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 License
6 * as published by the Free Software Foundation; either version 3 of
7 * the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful, but
10 * 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
22 /* SECTION: This code is compiled once.
31 #include "libguile/__scm.h"
34 #include "libguile/_scm.h"
35 #include "libguile/alist.h"
36 #include "libguile/async.h"
37 #include "libguile/continuations.h"
38 #include "libguile/debug.h"
39 #include "libguile/deprecation.h"
40 #include "libguile/dynwind.h"
41 #include "libguile/eq.h"
42 #include "libguile/feature.h"
43 #include "libguile/fluids.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/ports.h"
52 #include "libguile/print.h"
53 #include "libguile/procprop.h"
54 #include "libguile/programs.h"
55 #include "libguile/root.h"
56 #include "libguile/smob.h"
57 #include "libguile/srcprop.h"
58 #include "libguile/stackchk.h"
59 #include "libguile/strings.h"
60 #include "libguile/threads.h"
61 #include "libguile/throw.h"
62 #include "libguile/validate.h"
63 #include "libguile/values.h"
64 #include "libguile/vectors.h"
65 #include "libguile/vm.h"
67 #include "libguile/eval.h"
68 #include "libguile/private-options.h"
73 static SCM
unmemoize_exprs (SCM expr
, SCM env
);
74 static SCM
canonicalize_define (SCM expr
);
75 static SCM
*scm_lookupcar1 (SCM vloc
, SCM genv
, int check
);
76 static SCM
unmemoize_builtin_macro (SCM expr
, SCM env
);
77 static SCM
eval (SCM x
, SCM env
);
83 * This section defines the message strings for the syntax errors that can be
84 * detected during memoization and the functions and macros that shall be
85 * called by the memoizer code to signal syntax errors. */
88 /* Syntax errors that can be detected during memoization: */
90 /* Circular or improper lists do not form valid scheme expressions. If a
91 * circular list or an improper list is detected in a place where a scheme
92 * expression is expected, a 'Bad expression' error is signalled. */
93 static const char s_bad_expression
[] = "Bad expression";
95 /* If a form is detected that holds a different number of expressions than are
96 * required in that context, a 'Missing or extra expression' error is
98 static const char s_expression
[] = "Missing or extra expression in";
100 /* If a form is detected that holds less expressions than are required in that
101 * context, a 'Missing expression' error is signalled. */
102 static const char s_missing_expression
[] = "Missing expression in";
104 /* If a form is detected that holds more expressions than are allowed in that
105 * context, an 'Extra expression' error is signalled. */
106 static const char s_extra_expression
[] = "Extra expression in";
108 /* The empty combination '()' is not allowed as an expression in scheme. If
109 * it is detected in a place where an expression is expected, an 'Illegal
110 * empty combination' error is signalled. Note: If you encounter this error
111 * message, it is very likely that you intended to denote the empty list. To
112 * do so, you need to quote the empty list like (quote ()) or '(). */
113 static const char s_empty_combination
[] = "Illegal empty combination";
115 /* A body may hold an arbitrary number of internal defines, followed by a
116 * non-empty sequence of expressions. If a body with an empty sequence of
117 * expressions is detected, a 'Missing body expression' error is signalled.
119 static const char s_missing_body_expression
[] = "Missing body expression in";
121 /* A body may hold an arbitrary number of internal defines, followed by a
122 * non-empty sequence of expressions. Each the definitions and the
123 * expressions may be grouped arbitraryly with begin, but it is not allowed to
124 * mix definitions and expressions. If a define form in a body mixes
125 * definitions and expressions, a 'Mixed definitions and expressions' error is
127 static const char s_mixed_body_forms
[] = "Mixed definitions and expressions in";
128 /* Definitions are only allowed on the top level and at the start of a body.
129 * If a definition is detected anywhere else, a 'Bad define placement' error
131 static const char s_bad_define
[] = "Bad define placement";
133 /* Case or cond expressions must have at least one clause. If a case or cond
134 * expression without any clauses is detected, a 'Missing clauses' error is
136 static const char s_missing_clauses
[] = "Missing clauses";
138 /* If there is an 'else' clause in a case or a cond statement, it must be the
139 * last clause. If after the 'else' case clause further clauses are detected,
140 * a 'Misplaced else clause' error is signalled. */
141 static const char s_misplaced_else_clause
[] = "Misplaced else clause";
143 /* If a case clause is detected that is not in the format
144 * (<label(s)> <expression1> <expression2> ...)
145 * a 'Bad case clause' error is signalled. */
146 static const char s_bad_case_clause
[] = "Bad case clause";
148 /* If a case clause is detected where the <label(s)> element is neither a
149 * proper list nor (in case of the last clause) the syntactic keyword 'else',
150 * a 'Bad case labels' error is signalled. Note: If you encounter this error
151 * for an else-clause which seems to be syntactically correct, check if 'else'
152 * is really a syntactic keyword in that context. If 'else' is bound in the
153 * local or global environment, it is not considered a syntactic keyword, but
154 * will be treated as any other variable. */
155 static const char s_bad_case_labels
[] = "Bad case labels";
157 /* In a case statement all labels have to be distinct. If in a case statement
158 * a label occurs more than once, a 'Duplicate case label' error is
160 static const char s_duplicate_case_label
[] = "Duplicate case label";
162 /* If a cond clause is detected that is not in one of the formats
163 * (<test> <expression1> ...) or (else <expression1> <expression2> ...)
164 * a 'Bad cond clause' error is signalled. */
165 static const char s_bad_cond_clause
[] = "Bad cond clause";
167 /* If a cond clause is detected that uses the alternate '=>' form, but does
168 * not hold a recipient element for the test result, a 'Missing recipient'
169 * error is signalled. */
170 static const char s_missing_recipient
[] = "Missing recipient in";
172 /* If in a position where a variable name is required some other object is
173 * detected, a 'Bad variable' error is signalled. */
174 static const char s_bad_variable
[] = "Bad variable";
176 /* Bindings for forms like 'let' and 'do' have to be given in a proper,
177 * possibly empty list. If any other object is detected in a place where a
178 * list of bindings was required, a 'Bad bindings' error is signalled. */
179 static const char s_bad_bindings
[] = "Bad bindings";
181 /* Depending on the syntactic context, a binding has to be in the format
182 * (<variable> <expression>) or (<variable> <expression1> <expression2>).
183 * If anything else is detected in a place where a binding was expected, a
184 * 'Bad binding' error is signalled. */
185 static const char s_bad_binding
[] = "Bad binding";
187 /* Some syntactic forms don't allow variable names to appear more than once in
188 * a list of bindings. If such a situation is nevertheless detected, a
189 * 'Duplicate binding' error is signalled. */
190 static const char s_duplicate_binding
[] = "Duplicate binding";
192 /* If the exit form of a 'do' expression is not in the format
193 * (<test> <expression> ...)
194 * a 'Bad exit clause' error is signalled. */
195 static const char s_bad_exit_clause
[] = "Bad exit clause";
197 /* The formal function arguments of a lambda expression have to be either a
198 * single symbol or a non-cyclic list. For anything else a 'Bad formals'
199 * error is signalled. */
200 static const char s_bad_formals
[] = "Bad formals";
202 /* If in a lambda expression something else than a symbol is detected at a
203 * place where a formal function argument is required, a 'Bad formal' error is
205 static const char s_bad_formal
[] = "Bad formal";
207 /* If in the arguments list of a lambda expression an argument name occurs
208 * more than once, a 'Duplicate formal' error is signalled. */
209 static const char s_duplicate_formal
[] = "Duplicate formal";
211 /* If the evaluation of an unquote-splicing expression gives something else
212 * than a proper list, a 'Non-list result for unquote-splicing' error is
214 static const char s_splicing
[] = "Non-list result for unquote-splicing";
216 /* If something else than an exact integer is detected as the argument for
217 * @slot-ref and @slot-set!, a 'Bad slot number' error is signalled. */
218 static const char s_bad_slot_number
[] = "Bad slot number";
221 /* Signal a syntax error. We distinguish between the form that caused the
222 * error and the enclosing expression. The error message will print out as
223 * shown in the following pattern. The file name and line number are only
224 * given when they can be determined from the erroneous form or from the
225 * enclosing expression.
227 * <filename>: In procedure memoization:
228 * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
230 SCM_SYMBOL (syntax_error_key
, "syntax-error");
232 /* The prototype is needed to indicate that the function does not return. */
234 syntax_error (const char* const, const SCM
, const SCM
) SCM_NORETURN
;
237 syntax_error (const char* const msg
, const SCM form
, const SCM expr
)
239 SCM msg_string
= scm_from_locale_string (msg
);
240 SCM filename
= SCM_BOOL_F
;
241 SCM linenr
= SCM_BOOL_F
;
245 if (scm_is_pair (form
))
247 filename
= scm_source_property (form
, scm_sym_filename
);
248 linenr
= scm_source_property (form
, scm_sym_line
);
251 if (scm_is_false (filename
) && scm_is_false (linenr
) && scm_is_pair (expr
))
253 filename
= scm_source_property (expr
, scm_sym_filename
);
254 linenr
= scm_source_property (expr
, scm_sym_line
);
257 if (!SCM_UNBNDP (expr
))
259 if (scm_is_true (filename
))
261 format
= "In file ~S, line ~S: ~A ~S in expression ~S.";
262 args
= scm_list_5 (filename
, linenr
, msg_string
, form
, expr
);
264 else if (scm_is_true (linenr
))
266 format
= "In line ~S: ~A ~S in expression ~S.";
267 args
= scm_list_4 (linenr
, msg_string
, form
, expr
);
271 format
= "~A ~S in expression ~S.";
272 args
= scm_list_3 (msg_string
, form
, expr
);
277 if (scm_is_true (filename
))
279 format
= "In file ~S, line ~S: ~A ~S.";
280 args
= scm_list_4 (filename
, linenr
, msg_string
, form
);
282 else if (scm_is_true (linenr
))
284 format
= "In line ~S: ~A ~S.";
285 args
= scm_list_3 (linenr
, msg_string
, form
);
290 args
= scm_list_2 (msg_string
, form
);
294 scm_error (syntax_error_key
, "memoization", format
, args
, SCM_BOOL_F
);
298 /* Shortcut macros to simplify syntax error handling. */
299 #define ASSERT_SYNTAX(cond, message, form) \
300 { if (SCM_UNLIKELY (!(cond))) \
301 syntax_error (message, form, SCM_UNDEFINED); }
302 #define ASSERT_SYNTAX_2(cond, message, form, expr) \
303 { if (SCM_UNLIKELY (!(cond))) \
304 syntax_error (message, form, expr); }
306 static void error_unbound_variable (SCM symbol
) SCM_NORETURN
;
307 static void error_defined_variable (SCM symbol
) SCM_NORETURN
;
313 * Ilocs are memoized references to variables in local environment frames.
314 * They are represented as three values: The relative offset of the
315 * environment frame, the number of the binding within that frame, and a
316 * boolean value indicating whether the binding is the last binding in the
319 * Frame numbers have 11 bits, relative offsets have 12 bits.
322 #define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc)
323 #define SCM_IFRINC (0x00000100L)
324 #define SCM_ICDR (0x00080000L)
325 #define SCM_IDINC (0x00100000L)
326 #define SCM_IFRAME(n) ((long)((SCM_ICDR-SCM_IFRINC)>>8) \
327 & (SCM_UNPACK (n) >> 8))
328 #define SCM_IDIST(n) (SCM_UNPACK (n) >> 20)
329 #define SCM_ICDRP(n) (SCM_ICDR & SCM_UNPACK (n))
330 #define SCM_IDSTMSK (-SCM_IDINC)
331 #define SCM_IFRAMEMAX ((1<<11)-1)
332 #define SCM_IDISTMAX ((1<<12)-1)
333 #define SCM_MAKE_ILOC(frame_nr, binding_nr, last_p) \
336 + ((binding_nr) << 20) \
337 + ((last_p) ? SCM_ICDR : 0) \
341 scm_i_print_iloc (SCM iloc
, SCM port
)
343 scm_puts ("#@", port
);
344 scm_intprint ((long) SCM_IFRAME (iloc
), 10, port
);
345 scm_putc (SCM_ICDRP (iloc
) ? '-' : '+', port
);
346 scm_intprint ((long) SCM_IDIST (iloc
), 10, port
);
349 #if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
351 SCM
scm_dbg_make_iloc (SCM frame
, SCM binding
, SCM cdrp
);
353 SCM_DEFINE (scm_dbg_make_iloc
, "dbg-make-iloc", 3, 0, 0,
354 (SCM frame
, SCM binding
, SCM cdrp
),
355 "Return a new iloc with frame offset @var{frame}, binding\n"
356 "offset @var{binding} and the cdr flag @var{cdrp}.")
357 #define FUNC_NAME s_scm_dbg_make_iloc
359 return SCM_MAKE_ILOC ((scm_t_bits
) scm_to_unsigned_integer (frame
, 0, SCM_IFRAMEMAX
),
360 (scm_t_bits
) scm_to_unsigned_integer (binding
, 0, SCM_IDISTMAX
),
365 SCM
scm_dbg_iloc_p (SCM obj
);
367 SCM_DEFINE (scm_dbg_iloc_p
, "dbg-iloc?", 1, 0, 0,
369 "Return @code{#t} if @var{obj} is an iloc.")
370 #define FUNC_NAME s_scm_dbg_iloc_p
372 return scm_from_bool (SCM_ILOCP (obj
));
380 /* {Evaluator byte codes (isyms)}
383 #define ISYMNUM(n) (SCM_ITAG8_DATA (n))
385 /* This table must agree with the list of SCM_IM_ constants in tags.h */
386 static const char *const isymnames
[] =
403 "#@call-with-current-continuation",
408 "#@call-with-values",
416 scm_i_print_isym (SCM isym
, SCM port
)
418 const size_t isymnum
= ISYMNUM (isym
);
419 if (isymnum
< (sizeof isymnames
/ sizeof (char *)))
420 scm_puts (isymnames
[isymnum
], port
);
422 scm_ipruk ("isym", isym
, port
);
427 /* The function lookup_symbol is used during memoization: Lookup the symbol in
428 * the environment. If there is no binding for the symbol, SCM_UNDEFINED is
429 * returned. If the symbol is a global variable, the variable object to which
430 * the symbol is bound is returned. Finally, if the symbol is a local
431 * variable the corresponding iloc object is returned. */
433 /* A helper function for lookup_symbol: Try to find the symbol in the top
434 * level environment frame. The function returns SCM_UNDEFINED if the symbol
435 * is unbound and it returns a variable object if the symbol is a global
438 lookup_global_symbol (const SCM symbol
, const SCM top_level
)
440 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
441 if (scm_is_false (variable
))
442 return SCM_UNDEFINED
;
448 lookup_symbol (const SCM symbol
, const SCM env
)
451 unsigned int frame_nr
;
453 for (frame_idx
= env
, frame_nr
= 0;
454 !scm_is_null (frame_idx
);
455 frame_idx
= SCM_CDR (frame_idx
), ++frame_nr
)
457 const SCM frame
= SCM_CAR (frame_idx
);
458 if (scm_is_pair (frame
))
460 /* frame holds a local environment frame */
462 unsigned int symbol_nr
;
464 for (symbol_idx
= SCM_CAR (frame
), symbol_nr
= 0;
465 scm_is_pair (symbol_idx
);
466 symbol_idx
= SCM_CDR (symbol_idx
), ++symbol_nr
)
468 if (scm_is_eq (SCM_CAR (symbol_idx
), symbol
))
469 /* found the symbol, therefore return the iloc */
470 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 0);
472 if (scm_is_eq (symbol_idx
, symbol
))
473 /* found the symbol as the last element of the current frame */
474 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 1);
478 /* no more local environment frames */
479 return lookup_global_symbol (symbol
, frame
);
483 return lookup_global_symbol (symbol
, SCM_BOOL_F
);
487 /* Return true if the symbol is - from the point of view of a macro
488 * transformer - a literal in the sense specified in chapter "pattern
489 * language" of R5RS. In the code below, however, we don't match the
490 * definition of R5RS exactly: It returns true if the identifier has no
491 * binding or if it is a syntactic keyword. */
493 literal_p (const SCM symbol
, const SCM env
)
495 const SCM variable
= lookup_symbol (symbol
, env
);
496 if (SCM_UNBNDP (variable
))
498 if (SCM_VARIABLEP (variable
) && SCM_MACROP (SCM_VARIABLE_REF (variable
)))
505 /* Return true if the expression is self-quoting in the memoized code. Thus,
506 * some other objects (like e. g. vectors) are reported as self-quoting, which
507 * according to R5RS would need to be quoted. */
509 is_self_quoting_p (const SCM expr
)
511 if (scm_is_pair (expr
))
513 else if (scm_is_symbol (expr
))
515 else if (scm_is_null (expr
))
521 SCM_SYMBOL (sym_three_question_marks
, "???");
524 unmemoize_expression (const SCM expr
, const SCM env
)
526 if (SCM_ILOCP (expr
))
529 unsigned long int frame_nr
;
531 unsigned long int symbol_nr
;
533 for (frame_idx
= env
, frame_nr
= SCM_IFRAME (expr
);
535 frame_idx
= SCM_CDR (frame_idx
), --frame_nr
)
537 for (symbol_idx
= SCM_CAAR (frame_idx
), symbol_nr
= SCM_IDIST (expr
);
539 symbol_idx
= SCM_CDR (symbol_idx
), --symbol_nr
)
541 return SCM_ICDRP (expr
) ? symbol_idx
: SCM_CAR (symbol_idx
);
543 else if (SCM_VARIABLEP (expr
))
545 const SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), expr
);
546 return scm_is_true (sym
) ? sym
: sym_three_question_marks
;
548 else if (scm_is_simple_vector (expr
))
550 return scm_list_2 (scm_sym_quote
, expr
);
552 else if (!scm_is_pair (expr
))
556 else if (SCM_ISYMP (SCM_CAR (expr
)))
558 return unmemoize_builtin_macro (expr
, env
);
562 return unmemoize_exprs (expr
, env
);
568 unmemoize_exprs (const SCM exprs
, const SCM env
)
570 SCM r_result
= SCM_EOL
;
571 SCM expr_idx
= exprs
;
574 /* Note that due to the current lazy memoizer we may find partially memoized
575 * code during execution. In such code we have to expect improper lists of
576 * expressions: On the one hand, for such code syntax checks have not yet
577 * fully been performed, on the other hand, there may be even legal code
578 * like '(a . b) appear as an improper list of expressions as long as the
579 * quote expression is still in its unmemoized form. For this reason, the
580 * following code handles improper lists of expressions until memoization
581 * and execution have been completely separated. */
582 for (; scm_is_pair (expr_idx
); expr_idx
= SCM_CDR (expr_idx
))
584 const SCM expr
= SCM_CAR (expr_idx
);
586 /* In partially memoized code, lists of expressions that stem from a
587 * body form may start with an ISYM if the body itself has not yet been
588 * memoized. This isym is just an internal marker to indicate that the
589 * body still needs to be memoized. An isym may occur at the very
590 * beginning of the body or after one or more comment strings. It is
591 * dropped during unmemoization. */
592 if (!SCM_ISYMP (expr
))
594 um_expr
= unmemoize_expression (expr
, env
);
595 r_result
= scm_cons (um_expr
, r_result
);
598 um_expr
= unmemoize_expression (expr_idx
, env
);
599 if (!scm_is_null (r_result
))
601 const SCM result
= scm_reverse_x (r_result
, SCM_UNDEFINED
);
602 SCM_SETCDR (r_result
, um_expr
);
612 /* Rewrite the body (which is given as the list of expressions forming the
613 * body) into its internal form. The internal form of a body (<expr> ...) is
614 * just the body itself, but prefixed with an ISYM that denotes to what kind
615 * of outer construct this body belongs: (<ISYM> <expr> ...). A lambda body
616 * starts with SCM_IM_LAMBDA, for example, a body of a let starts with
619 * It is assumed that the calling expression has already made sure that the
620 * body is a proper list. */
622 m_body (SCM op
, SCM exprs
)
624 /* Don't add another ISYM if one is present already. */
625 if (SCM_ISYMP (SCM_CAR (exprs
)))
628 return scm_cons (op
, exprs
);
632 /* The function m_expand_body memoizes a proper list of expressions forming a
633 * body. This function takes care of dealing with internal defines and
634 * transforming them into an equivalent letrec expression. The list of
635 * expressions is rewritten in place. */
637 /* This is a helper function for m_expand_body. If the argument expression is
638 * a symbol that denotes a syntactic keyword, the corresponding macro object
639 * is returned, in all other cases the function returns SCM_UNDEFINED. */
641 try_macro_lookup (const SCM expr
, const SCM env
)
643 if (scm_is_symbol (expr
))
645 const SCM variable
= lookup_symbol (expr
, env
);
646 if (SCM_VARIABLEP (variable
))
648 const SCM value
= SCM_VARIABLE_REF (variable
);
649 if (SCM_MACROP (value
))
654 return SCM_UNDEFINED
;
657 /* This is a helper function for m_expand_body. It expands user macros,
658 * because for the correct translation of a body we need to know whether they
659 * expand to a definition. */
661 expand_user_macros (SCM expr
, const SCM env
)
663 while (scm_is_pair (expr
))
665 const SCM car_expr
= SCM_CAR (expr
);
666 const SCM new_car
= expand_user_macros (car_expr
, env
);
667 const SCM value
= try_macro_lookup (new_car
, env
);
669 if (SCM_MACROP (value
) && SCM_MACRO_TYPE (value
) == 2)
671 /* User macros transform code into code. */
672 expr
= scm_call_2 (SCM_MACRO_CODE (value
), expr
, env
);
673 /* We need to reiterate on the transformed code. */
677 /* No user macro: return. */
678 SCM_SETCAR (expr
, new_car
);
686 /* This is a helper function for m_expand_body. It determines if a given form
687 * represents an application of a given built-in macro. The built-in macro to
688 * check for is identified by its syntactic keyword. The form is an
689 * application of the given macro if looking up the car of the form in the
690 * given environment actually returns the built-in macro. */
692 is_system_macro_p (const SCM syntactic_keyword
, const SCM form
, const SCM env
)
694 if (scm_is_pair (form
))
696 const SCM car_form
= SCM_CAR (form
);
697 const SCM value
= try_macro_lookup (car_form
, env
);
698 if (SCM_BUILTIN_MACRO_P (value
))
700 const SCM macro_name
= scm_macro_name (value
);
701 return scm_is_eq (macro_name
, syntactic_keyword
);
709 macroexp (SCM x
, SCM env
)
711 SCM res
, proc
, orig_sym
;
713 /* Don't bother to produce error messages here. We get them when we
714 eventually execute the code for real. */
717 orig_sym
= SCM_CAR (x
);
718 if (!scm_is_symbol (orig_sym
))
722 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
723 if (proc_ptr
== NULL
)
725 /* We have lost the race. */
731 /* Only handle memoizing macros. `Acros' and `macros' are really
732 special forms and should not be evaluated here. */
734 if (!SCM_MACROP (proc
)
735 || (SCM_MACRO_TYPE (proc
) != 2 && !SCM_BUILTIN_MACRO_P (proc
)))
738 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
739 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
741 if (scm_ilength (res
) <= 0)
742 /* Result of expansion is not a list. */
743 return (scm_list_2 (SCM_IM_BEGIN
, res
));
746 /* njrev: Several queries here: (1) I don't see how it can be
747 correct that the SCM_SETCAR 2 lines below this comment needs
748 protection, but the SCM_SETCAR 6 lines above does not, so
749 something here is probably wrong. (2) macroexp() is now only
750 used in one place - scm_m_generalized_set_x - whereas all other
751 macro expansion happens through expand_user_macros. Therefore
752 (2.1) perhaps macroexp() could be eliminated completely now?
753 (2.2) Does expand_user_macros need any critical section
756 SCM_CRITICAL_SECTION_START
;
757 SCM_SETCAR (x
, SCM_CAR (res
));
758 SCM_SETCDR (x
, SCM_CDR (res
));
759 SCM_CRITICAL_SECTION_END
;
766 /* Start of the memoizers for the standard R5RS builtin macros. */
768 static SCM
scm_m_quote (SCM xorig
, SCM env
);
769 static SCM
scm_m_begin (SCM xorig
, SCM env
);
770 static SCM
scm_m_if (SCM xorig
, SCM env
);
771 static SCM
scm_m_set_x (SCM xorig
, SCM env
);
772 static SCM
scm_m_and (SCM xorig
, SCM env
);
773 static SCM
scm_m_or (SCM xorig
, SCM env
);
774 static SCM
scm_m_case (SCM xorig
, SCM env
);
775 static SCM
scm_m_cond (SCM xorig
, SCM env
);
776 static SCM
scm_m_lambda (SCM xorig
, SCM env
);
777 static SCM
scm_m_letstar (SCM xorig
, SCM env
);
778 static SCM
scm_m_do (SCM xorig
, SCM env
);
779 static SCM
scm_m_quasiquote (SCM xorig
, SCM env
);
780 static SCM
scm_m_delay (SCM xorig
, SCM env
);
781 static SCM
scm_m_generalized_set_x (SCM xorig
, SCM env
);
782 static SCM
scm_m_define (SCM x
, SCM env
);
783 static SCM
scm_m_letrec (SCM xorig
, SCM env
);
784 static SCM
scm_m_let (SCM xorig
, SCM env
);
785 static SCM
scm_m_at (SCM xorig
, SCM env
);
786 static SCM
scm_m_atat (SCM xorig
, SCM env
);
787 static SCM
scm_m_atslot_ref (SCM xorig
, SCM env
);
788 static SCM
scm_m_atslot_set_x (SCM xorig
, SCM env
);
789 static SCM
scm_m_apply (SCM xorig
, SCM env
);
790 static SCM
scm_m_cont (SCM xorig
, SCM env
);
792 static SCM
scm_m_nil_cond (SCM xorig
, SCM env
);
793 static SCM
scm_m_atfop (SCM xorig
, SCM env
);
794 #endif /* SCM_ENABLE_ELISP */
795 static SCM
scm_m_atbind (SCM xorig
, SCM env
);
796 static SCM
scm_m_at_call_with_values (SCM xorig
, SCM env
);
797 static SCM
scm_m_eval_when (SCM xorig
, SCM env
);
801 m_expand_body (const SCM forms
, const SCM env
)
803 /* The first body form can be skipped since it is known to be the ISYM that
804 * was prepended to the body by m_body. */
805 SCM cdr_forms
= SCM_CDR (forms
);
806 SCM form_idx
= cdr_forms
;
807 SCM definitions
= SCM_EOL
;
808 SCM sequence
= SCM_EOL
;
810 /* According to R5RS, the list of body forms consists of two parts: a number
811 * (maybe zero) of definitions, followed by a non-empty sequence of
812 * expressions. Each the definitions and the expressions may be grouped
813 * arbitrarily with begin, but it is not allowed to mix definitions and
814 * expressions. The task of the following loop therefore is to split the
815 * list of body forms into the list of definitions and the sequence of
817 while (!scm_is_null (form_idx
))
819 const SCM form
= SCM_CAR (form_idx
);
820 const SCM new_form
= expand_user_macros (form
, env
);
821 if (is_system_macro_p (scm_sym_define
, new_form
, env
))
823 definitions
= scm_cons (new_form
, definitions
);
824 form_idx
= SCM_CDR (form_idx
);
826 else if (is_system_macro_p (scm_sym_begin
, new_form
, env
))
828 /* We have encountered a group of forms. This has to be either a
829 * (possibly empty) group of (possibly further grouped) definitions,
830 * or a non-empty group of (possibly further grouped)
832 const SCM grouped_forms
= SCM_CDR (new_form
);
833 unsigned int found_definition
= 0;
834 unsigned int found_expression
= 0;
835 SCM grouped_form_idx
= grouped_forms
;
836 while (!found_expression
&& !scm_is_null (grouped_form_idx
))
838 const SCM inner_form
= SCM_CAR (grouped_form_idx
);
839 const SCM new_inner_form
= expand_user_macros (inner_form
, env
);
840 if (is_system_macro_p (scm_sym_define
, new_inner_form
, env
))
842 found_definition
= 1;
843 definitions
= scm_cons (new_inner_form
, definitions
);
844 grouped_form_idx
= SCM_CDR (grouped_form_idx
);
846 else if (is_system_macro_p (scm_sym_begin
, new_inner_form
, env
))
848 const SCM inner_group
= SCM_CDR (new_inner_form
);
850 = scm_append (scm_list_2 (inner_group
,
851 SCM_CDR (grouped_form_idx
)));
855 /* The group marks the start of the expressions of the body.
856 * We have to make sure that within the same group we have
857 * not encountered a definition before. */
858 ASSERT_SYNTAX (!found_definition
, s_mixed_body_forms
, form
);
859 found_expression
= 1;
860 grouped_form_idx
= SCM_EOL
;
864 /* We have finished processing the group. If we have not yet
865 * encountered an expression we continue processing the forms of the
866 * body to collect further definition forms. Otherwise, the group
867 * marks the start of the sequence of expressions of the body. */
868 if (!found_expression
)
870 form_idx
= SCM_CDR (form_idx
);
880 /* We have detected a form which is no definition. This marks the
881 * start of the sequence of expressions of the body. */
887 /* FIXME: forms does not hold information about the file location. */
888 ASSERT_SYNTAX (scm_is_pair (sequence
), s_missing_body_expression
, cdr_forms
);
890 if (!scm_is_null (definitions
))
894 SCM letrec_expression
;
895 SCM new_letrec_expression
;
897 SCM bindings
= SCM_EOL
;
898 for (definition_idx
= definitions
;
899 !scm_is_null (definition_idx
);
900 definition_idx
= SCM_CDR (definition_idx
))
902 const SCM definition
= SCM_CAR (definition_idx
);
903 const SCM canonical_definition
= canonicalize_define (definition
);
904 const SCM binding
= SCM_CDR (canonical_definition
);
905 bindings
= scm_cons (binding
, bindings
);
908 letrec_tail
= scm_cons (bindings
, sequence
);
909 /* FIXME: forms does not hold information about the file location. */
910 letrec_expression
= scm_cons_source (forms
, scm_sym_letrec
, letrec_tail
);
911 new_letrec_expression
= scm_m_letrec (letrec_expression
, env
);
912 SCM_SETCAR (forms
, new_letrec_expression
);
913 SCM_SETCDR (forms
, SCM_EOL
);
917 SCM_SETCAR (forms
, SCM_CAR (sequence
));
918 SCM_SETCDR (forms
, SCM_CDR (sequence
));
922 SCM_SYNTAX (s_and
, "and", scm_i_makbimacro
, scm_m_and
);
923 SCM_GLOBAL_SYMBOL (scm_sym_and
, "and");
926 scm_m_and (SCM expr
, SCM env SCM_UNUSED
)
928 const SCM cdr_expr
= SCM_CDR (expr
);
929 const long length
= scm_ilength (cdr_expr
);
931 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
935 /* Special case: (and) is replaced by #t. */
940 SCM_SETCAR (expr
, SCM_IM_AND
);
946 unmemoize_and (const SCM expr
, const SCM env
)
948 return scm_cons (scm_sym_and
, unmemoize_exprs (SCM_CDR (expr
), env
));
952 SCM_SYNTAX (s_begin
, "begin", scm_i_makbimacro
, scm_m_begin
);
953 SCM_GLOBAL_SYMBOL (scm_sym_begin
, "begin");
956 scm_m_begin (SCM expr
, SCM env SCM_UNUSED
)
958 const SCM cdr_expr
= SCM_CDR (expr
);
959 /* Dirk:FIXME:: An empty begin clause is not generally allowed by R5RS.
960 * That means, there should be a distinction between uses of begin where an
961 * empty clause is OK and where it is not. */
962 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
964 SCM_SETCAR (expr
, SCM_IM_BEGIN
);
969 unmemoize_begin (const SCM expr
, const SCM env
)
971 return scm_cons (scm_sym_begin
, unmemoize_exprs (SCM_CDR (expr
), env
));
975 SCM_SYNTAX (s_case
, "case", scm_i_makbimacro
, scm_m_case
);
976 SCM_GLOBAL_SYMBOL (scm_sym_case
, "case");
977 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
980 scm_m_case (SCM expr
, SCM env
)
983 SCM all_labels
= SCM_EOL
;
985 /* Check, whether 'else is a literal, i. e. not bound to a value. */
986 const int else_literal_p
= literal_p (scm_sym_else
, env
);
988 const SCM cdr_expr
= SCM_CDR (expr
);
989 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
990 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_clauses
, expr
);
992 clauses
= SCM_CDR (cdr_expr
);
993 while (!scm_is_null (clauses
))
997 const SCM clause
= SCM_CAR (clauses
);
998 ASSERT_SYNTAX_2 (scm_ilength (clause
) >= 2,
999 s_bad_case_clause
, clause
, expr
);
1001 labels
= SCM_CAR (clause
);
1002 if (scm_is_pair (labels
))
1004 ASSERT_SYNTAX_2 (scm_ilength (labels
) >= 0,
1005 s_bad_case_labels
, labels
, expr
);
1006 all_labels
= scm_append (scm_list_2 (labels
, all_labels
));
1008 else if (scm_is_null (labels
))
1010 /* The list of labels is empty. According to R5RS this is allowed.
1011 * It means that the sequence of expressions will never be executed.
1012 * Therefore, as an optimization, we could remove the whole
1017 ASSERT_SYNTAX_2 (scm_is_eq (labels
, scm_sym_else
) && else_literal_p
,
1018 s_bad_case_labels
, labels
, expr
);
1019 ASSERT_SYNTAX_2 (scm_is_null (SCM_CDR (clauses
)),
1020 s_misplaced_else_clause
, clause
, expr
);
1023 /* build the new clause */
1024 if (scm_is_eq (labels
, scm_sym_else
))
1025 SCM_SETCAR (clause
, SCM_IM_ELSE
);
1027 clauses
= SCM_CDR (clauses
);
1030 /* Check whether all case labels are distinct. */
1031 for (; !scm_is_null (all_labels
); all_labels
= SCM_CDR (all_labels
))
1033 const SCM label
= SCM_CAR (all_labels
);
1034 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (label
, SCM_CDR (all_labels
))),
1035 s_duplicate_case_label
, label
, expr
);
1038 SCM_SETCAR (expr
, SCM_IM_CASE
);
1043 unmemoize_case (const SCM expr
, const SCM env
)
1045 const SCM um_key_expr
= unmemoize_expression (SCM_CADR (expr
), env
);
1046 SCM um_clauses
= SCM_EOL
;
1049 for (clause_idx
= SCM_CDDR (expr
);
1050 !scm_is_null (clause_idx
);
1051 clause_idx
= SCM_CDR (clause_idx
))
1053 const SCM clause
= SCM_CAR (clause_idx
);
1054 const SCM labels
= SCM_CAR (clause
);
1055 const SCM exprs
= SCM_CDR (clause
);
1057 const SCM um_exprs
= unmemoize_exprs (exprs
, env
);
1058 const SCM um_labels
= (scm_is_eq (labels
, SCM_IM_ELSE
))
1060 : scm_i_finite_list_copy (labels
);
1061 const SCM um_clause
= scm_cons (um_labels
, um_exprs
);
1063 um_clauses
= scm_cons (um_clause
, um_clauses
);
1065 um_clauses
= scm_reverse_x (um_clauses
, SCM_UNDEFINED
);
1067 return scm_cons2 (scm_sym_case
, um_key_expr
, um_clauses
);
1071 SCM_SYNTAX (s_cond
, "cond", scm_i_makbimacro
, scm_m_cond
);
1072 SCM_GLOBAL_SYMBOL (scm_sym_cond
, "cond");
1073 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
1076 scm_m_cond (SCM expr
, SCM env
)
1078 /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
1079 const int else_literal_p
= literal_p (scm_sym_else
, env
);
1080 const int arrow_literal_p
= literal_p (scm_sym_arrow
, env
);
1082 const SCM clauses
= SCM_CDR (expr
);
1085 ASSERT_SYNTAX (scm_ilength (clauses
) >= 0, s_bad_expression
, expr
);
1086 ASSERT_SYNTAX (scm_ilength (clauses
) >= 1, s_missing_clauses
, expr
);
1088 for (clause_idx
= clauses
;
1089 !scm_is_null (clause_idx
);
1090 clause_idx
= SCM_CDR (clause_idx
))
1094 const SCM clause
= SCM_CAR (clause_idx
);
1095 const long length
= scm_ilength (clause
);
1096 ASSERT_SYNTAX_2 (length
>= 1, s_bad_cond_clause
, clause
, expr
);
1098 test
= SCM_CAR (clause
);
1099 if (scm_is_eq (test
, scm_sym_else
) && else_literal_p
)
1101 const int last_clause_p
= scm_is_null (SCM_CDR (clause_idx
));
1102 ASSERT_SYNTAX_2 (length
>= 2,
1103 s_bad_cond_clause
, clause
, expr
);
1104 ASSERT_SYNTAX_2 (last_clause_p
,
1105 s_misplaced_else_clause
, clause
, expr
);
1106 SCM_SETCAR (clause
, SCM_IM_ELSE
);
1108 else if (length
>= 2
1109 && scm_is_eq (SCM_CADR (clause
), scm_sym_arrow
)
1112 ASSERT_SYNTAX_2 (length
> 2, s_missing_recipient
, clause
, expr
);
1113 ASSERT_SYNTAX_2 (length
== 3, s_extra_expression
, clause
, expr
);
1114 SCM_SETCAR (SCM_CDR (clause
), SCM_IM_ARROW
);
1116 /* SRFI 61 extended cond */
1117 else if (length
>= 3
1118 && scm_is_eq (SCM_CADDR (clause
), scm_sym_arrow
)
1121 ASSERT_SYNTAX_2 (length
> 3, s_missing_recipient
, clause
, expr
);
1122 ASSERT_SYNTAX_2 (length
== 4, s_extra_expression
, clause
, expr
);
1123 SCM_SETCAR (SCM_CDDR (clause
), SCM_IM_ARROW
);
1127 SCM_SETCAR (expr
, SCM_IM_COND
);
1132 unmemoize_cond (const SCM expr
, const SCM env
)
1134 SCM um_clauses
= SCM_EOL
;
1137 for (clause_idx
= SCM_CDR (expr
);
1138 !scm_is_null (clause_idx
);
1139 clause_idx
= SCM_CDR (clause_idx
))
1141 const SCM clause
= SCM_CAR (clause_idx
);
1142 const SCM sequence
= SCM_CDR (clause
);
1143 const SCM test
= SCM_CAR (clause
);
1148 if (scm_is_eq (test
, SCM_IM_ELSE
))
1149 um_test
= scm_sym_else
;
1151 um_test
= unmemoize_expression (test
, env
);
1153 if (!scm_is_null (sequence
) && scm_is_eq (SCM_CAR (sequence
),
1156 const SCM target
= SCM_CADR (sequence
);
1157 const SCM um_target
= unmemoize_expression (target
, env
);
1158 um_sequence
= scm_list_2 (scm_sym_arrow
, um_target
);
1162 um_sequence
= unmemoize_exprs (sequence
, env
);
1165 um_clause
= scm_cons (um_test
, um_sequence
);
1166 um_clauses
= scm_cons (um_clause
, um_clauses
);
1168 um_clauses
= scm_reverse_x (um_clauses
, SCM_UNDEFINED
);
1170 return scm_cons (scm_sym_cond
, um_clauses
);
1174 SCM_SYNTAX (s_define
, "define", scm_i_makbimacro
, scm_m_define
);
1175 SCM_GLOBAL_SYMBOL (scm_sym_define
, "define");
1177 /* Guile provides an extension to R5RS' define syntax to represent function
1178 * currying in a compact way. With this extension, it is allowed to write
1179 * (define <nested-variable> <body>), where <nested-variable> has of one of
1180 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
1181 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
1182 * should be either a sequence of zero or more variables, or a sequence of one
1183 * or more variables followed by a space-delimited period and another
1184 * variable. Each level of argument nesting wraps the <body> within another
1185 * lambda expression. For example, the following forms are allowed, each one
1186 * followed by an equivalent, more explicit implementation.
1188 * (define ((a b . c) . d) <body>) is equivalent to
1189 * (define a (lambda (b . c) (lambda d <body>)))
1191 * (define (((a) b) c . d) <body>) is equivalent to
1192 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
1194 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
1195 * module that does not implement this extension. */
1197 canonicalize_define (const SCM expr
)
1202 const SCM cdr_expr
= SCM_CDR (expr
);
1203 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1204 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1206 body
= SCM_CDR (cdr_expr
);
1207 variable
= SCM_CAR (cdr_expr
);
1208 while (scm_is_pair (variable
))
1210 /* This while loop realizes function currying by variable nesting.
1211 * Variable is known to be a nested-variable. In every iteration of the
1212 * loop another level of lambda expression is created, starting with the
1213 * innermost one. Note that we don't check for duplicate formals here:
1214 * This will be done by the memoizer of the lambda expression. */
1215 const SCM formals
= SCM_CDR (variable
);
1216 const SCM tail
= scm_cons (formals
, body
);
1218 /* Add source properties to each new lambda expression: */
1219 const SCM lambda
= scm_cons_source (variable
, scm_sym_lambda
, tail
);
1221 body
= scm_list_1 (lambda
);
1222 variable
= SCM_CAR (variable
);
1224 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
1225 ASSERT_SYNTAX (scm_ilength (body
) == 1, s_expression
, expr
);
1227 SCM_SETCAR (cdr_expr
, variable
);
1228 SCM_SETCDR (cdr_expr
, body
);
1232 /* According to Section 5.2.1 of R5RS we first have to make sure that the
1233 variable is bound, and then perform the `(set! variable expression)'
1234 operation. However, EXPRESSION _can_ be evaluated before VARIABLE is
1235 bound. This means that EXPRESSION won't necessarily be able to assign
1236 values to VARIABLE as in `(define foo (begin (set! foo 1) (+ foo 1)))'. */
1238 scm_m_define (SCM expr
, SCM env
)
1240 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), s_bad_define
, expr
);
1243 const SCM canonical_definition
= canonicalize_define (expr
);
1244 const SCM cdr_canonical_definition
= SCM_CDR (canonical_definition
);
1245 const SCM variable
= SCM_CAR (cdr_canonical_definition
);
1246 const SCM value
= scm_eval_car (SCM_CDR (cdr_canonical_definition
), env
);
1248 = scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_T
);
1250 if (SCM_REC_PROCNAMES_P
)
1253 while (SCM_MACROP (tmp
))
1254 tmp
= SCM_MACRO_CODE (tmp
);
1255 if (scm_is_true (scm_procedure_p (tmp
))
1256 /* Only the first definition determines the name. */
1257 && scm_is_false (scm_procedure_property (tmp
, scm_sym_name
)))
1258 scm_set_procedure_property_x (tmp
, scm_sym_name
, variable
);
1261 SCM_VARIABLE_SET (location
, value
);
1263 return SCM_UNSPECIFIED
;
1268 /* This is a helper function for forms (<keyword> <expression>) that are
1269 * transformed into (#@<keyword> '() <memoized_expression>) in order to allow
1270 * for easy creation of a thunk (i. e. a closure without arguments) using the
1271 * ('() <memoized_expression>) tail of the memoized form. */
1273 memoize_as_thunk_prototype (const SCM expr
, const SCM env SCM_UNUSED
)
1275 const SCM cdr_expr
= SCM_CDR (expr
);
1276 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1277 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1279 SCM_SETCDR (expr
, scm_cons (SCM_EOL
, cdr_expr
));
1285 SCM_SYNTAX (s_delay
, "delay", scm_i_makbimacro
, scm_m_delay
);
1286 SCM_GLOBAL_SYMBOL (scm_sym_delay
, "delay");
1288 /* Promises are implemented as closures with an empty parameter list. Thus,
1289 * (delay <expression>) is transformed into (#@delay '() <expression>), where
1290 * the empty list represents the empty parameter list. This representation
1291 * allows for easy creation of the closure during evaluation. */
1293 scm_m_delay (SCM expr
, SCM env
)
1295 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1296 SCM_SETCAR (new_expr
, SCM_IM_DELAY
);
1301 unmemoize_delay (const SCM expr
, const SCM env
)
1303 const SCM thunk_expr
= SCM_CADDR (expr
);
1304 /* A promise is implemented as a closure, and when applying a
1305 closure the evaluator adds a new frame to the environment - even
1306 though, in the case of a promise, the added frame is always
1307 empty. We need to extend the environment here in the same way,
1308 so that any ILOCs in thunk_expr can be unmemoized correctly. */
1309 const SCM new_env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1310 return scm_list_2 (scm_sym_delay
, unmemoize_expression (thunk_expr
, new_env
));
1314 SCM_SYNTAX(s_do
, "do", scm_i_makbimacro
, scm_m_do
);
1315 SCM_GLOBAL_SYMBOL(scm_sym_do
, "do");
1317 /* DO gets the most radically altered syntax. The order of the vars is
1318 * reversed here. During the evaluation this allows for simple consing of the
1319 * results of the inits and steps:
1321 (do ((<var1> <init1> <step1>)
1329 (#@do (<init1> <init2> ... <initn>)
1330 (varn ... var2 var1)
1333 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
1336 scm_m_do (SCM expr
, SCM env SCM_UNUSED
)
1338 SCM variables
= SCM_EOL
;
1339 SCM init_forms
= SCM_EOL
;
1340 SCM step_forms
= SCM_EOL
;
1347 const SCM cdr_expr
= SCM_CDR (expr
);
1348 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1349 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1351 /* Collect variables, init and step forms. */
1352 binding_idx
= SCM_CAR (cdr_expr
);
1353 ASSERT_SYNTAX_2 (scm_ilength (binding_idx
) >= 0,
1354 s_bad_bindings
, binding_idx
, expr
);
1355 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1357 const SCM binding
= SCM_CAR (binding_idx
);
1358 const long length
= scm_ilength (binding
);
1359 ASSERT_SYNTAX_2 (length
== 2 || length
== 3,
1360 s_bad_binding
, binding
, expr
);
1363 const SCM name
= SCM_CAR (binding
);
1364 const SCM init
= SCM_CADR (binding
);
1365 const SCM step
= (length
== 2) ? name
: SCM_CADDR (binding
);
1366 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
1367 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, variables
)),
1368 s_duplicate_binding
, name
, expr
);
1370 variables
= scm_cons (name
, variables
);
1371 init_forms
= scm_cons (init
, init_forms
);
1372 step_forms
= scm_cons (step
, step_forms
);
1375 init_forms
= scm_reverse_x (init_forms
, SCM_UNDEFINED
);
1376 step_forms
= scm_reverse_x (step_forms
, SCM_UNDEFINED
);
1378 /* Memoize the test form and the exit sequence. */
1379 cddr_expr
= SCM_CDR (cdr_expr
);
1380 exit_clause
= SCM_CAR (cddr_expr
);
1381 ASSERT_SYNTAX_2 (scm_ilength (exit_clause
) >= 1,
1382 s_bad_exit_clause
, exit_clause
, expr
);
1384 commands
= SCM_CDR (cddr_expr
);
1385 tail
= scm_cons2 (exit_clause
, commands
, step_forms
);
1386 tail
= scm_cons2 (init_forms
, variables
, tail
);
1387 SCM_SETCAR (expr
, SCM_IM_DO
);
1388 SCM_SETCDR (expr
, tail
);
1393 unmemoize_do (const SCM expr
, const SCM env
)
1395 const SCM cdr_expr
= SCM_CDR (expr
);
1396 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1397 const SCM rnames
= SCM_CAR (cddr_expr
);
1398 const SCM extended_env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
1399 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
1400 const SCM exit_sequence
= SCM_CAR (cdddr_expr
);
1401 const SCM um_exit_sequence
= unmemoize_exprs (exit_sequence
, extended_env
);
1402 const SCM cddddr_expr
= SCM_CDR (cdddr_expr
);
1403 const SCM um_body
= unmemoize_exprs (SCM_CAR (cddddr_expr
), extended_env
);
1405 /* build transformed binding list */
1406 SCM um_names
= scm_reverse (rnames
);
1407 SCM um_inits
= unmemoize_exprs (SCM_CAR (cdr_expr
), env
);
1408 SCM um_steps
= unmemoize_exprs (SCM_CDR (cddddr_expr
), extended_env
);
1409 SCM um_bindings
= SCM_EOL
;
1410 while (!scm_is_null (um_names
))
1412 const SCM name
= SCM_CAR (um_names
);
1413 const SCM init
= SCM_CAR (um_inits
);
1414 SCM step
= SCM_CAR (um_steps
);
1415 step
= scm_is_eq (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
1417 um_bindings
= scm_cons (scm_cons2 (name
, init
, step
), um_bindings
);
1419 um_names
= SCM_CDR (um_names
);
1420 um_inits
= SCM_CDR (um_inits
);
1421 um_steps
= SCM_CDR (um_steps
);
1423 um_bindings
= scm_reverse_x (um_bindings
, SCM_UNDEFINED
);
1425 return scm_cons (scm_sym_do
,
1426 scm_cons2 (um_bindings
, um_exit_sequence
, um_body
));
1430 SCM_SYNTAX (s_if
, "if", scm_i_makbimacro
, scm_m_if
);
1431 SCM_GLOBAL_SYMBOL (scm_sym_if
, "if");
1434 scm_m_if (SCM expr
, SCM env SCM_UNUSED
)
1436 const SCM cdr_expr
= SCM_CDR (expr
);
1437 const long length
= scm_ilength (cdr_expr
);
1438 ASSERT_SYNTAX (length
== 2 || length
== 3, s_expression
, expr
);
1439 SCM_SETCAR (expr
, SCM_IM_IF
);
1444 unmemoize_if (const SCM expr
, const SCM env
)
1446 const SCM cdr_expr
= SCM_CDR (expr
);
1447 const SCM um_condition
= unmemoize_expression (SCM_CAR (cdr_expr
), env
);
1448 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1449 const SCM um_then
= unmemoize_expression (SCM_CAR (cddr_expr
), env
);
1450 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
1452 if (scm_is_null (cdddr_expr
))
1454 return scm_list_3 (scm_sym_if
, um_condition
, um_then
);
1458 const SCM um_else
= unmemoize_expression (SCM_CAR (cdddr_expr
), env
);
1459 return scm_list_4 (scm_sym_if
, um_condition
, um_then
, um_else
);
1464 SCM_SYNTAX (s_lambda
, "lambda", scm_i_makbimacro
, scm_m_lambda
);
1465 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, "lambda");
1467 /* A helper function for memoize_lambda to support checking for duplicate
1468 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
1469 * LIST or to the cdr of the last cons. Therefore, LIST may have any of the
1470 * forms that a formal argument can have:
1471 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
1473 c_improper_memq (SCM obj
, SCM list
)
1475 for (; scm_is_pair (list
); list
= SCM_CDR (list
))
1477 if (scm_is_eq (SCM_CAR (list
), obj
))
1480 return scm_is_eq (list
, obj
);
1484 scm_m_lambda (SCM expr
, SCM env SCM_UNUSED
)
1493 const SCM cdr_expr
= SCM_CDR (expr
);
1494 const long length
= scm_ilength (cdr_expr
);
1495 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1496 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1498 /* Before iterating the list of formal arguments, make sure the formals
1499 * actually are given as either a symbol or a non-cyclic list. */
1500 formals
= SCM_CAR (cdr_expr
);
1501 if (scm_is_pair (formals
))
1503 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
1504 * detected, report a 'Bad formals' error. */
1508 ASSERT_SYNTAX_2 (scm_is_symbol (formals
) || scm_is_null (formals
),
1509 s_bad_formals
, formals
, expr
);
1512 /* Now iterate the list of formal arguments to check if all formals are
1513 * symbols, and that there are no duplicates. */
1514 formals_idx
= formals
;
1515 while (scm_is_pair (formals_idx
))
1517 const SCM formal
= SCM_CAR (formals_idx
);
1518 const SCM next_idx
= SCM_CDR (formals_idx
);
1519 ASSERT_SYNTAX_2 (scm_is_symbol (formal
), s_bad_formal
, formal
, expr
);
1520 ASSERT_SYNTAX_2 (!c_improper_memq (formal
, next_idx
),
1521 s_duplicate_formal
, formal
, expr
);
1522 formals_idx
= next_idx
;
1524 ASSERT_SYNTAX_2 (scm_is_null (formals_idx
) || scm_is_symbol (formals_idx
),
1525 s_bad_formal
, formals_idx
, expr
);
1527 /* Memoize the body. Keep a potential documentation string. */
1528 /* Dirk:FIXME:: We should probably extract the documentation string to
1529 * some external database. Otherwise it will slow down execution, since
1530 * the documentation string will have to be skipped with every execution
1531 * of the closure. */
1532 cddr_expr
= SCM_CDR (cdr_expr
);
1533 documentation
= (length
>= 3 && scm_is_string (SCM_CAR (cddr_expr
)));
1534 body
= documentation
? SCM_CDR (cddr_expr
) : cddr_expr
;
1535 new_body
= m_body (SCM_IM_LAMBDA
, body
);
1537 SCM_SETCAR (expr
, SCM_IM_LAMBDA
);
1539 SCM_SETCDR (cddr_expr
, new_body
);
1541 SCM_SETCDR (cdr_expr
, new_body
);
1546 unmemoize_lambda (const SCM expr
, const SCM env
)
1548 const SCM formals
= SCM_CADR (expr
);
1549 const SCM body
= SCM_CDDR (expr
);
1551 const SCM new_env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, env
);
1552 const SCM um_formals
= scm_i_finite_list_copy (formals
);
1553 const SCM um_body
= unmemoize_exprs (body
, new_env
);
1555 return scm_cons2 (scm_sym_lambda
, um_formals
, um_body
);
1559 /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
1561 check_bindings (const SCM bindings
, const SCM expr
)
1565 ASSERT_SYNTAX_2 (scm_ilength (bindings
) >= 0,
1566 s_bad_bindings
, bindings
, expr
);
1568 binding_idx
= bindings
;
1569 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1571 SCM name
; /* const */
1573 const SCM binding
= SCM_CAR (binding_idx
);
1574 ASSERT_SYNTAX_2 (scm_ilength (binding
) == 2,
1575 s_bad_binding
, binding
, expr
);
1577 name
= SCM_CAR (binding
);
1578 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
1583 /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
1584 * transformed to the lists (vn ... v2 v1) and (i1 i2 ... in). That is, the
1585 * variables are returned in a list with their order reversed, and the init
1586 * forms are returned in a list in the same order as they are given in the
1587 * bindings. If a duplicate variable name is detected, an error is
1590 transform_bindings (
1591 const SCM bindings
, const SCM expr
,
1592 SCM
*const rvarptr
, SCM
*const initptr
)
1594 SCM rvariables
= SCM_EOL
;
1595 SCM rinits
= SCM_EOL
;
1596 SCM binding_idx
= bindings
;
1597 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1599 const SCM binding
= SCM_CAR (binding_idx
);
1600 const SCM cdr_binding
= SCM_CDR (binding
);
1601 const SCM name
= SCM_CAR (binding
);
1602 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, rvariables
)),
1603 s_duplicate_binding
, name
, expr
);
1604 rvariables
= scm_cons (name
, rvariables
);
1605 rinits
= scm_cons (SCM_CAR (cdr_binding
), rinits
);
1607 *rvarptr
= rvariables
;
1608 *initptr
= scm_reverse_x (rinits
, SCM_UNDEFINED
);
1612 SCM_SYNTAX(s_let
, "let", scm_i_makbimacro
, scm_m_let
);
1613 SCM_GLOBAL_SYMBOL(scm_sym_let
, "let");
1615 /* This function is a helper function for memoize_let. It transforms
1616 * (let name ((var init) ...) body ...) into
1617 * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
1618 * and memoizes the expression. It is assumed that the caller has checked
1619 * that name is a symbol and that there are bindings and a body. */
1621 memoize_named_let (const SCM expr
, const SCM env SCM_UNUSED
)
1627 const SCM cdr_expr
= SCM_CDR (expr
);
1628 const SCM name
= SCM_CAR (cdr_expr
);
1629 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1630 const SCM bindings
= SCM_CAR (cddr_expr
);
1631 check_bindings (bindings
, expr
);
1633 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1634 variables
= scm_reverse_x (rvariables
, SCM_UNDEFINED
);
1637 const SCM let_body
= SCM_CDR (cddr_expr
);
1638 const SCM lambda_body
= m_body (SCM_IM_LET
, let_body
);
1639 const SCM lambda_tail
= scm_cons (variables
, lambda_body
);
1640 const SCM lambda_form
= scm_cons_source (expr
, scm_sym_lambda
, lambda_tail
);
1642 const SCM rvar
= scm_list_1 (name
);
1643 const SCM init
= scm_list_1 (lambda_form
);
1644 const SCM body
= m_body (SCM_IM_LET
, scm_list_1 (name
));
1645 const SCM letrec_tail
= scm_cons (rvar
, scm_cons (init
, body
));
1646 const SCM letrec_form
= scm_cons_source (expr
, SCM_IM_LETREC
, letrec_tail
);
1647 return scm_cons_source (expr
, letrec_form
, inits
);
1651 /* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1652 * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
1654 scm_m_let (SCM expr
, SCM env
)
1658 const SCM cdr_expr
= SCM_CDR (expr
);
1659 const long length
= scm_ilength (cdr_expr
);
1660 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1661 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1663 bindings
= SCM_CAR (cdr_expr
);
1664 if (scm_is_symbol (bindings
))
1666 ASSERT_SYNTAX (length
>= 3, s_missing_expression
, expr
);
1667 return memoize_named_let (expr
, env
);
1670 check_bindings (bindings
, expr
);
1671 if (scm_is_null (bindings
) || scm_is_null (SCM_CDR (bindings
)))
1673 /* Special case: no bindings or single binding => let* is faster. */
1674 const SCM body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1675 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), bindings
, body
), env
);
1682 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1685 const SCM new_body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1686 const SCM new_tail
= scm_cons2 (rvariables
, inits
, new_body
);
1687 SCM_SETCAR (expr
, SCM_IM_LET
);
1688 SCM_SETCDR (expr
, new_tail
);
1695 build_binding_list (SCM rnames
, SCM rinits
)
1697 SCM bindings
= SCM_EOL
;
1698 while (!scm_is_null (rnames
))
1700 const SCM binding
= scm_list_2 (SCM_CAR (rnames
), SCM_CAR (rinits
));
1701 bindings
= scm_cons (binding
, bindings
);
1702 rnames
= SCM_CDR (rnames
);
1703 rinits
= SCM_CDR (rinits
);
1709 unmemoize_let (const SCM expr
, const SCM env
)
1711 const SCM cdr_expr
= SCM_CDR (expr
);
1712 const SCM um_rnames
= SCM_CAR (cdr_expr
);
1713 const SCM extended_env
= SCM_EXTEND_ENV (um_rnames
, SCM_EOL
, env
);
1714 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1715 const SCM um_inits
= unmemoize_exprs (SCM_CAR (cddr_expr
), env
);
1716 const SCM um_rinits
= scm_reverse_x (um_inits
, SCM_UNDEFINED
);
1717 const SCM um_bindings
= build_binding_list (um_rnames
, um_rinits
);
1718 const SCM um_body
= unmemoize_exprs (SCM_CDR (cddr_expr
), extended_env
);
1720 return scm_cons2 (scm_sym_let
, um_bindings
, um_body
);
1724 SCM_SYNTAX(s_letrec
, "letrec", scm_i_makbimacro
, scm_m_letrec
);
1725 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, "letrec");
1728 scm_m_letrec (SCM expr
, SCM env
)
1732 const SCM cdr_expr
= SCM_CDR (expr
);
1733 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1734 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1736 bindings
= SCM_CAR (cdr_expr
);
1737 if (scm_is_null (bindings
))
1739 /* no bindings, let* is executed faster */
1740 SCM body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1741 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), SCM_EOL
, body
), env
);
1749 check_bindings (bindings
, expr
);
1750 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1751 new_body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1752 return scm_cons2 (SCM_IM_LETREC
, rvariables
, scm_cons (inits
, new_body
));
1757 unmemoize_letrec (const SCM expr
, const SCM env
)
1759 const SCM cdr_expr
= SCM_CDR (expr
);
1760 const SCM um_rnames
= SCM_CAR (cdr_expr
);
1761 const SCM extended_env
= SCM_EXTEND_ENV (um_rnames
, SCM_EOL
, env
);
1762 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1763 const SCM um_inits
= unmemoize_exprs (SCM_CAR (cddr_expr
), extended_env
);
1764 const SCM um_rinits
= scm_reverse_x (um_inits
, SCM_UNDEFINED
);
1765 const SCM um_bindings
= build_binding_list (um_rnames
, um_rinits
);
1766 const SCM um_body
= unmemoize_exprs (SCM_CDR (cddr_expr
), extended_env
);
1768 return scm_cons2 (scm_sym_letrec
, um_bindings
, um_body
);
1773 SCM_SYNTAX (s_letstar
, "let*", scm_i_makbimacro
, scm_m_letstar
);
1774 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, "let*");
1776 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1777 * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
1779 scm_m_letstar (SCM expr
, SCM env SCM_UNUSED
)
1784 const SCM cdr_expr
= SCM_CDR (expr
);
1785 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1786 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1788 binding_idx
= SCM_CAR (cdr_expr
);
1789 check_bindings (binding_idx
, expr
);
1791 /* Transform ((v1 i1) (v2 i2) ...) into (v1 i1 v2 i2 ...). The
1792 * transformation is done in place. At the beginning of one iteration of
1793 * the loop the variable binding_idx holds the form
1794 * P1:( (vn . P2:(in . ())) . P3:( (vn+1 in+1) ... ) ),
1795 * where P1, P2 and P3 indicate the pairs, that are relevant for the
1796 * transformation. P1 and P2 are modified in the loop, P3 remains
1797 * untouched. After the execution of the loop, P1 will hold
1798 * P1:( vn . P2:(in . P3:( (vn+1 in+1) ... )) )
1799 * and binding_idx will hold P3. */
1800 while (!scm_is_null (binding_idx
))
1802 const SCM cdr_binding_idx
= SCM_CDR (binding_idx
); /* remember P3 */
1803 const SCM binding
= SCM_CAR (binding_idx
);
1804 const SCM name
= SCM_CAR (binding
);
1805 const SCM cdr_binding
= SCM_CDR (binding
);
1807 SCM_SETCDR (cdr_binding
, cdr_binding_idx
); /* update P2 */
1808 SCM_SETCAR (binding_idx
, name
); /* update P1 */
1809 SCM_SETCDR (binding_idx
, cdr_binding
); /* update P1 */
1811 binding_idx
= cdr_binding_idx
; /* continue with P3 */
1814 new_body
= m_body (SCM_IM_LETSTAR
, SCM_CDR (cdr_expr
));
1815 SCM_SETCAR (expr
, SCM_IM_LETSTAR
);
1816 /* the bindings have been changed in place */
1817 SCM_SETCDR (cdr_expr
, new_body
);
1822 unmemoize_letstar (const SCM expr
, const SCM env
)
1824 const SCM cdr_expr
= SCM_CDR (expr
);
1825 const SCM body
= SCM_CDR (cdr_expr
);
1826 SCM bindings
= SCM_CAR (cdr_expr
);
1827 SCM um_bindings
= SCM_EOL
;
1828 SCM extended_env
= env
;
1831 while (!scm_is_null (bindings
))
1833 const SCM variable
= SCM_CAR (bindings
);
1834 const SCM init
= SCM_CADR (bindings
);
1835 const SCM um_init
= unmemoize_expression (init
, extended_env
);
1836 um_bindings
= scm_cons (scm_list_2 (variable
, um_init
), um_bindings
);
1837 extended_env
= SCM_EXTEND_ENV (variable
, SCM_BOOL_F
, extended_env
);
1838 bindings
= SCM_CDDR (bindings
);
1840 um_bindings
= scm_reverse_x (um_bindings
, SCM_UNDEFINED
);
1842 um_body
= unmemoize_exprs (body
, extended_env
);
1844 return scm_cons2 (scm_sym_letstar
, um_bindings
, um_body
);
1848 SCM_SYNTAX (s_or
, "or", scm_i_makbimacro
, scm_m_or
);
1849 SCM_GLOBAL_SYMBOL (scm_sym_or
, "or");
1852 scm_m_or (SCM expr
, SCM env SCM_UNUSED
)
1854 const SCM cdr_expr
= SCM_CDR (expr
);
1855 const long length
= scm_ilength (cdr_expr
);
1857 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1861 /* Special case: (or) is replaced by #f. */
1866 SCM_SETCAR (expr
, SCM_IM_OR
);
1872 unmemoize_or (const SCM expr
, const SCM env
)
1874 return scm_cons (scm_sym_or
, unmemoize_exprs (SCM_CDR (expr
), env
));
1878 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
1879 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, "quasiquote");
1880 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
1881 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
1883 /* Internal function to handle a quasiquotation: 'form' is the parameter in
1884 * the call (quasiquotation form), 'env' is the environment where unquoted
1885 * expressions will be evaluated, and 'depth' is the current quasiquotation
1886 * nesting level and is known to be greater than zero. */
1888 iqq (SCM form
, SCM env
, unsigned long int depth
)
1890 if (scm_is_pair (form
))
1892 const SCM tmp
= SCM_CAR (form
);
1893 if (scm_is_eq (tmp
, scm_sym_quasiquote
))
1895 const SCM args
= SCM_CDR (form
);
1896 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1897 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
1899 else if (scm_is_eq (tmp
, scm_sym_unquote
))
1901 const SCM args
= SCM_CDR (form
);
1902 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1904 return scm_eval_car (args
, env
);
1906 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
1908 else if (scm_is_pair (tmp
)
1909 && scm_is_eq (SCM_CAR (tmp
), scm_sym_uq_splicing
))
1911 const SCM args
= SCM_CDR (tmp
);
1912 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1915 const SCM list
= scm_eval_car (args
, env
);
1916 const SCM rest
= SCM_CDR (form
);
1917 ASSERT_SYNTAX_2 (scm_ilength (list
) >= 0,
1918 s_splicing
, list
, form
);
1919 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
1922 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
1923 iqq (SCM_CDR (form
), env
, depth
));
1926 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
1927 iqq (SCM_CDR (form
), env
, depth
));
1929 else if (scm_is_vector (form
))
1930 return scm_vector (iqq (scm_vector_to_list (form
), env
, depth
));
1936 scm_m_quasiquote (SCM expr
, SCM env
)
1938 const SCM cdr_expr
= SCM_CDR (expr
);
1939 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1940 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1941 return iqq (SCM_CAR (cdr_expr
), env
, 1);
1945 SCM_SYNTAX (s_quote
, "quote", scm_i_makbimacro
, scm_m_quote
);
1946 SCM_GLOBAL_SYMBOL (scm_sym_quote
, "quote");
1949 scm_m_quote (SCM expr
, SCM env SCM_UNUSED
)
1953 const SCM cdr_expr
= SCM_CDR (expr
);
1954 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1955 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1956 quotee
= SCM_CAR (cdr_expr
);
1957 if (is_self_quoting_p (quotee
))
1960 SCM_SETCAR (expr
, SCM_IM_QUOTE
);
1961 SCM_SETCDR (expr
, quotee
);
1966 unmemoize_quote (const SCM expr
, const SCM env SCM_UNUSED
)
1968 return scm_list_2 (scm_sym_quote
, SCM_CDR (expr
));
1972 /* Will go into the RnRS module when Guile is factorized.
1973 SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
1974 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, "set!");
1977 scm_m_set_x (SCM expr
, SCM env SCM_UNUSED
)
1982 const SCM cdr_expr
= SCM_CDR (expr
);
1983 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1984 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1985 variable
= SCM_CAR (cdr_expr
);
1987 /* Memoize the variable form. */
1988 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
1989 new_variable
= lookup_symbol (variable
, env
);
1990 /* Leave the memoization of unbound symbols to lazy memoization: */
1991 if (SCM_UNBNDP (new_variable
))
1992 new_variable
= variable
;
1994 SCM_SETCAR (expr
, SCM_IM_SET_X
);
1995 SCM_SETCAR (cdr_expr
, new_variable
);
2000 unmemoize_set_x (const SCM expr
, const SCM env
)
2002 return scm_cons (scm_sym_set_x
, unmemoize_exprs (SCM_CDR (expr
), env
));
2007 /* Start of the memoizers for non-R5RS builtin macros. */
2010 SCM_SYNTAX (s_at
, "@", scm_makmmacro
, scm_m_at
);
2011 SCM_GLOBAL_SYMBOL (scm_sym_at
, "@");
2014 scm_m_at (SCM expr
, SCM env SCM_UNUSED
)
2017 ASSERT_SYNTAX (scm_ilength (expr
) == 3, s_bad_expression
, expr
);
2018 ASSERT_SYNTAX (scm_ilength (scm_cadr (expr
)) > 0, s_bad_expression
, expr
);
2019 ASSERT_SYNTAX (scm_is_symbol (scm_caddr (expr
)), s_bad_expression
, expr
);
2021 mod
= scm_resolve_module (scm_cadr (expr
));
2022 if (scm_is_false (mod
))
2023 error_unbound_variable (expr
);
2024 var
= scm_module_variable (scm_module_public_interface (mod
), scm_caddr (expr
));
2025 if (scm_is_false (var
))
2026 error_unbound_variable (expr
);
2031 SCM_SYNTAX (s_atat
, "@@", scm_makmmacro
, scm_m_atat
);
2032 SCM_GLOBAL_SYMBOL (scm_sym_atat
, "@@");
2035 scm_m_atat (SCM expr
, SCM env SCM_UNUSED
)
2038 ASSERT_SYNTAX (scm_ilength (expr
) == 3, s_bad_expression
, expr
);
2039 ASSERT_SYNTAX (scm_ilength (scm_cadr (expr
)) > 0, s_bad_expression
, expr
);
2040 ASSERT_SYNTAX (scm_is_symbol (scm_caddr (expr
)), s_bad_expression
, expr
);
2042 mod
= scm_resolve_module (scm_cadr (expr
));
2043 if (scm_is_false (mod
))
2044 error_unbound_variable (expr
);
2045 var
= scm_module_variable (mod
, scm_caddr (expr
));
2046 if (scm_is_false (var
))
2047 error_unbound_variable (expr
);
2052 SCM_SYNTAX (s_atapply
, "@apply", scm_i_makbimacro
, scm_m_apply
);
2053 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, "@apply");
2054 SCM_GLOBAL_SYMBOL (scm_sym_apply
, "apply");
2057 scm_m_apply (SCM expr
, SCM env SCM_UNUSED
)
2059 const SCM cdr_expr
= SCM_CDR (expr
);
2060 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2061 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_missing_expression
, expr
);
2063 SCM_SETCAR (expr
, SCM_IM_APPLY
);
2068 unmemoize_apply (const SCM expr
, const SCM env
)
2070 return scm_list_2 (scm_sym_atapply
, unmemoize_exprs (SCM_CDR (expr
), env
));
2074 SCM_SYNTAX (s_atbind
, "@bind", scm_i_makbimacro
, scm_m_atbind
);
2076 /* FIXME: The following explanation should go into the documentation: */
2077 /* (@bind ((var init) ...) body ...) will assign the values of the `init's to
2078 * the global variables named by `var's (symbols, not evaluated), creating
2079 * them if they don't exist, executes body, and then restores the previous
2080 * values of the `var's. Additionally, whenever control leaves body, the
2081 * values of the `var's are saved and restored when control returns. It is an
2082 * error when a symbol appears more than once among the `var's. All `init's
2083 * are evaluated before any `var' is set.
2085 * Think of this as `let' for dynamic scope.
2088 /* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into
2089 * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...).
2091 * FIXME - also implement `@bind*'.
2094 scm_m_atbind (SCM expr
, SCM env
)
2101 const SCM top_level
= scm_env_top_level (env
);
2103 const SCM cdr_expr
= SCM_CDR (expr
);
2104 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2105 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
2106 bindings
= SCM_CAR (cdr_expr
);
2107 check_bindings (bindings
, expr
);
2108 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
2110 for (variable_idx
= rvariables
;
2111 !scm_is_null (variable_idx
);
2112 variable_idx
= SCM_CDR (variable_idx
))
2114 /* The first call to scm_sym2var will look beyond the current module,
2115 * while the second call wont. */
2116 const SCM variable
= SCM_CAR (variable_idx
);
2117 SCM new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_F
);
2118 if (scm_is_false (new_variable
))
2119 new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_T
);
2120 SCM_SETCAR (variable_idx
, new_variable
);
2123 SCM_SETCAR (expr
, SCM_IM_BIND
);
2124 SCM_SETCAR (cdr_expr
, scm_cons (rvariables
, inits
));
2129 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_i_makbimacro
, scm_m_cont
);
2130 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, "@call-with-current-continuation");
2133 scm_m_cont (SCM expr
, SCM env SCM_UNUSED
)
2135 const SCM cdr_expr
= SCM_CDR (expr
);
2136 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2137 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2139 SCM_SETCAR (expr
, SCM_IM_CONT
);
2144 unmemoize_atcall_cc (const SCM expr
, const SCM env
)
2146 return scm_list_2 (scm_sym_atcall_cc
, unmemoize_exprs (SCM_CDR (expr
), env
));
2150 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_i_makbimacro
, scm_m_at_call_with_values
);
2151 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, "@call-with-values");
2154 scm_m_at_call_with_values (SCM expr
, SCM env SCM_UNUSED
)
2156 const SCM cdr_expr
= SCM_CDR (expr
);
2157 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2158 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2160 SCM_SETCAR (expr
, SCM_IM_CALL_WITH_VALUES
);
2165 unmemoize_at_call_with_values (const SCM expr
, const SCM env
)
2167 return scm_list_2 (scm_sym_at_call_with_values
,
2168 unmemoize_exprs (SCM_CDR (expr
), env
));
2171 SCM_SYNTAX (s_eval_when
, "eval-when", scm_makmmacro
, scm_m_eval_when
);
2172 SCM_GLOBAL_SYMBOL (scm_sym_eval_when
, "eval-when");
2173 SCM_SYMBOL (sym_eval
, "eval");
2174 SCM_SYMBOL (sym_load
, "load");
2178 scm_m_eval_when (SCM expr
, SCM env SCM_UNUSED
)
2180 ASSERT_SYNTAX (scm_ilength (expr
) >= 3, s_bad_expression
, expr
);
2181 ASSERT_SYNTAX (scm_ilength (scm_cadr (expr
)) > 0, s_bad_expression
, expr
);
2183 if (scm_is_true (scm_memq (sym_eval
, scm_cadr (expr
)))
2184 || scm_is_true (scm_memq (sym_load
, scm_cadr (expr
))))
2185 return scm_cons (SCM_IM_BEGIN
, scm_cddr (expr
));
2187 return scm_list_1 (SCM_IM_BEGIN
);
2190 SCM_SYNTAX (s_gset_x
, "set!", scm_i_makbimacro
, scm_m_generalized_set_x
);
2191 SCM_SYMBOL (scm_sym_setter
, "setter");
2194 scm_m_generalized_set_x (SCM expr
, SCM env
)
2196 SCM target
, exp_target
;
2198 const SCM cdr_expr
= SCM_CDR (expr
);
2199 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2200 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2202 target
= SCM_CAR (cdr_expr
);
2203 if (!scm_is_pair (target
))
2206 return scm_m_set_x (expr
, env
);
2210 /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */
2211 /* Macroexpanding the target might return things of the form
2212 (begin <atom>). In that case, <atom> must be a symbol or a
2213 variable and we memoize to (set! <atom> ...).
2215 exp_target
= macroexp (target
, env
);
2216 if (scm_is_eq (SCM_CAR (exp_target
), SCM_IM_BEGIN
)
2217 && !scm_is_null (SCM_CDR (exp_target
))
2218 && scm_is_null (SCM_CDDR (exp_target
)))
2220 exp_target
= SCM_CADR (exp_target
);
2221 ASSERT_SYNTAX_2 (scm_is_symbol (exp_target
)
2222 || SCM_VARIABLEP (exp_target
),
2223 s_bad_variable
, exp_target
, expr
);
2224 return scm_cons (SCM_IM_SET_X
, scm_cons (exp_target
,
2225 SCM_CDR (cdr_expr
)));
2229 const SCM setter_proc_tail
= scm_list_1 (SCM_CAR (target
));
2230 const SCM setter_proc
= scm_cons_source (expr
, scm_sym_setter
,
2233 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
2234 const SCM setter_args
= scm_append_x (scm_list_2 (SCM_CDR (target
),
2237 SCM_SETCAR (expr
, setter_proc
);
2238 SCM_SETCDR (expr
, setter_args
);
2245 /* @slot-ref is bound privately in the (oop goops) module from goops.c. As
2246 * soon as the module system allows us to more freely create bindings in
2247 * arbitrary modules during the startup phase, the code from goops.c should be
2250 SCM_SYNTAX (s_atslot_ref
, "@slot-ref", scm_i_makbimacro
, scm_m_atslot_ref
);
2251 SCM_SYNTAX (s_atslot_set_x
, "@slot-set!", scm_i_makbimacro
, scm_m_atslot_set_x
);
2252 SCM_SYMBOL (sym_atslot_ref
, "@slot-ref");
2255 scm_m_atslot_ref (SCM expr
, SCM env SCM_UNUSED
)
2259 const SCM cdr_expr
= SCM_CDR (expr
);
2260 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2261 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2262 slot_nr
= SCM_CADR (cdr_expr
);
2263 ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2265 SCM_SETCAR (expr
, SCM_IM_SLOT_REF
);
2266 SCM_SETCDR (cdr_expr
, slot_nr
);
2271 unmemoize_atslot_ref (const SCM expr
, const SCM env
)
2273 const SCM instance
= SCM_CADR (expr
);
2274 const SCM um_instance
= unmemoize_expression (instance
, env
);
2275 const SCM slot_nr
= SCM_CDDR (expr
);
2276 return scm_list_3 (sym_atslot_ref
, um_instance
, slot_nr
);
2280 /* @slot-set! is bound privately in the (oop goops) module from goops.c. As
2281 * soon as the module system allows us to more freely create bindings in
2282 * arbitrary modules during the startup phase, the code from goops.c should be
2285 SCM_SYMBOL (sym_atslot_set_x
, "@slot-set!");
2288 scm_m_atslot_set_x (SCM expr
, SCM env SCM_UNUSED
)
2292 const SCM cdr_expr
= SCM_CDR (expr
);
2293 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2294 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 3, s_expression
, expr
);
2295 slot_nr
= SCM_CADR (cdr_expr
);
2296 ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2298 SCM_SETCAR (expr
, SCM_IM_SLOT_SET_X
);
2303 unmemoize_atslot_set_x (const SCM expr
, const SCM env
)
2305 const SCM cdr_expr
= SCM_CDR (expr
);
2306 const SCM instance
= SCM_CAR (cdr_expr
);
2307 const SCM um_instance
= unmemoize_expression (instance
, env
);
2308 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
2309 const SCM slot_nr
= SCM_CAR (cddr_expr
);
2310 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
2311 const SCM value
= SCM_CAR (cdddr_expr
);
2312 const SCM um_value
= unmemoize_expression (value
, env
);
2313 return scm_list_4 (sym_atslot_set_x
, um_instance
, slot_nr
, um_value
);
2317 #if SCM_ENABLE_ELISP
2319 static const char s_defun
[] = "Symbol's function definition is void";
2321 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_i_makbimacro
, scm_m_nil_cond
);
2323 /* nil-cond expressions have the form
2324 * (nil-cond COND VAL COND VAL ... ELSEVAL) */
2326 scm_m_nil_cond (SCM expr
, SCM env SCM_UNUSED
)
2328 const long length
= scm_ilength (SCM_CDR (expr
));
2329 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
2330 ASSERT_SYNTAX (length
>= 1 && (length
% 2) == 1, s_expression
, expr
);
2332 SCM_SETCAR (expr
, SCM_IM_NIL_COND
);
2337 SCM_SYNTAX (s_atfop
, "@fop", scm_i_makbimacro
, scm_m_atfop
);
2339 /* The @fop-macro handles procedure and macro applications for elisp. The
2340 * input expression must have the form
2341 * (@fop <var> (transformer-macro <expr> ...))
2342 * where <var> must be a symbol. The expression is transformed into the
2343 * memoized form of either
2344 * (apply <un-aliased var> (transformer-macro <expr> ...))
2345 * if the value of var (across all aliasing) is not a macro, or
2346 * (<un-aliased var> <expr> ...)
2347 * if var is a macro. */
2349 scm_m_atfop (SCM expr
, SCM env SCM_UNUSED
)
2354 const SCM cdr_expr
= SCM_CDR (expr
);
2355 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2356 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 1, s_missing_expression
, expr
);
2358 symbol
= SCM_CAR (cdr_expr
);
2359 ASSERT_SYNTAX_2 (scm_is_symbol (symbol
), s_bad_variable
, symbol
, expr
);
2361 location
= scm_symbol_fref (symbol
);
2362 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2364 /* The elisp function `defalias' allows to define aliases for symbols. To
2365 * look up such definitions, the chain of symbol definitions has to be
2366 * followed up to the terminal symbol. */
2367 while (scm_is_symbol (SCM_VARIABLE_REF (location
)))
2369 const SCM alias
= SCM_VARIABLE_REF (location
);
2370 location
= scm_symbol_fref (alias
);
2371 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2374 /* Memoize the value location belonging to the terminal symbol. */
2375 SCM_SETCAR (cdr_expr
, location
);
2377 if (!SCM_MACROP (SCM_VARIABLE_REF (location
)))
2379 /* Since the location does not contain a macro, the form is a procedure
2380 * application. Replace `@fop' by `@apply' and transform the expression
2381 * including the `transformer-macro'. */
2382 SCM_SETCAR (expr
, SCM_IM_APPLY
);
2387 /* Since the location contains a macro, the arguments should not be
2388 * transformed, so the `transformer-macro' is cut out. The resulting
2389 * expression starts with the memoized variable, that is at the cdr of
2390 * the input expression. */
2391 SCM_SETCDR (cdr_expr
, SCM_CDADR (cdr_expr
));
2396 #endif /* SCM_ENABLE_ELISP */
2400 unmemoize_builtin_macro (const SCM expr
, const SCM env
)
2402 switch (ISYMNUM (SCM_CAR (expr
)))
2404 case (ISYMNUM (SCM_IM_AND
)):
2405 return unmemoize_and (expr
, env
);
2407 case (ISYMNUM (SCM_IM_BEGIN
)):
2408 return unmemoize_begin (expr
, env
);
2410 case (ISYMNUM (SCM_IM_CASE
)):
2411 return unmemoize_case (expr
, env
);
2413 case (ISYMNUM (SCM_IM_COND
)):
2414 return unmemoize_cond (expr
, env
);
2416 case (ISYMNUM (SCM_IM_DELAY
)):
2417 return unmemoize_delay (expr
, env
);
2419 case (ISYMNUM (SCM_IM_DO
)):
2420 return unmemoize_do (expr
, env
);
2422 case (ISYMNUM (SCM_IM_IF
)):
2423 return unmemoize_if (expr
, env
);
2425 case (ISYMNUM (SCM_IM_LAMBDA
)):
2426 return unmemoize_lambda (expr
, env
);
2428 case (ISYMNUM (SCM_IM_LET
)):
2429 return unmemoize_let (expr
, env
);
2431 case (ISYMNUM (SCM_IM_LETREC
)):
2432 return unmemoize_letrec (expr
, env
);
2434 case (ISYMNUM (SCM_IM_LETSTAR
)):
2435 return unmemoize_letstar (expr
, env
);
2437 case (ISYMNUM (SCM_IM_OR
)):
2438 return unmemoize_or (expr
, env
);
2440 case (ISYMNUM (SCM_IM_QUOTE
)):
2441 return unmemoize_quote (expr
, env
);
2443 case (ISYMNUM (SCM_IM_SET_X
)):
2444 return unmemoize_set_x (expr
, env
);
2446 case (ISYMNUM (SCM_IM_APPLY
)):
2447 return unmemoize_apply (expr
, env
);
2449 case (ISYMNUM (SCM_IM_BIND
)):
2450 return unmemoize_exprs (expr
, env
); /* FIXME */
2452 case (ISYMNUM (SCM_IM_CONT
)):
2453 return unmemoize_atcall_cc (expr
, env
);
2455 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2456 return unmemoize_at_call_with_values (expr
, env
);
2458 case (ISYMNUM (SCM_IM_SLOT_REF
)):
2459 return unmemoize_atslot_ref (expr
, env
);
2461 case (ISYMNUM (SCM_IM_SLOT_SET_X
)):
2462 return unmemoize_atslot_set_x (expr
, env
);
2464 case (ISYMNUM (SCM_IM_NIL_COND
)):
2465 return unmemoize_exprs (expr
, env
); /* FIXME */
2468 return unmemoize_exprs (expr
, env
); /* FIXME */
2473 /* scm_i_unmemocopy_expr and scm_i_unmemocopy_body take a memoized expression
2474 * respectively a memoized body together with its environment and rewrite it
2475 * to its original form. Thus, these functions are the inversion of the
2476 * rewrite rules above. The procedure is not optimized for speed. It's used
2477 * in scm_i_unmemoize_expr, scm_procedure_source, macro_print and scm_iprin1.
2479 * Unmemoizing is not a reliable process. You cannot in general expect to get
2480 * the original source back.
2482 * However, GOOPS currently relies on this for method compilation. This ought
2486 scm_i_unmemocopy_expr (SCM expr
, SCM env
)
2488 const SCM source_properties
= scm_whash_lookup (scm_source_whash
, expr
);
2489 const SCM um_expr
= unmemoize_expression (expr
, env
);
2491 if (scm_is_true (source_properties
))
2492 scm_whash_insert (scm_source_whash
, um_expr
, source_properties
);
2498 scm_i_unmemocopy_body (SCM forms
, SCM env
)
2500 const SCM source_properties
= scm_whash_lookup (scm_source_whash
, forms
);
2501 const SCM um_forms
= unmemoize_exprs (forms
, env
);
2503 if (scm_is_true (source_properties
))
2504 scm_whash_insert (scm_source_whash
, um_forms
, source_properties
);
2510 #if (SCM_ENABLE_DEPRECATED == 1)
2512 static SCM
scm_m_undefine (SCM expr
, SCM env
);
2514 SCM_SYNTAX (s_undefine
, "undefine", scm_makacro
, scm_m_undefine
);
2517 scm_m_undefine (SCM expr
, SCM env
)
2522 const SCM cdr_expr
= SCM_CDR (expr
);
2523 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), "Bad undefine placement in", expr
);
2524 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2525 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2527 scm_c_issue_deprecation_warning
2528 ("`undefine' is deprecated.\n");
2530 variable
= SCM_CAR (cdr_expr
);
2531 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
2532 location
= scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_F
);
2533 ASSERT_SYNTAX_2 (scm_is_true (location
)
2534 && !SCM_UNBNDP (SCM_VARIABLE_REF (location
)),
2535 "variable already unbound ", variable
, expr
);
2536 SCM_VARIABLE_SET (location
, SCM_UNDEFINED
);
2537 return SCM_UNSPECIFIED
;
2540 #endif /* SCM_ENABLE_DEPRECATED */
2544 /*****************************************************************************/
2545 /*****************************************************************************/
2546 /* The definitions for execution start here. */
2547 /*****************************************************************************/
2548 /*****************************************************************************/
2550 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
2551 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
2552 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
2553 SCM_GLOBAL_SYMBOL (scm_sym_memoize_symbol
, "memoize-symbol");
2554 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
2555 SCM_SYMBOL (sym_instead
, "instead");
2557 /* A function object to implement "apply" for non-closure functions. */
2559 /* An endless list consisting of #<undefined> objects: */
2560 static SCM undefineds
;
2564 scm_badargsp (SCM formals
, SCM args
)
2566 while (!scm_is_null (formals
))
2568 if (!scm_is_pair (formals
))
2570 if (scm_is_null (args
))
2572 formals
= SCM_CDR (formals
);
2573 args
= SCM_CDR (args
);
2575 return !scm_is_null (args
) ? 1 : 0;
2580 /* The evaluator contains a plethora of EVAL symbols.
2583 * SCM_I_EVALIM is used when it is known that the expression is an
2584 * immediate. (This macro never calls an evaluator.)
2586 * SCM_I_XEVAL evaluates an expression that is expected to have its symbols already
2587 * memoized. Expressions that are not of the form '(<form> <form> ...)' are
2588 * evaluated inline without calling an evaluator.
2590 * SCM_I_XEVALCAR evaluates the car of an expression 'X:(Y:<form> <form> ...)',
2591 * potentially replacing a symbol at the position Y:<form> by its memoized
2592 * variable. If Y:<form> is not of the form '(<form> <form> ...)', the
2593 * evaluation is performed inline without calling an evaluator.
2597 #define SCM_I_EVALIM2(x) \
2598 ((scm_is_eq ((x), SCM_EOL) \
2599 ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \
2603 #define SCM_I_EVALIM(x, env) (SCM_ILOCP (x) \
2604 ? *scm_ilookup ((x), (env)) \
2607 #define SCM_I_XEVAL(x, env) \
2609 ? SCM_I_EVALIM2 (x) \
2610 : (SCM_VARIABLEP (x) \
2611 ? SCM_VARIABLE_REF (x) \
2612 : (scm_is_pair (x) \
2613 ? eval ((x), (env)) \
2616 #define SCM_I_XEVALCAR(x, env) \
2617 (SCM_IMP (SCM_CAR (x)) \
2618 ? SCM_I_EVALIM (SCM_CAR (x), (env)) \
2619 : (SCM_VARIABLEP (SCM_CAR (x)) \
2620 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2621 : (scm_is_pair (SCM_CAR (x)) \
2622 ? eval (SCM_CAR (x), (env)) \
2623 : (!scm_is_symbol (SCM_CAR (x)) \
2625 : *scm_lookupcar ((x), (env), 1)))))
2627 scm_i_pthread_mutex_t source_mutex
;
2630 /* Lookup a given local variable in an environment. The local variable is
2631 * given as an iloc, that is a triple <frame, binding, last?>, where frame
2632 * indicates the relative number of the environment frame (counting upwards
2633 * from the innermost environment frame), binding indicates the number of the
2634 * binding within the frame, and last? (which is extracted from the iloc using
2635 * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
2636 * very end of the improper list of bindings. */
2638 scm_ilookup (SCM iloc
, SCM env
)
2640 unsigned int frame_nr
= SCM_IFRAME (iloc
);
2641 unsigned int binding_nr
= SCM_IDIST (iloc
);
2645 for (; 0 != frame_nr
; --frame_nr
)
2646 frames
= SCM_CDR (frames
);
2648 bindings
= SCM_CAR (frames
);
2649 for (; 0 != binding_nr
; --binding_nr
)
2650 bindings
= SCM_CDR (bindings
);
2652 if (SCM_ICDRP (iloc
))
2653 return SCM_CDRLOC (bindings
);
2654 return SCM_CARLOC (SCM_CDR (bindings
));
2658 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
2660 /* Call this for variables that are unfound.
2663 error_unbound_variable (SCM symbol
)
2665 scm_error (scm_unbound_variable_key
, NULL
,
2666 "Unbound variable: ~S",
2667 scm_list_1 (symbol
), SCM_BOOL_F
);
2670 /* Call this for variables that are found but contain SCM_UNDEFINED.
2673 error_defined_variable (SCM symbol
)
2675 /* We use the 'unbound-variable' key here as well, since it
2676 basically is the same kind of error, with a slight variation in
2677 the displayed message.
2679 scm_error (scm_unbound_variable_key
, NULL
,
2680 "Variable used before given a value: ~S",
2681 scm_list_1 (symbol
), SCM_BOOL_F
);
2685 /* The Lookup Car Race
2688 Memoization of variables and special forms is done while executing
2689 the code for the first time. As long as there is only one thread
2690 everything is fine, but as soon as two threads execute the same
2691 code concurrently `for the first time' they can come into conflict.
2693 This memoization includes rewriting variable references into more
2694 efficient forms and expanding macros. Furthermore, macro expansion
2695 includes `compiling' special forms like `let', `cond', etc. into
2696 tree-code instructions.
2698 There shouldn't normally be a problem with memoizing local and
2699 global variable references (into ilocs and variables), because all
2700 threads will mutate the code in *exactly* the same way and (if I
2701 read the C code correctly) it is not possible to observe a half-way
2702 mutated cons cell. The lookup procedure can handle this
2703 transparently without any critical sections.
2705 It is different with macro expansion, because macro expansion
2706 happens outside of the lookup procedure and can't be
2707 undone. Therefore the lookup procedure can't cope with it. It has
2708 to indicate failure when it detects a lost race and hope that the
2709 caller can handle it. Luckily, it turns out that this is the case.
2711 An example to illustrate this: Suppose that the following form will
2712 be memoized concurrently by two threads
2716 Let's first examine the lookup of X in the body. The first thread
2717 decides that it has to find the symbol "x" in the environment and
2718 starts to scan it. Then the other thread takes over and actually
2719 overtakes the first. It looks up "x" and substitutes an
2720 appropriate iloc for it. Now the first thread continues and
2721 completes its lookup. It comes to exactly the same conclusions as
2722 the second one and could - without much ado - just overwrite the
2723 iloc with the same iloc.
2725 But let's see what will happen when the race occurs while looking
2726 up the symbol "let" at the start of the form. It could happen that
2727 the second thread interrupts the lookup of the first thread and not
2728 only substitutes a variable for it but goes right ahead and
2729 replaces it with the compiled form (#@let* (x 12) x). Now, when
2730 the first thread completes its lookup, it would replace the #@let*
2731 with a variable containing the "let" binding, effectively reverting
2732 the form to (let (x 12) x). This is wrong. It has to detect that
2733 it has lost the race and the evaluator has to reconsider the
2734 changed form completely.
2736 This race condition could be resolved with some kind of traffic
2737 light (like mutexes) around scm_lookupcar, but I think that it is
2738 best to avoid them in this case. They would serialize memoization
2739 completely and because lookup involves calling arbitrary Scheme
2740 code (via the lookup-thunk), threads could be blocked for an
2741 arbitrary amount of time or even deadlock. But with the current
2742 solution a lot of unnecessary work is potentially done. */
2744 /* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
2745 return NULL to indicate a failed lookup due to some race conditions
2746 between threads. This only happens when VLOC is the first cell of
2747 a special form that will eventually be memoized (like `let', etc.)
2748 In that case the whole lookup is bogus and the caller has to
2749 reconsider the complete special form.
2751 SCM_LOOKUPCAR is still there, of course. It just calls
2752 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
2753 should only be called when it is known that VLOC is not the first
2754 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
2755 for NULL. I think I've found the only places where this
2759 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
2762 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
2763 register SCM iloc
= SCM_ILOC00
;
2764 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
2766 if (!scm_is_pair (SCM_CAR (env
)))
2768 al
= SCM_CARLOC (env
);
2769 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
2771 if (!scm_is_pair (fl
))
2773 if (scm_is_eq (fl
, var
))
2775 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2777 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
2778 return SCM_CDRLOC (*al
);
2783 al
= SCM_CDRLOC (*al
);
2784 if (scm_is_eq (SCM_CAR (fl
), var
))
2786 if (SCM_UNBNDP (SCM_CAR (*al
)))
2787 error_defined_variable (var
);
2788 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2790 SCM_SETCAR (vloc
, iloc
);
2791 return SCM_CARLOC (*al
);
2793 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
2795 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
2798 SCM top_thunk
, real_var
;
2801 top_thunk
= SCM_CAR (env
); /* env now refers to a
2802 top level env thunk */
2803 env
= SCM_CDR (env
);
2806 top_thunk
= SCM_BOOL_F
;
2807 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
2808 if (scm_is_false (real_var
))
2811 if (!scm_is_null (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
2816 if (scm_is_null (env
))
2817 error_unbound_variable (var
);
2819 scm_misc_error (NULL
, "Damaged environment: ~S",
2824 /* A variable could not be found, but we shall
2825 not throw an error. */
2826 static SCM undef_object
= SCM_UNDEFINED
;
2827 return &undef_object
;
2831 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2833 /* Some other thread has changed the very cell we are working
2834 on. In effect, it must have done our job or messed it up
2837 var
= SCM_CAR (vloc
);
2838 if (SCM_VARIABLEP (var
))
2839 return SCM_VARIABLE_LOC (var
);
2840 if (SCM_ILOCP (var
))
2841 return scm_ilookup (var
, genv
);
2842 /* We can't cope with anything else than variables and ilocs. When
2843 a special form has been memoized (i.e. `let' into `#@let') we
2844 return NULL and expect the calling function to do the right
2845 thing. For the evaluator, this means going back and redoing
2846 the dispatch on the car of the form. */
2850 SCM_SETCAR (vloc
, real_var
);
2851 return SCM_VARIABLE_LOC (real_var
);
2856 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
2858 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
2865 /* During execution, look up a symbol in the top level of the given local
2866 * environment and return the corresponding variable object. If no binding
2867 * for the symbol can be found, an 'Unbound variable' error is signalled. */
2869 lazy_memoize_variable (const SCM symbol
, const SCM environment
)
2871 const SCM top_level
= scm_env_top_level (environment
);
2872 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
2874 if (scm_is_false (variable
))
2875 error_unbound_variable (symbol
);
2882 scm_eval_car (SCM pair
, SCM env
)
2884 return SCM_I_XEVALCAR (pair
, env
);
2889 scm_eval_body (SCM code
, SCM env
)
2894 next
= SCM_CDR (code
);
2895 while (!scm_is_null (next
))
2897 if (SCM_IMP (SCM_CAR (code
)))
2899 if (SCM_ISYMP (SCM_CAR (code
)))
2901 scm_dynwind_begin (0);
2902 scm_i_dynwind_pthread_mutex_lock (&source_mutex
);
2903 /* check for race condition */
2904 if (SCM_ISYMP (SCM_CAR (code
)))
2905 m_expand_body (code
, env
);
2911 SCM_I_XEVAL (SCM_CAR (code
), env
);
2913 next
= SCM_CDR (code
);
2915 return SCM_I_XEVALCAR (code
, env
);
2919 /* scm_last_debug_frame contains a pointer to the last debugging information
2920 * stack frame. It is accessed very often from the debugging evaluator, so it
2921 * should probably not be indirectly addressed. Better to save and restore it
2922 * from the current root at any stack swaps.
2925 /* scm_debug_eframe_size is the number of slots available for pseudo
2926 * stack frames at each real stack frame.
2929 long scm_debug_eframe_size
;
2931 int scm_debug_mode_p
;
2932 int scm_check_entry_p
;
2933 int scm_check_apply_p
;
2934 int scm_check_exit_p
;
2935 int scm_check_memoize_p
;
2937 long scm_eval_stack
;
2939 scm_t_option scm_eval_opts
[] = {
2940 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." },
2944 scm_t_option scm_debug_opts
[] = {
2945 { SCM_OPTION_BOOLEAN
, "cheap", 1,
2946 "*This option is now obsolete. Setting it has no effect." },
2947 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
2948 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
2949 { SCM_OPTION_BOOLEAN
, "procnames", 1,
2950 "Record procedure names at definition." },
2951 { SCM_OPTION_BOOLEAN
, "backwards", 0,
2952 "Display backtrace in anti-chronological order." },
2953 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
2954 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
2955 { SCM_OPTION_INTEGER
, "frames", 3,
2956 "Maximum number of tail-recursive frames in backtrace." },
2957 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
2958 "Maximal number of stored backtrace frames." },
2959 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
2960 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
2961 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
2962 /* This default stack limit will be overridden by debug.c:init_stack_limit(),
2963 if we have getrlimit() and the stack limit is not INFINITY. But it is still
2964 important, as some systems have both the soft and the hard limits set to
2965 INFINITY; in that case we fall back to this value.
2967 The situation is aggravated by certain compilers, which can consume
2968 "beaucoup de stack", as they say in France.
2970 See http://thread.gmane.org/gmane.lisp.guile.devel/8599/focus=8662 for
2971 more discussion. This setting is 640 KB on 32-bit arches (should be enough
2972 for anyone!) or a whoppin' 1280 KB on 64-bit arches.
2974 { SCM_OPTION_INTEGER
, "stack", 160000, "Stack size limit (measured in words; 0 = no check)." },
2975 { SCM_OPTION_SCM
, "show-file-name", (unsigned long)SCM_BOOL_T
,
2976 "Show file names and line numbers "
2977 "in backtraces when not `#f'. A value of `base' "
2978 "displays only base names, while `#t' displays full names."},
2979 { SCM_OPTION_BOOLEAN
, "warn-deprecated", 0,
2980 "Warn when deprecated features are used." },
2986 * this ordering is awkward and illogical, but we maintain it for
2987 * compatibility. --hwn
2989 scm_t_option scm_evaluator_trap_table
[] = {
2990 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
2991 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
2992 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
2993 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
2994 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
2995 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
2996 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." },
2997 { SCM_OPTION_BOOLEAN
, "memoize-symbol", 0, "Trap when memoizing a symbol." },
2998 { SCM_OPTION_SCM
, "memoize-symbol-handler", (unsigned long)SCM_BOOL_F
, "The handler for memoization." },
3003 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
3005 "Option interface for the evaluation options. Instead of using\n"
3006 "this procedure directly, use the procedures @code{eval-enable},\n"
3007 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
3008 #define FUNC_NAME s_scm_eval_options_interface
3012 scm_dynwind_begin (0);
3013 scm_dynwind_critical_section (SCM_BOOL_F
);
3014 ans
= scm_options (setting
,
3017 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
3025 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
3027 "Option interface for the evaluator trap options.")
3028 #define FUNC_NAME s_scm_evaluator_traps
3033 scm_options_try (setting
,
3034 scm_evaluator_trap_table
,
3036 SCM_CRITICAL_SECTION_START
;
3037 ans
= scm_options (setting
,
3038 scm_evaluator_trap_table
,
3041 /* njrev: same again. */
3042 SCM_RESET_DEBUG_MODE
;
3043 SCM_CRITICAL_SECTION_END
;
3052 /* Simple procedure calls
3056 scm_call_0 (SCM proc
)
3058 if (SCM_PROGRAM_P (proc
))
3059 return scm_c_vm_run (scm_the_vm (), proc
, NULL
, 0);
3061 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
3065 scm_call_1 (SCM proc
, SCM arg1
)
3067 if (SCM_PROGRAM_P (proc
))
3068 return scm_c_vm_run (scm_the_vm (), proc
, &arg1
, 1);
3070 return scm_apply (proc
, arg1
, scm_listofnull
);
3074 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
3076 if (SCM_PROGRAM_P (proc
))
3078 SCM args
[] = { arg1
, arg2
};
3079 return scm_c_vm_run (scm_the_vm (), proc
, args
, 2);
3082 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
3086 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
3088 if (SCM_PROGRAM_P (proc
))
3090 SCM args
[] = { arg1
, arg2
, arg3
};
3091 return scm_c_vm_run (scm_the_vm (), proc
, args
, 3);
3094 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
3098 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
3100 if (SCM_PROGRAM_P (proc
))
3102 SCM args
[] = { arg1
, arg2
, arg3
, arg4
};
3103 return scm_c_vm_run (scm_the_vm (), proc
, args
, 4);
3106 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
3107 scm_cons (arg4
, scm_listofnull
)));
3110 /* Simple procedure applies
3114 scm_apply_0 (SCM proc
, SCM args
)
3116 return scm_apply (proc
, args
, SCM_EOL
);
3120 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
3122 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
3126 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
3128 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
3132 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
3134 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
3138 /* This code processes the arguments to apply:
3140 (apply PROC ARG1 ... ARGS)
3142 Given a list (ARG1 ... ARGS), this function conses the ARG1
3143 ... arguments onto the front of ARGS, and returns the resulting
3144 list. Note that ARGS is a list; thus, the argument to this
3145 function is a list whose last element is a list.
3147 Apply calls this function, and applies PROC to the elements of the
3148 result. apply:nconc2last takes care of building the list of
3149 arguments, given (ARG1 ... ARGS).
3151 Rather than do new consing, apply:nconc2last destroys its argument.
3152 On that topic, this code came into my care with the following
3153 beautifully cryptic comment on that topic: "This will only screw
3154 you if you do (scm_apply scm_apply '( ... ))" If you know what
3155 they're referring to, send me a patch to this comment. */
3157 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3159 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
3160 "conses the @var{arg1} @dots{} arguments onto the front of\n"
3161 "@var{args}, and returns the resulting list. Note that\n"
3162 "@var{args} is a list; thus, the argument to this function is\n"
3163 "a list whose last element is a list.\n"
3164 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
3165 "destroys its argument, so use with care.")
3166 #define FUNC_NAME s_scm_nconc2last
3169 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
3171 while (!scm_is_null (SCM_CDR (*lloc
))) /* Perhaps should be
3172 SCM_NULL_OR_NIL_P, but not
3173 needed in 99.99% of cases,
3174 and it could seriously hurt
3175 performance. - Neil */
3176 lloc
= SCM_CDRLOC (*lloc
);
3177 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3178 *lloc
= SCM_CAR (*lloc
);
3185 /* SECTION: The rest of this file is only read once.
3190 * Trampolines were an intent to speed up calling the same Scheme procedure many
3193 * However, this was the wrong thing to optimize; if you really know what you're
3194 * calling, call its function directly, otherwise you're in Scheme-land, and we
3195 * have many better tricks there (inlining, for example, which can remove the
3196 * need for closures and free variables).
3198 * Also, in the normal debugging case, trampolines were being computed but not
3203 scm_trampoline_0 (SCM proc
)
3209 scm_trampoline_1 (SCM proc
)
3215 scm_trampoline_2 (SCM proc
)
3220 /* Typechecking for multi-argument MAP and FOR-EACH.
3222 Verify that each element of the vector ARGV, except for the first,
3223 is a proper list whose length is LEN. Attribute errors to WHO,
3224 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3226 check_map_args (SCM argv
,
3235 for (i
= SCM_SIMPLE_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
3237 SCM elt
= SCM_SIMPLE_VECTOR_REF (argv
, i
);
3238 long elt_len
= scm_ilength (elt
);
3243 scm_apply_generic (gf
, scm_cons (proc
, args
));
3245 scm_wrong_type_arg (who
, i
+ 2, elt
);
3249 scm_out_of_range_pos (who
, elt
, scm_from_long (i
+ 2));
3254 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3256 /* Note: Currently, scm_map applies PROC to the argument list(s)
3257 sequentially, starting with the first element(s). This is used in
3258 evalext.c where the Scheme procedure `map-in-order', which guarantees
3259 sequential behaviour, is implemented using scm_map. If the
3260 behaviour changes, we need to update `map-in-order'.
3264 scm_map (SCM proc
, SCM arg1
, SCM args
)
3265 #define FUNC_NAME s_map
3271 len
= scm_ilength (arg1
);
3272 SCM_GASSERTn (len
>= 0,
3273 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
3274 SCM_VALIDATE_REST_ARGUMENT (args
);
3275 if (scm_is_null (args
))
3277 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
3278 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
3279 while (SCM_NIMP (arg1
))
3281 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
3282 pres
= SCM_CDRLOC (*pres
);
3283 arg1
= SCM_CDR (arg1
);
3287 if (scm_is_null (SCM_CDR (args
)))
3289 SCM arg2
= SCM_CAR (args
);
3290 int len2
= scm_ilength (arg2
);
3291 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
3293 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
3294 SCM_GASSERTn (len2
>= 0,
3295 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
3297 SCM_OUT_OF_RANGE (3, arg2
);
3298 while (SCM_NIMP (arg1
))
3300 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
3301 pres
= SCM_CDRLOC (*pres
);
3302 arg1
= SCM_CDR (arg1
);
3303 arg2
= SCM_CDR (arg2
);
3307 arg1
= scm_cons (arg1
, args
);
3308 args
= scm_vector (arg1
);
3309 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
3313 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3315 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
3318 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
3319 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
3321 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
3322 pres
= SCM_CDRLOC (*pres
);
3328 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
3331 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
3332 #define FUNC_NAME s_for_each
3335 len
= scm_ilength (arg1
);
3336 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
3337 SCM_ARG2
, s_for_each
);
3338 SCM_VALIDATE_REST_ARGUMENT (args
);
3339 if (scm_is_null (args
))
3341 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
3342 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
3343 while (SCM_NIMP (arg1
))
3345 call (proc
, SCM_CAR (arg1
));
3346 arg1
= SCM_CDR (arg1
);
3348 return SCM_UNSPECIFIED
;
3350 if (scm_is_null (SCM_CDR (args
)))
3352 SCM arg2
= SCM_CAR (args
);
3353 int len2
= scm_ilength (arg2
);
3354 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
3355 SCM_GASSERTn (call
, g_for_each
,
3356 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
3357 SCM_GASSERTn (len2
>= 0, g_for_each
,
3358 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
3360 SCM_OUT_OF_RANGE (3, arg2
);
3361 while (SCM_NIMP (arg1
))
3363 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
3364 arg1
= SCM_CDR (arg1
);
3365 arg2
= SCM_CDR (arg2
);
3367 return SCM_UNSPECIFIED
;
3369 arg1
= scm_cons (arg1
, args
);
3370 args
= scm_vector (arg1
);
3371 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
3375 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3377 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
3379 return SCM_UNSPECIFIED
;
3380 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
3381 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
3383 scm_apply (proc
, arg1
, SCM_EOL
);
3390 scm_closure (SCM code
, SCM env
)
3393 SCM closcar
= scm_cons (code
, SCM_EOL
);
3394 z
= scm_immutable_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
,
3396 scm_remember_upto_here (closcar
);
3401 scm_t_bits scm_tc16_promise
;
3403 SCM_DEFINE (scm_make_promise
, "make-promise", 1, 0, 0,
3405 "Create a new promise object.\n\n"
3406 "@code{make-promise} is a procedural form of @code{delay}.\n"
3407 "These two expressions are equivalent:\n"
3409 "(delay @var{exp})\n"
3410 "(make-promise (lambda () @var{exp}))\n"
3412 #define FUNC_NAME s_scm_make_promise
3414 SCM_VALIDATE_THUNK (1, thunk
);
3415 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
3417 scm_make_recursive_mutex ());
3423 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
3425 int writingp
= SCM_WRITINGP (pstate
);
3426 scm_puts ("#<promise ", port
);
3427 SCM_SET_WRITINGP (pstate
, 1);
3428 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
3429 SCM_SET_WRITINGP (pstate
, writingp
);
3430 scm_putc ('>', port
);
3434 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
3436 "If the promise @var{x} has not been computed yet, compute and\n"
3437 "return @var{x}, otherwise just return the previously computed\n"
3439 #define FUNC_NAME s_scm_force
3441 SCM_VALIDATE_SMOB (1, promise
, promise
);
3442 scm_lock_mutex (SCM_PROMISE_MUTEX (promise
));
3443 if (!SCM_PROMISE_COMPUTED_P (promise
))
3445 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
3446 if (!SCM_PROMISE_COMPUTED_P (promise
))
3448 SCM_SET_PROMISE_DATA (promise
, ans
);
3449 SCM_SET_PROMISE_COMPUTED (promise
);
3452 scm_unlock_mutex (SCM_PROMISE_MUTEX (promise
));
3453 return SCM_PROMISE_DATA (promise
);
3458 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
3460 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
3461 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
3462 #define FUNC_NAME s_scm_promise_p
3464 return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
3469 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
3470 (SCM xorig
, SCM x
, SCM y
),
3471 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
3472 "Any source properties associated with @var{xorig} are also associated\n"
3473 "with the new pair.")
3474 #define FUNC_NAME s_scm_cons_source
3477 z
= scm_cons (x
, y
);
3478 /* Copy source properties possibly associated with xorig. */
3479 p
= scm_whash_lookup (scm_source_whash
, xorig
);
3480 if (scm_is_true (p
))
3481 scm_whash_insert (scm_source_whash
, z
, p
);
3487 /* The function scm_copy_tree is used to copy an expression tree to allow the
3488 * memoizer to modify the expression during memoization. scm_copy_tree
3489 * creates deep copies of pairs and vectors, but not of any other data types,
3490 * since only pairs and vectors will be parsed by the memoizer.
3492 * To avoid infinite recursion due to cyclic structures, the hare-and-tortoise
3493 * pattern is used to detect cycles. In fact, the pattern is used in two
3494 * dimensions, vertical (indicated in the code by the variable names 'hare'
3495 * and 'tortoise') and horizontal ('rabbit' and 'turtle'). In both
3496 * dimensions, the hare/rabbit will take two steps when the tortoise/turtle
3499 * The vertical dimension corresponds to recursive calls to function
3500 * copy_tree: This happens when descending into vector elements, into cars of
3501 * lists and into the cdr of an improper list. In this dimension, the
3502 * tortoise follows the hare by using the processor stack: Every stack frame
3503 * will hold an instance of struct t_trace. These instances are connected in
3504 * a way that represents the trace of the hare, which thus can be followed by
3505 * the tortoise. The tortoise will always point to struct t_trace instances
3506 * relating to SCM objects that have already been copied. Thus, a cycle is
3507 * detected if the tortoise and the hare point to the same object,
3509 * The horizontal dimension is within one execution of copy_tree, when the
3510 * function cdr's along the pairs of a list. This is the standard
3511 * hare-and-tortoise implementation, found several times in guile. */
3514 struct t_trace
*trace
; /* These pointers form a trace along the stack. */
3515 SCM obj
; /* The object handled at the respective stack frame.*/
3520 struct t_trace
*const hare
,
3521 struct t_trace
*tortoise
,
3522 unsigned int tortoise_delay
)
3524 if (!scm_is_pair (hare
->obj
) && !scm_is_simple_vector (hare
->obj
))
3530 /* Prepare the trace along the stack. */
3531 struct t_trace new_hare
;
3532 hare
->trace
= &new_hare
;
3534 /* The tortoise will make its step after the delay has elapsed. Note
3535 * that in contrast to the typical hare-and-tortoise pattern, the step
3536 * of the tortoise happens before the hare takes its steps. This is, in
3537 * principle, no problem, except for the start of the algorithm: Then,
3538 * it has to be made sure that the hare actually gets its advantage of
3540 if (tortoise_delay
== 0)
3543 tortoise
= tortoise
->trace
;
3544 ASSERT_SYNTAX (!scm_is_eq (hare
->obj
, tortoise
->obj
),
3545 s_bad_expression
, hare
->obj
);
3552 if (scm_is_simple_vector (hare
->obj
))
3554 size_t length
= SCM_SIMPLE_VECTOR_LENGTH (hare
->obj
);
3555 SCM new_vector
= scm_c_make_vector (length
, SCM_UNSPECIFIED
);
3557 /* Each vector element is copied by recursing into copy_tree, having
3558 * the tortoise follow the hare into the depths of the stack. */
3559 unsigned long int i
;
3560 for (i
= 0; i
< length
; ++i
)
3563 new_hare
.obj
= SCM_SIMPLE_VECTOR_REF (hare
->obj
, i
);
3564 new_element
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3565 SCM_SIMPLE_VECTOR_SET (new_vector
, i
, new_element
);
3570 else /* scm_is_pair (hare->obj) */
3575 SCM rabbit
= hare
->obj
;
3576 SCM turtle
= hare
->obj
;
3580 /* The first pair of the list is treated specially, in order to
3581 * preserve a potential source code position. */
3582 result
= tail
= scm_cons_source (rabbit
, SCM_EOL
, SCM_EOL
);
3583 new_hare
.obj
= SCM_CAR (rabbit
);
3584 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3585 SCM_SETCAR (tail
, copy
);
3587 /* The remaining pairs of the list are copied by, horizontally,
3588 * having the turtle follow the rabbit, and, vertically, having the
3589 * tortoise follow the hare into the depths of the stack. */
3590 rabbit
= SCM_CDR (rabbit
);
3591 while (scm_is_pair (rabbit
))
3593 new_hare
.obj
= SCM_CAR (rabbit
);
3594 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3595 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
3596 tail
= SCM_CDR (tail
);
3598 rabbit
= SCM_CDR (rabbit
);
3599 if (scm_is_pair (rabbit
))
3601 new_hare
.obj
= SCM_CAR (rabbit
);
3602 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3603 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
3604 tail
= SCM_CDR (tail
);
3605 rabbit
= SCM_CDR (rabbit
);
3607 turtle
= SCM_CDR (turtle
);
3608 ASSERT_SYNTAX (!scm_is_eq (rabbit
, turtle
),
3609 s_bad_expression
, rabbit
);
3613 /* We have to recurse into copy_tree again for the last cdr, in
3614 * order to handle the situation that it holds a vector. */
3615 new_hare
.obj
= rabbit
;
3616 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3617 SCM_SETCDR (tail
, copy
);
3624 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
3626 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
3627 "the new data structure. @code{copy-tree} recurses down the\n"
3628 "contents of both pairs and vectors (since both cons cells and vector\n"
3629 "cells may point to arbitrary objects), and stops recursing when it hits\n"
3630 "any other object.")
3631 #define FUNC_NAME s_scm_copy_tree
3633 /* Prepare the trace along the stack. */
3634 struct t_trace trace
;
3637 /* In function copy_tree, if the tortoise makes its step, it will do this
3638 * before the hare has the chance to move. Thus, we have to make sure that
3639 * the very first step of the tortoise will not happen after the hare has
3640 * really made two steps. This is achieved by passing '2' as the initial
3641 * delay for the tortoise. NOTE: Since cycles are unlikely, giving the hare
3642 * a bigger advantage may improve performance slightly. */
3643 return copy_tree (&trace
, &trace
, 2);
3648 /* We have three levels of EVAL here:
3650 - scm_i_eval (exp, env)
3652 evaluates EXP in environment ENV. ENV is a lexical environment
3653 structure as used by the actual tree code evaluator. When ENV is
3654 a top-level environment, then changes to the current module are
3655 tracked by updating ENV so that it continues to be in sync with
3658 - scm_primitive_eval (exp)
3660 evaluates EXP in the top-level environment as determined by the
3661 current module. This is done by constructing a suitable
3662 environment and calling scm_i_eval. Thus, changes to the
3663 top-level module are tracked normally.
3665 - scm_eval (exp, mod_or_state)
3667 evaluates EXP while MOD_OR_STATE is the current module or current
3668 dynamic state (as appropriate). This is done by setting the
3669 current module (or dynamic state) to MOD_OR_STATE, invoking
3670 scm_primitive_eval on EXP, and then restoring the current module
3671 (or dynamic state) to the value it had previously. That is,
3672 while EXP is evaluated, changes to the current module (or dynamic
3673 state) are tracked, but these changes do not persist when
3676 For each level of evals, there are two variants, distinguished by a
3677 _x suffix: the ordinary variant does not modify EXP while the _x
3678 variant can destructively modify EXP into something completely
3679 unintelligible. A Scheme data structure passed as EXP to one of the
3680 _x variants should not ever be used again for anything. So when in
3681 doubt, use the ordinary variant.
3686 scm_i_eval_x (SCM exp
, SCM env
)
3688 if (scm_is_symbol (exp
))
3689 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
3691 return SCM_I_XEVAL (exp
, env
);
3695 scm_i_eval (SCM exp
, SCM env
)
3697 exp
= scm_copy_tree (exp
);
3698 if (scm_is_symbol (exp
))
3699 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
3701 return SCM_I_XEVAL (exp
, env
);
3705 scm_primitive_eval_x (SCM exp
)
3708 SCM transformer
= scm_current_module_transformer ();
3709 if (SCM_NIMP (transformer
))
3710 exp
= scm_call_1 (transformer
, exp
);
3711 env
= scm_top_level_env (scm_current_module_lookup_closure ());
3712 return scm_i_eval_x (exp
, env
);
3715 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
3717 "Evaluate @var{exp} in the top-level environment specified by\n"
3718 "the current module.")
3719 #define FUNC_NAME s_scm_primitive_eval
3722 SCM transformer
= scm_current_module_transformer ();
3723 if (scm_is_true (transformer
))
3724 exp
= scm_call_1 (transformer
, exp
);
3725 env
= scm_top_level_env (scm_current_module_lookup_closure ());
3726 return scm_i_eval (exp
, env
);
3731 /* Eval does not take the second arg optionally. This is intentional
3732 * in order to be R5RS compatible, and to prepare for the new module
3733 * system, where we would like to make the choice of evaluation
3734 * environment explicit. */
3737 scm_eval_x (SCM exp
, SCM module_or_state
)
3741 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
3742 if (scm_is_dynamic_state (module_or_state
))
3743 scm_dynwind_current_dynamic_state (module_or_state
);
3745 scm_dynwind_current_module (module_or_state
);
3747 res
= scm_primitive_eval_x (exp
);
3753 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
3754 (SCM exp
, SCM module_or_state
),
3755 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
3756 "in the top-level environment specified by\n"
3757 "@var{module_or_state}.\n"
3758 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
3759 "@var{module_or_state} is made the current module when\n"
3760 "it is a module, or the current dynamic state when it is\n"
3762 "Example: (eval '(+ 1 2) (interaction-environment))")
3763 #define FUNC_NAME s_scm_eval
3767 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
3768 if (scm_is_dynamic_state (module_or_state
))
3769 scm_dynwind_current_dynamic_state (module_or_state
);
3770 else if (scm_module_system_booted_p
)
3772 SCM_VALIDATE_MODULE (2, module_or_state
);
3773 scm_dynwind_current_module (module_or_state
);
3775 /* otherwise if the module system isn't booted, ignore the module arg */
3777 res
= scm_primitive_eval (exp
);
3785 /* At this point, eval and scm_apply are generated.
3789 ceval_letrec_inits (SCM env
, SCM init_forms
, SCM
**init_values_eol
)
3792 int i
= 0, imax
= sizeof (argv
) / sizeof (SCM
);
3794 while (!scm_is_null (init_forms
))
3798 ceval_letrec_inits (env
, init_forms
, init_values_eol
);
3801 argv
[i
++] = SCM_I_XEVALCAR (init_forms
, env
);
3802 init_forms
= SCM_CDR (init_forms
);
3805 for (i
--; i
>= 0; i
--)
3807 **init_values_eol
= scm_list_1 (argv
[i
]);
3808 *init_values_eol
= SCM_CDRLOC (**init_values_eol
);
3818 scm_i_pthread_mutex_init (&source_mutex
,
3819 scm_i_pthread_mutexattr_recursive
);
3821 scm_init_opts (scm_evaluator_traps
,
3822 scm_evaluator_trap_table
);
3823 scm_init_opts (scm_eval_options_interface
,
3826 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
3827 scm_set_smob_print (scm_tc16_promise
, promise_print
);
3829 undefineds
= scm_list_1 (SCM_UNDEFINED
);
3830 SCM_SETCDR (undefineds
, undefineds
);
3831 scm_permanent_object (undefineds
);
3833 scm_listofnull
= scm_list_1 (SCM_EOL
);
3835 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
3836 scm_permanent_object (f_apply
);
3838 #include "libguile/eval.x"
3840 scm_add_feature ("delay");