1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008
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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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 /* This blob per the Autoconf manual (under "Particular Functions"), updated
39 to match that of Gnulib. */
43 # elif defined __GNUC__
44 # define alloca __builtin_alloca
46 # define alloca __alloca
47 # elif defined _MSC_VER
49 # define alloca _alloca
55 void *alloca (size_t);
60 #include "libguile/_scm.h"
61 #include "libguile/alist.h"
62 #include "libguile/async.h"
63 #include "libguile/continuations.h"
64 #include "libguile/debug.h"
65 #include "libguile/deprecation.h"
66 #include "libguile/dynwind.h"
67 #include "libguile/eq.h"
68 #include "libguile/feature.h"
69 #include "libguile/fluids.h"
70 #include "libguile/futures.h"
71 #include "libguile/goops.h"
72 #include "libguile/hash.h"
73 #include "libguile/hashtab.h"
74 #include "libguile/lang.h"
75 #include "libguile/list.h"
76 #include "libguile/macros.h"
77 #include "libguile/modules.h"
78 #include "libguile/objects.h"
79 #include "libguile/ports.h"
80 #include "libguile/print.h"
81 #include "libguile/procprop.h"
82 #include "libguile/root.h"
83 #include "libguile/smob.h"
84 #include "libguile/srcprop.h"
85 #include "libguile/stackchk.h"
86 #include "libguile/strings.h"
87 #include "libguile/threads.h"
88 #include "libguile/throw.h"
89 #include "libguile/validate.h"
90 #include "libguile/values.h"
91 #include "libguile/vectors.h"
93 #include "libguile/eval.h"
97 static SCM unmemoize_exprs (SCM expr, SCM env);
98 static SCM canonicalize_define (SCM expr);
99 static SCM *scm_lookupcar1 (SCM vloc, SCM genv, int check);
100 static SCM unmemoize_builtin_macro (SCM expr, SCM env);
101 static void eval_letrec_inits (SCM env, SCM init_forms, SCM **init_values_eol);
107 * This section defines the message strings for the syntax errors that can be
108 * detected during memoization and the functions and macros that shall be
109 * called by the memoizer code to signal syntax errors. */
112 /* Syntax errors that can be detected during memoization: */
114 /* Circular or improper lists do not form valid scheme expressions. If a
115 * circular list or an improper list is detected in a place where a scheme
116 * expression is expected, a 'Bad expression' error is signalled. */
117 static const char s_bad_expression[] = "Bad expression";
119 /* If a form is detected that holds a different number of expressions than are
120 * required in that context, a 'Missing or extra expression' error is
122 static const char s_expression[] = "Missing or extra expression in";
124 /* If a form is detected that holds less expressions than are required in that
125 * context, a 'Missing expression' error is signalled. */
126 static const char s_missing_expression[] = "Missing expression in";
128 /* If a form is detected that holds more expressions than are allowed in that
129 * context, an 'Extra expression' error is signalled. */
130 static const char s_extra_expression[] = "Extra expression in";
132 /* The empty combination '()' is not allowed as an expression in scheme. If
133 * it is detected in a place where an expression is expected, an 'Illegal
134 * empty combination' error is signalled. Note: If you encounter this error
135 * message, it is very likely that you intended to denote the empty list. To
136 * do so, you need to quote the empty list like (quote ()) or '(). */
137 static const char s_empty_combination[] = "Illegal empty combination";
139 /* A body may hold an arbitrary number of internal defines, followed by a
140 * non-empty sequence of expressions. If a body with an empty sequence of
141 * expressions is detected, a 'Missing body expression' error is signalled.
143 static const char s_missing_body_expression[] = "Missing body expression in";
145 /* A body may hold an arbitrary number of internal defines, followed by a
146 * non-empty sequence of expressions. Each the definitions and the
147 * expressions may be grouped arbitraryly with begin, but it is not allowed to
148 * mix definitions and expressions. If a define form in a body mixes
149 * definitions and expressions, a 'Mixed definitions and expressions' error is
151 static const char s_mixed_body_forms[] = "Mixed definitions and expressions in";
152 /* Definitions are only allowed on the top level and at the start of a body.
153 * If a definition is detected anywhere else, a 'Bad define placement' error
155 static const char s_bad_define[] = "Bad define placement";
157 /* Case or cond expressions must have at least one clause. If a case or cond
158 * expression without any clauses is detected, a 'Missing clauses' error is
160 static const char s_missing_clauses[] = "Missing clauses";
162 /* If there is an 'else' clause in a case or a cond statement, it must be the
163 * last clause. If after the 'else' case clause further clauses are detected,
164 * a 'Misplaced else clause' error is signalled. */
165 static const char s_misplaced_else_clause[] = "Misplaced else clause";
167 /* If a case clause is detected that is not in the format
168 * (<label(s)> <expression1> <expression2> ...)
169 * a 'Bad case clause' error is signalled. */
170 static const char s_bad_case_clause[] = "Bad case clause";
172 /* If a case clause is detected where the <label(s)> element is neither a
173 * proper list nor (in case of the last clause) the syntactic keyword 'else',
174 * a 'Bad case labels' error is signalled. Note: If you encounter this error
175 * for an else-clause which seems to be syntactically correct, check if 'else'
176 * is really a syntactic keyword in that context. If 'else' is bound in the
177 * local or global environment, it is not considered a syntactic keyword, but
178 * will be treated as any other variable. */
179 static const char s_bad_case_labels[] = "Bad case labels";
181 /* In a case statement all labels have to be distinct. If in a case statement
182 * a label occurs more than once, a 'Duplicate case label' error is
184 static const char s_duplicate_case_label[] = "Duplicate case label";
186 /* If a cond clause is detected that is not in one of the formats
187 * (<test> <expression1> ...) or (else <expression1> <expression2> ...)
188 * a 'Bad cond clause' error is signalled. */
189 static const char s_bad_cond_clause[] = "Bad cond clause";
191 /* If a cond clause is detected that uses the alternate '=>' form, but does
192 * not hold a recipient element for the test result, a 'Missing recipient'
193 * error is signalled. */
194 static const char s_missing_recipient[] = "Missing recipient in";
196 /* If in a position where a variable name is required some other object is
197 * detected, a 'Bad variable' error is signalled. */
198 static const char s_bad_variable[] = "Bad variable";
200 /* Bindings for forms like 'let' and 'do' have to be given in a proper,
201 * possibly empty list. If any other object is detected in a place where a
202 * list of bindings was required, a 'Bad bindings' error is signalled. */
203 static const char s_bad_bindings[] = "Bad bindings";
205 /* Depending on the syntactic context, a binding has to be in the format
206 * (<variable> <expression>) or (<variable> <expression1> <expression2>).
207 * If anything else is detected in a place where a binding was expected, a
208 * 'Bad binding' error is signalled. */
209 static const char s_bad_binding[] = "Bad binding";
211 /* Some syntactic forms don't allow variable names to appear more than once in
212 * a list of bindings. If such a situation is nevertheless detected, a
213 * 'Duplicate binding' error is signalled. */
214 static const char s_duplicate_binding[] = "Duplicate binding";
216 /* If the exit form of a 'do' expression is not in the format
217 * (<test> <expression> ...)
218 * a 'Bad exit clause' error is signalled. */
219 static const char s_bad_exit_clause[] = "Bad exit clause";
221 /* The formal function arguments of a lambda expression have to be either a
222 * single symbol or a non-cyclic list. For anything else a 'Bad formals'
223 * error is signalled. */
224 static const char s_bad_formals[] = "Bad formals";
226 /* If in a lambda expression something else than a symbol is detected at a
227 * place where a formal function argument is required, a 'Bad formal' error is
229 static const char s_bad_formal[] = "Bad formal";
231 /* If in the arguments list of a lambda expression an argument name occurs
232 * more than once, a 'Duplicate formal' error is signalled. */
233 static const char s_duplicate_formal[] = "Duplicate formal";
235 /* If the evaluation of an unquote-splicing expression gives something else
236 * than a proper list, a 'Non-list result for unquote-splicing' error is
238 static const char s_splicing[] = "Non-list result for unquote-splicing";
240 /* If something else than an exact integer is detected as the argument for
241 * @slot-ref and @slot-set!, a 'Bad slot number' error is signalled. */
242 static const char s_bad_slot_number[] = "Bad slot number";
245 /* Signal a syntax error. We distinguish between the form that caused the
246 * error and the enclosing expression. The error message will print out as
247 * shown in the following pattern. The file name and line number are only
248 * given when they can be determined from the erroneous form or from the
249 * enclosing expression.
251 * <filename>: In procedure memoization:
252 * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
254 SCM_SYMBOL (syntax_error_key, "syntax-error");
256 /* The prototype is needed to indicate that the function does not return. */
258 syntax_error (const char* const, const SCM, const SCM) SCM_NORETURN;
261 syntax_error (const char* const msg, const SCM form, const SCM expr)
263 SCM msg_string = scm_from_locale_string (msg);
264 SCM filename = SCM_BOOL_F;
265 SCM linenr = SCM_BOOL_F;
269 if (scm_is_pair (form))
271 filename = scm_source_property (form, scm_sym_filename);
272 linenr = scm_source_property (form, scm_sym_line);
275 if (scm_is_false (filename) && scm_is_false (linenr) && scm_is_pair (expr))
277 filename = scm_source_property (expr, scm_sym_filename);
278 linenr = scm_source_property (expr, scm_sym_line);
281 if (!SCM_UNBNDP (expr))
283 if (scm_is_true (filename))
285 format = "In file ~S, line ~S: ~A ~S in expression ~S.";
286 args = scm_list_5 (filename, linenr, msg_string, form, expr);
288 else if (scm_is_true (linenr))
290 format = "In line ~S: ~A ~S in expression ~S.";
291 args = scm_list_4 (linenr, msg_string, form, expr);
295 format = "~A ~S in expression ~S.";
296 args = scm_list_3 (msg_string, form, expr);
301 if (scm_is_true (filename))
303 format = "In file ~S, line ~S: ~A ~S.";
304 args = scm_list_4 (filename, linenr, msg_string, form);
306 else if (scm_is_true (linenr))
308 format = "In line ~S: ~A ~S.";
309 args = scm_list_3 (linenr, msg_string, form);
314 args = scm_list_2 (msg_string, form);
318 scm_error (syntax_error_key, "memoization", format, args, SCM_BOOL_F);
322 /* Shortcut macros to simplify syntax error handling. */
323 #define ASSERT_SYNTAX(cond, message, form) \
324 { if (SCM_UNLIKELY (!(cond))) \
325 syntax_error (message, form, SCM_UNDEFINED); }
326 #define ASSERT_SYNTAX_2(cond, message, form, expr) \
327 { if (SCM_UNLIKELY (!(cond))) \
328 syntax_error (message, form, expr); }
334 * Ilocs are memoized references to variables in local environment frames.
335 * They are represented as three values: The relative offset of the
336 * environment frame, the number of the binding within that frame, and a
337 * boolean value indicating whether the binding is the last binding in the
340 * Frame numbers have 11 bits, relative offsets have 12 bits.
343 #define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc)
344 #define SCM_IFRINC (0x00000100L)
345 #define SCM_ICDR (0x00080000L)
346 #define SCM_IDINC (0x00100000L)
347 #define SCM_IFRAME(n) ((long)((SCM_ICDR-SCM_IFRINC)>>8) \
348 & (SCM_UNPACK (n) >> 8))
349 #define SCM_IDIST(n) (SCM_UNPACK (n) >> 20)
350 #define SCM_ICDRP(n) (SCM_ICDR & SCM_UNPACK (n))
351 #define SCM_IDSTMSK (-SCM_IDINC)
352 #define SCM_IFRAMEMAX ((1<<11)-1)
353 #define SCM_IDISTMAX ((1<<12)-1)
354 #define SCM_MAKE_ILOC(frame_nr, binding_nr, last_p) \
357 + ((binding_nr) << 20) \
358 + ((last_p) ? SCM_ICDR : 0) \
362 scm_i_print_iloc (SCM iloc, SCM port)
364 scm_puts ("#@", port);
365 scm_intprint ((long) SCM_IFRAME (iloc), 10, port);
366 scm_putc (SCM_ICDRP (iloc) ? '-' : '+', port);
367 scm_intprint ((long) SCM_IDIST (iloc), 10, port);
370 #if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
372 SCM scm_dbg_make_iloc (SCM frame, SCM binding, SCM cdrp);
374 SCM_DEFINE (scm_dbg_make_iloc, "dbg-make-iloc", 3, 0, 0,
375 (SCM frame, SCM binding, SCM cdrp),
376 "Return a new iloc with frame offset @var{frame}, binding\n"
377 "offset @var{binding} and the cdr flag @var{cdrp}.")
378 #define FUNC_NAME s_scm_dbg_make_iloc
380 return SCM_MAKE_ILOC ((scm_t_bits) scm_to_unsigned_integer (frame, 0, SCM_IFRAMEMAX),
381 (scm_t_bits) scm_to_unsigned_integer (binding, 0, SCM_IDISTMAX),
386 SCM scm_dbg_iloc_p (SCM obj);
388 SCM_DEFINE (scm_dbg_iloc_p, "dbg-iloc?", 1, 0, 0,
390 "Return @code{#t} if @var{obj} is an iloc.")
391 #define FUNC_NAME s_scm_dbg_iloc_p
393 return scm_from_bool (SCM_ILOCP (obj));
401 /* {Evaluator byte codes (isyms)}
404 #define ISYMNUM(n) (SCM_ITAG8_DATA (n))
406 /* This table must agree with the list of SCM_IM_ constants in tags.h */
407 static const char *const isymnames[] =
424 "#@call-with-current-continuation",
430 "#@call-with-values",
438 scm_i_print_isym (SCM isym, SCM port)
440 const size_t isymnum = ISYMNUM (isym);
441 if (isymnum < (sizeof isymnames / sizeof (char *)))
442 scm_puts (isymnames[isymnum], port);
444 scm_ipruk ("isym", isym, port);
449 /* The function lookup_symbol is used during memoization: Lookup the symbol in
450 * the environment. If there is no binding for the symbol, SCM_UNDEFINED is
451 * returned. If the symbol is a global variable, the variable object to which
452 * the symbol is bound is returned. Finally, if the symbol is a local
453 * variable the corresponding iloc object is returned. */
455 /* A helper function for lookup_symbol: Try to find the symbol in the top
456 * level environment frame. The function returns SCM_UNDEFINED if the symbol
457 * is unbound and it returns a variable object if the symbol is a global
460 lookup_global_symbol (const SCM symbol, const SCM top_level)
462 const SCM variable = scm_sym2var (symbol, top_level, SCM_BOOL_F);
463 if (scm_is_false (variable))
464 return SCM_UNDEFINED;
470 lookup_symbol (const SCM symbol, const SCM env)
473 unsigned int frame_nr;
475 for (frame_idx = env, frame_nr = 0;
476 !scm_is_null (frame_idx);
477 frame_idx = SCM_CDR (frame_idx), ++frame_nr)
479 const SCM frame = SCM_CAR (frame_idx);
480 if (scm_is_pair (frame))
482 /* frame holds a local environment frame */
484 unsigned int symbol_nr;
486 for (symbol_idx = SCM_CAR (frame), symbol_nr = 0;
487 scm_is_pair (symbol_idx);
488 symbol_idx = SCM_CDR (symbol_idx), ++symbol_nr)
490 if (scm_is_eq (SCM_CAR (symbol_idx), symbol))
491 /* found the symbol, therefore return the iloc */
492 return SCM_MAKE_ILOC (frame_nr, symbol_nr, 0);
494 if (scm_is_eq (symbol_idx, symbol))
495 /* found the symbol as the last element of the current frame */
496 return SCM_MAKE_ILOC (frame_nr, symbol_nr, 1);
500 /* no more local environment frames */
501 return lookup_global_symbol (symbol, frame);
505 return lookup_global_symbol (symbol, SCM_BOOL_F);
509 /* Return true if the symbol is - from the point of view of a macro
510 * transformer - a literal in the sense specified in chapter "pattern
511 * language" of R5RS. In the code below, however, we don't match the
512 * definition of R5RS exactly: It returns true if the identifier has no
513 * binding or if it is a syntactic keyword. */
515 literal_p (const SCM symbol, const SCM env)
517 const SCM variable = lookup_symbol (symbol, env);
518 if (SCM_UNBNDP (variable))
520 if (SCM_VARIABLEP (variable) && SCM_MACROP (SCM_VARIABLE_REF (variable)))
527 /* Return true if the expression is self-quoting in the memoized code. Thus,
528 * some other objects (like e. g. vectors) are reported as self-quoting, which
529 * according to R5RS would need to be quoted. */
531 is_self_quoting_p (const SCM expr)
533 if (scm_is_pair (expr))
535 else if (scm_is_symbol (expr))
537 else if (scm_is_null (expr))
543 SCM_SYMBOL (sym_three_question_marks, "???");
546 unmemoize_expression (const SCM expr, const SCM env)
548 if (SCM_ILOCP (expr))
551 unsigned long int frame_nr;
553 unsigned long int symbol_nr;
555 for (frame_idx = env, frame_nr = SCM_IFRAME (expr);
557 frame_idx = SCM_CDR (frame_idx), --frame_nr)
559 for (symbol_idx = SCM_CAAR (frame_idx), symbol_nr = SCM_IDIST (expr);
561 symbol_idx = SCM_CDR (symbol_idx), --symbol_nr)
563 return SCM_ICDRP (expr) ? symbol_idx : SCM_CAR (symbol_idx);
565 else if (SCM_VARIABLEP (expr))
567 const SCM sym = scm_module_reverse_lookup (scm_env_module (env), expr);
568 return scm_is_true (sym) ? sym : sym_three_question_marks;
570 else if (scm_is_simple_vector (expr))
572 return scm_list_2 (scm_sym_quote, expr);
574 else if (!scm_is_pair (expr))
578 else if (SCM_ISYMP (SCM_CAR (expr)))
580 return unmemoize_builtin_macro (expr, env);
584 return unmemoize_exprs (expr, env);
590 unmemoize_exprs (const SCM exprs, const SCM env)
592 SCM r_result = SCM_EOL;
593 SCM expr_idx = exprs;
596 /* Note that due to the current lazy memoizer we may find partially memoized
597 * code during execution. In such code we have to expect improper lists of
598 * expressions: On the one hand, for such code syntax checks have not yet
599 * fully been performed, on the other hand, there may be even legal code
600 * like '(a . b) appear as an improper list of expressions as long as the
601 * quote expression is still in its unmemoized form. For this reason, the
602 * following code handles improper lists of expressions until memoization
603 * and execution have been completely separated. */
604 for (; scm_is_pair (expr_idx); expr_idx = SCM_CDR (expr_idx))
606 const SCM expr = SCM_CAR (expr_idx);
608 /* In partially memoized code, lists of expressions that stem from a
609 * body form may start with an ISYM if the body itself has not yet been
610 * memoized. This isym is just an internal marker to indicate that the
611 * body still needs to be memoized. An isym may occur at the very
612 * beginning of the body or after one or more comment strings. It is
613 * dropped during unmemoization. */
614 if (!SCM_ISYMP (expr))
616 um_expr = unmemoize_expression (expr, env);
617 r_result = scm_cons (um_expr, r_result);
620 um_expr = unmemoize_expression (expr_idx, env);
621 if (!scm_is_null (r_result))
623 const SCM result = scm_reverse_x (r_result, SCM_UNDEFINED);
624 SCM_SETCDR (r_result, um_expr);
634 /* Rewrite the body (which is given as the list of expressions forming the
635 * body) into its internal form. The internal form of a body (<expr> ...) is
636 * just the body itself, but prefixed with an ISYM that denotes to what kind
637 * of outer construct this body belongs: (<ISYM> <expr> ...). A lambda body
638 * starts with SCM_IM_LAMBDA, for example, a body of a let starts with
641 * It is assumed that the calling expression has already made sure that the
642 * body is a proper list. */
644 m_body (SCM op, SCM exprs)
646 /* Don't add another ISYM if one is present already. */
647 if (SCM_ISYMP (SCM_CAR (exprs)))
650 return scm_cons (op, exprs);
654 /* The function m_expand_body memoizes a proper list of expressions forming a
655 * body. This function takes care of dealing with internal defines and
656 * transforming them into an equivalent letrec expression. The list of
657 * expressions is rewritten in place. */
659 /* This is a helper function for m_expand_body. If the argument expression is
660 * a symbol that denotes a syntactic keyword, the corresponding macro object
661 * is returned, in all other cases the function returns SCM_UNDEFINED. */
663 try_macro_lookup (const SCM expr, const SCM env)
665 if (scm_is_symbol (expr))
667 const SCM variable = lookup_symbol (expr, env);
668 if (SCM_VARIABLEP (variable))
670 const SCM value = SCM_VARIABLE_REF (variable);
671 if (SCM_MACROP (value))
676 return SCM_UNDEFINED;
679 /* This is a helper function for m_expand_body. It expands user macros,
680 * because for the correct translation of a body we need to know whether they
681 * expand to a definition. */
683 expand_user_macros (SCM expr, const SCM env)
685 while (scm_is_pair (expr))
687 const SCM car_expr = SCM_CAR (expr);
688 const SCM new_car = expand_user_macros (car_expr, env);
689 const SCM value = try_macro_lookup (new_car, env);
691 if (SCM_MACROP (value) && SCM_MACRO_TYPE (value) == 2)
693 /* User macros transform code into code. */
694 expr = scm_call_2 (SCM_MACRO_CODE (value), expr, env);
695 /* We need to reiterate on the transformed code. */
699 /* No user macro: return. */
700 SCM_SETCAR (expr, new_car);
708 /* This is a helper function for m_expand_body. It determines if a given form
709 * represents an application of a given built-in macro. The built-in macro to
710 * check for is identified by its syntactic keyword. The form is an
711 * application of the given macro if looking up the car of the form in the
712 * given environment actually returns the built-in macro. */
714 is_system_macro_p (const SCM syntactic_keyword, const SCM form, const SCM env)
716 if (scm_is_pair (form))
718 const SCM car_form = SCM_CAR (form);
719 const SCM value = try_macro_lookup (car_form, env);
720 if (SCM_BUILTIN_MACRO_P (value))
722 const SCM macro_name = scm_macro_name (value);
723 return scm_is_eq (macro_name, syntactic_keyword);
731 m_expand_body (const SCM forms, const SCM env)
733 /* The first body form can be skipped since it is known to be the ISYM that
734 * was prepended to the body by m_body. */
735 SCM cdr_forms = SCM_CDR (forms);
736 SCM form_idx = cdr_forms;
737 SCM definitions = SCM_EOL;
738 SCM sequence = SCM_EOL;
740 /* According to R5RS, the list of body forms consists of two parts: a number
741 * (maybe zero) of definitions, followed by a non-empty sequence of
742 * expressions. Each the definitions and the expressions may be grouped
743 * arbitrarily with begin, but it is not allowed to mix definitions and
744 * expressions. The task of the following loop therefore is to split the
745 * list of body forms into the list of definitions and the sequence of
747 while (!scm_is_null (form_idx))
749 const SCM form = SCM_CAR (form_idx);
750 const SCM new_form = expand_user_macros (form, env);
751 if (is_system_macro_p (scm_sym_define, new_form, env))
753 definitions = scm_cons (new_form, definitions);
754 form_idx = SCM_CDR (form_idx);
756 else if (is_system_macro_p (scm_sym_begin, new_form, env))
758 /* We have encountered a group of forms. This has to be either a
759 * (possibly empty) group of (possibly further grouped) definitions,
760 * or a non-empty group of (possibly further grouped)
762 const SCM grouped_forms = SCM_CDR (new_form);
763 unsigned int found_definition = 0;
764 unsigned int found_expression = 0;
765 SCM grouped_form_idx = grouped_forms;
766 while (!found_expression && !scm_is_null (grouped_form_idx))
768 const SCM inner_form = SCM_CAR (grouped_form_idx);
769 const SCM new_inner_form = expand_user_macros (inner_form, env);
770 if (is_system_macro_p (scm_sym_define, new_inner_form, env))
772 found_definition = 1;
773 definitions = scm_cons (new_inner_form, definitions);
774 grouped_form_idx = SCM_CDR (grouped_form_idx);
776 else if (is_system_macro_p (scm_sym_begin, new_inner_form, env))
778 const SCM inner_group = SCM_CDR (new_inner_form);
780 = scm_append (scm_list_2 (inner_group,
781 SCM_CDR (grouped_form_idx)));
785 /* The group marks the start of the expressions of the body.
786 * We have to make sure that within the same group we have
787 * not encountered a definition before. */
788 ASSERT_SYNTAX (!found_definition, s_mixed_body_forms, form);
789 found_expression = 1;
790 grouped_form_idx = SCM_EOL;
794 /* We have finished processing the group. If we have not yet
795 * encountered an expression we continue processing the forms of the
796 * body to collect further definition forms. Otherwise, the group
797 * marks the start of the sequence of expressions of the body. */
798 if (!found_expression)
800 form_idx = SCM_CDR (form_idx);
810 /* We have detected a form which is no definition. This marks the
811 * start of the sequence of expressions of the body. */
817 /* FIXME: forms does not hold information about the file location. */
818 ASSERT_SYNTAX (scm_is_pair (sequence), s_missing_body_expression, cdr_forms);
820 if (!scm_is_null (definitions))
824 SCM letrec_expression;
825 SCM new_letrec_expression;
827 SCM bindings = SCM_EOL;
828 for (definition_idx = definitions;
829 !scm_is_null (definition_idx);
830 definition_idx = SCM_CDR (definition_idx))
832 const SCM definition = SCM_CAR (definition_idx);
833 const SCM canonical_definition = canonicalize_define (definition);
834 const SCM binding = SCM_CDR (canonical_definition);
835 bindings = scm_cons (binding, bindings);
838 letrec_tail = scm_cons (bindings, sequence);
839 /* FIXME: forms does not hold information about the file location. */
840 letrec_expression = scm_cons_source (forms, scm_sym_letrec, letrec_tail);
841 new_letrec_expression = scm_m_letrec (letrec_expression, env);
842 SCM_SETCAR (forms, new_letrec_expression);
843 SCM_SETCDR (forms, SCM_EOL);
847 SCM_SETCAR (forms, SCM_CAR (sequence));
848 SCM_SETCDR (forms, SCM_CDR (sequence));
853 macroexp (SCM x, SCM env)
855 SCM res, proc, orig_sym;
857 /* Don't bother to produce error messages here. We get them when we
858 eventually execute the code for real. */
861 orig_sym = SCM_CAR (x);
862 if (!scm_is_symbol (orig_sym))
866 SCM *proc_ptr = scm_lookupcar1 (x, env, 0);
867 if (proc_ptr == NULL)
869 /* We have lost the race. */
875 /* Only handle memoizing macros. `Acros' and `macros' are really
876 special forms and should not be evaluated here. */
878 if (!SCM_MACROP (proc)
879 || (SCM_MACRO_TYPE (proc) != 2 && !SCM_BUILTIN_MACRO_P (proc)))
882 SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of lookupcar */
883 res = scm_call_2 (SCM_MACRO_CODE (proc), x, env);
885 if (scm_ilength (res) <= 0)
886 /* Result of expansion is not a list. */
887 return (scm_list_2 (SCM_IM_BEGIN, res));
890 /* njrev: Several queries here: (1) I don't see how it can be
891 correct that the SCM_SETCAR 2 lines below this comment needs
892 protection, but the SCM_SETCAR 6 lines above does not, so
893 something here is probably wrong. (2) macroexp() is now only
894 used in one place - scm_m_generalized_set_x - whereas all other
895 macro expansion happens through expand_user_macros. Therefore
896 (2.1) perhaps macroexp() could be eliminated completely now?
897 (2.2) Does expand_user_macros need any critical section
900 SCM_CRITICAL_SECTION_START;
901 SCM_SETCAR (x, SCM_CAR (res));
902 SCM_SETCDR (x, SCM_CDR (res));
903 SCM_CRITICAL_SECTION_END;
909 /* Start of the memoizers for the standard R5RS builtin macros. */
912 SCM_SYNTAX (s_and, "and", scm_i_makbimacro, scm_m_and);
913 SCM_GLOBAL_SYMBOL (scm_sym_and, s_and);
916 scm_m_and (SCM expr, SCM env SCM_UNUSED)
918 const SCM cdr_expr = SCM_CDR (expr);
919 const long length = scm_ilength (cdr_expr);
921 ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
925 /* Special case: (and) is replaced by #t. */
930 SCM_SETCAR (expr, SCM_IM_AND);
936 unmemoize_and (const SCM expr, const SCM env)
938 return scm_cons (scm_sym_and, unmemoize_exprs (SCM_CDR (expr), env));
942 SCM_SYNTAX (s_begin, "begin", scm_i_makbimacro, scm_m_begin);
943 SCM_GLOBAL_SYMBOL (scm_sym_begin, s_begin);
946 scm_m_begin (SCM expr, SCM env SCM_UNUSED)
948 const SCM cdr_expr = SCM_CDR (expr);
949 /* Dirk:FIXME:: An empty begin clause is not generally allowed by R5RS.
950 * That means, there should be a distinction between uses of begin where an
951 * empty clause is OK and where it is not. */
952 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
954 SCM_SETCAR (expr, SCM_IM_BEGIN);
959 unmemoize_begin (const SCM expr, const SCM env)
961 return scm_cons (scm_sym_begin, unmemoize_exprs (SCM_CDR (expr), env));
965 SCM_SYNTAX (s_case, "case", scm_i_makbimacro, scm_m_case);
966 SCM_GLOBAL_SYMBOL (scm_sym_case, s_case);
967 SCM_GLOBAL_SYMBOL (scm_sym_else, "else");
970 scm_m_case (SCM expr, SCM env)
973 SCM all_labels = SCM_EOL;
975 /* Check, whether 'else is a literal, i. e. not bound to a value. */
976 const int else_literal_p = literal_p (scm_sym_else, env);
978 const SCM cdr_expr = SCM_CDR (expr);
979 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
980 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_clauses, expr);
982 clauses = SCM_CDR (cdr_expr);
983 while (!scm_is_null (clauses))
987 const SCM clause = SCM_CAR (clauses);
988 ASSERT_SYNTAX_2 (scm_ilength (clause) >= 2,
989 s_bad_case_clause, clause, expr);
991 labels = SCM_CAR (clause);
992 if (scm_is_pair (labels))
994 ASSERT_SYNTAX_2 (scm_ilength (labels) >= 0,
995 s_bad_case_labels, labels, expr);
996 all_labels = scm_append (scm_list_2 (labels, all_labels));
998 else if (scm_is_null (labels))
1000 /* The list of labels is empty. According to R5RS this is allowed.
1001 * It means that the sequence of expressions will never be executed.
1002 * Therefore, as an optimization, we could remove the whole
1007 ASSERT_SYNTAX_2 (scm_is_eq (labels, scm_sym_else) && else_literal_p,
1008 s_bad_case_labels, labels, expr);
1009 ASSERT_SYNTAX_2 (scm_is_null (SCM_CDR (clauses)),
1010 s_misplaced_else_clause, clause, expr);
1013 /* build the new clause */
1014 if (scm_is_eq (labels, scm_sym_else))
1015 SCM_SETCAR (clause, SCM_IM_ELSE);
1017 clauses = SCM_CDR (clauses);
1020 /* Check whether all case labels are distinct. */
1021 for (; !scm_is_null (all_labels); all_labels = SCM_CDR (all_labels))
1023 const SCM label = SCM_CAR (all_labels);
1024 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (label, SCM_CDR (all_labels))),
1025 s_duplicate_case_label, label, expr);
1028 SCM_SETCAR (expr, SCM_IM_CASE);
1033 unmemoize_case (const SCM expr, const SCM env)
1035 const SCM um_key_expr = unmemoize_expression (SCM_CADR (expr), env);
1036 SCM um_clauses = SCM_EOL;
1039 for (clause_idx = SCM_CDDR (expr);
1040 !scm_is_null (clause_idx);
1041 clause_idx = SCM_CDR (clause_idx))
1043 const SCM clause = SCM_CAR (clause_idx);
1044 const SCM labels = SCM_CAR (clause);
1045 const SCM exprs = SCM_CDR (clause);
1047 const SCM um_exprs = unmemoize_exprs (exprs, env);
1048 const SCM um_labels = (scm_is_eq (labels, SCM_IM_ELSE))
1050 : scm_i_finite_list_copy (labels);
1051 const SCM um_clause = scm_cons (um_labels, um_exprs);
1053 um_clauses = scm_cons (um_clause, um_clauses);
1055 um_clauses = scm_reverse_x (um_clauses, SCM_UNDEFINED);
1057 return scm_cons2 (scm_sym_case, um_key_expr, um_clauses);
1061 SCM_SYNTAX (s_cond, "cond", scm_i_makbimacro, scm_m_cond);
1062 SCM_GLOBAL_SYMBOL (scm_sym_cond, s_cond);
1063 SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>");
1066 scm_m_cond (SCM expr, SCM env)
1068 /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
1069 const int else_literal_p = literal_p (scm_sym_else, env);
1070 const int arrow_literal_p = literal_p (scm_sym_arrow, env);
1072 const SCM clauses = SCM_CDR (expr);
1075 ASSERT_SYNTAX (scm_ilength (clauses) >= 0, s_bad_expression, expr);
1076 ASSERT_SYNTAX (scm_ilength (clauses) >= 1, s_missing_clauses, expr);
1078 for (clause_idx = clauses;
1079 !scm_is_null (clause_idx);
1080 clause_idx = SCM_CDR (clause_idx))
1084 const SCM clause = SCM_CAR (clause_idx);
1085 const long length = scm_ilength (clause);
1086 ASSERT_SYNTAX_2 (length >= 1, s_bad_cond_clause, clause, expr);
1088 test = SCM_CAR (clause);
1089 if (scm_is_eq (test, scm_sym_else) && else_literal_p)
1091 const int last_clause_p = scm_is_null (SCM_CDR (clause_idx));
1092 ASSERT_SYNTAX_2 (length >= 2,
1093 s_bad_cond_clause, clause, expr);
1094 ASSERT_SYNTAX_2 (last_clause_p,
1095 s_misplaced_else_clause, clause, expr);
1096 SCM_SETCAR (clause, SCM_IM_ELSE);
1098 else if (length >= 2
1099 && scm_is_eq (SCM_CADR (clause), scm_sym_arrow)
1102 ASSERT_SYNTAX_2 (length > 2, s_missing_recipient, clause, expr);
1103 ASSERT_SYNTAX_2 (length == 3, s_extra_expression, clause, expr);
1104 SCM_SETCAR (SCM_CDR (clause), SCM_IM_ARROW);
1106 /* SRFI 61 extended cond */
1107 else if (length >= 3
1108 && scm_is_eq (SCM_CADDR (clause), scm_sym_arrow)
1111 ASSERT_SYNTAX_2 (length > 3, s_missing_recipient, clause, expr);
1112 ASSERT_SYNTAX_2 (length == 4, s_extra_expression, clause, expr);
1113 SCM_SETCAR (SCM_CDDR (clause), SCM_IM_ARROW);
1117 SCM_SETCAR (expr, SCM_IM_COND);
1122 unmemoize_cond (const SCM expr, const SCM env)
1124 SCM um_clauses = SCM_EOL;
1127 for (clause_idx = SCM_CDR (expr);
1128 !scm_is_null (clause_idx);
1129 clause_idx = SCM_CDR (clause_idx))
1131 const SCM clause = SCM_CAR (clause_idx);
1132 const SCM sequence = SCM_CDR (clause);
1133 const SCM test = SCM_CAR (clause);
1138 if (scm_is_eq (test, SCM_IM_ELSE))
1139 um_test = scm_sym_else;
1141 um_test = unmemoize_expression (test, env);
1143 if (!scm_is_null (sequence) && scm_is_eq (SCM_CAR (sequence),
1146 const SCM target = SCM_CADR (sequence);
1147 const SCM um_target = unmemoize_expression (target, env);
1148 um_sequence = scm_list_2 (scm_sym_arrow, um_target);
1152 um_sequence = unmemoize_exprs (sequence, env);
1155 um_clause = scm_cons (um_test, um_sequence);
1156 um_clauses = scm_cons (um_clause, um_clauses);
1158 um_clauses = scm_reverse_x (um_clauses, SCM_UNDEFINED);
1160 return scm_cons (scm_sym_cond, um_clauses);
1164 SCM_SYNTAX (s_define, "define", scm_i_makbimacro, scm_m_define);
1165 SCM_GLOBAL_SYMBOL (scm_sym_define, s_define);
1167 /* Guile provides an extension to R5RS' define syntax to represent function
1168 * currying in a compact way. With this extension, it is allowed to write
1169 * (define <nested-variable> <body>), where <nested-variable> has of one of
1170 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
1171 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
1172 * should be either a sequence of zero or more variables, or a sequence of one
1173 * or more variables followed by a space-delimited period and another
1174 * variable. Each level of argument nesting wraps the <body> within another
1175 * lambda expression. For example, the following forms are allowed, each one
1176 * followed by an equivalent, more explicit implementation.
1178 * (define ((a b . c) . d) <body>) is equivalent to
1179 * (define a (lambda (b . c) (lambda d <body>)))
1181 * (define (((a) b) c . d) <body>) is equivalent to
1182 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
1184 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
1185 * module that does not implement this extension. */
1187 canonicalize_define (const SCM expr)
1192 const SCM cdr_expr = SCM_CDR (expr);
1193 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
1194 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
1196 body = SCM_CDR (cdr_expr);
1197 variable = SCM_CAR (cdr_expr);
1198 while (scm_is_pair (variable))
1200 /* This while loop realizes function currying by variable nesting.
1201 * Variable is known to be a nested-variable. In every iteration of the
1202 * loop another level of lambda expression is created, starting with the
1203 * innermost one. Note that we don't check for duplicate formals here:
1204 * This will be done by the memoizer of the lambda expression. */
1205 const SCM formals = SCM_CDR (variable);
1206 const SCM tail = scm_cons (formals, body);
1208 /* Add source properties to each new lambda expression: */
1209 const SCM lambda = scm_cons_source (variable, scm_sym_lambda, tail);
1211 body = scm_list_1 (lambda);
1212 variable = SCM_CAR (variable);
1214 ASSERT_SYNTAX_2 (scm_is_symbol (variable), s_bad_variable, variable, expr);
1215 ASSERT_SYNTAX (scm_ilength (body) == 1, s_expression, expr);
1217 SCM_SETCAR (cdr_expr, variable);
1218 SCM_SETCDR (cdr_expr, body);
1222 /* According to Section 5.2.1 of R5RS we first have to make sure that the
1223 variable is bound, and then perform the `(set! variable expression)'
1224 operation. However, EXPRESSION _can_ be evaluated before VARIABLE is
1225 bound. This means that EXPRESSION won't necessarily be able to assign
1226 values to VARIABLE as in `(define foo (begin (set! foo 1) (+ foo 1)))'. */
1228 scm_m_define (SCM expr, SCM env)
1230 ASSERT_SYNTAX (SCM_TOP_LEVEL (env), s_bad_define, expr);
1233 const SCM canonical_definition = canonicalize_define (expr);
1234 const SCM cdr_canonical_definition = SCM_CDR (canonical_definition);
1235 const SCM variable = SCM_CAR (cdr_canonical_definition);
1236 const SCM value = scm_eval_car (SCM_CDR (cdr_canonical_definition), env);
1238 = scm_sym2var (variable, scm_env_top_level (env), SCM_BOOL_T);
1240 if (SCM_REC_PROCNAMES_P)
1243 while (SCM_MACROP (tmp))
1244 tmp = SCM_MACRO_CODE (tmp);
1245 if (scm_is_true (scm_procedure_p (tmp))
1246 /* Only the first definition determines the name. */
1247 && scm_is_false (scm_procedure_property (tmp, scm_sym_name)))
1248 scm_set_procedure_property_x (tmp, scm_sym_name, variable);
1251 SCM_VARIABLE_SET (location, value);
1253 return SCM_UNSPECIFIED;
1258 /* This is a helper function for forms (<keyword> <expression>) that are
1259 * transformed into (#@<keyword> '() <memoized_expression>) in order to allow
1260 * for easy creation of a thunk (i. e. a closure without arguments) using the
1261 * ('() <memoized_expression>) tail of the memoized form. */
1263 memoize_as_thunk_prototype (const SCM expr, const SCM env SCM_UNUSED)
1265 const SCM cdr_expr = SCM_CDR (expr);
1266 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
1267 ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
1269 SCM_SETCDR (expr, scm_cons (SCM_EOL, cdr_expr));
1275 SCM_SYNTAX (s_delay, "delay", scm_i_makbimacro, scm_m_delay);
1276 SCM_GLOBAL_SYMBOL (scm_sym_delay, s_delay);
1278 /* Promises are implemented as closures with an empty parameter list. Thus,
1279 * (delay <expression>) is transformed into (#@delay '() <expression>), where
1280 * the empty list represents the empty parameter list. This representation
1281 * allows for easy creation of the closure during evaluation. */
1283 scm_m_delay (SCM expr, SCM env)
1285 const SCM new_expr = memoize_as_thunk_prototype (expr, env);
1286 SCM_SETCAR (new_expr, SCM_IM_DELAY);
1291 unmemoize_delay (const SCM expr, const SCM env)
1293 const SCM thunk_expr = SCM_CADDR (expr);
1294 /* A promise is implemented as a closure, and when applying a
1295 closure the evaluator adds a new frame to the environment - even
1296 though, in the case of a promise, the added frame is always
1297 empty. We need to extend the environment here in the same way,
1298 so that any ILOCs in thunk_expr can be unmemoized correctly. */
1299 const SCM new_env = SCM_EXTEND_ENV (SCM_EOL, SCM_EOL, env);
1300 return scm_list_2 (scm_sym_delay, unmemoize_expression (thunk_expr, new_env));
1304 SCM_SYNTAX(s_do, "do", scm_i_makbimacro, scm_m_do);
1305 SCM_GLOBAL_SYMBOL(scm_sym_do, s_do);
1307 /* DO gets the most radically altered syntax. The order of the vars is
1308 * reversed here. During the evaluation this allows for simple consing of the
1309 * results of the inits and steps:
1311 (do ((<var1> <init1> <step1>)
1319 (#@do (<init1> <init2> ... <initn>)
1320 (varn ... var2 var1)
1323 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
1326 scm_m_do (SCM expr, SCM env SCM_UNUSED)
1328 SCM variables = SCM_EOL;
1329 SCM init_forms = SCM_EOL;
1330 SCM step_forms = SCM_EOL;
1337 const SCM cdr_expr = SCM_CDR (expr);
1338 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
1339 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
1341 /* Collect variables, init and step forms. */
1342 binding_idx = SCM_CAR (cdr_expr);
1343 ASSERT_SYNTAX_2 (scm_ilength (binding_idx) >= 0,
1344 s_bad_bindings, binding_idx, expr);
1345 for (; !scm_is_null (binding_idx); binding_idx = SCM_CDR (binding_idx))
1347 const SCM binding = SCM_CAR (binding_idx);
1348 const long length = scm_ilength (binding);
1349 ASSERT_SYNTAX_2 (length == 2 || length == 3,
1350 s_bad_binding, binding, expr);
1353 const SCM name = SCM_CAR (binding);
1354 const SCM init = SCM_CADR (binding);
1355 const SCM step = (length == 2) ? name : SCM_CADDR (binding);
1356 ASSERT_SYNTAX_2 (scm_is_symbol (name), s_bad_variable, name, expr);
1357 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name, variables)),
1358 s_duplicate_binding, name, expr);
1360 variables = scm_cons (name, variables);
1361 init_forms = scm_cons (init, init_forms);
1362 step_forms = scm_cons (step, step_forms);
1365 init_forms = scm_reverse_x (init_forms, SCM_UNDEFINED);
1366 step_forms = scm_reverse_x (step_forms, SCM_UNDEFINED);
1368 /* Memoize the test form and the exit sequence. */
1369 cddr_expr = SCM_CDR (cdr_expr);
1370 exit_clause = SCM_CAR (cddr_expr);
1371 ASSERT_SYNTAX_2 (scm_ilength (exit_clause) >= 1,
1372 s_bad_exit_clause, exit_clause, expr);
1374 commands = SCM_CDR (cddr_expr);
1375 tail = scm_cons2 (exit_clause, commands, step_forms);
1376 tail = scm_cons2 (init_forms, variables, tail);
1377 SCM_SETCAR (expr, SCM_IM_DO);
1378 SCM_SETCDR (expr, tail);
1383 unmemoize_do (const SCM expr, const SCM env)
1385 const SCM cdr_expr = SCM_CDR (expr);
1386 const SCM cddr_expr = SCM_CDR (cdr_expr);
1387 const SCM rnames = SCM_CAR (cddr_expr);
1388 const SCM extended_env = SCM_EXTEND_ENV (rnames, SCM_EOL, env);
1389 const SCM cdddr_expr = SCM_CDR (cddr_expr);
1390 const SCM exit_sequence = SCM_CAR (cdddr_expr);
1391 const SCM um_exit_sequence = unmemoize_exprs (exit_sequence, extended_env);
1392 const SCM cddddr_expr = SCM_CDR (cdddr_expr);
1393 const SCM um_body = unmemoize_exprs (SCM_CAR (cddddr_expr), extended_env);
1395 /* build transformed binding list */
1396 SCM um_names = scm_reverse (rnames);
1397 SCM um_inits = unmemoize_exprs (SCM_CAR (cdr_expr), env);
1398 SCM um_steps = unmemoize_exprs (SCM_CDR (cddddr_expr), extended_env);
1399 SCM um_bindings = SCM_EOL;
1400 while (!scm_is_null (um_names))
1402 const SCM name = SCM_CAR (um_names);
1403 const SCM init = SCM_CAR (um_inits);
1404 SCM step = SCM_CAR (um_steps);
1405 step = scm_is_eq (step, name) ? SCM_EOL : scm_list_1 (step);
1407 um_bindings = scm_cons (scm_cons2 (name, init, step), um_bindings);
1409 um_names = SCM_CDR (um_names);
1410 um_inits = SCM_CDR (um_inits);
1411 um_steps = SCM_CDR (um_steps);
1413 um_bindings = scm_reverse_x (um_bindings, SCM_UNDEFINED);
1415 return scm_cons (scm_sym_do,
1416 scm_cons2 (um_bindings, um_exit_sequence, um_body));
1420 SCM_SYNTAX (s_if, "if", scm_i_makbimacro, scm_m_if);
1421 SCM_GLOBAL_SYMBOL (scm_sym_if, s_if);
1424 scm_m_if (SCM expr, SCM env SCM_UNUSED)
1426 const SCM cdr_expr = SCM_CDR (expr);
1427 const long length = scm_ilength (cdr_expr);
1428 ASSERT_SYNTAX (length == 2 || length == 3, s_expression, expr);
1429 SCM_SETCAR (expr, SCM_IM_IF);
1434 unmemoize_if (const SCM expr, const SCM env)
1436 const SCM cdr_expr = SCM_CDR (expr);
1437 const SCM um_condition = unmemoize_expression (SCM_CAR (cdr_expr), env);
1438 const SCM cddr_expr = SCM_CDR (cdr_expr);
1439 const SCM um_then = unmemoize_expression (SCM_CAR (cddr_expr), env);
1440 const SCM cdddr_expr = SCM_CDR (cddr_expr);
1442 if (scm_is_null (cdddr_expr))
1444 return scm_list_3 (scm_sym_if, um_condition, um_then);
1448 const SCM um_else = unmemoize_expression (SCM_CAR (cdddr_expr), env);
1449 return scm_list_4 (scm_sym_if, um_condition, um_then, um_else);
1454 SCM_SYNTAX (s_lambda, "lambda", scm_i_makbimacro, scm_m_lambda);
1455 SCM_GLOBAL_SYMBOL (scm_sym_lambda, s_lambda);
1457 /* A helper function for memoize_lambda to support checking for duplicate
1458 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
1459 * LIST or to the cdr of the last cons. Therefore, LIST may have any of the
1460 * forms that a formal argument can have:
1461 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
1463 c_improper_memq (SCM obj, SCM list)
1465 for (; scm_is_pair (list); list = SCM_CDR (list))
1467 if (scm_is_eq (SCM_CAR (list), obj))
1470 return scm_is_eq (list, obj);
1474 scm_m_lambda (SCM expr, SCM env SCM_UNUSED)
1483 const SCM cdr_expr = SCM_CDR (expr);
1484 const long length = scm_ilength (cdr_expr);
1485 ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
1486 ASSERT_SYNTAX (length >= 2, s_missing_expression, expr);
1488 /* Before iterating the list of formal arguments, make sure the formals
1489 * actually are given as either a symbol or a non-cyclic list. */
1490 formals = SCM_CAR (cdr_expr);
1491 if (scm_is_pair (formals))
1493 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
1494 * detected, report a 'Bad formals' error. */
1498 ASSERT_SYNTAX_2 (scm_is_symbol (formals) || scm_is_null (formals),
1499 s_bad_formals, formals, expr);
1502 /* Now iterate the list of formal arguments to check if all formals are
1503 * symbols, and that there are no duplicates. */
1504 formals_idx = formals;
1505 while (scm_is_pair (formals_idx))
1507 const SCM formal = SCM_CAR (formals_idx);
1508 const SCM next_idx = SCM_CDR (formals_idx);
1509 ASSERT_SYNTAX_2 (scm_is_symbol (formal), s_bad_formal, formal, expr);
1510 ASSERT_SYNTAX_2 (!c_improper_memq (formal, next_idx),
1511 s_duplicate_formal, formal, expr);
1512 formals_idx = next_idx;
1514 ASSERT_SYNTAX_2 (scm_is_null (formals_idx) || scm_is_symbol (formals_idx),
1515 s_bad_formal, formals_idx, expr);
1517 /* Memoize the body. Keep a potential documentation string. */
1518 /* Dirk:FIXME:: We should probably extract the documentation string to
1519 * some external database. Otherwise it will slow down execution, since
1520 * the documentation string will have to be skipped with every execution
1521 * of the closure. */
1522 cddr_expr = SCM_CDR (cdr_expr);
1523 documentation = (length >= 3 && scm_is_string (SCM_CAR (cddr_expr)));
1524 body = documentation ? SCM_CDR (cddr_expr) : cddr_expr;
1525 new_body = m_body (SCM_IM_LAMBDA, body);
1527 SCM_SETCAR (expr, SCM_IM_LAMBDA);
1529 SCM_SETCDR (cddr_expr, new_body);
1531 SCM_SETCDR (cdr_expr, new_body);
1536 unmemoize_lambda (const SCM expr, const SCM env)
1538 const SCM formals = SCM_CADR (expr);
1539 const SCM body = SCM_CDDR (expr);
1541 const SCM new_env = SCM_EXTEND_ENV (formals, SCM_EOL, env);
1542 const SCM um_formals = scm_i_finite_list_copy (formals);
1543 const SCM um_body = unmemoize_exprs (body, new_env);
1545 return scm_cons2 (scm_sym_lambda, um_formals, um_body);
1549 /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
1551 check_bindings (const SCM bindings, const SCM expr)
1555 ASSERT_SYNTAX_2 (scm_ilength (bindings) >= 0,
1556 s_bad_bindings, bindings, expr);
1558 binding_idx = bindings;
1559 for (; !scm_is_null (binding_idx); binding_idx = SCM_CDR (binding_idx))
1561 SCM name; /* const */
1563 const SCM binding = SCM_CAR (binding_idx);
1564 ASSERT_SYNTAX_2 (scm_ilength (binding) == 2,
1565 s_bad_binding, binding, expr);
1567 name = SCM_CAR (binding);
1568 ASSERT_SYNTAX_2 (scm_is_symbol (name), s_bad_variable, name, expr);
1573 /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
1574 * transformed to the lists (vn ... v2 v1) and (i1 i2 ... in). That is, the
1575 * variables are returned in a list with their order reversed, and the init
1576 * forms are returned in a list in the same order as they are given in the
1577 * bindings. If a duplicate variable name is detected, an error is
1580 transform_bindings (
1581 const SCM bindings, const SCM expr,
1582 SCM *const rvarptr, SCM *const initptr )
1584 SCM rvariables = SCM_EOL;
1585 SCM rinits = SCM_EOL;
1586 SCM binding_idx = bindings;
1587 for (; !scm_is_null (binding_idx); binding_idx = SCM_CDR (binding_idx))
1589 const SCM binding = SCM_CAR (binding_idx);
1590 const SCM cdr_binding = SCM_CDR (binding);
1591 const SCM name = SCM_CAR (binding);
1592 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name, rvariables)),
1593 s_duplicate_binding, name, expr);
1594 rvariables = scm_cons (name, rvariables);
1595 rinits = scm_cons (SCM_CAR (cdr_binding), rinits);
1597 *rvarptr = rvariables;
1598 *initptr = scm_reverse_x (rinits, SCM_UNDEFINED);
1602 SCM_SYNTAX(s_let, "let", scm_i_makbimacro, scm_m_let);
1603 SCM_GLOBAL_SYMBOL(scm_sym_let, s_let);
1605 /* This function is a helper function for memoize_let. It transforms
1606 * (let name ((var init) ...) body ...) into
1607 * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
1608 * and memoizes the expression. It is assumed that the caller has checked
1609 * that name is a symbol and that there are bindings and a body. */
1611 memoize_named_let (const SCM expr, const SCM env SCM_UNUSED)
1617 const SCM cdr_expr = SCM_CDR (expr);
1618 const SCM name = SCM_CAR (cdr_expr);
1619 const SCM cddr_expr = SCM_CDR (cdr_expr);
1620 const SCM bindings = SCM_CAR (cddr_expr);
1621 check_bindings (bindings, expr);
1623 transform_bindings (bindings, expr, &rvariables, &inits);
1624 variables = scm_reverse_x (rvariables, SCM_UNDEFINED);
1627 const SCM let_body = SCM_CDR (cddr_expr);
1628 const SCM lambda_body = m_body (SCM_IM_LET, let_body);
1629 const SCM lambda_tail = scm_cons (variables, lambda_body);
1630 const SCM lambda_form = scm_cons_source (expr, scm_sym_lambda, lambda_tail);
1632 const SCM rvar = scm_list_1 (name);
1633 const SCM init = scm_list_1 (lambda_form);
1634 const SCM body = m_body (SCM_IM_LET, scm_list_1 (name));
1635 const SCM letrec_tail = scm_cons (rvar, scm_cons (init, body));
1636 const SCM letrec_form = scm_cons_source (expr, SCM_IM_LETREC, letrec_tail);
1637 return scm_cons_source (expr, letrec_form, inits);
1641 /* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1642 * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
1644 scm_m_let (SCM expr, SCM env)
1648 const SCM cdr_expr = SCM_CDR (expr);
1649 const long length = scm_ilength (cdr_expr);
1650 ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
1651 ASSERT_SYNTAX (length >= 2, s_missing_expression, expr);
1653 bindings = SCM_CAR (cdr_expr);
1654 if (scm_is_symbol (bindings))
1656 ASSERT_SYNTAX (length >= 3, s_missing_expression, expr);
1657 return memoize_named_let (expr, env);
1660 check_bindings (bindings, expr);
1661 if (scm_is_null (bindings) || scm_is_null (SCM_CDR (bindings)))
1663 /* Special case: no bindings or single binding => let* is faster. */
1664 const SCM body = m_body (SCM_IM_LET, SCM_CDR (cdr_expr));
1665 return scm_m_letstar (scm_cons2 (SCM_CAR (expr), bindings, body), env);
1672 transform_bindings (bindings, expr, &rvariables, &inits);
1675 const SCM new_body = m_body (SCM_IM_LET, SCM_CDR (cdr_expr));
1676 const SCM new_tail = scm_cons2 (rvariables, inits, new_body);
1677 SCM_SETCAR (expr, SCM_IM_LET);
1678 SCM_SETCDR (expr, new_tail);
1685 build_binding_list (SCM rnames, SCM rinits)
1687 SCM bindings = SCM_EOL;
1688 while (!scm_is_null (rnames))
1690 const SCM binding = scm_list_2 (SCM_CAR (rnames), SCM_CAR (rinits));
1691 bindings = scm_cons (binding, bindings);
1692 rnames = SCM_CDR (rnames);
1693 rinits = SCM_CDR (rinits);
1699 unmemoize_let (const SCM expr, const SCM env)
1701 const SCM cdr_expr = SCM_CDR (expr);
1702 const SCM um_rnames = SCM_CAR (cdr_expr);
1703 const SCM extended_env = SCM_EXTEND_ENV (um_rnames, SCM_EOL, env);
1704 const SCM cddr_expr = SCM_CDR (cdr_expr);
1705 const SCM um_inits = unmemoize_exprs (SCM_CAR (cddr_expr), env);
1706 const SCM um_rinits = scm_reverse_x (um_inits, SCM_UNDEFINED);
1707 const SCM um_bindings = build_binding_list (um_rnames, um_rinits);
1708 const SCM um_body = unmemoize_exprs (SCM_CDR (cddr_expr), extended_env);
1710 return scm_cons2 (scm_sym_let, um_bindings, um_body);
1714 SCM_SYNTAX(s_letrec, "letrec", scm_i_makbimacro, scm_m_letrec);
1715 SCM_GLOBAL_SYMBOL(scm_sym_letrec, s_letrec);
1718 scm_m_letrec (SCM expr, SCM env)
1722 const SCM cdr_expr = SCM_CDR (expr);
1723 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
1724 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
1726 bindings = SCM_CAR (cdr_expr);
1727 if (scm_is_null (bindings))
1729 /* no bindings, let* is executed faster */
1730 SCM body = m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr));
1731 return scm_m_letstar (scm_cons2 (SCM_CAR (expr), SCM_EOL, body), env);
1739 check_bindings (bindings, expr);
1740 transform_bindings (bindings, expr, &rvariables, &inits);
1741 new_body = m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr));
1742 return scm_cons2 (SCM_IM_LETREC, rvariables, scm_cons (inits, new_body));
1747 unmemoize_letrec (const SCM expr, const SCM env)
1749 const SCM cdr_expr = SCM_CDR (expr);
1750 const SCM um_rnames = SCM_CAR (cdr_expr);
1751 const SCM extended_env = SCM_EXTEND_ENV (um_rnames, SCM_EOL, env);
1752 const SCM cddr_expr = SCM_CDR (cdr_expr);
1753 const SCM um_inits = unmemoize_exprs (SCM_CAR (cddr_expr), extended_env);
1754 const SCM um_rinits = scm_reverse_x (um_inits, SCM_UNDEFINED);
1755 const SCM um_bindings = build_binding_list (um_rnames, um_rinits);
1756 const SCM um_body = unmemoize_exprs (SCM_CDR (cddr_expr), extended_env);
1758 return scm_cons2 (scm_sym_letrec, um_bindings, um_body);
1763 SCM_SYNTAX (s_letstar, "let*", scm_i_makbimacro, scm_m_letstar);
1764 SCM_GLOBAL_SYMBOL (scm_sym_letstar, s_letstar);
1766 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1767 * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
1769 scm_m_letstar (SCM expr, SCM env SCM_UNUSED)
1774 const SCM cdr_expr = SCM_CDR (expr);
1775 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
1776 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
1778 binding_idx = SCM_CAR (cdr_expr);
1779 check_bindings (binding_idx, expr);
1781 /* Transform ((v1 i1) (v2 i2) ...) into (v1 i1 v2 i2 ...). The
1782 * transformation is done in place. At the beginning of one iteration of
1783 * the loop the variable binding_idx holds the form
1784 * P1:( (vn . P2:(in . ())) . P3:( (vn+1 in+1) ... ) ),
1785 * where P1, P2 and P3 indicate the pairs, that are relevant for the
1786 * transformation. P1 and P2 are modified in the loop, P3 remains
1787 * untouched. After the execution of the loop, P1 will hold
1788 * P1:( vn . P2:(in . P3:( (vn+1 in+1) ... )) )
1789 * and binding_idx will hold P3. */
1790 while (!scm_is_null (binding_idx))
1792 const SCM cdr_binding_idx = SCM_CDR (binding_idx); /* remember P3 */
1793 const SCM binding = SCM_CAR (binding_idx);
1794 const SCM name = SCM_CAR (binding);
1795 const SCM cdr_binding = SCM_CDR (binding);
1797 SCM_SETCDR (cdr_binding, cdr_binding_idx); /* update P2 */
1798 SCM_SETCAR (binding_idx, name); /* update P1 */
1799 SCM_SETCDR (binding_idx, cdr_binding); /* update P1 */
1801 binding_idx = cdr_binding_idx; /* continue with P3 */
1804 new_body = m_body (SCM_IM_LETSTAR, SCM_CDR (cdr_expr));
1805 SCM_SETCAR (expr, SCM_IM_LETSTAR);
1806 /* the bindings have been changed in place */
1807 SCM_SETCDR (cdr_expr, new_body);
1812 unmemoize_letstar (const SCM expr, const SCM env)
1814 const SCM cdr_expr = SCM_CDR (expr);
1815 const SCM body = SCM_CDR (cdr_expr);
1816 SCM bindings = SCM_CAR (cdr_expr);
1817 SCM um_bindings = SCM_EOL;
1818 SCM extended_env = env;
1821 while (!scm_is_null (bindings))
1823 const SCM variable = SCM_CAR (bindings);
1824 const SCM init = SCM_CADR (bindings);
1825 const SCM um_init = unmemoize_expression (init, extended_env);
1826 um_bindings = scm_cons (scm_list_2 (variable, um_init), um_bindings);
1827 extended_env = SCM_EXTEND_ENV (variable, SCM_BOOL_F, extended_env);
1828 bindings = SCM_CDDR (bindings);
1830 um_bindings = scm_reverse_x (um_bindings, SCM_UNDEFINED);
1832 um_body = unmemoize_exprs (body, extended_env);
1834 return scm_cons2 (scm_sym_letstar, um_bindings, um_body);
1838 SCM_SYNTAX (s_or, "or", scm_i_makbimacro, scm_m_or);
1839 SCM_GLOBAL_SYMBOL (scm_sym_or, s_or);
1842 scm_m_or (SCM expr, SCM env SCM_UNUSED)
1844 const SCM cdr_expr = SCM_CDR (expr);
1845 const long length = scm_ilength (cdr_expr);
1847 ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
1851 /* Special case: (or) is replaced by #f. */
1856 SCM_SETCAR (expr, SCM_IM_OR);
1862 unmemoize_or (const SCM expr, const SCM env)
1864 return scm_cons (scm_sym_or, unmemoize_exprs (SCM_CDR (expr), env));
1868 SCM_SYNTAX (s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote);
1869 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, s_quasiquote);
1870 SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote");
1871 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing, "unquote-splicing");
1873 /* Internal function to handle a quasiquotation: 'form' is the parameter in
1874 * the call (quasiquotation form), 'env' is the environment where unquoted
1875 * expressions will be evaluated, and 'depth' is the current quasiquotation
1876 * nesting level and is known to be greater than zero. */
1878 iqq (SCM form, SCM env, unsigned long int depth)
1880 if (scm_is_pair (form))
1882 const SCM tmp = SCM_CAR (form);
1883 if (scm_is_eq (tmp, scm_sym_quasiquote))
1885 const SCM args = SCM_CDR (form);
1886 ASSERT_SYNTAX (scm_ilength (args) == 1, s_expression, form);
1887 return scm_list_2 (tmp, iqq (SCM_CAR (args), env, depth + 1));
1889 else if (scm_is_eq (tmp, scm_sym_unquote))
1891 const SCM args = SCM_CDR (form);
1892 ASSERT_SYNTAX (scm_ilength (args) == 1, s_expression, form);
1894 return scm_eval_car (args, env);
1896 return scm_list_2 (tmp, iqq (SCM_CAR (args), env, depth - 1));
1898 else if (scm_is_pair (tmp)
1899 && scm_is_eq (SCM_CAR (tmp), scm_sym_uq_splicing))
1901 const SCM args = SCM_CDR (tmp);
1902 ASSERT_SYNTAX (scm_ilength (args) == 1, s_expression, form);
1905 const SCM list = scm_eval_car (args, env);
1906 const SCM rest = SCM_CDR (form);
1907 ASSERT_SYNTAX_2 (scm_ilength (list) >= 0,
1908 s_splicing, list, form);
1909 return scm_append (scm_list_2 (list, iqq (rest, env, depth)));
1912 return scm_cons (iqq (SCM_CAR (form), env, depth - 1),
1913 iqq (SCM_CDR (form), env, depth));
1916 return scm_cons (iqq (SCM_CAR (form), env, depth),
1917 iqq (SCM_CDR (form), env, depth));
1919 else if (scm_is_vector (form))
1920 return scm_vector (iqq (scm_vector_to_list (form), env, depth));
1926 scm_m_quasiquote (SCM expr, SCM env)
1928 const SCM cdr_expr = SCM_CDR (expr);
1929 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
1930 ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
1931 return iqq (SCM_CAR (cdr_expr), env, 1);
1935 SCM_SYNTAX (s_quote, "quote", scm_i_makbimacro, scm_m_quote);
1936 SCM_GLOBAL_SYMBOL (scm_sym_quote, s_quote);
1939 scm_m_quote (SCM expr, SCM env SCM_UNUSED)
1943 const SCM cdr_expr = SCM_CDR (expr);
1944 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
1945 ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
1946 quotee = SCM_CAR (cdr_expr);
1947 if (is_self_quoting_p (quotee))
1950 SCM_SETCAR (expr, SCM_IM_QUOTE);
1951 SCM_SETCDR (expr, quotee);
1956 unmemoize_quote (const SCM expr, const SCM env SCM_UNUSED)
1958 return scm_list_2 (scm_sym_quote, SCM_CDR (expr));
1962 /* Will go into the RnRS module when Guile is factorized.
1963 SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
1964 static const char s_set_x[] = "set!";
1965 SCM_GLOBAL_SYMBOL (scm_sym_set_x, s_set_x);
1968 scm_m_set_x (SCM expr, SCM env SCM_UNUSED)
1973 const SCM cdr_expr = SCM_CDR (expr);
1974 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
1975 ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
1976 variable = SCM_CAR (cdr_expr);
1978 /* Memoize the variable form. */
1979 ASSERT_SYNTAX_2 (scm_is_symbol (variable), s_bad_variable, variable, expr);
1980 new_variable = lookup_symbol (variable, env);
1981 /* Leave the memoization of unbound symbols to lazy memoization: */
1982 if (SCM_UNBNDP (new_variable))
1983 new_variable = variable;
1985 SCM_SETCAR (expr, SCM_IM_SET_X);
1986 SCM_SETCAR (cdr_expr, new_variable);
1991 unmemoize_set_x (const SCM expr, const SCM env)
1993 return scm_cons (scm_sym_set_x, unmemoize_exprs (SCM_CDR (expr), env));
1997 /* Start of the memoizers for non-R5RS builtin macros. */
2000 SCM_SYNTAX (s_atapply, "@apply", scm_i_makbimacro, scm_m_apply);
2001 SCM_GLOBAL_SYMBOL (scm_sym_atapply, s_atapply);
2002 SCM_GLOBAL_SYMBOL (scm_sym_apply, s_atapply + 1);
2005 scm_m_apply (SCM expr, SCM env SCM_UNUSED)
2007 const SCM cdr_expr = SCM_CDR (expr);
2008 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
2009 ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_missing_expression, expr);
2011 SCM_SETCAR (expr, SCM_IM_APPLY);
2016 unmemoize_apply (const SCM expr, const SCM env)
2018 return scm_list_2 (scm_sym_atapply, unmemoize_exprs (SCM_CDR (expr), env));
2022 SCM_SYNTAX (s_atbind, "@bind", scm_i_makbimacro, scm_m_atbind);
2024 /* FIXME: The following explanation should go into the documentation: */
2025 /* (@bind ((var init) ...) body ...) will assign the values of the `init's to
2026 * the global variables named by `var's (symbols, not evaluated), creating
2027 * them if they don't exist, executes body, and then restores the previous
2028 * values of the `var's. Additionally, whenever control leaves body, the
2029 * values of the `var's are saved and restored when control returns. It is an
2030 * error when a symbol appears more than once among the `var's. All `init's
2031 * are evaluated before any `var' is set.
2033 * Think of this as `let' for dynamic scope.
2036 /* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into
2037 * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...).
2039 * FIXME - also implement `@bind*'.
2042 scm_m_atbind (SCM expr, SCM env)
2049 const SCM top_level = scm_env_top_level (env);
2051 const SCM cdr_expr = SCM_CDR (expr);
2052 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
2053 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
2054 bindings = SCM_CAR (cdr_expr);
2055 check_bindings (bindings, expr);
2056 transform_bindings (bindings, expr, &rvariables, &inits);
2058 for (variable_idx = rvariables;
2059 !scm_is_null (variable_idx);
2060 variable_idx = SCM_CDR (variable_idx))
2062 /* The first call to scm_sym2var will look beyond the current module,
2063 * while the second call wont. */
2064 const SCM variable = SCM_CAR (variable_idx);
2065 SCM new_variable = scm_sym2var (variable, top_level, SCM_BOOL_F);
2066 if (scm_is_false (new_variable))
2067 new_variable = scm_sym2var (variable, top_level, SCM_BOOL_T);
2068 SCM_SETCAR (variable_idx, new_variable);
2071 SCM_SETCAR (expr, SCM_IM_BIND);
2072 SCM_SETCAR (cdr_expr, scm_cons (rvariables, inits));
2077 SCM_SYNTAX(s_atcall_cc, "@call-with-current-continuation", scm_i_makbimacro, scm_m_cont);
2078 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc, s_atcall_cc);
2081 scm_m_cont (SCM expr, SCM env SCM_UNUSED)
2083 const SCM cdr_expr = SCM_CDR (expr);
2084 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
2085 ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
2087 SCM_SETCAR (expr, SCM_IM_CONT);
2092 unmemoize_atcall_cc (const SCM expr, const SCM env)
2094 return scm_list_2 (scm_sym_atcall_cc, unmemoize_exprs (SCM_CDR (expr), env));
2098 SCM_SYNTAX (s_at_call_with_values, "@call-with-values", scm_i_makbimacro, scm_m_at_call_with_values);
2099 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values, s_at_call_with_values);
2102 scm_m_at_call_with_values (SCM expr, SCM env SCM_UNUSED)
2104 const SCM cdr_expr = SCM_CDR (expr);
2105 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
2106 ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
2108 SCM_SETCAR (expr, SCM_IM_CALL_WITH_VALUES);
2113 unmemoize_at_call_with_values (const SCM expr, const SCM env)
2115 return scm_list_2 (scm_sym_at_call_with_values,
2116 unmemoize_exprs (SCM_CDR (expr), env));
2121 /* See futures.h for a comment why futures are not enabled.
2124 SCM_SYNTAX (s_future, "future", scm_i_makbimacro, scm_m_future);
2125 SCM_GLOBAL_SYMBOL (scm_sym_future, s_future);
2127 /* Like promises, futures are implemented as closures with an empty
2128 * parameter list. Thus, (future <expression>) is transformed into
2129 * (#@future '() <expression>), where the empty list represents the
2130 * empty parameter list. This representation allows for easy creation
2131 * of the closure during evaluation. */
2133 scm_m_future (SCM expr, SCM env)
2135 const SCM new_expr = memoize_as_thunk_prototype (expr, env);
2136 SCM_SETCAR (new_expr, SCM_IM_FUTURE);
2141 unmemoize_future (const SCM expr, const SCM env)
2143 const SCM thunk_expr = SCM_CADDR (expr);
2144 return scm_list_2 (scm_sym_future, unmemoize_expression (thunk_expr, env));
2149 SCM_SYNTAX (s_gset_x, "set!", scm_i_makbimacro, scm_m_generalized_set_x);
2150 SCM_SYMBOL (scm_sym_setter, "setter");
2153 scm_m_generalized_set_x (SCM expr, SCM env)
2155 SCM target, exp_target;
2157 const SCM cdr_expr = SCM_CDR (expr);
2158 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
2159 ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
2161 target = SCM_CAR (cdr_expr);
2162 if (!scm_is_pair (target))
2165 return scm_m_set_x (expr, env);
2169 /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */
2170 /* Macroexpanding the target might return things of the form
2171 (begin <atom>). In that case, <atom> must be a symbol or a
2172 variable and we memoize to (set! <atom> ...).
2174 exp_target = macroexp (target, env);
2175 if (scm_is_eq (SCM_CAR (exp_target), SCM_IM_BEGIN)
2176 && !scm_is_null (SCM_CDR (exp_target))
2177 && scm_is_null (SCM_CDDR (exp_target)))
2179 exp_target= SCM_CADR (exp_target);
2180 ASSERT_SYNTAX_2 (scm_is_symbol (exp_target)
2181 || SCM_VARIABLEP (exp_target),
2182 s_bad_variable, exp_target, expr);
2183 return scm_cons (SCM_IM_SET_X, scm_cons (exp_target,
2184 SCM_CDR (cdr_expr)));
2188 const SCM setter_proc_tail = scm_list_1 (SCM_CAR (target));
2189 const SCM setter_proc = scm_cons_source (expr, scm_sym_setter,
2192 const SCM cddr_expr = SCM_CDR (cdr_expr);
2193 const SCM setter_args = scm_append_x (scm_list_2 (SCM_CDR (target),
2196 SCM_SETCAR (expr, setter_proc);
2197 SCM_SETCDR (expr, setter_args);
2204 /* @slot-ref is bound privately in the (oop goops) module from goops.c. As
2205 * soon as the module system allows us to more freely create bindings in
2206 * arbitrary modules during the startup phase, the code from goops.c should be
2209 SCM_SYMBOL (sym_atslot_ref, "@slot-ref");
2212 scm_m_atslot_ref (SCM expr, SCM env SCM_UNUSED)
2216 const SCM cdr_expr = SCM_CDR (expr);
2217 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
2218 ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
2219 slot_nr = SCM_CADR (cdr_expr);
2220 ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr), s_bad_slot_number, slot_nr, expr);
2222 SCM_SETCAR (expr, SCM_IM_SLOT_REF);
2223 SCM_SETCDR (cdr_expr, slot_nr);
2228 unmemoize_atslot_ref (const SCM expr, const SCM env)
2230 const SCM instance = SCM_CADR (expr);
2231 const SCM um_instance = unmemoize_expression (instance, env);
2232 const SCM slot_nr = SCM_CDDR (expr);
2233 return scm_list_3 (sym_atslot_ref, um_instance, slot_nr);
2237 /* @slot-set! is bound privately in the (oop goops) module from goops.c. As
2238 * soon as the module system allows us to more freely create bindings in
2239 * arbitrary modules during the startup phase, the code from goops.c should be
2242 SCM_SYMBOL (sym_atslot_set_x, "@slot-set!");
2245 scm_m_atslot_set_x (SCM expr, SCM env SCM_UNUSED)
2249 const SCM cdr_expr = SCM_CDR (expr);
2250 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
2251 ASSERT_SYNTAX (scm_ilength (cdr_expr) == 3, s_expression, expr);
2252 slot_nr = SCM_CADR (cdr_expr);
2253 ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr), s_bad_slot_number, slot_nr, expr);
2255 SCM_SETCAR (expr, SCM_IM_SLOT_SET_X);
2260 unmemoize_atslot_set_x (const SCM expr, const SCM env)
2262 const SCM cdr_expr = SCM_CDR (expr);
2263 const SCM instance = SCM_CAR (cdr_expr);
2264 const SCM um_instance = unmemoize_expression (instance, env);
2265 const SCM cddr_expr = SCM_CDR (cdr_expr);
2266 const SCM slot_nr = SCM_CAR (cddr_expr);
2267 const SCM cdddr_expr = SCM_CDR (cddr_expr);
2268 const SCM value = SCM_CAR (cdddr_expr);
2269 const SCM um_value = unmemoize_expression (value, env);
2270 return scm_list_4 (sym_atslot_set_x, um_instance, slot_nr, um_value);
2274 #if SCM_ENABLE_ELISP
2276 static const char s_defun[] = "Symbol's function definition is void";
2278 SCM_SYNTAX (s_nil_cond, "nil-cond", scm_i_makbimacro, scm_m_nil_cond);
2280 /* nil-cond expressions have the form
2281 * (nil-cond COND VAL COND VAL ... ELSEVAL) */
2283 scm_m_nil_cond (SCM expr, SCM env SCM_UNUSED)
2285 const long length = scm_ilength (SCM_CDR (expr));
2286 ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
2287 ASSERT_SYNTAX (length >= 1 && (length % 2) == 1, s_expression, expr);
2289 SCM_SETCAR (expr, SCM_IM_NIL_COND);
2294 SCM_SYNTAX (s_atfop, "@fop", scm_i_makbimacro, scm_m_atfop);
2296 /* The @fop-macro handles procedure and macro applications for elisp. The
2297 * input expression must have the form
2298 * (@fop <var> (transformer-macro <expr> ...))
2299 * where <var> must be a symbol. The expression is transformed into the
2300 * memoized form of either
2301 * (apply <un-aliased var> (transformer-macro <expr> ...))
2302 * if the value of var (across all aliasing) is not a macro, or
2303 * (<un-aliased var> <expr> ...)
2304 * if var is a macro. */
2306 scm_m_atfop (SCM expr, SCM env SCM_UNUSED)
2311 const SCM cdr_expr = SCM_CDR (expr);
2312 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
2313 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 1, s_missing_expression, expr);
2315 symbol = SCM_CAR (cdr_expr);
2316 ASSERT_SYNTAX_2 (scm_is_symbol (symbol), s_bad_variable, symbol, expr);
2318 location = scm_symbol_fref (symbol);
2319 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location), s_defun, symbol, expr);
2321 /* The elisp function `defalias' allows to define aliases for symbols. To
2322 * look up such definitions, the chain of symbol definitions has to be
2323 * followed up to the terminal symbol. */
2324 while (scm_is_symbol (SCM_VARIABLE_REF (location)))
2326 const SCM alias = SCM_VARIABLE_REF (location);
2327 location = scm_symbol_fref (alias);
2328 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location), s_defun, symbol, expr);
2331 /* Memoize the value location belonging to the terminal symbol. */
2332 SCM_SETCAR (cdr_expr, location);
2334 if (!SCM_MACROP (SCM_VARIABLE_REF (location)))
2336 /* Since the location does not contain a macro, the form is a procedure
2337 * application. Replace `@fop' by `@apply' and transform the expression
2338 * including the `transformer-macro'. */
2339 SCM_SETCAR (expr, SCM_IM_APPLY);
2344 /* Since the location contains a macro, the arguments should not be
2345 * transformed, so the `transformer-macro' is cut out. The resulting
2346 * expression starts with the memoized variable, that is at the cdr of
2347 * the input expression. */
2348 SCM_SETCDR (cdr_expr, SCM_CDADR (cdr_expr));
2353 #endif /* SCM_ENABLE_ELISP */
2357 unmemoize_builtin_macro (const SCM expr, const SCM env)
2359 switch (ISYMNUM (SCM_CAR (expr)))
2361 case (ISYMNUM (SCM_IM_AND)):
2362 return unmemoize_and (expr, env);
2364 case (ISYMNUM (SCM_IM_BEGIN)):
2365 return unmemoize_begin (expr, env);
2367 case (ISYMNUM (SCM_IM_CASE)):
2368 return unmemoize_case (expr, env);
2370 case (ISYMNUM (SCM_IM_COND)):
2371 return unmemoize_cond (expr, env);
2373 case (ISYMNUM (SCM_IM_DELAY)):
2374 return unmemoize_delay (expr, env);
2376 case (ISYMNUM (SCM_IM_DO)):
2377 return unmemoize_do (expr, env);
2379 case (ISYMNUM (SCM_IM_IF)):
2380 return unmemoize_if (expr, env);
2382 case (ISYMNUM (SCM_IM_LAMBDA)):
2383 return unmemoize_lambda (expr, env);
2385 case (ISYMNUM (SCM_IM_LET)):
2386 return unmemoize_let (expr, env);
2388 case (ISYMNUM (SCM_IM_LETREC)):
2389 return unmemoize_letrec (expr, env);
2391 case (ISYMNUM (SCM_IM_LETSTAR)):
2392 return unmemoize_letstar (expr, env);
2394 case (ISYMNUM (SCM_IM_OR)):
2395 return unmemoize_or (expr, env);
2397 case (ISYMNUM (SCM_IM_QUOTE)):
2398 return unmemoize_quote (expr, env);
2400 case (ISYMNUM (SCM_IM_SET_X)):
2401 return unmemoize_set_x (expr, env);
2403 case (ISYMNUM (SCM_IM_APPLY)):
2404 return unmemoize_apply (expr, env);
2406 case (ISYMNUM (SCM_IM_BIND)):
2407 return unmemoize_exprs (expr, env); /* FIXME */
2409 case (ISYMNUM (SCM_IM_CONT)):
2410 return unmemoize_atcall_cc (expr, env);
2412 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
2413 return unmemoize_at_call_with_values (expr, env);
2416 /* See futures.h for a comment why futures are not enabled.
2418 case (ISYMNUM (SCM_IM_FUTURE)):
2419 return unmemoize_future (expr, env);
2422 case (ISYMNUM (SCM_IM_SLOT_REF)):
2423 return unmemoize_atslot_ref (expr, env);
2425 case (ISYMNUM (SCM_IM_SLOT_SET_X)):
2426 return unmemoize_atslot_set_x (expr, env);
2428 case (ISYMNUM (SCM_IM_NIL_COND)):
2429 return unmemoize_exprs (expr, env); /* FIXME */
2432 return unmemoize_exprs (expr, env); /* FIXME */
2437 /* scm_i_unmemocopy_expr and scm_i_unmemocopy_body take a memoized expression
2438 * respectively a memoized body together with its environment and rewrite it
2439 * to its original form. Thus, these functions are the inversion of the
2440 * rewrite rules above. The procedure is not optimized for speed. It's used
2441 * in scm_i_unmemoize_expr, scm_procedure_source, macro_print and scm_iprin1.
2443 * Unmemoizing is not a reliable process. You cannot in general expect to get
2444 * the original source back.
2446 * However, GOOPS currently relies on this for method compilation. This ought
2450 scm_i_unmemocopy_expr (SCM expr, SCM env)
2452 const SCM source_properties = scm_whash_lookup (scm_source_whash, expr);
2453 const SCM um_expr = unmemoize_expression (expr, env);
2455 if (scm_is_true (source_properties))
2456 scm_whash_insert (scm_source_whash, um_expr, source_properties);
2462 scm_i_unmemocopy_body (SCM forms, SCM env)
2464 const SCM source_properties = scm_whash_lookup (scm_source_whash, forms);
2465 const SCM um_forms = unmemoize_exprs (forms, env);
2467 if (scm_is_true (source_properties))
2468 scm_whash_insert (scm_source_whash, um_forms, source_properties);
2474 #if (SCM_ENABLE_DEPRECATED == 1)
2476 /* Deprecated in guile 1.7.0 on 2003-11-09. */
2478 scm_m_expand_body (SCM exprs, SCM env)
2480 scm_c_issue_deprecation_warning
2481 ("`scm_m_expand_body' is deprecated.");
2482 m_expand_body (exprs, env);
2487 SCM_SYNTAX (s_undefine, "undefine", scm_makacro, scm_m_undefine);
2490 scm_m_undefine (SCM expr, SCM env)
2495 const SCM cdr_expr = SCM_CDR (expr);
2496 ASSERT_SYNTAX (SCM_TOP_LEVEL (env), "Bad undefine placement in", expr);
2497 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
2498 ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
2500 scm_c_issue_deprecation_warning
2501 ("`undefine' is deprecated.\n");
2503 variable = SCM_CAR (cdr_expr);
2504 ASSERT_SYNTAX_2 (scm_is_symbol (variable), s_bad_variable, variable, expr);
2505 location = scm_sym2var (variable, scm_env_top_level (env), SCM_BOOL_F);
2506 ASSERT_SYNTAX_2 (scm_is_true (location)
2507 && !SCM_UNBNDP (SCM_VARIABLE_REF (location)),
2508 "variable already unbound ", variable, expr);
2509 SCM_VARIABLE_SET (location, SCM_UNDEFINED);
2510 return SCM_UNSPECIFIED;
2514 scm_macroexp (SCM x, SCM env)
2516 scm_c_issue_deprecation_warning
2517 ("`scm_macroexp' is deprecated.");
2518 return macroexp (x, env);
2524 #if (SCM_ENABLE_DEPRECATED == 1)
2527 scm_unmemocar (SCM form, SCM env)
2529 scm_c_issue_deprecation_warning
2530 ("`scm_unmemocar' is deprecated.");
2532 if (!scm_is_pair (form))
2536 SCM c = SCM_CAR (form);
2537 if (SCM_VARIABLEP (c))
2539 SCM sym = scm_module_reverse_lookup (scm_env_module (env), c);
2540 if (scm_is_false (sym))
2541 sym = sym_three_question_marks;
2542 SCM_SETCAR (form, sym);
2544 else if (SCM_ILOCP (c))
2546 unsigned long int ir;
2548 for (ir = SCM_IFRAME (c); ir != 0; --ir)
2549 env = SCM_CDR (env);
2550 env = SCM_CAAR (env);
2551 for (ir = SCM_IDIST (c); ir != 0; --ir)
2552 env = SCM_CDR (env);
2554 SCM_SETCAR (form, SCM_ICDRP (c) ? env : SCM_CAR (env));
2562 /*****************************************************************************/
2563 /*****************************************************************************/
2564 /* The definitions for execution start here. */
2565 /*****************************************************************************/
2566 /*****************************************************************************/
2568 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame, "enter-frame");
2569 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame, "apply-frame");
2570 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame, "exit-frame");
2571 SCM_GLOBAL_SYMBOL (scm_sym_trace, "trace");
2572 SCM_SYMBOL (sym_instead, "instead");
2574 /* A function object to implement "apply" for non-closure functions. */
2576 /* An endless list consisting of #<undefined> objects: */
2577 static SCM undefineds;
2581 scm_badargsp (SCM formals, SCM args)
2583 while (!scm_is_null (formals))
2585 if (!scm_is_pair (formals))
2587 if (scm_is_null (args))
2589 formals = SCM_CDR (formals);
2590 args = SCM_CDR (args);
2592 return !scm_is_null (args) ? 1 : 0;
2597 /* The evaluator contains a plethora of EVAL symbols. This is an attempt at
2600 * The following macros should be used in code which is read twice (where the
2601 * choice of evaluator is hard soldered):
2603 * CEVAL is the symbol used within one evaluator to call itself.
2604 * Originally, it is defined to ceval, but is redefined to deval during the
2607 * SCM_I_EVALIM is used when it is known that the expression is an
2608 * immediate. (This macro never calls an evaluator.)
2610 * EVAL evaluates an expression that is expected to have its symbols already
2611 * memoized. Expressions that are not of the form '(<form> <form> ...)' are
2612 * evaluated inline without calling an evaluator.
2614 * EVALCAR evaluates the car of an expression 'X:(Y:<form> <form> ...)',
2615 * potentially replacing a symbol at the position Y:<form> by its memoized
2616 * variable. If Y:<form> is not of the form '(<form> <form> ...)', the
2617 * evaluation is performed inline without calling an evaluator.
2619 * The following macros should be used in code which is read once
2620 * (where the choice of evaluator is dynamic):
2622 * SCM_I_XEVAL corresponds to EVAL, but uses ceval *or* deval depending on the
2625 * SCM_I_XEVALCAR corresponds to EVALCAR, but uses ceval *or* deval depending
2626 * on the debugging mode.
2628 * The main motivation for keeping this plethora is efficiency
2629 * together with maintainability (=> locality of code).
2632 static SCM ceval (SCM x, SCM env);
2633 static SCM deval (SCM x, SCM env);
2637 #define SCM_I_EVALIM2(x) \
2638 ((scm_is_eq ((x), SCM_EOL) \
2639 ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \
2643 #define SCM_I_EVALIM(x, env) (SCM_ILOCP (x) \
2644 ? *scm_ilookup ((x), (env)) \
2647 #define SCM_I_XEVAL(x, env) \
2649 ? SCM_I_EVALIM2 (x) \
2650 : (SCM_VARIABLEP (x) \
2651 ? SCM_VARIABLE_REF (x) \
2652 : (scm_is_pair (x) \
2653 ? (scm_debug_mode_p \
2654 ? deval ((x), (env)) \
2655 : ceval ((x), (env))) \
2658 #define SCM_I_XEVALCAR(x, env) \
2659 (SCM_IMP (SCM_CAR (x)) \
2660 ? SCM_I_EVALIM (SCM_CAR (x), (env)) \
2661 : (SCM_VARIABLEP (SCM_CAR (x)) \
2662 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2663 : (scm_is_pair (SCM_CAR (x)) \
2664 ? (scm_debug_mode_p \
2665 ? deval (SCM_CAR (x), (env)) \
2666 : ceval (SCM_CAR (x), (env))) \
2667 : (!scm_is_symbol (SCM_CAR (x)) \
2669 : *scm_lookupcar ((x), (env), 1)))))
2671 #define EVAL(x, env) \
2673 ? SCM_I_EVALIM ((x), (env)) \
2674 : (SCM_VARIABLEP (x) \
2675 ? SCM_VARIABLE_REF (x) \
2676 : (scm_is_pair (x) \
2677 ? CEVAL ((x), (env)) \
2680 #define EVALCAR(x, env) \
2681 (SCM_IMP (SCM_CAR (x)) \
2682 ? SCM_I_EVALIM (SCM_CAR (x), (env)) \
2683 : (SCM_VARIABLEP (SCM_CAR (x)) \
2684 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2685 : (scm_is_pair (SCM_CAR (x)) \
2686 ? CEVAL (SCM_CAR (x), (env)) \
2687 : (!scm_is_symbol (SCM_CAR (x)) \
2689 : *scm_lookupcar ((x), (env), 1)))))
2691 scm_i_pthread_mutex_t source_mutex;
2694 /* Lookup a given local variable in an environment. The local variable is
2695 * given as an iloc, that is a triple <frame, binding, last?>, where frame
2696 * indicates the relative number of the environment frame (counting upwards
2697 * from the innermost environment frame), binding indicates the number of the
2698 * binding within the frame, and last? (which is extracted from the iloc using
2699 * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
2700 * very end of the improper list of bindings. */
2702 scm_ilookup (SCM iloc, SCM env)
2704 unsigned int frame_nr = SCM_IFRAME (iloc);
2705 unsigned int binding_nr = SCM_IDIST (iloc);
2709 for (; 0 != frame_nr; --frame_nr)
2710 frames = SCM_CDR (frames);
2712 bindings = SCM_CAR (frames);
2713 for (; 0 != binding_nr; --binding_nr)
2714 bindings = SCM_CDR (bindings);
2716 if (SCM_ICDRP (iloc))
2717 return SCM_CDRLOC (bindings);
2718 return SCM_CARLOC (SCM_CDR (bindings));
2722 SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable");
2724 static void error_unbound_variable (SCM symbol) SCM_NORETURN;
2725 static void error_defined_variable (SCM symbol) SCM_NORETURN;
2727 /* Call this for variables that are unfound.
2730 error_unbound_variable (SCM symbol)
2732 scm_error (scm_unbound_variable_key, NULL,
2733 "Unbound variable: ~S",
2734 scm_list_1 (symbol), SCM_BOOL_F);
2737 /* Call this for variables that are found but contain SCM_UNDEFINED.
2740 error_defined_variable (SCM symbol)
2742 /* We use the 'unbound-variable' key here as well, since it
2743 basically is the same kind of error, with a slight variation in
2744 the displayed message.
2746 scm_error (scm_unbound_variable_key, NULL,
2747 "Variable used before given a value: ~S",
2748 scm_list_1 (symbol), SCM_BOOL_F);
2752 /* The Lookup Car Race
2755 Memoization of variables and special forms is done while executing
2756 the code for the first time. As long as there is only one thread
2757 everything is fine, but as soon as two threads execute the same
2758 code concurrently `for the first time' they can come into conflict.
2760 This memoization includes rewriting variable references into more
2761 efficient forms and expanding macros. Furthermore, macro expansion
2762 includes `compiling' special forms like `let', `cond', etc. into
2763 tree-code instructions.
2765 There shouldn't normally be a problem with memoizing local and
2766 global variable references (into ilocs and variables), because all
2767 threads will mutate the code in *exactly* the same way and (if I
2768 read the C code correctly) it is not possible to observe a half-way
2769 mutated cons cell. The lookup procedure can handle this
2770 transparently without any critical sections.
2772 It is different with macro expansion, because macro expansion
2773 happens outside of the lookup procedure and can't be
2774 undone. Therefore the lookup procedure can't cope with it. It has
2775 to indicate failure when it detects a lost race and hope that the
2776 caller can handle it. Luckily, it turns out that this is the case.
2778 An example to illustrate this: Suppose that the following form will
2779 be memoized concurrently by two threads
2783 Let's first examine the lookup of X in the body. The first thread
2784 decides that it has to find the symbol "x" in the environment and
2785 starts to scan it. Then the other thread takes over and actually
2786 overtakes the first. It looks up "x" and substitutes an
2787 appropriate iloc for it. Now the first thread continues and
2788 completes its lookup. It comes to exactly the same conclusions as
2789 the second one and could - without much ado - just overwrite the
2790 iloc with the same iloc.
2792 But let's see what will happen when the race occurs while looking
2793 up the symbol "let" at the start of the form. It could happen that
2794 the second thread interrupts the lookup of the first thread and not
2795 only substitutes a variable for it but goes right ahead and
2796 replaces it with the compiled form (#@let* (x 12) x). Now, when
2797 the first thread completes its lookup, it would replace the #@let*
2798 with a variable containing the "let" binding, effectively reverting
2799 the form to (let (x 12) x). This is wrong. It has to detect that
2800 it has lost the race and the evaluator has to reconsider the
2801 changed form completely.
2803 This race condition could be resolved with some kind of traffic
2804 light (like mutexes) around scm_lookupcar, but I think that it is
2805 best to avoid them in this case. They would serialize memoization
2806 completely and because lookup involves calling arbitrary Scheme
2807 code (via the lookup-thunk), threads could be blocked for an
2808 arbitrary amount of time or even deadlock. But with the current
2809 solution a lot of unnecessary work is potentially done. */
2811 /* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
2812 return NULL to indicate a failed lookup due to some race conditions
2813 between threads. This only happens when VLOC is the first cell of
2814 a special form that will eventually be memoized (like `let', etc.)
2815 In that case the whole lookup is bogus and the caller has to
2816 reconsider the complete special form.
2818 SCM_LOOKUPCAR is still there, of course. It just calls
2819 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
2820 should only be called when it is known that VLOC is not the first
2821 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
2822 for NULL. I think I've found the only places where this
2826 scm_lookupcar1 (SCM vloc, SCM genv, int check)
2829 register SCM *al, fl, var = SCM_CAR (vloc);
2830 register SCM iloc = SCM_ILOC00;
2831 for (; SCM_NIMP (env); env = SCM_CDR (env))
2833 if (!scm_is_pair (SCM_CAR (env)))
2835 al = SCM_CARLOC (env);
2836 for (fl = SCM_CAR (*al); SCM_NIMP (fl); fl = SCM_CDR (fl))
2838 if (!scm_is_pair (fl))
2840 if (scm_is_eq (fl, var))
2842 if (!scm_is_eq (SCM_CAR (vloc), var))
2844 SCM_SET_CELL_WORD_0 (vloc, SCM_UNPACK (iloc) + SCM_ICDR);
2845 return SCM_CDRLOC (*al);
2850 al = SCM_CDRLOC (*al);
2851 if (scm_is_eq (SCM_CAR (fl), var))
2853 if (SCM_UNBNDP (SCM_CAR (*al)))
2854 error_defined_variable (var);
2855 if (!scm_is_eq (SCM_CAR (vloc), var))
2857 SCM_SETCAR (vloc, iloc);
2858 return SCM_CARLOC (*al);
2860 iloc = SCM_PACK (SCM_UNPACK (iloc) + SCM_IDINC);
2862 iloc = SCM_PACK ((~SCM_IDSTMSK) & (SCM_UNPACK(iloc) + SCM_IFRINC));
2865 SCM top_thunk, real_var;
2868 top_thunk = SCM_CAR (env); /* env now refers to a
2869 top level env thunk */
2870 env = SCM_CDR (env);
2873 top_thunk = SCM_BOOL_F;
2874 real_var = scm_sym2var (var, top_thunk, SCM_BOOL_F);
2875 if (scm_is_false (real_var))
2878 if (!scm_is_null (env) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var)))
2883 if (scm_is_null (env))
2884 error_unbound_variable (var);
2886 scm_misc_error (NULL, "Damaged environment: ~S",
2891 /* A variable could not be found, but we shall
2892 not throw an error. */
2893 static SCM undef_object = SCM_UNDEFINED;
2894 return &undef_object;
2898 if (!scm_is_eq (SCM_CAR (vloc), var))
2900 /* Some other thread has changed the very cell we are working
2901 on. In effect, it must have done our job or messed it up
2904 var = SCM_CAR (vloc);
2905 if (SCM_VARIABLEP (var))
2906 return SCM_VARIABLE_LOC (var);
2907 if (SCM_ILOCP (var))
2908 return scm_ilookup (var, genv);
2909 /* We can't cope with anything else than variables and ilocs. When
2910 a special form has been memoized (i.e. `let' into `#@let') we
2911 return NULL and expect the calling function to do the right
2912 thing. For the evaluator, this means going back and redoing
2913 the dispatch on the car of the form. */
2917 SCM_SETCAR (vloc, real_var);
2918 return SCM_VARIABLE_LOC (real_var);
2923 scm_lookupcar (SCM vloc, SCM genv, int check)
2925 SCM *loc = scm_lookupcar1 (vloc, genv, check);
2932 /* During execution, look up a symbol in the top level of the given local
2933 * environment and return the corresponding variable object. If no binding
2934 * for the symbol can be found, an 'Unbound variable' error is signalled. */
2936 lazy_memoize_variable (const SCM symbol, const SCM environment)
2938 const SCM top_level = scm_env_top_level (environment);
2939 const SCM variable = scm_sym2var (symbol, top_level, SCM_BOOL_F);
2941 if (scm_is_false (variable))
2942 error_unbound_variable (symbol);
2949 scm_eval_car (SCM pair, SCM env)
2951 return SCM_I_XEVALCAR (pair, env);
2956 scm_eval_args (SCM l, SCM env, SCM proc)
2958 SCM results = SCM_EOL, *lloc = &results, res;
2959 while (scm_is_pair (l))
2961 res = EVALCAR (l, env);
2963 *lloc = scm_list_1 (res);
2964 lloc = SCM_CDRLOC (*lloc);
2967 if (!scm_is_null (l))
2968 scm_wrong_num_args (proc);
2974 scm_eval_body (SCM code, SCM env)
2979 next = SCM_CDR (code);
2980 while (!scm_is_null (next))
2982 if (SCM_IMP (SCM_CAR (code)))
2984 if (SCM_ISYMP (SCM_CAR (code)))
2986 scm_dynwind_begin (0);
2987 scm_i_dynwind_pthread_mutex_lock (&source_mutex);
2988 /* check for race condition */
2989 if (SCM_ISYMP (SCM_CAR (code)))
2990 m_expand_body (code, env);
2996 SCM_I_XEVAL (SCM_CAR (code), env);
2998 next = SCM_CDR (code);
3000 return SCM_I_XEVALCAR (code, env);
3006 /* SECTION: This code is specific for the debugging support. One
3007 * branch is read when DEVAL isn't defined, the other when DEVAL is
3013 #define SCM_APPLY scm_apply
3014 #define PREP_APPLY(proc, args)
3016 #define RETURN(x) do { return x; } while (0)
3017 #ifdef STACK_CHECKING
3018 #ifndef NO_CEVAL_STACK_CHECKING
3019 #define EVAL_STACK_CHECKING
3026 #define CEVAL deval /* Substitute all uses of ceval */
3029 #define SCM_APPLY scm_dapply
3032 #define PREP_APPLY(p, l) \
3033 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
3036 #define ENTER_APPLY \
3038 SCM_SET_ARGSREADY (debug);\
3039 if (scm_check_apply_p && SCM_TRAPS_P)\
3040 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && SCM_PROCTRACEP (proc)))\
3042 SCM tmp, tail = scm_from_bool(SCM_TRACED_FRAME_P (debug)); \
3043 SCM_SET_TRACED_FRAME (debug); \
3045 tmp = scm_make_debugobj (&debug);\
3046 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
3052 #define RETURN(e) do { proc = (e); goto exit; } while (0)
3054 #ifdef STACK_CHECKING
3055 #ifndef EVAL_STACK_CHECKING
3056 #define EVAL_STACK_CHECKING
3061 /* scm_last_debug_frame contains a pointer to the last debugging information
3062 * stack frame. It is accessed very often from the debugging evaluator, so it
3063 * should probably not be indirectly addressed. Better to save and restore it
3064 * from the current root at any stack swaps.
3067 /* scm_debug_eframe_size is the number of slots available for pseudo
3068 * stack frames at each real stack frame.
3071 long scm_debug_eframe_size;
3073 int scm_debug_mode_p;
3074 int scm_check_entry_p;
3075 int scm_check_apply_p;
3076 int scm_check_exit_p;
3078 long scm_eval_stack;
3080 scm_t_option scm_eval_opts[] = {
3081 { SCM_OPTION_INTEGER, "stack", 22000, "Size of thread stacks (in machine words)." }
3084 scm_t_option scm_debug_opts[] = {
3085 { SCM_OPTION_BOOLEAN, "cheap", 1,
3086 "*This option is now obsolete. Setting it has no effect." },
3087 { SCM_OPTION_BOOLEAN, "breakpoints", 0, "*Check for breakpoints." },
3088 { SCM_OPTION_BOOLEAN, "trace", 0, "*Trace mode." },
3089 { SCM_OPTION_BOOLEAN, "procnames", 1,
3090 "Record procedure names at definition." },
3091 { SCM_OPTION_BOOLEAN, "backwards", 0,
3092 "Display backtrace in anti-chronological order." },
3093 { SCM_OPTION_INTEGER, "width", 79, "Maximal width of backtrace." },
3094 { SCM_OPTION_INTEGER, "indent", 10, "Maximal indentation in backtrace." },
3095 { SCM_OPTION_INTEGER, "frames", 3,
3096 "Maximum number of tail-recursive frames in backtrace." },
3097 { SCM_OPTION_INTEGER, "maxdepth", 1000,
3098 "Maximal number of stored backtrace frames." },
3099 { SCM_OPTION_INTEGER, "depth", 20, "Maximal length of printed backtrace." },
3100 { SCM_OPTION_BOOLEAN, "backtrace", 0, "Show backtrace on error." },
3101 { SCM_OPTION_BOOLEAN, "debug", 0, "Use the debugging evaluator." },
3102 { SCM_OPTION_INTEGER, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
3103 { 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."},
3104 { SCM_OPTION_BOOLEAN, "warn-deprecated", 0, "Warn when deprecated features are used." }
3107 scm_t_option scm_evaluator_trap_table[] = {
3108 { SCM_OPTION_BOOLEAN, "traps", 0, "Enable evaluator traps." },
3109 { SCM_OPTION_BOOLEAN, "enter-frame", 0, "Trap when eval enters new frame." },
3110 { SCM_OPTION_BOOLEAN, "apply-frame", 0, "Trap when entering apply." },
3111 { SCM_OPTION_BOOLEAN, "exit-frame", 0, "Trap when exiting eval or apply." },
3112 { SCM_OPTION_SCM, "enter-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for enter-frame traps." },
3113 { SCM_OPTION_SCM, "apply-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for apply-frame traps." },
3114 { SCM_OPTION_SCM, "exit-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for exit-frame traps." }
3117 SCM_DEFINE (scm_eval_options_interface, "eval-options-interface", 0, 1, 0,
3119 "Option interface for the evaluation options. Instead of using\n"
3120 "this procedure directly, use the procedures @code{eval-enable},\n"
3121 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
3122 #define FUNC_NAME s_scm_eval_options_interface
3126 scm_dynwind_begin (0);
3127 scm_dynwind_critical_section (SCM_BOOL_F);
3128 ans = scm_options (setting,
3132 scm_eval_stack = SCM_EVAL_STACK * sizeof (void *);
3140 SCM_DEFINE (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0,
3142 "Option interface for the evaluator trap options.")
3143 #define FUNC_NAME s_scm_evaluator_traps
3146 SCM_CRITICAL_SECTION_START;
3147 ans = scm_options (setting,
3148 scm_evaluator_trap_table,
3149 SCM_N_EVALUATOR_TRAPS,
3151 /* njrev: same again. */
3152 SCM_RESET_DEBUG_MODE;
3153 SCM_CRITICAL_SECTION_END;
3160 deval_args (SCM l, SCM env, SCM proc, SCM *lloc)
3162 SCM *results = lloc;
3163 while (scm_is_pair (l))
3165 const SCM res = EVALCAR (l, env);
3167 *lloc = scm_list_1 (res);
3168 lloc = SCM_CDRLOC (*lloc);
3171 if (!scm_is_null (l))
3172 scm_wrong_num_args (proc);
3177 eval_letrec_inits (SCM env, SCM init_forms, SCM **init_values_eol)
3180 int i = 0, imax = sizeof (argv) / sizeof (SCM);
3182 while (!scm_is_null (init_forms))
3186 eval_letrec_inits (env, init_forms, init_values_eol);
3189 argv[i++] = EVALCAR (init_forms, env);
3190 init_forms = SCM_CDR (init_forms);
3193 for (i--; i >= 0; i--)
3195 **init_values_eol = scm_list_1 (argv[i]);
3196 *init_values_eol = SCM_CDRLOC (**init_values_eol);
3203 /* SECTION: This code is compiled twice.
3207 /* Update the toplevel environment frame ENV so that it refers to the
3208 * current module. */
3209 #define UPDATE_TOPLEVEL_ENV(env) \
3211 SCM p = scm_current_module_lookup_closure (); \
3212 if (p != SCM_CAR (env)) \
3213 env = scm_top_level_env (p); \
3217 #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
3218 ASSERT_SYNTAX (!scm_is_eq ((x), SCM_EOL), s_empty_combination, x)
3221 /* This is the evaluator. Like any real monster, it has three heads:
3223 * ceval is the non-debugging evaluator, deval is the debugging version. Both
3224 * are implemented using a common code base, using the following mechanism:
3225 * CEVAL is a macro, which is either defined to ceval or deval. Thus, there
3226 * is no function CEVAL, but the code for CEVAL actually compiles to either
3227 * ceval or deval. When CEVAL is defined to ceval, it is known that the macro
3228 * DEVAL is not defined. When CEVAL is defined to deval, then the macro DEVAL
3229 * is known to be defined. Thus, in CEVAL parts for the debugging evaluator
3230 * are enclosed within #ifdef DEVAL ... #endif.
3232 * All three (ceval, deval and their common implementation CEVAL) take two
3233 * input parameters, x and env: x is a single expression to be evalutated.
3234 * env is the environment in which bindings are searched.
3236 * x is known to be a pair. Since x is a single expression, it is necessarily
3237 * in a tail position. If x is just a call to another function like in the
3238 * expression (foo exp1 exp2 ...), the realization of that call therefore
3239 * _must_not_ increase stack usage (the evaluation of exp1, exp2 etc.,
3240 * however, may do so). This is realized by making extensive use of 'goto'
3241 * statements within the evaluator: The gotos replace recursive calls to
3242 * CEVAL, thus re-using the same stack frame that CEVAL was already using.
3243 * If, however, x represents some form that requires to evaluate a sequence of
3244 * expressions like (begin exp1 exp2 ...), then recursive calls to CEVAL are
3245 * performed for all but the last expression of that sequence. */
3248 CEVAL (SCM x, SCM env)
3252 scm_t_debug_frame debug;
3253 scm_t_debug_info *debug_info_end;
3254 debug.prev = scm_i_last_debug_frame ();
3257 * The debug.vect contains twice as much scm_t_debug_info frames as the
3258 * user has specified with (debug-set! frames <n>).
3260 * Even frames are eval frames, odd frames are apply frames.
3262 debug.vect = (scm_t_debug_info *) alloca (scm_debug_eframe_size
3263 * sizeof (scm_t_debug_info));
3264 debug.info = debug.vect;
3265 debug_info_end = debug.vect + scm_debug_eframe_size;
3266 scm_i_set_last_debug_frame (&debug);
3268 #ifdef EVAL_STACK_CHECKING
3269 if (scm_stack_checking_enabled_p && SCM_STACK_OVERFLOW_P (&proc))
3272 debug.info->e.exp = x;
3273 debug.info->e.env = env;
3275 scm_report_stack_overflow ();
3285 SCM_CLEAR_ARGSREADY (debug);
3286 if (SCM_OVERFLOWP (debug))
3289 * In theory, this should be the only place where it is necessary to
3290 * check for space in debug.vect since both eval frames and
3291 * available space are even.
3293 * For this to be the case, however, it is necessary that primitive
3294 * special forms which jump back to `loop', `begin' or some similar
3295 * label call PREP_APPLY.
3297 else if (++debug.info >= debug_info_end)
3299 SCM_SET_OVERFLOW (debug);
3304 debug.info->e.exp = x;
3305 debug.info->e.env = env;
3306 if (scm_check_entry_p && SCM_TRAPS_P)
3308 if (SCM_ENTER_FRAME_P
3309 || (SCM_BREAKPOINTS_P && scm_c_source_property_breakpoint_p (x)))
3312 SCM tail = scm_from_bool (SCM_TAILRECP (debug));
3313 SCM_SET_TAILREC (debug);
3314 stackrep = scm_make_debugobj (&debug);
3316 stackrep = scm_call_4 (SCM_ENTER_FRAME_HDLR,
3317 scm_sym_enter_frame,
3320 unmemoize_expression (x, env));
3322 if (scm_is_pair (stackrep) &&
3323 scm_is_eq (SCM_CAR (stackrep), sym_instead))
3325 /* This gives the possibility for the debugger to modify
3326 the source expression before evaluation. */
3327 x = SCM_CDR (stackrep);
3336 if (SCM_ISYMP (SCM_CAR (x)))
3338 switch (ISYMNUM (SCM_CAR (x)))
3340 case (ISYMNUM (SCM_IM_AND)):
3342 while (!scm_is_null (SCM_CDR (x)))
3344 SCM test_result = EVALCAR (x, env);
3345 if (scm_is_false (test_result) || SCM_NILP (test_result))
3346 RETURN (SCM_BOOL_F);
3350 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
3353 case (ISYMNUM (SCM_IM_BEGIN)):
3355 if (scm_is_null (x))
3356 RETURN (SCM_UNSPECIFIED);
3358 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
3361 /* If we are on toplevel with a lookup closure, we need to sync
3362 with the current module. */
3363 if (scm_is_pair (env) && !scm_is_pair (SCM_CAR (env)))
3365 UPDATE_TOPLEVEL_ENV (env);
3366 while (!scm_is_null (SCM_CDR (x)))
3369 UPDATE_TOPLEVEL_ENV (env);
3375 goto nontoplevel_begin;
3378 while (!scm_is_null (SCM_CDR (x)))
3380 const SCM form = SCM_CAR (x);
3383 if (SCM_ISYMP (form))
3385 scm_dynwind_begin (0);
3386 scm_i_dynwind_pthread_mutex_lock (&source_mutex);
3387 /* check for race condition */
3388 if (SCM_ISYMP (SCM_CAR (x)))
3389 m_expand_body (x, env);
3391 goto nontoplevel_begin;
3394 SCM_VALIDATE_NON_EMPTY_COMBINATION (form);
3397 (void) EVAL (form, env);
3403 /* scm_eval last form in list */
3404 const SCM last_form = SCM_CAR (x);
3406 if (scm_is_pair (last_form))
3408 /* This is by far the most frequent case. */
3410 goto loop; /* tail recurse */
3412 else if (SCM_IMP (last_form))
3413 RETURN (SCM_I_EVALIM (last_form, env));
3414 else if (SCM_VARIABLEP (last_form))
3415 RETURN (SCM_VARIABLE_REF (last_form));
3416 else if (scm_is_symbol (last_form))
3417 RETURN (*scm_lookupcar (x, env, 1));
3423 case (ISYMNUM (SCM_IM_CASE)):
3426 const SCM key = EVALCAR (x, env);
3428 while (!scm_is_null (x))
3430 const SCM clause = SCM_CAR (x);
3431 SCM labels = SCM_CAR (clause);
3432 if (scm_is_eq (labels, SCM_IM_ELSE))
3434 x = SCM_CDR (clause);
3435 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
3438 while (!scm_is_null (labels))
3440 const SCM label = SCM_CAR (labels);
3441 if (scm_is_eq (label, key)
3442 || scm_is_true (scm_eqv_p (label, key)))
3444 x = SCM_CDR (clause);
3445 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
3448 labels = SCM_CDR (labels);
3453 RETURN (SCM_UNSPECIFIED);
3456 case (ISYMNUM (SCM_IM_COND)):
3458 while (!scm_is_null (x))
3460 const SCM clause = SCM_CAR (x);
3461 if (scm_is_eq (SCM_CAR (clause), SCM_IM_ELSE))
3463 x = SCM_CDR (clause);
3464 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
3469 arg1 = EVALCAR (clause, env);
3470 /* SRFI 61 extended cond */
3471 if (!scm_is_null (SCM_CDR (clause))
3472 && !scm_is_null (SCM_CDDR (clause))
3473 && scm_is_eq (SCM_CADDR (clause), SCM_IM_ARROW))
3475 SCM xx, guard_result;
3476 if (SCM_VALUESP (arg1))
3477 arg1 = scm_struct_ref (arg1, SCM_INUM0);
3479 arg1 = scm_list_1 (arg1);
3480 xx = SCM_CDR (clause);
3481 proc = EVALCAR (xx, env);
3482 guard_result = SCM_APPLY (proc, arg1, SCM_EOL);
3483 if (scm_is_true (guard_result)
3484 && !SCM_NILP (guard_result))
3486 proc = SCM_CDDR (xx);
3487 proc = EVALCAR (proc, env);
3488 PREP_APPLY (proc, arg1);
3492 else if (scm_is_true (arg1) && !SCM_NILP (arg1))
3494 x = SCM_CDR (clause);
3495 if (scm_is_null (x))
3497 else if (!scm_is_eq (SCM_CAR (x), SCM_IM_ARROW))
3499 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
3505 proc = EVALCAR (proc, env);
3506 PREP_APPLY (proc, scm_list_1 (arg1));
3514 RETURN (SCM_UNSPECIFIED);
3517 case (ISYMNUM (SCM_IM_DO)):
3520 /* Compute the initialization values and the initial environment. */
3521 SCM init_forms = SCM_CAR (x);
3522 SCM init_values = SCM_EOL;
3523 while (!scm_is_null (init_forms))
3525 init_values = scm_cons (EVALCAR (init_forms, env), init_values);
3526 init_forms = SCM_CDR (init_forms);
3529 env = SCM_EXTEND_ENV (SCM_CAR (x), init_values, env);
3533 SCM test_form = SCM_CAR (x);
3534 SCM body_forms = SCM_CADR (x);
3535 SCM step_forms = SCM_CDDR (x);
3537 SCM test_result = EVALCAR (test_form, env);
3539 while (scm_is_false (test_result) || SCM_NILP (test_result))
3542 /* Evaluate body forms. */
3544 for (temp_forms = body_forms;
3545 !scm_is_null (temp_forms);
3546 temp_forms = SCM_CDR (temp_forms))
3548 SCM form = SCM_CAR (temp_forms);
3549 /* Dirk:FIXME: We only need to eval forms that may have
3550 * a side effect here. This is only true for forms that
3551 * start with a pair. All others are just constants.
3552 * Since with the current memoizer 'form' may hold a
3553 * constant, we call EVAL here to handle the constant
3554 * cases. In the long run it would make sense to have
3555 * the macro transformer of 'do' eliminate all forms
3556 * that have no sideeffect. Then instead of EVAL we
3557 * could call CEVAL directly here. */
3558 (void) EVAL (form, env);
3563 /* Evaluate the step expressions. */
3565 SCM step_values = SCM_EOL;
3566 for (temp_forms = step_forms;
3567 !scm_is_null (temp_forms);
3568 temp_forms = SCM_CDR (temp_forms))
3570 const SCM value = EVALCAR (temp_forms, env);
3571 step_values = scm_cons (value, step_values);
3573 env = SCM_EXTEND_ENV (SCM_CAAR (env),
3578 test_result = EVALCAR (test_form, env);
3582 if (scm_is_null (x))
3583 RETURN (SCM_UNSPECIFIED);
3584 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
3585 goto nontoplevel_begin;
3588 case (ISYMNUM (SCM_IM_IF)):
3591 SCM test_result = EVALCAR (x, env);
3592 x = SCM_CDR (x); /* then expression */
3593 if (scm_is_false (test_result) || SCM_NILP (test_result))
3595 x = SCM_CDR (x); /* else expression */
3596 if (scm_is_null (x))
3597 RETURN (SCM_UNSPECIFIED);
3600 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
3604 case (ISYMNUM (SCM_IM_LET)):
3607 SCM init_forms = SCM_CADR (x);
3608 SCM init_values = SCM_EOL;
3611 init_values = scm_cons (EVALCAR (init_forms, env), init_values);
3612 init_forms = SCM_CDR (init_forms);
3614 while (!scm_is_null (init_forms));
3615 env = SCM_EXTEND_ENV (SCM_CAR (x), init_values, env);
3618 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
3619 goto nontoplevel_begin;
3622 case (ISYMNUM (SCM_IM_LETREC)):
3624 env = SCM_EXTEND_ENV (SCM_CAR (x), undefineds, env);
3627 SCM init_forms = SCM_CAR (x);
3628 SCM init_values = scm_list_1 (SCM_BOOL_T);
3629 SCM *init_values_eol = SCM_CDRLOC (init_values);
3630 eval_letrec_inits (env, init_forms, &init_values_eol);
3631 SCM_SETCDR (SCM_CAR (env), SCM_CDR (init_values));
3634 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
3635 goto nontoplevel_begin;
3638 case (ISYMNUM (SCM_IM_LETSTAR)):
3641 SCM bindings = SCM_CAR (x);
3642 if (!scm_is_null (bindings))
3646 SCM name = SCM_CAR (bindings);
3647 SCM init = SCM_CDR (bindings);
3648 env = SCM_EXTEND_ENV (name, EVALCAR (init, env), env);
3649 bindings = SCM_CDR (init);
3651 while (!scm_is_null (bindings));
3655 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
3656 goto nontoplevel_begin;
3659 case (ISYMNUM (SCM_IM_OR)):
3661 while (!scm_is_null (SCM_CDR (x)))
3663 SCM val = EVALCAR (x, env);
3664 if (scm_is_true (val) && !SCM_NILP (val))
3669 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
3673 case (ISYMNUM (SCM_IM_LAMBDA)):
3674 RETURN (scm_closure (SCM_CDR (x), env));
3677 case (ISYMNUM (SCM_IM_QUOTE)):
3678 RETURN (SCM_CDR (x));
3681 case (ISYMNUM (SCM_IM_SET_X)):
3685 SCM variable = SCM_CAR (x);
3686 if (SCM_ILOCP (variable))
3687 location = scm_ilookup (variable, env);
3688 else if (SCM_VARIABLEP (variable))
3689 location = SCM_VARIABLE_LOC (variable);
3692 /* (scm_is_symbol (variable)) is known to be true */
3693 variable = lazy_memoize_variable (variable, env);
3694 SCM_SETCAR (x, variable);
3695 location = SCM_VARIABLE_LOC (variable);
3698 *location = EVALCAR (x, env);
3700 RETURN (SCM_UNSPECIFIED);
3703 case (ISYMNUM (SCM_IM_APPLY)):
3704 /* Evaluate the procedure to be applied. */
3706 proc = EVALCAR (x, env);
3707 PREP_APPLY (proc, SCM_EOL);
3709 /* Evaluate the argument holding the list of arguments */
3711 arg1 = EVALCAR (x, env);
3714 /* Go here to tail-apply a procedure. PROC is the procedure and
3715 * ARG1 is the list of arguments. PREP_APPLY must have been called
3716 * before jumping to apply_proc. */
3717 if (SCM_CLOSUREP (proc))
3719 SCM formals = SCM_CLOSURE_FORMALS (proc);
3721 debug.info->a.args = arg1;
3723 if (SCM_UNLIKELY (scm_badargsp (formals, arg1)))
3724 scm_wrong_num_args (proc);
3726 /* Copy argument list */
3727 if (SCM_NULL_OR_NIL_P (arg1))
3728 env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc));
3731 SCM args = scm_list_1 (SCM_CAR (arg1));
3733 arg1 = SCM_CDR (arg1);
3734 while (!SCM_NULL_OR_NIL_P (arg1))
3736 SCM new_tail = scm_list_1 (SCM_CAR (arg1));
3737 SCM_SETCDR (tail, new_tail);
3739 arg1 = SCM_CDR (arg1);
3741 env = SCM_EXTEND_ENV (formals, args, SCM_ENV (proc));
3744 x = SCM_CLOSURE_BODY (proc);
3745 goto nontoplevel_begin;
3750 RETURN (SCM_APPLY (proc, arg1, SCM_EOL));
3754 case (ISYMNUM (SCM_IM_CONT)):
3757 SCM val = scm_make_continuation (&first);
3765 proc = EVALCAR (proc, env);
3766 PREP_APPLY (proc, scm_list_1 (arg1));
3773 case (ISYMNUM (SCM_IM_DELAY)):
3774 RETURN (scm_makprom (scm_closure (SCM_CDR (x), env)));
3777 /* See futures.h for a comment why futures are not enabled.
3779 case (ISYMNUM (SCM_IM_FUTURE)):
3780 RETURN (scm_i_make_future (scm_closure (SCM_CDR (x), env)));
3783 /* PLACEHOLDER for case (ISYMNUM (SCM_IM_DISPATCH)): The following
3784 code (type_dispatch) is intended to be the tail of the case
3785 clause for the internal macro SCM_IM_DISPATCH. Please don't
3786 remove it from this location without discussing it with Mikael
3787 <djurfeldt@nada.kth.se> */
3789 /* The type dispatch code is duplicated below
3790 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
3791 * cuts down execution time for type dispatch to 50%. */
3792 type_dispatch: /* inputs: x, arg1 */
3793 /* Type dispatch means to determine from the types of the function
3794 * arguments (i. e. the 'signature' of the call), which method from
3795 * a generic function is to be called. This process of selecting
3796 * the right method takes some time. To speed it up, guile uses
3797 * caching: Together with the macro call to dispatch the signatures
3798 * of some previous calls to that generic function from the same
3799 * place are stored (in the code!) in a cache that we call the
3800 * 'method cache'. This is done since it is likely, that
3801 * consecutive calls to dispatch from that position in the code will
3802 * have the same signature. Thus, the type dispatch works as
3803 * follows: First, determine a hash value from the signature of the
3804 * actual arguments. Second, use this hash value as an index to
3805 * find that same signature in the method cache stored at this
3806 * position in the code. If found, you have also found the
3807 * corresponding method that belongs to that signature. If the
3808 * signature is not found in the method cache, you have to perform a
3809 * full search over all signatures stored with the generic
3812 unsigned long int specializers;
3813 unsigned long int hash_value;
3814 unsigned long int cache_end_pos;
3815 unsigned long int mask;
3819 SCM z = SCM_CDDR (x);
3820 SCM tmp = SCM_CADR (z);
3821 specializers = scm_to_ulong (SCM_CAR (z));
3823 /* Compute a hash value for searching the method cache. There
3824 * are two variants for computing the hash value, a (rather)
3825 * complicated one, and a simple one. For the complicated one
3826 * explained below, tmp holds a number that is used in the
3828 if (scm_is_simple_vector (tmp))
3830 /* This method of determining the hash value is much
3831 * simpler: Set the hash value to zero and just perform a
3832 * linear search through the method cache. */
3834 mask = (unsigned long int) ((long) -1);
3836 cache_end_pos = SCM_SIMPLE_VECTOR_LENGTH (method_cache);
3840 /* Use the signature of the actual arguments to determine
3841 * the hash value. This is done as follows: Each class has
3842 * an array of random numbers, that are determined when the
3843 * class is created. The integer 'hashset' is an index into
3844 * that array of random numbers. Now, from all classes that
3845 * are part of the signature of the actual arguments, the
3846 * random numbers at index 'hashset' are taken and summed
3847 * up, giving the hash value. The value of 'hashset' is
3848 * stored at the call to dispatch. This allows to have
3849 * different 'formulas' for calculating the hash value at
3850 * different places where dispatch is called. This allows
3851 * to optimize the hash formula at every individual place
3852 * where dispatch is called, such that hopefully the hash
3853 * value that is computed will directly point to the right
3854 * method in the method cache. */
3855 unsigned long int hashset = scm_to_ulong (tmp);
3856 unsigned long int counter = specializers + 1;
3859 while (!scm_is_null (tmp_arg) && counter != 0)
3861 SCM class = scm_class_of (SCM_CAR (tmp_arg));
3862 hash_value += SCM_INSTANCE_HASH (class, hashset);
3863 tmp_arg = SCM_CDR (tmp_arg);
3867 method_cache = SCM_CADR (z);
3868 mask = scm_to_ulong (SCM_CAR (z));
3870 cache_end_pos = hash_value;
3875 /* Search the method cache for a method with a matching
3876 * signature. Start the search at position 'hash_value'. The
3877 * hashing implementation uses linear probing for conflict
3878 * resolution, that is, if the signature in question is not
3879 * found at the starting index in the hash table, the next table
3880 * entry is tried, and so on, until in the worst case the whole
3881 * cache has been searched, but still the signature has not been
3886 SCM args = arg1; /* list of arguments */
3887 z = SCM_SIMPLE_VECTOR_REF (method_cache, hash_value);
3888 while (!scm_is_null (args))
3890 /* More arguments than specifiers => CLASS != ENV */
3891 SCM class_of_arg = scm_class_of (SCM_CAR (args));
3892 if (!scm_is_eq (class_of_arg, SCM_CAR (z)))
3894 args = SCM_CDR (args);
3897 /* Fewer arguments than specifiers => CAR != ENV */
3898 if (scm_is_null (SCM_CAR (z)) || scm_is_pair (SCM_CAR (z)))
3901 hash_value = (hash_value + 1) & mask;
3902 } while (hash_value != cache_end_pos);
3904 /* No appropriate method was found in the cache. */
3905 z = scm_memoize_method (x, arg1);
3907 apply_cmethod: /* inputs: z, arg1 */
3909 SCM formals = SCM_CMETHOD_FORMALS (z);
3910 env = SCM_EXTEND_ENV (formals, arg1, SCM_CMETHOD_ENV (z));
3911 x = SCM_CMETHOD_BODY (z);
3912 goto nontoplevel_begin;
3918 case (ISYMNUM (SCM_IM_SLOT_REF)):
3921 SCM instance = EVALCAR (x, env);
3922 unsigned long int slot = SCM_I_INUM (SCM_CDR (x));
3923 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot]));
3927 case (ISYMNUM (SCM_IM_SLOT_SET_X)):
3930 SCM instance = EVALCAR (x, env);
3931 unsigned long int slot = SCM_I_INUM (SCM_CADR (x));
3932 SCM value = EVALCAR (SCM_CDDR (x), env);
3933 SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (value);
3934 RETURN (SCM_UNSPECIFIED);
3938 #if SCM_ENABLE_ELISP
3940 case (ISYMNUM (SCM_IM_NIL_COND)):
3942 SCM test_form = SCM_CDR (x);
3943 x = SCM_CDR (test_form);
3944 while (!SCM_NULL_OR_NIL_P (x))
3946 SCM test_result = EVALCAR (test_form, env);
3947 if (!(scm_is_false (test_result)
3948 || SCM_NULL_OR_NIL_P (test_result)))
3950 if (scm_is_eq (SCM_CAR (x), SCM_UNSPECIFIED))
3951 RETURN (test_result);
3952 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
3957 test_form = SCM_CDR (x);
3958 x = SCM_CDR (test_form);
3962 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
3966 #endif /* SCM_ENABLE_ELISP */
3968 case (ISYMNUM (SCM_IM_BIND)):
3970 SCM vars, exps, vals;
3973 vars = SCM_CAAR (x);
3974 exps = SCM_CDAR (x);
3976 while (!scm_is_null (exps))
3978 vals = scm_cons (EVALCAR (exps, env), vals);
3979 exps = SCM_CDR (exps);
3982 scm_swap_bindings (vars, vals);
3983 scm_i_set_dynwinds (scm_acons (vars, vals, scm_i_dynwinds ()));
3985 /* Ignore all but the last evaluation result. */
3986 for (x = SCM_CDR (x); !scm_is_null (SCM_CDR (x)); x = SCM_CDR (x))
3988 if (scm_is_pair (SCM_CAR (x)))
3989 CEVAL (SCM_CAR (x), env);
3991 proc = EVALCAR (x, env);
3993 scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
3994 scm_swap_bindings (vars, vals);
4000 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
4005 producer = EVALCAR (x, env);
4007 proc = EVALCAR (x, env); /* proc is the consumer. */
4008 arg1 = SCM_APPLY (producer, SCM_EOL, SCM_EOL);
4009 if (SCM_VALUESP (arg1))
4011 /* The list of arguments is not copied. Rather, it is assumed
4012 * that this has been done by the 'values' procedure. */
4013 arg1 = scm_struct_ref (arg1, SCM_INUM0);
4017 arg1 = scm_list_1 (arg1);
4019 PREP_APPLY (proc, arg1);
4030 if (SCM_VARIABLEP (SCM_CAR (x)))
4031 proc = SCM_VARIABLE_REF (SCM_CAR (x));
4032 else if (SCM_ILOCP (SCM_CAR (x)))
4033 proc = *scm_ilookup (SCM_CAR (x), env);
4034 else if (scm_is_pair (SCM_CAR (x)))
4035 proc = CEVAL (SCM_CAR (x), env);
4036 else if (scm_is_symbol (SCM_CAR (x)))
4038 SCM orig_sym = SCM_CAR (x);
4040 SCM *location = scm_lookupcar1 (x, env, 1);
4041 if (location == NULL)
4043 /* we have lost the race, start again. */
4049 if (SCM_MACROP (proc))
4051 SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of
4053 handle_a_macro: /* inputs: x, env, proc */
4055 /* Set a flag during macro expansion so that macro
4056 application frames can be deleted from the backtrace. */
4057 SCM_SET_MACROEXP (debug);
4059 arg1 = SCM_APPLY (SCM_MACRO_CODE (proc), x,
4060 scm_cons (env, scm_listofnull));
4062 SCM_CLEAR_MACROEXP (debug);
4064 switch (SCM_MACRO_TYPE (proc))
4068 if (!scm_is_pair (arg1))
4069 arg1 = scm_list_2 (SCM_IM_BEGIN, arg1);
4071 assert (!scm_is_eq (x, SCM_CAR (arg1))
4072 && !scm_is_eq (x, SCM_CDR (arg1)));
4075 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc)))
4077 SCM_CRITICAL_SECTION_START;
4078 SCM_SETCAR (x, SCM_CAR (arg1));
4079 SCM_SETCDR (x, SCM_CDR (arg1));
4080 SCM_CRITICAL_SECTION_END;
4083 /* Prevent memoizing of debug info expression. */
4084 debug.info->e.exp = scm_cons_source (debug.info->e.exp,
4088 SCM_CRITICAL_SECTION_START;
4089 SCM_SETCAR (x, SCM_CAR (arg1));
4090 SCM_SETCDR (x, SCM_CDR (arg1));
4091 SCM_CRITICAL_SECTION_END;
4092 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
4094 #if SCM_ENABLE_DEPRECATED == 1
4099 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
4113 if (SCM_MACROP (proc))
4114 goto handle_a_macro;
4118 /* When reaching this part of the code, the following is granted: Variable x
4119 * holds the first pair of an expression of the form (<function> arg ...).
4120 * Variable proc holds the object that resulted from the evaluation of
4121 * <function>. In the following, the arguments (if any) will be evaluated,
4122 * and proc will be applied to them. If proc does not really hold a
4123 * function object, this will be signalled as an error on the scheme
4124 * level. If the number of arguments does not match the number of arguments
4125 * that are allowed to be passed to proc, also an error on the scheme level
4126 * will be signalled. */
4127 PREP_APPLY (proc, SCM_EOL);
4128 if (scm_is_null (SCM_CDR (x))) {
4131 SCM_ASRTGO (!SCM_IMP (proc), badfun);
4132 switch (SCM_TYP7 (proc))
4133 { /* no arguments given */
4134 case scm_tc7_subr_0:
4135 RETURN (SCM_SUBRF (proc) ());
4136 case scm_tc7_subr_1o:
4137 RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED));
4139 RETURN (SCM_SUBRF (proc) (SCM_EOL));
4140 case scm_tc7_rpsubr:
4141 RETURN (SCM_BOOL_T);
4143 RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED));
4145 if (!SCM_SMOB_APPLICABLE_P (proc))
4147 RETURN (SCM_SMOB_APPLY_0 (proc));
4150 proc = SCM_CCLO_SUBR (proc);
4152 debug.info->a.proc = proc;
4153 debug.info->a.args = scm_list_1 (arg1);
4157 proc = SCM_PROCEDURE (proc);
4159 debug.info->a.proc = proc;
4161 if (!SCM_CLOSUREP (proc))
4164 case scm_tcs_closures:
4166 const SCM formals = SCM_CLOSURE_FORMALS (proc);
4167 if (SCM_UNLIKELY (scm_is_pair (formals)))
4169 x = SCM_CLOSURE_BODY (proc);
4170 env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc));
4171 goto nontoplevel_begin;
4173 case scm_tcs_struct:
4174 if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
4176 x = SCM_ENTITY_PROCEDURE (proc);
4180 else if (SCM_I_OPERATORP (proc))
4183 proc = (SCM_I_ENTITYP (proc)
4184 ? SCM_ENTITY_PROCEDURE (proc)
4185 : SCM_OPERATOR_PROCEDURE (proc));
4187 debug.info->a.proc = proc;
4188 debug.info->a.args = scm_list_1 (arg1);
4194 case scm_tc7_subr_1:
4195 case scm_tc7_subr_2:
4196 case scm_tc7_subr_2o:
4199 case scm_tc7_subr_3:
4200 case scm_tc7_lsubr_2:
4202 scm_wrong_num_args (proc);
4205 scm_misc_error (NULL, "Wrong type to apply: ~S", scm_list_1 (proc));
4209 /* must handle macros by here */
4211 if (SCM_LIKELY (scm_is_pair (x)))
4212 arg1 = EVALCAR (x, env);
4214 scm_wrong_num_args (proc);
4216 debug.info->a.args = scm_list_1 (arg1);
4221 if (scm_is_null (x))
4224 evap1: /* inputs: proc, arg1 */
4225 SCM_ASRTGO (!SCM_IMP (proc), badfun);
4226 switch (SCM_TYP7 (proc))
4227 { /* have one argument in arg1 */
4228 case scm_tc7_subr_2o:
4229 RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
4230 case scm_tc7_subr_1:
4231 case scm_tc7_subr_1o:
4232 RETURN (SCM_SUBRF (proc) (arg1));
4234 if (SCM_I_INUMP (arg1))
4236 RETURN (scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1))));
4238 else if (SCM_REALP (arg1))
4240 RETURN (scm_from_double (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
4242 else if (SCM_BIGP (arg1))
4244 RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
4246 else if (SCM_FRACTIONP (arg1))
4248 RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1))));
4250 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
4252 scm_i_symbol_chars (SCM_SNAME (proc)));
4254 RETURN (scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc)));
4255 case scm_tc7_rpsubr:
4256 RETURN (SCM_BOOL_T);
4258 RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
4261 RETURN (SCM_SUBRF (proc) (debug.info->a.args));
4263 RETURN (SCM_SUBRF (proc) (scm_list_1 (arg1)));
4266 if (!SCM_SMOB_APPLICABLE_P (proc))
4268 RETURN (SCM_SMOB_APPLY_1 (proc, arg1));
4272 proc = SCM_CCLO_SUBR (proc);
4274 debug.info->a.args = scm_cons (arg1, debug.info->a.args);
4275 debug.info->a.proc = proc;
4279 proc = SCM_PROCEDURE (proc);
4281 debug.info->a.proc = proc;
4283 if (!SCM_CLOSUREP (proc))
4286 case scm_tcs_closures:
4289 const SCM formals = SCM_CLOSURE_FORMALS (proc);
4290 if (SCM_UNLIKELY (scm_is_null (formals)
4291 || (scm_is_pair (formals) &&
4292 scm_is_pair (SCM_CDR (formals)))))
4294 x = SCM_CLOSURE_BODY (proc);
4296 env = SCM_EXTEND_ENV (formals,
4300 env = SCM_EXTEND_ENV (formals,
4304 goto nontoplevel_begin;
4306 case scm_tcs_struct:
4307 if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
4309 x = SCM_ENTITY_PROCEDURE (proc);
4311 arg1 = debug.info->a.args;
4313 arg1 = scm_list_1 (arg1);
4317 else if (SCM_I_OPERATORP (proc))
4321 proc = (SCM_I_ENTITYP (proc)
4322 ? SCM_ENTITY_PROCEDURE (proc)
4323 : SCM_OPERATOR_PROCEDURE (proc));
4325 debug.info->a.args = scm_cons (arg1, debug.info->a.args);
4326 debug.info->a.proc = proc;
4332 case scm_tc7_subr_2:
4333 case scm_tc7_subr_0:
4334 case scm_tc7_subr_3:
4335 case scm_tc7_lsubr_2:
4336 scm_wrong_num_args (proc);
4341 if (SCM_LIKELY (scm_is_pair (x)))
4342 arg2 = EVALCAR (x, env);
4344 scm_wrong_num_args (proc);
4346 { /* have two or more arguments */
4348 debug.info->a.args = scm_list_2 (arg1, arg2);
4351 if (scm_is_null (x)) {
4354 SCM_ASRTGO (!SCM_IMP (proc), badfun);
4355 switch (SCM_TYP7 (proc))
4356 { /* have two arguments */
4357 case scm_tc7_subr_2:
4358 case scm_tc7_subr_2o:
4359 RETURN (SCM_SUBRF (proc) (arg1, arg2));
4362 RETURN (SCM_SUBRF (proc) (debug.info->a.args));
4364 RETURN (SCM_SUBRF (proc) (scm_list_2 (arg1, arg2)));
4366 case scm_tc7_lsubr_2:
4367 RETURN (SCM_SUBRF (proc) (arg1, arg2, SCM_EOL));
4368 case scm_tc7_rpsubr:
4370 RETURN (SCM_SUBRF (proc) (arg1, arg2));
4372 if (!SCM_SMOB_APPLICABLE_P (proc))
4374 RETURN (SCM_SMOB_APPLY_2 (proc, arg1, arg2));
4378 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc),
4379 scm_cons (proc, debug.info->a.args),
4382 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc),
4383 scm_cons2 (proc, arg1,
4390 case scm_tcs_struct:
4391 if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
4393 x = SCM_ENTITY_PROCEDURE (proc);
4395 arg1 = debug.info->a.args;
4397 arg1 = scm_list_2 (arg1, arg2);
4401 else if (SCM_I_OPERATORP (proc))
4405 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc)
4406 ? SCM_ENTITY_PROCEDURE (proc)
4407 : SCM_OPERATOR_PROCEDURE (proc),
4408 scm_cons (proc, debug.info->a.args),
4411 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc)
4412 ? SCM_ENTITY_PROCEDURE (proc)
4413 : SCM_OPERATOR_PROCEDURE (proc),
4414 scm_cons2 (proc, arg1,
4424 case scm_tc7_subr_0:
4427 case scm_tc7_subr_1o:
4428 case scm_tc7_subr_1:
4429 case scm_tc7_subr_3:
4430 scm_wrong_num_args (proc);
4434 proc = SCM_PROCEDURE (proc);
4436 debug.info->a.proc = proc;
4438 if (!SCM_CLOSUREP (proc))
4441 case scm_tcs_closures:
4444 const SCM formals = SCM_CLOSURE_FORMALS (proc);
4446 (scm_is_null (formals)
4447 || (scm_is_pair (formals)
4448 && (scm_is_null (SCM_CDR (formals))
4449 || (scm_is_pair (SCM_CDR (formals))
4450 && scm_is_pair (SCM_CDDR (formals)))))))
4453 env = SCM_EXTEND_ENV (formals,
4457 env = SCM_EXTEND_ENV (formals,
4458 scm_list_2 (arg1, arg2),
4461 x = SCM_CLOSURE_BODY (proc);
4462 goto nontoplevel_begin;
4466 if (SCM_UNLIKELY (!scm_is_pair (x)))
4467 scm_wrong_num_args (proc);
4469 debug.info->a.args = scm_cons2 (arg1, arg2,
4470 deval_args (x, env, proc,
4471 SCM_CDRLOC (SCM_CDR (debug.info->a.args))));
4475 SCM_ASRTGO (!SCM_IMP (proc), badfun);
4476 switch (SCM_TYP7 (proc))
4477 { /* have 3 or more arguments */
4479 case scm_tc7_subr_3:
4480 if (SCM_UNLIKELY (!scm_is_null (SCM_CDR (x))))
4481 scm_wrong_num_args (proc);
4483 RETURN (SCM_SUBRF (proc) (arg1, arg2,
4484 SCM_CADDR (debug.info->a.args)));
4486 arg1 = SCM_SUBRF(proc)(arg1, arg2);
4487 arg2 = SCM_CDDR (debug.info->a.args);
4490 arg1 = SCM_SUBRF(proc)(arg1, SCM_CAR (arg2));
4491 arg2 = SCM_CDR (arg2);
4493 while (SCM_NIMP (arg2));
4495 case scm_tc7_rpsubr:
4496 if (scm_is_false (SCM_SUBRF (proc) (arg1, arg2)))
4497 RETURN (SCM_BOOL_F);
4498 arg1 = SCM_CDDR (debug.info->a.args);
4501 if (scm_is_false (SCM_SUBRF (proc) (arg2, SCM_CAR (arg1))))
4502 RETURN (SCM_BOOL_F);
4503 arg2 = SCM_CAR (arg1);
4504 arg1 = SCM_CDR (arg1);
4506 while (SCM_NIMP (arg1));
4507 RETURN (SCM_BOOL_T);
4508 case scm_tc7_lsubr_2:
4509 RETURN (SCM_SUBRF (proc) (arg1, arg2,
4510 SCM_CDDR (debug.info->a.args)));
4512 RETURN (SCM_SUBRF (proc) (debug.info->a.args));
4514 if (!SCM_SMOB_APPLICABLE_P (proc))
4516 RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2,
4517 SCM_CDDR (debug.info->a.args)));
4521 proc = SCM_PROCEDURE (proc);
4522 debug.info->a.proc = proc;
4523 if (!SCM_CLOSUREP (proc))
4526 case scm_tcs_closures:
4528 const SCM formals = SCM_CLOSURE_FORMALS (proc);
4529 if (scm_is_null (formals)
4530 || (scm_is_pair (formals)
4531 && (scm_is_null (SCM_CDR (formals))
4532 || (scm_is_pair (SCM_CDR (formals))
4533 && scm_badargsp (SCM_CDDR (formals), x)))))
4535 SCM_SET_ARGSREADY (debug);
4536 env = SCM_EXTEND_ENV (formals,
4539 x = SCM_CLOSURE_BODY (proc);
4540 goto nontoplevel_begin;
4543 case scm_tc7_subr_3:
4544 if (SCM_UNLIKELY (!scm_is_null (SCM_CDR (x))))
4545 scm_wrong_num_args (proc);
4547 RETURN (SCM_SUBRF (proc) (arg1, arg2, EVALCAR (x, env)));
4549 arg1 = SCM_SUBRF (proc) (arg1, arg2);
4552 arg1 = SCM_SUBRF(proc)(arg1, EVALCAR(x, env));
4555 while (!scm_is_null (x));
4557 case scm_tc7_rpsubr:
4558 if (scm_is_false (SCM_SUBRF (proc) (arg1, arg2)))
4559 RETURN (SCM_BOOL_F);
4562 arg1 = EVALCAR (x, env);
4563 if (scm_is_false (SCM_SUBRF (proc) (arg2, arg1)))
4564 RETURN (SCM_BOOL_F);
4568 while (!scm_is_null (x));
4569 RETURN (SCM_BOOL_T);
4570 case scm_tc7_lsubr_2:
4571 RETURN (SCM_SUBRF (proc) (arg1, arg2, scm_eval_args (x, env, proc)));
4573 RETURN (SCM_SUBRF (proc) (scm_cons2 (arg1,
4575 scm_eval_args (x, env, proc))));
4577 if (!SCM_SMOB_APPLICABLE_P (proc))
4579 RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2,
4580 scm_eval_args (x, env, proc)));
4584 proc = SCM_PROCEDURE (proc);
4585 if (!SCM_CLOSUREP (proc))
4588 case scm_tcs_closures:
4590 const SCM formals = SCM_CLOSURE_FORMALS (proc);
4591 if (scm_is_null (formals)
4592 || (scm_is_pair (formals)
4593 && (scm_is_null (SCM_CDR (formals))
4594 || (scm_is_pair (SCM_CDR (formals))
4595 && scm_badargsp (SCM_CDDR (formals), x)))))
4597 env = SCM_EXTEND_ENV (formals,
4600 scm_eval_args (x, env, proc)),
4602 x = SCM_CLOSURE_BODY (proc);
4603 goto nontoplevel_begin;
4606 case scm_tcs_struct:
4607 if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
4610 arg1 = debug.info->a.args;
4612 arg1 = scm_cons2 (arg1, arg2, scm_eval_args (x, env, proc));
4614 x = SCM_ENTITY_PROCEDURE (proc);
4617 else if (SCM_I_OPERATORP (proc))
4621 case scm_tc7_subr_2:
4622 case scm_tc7_subr_1o:
4623 case scm_tc7_subr_2o:
4624 case scm_tc7_subr_0:
4627 case scm_tc7_subr_1:
4628 scm_wrong_num_args (proc);
4636 if (scm_check_exit_p && SCM_TRAPS_P)
4637 if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug)))
4639 SCM_CLEAR_TRACED_FRAME (debug);
4640 arg1 = scm_make_debugobj (&debug);
4642 arg1 = scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, arg1, proc);
4644 if (scm_is_pair (arg1) && scm_is_eq (SCM_CAR (arg1), sym_instead))
4645 proc = SCM_CDR (arg1);
4647 scm_i_set_last_debug_frame (debug.prev);
4653 /* SECTION: This code is compiled once.
4660 /* Simple procedure calls
4664 scm_call_0 (SCM proc)
4666 return scm_apply (proc, SCM_EOL, SCM_EOL);
4670 scm_call_1 (SCM proc, SCM arg1)
4672 return scm_apply (proc, arg1, scm_listofnull);
4676 scm_call_2 (SCM proc, SCM arg1, SCM arg2)
4678 return scm_apply (proc, arg1, scm_cons (arg2, scm_listofnull));
4682 scm_call_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3)
4684 return scm_apply (proc, arg1, scm_cons2 (arg2, arg3, scm_listofnull));
4688 scm_call_4 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4)
4690 return scm_apply (proc, arg1, scm_cons2 (arg2, arg3,
4691 scm_cons (arg4, scm_listofnull)));
4694 /* Simple procedure applies
4698 scm_apply_0 (SCM proc, SCM args)
4700 return scm_apply (proc, args, SCM_EOL);
4704 scm_apply_1 (SCM proc, SCM arg1, SCM args)
4706 return scm_apply (proc, scm_cons (arg1, args), SCM_EOL);
4710 scm_apply_2 (SCM proc, SCM arg1, SCM arg2, SCM args)
4712 return scm_apply (proc, scm_cons2 (arg1, arg2, args), SCM_EOL);
4716 scm_apply_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM args)
4718 return scm_apply (proc, scm_cons (arg1, scm_cons2 (arg2, arg3, args)),
4722 /* This code processes the arguments to apply:
4724 (apply PROC ARG1 ... ARGS)
4726 Given a list (ARG1 ... ARGS), this function conses the ARG1
4727 ... arguments onto the front of ARGS, and returns the resulting
4728 list. Note that ARGS is a list; thus, the argument to this
4729 function is a list whose last element is a list.
4731 Apply calls this function, and applies PROC to the elements of the
4732 result. apply:nconc2last takes care of building the list of
4733 arguments, given (ARG1 ... ARGS).
4735 Rather than do new consing, apply:nconc2last destroys its argument.
4736 On that topic, this code came into my care with the following
4737 beautifully cryptic comment on that topic: "This will only screw
4738 you if you do (scm_apply scm_apply '( ... ))" If you know what
4739 they're referring to, send me a patch to this comment. */
4741 SCM_DEFINE (scm_nconc2last, "apply:nconc2last", 1, 0, 0,
4743 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
4744 "conses the @var{arg1} @dots{} arguments onto the front of\n"
4745 "@var{args}, and returns the resulting list. Note that\n"
4746 "@var{args} is a list; thus, the argument to this function is\n"
4747 "a list whose last element is a list.\n"
4748 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
4749 "destroys its argument, so use with care.")
4750 #define FUNC_NAME s_scm_nconc2last
4753 SCM_VALIDATE_NONEMPTYLIST (1, lst);
4755 while (!scm_is_null (SCM_CDR (*lloc))) /* Perhaps should be
4756 SCM_NULL_OR_NIL_P, but not
4757 needed in 99.99% of cases,
4758 and it could seriously hurt
4759 performance. - Neil */
4760 lloc = SCM_CDRLOC (*lloc);
4761 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc)) >= 0, lst, SCM_ARG1, FUNC_NAME);
4762 *lloc = SCM_CAR (*lloc);
4770 /* SECTION: When DEVAL is defined this code yields scm_dapply.
4771 * It is compiled twice.
4776 scm_apply (SCM proc, SCM arg1, SCM args)
4782 scm_dapply (SCM proc, SCM arg1, SCM args)
4787 /* Apply a function to a list of arguments.
4789 This function is exported to the Scheme level as taking two
4790 required arguments and a tail argument, as if it were:
4791 (lambda (proc arg1 . args) ...)
4792 Thus, if you just have a list of arguments to pass to a procedure,
4793 pass the list as ARG1, and '() for ARGS. If you have some fixed
4794 args, pass the first as ARG1, then cons any remaining fixed args
4795 onto the front of your argument list, and pass that as ARGS. */
4798 SCM_APPLY (SCM proc, SCM arg1, SCM args)
4801 scm_t_debug_frame debug;
4802 scm_t_debug_info debug_vect_body;
4803 debug.prev = scm_i_last_debug_frame ();
4804 debug.status = SCM_APPLYFRAME;
4805 debug.vect = &debug_vect_body;
4806 debug.vect[0].a.proc = proc;
4807 debug.vect[0].a.args = SCM_EOL;
4808 scm_i_set_last_debug_frame (&debug);
4810 if (scm_debug_mode_p)
4811 return scm_dapply (proc, arg1, args);
4814 SCM_ASRTGO (SCM_NIMP (proc), badproc);
4816 /* If ARGS is the empty list, then we're calling apply with only two
4817 arguments --- ARG1 is the list of arguments for PROC. Whatever
4818 the case, futz with things so that ARG1 is the first argument to
4819 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
4822 Setting the debug apply frame args this way is pretty messy.
4823 Perhaps we should store arg1 and args directly in the frame as
4824 received, and let scm_frame_arguments unpack them, because that's
4825 a relatively rare operation. This works for now; if the Guile
4826 developer archives are still around, see Mikael's post of
4828 if (scm_is_null (args))
4830 if (scm_is_null (arg1))
4832 arg1 = SCM_UNDEFINED;
4834 debug.vect[0].a.args = SCM_EOL;
4840 debug.vect[0].a.args = arg1;
4842 args = SCM_CDR (arg1);
4843 arg1 = SCM_CAR (arg1);
4848 args = scm_nconc2last (args);
4850 debug.vect[0].a.args = scm_cons (arg1, args);
4854 if (SCM_ENTER_FRAME_P && SCM_TRAPS_P)
4856 SCM tmp = scm_make_debugobj (&debug);
4858 scm_call_2 (SCM_ENTER_FRAME_HDLR, scm_sym_enter_frame, tmp);
4864 switch (SCM_TYP7 (proc))
4866 case scm_tc7_subr_2o:
4867 if (SCM_UNLIKELY (SCM_UNBNDP (arg1)))
4868 scm_wrong_num_args (proc);
4869 if (scm_is_null (args))
4870 args = SCM_UNDEFINED;
4873 if (SCM_UNLIKELY (!scm_is_null (SCM_CDR (args))))
4874 scm_wrong_num_args (proc);
4875 args = SCM_CAR (args);
4877 RETURN (SCM_SUBRF (proc) (arg1, args));
4878 case scm_tc7_subr_2:
4879 if (SCM_UNLIKELY (scm_is_null (args) || !scm_is_null (SCM_CDR (args))))
4880 scm_wrong_num_args (proc);
4881 args = SCM_CAR (args);
4882 RETURN (SCM_SUBRF (proc) (arg1, args));
4883 case scm_tc7_subr_0:
4884 if (SCM_UNLIKELY (!SCM_UNBNDP (arg1)))
4885 scm_wrong_num_args (proc);
4887 RETURN (SCM_SUBRF (proc) ());
4888 case scm_tc7_subr_1:
4889 if (SCM_UNLIKELY (SCM_UNBNDP (arg1)))
4890 scm_wrong_num_args (proc);
4891 case scm_tc7_subr_1o:
4892 if (SCM_UNLIKELY (!scm_is_null (args)))
4893 scm_wrong_num_args (proc);
4895 RETURN (SCM_SUBRF (proc) (arg1));
4897 if (SCM_UNLIKELY (SCM_UNBNDP (arg1) || !scm_is_null (args)))
4898 scm_wrong_num_args (proc);
4899 if (SCM_I_INUMP (arg1))
4901 RETURN (scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1))));
4903 else if (SCM_REALP (arg1))
4905 RETURN (scm_from_double (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
4907 else if (SCM_BIGP (arg1))
4909 RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
4911 else if (SCM_FRACTIONP (arg1))
4913 RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1))));
4915 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
4916 SCM_ARG1, scm_i_symbol_chars (SCM_SNAME (proc)));
4918 if (SCM_UNLIKELY (SCM_UNBNDP (arg1) || !scm_is_null (args)))
4919 scm_wrong_num_args (proc);
4920 RETURN (scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc)));
4921 case scm_tc7_subr_3:
4922 if (SCM_UNLIKELY (scm_is_null (args)
4923 || scm_is_null (SCM_CDR (args))
4924 || !scm_is_null (SCM_CDDR (args))))
4925 scm_wrong_num_args (proc);
4927 RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CADR (args)));
4930 RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args));
4932 RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args)));
4934 case scm_tc7_lsubr_2:
4935 if (SCM_UNLIKELY (!scm_is_pair (args)))
4936 scm_wrong_num_args (proc);
4938 RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CDR (args)));
4940 if (scm_is_null (args))
4941 RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
4942 while (SCM_NIMP (args))
4944 SCM_ASSERT (scm_is_pair (args), args, SCM_ARG2, "apply");
4945 arg1 = SCM_SUBRF (proc) (arg1, SCM_CAR (args));
4946 args = SCM_CDR (args);
4949 case scm_tc7_rpsubr:
4950 if (scm_is_null (args))
4951 RETURN (SCM_BOOL_T);
4952 while (SCM_NIMP (args))
4954 SCM_ASSERT (scm_is_pair (args), args, SCM_ARG2, "apply");
4955 if (scm_is_false (SCM_SUBRF (proc) (arg1, SCM_CAR (args))))
4956 RETURN (SCM_BOOL_F);
4957 arg1 = SCM_CAR (args);
4958 args = SCM_CDR (args);
4960 RETURN (SCM_BOOL_T);
4961 case scm_tcs_closures:
4963 arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args);
4965 arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args));
4967 if (SCM_UNLIKELY (scm_badargsp (SCM_CLOSURE_FORMALS (proc), arg1)))
4968 scm_wrong_num_args (proc);
4970 /* Copy argument list */
4975 SCM tl = args = scm_cons (SCM_CAR (arg1), SCM_UNSPECIFIED);
4976 for (arg1 = SCM_CDR (arg1); scm_is_pair (arg1); arg1 = SCM_CDR (arg1))
4978 SCM_SETCDR (tl, scm_cons (SCM_CAR (arg1), SCM_UNSPECIFIED));
4981 SCM_SETCDR (tl, arg1);
4984 args = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
4987 proc = SCM_CLOSURE_BODY (proc);
4989 arg1 = SCM_CDR (proc);
4990 while (!scm_is_null (arg1))
4992 if (SCM_IMP (SCM_CAR (proc)))
4994 if (SCM_ISYMP (SCM_CAR (proc)))
4996 scm_dynwind_begin (0);
4997 scm_i_dynwind_pthread_mutex_lock (&source_mutex);
4998 /* check for race condition */
4999 if (SCM_ISYMP (SCM_CAR (proc)))
5000 m_expand_body (proc, args);
5005 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc));
5008 (void) EVAL (SCM_CAR (proc), args);
5010 arg1 = SCM_CDR (proc);
5012 RETURN (EVALCAR (proc, args));
5014 if (!SCM_SMOB_APPLICABLE_P (proc))
5016 if (SCM_UNBNDP (arg1))
5017 RETURN (SCM_SMOB_APPLY_0 (proc));
5018 else if (scm_is_null (args))
5019 RETURN (SCM_SMOB_APPLY_1 (proc, arg1));
5020 else if (scm_is_null (SCM_CDR (args)))
5021 RETURN (SCM_SMOB_APPLY_2 (proc, arg1, SCM_CAR (args)));
5023 RETURN (SCM_SMOB_APPLY_3 (proc, arg1, SCM_CAR (args), SCM_CDR (args)));
5026 args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
5028 proc = SCM_CCLO_SUBR (proc);
5029 debug.vect[0].a.proc = proc;
5030 debug.vect[0].a.args = scm_cons (arg1, args);
5032 args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
5034 proc = SCM_CCLO_SUBR (proc);
5038 proc = SCM_PROCEDURE (proc);
5040 debug.vect[0].a.proc = proc;
5043 case scm_tcs_struct:
5044 if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
5047 args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
5049 args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
5051 RETURN (scm_apply_generic (proc, args));
5053 else if (SCM_I_OPERATORP (proc))
5057 args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
5059 args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
5062 proc = (SCM_I_ENTITYP (proc)
5063 ? SCM_ENTITY_PROCEDURE (proc)
5064 : SCM_OPERATOR_PROCEDURE (proc));
5066 debug.vect[0].a.proc = proc;
5067 debug.vect[0].a.args = scm_cons (arg1, args);
5069 if (SCM_NIMP (proc))
5078 scm_wrong_type_arg ("apply", SCM_ARG1, proc);
5082 if (scm_check_exit_p && SCM_TRAPS_P)
5083 if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug)))
5085 SCM_CLEAR_TRACED_FRAME (debug);
5086 arg1 = scm_make_debugobj (&debug);
5088 arg1 = scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, arg1, proc);
5090 if (scm_is_pair (arg1) && scm_is_eq (SCM_CAR (arg1), sym_instead))
5091 proc = SCM_CDR (arg1);
5093 scm_i_set_last_debug_frame (debug.prev);
5099 /* SECTION: The rest of this file is only read once.
5106 * Trampolines make it possible to move procedure application dispatch
5107 * outside inner loops. The motivation was clean implementation of
5108 * efficient replacements of R5RS primitives in SRFI-1.
5110 * The semantics is clear: scm_trampoline_N returns an optimized
5111 * version of scm_call_N (or NULL if the procedure isn't applicable
5114 * Applying the optimization to map and for-each increased efficiency
5115 * noticeably. For example, (map abs ls) is now 8 times faster than
5120 call_subr0_0 (SCM proc)
5122 return SCM_SUBRF (proc) ();
5126 call_subr1o_0 (SCM proc)
5128 return SCM_SUBRF (proc) (SCM_UNDEFINED);
5132 call_lsubr_0 (SCM proc)
5134 return SCM_SUBRF (proc) (SCM_EOL);
5138 scm_i_call_closure_0 (SCM proc)
5140 const SCM env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
5143 const SCM result = scm_eval_body (SCM_CLOSURE_BODY (proc), env);
5148 scm_trampoline_0 (SCM proc)
5150 scm_t_trampoline_0 trampoline;
5155 switch (SCM_TYP7 (proc))
5157 case scm_tc7_subr_0:
5158 trampoline = call_subr0_0;
5160 case scm_tc7_subr_1o:
5161 trampoline = call_subr1o_0;
5164 trampoline = call_lsubr_0;
5166 case scm_tcs_closures:
5168 SCM formals = SCM_CLOSURE_FORMALS (proc);
5169 if (scm_is_null (formals) || !scm_is_pair (formals))
5170 trampoline = scm_i_call_closure_0;
5175 case scm_tcs_struct:
5176 if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
5177 trampoline = scm_call_generic_0;
5178 else if (SCM_I_OPERATORP (proc))
5179 trampoline = scm_call_0;
5184 if (SCM_SMOB_APPLICABLE_P (proc))
5185 trampoline = SCM_SMOB_DESCRIPTOR (proc).apply_0;
5190 case scm_tc7_rpsubr:
5193 trampoline = scm_call_0;
5196 return NULL; /* not applicable on zero arguments */
5198 /* We only reach this point if a valid trampoline was determined. */
5200 /* If debugging is enabled, we want to see all calls to proc on the stack.
5201 * Thus, we replace the trampoline shortcut with scm_call_0. */
5202 if (scm_debug_mode_p)
5209 call_subr1_1 (SCM proc, SCM arg1)
5211 return SCM_SUBRF (proc) (arg1);
5215 call_subr2o_1 (SCM proc, SCM arg1)
5217 return SCM_SUBRF (proc) (arg1, SCM_UNDEFINED);
5221 call_lsubr_1 (SCM proc, SCM arg1)
5223 return SCM_SUBRF (proc) (scm_list_1 (arg1));
5227 call_dsubr_1 (SCM proc, SCM arg1)
5229 if (SCM_I_INUMP (arg1))
5231 RETURN (scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1))));
5233 else if (SCM_REALP (arg1))
5235 RETURN (scm_from_double (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
5237 else if (SCM_BIGP (arg1))
5239 RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
5241 else if (SCM_FRACTIONP (arg1))
5243 RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1))));
5245 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
5246 SCM_ARG1, scm_i_symbol_chars (SCM_SNAME (proc)));
5250 call_cxr_1 (SCM proc, SCM arg1)
5252 return scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc));
5256 call_closure_1 (SCM proc, SCM arg1)
5258 const SCM env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
5261 const SCM result = scm_eval_body (SCM_CLOSURE_BODY (proc), env);
5266 scm_trampoline_1 (SCM proc)
5268 scm_t_trampoline_1 trampoline;
5273 switch (SCM_TYP7 (proc))
5275 case scm_tc7_subr_1:
5276 case scm_tc7_subr_1o:
5277 trampoline = call_subr1_1;
5279 case scm_tc7_subr_2o:
5280 trampoline = call_subr2o_1;
5283 trampoline = call_lsubr_1;
5286 trampoline = call_dsubr_1;
5289 trampoline = call_cxr_1;
5291 case scm_tcs_closures:
5293 SCM formals = SCM_CLOSURE_FORMALS (proc);
5294 if (!scm_is_null (formals)
5295 && (!scm_is_pair (formals) || !scm_is_pair (SCM_CDR (formals))))
5296 trampoline = call_closure_1;
5301 case scm_tcs_struct:
5302 if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
5303 trampoline = scm_call_generic_1;
5304 else if (SCM_I_OPERATORP (proc))
5305 trampoline = scm_call_1;
5310 if (SCM_SMOB_APPLICABLE_P (proc))
5311 trampoline = SCM_SMOB_DESCRIPTOR (proc).apply_1;
5316 case scm_tc7_rpsubr:
5319 trampoline = scm_call_1;
5322 return NULL; /* not applicable on one arg */
5324 /* We only reach this point if a valid trampoline was determined. */
5326 /* If debugging is enabled, we want to see all calls to proc on the stack.
5327 * Thus, we replace the trampoline shortcut with scm_call_1. */
5328 if (scm_debug_mode_p)
5335 call_subr2_2 (SCM proc, SCM arg1, SCM arg2)
5337 return SCM_SUBRF (proc) (arg1, arg2);
5341 call_lsubr2_2 (SCM proc, SCM arg1, SCM arg2)
5343 return SCM_SUBRF (proc) (arg1, arg2, SCM_EOL);
5347 call_lsubr_2 (SCM proc, SCM arg1, SCM arg2)
5349 return SCM_SUBRF (proc) (scm_list_2 (arg1, arg2));
5353 call_closure_2 (SCM proc, SCM arg1, SCM arg2)
5355 const SCM env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
5356 scm_list_2 (arg1, arg2),
5358 const SCM result = scm_eval_body (SCM_CLOSURE_BODY (proc), env);
5363 scm_trampoline_2 (SCM proc)
5365 scm_t_trampoline_2 trampoline;
5370 switch (SCM_TYP7 (proc))
5372 case scm_tc7_subr_2:
5373 case scm_tc7_subr_2o:
5374 case scm_tc7_rpsubr:
5376 trampoline = call_subr2_2;
5378 case scm_tc7_lsubr_2:
5379 trampoline = call_lsubr2_2;
5382 trampoline = call_lsubr_2;
5384 case scm_tcs_closures:
5386 SCM formals = SCM_CLOSURE_FORMALS (proc);
5387 if (!scm_is_null (formals)
5388 && (!scm_is_pair (formals)
5389 || (!scm_is_null (SCM_CDR (formals))
5390 && (!scm_is_pair (SCM_CDR (formals))
5391 || !scm_is_pair (SCM_CDDR (formals))))))
5392 trampoline = call_closure_2;
5397 case scm_tcs_struct:
5398 if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
5399 trampoline = scm_call_generic_2;
5400 else if (SCM_I_OPERATORP (proc))
5401 trampoline = scm_call_2;
5406 if (SCM_SMOB_APPLICABLE_P (proc))
5407 trampoline = SCM_SMOB_DESCRIPTOR (proc).apply_2;
5413 trampoline = scm_call_2;
5416 return NULL; /* not applicable on two args */
5418 /* We only reach this point if a valid trampoline was determined. */
5420 /* If debugging is enabled, we want to see all calls to proc on the stack.
5421 * Thus, we replace the trampoline shortcut with scm_call_2. */
5422 if (scm_debug_mode_p)
5428 /* Typechecking for multi-argument MAP and FOR-EACH.
5430 Verify that each element of the vector ARGV, except for the first,
5431 is a proper list whose length is LEN. Attribute errors to WHO,
5432 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
5434 check_map_args (SCM argv,
5443 for (i = SCM_SIMPLE_VECTOR_LENGTH (argv) - 1; i >= 1; i--)
5445 SCM elt = SCM_SIMPLE_VECTOR_REF (argv, i);
5446 long elt_len = scm_ilength (elt);
5451 scm_apply_generic (gf, scm_cons (proc, args));
5453 scm_wrong_type_arg (who, i + 2, elt);
5457 scm_out_of_range_pos (who, elt, scm_from_long (i + 2));
5462 SCM_GPROC (s_map, "map", 2, 0, 1, scm_map, g_map);
5464 /* Note: Currently, scm_map applies PROC to the argument list(s)
5465 sequentially, starting with the first element(s). This is used in
5466 evalext.c where the Scheme procedure `map-in-order', which guarantees
5467 sequential behaviour, is implemented using scm_map. If the
5468 behaviour changes, we need to update `map-in-order'.
5472 scm_map (SCM proc, SCM arg1, SCM args)
5473 #define FUNC_NAME s_map
5479 len = scm_ilength (arg1);
5480 SCM_GASSERTn (len >= 0,
5481 g_map, scm_cons2 (proc, arg1, args), SCM_ARG2, s_map);
5482 SCM_VALIDATE_REST_ARGUMENT (args);
5483 if (scm_is_null (args))
5485 scm_t_trampoline_1 call = scm_trampoline_1 (proc);
5486 SCM_GASSERT2 (call, g_map, proc, arg1, SCM_ARG1, s_map);
5487 while (SCM_NIMP (arg1))
5489 *pres = scm_list_1 (call (proc, SCM_CAR (arg1)));
5490 pres = SCM_CDRLOC (*pres);
5491 arg1 = SCM_CDR (arg1);
5495 if (scm_is_null (SCM_CDR (args)))
5497 SCM arg2 = SCM_CAR (args);
5498 int len2 = scm_ilength (arg2);
5499 scm_t_trampoline_2 call = scm_trampoline_2 (proc);
5501 g_map, scm_cons2 (proc, arg1, args), SCM_ARG1, s_map);
5502 SCM_GASSERTn (len2 >= 0,
5503 g_map, scm_cons2 (proc, arg1, args), SCM_ARG3, s_map);
5505 SCM_OUT_OF_RANGE (3, arg2);
5506 while (SCM_NIMP (arg1))
5508 *pres = scm_list_1 (call (proc, SCM_CAR (arg1), SCM_CAR (arg2)));
5509 pres = SCM_CDRLOC (*pres);
5510 arg1 = SCM_CDR (arg1);
5511 arg2 = SCM_CDR (arg2);
5515 arg1 = scm_cons (arg1, args);
5516 args = scm_vector (arg1);
5517 check_map_args (args, len, g_map, proc, arg1, s_map);
5521 for (i = SCM_SIMPLE_VECTOR_LENGTH (args) - 1; i >= 0; i--)
5523 SCM elt = SCM_SIMPLE_VECTOR_REF (args, i);
5526 arg1 = scm_cons (SCM_CAR (elt), arg1);
5527 SCM_SIMPLE_VECTOR_SET (args, i, SCM_CDR (elt));
5529 *pres = scm_list_1 (scm_apply (proc, arg1, SCM_EOL));
5530 pres = SCM_CDRLOC (*pres);
5536 SCM_GPROC (s_for_each, "for-each", 2, 0, 1, scm_for_each, g_for_each);
5539 scm_for_each (SCM proc, SCM arg1, SCM args)
5540 #define FUNC_NAME s_for_each
5543 len = scm_ilength (arg1);
5544 SCM_GASSERTn (len >= 0, g_for_each, scm_cons2 (proc, arg1, args),
5545 SCM_ARG2, s_for_each);
5546 SCM_VALIDATE_REST_ARGUMENT (args);
5547 if (scm_is_null (args))
5549 scm_t_trampoline_1 call = scm_trampoline_1 (proc);
5550 SCM_GASSERT2 (call, g_for_each, proc, arg1, SCM_ARG1, s_for_each);
5551 while (SCM_NIMP (arg1))
5553 call (proc, SCM_CAR (arg1));
5554 arg1 = SCM_CDR (arg1);
5556 return SCM_UNSPECIFIED;
5558 if (scm_is_null (SCM_CDR (args)))
5560 SCM arg2 = SCM_CAR (args);
5561 int len2 = scm_ilength (arg2);
5562 scm_t_trampoline_2 call = scm_trampoline_2 (proc);
5563 SCM_GASSERTn (call, g_for_each,
5564 scm_cons2 (proc, arg1, args), SCM_ARG1, s_for_each);
5565 SCM_GASSERTn (len2 >= 0, g_for_each,
5566 scm_cons2 (proc, arg1, args), SCM_ARG3, s_for_each);
5568 SCM_OUT_OF_RANGE (3, arg2);
5569 while (SCM_NIMP (arg1))
5571 call (proc, SCM_CAR (arg1), SCM_CAR (arg2));
5572 arg1 = SCM_CDR (arg1);
5573 arg2 = SCM_CDR (arg2);
5575 return SCM_UNSPECIFIED;
5577 arg1 = scm_cons (arg1, args);
5578 args = scm_vector (arg1);
5579 check_map_args (args, len, g_for_each, proc, arg1, s_for_each);
5583 for (i = SCM_SIMPLE_VECTOR_LENGTH (args) - 1; i >= 0; i--)
5585 SCM elt = SCM_SIMPLE_VECTOR_REF (args, i);
5587 return SCM_UNSPECIFIED;
5588 arg1 = scm_cons (SCM_CAR (elt), arg1);
5589 SCM_SIMPLE_VECTOR_SET (args, i, SCM_CDR (elt));
5591 scm_apply (proc, arg1, SCM_EOL);
5598 scm_closure (SCM code, SCM env)
5601 SCM closcar = scm_cons (code, SCM_EOL);
5602 z = scm_cell (SCM_UNPACK (closcar) + scm_tc3_closure, (scm_t_bits) env);
5603 scm_remember_upto_here (closcar);
5608 scm_t_bits scm_tc16_promise;
5611 scm_makprom (SCM code)
5613 SCM_RETURN_NEWSMOB2 (scm_tc16_promise,
5615 scm_make_recursive_mutex ());
5619 promise_mark (SCM promise)
5621 scm_gc_mark (SCM_PROMISE_MUTEX (promise));
5622 return SCM_PROMISE_DATA (promise);
5626 promise_free (SCM promise)
5632 promise_print (SCM exp, SCM port, scm_print_state *pstate)
5634 int writingp = SCM_WRITINGP (pstate);
5635 scm_puts ("#<promise ", port);
5636 SCM_SET_WRITINGP (pstate, 1);
5637 scm_iprin1 (SCM_PROMISE_DATA (exp), port, pstate);
5638 SCM_SET_WRITINGP (pstate, writingp);
5639 scm_putc ('>', port);
5643 SCM_DEFINE (scm_force, "force", 1, 0, 0,
5645 "If the promise @var{x} has not been computed yet, compute and\n"
5646 "return @var{x}, otherwise just return the previously computed\n"
5648 #define FUNC_NAME s_scm_force
5650 SCM_VALIDATE_SMOB (1, promise, promise);
5651 scm_lock_mutex (SCM_PROMISE_MUTEX (promise));
5652 if (!SCM_PROMISE_COMPUTED_P (promise))
5654 SCM ans = scm_call_0 (SCM_PROMISE_DATA (promise));
5655 if (!SCM_PROMISE_COMPUTED_P (promise))
5657 SCM_SET_PROMISE_DATA (promise, ans);
5658 SCM_SET_PROMISE_COMPUTED (promise);
5661 scm_unlock_mutex (SCM_PROMISE_MUTEX (promise));
5662 return SCM_PROMISE_DATA (promise);
5667 SCM_DEFINE (scm_promise_p, "promise?", 1, 0, 0,
5669 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
5670 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
5671 #define FUNC_NAME s_scm_promise_p
5673 return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_promise, obj));
5678 SCM_DEFINE (scm_cons_source, "cons-source", 3, 0, 0,
5679 (SCM xorig, SCM x, SCM y),
5680 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
5681 "Any source properties associated with @var{xorig} are also associated\n"
5682 "with the new pair.")
5683 #define FUNC_NAME s_scm_cons_source
5686 z = scm_cons (x, y);
5687 /* Copy source properties possibly associated with xorig. */
5688 p = scm_whash_lookup (scm_source_whash, xorig);
5689 if (scm_is_true (p))
5690 scm_whash_insert (scm_source_whash, z, p);
5696 /* The function scm_copy_tree is used to copy an expression tree to allow the
5697 * memoizer to modify the expression during memoization. scm_copy_tree
5698 * creates deep copies of pairs and vectors, but not of any other data types,
5699 * since only pairs and vectors will be parsed by the memoizer.
5701 * To avoid infinite recursion due to cyclic structures, the hare-and-tortoise
5702 * pattern is used to detect cycles. In fact, the pattern is used in two
5703 * dimensions, vertical (indicated in the code by the variable names 'hare'
5704 * and 'tortoise') and horizontal ('rabbit' and 'turtle'). In both
5705 * dimensions, the hare/rabbit will take two steps when the tortoise/turtle
5708 * The vertical dimension corresponds to recursive calls to function
5709 * copy_tree: This happens when descending into vector elements, into cars of
5710 * lists and into the cdr of an improper list. In this dimension, the
5711 * tortoise follows the hare by using the processor stack: Every stack frame
5712 * will hold an instance of struct t_trace. These instances are connected in
5713 * a way that represents the trace of the hare, which thus can be followed by
5714 * the tortoise. The tortoise will always point to struct t_trace instances
5715 * relating to SCM objects that have already been copied. Thus, a cycle is
5716 * detected if the tortoise and the hare point to the same object,
5718 * The horizontal dimension is within one execution of copy_tree, when the
5719 * function cdr's along the pairs of a list. This is the standard
5720 * hare-and-tortoise implementation, found several times in guile. */
5723 struct t_trace *trace; /* These pointers form a trace along the stack. */
5724 SCM obj; /* The object handled at the respective stack frame.*/
5729 struct t_trace *const hare,
5730 struct t_trace *tortoise,
5731 unsigned int tortoise_delay )
5733 if (!scm_is_pair (hare->obj) && !scm_is_simple_vector (hare->obj))
5739 /* Prepare the trace along the stack. */
5740 struct t_trace new_hare;
5741 hare->trace = &new_hare;
5743 /* The tortoise will make its step after the delay has elapsed. Note
5744 * that in contrast to the typical hare-and-tortoise pattern, the step
5745 * of the tortoise happens before the hare takes its steps. This is, in
5746 * principle, no problem, except for the start of the algorithm: Then,
5747 * it has to be made sure that the hare actually gets its advantage of
5749 if (tortoise_delay == 0)
5752 tortoise = tortoise->trace;
5753 ASSERT_SYNTAX (!scm_is_eq (hare->obj, tortoise->obj),
5754 s_bad_expression, hare->obj);
5761 if (scm_is_simple_vector (hare->obj))
5763 size_t length = SCM_SIMPLE_VECTOR_LENGTH (hare->obj);
5764 SCM new_vector = scm_c_make_vector (length, SCM_UNSPECIFIED);
5766 /* Each vector element is copied by recursing into copy_tree, having
5767 * the tortoise follow the hare into the depths of the stack. */
5768 unsigned long int i;
5769 for (i = 0; i < length; ++i)
5772 new_hare.obj = SCM_SIMPLE_VECTOR_REF (hare->obj, i);
5773 new_element = copy_tree (&new_hare, tortoise, tortoise_delay);
5774 SCM_SIMPLE_VECTOR_SET (new_vector, i, new_element);
5779 else /* scm_is_pair (hare->obj) */
5784 SCM rabbit = hare->obj;
5785 SCM turtle = hare->obj;
5789 /* The first pair of the list is treated specially, in order to
5790 * preserve a potential source code position. */
5791 result = tail = scm_cons_source (rabbit, SCM_EOL, SCM_EOL);
5792 new_hare.obj = SCM_CAR (rabbit);
5793 copy = copy_tree (&new_hare, tortoise, tortoise_delay);
5794 SCM_SETCAR (tail, copy);
5796 /* The remaining pairs of the list are copied by, horizontally,
5797 * having the turtle follow the rabbit, and, vertically, having the
5798 * tortoise follow the hare into the depths of the stack. */
5799 rabbit = SCM_CDR (rabbit);
5800 while (scm_is_pair (rabbit))
5802 new_hare.obj = SCM_CAR (rabbit);
5803 copy = copy_tree (&new_hare, tortoise, tortoise_delay);
5804 SCM_SETCDR (tail, scm_cons (copy, SCM_UNDEFINED));
5805 tail = SCM_CDR (tail);
5807 rabbit = SCM_CDR (rabbit);
5808 if (scm_is_pair (rabbit))
5810 new_hare.obj = SCM_CAR (rabbit);
5811 copy = copy_tree (&new_hare, tortoise, tortoise_delay);
5812 SCM_SETCDR (tail, scm_cons (copy, SCM_UNDEFINED));
5813 tail = SCM_CDR (tail);
5814 rabbit = SCM_CDR (rabbit);
5816 turtle = SCM_CDR (turtle);
5817 ASSERT_SYNTAX (!scm_is_eq (rabbit, turtle),
5818 s_bad_expression, rabbit);
5822 /* We have to recurse into copy_tree again for the last cdr, in
5823 * order to handle the situation that it holds a vector. */
5824 new_hare.obj = rabbit;
5825 copy = copy_tree (&new_hare, tortoise, tortoise_delay);
5826 SCM_SETCDR (tail, copy);
5833 SCM_DEFINE (scm_copy_tree, "copy-tree", 1, 0, 0,
5835 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
5836 "the new data structure. @code{copy-tree} recurses down the\n"
5837 "contents of both pairs and vectors (since both cons cells and vector\n"
5838 "cells may point to arbitrary objects), and stops recursing when it hits\n"
5839 "any other object.")
5840 #define FUNC_NAME s_scm_copy_tree
5842 /* Prepare the trace along the stack. */
5843 struct t_trace trace;
5846 /* In function copy_tree, if the tortoise makes its step, it will do this
5847 * before the hare has the chance to move. Thus, we have to make sure that
5848 * the very first step of the tortoise will not happen after the hare has
5849 * really made two steps. This is achieved by passing '2' as the initial
5850 * delay for the tortoise. NOTE: Since cycles are unlikely, giving the hare
5851 * a bigger advantage may improve performance slightly. */
5852 return copy_tree (&trace, &trace, 2);
5857 /* We have three levels of EVAL here:
5859 - scm_i_eval (exp, env)
5861 evaluates EXP in environment ENV. ENV is a lexical environment
5862 structure as used by the actual tree code evaluator. When ENV is
5863 a top-level environment, then changes to the current module are
5864 tracked by updating ENV so that it continues to be in sync with
5867 - scm_primitive_eval (exp)
5869 evaluates EXP in the top-level environment as determined by the
5870 current module. This is done by constructing a suitable
5871 environment and calling scm_i_eval. Thus, changes to the
5872 top-level module are tracked normally.
5874 - scm_eval (exp, mod_or_state)
5876 evaluates EXP while MOD_OR_STATE is the current module or current
5877 dynamic state (as appropriate). This is done by setting the
5878 current module (or dynamic state) to MOD_OR_STATE, invoking
5879 scm_primitive_eval on EXP, and then restoring the current module
5880 (or dynamic state) to the value it had previously. That is,
5881 while EXP is evaluated, changes to the current module (or dynamic
5882 state) are tracked, but these changes do not persist when
5885 For each level of evals, there are two variants, distinguished by a
5886 _x suffix: the ordinary variant does not modify EXP while the _x
5887 variant can destructively modify EXP into something completely
5888 unintelligible. A Scheme data structure passed as EXP to one of the
5889 _x variants should not ever be used again for anything. So when in
5890 doubt, use the ordinary variant.
5895 scm_i_eval_x (SCM exp, SCM env)
5897 if (scm_is_symbol (exp))
5898 return *scm_lookupcar (scm_cons (exp, SCM_UNDEFINED), env, 1);
5900 return SCM_I_XEVAL (exp, env);
5904 scm_i_eval (SCM exp, SCM env)
5906 exp = scm_copy_tree (exp);
5907 if (scm_is_symbol (exp))
5908 return *scm_lookupcar (scm_cons (exp, SCM_UNDEFINED), env, 1);
5910 return SCM_I_XEVAL (exp, env);
5914 scm_primitive_eval_x (SCM exp)
5917 SCM transformer = scm_current_module_transformer ();
5918 if (SCM_NIMP (transformer))
5919 exp = scm_call_1 (transformer, exp);
5920 env = scm_top_level_env (scm_current_module_lookup_closure ());
5921 return scm_i_eval_x (exp, env);
5924 SCM_DEFINE (scm_primitive_eval, "primitive-eval", 1, 0, 0,
5926 "Evaluate @var{exp} in the top-level environment specified by\n"
5927 "the current module.")
5928 #define FUNC_NAME s_scm_primitive_eval
5931 SCM transformer = scm_current_module_transformer ();
5932 if (scm_is_true (transformer))
5933 exp = scm_call_1 (transformer, exp);
5934 env = scm_top_level_env (scm_current_module_lookup_closure ());
5935 return scm_i_eval (exp, env);
5940 /* Eval does not take the second arg optionally. This is intentional
5941 * in order to be R5RS compatible, and to prepare for the new module
5942 * system, where we would like to make the choice of evaluation
5943 * environment explicit. */
5946 scm_eval_x (SCM exp, SCM module_or_state)
5950 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
5951 if (scm_is_dynamic_state (module_or_state))
5952 scm_dynwind_current_dynamic_state (module_or_state);
5954 scm_dynwind_current_module (module_or_state);
5956 res = scm_primitive_eval_x (exp);
5962 SCM_DEFINE (scm_eval, "eval", 2, 0, 0,
5963 (SCM exp, SCM module_or_state),
5964 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
5965 "in the top-level environment specified by\n"
5966 "@var{module_or_state}.\n"
5967 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
5968 "@var{module_or_state} is made the current module when\n"
5969 "it is a module, or the current dynamic state when it is\n"
5971 "Example: (eval '(+ 1 2) (interaction-environment))")
5972 #define FUNC_NAME s_scm_eval
5976 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
5977 if (scm_is_dynamic_state (module_or_state))
5978 scm_dynwind_current_dynamic_state (module_or_state);
5981 SCM_VALIDATE_MODULE (2, module_or_state);
5982 scm_dynwind_current_module (module_or_state);
5985 res = scm_primitive_eval (exp);
5993 /* At this point, deval and scm_dapply are generated.
6000 #if (SCM_ENABLE_DEPRECATED == 1)
6002 /* Deprecated in guile 1.7.0 on 2004-03-29. */
6003 SCM scm_ceval (SCM x, SCM env)
6005 if (scm_is_pair (x))
6006 return ceval (x, env);
6007 else if (scm_is_symbol (x))
6008 return *scm_lookupcar (scm_cons (x, SCM_UNDEFINED), env, 1);
6010 return SCM_I_XEVAL (x, env);
6013 /* Deprecated in guile 1.7.0 on 2004-03-29. */
6014 SCM scm_deval (SCM x, SCM env)
6016 if (scm_is_pair (x))
6017 return deval (x, env);
6018 else if (scm_is_symbol (x))
6019 return *scm_lookupcar (scm_cons (x, SCM_UNDEFINED), env, 1);
6021 return SCM_I_XEVAL (x, env);
6025 dispatching_eval (SCM x, SCM env)
6027 if (scm_debug_mode_p)
6028 return scm_deval (x, env);
6030 return scm_ceval (x, env);
6033 /* Deprecated in guile 1.7.0 on 2004-03-29. */
6034 SCM (*scm_ceval_ptr) (SCM x, SCM env) = dispatching_eval;
6042 scm_i_pthread_mutex_init (&source_mutex,
6043 scm_i_pthread_mutexattr_recursive);
6045 scm_init_opts (scm_evaluator_traps,
6046 scm_evaluator_trap_table,
6047 SCM_N_EVALUATOR_TRAPS);
6048 scm_init_opts (scm_eval_options_interface,
6050 SCM_N_EVAL_OPTIONS);
6052 scm_tc16_promise = scm_make_smob_type ("promise", 0);
6053 scm_set_smob_mark (scm_tc16_promise, promise_mark);
6054 scm_set_smob_free (scm_tc16_promise, promise_free);
6055 scm_set_smob_print (scm_tc16_promise, promise_print);
6057 undefineds = scm_list_1 (SCM_UNDEFINED);
6058 SCM_SETCDR (undefineds, undefineds);
6059 scm_permanent_object (undefineds);
6061 scm_listofnull = scm_list_1 (SCM_EOL);
6063 f_apply = scm_c_define_subr ("apply", scm_tc7_lsubr_2, scm_apply);
6064 scm_permanent_object (f_apply);
6066 #include "libguile/eval.x"
6068 scm_add_feature ("delay");