1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009
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/programs.h"
56 #include "libguile/root.h"
57 #include "libguile/smob.h"
58 #include "libguile/srcprop.h"
59 #include "libguile/stackchk.h"
60 #include "libguile/strings.h"
61 #include "libguile/threads.h"
62 #include "libguile/throw.h"
63 #include "libguile/validate.h"
64 #include "libguile/values.h"
65 #include "libguile/vectors.h"
66 #include "libguile/vm.h"
68 #include "libguile/eval.h"
69 #include "libguile/private-options.h"
74 static SCM
unmemoize_exprs (SCM expr
, SCM env
);
75 static SCM
canonicalize_define (SCM expr
);
76 static SCM
*scm_lookupcar1 (SCM vloc
, SCM genv
, int check
);
77 static SCM
unmemoize_builtin_macro (SCM expr
, SCM env
);
78 static void ceval_letrec_inits (SCM env
, SCM init_forms
, SCM
**init_values_eol
);
79 static SCM
ceval (SCM x
, SCM env
);
80 static SCM
deval (SCM x
, SCM env
);
86 * This section defines the message strings for the syntax errors that can be
87 * detected during memoization and the functions and macros that shall be
88 * called by the memoizer code to signal syntax errors. */
91 /* Syntax errors that can be detected during memoization: */
93 /* Circular or improper lists do not form valid scheme expressions. If a
94 * circular list or an improper list is detected in a place where a scheme
95 * expression is expected, a 'Bad expression' error is signalled. */
96 static const char s_bad_expression
[] = "Bad expression";
98 /* If a form is detected that holds a different number of expressions than are
99 * required in that context, a 'Missing or extra expression' error is
101 static const char s_expression
[] = "Missing or extra expression in";
103 /* If a form is detected that holds less expressions than are required in that
104 * context, a 'Missing expression' error is signalled. */
105 static const char s_missing_expression
[] = "Missing expression in";
107 /* If a form is detected that holds more expressions than are allowed in that
108 * context, an 'Extra expression' error is signalled. */
109 static const char s_extra_expression
[] = "Extra expression in";
111 /* The empty combination '()' is not allowed as an expression in scheme. If
112 * it is detected in a place where an expression is expected, an 'Illegal
113 * empty combination' error is signalled. Note: If you encounter this error
114 * message, it is very likely that you intended to denote the empty list. To
115 * do so, you need to quote the empty list like (quote ()) or '(). */
116 static const char s_empty_combination
[] = "Illegal empty combination";
118 /* A body may hold an arbitrary number of internal defines, followed by a
119 * non-empty sequence of expressions. If a body with an empty sequence of
120 * expressions is detected, a 'Missing body expression' error is signalled.
122 static const char s_missing_body_expression
[] = "Missing body expression in";
124 /* A body may hold an arbitrary number of internal defines, followed by a
125 * non-empty sequence of expressions. Each the definitions and the
126 * expressions may be grouped arbitraryly with begin, but it is not allowed to
127 * mix definitions and expressions. If a define form in a body mixes
128 * definitions and expressions, a 'Mixed definitions and expressions' error is
130 static const char s_mixed_body_forms
[] = "Mixed definitions and expressions in";
131 /* Definitions are only allowed on the top level and at the start of a body.
132 * If a definition is detected anywhere else, a 'Bad define placement' error
134 static const char s_bad_define
[] = "Bad define placement";
136 /* Case or cond expressions must have at least one clause. If a case or cond
137 * expression without any clauses is detected, a 'Missing clauses' error is
139 static const char s_missing_clauses
[] = "Missing clauses";
141 /* If there is an 'else' clause in a case or a cond statement, it must be the
142 * last clause. If after the 'else' case clause further clauses are detected,
143 * a 'Misplaced else clause' error is signalled. */
144 static const char s_misplaced_else_clause
[] = "Misplaced else clause";
146 /* If a case clause is detected that is not in the format
147 * (<label(s)> <expression1> <expression2> ...)
148 * a 'Bad case clause' error is signalled. */
149 static const char s_bad_case_clause
[] = "Bad case clause";
151 /* If a case clause is detected where the <label(s)> element is neither a
152 * proper list nor (in case of the last clause) the syntactic keyword 'else',
153 * a 'Bad case labels' error is signalled. Note: If you encounter this error
154 * for an else-clause which seems to be syntactically correct, check if 'else'
155 * is really a syntactic keyword in that context. If 'else' is bound in the
156 * local or global environment, it is not considered a syntactic keyword, but
157 * will be treated as any other variable. */
158 static const char s_bad_case_labels
[] = "Bad case labels";
160 /* In a case statement all labels have to be distinct. If in a case statement
161 * a label occurs more than once, a 'Duplicate case label' error is
163 static const char s_duplicate_case_label
[] = "Duplicate case label";
165 /* If a cond clause is detected that is not in one of the formats
166 * (<test> <expression1> ...) or (else <expression1> <expression2> ...)
167 * a 'Bad cond clause' error is signalled. */
168 static const char s_bad_cond_clause
[] = "Bad cond clause";
170 /* If a cond clause is detected that uses the alternate '=>' form, but does
171 * not hold a recipient element for the test result, a 'Missing recipient'
172 * error is signalled. */
173 static const char s_missing_recipient
[] = "Missing recipient in";
175 /* If in a position where a variable name is required some other object is
176 * detected, a 'Bad variable' error is signalled. */
177 static const char s_bad_variable
[] = "Bad variable";
179 /* Bindings for forms like 'let' and 'do' have to be given in a proper,
180 * possibly empty list. If any other object is detected in a place where a
181 * list of bindings was required, a 'Bad bindings' error is signalled. */
182 static const char s_bad_bindings
[] = "Bad bindings";
184 /* Depending on the syntactic context, a binding has to be in the format
185 * (<variable> <expression>) or (<variable> <expression1> <expression2>).
186 * If anything else is detected in a place where a binding was expected, a
187 * 'Bad binding' error is signalled. */
188 static const char s_bad_binding
[] = "Bad binding";
190 /* Some syntactic forms don't allow variable names to appear more than once in
191 * a list of bindings. If such a situation is nevertheless detected, a
192 * 'Duplicate binding' error is signalled. */
193 static const char s_duplicate_binding
[] = "Duplicate binding";
195 /* If the exit form of a 'do' expression is not in the format
196 * (<test> <expression> ...)
197 * a 'Bad exit clause' error is signalled. */
198 static const char s_bad_exit_clause
[] = "Bad exit clause";
200 /* The formal function arguments of a lambda expression have to be either a
201 * single symbol or a non-cyclic list. For anything else a 'Bad formals'
202 * error is signalled. */
203 static const char s_bad_formals
[] = "Bad formals";
205 /* If in a lambda expression something else than a symbol is detected at a
206 * place where a formal function argument is required, a 'Bad formal' error is
208 static const char s_bad_formal
[] = "Bad formal";
210 /* If in the arguments list of a lambda expression an argument name occurs
211 * more than once, a 'Duplicate formal' error is signalled. */
212 static const char s_duplicate_formal
[] = "Duplicate formal";
214 /* If the evaluation of an unquote-splicing expression gives something else
215 * than a proper list, a 'Non-list result for unquote-splicing' error is
217 static const char s_splicing
[] = "Non-list result for unquote-splicing";
219 /* If something else than an exact integer is detected as the argument for
220 * @slot-ref and @slot-set!, a 'Bad slot number' error is signalled. */
221 static const char s_bad_slot_number
[] = "Bad slot number";
224 /* Signal a syntax error. We distinguish between the form that caused the
225 * error and the enclosing expression. The error message will print out as
226 * shown in the following pattern. The file name and line number are only
227 * given when they can be determined from the erroneous form or from the
228 * enclosing expression.
230 * <filename>: In procedure memoization:
231 * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
233 SCM_SYMBOL (syntax_error_key
, "syntax-error");
235 /* The prototype is needed to indicate that the function does not return. */
237 syntax_error (const char* const, const SCM
, const SCM
) SCM_NORETURN
;
240 syntax_error (const char* const msg
, const SCM form
, const SCM expr
)
242 SCM msg_string
= scm_from_locale_string (msg
);
243 SCM filename
= SCM_BOOL_F
;
244 SCM linenr
= SCM_BOOL_F
;
248 if (scm_is_pair (form
))
250 filename
= scm_source_property (form
, scm_sym_filename
);
251 linenr
= scm_source_property (form
, scm_sym_line
);
254 if (scm_is_false (filename
) && scm_is_false (linenr
) && scm_is_pair (expr
))
256 filename
= scm_source_property (expr
, scm_sym_filename
);
257 linenr
= scm_source_property (expr
, scm_sym_line
);
260 if (!SCM_UNBNDP (expr
))
262 if (scm_is_true (filename
))
264 format
= "In file ~S, line ~S: ~A ~S in expression ~S.";
265 args
= scm_list_5 (filename
, linenr
, msg_string
, form
, expr
);
267 else if (scm_is_true (linenr
))
269 format
= "In line ~S: ~A ~S in expression ~S.";
270 args
= scm_list_4 (linenr
, msg_string
, form
, expr
);
274 format
= "~A ~S in expression ~S.";
275 args
= scm_list_3 (msg_string
, form
, expr
);
280 if (scm_is_true (filename
))
282 format
= "In file ~S, line ~S: ~A ~S.";
283 args
= scm_list_4 (filename
, linenr
, msg_string
, form
);
285 else if (scm_is_true (linenr
))
287 format
= "In line ~S: ~A ~S.";
288 args
= scm_list_3 (linenr
, msg_string
, form
);
293 args
= scm_list_2 (msg_string
, form
);
297 scm_error (syntax_error_key
, "memoization", format
, args
, SCM_BOOL_F
);
301 /* Shortcut macros to simplify syntax error handling. */
302 #define ASSERT_SYNTAX(cond, message, form) \
303 { if (SCM_UNLIKELY (!(cond))) \
304 syntax_error (message, form, SCM_UNDEFINED); }
305 #define ASSERT_SYNTAX_2(cond, message, form, expr) \
306 { if (SCM_UNLIKELY (!(cond))) \
307 syntax_error (message, form, expr); }
309 static void error_unbound_variable (SCM symbol
) SCM_NORETURN
;
310 static void error_defined_variable (SCM symbol
) SCM_NORETURN
;
316 * Ilocs are memoized references to variables in local environment frames.
317 * They are represented as three values: The relative offset of the
318 * environment frame, the number of the binding within that frame, and a
319 * boolean value indicating whether the binding is the last binding in the
322 * Frame numbers have 11 bits, relative offsets have 12 bits.
325 #define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc)
326 #define SCM_IFRINC (0x00000100L)
327 #define SCM_ICDR (0x00080000L)
328 #define SCM_IDINC (0x00100000L)
329 #define SCM_IFRAME(n) ((long)((SCM_ICDR-SCM_IFRINC)>>8) \
330 & (SCM_UNPACK (n) >> 8))
331 #define SCM_IDIST(n) (SCM_UNPACK (n) >> 20)
332 #define SCM_ICDRP(n) (SCM_ICDR & SCM_UNPACK (n))
333 #define SCM_IDSTMSK (-SCM_IDINC)
334 #define SCM_IFRAMEMAX ((1<<11)-1)
335 #define SCM_IDISTMAX ((1<<12)-1)
336 #define SCM_MAKE_ILOC(frame_nr, binding_nr, last_p) \
339 + ((binding_nr) << 20) \
340 + ((last_p) ? SCM_ICDR : 0) \
344 scm_i_print_iloc (SCM iloc
, SCM port
)
346 scm_puts ("#@", port
);
347 scm_intprint ((long) SCM_IFRAME (iloc
), 10, port
);
348 scm_putc (SCM_ICDRP (iloc
) ? '-' : '+', port
);
349 scm_intprint ((long) SCM_IDIST (iloc
), 10, port
);
352 #if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
354 SCM
scm_dbg_make_iloc (SCM frame
, SCM binding
, SCM cdrp
);
356 SCM_DEFINE (scm_dbg_make_iloc
, "dbg-make-iloc", 3, 0, 0,
357 (SCM frame
, SCM binding
, SCM cdrp
),
358 "Return a new iloc with frame offset @var{frame}, binding\n"
359 "offset @var{binding} and the cdr flag @var{cdrp}.")
360 #define FUNC_NAME s_scm_dbg_make_iloc
362 return SCM_MAKE_ILOC ((scm_t_bits
) scm_to_unsigned_integer (frame
, 0, SCM_IFRAMEMAX
),
363 (scm_t_bits
) scm_to_unsigned_integer (binding
, 0, SCM_IDISTMAX
),
368 SCM
scm_dbg_iloc_p (SCM obj
);
370 SCM_DEFINE (scm_dbg_iloc_p
, "dbg-iloc?", 1, 0, 0,
372 "Return @code{#t} if @var{obj} is an iloc.")
373 #define FUNC_NAME s_scm_dbg_iloc_p
375 return scm_from_bool (SCM_ILOCP (obj
));
383 /* {Evaluator byte codes (isyms)}
386 #define ISYMNUM(n) (SCM_ITAG8_DATA (n))
388 /* This table must agree with the list of SCM_IM_ constants in tags.h */
389 static const char *const isymnames
[] =
406 "#@call-with-current-continuation",
412 "#@call-with-values",
420 scm_i_print_isym (SCM isym
, SCM port
)
422 const size_t isymnum
= ISYMNUM (isym
);
423 if (isymnum
< (sizeof isymnames
/ sizeof (char *)))
424 scm_puts (isymnames
[isymnum
], port
);
426 scm_ipruk ("isym", isym
, port
);
431 /* The function lookup_symbol is used during memoization: Lookup the symbol in
432 * the environment. If there is no binding for the symbol, SCM_UNDEFINED is
433 * returned. If the symbol is a global variable, the variable object to which
434 * the symbol is bound is returned. Finally, if the symbol is a local
435 * variable the corresponding iloc object is returned. */
437 /* A helper function for lookup_symbol: Try to find the symbol in the top
438 * level environment frame. The function returns SCM_UNDEFINED if the symbol
439 * is unbound and it returns a variable object if the symbol is a global
442 lookup_global_symbol (const SCM symbol
, const SCM top_level
)
444 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
445 if (scm_is_false (variable
))
446 return SCM_UNDEFINED
;
452 lookup_symbol (const SCM symbol
, const SCM env
)
455 unsigned int frame_nr
;
457 for (frame_idx
= env
, frame_nr
= 0;
458 !scm_is_null (frame_idx
);
459 frame_idx
= SCM_CDR (frame_idx
), ++frame_nr
)
461 const SCM frame
= SCM_CAR (frame_idx
);
462 if (scm_is_pair (frame
))
464 /* frame holds a local environment frame */
466 unsigned int symbol_nr
;
468 for (symbol_idx
= SCM_CAR (frame
), symbol_nr
= 0;
469 scm_is_pair (symbol_idx
);
470 symbol_idx
= SCM_CDR (symbol_idx
), ++symbol_nr
)
472 if (scm_is_eq (SCM_CAR (symbol_idx
), symbol
))
473 /* found the symbol, therefore return the iloc */
474 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 0);
476 if (scm_is_eq (symbol_idx
, symbol
))
477 /* found the symbol as the last element of the current frame */
478 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 1);
482 /* no more local environment frames */
483 return lookup_global_symbol (symbol
, frame
);
487 return lookup_global_symbol (symbol
, SCM_BOOL_F
);
491 /* Return true if the symbol is - from the point of view of a macro
492 * transformer - a literal in the sense specified in chapter "pattern
493 * language" of R5RS. In the code below, however, we don't match the
494 * definition of R5RS exactly: It returns true if the identifier has no
495 * binding or if it is a syntactic keyword. */
497 literal_p (const SCM symbol
, const SCM env
)
499 const SCM variable
= lookup_symbol (symbol
, env
);
500 if (SCM_UNBNDP (variable
))
502 if (SCM_VARIABLEP (variable
) && SCM_MACROP (SCM_VARIABLE_REF (variable
)))
509 /* Return true if the expression is self-quoting in the memoized code. Thus,
510 * some other objects (like e. g. vectors) are reported as self-quoting, which
511 * according to R5RS would need to be quoted. */
513 is_self_quoting_p (const SCM expr
)
515 if (scm_is_pair (expr
))
517 else if (scm_is_symbol (expr
))
519 else if (scm_is_null (expr
))
525 SCM_SYMBOL (sym_three_question_marks
, "???");
528 unmemoize_expression (const SCM expr
, const SCM env
)
530 if (SCM_ILOCP (expr
))
533 unsigned long int frame_nr
;
535 unsigned long int symbol_nr
;
537 for (frame_idx
= env
, frame_nr
= SCM_IFRAME (expr
);
539 frame_idx
= SCM_CDR (frame_idx
), --frame_nr
)
541 for (symbol_idx
= SCM_CAAR (frame_idx
), symbol_nr
= SCM_IDIST (expr
);
543 symbol_idx
= SCM_CDR (symbol_idx
), --symbol_nr
)
545 return SCM_ICDRP (expr
) ? symbol_idx
: SCM_CAR (symbol_idx
);
547 else if (SCM_VARIABLEP (expr
))
549 const SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), expr
);
550 return scm_is_true (sym
) ? sym
: sym_three_question_marks
;
552 else if (scm_is_simple_vector (expr
))
554 return scm_list_2 (scm_sym_quote
, expr
);
556 else if (!scm_is_pair (expr
))
560 else if (SCM_ISYMP (SCM_CAR (expr
)))
562 return unmemoize_builtin_macro (expr
, env
);
566 return unmemoize_exprs (expr
, env
);
572 unmemoize_exprs (const SCM exprs
, const SCM env
)
574 SCM r_result
= SCM_EOL
;
575 SCM expr_idx
= exprs
;
578 /* Note that due to the current lazy memoizer we may find partially memoized
579 * code during execution. In such code we have to expect improper lists of
580 * expressions: On the one hand, for such code syntax checks have not yet
581 * fully been performed, on the other hand, there may be even legal code
582 * like '(a . b) appear as an improper list of expressions as long as the
583 * quote expression is still in its unmemoized form. For this reason, the
584 * following code handles improper lists of expressions until memoization
585 * and execution have been completely separated. */
586 for (; scm_is_pair (expr_idx
); expr_idx
= SCM_CDR (expr_idx
))
588 const SCM expr
= SCM_CAR (expr_idx
);
590 /* In partially memoized code, lists of expressions that stem from a
591 * body form may start with an ISYM if the body itself has not yet been
592 * memoized. This isym is just an internal marker to indicate that the
593 * body still needs to be memoized. An isym may occur at the very
594 * beginning of the body or after one or more comment strings. It is
595 * dropped during unmemoization. */
596 if (!SCM_ISYMP (expr
))
598 um_expr
= unmemoize_expression (expr
, env
);
599 r_result
= scm_cons (um_expr
, r_result
);
602 um_expr
= unmemoize_expression (expr_idx
, env
);
603 if (!scm_is_null (r_result
))
605 const SCM result
= scm_reverse_x (r_result
, SCM_UNDEFINED
);
606 SCM_SETCDR (r_result
, um_expr
);
616 /* Rewrite the body (which is given as the list of expressions forming the
617 * body) into its internal form. The internal form of a body (<expr> ...) is
618 * just the body itself, but prefixed with an ISYM that denotes to what kind
619 * of outer construct this body belongs: (<ISYM> <expr> ...). A lambda body
620 * starts with SCM_IM_LAMBDA, for example, a body of a let starts with
623 * It is assumed that the calling expression has already made sure that the
624 * body is a proper list. */
626 m_body (SCM op
, SCM exprs
)
628 /* Don't add another ISYM if one is present already. */
629 if (SCM_ISYMP (SCM_CAR (exprs
)))
632 return scm_cons (op
, exprs
);
636 /* The function m_expand_body memoizes a proper list of expressions forming a
637 * body. This function takes care of dealing with internal defines and
638 * transforming them into an equivalent letrec expression. The list of
639 * expressions is rewritten in place. */
641 /* This is a helper function for m_expand_body. If the argument expression is
642 * a symbol that denotes a syntactic keyword, the corresponding macro object
643 * is returned, in all other cases the function returns SCM_UNDEFINED. */
645 try_macro_lookup (const SCM expr
, const SCM env
)
647 if (scm_is_symbol (expr
))
649 const SCM variable
= lookup_symbol (expr
, env
);
650 if (SCM_VARIABLEP (variable
))
652 const SCM value
= SCM_VARIABLE_REF (variable
);
653 if (SCM_MACROP (value
))
658 return SCM_UNDEFINED
;
661 /* This is a helper function for m_expand_body. It expands user macros,
662 * because for the correct translation of a body we need to know whether they
663 * expand to a definition. */
665 expand_user_macros (SCM expr
, const SCM env
)
667 while (scm_is_pair (expr
))
669 const SCM car_expr
= SCM_CAR (expr
);
670 const SCM new_car
= expand_user_macros (car_expr
, env
);
671 const SCM value
= try_macro_lookup (new_car
, env
);
673 if (SCM_MACROP (value
) && SCM_MACRO_TYPE (value
) == 2)
675 /* User macros transform code into code. */
676 expr
= scm_call_2 (SCM_MACRO_CODE (value
), expr
, env
);
677 /* We need to reiterate on the transformed code. */
681 /* No user macro: return. */
682 SCM_SETCAR (expr
, new_car
);
690 /* This is a helper function for m_expand_body. It determines if a given form
691 * represents an application of a given built-in macro. The built-in macro to
692 * check for is identified by its syntactic keyword. The form is an
693 * application of the given macro if looking up the car of the form in the
694 * given environment actually returns the built-in macro. */
696 is_system_macro_p (const SCM syntactic_keyword
, const SCM form
, const SCM env
)
698 if (scm_is_pair (form
))
700 const SCM car_form
= SCM_CAR (form
);
701 const SCM value
= try_macro_lookup (car_form
, env
);
702 if (SCM_BUILTIN_MACRO_P (value
))
704 const SCM macro_name
= scm_macro_name (value
);
705 return scm_is_eq (macro_name
, syntactic_keyword
);
713 m_expand_body (const SCM forms
, const SCM env
)
715 /* The first body form can be skipped since it is known to be the ISYM that
716 * was prepended to the body by m_body. */
717 SCM cdr_forms
= SCM_CDR (forms
);
718 SCM form_idx
= cdr_forms
;
719 SCM definitions
= SCM_EOL
;
720 SCM sequence
= SCM_EOL
;
722 /* According to R5RS, the list of body forms consists of two parts: a number
723 * (maybe zero) of definitions, followed by a non-empty sequence of
724 * expressions. Each the definitions and the expressions may be grouped
725 * arbitrarily with begin, but it is not allowed to mix definitions and
726 * expressions. The task of the following loop therefore is to split the
727 * list of body forms into the list of definitions and the sequence of
729 while (!scm_is_null (form_idx
))
731 const SCM form
= SCM_CAR (form_idx
);
732 const SCM new_form
= expand_user_macros (form
, env
);
733 if (is_system_macro_p (scm_sym_define
, new_form
, env
))
735 definitions
= scm_cons (new_form
, definitions
);
736 form_idx
= SCM_CDR (form_idx
);
738 else if (is_system_macro_p (scm_sym_begin
, new_form
, env
))
740 /* We have encountered a group of forms. This has to be either a
741 * (possibly empty) group of (possibly further grouped) definitions,
742 * or a non-empty group of (possibly further grouped)
744 const SCM grouped_forms
= SCM_CDR (new_form
);
745 unsigned int found_definition
= 0;
746 unsigned int found_expression
= 0;
747 SCM grouped_form_idx
= grouped_forms
;
748 while (!found_expression
&& !scm_is_null (grouped_form_idx
))
750 const SCM inner_form
= SCM_CAR (grouped_form_idx
);
751 const SCM new_inner_form
= expand_user_macros (inner_form
, env
);
752 if (is_system_macro_p (scm_sym_define
, new_inner_form
, env
))
754 found_definition
= 1;
755 definitions
= scm_cons (new_inner_form
, definitions
);
756 grouped_form_idx
= SCM_CDR (grouped_form_idx
);
758 else if (is_system_macro_p (scm_sym_begin
, new_inner_form
, env
))
760 const SCM inner_group
= SCM_CDR (new_inner_form
);
762 = scm_append (scm_list_2 (inner_group
,
763 SCM_CDR (grouped_form_idx
)));
767 /* The group marks the start of the expressions of the body.
768 * We have to make sure that within the same group we have
769 * not encountered a definition before. */
770 ASSERT_SYNTAX (!found_definition
, s_mixed_body_forms
, form
);
771 found_expression
= 1;
772 grouped_form_idx
= SCM_EOL
;
776 /* We have finished processing the group. If we have not yet
777 * encountered an expression we continue processing the forms of the
778 * body to collect further definition forms. Otherwise, the group
779 * marks the start of the sequence of expressions of the body. */
780 if (!found_expression
)
782 form_idx
= SCM_CDR (form_idx
);
792 /* We have detected a form which is no definition. This marks the
793 * start of the sequence of expressions of the body. */
799 /* FIXME: forms does not hold information about the file location. */
800 ASSERT_SYNTAX (scm_is_pair (sequence
), s_missing_body_expression
, cdr_forms
);
802 if (!scm_is_null (definitions
))
806 SCM letrec_expression
;
807 SCM new_letrec_expression
;
809 SCM bindings
= SCM_EOL
;
810 for (definition_idx
= definitions
;
811 !scm_is_null (definition_idx
);
812 definition_idx
= SCM_CDR (definition_idx
))
814 const SCM definition
= SCM_CAR (definition_idx
);
815 const SCM canonical_definition
= canonicalize_define (definition
);
816 const SCM binding
= SCM_CDR (canonical_definition
);
817 bindings
= scm_cons (binding
, bindings
);
820 letrec_tail
= scm_cons (bindings
, sequence
);
821 /* FIXME: forms does not hold information about the file location. */
822 letrec_expression
= scm_cons_source (forms
, scm_sym_letrec
, letrec_tail
);
823 new_letrec_expression
= scm_m_letrec (letrec_expression
, env
);
824 SCM_SETCAR (forms
, new_letrec_expression
);
825 SCM_SETCDR (forms
, SCM_EOL
);
829 SCM_SETCAR (forms
, SCM_CAR (sequence
));
830 SCM_SETCDR (forms
, SCM_CDR (sequence
));
835 macroexp (SCM x
, SCM env
)
837 SCM res
, proc
, orig_sym
;
839 /* Don't bother to produce error messages here. We get them when we
840 eventually execute the code for real. */
843 orig_sym
= SCM_CAR (x
);
844 if (!scm_is_symbol (orig_sym
))
848 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
849 if (proc_ptr
== NULL
)
851 /* We have lost the race. */
857 /* Only handle memoizing macros. `Acros' and `macros' are really
858 special forms and should not be evaluated here. */
860 if (!SCM_MACROP (proc
)
861 || (SCM_MACRO_TYPE (proc
) != 2 && !SCM_BUILTIN_MACRO_P (proc
)))
864 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
865 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
867 if (scm_ilength (res
) <= 0)
868 /* Result of expansion is not a list. */
869 return (scm_list_2 (SCM_IM_BEGIN
, res
));
872 /* njrev: Several queries here: (1) I don't see how it can be
873 correct that the SCM_SETCAR 2 lines below this comment needs
874 protection, but the SCM_SETCAR 6 lines above does not, so
875 something here is probably wrong. (2) macroexp() is now only
876 used in one place - scm_m_generalized_set_x - whereas all other
877 macro expansion happens through expand_user_macros. Therefore
878 (2.1) perhaps macroexp() could be eliminated completely now?
879 (2.2) Does expand_user_macros need any critical section
882 SCM_CRITICAL_SECTION_START
;
883 SCM_SETCAR (x
, SCM_CAR (res
));
884 SCM_SETCDR (x
, SCM_CDR (res
));
885 SCM_CRITICAL_SECTION_END
;
891 /* Start of the memoizers for the standard R5RS builtin macros. */
894 SCM_SYNTAX (s_and
, "and", scm_i_makbimacro
, scm_m_and
);
895 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
898 scm_m_and (SCM expr
, SCM env SCM_UNUSED
)
900 const SCM cdr_expr
= SCM_CDR (expr
);
901 const long length
= scm_ilength (cdr_expr
);
903 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
907 /* Special case: (and) is replaced by #t. */
912 SCM_SETCAR (expr
, SCM_IM_AND
);
918 unmemoize_and (const SCM expr
, const SCM env
)
920 return scm_cons (scm_sym_and
, unmemoize_exprs (SCM_CDR (expr
), env
));
924 SCM_SYNTAX (s_begin
, "begin", scm_i_makbimacro
, scm_m_begin
);
925 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
928 scm_m_begin (SCM expr
, SCM env SCM_UNUSED
)
930 const SCM cdr_expr
= SCM_CDR (expr
);
931 /* Dirk:FIXME:: An empty begin clause is not generally allowed by R5RS.
932 * That means, there should be a distinction between uses of begin where an
933 * empty clause is OK and where it is not. */
934 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
936 SCM_SETCAR (expr
, SCM_IM_BEGIN
);
941 unmemoize_begin (const SCM expr
, const SCM env
)
943 return scm_cons (scm_sym_begin
, unmemoize_exprs (SCM_CDR (expr
), env
));
947 SCM_SYNTAX (s_case
, "case", scm_i_makbimacro
, scm_m_case
);
948 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
949 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
952 scm_m_case (SCM expr
, SCM env
)
955 SCM all_labels
= SCM_EOL
;
957 /* Check, whether 'else is a literal, i. e. not bound to a value. */
958 const int else_literal_p
= literal_p (scm_sym_else
, env
);
960 const SCM cdr_expr
= SCM_CDR (expr
);
961 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
962 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_clauses
, expr
);
964 clauses
= SCM_CDR (cdr_expr
);
965 while (!scm_is_null (clauses
))
969 const SCM clause
= SCM_CAR (clauses
);
970 ASSERT_SYNTAX_2 (scm_ilength (clause
) >= 2,
971 s_bad_case_clause
, clause
, expr
);
973 labels
= SCM_CAR (clause
);
974 if (scm_is_pair (labels
))
976 ASSERT_SYNTAX_2 (scm_ilength (labels
) >= 0,
977 s_bad_case_labels
, labels
, expr
);
978 all_labels
= scm_append (scm_list_2 (labels
, all_labels
));
980 else if (scm_is_null (labels
))
982 /* The list of labels is empty. According to R5RS this is allowed.
983 * It means that the sequence of expressions will never be executed.
984 * Therefore, as an optimization, we could remove the whole
989 ASSERT_SYNTAX_2 (scm_is_eq (labels
, scm_sym_else
) && else_literal_p
,
990 s_bad_case_labels
, labels
, expr
);
991 ASSERT_SYNTAX_2 (scm_is_null (SCM_CDR (clauses
)),
992 s_misplaced_else_clause
, clause
, expr
);
995 /* build the new clause */
996 if (scm_is_eq (labels
, scm_sym_else
))
997 SCM_SETCAR (clause
, SCM_IM_ELSE
);
999 clauses
= SCM_CDR (clauses
);
1002 /* Check whether all case labels are distinct. */
1003 for (; !scm_is_null (all_labels
); all_labels
= SCM_CDR (all_labels
))
1005 const SCM label
= SCM_CAR (all_labels
);
1006 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (label
, SCM_CDR (all_labels
))),
1007 s_duplicate_case_label
, label
, expr
);
1010 SCM_SETCAR (expr
, SCM_IM_CASE
);
1015 unmemoize_case (const SCM expr
, const SCM env
)
1017 const SCM um_key_expr
= unmemoize_expression (SCM_CADR (expr
), env
);
1018 SCM um_clauses
= SCM_EOL
;
1021 for (clause_idx
= SCM_CDDR (expr
);
1022 !scm_is_null (clause_idx
);
1023 clause_idx
= SCM_CDR (clause_idx
))
1025 const SCM clause
= SCM_CAR (clause_idx
);
1026 const SCM labels
= SCM_CAR (clause
);
1027 const SCM exprs
= SCM_CDR (clause
);
1029 const SCM um_exprs
= unmemoize_exprs (exprs
, env
);
1030 const SCM um_labels
= (scm_is_eq (labels
, SCM_IM_ELSE
))
1032 : scm_i_finite_list_copy (labels
);
1033 const SCM um_clause
= scm_cons (um_labels
, um_exprs
);
1035 um_clauses
= scm_cons (um_clause
, um_clauses
);
1037 um_clauses
= scm_reverse_x (um_clauses
, SCM_UNDEFINED
);
1039 return scm_cons2 (scm_sym_case
, um_key_expr
, um_clauses
);
1043 SCM_SYNTAX (s_cond
, "cond", scm_i_makbimacro
, scm_m_cond
);
1044 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
1045 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
1048 scm_m_cond (SCM expr
, SCM env
)
1050 /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
1051 const int else_literal_p
= literal_p (scm_sym_else
, env
);
1052 const int arrow_literal_p
= literal_p (scm_sym_arrow
, env
);
1054 const SCM clauses
= SCM_CDR (expr
);
1057 ASSERT_SYNTAX (scm_ilength (clauses
) >= 0, s_bad_expression
, expr
);
1058 ASSERT_SYNTAX (scm_ilength (clauses
) >= 1, s_missing_clauses
, expr
);
1060 for (clause_idx
= clauses
;
1061 !scm_is_null (clause_idx
);
1062 clause_idx
= SCM_CDR (clause_idx
))
1066 const SCM clause
= SCM_CAR (clause_idx
);
1067 const long length
= scm_ilength (clause
);
1068 ASSERT_SYNTAX_2 (length
>= 1, s_bad_cond_clause
, clause
, expr
);
1070 test
= SCM_CAR (clause
);
1071 if (scm_is_eq (test
, scm_sym_else
) && else_literal_p
)
1073 const int last_clause_p
= scm_is_null (SCM_CDR (clause_idx
));
1074 ASSERT_SYNTAX_2 (length
>= 2,
1075 s_bad_cond_clause
, clause
, expr
);
1076 ASSERT_SYNTAX_2 (last_clause_p
,
1077 s_misplaced_else_clause
, clause
, expr
);
1078 SCM_SETCAR (clause
, SCM_IM_ELSE
);
1080 else if (length
>= 2
1081 && scm_is_eq (SCM_CADR (clause
), scm_sym_arrow
)
1084 ASSERT_SYNTAX_2 (length
> 2, s_missing_recipient
, clause
, expr
);
1085 ASSERT_SYNTAX_2 (length
== 3, s_extra_expression
, clause
, expr
);
1086 SCM_SETCAR (SCM_CDR (clause
), SCM_IM_ARROW
);
1088 /* SRFI 61 extended cond */
1089 else if (length
>= 3
1090 && scm_is_eq (SCM_CADDR (clause
), scm_sym_arrow
)
1093 ASSERT_SYNTAX_2 (length
> 3, s_missing_recipient
, clause
, expr
);
1094 ASSERT_SYNTAX_2 (length
== 4, s_extra_expression
, clause
, expr
);
1095 SCM_SETCAR (SCM_CDDR (clause
), SCM_IM_ARROW
);
1099 SCM_SETCAR (expr
, SCM_IM_COND
);
1104 unmemoize_cond (const SCM expr
, const SCM env
)
1106 SCM um_clauses
= SCM_EOL
;
1109 for (clause_idx
= SCM_CDR (expr
);
1110 !scm_is_null (clause_idx
);
1111 clause_idx
= SCM_CDR (clause_idx
))
1113 const SCM clause
= SCM_CAR (clause_idx
);
1114 const SCM sequence
= SCM_CDR (clause
);
1115 const SCM test
= SCM_CAR (clause
);
1120 if (scm_is_eq (test
, SCM_IM_ELSE
))
1121 um_test
= scm_sym_else
;
1123 um_test
= unmemoize_expression (test
, env
);
1125 if (!scm_is_null (sequence
) && scm_is_eq (SCM_CAR (sequence
),
1128 const SCM target
= SCM_CADR (sequence
);
1129 const SCM um_target
= unmemoize_expression (target
, env
);
1130 um_sequence
= scm_list_2 (scm_sym_arrow
, um_target
);
1134 um_sequence
= unmemoize_exprs (sequence
, env
);
1137 um_clause
= scm_cons (um_test
, um_sequence
);
1138 um_clauses
= scm_cons (um_clause
, um_clauses
);
1140 um_clauses
= scm_reverse_x (um_clauses
, SCM_UNDEFINED
);
1142 return scm_cons (scm_sym_cond
, um_clauses
);
1146 SCM_SYNTAX (s_define
, "define", scm_i_makbimacro
, scm_m_define
);
1147 SCM_GLOBAL_SYMBOL (scm_sym_define
, s_define
);
1149 /* Guile provides an extension to R5RS' define syntax to represent function
1150 * currying in a compact way. With this extension, it is allowed to write
1151 * (define <nested-variable> <body>), where <nested-variable> has of one of
1152 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
1153 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
1154 * should be either a sequence of zero or more variables, or a sequence of one
1155 * or more variables followed by a space-delimited period and another
1156 * variable. Each level of argument nesting wraps the <body> within another
1157 * lambda expression. For example, the following forms are allowed, each one
1158 * followed by an equivalent, more explicit implementation.
1160 * (define ((a b . c) . d) <body>) is equivalent to
1161 * (define a (lambda (b . c) (lambda d <body>)))
1163 * (define (((a) b) c . d) <body>) is equivalent to
1164 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
1166 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
1167 * module that does not implement this extension. */
1169 canonicalize_define (const SCM expr
)
1174 const SCM cdr_expr
= SCM_CDR (expr
);
1175 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1176 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1178 body
= SCM_CDR (cdr_expr
);
1179 variable
= SCM_CAR (cdr_expr
);
1180 while (scm_is_pair (variable
))
1182 /* This while loop realizes function currying by variable nesting.
1183 * Variable is known to be a nested-variable. In every iteration of the
1184 * loop another level of lambda expression is created, starting with the
1185 * innermost one. Note that we don't check for duplicate formals here:
1186 * This will be done by the memoizer of the lambda expression. */
1187 const SCM formals
= SCM_CDR (variable
);
1188 const SCM tail
= scm_cons (formals
, body
);
1190 /* Add source properties to each new lambda expression: */
1191 const SCM lambda
= scm_cons_source (variable
, scm_sym_lambda
, tail
);
1193 body
= scm_list_1 (lambda
);
1194 variable
= SCM_CAR (variable
);
1196 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
1197 ASSERT_SYNTAX (scm_ilength (body
) == 1, s_expression
, expr
);
1199 SCM_SETCAR (cdr_expr
, variable
);
1200 SCM_SETCDR (cdr_expr
, body
);
1204 /* According to Section 5.2.1 of R5RS we first have to make sure that the
1205 variable is bound, and then perform the `(set! variable expression)'
1206 operation. However, EXPRESSION _can_ be evaluated before VARIABLE is
1207 bound. This means that EXPRESSION won't necessarily be able to assign
1208 values to VARIABLE as in `(define foo (begin (set! foo 1) (+ foo 1)))'. */
1210 scm_m_define (SCM expr
, SCM env
)
1212 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), s_bad_define
, expr
);
1215 const SCM canonical_definition
= canonicalize_define (expr
);
1216 const SCM cdr_canonical_definition
= SCM_CDR (canonical_definition
);
1217 const SCM variable
= SCM_CAR (cdr_canonical_definition
);
1218 const SCM value
= scm_eval_car (SCM_CDR (cdr_canonical_definition
), env
);
1220 = scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_T
);
1222 if (SCM_REC_PROCNAMES_P
)
1225 while (SCM_MACROP (tmp
))
1226 tmp
= SCM_MACRO_CODE (tmp
);
1227 if (scm_is_true (scm_procedure_p (tmp
))
1228 /* Only the first definition determines the name. */
1229 && scm_is_false (scm_procedure_property (tmp
, scm_sym_name
)))
1230 scm_set_procedure_property_x (tmp
, scm_sym_name
, variable
);
1233 SCM_VARIABLE_SET (location
, value
);
1235 return SCM_UNSPECIFIED
;
1240 /* This is a helper function for forms (<keyword> <expression>) that are
1241 * transformed into (#@<keyword> '() <memoized_expression>) in order to allow
1242 * for easy creation of a thunk (i. e. a closure without arguments) using the
1243 * ('() <memoized_expression>) tail of the memoized form. */
1245 memoize_as_thunk_prototype (const SCM expr
, const SCM env SCM_UNUSED
)
1247 const SCM cdr_expr
= SCM_CDR (expr
);
1248 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1249 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1251 SCM_SETCDR (expr
, scm_cons (SCM_EOL
, cdr_expr
));
1257 SCM_SYNTAX (s_delay
, "delay", scm_i_makbimacro
, scm_m_delay
);
1258 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
1260 /* Promises are implemented as closures with an empty parameter list. Thus,
1261 * (delay <expression>) is transformed into (#@delay '() <expression>), where
1262 * the empty list represents the empty parameter list. This representation
1263 * allows for easy creation of the closure during evaluation. */
1265 scm_m_delay (SCM expr
, SCM env
)
1267 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1268 SCM_SETCAR (new_expr
, SCM_IM_DELAY
);
1273 unmemoize_delay (const SCM expr
, const SCM env
)
1275 const SCM thunk_expr
= SCM_CADDR (expr
);
1276 /* A promise is implemented as a closure, and when applying a
1277 closure the evaluator adds a new frame to the environment - even
1278 though, in the case of a promise, the added frame is always
1279 empty. We need to extend the environment here in the same way,
1280 so that any ILOCs in thunk_expr can be unmemoized correctly. */
1281 const SCM new_env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1282 return scm_list_2 (scm_sym_delay
, unmemoize_expression (thunk_expr
, new_env
));
1286 SCM_SYNTAX(s_do
, "do", scm_i_makbimacro
, scm_m_do
);
1287 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
1289 /* DO gets the most radically altered syntax. The order of the vars is
1290 * reversed here. During the evaluation this allows for simple consing of the
1291 * results of the inits and steps:
1293 (do ((<var1> <init1> <step1>)
1301 (#@do (<init1> <init2> ... <initn>)
1302 (varn ... var2 var1)
1305 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
1308 scm_m_do (SCM expr
, SCM env SCM_UNUSED
)
1310 SCM variables
= SCM_EOL
;
1311 SCM init_forms
= SCM_EOL
;
1312 SCM step_forms
= SCM_EOL
;
1319 const SCM cdr_expr
= SCM_CDR (expr
);
1320 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1321 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1323 /* Collect variables, init and step forms. */
1324 binding_idx
= SCM_CAR (cdr_expr
);
1325 ASSERT_SYNTAX_2 (scm_ilength (binding_idx
) >= 0,
1326 s_bad_bindings
, binding_idx
, expr
);
1327 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1329 const SCM binding
= SCM_CAR (binding_idx
);
1330 const long length
= scm_ilength (binding
);
1331 ASSERT_SYNTAX_2 (length
== 2 || length
== 3,
1332 s_bad_binding
, binding
, expr
);
1335 const SCM name
= SCM_CAR (binding
);
1336 const SCM init
= SCM_CADR (binding
);
1337 const SCM step
= (length
== 2) ? name
: SCM_CADDR (binding
);
1338 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
1339 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, variables
)),
1340 s_duplicate_binding
, name
, expr
);
1342 variables
= scm_cons (name
, variables
);
1343 init_forms
= scm_cons (init
, init_forms
);
1344 step_forms
= scm_cons (step
, step_forms
);
1347 init_forms
= scm_reverse_x (init_forms
, SCM_UNDEFINED
);
1348 step_forms
= scm_reverse_x (step_forms
, SCM_UNDEFINED
);
1350 /* Memoize the test form and the exit sequence. */
1351 cddr_expr
= SCM_CDR (cdr_expr
);
1352 exit_clause
= SCM_CAR (cddr_expr
);
1353 ASSERT_SYNTAX_2 (scm_ilength (exit_clause
) >= 1,
1354 s_bad_exit_clause
, exit_clause
, expr
);
1356 commands
= SCM_CDR (cddr_expr
);
1357 tail
= scm_cons2 (exit_clause
, commands
, step_forms
);
1358 tail
= scm_cons2 (init_forms
, variables
, tail
);
1359 SCM_SETCAR (expr
, SCM_IM_DO
);
1360 SCM_SETCDR (expr
, tail
);
1365 unmemoize_do (const SCM expr
, const SCM env
)
1367 const SCM cdr_expr
= SCM_CDR (expr
);
1368 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1369 const SCM rnames
= SCM_CAR (cddr_expr
);
1370 const SCM extended_env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
1371 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
1372 const SCM exit_sequence
= SCM_CAR (cdddr_expr
);
1373 const SCM um_exit_sequence
= unmemoize_exprs (exit_sequence
, extended_env
);
1374 const SCM cddddr_expr
= SCM_CDR (cdddr_expr
);
1375 const SCM um_body
= unmemoize_exprs (SCM_CAR (cddddr_expr
), extended_env
);
1377 /* build transformed binding list */
1378 SCM um_names
= scm_reverse (rnames
);
1379 SCM um_inits
= unmemoize_exprs (SCM_CAR (cdr_expr
), env
);
1380 SCM um_steps
= unmemoize_exprs (SCM_CDR (cddddr_expr
), extended_env
);
1381 SCM um_bindings
= SCM_EOL
;
1382 while (!scm_is_null (um_names
))
1384 const SCM name
= SCM_CAR (um_names
);
1385 const SCM init
= SCM_CAR (um_inits
);
1386 SCM step
= SCM_CAR (um_steps
);
1387 step
= scm_is_eq (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
1389 um_bindings
= scm_cons (scm_cons2 (name
, init
, step
), um_bindings
);
1391 um_names
= SCM_CDR (um_names
);
1392 um_inits
= SCM_CDR (um_inits
);
1393 um_steps
= SCM_CDR (um_steps
);
1395 um_bindings
= scm_reverse_x (um_bindings
, SCM_UNDEFINED
);
1397 return scm_cons (scm_sym_do
,
1398 scm_cons2 (um_bindings
, um_exit_sequence
, um_body
));
1402 SCM_SYNTAX (s_if
, "if", scm_i_makbimacro
, scm_m_if
);
1403 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
1406 scm_m_if (SCM expr
, SCM env SCM_UNUSED
)
1408 const SCM cdr_expr
= SCM_CDR (expr
);
1409 const long length
= scm_ilength (cdr_expr
);
1410 ASSERT_SYNTAX (length
== 2 || length
== 3, s_expression
, expr
);
1411 SCM_SETCAR (expr
, SCM_IM_IF
);
1416 unmemoize_if (const SCM expr
, const SCM env
)
1418 const SCM cdr_expr
= SCM_CDR (expr
);
1419 const SCM um_condition
= unmemoize_expression (SCM_CAR (cdr_expr
), env
);
1420 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1421 const SCM um_then
= unmemoize_expression (SCM_CAR (cddr_expr
), env
);
1422 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
1424 if (scm_is_null (cdddr_expr
))
1426 return scm_list_3 (scm_sym_if
, um_condition
, um_then
);
1430 const SCM um_else
= unmemoize_expression (SCM_CAR (cdddr_expr
), env
);
1431 return scm_list_4 (scm_sym_if
, um_condition
, um_then
, um_else
);
1436 SCM_SYNTAX (s_lambda
, "lambda", scm_i_makbimacro
, scm_m_lambda
);
1437 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
1439 /* A helper function for memoize_lambda to support checking for duplicate
1440 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
1441 * LIST or to the cdr of the last cons. Therefore, LIST may have any of the
1442 * forms that a formal argument can have:
1443 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
1445 c_improper_memq (SCM obj
, SCM list
)
1447 for (; scm_is_pair (list
); list
= SCM_CDR (list
))
1449 if (scm_is_eq (SCM_CAR (list
), obj
))
1452 return scm_is_eq (list
, obj
);
1456 scm_m_lambda (SCM expr
, SCM env SCM_UNUSED
)
1465 const SCM cdr_expr
= SCM_CDR (expr
);
1466 const long length
= scm_ilength (cdr_expr
);
1467 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1468 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1470 /* Before iterating the list of formal arguments, make sure the formals
1471 * actually are given as either a symbol or a non-cyclic list. */
1472 formals
= SCM_CAR (cdr_expr
);
1473 if (scm_is_pair (formals
))
1475 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
1476 * detected, report a 'Bad formals' error. */
1480 ASSERT_SYNTAX_2 (scm_is_symbol (formals
) || scm_is_null (formals
),
1481 s_bad_formals
, formals
, expr
);
1484 /* Now iterate the list of formal arguments to check if all formals are
1485 * symbols, and that there are no duplicates. */
1486 formals_idx
= formals
;
1487 while (scm_is_pair (formals_idx
))
1489 const SCM formal
= SCM_CAR (formals_idx
);
1490 const SCM next_idx
= SCM_CDR (formals_idx
);
1491 ASSERT_SYNTAX_2 (scm_is_symbol (formal
), s_bad_formal
, formal
, expr
);
1492 ASSERT_SYNTAX_2 (!c_improper_memq (formal
, next_idx
),
1493 s_duplicate_formal
, formal
, expr
);
1494 formals_idx
= next_idx
;
1496 ASSERT_SYNTAX_2 (scm_is_null (formals_idx
) || scm_is_symbol (formals_idx
),
1497 s_bad_formal
, formals_idx
, expr
);
1499 /* Memoize the body. Keep a potential documentation string. */
1500 /* Dirk:FIXME:: We should probably extract the documentation string to
1501 * some external database. Otherwise it will slow down execution, since
1502 * the documentation string will have to be skipped with every execution
1503 * of the closure. */
1504 cddr_expr
= SCM_CDR (cdr_expr
);
1505 documentation
= (length
>= 3 && scm_is_string (SCM_CAR (cddr_expr
)));
1506 body
= documentation
? SCM_CDR (cddr_expr
) : cddr_expr
;
1507 new_body
= m_body (SCM_IM_LAMBDA
, body
);
1509 SCM_SETCAR (expr
, SCM_IM_LAMBDA
);
1511 SCM_SETCDR (cddr_expr
, new_body
);
1513 SCM_SETCDR (cdr_expr
, new_body
);
1518 unmemoize_lambda (const SCM expr
, const SCM env
)
1520 const SCM formals
= SCM_CADR (expr
);
1521 const SCM body
= SCM_CDDR (expr
);
1523 const SCM new_env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, env
);
1524 const SCM um_formals
= scm_i_finite_list_copy (formals
);
1525 const SCM um_body
= unmemoize_exprs (body
, new_env
);
1527 return scm_cons2 (scm_sym_lambda
, um_formals
, um_body
);
1531 /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
1533 check_bindings (const SCM bindings
, const SCM expr
)
1537 ASSERT_SYNTAX_2 (scm_ilength (bindings
) >= 0,
1538 s_bad_bindings
, bindings
, expr
);
1540 binding_idx
= bindings
;
1541 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1543 SCM name
; /* const */
1545 const SCM binding
= SCM_CAR (binding_idx
);
1546 ASSERT_SYNTAX_2 (scm_ilength (binding
) == 2,
1547 s_bad_binding
, binding
, expr
);
1549 name
= SCM_CAR (binding
);
1550 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
1555 /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
1556 * transformed to the lists (vn ... v2 v1) and (i1 i2 ... in). That is, the
1557 * variables are returned in a list with their order reversed, and the init
1558 * forms are returned in a list in the same order as they are given in the
1559 * bindings. If a duplicate variable name is detected, an error is
1562 transform_bindings (
1563 const SCM bindings
, const SCM expr
,
1564 SCM
*const rvarptr
, SCM
*const initptr
)
1566 SCM rvariables
= SCM_EOL
;
1567 SCM rinits
= SCM_EOL
;
1568 SCM binding_idx
= bindings
;
1569 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1571 const SCM binding
= SCM_CAR (binding_idx
);
1572 const SCM cdr_binding
= SCM_CDR (binding
);
1573 const SCM name
= SCM_CAR (binding
);
1574 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, rvariables
)),
1575 s_duplicate_binding
, name
, expr
);
1576 rvariables
= scm_cons (name
, rvariables
);
1577 rinits
= scm_cons (SCM_CAR (cdr_binding
), rinits
);
1579 *rvarptr
= rvariables
;
1580 *initptr
= scm_reverse_x (rinits
, SCM_UNDEFINED
);
1584 SCM_SYNTAX(s_let
, "let", scm_i_makbimacro
, scm_m_let
);
1585 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
1587 /* This function is a helper function for memoize_let. It transforms
1588 * (let name ((var init) ...) body ...) into
1589 * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
1590 * and memoizes the expression. It is assumed that the caller has checked
1591 * that name is a symbol and that there are bindings and a body. */
1593 memoize_named_let (const SCM expr
, const SCM env SCM_UNUSED
)
1599 const SCM cdr_expr
= SCM_CDR (expr
);
1600 const SCM name
= SCM_CAR (cdr_expr
);
1601 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1602 const SCM bindings
= SCM_CAR (cddr_expr
);
1603 check_bindings (bindings
, expr
);
1605 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1606 variables
= scm_reverse_x (rvariables
, SCM_UNDEFINED
);
1609 const SCM let_body
= SCM_CDR (cddr_expr
);
1610 const SCM lambda_body
= m_body (SCM_IM_LET
, let_body
);
1611 const SCM lambda_tail
= scm_cons (variables
, lambda_body
);
1612 const SCM lambda_form
= scm_cons_source (expr
, scm_sym_lambda
, lambda_tail
);
1614 const SCM rvar
= scm_list_1 (name
);
1615 const SCM init
= scm_list_1 (lambda_form
);
1616 const SCM body
= m_body (SCM_IM_LET
, scm_list_1 (name
));
1617 const SCM letrec_tail
= scm_cons (rvar
, scm_cons (init
, body
));
1618 const SCM letrec_form
= scm_cons_source (expr
, SCM_IM_LETREC
, letrec_tail
);
1619 return scm_cons_source (expr
, letrec_form
, inits
);
1623 /* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1624 * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
1626 scm_m_let (SCM expr
, SCM env
)
1630 const SCM cdr_expr
= SCM_CDR (expr
);
1631 const long length
= scm_ilength (cdr_expr
);
1632 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1633 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1635 bindings
= SCM_CAR (cdr_expr
);
1636 if (scm_is_symbol (bindings
))
1638 ASSERT_SYNTAX (length
>= 3, s_missing_expression
, expr
);
1639 return memoize_named_let (expr
, env
);
1642 check_bindings (bindings
, expr
);
1643 if (scm_is_null (bindings
) || scm_is_null (SCM_CDR (bindings
)))
1645 /* Special case: no bindings or single binding => let* is faster. */
1646 const SCM body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1647 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), bindings
, body
), env
);
1654 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1657 const SCM new_body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1658 const SCM new_tail
= scm_cons2 (rvariables
, inits
, new_body
);
1659 SCM_SETCAR (expr
, SCM_IM_LET
);
1660 SCM_SETCDR (expr
, new_tail
);
1667 build_binding_list (SCM rnames
, SCM rinits
)
1669 SCM bindings
= SCM_EOL
;
1670 while (!scm_is_null (rnames
))
1672 const SCM binding
= scm_list_2 (SCM_CAR (rnames
), SCM_CAR (rinits
));
1673 bindings
= scm_cons (binding
, bindings
);
1674 rnames
= SCM_CDR (rnames
);
1675 rinits
= SCM_CDR (rinits
);
1681 unmemoize_let (const SCM expr
, const SCM env
)
1683 const SCM cdr_expr
= SCM_CDR (expr
);
1684 const SCM um_rnames
= SCM_CAR (cdr_expr
);
1685 const SCM extended_env
= SCM_EXTEND_ENV (um_rnames
, SCM_EOL
, env
);
1686 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1687 const SCM um_inits
= unmemoize_exprs (SCM_CAR (cddr_expr
), env
);
1688 const SCM um_rinits
= scm_reverse_x (um_inits
, SCM_UNDEFINED
);
1689 const SCM um_bindings
= build_binding_list (um_rnames
, um_rinits
);
1690 const SCM um_body
= unmemoize_exprs (SCM_CDR (cddr_expr
), extended_env
);
1692 return scm_cons2 (scm_sym_let
, um_bindings
, um_body
);
1696 SCM_SYNTAX(s_letrec
, "letrec", scm_i_makbimacro
, scm_m_letrec
);
1697 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
1700 scm_m_letrec (SCM expr
, SCM env
)
1704 const SCM cdr_expr
= SCM_CDR (expr
);
1705 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1706 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1708 bindings
= SCM_CAR (cdr_expr
);
1709 if (scm_is_null (bindings
))
1711 /* no bindings, let* is executed faster */
1712 SCM body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1713 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), SCM_EOL
, body
), env
);
1721 check_bindings (bindings
, expr
);
1722 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1723 new_body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1724 return scm_cons2 (SCM_IM_LETREC
, rvariables
, scm_cons (inits
, new_body
));
1729 unmemoize_letrec (const SCM expr
, const SCM env
)
1731 const SCM cdr_expr
= SCM_CDR (expr
);
1732 const SCM um_rnames
= SCM_CAR (cdr_expr
);
1733 const SCM extended_env
= SCM_EXTEND_ENV (um_rnames
, SCM_EOL
, env
);
1734 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1735 const SCM um_inits
= unmemoize_exprs (SCM_CAR (cddr_expr
), extended_env
);
1736 const SCM um_rinits
= scm_reverse_x (um_inits
, SCM_UNDEFINED
);
1737 const SCM um_bindings
= build_binding_list (um_rnames
, um_rinits
);
1738 const SCM um_body
= unmemoize_exprs (SCM_CDR (cddr_expr
), extended_env
);
1740 return scm_cons2 (scm_sym_letrec
, um_bindings
, um_body
);
1745 SCM_SYNTAX (s_letstar
, "let*", scm_i_makbimacro
, scm_m_letstar
);
1746 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
1748 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1749 * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
1751 scm_m_letstar (SCM expr
, SCM env SCM_UNUSED
)
1756 const SCM cdr_expr
= SCM_CDR (expr
);
1757 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1758 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1760 binding_idx
= SCM_CAR (cdr_expr
);
1761 check_bindings (binding_idx
, expr
);
1763 /* Transform ((v1 i1) (v2 i2) ...) into (v1 i1 v2 i2 ...). The
1764 * transformation is done in place. At the beginning of one iteration of
1765 * the loop the variable binding_idx holds the form
1766 * P1:( (vn . P2:(in . ())) . P3:( (vn+1 in+1) ... ) ),
1767 * where P1, P2 and P3 indicate the pairs, that are relevant for the
1768 * transformation. P1 and P2 are modified in the loop, P3 remains
1769 * untouched. After the execution of the loop, P1 will hold
1770 * P1:( vn . P2:(in . P3:( (vn+1 in+1) ... )) )
1771 * and binding_idx will hold P3. */
1772 while (!scm_is_null (binding_idx
))
1774 const SCM cdr_binding_idx
= SCM_CDR (binding_idx
); /* remember P3 */
1775 const SCM binding
= SCM_CAR (binding_idx
);
1776 const SCM name
= SCM_CAR (binding
);
1777 const SCM cdr_binding
= SCM_CDR (binding
);
1779 SCM_SETCDR (cdr_binding
, cdr_binding_idx
); /* update P2 */
1780 SCM_SETCAR (binding_idx
, name
); /* update P1 */
1781 SCM_SETCDR (binding_idx
, cdr_binding
); /* update P1 */
1783 binding_idx
= cdr_binding_idx
; /* continue with P3 */
1786 new_body
= m_body (SCM_IM_LETSTAR
, SCM_CDR (cdr_expr
));
1787 SCM_SETCAR (expr
, SCM_IM_LETSTAR
);
1788 /* the bindings have been changed in place */
1789 SCM_SETCDR (cdr_expr
, new_body
);
1794 unmemoize_letstar (const SCM expr
, const SCM env
)
1796 const SCM cdr_expr
= SCM_CDR (expr
);
1797 const SCM body
= SCM_CDR (cdr_expr
);
1798 SCM bindings
= SCM_CAR (cdr_expr
);
1799 SCM um_bindings
= SCM_EOL
;
1800 SCM extended_env
= env
;
1803 while (!scm_is_null (bindings
))
1805 const SCM variable
= SCM_CAR (bindings
);
1806 const SCM init
= SCM_CADR (bindings
);
1807 const SCM um_init
= unmemoize_expression (init
, extended_env
);
1808 um_bindings
= scm_cons (scm_list_2 (variable
, um_init
), um_bindings
);
1809 extended_env
= SCM_EXTEND_ENV (variable
, SCM_BOOL_F
, extended_env
);
1810 bindings
= SCM_CDDR (bindings
);
1812 um_bindings
= scm_reverse_x (um_bindings
, SCM_UNDEFINED
);
1814 um_body
= unmemoize_exprs (body
, extended_env
);
1816 return scm_cons2 (scm_sym_letstar
, um_bindings
, um_body
);
1820 SCM_SYNTAX (s_or
, "or", scm_i_makbimacro
, scm_m_or
);
1821 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
1824 scm_m_or (SCM expr
, SCM env SCM_UNUSED
)
1826 const SCM cdr_expr
= SCM_CDR (expr
);
1827 const long length
= scm_ilength (cdr_expr
);
1829 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1833 /* Special case: (or) is replaced by #f. */
1838 SCM_SETCAR (expr
, SCM_IM_OR
);
1844 unmemoize_or (const SCM expr
, const SCM env
)
1846 return scm_cons (scm_sym_or
, unmemoize_exprs (SCM_CDR (expr
), env
));
1850 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
1851 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
1852 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
1853 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
1855 /* Internal function to handle a quasiquotation: 'form' is the parameter in
1856 * the call (quasiquotation form), 'env' is the environment where unquoted
1857 * expressions will be evaluated, and 'depth' is the current quasiquotation
1858 * nesting level and is known to be greater than zero. */
1860 iqq (SCM form
, SCM env
, unsigned long int depth
)
1862 if (scm_is_pair (form
))
1864 const SCM tmp
= SCM_CAR (form
);
1865 if (scm_is_eq (tmp
, scm_sym_quasiquote
))
1867 const SCM args
= SCM_CDR (form
);
1868 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1869 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
1871 else if (scm_is_eq (tmp
, scm_sym_unquote
))
1873 const SCM args
= SCM_CDR (form
);
1874 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1876 return scm_eval_car (args
, env
);
1878 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
1880 else if (scm_is_pair (tmp
)
1881 && scm_is_eq (SCM_CAR (tmp
), scm_sym_uq_splicing
))
1883 const SCM args
= SCM_CDR (tmp
);
1884 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1887 const SCM list
= scm_eval_car (args
, env
);
1888 const SCM rest
= SCM_CDR (form
);
1889 ASSERT_SYNTAX_2 (scm_ilength (list
) >= 0,
1890 s_splicing
, list
, form
);
1891 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
1894 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
1895 iqq (SCM_CDR (form
), env
, depth
));
1898 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
1899 iqq (SCM_CDR (form
), env
, depth
));
1901 else if (scm_is_vector (form
))
1902 return scm_vector (iqq (scm_vector_to_list (form
), env
, depth
));
1908 scm_m_quasiquote (SCM expr
, SCM env
)
1910 const SCM cdr_expr
= SCM_CDR (expr
);
1911 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1912 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1913 return iqq (SCM_CAR (cdr_expr
), env
, 1);
1917 SCM_SYNTAX (s_quote
, "quote", scm_i_makbimacro
, scm_m_quote
);
1918 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
1921 scm_m_quote (SCM expr
, SCM env SCM_UNUSED
)
1925 const SCM cdr_expr
= SCM_CDR (expr
);
1926 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1927 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1928 quotee
= SCM_CAR (cdr_expr
);
1929 if (is_self_quoting_p (quotee
))
1932 SCM_SETCAR (expr
, SCM_IM_QUOTE
);
1933 SCM_SETCDR (expr
, quotee
);
1938 unmemoize_quote (const SCM expr
, const SCM env SCM_UNUSED
)
1940 return scm_list_2 (scm_sym_quote
, SCM_CDR (expr
));
1944 /* Will go into the RnRS module when Guile is factorized.
1945 SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
1946 static const char s_set_x
[] = "set!";
1947 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, s_set_x
);
1950 scm_m_set_x (SCM expr
, SCM env SCM_UNUSED
)
1955 const SCM cdr_expr
= SCM_CDR (expr
);
1956 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1957 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1958 variable
= SCM_CAR (cdr_expr
);
1960 /* Memoize the variable form. */
1961 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
1962 new_variable
= lookup_symbol (variable
, env
);
1963 /* Leave the memoization of unbound symbols to lazy memoization: */
1964 if (SCM_UNBNDP (new_variable
))
1965 new_variable
= variable
;
1967 SCM_SETCAR (expr
, SCM_IM_SET_X
);
1968 SCM_SETCAR (cdr_expr
, new_variable
);
1973 unmemoize_set_x (const SCM expr
, const SCM env
)
1975 return scm_cons (scm_sym_set_x
, unmemoize_exprs (SCM_CDR (expr
), env
));
1979 /* Start of the memoizers for non-R5RS builtin macros. */
1982 SCM_SYNTAX (s_at
, "@", scm_makmmacro
, scm_m_at
);
1983 SCM_GLOBAL_SYMBOL (scm_sym_at
, s_at
);
1986 scm_m_at (SCM expr
, SCM env SCM_UNUSED
)
1989 ASSERT_SYNTAX (scm_ilength (expr
) == 3, s_bad_expression
, expr
);
1990 ASSERT_SYNTAX (scm_ilength (scm_cadr (expr
)) > 0, s_bad_expression
, expr
);
1992 mod
= scm_resolve_module (scm_cadr (expr
));
1993 if (scm_is_false (mod
))
1994 error_unbound_variable (expr
);
1995 var
= scm_module_variable (scm_module_public_interface (mod
), scm_caddr (expr
));
1996 if (scm_is_false (var
))
1997 error_unbound_variable (expr
);
2002 SCM_SYNTAX (s_atat
, "@@", scm_makmmacro
, scm_m_atat
);
2003 SCM_GLOBAL_SYMBOL (scm_sym_atat
, s_atat
);
2006 scm_m_atat (SCM expr
, SCM env SCM_UNUSED
)
2009 ASSERT_SYNTAX (scm_ilength (expr
) == 3, s_bad_expression
, expr
);
2010 ASSERT_SYNTAX (scm_ilength (scm_cadr (expr
)) > 0, s_bad_expression
, expr
);
2012 mod
= scm_resolve_module (scm_cadr (expr
));
2013 if (scm_is_false (mod
))
2014 error_unbound_variable (expr
);
2015 var
= scm_module_variable (mod
, scm_caddr (expr
));
2016 if (scm_is_false (var
))
2017 error_unbound_variable (expr
);
2022 SCM_SYNTAX (s_atapply
, "@apply", scm_i_makbimacro
, scm_m_apply
);
2023 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
2024 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
2027 scm_m_apply (SCM expr
, SCM env SCM_UNUSED
)
2029 const SCM cdr_expr
= SCM_CDR (expr
);
2030 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2031 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_missing_expression
, expr
);
2033 SCM_SETCAR (expr
, SCM_IM_APPLY
);
2038 unmemoize_apply (const SCM expr
, const SCM env
)
2040 return scm_list_2 (scm_sym_atapply
, unmemoize_exprs (SCM_CDR (expr
), env
));
2044 SCM_SYNTAX (s_atbind
, "@bind", scm_i_makbimacro
, scm_m_atbind
);
2046 /* FIXME: The following explanation should go into the documentation: */
2047 /* (@bind ((var init) ...) body ...) will assign the values of the `init's to
2048 * the global variables named by `var's (symbols, not evaluated), creating
2049 * them if they don't exist, executes body, and then restores the previous
2050 * values of the `var's. Additionally, whenever control leaves body, the
2051 * values of the `var's are saved and restored when control returns. It is an
2052 * error when a symbol appears more than once among the `var's. All `init's
2053 * are evaluated before any `var' is set.
2055 * Think of this as `let' for dynamic scope.
2058 /* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into
2059 * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...).
2061 * FIXME - also implement `@bind*'.
2064 scm_m_atbind (SCM expr
, SCM env
)
2071 const SCM top_level
= scm_env_top_level (env
);
2073 const SCM cdr_expr
= SCM_CDR (expr
);
2074 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2075 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
2076 bindings
= SCM_CAR (cdr_expr
);
2077 check_bindings (bindings
, expr
);
2078 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
2080 for (variable_idx
= rvariables
;
2081 !scm_is_null (variable_idx
);
2082 variable_idx
= SCM_CDR (variable_idx
))
2084 /* The first call to scm_sym2var will look beyond the current module,
2085 * while the second call wont. */
2086 const SCM variable
= SCM_CAR (variable_idx
);
2087 SCM new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_F
);
2088 if (scm_is_false (new_variable
))
2089 new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_T
);
2090 SCM_SETCAR (variable_idx
, new_variable
);
2093 SCM_SETCAR (expr
, SCM_IM_BIND
);
2094 SCM_SETCAR (cdr_expr
, scm_cons (rvariables
, inits
));
2099 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_i_makbimacro
, scm_m_cont
);
2100 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, s_atcall_cc
);
2103 scm_m_cont (SCM expr
, SCM env SCM_UNUSED
)
2105 const SCM cdr_expr
= SCM_CDR (expr
);
2106 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2107 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2109 SCM_SETCAR (expr
, SCM_IM_CONT
);
2114 unmemoize_atcall_cc (const SCM expr
, const SCM env
)
2116 return scm_list_2 (scm_sym_atcall_cc
, unmemoize_exprs (SCM_CDR (expr
), env
));
2120 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_i_makbimacro
, scm_m_at_call_with_values
);
2121 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
2124 scm_m_at_call_with_values (SCM expr
, SCM env SCM_UNUSED
)
2126 const SCM cdr_expr
= SCM_CDR (expr
);
2127 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2128 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2130 SCM_SETCAR (expr
, SCM_IM_CALL_WITH_VALUES
);
2135 unmemoize_at_call_with_values (const SCM expr
, const SCM env
)
2137 return scm_list_2 (scm_sym_at_call_with_values
,
2138 unmemoize_exprs (SCM_CDR (expr
), env
));
2143 /* See futures.h for a comment why futures are not enabled.
2146 SCM_SYNTAX (s_future
, "future", scm_i_makbimacro
, scm_m_future
);
2147 SCM_GLOBAL_SYMBOL (scm_sym_future
, s_future
);
2149 /* Like promises, futures are implemented as closures with an empty
2150 * parameter list. Thus, (future <expression>) is transformed into
2151 * (#@future '() <expression>), where the empty list represents the
2152 * empty parameter list. This representation allows for easy creation
2153 * of the closure during evaluation. */
2155 scm_m_future (SCM expr
, SCM env
)
2157 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
2158 SCM_SETCAR (new_expr
, SCM_IM_FUTURE
);
2163 unmemoize_future (const SCM expr
, const SCM env
)
2165 const SCM thunk_expr
= SCM_CADDR (expr
);
2166 return scm_list_2 (scm_sym_future
, unmemoize_expression (thunk_expr
, env
));
2169 #endif /* futures disabled. */
2171 SCM_SYNTAX (s_gset_x
, "set!", scm_i_makbimacro
, scm_m_generalized_set_x
);
2172 SCM_SYMBOL (scm_sym_setter
, "setter");
2175 scm_m_generalized_set_x (SCM expr
, SCM env
)
2177 SCM target
, exp_target
;
2179 const SCM cdr_expr
= SCM_CDR (expr
);
2180 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2181 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2183 target
= SCM_CAR (cdr_expr
);
2184 if (!scm_is_pair (target
))
2187 return scm_m_set_x (expr
, env
);
2191 /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */
2192 /* Macroexpanding the target might return things of the form
2193 (begin <atom>). In that case, <atom> must be a symbol or a
2194 variable and we memoize to (set! <atom> ...).
2196 exp_target
= macroexp (target
, env
);
2197 if (scm_is_eq (SCM_CAR (exp_target
), SCM_IM_BEGIN
)
2198 && !scm_is_null (SCM_CDR (exp_target
))
2199 && scm_is_null (SCM_CDDR (exp_target
)))
2201 exp_target
= SCM_CADR (exp_target
);
2202 ASSERT_SYNTAX_2 (scm_is_symbol (exp_target
)
2203 || SCM_VARIABLEP (exp_target
),
2204 s_bad_variable
, exp_target
, expr
);
2205 return scm_cons (SCM_IM_SET_X
, scm_cons (exp_target
,
2206 SCM_CDR (cdr_expr
)));
2210 const SCM setter_proc_tail
= scm_list_1 (SCM_CAR (target
));
2211 const SCM setter_proc
= scm_cons_source (expr
, scm_sym_setter
,
2214 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
2215 const SCM setter_args
= scm_append_x (scm_list_2 (SCM_CDR (target
),
2218 SCM_SETCAR (expr
, setter_proc
);
2219 SCM_SETCDR (expr
, setter_args
);
2226 /* @slot-ref is bound privately in the (oop goops) module from goops.c. As
2227 * soon as the module system allows us to more freely create bindings in
2228 * arbitrary modules during the startup phase, the code from goops.c should be
2231 SCM_SYMBOL (sym_atslot_ref
, "@slot-ref");
2234 scm_m_atslot_ref (SCM expr
, SCM env SCM_UNUSED
)
2238 const SCM cdr_expr
= SCM_CDR (expr
);
2239 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2240 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2241 slot_nr
= SCM_CADR (cdr_expr
);
2242 ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2244 SCM_SETCAR (expr
, SCM_IM_SLOT_REF
);
2245 SCM_SETCDR (cdr_expr
, slot_nr
);
2250 unmemoize_atslot_ref (const SCM expr
, const SCM env
)
2252 const SCM instance
= SCM_CADR (expr
);
2253 const SCM um_instance
= unmemoize_expression (instance
, env
);
2254 const SCM slot_nr
= SCM_CDDR (expr
);
2255 return scm_list_3 (sym_atslot_ref
, um_instance
, slot_nr
);
2259 /* @slot-set! is bound privately in the (oop goops) module from goops.c. As
2260 * soon as the module system allows us to more freely create bindings in
2261 * arbitrary modules during the startup phase, the code from goops.c should be
2264 SCM_SYMBOL (sym_atslot_set_x
, "@slot-set!");
2267 scm_m_atslot_set_x (SCM expr
, SCM env SCM_UNUSED
)
2271 const SCM cdr_expr
= SCM_CDR (expr
);
2272 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2273 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 3, s_expression
, expr
);
2274 slot_nr
= SCM_CADR (cdr_expr
);
2275 ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2277 SCM_SETCAR (expr
, SCM_IM_SLOT_SET_X
);
2282 unmemoize_atslot_set_x (const SCM expr
, const SCM env
)
2284 const SCM cdr_expr
= SCM_CDR (expr
);
2285 const SCM instance
= SCM_CAR (cdr_expr
);
2286 const SCM um_instance
= unmemoize_expression (instance
, env
);
2287 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
2288 const SCM slot_nr
= SCM_CAR (cddr_expr
);
2289 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
2290 const SCM value
= SCM_CAR (cdddr_expr
);
2291 const SCM um_value
= unmemoize_expression (value
, env
);
2292 return scm_list_4 (sym_atslot_set_x
, um_instance
, slot_nr
, um_value
);
2296 #if SCM_ENABLE_ELISP
2298 static const char s_defun
[] = "Symbol's function definition is void";
2300 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_i_makbimacro
, scm_m_nil_cond
);
2302 /* nil-cond expressions have the form
2303 * (nil-cond COND VAL COND VAL ... ELSEVAL) */
2305 scm_m_nil_cond (SCM expr
, SCM env SCM_UNUSED
)
2307 const long length
= scm_ilength (SCM_CDR (expr
));
2308 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
2309 ASSERT_SYNTAX (length
>= 1 && (length
% 2) == 1, s_expression
, expr
);
2311 SCM_SETCAR (expr
, SCM_IM_NIL_COND
);
2316 SCM_SYNTAX (s_atfop
, "@fop", scm_i_makbimacro
, scm_m_atfop
);
2318 /* The @fop-macro handles procedure and macro applications for elisp. The
2319 * input expression must have the form
2320 * (@fop <var> (transformer-macro <expr> ...))
2321 * where <var> must be a symbol. The expression is transformed into the
2322 * memoized form of either
2323 * (apply <un-aliased var> (transformer-macro <expr> ...))
2324 * if the value of var (across all aliasing) is not a macro, or
2325 * (<un-aliased var> <expr> ...)
2326 * if var is a macro. */
2328 scm_m_atfop (SCM expr
, SCM env SCM_UNUSED
)
2333 const SCM cdr_expr
= SCM_CDR (expr
);
2334 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2335 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 1, s_missing_expression
, expr
);
2337 symbol
= SCM_CAR (cdr_expr
);
2338 ASSERT_SYNTAX_2 (scm_is_symbol (symbol
), s_bad_variable
, symbol
, expr
);
2340 location
= scm_symbol_fref (symbol
);
2341 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2343 /* The elisp function `defalias' allows to define aliases for symbols. To
2344 * look up such definitions, the chain of symbol definitions has to be
2345 * followed up to the terminal symbol. */
2346 while (scm_is_symbol (SCM_VARIABLE_REF (location
)))
2348 const SCM alias
= SCM_VARIABLE_REF (location
);
2349 location
= scm_symbol_fref (alias
);
2350 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2353 /* Memoize the value location belonging to the terminal symbol. */
2354 SCM_SETCAR (cdr_expr
, location
);
2356 if (!SCM_MACROP (SCM_VARIABLE_REF (location
)))
2358 /* Since the location does not contain a macro, the form is a procedure
2359 * application. Replace `@fop' by `@apply' and transform the expression
2360 * including the `transformer-macro'. */
2361 SCM_SETCAR (expr
, SCM_IM_APPLY
);
2366 /* Since the location contains a macro, the arguments should not be
2367 * transformed, so the `transformer-macro' is cut out. The resulting
2368 * expression starts with the memoized variable, that is at the cdr of
2369 * the input expression. */
2370 SCM_SETCDR (cdr_expr
, SCM_CDADR (cdr_expr
));
2375 #endif /* SCM_ENABLE_ELISP */
2379 unmemoize_builtin_macro (const SCM expr
, const SCM env
)
2381 switch (ISYMNUM (SCM_CAR (expr
)))
2383 case (ISYMNUM (SCM_IM_AND
)):
2384 return unmemoize_and (expr
, env
);
2386 case (ISYMNUM (SCM_IM_BEGIN
)):
2387 return unmemoize_begin (expr
, env
);
2389 case (ISYMNUM (SCM_IM_CASE
)):
2390 return unmemoize_case (expr
, env
);
2392 case (ISYMNUM (SCM_IM_COND
)):
2393 return unmemoize_cond (expr
, env
);
2395 case (ISYMNUM (SCM_IM_DELAY
)):
2396 return unmemoize_delay (expr
, env
);
2398 case (ISYMNUM (SCM_IM_DO
)):
2399 return unmemoize_do (expr
, env
);
2401 case (ISYMNUM (SCM_IM_IF
)):
2402 return unmemoize_if (expr
, env
);
2404 case (ISYMNUM (SCM_IM_LAMBDA
)):
2405 return unmemoize_lambda (expr
, env
);
2407 case (ISYMNUM (SCM_IM_LET
)):
2408 return unmemoize_let (expr
, env
);
2410 case (ISYMNUM (SCM_IM_LETREC
)):
2411 return unmemoize_letrec (expr
, env
);
2413 case (ISYMNUM (SCM_IM_LETSTAR
)):
2414 return unmemoize_letstar (expr
, env
);
2416 case (ISYMNUM (SCM_IM_OR
)):
2417 return unmemoize_or (expr
, env
);
2419 case (ISYMNUM (SCM_IM_QUOTE
)):
2420 return unmemoize_quote (expr
, env
);
2422 case (ISYMNUM (SCM_IM_SET_X
)):
2423 return unmemoize_set_x (expr
, env
);
2425 case (ISYMNUM (SCM_IM_APPLY
)):
2426 return unmemoize_apply (expr
, env
);
2428 case (ISYMNUM (SCM_IM_BIND
)):
2429 return unmemoize_exprs (expr
, env
); /* FIXME */
2431 case (ISYMNUM (SCM_IM_CONT
)):
2432 return unmemoize_atcall_cc (expr
, env
);
2434 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2435 return unmemoize_at_call_with_values (expr
, env
);
2438 /* See futures.h for a comment why futures are not enabled.
2440 case (ISYMNUM (SCM_IM_FUTURE
)):
2441 return unmemoize_future (expr
, env
);
2444 case (ISYMNUM (SCM_IM_SLOT_REF
)):
2445 return unmemoize_atslot_ref (expr
, env
);
2447 case (ISYMNUM (SCM_IM_SLOT_SET_X
)):
2448 return unmemoize_atslot_set_x (expr
, env
);
2450 case (ISYMNUM (SCM_IM_NIL_COND
)):
2451 return unmemoize_exprs (expr
, env
); /* FIXME */
2454 return unmemoize_exprs (expr
, env
); /* FIXME */
2459 /* scm_i_unmemocopy_expr and scm_i_unmemocopy_body take a memoized expression
2460 * respectively a memoized body together with its environment and rewrite it
2461 * to its original form. Thus, these functions are the inversion of the
2462 * rewrite rules above. The procedure is not optimized for speed. It's used
2463 * in scm_i_unmemoize_expr, scm_procedure_source, macro_print and scm_iprin1.
2465 * Unmemoizing is not a reliable process. You cannot in general expect to get
2466 * the original source back.
2468 * However, GOOPS currently relies on this for method compilation. This ought
2472 scm_i_unmemocopy_expr (SCM expr
, SCM env
)
2474 const SCM source_properties
= scm_whash_lookup (scm_source_whash
, expr
);
2475 const SCM um_expr
= unmemoize_expression (expr
, env
);
2477 if (scm_is_true (source_properties
))
2478 scm_whash_insert (scm_source_whash
, um_expr
, source_properties
);
2484 scm_i_unmemocopy_body (SCM forms
, SCM env
)
2486 const SCM source_properties
= scm_whash_lookup (scm_source_whash
, forms
);
2487 const SCM um_forms
= unmemoize_exprs (forms
, env
);
2489 if (scm_is_true (source_properties
))
2490 scm_whash_insert (scm_source_whash
, um_forms
, source_properties
);
2496 #if (SCM_ENABLE_DEPRECATED == 1)
2498 /* Deprecated in guile 1.7.0 on 2003-11-09. */
2500 scm_m_expand_body (SCM exprs
, SCM env
)
2502 scm_c_issue_deprecation_warning
2503 ("`scm_m_expand_body' is deprecated.");
2504 m_expand_body (exprs
, env
);
2509 SCM_SYNTAX (s_undefine
, "undefine", scm_makacro
, scm_m_undefine
);
2512 scm_m_undefine (SCM expr
, SCM env
)
2517 const SCM cdr_expr
= SCM_CDR (expr
);
2518 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), "Bad undefine placement in", expr
);
2519 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2520 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2522 scm_c_issue_deprecation_warning
2523 ("`undefine' is deprecated.\n");
2525 variable
= SCM_CAR (cdr_expr
);
2526 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
2527 location
= scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_F
);
2528 ASSERT_SYNTAX_2 (scm_is_true (location
)
2529 && !SCM_UNBNDP (SCM_VARIABLE_REF (location
)),
2530 "variable already unbound ", variable
, expr
);
2531 SCM_VARIABLE_SET (location
, SCM_UNDEFINED
);
2532 return SCM_UNSPECIFIED
;
2536 scm_macroexp (SCM x
, SCM env
)
2538 scm_c_issue_deprecation_warning
2539 ("`scm_macroexp' is deprecated.");
2540 return macroexp (x
, env
);
2546 #if (SCM_ENABLE_DEPRECATED == 1)
2549 scm_unmemocar (SCM form
, SCM env
)
2551 scm_c_issue_deprecation_warning
2552 ("`scm_unmemocar' is deprecated.");
2554 if (!scm_is_pair (form
))
2558 SCM c
= SCM_CAR (form
);
2559 if (SCM_VARIABLEP (c
))
2561 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
2562 if (scm_is_false (sym
))
2563 sym
= sym_three_question_marks
;
2564 SCM_SETCAR (form
, sym
);
2566 else if (SCM_ILOCP (c
))
2568 unsigned long int ir
;
2570 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
2571 env
= SCM_CDR (env
);
2572 env
= SCM_CAAR (env
);
2573 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
2574 env
= SCM_CDR (env
);
2576 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
2584 /*****************************************************************************/
2585 /*****************************************************************************/
2586 /* The definitions for execution start here. */
2587 /*****************************************************************************/
2588 /*****************************************************************************/
2590 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
2591 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
2592 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
2593 SCM_GLOBAL_SYMBOL (scm_sym_memoize_symbol
, "memoize-symbol");
2594 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
2595 SCM_SYMBOL (sym_instead
, "instead");
2597 /* A function object to implement "apply" for non-closure functions. */
2599 /* An endless list consisting of #<undefined> objects: */
2600 static SCM undefineds
;
2604 scm_badargsp (SCM formals
, SCM args
)
2606 while (!scm_is_null (formals
))
2608 if (!scm_is_pair (formals
))
2610 if (scm_is_null (args
))
2612 formals
= SCM_CDR (formals
);
2613 args
= SCM_CDR (args
);
2615 return !scm_is_null (args
) ? 1 : 0;
2620 /* The evaluator contains a plethora of EVAL symbols.
2623 * SCM_I_EVALIM is used when it is known that the expression is an
2624 * immediate. (This macro never calls an evaluator.)
2626 * SCM_I_XEVAL evaluates an expression that is expected to have its symbols already
2627 * memoized. Expressions that are not of the form '(<form> <form> ...)' are
2628 * evaluated inline without calling an evaluator.
2630 * This macro uses ceval or deval depending on its 3rd argument.
2632 * SCM_I_XEVALCAR evaluates the car of an expression 'X:(Y:<form> <form> ...)',
2633 * potentially replacing a symbol at the position Y:<form> by its memoized
2634 * variable. If Y:<form> is not of the form '(<form> <form> ...)', the
2635 * evaluation is performed inline without calling an evaluator.
2637 * This macro uses ceval or deval depending on its 3rd argument.
2641 #define SCM_I_EVALIM2(x) \
2642 ((scm_is_eq ((x), SCM_EOL) \
2643 ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \
2647 #define SCM_I_EVALIM(x, env) (SCM_ILOCP (x) \
2648 ? *scm_ilookup ((x), (env)) \
2651 #define SCM_I_XEVAL(x, env, debug_p) \
2653 ? SCM_I_EVALIM2 (x) \
2654 : (SCM_VARIABLEP (x) \
2655 ? SCM_VARIABLE_REF (x) \
2656 : (scm_is_pair (x) \
2658 ? deval ((x), (env)) \
2659 : ceval ((x), (env))) \
2662 #define SCM_I_XEVALCAR(x, env, debug_p) \
2663 (SCM_IMP (SCM_CAR (x)) \
2664 ? SCM_I_EVALIM (SCM_CAR (x), (env)) \
2665 : (SCM_VARIABLEP (SCM_CAR (x)) \
2666 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2667 : (scm_is_pair (SCM_CAR (x)) \
2669 ? deval (SCM_CAR (x), (env)) \
2670 : ceval (SCM_CAR (x), (env))) \
2671 : (!scm_is_symbol (SCM_CAR (x)) \
2673 : *scm_lookupcar ((x), (env), 1)))))
2675 scm_i_pthread_mutex_t source_mutex
;
2678 /* Lookup a given local variable in an environment. The local variable is
2679 * given as an iloc, that is a triple <frame, binding, last?>, where frame
2680 * indicates the relative number of the environment frame (counting upwards
2681 * from the innermost environment frame), binding indicates the number of the
2682 * binding within the frame, and last? (which is extracted from the iloc using
2683 * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
2684 * very end of the improper list of bindings. */
2686 scm_ilookup (SCM iloc
, SCM env
)
2688 unsigned int frame_nr
= SCM_IFRAME (iloc
);
2689 unsigned int binding_nr
= SCM_IDIST (iloc
);
2693 for (; 0 != frame_nr
; --frame_nr
)
2694 frames
= SCM_CDR (frames
);
2696 bindings
= SCM_CAR (frames
);
2697 for (; 0 != binding_nr
; --binding_nr
)
2698 bindings
= SCM_CDR (bindings
);
2700 if (SCM_ICDRP (iloc
))
2701 return SCM_CDRLOC (bindings
);
2702 return SCM_CARLOC (SCM_CDR (bindings
));
2706 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
2708 /* Call this for variables that are unfound.
2711 error_unbound_variable (SCM symbol
)
2713 scm_error (scm_unbound_variable_key
, NULL
,
2714 "Unbound variable: ~S",
2715 scm_list_1 (symbol
), SCM_BOOL_F
);
2718 /* Call this for variables that are found but contain SCM_UNDEFINED.
2721 error_defined_variable (SCM symbol
)
2723 /* We use the 'unbound-variable' key here as well, since it
2724 basically is the same kind of error, with a slight variation in
2725 the displayed message.
2727 scm_error (scm_unbound_variable_key
, NULL
,
2728 "Variable used before given a value: ~S",
2729 scm_list_1 (symbol
), SCM_BOOL_F
);
2733 /* The Lookup Car Race
2736 Memoization of variables and special forms is done while executing
2737 the code for the first time. As long as there is only one thread
2738 everything is fine, but as soon as two threads execute the same
2739 code concurrently `for the first time' they can come into conflict.
2741 This memoization includes rewriting variable references into more
2742 efficient forms and expanding macros. Furthermore, macro expansion
2743 includes `compiling' special forms like `let', `cond', etc. into
2744 tree-code instructions.
2746 There shouldn't normally be a problem with memoizing local and
2747 global variable references (into ilocs and variables), because all
2748 threads will mutate the code in *exactly* the same way and (if I
2749 read the C code correctly) it is not possible to observe a half-way
2750 mutated cons cell. The lookup procedure can handle this
2751 transparently without any critical sections.
2753 It is different with macro expansion, because macro expansion
2754 happens outside of the lookup procedure and can't be
2755 undone. Therefore the lookup procedure can't cope with it. It has
2756 to indicate failure when it detects a lost race and hope that the
2757 caller can handle it. Luckily, it turns out that this is the case.
2759 An example to illustrate this: Suppose that the following form will
2760 be memoized concurrently by two threads
2764 Let's first examine the lookup of X in the body. The first thread
2765 decides that it has to find the symbol "x" in the environment and
2766 starts to scan it. Then the other thread takes over and actually
2767 overtakes the first. It looks up "x" and substitutes an
2768 appropriate iloc for it. Now the first thread continues and
2769 completes its lookup. It comes to exactly the same conclusions as
2770 the second one and could - without much ado - just overwrite the
2771 iloc with the same iloc.
2773 But let's see what will happen when the race occurs while looking
2774 up the symbol "let" at the start of the form. It could happen that
2775 the second thread interrupts the lookup of the first thread and not
2776 only substitutes a variable for it but goes right ahead and
2777 replaces it with the compiled form (#@let* (x 12) x). Now, when
2778 the first thread completes its lookup, it would replace the #@let*
2779 with a variable containing the "let" binding, effectively reverting
2780 the form to (let (x 12) x). This is wrong. It has to detect that
2781 it has lost the race and the evaluator has to reconsider the
2782 changed form completely.
2784 This race condition could be resolved with some kind of traffic
2785 light (like mutexes) around scm_lookupcar, but I think that it is
2786 best to avoid them in this case. They would serialize memoization
2787 completely and because lookup involves calling arbitrary Scheme
2788 code (via the lookup-thunk), threads could be blocked for an
2789 arbitrary amount of time or even deadlock. But with the current
2790 solution a lot of unnecessary work is potentially done. */
2792 /* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
2793 return NULL to indicate a failed lookup due to some race conditions
2794 between threads. This only happens when VLOC is the first cell of
2795 a special form that will eventually be memoized (like `let', etc.)
2796 In that case the whole lookup is bogus and the caller has to
2797 reconsider the complete special form.
2799 SCM_LOOKUPCAR is still there, of course. It just calls
2800 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
2801 should only be called when it is known that VLOC is not the first
2802 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
2803 for NULL. I think I've found the only places where this
2807 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
2810 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
2811 register SCM iloc
= SCM_ILOC00
;
2812 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
2814 if (!scm_is_pair (SCM_CAR (env
)))
2816 al
= SCM_CARLOC (env
);
2817 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
2819 if (!scm_is_pair (fl
))
2821 if (scm_is_eq (fl
, var
))
2823 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2825 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
2826 return SCM_CDRLOC (*al
);
2831 al
= SCM_CDRLOC (*al
);
2832 if (scm_is_eq (SCM_CAR (fl
), var
))
2834 if (SCM_UNBNDP (SCM_CAR (*al
)))
2835 error_defined_variable (var
);
2836 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2838 SCM_SETCAR (vloc
, iloc
);
2839 return SCM_CARLOC (*al
);
2841 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
2843 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
2846 SCM top_thunk
, real_var
;
2849 top_thunk
= SCM_CAR (env
); /* env now refers to a
2850 top level env thunk */
2851 env
= SCM_CDR (env
);
2854 top_thunk
= SCM_BOOL_F
;
2855 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
2856 if (scm_is_false (real_var
))
2859 if (!scm_is_null (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
2864 if (scm_is_null (env
))
2865 error_unbound_variable (var
);
2867 scm_misc_error (NULL
, "Damaged environment: ~S",
2872 /* A variable could not be found, but we shall
2873 not throw an error. */
2874 static SCM undef_object
= SCM_UNDEFINED
;
2875 return &undef_object
;
2879 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2881 /* Some other thread has changed the very cell we are working
2882 on. In effect, it must have done our job or messed it up
2885 var
= SCM_CAR (vloc
);
2886 if (SCM_VARIABLEP (var
))
2887 return SCM_VARIABLE_LOC (var
);
2888 if (SCM_ILOCP (var
))
2889 return scm_ilookup (var
, genv
);
2890 /* We can't cope with anything else than variables and ilocs. When
2891 a special form has been memoized (i.e. `let' into `#@let') we
2892 return NULL and expect the calling function to do the right
2893 thing. For the evaluator, this means going back and redoing
2894 the dispatch on the car of the form. */
2898 SCM_SETCAR (vloc
, real_var
);
2899 return SCM_VARIABLE_LOC (real_var
);
2904 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
2906 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
2913 /* During execution, look up a symbol in the top level of the given local
2914 * environment and return the corresponding variable object. If no binding
2915 * for the symbol can be found, an 'Unbound variable' error is signalled. */
2917 lazy_memoize_variable (const SCM symbol
, const SCM environment
)
2919 const SCM top_level
= scm_env_top_level (environment
);
2920 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
2922 if (scm_is_false (variable
))
2923 error_unbound_variable (symbol
);
2930 scm_eval_car (SCM pair
, SCM env
)
2932 return SCM_I_XEVALCAR (pair
, env
, scm_debug_mode_p
);
2937 scm_eval_body (SCM code
, SCM env
)
2942 next
= SCM_CDR (code
);
2943 while (!scm_is_null (next
))
2945 if (SCM_IMP (SCM_CAR (code
)))
2947 if (SCM_ISYMP (SCM_CAR (code
)))
2949 scm_dynwind_begin (0);
2950 scm_i_dynwind_pthread_mutex_lock (&source_mutex
);
2951 /* check for race condition */
2952 if (SCM_ISYMP (SCM_CAR (code
)))
2953 m_expand_body (code
, env
);
2959 SCM_I_XEVAL (SCM_CAR (code
), env
, scm_debug_mode_p
);
2961 next
= SCM_CDR (code
);
2963 return SCM_I_XEVALCAR (code
, env
, scm_debug_mode_p
);
2967 /* scm_last_debug_frame contains a pointer to the last debugging information
2968 * stack frame. It is accessed very often from the debugging evaluator, so it
2969 * should probably not be indirectly addressed. Better to save and restore it
2970 * from the current root at any stack swaps.
2973 /* scm_debug_eframe_size is the number of slots available for pseudo
2974 * stack frames at each real stack frame.
2977 long scm_debug_eframe_size
;
2979 int scm_debug_mode_p
;
2980 int scm_check_entry_p
;
2981 int scm_check_apply_p
;
2982 int scm_check_exit_p
;
2983 int scm_check_memoize_p
;
2985 long scm_eval_stack
;
2987 scm_t_option scm_eval_opts
[] = {
2988 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." },
2992 scm_t_option scm_debug_opts
[] = {
2993 { SCM_OPTION_BOOLEAN
, "cheap", 1,
2994 "*This option is now obsolete. Setting it has no effect." },
2995 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
2996 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
2997 { SCM_OPTION_BOOLEAN
, "procnames", 1,
2998 "Record procedure names at definition." },
2999 { SCM_OPTION_BOOLEAN
, "backwards", 0,
3000 "Display backtrace in anti-chronological order." },
3001 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
3002 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
3003 { SCM_OPTION_INTEGER
, "frames", 3,
3004 "Maximum number of tail-recursive frames in backtrace." },
3005 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
3006 "Maximal number of stored backtrace frames." },
3007 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
3008 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
3009 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
3011 { SCM_OPTION_INTEGER
, "stack", 40000, "Stack size limit (measured in words; 0 = no check)." },
3012 { SCM_OPTION_SCM
, "show-file-name", (unsigned long)SCM_BOOL_T
,
3013 "Show file names and line numbers "
3014 "in backtraces when not `#f'. A value of `base' "
3015 "displays only base names, while `#t' displays full names."},
3016 { SCM_OPTION_BOOLEAN
, "warn-deprecated", 0,
3017 "Warn when deprecated features are used." },
3023 * this ordering is awkward and illogical, but we maintain it for
3024 * compatibility. --hwn
3026 scm_t_option scm_evaluator_trap_table
[] = {
3027 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
3028 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
3029 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
3030 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
3031 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
3032 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
3033 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." },
3034 { SCM_OPTION_BOOLEAN
, "memoize-symbol", 0, "Trap when memoizing a symbol." },
3035 { SCM_OPTION_SCM
, "memoize-symbol-handler", (unsigned long)SCM_BOOL_F
, "The handler for memoization." },
3040 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
3042 "Option interface for the evaluation options. Instead of using\n"
3043 "this procedure directly, use the procedures @code{eval-enable},\n"
3044 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
3045 #define FUNC_NAME s_scm_eval_options_interface
3049 scm_dynwind_begin (0);
3050 scm_dynwind_critical_section (SCM_BOOL_F
);
3051 ans
= scm_options (setting
,
3054 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
3062 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
3064 "Option interface for the evaluator trap options.")
3065 #define FUNC_NAME s_scm_evaluator_traps
3070 scm_options_try (setting
,
3071 scm_evaluator_trap_table
,
3073 SCM_CRITICAL_SECTION_START
;
3074 ans
= scm_options (setting
,
3075 scm_evaluator_trap_table
,
3078 /* njrev: same again. */
3079 SCM_RESET_DEBUG_MODE
;
3080 SCM_CRITICAL_SECTION_END
;
3089 /* Simple procedure calls
3093 scm_call_0 (SCM proc
)
3095 if (SCM_PROGRAM_P (proc
))
3096 return scm_c_vm_run (scm_the_vm (), proc
, NULL
, 0);
3098 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
3102 scm_call_1 (SCM proc
, SCM arg1
)
3104 if (SCM_PROGRAM_P (proc
))
3105 return scm_c_vm_run (scm_the_vm (), proc
, &arg1
, 1);
3107 return scm_apply (proc
, arg1
, scm_listofnull
);
3111 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
3113 if (SCM_PROGRAM_P (proc
))
3115 SCM args
[] = { arg1
, arg2
};
3116 return scm_c_vm_run (scm_the_vm (), proc
, args
, 2);
3119 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
3123 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
3125 if (SCM_PROGRAM_P (proc
))
3127 SCM args
[] = { arg1
, arg2
, arg3
};
3128 return scm_c_vm_run (scm_the_vm (), proc
, args
, 3);
3131 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
3135 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
3137 if (SCM_PROGRAM_P (proc
))
3139 SCM args
[] = { arg1
, arg2
, arg3
, arg4
};
3140 return scm_c_vm_run (scm_the_vm (), proc
, args
, 4);
3143 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
3144 scm_cons (arg4
, scm_listofnull
)));
3147 /* Simple procedure applies
3151 scm_apply_0 (SCM proc
, SCM args
)
3153 return scm_apply (proc
, args
, SCM_EOL
);
3157 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
3159 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
3163 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
3165 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
3169 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
3171 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
3175 /* This code processes the arguments to apply:
3177 (apply PROC ARG1 ... ARGS)
3179 Given a list (ARG1 ... ARGS), this function conses the ARG1
3180 ... arguments onto the front of ARGS, and returns the resulting
3181 list. Note that ARGS is a list; thus, the argument to this
3182 function is a list whose last element is a list.
3184 Apply calls this function, and applies PROC to the elements of the
3185 result. apply:nconc2last takes care of building the list of
3186 arguments, given (ARG1 ... ARGS).
3188 Rather than do new consing, apply:nconc2last destroys its argument.
3189 On that topic, this code came into my care with the following
3190 beautifully cryptic comment on that topic: "This will only screw
3191 you if you do (scm_apply scm_apply '( ... ))" If you know what
3192 they're referring to, send me a patch to this comment. */
3194 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3196 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
3197 "conses the @var{arg1} @dots{} arguments onto the front of\n"
3198 "@var{args}, and returns the resulting list. Note that\n"
3199 "@var{args} is a list; thus, the argument to this function is\n"
3200 "a list whose last element is a list.\n"
3201 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
3202 "destroys its argument, so use with care.")
3203 #define FUNC_NAME s_scm_nconc2last
3206 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
3208 while (!scm_is_null (SCM_CDR (*lloc
))) /* Perhaps should be
3209 SCM_NULL_OR_NIL_P, but not
3210 needed in 99.99% of cases,
3211 and it could seriously hurt
3212 performance. - Neil */
3213 lloc
= SCM_CDRLOC (*lloc
);
3214 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3215 *lloc
= SCM_CAR (*lloc
);
3222 /* SECTION: The rest of this file is only read once.
3227 * Trampolines make it possible to move procedure application dispatch
3228 * outside inner loops. The motivation was clean implementation of
3229 * efficient replacements of R5RS primitives in SRFI-1.
3231 * The semantics is clear: scm_trampoline_N returns an optimized
3232 * version of scm_call_N (or NULL if the procedure isn't applicable
3235 * Applying the optimization to map and for-each increased efficiency
3236 * noticeably. For example, (map abs ls) is now 8 times faster than
3241 call_subr0_0 (SCM proc
)
3243 return SCM_SUBRF (proc
) ();
3247 call_subr1o_0 (SCM proc
)
3249 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
3253 call_lsubr_0 (SCM proc
)
3255 return SCM_SUBRF (proc
) (SCM_EOL
);
3259 scm_i_call_closure_0 (SCM proc
)
3261 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3264 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
3269 scm_trampoline_0 (SCM proc
)
3271 scm_t_trampoline_0 trampoline
;
3276 switch (SCM_TYP7 (proc
))
3278 case scm_tc7_subr_0
:
3279 trampoline
= call_subr0_0
;
3281 case scm_tc7_subr_1o
:
3282 trampoline
= call_subr1o_0
;
3285 trampoline
= call_lsubr_0
;
3287 case scm_tcs_closures
:
3289 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3290 if (scm_is_null (formals
) || !scm_is_pair (formals
))
3291 trampoline
= scm_i_call_closure_0
;
3296 case scm_tcs_struct
:
3297 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3298 trampoline
= scm_call_generic_0
;
3299 else if (SCM_I_OPERATORP (proc
))
3300 trampoline
= scm_call_0
;
3305 if (SCM_SMOB_APPLICABLE_P (proc
))
3306 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
3311 case scm_tc7_rpsubr
:
3314 trampoline
= scm_call_0
;
3317 return NULL
; /* not applicable on zero arguments */
3319 /* We only reach this point if a valid trampoline was determined. */
3321 /* If debugging is enabled, we want to see all calls to proc on the stack.
3322 * Thus, we replace the trampoline shortcut with scm_call_0. */
3323 if (scm_debug_mode_p
)
3330 call_subr1_1 (SCM proc
, SCM arg1
)
3332 return SCM_SUBRF (proc
) (arg1
);
3336 call_subr2o_1 (SCM proc
, SCM arg1
)
3338 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
3342 call_lsubr_1 (SCM proc
, SCM arg1
)
3344 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
3348 call_dsubr_1 (SCM proc
, SCM arg1
)
3350 if (SCM_I_INUMP (arg1
))
3352 return (scm_from_double (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
))));
3354 else if (SCM_REALP (arg1
))
3356 return (scm_from_double (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3358 else if (SCM_BIGP (arg1
))
3360 return (scm_from_double (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3362 else if (SCM_FRACTIONP (arg1
))
3364 return (scm_from_double (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
3366 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3367 SCM_ARG1
, scm_i_symbol_chars (SCM_SNAME (proc
)));
3371 call_cxr_1 (SCM proc
, SCM arg1
)
3373 return scm_i_chase_pairs (arg1
, (scm_t_bits
) SCM_SUBRF (proc
));
3377 call_closure_1 (SCM proc
, SCM arg1
)
3379 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3382 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
3387 scm_trampoline_1 (SCM proc
)
3389 scm_t_trampoline_1 trampoline
;
3394 switch (SCM_TYP7 (proc
))
3396 case scm_tc7_subr_1
:
3397 case scm_tc7_subr_1o
:
3398 trampoline
= call_subr1_1
;
3400 case scm_tc7_subr_2o
:
3401 trampoline
= call_subr2o_1
;
3404 trampoline
= call_lsubr_1
;
3407 trampoline
= call_dsubr_1
;
3410 trampoline
= call_cxr_1
;
3412 case scm_tcs_closures
:
3414 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3415 if (!scm_is_null (formals
)
3416 && (!scm_is_pair (formals
) || !scm_is_pair (SCM_CDR (formals
))))
3417 trampoline
= call_closure_1
;
3422 case scm_tcs_struct
:
3423 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3424 trampoline
= scm_call_generic_1
;
3425 else if (SCM_I_OPERATORP (proc
))
3426 trampoline
= scm_call_1
;
3431 if (SCM_SMOB_APPLICABLE_P (proc
))
3432 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
3437 case scm_tc7_rpsubr
:
3440 trampoline
= scm_call_1
;
3443 return NULL
; /* not applicable on one arg */
3445 /* We only reach this point if a valid trampoline was determined. */
3447 /* If debugging is enabled, we want to see all calls to proc on the stack.
3448 * Thus, we replace the trampoline shortcut with scm_call_1. */
3449 if (scm_debug_mode_p
)
3456 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
3458 return SCM_SUBRF (proc
) (arg1
, arg2
);
3462 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
3464 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
3468 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
3470 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
3474 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
3476 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3477 scm_list_2 (arg1
, arg2
),
3479 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
3484 scm_trampoline_2 (SCM proc
)
3486 scm_t_trampoline_2 trampoline
;
3491 switch (SCM_TYP7 (proc
))
3493 case scm_tc7_subr_2
:
3494 case scm_tc7_subr_2o
:
3495 case scm_tc7_rpsubr
:
3497 trampoline
= call_subr2_2
;
3499 case scm_tc7_lsubr_2
:
3500 trampoline
= call_lsubr2_2
;
3503 trampoline
= call_lsubr_2
;
3505 case scm_tcs_closures
:
3507 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3508 if (!scm_is_null (formals
)
3509 && (!scm_is_pair (formals
)
3510 || (!scm_is_null (SCM_CDR (formals
))
3511 && (!scm_is_pair (SCM_CDR (formals
))
3512 || !scm_is_pair (SCM_CDDR (formals
))))))
3513 trampoline
= call_closure_2
;
3518 case scm_tcs_struct
:
3519 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3520 trampoline
= scm_call_generic_2
;
3521 else if (SCM_I_OPERATORP (proc
))
3522 trampoline
= scm_call_2
;
3527 if (SCM_SMOB_APPLICABLE_P (proc
))
3528 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
3534 trampoline
= scm_call_2
;
3537 return NULL
; /* not applicable on two args */
3539 /* We only reach this point if a valid trampoline was determined. */
3541 /* If debugging is enabled, we want to see all calls to proc on the stack.
3542 * Thus, we replace the trampoline shortcut with scm_call_2. */
3543 if (scm_debug_mode_p
)
3549 /* Typechecking for multi-argument MAP and FOR-EACH.
3551 Verify that each element of the vector ARGV, except for the first,
3552 is a proper list whose length is LEN. Attribute errors to WHO,
3553 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3555 check_map_args (SCM argv
,
3564 for (i
= SCM_SIMPLE_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
3566 SCM elt
= SCM_SIMPLE_VECTOR_REF (argv
, i
);
3567 long elt_len
= scm_ilength (elt
);
3572 scm_apply_generic (gf
, scm_cons (proc
, args
));
3574 scm_wrong_type_arg (who
, i
+ 2, elt
);
3578 scm_out_of_range_pos (who
, elt
, scm_from_long (i
+ 2));
3583 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3585 /* Note: Currently, scm_map applies PROC to the argument list(s)
3586 sequentially, starting with the first element(s). This is used in
3587 evalext.c where the Scheme procedure `map-in-order', which guarantees
3588 sequential behaviour, is implemented using scm_map. If the
3589 behaviour changes, we need to update `map-in-order'.
3593 scm_map (SCM proc
, SCM arg1
, SCM args
)
3594 #define FUNC_NAME s_map
3600 len
= scm_ilength (arg1
);
3601 SCM_GASSERTn (len
>= 0,
3602 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
3603 SCM_VALIDATE_REST_ARGUMENT (args
);
3604 if (scm_is_null (args
))
3606 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
3607 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
3608 while (SCM_NIMP (arg1
))
3610 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
3611 pres
= SCM_CDRLOC (*pres
);
3612 arg1
= SCM_CDR (arg1
);
3616 if (scm_is_null (SCM_CDR (args
)))
3618 SCM arg2
= SCM_CAR (args
);
3619 int len2
= scm_ilength (arg2
);
3620 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
3622 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
3623 SCM_GASSERTn (len2
>= 0,
3624 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
3626 SCM_OUT_OF_RANGE (3, arg2
);
3627 while (SCM_NIMP (arg1
))
3629 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
3630 pres
= SCM_CDRLOC (*pres
);
3631 arg1
= SCM_CDR (arg1
);
3632 arg2
= SCM_CDR (arg2
);
3636 arg1
= scm_cons (arg1
, args
);
3637 args
= scm_vector (arg1
);
3638 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
3642 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3644 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
3647 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
3648 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
3650 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
3651 pres
= SCM_CDRLOC (*pres
);
3657 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
3660 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
3661 #define FUNC_NAME s_for_each
3664 len
= scm_ilength (arg1
);
3665 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
3666 SCM_ARG2
, s_for_each
);
3667 SCM_VALIDATE_REST_ARGUMENT (args
);
3668 if (scm_is_null (args
))
3670 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
3671 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
3672 while (SCM_NIMP (arg1
))
3674 call (proc
, SCM_CAR (arg1
));
3675 arg1
= SCM_CDR (arg1
);
3677 return SCM_UNSPECIFIED
;
3679 if (scm_is_null (SCM_CDR (args
)))
3681 SCM arg2
= SCM_CAR (args
);
3682 int len2
= scm_ilength (arg2
);
3683 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
3684 SCM_GASSERTn (call
, g_for_each
,
3685 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
3686 SCM_GASSERTn (len2
>= 0, g_for_each
,
3687 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
3689 SCM_OUT_OF_RANGE (3, arg2
);
3690 while (SCM_NIMP (arg1
))
3692 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
3693 arg1
= SCM_CDR (arg1
);
3694 arg2
= SCM_CDR (arg2
);
3696 return SCM_UNSPECIFIED
;
3698 arg1
= scm_cons (arg1
, args
);
3699 args
= scm_vector (arg1
);
3700 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
3704 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3706 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
3708 return SCM_UNSPECIFIED
;
3709 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
3710 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
3712 scm_apply (proc
, arg1
, SCM_EOL
);
3719 scm_closure (SCM code
, SCM env
)
3722 SCM closcar
= scm_cons (code
, SCM_EOL
);
3723 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
3724 scm_remember_upto_here (closcar
);
3729 scm_t_bits scm_tc16_promise
;
3731 SCM_DEFINE (scm_make_promise
, "make-promise", 1, 0, 0,
3733 "Create a new promise object.\n\n"
3734 "@code{make-promise} is a procedural form of @code{delay}.\n"
3735 "These two expressions are equivalent:\n"
3737 "(delay @var{exp})\n"
3738 "(make-promise (lambda () @var{exp}))\n"
3740 #define FUNC_NAME s_scm_make_promise
3742 SCM_VALIDATE_THUNK (1, thunk
);
3743 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
3745 scm_make_recursive_mutex ());
3750 promise_mark (SCM promise
)
3752 scm_gc_mark (SCM_PROMISE_MUTEX (promise
));
3753 return SCM_PROMISE_DATA (promise
);
3757 promise_free (SCM promise
)
3763 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
3765 int writingp
= SCM_WRITINGP (pstate
);
3766 scm_puts ("#<promise ", port
);
3767 SCM_SET_WRITINGP (pstate
, 1);
3768 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
3769 SCM_SET_WRITINGP (pstate
, writingp
);
3770 scm_putc ('>', port
);
3774 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
3776 "If the promise @var{x} has not been computed yet, compute and\n"
3777 "return @var{x}, otherwise just return the previously computed\n"
3779 #define FUNC_NAME s_scm_force
3781 SCM_VALIDATE_SMOB (1, promise
, promise
);
3782 scm_lock_mutex (SCM_PROMISE_MUTEX (promise
));
3783 if (!SCM_PROMISE_COMPUTED_P (promise
))
3785 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
3786 if (!SCM_PROMISE_COMPUTED_P (promise
))
3788 SCM_SET_PROMISE_DATA (promise
, ans
);
3789 SCM_SET_PROMISE_COMPUTED (promise
);
3792 scm_unlock_mutex (SCM_PROMISE_MUTEX (promise
));
3793 return SCM_PROMISE_DATA (promise
);
3798 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
3800 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
3801 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
3802 #define FUNC_NAME s_scm_promise_p
3804 return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
3809 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
3810 (SCM xorig
, SCM x
, SCM y
),
3811 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
3812 "Any source properties associated with @var{xorig} are also associated\n"
3813 "with the new pair.")
3814 #define FUNC_NAME s_scm_cons_source
3817 z
= scm_cons (x
, y
);
3818 /* Copy source properties possibly associated with xorig. */
3819 p
= scm_whash_lookup (scm_source_whash
, xorig
);
3820 if (scm_is_true (p
))
3821 scm_whash_insert (scm_source_whash
, z
, p
);
3827 /* The function scm_copy_tree is used to copy an expression tree to allow the
3828 * memoizer to modify the expression during memoization. scm_copy_tree
3829 * creates deep copies of pairs and vectors, but not of any other data types,
3830 * since only pairs and vectors will be parsed by the memoizer.
3832 * To avoid infinite recursion due to cyclic structures, the hare-and-tortoise
3833 * pattern is used to detect cycles. In fact, the pattern is used in two
3834 * dimensions, vertical (indicated in the code by the variable names 'hare'
3835 * and 'tortoise') and horizontal ('rabbit' and 'turtle'). In both
3836 * dimensions, the hare/rabbit will take two steps when the tortoise/turtle
3839 * The vertical dimension corresponds to recursive calls to function
3840 * copy_tree: This happens when descending into vector elements, into cars of
3841 * lists and into the cdr of an improper list. In this dimension, the
3842 * tortoise follows the hare by using the processor stack: Every stack frame
3843 * will hold an instance of struct t_trace. These instances are connected in
3844 * a way that represents the trace of the hare, which thus can be followed by
3845 * the tortoise. The tortoise will always point to struct t_trace instances
3846 * relating to SCM objects that have already been copied. Thus, a cycle is
3847 * detected if the tortoise and the hare point to the same object,
3849 * The horizontal dimension is within one execution of copy_tree, when the
3850 * function cdr's along the pairs of a list. This is the standard
3851 * hare-and-tortoise implementation, found several times in guile. */
3854 struct t_trace
*trace
; /* These pointers form a trace along the stack. */
3855 SCM obj
; /* The object handled at the respective stack frame.*/
3860 struct t_trace
*const hare
,
3861 struct t_trace
*tortoise
,
3862 unsigned int tortoise_delay
)
3864 if (!scm_is_pair (hare
->obj
) && !scm_is_simple_vector (hare
->obj
))
3870 /* Prepare the trace along the stack. */
3871 struct t_trace new_hare
;
3872 hare
->trace
= &new_hare
;
3874 /* The tortoise will make its step after the delay has elapsed. Note
3875 * that in contrast to the typical hare-and-tortoise pattern, the step
3876 * of the tortoise happens before the hare takes its steps. This is, in
3877 * principle, no problem, except for the start of the algorithm: Then,
3878 * it has to be made sure that the hare actually gets its advantage of
3880 if (tortoise_delay
== 0)
3883 tortoise
= tortoise
->trace
;
3884 ASSERT_SYNTAX (!scm_is_eq (hare
->obj
, tortoise
->obj
),
3885 s_bad_expression
, hare
->obj
);
3892 if (scm_is_simple_vector (hare
->obj
))
3894 size_t length
= SCM_SIMPLE_VECTOR_LENGTH (hare
->obj
);
3895 SCM new_vector
= scm_c_make_vector (length
, SCM_UNSPECIFIED
);
3897 /* Each vector element is copied by recursing into copy_tree, having
3898 * the tortoise follow the hare into the depths of the stack. */
3899 unsigned long int i
;
3900 for (i
= 0; i
< length
; ++i
)
3903 new_hare
.obj
= SCM_SIMPLE_VECTOR_REF (hare
->obj
, i
);
3904 new_element
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3905 SCM_SIMPLE_VECTOR_SET (new_vector
, i
, new_element
);
3910 else /* scm_is_pair (hare->obj) */
3915 SCM rabbit
= hare
->obj
;
3916 SCM turtle
= hare
->obj
;
3920 /* The first pair of the list is treated specially, in order to
3921 * preserve a potential source code position. */
3922 result
= tail
= scm_cons_source (rabbit
, SCM_EOL
, SCM_EOL
);
3923 new_hare
.obj
= SCM_CAR (rabbit
);
3924 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3925 SCM_SETCAR (tail
, copy
);
3927 /* The remaining pairs of the list are copied by, horizontally,
3928 * having the turtle follow the rabbit, and, vertically, having the
3929 * tortoise follow the hare into the depths of the stack. */
3930 rabbit
= SCM_CDR (rabbit
);
3931 while (scm_is_pair (rabbit
))
3933 new_hare
.obj
= SCM_CAR (rabbit
);
3934 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3935 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
3936 tail
= SCM_CDR (tail
);
3938 rabbit
= SCM_CDR (rabbit
);
3939 if (scm_is_pair (rabbit
))
3941 new_hare
.obj
= SCM_CAR (rabbit
);
3942 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3943 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
3944 tail
= SCM_CDR (tail
);
3945 rabbit
= SCM_CDR (rabbit
);
3947 turtle
= SCM_CDR (turtle
);
3948 ASSERT_SYNTAX (!scm_is_eq (rabbit
, turtle
),
3949 s_bad_expression
, rabbit
);
3953 /* We have to recurse into copy_tree again for the last cdr, in
3954 * order to handle the situation that it holds a vector. */
3955 new_hare
.obj
= rabbit
;
3956 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3957 SCM_SETCDR (tail
, copy
);
3964 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
3966 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
3967 "the new data structure. @code{copy-tree} recurses down the\n"
3968 "contents of both pairs and vectors (since both cons cells and vector\n"
3969 "cells may point to arbitrary objects), and stops recursing when it hits\n"
3970 "any other object.")
3971 #define FUNC_NAME s_scm_copy_tree
3973 /* Prepare the trace along the stack. */
3974 struct t_trace trace
;
3977 /* In function copy_tree, if the tortoise makes its step, it will do this
3978 * before the hare has the chance to move. Thus, we have to make sure that
3979 * the very first step of the tortoise will not happen after the hare has
3980 * really made two steps. This is achieved by passing '2' as the initial
3981 * delay for the tortoise. NOTE: Since cycles are unlikely, giving the hare
3982 * a bigger advantage may improve performance slightly. */
3983 return copy_tree (&trace
, &trace
, 2);
3988 /* We have three levels of EVAL here:
3990 - scm_i_eval (exp, env)
3992 evaluates EXP in environment ENV. ENV is a lexical environment
3993 structure as used by the actual tree code evaluator. When ENV is
3994 a top-level environment, then changes to the current module are
3995 tracked by updating ENV so that it continues to be in sync with
3998 - scm_primitive_eval (exp)
4000 evaluates EXP in the top-level environment as determined by the
4001 current module. This is done by constructing a suitable
4002 environment and calling scm_i_eval. Thus, changes to the
4003 top-level module are tracked normally.
4005 - scm_eval (exp, mod_or_state)
4007 evaluates EXP while MOD_OR_STATE is the current module or current
4008 dynamic state (as appropriate). This is done by setting the
4009 current module (or dynamic state) to MOD_OR_STATE, invoking
4010 scm_primitive_eval on EXP, and then restoring the current module
4011 (or dynamic state) to the value it had previously. That is,
4012 while EXP is evaluated, changes to the current module (or dynamic
4013 state) are tracked, but these changes do not persist when
4016 For each level of evals, there are two variants, distinguished by a
4017 _x suffix: the ordinary variant does not modify EXP while the _x
4018 variant can destructively modify EXP into something completely
4019 unintelligible. A Scheme data structure passed as EXP to one of the
4020 _x variants should not ever be used again for anything. So when in
4021 doubt, use the ordinary variant.
4026 scm_i_eval_x (SCM exp
, SCM env
)
4028 if (scm_is_symbol (exp
))
4029 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
4031 return SCM_I_XEVAL (exp
, env
, scm_debug_mode_p
);
4035 scm_i_eval (SCM exp
, SCM env
)
4037 exp
= scm_copy_tree (exp
);
4038 if (scm_is_symbol (exp
))
4039 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
4041 return SCM_I_XEVAL (exp
, env
, scm_debug_mode_p
);
4045 scm_primitive_eval_x (SCM exp
)
4048 SCM transformer
= scm_current_module_transformer ();
4049 if (SCM_NIMP (transformer
))
4050 exp
= scm_call_1 (transformer
, exp
);
4051 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4052 return scm_i_eval_x (exp
, env
);
4055 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
4057 "Evaluate @var{exp} in the top-level environment specified by\n"
4058 "the current module.")
4059 #define FUNC_NAME s_scm_primitive_eval
4062 SCM transformer
= scm_current_module_transformer ();
4063 if (scm_is_true (transformer
))
4064 exp
= scm_call_1 (transformer
, exp
);
4065 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4066 return scm_i_eval (exp
, env
);
4071 /* Eval does not take the second arg optionally. This is intentional
4072 * in order to be R5RS compatible, and to prepare for the new module
4073 * system, where we would like to make the choice of evaluation
4074 * environment explicit. */
4077 scm_eval_x (SCM exp
, SCM module_or_state
)
4081 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
4082 if (scm_is_dynamic_state (module_or_state
))
4083 scm_dynwind_current_dynamic_state (module_or_state
);
4085 scm_dynwind_current_module (module_or_state
);
4087 res
= scm_primitive_eval_x (exp
);
4093 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
4094 (SCM exp
, SCM module_or_state
),
4095 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
4096 "in the top-level environment specified by\n"
4097 "@var{module_or_state}.\n"
4098 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
4099 "@var{module_or_state} is made the current module when\n"
4100 "it is a module, or the current dynamic state when it is\n"
4102 "Example: (eval '(+ 1 2) (interaction-environment))")
4103 #define FUNC_NAME s_scm_eval
4107 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
4108 if (scm_is_dynamic_state (module_or_state
))
4109 scm_dynwind_current_dynamic_state (module_or_state
);
4112 SCM_VALIDATE_MODULE (2, module_or_state
);
4113 scm_dynwind_current_module (module_or_state
);
4116 res
= scm_primitive_eval (exp
);
4124 /* At this point, deval and scm_dapply are generated.
4136 scm_i_pthread_mutex_init (&source_mutex
,
4137 scm_i_pthread_mutexattr_recursive
);
4139 scm_init_opts (scm_evaluator_traps
,
4140 scm_evaluator_trap_table
);
4141 scm_init_opts (scm_eval_options_interface
,
4144 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
4145 scm_set_smob_mark (scm_tc16_promise
, promise_mark
);
4146 scm_set_smob_free (scm_tc16_promise
, promise_free
);
4147 scm_set_smob_print (scm_tc16_promise
, promise_print
);
4149 undefineds
= scm_list_1 (SCM_UNDEFINED
);
4150 SCM_SETCDR (undefineds
, undefineds
);
4151 scm_permanent_object (undefineds
);
4153 scm_listofnull
= scm_list_1 (SCM_EOL
);
4155 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
4156 scm_permanent_object (f_apply
);
4158 #include "libguile/eval.x"
4160 scm_add_feature ("delay");