1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009
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 License
6 * as published by the Free Software Foundation; either version 3 of
7 * the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful, but
10 * 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
22 /* SECTION: This code is compiled once.
31 #include "libguile/__scm.h"
34 #include "libguile/_scm.h"
35 #include "libguile/alist.h"
36 #include "libguile/async.h"
37 #include "libguile/continuations.h"
38 #include "libguile/debug.h"
39 #include "libguile/deprecation.h"
40 #include "libguile/dynwind.h"
41 #include "libguile/eq.h"
42 #include "libguile/feature.h"
43 #include "libguile/fluids.h"
44 #include "libguile/futures.h"
45 #include "libguile/goops.h"
46 #include "libguile/hash.h"
47 #include "libguile/hashtab.h"
48 #include "libguile/lang.h"
49 #include "libguile/list.h"
50 #include "libguile/macros.h"
51 #include "libguile/modules.h"
52 #include "libguile/objects.h"
53 #include "libguile/ports.h"
54 #include "libguile/print.h"
55 #include "libguile/procprop.h"
56 #include "libguile/programs.h"
57 #include "libguile/root.h"
58 #include "libguile/smob.h"
59 #include "libguile/srcprop.h"
60 #include "libguile/stackchk.h"
61 #include "libguile/strings.h"
62 #include "libguile/threads.h"
63 #include "libguile/throw.h"
64 #include "libguile/validate.h"
65 #include "libguile/values.h"
66 #include "libguile/vectors.h"
67 #include "libguile/vm.h"
69 #include "libguile/eval.h"
70 #include "libguile/private-options.h"
75 static SCM
unmemoize_exprs (SCM expr
, SCM env
);
76 static SCM
canonicalize_define (SCM expr
);
77 static SCM
*scm_lookupcar1 (SCM vloc
, SCM genv
, int check
);
78 static SCM
unmemoize_builtin_macro (SCM expr
, SCM env
);
79 static void ceval_letrec_inits (SCM env
, SCM init_forms
, SCM
**init_values_eol
);
80 static SCM
ceval (SCM x
, SCM env
);
81 static SCM
deval (SCM x
, SCM env
);
87 * This section defines the message strings for the syntax errors that can be
88 * detected during memoization and the functions and macros that shall be
89 * called by the memoizer code to signal syntax errors. */
92 /* Syntax errors that can be detected during memoization: */
94 /* Circular or improper lists do not form valid scheme expressions. If a
95 * circular list or an improper list is detected in a place where a scheme
96 * expression is expected, a 'Bad expression' error is signalled. */
97 static const char s_bad_expression
[] = "Bad expression";
99 /* If a form is detected that holds a different number of expressions than are
100 * required in that context, a 'Missing or extra expression' error is
102 static const char s_expression
[] = "Missing or extra expression in";
104 /* If a form is detected that holds less expressions than are required in that
105 * context, a 'Missing expression' error is signalled. */
106 static const char s_missing_expression
[] = "Missing expression in";
108 /* If a form is detected that holds more expressions than are allowed in that
109 * context, an 'Extra expression' error is signalled. */
110 static const char s_extra_expression
[] = "Extra expression in";
112 /* The empty combination '()' is not allowed as an expression in scheme. If
113 * it is detected in a place where an expression is expected, an 'Illegal
114 * empty combination' error is signalled. Note: If you encounter this error
115 * message, it is very likely that you intended to denote the empty list. To
116 * do so, you need to quote the empty list like (quote ()) or '(). */
117 static const char s_empty_combination
[] = "Illegal empty combination";
119 /* A body may hold an arbitrary number of internal defines, followed by a
120 * non-empty sequence of expressions. If a body with an empty sequence of
121 * expressions is detected, a 'Missing body expression' error is signalled.
123 static const char s_missing_body_expression
[] = "Missing body expression in";
125 /* A body may hold an arbitrary number of internal defines, followed by a
126 * non-empty sequence of expressions. Each the definitions and the
127 * expressions may be grouped arbitraryly with begin, but it is not allowed to
128 * mix definitions and expressions. If a define form in a body mixes
129 * definitions and expressions, a 'Mixed definitions and expressions' error is
131 static const char s_mixed_body_forms
[] = "Mixed definitions and expressions in";
132 /* Definitions are only allowed on the top level and at the start of a body.
133 * If a definition is detected anywhere else, a 'Bad define placement' error
135 static const char s_bad_define
[] = "Bad define placement";
137 /* Case or cond expressions must have at least one clause. If a case or cond
138 * expression without any clauses is detected, a 'Missing clauses' error is
140 static const char s_missing_clauses
[] = "Missing clauses";
142 /* If there is an 'else' clause in a case or a cond statement, it must be the
143 * last clause. If after the 'else' case clause further clauses are detected,
144 * a 'Misplaced else clause' error is signalled. */
145 static const char s_misplaced_else_clause
[] = "Misplaced else clause";
147 /* If a case clause is detected that is not in the format
148 * (<label(s)> <expression1> <expression2> ...)
149 * a 'Bad case clause' error is signalled. */
150 static const char s_bad_case_clause
[] = "Bad case clause";
152 /* If a case clause is detected where the <label(s)> element is neither a
153 * proper list nor (in case of the last clause) the syntactic keyword 'else',
154 * a 'Bad case labels' error is signalled. Note: If you encounter this error
155 * for an else-clause which seems to be syntactically correct, check if 'else'
156 * is really a syntactic keyword in that context. If 'else' is bound in the
157 * local or global environment, it is not considered a syntactic keyword, but
158 * will be treated as any other variable. */
159 static const char s_bad_case_labels
[] = "Bad case labels";
161 /* In a case statement all labels have to be distinct. If in a case statement
162 * a label occurs more than once, a 'Duplicate case label' error is
164 static const char s_duplicate_case_label
[] = "Duplicate case label";
166 /* If a cond clause is detected that is not in one of the formats
167 * (<test> <expression1> ...) or (else <expression1> <expression2> ...)
168 * a 'Bad cond clause' error is signalled. */
169 static const char s_bad_cond_clause
[] = "Bad cond clause";
171 /* If a cond clause is detected that uses the alternate '=>' form, but does
172 * not hold a recipient element for the test result, a 'Missing recipient'
173 * error is signalled. */
174 static const char s_missing_recipient
[] = "Missing recipient in";
176 /* If in a position where a variable name is required some other object is
177 * detected, a 'Bad variable' error is signalled. */
178 static const char s_bad_variable
[] = "Bad variable";
180 /* Bindings for forms like 'let' and 'do' have to be given in a proper,
181 * possibly empty list. If any other object is detected in a place where a
182 * list of bindings was required, a 'Bad bindings' error is signalled. */
183 static const char s_bad_bindings
[] = "Bad bindings";
185 /* Depending on the syntactic context, a binding has to be in the format
186 * (<variable> <expression>) or (<variable> <expression1> <expression2>).
187 * If anything else is detected in a place where a binding was expected, a
188 * 'Bad binding' error is signalled. */
189 static const char s_bad_binding
[] = "Bad binding";
191 /* Some syntactic forms don't allow variable names to appear more than once in
192 * a list of bindings. If such a situation is nevertheless detected, a
193 * 'Duplicate binding' error is signalled. */
194 static const char s_duplicate_binding
[] = "Duplicate binding";
196 /* If the exit form of a 'do' expression is not in the format
197 * (<test> <expression> ...)
198 * a 'Bad exit clause' error is signalled. */
199 static const char s_bad_exit_clause
[] = "Bad exit clause";
201 /* The formal function arguments of a lambda expression have to be either a
202 * single symbol or a non-cyclic list. For anything else a 'Bad formals'
203 * error is signalled. */
204 static const char s_bad_formals
[] = "Bad formals";
206 /* If in a lambda expression something else than a symbol is detected at a
207 * place where a formal function argument is required, a 'Bad formal' error is
209 static const char s_bad_formal
[] = "Bad formal";
211 /* If in the arguments list of a lambda expression an argument name occurs
212 * more than once, a 'Duplicate formal' error is signalled. */
213 static const char s_duplicate_formal
[] = "Duplicate formal";
215 /* If the evaluation of an unquote-splicing expression gives something else
216 * than a proper list, a 'Non-list result for unquote-splicing' error is
218 static const char s_splicing
[] = "Non-list result for unquote-splicing";
220 /* If something else than an exact integer is detected as the argument for
221 * @slot-ref and @slot-set!, a 'Bad slot number' error is signalled. */
222 static const char s_bad_slot_number
[] = "Bad slot number";
225 /* Signal a syntax error. We distinguish between the form that caused the
226 * error and the enclosing expression. The error message will print out as
227 * shown in the following pattern. The file name and line number are only
228 * given when they can be determined from the erroneous form or from the
229 * enclosing expression.
231 * <filename>: In procedure memoization:
232 * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
234 SCM_SYMBOL (syntax_error_key
, "syntax-error");
236 /* The prototype is needed to indicate that the function does not return. */
238 syntax_error (const char* const, const SCM
, const SCM
) SCM_NORETURN
;
241 syntax_error (const char* const msg
, const SCM form
, const SCM expr
)
243 SCM msg_string
= scm_from_locale_string (msg
);
244 SCM filename
= SCM_BOOL_F
;
245 SCM linenr
= SCM_BOOL_F
;
249 if (scm_is_pair (form
))
251 filename
= scm_source_property (form
, scm_sym_filename
);
252 linenr
= scm_source_property (form
, scm_sym_line
);
255 if (scm_is_false (filename
) && scm_is_false (linenr
) && scm_is_pair (expr
))
257 filename
= scm_source_property (expr
, scm_sym_filename
);
258 linenr
= scm_source_property (expr
, scm_sym_line
);
261 if (!SCM_UNBNDP (expr
))
263 if (scm_is_true (filename
))
265 format
= "In file ~S, line ~S: ~A ~S in expression ~S.";
266 args
= scm_list_5 (filename
, linenr
, msg_string
, form
, expr
);
268 else if (scm_is_true (linenr
))
270 format
= "In line ~S: ~A ~S in expression ~S.";
271 args
= scm_list_4 (linenr
, msg_string
, form
, expr
);
275 format
= "~A ~S in expression ~S.";
276 args
= scm_list_3 (msg_string
, form
, expr
);
281 if (scm_is_true (filename
))
283 format
= "In file ~S, line ~S: ~A ~S.";
284 args
= scm_list_4 (filename
, linenr
, msg_string
, form
);
286 else if (scm_is_true (linenr
))
288 format
= "In line ~S: ~A ~S.";
289 args
= scm_list_3 (linenr
, msg_string
, form
);
294 args
= scm_list_2 (msg_string
, form
);
298 scm_error (syntax_error_key
, "memoization", format
, args
, SCM_BOOL_F
);
302 /* Shortcut macros to simplify syntax error handling. */
303 #define ASSERT_SYNTAX(cond, message, form) \
304 { if (SCM_UNLIKELY (!(cond))) \
305 syntax_error (message, form, SCM_UNDEFINED); }
306 #define ASSERT_SYNTAX_2(cond, message, form, expr) \
307 { if (SCM_UNLIKELY (!(cond))) \
308 syntax_error (message, form, expr); }
310 static void error_unbound_variable (SCM symbol
) SCM_NORETURN
;
311 static void error_defined_variable (SCM symbol
) SCM_NORETURN
;
317 * Ilocs are memoized references to variables in local environment frames.
318 * They are represented as three values: The relative offset of the
319 * environment frame, the number of the binding within that frame, and a
320 * boolean value indicating whether the binding is the last binding in the
323 * Frame numbers have 11 bits, relative offsets have 12 bits.
326 #define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc)
327 #define SCM_IFRINC (0x00000100L)
328 #define SCM_ICDR (0x00080000L)
329 #define SCM_IDINC (0x00100000L)
330 #define SCM_IFRAME(n) ((long)((SCM_ICDR-SCM_IFRINC)>>8) \
331 & (SCM_UNPACK (n) >> 8))
332 #define SCM_IDIST(n) (SCM_UNPACK (n) >> 20)
333 #define SCM_ICDRP(n) (SCM_ICDR & SCM_UNPACK (n))
334 #define SCM_IDSTMSK (-SCM_IDINC)
335 #define SCM_IFRAMEMAX ((1<<11)-1)
336 #define SCM_IDISTMAX ((1<<12)-1)
337 #define SCM_MAKE_ILOC(frame_nr, binding_nr, last_p) \
340 + ((binding_nr) << 20) \
341 + ((last_p) ? SCM_ICDR : 0) \
345 scm_i_print_iloc (SCM iloc
, SCM port
)
347 scm_puts ("#@", port
);
348 scm_intprint ((long) SCM_IFRAME (iloc
), 10, port
);
349 scm_putc (SCM_ICDRP (iloc
) ? '-' : '+', port
);
350 scm_intprint ((long) SCM_IDIST (iloc
), 10, port
);
353 #if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
355 SCM
scm_dbg_make_iloc (SCM frame
, SCM binding
, SCM cdrp
);
357 SCM_DEFINE (scm_dbg_make_iloc
, "dbg-make-iloc", 3, 0, 0,
358 (SCM frame
, SCM binding
, SCM cdrp
),
359 "Return a new iloc with frame offset @var{frame}, binding\n"
360 "offset @var{binding} and the cdr flag @var{cdrp}.")
361 #define FUNC_NAME s_scm_dbg_make_iloc
363 return SCM_MAKE_ILOC ((scm_t_bits
) scm_to_unsigned_integer (frame
, 0, SCM_IFRAMEMAX
),
364 (scm_t_bits
) scm_to_unsigned_integer (binding
, 0, SCM_IDISTMAX
),
369 SCM
scm_dbg_iloc_p (SCM obj
);
371 SCM_DEFINE (scm_dbg_iloc_p
, "dbg-iloc?", 1, 0, 0,
373 "Return @code{#t} if @var{obj} is an iloc.")
374 #define FUNC_NAME s_scm_dbg_iloc_p
376 return scm_from_bool (SCM_ILOCP (obj
));
384 /* {Evaluator byte codes (isyms)}
387 #define ISYMNUM(n) (SCM_ITAG8_DATA (n))
389 /* This table must agree with the list of SCM_IM_ constants in tags.h */
390 static const char *const isymnames
[] =
407 "#@call-with-current-continuation",
413 "#@call-with-values",
421 scm_i_print_isym (SCM isym
, SCM port
)
423 const size_t isymnum
= ISYMNUM (isym
);
424 if (isymnum
< (sizeof isymnames
/ sizeof (char *)))
425 scm_puts (isymnames
[isymnum
], port
);
427 scm_ipruk ("isym", isym
, port
);
432 /* The function lookup_symbol is used during memoization: Lookup the symbol in
433 * the environment. If there is no binding for the symbol, SCM_UNDEFINED is
434 * returned. If the symbol is a global variable, the variable object to which
435 * the symbol is bound is returned. Finally, if the symbol is a local
436 * variable the corresponding iloc object is returned. */
438 /* A helper function for lookup_symbol: Try to find the symbol in the top
439 * level environment frame. The function returns SCM_UNDEFINED if the symbol
440 * is unbound and it returns a variable object if the symbol is a global
443 lookup_global_symbol (const SCM symbol
, const SCM top_level
)
445 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
446 if (scm_is_false (variable
))
447 return SCM_UNDEFINED
;
453 lookup_symbol (const SCM symbol
, const SCM env
)
456 unsigned int frame_nr
;
458 for (frame_idx
= env
, frame_nr
= 0;
459 !scm_is_null (frame_idx
);
460 frame_idx
= SCM_CDR (frame_idx
), ++frame_nr
)
462 const SCM frame
= SCM_CAR (frame_idx
);
463 if (scm_is_pair (frame
))
465 /* frame holds a local environment frame */
467 unsigned int symbol_nr
;
469 for (symbol_idx
= SCM_CAR (frame
), symbol_nr
= 0;
470 scm_is_pair (symbol_idx
);
471 symbol_idx
= SCM_CDR (symbol_idx
), ++symbol_nr
)
473 if (scm_is_eq (SCM_CAR (symbol_idx
), symbol
))
474 /* found the symbol, therefore return the iloc */
475 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 0);
477 if (scm_is_eq (symbol_idx
, symbol
))
478 /* found the symbol as the last element of the current frame */
479 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 1);
483 /* no more local environment frames */
484 return lookup_global_symbol (symbol
, frame
);
488 return lookup_global_symbol (symbol
, SCM_BOOL_F
);
492 /* Return true if the symbol is - from the point of view of a macro
493 * transformer - a literal in the sense specified in chapter "pattern
494 * language" of R5RS. In the code below, however, we don't match the
495 * definition of R5RS exactly: It returns true if the identifier has no
496 * binding or if it is a syntactic keyword. */
498 literal_p (const SCM symbol
, const SCM env
)
500 const SCM variable
= lookup_symbol (symbol
, env
);
501 if (SCM_UNBNDP (variable
))
503 if (SCM_VARIABLEP (variable
) && SCM_MACROP (SCM_VARIABLE_REF (variable
)))
510 /* Return true if the expression is self-quoting in the memoized code. Thus,
511 * some other objects (like e. g. vectors) are reported as self-quoting, which
512 * according to R5RS would need to be quoted. */
514 is_self_quoting_p (const SCM expr
)
516 if (scm_is_pair (expr
))
518 else if (scm_is_symbol (expr
))
520 else if (scm_is_null (expr
))
526 SCM_SYMBOL (sym_three_question_marks
, "???");
529 unmemoize_expression (const SCM expr
, const SCM env
)
531 if (SCM_ILOCP (expr
))
534 unsigned long int frame_nr
;
536 unsigned long int symbol_nr
;
538 for (frame_idx
= env
, frame_nr
= SCM_IFRAME (expr
);
540 frame_idx
= SCM_CDR (frame_idx
), --frame_nr
)
542 for (symbol_idx
= SCM_CAAR (frame_idx
), symbol_nr
= SCM_IDIST (expr
);
544 symbol_idx
= SCM_CDR (symbol_idx
), --symbol_nr
)
546 return SCM_ICDRP (expr
) ? symbol_idx
: SCM_CAR (symbol_idx
);
548 else if (SCM_VARIABLEP (expr
))
550 const SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), expr
);
551 return scm_is_true (sym
) ? sym
: sym_three_question_marks
;
553 else if (scm_is_simple_vector (expr
))
555 return scm_list_2 (scm_sym_quote
, expr
);
557 else if (!scm_is_pair (expr
))
561 else if (SCM_ISYMP (SCM_CAR (expr
)))
563 return unmemoize_builtin_macro (expr
, env
);
567 return unmemoize_exprs (expr
, env
);
573 unmemoize_exprs (const SCM exprs
, const SCM env
)
575 SCM r_result
= SCM_EOL
;
576 SCM expr_idx
= exprs
;
579 /* Note that due to the current lazy memoizer we may find partially memoized
580 * code during execution. In such code we have to expect improper lists of
581 * expressions: On the one hand, for such code syntax checks have not yet
582 * fully been performed, on the other hand, there may be even legal code
583 * like '(a . b) appear as an improper list of expressions as long as the
584 * quote expression is still in its unmemoized form. For this reason, the
585 * following code handles improper lists of expressions until memoization
586 * and execution have been completely separated. */
587 for (; scm_is_pair (expr_idx
); expr_idx
= SCM_CDR (expr_idx
))
589 const SCM expr
= SCM_CAR (expr_idx
);
591 /* In partially memoized code, lists of expressions that stem from a
592 * body form may start with an ISYM if the body itself has not yet been
593 * memoized. This isym is just an internal marker to indicate that the
594 * body still needs to be memoized. An isym may occur at the very
595 * beginning of the body or after one or more comment strings. It is
596 * dropped during unmemoization. */
597 if (!SCM_ISYMP (expr
))
599 um_expr
= unmemoize_expression (expr
, env
);
600 r_result
= scm_cons (um_expr
, r_result
);
603 um_expr
= unmemoize_expression (expr_idx
, env
);
604 if (!scm_is_null (r_result
))
606 const SCM result
= scm_reverse_x (r_result
, SCM_UNDEFINED
);
607 SCM_SETCDR (r_result
, um_expr
);
617 /* Rewrite the body (which is given as the list of expressions forming the
618 * body) into its internal form. The internal form of a body (<expr> ...) is
619 * just the body itself, but prefixed with an ISYM that denotes to what kind
620 * of outer construct this body belongs: (<ISYM> <expr> ...). A lambda body
621 * starts with SCM_IM_LAMBDA, for example, a body of a let starts with
624 * It is assumed that the calling expression has already made sure that the
625 * body is a proper list. */
627 m_body (SCM op
, SCM exprs
)
629 /* Don't add another ISYM if one is present already. */
630 if (SCM_ISYMP (SCM_CAR (exprs
)))
633 return scm_cons (op
, exprs
);
637 /* The function m_expand_body memoizes a proper list of expressions forming a
638 * body. This function takes care of dealing with internal defines and
639 * transforming them into an equivalent letrec expression. The list of
640 * expressions is rewritten in place. */
642 /* This is a helper function for m_expand_body. If the argument expression is
643 * a symbol that denotes a syntactic keyword, the corresponding macro object
644 * is returned, in all other cases the function returns SCM_UNDEFINED. */
646 try_macro_lookup (const SCM expr
, const SCM env
)
648 if (scm_is_symbol (expr
))
650 const SCM variable
= lookup_symbol (expr
, env
);
651 if (SCM_VARIABLEP (variable
))
653 const SCM value
= SCM_VARIABLE_REF (variable
);
654 if (SCM_MACROP (value
))
659 return SCM_UNDEFINED
;
662 /* This is a helper function for m_expand_body. It expands user macros,
663 * because for the correct translation of a body we need to know whether they
664 * expand to a definition. */
666 expand_user_macros (SCM expr
, const SCM env
)
668 while (scm_is_pair (expr
))
670 const SCM car_expr
= SCM_CAR (expr
);
671 const SCM new_car
= expand_user_macros (car_expr
, env
);
672 const SCM value
= try_macro_lookup (new_car
, env
);
674 if (SCM_MACROP (value
) && SCM_MACRO_TYPE (value
) == 2)
676 /* User macros transform code into code. */
677 expr
= scm_call_2 (SCM_MACRO_CODE (value
), expr
, env
);
678 /* We need to reiterate on the transformed code. */
682 /* No user macro: return. */
683 SCM_SETCAR (expr
, new_car
);
691 /* This is a helper function for m_expand_body. It determines if a given form
692 * represents an application of a given built-in macro. The built-in macro to
693 * check for is identified by its syntactic keyword. The form is an
694 * application of the given macro if looking up the car of the form in the
695 * given environment actually returns the built-in macro. */
697 is_system_macro_p (const SCM syntactic_keyword
, const SCM form
, const SCM env
)
699 if (scm_is_pair (form
))
701 const SCM car_form
= SCM_CAR (form
);
702 const SCM value
= try_macro_lookup (car_form
, env
);
703 if (SCM_BUILTIN_MACRO_P (value
))
705 const SCM macro_name
= scm_macro_name (value
);
706 return scm_is_eq (macro_name
, syntactic_keyword
);
714 macroexp (SCM x
, SCM env
)
716 SCM res
, proc
, orig_sym
;
718 /* Don't bother to produce error messages here. We get them when we
719 eventually execute the code for real. */
722 orig_sym
= SCM_CAR (x
);
723 if (!scm_is_symbol (orig_sym
))
727 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
728 if (proc_ptr
== NULL
)
730 /* We have lost the race. */
736 /* Only handle memoizing macros. `Acros' and `macros' are really
737 special forms and should not be evaluated here. */
739 if (!SCM_MACROP (proc
)
740 || (SCM_MACRO_TYPE (proc
) != 2 && !SCM_BUILTIN_MACRO_P (proc
)))
743 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
744 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
746 if (scm_ilength (res
) <= 0)
747 /* Result of expansion is not a list. */
748 return (scm_list_2 (SCM_IM_BEGIN
, res
));
751 /* njrev: Several queries here: (1) I don't see how it can be
752 correct that the SCM_SETCAR 2 lines below this comment needs
753 protection, but the SCM_SETCAR 6 lines above does not, so
754 something here is probably wrong. (2) macroexp() is now only
755 used in one place - scm_m_generalized_set_x - whereas all other
756 macro expansion happens through expand_user_macros. Therefore
757 (2.1) perhaps macroexp() could be eliminated completely now?
758 (2.2) Does expand_user_macros need any critical section
761 SCM_CRITICAL_SECTION_START
;
762 SCM_SETCAR (x
, SCM_CAR (res
));
763 SCM_SETCDR (x
, SCM_CDR (res
));
764 SCM_CRITICAL_SECTION_END
;
771 /* Start of the memoizers for the standard R5RS builtin macros. */
773 static SCM
scm_m_quote (SCM xorig
, SCM env
);
774 static SCM
scm_m_begin (SCM xorig
, SCM env
);
775 static SCM
scm_m_if (SCM xorig
, SCM env
);
776 static SCM
scm_m_set_x (SCM xorig
, SCM env
);
777 static SCM
scm_m_and (SCM xorig
, SCM env
);
778 static SCM
scm_m_or (SCM xorig
, SCM env
);
779 static SCM
scm_m_case (SCM xorig
, SCM env
);
780 static SCM
scm_m_cond (SCM xorig
, SCM env
);
781 static SCM
scm_m_lambda (SCM xorig
, SCM env
);
782 static SCM
scm_m_letstar (SCM xorig
, SCM env
);
783 static SCM
scm_m_do (SCM xorig
, SCM env
);
784 static SCM
scm_m_quasiquote (SCM xorig
, SCM env
);
785 static SCM
scm_m_delay (SCM xorig
, SCM env
);
786 static SCM
scm_m_generalized_set_x (SCM xorig
, SCM env
);
787 #if 0 /* Futures are disabled, see "futures.h". */
788 static SCM
scm_m_future (SCM xorig
, SCM env
);
790 static SCM
scm_m_define (SCM x
, SCM env
);
791 static SCM
scm_m_letrec (SCM xorig
, SCM env
);
792 static SCM
scm_m_let (SCM xorig
, SCM env
);
793 static SCM
scm_m_at (SCM xorig
, SCM env
);
794 static SCM
scm_m_atat (SCM xorig
, SCM env
);
795 static SCM
scm_m_atslot_ref (SCM xorig
, SCM env
);
796 static SCM
scm_m_atslot_set_x (SCM xorig
, SCM env
);
797 static SCM
scm_m_apply (SCM xorig
, SCM env
);
798 static SCM
scm_m_cont (SCM xorig
, SCM env
);
800 static SCM
scm_m_nil_cond (SCM xorig
, SCM env
);
801 static SCM
scm_m_atfop (SCM xorig
, SCM env
);
802 #endif /* SCM_ENABLE_ELISP */
803 static SCM
scm_m_atbind (SCM xorig
, SCM env
);
804 static SCM
scm_m_at_call_with_values (SCM xorig
, SCM env
);
805 static SCM
scm_m_eval_when (SCM xorig
, SCM env
);
809 m_expand_body (const SCM forms
, const SCM env
)
811 /* The first body form can be skipped since it is known to be the ISYM that
812 * was prepended to the body by m_body. */
813 SCM cdr_forms
= SCM_CDR (forms
);
814 SCM form_idx
= cdr_forms
;
815 SCM definitions
= SCM_EOL
;
816 SCM sequence
= SCM_EOL
;
818 /* According to R5RS, the list of body forms consists of two parts: a number
819 * (maybe zero) of definitions, followed by a non-empty sequence of
820 * expressions. Each the definitions and the expressions may be grouped
821 * arbitrarily with begin, but it is not allowed to mix definitions and
822 * expressions. The task of the following loop therefore is to split the
823 * list of body forms into the list of definitions and the sequence of
825 while (!scm_is_null (form_idx
))
827 const SCM form
= SCM_CAR (form_idx
);
828 const SCM new_form
= expand_user_macros (form
, env
);
829 if (is_system_macro_p (scm_sym_define
, new_form
, env
))
831 definitions
= scm_cons (new_form
, definitions
);
832 form_idx
= SCM_CDR (form_idx
);
834 else if (is_system_macro_p (scm_sym_begin
, new_form
, env
))
836 /* We have encountered a group of forms. This has to be either a
837 * (possibly empty) group of (possibly further grouped) definitions,
838 * or a non-empty group of (possibly further grouped)
840 const SCM grouped_forms
= SCM_CDR (new_form
);
841 unsigned int found_definition
= 0;
842 unsigned int found_expression
= 0;
843 SCM grouped_form_idx
= grouped_forms
;
844 while (!found_expression
&& !scm_is_null (grouped_form_idx
))
846 const SCM inner_form
= SCM_CAR (grouped_form_idx
);
847 const SCM new_inner_form
= expand_user_macros (inner_form
, env
);
848 if (is_system_macro_p (scm_sym_define
, new_inner_form
, env
))
850 found_definition
= 1;
851 definitions
= scm_cons (new_inner_form
, definitions
);
852 grouped_form_idx
= SCM_CDR (grouped_form_idx
);
854 else if (is_system_macro_p (scm_sym_begin
, new_inner_form
, env
))
856 const SCM inner_group
= SCM_CDR (new_inner_form
);
858 = scm_append (scm_list_2 (inner_group
,
859 SCM_CDR (grouped_form_idx
)));
863 /* The group marks the start of the expressions of the body.
864 * We have to make sure that within the same group we have
865 * not encountered a definition before. */
866 ASSERT_SYNTAX (!found_definition
, s_mixed_body_forms
, form
);
867 found_expression
= 1;
868 grouped_form_idx
= SCM_EOL
;
872 /* We have finished processing the group. If we have not yet
873 * encountered an expression we continue processing the forms of the
874 * body to collect further definition forms. Otherwise, the group
875 * marks the start of the sequence of expressions of the body. */
876 if (!found_expression
)
878 form_idx
= SCM_CDR (form_idx
);
888 /* We have detected a form which is no definition. This marks the
889 * start of the sequence of expressions of the body. */
895 /* FIXME: forms does not hold information about the file location. */
896 ASSERT_SYNTAX (scm_is_pair (sequence
), s_missing_body_expression
, cdr_forms
);
898 if (!scm_is_null (definitions
))
902 SCM letrec_expression
;
903 SCM new_letrec_expression
;
905 SCM bindings
= SCM_EOL
;
906 for (definition_idx
= definitions
;
907 !scm_is_null (definition_idx
);
908 definition_idx
= SCM_CDR (definition_idx
))
910 const SCM definition
= SCM_CAR (definition_idx
);
911 const SCM canonical_definition
= canonicalize_define (definition
);
912 const SCM binding
= SCM_CDR (canonical_definition
);
913 bindings
= scm_cons (binding
, bindings
);
916 letrec_tail
= scm_cons (bindings
, sequence
);
917 /* FIXME: forms does not hold information about the file location. */
918 letrec_expression
= scm_cons_source (forms
, scm_sym_letrec
, letrec_tail
);
919 new_letrec_expression
= scm_m_letrec (letrec_expression
, env
);
920 SCM_SETCAR (forms
, new_letrec_expression
);
921 SCM_SETCDR (forms
, SCM_EOL
);
925 SCM_SETCAR (forms
, SCM_CAR (sequence
));
926 SCM_SETCDR (forms
, SCM_CDR (sequence
));
930 SCM_SYNTAX (s_and
, "and", scm_i_makbimacro
, scm_m_and
);
931 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
934 scm_m_and (SCM expr
, SCM env SCM_UNUSED
)
936 const SCM cdr_expr
= SCM_CDR (expr
);
937 const long length
= scm_ilength (cdr_expr
);
939 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
943 /* Special case: (and) is replaced by #t. */
948 SCM_SETCAR (expr
, SCM_IM_AND
);
954 unmemoize_and (const SCM expr
, const SCM env
)
956 return scm_cons (scm_sym_and
, unmemoize_exprs (SCM_CDR (expr
), env
));
960 SCM_SYNTAX (s_begin
, "begin", scm_i_makbimacro
, scm_m_begin
);
961 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
964 scm_m_begin (SCM expr
, SCM env SCM_UNUSED
)
966 const SCM cdr_expr
= SCM_CDR (expr
);
967 /* Dirk:FIXME:: An empty begin clause is not generally allowed by R5RS.
968 * That means, there should be a distinction between uses of begin where an
969 * empty clause is OK and where it is not. */
970 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
972 SCM_SETCAR (expr
, SCM_IM_BEGIN
);
977 unmemoize_begin (const SCM expr
, const SCM env
)
979 return scm_cons (scm_sym_begin
, unmemoize_exprs (SCM_CDR (expr
), env
));
983 SCM_SYNTAX (s_case
, "case", scm_i_makbimacro
, scm_m_case
);
984 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
985 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
988 scm_m_case (SCM expr
, SCM env
)
991 SCM all_labels
= SCM_EOL
;
993 /* Check, whether 'else is a literal, i. e. not bound to a value. */
994 const int else_literal_p
= literal_p (scm_sym_else
, env
);
996 const SCM cdr_expr
= SCM_CDR (expr
);
997 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
998 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_clauses
, expr
);
1000 clauses
= SCM_CDR (cdr_expr
);
1001 while (!scm_is_null (clauses
))
1005 const SCM clause
= SCM_CAR (clauses
);
1006 ASSERT_SYNTAX_2 (scm_ilength (clause
) >= 2,
1007 s_bad_case_clause
, clause
, expr
);
1009 labels
= SCM_CAR (clause
);
1010 if (scm_is_pair (labels
))
1012 ASSERT_SYNTAX_2 (scm_ilength (labels
) >= 0,
1013 s_bad_case_labels
, labels
, expr
);
1014 all_labels
= scm_append (scm_list_2 (labels
, all_labels
));
1016 else if (scm_is_null (labels
))
1018 /* The list of labels is empty. According to R5RS this is allowed.
1019 * It means that the sequence of expressions will never be executed.
1020 * Therefore, as an optimization, we could remove the whole
1025 ASSERT_SYNTAX_2 (scm_is_eq (labels
, scm_sym_else
) && else_literal_p
,
1026 s_bad_case_labels
, labels
, expr
);
1027 ASSERT_SYNTAX_2 (scm_is_null (SCM_CDR (clauses
)),
1028 s_misplaced_else_clause
, clause
, expr
);
1031 /* build the new clause */
1032 if (scm_is_eq (labels
, scm_sym_else
))
1033 SCM_SETCAR (clause
, SCM_IM_ELSE
);
1035 clauses
= SCM_CDR (clauses
);
1038 /* Check whether all case labels are distinct. */
1039 for (; !scm_is_null (all_labels
); all_labels
= SCM_CDR (all_labels
))
1041 const SCM label
= SCM_CAR (all_labels
);
1042 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (label
, SCM_CDR (all_labels
))),
1043 s_duplicate_case_label
, label
, expr
);
1046 SCM_SETCAR (expr
, SCM_IM_CASE
);
1051 unmemoize_case (const SCM expr
, const SCM env
)
1053 const SCM um_key_expr
= unmemoize_expression (SCM_CADR (expr
), env
);
1054 SCM um_clauses
= SCM_EOL
;
1057 for (clause_idx
= SCM_CDDR (expr
);
1058 !scm_is_null (clause_idx
);
1059 clause_idx
= SCM_CDR (clause_idx
))
1061 const SCM clause
= SCM_CAR (clause_idx
);
1062 const SCM labels
= SCM_CAR (clause
);
1063 const SCM exprs
= SCM_CDR (clause
);
1065 const SCM um_exprs
= unmemoize_exprs (exprs
, env
);
1066 const SCM um_labels
= (scm_is_eq (labels
, SCM_IM_ELSE
))
1068 : scm_i_finite_list_copy (labels
);
1069 const SCM um_clause
= scm_cons (um_labels
, um_exprs
);
1071 um_clauses
= scm_cons (um_clause
, um_clauses
);
1073 um_clauses
= scm_reverse_x (um_clauses
, SCM_UNDEFINED
);
1075 return scm_cons2 (scm_sym_case
, um_key_expr
, um_clauses
);
1079 SCM_SYNTAX (s_cond
, "cond", scm_i_makbimacro
, scm_m_cond
);
1080 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
1081 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
1084 scm_m_cond (SCM expr
, SCM env
)
1086 /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
1087 const int else_literal_p
= literal_p (scm_sym_else
, env
);
1088 const int arrow_literal_p
= literal_p (scm_sym_arrow
, env
);
1090 const SCM clauses
= SCM_CDR (expr
);
1093 ASSERT_SYNTAX (scm_ilength (clauses
) >= 0, s_bad_expression
, expr
);
1094 ASSERT_SYNTAX (scm_ilength (clauses
) >= 1, s_missing_clauses
, expr
);
1096 for (clause_idx
= clauses
;
1097 !scm_is_null (clause_idx
);
1098 clause_idx
= SCM_CDR (clause_idx
))
1102 const SCM clause
= SCM_CAR (clause_idx
);
1103 const long length
= scm_ilength (clause
);
1104 ASSERT_SYNTAX_2 (length
>= 1, s_bad_cond_clause
, clause
, expr
);
1106 test
= SCM_CAR (clause
);
1107 if (scm_is_eq (test
, scm_sym_else
) && else_literal_p
)
1109 const int last_clause_p
= scm_is_null (SCM_CDR (clause_idx
));
1110 ASSERT_SYNTAX_2 (length
>= 2,
1111 s_bad_cond_clause
, clause
, expr
);
1112 ASSERT_SYNTAX_2 (last_clause_p
,
1113 s_misplaced_else_clause
, clause
, expr
);
1114 SCM_SETCAR (clause
, SCM_IM_ELSE
);
1116 else if (length
>= 2
1117 && scm_is_eq (SCM_CADR (clause
), scm_sym_arrow
)
1120 ASSERT_SYNTAX_2 (length
> 2, s_missing_recipient
, clause
, expr
);
1121 ASSERT_SYNTAX_2 (length
== 3, s_extra_expression
, clause
, expr
);
1122 SCM_SETCAR (SCM_CDR (clause
), SCM_IM_ARROW
);
1124 /* SRFI 61 extended cond */
1125 else if (length
>= 3
1126 && scm_is_eq (SCM_CADDR (clause
), scm_sym_arrow
)
1129 ASSERT_SYNTAX_2 (length
> 3, s_missing_recipient
, clause
, expr
);
1130 ASSERT_SYNTAX_2 (length
== 4, s_extra_expression
, clause
, expr
);
1131 SCM_SETCAR (SCM_CDDR (clause
), SCM_IM_ARROW
);
1135 SCM_SETCAR (expr
, SCM_IM_COND
);
1140 unmemoize_cond (const SCM expr
, const SCM env
)
1142 SCM um_clauses
= SCM_EOL
;
1145 for (clause_idx
= SCM_CDR (expr
);
1146 !scm_is_null (clause_idx
);
1147 clause_idx
= SCM_CDR (clause_idx
))
1149 const SCM clause
= SCM_CAR (clause_idx
);
1150 const SCM sequence
= SCM_CDR (clause
);
1151 const SCM test
= SCM_CAR (clause
);
1156 if (scm_is_eq (test
, SCM_IM_ELSE
))
1157 um_test
= scm_sym_else
;
1159 um_test
= unmemoize_expression (test
, env
);
1161 if (!scm_is_null (sequence
) && scm_is_eq (SCM_CAR (sequence
),
1164 const SCM target
= SCM_CADR (sequence
);
1165 const SCM um_target
= unmemoize_expression (target
, env
);
1166 um_sequence
= scm_list_2 (scm_sym_arrow
, um_target
);
1170 um_sequence
= unmemoize_exprs (sequence
, env
);
1173 um_clause
= scm_cons (um_test
, um_sequence
);
1174 um_clauses
= scm_cons (um_clause
, um_clauses
);
1176 um_clauses
= scm_reverse_x (um_clauses
, SCM_UNDEFINED
);
1178 return scm_cons (scm_sym_cond
, um_clauses
);
1182 SCM_SYNTAX (s_define
, "define", scm_i_makbimacro
, scm_m_define
);
1183 SCM_GLOBAL_SYMBOL (scm_sym_define
, s_define
);
1185 /* Guile provides an extension to R5RS' define syntax to represent function
1186 * currying in a compact way. With this extension, it is allowed to write
1187 * (define <nested-variable> <body>), where <nested-variable> has of one of
1188 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
1189 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
1190 * should be either a sequence of zero or more variables, or a sequence of one
1191 * or more variables followed by a space-delimited period and another
1192 * variable. Each level of argument nesting wraps the <body> within another
1193 * lambda expression. For example, the following forms are allowed, each one
1194 * followed by an equivalent, more explicit implementation.
1196 * (define ((a b . c) . d) <body>) is equivalent to
1197 * (define a (lambda (b . c) (lambda d <body>)))
1199 * (define (((a) b) c . d) <body>) is equivalent to
1200 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
1202 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
1203 * module that does not implement this extension. */
1205 canonicalize_define (const SCM expr
)
1210 const SCM cdr_expr
= SCM_CDR (expr
);
1211 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1212 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1214 body
= SCM_CDR (cdr_expr
);
1215 variable
= SCM_CAR (cdr_expr
);
1216 while (scm_is_pair (variable
))
1218 /* This while loop realizes function currying by variable nesting.
1219 * Variable is known to be a nested-variable. In every iteration of the
1220 * loop another level of lambda expression is created, starting with the
1221 * innermost one. Note that we don't check for duplicate formals here:
1222 * This will be done by the memoizer of the lambda expression. */
1223 const SCM formals
= SCM_CDR (variable
);
1224 const SCM tail
= scm_cons (formals
, body
);
1226 /* Add source properties to each new lambda expression: */
1227 const SCM lambda
= scm_cons_source (variable
, scm_sym_lambda
, tail
);
1229 body
= scm_list_1 (lambda
);
1230 variable
= SCM_CAR (variable
);
1232 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
1233 ASSERT_SYNTAX (scm_ilength (body
) == 1, s_expression
, expr
);
1235 SCM_SETCAR (cdr_expr
, variable
);
1236 SCM_SETCDR (cdr_expr
, body
);
1240 /* According to Section 5.2.1 of R5RS we first have to make sure that the
1241 variable is bound, and then perform the `(set! variable expression)'
1242 operation. However, EXPRESSION _can_ be evaluated before VARIABLE is
1243 bound. This means that EXPRESSION won't necessarily be able to assign
1244 values to VARIABLE as in `(define foo (begin (set! foo 1) (+ foo 1)))'. */
1246 scm_m_define (SCM expr
, SCM env
)
1248 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), s_bad_define
, expr
);
1251 const SCM canonical_definition
= canonicalize_define (expr
);
1252 const SCM cdr_canonical_definition
= SCM_CDR (canonical_definition
);
1253 const SCM variable
= SCM_CAR (cdr_canonical_definition
);
1254 const SCM value
= scm_eval_car (SCM_CDR (cdr_canonical_definition
), env
);
1256 = scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_T
);
1258 if (SCM_REC_PROCNAMES_P
)
1261 while (SCM_MACROP (tmp
))
1262 tmp
= SCM_MACRO_CODE (tmp
);
1263 if (scm_is_true (scm_procedure_p (tmp
))
1264 /* Only the first definition determines the name. */
1265 && scm_is_false (scm_procedure_property (tmp
, scm_sym_name
)))
1266 scm_set_procedure_property_x (tmp
, scm_sym_name
, variable
);
1269 SCM_VARIABLE_SET (location
, value
);
1271 return SCM_UNSPECIFIED
;
1276 /* This is a helper function for forms (<keyword> <expression>) that are
1277 * transformed into (#@<keyword> '() <memoized_expression>) in order to allow
1278 * for easy creation of a thunk (i. e. a closure without arguments) using the
1279 * ('() <memoized_expression>) tail of the memoized form. */
1281 memoize_as_thunk_prototype (const SCM expr
, const SCM env SCM_UNUSED
)
1283 const SCM cdr_expr
= SCM_CDR (expr
);
1284 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1285 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1287 SCM_SETCDR (expr
, scm_cons (SCM_EOL
, cdr_expr
));
1293 SCM_SYNTAX (s_delay
, "delay", scm_i_makbimacro
, scm_m_delay
);
1294 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
1296 /* Promises are implemented as closures with an empty parameter list. Thus,
1297 * (delay <expression>) is transformed into (#@delay '() <expression>), where
1298 * the empty list represents the empty parameter list. This representation
1299 * allows for easy creation of the closure during evaluation. */
1301 scm_m_delay (SCM expr
, SCM env
)
1303 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1304 SCM_SETCAR (new_expr
, SCM_IM_DELAY
);
1309 unmemoize_delay (const SCM expr
, const SCM env
)
1311 const SCM thunk_expr
= SCM_CADDR (expr
);
1312 /* A promise is implemented as a closure, and when applying a
1313 closure the evaluator adds a new frame to the environment - even
1314 though, in the case of a promise, the added frame is always
1315 empty. We need to extend the environment here in the same way,
1316 so that any ILOCs in thunk_expr can be unmemoized correctly. */
1317 const SCM new_env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1318 return scm_list_2 (scm_sym_delay
, unmemoize_expression (thunk_expr
, new_env
));
1322 SCM_SYNTAX(s_do
, "do", scm_i_makbimacro
, scm_m_do
);
1323 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
1325 /* DO gets the most radically altered syntax. The order of the vars is
1326 * reversed here. During the evaluation this allows for simple consing of the
1327 * results of the inits and steps:
1329 (do ((<var1> <init1> <step1>)
1337 (#@do (<init1> <init2> ... <initn>)
1338 (varn ... var2 var1)
1341 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
1344 scm_m_do (SCM expr
, SCM env SCM_UNUSED
)
1346 SCM variables
= SCM_EOL
;
1347 SCM init_forms
= SCM_EOL
;
1348 SCM step_forms
= SCM_EOL
;
1355 const SCM cdr_expr
= SCM_CDR (expr
);
1356 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1357 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1359 /* Collect variables, init and step forms. */
1360 binding_idx
= SCM_CAR (cdr_expr
);
1361 ASSERT_SYNTAX_2 (scm_ilength (binding_idx
) >= 0,
1362 s_bad_bindings
, binding_idx
, expr
);
1363 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1365 const SCM binding
= SCM_CAR (binding_idx
);
1366 const long length
= scm_ilength (binding
);
1367 ASSERT_SYNTAX_2 (length
== 2 || length
== 3,
1368 s_bad_binding
, binding
, expr
);
1371 const SCM name
= SCM_CAR (binding
);
1372 const SCM init
= SCM_CADR (binding
);
1373 const SCM step
= (length
== 2) ? name
: SCM_CADDR (binding
);
1374 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
1375 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, variables
)),
1376 s_duplicate_binding
, name
, expr
);
1378 variables
= scm_cons (name
, variables
);
1379 init_forms
= scm_cons (init
, init_forms
);
1380 step_forms
= scm_cons (step
, step_forms
);
1383 init_forms
= scm_reverse_x (init_forms
, SCM_UNDEFINED
);
1384 step_forms
= scm_reverse_x (step_forms
, SCM_UNDEFINED
);
1386 /* Memoize the test form and the exit sequence. */
1387 cddr_expr
= SCM_CDR (cdr_expr
);
1388 exit_clause
= SCM_CAR (cddr_expr
);
1389 ASSERT_SYNTAX_2 (scm_ilength (exit_clause
) >= 1,
1390 s_bad_exit_clause
, exit_clause
, expr
);
1392 commands
= SCM_CDR (cddr_expr
);
1393 tail
= scm_cons2 (exit_clause
, commands
, step_forms
);
1394 tail
= scm_cons2 (init_forms
, variables
, tail
);
1395 SCM_SETCAR (expr
, SCM_IM_DO
);
1396 SCM_SETCDR (expr
, tail
);
1401 unmemoize_do (const SCM expr
, const SCM env
)
1403 const SCM cdr_expr
= SCM_CDR (expr
);
1404 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1405 const SCM rnames
= SCM_CAR (cddr_expr
);
1406 const SCM extended_env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
1407 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
1408 const SCM exit_sequence
= SCM_CAR (cdddr_expr
);
1409 const SCM um_exit_sequence
= unmemoize_exprs (exit_sequence
, extended_env
);
1410 const SCM cddddr_expr
= SCM_CDR (cdddr_expr
);
1411 const SCM um_body
= unmemoize_exprs (SCM_CAR (cddddr_expr
), extended_env
);
1413 /* build transformed binding list */
1414 SCM um_names
= scm_reverse (rnames
);
1415 SCM um_inits
= unmemoize_exprs (SCM_CAR (cdr_expr
), env
);
1416 SCM um_steps
= unmemoize_exprs (SCM_CDR (cddddr_expr
), extended_env
);
1417 SCM um_bindings
= SCM_EOL
;
1418 while (!scm_is_null (um_names
))
1420 const SCM name
= SCM_CAR (um_names
);
1421 const SCM init
= SCM_CAR (um_inits
);
1422 SCM step
= SCM_CAR (um_steps
);
1423 step
= scm_is_eq (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
1425 um_bindings
= scm_cons (scm_cons2 (name
, init
, step
), um_bindings
);
1427 um_names
= SCM_CDR (um_names
);
1428 um_inits
= SCM_CDR (um_inits
);
1429 um_steps
= SCM_CDR (um_steps
);
1431 um_bindings
= scm_reverse_x (um_bindings
, SCM_UNDEFINED
);
1433 return scm_cons (scm_sym_do
,
1434 scm_cons2 (um_bindings
, um_exit_sequence
, um_body
));
1438 SCM_SYNTAX (s_if
, "if", scm_i_makbimacro
, scm_m_if
);
1439 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
1442 scm_m_if (SCM expr
, SCM env SCM_UNUSED
)
1444 const SCM cdr_expr
= SCM_CDR (expr
);
1445 const long length
= scm_ilength (cdr_expr
);
1446 ASSERT_SYNTAX (length
== 2 || length
== 3, s_expression
, expr
);
1447 SCM_SETCAR (expr
, SCM_IM_IF
);
1452 unmemoize_if (const SCM expr
, const SCM env
)
1454 const SCM cdr_expr
= SCM_CDR (expr
);
1455 const SCM um_condition
= unmemoize_expression (SCM_CAR (cdr_expr
), env
);
1456 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1457 const SCM um_then
= unmemoize_expression (SCM_CAR (cddr_expr
), env
);
1458 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
1460 if (scm_is_null (cdddr_expr
))
1462 return scm_list_3 (scm_sym_if
, um_condition
, um_then
);
1466 const SCM um_else
= unmemoize_expression (SCM_CAR (cdddr_expr
), env
);
1467 return scm_list_4 (scm_sym_if
, um_condition
, um_then
, um_else
);
1472 SCM_SYNTAX (s_lambda
, "lambda", scm_i_makbimacro
, scm_m_lambda
);
1473 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
1475 /* A helper function for memoize_lambda to support checking for duplicate
1476 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
1477 * LIST or to the cdr of the last cons. Therefore, LIST may have any of the
1478 * forms that a formal argument can have:
1479 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
1481 c_improper_memq (SCM obj
, SCM list
)
1483 for (; scm_is_pair (list
); list
= SCM_CDR (list
))
1485 if (scm_is_eq (SCM_CAR (list
), obj
))
1488 return scm_is_eq (list
, obj
);
1492 scm_m_lambda (SCM expr
, SCM env SCM_UNUSED
)
1501 const SCM cdr_expr
= SCM_CDR (expr
);
1502 const long length
= scm_ilength (cdr_expr
);
1503 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1504 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1506 /* Before iterating the list of formal arguments, make sure the formals
1507 * actually are given as either a symbol or a non-cyclic list. */
1508 formals
= SCM_CAR (cdr_expr
);
1509 if (scm_is_pair (formals
))
1511 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
1512 * detected, report a 'Bad formals' error. */
1516 ASSERT_SYNTAX_2 (scm_is_symbol (formals
) || scm_is_null (formals
),
1517 s_bad_formals
, formals
, expr
);
1520 /* Now iterate the list of formal arguments to check if all formals are
1521 * symbols, and that there are no duplicates. */
1522 formals_idx
= formals
;
1523 while (scm_is_pair (formals_idx
))
1525 const SCM formal
= SCM_CAR (formals_idx
);
1526 const SCM next_idx
= SCM_CDR (formals_idx
);
1527 ASSERT_SYNTAX_2 (scm_is_symbol (formal
), s_bad_formal
, formal
, expr
);
1528 ASSERT_SYNTAX_2 (!c_improper_memq (formal
, next_idx
),
1529 s_duplicate_formal
, formal
, expr
);
1530 formals_idx
= next_idx
;
1532 ASSERT_SYNTAX_2 (scm_is_null (formals_idx
) || scm_is_symbol (formals_idx
),
1533 s_bad_formal
, formals_idx
, expr
);
1535 /* Memoize the body. Keep a potential documentation string. */
1536 /* Dirk:FIXME:: We should probably extract the documentation string to
1537 * some external database. Otherwise it will slow down execution, since
1538 * the documentation string will have to be skipped with every execution
1539 * of the closure. */
1540 cddr_expr
= SCM_CDR (cdr_expr
);
1541 documentation
= (length
>= 3 && scm_is_string (SCM_CAR (cddr_expr
)));
1542 body
= documentation
? SCM_CDR (cddr_expr
) : cddr_expr
;
1543 new_body
= m_body (SCM_IM_LAMBDA
, body
);
1545 SCM_SETCAR (expr
, SCM_IM_LAMBDA
);
1547 SCM_SETCDR (cddr_expr
, new_body
);
1549 SCM_SETCDR (cdr_expr
, new_body
);
1554 unmemoize_lambda (const SCM expr
, const SCM env
)
1556 const SCM formals
= SCM_CADR (expr
);
1557 const SCM body
= SCM_CDDR (expr
);
1559 const SCM new_env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, env
);
1560 const SCM um_formals
= scm_i_finite_list_copy (formals
);
1561 const SCM um_body
= unmemoize_exprs (body
, new_env
);
1563 return scm_cons2 (scm_sym_lambda
, um_formals
, um_body
);
1567 /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
1569 check_bindings (const SCM bindings
, const SCM expr
)
1573 ASSERT_SYNTAX_2 (scm_ilength (bindings
) >= 0,
1574 s_bad_bindings
, bindings
, expr
);
1576 binding_idx
= bindings
;
1577 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1579 SCM name
; /* const */
1581 const SCM binding
= SCM_CAR (binding_idx
);
1582 ASSERT_SYNTAX_2 (scm_ilength (binding
) == 2,
1583 s_bad_binding
, binding
, expr
);
1585 name
= SCM_CAR (binding
);
1586 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
1591 /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
1592 * transformed to the lists (vn ... v2 v1) and (i1 i2 ... in). That is, the
1593 * variables are returned in a list with their order reversed, and the init
1594 * forms are returned in a list in the same order as they are given in the
1595 * bindings. If a duplicate variable name is detected, an error is
1598 transform_bindings (
1599 const SCM bindings
, const SCM expr
,
1600 SCM
*const rvarptr
, SCM
*const initptr
)
1602 SCM rvariables
= SCM_EOL
;
1603 SCM rinits
= SCM_EOL
;
1604 SCM binding_idx
= bindings
;
1605 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1607 const SCM binding
= SCM_CAR (binding_idx
);
1608 const SCM cdr_binding
= SCM_CDR (binding
);
1609 const SCM name
= SCM_CAR (binding
);
1610 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, rvariables
)),
1611 s_duplicate_binding
, name
, expr
);
1612 rvariables
= scm_cons (name
, rvariables
);
1613 rinits
= scm_cons (SCM_CAR (cdr_binding
), rinits
);
1615 *rvarptr
= rvariables
;
1616 *initptr
= scm_reverse_x (rinits
, SCM_UNDEFINED
);
1620 SCM_SYNTAX(s_let
, "let", scm_i_makbimacro
, scm_m_let
);
1621 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
1623 /* This function is a helper function for memoize_let. It transforms
1624 * (let name ((var init) ...) body ...) into
1625 * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
1626 * and memoizes the expression. It is assumed that the caller has checked
1627 * that name is a symbol and that there are bindings and a body. */
1629 memoize_named_let (const SCM expr
, const SCM env SCM_UNUSED
)
1635 const SCM cdr_expr
= SCM_CDR (expr
);
1636 const SCM name
= SCM_CAR (cdr_expr
);
1637 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1638 const SCM bindings
= SCM_CAR (cddr_expr
);
1639 check_bindings (bindings
, expr
);
1641 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1642 variables
= scm_reverse_x (rvariables
, SCM_UNDEFINED
);
1645 const SCM let_body
= SCM_CDR (cddr_expr
);
1646 const SCM lambda_body
= m_body (SCM_IM_LET
, let_body
);
1647 const SCM lambda_tail
= scm_cons (variables
, lambda_body
);
1648 const SCM lambda_form
= scm_cons_source (expr
, scm_sym_lambda
, lambda_tail
);
1650 const SCM rvar
= scm_list_1 (name
);
1651 const SCM init
= scm_list_1 (lambda_form
);
1652 const SCM body
= m_body (SCM_IM_LET
, scm_list_1 (name
));
1653 const SCM letrec_tail
= scm_cons (rvar
, scm_cons (init
, body
));
1654 const SCM letrec_form
= scm_cons_source (expr
, SCM_IM_LETREC
, letrec_tail
);
1655 return scm_cons_source (expr
, letrec_form
, inits
);
1659 /* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1660 * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
1662 scm_m_let (SCM expr
, SCM env
)
1666 const SCM cdr_expr
= SCM_CDR (expr
);
1667 const long length
= scm_ilength (cdr_expr
);
1668 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1669 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1671 bindings
= SCM_CAR (cdr_expr
);
1672 if (scm_is_symbol (bindings
))
1674 ASSERT_SYNTAX (length
>= 3, s_missing_expression
, expr
);
1675 return memoize_named_let (expr
, env
);
1678 check_bindings (bindings
, expr
);
1679 if (scm_is_null (bindings
) || scm_is_null (SCM_CDR (bindings
)))
1681 /* Special case: no bindings or single binding => let* is faster. */
1682 const SCM body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1683 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), bindings
, body
), env
);
1690 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1693 const SCM new_body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1694 const SCM new_tail
= scm_cons2 (rvariables
, inits
, new_body
);
1695 SCM_SETCAR (expr
, SCM_IM_LET
);
1696 SCM_SETCDR (expr
, new_tail
);
1703 build_binding_list (SCM rnames
, SCM rinits
)
1705 SCM bindings
= SCM_EOL
;
1706 while (!scm_is_null (rnames
))
1708 const SCM binding
= scm_list_2 (SCM_CAR (rnames
), SCM_CAR (rinits
));
1709 bindings
= scm_cons (binding
, bindings
);
1710 rnames
= SCM_CDR (rnames
);
1711 rinits
= SCM_CDR (rinits
);
1717 unmemoize_let (const SCM expr
, const SCM env
)
1719 const SCM cdr_expr
= SCM_CDR (expr
);
1720 const SCM um_rnames
= SCM_CAR (cdr_expr
);
1721 const SCM extended_env
= SCM_EXTEND_ENV (um_rnames
, SCM_EOL
, env
);
1722 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1723 const SCM um_inits
= unmemoize_exprs (SCM_CAR (cddr_expr
), env
);
1724 const SCM um_rinits
= scm_reverse_x (um_inits
, SCM_UNDEFINED
);
1725 const SCM um_bindings
= build_binding_list (um_rnames
, um_rinits
);
1726 const SCM um_body
= unmemoize_exprs (SCM_CDR (cddr_expr
), extended_env
);
1728 return scm_cons2 (scm_sym_let
, um_bindings
, um_body
);
1732 SCM_SYNTAX(s_letrec
, "letrec", scm_i_makbimacro
, scm_m_letrec
);
1733 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
1736 scm_m_letrec (SCM expr
, SCM env
)
1740 const SCM cdr_expr
= SCM_CDR (expr
);
1741 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1742 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1744 bindings
= SCM_CAR (cdr_expr
);
1745 if (scm_is_null (bindings
))
1747 /* no bindings, let* is executed faster */
1748 SCM body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1749 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), SCM_EOL
, body
), env
);
1757 check_bindings (bindings
, expr
);
1758 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1759 new_body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1760 return scm_cons2 (SCM_IM_LETREC
, rvariables
, scm_cons (inits
, new_body
));
1765 unmemoize_letrec (const SCM expr
, const SCM env
)
1767 const SCM cdr_expr
= SCM_CDR (expr
);
1768 const SCM um_rnames
= SCM_CAR (cdr_expr
);
1769 const SCM extended_env
= SCM_EXTEND_ENV (um_rnames
, SCM_EOL
, env
);
1770 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1771 const SCM um_inits
= unmemoize_exprs (SCM_CAR (cddr_expr
), extended_env
);
1772 const SCM um_rinits
= scm_reverse_x (um_inits
, SCM_UNDEFINED
);
1773 const SCM um_bindings
= build_binding_list (um_rnames
, um_rinits
);
1774 const SCM um_body
= unmemoize_exprs (SCM_CDR (cddr_expr
), extended_env
);
1776 return scm_cons2 (scm_sym_letrec
, um_bindings
, um_body
);
1781 SCM_SYNTAX (s_letstar
, "let*", scm_i_makbimacro
, scm_m_letstar
);
1782 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
1784 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1785 * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
1787 scm_m_letstar (SCM expr
, SCM env SCM_UNUSED
)
1792 const SCM cdr_expr
= SCM_CDR (expr
);
1793 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1794 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1796 binding_idx
= SCM_CAR (cdr_expr
);
1797 check_bindings (binding_idx
, expr
);
1799 /* Transform ((v1 i1) (v2 i2) ...) into (v1 i1 v2 i2 ...). The
1800 * transformation is done in place. At the beginning of one iteration of
1801 * the loop the variable binding_idx holds the form
1802 * P1:( (vn . P2:(in . ())) . P3:( (vn+1 in+1) ... ) ),
1803 * where P1, P2 and P3 indicate the pairs, that are relevant for the
1804 * transformation. P1 and P2 are modified in the loop, P3 remains
1805 * untouched. After the execution of the loop, P1 will hold
1806 * P1:( vn . P2:(in . P3:( (vn+1 in+1) ... )) )
1807 * and binding_idx will hold P3. */
1808 while (!scm_is_null (binding_idx
))
1810 const SCM cdr_binding_idx
= SCM_CDR (binding_idx
); /* remember P3 */
1811 const SCM binding
= SCM_CAR (binding_idx
);
1812 const SCM name
= SCM_CAR (binding
);
1813 const SCM cdr_binding
= SCM_CDR (binding
);
1815 SCM_SETCDR (cdr_binding
, cdr_binding_idx
); /* update P2 */
1816 SCM_SETCAR (binding_idx
, name
); /* update P1 */
1817 SCM_SETCDR (binding_idx
, cdr_binding
); /* update P1 */
1819 binding_idx
= cdr_binding_idx
; /* continue with P3 */
1822 new_body
= m_body (SCM_IM_LETSTAR
, SCM_CDR (cdr_expr
));
1823 SCM_SETCAR (expr
, SCM_IM_LETSTAR
);
1824 /* the bindings have been changed in place */
1825 SCM_SETCDR (cdr_expr
, new_body
);
1830 unmemoize_letstar (const SCM expr
, const SCM env
)
1832 const SCM cdr_expr
= SCM_CDR (expr
);
1833 const SCM body
= SCM_CDR (cdr_expr
);
1834 SCM bindings
= SCM_CAR (cdr_expr
);
1835 SCM um_bindings
= SCM_EOL
;
1836 SCM extended_env
= env
;
1839 while (!scm_is_null (bindings
))
1841 const SCM variable
= SCM_CAR (bindings
);
1842 const SCM init
= SCM_CADR (bindings
);
1843 const SCM um_init
= unmemoize_expression (init
, extended_env
);
1844 um_bindings
= scm_cons (scm_list_2 (variable
, um_init
), um_bindings
);
1845 extended_env
= SCM_EXTEND_ENV (variable
, SCM_BOOL_F
, extended_env
);
1846 bindings
= SCM_CDDR (bindings
);
1848 um_bindings
= scm_reverse_x (um_bindings
, SCM_UNDEFINED
);
1850 um_body
= unmemoize_exprs (body
, extended_env
);
1852 return scm_cons2 (scm_sym_letstar
, um_bindings
, um_body
);
1856 SCM_SYNTAX (s_or
, "or", scm_i_makbimacro
, scm_m_or
);
1857 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
1860 scm_m_or (SCM expr
, SCM env SCM_UNUSED
)
1862 const SCM cdr_expr
= SCM_CDR (expr
);
1863 const long length
= scm_ilength (cdr_expr
);
1865 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1869 /* Special case: (or) is replaced by #f. */
1874 SCM_SETCAR (expr
, SCM_IM_OR
);
1880 unmemoize_or (const SCM expr
, const SCM env
)
1882 return scm_cons (scm_sym_or
, unmemoize_exprs (SCM_CDR (expr
), env
));
1886 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
1887 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
1888 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
1889 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
1891 /* Internal function to handle a quasiquotation: 'form' is the parameter in
1892 * the call (quasiquotation form), 'env' is the environment where unquoted
1893 * expressions will be evaluated, and 'depth' is the current quasiquotation
1894 * nesting level and is known to be greater than zero. */
1896 iqq (SCM form
, SCM env
, unsigned long int depth
)
1898 if (scm_is_pair (form
))
1900 const SCM tmp
= SCM_CAR (form
);
1901 if (scm_is_eq (tmp
, scm_sym_quasiquote
))
1903 const SCM args
= SCM_CDR (form
);
1904 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1905 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
1907 else if (scm_is_eq (tmp
, scm_sym_unquote
))
1909 const SCM args
= SCM_CDR (form
);
1910 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1912 return scm_eval_car (args
, env
);
1914 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
1916 else if (scm_is_pair (tmp
)
1917 && scm_is_eq (SCM_CAR (tmp
), scm_sym_uq_splicing
))
1919 const SCM args
= SCM_CDR (tmp
);
1920 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1923 const SCM list
= scm_eval_car (args
, env
);
1924 const SCM rest
= SCM_CDR (form
);
1925 ASSERT_SYNTAX_2 (scm_ilength (list
) >= 0,
1926 s_splicing
, list
, form
);
1927 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
1930 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
1931 iqq (SCM_CDR (form
), env
, depth
));
1934 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
1935 iqq (SCM_CDR (form
), env
, depth
));
1937 else if (scm_is_vector (form
))
1938 return scm_vector (iqq (scm_vector_to_list (form
), env
, depth
));
1944 scm_m_quasiquote (SCM expr
, SCM env
)
1946 const SCM cdr_expr
= SCM_CDR (expr
);
1947 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1948 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1949 return iqq (SCM_CAR (cdr_expr
), env
, 1);
1953 SCM_SYNTAX (s_quote
, "quote", scm_i_makbimacro
, scm_m_quote
);
1954 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
1957 scm_m_quote (SCM expr
, SCM env SCM_UNUSED
)
1961 const SCM cdr_expr
= SCM_CDR (expr
);
1962 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1963 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1964 quotee
= SCM_CAR (cdr_expr
);
1965 if (is_self_quoting_p (quotee
))
1968 SCM_SETCAR (expr
, SCM_IM_QUOTE
);
1969 SCM_SETCDR (expr
, quotee
);
1974 unmemoize_quote (const SCM expr
, const SCM env SCM_UNUSED
)
1976 return scm_list_2 (scm_sym_quote
, SCM_CDR (expr
));
1980 /* Will go into the RnRS module when Guile is factorized.
1981 SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
1982 static const char s_set_x
[] = "set!";
1983 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, s_set_x
);
1986 scm_m_set_x (SCM expr
, SCM env SCM_UNUSED
)
1991 const SCM cdr_expr
= SCM_CDR (expr
);
1992 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1993 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1994 variable
= SCM_CAR (cdr_expr
);
1996 /* Memoize the variable form. */
1997 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
1998 new_variable
= lookup_symbol (variable
, env
);
1999 /* Leave the memoization of unbound symbols to lazy memoization: */
2000 if (SCM_UNBNDP (new_variable
))
2001 new_variable
= variable
;
2003 SCM_SETCAR (expr
, SCM_IM_SET_X
);
2004 SCM_SETCAR (cdr_expr
, new_variable
);
2009 unmemoize_set_x (const SCM expr
, const SCM env
)
2011 return scm_cons (scm_sym_set_x
, unmemoize_exprs (SCM_CDR (expr
), env
));
2016 /* Start of the memoizers for non-R5RS builtin macros. */
2019 SCM_SYNTAX (s_at
, "@", scm_makmmacro
, scm_m_at
);
2020 SCM_GLOBAL_SYMBOL (scm_sym_at
, s_at
);
2023 scm_m_at (SCM expr
, SCM env SCM_UNUSED
)
2026 ASSERT_SYNTAX (scm_ilength (expr
) == 3, s_bad_expression
, expr
);
2027 ASSERT_SYNTAX (scm_ilength (scm_cadr (expr
)) > 0, s_bad_expression
, expr
);
2028 ASSERT_SYNTAX (scm_is_symbol (scm_caddr (expr
)), s_bad_expression
, expr
);
2030 mod
= scm_resolve_module (scm_cadr (expr
));
2031 if (scm_is_false (mod
))
2032 error_unbound_variable (expr
);
2033 var
= scm_module_variable (scm_module_public_interface (mod
), scm_caddr (expr
));
2034 if (scm_is_false (var
))
2035 error_unbound_variable (expr
);
2040 SCM_SYNTAX (s_atat
, "@@", scm_makmmacro
, scm_m_atat
);
2041 SCM_GLOBAL_SYMBOL (scm_sym_atat
, s_atat
);
2044 scm_m_atat (SCM expr
, SCM env SCM_UNUSED
)
2047 ASSERT_SYNTAX (scm_ilength (expr
) == 3, s_bad_expression
, expr
);
2048 ASSERT_SYNTAX (scm_ilength (scm_cadr (expr
)) > 0, s_bad_expression
, expr
);
2049 ASSERT_SYNTAX (scm_is_symbol (scm_caddr (expr
)), s_bad_expression
, expr
);
2051 mod
= scm_resolve_module (scm_cadr (expr
));
2052 if (scm_is_false (mod
))
2053 error_unbound_variable (expr
);
2054 var
= scm_module_variable (mod
, scm_caddr (expr
));
2055 if (scm_is_false (var
))
2056 error_unbound_variable (expr
);
2061 SCM_SYNTAX (s_atapply
, "@apply", scm_i_makbimacro
, scm_m_apply
);
2062 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
2063 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
2066 scm_m_apply (SCM expr
, SCM env SCM_UNUSED
)
2068 const SCM cdr_expr
= SCM_CDR (expr
);
2069 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2070 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_missing_expression
, expr
);
2072 SCM_SETCAR (expr
, SCM_IM_APPLY
);
2077 unmemoize_apply (const SCM expr
, const SCM env
)
2079 return scm_list_2 (scm_sym_atapply
, unmemoize_exprs (SCM_CDR (expr
), env
));
2083 SCM_SYNTAX (s_atbind
, "@bind", scm_i_makbimacro
, scm_m_atbind
);
2085 /* FIXME: The following explanation should go into the documentation: */
2086 /* (@bind ((var init) ...) body ...) will assign the values of the `init's to
2087 * the global variables named by `var's (symbols, not evaluated), creating
2088 * them if they don't exist, executes body, and then restores the previous
2089 * values of the `var's. Additionally, whenever control leaves body, the
2090 * values of the `var's are saved and restored when control returns. It is an
2091 * error when a symbol appears more than once among the `var's. All `init's
2092 * are evaluated before any `var' is set.
2094 * Think of this as `let' for dynamic scope.
2097 /* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into
2098 * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...).
2100 * FIXME - also implement `@bind*'.
2103 scm_m_atbind (SCM expr
, SCM env
)
2110 const SCM top_level
= scm_env_top_level (env
);
2112 const SCM cdr_expr
= SCM_CDR (expr
);
2113 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2114 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
2115 bindings
= SCM_CAR (cdr_expr
);
2116 check_bindings (bindings
, expr
);
2117 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
2119 for (variable_idx
= rvariables
;
2120 !scm_is_null (variable_idx
);
2121 variable_idx
= SCM_CDR (variable_idx
))
2123 /* The first call to scm_sym2var will look beyond the current module,
2124 * while the second call wont. */
2125 const SCM variable
= SCM_CAR (variable_idx
);
2126 SCM new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_F
);
2127 if (scm_is_false (new_variable
))
2128 new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_T
);
2129 SCM_SETCAR (variable_idx
, new_variable
);
2132 SCM_SETCAR (expr
, SCM_IM_BIND
);
2133 SCM_SETCAR (cdr_expr
, scm_cons (rvariables
, inits
));
2138 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_i_makbimacro
, scm_m_cont
);
2139 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, s_atcall_cc
);
2142 scm_m_cont (SCM expr
, SCM env SCM_UNUSED
)
2144 const SCM cdr_expr
= SCM_CDR (expr
);
2145 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2146 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2148 SCM_SETCAR (expr
, SCM_IM_CONT
);
2153 unmemoize_atcall_cc (const SCM expr
, const SCM env
)
2155 return scm_list_2 (scm_sym_atcall_cc
, unmemoize_exprs (SCM_CDR (expr
), env
));
2159 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_i_makbimacro
, scm_m_at_call_with_values
);
2160 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
2163 scm_m_at_call_with_values (SCM expr
, SCM env SCM_UNUSED
)
2165 const SCM cdr_expr
= SCM_CDR (expr
);
2166 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2167 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2169 SCM_SETCAR (expr
, SCM_IM_CALL_WITH_VALUES
);
2174 unmemoize_at_call_with_values (const SCM expr
, const SCM env
)
2176 return scm_list_2 (scm_sym_at_call_with_values
,
2177 unmemoize_exprs (SCM_CDR (expr
), env
));
2180 SCM_SYNTAX (s_eval_when
, "eval-when", scm_makmmacro
, scm_m_eval_when
);
2181 SCM_GLOBAL_SYMBOL (scm_sym_eval_when
, s_eval_when
);
2182 SCM_SYMBOL (sym_eval
, "eval");
2183 SCM_SYMBOL (sym_load
, "load");
2187 scm_m_eval_when (SCM expr
, SCM env SCM_UNUSED
)
2189 ASSERT_SYNTAX (scm_ilength (expr
) >= 3, s_bad_expression
, expr
);
2190 ASSERT_SYNTAX (scm_ilength (scm_cadr (expr
)) > 0, s_bad_expression
, expr
);
2192 if (scm_is_true (scm_memq (sym_eval
, scm_cadr (expr
)))
2193 || scm_is_true (scm_memq (sym_load
, scm_cadr (expr
))))
2194 return scm_cons (SCM_IM_BEGIN
, scm_cddr (expr
));
2196 return scm_list_1 (SCM_IM_BEGIN
);
2201 /* See futures.h for a comment why futures are not enabled.
2204 SCM_SYNTAX (s_future
, "future", scm_i_makbimacro
, scm_m_future
);
2205 SCM_GLOBAL_SYMBOL (scm_sym_future
, s_future
);
2207 /* Like promises, futures are implemented as closures with an empty
2208 * parameter list. Thus, (future <expression>) is transformed into
2209 * (#@future '() <expression>), where the empty list represents the
2210 * empty parameter list. This representation allows for easy creation
2211 * of the closure during evaluation. */
2213 scm_m_future (SCM expr
, SCM env
)
2215 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
2216 SCM_SETCAR (new_expr
, SCM_IM_FUTURE
);
2221 unmemoize_future (const SCM expr
, const SCM env
)
2223 const SCM thunk_expr
= SCM_CADDR (expr
);
2224 return scm_list_2 (scm_sym_future
, unmemoize_expression (thunk_expr
, env
));
2227 #endif /* futures disabled. */
2229 SCM_SYNTAX (s_gset_x
, "set!", scm_i_makbimacro
, scm_m_generalized_set_x
);
2230 SCM_SYMBOL (scm_sym_setter
, "setter");
2233 scm_m_generalized_set_x (SCM expr
, SCM env
)
2235 SCM target
, exp_target
;
2237 const SCM cdr_expr
= SCM_CDR (expr
);
2238 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2239 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2241 target
= SCM_CAR (cdr_expr
);
2242 if (!scm_is_pair (target
))
2245 return scm_m_set_x (expr
, env
);
2249 /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */
2250 /* Macroexpanding the target might return things of the form
2251 (begin <atom>). In that case, <atom> must be a symbol or a
2252 variable and we memoize to (set! <atom> ...).
2254 exp_target
= macroexp (target
, env
);
2255 if (scm_is_eq (SCM_CAR (exp_target
), SCM_IM_BEGIN
)
2256 && !scm_is_null (SCM_CDR (exp_target
))
2257 && scm_is_null (SCM_CDDR (exp_target
)))
2259 exp_target
= SCM_CADR (exp_target
);
2260 ASSERT_SYNTAX_2 (scm_is_symbol (exp_target
)
2261 || SCM_VARIABLEP (exp_target
),
2262 s_bad_variable
, exp_target
, expr
);
2263 return scm_cons (SCM_IM_SET_X
, scm_cons (exp_target
,
2264 SCM_CDR (cdr_expr
)));
2268 const SCM setter_proc_tail
= scm_list_1 (SCM_CAR (target
));
2269 const SCM setter_proc
= scm_cons_source (expr
, scm_sym_setter
,
2272 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
2273 const SCM setter_args
= scm_append_x (scm_list_2 (SCM_CDR (target
),
2276 SCM_SETCAR (expr
, setter_proc
);
2277 SCM_SETCDR (expr
, setter_args
);
2284 /* @slot-ref is bound privately in the (oop goops) module from goops.c. As
2285 * soon as the module system allows us to more freely create bindings in
2286 * arbitrary modules during the startup phase, the code from goops.c should be
2289 SCM_SYNTAX (s_atslot_ref
, "@slot-ref", scm_i_makbimacro
, scm_m_atslot_ref
);
2290 SCM_SYNTAX (s_atslot_set_x
, "@slot-set!", scm_i_makbimacro
, scm_m_atslot_set_x
);
2291 SCM_SYMBOL (sym_atslot_ref
, "@slot-ref");
2294 scm_m_atslot_ref (SCM expr
, SCM env SCM_UNUSED
)
2298 const SCM cdr_expr
= SCM_CDR (expr
);
2299 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2300 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2301 slot_nr
= SCM_CADR (cdr_expr
);
2302 ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2304 SCM_SETCAR (expr
, SCM_IM_SLOT_REF
);
2305 SCM_SETCDR (cdr_expr
, slot_nr
);
2310 unmemoize_atslot_ref (const SCM expr
, const SCM env
)
2312 const SCM instance
= SCM_CADR (expr
);
2313 const SCM um_instance
= unmemoize_expression (instance
, env
);
2314 const SCM slot_nr
= SCM_CDDR (expr
);
2315 return scm_list_3 (sym_atslot_ref
, um_instance
, slot_nr
);
2319 /* @slot-set! is bound privately in the (oop goops) module from goops.c. As
2320 * soon as the module system allows us to more freely create bindings in
2321 * arbitrary modules during the startup phase, the code from goops.c should be
2324 SCM_SYMBOL (sym_atslot_set_x
, "@slot-set!");
2327 scm_m_atslot_set_x (SCM expr
, SCM env SCM_UNUSED
)
2331 const SCM cdr_expr
= SCM_CDR (expr
);
2332 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2333 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 3, s_expression
, expr
);
2334 slot_nr
= SCM_CADR (cdr_expr
);
2335 ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2337 SCM_SETCAR (expr
, SCM_IM_SLOT_SET_X
);
2342 unmemoize_atslot_set_x (const SCM expr
, const SCM env
)
2344 const SCM cdr_expr
= SCM_CDR (expr
);
2345 const SCM instance
= SCM_CAR (cdr_expr
);
2346 const SCM um_instance
= unmemoize_expression (instance
, env
);
2347 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
2348 const SCM slot_nr
= SCM_CAR (cddr_expr
);
2349 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
2350 const SCM value
= SCM_CAR (cdddr_expr
);
2351 const SCM um_value
= unmemoize_expression (value
, env
);
2352 return scm_list_4 (sym_atslot_set_x
, um_instance
, slot_nr
, um_value
);
2356 #if SCM_ENABLE_ELISP
2358 static const char s_defun
[] = "Symbol's function definition is void";
2360 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_i_makbimacro
, scm_m_nil_cond
);
2362 /* nil-cond expressions have the form
2363 * (nil-cond COND VAL COND VAL ... ELSEVAL) */
2365 scm_m_nil_cond (SCM expr
, SCM env SCM_UNUSED
)
2367 const long length
= scm_ilength (SCM_CDR (expr
));
2368 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
2369 ASSERT_SYNTAX (length
>= 1 && (length
% 2) == 1, s_expression
, expr
);
2371 SCM_SETCAR (expr
, SCM_IM_NIL_COND
);
2376 SCM_SYNTAX (s_atfop
, "@fop", scm_i_makbimacro
, scm_m_atfop
);
2378 /* The @fop-macro handles procedure and macro applications for elisp. The
2379 * input expression must have the form
2380 * (@fop <var> (transformer-macro <expr> ...))
2381 * where <var> must be a symbol. The expression is transformed into the
2382 * memoized form of either
2383 * (apply <un-aliased var> (transformer-macro <expr> ...))
2384 * if the value of var (across all aliasing) is not a macro, or
2385 * (<un-aliased var> <expr> ...)
2386 * if var is a macro. */
2388 scm_m_atfop (SCM expr
, SCM env SCM_UNUSED
)
2393 const SCM cdr_expr
= SCM_CDR (expr
);
2394 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2395 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 1, s_missing_expression
, expr
);
2397 symbol
= SCM_CAR (cdr_expr
);
2398 ASSERT_SYNTAX_2 (scm_is_symbol (symbol
), s_bad_variable
, symbol
, expr
);
2400 location
= scm_symbol_fref (symbol
);
2401 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2403 /* The elisp function `defalias' allows to define aliases for symbols. To
2404 * look up such definitions, the chain of symbol definitions has to be
2405 * followed up to the terminal symbol. */
2406 while (scm_is_symbol (SCM_VARIABLE_REF (location
)))
2408 const SCM alias
= SCM_VARIABLE_REF (location
);
2409 location
= scm_symbol_fref (alias
);
2410 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2413 /* Memoize the value location belonging to the terminal symbol. */
2414 SCM_SETCAR (cdr_expr
, location
);
2416 if (!SCM_MACROP (SCM_VARIABLE_REF (location
)))
2418 /* Since the location does not contain a macro, the form is a procedure
2419 * application. Replace `@fop' by `@apply' and transform the expression
2420 * including the `transformer-macro'. */
2421 SCM_SETCAR (expr
, SCM_IM_APPLY
);
2426 /* Since the location contains a macro, the arguments should not be
2427 * transformed, so the `transformer-macro' is cut out. The resulting
2428 * expression starts with the memoized variable, that is at the cdr of
2429 * the input expression. */
2430 SCM_SETCDR (cdr_expr
, SCM_CDADR (cdr_expr
));
2435 #endif /* SCM_ENABLE_ELISP */
2439 unmemoize_builtin_macro (const SCM expr
, const SCM env
)
2441 switch (ISYMNUM (SCM_CAR (expr
)))
2443 case (ISYMNUM (SCM_IM_AND
)):
2444 return unmemoize_and (expr
, env
);
2446 case (ISYMNUM (SCM_IM_BEGIN
)):
2447 return unmemoize_begin (expr
, env
);
2449 case (ISYMNUM (SCM_IM_CASE
)):
2450 return unmemoize_case (expr
, env
);
2452 case (ISYMNUM (SCM_IM_COND
)):
2453 return unmemoize_cond (expr
, env
);
2455 case (ISYMNUM (SCM_IM_DELAY
)):
2456 return unmemoize_delay (expr
, env
);
2458 case (ISYMNUM (SCM_IM_DO
)):
2459 return unmemoize_do (expr
, env
);
2461 case (ISYMNUM (SCM_IM_IF
)):
2462 return unmemoize_if (expr
, env
);
2464 case (ISYMNUM (SCM_IM_LAMBDA
)):
2465 return unmemoize_lambda (expr
, env
);
2467 case (ISYMNUM (SCM_IM_LET
)):
2468 return unmemoize_let (expr
, env
);
2470 case (ISYMNUM (SCM_IM_LETREC
)):
2471 return unmemoize_letrec (expr
, env
);
2473 case (ISYMNUM (SCM_IM_LETSTAR
)):
2474 return unmemoize_letstar (expr
, env
);
2476 case (ISYMNUM (SCM_IM_OR
)):
2477 return unmemoize_or (expr
, env
);
2479 case (ISYMNUM (SCM_IM_QUOTE
)):
2480 return unmemoize_quote (expr
, env
);
2482 case (ISYMNUM (SCM_IM_SET_X
)):
2483 return unmemoize_set_x (expr
, env
);
2485 case (ISYMNUM (SCM_IM_APPLY
)):
2486 return unmemoize_apply (expr
, env
);
2488 case (ISYMNUM (SCM_IM_BIND
)):
2489 return unmemoize_exprs (expr
, env
); /* FIXME */
2491 case (ISYMNUM (SCM_IM_CONT
)):
2492 return unmemoize_atcall_cc (expr
, env
);
2494 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2495 return unmemoize_at_call_with_values (expr
, env
);
2498 /* See futures.h for a comment why futures are not enabled.
2500 case (ISYMNUM (SCM_IM_FUTURE
)):
2501 return unmemoize_future (expr
, env
);
2504 case (ISYMNUM (SCM_IM_SLOT_REF
)):
2505 return unmemoize_atslot_ref (expr
, env
);
2507 case (ISYMNUM (SCM_IM_SLOT_SET_X
)):
2508 return unmemoize_atslot_set_x (expr
, env
);
2510 case (ISYMNUM (SCM_IM_NIL_COND
)):
2511 return unmemoize_exprs (expr
, env
); /* FIXME */
2514 return unmemoize_exprs (expr
, env
); /* FIXME */
2519 /* scm_i_unmemocopy_expr and scm_i_unmemocopy_body take a memoized expression
2520 * respectively a memoized body together with its environment and rewrite it
2521 * to its original form. Thus, these functions are the inversion of the
2522 * rewrite rules above. The procedure is not optimized for speed. It's used
2523 * in scm_i_unmemoize_expr, scm_procedure_source, macro_print and scm_iprin1.
2525 * Unmemoizing is not a reliable process. You cannot in general expect to get
2526 * the original source back.
2528 * However, GOOPS currently relies on this for method compilation. This ought
2532 scm_i_unmemocopy_expr (SCM expr
, SCM env
)
2534 const SCM source_properties
= scm_whash_lookup (scm_source_whash
, expr
);
2535 const SCM um_expr
= unmemoize_expression (expr
, env
);
2537 if (scm_is_true (source_properties
))
2538 scm_whash_insert (scm_source_whash
, um_expr
, source_properties
);
2544 scm_i_unmemocopy_body (SCM forms
, SCM env
)
2546 const SCM source_properties
= scm_whash_lookup (scm_source_whash
, forms
);
2547 const SCM um_forms
= unmemoize_exprs (forms
, env
);
2549 if (scm_is_true (source_properties
))
2550 scm_whash_insert (scm_source_whash
, um_forms
, source_properties
);
2556 #if (SCM_ENABLE_DEPRECATED == 1)
2558 static SCM
scm_m_undefine (SCM expr
, SCM env
);
2560 SCM_SYNTAX (s_undefine
, "undefine", scm_makacro
, scm_m_undefine
);
2563 scm_m_undefine (SCM expr
, SCM env
)
2568 const SCM cdr_expr
= SCM_CDR (expr
);
2569 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), "Bad undefine placement in", expr
);
2570 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2571 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2573 scm_c_issue_deprecation_warning
2574 ("`undefine' is deprecated.\n");
2576 variable
= SCM_CAR (cdr_expr
);
2577 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
2578 location
= scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_F
);
2579 ASSERT_SYNTAX_2 (scm_is_true (location
)
2580 && !SCM_UNBNDP (SCM_VARIABLE_REF (location
)),
2581 "variable already unbound ", variable
, expr
);
2582 SCM_VARIABLE_SET (location
, SCM_UNDEFINED
);
2583 return SCM_UNSPECIFIED
;
2586 #endif /* SCM_ENABLE_DEPRECATED */
2590 /*****************************************************************************/
2591 /*****************************************************************************/
2592 /* The definitions for execution start here. */
2593 /*****************************************************************************/
2594 /*****************************************************************************/
2596 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
2597 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
2598 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
2599 SCM_GLOBAL_SYMBOL (scm_sym_memoize_symbol
, "memoize-symbol");
2600 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
2601 SCM_SYMBOL (sym_instead
, "instead");
2603 /* A function object to implement "apply" for non-closure functions. */
2605 /* An endless list consisting of #<undefined> objects: */
2606 static SCM undefineds
;
2610 scm_badargsp (SCM formals
, SCM args
)
2612 while (!scm_is_null (formals
))
2614 if (!scm_is_pair (formals
))
2616 if (scm_is_null (args
))
2618 formals
= SCM_CDR (formals
);
2619 args
= SCM_CDR (args
);
2621 return !scm_is_null (args
) ? 1 : 0;
2626 /* The evaluator contains a plethora of EVAL symbols.
2629 * SCM_I_EVALIM is used when it is known that the expression is an
2630 * immediate. (This macro never calls an evaluator.)
2632 * SCM_I_XEVAL evaluates an expression that is expected to have its symbols already
2633 * memoized. Expressions that are not of the form '(<form> <form> ...)' are
2634 * evaluated inline without calling an evaluator.
2636 * This macro uses ceval or deval depending on its 3rd argument.
2638 * SCM_I_XEVALCAR evaluates the car of an expression 'X:(Y:<form> <form> ...)',
2639 * potentially replacing a symbol at the position Y:<form> by its memoized
2640 * variable. If Y:<form> is not of the form '(<form> <form> ...)', the
2641 * evaluation is performed inline without calling an evaluator.
2643 * This macro uses ceval or deval depending on its 3rd argument.
2647 #define SCM_I_EVALIM2(x) \
2648 ((scm_is_eq ((x), SCM_EOL) \
2649 ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \
2653 #define SCM_I_EVALIM(x, env) (SCM_ILOCP (x) \
2654 ? *scm_ilookup ((x), (env)) \
2657 #define SCM_I_XEVAL(x, env, debug_p) \
2659 ? SCM_I_EVALIM2 (x) \
2660 : (SCM_VARIABLEP (x) \
2661 ? SCM_VARIABLE_REF (x) \
2662 : (scm_is_pair (x) \
2664 ? deval ((x), (env)) \
2665 : ceval ((x), (env))) \
2668 #define SCM_I_XEVALCAR(x, env, debug_p) \
2669 (SCM_IMP (SCM_CAR (x)) \
2670 ? SCM_I_EVALIM (SCM_CAR (x), (env)) \
2671 : (SCM_VARIABLEP (SCM_CAR (x)) \
2672 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2673 : (scm_is_pair (SCM_CAR (x)) \
2675 ? deval (SCM_CAR (x), (env)) \
2676 : ceval (SCM_CAR (x), (env))) \
2677 : (!scm_is_symbol (SCM_CAR (x)) \
2679 : *scm_lookupcar ((x), (env), 1)))))
2681 scm_i_pthread_mutex_t source_mutex
;
2684 /* Lookup a given local variable in an environment. The local variable is
2685 * given as an iloc, that is a triple <frame, binding, last?>, where frame
2686 * indicates the relative number of the environment frame (counting upwards
2687 * from the innermost environment frame), binding indicates the number of the
2688 * binding within the frame, and last? (which is extracted from the iloc using
2689 * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
2690 * very end of the improper list of bindings. */
2692 scm_ilookup (SCM iloc
, SCM env
)
2694 unsigned int frame_nr
= SCM_IFRAME (iloc
);
2695 unsigned int binding_nr
= SCM_IDIST (iloc
);
2699 for (; 0 != frame_nr
; --frame_nr
)
2700 frames
= SCM_CDR (frames
);
2702 bindings
= SCM_CAR (frames
);
2703 for (; 0 != binding_nr
; --binding_nr
)
2704 bindings
= SCM_CDR (bindings
);
2706 if (SCM_ICDRP (iloc
))
2707 return SCM_CDRLOC (bindings
);
2708 return SCM_CARLOC (SCM_CDR (bindings
));
2712 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
2714 /* Call this for variables that are unfound.
2717 error_unbound_variable (SCM symbol
)
2719 scm_error (scm_unbound_variable_key
, NULL
,
2720 "Unbound variable: ~S",
2721 scm_list_1 (symbol
), SCM_BOOL_F
);
2724 /* Call this for variables that are found but contain SCM_UNDEFINED.
2727 error_defined_variable (SCM symbol
)
2729 /* We use the 'unbound-variable' key here as well, since it
2730 basically is the same kind of error, with a slight variation in
2731 the displayed message.
2733 scm_error (scm_unbound_variable_key
, NULL
,
2734 "Variable used before given a value: ~S",
2735 scm_list_1 (symbol
), SCM_BOOL_F
);
2739 /* The Lookup Car Race
2742 Memoization of variables and special forms is done while executing
2743 the code for the first time. As long as there is only one thread
2744 everything is fine, but as soon as two threads execute the same
2745 code concurrently `for the first time' they can come into conflict.
2747 This memoization includes rewriting variable references into more
2748 efficient forms and expanding macros. Furthermore, macro expansion
2749 includes `compiling' special forms like `let', `cond', etc. into
2750 tree-code instructions.
2752 There shouldn't normally be a problem with memoizing local and
2753 global variable references (into ilocs and variables), because all
2754 threads will mutate the code in *exactly* the same way and (if I
2755 read the C code correctly) it is not possible to observe a half-way
2756 mutated cons cell. The lookup procedure can handle this
2757 transparently without any critical sections.
2759 It is different with macro expansion, because macro expansion
2760 happens outside of the lookup procedure and can't be
2761 undone. Therefore the lookup procedure can't cope with it. It has
2762 to indicate failure when it detects a lost race and hope that the
2763 caller can handle it. Luckily, it turns out that this is the case.
2765 An example to illustrate this: Suppose that the following form will
2766 be memoized concurrently by two threads
2770 Let's first examine the lookup of X in the body. The first thread
2771 decides that it has to find the symbol "x" in the environment and
2772 starts to scan it. Then the other thread takes over and actually
2773 overtakes the first. It looks up "x" and substitutes an
2774 appropriate iloc for it. Now the first thread continues and
2775 completes its lookup. It comes to exactly the same conclusions as
2776 the second one and could - without much ado - just overwrite the
2777 iloc with the same iloc.
2779 But let's see what will happen when the race occurs while looking
2780 up the symbol "let" at the start of the form. It could happen that
2781 the second thread interrupts the lookup of the first thread and not
2782 only substitutes a variable for it but goes right ahead and
2783 replaces it with the compiled form (#@let* (x 12) x). Now, when
2784 the first thread completes its lookup, it would replace the #@let*
2785 with a variable containing the "let" binding, effectively reverting
2786 the form to (let (x 12) x). This is wrong. It has to detect that
2787 it has lost the race and the evaluator has to reconsider the
2788 changed form completely.
2790 This race condition could be resolved with some kind of traffic
2791 light (like mutexes) around scm_lookupcar, but I think that it is
2792 best to avoid them in this case. They would serialize memoization
2793 completely and because lookup involves calling arbitrary Scheme
2794 code (via the lookup-thunk), threads could be blocked for an
2795 arbitrary amount of time or even deadlock. But with the current
2796 solution a lot of unnecessary work is potentially done. */
2798 /* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
2799 return NULL to indicate a failed lookup due to some race conditions
2800 between threads. This only happens when VLOC is the first cell of
2801 a special form that will eventually be memoized (like `let', etc.)
2802 In that case the whole lookup is bogus and the caller has to
2803 reconsider the complete special form.
2805 SCM_LOOKUPCAR is still there, of course. It just calls
2806 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
2807 should only be called when it is known that VLOC is not the first
2808 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
2809 for NULL. I think I've found the only places where this
2813 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
2816 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
2817 register SCM iloc
= SCM_ILOC00
;
2818 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
2820 if (!scm_is_pair (SCM_CAR (env
)))
2822 al
= SCM_CARLOC (env
);
2823 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
2825 if (!scm_is_pair (fl
))
2827 if (scm_is_eq (fl
, var
))
2829 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2831 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
2832 return SCM_CDRLOC (*al
);
2837 al
= SCM_CDRLOC (*al
);
2838 if (scm_is_eq (SCM_CAR (fl
), var
))
2840 if (SCM_UNBNDP (SCM_CAR (*al
)))
2841 error_defined_variable (var
);
2842 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2844 SCM_SETCAR (vloc
, iloc
);
2845 return SCM_CARLOC (*al
);
2847 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
2849 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
2852 SCM top_thunk
, real_var
;
2855 top_thunk
= SCM_CAR (env
); /* env now refers to a
2856 top level env thunk */
2857 env
= SCM_CDR (env
);
2860 top_thunk
= SCM_BOOL_F
;
2861 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
2862 if (scm_is_false (real_var
))
2865 if (!scm_is_null (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
2870 if (scm_is_null (env
))
2871 error_unbound_variable (var
);
2873 scm_misc_error (NULL
, "Damaged environment: ~S",
2878 /* A variable could not be found, but we shall
2879 not throw an error. */
2880 static SCM undef_object
= SCM_UNDEFINED
;
2881 return &undef_object
;
2885 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2887 /* Some other thread has changed the very cell we are working
2888 on. In effect, it must have done our job or messed it up
2891 var
= SCM_CAR (vloc
);
2892 if (SCM_VARIABLEP (var
))
2893 return SCM_VARIABLE_LOC (var
);
2894 if (SCM_ILOCP (var
))
2895 return scm_ilookup (var
, genv
);
2896 /* We can't cope with anything else than variables and ilocs. When
2897 a special form has been memoized (i.e. `let' into `#@let') we
2898 return NULL and expect the calling function to do the right
2899 thing. For the evaluator, this means going back and redoing
2900 the dispatch on the car of the form. */
2904 SCM_SETCAR (vloc
, real_var
);
2905 return SCM_VARIABLE_LOC (real_var
);
2910 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
2912 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
2919 /* During execution, look up a symbol in the top level of the given local
2920 * environment and return the corresponding variable object. If no binding
2921 * for the symbol can be found, an 'Unbound variable' error is signalled. */
2923 lazy_memoize_variable (const SCM symbol
, const SCM environment
)
2925 const SCM top_level
= scm_env_top_level (environment
);
2926 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
2928 if (scm_is_false (variable
))
2929 error_unbound_variable (symbol
);
2936 scm_eval_car (SCM pair
, SCM env
)
2938 return SCM_I_XEVALCAR (pair
, env
, scm_debug_mode_p
);
2943 scm_eval_body (SCM code
, SCM env
)
2948 next
= SCM_CDR (code
);
2949 while (!scm_is_null (next
))
2951 if (SCM_IMP (SCM_CAR (code
)))
2953 if (SCM_ISYMP (SCM_CAR (code
)))
2955 scm_dynwind_begin (0);
2956 scm_i_dynwind_pthread_mutex_lock (&source_mutex
);
2957 /* check for race condition */
2958 if (SCM_ISYMP (SCM_CAR (code
)))
2959 m_expand_body (code
, env
);
2965 SCM_I_XEVAL (SCM_CAR (code
), env
, scm_debug_mode_p
);
2967 next
= SCM_CDR (code
);
2969 return SCM_I_XEVALCAR (code
, env
, scm_debug_mode_p
);
2973 /* scm_last_debug_frame contains a pointer to the last debugging information
2974 * stack frame. It is accessed very often from the debugging evaluator, so it
2975 * should probably not be indirectly addressed. Better to save and restore it
2976 * from the current root at any stack swaps.
2979 /* scm_debug_eframe_size is the number of slots available for pseudo
2980 * stack frames at each real stack frame.
2983 long scm_debug_eframe_size
;
2985 int scm_debug_mode_p
;
2986 int scm_check_entry_p
;
2987 int scm_check_apply_p
;
2988 int scm_check_exit_p
;
2989 int scm_check_memoize_p
;
2991 long scm_eval_stack
;
2993 scm_t_option scm_eval_opts
[] = {
2994 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." },
2998 scm_t_option scm_debug_opts
[] = {
2999 { SCM_OPTION_BOOLEAN
, "cheap", 1,
3000 "*This option is now obsolete. Setting it has no effect." },
3001 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
3002 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
3003 { SCM_OPTION_BOOLEAN
, "procnames", 1,
3004 "Record procedure names at definition." },
3005 { SCM_OPTION_BOOLEAN
, "backwards", 0,
3006 "Display backtrace in anti-chronological order." },
3007 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
3008 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
3009 { SCM_OPTION_INTEGER
, "frames", 3,
3010 "Maximum number of tail-recursive frames in backtrace." },
3011 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
3012 "Maximal number of stored backtrace frames." },
3013 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
3014 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
3015 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
3016 /* This default stack limit will be overridden by debug.c:init_stack_limit(),
3017 if we have getrlimit() and the stack limit is not INFINITY. But it is still
3018 important, as some systems have both the soft and the hard limits set to
3019 INFINITY; in that case we fall back to this value.
3021 The situation is aggravated by certain compilers, which can consume
3022 "beaucoup de stack", as they say in France.
3024 See http://thread.gmane.org/gmane.lisp.guile.devel/8599/focus=8662 for
3025 more discussion. This setting is 640 KB on 32-bit arches (should be enough
3026 for anyone!) or a whoppin' 1280 KB on 64-bit arches.
3028 { SCM_OPTION_INTEGER
, "stack", 160000, "Stack size limit (measured in words; 0 = no check)." },
3029 { SCM_OPTION_SCM
, "show-file-name", (unsigned long)SCM_BOOL_T
,
3030 "Show file names and line numbers "
3031 "in backtraces when not `#f'. A value of `base' "
3032 "displays only base names, while `#t' displays full names."},
3033 { SCM_OPTION_BOOLEAN
, "warn-deprecated", 0,
3034 "Warn when deprecated features are used." },
3040 * this ordering is awkward and illogical, but we maintain it for
3041 * compatibility. --hwn
3043 scm_t_option scm_evaluator_trap_table
[] = {
3044 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
3045 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
3046 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
3047 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
3048 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
3049 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
3050 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." },
3051 { SCM_OPTION_BOOLEAN
, "memoize-symbol", 0, "Trap when memoizing a symbol." },
3052 { SCM_OPTION_SCM
, "memoize-symbol-handler", (unsigned long)SCM_BOOL_F
, "The handler for memoization." },
3057 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
3059 "Option interface for the evaluation options. Instead of using\n"
3060 "this procedure directly, use the procedures @code{eval-enable},\n"
3061 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
3062 #define FUNC_NAME s_scm_eval_options_interface
3066 scm_dynwind_begin (0);
3067 scm_dynwind_critical_section (SCM_BOOL_F
);
3068 ans
= scm_options (setting
,
3071 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
3079 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
3081 "Option interface for the evaluator trap options.")
3082 #define FUNC_NAME s_scm_evaluator_traps
3087 scm_options_try (setting
,
3088 scm_evaluator_trap_table
,
3090 SCM_CRITICAL_SECTION_START
;
3091 ans
= scm_options (setting
,
3092 scm_evaluator_trap_table
,
3095 /* njrev: same again. */
3096 SCM_RESET_DEBUG_MODE
;
3097 SCM_CRITICAL_SECTION_END
;
3106 /* Simple procedure calls
3110 scm_call_0 (SCM proc
)
3112 if (SCM_PROGRAM_P (proc
))
3113 return scm_c_vm_run (scm_the_vm (), proc
, NULL
, 0);
3115 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
3119 scm_call_1 (SCM proc
, SCM arg1
)
3121 if (SCM_PROGRAM_P (proc
))
3122 return scm_c_vm_run (scm_the_vm (), proc
, &arg1
, 1);
3124 return scm_apply (proc
, arg1
, scm_listofnull
);
3128 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
3130 if (SCM_PROGRAM_P (proc
))
3132 SCM args
[] = { arg1
, arg2
};
3133 return scm_c_vm_run (scm_the_vm (), proc
, args
, 2);
3136 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
3140 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
3142 if (SCM_PROGRAM_P (proc
))
3144 SCM args
[] = { arg1
, arg2
, arg3
};
3145 return scm_c_vm_run (scm_the_vm (), proc
, args
, 3);
3148 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
3152 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
3154 if (SCM_PROGRAM_P (proc
))
3156 SCM args
[] = { arg1
, arg2
, arg3
, arg4
};
3157 return scm_c_vm_run (scm_the_vm (), proc
, args
, 4);
3160 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
3161 scm_cons (arg4
, scm_listofnull
)));
3164 /* Simple procedure applies
3168 scm_apply_0 (SCM proc
, SCM args
)
3170 return scm_apply (proc
, args
, SCM_EOL
);
3174 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
3176 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
3180 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
3182 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
3186 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
3188 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
3192 /* This code processes the arguments to apply:
3194 (apply PROC ARG1 ... ARGS)
3196 Given a list (ARG1 ... ARGS), this function conses the ARG1
3197 ... arguments onto the front of ARGS, and returns the resulting
3198 list. Note that ARGS is a list; thus, the argument to this
3199 function is a list whose last element is a list.
3201 Apply calls this function, and applies PROC to the elements of the
3202 result. apply:nconc2last takes care of building the list of
3203 arguments, given (ARG1 ... ARGS).
3205 Rather than do new consing, apply:nconc2last destroys its argument.
3206 On that topic, this code came into my care with the following
3207 beautifully cryptic comment on that topic: "This will only screw
3208 you if you do (scm_apply scm_apply '( ... ))" If you know what
3209 they're referring to, send me a patch to this comment. */
3211 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3213 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
3214 "conses the @var{arg1} @dots{} arguments onto the front of\n"
3215 "@var{args}, and returns the resulting list. Note that\n"
3216 "@var{args} is a list; thus, the argument to this function is\n"
3217 "a list whose last element is a list.\n"
3218 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
3219 "destroys its argument, so use with care.")
3220 #define FUNC_NAME s_scm_nconc2last
3223 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
3225 while (!scm_is_null (SCM_CDR (*lloc
))) /* Perhaps should be
3226 SCM_NULL_OR_NIL_P, but not
3227 needed in 99.99% of cases,
3228 and it could seriously hurt
3229 performance. - Neil */
3230 lloc
= SCM_CDRLOC (*lloc
);
3231 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3232 *lloc
= SCM_CAR (*lloc
);
3239 /* SECTION: The rest of this file is only read once.
3244 * Trampolines make it possible to move procedure application dispatch
3245 * outside inner loops. The motivation was clean implementation of
3246 * efficient replacements of R5RS primitives in SRFI-1.
3248 * The semantics is clear: scm_trampoline_N returns an optimized
3249 * version of scm_call_N (or NULL if the procedure isn't applicable
3252 * Applying the optimization to map and for-each increased efficiency
3253 * noticeably. For example, (map abs ls) is now 8 times faster than
3258 call_subr0_0 (SCM proc
)
3260 return SCM_SUBRF (proc
) ();
3264 call_subr1o_0 (SCM proc
)
3266 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
3270 call_lsubr_0 (SCM proc
)
3272 return SCM_SUBRF (proc
) (SCM_EOL
);
3276 scm_i_call_closure_0 (SCM proc
)
3278 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3281 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
3286 scm_trampoline_0 (SCM proc
)
3288 scm_t_trampoline_0 trampoline
;
3293 switch (SCM_TYP7 (proc
))
3295 case scm_tc7_subr_0
:
3296 trampoline
= call_subr0_0
;
3298 case scm_tc7_subr_1o
:
3299 trampoline
= call_subr1o_0
;
3302 trampoline
= call_lsubr_0
;
3304 case scm_tcs_closures
:
3306 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3307 if (scm_is_null (formals
) || !scm_is_pair (formals
))
3308 trampoline
= scm_i_call_closure_0
;
3313 case scm_tcs_struct
:
3314 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3315 trampoline
= scm_call_generic_0
;
3316 else if (SCM_I_OPERATORP (proc
))
3317 trampoline
= scm_call_0
;
3322 if (SCM_SMOB_APPLICABLE_P (proc
))
3323 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
3328 case scm_tc7_rpsubr
:
3331 case scm_tc7_program
:
3332 trampoline
= scm_call_0
;
3335 return NULL
; /* not applicable on zero arguments */
3337 /* We only reach this point if a valid trampoline was determined. */
3339 /* If debugging is enabled, we want to see all calls to proc on the stack.
3340 * Thus, we replace the trampoline shortcut with scm_call_0. */
3341 if (scm_debug_mode_p
)
3348 call_subr1_1 (SCM proc
, SCM arg1
)
3350 return SCM_SUBRF (proc
) (arg1
);
3354 call_subr2o_1 (SCM proc
, SCM arg1
)
3356 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
3360 call_lsubr_1 (SCM proc
, SCM arg1
)
3362 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
3366 call_dsubr_1 (SCM proc
, SCM arg1
)
3368 if (SCM_I_INUMP (arg1
))
3370 return (scm_from_double (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
))));
3372 else if (SCM_REALP (arg1
))
3374 return (scm_from_double (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3376 else if (SCM_BIGP (arg1
))
3378 return (scm_from_double (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3380 else if (SCM_FRACTIONP (arg1
))
3382 return (scm_from_double (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
3384 SCM_WTA_DISPATCH_1_SUBR (proc
, arg1
, SCM_ARG1
);
3388 call_cxr_1 (SCM proc
, SCM arg1
)
3390 return scm_i_chase_pairs (arg1
, (scm_t_bits
) SCM_SUBRF (proc
));
3394 call_closure_1 (SCM proc
, SCM arg1
)
3396 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3399 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
3404 scm_trampoline_1 (SCM proc
)
3406 scm_t_trampoline_1 trampoline
;
3411 switch (SCM_TYP7 (proc
))
3413 case scm_tc7_subr_1
:
3414 case scm_tc7_subr_1o
:
3415 trampoline
= call_subr1_1
;
3417 case scm_tc7_subr_2o
:
3418 trampoline
= call_subr2o_1
;
3421 trampoline
= call_lsubr_1
;
3424 trampoline
= call_dsubr_1
;
3427 trampoline
= call_cxr_1
;
3429 case scm_tcs_closures
:
3431 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3432 if (!scm_is_null (formals
)
3433 && (!scm_is_pair (formals
) || !scm_is_pair (SCM_CDR (formals
))))
3434 trampoline
= call_closure_1
;
3439 case scm_tcs_struct
:
3440 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3441 trampoline
= scm_call_generic_1
;
3442 else if (SCM_I_OPERATORP (proc
))
3443 trampoline
= scm_call_1
;
3448 if (SCM_SMOB_APPLICABLE_P (proc
))
3449 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
3454 case scm_tc7_rpsubr
:
3457 case scm_tc7_program
:
3458 trampoline
= scm_call_1
;
3461 return NULL
; /* not applicable on one arg */
3463 /* We only reach this point if a valid trampoline was determined. */
3465 /* If debugging is enabled, we want to see all calls to proc on the stack.
3466 * Thus, we replace the trampoline shortcut with scm_call_1. */
3467 if (scm_debug_mode_p
)
3474 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
3476 return SCM_SUBRF (proc
) (arg1
, arg2
);
3480 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
3482 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
3486 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
3488 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
3492 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
3494 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3495 scm_list_2 (arg1
, arg2
),
3497 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
3502 scm_trampoline_2 (SCM proc
)
3504 scm_t_trampoline_2 trampoline
;
3509 switch (SCM_TYP7 (proc
))
3511 case scm_tc7_subr_2
:
3512 case scm_tc7_subr_2o
:
3513 case scm_tc7_rpsubr
:
3515 trampoline
= call_subr2_2
;
3517 case scm_tc7_lsubr_2
:
3518 trampoline
= call_lsubr2_2
;
3521 trampoline
= call_lsubr_2
;
3523 case scm_tcs_closures
:
3525 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3526 if (!scm_is_null (formals
)
3527 && (!scm_is_pair (formals
)
3528 || (!scm_is_null (SCM_CDR (formals
))
3529 && (!scm_is_pair (SCM_CDR (formals
))
3530 || !scm_is_pair (SCM_CDDR (formals
))))))
3531 trampoline
= call_closure_2
;
3536 case scm_tcs_struct
:
3537 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3538 trampoline
= scm_call_generic_2
;
3539 else if (SCM_I_OPERATORP (proc
))
3540 trampoline
= scm_call_2
;
3545 if (SCM_SMOB_APPLICABLE_P (proc
))
3546 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
3552 case scm_tc7_program
:
3553 trampoline
= scm_call_2
;
3556 return NULL
; /* not applicable on two args */
3558 /* We only reach this point if a valid trampoline was determined. */
3560 /* If debugging is enabled, we want to see all calls to proc on the stack.
3561 * Thus, we replace the trampoline shortcut with scm_call_2. */
3562 if (scm_debug_mode_p
)
3568 /* Typechecking for multi-argument MAP and FOR-EACH.
3570 Verify that each element of the vector ARGV, except for the first,
3571 is a proper list whose length is LEN. Attribute errors to WHO,
3572 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3574 check_map_args (SCM argv
,
3583 for (i
= SCM_SIMPLE_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
3585 SCM elt
= SCM_SIMPLE_VECTOR_REF (argv
, i
);
3586 long elt_len
= scm_ilength (elt
);
3591 scm_apply_generic (gf
, scm_cons (proc
, args
));
3593 scm_wrong_type_arg (who
, i
+ 2, elt
);
3597 scm_out_of_range_pos (who
, elt
, scm_from_long (i
+ 2));
3602 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3604 /* Note: Currently, scm_map applies PROC to the argument list(s)
3605 sequentially, starting with the first element(s). This is used in
3606 evalext.c where the Scheme procedure `map-in-order', which guarantees
3607 sequential behaviour, is implemented using scm_map. If the
3608 behaviour changes, we need to update `map-in-order'.
3612 scm_map (SCM proc
, SCM arg1
, SCM args
)
3613 #define FUNC_NAME s_map
3619 len
= scm_ilength (arg1
);
3620 SCM_GASSERTn (len
>= 0,
3621 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
3622 SCM_VALIDATE_REST_ARGUMENT (args
);
3623 if (scm_is_null (args
))
3625 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
3626 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
3627 while (SCM_NIMP (arg1
))
3629 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
3630 pres
= SCM_CDRLOC (*pres
);
3631 arg1
= SCM_CDR (arg1
);
3635 if (scm_is_null (SCM_CDR (args
)))
3637 SCM arg2
= SCM_CAR (args
);
3638 int len2
= scm_ilength (arg2
);
3639 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
3641 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
3642 SCM_GASSERTn (len2
>= 0,
3643 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
3645 SCM_OUT_OF_RANGE (3, arg2
);
3646 while (SCM_NIMP (arg1
))
3648 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
3649 pres
= SCM_CDRLOC (*pres
);
3650 arg1
= SCM_CDR (arg1
);
3651 arg2
= SCM_CDR (arg2
);
3655 arg1
= scm_cons (arg1
, args
);
3656 args
= scm_vector (arg1
);
3657 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
3661 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3663 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
3666 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
3667 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
3669 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
3670 pres
= SCM_CDRLOC (*pres
);
3676 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
3679 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
3680 #define FUNC_NAME s_for_each
3683 len
= scm_ilength (arg1
);
3684 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
3685 SCM_ARG2
, s_for_each
);
3686 SCM_VALIDATE_REST_ARGUMENT (args
);
3687 if (scm_is_null (args
))
3689 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
3690 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
3691 while (SCM_NIMP (arg1
))
3693 call (proc
, SCM_CAR (arg1
));
3694 arg1
= SCM_CDR (arg1
);
3696 return SCM_UNSPECIFIED
;
3698 if (scm_is_null (SCM_CDR (args
)))
3700 SCM arg2
= SCM_CAR (args
);
3701 int len2
= scm_ilength (arg2
);
3702 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
3703 SCM_GASSERTn (call
, g_for_each
,
3704 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
3705 SCM_GASSERTn (len2
>= 0, g_for_each
,
3706 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
3708 SCM_OUT_OF_RANGE (3, arg2
);
3709 while (SCM_NIMP (arg1
))
3711 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
3712 arg1
= SCM_CDR (arg1
);
3713 arg2
= SCM_CDR (arg2
);
3715 return SCM_UNSPECIFIED
;
3717 arg1
= scm_cons (arg1
, args
);
3718 args
= scm_vector (arg1
);
3719 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
3723 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3725 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
3727 return SCM_UNSPECIFIED
;
3728 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
3729 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
3731 scm_apply (proc
, arg1
, SCM_EOL
);
3738 scm_closure (SCM code
, SCM env
)
3741 SCM closcar
= scm_cons (code
, SCM_EOL
);
3742 z
= scm_immutable_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
,
3744 scm_remember_upto_here (closcar
);
3749 scm_t_bits scm_tc16_promise
;
3751 SCM_DEFINE (scm_make_promise
, "make-promise", 1, 0, 0,
3753 "Create a new promise object.\n\n"
3754 "@code{make-promise} is a procedural form of @code{delay}.\n"
3755 "These two expressions are equivalent:\n"
3757 "(delay @var{exp})\n"
3758 "(make-promise (lambda () @var{exp}))\n"
3760 #define FUNC_NAME s_scm_make_promise
3762 SCM_VALIDATE_THUNK (1, thunk
);
3763 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
3765 scm_make_recursive_mutex ());
3771 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
3773 int writingp
= SCM_WRITINGP (pstate
);
3774 scm_puts ("#<promise ", port
);
3775 SCM_SET_WRITINGP (pstate
, 1);
3776 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
3777 SCM_SET_WRITINGP (pstate
, writingp
);
3778 scm_putc ('>', port
);
3782 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
3784 "If the promise @var{x} has not been computed yet, compute and\n"
3785 "return @var{x}, otherwise just return the previously computed\n"
3787 #define FUNC_NAME s_scm_force
3789 SCM_VALIDATE_SMOB (1, promise
, promise
);
3790 scm_lock_mutex (SCM_PROMISE_MUTEX (promise
));
3791 if (!SCM_PROMISE_COMPUTED_P (promise
))
3793 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
3794 if (!SCM_PROMISE_COMPUTED_P (promise
))
3796 SCM_SET_PROMISE_DATA (promise
, ans
);
3797 SCM_SET_PROMISE_COMPUTED (promise
);
3800 scm_unlock_mutex (SCM_PROMISE_MUTEX (promise
));
3801 return SCM_PROMISE_DATA (promise
);
3806 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
3808 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
3809 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
3810 #define FUNC_NAME s_scm_promise_p
3812 return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
3817 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
3818 (SCM xorig
, SCM x
, SCM y
),
3819 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
3820 "Any source properties associated with @var{xorig} are also associated\n"
3821 "with the new pair.")
3822 #define FUNC_NAME s_scm_cons_source
3825 z
= scm_cons (x
, y
);
3826 /* Copy source properties possibly associated with xorig. */
3827 p
= scm_whash_lookup (scm_source_whash
, xorig
);
3828 if (scm_is_true (p
))
3829 scm_whash_insert (scm_source_whash
, z
, p
);
3835 /* The function scm_copy_tree is used to copy an expression tree to allow the
3836 * memoizer to modify the expression during memoization. scm_copy_tree
3837 * creates deep copies of pairs and vectors, but not of any other data types,
3838 * since only pairs and vectors will be parsed by the memoizer.
3840 * To avoid infinite recursion due to cyclic structures, the hare-and-tortoise
3841 * pattern is used to detect cycles. In fact, the pattern is used in two
3842 * dimensions, vertical (indicated in the code by the variable names 'hare'
3843 * and 'tortoise') and horizontal ('rabbit' and 'turtle'). In both
3844 * dimensions, the hare/rabbit will take two steps when the tortoise/turtle
3847 * The vertical dimension corresponds to recursive calls to function
3848 * copy_tree: This happens when descending into vector elements, into cars of
3849 * lists and into the cdr of an improper list. In this dimension, the
3850 * tortoise follows the hare by using the processor stack: Every stack frame
3851 * will hold an instance of struct t_trace. These instances are connected in
3852 * a way that represents the trace of the hare, which thus can be followed by
3853 * the tortoise. The tortoise will always point to struct t_trace instances
3854 * relating to SCM objects that have already been copied. Thus, a cycle is
3855 * detected if the tortoise and the hare point to the same object,
3857 * The horizontal dimension is within one execution of copy_tree, when the
3858 * function cdr's along the pairs of a list. This is the standard
3859 * hare-and-tortoise implementation, found several times in guile. */
3862 struct t_trace
*trace
; /* These pointers form a trace along the stack. */
3863 SCM obj
; /* The object handled at the respective stack frame.*/
3868 struct t_trace
*const hare
,
3869 struct t_trace
*tortoise
,
3870 unsigned int tortoise_delay
)
3872 if (!scm_is_pair (hare
->obj
) && !scm_is_simple_vector (hare
->obj
))
3878 /* Prepare the trace along the stack. */
3879 struct t_trace new_hare
;
3880 hare
->trace
= &new_hare
;
3882 /* The tortoise will make its step after the delay has elapsed. Note
3883 * that in contrast to the typical hare-and-tortoise pattern, the step
3884 * of the tortoise happens before the hare takes its steps. This is, in
3885 * principle, no problem, except for the start of the algorithm: Then,
3886 * it has to be made sure that the hare actually gets its advantage of
3888 if (tortoise_delay
== 0)
3891 tortoise
= tortoise
->trace
;
3892 ASSERT_SYNTAX (!scm_is_eq (hare
->obj
, tortoise
->obj
),
3893 s_bad_expression
, hare
->obj
);
3900 if (scm_is_simple_vector (hare
->obj
))
3902 size_t length
= SCM_SIMPLE_VECTOR_LENGTH (hare
->obj
);
3903 SCM new_vector
= scm_c_make_vector (length
, SCM_UNSPECIFIED
);
3905 /* Each vector element is copied by recursing into copy_tree, having
3906 * the tortoise follow the hare into the depths of the stack. */
3907 unsigned long int i
;
3908 for (i
= 0; i
< length
; ++i
)
3911 new_hare
.obj
= SCM_SIMPLE_VECTOR_REF (hare
->obj
, i
);
3912 new_element
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3913 SCM_SIMPLE_VECTOR_SET (new_vector
, i
, new_element
);
3918 else /* scm_is_pair (hare->obj) */
3923 SCM rabbit
= hare
->obj
;
3924 SCM turtle
= hare
->obj
;
3928 /* The first pair of the list is treated specially, in order to
3929 * preserve a potential source code position. */
3930 result
= tail
= scm_cons_source (rabbit
, SCM_EOL
, SCM_EOL
);
3931 new_hare
.obj
= SCM_CAR (rabbit
);
3932 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3933 SCM_SETCAR (tail
, copy
);
3935 /* The remaining pairs of the list are copied by, horizontally,
3936 * having the turtle follow the rabbit, and, vertically, having the
3937 * tortoise follow the hare into the depths of the stack. */
3938 rabbit
= SCM_CDR (rabbit
);
3939 while (scm_is_pair (rabbit
))
3941 new_hare
.obj
= SCM_CAR (rabbit
);
3942 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3943 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
3944 tail
= SCM_CDR (tail
);
3946 rabbit
= SCM_CDR (rabbit
);
3947 if (scm_is_pair (rabbit
))
3949 new_hare
.obj
= SCM_CAR (rabbit
);
3950 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3951 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
3952 tail
= SCM_CDR (tail
);
3953 rabbit
= SCM_CDR (rabbit
);
3955 turtle
= SCM_CDR (turtle
);
3956 ASSERT_SYNTAX (!scm_is_eq (rabbit
, turtle
),
3957 s_bad_expression
, rabbit
);
3961 /* We have to recurse into copy_tree again for the last cdr, in
3962 * order to handle the situation that it holds a vector. */
3963 new_hare
.obj
= rabbit
;
3964 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3965 SCM_SETCDR (tail
, copy
);
3972 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
3974 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
3975 "the new data structure. @code{copy-tree} recurses down the\n"
3976 "contents of both pairs and vectors (since both cons cells and vector\n"
3977 "cells may point to arbitrary objects), and stops recursing when it hits\n"
3978 "any other object.")
3979 #define FUNC_NAME s_scm_copy_tree
3981 /* Prepare the trace along the stack. */
3982 struct t_trace trace
;
3985 /* In function copy_tree, if the tortoise makes its step, it will do this
3986 * before the hare has the chance to move. Thus, we have to make sure that
3987 * the very first step of the tortoise will not happen after the hare has
3988 * really made two steps. This is achieved by passing '2' as the initial
3989 * delay for the tortoise. NOTE: Since cycles are unlikely, giving the hare
3990 * a bigger advantage may improve performance slightly. */
3991 return copy_tree (&trace
, &trace
, 2);
3996 /* We have three levels of EVAL here:
3998 - scm_i_eval (exp, env)
4000 evaluates EXP in environment ENV. ENV is a lexical environment
4001 structure as used by the actual tree code evaluator. When ENV is
4002 a top-level environment, then changes to the current module are
4003 tracked by updating ENV so that it continues to be in sync with
4006 - scm_primitive_eval (exp)
4008 evaluates EXP in the top-level environment as determined by the
4009 current module. This is done by constructing a suitable
4010 environment and calling scm_i_eval. Thus, changes to the
4011 top-level module are tracked normally.
4013 - scm_eval (exp, mod_or_state)
4015 evaluates EXP while MOD_OR_STATE is the current module or current
4016 dynamic state (as appropriate). This is done by setting the
4017 current module (or dynamic state) to MOD_OR_STATE, invoking
4018 scm_primitive_eval on EXP, and then restoring the current module
4019 (or dynamic state) to the value it had previously. That is,
4020 while EXP is evaluated, changes to the current module (or dynamic
4021 state) are tracked, but these changes do not persist when
4024 For each level of evals, there are two variants, distinguished by a
4025 _x suffix: the ordinary variant does not modify EXP while the _x
4026 variant can destructively modify EXP into something completely
4027 unintelligible. A Scheme data structure passed as EXP to one of the
4028 _x variants should not ever be used again for anything. So when in
4029 doubt, use the ordinary variant.
4034 scm_i_eval_x (SCM exp
, SCM env
)
4036 if (scm_is_symbol (exp
))
4037 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
4039 return SCM_I_XEVAL (exp
, env
, scm_debug_mode_p
);
4043 scm_i_eval (SCM exp
, SCM env
)
4045 exp
= scm_copy_tree (exp
);
4046 if (scm_is_symbol (exp
))
4047 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
4049 return SCM_I_XEVAL (exp
, env
, scm_debug_mode_p
);
4053 scm_primitive_eval_x (SCM exp
)
4056 SCM transformer
= scm_current_module_transformer ();
4057 if (SCM_NIMP (transformer
))
4058 exp
= scm_call_1 (transformer
, exp
);
4059 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4060 return scm_i_eval_x (exp
, env
);
4063 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
4065 "Evaluate @var{exp} in the top-level environment specified by\n"
4066 "the current module.")
4067 #define FUNC_NAME s_scm_primitive_eval
4070 SCM transformer
= scm_current_module_transformer ();
4071 if (scm_is_true (transformer
))
4072 exp
= scm_call_1 (transformer
, exp
);
4073 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4074 return scm_i_eval (exp
, env
);
4079 /* Eval does not take the second arg optionally. This is intentional
4080 * in order to be R5RS compatible, and to prepare for the new module
4081 * system, where we would like to make the choice of evaluation
4082 * environment explicit. */
4085 scm_eval_x (SCM exp
, SCM module_or_state
)
4089 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
4090 if (scm_is_dynamic_state (module_or_state
))
4091 scm_dynwind_current_dynamic_state (module_or_state
);
4093 scm_dynwind_current_module (module_or_state
);
4095 res
= scm_primitive_eval_x (exp
);
4101 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
4102 (SCM exp
, SCM module_or_state
),
4103 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
4104 "in the top-level environment specified by\n"
4105 "@var{module_or_state}.\n"
4106 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
4107 "@var{module_or_state} is made the current module when\n"
4108 "it is a module, or the current dynamic state when it is\n"
4110 "Example: (eval '(+ 1 2) (interaction-environment))")
4111 #define FUNC_NAME s_scm_eval
4115 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
4116 if (scm_is_dynamic_state (module_or_state
))
4117 scm_dynwind_current_dynamic_state (module_or_state
);
4118 else if (scm_module_system_booted_p
)
4120 SCM_VALIDATE_MODULE (2, module_or_state
);
4121 scm_dynwind_current_module (module_or_state
);
4123 /* otherwise if the module system isn't booted, ignore the module arg */
4125 res
= scm_primitive_eval (exp
);
4133 /* At this point, deval and scm_dapply are generated.
4145 scm_i_pthread_mutex_init (&source_mutex
,
4146 scm_i_pthread_mutexattr_recursive
);
4148 scm_init_opts (scm_evaluator_traps
,
4149 scm_evaluator_trap_table
);
4150 scm_init_opts (scm_eval_options_interface
,
4153 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
4154 scm_set_smob_print (scm_tc16_promise
, promise_print
);
4156 undefineds
= scm_list_1 (SCM_UNDEFINED
);
4157 SCM_SETCDR (undefineds
, undefineds
);
4158 scm_permanent_object (undefineds
);
4160 scm_listofnull
= scm_list_1 (SCM_EOL
);
4162 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
4163 scm_permanent_object (f_apply
);
4165 #include "libguile/eval.x"
4167 scm_add_feature ("delay");