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 m_expand_body (const SCM forms
, const SCM env
)
716 /* The first body form can be skipped since it is known to be the ISYM that
717 * was prepended to the body by m_body. */
718 SCM cdr_forms
= SCM_CDR (forms
);
719 SCM form_idx
= cdr_forms
;
720 SCM definitions
= SCM_EOL
;
721 SCM sequence
= SCM_EOL
;
723 /* According to R5RS, the list of body forms consists of two parts: a number
724 * (maybe zero) of definitions, followed by a non-empty sequence of
725 * expressions. Each the definitions and the expressions may be grouped
726 * arbitrarily with begin, but it is not allowed to mix definitions and
727 * expressions. The task of the following loop therefore is to split the
728 * list of body forms into the list of definitions and the sequence of
730 while (!scm_is_null (form_idx
))
732 const SCM form
= SCM_CAR (form_idx
);
733 const SCM new_form
= expand_user_macros (form
, env
);
734 if (is_system_macro_p (scm_sym_define
, new_form
, env
))
736 definitions
= scm_cons (new_form
, definitions
);
737 form_idx
= SCM_CDR (form_idx
);
739 else if (is_system_macro_p (scm_sym_begin
, new_form
, env
))
741 /* We have encountered a group of forms. This has to be either a
742 * (possibly empty) group of (possibly further grouped) definitions,
743 * or a non-empty group of (possibly further grouped)
745 const SCM grouped_forms
= SCM_CDR (new_form
);
746 unsigned int found_definition
= 0;
747 unsigned int found_expression
= 0;
748 SCM grouped_form_idx
= grouped_forms
;
749 while (!found_expression
&& !scm_is_null (grouped_form_idx
))
751 const SCM inner_form
= SCM_CAR (grouped_form_idx
);
752 const SCM new_inner_form
= expand_user_macros (inner_form
, env
);
753 if (is_system_macro_p (scm_sym_define
, new_inner_form
, env
))
755 found_definition
= 1;
756 definitions
= scm_cons (new_inner_form
, definitions
);
757 grouped_form_idx
= SCM_CDR (grouped_form_idx
);
759 else if (is_system_macro_p (scm_sym_begin
, new_inner_form
, env
))
761 const SCM inner_group
= SCM_CDR (new_inner_form
);
763 = scm_append (scm_list_2 (inner_group
,
764 SCM_CDR (grouped_form_idx
)));
768 /* The group marks the start of the expressions of the body.
769 * We have to make sure that within the same group we have
770 * not encountered a definition before. */
771 ASSERT_SYNTAX (!found_definition
, s_mixed_body_forms
, form
);
772 found_expression
= 1;
773 grouped_form_idx
= SCM_EOL
;
777 /* We have finished processing the group. If we have not yet
778 * encountered an expression we continue processing the forms of the
779 * body to collect further definition forms. Otherwise, the group
780 * marks the start of the sequence of expressions of the body. */
781 if (!found_expression
)
783 form_idx
= SCM_CDR (form_idx
);
793 /* We have detected a form which is no definition. This marks the
794 * start of the sequence of expressions of the body. */
800 /* FIXME: forms does not hold information about the file location. */
801 ASSERT_SYNTAX (scm_is_pair (sequence
), s_missing_body_expression
, cdr_forms
);
803 if (!scm_is_null (definitions
))
807 SCM letrec_expression
;
808 SCM new_letrec_expression
;
810 SCM bindings
= SCM_EOL
;
811 for (definition_idx
= definitions
;
812 !scm_is_null (definition_idx
);
813 definition_idx
= SCM_CDR (definition_idx
))
815 const SCM definition
= SCM_CAR (definition_idx
);
816 const SCM canonical_definition
= canonicalize_define (definition
);
817 const SCM binding
= SCM_CDR (canonical_definition
);
818 bindings
= scm_cons (binding
, bindings
);
821 letrec_tail
= scm_cons (bindings
, sequence
);
822 /* FIXME: forms does not hold information about the file location. */
823 letrec_expression
= scm_cons_source (forms
, scm_sym_letrec
, letrec_tail
);
824 new_letrec_expression
= scm_m_letrec (letrec_expression
, env
);
825 SCM_SETCAR (forms
, new_letrec_expression
);
826 SCM_SETCDR (forms
, SCM_EOL
);
830 SCM_SETCAR (forms
, SCM_CAR (sequence
));
831 SCM_SETCDR (forms
, SCM_CDR (sequence
));
836 macroexp (SCM x
, SCM env
)
838 SCM res
, proc
, orig_sym
;
840 /* Don't bother to produce error messages here. We get them when we
841 eventually execute the code for real. */
844 orig_sym
= SCM_CAR (x
);
845 if (!scm_is_symbol (orig_sym
))
849 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
850 if (proc_ptr
== NULL
)
852 /* We have lost the race. */
858 /* Only handle memoizing macros. `Acros' and `macros' are really
859 special forms and should not be evaluated here. */
861 if (!SCM_MACROP (proc
)
862 || (SCM_MACRO_TYPE (proc
) != 2 && !SCM_BUILTIN_MACRO_P (proc
)))
865 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
866 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
868 if (scm_ilength (res
) <= 0)
869 /* Result of expansion is not a list. */
870 return (scm_list_2 (SCM_IM_BEGIN
, res
));
873 /* njrev: Several queries here: (1) I don't see how it can be
874 correct that the SCM_SETCAR 2 lines below this comment needs
875 protection, but the SCM_SETCAR 6 lines above does not, so
876 something here is probably wrong. (2) macroexp() is now only
877 used in one place - scm_m_generalized_set_x - whereas all other
878 macro expansion happens through expand_user_macros. Therefore
879 (2.1) perhaps macroexp() could be eliminated completely now?
880 (2.2) Does expand_user_macros need any critical section
883 SCM_CRITICAL_SECTION_START
;
884 SCM_SETCAR (x
, SCM_CAR (res
));
885 SCM_SETCDR (x
, SCM_CDR (res
));
886 SCM_CRITICAL_SECTION_END
;
892 /* Start of the memoizers for the standard R5RS builtin macros. */
895 SCM_SYNTAX (s_and
, "and", scm_i_makbimacro
, scm_m_and
);
896 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
899 scm_m_and (SCM expr
, SCM env SCM_UNUSED
)
901 const SCM cdr_expr
= SCM_CDR (expr
);
902 const long length
= scm_ilength (cdr_expr
);
904 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
908 /* Special case: (and) is replaced by #t. */
913 SCM_SETCAR (expr
, SCM_IM_AND
);
919 unmemoize_and (const SCM expr
, const SCM env
)
921 return scm_cons (scm_sym_and
, unmemoize_exprs (SCM_CDR (expr
), env
));
925 SCM_SYNTAX (s_begin
, "begin", scm_i_makbimacro
, scm_m_begin
);
926 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
929 scm_m_begin (SCM expr
, SCM env SCM_UNUSED
)
931 const SCM cdr_expr
= SCM_CDR (expr
);
932 /* Dirk:FIXME:: An empty begin clause is not generally allowed by R5RS.
933 * That means, there should be a distinction between uses of begin where an
934 * empty clause is OK and where it is not. */
935 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
937 SCM_SETCAR (expr
, SCM_IM_BEGIN
);
942 unmemoize_begin (const SCM expr
, const SCM env
)
944 return scm_cons (scm_sym_begin
, unmemoize_exprs (SCM_CDR (expr
), env
));
948 SCM_SYNTAX (s_case
, "case", scm_i_makbimacro
, scm_m_case
);
949 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
950 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
953 scm_m_case (SCM expr
, SCM env
)
956 SCM all_labels
= SCM_EOL
;
958 /* Check, whether 'else is a literal, i. e. not bound to a value. */
959 const int else_literal_p
= literal_p (scm_sym_else
, env
);
961 const SCM cdr_expr
= SCM_CDR (expr
);
962 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
963 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_clauses
, expr
);
965 clauses
= SCM_CDR (cdr_expr
);
966 while (!scm_is_null (clauses
))
970 const SCM clause
= SCM_CAR (clauses
);
971 ASSERT_SYNTAX_2 (scm_ilength (clause
) >= 2,
972 s_bad_case_clause
, clause
, expr
);
974 labels
= SCM_CAR (clause
);
975 if (scm_is_pair (labels
))
977 ASSERT_SYNTAX_2 (scm_ilength (labels
) >= 0,
978 s_bad_case_labels
, labels
, expr
);
979 all_labels
= scm_append (scm_list_2 (labels
, all_labels
));
981 else if (scm_is_null (labels
))
983 /* The list of labels is empty. According to R5RS this is allowed.
984 * It means that the sequence of expressions will never be executed.
985 * Therefore, as an optimization, we could remove the whole
990 ASSERT_SYNTAX_2 (scm_is_eq (labels
, scm_sym_else
) && else_literal_p
,
991 s_bad_case_labels
, labels
, expr
);
992 ASSERT_SYNTAX_2 (scm_is_null (SCM_CDR (clauses
)),
993 s_misplaced_else_clause
, clause
, expr
);
996 /* build the new clause */
997 if (scm_is_eq (labels
, scm_sym_else
))
998 SCM_SETCAR (clause
, SCM_IM_ELSE
);
1000 clauses
= SCM_CDR (clauses
);
1003 /* Check whether all case labels are distinct. */
1004 for (; !scm_is_null (all_labels
); all_labels
= SCM_CDR (all_labels
))
1006 const SCM label
= SCM_CAR (all_labels
);
1007 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (label
, SCM_CDR (all_labels
))),
1008 s_duplicate_case_label
, label
, expr
);
1011 SCM_SETCAR (expr
, SCM_IM_CASE
);
1016 unmemoize_case (const SCM expr
, const SCM env
)
1018 const SCM um_key_expr
= unmemoize_expression (SCM_CADR (expr
), env
);
1019 SCM um_clauses
= SCM_EOL
;
1022 for (clause_idx
= SCM_CDDR (expr
);
1023 !scm_is_null (clause_idx
);
1024 clause_idx
= SCM_CDR (clause_idx
))
1026 const SCM clause
= SCM_CAR (clause_idx
);
1027 const SCM labels
= SCM_CAR (clause
);
1028 const SCM exprs
= SCM_CDR (clause
);
1030 const SCM um_exprs
= unmemoize_exprs (exprs
, env
);
1031 const SCM um_labels
= (scm_is_eq (labels
, SCM_IM_ELSE
))
1033 : scm_i_finite_list_copy (labels
);
1034 const SCM um_clause
= scm_cons (um_labels
, um_exprs
);
1036 um_clauses
= scm_cons (um_clause
, um_clauses
);
1038 um_clauses
= scm_reverse_x (um_clauses
, SCM_UNDEFINED
);
1040 return scm_cons2 (scm_sym_case
, um_key_expr
, um_clauses
);
1044 SCM_SYNTAX (s_cond
, "cond", scm_i_makbimacro
, scm_m_cond
);
1045 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
1046 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
1049 scm_m_cond (SCM expr
, SCM env
)
1051 /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
1052 const int else_literal_p
= literal_p (scm_sym_else
, env
);
1053 const int arrow_literal_p
= literal_p (scm_sym_arrow
, env
);
1055 const SCM clauses
= SCM_CDR (expr
);
1058 ASSERT_SYNTAX (scm_ilength (clauses
) >= 0, s_bad_expression
, expr
);
1059 ASSERT_SYNTAX (scm_ilength (clauses
) >= 1, s_missing_clauses
, expr
);
1061 for (clause_idx
= clauses
;
1062 !scm_is_null (clause_idx
);
1063 clause_idx
= SCM_CDR (clause_idx
))
1067 const SCM clause
= SCM_CAR (clause_idx
);
1068 const long length
= scm_ilength (clause
);
1069 ASSERT_SYNTAX_2 (length
>= 1, s_bad_cond_clause
, clause
, expr
);
1071 test
= SCM_CAR (clause
);
1072 if (scm_is_eq (test
, scm_sym_else
) && else_literal_p
)
1074 const int last_clause_p
= scm_is_null (SCM_CDR (clause_idx
));
1075 ASSERT_SYNTAX_2 (length
>= 2,
1076 s_bad_cond_clause
, clause
, expr
);
1077 ASSERT_SYNTAX_2 (last_clause_p
,
1078 s_misplaced_else_clause
, clause
, expr
);
1079 SCM_SETCAR (clause
, SCM_IM_ELSE
);
1081 else if (length
>= 2
1082 && scm_is_eq (SCM_CADR (clause
), scm_sym_arrow
)
1085 ASSERT_SYNTAX_2 (length
> 2, s_missing_recipient
, clause
, expr
);
1086 ASSERT_SYNTAX_2 (length
== 3, s_extra_expression
, clause
, expr
);
1087 SCM_SETCAR (SCM_CDR (clause
), SCM_IM_ARROW
);
1089 /* SRFI 61 extended cond */
1090 else if (length
>= 3
1091 && scm_is_eq (SCM_CADDR (clause
), scm_sym_arrow
)
1094 ASSERT_SYNTAX_2 (length
> 3, s_missing_recipient
, clause
, expr
);
1095 ASSERT_SYNTAX_2 (length
== 4, s_extra_expression
, clause
, expr
);
1096 SCM_SETCAR (SCM_CDDR (clause
), SCM_IM_ARROW
);
1100 SCM_SETCAR (expr
, SCM_IM_COND
);
1105 unmemoize_cond (const SCM expr
, const SCM env
)
1107 SCM um_clauses
= SCM_EOL
;
1110 for (clause_idx
= SCM_CDR (expr
);
1111 !scm_is_null (clause_idx
);
1112 clause_idx
= SCM_CDR (clause_idx
))
1114 const SCM clause
= SCM_CAR (clause_idx
);
1115 const SCM sequence
= SCM_CDR (clause
);
1116 const SCM test
= SCM_CAR (clause
);
1121 if (scm_is_eq (test
, SCM_IM_ELSE
))
1122 um_test
= scm_sym_else
;
1124 um_test
= unmemoize_expression (test
, env
);
1126 if (!scm_is_null (sequence
) && scm_is_eq (SCM_CAR (sequence
),
1129 const SCM target
= SCM_CADR (sequence
);
1130 const SCM um_target
= unmemoize_expression (target
, env
);
1131 um_sequence
= scm_list_2 (scm_sym_arrow
, um_target
);
1135 um_sequence
= unmemoize_exprs (sequence
, env
);
1138 um_clause
= scm_cons (um_test
, um_sequence
);
1139 um_clauses
= scm_cons (um_clause
, um_clauses
);
1141 um_clauses
= scm_reverse_x (um_clauses
, SCM_UNDEFINED
);
1143 return scm_cons (scm_sym_cond
, um_clauses
);
1147 SCM_SYNTAX (s_define
, "define", scm_i_makbimacro
, scm_m_define
);
1148 SCM_GLOBAL_SYMBOL (scm_sym_define
, s_define
);
1150 /* Guile provides an extension to R5RS' define syntax to represent function
1151 * currying in a compact way. With this extension, it is allowed to write
1152 * (define <nested-variable> <body>), where <nested-variable> has of one of
1153 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
1154 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
1155 * should be either a sequence of zero or more variables, or a sequence of one
1156 * or more variables followed by a space-delimited period and another
1157 * variable. Each level of argument nesting wraps the <body> within another
1158 * lambda expression. For example, the following forms are allowed, each one
1159 * followed by an equivalent, more explicit implementation.
1161 * (define ((a b . c) . d) <body>) is equivalent to
1162 * (define a (lambda (b . c) (lambda d <body>)))
1164 * (define (((a) b) c . d) <body>) is equivalent to
1165 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
1167 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
1168 * module that does not implement this extension. */
1170 canonicalize_define (const SCM expr
)
1175 const SCM cdr_expr
= SCM_CDR (expr
);
1176 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1177 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1179 body
= SCM_CDR (cdr_expr
);
1180 variable
= SCM_CAR (cdr_expr
);
1181 while (scm_is_pair (variable
))
1183 /* This while loop realizes function currying by variable nesting.
1184 * Variable is known to be a nested-variable. In every iteration of the
1185 * loop another level of lambda expression is created, starting with the
1186 * innermost one. Note that we don't check for duplicate formals here:
1187 * This will be done by the memoizer of the lambda expression. */
1188 const SCM formals
= SCM_CDR (variable
);
1189 const SCM tail
= scm_cons (formals
, body
);
1191 /* Add source properties to each new lambda expression: */
1192 const SCM lambda
= scm_cons_source (variable
, scm_sym_lambda
, tail
);
1194 body
= scm_list_1 (lambda
);
1195 variable
= SCM_CAR (variable
);
1197 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
1198 ASSERT_SYNTAX (scm_ilength (body
) == 1, s_expression
, expr
);
1200 SCM_SETCAR (cdr_expr
, variable
);
1201 SCM_SETCDR (cdr_expr
, body
);
1205 /* According to Section 5.2.1 of R5RS we first have to make sure that the
1206 variable is bound, and then perform the `(set! variable expression)'
1207 operation. However, EXPRESSION _can_ be evaluated before VARIABLE is
1208 bound. This means that EXPRESSION won't necessarily be able to assign
1209 values to VARIABLE as in `(define foo (begin (set! foo 1) (+ foo 1)))'. */
1211 scm_m_define (SCM expr
, SCM env
)
1213 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), s_bad_define
, expr
);
1216 const SCM canonical_definition
= canonicalize_define (expr
);
1217 const SCM cdr_canonical_definition
= SCM_CDR (canonical_definition
);
1218 const SCM variable
= SCM_CAR (cdr_canonical_definition
);
1219 const SCM value
= scm_eval_car (SCM_CDR (cdr_canonical_definition
), env
);
1221 = scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_T
);
1223 if (SCM_REC_PROCNAMES_P
)
1226 while (SCM_MACROP (tmp
))
1227 tmp
= SCM_MACRO_CODE (tmp
);
1228 if (scm_is_true (scm_procedure_p (tmp
))
1229 /* Only the first definition determines the name. */
1230 && scm_is_false (scm_procedure_property (tmp
, scm_sym_name
)))
1231 scm_set_procedure_property_x (tmp
, scm_sym_name
, variable
);
1234 SCM_VARIABLE_SET (location
, value
);
1236 return SCM_UNSPECIFIED
;
1241 /* This is a helper function for forms (<keyword> <expression>) that are
1242 * transformed into (#@<keyword> '() <memoized_expression>) in order to allow
1243 * for easy creation of a thunk (i. e. a closure without arguments) using the
1244 * ('() <memoized_expression>) tail of the memoized form. */
1246 memoize_as_thunk_prototype (const SCM expr
, const SCM env SCM_UNUSED
)
1248 const SCM cdr_expr
= SCM_CDR (expr
);
1249 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1250 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1252 SCM_SETCDR (expr
, scm_cons (SCM_EOL
, cdr_expr
));
1258 SCM_SYNTAX (s_delay
, "delay", scm_i_makbimacro
, scm_m_delay
);
1259 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
1261 /* Promises are implemented as closures with an empty parameter list. Thus,
1262 * (delay <expression>) is transformed into (#@delay '() <expression>), where
1263 * the empty list represents the empty parameter list. This representation
1264 * allows for easy creation of the closure during evaluation. */
1266 scm_m_delay (SCM expr
, SCM env
)
1268 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1269 SCM_SETCAR (new_expr
, SCM_IM_DELAY
);
1274 unmemoize_delay (const SCM expr
, const SCM env
)
1276 const SCM thunk_expr
= SCM_CADDR (expr
);
1277 /* A promise is implemented as a closure, and when applying a
1278 closure the evaluator adds a new frame to the environment - even
1279 though, in the case of a promise, the added frame is always
1280 empty. We need to extend the environment here in the same way,
1281 so that any ILOCs in thunk_expr can be unmemoized correctly. */
1282 const SCM new_env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1283 return scm_list_2 (scm_sym_delay
, unmemoize_expression (thunk_expr
, new_env
));
1287 SCM_SYNTAX(s_do
, "do", scm_i_makbimacro
, scm_m_do
);
1288 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
1290 /* DO gets the most radically altered syntax. The order of the vars is
1291 * reversed here. During the evaluation this allows for simple consing of the
1292 * results of the inits and steps:
1294 (do ((<var1> <init1> <step1>)
1302 (#@do (<init1> <init2> ... <initn>)
1303 (varn ... var2 var1)
1306 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
1309 scm_m_do (SCM expr
, SCM env SCM_UNUSED
)
1311 SCM variables
= SCM_EOL
;
1312 SCM init_forms
= SCM_EOL
;
1313 SCM step_forms
= SCM_EOL
;
1320 const SCM cdr_expr
= SCM_CDR (expr
);
1321 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1322 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1324 /* Collect variables, init and step forms. */
1325 binding_idx
= SCM_CAR (cdr_expr
);
1326 ASSERT_SYNTAX_2 (scm_ilength (binding_idx
) >= 0,
1327 s_bad_bindings
, binding_idx
, expr
);
1328 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1330 const SCM binding
= SCM_CAR (binding_idx
);
1331 const long length
= scm_ilength (binding
);
1332 ASSERT_SYNTAX_2 (length
== 2 || length
== 3,
1333 s_bad_binding
, binding
, expr
);
1336 const SCM name
= SCM_CAR (binding
);
1337 const SCM init
= SCM_CADR (binding
);
1338 const SCM step
= (length
== 2) ? name
: SCM_CADDR (binding
);
1339 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
1340 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, variables
)),
1341 s_duplicate_binding
, name
, expr
);
1343 variables
= scm_cons (name
, variables
);
1344 init_forms
= scm_cons (init
, init_forms
);
1345 step_forms
= scm_cons (step
, step_forms
);
1348 init_forms
= scm_reverse_x (init_forms
, SCM_UNDEFINED
);
1349 step_forms
= scm_reverse_x (step_forms
, SCM_UNDEFINED
);
1351 /* Memoize the test form and the exit sequence. */
1352 cddr_expr
= SCM_CDR (cdr_expr
);
1353 exit_clause
= SCM_CAR (cddr_expr
);
1354 ASSERT_SYNTAX_2 (scm_ilength (exit_clause
) >= 1,
1355 s_bad_exit_clause
, exit_clause
, expr
);
1357 commands
= SCM_CDR (cddr_expr
);
1358 tail
= scm_cons2 (exit_clause
, commands
, step_forms
);
1359 tail
= scm_cons2 (init_forms
, variables
, tail
);
1360 SCM_SETCAR (expr
, SCM_IM_DO
);
1361 SCM_SETCDR (expr
, tail
);
1366 unmemoize_do (const SCM expr
, const SCM env
)
1368 const SCM cdr_expr
= SCM_CDR (expr
);
1369 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1370 const SCM rnames
= SCM_CAR (cddr_expr
);
1371 const SCM extended_env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
1372 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
1373 const SCM exit_sequence
= SCM_CAR (cdddr_expr
);
1374 const SCM um_exit_sequence
= unmemoize_exprs (exit_sequence
, extended_env
);
1375 const SCM cddddr_expr
= SCM_CDR (cdddr_expr
);
1376 const SCM um_body
= unmemoize_exprs (SCM_CAR (cddddr_expr
), extended_env
);
1378 /* build transformed binding list */
1379 SCM um_names
= scm_reverse (rnames
);
1380 SCM um_inits
= unmemoize_exprs (SCM_CAR (cdr_expr
), env
);
1381 SCM um_steps
= unmemoize_exprs (SCM_CDR (cddddr_expr
), extended_env
);
1382 SCM um_bindings
= SCM_EOL
;
1383 while (!scm_is_null (um_names
))
1385 const SCM name
= SCM_CAR (um_names
);
1386 const SCM init
= SCM_CAR (um_inits
);
1387 SCM step
= SCM_CAR (um_steps
);
1388 step
= scm_is_eq (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
1390 um_bindings
= scm_cons (scm_cons2 (name
, init
, step
), um_bindings
);
1392 um_names
= SCM_CDR (um_names
);
1393 um_inits
= SCM_CDR (um_inits
);
1394 um_steps
= SCM_CDR (um_steps
);
1396 um_bindings
= scm_reverse_x (um_bindings
, SCM_UNDEFINED
);
1398 return scm_cons (scm_sym_do
,
1399 scm_cons2 (um_bindings
, um_exit_sequence
, um_body
));
1403 SCM_SYNTAX (s_if
, "if", scm_i_makbimacro
, scm_m_if
);
1404 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
1407 scm_m_if (SCM expr
, SCM env SCM_UNUSED
)
1409 const SCM cdr_expr
= SCM_CDR (expr
);
1410 const long length
= scm_ilength (cdr_expr
);
1411 ASSERT_SYNTAX (length
== 2 || length
== 3, s_expression
, expr
);
1412 SCM_SETCAR (expr
, SCM_IM_IF
);
1417 unmemoize_if (const SCM expr
, const SCM env
)
1419 const SCM cdr_expr
= SCM_CDR (expr
);
1420 const SCM um_condition
= unmemoize_expression (SCM_CAR (cdr_expr
), env
);
1421 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1422 const SCM um_then
= unmemoize_expression (SCM_CAR (cddr_expr
), env
);
1423 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
1425 if (scm_is_null (cdddr_expr
))
1427 return scm_list_3 (scm_sym_if
, um_condition
, um_then
);
1431 const SCM um_else
= unmemoize_expression (SCM_CAR (cdddr_expr
), env
);
1432 return scm_list_4 (scm_sym_if
, um_condition
, um_then
, um_else
);
1437 SCM_SYNTAX (s_lambda
, "lambda", scm_i_makbimacro
, scm_m_lambda
);
1438 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
1440 /* A helper function for memoize_lambda to support checking for duplicate
1441 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
1442 * LIST or to the cdr of the last cons. Therefore, LIST may have any of the
1443 * forms that a formal argument can have:
1444 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
1446 c_improper_memq (SCM obj
, SCM list
)
1448 for (; scm_is_pair (list
); list
= SCM_CDR (list
))
1450 if (scm_is_eq (SCM_CAR (list
), obj
))
1453 return scm_is_eq (list
, obj
);
1457 scm_m_lambda (SCM expr
, SCM env SCM_UNUSED
)
1466 const SCM cdr_expr
= SCM_CDR (expr
);
1467 const long length
= scm_ilength (cdr_expr
);
1468 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1469 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1471 /* Before iterating the list of formal arguments, make sure the formals
1472 * actually are given as either a symbol or a non-cyclic list. */
1473 formals
= SCM_CAR (cdr_expr
);
1474 if (scm_is_pair (formals
))
1476 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
1477 * detected, report a 'Bad formals' error. */
1481 ASSERT_SYNTAX_2 (scm_is_symbol (formals
) || scm_is_null (formals
),
1482 s_bad_formals
, formals
, expr
);
1485 /* Now iterate the list of formal arguments to check if all formals are
1486 * symbols, and that there are no duplicates. */
1487 formals_idx
= formals
;
1488 while (scm_is_pair (formals_idx
))
1490 const SCM formal
= SCM_CAR (formals_idx
);
1491 const SCM next_idx
= SCM_CDR (formals_idx
);
1492 ASSERT_SYNTAX_2 (scm_is_symbol (formal
), s_bad_formal
, formal
, expr
);
1493 ASSERT_SYNTAX_2 (!c_improper_memq (formal
, next_idx
),
1494 s_duplicate_formal
, formal
, expr
);
1495 formals_idx
= next_idx
;
1497 ASSERT_SYNTAX_2 (scm_is_null (formals_idx
) || scm_is_symbol (formals_idx
),
1498 s_bad_formal
, formals_idx
, expr
);
1500 /* Memoize the body. Keep a potential documentation string. */
1501 /* Dirk:FIXME:: We should probably extract the documentation string to
1502 * some external database. Otherwise it will slow down execution, since
1503 * the documentation string will have to be skipped with every execution
1504 * of the closure. */
1505 cddr_expr
= SCM_CDR (cdr_expr
);
1506 documentation
= (length
>= 3 && scm_is_string (SCM_CAR (cddr_expr
)));
1507 body
= documentation
? SCM_CDR (cddr_expr
) : cddr_expr
;
1508 new_body
= m_body (SCM_IM_LAMBDA
, body
);
1510 SCM_SETCAR (expr
, SCM_IM_LAMBDA
);
1512 SCM_SETCDR (cddr_expr
, new_body
);
1514 SCM_SETCDR (cdr_expr
, new_body
);
1519 unmemoize_lambda (const SCM expr
, const SCM env
)
1521 const SCM formals
= SCM_CADR (expr
);
1522 const SCM body
= SCM_CDDR (expr
);
1524 const SCM new_env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, env
);
1525 const SCM um_formals
= scm_i_finite_list_copy (formals
);
1526 const SCM um_body
= unmemoize_exprs (body
, new_env
);
1528 return scm_cons2 (scm_sym_lambda
, um_formals
, um_body
);
1532 /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
1534 check_bindings (const SCM bindings
, const SCM expr
)
1538 ASSERT_SYNTAX_2 (scm_ilength (bindings
) >= 0,
1539 s_bad_bindings
, bindings
, expr
);
1541 binding_idx
= bindings
;
1542 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1544 SCM name
; /* const */
1546 const SCM binding
= SCM_CAR (binding_idx
);
1547 ASSERT_SYNTAX_2 (scm_ilength (binding
) == 2,
1548 s_bad_binding
, binding
, expr
);
1550 name
= SCM_CAR (binding
);
1551 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
1556 /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
1557 * transformed to the lists (vn ... v2 v1) and (i1 i2 ... in). That is, the
1558 * variables are returned in a list with their order reversed, and the init
1559 * forms are returned in a list in the same order as they are given in the
1560 * bindings. If a duplicate variable name is detected, an error is
1563 transform_bindings (
1564 const SCM bindings
, const SCM expr
,
1565 SCM
*const rvarptr
, SCM
*const initptr
)
1567 SCM rvariables
= SCM_EOL
;
1568 SCM rinits
= SCM_EOL
;
1569 SCM binding_idx
= bindings
;
1570 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1572 const SCM binding
= SCM_CAR (binding_idx
);
1573 const SCM cdr_binding
= SCM_CDR (binding
);
1574 const SCM name
= SCM_CAR (binding
);
1575 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, rvariables
)),
1576 s_duplicate_binding
, name
, expr
);
1577 rvariables
= scm_cons (name
, rvariables
);
1578 rinits
= scm_cons (SCM_CAR (cdr_binding
), rinits
);
1580 *rvarptr
= rvariables
;
1581 *initptr
= scm_reverse_x (rinits
, SCM_UNDEFINED
);
1585 SCM_SYNTAX(s_let
, "let", scm_i_makbimacro
, scm_m_let
);
1586 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
1588 /* This function is a helper function for memoize_let. It transforms
1589 * (let name ((var init) ...) body ...) into
1590 * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
1591 * and memoizes the expression. It is assumed that the caller has checked
1592 * that name is a symbol and that there are bindings and a body. */
1594 memoize_named_let (const SCM expr
, const SCM env SCM_UNUSED
)
1600 const SCM cdr_expr
= SCM_CDR (expr
);
1601 const SCM name
= SCM_CAR (cdr_expr
);
1602 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1603 const SCM bindings
= SCM_CAR (cddr_expr
);
1604 check_bindings (bindings
, expr
);
1606 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1607 variables
= scm_reverse_x (rvariables
, SCM_UNDEFINED
);
1610 const SCM let_body
= SCM_CDR (cddr_expr
);
1611 const SCM lambda_body
= m_body (SCM_IM_LET
, let_body
);
1612 const SCM lambda_tail
= scm_cons (variables
, lambda_body
);
1613 const SCM lambda_form
= scm_cons_source (expr
, scm_sym_lambda
, lambda_tail
);
1615 const SCM rvar
= scm_list_1 (name
);
1616 const SCM init
= scm_list_1 (lambda_form
);
1617 const SCM body
= m_body (SCM_IM_LET
, scm_list_1 (name
));
1618 const SCM letrec_tail
= scm_cons (rvar
, scm_cons (init
, body
));
1619 const SCM letrec_form
= scm_cons_source (expr
, SCM_IM_LETREC
, letrec_tail
);
1620 return scm_cons_source (expr
, letrec_form
, inits
);
1624 /* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1625 * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
1627 scm_m_let (SCM expr
, SCM env
)
1631 const SCM cdr_expr
= SCM_CDR (expr
);
1632 const long length
= scm_ilength (cdr_expr
);
1633 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1634 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1636 bindings
= SCM_CAR (cdr_expr
);
1637 if (scm_is_symbol (bindings
))
1639 ASSERT_SYNTAX (length
>= 3, s_missing_expression
, expr
);
1640 return memoize_named_let (expr
, env
);
1643 check_bindings (bindings
, expr
);
1644 if (scm_is_null (bindings
) || scm_is_null (SCM_CDR (bindings
)))
1646 /* Special case: no bindings or single binding => let* is faster. */
1647 const SCM body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1648 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), bindings
, body
), env
);
1655 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1658 const SCM new_body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1659 const SCM new_tail
= scm_cons2 (rvariables
, inits
, new_body
);
1660 SCM_SETCAR (expr
, SCM_IM_LET
);
1661 SCM_SETCDR (expr
, new_tail
);
1668 build_binding_list (SCM rnames
, SCM rinits
)
1670 SCM bindings
= SCM_EOL
;
1671 while (!scm_is_null (rnames
))
1673 const SCM binding
= scm_list_2 (SCM_CAR (rnames
), SCM_CAR (rinits
));
1674 bindings
= scm_cons (binding
, bindings
);
1675 rnames
= SCM_CDR (rnames
);
1676 rinits
= SCM_CDR (rinits
);
1682 unmemoize_let (const SCM expr
, const SCM env
)
1684 const SCM cdr_expr
= SCM_CDR (expr
);
1685 const SCM um_rnames
= SCM_CAR (cdr_expr
);
1686 const SCM extended_env
= SCM_EXTEND_ENV (um_rnames
, SCM_EOL
, env
);
1687 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1688 const SCM um_inits
= unmemoize_exprs (SCM_CAR (cddr_expr
), env
);
1689 const SCM um_rinits
= scm_reverse_x (um_inits
, SCM_UNDEFINED
);
1690 const SCM um_bindings
= build_binding_list (um_rnames
, um_rinits
);
1691 const SCM um_body
= unmemoize_exprs (SCM_CDR (cddr_expr
), extended_env
);
1693 return scm_cons2 (scm_sym_let
, um_bindings
, um_body
);
1697 SCM_SYNTAX(s_letrec
, "letrec", scm_i_makbimacro
, scm_m_letrec
);
1698 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
1701 scm_m_letrec (SCM expr
, SCM env
)
1705 const SCM cdr_expr
= SCM_CDR (expr
);
1706 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1707 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1709 bindings
= SCM_CAR (cdr_expr
);
1710 if (scm_is_null (bindings
))
1712 /* no bindings, let* is executed faster */
1713 SCM body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1714 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), SCM_EOL
, body
), env
);
1722 check_bindings (bindings
, expr
);
1723 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1724 new_body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1725 return scm_cons2 (SCM_IM_LETREC
, rvariables
, scm_cons (inits
, new_body
));
1730 unmemoize_letrec (const SCM expr
, const SCM env
)
1732 const SCM cdr_expr
= SCM_CDR (expr
);
1733 const SCM um_rnames
= SCM_CAR (cdr_expr
);
1734 const SCM extended_env
= SCM_EXTEND_ENV (um_rnames
, SCM_EOL
, env
);
1735 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1736 const SCM um_inits
= unmemoize_exprs (SCM_CAR (cddr_expr
), extended_env
);
1737 const SCM um_rinits
= scm_reverse_x (um_inits
, SCM_UNDEFINED
);
1738 const SCM um_bindings
= build_binding_list (um_rnames
, um_rinits
);
1739 const SCM um_body
= unmemoize_exprs (SCM_CDR (cddr_expr
), extended_env
);
1741 return scm_cons2 (scm_sym_letrec
, um_bindings
, um_body
);
1746 SCM_SYNTAX (s_letstar
, "let*", scm_i_makbimacro
, scm_m_letstar
);
1747 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
1749 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1750 * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
1752 scm_m_letstar (SCM expr
, SCM env SCM_UNUSED
)
1757 const SCM cdr_expr
= SCM_CDR (expr
);
1758 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1759 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1761 binding_idx
= SCM_CAR (cdr_expr
);
1762 check_bindings (binding_idx
, expr
);
1764 /* Transform ((v1 i1) (v2 i2) ...) into (v1 i1 v2 i2 ...). The
1765 * transformation is done in place. At the beginning of one iteration of
1766 * the loop the variable binding_idx holds the form
1767 * P1:( (vn . P2:(in . ())) . P3:( (vn+1 in+1) ... ) ),
1768 * where P1, P2 and P3 indicate the pairs, that are relevant for the
1769 * transformation. P1 and P2 are modified in the loop, P3 remains
1770 * untouched. After the execution of the loop, P1 will hold
1771 * P1:( vn . P2:(in . P3:( (vn+1 in+1) ... )) )
1772 * and binding_idx will hold P3. */
1773 while (!scm_is_null (binding_idx
))
1775 const SCM cdr_binding_idx
= SCM_CDR (binding_idx
); /* remember P3 */
1776 const SCM binding
= SCM_CAR (binding_idx
);
1777 const SCM name
= SCM_CAR (binding
);
1778 const SCM cdr_binding
= SCM_CDR (binding
);
1780 SCM_SETCDR (cdr_binding
, cdr_binding_idx
); /* update P2 */
1781 SCM_SETCAR (binding_idx
, name
); /* update P1 */
1782 SCM_SETCDR (binding_idx
, cdr_binding
); /* update P1 */
1784 binding_idx
= cdr_binding_idx
; /* continue with P3 */
1787 new_body
= m_body (SCM_IM_LETSTAR
, SCM_CDR (cdr_expr
));
1788 SCM_SETCAR (expr
, SCM_IM_LETSTAR
);
1789 /* the bindings have been changed in place */
1790 SCM_SETCDR (cdr_expr
, new_body
);
1795 unmemoize_letstar (const SCM expr
, const SCM env
)
1797 const SCM cdr_expr
= SCM_CDR (expr
);
1798 const SCM body
= SCM_CDR (cdr_expr
);
1799 SCM bindings
= SCM_CAR (cdr_expr
);
1800 SCM um_bindings
= SCM_EOL
;
1801 SCM extended_env
= env
;
1804 while (!scm_is_null (bindings
))
1806 const SCM variable
= SCM_CAR (bindings
);
1807 const SCM init
= SCM_CADR (bindings
);
1808 const SCM um_init
= unmemoize_expression (init
, extended_env
);
1809 um_bindings
= scm_cons (scm_list_2 (variable
, um_init
), um_bindings
);
1810 extended_env
= SCM_EXTEND_ENV (variable
, SCM_BOOL_F
, extended_env
);
1811 bindings
= SCM_CDDR (bindings
);
1813 um_bindings
= scm_reverse_x (um_bindings
, SCM_UNDEFINED
);
1815 um_body
= unmemoize_exprs (body
, extended_env
);
1817 return scm_cons2 (scm_sym_letstar
, um_bindings
, um_body
);
1821 SCM_SYNTAX (s_or
, "or", scm_i_makbimacro
, scm_m_or
);
1822 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
1825 scm_m_or (SCM expr
, SCM env SCM_UNUSED
)
1827 const SCM cdr_expr
= SCM_CDR (expr
);
1828 const long length
= scm_ilength (cdr_expr
);
1830 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1834 /* Special case: (or) is replaced by #f. */
1839 SCM_SETCAR (expr
, SCM_IM_OR
);
1845 unmemoize_or (const SCM expr
, const SCM env
)
1847 return scm_cons (scm_sym_or
, unmemoize_exprs (SCM_CDR (expr
), env
));
1851 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
1852 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
1853 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
1854 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
1856 /* Internal function to handle a quasiquotation: 'form' is the parameter in
1857 * the call (quasiquotation form), 'env' is the environment where unquoted
1858 * expressions will be evaluated, and 'depth' is the current quasiquotation
1859 * nesting level and is known to be greater than zero. */
1861 iqq (SCM form
, SCM env
, unsigned long int depth
)
1863 if (scm_is_pair (form
))
1865 const SCM tmp
= SCM_CAR (form
);
1866 if (scm_is_eq (tmp
, scm_sym_quasiquote
))
1868 const SCM args
= SCM_CDR (form
);
1869 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1870 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
1872 else if (scm_is_eq (tmp
, scm_sym_unquote
))
1874 const SCM args
= SCM_CDR (form
);
1875 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1877 return scm_eval_car (args
, env
);
1879 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
1881 else if (scm_is_pair (tmp
)
1882 && scm_is_eq (SCM_CAR (tmp
), scm_sym_uq_splicing
))
1884 const SCM args
= SCM_CDR (tmp
);
1885 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1888 const SCM list
= scm_eval_car (args
, env
);
1889 const SCM rest
= SCM_CDR (form
);
1890 ASSERT_SYNTAX_2 (scm_ilength (list
) >= 0,
1891 s_splicing
, list
, form
);
1892 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
1895 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
1896 iqq (SCM_CDR (form
), env
, depth
));
1899 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
1900 iqq (SCM_CDR (form
), env
, depth
));
1902 else if (scm_is_vector (form
))
1903 return scm_vector (iqq (scm_vector_to_list (form
), env
, depth
));
1909 scm_m_quasiquote (SCM expr
, SCM env
)
1911 const SCM cdr_expr
= SCM_CDR (expr
);
1912 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1913 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1914 return iqq (SCM_CAR (cdr_expr
), env
, 1);
1918 SCM_SYNTAX (s_quote
, "quote", scm_i_makbimacro
, scm_m_quote
);
1919 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
1922 scm_m_quote (SCM expr
, SCM env SCM_UNUSED
)
1926 const SCM cdr_expr
= SCM_CDR (expr
);
1927 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1928 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1929 quotee
= SCM_CAR (cdr_expr
);
1930 if (is_self_quoting_p (quotee
))
1933 SCM_SETCAR (expr
, SCM_IM_QUOTE
);
1934 SCM_SETCDR (expr
, quotee
);
1939 unmemoize_quote (const SCM expr
, const SCM env SCM_UNUSED
)
1941 return scm_list_2 (scm_sym_quote
, SCM_CDR (expr
));
1945 /* Will go into the RnRS module when Guile is factorized.
1946 SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
1947 static const char s_set_x
[] = "set!";
1948 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, s_set_x
);
1951 scm_m_set_x (SCM expr
, SCM env SCM_UNUSED
)
1956 const SCM cdr_expr
= SCM_CDR (expr
);
1957 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1958 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1959 variable
= SCM_CAR (cdr_expr
);
1961 /* Memoize the variable form. */
1962 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
1963 new_variable
= lookup_symbol (variable
, env
);
1964 /* Leave the memoization of unbound symbols to lazy memoization: */
1965 if (SCM_UNBNDP (new_variable
))
1966 new_variable
= variable
;
1968 SCM_SETCAR (expr
, SCM_IM_SET_X
);
1969 SCM_SETCAR (cdr_expr
, new_variable
);
1974 unmemoize_set_x (const SCM expr
, const SCM env
)
1976 return scm_cons (scm_sym_set_x
, unmemoize_exprs (SCM_CDR (expr
), env
));
1980 /* Start of the memoizers for non-R5RS builtin macros. */
1983 SCM_SYNTAX (s_at
, "@", scm_makmmacro
, scm_m_at
);
1984 SCM_GLOBAL_SYMBOL (scm_sym_at
, s_at
);
1987 scm_m_at (SCM expr
, SCM env SCM_UNUSED
)
1990 ASSERT_SYNTAX (scm_ilength (expr
) == 3, s_bad_expression
, expr
);
1991 ASSERT_SYNTAX (scm_ilength (scm_cadr (expr
)) > 0, s_bad_expression
, expr
);
1992 ASSERT_SYNTAX (scm_is_symbol (scm_caddr (expr
)), s_bad_expression
, expr
);
1994 mod
= scm_resolve_module (scm_cadr (expr
));
1995 if (scm_is_false (mod
))
1996 error_unbound_variable (expr
);
1997 var
= scm_module_variable (scm_module_public_interface (mod
), scm_caddr (expr
));
1998 if (scm_is_false (var
))
1999 error_unbound_variable (expr
);
2004 SCM_SYNTAX (s_atat
, "@@", scm_makmmacro
, scm_m_atat
);
2005 SCM_GLOBAL_SYMBOL (scm_sym_atat
, s_atat
);
2008 scm_m_atat (SCM expr
, SCM env SCM_UNUSED
)
2011 ASSERT_SYNTAX (scm_ilength (expr
) == 3, s_bad_expression
, expr
);
2012 ASSERT_SYNTAX (scm_ilength (scm_cadr (expr
)) > 0, s_bad_expression
, expr
);
2013 ASSERT_SYNTAX (scm_is_symbol (scm_caddr (expr
)), s_bad_expression
, expr
);
2015 mod
= scm_resolve_module (scm_cadr (expr
));
2016 if (scm_is_false (mod
))
2017 error_unbound_variable (expr
);
2018 var
= scm_module_variable (mod
, scm_caddr (expr
));
2019 if (scm_is_false (var
))
2020 error_unbound_variable (expr
);
2025 SCM_SYNTAX (s_atapply
, "@apply", scm_i_makbimacro
, scm_m_apply
);
2026 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
2027 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
2030 scm_m_apply (SCM expr
, SCM env SCM_UNUSED
)
2032 const SCM cdr_expr
= SCM_CDR (expr
);
2033 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2034 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_missing_expression
, expr
);
2036 SCM_SETCAR (expr
, SCM_IM_APPLY
);
2041 unmemoize_apply (const SCM expr
, const SCM env
)
2043 return scm_list_2 (scm_sym_atapply
, unmemoize_exprs (SCM_CDR (expr
), env
));
2047 SCM_SYNTAX (s_atbind
, "@bind", scm_i_makbimacro
, scm_m_atbind
);
2049 /* FIXME: The following explanation should go into the documentation: */
2050 /* (@bind ((var init) ...) body ...) will assign the values of the `init's to
2051 * the global variables named by `var's (symbols, not evaluated), creating
2052 * them if they don't exist, executes body, and then restores the previous
2053 * values of the `var's. Additionally, whenever control leaves body, the
2054 * values of the `var's are saved and restored when control returns. It is an
2055 * error when a symbol appears more than once among the `var's. All `init's
2056 * are evaluated before any `var' is set.
2058 * Think of this as `let' for dynamic scope.
2061 /* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into
2062 * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...).
2064 * FIXME - also implement `@bind*'.
2067 scm_m_atbind (SCM expr
, SCM env
)
2074 const SCM top_level
= scm_env_top_level (env
);
2076 const SCM cdr_expr
= SCM_CDR (expr
);
2077 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2078 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
2079 bindings
= SCM_CAR (cdr_expr
);
2080 check_bindings (bindings
, expr
);
2081 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
2083 for (variable_idx
= rvariables
;
2084 !scm_is_null (variable_idx
);
2085 variable_idx
= SCM_CDR (variable_idx
))
2087 /* The first call to scm_sym2var will look beyond the current module,
2088 * while the second call wont. */
2089 const SCM variable
= SCM_CAR (variable_idx
);
2090 SCM new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_F
);
2091 if (scm_is_false (new_variable
))
2092 new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_T
);
2093 SCM_SETCAR (variable_idx
, new_variable
);
2096 SCM_SETCAR (expr
, SCM_IM_BIND
);
2097 SCM_SETCAR (cdr_expr
, scm_cons (rvariables
, inits
));
2102 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_i_makbimacro
, scm_m_cont
);
2103 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, s_atcall_cc
);
2106 scm_m_cont (SCM expr
, SCM env SCM_UNUSED
)
2108 const SCM cdr_expr
= SCM_CDR (expr
);
2109 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2110 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2112 SCM_SETCAR (expr
, SCM_IM_CONT
);
2117 unmemoize_atcall_cc (const SCM expr
, const SCM env
)
2119 return scm_list_2 (scm_sym_atcall_cc
, unmemoize_exprs (SCM_CDR (expr
), env
));
2123 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_i_makbimacro
, scm_m_at_call_with_values
);
2124 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
2127 scm_m_at_call_with_values (SCM expr
, SCM env SCM_UNUSED
)
2129 const SCM cdr_expr
= SCM_CDR (expr
);
2130 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2131 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2133 SCM_SETCAR (expr
, SCM_IM_CALL_WITH_VALUES
);
2138 unmemoize_at_call_with_values (const SCM expr
, const SCM env
)
2140 return scm_list_2 (scm_sym_at_call_with_values
,
2141 unmemoize_exprs (SCM_CDR (expr
), env
));
2144 SCM_SYNTAX (s_eval_when
, "eval-when", scm_makmmacro
, scm_m_eval_when
);
2145 SCM_GLOBAL_SYMBOL (scm_sym_eval_when
, s_eval_when
);
2146 SCM_SYMBOL (sym_eval
, "eval");
2147 SCM_SYMBOL (sym_load
, "load");
2151 scm_m_eval_when (SCM expr
, SCM env SCM_UNUSED
)
2153 ASSERT_SYNTAX (scm_ilength (expr
) >= 3, s_bad_expression
, expr
);
2154 ASSERT_SYNTAX (scm_ilength (scm_cadr (expr
)) > 0, s_bad_expression
, expr
);
2156 if (scm_is_true (scm_memq (sym_eval
, scm_cadr (expr
)))
2157 || scm_is_true (scm_memq (sym_load
, scm_cadr (expr
))))
2158 return scm_cons (SCM_IM_BEGIN
, scm_cddr (expr
));
2160 return scm_list_1 (SCM_IM_BEGIN
);
2165 /* See futures.h for a comment why futures are not enabled.
2168 SCM_SYNTAX (s_future
, "future", scm_i_makbimacro
, scm_m_future
);
2169 SCM_GLOBAL_SYMBOL (scm_sym_future
, s_future
);
2171 /* Like promises, futures are implemented as closures with an empty
2172 * parameter list. Thus, (future <expression>) is transformed into
2173 * (#@future '() <expression>), where the empty list represents the
2174 * empty parameter list. This representation allows for easy creation
2175 * of the closure during evaluation. */
2177 scm_m_future (SCM expr
, SCM env
)
2179 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
2180 SCM_SETCAR (new_expr
, SCM_IM_FUTURE
);
2185 unmemoize_future (const SCM expr
, const SCM env
)
2187 const SCM thunk_expr
= SCM_CADDR (expr
);
2188 return scm_list_2 (scm_sym_future
, unmemoize_expression (thunk_expr
, env
));
2191 #endif /* futures disabled. */
2193 SCM_SYNTAX (s_gset_x
, "set!", scm_i_makbimacro
, scm_m_generalized_set_x
);
2194 SCM_SYMBOL (scm_sym_setter
, "setter");
2197 scm_m_generalized_set_x (SCM expr
, SCM env
)
2199 SCM target
, exp_target
;
2201 const SCM cdr_expr
= SCM_CDR (expr
);
2202 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2203 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2205 target
= SCM_CAR (cdr_expr
);
2206 if (!scm_is_pair (target
))
2209 return scm_m_set_x (expr
, env
);
2213 /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */
2214 /* Macroexpanding the target might return things of the form
2215 (begin <atom>). In that case, <atom> must be a symbol or a
2216 variable and we memoize to (set! <atom> ...).
2218 exp_target
= macroexp (target
, env
);
2219 if (scm_is_eq (SCM_CAR (exp_target
), SCM_IM_BEGIN
)
2220 && !scm_is_null (SCM_CDR (exp_target
))
2221 && scm_is_null (SCM_CDDR (exp_target
)))
2223 exp_target
= SCM_CADR (exp_target
);
2224 ASSERT_SYNTAX_2 (scm_is_symbol (exp_target
)
2225 || SCM_VARIABLEP (exp_target
),
2226 s_bad_variable
, exp_target
, expr
);
2227 return scm_cons (SCM_IM_SET_X
, scm_cons (exp_target
,
2228 SCM_CDR (cdr_expr
)));
2232 const SCM setter_proc_tail
= scm_list_1 (SCM_CAR (target
));
2233 const SCM setter_proc
= scm_cons_source (expr
, scm_sym_setter
,
2236 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
2237 const SCM setter_args
= scm_append_x (scm_list_2 (SCM_CDR (target
),
2240 SCM_SETCAR (expr
, setter_proc
);
2241 SCM_SETCDR (expr
, setter_args
);
2248 /* @slot-ref is bound privately in the (oop goops) module from goops.c. As
2249 * soon as the module system allows us to more freely create bindings in
2250 * arbitrary modules during the startup phase, the code from goops.c should be
2253 SCM_SYMBOL (sym_atslot_ref
, "@slot-ref");
2256 scm_m_atslot_ref (SCM expr
, SCM env SCM_UNUSED
)
2260 const SCM cdr_expr
= SCM_CDR (expr
);
2261 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2262 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2263 slot_nr
= SCM_CADR (cdr_expr
);
2264 ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2266 SCM_SETCAR (expr
, SCM_IM_SLOT_REF
);
2267 SCM_SETCDR (cdr_expr
, slot_nr
);
2272 unmemoize_atslot_ref (const SCM expr
, const SCM env
)
2274 const SCM instance
= SCM_CADR (expr
);
2275 const SCM um_instance
= unmemoize_expression (instance
, env
);
2276 const SCM slot_nr
= SCM_CDDR (expr
);
2277 return scm_list_3 (sym_atslot_ref
, um_instance
, slot_nr
);
2281 /* @slot-set! is bound privately in the (oop goops) module from goops.c. As
2282 * soon as the module system allows us to more freely create bindings in
2283 * arbitrary modules during the startup phase, the code from goops.c should be
2286 SCM_SYMBOL (sym_atslot_set_x
, "@slot-set!");
2289 scm_m_atslot_set_x (SCM expr
, SCM env SCM_UNUSED
)
2293 const SCM cdr_expr
= SCM_CDR (expr
);
2294 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2295 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 3, s_expression
, expr
);
2296 slot_nr
= SCM_CADR (cdr_expr
);
2297 ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2299 SCM_SETCAR (expr
, SCM_IM_SLOT_SET_X
);
2304 unmemoize_atslot_set_x (const SCM expr
, const SCM env
)
2306 const SCM cdr_expr
= SCM_CDR (expr
);
2307 const SCM instance
= SCM_CAR (cdr_expr
);
2308 const SCM um_instance
= unmemoize_expression (instance
, env
);
2309 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
2310 const SCM slot_nr
= SCM_CAR (cddr_expr
);
2311 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
2312 const SCM value
= SCM_CAR (cdddr_expr
);
2313 const SCM um_value
= unmemoize_expression (value
, env
);
2314 return scm_list_4 (sym_atslot_set_x
, um_instance
, slot_nr
, um_value
);
2318 #if SCM_ENABLE_ELISP
2320 static const char s_defun
[] = "Symbol's function definition is void";
2322 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_i_makbimacro
, scm_m_nil_cond
);
2324 /* nil-cond expressions have the form
2325 * (nil-cond COND VAL COND VAL ... ELSEVAL) */
2327 scm_m_nil_cond (SCM expr
, SCM env SCM_UNUSED
)
2329 const long length
= scm_ilength (SCM_CDR (expr
));
2330 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
2331 ASSERT_SYNTAX (length
>= 1 && (length
% 2) == 1, s_expression
, expr
);
2333 SCM_SETCAR (expr
, SCM_IM_NIL_COND
);
2338 SCM_SYNTAX (s_atfop
, "@fop", scm_i_makbimacro
, scm_m_atfop
);
2340 /* The @fop-macro handles procedure and macro applications for elisp. The
2341 * input expression must have the form
2342 * (@fop <var> (transformer-macro <expr> ...))
2343 * where <var> must be a symbol. The expression is transformed into the
2344 * memoized form of either
2345 * (apply <un-aliased var> (transformer-macro <expr> ...))
2346 * if the value of var (across all aliasing) is not a macro, or
2347 * (<un-aliased var> <expr> ...)
2348 * if var is a macro. */
2350 scm_m_atfop (SCM expr
, SCM env SCM_UNUSED
)
2355 const SCM cdr_expr
= SCM_CDR (expr
);
2356 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2357 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 1, s_missing_expression
, expr
);
2359 symbol
= SCM_CAR (cdr_expr
);
2360 ASSERT_SYNTAX_2 (scm_is_symbol (symbol
), s_bad_variable
, symbol
, expr
);
2362 location
= scm_symbol_fref (symbol
);
2363 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2365 /* The elisp function `defalias' allows to define aliases for symbols. To
2366 * look up such definitions, the chain of symbol definitions has to be
2367 * followed up to the terminal symbol. */
2368 while (scm_is_symbol (SCM_VARIABLE_REF (location
)))
2370 const SCM alias
= SCM_VARIABLE_REF (location
);
2371 location
= scm_symbol_fref (alias
);
2372 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2375 /* Memoize the value location belonging to the terminal symbol. */
2376 SCM_SETCAR (cdr_expr
, location
);
2378 if (!SCM_MACROP (SCM_VARIABLE_REF (location
)))
2380 /* Since the location does not contain a macro, the form is a procedure
2381 * application. Replace `@fop' by `@apply' and transform the expression
2382 * including the `transformer-macro'. */
2383 SCM_SETCAR (expr
, SCM_IM_APPLY
);
2388 /* Since the location contains a macro, the arguments should not be
2389 * transformed, so the `transformer-macro' is cut out. The resulting
2390 * expression starts with the memoized variable, that is at the cdr of
2391 * the input expression. */
2392 SCM_SETCDR (cdr_expr
, SCM_CDADR (cdr_expr
));
2397 #endif /* SCM_ENABLE_ELISP */
2401 unmemoize_builtin_macro (const SCM expr
, const SCM env
)
2403 switch (ISYMNUM (SCM_CAR (expr
)))
2405 case (ISYMNUM (SCM_IM_AND
)):
2406 return unmemoize_and (expr
, env
);
2408 case (ISYMNUM (SCM_IM_BEGIN
)):
2409 return unmemoize_begin (expr
, env
);
2411 case (ISYMNUM (SCM_IM_CASE
)):
2412 return unmemoize_case (expr
, env
);
2414 case (ISYMNUM (SCM_IM_COND
)):
2415 return unmemoize_cond (expr
, env
);
2417 case (ISYMNUM (SCM_IM_DELAY
)):
2418 return unmemoize_delay (expr
, env
);
2420 case (ISYMNUM (SCM_IM_DO
)):
2421 return unmemoize_do (expr
, env
);
2423 case (ISYMNUM (SCM_IM_IF
)):
2424 return unmemoize_if (expr
, env
);
2426 case (ISYMNUM (SCM_IM_LAMBDA
)):
2427 return unmemoize_lambda (expr
, env
);
2429 case (ISYMNUM (SCM_IM_LET
)):
2430 return unmemoize_let (expr
, env
);
2432 case (ISYMNUM (SCM_IM_LETREC
)):
2433 return unmemoize_letrec (expr
, env
);
2435 case (ISYMNUM (SCM_IM_LETSTAR
)):
2436 return unmemoize_letstar (expr
, env
);
2438 case (ISYMNUM (SCM_IM_OR
)):
2439 return unmemoize_or (expr
, env
);
2441 case (ISYMNUM (SCM_IM_QUOTE
)):
2442 return unmemoize_quote (expr
, env
);
2444 case (ISYMNUM (SCM_IM_SET_X
)):
2445 return unmemoize_set_x (expr
, env
);
2447 case (ISYMNUM (SCM_IM_APPLY
)):
2448 return unmemoize_apply (expr
, env
);
2450 case (ISYMNUM (SCM_IM_BIND
)):
2451 return unmemoize_exprs (expr
, env
); /* FIXME */
2453 case (ISYMNUM (SCM_IM_CONT
)):
2454 return unmemoize_atcall_cc (expr
, env
);
2456 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2457 return unmemoize_at_call_with_values (expr
, env
);
2460 /* See futures.h for a comment why futures are not enabled.
2462 case (ISYMNUM (SCM_IM_FUTURE
)):
2463 return unmemoize_future (expr
, env
);
2466 case (ISYMNUM (SCM_IM_SLOT_REF
)):
2467 return unmemoize_atslot_ref (expr
, env
);
2469 case (ISYMNUM (SCM_IM_SLOT_SET_X
)):
2470 return unmemoize_atslot_set_x (expr
, env
);
2472 case (ISYMNUM (SCM_IM_NIL_COND
)):
2473 return unmemoize_exprs (expr
, env
); /* FIXME */
2476 return unmemoize_exprs (expr
, env
); /* FIXME */
2481 /* scm_i_unmemocopy_expr and scm_i_unmemocopy_body take a memoized expression
2482 * respectively a memoized body together with its environment and rewrite it
2483 * to its original form. Thus, these functions are the inversion of the
2484 * rewrite rules above. The procedure is not optimized for speed. It's used
2485 * in scm_i_unmemoize_expr, scm_procedure_source, macro_print and scm_iprin1.
2487 * Unmemoizing is not a reliable process. You cannot in general expect to get
2488 * the original source back.
2490 * However, GOOPS currently relies on this for method compilation. This ought
2494 scm_i_unmemocopy_expr (SCM expr
, SCM env
)
2496 const SCM source_properties
= scm_whash_lookup (scm_source_whash
, expr
);
2497 const SCM um_expr
= unmemoize_expression (expr
, env
);
2499 if (scm_is_true (source_properties
))
2500 scm_whash_insert (scm_source_whash
, um_expr
, source_properties
);
2506 scm_i_unmemocopy_body (SCM forms
, SCM env
)
2508 const SCM source_properties
= scm_whash_lookup (scm_source_whash
, forms
);
2509 const SCM um_forms
= unmemoize_exprs (forms
, env
);
2511 if (scm_is_true (source_properties
))
2512 scm_whash_insert (scm_source_whash
, um_forms
, source_properties
);
2518 #if (SCM_ENABLE_DEPRECATED == 1)
2520 /* Deprecated in guile 1.7.0 on 2003-11-09. */
2522 scm_m_expand_body (SCM exprs
, SCM env
)
2524 scm_c_issue_deprecation_warning
2525 ("`scm_m_expand_body' is deprecated.");
2526 m_expand_body (exprs
, env
);
2531 SCM_SYNTAX (s_undefine
, "undefine", scm_makacro
, scm_m_undefine
);
2534 scm_m_undefine (SCM expr
, SCM env
)
2539 const SCM cdr_expr
= SCM_CDR (expr
);
2540 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), "Bad undefine placement in", expr
);
2541 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2542 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2544 scm_c_issue_deprecation_warning
2545 ("`undefine' is deprecated.\n");
2547 variable
= SCM_CAR (cdr_expr
);
2548 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
2549 location
= scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_F
);
2550 ASSERT_SYNTAX_2 (scm_is_true (location
)
2551 && !SCM_UNBNDP (SCM_VARIABLE_REF (location
)),
2552 "variable already unbound ", variable
, expr
);
2553 SCM_VARIABLE_SET (location
, SCM_UNDEFINED
);
2554 return SCM_UNSPECIFIED
;
2558 scm_macroexp (SCM x
, SCM env
)
2560 scm_c_issue_deprecation_warning
2561 ("`scm_macroexp' is deprecated.");
2562 return macroexp (x
, env
);
2568 #if (SCM_ENABLE_DEPRECATED == 1)
2571 scm_unmemocar (SCM form
, SCM env
)
2573 scm_c_issue_deprecation_warning
2574 ("`scm_unmemocar' is deprecated.");
2576 if (!scm_is_pair (form
))
2580 SCM c
= SCM_CAR (form
);
2581 if (SCM_VARIABLEP (c
))
2583 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
2584 if (scm_is_false (sym
))
2585 sym
= sym_three_question_marks
;
2586 SCM_SETCAR (form
, sym
);
2588 else if (SCM_ILOCP (c
))
2590 unsigned long int ir
;
2592 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
2593 env
= SCM_CDR (env
);
2594 env
= SCM_CAAR (env
);
2595 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
2596 env
= SCM_CDR (env
);
2598 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
2606 /*****************************************************************************/
2607 /*****************************************************************************/
2608 /* The definitions for execution start here. */
2609 /*****************************************************************************/
2610 /*****************************************************************************/
2612 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
2613 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
2614 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
2615 SCM_GLOBAL_SYMBOL (scm_sym_memoize_symbol
, "memoize-symbol");
2616 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
2617 SCM_SYMBOL (sym_instead
, "instead");
2619 /* A function object to implement "apply" for non-closure functions. */
2621 /* An endless list consisting of #<undefined> objects: */
2622 static SCM undefineds
;
2626 scm_badargsp (SCM formals
, SCM args
)
2628 while (!scm_is_null (formals
))
2630 if (!scm_is_pair (formals
))
2632 if (scm_is_null (args
))
2634 formals
= SCM_CDR (formals
);
2635 args
= SCM_CDR (args
);
2637 return !scm_is_null (args
) ? 1 : 0;
2642 /* The evaluator contains a plethora of EVAL symbols.
2645 * SCM_I_EVALIM is used when it is known that the expression is an
2646 * immediate. (This macro never calls an evaluator.)
2648 * SCM_I_XEVAL evaluates an expression that is expected to have its symbols already
2649 * memoized. Expressions that are not of the form '(<form> <form> ...)' are
2650 * evaluated inline without calling an evaluator.
2652 * This macro uses ceval or deval depending on its 3rd argument.
2654 * SCM_I_XEVALCAR evaluates the car of an expression 'X:(Y:<form> <form> ...)',
2655 * potentially replacing a symbol at the position Y:<form> by its memoized
2656 * variable. If Y:<form> is not of the form '(<form> <form> ...)', the
2657 * evaluation is performed inline without calling an evaluator.
2659 * This macro uses ceval or deval depending on its 3rd argument.
2663 #define SCM_I_EVALIM2(x) \
2664 ((scm_is_eq ((x), SCM_EOL) \
2665 ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \
2669 #define SCM_I_EVALIM(x, env) (SCM_ILOCP (x) \
2670 ? *scm_ilookup ((x), (env)) \
2673 #define SCM_I_XEVAL(x, env, debug_p) \
2675 ? SCM_I_EVALIM2 (x) \
2676 : (SCM_VARIABLEP (x) \
2677 ? SCM_VARIABLE_REF (x) \
2678 : (scm_is_pair (x) \
2680 ? deval ((x), (env)) \
2681 : ceval ((x), (env))) \
2684 #define SCM_I_XEVALCAR(x, env, debug_p) \
2685 (SCM_IMP (SCM_CAR (x)) \
2686 ? SCM_I_EVALIM (SCM_CAR (x), (env)) \
2687 : (SCM_VARIABLEP (SCM_CAR (x)) \
2688 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2689 : (scm_is_pair (SCM_CAR (x)) \
2691 ? deval (SCM_CAR (x), (env)) \
2692 : ceval (SCM_CAR (x), (env))) \
2693 : (!scm_is_symbol (SCM_CAR (x)) \
2695 : *scm_lookupcar ((x), (env), 1)))))
2697 scm_i_pthread_mutex_t source_mutex
;
2700 /* Lookup a given local variable in an environment. The local variable is
2701 * given as an iloc, that is a triple <frame, binding, last?>, where frame
2702 * indicates the relative number of the environment frame (counting upwards
2703 * from the innermost environment frame), binding indicates the number of the
2704 * binding within the frame, and last? (which is extracted from the iloc using
2705 * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
2706 * very end of the improper list of bindings. */
2708 scm_ilookup (SCM iloc
, SCM env
)
2710 unsigned int frame_nr
= SCM_IFRAME (iloc
);
2711 unsigned int binding_nr
= SCM_IDIST (iloc
);
2715 for (; 0 != frame_nr
; --frame_nr
)
2716 frames
= SCM_CDR (frames
);
2718 bindings
= SCM_CAR (frames
);
2719 for (; 0 != binding_nr
; --binding_nr
)
2720 bindings
= SCM_CDR (bindings
);
2722 if (SCM_ICDRP (iloc
))
2723 return SCM_CDRLOC (bindings
);
2724 return SCM_CARLOC (SCM_CDR (bindings
));
2728 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
2730 /* Call this for variables that are unfound.
2733 error_unbound_variable (SCM symbol
)
2735 scm_error (scm_unbound_variable_key
, NULL
,
2736 "Unbound variable: ~S",
2737 scm_list_1 (symbol
), SCM_BOOL_F
);
2740 /* Call this for variables that are found but contain SCM_UNDEFINED.
2743 error_defined_variable (SCM symbol
)
2745 /* We use the 'unbound-variable' key here as well, since it
2746 basically is the same kind of error, with a slight variation in
2747 the displayed message.
2749 scm_error (scm_unbound_variable_key
, NULL
,
2750 "Variable used before given a value: ~S",
2751 scm_list_1 (symbol
), SCM_BOOL_F
);
2755 /* The Lookup Car Race
2758 Memoization of variables and special forms is done while executing
2759 the code for the first time. As long as there is only one thread
2760 everything is fine, but as soon as two threads execute the same
2761 code concurrently `for the first time' they can come into conflict.
2763 This memoization includes rewriting variable references into more
2764 efficient forms and expanding macros. Furthermore, macro expansion
2765 includes `compiling' special forms like `let', `cond', etc. into
2766 tree-code instructions.
2768 There shouldn't normally be a problem with memoizing local and
2769 global variable references (into ilocs and variables), because all
2770 threads will mutate the code in *exactly* the same way and (if I
2771 read the C code correctly) it is not possible to observe a half-way
2772 mutated cons cell. The lookup procedure can handle this
2773 transparently without any critical sections.
2775 It is different with macro expansion, because macro expansion
2776 happens outside of the lookup procedure and can't be
2777 undone. Therefore the lookup procedure can't cope with it. It has
2778 to indicate failure when it detects a lost race and hope that the
2779 caller can handle it. Luckily, it turns out that this is the case.
2781 An example to illustrate this: Suppose that the following form will
2782 be memoized concurrently by two threads
2786 Let's first examine the lookup of X in the body. The first thread
2787 decides that it has to find the symbol "x" in the environment and
2788 starts to scan it. Then the other thread takes over and actually
2789 overtakes the first. It looks up "x" and substitutes an
2790 appropriate iloc for it. Now the first thread continues and
2791 completes its lookup. It comes to exactly the same conclusions as
2792 the second one and could - without much ado - just overwrite the
2793 iloc with the same iloc.
2795 But let's see what will happen when the race occurs while looking
2796 up the symbol "let" at the start of the form. It could happen that
2797 the second thread interrupts the lookup of the first thread and not
2798 only substitutes a variable for it but goes right ahead and
2799 replaces it with the compiled form (#@let* (x 12) x). Now, when
2800 the first thread completes its lookup, it would replace the #@let*
2801 with a variable containing the "let" binding, effectively reverting
2802 the form to (let (x 12) x). This is wrong. It has to detect that
2803 it has lost the race and the evaluator has to reconsider the
2804 changed form completely.
2806 This race condition could be resolved with some kind of traffic
2807 light (like mutexes) around scm_lookupcar, but I think that it is
2808 best to avoid them in this case. They would serialize memoization
2809 completely and because lookup involves calling arbitrary Scheme
2810 code (via the lookup-thunk), threads could be blocked for an
2811 arbitrary amount of time or even deadlock. But with the current
2812 solution a lot of unnecessary work is potentially done. */
2814 /* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
2815 return NULL to indicate a failed lookup due to some race conditions
2816 between threads. This only happens when VLOC is the first cell of
2817 a special form that will eventually be memoized (like `let', etc.)
2818 In that case the whole lookup is bogus and the caller has to
2819 reconsider the complete special form.
2821 SCM_LOOKUPCAR is still there, of course. It just calls
2822 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
2823 should only be called when it is known that VLOC is not the first
2824 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
2825 for NULL. I think I've found the only places where this
2829 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
2832 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
2833 register SCM iloc
= SCM_ILOC00
;
2834 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
2836 if (!scm_is_pair (SCM_CAR (env
)))
2838 al
= SCM_CARLOC (env
);
2839 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
2841 if (!scm_is_pair (fl
))
2843 if (scm_is_eq (fl
, var
))
2845 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2847 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
2848 return SCM_CDRLOC (*al
);
2853 al
= SCM_CDRLOC (*al
);
2854 if (scm_is_eq (SCM_CAR (fl
), var
))
2856 if (SCM_UNBNDP (SCM_CAR (*al
)))
2857 error_defined_variable (var
);
2858 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2860 SCM_SETCAR (vloc
, iloc
);
2861 return SCM_CARLOC (*al
);
2863 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
2865 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
2868 SCM top_thunk
, real_var
;
2871 top_thunk
= SCM_CAR (env
); /* env now refers to a
2872 top level env thunk */
2873 env
= SCM_CDR (env
);
2876 top_thunk
= SCM_BOOL_F
;
2877 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
2878 if (scm_is_false (real_var
))
2881 if (!scm_is_null (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
2886 if (scm_is_null (env
))
2887 error_unbound_variable (var
);
2889 scm_misc_error (NULL
, "Damaged environment: ~S",
2894 /* A variable could not be found, but we shall
2895 not throw an error. */
2896 static SCM undef_object
= SCM_UNDEFINED
;
2897 return &undef_object
;
2901 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2903 /* Some other thread has changed the very cell we are working
2904 on. In effect, it must have done our job or messed it up
2907 var
= SCM_CAR (vloc
);
2908 if (SCM_VARIABLEP (var
))
2909 return SCM_VARIABLE_LOC (var
);
2910 if (SCM_ILOCP (var
))
2911 return scm_ilookup (var
, genv
);
2912 /* We can't cope with anything else than variables and ilocs. When
2913 a special form has been memoized (i.e. `let' into `#@let') we
2914 return NULL and expect the calling function to do the right
2915 thing. For the evaluator, this means going back and redoing
2916 the dispatch on the car of the form. */
2920 SCM_SETCAR (vloc
, real_var
);
2921 return SCM_VARIABLE_LOC (real_var
);
2926 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
2928 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
2935 /* During execution, look up a symbol in the top level of the given local
2936 * environment and return the corresponding variable object. If no binding
2937 * for the symbol can be found, an 'Unbound variable' error is signalled. */
2939 lazy_memoize_variable (const SCM symbol
, const SCM environment
)
2941 const SCM top_level
= scm_env_top_level (environment
);
2942 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
2944 if (scm_is_false (variable
))
2945 error_unbound_variable (symbol
);
2952 scm_eval_car (SCM pair
, SCM env
)
2954 return SCM_I_XEVALCAR (pair
, env
, scm_debug_mode_p
);
2959 scm_eval_body (SCM code
, SCM env
)
2964 next
= SCM_CDR (code
);
2965 while (!scm_is_null (next
))
2967 if (SCM_IMP (SCM_CAR (code
)))
2969 if (SCM_ISYMP (SCM_CAR (code
)))
2971 scm_dynwind_begin (0);
2972 scm_i_dynwind_pthread_mutex_lock (&source_mutex
);
2973 /* check for race condition */
2974 if (SCM_ISYMP (SCM_CAR (code
)))
2975 m_expand_body (code
, env
);
2981 SCM_I_XEVAL (SCM_CAR (code
), env
, scm_debug_mode_p
);
2983 next
= SCM_CDR (code
);
2985 return SCM_I_XEVALCAR (code
, env
, scm_debug_mode_p
);
2989 /* scm_last_debug_frame contains a pointer to the last debugging information
2990 * stack frame. It is accessed very often from the debugging evaluator, so it
2991 * should probably not be indirectly addressed. Better to save and restore it
2992 * from the current root at any stack swaps.
2995 /* scm_debug_eframe_size is the number of slots available for pseudo
2996 * stack frames at each real stack frame.
2999 long scm_debug_eframe_size
;
3001 int scm_debug_mode_p
;
3002 int scm_check_entry_p
;
3003 int scm_check_apply_p
;
3004 int scm_check_exit_p
;
3005 int scm_check_memoize_p
;
3007 long scm_eval_stack
;
3009 scm_t_option scm_eval_opts
[] = {
3010 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." },
3014 scm_t_option scm_debug_opts
[] = {
3015 { SCM_OPTION_BOOLEAN
, "cheap", 1,
3016 "*This option is now obsolete. Setting it has no effect." },
3017 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
3018 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
3019 { SCM_OPTION_BOOLEAN
, "procnames", 1,
3020 "Record procedure names at definition." },
3021 { SCM_OPTION_BOOLEAN
, "backwards", 0,
3022 "Display backtrace in anti-chronological order." },
3023 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
3024 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
3025 { SCM_OPTION_INTEGER
, "frames", 3,
3026 "Maximum number of tail-recursive frames in backtrace." },
3027 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
3028 "Maximal number of stored backtrace frames." },
3029 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
3030 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
3031 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
3032 /* This default stack limit will be overridden by debug.c:init_stack_limit(),
3033 if we have getrlimit() and the stack limit is not INFINITY. But it is still
3034 important, as some systems have both the soft and the hard limits set to
3035 INFINITY; in that case we fall back to this value.
3037 The situation is aggravated by certain compilers, which can consume
3038 "beaucoup de stack", as they say in France.
3040 See http://thread.gmane.org/gmane.lisp.guile.devel/8599/focus=8662 for
3041 more discussion. This setting is 640 KB on 32-bit arches (should be enough
3042 for anyone!) or a whoppin' 1280 KB on 64-bit arches.
3044 { SCM_OPTION_INTEGER
, "stack", 160000, "Stack size limit (measured in words; 0 = no check)." },
3045 { SCM_OPTION_SCM
, "show-file-name", (unsigned long)SCM_BOOL_T
,
3046 "Show file names and line numbers "
3047 "in backtraces when not `#f'. A value of `base' "
3048 "displays only base names, while `#t' displays full names."},
3049 { SCM_OPTION_BOOLEAN
, "warn-deprecated", 0,
3050 "Warn when deprecated features are used." },
3056 * this ordering is awkward and illogical, but we maintain it for
3057 * compatibility. --hwn
3059 scm_t_option scm_evaluator_trap_table
[] = {
3060 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
3061 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
3062 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
3063 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
3064 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
3065 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
3066 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." },
3067 { SCM_OPTION_BOOLEAN
, "memoize-symbol", 0, "Trap when memoizing a symbol." },
3068 { SCM_OPTION_SCM
, "memoize-symbol-handler", (unsigned long)SCM_BOOL_F
, "The handler for memoization." },
3073 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
3075 "Option interface for the evaluation options. Instead of using\n"
3076 "this procedure directly, use the procedures @code{eval-enable},\n"
3077 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
3078 #define FUNC_NAME s_scm_eval_options_interface
3082 scm_dynwind_begin (0);
3083 scm_dynwind_critical_section (SCM_BOOL_F
);
3084 ans
= scm_options (setting
,
3087 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
3095 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
3097 "Option interface for the evaluator trap options.")
3098 #define FUNC_NAME s_scm_evaluator_traps
3103 scm_options_try (setting
,
3104 scm_evaluator_trap_table
,
3106 SCM_CRITICAL_SECTION_START
;
3107 ans
= scm_options (setting
,
3108 scm_evaluator_trap_table
,
3111 /* njrev: same again. */
3112 SCM_RESET_DEBUG_MODE
;
3113 SCM_CRITICAL_SECTION_END
;
3122 /* Simple procedure calls
3126 scm_call_0 (SCM proc
)
3128 if (SCM_PROGRAM_P (proc
))
3129 return scm_c_vm_run (scm_the_vm (), proc
, NULL
, 0);
3131 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
3135 scm_call_1 (SCM proc
, SCM arg1
)
3137 if (SCM_PROGRAM_P (proc
))
3138 return scm_c_vm_run (scm_the_vm (), proc
, &arg1
, 1);
3140 return scm_apply (proc
, arg1
, scm_listofnull
);
3144 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
3146 if (SCM_PROGRAM_P (proc
))
3148 SCM args
[] = { arg1
, arg2
};
3149 return scm_c_vm_run (scm_the_vm (), proc
, args
, 2);
3152 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
3156 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
3158 if (SCM_PROGRAM_P (proc
))
3160 SCM args
[] = { arg1
, arg2
, arg3
};
3161 return scm_c_vm_run (scm_the_vm (), proc
, args
, 3);
3164 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
3168 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
3170 if (SCM_PROGRAM_P (proc
))
3172 SCM args
[] = { arg1
, arg2
, arg3
, arg4
};
3173 return scm_c_vm_run (scm_the_vm (), proc
, args
, 4);
3176 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
3177 scm_cons (arg4
, scm_listofnull
)));
3180 /* Simple procedure applies
3184 scm_apply_0 (SCM proc
, SCM args
)
3186 return scm_apply (proc
, args
, SCM_EOL
);
3190 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
3192 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
3196 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
3198 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
3202 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
3204 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
3208 /* This code processes the arguments to apply:
3210 (apply PROC ARG1 ... ARGS)
3212 Given a list (ARG1 ... ARGS), this function conses the ARG1
3213 ... arguments onto the front of ARGS, and returns the resulting
3214 list. Note that ARGS is a list; thus, the argument to this
3215 function is a list whose last element is a list.
3217 Apply calls this function, and applies PROC to the elements of the
3218 result. apply:nconc2last takes care of building the list of
3219 arguments, given (ARG1 ... ARGS).
3221 Rather than do new consing, apply:nconc2last destroys its argument.
3222 On that topic, this code came into my care with the following
3223 beautifully cryptic comment on that topic: "This will only screw
3224 you if you do (scm_apply scm_apply '( ... ))" If you know what
3225 they're referring to, send me a patch to this comment. */
3227 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3229 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
3230 "conses the @var{arg1} @dots{} arguments onto the front of\n"
3231 "@var{args}, and returns the resulting list. Note that\n"
3232 "@var{args} is a list; thus, the argument to this function is\n"
3233 "a list whose last element is a list.\n"
3234 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
3235 "destroys its argument, so use with care.")
3236 #define FUNC_NAME s_scm_nconc2last
3239 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
3241 while (!scm_is_null (SCM_CDR (*lloc
))) /* Perhaps should be
3242 SCM_NULL_OR_NIL_P, but not
3243 needed in 99.99% of cases,
3244 and it could seriously hurt
3245 performance. - Neil */
3246 lloc
= SCM_CDRLOC (*lloc
);
3247 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3248 *lloc
= SCM_CAR (*lloc
);
3255 /* SECTION: The rest of this file is only read once.
3260 * Trampolines make it possible to move procedure application dispatch
3261 * outside inner loops. The motivation was clean implementation of
3262 * efficient replacements of R5RS primitives in SRFI-1.
3264 * The semantics is clear: scm_trampoline_N returns an optimized
3265 * version of scm_call_N (or NULL if the procedure isn't applicable
3268 * Applying the optimization to map and for-each increased efficiency
3269 * noticeably. For example, (map abs ls) is now 8 times faster than
3274 call_subr0_0 (SCM proc
)
3276 return SCM_SUBRF (proc
) ();
3280 call_subr1o_0 (SCM proc
)
3282 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
3286 call_lsubr_0 (SCM proc
)
3288 return SCM_SUBRF (proc
) (SCM_EOL
);
3292 scm_i_call_closure_0 (SCM proc
)
3294 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3297 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
3302 scm_trampoline_0 (SCM proc
)
3304 scm_t_trampoline_0 trampoline
;
3309 switch (SCM_TYP7 (proc
))
3311 case scm_tc7_subr_0
:
3312 trampoline
= call_subr0_0
;
3314 case scm_tc7_subr_1o
:
3315 trampoline
= call_subr1o_0
;
3318 trampoline
= call_lsubr_0
;
3320 case scm_tcs_closures
:
3322 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3323 if (scm_is_null (formals
) || !scm_is_pair (formals
))
3324 trampoline
= scm_i_call_closure_0
;
3329 case scm_tcs_struct
:
3330 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3331 trampoline
= scm_call_generic_0
;
3332 else if (SCM_I_OPERATORP (proc
))
3333 trampoline
= scm_call_0
;
3338 if (SCM_SMOB_APPLICABLE_P (proc
))
3339 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
3344 case scm_tc7_rpsubr
:
3347 trampoline
= scm_call_0
;
3350 return NULL
; /* not applicable on zero arguments */
3352 /* We only reach this point if a valid trampoline was determined. */
3354 /* If debugging is enabled, we want to see all calls to proc on the stack.
3355 * Thus, we replace the trampoline shortcut with scm_call_0. */
3356 if (scm_debug_mode_p
)
3363 call_subr1_1 (SCM proc
, SCM arg1
)
3365 return SCM_SUBRF (proc
) (arg1
);
3369 call_subr2o_1 (SCM proc
, SCM arg1
)
3371 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
3375 call_lsubr_1 (SCM proc
, SCM arg1
)
3377 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
3381 call_dsubr_1 (SCM proc
, SCM arg1
)
3383 if (SCM_I_INUMP (arg1
))
3385 return (scm_from_double (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
))));
3387 else if (SCM_REALP (arg1
))
3389 return (scm_from_double (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3391 else if (SCM_BIGP (arg1
))
3393 return (scm_from_double (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3395 else if (SCM_FRACTIONP (arg1
))
3397 return (scm_from_double (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
3399 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3400 SCM_ARG1
, scm_i_symbol_chars (SCM_SUBR_NAME (proc
)));
3404 call_cxr_1 (SCM proc
, SCM arg1
)
3406 return scm_i_chase_pairs (arg1
, (scm_t_bits
) SCM_SUBRF (proc
));
3410 call_closure_1 (SCM proc
, SCM arg1
)
3412 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3415 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
3420 scm_trampoline_1 (SCM proc
)
3422 scm_t_trampoline_1 trampoline
;
3427 switch (SCM_TYP7 (proc
))
3429 case scm_tc7_subr_1
:
3430 case scm_tc7_subr_1o
:
3431 trampoline
= call_subr1_1
;
3433 case scm_tc7_subr_2o
:
3434 trampoline
= call_subr2o_1
;
3437 trampoline
= call_lsubr_1
;
3440 trampoline
= call_dsubr_1
;
3443 trampoline
= call_cxr_1
;
3445 case scm_tcs_closures
:
3447 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3448 if (!scm_is_null (formals
)
3449 && (!scm_is_pair (formals
) || !scm_is_pair (SCM_CDR (formals
))))
3450 trampoline
= call_closure_1
;
3455 case scm_tcs_struct
:
3456 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3457 trampoline
= scm_call_generic_1
;
3458 else if (SCM_I_OPERATORP (proc
))
3459 trampoline
= scm_call_1
;
3464 if (SCM_SMOB_APPLICABLE_P (proc
))
3465 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
3470 case scm_tc7_rpsubr
:
3473 trampoline
= scm_call_1
;
3476 return NULL
; /* not applicable on one arg */
3478 /* We only reach this point if a valid trampoline was determined. */
3480 /* If debugging is enabled, we want to see all calls to proc on the stack.
3481 * Thus, we replace the trampoline shortcut with scm_call_1. */
3482 if (scm_debug_mode_p
)
3489 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
3491 return SCM_SUBRF (proc
) (arg1
, arg2
);
3495 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
3497 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
3501 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
3503 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
3507 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
3509 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3510 scm_list_2 (arg1
, arg2
),
3512 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
3517 scm_trampoline_2 (SCM proc
)
3519 scm_t_trampoline_2 trampoline
;
3524 switch (SCM_TYP7 (proc
))
3526 case scm_tc7_subr_2
:
3527 case scm_tc7_subr_2o
:
3528 case scm_tc7_rpsubr
:
3530 trampoline
= call_subr2_2
;
3532 case scm_tc7_lsubr_2
:
3533 trampoline
= call_lsubr2_2
;
3536 trampoline
= call_lsubr_2
;
3538 case scm_tcs_closures
:
3540 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3541 if (!scm_is_null (formals
)
3542 && (!scm_is_pair (formals
)
3543 || (!scm_is_null (SCM_CDR (formals
))
3544 && (!scm_is_pair (SCM_CDR (formals
))
3545 || !scm_is_pair (SCM_CDDR (formals
))))))
3546 trampoline
= call_closure_2
;
3551 case scm_tcs_struct
:
3552 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3553 trampoline
= scm_call_generic_2
;
3554 else if (SCM_I_OPERATORP (proc
))
3555 trampoline
= scm_call_2
;
3560 if (SCM_SMOB_APPLICABLE_P (proc
))
3561 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
3567 trampoline
= scm_call_2
;
3570 return NULL
; /* not applicable on two args */
3572 /* We only reach this point if a valid trampoline was determined. */
3574 /* If debugging is enabled, we want to see all calls to proc on the stack.
3575 * Thus, we replace the trampoline shortcut with scm_call_2. */
3576 if (scm_debug_mode_p
)
3582 /* Typechecking for multi-argument MAP and FOR-EACH.
3584 Verify that each element of the vector ARGV, except for the first,
3585 is a proper list whose length is LEN. Attribute errors to WHO,
3586 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3588 check_map_args (SCM argv
,
3597 for (i
= SCM_SIMPLE_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
3599 SCM elt
= SCM_SIMPLE_VECTOR_REF (argv
, i
);
3600 long elt_len
= scm_ilength (elt
);
3605 scm_apply_generic (gf
, scm_cons (proc
, args
));
3607 scm_wrong_type_arg (who
, i
+ 2, elt
);
3611 scm_out_of_range_pos (who
, elt
, scm_from_long (i
+ 2));
3616 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3618 /* Note: Currently, scm_map applies PROC to the argument list(s)
3619 sequentially, starting with the first element(s). This is used in
3620 evalext.c where the Scheme procedure `map-in-order', which guarantees
3621 sequential behaviour, is implemented using scm_map. If the
3622 behaviour changes, we need to update `map-in-order'.
3626 scm_map (SCM proc
, SCM arg1
, SCM args
)
3627 #define FUNC_NAME s_map
3633 len
= scm_ilength (arg1
);
3634 SCM_GASSERTn (len
>= 0,
3635 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
3636 SCM_VALIDATE_REST_ARGUMENT (args
);
3637 if (scm_is_null (args
))
3639 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
3640 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
3641 while (SCM_NIMP (arg1
))
3643 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
3644 pres
= SCM_CDRLOC (*pres
);
3645 arg1
= SCM_CDR (arg1
);
3649 if (scm_is_null (SCM_CDR (args
)))
3651 SCM arg2
= SCM_CAR (args
);
3652 int len2
= scm_ilength (arg2
);
3653 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
3655 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
3656 SCM_GASSERTn (len2
>= 0,
3657 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
3659 SCM_OUT_OF_RANGE (3, arg2
);
3660 while (SCM_NIMP (arg1
))
3662 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
3663 pres
= SCM_CDRLOC (*pres
);
3664 arg1
= SCM_CDR (arg1
);
3665 arg2
= SCM_CDR (arg2
);
3669 arg1
= scm_cons (arg1
, args
);
3670 args
= scm_vector (arg1
);
3671 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
3675 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3677 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
3680 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
3681 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
3683 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
3684 pres
= SCM_CDRLOC (*pres
);
3690 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
3693 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
3694 #define FUNC_NAME s_for_each
3697 len
= scm_ilength (arg1
);
3698 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
3699 SCM_ARG2
, s_for_each
);
3700 SCM_VALIDATE_REST_ARGUMENT (args
);
3701 if (scm_is_null (args
))
3703 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
3704 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
3705 while (SCM_NIMP (arg1
))
3707 call (proc
, SCM_CAR (arg1
));
3708 arg1
= SCM_CDR (arg1
);
3710 return SCM_UNSPECIFIED
;
3712 if (scm_is_null (SCM_CDR (args
)))
3714 SCM arg2
= SCM_CAR (args
);
3715 int len2
= scm_ilength (arg2
);
3716 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
3717 SCM_GASSERTn (call
, g_for_each
,
3718 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
3719 SCM_GASSERTn (len2
>= 0, g_for_each
,
3720 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
3722 SCM_OUT_OF_RANGE (3, arg2
);
3723 while (SCM_NIMP (arg1
))
3725 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
3726 arg1
= SCM_CDR (arg1
);
3727 arg2
= SCM_CDR (arg2
);
3729 return SCM_UNSPECIFIED
;
3731 arg1
= scm_cons (arg1
, args
);
3732 args
= scm_vector (arg1
);
3733 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
3737 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3739 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
3741 return SCM_UNSPECIFIED
;
3742 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
3743 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
3745 scm_apply (proc
, arg1
, SCM_EOL
);
3752 scm_closure (SCM code
, SCM env
)
3755 SCM closcar
= scm_cons (code
, SCM_EOL
);
3756 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
3757 scm_remember_upto_here (closcar
);
3762 scm_t_bits scm_tc16_promise
;
3764 SCM_DEFINE (scm_make_promise
, "make-promise", 1, 0, 0,
3766 "Create a new promise object.\n\n"
3767 "@code{make-promise} is a procedural form of @code{delay}.\n"
3768 "These two expressions are equivalent:\n"
3770 "(delay @var{exp})\n"
3771 "(make-promise (lambda () @var{exp}))\n"
3773 #define FUNC_NAME s_scm_make_promise
3775 SCM_VALIDATE_THUNK (1, thunk
);
3776 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
3778 scm_make_recursive_mutex ());
3783 promise_mark (SCM promise
)
3785 scm_gc_mark (SCM_PROMISE_MUTEX (promise
));
3786 return SCM_PROMISE_DATA (promise
);
3790 promise_free (SCM promise
)
3796 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
3798 int writingp
= SCM_WRITINGP (pstate
);
3799 scm_puts ("#<promise ", port
);
3800 SCM_SET_WRITINGP (pstate
, 1);
3801 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
3802 SCM_SET_WRITINGP (pstate
, writingp
);
3803 scm_putc ('>', port
);
3807 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
3809 "If the promise @var{x} has not been computed yet, compute and\n"
3810 "return @var{x}, otherwise just return the previously computed\n"
3812 #define FUNC_NAME s_scm_force
3814 SCM_VALIDATE_SMOB (1, promise
, promise
);
3815 scm_lock_mutex (SCM_PROMISE_MUTEX (promise
));
3816 if (!SCM_PROMISE_COMPUTED_P (promise
))
3818 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
3819 if (!SCM_PROMISE_COMPUTED_P (promise
))
3821 SCM_SET_PROMISE_DATA (promise
, ans
);
3822 SCM_SET_PROMISE_COMPUTED (promise
);
3825 scm_unlock_mutex (SCM_PROMISE_MUTEX (promise
));
3826 return SCM_PROMISE_DATA (promise
);
3831 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
3833 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
3834 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
3835 #define FUNC_NAME s_scm_promise_p
3837 return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
3842 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
3843 (SCM xorig
, SCM x
, SCM y
),
3844 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
3845 "Any source properties associated with @var{xorig} are also associated\n"
3846 "with the new pair.")
3847 #define FUNC_NAME s_scm_cons_source
3850 z
= scm_cons (x
, y
);
3851 /* Copy source properties possibly associated with xorig. */
3852 p
= scm_whash_lookup (scm_source_whash
, xorig
);
3853 if (scm_is_true (p
))
3854 scm_whash_insert (scm_source_whash
, z
, p
);
3860 /* The function scm_copy_tree is used to copy an expression tree to allow the
3861 * memoizer to modify the expression during memoization. scm_copy_tree
3862 * creates deep copies of pairs and vectors, but not of any other data types,
3863 * since only pairs and vectors will be parsed by the memoizer.
3865 * To avoid infinite recursion due to cyclic structures, the hare-and-tortoise
3866 * pattern is used to detect cycles. In fact, the pattern is used in two
3867 * dimensions, vertical (indicated in the code by the variable names 'hare'
3868 * and 'tortoise') and horizontal ('rabbit' and 'turtle'). In both
3869 * dimensions, the hare/rabbit will take two steps when the tortoise/turtle
3872 * The vertical dimension corresponds to recursive calls to function
3873 * copy_tree: This happens when descending into vector elements, into cars of
3874 * lists and into the cdr of an improper list. In this dimension, the
3875 * tortoise follows the hare by using the processor stack: Every stack frame
3876 * will hold an instance of struct t_trace. These instances are connected in
3877 * a way that represents the trace of the hare, which thus can be followed by
3878 * the tortoise. The tortoise will always point to struct t_trace instances
3879 * relating to SCM objects that have already been copied. Thus, a cycle is
3880 * detected if the tortoise and the hare point to the same object,
3882 * The horizontal dimension is within one execution of copy_tree, when the
3883 * function cdr's along the pairs of a list. This is the standard
3884 * hare-and-tortoise implementation, found several times in guile. */
3887 struct t_trace
*trace
; /* These pointers form a trace along the stack. */
3888 SCM obj
; /* The object handled at the respective stack frame.*/
3893 struct t_trace
*const hare
,
3894 struct t_trace
*tortoise
,
3895 unsigned int tortoise_delay
)
3897 if (!scm_is_pair (hare
->obj
) && !scm_is_simple_vector (hare
->obj
))
3903 /* Prepare the trace along the stack. */
3904 struct t_trace new_hare
;
3905 hare
->trace
= &new_hare
;
3907 /* The tortoise will make its step after the delay has elapsed. Note
3908 * that in contrast to the typical hare-and-tortoise pattern, the step
3909 * of the tortoise happens before the hare takes its steps. This is, in
3910 * principle, no problem, except for the start of the algorithm: Then,
3911 * it has to be made sure that the hare actually gets its advantage of
3913 if (tortoise_delay
== 0)
3916 tortoise
= tortoise
->trace
;
3917 ASSERT_SYNTAX (!scm_is_eq (hare
->obj
, tortoise
->obj
),
3918 s_bad_expression
, hare
->obj
);
3925 if (scm_is_simple_vector (hare
->obj
))
3927 size_t length
= SCM_SIMPLE_VECTOR_LENGTH (hare
->obj
);
3928 SCM new_vector
= scm_c_make_vector (length
, SCM_UNSPECIFIED
);
3930 /* Each vector element is copied by recursing into copy_tree, having
3931 * the tortoise follow the hare into the depths of the stack. */
3932 unsigned long int i
;
3933 for (i
= 0; i
< length
; ++i
)
3936 new_hare
.obj
= SCM_SIMPLE_VECTOR_REF (hare
->obj
, i
);
3937 new_element
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3938 SCM_SIMPLE_VECTOR_SET (new_vector
, i
, new_element
);
3943 else /* scm_is_pair (hare->obj) */
3948 SCM rabbit
= hare
->obj
;
3949 SCM turtle
= hare
->obj
;
3953 /* The first pair of the list is treated specially, in order to
3954 * preserve a potential source code position. */
3955 result
= tail
= scm_cons_source (rabbit
, SCM_EOL
, SCM_EOL
);
3956 new_hare
.obj
= SCM_CAR (rabbit
);
3957 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3958 SCM_SETCAR (tail
, copy
);
3960 /* The remaining pairs of the list are copied by, horizontally,
3961 * having the turtle follow the rabbit, and, vertically, having the
3962 * tortoise follow the hare into the depths of the stack. */
3963 rabbit
= SCM_CDR (rabbit
);
3964 while (scm_is_pair (rabbit
))
3966 new_hare
.obj
= SCM_CAR (rabbit
);
3967 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3968 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
3969 tail
= SCM_CDR (tail
);
3971 rabbit
= SCM_CDR (rabbit
);
3972 if (scm_is_pair (rabbit
))
3974 new_hare
.obj
= SCM_CAR (rabbit
);
3975 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3976 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
3977 tail
= SCM_CDR (tail
);
3978 rabbit
= SCM_CDR (rabbit
);
3980 turtle
= SCM_CDR (turtle
);
3981 ASSERT_SYNTAX (!scm_is_eq (rabbit
, turtle
),
3982 s_bad_expression
, rabbit
);
3986 /* We have to recurse into copy_tree again for the last cdr, in
3987 * order to handle the situation that it holds a vector. */
3988 new_hare
.obj
= rabbit
;
3989 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3990 SCM_SETCDR (tail
, copy
);
3997 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
3999 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
4000 "the new data structure. @code{copy-tree} recurses down the\n"
4001 "contents of both pairs and vectors (since both cons cells and vector\n"
4002 "cells may point to arbitrary objects), and stops recursing when it hits\n"
4003 "any other object.")
4004 #define FUNC_NAME s_scm_copy_tree
4006 /* Prepare the trace along the stack. */
4007 struct t_trace trace
;
4010 /* In function copy_tree, if the tortoise makes its step, it will do this
4011 * before the hare has the chance to move. Thus, we have to make sure that
4012 * the very first step of the tortoise will not happen after the hare has
4013 * really made two steps. This is achieved by passing '2' as the initial
4014 * delay for the tortoise. NOTE: Since cycles are unlikely, giving the hare
4015 * a bigger advantage may improve performance slightly. */
4016 return copy_tree (&trace
, &trace
, 2);
4021 /* We have three levels of EVAL here:
4023 - scm_i_eval (exp, env)
4025 evaluates EXP in environment ENV. ENV is a lexical environment
4026 structure as used by the actual tree code evaluator. When ENV is
4027 a top-level environment, then changes to the current module are
4028 tracked by updating ENV so that it continues to be in sync with
4031 - scm_primitive_eval (exp)
4033 evaluates EXP in the top-level environment as determined by the
4034 current module. This is done by constructing a suitable
4035 environment and calling scm_i_eval. Thus, changes to the
4036 top-level module are tracked normally.
4038 - scm_eval (exp, mod_or_state)
4040 evaluates EXP while MOD_OR_STATE is the current module or current
4041 dynamic state (as appropriate). This is done by setting the
4042 current module (or dynamic state) to MOD_OR_STATE, invoking
4043 scm_primitive_eval on EXP, and then restoring the current module
4044 (or dynamic state) to the value it had previously. That is,
4045 while EXP is evaluated, changes to the current module (or dynamic
4046 state) are tracked, but these changes do not persist when
4049 For each level of evals, there are two variants, distinguished by a
4050 _x suffix: the ordinary variant does not modify EXP while the _x
4051 variant can destructively modify EXP into something completely
4052 unintelligible. A Scheme data structure passed as EXP to one of the
4053 _x variants should not ever be used again for anything. So when in
4054 doubt, use the ordinary variant.
4059 scm_i_eval_x (SCM exp
, SCM env
)
4061 if (scm_is_symbol (exp
))
4062 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
4064 return SCM_I_XEVAL (exp
, env
, scm_debug_mode_p
);
4068 scm_i_eval (SCM exp
, SCM env
)
4070 exp
= scm_copy_tree (exp
);
4071 if (scm_is_symbol (exp
))
4072 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
4074 return SCM_I_XEVAL (exp
, env
, scm_debug_mode_p
);
4078 scm_primitive_eval_x (SCM exp
)
4081 SCM transformer
= scm_current_module_transformer ();
4082 if (SCM_NIMP (transformer
))
4083 exp
= scm_call_1 (transformer
, exp
);
4084 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4085 return scm_i_eval_x (exp
, env
);
4088 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
4090 "Evaluate @var{exp} in the top-level environment specified by\n"
4091 "the current module.")
4092 #define FUNC_NAME s_scm_primitive_eval
4095 SCM transformer
= scm_current_module_transformer ();
4096 if (scm_is_true (transformer
))
4097 exp
= scm_call_1 (transformer
, exp
);
4098 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4099 return scm_i_eval (exp
, env
);
4104 /* Eval does not take the second arg optionally. This is intentional
4105 * in order to be R5RS compatible, and to prepare for the new module
4106 * system, where we would like to make the choice of evaluation
4107 * environment explicit. */
4110 scm_eval_x (SCM exp
, SCM module_or_state
)
4114 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
4115 if (scm_is_dynamic_state (module_or_state
))
4116 scm_dynwind_current_dynamic_state (module_or_state
);
4118 scm_dynwind_current_module (module_or_state
);
4120 res
= scm_primitive_eval_x (exp
);
4126 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
4127 (SCM exp
, SCM module_or_state
),
4128 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
4129 "in the top-level environment specified by\n"
4130 "@var{module_or_state}.\n"
4131 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
4132 "@var{module_or_state} is made the current module when\n"
4133 "it is a module, or the current dynamic state when it is\n"
4135 "Example: (eval '(+ 1 2) (interaction-environment))")
4136 #define FUNC_NAME s_scm_eval
4140 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
4141 if (scm_is_dynamic_state (module_or_state
))
4142 scm_dynwind_current_dynamic_state (module_or_state
);
4143 else if (scm_module_system_booted_p
)
4145 SCM_VALIDATE_MODULE (2, module_or_state
);
4146 scm_dynwind_current_module (module_or_state
);
4148 /* otherwise if the module system isn't booted, ignore the module arg */
4150 res
= scm_primitive_eval (exp
);
4158 /* At this point, deval and scm_dapply are generated.
4170 scm_i_pthread_mutex_init (&source_mutex
,
4171 scm_i_pthread_mutexattr_recursive
);
4173 scm_init_opts (scm_evaluator_traps
,
4174 scm_evaluator_trap_table
);
4175 scm_init_opts (scm_eval_options_interface
,
4178 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
4179 scm_set_smob_mark (scm_tc16_promise
, promise_mark
);
4180 scm_set_smob_free (scm_tc16_promise
, promise_free
);
4181 scm_set_smob_print (scm_tc16_promise
, promise_print
);
4183 undefineds
= scm_list_1 (SCM_UNDEFINED
);
4184 SCM_SETCDR (undefineds
, undefineds
);
4185 scm_permanent_object (undefineds
);
4187 scm_listofnull
= scm_list_1 (SCM_EOL
);
4189 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
4190 scm_permanent_object (f_apply
);
4192 #include "libguile/eval.x"
4194 scm_add_feature ("delay");