1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008
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
21 /* SECTION: This code is compiled once.
30 #include "libguile/__scm.h"
33 #include "libguile/_scm.h"
34 #include "libguile/alist.h"
35 #include "libguile/async.h"
36 #include "libguile/continuations.h"
37 #include "libguile/debug.h"
38 #include "libguile/deprecation.h"
39 #include "libguile/dynwind.h"
40 #include "libguile/eq.h"
41 #include "libguile/feature.h"
42 #include "libguile/fluids.h"
43 #include "libguile/futures.h"
44 #include "libguile/goops.h"
45 #include "libguile/hash.h"
46 #include "libguile/hashtab.h"
47 #include "libguile/lang.h"
48 #include "libguile/list.h"
49 #include "libguile/macros.h"
50 #include "libguile/modules.h"
51 #include "libguile/objects.h"
52 #include "libguile/ports.h"
53 #include "libguile/print.h"
54 #include "libguile/procprop.h"
55 #include "libguile/root.h"
56 #include "libguile/smob.h"
57 #include "libguile/srcprop.h"
58 #include "libguile/stackchk.h"
59 #include "libguile/strings.h"
60 #include "libguile/threads.h"
61 #include "libguile/throw.h"
62 #include "libguile/validate.h"
63 #include "libguile/values.h"
64 #include "libguile/vectors.h"
66 #include "libguile/eval.h"
67 #include "libguile/private-options.h"
72 static SCM
unmemoize_exprs (SCM expr
, SCM env
);
73 static SCM
canonicalize_define (SCM expr
);
74 static SCM
*scm_lookupcar1 (SCM vloc
, SCM genv
, int check
);
75 static SCM
unmemoize_builtin_macro (SCM expr
, SCM env
);
76 static void ceval_letrec_inits (SCM env
, SCM init_forms
, SCM
**init_values_eol
);
77 static SCM
ceval (SCM x
, SCM env
);
78 static SCM
deval (SCM x
, SCM env
);
84 * This section defines the message strings for the syntax errors that can be
85 * detected during memoization and the functions and macros that shall be
86 * called by the memoizer code to signal syntax errors. */
89 /* Syntax errors that can be detected during memoization: */
91 /* Circular or improper lists do not form valid scheme expressions. If a
92 * circular list or an improper list is detected in a place where a scheme
93 * expression is expected, a 'Bad expression' error is signalled. */
94 static const char s_bad_expression
[] = "Bad expression";
96 /* If a form is detected that holds a different number of expressions than are
97 * required in that context, a 'Missing or extra expression' error is
99 static const char s_expression
[] = "Missing or extra expression in";
101 /* If a form is detected that holds less expressions than are required in that
102 * context, a 'Missing expression' error is signalled. */
103 static const char s_missing_expression
[] = "Missing expression in";
105 /* If a form is detected that holds more expressions than are allowed in that
106 * context, an 'Extra expression' error is signalled. */
107 static const char s_extra_expression
[] = "Extra expression in";
109 /* The empty combination '()' is not allowed as an expression in scheme. If
110 * it is detected in a place where an expression is expected, an 'Illegal
111 * empty combination' error is signalled. Note: If you encounter this error
112 * message, it is very likely that you intended to denote the empty list. To
113 * do so, you need to quote the empty list like (quote ()) or '(). */
114 static const char s_empty_combination
[] = "Illegal empty combination";
116 /* A body may hold an arbitrary number of internal defines, followed by a
117 * non-empty sequence of expressions. If a body with an empty sequence of
118 * expressions is detected, a 'Missing body expression' error is signalled.
120 static const char s_missing_body_expression
[] = "Missing body expression in";
122 /* A body may hold an arbitrary number of internal defines, followed by a
123 * non-empty sequence of expressions. Each the definitions and the
124 * expressions may be grouped arbitraryly with begin, but it is not allowed to
125 * mix definitions and expressions. If a define form in a body mixes
126 * definitions and expressions, a 'Mixed definitions and expressions' error is
128 static const char s_mixed_body_forms
[] = "Mixed definitions and expressions in";
129 /* Definitions are only allowed on the top level and at the start of a body.
130 * If a definition is detected anywhere else, a 'Bad define placement' error
132 static const char s_bad_define
[] = "Bad define placement";
134 /* Case or cond expressions must have at least one clause. If a case or cond
135 * expression without any clauses is detected, a 'Missing clauses' error is
137 static const char s_missing_clauses
[] = "Missing clauses";
139 /* If there is an 'else' clause in a case or a cond statement, it must be the
140 * last clause. If after the 'else' case clause further clauses are detected,
141 * a 'Misplaced else clause' error is signalled. */
142 static const char s_misplaced_else_clause
[] = "Misplaced else clause";
144 /* If a case clause is detected that is not in the format
145 * (<label(s)> <expression1> <expression2> ...)
146 * a 'Bad case clause' error is signalled. */
147 static const char s_bad_case_clause
[] = "Bad case clause";
149 /* If a case clause is detected where the <label(s)> element is neither a
150 * proper list nor (in case of the last clause) the syntactic keyword 'else',
151 * a 'Bad case labels' error is signalled. Note: If you encounter this error
152 * for an else-clause which seems to be syntactically correct, check if 'else'
153 * is really a syntactic keyword in that context. If 'else' is bound in the
154 * local or global environment, it is not considered a syntactic keyword, but
155 * will be treated as any other variable. */
156 static const char s_bad_case_labels
[] = "Bad case labels";
158 /* In a case statement all labels have to be distinct. If in a case statement
159 * a label occurs more than once, a 'Duplicate case label' error is
161 static const char s_duplicate_case_label
[] = "Duplicate case label";
163 /* If a cond clause is detected that is not in one of the formats
164 * (<test> <expression1> ...) or (else <expression1> <expression2> ...)
165 * a 'Bad cond clause' error is signalled. */
166 static const char s_bad_cond_clause
[] = "Bad cond clause";
168 /* If a cond clause is detected that uses the alternate '=>' form, but does
169 * not hold a recipient element for the test result, a 'Missing recipient'
170 * error is signalled. */
171 static const char s_missing_recipient
[] = "Missing recipient in";
173 /* If in a position where a variable name is required some other object is
174 * detected, a 'Bad variable' error is signalled. */
175 static const char s_bad_variable
[] = "Bad variable";
177 /* Bindings for forms like 'let' and 'do' have to be given in a proper,
178 * possibly empty list. If any other object is detected in a place where a
179 * list of bindings was required, a 'Bad bindings' error is signalled. */
180 static const char s_bad_bindings
[] = "Bad bindings";
182 /* Depending on the syntactic context, a binding has to be in the format
183 * (<variable> <expression>) or (<variable> <expression1> <expression2>).
184 * If anything else is detected in a place where a binding was expected, a
185 * 'Bad binding' error is signalled. */
186 static const char s_bad_binding
[] = "Bad binding";
188 /* Some syntactic forms don't allow variable names to appear more than once in
189 * a list of bindings. If such a situation is nevertheless detected, a
190 * 'Duplicate binding' error is signalled. */
191 static const char s_duplicate_binding
[] = "Duplicate binding";
193 /* If the exit form of a 'do' expression is not in the format
194 * (<test> <expression> ...)
195 * a 'Bad exit clause' error is signalled. */
196 static const char s_bad_exit_clause
[] = "Bad exit clause";
198 /* The formal function arguments of a lambda expression have to be either a
199 * single symbol or a non-cyclic list. For anything else a 'Bad formals'
200 * error is signalled. */
201 static const char s_bad_formals
[] = "Bad formals";
203 /* If in a lambda expression something else than a symbol is detected at a
204 * place where a formal function argument is required, a 'Bad formal' error is
206 static const char s_bad_formal
[] = "Bad formal";
208 /* If in the arguments list of a lambda expression an argument name occurs
209 * more than once, a 'Duplicate formal' error is signalled. */
210 static const char s_duplicate_formal
[] = "Duplicate formal";
212 /* If the evaluation of an unquote-splicing expression gives something else
213 * than a proper list, a 'Non-list result for unquote-splicing' error is
215 static const char s_splicing
[] = "Non-list result for unquote-splicing";
217 /* If something else than an exact integer is detected as the argument for
218 * @slot-ref and @slot-set!, a 'Bad slot number' error is signalled. */
219 static const char s_bad_slot_number
[] = "Bad slot number";
222 /* Signal a syntax error. We distinguish between the form that caused the
223 * error and the enclosing expression. The error message will print out as
224 * shown in the following pattern. The file name and line number are only
225 * given when they can be determined from the erroneous form or from the
226 * enclosing expression.
228 * <filename>: In procedure memoization:
229 * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
231 SCM_SYMBOL (syntax_error_key
, "syntax-error");
233 /* The prototype is needed to indicate that the function does not return. */
235 syntax_error (const char* const, const SCM
, const SCM
) SCM_NORETURN
;
238 syntax_error (const char* const msg
, const SCM form
, const SCM expr
)
240 SCM msg_string
= scm_from_locale_string (msg
);
241 SCM filename
= SCM_BOOL_F
;
242 SCM linenr
= SCM_BOOL_F
;
246 if (scm_is_pair (form
))
248 filename
= scm_source_property (form
, scm_sym_filename
);
249 linenr
= scm_source_property (form
, scm_sym_line
);
252 if (scm_is_false (filename
) && scm_is_false (linenr
) && scm_is_pair (expr
))
254 filename
= scm_source_property (expr
, scm_sym_filename
);
255 linenr
= scm_source_property (expr
, scm_sym_line
);
258 if (!SCM_UNBNDP (expr
))
260 if (scm_is_true (filename
))
262 format
= "In file ~S, line ~S: ~A ~S in expression ~S.";
263 args
= scm_list_5 (filename
, linenr
, msg_string
, form
, expr
);
265 else if (scm_is_true (linenr
))
267 format
= "In line ~S: ~A ~S in expression ~S.";
268 args
= scm_list_4 (linenr
, msg_string
, form
, expr
);
272 format
= "~A ~S in expression ~S.";
273 args
= scm_list_3 (msg_string
, form
, expr
);
278 if (scm_is_true (filename
))
280 format
= "In file ~S, line ~S: ~A ~S.";
281 args
= scm_list_4 (filename
, linenr
, msg_string
, form
);
283 else if (scm_is_true (linenr
))
285 format
= "In line ~S: ~A ~S.";
286 args
= scm_list_3 (linenr
, msg_string
, form
);
291 args
= scm_list_2 (msg_string
, form
);
295 scm_error (syntax_error_key
, "memoization", format
, args
, SCM_BOOL_F
);
299 /* Shortcut macros to simplify syntax error handling. */
300 #define ASSERT_SYNTAX(cond, message, form) \
301 { if (SCM_UNLIKELY (!(cond))) \
302 syntax_error (message, form, SCM_UNDEFINED); }
303 #define ASSERT_SYNTAX_2(cond, message, form, expr) \
304 { if (SCM_UNLIKELY (!(cond))) \
305 syntax_error (message, form, expr); }
311 * Ilocs are memoized references to variables in local environment frames.
312 * They are represented as three values: The relative offset of the
313 * environment frame, the number of the binding within that frame, and a
314 * boolean value indicating whether the binding is the last binding in the
317 * Frame numbers have 11 bits, relative offsets have 12 bits.
320 #define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc)
321 #define SCM_IFRINC (0x00000100L)
322 #define SCM_ICDR (0x00080000L)
323 #define SCM_IDINC (0x00100000L)
324 #define SCM_IFRAME(n) ((long)((SCM_ICDR-SCM_IFRINC)>>8) \
325 & (SCM_UNPACK (n) >> 8))
326 #define SCM_IDIST(n) (SCM_UNPACK (n) >> 20)
327 #define SCM_ICDRP(n) (SCM_ICDR & SCM_UNPACK (n))
328 #define SCM_IDSTMSK (-SCM_IDINC)
329 #define SCM_IFRAMEMAX ((1<<11)-1)
330 #define SCM_IDISTMAX ((1<<12)-1)
331 #define SCM_MAKE_ILOC(frame_nr, binding_nr, last_p) \
334 + ((binding_nr) << 20) \
335 + ((last_p) ? SCM_ICDR : 0) \
339 scm_i_print_iloc (SCM iloc
, SCM port
)
341 scm_puts ("#@", port
);
342 scm_intprint ((long) SCM_IFRAME (iloc
), 10, port
);
343 scm_putc (SCM_ICDRP (iloc
) ? '-' : '+', port
);
344 scm_intprint ((long) SCM_IDIST (iloc
), 10, port
);
347 #if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
349 SCM
scm_dbg_make_iloc (SCM frame
, SCM binding
, SCM cdrp
);
351 SCM_DEFINE (scm_dbg_make_iloc
, "dbg-make-iloc", 3, 0, 0,
352 (SCM frame
, SCM binding
, SCM cdrp
),
353 "Return a new iloc with frame offset @var{frame}, binding\n"
354 "offset @var{binding} and the cdr flag @var{cdrp}.")
355 #define FUNC_NAME s_scm_dbg_make_iloc
357 return SCM_MAKE_ILOC ((scm_t_bits
) scm_to_unsigned_integer (frame
, 0, SCM_IFRAMEMAX
),
358 (scm_t_bits
) scm_to_unsigned_integer (binding
, 0, SCM_IDISTMAX
),
363 SCM
scm_dbg_iloc_p (SCM obj
);
365 SCM_DEFINE (scm_dbg_iloc_p
, "dbg-iloc?", 1, 0, 0,
367 "Return @code{#t} if @var{obj} is an iloc.")
368 #define FUNC_NAME s_scm_dbg_iloc_p
370 return scm_from_bool (SCM_ILOCP (obj
));
378 /* {Evaluator byte codes (isyms)}
381 #define ISYMNUM(n) (SCM_ITAG8_DATA (n))
383 /* This table must agree with the list of SCM_IM_ constants in tags.h */
384 static const char *const isymnames
[] =
401 "#@call-with-current-continuation",
407 "#@call-with-values",
415 scm_i_print_isym (SCM isym
, SCM port
)
417 const size_t isymnum
= ISYMNUM (isym
);
418 if (isymnum
< (sizeof isymnames
/ sizeof (char *)))
419 scm_puts (isymnames
[isymnum
], port
);
421 scm_ipruk ("isym", isym
, port
);
426 /* The function lookup_symbol is used during memoization: Lookup the symbol in
427 * the environment. If there is no binding for the symbol, SCM_UNDEFINED is
428 * returned. If the symbol is a global variable, the variable object to which
429 * the symbol is bound is returned. Finally, if the symbol is a local
430 * variable the corresponding iloc object is returned. */
432 /* A helper function for lookup_symbol: Try to find the symbol in the top
433 * level environment frame. The function returns SCM_UNDEFINED if the symbol
434 * is unbound and it returns a variable object if the symbol is a global
437 lookup_global_symbol (const SCM symbol
, const SCM top_level
)
439 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
440 if (scm_is_false (variable
))
441 return SCM_UNDEFINED
;
447 lookup_symbol (const SCM symbol
, const SCM env
)
450 unsigned int frame_nr
;
452 for (frame_idx
= env
, frame_nr
= 0;
453 !scm_is_null (frame_idx
);
454 frame_idx
= SCM_CDR (frame_idx
), ++frame_nr
)
456 const SCM frame
= SCM_CAR (frame_idx
);
457 if (scm_is_pair (frame
))
459 /* frame holds a local environment frame */
461 unsigned int symbol_nr
;
463 for (symbol_idx
= SCM_CAR (frame
), symbol_nr
= 0;
464 scm_is_pair (symbol_idx
);
465 symbol_idx
= SCM_CDR (symbol_idx
), ++symbol_nr
)
467 if (scm_is_eq (SCM_CAR (symbol_idx
), symbol
))
468 /* found the symbol, therefore return the iloc */
469 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 0);
471 if (scm_is_eq (symbol_idx
, symbol
))
472 /* found the symbol as the last element of the current frame */
473 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 1);
477 /* no more local environment frames */
478 return lookup_global_symbol (symbol
, frame
);
482 return lookup_global_symbol (symbol
, SCM_BOOL_F
);
486 /* Return true if the symbol is - from the point of view of a macro
487 * transformer - a literal in the sense specified in chapter "pattern
488 * language" of R5RS. In the code below, however, we don't match the
489 * definition of R5RS exactly: It returns true if the identifier has no
490 * binding or if it is a syntactic keyword. */
492 literal_p (const SCM symbol
, const SCM env
)
494 const SCM variable
= lookup_symbol (symbol
, env
);
495 if (SCM_UNBNDP (variable
))
497 if (SCM_VARIABLEP (variable
) && SCM_MACROP (SCM_VARIABLE_REF (variable
)))
504 /* Return true if the expression is self-quoting in the memoized code. Thus,
505 * some other objects (like e. g. vectors) are reported as self-quoting, which
506 * according to R5RS would need to be quoted. */
508 is_self_quoting_p (const SCM expr
)
510 if (scm_is_pair (expr
))
512 else if (scm_is_symbol (expr
))
514 else if (scm_is_null (expr
))
520 SCM_SYMBOL (sym_three_question_marks
, "???");
523 unmemoize_expression (const SCM expr
, const SCM env
)
525 if (SCM_ILOCP (expr
))
528 unsigned long int frame_nr
;
530 unsigned long int symbol_nr
;
532 for (frame_idx
= env
, frame_nr
= SCM_IFRAME (expr
);
534 frame_idx
= SCM_CDR (frame_idx
), --frame_nr
)
536 for (symbol_idx
= SCM_CAAR (frame_idx
), symbol_nr
= SCM_IDIST (expr
);
538 symbol_idx
= SCM_CDR (symbol_idx
), --symbol_nr
)
540 return SCM_ICDRP (expr
) ? symbol_idx
: SCM_CAR (symbol_idx
);
542 else if (SCM_VARIABLEP (expr
))
544 const SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), expr
);
545 return scm_is_true (sym
) ? sym
: sym_three_question_marks
;
547 else if (scm_is_simple_vector (expr
))
549 return scm_list_2 (scm_sym_quote
, expr
);
551 else if (!scm_is_pair (expr
))
555 else if (SCM_ISYMP (SCM_CAR (expr
)))
557 return unmemoize_builtin_macro (expr
, env
);
561 return unmemoize_exprs (expr
, env
);
567 unmemoize_exprs (const SCM exprs
, const SCM env
)
569 SCM r_result
= SCM_EOL
;
570 SCM expr_idx
= exprs
;
573 /* Note that due to the current lazy memoizer we may find partially memoized
574 * code during execution. In such code we have to expect improper lists of
575 * expressions: On the one hand, for such code syntax checks have not yet
576 * fully been performed, on the other hand, there may be even legal code
577 * like '(a . b) appear as an improper list of expressions as long as the
578 * quote expression is still in its unmemoized form. For this reason, the
579 * following code handles improper lists of expressions until memoization
580 * and execution have been completely separated. */
581 for (; scm_is_pair (expr_idx
); expr_idx
= SCM_CDR (expr_idx
))
583 const SCM expr
= SCM_CAR (expr_idx
);
585 /* In partially memoized code, lists of expressions that stem from a
586 * body form may start with an ISYM if the body itself has not yet been
587 * memoized. This isym is just an internal marker to indicate that the
588 * body still needs to be memoized. An isym may occur at the very
589 * beginning of the body or after one or more comment strings. It is
590 * dropped during unmemoization. */
591 if (!SCM_ISYMP (expr
))
593 um_expr
= unmemoize_expression (expr
, env
);
594 r_result
= scm_cons (um_expr
, r_result
);
597 um_expr
= unmemoize_expression (expr_idx
, env
);
598 if (!scm_is_null (r_result
))
600 const SCM result
= scm_reverse_x (r_result
, SCM_UNDEFINED
);
601 SCM_SETCDR (r_result
, um_expr
);
611 /* Rewrite the body (which is given as the list of expressions forming the
612 * body) into its internal form. The internal form of a body (<expr> ...) is
613 * just the body itself, but prefixed with an ISYM that denotes to what kind
614 * of outer construct this body belongs: (<ISYM> <expr> ...). A lambda body
615 * starts with SCM_IM_LAMBDA, for example, a body of a let starts with
618 * It is assumed that the calling expression has already made sure that the
619 * body is a proper list. */
621 m_body (SCM op
, SCM exprs
)
623 /* Don't add another ISYM if one is present already. */
624 if (SCM_ISYMP (SCM_CAR (exprs
)))
627 return scm_cons (op
, exprs
);
631 /* The function m_expand_body memoizes a proper list of expressions forming a
632 * body. This function takes care of dealing with internal defines and
633 * transforming them into an equivalent letrec expression. The list of
634 * expressions is rewritten in place. */
636 /* This is a helper function for m_expand_body. If the argument expression is
637 * a symbol that denotes a syntactic keyword, the corresponding macro object
638 * is returned, in all other cases the function returns SCM_UNDEFINED. */
640 try_macro_lookup (const SCM expr
, const SCM env
)
642 if (scm_is_symbol (expr
))
644 const SCM variable
= lookup_symbol (expr
, env
);
645 if (SCM_VARIABLEP (variable
))
647 const SCM value
= SCM_VARIABLE_REF (variable
);
648 if (SCM_MACROP (value
))
653 return SCM_UNDEFINED
;
656 /* This is a helper function for m_expand_body. It expands user macros,
657 * because for the correct translation of a body we need to know whether they
658 * expand to a definition. */
660 expand_user_macros (SCM expr
, const SCM env
)
662 while (scm_is_pair (expr
))
664 const SCM car_expr
= SCM_CAR (expr
);
665 const SCM new_car
= expand_user_macros (car_expr
, env
);
666 const SCM value
= try_macro_lookup (new_car
, env
);
668 if (SCM_MACROP (value
) && SCM_MACRO_TYPE (value
) == 2)
670 /* User macros transform code into code. */
671 expr
= scm_call_2 (SCM_MACRO_CODE (value
), expr
, env
);
672 /* We need to reiterate on the transformed code. */
676 /* No user macro: return. */
677 SCM_SETCAR (expr
, new_car
);
685 /* This is a helper function for m_expand_body. It determines if a given form
686 * represents an application of a given built-in macro. The built-in macro to
687 * check for is identified by its syntactic keyword. The form is an
688 * application of the given macro if looking up the car of the form in the
689 * given environment actually returns the built-in macro. */
691 is_system_macro_p (const SCM syntactic_keyword
, const SCM form
, const SCM env
)
693 if (scm_is_pair (form
))
695 const SCM car_form
= SCM_CAR (form
);
696 const SCM value
= try_macro_lookup (car_form
, env
);
697 if (SCM_BUILTIN_MACRO_P (value
))
699 const SCM macro_name
= scm_macro_name (value
);
700 return scm_is_eq (macro_name
, syntactic_keyword
);
708 m_expand_body (const SCM forms
, const SCM env
)
710 /* The first body form can be skipped since it is known to be the ISYM that
711 * was prepended to the body by m_body. */
712 SCM cdr_forms
= SCM_CDR (forms
);
713 SCM form_idx
= cdr_forms
;
714 SCM definitions
= SCM_EOL
;
715 SCM sequence
= SCM_EOL
;
717 /* According to R5RS, the list of body forms consists of two parts: a number
718 * (maybe zero) of definitions, followed by a non-empty sequence of
719 * expressions. Each the definitions and the expressions may be grouped
720 * arbitrarily with begin, but it is not allowed to mix definitions and
721 * expressions. The task of the following loop therefore is to split the
722 * list of body forms into the list of definitions and the sequence of
724 while (!scm_is_null (form_idx
))
726 const SCM form
= SCM_CAR (form_idx
);
727 const SCM new_form
= expand_user_macros (form
, env
);
728 if (is_system_macro_p (scm_sym_define
, new_form
, env
))
730 definitions
= scm_cons (new_form
, definitions
);
731 form_idx
= SCM_CDR (form_idx
);
733 else if (is_system_macro_p (scm_sym_begin
, new_form
, env
))
735 /* We have encountered a group of forms. This has to be either a
736 * (possibly empty) group of (possibly further grouped) definitions,
737 * or a non-empty group of (possibly further grouped)
739 const SCM grouped_forms
= SCM_CDR (new_form
);
740 unsigned int found_definition
= 0;
741 unsigned int found_expression
= 0;
742 SCM grouped_form_idx
= grouped_forms
;
743 while (!found_expression
&& !scm_is_null (grouped_form_idx
))
745 const SCM inner_form
= SCM_CAR (grouped_form_idx
);
746 const SCM new_inner_form
= expand_user_macros (inner_form
, env
);
747 if (is_system_macro_p (scm_sym_define
, new_inner_form
, env
))
749 found_definition
= 1;
750 definitions
= scm_cons (new_inner_form
, definitions
);
751 grouped_form_idx
= SCM_CDR (grouped_form_idx
);
753 else if (is_system_macro_p (scm_sym_begin
, new_inner_form
, env
))
755 const SCM inner_group
= SCM_CDR (new_inner_form
);
757 = scm_append (scm_list_2 (inner_group
,
758 SCM_CDR (grouped_form_idx
)));
762 /* The group marks the start of the expressions of the body.
763 * We have to make sure that within the same group we have
764 * not encountered a definition before. */
765 ASSERT_SYNTAX (!found_definition
, s_mixed_body_forms
, form
);
766 found_expression
= 1;
767 grouped_form_idx
= SCM_EOL
;
771 /* We have finished processing the group. If we have not yet
772 * encountered an expression we continue processing the forms of the
773 * body to collect further definition forms. Otherwise, the group
774 * marks the start of the sequence of expressions of the body. */
775 if (!found_expression
)
777 form_idx
= SCM_CDR (form_idx
);
787 /* We have detected a form which is no definition. This marks the
788 * start of the sequence of expressions of the body. */
794 /* FIXME: forms does not hold information about the file location. */
795 ASSERT_SYNTAX (scm_is_pair (sequence
), s_missing_body_expression
, cdr_forms
);
797 if (!scm_is_null (definitions
))
801 SCM letrec_expression
;
802 SCM new_letrec_expression
;
804 SCM bindings
= SCM_EOL
;
805 for (definition_idx
= definitions
;
806 !scm_is_null (definition_idx
);
807 definition_idx
= SCM_CDR (definition_idx
))
809 const SCM definition
= SCM_CAR (definition_idx
);
810 const SCM canonical_definition
= canonicalize_define (definition
);
811 const SCM binding
= SCM_CDR (canonical_definition
);
812 bindings
= scm_cons (binding
, bindings
);
815 letrec_tail
= scm_cons (bindings
, sequence
);
816 /* FIXME: forms does not hold information about the file location. */
817 letrec_expression
= scm_cons_source (forms
, scm_sym_letrec
, letrec_tail
);
818 new_letrec_expression
= scm_m_letrec (letrec_expression
, env
);
819 SCM_SETCAR (forms
, new_letrec_expression
);
820 SCM_SETCDR (forms
, SCM_EOL
);
824 SCM_SETCAR (forms
, SCM_CAR (sequence
));
825 SCM_SETCDR (forms
, SCM_CDR (sequence
));
830 macroexp (SCM x
, SCM env
)
832 SCM res
, proc
, orig_sym
;
834 /* Don't bother to produce error messages here. We get them when we
835 eventually execute the code for real. */
838 orig_sym
= SCM_CAR (x
);
839 if (!scm_is_symbol (orig_sym
))
843 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
844 if (proc_ptr
== NULL
)
846 /* We have lost the race. */
852 /* Only handle memoizing macros. `Acros' and `macros' are really
853 special forms and should not be evaluated here. */
855 if (!SCM_MACROP (proc
)
856 || (SCM_MACRO_TYPE (proc
) != 2 && !SCM_BUILTIN_MACRO_P (proc
)))
859 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
860 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
862 if (scm_ilength (res
) <= 0)
863 /* Result of expansion is not a list. */
864 return (scm_list_2 (SCM_IM_BEGIN
, res
));
867 /* njrev: Several queries here: (1) I don't see how it can be
868 correct that the SCM_SETCAR 2 lines below this comment needs
869 protection, but the SCM_SETCAR 6 lines above does not, so
870 something here is probably wrong. (2) macroexp() is now only
871 used in one place - scm_m_generalized_set_x - whereas all other
872 macro expansion happens through expand_user_macros. Therefore
873 (2.1) perhaps macroexp() could be eliminated completely now?
874 (2.2) Does expand_user_macros need any critical section
877 SCM_CRITICAL_SECTION_START
;
878 SCM_SETCAR (x
, SCM_CAR (res
));
879 SCM_SETCDR (x
, SCM_CDR (res
));
880 SCM_CRITICAL_SECTION_END
;
886 /* Start of the memoizers for the standard R5RS builtin macros. */
889 SCM_SYNTAX (s_and
, "and", scm_i_makbimacro
, scm_m_and
);
890 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
893 scm_m_and (SCM expr
, SCM env SCM_UNUSED
)
895 const SCM cdr_expr
= SCM_CDR (expr
);
896 const long length
= scm_ilength (cdr_expr
);
898 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
902 /* Special case: (and) is replaced by #t. */
907 SCM_SETCAR (expr
, SCM_IM_AND
);
913 unmemoize_and (const SCM expr
, const SCM env
)
915 return scm_cons (scm_sym_and
, unmemoize_exprs (SCM_CDR (expr
), env
));
919 SCM_SYNTAX (s_begin
, "begin", scm_i_makbimacro
, scm_m_begin
);
920 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
923 scm_m_begin (SCM expr
, SCM env SCM_UNUSED
)
925 const SCM cdr_expr
= SCM_CDR (expr
);
926 /* Dirk:FIXME:: An empty begin clause is not generally allowed by R5RS.
927 * That means, there should be a distinction between uses of begin where an
928 * empty clause is OK and where it is not. */
929 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
931 SCM_SETCAR (expr
, SCM_IM_BEGIN
);
936 unmemoize_begin (const SCM expr
, const SCM env
)
938 return scm_cons (scm_sym_begin
, unmemoize_exprs (SCM_CDR (expr
), env
));
942 SCM_SYNTAX (s_case
, "case", scm_i_makbimacro
, scm_m_case
);
943 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
944 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
947 scm_m_case (SCM expr
, SCM env
)
950 SCM all_labels
= SCM_EOL
;
952 /* Check, whether 'else is a literal, i. e. not bound to a value. */
953 const int else_literal_p
= literal_p (scm_sym_else
, env
);
955 const SCM cdr_expr
= SCM_CDR (expr
);
956 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
957 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_clauses
, expr
);
959 clauses
= SCM_CDR (cdr_expr
);
960 while (!scm_is_null (clauses
))
964 const SCM clause
= SCM_CAR (clauses
);
965 ASSERT_SYNTAX_2 (scm_ilength (clause
) >= 2,
966 s_bad_case_clause
, clause
, expr
);
968 labels
= SCM_CAR (clause
);
969 if (scm_is_pair (labels
))
971 ASSERT_SYNTAX_2 (scm_ilength (labels
) >= 0,
972 s_bad_case_labels
, labels
, expr
);
973 all_labels
= scm_append (scm_list_2 (labels
, all_labels
));
975 else if (scm_is_null (labels
))
977 /* The list of labels is empty. According to R5RS this is allowed.
978 * It means that the sequence of expressions will never be executed.
979 * Therefore, as an optimization, we could remove the whole
984 ASSERT_SYNTAX_2 (scm_is_eq (labels
, scm_sym_else
) && else_literal_p
,
985 s_bad_case_labels
, labels
, expr
);
986 ASSERT_SYNTAX_2 (scm_is_null (SCM_CDR (clauses
)),
987 s_misplaced_else_clause
, clause
, expr
);
990 /* build the new clause */
991 if (scm_is_eq (labels
, scm_sym_else
))
992 SCM_SETCAR (clause
, SCM_IM_ELSE
);
994 clauses
= SCM_CDR (clauses
);
997 /* Check whether all case labels are distinct. */
998 for (; !scm_is_null (all_labels
); all_labels
= SCM_CDR (all_labels
))
1000 const SCM label
= SCM_CAR (all_labels
);
1001 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (label
, SCM_CDR (all_labels
))),
1002 s_duplicate_case_label
, label
, expr
);
1005 SCM_SETCAR (expr
, SCM_IM_CASE
);
1010 unmemoize_case (const SCM expr
, const SCM env
)
1012 const SCM um_key_expr
= unmemoize_expression (SCM_CADR (expr
), env
);
1013 SCM um_clauses
= SCM_EOL
;
1016 for (clause_idx
= SCM_CDDR (expr
);
1017 !scm_is_null (clause_idx
);
1018 clause_idx
= SCM_CDR (clause_idx
))
1020 const SCM clause
= SCM_CAR (clause_idx
);
1021 const SCM labels
= SCM_CAR (clause
);
1022 const SCM exprs
= SCM_CDR (clause
);
1024 const SCM um_exprs
= unmemoize_exprs (exprs
, env
);
1025 const SCM um_labels
= (scm_is_eq (labels
, SCM_IM_ELSE
))
1027 : scm_i_finite_list_copy (labels
);
1028 const SCM um_clause
= scm_cons (um_labels
, um_exprs
);
1030 um_clauses
= scm_cons (um_clause
, um_clauses
);
1032 um_clauses
= scm_reverse_x (um_clauses
, SCM_UNDEFINED
);
1034 return scm_cons2 (scm_sym_case
, um_key_expr
, um_clauses
);
1038 SCM_SYNTAX (s_cond
, "cond", scm_i_makbimacro
, scm_m_cond
);
1039 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
1040 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
1043 scm_m_cond (SCM expr
, SCM env
)
1045 /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
1046 const int else_literal_p
= literal_p (scm_sym_else
, env
);
1047 const int arrow_literal_p
= literal_p (scm_sym_arrow
, env
);
1049 const SCM clauses
= SCM_CDR (expr
);
1052 ASSERT_SYNTAX (scm_ilength (clauses
) >= 0, s_bad_expression
, expr
);
1053 ASSERT_SYNTAX (scm_ilength (clauses
) >= 1, s_missing_clauses
, expr
);
1055 for (clause_idx
= clauses
;
1056 !scm_is_null (clause_idx
);
1057 clause_idx
= SCM_CDR (clause_idx
))
1061 const SCM clause
= SCM_CAR (clause_idx
);
1062 const long length
= scm_ilength (clause
);
1063 ASSERT_SYNTAX_2 (length
>= 1, s_bad_cond_clause
, clause
, expr
);
1065 test
= SCM_CAR (clause
);
1066 if (scm_is_eq (test
, scm_sym_else
) && else_literal_p
)
1068 const int last_clause_p
= scm_is_null (SCM_CDR (clause_idx
));
1069 ASSERT_SYNTAX_2 (length
>= 2,
1070 s_bad_cond_clause
, clause
, expr
);
1071 ASSERT_SYNTAX_2 (last_clause_p
,
1072 s_misplaced_else_clause
, clause
, expr
);
1073 SCM_SETCAR (clause
, SCM_IM_ELSE
);
1075 else if (length
>= 2
1076 && scm_is_eq (SCM_CADR (clause
), scm_sym_arrow
)
1079 ASSERT_SYNTAX_2 (length
> 2, s_missing_recipient
, clause
, expr
);
1080 ASSERT_SYNTAX_2 (length
== 3, s_extra_expression
, clause
, expr
);
1081 SCM_SETCAR (SCM_CDR (clause
), SCM_IM_ARROW
);
1083 /* SRFI 61 extended cond */
1084 else if (length
>= 3
1085 && scm_is_eq (SCM_CADDR (clause
), scm_sym_arrow
)
1088 ASSERT_SYNTAX_2 (length
> 3, s_missing_recipient
, clause
, expr
);
1089 ASSERT_SYNTAX_2 (length
== 4, s_extra_expression
, clause
, expr
);
1090 SCM_SETCAR (SCM_CDDR (clause
), SCM_IM_ARROW
);
1094 SCM_SETCAR (expr
, SCM_IM_COND
);
1099 unmemoize_cond (const SCM expr
, const SCM env
)
1101 SCM um_clauses
= SCM_EOL
;
1104 for (clause_idx
= SCM_CDR (expr
);
1105 !scm_is_null (clause_idx
);
1106 clause_idx
= SCM_CDR (clause_idx
))
1108 const SCM clause
= SCM_CAR (clause_idx
);
1109 const SCM sequence
= SCM_CDR (clause
);
1110 const SCM test
= SCM_CAR (clause
);
1115 if (scm_is_eq (test
, SCM_IM_ELSE
))
1116 um_test
= scm_sym_else
;
1118 um_test
= unmemoize_expression (test
, env
);
1120 if (!scm_is_null (sequence
) && scm_is_eq (SCM_CAR (sequence
),
1123 const SCM target
= SCM_CADR (sequence
);
1124 const SCM um_target
= unmemoize_expression (target
, env
);
1125 um_sequence
= scm_list_2 (scm_sym_arrow
, um_target
);
1129 um_sequence
= unmemoize_exprs (sequence
, env
);
1132 um_clause
= scm_cons (um_test
, um_sequence
);
1133 um_clauses
= scm_cons (um_clause
, um_clauses
);
1135 um_clauses
= scm_reverse_x (um_clauses
, SCM_UNDEFINED
);
1137 return scm_cons (scm_sym_cond
, um_clauses
);
1141 SCM_SYNTAX (s_define
, "define", scm_i_makbimacro
, scm_m_define
);
1142 SCM_GLOBAL_SYMBOL (scm_sym_define
, s_define
);
1144 /* Guile provides an extension to R5RS' define syntax to represent function
1145 * currying in a compact way. With this extension, it is allowed to write
1146 * (define <nested-variable> <body>), where <nested-variable> has of one of
1147 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
1148 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
1149 * should be either a sequence of zero or more variables, or a sequence of one
1150 * or more variables followed by a space-delimited period and another
1151 * variable. Each level of argument nesting wraps the <body> within another
1152 * lambda expression. For example, the following forms are allowed, each one
1153 * followed by an equivalent, more explicit implementation.
1155 * (define ((a b . c) . d) <body>) is equivalent to
1156 * (define a (lambda (b . c) (lambda d <body>)))
1158 * (define (((a) b) c . d) <body>) is equivalent to
1159 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
1161 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
1162 * module that does not implement this extension. */
1164 canonicalize_define (const SCM expr
)
1169 const SCM cdr_expr
= SCM_CDR (expr
);
1170 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1171 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1173 body
= SCM_CDR (cdr_expr
);
1174 variable
= SCM_CAR (cdr_expr
);
1175 while (scm_is_pair (variable
))
1177 /* This while loop realizes function currying by variable nesting.
1178 * Variable is known to be a nested-variable. In every iteration of the
1179 * loop another level of lambda expression is created, starting with the
1180 * innermost one. Note that we don't check for duplicate formals here:
1181 * This will be done by the memoizer of the lambda expression. */
1182 const SCM formals
= SCM_CDR (variable
);
1183 const SCM tail
= scm_cons (formals
, body
);
1185 /* Add source properties to each new lambda expression: */
1186 const SCM lambda
= scm_cons_source (variable
, scm_sym_lambda
, tail
);
1188 body
= scm_list_1 (lambda
);
1189 variable
= SCM_CAR (variable
);
1191 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
1192 ASSERT_SYNTAX (scm_ilength (body
) == 1, s_expression
, expr
);
1194 SCM_SETCAR (cdr_expr
, variable
);
1195 SCM_SETCDR (cdr_expr
, body
);
1199 /* According to Section 5.2.1 of R5RS we first have to make sure that the
1200 variable is bound, and then perform the `(set! variable expression)'
1201 operation. However, EXPRESSION _can_ be evaluated before VARIABLE is
1202 bound. This means that EXPRESSION won't necessarily be able to assign
1203 values to VARIABLE as in `(define foo (begin (set! foo 1) (+ foo 1)))'. */
1205 scm_m_define (SCM expr
, SCM env
)
1207 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), s_bad_define
, expr
);
1210 const SCM canonical_definition
= canonicalize_define (expr
);
1211 const SCM cdr_canonical_definition
= SCM_CDR (canonical_definition
);
1212 const SCM variable
= SCM_CAR (cdr_canonical_definition
);
1213 const SCM value
= scm_eval_car (SCM_CDR (cdr_canonical_definition
), env
);
1215 = scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_T
);
1217 if (SCM_REC_PROCNAMES_P
)
1220 while (SCM_MACROP (tmp
))
1221 tmp
= SCM_MACRO_CODE (tmp
);
1222 if (scm_is_true (scm_procedure_p (tmp
))
1223 /* Only the first definition determines the name. */
1224 && scm_is_false (scm_procedure_property (tmp
, scm_sym_name
)))
1225 scm_set_procedure_property_x (tmp
, scm_sym_name
, variable
);
1228 SCM_VARIABLE_SET (location
, value
);
1230 return SCM_UNSPECIFIED
;
1235 /* This is a helper function for forms (<keyword> <expression>) that are
1236 * transformed into (#@<keyword> '() <memoized_expression>) in order to allow
1237 * for easy creation of a thunk (i. e. a closure without arguments) using the
1238 * ('() <memoized_expression>) tail of the memoized form. */
1240 memoize_as_thunk_prototype (const SCM expr
, const SCM env SCM_UNUSED
)
1242 const SCM cdr_expr
= SCM_CDR (expr
);
1243 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1244 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1246 SCM_SETCDR (expr
, scm_cons (SCM_EOL
, cdr_expr
));
1252 SCM_SYNTAX (s_delay
, "delay", scm_i_makbimacro
, scm_m_delay
);
1253 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
1255 /* Promises are implemented as closures with an empty parameter list. Thus,
1256 * (delay <expression>) is transformed into (#@delay '() <expression>), where
1257 * the empty list represents the empty parameter list. This representation
1258 * allows for easy creation of the closure during evaluation. */
1260 scm_m_delay (SCM expr
, SCM env
)
1262 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1263 SCM_SETCAR (new_expr
, SCM_IM_DELAY
);
1268 unmemoize_delay (const SCM expr
, const SCM env
)
1270 const SCM thunk_expr
= SCM_CADDR (expr
);
1271 /* A promise is implemented as a closure, and when applying a
1272 closure the evaluator adds a new frame to the environment - even
1273 though, in the case of a promise, the added frame is always
1274 empty. We need to extend the environment here in the same way,
1275 so that any ILOCs in thunk_expr can be unmemoized correctly. */
1276 const SCM new_env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1277 return scm_list_2 (scm_sym_delay
, unmemoize_expression (thunk_expr
, new_env
));
1281 SCM_SYNTAX(s_do
, "do", scm_i_makbimacro
, scm_m_do
);
1282 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
1284 /* DO gets the most radically altered syntax. The order of the vars is
1285 * reversed here. During the evaluation this allows for simple consing of the
1286 * results of the inits and steps:
1288 (do ((<var1> <init1> <step1>)
1296 (#@do (<init1> <init2> ... <initn>)
1297 (varn ... var2 var1)
1300 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
1303 scm_m_do (SCM expr
, SCM env SCM_UNUSED
)
1305 SCM variables
= SCM_EOL
;
1306 SCM init_forms
= SCM_EOL
;
1307 SCM step_forms
= SCM_EOL
;
1314 const SCM cdr_expr
= SCM_CDR (expr
);
1315 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1316 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1318 /* Collect variables, init and step forms. */
1319 binding_idx
= SCM_CAR (cdr_expr
);
1320 ASSERT_SYNTAX_2 (scm_ilength (binding_idx
) >= 0,
1321 s_bad_bindings
, binding_idx
, expr
);
1322 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1324 const SCM binding
= SCM_CAR (binding_idx
);
1325 const long length
= scm_ilength (binding
);
1326 ASSERT_SYNTAX_2 (length
== 2 || length
== 3,
1327 s_bad_binding
, binding
, expr
);
1330 const SCM name
= SCM_CAR (binding
);
1331 const SCM init
= SCM_CADR (binding
);
1332 const SCM step
= (length
== 2) ? name
: SCM_CADDR (binding
);
1333 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
1334 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, variables
)),
1335 s_duplicate_binding
, name
, expr
);
1337 variables
= scm_cons (name
, variables
);
1338 init_forms
= scm_cons (init
, init_forms
);
1339 step_forms
= scm_cons (step
, step_forms
);
1342 init_forms
= scm_reverse_x (init_forms
, SCM_UNDEFINED
);
1343 step_forms
= scm_reverse_x (step_forms
, SCM_UNDEFINED
);
1345 /* Memoize the test form and the exit sequence. */
1346 cddr_expr
= SCM_CDR (cdr_expr
);
1347 exit_clause
= SCM_CAR (cddr_expr
);
1348 ASSERT_SYNTAX_2 (scm_ilength (exit_clause
) >= 1,
1349 s_bad_exit_clause
, exit_clause
, expr
);
1351 commands
= SCM_CDR (cddr_expr
);
1352 tail
= scm_cons2 (exit_clause
, commands
, step_forms
);
1353 tail
= scm_cons2 (init_forms
, variables
, tail
);
1354 SCM_SETCAR (expr
, SCM_IM_DO
);
1355 SCM_SETCDR (expr
, tail
);
1360 unmemoize_do (const SCM expr
, const SCM env
)
1362 const SCM cdr_expr
= SCM_CDR (expr
);
1363 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1364 const SCM rnames
= SCM_CAR (cddr_expr
);
1365 const SCM extended_env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
1366 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
1367 const SCM exit_sequence
= SCM_CAR (cdddr_expr
);
1368 const SCM um_exit_sequence
= unmemoize_exprs (exit_sequence
, extended_env
);
1369 const SCM cddddr_expr
= SCM_CDR (cdddr_expr
);
1370 const SCM um_body
= unmemoize_exprs (SCM_CAR (cddddr_expr
), extended_env
);
1372 /* build transformed binding list */
1373 SCM um_names
= scm_reverse (rnames
);
1374 SCM um_inits
= unmemoize_exprs (SCM_CAR (cdr_expr
), env
);
1375 SCM um_steps
= unmemoize_exprs (SCM_CDR (cddddr_expr
), extended_env
);
1376 SCM um_bindings
= SCM_EOL
;
1377 while (!scm_is_null (um_names
))
1379 const SCM name
= SCM_CAR (um_names
);
1380 const SCM init
= SCM_CAR (um_inits
);
1381 SCM step
= SCM_CAR (um_steps
);
1382 step
= scm_is_eq (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
1384 um_bindings
= scm_cons (scm_cons2 (name
, init
, step
), um_bindings
);
1386 um_names
= SCM_CDR (um_names
);
1387 um_inits
= SCM_CDR (um_inits
);
1388 um_steps
= SCM_CDR (um_steps
);
1390 um_bindings
= scm_reverse_x (um_bindings
, SCM_UNDEFINED
);
1392 return scm_cons (scm_sym_do
,
1393 scm_cons2 (um_bindings
, um_exit_sequence
, um_body
));
1397 SCM_SYNTAX (s_if
, "if", scm_i_makbimacro
, scm_m_if
);
1398 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
1401 scm_m_if (SCM expr
, SCM env SCM_UNUSED
)
1403 const SCM cdr_expr
= SCM_CDR (expr
);
1404 const long length
= scm_ilength (cdr_expr
);
1405 ASSERT_SYNTAX (length
== 2 || length
== 3, s_expression
, expr
);
1406 SCM_SETCAR (expr
, SCM_IM_IF
);
1411 unmemoize_if (const SCM expr
, const SCM env
)
1413 const SCM cdr_expr
= SCM_CDR (expr
);
1414 const SCM um_condition
= unmemoize_expression (SCM_CAR (cdr_expr
), env
);
1415 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1416 const SCM um_then
= unmemoize_expression (SCM_CAR (cddr_expr
), env
);
1417 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
1419 if (scm_is_null (cdddr_expr
))
1421 return scm_list_3 (scm_sym_if
, um_condition
, um_then
);
1425 const SCM um_else
= unmemoize_expression (SCM_CAR (cdddr_expr
), env
);
1426 return scm_list_4 (scm_sym_if
, um_condition
, um_then
, um_else
);
1431 SCM_SYNTAX (s_lambda
, "lambda", scm_i_makbimacro
, scm_m_lambda
);
1432 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
1434 /* A helper function for memoize_lambda to support checking for duplicate
1435 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
1436 * LIST or to the cdr of the last cons. Therefore, LIST may have any of the
1437 * forms that a formal argument can have:
1438 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
1440 c_improper_memq (SCM obj
, SCM list
)
1442 for (; scm_is_pair (list
); list
= SCM_CDR (list
))
1444 if (scm_is_eq (SCM_CAR (list
), obj
))
1447 return scm_is_eq (list
, obj
);
1451 scm_m_lambda (SCM expr
, SCM env SCM_UNUSED
)
1460 const SCM cdr_expr
= SCM_CDR (expr
);
1461 const long length
= scm_ilength (cdr_expr
);
1462 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1463 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1465 /* Before iterating the list of formal arguments, make sure the formals
1466 * actually are given as either a symbol or a non-cyclic list. */
1467 formals
= SCM_CAR (cdr_expr
);
1468 if (scm_is_pair (formals
))
1470 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
1471 * detected, report a 'Bad formals' error. */
1475 ASSERT_SYNTAX_2 (scm_is_symbol (formals
) || scm_is_null (formals
),
1476 s_bad_formals
, formals
, expr
);
1479 /* Now iterate the list of formal arguments to check if all formals are
1480 * symbols, and that there are no duplicates. */
1481 formals_idx
= formals
;
1482 while (scm_is_pair (formals_idx
))
1484 const SCM formal
= SCM_CAR (formals_idx
);
1485 const SCM next_idx
= SCM_CDR (formals_idx
);
1486 ASSERT_SYNTAX_2 (scm_is_symbol (formal
), s_bad_formal
, formal
, expr
);
1487 ASSERT_SYNTAX_2 (!c_improper_memq (formal
, next_idx
),
1488 s_duplicate_formal
, formal
, expr
);
1489 formals_idx
= next_idx
;
1491 ASSERT_SYNTAX_2 (scm_is_null (formals_idx
) || scm_is_symbol (formals_idx
),
1492 s_bad_formal
, formals_idx
, expr
);
1494 /* Memoize the body. Keep a potential documentation string. */
1495 /* Dirk:FIXME:: We should probably extract the documentation string to
1496 * some external database. Otherwise it will slow down execution, since
1497 * the documentation string will have to be skipped with every execution
1498 * of the closure. */
1499 cddr_expr
= SCM_CDR (cdr_expr
);
1500 documentation
= (length
>= 3 && scm_is_string (SCM_CAR (cddr_expr
)));
1501 body
= documentation
? SCM_CDR (cddr_expr
) : cddr_expr
;
1502 new_body
= m_body (SCM_IM_LAMBDA
, body
);
1504 SCM_SETCAR (expr
, SCM_IM_LAMBDA
);
1506 SCM_SETCDR (cddr_expr
, new_body
);
1508 SCM_SETCDR (cdr_expr
, new_body
);
1513 unmemoize_lambda (const SCM expr
, const SCM env
)
1515 const SCM formals
= SCM_CADR (expr
);
1516 const SCM body
= SCM_CDDR (expr
);
1518 const SCM new_env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, env
);
1519 const SCM um_formals
= scm_i_finite_list_copy (formals
);
1520 const SCM um_body
= unmemoize_exprs (body
, new_env
);
1522 return scm_cons2 (scm_sym_lambda
, um_formals
, um_body
);
1526 /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
1528 check_bindings (const SCM bindings
, const SCM expr
)
1532 ASSERT_SYNTAX_2 (scm_ilength (bindings
) >= 0,
1533 s_bad_bindings
, bindings
, expr
);
1535 binding_idx
= bindings
;
1536 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1538 SCM name
; /* const */
1540 const SCM binding
= SCM_CAR (binding_idx
);
1541 ASSERT_SYNTAX_2 (scm_ilength (binding
) == 2,
1542 s_bad_binding
, binding
, expr
);
1544 name
= SCM_CAR (binding
);
1545 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
1550 /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
1551 * transformed to the lists (vn ... v2 v1) and (i1 i2 ... in). That is, the
1552 * variables are returned in a list with their order reversed, and the init
1553 * forms are returned in a list in the same order as they are given in the
1554 * bindings. If a duplicate variable name is detected, an error is
1557 transform_bindings (
1558 const SCM bindings
, const SCM expr
,
1559 SCM
*const rvarptr
, SCM
*const initptr
)
1561 SCM rvariables
= SCM_EOL
;
1562 SCM rinits
= SCM_EOL
;
1563 SCM binding_idx
= bindings
;
1564 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1566 const SCM binding
= SCM_CAR (binding_idx
);
1567 const SCM cdr_binding
= SCM_CDR (binding
);
1568 const SCM name
= SCM_CAR (binding
);
1569 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, rvariables
)),
1570 s_duplicate_binding
, name
, expr
);
1571 rvariables
= scm_cons (name
, rvariables
);
1572 rinits
= scm_cons (SCM_CAR (cdr_binding
), rinits
);
1574 *rvarptr
= rvariables
;
1575 *initptr
= scm_reverse_x (rinits
, SCM_UNDEFINED
);
1579 SCM_SYNTAX(s_let
, "let", scm_i_makbimacro
, scm_m_let
);
1580 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
1582 /* This function is a helper function for memoize_let. It transforms
1583 * (let name ((var init) ...) body ...) into
1584 * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
1585 * and memoizes the expression. It is assumed that the caller has checked
1586 * that name is a symbol and that there are bindings and a body. */
1588 memoize_named_let (const SCM expr
, const SCM env SCM_UNUSED
)
1594 const SCM cdr_expr
= SCM_CDR (expr
);
1595 const SCM name
= SCM_CAR (cdr_expr
);
1596 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1597 const SCM bindings
= SCM_CAR (cddr_expr
);
1598 check_bindings (bindings
, expr
);
1600 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1601 variables
= scm_reverse_x (rvariables
, SCM_UNDEFINED
);
1604 const SCM let_body
= SCM_CDR (cddr_expr
);
1605 const SCM lambda_body
= m_body (SCM_IM_LET
, let_body
);
1606 const SCM lambda_tail
= scm_cons (variables
, lambda_body
);
1607 const SCM lambda_form
= scm_cons_source (expr
, scm_sym_lambda
, lambda_tail
);
1609 const SCM rvar
= scm_list_1 (name
);
1610 const SCM init
= scm_list_1 (lambda_form
);
1611 const SCM body
= m_body (SCM_IM_LET
, scm_list_1 (name
));
1612 const SCM letrec_tail
= scm_cons (rvar
, scm_cons (init
, body
));
1613 const SCM letrec_form
= scm_cons_source (expr
, SCM_IM_LETREC
, letrec_tail
);
1614 return scm_cons_source (expr
, letrec_form
, inits
);
1618 /* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1619 * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
1621 scm_m_let (SCM expr
, SCM env
)
1625 const SCM cdr_expr
= SCM_CDR (expr
);
1626 const long length
= scm_ilength (cdr_expr
);
1627 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1628 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1630 bindings
= SCM_CAR (cdr_expr
);
1631 if (scm_is_symbol (bindings
))
1633 ASSERT_SYNTAX (length
>= 3, s_missing_expression
, expr
);
1634 return memoize_named_let (expr
, env
);
1637 check_bindings (bindings
, expr
);
1638 if (scm_is_null (bindings
) || scm_is_null (SCM_CDR (bindings
)))
1640 /* Special case: no bindings or single binding => let* is faster. */
1641 const SCM body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1642 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), bindings
, body
), env
);
1649 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1652 const SCM new_body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1653 const SCM new_tail
= scm_cons2 (rvariables
, inits
, new_body
);
1654 SCM_SETCAR (expr
, SCM_IM_LET
);
1655 SCM_SETCDR (expr
, new_tail
);
1662 build_binding_list (SCM rnames
, SCM rinits
)
1664 SCM bindings
= SCM_EOL
;
1665 while (!scm_is_null (rnames
))
1667 const SCM binding
= scm_list_2 (SCM_CAR (rnames
), SCM_CAR (rinits
));
1668 bindings
= scm_cons (binding
, bindings
);
1669 rnames
= SCM_CDR (rnames
);
1670 rinits
= SCM_CDR (rinits
);
1676 unmemoize_let (const SCM expr
, const SCM env
)
1678 const SCM cdr_expr
= SCM_CDR (expr
);
1679 const SCM um_rnames
= SCM_CAR (cdr_expr
);
1680 const SCM extended_env
= SCM_EXTEND_ENV (um_rnames
, SCM_EOL
, env
);
1681 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1682 const SCM um_inits
= unmemoize_exprs (SCM_CAR (cddr_expr
), env
);
1683 const SCM um_rinits
= scm_reverse_x (um_inits
, SCM_UNDEFINED
);
1684 const SCM um_bindings
= build_binding_list (um_rnames
, um_rinits
);
1685 const SCM um_body
= unmemoize_exprs (SCM_CDR (cddr_expr
), extended_env
);
1687 return scm_cons2 (scm_sym_let
, um_bindings
, um_body
);
1691 SCM_SYNTAX(s_letrec
, "letrec", scm_i_makbimacro
, scm_m_letrec
);
1692 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
1695 scm_m_letrec (SCM expr
, SCM env
)
1699 const SCM cdr_expr
= SCM_CDR (expr
);
1700 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1701 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1703 bindings
= SCM_CAR (cdr_expr
);
1704 if (scm_is_null (bindings
))
1706 /* no bindings, let* is executed faster */
1707 SCM body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1708 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), SCM_EOL
, body
), env
);
1716 check_bindings (bindings
, expr
);
1717 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1718 new_body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1719 return scm_cons2 (SCM_IM_LETREC
, rvariables
, scm_cons (inits
, new_body
));
1724 unmemoize_letrec (const SCM expr
, const SCM env
)
1726 const SCM cdr_expr
= SCM_CDR (expr
);
1727 const SCM um_rnames
= SCM_CAR (cdr_expr
);
1728 const SCM extended_env
= SCM_EXTEND_ENV (um_rnames
, SCM_EOL
, env
);
1729 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1730 const SCM um_inits
= unmemoize_exprs (SCM_CAR (cddr_expr
), extended_env
);
1731 const SCM um_rinits
= scm_reverse_x (um_inits
, SCM_UNDEFINED
);
1732 const SCM um_bindings
= build_binding_list (um_rnames
, um_rinits
);
1733 const SCM um_body
= unmemoize_exprs (SCM_CDR (cddr_expr
), extended_env
);
1735 return scm_cons2 (scm_sym_letrec
, um_bindings
, um_body
);
1740 SCM_SYNTAX (s_letstar
, "let*", scm_i_makbimacro
, scm_m_letstar
);
1741 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
1743 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1744 * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
1746 scm_m_letstar (SCM expr
, SCM env SCM_UNUSED
)
1751 const SCM cdr_expr
= SCM_CDR (expr
);
1752 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1753 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1755 binding_idx
= SCM_CAR (cdr_expr
);
1756 check_bindings (binding_idx
, expr
);
1758 /* Transform ((v1 i1) (v2 i2) ...) into (v1 i1 v2 i2 ...). The
1759 * transformation is done in place. At the beginning of one iteration of
1760 * the loop the variable binding_idx holds the form
1761 * P1:( (vn . P2:(in . ())) . P3:( (vn+1 in+1) ... ) ),
1762 * where P1, P2 and P3 indicate the pairs, that are relevant for the
1763 * transformation. P1 and P2 are modified in the loop, P3 remains
1764 * untouched. After the execution of the loop, P1 will hold
1765 * P1:( vn . P2:(in . P3:( (vn+1 in+1) ... )) )
1766 * and binding_idx will hold P3. */
1767 while (!scm_is_null (binding_idx
))
1769 const SCM cdr_binding_idx
= SCM_CDR (binding_idx
); /* remember P3 */
1770 const SCM binding
= SCM_CAR (binding_idx
);
1771 const SCM name
= SCM_CAR (binding
);
1772 const SCM cdr_binding
= SCM_CDR (binding
);
1774 SCM_SETCDR (cdr_binding
, cdr_binding_idx
); /* update P2 */
1775 SCM_SETCAR (binding_idx
, name
); /* update P1 */
1776 SCM_SETCDR (binding_idx
, cdr_binding
); /* update P1 */
1778 binding_idx
= cdr_binding_idx
; /* continue with P3 */
1781 new_body
= m_body (SCM_IM_LETSTAR
, SCM_CDR (cdr_expr
));
1782 SCM_SETCAR (expr
, SCM_IM_LETSTAR
);
1783 /* the bindings have been changed in place */
1784 SCM_SETCDR (cdr_expr
, new_body
);
1789 unmemoize_letstar (const SCM expr
, const SCM env
)
1791 const SCM cdr_expr
= SCM_CDR (expr
);
1792 const SCM body
= SCM_CDR (cdr_expr
);
1793 SCM bindings
= SCM_CAR (cdr_expr
);
1794 SCM um_bindings
= SCM_EOL
;
1795 SCM extended_env
= env
;
1798 while (!scm_is_null (bindings
))
1800 const SCM variable
= SCM_CAR (bindings
);
1801 const SCM init
= SCM_CADR (bindings
);
1802 const SCM um_init
= unmemoize_expression (init
, extended_env
);
1803 um_bindings
= scm_cons (scm_list_2 (variable
, um_init
), um_bindings
);
1804 extended_env
= SCM_EXTEND_ENV (variable
, SCM_BOOL_F
, extended_env
);
1805 bindings
= SCM_CDDR (bindings
);
1807 um_bindings
= scm_reverse_x (um_bindings
, SCM_UNDEFINED
);
1809 um_body
= unmemoize_exprs (body
, extended_env
);
1811 return scm_cons2 (scm_sym_letstar
, um_bindings
, um_body
);
1815 SCM_SYNTAX (s_or
, "or", scm_i_makbimacro
, scm_m_or
);
1816 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
1819 scm_m_or (SCM expr
, SCM env SCM_UNUSED
)
1821 const SCM cdr_expr
= SCM_CDR (expr
);
1822 const long length
= scm_ilength (cdr_expr
);
1824 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1828 /* Special case: (or) is replaced by #f. */
1833 SCM_SETCAR (expr
, SCM_IM_OR
);
1839 unmemoize_or (const SCM expr
, const SCM env
)
1841 return scm_cons (scm_sym_or
, unmemoize_exprs (SCM_CDR (expr
), env
));
1845 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
1846 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
1847 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
1848 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
1850 /* Internal function to handle a quasiquotation: 'form' is the parameter in
1851 * the call (quasiquotation form), 'env' is the environment where unquoted
1852 * expressions will be evaluated, and 'depth' is the current quasiquotation
1853 * nesting level and is known to be greater than zero. */
1855 iqq (SCM form
, SCM env
, unsigned long int depth
)
1857 if (scm_is_pair (form
))
1859 const SCM tmp
= SCM_CAR (form
);
1860 if (scm_is_eq (tmp
, scm_sym_quasiquote
))
1862 const SCM args
= SCM_CDR (form
);
1863 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1864 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
1866 else if (scm_is_eq (tmp
, scm_sym_unquote
))
1868 const SCM args
= SCM_CDR (form
);
1869 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1871 return scm_eval_car (args
, env
);
1873 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
1875 else if (scm_is_pair (tmp
)
1876 && scm_is_eq (SCM_CAR (tmp
), scm_sym_uq_splicing
))
1878 const SCM args
= SCM_CDR (tmp
);
1879 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1882 const SCM list
= scm_eval_car (args
, env
);
1883 const SCM rest
= SCM_CDR (form
);
1884 ASSERT_SYNTAX_2 (scm_ilength (list
) >= 0,
1885 s_splicing
, list
, form
);
1886 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
1889 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
1890 iqq (SCM_CDR (form
), env
, depth
));
1893 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
1894 iqq (SCM_CDR (form
), env
, depth
));
1896 else if (scm_is_vector (form
))
1897 return scm_vector (iqq (scm_vector_to_list (form
), env
, depth
));
1903 scm_m_quasiquote (SCM expr
, SCM env
)
1905 const SCM cdr_expr
= SCM_CDR (expr
);
1906 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1907 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1908 return iqq (SCM_CAR (cdr_expr
), env
, 1);
1912 SCM_SYNTAX (s_quote
, "quote", scm_i_makbimacro
, scm_m_quote
);
1913 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
1916 scm_m_quote (SCM expr
, SCM env SCM_UNUSED
)
1920 const SCM cdr_expr
= SCM_CDR (expr
);
1921 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1922 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1923 quotee
= SCM_CAR (cdr_expr
);
1924 if (is_self_quoting_p (quotee
))
1927 SCM_SETCAR (expr
, SCM_IM_QUOTE
);
1928 SCM_SETCDR (expr
, quotee
);
1933 unmemoize_quote (const SCM expr
, const SCM env SCM_UNUSED
)
1935 return scm_list_2 (scm_sym_quote
, SCM_CDR (expr
));
1939 /* Will go into the RnRS module when Guile is factorized.
1940 SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
1941 static const char s_set_x
[] = "set!";
1942 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, s_set_x
);
1945 scm_m_set_x (SCM expr
, SCM env SCM_UNUSED
)
1950 const SCM cdr_expr
= SCM_CDR (expr
);
1951 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1952 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1953 variable
= SCM_CAR (cdr_expr
);
1955 /* Memoize the variable form. */
1956 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
1957 new_variable
= lookup_symbol (variable
, env
);
1958 /* Leave the memoization of unbound symbols to lazy memoization: */
1959 if (SCM_UNBNDP (new_variable
))
1960 new_variable
= variable
;
1962 SCM_SETCAR (expr
, SCM_IM_SET_X
);
1963 SCM_SETCAR (cdr_expr
, new_variable
);
1968 unmemoize_set_x (const SCM expr
, const SCM env
)
1970 return scm_cons (scm_sym_set_x
, unmemoize_exprs (SCM_CDR (expr
), env
));
1974 /* Start of the memoizers for non-R5RS builtin macros. */
1977 SCM_SYNTAX (s_atapply
, "@apply", scm_i_makbimacro
, scm_m_apply
);
1978 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1979 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1982 scm_m_apply (SCM expr
, SCM env SCM_UNUSED
)
1984 const SCM cdr_expr
= SCM_CDR (expr
);
1985 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1986 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_missing_expression
, expr
);
1988 SCM_SETCAR (expr
, SCM_IM_APPLY
);
1993 unmemoize_apply (const SCM expr
, const SCM env
)
1995 return scm_list_2 (scm_sym_atapply
, unmemoize_exprs (SCM_CDR (expr
), env
));
1999 SCM_SYNTAX (s_atbind
, "@bind", scm_i_makbimacro
, scm_m_atbind
);
2001 /* FIXME: The following explanation should go into the documentation: */
2002 /* (@bind ((var init) ...) body ...) will assign the values of the `init's to
2003 * the global variables named by `var's (symbols, not evaluated), creating
2004 * them if they don't exist, executes body, and then restores the previous
2005 * values of the `var's. Additionally, whenever control leaves body, the
2006 * values of the `var's are saved and restored when control returns. It is an
2007 * error when a symbol appears more than once among the `var's. All `init's
2008 * are evaluated before any `var' is set.
2010 * Think of this as `let' for dynamic scope.
2013 /* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into
2014 * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...).
2016 * FIXME - also implement `@bind*'.
2019 scm_m_atbind (SCM expr
, SCM env
)
2026 const SCM top_level
= scm_env_top_level (env
);
2028 const SCM cdr_expr
= SCM_CDR (expr
);
2029 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2030 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
2031 bindings
= SCM_CAR (cdr_expr
);
2032 check_bindings (bindings
, expr
);
2033 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
2035 for (variable_idx
= rvariables
;
2036 !scm_is_null (variable_idx
);
2037 variable_idx
= SCM_CDR (variable_idx
))
2039 /* The first call to scm_sym2var will look beyond the current module,
2040 * while the second call wont. */
2041 const SCM variable
= SCM_CAR (variable_idx
);
2042 SCM new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_F
);
2043 if (scm_is_false (new_variable
))
2044 new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_T
);
2045 SCM_SETCAR (variable_idx
, new_variable
);
2048 SCM_SETCAR (expr
, SCM_IM_BIND
);
2049 SCM_SETCAR (cdr_expr
, scm_cons (rvariables
, inits
));
2054 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_i_makbimacro
, scm_m_cont
);
2055 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, s_atcall_cc
);
2058 scm_m_cont (SCM expr
, SCM env SCM_UNUSED
)
2060 const SCM cdr_expr
= SCM_CDR (expr
);
2061 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2062 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2064 SCM_SETCAR (expr
, SCM_IM_CONT
);
2069 unmemoize_atcall_cc (const SCM expr
, const SCM env
)
2071 return scm_list_2 (scm_sym_atcall_cc
, unmemoize_exprs (SCM_CDR (expr
), env
));
2075 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_i_makbimacro
, scm_m_at_call_with_values
);
2076 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
2079 scm_m_at_call_with_values (SCM expr
, SCM env SCM_UNUSED
)
2081 const SCM cdr_expr
= SCM_CDR (expr
);
2082 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2083 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2085 SCM_SETCAR (expr
, SCM_IM_CALL_WITH_VALUES
);
2090 unmemoize_at_call_with_values (const SCM expr
, const SCM env
)
2092 return scm_list_2 (scm_sym_at_call_with_values
,
2093 unmemoize_exprs (SCM_CDR (expr
), env
));
2098 /* See futures.h for a comment why futures are not enabled.
2101 SCM_SYNTAX (s_future
, "future", scm_i_makbimacro
, scm_m_future
);
2102 SCM_GLOBAL_SYMBOL (scm_sym_future
, s_future
);
2104 /* Like promises, futures are implemented as closures with an empty
2105 * parameter list. Thus, (future <expression>) is transformed into
2106 * (#@future '() <expression>), where the empty list represents the
2107 * empty parameter list. This representation allows for easy creation
2108 * of the closure during evaluation. */
2110 scm_m_future (SCM expr
, SCM env
)
2112 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
2113 SCM_SETCAR (new_expr
, SCM_IM_FUTURE
);
2118 unmemoize_future (const SCM expr
, const SCM env
)
2120 const SCM thunk_expr
= SCM_CADDR (expr
);
2121 return scm_list_2 (scm_sym_future
, unmemoize_expression (thunk_expr
, env
));
2124 #endif /* futures disabled. */
2126 SCM_SYNTAX (s_gset_x
, "set!", scm_i_makbimacro
, scm_m_generalized_set_x
);
2127 SCM_SYMBOL (scm_sym_setter
, "setter");
2130 scm_m_generalized_set_x (SCM expr
, SCM env
)
2132 SCM target
, exp_target
;
2134 const SCM cdr_expr
= SCM_CDR (expr
);
2135 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2136 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2138 target
= SCM_CAR (cdr_expr
);
2139 if (!scm_is_pair (target
))
2142 return scm_m_set_x (expr
, env
);
2146 /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */
2147 /* Macroexpanding the target might return things of the form
2148 (begin <atom>). In that case, <atom> must be a symbol or a
2149 variable and we memoize to (set! <atom> ...).
2151 exp_target
= macroexp (target
, env
);
2152 if (scm_is_eq (SCM_CAR (exp_target
), SCM_IM_BEGIN
)
2153 && !scm_is_null (SCM_CDR (exp_target
))
2154 && scm_is_null (SCM_CDDR (exp_target
)))
2156 exp_target
= SCM_CADR (exp_target
);
2157 ASSERT_SYNTAX_2 (scm_is_symbol (exp_target
)
2158 || SCM_VARIABLEP (exp_target
),
2159 s_bad_variable
, exp_target
, expr
);
2160 return scm_cons (SCM_IM_SET_X
, scm_cons (exp_target
,
2161 SCM_CDR (cdr_expr
)));
2165 const SCM setter_proc_tail
= scm_list_1 (SCM_CAR (target
));
2166 const SCM setter_proc
= scm_cons_source (expr
, scm_sym_setter
,
2169 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
2170 const SCM setter_args
= scm_append_x (scm_list_2 (SCM_CDR (target
),
2173 SCM_SETCAR (expr
, setter_proc
);
2174 SCM_SETCDR (expr
, setter_args
);
2181 /* @slot-ref is bound privately in the (oop goops) module from goops.c. As
2182 * soon as the module system allows us to more freely create bindings in
2183 * arbitrary modules during the startup phase, the code from goops.c should be
2186 SCM_SYMBOL (sym_atslot_ref
, "@slot-ref");
2189 scm_m_atslot_ref (SCM expr
, SCM env SCM_UNUSED
)
2193 const SCM cdr_expr
= SCM_CDR (expr
);
2194 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2195 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2196 slot_nr
= SCM_CADR (cdr_expr
);
2197 ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2199 SCM_SETCAR (expr
, SCM_IM_SLOT_REF
);
2200 SCM_SETCDR (cdr_expr
, slot_nr
);
2205 unmemoize_atslot_ref (const SCM expr
, const SCM env
)
2207 const SCM instance
= SCM_CADR (expr
);
2208 const SCM um_instance
= unmemoize_expression (instance
, env
);
2209 const SCM slot_nr
= SCM_CDDR (expr
);
2210 return scm_list_3 (sym_atslot_ref
, um_instance
, slot_nr
);
2214 /* @slot-set! is bound privately in the (oop goops) module from goops.c. As
2215 * soon as the module system allows us to more freely create bindings in
2216 * arbitrary modules during the startup phase, the code from goops.c should be
2219 SCM_SYMBOL (sym_atslot_set_x
, "@slot-set!");
2222 scm_m_atslot_set_x (SCM expr
, SCM env SCM_UNUSED
)
2226 const SCM cdr_expr
= SCM_CDR (expr
);
2227 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2228 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 3, s_expression
, expr
);
2229 slot_nr
= SCM_CADR (cdr_expr
);
2230 ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2232 SCM_SETCAR (expr
, SCM_IM_SLOT_SET_X
);
2237 unmemoize_atslot_set_x (const SCM expr
, const SCM env
)
2239 const SCM cdr_expr
= SCM_CDR (expr
);
2240 const SCM instance
= SCM_CAR (cdr_expr
);
2241 const SCM um_instance
= unmemoize_expression (instance
, env
);
2242 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
2243 const SCM slot_nr
= SCM_CAR (cddr_expr
);
2244 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
2245 const SCM value
= SCM_CAR (cdddr_expr
);
2246 const SCM um_value
= unmemoize_expression (value
, env
);
2247 return scm_list_4 (sym_atslot_set_x
, um_instance
, slot_nr
, um_value
);
2251 #if SCM_ENABLE_ELISP
2253 static const char s_defun
[] = "Symbol's function definition is void";
2255 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_i_makbimacro
, scm_m_nil_cond
);
2257 /* nil-cond expressions have the form
2258 * (nil-cond COND VAL COND VAL ... ELSEVAL) */
2260 scm_m_nil_cond (SCM expr
, SCM env SCM_UNUSED
)
2262 const long length
= scm_ilength (SCM_CDR (expr
));
2263 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
2264 ASSERT_SYNTAX (length
>= 1 && (length
% 2) == 1, s_expression
, expr
);
2266 SCM_SETCAR (expr
, SCM_IM_NIL_COND
);
2271 SCM_SYNTAX (s_atfop
, "@fop", scm_i_makbimacro
, scm_m_atfop
);
2273 /* The @fop-macro handles procedure and macro applications for elisp. The
2274 * input expression must have the form
2275 * (@fop <var> (transformer-macro <expr> ...))
2276 * where <var> must be a symbol. The expression is transformed into the
2277 * memoized form of either
2278 * (apply <un-aliased var> (transformer-macro <expr> ...))
2279 * if the value of var (across all aliasing) is not a macro, or
2280 * (<un-aliased var> <expr> ...)
2281 * if var is a macro. */
2283 scm_m_atfop (SCM expr
, SCM env SCM_UNUSED
)
2288 const SCM cdr_expr
= SCM_CDR (expr
);
2289 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2290 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 1, s_missing_expression
, expr
);
2292 symbol
= SCM_CAR (cdr_expr
);
2293 ASSERT_SYNTAX_2 (scm_is_symbol (symbol
), s_bad_variable
, symbol
, expr
);
2295 location
= scm_symbol_fref (symbol
);
2296 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2298 /* The elisp function `defalias' allows to define aliases for symbols. To
2299 * look up such definitions, the chain of symbol definitions has to be
2300 * followed up to the terminal symbol. */
2301 while (scm_is_symbol (SCM_VARIABLE_REF (location
)))
2303 const SCM alias
= SCM_VARIABLE_REF (location
);
2304 location
= scm_symbol_fref (alias
);
2305 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2308 /* Memoize the value location belonging to the terminal symbol. */
2309 SCM_SETCAR (cdr_expr
, location
);
2311 if (!SCM_MACROP (SCM_VARIABLE_REF (location
)))
2313 /* Since the location does not contain a macro, the form is a procedure
2314 * application. Replace `@fop' by `@apply' and transform the expression
2315 * including the `transformer-macro'. */
2316 SCM_SETCAR (expr
, SCM_IM_APPLY
);
2321 /* Since the location contains a macro, the arguments should not be
2322 * transformed, so the `transformer-macro' is cut out. The resulting
2323 * expression starts with the memoized variable, that is at the cdr of
2324 * the input expression. */
2325 SCM_SETCDR (cdr_expr
, SCM_CDADR (cdr_expr
));
2330 #endif /* SCM_ENABLE_ELISP */
2334 unmemoize_builtin_macro (const SCM expr
, const SCM env
)
2336 switch (ISYMNUM (SCM_CAR (expr
)))
2338 case (ISYMNUM (SCM_IM_AND
)):
2339 return unmemoize_and (expr
, env
);
2341 case (ISYMNUM (SCM_IM_BEGIN
)):
2342 return unmemoize_begin (expr
, env
);
2344 case (ISYMNUM (SCM_IM_CASE
)):
2345 return unmemoize_case (expr
, env
);
2347 case (ISYMNUM (SCM_IM_COND
)):
2348 return unmemoize_cond (expr
, env
);
2350 case (ISYMNUM (SCM_IM_DELAY
)):
2351 return unmemoize_delay (expr
, env
);
2353 case (ISYMNUM (SCM_IM_DO
)):
2354 return unmemoize_do (expr
, env
);
2356 case (ISYMNUM (SCM_IM_IF
)):
2357 return unmemoize_if (expr
, env
);
2359 case (ISYMNUM (SCM_IM_LAMBDA
)):
2360 return unmemoize_lambda (expr
, env
);
2362 case (ISYMNUM (SCM_IM_LET
)):
2363 return unmemoize_let (expr
, env
);
2365 case (ISYMNUM (SCM_IM_LETREC
)):
2366 return unmemoize_letrec (expr
, env
);
2368 case (ISYMNUM (SCM_IM_LETSTAR
)):
2369 return unmemoize_letstar (expr
, env
);
2371 case (ISYMNUM (SCM_IM_OR
)):
2372 return unmemoize_or (expr
, env
);
2374 case (ISYMNUM (SCM_IM_QUOTE
)):
2375 return unmemoize_quote (expr
, env
);
2377 case (ISYMNUM (SCM_IM_SET_X
)):
2378 return unmemoize_set_x (expr
, env
);
2380 case (ISYMNUM (SCM_IM_APPLY
)):
2381 return unmemoize_apply (expr
, env
);
2383 case (ISYMNUM (SCM_IM_BIND
)):
2384 return unmemoize_exprs (expr
, env
); /* FIXME */
2386 case (ISYMNUM (SCM_IM_CONT
)):
2387 return unmemoize_atcall_cc (expr
, env
);
2389 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2390 return unmemoize_at_call_with_values (expr
, env
);
2393 /* See futures.h for a comment why futures are not enabled.
2395 case (ISYMNUM (SCM_IM_FUTURE
)):
2396 return unmemoize_future (expr
, env
);
2399 case (ISYMNUM (SCM_IM_SLOT_REF
)):
2400 return unmemoize_atslot_ref (expr
, env
);
2402 case (ISYMNUM (SCM_IM_SLOT_SET_X
)):
2403 return unmemoize_atslot_set_x (expr
, env
);
2405 case (ISYMNUM (SCM_IM_NIL_COND
)):
2406 return unmemoize_exprs (expr
, env
); /* FIXME */
2409 return unmemoize_exprs (expr
, env
); /* FIXME */
2414 /* scm_i_unmemocopy_expr and scm_i_unmemocopy_body take a memoized expression
2415 * respectively a memoized body together with its environment and rewrite it
2416 * to its original form. Thus, these functions are the inversion of the
2417 * rewrite rules above. The procedure is not optimized for speed. It's used
2418 * in scm_i_unmemoize_expr, scm_procedure_source, macro_print and scm_iprin1.
2420 * Unmemoizing is not a reliable process. You cannot in general expect to get
2421 * the original source back.
2423 * However, GOOPS currently relies on this for method compilation. This ought
2427 scm_i_unmemocopy_expr (SCM expr
, SCM env
)
2429 const SCM source_properties
= scm_whash_lookup (scm_source_whash
, expr
);
2430 const SCM um_expr
= unmemoize_expression (expr
, env
);
2432 if (scm_is_true (source_properties
))
2433 scm_whash_insert (scm_source_whash
, um_expr
, source_properties
);
2439 scm_i_unmemocopy_body (SCM forms
, SCM env
)
2441 const SCM source_properties
= scm_whash_lookup (scm_source_whash
, forms
);
2442 const SCM um_forms
= unmemoize_exprs (forms
, env
);
2444 if (scm_is_true (source_properties
))
2445 scm_whash_insert (scm_source_whash
, um_forms
, source_properties
);
2451 #if (SCM_ENABLE_DEPRECATED == 1)
2453 /* Deprecated in guile 1.7.0 on 2003-11-09. */
2455 scm_m_expand_body (SCM exprs
, SCM env
)
2457 scm_c_issue_deprecation_warning
2458 ("`scm_m_expand_body' is deprecated.");
2459 m_expand_body (exprs
, env
);
2464 SCM_SYNTAX (s_undefine
, "undefine", scm_makacro
, scm_m_undefine
);
2467 scm_m_undefine (SCM expr
, SCM env
)
2472 const SCM cdr_expr
= SCM_CDR (expr
);
2473 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), "Bad undefine placement in", expr
);
2474 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2475 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2477 scm_c_issue_deprecation_warning
2478 ("`undefine' is deprecated.\n");
2480 variable
= SCM_CAR (cdr_expr
);
2481 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
2482 location
= scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_F
);
2483 ASSERT_SYNTAX_2 (scm_is_true (location
)
2484 && !SCM_UNBNDP (SCM_VARIABLE_REF (location
)),
2485 "variable already unbound ", variable
, expr
);
2486 SCM_VARIABLE_SET (location
, SCM_UNDEFINED
);
2487 return SCM_UNSPECIFIED
;
2491 scm_macroexp (SCM x
, SCM env
)
2493 scm_c_issue_deprecation_warning
2494 ("`scm_macroexp' is deprecated.");
2495 return macroexp (x
, env
);
2501 #if (SCM_ENABLE_DEPRECATED == 1)
2504 scm_unmemocar (SCM form
, SCM env
)
2506 scm_c_issue_deprecation_warning
2507 ("`scm_unmemocar' is deprecated.");
2509 if (!scm_is_pair (form
))
2513 SCM c
= SCM_CAR (form
);
2514 if (SCM_VARIABLEP (c
))
2516 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
2517 if (scm_is_false (sym
))
2518 sym
= sym_three_question_marks
;
2519 SCM_SETCAR (form
, sym
);
2521 else if (SCM_ILOCP (c
))
2523 unsigned long int ir
;
2525 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
2526 env
= SCM_CDR (env
);
2527 env
= SCM_CAAR (env
);
2528 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
2529 env
= SCM_CDR (env
);
2531 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
2539 /*****************************************************************************/
2540 /*****************************************************************************/
2541 /* The definitions for execution start here. */
2542 /*****************************************************************************/
2543 /*****************************************************************************/
2545 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
2546 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
2547 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
2548 SCM_GLOBAL_SYMBOL (scm_sym_memoize_symbol
, "memoize-symbol");
2549 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
2550 SCM_SYMBOL (sym_instead
, "instead");
2552 /* A function object to implement "apply" for non-closure functions. */
2554 /* An endless list consisting of #<undefined> objects: */
2555 static SCM undefineds
;
2559 scm_badargsp (SCM formals
, SCM args
)
2561 while (!scm_is_null (formals
))
2563 if (!scm_is_pair (formals
))
2565 if (scm_is_null (args
))
2567 formals
= SCM_CDR (formals
);
2568 args
= SCM_CDR (args
);
2570 return !scm_is_null (args
) ? 1 : 0;
2575 /* The evaluator contains a plethora of EVAL symbols.
2578 * SCM_I_EVALIM is used when it is known that the expression is an
2579 * immediate. (This macro never calls an evaluator.)
2581 * SCM_I_XEVAL evaluates an expression that is expected to have its symbols already
2582 * memoized. Expressions that are not of the form '(<form> <form> ...)' are
2583 * evaluated inline without calling an evaluator.
2585 * This macro uses ceval or deval depending on its 3rd argument.
2587 * SCM_I_XEVALCAR evaluates the car of an expression 'X:(Y:<form> <form> ...)',
2588 * potentially replacing a symbol at the position Y:<form> by its memoized
2589 * variable. If Y:<form> is not of the form '(<form> <form> ...)', the
2590 * evaluation is performed inline without calling an evaluator.
2592 * This macro uses ceval or deval depending on its 3rd argument.
2596 #define SCM_I_EVALIM2(x) \
2597 ((scm_is_eq ((x), SCM_EOL) \
2598 ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \
2602 #define SCM_I_EVALIM(x, env) (SCM_ILOCP (x) \
2603 ? *scm_ilookup ((x), (env)) \
2606 #define SCM_I_XEVAL(x, env, debug_p) \
2608 ? SCM_I_EVALIM2 (x) \
2609 : (SCM_VARIABLEP (x) \
2610 ? SCM_VARIABLE_REF (x) \
2611 : (scm_is_pair (x) \
2613 ? deval ((x), (env)) \
2614 : ceval ((x), (env))) \
2617 #define SCM_I_XEVALCAR(x, env, debug_p) \
2618 (SCM_IMP (SCM_CAR (x)) \
2619 ? SCM_I_EVALIM (SCM_CAR (x), (env)) \
2620 : (SCM_VARIABLEP (SCM_CAR (x)) \
2621 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2622 : (scm_is_pair (SCM_CAR (x)) \
2624 ? deval (SCM_CAR (x), (env)) \
2625 : ceval (SCM_CAR (x), (env))) \
2626 : (!scm_is_symbol (SCM_CAR (x)) \
2628 : *scm_lookupcar ((x), (env), 1)))))
2630 scm_i_pthread_mutex_t source_mutex
;
2633 /* Lookup a given local variable in an environment. The local variable is
2634 * given as an iloc, that is a triple <frame, binding, last?>, where frame
2635 * indicates the relative number of the environment frame (counting upwards
2636 * from the innermost environment frame), binding indicates the number of the
2637 * binding within the frame, and last? (which is extracted from the iloc using
2638 * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
2639 * very end of the improper list of bindings. */
2641 scm_ilookup (SCM iloc
, SCM env
)
2643 unsigned int frame_nr
= SCM_IFRAME (iloc
);
2644 unsigned int binding_nr
= SCM_IDIST (iloc
);
2648 for (; 0 != frame_nr
; --frame_nr
)
2649 frames
= SCM_CDR (frames
);
2651 bindings
= SCM_CAR (frames
);
2652 for (; 0 != binding_nr
; --binding_nr
)
2653 bindings
= SCM_CDR (bindings
);
2655 if (SCM_ICDRP (iloc
))
2656 return SCM_CDRLOC (bindings
);
2657 return SCM_CARLOC (SCM_CDR (bindings
));
2661 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
2663 static void error_unbound_variable (SCM symbol
) SCM_NORETURN
;
2664 static void error_defined_variable (SCM symbol
) SCM_NORETURN
;
2666 /* Call this for variables that are unfound.
2669 error_unbound_variable (SCM symbol
)
2671 scm_error (scm_unbound_variable_key
, NULL
,
2672 "Unbound variable: ~S",
2673 scm_list_1 (symbol
), SCM_BOOL_F
);
2676 /* Call this for variables that are found but contain SCM_UNDEFINED.
2679 error_defined_variable (SCM symbol
)
2681 /* We use the 'unbound-variable' key here as well, since it
2682 basically is the same kind of error, with a slight variation in
2683 the displayed message.
2685 scm_error (scm_unbound_variable_key
, NULL
,
2686 "Variable used before given a value: ~S",
2687 scm_list_1 (symbol
), SCM_BOOL_F
);
2691 /* The Lookup Car Race
2694 Memoization of variables and special forms is done while executing
2695 the code for the first time. As long as there is only one thread
2696 everything is fine, but as soon as two threads execute the same
2697 code concurrently `for the first time' they can come into conflict.
2699 This memoization includes rewriting variable references into more
2700 efficient forms and expanding macros. Furthermore, macro expansion
2701 includes `compiling' special forms like `let', `cond', etc. into
2702 tree-code instructions.
2704 There shouldn't normally be a problem with memoizing local and
2705 global variable references (into ilocs and variables), because all
2706 threads will mutate the code in *exactly* the same way and (if I
2707 read the C code correctly) it is not possible to observe a half-way
2708 mutated cons cell. The lookup procedure can handle this
2709 transparently without any critical sections.
2711 It is different with macro expansion, because macro expansion
2712 happens outside of the lookup procedure and can't be
2713 undone. Therefore the lookup procedure can't cope with it. It has
2714 to indicate failure when it detects a lost race and hope that the
2715 caller can handle it. Luckily, it turns out that this is the case.
2717 An example to illustrate this: Suppose that the following form will
2718 be memoized concurrently by two threads
2722 Let's first examine the lookup of X in the body. The first thread
2723 decides that it has to find the symbol "x" in the environment and
2724 starts to scan it. Then the other thread takes over and actually
2725 overtakes the first. It looks up "x" and substitutes an
2726 appropriate iloc for it. Now the first thread continues and
2727 completes its lookup. It comes to exactly the same conclusions as
2728 the second one and could - without much ado - just overwrite the
2729 iloc with the same iloc.
2731 But let's see what will happen when the race occurs while looking
2732 up the symbol "let" at the start of the form. It could happen that
2733 the second thread interrupts the lookup of the first thread and not
2734 only substitutes a variable for it but goes right ahead and
2735 replaces it with the compiled form (#@let* (x 12) x). Now, when
2736 the first thread completes its lookup, it would replace the #@let*
2737 with a variable containing the "let" binding, effectively reverting
2738 the form to (let (x 12) x). This is wrong. It has to detect that
2739 it has lost the race and the evaluator has to reconsider the
2740 changed form completely.
2742 This race condition could be resolved with some kind of traffic
2743 light (like mutexes) around scm_lookupcar, but I think that it is
2744 best to avoid them in this case. They would serialize memoization
2745 completely and because lookup involves calling arbitrary Scheme
2746 code (via the lookup-thunk), threads could be blocked for an
2747 arbitrary amount of time or even deadlock. But with the current
2748 solution a lot of unnecessary work is potentially done. */
2750 /* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
2751 return NULL to indicate a failed lookup due to some race conditions
2752 between threads. This only happens when VLOC is the first cell of
2753 a special form that will eventually be memoized (like `let', etc.)
2754 In that case the whole lookup is bogus and the caller has to
2755 reconsider the complete special form.
2757 SCM_LOOKUPCAR is still there, of course. It just calls
2758 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
2759 should only be called when it is known that VLOC is not the first
2760 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
2761 for NULL. I think I've found the only places where this
2765 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
2768 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
2769 register SCM iloc
= SCM_ILOC00
;
2770 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
2772 if (!scm_is_pair (SCM_CAR (env
)))
2774 al
= SCM_CARLOC (env
);
2775 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
2777 if (!scm_is_pair (fl
))
2779 if (scm_is_eq (fl
, var
))
2781 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2783 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
2784 return SCM_CDRLOC (*al
);
2789 al
= SCM_CDRLOC (*al
);
2790 if (scm_is_eq (SCM_CAR (fl
), var
))
2792 if (SCM_UNBNDP (SCM_CAR (*al
)))
2793 error_defined_variable (var
);
2794 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2796 SCM_SETCAR (vloc
, iloc
);
2797 return SCM_CARLOC (*al
);
2799 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
2801 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
2804 SCM top_thunk
, real_var
;
2807 top_thunk
= SCM_CAR (env
); /* env now refers to a
2808 top level env thunk */
2809 env
= SCM_CDR (env
);
2812 top_thunk
= SCM_BOOL_F
;
2813 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
2814 if (scm_is_false (real_var
))
2817 if (!scm_is_null (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
2822 if (scm_is_null (env
))
2823 error_unbound_variable (var
);
2825 scm_misc_error (NULL
, "Damaged environment: ~S",
2830 /* A variable could not be found, but we shall
2831 not throw an error. */
2832 static SCM undef_object
= SCM_UNDEFINED
;
2833 return &undef_object
;
2837 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2839 /* Some other thread has changed the very cell we are working
2840 on. In effect, it must have done our job or messed it up
2843 var
= SCM_CAR (vloc
);
2844 if (SCM_VARIABLEP (var
))
2845 return SCM_VARIABLE_LOC (var
);
2846 if (SCM_ILOCP (var
))
2847 return scm_ilookup (var
, genv
);
2848 /* We can't cope with anything else than variables and ilocs. When
2849 a special form has been memoized (i.e. `let' into `#@let') we
2850 return NULL and expect the calling function to do the right
2851 thing. For the evaluator, this means going back and redoing
2852 the dispatch on the car of the form. */
2856 SCM_SETCAR (vloc
, real_var
);
2857 return SCM_VARIABLE_LOC (real_var
);
2862 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
2864 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
2871 /* During execution, look up a symbol in the top level of the given local
2872 * environment and return the corresponding variable object. If no binding
2873 * for the symbol can be found, an 'Unbound variable' error is signalled. */
2875 lazy_memoize_variable (const SCM symbol
, const SCM environment
)
2877 const SCM top_level
= scm_env_top_level (environment
);
2878 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
2880 if (scm_is_false (variable
))
2881 error_unbound_variable (symbol
);
2888 scm_eval_car (SCM pair
, SCM env
)
2890 return SCM_I_XEVALCAR (pair
, env
, scm_debug_mode_p
);
2895 scm_eval_body (SCM code
, SCM env
)
2900 next
= SCM_CDR (code
);
2901 while (!scm_is_null (next
))
2903 if (SCM_IMP (SCM_CAR (code
)))
2905 if (SCM_ISYMP (SCM_CAR (code
)))
2907 scm_dynwind_begin (0);
2908 scm_i_dynwind_pthread_mutex_lock (&source_mutex
);
2909 /* check for race condition */
2910 if (SCM_ISYMP (SCM_CAR (code
)))
2911 m_expand_body (code
, env
);
2917 SCM_I_XEVAL (SCM_CAR (code
), env
, scm_debug_mode_p
);
2919 next
= SCM_CDR (code
);
2921 return SCM_I_XEVALCAR (code
, env
, scm_debug_mode_p
);
2925 /* scm_last_debug_frame contains a pointer to the last debugging information
2926 * stack frame. It is accessed very often from the debugging evaluator, so it
2927 * should probably not be indirectly addressed. Better to save and restore it
2928 * from the current root at any stack swaps.
2931 /* scm_debug_eframe_size is the number of slots available for pseudo
2932 * stack frames at each real stack frame.
2935 long scm_debug_eframe_size
;
2937 int scm_debug_mode_p
;
2938 int scm_check_entry_p
;
2939 int scm_check_apply_p
;
2940 int scm_check_exit_p
;
2941 int scm_check_memoize_p
;
2943 long scm_eval_stack
;
2945 scm_t_option scm_eval_opts
[] = {
2946 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." },
2950 scm_t_option scm_debug_opts
[] = {
2951 { SCM_OPTION_BOOLEAN
, "cheap", 1,
2952 "*This option is now obsolete. Setting it has no effect." },
2953 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
2954 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
2955 { SCM_OPTION_BOOLEAN
, "procnames", 1,
2956 "Record procedure names at definition." },
2957 { SCM_OPTION_BOOLEAN
, "backwards", 0,
2958 "Display backtrace in anti-chronological order." },
2959 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
2960 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
2961 { SCM_OPTION_INTEGER
, "frames", 3,
2962 "Maximum number of tail-recursive frames in backtrace." },
2963 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
2964 "Maximal number of stored backtrace frames." },
2965 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
2966 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
2967 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
2969 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
2970 { SCM_OPTION_SCM
, "show-file-name", (unsigned long)SCM_BOOL_T
,
2971 "Show file names and line numbers "
2972 "in backtraces when not `#f'. A value of `base' "
2973 "displays only base names, while `#t' displays full names."},
2974 { SCM_OPTION_BOOLEAN
, "warn-deprecated", 0,
2975 "Warn when deprecated features are used." },
2981 * this ordering is awkward and illogical, but we maintain it for
2982 * compatibility. --hwn
2984 scm_t_option scm_evaluator_trap_table
[] = {
2985 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
2986 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
2987 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
2988 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
2989 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
2990 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
2991 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." },
2992 { SCM_OPTION_BOOLEAN
, "memoize-symbol", 0, "Trap when memoizing a symbol." },
2993 { SCM_OPTION_SCM
, "memoize-symbol-handler", (unsigned long)SCM_BOOL_F
, "The handler for memoization." },
2998 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
3000 "Option interface for the evaluation options. Instead of using\n"
3001 "this procedure directly, use the procedures @code{eval-enable},\n"
3002 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
3003 #define FUNC_NAME s_scm_eval_options_interface
3007 scm_dynwind_begin (0);
3008 scm_dynwind_critical_section (SCM_BOOL_F
);
3009 ans
= scm_options (setting
,
3012 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
3020 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
3022 "Option interface for the evaluator trap options.")
3023 #define FUNC_NAME s_scm_evaluator_traps
3028 scm_options_try (setting
,
3029 scm_evaluator_trap_table
,
3031 SCM_CRITICAL_SECTION_START
;
3032 ans
= scm_options (setting
,
3033 scm_evaluator_trap_table
,
3036 /* njrev: same again. */
3037 SCM_RESET_DEBUG_MODE
;
3038 SCM_CRITICAL_SECTION_END
;
3047 /* Simple procedure calls
3051 scm_call_0 (SCM proc
)
3053 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
3057 scm_call_1 (SCM proc
, SCM arg1
)
3059 return scm_apply (proc
, arg1
, scm_listofnull
);
3063 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
3065 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
3069 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
3071 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
3075 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
3077 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
3078 scm_cons (arg4
, scm_listofnull
)));
3081 /* Simple procedure applies
3085 scm_apply_0 (SCM proc
, SCM args
)
3087 return scm_apply (proc
, args
, SCM_EOL
);
3091 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
3093 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
3097 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
3099 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
3103 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
3105 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
3109 /* This code processes the arguments to apply:
3111 (apply PROC ARG1 ... ARGS)
3113 Given a list (ARG1 ... ARGS), this function conses the ARG1
3114 ... arguments onto the front of ARGS, and returns the resulting
3115 list. Note that ARGS is a list; thus, the argument to this
3116 function is a list whose last element is a list.
3118 Apply calls this function, and applies PROC to the elements of the
3119 result. apply:nconc2last takes care of building the list of
3120 arguments, given (ARG1 ... ARGS).
3122 Rather than do new consing, apply:nconc2last destroys its argument.
3123 On that topic, this code came into my care with the following
3124 beautifully cryptic comment on that topic: "This will only screw
3125 you if you do (scm_apply scm_apply '( ... ))" If you know what
3126 they're referring to, send me a patch to this comment. */
3128 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3130 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
3131 "conses the @var{arg1} @dots{} arguments onto the front of\n"
3132 "@var{args}, and returns the resulting list. Note that\n"
3133 "@var{args} is a list; thus, the argument to this function is\n"
3134 "a list whose last element is a list.\n"
3135 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
3136 "destroys its argument, so use with care.")
3137 #define FUNC_NAME s_scm_nconc2last
3140 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
3142 while (!scm_is_null (SCM_CDR (*lloc
))) /* Perhaps should be
3143 SCM_NULL_OR_NIL_P, but not
3144 needed in 99.99% of cases,
3145 and it could seriously hurt
3146 performance. - Neil */
3147 lloc
= SCM_CDRLOC (*lloc
);
3148 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3149 *lloc
= SCM_CAR (*lloc
);
3156 /* SECTION: The rest of this file is only read once.
3161 * Trampolines make it possible to move procedure application dispatch
3162 * outside inner loops. The motivation was clean implementation of
3163 * efficient replacements of R5RS primitives in SRFI-1.
3165 * The semantics is clear: scm_trampoline_N returns an optimized
3166 * version of scm_call_N (or NULL if the procedure isn't applicable
3169 * Applying the optimization to map and for-each increased efficiency
3170 * noticeably. For example, (map abs ls) is now 8 times faster than
3175 call_subr0_0 (SCM proc
)
3177 return SCM_SUBRF (proc
) ();
3181 call_subr1o_0 (SCM proc
)
3183 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
3187 call_lsubr_0 (SCM proc
)
3189 return SCM_SUBRF (proc
) (SCM_EOL
);
3193 scm_i_call_closure_0 (SCM proc
)
3195 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3198 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
3203 scm_trampoline_0 (SCM proc
)
3205 scm_t_trampoline_0 trampoline
;
3210 switch (SCM_TYP7 (proc
))
3212 case scm_tc7_subr_0
:
3213 trampoline
= call_subr0_0
;
3215 case scm_tc7_subr_1o
:
3216 trampoline
= call_subr1o_0
;
3219 trampoline
= call_lsubr_0
;
3221 case scm_tcs_closures
:
3223 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3224 if (scm_is_null (formals
) || !scm_is_pair (formals
))
3225 trampoline
= scm_i_call_closure_0
;
3230 case scm_tcs_struct
:
3231 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3232 trampoline
= scm_call_generic_0
;
3233 else if (SCM_I_OPERATORP (proc
))
3234 trampoline
= scm_call_0
;
3239 if (SCM_SMOB_APPLICABLE_P (proc
))
3240 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
3245 case scm_tc7_rpsubr
:
3248 trampoline
= scm_call_0
;
3251 return NULL
; /* not applicable on zero arguments */
3253 /* We only reach this point if a valid trampoline was determined. */
3255 /* If debugging is enabled, we want to see all calls to proc on the stack.
3256 * Thus, we replace the trampoline shortcut with scm_call_0. */
3257 if (scm_debug_mode_p
)
3264 call_subr1_1 (SCM proc
, SCM arg1
)
3266 return SCM_SUBRF (proc
) (arg1
);
3270 call_subr2o_1 (SCM proc
, SCM arg1
)
3272 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
3276 call_lsubr_1 (SCM proc
, SCM arg1
)
3278 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
3282 call_dsubr_1 (SCM proc
, SCM arg1
)
3284 if (SCM_I_INUMP (arg1
))
3286 return (scm_from_double (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
))));
3288 else if (SCM_REALP (arg1
))
3290 return (scm_from_double (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3292 else if (SCM_BIGP (arg1
))
3294 return (scm_from_double (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3296 else if (SCM_FRACTIONP (arg1
))
3298 return (scm_from_double (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
3300 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3301 SCM_ARG1
, scm_i_symbol_chars (SCM_SNAME (proc
)));
3305 call_cxr_1 (SCM proc
, SCM arg1
)
3307 return scm_i_chase_pairs (arg1
, (scm_t_bits
) SCM_SUBRF (proc
));
3311 call_closure_1 (SCM proc
, SCM arg1
)
3313 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3316 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
3321 scm_trampoline_1 (SCM proc
)
3323 scm_t_trampoline_1 trampoline
;
3328 switch (SCM_TYP7 (proc
))
3330 case scm_tc7_subr_1
:
3331 case scm_tc7_subr_1o
:
3332 trampoline
= call_subr1_1
;
3334 case scm_tc7_subr_2o
:
3335 trampoline
= call_subr2o_1
;
3338 trampoline
= call_lsubr_1
;
3341 trampoline
= call_dsubr_1
;
3344 trampoline
= call_cxr_1
;
3346 case scm_tcs_closures
:
3348 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3349 if (!scm_is_null (formals
)
3350 && (!scm_is_pair (formals
) || !scm_is_pair (SCM_CDR (formals
))))
3351 trampoline
= call_closure_1
;
3356 case scm_tcs_struct
:
3357 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3358 trampoline
= scm_call_generic_1
;
3359 else if (SCM_I_OPERATORP (proc
))
3360 trampoline
= scm_call_1
;
3365 if (SCM_SMOB_APPLICABLE_P (proc
))
3366 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
3371 case scm_tc7_rpsubr
:
3374 trampoline
= scm_call_1
;
3377 return NULL
; /* not applicable on one arg */
3379 /* We only reach this point if a valid trampoline was determined. */
3381 /* If debugging is enabled, we want to see all calls to proc on the stack.
3382 * Thus, we replace the trampoline shortcut with scm_call_1. */
3383 if (scm_debug_mode_p
)
3390 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
3392 return SCM_SUBRF (proc
) (arg1
, arg2
);
3396 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
3398 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
3402 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
3404 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
3408 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
3410 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3411 scm_list_2 (arg1
, arg2
),
3413 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
3418 scm_trampoline_2 (SCM proc
)
3420 scm_t_trampoline_2 trampoline
;
3425 switch (SCM_TYP7 (proc
))
3427 case scm_tc7_subr_2
:
3428 case scm_tc7_subr_2o
:
3429 case scm_tc7_rpsubr
:
3431 trampoline
= call_subr2_2
;
3433 case scm_tc7_lsubr_2
:
3434 trampoline
= call_lsubr2_2
;
3437 trampoline
= call_lsubr_2
;
3439 case scm_tcs_closures
:
3441 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3442 if (!scm_is_null (formals
)
3443 && (!scm_is_pair (formals
)
3444 || (!scm_is_null (SCM_CDR (formals
))
3445 && (!scm_is_pair (SCM_CDR (formals
))
3446 || !scm_is_pair (SCM_CDDR (formals
))))))
3447 trampoline
= call_closure_2
;
3452 case scm_tcs_struct
:
3453 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3454 trampoline
= scm_call_generic_2
;
3455 else if (SCM_I_OPERATORP (proc
))
3456 trampoline
= scm_call_2
;
3461 if (SCM_SMOB_APPLICABLE_P (proc
))
3462 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
3468 trampoline
= scm_call_2
;
3471 return NULL
; /* not applicable on two args */
3473 /* We only reach this point if a valid trampoline was determined. */
3475 /* If debugging is enabled, we want to see all calls to proc on the stack.
3476 * Thus, we replace the trampoline shortcut with scm_call_2. */
3477 if (scm_debug_mode_p
)
3483 /* Typechecking for multi-argument MAP and FOR-EACH.
3485 Verify that each element of the vector ARGV, except for the first,
3486 is a proper list whose length is LEN. Attribute errors to WHO,
3487 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3489 check_map_args (SCM argv
,
3498 for (i
= SCM_SIMPLE_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
3500 SCM elt
= SCM_SIMPLE_VECTOR_REF (argv
, i
);
3501 long elt_len
= scm_ilength (elt
);
3506 scm_apply_generic (gf
, scm_cons (proc
, args
));
3508 scm_wrong_type_arg (who
, i
+ 2, elt
);
3512 scm_out_of_range_pos (who
, elt
, scm_from_long (i
+ 2));
3517 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3519 /* Note: Currently, scm_map applies PROC to the argument list(s)
3520 sequentially, starting with the first element(s). This is used in
3521 evalext.c where the Scheme procedure `map-in-order', which guarantees
3522 sequential behaviour, is implemented using scm_map. If the
3523 behaviour changes, we need to update `map-in-order'.
3527 scm_map (SCM proc
, SCM arg1
, SCM args
)
3528 #define FUNC_NAME s_map
3534 len
= scm_ilength (arg1
);
3535 SCM_GASSERTn (len
>= 0,
3536 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
3537 SCM_VALIDATE_REST_ARGUMENT (args
);
3538 if (scm_is_null (args
))
3540 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
3541 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
3542 while (SCM_NIMP (arg1
))
3544 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
3545 pres
= SCM_CDRLOC (*pres
);
3546 arg1
= SCM_CDR (arg1
);
3550 if (scm_is_null (SCM_CDR (args
)))
3552 SCM arg2
= SCM_CAR (args
);
3553 int len2
= scm_ilength (arg2
);
3554 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
3556 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
3557 SCM_GASSERTn (len2
>= 0,
3558 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
3560 SCM_OUT_OF_RANGE (3, arg2
);
3561 while (SCM_NIMP (arg1
))
3563 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
3564 pres
= SCM_CDRLOC (*pres
);
3565 arg1
= SCM_CDR (arg1
);
3566 arg2
= SCM_CDR (arg2
);
3570 arg1
= scm_cons (arg1
, args
);
3571 args
= scm_vector (arg1
);
3572 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
3576 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3578 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
3581 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
3582 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
3584 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
3585 pres
= SCM_CDRLOC (*pres
);
3591 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
3594 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
3595 #define FUNC_NAME s_for_each
3598 len
= scm_ilength (arg1
);
3599 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
3600 SCM_ARG2
, s_for_each
);
3601 SCM_VALIDATE_REST_ARGUMENT (args
);
3602 if (scm_is_null (args
))
3604 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
3605 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
3606 while (SCM_NIMP (arg1
))
3608 call (proc
, SCM_CAR (arg1
));
3609 arg1
= SCM_CDR (arg1
);
3611 return SCM_UNSPECIFIED
;
3613 if (scm_is_null (SCM_CDR (args
)))
3615 SCM arg2
= SCM_CAR (args
);
3616 int len2
= scm_ilength (arg2
);
3617 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
3618 SCM_GASSERTn (call
, g_for_each
,
3619 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
3620 SCM_GASSERTn (len2
>= 0, g_for_each
,
3621 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
3623 SCM_OUT_OF_RANGE (3, arg2
);
3624 while (SCM_NIMP (arg1
))
3626 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
3627 arg1
= SCM_CDR (arg1
);
3628 arg2
= SCM_CDR (arg2
);
3630 return SCM_UNSPECIFIED
;
3632 arg1
= scm_cons (arg1
, args
);
3633 args
= scm_vector (arg1
);
3634 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
3638 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3640 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
3642 return SCM_UNSPECIFIED
;
3643 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
3644 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
3646 scm_apply (proc
, arg1
, SCM_EOL
);
3653 scm_closure (SCM code
, SCM env
)
3656 SCM closcar
= scm_cons (code
, SCM_EOL
);
3657 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
3658 scm_remember_upto_here (closcar
);
3663 scm_t_bits scm_tc16_promise
;
3666 scm_makprom (SCM code
)
3668 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
3670 scm_make_recursive_mutex ());
3674 promise_mark (SCM promise
)
3676 scm_gc_mark (SCM_PROMISE_MUTEX (promise
));
3677 return SCM_PROMISE_DATA (promise
);
3681 promise_free (SCM promise
)
3687 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
3689 int writingp
= SCM_WRITINGP (pstate
);
3690 scm_puts ("#<promise ", port
);
3691 SCM_SET_WRITINGP (pstate
, 1);
3692 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
3693 SCM_SET_WRITINGP (pstate
, writingp
);
3694 scm_putc ('>', port
);
3698 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
3700 "If the promise @var{x} has not been computed yet, compute and\n"
3701 "return @var{x}, otherwise just return the previously computed\n"
3703 #define FUNC_NAME s_scm_force
3705 SCM_VALIDATE_SMOB (1, promise
, promise
);
3706 scm_lock_mutex (SCM_PROMISE_MUTEX (promise
));
3707 if (!SCM_PROMISE_COMPUTED_P (promise
))
3709 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
3710 if (!SCM_PROMISE_COMPUTED_P (promise
))
3712 SCM_SET_PROMISE_DATA (promise
, ans
);
3713 SCM_SET_PROMISE_COMPUTED (promise
);
3716 scm_unlock_mutex (SCM_PROMISE_MUTEX (promise
));
3717 return SCM_PROMISE_DATA (promise
);
3722 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
3724 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
3725 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
3726 #define FUNC_NAME s_scm_promise_p
3728 return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
3733 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
3734 (SCM xorig
, SCM x
, SCM y
),
3735 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
3736 "Any source properties associated with @var{xorig} are also associated\n"
3737 "with the new pair.")
3738 #define FUNC_NAME s_scm_cons_source
3741 z
= scm_cons (x
, y
);
3742 /* Copy source properties possibly associated with xorig. */
3743 p
= scm_whash_lookup (scm_source_whash
, xorig
);
3744 if (scm_is_true (p
))
3745 scm_whash_insert (scm_source_whash
, z
, p
);
3751 /* The function scm_copy_tree is used to copy an expression tree to allow the
3752 * memoizer to modify the expression during memoization. scm_copy_tree
3753 * creates deep copies of pairs and vectors, but not of any other data types,
3754 * since only pairs and vectors will be parsed by the memoizer.
3756 * To avoid infinite recursion due to cyclic structures, the hare-and-tortoise
3757 * pattern is used to detect cycles. In fact, the pattern is used in two
3758 * dimensions, vertical (indicated in the code by the variable names 'hare'
3759 * and 'tortoise') and horizontal ('rabbit' and 'turtle'). In both
3760 * dimensions, the hare/rabbit will take two steps when the tortoise/turtle
3763 * The vertical dimension corresponds to recursive calls to function
3764 * copy_tree: This happens when descending into vector elements, into cars of
3765 * lists and into the cdr of an improper list. In this dimension, the
3766 * tortoise follows the hare by using the processor stack: Every stack frame
3767 * will hold an instance of struct t_trace. These instances are connected in
3768 * a way that represents the trace of the hare, which thus can be followed by
3769 * the tortoise. The tortoise will always point to struct t_trace instances
3770 * relating to SCM objects that have already been copied. Thus, a cycle is
3771 * detected if the tortoise and the hare point to the same object,
3773 * The horizontal dimension is within one execution of copy_tree, when the
3774 * function cdr's along the pairs of a list. This is the standard
3775 * hare-and-tortoise implementation, found several times in guile. */
3778 struct t_trace
*trace
; /* These pointers form a trace along the stack. */
3779 SCM obj
; /* The object handled at the respective stack frame.*/
3784 struct t_trace
*const hare
,
3785 struct t_trace
*tortoise
,
3786 unsigned int tortoise_delay
)
3788 if (!scm_is_pair (hare
->obj
) && !scm_is_simple_vector (hare
->obj
))
3794 /* Prepare the trace along the stack. */
3795 struct t_trace new_hare
;
3796 hare
->trace
= &new_hare
;
3798 /* The tortoise will make its step after the delay has elapsed. Note
3799 * that in contrast to the typical hare-and-tortoise pattern, the step
3800 * of the tortoise happens before the hare takes its steps. This is, in
3801 * principle, no problem, except for the start of the algorithm: Then,
3802 * it has to be made sure that the hare actually gets its advantage of
3804 if (tortoise_delay
== 0)
3807 tortoise
= tortoise
->trace
;
3808 ASSERT_SYNTAX (!scm_is_eq (hare
->obj
, tortoise
->obj
),
3809 s_bad_expression
, hare
->obj
);
3816 if (scm_is_simple_vector (hare
->obj
))
3818 size_t length
= SCM_SIMPLE_VECTOR_LENGTH (hare
->obj
);
3819 SCM new_vector
= scm_c_make_vector (length
, SCM_UNSPECIFIED
);
3821 /* Each vector element is copied by recursing into copy_tree, having
3822 * the tortoise follow the hare into the depths of the stack. */
3823 unsigned long int i
;
3824 for (i
= 0; i
< length
; ++i
)
3827 new_hare
.obj
= SCM_SIMPLE_VECTOR_REF (hare
->obj
, i
);
3828 new_element
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3829 SCM_SIMPLE_VECTOR_SET (new_vector
, i
, new_element
);
3834 else /* scm_is_pair (hare->obj) */
3839 SCM rabbit
= hare
->obj
;
3840 SCM turtle
= hare
->obj
;
3844 /* The first pair of the list is treated specially, in order to
3845 * preserve a potential source code position. */
3846 result
= tail
= scm_cons_source (rabbit
, SCM_EOL
, SCM_EOL
);
3847 new_hare
.obj
= SCM_CAR (rabbit
);
3848 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3849 SCM_SETCAR (tail
, copy
);
3851 /* The remaining pairs of the list are copied by, horizontally,
3852 * having the turtle follow the rabbit, and, vertically, having the
3853 * tortoise follow the hare into the depths of the stack. */
3854 rabbit
= SCM_CDR (rabbit
);
3855 while (scm_is_pair (rabbit
))
3857 new_hare
.obj
= SCM_CAR (rabbit
);
3858 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3859 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
3860 tail
= SCM_CDR (tail
);
3862 rabbit
= SCM_CDR (rabbit
);
3863 if (scm_is_pair (rabbit
))
3865 new_hare
.obj
= SCM_CAR (rabbit
);
3866 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3867 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
3868 tail
= SCM_CDR (tail
);
3869 rabbit
= SCM_CDR (rabbit
);
3871 turtle
= SCM_CDR (turtle
);
3872 ASSERT_SYNTAX (!scm_is_eq (rabbit
, turtle
),
3873 s_bad_expression
, rabbit
);
3877 /* We have to recurse into copy_tree again for the last cdr, in
3878 * order to handle the situation that it holds a vector. */
3879 new_hare
.obj
= rabbit
;
3880 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3881 SCM_SETCDR (tail
, copy
);
3888 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
3890 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
3891 "the new data structure. @code{copy-tree} recurses down the\n"
3892 "contents of both pairs and vectors (since both cons cells and vector\n"
3893 "cells may point to arbitrary objects), and stops recursing when it hits\n"
3894 "any other object.")
3895 #define FUNC_NAME s_scm_copy_tree
3897 /* Prepare the trace along the stack. */
3898 struct t_trace trace
;
3901 /* In function copy_tree, if the tortoise makes its step, it will do this
3902 * before the hare has the chance to move. Thus, we have to make sure that
3903 * the very first step of the tortoise will not happen after the hare has
3904 * really made two steps. This is achieved by passing '2' as the initial
3905 * delay for the tortoise. NOTE: Since cycles are unlikely, giving the hare
3906 * a bigger advantage may improve performance slightly. */
3907 return copy_tree (&trace
, &trace
, 2);
3912 /* We have three levels of EVAL here:
3914 - scm_i_eval (exp, env)
3916 evaluates EXP in environment ENV. ENV is a lexical environment
3917 structure as used by the actual tree code evaluator. When ENV is
3918 a top-level environment, then changes to the current module are
3919 tracked by updating ENV so that it continues to be in sync with
3922 - scm_primitive_eval (exp)
3924 evaluates EXP in the top-level environment as determined by the
3925 current module. This is done by constructing a suitable
3926 environment and calling scm_i_eval. Thus, changes to the
3927 top-level module are tracked normally.
3929 - scm_eval (exp, mod_or_state)
3931 evaluates EXP while MOD_OR_STATE is the current module or current
3932 dynamic state (as appropriate). This is done by setting the
3933 current module (or dynamic state) to MOD_OR_STATE, invoking
3934 scm_primitive_eval on EXP, and then restoring the current module
3935 (or dynamic state) to the value it had previously. That is,
3936 while EXP is evaluated, changes to the current module (or dynamic
3937 state) are tracked, but these changes do not persist when
3940 For each level of evals, there are two variants, distinguished by a
3941 _x suffix: the ordinary variant does not modify EXP while the _x
3942 variant can destructively modify EXP into something completely
3943 unintelligible. A Scheme data structure passed as EXP to one of the
3944 _x variants should not ever be used again for anything. So when in
3945 doubt, use the ordinary variant.
3950 scm_i_eval_x (SCM exp
, SCM env
)
3952 if (scm_is_symbol (exp
))
3953 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
3955 return SCM_I_XEVAL (exp
, env
, scm_debug_mode_p
);
3959 scm_i_eval (SCM exp
, SCM env
)
3961 exp
= scm_copy_tree (exp
);
3962 if (scm_is_symbol (exp
))
3963 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
3965 return SCM_I_XEVAL (exp
, env
, scm_debug_mode_p
);
3969 scm_primitive_eval_x (SCM exp
)
3972 SCM transformer
= scm_current_module_transformer ();
3973 if (SCM_NIMP (transformer
))
3974 exp
= scm_call_1 (transformer
, exp
);
3975 env
= scm_top_level_env (scm_current_module_lookup_closure ());
3976 return scm_i_eval_x (exp
, env
);
3979 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
3981 "Evaluate @var{exp} in the top-level environment specified by\n"
3982 "the current module.")
3983 #define FUNC_NAME s_scm_primitive_eval
3986 SCM transformer
= scm_current_module_transformer ();
3987 if (scm_is_true (transformer
))
3988 exp
= scm_call_1 (transformer
, exp
);
3989 env
= scm_top_level_env (scm_current_module_lookup_closure ());
3990 return scm_i_eval (exp
, env
);
3995 /* Eval does not take the second arg optionally. This is intentional
3996 * in order to be R5RS compatible, and to prepare for the new module
3997 * system, where we would like to make the choice of evaluation
3998 * environment explicit. */
4001 scm_eval_x (SCM exp
, SCM module_or_state
)
4005 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
4006 if (scm_is_dynamic_state (module_or_state
))
4007 scm_dynwind_current_dynamic_state (module_or_state
);
4009 scm_dynwind_current_module (module_or_state
);
4011 res
= scm_primitive_eval_x (exp
);
4017 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
4018 (SCM exp
, SCM module_or_state
),
4019 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
4020 "in the top-level environment specified by\n"
4021 "@var{module_or_state}.\n"
4022 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
4023 "@var{module_or_state} is made the current module when\n"
4024 "it is a module, or the current dynamic state when it is\n"
4026 "Example: (eval '(+ 1 2) (interaction-environment))")
4027 #define FUNC_NAME s_scm_eval
4031 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
4032 if (scm_is_dynamic_state (module_or_state
))
4033 scm_dynwind_current_dynamic_state (module_or_state
);
4036 SCM_VALIDATE_MODULE (2, module_or_state
);
4037 scm_dynwind_current_module (module_or_state
);
4040 res
= scm_primitive_eval (exp
);
4048 /* At this point, deval and scm_dapply are generated.
4060 scm_i_pthread_mutex_init (&source_mutex
,
4061 scm_i_pthread_mutexattr_recursive
);
4063 scm_init_opts (scm_evaluator_traps
,
4064 scm_evaluator_trap_table
);
4065 scm_init_opts (scm_eval_options_interface
,
4068 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
4069 scm_set_smob_mark (scm_tc16_promise
, promise_mark
);
4070 scm_set_smob_free (scm_tc16_promise
, promise_free
);
4071 scm_set_smob_print (scm_tc16_promise
, promise_print
);
4073 undefineds
= scm_list_1 (SCM_UNDEFINED
);
4074 SCM_SETCDR (undefineds
, undefineds
);
4075 scm_permanent_object (undefineds
);
4077 scm_listofnull
= scm_list_1 (SCM_EOL
);
4079 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
4080 scm_permanent_object (f_apply
);
4082 #include "libguile/eval.x"
4084 scm_add_feature ("delay");