1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006
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 (!(cond)) syntax_error (message, form, SCM_UNDEFINED); }
304 #define ASSERT_SYNTAX_2(cond, message, form, expr) \
305 { if (!(cond)) syntax_error (message, form, expr); }
311 * Ilocs are memoized references to variables in local environment frames.
312 * They are represented as three values: The relative offset of the
313 * environment frame, the number of the binding within that frame, and a
314 * boolean value indicating whether the binding is the last binding in the
317 * Frame numbers have 11 bits, relative offsets have 12 bits.
320 #define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc)
321 #define SCM_IFRINC (0x00000100L)
322 #define SCM_ICDR (0x00080000L)
323 #define SCM_IDINC (0x00100000L)
324 #define SCM_IFRAME(n) ((long)((SCM_ICDR-SCM_IFRINC)>>8) \
325 & (SCM_UNPACK (n) >> 8))
326 #define SCM_IDIST(n) (SCM_UNPACK (n) >> 20)
327 #define SCM_ICDRP(n) (SCM_ICDR & SCM_UNPACK (n))
328 #define SCM_IDSTMSK (-SCM_IDINC)
329 #define SCM_IFRAMEMAX ((1<<11)-1)
330 #define SCM_IDISTMAX ((1<<12)-1)
331 #define SCM_MAKE_ILOC(frame_nr, binding_nr, last_p) \
334 + ((binding_nr) << 20) \
335 + ((last_p) ? SCM_ICDR : 0) \
339 scm_i_print_iloc (SCM iloc
, SCM port
)
341 scm_puts ("#@", port
);
342 scm_intprint ((long) SCM_IFRAME (iloc
), 10, port
);
343 scm_putc (SCM_ICDRP (iloc
) ? '-' : '+', port
);
344 scm_intprint ((long) SCM_IDIST (iloc
), 10, port
);
347 #if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
349 SCM
scm_dbg_make_iloc (SCM frame
, SCM binding
, SCM cdrp
);
351 SCM_DEFINE (scm_dbg_make_iloc
, "dbg-make-iloc", 3, 0, 0,
352 (SCM frame
, SCM binding
, SCM cdrp
),
353 "Return a new iloc with frame offset @var{frame}, binding\n"
354 "offset @var{binding} and the cdr flag @var{cdrp}.")
355 #define FUNC_NAME s_scm_dbg_make_iloc
357 return SCM_MAKE_ILOC ((scm_t_bits
) scm_to_unsigned_integer (frame
, 0, SCM_IFRAMEMAX
),
358 (scm_t_bits
) scm_to_unsigned_integer (binding
, 0, SCM_IDISTMAX
),
363 SCM
scm_dbg_iloc_p (SCM obj
);
365 SCM_DEFINE (scm_dbg_iloc_p
, "dbg-iloc?", 1, 0, 0,
367 "Return @code{#t} if @var{obj} is an iloc.")
368 #define FUNC_NAME s_scm_dbg_iloc_p
370 return scm_from_bool (SCM_ILOCP (obj
));
378 /* {Evaluator byte codes (isyms)}
381 #define ISYMNUM(n) (SCM_ITAG8_DATA (n))
383 /* This table must agree with the list of SCM_IM_ constants in tags.h */
384 static const char *const isymnames
[] =
401 "#@call-with-current-continuation",
407 "#@call-with-values",
415 scm_i_print_isym (SCM isym
, SCM port
)
417 const size_t isymnum
= ISYMNUM (isym
);
418 if (isymnum
< (sizeof isymnames
/ sizeof (char *)))
419 scm_puts (isymnames
[isymnum
], port
);
421 scm_ipruk ("isym", isym
, port
);
426 /* The function lookup_symbol is used during memoization: Lookup the symbol in
427 * the environment. If there is no binding for the symbol, SCM_UNDEFINED is
428 * returned. If the symbol is a global variable, the variable object to which
429 * the symbol is bound is returned. Finally, if the symbol is a local
430 * variable the corresponding iloc object is returned. */
432 /* A helper function for lookup_symbol: Try to find the symbol in the top
433 * level environment frame. The function returns SCM_UNDEFINED if the symbol
434 * is unbound and it returns a variable object if the symbol is a global
437 lookup_global_symbol (const SCM symbol
, const SCM top_level
)
439 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
440 if (scm_is_false (variable
))
441 return SCM_UNDEFINED
;
447 lookup_symbol (const SCM symbol
, const SCM env
)
450 unsigned int frame_nr
;
452 for (frame_idx
= env
, frame_nr
= 0;
453 !scm_is_null (frame_idx
);
454 frame_idx
= SCM_CDR (frame_idx
), ++frame_nr
)
456 const SCM frame
= SCM_CAR (frame_idx
);
457 if (scm_is_pair (frame
))
459 /* frame holds a local environment frame */
461 unsigned int symbol_nr
;
463 for (symbol_idx
= SCM_CAR (frame
), symbol_nr
= 0;
464 scm_is_pair (symbol_idx
);
465 symbol_idx
= SCM_CDR (symbol_idx
), ++symbol_nr
)
467 if (scm_is_eq (SCM_CAR (symbol_idx
), symbol
))
468 /* found the symbol, therefore return the iloc */
469 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 0);
471 if (scm_is_eq (symbol_idx
, symbol
))
472 /* found the symbol as the last element of the current frame */
473 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 1);
477 /* no more local environment frames */
478 return lookup_global_symbol (symbol
, frame
);
482 return lookup_global_symbol (symbol
, SCM_BOOL_F
);
486 /* Return true if the symbol is - from the point of view of a macro
487 * transformer - a literal in the sense specified in chapter "pattern
488 * language" of R5RS. In the code below, however, we don't match the
489 * definition of R5RS exactly: It returns true if the identifier has no
490 * binding or if it is a syntactic keyword. */
492 literal_p (const SCM symbol
, const SCM env
)
494 const SCM variable
= lookup_symbol (symbol
, env
);
495 if (SCM_UNBNDP (variable
))
497 if (SCM_VARIABLEP (variable
) && SCM_MACROP (SCM_VARIABLE_REF (variable
)))
504 /* Return true if the expression is self-quoting in the memoized code. Thus,
505 * some other objects (like e. g. vectors) are reported as self-quoting, which
506 * according to R5RS would need to be quoted. */
508 is_self_quoting_p (const SCM expr
)
510 if (scm_is_pair (expr
))
512 else if (scm_is_symbol (expr
))
514 else if (scm_is_null (expr
))
520 SCM_SYMBOL (sym_three_question_marks
, "???");
523 unmemoize_expression (const SCM expr
, const SCM env
)
525 if (SCM_ILOCP (expr
))
528 unsigned long int frame_nr
;
530 unsigned long int symbol_nr
;
532 for (frame_idx
= env
, frame_nr
= SCM_IFRAME (expr
);
534 frame_idx
= SCM_CDR (frame_idx
), --frame_nr
)
536 for (symbol_idx
= SCM_CAAR (frame_idx
), symbol_nr
= SCM_IDIST (expr
);
538 symbol_idx
= SCM_CDR (symbol_idx
), --symbol_nr
)
540 return SCM_ICDRP (expr
) ? symbol_idx
: SCM_CAR (symbol_idx
);
542 else if (SCM_VARIABLEP (expr
))
544 const SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), expr
);
545 return scm_is_true (sym
) ? sym
: sym_three_question_marks
;
547 else if (scm_is_simple_vector (expr
))
549 return scm_list_2 (scm_sym_quote
, expr
);
551 else if (!scm_is_pair (expr
))
555 else if (SCM_ISYMP (SCM_CAR (expr
)))
557 return unmemoize_builtin_macro (expr
, env
);
561 return unmemoize_exprs (expr
, env
);
567 unmemoize_exprs (const SCM exprs
, const SCM env
)
569 SCM r_result
= SCM_EOL
;
570 SCM expr_idx
= exprs
;
573 /* Note that due to the current lazy memoizer we may find partially memoized
574 * code during execution. In such code we have to expect improper lists of
575 * expressions: On the one hand, for such code syntax checks have not yet
576 * fully been performed, on the other hand, there may be even legal code
577 * like '(a . b) appear as an improper list of expressions as long as the
578 * quote expression is still in its unmemoized form. For this reason, the
579 * following code handles improper lists of expressions until memoization
580 * and execution have been completely separated. */
581 for (; scm_is_pair (expr_idx
); expr_idx
= SCM_CDR (expr_idx
))
583 const SCM expr
= SCM_CAR (expr_idx
);
585 /* In partially memoized code, lists of expressions that stem from a
586 * body form may start with an ISYM if the body itself has not yet been
587 * memoized. This isym is just an internal marker to indicate that the
588 * body still needs to be memoized. An isym may occur at the very
589 * beginning of the body or after one or more comment strings. It is
590 * dropped during unmemoization. */
591 if (!SCM_ISYMP (expr
))
593 um_expr
= unmemoize_expression (expr
, env
);
594 r_result
= scm_cons (um_expr
, r_result
);
597 um_expr
= unmemoize_expression (expr_idx
, env
);
598 if (!scm_is_null (r_result
))
600 const SCM result
= scm_reverse_x (r_result
, SCM_UNDEFINED
);
601 SCM_SETCDR (r_result
, um_expr
);
611 /* Rewrite the body (which is given as the list of expressions forming the
612 * body) into its internal form. The internal form of a body (<expr> ...) is
613 * just the body itself, but prefixed with an ISYM that denotes to what kind
614 * of outer construct this body belongs: (<ISYM> <expr> ...). A lambda body
615 * starts with SCM_IM_LAMBDA, for example, a body of a let starts with
618 * It is assumed that the calling expression has already made sure that the
619 * body is a proper list. */
621 m_body (SCM op
, SCM exprs
)
623 /* Don't add another ISYM if one is present already. */
624 if (SCM_ISYMP (SCM_CAR (exprs
)))
627 return scm_cons (op
, exprs
);
631 /* The function m_expand_body memoizes a proper list of expressions forming a
632 * body. This function takes care of dealing with internal defines and
633 * transforming them into an equivalent letrec expression. The list of
634 * expressions is rewritten in place. */
636 /* This is a helper function for m_expand_body. If the argument expression is
637 * a symbol that denotes a syntactic keyword, the corresponding macro object
638 * is returned, in all other cases the function returns SCM_UNDEFINED. */
640 try_macro_lookup (const SCM expr
, const SCM env
)
642 if (scm_is_symbol (expr
))
644 const SCM variable
= lookup_symbol (expr
, env
);
645 if (SCM_VARIABLEP (variable
))
647 const SCM value
= SCM_VARIABLE_REF (variable
);
648 if (SCM_MACROP (value
))
653 return SCM_UNDEFINED
;
656 /* This is a helper function for m_expand_body. It expands user macros,
657 * because for the correct translation of a body we need to know whether they
658 * expand to a definition. */
660 expand_user_macros (SCM expr
, const SCM env
)
662 while (scm_is_pair (expr
))
664 const SCM car_expr
= SCM_CAR (expr
);
665 const SCM new_car
= expand_user_macros (car_expr
, env
);
666 const SCM value
= try_macro_lookup (new_car
, env
);
668 if (SCM_MACROP (value
) && SCM_MACRO_TYPE (value
) == 2)
670 /* User macros transform code into code. */
671 expr
= scm_call_2 (SCM_MACRO_CODE (value
), expr
, env
);
672 /* We need to reiterate on the transformed code. */
676 /* No user macro: return. */
677 SCM_SETCAR (expr
, new_car
);
685 /* This is a helper function for m_expand_body. It determines if a given form
686 * represents an application of a given built-in macro. The built-in macro to
687 * check for is identified by its syntactic keyword. The form is an
688 * application of the given macro if looking up the car of the form in the
689 * given environment actually returns the built-in macro. */
691 is_system_macro_p (const SCM syntactic_keyword
, const SCM form
, const SCM env
)
693 if (scm_is_pair (form
))
695 const SCM car_form
= SCM_CAR (form
);
696 const SCM value
= try_macro_lookup (car_form
, env
);
697 if (SCM_BUILTIN_MACRO_P (value
))
699 const SCM macro_name
= scm_macro_name (value
);
700 return scm_is_eq (macro_name
, syntactic_keyword
);
708 m_expand_body (const SCM forms
, const SCM env
)
710 /* The first body form can be skipped since it is known to be the ISYM that
711 * was prepended to the body by m_body. */
712 SCM cdr_forms
= SCM_CDR (forms
);
713 SCM form_idx
= cdr_forms
;
714 SCM definitions
= SCM_EOL
;
715 SCM sequence
= SCM_EOL
;
717 /* According to R5RS, the list of body forms consists of two parts: a number
718 * (maybe zero) of definitions, followed by a non-empty sequence of
719 * expressions. Each the definitions and the expressions may be grouped
720 * arbitrarily with begin, but it is not allowed to mix definitions and
721 * expressions. The task of the following loop therefore is to split the
722 * list of body forms into the list of definitions and the sequence of
724 while (!scm_is_null (form_idx
))
726 const SCM form
= SCM_CAR (form_idx
);
727 const SCM new_form
= expand_user_macros (form
, env
);
728 if (is_system_macro_p (scm_sym_define
, new_form
, env
))
730 definitions
= scm_cons (new_form
, definitions
);
731 form_idx
= SCM_CDR (form_idx
);
733 else if (is_system_macro_p (scm_sym_begin
, new_form
, env
))
735 /* We have encountered a group of forms. This has to be either a
736 * (possibly empty) group of (possibly further grouped) definitions,
737 * or a non-empty group of (possibly further grouped)
739 const SCM grouped_forms
= SCM_CDR (new_form
);
740 unsigned int found_definition
= 0;
741 unsigned int found_expression
= 0;
742 SCM grouped_form_idx
= grouped_forms
;
743 while (!found_expression
&& !scm_is_null (grouped_form_idx
))
745 const SCM inner_form
= SCM_CAR (grouped_form_idx
);
746 const SCM new_inner_form
= expand_user_macros (inner_form
, env
);
747 if (is_system_macro_p (scm_sym_define
, new_inner_form
, env
))
749 found_definition
= 1;
750 definitions
= scm_cons (new_inner_form
, definitions
);
751 grouped_form_idx
= SCM_CDR (grouped_form_idx
);
753 else if (is_system_macro_p (scm_sym_begin
, new_inner_form
, env
))
755 const SCM inner_group
= SCM_CDR (new_inner_form
);
757 = scm_append (scm_list_2 (inner_group
,
758 SCM_CDR (grouped_form_idx
)));
762 /* The group marks the start of the expressions of the body.
763 * We have to make sure that within the same group we have
764 * not encountered a definition before. */
765 ASSERT_SYNTAX (!found_definition
, s_mixed_body_forms
, form
);
766 found_expression
= 1;
767 grouped_form_idx
= SCM_EOL
;
771 /* We have finished processing the group. If we have not yet
772 * encountered an expression we continue processing the forms of the
773 * body to collect further definition forms. Otherwise, the group
774 * marks the start of the sequence of expressions of the body. */
775 if (!found_expression
)
777 form_idx
= SCM_CDR (form_idx
);
787 /* We have detected a form which is no definition. This marks the
788 * start of the sequence of expressions of the body. */
794 /* FIXME: forms does not hold information about the file location. */
795 ASSERT_SYNTAX (scm_is_pair (sequence
), s_missing_body_expression
, cdr_forms
);
797 if (!scm_is_null (definitions
))
801 SCM letrec_expression
;
802 SCM new_letrec_expression
;
804 SCM bindings
= SCM_EOL
;
805 for (definition_idx
= definitions
;
806 !scm_is_null (definition_idx
);
807 definition_idx
= SCM_CDR (definition_idx
))
809 const SCM definition
= SCM_CAR (definition_idx
);
810 const SCM canonical_definition
= canonicalize_define (definition
);
811 const SCM binding
= SCM_CDR (canonical_definition
);
812 bindings
= scm_cons (binding
, bindings
);
815 letrec_tail
= scm_cons (bindings
, sequence
);
816 /* FIXME: forms does not hold information about the file location. */
817 letrec_expression
= scm_cons_source (forms
, scm_sym_letrec
, letrec_tail
);
818 new_letrec_expression
= scm_m_letrec (letrec_expression
, env
);
819 SCM_SETCAR (forms
, new_letrec_expression
);
820 SCM_SETCDR (forms
, SCM_EOL
);
824 SCM_SETCAR (forms
, SCM_CAR (sequence
));
825 SCM_SETCDR (forms
, SCM_CDR (sequence
));
830 macroexp (SCM x
, SCM env
)
832 SCM res
, proc
, orig_sym
;
834 /* Don't bother to produce error messages here. We get them when we
835 eventually execute the code for real. */
838 orig_sym
= SCM_CAR (x
);
839 if (!scm_is_symbol (orig_sym
))
843 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
844 if (proc_ptr
== NULL
)
846 /* We have lost the race. */
852 /* Only handle memoizing macros. `Acros' and `macros' are really
853 special forms and should not be evaluated here. */
855 if (!SCM_MACROP (proc
)
856 || (SCM_MACRO_TYPE (proc
) != 2 && !SCM_BUILTIN_MACRO_P (proc
)))
859 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
860 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
862 if (scm_ilength (res
) <= 0)
863 /* Result of expansion is not a list. */
864 return (scm_list_2 (SCM_IM_BEGIN
, res
));
867 /* njrev: Several queries here: (1) I don't see how it can be
868 correct that the SCM_SETCAR 2 lines below this comment needs
869 protection, but the SCM_SETCAR 6 lines above does not, so
870 something here is probably wrong. (2) macroexp() is now only
871 used in one place - scm_m_generalized_set_x - whereas all other
872 macro expansion happens through expand_user_macros. Therefore
873 (2.1) perhaps macroexp() could be eliminated completely now?
874 (2.2) Does expand_user_macros need any critical section
877 SCM_CRITICAL_SECTION_START
;
878 SCM_SETCAR (x
, SCM_CAR (res
));
879 SCM_SETCDR (x
, SCM_CDR (res
));
880 SCM_CRITICAL_SECTION_END
;
886 /* Start of the memoizers for the standard R5RS builtin macros. */
889 SCM_SYNTAX (s_and
, "and", scm_i_makbimacro
, scm_m_and
);
890 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
893 scm_m_and (SCM expr
, SCM env SCM_UNUSED
)
895 const SCM cdr_expr
= SCM_CDR (expr
);
896 const long length
= scm_ilength (cdr_expr
);
898 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
902 /* Special case: (and) is replaced by #t. */
907 SCM_SETCAR (expr
, SCM_IM_AND
);
913 unmemoize_and (const SCM expr
, const SCM env
)
915 return scm_cons (scm_sym_and
, unmemoize_exprs (SCM_CDR (expr
), env
));
919 SCM_SYNTAX (s_begin
, "begin", scm_i_makbimacro
, scm_m_begin
);
920 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
923 scm_m_begin (SCM expr
, SCM env SCM_UNUSED
)
925 const SCM cdr_expr
= SCM_CDR (expr
);
926 /* Dirk:FIXME:: An empty begin clause is not generally allowed by R5RS.
927 * That means, there should be a distinction between uses of begin where an
928 * empty clause is OK and where it is not. */
929 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
931 SCM_SETCAR (expr
, SCM_IM_BEGIN
);
936 unmemoize_begin (const SCM expr
, const SCM env
)
938 return scm_cons (scm_sym_begin
, unmemoize_exprs (SCM_CDR (expr
), env
));
942 SCM_SYNTAX (s_case
, "case", scm_i_makbimacro
, scm_m_case
);
943 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
944 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
947 scm_m_case (SCM expr
, SCM env
)
950 SCM all_labels
= SCM_EOL
;
952 /* Check, whether 'else is a literal, i. e. not bound to a value. */
953 const int else_literal_p
= literal_p (scm_sym_else
, env
);
955 const SCM cdr_expr
= SCM_CDR (expr
);
956 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
957 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_clauses
, expr
);
959 clauses
= SCM_CDR (cdr_expr
);
960 while (!scm_is_null (clauses
))
964 const SCM clause
= SCM_CAR (clauses
);
965 ASSERT_SYNTAX_2 (scm_ilength (clause
) >= 2,
966 s_bad_case_clause
, clause
, expr
);
968 labels
= SCM_CAR (clause
);
969 if (scm_is_pair (labels
))
971 ASSERT_SYNTAX_2 (scm_ilength (labels
) >= 0,
972 s_bad_case_labels
, labels
, expr
);
973 all_labels
= scm_append (scm_list_2 (labels
, all_labels
));
975 else if (scm_is_null (labels
))
977 /* The list of labels is empty. According to R5RS this is allowed.
978 * It means that the sequence of expressions will never be executed.
979 * Therefore, as an optimization, we could remove the whole
984 ASSERT_SYNTAX_2 (scm_is_eq (labels
, scm_sym_else
) && else_literal_p
,
985 s_bad_case_labels
, labels
, expr
);
986 ASSERT_SYNTAX_2 (scm_is_null (SCM_CDR (clauses
)),
987 s_misplaced_else_clause
, clause
, expr
);
990 /* build the new clause */
991 if (scm_is_eq (labels
, scm_sym_else
))
992 SCM_SETCAR (clause
, SCM_IM_ELSE
);
994 clauses
= SCM_CDR (clauses
);
997 /* Check whether all case labels are distinct. */
998 for (; !scm_is_null (all_labels
); all_labels
= SCM_CDR (all_labels
))
1000 const SCM label
= SCM_CAR (all_labels
);
1001 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (label
, SCM_CDR (all_labels
))),
1002 s_duplicate_case_label
, label
, expr
);
1005 SCM_SETCAR (expr
, SCM_IM_CASE
);
1010 unmemoize_case (const SCM expr
, const SCM env
)
1012 const SCM um_key_expr
= unmemoize_expression (SCM_CADR (expr
), env
);
1013 SCM um_clauses
= SCM_EOL
;
1016 for (clause_idx
= SCM_CDDR (expr
);
1017 !scm_is_null (clause_idx
);
1018 clause_idx
= SCM_CDR (clause_idx
))
1020 const SCM clause
= SCM_CAR (clause_idx
);
1021 const SCM labels
= SCM_CAR (clause
);
1022 const SCM exprs
= SCM_CDR (clause
);
1024 const SCM um_exprs
= unmemoize_exprs (exprs
, env
);
1025 const SCM um_labels
= (scm_is_eq (labels
, SCM_IM_ELSE
))
1027 : scm_i_finite_list_copy (labels
);
1028 const SCM um_clause
= scm_cons (um_labels
, um_exprs
);
1030 um_clauses
= scm_cons (um_clause
, um_clauses
);
1032 um_clauses
= scm_reverse_x (um_clauses
, SCM_UNDEFINED
);
1034 return scm_cons2 (scm_sym_case
, um_key_expr
, um_clauses
);
1038 SCM_SYNTAX (s_cond
, "cond", scm_i_makbimacro
, scm_m_cond
);
1039 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
1040 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
1043 scm_m_cond (SCM expr
, SCM env
)
1045 /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
1046 const int else_literal_p
= literal_p (scm_sym_else
, env
);
1047 const int arrow_literal_p
= literal_p (scm_sym_arrow
, env
);
1049 const SCM clauses
= SCM_CDR (expr
);
1052 ASSERT_SYNTAX (scm_ilength (clauses
) >= 0, s_bad_expression
, expr
);
1053 ASSERT_SYNTAX (scm_ilength (clauses
) >= 1, s_missing_clauses
, expr
);
1055 for (clause_idx
= clauses
;
1056 !scm_is_null (clause_idx
);
1057 clause_idx
= SCM_CDR (clause_idx
))
1061 const SCM clause
= SCM_CAR (clause_idx
);
1062 const long length
= scm_ilength (clause
);
1063 ASSERT_SYNTAX_2 (length
>= 1, s_bad_cond_clause
, clause
, expr
);
1065 test
= SCM_CAR (clause
);
1066 if (scm_is_eq (test
, scm_sym_else
) && else_literal_p
)
1068 const int last_clause_p
= scm_is_null (SCM_CDR (clause_idx
));
1069 ASSERT_SYNTAX_2 (length
>= 2,
1070 s_bad_cond_clause
, clause
, expr
);
1071 ASSERT_SYNTAX_2 (last_clause_p
,
1072 s_misplaced_else_clause
, clause
, expr
);
1073 SCM_SETCAR (clause
, SCM_IM_ELSE
);
1075 else if (length
>= 2
1076 && scm_is_eq (SCM_CADR (clause
), scm_sym_arrow
)
1079 ASSERT_SYNTAX_2 (length
> 2, s_missing_recipient
, clause
, expr
);
1080 ASSERT_SYNTAX_2 (length
== 3, s_extra_expression
, clause
, expr
);
1081 SCM_SETCAR (SCM_CDR (clause
), SCM_IM_ARROW
);
1083 /* SRFI 61 extended cond */
1084 else if (length
>= 3
1085 && scm_is_eq (SCM_CADDR (clause
), scm_sym_arrow
)
1088 ASSERT_SYNTAX_2 (length
> 3, s_missing_recipient
, clause
, expr
);
1089 ASSERT_SYNTAX_2 (length
== 4, s_extra_expression
, clause
, expr
);
1090 SCM_SETCAR (SCM_CDDR (clause
), SCM_IM_ARROW
);
1094 SCM_SETCAR (expr
, SCM_IM_COND
);
1099 unmemoize_cond (const SCM expr
, const SCM env
)
1101 SCM um_clauses
= SCM_EOL
;
1104 for (clause_idx
= SCM_CDR (expr
);
1105 !scm_is_null (clause_idx
);
1106 clause_idx
= SCM_CDR (clause_idx
))
1108 const SCM clause
= SCM_CAR (clause_idx
);
1109 const SCM sequence
= SCM_CDR (clause
);
1110 const SCM test
= SCM_CAR (clause
);
1115 if (scm_is_eq (test
, SCM_IM_ELSE
))
1116 um_test
= scm_sym_else
;
1118 um_test
= unmemoize_expression (test
, env
);
1120 if (!scm_is_null (sequence
) && scm_is_eq (SCM_CAR (sequence
),
1123 const SCM target
= SCM_CADR (sequence
);
1124 const SCM um_target
= unmemoize_expression (target
, env
);
1125 um_sequence
= scm_list_2 (scm_sym_arrow
, um_target
);
1129 um_sequence
= unmemoize_exprs (sequence
, env
);
1132 um_clause
= scm_cons (um_test
, um_sequence
);
1133 um_clauses
= scm_cons (um_clause
, um_clauses
);
1135 um_clauses
= scm_reverse_x (um_clauses
, SCM_UNDEFINED
);
1137 return scm_cons (scm_sym_cond
, um_clauses
);
1141 SCM_SYNTAX (s_define
, "define", scm_i_makbimacro
, scm_m_define
);
1142 SCM_GLOBAL_SYMBOL (scm_sym_define
, s_define
);
1144 /* Guile provides an extension to R5RS' define syntax to represent function
1145 * currying in a compact way. With this extension, it is allowed to write
1146 * (define <nested-variable> <body>), where <nested-variable> has of one of
1147 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
1148 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
1149 * should be either a sequence of zero or more variables, or a sequence of one
1150 * or more variables followed by a space-delimited period and another
1151 * variable. Each level of argument nesting wraps the <body> within another
1152 * lambda expression. For example, the following forms are allowed, each one
1153 * followed by an equivalent, more explicit implementation.
1155 * (define ((a b . c) . d) <body>) is equivalent to
1156 * (define a (lambda (b . c) (lambda d <body>)))
1158 * (define (((a) b) c . d) <body>) is equivalent to
1159 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
1161 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
1162 * module that does not implement this extension. */
1164 canonicalize_define (const SCM expr
)
1169 const SCM cdr_expr
= SCM_CDR (expr
);
1170 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1171 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1173 body
= SCM_CDR (cdr_expr
);
1174 variable
= SCM_CAR (cdr_expr
);
1175 while (scm_is_pair (variable
))
1177 /* This while loop realizes function currying by variable nesting.
1178 * Variable is known to be a nested-variable. In every iteration of the
1179 * loop another level of lambda expression is created, starting with the
1180 * innermost one. Note that we don't check for duplicate formals here:
1181 * This will be done by the memoizer of the lambda expression. */
1182 const SCM formals
= SCM_CDR (variable
);
1183 const SCM tail
= scm_cons (formals
, body
);
1185 /* Add source properties to each new lambda expression: */
1186 const SCM lambda
= scm_cons_source (variable
, scm_sym_lambda
, tail
);
1188 body
= scm_list_1 (lambda
);
1189 variable
= SCM_CAR (variable
);
1191 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
1192 ASSERT_SYNTAX (scm_ilength (body
) == 1, s_expression
, expr
);
1194 SCM_SETCAR (cdr_expr
, variable
);
1195 SCM_SETCDR (cdr_expr
, body
);
1199 /* According to Section 5.2.1 of R5RS we first have to make sure that the
1200 variable is bound, and then perform the `(set! variable expression)'
1201 operation. However, EXPRESSION _can_ be evaluated before VARIABLE is
1202 bound. This means that EXPRESSION won't necessarily be able to assign
1203 values to VARIABLE as in `(define foo (begin (set! foo 1) (+ foo 1)))'. */
1205 scm_m_define (SCM expr
, SCM env
)
1207 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), s_bad_define
, expr
);
1210 const SCM canonical_definition
= canonicalize_define (expr
);
1211 const SCM cdr_canonical_definition
= SCM_CDR (canonical_definition
);
1212 const SCM variable
= SCM_CAR (cdr_canonical_definition
);
1213 const SCM value
= scm_eval_car (SCM_CDR (cdr_canonical_definition
), env
);
1215 = scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_T
);
1217 if (SCM_REC_PROCNAMES_P
)
1220 while (SCM_MACROP (tmp
))
1221 tmp
= SCM_MACRO_CODE (tmp
);
1222 if (scm_is_true (scm_procedure_p (tmp
))
1223 /* Only the first definition determines the name. */
1224 && scm_is_false (scm_procedure_property (tmp
, scm_sym_name
)))
1225 scm_set_procedure_property_x (tmp
, scm_sym_name
, variable
);
1228 SCM_VARIABLE_SET (location
, value
);
1230 return SCM_UNSPECIFIED
;
1235 /* This is a helper function for forms (<keyword> <expression>) that are
1236 * transformed into (#@<keyword> '() <memoized_expression>) in order to allow
1237 * for easy creation of a thunk (i. e. a closure without arguments) using the
1238 * ('() <memoized_expression>) tail of the memoized form. */
1240 memoize_as_thunk_prototype (const SCM expr
, const SCM env SCM_UNUSED
)
1242 const SCM cdr_expr
= SCM_CDR (expr
);
1243 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1244 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1246 SCM_SETCDR (expr
, scm_cons (SCM_EOL
, cdr_expr
));
1252 SCM_SYNTAX (s_delay
, "delay", scm_i_makbimacro
, scm_m_delay
);
1253 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
1255 /* Promises are implemented as closures with an empty parameter list. Thus,
1256 * (delay <expression>) is transformed into (#@delay '() <expression>), where
1257 * the empty list represents the empty parameter list. This representation
1258 * allows for easy creation of the closure during evaluation. */
1260 scm_m_delay (SCM expr
, SCM env
)
1262 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1263 SCM_SETCAR (new_expr
, SCM_IM_DELAY
);
1268 unmemoize_delay (const SCM expr
, const SCM env
)
1270 const SCM thunk_expr
= SCM_CADDR (expr
);
1271 return scm_list_2 (scm_sym_delay
, unmemoize_expression (thunk_expr
, env
));
1275 SCM_SYNTAX(s_do
, "do", scm_i_makbimacro
, scm_m_do
);
1276 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
1278 /* DO gets the most radically altered syntax. The order of the vars is
1279 * reversed here. During the evaluation this allows for simple consing of the
1280 * results of the inits and steps:
1282 (do ((<var1> <init1> <step1>)
1290 (#@do (<init1> <init2> ... <initn>)
1291 (varn ... var2 var1)
1294 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
1297 scm_m_do (SCM expr
, SCM env SCM_UNUSED
)
1299 SCM variables
= SCM_EOL
;
1300 SCM init_forms
= SCM_EOL
;
1301 SCM step_forms
= SCM_EOL
;
1308 const SCM cdr_expr
= SCM_CDR (expr
);
1309 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1310 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1312 /* Collect variables, init and step forms. */
1313 binding_idx
= SCM_CAR (cdr_expr
);
1314 ASSERT_SYNTAX_2 (scm_ilength (binding_idx
) >= 0,
1315 s_bad_bindings
, binding_idx
, expr
);
1316 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1318 const SCM binding
= SCM_CAR (binding_idx
);
1319 const long length
= scm_ilength (binding
);
1320 ASSERT_SYNTAX_2 (length
== 2 || length
== 3,
1321 s_bad_binding
, binding
, expr
);
1324 const SCM name
= SCM_CAR (binding
);
1325 const SCM init
= SCM_CADR (binding
);
1326 const SCM step
= (length
== 2) ? name
: SCM_CADDR (binding
);
1327 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
1328 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, variables
)),
1329 s_duplicate_binding
, name
, expr
);
1331 variables
= scm_cons (name
, variables
);
1332 init_forms
= scm_cons (init
, init_forms
);
1333 step_forms
= scm_cons (step
, step_forms
);
1336 init_forms
= scm_reverse_x (init_forms
, SCM_UNDEFINED
);
1337 step_forms
= scm_reverse_x (step_forms
, SCM_UNDEFINED
);
1339 /* Memoize the test form and the exit sequence. */
1340 cddr_expr
= SCM_CDR (cdr_expr
);
1341 exit_clause
= SCM_CAR (cddr_expr
);
1342 ASSERT_SYNTAX_2 (scm_ilength (exit_clause
) >= 1,
1343 s_bad_exit_clause
, exit_clause
, expr
);
1345 commands
= SCM_CDR (cddr_expr
);
1346 tail
= scm_cons2 (exit_clause
, commands
, step_forms
);
1347 tail
= scm_cons2 (init_forms
, variables
, tail
);
1348 SCM_SETCAR (expr
, SCM_IM_DO
);
1349 SCM_SETCDR (expr
, tail
);
1354 unmemoize_do (const SCM expr
, const SCM env
)
1356 const SCM cdr_expr
= SCM_CDR (expr
);
1357 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1358 const SCM rnames
= SCM_CAR (cddr_expr
);
1359 const SCM extended_env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
1360 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
1361 const SCM exit_sequence
= SCM_CAR (cdddr_expr
);
1362 const SCM um_exit_sequence
= unmemoize_exprs (exit_sequence
, extended_env
);
1363 const SCM cddddr_expr
= SCM_CDR (cdddr_expr
);
1364 const SCM um_body
= unmemoize_exprs (SCM_CAR (cddddr_expr
), extended_env
);
1366 /* build transformed binding list */
1367 SCM um_names
= scm_reverse (rnames
);
1368 SCM um_inits
= unmemoize_exprs (SCM_CAR (cdr_expr
), env
);
1369 SCM um_steps
= unmemoize_exprs (SCM_CDR (cddddr_expr
), extended_env
);
1370 SCM um_bindings
= SCM_EOL
;
1371 while (!scm_is_null (um_names
))
1373 const SCM name
= SCM_CAR (um_names
);
1374 const SCM init
= SCM_CAR (um_inits
);
1375 SCM step
= SCM_CAR (um_steps
);
1376 step
= scm_is_eq (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
1378 um_bindings
= scm_cons (scm_cons2 (name
, init
, step
), um_bindings
);
1380 um_names
= SCM_CDR (um_names
);
1381 um_inits
= SCM_CDR (um_inits
);
1382 um_steps
= SCM_CDR (um_steps
);
1384 um_bindings
= scm_reverse_x (um_bindings
, SCM_UNDEFINED
);
1386 return scm_cons (scm_sym_do
,
1387 scm_cons2 (um_bindings
, um_exit_sequence
, um_body
));
1391 SCM_SYNTAX (s_if
, "if", scm_i_makbimacro
, scm_m_if
);
1392 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
1395 scm_m_if (SCM expr
, SCM env SCM_UNUSED
)
1397 const SCM cdr_expr
= SCM_CDR (expr
);
1398 const long length
= scm_ilength (cdr_expr
);
1399 ASSERT_SYNTAX (length
== 2 || length
== 3, s_expression
, expr
);
1400 SCM_SETCAR (expr
, SCM_IM_IF
);
1405 unmemoize_if (const SCM expr
, const SCM env
)
1407 const SCM cdr_expr
= SCM_CDR (expr
);
1408 const SCM um_condition
= unmemoize_expression (SCM_CAR (cdr_expr
), env
);
1409 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1410 const SCM um_then
= unmemoize_expression (SCM_CAR (cddr_expr
), env
);
1411 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
1413 if (scm_is_null (cdddr_expr
))
1415 return scm_list_3 (scm_sym_if
, um_condition
, um_then
);
1419 const SCM um_else
= unmemoize_expression (SCM_CAR (cdddr_expr
), env
);
1420 return scm_list_4 (scm_sym_if
, um_condition
, um_then
, um_else
);
1425 SCM_SYNTAX (s_lambda
, "lambda", scm_i_makbimacro
, scm_m_lambda
);
1426 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
1428 /* A helper function for memoize_lambda to support checking for duplicate
1429 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
1430 * LIST or to the cdr of the last cons. Therefore, LIST may have any of the
1431 * forms that a formal argument can have:
1432 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
1434 c_improper_memq (SCM obj
, SCM list
)
1436 for (; scm_is_pair (list
); list
= SCM_CDR (list
))
1438 if (scm_is_eq (SCM_CAR (list
), obj
))
1441 return scm_is_eq (list
, obj
);
1445 scm_m_lambda (SCM expr
, SCM env SCM_UNUSED
)
1454 const SCM cdr_expr
= SCM_CDR (expr
);
1455 const long length
= scm_ilength (cdr_expr
);
1456 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1457 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1459 /* Before iterating the list of formal arguments, make sure the formals
1460 * actually are given as either a symbol or a non-cyclic list. */
1461 formals
= SCM_CAR (cdr_expr
);
1462 if (scm_is_pair (formals
))
1464 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
1465 * detected, report a 'Bad formals' error. */
1469 ASSERT_SYNTAX_2 (scm_is_symbol (formals
) || scm_is_null (formals
),
1470 s_bad_formals
, formals
, expr
);
1473 /* Now iterate the list of formal arguments to check if all formals are
1474 * symbols, and that there are no duplicates. */
1475 formals_idx
= formals
;
1476 while (scm_is_pair (formals_idx
))
1478 const SCM formal
= SCM_CAR (formals_idx
);
1479 const SCM next_idx
= SCM_CDR (formals_idx
);
1480 ASSERT_SYNTAX_2 (scm_is_symbol (formal
), s_bad_formal
, formal
, expr
);
1481 ASSERT_SYNTAX_2 (!c_improper_memq (formal
, next_idx
),
1482 s_duplicate_formal
, formal
, expr
);
1483 formals_idx
= next_idx
;
1485 ASSERT_SYNTAX_2 (scm_is_null (formals_idx
) || scm_is_symbol (formals_idx
),
1486 s_bad_formal
, formals_idx
, expr
);
1488 /* Memoize the body. Keep a potential documentation string. */
1489 /* Dirk:FIXME:: We should probably extract the documentation string to
1490 * some external database. Otherwise it will slow down execution, since
1491 * the documentation string will have to be skipped with every execution
1492 * of the closure. */
1493 cddr_expr
= SCM_CDR (cdr_expr
);
1494 documentation
= (length
>= 3 && scm_is_string (SCM_CAR (cddr_expr
)));
1495 body
= documentation
? SCM_CDR (cddr_expr
) : cddr_expr
;
1496 new_body
= m_body (SCM_IM_LAMBDA
, body
);
1498 SCM_SETCAR (expr
, SCM_IM_LAMBDA
);
1500 SCM_SETCDR (cddr_expr
, new_body
);
1502 SCM_SETCDR (cdr_expr
, new_body
);
1507 unmemoize_lambda (const SCM expr
, const SCM env
)
1509 const SCM formals
= SCM_CADR (expr
);
1510 const SCM body
= SCM_CDDR (expr
);
1512 const SCM new_env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, env
);
1513 const SCM um_formals
= scm_i_finite_list_copy (formals
);
1514 const SCM um_body
= unmemoize_exprs (body
, new_env
);
1516 return scm_cons2 (scm_sym_lambda
, um_formals
, um_body
);
1520 /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
1522 check_bindings (const SCM bindings
, const SCM expr
)
1526 ASSERT_SYNTAX_2 (scm_ilength (bindings
) >= 0,
1527 s_bad_bindings
, bindings
, expr
);
1529 binding_idx
= bindings
;
1530 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1532 SCM name
; /* const */
1534 const SCM binding
= SCM_CAR (binding_idx
);
1535 ASSERT_SYNTAX_2 (scm_ilength (binding
) == 2,
1536 s_bad_binding
, binding
, expr
);
1538 name
= SCM_CAR (binding
);
1539 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
1544 /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
1545 * transformed to the lists (vn ... v2 v1) and (i1 i2 ... in). That is, the
1546 * variables are returned in a list with their order reversed, and the init
1547 * forms are returned in a list in the same order as they are given in the
1548 * bindings. If a duplicate variable name is detected, an error is
1551 transform_bindings (
1552 const SCM bindings
, const SCM expr
,
1553 SCM
*const rvarptr
, SCM
*const initptr
)
1555 SCM rvariables
= SCM_EOL
;
1556 SCM rinits
= SCM_EOL
;
1557 SCM binding_idx
= bindings
;
1558 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1560 const SCM binding
= SCM_CAR (binding_idx
);
1561 const SCM cdr_binding
= SCM_CDR (binding
);
1562 const SCM name
= SCM_CAR (binding
);
1563 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, rvariables
)),
1564 s_duplicate_binding
, name
, expr
);
1565 rvariables
= scm_cons (name
, rvariables
);
1566 rinits
= scm_cons (SCM_CAR (cdr_binding
), rinits
);
1568 *rvarptr
= rvariables
;
1569 *initptr
= scm_reverse_x (rinits
, SCM_UNDEFINED
);
1573 SCM_SYNTAX(s_let
, "let", scm_i_makbimacro
, scm_m_let
);
1574 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
1576 /* This function is a helper function for memoize_let. It transforms
1577 * (let name ((var init) ...) body ...) into
1578 * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
1579 * and memoizes the expression. It is assumed that the caller has checked
1580 * that name is a symbol and that there are bindings and a body. */
1582 memoize_named_let (const SCM expr
, const SCM env SCM_UNUSED
)
1588 const SCM cdr_expr
= SCM_CDR (expr
);
1589 const SCM name
= SCM_CAR (cdr_expr
);
1590 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1591 const SCM bindings
= SCM_CAR (cddr_expr
);
1592 check_bindings (bindings
, expr
);
1594 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1595 variables
= scm_reverse_x (rvariables
, SCM_UNDEFINED
);
1598 const SCM let_body
= SCM_CDR (cddr_expr
);
1599 const SCM lambda_body
= m_body (SCM_IM_LET
, let_body
);
1600 const SCM lambda_tail
= scm_cons (variables
, lambda_body
);
1601 const SCM lambda_form
= scm_cons_source (expr
, scm_sym_lambda
, lambda_tail
);
1603 const SCM rvar
= scm_list_1 (name
);
1604 const SCM init
= scm_list_1 (lambda_form
);
1605 const SCM body
= m_body (SCM_IM_LET
, scm_list_1 (name
));
1606 const SCM letrec_tail
= scm_cons (rvar
, scm_cons (init
, body
));
1607 const SCM letrec_form
= scm_cons_source (expr
, SCM_IM_LETREC
, letrec_tail
);
1608 return scm_cons_source (expr
, letrec_form
, inits
);
1612 /* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1613 * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
1615 scm_m_let (SCM expr
, SCM env
)
1619 const SCM cdr_expr
= SCM_CDR (expr
);
1620 const long length
= scm_ilength (cdr_expr
);
1621 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1622 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1624 bindings
= SCM_CAR (cdr_expr
);
1625 if (scm_is_symbol (bindings
))
1627 ASSERT_SYNTAX (length
>= 3, s_missing_expression
, expr
);
1628 return memoize_named_let (expr
, env
);
1631 check_bindings (bindings
, expr
);
1632 if (scm_is_null (bindings
) || scm_is_null (SCM_CDR (bindings
)))
1634 /* Special case: no bindings or single binding => let* is faster. */
1635 const SCM body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1636 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), bindings
, body
), env
);
1643 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1646 const SCM new_body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1647 const SCM new_tail
= scm_cons2 (rvariables
, inits
, new_body
);
1648 SCM_SETCAR (expr
, SCM_IM_LET
);
1649 SCM_SETCDR (expr
, new_tail
);
1656 build_binding_list (SCM rnames
, SCM rinits
)
1658 SCM bindings
= SCM_EOL
;
1659 while (!scm_is_null (rnames
))
1661 const SCM binding
= scm_list_2 (SCM_CAR (rnames
), SCM_CAR (rinits
));
1662 bindings
= scm_cons (binding
, bindings
);
1663 rnames
= SCM_CDR (rnames
);
1664 rinits
= SCM_CDR (rinits
);
1670 unmemoize_let (const SCM expr
, const SCM env
)
1672 const SCM cdr_expr
= SCM_CDR (expr
);
1673 const SCM um_rnames
= SCM_CAR (cdr_expr
);
1674 const SCM extended_env
= SCM_EXTEND_ENV (um_rnames
, SCM_EOL
, env
);
1675 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1676 const SCM um_inits
= unmemoize_exprs (SCM_CAR (cddr_expr
), env
);
1677 const SCM um_rinits
= scm_reverse_x (um_inits
, SCM_UNDEFINED
);
1678 const SCM um_bindings
= build_binding_list (um_rnames
, um_rinits
);
1679 const SCM um_body
= unmemoize_exprs (SCM_CDR (cddr_expr
), extended_env
);
1681 return scm_cons2 (scm_sym_let
, um_bindings
, um_body
);
1685 SCM_SYNTAX(s_letrec
, "letrec", scm_i_makbimacro
, scm_m_letrec
);
1686 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
1689 scm_m_letrec (SCM expr
, SCM env
)
1693 const SCM cdr_expr
= SCM_CDR (expr
);
1694 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1695 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1697 bindings
= SCM_CAR (cdr_expr
);
1698 if (scm_is_null (bindings
))
1700 /* no bindings, let* is executed faster */
1701 SCM body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1702 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), SCM_EOL
, body
), env
);
1710 check_bindings (bindings
, expr
);
1711 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1712 new_body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1713 return scm_cons2 (SCM_IM_LETREC
, rvariables
, scm_cons (inits
, new_body
));
1718 unmemoize_letrec (const SCM expr
, const SCM env
)
1720 const SCM cdr_expr
= SCM_CDR (expr
);
1721 const SCM um_rnames
= SCM_CAR (cdr_expr
);
1722 const SCM extended_env
= SCM_EXTEND_ENV (um_rnames
, SCM_EOL
, env
);
1723 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1724 const SCM um_inits
= unmemoize_exprs (SCM_CAR (cddr_expr
), extended_env
);
1725 const SCM um_rinits
= scm_reverse_x (um_inits
, SCM_UNDEFINED
);
1726 const SCM um_bindings
= build_binding_list (um_rnames
, um_rinits
);
1727 const SCM um_body
= unmemoize_exprs (SCM_CDR (cddr_expr
), extended_env
);
1729 return scm_cons2 (scm_sym_letrec
, um_bindings
, um_body
);
1734 SCM_SYNTAX (s_letstar
, "let*", scm_i_makbimacro
, scm_m_letstar
);
1735 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
1737 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1738 * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
1740 scm_m_letstar (SCM expr
, SCM env SCM_UNUSED
)
1745 const SCM cdr_expr
= SCM_CDR (expr
);
1746 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1747 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1749 binding_idx
= SCM_CAR (cdr_expr
);
1750 check_bindings (binding_idx
, expr
);
1752 /* Transform ((v1 i1) (v2 i2) ...) into (v1 i1 v2 i2 ...). The
1753 * transformation is done in place. At the beginning of one iteration of
1754 * the loop the variable binding_idx holds the form
1755 * P1:( (vn . P2:(in . ())) . P3:( (vn+1 in+1) ... ) ),
1756 * where P1, P2 and P3 indicate the pairs, that are relevant for the
1757 * transformation. P1 and P2 are modified in the loop, P3 remains
1758 * untouched. After the execution of the loop, P1 will hold
1759 * P1:( vn . P2:(in . P3:( (vn+1 in+1) ... )) )
1760 * and binding_idx will hold P3. */
1761 while (!scm_is_null (binding_idx
))
1763 const SCM cdr_binding_idx
= SCM_CDR (binding_idx
); /* remember P3 */
1764 const SCM binding
= SCM_CAR (binding_idx
);
1765 const SCM name
= SCM_CAR (binding
);
1766 const SCM cdr_binding
= SCM_CDR (binding
);
1768 SCM_SETCDR (cdr_binding
, cdr_binding_idx
); /* update P2 */
1769 SCM_SETCAR (binding_idx
, name
); /* update P1 */
1770 SCM_SETCDR (binding_idx
, cdr_binding
); /* update P1 */
1772 binding_idx
= cdr_binding_idx
; /* continue with P3 */
1775 new_body
= m_body (SCM_IM_LETSTAR
, SCM_CDR (cdr_expr
));
1776 SCM_SETCAR (expr
, SCM_IM_LETSTAR
);
1777 /* the bindings have been changed in place */
1778 SCM_SETCDR (cdr_expr
, new_body
);
1783 unmemoize_letstar (const SCM expr
, const SCM env
)
1785 const SCM cdr_expr
= SCM_CDR (expr
);
1786 const SCM body
= SCM_CDR (cdr_expr
);
1787 SCM bindings
= SCM_CAR (cdr_expr
);
1788 SCM um_bindings
= SCM_EOL
;
1789 SCM extended_env
= env
;
1792 while (!scm_is_null (bindings
))
1794 const SCM variable
= SCM_CAR (bindings
);
1795 const SCM init
= SCM_CADR (bindings
);
1796 const SCM um_init
= unmemoize_expression (init
, extended_env
);
1797 um_bindings
= scm_cons (scm_list_2 (variable
, um_init
), um_bindings
);
1798 extended_env
= SCM_EXTEND_ENV (variable
, SCM_BOOL_F
, extended_env
);
1799 bindings
= SCM_CDDR (bindings
);
1801 um_bindings
= scm_reverse_x (um_bindings
, SCM_UNDEFINED
);
1803 um_body
= unmemoize_exprs (body
, extended_env
);
1805 return scm_cons2 (scm_sym_letstar
, um_bindings
, um_body
);
1809 SCM_SYNTAX (s_or
, "or", scm_i_makbimacro
, scm_m_or
);
1810 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
1813 scm_m_or (SCM expr
, SCM env SCM_UNUSED
)
1815 const SCM cdr_expr
= SCM_CDR (expr
);
1816 const long length
= scm_ilength (cdr_expr
);
1818 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1822 /* Special case: (or) is replaced by #f. */
1827 SCM_SETCAR (expr
, SCM_IM_OR
);
1833 unmemoize_or (const SCM expr
, const SCM env
)
1835 return scm_cons (scm_sym_or
, unmemoize_exprs (SCM_CDR (expr
), env
));
1839 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
1840 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
1841 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
1842 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
1844 /* Internal function to handle a quasiquotation: 'form' is the parameter in
1845 * the call (quasiquotation form), 'env' is the environment where unquoted
1846 * expressions will be evaluated, and 'depth' is the current quasiquotation
1847 * nesting level and is known to be greater than zero. */
1849 iqq (SCM form
, SCM env
, unsigned long int depth
)
1851 if (scm_is_pair (form
))
1853 const SCM tmp
= SCM_CAR (form
);
1854 if (scm_is_eq (tmp
, scm_sym_quasiquote
))
1856 const SCM args
= SCM_CDR (form
);
1857 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1858 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
1860 else if (scm_is_eq (tmp
, scm_sym_unquote
))
1862 const SCM args
= SCM_CDR (form
);
1863 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1865 return scm_eval_car (args
, env
);
1867 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
1869 else if (scm_is_pair (tmp
)
1870 && scm_is_eq (SCM_CAR (tmp
), scm_sym_uq_splicing
))
1872 const SCM args
= SCM_CDR (tmp
);
1873 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1876 const SCM list
= scm_eval_car (args
, env
);
1877 const SCM rest
= SCM_CDR (form
);
1878 ASSERT_SYNTAX_2 (scm_ilength (list
) >= 0,
1879 s_splicing
, list
, form
);
1880 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
1883 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
1884 iqq (SCM_CDR (form
), env
, depth
));
1887 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
1888 iqq (SCM_CDR (form
), env
, depth
));
1890 else if (scm_is_vector (form
))
1891 return scm_vector (iqq (scm_vector_to_list (form
), env
, depth
));
1897 scm_m_quasiquote (SCM expr
, SCM env
)
1899 const SCM cdr_expr
= SCM_CDR (expr
);
1900 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1901 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1902 return iqq (SCM_CAR (cdr_expr
), env
, 1);
1906 SCM_SYNTAX (s_quote
, "quote", scm_i_makbimacro
, scm_m_quote
);
1907 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
1910 scm_m_quote (SCM expr
, SCM env SCM_UNUSED
)
1914 const SCM cdr_expr
= SCM_CDR (expr
);
1915 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1916 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1917 quotee
= SCM_CAR (cdr_expr
);
1918 if (is_self_quoting_p (quotee
))
1921 SCM_SETCAR (expr
, SCM_IM_QUOTE
);
1922 SCM_SETCDR (expr
, quotee
);
1927 unmemoize_quote (const SCM expr
, const SCM env SCM_UNUSED
)
1929 return scm_list_2 (scm_sym_quote
, SCM_CDR (expr
));
1933 /* Will go into the RnRS module when Guile is factorized.
1934 SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
1935 static const char s_set_x
[] = "set!";
1936 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, s_set_x
);
1939 scm_m_set_x (SCM expr
, SCM env SCM_UNUSED
)
1944 const SCM cdr_expr
= SCM_CDR (expr
);
1945 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1946 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1947 variable
= SCM_CAR (cdr_expr
);
1949 /* Memoize the variable form. */
1950 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
1951 new_variable
= lookup_symbol (variable
, env
);
1952 /* Leave the memoization of unbound symbols to lazy memoization: */
1953 if (SCM_UNBNDP (new_variable
))
1954 new_variable
= variable
;
1956 SCM_SETCAR (expr
, SCM_IM_SET_X
);
1957 SCM_SETCAR (cdr_expr
, new_variable
);
1962 unmemoize_set_x (const SCM expr
, const SCM env
)
1964 return scm_cons (scm_sym_set_x
, unmemoize_exprs (SCM_CDR (expr
), env
));
1968 /* Start of the memoizers for non-R5RS builtin macros. */
1971 SCM_SYNTAX (s_atapply
, "@apply", scm_i_makbimacro
, scm_m_apply
);
1972 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1973 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1976 scm_m_apply (SCM expr
, SCM env SCM_UNUSED
)
1978 const SCM cdr_expr
= SCM_CDR (expr
);
1979 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1980 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_missing_expression
, expr
);
1982 SCM_SETCAR (expr
, SCM_IM_APPLY
);
1987 unmemoize_apply (const SCM expr
, const SCM env
)
1989 return scm_list_2 (scm_sym_atapply
, unmemoize_exprs (SCM_CDR (expr
), env
));
1993 SCM_SYNTAX (s_atbind
, "@bind", scm_i_makbimacro
, scm_m_atbind
);
1995 /* FIXME: The following explanation should go into the documentation: */
1996 /* (@bind ((var init) ...) body ...) will assign the values of the `init's to
1997 * the global variables named by `var's (symbols, not evaluated), creating
1998 * them if they don't exist, executes body, and then restores the previous
1999 * values of the `var's. Additionally, whenever control leaves body, the
2000 * values of the `var's are saved and restored when control returns. It is an
2001 * error when a symbol appears more than once among the `var's. All `init's
2002 * are evaluated before any `var' is set.
2004 * Think of this as `let' for dynamic scope.
2007 /* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into
2008 * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...).
2010 * FIXME - also implement `@bind*'.
2013 scm_m_atbind (SCM expr
, SCM env
)
2020 const SCM top_level
= scm_env_top_level (env
);
2022 const SCM cdr_expr
= SCM_CDR (expr
);
2023 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2024 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
2025 bindings
= SCM_CAR (cdr_expr
);
2026 check_bindings (bindings
, expr
);
2027 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
2029 for (variable_idx
= rvariables
;
2030 !scm_is_null (variable_idx
);
2031 variable_idx
= SCM_CDR (variable_idx
))
2033 /* The first call to scm_sym2var will look beyond the current module,
2034 * while the second call wont. */
2035 const SCM variable
= SCM_CAR (variable_idx
);
2036 SCM new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_F
);
2037 if (scm_is_false (new_variable
))
2038 new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_T
);
2039 SCM_SETCAR (variable_idx
, new_variable
);
2042 SCM_SETCAR (expr
, SCM_IM_BIND
);
2043 SCM_SETCAR (cdr_expr
, scm_cons (rvariables
, inits
));
2048 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_i_makbimacro
, scm_m_cont
);
2049 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, s_atcall_cc
);
2052 scm_m_cont (SCM expr
, SCM env SCM_UNUSED
)
2054 const SCM cdr_expr
= SCM_CDR (expr
);
2055 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2056 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2058 SCM_SETCAR (expr
, SCM_IM_CONT
);
2063 unmemoize_atcall_cc (const SCM expr
, const SCM env
)
2065 return scm_list_2 (scm_sym_atcall_cc
, unmemoize_exprs (SCM_CDR (expr
), env
));
2069 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_i_makbimacro
, scm_m_at_call_with_values
);
2070 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
2073 scm_m_at_call_with_values (SCM expr
, SCM env SCM_UNUSED
)
2075 const SCM cdr_expr
= SCM_CDR (expr
);
2076 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2077 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2079 SCM_SETCAR (expr
, SCM_IM_CALL_WITH_VALUES
);
2084 unmemoize_at_call_with_values (const SCM expr
, const SCM env
)
2086 return scm_list_2 (scm_sym_at_call_with_values
,
2087 unmemoize_exprs (SCM_CDR (expr
), env
));
2092 /* See futures.h for a comment why futures are not enabled.
2095 SCM_SYNTAX (s_future
, "future", scm_i_makbimacro
, scm_m_future
);
2096 SCM_GLOBAL_SYMBOL (scm_sym_future
, s_future
);
2098 /* Like promises, futures are implemented as closures with an empty
2099 * parameter list. Thus, (future <expression>) is transformed into
2100 * (#@future '() <expression>), where the empty list represents the
2101 * empty parameter list. This representation allows for easy creation
2102 * of the closure during evaluation. */
2104 scm_m_future (SCM expr
, SCM env
)
2106 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
2107 SCM_SETCAR (new_expr
, SCM_IM_FUTURE
);
2112 unmemoize_future (const SCM expr
, const SCM env
)
2114 const SCM thunk_expr
= SCM_CADDR (expr
);
2115 return scm_list_2 (scm_sym_future
, unmemoize_expression (thunk_expr
, env
));
2120 SCM_SYNTAX (s_gset_x
, "set!", scm_i_makbimacro
, scm_m_generalized_set_x
);
2121 SCM_SYMBOL (scm_sym_setter
, "setter");
2124 scm_m_generalized_set_x (SCM expr
, SCM env
)
2126 SCM target
, exp_target
;
2128 const SCM cdr_expr
= SCM_CDR (expr
);
2129 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2130 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2132 target
= SCM_CAR (cdr_expr
);
2133 if (!scm_is_pair (target
))
2136 return scm_m_set_x (expr
, env
);
2140 /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */
2141 /* Macroexpanding the target might return things of the form
2142 (begin <atom>). In that case, <atom> must be a symbol or a
2143 variable and we memoize to (set! <atom> ...).
2145 exp_target
= macroexp (target
, env
);
2146 if (scm_is_eq (SCM_CAR (exp_target
), SCM_IM_BEGIN
)
2147 && !scm_is_null (SCM_CDR (exp_target
))
2148 && scm_is_null (SCM_CDDR (exp_target
)))
2150 exp_target
= SCM_CADR (exp_target
);
2151 ASSERT_SYNTAX_2 (scm_is_symbol (exp_target
)
2152 || SCM_VARIABLEP (exp_target
),
2153 s_bad_variable
, exp_target
, expr
);
2154 return scm_cons (SCM_IM_SET_X
, scm_cons (exp_target
,
2155 SCM_CDR (cdr_expr
)));
2159 const SCM setter_proc_tail
= scm_list_1 (SCM_CAR (target
));
2160 const SCM setter_proc
= scm_cons_source (expr
, scm_sym_setter
,
2163 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
2164 const SCM setter_args
= scm_append_x (scm_list_2 (SCM_CDR (target
),
2167 SCM_SETCAR (expr
, setter_proc
);
2168 SCM_SETCDR (expr
, setter_args
);
2175 /* @slot-ref is bound privately in the (oop goops) module from goops.c. As
2176 * soon as the module system allows us to more freely create bindings in
2177 * arbitrary modules during the startup phase, the code from goops.c should be
2180 SCM_SYMBOL (sym_atslot_ref
, "@slot-ref");
2183 scm_m_atslot_ref (SCM expr
, SCM env SCM_UNUSED
)
2187 const SCM cdr_expr
= SCM_CDR (expr
);
2188 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2189 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2190 slot_nr
= SCM_CADR (cdr_expr
);
2191 ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2193 SCM_SETCAR (expr
, SCM_IM_SLOT_REF
);
2194 SCM_SETCDR (cdr_expr
, slot_nr
);
2199 unmemoize_atslot_ref (const SCM expr
, const SCM env
)
2201 const SCM instance
= SCM_CADR (expr
);
2202 const SCM um_instance
= unmemoize_expression (instance
, env
);
2203 const SCM slot_nr
= SCM_CDDR (expr
);
2204 return scm_list_3 (sym_atslot_ref
, um_instance
, slot_nr
);
2208 /* @slot-set! is bound privately in the (oop goops) module from goops.c. As
2209 * soon as the module system allows us to more freely create bindings in
2210 * arbitrary modules during the startup phase, the code from goops.c should be
2213 SCM_SYMBOL (sym_atslot_set_x
, "@slot-set!");
2216 scm_m_atslot_set_x (SCM expr
, SCM env SCM_UNUSED
)
2220 const SCM cdr_expr
= SCM_CDR (expr
);
2221 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2222 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 3, s_expression
, expr
);
2223 slot_nr
= SCM_CADR (cdr_expr
);
2224 ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2226 SCM_SETCAR (expr
, SCM_IM_SLOT_SET_X
);
2231 unmemoize_atslot_set_x (const SCM expr
, const SCM env
)
2233 const SCM cdr_expr
= SCM_CDR (expr
);
2234 const SCM instance
= SCM_CAR (cdr_expr
);
2235 const SCM um_instance
= unmemoize_expression (instance
, env
);
2236 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
2237 const SCM slot_nr
= SCM_CAR (cddr_expr
);
2238 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
2239 const SCM value
= SCM_CAR (cdddr_expr
);
2240 const SCM um_value
= unmemoize_expression (value
, env
);
2241 return scm_list_4 (sym_atslot_set_x
, um_instance
, slot_nr
, um_value
);
2245 #if SCM_ENABLE_ELISP
2247 static const char s_defun
[] = "Symbol's function definition is void";
2249 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_i_makbimacro
, scm_m_nil_cond
);
2251 /* nil-cond expressions have the form
2252 * (nil-cond COND VAL COND VAL ... ELSEVAL) */
2254 scm_m_nil_cond (SCM expr
, SCM env SCM_UNUSED
)
2256 const long length
= scm_ilength (SCM_CDR (expr
));
2257 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
2258 ASSERT_SYNTAX (length
>= 1 && (length
% 2) == 1, s_expression
, expr
);
2260 SCM_SETCAR (expr
, SCM_IM_NIL_COND
);
2265 SCM_SYNTAX (s_atfop
, "@fop", scm_i_makbimacro
, scm_m_atfop
);
2267 /* The @fop-macro handles procedure and macro applications for elisp. The
2268 * input expression must have the form
2269 * (@fop <var> (transformer-macro <expr> ...))
2270 * where <var> must be a symbol. The expression is transformed into the
2271 * memoized form of either
2272 * (apply <un-aliased var> (transformer-macro <expr> ...))
2273 * if the value of var (across all aliasing) is not a macro, or
2274 * (<un-aliased var> <expr> ...)
2275 * if var is a macro. */
2277 scm_m_atfop (SCM expr
, SCM env SCM_UNUSED
)
2282 const SCM cdr_expr
= SCM_CDR (expr
);
2283 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2284 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 1, s_missing_expression
, expr
);
2286 symbol
= SCM_CAR (cdr_expr
);
2287 ASSERT_SYNTAX_2 (scm_is_symbol (symbol
), s_bad_variable
, symbol
, expr
);
2289 location
= scm_symbol_fref (symbol
);
2290 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2292 /* The elisp function `defalias' allows to define aliases for symbols. To
2293 * look up such definitions, the chain of symbol definitions has to be
2294 * followed up to the terminal symbol. */
2295 while (scm_is_symbol (SCM_VARIABLE_REF (location
)))
2297 const SCM alias
= SCM_VARIABLE_REF (location
);
2298 location
= scm_symbol_fref (alias
);
2299 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2302 /* Memoize the value location belonging to the terminal symbol. */
2303 SCM_SETCAR (cdr_expr
, location
);
2305 if (!SCM_MACROP (SCM_VARIABLE_REF (location
)))
2307 /* Since the location does not contain a macro, the form is a procedure
2308 * application. Replace `@fop' by `@apply' and transform the expression
2309 * including the `transformer-macro'. */
2310 SCM_SETCAR (expr
, SCM_IM_APPLY
);
2315 /* Since the location contains a macro, the arguments should not be
2316 * transformed, so the `transformer-macro' is cut out. The resulting
2317 * expression starts with the memoized variable, that is at the cdr of
2318 * the input expression. */
2319 SCM_SETCDR (cdr_expr
, SCM_CDADR (cdr_expr
));
2324 #endif /* SCM_ENABLE_ELISP */
2328 unmemoize_builtin_macro (const SCM expr
, const SCM env
)
2330 switch (ISYMNUM (SCM_CAR (expr
)))
2332 case (ISYMNUM (SCM_IM_AND
)):
2333 return unmemoize_and (expr
, env
);
2335 case (ISYMNUM (SCM_IM_BEGIN
)):
2336 return unmemoize_begin (expr
, env
);
2338 case (ISYMNUM (SCM_IM_CASE
)):
2339 return unmemoize_case (expr
, env
);
2341 case (ISYMNUM (SCM_IM_COND
)):
2342 return unmemoize_cond (expr
, env
);
2344 case (ISYMNUM (SCM_IM_DELAY
)):
2345 return unmemoize_delay (expr
, env
);
2347 case (ISYMNUM (SCM_IM_DO
)):
2348 return unmemoize_do (expr
, env
);
2350 case (ISYMNUM (SCM_IM_IF
)):
2351 return unmemoize_if (expr
, env
);
2353 case (ISYMNUM (SCM_IM_LAMBDA
)):
2354 return unmemoize_lambda (expr
, env
);
2356 case (ISYMNUM (SCM_IM_LET
)):
2357 return unmemoize_let (expr
, env
);
2359 case (ISYMNUM (SCM_IM_LETREC
)):
2360 return unmemoize_letrec (expr
, env
);
2362 case (ISYMNUM (SCM_IM_LETSTAR
)):
2363 return unmemoize_letstar (expr
, env
);
2365 case (ISYMNUM (SCM_IM_OR
)):
2366 return unmemoize_or (expr
, env
);
2368 case (ISYMNUM (SCM_IM_QUOTE
)):
2369 return unmemoize_quote (expr
, env
);
2371 case (ISYMNUM (SCM_IM_SET_X
)):
2372 return unmemoize_set_x (expr
, env
);
2374 case (ISYMNUM (SCM_IM_APPLY
)):
2375 return unmemoize_apply (expr
, env
);
2377 case (ISYMNUM (SCM_IM_BIND
)):
2378 return unmemoize_exprs (expr
, env
); /* FIXME */
2380 case (ISYMNUM (SCM_IM_CONT
)):
2381 return unmemoize_atcall_cc (expr
, env
);
2383 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2384 return unmemoize_at_call_with_values (expr
, env
);
2387 /* See futures.h for a comment why futures are not enabled.
2389 case (ISYMNUM (SCM_IM_FUTURE
)):
2390 return unmemoize_future (expr
, env
);
2393 case (ISYMNUM (SCM_IM_SLOT_REF
)):
2394 return unmemoize_atslot_ref (expr
, env
);
2396 case (ISYMNUM (SCM_IM_SLOT_SET_X
)):
2397 return unmemoize_atslot_set_x (expr
, env
);
2399 case (ISYMNUM (SCM_IM_NIL_COND
)):
2400 return unmemoize_exprs (expr
, env
); /* FIXME */
2403 return unmemoize_exprs (expr
, env
); /* FIXME */
2408 /* scm_i_unmemocopy_expr and scm_i_unmemocopy_body take a memoized expression
2409 * respectively a memoized body together with its environment and rewrite it
2410 * to its original form. Thus, these functions are the inversion of the
2411 * rewrite rules above. The procedure is not optimized for speed. It's used
2412 * in scm_i_unmemoize_expr, scm_procedure_source, macro_print and scm_iprin1.
2414 * Unmemoizing is not a reliable process. You cannot in general expect to get
2415 * the original source back.
2417 * However, GOOPS currently relies on this for method compilation. This ought
2421 scm_i_unmemocopy_expr (SCM expr
, SCM env
)
2423 const SCM source_properties
= scm_whash_lookup (scm_source_whash
, expr
);
2424 const SCM um_expr
= unmemoize_expression (expr
, env
);
2426 if (scm_is_true (source_properties
))
2427 scm_whash_insert (scm_source_whash
, um_expr
, source_properties
);
2433 scm_i_unmemocopy_body (SCM forms
, SCM env
)
2435 const SCM source_properties
= scm_whash_lookup (scm_source_whash
, forms
);
2436 const SCM um_forms
= unmemoize_exprs (forms
, env
);
2438 if (scm_is_true (source_properties
))
2439 scm_whash_insert (scm_source_whash
, um_forms
, source_properties
);
2445 #if (SCM_ENABLE_DEPRECATED == 1)
2447 /* Deprecated in guile 1.7.0 on 2003-11-09. */
2449 scm_m_expand_body (SCM exprs
, SCM env
)
2451 scm_c_issue_deprecation_warning
2452 ("`scm_m_expand_body' is deprecated.");
2453 m_expand_body (exprs
, env
);
2458 SCM_SYNTAX (s_undefine
, "undefine", scm_makacro
, scm_m_undefine
);
2461 scm_m_undefine (SCM expr
, SCM env
)
2466 const SCM cdr_expr
= SCM_CDR (expr
);
2467 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), "Bad undefine placement in", expr
);
2468 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2469 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2471 scm_c_issue_deprecation_warning
2472 ("`undefine' is deprecated.\n");
2474 variable
= SCM_CAR (cdr_expr
);
2475 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
2476 location
= scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_F
);
2477 ASSERT_SYNTAX_2 (scm_is_true (location
)
2478 && !SCM_UNBNDP (SCM_VARIABLE_REF (location
)),
2479 "variable already unbound ", variable
, expr
);
2480 SCM_VARIABLE_SET (location
, SCM_UNDEFINED
);
2481 return SCM_UNSPECIFIED
;
2485 scm_macroexp (SCM x
, SCM env
)
2487 scm_c_issue_deprecation_warning
2488 ("`scm_macroexp' is deprecated.");
2489 return macroexp (x
, env
);
2495 #if (SCM_ENABLE_DEPRECATED == 1)
2498 scm_unmemocar (SCM form
, SCM env
)
2500 scm_c_issue_deprecation_warning
2501 ("`scm_unmemocar' is deprecated.");
2503 if (!scm_is_pair (form
))
2507 SCM c
= SCM_CAR (form
);
2508 if (SCM_VARIABLEP (c
))
2510 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
2511 if (scm_is_false (sym
))
2512 sym
= sym_three_question_marks
;
2513 SCM_SETCAR (form
, sym
);
2515 else if (SCM_ILOCP (c
))
2517 unsigned long int ir
;
2519 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
2520 env
= SCM_CDR (env
);
2521 env
= SCM_CAAR (env
);
2522 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
2523 env
= SCM_CDR (env
);
2525 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
2533 /*****************************************************************************/
2534 /*****************************************************************************/
2535 /* The definitions for execution start here. */
2536 /*****************************************************************************/
2537 /*****************************************************************************/
2539 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
2540 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
2541 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
2542 SCM_GLOBAL_SYMBOL (scm_sym_memoize_symbol
, "memoize-symbol");
2543 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
2544 SCM_SYMBOL (sym_instead
, "instead");
2546 /* A function object to implement "apply" for non-closure functions. */
2548 /* An endless list consisting of #<undefined> objects: */
2549 static SCM undefineds
;
2553 scm_badargsp (SCM formals
, SCM args
)
2555 while (!scm_is_null (formals
))
2557 if (!scm_is_pair (formals
))
2559 if (scm_is_null (args
))
2561 formals
= SCM_CDR (formals
);
2562 args
= SCM_CDR (args
);
2564 return !scm_is_null (args
) ? 1 : 0;
2569 /* The evaluator contains a plethora of EVAL symbols.
2572 * SCM_I_EVALIM is used when it is known that the expression is an
2573 * immediate. (This macro never calls an evaluator.)
2575 * SCM_I_XEVAL evaluates an expression that is expected to have its symbols already
2576 * memoized. Expressions that are not of the form '(<form> <form> ...)' are
2577 * evaluated inline without calling an evaluator.
2579 * This macro uses ceval or deval depending on its 3rd argument.
2581 * SCM_I_XEVALCAR evaluates the car of an expression 'X:(Y:<form> <form> ...)',
2582 * potentially replacing a symbol at the position Y:<form> by its memoized
2583 * variable. If Y:<form> is not of the form '(<form> <form> ...)', the
2584 * evaluation is performed inline without calling an evaluator.
2586 * This macro uses ceval or deval depending on its 3rd argument.
2590 #define SCM_I_EVALIM2(x) \
2591 ((scm_is_eq ((x), SCM_EOL) \
2592 ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \
2596 #define SCM_I_EVALIM(x, env) (SCM_ILOCP (x) \
2597 ? *scm_ilookup ((x), (env)) \
2600 #define SCM_I_XEVAL(x, env, debug_p) \
2602 ? SCM_I_EVALIM2 (x) \
2603 : (SCM_VARIABLEP (x) \
2604 ? SCM_VARIABLE_REF (x) \
2605 : (scm_is_pair (x) \
2607 ? deval ((x), (env)) \
2608 : ceval ((x), (env))) \
2611 #define SCM_I_XEVALCAR(x, env, debug_p) \
2612 (SCM_IMP (SCM_CAR (x)) \
2613 ? SCM_I_EVALIM (SCM_CAR (x), (env)) \
2614 : (SCM_VARIABLEP (SCM_CAR (x)) \
2615 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2616 : (scm_is_pair (SCM_CAR (x)) \
2618 ? deval (SCM_CAR (x), (env)) \
2619 : ceval (SCM_CAR (x), (env))) \
2620 : (!scm_is_symbol (SCM_CAR (x)) \
2622 : *scm_lookupcar ((x), (env), 1)))))
2624 scm_i_pthread_mutex_t source_mutex
;
2627 /* Lookup a given local variable in an environment. The local variable is
2628 * given as an iloc, that is a triple <frame, binding, last?>, where frame
2629 * indicates the relative number of the environment frame (counting upwards
2630 * from the innermost environment frame), binding indicates the number of the
2631 * binding within the frame, and last? (which is extracted from the iloc using
2632 * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
2633 * very end of the improper list of bindings. */
2635 scm_ilookup (SCM iloc
, SCM env
)
2637 unsigned int frame_nr
= SCM_IFRAME (iloc
);
2638 unsigned int binding_nr
= SCM_IDIST (iloc
);
2642 for (; 0 != frame_nr
; --frame_nr
)
2643 frames
= SCM_CDR (frames
);
2645 bindings
= SCM_CAR (frames
);
2646 for (; 0 != binding_nr
; --binding_nr
)
2647 bindings
= SCM_CDR (bindings
);
2649 if (SCM_ICDRP (iloc
))
2650 return SCM_CDRLOC (bindings
);
2651 return SCM_CARLOC (SCM_CDR (bindings
));
2655 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
2657 static void error_unbound_variable (SCM symbol
) SCM_NORETURN
;
2658 static void error_defined_variable (SCM symbol
) SCM_NORETURN
;
2660 /* Call this for variables that are unfound.
2663 error_unbound_variable (SCM symbol
)
2665 scm_error (scm_unbound_variable_key
, NULL
,
2666 "Unbound variable: ~S",
2667 scm_list_1 (symbol
), SCM_BOOL_F
);
2670 /* Call this for variables that are found but contain SCM_UNDEFINED.
2673 error_defined_variable (SCM symbol
)
2675 /* We use the 'unbound-variable' key here as well, since it
2676 basically is the same kind of error, with a slight variation in
2677 the displayed message.
2679 scm_error (scm_unbound_variable_key
, NULL
,
2680 "Variable used before given a value: ~S",
2681 scm_list_1 (symbol
), SCM_BOOL_F
);
2685 /* The Lookup Car Race
2688 Memoization of variables and special forms is done while executing
2689 the code for the first time. As long as there is only one thread
2690 everything is fine, but as soon as two threads execute the same
2691 code concurrently `for the first time' they can come into conflict.
2693 This memoization includes rewriting variable references into more
2694 efficient forms and expanding macros. Furthermore, macro expansion
2695 includes `compiling' special forms like `let', `cond', etc. into
2696 tree-code instructions.
2698 There shouldn't normally be a problem with memoizing local and
2699 global variable references (into ilocs and variables), because all
2700 threads will mutate the code in *exactly* the same way and (if I
2701 read the C code correctly) it is not possible to observe a half-way
2702 mutated cons cell. The lookup procedure can handle this
2703 transparently without any critical sections.
2705 It is different with macro expansion, because macro expansion
2706 happens outside of the lookup procedure and can't be
2707 undone. Therefore the lookup procedure can't cope with it. It has
2708 to indicate failure when it detects a lost race and hope that the
2709 caller can handle it. Luckily, it turns out that this is the case.
2711 An example to illustrate this: Suppose that the following form will
2712 be memoized concurrently by two threads
2716 Let's first examine the lookup of X in the body. The first thread
2717 decides that it has to find the symbol "x" in the environment and
2718 starts to scan it. Then the other thread takes over and actually
2719 overtakes the first. It looks up "x" and substitutes an
2720 appropriate iloc for it. Now the first thread continues and
2721 completes its lookup. It comes to exactly the same conclusions as
2722 the second one and could - without much ado - just overwrite the
2723 iloc with the same iloc.
2725 But let's see what will happen when the race occurs while looking
2726 up the symbol "let" at the start of the form. It could happen that
2727 the second thread interrupts the lookup of the first thread and not
2728 only substitutes a variable for it but goes right ahead and
2729 replaces it with the compiled form (#@let* (x 12) x). Now, when
2730 the first thread completes its lookup, it would replace the #@let*
2731 with a variable containing the "let" binding, effectively reverting
2732 the form to (let (x 12) x). This is wrong. It has to detect that
2733 it has lost the race and the evaluator has to reconsider the
2734 changed form completely.
2736 This race condition could be resolved with some kind of traffic
2737 light (like mutexes) around scm_lookupcar, but I think that it is
2738 best to avoid them in this case. They would serialize memoization
2739 completely and because lookup involves calling arbitrary Scheme
2740 code (via the lookup-thunk), threads could be blocked for an
2741 arbitrary amount of time or even deadlock. But with the current
2742 solution a lot of unnecessary work is potentially done. */
2744 /* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
2745 return NULL to indicate a failed lookup due to some race conditions
2746 between threads. This only happens when VLOC is the first cell of
2747 a special form that will eventually be memoized (like `let', etc.)
2748 In that case the whole lookup is bogus and the caller has to
2749 reconsider the complete special form.
2751 SCM_LOOKUPCAR is still there, of course. It just calls
2752 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
2753 should only be called when it is known that VLOC is not the first
2754 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
2755 for NULL. I think I've found the only places where this
2759 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
2762 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
2763 register SCM iloc
= SCM_ILOC00
;
2764 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
2766 if (!scm_is_pair (SCM_CAR (env
)))
2768 al
= SCM_CARLOC (env
);
2769 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
2771 if (!scm_is_pair (fl
))
2773 if (scm_is_eq (fl
, var
))
2775 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2777 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
2778 return SCM_CDRLOC (*al
);
2783 al
= SCM_CDRLOC (*al
);
2784 if (scm_is_eq (SCM_CAR (fl
), var
))
2786 if (SCM_UNBNDP (SCM_CAR (*al
)))
2787 error_defined_variable (var
);
2788 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2790 SCM_SETCAR (vloc
, iloc
);
2791 return SCM_CARLOC (*al
);
2793 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
2795 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
2798 SCM top_thunk
, real_var
;
2801 top_thunk
= SCM_CAR (env
); /* env now refers to a
2802 top level env thunk */
2803 env
= SCM_CDR (env
);
2806 top_thunk
= SCM_BOOL_F
;
2807 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
2808 if (scm_is_false (real_var
))
2811 if (!scm_is_null (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
2816 if (scm_is_null (env
))
2817 error_unbound_variable (var
);
2819 scm_misc_error (NULL
, "Damaged environment: ~S",
2824 /* A variable could not be found, but we shall
2825 not throw an error. */
2826 static SCM undef_object
= SCM_UNDEFINED
;
2827 return &undef_object
;
2831 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2833 /* Some other thread has changed the very cell we are working
2834 on. In effect, it must have done our job or messed it up
2837 var
= SCM_CAR (vloc
);
2838 if (SCM_VARIABLEP (var
))
2839 return SCM_VARIABLE_LOC (var
);
2840 if (SCM_ILOCP (var
))
2841 return scm_ilookup (var
, genv
);
2842 /* We can't cope with anything else than variables and ilocs. When
2843 a special form has been memoized (i.e. `let' into `#@let') we
2844 return NULL and expect the calling function to do the right
2845 thing. For the evaluator, this means going back and redoing
2846 the dispatch on the car of the form. */
2850 SCM_SETCAR (vloc
, real_var
);
2851 return SCM_VARIABLE_LOC (real_var
);
2856 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
2858 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
2865 /* During execution, look up a symbol in the top level of the given local
2866 * environment and return the corresponding variable object. If no binding
2867 * for the symbol can be found, an 'Unbound variable' error is signalled. */
2869 lazy_memoize_variable (const SCM symbol
, const SCM environment
)
2871 const SCM top_level
= scm_env_top_level (environment
);
2872 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
2874 if (scm_is_false (variable
))
2875 error_unbound_variable (symbol
);
2882 scm_eval_car (SCM pair
, SCM env
)
2884 return SCM_I_XEVALCAR (pair
, env
, scm_debug_mode_p
);
2889 scm_eval_body (SCM code
, SCM env
)
2894 next
= SCM_CDR (code
);
2895 while (!scm_is_null (next
))
2897 if (SCM_IMP (SCM_CAR (code
)))
2899 if (SCM_ISYMP (SCM_CAR (code
)))
2901 scm_dynwind_begin (0);
2902 scm_i_dynwind_pthread_mutex_lock (&source_mutex
);
2903 /* check for race condition */
2904 if (SCM_ISYMP (SCM_CAR (code
)))
2905 m_expand_body (code
, env
);
2911 SCM_I_XEVAL (SCM_CAR (code
), env
, scm_debug_mode_p
);
2913 next
= SCM_CDR (code
);
2915 return SCM_I_XEVALCAR (code
, env
, scm_debug_mode_p
);
2919 /* scm_last_debug_frame contains a pointer to the last debugging information
2920 * stack frame. It is accessed very often from the debugging evaluator, so it
2921 * should probably not be indirectly addressed. Better to save and restore it
2922 * from the current root at any stack swaps.
2925 /* scm_debug_eframe_size is the number of slots available for pseudo
2926 * stack frames at each real stack frame.
2929 long scm_debug_eframe_size
;
2931 int scm_debug_mode_p
;
2932 int scm_check_entry_p
;
2933 int scm_check_apply_p
;
2934 int scm_check_exit_p
;
2935 int scm_check_memoize_p
;
2937 long scm_eval_stack
;
2939 scm_t_option scm_eval_opts
[] = {
2940 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." },
2944 scm_t_option scm_debug_opts
[] = {
2945 { SCM_OPTION_BOOLEAN
, "cheap", 1,
2946 "*This option is now obsolete. Setting it has no effect." },
2947 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
2948 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
2949 { SCM_OPTION_BOOLEAN
, "procnames", 1,
2950 "Record procedure names at definition." },
2951 { SCM_OPTION_BOOLEAN
, "backwards", 0,
2952 "Display backtrace in anti-chronological order." },
2953 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
2954 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
2955 { SCM_OPTION_INTEGER
, "frames", 3,
2956 "Maximum number of tail-recursive frames in backtrace." },
2957 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
2958 "Maximal number of stored backtrace frames." },
2959 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
2960 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
2961 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
2963 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
2964 { SCM_OPTION_SCM
, "show-file-name", (unsigned long)SCM_BOOL_T
,
2965 "Show file names and line numbers "
2966 "in backtraces when not `#f'. A value of `base' "
2967 "displays only base names, while `#t' displays full names."},
2968 { SCM_OPTION_BOOLEAN
, "warn-deprecated", 0,
2969 "Warn when deprecated features are used." },
2975 * this ordering is awkward and illogical, but we maintain it for
2976 * compatibility. --hwn
2978 scm_t_option scm_evaluator_trap_table
[] = {
2979 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
2980 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
2981 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
2982 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
2983 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
2984 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
2985 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." },
2986 { SCM_OPTION_BOOLEAN
, "memoize-symbol", 0, "Trap when memoizing a symbol." },
2987 { SCM_OPTION_SCM
, "memoize-symbol-handler", (unsigned long)SCM_BOOL_F
, "The handler for memoization." },
2992 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
2994 "Option interface for the evaluation options. Instead of using\n"
2995 "this procedure directly, use the procedures @code{eval-enable},\n"
2996 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
2997 #define FUNC_NAME s_scm_eval_options_interface
3001 scm_dynwind_begin (0);
3002 scm_dynwind_critical_section (SCM_BOOL_F
);
3003 ans
= scm_options (setting
,
3006 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
3014 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
3016 "Option interface for the evaluator trap options.")
3017 #define FUNC_NAME s_scm_evaluator_traps
3022 scm_options_try (setting
,
3023 scm_evaluator_trap_table
,
3025 SCM_CRITICAL_SECTION_START
;
3026 ans
= scm_options (setting
,
3027 scm_evaluator_trap_table
,
3030 /* njrev: same again. */
3031 SCM_RESET_DEBUG_MODE
;
3032 SCM_CRITICAL_SECTION_END
;
3041 /* Simple procedure calls
3045 scm_call_0 (SCM proc
)
3047 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
3051 scm_call_1 (SCM proc
, SCM arg1
)
3053 return scm_apply (proc
, arg1
, scm_listofnull
);
3057 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
3059 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
3063 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
3065 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
3069 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
3071 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
3072 scm_cons (arg4
, scm_listofnull
)));
3075 /* Simple procedure applies
3079 scm_apply_0 (SCM proc
, SCM args
)
3081 return scm_apply (proc
, args
, SCM_EOL
);
3085 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
3087 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
3091 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
3093 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
3097 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
3099 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
3103 /* This code processes the arguments to apply:
3105 (apply PROC ARG1 ... ARGS)
3107 Given a list (ARG1 ... ARGS), this function conses the ARG1
3108 ... arguments onto the front of ARGS, and returns the resulting
3109 list. Note that ARGS is a list; thus, the argument to this
3110 function is a list whose last element is a list.
3112 Apply calls this function, and applies PROC to the elements of the
3113 result. apply:nconc2last takes care of building the list of
3114 arguments, given (ARG1 ... ARGS).
3116 Rather than do new consing, apply:nconc2last destroys its argument.
3117 On that topic, this code came into my care with the following
3118 beautifully cryptic comment on that topic: "This will only screw
3119 you if you do (scm_apply scm_apply '( ... ))" If you know what
3120 they're referring to, send me a patch to this comment. */
3122 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3124 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
3125 "conses the @var{arg1} @dots{} arguments onto the front of\n"
3126 "@var{args}, and returns the resulting list. Note that\n"
3127 "@var{args} is a list; thus, the argument to this function is\n"
3128 "a list whose last element is a list.\n"
3129 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
3130 "destroys its argument, so use with care.")
3131 #define FUNC_NAME s_scm_nconc2last
3134 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
3136 while (!scm_is_null (SCM_CDR (*lloc
))) /* Perhaps should be
3137 SCM_NULL_OR_NIL_P, but not
3138 needed in 99.99% of cases,
3139 and it could seriously hurt
3140 performance. - Neil */
3141 lloc
= SCM_CDRLOC (*lloc
);
3142 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3143 *lloc
= SCM_CAR (*lloc
);
3150 /* SECTION: The rest of this file is only read once.
3155 * Trampolines make it possible to move procedure application dispatch
3156 * outside inner loops. The motivation was clean implementation of
3157 * efficient replacements of R5RS primitives in SRFI-1.
3159 * The semantics is clear: scm_trampoline_N returns an optimized
3160 * version of scm_call_N (or NULL if the procedure isn't applicable
3163 * Applying the optimization to map and for-each increased efficiency
3164 * noticeably. For example, (map abs ls) is now 8 times faster than
3169 call_subr0_0 (SCM proc
)
3171 return SCM_SUBRF (proc
) ();
3175 call_subr1o_0 (SCM proc
)
3177 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
3181 call_lsubr_0 (SCM proc
)
3183 return SCM_SUBRF (proc
) (SCM_EOL
);
3187 scm_i_call_closure_0 (SCM proc
)
3189 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3192 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
3197 scm_trampoline_0 (SCM proc
)
3199 scm_t_trampoline_0 trampoline
;
3204 switch (SCM_TYP7 (proc
))
3206 case scm_tc7_subr_0
:
3207 trampoline
= call_subr0_0
;
3209 case scm_tc7_subr_1o
:
3210 trampoline
= call_subr1o_0
;
3213 trampoline
= call_lsubr_0
;
3215 case scm_tcs_closures
:
3217 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3218 if (scm_is_null (formals
) || !scm_is_pair (formals
))
3219 trampoline
= scm_i_call_closure_0
;
3224 case scm_tcs_struct
:
3225 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3226 trampoline
= scm_call_generic_0
;
3227 else if (SCM_I_OPERATORP (proc
))
3228 trampoline
= scm_call_0
;
3233 if (SCM_SMOB_APPLICABLE_P (proc
))
3234 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
3239 case scm_tc7_rpsubr
:
3242 trampoline
= scm_call_0
;
3245 return NULL
; /* not applicable on zero arguments */
3247 /* We only reach this point if a valid trampoline was determined. */
3249 /* If debugging is enabled, we want to see all calls to proc on the stack.
3250 * Thus, we replace the trampoline shortcut with scm_call_0. */
3251 if (scm_debug_mode_p
)
3258 call_subr1_1 (SCM proc
, SCM arg1
)
3260 return SCM_SUBRF (proc
) (arg1
);
3264 call_subr2o_1 (SCM proc
, SCM arg1
)
3266 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
3270 call_lsubr_1 (SCM proc
, SCM arg1
)
3272 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
3276 call_dsubr_1 (SCM proc
, SCM arg1
)
3278 if (SCM_I_INUMP (arg1
))
3280 return (scm_from_double (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
))));
3282 else if (SCM_REALP (arg1
))
3284 return (scm_from_double (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3286 else if (SCM_BIGP (arg1
))
3288 return (scm_from_double (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3290 else if (SCM_FRACTIONP (arg1
))
3292 return (scm_from_double (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
3294 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3295 SCM_ARG1
, scm_i_symbol_chars (SCM_SNAME (proc
)));
3299 call_cxr_1 (SCM proc
, SCM arg1
)
3301 return scm_i_chase_pairs (arg1
, (scm_t_bits
) SCM_SUBRF (proc
));
3305 call_closure_1 (SCM proc
, SCM arg1
)
3307 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3310 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
3315 scm_trampoline_1 (SCM proc
)
3317 scm_t_trampoline_1 trampoline
;
3322 switch (SCM_TYP7 (proc
))
3324 case scm_tc7_subr_1
:
3325 case scm_tc7_subr_1o
:
3326 trampoline
= call_subr1_1
;
3328 case scm_tc7_subr_2o
:
3329 trampoline
= call_subr2o_1
;
3332 trampoline
= call_lsubr_1
;
3335 trampoline
= call_dsubr_1
;
3338 trampoline
= call_cxr_1
;
3340 case scm_tcs_closures
:
3342 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3343 if (!scm_is_null (formals
)
3344 && (!scm_is_pair (formals
) || !scm_is_pair (SCM_CDR (formals
))))
3345 trampoline
= call_closure_1
;
3350 case scm_tcs_struct
:
3351 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3352 trampoline
= scm_call_generic_1
;
3353 else if (SCM_I_OPERATORP (proc
))
3354 trampoline
= scm_call_1
;
3359 if (SCM_SMOB_APPLICABLE_P (proc
))
3360 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
3365 case scm_tc7_rpsubr
:
3368 trampoline
= scm_call_1
;
3371 return NULL
; /* not applicable on one arg */
3373 /* We only reach this point if a valid trampoline was determined. */
3375 /* If debugging is enabled, we want to see all calls to proc on the stack.
3376 * Thus, we replace the trampoline shortcut with scm_call_1. */
3377 if (scm_debug_mode_p
)
3384 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
3386 return SCM_SUBRF (proc
) (arg1
, arg2
);
3390 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
3392 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
3396 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
3398 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
3402 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
3404 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3405 scm_list_2 (arg1
, arg2
),
3407 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
3412 scm_trampoline_2 (SCM proc
)
3414 scm_t_trampoline_2 trampoline
;
3419 switch (SCM_TYP7 (proc
))
3421 case scm_tc7_subr_2
:
3422 case scm_tc7_subr_2o
:
3423 case scm_tc7_rpsubr
:
3425 trampoline
= call_subr2_2
;
3427 case scm_tc7_lsubr_2
:
3428 trampoline
= call_lsubr2_2
;
3431 trampoline
= call_lsubr_2
;
3433 case scm_tcs_closures
:
3435 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3436 if (!scm_is_null (formals
)
3437 && (!scm_is_pair (formals
)
3438 || (!scm_is_null (SCM_CDR (formals
))
3439 && (!scm_is_pair (SCM_CDR (formals
))
3440 || !scm_is_pair (SCM_CDDR (formals
))))))
3441 trampoline
= call_closure_2
;
3446 case scm_tcs_struct
:
3447 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3448 trampoline
= scm_call_generic_2
;
3449 else if (SCM_I_OPERATORP (proc
))
3450 trampoline
= scm_call_2
;
3455 if (SCM_SMOB_APPLICABLE_P (proc
))
3456 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
3462 trampoline
= scm_call_2
;
3465 return NULL
; /* not applicable on two args */
3467 /* We only reach this point if a valid trampoline was determined. */
3469 /* If debugging is enabled, we want to see all calls to proc on the stack.
3470 * Thus, we replace the trampoline shortcut with scm_call_2. */
3471 if (scm_debug_mode_p
)
3477 /* Typechecking for multi-argument MAP and FOR-EACH.
3479 Verify that each element of the vector ARGV, except for the first,
3480 is a proper list whose length is LEN. Attribute errors to WHO,
3481 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3483 check_map_args (SCM argv
,
3492 for (i
= SCM_SIMPLE_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
3494 SCM elt
= SCM_SIMPLE_VECTOR_REF (argv
, i
);
3495 long elt_len
= scm_ilength (elt
);
3500 scm_apply_generic (gf
, scm_cons (proc
, args
));
3502 scm_wrong_type_arg (who
, i
+ 2, elt
);
3506 scm_out_of_range_pos (who
, elt
, scm_from_long (i
+ 2));
3511 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3513 /* Note: Currently, scm_map applies PROC to the argument list(s)
3514 sequentially, starting with the first element(s). This is used in
3515 evalext.c where the Scheme procedure `map-in-order', which guarantees
3516 sequential behaviour, is implemented using scm_map. If the
3517 behaviour changes, we need to update `map-in-order'.
3521 scm_map (SCM proc
, SCM arg1
, SCM args
)
3522 #define FUNC_NAME s_map
3528 len
= scm_ilength (arg1
);
3529 SCM_GASSERTn (len
>= 0,
3530 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
3531 SCM_VALIDATE_REST_ARGUMENT (args
);
3532 if (scm_is_null (args
))
3534 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
3535 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
3536 while (SCM_NIMP (arg1
))
3538 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
3539 pres
= SCM_CDRLOC (*pres
);
3540 arg1
= SCM_CDR (arg1
);
3544 if (scm_is_null (SCM_CDR (args
)))
3546 SCM arg2
= SCM_CAR (args
);
3547 int len2
= scm_ilength (arg2
);
3548 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
3550 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
3551 SCM_GASSERTn (len2
>= 0,
3552 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
3554 SCM_OUT_OF_RANGE (3, arg2
);
3555 while (SCM_NIMP (arg1
))
3557 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
3558 pres
= SCM_CDRLOC (*pres
);
3559 arg1
= SCM_CDR (arg1
);
3560 arg2
= SCM_CDR (arg2
);
3564 arg1
= scm_cons (arg1
, args
);
3565 args
= scm_vector (arg1
);
3566 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
3570 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3572 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
3575 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
3576 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
3578 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
3579 pres
= SCM_CDRLOC (*pres
);
3585 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
3588 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
3589 #define FUNC_NAME s_for_each
3592 len
= scm_ilength (arg1
);
3593 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
3594 SCM_ARG2
, s_for_each
);
3595 SCM_VALIDATE_REST_ARGUMENT (args
);
3596 if (scm_is_null (args
))
3598 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
3599 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
3600 while (SCM_NIMP (arg1
))
3602 call (proc
, SCM_CAR (arg1
));
3603 arg1
= SCM_CDR (arg1
);
3605 return SCM_UNSPECIFIED
;
3607 if (scm_is_null (SCM_CDR (args
)))
3609 SCM arg2
= SCM_CAR (args
);
3610 int len2
= scm_ilength (arg2
);
3611 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
3612 SCM_GASSERTn (call
, g_for_each
,
3613 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
3614 SCM_GASSERTn (len2
>= 0, g_for_each
,
3615 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
3617 SCM_OUT_OF_RANGE (3, arg2
);
3618 while (SCM_NIMP (arg1
))
3620 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
3621 arg1
= SCM_CDR (arg1
);
3622 arg2
= SCM_CDR (arg2
);
3624 return SCM_UNSPECIFIED
;
3626 arg1
= scm_cons (arg1
, args
);
3627 args
= scm_vector (arg1
);
3628 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
3632 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3634 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
3636 return SCM_UNSPECIFIED
;
3637 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
3638 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
3640 scm_apply (proc
, arg1
, SCM_EOL
);
3647 scm_closure (SCM code
, SCM env
)
3650 SCM closcar
= scm_cons (code
, SCM_EOL
);
3651 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
3652 scm_remember_upto_here (closcar
);
3657 scm_t_bits scm_tc16_promise
;
3660 scm_makprom (SCM code
)
3662 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
3664 scm_make_recursive_mutex ());
3669 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
3671 int writingp
= SCM_WRITINGP (pstate
);
3672 scm_puts ("#<promise ", port
);
3673 SCM_SET_WRITINGP (pstate
, 1);
3674 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
3675 SCM_SET_WRITINGP (pstate
, writingp
);
3676 scm_putc ('>', port
);
3680 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
3682 "If the promise @var{x} has not been computed yet, compute and\n"
3683 "return @var{x}, otherwise just return the previously computed\n"
3685 #define FUNC_NAME s_scm_force
3687 SCM_VALIDATE_SMOB (1, promise
, promise
);
3688 scm_lock_mutex (SCM_PROMISE_MUTEX (promise
));
3689 if (!SCM_PROMISE_COMPUTED_P (promise
))
3691 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
3692 if (!SCM_PROMISE_COMPUTED_P (promise
))
3694 SCM_SET_PROMISE_DATA (promise
, ans
);
3695 SCM_SET_PROMISE_COMPUTED (promise
);
3698 scm_unlock_mutex (SCM_PROMISE_MUTEX (promise
));
3699 return SCM_PROMISE_DATA (promise
);
3704 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
3706 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
3707 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
3708 #define FUNC_NAME s_scm_promise_p
3710 return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
3715 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
3716 (SCM xorig
, SCM x
, SCM y
),
3717 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
3718 "Any source properties associated with @var{xorig} are also associated\n"
3719 "with the new pair.")
3720 #define FUNC_NAME s_scm_cons_source
3723 z
= scm_cons (x
, y
);
3724 /* Copy source properties possibly associated with xorig. */
3725 p
= scm_whash_lookup (scm_source_whash
, xorig
);
3726 if (scm_is_true (p
))
3727 scm_whash_insert (scm_source_whash
, z
, p
);
3733 /* The function scm_copy_tree is used to copy an expression tree to allow the
3734 * memoizer to modify the expression during memoization. scm_copy_tree
3735 * creates deep copies of pairs and vectors, but not of any other data types,
3736 * since only pairs and vectors will be parsed by the memoizer.
3738 * To avoid infinite recursion due to cyclic structures, the hare-and-tortoise
3739 * pattern is used to detect cycles. In fact, the pattern is used in two
3740 * dimensions, vertical (indicated in the code by the variable names 'hare'
3741 * and 'tortoise') and horizontal ('rabbit' and 'turtle'). In both
3742 * dimensions, the hare/rabbit will take two steps when the tortoise/turtle
3745 * The vertical dimension corresponds to recursive calls to function
3746 * copy_tree: This happens when descending into vector elements, into cars of
3747 * lists and into the cdr of an improper list. In this dimension, the
3748 * tortoise follows the hare by using the processor stack: Every stack frame
3749 * will hold an instance of struct t_trace. These instances are connected in
3750 * a way that represents the trace of the hare, which thus can be followed by
3751 * the tortoise. The tortoise will always point to struct t_trace instances
3752 * relating to SCM objects that have already been copied. Thus, a cycle is
3753 * detected if the tortoise and the hare point to the same object,
3755 * The horizontal dimension is within one execution of copy_tree, when the
3756 * function cdr's along the pairs of a list. This is the standard
3757 * hare-and-tortoise implementation, found several times in guile. */
3760 struct t_trace
*trace
; /* These pointers form a trace along the stack. */
3761 SCM obj
; /* The object handled at the respective stack frame.*/
3766 struct t_trace
*const hare
,
3767 struct t_trace
*tortoise
,
3768 unsigned int tortoise_delay
)
3770 if (!scm_is_pair (hare
->obj
) && !scm_is_simple_vector (hare
->obj
))
3776 /* Prepare the trace along the stack. */
3777 struct t_trace new_hare
;
3778 hare
->trace
= &new_hare
;
3780 /* The tortoise will make its step after the delay has elapsed. Note
3781 * that in contrast to the typical hare-and-tortoise pattern, the step
3782 * of the tortoise happens before the hare takes its steps. This is, in
3783 * principle, no problem, except for the start of the algorithm: Then,
3784 * it has to be made sure that the hare actually gets its advantage of
3786 if (tortoise_delay
== 0)
3789 tortoise
= tortoise
->trace
;
3790 ASSERT_SYNTAX (!scm_is_eq (hare
->obj
, tortoise
->obj
),
3791 s_bad_expression
, hare
->obj
);
3798 if (scm_is_simple_vector (hare
->obj
))
3800 size_t length
= SCM_SIMPLE_VECTOR_LENGTH (hare
->obj
);
3801 SCM new_vector
= scm_c_make_vector (length
, SCM_UNSPECIFIED
);
3803 /* Each vector element is copied by recursing into copy_tree, having
3804 * the tortoise follow the hare into the depths of the stack. */
3805 unsigned long int i
;
3806 for (i
= 0; i
< length
; ++i
)
3809 new_hare
.obj
= SCM_SIMPLE_VECTOR_REF (hare
->obj
, i
);
3810 new_element
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3811 SCM_SIMPLE_VECTOR_SET (new_vector
, i
, new_element
);
3816 else /* scm_is_pair (hare->obj) */
3821 SCM rabbit
= hare
->obj
;
3822 SCM turtle
= hare
->obj
;
3826 /* The first pair of the list is treated specially, in order to
3827 * preserve a potential source code position. */
3828 result
= tail
= scm_cons_source (rabbit
, SCM_EOL
, SCM_EOL
);
3829 new_hare
.obj
= SCM_CAR (rabbit
);
3830 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3831 SCM_SETCAR (tail
, copy
);
3833 /* The remaining pairs of the list are copied by, horizontally,
3834 * having the turtle follow the rabbit, and, vertically, having the
3835 * tortoise follow the hare into the depths of the stack. */
3836 rabbit
= SCM_CDR (rabbit
);
3837 while (scm_is_pair (rabbit
))
3839 new_hare
.obj
= SCM_CAR (rabbit
);
3840 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3841 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
3842 tail
= SCM_CDR (tail
);
3844 rabbit
= SCM_CDR (rabbit
);
3845 if (scm_is_pair (rabbit
))
3847 new_hare
.obj
= SCM_CAR (rabbit
);
3848 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3849 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
3850 tail
= SCM_CDR (tail
);
3851 rabbit
= SCM_CDR (rabbit
);
3853 turtle
= SCM_CDR (turtle
);
3854 ASSERT_SYNTAX (!scm_is_eq (rabbit
, turtle
),
3855 s_bad_expression
, rabbit
);
3859 /* We have to recurse into copy_tree again for the last cdr, in
3860 * order to handle the situation that it holds a vector. */
3861 new_hare
.obj
= rabbit
;
3862 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3863 SCM_SETCDR (tail
, copy
);
3870 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
3872 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
3873 "the new data structure. @code{copy-tree} recurses down the\n"
3874 "contents of both pairs and vectors (since both cons cells and vector\n"
3875 "cells may point to arbitrary objects), and stops recursing when it hits\n"
3876 "any other object.")
3877 #define FUNC_NAME s_scm_copy_tree
3879 /* Prepare the trace along the stack. */
3880 struct t_trace trace
;
3883 /* In function copy_tree, if the tortoise makes its step, it will do this
3884 * before the hare has the chance to move. Thus, we have to make sure that
3885 * the very first step of the tortoise will not happen after the hare has
3886 * really made two steps. This is achieved by passing '2' as the initial
3887 * delay for the tortoise. NOTE: Since cycles are unlikely, giving the hare
3888 * a bigger advantage may improve performance slightly. */
3889 return copy_tree (&trace
, &trace
, 2);
3894 /* We have three levels of EVAL here:
3896 - scm_i_eval (exp, env)
3898 evaluates EXP in environment ENV. ENV is a lexical environment
3899 structure as used by the actual tree code evaluator. When ENV is
3900 a top-level environment, then changes to the current module are
3901 tracked by updating ENV so that it continues to be in sync with
3904 - scm_primitive_eval (exp)
3906 evaluates EXP in the top-level environment as determined by the
3907 current module. This is done by constructing a suitable
3908 environment and calling scm_i_eval. Thus, changes to the
3909 top-level module are tracked normally.
3911 - scm_eval (exp, mod_or_state)
3913 evaluates EXP while MOD_OR_STATE is the current module or current
3914 dynamic state (as appropriate). This is done by setting the
3915 current module (or dynamic state) to MOD_OR_STATE, invoking
3916 scm_primitive_eval on EXP, and then restoring the current module
3917 (or dynamic state) to the value it had previously. That is,
3918 while EXP is evaluated, changes to the current module (or dynamic
3919 state) are tracked, but these changes do not persist when
3922 For each level of evals, there are two variants, distinguished by a
3923 _x suffix: the ordinary variant does not modify EXP while the _x
3924 variant can destructively modify EXP into something completely
3925 unintelligible. A Scheme data structure passed as EXP to one of the
3926 _x variants should not ever be used again for anything. So when in
3927 doubt, use the ordinary variant.
3932 scm_i_eval_x (SCM exp
, SCM env
)
3934 if (scm_is_symbol (exp
))
3935 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
3937 return SCM_I_XEVAL (exp
, env
, scm_debug_mode_p
);
3941 scm_i_eval (SCM exp
, SCM env
)
3943 exp
= scm_copy_tree (exp
);
3944 if (scm_is_symbol (exp
))
3945 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
3947 return SCM_I_XEVAL (exp
, env
, scm_debug_mode_p
);
3951 scm_primitive_eval_x (SCM exp
)
3954 SCM transformer
= scm_current_module_transformer ();
3955 if (SCM_NIMP (transformer
))
3956 exp
= scm_call_1 (transformer
, exp
);
3957 env
= scm_top_level_env (scm_current_module_lookup_closure ());
3958 return scm_i_eval_x (exp
, env
);
3961 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
3963 "Evaluate @var{exp} in the top-level environment specified by\n"
3964 "the current module.")
3965 #define FUNC_NAME s_scm_primitive_eval
3968 SCM transformer
= scm_current_module_transformer ();
3969 if (scm_is_true (transformer
))
3970 exp
= scm_call_1 (transformer
, exp
);
3971 env
= scm_top_level_env (scm_current_module_lookup_closure ());
3972 return scm_i_eval (exp
, env
);
3977 /* Eval does not take the second arg optionally. This is intentional
3978 * in order to be R5RS compatible, and to prepare for the new module
3979 * system, where we would like to make the choice of evaluation
3980 * environment explicit. */
3983 scm_eval_x (SCM exp
, SCM module_or_state
)
3987 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
3988 if (scm_is_dynamic_state (module_or_state
))
3989 scm_dynwind_current_dynamic_state (module_or_state
);
3991 scm_dynwind_current_module (module_or_state
);
3993 res
= scm_primitive_eval_x (exp
);
3999 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
4000 (SCM exp
, SCM module_or_state
),
4001 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
4002 "in the top-level environment specified by\n"
4003 "@var{module_or_state}.\n"
4004 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
4005 "@var{module_or_state} is made the current module when\n"
4006 "it is a module, or the current dynamic state when it is\n"
4008 "Example: (eval '(+ 1 2) (interaction-environment))")
4009 #define FUNC_NAME s_scm_eval
4013 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
4014 if (scm_is_dynamic_state (module_or_state
))
4015 scm_dynwind_current_dynamic_state (module_or_state
);
4017 scm_dynwind_current_module (module_or_state
);
4019 res
= scm_primitive_eval (exp
);
4027 /* At this point, deval and scm_dapply are generated.
4039 scm_i_pthread_mutex_init (&source_mutex
,
4040 scm_i_pthread_mutexattr_recursive
);
4042 scm_init_opts (scm_evaluator_traps
,
4043 scm_evaluator_trap_table
);
4044 scm_init_opts (scm_eval_options_interface
,
4047 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
4048 scm_set_smob_print (scm_tc16_promise
, promise_print
);
4050 undefineds
= scm_list_1 (SCM_UNDEFINED
);
4051 SCM_SETCDR (undefineds
, undefineds
);
4052 scm_permanent_object (undefineds
);
4054 scm_listofnull
= scm_list_1 (SCM_EOL
);
4056 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
4057 scm_permanent_object (f_apply
);
4059 #include "libguile/eval.x"
4061 scm_add_feature ("delay");