1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007
2 * Free Software Foundation, Inc.
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public
6 * License as published by the Free Software Foundation; either
7 * version 2.1 of the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
23 /* SECTION: This code is compiled once.
32 #include "libguile/__scm.h"
35 #include "libguile/_scm.h"
36 #include "libguile/alist.h"
37 #include "libguile/async.h"
38 #include "libguile/continuations.h"
39 #include "libguile/debug.h"
40 #include "libguile/deprecation.h"
41 #include "libguile/dynwind.h"
42 #include "libguile/eq.h"
43 #include "libguile/feature.h"
44 #include "libguile/fluids.h"
45 #include "libguile/futures.h"
46 #include "libguile/goops.h"
47 #include "libguile/hash.h"
48 #include "libguile/hashtab.h"
49 #include "libguile/lang.h"
50 #include "libguile/list.h"
51 #include "libguile/macros.h"
52 #include "libguile/modules.h"
53 #include "libguile/objects.h"
54 #include "libguile/ports.h"
55 #include "libguile/print.h"
56 #include "libguile/procprop.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"
68 #include "libguile/eval.h"
69 #include "libguile/private-options.h"
74 static SCM
unmemoize_exprs (SCM expr
, SCM env
);
75 static SCM
canonicalize_define (SCM expr
);
76 static SCM
*scm_lookupcar1 (SCM vloc
, SCM genv
, int check
);
77 static SCM
unmemoize_builtin_macro (SCM expr
, SCM env
);
78 static void ceval_letrec_inits (SCM env
, SCM init_forms
, SCM
**init_values_eol
);
79 static SCM
ceval (SCM x
, SCM env
);
80 static SCM
deval (SCM x
, SCM env
);
86 * This section defines the message strings for the syntax errors that can be
87 * detected during memoization and the functions and macros that shall be
88 * called by the memoizer code to signal syntax errors. */
91 /* Syntax errors that can be detected during memoization: */
93 /* Circular or improper lists do not form valid scheme expressions. If a
94 * circular list or an improper list is detected in a place where a scheme
95 * expression is expected, a 'Bad expression' error is signalled. */
96 static const char s_bad_expression
[] = "Bad expression";
98 /* If a form is detected that holds a different number of expressions than are
99 * required in that context, a 'Missing or extra expression' error is
101 static const char s_expression
[] = "Missing or extra expression in";
103 /* If a form is detected that holds less expressions than are required in that
104 * context, a 'Missing expression' error is signalled. */
105 static const char s_missing_expression
[] = "Missing expression in";
107 /* If a form is detected that holds more expressions than are allowed in that
108 * context, an 'Extra expression' error is signalled. */
109 static const char s_extra_expression
[] = "Extra expression in";
111 /* The empty combination '()' is not allowed as an expression in scheme. If
112 * it is detected in a place where an expression is expected, an 'Illegal
113 * empty combination' error is signalled. Note: If you encounter this error
114 * message, it is very likely that you intended to denote the empty list. To
115 * do so, you need to quote the empty list like (quote ()) or '(). */
116 static const char s_empty_combination
[] = "Illegal empty combination";
118 /* A body may hold an arbitrary number of internal defines, followed by a
119 * non-empty sequence of expressions. If a body with an empty sequence of
120 * expressions is detected, a 'Missing body expression' error is signalled.
122 static const char s_missing_body_expression
[] = "Missing body expression in";
124 /* A body may hold an arbitrary number of internal defines, followed by a
125 * non-empty sequence of expressions. Each the definitions and the
126 * expressions may be grouped arbitraryly with begin, but it is not allowed to
127 * mix definitions and expressions. If a define form in a body mixes
128 * definitions and expressions, a 'Mixed definitions and expressions' error is
130 static const char s_mixed_body_forms
[] = "Mixed definitions and expressions in";
131 /* Definitions are only allowed on the top level and at the start of a body.
132 * If a definition is detected anywhere else, a 'Bad define placement' error
134 static const char s_bad_define
[] = "Bad define placement";
136 /* Case or cond expressions must have at least one clause. If a case or cond
137 * expression without any clauses is detected, a 'Missing clauses' error is
139 static const char s_missing_clauses
[] = "Missing clauses";
141 /* If there is an 'else' clause in a case or a cond statement, it must be the
142 * last clause. If after the 'else' case clause further clauses are detected,
143 * a 'Misplaced else clause' error is signalled. */
144 static const char s_misplaced_else_clause
[] = "Misplaced else clause";
146 /* If a case clause is detected that is not in the format
147 * (<label(s)> <expression1> <expression2> ...)
148 * a 'Bad case clause' error is signalled. */
149 static const char s_bad_case_clause
[] = "Bad case clause";
151 /* If a case clause is detected where the <label(s)> element is neither a
152 * proper list nor (in case of the last clause) the syntactic keyword 'else',
153 * a 'Bad case labels' error is signalled. Note: If you encounter this error
154 * for an else-clause which seems to be syntactically correct, check if 'else'
155 * is really a syntactic keyword in that context. If 'else' is bound in the
156 * local or global environment, it is not considered a syntactic keyword, but
157 * will be treated as any other variable. */
158 static const char s_bad_case_labels
[] = "Bad case labels";
160 /* In a case statement all labels have to be distinct. If in a case statement
161 * a label occurs more than once, a 'Duplicate case label' error is
163 static const char s_duplicate_case_label
[] = "Duplicate case label";
165 /* If a cond clause is detected that is not in one of the formats
166 * (<test> <expression1> ...) or (else <expression1> <expression2> ...)
167 * a 'Bad cond clause' error is signalled. */
168 static const char s_bad_cond_clause
[] = "Bad cond clause";
170 /* If a cond clause is detected that uses the alternate '=>' form, but does
171 * not hold a recipient element for the test result, a 'Missing recipient'
172 * error is signalled. */
173 static const char s_missing_recipient
[] = "Missing recipient in";
175 /* If in a position where a variable name is required some other object is
176 * detected, a 'Bad variable' error is signalled. */
177 static const char s_bad_variable
[] = "Bad variable";
179 /* Bindings for forms like 'let' and 'do' have to be given in a proper,
180 * possibly empty list. If any other object is detected in a place where a
181 * list of bindings was required, a 'Bad bindings' error is signalled. */
182 static const char s_bad_bindings
[] = "Bad bindings";
184 /* Depending on the syntactic context, a binding has to be in the format
185 * (<variable> <expression>) or (<variable> <expression1> <expression2>).
186 * If anything else is detected in a place where a binding was expected, a
187 * 'Bad binding' error is signalled. */
188 static const char s_bad_binding
[] = "Bad binding";
190 /* Some syntactic forms don't allow variable names to appear more than once in
191 * a list of bindings. If such a situation is nevertheless detected, a
192 * 'Duplicate binding' error is signalled. */
193 static const char s_duplicate_binding
[] = "Duplicate binding";
195 /* If the exit form of a 'do' expression is not in the format
196 * (<test> <expression> ...)
197 * a 'Bad exit clause' error is signalled. */
198 static const char s_bad_exit_clause
[] = "Bad exit clause";
200 /* The formal function arguments of a lambda expression have to be either a
201 * single symbol or a non-cyclic list. For anything else a 'Bad formals'
202 * error is signalled. */
203 static const char s_bad_formals
[] = "Bad formals";
205 /* If in a lambda expression something else than a symbol is detected at a
206 * place where a formal function argument is required, a 'Bad formal' error is
208 static const char s_bad_formal
[] = "Bad formal";
210 /* If in the arguments list of a lambda expression an argument name occurs
211 * more than once, a 'Duplicate formal' error is signalled. */
212 static const char s_duplicate_formal
[] = "Duplicate formal";
214 /* If the evaluation of an unquote-splicing expression gives something else
215 * than a proper list, a 'Non-list result for unquote-splicing' error is
217 static const char s_splicing
[] = "Non-list result for unquote-splicing";
219 /* If something else than an exact integer is detected as the argument for
220 * @slot-ref and @slot-set!, a 'Bad slot number' error is signalled. */
221 static const char s_bad_slot_number
[] = "Bad slot number";
224 /* Signal a syntax error. We distinguish between the form that caused the
225 * error and the enclosing expression. The error message will print out as
226 * shown in the following pattern. The file name and line number are only
227 * given when they can be determined from the erroneous form or from the
228 * enclosing expression.
230 * <filename>: In procedure memoization:
231 * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
233 SCM_SYMBOL (syntax_error_key
, "syntax-error");
235 /* The prototype is needed to indicate that the function does not return. */
237 syntax_error (const char* const, const SCM
, const SCM
) SCM_NORETURN
;
240 syntax_error (const char* const msg
, const SCM form
, const SCM expr
)
242 SCM msg_string
= scm_from_locale_string (msg
);
243 SCM filename
= SCM_BOOL_F
;
244 SCM linenr
= SCM_BOOL_F
;
248 if (scm_is_pair (form
))
250 filename
= scm_source_property (form
, scm_sym_filename
);
251 linenr
= scm_source_property (form
, scm_sym_line
);
254 if (scm_is_false (filename
) && scm_is_false (linenr
) && scm_is_pair (expr
))
256 filename
= scm_source_property (expr
, scm_sym_filename
);
257 linenr
= scm_source_property (expr
, scm_sym_line
);
260 if (!SCM_UNBNDP (expr
))
262 if (scm_is_true (filename
))
264 format
= "In file ~S, line ~S: ~A ~S in expression ~S.";
265 args
= scm_list_5 (filename
, linenr
, msg_string
, form
, expr
);
267 else if (scm_is_true (linenr
))
269 format
= "In line ~S: ~A ~S in expression ~S.";
270 args
= scm_list_4 (linenr
, msg_string
, form
, expr
);
274 format
= "~A ~S in expression ~S.";
275 args
= scm_list_3 (msg_string
, form
, expr
);
280 if (scm_is_true (filename
))
282 format
= "In file ~S, line ~S: ~A ~S.";
283 args
= scm_list_4 (filename
, linenr
, msg_string
, form
);
285 else if (scm_is_true (linenr
))
287 format
= "In line ~S: ~A ~S.";
288 args
= scm_list_3 (linenr
, msg_string
, form
);
293 args
= scm_list_2 (msg_string
, form
);
297 scm_error (syntax_error_key
, "memoization", format
, args
, SCM_BOOL_F
);
301 /* Shortcut macros to simplify syntax error handling. */
302 #define ASSERT_SYNTAX(cond, message, form) \
303 { if (SCM_UNLIKELY (!(cond))) \
304 syntax_error (message, form, SCM_UNDEFINED); }
305 #define ASSERT_SYNTAX_2(cond, message, form, expr) \
306 { if (SCM_UNLIKELY (!(cond))) \
307 syntax_error (message, form, expr); }
313 * Ilocs are memoized references to variables in local environment frames.
314 * They are represented as three values: The relative offset of the
315 * environment frame, the number of the binding within that frame, and a
316 * boolean value indicating whether the binding is the last binding in the
319 * Frame numbers have 11 bits, relative offsets have 12 bits.
322 #define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc)
323 #define SCM_IFRINC (0x00000100L)
324 #define SCM_ICDR (0x00080000L)
325 #define SCM_IDINC (0x00100000L)
326 #define SCM_IFRAME(n) ((long)((SCM_ICDR-SCM_IFRINC)>>8) \
327 & (SCM_UNPACK (n) >> 8))
328 #define SCM_IDIST(n) (SCM_UNPACK (n) >> 20)
329 #define SCM_ICDRP(n) (SCM_ICDR & SCM_UNPACK (n))
330 #define SCM_IDSTMSK (-SCM_IDINC)
331 #define SCM_IFRAMEMAX ((1<<11)-1)
332 #define SCM_IDISTMAX ((1<<12)-1)
333 #define SCM_MAKE_ILOC(frame_nr, binding_nr, last_p) \
336 + ((binding_nr) << 20) \
337 + ((last_p) ? SCM_ICDR : 0) \
341 scm_i_print_iloc (SCM iloc
, SCM port
)
343 scm_puts ("#@", port
);
344 scm_intprint ((long) SCM_IFRAME (iloc
), 10, port
);
345 scm_putc (SCM_ICDRP (iloc
) ? '-' : '+', port
);
346 scm_intprint ((long) SCM_IDIST (iloc
), 10, port
);
349 #if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
351 SCM
scm_dbg_make_iloc (SCM frame
, SCM binding
, SCM cdrp
);
353 SCM_DEFINE (scm_dbg_make_iloc
, "dbg-make-iloc", 3, 0, 0,
354 (SCM frame
, SCM binding
, SCM cdrp
),
355 "Return a new iloc with frame offset @var{frame}, binding\n"
356 "offset @var{binding} and the cdr flag @var{cdrp}.")
357 #define FUNC_NAME s_scm_dbg_make_iloc
359 return SCM_MAKE_ILOC ((scm_t_bits
) scm_to_unsigned_integer (frame
, 0, SCM_IFRAMEMAX
),
360 (scm_t_bits
) scm_to_unsigned_integer (binding
, 0, SCM_IDISTMAX
),
365 SCM
scm_dbg_iloc_p (SCM obj
);
367 SCM_DEFINE (scm_dbg_iloc_p
, "dbg-iloc?", 1, 0, 0,
369 "Return @code{#t} if @var{obj} is an iloc.")
370 #define FUNC_NAME s_scm_dbg_iloc_p
372 return scm_from_bool (SCM_ILOCP (obj
));
380 /* {Evaluator byte codes (isyms)}
383 #define ISYMNUM(n) (SCM_ITAG8_DATA (n))
385 /* This table must agree with the list of SCM_IM_ constants in tags.h */
386 static const char *const isymnames
[] =
403 "#@call-with-current-continuation",
409 "#@call-with-values",
417 scm_i_print_isym (SCM isym
, SCM port
)
419 const size_t isymnum
= ISYMNUM (isym
);
420 if (isymnum
< (sizeof isymnames
/ sizeof (char *)))
421 scm_puts (isymnames
[isymnum
], port
);
423 scm_ipruk ("isym", isym
, port
);
428 /* The function lookup_symbol is used during memoization: Lookup the symbol in
429 * the environment. If there is no binding for the symbol, SCM_UNDEFINED is
430 * returned. If the symbol is a global variable, the variable object to which
431 * the symbol is bound is returned. Finally, if the symbol is a local
432 * variable the corresponding iloc object is returned. */
434 /* A helper function for lookup_symbol: Try to find the symbol in the top
435 * level environment frame. The function returns SCM_UNDEFINED if the symbol
436 * is unbound and it returns a variable object if the symbol is a global
439 lookup_global_symbol (const SCM symbol
, const SCM top_level
)
441 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
442 if (scm_is_false (variable
))
443 return SCM_UNDEFINED
;
449 lookup_symbol (const SCM symbol
, const SCM env
)
452 unsigned int frame_nr
;
454 for (frame_idx
= env
, frame_nr
= 0;
455 !scm_is_null (frame_idx
);
456 frame_idx
= SCM_CDR (frame_idx
), ++frame_nr
)
458 const SCM frame
= SCM_CAR (frame_idx
);
459 if (scm_is_pair (frame
))
461 /* frame holds a local environment frame */
463 unsigned int symbol_nr
;
465 for (symbol_idx
= SCM_CAR (frame
), symbol_nr
= 0;
466 scm_is_pair (symbol_idx
);
467 symbol_idx
= SCM_CDR (symbol_idx
), ++symbol_nr
)
469 if (scm_is_eq (SCM_CAR (symbol_idx
), symbol
))
470 /* found the symbol, therefore return the iloc */
471 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 0);
473 if (scm_is_eq (symbol_idx
, symbol
))
474 /* found the symbol as the last element of the current frame */
475 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 1);
479 /* no more local environment frames */
480 return lookup_global_symbol (symbol
, frame
);
484 return lookup_global_symbol (symbol
, SCM_BOOL_F
);
488 /* Return true if the symbol is - from the point of view of a macro
489 * transformer - a literal in the sense specified in chapter "pattern
490 * language" of R5RS. In the code below, however, we don't match the
491 * definition of R5RS exactly: It returns true if the identifier has no
492 * binding or if it is a syntactic keyword. */
494 literal_p (const SCM symbol
, const SCM env
)
496 const SCM variable
= lookup_symbol (symbol
, env
);
497 if (SCM_UNBNDP (variable
))
499 if (SCM_VARIABLEP (variable
) && SCM_MACROP (SCM_VARIABLE_REF (variable
)))
506 /* Return true if the expression is self-quoting in the memoized code. Thus,
507 * some other objects (like e. g. vectors) are reported as self-quoting, which
508 * according to R5RS would need to be quoted. */
510 is_self_quoting_p (const SCM expr
)
512 if (scm_is_pair (expr
))
514 else if (scm_is_symbol (expr
))
516 else if (scm_is_null (expr
))
522 SCM_SYMBOL (sym_three_question_marks
, "???");
525 unmemoize_expression (const SCM expr
, const SCM env
)
527 if (SCM_ILOCP (expr
))
530 unsigned long int frame_nr
;
532 unsigned long int symbol_nr
;
534 for (frame_idx
= env
, frame_nr
= SCM_IFRAME (expr
);
536 frame_idx
= SCM_CDR (frame_idx
), --frame_nr
)
538 for (symbol_idx
= SCM_CAAR (frame_idx
), symbol_nr
= SCM_IDIST (expr
);
540 symbol_idx
= SCM_CDR (symbol_idx
), --symbol_nr
)
542 return SCM_ICDRP (expr
) ? symbol_idx
: SCM_CAR (symbol_idx
);
544 else if (SCM_VARIABLEP (expr
))
546 const SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), expr
);
547 return scm_is_true (sym
) ? sym
: sym_three_question_marks
;
549 else if (scm_is_simple_vector (expr
))
551 return scm_list_2 (scm_sym_quote
, expr
);
553 else if (!scm_is_pair (expr
))
557 else if (SCM_ISYMP (SCM_CAR (expr
)))
559 return unmemoize_builtin_macro (expr
, env
);
563 return unmemoize_exprs (expr
, env
);
569 unmemoize_exprs (const SCM exprs
, const SCM env
)
571 SCM r_result
= SCM_EOL
;
572 SCM expr_idx
= exprs
;
575 /* Note that due to the current lazy memoizer we may find partially memoized
576 * code during execution. In such code we have to expect improper lists of
577 * expressions: On the one hand, for such code syntax checks have not yet
578 * fully been performed, on the other hand, there may be even legal code
579 * like '(a . b) appear as an improper list of expressions as long as the
580 * quote expression is still in its unmemoized form. For this reason, the
581 * following code handles improper lists of expressions until memoization
582 * and execution have been completely separated. */
583 for (; scm_is_pair (expr_idx
); expr_idx
= SCM_CDR (expr_idx
))
585 const SCM expr
= SCM_CAR (expr_idx
);
587 /* In partially memoized code, lists of expressions that stem from a
588 * body form may start with an ISYM if the body itself has not yet been
589 * memoized. This isym is just an internal marker to indicate that the
590 * body still needs to be memoized. An isym may occur at the very
591 * beginning of the body or after one or more comment strings. It is
592 * dropped during unmemoization. */
593 if (!SCM_ISYMP (expr
))
595 um_expr
= unmemoize_expression (expr
, env
);
596 r_result
= scm_cons (um_expr
, r_result
);
599 um_expr
= unmemoize_expression (expr_idx
, env
);
600 if (!scm_is_null (r_result
))
602 const SCM result
= scm_reverse_x (r_result
, SCM_UNDEFINED
);
603 SCM_SETCDR (r_result
, um_expr
);
613 /* Rewrite the body (which is given as the list of expressions forming the
614 * body) into its internal form. The internal form of a body (<expr> ...) is
615 * just the body itself, but prefixed with an ISYM that denotes to what kind
616 * of outer construct this body belongs: (<ISYM> <expr> ...). A lambda body
617 * starts with SCM_IM_LAMBDA, for example, a body of a let starts with
620 * It is assumed that the calling expression has already made sure that the
621 * body is a proper list. */
623 m_body (SCM op
, SCM exprs
)
625 /* Don't add another ISYM if one is present already. */
626 if (SCM_ISYMP (SCM_CAR (exprs
)))
629 return scm_cons (op
, exprs
);
633 /* The function m_expand_body memoizes a proper list of expressions forming a
634 * body. This function takes care of dealing with internal defines and
635 * transforming them into an equivalent letrec expression. The list of
636 * expressions is rewritten in place. */
638 /* This is a helper function for m_expand_body. If the argument expression is
639 * a symbol that denotes a syntactic keyword, the corresponding macro object
640 * is returned, in all other cases the function returns SCM_UNDEFINED. */
642 try_macro_lookup (const SCM expr
, const SCM env
)
644 if (scm_is_symbol (expr
))
646 const SCM variable
= lookup_symbol (expr
, env
);
647 if (SCM_VARIABLEP (variable
))
649 const SCM value
= SCM_VARIABLE_REF (variable
);
650 if (SCM_MACROP (value
))
655 return SCM_UNDEFINED
;
658 /* This is a helper function for m_expand_body. It expands user macros,
659 * because for the correct translation of a body we need to know whether they
660 * expand to a definition. */
662 expand_user_macros (SCM expr
, const SCM env
)
664 while (scm_is_pair (expr
))
666 const SCM car_expr
= SCM_CAR (expr
);
667 const SCM new_car
= expand_user_macros (car_expr
, env
);
668 const SCM value
= try_macro_lookup (new_car
, env
);
670 if (SCM_MACROP (value
) && SCM_MACRO_TYPE (value
) == 2)
672 /* User macros transform code into code. */
673 expr
= scm_call_2 (SCM_MACRO_CODE (value
), expr
, env
);
674 /* We need to reiterate on the transformed code. */
678 /* No user macro: return. */
679 SCM_SETCAR (expr
, new_car
);
687 /* This is a helper function for m_expand_body. It determines if a given form
688 * represents an application of a given built-in macro. The built-in macro to
689 * check for is identified by its syntactic keyword. The form is an
690 * application of the given macro if looking up the car of the form in the
691 * given environment actually returns the built-in macro. */
693 is_system_macro_p (const SCM syntactic_keyword
, const SCM form
, const SCM env
)
695 if (scm_is_pair (form
))
697 const SCM car_form
= SCM_CAR (form
);
698 const SCM value
= try_macro_lookup (car_form
, env
);
699 if (SCM_BUILTIN_MACRO_P (value
))
701 const SCM macro_name
= scm_macro_name (value
);
702 return scm_is_eq (macro_name
, syntactic_keyword
);
710 m_expand_body (const SCM forms
, const SCM env
)
712 /* The first body form can be skipped since it is known to be the ISYM that
713 * was prepended to the body by m_body. */
714 SCM cdr_forms
= SCM_CDR (forms
);
715 SCM form_idx
= cdr_forms
;
716 SCM definitions
= SCM_EOL
;
717 SCM sequence
= SCM_EOL
;
719 /* According to R5RS, the list of body forms consists of two parts: a number
720 * (maybe zero) of definitions, followed by a non-empty sequence of
721 * expressions. Each the definitions and the expressions may be grouped
722 * arbitrarily with begin, but it is not allowed to mix definitions and
723 * expressions. The task of the following loop therefore is to split the
724 * list of body forms into the list of definitions and the sequence of
726 while (!scm_is_null (form_idx
))
728 const SCM form
= SCM_CAR (form_idx
);
729 const SCM new_form
= expand_user_macros (form
, env
);
730 if (is_system_macro_p (scm_sym_define
, new_form
, env
))
732 definitions
= scm_cons (new_form
, definitions
);
733 form_idx
= SCM_CDR (form_idx
);
735 else if (is_system_macro_p (scm_sym_begin
, new_form
, env
))
737 /* We have encountered a group of forms. This has to be either a
738 * (possibly empty) group of (possibly further grouped) definitions,
739 * or a non-empty group of (possibly further grouped)
741 const SCM grouped_forms
= SCM_CDR (new_form
);
742 unsigned int found_definition
= 0;
743 unsigned int found_expression
= 0;
744 SCM grouped_form_idx
= grouped_forms
;
745 while (!found_expression
&& !scm_is_null (grouped_form_idx
))
747 const SCM inner_form
= SCM_CAR (grouped_form_idx
);
748 const SCM new_inner_form
= expand_user_macros (inner_form
, env
);
749 if (is_system_macro_p (scm_sym_define
, new_inner_form
, env
))
751 found_definition
= 1;
752 definitions
= scm_cons (new_inner_form
, definitions
);
753 grouped_form_idx
= SCM_CDR (grouped_form_idx
);
755 else if (is_system_macro_p (scm_sym_begin
, new_inner_form
, env
))
757 const SCM inner_group
= SCM_CDR (new_inner_form
);
759 = scm_append (scm_list_2 (inner_group
,
760 SCM_CDR (grouped_form_idx
)));
764 /* The group marks the start of the expressions of the body.
765 * We have to make sure that within the same group we have
766 * not encountered a definition before. */
767 ASSERT_SYNTAX (!found_definition
, s_mixed_body_forms
, form
);
768 found_expression
= 1;
769 grouped_form_idx
= SCM_EOL
;
773 /* We have finished processing the group. If we have not yet
774 * encountered an expression we continue processing the forms of the
775 * body to collect further definition forms. Otherwise, the group
776 * marks the start of the sequence of expressions of the body. */
777 if (!found_expression
)
779 form_idx
= SCM_CDR (form_idx
);
789 /* We have detected a form which is no definition. This marks the
790 * start of the sequence of expressions of the body. */
796 /* FIXME: forms does not hold information about the file location. */
797 ASSERT_SYNTAX (scm_is_pair (sequence
), s_missing_body_expression
, cdr_forms
);
799 if (!scm_is_null (definitions
))
803 SCM letrec_expression
;
804 SCM new_letrec_expression
;
806 SCM bindings
= SCM_EOL
;
807 for (definition_idx
= definitions
;
808 !scm_is_null (definition_idx
);
809 definition_idx
= SCM_CDR (definition_idx
))
811 const SCM definition
= SCM_CAR (definition_idx
);
812 const SCM canonical_definition
= canonicalize_define (definition
);
813 const SCM binding
= SCM_CDR (canonical_definition
);
814 bindings
= scm_cons (binding
, bindings
);
817 letrec_tail
= scm_cons (bindings
, sequence
);
818 /* FIXME: forms does not hold information about the file location. */
819 letrec_expression
= scm_cons_source (forms
, scm_sym_letrec
, letrec_tail
);
820 new_letrec_expression
= scm_m_letrec (letrec_expression
, env
);
821 SCM_SETCAR (forms
, new_letrec_expression
);
822 SCM_SETCDR (forms
, SCM_EOL
);
826 SCM_SETCAR (forms
, SCM_CAR (sequence
));
827 SCM_SETCDR (forms
, SCM_CDR (sequence
));
832 macroexp (SCM x
, SCM env
)
834 SCM res
, proc
, orig_sym
;
836 /* Don't bother to produce error messages here. We get them when we
837 eventually execute the code for real. */
840 orig_sym
= SCM_CAR (x
);
841 if (!scm_is_symbol (orig_sym
))
845 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
846 if (proc_ptr
== NULL
)
848 /* We have lost the race. */
854 /* Only handle memoizing macros. `Acros' and `macros' are really
855 special forms and should not be evaluated here. */
857 if (!SCM_MACROP (proc
)
858 || (SCM_MACRO_TYPE (proc
) != 2 && !SCM_BUILTIN_MACRO_P (proc
)))
861 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
862 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
864 if (scm_ilength (res
) <= 0)
865 /* Result of expansion is not a list. */
866 return (scm_list_2 (SCM_IM_BEGIN
, res
));
869 /* njrev: Several queries here: (1) I don't see how it can be
870 correct that the SCM_SETCAR 2 lines below this comment needs
871 protection, but the SCM_SETCAR 6 lines above does not, so
872 something here is probably wrong. (2) macroexp() is now only
873 used in one place - scm_m_generalized_set_x - whereas all other
874 macro expansion happens through expand_user_macros. Therefore
875 (2.1) perhaps macroexp() could be eliminated completely now?
876 (2.2) Does expand_user_macros need any critical section
879 SCM_CRITICAL_SECTION_START
;
880 SCM_SETCAR (x
, SCM_CAR (res
));
881 SCM_SETCDR (x
, SCM_CDR (res
));
882 SCM_CRITICAL_SECTION_END
;
888 /* Start of the memoizers for the standard R5RS builtin macros. */
891 SCM_SYNTAX (s_and
, "and", scm_i_makbimacro
, scm_m_and
);
892 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
895 scm_m_and (SCM expr
, SCM env SCM_UNUSED
)
897 const SCM cdr_expr
= SCM_CDR (expr
);
898 const long length
= scm_ilength (cdr_expr
);
900 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
904 /* Special case: (and) is replaced by #t. */
909 SCM_SETCAR (expr
, SCM_IM_AND
);
915 unmemoize_and (const SCM expr
, const SCM env
)
917 return scm_cons (scm_sym_and
, unmemoize_exprs (SCM_CDR (expr
), env
));
921 SCM_SYNTAX (s_begin
, "begin", scm_i_makbimacro
, scm_m_begin
);
922 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
925 scm_m_begin (SCM expr
, SCM env SCM_UNUSED
)
927 const SCM cdr_expr
= SCM_CDR (expr
);
928 /* Dirk:FIXME:: An empty begin clause is not generally allowed by R5RS.
929 * That means, there should be a distinction between uses of begin where an
930 * empty clause is OK and where it is not. */
931 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
933 SCM_SETCAR (expr
, SCM_IM_BEGIN
);
938 unmemoize_begin (const SCM expr
, const SCM env
)
940 return scm_cons (scm_sym_begin
, unmemoize_exprs (SCM_CDR (expr
), env
));
944 SCM_SYNTAX (s_case
, "case", scm_i_makbimacro
, scm_m_case
);
945 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
946 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
949 scm_m_case (SCM expr
, SCM env
)
952 SCM all_labels
= SCM_EOL
;
954 /* Check, whether 'else is a literal, i. e. not bound to a value. */
955 const int else_literal_p
= literal_p (scm_sym_else
, env
);
957 const SCM cdr_expr
= SCM_CDR (expr
);
958 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
959 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_clauses
, expr
);
961 clauses
= SCM_CDR (cdr_expr
);
962 while (!scm_is_null (clauses
))
966 const SCM clause
= SCM_CAR (clauses
);
967 ASSERT_SYNTAX_2 (scm_ilength (clause
) >= 2,
968 s_bad_case_clause
, clause
, expr
);
970 labels
= SCM_CAR (clause
);
971 if (scm_is_pair (labels
))
973 ASSERT_SYNTAX_2 (scm_ilength (labels
) >= 0,
974 s_bad_case_labels
, labels
, expr
);
975 all_labels
= scm_append (scm_list_2 (labels
, all_labels
));
977 else if (scm_is_null (labels
))
979 /* The list of labels is empty. According to R5RS this is allowed.
980 * It means that the sequence of expressions will never be executed.
981 * Therefore, as an optimization, we could remove the whole
986 ASSERT_SYNTAX_2 (scm_is_eq (labels
, scm_sym_else
) && else_literal_p
,
987 s_bad_case_labels
, labels
, expr
);
988 ASSERT_SYNTAX_2 (scm_is_null (SCM_CDR (clauses
)),
989 s_misplaced_else_clause
, clause
, expr
);
992 /* build the new clause */
993 if (scm_is_eq (labels
, scm_sym_else
))
994 SCM_SETCAR (clause
, SCM_IM_ELSE
);
996 clauses
= SCM_CDR (clauses
);
999 /* Check whether all case labels are distinct. */
1000 for (; !scm_is_null (all_labels
); all_labels
= SCM_CDR (all_labels
))
1002 const SCM label
= SCM_CAR (all_labels
);
1003 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (label
, SCM_CDR (all_labels
))),
1004 s_duplicate_case_label
, label
, expr
);
1007 SCM_SETCAR (expr
, SCM_IM_CASE
);
1012 unmemoize_case (const SCM expr
, const SCM env
)
1014 const SCM um_key_expr
= unmemoize_expression (SCM_CADR (expr
), env
);
1015 SCM um_clauses
= SCM_EOL
;
1018 for (clause_idx
= SCM_CDDR (expr
);
1019 !scm_is_null (clause_idx
);
1020 clause_idx
= SCM_CDR (clause_idx
))
1022 const SCM clause
= SCM_CAR (clause_idx
);
1023 const SCM labels
= SCM_CAR (clause
);
1024 const SCM exprs
= SCM_CDR (clause
);
1026 const SCM um_exprs
= unmemoize_exprs (exprs
, env
);
1027 const SCM um_labels
= (scm_is_eq (labels
, SCM_IM_ELSE
))
1029 : scm_i_finite_list_copy (labels
);
1030 const SCM um_clause
= scm_cons (um_labels
, um_exprs
);
1032 um_clauses
= scm_cons (um_clause
, um_clauses
);
1034 um_clauses
= scm_reverse_x (um_clauses
, SCM_UNDEFINED
);
1036 return scm_cons2 (scm_sym_case
, um_key_expr
, um_clauses
);
1040 SCM_SYNTAX (s_cond
, "cond", scm_i_makbimacro
, scm_m_cond
);
1041 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
1042 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
1045 scm_m_cond (SCM expr
, SCM env
)
1047 /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
1048 const int else_literal_p
= literal_p (scm_sym_else
, env
);
1049 const int arrow_literal_p
= literal_p (scm_sym_arrow
, env
);
1051 const SCM clauses
= SCM_CDR (expr
);
1054 ASSERT_SYNTAX (scm_ilength (clauses
) >= 0, s_bad_expression
, expr
);
1055 ASSERT_SYNTAX (scm_ilength (clauses
) >= 1, s_missing_clauses
, expr
);
1057 for (clause_idx
= clauses
;
1058 !scm_is_null (clause_idx
);
1059 clause_idx
= SCM_CDR (clause_idx
))
1063 const SCM clause
= SCM_CAR (clause_idx
);
1064 const long length
= scm_ilength (clause
);
1065 ASSERT_SYNTAX_2 (length
>= 1, s_bad_cond_clause
, clause
, expr
);
1067 test
= SCM_CAR (clause
);
1068 if (scm_is_eq (test
, scm_sym_else
) && else_literal_p
)
1070 const int last_clause_p
= scm_is_null (SCM_CDR (clause_idx
));
1071 ASSERT_SYNTAX_2 (length
>= 2,
1072 s_bad_cond_clause
, clause
, expr
);
1073 ASSERT_SYNTAX_2 (last_clause_p
,
1074 s_misplaced_else_clause
, clause
, expr
);
1075 SCM_SETCAR (clause
, SCM_IM_ELSE
);
1077 else if (length
>= 2
1078 && scm_is_eq (SCM_CADR (clause
), scm_sym_arrow
)
1081 ASSERT_SYNTAX_2 (length
> 2, s_missing_recipient
, clause
, expr
);
1082 ASSERT_SYNTAX_2 (length
== 3, s_extra_expression
, clause
, expr
);
1083 SCM_SETCAR (SCM_CDR (clause
), SCM_IM_ARROW
);
1085 /* SRFI 61 extended cond */
1086 else if (length
>= 3
1087 && scm_is_eq (SCM_CADDR (clause
), scm_sym_arrow
)
1090 ASSERT_SYNTAX_2 (length
> 3, s_missing_recipient
, clause
, expr
);
1091 ASSERT_SYNTAX_2 (length
== 4, s_extra_expression
, clause
, expr
);
1092 SCM_SETCAR (SCM_CDDR (clause
), SCM_IM_ARROW
);
1096 SCM_SETCAR (expr
, SCM_IM_COND
);
1101 unmemoize_cond (const SCM expr
, const SCM env
)
1103 SCM um_clauses
= SCM_EOL
;
1106 for (clause_idx
= SCM_CDR (expr
);
1107 !scm_is_null (clause_idx
);
1108 clause_idx
= SCM_CDR (clause_idx
))
1110 const SCM clause
= SCM_CAR (clause_idx
);
1111 const SCM sequence
= SCM_CDR (clause
);
1112 const SCM test
= SCM_CAR (clause
);
1117 if (scm_is_eq (test
, SCM_IM_ELSE
))
1118 um_test
= scm_sym_else
;
1120 um_test
= unmemoize_expression (test
, env
);
1122 if (!scm_is_null (sequence
) && scm_is_eq (SCM_CAR (sequence
),
1125 const SCM target
= SCM_CADR (sequence
);
1126 const SCM um_target
= unmemoize_expression (target
, env
);
1127 um_sequence
= scm_list_2 (scm_sym_arrow
, um_target
);
1131 um_sequence
= unmemoize_exprs (sequence
, env
);
1134 um_clause
= scm_cons (um_test
, um_sequence
);
1135 um_clauses
= scm_cons (um_clause
, um_clauses
);
1137 um_clauses
= scm_reverse_x (um_clauses
, SCM_UNDEFINED
);
1139 return scm_cons (scm_sym_cond
, um_clauses
);
1143 SCM_SYNTAX (s_define
, "define", scm_i_makbimacro
, scm_m_define
);
1144 SCM_GLOBAL_SYMBOL (scm_sym_define
, s_define
);
1146 /* Guile provides an extension to R5RS' define syntax to represent function
1147 * currying in a compact way. With this extension, it is allowed to write
1148 * (define <nested-variable> <body>), where <nested-variable> has of one of
1149 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
1150 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
1151 * should be either a sequence of zero or more variables, or a sequence of one
1152 * or more variables followed by a space-delimited period and another
1153 * variable. Each level of argument nesting wraps the <body> within another
1154 * lambda expression. For example, the following forms are allowed, each one
1155 * followed by an equivalent, more explicit implementation.
1157 * (define ((a b . c) . d) <body>) is equivalent to
1158 * (define a (lambda (b . c) (lambda d <body>)))
1160 * (define (((a) b) c . d) <body>) is equivalent to
1161 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
1163 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
1164 * module that does not implement this extension. */
1166 canonicalize_define (const SCM expr
)
1171 const SCM cdr_expr
= SCM_CDR (expr
);
1172 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1173 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1175 body
= SCM_CDR (cdr_expr
);
1176 variable
= SCM_CAR (cdr_expr
);
1177 while (scm_is_pair (variable
))
1179 /* This while loop realizes function currying by variable nesting.
1180 * Variable is known to be a nested-variable. In every iteration of the
1181 * loop another level of lambda expression is created, starting with the
1182 * innermost one. Note that we don't check for duplicate formals here:
1183 * This will be done by the memoizer of the lambda expression. */
1184 const SCM formals
= SCM_CDR (variable
);
1185 const SCM tail
= scm_cons (formals
, body
);
1187 /* Add source properties to each new lambda expression: */
1188 const SCM lambda
= scm_cons_source (variable
, scm_sym_lambda
, tail
);
1190 body
= scm_list_1 (lambda
);
1191 variable
= SCM_CAR (variable
);
1193 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
1194 ASSERT_SYNTAX (scm_ilength (body
) == 1, s_expression
, expr
);
1196 SCM_SETCAR (cdr_expr
, variable
);
1197 SCM_SETCDR (cdr_expr
, body
);
1201 /* According to Section 5.2.1 of R5RS we first have to make sure that the
1202 variable is bound, and then perform the `(set! variable expression)'
1203 operation. However, EXPRESSION _can_ be evaluated before VARIABLE is
1204 bound. This means that EXPRESSION won't necessarily be able to assign
1205 values to VARIABLE as in `(define foo (begin (set! foo 1) (+ foo 1)))'. */
1207 scm_m_define (SCM expr
, SCM env
)
1209 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), s_bad_define
, expr
);
1212 const SCM canonical_definition
= canonicalize_define (expr
);
1213 const SCM cdr_canonical_definition
= SCM_CDR (canonical_definition
);
1214 const SCM variable
= SCM_CAR (cdr_canonical_definition
);
1215 const SCM value
= scm_eval_car (SCM_CDR (cdr_canonical_definition
), env
);
1217 = scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_T
);
1219 if (SCM_REC_PROCNAMES_P
)
1222 while (SCM_MACROP (tmp
))
1223 tmp
= SCM_MACRO_CODE (tmp
);
1224 if (scm_is_true (scm_procedure_p (tmp
))
1225 /* Only the first definition determines the name. */
1226 && scm_is_false (scm_procedure_property (tmp
, scm_sym_name
)))
1227 scm_set_procedure_property_x (tmp
, scm_sym_name
, variable
);
1230 SCM_VARIABLE_SET (location
, value
);
1232 return SCM_UNSPECIFIED
;
1237 /* This is a helper function for forms (<keyword> <expression>) that are
1238 * transformed into (#@<keyword> '() <memoized_expression>) in order to allow
1239 * for easy creation of a thunk (i. e. a closure without arguments) using the
1240 * ('() <memoized_expression>) tail of the memoized form. */
1242 memoize_as_thunk_prototype (const SCM expr
, const SCM env SCM_UNUSED
)
1244 const SCM cdr_expr
= SCM_CDR (expr
);
1245 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1246 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1248 SCM_SETCDR (expr
, scm_cons (SCM_EOL
, cdr_expr
));
1254 SCM_SYNTAX (s_delay
, "delay", scm_i_makbimacro
, scm_m_delay
);
1255 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
1257 /* Promises are implemented as closures with an empty parameter list. Thus,
1258 * (delay <expression>) is transformed into (#@delay '() <expression>), where
1259 * the empty list represents the empty parameter list. This representation
1260 * allows for easy creation of the closure during evaluation. */
1262 scm_m_delay (SCM expr
, SCM env
)
1264 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1265 SCM_SETCAR (new_expr
, SCM_IM_DELAY
);
1270 unmemoize_delay (const SCM expr
, const SCM env
)
1272 const SCM thunk_expr
= SCM_CADDR (expr
);
1273 /* A promise is implemented as a closure, and when applying a
1274 closure the evaluator adds a new frame to the environment - even
1275 though, in the case of a promise, the added frame is always
1276 empty. We need to extend the environment here in the same way,
1277 so that any ILOCs in thunk_expr can be unmemoized correctly. */
1278 const SCM new_env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1279 return scm_list_2 (scm_sym_delay
, unmemoize_expression (thunk_expr
, new_env
));
1283 SCM_SYNTAX(s_do
, "do", scm_i_makbimacro
, scm_m_do
);
1284 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
1286 /* DO gets the most radically altered syntax. The order of the vars is
1287 * reversed here. During the evaluation this allows for simple consing of the
1288 * results of the inits and steps:
1290 (do ((<var1> <init1> <step1>)
1298 (#@do (<init1> <init2> ... <initn>)
1299 (varn ... var2 var1)
1302 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
1305 scm_m_do (SCM expr
, SCM env SCM_UNUSED
)
1307 SCM variables
= SCM_EOL
;
1308 SCM init_forms
= SCM_EOL
;
1309 SCM step_forms
= SCM_EOL
;
1316 const SCM cdr_expr
= SCM_CDR (expr
);
1317 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1318 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1320 /* Collect variables, init and step forms. */
1321 binding_idx
= SCM_CAR (cdr_expr
);
1322 ASSERT_SYNTAX_2 (scm_ilength (binding_idx
) >= 0,
1323 s_bad_bindings
, binding_idx
, expr
);
1324 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1326 const SCM binding
= SCM_CAR (binding_idx
);
1327 const long length
= scm_ilength (binding
);
1328 ASSERT_SYNTAX_2 (length
== 2 || length
== 3,
1329 s_bad_binding
, binding
, expr
);
1332 const SCM name
= SCM_CAR (binding
);
1333 const SCM init
= SCM_CADR (binding
);
1334 const SCM step
= (length
== 2) ? name
: SCM_CADDR (binding
);
1335 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
1336 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, variables
)),
1337 s_duplicate_binding
, name
, expr
);
1339 variables
= scm_cons (name
, variables
);
1340 init_forms
= scm_cons (init
, init_forms
);
1341 step_forms
= scm_cons (step
, step_forms
);
1344 init_forms
= scm_reverse_x (init_forms
, SCM_UNDEFINED
);
1345 step_forms
= scm_reverse_x (step_forms
, SCM_UNDEFINED
);
1347 /* Memoize the test form and the exit sequence. */
1348 cddr_expr
= SCM_CDR (cdr_expr
);
1349 exit_clause
= SCM_CAR (cddr_expr
);
1350 ASSERT_SYNTAX_2 (scm_ilength (exit_clause
) >= 1,
1351 s_bad_exit_clause
, exit_clause
, expr
);
1353 commands
= SCM_CDR (cddr_expr
);
1354 tail
= scm_cons2 (exit_clause
, commands
, step_forms
);
1355 tail
= scm_cons2 (init_forms
, variables
, tail
);
1356 SCM_SETCAR (expr
, SCM_IM_DO
);
1357 SCM_SETCDR (expr
, tail
);
1362 unmemoize_do (const SCM expr
, const SCM env
)
1364 const SCM cdr_expr
= SCM_CDR (expr
);
1365 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1366 const SCM rnames
= SCM_CAR (cddr_expr
);
1367 const SCM extended_env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
1368 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
1369 const SCM exit_sequence
= SCM_CAR (cdddr_expr
);
1370 const SCM um_exit_sequence
= unmemoize_exprs (exit_sequence
, extended_env
);
1371 const SCM cddddr_expr
= SCM_CDR (cdddr_expr
);
1372 const SCM um_body
= unmemoize_exprs (SCM_CAR (cddddr_expr
), extended_env
);
1374 /* build transformed binding list */
1375 SCM um_names
= scm_reverse (rnames
);
1376 SCM um_inits
= unmemoize_exprs (SCM_CAR (cdr_expr
), env
);
1377 SCM um_steps
= unmemoize_exprs (SCM_CDR (cddddr_expr
), extended_env
);
1378 SCM um_bindings
= SCM_EOL
;
1379 while (!scm_is_null (um_names
))
1381 const SCM name
= SCM_CAR (um_names
);
1382 const SCM init
= SCM_CAR (um_inits
);
1383 SCM step
= SCM_CAR (um_steps
);
1384 step
= scm_is_eq (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
1386 um_bindings
= scm_cons (scm_cons2 (name
, init
, step
), um_bindings
);
1388 um_names
= SCM_CDR (um_names
);
1389 um_inits
= SCM_CDR (um_inits
);
1390 um_steps
= SCM_CDR (um_steps
);
1392 um_bindings
= scm_reverse_x (um_bindings
, SCM_UNDEFINED
);
1394 return scm_cons (scm_sym_do
,
1395 scm_cons2 (um_bindings
, um_exit_sequence
, um_body
));
1399 SCM_SYNTAX (s_if
, "if", scm_i_makbimacro
, scm_m_if
);
1400 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
1403 scm_m_if (SCM expr
, SCM env SCM_UNUSED
)
1405 const SCM cdr_expr
= SCM_CDR (expr
);
1406 const long length
= scm_ilength (cdr_expr
);
1407 ASSERT_SYNTAX (length
== 2 || length
== 3, s_expression
, expr
);
1408 SCM_SETCAR (expr
, SCM_IM_IF
);
1413 unmemoize_if (const SCM expr
, const SCM env
)
1415 const SCM cdr_expr
= SCM_CDR (expr
);
1416 const SCM um_condition
= unmemoize_expression (SCM_CAR (cdr_expr
), env
);
1417 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1418 const SCM um_then
= unmemoize_expression (SCM_CAR (cddr_expr
), env
);
1419 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
1421 if (scm_is_null (cdddr_expr
))
1423 return scm_list_3 (scm_sym_if
, um_condition
, um_then
);
1427 const SCM um_else
= unmemoize_expression (SCM_CAR (cdddr_expr
), env
);
1428 return scm_list_4 (scm_sym_if
, um_condition
, um_then
, um_else
);
1433 SCM_SYNTAX (s_lambda
, "lambda", scm_i_makbimacro
, scm_m_lambda
);
1434 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
1436 /* A helper function for memoize_lambda to support checking for duplicate
1437 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
1438 * LIST or to the cdr of the last cons. Therefore, LIST may have any of the
1439 * forms that a formal argument can have:
1440 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
1442 c_improper_memq (SCM obj
, SCM list
)
1444 for (; scm_is_pair (list
); list
= SCM_CDR (list
))
1446 if (scm_is_eq (SCM_CAR (list
), obj
))
1449 return scm_is_eq (list
, obj
);
1453 scm_m_lambda (SCM expr
, SCM env SCM_UNUSED
)
1462 const SCM cdr_expr
= SCM_CDR (expr
);
1463 const long length
= scm_ilength (cdr_expr
);
1464 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1465 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1467 /* Before iterating the list of formal arguments, make sure the formals
1468 * actually are given as either a symbol or a non-cyclic list. */
1469 formals
= SCM_CAR (cdr_expr
);
1470 if (scm_is_pair (formals
))
1472 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
1473 * detected, report a 'Bad formals' error. */
1477 ASSERT_SYNTAX_2 (scm_is_symbol (formals
) || scm_is_null (formals
),
1478 s_bad_formals
, formals
, expr
);
1481 /* Now iterate the list of formal arguments to check if all formals are
1482 * symbols, and that there are no duplicates. */
1483 formals_idx
= formals
;
1484 while (scm_is_pair (formals_idx
))
1486 const SCM formal
= SCM_CAR (formals_idx
);
1487 const SCM next_idx
= SCM_CDR (formals_idx
);
1488 ASSERT_SYNTAX_2 (scm_is_symbol (formal
), s_bad_formal
, formal
, expr
);
1489 ASSERT_SYNTAX_2 (!c_improper_memq (formal
, next_idx
),
1490 s_duplicate_formal
, formal
, expr
);
1491 formals_idx
= next_idx
;
1493 ASSERT_SYNTAX_2 (scm_is_null (formals_idx
) || scm_is_symbol (formals_idx
),
1494 s_bad_formal
, formals_idx
, expr
);
1496 /* Memoize the body. Keep a potential documentation string. */
1497 /* Dirk:FIXME:: We should probably extract the documentation string to
1498 * some external database. Otherwise it will slow down execution, since
1499 * the documentation string will have to be skipped with every execution
1500 * of the closure. */
1501 cddr_expr
= SCM_CDR (cdr_expr
);
1502 documentation
= (length
>= 3 && scm_is_string (SCM_CAR (cddr_expr
)));
1503 body
= documentation
? SCM_CDR (cddr_expr
) : cddr_expr
;
1504 new_body
= m_body (SCM_IM_LAMBDA
, body
);
1506 SCM_SETCAR (expr
, SCM_IM_LAMBDA
);
1508 SCM_SETCDR (cddr_expr
, new_body
);
1510 SCM_SETCDR (cdr_expr
, new_body
);
1515 unmemoize_lambda (const SCM expr
, const SCM env
)
1517 const SCM formals
= SCM_CADR (expr
);
1518 const SCM body
= SCM_CDDR (expr
);
1520 const SCM new_env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, env
);
1521 const SCM um_formals
= scm_i_finite_list_copy (formals
);
1522 const SCM um_body
= unmemoize_exprs (body
, new_env
);
1524 return scm_cons2 (scm_sym_lambda
, um_formals
, um_body
);
1528 /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
1530 check_bindings (const SCM bindings
, const SCM expr
)
1534 ASSERT_SYNTAX_2 (scm_ilength (bindings
) >= 0,
1535 s_bad_bindings
, bindings
, expr
);
1537 binding_idx
= bindings
;
1538 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1540 SCM name
; /* const */
1542 const SCM binding
= SCM_CAR (binding_idx
);
1543 ASSERT_SYNTAX_2 (scm_ilength (binding
) == 2,
1544 s_bad_binding
, binding
, expr
);
1546 name
= SCM_CAR (binding
);
1547 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
1552 /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
1553 * transformed to the lists (vn ... v2 v1) and (i1 i2 ... in). That is, the
1554 * variables are returned in a list with their order reversed, and the init
1555 * forms are returned in a list in the same order as they are given in the
1556 * bindings. If a duplicate variable name is detected, an error is
1559 transform_bindings (
1560 const SCM bindings
, const SCM expr
,
1561 SCM
*const rvarptr
, SCM
*const initptr
)
1563 SCM rvariables
= SCM_EOL
;
1564 SCM rinits
= SCM_EOL
;
1565 SCM binding_idx
= bindings
;
1566 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1568 const SCM binding
= SCM_CAR (binding_idx
);
1569 const SCM cdr_binding
= SCM_CDR (binding
);
1570 const SCM name
= SCM_CAR (binding
);
1571 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, rvariables
)),
1572 s_duplicate_binding
, name
, expr
);
1573 rvariables
= scm_cons (name
, rvariables
);
1574 rinits
= scm_cons (SCM_CAR (cdr_binding
), rinits
);
1576 *rvarptr
= rvariables
;
1577 *initptr
= scm_reverse_x (rinits
, SCM_UNDEFINED
);
1581 SCM_SYNTAX(s_let
, "let", scm_i_makbimacro
, scm_m_let
);
1582 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
1584 /* This function is a helper function for memoize_let. It transforms
1585 * (let name ((var init) ...) body ...) into
1586 * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
1587 * and memoizes the expression. It is assumed that the caller has checked
1588 * that name is a symbol and that there are bindings and a body. */
1590 memoize_named_let (const SCM expr
, const SCM env SCM_UNUSED
)
1596 const SCM cdr_expr
= SCM_CDR (expr
);
1597 const SCM name
= SCM_CAR (cdr_expr
);
1598 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1599 const SCM bindings
= SCM_CAR (cddr_expr
);
1600 check_bindings (bindings
, expr
);
1602 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1603 variables
= scm_reverse_x (rvariables
, SCM_UNDEFINED
);
1606 const SCM let_body
= SCM_CDR (cddr_expr
);
1607 const SCM lambda_body
= m_body (SCM_IM_LET
, let_body
);
1608 const SCM lambda_tail
= scm_cons (variables
, lambda_body
);
1609 const SCM lambda_form
= scm_cons_source (expr
, scm_sym_lambda
, lambda_tail
);
1611 const SCM rvar
= scm_list_1 (name
);
1612 const SCM init
= scm_list_1 (lambda_form
);
1613 const SCM body
= m_body (SCM_IM_LET
, scm_list_1 (name
));
1614 const SCM letrec_tail
= scm_cons (rvar
, scm_cons (init
, body
));
1615 const SCM letrec_form
= scm_cons_source (expr
, SCM_IM_LETREC
, letrec_tail
);
1616 return scm_cons_source (expr
, letrec_form
, inits
);
1620 /* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1621 * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
1623 scm_m_let (SCM expr
, SCM env
)
1627 const SCM cdr_expr
= SCM_CDR (expr
);
1628 const long length
= scm_ilength (cdr_expr
);
1629 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1630 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1632 bindings
= SCM_CAR (cdr_expr
);
1633 if (scm_is_symbol (bindings
))
1635 ASSERT_SYNTAX (length
>= 3, s_missing_expression
, expr
);
1636 return memoize_named_let (expr
, env
);
1639 check_bindings (bindings
, expr
);
1640 if (scm_is_null (bindings
) || scm_is_null (SCM_CDR (bindings
)))
1642 /* Special case: no bindings or single binding => let* is faster. */
1643 const SCM body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1644 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), bindings
, body
), env
);
1651 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1654 const SCM new_body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1655 const SCM new_tail
= scm_cons2 (rvariables
, inits
, new_body
);
1656 SCM_SETCAR (expr
, SCM_IM_LET
);
1657 SCM_SETCDR (expr
, new_tail
);
1664 build_binding_list (SCM rnames
, SCM rinits
)
1666 SCM bindings
= SCM_EOL
;
1667 while (!scm_is_null (rnames
))
1669 const SCM binding
= scm_list_2 (SCM_CAR (rnames
), SCM_CAR (rinits
));
1670 bindings
= scm_cons (binding
, bindings
);
1671 rnames
= SCM_CDR (rnames
);
1672 rinits
= SCM_CDR (rinits
);
1678 unmemoize_let (const SCM expr
, const SCM env
)
1680 const SCM cdr_expr
= SCM_CDR (expr
);
1681 const SCM um_rnames
= SCM_CAR (cdr_expr
);
1682 const SCM extended_env
= SCM_EXTEND_ENV (um_rnames
, SCM_EOL
, env
);
1683 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1684 const SCM um_inits
= unmemoize_exprs (SCM_CAR (cddr_expr
), env
);
1685 const SCM um_rinits
= scm_reverse_x (um_inits
, SCM_UNDEFINED
);
1686 const SCM um_bindings
= build_binding_list (um_rnames
, um_rinits
);
1687 const SCM um_body
= unmemoize_exprs (SCM_CDR (cddr_expr
), extended_env
);
1689 return scm_cons2 (scm_sym_let
, um_bindings
, um_body
);
1693 SCM_SYNTAX(s_letrec
, "letrec", scm_i_makbimacro
, scm_m_letrec
);
1694 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
1697 scm_m_letrec (SCM expr
, SCM env
)
1701 const SCM cdr_expr
= SCM_CDR (expr
);
1702 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1703 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1705 bindings
= SCM_CAR (cdr_expr
);
1706 if (scm_is_null (bindings
))
1708 /* no bindings, let* is executed faster */
1709 SCM body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1710 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), SCM_EOL
, body
), env
);
1718 check_bindings (bindings
, expr
);
1719 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1720 new_body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1721 return scm_cons2 (SCM_IM_LETREC
, rvariables
, scm_cons (inits
, new_body
));
1726 unmemoize_letrec (const SCM expr
, const SCM env
)
1728 const SCM cdr_expr
= SCM_CDR (expr
);
1729 const SCM um_rnames
= SCM_CAR (cdr_expr
);
1730 const SCM extended_env
= SCM_EXTEND_ENV (um_rnames
, SCM_EOL
, env
);
1731 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1732 const SCM um_inits
= unmemoize_exprs (SCM_CAR (cddr_expr
), extended_env
);
1733 const SCM um_rinits
= scm_reverse_x (um_inits
, SCM_UNDEFINED
);
1734 const SCM um_bindings
= build_binding_list (um_rnames
, um_rinits
);
1735 const SCM um_body
= unmemoize_exprs (SCM_CDR (cddr_expr
), extended_env
);
1737 return scm_cons2 (scm_sym_letrec
, um_bindings
, um_body
);
1742 SCM_SYNTAX (s_letstar
, "let*", scm_i_makbimacro
, scm_m_letstar
);
1743 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
1745 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1746 * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
1748 scm_m_letstar (SCM expr
, SCM env SCM_UNUSED
)
1753 const SCM cdr_expr
= SCM_CDR (expr
);
1754 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1755 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1757 binding_idx
= SCM_CAR (cdr_expr
);
1758 check_bindings (binding_idx
, expr
);
1760 /* Transform ((v1 i1) (v2 i2) ...) into (v1 i1 v2 i2 ...). The
1761 * transformation is done in place. At the beginning of one iteration of
1762 * the loop the variable binding_idx holds the form
1763 * P1:( (vn . P2:(in . ())) . P3:( (vn+1 in+1) ... ) ),
1764 * where P1, P2 and P3 indicate the pairs, that are relevant for the
1765 * transformation. P1 and P2 are modified in the loop, P3 remains
1766 * untouched. After the execution of the loop, P1 will hold
1767 * P1:( vn . P2:(in . P3:( (vn+1 in+1) ... )) )
1768 * and binding_idx will hold P3. */
1769 while (!scm_is_null (binding_idx
))
1771 const SCM cdr_binding_idx
= SCM_CDR (binding_idx
); /* remember P3 */
1772 const SCM binding
= SCM_CAR (binding_idx
);
1773 const SCM name
= SCM_CAR (binding
);
1774 const SCM cdr_binding
= SCM_CDR (binding
);
1776 SCM_SETCDR (cdr_binding
, cdr_binding_idx
); /* update P2 */
1777 SCM_SETCAR (binding_idx
, name
); /* update P1 */
1778 SCM_SETCDR (binding_idx
, cdr_binding
); /* update P1 */
1780 binding_idx
= cdr_binding_idx
; /* continue with P3 */
1783 new_body
= m_body (SCM_IM_LETSTAR
, SCM_CDR (cdr_expr
));
1784 SCM_SETCAR (expr
, SCM_IM_LETSTAR
);
1785 /* the bindings have been changed in place */
1786 SCM_SETCDR (cdr_expr
, new_body
);
1791 unmemoize_letstar (const SCM expr
, const SCM env
)
1793 const SCM cdr_expr
= SCM_CDR (expr
);
1794 const SCM body
= SCM_CDR (cdr_expr
);
1795 SCM bindings
= SCM_CAR (cdr_expr
);
1796 SCM um_bindings
= SCM_EOL
;
1797 SCM extended_env
= env
;
1800 while (!scm_is_null (bindings
))
1802 const SCM variable
= SCM_CAR (bindings
);
1803 const SCM init
= SCM_CADR (bindings
);
1804 const SCM um_init
= unmemoize_expression (init
, extended_env
);
1805 um_bindings
= scm_cons (scm_list_2 (variable
, um_init
), um_bindings
);
1806 extended_env
= SCM_EXTEND_ENV (variable
, SCM_BOOL_F
, extended_env
);
1807 bindings
= SCM_CDDR (bindings
);
1809 um_bindings
= scm_reverse_x (um_bindings
, SCM_UNDEFINED
);
1811 um_body
= unmemoize_exprs (body
, extended_env
);
1813 return scm_cons2 (scm_sym_letstar
, um_bindings
, um_body
);
1817 SCM_SYNTAX (s_or
, "or", scm_i_makbimacro
, scm_m_or
);
1818 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
1821 scm_m_or (SCM expr
, SCM env SCM_UNUSED
)
1823 const SCM cdr_expr
= SCM_CDR (expr
);
1824 const long length
= scm_ilength (cdr_expr
);
1826 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1830 /* Special case: (or) is replaced by #f. */
1835 SCM_SETCAR (expr
, SCM_IM_OR
);
1841 unmemoize_or (const SCM expr
, const SCM env
)
1843 return scm_cons (scm_sym_or
, unmemoize_exprs (SCM_CDR (expr
), env
));
1847 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
1848 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
1849 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
1850 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
1852 /* Internal function to handle a quasiquotation: 'form' is the parameter in
1853 * the call (quasiquotation form), 'env' is the environment where unquoted
1854 * expressions will be evaluated, and 'depth' is the current quasiquotation
1855 * nesting level and is known to be greater than zero. */
1857 iqq (SCM form
, SCM env
, unsigned long int depth
)
1859 if (scm_is_pair (form
))
1861 const SCM tmp
= SCM_CAR (form
);
1862 if (scm_is_eq (tmp
, scm_sym_quasiquote
))
1864 const SCM args
= SCM_CDR (form
);
1865 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1866 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
1868 else if (scm_is_eq (tmp
, scm_sym_unquote
))
1870 const SCM args
= SCM_CDR (form
);
1871 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1873 return scm_eval_car (args
, env
);
1875 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
1877 else if (scm_is_pair (tmp
)
1878 && scm_is_eq (SCM_CAR (tmp
), scm_sym_uq_splicing
))
1880 const SCM args
= SCM_CDR (tmp
);
1881 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1884 const SCM list
= scm_eval_car (args
, env
);
1885 const SCM rest
= SCM_CDR (form
);
1886 ASSERT_SYNTAX_2 (scm_ilength (list
) >= 0,
1887 s_splicing
, list
, form
);
1888 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
1891 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
1892 iqq (SCM_CDR (form
), env
, depth
));
1895 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
1896 iqq (SCM_CDR (form
), env
, depth
));
1898 else if (scm_is_vector (form
))
1899 return scm_vector (iqq (scm_vector_to_list (form
), env
, depth
));
1905 scm_m_quasiquote (SCM expr
, SCM env
)
1907 const SCM cdr_expr
= SCM_CDR (expr
);
1908 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1909 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1910 return iqq (SCM_CAR (cdr_expr
), env
, 1);
1914 SCM_SYNTAX (s_quote
, "quote", scm_i_makbimacro
, scm_m_quote
);
1915 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
1918 scm_m_quote (SCM expr
, SCM env SCM_UNUSED
)
1922 const SCM cdr_expr
= SCM_CDR (expr
);
1923 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1924 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1925 quotee
= SCM_CAR (cdr_expr
);
1926 if (is_self_quoting_p (quotee
))
1929 SCM_SETCAR (expr
, SCM_IM_QUOTE
);
1930 SCM_SETCDR (expr
, quotee
);
1935 unmemoize_quote (const SCM expr
, const SCM env SCM_UNUSED
)
1937 return scm_list_2 (scm_sym_quote
, SCM_CDR (expr
));
1941 /* Will go into the RnRS module when Guile is factorized.
1942 SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
1943 static const char s_set_x
[] = "set!";
1944 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, s_set_x
);
1947 scm_m_set_x (SCM expr
, SCM env SCM_UNUSED
)
1952 const SCM cdr_expr
= SCM_CDR (expr
);
1953 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1954 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1955 variable
= SCM_CAR (cdr_expr
);
1957 /* Memoize the variable form. */
1958 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
1959 new_variable
= lookup_symbol (variable
, env
);
1960 /* Leave the memoization of unbound symbols to lazy memoization: */
1961 if (SCM_UNBNDP (new_variable
))
1962 new_variable
= variable
;
1964 SCM_SETCAR (expr
, SCM_IM_SET_X
);
1965 SCM_SETCAR (cdr_expr
, new_variable
);
1970 unmemoize_set_x (const SCM expr
, const SCM env
)
1972 return scm_cons (scm_sym_set_x
, unmemoize_exprs (SCM_CDR (expr
), env
));
1976 /* Start of the memoizers for non-R5RS builtin macros. */
1979 SCM_SYNTAX (s_atapply
, "@apply", scm_i_makbimacro
, scm_m_apply
);
1980 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1981 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1984 scm_m_apply (SCM expr
, SCM env SCM_UNUSED
)
1986 const SCM cdr_expr
= SCM_CDR (expr
);
1987 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1988 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_missing_expression
, expr
);
1990 SCM_SETCAR (expr
, SCM_IM_APPLY
);
1995 unmemoize_apply (const SCM expr
, const SCM env
)
1997 return scm_list_2 (scm_sym_atapply
, unmemoize_exprs (SCM_CDR (expr
), env
));
2001 SCM_SYNTAX (s_atbind
, "@bind", scm_i_makbimacro
, scm_m_atbind
);
2003 /* FIXME: The following explanation should go into the documentation: */
2004 /* (@bind ((var init) ...) body ...) will assign the values of the `init's to
2005 * the global variables named by `var's (symbols, not evaluated), creating
2006 * them if they don't exist, executes body, and then restores the previous
2007 * values of the `var's. Additionally, whenever control leaves body, the
2008 * values of the `var's are saved and restored when control returns. It is an
2009 * error when a symbol appears more than once among the `var's. All `init's
2010 * are evaluated before any `var' is set.
2012 * Think of this as `let' for dynamic scope.
2015 /* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into
2016 * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...).
2018 * FIXME - also implement `@bind*'.
2021 scm_m_atbind (SCM expr
, SCM env
)
2028 const SCM top_level
= scm_env_top_level (env
);
2030 const SCM cdr_expr
= SCM_CDR (expr
);
2031 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2032 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
2033 bindings
= SCM_CAR (cdr_expr
);
2034 check_bindings (bindings
, expr
);
2035 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
2037 for (variable_idx
= rvariables
;
2038 !scm_is_null (variable_idx
);
2039 variable_idx
= SCM_CDR (variable_idx
))
2041 /* The first call to scm_sym2var will look beyond the current module,
2042 * while the second call wont. */
2043 const SCM variable
= SCM_CAR (variable_idx
);
2044 SCM new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_F
);
2045 if (scm_is_false (new_variable
))
2046 new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_T
);
2047 SCM_SETCAR (variable_idx
, new_variable
);
2050 SCM_SETCAR (expr
, SCM_IM_BIND
);
2051 SCM_SETCAR (cdr_expr
, scm_cons (rvariables
, inits
));
2056 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_i_makbimacro
, scm_m_cont
);
2057 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, s_atcall_cc
);
2060 scm_m_cont (SCM expr
, SCM env SCM_UNUSED
)
2062 const SCM cdr_expr
= SCM_CDR (expr
);
2063 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2064 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2066 SCM_SETCAR (expr
, SCM_IM_CONT
);
2071 unmemoize_atcall_cc (const SCM expr
, const SCM env
)
2073 return scm_list_2 (scm_sym_atcall_cc
, unmemoize_exprs (SCM_CDR (expr
), env
));
2077 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_i_makbimacro
, scm_m_at_call_with_values
);
2078 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
2081 scm_m_at_call_with_values (SCM expr
, SCM env SCM_UNUSED
)
2083 const SCM cdr_expr
= SCM_CDR (expr
);
2084 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2085 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2087 SCM_SETCAR (expr
, SCM_IM_CALL_WITH_VALUES
);
2092 unmemoize_at_call_with_values (const SCM expr
, const SCM env
)
2094 return scm_list_2 (scm_sym_at_call_with_values
,
2095 unmemoize_exprs (SCM_CDR (expr
), env
));
2100 /* See futures.h for a comment why futures are not enabled.
2103 SCM_SYNTAX (s_future
, "future", scm_i_makbimacro
, scm_m_future
);
2104 SCM_GLOBAL_SYMBOL (scm_sym_future
, s_future
);
2106 /* Like promises, futures are implemented as closures with an empty
2107 * parameter list. Thus, (future <expression>) is transformed into
2108 * (#@future '() <expression>), where the empty list represents the
2109 * empty parameter list. This representation allows for easy creation
2110 * of the closure during evaluation. */
2112 scm_m_future (SCM expr
, SCM env
)
2114 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
2115 SCM_SETCAR (new_expr
, SCM_IM_FUTURE
);
2120 unmemoize_future (const SCM expr
, const SCM env
)
2122 const SCM thunk_expr
= SCM_CADDR (expr
);
2123 return scm_list_2 (scm_sym_future
, unmemoize_expression (thunk_expr
, env
));
2128 SCM_SYNTAX (s_gset_x
, "set!", scm_i_makbimacro
, scm_m_generalized_set_x
);
2129 SCM_SYMBOL (scm_sym_setter
, "setter");
2132 scm_m_generalized_set_x (SCM expr
, SCM env
)
2134 SCM target
, exp_target
;
2136 const SCM cdr_expr
= SCM_CDR (expr
);
2137 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2138 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2140 target
= SCM_CAR (cdr_expr
);
2141 if (!scm_is_pair (target
))
2144 return scm_m_set_x (expr
, env
);
2148 /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */
2149 /* Macroexpanding the target might return things of the form
2150 (begin <atom>). In that case, <atom> must be a symbol or a
2151 variable and we memoize to (set! <atom> ...).
2153 exp_target
= macroexp (target
, env
);
2154 if (scm_is_eq (SCM_CAR (exp_target
), SCM_IM_BEGIN
)
2155 && !scm_is_null (SCM_CDR (exp_target
))
2156 && scm_is_null (SCM_CDDR (exp_target
)))
2158 exp_target
= SCM_CADR (exp_target
);
2159 ASSERT_SYNTAX_2 (scm_is_symbol (exp_target
)
2160 || SCM_VARIABLEP (exp_target
),
2161 s_bad_variable
, exp_target
, expr
);
2162 return scm_cons (SCM_IM_SET_X
, scm_cons (exp_target
,
2163 SCM_CDR (cdr_expr
)));
2167 const SCM setter_proc_tail
= scm_list_1 (SCM_CAR (target
));
2168 const SCM setter_proc
= scm_cons_source (expr
, scm_sym_setter
,
2171 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
2172 const SCM setter_args
= scm_append_x (scm_list_2 (SCM_CDR (target
),
2175 SCM_SETCAR (expr
, setter_proc
);
2176 SCM_SETCDR (expr
, setter_args
);
2183 /* @slot-ref is bound privately in the (oop goops) module from goops.c. As
2184 * soon as the module system allows us to more freely create bindings in
2185 * arbitrary modules during the startup phase, the code from goops.c should be
2188 SCM_SYMBOL (sym_atslot_ref
, "@slot-ref");
2191 scm_m_atslot_ref (SCM expr
, SCM env SCM_UNUSED
)
2195 const SCM cdr_expr
= SCM_CDR (expr
);
2196 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2197 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2198 slot_nr
= SCM_CADR (cdr_expr
);
2199 ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2201 SCM_SETCAR (expr
, SCM_IM_SLOT_REF
);
2202 SCM_SETCDR (cdr_expr
, slot_nr
);
2207 unmemoize_atslot_ref (const SCM expr
, const SCM env
)
2209 const SCM instance
= SCM_CADR (expr
);
2210 const SCM um_instance
= unmemoize_expression (instance
, env
);
2211 const SCM slot_nr
= SCM_CDDR (expr
);
2212 return scm_list_3 (sym_atslot_ref
, um_instance
, slot_nr
);
2216 /* @slot-set! is bound privately in the (oop goops) module from goops.c. As
2217 * soon as the module system allows us to more freely create bindings in
2218 * arbitrary modules during the startup phase, the code from goops.c should be
2221 SCM_SYMBOL (sym_atslot_set_x
, "@slot-set!");
2224 scm_m_atslot_set_x (SCM expr
, SCM env SCM_UNUSED
)
2228 const SCM cdr_expr
= SCM_CDR (expr
);
2229 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2230 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 3, s_expression
, expr
);
2231 slot_nr
= SCM_CADR (cdr_expr
);
2232 ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2234 SCM_SETCAR (expr
, SCM_IM_SLOT_SET_X
);
2239 unmemoize_atslot_set_x (const SCM expr
, const SCM env
)
2241 const SCM cdr_expr
= SCM_CDR (expr
);
2242 const SCM instance
= SCM_CAR (cdr_expr
);
2243 const SCM um_instance
= unmemoize_expression (instance
, env
);
2244 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
2245 const SCM slot_nr
= SCM_CAR (cddr_expr
);
2246 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
2247 const SCM value
= SCM_CAR (cdddr_expr
);
2248 const SCM um_value
= unmemoize_expression (value
, env
);
2249 return scm_list_4 (sym_atslot_set_x
, um_instance
, slot_nr
, um_value
);
2253 #if SCM_ENABLE_ELISP
2255 static const char s_defun
[] = "Symbol's function definition is void";
2257 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_i_makbimacro
, scm_m_nil_cond
);
2259 /* nil-cond expressions have the form
2260 * (nil-cond COND VAL COND VAL ... ELSEVAL) */
2262 scm_m_nil_cond (SCM expr
, SCM env SCM_UNUSED
)
2264 const long length
= scm_ilength (SCM_CDR (expr
));
2265 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
2266 ASSERT_SYNTAX (length
>= 1 && (length
% 2) == 1, s_expression
, expr
);
2268 SCM_SETCAR (expr
, SCM_IM_NIL_COND
);
2273 SCM_SYNTAX (s_atfop
, "@fop", scm_i_makbimacro
, scm_m_atfop
);
2275 /* The @fop-macro handles procedure and macro applications for elisp. The
2276 * input expression must have the form
2277 * (@fop <var> (transformer-macro <expr> ...))
2278 * where <var> must be a symbol. The expression is transformed into the
2279 * memoized form of either
2280 * (apply <un-aliased var> (transformer-macro <expr> ...))
2281 * if the value of var (across all aliasing) is not a macro, or
2282 * (<un-aliased var> <expr> ...)
2283 * if var is a macro. */
2285 scm_m_atfop (SCM expr
, SCM env SCM_UNUSED
)
2290 const SCM cdr_expr
= SCM_CDR (expr
);
2291 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2292 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 1, s_missing_expression
, expr
);
2294 symbol
= SCM_CAR (cdr_expr
);
2295 ASSERT_SYNTAX_2 (scm_is_symbol (symbol
), s_bad_variable
, symbol
, expr
);
2297 location
= scm_symbol_fref (symbol
);
2298 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2300 /* The elisp function `defalias' allows to define aliases for symbols. To
2301 * look up such definitions, the chain of symbol definitions has to be
2302 * followed up to the terminal symbol. */
2303 while (scm_is_symbol (SCM_VARIABLE_REF (location
)))
2305 const SCM alias
= SCM_VARIABLE_REF (location
);
2306 location
= scm_symbol_fref (alias
);
2307 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2310 /* Memoize the value location belonging to the terminal symbol. */
2311 SCM_SETCAR (cdr_expr
, location
);
2313 if (!SCM_MACROP (SCM_VARIABLE_REF (location
)))
2315 /* Since the location does not contain a macro, the form is a procedure
2316 * application. Replace `@fop' by `@apply' and transform the expression
2317 * including the `transformer-macro'. */
2318 SCM_SETCAR (expr
, SCM_IM_APPLY
);
2323 /* Since the location contains a macro, the arguments should not be
2324 * transformed, so the `transformer-macro' is cut out. The resulting
2325 * expression starts with the memoized variable, that is at the cdr of
2326 * the input expression. */
2327 SCM_SETCDR (cdr_expr
, SCM_CDADR (cdr_expr
));
2332 #endif /* SCM_ENABLE_ELISP */
2336 unmemoize_builtin_macro (const SCM expr
, const SCM env
)
2338 switch (ISYMNUM (SCM_CAR (expr
)))
2340 case (ISYMNUM (SCM_IM_AND
)):
2341 return unmemoize_and (expr
, env
);
2343 case (ISYMNUM (SCM_IM_BEGIN
)):
2344 return unmemoize_begin (expr
, env
);
2346 case (ISYMNUM (SCM_IM_CASE
)):
2347 return unmemoize_case (expr
, env
);
2349 case (ISYMNUM (SCM_IM_COND
)):
2350 return unmemoize_cond (expr
, env
);
2352 case (ISYMNUM (SCM_IM_DELAY
)):
2353 return unmemoize_delay (expr
, env
);
2355 case (ISYMNUM (SCM_IM_DO
)):
2356 return unmemoize_do (expr
, env
);
2358 case (ISYMNUM (SCM_IM_IF
)):
2359 return unmemoize_if (expr
, env
);
2361 case (ISYMNUM (SCM_IM_LAMBDA
)):
2362 return unmemoize_lambda (expr
, env
);
2364 case (ISYMNUM (SCM_IM_LET
)):
2365 return unmemoize_let (expr
, env
);
2367 case (ISYMNUM (SCM_IM_LETREC
)):
2368 return unmemoize_letrec (expr
, env
);
2370 case (ISYMNUM (SCM_IM_LETSTAR
)):
2371 return unmemoize_letstar (expr
, env
);
2373 case (ISYMNUM (SCM_IM_OR
)):
2374 return unmemoize_or (expr
, env
);
2376 case (ISYMNUM (SCM_IM_QUOTE
)):
2377 return unmemoize_quote (expr
, env
);
2379 case (ISYMNUM (SCM_IM_SET_X
)):
2380 return unmemoize_set_x (expr
, env
);
2382 case (ISYMNUM (SCM_IM_APPLY
)):
2383 return unmemoize_apply (expr
, env
);
2385 case (ISYMNUM (SCM_IM_BIND
)):
2386 return unmemoize_exprs (expr
, env
); /* FIXME */
2388 case (ISYMNUM (SCM_IM_CONT
)):
2389 return unmemoize_atcall_cc (expr
, env
);
2391 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2392 return unmemoize_at_call_with_values (expr
, env
);
2395 /* See futures.h for a comment why futures are not enabled.
2397 case (ISYMNUM (SCM_IM_FUTURE
)):
2398 return unmemoize_future (expr
, env
);
2401 case (ISYMNUM (SCM_IM_SLOT_REF
)):
2402 return unmemoize_atslot_ref (expr
, env
);
2404 case (ISYMNUM (SCM_IM_SLOT_SET_X
)):
2405 return unmemoize_atslot_set_x (expr
, env
);
2407 case (ISYMNUM (SCM_IM_NIL_COND
)):
2408 return unmemoize_exprs (expr
, env
); /* FIXME */
2411 return unmemoize_exprs (expr
, env
); /* FIXME */
2416 /* scm_i_unmemocopy_expr and scm_i_unmemocopy_body take a memoized expression
2417 * respectively a memoized body together with its environment and rewrite it
2418 * to its original form. Thus, these functions are the inversion of the
2419 * rewrite rules above. The procedure is not optimized for speed. It's used
2420 * in scm_i_unmemoize_expr, scm_procedure_source, macro_print and scm_iprin1.
2422 * Unmemoizing is not a reliable process. You cannot in general expect to get
2423 * the original source back.
2425 * However, GOOPS currently relies on this for method compilation. This ought
2429 scm_i_unmemocopy_expr (SCM expr
, SCM env
)
2431 const SCM source_properties
= scm_whash_lookup (scm_source_whash
, expr
);
2432 const SCM um_expr
= unmemoize_expression (expr
, env
);
2434 if (scm_is_true (source_properties
))
2435 scm_whash_insert (scm_source_whash
, um_expr
, source_properties
);
2441 scm_i_unmemocopy_body (SCM forms
, SCM env
)
2443 const SCM source_properties
= scm_whash_lookup (scm_source_whash
, forms
);
2444 const SCM um_forms
= unmemoize_exprs (forms
, env
);
2446 if (scm_is_true (source_properties
))
2447 scm_whash_insert (scm_source_whash
, um_forms
, source_properties
);
2453 #if (SCM_ENABLE_DEPRECATED == 1)
2455 /* Deprecated in guile 1.7.0 on 2003-11-09. */
2457 scm_m_expand_body (SCM exprs
, SCM env
)
2459 scm_c_issue_deprecation_warning
2460 ("`scm_m_expand_body' is deprecated.");
2461 m_expand_body (exprs
, env
);
2466 SCM_SYNTAX (s_undefine
, "undefine", scm_makacro
, scm_m_undefine
);
2469 scm_m_undefine (SCM expr
, SCM env
)
2474 const SCM cdr_expr
= SCM_CDR (expr
);
2475 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), "Bad undefine placement in", expr
);
2476 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2477 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2479 scm_c_issue_deprecation_warning
2480 ("`undefine' is deprecated.\n");
2482 variable
= SCM_CAR (cdr_expr
);
2483 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
2484 location
= scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_F
);
2485 ASSERT_SYNTAX_2 (scm_is_true (location
)
2486 && !SCM_UNBNDP (SCM_VARIABLE_REF (location
)),
2487 "variable already unbound ", variable
, expr
);
2488 SCM_VARIABLE_SET (location
, SCM_UNDEFINED
);
2489 return SCM_UNSPECIFIED
;
2493 scm_macroexp (SCM x
, SCM env
)
2495 scm_c_issue_deprecation_warning
2496 ("`scm_macroexp' is deprecated.");
2497 return macroexp (x
, env
);
2503 #if (SCM_ENABLE_DEPRECATED == 1)
2506 scm_unmemocar (SCM form
, SCM env
)
2508 scm_c_issue_deprecation_warning
2509 ("`scm_unmemocar' is deprecated.");
2511 if (!scm_is_pair (form
))
2515 SCM c
= SCM_CAR (form
);
2516 if (SCM_VARIABLEP (c
))
2518 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
2519 if (scm_is_false (sym
))
2520 sym
= sym_three_question_marks
;
2521 SCM_SETCAR (form
, sym
);
2523 else if (SCM_ILOCP (c
))
2525 unsigned long int ir
;
2527 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
2528 env
= SCM_CDR (env
);
2529 env
= SCM_CAAR (env
);
2530 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
2531 env
= SCM_CDR (env
);
2533 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
2541 /*****************************************************************************/
2542 /*****************************************************************************/
2543 /* The definitions for execution start here. */
2544 /*****************************************************************************/
2545 /*****************************************************************************/
2547 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
2548 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
2549 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
2550 SCM_GLOBAL_SYMBOL (scm_sym_memoize_symbol
, "memoize-symbol");
2551 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
2552 SCM_SYMBOL (sym_instead
, "instead");
2554 /* A function object to implement "apply" for non-closure functions. */
2556 /* An endless list consisting of #<undefined> objects: */
2557 static SCM undefineds
;
2561 scm_badargsp (SCM formals
, SCM args
)
2563 while (!scm_is_null (formals
))
2565 if (!scm_is_pair (formals
))
2567 if (scm_is_null (args
))
2569 formals
= SCM_CDR (formals
);
2570 args
= SCM_CDR (args
);
2572 return !scm_is_null (args
) ? 1 : 0;
2577 /* The evaluator contains a plethora of EVAL symbols.
2580 * SCM_I_EVALIM is used when it is known that the expression is an
2581 * immediate. (This macro never calls an evaluator.)
2583 * SCM_I_XEVAL evaluates an expression that is expected to have its symbols already
2584 * memoized. Expressions that are not of the form '(<form> <form> ...)' are
2585 * evaluated inline without calling an evaluator.
2587 * This macro uses ceval or deval depending on its 3rd argument.
2589 * SCM_I_XEVALCAR evaluates the car of an expression 'X:(Y:<form> <form> ...)',
2590 * potentially replacing a symbol at the position Y:<form> by its memoized
2591 * variable. If Y:<form> is not of the form '(<form> <form> ...)', the
2592 * evaluation is performed inline without calling an evaluator.
2594 * This macro uses ceval or deval depending on its 3rd argument.
2598 #define SCM_I_EVALIM2(x) \
2599 ((scm_is_eq ((x), SCM_EOL) \
2600 ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \
2604 #define SCM_I_EVALIM(x, env) (SCM_ILOCP (x) \
2605 ? *scm_ilookup ((x), (env)) \
2608 #define SCM_I_XEVAL(x, env, debug_p) \
2610 ? SCM_I_EVALIM2 (x) \
2611 : (SCM_VARIABLEP (x) \
2612 ? SCM_VARIABLE_REF (x) \
2613 : (scm_is_pair (x) \
2615 ? deval ((x), (env)) \
2616 : ceval ((x), (env))) \
2619 #define SCM_I_XEVALCAR(x, env, debug_p) \
2620 (SCM_IMP (SCM_CAR (x)) \
2621 ? SCM_I_EVALIM (SCM_CAR (x), (env)) \
2622 : (SCM_VARIABLEP (SCM_CAR (x)) \
2623 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2624 : (scm_is_pair (SCM_CAR (x)) \
2626 ? deval (SCM_CAR (x), (env)) \
2627 : ceval (SCM_CAR (x), (env))) \
2628 : (!scm_is_symbol (SCM_CAR (x)) \
2630 : *scm_lookupcar ((x), (env), 1)))))
2632 scm_i_pthread_mutex_t source_mutex
;
2635 /* Lookup a given local variable in an environment. The local variable is
2636 * given as an iloc, that is a triple <frame, binding, last?>, where frame
2637 * indicates the relative number of the environment frame (counting upwards
2638 * from the innermost environment frame), binding indicates the number of the
2639 * binding within the frame, and last? (which is extracted from the iloc using
2640 * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
2641 * very end of the improper list of bindings. */
2643 scm_ilookup (SCM iloc
, SCM env
)
2645 unsigned int frame_nr
= SCM_IFRAME (iloc
);
2646 unsigned int binding_nr
= SCM_IDIST (iloc
);
2650 for (; 0 != frame_nr
; --frame_nr
)
2651 frames
= SCM_CDR (frames
);
2653 bindings
= SCM_CAR (frames
);
2654 for (; 0 != binding_nr
; --binding_nr
)
2655 bindings
= SCM_CDR (bindings
);
2657 if (SCM_ICDRP (iloc
))
2658 return SCM_CDRLOC (bindings
);
2659 return SCM_CARLOC (SCM_CDR (bindings
));
2663 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
2665 static void error_unbound_variable (SCM symbol
) SCM_NORETURN
;
2666 static void error_defined_variable (SCM symbol
) SCM_NORETURN
;
2668 /* Call this for variables that are unfound.
2671 error_unbound_variable (SCM symbol
)
2673 scm_error (scm_unbound_variable_key
, NULL
,
2674 "Unbound variable: ~S",
2675 scm_list_1 (symbol
), SCM_BOOL_F
);
2678 /* Call this for variables that are found but contain SCM_UNDEFINED.
2681 error_defined_variable (SCM symbol
)
2683 /* We use the 'unbound-variable' key here as well, since it
2684 basically is the same kind of error, with a slight variation in
2685 the displayed message.
2687 scm_error (scm_unbound_variable_key
, NULL
,
2688 "Variable used before given a value: ~S",
2689 scm_list_1 (symbol
), SCM_BOOL_F
);
2693 /* The Lookup Car Race
2696 Memoization of variables and special forms is done while executing
2697 the code for the first time. As long as there is only one thread
2698 everything is fine, but as soon as two threads execute the same
2699 code concurrently `for the first time' they can come into conflict.
2701 This memoization includes rewriting variable references into more
2702 efficient forms and expanding macros. Furthermore, macro expansion
2703 includes `compiling' special forms like `let', `cond', etc. into
2704 tree-code instructions.
2706 There shouldn't normally be a problem with memoizing local and
2707 global variable references (into ilocs and variables), because all
2708 threads will mutate the code in *exactly* the same way and (if I
2709 read the C code correctly) it is not possible to observe a half-way
2710 mutated cons cell. The lookup procedure can handle this
2711 transparently without any critical sections.
2713 It is different with macro expansion, because macro expansion
2714 happens outside of the lookup procedure and can't be
2715 undone. Therefore the lookup procedure can't cope with it. It has
2716 to indicate failure when it detects a lost race and hope that the
2717 caller can handle it. Luckily, it turns out that this is the case.
2719 An example to illustrate this: Suppose that the following form will
2720 be memoized concurrently by two threads
2724 Let's first examine the lookup of X in the body. The first thread
2725 decides that it has to find the symbol "x" in the environment and
2726 starts to scan it. Then the other thread takes over and actually
2727 overtakes the first. It looks up "x" and substitutes an
2728 appropriate iloc for it. Now the first thread continues and
2729 completes its lookup. It comes to exactly the same conclusions as
2730 the second one and could - without much ado - just overwrite the
2731 iloc with the same iloc.
2733 But let's see what will happen when the race occurs while looking
2734 up the symbol "let" at the start of the form. It could happen that
2735 the second thread interrupts the lookup of the first thread and not
2736 only substitutes a variable for it but goes right ahead and
2737 replaces it with the compiled form (#@let* (x 12) x). Now, when
2738 the first thread completes its lookup, it would replace the #@let*
2739 with a variable containing the "let" binding, effectively reverting
2740 the form to (let (x 12) x). This is wrong. It has to detect that
2741 it has lost the race and the evaluator has to reconsider the
2742 changed form completely.
2744 This race condition could be resolved with some kind of traffic
2745 light (like mutexes) around scm_lookupcar, but I think that it is
2746 best to avoid them in this case. They would serialize memoization
2747 completely and because lookup involves calling arbitrary Scheme
2748 code (via the lookup-thunk), threads could be blocked for an
2749 arbitrary amount of time or even deadlock. But with the current
2750 solution a lot of unnecessary work is potentially done. */
2752 /* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
2753 return NULL to indicate a failed lookup due to some race conditions
2754 between threads. This only happens when VLOC is the first cell of
2755 a special form that will eventually be memoized (like `let', etc.)
2756 In that case the whole lookup is bogus and the caller has to
2757 reconsider the complete special form.
2759 SCM_LOOKUPCAR is still there, of course. It just calls
2760 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
2761 should only be called when it is known that VLOC is not the first
2762 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
2763 for NULL. I think I've found the only places where this
2767 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
2770 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
2771 register SCM iloc
= SCM_ILOC00
;
2772 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
2774 if (!scm_is_pair (SCM_CAR (env
)))
2776 al
= SCM_CARLOC (env
);
2777 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
2779 if (!scm_is_pair (fl
))
2781 if (scm_is_eq (fl
, var
))
2783 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2785 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
2786 return SCM_CDRLOC (*al
);
2791 al
= SCM_CDRLOC (*al
);
2792 if (scm_is_eq (SCM_CAR (fl
), var
))
2794 if (SCM_UNBNDP (SCM_CAR (*al
)))
2795 error_defined_variable (var
);
2796 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2798 SCM_SETCAR (vloc
, iloc
);
2799 return SCM_CARLOC (*al
);
2801 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
2803 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
2806 SCM top_thunk
, real_var
;
2809 top_thunk
= SCM_CAR (env
); /* env now refers to a
2810 top level env thunk */
2811 env
= SCM_CDR (env
);
2814 top_thunk
= SCM_BOOL_F
;
2815 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
2816 if (scm_is_false (real_var
))
2819 if (!scm_is_null (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
2824 if (scm_is_null (env
))
2825 error_unbound_variable (var
);
2827 scm_misc_error (NULL
, "Damaged environment: ~S",
2832 /* A variable could not be found, but we shall
2833 not throw an error. */
2834 static SCM undef_object
= SCM_UNDEFINED
;
2835 return &undef_object
;
2839 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2841 /* Some other thread has changed the very cell we are working
2842 on. In effect, it must have done our job or messed it up
2845 var
= SCM_CAR (vloc
);
2846 if (SCM_VARIABLEP (var
))
2847 return SCM_VARIABLE_LOC (var
);
2848 if (SCM_ILOCP (var
))
2849 return scm_ilookup (var
, genv
);
2850 /* We can't cope with anything else than variables and ilocs. When
2851 a special form has been memoized (i.e. `let' into `#@let') we
2852 return NULL and expect the calling function to do the right
2853 thing. For the evaluator, this means going back and redoing
2854 the dispatch on the car of the form. */
2858 SCM_SETCAR (vloc
, real_var
);
2859 return SCM_VARIABLE_LOC (real_var
);
2864 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
2866 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
2873 /* During execution, look up a symbol in the top level of the given local
2874 * environment and return the corresponding variable object. If no binding
2875 * for the symbol can be found, an 'Unbound variable' error is signalled. */
2877 lazy_memoize_variable (const SCM symbol
, const SCM environment
)
2879 const SCM top_level
= scm_env_top_level (environment
);
2880 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
2882 if (scm_is_false (variable
))
2883 error_unbound_variable (symbol
);
2890 scm_eval_car (SCM pair
, SCM env
)
2892 return SCM_I_XEVALCAR (pair
, env
, scm_debug_mode_p
);
2897 scm_eval_body (SCM code
, SCM env
)
2902 next
= SCM_CDR (code
);
2903 while (!scm_is_null (next
))
2905 if (SCM_IMP (SCM_CAR (code
)))
2907 if (SCM_ISYMP (SCM_CAR (code
)))
2909 scm_dynwind_begin (0);
2910 scm_i_dynwind_pthread_mutex_lock (&source_mutex
);
2911 /* check for race condition */
2912 if (SCM_ISYMP (SCM_CAR (code
)))
2913 m_expand_body (code
, env
);
2919 SCM_I_XEVAL (SCM_CAR (code
), env
, scm_debug_mode_p
);
2921 next
= SCM_CDR (code
);
2923 return SCM_I_XEVALCAR (code
, env
, scm_debug_mode_p
);
2927 /* scm_last_debug_frame contains a pointer to the last debugging information
2928 * stack frame. It is accessed very often from the debugging evaluator, so it
2929 * should probably not be indirectly addressed. Better to save and restore it
2930 * from the current root at any stack swaps.
2933 /* scm_debug_eframe_size is the number of slots available for pseudo
2934 * stack frames at each real stack frame.
2937 long scm_debug_eframe_size
;
2939 int scm_debug_mode_p
;
2940 int scm_check_entry_p
;
2941 int scm_check_apply_p
;
2942 int scm_check_exit_p
;
2943 int scm_check_memoize_p
;
2945 long scm_eval_stack
;
2947 scm_t_option scm_eval_opts
[] = {
2948 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." },
2952 scm_t_option scm_debug_opts
[] = {
2953 { SCM_OPTION_BOOLEAN
, "cheap", 1,
2954 "*This option is now obsolete. Setting it has no effect." },
2955 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
2956 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
2957 { SCM_OPTION_BOOLEAN
, "procnames", 1,
2958 "Record procedure names at definition." },
2959 { SCM_OPTION_BOOLEAN
, "backwards", 0,
2960 "Display backtrace in anti-chronological order." },
2961 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
2962 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
2963 { SCM_OPTION_INTEGER
, "frames", 3,
2964 "Maximum number of tail-recursive frames in backtrace." },
2965 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
2966 "Maximal number of stored backtrace frames." },
2967 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
2968 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
2969 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
2971 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
2972 { SCM_OPTION_SCM
, "show-file-name", (unsigned long)SCM_BOOL_T
,
2973 "Show file names and line numbers "
2974 "in backtraces when not `#f'. A value of `base' "
2975 "displays only base names, while `#t' displays full names."},
2976 { SCM_OPTION_BOOLEAN
, "warn-deprecated", 0,
2977 "Warn when deprecated features are used." },
2983 * this ordering is awkward and illogical, but we maintain it for
2984 * compatibility. --hwn
2986 scm_t_option scm_evaluator_trap_table
[] = {
2987 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
2988 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
2989 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
2990 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
2991 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
2992 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
2993 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." },
2994 { SCM_OPTION_BOOLEAN
, "memoize-symbol", 0, "Trap when memoizing a symbol." },
2995 { SCM_OPTION_SCM
, "memoize-symbol-handler", (unsigned long)SCM_BOOL_F
, "The handler for memoization." },
3000 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
3002 "Option interface for the evaluation options. Instead of using\n"
3003 "this procedure directly, use the procedures @code{eval-enable},\n"
3004 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
3005 #define FUNC_NAME s_scm_eval_options_interface
3009 scm_dynwind_begin (0);
3010 scm_dynwind_critical_section (SCM_BOOL_F
);
3011 ans
= scm_options (setting
,
3014 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
3022 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
3024 "Option interface for the evaluator trap options.")
3025 #define FUNC_NAME s_scm_evaluator_traps
3030 scm_options_try (setting
,
3031 scm_evaluator_trap_table
,
3033 SCM_CRITICAL_SECTION_START
;
3034 ans
= scm_options (setting
,
3035 scm_evaluator_trap_table
,
3038 /* njrev: same again. */
3039 SCM_RESET_DEBUG_MODE
;
3040 SCM_CRITICAL_SECTION_END
;
3049 /* Simple procedure calls
3053 scm_call_0 (SCM proc
)
3055 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
3059 scm_call_1 (SCM proc
, SCM arg1
)
3061 return scm_apply (proc
, arg1
, scm_listofnull
);
3065 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
3067 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
3071 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
3073 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
3077 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
3079 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
3080 scm_cons (arg4
, scm_listofnull
)));
3083 /* Simple procedure applies
3087 scm_apply_0 (SCM proc
, SCM args
)
3089 return scm_apply (proc
, args
, SCM_EOL
);
3093 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
3095 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
3099 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
3101 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
3105 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
3107 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
3111 /* This code processes the arguments to apply:
3113 (apply PROC ARG1 ... ARGS)
3115 Given a list (ARG1 ... ARGS), this function conses the ARG1
3116 ... arguments onto the front of ARGS, and returns the resulting
3117 list. Note that ARGS is a list; thus, the argument to this
3118 function is a list whose last element is a list.
3120 Apply calls this function, and applies PROC to the elements of the
3121 result. apply:nconc2last takes care of building the list of
3122 arguments, given (ARG1 ... ARGS).
3124 Rather than do new consing, apply:nconc2last destroys its argument.
3125 On that topic, this code came into my care with the following
3126 beautifully cryptic comment on that topic: "This will only screw
3127 you if you do (scm_apply scm_apply '( ... ))" If you know what
3128 they're referring to, send me a patch to this comment. */
3130 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3132 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
3133 "conses the @var{arg1} @dots{} arguments onto the front of\n"
3134 "@var{args}, and returns the resulting list. Note that\n"
3135 "@var{args} is a list; thus, the argument to this function is\n"
3136 "a list whose last element is a list.\n"
3137 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
3138 "destroys its argument, so use with care.")
3139 #define FUNC_NAME s_scm_nconc2last
3142 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
3144 while (!scm_is_null (SCM_CDR (*lloc
))) /* Perhaps should be
3145 SCM_NULL_OR_NIL_P, but not
3146 needed in 99.99% of cases,
3147 and it could seriously hurt
3148 performance. - Neil */
3149 lloc
= SCM_CDRLOC (*lloc
);
3150 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3151 *lloc
= SCM_CAR (*lloc
);
3158 /* SECTION: The rest of this file is only read once.
3163 * Trampolines make it possible to move procedure application dispatch
3164 * outside inner loops. The motivation was clean implementation of
3165 * efficient replacements of R5RS primitives in SRFI-1.
3167 * The semantics is clear: scm_trampoline_N returns an optimized
3168 * version of scm_call_N (or NULL if the procedure isn't applicable
3171 * Applying the optimization to map and for-each increased efficiency
3172 * noticeably. For example, (map abs ls) is now 8 times faster than
3177 call_subr0_0 (SCM proc
)
3179 return SCM_SUBRF (proc
) ();
3183 call_subr1o_0 (SCM proc
)
3185 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
3189 call_lsubr_0 (SCM proc
)
3191 return SCM_SUBRF (proc
) (SCM_EOL
);
3195 scm_i_call_closure_0 (SCM proc
)
3197 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3200 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
3205 scm_trampoline_0 (SCM proc
)
3207 scm_t_trampoline_0 trampoline
;
3212 switch (SCM_TYP7 (proc
))
3214 case scm_tc7_subr_0
:
3215 trampoline
= call_subr0_0
;
3217 case scm_tc7_subr_1o
:
3218 trampoline
= call_subr1o_0
;
3221 trampoline
= call_lsubr_0
;
3223 case scm_tcs_closures
:
3225 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3226 if (scm_is_null (formals
) || !scm_is_pair (formals
))
3227 trampoline
= scm_i_call_closure_0
;
3232 case scm_tcs_struct
:
3233 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3234 trampoline
= scm_call_generic_0
;
3235 else if (SCM_I_OPERATORP (proc
))
3236 trampoline
= scm_call_0
;
3241 if (SCM_SMOB_APPLICABLE_P (proc
))
3242 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
3247 case scm_tc7_rpsubr
:
3250 trampoline
= scm_call_0
;
3253 return NULL
; /* not applicable on zero arguments */
3255 /* We only reach this point if a valid trampoline was determined. */
3257 /* If debugging is enabled, we want to see all calls to proc on the stack.
3258 * Thus, we replace the trampoline shortcut with scm_call_0. */
3259 if (scm_debug_mode_p
)
3266 call_subr1_1 (SCM proc
, SCM arg1
)
3268 return SCM_SUBRF (proc
) (arg1
);
3272 call_subr2o_1 (SCM proc
, SCM arg1
)
3274 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
3278 call_lsubr_1 (SCM proc
, SCM arg1
)
3280 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
3284 call_dsubr_1 (SCM proc
, SCM arg1
)
3286 if (SCM_I_INUMP (arg1
))
3288 return (scm_from_double (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
))));
3290 else if (SCM_REALP (arg1
))
3292 return (scm_from_double (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3294 else if (SCM_BIGP (arg1
))
3296 return (scm_from_double (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3298 else if (SCM_FRACTIONP (arg1
))
3300 return (scm_from_double (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
3302 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3303 SCM_ARG1
, scm_i_symbol_chars (SCM_SNAME (proc
)));
3307 call_cxr_1 (SCM proc
, SCM arg1
)
3309 return scm_i_chase_pairs (arg1
, (scm_t_bits
) SCM_SUBRF (proc
));
3313 call_closure_1 (SCM proc
, SCM arg1
)
3315 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3318 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
3323 scm_trampoline_1 (SCM proc
)
3325 scm_t_trampoline_1 trampoline
;
3330 switch (SCM_TYP7 (proc
))
3332 case scm_tc7_subr_1
:
3333 case scm_tc7_subr_1o
:
3334 trampoline
= call_subr1_1
;
3336 case scm_tc7_subr_2o
:
3337 trampoline
= call_subr2o_1
;
3340 trampoline
= call_lsubr_1
;
3343 trampoline
= call_dsubr_1
;
3346 trampoline
= call_cxr_1
;
3348 case scm_tcs_closures
:
3350 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3351 if (!scm_is_null (formals
)
3352 && (!scm_is_pair (formals
) || !scm_is_pair (SCM_CDR (formals
))))
3353 trampoline
= call_closure_1
;
3358 case scm_tcs_struct
:
3359 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3360 trampoline
= scm_call_generic_1
;
3361 else if (SCM_I_OPERATORP (proc
))
3362 trampoline
= scm_call_1
;
3367 if (SCM_SMOB_APPLICABLE_P (proc
))
3368 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
3373 case scm_tc7_rpsubr
:
3376 trampoline
= scm_call_1
;
3379 return NULL
; /* not applicable on one arg */
3381 /* We only reach this point if a valid trampoline was determined. */
3383 /* If debugging is enabled, we want to see all calls to proc on the stack.
3384 * Thus, we replace the trampoline shortcut with scm_call_1. */
3385 if (scm_debug_mode_p
)
3392 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
3394 return SCM_SUBRF (proc
) (arg1
, arg2
);
3398 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
3400 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
3404 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
3406 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
3410 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
3412 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3413 scm_list_2 (arg1
, arg2
),
3415 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
3420 scm_trampoline_2 (SCM proc
)
3422 scm_t_trampoline_2 trampoline
;
3427 switch (SCM_TYP7 (proc
))
3429 case scm_tc7_subr_2
:
3430 case scm_tc7_subr_2o
:
3431 case scm_tc7_rpsubr
:
3433 trampoline
= call_subr2_2
;
3435 case scm_tc7_lsubr_2
:
3436 trampoline
= call_lsubr2_2
;
3439 trampoline
= call_lsubr_2
;
3441 case scm_tcs_closures
:
3443 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3444 if (!scm_is_null (formals
)
3445 && (!scm_is_pair (formals
)
3446 || (!scm_is_null (SCM_CDR (formals
))
3447 && (!scm_is_pair (SCM_CDR (formals
))
3448 || !scm_is_pair (SCM_CDDR (formals
))))))
3449 trampoline
= call_closure_2
;
3454 case scm_tcs_struct
:
3455 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3456 trampoline
= scm_call_generic_2
;
3457 else if (SCM_I_OPERATORP (proc
))
3458 trampoline
= scm_call_2
;
3463 if (SCM_SMOB_APPLICABLE_P (proc
))
3464 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
3470 trampoline
= scm_call_2
;
3473 return NULL
; /* not applicable on two args */
3475 /* We only reach this point if a valid trampoline was determined. */
3477 /* If debugging is enabled, we want to see all calls to proc on the stack.
3478 * Thus, we replace the trampoline shortcut with scm_call_2. */
3479 if (scm_debug_mode_p
)
3485 /* Typechecking for multi-argument MAP and FOR-EACH.
3487 Verify that each element of the vector ARGV, except for the first,
3488 is a proper list whose length is LEN. Attribute errors to WHO,
3489 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3491 check_map_args (SCM argv
,
3500 for (i
= SCM_SIMPLE_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
3502 SCM elt
= SCM_SIMPLE_VECTOR_REF (argv
, i
);
3503 long elt_len
= scm_ilength (elt
);
3508 scm_apply_generic (gf
, scm_cons (proc
, args
));
3510 scm_wrong_type_arg (who
, i
+ 2, elt
);
3514 scm_out_of_range_pos (who
, elt
, scm_from_long (i
+ 2));
3519 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3521 /* Note: Currently, scm_map applies PROC to the argument list(s)
3522 sequentially, starting with the first element(s). This is used in
3523 evalext.c where the Scheme procedure `map-in-order', which guarantees
3524 sequential behaviour, is implemented using scm_map. If the
3525 behaviour changes, we need to update `map-in-order'.
3529 scm_map (SCM proc
, SCM arg1
, SCM args
)
3530 #define FUNC_NAME s_map
3536 len
= scm_ilength (arg1
);
3537 SCM_GASSERTn (len
>= 0,
3538 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
3539 SCM_VALIDATE_REST_ARGUMENT (args
);
3540 if (scm_is_null (args
))
3542 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
3543 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
3544 while (SCM_NIMP (arg1
))
3546 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
3547 pres
= SCM_CDRLOC (*pres
);
3548 arg1
= SCM_CDR (arg1
);
3552 if (scm_is_null (SCM_CDR (args
)))
3554 SCM arg2
= SCM_CAR (args
);
3555 int len2
= scm_ilength (arg2
);
3556 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
3558 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
3559 SCM_GASSERTn (len2
>= 0,
3560 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
3562 SCM_OUT_OF_RANGE (3, arg2
);
3563 while (SCM_NIMP (arg1
))
3565 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
3566 pres
= SCM_CDRLOC (*pres
);
3567 arg1
= SCM_CDR (arg1
);
3568 arg2
= SCM_CDR (arg2
);
3572 arg1
= scm_cons (arg1
, args
);
3573 args
= scm_vector (arg1
);
3574 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
3578 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3580 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
3583 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
3584 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
3586 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
3587 pres
= SCM_CDRLOC (*pres
);
3593 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
3596 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
3597 #define FUNC_NAME s_for_each
3600 len
= scm_ilength (arg1
);
3601 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
3602 SCM_ARG2
, s_for_each
);
3603 SCM_VALIDATE_REST_ARGUMENT (args
);
3604 if (scm_is_null (args
))
3606 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
3607 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
3608 while (SCM_NIMP (arg1
))
3610 call (proc
, SCM_CAR (arg1
));
3611 arg1
= SCM_CDR (arg1
);
3613 return SCM_UNSPECIFIED
;
3615 if (scm_is_null (SCM_CDR (args
)))
3617 SCM arg2
= SCM_CAR (args
);
3618 int len2
= scm_ilength (arg2
);
3619 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
3620 SCM_GASSERTn (call
, g_for_each
,
3621 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
3622 SCM_GASSERTn (len2
>= 0, g_for_each
,
3623 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
3625 SCM_OUT_OF_RANGE (3, arg2
);
3626 while (SCM_NIMP (arg1
))
3628 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
3629 arg1
= SCM_CDR (arg1
);
3630 arg2
= SCM_CDR (arg2
);
3632 return SCM_UNSPECIFIED
;
3634 arg1
= scm_cons (arg1
, args
);
3635 args
= scm_vector (arg1
);
3636 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
3640 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3642 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
3644 return SCM_UNSPECIFIED
;
3645 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
3646 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
3648 scm_apply (proc
, arg1
, SCM_EOL
);
3655 scm_closure (SCM code
, SCM env
)
3658 SCM closcar
= scm_cons (code
, SCM_EOL
);
3659 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
3660 scm_remember_upto_here (closcar
);
3665 scm_t_bits scm_tc16_promise
;
3668 scm_makprom (SCM code
)
3670 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
3672 scm_make_recursive_mutex ());
3676 promise_mark (SCM promise
)
3678 scm_gc_mark (SCM_PROMISE_MUTEX (promise
));
3679 return SCM_PROMISE_DATA (promise
);
3683 promise_free (SCM promise
)
3689 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
3691 int writingp
= SCM_WRITINGP (pstate
);
3692 scm_puts ("#<promise ", port
);
3693 SCM_SET_WRITINGP (pstate
, 1);
3694 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
3695 SCM_SET_WRITINGP (pstate
, writingp
);
3696 scm_putc ('>', port
);
3700 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
3702 "If the promise @var{x} has not been computed yet, compute and\n"
3703 "return @var{x}, otherwise just return the previously computed\n"
3705 #define FUNC_NAME s_scm_force
3707 SCM_VALIDATE_SMOB (1, promise
, promise
);
3708 scm_lock_mutex (SCM_PROMISE_MUTEX (promise
));
3709 if (!SCM_PROMISE_COMPUTED_P (promise
))
3711 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
3712 if (!SCM_PROMISE_COMPUTED_P (promise
))
3714 SCM_SET_PROMISE_DATA (promise
, ans
);
3715 SCM_SET_PROMISE_COMPUTED (promise
);
3718 scm_unlock_mutex (SCM_PROMISE_MUTEX (promise
));
3719 return SCM_PROMISE_DATA (promise
);
3724 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
3726 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
3727 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
3728 #define FUNC_NAME s_scm_promise_p
3730 return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
3735 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
3736 (SCM xorig
, SCM x
, SCM y
),
3737 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
3738 "Any source properties associated with @var{xorig} are also associated\n"
3739 "with the new pair.")
3740 #define FUNC_NAME s_scm_cons_source
3743 z
= scm_cons (x
, y
);
3744 /* Copy source properties possibly associated with xorig. */
3745 p
= scm_whash_lookup (scm_source_whash
, xorig
);
3746 if (scm_is_true (p
))
3747 scm_whash_insert (scm_source_whash
, z
, p
);
3753 /* The function scm_copy_tree is used to copy an expression tree to allow the
3754 * memoizer to modify the expression during memoization. scm_copy_tree
3755 * creates deep copies of pairs and vectors, but not of any other data types,
3756 * since only pairs and vectors will be parsed by the memoizer.
3758 * To avoid infinite recursion due to cyclic structures, the hare-and-tortoise
3759 * pattern is used to detect cycles. In fact, the pattern is used in two
3760 * dimensions, vertical (indicated in the code by the variable names 'hare'
3761 * and 'tortoise') and horizontal ('rabbit' and 'turtle'). In both
3762 * dimensions, the hare/rabbit will take two steps when the tortoise/turtle
3765 * The vertical dimension corresponds to recursive calls to function
3766 * copy_tree: This happens when descending into vector elements, into cars of
3767 * lists and into the cdr of an improper list. In this dimension, the
3768 * tortoise follows the hare by using the processor stack: Every stack frame
3769 * will hold an instance of struct t_trace. These instances are connected in
3770 * a way that represents the trace of the hare, which thus can be followed by
3771 * the tortoise. The tortoise will always point to struct t_trace instances
3772 * relating to SCM objects that have already been copied. Thus, a cycle is
3773 * detected if the tortoise and the hare point to the same object,
3775 * The horizontal dimension is within one execution of copy_tree, when the
3776 * function cdr's along the pairs of a list. This is the standard
3777 * hare-and-tortoise implementation, found several times in guile. */
3780 struct t_trace
*trace
; /* These pointers form a trace along the stack. */
3781 SCM obj
; /* The object handled at the respective stack frame.*/
3786 struct t_trace
*const hare
,
3787 struct t_trace
*tortoise
,
3788 unsigned int tortoise_delay
)
3790 if (!scm_is_pair (hare
->obj
) && !scm_is_simple_vector (hare
->obj
))
3796 /* Prepare the trace along the stack. */
3797 struct t_trace new_hare
;
3798 hare
->trace
= &new_hare
;
3800 /* The tortoise will make its step after the delay has elapsed. Note
3801 * that in contrast to the typical hare-and-tortoise pattern, the step
3802 * of the tortoise happens before the hare takes its steps. This is, in
3803 * principle, no problem, except for the start of the algorithm: Then,
3804 * it has to be made sure that the hare actually gets its advantage of
3806 if (tortoise_delay
== 0)
3809 tortoise
= tortoise
->trace
;
3810 ASSERT_SYNTAX (!scm_is_eq (hare
->obj
, tortoise
->obj
),
3811 s_bad_expression
, hare
->obj
);
3818 if (scm_is_simple_vector (hare
->obj
))
3820 size_t length
= SCM_SIMPLE_VECTOR_LENGTH (hare
->obj
);
3821 SCM new_vector
= scm_c_make_vector (length
, SCM_UNSPECIFIED
);
3823 /* Each vector element is copied by recursing into copy_tree, having
3824 * the tortoise follow the hare into the depths of the stack. */
3825 unsigned long int i
;
3826 for (i
= 0; i
< length
; ++i
)
3829 new_hare
.obj
= SCM_SIMPLE_VECTOR_REF (hare
->obj
, i
);
3830 new_element
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3831 SCM_SIMPLE_VECTOR_SET (new_vector
, i
, new_element
);
3836 else /* scm_is_pair (hare->obj) */
3841 SCM rabbit
= hare
->obj
;
3842 SCM turtle
= hare
->obj
;
3846 /* The first pair of the list is treated specially, in order to
3847 * preserve a potential source code position. */
3848 result
= tail
= scm_cons_source (rabbit
, SCM_EOL
, SCM_EOL
);
3849 new_hare
.obj
= SCM_CAR (rabbit
);
3850 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3851 SCM_SETCAR (tail
, copy
);
3853 /* The remaining pairs of the list are copied by, horizontally,
3854 * having the turtle follow the rabbit, and, vertically, having the
3855 * tortoise follow the hare into the depths of the stack. */
3856 rabbit
= SCM_CDR (rabbit
);
3857 while (scm_is_pair (rabbit
))
3859 new_hare
.obj
= SCM_CAR (rabbit
);
3860 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3861 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
3862 tail
= SCM_CDR (tail
);
3864 rabbit
= SCM_CDR (rabbit
);
3865 if (scm_is_pair (rabbit
))
3867 new_hare
.obj
= SCM_CAR (rabbit
);
3868 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3869 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
3870 tail
= SCM_CDR (tail
);
3871 rabbit
= SCM_CDR (rabbit
);
3873 turtle
= SCM_CDR (turtle
);
3874 ASSERT_SYNTAX (!scm_is_eq (rabbit
, turtle
),
3875 s_bad_expression
, rabbit
);
3879 /* We have to recurse into copy_tree again for the last cdr, in
3880 * order to handle the situation that it holds a vector. */
3881 new_hare
.obj
= rabbit
;
3882 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3883 SCM_SETCDR (tail
, copy
);
3890 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
3892 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
3893 "the new data structure. @code{copy-tree} recurses down the\n"
3894 "contents of both pairs and vectors (since both cons cells and vector\n"
3895 "cells may point to arbitrary objects), and stops recursing when it hits\n"
3896 "any other object.")
3897 #define FUNC_NAME s_scm_copy_tree
3899 /* Prepare the trace along the stack. */
3900 struct t_trace trace
;
3903 /* In function copy_tree, if the tortoise makes its step, it will do this
3904 * before the hare has the chance to move. Thus, we have to make sure that
3905 * the very first step of the tortoise will not happen after the hare has
3906 * really made two steps. This is achieved by passing '2' as the initial
3907 * delay for the tortoise. NOTE: Since cycles are unlikely, giving the hare
3908 * a bigger advantage may improve performance slightly. */
3909 return copy_tree (&trace
, &trace
, 2);
3914 /* We have three levels of EVAL here:
3916 - scm_i_eval (exp, env)
3918 evaluates EXP in environment ENV. ENV is a lexical environment
3919 structure as used by the actual tree code evaluator. When ENV is
3920 a top-level environment, then changes to the current module are
3921 tracked by updating ENV so that it continues to be in sync with
3924 - scm_primitive_eval (exp)
3926 evaluates EXP in the top-level environment as determined by the
3927 current module. This is done by constructing a suitable
3928 environment and calling scm_i_eval. Thus, changes to the
3929 top-level module are tracked normally.
3931 - scm_eval (exp, mod_or_state)
3933 evaluates EXP while MOD_OR_STATE is the current module or current
3934 dynamic state (as appropriate). This is done by setting the
3935 current module (or dynamic state) to MOD_OR_STATE, invoking
3936 scm_primitive_eval on EXP, and then restoring the current module
3937 (or dynamic state) to the value it had previously. That is,
3938 while EXP is evaluated, changes to the current module (or dynamic
3939 state) are tracked, but these changes do not persist when
3942 For each level of evals, there are two variants, distinguished by a
3943 _x suffix: the ordinary variant does not modify EXP while the _x
3944 variant can destructively modify EXP into something completely
3945 unintelligible. A Scheme data structure passed as EXP to one of the
3946 _x variants should not ever be used again for anything. So when in
3947 doubt, use the ordinary variant.
3952 scm_i_eval_x (SCM exp
, SCM env
)
3954 if (scm_is_symbol (exp
))
3955 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
3957 return SCM_I_XEVAL (exp
, env
, scm_debug_mode_p
);
3961 scm_i_eval (SCM exp
, SCM env
)
3963 exp
= scm_copy_tree (exp
);
3964 if (scm_is_symbol (exp
))
3965 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
3967 return SCM_I_XEVAL (exp
, env
, scm_debug_mode_p
);
3971 scm_primitive_eval_x (SCM exp
)
3974 SCM transformer
= scm_current_module_transformer ();
3975 if (SCM_NIMP (transformer
))
3976 exp
= scm_call_1 (transformer
, exp
);
3977 env
= scm_top_level_env (scm_current_module_lookup_closure ());
3978 return scm_i_eval_x (exp
, env
);
3981 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
3983 "Evaluate @var{exp} in the top-level environment specified by\n"
3984 "the current module.")
3985 #define FUNC_NAME s_scm_primitive_eval
3988 SCM transformer
= scm_current_module_transformer ();
3989 if (scm_is_true (transformer
))
3990 exp
= scm_call_1 (transformer
, exp
);
3991 env
= scm_top_level_env (scm_current_module_lookup_closure ());
3992 return scm_i_eval (exp
, env
);
3997 /* Eval does not take the second arg optionally. This is intentional
3998 * in order to be R5RS compatible, and to prepare for the new module
3999 * system, where we would like to make the choice of evaluation
4000 * environment explicit. */
4003 scm_eval_x (SCM exp
, SCM module_or_state
)
4007 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
4008 if (scm_is_dynamic_state (module_or_state
))
4009 scm_dynwind_current_dynamic_state (module_or_state
);
4011 scm_dynwind_current_module (module_or_state
);
4013 res
= scm_primitive_eval_x (exp
);
4019 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
4020 (SCM exp
, SCM module_or_state
),
4021 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
4022 "in the top-level environment specified by\n"
4023 "@var{module_or_state}.\n"
4024 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
4025 "@var{module_or_state} is made the current module when\n"
4026 "it is a module, or the current dynamic state when it is\n"
4028 "Example: (eval '(+ 1 2) (interaction-environment))")
4029 #define FUNC_NAME s_scm_eval
4033 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
4034 if (scm_is_dynamic_state (module_or_state
))
4035 scm_dynwind_current_dynamic_state (module_or_state
);
4037 scm_dynwind_current_module (module_or_state
);
4039 res
= scm_primitive_eval (exp
);
4047 /* At this point, deval and scm_dapply are generated.
4059 scm_i_pthread_mutex_init (&source_mutex
,
4060 scm_i_pthread_mutexattr_recursive
);
4062 scm_init_opts (scm_evaluator_traps
,
4063 scm_evaluator_trap_table
);
4064 scm_init_opts (scm_eval_options_interface
,
4067 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
4068 scm_set_smob_mark (scm_tc16_promise
, promise_mark
);
4069 scm_set_smob_free (scm_tc16_promise
, promise_free
);
4070 scm_set_smob_print (scm_tc16_promise
, promise_print
);
4072 undefineds
= scm_list_1 (SCM_UNDEFINED
);
4073 SCM_SETCDR (undefineds
, undefineds
);
4074 scm_permanent_object (undefineds
);
4076 scm_listofnull
= scm_list_1 (SCM_EOL
);
4078 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
4079 scm_permanent_object (f_apply
);
4081 #include "libguile/eval.x"
4083 scm_add_feature ("delay");