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