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. However, EXPRESSION _can_ be evaluated before VARIABLE is
1215 bound. This means that EXPRESSION won't necessarily be able to assign
1216 values to VARIABLE as in `(define foo (begin (set! foo 1) (+ foo 1)))'. */
1218 scm_m_define (SCM expr
, SCM env
)
1220 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), s_bad_define
, expr
);
1223 const SCM canonical_definition
= canonicalize_define (expr
);
1224 const SCM cdr_canonical_definition
= SCM_CDR (canonical_definition
);
1225 const SCM variable
= SCM_CAR (cdr_canonical_definition
);
1226 const SCM value
= scm_eval_car (SCM_CDR (cdr_canonical_definition
), env
);
1228 = scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_T
);
1230 if (SCM_REC_PROCNAMES_P
)
1233 while (SCM_MACROP (tmp
))
1234 tmp
= SCM_MACRO_CODE (tmp
);
1235 if (scm_is_true (scm_procedure_p (tmp
))
1236 /* Only the first definition determines the name. */
1237 && scm_is_false (scm_procedure_property (tmp
, scm_sym_name
)))
1238 scm_set_procedure_property_x (tmp
, scm_sym_name
, variable
);
1241 SCM_VARIABLE_SET (location
, value
);
1243 return SCM_UNSPECIFIED
;
1248 /* This is a helper function for forms (<keyword> <expression>) that are
1249 * transformed into (#@<keyword> '() <memoized_expression>) in order to allow
1250 * for easy creation of a thunk (i. e. a closure without arguments) using the
1251 * ('() <memoized_expression>) tail of the memoized form. */
1253 memoize_as_thunk_prototype (const SCM expr
, const SCM env SCM_UNUSED
)
1255 const SCM cdr_expr
= SCM_CDR (expr
);
1256 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1257 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1259 SCM_SETCDR (expr
, scm_cons (SCM_EOL
, cdr_expr
));
1265 SCM_SYNTAX (s_delay
, "delay", scm_i_makbimacro
, scm_m_delay
);
1266 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
1268 /* Promises are implemented as closures with an empty parameter list. Thus,
1269 * (delay <expression>) is transformed into (#@delay '() <expression>), where
1270 * the empty list represents the empty parameter list. This representation
1271 * allows for easy creation of the closure during evaluation. */
1273 scm_m_delay (SCM expr
, SCM env
)
1275 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1276 SCM_SETCAR (new_expr
, SCM_IM_DELAY
);
1281 unmemoize_delay (const SCM expr
, const SCM env
)
1283 const SCM thunk_expr
= SCM_CADDR (expr
);
1284 return scm_list_2 (scm_sym_delay
, unmemoize_expression (thunk_expr
, env
));
1288 SCM_SYNTAX(s_do
, "do", scm_i_makbimacro
, scm_m_do
);
1289 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
1291 /* DO gets the most radically altered syntax. The order of the vars is
1292 * reversed here. During the evaluation this allows for simple consing of the
1293 * results of the inits and steps:
1295 (do ((<var1> <init1> <step1>)
1303 (#@do (<init1> <init2> ... <initn>)
1304 (varn ... var2 var1)
1307 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
1310 scm_m_do (SCM expr
, SCM env SCM_UNUSED
)
1312 SCM variables
= SCM_EOL
;
1313 SCM init_forms
= SCM_EOL
;
1314 SCM step_forms
= SCM_EOL
;
1321 const SCM cdr_expr
= SCM_CDR (expr
);
1322 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1323 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1325 /* Collect variables, init and step forms. */
1326 binding_idx
= SCM_CAR (cdr_expr
);
1327 ASSERT_SYNTAX_2 (scm_ilength (binding_idx
) >= 0,
1328 s_bad_bindings
, binding_idx
, expr
);
1329 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1331 const SCM binding
= SCM_CAR (binding_idx
);
1332 const long length
= scm_ilength (binding
);
1333 ASSERT_SYNTAX_2 (length
== 2 || length
== 3,
1334 s_bad_binding
, binding
, expr
);
1337 const SCM name
= SCM_CAR (binding
);
1338 const SCM init
= SCM_CADR (binding
);
1339 const SCM step
= (length
== 2) ? name
: SCM_CADDR (binding
);
1340 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
1341 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, variables
)),
1342 s_duplicate_binding
, name
, expr
);
1344 variables
= scm_cons (name
, variables
);
1345 init_forms
= scm_cons (init
, init_forms
);
1346 step_forms
= scm_cons (step
, step_forms
);
1349 init_forms
= scm_reverse_x (init_forms
, SCM_UNDEFINED
);
1350 step_forms
= scm_reverse_x (step_forms
, SCM_UNDEFINED
);
1352 /* Memoize the test form and the exit sequence. */
1353 cddr_expr
= SCM_CDR (cdr_expr
);
1354 exit_clause
= SCM_CAR (cddr_expr
);
1355 ASSERT_SYNTAX_2 (scm_ilength (exit_clause
) >= 1,
1356 s_bad_exit_clause
, exit_clause
, expr
);
1358 commands
= SCM_CDR (cddr_expr
);
1359 tail
= scm_cons2 (exit_clause
, commands
, step_forms
);
1360 tail
= scm_cons2 (init_forms
, variables
, tail
);
1361 SCM_SETCAR (expr
, SCM_IM_DO
);
1362 SCM_SETCDR (expr
, tail
);
1367 unmemoize_do (const SCM expr
, const SCM env
)
1369 const SCM cdr_expr
= SCM_CDR (expr
);
1370 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1371 const SCM rnames
= SCM_CAR (cddr_expr
);
1372 const SCM extended_env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
1373 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
1374 const SCM exit_sequence
= SCM_CAR (cdddr_expr
);
1375 const SCM um_exit_sequence
= unmemoize_exprs (exit_sequence
, extended_env
);
1376 const SCM cddddr_expr
= SCM_CDR (cdddr_expr
);
1377 const SCM um_body
= unmemoize_exprs (SCM_CAR (cddddr_expr
), extended_env
);
1379 /* build transformed binding list */
1380 SCM um_names
= scm_reverse (rnames
);
1381 SCM um_inits
= unmemoize_exprs (SCM_CAR (cdr_expr
), env
);
1382 SCM um_steps
= unmemoize_exprs (SCM_CDR (cddddr_expr
), extended_env
);
1383 SCM um_bindings
= SCM_EOL
;
1384 while (!scm_is_null (um_names
))
1386 const SCM name
= SCM_CAR (um_names
);
1387 const SCM init
= SCM_CAR (um_inits
);
1388 SCM step
= SCM_CAR (um_steps
);
1389 step
= scm_is_eq (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
1391 um_bindings
= scm_cons (scm_cons2 (name
, init
, step
), um_bindings
);
1393 um_names
= SCM_CDR (um_names
);
1394 um_inits
= SCM_CDR (um_inits
);
1395 um_steps
= SCM_CDR (um_steps
);
1397 um_bindings
= scm_reverse_x (um_bindings
, SCM_UNDEFINED
);
1399 return scm_cons (scm_sym_do
,
1400 scm_cons2 (um_bindings
, um_exit_sequence
, um_body
));
1404 SCM_SYNTAX (s_if
, "if", scm_i_makbimacro
, scm_m_if
);
1405 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
1408 scm_m_if (SCM expr
, SCM env SCM_UNUSED
)
1410 const SCM cdr_expr
= SCM_CDR (expr
);
1411 const long length
= scm_ilength (cdr_expr
);
1412 ASSERT_SYNTAX (length
== 2 || length
== 3, s_expression
, expr
);
1413 SCM_SETCAR (expr
, SCM_IM_IF
);
1418 unmemoize_if (const SCM expr
, const SCM env
)
1420 const SCM cdr_expr
= SCM_CDR (expr
);
1421 const SCM um_condition
= unmemoize_expression (SCM_CAR (cdr_expr
), env
);
1422 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1423 const SCM um_then
= unmemoize_expression (SCM_CAR (cddr_expr
), env
);
1424 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
1426 if (scm_is_null (cdddr_expr
))
1428 return scm_list_3 (scm_sym_if
, um_condition
, um_then
);
1432 const SCM um_else
= unmemoize_expression (SCM_CAR (cdddr_expr
), env
);
1433 return scm_list_4 (scm_sym_if
, um_condition
, um_then
, um_else
);
1438 SCM_SYNTAX (s_lambda
, "lambda", scm_i_makbimacro
, scm_m_lambda
);
1439 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
1441 /* A helper function for memoize_lambda to support checking for duplicate
1442 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
1443 * LIST or to the cdr of the last cons. Therefore, LIST may have any of the
1444 * forms that a formal argument can have:
1445 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
1447 c_improper_memq (SCM obj
, SCM list
)
1449 for (; scm_is_pair (list
); list
= SCM_CDR (list
))
1451 if (scm_is_eq (SCM_CAR (list
), obj
))
1454 return scm_is_eq (list
, obj
);
1458 scm_m_lambda (SCM expr
, SCM env SCM_UNUSED
)
1467 const SCM cdr_expr
= SCM_CDR (expr
);
1468 const long length
= scm_ilength (cdr_expr
);
1469 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1470 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1472 /* Before iterating the list of formal arguments, make sure the formals
1473 * actually are given as either a symbol or a non-cyclic list. */
1474 formals
= SCM_CAR (cdr_expr
);
1475 if (scm_is_pair (formals
))
1477 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
1478 * detected, report a 'Bad formals' error. */
1482 ASSERT_SYNTAX_2 (scm_is_symbol (formals
) || scm_is_null (formals
),
1483 s_bad_formals
, formals
, expr
);
1486 /* Now iterate the list of formal arguments to check if all formals are
1487 * symbols, and that there are no duplicates. */
1488 formals_idx
= formals
;
1489 while (scm_is_pair (formals_idx
))
1491 const SCM formal
= SCM_CAR (formals_idx
);
1492 const SCM next_idx
= SCM_CDR (formals_idx
);
1493 ASSERT_SYNTAX_2 (scm_is_symbol (formal
), s_bad_formal
, formal
, expr
);
1494 ASSERT_SYNTAX_2 (!c_improper_memq (formal
, next_idx
),
1495 s_duplicate_formal
, formal
, expr
);
1496 formals_idx
= next_idx
;
1498 ASSERT_SYNTAX_2 (scm_is_null (formals_idx
) || scm_is_symbol (formals_idx
),
1499 s_bad_formal
, formals_idx
, expr
);
1501 /* Memoize the body. Keep a potential documentation string. */
1502 /* Dirk:FIXME:: We should probably extract the documentation string to
1503 * some external database. Otherwise it will slow down execution, since
1504 * the documentation string will have to be skipped with every execution
1505 * of the closure. */
1506 cddr_expr
= SCM_CDR (cdr_expr
);
1507 documentation
= (length
>= 3 && scm_is_string (SCM_CAR (cddr_expr
)));
1508 body
= documentation
? SCM_CDR (cddr_expr
) : cddr_expr
;
1509 new_body
= m_body (SCM_IM_LAMBDA
, body
);
1511 SCM_SETCAR (expr
, SCM_IM_LAMBDA
);
1513 SCM_SETCDR (cddr_expr
, new_body
);
1515 SCM_SETCDR (cdr_expr
, new_body
);
1520 unmemoize_lambda (const SCM expr
, const SCM env
)
1522 const SCM formals
= SCM_CADR (expr
);
1523 const SCM body
= SCM_CDDR (expr
);
1525 const SCM new_env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, env
);
1526 const SCM um_formals
= scm_i_finite_list_copy (formals
);
1527 const SCM um_body
= unmemoize_exprs (body
, new_env
);
1529 return scm_cons2 (scm_sym_lambda
, um_formals
, um_body
);
1533 /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
1535 check_bindings (const SCM bindings
, const SCM expr
)
1539 ASSERT_SYNTAX_2 (scm_ilength (bindings
) >= 0,
1540 s_bad_bindings
, bindings
, expr
);
1542 binding_idx
= bindings
;
1543 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1545 SCM name
; /* const */
1547 const SCM binding
= SCM_CAR (binding_idx
);
1548 ASSERT_SYNTAX_2 (scm_ilength (binding
) == 2,
1549 s_bad_binding
, binding
, expr
);
1551 name
= SCM_CAR (binding
);
1552 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
1557 /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
1558 * transformed to the lists (vn ... v2 v1) and (i1 i2 ... in). That is, the
1559 * variables are returned in a list with their order reversed, and the init
1560 * forms are returned in a list in the same order as they are given in the
1561 * bindings. If a duplicate variable name is detected, an error is
1564 transform_bindings (
1565 const SCM bindings
, const SCM expr
,
1566 SCM
*const rvarptr
, SCM
*const initptr
)
1568 SCM rvariables
= SCM_EOL
;
1569 SCM rinits
= SCM_EOL
;
1570 SCM binding_idx
= bindings
;
1571 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1573 const SCM binding
= SCM_CAR (binding_idx
);
1574 const SCM cdr_binding
= SCM_CDR (binding
);
1575 const SCM name
= SCM_CAR (binding
);
1576 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, rvariables
)),
1577 s_duplicate_binding
, name
, expr
);
1578 rvariables
= scm_cons (name
, rvariables
);
1579 rinits
= scm_cons (SCM_CAR (cdr_binding
), rinits
);
1581 *rvarptr
= rvariables
;
1582 *initptr
= scm_reverse_x (rinits
, SCM_UNDEFINED
);
1586 SCM_SYNTAX(s_let
, "let", scm_i_makbimacro
, scm_m_let
);
1587 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
1589 /* This function is a helper function for memoize_let. It transforms
1590 * (let name ((var init) ...) body ...) into
1591 * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
1592 * and memoizes the expression. It is assumed that the caller has checked
1593 * that name is a symbol and that there are bindings and a body. */
1595 memoize_named_let (const SCM expr
, const SCM env SCM_UNUSED
)
1601 const SCM cdr_expr
= SCM_CDR (expr
);
1602 const SCM name
= SCM_CAR (cdr_expr
);
1603 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1604 const SCM bindings
= SCM_CAR (cddr_expr
);
1605 check_bindings (bindings
, expr
);
1607 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1608 variables
= scm_reverse_x (rvariables
, SCM_UNDEFINED
);
1611 const SCM let_body
= SCM_CDR (cddr_expr
);
1612 const SCM lambda_body
= m_body (SCM_IM_LET
, let_body
);
1613 const SCM lambda_tail
= scm_cons (variables
, lambda_body
);
1614 const SCM lambda_form
= scm_cons_source (expr
, scm_sym_lambda
, lambda_tail
);
1616 const SCM rvar
= scm_list_1 (name
);
1617 const SCM init
= scm_list_1 (lambda_form
);
1618 const SCM body
= m_body (SCM_IM_LET
, scm_list_1 (name
));
1619 const SCM letrec_tail
= scm_cons (rvar
, scm_cons (init
, body
));
1620 const SCM letrec_form
= scm_cons_source (expr
, SCM_IM_LETREC
, letrec_tail
);
1621 return scm_cons_source (expr
, letrec_form
, inits
);
1625 /* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1626 * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
1628 scm_m_let (SCM expr
, SCM env
)
1632 const SCM cdr_expr
= SCM_CDR (expr
);
1633 const long length
= scm_ilength (cdr_expr
);
1634 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1635 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1637 bindings
= SCM_CAR (cdr_expr
);
1638 if (scm_is_symbol (bindings
))
1640 ASSERT_SYNTAX (length
>= 3, s_missing_expression
, expr
);
1641 return memoize_named_let (expr
, env
);
1644 check_bindings (bindings
, expr
);
1645 if (scm_is_null (bindings
) || scm_is_null (SCM_CDR (bindings
)))
1647 /* Special case: no bindings or single binding => let* is faster. */
1648 const SCM body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1649 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), bindings
, body
), env
);
1656 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1659 const SCM new_body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1660 const SCM new_tail
= scm_cons2 (rvariables
, inits
, new_body
);
1661 SCM_SETCAR (expr
, SCM_IM_LET
);
1662 SCM_SETCDR (expr
, new_tail
);
1669 build_binding_list (SCM rnames
, SCM rinits
)
1671 SCM bindings
= SCM_EOL
;
1672 while (!scm_is_null (rnames
))
1674 const SCM binding
= scm_list_2 (SCM_CAR (rnames
), SCM_CAR (rinits
));
1675 bindings
= scm_cons (binding
, bindings
);
1676 rnames
= SCM_CDR (rnames
);
1677 rinits
= SCM_CDR (rinits
);
1683 unmemoize_let (const SCM expr
, const SCM env
)
1685 const SCM cdr_expr
= SCM_CDR (expr
);
1686 const SCM um_rnames
= SCM_CAR (cdr_expr
);
1687 const SCM extended_env
= SCM_EXTEND_ENV (um_rnames
, SCM_EOL
, env
);
1688 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1689 const SCM um_inits
= unmemoize_exprs (SCM_CAR (cddr_expr
), env
);
1690 const SCM um_rinits
= scm_reverse_x (um_inits
, SCM_UNDEFINED
);
1691 const SCM um_bindings
= build_binding_list (um_rnames
, um_rinits
);
1692 const SCM um_body
= unmemoize_exprs (SCM_CDR (cddr_expr
), extended_env
);
1694 return scm_cons2 (scm_sym_let
, um_bindings
, um_body
);
1698 SCM_SYNTAX(s_letrec
, "letrec", scm_i_makbimacro
, scm_m_letrec
);
1699 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
1702 scm_m_letrec (SCM expr
, SCM env
)
1706 const SCM cdr_expr
= SCM_CDR (expr
);
1707 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1708 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1710 bindings
= SCM_CAR (cdr_expr
);
1711 if (scm_is_null (bindings
))
1713 /* no bindings, let* is executed faster */
1714 SCM body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1715 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), SCM_EOL
, body
), env
);
1723 check_bindings (bindings
, expr
);
1724 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1725 new_body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1726 return scm_cons2 (SCM_IM_LETREC
, rvariables
, scm_cons (inits
, new_body
));
1731 unmemoize_letrec (const SCM expr
, const SCM env
)
1733 const SCM cdr_expr
= SCM_CDR (expr
);
1734 const SCM um_rnames
= SCM_CAR (cdr_expr
);
1735 const SCM extended_env
= SCM_EXTEND_ENV (um_rnames
, SCM_EOL
, env
);
1736 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1737 const SCM um_inits
= unmemoize_exprs (SCM_CAR (cddr_expr
), extended_env
);
1738 const SCM um_rinits
= scm_reverse_x (um_inits
, SCM_UNDEFINED
);
1739 const SCM um_bindings
= build_binding_list (um_rnames
, um_rinits
);
1740 const SCM um_body
= unmemoize_exprs (SCM_CDR (cddr_expr
), extended_env
);
1742 return scm_cons2 (scm_sym_letrec
, um_bindings
, um_body
);
1747 SCM_SYNTAX (s_letstar
, "let*", scm_i_makbimacro
, scm_m_letstar
);
1748 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
1750 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1751 * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
1753 scm_m_letstar (SCM expr
, SCM env SCM_UNUSED
)
1758 const SCM cdr_expr
= SCM_CDR (expr
);
1759 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1760 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1762 binding_idx
= SCM_CAR (cdr_expr
);
1763 check_bindings (binding_idx
, expr
);
1765 /* Transform ((v1 i1) (v2 i2) ...) into (v1 i1 v2 i2 ...). The
1766 * transformation is done in place. At the beginning of one iteration of
1767 * the loop the variable binding_idx holds the form
1768 * P1:( (vn . P2:(in . ())) . P3:( (vn+1 in+1) ... ) ),
1769 * where P1, P2 and P3 indicate the pairs, that are relevant for the
1770 * transformation. P1 and P2 are modified in the loop, P3 remains
1771 * untouched. After the execution of the loop, P1 will hold
1772 * P1:( vn . P2:(in . P3:( (vn+1 in+1) ... )) )
1773 * and binding_idx will hold P3. */
1774 while (!scm_is_null (binding_idx
))
1776 const SCM cdr_binding_idx
= SCM_CDR (binding_idx
); /* remember P3 */
1777 const SCM binding
= SCM_CAR (binding_idx
);
1778 const SCM name
= SCM_CAR (binding
);
1779 const SCM cdr_binding
= SCM_CDR (binding
);
1781 SCM_SETCDR (cdr_binding
, cdr_binding_idx
); /* update P2 */
1782 SCM_SETCAR (binding_idx
, name
); /* update P1 */
1783 SCM_SETCDR (binding_idx
, cdr_binding
); /* update P1 */
1785 binding_idx
= cdr_binding_idx
; /* continue with P3 */
1788 new_body
= m_body (SCM_IM_LETSTAR
, SCM_CDR (cdr_expr
));
1789 SCM_SETCAR (expr
, SCM_IM_LETSTAR
);
1790 /* the bindings have been changed in place */
1791 SCM_SETCDR (cdr_expr
, new_body
);
1796 unmemoize_letstar (const SCM expr
, const SCM env
)
1798 const SCM cdr_expr
= SCM_CDR (expr
);
1799 const SCM body
= SCM_CDR (cdr_expr
);
1800 SCM bindings
= SCM_CAR (cdr_expr
);
1801 SCM um_bindings
= SCM_EOL
;
1802 SCM extended_env
= env
;
1805 while (!scm_is_null (bindings
))
1807 const SCM variable
= SCM_CAR (bindings
);
1808 const SCM init
= SCM_CADR (bindings
);
1809 const SCM um_init
= unmemoize_expression (init
, extended_env
);
1810 um_bindings
= scm_cons (scm_list_2 (variable
, um_init
), um_bindings
);
1811 extended_env
= SCM_EXTEND_ENV (variable
, SCM_BOOL_F
, extended_env
);
1812 bindings
= SCM_CDDR (bindings
);
1814 um_bindings
= scm_reverse_x (um_bindings
, SCM_UNDEFINED
);
1816 um_body
= unmemoize_exprs (body
, extended_env
);
1818 return scm_cons2 (scm_sym_letstar
, um_bindings
, um_body
);
1822 SCM_SYNTAX (s_or
, "or", scm_i_makbimacro
, scm_m_or
);
1823 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
1826 scm_m_or (SCM expr
, SCM env SCM_UNUSED
)
1828 const SCM cdr_expr
= SCM_CDR (expr
);
1829 const long length
= scm_ilength (cdr_expr
);
1831 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1835 /* Special case: (or) is replaced by #f. */
1840 SCM_SETCAR (expr
, SCM_IM_OR
);
1846 unmemoize_or (const SCM expr
, const SCM env
)
1848 return scm_cons (scm_sym_or
, unmemoize_exprs (SCM_CDR (expr
), env
));
1852 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
1853 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
1854 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
1855 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
1857 /* Internal function to handle a quasiquotation: 'form' is the parameter in
1858 * the call (quasiquotation form), 'env' is the environment where unquoted
1859 * expressions will be evaluated, and 'depth' is the current quasiquotation
1860 * nesting level and is known to be greater than zero. */
1862 iqq (SCM form
, SCM env
, unsigned long int depth
)
1864 if (scm_is_pair (form
))
1866 const SCM tmp
= SCM_CAR (form
);
1867 if (scm_is_eq (tmp
, scm_sym_quasiquote
))
1869 const SCM args
= SCM_CDR (form
);
1870 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1871 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
1873 else if (scm_is_eq (tmp
, scm_sym_unquote
))
1875 const SCM args
= SCM_CDR (form
);
1876 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1878 return scm_eval_car (args
, env
);
1880 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
1882 else if (scm_is_pair (tmp
)
1883 && scm_is_eq (SCM_CAR (tmp
), scm_sym_uq_splicing
))
1885 const SCM args
= SCM_CDR (tmp
);
1886 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1889 const SCM list
= scm_eval_car (args
, env
);
1890 const SCM rest
= SCM_CDR (form
);
1891 ASSERT_SYNTAX_2 (scm_ilength (list
) >= 0,
1892 s_splicing
, list
, form
);
1893 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
1896 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
1897 iqq (SCM_CDR (form
), env
, depth
));
1900 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
1901 iqq (SCM_CDR (form
), env
, depth
));
1903 else if (scm_is_vector (form
))
1904 return scm_vector (iqq (scm_vector_to_list (form
), env
, depth
));
1910 scm_m_quasiquote (SCM expr
, SCM env
)
1912 const SCM cdr_expr
= SCM_CDR (expr
);
1913 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1914 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1915 return iqq (SCM_CAR (cdr_expr
), env
, 1);
1919 SCM_SYNTAX (s_quote
, "quote", scm_i_makbimacro
, scm_m_quote
);
1920 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
1923 scm_m_quote (SCM expr
, SCM env SCM_UNUSED
)
1927 const SCM cdr_expr
= SCM_CDR (expr
);
1928 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1929 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1930 quotee
= SCM_CAR (cdr_expr
);
1931 if (is_self_quoting_p (quotee
))
1934 SCM_SETCAR (expr
, SCM_IM_QUOTE
);
1935 SCM_SETCDR (expr
, quotee
);
1940 unmemoize_quote (const SCM expr
, const SCM env SCM_UNUSED
)
1942 return scm_list_2 (scm_sym_quote
, SCM_CDR (expr
));
1946 /* Will go into the RnRS module when Guile is factorized.
1947 SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
1948 static const char s_set_x
[] = "set!";
1949 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, s_set_x
);
1952 scm_m_set_x (SCM expr
, SCM env SCM_UNUSED
)
1957 const SCM cdr_expr
= SCM_CDR (expr
);
1958 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1959 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1960 variable
= SCM_CAR (cdr_expr
);
1962 /* Memoize the variable form. */
1963 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
1964 new_variable
= lookup_symbol (variable
, env
);
1965 /* Leave the memoization of unbound symbols to lazy memoization: */
1966 if (SCM_UNBNDP (new_variable
))
1967 new_variable
= variable
;
1969 SCM_SETCAR (expr
, SCM_IM_SET_X
);
1970 SCM_SETCAR (cdr_expr
, new_variable
);
1975 unmemoize_set_x (const SCM expr
, const SCM env
)
1977 return scm_cons (scm_sym_set_x
, unmemoize_exprs (SCM_CDR (expr
), env
));
1981 /* Start of the memoizers for non-R5RS builtin macros. */
1984 SCM_SYNTAX (s_atapply
, "@apply", scm_i_makbimacro
, scm_m_apply
);
1985 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1986 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1989 scm_m_apply (SCM expr
, SCM env SCM_UNUSED
)
1991 const SCM cdr_expr
= SCM_CDR (expr
);
1992 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1993 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_missing_expression
, expr
);
1995 SCM_SETCAR (expr
, SCM_IM_APPLY
);
2000 unmemoize_apply (const SCM expr
, const SCM env
)
2002 return scm_list_2 (scm_sym_atapply
, unmemoize_exprs (SCM_CDR (expr
), env
));
2006 SCM_SYNTAX (s_atbind
, "@bind", scm_i_makbimacro
, scm_m_atbind
);
2008 /* FIXME: The following explanation should go into the documentation: */
2009 /* (@bind ((var init) ...) body ...) will assign the values of the `init's to
2010 * the global variables named by `var's (symbols, not evaluated), creating
2011 * them if they don't exist, executes body, and then restores the previous
2012 * values of the `var's. Additionally, whenever control leaves body, the
2013 * values of the `var's are saved and restored when control returns. It is an
2014 * error when a symbol appears more than once among the `var's. All `init's
2015 * are evaluated before any `var' is set.
2017 * Think of this as `let' for dynamic scope.
2020 /* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into
2021 * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...).
2023 * FIXME - also implement `@bind*'.
2026 scm_m_atbind (SCM expr
, SCM env
)
2033 const SCM top_level
= scm_env_top_level (env
);
2035 const SCM cdr_expr
= SCM_CDR (expr
);
2036 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2037 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
2038 bindings
= SCM_CAR (cdr_expr
);
2039 check_bindings (bindings
, expr
);
2040 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
2042 for (variable_idx
= rvariables
;
2043 !scm_is_null (variable_idx
);
2044 variable_idx
= SCM_CDR (variable_idx
))
2046 /* The first call to scm_sym2var will look beyond the current module,
2047 * while the second call wont. */
2048 const SCM variable
= SCM_CAR (variable_idx
);
2049 SCM new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_F
);
2050 if (scm_is_false (new_variable
))
2051 new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_T
);
2052 SCM_SETCAR (variable_idx
, new_variable
);
2055 SCM_SETCAR (expr
, SCM_IM_BIND
);
2056 SCM_SETCAR (cdr_expr
, scm_cons (rvariables
, inits
));
2061 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_i_makbimacro
, scm_m_cont
);
2062 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, s_atcall_cc
);
2065 scm_m_cont (SCM expr
, SCM env SCM_UNUSED
)
2067 const SCM cdr_expr
= SCM_CDR (expr
);
2068 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2069 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2071 SCM_SETCAR (expr
, SCM_IM_CONT
);
2076 unmemoize_atcall_cc (const SCM expr
, const SCM env
)
2078 return scm_list_2 (scm_sym_atcall_cc
, unmemoize_exprs (SCM_CDR (expr
), env
));
2082 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_i_makbimacro
, scm_m_at_call_with_values
);
2083 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
2086 scm_m_at_call_with_values (SCM expr
, SCM env SCM_UNUSED
)
2088 const SCM cdr_expr
= SCM_CDR (expr
);
2089 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2090 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2092 SCM_SETCAR (expr
, SCM_IM_CALL_WITH_VALUES
);
2097 unmemoize_at_call_with_values (const SCM expr
, const SCM env
)
2099 return scm_list_2 (scm_sym_at_call_with_values
,
2100 unmemoize_exprs (SCM_CDR (expr
), env
));
2105 /* See futures.h for a comment why futures are not enabled.
2108 SCM_SYNTAX (s_future
, "future", scm_i_makbimacro
, scm_m_future
);
2109 SCM_GLOBAL_SYMBOL (scm_sym_future
, s_future
);
2111 /* Like promises, futures are implemented as closures with an empty
2112 * parameter list. Thus, (future <expression>) is transformed into
2113 * (#@future '() <expression>), where the empty list represents the
2114 * empty parameter list. This representation allows for easy creation
2115 * of the closure during evaluation. */
2117 scm_m_future (SCM expr
, SCM env
)
2119 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
2120 SCM_SETCAR (new_expr
, SCM_IM_FUTURE
);
2125 unmemoize_future (const SCM expr
, const SCM env
)
2127 const SCM thunk_expr
= SCM_CADDR (expr
);
2128 return scm_list_2 (scm_sym_future
, unmemoize_expression (thunk_expr
, env
));
2133 SCM_SYNTAX (s_gset_x
, "set!", scm_i_makbimacro
, scm_m_generalized_set_x
);
2134 SCM_SYMBOL (scm_sym_setter
, "setter");
2137 scm_m_generalized_set_x (SCM expr
, SCM env
)
2139 SCM target
, exp_target
;
2141 const SCM cdr_expr
= SCM_CDR (expr
);
2142 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2143 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2145 target
= SCM_CAR (cdr_expr
);
2146 if (!scm_is_pair (target
))
2149 return scm_m_set_x (expr
, env
);
2153 /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */
2154 /* Macroexpanding the target might return things of the form
2155 (begin <atom>). In that case, <atom> must be a symbol or a
2156 variable and we memoize to (set! <atom> ...).
2158 exp_target
= macroexp (target
, env
);
2159 if (scm_is_eq (SCM_CAR (exp_target
), SCM_IM_BEGIN
)
2160 && !scm_is_null (SCM_CDR (exp_target
))
2161 && scm_is_null (SCM_CDDR (exp_target
)))
2163 exp_target
= SCM_CADR (exp_target
);
2164 ASSERT_SYNTAX_2 (scm_is_symbol (exp_target
)
2165 || SCM_VARIABLEP (exp_target
),
2166 s_bad_variable
, exp_target
, expr
);
2167 return scm_cons (SCM_IM_SET_X
, scm_cons (exp_target
,
2168 SCM_CDR (cdr_expr
)));
2172 const SCM setter_proc_tail
= scm_list_1 (SCM_CAR (target
));
2173 const SCM setter_proc
= scm_cons_source (expr
, scm_sym_setter
,
2176 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
2177 const SCM setter_args
= scm_append_x (scm_list_2 (SCM_CDR (target
),
2180 SCM_SETCAR (expr
, setter_proc
);
2181 SCM_SETCDR (expr
, setter_args
);
2188 /* @slot-ref is bound privately in the (oop goops) module from goops.c. As
2189 * soon as the module system allows us to more freely create bindings in
2190 * arbitrary modules during the startup phase, the code from goops.c should be
2193 SCM_SYMBOL (sym_atslot_ref
, "@slot-ref");
2196 scm_m_atslot_ref (SCM expr
, SCM env SCM_UNUSED
)
2200 const SCM cdr_expr
= SCM_CDR (expr
);
2201 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2202 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2203 slot_nr
= SCM_CADR (cdr_expr
);
2204 ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2206 SCM_SETCAR (expr
, SCM_IM_SLOT_REF
);
2207 SCM_SETCDR (cdr_expr
, slot_nr
);
2212 unmemoize_atslot_ref (const SCM expr
, const SCM env
)
2214 const SCM instance
= SCM_CADR (expr
);
2215 const SCM um_instance
= unmemoize_expression (instance
, env
);
2216 const SCM slot_nr
= SCM_CDDR (expr
);
2217 return scm_list_3 (sym_atslot_ref
, um_instance
, slot_nr
);
2221 /* @slot-set! is bound privately in the (oop goops) module from goops.c. As
2222 * soon as the module system allows us to more freely create bindings in
2223 * arbitrary modules during the startup phase, the code from goops.c should be
2226 SCM_SYMBOL (sym_atslot_set_x
, "@slot-set!");
2229 scm_m_atslot_set_x (SCM expr
, SCM env SCM_UNUSED
)
2233 const SCM cdr_expr
= SCM_CDR (expr
);
2234 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2235 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 3, s_expression
, expr
);
2236 slot_nr
= SCM_CADR (cdr_expr
);
2237 ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2239 SCM_SETCAR (expr
, SCM_IM_SLOT_SET_X
);
2244 unmemoize_atslot_set_x (const SCM expr
, const SCM env
)
2246 const SCM cdr_expr
= SCM_CDR (expr
);
2247 const SCM instance
= SCM_CAR (cdr_expr
);
2248 const SCM um_instance
= unmemoize_expression (instance
, env
);
2249 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
2250 const SCM slot_nr
= SCM_CAR (cddr_expr
);
2251 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
2252 const SCM value
= SCM_CAR (cdddr_expr
);
2253 const SCM um_value
= unmemoize_expression (value
, env
);
2254 return scm_list_4 (sym_atslot_set_x
, um_instance
, slot_nr
, um_value
);
2258 #if SCM_ENABLE_ELISP
2260 static const char s_defun
[] = "Symbol's function definition is void";
2262 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_i_makbimacro
, scm_m_nil_cond
);
2264 /* nil-cond expressions have the form
2265 * (nil-cond COND VAL COND VAL ... ELSEVAL) */
2267 scm_m_nil_cond (SCM expr
, SCM env SCM_UNUSED
)
2269 const long length
= scm_ilength (SCM_CDR (expr
));
2270 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
2271 ASSERT_SYNTAX (length
>= 1 && (length
% 2) == 1, s_expression
, expr
);
2273 SCM_SETCAR (expr
, SCM_IM_NIL_COND
);
2278 SCM_SYNTAX (s_atfop
, "@fop", scm_i_makbimacro
, scm_m_atfop
);
2280 /* The @fop-macro handles procedure and macro applications for elisp. The
2281 * input expression must have the form
2282 * (@fop <var> (transformer-macro <expr> ...))
2283 * where <var> must be a symbol. The expression is transformed into the
2284 * memoized form of either
2285 * (apply <un-aliased var> (transformer-macro <expr> ...))
2286 * if the value of var (across all aliasing) is not a macro, or
2287 * (<un-aliased var> <expr> ...)
2288 * if var is a macro. */
2290 scm_m_atfop (SCM expr
, SCM env SCM_UNUSED
)
2295 const SCM cdr_expr
= SCM_CDR (expr
);
2296 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2297 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 1, s_missing_expression
, expr
);
2299 symbol
= SCM_CAR (cdr_expr
);
2300 ASSERT_SYNTAX_2 (scm_is_symbol (symbol
), s_bad_variable
, symbol
, expr
);
2302 location
= scm_symbol_fref (symbol
);
2303 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2305 /* The elisp function `defalias' allows to define aliases for symbols. To
2306 * look up such definitions, the chain of symbol definitions has to be
2307 * followed up to the terminal symbol. */
2308 while (scm_is_symbol (SCM_VARIABLE_REF (location
)))
2310 const SCM alias
= SCM_VARIABLE_REF (location
);
2311 location
= scm_symbol_fref (alias
);
2312 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2315 /* Memoize the value location belonging to the terminal symbol. */
2316 SCM_SETCAR (cdr_expr
, location
);
2318 if (!SCM_MACROP (SCM_VARIABLE_REF (location
)))
2320 /* Since the location does not contain a macro, the form is a procedure
2321 * application. Replace `@fop' by `@apply' and transform the expression
2322 * including the `transformer-macro'. */
2323 SCM_SETCAR (expr
, SCM_IM_APPLY
);
2328 /* Since the location contains a macro, the arguments should not be
2329 * transformed, so the `transformer-macro' is cut out. The resulting
2330 * expression starts with the memoized variable, that is at the cdr of
2331 * the input expression. */
2332 SCM_SETCDR (cdr_expr
, SCM_CDADR (cdr_expr
));
2337 #endif /* SCM_ENABLE_ELISP */
2341 unmemoize_builtin_macro (const SCM expr
, const SCM env
)
2343 switch (ISYMNUM (SCM_CAR (expr
)))
2345 case (ISYMNUM (SCM_IM_AND
)):
2346 return unmemoize_and (expr
, env
);
2348 case (ISYMNUM (SCM_IM_BEGIN
)):
2349 return unmemoize_begin (expr
, env
);
2351 case (ISYMNUM (SCM_IM_CASE
)):
2352 return unmemoize_case (expr
, env
);
2354 case (ISYMNUM (SCM_IM_COND
)):
2355 return unmemoize_cond (expr
, env
);
2357 case (ISYMNUM (SCM_IM_DELAY
)):
2358 return unmemoize_delay (expr
, env
);
2360 case (ISYMNUM (SCM_IM_DO
)):
2361 return unmemoize_do (expr
, env
);
2363 case (ISYMNUM (SCM_IM_IF
)):
2364 return unmemoize_if (expr
, env
);
2366 case (ISYMNUM (SCM_IM_LAMBDA
)):
2367 return unmemoize_lambda (expr
, env
);
2369 case (ISYMNUM (SCM_IM_LET
)):
2370 return unmemoize_let (expr
, env
);
2372 case (ISYMNUM (SCM_IM_LETREC
)):
2373 return unmemoize_letrec (expr
, env
);
2375 case (ISYMNUM (SCM_IM_LETSTAR
)):
2376 return unmemoize_letstar (expr
, env
);
2378 case (ISYMNUM (SCM_IM_OR
)):
2379 return unmemoize_or (expr
, env
);
2381 case (ISYMNUM (SCM_IM_QUOTE
)):
2382 return unmemoize_quote (expr
, env
);
2384 case (ISYMNUM (SCM_IM_SET_X
)):
2385 return unmemoize_set_x (expr
, env
);
2387 case (ISYMNUM (SCM_IM_APPLY
)):
2388 return unmemoize_apply (expr
, env
);
2390 case (ISYMNUM (SCM_IM_BIND
)):
2391 return unmemoize_exprs (expr
, env
); /* FIXME */
2393 case (ISYMNUM (SCM_IM_CONT
)):
2394 return unmemoize_atcall_cc (expr
, env
);
2396 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2397 return unmemoize_at_call_with_values (expr
, env
);
2400 /* See futures.h for a comment why futures are not enabled.
2402 case (ISYMNUM (SCM_IM_FUTURE
)):
2403 return unmemoize_future (expr
, env
);
2406 case (ISYMNUM (SCM_IM_SLOT_REF
)):
2407 return unmemoize_atslot_ref (expr
, env
);
2409 case (ISYMNUM (SCM_IM_SLOT_SET_X
)):
2410 return unmemoize_atslot_set_x (expr
, env
);
2412 case (ISYMNUM (SCM_IM_NIL_COND
)):
2413 return unmemoize_exprs (expr
, env
); /* FIXME */
2416 return unmemoize_exprs (expr
, env
); /* FIXME */
2421 /* scm_i_unmemocopy_expr and scm_i_unmemocopy_body take a memoized expression
2422 * respectively a memoized body together with its environment and rewrite it
2423 * to its original form. Thus, these functions are the inversion of the
2424 * rewrite rules above. The procedure is not optimized for speed. It's used
2425 * in scm_i_unmemoize_expr, scm_procedure_source, macro_print and scm_iprin1.
2427 * Unmemoizing is not a reliable process. You cannot in general expect to get
2428 * the original source back.
2430 * However, GOOPS currently relies on this for method compilation. This ought
2434 scm_i_unmemocopy_expr (SCM expr
, SCM env
)
2436 const SCM source_properties
= scm_whash_lookup (scm_source_whash
, expr
);
2437 const SCM um_expr
= unmemoize_expression (expr
, env
);
2439 if (scm_is_true (source_properties
))
2440 scm_whash_insert (scm_source_whash
, um_expr
, source_properties
);
2446 scm_i_unmemocopy_body (SCM forms
, SCM env
)
2448 const SCM source_properties
= scm_whash_lookup (scm_source_whash
, forms
);
2449 const SCM um_forms
= unmemoize_exprs (forms
, env
);
2451 if (scm_is_true (source_properties
))
2452 scm_whash_insert (scm_source_whash
, um_forms
, source_properties
);
2458 #if (SCM_ENABLE_DEPRECATED == 1)
2460 /* Deprecated in guile 1.7.0 on 2003-11-09. */
2462 scm_m_expand_body (SCM exprs
, SCM env
)
2464 scm_c_issue_deprecation_warning
2465 ("`scm_m_expand_body' is deprecated.");
2466 m_expand_body (exprs
, env
);
2471 SCM_SYNTAX (s_undefine
, "undefine", scm_makacro
, scm_m_undefine
);
2474 scm_m_undefine (SCM expr
, SCM env
)
2479 const SCM cdr_expr
= SCM_CDR (expr
);
2480 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), "Bad undefine placement in", expr
);
2481 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2482 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2484 scm_c_issue_deprecation_warning
2485 ("`undefine' is deprecated.\n");
2487 variable
= SCM_CAR (cdr_expr
);
2488 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
2489 location
= scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_F
);
2490 ASSERT_SYNTAX_2 (scm_is_true (location
)
2491 && !SCM_UNBNDP (SCM_VARIABLE_REF (location
)),
2492 "variable already unbound ", variable
, expr
);
2493 SCM_VARIABLE_SET (location
, SCM_UNDEFINED
);
2494 return SCM_UNSPECIFIED
;
2498 scm_macroexp (SCM x
, SCM env
)
2500 scm_c_issue_deprecation_warning
2501 ("`scm_macroexp' is deprecated.");
2502 return macroexp (x
, env
);
2508 #if (SCM_ENABLE_DEPRECATED == 1)
2511 scm_unmemocar (SCM form
, SCM env
)
2513 scm_c_issue_deprecation_warning
2514 ("`scm_unmemocar' is deprecated.");
2516 if (!scm_is_pair (form
))
2520 SCM c
= SCM_CAR (form
);
2521 if (SCM_VARIABLEP (c
))
2523 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
2524 if (scm_is_false (sym
))
2525 sym
= sym_three_question_marks
;
2526 SCM_SETCAR (form
, sym
);
2528 else if (SCM_ILOCP (c
))
2530 unsigned long int ir
;
2532 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
2533 env
= SCM_CDR (env
);
2534 env
= SCM_CAAR (env
);
2535 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
2536 env
= SCM_CDR (env
);
2538 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
2546 /*****************************************************************************/
2547 /*****************************************************************************/
2548 /* The definitions for execution start here. */
2549 /*****************************************************************************/
2550 /*****************************************************************************/
2552 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
2553 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
2554 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
2555 SCM_GLOBAL_SYMBOL (scm_sym_memoize_symbol
, "memoize-symbol");
2556 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
2557 SCM_SYMBOL (sym_instead
, "instead");
2559 /* A function object to implement "apply" for non-closure functions. */
2561 /* An endless list consisting of #<undefined> objects: */
2562 static SCM undefineds
;
2566 scm_badargsp (SCM formals
, SCM args
)
2568 while (!scm_is_null (formals
))
2570 if (!scm_is_pair (formals
))
2572 if (scm_is_null (args
))
2574 formals
= SCM_CDR (formals
);
2575 args
= SCM_CDR (args
);
2577 return !scm_is_null (args
) ? 1 : 0;
2582 /* The evaluator contains a plethora of EVAL symbols.
2585 * SCM_I_EVALIM is used when it is known that the expression is an
2586 * immediate. (This macro never calls an evaluator.)
2588 * SCM_I_XEVAL evaluates an expression that is expected to have its symbols already
2589 * memoized. Expressions that are not of the form '(<form> <form> ...)' are
2590 * evaluated inline without calling an evaluator.
2592 * This macro uses ceval or deval depending on its 3rd argument.
2594 * SCM_I_XEVALCAR evaluates the car of an expression 'X:(Y:<form> <form> ...)',
2595 * potentially replacing a symbol at the position Y:<form> by its memoized
2596 * variable. If Y:<form> is not of the form '(<form> <form> ...)', the
2597 * evaluation is performed inline without calling an evaluator.
2599 * This macro uses ceval or deval depending on its 3rd argument.
2603 #define SCM_I_EVALIM2(x) \
2604 ((scm_is_eq ((x), SCM_EOL) \
2605 ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \
2609 #define SCM_I_EVALIM(x, env) (SCM_ILOCP (x) \
2610 ? *scm_ilookup ((x), (env)) \
2613 #define SCM_I_XEVAL(x, env, debug_p) \
2615 ? SCM_I_EVALIM2 (x) \
2616 : (SCM_VARIABLEP (x) \
2617 ? SCM_VARIABLE_REF (x) \
2618 : (scm_is_pair (x) \
2620 ? deval ((x), (env)) \
2621 : ceval ((x), (env))) \
2624 #define SCM_I_XEVALCAR(x, env, debug_p) \
2625 (SCM_IMP (SCM_CAR (x)) \
2626 ? SCM_I_EVALIM (SCM_CAR (x), (env)) \
2627 : (SCM_VARIABLEP (SCM_CAR (x)) \
2628 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2629 : (scm_is_pair (SCM_CAR (x)) \
2631 ? deval (SCM_CAR (x), (env)) \
2632 : ceval (SCM_CAR (x), (env))) \
2633 : (!scm_is_symbol (SCM_CAR (x)) \
2635 : *scm_lookupcar ((x), (env), 1)))))
2637 scm_i_pthread_mutex_t source_mutex
;
2640 /* Lookup a given local variable in an environment. The local variable is
2641 * given as an iloc, that is a triple <frame, binding, last?>, where frame
2642 * indicates the relative number of the environment frame (counting upwards
2643 * from the innermost environment frame), binding indicates the number of the
2644 * binding within the frame, and last? (which is extracted from the iloc using
2645 * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
2646 * very end of the improper list of bindings. */
2648 scm_ilookup (SCM iloc
, SCM env
)
2650 unsigned int frame_nr
= SCM_IFRAME (iloc
);
2651 unsigned int binding_nr
= SCM_IDIST (iloc
);
2655 for (; 0 != frame_nr
; --frame_nr
)
2656 frames
= SCM_CDR (frames
);
2658 bindings
= SCM_CAR (frames
);
2659 for (; 0 != binding_nr
; --binding_nr
)
2660 bindings
= SCM_CDR (bindings
);
2662 if (SCM_ICDRP (iloc
))
2663 return SCM_CDRLOC (bindings
);
2664 return SCM_CARLOC (SCM_CDR (bindings
));
2668 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
2670 static void error_unbound_variable (SCM symbol
) SCM_NORETURN
;
2671 static void error_defined_variable (SCM symbol
) SCM_NORETURN
;
2673 /* Call this for variables that are unfound.
2676 error_unbound_variable (SCM symbol
)
2678 scm_error (scm_unbound_variable_key
, NULL
,
2679 "Unbound variable: ~S",
2680 scm_list_1 (symbol
), SCM_BOOL_F
);
2683 /* Call this for variables that are found but contain SCM_UNDEFINED.
2686 error_defined_variable (SCM symbol
)
2688 /* We use the 'unbound-variable' key here as well, since it
2689 basically is the same kind of error, with a slight variation in
2690 the displayed message.
2692 scm_error (scm_unbound_variable_key
, NULL
,
2693 "Variable used before given a value: ~S",
2694 scm_list_1 (symbol
), SCM_BOOL_F
);
2698 /* The Lookup Car Race
2701 Memoization of variables and special forms is done while executing
2702 the code for the first time. As long as there is only one thread
2703 everything is fine, but as soon as two threads execute the same
2704 code concurrently `for the first time' they can come into conflict.
2706 This memoization includes rewriting variable references into more
2707 efficient forms and expanding macros. Furthermore, macro expansion
2708 includes `compiling' special forms like `let', `cond', etc. into
2709 tree-code instructions.
2711 There shouldn't normally be a problem with memoizing local and
2712 global variable references (into ilocs and variables), because all
2713 threads will mutate the code in *exactly* the same way and (if I
2714 read the C code correctly) it is not possible to observe a half-way
2715 mutated cons cell. The lookup procedure can handle this
2716 transparently without any critical sections.
2718 It is different with macro expansion, because macro expansion
2719 happens outside of the lookup procedure and can't be
2720 undone. Therefore the lookup procedure can't cope with it. It has
2721 to indicate failure when it detects a lost race and hope that the
2722 caller can handle it. Luckily, it turns out that this is the case.
2724 An example to illustrate this: Suppose that the following form will
2725 be memoized concurrently by two threads
2729 Let's first examine the lookup of X in the body. The first thread
2730 decides that it has to find the symbol "x" in the environment and
2731 starts to scan it. Then the other thread takes over and actually
2732 overtakes the first. It looks up "x" and substitutes an
2733 appropriate iloc for it. Now the first thread continues and
2734 completes its lookup. It comes to exactly the same conclusions as
2735 the second one and could - without much ado - just overwrite the
2736 iloc with the same iloc.
2738 But let's see what will happen when the race occurs while looking
2739 up the symbol "let" at the start of the form. It could happen that
2740 the second thread interrupts the lookup of the first thread and not
2741 only substitutes a variable for it but goes right ahead and
2742 replaces it with the compiled form (#@let* (x 12) x). Now, when
2743 the first thread completes its lookup, it would replace the #@let*
2744 with a variable containing the "let" binding, effectively reverting
2745 the form to (let (x 12) x). This is wrong. It has to detect that
2746 it has lost the race and the evaluator has to reconsider the
2747 changed form completely.
2749 This race condition could be resolved with some kind of traffic
2750 light (like mutexes) around scm_lookupcar, but I think that it is
2751 best to avoid them in this case. They would serialize memoization
2752 completely and because lookup involves calling arbitrary Scheme
2753 code (via the lookup-thunk), threads could be blocked for an
2754 arbitrary amount of time or even deadlock. But with the current
2755 solution a lot of unnecessary work is potentially done. */
2757 /* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
2758 return NULL to indicate a failed lookup due to some race conditions
2759 between threads. This only happens when VLOC is the first cell of
2760 a special form that will eventually be memoized (like `let', etc.)
2761 In that case the whole lookup is bogus and the caller has to
2762 reconsider the complete special form.
2764 SCM_LOOKUPCAR is still there, of course. It just calls
2765 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
2766 should only be called when it is known that VLOC is not the first
2767 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
2768 for NULL. I think I've found the only places where this
2772 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
2775 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
2776 register SCM iloc
= SCM_ILOC00
;
2777 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
2779 if (!scm_is_pair (SCM_CAR (env
)))
2781 al
= SCM_CARLOC (env
);
2782 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
2784 if (!scm_is_pair (fl
))
2786 if (scm_is_eq (fl
, var
))
2788 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2790 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
2791 return SCM_CDRLOC (*al
);
2796 al
= SCM_CDRLOC (*al
);
2797 if (scm_is_eq (SCM_CAR (fl
), var
))
2799 if (SCM_UNBNDP (SCM_CAR (*al
)))
2800 error_defined_variable (var
);
2801 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2803 SCM_SETCAR (vloc
, iloc
);
2804 return SCM_CARLOC (*al
);
2806 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
2808 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
2811 SCM top_thunk
, real_var
;
2814 top_thunk
= SCM_CAR (env
); /* env now refers to a
2815 top level env thunk */
2816 env
= SCM_CDR (env
);
2819 top_thunk
= SCM_BOOL_F
;
2820 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
2821 if (scm_is_false (real_var
))
2824 if (!scm_is_null (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
2829 if (scm_is_null (env
))
2830 error_unbound_variable (var
);
2832 scm_misc_error (NULL
, "Damaged environment: ~S",
2837 /* A variable could not be found, but we shall
2838 not throw an error. */
2839 static SCM undef_object
= SCM_UNDEFINED
;
2840 return &undef_object
;
2844 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2846 /* Some other thread has changed the very cell we are working
2847 on. In effect, it must have done our job or messed it up
2850 var
= SCM_CAR (vloc
);
2851 if (SCM_VARIABLEP (var
))
2852 return SCM_VARIABLE_LOC (var
);
2853 if (SCM_ILOCP (var
))
2854 return scm_ilookup (var
, genv
);
2855 /* We can't cope with anything else than variables and ilocs. When
2856 a special form has been memoized (i.e. `let' into `#@let') we
2857 return NULL and expect the calling function to do the right
2858 thing. For the evaluator, this means going back and redoing
2859 the dispatch on the car of the form. */
2863 SCM_SETCAR (vloc
, real_var
);
2864 return SCM_VARIABLE_LOC (real_var
);
2869 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
2871 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
2878 /* During execution, look up a symbol in the top level of the given local
2879 * environment and return the corresponding variable object. If no binding
2880 * for the symbol can be found, an 'Unbound variable' error is signalled. */
2882 lazy_memoize_variable (const SCM symbol
, const SCM environment
)
2884 const SCM top_level
= scm_env_top_level (environment
);
2885 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
2887 if (scm_is_false (variable
))
2888 error_unbound_variable (symbol
);
2895 scm_eval_car (SCM pair
, SCM env
)
2897 return SCM_I_XEVALCAR (pair
, env
, scm_debug_mode_p
);
2902 scm_eval_body (SCM code
, SCM env
)
2907 next
= SCM_CDR (code
);
2908 while (!scm_is_null (next
))
2910 if (SCM_IMP (SCM_CAR (code
)))
2912 if (SCM_ISYMP (SCM_CAR (code
)))
2914 scm_dynwind_begin (0);
2915 scm_i_dynwind_pthread_mutex_lock (&source_mutex
);
2916 /* check for race condition */
2917 if (SCM_ISYMP (SCM_CAR (code
)))
2918 m_expand_body (code
, env
);
2924 SCM_I_XEVAL (SCM_CAR (code
), env
, scm_debug_mode_p
);
2926 next
= SCM_CDR (code
);
2928 return SCM_I_XEVALCAR (code
, env
, scm_debug_mode_p
);
2932 /* scm_last_debug_frame contains a pointer to the last debugging information
2933 * stack frame. It is accessed very often from the debugging evaluator, so it
2934 * should probably not be indirectly addressed. Better to save and restore it
2935 * from the current root at any stack swaps.
2938 /* scm_debug_eframe_size is the number of slots available for pseudo
2939 * stack frames at each real stack frame.
2942 long scm_debug_eframe_size
;
2944 int scm_debug_mode_p
;
2945 int scm_check_entry_p
;
2946 int scm_check_apply_p
;
2947 int scm_check_exit_p
;
2948 int scm_check_memoize_p
;
2950 long scm_eval_stack
;
2952 scm_t_option scm_eval_opts
[] = {
2953 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." },
2957 scm_t_option scm_debug_opts
[] = {
2958 { SCM_OPTION_BOOLEAN
, "cheap", 1,
2959 "*This option is now obsolete. Setting it has no effect." },
2960 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
2961 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
2962 { SCM_OPTION_BOOLEAN
, "procnames", 1,
2963 "Record procedure names at definition." },
2964 { SCM_OPTION_BOOLEAN
, "backwards", 0,
2965 "Display backtrace in anti-chronological order." },
2966 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
2967 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
2968 { SCM_OPTION_INTEGER
, "frames", 3,
2969 "Maximum number of tail-recursive frames in backtrace." },
2970 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
2971 "Maximal number of stored backtrace frames." },
2972 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
2973 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
2974 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
2976 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
2977 { SCM_OPTION_SCM
, "show-file-name", (unsigned long)SCM_BOOL_T
,
2978 "Show file names and line numbers "
2979 "in backtraces when not `#f'. A value of `base' "
2980 "displays only base names, while `#t' displays full names."},
2981 { SCM_OPTION_BOOLEAN
, "warn-deprecated", 0,
2982 "Warn when deprecated features are used." },
2988 * this ordering is awkward and illogical, but we maintain it for
2989 * compatibility. --hwn
2991 scm_t_option scm_evaluator_trap_table
[] = {
2992 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
2993 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
2994 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
2995 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
2996 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
2997 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
2998 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." },
2999 { SCM_OPTION_BOOLEAN
, "memoize-symbol", 0, "Trap when memoizing a symbol." },
3000 { SCM_OPTION_SCM
, "memoize-symbol-handler", (unsigned long)SCM_BOOL_F
, "The handler for memoization." },
3005 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
3007 "Option interface for the evaluation options. Instead of using\n"
3008 "this procedure directly, use the procedures @code{eval-enable},\n"
3009 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
3010 #define FUNC_NAME s_scm_eval_options_interface
3014 scm_dynwind_begin (0);
3015 scm_dynwind_critical_section (SCM_BOOL_F
);
3016 ans
= scm_options (setting
,
3019 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
3027 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
3029 "Option interface for the evaluator trap options.")
3030 #define FUNC_NAME s_scm_evaluator_traps
3035 scm_options_try (setting
,
3036 scm_evaluator_trap_table
,
3038 SCM_CRITICAL_SECTION_START
;
3039 ans
= scm_options (setting
,
3040 scm_evaluator_trap_table
,
3043 /* njrev: same again. */
3044 SCM_RESET_DEBUG_MODE
;
3045 SCM_CRITICAL_SECTION_END
;
3054 /* Simple procedure calls
3058 scm_call_0 (SCM proc
)
3060 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
3064 scm_call_1 (SCM proc
, SCM arg1
)
3066 return scm_apply (proc
, arg1
, scm_listofnull
);
3070 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
3072 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
3076 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
3078 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
3082 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
3084 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
3085 scm_cons (arg4
, scm_listofnull
)));
3088 /* Simple procedure applies
3092 scm_apply_0 (SCM proc
, SCM args
)
3094 return scm_apply (proc
, args
, SCM_EOL
);
3098 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
3100 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
3104 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
3106 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
3110 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
3112 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
3116 /* This code processes the arguments to apply:
3118 (apply PROC ARG1 ... ARGS)
3120 Given a list (ARG1 ... ARGS), this function conses the ARG1
3121 ... arguments onto the front of ARGS, and returns the resulting
3122 list. Note that ARGS is a list; thus, the argument to this
3123 function is a list whose last element is a list.
3125 Apply calls this function, and applies PROC to the elements of the
3126 result. apply:nconc2last takes care of building the list of
3127 arguments, given (ARG1 ... ARGS).
3129 Rather than do new consing, apply:nconc2last destroys its argument.
3130 On that topic, this code came into my care with the following
3131 beautifully cryptic comment on that topic: "This will only screw
3132 you if you do (scm_apply scm_apply '( ... ))" If you know what
3133 they're referring to, send me a patch to this comment. */
3135 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3137 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
3138 "conses the @var{arg1} @dots{} arguments onto the front of\n"
3139 "@var{args}, and returns the resulting list. Note that\n"
3140 "@var{args} is a list; thus, the argument to this function is\n"
3141 "a list whose last element is a list.\n"
3142 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
3143 "destroys its argument, so use with care.")
3144 #define FUNC_NAME s_scm_nconc2last
3147 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
3149 while (!scm_is_null (SCM_CDR (*lloc
))) /* Perhaps should be
3150 SCM_NULL_OR_NIL_P, but not
3151 needed in 99.99% of cases,
3152 and it could seriously hurt
3153 performance. - Neil */
3154 lloc
= SCM_CDRLOC (*lloc
);
3155 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3156 *lloc
= SCM_CAR (*lloc
);
3163 /* SECTION: The rest of this file is only read once.
3168 * Trampolines make it possible to move procedure application dispatch
3169 * outside inner loops. The motivation was clean implementation of
3170 * efficient replacements of R5RS primitives in SRFI-1.
3172 * The semantics is clear: scm_trampoline_N returns an optimized
3173 * version of scm_call_N (or NULL if the procedure isn't applicable
3176 * Applying the optimization to map and for-each increased efficiency
3177 * noticeably. For example, (map abs ls) is now 8 times faster than
3182 call_subr0_0 (SCM proc
)
3184 return SCM_SUBRF (proc
) ();
3188 call_subr1o_0 (SCM proc
)
3190 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
3194 call_lsubr_0 (SCM proc
)
3196 return SCM_SUBRF (proc
) (SCM_EOL
);
3200 scm_i_call_closure_0 (SCM proc
)
3202 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3205 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
3210 scm_trampoline_0 (SCM proc
)
3212 scm_t_trampoline_0 trampoline
;
3217 switch (SCM_TYP7 (proc
))
3219 case scm_tc7_subr_0
:
3220 trampoline
= call_subr0_0
;
3222 case scm_tc7_subr_1o
:
3223 trampoline
= call_subr1o_0
;
3226 trampoline
= call_lsubr_0
;
3228 case scm_tcs_closures
:
3230 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3231 if (scm_is_null (formals
) || !scm_is_pair (formals
))
3232 trampoline
= scm_i_call_closure_0
;
3237 case scm_tcs_struct
:
3238 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3239 trampoline
= scm_call_generic_0
;
3240 else if (SCM_I_OPERATORP (proc
))
3241 trampoline
= scm_call_0
;
3246 if (SCM_SMOB_APPLICABLE_P (proc
))
3247 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
3252 case scm_tc7_rpsubr
:
3255 trampoline
= scm_call_0
;
3258 return NULL
; /* not applicable on zero arguments */
3260 /* We only reach this point if a valid trampoline was determined. */
3262 /* If debugging is enabled, we want to see all calls to proc on the stack.
3263 * Thus, we replace the trampoline shortcut with scm_call_0. */
3264 if (scm_debug_mode_p
)
3271 call_subr1_1 (SCM proc
, SCM arg1
)
3273 return SCM_SUBRF (proc
) (arg1
);
3277 call_subr2o_1 (SCM proc
, SCM arg1
)
3279 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
3283 call_lsubr_1 (SCM proc
, SCM arg1
)
3285 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
3289 call_dsubr_1 (SCM proc
, SCM arg1
)
3291 if (SCM_I_INUMP (arg1
))
3293 return (scm_from_double (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
))));
3295 else if (SCM_REALP (arg1
))
3297 return (scm_from_double (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3299 else if (SCM_BIGP (arg1
))
3301 return (scm_from_double (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3303 else if (SCM_FRACTIONP (arg1
))
3305 return (scm_from_double (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
3307 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3308 SCM_ARG1
, scm_i_symbol_chars (SCM_SNAME (proc
)));
3312 call_cxr_1 (SCM proc
, SCM arg1
)
3314 return scm_i_chase_pairs (arg1
, (scm_t_bits
) SCM_SUBRF (proc
));
3318 call_closure_1 (SCM proc
, SCM arg1
)
3320 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3323 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
3328 scm_trampoline_1 (SCM proc
)
3330 scm_t_trampoline_1 trampoline
;
3335 switch (SCM_TYP7 (proc
))
3337 case scm_tc7_subr_1
:
3338 case scm_tc7_subr_1o
:
3339 trampoline
= call_subr1_1
;
3341 case scm_tc7_subr_2o
:
3342 trampoline
= call_subr2o_1
;
3345 trampoline
= call_lsubr_1
;
3348 trampoline
= call_dsubr_1
;
3351 trampoline
= call_cxr_1
;
3353 case scm_tcs_closures
:
3355 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3356 if (!scm_is_null (formals
)
3357 && (!scm_is_pair (formals
) || !scm_is_pair (SCM_CDR (formals
))))
3358 trampoline
= call_closure_1
;
3363 case scm_tcs_struct
:
3364 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3365 trampoline
= scm_call_generic_1
;
3366 else if (SCM_I_OPERATORP (proc
))
3367 trampoline
= scm_call_1
;
3372 if (SCM_SMOB_APPLICABLE_P (proc
))
3373 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
3378 case scm_tc7_rpsubr
:
3381 trampoline
= scm_call_1
;
3384 return NULL
; /* not applicable on one arg */
3386 /* We only reach this point if a valid trampoline was determined. */
3388 /* If debugging is enabled, we want to see all calls to proc on the stack.
3389 * Thus, we replace the trampoline shortcut with scm_call_1. */
3390 if (scm_debug_mode_p
)
3397 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
3399 return SCM_SUBRF (proc
) (arg1
, arg2
);
3403 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
3405 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
3409 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
3411 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
3415 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
3417 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3418 scm_list_2 (arg1
, arg2
),
3420 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
3425 scm_trampoline_2 (SCM proc
)
3427 scm_t_trampoline_2 trampoline
;
3432 switch (SCM_TYP7 (proc
))
3434 case scm_tc7_subr_2
:
3435 case scm_tc7_subr_2o
:
3436 case scm_tc7_rpsubr
:
3438 trampoline
= call_subr2_2
;
3440 case scm_tc7_lsubr_2
:
3441 trampoline
= call_lsubr2_2
;
3444 trampoline
= call_lsubr_2
;
3446 case scm_tcs_closures
:
3448 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3449 if (!scm_is_null (formals
)
3450 && (!scm_is_pair (formals
)
3451 || (!scm_is_null (SCM_CDR (formals
))
3452 && (!scm_is_pair (SCM_CDR (formals
))
3453 || !scm_is_pair (SCM_CDDR (formals
))))))
3454 trampoline
= call_closure_2
;
3459 case scm_tcs_struct
:
3460 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3461 trampoline
= scm_call_generic_2
;
3462 else if (SCM_I_OPERATORP (proc
))
3463 trampoline
= scm_call_2
;
3468 if (SCM_SMOB_APPLICABLE_P (proc
))
3469 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
3475 trampoline
= scm_call_2
;
3478 return NULL
; /* not applicable on two args */
3480 /* We only reach this point if a valid trampoline was determined. */
3482 /* If debugging is enabled, we want to see all calls to proc on the stack.
3483 * Thus, we replace the trampoline shortcut with scm_call_2. */
3484 if (scm_debug_mode_p
)
3490 /* Typechecking for multi-argument MAP and FOR-EACH.
3492 Verify that each element of the vector ARGV, except for the first,
3493 is a proper list whose length is LEN. Attribute errors to WHO,
3494 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3496 check_map_args (SCM argv
,
3505 for (i
= SCM_SIMPLE_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
3507 SCM elt
= SCM_SIMPLE_VECTOR_REF (argv
, i
);
3508 long elt_len
= scm_ilength (elt
);
3513 scm_apply_generic (gf
, scm_cons (proc
, args
));
3515 scm_wrong_type_arg (who
, i
+ 2, elt
);
3519 scm_out_of_range_pos (who
, elt
, scm_from_long (i
+ 2));
3524 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3526 /* Note: Currently, scm_map applies PROC to the argument list(s)
3527 sequentially, starting with the first element(s). This is used in
3528 evalext.c where the Scheme procedure `map-in-order', which guarantees
3529 sequential behaviour, is implemented using scm_map. If the
3530 behaviour changes, we need to update `map-in-order'.
3534 scm_map (SCM proc
, SCM arg1
, SCM args
)
3535 #define FUNC_NAME s_map
3541 len
= scm_ilength (arg1
);
3542 SCM_GASSERTn (len
>= 0,
3543 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
3544 SCM_VALIDATE_REST_ARGUMENT (args
);
3545 if (scm_is_null (args
))
3547 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
3548 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
3549 while (SCM_NIMP (arg1
))
3551 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
3552 pres
= SCM_CDRLOC (*pres
);
3553 arg1
= SCM_CDR (arg1
);
3557 if (scm_is_null (SCM_CDR (args
)))
3559 SCM arg2
= SCM_CAR (args
);
3560 int len2
= scm_ilength (arg2
);
3561 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
3563 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
3564 SCM_GASSERTn (len2
>= 0,
3565 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
3567 SCM_OUT_OF_RANGE (3, arg2
);
3568 while (SCM_NIMP (arg1
))
3570 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
3571 pres
= SCM_CDRLOC (*pres
);
3572 arg1
= SCM_CDR (arg1
);
3573 arg2
= SCM_CDR (arg2
);
3577 arg1
= scm_cons (arg1
, args
);
3578 args
= scm_vector (arg1
);
3579 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
3583 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3585 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
3588 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
3589 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
3591 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
3592 pres
= SCM_CDRLOC (*pres
);
3598 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
3601 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
3602 #define FUNC_NAME s_for_each
3605 len
= scm_ilength (arg1
);
3606 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
3607 SCM_ARG2
, s_for_each
);
3608 SCM_VALIDATE_REST_ARGUMENT (args
);
3609 if (scm_is_null (args
))
3611 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
3612 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
3613 while (SCM_NIMP (arg1
))
3615 call (proc
, SCM_CAR (arg1
));
3616 arg1
= SCM_CDR (arg1
);
3618 return SCM_UNSPECIFIED
;
3620 if (scm_is_null (SCM_CDR (args
)))
3622 SCM arg2
= SCM_CAR (args
);
3623 int len2
= scm_ilength (arg2
);
3624 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
3625 SCM_GASSERTn (call
, g_for_each
,
3626 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
3627 SCM_GASSERTn (len2
>= 0, g_for_each
,
3628 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
3630 SCM_OUT_OF_RANGE (3, arg2
);
3631 while (SCM_NIMP (arg1
))
3633 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
3634 arg1
= SCM_CDR (arg1
);
3635 arg2
= SCM_CDR (arg2
);
3637 return SCM_UNSPECIFIED
;
3639 arg1
= scm_cons (arg1
, args
);
3640 args
= scm_vector (arg1
);
3641 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
3645 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3647 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
3649 return SCM_UNSPECIFIED
;
3650 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
3651 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
3653 scm_apply (proc
, arg1
, SCM_EOL
);
3660 scm_closure (SCM code
, SCM env
)
3663 SCM closcar
= scm_cons (code
, SCM_EOL
);
3664 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
3665 scm_remember_upto_here (closcar
);
3670 scm_t_bits scm_tc16_promise
;
3673 scm_makprom (SCM code
)
3675 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
3677 scm_make_recursive_mutex ());
3682 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
3684 int writingp
= SCM_WRITINGP (pstate
);
3685 scm_puts ("#<promise ", port
);
3686 SCM_SET_WRITINGP (pstate
, 1);
3687 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
3688 SCM_SET_WRITINGP (pstate
, writingp
);
3689 scm_putc ('>', port
);
3693 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
3695 "If the promise @var{x} has not been computed yet, compute and\n"
3696 "return @var{x}, otherwise just return the previously computed\n"
3698 #define FUNC_NAME s_scm_force
3700 SCM_VALIDATE_SMOB (1, promise
, promise
);
3701 scm_lock_mutex (SCM_PROMISE_MUTEX (promise
));
3702 if (!SCM_PROMISE_COMPUTED_P (promise
))
3704 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
3705 if (!SCM_PROMISE_COMPUTED_P (promise
))
3707 SCM_SET_PROMISE_DATA (promise
, ans
);
3708 SCM_SET_PROMISE_COMPUTED (promise
);
3711 scm_unlock_mutex (SCM_PROMISE_MUTEX (promise
));
3712 return SCM_PROMISE_DATA (promise
);
3717 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
3719 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
3720 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
3721 #define FUNC_NAME s_scm_promise_p
3723 return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
3728 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
3729 (SCM xorig
, SCM x
, SCM y
),
3730 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
3731 "Any source properties associated with @var{xorig} are also associated\n"
3732 "with the new pair.")
3733 #define FUNC_NAME s_scm_cons_source
3736 z
= scm_cons (x
, y
);
3737 /* Copy source properties possibly associated with xorig. */
3738 p
= scm_whash_lookup (scm_source_whash
, xorig
);
3739 if (scm_is_true (p
))
3740 scm_whash_insert (scm_source_whash
, z
, p
);
3746 /* The function scm_copy_tree is used to copy an expression tree to allow the
3747 * memoizer to modify the expression during memoization. scm_copy_tree
3748 * creates deep copies of pairs and vectors, but not of any other data types,
3749 * since only pairs and vectors will be parsed by the memoizer.
3751 * To avoid infinite recursion due to cyclic structures, the hare-and-tortoise
3752 * pattern is used to detect cycles. In fact, the pattern is used in two
3753 * dimensions, vertical (indicated in the code by the variable names 'hare'
3754 * and 'tortoise') and horizontal ('rabbit' and 'turtle'). In both
3755 * dimensions, the hare/rabbit will take two steps when the tortoise/turtle
3758 * The vertical dimension corresponds to recursive calls to function
3759 * copy_tree: This happens when descending into vector elements, into cars of
3760 * lists and into the cdr of an improper list. In this dimension, the
3761 * tortoise follows the hare by using the processor stack: Every stack frame
3762 * will hold an instance of struct t_trace. These instances are connected in
3763 * a way that represents the trace of the hare, which thus can be followed by
3764 * the tortoise. The tortoise will always point to struct t_trace instances
3765 * relating to SCM objects that have already been copied. Thus, a cycle is
3766 * detected if the tortoise and the hare point to the same object,
3768 * The horizontal dimension is within one execution of copy_tree, when the
3769 * function cdr's along the pairs of a list. This is the standard
3770 * hare-and-tortoise implementation, found several times in guile. */
3773 struct t_trace
*trace
; /* These pointers form a trace along the stack. */
3774 SCM obj
; /* The object handled at the respective stack frame.*/
3779 struct t_trace
*const hare
,
3780 struct t_trace
*tortoise
,
3781 unsigned int tortoise_delay
)
3783 if (!scm_is_pair (hare
->obj
) && !scm_is_simple_vector (hare
->obj
))
3789 /* Prepare the trace along the stack. */
3790 struct t_trace new_hare
;
3791 hare
->trace
= &new_hare
;
3793 /* The tortoise will make its step after the delay has elapsed. Note
3794 * that in contrast to the typical hare-and-tortoise pattern, the step
3795 * of the tortoise happens before the hare takes its steps. This is, in
3796 * principle, no problem, except for the start of the algorithm: Then,
3797 * it has to be made sure that the hare actually gets its advantage of
3799 if (tortoise_delay
== 0)
3802 tortoise
= tortoise
->trace
;
3803 ASSERT_SYNTAX (!scm_is_eq (hare
->obj
, tortoise
->obj
),
3804 s_bad_expression
, hare
->obj
);
3811 if (scm_is_simple_vector (hare
->obj
))
3813 size_t length
= SCM_SIMPLE_VECTOR_LENGTH (hare
->obj
);
3814 SCM new_vector
= scm_c_make_vector (length
, SCM_UNSPECIFIED
);
3816 /* Each vector element is copied by recursing into copy_tree, having
3817 * the tortoise follow the hare into the depths of the stack. */
3818 unsigned long int i
;
3819 for (i
= 0; i
< length
; ++i
)
3822 new_hare
.obj
= SCM_SIMPLE_VECTOR_REF (hare
->obj
, i
);
3823 new_element
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3824 SCM_SIMPLE_VECTOR_SET (new_vector
, i
, new_element
);
3829 else /* scm_is_pair (hare->obj) */
3834 SCM rabbit
= hare
->obj
;
3835 SCM turtle
= hare
->obj
;
3839 /* The first pair of the list is treated specially, in order to
3840 * preserve a potential source code position. */
3841 result
= tail
= scm_cons_source (rabbit
, SCM_EOL
, SCM_EOL
);
3842 new_hare
.obj
= SCM_CAR (rabbit
);
3843 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3844 SCM_SETCAR (tail
, copy
);
3846 /* The remaining pairs of the list are copied by, horizontally,
3847 * having the turtle follow the rabbit, and, vertically, having the
3848 * tortoise follow the hare into the depths of the stack. */
3849 rabbit
= SCM_CDR (rabbit
);
3850 while (scm_is_pair (rabbit
))
3852 new_hare
.obj
= SCM_CAR (rabbit
);
3853 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3854 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
3855 tail
= SCM_CDR (tail
);
3857 rabbit
= SCM_CDR (rabbit
);
3858 if (scm_is_pair (rabbit
))
3860 new_hare
.obj
= SCM_CAR (rabbit
);
3861 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3862 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
3863 tail
= SCM_CDR (tail
);
3864 rabbit
= SCM_CDR (rabbit
);
3866 turtle
= SCM_CDR (turtle
);
3867 ASSERT_SYNTAX (!scm_is_eq (rabbit
, turtle
),
3868 s_bad_expression
, rabbit
);
3872 /* We have to recurse into copy_tree again for the last cdr, in
3873 * order to handle the situation that it holds a vector. */
3874 new_hare
.obj
= rabbit
;
3875 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3876 SCM_SETCDR (tail
, copy
);
3883 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
3885 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
3886 "the new data structure. @code{copy-tree} recurses down the\n"
3887 "contents of both pairs and vectors (since both cons cells and vector\n"
3888 "cells may point to arbitrary objects), and stops recursing when it hits\n"
3889 "any other object.")
3890 #define FUNC_NAME s_scm_copy_tree
3892 /* Prepare the trace along the stack. */
3893 struct t_trace trace
;
3896 /* In function copy_tree, if the tortoise makes its step, it will do this
3897 * before the hare has the chance to move. Thus, we have to make sure that
3898 * the very first step of the tortoise will not happen after the hare has
3899 * really made two steps. This is achieved by passing '2' as the initial
3900 * delay for the tortoise. NOTE: Since cycles are unlikely, giving the hare
3901 * a bigger advantage may improve performance slightly. */
3902 return copy_tree (&trace
, &trace
, 2);
3907 /* We have three levels of EVAL here:
3909 - scm_i_eval (exp, env)
3911 evaluates EXP in environment ENV. ENV is a lexical environment
3912 structure as used by the actual tree code evaluator. When ENV is
3913 a top-level environment, then changes to the current module are
3914 tracked by updating ENV so that it continues to be in sync with
3917 - scm_primitive_eval (exp)
3919 evaluates EXP in the top-level environment as determined by the
3920 current module. This is done by constructing a suitable
3921 environment and calling scm_i_eval. Thus, changes to the
3922 top-level module are tracked normally.
3924 - scm_eval (exp, mod_or_state)
3926 evaluates EXP while MOD_OR_STATE is the current module or current
3927 dynamic state (as appropriate). This is done by setting the
3928 current module (or dynamic state) to MOD_OR_STATE, invoking
3929 scm_primitive_eval on EXP, and then restoring the current module
3930 (or dynamic state) to the value it had previously. That is,
3931 while EXP is evaluated, changes to the current module (or dynamic
3932 state) are tracked, but these changes do not persist when
3935 For each level of evals, there are two variants, distinguished by a
3936 _x suffix: the ordinary variant does not modify EXP while the _x
3937 variant can destructively modify EXP into something completely
3938 unintelligible. A Scheme data structure passed as EXP to one of the
3939 _x variants should not ever be used again for anything. So when in
3940 doubt, use the ordinary variant.
3945 scm_i_eval_x (SCM exp
, SCM env
)
3947 if (scm_is_symbol (exp
))
3948 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
3950 return SCM_I_XEVAL (exp
, env
, scm_debug_mode_p
);
3954 scm_i_eval (SCM exp
, SCM env
)
3956 exp
= scm_copy_tree (exp
);
3957 if (scm_is_symbol (exp
))
3958 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
3960 return SCM_I_XEVAL (exp
, env
, scm_debug_mode_p
);
3964 scm_primitive_eval_x (SCM exp
)
3967 SCM transformer
= scm_current_module_transformer ();
3968 if (SCM_NIMP (transformer
))
3969 exp
= scm_call_1 (transformer
, exp
);
3970 env
= scm_top_level_env (scm_current_module_lookup_closure ());
3971 return scm_i_eval_x (exp
, env
);
3974 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
3976 "Evaluate @var{exp} in the top-level environment specified by\n"
3977 "the current module.")
3978 #define FUNC_NAME s_scm_primitive_eval
3981 SCM transformer
= scm_current_module_transformer ();
3982 if (scm_is_true (transformer
))
3983 exp
= scm_call_1 (transformer
, exp
);
3984 env
= scm_top_level_env (scm_current_module_lookup_closure ());
3985 return scm_i_eval (exp
, env
);
3990 /* Eval does not take the second arg optionally. This is intentional
3991 * in order to be R5RS compatible, and to prepare for the new module
3992 * system, where we would like to make the choice of evaluation
3993 * environment explicit. */
3996 scm_eval_x (SCM exp
, SCM module_or_state
)
4000 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
4001 if (scm_is_dynamic_state (module_or_state
))
4002 scm_dynwind_current_dynamic_state (module_or_state
);
4004 scm_dynwind_current_module (module_or_state
);
4006 res
= scm_primitive_eval_x (exp
);
4012 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
4013 (SCM exp
, SCM module_or_state
),
4014 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
4015 "in the top-level environment specified by\n"
4016 "@var{module_or_state}.\n"
4017 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
4018 "@var{module_or_state} is made the current module when\n"
4019 "it is a module, or the current dynamic state when it is\n"
4021 "Example: (eval '(+ 1 2) (interaction-environment))")
4022 #define FUNC_NAME s_scm_eval
4026 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
4027 if (scm_is_dynamic_state (module_or_state
))
4028 scm_dynwind_current_dynamic_state (module_or_state
);
4030 scm_dynwind_current_module (module_or_state
);
4032 res
= scm_primitive_eval (exp
);
4040 /* At this point, deval and scm_dapply are generated.
4052 scm_i_pthread_mutex_init (&source_mutex
,
4053 scm_i_pthread_mutexattr_recursive
);
4055 scm_init_opts (scm_evaluator_traps
,
4056 scm_evaluator_trap_table
);
4057 scm_init_opts (scm_eval_options_interface
,
4060 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
4061 scm_set_smob_print (scm_tc16_promise
, promise_print
);
4063 undefineds
= scm_list_1 (SCM_UNDEFINED
);
4064 SCM_SETCDR (undefineds
, undefineds
);
4065 scm_permanent_object (undefineds
);
4067 scm_listofnull
= scm_list_1 (SCM_EOL
);
4069 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
4070 scm_permanent_object (f_apply
);
4072 #include "libguile/eval.x"
4074 scm_add_feature ("delay");