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 void ceval_letrec_inits (SCM env
, SCM init_forms
, SCM
**init_values_eol
);
78 static SCM
ceval (SCM x
, SCM env
);
79 static SCM
deval (SCM x
, SCM env
);
85 * This section defines the message strings for the syntax errors that can be
86 * detected during memoization and the functions and macros that shall be
87 * called by the memoizer code to signal syntax errors. */
90 /* Syntax errors that can be detected during memoization: */
92 /* Circular or improper lists do not form valid scheme expressions. If a
93 * circular list or an improper list is detected in a place where a scheme
94 * expression is expected, a 'Bad expression' error is signalled. */
95 static const char s_bad_expression
[] = "Bad expression";
97 /* If a form is detected that holds a different number of expressions than are
98 * required in that context, a 'Missing or extra expression' error is
100 static const char s_expression
[] = "Missing or extra expression in";
102 /* If a form is detected that holds less expressions than are required in that
103 * context, a 'Missing expression' error is signalled. */
104 static const char s_missing_expression
[] = "Missing expression in";
106 /* If a form is detected that holds more expressions than are allowed in that
107 * context, an 'Extra expression' error is signalled. */
108 static const char s_extra_expression
[] = "Extra expression in";
110 /* The empty combination '()' is not allowed as an expression in scheme. If
111 * it is detected in a place where an expression is expected, an 'Illegal
112 * empty combination' error is signalled. Note: If you encounter this error
113 * message, it is very likely that you intended to denote the empty list. To
114 * do so, you need to quote the empty list like (quote ()) or '(). */
115 static const char s_empty_combination
[] = "Illegal empty combination";
117 /* A body may hold an arbitrary number of internal defines, followed by a
118 * non-empty sequence of expressions. If a body with an empty sequence of
119 * expressions is detected, a 'Missing body expression' error is signalled.
121 static const char s_missing_body_expression
[] = "Missing body expression in";
123 /* A body may hold an arbitrary number of internal defines, followed by a
124 * non-empty sequence of expressions. Each the definitions and the
125 * expressions may be grouped arbitraryly with begin, but it is not allowed to
126 * mix definitions and expressions. If a define form in a body mixes
127 * definitions and expressions, a 'Mixed definitions and expressions' error is
129 static const char s_mixed_body_forms
[] = "Mixed definitions and expressions in";
130 /* Definitions are only allowed on the top level and at the start of a body.
131 * If a definition is detected anywhere else, a 'Bad define placement' error
133 static const char s_bad_define
[] = "Bad define placement";
135 /* Case or cond expressions must have at least one clause. If a case or cond
136 * expression without any clauses is detected, a 'Missing clauses' error is
138 static const char s_missing_clauses
[] = "Missing clauses";
140 /* If there is an 'else' clause in a case or a cond statement, it must be the
141 * last clause. If after the 'else' case clause further clauses are detected,
142 * a 'Misplaced else clause' error is signalled. */
143 static const char s_misplaced_else_clause
[] = "Misplaced else clause";
145 /* If a case clause is detected that is not in the format
146 * (<label(s)> <expression1> <expression2> ...)
147 * a 'Bad case clause' error is signalled. */
148 static const char s_bad_case_clause
[] = "Bad case clause";
150 /* If a case clause is detected where the <label(s)> element is neither a
151 * proper list nor (in case of the last clause) the syntactic keyword 'else',
152 * a 'Bad case labels' error is signalled. Note: If you encounter this error
153 * for an else-clause which seems to be syntactically correct, check if 'else'
154 * is really a syntactic keyword in that context. If 'else' is bound in the
155 * local or global environment, it is not considered a syntactic keyword, but
156 * will be treated as any other variable. */
157 static const char s_bad_case_labels
[] = "Bad case labels";
159 /* In a case statement all labels have to be distinct. If in a case statement
160 * a label occurs more than once, a 'Duplicate case label' error is
162 static const char s_duplicate_case_label
[] = "Duplicate case label";
164 /* If a cond clause is detected that is not in one of the formats
165 * (<test> <expression1> ...) or (else <expression1> <expression2> ...)
166 * a 'Bad cond clause' error is signalled. */
167 static const char s_bad_cond_clause
[] = "Bad cond clause";
169 /* If a cond clause is detected that uses the alternate '=>' form, but does
170 * not hold a recipient element for the test result, a 'Missing recipient'
171 * error is signalled. */
172 static const char s_missing_recipient
[] = "Missing recipient in";
174 /* If in a position where a variable name is required some other object is
175 * detected, a 'Bad variable' error is signalled. */
176 static const char s_bad_variable
[] = "Bad variable";
178 /* Bindings for forms like 'let' and 'do' have to be given in a proper,
179 * possibly empty list. If any other object is detected in a place where a
180 * list of bindings was required, a 'Bad bindings' error is signalled. */
181 static const char s_bad_bindings
[] = "Bad bindings";
183 /* Depending on the syntactic context, a binding has to be in the format
184 * (<variable> <expression>) or (<variable> <expression1> <expression2>).
185 * If anything else is detected in a place where a binding was expected, a
186 * 'Bad binding' error is signalled. */
187 static const char s_bad_binding
[] = "Bad binding";
189 /* Some syntactic forms don't allow variable names to appear more than once in
190 * a list of bindings. If such a situation is nevertheless detected, a
191 * 'Duplicate binding' error is signalled. */
192 static const char s_duplicate_binding
[] = "Duplicate binding";
194 /* If the exit form of a 'do' expression is not in the format
195 * (<test> <expression> ...)
196 * a 'Bad exit clause' error is signalled. */
197 static const char s_bad_exit_clause
[] = "Bad exit clause";
199 /* The formal function arguments of a lambda expression have to be either a
200 * single symbol or a non-cyclic list. For anything else a 'Bad formals'
201 * error is signalled. */
202 static const char s_bad_formals
[] = "Bad formals";
204 /* If in a lambda expression something else than a symbol is detected at a
205 * place where a formal function argument is required, a 'Bad formal' error is
207 static const char s_bad_formal
[] = "Bad formal";
209 /* If in the arguments list of a lambda expression an argument name occurs
210 * more than once, a 'Duplicate formal' error is signalled. */
211 static const char s_duplicate_formal
[] = "Duplicate formal";
213 /* If the evaluation of an unquote-splicing expression gives something else
214 * than a proper list, a 'Non-list result for unquote-splicing' error is
216 static const char s_splicing
[] = "Non-list result for unquote-splicing";
218 /* If something else than an exact integer is detected as the argument for
219 * @slot-ref and @slot-set!, a 'Bad slot number' error is signalled. */
220 static const char s_bad_slot_number
[] = "Bad slot number";
223 /* Signal a syntax error. We distinguish between the form that caused the
224 * error and the enclosing expression. The error message will print out as
225 * shown in the following pattern. The file name and line number are only
226 * given when they can be determined from the erroneous form or from the
227 * enclosing expression.
229 * <filename>: In procedure memoization:
230 * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
232 SCM_SYMBOL (syntax_error_key
, "syntax-error");
234 /* The prototype is needed to indicate that the function does not return. */
236 syntax_error (const char* const, const SCM
, const SCM
) SCM_NORETURN
;
239 syntax_error (const char* const msg
, const SCM form
, const SCM expr
)
241 SCM msg_string
= scm_from_locale_string (msg
);
242 SCM filename
= SCM_BOOL_F
;
243 SCM linenr
= SCM_BOOL_F
;
247 if (scm_is_pair (form
))
249 filename
= scm_source_property (form
, scm_sym_filename
);
250 linenr
= scm_source_property (form
, scm_sym_line
);
253 if (scm_is_false (filename
) && scm_is_false (linenr
) && scm_is_pair (expr
))
255 filename
= scm_source_property (expr
, scm_sym_filename
);
256 linenr
= scm_source_property (expr
, scm_sym_line
);
259 if (!SCM_UNBNDP (expr
))
261 if (scm_is_true (filename
))
263 format
= "In file ~S, line ~S: ~A ~S in expression ~S.";
264 args
= scm_list_5 (filename
, linenr
, msg_string
, form
, expr
);
266 else if (scm_is_true (linenr
))
268 format
= "In line ~S: ~A ~S in expression ~S.";
269 args
= scm_list_4 (linenr
, msg_string
, form
, expr
);
273 format
= "~A ~S in expression ~S.";
274 args
= scm_list_3 (msg_string
, form
, expr
);
279 if (scm_is_true (filename
))
281 format
= "In file ~S, line ~S: ~A ~S.";
282 args
= scm_list_4 (filename
, linenr
, msg_string
, form
);
284 else if (scm_is_true (linenr
))
286 format
= "In line ~S: ~A ~S.";
287 args
= scm_list_3 (linenr
, msg_string
, form
);
292 args
= scm_list_2 (msg_string
, form
);
296 scm_error (syntax_error_key
, "memoization", format
, args
, SCM_BOOL_F
);
300 /* Shortcut macros to simplify syntax error handling. */
301 #define ASSERT_SYNTAX(cond, message, form) \
302 { if (SCM_UNLIKELY (!(cond))) \
303 syntax_error (message, form, SCM_UNDEFINED); }
304 #define ASSERT_SYNTAX_2(cond, message, form, expr) \
305 { if (SCM_UNLIKELY (!(cond))) \
306 syntax_error (message, form, expr); }
308 static void error_unbound_variable (SCM symbol
) SCM_NORETURN
;
309 static void error_defined_variable (SCM symbol
) SCM_NORETURN
;
315 * Ilocs are memoized references to variables in local environment frames.
316 * They are represented as three values: The relative offset of the
317 * environment frame, the number of the binding within that frame, and a
318 * boolean value indicating whether the binding is the last binding in the
321 * Frame numbers have 11 bits, relative offsets have 12 bits.
324 #define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc)
325 #define SCM_IFRINC (0x00000100L)
326 #define SCM_ICDR (0x00080000L)
327 #define SCM_IDINC (0x00100000L)
328 #define SCM_IFRAME(n) ((long)((SCM_ICDR-SCM_IFRINC)>>8) \
329 & (SCM_UNPACK (n) >> 8))
330 #define SCM_IDIST(n) (SCM_UNPACK (n) >> 20)
331 #define SCM_ICDRP(n) (SCM_ICDR & SCM_UNPACK (n))
332 #define SCM_IDSTMSK (-SCM_IDINC)
333 #define SCM_IFRAMEMAX ((1<<11)-1)
334 #define SCM_IDISTMAX ((1<<12)-1)
335 #define SCM_MAKE_ILOC(frame_nr, binding_nr, last_p) \
338 + ((binding_nr) << 20) \
339 + ((last_p) ? SCM_ICDR : 0) \
343 scm_i_print_iloc (SCM iloc
, SCM port
)
345 scm_puts ("#@", port
);
346 scm_intprint ((long) SCM_IFRAME (iloc
), 10, port
);
347 scm_putc (SCM_ICDRP (iloc
) ? '-' : '+', port
);
348 scm_intprint ((long) SCM_IDIST (iloc
), 10, port
);
351 #if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
353 SCM
scm_dbg_make_iloc (SCM frame
, SCM binding
, SCM cdrp
);
355 SCM_DEFINE (scm_dbg_make_iloc
, "dbg-make-iloc", 3, 0, 0,
356 (SCM frame
, SCM binding
, SCM cdrp
),
357 "Return a new iloc with frame offset @var{frame}, binding\n"
358 "offset @var{binding} and the cdr flag @var{cdrp}.")
359 #define FUNC_NAME s_scm_dbg_make_iloc
361 return SCM_MAKE_ILOC ((scm_t_bits
) scm_to_unsigned_integer (frame
, 0, SCM_IFRAMEMAX
),
362 (scm_t_bits
) scm_to_unsigned_integer (binding
, 0, SCM_IDISTMAX
),
367 SCM
scm_dbg_iloc_p (SCM obj
);
369 SCM_DEFINE (scm_dbg_iloc_p
, "dbg-iloc?", 1, 0, 0,
371 "Return @code{#t} if @var{obj} is an iloc.")
372 #define FUNC_NAME s_scm_dbg_iloc_p
374 return scm_from_bool (SCM_ILOCP (obj
));
382 /* {Evaluator byte codes (isyms)}
385 #define ISYMNUM(n) (SCM_ITAG8_DATA (n))
387 /* This table must agree with the list of SCM_IM_ constants in tags.h */
388 static const char *const isymnames
[] =
405 "#@call-with-current-continuation",
410 "#@call-with-values",
418 scm_i_print_isym (SCM isym
, SCM port
)
420 const size_t isymnum
= ISYMNUM (isym
);
421 if (isymnum
< (sizeof isymnames
/ sizeof (char *)))
422 scm_puts (isymnames
[isymnum
], port
);
424 scm_ipruk ("isym", isym
, port
);
429 /* The function lookup_symbol is used during memoization: Lookup the symbol in
430 * the environment. If there is no binding for the symbol, SCM_UNDEFINED is
431 * returned. If the symbol is a global variable, the variable object to which
432 * the symbol is bound is returned. Finally, if the symbol is a local
433 * variable the corresponding iloc object is returned. */
435 /* A helper function for lookup_symbol: Try to find the symbol in the top
436 * level environment frame. The function returns SCM_UNDEFINED if the symbol
437 * is unbound and it returns a variable object if the symbol is a global
440 lookup_global_symbol (const SCM symbol
, const SCM top_level
)
442 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
443 if (scm_is_false (variable
))
444 return SCM_UNDEFINED
;
450 lookup_symbol (const SCM symbol
, const SCM env
)
453 unsigned int frame_nr
;
455 for (frame_idx
= env
, frame_nr
= 0;
456 !scm_is_null (frame_idx
);
457 frame_idx
= SCM_CDR (frame_idx
), ++frame_nr
)
459 const SCM frame
= SCM_CAR (frame_idx
);
460 if (scm_is_pair (frame
))
462 /* frame holds a local environment frame */
464 unsigned int symbol_nr
;
466 for (symbol_idx
= SCM_CAR (frame
), symbol_nr
= 0;
467 scm_is_pair (symbol_idx
);
468 symbol_idx
= SCM_CDR (symbol_idx
), ++symbol_nr
)
470 if (scm_is_eq (SCM_CAR (symbol_idx
), symbol
))
471 /* found the symbol, therefore return the iloc */
472 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 0);
474 if (scm_is_eq (symbol_idx
, symbol
))
475 /* found the symbol as the last element of the current frame */
476 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 1);
480 /* no more local environment frames */
481 return lookup_global_symbol (symbol
, frame
);
485 return lookup_global_symbol (symbol
, SCM_BOOL_F
);
489 /* Return true if the symbol is - from the point of view of a macro
490 * transformer - a literal in the sense specified in chapter "pattern
491 * language" of R5RS. In the code below, however, we don't match the
492 * definition of R5RS exactly: It returns true if the identifier has no
493 * binding or if it is a syntactic keyword. */
495 literal_p (const SCM symbol
, const SCM env
)
497 const SCM variable
= lookup_symbol (symbol
, env
);
498 if (SCM_UNBNDP (variable
))
500 if (SCM_VARIABLEP (variable
) && SCM_MACROP (SCM_VARIABLE_REF (variable
)))
507 /* Return true if the expression is self-quoting in the memoized code. Thus,
508 * some other objects (like e. g. vectors) are reported as self-quoting, which
509 * according to R5RS would need to be quoted. */
511 is_self_quoting_p (const SCM expr
)
513 if (scm_is_pair (expr
))
515 else if (scm_is_symbol (expr
))
517 else if (scm_is_null (expr
))
523 SCM_SYMBOL (sym_three_question_marks
, "???");
526 unmemoize_expression (const SCM expr
, const SCM env
)
528 if (SCM_ILOCP (expr
))
531 unsigned long int frame_nr
;
533 unsigned long int symbol_nr
;
535 for (frame_idx
= env
, frame_nr
= SCM_IFRAME (expr
);
537 frame_idx
= SCM_CDR (frame_idx
), --frame_nr
)
539 for (symbol_idx
= SCM_CAAR (frame_idx
), symbol_nr
= SCM_IDIST (expr
);
541 symbol_idx
= SCM_CDR (symbol_idx
), --symbol_nr
)
543 return SCM_ICDRP (expr
) ? symbol_idx
: SCM_CAR (symbol_idx
);
545 else if (SCM_VARIABLEP (expr
))
547 const SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), expr
);
548 return scm_is_true (sym
) ? sym
: sym_three_question_marks
;
550 else if (scm_is_simple_vector (expr
))
552 return scm_list_2 (scm_sym_quote
, expr
);
554 else if (!scm_is_pair (expr
))
558 else if (SCM_ISYMP (SCM_CAR (expr
)))
560 return unmemoize_builtin_macro (expr
, env
);
564 return unmemoize_exprs (expr
, env
);
570 unmemoize_exprs (const SCM exprs
, const SCM env
)
572 SCM r_result
= SCM_EOL
;
573 SCM expr_idx
= exprs
;
576 /* Note that due to the current lazy memoizer we may find partially memoized
577 * code during execution. In such code we have to expect improper lists of
578 * expressions: On the one hand, for such code syntax checks have not yet
579 * fully been performed, on the other hand, there may be even legal code
580 * like '(a . b) appear as an improper list of expressions as long as the
581 * quote expression is still in its unmemoized form. For this reason, the
582 * following code handles improper lists of expressions until memoization
583 * and execution have been completely separated. */
584 for (; scm_is_pair (expr_idx
); expr_idx
= SCM_CDR (expr_idx
))
586 const SCM expr
= SCM_CAR (expr_idx
);
588 /* In partially memoized code, lists of expressions that stem from a
589 * body form may start with an ISYM if the body itself has not yet been
590 * memoized. This isym is just an internal marker to indicate that the
591 * body still needs to be memoized. An isym may occur at the very
592 * beginning of the body or after one or more comment strings. It is
593 * dropped during unmemoization. */
594 if (!SCM_ISYMP (expr
))
596 um_expr
= unmemoize_expression (expr
, env
);
597 r_result
= scm_cons (um_expr
, r_result
);
600 um_expr
= unmemoize_expression (expr_idx
, env
);
601 if (!scm_is_null (r_result
))
603 const SCM result
= scm_reverse_x (r_result
, SCM_UNDEFINED
);
604 SCM_SETCDR (r_result
, um_expr
);
614 /* Rewrite the body (which is given as the list of expressions forming the
615 * body) into its internal form. The internal form of a body (<expr> ...) is
616 * just the body itself, but prefixed with an ISYM that denotes to what kind
617 * of outer construct this body belongs: (<ISYM> <expr> ...). A lambda body
618 * starts with SCM_IM_LAMBDA, for example, a body of a let starts with
621 * It is assumed that the calling expression has already made sure that the
622 * body is a proper list. */
624 m_body (SCM op
, SCM exprs
)
626 /* Don't add another ISYM if one is present already. */
627 if (SCM_ISYMP (SCM_CAR (exprs
)))
630 return scm_cons (op
, exprs
);
634 /* The function m_expand_body memoizes a proper list of expressions forming a
635 * body. This function takes care of dealing with internal defines and
636 * transforming them into an equivalent letrec expression. The list of
637 * expressions is rewritten in place. */
639 /* This is a helper function for m_expand_body. If the argument expression is
640 * a symbol that denotes a syntactic keyword, the corresponding macro object
641 * is returned, in all other cases the function returns SCM_UNDEFINED. */
643 try_macro_lookup (const SCM expr
, const SCM env
)
645 if (scm_is_symbol (expr
))
647 const SCM variable
= lookup_symbol (expr
, env
);
648 if (SCM_VARIABLEP (variable
))
650 const SCM value
= SCM_VARIABLE_REF (variable
);
651 if (SCM_MACROP (value
))
656 return SCM_UNDEFINED
;
659 /* This is a helper function for m_expand_body. It expands user macros,
660 * because for the correct translation of a body we need to know whether they
661 * expand to a definition. */
663 expand_user_macros (SCM expr
, const SCM env
)
665 while (scm_is_pair (expr
))
667 const SCM car_expr
= SCM_CAR (expr
);
668 const SCM new_car
= expand_user_macros (car_expr
, env
);
669 const SCM value
= try_macro_lookup (new_car
, env
);
671 if (SCM_MACROP (value
) && SCM_MACRO_TYPE (value
) == 2)
673 /* User macros transform code into code. */
674 expr
= scm_call_2 (SCM_MACRO_CODE (value
), expr
, env
);
675 /* We need to reiterate on the transformed code. */
679 /* No user macro: return. */
680 SCM_SETCAR (expr
, new_car
);
688 /* This is a helper function for m_expand_body. It determines if a given form
689 * represents an application of a given built-in macro. The built-in macro to
690 * check for is identified by its syntactic keyword. The form is an
691 * application of the given macro if looking up the car of the form in the
692 * given environment actually returns the built-in macro. */
694 is_system_macro_p (const SCM syntactic_keyword
, const SCM form
, const SCM env
)
696 if (scm_is_pair (form
))
698 const SCM car_form
= SCM_CAR (form
);
699 const SCM value
= try_macro_lookup (car_form
, env
);
700 if (SCM_BUILTIN_MACRO_P (value
))
702 const SCM macro_name
= scm_macro_name (value
);
703 return scm_is_eq (macro_name
, syntactic_keyword
);
711 macroexp (SCM x
, SCM env
)
713 SCM res
, proc
, orig_sym
;
715 /* Don't bother to produce error messages here. We get them when we
716 eventually execute the code for real. */
719 orig_sym
= SCM_CAR (x
);
720 if (!scm_is_symbol (orig_sym
))
724 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
725 if (proc_ptr
== NULL
)
727 /* We have lost the race. */
733 /* Only handle memoizing macros. `Acros' and `macros' are really
734 special forms and should not be evaluated here. */
736 if (!SCM_MACROP (proc
)
737 || (SCM_MACRO_TYPE (proc
) != 2 && !SCM_BUILTIN_MACRO_P (proc
)))
740 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
741 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
743 if (scm_ilength (res
) <= 0)
744 /* Result of expansion is not a list. */
745 return (scm_list_2 (SCM_IM_BEGIN
, res
));
748 /* njrev: Several queries here: (1) I don't see how it can be
749 correct that the SCM_SETCAR 2 lines below this comment needs
750 protection, but the SCM_SETCAR 6 lines above does not, so
751 something here is probably wrong. (2) macroexp() is now only
752 used in one place - scm_m_generalized_set_x - whereas all other
753 macro expansion happens through expand_user_macros. Therefore
754 (2.1) perhaps macroexp() could be eliminated completely now?
755 (2.2) Does expand_user_macros need any critical section
758 SCM_CRITICAL_SECTION_START
;
759 SCM_SETCAR (x
, SCM_CAR (res
));
760 SCM_SETCDR (x
, SCM_CDR (res
));
761 SCM_CRITICAL_SECTION_END
;
768 /* Start of the memoizers for the standard R5RS builtin macros. */
770 static SCM
scm_m_quote (SCM xorig
, SCM env
);
771 static SCM
scm_m_begin (SCM xorig
, SCM env
);
772 static SCM
scm_m_if (SCM xorig
, SCM env
);
773 static SCM
scm_m_set_x (SCM xorig
, SCM env
);
774 static SCM
scm_m_and (SCM xorig
, SCM env
);
775 static SCM
scm_m_or (SCM xorig
, SCM env
);
776 static SCM
scm_m_case (SCM xorig
, SCM env
);
777 static SCM
scm_m_cond (SCM xorig
, SCM env
);
778 static SCM
scm_m_lambda (SCM xorig
, SCM env
);
779 static SCM
scm_m_letstar (SCM xorig
, SCM env
);
780 static SCM
scm_m_do (SCM xorig
, SCM env
);
781 static SCM
scm_m_quasiquote (SCM xorig
, SCM env
);
782 static SCM
scm_m_delay (SCM xorig
, SCM env
);
783 static SCM
scm_m_generalized_set_x (SCM xorig
, SCM env
);
784 static SCM
scm_m_define (SCM x
, SCM env
);
785 static SCM
scm_m_letrec (SCM xorig
, SCM env
);
786 static SCM
scm_m_let (SCM xorig
, SCM env
);
787 static SCM
scm_m_at (SCM xorig
, SCM env
);
788 static SCM
scm_m_atat (SCM xorig
, SCM env
);
789 static SCM
scm_m_atslot_ref (SCM xorig
, SCM env
);
790 static SCM
scm_m_atslot_set_x (SCM xorig
, SCM env
);
791 static SCM
scm_m_apply (SCM xorig
, SCM env
);
792 static SCM
scm_m_cont (SCM xorig
, SCM env
);
794 static SCM
scm_m_nil_cond (SCM xorig
, SCM env
);
795 static SCM
scm_m_atfop (SCM xorig
, SCM env
);
796 #endif /* SCM_ENABLE_ELISP */
797 static SCM
scm_m_atbind (SCM xorig
, SCM env
);
798 static SCM
scm_m_at_call_with_values (SCM xorig
, SCM env
);
799 static SCM
scm_m_eval_when (SCM xorig
, SCM env
);
803 m_expand_body (const SCM forms
, const SCM env
)
805 /* The first body form can be skipped since it is known to be the ISYM that
806 * was prepended to the body by m_body. */
807 SCM cdr_forms
= SCM_CDR (forms
);
808 SCM form_idx
= cdr_forms
;
809 SCM definitions
= SCM_EOL
;
810 SCM sequence
= SCM_EOL
;
812 /* According to R5RS, the list of body forms consists of two parts: a number
813 * (maybe zero) of definitions, followed by a non-empty sequence of
814 * expressions. Each the definitions and the expressions may be grouped
815 * arbitrarily with begin, but it is not allowed to mix definitions and
816 * expressions. The task of the following loop therefore is to split the
817 * list of body forms into the list of definitions and the sequence of
819 while (!scm_is_null (form_idx
))
821 const SCM form
= SCM_CAR (form_idx
);
822 const SCM new_form
= expand_user_macros (form
, env
);
823 if (is_system_macro_p (scm_sym_define
, new_form
, env
))
825 definitions
= scm_cons (new_form
, definitions
);
826 form_idx
= SCM_CDR (form_idx
);
828 else if (is_system_macro_p (scm_sym_begin
, new_form
, env
))
830 /* We have encountered a group of forms. This has to be either a
831 * (possibly empty) group of (possibly further grouped) definitions,
832 * or a non-empty group of (possibly further grouped)
834 const SCM grouped_forms
= SCM_CDR (new_form
);
835 unsigned int found_definition
= 0;
836 unsigned int found_expression
= 0;
837 SCM grouped_form_idx
= grouped_forms
;
838 while (!found_expression
&& !scm_is_null (grouped_form_idx
))
840 const SCM inner_form
= SCM_CAR (grouped_form_idx
);
841 const SCM new_inner_form
= expand_user_macros (inner_form
, env
);
842 if (is_system_macro_p (scm_sym_define
, new_inner_form
, env
))
844 found_definition
= 1;
845 definitions
= scm_cons (new_inner_form
, definitions
);
846 grouped_form_idx
= SCM_CDR (grouped_form_idx
);
848 else if (is_system_macro_p (scm_sym_begin
, new_inner_form
, env
))
850 const SCM inner_group
= SCM_CDR (new_inner_form
);
852 = scm_append (scm_list_2 (inner_group
,
853 SCM_CDR (grouped_form_idx
)));
857 /* The group marks the start of the expressions of the body.
858 * We have to make sure that within the same group we have
859 * not encountered a definition before. */
860 ASSERT_SYNTAX (!found_definition
, s_mixed_body_forms
, form
);
861 found_expression
= 1;
862 grouped_form_idx
= SCM_EOL
;
866 /* We have finished processing the group. If we have not yet
867 * encountered an expression we continue processing the forms of the
868 * body to collect further definition forms. Otherwise, the group
869 * marks the start of the sequence of expressions of the body. */
870 if (!found_expression
)
872 form_idx
= SCM_CDR (form_idx
);
882 /* We have detected a form which is no definition. This marks the
883 * start of the sequence of expressions of the body. */
889 /* FIXME: forms does not hold information about the file location. */
890 ASSERT_SYNTAX (scm_is_pair (sequence
), s_missing_body_expression
, cdr_forms
);
892 if (!scm_is_null (definitions
))
896 SCM letrec_expression
;
897 SCM new_letrec_expression
;
899 SCM bindings
= SCM_EOL
;
900 for (definition_idx
= definitions
;
901 !scm_is_null (definition_idx
);
902 definition_idx
= SCM_CDR (definition_idx
))
904 const SCM definition
= SCM_CAR (definition_idx
);
905 const SCM canonical_definition
= canonicalize_define (definition
);
906 const SCM binding
= SCM_CDR (canonical_definition
);
907 bindings
= scm_cons (binding
, bindings
);
910 letrec_tail
= scm_cons (bindings
, sequence
);
911 /* FIXME: forms does not hold information about the file location. */
912 letrec_expression
= scm_cons_source (forms
, scm_sym_letrec
, letrec_tail
);
913 new_letrec_expression
= scm_m_letrec (letrec_expression
, env
);
914 SCM_SETCAR (forms
, new_letrec_expression
);
915 SCM_SETCDR (forms
, SCM_EOL
);
919 SCM_SETCAR (forms
, SCM_CAR (sequence
));
920 SCM_SETCDR (forms
, SCM_CDR (sequence
));
924 SCM_SYNTAX (s_and
, "and", scm_i_makbimacro
, scm_m_and
);
925 SCM_GLOBAL_SYMBOL (scm_sym_and
, "and");
928 scm_m_and (SCM expr
, SCM env SCM_UNUSED
)
930 const SCM cdr_expr
= SCM_CDR (expr
);
931 const long length
= scm_ilength (cdr_expr
);
933 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
937 /* Special case: (and) is replaced by #t. */
942 SCM_SETCAR (expr
, SCM_IM_AND
);
948 unmemoize_and (const SCM expr
, const SCM env
)
950 return scm_cons (scm_sym_and
, unmemoize_exprs (SCM_CDR (expr
), env
));
954 SCM_SYNTAX (s_begin
, "begin", scm_i_makbimacro
, scm_m_begin
);
955 SCM_GLOBAL_SYMBOL (scm_sym_begin
, "begin");
958 scm_m_begin (SCM expr
, SCM env SCM_UNUSED
)
960 const SCM cdr_expr
= SCM_CDR (expr
);
961 /* Dirk:FIXME:: An empty begin clause is not generally allowed by R5RS.
962 * That means, there should be a distinction between uses of begin where an
963 * empty clause is OK and where it is not. */
964 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
966 SCM_SETCAR (expr
, SCM_IM_BEGIN
);
971 unmemoize_begin (const SCM expr
, const SCM env
)
973 return scm_cons (scm_sym_begin
, unmemoize_exprs (SCM_CDR (expr
), env
));
977 SCM_SYNTAX (s_case
, "case", scm_i_makbimacro
, scm_m_case
);
978 SCM_GLOBAL_SYMBOL (scm_sym_case
, "case");
979 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
982 scm_m_case (SCM expr
, SCM env
)
985 SCM all_labels
= SCM_EOL
;
987 /* Check, whether 'else is a literal, i. e. not bound to a value. */
988 const int else_literal_p
= literal_p (scm_sym_else
, env
);
990 const SCM cdr_expr
= SCM_CDR (expr
);
991 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
992 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_clauses
, expr
);
994 clauses
= SCM_CDR (cdr_expr
);
995 while (!scm_is_null (clauses
))
999 const SCM clause
= SCM_CAR (clauses
);
1000 ASSERT_SYNTAX_2 (scm_ilength (clause
) >= 2,
1001 s_bad_case_clause
, clause
, expr
);
1003 labels
= SCM_CAR (clause
);
1004 if (scm_is_pair (labels
))
1006 ASSERT_SYNTAX_2 (scm_ilength (labels
) >= 0,
1007 s_bad_case_labels
, labels
, expr
);
1008 all_labels
= scm_append (scm_list_2 (labels
, all_labels
));
1010 else if (scm_is_null (labels
))
1012 /* The list of labels is empty. According to R5RS this is allowed.
1013 * It means that the sequence of expressions will never be executed.
1014 * Therefore, as an optimization, we could remove the whole
1019 ASSERT_SYNTAX_2 (scm_is_eq (labels
, scm_sym_else
) && else_literal_p
,
1020 s_bad_case_labels
, labels
, expr
);
1021 ASSERT_SYNTAX_2 (scm_is_null (SCM_CDR (clauses
)),
1022 s_misplaced_else_clause
, clause
, expr
);
1025 /* build the new clause */
1026 if (scm_is_eq (labels
, scm_sym_else
))
1027 SCM_SETCAR (clause
, SCM_IM_ELSE
);
1029 clauses
= SCM_CDR (clauses
);
1032 /* Check whether all case labels are distinct. */
1033 for (; !scm_is_null (all_labels
); all_labels
= SCM_CDR (all_labels
))
1035 const SCM label
= SCM_CAR (all_labels
);
1036 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (label
, SCM_CDR (all_labels
))),
1037 s_duplicate_case_label
, label
, expr
);
1040 SCM_SETCAR (expr
, SCM_IM_CASE
);
1045 unmemoize_case (const SCM expr
, const SCM env
)
1047 const SCM um_key_expr
= unmemoize_expression (SCM_CADR (expr
), env
);
1048 SCM um_clauses
= SCM_EOL
;
1051 for (clause_idx
= SCM_CDDR (expr
);
1052 !scm_is_null (clause_idx
);
1053 clause_idx
= SCM_CDR (clause_idx
))
1055 const SCM clause
= SCM_CAR (clause_idx
);
1056 const SCM labels
= SCM_CAR (clause
);
1057 const SCM exprs
= SCM_CDR (clause
);
1059 const SCM um_exprs
= unmemoize_exprs (exprs
, env
);
1060 const SCM um_labels
= (scm_is_eq (labels
, SCM_IM_ELSE
))
1062 : scm_i_finite_list_copy (labels
);
1063 const SCM um_clause
= scm_cons (um_labels
, um_exprs
);
1065 um_clauses
= scm_cons (um_clause
, um_clauses
);
1067 um_clauses
= scm_reverse_x (um_clauses
, SCM_UNDEFINED
);
1069 return scm_cons2 (scm_sym_case
, um_key_expr
, um_clauses
);
1073 SCM_SYNTAX (s_cond
, "cond", scm_i_makbimacro
, scm_m_cond
);
1074 SCM_GLOBAL_SYMBOL (scm_sym_cond
, "cond");
1075 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
1078 scm_m_cond (SCM expr
, SCM env
)
1080 /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
1081 const int else_literal_p
= literal_p (scm_sym_else
, env
);
1082 const int arrow_literal_p
= literal_p (scm_sym_arrow
, env
);
1084 const SCM clauses
= SCM_CDR (expr
);
1087 ASSERT_SYNTAX (scm_ilength (clauses
) >= 0, s_bad_expression
, expr
);
1088 ASSERT_SYNTAX (scm_ilength (clauses
) >= 1, s_missing_clauses
, expr
);
1090 for (clause_idx
= clauses
;
1091 !scm_is_null (clause_idx
);
1092 clause_idx
= SCM_CDR (clause_idx
))
1096 const SCM clause
= SCM_CAR (clause_idx
);
1097 const long length
= scm_ilength (clause
);
1098 ASSERT_SYNTAX_2 (length
>= 1, s_bad_cond_clause
, clause
, expr
);
1100 test
= SCM_CAR (clause
);
1101 if (scm_is_eq (test
, scm_sym_else
) && else_literal_p
)
1103 const int last_clause_p
= scm_is_null (SCM_CDR (clause_idx
));
1104 ASSERT_SYNTAX_2 (length
>= 2,
1105 s_bad_cond_clause
, clause
, expr
);
1106 ASSERT_SYNTAX_2 (last_clause_p
,
1107 s_misplaced_else_clause
, clause
, expr
);
1108 SCM_SETCAR (clause
, SCM_IM_ELSE
);
1110 else if (length
>= 2
1111 && scm_is_eq (SCM_CADR (clause
), scm_sym_arrow
)
1114 ASSERT_SYNTAX_2 (length
> 2, s_missing_recipient
, clause
, expr
);
1115 ASSERT_SYNTAX_2 (length
== 3, s_extra_expression
, clause
, expr
);
1116 SCM_SETCAR (SCM_CDR (clause
), SCM_IM_ARROW
);
1118 /* SRFI 61 extended cond */
1119 else if (length
>= 3
1120 && scm_is_eq (SCM_CADDR (clause
), scm_sym_arrow
)
1123 ASSERT_SYNTAX_2 (length
> 3, s_missing_recipient
, clause
, expr
);
1124 ASSERT_SYNTAX_2 (length
== 4, s_extra_expression
, clause
, expr
);
1125 SCM_SETCAR (SCM_CDDR (clause
), SCM_IM_ARROW
);
1129 SCM_SETCAR (expr
, SCM_IM_COND
);
1134 unmemoize_cond (const SCM expr
, const SCM env
)
1136 SCM um_clauses
= SCM_EOL
;
1139 for (clause_idx
= SCM_CDR (expr
);
1140 !scm_is_null (clause_idx
);
1141 clause_idx
= SCM_CDR (clause_idx
))
1143 const SCM clause
= SCM_CAR (clause_idx
);
1144 const SCM sequence
= SCM_CDR (clause
);
1145 const SCM test
= SCM_CAR (clause
);
1150 if (scm_is_eq (test
, SCM_IM_ELSE
))
1151 um_test
= scm_sym_else
;
1153 um_test
= unmemoize_expression (test
, env
);
1155 if (!scm_is_null (sequence
) && scm_is_eq (SCM_CAR (sequence
),
1158 const SCM target
= SCM_CADR (sequence
);
1159 const SCM um_target
= unmemoize_expression (target
, env
);
1160 um_sequence
= scm_list_2 (scm_sym_arrow
, um_target
);
1164 um_sequence
= unmemoize_exprs (sequence
, env
);
1167 um_clause
= scm_cons (um_test
, um_sequence
);
1168 um_clauses
= scm_cons (um_clause
, um_clauses
);
1170 um_clauses
= scm_reverse_x (um_clauses
, SCM_UNDEFINED
);
1172 return scm_cons (scm_sym_cond
, um_clauses
);
1176 SCM_SYNTAX (s_define
, "define", scm_i_makbimacro
, scm_m_define
);
1177 SCM_GLOBAL_SYMBOL (scm_sym_define
, "define");
1179 /* Guile provides an extension to R5RS' define syntax to represent function
1180 * currying in a compact way. With this extension, it is allowed to write
1181 * (define <nested-variable> <body>), where <nested-variable> has of one of
1182 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
1183 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
1184 * should be either a sequence of zero or more variables, or a sequence of one
1185 * or more variables followed by a space-delimited period and another
1186 * variable. Each level of argument nesting wraps the <body> within another
1187 * lambda expression. For example, the following forms are allowed, each one
1188 * followed by an equivalent, more explicit implementation.
1190 * (define ((a b . c) . d) <body>) is equivalent to
1191 * (define a (lambda (b . c) (lambda d <body>)))
1193 * (define (((a) b) c . d) <body>) is equivalent to
1194 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
1196 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
1197 * module that does not implement this extension. */
1199 canonicalize_define (const SCM expr
)
1204 const SCM cdr_expr
= SCM_CDR (expr
);
1205 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1206 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1208 body
= SCM_CDR (cdr_expr
);
1209 variable
= SCM_CAR (cdr_expr
);
1210 while (scm_is_pair (variable
))
1212 /* This while loop realizes function currying by variable nesting.
1213 * Variable is known to be a nested-variable. In every iteration of the
1214 * loop another level of lambda expression is created, starting with the
1215 * innermost one. Note that we don't check for duplicate formals here:
1216 * This will be done by the memoizer of the lambda expression. */
1217 const SCM formals
= SCM_CDR (variable
);
1218 const SCM tail
= scm_cons (formals
, body
);
1220 /* Add source properties to each new lambda expression: */
1221 const SCM lambda
= scm_cons_source (variable
, scm_sym_lambda
, tail
);
1223 body
= scm_list_1 (lambda
);
1224 variable
= SCM_CAR (variable
);
1226 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
1227 ASSERT_SYNTAX (scm_ilength (body
) == 1, s_expression
, expr
);
1229 SCM_SETCAR (cdr_expr
, variable
);
1230 SCM_SETCDR (cdr_expr
, body
);
1234 /* According to Section 5.2.1 of R5RS we first have to make sure that the
1235 variable is bound, and then perform the `(set! variable expression)'
1236 operation. However, EXPRESSION _can_ be evaluated before VARIABLE is
1237 bound. This means that EXPRESSION won't necessarily be able to assign
1238 values to VARIABLE as in `(define foo (begin (set! foo 1) (+ foo 1)))'. */
1240 scm_m_define (SCM expr
, SCM env
)
1242 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), s_bad_define
, expr
);
1245 const SCM canonical_definition
= canonicalize_define (expr
);
1246 const SCM cdr_canonical_definition
= SCM_CDR (canonical_definition
);
1247 const SCM variable
= SCM_CAR (cdr_canonical_definition
);
1248 const SCM value
= scm_eval_car (SCM_CDR (cdr_canonical_definition
), env
);
1250 = scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_T
);
1252 if (SCM_REC_PROCNAMES_P
)
1255 while (SCM_MACROP (tmp
))
1256 tmp
= SCM_MACRO_CODE (tmp
);
1257 if (scm_is_true (scm_procedure_p (tmp
))
1258 /* Only the first definition determines the name. */
1259 && scm_is_false (scm_procedure_property (tmp
, scm_sym_name
)))
1260 scm_set_procedure_property_x (tmp
, scm_sym_name
, variable
);
1263 SCM_VARIABLE_SET (location
, value
);
1265 return SCM_UNSPECIFIED
;
1270 /* This is a helper function for forms (<keyword> <expression>) that are
1271 * transformed into (#@<keyword> '() <memoized_expression>) in order to allow
1272 * for easy creation of a thunk (i. e. a closure without arguments) using the
1273 * ('() <memoized_expression>) tail of the memoized form. */
1275 memoize_as_thunk_prototype (const SCM expr
, const SCM env SCM_UNUSED
)
1277 const SCM cdr_expr
= SCM_CDR (expr
);
1278 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1279 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1281 SCM_SETCDR (expr
, scm_cons (SCM_EOL
, cdr_expr
));
1287 SCM_SYNTAX (s_delay
, "delay", scm_i_makbimacro
, scm_m_delay
);
1288 SCM_GLOBAL_SYMBOL (scm_sym_delay
, "delay");
1290 /* Promises are implemented as closures with an empty parameter list. Thus,
1291 * (delay <expression>) is transformed into (#@delay '() <expression>), where
1292 * the empty list represents the empty parameter list. This representation
1293 * allows for easy creation of the closure during evaluation. */
1295 scm_m_delay (SCM expr
, SCM env
)
1297 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1298 SCM_SETCAR (new_expr
, SCM_IM_DELAY
);
1303 unmemoize_delay (const SCM expr
, const SCM env
)
1305 const SCM thunk_expr
= SCM_CADDR (expr
);
1306 /* A promise is implemented as a closure, and when applying a
1307 closure the evaluator adds a new frame to the environment - even
1308 though, in the case of a promise, the added frame is always
1309 empty. We need to extend the environment here in the same way,
1310 so that any ILOCs in thunk_expr can be unmemoized correctly. */
1311 const SCM new_env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1312 return scm_list_2 (scm_sym_delay
, unmemoize_expression (thunk_expr
, new_env
));
1316 SCM_SYNTAX(s_do
, "do", scm_i_makbimacro
, scm_m_do
);
1317 SCM_GLOBAL_SYMBOL(scm_sym_do
, "do");
1319 /* DO gets the most radically altered syntax. The order of the vars is
1320 * reversed here. During the evaluation this allows for simple consing of the
1321 * results of the inits and steps:
1323 (do ((<var1> <init1> <step1>)
1331 (#@do (<init1> <init2> ... <initn>)
1332 (varn ... var2 var1)
1335 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
1338 scm_m_do (SCM expr
, SCM env SCM_UNUSED
)
1340 SCM variables
= SCM_EOL
;
1341 SCM init_forms
= SCM_EOL
;
1342 SCM step_forms
= SCM_EOL
;
1349 const SCM cdr_expr
= SCM_CDR (expr
);
1350 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1351 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1353 /* Collect variables, init and step forms. */
1354 binding_idx
= SCM_CAR (cdr_expr
);
1355 ASSERT_SYNTAX_2 (scm_ilength (binding_idx
) >= 0,
1356 s_bad_bindings
, binding_idx
, expr
);
1357 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1359 const SCM binding
= SCM_CAR (binding_idx
);
1360 const long length
= scm_ilength (binding
);
1361 ASSERT_SYNTAX_2 (length
== 2 || length
== 3,
1362 s_bad_binding
, binding
, expr
);
1365 const SCM name
= SCM_CAR (binding
);
1366 const SCM init
= SCM_CADR (binding
);
1367 const SCM step
= (length
== 2) ? name
: SCM_CADDR (binding
);
1368 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
1369 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, variables
)),
1370 s_duplicate_binding
, name
, expr
);
1372 variables
= scm_cons (name
, variables
);
1373 init_forms
= scm_cons (init
, init_forms
);
1374 step_forms
= scm_cons (step
, step_forms
);
1377 init_forms
= scm_reverse_x (init_forms
, SCM_UNDEFINED
);
1378 step_forms
= scm_reverse_x (step_forms
, SCM_UNDEFINED
);
1380 /* Memoize the test form and the exit sequence. */
1381 cddr_expr
= SCM_CDR (cdr_expr
);
1382 exit_clause
= SCM_CAR (cddr_expr
);
1383 ASSERT_SYNTAX_2 (scm_ilength (exit_clause
) >= 1,
1384 s_bad_exit_clause
, exit_clause
, expr
);
1386 commands
= SCM_CDR (cddr_expr
);
1387 tail
= scm_cons2 (exit_clause
, commands
, step_forms
);
1388 tail
= scm_cons2 (init_forms
, variables
, tail
);
1389 SCM_SETCAR (expr
, SCM_IM_DO
);
1390 SCM_SETCDR (expr
, tail
);
1395 unmemoize_do (const SCM expr
, const SCM env
)
1397 const SCM cdr_expr
= SCM_CDR (expr
);
1398 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1399 const SCM rnames
= SCM_CAR (cddr_expr
);
1400 const SCM extended_env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
1401 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
1402 const SCM exit_sequence
= SCM_CAR (cdddr_expr
);
1403 const SCM um_exit_sequence
= unmemoize_exprs (exit_sequence
, extended_env
);
1404 const SCM cddddr_expr
= SCM_CDR (cdddr_expr
);
1405 const SCM um_body
= unmemoize_exprs (SCM_CAR (cddddr_expr
), extended_env
);
1407 /* build transformed binding list */
1408 SCM um_names
= scm_reverse (rnames
);
1409 SCM um_inits
= unmemoize_exprs (SCM_CAR (cdr_expr
), env
);
1410 SCM um_steps
= unmemoize_exprs (SCM_CDR (cddddr_expr
), extended_env
);
1411 SCM um_bindings
= SCM_EOL
;
1412 while (!scm_is_null (um_names
))
1414 const SCM name
= SCM_CAR (um_names
);
1415 const SCM init
= SCM_CAR (um_inits
);
1416 SCM step
= SCM_CAR (um_steps
);
1417 step
= scm_is_eq (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
1419 um_bindings
= scm_cons (scm_cons2 (name
, init
, step
), um_bindings
);
1421 um_names
= SCM_CDR (um_names
);
1422 um_inits
= SCM_CDR (um_inits
);
1423 um_steps
= SCM_CDR (um_steps
);
1425 um_bindings
= scm_reverse_x (um_bindings
, SCM_UNDEFINED
);
1427 return scm_cons (scm_sym_do
,
1428 scm_cons2 (um_bindings
, um_exit_sequence
, um_body
));
1432 SCM_SYNTAX (s_if
, "if", scm_i_makbimacro
, scm_m_if
);
1433 SCM_GLOBAL_SYMBOL (scm_sym_if
, "if");
1436 scm_m_if (SCM expr
, SCM env SCM_UNUSED
)
1438 const SCM cdr_expr
= SCM_CDR (expr
);
1439 const long length
= scm_ilength (cdr_expr
);
1440 ASSERT_SYNTAX (length
== 2 || length
== 3, s_expression
, expr
);
1441 SCM_SETCAR (expr
, SCM_IM_IF
);
1446 unmemoize_if (const SCM expr
, const SCM env
)
1448 const SCM cdr_expr
= SCM_CDR (expr
);
1449 const SCM um_condition
= unmemoize_expression (SCM_CAR (cdr_expr
), env
);
1450 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1451 const SCM um_then
= unmemoize_expression (SCM_CAR (cddr_expr
), env
);
1452 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
1454 if (scm_is_null (cdddr_expr
))
1456 return scm_list_3 (scm_sym_if
, um_condition
, um_then
);
1460 const SCM um_else
= unmemoize_expression (SCM_CAR (cdddr_expr
), env
);
1461 return scm_list_4 (scm_sym_if
, um_condition
, um_then
, um_else
);
1466 SCM_SYNTAX (s_lambda
, "lambda", scm_i_makbimacro
, scm_m_lambda
);
1467 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, "lambda");
1469 /* A helper function for memoize_lambda to support checking for duplicate
1470 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
1471 * LIST or to the cdr of the last cons. Therefore, LIST may have any of the
1472 * forms that a formal argument can have:
1473 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
1475 c_improper_memq (SCM obj
, SCM list
)
1477 for (; scm_is_pair (list
); list
= SCM_CDR (list
))
1479 if (scm_is_eq (SCM_CAR (list
), obj
))
1482 return scm_is_eq (list
, obj
);
1486 scm_m_lambda (SCM expr
, SCM env SCM_UNUSED
)
1495 const SCM cdr_expr
= SCM_CDR (expr
);
1496 const long length
= scm_ilength (cdr_expr
);
1497 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1498 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1500 /* Before iterating the list of formal arguments, make sure the formals
1501 * actually are given as either a symbol or a non-cyclic list. */
1502 formals
= SCM_CAR (cdr_expr
);
1503 if (scm_is_pair (formals
))
1505 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
1506 * detected, report a 'Bad formals' error. */
1510 ASSERT_SYNTAX_2 (scm_is_symbol (formals
) || scm_is_null (formals
),
1511 s_bad_formals
, formals
, expr
);
1514 /* Now iterate the list of formal arguments to check if all formals are
1515 * symbols, and that there are no duplicates. */
1516 formals_idx
= formals
;
1517 while (scm_is_pair (formals_idx
))
1519 const SCM formal
= SCM_CAR (formals_idx
);
1520 const SCM next_idx
= SCM_CDR (formals_idx
);
1521 ASSERT_SYNTAX_2 (scm_is_symbol (formal
), s_bad_formal
, formal
, expr
);
1522 ASSERT_SYNTAX_2 (!c_improper_memq (formal
, next_idx
),
1523 s_duplicate_formal
, formal
, expr
);
1524 formals_idx
= next_idx
;
1526 ASSERT_SYNTAX_2 (scm_is_null (formals_idx
) || scm_is_symbol (formals_idx
),
1527 s_bad_formal
, formals_idx
, expr
);
1529 /* Memoize the body. Keep a potential documentation string. */
1530 /* Dirk:FIXME:: We should probably extract the documentation string to
1531 * some external database. Otherwise it will slow down execution, since
1532 * the documentation string will have to be skipped with every execution
1533 * of the closure. */
1534 cddr_expr
= SCM_CDR (cdr_expr
);
1535 documentation
= (length
>= 3 && scm_is_string (SCM_CAR (cddr_expr
)));
1536 body
= documentation
? SCM_CDR (cddr_expr
) : cddr_expr
;
1537 new_body
= m_body (SCM_IM_LAMBDA
, body
);
1539 SCM_SETCAR (expr
, SCM_IM_LAMBDA
);
1541 SCM_SETCDR (cddr_expr
, new_body
);
1543 SCM_SETCDR (cdr_expr
, new_body
);
1548 unmemoize_lambda (const SCM expr
, const SCM env
)
1550 const SCM formals
= SCM_CADR (expr
);
1551 const SCM body
= SCM_CDDR (expr
);
1553 const SCM new_env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, env
);
1554 const SCM um_formals
= scm_i_finite_list_copy (formals
);
1555 const SCM um_body
= unmemoize_exprs (body
, new_env
);
1557 return scm_cons2 (scm_sym_lambda
, um_formals
, um_body
);
1561 /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
1563 check_bindings (const SCM bindings
, const SCM expr
)
1567 ASSERT_SYNTAX_2 (scm_ilength (bindings
) >= 0,
1568 s_bad_bindings
, bindings
, expr
);
1570 binding_idx
= bindings
;
1571 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1573 SCM name
; /* const */
1575 const SCM binding
= SCM_CAR (binding_idx
);
1576 ASSERT_SYNTAX_2 (scm_ilength (binding
) == 2,
1577 s_bad_binding
, binding
, expr
);
1579 name
= SCM_CAR (binding
);
1580 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
1585 /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
1586 * transformed to the lists (vn ... v2 v1) and (i1 i2 ... in). That is, the
1587 * variables are returned in a list with their order reversed, and the init
1588 * forms are returned in a list in the same order as they are given in the
1589 * bindings. If a duplicate variable name is detected, an error is
1592 transform_bindings (
1593 const SCM bindings
, const SCM expr
,
1594 SCM
*const rvarptr
, SCM
*const initptr
)
1596 SCM rvariables
= SCM_EOL
;
1597 SCM rinits
= SCM_EOL
;
1598 SCM binding_idx
= bindings
;
1599 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1601 const SCM binding
= SCM_CAR (binding_idx
);
1602 const SCM cdr_binding
= SCM_CDR (binding
);
1603 const SCM name
= SCM_CAR (binding
);
1604 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, rvariables
)),
1605 s_duplicate_binding
, name
, expr
);
1606 rvariables
= scm_cons (name
, rvariables
);
1607 rinits
= scm_cons (SCM_CAR (cdr_binding
), rinits
);
1609 *rvarptr
= rvariables
;
1610 *initptr
= scm_reverse_x (rinits
, SCM_UNDEFINED
);
1614 SCM_SYNTAX(s_let
, "let", scm_i_makbimacro
, scm_m_let
);
1615 SCM_GLOBAL_SYMBOL(scm_sym_let
, "let");
1617 /* This function is a helper function for memoize_let. It transforms
1618 * (let name ((var init) ...) body ...) into
1619 * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
1620 * and memoizes the expression. It is assumed that the caller has checked
1621 * that name is a symbol and that there are bindings and a body. */
1623 memoize_named_let (const SCM expr
, const SCM env SCM_UNUSED
)
1629 const SCM cdr_expr
= SCM_CDR (expr
);
1630 const SCM name
= SCM_CAR (cdr_expr
);
1631 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1632 const SCM bindings
= SCM_CAR (cddr_expr
);
1633 check_bindings (bindings
, expr
);
1635 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1636 variables
= scm_reverse_x (rvariables
, SCM_UNDEFINED
);
1639 const SCM let_body
= SCM_CDR (cddr_expr
);
1640 const SCM lambda_body
= m_body (SCM_IM_LET
, let_body
);
1641 const SCM lambda_tail
= scm_cons (variables
, lambda_body
);
1642 const SCM lambda_form
= scm_cons_source (expr
, scm_sym_lambda
, lambda_tail
);
1644 const SCM rvar
= scm_list_1 (name
);
1645 const SCM init
= scm_list_1 (lambda_form
);
1646 const SCM body
= m_body (SCM_IM_LET
, scm_list_1 (name
));
1647 const SCM letrec_tail
= scm_cons (rvar
, scm_cons (init
, body
));
1648 const SCM letrec_form
= scm_cons_source (expr
, SCM_IM_LETREC
, letrec_tail
);
1649 return scm_cons_source (expr
, letrec_form
, inits
);
1653 /* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1654 * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
1656 scm_m_let (SCM expr
, SCM env
)
1660 const SCM cdr_expr
= SCM_CDR (expr
);
1661 const long length
= scm_ilength (cdr_expr
);
1662 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1663 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1665 bindings
= SCM_CAR (cdr_expr
);
1666 if (scm_is_symbol (bindings
))
1668 ASSERT_SYNTAX (length
>= 3, s_missing_expression
, expr
);
1669 return memoize_named_let (expr
, env
);
1672 check_bindings (bindings
, expr
);
1673 if (scm_is_null (bindings
) || scm_is_null (SCM_CDR (bindings
)))
1675 /* Special case: no bindings or single binding => let* is faster. */
1676 const SCM body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1677 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), bindings
, body
), env
);
1684 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1687 const SCM new_body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1688 const SCM new_tail
= scm_cons2 (rvariables
, inits
, new_body
);
1689 SCM_SETCAR (expr
, SCM_IM_LET
);
1690 SCM_SETCDR (expr
, new_tail
);
1697 build_binding_list (SCM rnames
, SCM rinits
)
1699 SCM bindings
= SCM_EOL
;
1700 while (!scm_is_null (rnames
))
1702 const SCM binding
= scm_list_2 (SCM_CAR (rnames
), SCM_CAR (rinits
));
1703 bindings
= scm_cons (binding
, bindings
);
1704 rnames
= SCM_CDR (rnames
);
1705 rinits
= SCM_CDR (rinits
);
1711 unmemoize_let (const SCM expr
, const SCM env
)
1713 const SCM cdr_expr
= SCM_CDR (expr
);
1714 const SCM um_rnames
= SCM_CAR (cdr_expr
);
1715 const SCM extended_env
= SCM_EXTEND_ENV (um_rnames
, SCM_EOL
, env
);
1716 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1717 const SCM um_inits
= unmemoize_exprs (SCM_CAR (cddr_expr
), env
);
1718 const SCM um_rinits
= scm_reverse_x (um_inits
, SCM_UNDEFINED
);
1719 const SCM um_bindings
= build_binding_list (um_rnames
, um_rinits
);
1720 const SCM um_body
= unmemoize_exprs (SCM_CDR (cddr_expr
), extended_env
);
1722 return scm_cons2 (scm_sym_let
, um_bindings
, um_body
);
1726 SCM_SYNTAX(s_letrec
, "letrec", scm_i_makbimacro
, scm_m_letrec
);
1727 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, "letrec");
1730 scm_m_letrec (SCM expr
, SCM env
)
1734 const SCM cdr_expr
= SCM_CDR (expr
);
1735 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1736 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1738 bindings
= SCM_CAR (cdr_expr
);
1739 if (scm_is_null (bindings
))
1741 /* no bindings, let* is executed faster */
1742 SCM body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1743 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), SCM_EOL
, body
), env
);
1751 check_bindings (bindings
, expr
);
1752 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1753 new_body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1754 return scm_cons2 (SCM_IM_LETREC
, rvariables
, scm_cons (inits
, new_body
));
1759 unmemoize_letrec (const SCM expr
, const SCM env
)
1761 const SCM cdr_expr
= SCM_CDR (expr
);
1762 const SCM um_rnames
= SCM_CAR (cdr_expr
);
1763 const SCM extended_env
= SCM_EXTEND_ENV (um_rnames
, SCM_EOL
, env
);
1764 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1765 const SCM um_inits
= unmemoize_exprs (SCM_CAR (cddr_expr
), extended_env
);
1766 const SCM um_rinits
= scm_reverse_x (um_inits
, SCM_UNDEFINED
);
1767 const SCM um_bindings
= build_binding_list (um_rnames
, um_rinits
);
1768 const SCM um_body
= unmemoize_exprs (SCM_CDR (cddr_expr
), extended_env
);
1770 return scm_cons2 (scm_sym_letrec
, um_bindings
, um_body
);
1775 SCM_SYNTAX (s_letstar
, "let*", scm_i_makbimacro
, scm_m_letstar
);
1776 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, "let*");
1778 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1779 * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
1781 scm_m_letstar (SCM expr
, SCM env SCM_UNUSED
)
1786 const SCM cdr_expr
= SCM_CDR (expr
);
1787 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1788 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1790 binding_idx
= SCM_CAR (cdr_expr
);
1791 check_bindings (binding_idx
, expr
);
1793 /* Transform ((v1 i1) (v2 i2) ...) into (v1 i1 v2 i2 ...). The
1794 * transformation is done in place. At the beginning of one iteration of
1795 * the loop the variable binding_idx holds the form
1796 * P1:( (vn . P2:(in . ())) . P3:( (vn+1 in+1) ... ) ),
1797 * where P1, P2 and P3 indicate the pairs, that are relevant for the
1798 * transformation. P1 and P2 are modified in the loop, P3 remains
1799 * untouched. After the execution of the loop, P1 will hold
1800 * P1:( vn . P2:(in . P3:( (vn+1 in+1) ... )) )
1801 * and binding_idx will hold P3. */
1802 while (!scm_is_null (binding_idx
))
1804 const SCM cdr_binding_idx
= SCM_CDR (binding_idx
); /* remember P3 */
1805 const SCM binding
= SCM_CAR (binding_idx
);
1806 const SCM name
= SCM_CAR (binding
);
1807 const SCM cdr_binding
= SCM_CDR (binding
);
1809 SCM_SETCDR (cdr_binding
, cdr_binding_idx
); /* update P2 */
1810 SCM_SETCAR (binding_idx
, name
); /* update P1 */
1811 SCM_SETCDR (binding_idx
, cdr_binding
); /* update P1 */
1813 binding_idx
= cdr_binding_idx
; /* continue with P3 */
1816 new_body
= m_body (SCM_IM_LETSTAR
, SCM_CDR (cdr_expr
));
1817 SCM_SETCAR (expr
, SCM_IM_LETSTAR
);
1818 /* the bindings have been changed in place */
1819 SCM_SETCDR (cdr_expr
, new_body
);
1824 unmemoize_letstar (const SCM expr
, const SCM env
)
1826 const SCM cdr_expr
= SCM_CDR (expr
);
1827 const SCM body
= SCM_CDR (cdr_expr
);
1828 SCM bindings
= SCM_CAR (cdr_expr
);
1829 SCM um_bindings
= SCM_EOL
;
1830 SCM extended_env
= env
;
1833 while (!scm_is_null (bindings
))
1835 const SCM variable
= SCM_CAR (bindings
);
1836 const SCM init
= SCM_CADR (bindings
);
1837 const SCM um_init
= unmemoize_expression (init
, extended_env
);
1838 um_bindings
= scm_cons (scm_list_2 (variable
, um_init
), um_bindings
);
1839 extended_env
= SCM_EXTEND_ENV (variable
, SCM_BOOL_F
, extended_env
);
1840 bindings
= SCM_CDDR (bindings
);
1842 um_bindings
= scm_reverse_x (um_bindings
, SCM_UNDEFINED
);
1844 um_body
= unmemoize_exprs (body
, extended_env
);
1846 return scm_cons2 (scm_sym_letstar
, um_bindings
, um_body
);
1850 SCM_SYNTAX (s_or
, "or", scm_i_makbimacro
, scm_m_or
);
1851 SCM_GLOBAL_SYMBOL (scm_sym_or
, "or");
1854 scm_m_or (SCM expr
, SCM env SCM_UNUSED
)
1856 const SCM cdr_expr
= SCM_CDR (expr
);
1857 const long length
= scm_ilength (cdr_expr
);
1859 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1863 /* Special case: (or) is replaced by #f. */
1868 SCM_SETCAR (expr
, SCM_IM_OR
);
1874 unmemoize_or (const SCM expr
, const SCM env
)
1876 return scm_cons (scm_sym_or
, unmemoize_exprs (SCM_CDR (expr
), env
));
1880 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
1881 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, "quasiquote");
1882 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
1883 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
1885 /* Internal function to handle a quasiquotation: 'form' is the parameter in
1886 * the call (quasiquotation form), 'env' is the environment where unquoted
1887 * expressions will be evaluated, and 'depth' is the current quasiquotation
1888 * nesting level and is known to be greater than zero. */
1890 iqq (SCM form
, SCM env
, unsigned long int depth
)
1892 if (scm_is_pair (form
))
1894 const SCM tmp
= SCM_CAR (form
);
1895 if (scm_is_eq (tmp
, scm_sym_quasiquote
))
1897 const SCM args
= SCM_CDR (form
);
1898 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1899 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
1901 else if (scm_is_eq (tmp
, scm_sym_unquote
))
1903 const SCM args
= SCM_CDR (form
);
1904 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1906 return scm_eval_car (args
, env
);
1908 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
1910 else if (scm_is_pair (tmp
)
1911 && scm_is_eq (SCM_CAR (tmp
), scm_sym_uq_splicing
))
1913 const SCM args
= SCM_CDR (tmp
);
1914 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1917 const SCM list
= scm_eval_car (args
, env
);
1918 const SCM rest
= SCM_CDR (form
);
1919 ASSERT_SYNTAX_2 (scm_ilength (list
) >= 0,
1920 s_splicing
, list
, form
);
1921 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
1924 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
1925 iqq (SCM_CDR (form
), env
, depth
));
1928 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
1929 iqq (SCM_CDR (form
), env
, depth
));
1931 else if (scm_is_vector (form
))
1932 return scm_vector (iqq (scm_vector_to_list (form
), env
, depth
));
1938 scm_m_quasiquote (SCM expr
, SCM env
)
1940 const SCM cdr_expr
= SCM_CDR (expr
);
1941 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1942 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1943 return iqq (SCM_CAR (cdr_expr
), env
, 1);
1947 SCM_SYNTAX (s_quote
, "quote", scm_i_makbimacro
, scm_m_quote
);
1948 SCM_GLOBAL_SYMBOL (scm_sym_quote
, "quote");
1951 scm_m_quote (SCM expr
, SCM env SCM_UNUSED
)
1955 const SCM cdr_expr
= SCM_CDR (expr
);
1956 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1957 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1958 quotee
= SCM_CAR (cdr_expr
);
1959 if (is_self_quoting_p (quotee
))
1962 SCM_SETCAR (expr
, SCM_IM_QUOTE
);
1963 SCM_SETCDR (expr
, quotee
);
1968 unmemoize_quote (const SCM expr
, const SCM env SCM_UNUSED
)
1970 return scm_list_2 (scm_sym_quote
, SCM_CDR (expr
));
1974 /* Will go into the RnRS module when Guile is factorized.
1975 SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
1976 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, "set!");
1979 scm_m_set_x (SCM expr
, SCM env SCM_UNUSED
)
1984 const SCM cdr_expr
= SCM_CDR (expr
);
1985 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1986 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1987 variable
= SCM_CAR (cdr_expr
);
1989 /* Memoize the variable form. */
1990 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
1991 new_variable
= lookup_symbol (variable
, env
);
1992 /* Leave the memoization of unbound symbols to lazy memoization: */
1993 if (SCM_UNBNDP (new_variable
))
1994 new_variable
= variable
;
1996 SCM_SETCAR (expr
, SCM_IM_SET_X
);
1997 SCM_SETCAR (cdr_expr
, new_variable
);
2002 unmemoize_set_x (const SCM expr
, const SCM env
)
2004 return scm_cons (scm_sym_set_x
, unmemoize_exprs (SCM_CDR (expr
), env
));
2009 /* Start of the memoizers for non-R5RS builtin macros. */
2012 SCM_SYNTAX (s_at
, "@", scm_makmmacro
, scm_m_at
);
2013 SCM_GLOBAL_SYMBOL (scm_sym_at
, "@");
2016 scm_m_at (SCM expr
, SCM env SCM_UNUSED
)
2019 ASSERT_SYNTAX (scm_ilength (expr
) == 3, s_bad_expression
, expr
);
2020 ASSERT_SYNTAX (scm_ilength (scm_cadr (expr
)) > 0, s_bad_expression
, expr
);
2021 ASSERT_SYNTAX (scm_is_symbol (scm_caddr (expr
)), s_bad_expression
, expr
);
2023 mod
= scm_resolve_module (scm_cadr (expr
));
2024 if (scm_is_false (mod
))
2025 error_unbound_variable (expr
);
2026 var
= scm_module_variable (scm_module_public_interface (mod
), scm_caddr (expr
));
2027 if (scm_is_false (var
))
2028 error_unbound_variable (expr
);
2033 SCM_SYNTAX (s_atat
, "@@", scm_makmmacro
, scm_m_atat
);
2034 SCM_GLOBAL_SYMBOL (scm_sym_atat
, "@@");
2037 scm_m_atat (SCM expr
, SCM env SCM_UNUSED
)
2040 ASSERT_SYNTAX (scm_ilength (expr
) == 3, s_bad_expression
, expr
);
2041 ASSERT_SYNTAX (scm_ilength (scm_cadr (expr
)) > 0, s_bad_expression
, expr
);
2042 ASSERT_SYNTAX (scm_is_symbol (scm_caddr (expr
)), s_bad_expression
, expr
);
2044 mod
= scm_resolve_module (scm_cadr (expr
));
2045 if (scm_is_false (mod
))
2046 error_unbound_variable (expr
);
2047 var
= scm_module_variable (mod
, scm_caddr (expr
));
2048 if (scm_is_false (var
))
2049 error_unbound_variable (expr
);
2054 SCM_SYNTAX (s_atapply
, "@apply", scm_i_makbimacro
, scm_m_apply
);
2055 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, "@apply");
2056 SCM_GLOBAL_SYMBOL (scm_sym_apply
, "apply");
2059 scm_m_apply (SCM expr
, SCM env SCM_UNUSED
)
2061 const SCM cdr_expr
= SCM_CDR (expr
);
2062 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2063 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_missing_expression
, expr
);
2065 SCM_SETCAR (expr
, SCM_IM_APPLY
);
2070 unmemoize_apply (const SCM expr
, const SCM env
)
2072 return scm_list_2 (scm_sym_atapply
, unmemoize_exprs (SCM_CDR (expr
), env
));
2076 SCM_SYNTAX (s_atbind
, "@bind", scm_i_makbimacro
, scm_m_atbind
);
2078 /* FIXME: The following explanation should go into the documentation: */
2079 /* (@bind ((var init) ...) body ...) will assign the values of the `init's to
2080 * the global variables named by `var's (symbols, not evaluated), creating
2081 * them if they don't exist, executes body, and then restores the previous
2082 * values of the `var's. Additionally, whenever control leaves body, the
2083 * values of the `var's are saved and restored when control returns. It is an
2084 * error when a symbol appears more than once among the `var's. All `init's
2085 * are evaluated before any `var' is set.
2087 * Think of this as `let' for dynamic scope.
2090 /* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into
2091 * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...).
2093 * FIXME - also implement `@bind*'.
2096 scm_m_atbind (SCM expr
, SCM env
)
2103 const SCM top_level
= scm_env_top_level (env
);
2105 const SCM cdr_expr
= SCM_CDR (expr
);
2106 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2107 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
2108 bindings
= SCM_CAR (cdr_expr
);
2109 check_bindings (bindings
, expr
);
2110 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
2112 for (variable_idx
= rvariables
;
2113 !scm_is_null (variable_idx
);
2114 variable_idx
= SCM_CDR (variable_idx
))
2116 /* The first call to scm_sym2var will look beyond the current module,
2117 * while the second call wont. */
2118 const SCM variable
= SCM_CAR (variable_idx
);
2119 SCM new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_F
);
2120 if (scm_is_false (new_variable
))
2121 new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_T
);
2122 SCM_SETCAR (variable_idx
, new_variable
);
2125 SCM_SETCAR (expr
, SCM_IM_BIND
);
2126 SCM_SETCAR (cdr_expr
, scm_cons (rvariables
, inits
));
2131 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_i_makbimacro
, scm_m_cont
);
2132 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, "@call-with-current-continuation");
2135 scm_m_cont (SCM expr
, SCM env SCM_UNUSED
)
2137 const SCM cdr_expr
= SCM_CDR (expr
);
2138 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2139 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2141 SCM_SETCAR (expr
, SCM_IM_CONT
);
2146 unmemoize_atcall_cc (const SCM expr
, const SCM env
)
2148 return scm_list_2 (scm_sym_atcall_cc
, unmemoize_exprs (SCM_CDR (expr
), env
));
2152 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_i_makbimacro
, scm_m_at_call_with_values
);
2153 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, "@call-with-values");
2156 scm_m_at_call_with_values (SCM expr
, SCM env SCM_UNUSED
)
2158 const SCM cdr_expr
= SCM_CDR (expr
);
2159 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2160 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2162 SCM_SETCAR (expr
, SCM_IM_CALL_WITH_VALUES
);
2167 unmemoize_at_call_with_values (const SCM expr
, const SCM env
)
2169 return scm_list_2 (scm_sym_at_call_with_values
,
2170 unmemoize_exprs (SCM_CDR (expr
), env
));
2173 SCM_SYNTAX (s_eval_when
, "eval-when", scm_makmmacro
, scm_m_eval_when
);
2174 SCM_GLOBAL_SYMBOL (scm_sym_eval_when
, "eval-when");
2175 SCM_SYMBOL (sym_eval
, "eval");
2176 SCM_SYMBOL (sym_load
, "load");
2180 scm_m_eval_when (SCM expr
, SCM env SCM_UNUSED
)
2182 ASSERT_SYNTAX (scm_ilength (expr
) >= 3, s_bad_expression
, expr
);
2183 ASSERT_SYNTAX (scm_ilength (scm_cadr (expr
)) > 0, s_bad_expression
, expr
);
2185 if (scm_is_true (scm_memq (sym_eval
, scm_cadr (expr
)))
2186 || scm_is_true (scm_memq (sym_load
, scm_cadr (expr
))))
2187 return scm_cons (SCM_IM_BEGIN
, scm_cddr (expr
));
2189 return scm_list_1 (SCM_IM_BEGIN
);
2192 SCM_SYNTAX (s_gset_x
, "set!", scm_i_makbimacro
, scm_m_generalized_set_x
);
2193 SCM_SYMBOL (scm_sym_setter
, "setter");
2196 scm_m_generalized_set_x (SCM expr
, SCM env
)
2198 SCM target
, exp_target
;
2200 const SCM cdr_expr
= SCM_CDR (expr
);
2201 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2202 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2204 target
= SCM_CAR (cdr_expr
);
2205 if (!scm_is_pair (target
))
2208 return scm_m_set_x (expr
, env
);
2212 /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */
2213 /* Macroexpanding the target might return things of the form
2214 (begin <atom>). In that case, <atom> must be a symbol or a
2215 variable and we memoize to (set! <atom> ...).
2217 exp_target
= macroexp (target
, env
);
2218 if (scm_is_eq (SCM_CAR (exp_target
), SCM_IM_BEGIN
)
2219 && !scm_is_null (SCM_CDR (exp_target
))
2220 && scm_is_null (SCM_CDDR (exp_target
)))
2222 exp_target
= SCM_CADR (exp_target
);
2223 ASSERT_SYNTAX_2 (scm_is_symbol (exp_target
)
2224 || SCM_VARIABLEP (exp_target
),
2225 s_bad_variable
, exp_target
, expr
);
2226 return scm_cons (SCM_IM_SET_X
, scm_cons (exp_target
,
2227 SCM_CDR (cdr_expr
)));
2231 const SCM setter_proc_tail
= scm_list_1 (SCM_CAR (target
));
2232 const SCM setter_proc
= scm_cons_source (expr
, scm_sym_setter
,
2235 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
2236 const SCM setter_args
= scm_append_x (scm_list_2 (SCM_CDR (target
),
2239 SCM_SETCAR (expr
, setter_proc
);
2240 SCM_SETCDR (expr
, setter_args
);
2247 /* @slot-ref is bound privately in the (oop goops) module from goops.c. As
2248 * soon as the module system allows us to more freely create bindings in
2249 * arbitrary modules during the startup phase, the code from goops.c should be
2252 SCM_SYNTAX (s_atslot_ref
, "@slot-ref", scm_i_makbimacro
, scm_m_atslot_ref
);
2253 SCM_SYNTAX (s_atslot_set_x
, "@slot-set!", scm_i_makbimacro
, scm_m_atslot_set_x
);
2254 SCM_SYMBOL (sym_atslot_ref
, "@slot-ref");
2257 scm_m_atslot_ref (SCM expr
, SCM env SCM_UNUSED
)
2261 const SCM cdr_expr
= SCM_CDR (expr
);
2262 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2263 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2264 slot_nr
= SCM_CADR (cdr_expr
);
2265 ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2267 SCM_SETCAR (expr
, SCM_IM_SLOT_REF
);
2268 SCM_SETCDR (cdr_expr
, slot_nr
);
2273 unmemoize_atslot_ref (const SCM expr
, const SCM env
)
2275 const SCM instance
= SCM_CADR (expr
);
2276 const SCM um_instance
= unmemoize_expression (instance
, env
);
2277 const SCM slot_nr
= SCM_CDDR (expr
);
2278 return scm_list_3 (sym_atslot_ref
, um_instance
, slot_nr
);
2282 /* @slot-set! is bound privately in the (oop goops) module from goops.c. As
2283 * soon as the module system allows us to more freely create bindings in
2284 * arbitrary modules during the startup phase, the code from goops.c should be
2287 SCM_SYMBOL (sym_atslot_set_x
, "@slot-set!");
2290 scm_m_atslot_set_x (SCM expr
, SCM env SCM_UNUSED
)
2294 const SCM cdr_expr
= SCM_CDR (expr
);
2295 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2296 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 3, s_expression
, expr
);
2297 slot_nr
= SCM_CADR (cdr_expr
);
2298 ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2300 SCM_SETCAR (expr
, SCM_IM_SLOT_SET_X
);
2305 unmemoize_atslot_set_x (const SCM expr
, const SCM env
)
2307 const SCM cdr_expr
= SCM_CDR (expr
);
2308 const SCM instance
= SCM_CAR (cdr_expr
);
2309 const SCM um_instance
= unmemoize_expression (instance
, env
);
2310 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
2311 const SCM slot_nr
= SCM_CAR (cddr_expr
);
2312 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
2313 const SCM value
= SCM_CAR (cdddr_expr
);
2314 const SCM um_value
= unmemoize_expression (value
, env
);
2315 return scm_list_4 (sym_atslot_set_x
, um_instance
, slot_nr
, um_value
);
2319 #if SCM_ENABLE_ELISP
2321 static const char s_defun
[] = "Symbol's function definition is void";
2323 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_i_makbimacro
, scm_m_nil_cond
);
2325 /* nil-cond expressions have the form
2326 * (nil-cond COND VAL COND VAL ... ELSEVAL) */
2328 scm_m_nil_cond (SCM expr
, SCM env SCM_UNUSED
)
2330 const long length
= scm_ilength (SCM_CDR (expr
));
2331 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
2332 ASSERT_SYNTAX (length
>= 1 && (length
% 2) == 1, s_expression
, expr
);
2334 SCM_SETCAR (expr
, SCM_IM_NIL_COND
);
2339 SCM_SYNTAX (s_atfop
, "@fop", scm_i_makbimacro
, scm_m_atfop
);
2341 /* The @fop-macro handles procedure and macro applications for elisp. The
2342 * input expression must have the form
2343 * (@fop <var> (transformer-macro <expr> ...))
2344 * where <var> must be a symbol. The expression is transformed into the
2345 * memoized form of either
2346 * (apply <un-aliased var> (transformer-macro <expr> ...))
2347 * if the value of var (across all aliasing) is not a macro, or
2348 * (<un-aliased var> <expr> ...)
2349 * if var is a macro. */
2351 scm_m_atfop (SCM expr
, SCM env SCM_UNUSED
)
2356 const SCM cdr_expr
= SCM_CDR (expr
);
2357 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2358 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 1, s_missing_expression
, expr
);
2360 symbol
= SCM_CAR (cdr_expr
);
2361 ASSERT_SYNTAX_2 (scm_is_symbol (symbol
), s_bad_variable
, symbol
, expr
);
2363 location
= scm_symbol_fref (symbol
);
2364 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2366 /* The elisp function `defalias' allows to define aliases for symbols. To
2367 * look up such definitions, the chain of symbol definitions has to be
2368 * followed up to the terminal symbol. */
2369 while (scm_is_symbol (SCM_VARIABLE_REF (location
)))
2371 const SCM alias
= SCM_VARIABLE_REF (location
);
2372 location
= scm_symbol_fref (alias
);
2373 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2376 /* Memoize the value location belonging to the terminal symbol. */
2377 SCM_SETCAR (cdr_expr
, location
);
2379 if (!SCM_MACROP (SCM_VARIABLE_REF (location
)))
2381 /* Since the location does not contain a macro, the form is a procedure
2382 * application. Replace `@fop' by `@apply' and transform the expression
2383 * including the `transformer-macro'. */
2384 SCM_SETCAR (expr
, SCM_IM_APPLY
);
2389 /* Since the location contains a macro, the arguments should not be
2390 * transformed, so the `transformer-macro' is cut out. The resulting
2391 * expression starts with the memoized variable, that is at the cdr of
2392 * the input expression. */
2393 SCM_SETCDR (cdr_expr
, SCM_CDADR (cdr_expr
));
2398 #endif /* SCM_ENABLE_ELISP */
2402 unmemoize_builtin_macro (const SCM expr
, const SCM env
)
2404 switch (ISYMNUM (SCM_CAR (expr
)))
2406 case (ISYMNUM (SCM_IM_AND
)):
2407 return unmemoize_and (expr
, env
);
2409 case (ISYMNUM (SCM_IM_BEGIN
)):
2410 return unmemoize_begin (expr
, env
);
2412 case (ISYMNUM (SCM_IM_CASE
)):
2413 return unmemoize_case (expr
, env
);
2415 case (ISYMNUM (SCM_IM_COND
)):
2416 return unmemoize_cond (expr
, env
);
2418 case (ISYMNUM (SCM_IM_DELAY
)):
2419 return unmemoize_delay (expr
, env
);
2421 case (ISYMNUM (SCM_IM_DO
)):
2422 return unmemoize_do (expr
, env
);
2424 case (ISYMNUM (SCM_IM_IF
)):
2425 return unmemoize_if (expr
, env
);
2427 case (ISYMNUM (SCM_IM_LAMBDA
)):
2428 return unmemoize_lambda (expr
, env
);
2430 case (ISYMNUM (SCM_IM_LET
)):
2431 return unmemoize_let (expr
, env
);
2433 case (ISYMNUM (SCM_IM_LETREC
)):
2434 return unmemoize_letrec (expr
, env
);
2436 case (ISYMNUM (SCM_IM_LETSTAR
)):
2437 return unmemoize_letstar (expr
, env
);
2439 case (ISYMNUM (SCM_IM_OR
)):
2440 return unmemoize_or (expr
, env
);
2442 case (ISYMNUM (SCM_IM_QUOTE
)):
2443 return unmemoize_quote (expr
, env
);
2445 case (ISYMNUM (SCM_IM_SET_X
)):
2446 return unmemoize_set_x (expr
, env
);
2448 case (ISYMNUM (SCM_IM_APPLY
)):
2449 return unmemoize_apply (expr
, env
);
2451 case (ISYMNUM (SCM_IM_BIND
)):
2452 return unmemoize_exprs (expr
, env
); /* FIXME */
2454 case (ISYMNUM (SCM_IM_CONT
)):
2455 return unmemoize_atcall_cc (expr
, env
);
2457 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2458 return unmemoize_at_call_with_values (expr
, env
);
2460 case (ISYMNUM (SCM_IM_SLOT_REF
)):
2461 return unmemoize_atslot_ref (expr
, env
);
2463 case (ISYMNUM (SCM_IM_SLOT_SET_X
)):
2464 return unmemoize_atslot_set_x (expr
, env
);
2466 case (ISYMNUM (SCM_IM_NIL_COND
)):
2467 return unmemoize_exprs (expr
, env
); /* FIXME */
2470 return unmemoize_exprs (expr
, env
); /* FIXME */
2475 /* scm_i_unmemocopy_expr and scm_i_unmemocopy_body take a memoized expression
2476 * respectively a memoized body together with its environment and rewrite it
2477 * to its original form. Thus, these functions are the inversion of the
2478 * rewrite rules above. The procedure is not optimized for speed. It's used
2479 * in scm_i_unmemoize_expr, scm_procedure_source, macro_print and scm_iprin1.
2481 * Unmemoizing is not a reliable process. You cannot in general expect to get
2482 * the original source back.
2484 * However, GOOPS currently relies on this for method compilation. This ought
2488 scm_i_unmemocopy_expr (SCM expr
, SCM env
)
2490 const SCM source_properties
= scm_whash_lookup (scm_source_whash
, expr
);
2491 const SCM um_expr
= unmemoize_expression (expr
, env
);
2493 if (scm_is_true (source_properties
))
2494 scm_whash_insert (scm_source_whash
, um_expr
, source_properties
);
2500 scm_i_unmemocopy_body (SCM forms
, SCM env
)
2502 const SCM source_properties
= scm_whash_lookup (scm_source_whash
, forms
);
2503 const SCM um_forms
= unmemoize_exprs (forms
, env
);
2505 if (scm_is_true (source_properties
))
2506 scm_whash_insert (scm_source_whash
, um_forms
, source_properties
);
2512 #if (SCM_ENABLE_DEPRECATED == 1)
2514 static SCM
scm_m_undefine (SCM expr
, SCM env
);
2516 SCM_SYNTAX (s_undefine
, "undefine", scm_makacro
, scm_m_undefine
);
2519 scm_m_undefine (SCM expr
, SCM env
)
2524 const SCM cdr_expr
= SCM_CDR (expr
);
2525 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), "Bad undefine placement in", expr
);
2526 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2527 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2529 scm_c_issue_deprecation_warning
2530 ("`undefine' is deprecated.\n");
2532 variable
= SCM_CAR (cdr_expr
);
2533 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
2534 location
= scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_F
);
2535 ASSERT_SYNTAX_2 (scm_is_true (location
)
2536 && !SCM_UNBNDP (SCM_VARIABLE_REF (location
)),
2537 "variable already unbound ", variable
, expr
);
2538 SCM_VARIABLE_SET (location
, SCM_UNDEFINED
);
2539 return SCM_UNSPECIFIED
;
2542 #endif /* SCM_ENABLE_DEPRECATED */
2546 /*****************************************************************************/
2547 /*****************************************************************************/
2548 /* The definitions for execution start here. */
2549 /*****************************************************************************/
2550 /*****************************************************************************/
2552 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
2553 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
2554 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
2555 SCM_GLOBAL_SYMBOL (scm_sym_memoize_symbol
, "memoize-symbol");
2556 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
2557 SCM_SYMBOL (sym_instead
, "instead");
2559 /* A function object to implement "apply" for non-closure functions. */
2561 /* An endless list consisting of #<undefined> objects: */
2562 static SCM undefineds
;
2566 scm_badargsp (SCM formals
, SCM args
)
2568 while (!scm_is_null (formals
))
2570 if (!scm_is_pair (formals
))
2572 if (scm_is_null (args
))
2574 formals
= SCM_CDR (formals
);
2575 args
= SCM_CDR (args
);
2577 return !scm_is_null (args
) ? 1 : 0;
2582 /* The evaluator contains a plethora of EVAL symbols.
2585 * SCM_I_EVALIM is used when it is known that the expression is an
2586 * immediate. (This macro never calls an evaluator.)
2588 * SCM_I_XEVAL evaluates an expression that is expected to have its symbols already
2589 * memoized. Expressions that are not of the form '(<form> <form> ...)' are
2590 * evaluated inline without calling an evaluator.
2592 * This macro uses ceval or deval depending on its 3rd argument.
2594 * SCM_I_XEVALCAR evaluates the car of an expression 'X:(Y:<form> <form> ...)',
2595 * potentially replacing a symbol at the position Y:<form> by its memoized
2596 * variable. If Y:<form> is not of the form '(<form> <form> ...)', the
2597 * evaluation is performed inline without calling an evaluator.
2599 * This macro uses ceval or deval depending on its 3rd argument.
2603 #define SCM_I_EVALIM2(x) \
2604 ((scm_is_eq ((x), SCM_EOL) \
2605 ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \
2609 #define SCM_I_EVALIM(x, env) (SCM_ILOCP (x) \
2610 ? *scm_ilookup ((x), (env)) \
2613 #define SCM_I_XEVAL(x, env, debug_p) \
2615 ? SCM_I_EVALIM2 (x) \
2616 : (SCM_VARIABLEP (x) \
2617 ? SCM_VARIABLE_REF (x) \
2618 : (scm_is_pair (x) \
2620 ? deval ((x), (env)) \
2621 : ceval ((x), (env))) \
2624 #define SCM_I_XEVALCAR(x, env, debug_p) \
2625 (SCM_IMP (SCM_CAR (x)) \
2626 ? SCM_I_EVALIM (SCM_CAR (x), (env)) \
2627 : (SCM_VARIABLEP (SCM_CAR (x)) \
2628 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2629 : (scm_is_pair (SCM_CAR (x)) \
2631 ? deval (SCM_CAR (x), (env)) \
2632 : ceval (SCM_CAR (x), (env))) \
2633 : (!scm_is_symbol (SCM_CAR (x)) \
2635 : *scm_lookupcar ((x), (env), 1)))))
2637 scm_i_pthread_mutex_t source_mutex
;
2640 /* Lookup a given local variable in an environment. The local variable is
2641 * given as an iloc, that is a triple <frame, binding, last?>, where frame
2642 * indicates the relative number of the environment frame (counting upwards
2643 * from the innermost environment frame), binding indicates the number of the
2644 * binding within the frame, and last? (which is extracted from the iloc using
2645 * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
2646 * very end of the improper list of bindings. */
2648 scm_ilookup (SCM iloc
, SCM env
)
2650 unsigned int frame_nr
= SCM_IFRAME (iloc
);
2651 unsigned int binding_nr
= SCM_IDIST (iloc
);
2655 for (; 0 != frame_nr
; --frame_nr
)
2656 frames
= SCM_CDR (frames
);
2658 bindings
= SCM_CAR (frames
);
2659 for (; 0 != binding_nr
; --binding_nr
)
2660 bindings
= SCM_CDR (bindings
);
2662 if (SCM_ICDRP (iloc
))
2663 return SCM_CDRLOC (bindings
);
2664 return SCM_CARLOC (SCM_CDR (bindings
));
2668 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
2670 /* Call this for variables that are unfound.
2673 error_unbound_variable (SCM symbol
)
2675 scm_error (scm_unbound_variable_key
, NULL
,
2676 "Unbound variable: ~S",
2677 scm_list_1 (symbol
), SCM_BOOL_F
);
2680 /* Call this for variables that are found but contain SCM_UNDEFINED.
2683 error_defined_variable (SCM symbol
)
2685 /* We use the 'unbound-variable' key here as well, since it
2686 basically is the same kind of error, with a slight variation in
2687 the displayed message.
2689 scm_error (scm_unbound_variable_key
, NULL
,
2690 "Variable used before given a value: ~S",
2691 scm_list_1 (symbol
), SCM_BOOL_F
);
2695 /* The Lookup Car Race
2698 Memoization of variables and special forms is done while executing
2699 the code for the first time. As long as there is only one thread
2700 everything is fine, but as soon as two threads execute the same
2701 code concurrently `for the first time' they can come into conflict.
2703 This memoization includes rewriting variable references into more
2704 efficient forms and expanding macros. Furthermore, macro expansion
2705 includes `compiling' special forms like `let', `cond', etc. into
2706 tree-code instructions.
2708 There shouldn't normally be a problem with memoizing local and
2709 global variable references (into ilocs and variables), because all
2710 threads will mutate the code in *exactly* the same way and (if I
2711 read the C code correctly) it is not possible to observe a half-way
2712 mutated cons cell. The lookup procedure can handle this
2713 transparently without any critical sections.
2715 It is different with macro expansion, because macro expansion
2716 happens outside of the lookup procedure and can't be
2717 undone. Therefore the lookup procedure can't cope with it. It has
2718 to indicate failure when it detects a lost race and hope that the
2719 caller can handle it. Luckily, it turns out that this is the case.
2721 An example to illustrate this: Suppose that the following form will
2722 be memoized concurrently by two threads
2726 Let's first examine the lookup of X in the body. The first thread
2727 decides that it has to find the symbol "x" in the environment and
2728 starts to scan it. Then the other thread takes over and actually
2729 overtakes the first. It looks up "x" and substitutes an
2730 appropriate iloc for it. Now the first thread continues and
2731 completes its lookup. It comes to exactly the same conclusions as
2732 the second one and could - without much ado - just overwrite the
2733 iloc with the same iloc.
2735 But let's see what will happen when the race occurs while looking
2736 up the symbol "let" at the start of the form. It could happen that
2737 the second thread interrupts the lookup of the first thread and not
2738 only substitutes a variable for it but goes right ahead and
2739 replaces it with the compiled form (#@let* (x 12) x). Now, when
2740 the first thread completes its lookup, it would replace the #@let*
2741 with a variable containing the "let" binding, effectively reverting
2742 the form to (let (x 12) x). This is wrong. It has to detect that
2743 it has lost the race and the evaluator has to reconsider the
2744 changed form completely.
2746 This race condition could be resolved with some kind of traffic
2747 light (like mutexes) around scm_lookupcar, but I think that it is
2748 best to avoid them in this case. They would serialize memoization
2749 completely and because lookup involves calling arbitrary Scheme
2750 code (via the lookup-thunk), threads could be blocked for an
2751 arbitrary amount of time or even deadlock. But with the current
2752 solution a lot of unnecessary work is potentially done. */
2754 /* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
2755 return NULL to indicate a failed lookup due to some race conditions
2756 between threads. This only happens when VLOC is the first cell of
2757 a special form that will eventually be memoized (like `let', etc.)
2758 In that case the whole lookup is bogus and the caller has to
2759 reconsider the complete special form.
2761 SCM_LOOKUPCAR is still there, of course. It just calls
2762 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
2763 should only be called when it is known that VLOC is not the first
2764 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
2765 for NULL. I think I've found the only places where this
2769 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
2772 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
2773 register SCM iloc
= SCM_ILOC00
;
2774 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
2776 if (!scm_is_pair (SCM_CAR (env
)))
2778 al
= SCM_CARLOC (env
);
2779 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
2781 if (!scm_is_pair (fl
))
2783 if (scm_is_eq (fl
, var
))
2785 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2787 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
2788 return SCM_CDRLOC (*al
);
2793 al
= SCM_CDRLOC (*al
);
2794 if (scm_is_eq (SCM_CAR (fl
), var
))
2796 if (SCM_UNBNDP (SCM_CAR (*al
)))
2797 error_defined_variable (var
);
2798 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2800 SCM_SETCAR (vloc
, iloc
);
2801 return SCM_CARLOC (*al
);
2803 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
2805 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
2808 SCM top_thunk
, real_var
;
2811 top_thunk
= SCM_CAR (env
); /* env now refers to a
2812 top level env thunk */
2813 env
= SCM_CDR (env
);
2816 top_thunk
= SCM_BOOL_F
;
2817 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
2818 if (scm_is_false (real_var
))
2821 if (!scm_is_null (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
2826 if (scm_is_null (env
))
2827 error_unbound_variable (var
);
2829 scm_misc_error (NULL
, "Damaged environment: ~S",
2834 /* A variable could not be found, but we shall
2835 not throw an error. */
2836 static SCM undef_object
= SCM_UNDEFINED
;
2837 return &undef_object
;
2841 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2843 /* Some other thread has changed the very cell we are working
2844 on. In effect, it must have done our job or messed it up
2847 var
= SCM_CAR (vloc
);
2848 if (SCM_VARIABLEP (var
))
2849 return SCM_VARIABLE_LOC (var
);
2850 if (SCM_ILOCP (var
))
2851 return scm_ilookup (var
, genv
);
2852 /* We can't cope with anything else than variables and ilocs. When
2853 a special form has been memoized (i.e. `let' into `#@let') we
2854 return NULL and expect the calling function to do the right
2855 thing. For the evaluator, this means going back and redoing
2856 the dispatch on the car of the form. */
2860 SCM_SETCAR (vloc
, real_var
);
2861 return SCM_VARIABLE_LOC (real_var
);
2866 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
2868 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
2875 /* During execution, look up a symbol in the top level of the given local
2876 * environment and return the corresponding variable object. If no binding
2877 * for the symbol can be found, an 'Unbound variable' error is signalled. */
2879 lazy_memoize_variable (const SCM symbol
, const SCM environment
)
2881 const SCM top_level
= scm_env_top_level (environment
);
2882 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
2884 if (scm_is_false (variable
))
2885 error_unbound_variable (symbol
);
2892 scm_eval_car (SCM pair
, SCM env
)
2894 return SCM_I_XEVALCAR (pair
, env
, scm_debug_mode_p
);
2899 scm_eval_body (SCM code
, SCM env
)
2904 next
= SCM_CDR (code
);
2905 while (!scm_is_null (next
))
2907 if (SCM_IMP (SCM_CAR (code
)))
2909 if (SCM_ISYMP (SCM_CAR (code
)))
2911 scm_dynwind_begin (0);
2912 scm_i_dynwind_pthread_mutex_lock (&source_mutex
);
2913 /* check for race condition */
2914 if (SCM_ISYMP (SCM_CAR (code
)))
2915 m_expand_body (code
, env
);
2921 SCM_I_XEVAL (SCM_CAR (code
), env
, scm_debug_mode_p
);
2923 next
= SCM_CDR (code
);
2925 return SCM_I_XEVALCAR (code
, env
, scm_debug_mode_p
);
2929 /* scm_last_debug_frame contains a pointer to the last debugging information
2930 * stack frame. It is accessed very often from the debugging evaluator, so it
2931 * should probably not be indirectly addressed. Better to save and restore it
2932 * from the current root at any stack swaps.
2935 /* scm_debug_eframe_size is the number of slots available for pseudo
2936 * stack frames at each real stack frame.
2939 long scm_debug_eframe_size
;
2941 int scm_debug_mode_p
;
2942 int scm_check_entry_p
;
2943 int scm_check_apply_p
;
2944 int scm_check_exit_p
;
2945 int scm_check_memoize_p
;
2947 long scm_eval_stack
;
2949 scm_t_option scm_eval_opts
[] = {
2950 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." },
2954 scm_t_option scm_debug_opts
[] = {
2955 { SCM_OPTION_BOOLEAN
, "cheap", 1,
2956 "*This option is now obsolete. Setting it has no effect." },
2957 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
2958 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
2959 { SCM_OPTION_BOOLEAN
, "procnames", 1,
2960 "Record procedure names at definition." },
2961 { SCM_OPTION_BOOLEAN
, "backwards", 0,
2962 "Display backtrace in anti-chronological order." },
2963 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
2964 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
2965 { SCM_OPTION_INTEGER
, "frames", 3,
2966 "Maximum number of tail-recursive frames in backtrace." },
2967 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
2968 "Maximal number of stored backtrace frames." },
2969 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
2970 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
2971 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
2972 /* This default stack limit will be overridden by debug.c:init_stack_limit(),
2973 if we have getrlimit() and the stack limit is not INFINITY. But it is still
2974 important, as some systems have both the soft and the hard limits set to
2975 INFINITY; in that case we fall back to this value.
2977 The situation is aggravated by certain compilers, which can consume
2978 "beaucoup de stack", as they say in France.
2980 See http://thread.gmane.org/gmane.lisp.guile.devel/8599/focus=8662 for
2981 more discussion. This setting is 640 KB on 32-bit arches (should be enough
2982 for anyone!) or a whoppin' 1280 KB on 64-bit arches.
2984 { SCM_OPTION_INTEGER
, "stack", 160000, "Stack size limit (measured in words; 0 = no check)." },
2985 { SCM_OPTION_SCM
, "show-file-name", (unsigned long)SCM_BOOL_T
,
2986 "Show file names and line numbers "
2987 "in backtraces when not `#f'. A value of `base' "
2988 "displays only base names, while `#t' displays full names."},
2989 { SCM_OPTION_BOOLEAN
, "warn-deprecated", 0,
2990 "Warn when deprecated features are used." },
2996 * this ordering is awkward and illogical, but we maintain it for
2997 * compatibility. --hwn
2999 scm_t_option scm_evaluator_trap_table
[] = {
3000 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
3001 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
3002 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
3003 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
3004 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
3005 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
3006 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." },
3007 { SCM_OPTION_BOOLEAN
, "memoize-symbol", 0, "Trap when memoizing a symbol." },
3008 { SCM_OPTION_SCM
, "memoize-symbol-handler", (unsigned long)SCM_BOOL_F
, "The handler for memoization." },
3013 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
3015 "Option interface for the evaluation options. Instead of using\n"
3016 "this procedure directly, use the procedures @code{eval-enable},\n"
3017 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
3018 #define FUNC_NAME s_scm_eval_options_interface
3022 scm_dynwind_begin (0);
3023 scm_dynwind_critical_section (SCM_BOOL_F
);
3024 ans
= scm_options (setting
,
3027 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
3035 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
3037 "Option interface for the evaluator trap options.")
3038 #define FUNC_NAME s_scm_evaluator_traps
3043 scm_options_try (setting
,
3044 scm_evaluator_trap_table
,
3046 SCM_CRITICAL_SECTION_START
;
3047 ans
= scm_options (setting
,
3048 scm_evaluator_trap_table
,
3051 /* njrev: same again. */
3052 SCM_RESET_DEBUG_MODE
;
3053 SCM_CRITICAL_SECTION_END
;
3062 /* Simple procedure calls
3066 scm_call_0 (SCM proc
)
3068 if (SCM_PROGRAM_P (proc
))
3069 return scm_c_vm_run (scm_the_vm (), proc
, NULL
, 0);
3071 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
3075 scm_call_1 (SCM proc
, SCM arg1
)
3077 if (SCM_PROGRAM_P (proc
))
3078 return scm_c_vm_run (scm_the_vm (), proc
, &arg1
, 1);
3080 return scm_apply (proc
, arg1
, scm_listofnull
);
3084 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
3086 if (SCM_PROGRAM_P (proc
))
3088 SCM args
[] = { arg1
, arg2
};
3089 return scm_c_vm_run (scm_the_vm (), proc
, args
, 2);
3092 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
3096 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
3098 if (SCM_PROGRAM_P (proc
))
3100 SCM args
[] = { arg1
, arg2
, arg3
};
3101 return scm_c_vm_run (scm_the_vm (), proc
, args
, 3);
3104 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
3108 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
3110 if (SCM_PROGRAM_P (proc
))
3112 SCM args
[] = { arg1
, arg2
, arg3
, arg4
};
3113 return scm_c_vm_run (scm_the_vm (), proc
, args
, 4);
3116 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
3117 scm_cons (arg4
, scm_listofnull
)));
3120 /* Simple procedure applies
3124 scm_apply_0 (SCM proc
, SCM args
)
3126 return scm_apply (proc
, args
, SCM_EOL
);
3130 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
3132 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
3136 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
3138 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
3142 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
3144 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
3148 /* This code processes the arguments to apply:
3150 (apply PROC ARG1 ... ARGS)
3152 Given a list (ARG1 ... ARGS), this function conses the ARG1
3153 ... arguments onto the front of ARGS, and returns the resulting
3154 list. Note that ARGS is a list; thus, the argument to this
3155 function is a list whose last element is a list.
3157 Apply calls this function, and applies PROC to the elements of the
3158 result. apply:nconc2last takes care of building the list of
3159 arguments, given (ARG1 ... ARGS).
3161 Rather than do new consing, apply:nconc2last destroys its argument.
3162 On that topic, this code came into my care with the following
3163 beautifully cryptic comment on that topic: "This will only screw
3164 you if you do (scm_apply scm_apply '( ... ))" If you know what
3165 they're referring to, send me a patch to this comment. */
3167 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3169 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
3170 "conses the @var{arg1} @dots{} arguments onto the front of\n"
3171 "@var{args}, and returns the resulting list. Note that\n"
3172 "@var{args} is a list; thus, the argument to this function is\n"
3173 "a list whose last element is a list.\n"
3174 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
3175 "destroys its argument, so use with care.")
3176 #define FUNC_NAME s_scm_nconc2last
3179 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
3181 while (!scm_is_null (SCM_CDR (*lloc
))) /* Perhaps should be
3182 SCM_NULL_OR_NIL_P, but not
3183 needed in 99.99% of cases,
3184 and it could seriously hurt
3185 performance. - Neil */
3186 lloc
= SCM_CDRLOC (*lloc
);
3187 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3188 *lloc
= SCM_CAR (*lloc
);
3195 /* SECTION: The rest of this file is only read once.
3200 * Trampolines make it possible to move procedure application dispatch
3201 * outside inner loops. The motivation was clean implementation of
3202 * efficient replacements of R5RS primitives in SRFI-1.
3204 * The semantics is clear: scm_trampoline_N returns an optimized
3205 * version of scm_call_N (or NULL if the procedure isn't applicable
3208 * Applying the optimization to map and for-each increased efficiency
3209 * noticeably. For example, (map abs ls) is now 8 times faster than
3214 call_subr0_0 (SCM proc
)
3216 return SCM_SUBRF (proc
) ();
3220 call_subr1o_0 (SCM proc
)
3222 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
3226 call_lsubr_0 (SCM proc
)
3228 return SCM_SUBRF (proc
) (SCM_EOL
);
3232 scm_i_call_closure_0 (SCM proc
)
3234 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3237 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
3242 scm_trampoline_0 (SCM proc
)
3244 scm_t_trampoline_0 trampoline
;
3249 switch (SCM_TYP7 (proc
))
3251 case scm_tc7_subr_0
:
3252 trampoline
= call_subr0_0
;
3254 case scm_tc7_subr_1o
:
3255 trampoline
= call_subr1o_0
;
3258 trampoline
= call_lsubr_0
;
3260 case scm_tcs_closures
:
3262 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3263 if (scm_is_null (formals
) || !scm_is_pair (formals
))
3264 trampoline
= scm_i_call_closure_0
;
3269 case scm_tcs_struct
:
3270 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3271 trampoline
= scm_call_generic_0
;
3276 if (SCM_SMOB_APPLICABLE_P (proc
))
3277 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
3282 case scm_tc7_rpsubr
:
3285 case scm_tc7_program
:
3286 trampoline
= scm_call_0
;
3289 return NULL
; /* not applicable on zero arguments */
3291 /* We only reach this point if a valid trampoline was determined. */
3293 /* If debugging is enabled, we want to see all calls to proc on the stack.
3294 * Thus, we replace the trampoline shortcut with scm_call_0. */
3295 if (scm_debug_mode_p
)
3302 call_subr1_1 (SCM proc
, SCM arg1
)
3304 return SCM_SUBRF (proc
) (arg1
);
3308 call_subr2o_1 (SCM proc
, SCM arg1
)
3310 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
3314 call_lsubr_1 (SCM proc
, SCM arg1
)
3316 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
3320 call_dsubr_1 (SCM proc
, SCM arg1
)
3322 if (SCM_I_INUMP (arg1
))
3324 return (scm_from_double (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
))));
3326 else if (SCM_REALP (arg1
))
3328 return (scm_from_double (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3330 else if (SCM_BIGP (arg1
))
3332 return (scm_from_double (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3334 else if (SCM_FRACTIONP (arg1
))
3336 return (scm_from_double (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
3338 SCM_WTA_DISPATCH_1_SUBR (proc
, arg1
, SCM_ARG1
);
3342 call_cxr_1 (SCM proc
, SCM arg1
)
3344 return scm_i_chase_pairs (arg1
, (scm_t_bits
) SCM_SUBRF (proc
));
3348 call_closure_1 (SCM proc
, SCM arg1
)
3350 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3353 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
3358 scm_trampoline_1 (SCM proc
)
3360 scm_t_trampoline_1 trampoline
;
3365 switch (SCM_TYP7 (proc
))
3367 case scm_tc7_subr_1
:
3368 case scm_tc7_subr_1o
:
3369 trampoline
= call_subr1_1
;
3371 case scm_tc7_subr_2o
:
3372 trampoline
= call_subr2o_1
;
3375 trampoline
= call_lsubr_1
;
3378 trampoline
= call_dsubr_1
;
3381 trampoline
= call_cxr_1
;
3383 case scm_tcs_closures
:
3385 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3386 if (!scm_is_null (formals
)
3387 && (!scm_is_pair (formals
) || !scm_is_pair (SCM_CDR (formals
))))
3388 trampoline
= call_closure_1
;
3393 case scm_tcs_struct
:
3394 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3395 trampoline
= scm_call_generic_1
;
3400 if (SCM_SMOB_APPLICABLE_P (proc
))
3401 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
3406 case scm_tc7_rpsubr
:
3409 case scm_tc7_program
:
3410 trampoline
= scm_call_1
;
3413 return NULL
; /* not applicable on one arg */
3415 /* We only reach this point if a valid trampoline was determined. */
3417 /* If debugging is enabled, we want to see all calls to proc on the stack.
3418 * Thus, we replace the trampoline shortcut with scm_call_1. */
3419 if (scm_debug_mode_p
)
3426 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
3428 return SCM_SUBRF (proc
) (arg1
, arg2
);
3432 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
3434 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
3438 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
3440 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
3444 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
3446 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3447 scm_list_2 (arg1
, arg2
),
3449 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
3454 scm_trampoline_2 (SCM proc
)
3456 scm_t_trampoline_2 trampoline
;
3461 switch (SCM_TYP7 (proc
))
3463 case scm_tc7_subr_2
:
3464 case scm_tc7_subr_2o
:
3465 case scm_tc7_rpsubr
:
3467 trampoline
= call_subr2_2
;
3469 case scm_tc7_lsubr_2
:
3470 trampoline
= call_lsubr2_2
;
3473 trampoline
= call_lsubr_2
;
3475 case scm_tcs_closures
:
3477 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3478 if (!scm_is_null (formals
)
3479 && (!scm_is_pair (formals
)
3480 || (!scm_is_null (SCM_CDR (formals
))
3481 && (!scm_is_pair (SCM_CDR (formals
))
3482 || !scm_is_pair (SCM_CDDR (formals
))))))
3483 trampoline
= call_closure_2
;
3488 case scm_tcs_struct
:
3489 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3490 trampoline
= scm_call_generic_2
;
3495 if (SCM_SMOB_APPLICABLE_P (proc
))
3496 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
3502 case scm_tc7_program
:
3503 trampoline
= scm_call_2
;
3506 return NULL
; /* not applicable on two args */
3508 /* We only reach this point if a valid trampoline was determined. */
3510 /* If debugging is enabled, we want to see all calls to proc on the stack.
3511 * Thus, we replace the trampoline shortcut with scm_call_2. */
3512 if (scm_debug_mode_p
)
3518 /* Typechecking for multi-argument MAP and FOR-EACH.
3520 Verify that each element of the vector ARGV, except for the first,
3521 is a proper list whose length is LEN. Attribute errors to WHO,
3522 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3524 check_map_args (SCM argv
,
3533 for (i
= SCM_SIMPLE_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
3535 SCM elt
= SCM_SIMPLE_VECTOR_REF (argv
, i
);
3536 long elt_len
= scm_ilength (elt
);
3541 scm_apply_generic (gf
, scm_cons (proc
, args
));
3543 scm_wrong_type_arg (who
, i
+ 2, elt
);
3547 scm_out_of_range_pos (who
, elt
, scm_from_long (i
+ 2));
3552 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3554 /* Note: Currently, scm_map applies PROC to the argument list(s)
3555 sequentially, starting with the first element(s). This is used in
3556 evalext.c where the Scheme procedure `map-in-order', which guarantees
3557 sequential behaviour, is implemented using scm_map. If the
3558 behaviour changes, we need to update `map-in-order'.
3562 scm_map (SCM proc
, SCM arg1
, SCM args
)
3563 #define FUNC_NAME s_map
3569 len
= scm_ilength (arg1
);
3570 SCM_GASSERTn (len
>= 0,
3571 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
3572 SCM_VALIDATE_REST_ARGUMENT (args
);
3573 if (scm_is_null (args
))
3575 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
3576 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
3577 while (SCM_NIMP (arg1
))
3579 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
3580 pres
= SCM_CDRLOC (*pres
);
3581 arg1
= SCM_CDR (arg1
);
3585 if (scm_is_null (SCM_CDR (args
)))
3587 SCM arg2
= SCM_CAR (args
);
3588 int len2
= scm_ilength (arg2
);
3589 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
3591 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
3592 SCM_GASSERTn (len2
>= 0,
3593 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
3595 SCM_OUT_OF_RANGE (3, arg2
);
3596 while (SCM_NIMP (arg1
))
3598 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
3599 pres
= SCM_CDRLOC (*pres
);
3600 arg1
= SCM_CDR (arg1
);
3601 arg2
= SCM_CDR (arg2
);
3605 arg1
= scm_cons (arg1
, args
);
3606 args
= scm_vector (arg1
);
3607 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
3611 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3613 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
3616 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
3617 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
3619 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
3620 pres
= SCM_CDRLOC (*pres
);
3626 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
3629 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
3630 #define FUNC_NAME s_for_each
3633 len
= scm_ilength (arg1
);
3634 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
3635 SCM_ARG2
, s_for_each
);
3636 SCM_VALIDATE_REST_ARGUMENT (args
);
3637 if (scm_is_null (args
))
3639 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
3640 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
3641 while (SCM_NIMP (arg1
))
3643 call (proc
, SCM_CAR (arg1
));
3644 arg1
= SCM_CDR (arg1
);
3646 return SCM_UNSPECIFIED
;
3648 if (scm_is_null (SCM_CDR (args
)))
3650 SCM arg2
= SCM_CAR (args
);
3651 int len2
= scm_ilength (arg2
);
3652 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
3653 SCM_GASSERTn (call
, g_for_each
,
3654 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
3655 SCM_GASSERTn (len2
>= 0, g_for_each
,
3656 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
3658 SCM_OUT_OF_RANGE (3, arg2
);
3659 while (SCM_NIMP (arg1
))
3661 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
3662 arg1
= SCM_CDR (arg1
);
3663 arg2
= SCM_CDR (arg2
);
3665 return SCM_UNSPECIFIED
;
3667 arg1
= scm_cons (arg1
, args
);
3668 args
= scm_vector (arg1
);
3669 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
3673 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3675 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
3677 return SCM_UNSPECIFIED
;
3678 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
3679 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
3681 scm_apply (proc
, arg1
, SCM_EOL
);
3688 scm_closure (SCM code
, SCM env
)
3691 SCM closcar
= scm_cons (code
, SCM_EOL
);
3692 z
= scm_immutable_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
,
3694 scm_remember_upto_here (closcar
);
3699 scm_t_bits scm_tc16_promise
;
3701 SCM_DEFINE (scm_make_promise
, "make-promise", 1, 0, 0,
3703 "Create a new promise object.\n\n"
3704 "@code{make-promise} is a procedural form of @code{delay}.\n"
3705 "These two expressions are equivalent:\n"
3707 "(delay @var{exp})\n"
3708 "(make-promise (lambda () @var{exp}))\n"
3710 #define FUNC_NAME s_scm_make_promise
3712 SCM_VALIDATE_THUNK (1, thunk
);
3713 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
3715 scm_make_recursive_mutex ());
3721 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
3723 int writingp
= SCM_WRITINGP (pstate
);
3724 scm_puts ("#<promise ", port
);
3725 SCM_SET_WRITINGP (pstate
, 1);
3726 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
3727 SCM_SET_WRITINGP (pstate
, writingp
);
3728 scm_putc ('>', port
);
3732 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
3734 "If the promise @var{x} has not been computed yet, compute and\n"
3735 "return @var{x}, otherwise just return the previously computed\n"
3737 #define FUNC_NAME s_scm_force
3739 SCM_VALIDATE_SMOB (1, promise
, promise
);
3740 scm_lock_mutex (SCM_PROMISE_MUTEX (promise
));
3741 if (!SCM_PROMISE_COMPUTED_P (promise
))
3743 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
3744 if (!SCM_PROMISE_COMPUTED_P (promise
))
3746 SCM_SET_PROMISE_DATA (promise
, ans
);
3747 SCM_SET_PROMISE_COMPUTED (promise
);
3750 scm_unlock_mutex (SCM_PROMISE_MUTEX (promise
));
3751 return SCM_PROMISE_DATA (promise
);
3756 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
3758 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
3759 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
3760 #define FUNC_NAME s_scm_promise_p
3762 return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
3767 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
3768 (SCM xorig
, SCM x
, SCM y
),
3769 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
3770 "Any source properties associated with @var{xorig} are also associated\n"
3771 "with the new pair.")
3772 #define FUNC_NAME s_scm_cons_source
3775 z
= scm_cons (x
, y
);
3776 /* Copy source properties possibly associated with xorig. */
3777 p
= scm_whash_lookup (scm_source_whash
, xorig
);
3778 if (scm_is_true (p
))
3779 scm_whash_insert (scm_source_whash
, z
, p
);
3785 /* The function scm_copy_tree is used to copy an expression tree to allow the
3786 * memoizer to modify the expression during memoization. scm_copy_tree
3787 * creates deep copies of pairs and vectors, but not of any other data types,
3788 * since only pairs and vectors will be parsed by the memoizer.
3790 * To avoid infinite recursion due to cyclic structures, the hare-and-tortoise
3791 * pattern is used to detect cycles. In fact, the pattern is used in two
3792 * dimensions, vertical (indicated in the code by the variable names 'hare'
3793 * and 'tortoise') and horizontal ('rabbit' and 'turtle'). In both
3794 * dimensions, the hare/rabbit will take two steps when the tortoise/turtle
3797 * The vertical dimension corresponds to recursive calls to function
3798 * copy_tree: This happens when descending into vector elements, into cars of
3799 * lists and into the cdr of an improper list. In this dimension, the
3800 * tortoise follows the hare by using the processor stack: Every stack frame
3801 * will hold an instance of struct t_trace. These instances are connected in
3802 * a way that represents the trace of the hare, which thus can be followed by
3803 * the tortoise. The tortoise will always point to struct t_trace instances
3804 * relating to SCM objects that have already been copied. Thus, a cycle is
3805 * detected if the tortoise and the hare point to the same object,
3807 * The horizontal dimension is within one execution of copy_tree, when the
3808 * function cdr's along the pairs of a list. This is the standard
3809 * hare-and-tortoise implementation, found several times in guile. */
3812 struct t_trace
*trace
; /* These pointers form a trace along the stack. */
3813 SCM obj
; /* The object handled at the respective stack frame.*/
3818 struct t_trace
*const hare
,
3819 struct t_trace
*tortoise
,
3820 unsigned int tortoise_delay
)
3822 if (!scm_is_pair (hare
->obj
) && !scm_is_simple_vector (hare
->obj
))
3828 /* Prepare the trace along the stack. */
3829 struct t_trace new_hare
;
3830 hare
->trace
= &new_hare
;
3832 /* The tortoise will make its step after the delay has elapsed. Note
3833 * that in contrast to the typical hare-and-tortoise pattern, the step
3834 * of the tortoise happens before the hare takes its steps. This is, in
3835 * principle, no problem, except for the start of the algorithm: Then,
3836 * it has to be made sure that the hare actually gets its advantage of
3838 if (tortoise_delay
== 0)
3841 tortoise
= tortoise
->trace
;
3842 ASSERT_SYNTAX (!scm_is_eq (hare
->obj
, tortoise
->obj
),
3843 s_bad_expression
, hare
->obj
);
3850 if (scm_is_simple_vector (hare
->obj
))
3852 size_t length
= SCM_SIMPLE_VECTOR_LENGTH (hare
->obj
);
3853 SCM new_vector
= scm_c_make_vector (length
, SCM_UNSPECIFIED
);
3855 /* Each vector element is copied by recursing into copy_tree, having
3856 * the tortoise follow the hare into the depths of the stack. */
3857 unsigned long int i
;
3858 for (i
= 0; i
< length
; ++i
)
3861 new_hare
.obj
= SCM_SIMPLE_VECTOR_REF (hare
->obj
, i
);
3862 new_element
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3863 SCM_SIMPLE_VECTOR_SET (new_vector
, i
, new_element
);
3868 else /* scm_is_pair (hare->obj) */
3873 SCM rabbit
= hare
->obj
;
3874 SCM turtle
= hare
->obj
;
3878 /* The first pair of the list is treated specially, in order to
3879 * preserve a potential source code position. */
3880 result
= tail
= scm_cons_source (rabbit
, SCM_EOL
, SCM_EOL
);
3881 new_hare
.obj
= SCM_CAR (rabbit
);
3882 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3883 SCM_SETCAR (tail
, copy
);
3885 /* The remaining pairs of the list are copied by, horizontally,
3886 * having the turtle follow the rabbit, and, vertically, having the
3887 * tortoise follow the hare into the depths of the stack. */
3888 rabbit
= SCM_CDR (rabbit
);
3889 while (scm_is_pair (rabbit
))
3891 new_hare
.obj
= SCM_CAR (rabbit
);
3892 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3893 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
3894 tail
= SCM_CDR (tail
);
3896 rabbit
= SCM_CDR (rabbit
);
3897 if (scm_is_pair (rabbit
))
3899 new_hare
.obj
= SCM_CAR (rabbit
);
3900 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3901 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
3902 tail
= SCM_CDR (tail
);
3903 rabbit
= SCM_CDR (rabbit
);
3905 turtle
= SCM_CDR (turtle
);
3906 ASSERT_SYNTAX (!scm_is_eq (rabbit
, turtle
),
3907 s_bad_expression
, rabbit
);
3911 /* We have to recurse into copy_tree again for the last cdr, in
3912 * order to handle the situation that it holds a vector. */
3913 new_hare
.obj
= rabbit
;
3914 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3915 SCM_SETCDR (tail
, copy
);
3922 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
3924 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
3925 "the new data structure. @code{copy-tree} recurses down the\n"
3926 "contents of both pairs and vectors (since both cons cells and vector\n"
3927 "cells may point to arbitrary objects), and stops recursing when it hits\n"
3928 "any other object.")
3929 #define FUNC_NAME s_scm_copy_tree
3931 /* Prepare the trace along the stack. */
3932 struct t_trace trace
;
3935 /* In function copy_tree, if the tortoise makes its step, it will do this
3936 * before the hare has the chance to move. Thus, we have to make sure that
3937 * the very first step of the tortoise will not happen after the hare has
3938 * really made two steps. This is achieved by passing '2' as the initial
3939 * delay for the tortoise. NOTE: Since cycles are unlikely, giving the hare
3940 * a bigger advantage may improve performance slightly. */
3941 return copy_tree (&trace
, &trace
, 2);
3946 /* We have three levels of EVAL here:
3948 - scm_i_eval (exp, env)
3950 evaluates EXP in environment ENV. ENV is a lexical environment
3951 structure as used by the actual tree code evaluator. When ENV is
3952 a top-level environment, then changes to the current module are
3953 tracked by updating ENV so that it continues to be in sync with
3956 - scm_primitive_eval (exp)
3958 evaluates EXP in the top-level environment as determined by the
3959 current module. This is done by constructing a suitable
3960 environment and calling scm_i_eval. Thus, changes to the
3961 top-level module are tracked normally.
3963 - scm_eval (exp, mod_or_state)
3965 evaluates EXP while MOD_OR_STATE is the current module or current
3966 dynamic state (as appropriate). This is done by setting the
3967 current module (or dynamic state) to MOD_OR_STATE, invoking
3968 scm_primitive_eval on EXP, and then restoring the current module
3969 (or dynamic state) to the value it had previously. That is,
3970 while EXP is evaluated, changes to the current module (or dynamic
3971 state) are tracked, but these changes do not persist when
3974 For each level of evals, there are two variants, distinguished by a
3975 _x suffix: the ordinary variant does not modify EXP while the _x
3976 variant can destructively modify EXP into something completely
3977 unintelligible. A Scheme data structure passed as EXP to one of the
3978 _x variants should not ever be used again for anything. So when in
3979 doubt, use the ordinary variant.
3984 scm_i_eval_x (SCM exp
, SCM env
)
3986 if (scm_is_symbol (exp
))
3987 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
3989 return SCM_I_XEVAL (exp
, env
, scm_debug_mode_p
);
3993 scm_i_eval (SCM exp
, SCM env
)
3995 exp
= scm_copy_tree (exp
);
3996 if (scm_is_symbol (exp
))
3997 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
3999 return SCM_I_XEVAL (exp
, env
, scm_debug_mode_p
);
4003 scm_primitive_eval_x (SCM exp
)
4006 SCM transformer
= scm_current_module_transformer ();
4007 if (SCM_NIMP (transformer
))
4008 exp
= scm_call_1 (transformer
, exp
);
4009 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4010 return scm_i_eval_x (exp
, env
);
4013 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
4015 "Evaluate @var{exp} in the top-level environment specified by\n"
4016 "the current module.")
4017 #define FUNC_NAME s_scm_primitive_eval
4020 SCM transformer
= scm_current_module_transformer ();
4021 if (scm_is_true (transformer
))
4022 exp
= scm_call_1 (transformer
, exp
);
4023 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4024 return scm_i_eval (exp
, env
);
4029 /* Eval does not take the second arg optionally. This is intentional
4030 * in order to be R5RS compatible, and to prepare for the new module
4031 * system, where we would like to make the choice of evaluation
4032 * environment explicit. */
4035 scm_eval_x (SCM exp
, SCM module_or_state
)
4039 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
4040 if (scm_is_dynamic_state (module_or_state
))
4041 scm_dynwind_current_dynamic_state (module_or_state
);
4043 scm_dynwind_current_module (module_or_state
);
4045 res
= scm_primitive_eval_x (exp
);
4051 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
4052 (SCM exp
, SCM module_or_state
),
4053 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
4054 "in the top-level environment specified by\n"
4055 "@var{module_or_state}.\n"
4056 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
4057 "@var{module_or_state} is made the current module when\n"
4058 "it is a module, or the current dynamic state when it is\n"
4060 "Example: (eval '(+ 1 2) (interaction-environment))")
4061 #define FUNC_NAME s_scm_eval
4065 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
4066 if (scm_is_dynamic_state (module_or_state
))
4067 scm_dynwind_current_dynamic_state (module_or_state
);
4068 else if (scm_module_system_booted_p
)
4070 SCM_VALIDATE_MODULE (2, module_or_state
);
4071 scm_dynwind_current_module (module_or_state
);
4073 /* otherwise if the module system isn't booted, ignore the module arg */
4075 res
= scm_primitive_eval (exp
);
4083 /* At this point, deval and scm_dapply are generated.
4095 scm_i_pthread_mutex_init (&source_mutex
,
4096 scm_i_pthread_mutexattr_recursive
);
4098 scm_init_opts (scm_evaluator_traps
,
4099 scm_evaluator_trap_table
);
4100 scm_init_opts (scm_eval_options_interface
,
4103 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
4104 scm_set_smob_print (scm_tc16_promise
, promise_print
);
4106 undefineds
= scm_list_1 (SCM_UNDEFINED
);
4107 SCM_SETCDR (undefineds
, undefineds
);
4108 scm_permanent_object (undefineds
);
4110 scm_listofnull
= scm_list_1 (SCM_EOL
);
4112 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
4113 scm_permanent_object (f_apply
);
4115 #include "libguile/eval.x"
4117 scm_add_feature ("delay");