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/procprop.h"
76 #include "libguile/root.h"
77 #include "libguile/smob.h"
78 #include "libguile/srcprop.h"
79 #include "libguile/stackchk.h"
80 #include "libguile/strings.h"
81 #include "libguile/throw.h"
82 #include "libguile/validate.h"
83 #include "libguile/values.h"
84 #include "libguile/vectors.h"
86 #include "libguile/eval.h"
90 static SCM
canonicalize_define (SCM expr
);
96 * This section defines the message strings for the syntax errors that can be
97 * detected during memoization and the functions and macros that shall be
98 * called by the memoizer code to signal syntax errors. */
101 /* Syntax errors that can be detected during memoization: */
103 /* Circular or improper lists do not form valid scheme expressions. If a
104 * circular list or an improper list is detected in a place where a scheme
105 * expression is expected, a 'Bad expression' error is signalled. */
106 static const char s_bad_expression
[] = "Bad expression";
108 /* If a form is detected that holds a different number of expressions than are
109 * required in that context, a 'Missing or extra expression' error is
111 static const char s_expression
[] = "Missing or extra expression in";
113 /* If a form is detected that holds less expressions than are required in that
114 * context, a 'Missing expression' error is signalled. */
115 static const char s_missing_expression
[] = "Missing expression in";
117 /* If a form is detected that holds more expressions than are allowed in that
118 * context, an 'Extra expression' error is signalled. */
119 static const char s_extra_expression
[] = "Extra expression in";
121 /* The empty combination '()' is not allowed as an expression in scheme. If
122 * it is detected in a place where an expression is expected, an 'Illegal
123 * empty combination' error is signalled. Note: If you encounter this error
124 * message, it is very likely that you intended to denote the empty list. To
125 * do so, you need to quote the empty list like (quote ()) or '(). */
126 static const char s_empty_combination
[] = "Illegal empty combination";
128 /* A body may hold an arbitrary number of internal defines, followed by a
129 * non-empty sequence of expressions. If a body with an empty sequence of
130 * expressions is detected, a 'Missing body expression' error is signalled.
132 static const char s_missing_body_expression
[] = "Missing body expression in";
134 /* A body may hold an arbitrary number of internal defines, followed by a
135 * non-empty sequence of expressions. Each the definitions and the
136 * expressions may be grouped arbitraryly with begin, but it is not allowed to
137 * mix definitions and expressions. If a define form in a body mixes
138 * definitions and expressions, a 'Mixed definitions and expressions' error is
140 static const char s_mixed_body_forms
[] = "Mixed definitions and expressions in";
141 /* Definitions are only allowed on the top level and at the start of a body.
142 * If a definition is detected anywhere else, a 'Bad define placement' error
144 static const char s_bad_define
[] = "Bad define placement";
146 /* Case or cond expressions must have at least one clause. If a case or cond
147 * expression without any clauses is detected, a 'Missing clauses' error is
149 static const char s_missing_clauses
[] = "Missing clauses";
151 /* If there is an 'else' clause in a case or a cond statement, it must be the
152 * last clause. If after the 'else' case clause further clauses are detected,
153 * a 'Misplaced else clause' error is signalled. */
154 static const char s_misplaced_else_clause
[] = "Misplaced else clause";
156 /* If a case clause is detected that is not in the format
157 * (<label(s)> <expression1> <expression2> ...)
158 * a 'Bad case clause' error is signalled. */
159 static const char s_bad_case_clause
[] = "Bad case clause";
161 /* If a case clause is detected where the <label(s)> element is neither a
162 * proper list nor (in case of the last clause) the syntactic keyword 'else',
163 * a 'Bad case labels' error is signalled. Note: If you encounter this error
164 * for an else-clause which seems to be syntactically correct, check if 'else'
165 * is really a syntactic keyword in that context. If 'else' is bound in the
166 * local or global environment, it is not considered a syntactic keyword, but
167 * will be treated as any other variable. */
168 static const char s_bad_case_labels
[] = "Bad case labels";
170 /* In a case statement all labels have to be distinct. If in a case statement
171 * a label occurs more than once, a 'Duplicate case label' error is
173 static const char s_duplicate_case_label
[] = "Duplicate case label";
175 /* If a cond clause is detected that is not in one of the formats
176 * (<test> <expression1> ...) or (else <expression1> <expression2> ...)
177 * a 'Bad cond clause' error is signalled. */
178 static const char s_bad_cond_clause
[] = "Bad cond clause";
180 /* If a cond clause is detected that uses the alternate '=>' form, but does
181 * not hold a recipient element for the test result, a 'Missing recipient'
182 * error is signalled. */
183 static const char s_missing_recipient
[] = "Missing recipient in";
185 /* If in a position where a variable name is required some other object is
186 * detected, a 'Bad variable' error is signalled. */
187 static const char s_bad_variable
[] = "Bad variable";
189 /* Bindings for forms like 'let' and 'do' have to be given in a proper,
190 * possibly empty list. If any other object is detected in a place where a
191 * list of bindings was required, a 'Bad bindings' error is signalled. */
192 static const char s_bad_bindings
[] = "Bad bindings";
194 /* Depending on the syntactic context, a binding has to be in the format
195 * (<variable> <expression>) or (<variable> <expression1> <expression2>).
196 * If anything else is detected in a place where a binding was expected, a
197 * 'Bad binding' error is signalled. */
198 static const char s_bad_binding
[] = "Bad binding";
200 /* Some syntactic forms don't allow variable names to appear more than once in
201 * a list of bindings. If such a situation is nevertheless detected, a
202 * 'Duplicate binding' error is signalled. */
203 static const char s_duplicate_binding
[] = "Duplicate binding";
205 /* If the exit form of a 'do' expression is not in the format
206 * (<test> <expression> ...)
207 * a 'Bad exit clause' error is signalled. */
208 static const char s_bad_exit_clause
[] = "Bad exit clause";
210 /* The formal function arguments of a lambda expression have to be either a
211 * single symbol or a non-cyclic list. For anything else a 'Bad formals'
212 * error is signalled. */
213 static const char s_bad_formals
[] = "Bad formals";
215 /* If in a lambda expression something else than a symbol is detected at a
216 * place where a formal function argument is required, a 'Bad formal' error is
218 static const char s_bad_formal
[] = "Bad formal";
220 /* If in the arguments list of a lambda expression an argument name occurs
221 * more than once, a 'Duplicate formal' error is signalled. */
222 static const char s_duplicate_formal
[] = "Duplicate formal";
224 /* If the evaluation of an unquote-splicing expression gives something else
225 * than a proper list, a 'Non-list result for unquote-splicing' error is
227 static const char s_splicing
[] = "Non-list result for unquote-splicing";
229 /* If something else than an exact integer is detected as the argument for
230 * @slot-ref and @slot-set!, a 'Bad slot number' error is signalled. */
231 static const char s_bad_slot_number
[] = "Bad slot number";
234 /* Signal a syntax error. We distinguish between the form that caused the
235 * error and the enclosing expression. The error message will print out as
236 * shown in the following pattern. The file name and line number are only
237 * given when they can be determined from the erroneous form or from the
238 * enclosing expression.
240 * <filename>: In procedure memoization:
241 * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
243 SCM_SYMBOL (syntax_error_key
, "syntax-error");
245 /* The prototype is needed to indicate that the function does not return. */
247 syntax_error (const char* const, const SCM
, const SCM
) SCM_NORETURN
;
250 syntax_error (const char* const msg
, const SCM form
, const SCM expr
)
252 const SCM msg_string
= scm_makfrom0str (msg
);
253 SCM filename
= SCM_BOOL_F
;
254 SCM linenr
= SCM_BOOL_F
;
258 if (SCM_CONSP (form
))
260 filename
= scm_source_property (form
, scm_sym_filename
);
261 linenr
= scm_source_property (form
, scm_sym_line
);
264 if (SCM_FALSEP (filename
) && SCM_FALSEP (linenr
) && SCM_CONSP (expr
))
266 filename
= scm_source_property (expr
, scm_sym_filename
);
267 linenr
= scm_source_property (expr
, scm_sym_line
);
270 if (!SCM_UNBNDP (expr
))
272 if (!SCM_FALSEP (filename
))
274 format
= "In file ~S, line ~S: ~A ~S in expression ~S.";
275 args
= scm_list_5 (filename
, linenr
, msg_string
, form
, expr
);
277 else if (!SCM_FALSEP (linenr
))
279 format
= "In line ~S: ~A ~S in expression ~S.";
280 args
= scm_list_4 (linenr
, msg_string
, form
, expr
);
284 format
= "~A ~S in expression ~S.";
285 args
= scm_list_3 (msg_string
, form
, expr
);
290 if (!SCM_FALSEP (filename
))
292 format
= "In file ~S, line ~S: ~A ~S.";
293 args
= scm_list_4 (filename
, linenr
, msg_string
, form
);
295 else if (!SCM_FALSEP (linenr
))
297 format
= "In line ~S: ~A ~S.";
298 args
= scm_list_3 (linenr
, msg_string
, form
);
303 args
= scm_list_2 (msg_string
, form
);
307 scm_error (syntax_error_key
, "memoization", format
, args
, SCM_BOOL_F
);
311 /* Shortcut macros to simplify syntax error handling. */
312 #define ASSERT_SYNTAX(cond, message, form) \
313 { if (!(cond)) syntax_error (message, form, SCM_UNDEFINED); }
314 #define ASSERT_SYNTAX_2(cond, message, form, expr) \
315 { if (!(cond)) syntax_error (message, form, expr); }
321 * Ilocs are memoized references to variables in local environment frames.
322 * They are represented as three values: The relative offset of the
323 * environment frame, the number of the binding within that frame, and a
324 * boolean value indicating whether the binding is the last binding in the
327 #define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc)
328 #define SCM_IDINC (0x00100000L)
329 #define SCM_IDSTMSK (-SCM_IDINC)
330 #define SCM_MAKE_ILOC(frame_nr, binding_nr, last_p) \
333 + ((binding_nr) << 20) \
334 + ((last_p) ? SCM_ICDR : 0) \
337 #if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
339 SCM
scm_dbg_make_iloc (SCM frame
, SCM binding
, SCM cdrp
);
340 SCM_DEFINE (scm_dbg_make_iloc
, "dbg-make-iloc", 3, 0, 0,
341 (SCM frame
, SCM binding
, SCM cdrp
),
342 "Return a new iloc with frame offset @var{frame}, binding\n"
343 "offset @var{binding} and the cdr flag @var{cdrp}.")
344 #define FUNC_NAME s_scm_dbg_make_iloc
346 SCM_VALIDATE_INUM (1, frame
);
347 SCM_VALIDATE_INUM (2, binding
);
348 return SCM_MAKE_ILOC (SCM_INUM (frame
),
354 SCM
scm_dbg_iloc_p (SCM obj
);
355 SCM_DEFINE (scm_dbg_iloc_p
, "dbg-iloc?", 1, 0, 0,
357 "Return @code{#t} if @var{obj} is an iloc.")
358 #define FUNC_NAME s_scm_dbg_iloc_p
360 return SCM_BOOL (SCM_ILOCP (obj
));
368 /* The function lookup_symbol is used during memoization: Lookup the symbol
369 * in the environment. If there is no binding for the symbol, SCM_UNDEFINED
370 * is returned. If the symbol is a syntactic keyword, the macro object to
371 * which the symbol is bound is returned. If the symbol is a global variable,
372 * the variable object to which the symbol is bound is returned. Finally, if
373 * the symbol is a local variable the corresponding iloc object is returned.
376 /* A helper function for lookup_symbol: Try to find the symbol in the top
377 * level environment frame. The function returns SCM_UNDEFINED if the symbol
378 * is unbound, it returns a macro object if the symbol is a syntactic keyword
379 * and it returns a variable object if the symbol is a global variable. */
381 lookup_global_symbol (const SCM symbol
, const SCM top_level
)
383 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
384 if (SCM_FALSEP (variable
))
386 return SCM_UNDEFINED
;
390 const SCM value
= SCM_VARIABLE_REF (variable
);
391 if (SCM_MACROP (value
))
399 lookup_symbol (const SCM symbol
, const SCM env
)
402 unsigned int frame_nr
;
404 for (frame_idx
= env
, frame_nr
= 0;
405 !SCM_NULLP (frame_idx
);
406 frame_idx
= SCM_CDR (frame_idx
), ++frame_nr
)
408 const SCM frame
= SCM_CAR (frame_idx
);
409 if (SCM_CONSP (frame
))
411 /* frame holds a local environment frame */
413 unsigned int symbol_nr
;
415 for (symbol_idx
= SCM_CAR (frame
), symbol_nr
= 0;
416 SCM_CONSP (symbol_idx
);
417 symbol_idx
= SCM_CDR (symbol_idx
), ++symbol_nr
)
419 if (SCM_EQ_P (SCM_CAR (symbol_idx
), symbol
))
420 /* found the symbol, therefore return the iloc */
421 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 0);
423 if (SCM_EQ_P (symbol_idx
, symbol
))
424 /* found the symbol as the last element of the current frame */
425 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 1);
429 /* no more local environment frames */
430 return lookup_global_symbol (symbol
, frame
);
434 return lookup_global_symbol (symbol
, SCM_BOOL_F
);
438 /* Return true if the symbol is - from the point of view of a macro
439 * transformer - a literal in the sense specified in chapter "pattern
440 * language" of R5RS. In the code below, however, we don't match the
441 * definition of R5RS exactly: It returns true if the identifier has no
442 * binding or if it is a syntactic keyword. */
444 literal_p (const SCM symbol
, const SCM env
)
446 const SCM value
= lookup_symbol (symbol
, env
);
447 if (SCM_UNBNDP (value
) || SCM_MACROP (value
))
454 /* Return true if the expression is self-quoting in the memoized code. Thus,
455 * some other objects (like e. g. vectors) are reported as self-quoting, which
456 * according to R5RS would need to be quoted. */
458 is_self_quoting_p (const SCM expr
)
460 if (SCM_CONSP (expr
))
462 else if (SCM_SYMBOLP (expr
))
464 else if (SCM_NULLP (expr
))
471 /* Lookup a given local variable in an environment. The local variable is
472 * given as an iloc, that is a triple <frame, binding, last?>, where frame
473 * indicates the relative number of the environment frame (counting upwards
474 * from the innermost environment frame), binding indicates the number of the
475 * binding within the frame, and last? (which is extracted from the iloc using
476 * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
477 * very end of the improper list of bindings. */
479 scm_ilookup (SCM iloc
, SCM env
)
481 unsigned int frame_nr
= SCM_IFRAME (iloc
);
482 unsigned int binding_nr
= SCM_IDIST (iloc
);
486 for (; 0 != frame_nr
; --frame_nr
)
487 frames
= SCM_CDR (frames
);
489 bindings
= SCM_CAR (frames
);
490 for (; 0 != binding_nr
; --binding_nr
)
491 bindings
= SCM_CDR (bindings
);
493 if (SCM_ICDRP (iloc
))
494 return SCM_CDRLOC (bindings
);
495 return SCM_CARLOC (SCM_CDR (bindings
));
499 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
501 static void error_unbound_variable (SCM symbol
) SCM_NORETURN
;
503 error_unbound_variable (SCM symbol
)
505 scm_error (scm_unbound_variable_key
, NULL
,
506 "Unbound variable: ~S",
507 scm_list_1 (symbol
), SCM_BOOL_F
);
511 /* The Lookup Car Race
514 Memoization of variables and special forms is done while executing
515 the code for the first time. As long as there is only one thread
516 everything is fine, but as soon as two threads execute the same
517 code concurrently `for the first time' they can come into conflict.
519 This memoization includes rewriting variable references into more
520 efficient forms and expanding macros. Furthermore, macro expansion
521 includes `compiling' special forms like `let', `cond', etc. into
522 tree-code instructions.
524 There shouldn't normally be a problem with memoizing local and
525 global variable references (into ilocs and variables), because all
526 threads will mutate the code in *exactly* the same way and (if I
527 read the C code correctly) it is not possible to observe a half-way
528 mutated cons cell. The lookup procedure can handle this
529 transparently without any critical sections.
531 It is different with macro expansion, because macro expansion
532 happens outside of the lookup procedure and can't be
533 undone. Therefore the lookup procedure can't cope with it. It has
534 to indicate failure when it detects a lost race and hope that the
535 caller can handle it. Luckily, it turns out that this is the case.
537 An example to illustrate this: Suppose that the following form will
538 be memoized concurrently by two threads
542 Let's first examine the lookup of X in the body. The first thread
543 decides that it has to find the symbol "x" in the environment and
544 starts to scan it. Then the other thread takes over and actually
545 overtakes the first. It looks up "x" and substitutes an
546 appropriate iloc for it. Now the first thread continues and
547 completes its lookup. It comes to exactly the same conclusions as
548 the second one and could - without much ado - just overwrite the
549 iloc with the same iloc.
551 But let's see what will happen when the race occurs while looking
552 up the symbol "let" at the start of the form. It could happen that
553 the second thread interrupts the lookup of the first thread and not
554 only substitutes a variable for it but goes right ahead and
555 replaces it with the compiled form (#@let* (x 12) x). Now, when
556 the first thread completes its lookup, it would replace the #@let*
557 with a variable containing the "let" binding, effectively reverting
558 the form to (let (x 12) x). This is wrong. It has to detect that
559 it has lost the race and the evaluator has to reconsider the
560 changed form completely.
562 This race condition could be resolved with some kind of traffic
563 light (like mutexes) around scm_lookupcar, but I think that it is
564 best to avoid them in this case. They would serialize memoization
565 completely and because lookup involves calling arbitrary Scheme
566 code (via the lookup-thunk), threads could be blocked for an
567 arbitrary amount of time or even deadlock. But with the current
568 solution a lot of unnecessary work is potentially done. */
570 /* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
571 return NULL to indicate a failed lookup due to some race conditions
572 between threads. This only happens when VLOC is the first cell of
573 a special form that will eventually be memoized (like `let', etc.)
574 In that case the whole lookup is bogus and the caller has to
575 reconsider the complete special form.
577 SCM_LOOKUPCAR is still there, of course. It just calls
578 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
579 should only be called when it is known that VLOC is not the first
580 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
581 for NULL. I think I've found the only places where this
585 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
588 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
589 register SCM iloc
= SCM_ILOC00
;
590 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
592 if (!SCM_CONSP (SCM_CAR (env
)))
594 al
= SCM_CARLOC (env
);
595 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
599 if (SCM_EQ_P (fl
, var
))
601 if (! SCM_EQ_P (SCM_CAR (vloc
), var
))
603 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
604 return SCM_CDRLOC (*al
);
609 al
= SCM_CDRLOC (*al
);
610 if (SCM_EQ_P (SCM_CAR (fl
), var
))
612 if (SCM_UNBNDP (SCM_CAR (*al
)))
617 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
619 SCM_SETCAR (vloc
, iloc
);
620 return SCM_CARLOC (*al
);
622 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
624 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
627 SCM top_thunk
, real_var
;
630 top_thunk
= SCM_CAR (env
); /* env now refers to a
631 top level env thunk */
635 top_thunk
= SCM_BOOL_F
;
636 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
637 if (SCM_FALSEP (real_var
))
640 if (!SCM_NULLP (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
646 error_unbound_variable (var
);
648 scm_misc_error (NULL
, "Damaged environment: ~S",
653 /* A variable could not be found, but we shall
654 not throw an error. */
655 static SCM undef_object
= SCM_UNDEFINED
;
656 return &undef_object
;
660 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
662 /* Some other thread has changed the very cell we are working
663 on. In effect, it must have done our job or messed it up
666 var
= SCM_CAR (vloc
);
667 if (SCM_VARIABLEP (var
))
668 return SCM_VARIABLE_LOC (var
);
670 return scm_ilookup (var
, genv
);
671 /* We can't cope with anything else than variables and ilocs. When
672 a special form has been memoized (i.e. `let' into `#@let') we
673 return NULL and expect the calling function to do the right
674 thing. For the evaluator, this means going back and redoing
675 the dispatch on the car of the form. */
679 SCM_SETCAR (vloc
, real_var
);
680 return SCM_VARIABLE_LOC (real_var
);
685 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
687 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
695 /* Rewrite the body (which is given as the list of expressions forming the
696 * body) into its internal form. The internal form of a body (<expr> ...) is
697 * just the body itself, but prefixed with an ISYM that denotes to what kind
698 * of outer construct this body belongs: (<ISYM> <expr> ...). A lambda body
699 * starts with SCM_IM_LAMBDA, for example, a body of a let starts with
702 * It is assumed that the calling expression has already made sure that the
703 * body is a proper list. */
705 m_body (SCM op
, SCM exprs
)
707 /* Don't add another ISYM if one is present already. */
708 if (SCM_ISYMP (SCM_CAR (exprs
)))
711 return scm_cons (op
, exprs
);
715 /* The function m_expand_body memoizes a proper list of expressions
716 * forming a body. This function takes care of dealing with internal
717 * defines and transforming them into an equivalent letrec expression.
718 * The list of expressions is rewritten in place. */
720 /* This is a helper function for m_expand_body. It helps to figure out whether
721 * an expression denotes a syntactic keyword. */
723 try_macro_lookup (const SCM expr
, const SCM env
)
725 if (SCM_SYMBOLP (expr
))
727 const SCM value
= lookup_symbol (expr
, env
);
732 return SCM_UNDEFINED
;
736 /* This is a helper function for m_expand_body. It expands user macros,
737 * because for the correct translation of a body we need to know whether they
738 * expand to a definition. */
740 expand_user_macros (SCM expr
, const SCM env
)
742 while (SCM_CONSP (expr
))
744 const SCM car_expr
= SCM_CAR (expr
);
745 const SCM new_car
= expand_user_macros (car_expr
, env
);
746 const SCM value
= try_macro_lookup (new_car
, env
);
748 if (SCM_MACROP (value
) && SCM_MACRO_TYPE (value
) == 2)
750 /* User macros transform code into code. */
751 expr
= scm_call_2 (SCM_MACRO_CODE (value
), expr
, env
);
752 /* We need to reiterate on the transformed code. */
756 /* No user macro: return. */
757 SCM_SETCAR (expr
, new_car
);
765 /* This is a helper function for m_expand_body. It determines if a given form
766 * represents an application of a given built-in macro. The built-in macro to
767 * check for is identified by its syntactic keyword. The form is an
768 * application of the given macro if looking up the car of the form in the
769 * given environment actually returns the built-in macro. */
771 is_system_macro_p (const SCM syntactic_keyword
, const SCM form
, const SCM env
)
773 if (SCM_CONSP (form
))
775 const SCM car_form
= SCM_CAR (form
);
776 const SCM value
= try_macro_lookup (car_form
, env
);
777 if (SCM_BUILTIN_MACRO_P (value
))
779 const SCM macro_name
= scm_macro_name (value
);
780 return SCM_EQ_P (macro_name
, syntactic_keyword
);
788 m_expand_body (const SCM forms
, const SCM env
)
790 /* The first body form can be skipped since it is known to be the ISYM that
791 * was prepended to the body by m_body. */
792 SCM cdr_forms
= SCM_CDR (forms
);
793 SCM form_idx
= cdr_forms
;
794 SCM definitions
= SCM_EOL
;
795 SCM sequence
= SCM_EOL
;
797 /* According to R5RS, the list of body forms consists of two parts: a number
798 * (maybe zero) of definitions, followed by a non-empty sequence of
799 * expressions. Each the definitions and the expressions may be grouped
800 * arbitrarily with begin, but it is not allowed to mix definitions and
801 * expressions. The task of the following loop therefore is to split the
802 * list of body forms into the list of definitions and the sequence of
804 while (!SCM_NULLP (form_idx
))
806 const SCM form
= SCM_CAR (form_idx
);
807 const SCM new_form
= expand_user_macros (form
, env
);
808 if (is_system_macro_p (scm_sym_define
, new_form
, env
))
810 definitions
= scm_cons (new_form
, definitions
);
811 form_idx
= SCM_CDR (form_idx
);
813 else if (is_system_macro_p (scm_sym_begin
, new_form
, env
))
815 /* We have encountered a group of forms. This has to be either a
816 * (possibly empty) group of (possibly further grouped) definitions,
817 * or a non-empty group of (possibly further grouped)
819 const SCM grouped_forms
= SCM_CDR (new_form
);
820 unsigned int found_definition
= 0;
821 unsigned int found_expression
= 0;
822 SCM grouped_form_idx
= grouped_forms
;
823 while (!found_expression
&& !SCM_NULLP (grouped_form_idx
))
825 const SCM inner_form
= SCM_CAR (grouped_form_idx
);
826 const SCM new_inner_form
= expand_user_macros (inner_form
, env
);
827 if (is_system_macro_p (scm_sym_define
, new_inner_form
, env
))
829 found_definition
= 1;
830 definitions
= scm_cons (new_inner_form
, definitions
);
831 grouped_form_idx
= SCM_CDR (grouped_form_idx
);
833 else if (is_system_macro_p (scm_sym_begin
, new_inner_form
, env
))
835 const SCM inner_group
= SCM_CDR (new_inner_form
);
837 = scm_append (scm_list_2 (inner_group
,
838 SCM_CDR (grouped_form_idx
)));
842 /* The group marks the start of the expressions of the body.
843 * We have to make sure that within the same group we have
844 * not encountered a definition before. */
845 ASSERT_SYNTAX (!found_definition
, s_mixed_body_forms
, form
);
846 found_expression
= 1;
847 grouped_form_idx
= SCM_EOL
;
851 /* We have finished processing the group. If we have not yet
852 * encountered an expression we continue processing the forms of the
853 * body to collect further definition forms. Otherwise, the group
854 * marks the start of the sequence of expressions of the body. */
855 if (!found_expression
)
857 form_idx
= SCM_CDR (form_idx
);
867 /* We have detected a form which is no definition. This marks the
868 * start of the sequence of expressions of the body. */
874 /* FIXME: forms does not hold information about the file location. */
875 ASSERT_SYNTAX (SCM_CONSP (sequence
), s_missing_body_expression
, cdr_forms
);
877 if (!SCM_NULLP (definitions
))
881 SCM letrec_expression
;
882 SCM new_letrec_expression
;
884 SCM bindings
= SCM_EOL
;
885 for (definition_idx
= definitions
;
886 !SCM_NULLP (definition_idx
);
887 definition_idx
= SCM_CDR (definition_idx
))
889 const SCM definition
= SCM_CAR (definition_idx
);
890 const SCM canonical_definition
= canonicalize_define (definition
);
891 const SCM binding
= SCM_CDR (canonical_definition
);
892 bindings
= scm_cons (binding
, bindings
);
895 letrec_tail
= scm_cons (bindings
, sequence
);
896 /* FIXME: forms does not hold information about the file location. */
897 letrec_expression
= scm_cons_source (forms
, scm_sym_letrec
, letrec_tail
);
898 new_letrec_expression
= scm_m_letrec (letrec_expression
, env
);
899 SCM_SETCAR (forms
, new_letrec_expression
);
900 SCM_SETCDR (forms
, SCM_EOL
);
904 SCM_SETCAR (forms
, SCM_CAR (sequence
));
905 SCM_SETCDR (forms
, SCM_CDR (sequence
));
910 /* Start of the memoizers for the standard R5RS builtin macros. */
913 SCM_SYNTAX (s_and
, "and", scm_i_makbimacro
, scm_m_and
);
914 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
917 scm_m_and (SCM expr
, SCM env SCM_UNUSED
)
919 const SCM cdr_expr
= SCM_CDR (expr
);
920 const long length
= scm_ilength (cdr_expr
);
922 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
926 /* Special case: (and) is replaced by #t. */
931 SCM_SETCAR (expr
, SCM_IM_AND
);
937 SCM_SYNTAX (s_begin
, "begin", scm_i_makbimacro
, scm_m_begin
);
938 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
941 scm_m_begin (SCM expr
, SCM env SCM_UNUSED
)
943 const SCM cdr_expr
= SCM_CDR (expr
);
944 /* Dirk:FIXME:: An empty begin clause is not generally allowed by R5RS.
945 * That means, there should be a distinction between uses of begin where an
946 * empty clause is OK and where it is not. */
947 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
949 SCM_SETCAR (expr
, SCM_IM_BEGIN
);
954 SCM_SYNTAX (s_case
, "case", scm_i_makbimacro
, scm_m_case
);
955 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
956 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
959 scm_m_case (SCM expr
, SCM env
)
962 SCM all_labels
= SCM_EOL
;
964 /* Check, whether 'else is a literal, i. e. not bound to a value. */
965 const int else_literal_p
= literal_p (scm_sym_else
, env
);
967 const SCM cdr_expr
= SCM_CDR (expr
);
968 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
969 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_clauses
, expr
);
971 clauses
= SCM_CDR (cdr_expr
);
972 while (!SCM_NULLP (clauses
))
976 const SCM clause
= SCM_CAR (clauses
);
977 ASSERT_SYNTAX_2 (scm_ilength (clause
) >= 2,
978 s_bad_case_clause
, clause
, expr
);
980 labels
= SCM_CAR (clause
);
981 if (SCM_CONSP (labels
))
983 ASSERT_SYNTAX_2 (scm_ilength (labels
) >= 0,
984 s_bad_case_labels
, labels
, expr
);
985 all_labels
= scm_append_x (scm_list_2 (labels
, all_labels
));
987 else if (SCM_NULLP (labels
))
989 /* The list of labels is empty. According to R5RS this is allowed.
990 * It means that the sequence of expressions will never be executed.
991 * Therefore, as an optimization, we could remove the whole
996 ASSERT_SYNTAX_2 (SCM_EQ_P (labels
, scm_sym_else
) && else_literal_p
,
997 s_bad_case_labels
, labels
, expr
);
998 ASSERT_SYNTAX_2 (SCM_NULLP (SCM_CDR (clauses
)),
999 s_misplaced_else_clause
, clause
, expr
);
1002 /* build the new clause */
1003 if (SCM_EQ_P (labels
, scm_sym_else
))
1004 SCM_SETCAR (clause
, SCM_IM_ELSE
);
1006 clauses
= SCM_CDR (clauses
);
1009 /* Check whether all case labels are distinct. */
1010 for (; !SCM_NULLP (all_labels
); all_labels
= SCM_CDR (all_labels
))
1012 const SCM label
= SCM_CAR (all_labels
);
1013 ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (label
, SCM_CDR (all_labels
))),
1014 s_duplicate_case_label
, label
, expr
);
1017 SCM_SETCAR (expr
, SCM_IM_CASE
);
1022 SCM_SYNTAX (s_cond
, "cond", scm_i_makbimacro
, scm_m_cond
);
1023 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
1024 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
1027 scm_m_cond (SCM expr
, SCM env
)
1029 /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
1030 const int else_literal_p
= literal_p (scm_sym_else
, env
);
1031 const int arrow_literal_p
= literal_p (scm_sym_arrow
, env
);
1033 const SCM clauses
= SCM_CDR (expr
);
1036 ASSERT_SYNTAX (scm_ilength (clauses
) >= 0, s_bad_expression
, expr
);
1037 ASSERT_SYNTAX (scm_ilength (clauses
) >= 1, s_missing_clauses
, expr
);
1039 for (clause_idx
= clauses
;
1040 !SCM_NULLP (clause_idx
);
1041 clause_idx
= SCM_CDR (clause_idx
))
1045 const SCM clause
= SCM_CAR (clause_idx
);
1046 const long length
= scm_ilength (clause
);
1047 ASSERT_SYNTAX_2 (length
>= 1, s_bad_cond_clause
, clause
, expr
);
1049 test
= SCM_CAR (clause
);
1050 if (SCM_EQ_P (test
, scm_sym_else
) && else_literal_p
)
1052 const int last_clause_p
= SCM_NULLP (SCM_CDR (clause_idx
));
1053 ASSERT_SYNTAX_2 (length
>= 2,
1054 s_bad_cond_clause
, clause
, expr
);
1055 ASSERT_SYNTAX_2 (last_clause_p
,
1056 s_misplaced_else_clause
, clause
, expr
);
1057 SCM_SETCAR (clause
, SCM_IM_ELSE
);
1059 else if (length
>= 2
1060 && SCM_EQ_P (SCM_CADR (clause
), scm_sym_arrow
)
1063 ASSERT_SYNTAX_2 (length
> 2, s_missing_recipient
, clause
, expr
);
1064 ASSERT_SYNTAX_2 (length
== 3, s_extra_expression
, clause
, expr
);
1065 SCM_SETCAR (SCM_CDR (clause
), SCM_IM_ARROW
);
1069 SCM_SETCAR (expr
, SCM_IM_COND
);
1074 SCM_SYNTAX (s_define
, "define", scm_i_makbimacro
, scm_m_define
);
1075 SCM_GLOBAL_SYMBOL (scm_sym_define
, s_define
);
1077 /* Guile provides an extension to R5RS' define syntax to represent function
1078 * currying in a compact way. With this extension, it is allowed to write
1079 * (define <nested-variable> <body>), where <nested-variable> has of one of
1080 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
1081 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
1082 * should be either a sequence of zero or more variables, or a sequence of one
1083 * or more variables followed by a space-delimited period and another
1084 * variable. Each level of argument nesting wraps the <body> within another
1085 * lambda expression. For example, the following forms are allowed, each one
1086 * followed by an equivalent, more explicit implementation.
1088 * (define ((a b . c) . d) <body>) is equivalent to
1089 * (define a (lambda (b . c) (lambda d <body>)))
1091 * (define (((a) b) c . d) <body>) is equivalent to
1092 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
1094 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
1095 * module that does not implement this extension. */
1097 canonicalize_define (const SCM expr
)
1102 const SCM cdr_expr
= SCM_CDR (expr
);
1103 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1104 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1106 body
= SCM_CDR (cdr_expr
);
1107 variable
= SCM_CAR (cdr_expr
);
1108 while (SCM_CONSP (variable
))
1110 /* This while loop realizes function currying by variable nesting.
1111 * Variable is known to be a nested-variable. In every iteration of the
1112 * loop another level of lambda expression is created, starting with the
1113 * innermost one. Note that we don't check for duplicate formals here:
1114 * This will be done by the memoizer of the lambda expression. */
1115 const SCM formals
= SCM_CDR (variable
);
1116 const SCM tail
= scm_cons (formals
, body
);
1118 /* Add source properties to each new lambda expression: */
1119 const SCM lambda
= scm_cons_source (variable
, scm_sym_lambda
, tail
);
1121 body
= scm_list_1 (lambda
);
1122 variable
= SCM_CAR (variable
);
1124 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
), s_bad_variable
, variable
, expr
);
1125 ASSERT_SYNTAX (scm_ilength (body
) == 1, s_expression
, expr
);
1127 SCM_SETCAR (cdr_expr
, variable
);
1128 SCM_SETCDR (cdr_expr
, body
);
1133 scm_m_define (SCM expr
, SCM env
)
1135 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), s_bad_define
, expr
);
1138 const SCM canonical_definition
= canonicalize_define (expr
);
1139 const SCM cdr_canonical_definition
= SCM_CDR (canonical_definition
);
1140 const SCM variable
= SCM_CAR (cdr_canonical_definition
);
1141 const SCM body
= SCM_CDR (cdr_canonical_definition
);
1142 const SCM value
= scm_eval_car (body
, env
);
1145 if (SCM_REC_PROCNAMES_P
)
1148 while (SCM_MACROP (tmp
))
1149 tmp
= SCM_MACRO_CODE (tmp
);
1150 if (SCM_CLOSUREP (tmp
)
1151 /* Only the first definition determines the name. */
1152 && SCM_FALSEP (scm_procedure_property (tmp
, scm_sym_name
)))
1153 scm_set_procedure_property_x (tmp
, scm_sym_name
, variable
);
1156 var
= scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_T
);
1157 SCM_VARIABLE_SET (var
, value
);
1159 return SCM_UNSPECIFIED
;
1164 /* This is a helper function for forms (<keyword> <expression>) that are
1165 * transformed into (#@<keyword> '() <memoized_expression>) in order to allow
1166 * for easy creation of a thunk (i. e. a closure without arguments) using the
1167 * ('() <memoized_expression>) tail of the memoized form. */
1169 memoize_as_thunk_prototype (const SCM expr
, const SCM env SCM_UNUSED
)
1171 const SCM cdr_expr
= SCM_CDR (expr
);
1172 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1173 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1175 SCM_SETCDR (expr
, scm_cons (SCM_EOL
, cdr_expr
));
1181 SCM_SYNTAX (s_delay
, "delay", scm_i_makbimacro
, scm_m_delay
);
1182 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
1184 /* Promises are implemented as closures with an empty parameter list. Thus,
1185 * (delay <expression>) is transformed into (#@delay '() <expression>), where
1186 * the empty list represents the empty parameter list. This representation
1187 * allows for easy creation of the closure during evaluation. */
1189 scm_m_delay (SCM expr
, SCM env
)
1191 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1192 SCM_SETCAR (new_expr
, SCM_IM_DELAY
);
1197 SCM_SYNTAX(s_do
, "do", scm_i_makbimacro
, scm_m_do
);
1198 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
1200 /* DO gets the most radically altered syntax. The order of the vars is
1201 * reversed here. During the evaluation this allows for simple consing of the
1202 * results of the inits and steps:
1204 (do ((<var1> <init1> <step1>)
1212 (#@do (<init1> <init2> ... <initn>)
1213 (varn ... var2 var1)
1216 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
1219 scm_m_do (SCM expr
, SCM env SCM_UNUSED
)
1221 SCM variables
= SCM_EOL
;
1222 SCM init_forms
= SCM_EOL
;
1223 SCM step_forms
= SCM_EOL
;
1230 const SCM cdr_expr
= SCM_CDR (expr
);
1231 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1232 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1234 /* Collect variables, init and step forms. */
1235 binding_idx
= SCM_CAR (cdr_expr
);
1236 ASSERT_SYNTAX_2 (scm_ilength (binding_idx
) >= 0,
1237 s_bad_bindings
, binding_idx
, expr
);
1238 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1240 const SCM binding
= SCM_CAR (binding_idx
);
1241 const long length
= scm_ilength (binding
);
1242 ASSERT_SYNTAX_2 (length
== 2 || length
== 3,
1243 s_bad_binding
, binding
, expr
);
1246 const SCM name
= SCM_CAR (binding
);
1247 const SCM init
= SCM_CADR (binding
);
1248 const SCM step
= (length
== 2) ? name
: SCM_CADDR (binding
);
1249 ASSERT_SYNTAX_2 (SCM_SYMBOLP (name
), s_bad_variable
, name
, expr
);
1250 ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (name
, variables
)),
1251 s_duplicate_binding
, name
, expr
);
1253 variables
= scm_cons (name
, variables
);
1254 init_forms
= scm_cons (init
, init_forms
);
1255 step_forms
= scm_cons (step
, step_forms
);
1258 init_forms
= scm_reverse_x (init_forms
, SCM_UNDEFINED
);
1259 step_forms
= scm_reverse_x (step_forms
, SCM_UNDEFINED
);
1261 /* Memoize the test form and the exit sequence. */
1262 cddr_expr
= SCM_CDR (cdr_expr
);
1263 exit_clause
= SCM_CAR (cddr_expr
);
1264 ASSERT_SYNTAX_2 (scm_ilength (exit_clause
) >= 1,
1265 s_bad_exit_clause
, exit_clause
, expr
);
1267 commands
= SCM_CDR (cddr_expr
);
1268 tail
= scm_cons2 (exit_clause
, commands
, step_forms
);
1269 tail
= scm_cons2 (init_forms
, variables
, tail
);
1270 SCM_SETCAR (expr
, SCM_IM_DO
);
1271 SCM_SETCDR (expr
, tail
);
1276 SCM_SYNTAX (s_if
, "if", scm_i_makbimacro
, scm_m_if
);
1277 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
1280 scm_m_if (SCM expr
, SCM env SCM_UNUSED
)
1282 const SCM cdr_expr
= SCM_CDR (expr
);
1283 const long length
= scm_ilength (cdr_expr
);
1284 ASSERT_SYNTAX (length
== 2 || length
== 3, s_expression
, expr
);
1285 SCM_SETCAR (expr
, SCM_IM_IF
);
1290 SCM_SYNTAX (s_lambda
, "lambda", scm_i_makbimacro
, scm_m_lambda
);
1291 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
1293 /* A helper function for memoize_lambda to support checking for duplicate
1294 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
1295 * LIST or to the cdr of the last cons. Therefore, LIST may have any of the
1296 * forms that a formal argument can have:
1297 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
1299 c_improper_memq (SCM obj
, SCM list
)
1301 for (; SCM_CONSP (list
); list
= SCM_CDR (list
))
1303 if (SCM_EQ_P (SCM_CAR (list
), obj
))
1306 return SCM_EQ_P (list
, obj
);
1310 scm_m_lambda (SCM expr
, SCM env SCM_UNUSED
)
1319 const SCM cdr_expr
= SCM_CDR (expr
);
1320 const long length
= scm_ilength (cdr_expr
);
1321 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1322 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1324 /* Before iterating the list of formal arguments, make sure the formals
1325 * actually are given as either a symbol or a non-cyclic list. */
1326 formals
= SCM_CAR (cdr_expr
);
1327 if (SCM_CONSP (formals
))
1329 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
1330 * detected, report a 'Bad formals' error. */
1334 ASSERT_SYNTAX_2 (SCM_SYMBOLP (formals
) || SCM_NULLP (formals
),
1335 s_bad_formals
, formals
, expr
);
1338 /* Now iterate the list of formal arguments to check if all formals are
1339 * symbols, and that there are no duplicates. */
1340 formals_idx
= formals
;
1341 while (SCM_CONSP (formals_idx
))
1343 const SCM formal
= SCM_CAR (formals_idx
);
1344 const SCM next_idx
= SCM_CDR (formals_idx
);
1345 ASSERT_SYNTAX_2 (SCM_SYMBOLP (formal
), s_bad_formal
, formal
, expr
);
1346 ASSERT_SYNTAX_2 (!c_improper_memq (formal
, next_idx
),
1347 s_duplicate_formal
, formal
, expr
);
1348 formals_idx
= next_idx
;
1350 ASSERT_SYNTAX_2 (SCM_NULLP (formals_idx
) || SCM_SYMBOLP (formals_idx
),
1351 s_bad_formal
, formals_idx
, expr
);
1353 /* Memoize the body. Keep a potential documentation string. */
1354 /* Dirk:FIXME:: We should probably extract the documentation string to
1355 * some external database. Otherwise it will slow down execution, since
1356 * the documentation string will have to be skipped with every execution
1357 * of the closure. */
1358 cddr_expr
= SCM_CDR (cdr_expr
);
1359 documentation
= (length
>= 3 && SCM_STRINGP (SCM_CAR (cddr_expr
)));
1360 body
= documentation
? SCM_CDR (cddr_expr
) : cddr_expr
;
1361 new_body
= m_body (SCM_IM_LAMBDA
, body
);
1363 SCM_SETCAR (expr
, SCM_IM_LAMBDA
);
1365 SCM_SETCDR (cddr_expr
, new_body
);
1367 SCM_SETCDR (cdr_expr
, new_body
);
1372 /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
1374 check_bindings (const SCM bindings
, const SCM expr
)
1378 ASSERT_SYNTAX_2 (scm_ilength (bindings
) >= 0,
1379 s_bad_bindings
, bindings
, expr
);
1381 binding_idx
= bindings
;
1382 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1384 SCM name
; /* const */
1386 const SCM binding
= SCM_CAR (binding_idx
);
1387 ASSERT_SYNTAX_2 (scm_ilength (binding
) == 2,
1388 s_bad_binding
, binding
, expr
);
1390 name
= SCM_CAR (binding
);
1391 ASSERT_SYNTAX_2 (SCM_SYMBOLP (name
), s_bad_variable
, name
, expr
);
1396 /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
1397 * transformed to the lists (vn ... v2 v1) and (i1 i2 ... in). That is, the
1398 * variables are returned in a list with their order reversed, and the init
1399 * forms are returned in a list in the same order as they are given in the
1400 * bindings. If a duplicate variable name is detected, an error is
1403 transform_bindings (
1404 const SCM bindings
, const SCM expr
,
1405 SCM
*const rvarptr
, SCM
*const initptr
)
1407 SCM rvariables
= SCM_EOL
;
1408 SCM rinits
= SCM_EOL
;
1409 SCM binding_idx
= bindings
;
1410 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1412 const SCM binding
= SCM_CAR (binding_idx
);
1413 const SCM cdr_binding
= SCM_CDR (binding
);
1414 const SCM name
= SCM_CAR (binding
);
1415 ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (name
, rvariables
)),
1416 s_duplicate_binding
, name
, expr
);
1417 rvariables
= scm_cons (name
, rvariables
);
1418 rinits
= scm_cons (SCM_CAR (cdr_binding
), rinits
);
1420 *rvarptr
= rvariables
;
1421 *initptr
= scm_reverse_x (rinits
, SCM_UNDEFINED
);
1425 SCM_SYNTAX(s_let
, "let", scm_i_makbimacro
, scm_m_let
);
1426 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
1428 /* This function is a helper function for memoize_let. It transforms
1429 * (let name ((var init) ...) body ...) into
1430 * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
1431 * and memoizes the expression. It is assumed that the caller has checked
1432 * that name is a symbol and that there are bindings and a body. */
1434 memoize_named_let (const SCM expr
, const SCM env SCM_UNUSED
)
1440 const SCM cdr_expr
= SCM_CDR (expr
);
1441 const SCM name
= SCM_CAR (cdr_expr
);
1442 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1443 const SCM bindings
= SCM_CAR (cddr_expr
);
1444 check_bindings (bindings
, expr
);
1446 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1447 variables
= scm_reverse_x (rvariables
, SCM_UNDEFINED
);
1450 const SCM let_body
= SCM_CDR (cddr_expr
);
1451 const SCM lambda_body
= m_body (SCM_IM_LET
, let_body
);
1452 const SCM lambda_tail
= scm_cons (variables
, lambda_body
);
1453 const SCM lambda_form
= scm_cons_source (expr
, scm_sym_lambda
, lambda_tail
);
1455 const SCM rvar
= scm_list_1 (name
);
1456 const SCM init
= scm_list_1 (lambda_form
);
1457 const SCM body
= m_body (SCM_IM_LET
, scm_list_1 (name
));
1458 const SCM letrec_tail
= scm_cons (rvar
, scm_cons (init
, body
));
1459 const SCM letrec_form
= scm_cons_source (expr
, SCM_IM_LETREC
, letrec_tail
);
1460 return scm_cons_source (expr
, letrec_form
, inits
);
1464 /* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1465 * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
1467 scm_m_let (SCM expr
, SCM env
)
1471 const SCM cdr_expr
= SCM_CDR (expr
);
1472 const long length
= scm_ilength (cdr_expr
);
1473 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1474 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1476 bindings
= SCM_CAR (cdr_expr
);
1477 if (SCM_SYMBOLP (bindings
))
1479 ASSERT_SYNTAX (length
>= 3, s_missing_expression
, expr
);
1480 return memoize_named_let (expr
, env
);
1483 check_bindings (bindings
, expr
);
1484 if (SCM_NULLP (bindings
) || SCM_NULLP (SCM_CDR (bindings
)))
1486 /* Special case: no bindings or single binding => let* is faster. */
1487 const SCM body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1488 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), bindings
, body
), env
);
1495 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1498 const SCM new_body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1499 const SCM new_tail
= scm_cons2 (rvariables
, inits
, new_body
);
1500 SCM_SETCAR (expr
, SCM_IM_LET
);
1501 SCM_SETCDR (expr
, new_tail
);
1508 SCM_SYNTAX (s_letstar
, "let*", scm_i_makbimacro
, scm_m_letstar
);
1509 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
1511 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1512 * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
1514 scm_m_letstar (SCM expr
, SCM env SCM_UNUSED
)
1519 const SCM cdr_expr
= SCM_CDR (expr
);
1520 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1521 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1523 binding_idx
= SCM_CAR (cdr_expr
);
1524 check_bindings (binding_idx
, expr
);
1526 /* Transform ((v1 i1) (v2 i2) ...) into (v1 i1 v2 i2 ...). The
1527 * transformation is done in place. At the beginning of one iteration of
1528 * the loop the variable binding_idx holds the form
1529 * P1:( (vn . P2:(in . ())) . P3:( (vn+1 in+1) ... ) ),
1530 * where P1, P2 and P3 indicate the pairs, that are relevant for the
1531 * transformation. P1 and P2 are modified in the loop, P3 remains
1532 * untouched. After the execution of the loop, P1 will hold
1533 * P1:( vn . P2:(in . P3:( (vn+1 in+1) ... )) )
1534 * and binding_idx will hold P3. */
1535 while (!SCM_NULLP (binding_idx
))
1537 const SCM cdr_binding_idx
= SCM_CDR (binding_idx
); /* remember P3 */
1538 const SCM binding
= SCM_CAR (binding_idx
);
1539 const SCM name
= SCM_CAR (binding
);
1540 const SCM cdr_binding
= SCM_CDR (binding
);
1542 SCM_SETCDR (cdr_binding
, cdr_binding_idx
); /* update P2 */
1543 SCM_SETCAR (binding_idx
, name
); /* update P1 */
1544 SCM_SETCDR (binding_idx
, cdr_binding
); /* update P1 */
1546 binding_idx
= cdr_binding_idx
; /* continue with P3 */
1549 new_body
= m_body (SCM_IM_LETSTAR
, SCM_CDR (cdr_expr
));
1550 SCM_SETCAR (expr
, SCM_IM_LETSTAR
);
1551 /* the bindings have been changed in place */
1552 SCM_SETCDR (cdr_expr
, new_body
);
1557 SCM_SYNTAX(s_letrec
, "letrec", scm_i_makbimacro
, scm_m_letrec
);
1558 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
1561 scm_m_letrec (SCM expr
, SCM env
)
1565 const SCM cdr_expr
= SCM_CDR (expr
);
1566 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1567 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1569 bindings
= SCM_CAR (cdr_expr
);
1570 if (SCM_NULLP (bindings
))
1572 /* no bindings, let* is executed faster */
1573 SCM body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1574 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), SCM_EOL
, body
), env
);
1582 check_bindings (bindings
, expr
);
1583 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1584 new_body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1585 return scm_cons2 (SCM_IM_LETREC
, rvariables
, scm_cons (inits
, new_body
));
1590 SCM_SYNTAX (s_or
, "or", scm_i_makbimacro
, scm_m_or
);
1591 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
1594 scm_m_or (SCM expr
, SCM env SCM_UNUSED
)
1596 const SCM cdr_expr
= SCM_CDR (expr
);
1597 const long length
= scm_ilength (cdr_expr
);
1599 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1603 /* Special case: (or) is replaced by #f. */
1608 SCM_SETCAR (expr
, SCM_IM_OR
);
1614 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
1615 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
1616 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
1617 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
1619 /* Internal function to handle a quasiquotation: 'form' is the parameter in
1620 * the call (quasiquotation form), 'env' is the environment where unquoted
1621 * expressions will be evaluated, and 'depth' is the current quasiquotation
1622 * nesting level and is known to be greater than zero. */
1624 iqq (SCM form
, SCM env
, unsigned long int depth
)
1626 if (SCM_CONSP (form
))
1628 const SCM tmp
= SCM_CAR (form
);
1629 if (SCM_EQ_P (tmp
, scm_sym_quasiquote
))
1631 const SCM args
= SCM_CDR (form
);
1632 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1633 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
1635 else if (SCM_EQ_P (tmp
, scm_sym_unquote
))
1637 const SCM args
= SCM_CDR (form
);
1638 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1640 return scm_eval_car (args
, env
);
1642 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
1644 else if (SCM_CONSP (tmp
)
1645 && SCM_EQ_P (SCM_CAR (tmp
), scm_sym_uq_splicing
))
1647 const SCM args
= SCM_CDR (tmp
);
1648 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1651 const SCM list
= scm_eval_car (args
, env
);
1652 const SCM rest
= SCM_CDR (form
);
1653 ASSERT_SYNTAX_2 (scm_ilength (list
) >= 0,
1654 s_splicing
, list
, form
);
1655 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
1658 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
1659 iqq (SCM_CDR (form
), env
, depth
));
1662 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
1663 iqq (SCM_CDR (form
), env
, depth
));
1665 else if (SCM_VECTORP (form
))
1667 size_t i
= SCM_VECTOR_LENGTH (form
);
1668 SCM
const *const data
= SCM_VELTS (form
);
1671 tmp
= scm_cons (data
[--i
], tmp
);
1672 scm_remember_upto_here_1 (form
);
1673 return scm_vector (iqq (tmp
, env
, depth
));
1680 scm_m_quasiquote (SCM expr
, SCM env
)
1682 const SCM cdr_expr
= SCM_CDR (expr
);
1683 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1684 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1685 return iqq (SCM_CAR (cdr_expr
), env
, 1);
1689 SCM_SYNTAX (s_quote
, "quote", scm_i_makbimacro
, scm_m_quote
);
1690 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
1693 scm_m_quote (SCM expr
, SCM env SCM_UNUSED
)
1697 const SCM cdr_expr
= SCM_CDR (expr
);
1698 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1699 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1700 quotee
= SCM_CAR (cdr_expr
);
1701 if (is_self_quoting_p (quotee
))
1703 SCM_SETCAR (expr
, SCM_IM_QUOTE
);
1708 /* Will go into the RnRS module when Guile is factorized.
1709 SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
1710 static const char s_set_x
[] = "set!";
1711 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, s_set_x
);
1714 scm_m_set_x (SCM expr
, SCM env SCM_UNUSED
)
1718 const SCM cdr_expr
= SCM_CDR (expr
);
1719 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1720 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1721 variable
= SCM_CAR (cdr_expr
);
1722 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
) || SCM_VARIABLEP (variable
),
1723 s_bad_variable
, variable
, expr
);
1725 SCM_SETCAR (expr
, SCM_IM_SET_X
);
1730 /* Start of the memoizers for non-R5RS builtin macros. */
1733 SCM_SYNTAX (s_atapply
, "@apply", scm_i_makbimacro
, scm_m_apply
);
1734 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1735 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1738 scm_m_apply (SCM expr
, SCM env SCM_UNUSED
)
1740 const SCM cdr_expr
= SCM_CDR (expr
);
1741 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1742 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_missing_expression
, expr
);
1744 SCM_SETCAR (expr
, SCM_IM_APPLY
);
1749 SCM_SYNTAX (s_atbind
, "@bind", scm_i_makbimacro
, scm_m_atbind
);
1751 /* FIXME: The following explanation should go into the documentation: */
1752 /* (@bind ((var init) ...) body ...) will assign the values of the `init's to
1753 * the global variables named by `var's (symbols, not evaluated), creating
1754 * them if they don't exist, executes body, and then restores the previous
1755 * values of the `var's. Additionally, whenever control leaves body, the
1756 * values of the `var's are saved and restored when control returns. It is an
1757 * error when a symbol appears more than once among the `var's. All `init's
1758 * are evaluated before any `var' is set.
1760 * Think of this as `let' for dynamic scope.
1763 /* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into
1764 * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...).
1766 * FIXME - also implement `@bind*'.
1769 scm_m_atbind (SCM expr
, SCM env
)
1776 const SCM top_level
= scm_env_top_level (env
);
1778 const SCM cdr_expr
= SCM_CDR (expr
);
1779 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1780 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1781 bindings
= SCM_CAR (cdr_expr
);
1782 check_bindings (bindings
, expr
);
1783 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1785 for (variable_idx
= rvariables
;
1786 !SCM_NULLP (variable_idx
);
1787 variable_idx
= SCM_CDR (variable_idx
))
1789 /* The first call to scm_sym2var will look beyond the current module,
1790 * while the second call wont. */
1791 const SCM variable
= SCM_CAR (variable_idx
);
1792 SCM new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_F
);
1793 if (SCM_FALSEP (new_variable
))
1794 new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_T
);
1795 SCM_SETCAR (variable_idx
, new_variable
);
1798 SCM_SETCAR (expr
, SCM_IM_BIND
);
1799 SCM_SETCAR (cdr_expr
, scm_cons (rvariables
, inits
));
1804 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_i_makbimacro
, scm_m_cont
);
1805 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, s_atcall_cc
);
1808 scm_m_cont (SCM expr
, SCM env SCM_UNUSED
)
1810 const SCM cdr_expr
= SCM_CDR (expr
);
1811 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1812 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1814 SCM_SETCAR (expr
, SCM_IM_CONT
);
1819 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_i_makbimacro
, scm_m_at_call_with_values
);
1820 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
1823 scm_m_at_call_with_values (SCM expr
, SCM env SCM_UNUSED
)
1825 const SCM cdr_expr
= SCM_CDR (expr
);
1826 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1827 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1829 SCM_SETCAR (expr
, SCM_IM_CALL_WITH_VALUES
);
1834 SCM_SYNTAX (s_future
, "future", scm_i_makbimacro
, scm_m_future
);
1835 SCM_GLOBAL_SYMBOL (scm_sym_future
, s_future
);
1837 /* Like promises, futures are implemented as closures with an empty
1838 * parameter list. Thus, (future <expression>) is transformed into
1839 * (#@future '() <expression>), where the empty list represents the
1840 * empty parameter list. This representation allows for easy creation
1841 * of the closure during evaluation. */
1843 scm_m_future (SCM expr
, SCM env
)
1845 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1846 SCM_SETCAR (new_expr
, SCM_IM_FUTURE
);
1851 SCM_SYNTAX (s_gset_x
, "set!", scm_i_makbimacro
, scm_m_generalized_set_x
);
1852 SCM_SYMBOL (scm_sym_setter
, "setter");
1855 scm_m_generalized_set_x (SCM expr
, SCM env
)
1857 SCM target
, exp_target
;
1859 const SCM cdr_expr
= SCM_CDR (expr
);
1860 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1861 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1863 target
= SCM_CAR (cdr_expr
);
1864 if (!SCM_CONSP (target
))
1867 return scm_m_set_x (expr
, env
);
1871 /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */
1872 /* Macroexpanding the target might return things of the form
1873 (begin <atom>). In that case, <atom> must be a symbol or a
1874 variable and we memoize to (set! <atom> ...).
1876 exp_target
= scm_macroexp (target
, env
);
1877 if (SCM_EQ_P (SCM_CAR (exp_target
), SCM_IM_BEGIN
)
1878 && !SCM_NULLP (SCM_CDR (exp_target
))
1879 && SCM_NULLP (SCM_CDDR (exp_target
)))
1881 exp_target
= SCM_CADR (exp_target
);
1882 ASSERT_SYNTAX_2 (SCM_SYMBOLP (exp_target
)
1883 || SCM_VARIABLEP (exp_target
),
1884 s_bad_variable
, exp_target
, expr
);
1885 return scm_cons (SCM_IM_SET_X
, scm_cons (exp_target
,
1886 SCM_CDR (cdr_expr
)));
1890 const SCM setter_proc_tail
= scm_list_1 (SCM_CAR (target
));
1891 const SCM setter_proc
= scm_cons_source (expr
, scm_sym_setter
,
1894 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1895 const SCM setter_args
= scm_append_x (scm_list_2 (SCM_CDR (target
),
1898 SCM_SETCAR (expr
, setter_proc
);
1899 SCM_SETCDR (expr
, setter_args
);
1906 /* @slot-ref is bound privately in the (oop goops) module from goops.c. As
1907 * soon as the module system allows us to more freely create bindings in
1908 * arbitrary modules during the startup phase, the code from goops.c should be
1911 scm_m_atslot_ref (SCM expr
, SCM env SCM_UNUSED
)
1915 const SCM cdr_expr
= SCM_CDR (expr
);
1916 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1917 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1918 slot_nr
= SCM_CADR (cdr_expr
);
1919 ASSERT_SYNTAX_2 (SCM_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
1921 SCM_SETCAR (expr
, SCM_IM_SLOT_REF
);
1926 /* @slot-set! is bound privately in the (oop goops) module from goops.c. As
1927 * soon as the module system allows us to more freely create bindings in
1928 * arbitrary modules during the startup phase, the code from goops.c should be
1931 scm_m_atslot_set_x (SCM expr
, SCM env SCM_UNUSED
)
1935 const SCM cdr_expr
= SCM_CDR (expr
);
1936 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1937 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 3, s_expression
, expr
);
1938 slot_nr
= SCM_CADR (cdr_expr
);
1939 ASSERT_SYNTAX_2 (SCM_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
1941 SCM_SETCAR (expr
, SCM_IM_SLOT_SET_X
);
1946 #if SCM_ENABLE_ELISP
1948 static const char s_defun
[] = "Symbol's function definition is void";
1950 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_i_makbimacro
, scm_m_nil_cond
);
1952 /* nil-cond expressions have the form
1953 * (nil-cond COND VAL COND VAL ... ELSEVAL) */
1955 scm_m_nil_cond (SCM expr
, SCM env SCM_UNUSED
)
1957 const long length
= scm_ilength (SCM_CDR (expr
));
1958 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1959 ASSERT_SYNTAX (length
>= 1 && (length
% 2) == 1, s_expression
, expr
);
1961 SCM_SETCAR (expr
, SCM_IM_NIL_COND
);
1966 SCM_SYNTAX (s_atfop
, "@fop", scm_i_makbimacro
, scm_m_atfop
);
1968 /* The @fop-macro handles procedure and macro applications for elisp. The
1969 * input expression must have the form
1970 * (@fop <var> (transformer-macro <expr> ...))
1971 * where <var> must be a symbol. The expression is transformed into the
1972 * memoized form of either
1973 * (apply <un-aliased var> (transformer-macro <expr> ...))
1974 * if the value of var (across all aliasing) is not a macro, or
1975 * (<un-aliased var> <expr> ...)
1976 * if var is a macro. */
1978 scm_m_atfop (SCM expr
, SCM env SCM_UNUSED
)
1983 const SCM cdr_expr
= SCM_CDR (expr
);
1984 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1985 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 1, s_missing_expression
, expr
);
1987 symbol
= SCM_CAR (cdr_expr
);
1988 ASSERT_SYNTAX_2 (SCM_SYMBOLP (symbol
), s_bad_variable
, symbol
, expr
);
1990 location
= scm_symbol_fref (symbol
);
1991 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
1993 /* The elisp function `defalias' allows to define aliases for symbols. To
1994 * look up such definitions, the chain of symbol definitions has to be
1995 * followed up to the terminal symbol. */
1996 while (SCM_SYMBOLP (SCM_VARIABLE_REF (location
)))
1998 const SCM alias
= SCM_VARIABLE_REF (location
);
1999 location
= scm_symbol_fref (alias
);
2000 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2003 /* Memoize the value location belonging to the terminal symbol. */
2004 SCM_SETCAR (cdr_expr
, location
);
2006 if (!SCM_MACROP (SCM_VARIABLE_REF (location
)))
2008 /* Since the location does not contain a macro, the form is a procedure
2009 * application. Replace `@fop' by `@apply' and transform the expression
2010 * including the `transformer-macro'. */
2011 SCM_SETCAR (expr
, SCM_IM_APPLY
);
2016 /* Since the location contains a macro, the arguments should not be
2017 * transformed, so the `transformer-macro' is cut out. The resulting
2018 * expression starts with the memoized variable, that is at the cdr of
2019 * the input expression. */
2020 SCM_SETCDR (cdr_expr
, SCM_CDADR (cdr_expr
));
2025 #endif /* SCM_ENABLE_ELISP */
2028 #if (SCM_ENABLE_DEPRECATED == 1)
2030 /* Deprecated in guile 1.7.0 on 2003-11-09. */
2032 scm_m_expand_body (SCM exprs
, SCM env
)
2034 scm_c_issue_deprecation_warning
2035 ("`scm_m_expand_body' is deprecated.");
2036 m_expand_body (exprs
, env
);
2041 SCM_SYNTAX (s_undefine
, "undefine", scm_makacro
, scm_m_undefine
);
2044 scm_m_undefine (SCM expr
, SCM env
)
2049 const SCM cdr_expr
= SCM_CDR (expr
);
2050 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), "Bad undefine placement in", expr
);
2051 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2052 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2054 variable
= SCM_CAR (cdr_expr
);
2055 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
), s_bad_variable
, variable
, expr
);
2056 location
= scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_F
);
2057 ASSERT_SYNTAX_2 (!SCM_FALSEP (location
)
2058 && !SCM_UNBNDP (SCM_VARIABLE_REF (location
)),
2059 "variable already unbound ", variable
, expr
);
2060 SCM_VARIABLE_SET (location
, SCM_UNDEFINED
);
2061 return SCM_UNSPECIFIED
;
2066 scm_macroexp (SCM x
, SCM env
)
2068 SCM res
, proc
, orig_sym
;
2070 /* Don't bother to produce error messages here. We get them when we
2071 eventually execute the code for real. */
2074 orig_sym
= SCM_CAR (x
);
2075 if (!SCM_SYMBOLP (orig_sym
))
2079 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
2080 if (proc_ptr
== NULL
)
2082 /* We have lost the race. */
2088 /* Only handle memoizing macros. `Acros' and `macros' are really
2089 special forms and should not be evaluated here. */
2091 if (!SCM_MACROP (proc
)
2092 || (SCM_MACRO_TYPE (proc
) != 2 && !SCM_BUILTIN_MACRO_P (proc
)))
2095 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
2096 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
2098 if (scm_ilength (res
) <= 0)
2099 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
2102 SCM_SETCAR (x
, SCM_CAR (res
));
2103 SCM_SETCDR (x
, SCM_CDR (res
));
2111 /*****************************************************************************/
2112 /*****************************************************************************/
2113 /* The definitions for unmemoization start here. */
2114 /*****************************************************************************/
2115 /*****************************************************************************/
2117 #define SCM_BIT7(x) (127 & SCM_UNPACK (x))
2119 SCM_SYMBOL (sym_three_question_marks
, "???");
2122 /* scm_unmemocopy takes a memoized expression together with its
2123 * environment and rewrites it to its original form. Thus, it is the
2124 * inversion of the rewrite rules above. The procedure is not
2125 * optimized for speed. It's used in scm_iprin1 when printing the
2126 * code of a closure, in scm_procedure_source, in display_frame when
2127 * generating the source for a stackframe in a backtrace, and in
2128 * display_expression.
2130 * Unmemoizing is not a reliable process. You cannot in general
2131 * expect to get the original source back.
2133 * However, GOOPS currently relies on this for method compilation.
2134 * This ought to change.
2138 build_binding_list (SCM rnames
, SCM rinits
)
2140 SCM bindings
= SCM_EOL
;
2141 while (!SCM_NULLP (rnames
))
2143 SCM binding
= scm_list_2 (SCM_CAR (rnames
), SCM_CAR (rinits
));
2144 bindings
= scm_cons (binding
, bindings
);
2145 rnames
= SCM_CDR (rnames
);
2146 rinits
= SCM_CDR (rinits
);
2153 unmemocar (SCM form
, SCM env
)
2155 if (!SCM_CONSP (form
))
2159 SCM c
= SCM_CAR (form
);
2160 if (SCM_VARIABLEP (c
))
2162 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
2163 if (SCM_FALSEP (sym
))
2164 sym
= sym_three_question_marks
;
2165 SCM_SETCAR (form
, sym
);
2167 else if (SCM_ILOCP (c
))
2169 unsigned long int ir
;
2171 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
2172 env
= SCM_CDR (env
);
2173 env
= SCM_CAAR (env
);
2174 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
2175 env
= SCM_CDR (env
);
2177 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
2185 scm_unmemocopy (SCM x
, SCM env
)
2190 if (SCM_VECTORP (x
))
2192 return scm_list_2 (scm_sym_quote
, x
);
2194 else if (!SCM_CONSP (x
))
2197 p
= scm_whash_lookup (scm_source_whash
, x
);
2198 if (SCM_ISYMP (SCM_CAR (x
)))
2200 switch (SCM_ISYMNUM (SCM_CAR (x
)))
2202 case (SCM_ISYMNUM (SCM_IM_AND
)):
2203 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
2205 case (SCM_ISYMNUM (SCM_IM_BEGIN
)):
2206 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
2208 case (SCM_ISYMNUM (SCM_IM_CASE
)):
2209 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
2211 case (SCM_ISYMNUM (SCM_IM_COND
)):
2212 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
2214 case (SCM_ISYMNUM (SCM_IM_DO
)):
2216 /* format: (#@do (i1 ... ik) (nk ... n1) (test) (body) s1 ... sk),
2217 * where ix is an initializer for a local variable, nx is the name
2218 * of the local variable, test is the test clause of the do loop,
2219 * body is the body of the do loop and sx are the step clauses for
2220 * the local variables. */
2221 SCM names
, inits
, test
, memoized_body
, steps
, bindings
;
2224 inits
= scm_reverse (scm_unmemocopy (SCM_CAR (x
), env
));
2226 names
= SCM_CAR (x
);
2227 env
= SCM_EXTEND_ENV (names
, SCM_EOL
, env
);
2229 test
= scm_unmemocopy (SCM_CAR (x
), env
);
2231 memoized_body
= SCM_CAR (x
);
2233 steps
= scm_reverse (scm_unmemocopy (x
, env
));
2235 /* build transformed binding list */
2237 while (!SCM_NULLP (names
))
2239 SCM name
= SCM_CAR (names
);
2240 SCM init
= SCM_CAR (inits
);
2241 SCM step
= SCM_CAR (steps
);
2242 step
= SCM_EQ_P (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
2244 bindings
= scm_cons (scm_cons2 (name
, init
, step
), bindings
);
2246 names
= SCM_CDR (names
);
2247 inits
= SCM_CDR (inits
);
2248 steps
= SCM_CDR (steps
);
2250 z
= scm_cons (test
, SCM_UNSPECIFIED
);
2251 ls
= scm_cons2 (scm_sym_do
, bindings
, z
);
2253 x
= scm_cons (SCM_BOOL_F
, memoized_body
);
2256 case (SCM_ISYMNUM (SCM_IM_IF
)):
2257 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
2259 case (SCM_ISYMNUM (SCM_IM_LET
)):
2261 /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),
2262 * where nx is the name of a local variable, ix is an initializer
2263 * for the local variable and by are the body clauses. */
2264 SCM rnames
, rinits
, bindings
;
2267 rnames
= SCM_CAR (x
);
2269 rinits
= scm_reverse (scm_unmemocopy (SCM_CAR (x
), env
));
2270 env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
2272 bindings
= build_binding_list (rnames
, rinits
);
2273 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
2274 ls
= scm_cons (scm_sym_let
, z
);
2277 case (SCM_ISYMNUM (SCM_IM_LETREC
)):
2279 /* format: (#@letrec (vn ... v2 v1) (i1 i2 ... in) b1 ...),
2280 * where vx is the name of a local variable, ix is an initializer
2281 * for the local variable and by are the body clauses. */
2282 SCM rnames
, rinits
, bindings
;
2285 rnames
= SCM_CAR (x
);
2286 env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
2288 rinits
= scm_reverse (scm_unmemocopy (SCM_CAR (x
), env
));
2290 bindings
= build_binding_list (rnames
, rinits
);
2291 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
2292 ls
= scm_cons (scm_sym_letrec
, z
);
2295 case (SCM_ISYMNUM (SCM_IM_LETSTAR
)):
2303 env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2307 SCM copy
= scm_unmemocopy (SCM_CADR (b
), env
);
2308 SCM initializer
= unmemocar (scm_list_1 (copy
), env
);
2309 y
= z
= scm_acons (SCM_CAR (b
), initializer
, SCM_UNSPECIFIED
);
2310 env
= SCM_EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
2314 SCM_SETCDR (y
, SCM_EOL
);
2315 z
= scm_cons (y
, SCM_UNSPECIFIED
);
2316 ls
= scm_cons (scm_sym_let
, z
);
2321 copy
= scm_unmemocopy (SCM_CADR (b
), env
);
2322 initializer
= unmemocar (scm_list_1 (copy
), env
);
2323 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
2327 env
= SCM_EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
2330 while (!SCM_NULLP (b
));
2331 SCM_SETCDR (z
, SCM_EOL
);
2333 z
= scm_cons (y
, SCM_UNSPECIFIED
);
2334 ls
= scm_cons (scm_sym_letstar
, z
);
2337 case (SCM_ISYMNUM (SCM_IM_OR
)):
2338 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
2340 case (SCM_ISYMNUM (SCM_IM_LAMBDA
)):
2342 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
);
2343 ls
= scm_cons (scm_sym_lambda
, z
);
2344 env
= SCM_EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
2346 case (SCM_ISYMNUM (SCM_IM_QUOTE
)):
2347 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
2349 case (SCM_ISYMNUM (SCM_IM_SET_X
)):
2350 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
2352 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2353 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
2355 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2356 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
2358 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2359 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
2362 case (SCM_ISYMNUM (SCM_IM_FUTURE
)):
2363 ls
= z
= scm_cons (scm_sym_future
, SCM_UNSPECIFIED
);
2366 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2367 ls
= z
= scm_cons (scm_sym_at_call_with_values
, SCM_UNSPECIFIED
);
2369 case (SCM_ISYMNUM (SCM_IM_ELSE
)):
2370 ls
= z
= scm_cons (scm_sym_else
, SCM_UNSPECIFIED
);
2373 ls
= z
= unmemocar (scm_cons (scm_unmemocopy (SCM_CAR (x
), env
),
2380 ls
= z
= unmemocar (scm_cons (scm_unmemocopy (SCM_CAR (x
), env
),
2386 while (SCM_CONSP (x
))
2388 SCM form
= SCM_CAR (x
);
2389 if (!SCM_ISYMP (form
))
2391 SCM copy
= scm_cons (scm_unmemocopy (form
, env
), SCM_UNSPECIFIED
);
2392 SCM_SETCDR (z
, unmemocar (copy
, env
));
2395 else if (SCM_EQ_P (form
, SCM_IM_ARROW
))
2397 SCM_SETCDR (z
, scm_cons (scm_sym_arrow
, SCM_UNSPECIFIED
));
2403 if (!SCM_FALSEP (p
))
2404 scm_whash_insert (scm_source_whash
, ls
, p
);
2409 #if (SCM_ENABLE_DEPRECATED == 1)
2412 scm_unmemocar (SCM form
, SCM env
)
2414 return unmemocar (form
, env
);
2419 /*****************************************************************************/
2420 /*****************************************************************************/
2421 /* The definitions for execution start here. */
2422 /*****************************************************************************/
2423 /*****************************************************************************/
2425 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
2426 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
2427 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
2428 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
2430 /* A function object to implement "apply" for non-closure functions. */
2432 /* An endless list consisting of #<undefined> objects: */
2433 static SCM undefineds
;
2437 scm_badargsp (SCM formals
, SCM args
)
2439 while (!SCM_NULLP (formals
))
2441 if (!SCM_CONSP (formals
))
2443 if (SCM_NULLP (args
))
2445 formals
= SCM_CDR (formals
);
2446 args
= SCM_CDR (args
);
2448 return !SCM_NULLP (args
) ? 1 : 0;
2453 /* The evaluator contains a plethora of EVAL symbols. This is an attempt at
2456 * The following macros should be used in code which is read twice (where the
2457 * choice of evaluator is hard soldered):
2459 * CEVAL is the symbol used within one evaluator to call itself.
2460 * Originally, it is defined to ceval, but is redefined to deval during the
2463 * SCM_EVALIM is used when it is known that the expression is an
2464 * immediate. (This macro never calls an evaluator.)
2466 * EVAL evaluates an expression that is expected to have its symbols already
2467 * memoized. Expressions that are not of the form '(<form> <form> ...)' are
2468 * evaluated inline without calling an evaluator.
2470 * EVALCAR evaluates the car of an expression 'X:(Y:<form> <form> ...)',
2471 * potentially replacing a symbol at the position Y:<form> by its memoized
2472 * variable. If Y:<form> is not of the form '(<form> <form> ...)', the
2473 * evaluation is performed inline without calling an evaluator.
2475 * The following macros should be used in code which is read once
2476 * (where the choice of evaluator is dynamic):
2478 * SCM_XEVAL corresponds to EVAL, but uses ceval *or* deval depending on the
2481 * SCM_XEVALCAR corresponds to EVALCAR, but uses ceval *or* deval depending
2482 * on the debugging mode.
2484 * The main motivation for keeping this plethora is efficiency
2485 * together with maintainability (=> locality of code).
2488 static SCM
ceval (SCM x
, SCM env
);
2489 static SCM
deval (SCM x
, SCM env
);
2493 #define SCM_EVALIM2(x) \
2494 ((SCM_EQ_P ((x), SCM_EOL) \
2495 ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \
2499 #define SCM_EVALIM(x, env) (SCM_ILOCP (x) \
2500 ? *scm_ilookup ((x), (env)) \
2503 #define SCM_XEVAL(x, env) \
2506 : (SCM_VARIABLEP (x) \
2507 ? SCM_VARIABLE_REF (x) \
2509 ? (scm_debug_mode_p \
2510 ? deval ((x), (env)) \
2511 : ceval ((x), (env))) \
2514 #define SCM_XEVALCAR(x, env) \
2515 (SCM_IMP (SCM_CAR (x)) \
2516 ? SCM_EVALIM (SCM_CAR (x), (env)) \
2517 : (SCM_VARIABLEP (SCM_CAR (x)) \
2518 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2519 : (SCM_CONSP (SCM_CAR (x)) \
2520 ? (scm_debug_mode_p \
2521 ? deval (SCM_CAR (x), (env)) \
2522 : ceval (SCM_CAR (x), (env))) \
2523 : (!SCM_SYMBOLP (SCM_CAR (x)) \
2525 : *scm_lookupcar ((x), (env), 1)))))
2527 #define EVAL(x, env) \
2529 ? SCM_EVALIM ((x), (env)) \
2530 : (SCM_VARIABLEP (x) \
2531 ? SCM_VARIABLE_REF (x) \
2533 ? CEVAL ((x), (env)) \
2536 #define EVALCAR(x, env) \
2537 (SCM_IMP (SCM_CAR (x)) \
2538 ? SCM_EVALIM (SCM_CAR (x), (env)) \
2539 : (SCM_VARIABLEP (SCM_CAR (x)) \
2540 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2541 : (SCM_CONSP (SCM_CAR (x)) \
2542 ? CEVAL (SCM_CAR (x), (env)) \
2543 : (!SCM_SYMBOLP (SCM_CAR (x)) \
2545 : *scm_lookupcar ((x), (env), 1)))))
2547 SCM_REC_MUTEX (source_mutex
);
2551 scm_eval_car (SCM pair
, SCM env
)
2553 return SCM_XEVALCAR (pair
, env
);
2558 scm_eval_args (SCM l
, SCM env
, SCM proc
)
2560 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
2561 while (SCM_CONSP (l
))
2563 res
= EVALCAR (l
, env
);
2565 *lloc
= scm_list_1 (res
);
2566 lloc
= SCM_CDRLOC (*lloc
);
2570 scm_wrong_num_args (proc
);
2576 scm_eval_body (SCM code
, SCM env
)
2581 next
= SCM_CDR (code
);
2582 while (!SCM_NULLP (next
))
2584 if (SCM_IMP (SCM_CAR (code
)))
2586 if (SCM_ISYMP (SCM_CAR (code
)))
2588 scm_rec_mutex_lock (&source_mutex
);
2589 /* check for race condition */
2590 if (SCM_ISYMP (SCM_CAR (code
)))
2591 m_expand_body (code
, env
);
2592 scm_rec_mutex_unlock (&source_mutex
);
2597 SCM_XEVAL (SCM_CAR (code
), env
);
2599 next
= SCM_CDR (code
);
2601 return SCM_XEVALCAR (code
, env
);
2607 /* SECTION: This code is specific for the debugging support. One
2608 * branch is read when DEVAL isn't defined, the other when DEVAL is
2614 #define SCM_APPLY scm_apply
2615 #define PREP_APPLY(proc, args)
2617 #define RETURN(x) do { return x; } while (0)
2618 #ifdef STACK_CHECKING
2619 #ifndef NO_CEVAL_STACK_CHECKING
2620 #define EVAL_STACK_CHECKING
2627 #define CEVAL deval /* Substitute all uses of ceval */
2630 #define SCM_APPLY scm_dapply
2633 #define PREP_APPLY(p, l) \
2634 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
2637 #define ENTER_APPLY \
2639 SCM_SET_ARGSREADY (debug);\
2640 if (scm_check_apply_p && SCM_TRAPS_P)\
2641 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
2643 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
2644 SCM_SET_TRACED_FRAME (debug); \
2646 if (SCM_CHEAPTRAPS_P)\
2648 tmp = scm_make_debugobj (&debug);\
2649 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
2654 tmp = scm_make_continuation (&first);\
2656 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
2663 #define RETURN(e) do { proc = (e); goto exit; } while (0)
2665 #ifdef STACK_CHECKING
2666 #ifndef EVAL_STACK_CHECKING
2667 #define EVAL_STACK_CHECKING
2672 /* scm_last_debug_frame contains a pointer to the last debugging information
2673 * stack frame. It is accessed very often from the debugging evaluator, so it
2674 * should probably not be indirectly addressed. Better to save and restore it
2675 * from the current root at any stack swaps.
2678 /* scm_debug_eframe_size is the number of slots available for pseudo
2679 * stack frames at each real stack frame.
2682 long scm_debug_eframe_size
;
2684 int scm_debug_mode_p
;
2685 int scm_check_entry_p
;
2686 int scm_check_apply_p
;
2687 int scm_check_exit_p
;
2689 long scm_eval_stack
;
2691 scm_t_option scm_eval_opts
[] = {
2692 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
2695 scm_t_option scm_debug_opts
[] = {
2696 { SCM_OPTION_BOOLEAN
, "cheap", 1,
2697 "*Flyweight representation of the stack at traps." },
2698 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
2699 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
2700 { SCM_OPTION_BOOLEAN
, "procnames", 1,
2701 "Record procedure names at definition." },
2702 { SCM_OPTION_BOOLEAN
, "backwards", 0,
2703 "Display backtrace in anti-chronological order." },
2704 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
2705 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
2706 { SCM_OPTION_INTEGER
, "frames", 3,
2707 "Maximum number of tail-recursive frames in backtrace." },
2708 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
2709 "Maximal number of stored backtrace frames." },
2710 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
2711 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
2712 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
2713 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
2714 { 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."}
2717 scm_t_option scm_evaluator_trap_table
[] = {
2718 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
2719 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
2720 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
2721 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
2722 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
2723 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
2724 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
2727 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
2729 "Option interface for the evaluation options. Instead of using\n"
2730 "this procedure directly, use the procedures @code{eval-enable},\n"
2731 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
2732 #define FUNC_NAME s_scm_eval_options_interface
2736 ans
= scm_options (setting
,
2740 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
2747 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
2749 "Option interface for the evaluator trap options.")
2750 #define FUNC_NAME s_scm_evaluator_traps
2754 ans
= scm_options (setting
,
2755 scm_evaluator_trap_table
,
2756 SCM_N_EVALUATOR_TRAPS
,
2758 SCM_RESET_DEBUG_MODE
;
2766 deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
2768 SCM
*results
= lloc
, res
;
2769 while (SCM_CONSP (l
))
2771 res
= EVALCAR (l
, env
);
2773 *lloc
= scm_list_1 (res
);
2774 lloc
= SCM_CDRLOC (*lloc
);
2778 scm_wrong_num_args (proc
);
2785 /* SECTION: This code is compiled twice.
2789 /* Update the toplevel environment frame ENV so that it refers to the
2790 * current module. */
2791 #define UPDATE_TOPLEVEL_ENV(env) \
2793 SCM p = scm_current_module_lookup_closure (); \
2794 if (p != SCM_CAR (env)) \
2795 env = scm_top_level_env (p); \
2799 #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
2800 ASSERT_SYNTAX (!SCM_EQ_P ((x), SCM_EOL), s_empty_combination, x)
2803 /* This is the evaluator. Like any real monster, it has three heads:
2805 * ceval is the non-debugging evaluator, deval is the debugging version. Both
2806 * are implemented using a common code base, using the following mechanism:
2807 * CEVAL is a macro, which is either defined to ceval or deval. Thus, there
2808 * is no function CEVAL, but the code for CEVAL actually compiles to either
2809 * ceval or deval. When CEVAL is defined to ceval, it is known that the macro
2810 * DEVAL is not defined. When CEVAL is defined to deval, then the macro DEVAL
2811 * is known to be defined. Thus, in CEVAL parts for the debugging evaluator
2812 * are enclosed within #ifdef DEVAL ... #endif.
2814 * All three (ceval, deval and their common implementation CEVAL) take two
2815 * input parameters, x and env: x is a single expression to be evalutated.
2816 * env is the environment in which bindings are searched.
2818 * x is known to be a pair. Since x is a single expression, it is necessarily
2819 * in a tail position. If x is just a call to another function like in the
2820 * expression (foo exp1 exp2 ...), the realization of that call therefore
2821 * _must_not_ increase stack usage (the evaluation of exp1, exp2 etc.,
2822 * however, may do so). This is realized by making extensive use of 'goto'
2823 * statements within the evaluator: The gotos replace recursive calls to
2824 * CEVAL, thus re-using the same stack frame that CEVAL was already using.
2825 * If, however, x represents some form that requires to evaluate a sequence of
2826 * expressions like (begin exp1 exp2 ...), then recursive calls to CEVAL are
2827 * performed for all but the last expression of that sequence. */
2830 CEVAL (SCM x
, SCM env
)
2834 scm_t_debug_frame debug
;
2835 scm_t_debug_info
*debug_info_end
;
2836 debug
.prev
= scm_last_debug_frame
;
2839 * The debug.vect contains twice as much scm_t_debug_info frames as the
2840 * user has specified with (debug-set! frames <n>).
2842 * Even frames are eval frames, odd frames are apply frames.
2844 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
2845 * sizeof (scm_t_debug_info
));
2846 debug
.info
= debug
.vect
;
2847 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
2848 scm_last_debug_frame
= &debug
;
2850 #ifdef EVAL_STACK_CHECKING
2851 if (scm_stack_checking_enabled_p
&& SCM_STACK_OVERFLOW_P (&proc
))
2854 debug
.info
->e
.exp
= x
;
2855 debug
.info
->e
.env
= env
;
2857 scm_report_stack_overflow ();
2867 SCM_CLEAR_ARGSREADY (debug
);
2868 if (SCM_OVERFLOWP (debug
))
2871 * In theory, this should be the only place where it is necessary to
2872 * check for space in debug.vect since both eval frames and
2873 * available space are even.
2875 * For this to be the case, however, it is necessary that primitive
2876 * special forms which jump back to `loop', `begin' or some similar
2877 * label call PREP_APPLY.
2879 else if (++debug
.info
>= debug_info_end
)
2881 SCM_SET_OVERFLOW (debug
);
2886 debug
.info
->e
.exp
= x
;
2887 debug
.info
->e
.env
= env
;
2888 if (scm_check_entry_p
&& SCM_TRAPS_P
)
2890 if (SCM_ENTER_FRAME_P
2891 || (SCM_BREAKPOINTS_P
&& scm_c_source_property_breakpoint_p (x
)))
2894 SCM tail
= SCM_BOOL (SCM_TAILRECP (debug
));
2895 SCM_SET_TAILREC (debug
);
2896 if (SCM_CHEAPTRAPS_P
)
2897 stackrep
= scm_make_debugobj (&debug
);
2901 SCM val
= scm_make_continuation (&first
);
2911 /* This gives the possibility for the debugger to
2912 modify the source expression before evaluation. */
2917 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
2918 scm_sym_enter_frame
,
2921 scm_unmemocopy (x
, env
));
2928 if (SCM_ISYMP (SCM_CAR (x
)))
2930 switch (SCM_ISYMNUM (SCM_CAR (x
)))
2932 case (SCM_ISYMNUM (SCM_IM_AND
)):
2934 while (!SCM_NULLP (SCM_CDR (x
)))
2936 SCM test_result
= EVALCAR (x
, env
);
2937 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
2938 RETURN (SCM_BOOL_F
);
2942 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2945 case (SCM_ISYMNUM (SCM_IM_BEGIN
)):
2948 RETURN (SCM_UNSPECIFIED
);
2950 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2953 /* If we are on toplevel with a lookup closure, we need to sync
2954 with the current module. */
2955 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
2957 UPDATE_TOPLEVEL_ENV (env
);
2958 while (!SCM_NULLP (SCM_CDR (x
)))
2961 UPDATE_TOPLEVEL_ENV (env
);
2967 goto nontoplevel_begin
;
2970 while (!SCM_NULLP (SCM_CDR (x
)))
2972 SCM form
= SCM_CAR (x
);
2975 if (SCM_ISYMP (form
))
2977 scm_rec_mutex_lock (&source_mutex
);
2978 /* check for race condition */
2979 if (SCM_ISYMP (SCM_CAR (x
)))
2980 m_expand_body (x
, env
);
2981 scm_rec_mutex_unlock (&source_mutex
);
2982 goto nontoplevel_begin
;
2985 SCM_VALIDATE_NON_EMPTY_COMBINATION (form
);
2994 /* scm_eval last form in list */
2995 SCM last_form
= SCM_CAR (x
);
2997 if (SCM_CONSP (last_form
))
2999 /* This is by far the most frequent case. */
3001 goto loop
; /* tail recurse */
3003 else if (SCM_IMP (last_form
))
3004 RETURN (SCM_EVALIM (last_form
, env
));
3005 else if (SCM_VARIABLEP (last_form
))
3006 RETURN (SCM_VARIABLE_REF (last_form
));
3007 else if (SCM_SYMBOLP (last_form
))
3008 RETURN (*scm_lookupcar (x
, env
, 1));
3014 case (SCM_ISYMNUM (SCM_IM_CASE
)):
3017 SCM key
= EVALCAR (x
, env
);
3019 while (!SCM_NULLP (x
))
3021 SCM clause
= SCM_CAR (x
);
3022 SCM labels
= SCM_CAR (clause
);
3023 if (SCM_EQ_P (labels
, SCM_IM_ELSE
))
3025 x
= SCM_CDR (clause
);
3026 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3029 while (!SCM_NULLP (labels
))
3031 SCM label
= SCM_CAR (labels
);
3032 if (SCM_EQ_P (label
, key
)
3033 || !SCM_FALSEP (scm_eqv_p (label
, key
)))
3035 x
= SCM_CDR (clause
);
3036 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3039 labels
= SCM_CDR (labels
);
3044 RETURN (SCM_UNSPECIFIED
);
3047 case (SCM_ISYMNUM (SCM_IM_COND
)):
3049 while (!SCM_NULLP (x
))
3051 SCM clause
= SCM_CAR (x
);
3052 if (SCM_EQ_P (SCM_CAR (clause
), SCM_IM_ELSE
))
3054 x
= SCM_CDR (clause
);
3055 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3060 arg1
= EVALCAR (clause
, env
);
3061 if (!SCM_FALSEP (arg1
) && !SCM_NILP (arg1
))
3063 x
= SCM_CDR (clause
);
3066 else if (!SCM_EQ_P (SCM_CAR (x
), SCM_IM_ARROW
))
3068 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3074 proc
= EVALCAR (proc
, env
);
3075 PREP_APPLY (proc
, scm_list_1 (arg1
));
3083 RETURN (SCM_UNSPECIFIED
);
3086 case (SCM_ISYMNUM (SCM_IM_DO
)):
3089 /* Compute the initialization values and the initial environment. */
3090 SCM init_forms
= SCM_CAR (x
);
3091 SCM init_values
= SCM_EOL
;
3092 while (!SCM_NULLP (init_forms
))
3094 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3095 init_forms
= SCM_CDR (init_forms
);
3098 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
3102 SCM test_form
= SCM_CAR (x
);
3103 SCM body_forms
= SCM_CADR (x
);
3104 SCM step_forms
= SCM_CDDR (x
);
3106 SCM test_result
= EVALCAR (test_form
, env
);
3108 while (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
3111 /* Evaluate body forms. */
3113 for (temp_forms
= body_forms
;
3114 !SCM_NULLP (temp_forms
);
3115 temp_forms
= SCM_CDR (temp_forms
))
3117 SCM form
= SCM_CAR (temp_forms
);
3118 /* Dirk:FIXME: We only need to eval forms, that may have a
3119 * side effect here. This is only true for forms that start
3120 * with a pair. All others are just constants. However,
3121 * since in the common case there is no constant expression
3122 * in a body of a do form, we just check for immediates here
3123 * and have CEVAL take care of other cases. In the long run
3124 * it would make sense to get rid of this test and have the
3125 * macro transformer of 'do' eliminate all forms that have
3132 /* Evaluate the step expressions. */
3134 SCM step_values
= SCM_EOL
;
3135 for (temp_forms
= step_forms
;
3136 !SCM_NULLP (temp_forms
);
3137 temp_forms
= SCM_CDR (temp_forms
))
3139 SCM value
= EVALCAR (temp_forms
, env
);
3140 step_values
= scm_cons (value
, step_values
);
3142 env
= SCM_EXTEND_ENV (SCM_CAAR (env
),
3147 test_result
= EVALCAR (test_form
, env
);
3152 RETURN (SCM_UNSPECIFIED
);
3153 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3154 goto nontoplevel_begin
;
3157 case (SCM_ISYMNUM (SCM_IM_IF
)):
3160 SCM test_result
= EVALCAR (x
, env
);
3161 x
= SCM_CDR (x
); /* then expression */
3162 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
3164 x
= SCM_CDR (x
); /* else expression */
3166 RETURN (SCM_UNSPECIFIED
);
3169 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3173 case (SCM_ISYMNUM (SCM_IM_LET
)):
3176 SCM init_forms
= SCM_CADR (x
);
3177 SCM init_values
= SCM_EOL
;
3180 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3181 init_forms
= SCM_CDR (init_forms
);
3183 while (!SCM_NULLP (init_forms
));
3184 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
3187 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3188 goto nontoplevel_begin
;
3191 case (SCM_ISYMNUM (SCM_IM_LETREC
)):
3193 env
= SCM_EXTEND_ENV (SCM_CAR (x
), undefineds
, env
);
3196 SCM init_forms
= SCM_CAR (x
);
3197 SCM init_values
= SCM_EOL
;
3200 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3201 init_forms
= SCM_CDR (init_forms
);
3203 while (!SCM_NULLP (init_forms
));
3204 SCM_SETCDR (SCM_CAR (env
), init_values
);
3207 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3208 goto nontoplevel_begin
;
3211 case (SCM_ISYMNUM (SCM_IM_LETSTAR
)):
3214 SCM bindings
= SCM_CAR (x
);
3215 if (SCM_NULLP (bindings
))
3216 env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
3221 SCM name
= SCM_CAR (bindings
);
3222 SCM init
= SCM_CDR (bindings
);
3223 env
= SCM_EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
3224 bindings
= SCM_CDR (init
);
3226 while (!SCM_NULLP (bindings
));
3230 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3231 goto nontoplevel_begin
;
3234 case (SCM_ISYMNUM (SCM_IM_OR
)):
3236 while (!SCM_NULLP (SCM_CDR (x
)))
3238 SCM val
= EVALCAR (x
, env
);
3239 if (!SCM_FALSEP (val
) && !SCM_NILP (val
))
3244 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3248 case (SCM_ISYMNUM (SCM_IM_LAMBDA
)):
3249 RETURN (scm_closure (SCM_CDR (x
), env
));
3252 case (SCM_ISYMNUM (SCM_IM_QUOTE
)):
3253 RETURN (SCM_CADR (x
));
3256 case (SCM_ISYMNUM (SCM_IM_SET_X
)):
3260 SCM variable
= SCM_CAR (x
);
3261 if (SCM_ILOCP (variable
))
3262 location
= scm_ilookup (variable
, env
);
3263 else if (SCM_VARIABLEP (variable
))
3264 location
= SCM_VARIABLE_LOC (variable
);
3265 else /* (SCM_SYMBOLP (variable)) is known to be true */
3266 location
= scm_lookupcar (x
, env
, 1);
3268 *location
= EVALCAR (x
, env
);
3270 RETURN (SCM_UNSPECIFIED
);
3273 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
3274 /* Evaluate the procedure to be applied. */
3276 proc
= EVALCAR (x
, env
);
3277 PREP_APPLY (proc
, SCM_EOL
);
3279 /* Evaluate the argument holding the list of arguments */
3281 arg1
= EVALCAR (x
, env
);
3284 /* Go here to tail-apply a procedure. PROC is the procedure and
3285 * ARG1 is the list of arguments. PREP_APPLY must have been called
3286 * before jumping to apply_proc. */
3287 if (SCM_CLOSUREP (proc
))
3289 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3291 debug
.info
->a
.args
= arg1
;
3293 if (scm_badargsp (formals
, arg1
))
3294 scm_wrong_num_args (proc
);
3296 /* Copy argument list */
3297 if (SCM_NULL_OR_NIL_P (arg1
))
3298 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
3301 SCM args
= scm_list_1 (SCM_CAR (arg1
));
3303 arg1
= SCM_CDR (arg1
);
3304 while (!SCM_NULL_OR_NIL_P (arg1
))
3306 SCM new_tail
= scm_list_1 (SCM_CAR (arg1
));
3307 SCM_SETCDR (tail
, new_tail
);
3309 arg1
= SCM_CDR (arg1
);
3311 env
= SCM_EXTEND_ENV (formals
, args
, SCM_ENV (proc
));
3314 x
= SCM_CLOSURE_BODY (proc
);
3315 goto nontoplevel_begin
;
3320 RETURN (SCM_APPLY (proc
, arg1
, SCM_EOL
));
3324 case (SCM_ISYMNUM (SCM_IM_CONT
)):
3327 SCM val
= scm_make_continuation (&first
);
3335 proc
= EVALCAR (proc
, env
);
3336 PREP_APPLY (proc
, scm_list_1 (arg1
));
3343 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
3344 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
3347 case (SCM_ISYMNUM (SCM_IM_FUTURE
)):
3348 RETURN (scm_i_make_future (scm_closure (SCM_CDR (x
), env
)));
3351 /* PLACEHOLDER for case (SCM_ISYMNUM (SCM_IM_DISPATCH)): The
3352 following code (type_dispatch) is intended to be the tail
3353 of the case clause for the internal macro
3354 SCM_IM_DISPATCH. Please don't remove it from this
3355 location without discussing it with Mikael
3356 <djurfeldt@nada.kth.se> */
3358 /* The type dispatch code is duplicated below
3359 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
3360 * cuts down execution time for type dispatch to 50%. */
3361 type_dispatch
: /* inputs: x, arg1 */
3362 /* Type dispatch means to determine from the types of the function
3363 * arguments (i. e. the 'signature' of the call), which method from
3364 * a generic function is to be called. This process of selecting
3365 * the right method takes some time. To speed it up, guile uses
3366 * caching: Together with the macro call to dispatch the signatures
3367 * of some previous calls to that generic function from the same
3368 * place are stored (in the code!) in a cache that we call the
3369 * 'method cache'. This is done since it is likely, that
3370 * consecutive calls to dispatch from that position in the code will
3371 * have the same signature. Thus, the type dispatch works as
3372 * follows: First, determine a hash value from the signature of the
3373 * actual arguments. Second, use this hash value as an index to
3374 * find that same signature in the method cache stored at this
3375 * position in the code. If found, you have also found the
3376 * corresponding method that belongs to that signature. If the
3377 * signature is not found in the method cache, you have to perform a
3378 * full search over all signatures stored with the generic
3381 unsigned long int specializers
;
3382 unsigned long int hash_value
;
3383 unsigned long int cache_end_pos
;
3384 unsigned long int mask
;
3388 SCM z
= SCM_CDDR (x
);
3389 SCM tmp
= SCM_CADR (z
);
3390 specializers
= SCM_INUM (SCM_CAR (z
));
3392 /* Compute a hash value for searching the method cache. There
3393 * are two variants for computing the hash value, a (rather)
3394 * complicated one, and a simple one. For the complicated one
3395 * explained below, tmp holds a number that is used in the
3397 if (SCM_INUMP (tmp
))
3399 /* Use the signature of the actual arguments to determine
3400 * the hash value. This is done as follows: Each class has
3401 * an array of random numbers, that are determined when the
3402 * class is created. The integer 'hashset' is an index into
3403 * that array of random numbers. Now, from all classes that
3404 * are part of the signature of the actual arguments, the
3405 * random numbers at index 'hashset' are taken and summed
3406 * up, giving the hash value. The value of 'hashset' is
3407 * stored at the call to dispatch. This allows to have
3408 * different 'formulas' for calculating the hash value at
3409 * different places where dispatch is called. This allows
3410 * to optimize the hash formula at every individual place
3411 * where dispatch is called, such that hopefully the hash
3412 * value that is computed will directly point to the right
3413 * method in the method cache. */
3414 unsigned long int hashset
= SCM_INUM (tmp
);
3415 unsigned long int counter
= specializers
+ 1;
3418 while (!SCM_NULLP (tmp_arg
) && counter
!= 0)
3420 SCM
class = scm_class_of (SCM_CAR (tmp_arg
));
3421 hash_value
+= SCM_INSTANCE_HASH (class, hashset
);
3422 tmp_arg
= SCM_CDR (tmp_arg
);
3426 method_cache
= SCM_CADR (z
);
3427 mask
= SCM_INUM (SCM_CAR (z
));
3429 cache_end_pos
= hash_value
;
3433 /* This method of determining the hash value is much
3434 * simpler: Set the hash value to zero and just perform a
3435 * linear search through the method cache. */
3437 mask
= (unsigned long int) ((long) -1);
3439 cache_end_pos
= SCM_VECTOR_LENGTH (method_cache
);
3444 /* Search the method cache for a method with a matching
3445 * signature. Start the search at position 'hash_value'. The
3446 * hashing implementation uses linear probing for conflict
3447 * resolution, that is, if the signature in question is not
3448 * found at the starting index in the hash table, the next table
3449 * entry is tried, and so on, until in the worst case the whole
3450 * cache has been searched, but still the signature has not been
3455 SCM args
= arg1
; /* list of arguments */
3456 z
= SCM_VELTS (method_cache
)[hash_value
];
3457 while (!SCM_NULLP (args
))
3459 /* More arguments than specifiers => CLASS != ENV */
3460 SCM class_of_arg
= scm_class_of (SCM_CAR (args
));
3461 if (!SCM_EQ_P (class_of_arg
, SCM_CAR (z
)))
3463 args
= SCM_CDR (args
);
3466 /* Fewer arguments than specifiers => CAR != ENV */
3467 if (SCM_NULLP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
)))
3470 hash_value
= (hash_value
+ 1) & mask
;
3471 } while (hash_value
!= cache_end_pos
);
3473 /* No appropriate method was found in the cache. */
3474 z
= scm_memoize_method (x
, arg1
);
3476 apply_cmethod
: /* inputs: z, arg1 */
3478 SCM formals
= SCM_CMETHOD_FORMALS (z
);
3479 env
= SCM_EXTEND_ENV (formals
, arg1
, SCM_CMETHOD_ENV (z
));
3480 x
= SCM_CMETHOD_BODY (z
);
3481 goto nontoplevel_begin
;
3487 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
3490 SCM instance
= EVALCAR (x
, env
);
3491 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
3492 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance
) [slot
]));
3496 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
3499 SCM instance
= EVALCAR (x
, env
);
3500 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
3501 SCM value
= EVALCAR (SCM_CDDR (x
), env
);
3502 SCM_STRUCT_DATA (instance
) [slot
] = SCM_UNPACK (value
);
3503 RETURN (SCM_UNSPECIFIED
);
3507 #if SCM_ENABLE_ELISP
3509 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
3511 SCM test_form
= SCM_CDR (x
);
3512 x
= SCM_CDR (test_form
);
3513 while (!SCM_NULL_OR_NIL_P (x
))
3515 SCM test_result
= EVALCAR (test_form
, env
);
3516 if (!(SCM_FALSEP (test_result
)
3517 || SCM_NULL_OR_NIL_P (test_result
)))
3519 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
3520 RETURN (test_result
);
3521 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3526 test_form
= SCM_CDR (x
);
3527 x
= SCM_CDR (test_form
);
3531 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3535 #endif /* SCM_ENABLE_ELISP */
3537 case (SCM_ISYMNUM (SCM_IM_BIND
)):
3539 SCM vars
, exps
, vals
;
3542 vars
= SCM_CAAR (x
);
3543 exps
= SCM_CDAR (x
);
3545 while (!SCM_NULLP (exps
))
3547 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
3548 exps
= SCM_CDR (exps
);
3551 scm_swap_bindings (vars
, vals
);
3552 scm_dynwinds
= scm_acons (vars
, vals
, scm_dynwinds
);
3554 /* Ignore all but the last evaluation result. */
3555 for (x
= SCM_CDR (x
); !SCM_NULLP (SCM_CDR (x
)); x
= SCM_CDR (x
))
3557 if (SCM_CONSP (SCM_CAR (x
)))
3558 CEVAL (SCM_CAR (x
), env
);
3560 proc
= EVALCAR (x
, env
);
3562 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
3563 scm_swap_bindings (vars
, vals
);
3569 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
3574 producer
= EVALCAR (x
, env
);
3576 proc
= EVALCAR (x
, env
); /* proc is the consumer. */
3577 arg1
= SCM_APPLY (producer
, SCM_EOL
, SCM_EOL
);
3578 if (SCM_VALUESP (arg1
))
3580 /* The list of arguments is not copied. Rather, it is assumed
3581 * that this has been done by the 'values' procedure. */
3582 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
3586 arg1
= scm_list_1 (arg1
);
3588 PREP_APPLY (proc
, arg1
);
3599 if (SCM_VARIABLEP (SCM_CAR (x
)))
3600 proc
= SCM_VARIABLE_REF (SCM_CAR (x
));
3601 else if (SCM_ILOCP (SCM_CAR (x
)))
3602 proc
= *scm_ilookup (SCM_CAR (x
), env
);
3603 else if (SCM_CONSP (SCM_CAR (x
)))
3604 proc
= CEVAL (SCM_CAR (x
), env
);
3605 else if (SCM_SYMBOLP (SCM_CAR (x
)))
3607 SCM orig_sym
= SCM_CAR (x
);
3609 SCM
*location
= scm_lookupcar1 (x
, env
, 1);
3610 if (location
== NULL
)
3612 /* we have lost the race, start again. */
3618 if (SCM_MACROP (proc
))
3620 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
3622 handle_a_macro
: /* inputs: x, env, proc */
3624 /* Set a flag during macro expansion so that macro
3625 application frames can be deleted from the backtrace. */
3626 SCM_SET_MACROEXP (debug
);
3628 arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
3629 scm_cons (env
, scm_listofnull
));
3631 SCM_CLEAR_MACROEXP (debug
);
3633 switch (SCM_MACRO_TYPE (proc
))
3637 if (scm_ilength (arg1
) <= 0)
3638 arg1
= scm_list_2 (SCM_IM_BEGIN
, arg1
);
3640 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
3643 SCM_SETCAR (x
, SCM_CAR (arg1
));
3644 SCM_SETCDR (x
, SCM_CDR (arg1
));
3648 /* Prevent memoizing of debug info expression. */
3649 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
3654 SCM_SETCAR (x
, SCM_CAR (arg1
));
3655 SCM_SETCDR (x
, SCM_CDR (arg1
));
3657 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3659 #if SCM_ENABLE_DEPRECATED == 1
3664 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3678 if (SCM_MACROP (proc
))
3679 goto handle_a_macro
;
3683 /* When reaching this part of the code, the following is granted: Variable x
3684 * holds the first pair of an expression of the form (<function> arg ...).
3685 * Variable proc holds the object that resulted from the evaluation of
3686 * <function>. In the following, the arguments (if any) will be evaluated,
3687 * and proc will be applied to them. If proc does not really hold a
3688 * function object, this will be signalled as an error on the scheme
3689 * level. If the number of arguments does not match the number of arguments
3690 * that are allowed to be passed to proc, also an error on the scheme level
3691 * will be signalled. */
3692 PREP_APPLY (proc
, SCM_EOL
);
3693 if (SCM_NULLP (SCM_CDR (x
))) {
3696 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3697 switch (SCM_TYP7 (proc
))
3698 { /* no arguments given */
3699 case scm_tc7_subr_0
:
3700 RETURN (SCM_SUBRF (proc
) ());
3701 case scm_tc7_subr_1o
:
3702 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
3704 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
3705 case scm_tc7_rpsubr
:
3706 RETURN (SCM_BOOL_T
);
3708 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
3710 if (!SCM_SMOB_APPLICABLE_P (proc
))
3712 RETURN (SCM_SMOB_APPLY_0 (proc
));
3715 proc
= SCM_CCLO_SUBR (proc
);
3717 debug
.info
->a
.proc
= proc
;
3718 debug
.info
->a
.args
= scm_list_1 (arg1
);
3722 proc
= SCM_PROCEDURE (proc
);
3724 debug
.info
->a
.proc
= proc
;
3726 if (!SCM_CLOSUREP (proc
))
3729 case scm_tcs_closures
:
3731 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3732 if (SCM_CONSP (formals
))
3733 goto umwrongnumargs
;
3734 x
= SCM_CLOSURE_BODY (proc
);
3735 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
3736 goto nontoplevel_begin
;
3738 case scm_tcs_struct
:
3739 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3741 x
= SCM_ENTITY_PROCEDURE (proc
);
3745 else if (SCM_I_OPERATORP (proc
))
3748 proc
= (SCM_I_ENTITYP (proc
)
3749 ? SCM_ENTITY_PROCEDURE (proc
)
3750 : SCM_OPERATOR_PROCEDURE (proc
));
3752 debug
.info
->a
.proc
= proc
;
3753 debug
.info
->a
.args
= scm_list_1 (arg1
);
3759 case scm_tc7_subr_1
:
3760 case scm_tc7_subr_2
:
3761 case scm_tc7_subr_2o
:
3764 case scm_tc7_subr_3
:
3765 case scm_tc7_lsubr_2
:
3768 scm_wrong_num_args (proc
);
3771 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
3775 /* must handle macros by here */
3778 arg1
= EVALCAR (x
, env
);
3780 scm_wrong_num_args (proc
);
3782 debug
.info
->a
.args
= scm_list_1 (arg1
);
3790 evap1
: /* inputs: proc, arg1 */
3791 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3792 switch (SCM_TYP7 (proc
))
3793 { /* have one argument in arg1 */
3794 case scm_tc7_subr_2o
:
3795 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3796 case scm_tc7_subr_1
:
3797 case scm_tc7_subr_1o
:
3798 RETURN (SCM_SUBRF (proc
) (arg1
));
3800 if (SCM_INUMP (arg1
))
3802 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3804 else if (SCM_REALP (arg1
))
3806 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3808 else if (SCM_BIGP (arg1
))
3810 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3812 else if (SCM_FRACTIONP (arg1
))
3814 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
3816 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3817 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3820 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
3823 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
3824 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3825 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3830 case scm_tc7_rpsubr
:
3831 RETURN (SCM_BOOL_T
);
3833 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3836 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3838 RETURN (SCM_SUBRF (proc
) (scm_list_1 (arg1
)));
3841 if (!SCM_SMOB_APPLICABLE_P (proc
))
3843 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
3847 proc
= SCM_CCLO_SUBR (proc
);
3849 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
3850 debug
.info
->a
.proc
= proc
;
3854 proc
= SCM_PROCEDURE (proc
);
3856 debug
.info
->a
.proc
= proc
;
3858 if (!SCM_CLOSUREP (proc
))
3861 case scm_tcs_closures
:
3864 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3865 if (SCM_NULLP (formals
)
3866 || (SCM_CONSP (formals
) && SCM_CONSP (SCM_CDR (formals
))))
3867 goto umwrongnumargs
;
3868 x
= SCM_CLOSURE_BODY (proc
);
3870 env
= SCM_EXTEND_ENV (formals
,
3874 env
= SCM_EXTEND_ENV (formals
,
3878 goto nontoplevel_begin
;
3880 case scm_tcs_struct
:
3881 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3883 x
= SCM_ENTITY_PROCEDURE (proc
);
3885 arg1
= debug
.info
->a
.args
;
3887 arg1
= scm_list_1 (arg1
);
3891 else if (SCM_I_OPERATORP (proc
))
3895 proc
= (SCM_I_ENTITYP (proc
)
3896 ? SCM_ENTITY_PROCEDURE (proc
)
3897 : SCM_OPERATOR_PROCEDURE (proc
));
3899 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
3900 debug
.info
->a
.proc
= proc
;
3906 case scm_tc7_subr_2
:
3907 case scm_tc7_subr_0
:
3908 case scm_tc7_subr_3
:
3909 case scm_tc7_lsubr_2
:
3910 scm_wrong_num_args (proc
);
3916 arg2
= EVALCAR (x
, env
);
3918 scm_wrong_num_args (proc
);
3920 { /* have two or more arguments */
3922 debug
.info
->a
.args
= scm_list_2 (arg1
, arg2
);
3925 if (SCM_NULLP (x
)) {
3928 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3929 switch (SCM_TYP7 (proc
))
3930 { /* have two arguments */
3931 case scm_tc7_subr_2
:
3932 case scm_tc7_subr_2o
:
3933 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3936 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3938 RETURN (SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
)));
3940 case scm_tc7_lsubr_2
:
3941 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
));
3942 case scm_tc7_rpsubr
:
3944 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3946 if (!SCM_SMOB_APPLICABLE_P (proc
))
3948 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
));
3952 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3953 scm_cons (proc
, debug
.info
->a
.args
),
3956 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3957 scm_cons2 (proc
, arg1
,
3964 case scm_tcs_struct
:
3965 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3967 x
= SCM_ENTITY_PROCEDURE (proc
);
3969 arg1
= debug
.info
->a
.args
;
3971 arg1
= scm_list_2 (arg1
, arg2
);
3975 else if (SCM_I_OPERATORP (proc
))
3979 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3980 ? SCM_ENTITY_PROCEDURE (proc
)
3981 : SCM_OPERATOR_PROCEDURE (proc
),
3982 scm_cons (proc
, debug
.info
->a
.args
),
3985 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3986 ? SCM_ENTITY_PROCEDURE (proc
)
3987 : SCM_OPERATOR_PROCEDURE (proc
),
3988 scm_cons2 (proc
, arg1
,
3998 case scm_tc7_subr_0
:
4001 case scm_tc7_subr_1o
:
4002 case scm_tc7_subr_1
:
4003 case scm_tc7_subr_3
:
4004 scm_wrong_num_args (proc
);
4008 proc
= SCM_PROCEDURE (proc
);
4010 debug
.info
->a
.proc
= proc
;
4012 if (!SCM_CLOSUREP (proc
))
4015 case scm_tcs_closures
:
4018 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4019 if (SCM_NULLP (formals
)
4020 || (SCM_CONSP (formals
)
4021 && (SCM_NULLP (SCM_CDR (formals
))
4022 || (SCM_CONSP (SCM_CDR (formals
))
4023 && SCM_CONSP (SCM_CDDR (formals
))))))
4024 goto umwrongnumargs
;
4026 env
= SCM_EXTEND_ENV (formals
,
4030 env
= SCM_EXTEND_ENV (formals
,
4031 scm_list_2 (arg1
, arg2
),
4034 x
= SCM_CLOSURE_BODY (proc
);
4035 goto nontoplevel_begin
;
4040 scm_wrong_num_args (proc
);
4042 debug
.info
->a
.args
= scm_cons2 (arg1
, arg2
,
4043 deval_args (x
, env
, proc
,
4044 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
4048 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4049 switch (SCM_TYP7 (proc
))
4050 { /* have 3 or more arguments */
4052 case scm_tc7_subr_3
:
4053 if (!SCM_NULLP (SCM_CDR (x
)))
4054 scm_wrong_num_args (proc
);
4056 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4057 SCM_CADDR (debug
.info
->a
.args
)));
4059 arg1
= SCM_SUBRF(proc
)(arg1
, arg2
);
4060 arg2
= SCM_CDDR (debug
.info
->a
.args
);
4063 arg1
= SCM_SUBRF(proc
)(arg1
, SCM_CAR (arg2
));
4064 arg2
= SCM_CDR (arg2
);
4066 while (SCM_NIMP (arg2
));
4068 case scm_tc7_rpsubr
:
4069 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
4070 RETURN (SCM_BOOL_F
);
4071 arg1
= SCM_CDDR (debug
.info
->a
.args
);
4074 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (arg1
))))
4075 RETURN (SCM_BOOL_F
);
4076 arg2
= SCM_CAR (arg1
);
4077 arg1
= SCM_CDR (arg1
);
4079 while (SCM_NIMP (arg1
));
4080 RETURN (SCM_BOOL_T
);
4081 case scm_tc7_lsubr_2
:
4082 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4083 SCM_CDDR (debug
.info
->a
.args
)));
4085 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4087 if (!SCM_SMOB_APPLICABLE_P (proc
))
4089 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4090 SCM_CDDR (debug
.info
->a
.args
)));
4094 proc
= SCM_PROCEDURE (proc
);
4095 debug
.info
->a
.proc
= proc
;
4096 if (!SCM_CLOSUREP (proc
))
4099 case scm_tcs_closures
:
4101 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4102 if (SCM_NULLP (formals
)
4103 || (SCM_CONSP (formals
)
4104 && (SCM_NULLP (SCM_CDR (formals
))
4105 || (SCM_CONSP (SCM_CDR (formals
))
4106 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4107 goto umwrongnumargs
;
4108 SCM_SET_ARGSREADY (debug
);
4109 env
= SCM_EXTEND_ENV (formals
,
4112 x
= SCM_CLOSURE_BODY (proc
);
4113 goto nontoplevel_begin
;
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
, EVALCAR (x
, env
)));
4122 arg1
= SCM_SUBRF (proc
) (arg1
, arg2
);
4125 arg1
= SCM_SUBRF(proc
)(arg1
, EVALCAR(x
, env
));
4128 while (!SCM_NULLP (x
));
4130 case scm_tc7_rpsubr
:
4131 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
4132 RETURN (SCM_BOOL_F
);
4135 arg1
= EVALCAR (x
, env
);
4136 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, arg1
)))
4137 RETURN (SCM_BOOL_F
);
4141 while (!SCM_NULLP (x
));
4142 RETURN (SCM_BOOL_T
);
4143 case scm_tc7_lsubr_2
:
4144 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
4146 RETURN (SCM_SUBRF (proc
) (scm_cons2 (arg1
,
4148 scm_eval_args (x
, env
, proc
))));
4150 if (!SCM_SMOB_APPLICABLE_P (proc
))
4152 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4153 scm_eval_args (x
, env
, proc
)));
4157 proc
= SCM_PROCEDURE (proc
);
4158 if (!SCM_CLOSUREP (proc
))
4161 case scm_tcs_closures
:
4163 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4164 if (SCM_NULLP (formals
)
4165 || (SCM_CONSP (formals
)
4166 && (SCM_NULLP (SCM_CDR (formals
))
4167 || (SCM_CONSP (SCM_CDR (formals
))
4168 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4169 goto umwrongnumargs
;
4170 env
= SCM_EXTEND_ENV (formals
,
4173 scm_eval_args (x
, env
, proc
)),
4175 x
= SCM_CLOSURE_BODY (proc
);
4176 goto nontoplevel_begin
;
4179 case scm_tcs_struct
:
4180 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4183 arg1
= debug
.info
->a
.args
;
4185 arg1
= scm_cons2 (arg1
, arg2
, scm_eval_args (x
, env
, proc
));
4187 x
= SCM_ENTITY_PROCEDURE (proc
);
4190 else if (SCM_I_OPERATORP (proc
))
4194 case scm_tc7_subr_2
:
4195 case scm_tc7_subr_1o
:
4196 case scm_tc7_subr_2o
:
4197 case scm_tc7_subr_0
:
4200 case scm_tc7_subr_1
:
4201 scm_wrong_num_args (proc
);
4209 if (scm_check_exit_p
&& SCM_TRAPS_P
)
4210 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
4212 SCM_CLEAR_TRACED_FRAME (debug
);
4213 if (SCM_CHEAPTRAPS_P
)
4214 arg1
= scm_make_debugobj (&debug
);
4218 SCM val
= scm_make_continuation (&first
);
4229 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
4233 scm_last_debug_frame
= debug
.prev
;
4239 /* SECTION: This code is compiled once.
4246 /* Simple procedure calls
4250 scm_call_0 (SCM proc
)
4252 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
4256 scm_call_1 (SCM proc
, SCM arg1
)
4258 return scm_apply (proc
, arg1
, scm_listofnull
);
4262 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
4264 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
4268 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
4270 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
4274 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
4276 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
4277 scm_cons (arg4
, scm_listofnull
)));
4280 /* Simple procedure applies
4284 scm_apply_0 (SCM proc
, SCM args
)
4286 return scm_apply (proc
, args
, SCM_EOL
);
4290 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
4292 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
4296 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
4298 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
4302 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
4304 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
4308 /* This code processes the arguments to apply:
4310 (apply PROC ARG1 ... ARGS)
4312 Given a list (ARG1 ... ARGS), this function conses the ARG1
4313 ... arguments onto the front of ARGS, and returns the resulting
4314 list. Note that ARGS is a list; thus, the argument to this
4315 function is a list whose last element is a list.
4317 Apply calls this function, and applies PROC to the elements of the
4318 result. apply:nconc2last takes care of building the list of
4319 arguments, given (ARG1 ... ARGS).
4321 Rather than do new consing, apply:nconc2last destroys its argument.
4322 On that topic, this code came into my care with the following
4323 beautifully cryptic comment on that topic: "This will only screw
4324 you if you do (scm_apply scm_apply '( ... ))" If you know what
4325 they're referring to, send me a patch to this comment. */
4327 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
4329 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
4330 "conses the @var{arg1} @dots{} arguments onto the front of\n"
4331 "@var{args}, and returns the resulting list. Note that\n"
4332 "@var{args} is a list; thus, the argument to this function is\n"
4333 "a list whose last element is a list.\n"
4334 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
4335 "destroys its argument, so use with care.")
4336 #define FUNC_NAME s_scm_nconc2last
4339 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
4341 while (!SCM_NULLP (SCM_CDR (*lloc
))) /* Perhaps should be
4342 SCM_NULL_OR_NIL_P, but not
4343 needed in 99.99% of cases,
4344 and it could seriously hurt
4345 performance. - Neil */
4346 lloc
= SCM_CDRLOC (*lloc
);
4347 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
4348 *lloc
= SCM_CAR (*lloc
);
4356 /* SECTION: When DEVAL is defined this code yields scm_dapply.
4357 * It is compiled twice.
4362 scm_apply (SCM proc
, SCM arg1
, SCM args
)
4368 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
4373 /* Apply a function to a list of arguments.
4375 This function is exported to the Scheme level as taking two
4376 required arguments and a tail argument, as if it were:
4377 (lambda (proc arg1 . args) ...)
4378 Thus, if you just have a list of arguments to pass to a procedure,
4379 pass the list as ARG1, and '() for ARGS. If you have some fixed
4380 args, pass the first as ARG1, then cons any remaining fixed args
4381 onto the front of your argument list, and pass that as ARGS. */
4384 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
4387 scm_t_debug_frame debug
;
4388 scm_t_debug_info debug_vect_body
;
4389 debug
.prev
= scm_last_debug_frame
;
4390 debug
.status
= SCM_APPLYFRAME
;
4391 debug
.vect
= &debug_vect_body
;
4392 debug
.vect
[0].a
.proc
= proc
;
4393 debug
.vect
[0].a
.args
= SCM_EOL
;
4394 scm_last_debug_frame
= &debug
;
4396 if (scm_debug_mode_p
)
4397 return scm_dapply (proc
, arg1
, args
);
4400 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
4402 /* If ARGS is the empty list, then we're calling apply with only two
4403 arguments --- ARG1 is the list of arguments for PROC. Whatever
4404 the case, futz with things so that ARG1 is the first argument to
4405 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
4408 Setting the debug apply frame args this way is pretty messy.
4409 Perhaps we should store arg1 and args directly in the frame as
4410 received, and let scm_frame_arguments unpack them, because that's
4411 a relatively rare operation. This works for now; if the Guile
4412 developer archives are still around, see Mikael's post of
4414 if (SCM_NULLP (args
))
4416 if (SCM_NULLP (arg1
))
4418 arg1
= SCM_UNDEFINED
;
4420 debug
.vect
[0].a
.args
= SCM_EOL
;
4426 debug
.vect
[0].a
.args
= arg1
;
4428 args
= SCM_CDR (arg1
);
4429 arg1
= SCM_CAR (arg1
);
4434 args
= scm_nconc2last (args
);
4436 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4440 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
4443 if (SCM_CHEAPTRAPS_P
)
4444 tmp
= scm_make_debugobj (&debug
);
4449 tmp
= scm_make_continuation (&first
);
4454 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
4461 switch (SCM_TYP7 (proc
))
4463 case scm_tc7_subr_2o
:
4464 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
4465 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4466 case scm_tc7_subr_2
:
4467 if (SCM_NULLP (args
) || !SCM_NULLP (SCM_CDR (args
)))
4468 scm_wrong_num_args (proc
);
4469 args
= SCM_CAR (args
);
4470 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4471 case scm_tc7_subr_0
:
4472 if (!SCM_UNBNDP (arg1
))
4473 scm_wrong_num_args (proc
);
4475 RETURN (SCM_SUBRF (proc
) ());
4476 case scm_tc7_subr_1
:
4477 if (SCM_UNBNDP (arg1
))
4478 scm_wrong_num_args (proc
);
4479 case scm_tc7_subr_1o
:
4480 if (!SCM_NULLP (args
))
4481 scm_wrong_num_args (proc
);
4483 RETURN (SCM_SUBRF (proc
) (arg1
));
4485 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
4486 scm_wrong_num_args (proc
);
4487 if (SCM_INUMP (arg1
))
4489 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
4491 else if (SCM_REALP (arg1
))
4493 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4495 else if (SCM_BIGP (arg1
))
4497 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4499 else if (SCM_FRACTIONP (arg1
))
4501 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4503 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4504 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4506 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
4507 scm_wrong_num_args (proc
);
4509 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
4512 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
4513 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4514 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
4519 case scm_tc7_subr_3
:
4520 if (SCM_NULLP (args
)
4521 || SCM_NULLP (SCM_CDR (args
))
4522 || !SCM_NULLP (SCM_CDDR (args
)))
4523 scm_wrong_num_args (proc
);
4525 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
4528 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
4530 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
4532 case scm_tc7_lsubr_2
:
4533 if (!SCM_CONSP (args
))
4534 scm_wrong_num_args (proc
);
4536 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4538 if (SCM_NULLP (args
))
4539 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4540 while (SCM_NIMP (args
))
4542 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
4543 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
4544 args
= SCM_CDR (args
);
4547 case scm_tc7_rpsubr
:
4548 if (SCM_NULLP (args
))
4549 RETURN (SCM_BOOL_T
);
4550 while (SCM_NIMP (args
))
4552 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
4553 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
4554 RETURN (SCM_BOOL_F
);
4555 arg1
= SCM_CAR (args
);
4556 args
= SCM_CDR (args
);
4558 RETURN (SCM_BOOL_T
);
4559 case scm_tcs_closures
:
4561 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4563 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4565 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
4566 scm_wrong_num_args (proc
);
4568 /* Copy argument list */
4573 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
4574 for (arg1
= SCM_CDR (arg1
); SCM_CONSP (arg1
); arg1
= SCM_CDR (arg1
))
4576 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
));
4579 SCM_SETCDR (tl
, arg1
);
4582 args
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4585 proc
= SCM_CLOSURE_BODY (proc
);
4587 arg1
= SCM_CDR (proc
);
4588 while (!SCM_NULLP (arg1
))
4590 if (SCM_IMP (SCM_CAR (proc
)))
4592 if (SCM_ISYMP (SCM_CAR (proc
)))
4594 scm_rec_mutex_lock (&source_mutex
);
4595 /* check for race condition */
4596 if (SCM_ISYMP (SCM_CAR (proc
)))
4597 m_expand_body (proc
, args
);
4598 scm_rec_mutex_unlock (&source_mutex
);
4602 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
4605 EVAL (SCM_CAR (proc
), args
);
4607 arg1
= SCM_CDR (proc
);
4609 RETURN (EVALCAR (proc
, args
));
4611 if (!SCM_SMOB_APPLICABLE_P (proc
))
4613 if (SCM_UNBNDP (arg1
))
4614 RETURN (SCM_SMOB_APPLY_0 (proc
));
4615 else if (SCM_NULLP (args
))
4616 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
4617 else if (SCM_NULLP (SCM_CDR (args
)))
4618 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
4620 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4623 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4625 proc
= SCM_CCLO_SUBR (proc
);
4626 debug
.vect
[0].a
.proc
= proc
;
4627 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4629 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4631 proc
= SCM_CCLO_SUBR (proc
);
4635 proc
= SCM_PROCEDURE (proc
);
4637 debug
.vect
[0].a
.proc
= proc
;
4640 case scm_tcs_struct
:
4641 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4644 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4646 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4648 RETURN (scm_apply_generic (proc
, args
));
4650 else if (SCM_I_OPERATORP (proc
))
4654 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4656 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4659 proc
= (SCM_I_ENTITYP (proc
)
4660 ? SCM_ENTITY_PROCEDURE (proc
)
4661 : SCM_OPERATOR_PROCEDURE (proc
));
4663 debug
.vect
[0].a
.proc
= proc
;
4664 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4666 if (SCM_NIMP (proc
))
4675 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
4679 if (scm_check_exit_p
&& SCM_TRAPS_P
)
4680 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
4682 SCM_CLEAR_TRACED_FRAME (debug
);
4683 if (SCM_CHEAPTRAPS_P
)
4684 arg1
= scm_make_debugobj (&debug
);
4688 SCM val
= scm_make_continuation (&first
);
4699 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
4703 scm_last_debug_frame
= debug
.prev
;
4709 /* SECTION: The rest of this file is only read once.
4716 * Trampolines make it possible to move procedure application dispatch
4717 * outside inner loops. The motivation was clean implementation of
4718 * efficient replacements of R5RS primitives in SRFI-1.
4720 * The semantics is clear: scm_trampoline_N returns an optimized
4721 * version of scm_call_N (or NULL if the procedure isn't applicable
4724 * Applying the optimization to map and for-each increased efficiency
4725 * noticeably. For example, (map abs ls) is now 8 times faster than
4730 call_subr0_0 (SCM proc
)
4732 return SCM_SUBRF (proc
) ();
4736 call_subr1o_0 (SCM proc
)
4738 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
4742 call_lsubr_0 (SCM proc
)
4744 return SCM_SUBRF (proc
) (SCM_EOL
);
4748 scm_i_call_closure_0 (SCM proc
)
4750 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4753 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
4758 scm_trampoline_0 (SCM proc
)
4760 scm_t_trampoline_0 trampoline
;
4765 switch (SCM_TYP7 (proc
))
4767 case scm_tc7_subr_0
:
4768 trampoline
= call_subr0_0
;
4770 case scm_tc7_subr_1o
:
4771 trampoline
= call_subr1o_0
;
4774 trampoline
= call_lsubr_0
;
4776 case scm_tcs_closures
:
4778 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4779 if (SCM_NULLP (formals
) || !SCM_CONSP (formals
))
4780 trampoline
= scm_i_call_closure_0
;
4785 case scm_tcs_struct
:
4786 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4787 trampoline
= scm_call_generic_0
;
4788 else if (SCM_I_OPERATORP (proc
))
4789 trampoline
= scm_call_0
;
4794 if (SCM_SMOB_APPLICABLE_P (proc
))
4795 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
4800 case scm_tc7_rpsubr
:
4803 trampoline
= scm_call_0
;
4806 return NULL
; /* not applicable on zero arguments */
4808 /* We only reach this point if a valid trampoline was determined. */
4810 /* If debugging is enabled, we want to see all calls to proc on the stack.
4811 * Thus, we replace the trampoline shortcut with scm_call_0. */
4812 if (scm_debug_mode_p
)
4819 call_subr1_1 (SCM proc
, SCM arg1
)
4821 return SCM_SUBRF (proc
) (arg1
);
4825 call_subr2o_1 (SCM proc
, SCM arg1
)
4827 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
4831 call_lsubr_1 (SCM proc
, SCM arg1
)
4833 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
4837 call_dsubr_1 (SCM proc
, SCM arg1
)
4839 if (SCM_INUMP (arg1
))
4841 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
4843 else if (SCM_REALP (arg1
))
4845 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4847 else if (SCM_BIGP (arg1
))
4849 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4851 else if (SCM_FRACTIONP (arg1
))
4853 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4855 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4856 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4860 call_cxr_1 (SCM proc
, SCM arg1
)
4862 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
4865 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
4866 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4867 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
4874 call_closure_1 (SCM proc
, SCM arg1
)
4876 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4879 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
4884 scm_trampoline_1 (SCM proc
)
4886 scm_t_trampoline_1 trampoline
;
4891 switch (SCM_TYP7 (proc
))
4893 case scm_tc7_subr_1
:
4894 case scm_tc7_subr_1o
:
4895 trampoline
= call_subr1_1
;
4897 case scm_tc7_subr_2o
:
4898 trampoline
= call_subr2o_1
;
4901 trampoline
= call_lsubr_1
;
4904 trampoline
= call_dsubr_1
;
4907 trampoline
= call_cxr_1
;
4909 case scm_tcs_closures
:
4911 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4912 if (!SCM_NULLP (formals
)
4913 && (!SCM_CONSP (formals
) || !SCM_CONSP (SCM_CDR (formals
))))
4914 trampoline
= call_closure_1
;
4919 case scm_tcs_struct
:
4920 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4921 trampoline
= scm_call_generic_1
;
4922 else if (SCM_I_OPERATORP (proc
))
4923 trampoline
= scm_call_1
;
4928 if (SCM_SMOB_APPLICABLE_P (proc
))
4929 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
4934 case scm_tc7_rpsubr
:
4937 trampoline
= scm_call_1
;
4940 return NULL
; /* not applicable on one arg */
4942 /* We only reach this point if a valid trampoline was determined. */
4944 /* If debugging is enabled, we want to see all calls to proc on the stack.
4945 * Thus, we replace the trampoline shortcut with scm_call_1. */
4946 if (scm_debug_mode_p
)
4953 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
4955 return SCM_SUBRF (proc
) (arg1
, arg2
);
4959 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
4961 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
4965 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
4967 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
4971 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
4973 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4974 scm_list_2 (arg1
, arg2
),
4976 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
4981 scm_trampoline_2 (SCM proc
)
4983 scm_t_trampoline_2 trampoline
;
4988 switch (SCM_TYP7 (proc
))
4990 case scm_tc7_subr_2
:
4991 case scm_tc7_subr_2o
:
4992 case scm_tc7_rpsubr
:
4994 trampoline
= call_subr2_2
;
4996 case scm_tc7_lsubr_2
:
4997 trampoline
= call_lsubr2_2
;
5000 trampoline
= call_lsubr_2
;
5002 case scm_tcs_closures
:
5004 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5005 if (!SCM_NULLP (formals
)
5006 && (!SCM_CONSP (formals
)
5007 || (!SCM_NULLP (SCM_CDR (formals
))
5008 && (!SCM_CONSP (SCM_CDR (formals
))
5009 || !SCM_CONSP (SCM_CDDR (formals
))))))
5010 trampoline
= call_closure_2
;
5015 case scm_tcs_struct
:
5016 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5017 trampoline
= scm_call_generic_2
;
5018 else if (SCM_I_OPERATORP (proc
))
5019 trampoline
= scm_call_2
;
5024 if (SCM_SMOB_APPLICABLE_P (proc
))
5025 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
5031 trampoline
= scm_call_2
;
5034 return NULL
; /* not applicable on two args */
5036 /* We only reach this point if a valid trampoline was determined. */
5038 /* If debugging is enabled, we want to see all calls to proc on the stack.
5039 * Thus, we replace the trampoline shortcut with scm_call_2. */
5040 if (scm_debug_mode_p
)
5046 /* Typechecking for multi-argument MAP and FOR-EACH.
5048 Verify that each element of the vector ARGV, except for the first,
5049 is a proper list whose length is LEN. Attribute errors to WHO,
5050 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
5052 check_map_args (SCM argv
,
5059 SCM
const *ve
= SCM_VELTS (argv
);
5062 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
5064 long elt_len
= scm_ilength (ve
[i
]);
5069 scm_apply_generic (gf
, scm_cons (proc
, args
));
5071 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
5075 scm_out_of_range_pos (who
, ve
[i
], SCM_MAKINUM (i
+ 2));
5078 scm_remember_upto_here_1 (argv
);
5082 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
5084 /* Note: Currently, scm_map applies PROC to the argument list(s)
5085 sequentially, starting with the first element(s). This is used in
5086 evalext.c where the Scheme procedure `map-in-order', which guarantees
5087 sequential behaviour, is implemented using scm_map. If the
5088 behaviour changes, we need to update `map-in-order'.
5092 scm_map (SCM proc
, SCM arg1
, SCM args
)
5093 #define FUNC_NAME s_map
5098 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
5100 len
= scm_ilength (arg1
);
5101 SCM_GASSERTn (len
>= 0,
5102 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
5103 SCM_VALIDATE_REST_ARGUMENT (args
);
5104 if (SCM_NULLP (args
))
5106 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5107 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
5108 while (SCM_NIMP (arg1
))
5110 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
5111 pres
= SCM_CDRLOC (*pres
);
5112 arg1
= SCM_CDR (arg1
);
5116 if (SCM_NULLP (SCM_CDR (args
)))
5118 SCM arg2
= SCM_CAR (args
);
5119 int len2
= scm_ilength (arg2
);
5120 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5122 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
5123 SCM_GASSERTn (len2
>= 0,
5124 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
5126 SCM_OUT_OF_RANGE (3, arg2
);
5127 while (SCM_NIMP (arg1
))
5129 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
5130 pres
= SCM_CDRLOC (*pres
);
5131 arg1
= SCM_CDR (arg1
);
5132 arg2
= SCM_CDR (arg2
);
5136 arg1
= scm_cons (arg1
, args
);
5137 args
= scm_vector (arg1
);
5138 ve
= SCM_VELTS (args
);
5139 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
5143 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5145 if (SCM_IMP (ve
[i
]))
5147 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
5148 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
5150 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
5151 pres
= SCM_CDRLOC (*pres
);
5157 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
5160 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
5161 #define FUNC_NAME s_for_each
5163 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
5165 len
= scm_ilength (arg1
);
5166 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
5167 SCM_ARG2
, s_for_each
);
5168 SCM_VALIDATE_REST_ARGUMENT (args
);
5169 if (SCM_NULLP (args
))
5171 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5172 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
5173 while (SCM_NIMP (arg1
))
5175 call (proc
, SCM_CAR (arg1
));
5176 arg1
= SCM_CDR (arg1
);
5178 return SCM_UNSPECIFIED
;
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
);
5185 SCM_GASSERTn (call
, g_for_each
,
5186 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
5187 SCM_GASSERTn (len2
>= 0, g_for_each
,
5188 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
5190 SCM_OUT_OF_RANGE (3, arg2
);
5191 while (SCM_NIMP (arg1
))
5193 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
5194 arg1
= SCM_CDR (arg1
);
5195 arg2
= SCM_CDR (arg2
);
5197 return SCM_UNSPECIFIED
;
5199 arg1
= scm_cons (arg1
, args
);
5200 args
= scm_vector (arg1
);
5201 ve
= SCM_VELTS (args
);
5202 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
5206 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5208 if (SCM_IMP (ve
[i
]))
5209 return SCM_UNSPECIFIED
;
5210 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
5211 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
5213 scm_apply (proc
, arg1
, SCM_EOL
);
5220 scm_closure (SCM code
, SCM env
)
5223 SCM closcar
= scm_cons (code
, SCM_EOL
);
5224 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
5225 scm_remember_upto_here (closcar
);
5230 scm_t_bits scm_tc16_promise
;
5233 scm_makprom (SCM code
)
5235 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
5237 scm_make_rec_mutex ());
5241 promise_free (SCM promise
)
5243 scm_rec_mutex_free (SCM_PROMISE_MUTEX (promise
));
5248 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
5250 int writingp
= SCM_WRITINGP (pstate
);
5251 scm_puts ("#<promise ", port
);
5252 SCM_SET_WRITINGP (pstate
, 1);
5253 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
5254 SCM_SET_WRITINGP (pstate
, writingp
);
5255 scm_putc ('>', port
);
5259 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
5261 "If the promise @var{x} has not been computed yet, compute and\n"
5262 "return @var{x}, otherwise just return the previously computed\n"
5264 #define FUNC_NAME s_scm_force
5266 SCM_VALIDATE_SMOB (1, promise
, promise
);
5267 scm_rec_mutex_lock (SCM_PROMISE_MUTEX (promise
));
5268 if (!SCM_PROMISE_COMPUTED_P (promise
))
5270 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
5271 if (!SCM_PROMISE_COMPUTED_P (promise
))
5273 SCM_SET_PROMISE_DATA (promise
, ans
);
5274 SCM_SET_PROMISE_COMPUTED (promise
);
5277 scm_rec_mutex_unlock (SCM_PROMISE_MUTEX (promise
));
5278 return SCM_PROMISE_DATA (promise
);
5283 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
5285 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
5286 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
5287 #define FUNC_NAME s_scm_promise_p
5289 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
5294 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
5295 (SCM xorig
, SCM x
, SCM y
),
5296 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
5297 "Any source properties associated with @var{xorig} are also associated\n"
5298 "with the new pair.")
5299 #define FUNC_NAME s_scm_cons_source
5302 z
= scm_cons (x
, y
);
5303 /* Copy source properties possibly associated with xorig. */
5304 p
= scm_whash_lookup (scm_source_whash
, xorig
);
5306 scm_whash_insert (scm_source_whash
, z
, p
);
5312 /* The function scm_copy_tree is used to copy an expression tree to allow the
5313 * memoizer to modify the expression during memoization. scm_copy_tree
5314 * creates deep copies of pairs and vectors, but not of any other data types,
5315 * since only pairs and vectors will be parsed by the memoizer.
5317 * To avoid infinite recursion due to cyclic structures, the hare-and-tortoise
5318 * pattern is used to detect cycles. In fact, the pattern is used in two
5319 * dimensions, vertical (indicated in the code by the variable names 'hare'
5320 * and 'tortoise') and horizontal ('rabbit' and 'turtle'). In both
5321 * dimensions, the hare/rabbit will take two steps when the tortoise/turtle
5324 * The vertical dimension corresponds to recursive calls to function
5325 * copy_tree: This happens when descending into vector elements, into cars of
5326 * lists and into the cdr of an improper list. In this dimension, the
5327 * tortoise follows the hare by using the processor stack: Every stack frame
5328 * will hold an instance of struct t_trace. These instances are connected in
5329 * a way that represents the trace of the hare, which thus can be followed by
5330 * the tortoise. The tortoise will always point to struct t_trace instances
5331 * relating to SCM objects that have already been copied. Thus, a cycle is
5332 * detected if the tortoise and the hare point to the same object,
5334 * The horizontal dimension is within one execution of copy_tree, when the
5335 * function cdr's along the pairs of a list. This is the standard
5336 * hare-and-tortoise implementation, found several times in guile. */
5339 struct t_trace
*trace
; // These pointers form a trace along the stack.
5340 SCM obj
; // The object handled at the respective stack frame.
5345 struct t_trace
*const hare
,
5346 struct t_trace
*tortoise
,
5347 unsigned int tortoise_delay
)
5349 if (!SCM_CONSP (hare
->obj
) && !SCM_VECTORP (hare
->obj
))
5355 /* Prepare the trace along the stack. */
5356 struct t_trace new_hare
;
5357 hare
->trace
= &new_hare
;
5359 /* The tortoise will make its step after the delay has elapsed. Note
5360 * that in contrast to the typical hare-and-tortoise pattern, the step
5361 * of the tortoise happens before the hare takes its steps. This is, in
5362 * principle, no problem, except for the start of the algorithm: Then,
5363 * it has to be made sure that the hare actually gets its advantage of
5365 if (tortoise_delay
== 0)
5368 tortoise
= tortoise
->trace
;
5369 ASSERT_SYNTAX (!SCM_EQ_P (hare
->obj
, tortoise
->obj
),
5370 s_bad_expression
, hare
->obj
);
5377 if (SCM_VECTORP (hare
->obj
))
5379 const unsigned long int length
= SCM_VECTOR_LENGTH (hare
->obj
);
5380 const SCM new_vector
= scm_c_make_vector (length
, SCM_UNSPECIFIED
);
5382 /* Each vector element is copied by recursing into copy_tree, having
5383 * the tortoise follow the hare into the depths of the stack. */
5384 unsigned long int i
;
5385 for (i
= 0; i
< length
; ++i
)
5388 new_hare
.obj
= SCM_VECTOR_REF (hare
->obj
, i
);
5389 new_element
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5390 SCM_VECTOR_SET (new_vector
, i
, new_element
);
5395 else // SCM_CONSP (hare->obj)
5400 SCM rabbit
= hare
->obj
;
5401 SCM turtle
= hare
->obj
;
5405 /* The first pair of the list is treated specially, in order to
5406 * preserve a potential source code position. */
5407 result
= tail
= scm_cons_source (rabbit
, SCM_EOL
, SCM_EOL
);
5408 new_hare
.obj
= SCM_CAR (rabbit
);
5409 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5410 SCM_SETCAR (tail
, copy
);
5412 /* The remaining pairs of the list are copied by, horizontally,
5413 * having the turtle follow the rabbit, and, vertically, having the
5414 * tortoise follow the hare into the depths of the stack. */
5415 rabbit
= SCM_CDR (rabbit
);
5416 while (SCM_CONSP (rabbit
))
5418 new_hare
.obj
= SCM_CAR (rabbit
);
5419 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5420 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
5421 tail
= SCM_CDR (tail
);
5423 rabbit
= SCM_CDR (rabbit
);
5424 if (SCM_CONSP (rabbit
))
5426 new_hare
.obj
= SCM_CAR (rabbit
);
5427 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5428 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
5429 tail
= SCM_CDR (tail
);
5430 rabbit
= SCM_CDR (rabbit
);
5432 turtle
= SCM_CDR (turtle
);
5433 ASSERT_SYNTAX (!SCM_EQ_P (rabbit
, turtle
),
5434 s_bad_expression
, rabbit
);
5438 /* We have to recurse into copy_tree again for the last cdr, in
5439 * order to handle the situation that it holds a vector. */
5440 new_hare
.obj
= rabbit
;
5441 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5442 SCM_SETCDR (tail
, copy
);
5449 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
5451 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
5452 "the new data structure. @code{copy-tree} recurses down the\n"
5453 "contents of both pairs and vectors (since both cons cells and vector\n"
5454 "cells may point to arbitrary objects), and stops recursing when it hits\n"
5455 "any other object.")
5456 #define FUNC_NAME s_scm_copy_tree
5458 /* Prepare the trace along the stack. */
5459 struct t_trace trace
;
5462 /* In function copy_tree, if the tortoise makes its step, it will do this
5463 * before the hare has the chance to move. Thus, we have to make sure that
5464 * the very first step of the tortoise will not happen after the hare has
5465 * really made two steps. This is achieved by passing '2' as the initial
5466 * delay for the tortoise. NOTE: Since cycles are unlikely, giving the hare
5467 * a bigger advantage may improve performance slightly. */
5468 return copy_tree (&trace
, &trace
, 2);
5473 /* We have three levels of EVAL here:
5475 - scm_i_eval (exp, env)
5477 evaluates EXP in environment ENV. ENV is a lexical environment
5478 structure as used by the actual tree code evaluator. When ENV is
5479 a top-level environment, then changes to the current module are
5480 tracked by updating ENV so that it continues to be in sync with
5483 - scm_primitive_eval (exp)
5485 evaluates EXP in the top-level environment as determined by the
5486 current module. This is done by constructing a suitable
5487 environment and calling scm_i_eval. Thus, changes to the
5488 top-level module are tracked normally.
5490 - scm_eval (exp, mod)
5492 evaluates EXP while MOD is the current module. This is done by
5493 setting the current module to MOD, invoking scm_primitive_eval on
5494 EXP, and then restoring the current module to the value it had
5495 previously. That is, while EXP is evaluated, changes to the
5496 current module are tracked, but these changes do not persist when
5499 For each level of evals, there are two variants, distinguished by a
5500 _x suffix: the ordinary variant does not modify EXP while the _x
5501 variant can destructively modify EXP into something completely
5502 unintelligible. A Scheme data structure passed as EXP to one of the
5503 _x variants should not ever be used again for anything. So when in
5504 doubt, use the ordinary variant.
5509 scm_i_eval_x (SCM exp
, SCM env
)
5511 if (SCM_SYMBOLP (exp
))
5512 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
5514 return SCM_XEVAL (exp
, env
);
5518 scm_i_eval (SCM exp
, SCM env
)
5520 exp
= scm_copy_tree (exp
);
5521 if (SCM_SYMBOLP (exp
))
5522 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
5524 return SCM_XEVAL (exp
, env
);
5528 scm_primitive_eval_x (SCM exp
)
5531 SCM transformer
= scm_current_module_transformer ();
5532 if (SCM_NIMP (transformer
))
5533 exp
= scm_call_1 (transformer
, exp
);
5534 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5535 return scm_i_eval_x (exp
, env
);
5538 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
5540 "Evaluate @var{exp} in the top-level environment specified by\n"
5541 "the current module.")
5542 #define FUNC_NAME s_scm_primitive_eval
5545 SCM transformer
= scm_current_module_transformer ();
5546 if (SCM_NIMP (transformer
))
5547 exp
= scm_call_1 (transformer
, exp
);
5548 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5549 return scm_i_eval (exp
, env
);
5554 /* Eval does not take the second arg optionally. This is intentional
5555 * in order to be R5RS compatible, and to prepare for the new module
5556 * system, where we would like to make the choice of evaluation
5557 * environment explicit. */
5560 change_environment (void *data
)
5562 SCM pair
= SCM_PACK (data
);
5563 SCM new_module
= SCM_CAR (pair
);
5564 SCM old_module
= scm_current_module ();
5565 SCM_SETCDR (pair
, old_module
);
5566 scm_set_current_module (new_module
);
5570 restore_environment (void *data
)
5572 SCM pair
= SCM_PACK (data
);
5573 SCM old_module
= SCM_CDR (pair
);
5574 SCM new_module
= scm_current_module ();
5575 SCM_SETCAR (pair
, new_module
);
5576 scm_set_current_module (old_module
);
5580 inner_eval_x (void *data
)
5582 return scm_primitive_eval_x (SCM_PACK(data
));
5586 scm_eval_x (SCM exp
, SCM module
)
5587 #define FUNC_NAME "eval!"
5589 SCM_VALIDATE_MODULE (2, module
);
5591 return scm_internal_dynamic_wind
5592 (change_environment
, inner_eval_x
, restore_environment
,
5593 (void *) SCM_UNPACK (exp
),
5594 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
5599 inner_eval (void *data
)
5601 return scm_primitive_eval (SCM_PACK(data
));
5604 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
5605 (SCM exp
, SCM module
),
5606 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
5607 "in the top-level environment specified by @var{module}.\n"
5608 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
5609 "@var{module} is made the current module. The current module\n"
5610 "is reset to its previous value when @var{eval} returns.")
5611 #define FUNC_NAME s_scm_eval
5613 SCM_VALIDATE_MODULE (2, module
);
5615 return scm_internal_dynamic_wind
5616 (change_environment
, inner_eval
, restore_environment
,
5617 (void *) SCM_UNPACK (exp
),
5618 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
5623 /* At this point, deval and scm_dapply are generated.
5630 #if (SCM_ENABLE_DEPRECATED == 1)
5632 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5633 SCM
scm_ceval (SCM x
, SCM env
)
5636 return ceval (x
, env
);
5637 else if (SCM_SYMBOLP (x
))
5638 return *scm_lookupcar (scm_cons (x
, SCM_UNDEFINED
), env
, 1);
5640 return SCM_XEVAL (x
, env
);
5643 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5644 SCM
scm_deval (SCM x
, SCM env
)
5647 return deval (x
, env
);
5648 else if (SCM_SYMBOLP (x
))
5649 return *scm_lookupcar (scm_cons (x
, SCM_UNDEFINED
), env
, 1);
5651 return SCM_XEVAL (x
, env
);
5655 dispatching_eval (SCM x
, SCM env
)
5657 if (scm_debug_mode_p
)
5658 return scm_deval (x
, env
);
5660 return scm_ceval (x
, env
);
5663 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5664 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
) = dispatching_eval
;
5672 scm_init_opts (scm_evaluator_traps
,
5673 scm_evaluator_trap_table
,
5674 SCM_N_EVALUATOR_TRAPS
);
5675 scm_init_opts (scm_eval_options_interface
,
5677 SCM_N_EVAL_OPTIONS
);
5679 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
5680 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
5681 scm_set_smob_free (scm_tc16_promise
, promise_free
);
5682 scm_set_smob_print (scm_tc16_promise
, promise_print
);
5684 undefineds
= scm_list_1 (SCM_UNDEFINED
);
5685 SCM_SETCDR (undefineds
, undefineds
);
5686 scm_permanent_object (undefineds
);
5688 scm_listofnull
= scm_list_1 (SCM_EOL
);
5690 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
5691 scm_permanent_object (f_apply
);
5693 #include "libguile/eval.x"
5695 scm_add_feature ("delay");