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.
30 #include "libguile/__scm.h"
32 /* This blob per the Autoconf manual (under "Particular Functions"). */
35 #elif defined __GNUC__
36 # define alloca __builtin_alloca
38 # define alloca __alloca
39 #elif defined _MSC_VER
41 # define alloca _alloca
47 void *alloca (size_t);
51 #include "libguile/_scm.h"
52 #include "libguile/alist.h"
53 #include "libguile/async.h"
54 #include "libguile/continuations.h"
55 #include "libguile/debug.h"
56 #include "libguile/deprecation.h"
57 #include "libguile/dynwind.h"
58 #include "libguile/eq.h"
59 #include "libguile/feature.h"
60 #include "libguile/fluids.h"
61 #include "libguile/futures.h"
62 #include "libguile/goops.h"
63 #include "libguile/hash.h"
64 #include "libguile/hashtab.h"
65 #include "libguile/lang.h"
66 #include "libguile/list.h"
67 #include "libguile/macros.h"
68 #include "libguile/modules.h"
69 #include "libguile/objects.h"
70 #include "libguile/ports.h"
71 #include "libguile/print.h"
72 #include "libguile/procprop.h"
73 #include "libguile/root.h"
74 #include "libguile/smob.h"
75 #include "libguile/srcprop.h"
76 #include "libguile/stackchk.h"
77 #include "libguile/strings.h"
78 #include "libguile/threads.h"
79 #include "libguile/throw.h"
80 #include "libguile/validate.h"
81 #include "libguile/values.h"
82 #include "libguile/vectors.h"
84 #include "libguile/eval.h"
85 #include "libguile/private-options.h"
90 static SCM
unmemoize_exprs (SCM expr
, SCM env
);
91 static SCM
canonicalize_define (SCM expr
);
92 static SCM
*scm_lookupcar1 (SCM vloc
, SCM genv
, int check
);
93 static SCM
unmemoize_builtin_macro (SCM expr
, SCM env
);
94 static void ceval_letrec_inits (SCM env
, SCM init_forms
, SCM
**init_values_eol
);
95 static SCM
ceval (SCM x
, SCM env
);
96 static SCM
deval (SCM x
, SCM env
);
102 * This section defines the message strings for the syntax errors that can be
103 * detected during memoization and the functions and macros that shall be
104 * called by the memoizer code to signal syntax errors. */
107 /* Syntax errors that can be detected during memoization: */
109 /* Circular or improper lists do not form valid scheme expressions. If a
110 * circular list or an improper list is detected in a place where a scheme
111 * expression is expected, a 'Bad expression' error is signalled. */
112 static const char s_bad_expression
[] = "Bad expression";
114 /* If a form is detected that holds a different number of expressions than are
115 * required in that context, a 'Missing or extra expression' error is
117 static const char s_expression
[] = "Missing or extra expression in";
119 /* If a form is detected that holds less expressions than are required in that
120 * context, a 'Missing expression' error is signalled. */
121 static const char s_missing_expression
[] = "Missing expression in";
123 /* If a form is detected that holds more expressions than are allowed in that
124 * context, an 'Extra expression' error is signalled. */
125 static const char s_extra_expression
[] = "Extra expression in";
127 /* The empty combination '()' is not allowed as an expression in scheme. If
128 * it is detected in a place where an expression is expected, an 'Illegal
129 * empty combination' error is signalled. Note: If you encounter this error
130 * message, it is very likely that you intended to denote the empty list. To
131 * do so, you need to quote the empty list like (quote ()) or '(). */
132 static const char s_empty_combination
[] = "Illegal empty combination";
134 /* A body may hold an arbitrary number of internal defines, followed by a
135 * non-empty sequence of expressions. If a body with an empty sequence of
136 * expressions is detected, a 'Missing body expression' error is signalled.
138 static const char s_missing_body_expression
[] = "Missing body expression in";
140 /* A body may hold an arbitrary number of internal defines, followed by a
141 * non-empty sequence of expressions. Each the definitions and the
142 * expressions may be grouped arbitraryly with begin, but it is not allowed to
143 * mix definitions and expressions. If a define form in a body mixes
144 * definitions and expressions, a 'Mixed definitions and expressions' error is
146 static const char s_mixed_body_forms
[] = "Mixed definitions and expressions in";
147 /* Definitions are only allowed on the top level and at the start of a body.
148 * If a definition is detected anywhere else, a 'Bad define placement' error
150 static const char s_bad_define
[] = "Bad define placement";
152 /* Case or cond expressions must have at least one clause. If a case or cond
153 * expression without any clauses is detected, a 'Missing clauses' error is
155 static const char s_missing_clauses
[] = "Missing clauses";
157 /* If there is an 'else' clause in a case or a cond statement, it must be the
158 * last clause. If after the 'else' case clause further clauses are detected,
159 * a 'Misplaced else clause' error is signalled. */
160 static const char s_misplaced_else_clause
[] = "Misplaced else clause";
162 /* If a case clause is detected that is not in the format
163 * (<label(s)> <expression1> <expression2> ...)
164 * a 'Bad case clause' error is signalled. */
165 static const char s_bad_case_clause
[] = "Bad case clause";
167 /* If a case clause is detected where the <label(s)> element is neither a
168 * proper list nor (in case of the last clause) the syntactic keyword 'else',
169 * a 'Bad case labels' error is signalled. Note: If you encounter this error
170 * for an else-clause which seems to be syntactically correct, check if 'else'
171 * is really a syntactic keyword in that context. If 'else' is bound in the
172 * local or global environment, it is not considered a syntactic keyword, but
173 * will be treated as any other variable. */
174 static const char s_bad_case_labels
[] = "Bad case labels";
176 /* In a case statement all labels have to be distinct. If in a case statement
177 * a label occurs more than once, a 'Duplicate case label' error is
179 static const char s_duplicate_case_label
[] = "Duplicate case label";
181 /* If a cond clause is detected that is not in one of the formats
182 * (<test> <expression1> ...) or (else <expression1> <expression2> ...)
183 * a 'Bad cond clause' error is signalled. */
184 static const char s_bad_cond_clause
[] = "Bad cond clause";
186 /* If a cond clause is detected that uses the alternate '=>' form, but does
187 * not hold a recipient element for the test result, a 'Missing recipient'
188 * error is signalled. */
189 static const char s_missing_recipient
[] = "Missing recipient in";
191 /* If in a position where a variable name is required some other object is
192 * detected, a 'Bad variable' error is signalled. */
193 static const char s_bad_variable
[] = "Bad variable";
195 /* Bindings for forms like 'let' and 'do' have to be given in a proper,
196 * possibly empty list. If any other object is detected in a place where a
197 * list of bindings was required, a 'Bad bindings' error is signalled. */
198 static const char s_bad_bindings
[] = "Bad bindings";
200 /* Depending on the syntactic context, a binding has to be in the format
201 * (<variable> <expression>) or (<variable> <expression1> <expression2>).
202 * If anything else is detected in a place where a binding was expected, a
203 * 'Bad binding' error is signalled. */
204 static const char s_bad_binding
[] = "Bad binding";
206 /* Some syntactic forms don't allow variable names to appear more than once in
207 * a list of bindings. If such a situation is nevertheless detected, a
208 * 'Duplicate binding' error is signalled. */
209 static const char s_duplicate_binding
[] = "Duplicate binding";
211 /* If the exit form of a 'do' expression is not in the format
212 * (<test> <expression> ...)
213 * a 'Bad exit clause' error is signalled. */
214 static const char s_bad_exit_clause
[] = "Bad exit clause";
216 /* The formal function arguments of a lambda expression have to be either a
217 * single symbol or a non-cyclic list. For anything else a 'Bad formals'
218 * error is signalled. */
219 static const char s_bad_formals
[] = "Bad formals";
221 /* If in a lambda expression something else than a symbol is detected at a
222 * place where a formal function argument is required, a 'Bad formal' error is
224 static const char s_bad_formal
[] = "Bad formal";
226 /* If in the arguments list of a lambda expression an argument name occurs
227 * more than once, a 'Duplicate formal' error is signalled. */
228 static const char s_duplicate_formal
[] = "Duplicate formal";
230 /* If the evaluation of an unquote-splicing expression gives something else
231 * than a proper list, a 'Non-list result for unquote-splicing' error is
233 static const char s_splicing
[] = "Non-list result for unquote-splicing";
235 /* If something else than an exact integer is detected as the argument for
236 * @slot-ref and @slot-set!, a 'Bad slot number' error is signalled. */
237 static const char s_bad_slot_number
[] = "Bad slot number";
240 /* Signal a syntax error. We distinguish between the form that caused the
241 * error and the enclosing expression. The error message will print out as
242 * shown in the following pattern. The file name and line number are only
243 * given when they can be determined from the erroneous form or from the
244 * enclosing expression.
246 * <filename>: In procedure memoization:
247 * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
249 SCM_SYMBOL (syntax_error_key
, "syntax-error");
251 /* The prototype is needed to indicate that the function does not return. */
253 syntax_error (const char* const, const SCM
, const SCM
) SCM_NORETURN
;
256 syntax_error (const char* const msg
, const SCM form
, const SCM expr
)
258 SCM msg_string
= scm_from_locale_string (msg
);
259 SCM filename
= SCM_BOOL_F
;
260 SCM linenr
= SCM_BOOL_F
;
264 if (scm_is_pair (form
))
266 filename
= scm_source_property (form
, scm_sym_filename
);
267 linenr
= scm_source_property (form
, scm_sym_line
);
270 if (scm_is_false (filename
) && scm_is_false (linenr
) && scm_is_pair (expr
))
272 filename
= scm_source_property (expr
, scm_sym_filename
);
273 linenr
= scm_source_property (expr
, scm_sym_line
);
276 if (!SCM_UNBNDP (expr
))
278 if (scm_is_true (filename
))
280 format
= "In file ~S, line ~S: ~A ~S in expression ~S.";
281 args
= scm_list_5 (filename
, linenr
, msg_string
, form
, expr
);
283 else if (scm_is_true (linenr
))
285 format
= "In line ~S: ~A ~S in expression ~S.";
286 args
= scm_list_4 (linenr
, msg_string
, form
, expr
);
290 format
= "~A ~S in expression ~S.";
291 args
= scm_list_3 (msg_string
, form
, expr
);
296 if (scm_is_true (filename
))
298 format
= "In file ~S, line ~S: ~A ~S.";
299 args
= scm_list_4 (filename
, linenr
, msg_string
, form
);
301 else if (scm_is_true (linenr
))
303 format
= "In line ~S: ~A ~S.";
304 args
= scm_list_3 (linenr
, msg_string
, form
);
309 args
= scm_list_2 (msg_string
, form
);
313 scm_error (syntax_error_key
, "memoization", format
, args
, SCM_BOOL_F
);
317 /* Shortcut macros to simplify syntax error handling. */
318 #define ASSERT_SYNTAX(cond, message, form) \
319 { if (!(cond)) syntax_error (message, form, SCM_UNDEFINED); }
320 #define ASSERT_SYNTAX_2(cond, message, form, expr) \
321 { if (!(cond)) syntax_error (message, form, expr); }
327 * Ilocs are memoized references to variables in local environment frames.
328 * They are represented as three values: The relative offset of the
329 * environment frame, the number of the binding within that frame, and a
330 * boolean value indicating whether the binding is the last binding in the
333 * Frame numbers have 11 bits, relative offsets have 12 bits.
336 #define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc)
337 #define SCM_IFRINC (0x00000100L)
338 #define SCM_ICDR (0x00080000L)
339 #define SCM_IDINC (0x00100000L)
340 #define SCM_IFRAME(n) ((long)((SCM_ICDR-SCM_IFRINC)>>8) \
341 & (SCM_UNPACK (n) >> 8))
342 #define SCM_IDIST(n) (SCM_UNPACK (n) >> 20)
343 #define SCM_ICDRP(n) (SCM_ICDR & SCM_UNPACK (n))
344 #define SCM_IDSTMSK (-SCM_IDINC)
345 #define SCM_IFRAMEMAX ((1<<11)-1)
346 #define SCM_IDISTMAX ((1<<12)-1)
347 #define SCM_MAKE_ILOC(frame_nr, binding_nr, last_p) \
350 + ((binding_nr) << 20) \
351 + ((last_p) ? SCM_ICDR : 0) \
355 scm_i_print_iloc (SCM iloc
, SCM port
)
357 scm_puts ("#@", port
);
358 scm_intprint ((long) SCM_IFRAME (iloc
), 10, port
);
359 scm_putc (SCM_ICDRP (iloc
) ? '-' : '+', port
);
360 scm_intprint ((long) SCM_IDIST (iloc
), 10, port
);
363 #if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
365 SCM
scm_dbg_make_iloc (SCM frame
, SCM binding
, SCM cdrp
);
367 SCM_DEFINE (scm_dbg_make_iloc
, "dbg-make-iloc", 3, 0, 0,
368 (SCM frame
, SCM binding
, SCM cdrp
),
369 "Return a new iloc with frame offset @var{frame}, binding\n"
370 "offset @var{binding} and the cdr flag @var{cdrp}.")
371 #define FUNC_NAME s_scm_dbg_make_iloc
373 return SCM_MAKE_ILOC ((scm_t_bits
) scm_to_unsigned_integer (frame
, 0, SCM_IFRAMEMAX
),
374 (scm_t_bits
) scm_to_unsigned_integer (binding
, 0, SCM_IDISTMAX
),
379 SCM
scm_dbg_iloc_p (SCM obj
);
381 SCM_DEFINE (scm_dbg_iloc_p
, "dbg-iloc?", 1, 0, 0,
383 "Return @code{#t} if @var{obj} is an iloc.")
384 #define FUNC_NAME s_scm_dbg_iloc_p
386 return scm_from_bool (SCM_ILOCP (obj
));
394 /* {Evaluator byte codes (isyms)}
397 #define ISYMNUM(n) (SCM_ITAG8_DATA (n))
399 /* This table must agree with the list of SCM_IM_ constants in tags.h */
400 static const char *const isymnames
[] =
417 "#@call-with-current-continuation",
423 "#@call-with-values",
431 scm_i_print_isym (SCM isym
, SCM port
)
433 const size_t isymnum
= ISYMNUM (isym
);
434 if (isymnum
< (sizeof isymnames
/ sizeof (char *)))
435 scm_puts (isymnames
[isymnum
], port
);
437 scm_ipruk ("isym", isym
, port
);
442 /* The function lookup_symbol is used during memoization: Lookup the symbol in
443 * the environment. If there is no binding for the symbol, SCM_UNDEFINED is
444 * returned. If the symbol is a global variable, the variable object to which
445 * the symbol is bound is returned. Finally, if the symbol is a local
446 * variable the corresponding iloc object is returned. */
448 /* A helper function for lookup_symbol: Try to find the symbol in the top
449 * level environment frame. The function returns SCM_UNDEFINED if the symbol
450 * is unbound and it returns a variable object if the symbol is a global
453 lookup_global_symbol (const SCM symbol
, const SCM top_level
)
455 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
456 if (scm_is_false (variable
))
457 return SCM_UNDEFINED
;
463 lookup_symbol (const SCM symbol
, const SCM env
)
466 unsigned int frame_nr
;
468 for (frame_idx
= env
, frame_nr
= 0;
469 !scm_is_null (frame_idx
);
470 frame_idx
= SCM_CDR (frame_idx
), ++frame_nr
)
472 const SCM frame
= SCM_CAR (frame_idx
);
473 if (scm_is_pair (frame
))
475 /* frame holds a local environment frame */
477 unsigned int symbol_nr
;
479 for (symbol_idx
= SCM_CAR (frame
), symbol_nr
= 0;
480 scm_is_pair (symbol_idx
);
481 symbol_idx
= SCM_CDR (symbol_idx
), ++symbol_nr
)
483 if (scm_is_eq (SCM_CAR (symbol_idx
), symbol
))
484 /* found the symbol, therefore return the iloc */
485 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 0);
487 if (scm_is_eq (symbol_idx
, symbol
))
488 /* found the symbol as the last element of the current frame */
489 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 1);
493 /* no more local environment frames */
494 return lookup_global_symbol (symbol
, frame
);
498 return lookup_global_symbol (symbol
, SCM_BOOL_F
);
502 /* Return true if the symbol is - from the point of view of a macro
503 * transformer - a literal in the sense specified in chapter "pattern
504 * language" of R5RS. In the code below, however, we don't match the
505 * definition of R5RS exactly: It returns true if the identifier has no
506 * binding or if it is a syntactic keyword. */
508 literal_p (const SCM symbol
, const SCM env
)
510 const SCM variable
= lookup_symbol (symbol
, env
);
511 if (SCM_UNBNDP (variable
))
513 if (SCM_VARIABLEP (variable
) && SCM_MACROP (SCM_VARIABLE_REF (variable
)))
520 /* Return true if the expression is self-quoting in the memoized code. Thus,
521 * some other objects (like e. g. vectors) are reported as self-quoting, which
522 * according to R5RS would need to be quoted. */
524 is_self_quoting_p (const SCM expr
)
526 if (scm_is_pair (expr
))
528 else if (scm_is_symbol (expr
))
530 else if (scm_is_null (expr
))
536 SCM_SYMBOL (sym_three_question_marks
, "???");
539 unmemoize_expression (const SCM expr
, const SCM env
)
541 if (SCM_ILOCP (expr
))
544 unsigned long int frame_nr
;
546 unsigned long int symbol_nr
;
548 for (frame_idx
= env
, frame_nr
= SCM_IFRAME (expr
);
550 frame_idx
= SCM_CDR (frame_idx
), --frame_nr
)
552 for (symbol_idx
= SCM_CAAR (frame_idx
), symbol_nr
= SCM_IDIST (expr
);
554 symbol_idx
= SCM_CDR (symbol_idx
), --symbol_nr
)
556 return SCM_ICDRP (expr
) ? symbol_idx
: SCM_CAR (symbol_idx
);
558 else if (SCM_VARIABLEP (expr
))
560 const SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), expr
);
561 return scm_is_true (sym
) ? sym
: sym_three_question_marks
;
563 else if (scm_is_simple_vector (expr
))
565 return scm_list_2 (scm_sym_quote
, expr
);
567 else if (!scm_is_pair (expr
))
571 else if (SCM_ISYMP (SCM_CAR (expr
)))
573 return unmemoize_builtin_macro (expr
, env
);
577 return unmemoize_exprs (expr
, env
);
583 unmemoize_exprs (const SCM exprs
, const SCM env
)
585 SCM r_result
= SCM_EOL
;
586 SCM expr_idx
= exprs
;
589 /* Note that due to the current lazy memoizer we may find partially memoized
590 * code during execution. In such code we have to expect improper lists of
591 * expressions: On the one hand, for such code syntax checks have not yet
592 * fully been performed, on the other hand, there may be even legal code
593 * like '(a . b) appear as an improper list of expressions as long as the
594 * quote expression is still in its unmemoized form. For this reason, the
595 * following code handles improper lists of expressions until memoization
596 * and execution have been completely separated. */
597 for (; scm_is_pair (expr_idx
); expr_idx
= SCM_CDR (expr_idx
))
599 const SCM expr
= SCM_CAR (expr_idx
);
601 /* In partially memoized code, lists of expressions that stem from a
602 * body form may start with an ISYM if the body itself has not yet been
603 * memoized. This isym is just an internal marker to indicate that the
604 * body still needs to be memoized. An isym may occur at the very
605 * beginning of the body or after one or more comment strings. It is
606 * dropped during unmemoization. */
607 if (!SCM_ISYMP (expr
))
609 um_expr
= unmemoize_expression (expr
, env
);
610 r_result
= scm_cons (um_expr
, r_result
);
613 um_expr
= unmemoize_expression (expr_idx
, env
);
614 if (!scm_is_null (r_result
))
616 const SCM result
= scm_reverse_x (r_result
, SCM_UNDEFINED
);
617 SCM_SETCDR (r_result
, um_expr
);
627 /* Rewrite the body (which is given as the list of expressions forming the
628 * body) into its internal form. The internal form of a body (<expr> ...) is
629 * just the body itself, but prefixed with an ISYM that denotes to what kind
630 * of outer construct this body belongs: (<ISYM> <expr> ...). A lambda body
631 * starts with SCM_IM_LAMBDA, for example, a body of a let starts with
634 * It is assumed that the calling expression has already made sure that the
635 * body is a proper list. */
637 m_body (SCM op
, SCM exprs
)
639 /* Don't add another ISYM if one is present already. */
640 if (SCM_ISYMP (SCM_CAR (exprs
)))
643 return scm_cons (op
, exprs
);
647 /* The function m_expand_body memoizes a proper list of expressions forming a
648 * body. This function takes care of dealing with internal defines and
649 * transforming them into an equivalent letrec expression. The list of
650 * expressions is rewritten in place. */
652 /* This is a helper function for m_expand_body. If the argument expression is
653 * a symbol that denotes a syntactic keyword, the corresponding macro object
654 * is returned, in all other cases the function returns SCM_UNDEFINED. */
656 try_macro_lookup (const SCM expr
, const SCM env
)
658 if (scm_is_symbol (expr
))
660 const SCM variable
= lookup_symbol (expr
, env
);
661 if (SCM_VARIABLEP (variable
))
663 const SCM value
= SCM_VARIABLE_REF (variable
);
664 if (SCM_MACROP (value
))
669 return SCM_UNDEFINED
;
672 /* This is a helper function for m_expand_body. It expands user macros,
673 * because for the correct translation of a body we need to know whether they
674 * expand to a definition. */
676 expand_user_macros (SCM expr
, const SCM env
)
678 while (scm_is_pair (expr
))
680 const SCM car_expr
= SCM_CAR (expr
);
681 const SCM new_car
= expand_user_macros (car_expr
, env
);
682 const SCM value
= try_macro_lookup (new_car
, env
);
684 if (SCM_MACROP (value
) && SCM_MACRO_TYPE (value
) == 2)
686 /* User macros transform code into code. */
687 expr
= scm_call_2 (SCM_MACRO_CODE (value
), expr
, env
);
688 /* We need to reiterate on the transformed code. */
692 /* No user macro: return. */
693 SCM_SETCAR (expr
, new_car
);
701 /* This is a helper function for m_expand_body. It determines if a given form
702 * represents an application of a given built-in macro. The built-in macro to
703 * check for is identified by its syntactic keyword. The form is an
704 * application of the given macro if looking up the car of the form in the
705 * given environment actually returns the built-in macro. */
707 is_system_macro_p (const SCM syntactic_keyword
, const SCM form
, const SCM env
)
709 if (scm_is_pair (form
))
711 const SCM car_form
= SCM_CAR (form
);
712 const SCM value
= try_macro_lookup (car_form
, env
);
713 if (SCM_BUILTIN_MACRO_P (value
))
715 const SCM macro_name
= scm_macro_name (value
);
716 return scm_is_eq (macro_name
, syntactic_keyword
);
724 m_expand_body (const SCM forms
, const SCM env
)
726 /* The first body form can be skipped since it is known to be the ISYM that
727 * was prepended to the body by m_body. */
728 SCM cdr_forms
= SCM_CDR (forms
);
729 SCM form_idx
= cdr_forms
;
730 SCM definitions
= SCM_EOL
;
731 SCM sequence
= SCM_EOL
;
733 /* According to R5RS, the list of body forms consists of two parts: a number
734 * (maybe zero) of definitions, followed by a non-empty sequence of
735 * expressions. Each the definitions and the expressions may be grouped
736 * arbitrarily with begin, but it is not allowed to mix definitions and
737 * expressions. The task of the following loop therefore is to split the
738 * list of body forms into the list of definitions and the sequence of
740 while (!scm_is_null (form_idx
))
742 const SCM form
= SCM_CAR (form_idx
);
743 const SCM new_form
= expand_user_macros (form
, env
);
744 if (is_system_macro_p (scm_sym_define
, new_form
, env
))
746 definitions
= scm_cons (new_form
, definitions
);
747 form_idx
= SCM_CDR (form_idx
);
749 else if (is_system_macro_p (scm_sym_begin
, new_form
, env
))
751 /* We have encountered a group of forms. This has to be either a
752 * (possibly empty) group of (possibly further grouped) definitions,
753 * or a non-empty group of (possibly further grouped)
755 const SCM grouped_forms
= SCM_CDR (new_form
);
756 unsigned int found_definition
= 0;
757 unsigned int found_expression
= 0;
758 SCM grouped_form_idx
= grouped_forms
;
759 while (!found_expression
&& !scm_is_null (grouped_form_idx
))
761 const SCM inner_form
= SCM_CAR (grouped_form_idx
);
762 const SCM new_inner_form
= expand_user_macros (inner_form
, env
);
763 if (is_system_macro_p (scm_sym_define
, new_inner_form
, env
))
765 found_definition
= 1;
766 definitions
= scm_cons (new_inner_form
, definitions
);
767 grouped_form_idx
= SCM_CDR (grouped_form_idx
);
769 else if (is_system_macro_p (scm_sym_begin
, new_inner_form
, env
))
771 const SCM inner_group
= SCM_CDR (new_inner_form
);
773 = scm_append (scm_list_2 (inner_group
,
774 SCM_CDR (grouped_form_idx
)));
778 /* The group marks the start of the expressions of the body.
779 * We have to make sure that within the same group we have
780 * not encountered a definition before. */
781 ASSERT_SYNTAX (!found_definition
, s_mixed_body_forms
, form
);
782 found_expression
= 1;
783 grouped_form_idx
= SCM_EOL
;
787 /* We have finished processing the group. If we have not yet
788 * encountered an expression we continue processing the forms of the
789 * body to collect further definition forms. Otherwise, the group
790 * marks the start of the sequence of expressions of the body. */
791 if (!found_expression
)
793 form_idx
= SCM_CDR (form_idx
);
803 /* We have detected a form which is no definition. This marks the
804 * start of the sequence of expressions of the body. */
810 /* FIXME: forms does not hold information about the file location. */
811 ASSERT_SYNTAX (scm_is_pair (sequence
), s_missing_body_expression
, cdr_forms
);
813 if (!scm_is_null (definitions
))
817 SCM letrec_expression
;
818 SCM new_letrec_expression
;
820 SCM bindings
= SCM_EOL
;
821 for (definition_idx
= definitions
;
822 !scm_is_null (definition_idx
);
823 definition_idx
= SCM_CDR (definition_idx
))
825 const SCM definition
= SCM_CAR (definition_idx
);
826 const SCM canonical_definition
= canonicalize_define (definition
);
827 const SCM binding
= SCM_CDR (canonical_definition
);
828 bindings
= scm_cons (binding
, bindings
);
831 letrec_tail
= scm_cons (bindings
, sequence
);
832 /* FIXME: forms does not hold information about the file location. */
833 letrec_expression
= scm_cons_source (forms
, scm_sym_letrec
, letrec_tail
);
834 new_letrec_expression
= scm_m_letrec (letrec_expression
, env
);
835 SCM_SETCAR (forms
, new_letrec_expression
);
836 SCM_SETCDR (forms
, SCM_EOL
);
840 SCM_SETCAR (forms
, SCM_CAR (sequence
));
841 SCM_SETCDR (forms
, SCM_CDR (sequence
));
846 macroexp (SCM x
, SCM env
)
848 SCM res
, proc
, orig_sym
;
850 /* Don't bother to produce error messages here. We get them when we
851 eventually execute the code for real. */
854 orig_sym
= SCM_CAR (x
);
855 if (!scm_is_symbol (orig_sym
))
859 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
860 if (proc_ptr
== NULL
)
862 /* We have lost the race. */
868 /* Only handle memoizing macros. `Acros' and `macros' are really
869 special forms and should not be evaluated here. */
871 if (!SCM_MACROP (proc
)
872 || (SCM_MACRO_TYPE (proc
) != 2 && !SCM_BUILTIN_MACRO_P (proc
)))
875 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
876 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
878 if (scm_ilength (res
) <= 0)
879 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
881 /* njrev: Several queries here: (1) I don't see how it can be
882 correct that the SCM_SETCAR 2 lines below this comment needs
883 protection, but the SCM_SETCAR 6 lines above does not, so
884 something here is probably wrong. (2) macroexp() is now only
885 used in one place - scm_m_generalized_set_x - whereas all other
886 macro expansion happens through expand_user_macros. Therefore
887 (2.1) perhaps macroexp() could be eliminated completely now?
888 (2.2) Does expand_user_macros need any critical section
891 SCM_CRITICAL_SECTION_START
;
892 SCM_SETCAR (x
, SCM_CAR (res
));
893 SCM_SETCDR (x
, SCM_CDR (res
));
894 SCM_CRITICAL_SECTION_END
;
899 /* Start of the memoizers for the standard R5RS builtin macros. */
902 SCM_SYNTAX (s_and
, "and", scm_i_makbimacro
, scm_m_and
);
903 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
906 scm_m_and (SCM expr
, SCM env SCM_UNUSED
)
908 const SCM cdr_expr
= SCM_CDR (expr
);
909 const long length
= scm_ilength (cdr_expr
);
911 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
915 /* Special case: (and) is replaced by #t. */
920 SCM_SETCAR (expr
, SCM_IM_AND
);
926 unmemoize_and (const SCM expr
, const SCM env
)
928 return scm_cons (scm_sym_and
, unmemoize_exprs (SCM_CDR (expr
), env
));
932 SCM_SYNTAX (s_begin
, "begin", scm_i_makbimacro
, scm_m_begin
);
933 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
936 scm_m_begin (SCM expr
, SCM env SCM_UNUSED
)
938 const SCM cdr_expr
= SCM_CDR (expr
);
939 /* Dirk:FIXME:: An empty begin clause is not generally allowed by R5RS.
940 * That means, there should be a distinction between uses of begin where an
941 * empty clause is OK and where it is not. */
942 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
944 SCM_SETCAR (expr
, SCM_IM_BEGIN
);
949 unmemoize_begin (const SCM expr
, const SCM env
)
951 return scm_cons (scm_sym_begin
, unmemoize_exprs (SCM_CDR (expr
), env
));
955 SCM_SYNTAX (s_case
, "case", scm_i_makbimacro
, scm_m_case
);
956 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
957 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
960 scm_m_case (SCM expr
, SCM env
)
963 SCM all_labels
= SCM_EOL
;
965 /* Check, whether 'else is a literal, i. e. not bound to a value. */
966 const int else_literal_p
= literal_p (scm_sym_else
, env
);
968 const SCM cdr_expr
= SCM_CDR (expr
);
969 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
970 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_clauses
, expr
);
972 clauses
= SCM_CDR (cdr_expr
);
973 while (!scm_is_null (clauses
))
977 const SCM clause
= SCM_CAR (clauses
);
978 ASSERT_SYNTAX_2 (scm_ilength (clause
) >= 2,
979 s_bad_case_clause
, clause
, expr
);
981 labels
= SCM_CAR (clause
);
982 if (scm_is_pair (labels
))
984 ASSERT_SYNTAX_2 (scm_ilength (labels
) >= 0,
985 s_bad_case_labels
, labels
, expr
);
986 all_labels
= scm_append (scm_list_2 (labels
, all_labels
));
988 else if (scm_is_null (labels
))
990 /* The list of labels is empty. According to R5RS this is allowed.
991 * It means that the sequence of expressions will never be executed.
992 * Therefore, as an optimization, we could remove the whole
997 ASSERT_SYNTAX_2 (scm_is_eq (labels
, scm_sym_else
) && else_literal_p
,
998 s_bad_case_labels
, labels
, expr
);
999 ASSERT_SYNTAX_2 (scm_is_null (SCM_CDR (clauses
)),
1000 s_misplaced_else_clause
, clause
, expr
);
1003 /* build the new clause */
1004 if (scm_is_eq (labels
, scm_sym_else
))
1005 SCM_SETCAR (clause
, SCM_IM_ELSE
);
1007 clauses
= SCM_CDR (clauses
);
1010 /* Check whether all case labels are distinct. */
1011 for (; !scm_is_null (all_labels
); all_labels
= SCM_CDR (all_labels
))
1013 const SCM label
= SCM_CAR (all_labels
);
1014 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (label
, SCM_CDR (all_labels
))),
1015 s_duplicate_case_label
, label
, expr
);
1018 SCM_SETCAR (expr
, SCM_IM_CASE
);
1023 unmemoize_case (const SCM expr
, const SCM env
)
1025 const SCM um_key_expr
= unmemoize_expression (SCM_CADR (expr
), env
);
1026 SCM um_clauses
= SCM_EOL
;
1029 for (clause_idx
= SCM_CDDR (expr
);
1030 !scm_is_null (clause_idx
);
1031 clause_idx
= SCM_CDR (clause_idx
))
1033 const SCM clause
= SCM_CAR (clause_idx
);
1034 const SCM labels
= SCM_CAR (clause
);
1035 const SCM exprs
= SCM_CDR (clause
);
1037 const SCM um_exprs
= unmemoize_exprs (exprs
, env
);
1038 const SCM um_labels
= (scm_is_eq (labels
, SCM_IM_ELSE
))
1040 : scm_i_finite_list_copy (labels
);
1041 const SCM um_clause
= scm_cons (um_labels
, um_exprs
);
1043 um_clauses
= scm_cons (um_clause
, um_clauses
);
1045 um_clauses
= scm_reverse_x (um_clauses
, SCM_UNDEFINED
);
1047 return scm_cons2 (scm_sym_case
, um_key_expr
, um_clauses
);
1051 SCM_SYNTAX (s_cond
, "cond", scm_i_makbimacro
, scm_m_cond
);
1052 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
1053 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
1056 scm_m_cond (SCM expr
, SCM env
)
1058 /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
1059 const int else_literal_p
= literal_p (scm_sym_else
, env
);
1060 const int arrow_literal_p
= literal_p (scm_sym_arrow
, env
);
1062 const SCM clauses
= SCM_CDR (expr
);
1065 ASSERT_SYNTAX (scm_ilength (clauses
) >= 0, s_bad_expression
, expr
);
1066 ASSERT_SYNTAX (scm_ilength (clauses
) >= 1, s_missing_clauses
, expr
);
1068 for (clause_idx
= clauses
;
1069 !scm_is_null (clause_idx
);
1070 clause_idx
= SCM_CDR (clause_idx
))
1074 const SCM clause
= SCM_CAR (clause_idx
);
1075 const long length
= scm_ilength (clause
);
1076 ASSERT_SYNTAX_2 (length
>= 1, s_bad_cond_clause
, clause
, expr
);
1078 test
= SCM_CAR (clause
);
1079 if (scm_is_eq (test
, scm_sym_else
) && else_literal_p
)
1081 const int last_clause_p
= scm_is_null (SCM_CDR (clause_idx
));
1082 ASSERT_SYNTAX_2 (length
>= 2,
1083 s_bad_cond_clause
, clause
, expr
);
1084 ASSERT_SYNTAX_2 (last_clause_p
,
1085 s_misplaced_else_clause
, clause
, expr
);
1086 SCM_SETCAR (clause
, SCM_IM_ELSE
);
1088 else if (length
>= 2
1089 && scm_is_eq (SCM_CADR (clause
), scm_sym_arrow
)
1092 ASSERT_SYNTAX_2 (length
> 2, s_missing_recipient
, clause
, expr
);
1093 ASSERT_SYNTAX_2 (length
== 3, s_extra_expression
, clause
, expr
);
1094 SCM_SETCAR (SCM_CDR (clause
), SCM_IM_ARROW
);
1096 /* SRFI 61 extended cond */
1097 else if (length
>= 3
1098 && scm_is_eq (SCM_CADDR (clause
), scm_sym_arrow
)
1101 ASSERT_SYNTAX_2 (length
> 3, s_missing_recipient
, clause
, expr
);
1102 ASSERT_SYNTAX_2 (length
== 4, s_extra_expression
, clause
, expr
);
1103 SCM_SETCAR (SCM_CDDR (clause
), SCM_IM_ARROW
);
1107 SCM_SETCAR (expr
, SCM_IM_COND
);
1112 unmemoize_cond (const SCM expr
, const SCM env
)
1114 SCM um_clauses
= SCM_EOL
;
1117 for (clause_idx
= SCM_CDR (expr
);
1118 !scm_is_null (clause_idx
);
1119 clause_idx
= SCM_CDR (clause_idx
))
1121 const SCM clause
= SCM_CAR (clause_idx
);
1122 const SCM sequence
= SCM_CDR (clause
);
1123 const SCM test
= SCM_CAR (clause
);
1128 if (scm_is_eq (test
, SCM_IM_ELSE
))
1129 um_test
= scm_sym_else
;
1131 um_test
= unmemoize_expression (test
, env
);
1133 if (!scm_is_null (sequence
) && scm_is_eq (SCM_CAR (sequence
),
1136 const SCM target
= SCM_CADR (sequence
);
1137 const SCM um_target
= unmemoize_expression (target
, env
);
1138 um_sequence
= scm_list_2 (scm_sym_arrow
, um_target
);
1142 um_sequence
= unmemoize_exprs (sequence
, env
);
1145 um_clause
= scm_cons (um_test
, um_sequence
);
1146 um_clauses
= scm_cons (um_clause
, um_clauses
);
1148 um_clauses
= scm_reverse_x (um_clauses
, SCM_UNDEFINED
);
1150 return scm_cons (scm_sym_cond
, um_clauses
);
1154 SCM_SYNTAX (s_define
, "define", scm_i_makbimacro
, scm_m_define
);
1155 SCM_GLOBAL_SYMBOL (scm_sym_define
, s_define
);
1157 /* Guile provides an extension to R5RS' define syntax to represent function
1158 * currying in a compact way. With this extension, it is allowed to write
1159 * (define <nested-variable> <body>), where <nested-variable> has of one of
1160 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
1161 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
1162 * should be either a sequence of zero or more variables, or a sequence of one
1163 * or more variables followed by a space-delimited period and another
1164 * variable. Each level of argument nesting wraps the <body> within another
1165 * lambda expression. For example, the following forms are allowed, each one
1166 * followed by an equivalent, more explicit implementation.
1168 * (define ((a b . c) . d) <body>) is equivalent to
1169 * (define a (lambda (b . c) (lambda d <body>)))
1171 * (define (((a) b) c . d) <body>) is equivalent to
1172 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
1174 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
1175 * module that does not implement this extension. */
1177 canonicalize_define (const SCM expr
)
1182 const SCM cdr_expr
= SCM_CDR (expr
);
1183 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1184 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1186 body
= SCM_CDR (cdr_expr
);
1187 variable
= SCM_CAR (cdr_expr
);
1188 while (scm_is_pair (variable
))
1190 /* This while loop realizes function currying by variable nesting.
1191 * Variable is known to be a nested-variable. In every iteration of the
1192 * loop another level of lambda expression is created, starting with the
1193 * innermost one. Note that we don't check for duplicate formals here:
1194 * This will be done by the memoizer of the lambda expression. */
1195 const SCM formals
= SCM_CDR (variable
);
1196 const SCM tail
= scm_cons (formals
, body
);
1198 /* Add source properties to each new lambda expression: */
1199 const SCM lambda
= scm_cons_source (variable
, scm_sym_lambda
, tail
);
1201 body
= scm_list_1 (lambda
);
1202 variable
= SCM_CAR (variable
);
1204 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
1205 ASSERT_SYNTAX (scm_ilength (body
) == 1, s_expression
, expr
);
1207 SCM_SETCAR (cdr_expr
, variable
);
1208 SCM_SETCDR (cdr_expr
, body
);
1212 /* According to section 5.2.1 of R5RS we first have to make sure that the
1213 * variable is bound, and then perform the (set! variable expression)
1214 * operation. This means, that within the expression we may already assign
1215 * values to variable: (define foo (begin (set! foo 1) (+ foo 1))) */
1217 scm_m_define (SCM expr
, SCM env
)
1219 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), s_bad_define
, expr
);
1222 const SCM canonical_definition
= canonicalize_define (expr
);
1223 const SCM cdr_canonical_definition
= SCM_CDR (canonical_definition
);
1224 const SCM variable
= SCM_CAR (cdr_canonical_definition
);
1226 = scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_T
);
1227 const SCM value
= scm_eval_car (SCM_CDR (cdr_canonical_definition
), env
);
1229 if (SCM_REC_PROCNAMES_P
)
1232 while (SCM_MACROP (tmp
))
1233 tmp
= SCM_MACRO_CODE (tmp
);
1234 if (scm_is_true (scm_procedure_p (tmp
))
1235 /* Only the first definition determines the name. */
1236 && scm_is_false (scm_procedure_property (tmp
, scm_sym_name
)))
1237 scm_set_procedure_property_x (tmp
, scm_sym_name
, variable
);
1240 SCM_VARIABLE_SET (location
, value
);
1242 return SCM_UNSPECIFIED
;
1247 /* This is a helper function for forms (<keyword> <expression>) that are
1248 * transformed into (#@<keyword> '() <memoized_expression>) in order to allow
1249 * for easy creation of a thunk (i. e. a closure without arguments) using the
1250 * ('() <memoized_expression>) tail of the memoized form. */
1252 memoize_as_thunk_prototype (const SCM expr
, const SCM env SCM_UNUSED
)
1254 const SCM cdr_expr
= SCM_CDR (expr
);
1255 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1256 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1258 SCM_SETCDR (expr
, scm_cons (SCM_EOL
, cdr_expr
));
1264 SCM_SYNTAX (s_delay
, "delay", scm_i_makbimacro
, scm_m_delay
);
1265 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
1267 /* Promises are implemented as closures with an empty parameter list. Thus,
1268 * (delay <expression>) is transformed into (#@delay '() <expression>), where
1269 * the empty list represents the empty parameter list. This representation
1270 * allows for easy creation of the closure during evaluation. */
1272 scm_m_delay (SCM expr
, SCM env
)
1274 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1275 SCM_SETCAR (new_expr
, SCM_IM_DELAY
);
1280 unmemoize_delay (const SCM expr
, const SCM env
)
1282 const SCM thunk_expr
= SCM_CADDR (expr
);
1283 return scm_list_2 (scm_sym_delay
, unmemoize_expression (thunk_expr
, env
));
1287 SCM_SYNTAX(s_do
, "do", scm_i_makbimacro
, scm_m_do
);
1288 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
1290 /* DO gets the most radically altered syntax. The order of the vars is
1291 * reversed here. During the evaluation this allows for simple consing of the
1292 * results of the inits and steps:
1294 (do ((<var1> <init1> <step1>)
1302 (#@do (<init1> <init2> ... <initn>)
1303 (varn ... var2 var1)
1306 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
1309 scm_m_do (SCM expr
, SCM env SCM_UNUSED
)
1311 SCM variables
= SCM_EOL
;
1312 SCM init_forms
= SCM_EOL
;
1313 SCM step_forms
= SCM_EOL
;
1320 const SCM cdr_expr
= SCM_CDR (expr
);
1321 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1322 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1324 /* Collect variables, init and step forms. */
1325 binding_idx
= SCM_CAR (cdr_expr
);
1326 ASSERT_SYNTAX_2 (scm_ilength (binding_idx
) >= 0,
1327 s_bad_bindings
, binding_idx
, expr
);
1328 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1330 const SCM binding
= SCM_CAR (binding_idx
);
1331 const long length
= scm_ilength (binding
);
1332 ASSERT_SYNTAX_2 (length
== 2 || length
== 3,
1333 s_bad_binding
, binding
, expr
);
1336 const SCM name
= SCM_CAR (binding
);
1337 const SCM init
= SCM_CADR (binding
);
1338 const SCM step
= (length
== 2) ? name
: SCM_CADDR (binding
);
1339 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
1340 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, variables
)),
1341 s_duplicate_binding
, name
, expr
);
1343 variables
= scm_cons (name
, variables
);
1344 init_forms
= scm_cons (init
, init_forms
);
1345 step_forms
= scm_cons (step
, step_forms
);
1348 init_forms
= scm_reverse_x (init_forms
, SCM_UNDEFINED
);
1349 step_forms
= scm_reverse_x (step_forms
, SCM_UNDEFINED
);
1351 /* Memoize the test form and the exit sequence. */
1352 cddr_expr
= SCM_CDR (cdr_expr
);
1353 exit_clause
= SCM_CAR (cddr_expr
);
1354 ASSERT_SYNTAX_2 (scm_ilength (exit_clause
) >= 1,
1355 s_bad_exit_clause
, exit_clause
, expr
);
1357 commands
= SCM_CDR (cddr_expr
);
1358 tail
= scm_cons2 (exit_clause
, commands
, step_forms
);
1359 tail
= scm_cons2 (init_forms
, variables
, tail
);
1360 SCM_SETCAR (expr
, SCM_IM_DO
);
1361 SCM_SETCDR (expr
, tail
);
1366 unmemoize_do (const SCM expr
, const SCM env
)
1368 const SCM cdr_expr
= SCM_CDR (expr
);
1369 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1370 const SCM rnames
= SCM_CAR (cddr_expr
);
1371 const SCM extended_env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
1372 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
1373 const SCM exit_sequence
= SCM_CAR (cdddr_expr
);
1374 const SCM um_exit_sequence
= unmemoize_exprs (exit_sequence
, extended_env
);
1375 const SCM cddddr_expr
= SCM_CDR (cdddr_expr
);
1376 const SCM um_body
= unmemoize_exprs (SCM_CAR (cddddr_expr
), extended_env
);
1378 /* build transformed binding list */
1379 SCM um_names
= scm_reverse (rnames
);
1380 SCM um_inits
= unmemoize_exprs (SCM_CAR (cdr_expr
), env
);
1381 SCM um_steps
= unmemoize_exprs (SCM_CDR (cddddr_expr
), extended_env
);
1382 SCM um_bindings
= SCM_EOL
;
1383 while (!scm_is_null (um_names
))
1385 const SCM name
= SCM_CAR (um_names
);
1386 const SCM init
= SCM_CAR (um_inits
);
1387 SCM step
= SCM_CAR (um_steps
);
1388 step
= scm_is_eq (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
1390 um_bindings
= scm_cons (scm_cons2 (name
, init
, step
), um_bindings
);
1392 um_names
= SCM_CDR (um_names
);
1393 um_inits
= SCM_CDR (um_inits
);
1394 um_steps
= SCM_CDR (um_steps
);
1396 um_bindings
= scm_reverse_x (um_bindings
, SCM_UNDEFINED
);
1398 return scm_cons (scm_sym_do
,
1399 scm_cons2 (um_bindings
, um_exit_sequence
, um_body
));
1403 SCM_SYNTAX (s_if
, "if", scm_i_makbimacro
, scm_m_if
);
1404 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
1407 scm_m_if (SCM expr
, SCM env SCM_UNUSED
)
1409 const SCM cdr_expr
= SCM_CDR (expr
);
1410 const long length
= scm_ilength (cdr_expr
);
1411 ASSERT_SYNTAX (length
== 2 || length
== 3, s_expression
, expr
);
1412 SCM_SETCAR (expr
, SCM_IM_IF
);
1417 unmemoize_if (const SCM expr
, const SCM env
)
1419 const SCM cdr_expr
= SCM_CDR (expr
);
1420 const SCM um_condition
= unmemoize_expression (SCM_CAR (cdr_expr
), env
);
1421 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1422 const SCM um_then
= unmemoize_expression (SCM_CAR (cddr_expr
), env
);
1423 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
1425 if (scm_is_null (cdddr_expr
))
1427 return scm_list_3 (scm_sym_if
, um_condition
, um_then
);
1431 const SCM um_else
= unmemoize_expression (SCM_CAR (cdddr_expr
), env
);
1432 return scm_list_4 (scm_sym_if
, um_condition
, um_then
, um_else
);
1437 SCM_SYNTAX (s_lambda
, "lambda", scm_i_makbimacro
, scm_m_lambda
);
1438 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
1440 /* A helper function for memoize_lambda to support checking for duplicate
1441 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
1442 * LIST or to the cdr of the last cons. Therefore, LIST may have any of the
1443 * forms that a formal argument can have:
1444 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
1446 c_improper_memq (SCM obj
, SCM list
)
1448 for (; scm_is_pair (list
); list
= SCM_CDR (list
))
1450 if (scm_is_eq (SCM_CAR (list
), obj
))
1453 return scm_is_eq (list
, obj
);
1457 scm_m_lambda (SCM expr
, SCM env SCM_UNUSED
)
1466 const SCM cdr_expr
= SCM_CDR (expr
);
1467 const long length
= scm_ilength (cdr_expr
);
1468 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1469 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1471 /* Before iterating the list of formal arguments, make sure the formals
1472 * actually are given as either a symbol or a non-cyclic list. */
1473 formals
= SCM_CAR (cdr_expr
);
1474 if (scm_is_pair (formals
))
1476 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
1477 * detected, report a 'Bad formals' error. */
1481 ASSERT_SYNTAX_2 (scm_is_symbol (formals
) || scm_is_null (formals
),
1482 s_bad_formals
, formals
, expr
);
1485 /* Now iterate the list of formal arguments to check if all formals are
1486 * symbols, and that there are no duplicates. */
1487 formals_idx
= formals
;
1488 while (scm_is_pair (formals_idx
))
1490 const SCM formal
= SCM_CAR (formals_idx
);
1491 const SCM next_idx
= SCM_CDR (formals_idx
);
1492 ASSERT_SYNTAX_2 (scm_is_symbol (formal
), s_bad_formal
, formal
, expr
);
1493 ASSERT_SYNTAX_2 (!c_improper_memq (formal
, next_idx
),
1494 s_duplicate_formal
, formal
, expr
);
1495 formals_idx
= next_idx
;
1497 ASSERT_SYNTAX_2 (scm_is_null (formals_idx
) || scm_is_symbol (formals_idx
),
1498 s_bad_formal
, formals_idx
, expr
);
1500 /* Memoize the body. Keep a potential documentation string. */
1501 /* Dirk:FIXME:: We should probably extract the documentation string to
1502 * some external database. Otherwise it will slow down execution, since
1503 * the documentation string will have to be skipped with every execution
1504 * of the closure. */
1505 cddr_expr
= SCM_CDR (cdr_expr
);
1506 documentation
= (length
>= 3 && scm_is_string (SCM_CAR (cddr_expr
)));
1507 body
= documentation
? SCM_CDR (cddr_expr
) : cddr_expr
;
1508 new_body
= m_body (SCM_IM_LAMBDA
, body
);
1510 SCM_SETCAR (expr
, SCM_IM_LAMBDA
);
1512 SCM_SETCDR (cddr_expr
, new_body
);
1514 SCM_SETCDR (cdr_expr
, new_body
);
1519 unmemoize_lambda (const SCM expr
, const SCM env
)
1521 const SCM formals
= SCM_CADR (expr
);
1522 const SCM body
= SCM_CDDR (expr
);
1524 const SCM new_env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, env
);
1525 const SCM um_formals
= scm_i_finite_list_copy (formals
);
1526 const SCM um_body
= unmemoize_exprs (body
, new_env
);
1528 return scm_cons2 (scm_sym_lambda
, um_formals
, um_body
);
1532 /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
1534 check_bindings (const SCM bindings
, const SCM expr
)
1538 ASSERT_SYNTAX_2 (scm_ilength (bindings
) >= 0,
1539 s_bad_bindings
, bindings
, expr
);
1541 binding_idx
= bindings
;
1542 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1544 SCM name
; /* const */
1546 const SCM binding
= SCM_CAR (binding_idx
);
1547 ASSERT_SYNTAX_2 (scm_ilength (binding
) == 2,
1548 s_bad_binding
, binding
, expr
);
1550 name
= SCM_CAR (binding
);
1551 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
1556 /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
1557 * transformed to the lists (vn ... v2 v1) and (i1 i2 ... in). That is, the
1558 * variables are returned in a list with their order reversed, and the init
1559 * forms are returned in a list in the same order as they are given in the
1560 * bindings. If a duplicate variable name is detected, an error is
1563 transform_bindings (
1564 const SCM bindings
, const SCM expr
,
1565 SCM
*const rvarptr
, SCM
*const initptr
)
1567 SCM rvariables
= SCM_EOL
;
1568 SCM rinits
= SCM_EOL
;
1569 SCM binding_idx
= bindings
;
1570 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1572 const SCM binding
= SCM_CAR (binding_idx
);
1573 const SCM cdr_binding
= SCM_CDR (binding
);
1574 const SCM name
= SCM_CAR (binding
);
1575 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, rvariables
)),
1576 s_duplicate_binding
, name
, expr
);
1577 rvariables
= scm_cons (name
, rvariables
);
1578 rinits
= scm_cons (SCM_CAR (cdr_binding
), rinits
);
1580 *rvarptr
= rvariables
;
1581 *initptr
= scm_reverse_x (rinits
, SCM_UNDEFINED
);
1585 SCM_SYNTAX(s_let
, "let", scm_i_makbimacro
, scm_m_let
);
1586 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
1588 /* This function is a helper function for memoize_let. It transforms
1589 * (let name ((var init) ...) body ...) into
1590 * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
1591 * and memoizes the expression. It is assumed that the caller has checked
1592 * that name is a symbol and that there are bindings and a body. */
1594 memoize_named_let (const SCM expr
, const SCM env SCM_UNUSED
)
1600 const SCM cdr_expr
= SCM_CDR (expr
);
1601 const SCM name
= SCM_CAR (cdr_expr
);
1602 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1603 const SCM bindings
= SCM_CAR (cddr_expr
);
1604 check_bindings (bindings
, expr
);
1606 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1607 variables
= scm_reverse_x (rvariables
, SCM_UNDEFINED
);
1610 const SCM let_body
= SCM_CDR (cddr_expr
);
1611 const SCM lambda_body
= m_body (SCM_IM_LET
, let_body
);
1612 const SCM lambda_tail
= scm_cons (variables
, lambda_body
);
1613 const SCM lambda_form
= scm_cons_source (expr
, scm_sym_lambda
, lambda_tail
);
1615 const SCM rvar
= scm_list_1 (name
);
1616 const SCM init
= scm_list_1 (lambda_form
);
1617 const SCM body
= m_body (SCM_IM_LET
, scm_list_1 (name
));
1618 const SCM letrec_tail
= scm_cons (rvar
, scm_cons (init
, body
));
1619 const SCM letrec_form
= scm_cons_source (expr
, SCM_IM_LETREC
, letrec_tail
);
1620 return scm_cons_source (expr
, letrec_form
, inits
);
1624 /* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1625 * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
1627 scm_m_let (SCM expr
, SCM env
)
1631 const SCM cdr_expr
= SCM_CDR (expr
);
1632 const long length
= scm_ilength (cdr_expr
);
1633 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1634 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1636 bindings
= SCM_CAR (cdr_expr
);
1637 if (scm_is_symbol (bindings
))
1639 ASSERT_SYNTAX (length
>= 3, s_missing_expression
, expr
);
1640 return memoize_named_let (expr
, env
);
1643 check_bindings (bindings
, expr
);
1644 if (scm_is_null (bindings
) || scm_is_null (SCM_CDR (bindings
)))
1646 /* Special case: no bindings or single binding => let* is faster. */
1647 const SCM body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1648 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), bindings
, body
), env
);
1655 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1658 const SCM new_body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1659 const SCM new_tail
= scm_cons2 (rvariables
, inits
, new_body
);
1660 SCM_SETCAR (expr
, SCM_IM_LET
);
1661 SCM_SETCDR (expr
, new_tail
);
1668 build_binding_list (SCM rnames
, SCM rinits
)
1670 SCM bindings
= SCM_EOL
;
1671 while (!scm_is_null (rnames
))
1673 const SCM binding
= scm_list_2 (SCM_CAR (rnames
), SCM_CAR (rinits
));
1674 bindings
= scm_cons (binding
, bindings
);
1675 rnames
= SCM_CDR (rnames
);
1676 rinits
= SCM_CDR (rinits
);
1682 unmemoize_let (const SCM expr
, const SCM env
)
1684 const SCM cdr_expr
= SCM_CDR (expr
);
1685 const SCM um_rnames
= SCM_CAR (cdr_expr
);
1686 const SCM extended_env
= SCM_EXTEND_ENV (um_rnames
, SCM_EOL
, env
);
1687 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1688 const SCM um_inits
= unmemoize_exprs (SCM_CAR (cddr_expr
), env
);
1689 const SCM um_rinits
= scm_reverse_x (um_inits
, SCM_UNDEFINED
);
1690 const SCM um_bindings
= build_binding_list (um_rnames
, um_rinits
);
1691 const SCM um_body
= unmemoize_exprs (SCM_CDR (cddr_expr
), extended_env
);
1693 return scm_cons2 (scm_sym_let
, um_bindings
, um_body
);
1697 SCM_SYNTAX(s_letrec
, "letrec", scm_i_makbimacro
, scm_m_letrec
);
1698 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
1701 scm_m_letrec (SCM expr
, SCM env
)
1705 const SCM cdr_expr
= SCM_CDR (expr
);
1706 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1707 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1709 bindings
= SCM_CAR (cdr_expr
);
1710 if (scm_is_null (bindings
))
1712 /* no bindings, let* is executed faster */
1713 SCM body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1714 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), SCM_EOL
, body
), env
);
1722 check_bindings (bindings
, expr
);
1723 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1724 new_body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1725 return scm_cons2 (SCM_IM_LETREC
, rvariables
, scm_cons (inits
, new_body
));
1730 unmemoize_letrec (const SCM expr
, const SCM env
)
1732 const SCM cdr_expr
= SCM_CDR (expr
);
1733 const SCM um_rnames
= SCM_CAR (cdr_expr
);
1734 const SCM extended_env
= SCM_EXTEND_ENV (um_rnames
, SCM_EOL
, env
);
1735 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1736 const SCM um_inits
= unmemoize_exprs (SCM_CAR (cddr_expr
), extended_env
);
1737 const SCM um_rinits
= scm_reverse_x (um_inits
, SCM_UNDEFINED
);
1738 const SCM um_bindings
= build_binding_list (um_rnames
, um_rinits
);
1739 const SCM um_body
= unmemoize_exprs (SCM_CDR (cddr_expr
), extended_env
);
1741 return scm_cons2 (scm_sym_letrec
, um_bindings
, um_body
);
1746 SCM_SYNTAX (s_letstar
, "let*", scm_i_makbimacro
, scm_m_letstar
);
1747 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
1749 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1750 * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
1752 scm_m_letstar (SCM expr
, SCM env SCM_UNUSED
)
1757 const SCM cdr_expr
= SCM_CDR (expr
);
1758 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1759 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1761 binding_idx
= SCM_CAR (cdr_expr
);
1762 check_bindings (binding_idx
, expr
);
1764 /* Transform ((v1 i1) (v2 i2) ...) into (v1 i1 v2 i2 ...). The
1765 * transformation is done in place. At the beginning of one iteration of
1766 * the loop the variable binding_idx holds the form
1767 * P1:( (vn . P2:(in . ())) . P3:( (vn+1 in+1) ... ) ),
1768 * where P1, P2 and P3 indicate the pairs, that are relevant for the
1769 * transformation. P1 and P2 are modified in the loop, P3 remains
1770 * untouched. After the execution of the loop, P1 will hold
1771 * P1:( vn . P2:(in . P3:( (vn+1 in+1) ... )) )
1772 * and binding_idx will hold P3. */
1773 while (!scm_is_null (binding_idx
))
1775 const SCM cdr_binding_idx
= SCM_CDR (binding_idx
); /* remember P3 */
1776 const SCM binding
= SCM_CAR (binding_idx
);
1777 const SCM name
= SCM_CAR (binding
);
1778 const SCM cdr_binding
= SCM_CDR (binding
);
1780 SCM_SETCDR (cdr_binding
, cdr_binding_idx
); /* update P2 */
1781 SCM_SETCAR (binding_idx
, name
); /* update P1 */
1782 SCM_SETCDR (binding_idx
, cdr_binding
); /* update P1 */
1784 binding_idx
= cdr_binding_idx
; /* continue with P3 */
1787 new_body
= m_body (SCM_IM_LETSTAR
, SCM_CDR (cdr_expr
));
1788 SCM_SETCAR (expr
, SCM_IM_LETSTAR
);
1789 /* the bindings have been changed in place */
1790 SCM_SETCDR (cdr_expr
, new_body
);
1795 unmemoize_letstar (const SCM expr
, const SCM env
)
1797 const SCM cdr_expr
= SCM_CDR (expr
);
1798 const SCM body
= SCM_CDR (cdr_expr
);
1799 SCM bindings
= SCM_CAR (cdr_expr
);
1800 SCM um_bindings
= SCM_EOL
;
1801 SCM extended_env
= env
;
1804 while (!scm_is_null (bindings
))
1806 const SCM variable
= SCM_CAR (bindings
);
1807 const SCM init
= SCM_CADR (bindings
);
1808 const SCM um_init
= unmemoize_expression (init
, extended_env
);
1809 um_bindings
= scm_cons (scm_list_2 (variable
, um_init
), um_bindings
);
1810 extended_env
= SCM_EXTEND_ENV (variable
, SCM_BOOL_F
, extended_env
);
1811 bindings
= SCM_CDDR (bindings
);
1813 um_bindings
= scm_reverse_x (um_bindings
, SCM_UNDEFINED
);
1815 um_body
= unmemoize_exprs (body
, extended_env
);
1817 return scm_cons2 (scm_sym_letstar
, um_bindings
, um_body
);
1821 SCM_SYNTAX (s_or
, "or", scm_i_makbimacro
, scm_m_or
);
1822 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
1825 scm_m_or (SCM expr
, SCM env SCM_UNUSED
)
1827 const SCM cdr_expr
= SCM_CDR (expr
);
1828 const long length
= scm_ilength (cdr_expr
);
1830 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1834 /* Special case: (or) is replaced by #f. */
1839 SCM_SETCAR (expr
, SCM_IM_OR
);
1845 unmemoize_or (const SCM expr
, const SCM env
)
1847 return scm_cons (scm_sym_or
, unmemoize_exprs (SCM_CDR (expr
), env
));
1851 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
1852 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
1853 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
1854 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
1856 /* Internal function to handle a quasiquotation: 'form' is the parameter in
1857 * the call (quasiquotation form), 'env' is the environment where unquoted
1858 * expressions will be evaluated, and 'depth' is the current quasiquotation
1859 * nesting level and is known to be greater than zero. */
1861 iqq (SCM form
, SCM env
, unsigned long int depth
)
1863 if (scm_is_pair (form
))
1865 const SCM tmp
= SCM_CAR (form
);
1866 if (scm_is_eq (tmp
, scm_sym_quasiquote
))
1868 const SCM args
= SCM_CDR (form
);
1869 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1870 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
1872 else if (scm_is_eq (tmp
, scm_sym_unquote
))
1874 const SCM args
= SCM_CDR (form
);
1875 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1877 return scm_eval_car (args
, env
);
1879 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
1881 else if (scm_is_pair (tmp
)
1882 && scm_is_eq (SCM_CAR (tmp
), scm_sym_uq_splicing
))
1884 const SCM args
= SCM_CDR (tmp
);
1885 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1888 const SCM list
= scm_eval_car (args
, env
);
1889 const SCM rest
= SCM_CDR (form
);
1890 ASSERT_SYNTAX_2 (scm_ilength (list
) >= 0,
1891 s_splicing
, list
, form
);
1892 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
1895 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
1896 iqq (SCM_CDR (form
), env
, depth
));
1899 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
1900 iqq (SCM_CDR (form
), env
, depth
));
1902 else if (scm_is_vector (form
))
1903 return scm_vector (iqq (scm_vector_to_list (form
), env
, depth
));
1909 scm_m_quasiquote (SCM expr
, SCM env
)
1911 const SCM cdr_expr
= SCM_CDR (expr
);
1912 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1913 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1914 return iqq (SCM_CAR (cdr_expr
), env
, 1);
1918 SCM_SYNTAX (s_quote
, "quote", scm_i_makbimacro
, scm_m_quote
);
1919 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
1922 scm_m_quote (SCM expr
, SCM env SCM_UNUSED
)
1926 const SCM cdr_expr
= SCM_CDR (expr
);
1927 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1928 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1929 quotee
= SCM_CAR (cdr_expr
);
1930 if (is_self_quoting_p (quotee
))
1933 SCM_SETCAR (expr
, SCM_IM_QUOTE
);
1934 SCM_SETCDR (expr
, quotee
);
1939 unmemoize_quote (const SCM expr
, const SCM env SCM_UNUSED
)
1941 return scm_list_2 (scm_sym_quote
, SCM_CDR (expr
));
1945 /* Will go into the RnRS module when Guile is factorized.
1946 SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
1947 static const char s_set_x
[] = "set!";
1948 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, s_set_x
);
1951 scm_m_set_x (SCM expr
, SCM env SCM_UNUSED
)
1956 const SCM cdr_expr
= SCM_CDR (expr
);
1957 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1958 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1959 variable
= SCM_CAR (cdr_expr
);
1961 /* Memoize the variable form. */
1962 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
1963 new_variable
= lookup_symbol (variable
, env
);
1964 /* Leave the memoization of unbound symbols to lazy memoization: */
1965 if (SCM_UNBNDP (new_variable
))
1966 new_variable
= variable
;
1968 SCM_SETCAR (expr
, SCM_IM_SET_X
);
1969 SCM_SETCAR (cdr_expr
, new_variable
);
1974 unmemoize_set_x (const SCM expr
, const SCM env
)
1976 return scm_cons (scm_sym_set_x
, unmemoize_exprs (SCM_CDR (expr
), env
));
1980 /* Start of the memoizers for non-R5RS builtin macros. */
1983 SCM_SYNTAX (s_atapply
, "@apply", scm_i_makbimacro
, scm_m_apply
);
1984 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1985 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1988 scm_m_apply (SCM expr
, SCM env SCM_UNUSED
)
1990 const SCM cdr_expr
= SCM_CDR (expr
);
1991 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1992 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_missing_expression
, expr
);
1994 SCM_SETCAR (expr
, SCM_IM_APPLY
);
1999 unmemoize_apply (const SCM expr
, const SCM env
)
2001 return scm_list_2 (scm_sym_atapply
, unmemoize_exprs (SCM_CDR (expr
), env
));
2005 SCM_SYNTAX (s_atbind
, "@bind", scm_i_makbimacro
, scm_m_atbind
);
2007 /* FIXME: The following explanation should go into the documentation: */
2008 /* (@bind ((var init) ...) body ...) will assign the values of the `init's to
2009 * the global variables named by `var's (symbols, not evaluated), creating
2010 * them if they don't exist, executes body, and then restores the previous
2011 * values of the `var's. Additionally, whenever control leaves body, the
2012 * values of the `var's are saved and restored when control returns. It is an
2013 * error when a symbol appears more than once among the `var's. All `init's
2014 * are evaluated before any `var' is set.
2016 * Think of this as `let' for dynamic scope.
2019 /* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into
2020 * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...).
2022 * FIXME - also implement `@bind*'.
2025 scm_m_atbind (SCM expr
, SCM env
)
2032 const SCM top_level
= scm_env_top_level (env
);
2034 const SCM cdr_expr
= SCM_CDR (expr
);
2035 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2036 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
2037 bindings
= SCM_CAR (cdr_expr
);
2038 check_bindings (bindings
, expr
);
2039 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
2041 for (variable_idx
= rvariables
;
2042 !scm_is_null (variable_idx
);
2043 variable_idx
= SCM_CDR (variable_idx
))
2045 /* The first call to scm_sym2var will look beyond the current module,
2046 * while the second call wont. */
2047 const SCM variable
= SCM_CAR (variable_idx
);
2048 SCM new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_F
);
2049 if (scm_is_false (new_variable
))
2050 new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_T
);
2051 SCM_SETCAR (variable_idx
, new_variable
);
2054 SCM_SETCAR (expr
, SCM_IM_BIND
);
2055 SCM_SETCAR (cdr_expr
, scm_cons (rvariables
, inits
));
2060 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_i_makbimacro
, scm_m_cont
);
2061 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, s_atcall_cc
);
2064 scm_m_cont (SCM expr
, SCM env SCM_UNUSED
)
2066 const SCM cdr_expr
= SCM_CDR (expr
);
2067 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2068 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2070 SCM_SETCAR (expr
, SCM_IM_CONT
);
2075 unmemoize_atcall_cc (const SCM expr
, const SCM env
)
2077 return scm_list_2 (scm_sym_atcall_cc
, unmemoize_exprs (SCM_CDR (expr
), env
));
2081 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_i_makbimacro
, scm_m_at_call_with_values
);
2082 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
2085 scm_m_at_call_with_values (SCM expr
, SCM env SCM_UNUSED
)
2087 const SCM cdr_expr
= SCM_CDR (expr
);
2088 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2089 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2091 SCM_SETCAR (expr
, SCM_IM_CALL_WITH_VALUES
);
2096 unmemoize_at_call_with_values (const SCM expr
, const SCM env
)
2098 return scm_list_2 (scm_sym_at_call_with_values
,
2099 unmemoize_exprs (SCM_CDR (expr
), env
));
2104 /* See futures.h for a comment why futures are not enabled.
2107 SCM_SYNTAX (s_future
, "future", scm_i_makbimacro
, scm_m_future
);
2108 SCM_GLOBAL_SYMBOL (scm_sym_future
, s_future
);
2110 /* Like promises, futures are implemented as closures with an empty
2111 * parameter list. Thus, (future <expression>) is transformed into
2112 * (#@future '() <expression>), where the empty list represents the
2113 * empty parameter list. This representation allows for easy creation
2114 * of the closure during evaluation. */
2116 scm_m_future (SCM expr
, SCM env
)
2118 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
2119 SCM_SETCAR (new_expr
, SCM_IM_FUTURE
);
2124 unmemoize_future (const SCM expr
, const SCM env
)
2126 const SCM thunk_expr
= SCM_CADDR (expr
);
2127 return scm_list_2 (scm_sym_future
, unmemoize_expression (thunk_expr
, env
));
2132 SCM_SYNTAX (s_gset_x
, "set!", scm_i_makbimacro
, scm_m_generalized_set_x
);
2133 SCM_SYMBOL (scm_sym_setter
, "setter");
2136 scm_m_generalized_set_x (SCM expr
, SCM env
)
2138 SCM target
, exp_target
;
2140 const SCM cdr_expr
= SCM_CDR (expr
);
2141 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2142 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2144 target
= SCM_CAR (cdr_expr
);
2145 if (!scm_is_pair (target
))
2148 return scm_m_set_x (expr
, env
);
2152 /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */
2153 /* Macroexpanding the target might return things of the form
2154 (begin <atom>). In that case, <atom> must be a symbol or a
2155 variable and we memoize to (set! <atom> ...).
2157 exp_target
= macroexp (target
, env
);
2158 if (scm_is_eq (SCM_CAR (exp_target
), SCM_IM_BEGIN
)
2159 && !scm_is_null (SCM_CDR (exp_target
))
2160 && scm_is_null (SCM_CDDR (exp_target
)))
2162 exp_target
= SCM_CADR (exp_target
);
2163 ASSERT_SYNTAX_2 (scm_is_symbol (exp_target
)
2164 || SCM_VARIABLEP (exp_target
),
2165 s_bad_variable
, exp_target
, expr
);
2166 return scm_cons (SCM_IM_SET_X
, scm_cons (exp_target
,
2167 SCM_CDR (cdr_expr
)));
2171 const SCM setter_proc_tail
= scm_list_1 (SCM_CAR (target
));
2172 const SCM setter_proc
= scm_cons_source (expr
, scm_sym_setter
,
2175 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
2176 const SCM setter_args
= scm_append_x (scm_list_2 (SCM_CDR (target
),
2179 SCM_SETCAR (expr
, setter_proc
);
2180 SCM_SETCDR (expr
, setter_args
);
2187 /* @slot-ref is bound privately in the (oop goops) module from goops.c. As
2188 * soon as the module system allows us to more freely create bindings in
2189 * arbitrary modules during the startup phase, the code from goops.c should be
2192 SCM_SYMBOL (sym_atslot_ref
, "@slot-ref");
2195 scm_m_atslot_ref (SCM expr
, SCM env SCM_UNUSED
)
2199 const SCM cdr_expr
= SCM_CDR (expr
);
2200 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2201 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2202 slot_nr
= SCM_CADR (cdr_expr
);
2203 ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2205 SCM_SETCAR (expr
, SCM_IM_SLOT_REF
);
2206 SCM_SETCDR (cdr_expr
, slot_nr
);
2211 unmemoize_atslot_ref (const SCM expr
, const SCM env
)
2213 const SCM instance
= SCM_CADR (expr
);
2214 const SCM um_instance
= unmemoize_expression (instance
, env
);
2215 const SCM slot_nr
= SCM_CDDR (expr
);
2216 return scm_list_3 (sym_atslot_ref
, um_instance
, slot_nr
);
2220 /* @slot-set! is bound privately in the (oop goops) module from goops.c. As
2221 * soon as the module system allows us to more freely create bindings in
2222 * arbitrary modules during the startup phase, the code from goops.c should be
2225 SCM_SYMBOL (sym_atslot_set_x
, "@slot-set!");
2228 scm_m_atslot_set_x (SCM expr
, SCM env SCM_UNUSED
)
2232 const SCM cdr_expr
= SCM_CDR (expr
);
2233 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2234 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 3, s_expression
, expr
);
2235 slot_nr
= SCM_CADR (cdr_expr
);
2236 ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2238 SCM_SETCAR (expr
, SCM_IM_SLOT_SET_X
);
2243 unmemoize_atslot_set_x (const SCM expr
, const SCM env
)
2245 const SCM cdr_expr
= SCM_CDR (expr
);
2246 const SCM instance
= SCM_CAR (cdr_expr
);
2247 const SCM um_instance
= unmemoize_expression (instance
, env
);
2248 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
2249 const SCM slot_nr
= SCM_CAR (cddr_expr
);
2250 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
2251 const SCM value
= SCM_CAR (cdddr_expr
);
2252 const SCM um_value
= unmemoize_expression (value
, env
);
2253 return scm_list_4 (sym_atslot_set_x
, um_instance
, slot_nr
, um_value
);
2257 #if SCM_ENABLE_ELISP
2259 static const char s_defun
[] = "Symbol's function definition is void";
2261 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_i_makbimacro
, scm_m_nil_cond
);
2263 /* nil-cond expressions have the form
2264 * (nil-cond COND VAL COND VAL ... ELSEVAL) */
2266 scm_m_nil_cond (SCM expr
, SCM env SCM_UNUSED
)
2268 const long length
= scm_ilength (SCM_CDR (expr
));
2269 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
2270 ASSERT_SYNTAX (length
>= 1 && (length
% 2) == 1, s_expression
, expr
);
2272 SCM_SETCAR (expr
, SCM_IM_NIL_COND
);
2277 SCM_SYNTAX (s_atfop
, "@fop", scm_i_makbimacro
, scm_m_atfop
);
2279 /* The @fop-macro handles procedure and macro applications for elisp. The
2280 * input expression must have the form
2281 * (@fop <var> (transformer-macro <expr> ...))
2282 * where <var> must be a symbol. The expression is transformed into the
2283 * memoized form of either
2284 * (apply <un-aliased var> (transformer-macro <expr> ...))
2285 * if the value of var (across all aliasing) is not a macro, or
2286 * (<un-aliased var> <expr> ...)
2287 * if var is a macro. */
2289 scm_m_atfop (SCM expr
, SCM env SCM_UNUSED
)
2294 const SCM cdr_expr
= SCM_CDR (expr
);
2295 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2296 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 1, s_missing_expression
, expr
);
2298 symbol
= SCM_CAR (cdr_expr
);
2299 ASSERT_SYNTAX_2 (scm_is_symbol (symbol
), s_bad_variable
, symbol
, expr
);
2301 location
= scm_symbol_fref (symbol
);
2302 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2304 /* The elisp function `defalias' allows to define aliases for symbols. To
2305 * look up such definitions, the chain of symbol definitions has to be
2306 * followed up to the terminal symbol. */
2307 while (scm_is_symbol (SCM_VARIABLE_REF (location
)))
2309 const SCM alias
= SCM_VARIABLE_REF (location
);
2310 location
= scm_symbol_fref (alias
);
2311 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2314 /* Memoize the value location belonging to the terminal symbol. */
2315 SCM_SETCAR (cdr_expr
, location
);
2317 if (!SCM_MACROP (SCM_VARIABLE_REF (location
)))
2319 /* Since the location does not contain a macro, the form is a procedure
2320 * application. Replace `@fop' by `@apply' and transform the expression
2321 * including the `transformer-macro'. */
2322 SCM_SETCAR (expr
, SCM_IM_APPLY
);
2327 /* Since the location contains a macro, the arguments should not be
2328 * transformed, so the `transformer-macro' is cut out. The resulting
2329 * expression starts with the memoized variable, that is at the cdr of
2330 * the input expression. */
2331 SCM_SETCDR (cdr_expr
, SCM_CDADR (cdr_expr
));
2336 #endif /* SCM_ENABLE_ELISP */
2340 unmemoize_builtin_macro (const SCM expr
, const SCM env
)
2342 switch (ISYMNUM (SCM_CAR (expr
)))
2344 case (ISYMNUM (SCM_IM_AND
)):
2345 return unmemoize_and (expr
, env
);
2347 case (ISYMNUM (SCM_IM_BEGIN
)):
2348 return unmemoize_begin (expr
, env
);
2350 case (ISYMNUM (SCM_IM_CASE
)):
2351 return unmemoize_case (expr
, env
);
2353 case (ISYMNUM (SCM_IM_COND
)):
2354 return unmemoize_cond (expr
, env
);
2356 case (ISYMNUM (SCM_IM_DELAY
)):
2357 return unmemoize_delay (expr
, env
);
2359 case (ISYMNUM (SCM_IM_DO
)):
2360 return unmemoize_do (expr
, env
);
2362 case (ISYMNUM (SCM_IM_IF
)):
2363 return unmemoize_if (expr
, env
);
2365 case (ISYMNUM (SCM_IM_LAMBDA
)):
2366 return unmemoize_lambda (expr
, env
);
2368 case (ISYMNUM (SCM_IM_LET
)):
2369 return unmemoize_let (expr
, env
);
2371 case (ISYMNUM (SCM_IM_LETREC
)):
2372 return unmemoize_letrec (expr
, env
);
2374 case (ISYMNUM (SCM_IM_LETSTAR
)):
2375 return unmemoize_letstar (expr
, env
);
2377 case (ISYMNUM (SCM_IM_OR
)):
2378 return unmemoize_or (expr
, env
);
2380 case (ISYMNUM (SCM_IM_QUOTE
)):
2381 return unmemoize_quote (expr
, env
);
2383 case (ISYMNUM (SCM_IM_SET_X
)):
2384 return unmemoize_set_x (expr
, env
);
2386 case (ISYMNUM (SCM_IM_APPLY
)):
2387 return unmemoize_apply (expr
, env
);
2389 case (ISYMNUM (SCM_IM_BIND
)):
2390 return unmemoize_exprs (expr
, env
); /* FIXME */
2392 case (ISYMNUM (SCM_IM_CONT
)):
2393 return unmemoize_atcall_cc (expr
, env
);
2395 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2396 return unmemoize_at_call_with_values (expr
, env
);
2399 /* See futures.h for a comment why futures are not enabled.
2401 case (ISYMNUM (SCM_IM_FUTURE
)):
2402 return unmemoize_future (expr
, env
);
2405 case (ISYMNUM (SCM_IM_SLOT_REF
)):
2406 return unmemoize_atslot_ref (expr
, env
);
2408 case (ISYMNUM (SCM_IM_SLOT_SET_X
)):
2409 return unmemoize_atslot_set_x (expr
, env
);
2411 case (ISYMNUM (SCM_IM_NIL_COND
)):
2412 return unmemoize_exprs (expr
, env
); /* FIXME */
2415 return unmemoize_exprs (expr
, env
); /* FIXME */
2420 /* scm_i_unmemocopy_expr and scm_i_unmemocopy_body take a memoized expression
2421 * respectively a memoized body together with its environment and rewrite it
2422 * to its original form. Thus, these functions are the inversion of the
2423 * rewrite rules above. The procedure is not optimized for speed. It's used
2424 * in scm_i_unmemoize_expr, scm_procedure_source, macro_print and scm_iprin1.
2426 * Unmemoizing is not a reliable process. You cannot in general expect to get
2427 * the original source back.
2429 * However, GOOPS currently relies on this for method compilation. This ought
2433 scm_i_unmemocopy_expr (SCM expr
, SCM env
)
2435 const SCM source_properties
= scm_whash_lookup (scm_source_whash
, expr
);
2436 const SCM um_expr
= unmemoize_expression (expr
, env
);
2438 if (scm_is_true (source_properties
))
2439 scm_whash_insert (scm_source_whash
, um_expr
, source_properties
);
2445 scm_i_unmemocopy_body (SCM forms
, SCM env
)
2447 const SCM source_properties
= scm_whash_lookup (scm_source_whash
, forms
);
2448 const SCM um_forms
= unmemoize_exprs (forms
, env
);
2450 if (scm_is_true (source_properties
))
2451 scm_whash_insert (scm_source_whash
, um_forms
, source_properties
);
2457 #if (SCM_ENABLE_DEPRECATED == 1)
2459 /* Deprecated in guile 1.7.0 on 2003-11-09. */
2461 scm_m_expand_body (SCM exprs
, SCM env
)
2463 scm_c_issue_deprecation_warning
2464 ("`scm_m_expand_body' is deprecated.");
2465 m_expand_body (exprs
, env
);
2470 SCM_SYNTAX (s_undefine
, "undefine", scm_makacro
, scm_m_undefine
);
2473 scm_m_undefine (SCM expr
, SCM env
)
2478 const SCM cdr_expr
= SCM_CDR (expr
);
2479 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), "Bad undefine placement in", expr
);
2480 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2481 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2483 scm_c_issue_deprecation_warning
2484 ("`undefine' is deprecated.\n");
2486 variable
= SCM_CAR (cdr_expr
);
2487 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
2488 location
= scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_F
);
2489 ASSERT_SYNTAX_2 (scm_is_true (location
)
2490 && !SCM_UNBNDP (SCM_VARIABLE_REF (location
)),
2491 "variable already unbound ", variable
, expr
);
2492 SCM_VARIABLE_SET (location
, SCM_UNDEFINED
);
2493 return SCM_UNSPECIFIED
;
2497 scm_macroexp (SCM x
, SCM env
)
2499 scm_c_issue_deprecation_warning
2500 ("`scm_macroexp' is deprecated.");
2501 return macroexp (x
, env
);
2507 #if (SCM_ENABLE_DEPRECATED == 1)
2510 scm_unmemocar (SCM form
, SCM env
)
2512 scm_c_issue_deprecation_warning
2513 ("`scm_unmemocar' is deprecated.");
2515 if (!scm_is_pair (form
))
2519 SCM c
= SCM_CAR (form
);
2520 if (SCM_VARIABLEP (c
))
2522 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
2523 if (scm_is_false (sym
))
2524 sym
= sym_three_question_marks
;
2525 SCM_SETCAR (form
, sym
);
2527 else if (SCM_ILOCP (c
))
2529 unsigned long int ir
;
2531 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
2532 env
= SCM_CDR (env
);
2533 env
= SCM_CAAR (env
);
2534 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
2535 env
= SCM_CDR (env
);
2537 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
2545 /*****************************************************************************/
2546 /*****************************************************************************/
2547 /* The definitions for execution start here. */
2548 /*****************************************************************************/
2549 /*****************************************************************************/
2551 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
2552 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
2553 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
2554 SCM_GLOBAL_SYMBOL (scm_sym_memoize_symbol
, "memoize-symbol");
2555 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
2556 SCM_SYMBOL (sym_instead
, "instead");
2558 /* A function object to implement "apply" for non-closure functions. */
2560 /* An endless list consisting of #<undefined> objects: */
2561 static SCM undefineds
;
2565 scm_badargsp (SCM formals
, SCM args
)
2567 while (!scm_is_null (formals
))
2569 if (!scm_is_pair (formals
))
2571 if (scm_is_null (args
))
2573 formals
= SCM_CDR (formals
);
2574 args
= SCM_CDR (args
);
2576 return !scm_is_null (args
) ? 1 : 0;
2581 /* The evaluator contains a plethora of EVAL symbols.
2584 * SCM_I_EVALIM is used when it is known that the expression is an
2585 * immediate. (This macro never calls an evaluator.)
2587 * SCM_I_XEVAL evaluates an expression that is expected to have its symbols already
2588 * memoized. Expressions that are not of the form '(<form> <form> ...)' are
2589 * evaluated inline without calling an evaluator.
2591 * This macro uses ceval or deval depending on its 3rd argument.
2593 * SCM_I_XEVALCAR evaluates the car of an expression 'X:(Y:<form> <form> ...)',
2594 * potentially replacing a symbol at the position Y:<form> by its memoized
2595 * variable. If Y:<form> is not of the form '(<form> <form> ...)', the
2596 * evaluation is performed inline without calling an evaluator.
2598 * This macro uses ceval or deval depending on its 3rd argument.
2602 #define SCM_I_EVALIM2(x) \
2603 ((scm_is_eq ((x), SCM_EOL) \
2604 ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \
2608 #define SCM_I_EVALIM(x, env) (SCM_ILOCP (x) \
2609 ? *scm_ilookup ((x), (env)) \
2612 #define SCM_I_XEVAL(x, env, debug_p) \
2614 ? SCM_I_EVALIM2 (x) \
2615 : (SCM_VARIABLEP (x) \
2616 ? SCM_VARIABLE_REF (x) \
2617 : (scm_is_pair (x) \
2619 ? deval ((x), (env)) \
2620 : ceval ((x), (env))) \
2623 #define SCM_I_XEVALCAR(x, env, debug_p) \
2624 (SCM_IMP (SCM_CAR (x)) \
2625 ? SCM_I_EVALIM (SCM_CAR (x), (env)) \
2626 : (SCM_VARIABLEP (SCM_CAR (x)) \
2627 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2628 : (scm_is_pair (SCM_CAR (x)) \
2630 ? deval (SCM_CAR (x), (env)) \
2631 : ceval (SCM_CAR (x), (env))) \
2632 : (!scm_is_symbol (SCM_CAR (x)) \
2634 : *scm_lookupcar ((x), (env), 1)))))
2636 scm_i_pthread_mutex_t source_mutex
;
2639 /* Lookup a given local variable in an environment. The local variable is
2640 * given as an iloc, that is a triple <frame, binding, last?>, where frame
2641 * indicates the relative number of the environment frame (counting upwards
2642 * from the innermost environment frame), binding indicates the number of the
2643 * binding within the frame, and last? (which is extracted from the iloc using
2644 * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
2645 * very end of the improper list of bindings. */
2647 scm_ilookup (SCM iloc
, SCM env
)
2649 unsigned int frame_nr
= SCM_IFRAME (iloc
);
2650 unsigned int binding_nr
= SCM_IDIST (iloc
);
2654 for (; 0 != frame_nr
; --frame_nr
)
2655 frames
= SCM_CDR (frames
);
2657 bindings
= SCM_CAR (frames
);
2658 for (; 0 != binding_nr
; --binding_nr
)
2659 bindings
= SCM_CDR (bindings
);
2661 if (SCM_ICDRP (iloc
))
2662 return SCM_CDRLOC (bindings
);
2663 return SCM_CARLOC (SCM_CDR (bindings
));
2667 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
2669 static void error_unbound_variable (SCM symbol
) SCM_NORETURN
;
2670 static void error_defined_variable (SCM symbol
) SCM_NORETURN
;
2672 /* Call this for variables that are unfound.
2675 error_unbound_variable (SCM symbol
)
2677 scm_error (scm_unbound_variable_key
, NULL
,
2678 "Unbound variable: ~S",
2679 scm_list_1 (symbol
), SCM_BOOL_F
);
2682 /* Call this for variables that are found but contain SCM_UNDEFINED.
2685 error_defined_variable (SCM symbol
)
2687 /* We use the 'unbound-variable' key here as well, since it
2688 basically is the same kind of error, with a slight variation in
2689 the displayed message.
2691 scm_error (scm_unbound_variable_key
, NULL
,
2692 "Variable used before given a value: ~S",
2693 scm_list_1 (symbol
), SCM_BOOL_F
);
2697 /* The Lookup Car Race
2700 Memoization of variables and special forms is done while executing
2701 the code for the first time. As long as there is only one thread
2702 everything is fine, but as soon as two threads execute the same
2703 code concurrently `for the first time' they can come into conflict.
2705 This memoization includes rewriting variable references into more
2706 efficient forms and expanding macros. Furthermore, macro expansion
2707 includes `compiling' special forms like `let', `cond', etc. into
2708 tree-code instructions.
2710 There shouldn't normally be a problem with memoizing local and
2711 global variable references (into ilocs and variables), because all
2712 threads will mutate the code in *exactly* the same way and (if I
2713 read the C code correctly) it is not possible to observe a half-way
2714 mutated cons cell. The lookup procedure can handle this
2715 transparently without any critical sections.
2717 It is different with macro expansion, because macro expansion
2718 happens outside of the lookup procedure and can't be
2719 undone. Therefore the lookup procedure can't cope with it. It has
2720 to indicate failure when it detects a lost race and hope that the
2721 caller can handle it. Luckily, it turns out that this is the case.
2723 An example to illustrate this: Suppose that the following form will
2724 be memoized concurrently by two threads
2728 Let's first examine the lookup of X in the body. The first thread
2729 decides that it has to find the symbol "x" in the environment and
2730 starts to scan it. Then the other thread takes over and actually
2731 overtakes the first. It looks up "x" and substitutes an
2732 appropriate iloc for it. Now the first thread continues and
2733 completes its lookup. It comes to exactly the same conclusions as
2734 the second one and could - without much ado - just overwrite the
2735 iloc with the same iloc.
2737 But let's see what will happen when the race occurs while looking
2738 up the symbol "let" at the start of the form. It could happen that
2739 the second thread interrupts the lookup of the first thread and not
2740 only substitutes a variable for it but goes right ahead and
2741 replaces it with the compiled form (#@let* (x 12) x). Now, when
2742 the first thread completes its lookup, it would replace the #@let*
2743 with a variable containing the "let" binding, effectively reverting
2744 the form to (let (x 12) x). This is wrong. It has to detect that
2745 it has lost the race and the evaluator has to reconsider the
2746 changed form completely.
2748 This race condition could be resolved with some kind of traffic
2749 light (like mutexes) around scm_lookupcar, but I think that it is
2750 best to avoid them in this case. They would serialize memoization
2751 completely and because lookup involves calling arbitrary Scheme
2752 code (via the lookup-thunk), threads could be blocked for an
2753 arbitrary amount of time or even deadlock. But with the current
2754 solution a lot of unnecessary work is potentially done. */
2756 /* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
2757 return NULL to indicate a failed lookup due to some race conditions
2758 between threads. This only happens when VLOC is the first cell of
2759 a special form that will eventually be memoized (like `let', etc.)
2760 In that case the whole lookup is bogus and the caller has to
2761 reconsider the complete special form.
2763 SCM_LOOKUPCAR is still there, of course. It just calls
2764 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
2765 should only be called when it is known that VLOC is not the first
2766 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
2767 for NULL. I think I've found the only places where this
2771 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
2774 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
2775 register SCM iloc
= SCM_ILOC00
;
2776 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
2778 if (!scm_is_pair (SCM_CAR (env
)))
2780 al
= SCM_CARLOC (env
);
2781 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
2783 if (!scm_is_pair (fl
))
2785 if (scm_is_eq (fl
, var
))
2787 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2789 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
2790 return SCM_CDRLOC (*al
);
2795 al
= SCM_CDRLOC (*al
);
2796 if (scm_is_eq (SCM_CAR (fl
), var
))
2798 if (SCM_UNBNDP (SCM_CAR (*al
)))
2799 error_defined_variable (var
);
2800 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2802 SCM_SETCAR (vloc
, iloc
);
2803 return SCM_CARLOC (*al
);
2805 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
2807 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
2810 SCM top_thunk
, real_var
;
2813 top_thunk
= SCM_CAR (env
); /* env now refers to a
2814 top level env thunk */
2815 env
= SCM_CDR (env
);
2818 top_thunk
= SCM_BOOL_F
;
2819 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
2820 if (scm_is_false (real_var
))
2823 if (!scm_is_null (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
2828 if (scm_is_null (env
))
2829 error_unbound_variable (var
);
2831 scm_misc_error (NULL
, "Damaged environment: ~S",
2836 /* A variable could not be found, but we shall
2837 not throw an error. */
2838 static SCM undef_object
= SCM_UNDEFINED
;
2839 return &undef_object
;
2843 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2845 /* Some other thread has changed the very cell we are working
2846 on. In effect, it must have done our job or messed it up
2849 var
= SCM_CAR (vloc
);
2850 if (SCM_VARIABLEP (var
))
2851 return SCM_VARIABLE_LOC (var
);
2852 if (SCM_ILOCP (var
))
2853 return scm_ilookup (var
, genv
);
2854 /* We can't cope with anything else than variables and ilocs. When
2855 a special form has been memoized (i.e. `let' into `#@let') we
2856 return NULL and expect the calling function to do the right
2857 thing. For the evaluator, this means going back and redoing
2858 the dispatch on the car of the form. */
2862 SCM_SETCAR (vloc
, real_var
);
2863 return SCM_VARIABLE_LOC (real_var
);
2868 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
2870 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
2877 /* During execution, look up a symbol in the top level of the given local
2878 * environment and return the corresponding variable object. If no binding
2879 * for the symbol can be found, an 'Unbound variable' error is signalled. */
2881 lazy_memoize_variable (const SCM symbol
, const SCM environment
)
2883 const SCM top_level
= scm_env_top_level (environment
);
2884 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
2886 if (scm_is_false (variable
))
2887 error_unbound_variable (symbol
);
2894 scm_eval_car (SCM pair
, SCM env
)
2896 return SCM_I_XEVALCAR (pair
, env
, scm_debug_mode_p
);
2901 scm_eval_body (SCM code
, SCM env
)
2906 next
= SCM_CDR (code
);
2907 while (!scm_is_null (next
))
2909 if (SCM_IMP (SCM_CAR (code
)))
2911 if (SCM_ISYMP (SCM_CAR (code
)))
2913 scm_dynwind_begin (0);
2914 scm_i_dynwind_pthread_mutex_lock (&source_mutex
);
2915 /* check for race condition */
2916 if (SCM_ISYMP (SCM_CAR (code
)))
2917 m_expand_body (code
, env
);
2923 SCM_I_XEVAL (SCM_CAR (code
), env
, scm_debug_mode_p
);
2925 next
= SCM_CDR (code
);
2927 return SCM_I_XEVALCAR (code
, env
, scm_debug_mode_p
);
2931 /* scm_last_debug_frame contains a pointer to the last debugging information
2932 * stack frame. It is accessed very often from the debugging evaluator, so it
2933 * should probably not be indirectly addressed. Better to save and restore it
2934 * from the current root at any stack swaps.
2937 /* scm_debug_eframe_size is the number of slots available for pseudo
2938 * stack frames at each real stack frame.
2941 long scm_debug_eframe_size
;
2943 int scm_debug_mode_p
;
2944 int scm_check_entry_p
;
2945 int scm_check_apply_p
;
2946 int scm_check_exit_p
;
2947 int scm_check_memoize_p
;
2949 long scm_eval_stack
;
2951 scm_t_option scm_eval_opts
[] = {
2952 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." },
2956 scm_t_option scm_debug_opts
[] = {
2957 { SCM_OPTION_BOOLEAN
, "cheap", 1,
2958 "*This option is now obsolete. Setting it has no effect." },
2959 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
2960 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
2961 { SCM_OPTION_BOOLEAN
, "procnames", 1,
2962 "Record procedure names at definition." },
2963 { SCM_OPTION_BOOLEAN
, "backwards", 0,
2964 "Display backtrace in anti-chronological order." },
2965 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
2966 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
2967 { SCM_OPTION_INTEGER
, "frames", 3,
2968 "Maximum number of tail-recursive frames in backtrace." },
2969 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
2970 "Maximal number of stored backtrace frames." },
2971 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
2972 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
2973 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
2975 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
2976 { SCM_OPTION_SCM
, "show-file-name", (unsigned long)SCM_BOOL_T
,
2977 "Show file names and line numbers "
2978 "in backtraces when not `#f'. A value of `base' "
2979 "displays only base names, while `#t' displays full names."},
2980 { SCM_OPTION_BOOLEAN
, "warn-deprecated", 0,
2981 "Warn when deprecated features are used." },
2987 * this ordering is awkward and illogical, but we maintain it for
2988 * compatibility. --hwn
2990 scm_t_option scm_evaluator_trap_table
[] = {
2991 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
2992 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
2993 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
2994 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
2995 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
2996 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
2997 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." },
2998 { SCM_OPTION_BOOLEAN
, "memoize-symbol", 0, "Trap when memoizing a symbol." },
2999 { SCM_OPTION_SCM
, "memoize-symbol-handler", (unsigned long)SCM_BOOL_F
, "The handler for memoization." },
3004 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
3006 "Option interface for the evaluation options. Instead of using\n"
3007 "this procedure directly, use the procedures @code{eval-enable},\n"
3008 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
3009 #define FUNC_NAME s_scm_eval_options_interface
3013 scm_dynwind_begin (0);
3014 scm_dynwind_critical_section (SCM_BOOL_F
);
3015 ans
= scm_options (setting
,
3018 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
3026 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
3028 "Option interface for the evaluator trap options.")
3029 #define FUNC_NAME s_scm_evaluator_traps
3034 scm_options_try (setting
,
3035 scm_evaluator_trap_table
,
3037 SCM_CRITICAL_SECTION_START
;
3038 ans
= scm_options (setting
,
3039 scm_evaluator_trap_table
,
3042 /* njrev: same again. */
3043 SCM_RESET_DEBUG_MODE
;
3044 SCM_CRITICAL_SECTION_END
;
3053 /* Simple procedure calls
3057 scm_call_0 (SCM proc
)
3059 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
3063 scm_call_1 (SCM proc
, SCM arg1
)
3065 return scm_apply (proc
, arg1
, scm_listofnull
);
3069 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
3071 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
3075 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
3077 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
3081 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
3083 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
3084 scm_cons (arg4
, scm_listofnull
)));
3087 /* Simple procedure applies
3091 scm_apply_0 (SCM proc
, SCM args
)
3093 return scm_apply (proc
, args
, SCM_EOL
);
3097 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
3099 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
3103 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
3105 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
3109 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
3111 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
3115 /* This code processes the arguments to apply:
3117 (apply PROC ARG1 ... ARGS)
3119 Given a list (ARG1 ... ARGS), this function conses the ARG1
3120 ... arguments onto the front of ARGS, and returns the resulting
3121 list. Note that ARGS is a list; thus, the argument to this
3122 function is a list whose last element is a list.
3124 Apply calls this function, and applies PROC to the elements of the
3125 result. apply:nconc2last takes care of building the list of
3126 arguments, given (ARG1 ... ARGS).
3128 Rather than do new consing, apply:nconc2last destroys its argument.
3129 On that topic, this code came into my care with the following
3130 beautifully cryptic comment on that topic: "This will only screw
3131 you if you do (scm_apply scm_apply '( ... ))" If you know what
3132 they're referring to, send me a patch to this comment. */
3134 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3136 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
3137 "conses the @var{arg1} @dots{} arguments onto the front of\n"
3138 "@var{args}, and returns the resulting list. Note that\n"
3139 "@var{args} is a list; thus, the argument to this function is\n"
3140 "a list whose last element is a list.\n"
3141 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
3142 "destroys its argument, so use with care.")
3143 #define FUNC_NAME s_scm_nconc2last
3146 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
3148 while (!scm_is_null (SCM_CDR (*lloc
))) /* Perhaps should be
3149 SCM_NULL_OR_NIL_P, but not
3150 needed in 99.99% of cases,
3151 and it could seriously hurt
3152 performance. - Neil */
3153 lloc
= SCM_CDRLOC (*lloc
);
3154 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3155 *lloc
= SCM_CAR (*lloc
);
3162 /* SECTION: The rest of this file is only read once.
3167 * Trampolines make it possible to move procedure application dispatch
3168 * outside inner loops. The motivation was clean implementation of
3169 * efficient replacements of R5RS primitives in SRFI-1.
3171 * The semantics is clear: scm_trampoline_N returns an optimized
3172 * version of scm_call_N (or NULL if the procedure isn't applicable
3175 * Applying the optimization to map and for-each increased efficiency
3176 * noticeably. For example, (map abs ls) is now 8 times faster than
3181 call_subr0_0 (SCM proc
)
3183 return SCM_SUBRF (proc
) ();
3187 call_subr1o_0 (SCM proc
)
3189 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
3193 call_lsubr_0 (SCM proc
)
3195 return SCM_SUBRF (proc
) (SCM_EOL
);
3199 scm_i_call_closure_0 (SCM proc
)
3201 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3204 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
3209 scm_trampoline_0 (SCM proc
)
3211 scm_t_trampoline_0 trampoline
;
3216 switch (SCM_TYP7 (proc
))
3218 case scm_tc7_subr_0
:
3219 trampoline
= call_subr0_0
;
3221 case scm_tc7_subr_1o
:
3222 trampoline
= call_subr1o_0
;
3225 trampoline
= call_lsubr_0
;
3227 case scm_tcs_closures
:
3229 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3230 if (scm_is_null (formals
) || !scm_is_pair (formals
))
3231 trampoline
= scm_i_call_closure_0
;
3236 case scm_tcs_struct
:
3237 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3238 trampoline
= scm_call_generic_0
;
3239 else if (SCM_I_OPERATORP (proc
))
3240 trampoline
= scm_call_0
;
3245 if (SCM_SMOB_APPLICABLE_P (proc
))
3246 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
3251 case scm_tc7_rpsubr
:
3254 trampoline
= scm_call_0
;
3257 return NULL
; /* not applicable on zero arguments */
3259 /* We only reach this point if a valid trampoline was determined. */
3261 /* If debugging is enabled, we want to see all calls to proc on the stack.
3262 * Thus, we replace the trampoline shortcut with scm_call_0. */
3263 if (scm_debug_mode_p
)
3270 call_subr1_1 (SCM proc
, SCM arg1
)
3272 return SCM_SUBRF (proc
) (arg1
);
3276 call_subr2o_1 (SCM proc
, SCM arg1
)
3278 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
3282 call_lsubr_1 (SCM proc
, SCM arg1
)
3284 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
3288 call_dsubr_1 (SCM proc
, SCM arg1
)
3290 if (SCM_I_INUMP (arg1
))
3292 return (scm_from_double (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
))));
3294 else if (SCM_REALP (arg1
))
3296 return (scm_from_double (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3298 else if (SCM_BIGP (arg1
))
3300 return (scm_from_double (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3302 else if (SCM_FRACTIONP (arg1
))
3304 return (scm_from_double (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
3306 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3307 SCM_ARG1
, scm_i_symbol_chars (SCM_SNAME (proc
)));
3311 call_cxr_1 (SCM proc
, SCM arg1
)
3313 return scm_i_chase_pairs (arg1
, (scm_t_bits
) SCM_SUBRF (proc
));
3317 call_closure_1 (SCM proc
, SCM arg1
)
3319 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3322 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
3327 scm_trampoline_1 (SCM proc
)
3329 scm_t_trampoline_1 trampoline
;
3334 switch (SCM_TYP7 (proc
))
3336 case scm_tc7_subr_1
:
3337 case scm_tc7_subr_1o
:
3338 trampoline
= call_subr1_1
;
3340 case scm_tc7_subr_2o
:
3341 trampoline
= call_subr2o_1
;
3344 trampoline
= call_lsubr_1
;
3347 trampoline
= call_dsubr_1
;
3350 trampoline
= call_cxr_1
;
3352 case scm_tcs_closures
:
3354 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3355 if (!scm_is_null (formals
)
3356 && (!scm_is_pair (formals
) || !scm_is_pair (SCM_CDR (formals
))))
3357 trampoline
= call_closure_1
;
3362 case scm_tcs_struct
:
3363 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3364 trampoline
= scm_call_generic_1
;
3365 else if (SCM_I_OPERATORP (proc
))
3366 trampoline
= scm_call_1
;
3371 if (SCM_SMOB_APPLICABLE_P (proc
))
3372 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
3377 case scm_tc7_rpsubr
:
3380 trampoline
= scm_call_1
;
3383 return NULL
; /* not applicable on one arg */
3385 /* We only reach this point if a valid trampoline was determined. */
3387 /* If debugging is enabled, we want to see all calls to proc on the stack.
3388 * Thus, we replace the trampoline shortcut with scm_call_1. */
3389 if (scm_debug_mode_p
)
3396 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
3398 return SCM_SUBRF (proc
) (arg1
, arg2
);
3402 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
3404 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
3408 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
3410 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
3414 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
3416 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3417 scm_list_2 (arg1
, arg2
),
3419 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
3424 scm_trampoline_2 (SCM proc
)
3426 scm_t_trampoline_2 trampoline
;
3431 switch (SCM_TYP7 (proc
))
3433 case scm_tc7_subr_2
:
3434 case scm_tc7_subr_2o
:
3435 case scm_tc7_rpsubr
:
3437 trampoline
= call_subr2_2
;
3439 case scm_tc7_lsubr_2
:
3440 trampoline
= call_lsubr2_2
;
3443 trampoline
= call_lsubr_2
;
3445 case scm_tcs_closures
:
3447 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3448 if (!scm_is_null (formals
)
3449 && (!scm_is_pair (formals
)
3450 || (!scm_is_null (SCM_CDR (formals
))
3451 && (!scm_is_pair (SCM_CDR (formals
))
3452 || !scm_is_pair (SCM_CDDR (formals
))))))
3453 trampoline
= call_closure_2
;
3458 case scm_tcs_struct
:
3459 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3460 trampoline
= scm_call_generic_2
;
3461 else if (SCM_I_OPERATORP (proc
))
3462 trampoline
= scm_call_2
;
3467 if (SCM_SMOB_APPLICABLE_P (proc
))
3468 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
3474 trampoline
= scm_call_2
;
3477 return NULL
; /* not applicable on two args */
3479 /* We only reach this point if a valid trampoline was determined. */
3481 /* If debugging is enabled, we want to see all calls to proc on the stack.
3482 * Thus, we replace the trampoline shortcut with scm_call_2. */
3483 if (scm_debug_mode_p
)
3489 /* Typechecking for multi-argument MAP and FOR-EACH.
3491 Verify that each element of the vector ARGV, except for the first,
3492 is a proper list whose length is LEN. Attribute errors to WHO,
3493 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3495 check_map_args (SCM argv
,
3504 for (i
= SCM_SIMPLE_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
3506 SCM elt
= SCM_SIMPLE_VECTOR_REF (argv
, i
);
3507 long elt_len
= scm_ilength (elt
);
3512 scm_apply_generic (gf
, scm_cons (proc
, args
));
3514 scm_wrong_type_arg (who
, i
+ 2, elt
);
3518 scm_out_of_range_pos (who
, elt
, scm_from_long (i
+ 2));
3523 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3525 /* Note: Currently, scm_map applies PROC to the argument list(s)
3526 sequentially, starting with the first element(s). This is used in
3527 evalext.c where the Scheme procedure `map-in-order', which guarantees
3528 sequential behaviour, is implemented using scm_map. If the
3529 behaviour changes, we need to update `map-in-order'.
3533 scm_map (SCM proc
, SCM arg1
, SCM args
)
3534 #define FUNC_NAME s_map
3540 len
= scm_ilength (arg1
);
3541 SCM_GASSERTn (len
>= 0,
3542 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
3543 SCM_VALIDATE_REST_ARGUMENT (args
);
3544 if (scm_is_null (args
))
3546 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
3547 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
3548 while (SCM_NIMP (arg1
))
3550 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
3551 pres
= SCM_CDRLOC (*pres
);
3552 arg1
= SCM_CDR (arg1
);
3556 if (scm_is_null (SCM_CDR (args
)))
3558 SCM arg2
= SCM_CAR (args
);
3559 int len2
= scm_ilength (arg2
);
3560 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
3562 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
3563 SCM_GASSERTn (len2
>= 0,
3564 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
3566 SCM_OUT_OF_RANGE (3, arg2
);
3567 while (SCM_NIMP (arg1
))
3569 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
3570 pres
= SCM_CDRLOC (*pres
);
3571 arg1
= SCM_CDR (arg1
);
3572 arg2
= SCM_CDR (arg2
);
3576 arg1
= scm_cons (arg1
, args
);
3577 args
= scm_vector (arg1
);
3578 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
3582 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3584 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
3587 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
3588 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
3590 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
3591 pres
= SCM_CDRLOC (*pres
);
3597 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
3600 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
3601 #define FUNC_NAME s_for_each
3604 len
= scm_ilength (arg1
);
3605 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
3606 SCM_ARG2
, s_for_each
);
3607 SCM_VALIDATE_REST_ARGUMENT (args
);
3608 if (scm_is_null (args
))
3610 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
3611 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
3612 while (SCM_NIMP (arg1
))
3614 call (proc
, SCM_CAR (arg1
));
3615 arg1
= SCM_CDR (arg1
);
3617 return SCM_UNSPECIFIED
;
3619 if (scm_is_null (SCM_CDR (args
)))
3621 SCM arg2
= SCM_CAR (args
);
3622 int len2
= scm_ilength (arg2
);
3623 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
3624 SCM_GASSERTn (call
, g_for_each
,
3625 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
3626 SCM_GASSERTn (len2
>= 0, g_for_each
,
3627 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
3629 SCM_OUT_OF_RANGE (3, arg2
);
3630 while (SCM_NIMP (arg1
))
3632 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
3633 arg1
= SCM_CDR (arg1
);
3634 arg2
= SCM_CDR (arg2
);
3636 return SCM_UNSPECIFIED
;
3638 arg1
= scm_cons (arg1
, args
);
3639 args
= scm_vector (arg1
);
3640 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
3644 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3646 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
3648 return SCM_UNSPECIFIED
;
3649 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
3650 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
3652 scm_apply (proc
, arg1
, SCM_EOL
);
3659 scm_closure (SCM code
, SCM env
)
3662 SCM closcar
= scm_cons (code
, SCM_EOL
);
3663 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
3664 scm_remember_upto_here (closcar
);
3669 scm_t_bits scm_tc16_promise
;
3672 scm_makprom (SCM code
)
3674 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
3676 scm_make_recursive_mutex ());
3681 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
3683 int writingp
= SCM_WRITINGP (pstate
);
3684 scm_puts ("#<promise ", port
);
3685 SCM_SET_WRITINGP (pstate
, 1);
3686 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
3687 SCM_SET_WRITINGP (pstate
, writingp
);
3688 scm_putc ('>', port
);
3692 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
3694 "If the promise @var{x} has not been computed yet, compute and\n"
3695 "return @var{x}, otherwise just return the previously computed\n"
3697 #define FUNC_NAME s_scm_force
3699 SCM_VALIDATE_SMOB (1, promise
, promise
);
3700 scm_lock_mutex (SCM_PROMISE_MUTEX (promise
));
3701 if (!SCM_PROMISE_COMPUTED_P (promise
))
3703 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
3704 if (!SCM_PROMISE_COMPUTED_P (promise
))
3706 SCM_SET_PROMISE_DATA (promise
, ans
);
3707 SCM_SET_PROMISE_COMPUTED (promise
);
3710 scm_unlock_mutex (SCM_PROMISE_MUTEX (promise
));
3711 return SCM_PROMISE_DATA (promise
);
3716 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
3718 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
3719 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
3720 #define FUNC_NAME s_scm_promise_p
3722 return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
3727 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
3728 (SCM xorig
, SCM x
, SCM y
),
3729 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
3730 "Any source properties associated with @var{xorig} are also associated\n"
3731 "with the new pair.")
3732 #define FUNC_NAME s_scm_cons_source
3735 z
= scm_cons (x
, y
);
3736 /* Copy source properties possibly associated with xorig. */
3737 p
= scm_whash_lookup (scm_source_whash
, xorig
);
3738 if (scm_is_true (p
))
3739 scm_whash_insert (scm_source_whash
, z
, p
);
3745 /* The function scm_copy_tree is used to copy an expression tree to allow the
3746 * memoizer to modify the expression during memoization. scm_copy_tree
3747 * creates deep copies of pairs and vectors, but not of any other data types,
3748 * since only pairs and vectors will be parsed by the memoizer.
3750 * To avoid infinite recursion due to cyclic structures, the hare-and-tortoise
3751 * pattern is used to detect cycles. In fact, the pattern is used in two
3752 * dimensions, vertical (indicated in the code by the variable names 'hare'
3753 * and 'tortoise') and horizontal ('rabbit' and 'turtle'). In both
3754 * dimensions, the hare/rabbit will take two steps when the tortoise/turtle
3757 * The vertical dimension corresponds to recursive calls to function
3758 * copy_tree: This happens when descending into vector elements, into cars of
3759 * lists and into the cdr of an improper list. In this dimension, the
3760 * tortoise follows the hare by using the processor stack: Every stack frame
3761 * will hold an instance of struct t_trace. These instances are connected in
3762 * a way that represents the trace of the hare, which thus can be followed by
3763 * the tortoise. The tortoise will always point to struct t_trace instances
3764 * relating to SCM objects that have already been copied. Thus, a cycle is
3765 * detected if the tortoise and the hare point to the same object,
3767 * The horizontal dimension is within one execution of copy_tree, when the
3768 * function cdr's along the pairs of a list. This is the standard
3769 * hare-and-tortoise implementation, found several times in guile. */
3772 struct t_trace
*trace
; /* These pointers form a trace along the stack. */
3773 SCM obj
; /* The object handled at the respective stack frame.*/
3778 struct t_trace
*const hare
,
3779 struct t_trace
*tortoise
,
3780 unsigned int tortoise_delay
)
3782 if (!scm_is_pair (hare
->obj
) && !scm_is_simple_vector (hare
->obj
))
3788 /* Prepare the trace along the stack. */
3789 struct t_trace new_hare
;
3790 hare
->trace
= &new_hare
;
3792 /* The tortoise will make its step after the delay has elapsed. Note
3793 * that in contrast to the typical hare-and-tortoise pattern, the step
3794 * of the tortoise happens before the hare takes its steps. This is, in
3795 * principle, no problem, except for the start of the algorithm: Then,
3796 * it has to be made sure that the hare actually gets its advantage of
3798 if (tortoise_delay
== 0)
3801 tortoise
= tortoise
->trace
;
3802 ASSERT_SYNTAX (!scm_is_eq (hare
->obj
, tortoise
->obj
),
3803 s_bad_expression
, hare
->obj
);
3810 if (scm_is_simple_vector (hare
->obj
))
3812 size_t length
= SCM_SIMPLE_VECTOR_LENGTH (hare
->obj
);
3813 SCM new_vector
= scm_c_make_vector (length
, SCM_UNSPECIFIED
);
3815 /* Each vector element is copied by recursing into copy_tree, having
3816 * the tortoise follow the hare into the depths of the stack. */
3817 unsigned long int i
;
3818 for (i
= 0; i
< length
; ++i
)
3821 new_hare
.obj
= SCM_SIMPLE_VECTOR_REF (hare
->obj
, i
);
3822 new_element
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3823 SCM_SIMPLE_VECTOR_SET (new_vector
, i
, new_element
);
3828 else /* scm_is_pair (hare->obj) */
3833 SCM rabbit
= hare
->obj
;
3834 SCM turtle
= hare
->obj
;
3838 /* The first pair of the list is treated specially, in order to
3839 * preserve a potential source code position. */
3840 result
= tail
= scm_cons_source (rabbit
, SCM_EOL
, SCM_EOL
);
3841 new_hare
.obj
= SCM_CAR (rabbit
);
3842 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3843 SCM_SETCAR (tail
, copy
);
3845 /* The remaining pairs of the list are copied by, horizontally,
3846 * having the turtle follow the rabbit, and, vertically, having the
3847 * tortoise follow the hare into the depths of the stack. */
3848 rabbit
= SCM_CDR (rabbit
);
3849 while (scm_is_pair (rabbit
))
3851 new_hare
.obj
= SCM_CAR (rabbit
);
3852 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3853 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
3854 tail
= SCM_CDR (tail
);
3856 rabbit
= SCM_CDR (rabbit
);
3857 if (scm_is_pair (rabbit
))
3859 new_hare
.obj
= SCM_CAR (rabbit
);
3860 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3861 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
3862 tail
= SCM_CDR (tail
);
3863 rabbit
= SCM_CDR (rabbit
);
3865 turtle
= SCM_CDR (turtle
);
3866 ASSERT_SYNTAX (!scm_is_eq (rabbit
, turtle
),
3867 s_bad_expression
, rabbit
);
3871 /* We have to recurse into copy_tree again for the last cdr, in
3872 * order to handle the situation that it holds a vector. */
3873 new_hare
.obj
= rabbit
;
3874 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3875 SCM_SETCDR (tail
, copy
);
3882 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
3884 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
3885 "the new data structure. @code{copy-tree} recurses down the\n"
3886 "contents of both pairs and vectors (since both cons cells and vector\n"
3887 "cells may point to arbitrary objects), and stops recursing when it hits\n"
3888 "any other object.")
3889 #define FUNC_NAME s_scm_copy_tree
3891 /* Prepare the trace along the stack. */
3892 struct t_trace trace
;
3895 /* In function copy_tree, if the tortoise makes its step, it will do this
3896 * before the hare has the chance to move. Thus, we have to make sure that
3897 * the very first step of the tortoise will not happen after the hare has
3898 * really made two steps. This is achieved by passing '2' as the initial
3899 * delay for the tortoise. NOTE: Since cycles are unlikely, giving the hare
3900 * a bigger advantage may improve performance slightly. */
3901 return copy_tree (&trace
, &trace
, 2);
3906 /* We have three levels of EVAL here:
3908 - scm_i_eval (exp, env)
3910 evaluates EXP in environment ENV. ENV is a lexical environment
3911 structure as used by the actual tree code evaluator. When ENV is
3912 a top-level environment, then changes to the current module are
3913 tracked by updating ENV so that it continues to be in sync with
3916 - scm_primitive_eval (exp)
3918 evaluates EXP in the top-level environment as determined by the
3919 current module. This is done by constructing a suitable
3920 environment and calling scm_i_eval. Thus, changes to the
3921 top-level module are tracked normally.
3923 - scm_eval (exp, mod_or_state)
3925 evaluates EXP while MOD_OR_STATE is the current module or current
3926 dynamic state (as appropriate). This is done by setting the
3927 current module (or dynamic state) to MOD_OR_STATE, invoking
3928 scm_primitive_eval on EXP, and then restoring the current module
3929 (or dynamic state) to the value it had previously. That is,
3930 while EXP is evaluated, changes to the current module (or dynamic
3931 state) are tracked, but these changes do not persist when
3934 For each level of evals, there are two variants, distinguished by a
3935 _x suffix: the ordinary variant does not modify EXP while the _x
3936 variant can destructively modify EXP into something completely
3937 unintelligible. A Scheme data structure passed as EXP to one of the
3938 _x variants should not ever be used again for anything. So when in
3939 doubt, use the ordinary variant.
3944 scm_i_eval_x (SCM exp
, SCM env
)
3946 if (scm_is_symbol (exp
))
3947 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
3949 return SCM_I_XEVAL (exp
, env
, scm_debug_mode_p
);
3953 scm_i_eval (SCM exp
, SCM env
)
3955 exp
= scm_copy_tree (exp
);
3956 if (scm_is_symbol (exp
))
3957 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
3959 return SCM_I_XEVAL (exp
, env
, scm_debug_mode_p
);
3963 scm_primitive_eval_x (SCM exp
)
3966 SCM transformer
= scm_current_module_transformer ();
3967 if (SCM_NIMP (transformer
))
3968 exp
= scm_call_1 (transformer
, exp
);
3969 env
= scm_top_level_env (scm_current_module_lookup_closure ());
3970 return scm_i_eval_x (exp
, env
);
3973 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
3975 "Evaluate @var{exp} in the top-level environment specified by\n"
3976 "the current module.")
3977 #define FUNC_NAME s_scm_primitive_eval
3980 SCM transformer
= scm_current_module_transformer ();
3981 if (scm_is_true (transformer
))
3982 exp
= scm_call_1 (transformer
, exp
);
3983 env
= scm_top_level_env (scm_current_module_lookup_closure ());
3984 return scm_i_eval (exp
, env
);
3989 /* Eval does not take the second arg optionally. This is intentional
3990 * in order to be R5RS compatible, and to prepare for the new module
3991 * system, where we would like to make the choice of evaluation
3992 * environment explicit. */
3995 scm_eval_x (SCM exp
, SCM module_or_state
)
3999 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
4000 if (scm_is_dynamic_state (module_or_state
))
4001 scm_dynwind_current_dynamic_state (module_or_state
);
4003 scm_dynwind_current_module (module_or_state
);
4005 res
= scm_primitive_eval_x (exp
);
4011 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
4012 (SCM exp
, SCM module_or_state
),
4013 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
4014 "in the top-level environment specified by\n"
4015 "@var{module_or_state}.\n"
4016 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
4017 "@var{module_or_state} is made the current module when\n"
4018 "it is a module, or the current dynamic state when it is\n"
4020 "Example: (eval '(+ 1 2) (interaction-environment))")
4021 #define FUNC_NAME s_scm_eval
4025 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
4026 if (scm_is_dynamic_state (module_or_state
))
4027 scm_dynwind_current_dynamic_state (module_or_state
);
4029 scm_dynwind_current_module (module_or_state
);
4031 res
= scm_primitive_eval (exp
);
4039 /* At this point, deval and scm_dapply are generated.
4051 scm_i_pthread_mutex_init (&source_mutex
,
4052 scm_i_pthread_mutexattr_recursive
);
4054 scm_init_opts (scm_evaluator_traps
,
4055 scm_evaluator_trap_table
);
4056 scm_init_opts (scm_eval_options_interface
,
4059 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
4060 scm_set_smob_print (scm_tc16_promise
, promise_print
);
4062 undefineds
= scm_list_1 (SCM_UNDEFINED
);
4063 SCM_SETCDR (undefineds
, undefineds
);
4064 scm_permanent_object (undefineds
);
4066 scm_listofnull
= scm_list_1 (SCM_EOL
);
4068 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
4069 scm_permanent_object (f_apply
);
4071 #include "libguile/eval.x"
4073 scm_add_feature ("delay");