1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004
2 * Free Software Foundation, Inc.
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public
6 * License as published by the Free Software Foundation; either
7 * version 2.1 of the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
23 /* This file is read twice in order to produce debugging versions of ceval and
24 * scm_apply. These functions, deval and scm_dapply, are produced when we
25 * define the preprocessor macro DEVAL. The file is divided into sections
26 * which are treated differently with respect to DEVAL. The heads of these
27 * sections are marked with the string "SECTION:". */
29 /* SECTION: This code is compiled once.
36 #include "libguile/__scm.h"
40 /* AIX requires this to be the first thing in the file. The #pragma
41 directive is indented so pre-ANSI compilers will ignore it, rather
50 # ifndef alloca /* predefined by HP cc +Olibcalls */
58 #include "libguile/_scm.h"
59 #include "libguile/alist.h"
60 #include "libguile/async.h"
61 #include "libguile/continuations.h"
62 #include "libguile/debug.h"
63 #include "libguile/deprecation.h"
64 #include "libguile/dynwind.h"
65 #include "libguile/eq.h"
66 #include "libguile/feature.h"
67 #include "libguile/fluids.h"
68 #include "libguile/futures.h"
69 #include "libguile/goops.h"
70 #include "libguile/hash.h"
71 #include "libguile/hashtab.h"
72 #include "libguile/lang.h"
73 #include "libguile/list.h"
74 #include "libguile/macros.h"
75 #include "libguile/modules.h"
76 #include "libguile/objects.h"
77 #include "libguile/ports.h"
78 #include "libguile/print.h"
79 #include "libguile/procprop.h"
80 #include "libguile/root.h"
81 #include "libguile/smob.h"
82 #include "libguile/srcprop.h"
83 #include "libguile/stackchk.h"
84 #include "libguile/strings.h"
85 #include "libguile/threads.h"
86 #include "libguile/throw.h"
87 #include "libguile/validate.h"
88 #include "libguile/values.h"
89 #include "libguile/vectors.h"
91 #include "libguile/eval.h"
95 static SCM
unmemoize_exprs (SCM expr
, SCM env
);
96 static SCM
canonicalize_define (SCM expr
);
97 static SCM
*scm_lookupcar1 (SCM vloc
, SCM genv
, int check
);
98 static SCM
unmemoize_builtin_macro (SCM expr
, SCM env
);
104 * This section defines the message strings for the syntax errors that can be
105 * detected during memoization and the functions and macros that shall be
106 * called by the memoizer code to signal syntax errors. */
109 /* Syntax errors that can be detected during memoization: */
111 /* Circular or improper lists do not form valid scheme expressions. If a
112 * circular list or an improper list is detected in a place where a scheme
113 * expression is expected, a 'Bad expression' error is signalled. */
114 static const char s_bad_expression
[] = "Bad expression";
116 /* If a form is detected that holds a different number of expressions than are
117 * required in that context, a 'Missing or extra expression' error is
119 static const char s_expression
[] = "Missing or extra expression in";
121 /* If a form is detected that holds less expressions than are required in that
122 * context, a 'Missing expression' error is signalled. */
123 static const char s_missing_expression
[] = "Missing expression in";
125 /* If a form is detected that holds more expressions than are allowed in that
126 * context, an 'Extra expression' error is signalled. */
127 static const char s_extra_expression
[] = "Extra expression in";
129 /* The empty combination '()' is not allowed as an expression in scheme. If
130 * it is detected in a place where an expression is expected, an 'Illegal
131 * empty combination' error is signalled. Note: If you encounter this error
132 * message, it is very likely that you intended to denote the empty list. To
133 * do so, you need to quote the empty list like (quote ()) or '(). */
134 static const char s_empty_combination
[] = "Illegal empty combination";
136 /* A body may hold an arbitrary number of internal defines, followed by a
137 * non-empty sequence of expressions. If a body with an empty sequence of
138 * expressions is detected, a 'Missing body expression' error is signalled.
140 static const char s_missing_body_expression
[] = "Missing body expression in";
142 /* A body may hold an arbitrary number of internal defines, followed by a
143 * non-empty sequence of expressions. Each the definitions and the
144 * expressions may be grouped arbitraryly with begin, but it is not allowed to
145 * mix definitions and expressions. If a define form in a body mixes
146 * definitions and expressions, a 'Mixed definitions and expressions' error is
148 static const char s_mixed_body_forms
[] = "Mixed definitions and expressions in";
149 /* Definitions are only allowed on the top level and at the start of a body.
150 * If a definition is detected anywhere else, a 'Bad define placement' error
152 static const char s_bad_define
[] = "Bad define placement";
154 /* Case or cond expressions must have at least one clause. If a case or cond
155 * expression without any clauses is detected, a 'Missing clauses' error is
157 static const char s_missing_clauses
[] = "Missing clauses";
159 /* If there is an 'else' clause in a case or a cond statement, it must be the
160 * last clause. If after the 'else' case clause further clauses are detected,
161 * a 'Misplaced else clause' error is signalled. */
162 static const char s_misplaced_else_clause
[] = "Misplaced else clause";
164 /* If a case clause is detected that is not in the format
165 * (<label(s)> <expression1> <expression2> ...)
166 * a 'Bad case clause' error is signalled. */
167 static const char s_bad_case_clause
[] = "Bad case clause";
169 /* If a case clause is detected where the <label(s)> element is neither a
170 * proper list nor (in case of the last clause) the syntactic keyword 'else',
171 * a 'Bad case labels' error is signalled. Note: If you encounter this error
172 * for an else-clause which seems to be syntactically correct, check if 'else'
173 * is really a syntactic keyword in that context. If 'else' is bound in the
174 * local or global environment, it is not considered a syntactic keyword, but
175 * will be treated as any other variable. */
176 static const char s_bad_case_labels
[] = "Bad case labels";
178 /* In a case statement all labels have to be distinct. If in a case statement
179 * a label occurs more than once, a 'Duplicate case label' error is
181 static const char s_duplicate_case_label
[] = "Duplicate case label";
183 /* If a cond clause is detected that is not in one of the formats
184 * (<test> <expression1> ...) or (else <expression1> <expression2> ...)
185 * a 'Bad cond clause' error is signalled. */
186 static const char s_bad_cond_clause
[] = "Bad cond clause";
188 /* If a cond clause is detected that uses the alternate '=>' form, but does
189 * not hold a recipient element for the test result, a 'Missing recipient'
190 * error is signalled. */
191 static const char s_missing_recipient
[] = "Missing recipient in";
193 /* If in a position where a variable name is required some other object is
194 * detected, a 'Bad variable' error is signalled. */
195 static const char s_bad_variable
[] = "Bad variable";
197 /* Bindings for forms like 'let' and 'do' have to be given in a proper,
198 * possibly empty list. If any other object is detected in a place where a
199 * list of bindings was required, a 'Bad bindings' error is signalled. */
200 static const char s_bad_bindings
[] = "Bad bindings";
202 /* Depending on the syntactic context, a binding has to be in the format
203 * (<variable> <expression>) or (<variable> <expression1> <expression2>).
204 * If anything else is detected in a place where a binding was expected, a
205 * 'Bad binding' error is signalled. */
206 static const char s_bad_binding
[] = "Bad binding";
208 /* Some syntactic forms don't allow variable names to appear more than once in
209 * a list of bindings. If such a situation is nevertheless detected, a
210 * 'Duplicate binding' error is signalled. */
211 static const char s_duplicate_binding
[] = "Duplicate binding";
213 /* If the exit form of a 'do' expression is not in the format
214 * (<test> <expression> ...)
215 * a 'Bad exit clause' error is signalled. */
216 static const char s_bad_exit_clause
[] = "Bad exit clause";
218 /* The formal function arguments of a lambda expression have to be either a
219 * single symbol or a non-cyclic list. For anything else a 'Bad formals'
220 * error is signalled. */
221 static const char s_bad_formals
[] = "Bad formals";
223 /* If in a lambda expression something else than a symbol is detected at a
224 * place where a formal function argument is required, a 'Bad formal' error is
226 static const char s_bad_formal
[] = "Bad formal";
228 /* If in the arguments list of a lambda expression an argument name occurs
229 * more than once, a 'Duplicate formal' error is signalled. */
230 static const char s_duplicate_formal
[] = "Duplicate formal";
232 /* If the evaluation of an unquote-splicing expression gives something else
233 * than a proper list, a 'Non-list result for unquote-splicing' error is
235 static const char s_splicing
[] = "Non-list result for unquote-splicing";
237 /* If something else than an exact integer is detected as the argument for
238 * @slot-ref and @slot-set!, a 'Bad slot number' error is signalled. */
239 static const char s_bad_slot_number
[] = "Bad slot number";
242 /* Signal a syntax error. We distinguish between the form that caused the
243 * error and the enclosing expression. The error message will print out as
244 * shown in the following pattern. The file name and line number are only
245 * given when they can be determined from the erroneous form or from the
246 * enclosing expression.
248 * <filename>: In procedure memoization:
249 * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
251 SCM_SYMBOL (syntax_error_key
, "syntax-error");
253 /* The prototype is needed to indicate that the function does not return. */
255 syntax_error (const char* const, const SCM
, const SCM
) SCM_NORETURN
;
258 syntax_error (const char* const msg
, const SCM form
, const SCM expr
)
260 SCM msg_string
= scm_from_locale_string (msg
);
261 SCM filename
= SCM_BOOL_F
;
262 SCM linenr
= SCM_BOOL_F
;
266 if (scm_is_pair (form
))
268 filename
= scm_source_property (form
, scm_sym_filename
);
269 linenr
= scm_source_property (form
, scm_sym_line
);
272 if (scm_is_false (filename
) && scm_is_false (linenr
) && scm_is_pair (expr
))
274 filename
= scm_source_property (expr
, scm_sym_filename
);
275 linenr
= scm_source_property (expr
, scm_sym_line
);
278 if (!SCM_UNBNDP (expr
))
280 if (scm_is_true (filename
))
282 format
= "In file ~S, line ~S: ~A ~S in expression ~S.";
283 args
= scm_list_5 (filename
, linenr
, msg_string
, form
, expr
);
285 else if (scm_is_true (linenr
))
287 format
= "In line ~S: ~A ~S in expression ~S.";
288 args
= scm_list_4 (linenr
, msg_string
, form
, expr
);
292 format
= "~A ~S in expression ~S.";
293 args
= scm_list_3 (msg_string
, form
, expr
);
298 if (scm_is_true (filename
))
300 format
= "In file ~S, line ~S: ~A ~S.";
301 args
= scm_list_4 (filename
, linenr
, msg_string
, form
);
303 else if (scm_is_true (linenr
))
305 format
= "In line ~S: ~A ~S.";
306 args
= scm_list_3 (linenr
, msg_string
, form
);
311 args
= scm_list_2 (msg_string
, form
);
315 scm_error (syntax_error_key
, "memoization", format
, args
, SCM_BOOL_F
);
319 /* Shortcut macros to simplify syntax error handling. */
320 #define ASSERT_SYNTAX(cond, message, form) \
321 { if (!(cond)) syntax_error (message, form, SCM_UNDEFINED); }
322 #define ASSERT_SYNTAX_2(cond, message, form, expr) \
323 { if (!(cond)) syntax_error (message, form, expr); }
329 * Ilocs are memoized references to variables in local environment frames.
330 * They are represented as three values: The relative offset of the
331 * environment frame, the number of the binding within that frame, and a
332 * boolean value indicating whether the binding is the last binding in the
335 * Frame numbers have 11 bits, relative offsets have 12 bits.
338 #define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc)
339 #define SCM_IFRINC (0x00000100L)
340 #define SCM_ICDR (0x00080000L)
341 #define SCM_IDINC (0x00100000L)
342 #define SCM_IFRAME(n) ((long)((SCM_ICDR-SCM_IFRINC)>>8) \
343 & (SCM_UNPACK (n) >> 8))
344 #define SCM_IDIST(n) (SCM_UNPACK (n) >> 20)
345 #define SCM_ICDRP(n) (SCM_ICDR & SCM_UNPACK (n))
346 #define SCM_IDSTMSK (-SCM_IDINC)
347 #define SCM_IFRAMEMAX ((1<<11)-1)
348 #define SCM_IDISTMAX ((1<<12)-1)
349 #define SCM_MAKE_ILOC(frame_nr, binding_nr, last_p) \
352 + ((binding_nr) << 20) \
353 + ((last_p) ? SCM_ICDR : 0) \
357 scm_i_print_iloc (SCM iloc
, SCM port
)
359 scm_puts ("#@", port
);
360 scm_intprint ((long) SCM_IFRAME (iloc
), 10, port
);
361 scm_putc (SCM_ICDRP (iloc
) ? '-' : '+', port
);
362 scm_intprint ((long) SCM_IDIST (iloc
), 10, port
);
365 #if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
367 SCM
scm_dbg_make_iloc (SCM frame
, SCM binding
, SCM cdrp
);
369 SCM_DEFINE (scm_dbg_make_iloc
, "dbg-make-iloc", 3, 0, 0,
370 (SCM frame
, SCM binding
, SCM cdrp
),
371 "Return a new iloc with frame offset @var{frame}, binding\n"
372 "offset @var{binding} and the cdr flag @var{cdrp}.")
373 #define FUNC_NAME s_scm_dbg_make_iloc
375 return SCM_MAKE_ILOC (scm_to_unsigned_integer (frame
, 0, SCM_IFRAME_MAX
),
376 scm_to_unsigned_integer (binding
, 0, SCM_IDIST_MAX
),
381 SCM
scm_dbg_iloc_p (SCM obj
);
383 SCM_DEFINE (scm_dbg_iloc_p
, "dbg-iloc?", 1, 0, 0,
385 "Return @code{#t} if @var{obj} is an iloc.")
386 #define FUNC_NAME s_scm_dbg_iloc_p
388 return scm_from_bool (SCM_ILOCP (obj
));
396 /* {Evaluator byte codes (isyms)}
399 #define ISYMNUM(n) (SCM_ITAG8_DATA (n))
401 /* This table must agree with the list of SCM_IM_ constants in tags.h */
402 static const char *const isymnames
[] =
419 "#@call-with-current-continuation",
425 "#@call-with-values",
433 scm_i_print_isym (SCM isym
, SCM port
)
435 const size_t isymnum
= ISYMNUM (isym
);
436 if (isymnum
< (sizeof isymnames
/ sizeof (char *)))
437 scm_puts (isymnames
[isymnum
], port
);
439 scm_ipruk ("isym", isym
, port
);
444 /* The function lookup_symbol is used during memoization: Lookup the symbol in
445 * the environment. If there is no binding for the symbol, SCM_UNDEFINED is
446 * returned. If the symbol is a global variable, the variable object to which
447 * the symbol is bound is returned. Finally, if the symbol is a local
448 * variable the corresponding iloc object is returned. */
450 /* A helper function for lookup_symbol: Try to find the symbol in the top
451 * level environment frame. The function returns SCM_UNDEFINED if the symbol
452 * is unbound and it returns a variable object if the symbol is a global
455 lookup_global_symbol (const SCM symbol
, const SCM top_level
)
457 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
458 if (scm_is_false (variable
))
459 return SCM_UNDEFINED
;
465 lookup_symbol (const SCM symbol
, const SCM env
)
468 unsigned int frame_nr
;
470 for (frame_idx
= env
, frame_nr
= 0;
471 !scm_is_null (frame_idx
);
472 frame_idx
= SCM_CDR (frame_idx
), ++frame_nr
)
474 const SCM frame
= SCM_CAR (frame_idx
);
475 if (scm_is_pair (frame
))
477 /* frame holds a local environment frame */
479 unsigned int symbol_nr
;
481 for (symbol_idx
= SCM_CAR (frame
), symbol_nr
= 0;
482 scm_is_pair (symbol_idx
);
483 symbol_idx
= SCM_CDR (symbol_idx
), ++symbol_nr
)
485 if (scm_is_eq (SCM_CAR (symbol_idx
), symbol
))
486 /* found the symbol, therefore return the iloc */
487 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 0);
489 if (scm_is_eq (symbol_idx
, symbol
))
490 /* found the symbol as the last element of the current frame */
491 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 1);
495 /* no more local environment frames */
496 return lookup_global_symbol (symbol
, frame
);
500 return lookup_global_symbol (symbol
, SCM_BOOL_F
);
504 /* Return true if the symbol is - from the point of view of a macro
505 * transformer - a literal in the sense specified in chapter "pattern
506 * language" of R5RS. In the code below, however, we don't match the
507 * definition of R5RS exactly: It returns true if the identifier has no
508 * binding or if it is a syntactic keyword. */
510 literal_p (const SCM symbol
, const SCM env
)
512 const SCM variable
= lookup_symbol (symbol
, env
);
513 if (SCM_UNBNDP (variable
))
515 if (SCM_VARIABLEP (variable
) && SCM_MACROP (SCM_VARIABLE_REF (variable
)))
522 /* Return true if the expression is self-quoting in the memoized code. Thus,
523 * some other objects (like e. g. vectors) are reported as self-quoting, which
524 * according to R5RS would need to be quoted. */
526 is_self_quoting_p (const SCM expr
)
528 if (scm_is_pair (expr
))
530 else if (scm_is_symbol (expr
))
532 else if (scm_is_null (expr
))
538 SCM_SYMBOL (sym_three_question_marks
, "???");
541 unmemoize_expression (const SCM expr
, const SCM env
)
543 if (SCM_ILOCP (expr
))
546 unsigned long int frame_nr
;
548 unsigned long int symbol_nr
;
550 for (frame_idx
= env
, frame_nr
= SCM_IFRAME (expr
);
552 frame_idx
= SCM_CDR (frame_idx
), --frame_nr
)
554 for (symbol_idx
= SCM_CAAR (frame_idx
), symbol_nr
= SCM_IDIST (expr
);
556 symbol_idx
= SCM_CDR (symbol_idx
), --symbol_nr
)
558 return SCM_ICDRP (expr
) ? symbol_idx
: SCM_CAR (symbol_idx
);
560 else if (SCM_VARIABLEP (expr
))
562 const SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), expr
);
563 return scm_is_true (sym
) ? sym
: sym_three_question_marks
;
565 else if (scm_is_simple_vector (expr
))
567 return scm_list_2 (scm_sym_quote
, expr
);
569 else if (!scm_is_pair (expr
))
573 else if (SCM_ISYMP (SCM_CAR (expr
)))
575 return unmemoize_builtin_macro (expr
, env
);
579 return unmemoize_exprs (expr
, env
);
585 unmemoize_exprs (const SCM exprs
, const SCM env
)
587 SCM r_result
= SCM_EOL
;
588 SCM expr_idx
= exprs
;
591 /* Note that due to the current lazy memoizer we may find partially memoized
592 * code during execution. In such code we have to expect improper lists of
593 * expressions: On the one hand, for such code syntax checks have not yet
594 * fully been performed, on the other hand, there may be even legal code
595 * like '(a . b) appear as an improper list of expressions as long as the
596 * quote expression is still in its unmemoized form. For this reason, the
597 * following code handles improper lists of expressions until memoization
598 * and execution have been completely separated. */
599 for (; scm_is_pair (expr_idx
); expr_idx
= SCM_CDR (expr_idx
))
601 const SCM expr
= SCM_CAR (expr_idx
);
603 /* In partially memoized code, lists of expressions that stem from a
604 * body form may start with an ISYM if the body itself has not yet been
605 * memoized. This isym is just an internal marker to indicate that the
606 * body still needs to be memoized. An isym may occur at the very
607 * beginning of the body or after one or more comment strings. It is
608 * dropped during unmemoization. */
609 if (!SCM_ISYMP (expr
))
611 um_expr
= unmemoize_expression (expr
, env
);
612 r_result
= scm_cons (um_expr
, r_result
);
615 um_expr
= unmemoize_expression (expr_idx
, env
);
616 if (!scm_is_null (r_result
))
618 const SCM result
= scm_reverse_x (r_result
, SCM_UNDEFINED
);
619 SCM_SETCDR (r_result
, um_expr
);
629 /* Rewrite the body (which is given as the list of expressions forming the
630 * body) into its internal form. The internal form of a body (<expr> ...) is
631 * just the body itself, but prefixed with an ISYM that denotes to what kind
632 * of outer construct this body belongs: (<ISYM> <expr> ...). A lambda body
633 * starts with SCM_IM_LAMBDA, for example, a body of a let starts with
636 * It is assumed that the calling expression has already made sure that the
637 * body is a proper list. */
639 m_body (SCM op
, SCM exprs
)
641 /* Don't add another ISYM if one is present already. */
642 if (SCM_ISYMP (SCM_CAR (exprs
)))
645 return scm_cons (op
, exprs
);
649 /* The function m_expand_body memoizes a proper list of expressions forming a
650 * body. This function takes care of dealing with internal defines and
651 * transforming them into an equivalent letrec expression. The list of
652 * expressions is rewritten in place. */
654 /* This is a helper function for m_expand_body. If the argument expression is
655 * a symbol that denotes a syntactic keyword, the corresponding macro object
656 * is returned, in all other cases the function returns SCM_UNDEFINED. */
658 try_macro_lookup (const SCM expr
, const SCM env
)
660 if (scm_is_symbol (expr
))
662 const SCM variable
= lookup_symbol (expr
, env
);
663 if (SCM_VARIABLEP (variable
))
665 const SCM value
= SCM_VARIABLE_REF (variable
);
666 if (SCM_MACROP (value
))
671 return SCM_UNDEFINED
;
674 /* This is a helper function for m_expand_body. It expands user macros,
675 * because for the correct translation of a body we need to know whether they
676 * expand to a definition. */
678 expand_user_macros (SCM expr
, const SCM env
)
680 while (scm_is_pair (expr
))
682 const SCM car_expr
= SCM_CAR (expr
);
683 const SCM new_car
= expand_user_macros (car_expr
, env
);
684 const SCM value
= try_macro_lookup (new_car
, env
);
686 if (SCM_MACROP (value
) && SCM_MACRO_TYPE (value
) == 2)
688 /* User macros transform code into code. */
689 expr
= scm_call_2 (SCM_MACRO_CODE (value
), expr
, env
);
690 /* We need to reiterate on the transformed code. */
694 /* No user macro: return. */
695 SCM_SETCAR (expr
, new_car
);
703 /* This is a helper function for m_expand_body. It determines if a given form
704 * represents an application of a given built-in macro. The built-in macro to
705 * check for is identified by its syntactic keyword. The form is an
706 * application of the given macro if looking up the car of the form in the
707 * given environment actually returns the built-in macro. */
709 is_system_macro_p (const SCM syntactic_keyword
, const SCM form
, const SCM env
)
711 if (scm_is_pair (form
))
713 const SCM car_form
= SCM_CAR (form
);
714 const SCM value
= try_macro_lookup (car_form
, env
);
715 if (SCM_BUILTIN_MACRO_P (value
))
717 const SCM macro_name
= scm_macro_name (value
);
718 return scm_is_eq (macro_name
, syntactic_keyword
);
726 m_expand_body (const SCM forms
, const SCM env
)
728 /* The first body form can be skipped since it is known to be the ISYM that
729 * was prepended to the body by m_body. */
730 SCM cdr_forms
= SCM_CDR (forms
);
731 SCM form_idx
= cdr_forms
;
732 SCM definitions
= SCM_EOL
;
733 SCM sequence
= SCM_EOL
;
735 /* According to R5RS, the list of body forms consists of two parts: a number
736 * (maybe zero) of definitions, followed by a non-empty sequence of
737 * expressions. Each the definitions and the expressions may be grouped
738 * arbitrarily with begin, but it is not allowed to mix definitions and
739 * expressions. The task of the following loop therefore is to split the
740 * list of body forms into the list of definitions and the sequence of
742 while (!scm_is_null (form_idx
))
744 const SCM form
= SCM_CAR (form_idx
);
745 const SCM new_form
= expand_user_macros (form
, env
);
746 if (is_system_macro_p (scm_sym_define
, new_form
, env
))
748 definitions
= scm_cons (new_form
, definitions
);
749 form_idx
= SCM_CDR (form_idx
);
751 else if (is_system_macro_p (scm_sym_begin
, new_form
, env
))
753 /* We have encountered a group of forms. This has to be either a
754 * (possibly empty) group of (possibly further grouped) definitions,
755 * or a non-empty group of (possibly further grouped)
757 const SCM grouped_forms
= SCM_CDR (new_form
);
758 unsigned int found_definition
= 0;
759 unsigned int found_expression
= 0;
760 SCM grouped_form_idx
= grouped_forms
;
761 while (!found_expression
&& !scm_is_null (grouped_form_idx
))
763 const SCM inner_form
= SCM_CAR (grouped_form_idx
);
764 const SCM new_inner_form
= expand_user_macros (inner_form
, env
);
765 if (is_system_macro_p (scm_sym_define
, new_inner_form
, env
))
767 found_definition
= 1;
768 definitions
= scm_cons (new_inner_form
, definitions
);
769 grouped_form_idx
= SCM_CDR (grouped_form_idx
);
771 else if (is_system_macro_p (scm_sym_begin
, new_inner_form
, env
))
773 const SCM inner_group
= SCM_CDR (new_inner_form
);
775 = scm_append (scm_list_2 (inner_group
,
776 SCM_CDR (grouped_form_idx
)));
780 /* The group marks the start of the expressions of the body.
781 * We have to make sure that within the same group we have
782 * not encountered a definition before. */
783 ASSERT_SYNTAX (!found_definition
, s_mixed_body_forms
, form
);
784 found_expression
= 1;
785 grouped_form_idx
= SCM_EOL
;
789 /* We have finished processing the group. If we have not yet
790 * encountered an expression we continue processing the forms of the
791 * body to collect further definition forms. Otherwise, the group
792 * marks the start of the sequence of expressions of the body. */
793 if (!found_expression
)
795 form_idx
= SCM_CDR (form_idx
);
805 /* We have detected a form which is no definition. This marks the
806 * start of the sequence of expressions of the body. */
812 /* FIXME: forms does not hold information about the file location. */
813 ASSERT_SYNTAX (scm_is_pair (sequence
), s_missing_body_expression
, cdr_forms
);
815 if (!scm_is_null (definitions
))
819 SCM letrec_expression
;
820 SCM new_letrec_expression
;
822 SCM bindings
= SCM_EOL
;
823 for (definition_idx
= definitions
;
824 !scm_is_null (definition_idx
);
825 definition_idx
= SCM_CDR (definition_idx
))
827 const SCM definition
= SCM_CAR (definition_idx
);
828 const SCM canonical_definition
= canonicalize_define (definition
);
829 const SCM binding
= SCM_CDR (canonical_definition
);
830 bindings
= scm_cons (binding
, bindings
);
833 letrec_tail
= scm_cons (bindings
, sequence
);
834 /* FIXME: forms does not hold information about the file location. */
835 letrec_expression
= scm_cons_source (forms
, scm_sym_letrec
, letrec_tail
);
836 new_letrec_expression
= scm_m_letrec (letrec_expression
, env
);
837 SCM_SETCAR (forms
, new_letrec_expression
);
838 SCM_SETCDR (forms
, SCM_EOL
);
842 SCM_SETCAR (forms
, SCM_CAR (sequence
));
843 SCM_SETCDR (forms
, SCM_CDR (sequence
));
848 macroexp (SCM x
, SCM env
)
850 SCM res
, proc
, orig_sym
;
852 /* Don't bother to produce error messages here. We get them when we
853 eventually execute the code for real. */
856 orig_sym
= SCM_CAR (x
);
857 if (!scm_is_symbol (orig_sym
))
861 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
862 if (proc_ptr
== NULL
)
864 /* We have lost the race. */
870 /* Only handle memoizing macros. `Acros' and `macros' are really
871 special forms and should not be evaluated here. */
873 if (!SCM_MACROP (proc
)
874 || (SCM_MACRO_TYPE (proc
) != 2 && !SCM_BUILTIN_MACRO_P (proc
)))
877 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
878 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
880 if (scm_ilength (res
) <= 0)
881 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
883 /* njrev: Several queries here: (1) I don't see how it can be
884 correct that the SCM_SETCAR 2 lines below this comment needs
885 protection, but the SCM_SETCAR 6 lines above does not, so
886 something here is probably wrong. (2) macroexp() is now only
887 used in one place - scm_m_generalized_set_x - whereas all other
888 macro expansion happens through expand_user_macros. Therefore
889 (2.1) perhaps macroexp() could be eliminated completely now?
890 (2.2) Does expand_user_macros need any critical section
893 SCM_CRITICAL_SECTION_START
;
894 SCM_SETCAR (x
, SCM_CAR (res
));
895 SCM_SETCDR (x
, SCM_CDR (res
));
896 SCM_CRITICAL_SECTION_END
;
901 /* Start of the memoizers for the standard R5RS builtin macros. */
904 SCM_SYNTAX (s_and
, "and", scm_i_makbimacro
, scm_m_and
);
905 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
908 scm_m_and (SCM expr
, SCM env SCM_UNUSED
)
910 const SCM cdr_expr
= SCM_CDR (expr
);
911 const long length
= scm_ilength (cdr_expr
);
913 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
917 /* Special case: (and) is replaced by #t. */
922 SCM_SETCAR (expr
, SCM_IM_AND
);
928 unmemoize_and (const SCM expr
, const SCM env
)
930 return scm_cons (scm_sym_and
, unmemoize_exprs (SCM_CDR (expr
), env
));
934 SCM_SYNTAX (s_begin
, "begin", scm_i_makbimacro
, scm_m_begin
);
935 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
938 scm_m_begin (SCM expr
, SCM env SCM_UNUSED
)
940 const SCM cdr_expr
= SCM_CDR (expr
);
941 /* Dirk:FIXME:: An empty begin clause is not generally allowed by R5RS.
942 * That means, there should be a distinction between uses of begin where an
943 * empty clause is OK and where it is not. */
944 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
946 SCM_SETCAR (expr
, SCM_IM_BEGIN
);
951 unmemoize_begin (const SCM expr
, const SCM env
)
953 return scm_cons (scm_sym_begin
, unmemoize_exprs (SCM_CDR (expr
), env
));
957 SCM_SYNTAX (s_case
, "case", scm_i_makbimacro
, scm_m_case
);
958 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
959 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
962 scm_m_case (SCM expr
, SCM env
)
965 SCM all_labels
= SCM_EOL
;
967 /* Check, whether 'else is a literal, i. e. not bound to a value. */
968 const int else_literal_p
= literal_p (scm_sym_else
, env
);
970 const SCM cdr_expr
= SCM_CDR (expr
);
971 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
972 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_clauses
, expr
);
974 clauses
= SCM_CDR (cdr_expr
);
975 while (!scm_is_null (clauses
))
979 const SCM clause
= SCM_CAR (clauses
);
980 ASSERT_SYNTAX_2 (scm_ilength (clause
) >= 2,
981 s_bad_case_clause
, clause
, expr
);
983 labels
= SCM_CAR (clause
);
984 if (scm_is_pair (labels
))
986 ASSERT_SYNTAX_2 (scm_ilength (labels
) >= 0,
987 s_bad_case_labels
, labels
, expr
);
988 all_labels
= scm_append (scm_list_2 (labels
, all_labels
));
990 else if (scm_is_null (labels
))
992 /* The list of labels is empty. According to R5RS this is allowed.
993 * It means that the sequence of expressions will never be executed.
994 * Therefore, as an optimization, we could remove the whole
999 ASSERT_SYNTAX_2 (scm_is_eq (labels
, scm_sym_else
) && else_literal_p
,
1000 s_bad_case_labels
, labels
, expr
);
1001 ASSERT_SYNTAX_2 (scm_is_null (SCM_CDR (clauses
)),
1002 s_misplaced_else_clause
, clause
, expr
);
1005 /* build the new clause */
1006 if (scm_is_eq (labels
, scm_sym_else
))
1007 SCM_SETCAR (clause
, SCM_IM_ELSE
);
1009 clauses
= SCM_CDR (clauses
);
1012 /* Check whether all case labels are distinct. */
1013 for (; !scm_is_null (all_labels
); all_labels
= SCM_CDR (all_labels
))
1015 const SCM label
= SCM_CAR (all_labels
);
1016 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (label
, SCM_CDR (all_labels
))),
1017 s_duplicate_case_label
, label
, expr
);
1020 SCM_SETCAR (expr
, SCM_IM_CASE
);
1025 unmemoize_case (const SCM expr
, const SCM env
)
1027 const SCM um_key_expr
= unmemoize_expression (SCM_CADR (expr
), env
);
1028 SCM um_clauses
= SCM_EOL
;
1031 for (clause_idx
= SCM_CDDR (expr
);
1032 !scm_is_null (clause_idx
);
1033 clause_idx
= SCM_CDR (clause_idx
))
1035 const SCM clause
= SCM_CAR (clause_idx
);
1036 const SCM labels
= SCM_CAR (clause
);
1037 const SCM exprs
= SCM_CDR (clause
);
1039 const SCM um_exprs
= unmemoize_exprs (exprs
, env
);
1040 const SCM um_labels
= (scm_is_eq (labels
, SCM_IM_ELSE
))
1042 : scm_i_finite_list_copy (labels
);
1043 const SCM um_clause
= scm_cons (um_labels
, um_exprs
);
1045 um_clauses
= scm_cons (um_clause
, um_clauses
);
1047 um_clauses
= scm_reverse_x (um_clauses
, SCM_UNDEFINED
);
1049 return scm_cons2 (scm_sym_case
, um_key_expr
, um_clauses
);
1053 SCM_SYNTAX (s_cond
, "cond", scm_i_makbimacro
, scm_m_cond
);
1054 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
1055 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
1058 scm_m_cond (SCM expr
, SCM env
)
1060 /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
1061 const int else_literal_p
= literal_p (scm_sym_else
, env
);
1062 const int arrow_literal_p
= literal_p (scm_sym_arrow
, env
);
1064 const SCM clauses
= SCM_CDR (expr
);
1067 ASSERT_SYNTAX (scm_ilength (clauses
) >= 0, s_bad_expression
, expr
);
1068 ASSERT_SYNTAX (scm_ilength (clauses
) >= 1, s_missing_clauses
, expr
);
1070 for (clause_idx
= clauses
;
1071 !scm_is_null (clause_idx
);
1072 clause_idx
= SCM_CDR (clause_idx
))
1076 const SCM clause
= SCM_CAR (clause_idx
);
1077 const long length
= scm_ilength (clause
);
1078 ASSERT_SYNTAX_2 (length
>= 1, s_bad_cond_clause
, clause
, expr
);
1080 test
= SCM_CAR (clause
);
1081 if (scm_is_eq (test
, scm_sym_else
) && else_literal_p
)
1083 const int last_clause_p
= scm_is_null (SCM_CDR (clause_idx
));
1084 ASSERT_SYNTAX_2 (length
>= 2,
1085 s_bad_cond_clause
, clause
, expr
);
1086 ASSERT_SYNTAX_2 (last_clause_p
,
1087 s_misplaced_else_clause
, clause
, expr
);
1088 SCM_SETCAR (clause
, SCM_IM_ELSE
);
1090 else if (length
>= 2
1091 && scm_is_eq (SCM_CADR (clause
), scm_sym_arrow
)
1094 ASSERT_SYNTAX_2 (length
> 2, s_missing_recipient
, clause
, expr
);
1095 ASSERT_SYNTAX_2 (length
== 3, s_extra_expression
, clause
, expr
);
1096 SCM_SETCAR (SCM_CDR (clause
), SCM_IM_ARROW
);
1100 SCM_SETCAR (expr
, SCM_IM_COND
);
1105 unmemoize_cond (const SCM expr
, const SCM env
)
1107 SCM um_clauses
= SCM_EOL
;
1110 for (clause_idx
= SCM_CDR (expr
);
1111 !scm_is_null (clause_idx
);
1112 clause_idx
= SCM_CDR (clause_idx
))
1114 const SCM clause
= SCM_CAR (clause_idx
);
1115 const SCM sequence
= SCM_CDR (clause
);
1116 const SCM test
= SCM_CAR (clause
);
1121 if (scm_is_eq (test
, SCM_IM_ELSE
))
1122 um_test
= scm_sym_else
;
1124 um_test
= unmemoize_expression (test
, env
);
1126 if (!scm_is_null (sequence
) && scm_is_eq (SCM_CAR (sequence
),
1129 const SCM target
= SCM_CADR (sequence
);
1130 const SCM um_target
= unmemoize_expression (target
, env
);
1131 um_sequence
= scm_list_2 (scm_sym_arrow
, um_target
);
1135 um_sequence
= unmemoize_exprs (sequence
, env
);
1138 um_clause
= scm_cons (um_test
, um_sequence
);
1139 um_clauses
= scm_cons (um_clause
, um_clauses
);
1141 um_clauses
= scm_reverse_x (um_clauses
, SCM_UNDEFINED
);
1143 return scm_cons (scm_sym_cond
, um_clauses
);
1147 SCM_SYNTAX (s_define
, "define", scm_i_makbimacro
, scm_m_define
);
1148 SCM_GLOBAL_SYMBOL (scm_sym_define
, s_define
);
1150 /* Guile provides an extension to R5RS' define syntax to represent function
1151 * currying in a compact way. With this extension, it is allowed to write
1152 * (define <nested-variable> <body>), where <nested-variable> has of one of
1153 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
1154 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
1155 * should be either a sequence of zero or more variables, or a sequence of one
1156 * or more variables followed by a space-delimited period and another
1157 * variable. Each level of argument nesting wraps the <body> within another
1158 * lambda expression. For example, the following forms are allowed, each one
1159 * followed by an equivalent, more explicit implementation.
1161 * (define ((a b . c) . d) <body>) is equivalent to
1162 * (define a (lambda (b . c) (lambda d <body>)))
1164 * (define (((a) b) c . d) <body>) is equivalent to
1165 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
1167 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
1168 * module that does not implement this extension. */
1170 canonicalize_define (const SCM expr
)
1175 const SCM cdr_expr
= SCM_CDR (expr
);
1176 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1177 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1179 body
= SCM_CDR (cdr_expr
);
1180 variable
= SCM_CAR (cdr_expr
);
1181 while (scm_is_pair (variable
))
1183 /* This while loop realizes function currying by variable nesting.
1184 * Variable is known to be a nested-variable. In every iteration of the
1185 * loop another level of lambda expression is created, starting with the
1186 * innermost one. Note that we don't check for duplicate formals here:
1187 * This will be done by the memoizer of the lambda expression. */
1188 const SCM formals
= SCM_CDR (variable
);
1189 const SCM tail
= scm_cons (formals
, body
);
1191 /* Add source properties to each new lambda expression: */
1192 const SCM lambda
= scm_cons_source (variable
, scm_sym_lambda
, tail
);
1194 body
= scm_list_1 (lambda
);
1195 variable
= SCM_CAR (variable
);
1197 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
1198 ASSERT_SYNTAX (scm_ilength (body
) == 1, s_expression
, expr
);
1200 SCM_SETCAR (cdr_expr
, variable
);
1201 SCM_SETCDR (cdr_expr
, body
);
1205 /* According to section 5.2.1 of R5RS we first have to make sure that the
1206 * variable is bound, and then perform the (set! variable expression)
1207 * operation. This means, that within the expression we may already assign
1208 * values to variable: (define foo (begin (set! foo 1) (+ foo 1))) */
1210 scm_m_define (SCM expr
, SCM env
)
1212 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), s_bad_define
, expr
);
1215 const SCM canonical_definition
= canonicalize_define (expr
);
1216 const SCM cdr_canonical_definition
= SCM_CDR (canonical_definition
);
1217 const SCM variable
= SCM_CAR (cdr_canonical_definition
);
1219 = scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_T
);
1220 const SCM value
= scm_eval_car (SCM_CDR (cdr_canonical_definition
), env
);
1222 if (SCM_REC_PROCNAMES_P
)
1225 while (SCM_MACROP (tmp
))
1226 tmp
= SCM_MACRO_CODE (tmp
);
1227 if (SCM_CLOSUREP (tmp
)
1228 /* Only the first definition determines the name. */
1229 && scm_is_false (scm_procedure_property (tmp
, scm_sym_name
)))
1230 scm_set_procedure_property_x (tmp
, scm_sym_name
, variable
);
1233 SCM_VARIABLE_SET (location
, value
);
1235 return SCM_UNSPECIFIED
;
1240 /* This is a helper function for forms (<keyword> <expression>) that are
1241 * transformed into (#@<keyword> '() <memoized_expression>) in order to allow
1242 * for easy creation of a thunk (i. e. a closure without arguments) using the
1243 * ('() <memoized_expression>) tail of the memoized form. */
1245 memoize_as_thunk_prototype (const SCM expr
, const SCM env SCM_UNUSED
)
1247 const SCM cdr_expr
= SCM_CDR (expr
);
1248 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1249 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1251 SCM_SETCDR (expr
, scm_cons (SCM_EOL
, cdr_expr
));
1257 SCM_SYNTAX (s_delay
, "delay", scm_i_makbimacro
, scm_m_delay
);
1258 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
1260 /* Promises are implemented as closures with an empty parameter list. Thus,
1261 * (delay <expression>) is transformed into (#@delay '() <expression>), where
1262 * the empty list represents the empty parameter list. This representation
1263 * allows for easy creation of the closure during evaluation. */
1265 scm_m_delay (SCM expr
, SCM env
)
1267 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1268 SCM_SETCAR (new_expr
, SCM_IM_DELAY
);
1273 unmemoize_delay (const SCM expr
, const SCM env
)
1275 const SCM thunk_expr
= SCM_CADDR (expr
);
1276 return scm_list_2 (scm_sym_delay
, unmemoize_expression (thunk_expr
, env
));
1280 SCM_SYNTAX(s_do
, "do", scm_i_makbimacro
, scm_m_do
);
1281 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
1283 /* DO gets the most radically altered syntax. The order of the vars is
1284 * reversed here. During the evaluation this allows for simple consing of the
1285 * results of the inits and steps:
1287 (do ((<var1> <init1> <step1>)
1295 (#@do (<init1> <init2> ... <initn>)
1296 (varn ... var2 var1)
1299 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
1302 scm_m_do (SCM expr
, SCM env SCM_UNUSED
)
1304 SCM variables
= SCM_EOL
;
1305 SCM init_forms
= SCM_EOL
;
1306 SCM step_forms
= SCM_EOL
;
1313 const SCM cdr_expr
= SCM_CDR (expr
);
1314 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1315 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1317 /* Collect variables, init and step forms. */
1318 binding_idx
= SCM_CAR (cdr_expr
);
1319 ASSERT_SYNTAX_2 (scm_ilength (binding_idx
) >= 0,
1320 s_bad_bindings
, binding_idx
, expr
);
1321 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1323 const SCM binding
= SCM_CAR (binding_idx
);
1324 const long length
= scm_ilength (binding
);
1325 ASSERT_SYNTAX_2 (length
== 2 || length
== 3,
1326 s_bad_binding
, binding
, expr
);
1329 const SCM name
= SCM_CAR (binding
);
1330 const SCM init
= SCM_CADR (binding
);
1331 const SCM step
= (length
== 2) ? name
: SCM_CADDR (binding
);
1332 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
1333 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, variables
)),
1334 s_duplicate_binding
, name
, expr
);
1336 variables
= scm_cons (name
, variables
);
1337 init_forms
= scm_cons (init
, init_forms
);
1338 step_forms
= scm_cons (step
, step_forms
);
1341 init_forms
= scm_reverse_x (init_forms
, SCM_UNDEFINED
);
1342 step_forms
= scm_reverse_x (step_forms
, SCM_UNDEFINED
);
1344 /* Memoize the test form and the exit sequence. */
1345 cddr_expr
= SCM_CDR (cdr_expr
);
1346 exit_clause
= SCM_CAR (cddr_expr
);
1347 ASSERT_SYNTAX_2 (scm_ilength (exit_clause
) >= 1,
1348 s_bad_exit_clause
, exit_clause
, expr
);
1350 commands
= SCM_CDR (cddr_expr
);
1351 tail
= scm_cons2 (exit_clause
, commands
, step_forms
);
1352 tail
= scm_cons2 (init_forms
, variables
, tail
);
1353 SCM_SETCAR (expr
, SCM_IM_DO
);
1354 SCM_SETCDR (expr
, tail
);
1359 unmemoize_do (const SCM expr
, const SCM env
)
1361 const SCM cdr_expr
= SCM_CDR (expr
);
1362 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1363 const SCM rnames
= SCM_CAR (cddr_expr
);
1364 const SCM extended_env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
1365 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
1366 const SCM exit_sequence
= SCM_CAR (cdddr_expr
);
1367 const SCM um_exit_sequence
= unmemoize_exprs (exit_sequence
, extended_env
);
1368 const SCM cddddr_expr
= SCM_CDR (cdddr_expr
);
1369 const SCM um_body
= unmemoize_exprs (SCM_CAR (cddddr_expr
), extended_env
);
1371 /* build transformed binding list */
1372 SCM um_names
= scm_reverse (rnames
);
1373 SCM um_inits
= unmemoize_exprs (SCM_CAR (cdr_expr
), env
);
1374 SCM um_steps
= unmemoize_exprs (SCM_CDR (cddddr_expr
), extended_env
);
1375 SCM um_bindings
= SCM_EOL
;
1376 while (!scm_is_null (um_names
))
1378 const SCM name
= SCM_CAR (um_names
);
1379 const SCM init
= SCM_CAR (um_inits
);
1380 SCM step
= SCM_CAR (um_steps
);
1381 step
= scm_is_eq (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
1383 um_bindings
= scm_cons (scm_cons2 (name
, init
, step
), um_bindings
);
1385 um_names
= SCM_CDR (um_names
);
1386 um_inits
= SCM_CDR (um_inits
);
1387 um_steps
= SCM_CDR (um_steps
);
1389 um_bindings
= scm_reverse_x (um_bindings
, SCM_UNDEFINED
);
1391 return scm_cons (scm_sym_do
,
1392 scm_cons2 (um_bindings
, um_exit_sequence
, um_body
));
1396 SCM_SYNTAX (s_if
, "if", scm_i_makbimacro
, scm_m_if
);
1397 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
1400 scm_m_if (SCM expr
, SCM env SCM_UNUSED
)
1402 const SCM cdr_expr
= SCM_CDR (expr
);
1403 const long length
= scm_ilength (cdr_expr
);
1404 ASSERT_SYNTAX (length
== 2 || length
== 3, s_expression
, expr
);
1405 SCM_SETCAR (expr
, SCM_IM_IF
);
1410 unmemoize_if (const SCM expr
, const SCM env
)
1412 const SCM cdr_expr
= SCM_CDR (expr
);
1413 const SCM um_condition
= unmemoize_expression (SCM_CAR (cdr_expr
), env
);
1414 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1415 const SCM um_then
= unmemoize_expression (SCM_CAR (cddr_expr
), env
);
1416 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
1418 if (scm_is_null (cdddr_expr
))
1420 return scm_list_3 (scm_sym_if
, um_condition
, um_then
);
1424 const SCM um_else
= unmemoize_expression (SCM_CAR (cdddr_expr
), env
);
1425 return scm_list_4 (scm_sym_if
, um_condition
, um_then
, um_else
);
1430 SCM_SYNTAX (s_lambda
, "lambda", scm_i_makbimacro
, scm_m_lambda
);
1431 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
1433 /* A helper function for memoize_lambda to support checking for duplicate
1434 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
1435 * LIST or to the cdr of the last cons. Therefore, LIST may have any of the
1436 * forms that a formal argument can have:
1437 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
1439 c_improper_memq (SCM obj
, SCM list
)
1441 for (; scm_is_pair (list
); list
= SCM_CDR (list
))
1443 if (scm_is_eq (SCM_CAR (list
), obj
))
1446 return scm_is_eq (list
, obj
);
1450 scm_m_lambda (SCM expr
, SCM env SCM_UNUSED
)
1459 const SCM cdr_expr
= SCM_CDR (expr
);
1460 const long length
= scm_ilength (cdr_expr
);
1461 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1462 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1464 /* Before iterating the list of formal arguments, make sure the formals
1465 * actually are given as either a symbol or a non-cyclic list. */
1466 formals
= SCM_CAR (cdr_expr
);
1467 if (scm_is_pair (formals
))
1469 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
1470 * detected, report a 'Bad formals' error. */
1474 ASSERT_SYNTAX_2 (scm_is_symbol (formals
) || scm_is_null (formals
),
1475 s_bad_formals
, formals
, expr
);
1478 /* Now iterate the list of formal arguments to check if all formals are
1479 * symbols, and that there are no duplicates. */
1480 formals_idx
= formals
;
1481 while (scm_is_pair (formals_idx
))
1483 const SCM formal
= SCM_CAR (formals_idx
);
1484 const SCM next_idx
= SCM_CDR (formals_idx
);
1485 ASSERT_SYNTAX_2 (scm_is_symbol (formal
), s_bad_formal
, formal
, expr
);
1486 ASSERT_SYNTAX_2 (!c_improper_memq (formal
, next_idx
),
1487 s_duplicate_formal
, formal
, expr
);
1488 formals_idx
= next_idx
;
1490 ASSERT_SYNTAX_2 (scm_is_null (formals_idx
) || scm_is_symbol (formals_idx
),
1491 s_bad_formal
, formals_idx
, expr
);
1493 /* Memoize the body. Keep a potential documentation string. */
1494 /* Dirk:FIXME:: We should probably extract the documentation string to
1495 * some external database. Otherwise it will slow down execution, since
1496 * the documentation string will have to be skipped with every execution
1497 * of the closure. */
1498 cddr_expr
= SCM_CDR (cdr_expr
);
1499 documentation
= (length
>= 3 && scm_is_string (SCM_CAR (cddr_expr
)));
1500 body
= documentation
? SCM_CDR (cddr_expr
) : cddr_expr
;
1501 new_body
= m_body (SCM_IM_LAMBDA
, body
);
1503 SCM_SETCAR (expr
, SCM_IM_LAMBDA
);
1505 SCM_SETCDR (cddr_expr
, new_body
);
1507 SCM_SETCDR (cdr_expr
, new_body
);
1512 unmemoize_lambda (const SCM expr
, const SCM env
)
1514 const SCM formals
= SCM_CADR (expr
);
1515 const SCM body
= SCM_CDDR (expr
);
1517 const SCM new_env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, env
);
1518 const SCM um_formals
= scm_i_finite_list_copy (formals
);
1519 const SCM um_body
= unmemoize_exprs (body
, new_env
);
1521 return scm_cons2 (scm_sym_lambda
, um_formals
, um_body
);
1525 /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
1527 check_bindings (const SCM bindings
, const SCM expr
)
1531 ASSERT_SYNTAX_2 (scm_ilength (bindings
) >= 0,
1532 s_bad_bindings
, bindings
, expr
);
1534 binding_idx
= bindings
;
1535 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1537 SCM name
; /* const */
1539 const SCM binding
= SCM_CAR (binding_idx
);
1540 ASSERT_SYNTAX_2 (scm_ilength (binding
) == 2,
1541 s_bad_binding
, binding
, expr
);
1543 name
= SCM_CAR (binding
);
1544 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
1549 /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
1550 * transformed to the lists (vn ... v2 v1) and (i1 i2 ... in). That is, the
1551 * variables are returned in a list with their order reversed, and the init
1552 * forms are returned in a list in the same order as they are given in the
1553 * bindings. If a duplicate variable name is detected, an error is
1556 transform_bindings (
1557 const SCM bindings
, const SCM expr
,
1558 SCM
*const rvarptr
, SCM
*const initptr
)
1560 SCM rvariables
= SCM_EOL
;
1561 SCM rinits
= SCM_EOL
;
1562 SCM binding_idx
= bindings
;
1563 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1565 const SCM binding
= SCM_CAR (binding_idx
);
1566 const SCM cdr_binding
= SCM_CDR (binding
);
1567 const SCM name
= SCM_CAR (binding
);
1568 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, rvariables
)),
1569 s_duplicate_binding
, name
, expr
);
1570 rvariables
= scm_cons (name
, rvariables
);
1571 rinits
= scm_cons (SCM_CAR (cdr_binding
), rinits
);
1573 *rvarptr
= rvariables
;
1574 *initptr
= scm_reverse_x (rinits
, SCM_UNDEFINED
);
1578 SCM_SYNTAX(s_let
, "let", scm_i_makbimacro
, scm_m_let
);
1579 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
1581 /* This function is a helper function for memoize_let. It transforms
1582 * (let name ((var init) ...) body ...) into
1583 * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
1584 * and memoizes the expression. It is assumed that the caller has checked
1585 * that name is a symbol and that there are bindings and a body. */
1587 memoize_named_let (const SCM expr
, const SCM env SCM_UNUSED
)
1593 const SCM cdr_expr
= SCM_CDR (expr
);
1594 const SCM name
= SCM_CAR (cdr_expr
);
1595 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1596 const SCM bindings
= SCM_CAR (cddr_expr
);
1597 check_bindings (bindings
, expr
);
1599 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1600 variables
= scm_reverse_x (rvariables
, SCM_UNDEFINED
);
1603 const SCM let_body
= SCM_CDR (cddr_expr
);
1604 const SCM lambda_body
= m_body (SCM_IM_LET
, let_body
);
1605 const SCM lambda_tail
= scm_cons (variables
, lambda_body
);
1606 const SCM lambda_form
= scm_cons_source (expr
, scm_sym_lambda
, lambda_tail
);
1608 const SCM rvar
= scm_list_1 (name
);
1609 const SCM init
= scm_list_1 (lambda_form
);
1610 const SCM body
= m_body (SCM_IM_LET
, scm_list_1 (name
));
1611 const SCM letrec_tail
= scm_cons (rvar
, scm_cons (init
, body
));
1612 const SCM letrec_form
= scm_cons_source (expr
, SCM_IM_LETREC
, letrec_tail
);
1613 return scm_cons_source (expr
, letrec_form
, inits
);
1617 /* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1618 * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
1620 scm_m_let (SCM expr
, SCM env
)
1624 const SCM cdr_expr
= SCM_CDR (expr
);
1625 const long length
= scm_ilength (cdr_expr
);
1626 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1627 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1629 bindings
= SCM_CAR (cdr_expr
);
1630 if (scm_is_symbol (bindings
))
1632 ASSERT_SYNTAX (length
>= 3, s_missing_expression
, expr
);
1633 return memoize_named_let (expr
, env
);
1636 check_bindings (bindings
, expr
);
1637 if (scm_is_null (bindings
) || scm_is_null (SCM_CDR (bindings
)))
1639 /* Special case: no bindings or single binding => let* is faster. */
1640 const SCM body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1641 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), bindings
, body
), env
);
1648 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1651 const SCM new_body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1652 const SCM new_tail
= scm_cons2 (rvariables
, inits
, new_body
);
1653 SCM_SETCAR (expr
, SCM_IM_LET
);
1654 SCM_SETCDR (expr
, new_tail
);
1661 build_binding_list (SCM rnames
, SCM rinits
)
1663 SCM bindings
= SCM_EOL
;
1664 while (!scm_is_null (rnames
))
1666 const SCM binding
= scm_list_2 (SCM_CAR (rnames
), SCM_CAR (rinits
));
1667 bindings
= scm_cons (binding
, bindings
);
1668 rnames
= SCM_CDR (rnames
);
1669 rinits
= SCM_CDR (rinits
);
1675 unmemoize_let (const SCM expr
, const SCM env
)
1677 const SCM cdr_expr
= SCM_CDR (expr
);
1678 const SCM um_rnames
= SCM_CAR (cdr_expr
);
1679 const SCM extended_env
= SCM_EXTEND_ENV (um_rnames
, SCM_EOL
, env
);
1680 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1681 const SCM um_inits
= unmemoize_exprs (SCM_CAR (cddr_expr
), env
);
1682 const SCM um_rinits
= scm_reverse_x (um_inits
, SCM_UNDEFINED
);
1683 const SCM um_bindings
= build_binding_list (um_rnames
, um_rinits
);
1684 const SCM um_body
= unmemoize_exprs (SCM_CDR (cddr_expr
), extended_env
);
1686 return scm_cons2 (scm_sym_let
, um_bindings
, um_body
);
1690 SCM_SYNTAX(s_letrec
, "letrec", scm_i_makbimacro
, scm_m_letrec
);
1691 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
1694 scm_m_letrec (SCM expr
, SCM env
)
1698 const SCM cdr_expr
= SCM_CDR (expr
);
1699 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1700 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1702 bindings
= SCM_CAR (cdr_expr
);
1703 if (scm_is_null (bindings
))
1705 /* no bindings, let* is executed faster */
1706 SCM body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1707 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), SCM_EOL
, body
), env
);
1715 check_bindings (bindings
, expr
);
1716 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1717 new_body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1718 return scm_cons2 (SCM_IM_LETREC
, rvariables
, scm_cons (inits
, new_body
));
1723 unmemoize_letrec (const SCM expr
, const SCM env
)
1725 const SCM cdr_expr
= SCM_CDR (expr
);
1726 const SCM um_rnames
= SCM_CAR (cdr_expr
);
1727 const SCM extended_env
= SCM_EXTEND_ENV (um_rnames
, SCM_EOL
, env
);
1728 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1729 const SCM um_inits
= unmemoize_exprs (SCM_CAR (cddr_expr
), extended_env
);
1730 const SCM um_rinits
= scm_reverse_x (um_inits
, SCM_UNDEFINED
);
1731 const SCM um_bindings
= build_binding_list (um_rnames
, um_rinits
);
1732 const SCM um_body
= unmemoize_exprs (SCM_CDR (cddr_expr
), extended_env
);
1734 return scm_cons2 (scm_sym_letrec
, um_bindings
, um_body
);
1739 SCM_SYNTAX (s_letstar
, "let*", scm_i_makbimacro
, scm_m_letstar
);
1740 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
1742 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1743 * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
1745 scm_m_letstar (SCM expr
, SCM env SCM_UNUSED
)
1750 const SCM cdr_expr
= SCM_CDR (expr
);
1751 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1752 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1754 binding_idx
= SCM_CAR (cdr_expr
);
1755 check_bindings (binding_idx
, expr
);
1757 /* Transform ((v1 i1) (v2 i2) ...) into (v1 i1 v2 i2 ...). The
1758 * transformation is done in place. At the beginning of one iteration of
1759 * the loop the variable binding_idx holds the form
1760 * P1:( (vn . P2:(in . ())) . P3:( (vn+1 in+1) ... ) ),
1761 * where P1, P2 and P3 indicate the pairs, that are relevant for the
1762 * transformation. P1 and P2 are modified in the loop, P3 remains
1763 * untouched. After the execution of the loop, P1 will hold
1764 * P1:( vn . P2:(in . P3:( (vn+1 in+1) ... )) )
1765 * and binding_idx will hold P3. */
1766 while (!scm_is_null (binding_idx
))
1768 const SCM cdr_binding_idx
= SCM_CDR (binding_idx
); /* remember P3 */
1769 const SCM binding
= SCM_CAR (binding_idx
);
1770 const SCM name
= SCM_CAR (binding
);
1771 const SCM cdr_binding
= SCM_CDR (binding
);
1773 SCM_SETCDR (cdr_binding
, cdr_binding_idx
); /* update P2 */
1774 SCM_SETCAR (binding_idx
, name
); /* update P1 */
1775 SCM_SETCDR (binding_idx
, cdr_binding
); /* update P1 */
1777 binding_idx
= cdr_binding_idx
; /* continue with P3 */
1780 new_body
= m_body (SCM_IM_LETSTAR
, SCM_CDR (cdr_expr
));
1781 SCM_SETCAR (expr
, SCM_IM_LETSTAR
);
1782 /* the bindings have been changed in place */
1783 SCM_SETCDR (cdr_expr
, new_body
);
1788 unmemoize_letstar (const SCM expr
, const SCM env
)
1790 const SCM cdr_expr
= SCM_CDR (expr
);
1791 const SCM body
= SCM_CDR (cdr_expr
);
1792 SCM bindings
= SCM_CAR (cdr_expr
);
1793 SCM um_bindings
= SCM_EOL
;
1794 SCM extended_env
= env
;
1797 while (!scm_is_null (bindings
))
1799 const SCM variable
= SCM_CAR (bindings
);
1800 const SCM init
= SCM_CADR (bindings
);
1801 const SCM um_init
= unmemoize_expression (init
, extended_env
);
1802 um_bindings
= scm_cons (scm_list_2 (variable
, um_init
), um_bindings
);
1803 extended_env
= SCM_EXTEND_ENV (variable
, SCM_BOOL_F
, extended_env
);
1804 bindings
= SCM_CDDR (bindings
);
1806 um_bindings
= scm_reverse_x (um_bindings
, SCM_UNDEFINED
);
1808 um_body
= unmemoize_exprs (body
, extended_env
);
1810 return scm_cons2 (scm_sym_letstar
, um_bindings
, um_body
);
1814 SCM_SYNTAX (s_or
, "or", scm_i_makbimacro
, scm_m_or
);
1815 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
1818 scm_m_or (SCM expr
, SCM env SCM_UNUSED
)
1820 const SCM cdr_expr
= SCM_CDR (expr
);
1821 const long length
= scm_ilength (cdr_expr
);
1823 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1827 /* Special case: (or) is replaced by #f. */
1832 SCM_SETCAR (expr
, SCM_IM_OR
);
1838 unmemoize_or (const SCM expr
, const SCM env
)
1840 return scm_cons (scm_sym_or
, unmemoize_exprs (SCM_CDR (expr
), env
));
1844 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
1845 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
1846 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
1847 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
1849 /* Internal function to handle a quasiquotation: 'form' is the parameter in
1850 * the call (quasiquotation form), 'env' is the environment where unquoted
1851 * expressions will be evaluated, and 'depth' is the current quasiquotation
1852 * nesting level and is known to be greater than zero. */
1854 iqq (SCM form
, SCM env
, unsigned long int depth
)
1856 if (scm_is_pair (form
))
1858 const SCM tmp
= SCM_CAR (form
);
1859 if (scm_is_eq (tmp
, scm_sym_quasiquote
))
1861 const SCM args
= SCM_CDR (form
);
1862 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1863 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
1865 else if (scm_is_eq (tmp
, scm_sym_unquote
))
1867 const SCM args
= SCM_CDR (form
);
1868 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1870 return scm_eval_car (args
, env
);
1872 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
1874 else if (scm_is_pair (tmp
)
1875 && scm_is_eq (SCM_CAR (tmp
), scm_sym_uq_splicing
))
1877 const SCM args
= SCM_CDR (tmp
);
1878 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1881 const SCM list
= scm_eval_car (args
, env
);
1882 const SCM rest
= SCM_CDR (form
);
1883 ASSERT_SYNTAX_2 (scm_ilength (list
) >= 0,
1884 s_splicing
, list
, form
);
1885 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
1888 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
1889 iqq (SCM_CDR (form
), env
, depth
));
1892 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
1893 iqq (SCM_CDR (form
), env
, depth
));
1895 else if (scm_is_vector (form
))
1896 return scm_vector (iqq (scm_vector_to_list (form
), env
, depth
));
1902 scm_m_quasiquote (SCM expr
, SCM env
)
1904 const SCM cdr_expr
= SCM_CDR (expr
);
1905 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1906 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1907 return iqq (SCM_CAR (cdr_expr
), env
, 1);
1911 SCM_SYNTAX (s_quote
, "quote", scm_i_makbimacro
, scm_m_quote
);
1912 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
1915 scm_m_quote (SCM expr
, SCM env SCM_UNUSED
)
1919 const SCM cdr_expr
= SCM_CDR (expr
);
1920 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1921 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1922 quotee
= SCM_CAR (cdr_expr
);
1923 if (is_self_quoting_p (quotee
))
1926 SCM_SETCAR (expr
, SCM_IM_QUOTE
);
1927 SCM_SETCDR (expr
, quotee
);
1932 unmemoize_quote (const SCM expr
, const SCM env SCM_UNUSED
)
1934 return scm_list_2 (scm_sym_quote
, SCM_CDR (expr
));
1938 /* Will go into the RnRS module when Guile is factorized.
1939 SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
1940 static const char s_set_x
[] = "set!";
1941 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, s_set_x
);
1944 scm_m_set_x (SCM expr
, SCM env SCM_UNUSED
)
1949 const SCM cdr_expr
= SCM_CDR (expr
);
1950 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1951 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1952 variable
= SCM_CAR (cdr_expr
);
1954 /* Memoize the variable form. */
1955 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
1956 new_variable
= lookup_symbol (variable
, env
);
1957 /* Leave the memoization of unbound symbols to lazy memoization: */
1958 if (SCM_UNBNDP (new_variable
))
1959 new_variable
= variable
;
1961 SCM_SETCAR (expr
, SCM_IM_SET_X
);
1962 SCM_SETCAR (cdr_expr
, new_variable
);
1967 unmemoize_set_x (const SCM expr
, const SCM env
)
1969 return scm_cons (scm_sym_set_x
, unmemoize_exprs (SCM_CDR (expr
), env
));
1973 /* Start of the memoizers for non-R5RS builtin macros. */
1976 SCM_SYNTAX (s_atapply
, "@apply", scm_i_makbimacro
, scm_m_apply
);
1977 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1978 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1981 scm_m_apply (SCM expr
, SCM env SCM_UNUSED
)
1983 const SCM cdr_expr
= SCM_CDR (expr
);
1984 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1985 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_missing_expression
, expr
);
1987 SCM_SETCAR (expr
, SCM_IM_APPLY
);
1992 unmemoize_apply (const SCM expr
, const SCM env
)
1994 return scm_list_2 (scm_sym_atapply
, unmemoize_exprs (SCM_CDR (expr
), env
));
1998 SCM_SYNTAX (s_atbind
, "@bind", scm_i_makbimacro
, scm_m_atbind
);
2000 /* FIXME: The following explanation should go into the documentation: */
2001 /* (@bind ((var init) ...) body ...) will assign the values of the `init's to
2002 * the global variables named by `var's (symbols, not evaluated), creating
2003 * them if they don't exist, executes body, and then restores the previous
2004 * values of the `var's. Additionally, whenever control leaves body, the
2005 * values of the `var's are saved and restored when control returns. It is an
2006 * error when a symbol appears more than once among the `var's. All `init's
2007 * are evaluated before any `var' is set.
2009 * Think of this as `let' for dynamic scope.
2012 /* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into
2013 * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...).
2015 * FIXME - also implement `@bind*'.
2018 scm_m_atbind (SCM expr
, SCM env
)
2025 const SCM top_level
= scm_env_top_level (env
);
2027 const SCM cdr_expr
= SCM_CDR (expr
);
2028 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2029 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
2030 bindings
= SCM_CAR (cdr_expr
);
2031 check_bindings (bindings
, expr
);
2032 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
2034 for (variable_idx
= rvariables
;
2035 !scm_is_null (variable_idx
);
2036 variable_idx
= SCM_CDR (variable_idx
))
2038 /* The first call to scm_sym2var will look beyond the current module,
2039 * while the second call wont. */
2040 const SCM variable
= SCM_CAR (variable_idx
);
2041 SCM new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_F
);
2042 if (scm_is_false (new_variable
))
2043 new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_T
);
2044 SCM_SETCAR (variable_idx
, new_variable
);
2047 SCM_SETCAR (expr
, SCM_IM_BIND
);
2048 SCM_SETCAR (cdr_expr
, scm_cons (rvariables
, inits
));
2053 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_i_makbimacro
, scm_m_cont
);
2054 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, s_atcall_cc
);
2057 scm_m_cont (SCM expr
, SCM env SCM_UNUSED
)
2059 const SCM cdr_expr
= SCM_CDR (expr
);
2060 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2061 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2063 SCM_SETCAR (expr
, SCM_IM_CONT
);
2068 unmemoize_atcall_cc (const SCM expr
, const SCM env
)
2070 return scm_list_2 (scm_sym_atcall_cc
, unmemoize_exprs (SCM_CDR (expr
), env
));
2074 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_i_makbimacro
, scm_m_at_call_with_values
);
2075 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
2078 scm_m_at_call_with_values (SCM expr
, SCM env SCM_UNUSED
)
2080 const SCM cdr_expr
= SCM_CDR (expr
);
2081 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2082 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2084 SCM_SETCAR (expr
, SCM_IM_CALL_WITH_VALUES
);
2089 unmemoize_at_call_with_values (const SCM expr
, const SCM env
)
2091 return scm_list_2 (scm_sym_at_call_with_values
,
2092 unmemoize_exprs (SCM_CDR (expr
), env
));
2096 SCM_SYNTAX (s_future
, "future", scm_i_makbimacro
, scm_m_future
);
2097 SCM_GLOBAL_SYMBOL (scm_sym_future
, s_future
);
2099 /* Like promises, futures are implemented as closures with an empty
2100 * parameter list. Thus, (future <expression>) is transformed into
2101 * (#@future '() <expression>), where the empty list represents the
2102 * empty parameter list. This representation allows for easy creation
2103 * of the closure during evaluation. */
2105 scm_m_future (SCM expr
, SCM env
)
2107 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
2108 SCM_SETCAR (new_expr
, SCM_IM_FUTURE
);
2113 unmemoize_future (const SCM expr
, const SCM env
)
2115 const SCM thunk_expr
= SCM_CADDR (expr
);
2116 return scm_list_2 (scm_sym_future
, unmemoize_expression (thunk_expr
, env
));
2120 SCM_SYNTAX (s_gset_x
, "set!", scm_i_makbimacro
, scm_m_generalized_set_x
);
2121 SCM_SYMBOL (scm_sym_setter
, "setter");
2124 scm_m_generalized_set_x (SCM expr
, SCM env
)
2126 SCM target
, exp_target
;
2128 const SCM cdr_expr
= SCM_CDR (expr
);
2129 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2130 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2132 target
= SCM_CAR (cdr_expr
);
2133 if (!scm_is_pair (target
))
2136 return scm_m_set_x (expr
, env
);
2140 /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */
2141 /* Macroexpanding the target might return things of the form
2142 (begin <atom>). In that case, <atom> must be a symbol or a
2143 variable and we memoize to (set! <atom> ...).
2145 exp_target
= macroexp (target
, env
);
2146 if (scm_is_eq (SCM_CAR (exp_target
), SCM_IM_BEGIN
)
2147 && !scm_is_null (SCM_CDR (exp_target
))
2148 && scm_is_null (SCM_CDDR (exp_target
)))
2150 exp_target
= SCM_CADR (exp_target
);
2151 ASSERT_SYNTAX_2 (scm_is_symbol (exp_target
)
2152 || SCM_VARIABLEP (exp_target
),
2153 s_bad_variable
, exp_target
, expr
);
2154 return scm_cons (SCM_IM_SET_X
, scm_cons (exp_target
,
2155 SCM_CDR (cdr_expr
)));
2159 const SCM setter_proc_tail
= scm_list_1 (SCM_CAR (target
));
2160 const SCM setter_proc
= scm_cons_source (expr
, scm_sym_setter
,
2163 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
2164 const SCM setter_args
= scm_append_x (scm_list_2 (SCM_CDR (target
),
2167 SCM_SETCAR (expr
, setter_proc
);
2168 SCM_SETCDR (expr
, setter_args
);
2175 /* @slot-ref is bound privately in the (oop goops) module from goops.c. As
2176 * soon as the module system allows us to more freely create bindings in
2177 * arbitrary modules during the startup phase, the code from goops.c should be
2180 SCM_SYMBOL (sym_atslot_ref
, "@slot-ref");
2183 scm_m_atslot_ref (SCM expr
, SCM env SCM_UNUSED
)
2187 const SCM cdr_expr
= SCM_CDR (expr
);
2188 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2189 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2190 slot_nr
= SCM_CADR (cdr_expr
);
2191 ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2193 SCM_SETCAR (expr
, SCM_IM_SLOT_REF
);
2194 SCM_SETCDR (cdr_expr
, slot_nr
);
2199 unmemoize_atslot_ref (const SCM expr
, const SCM env
)
2201 const SCM instance
= SCM_CADR (expr
);
2202 const SCM um_instance
= unmemoize_expression (instance
, env
);
2203 const SCM slot_nr
= SCM_CDDR (expr
);
2204 return scm_list_3 (sym_atslot_ref
, um_instance
, slot_nr
);
2208 /* @slot-set! is bound privately in the (oop goops) module from goops.c. As
2209 * soon as the module system allows us to more freely create bindings in
2210 * arbitrary modules during the startup phase, the code from goops.c should be
2213 SCM_SYMBOL (sym_atslot_set_x
, "@slot-set!");
2216 scm_m_atslot_set_x (SCM expr
, SCM env SCM_UNUSED
)
2220 const SCM cdr_expr
= SCM_CDR (expr
);
2221 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2222 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 3, s_expression
, expr
);
2223 slot_nr
= SCM_CADR (cdr_expr
);
2224 ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2226 SCM_SETCAR (expr
, SCM_IM_SLOT_SET_X
);
2231 unmemoize_atslot_set_x (const SCM expr
, const SCM env
)
2233 const SCM cdr_expr
= SCM_CDR (expr
);
2234 const SCM instance
= SCM_CAR (cdr_expr
);
2235 const SCM um_instance
= unmemoize_expression (instance
, env
);
2236 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
2237 const SCM slot_nr
= SCM_CAR (cddr_expr
);
2238 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
2239 const SCM value
= SCM_CAR (cdddr_expr
);
2240 const SCM um_value
= unmemoize_expression (value
, env
);
2241 return scm_list_4 (sym_atslot_set_x
, um_instance
, slot_nr
, um_value
);
2245 #if SCM_ENABLE_ELISP
2247 static const char s_defun
[] = "Symbol's function definition is void";
2249 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_i_makbimacro
, scm_m_nil_cond
);
2251 /* nil-cond expressions have the form
2252 * (nil-cond COND VAL COND VAL ... ELSEVAL) */
2254 scm_m_nil_cond (SCM expr
, SCM env SCM_UNUSED
)
2256 const long length
= scm_ilength (SCM_CDR (expr
));
2257 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
2258 ASSERT_SYNTAX (length
>= 1 && (length
% 2) == 1, s_expression
, expr
);
2260 SCM_SETCAR (expr
, SCM_IM_NIL_COND
);
2265 SCM_SYNTAX (s_atfop
, "@fop", scm_i_makbimacro
, scm_m_atfop
);
2267 /* The @fop-macro handles procedure and macro applications for elisp. The
2268 * input expression must have the form
2269 * (@fop <var> (transformer-macro <expr> ...))
2270 * where <var> must be a symbol. The expression is transformed into the
2271 * memoized form of either
2272 * (apply <un-aliased var> (transformer-macro <expr> ...))
2273 * if the value of var (across all aliasing) is not a macro, or
2274 * (<un-aliased var> <expr> ...)
2275 * if var is a macro. */
2277 scm_m_atfop (SCM expr
, SCM env SCM_UNUSED
)
2282 const SCM cdr_expr
= SCM_CDR (expr
);
2283 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2284 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 1, s_missing_expression
, expr
);
2286 symbol
= SCM_CAR (cdr_expr
);
2287 ASSERT_SYNTAX_2 (scm_is_symbol (symbol
), s_bad_variable
, symbol
, expr
);
2289 location
= scm_symbol_fref (symbol
);
2290 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2292 /* The elisp function `defalias' allows to define aliases for symbols. To
2293 * look up such definitions, the chain of symbol definitions has to be
2294 * followed up to the terminal symbol. */
2295 while (scm_is_symbol (SCM_VARIABLE_REF (location
)))
2297 const SCM alias
= SCM_VARIABLE_REF (location
);
2298 location
= scm_symbol_fref (alias
);
2299 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2302 /* Memoize the value location belonging to the terminal symbol. */
2303 SCM_SETCAR (cdr_expr
, location
);
2305 if (!SCM_MACROP (SCM_VARIABLE_REF (location
)))
2307 /* Since the location does not contain a macro, the form is a procedure
2308 * application. Replace `@fop' by `@apply' and transform the expression
2309 * including the `transformer-macro'. */
2310 SCM_SETCAR (expr
, SCM_IM_APPLY
);
2315 /* Since the location contains a macro, the arguments should not be
2316 * transformed, so the `transformer-macro' is cut out. The resulting
2317 * expression starts with the memoized variable, that is at the cdr of
2318 * the input expression. */
2319 SCM_SETCDR (cdr_expr
, SCM_CDADR (cdr_expr
));
2324 #endif /* SCM_ENABLE_ELISP */
2328 unmemoize_builtin_macro (const SCM expr
, const SCM env
)
2330 switch (ISYMNUM (SCM_CAR (expr
)))
2332 case (ISYMNUM (SCM_IM_AND
)):
2333 return unmemoize_and (expr
, env
);
2335 case (ISYMNUM (SCM_IM_BEGIN
)):
2336 return unmemoize_begin (expr
, env
);
2338 case (ISYMNUM (SCM_IM_CASE
)):
2339 return unmemoize_case (expr
, env
);
2341 case (ISYMNUM (SCM_IM_COND
)):
2342 return unmemoize_cond (expr
, env
);
2344 case (ISYMNUM (SCM_IM_DELAY
)):
2345 return unmemoize_delay (expr
, env
);
2347 case (ISYMNUM (SCM_IM_DO
)):
2348 return unmemoize_do (expr
, env
);
2350 case (ISYMNUM (SCM_IM_IF
)):
2351 return unmemoize_if (expr
, env
);
2353 case (ISYMNUM (SCM_IM_LAMBDA
)):
2354 return unmemoize_lambda (expr
, env
);
2356 case (ISYMNUM (SCM_IM_LET
)):
2357 return unmemoize_let (expr
, env
);
2359 case (ISYMNUM (SCM_IM_LETREC
)):
2360 return unmemoize_letrec (expr
, env
);
2362 case (ISYMNUM (SCM_IM_LETSTAR
)):
2363 return unmemoize_letstar (expr
, env
);
2365 case (ISYMNUM (SCM_IM_OR
)):
2366 return unmemoize_or (expr
, env
);
2368 case (ISYMNUM (SCM_IM_QUOTE
)):
2369 return unmemoize_quote (expr
, env
);
2371 case (ISYMNUM (SCM_IM_SET_X
)):
2372 return unmemoize_set_x (expr
, env
);
2374 case (ISYMNUM (SCM_IM_APPLY
)):
2375 return unmemoize_apply (expr
, env
);
2377 case (ISYMNUM (SCM_IM_BIND
)):
2378 return unmemoize_exprs (expr
, env
); /* FIXME */
2380 case (ISYMNUM (SCM_IM_CONT
)):
2381 return unmemoize_atcall_cc (expr
, env
);
2383 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2384 return unmemoize_at_call_with_values (expr
, env
);
2386 case (ISYMNUM (SCM_IM_FUTURE
)):
2387 return unmemoize_future (expr
, env
);
2389 case (ISYMNUM (SCM_IM_SLOT_REF
)):
2390 return unmemoize_atslot_ref (expr
, env
);
2392 case (ISYMNUM (SCM_IM_SLOT_SET_X
)):
2393 return unmemoize_atslot_set_x (expr
, env
);
2395 case (ISYMNUM (SCM_IM_NIL_COND
)):
2396 return unmemoize_exprs (expr
, env
); /* FIXME */
2399 return unmemoize_exprs (expr
, env
); /* FIXME */
2404 /* scm_i_unmemocopy_expr and scm_i_unmemocopy_body take a memoized expression
2405 * respectively a memoized body together with its environment and rewrite it
2406 * to its original form. Thus, these functions are the inversion of the
2407 * rewrite rules above. The procedure is not optimized for speed. It's used
2408 * in scm_i_unmemoize_expr, scm_procedure_source, macro_print and scm_iprin1.
2410 * Unmemoizing is not a reliable process. You cannot in general expect to get
2411 * the original source back.
2413 * However, GOOPS currently relies on this for method compilation. This ought
2417 scm_i_unmemocopy_expr (SCM expr
, SCM env
)
2419 const SCM source_properties
= scm_whash_lookup (scm_source_whash
, expr
);
2420 const SCM um_expr
= unmemoize_expression (expr
, env
);
2422 if (scm_is_true (source_properties
))
2423 scm_whash_insert (scm_source_whash
, um_expr
, source_properties
);
2429 scm_i_unmemocopy_body (SCM forms
, SCM env
)
2431 const SCM source_properties
= scm_whash_lookup (scm_source_whash
, forms
);
2432 const SCM um_forms
= unmemoize_exprs (forms
, env
);
2434 if (scm_is_true (source_properties
))
2435 scm_whash_insert (scm_source_whash
, um_forms
, source_properties
);
2441 #if (SCM_ENABLE_DEPRECATED == 1)
2443 /* Deprecated in guile 1.7.0 on 2003-11-09. */
2445 scm_m_expand_body (SCM exprs
, SCM env
)
2447 scm_c_issue_deprecation_warning
2448 ("`scm_m_expand_body' is deprecated.");
2449 m_expand_body (exprs
, env
);
2454 SCM_SYNTAX (s_undefine
, "undefine", scm_makacro
, scm_m_undefine
);
2457 scm_m_undefine (SCM expr
, SCM env
)
2462 const SCM cdr_expr
= SCM_CDR (expr
);
2463 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), "Bad undefine placement in", expr
);
2464 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2465 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2467 scm_c_issue_deprecation_warning
2468 ("`undefine' is deprecated.\n");
2470 variable
= SCM_CAR (cdr_expr
);
2471 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
2472 location
= scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_F
);
2473 ASSERT_SYNTAX_2 (scm_is_true (location
)
2474 && !SCM_UNBNDP (SCM_VARIABLE_REF (location
)),
2475 "variable already unbound ", variable
, expr
);
2476 SCM_VARIABLE_SET (location
, SCM_UNDEFINED
);
2477 return SCM_UNSPECIFIED
;
2481 scm_macroexp (SCM x
, SCM env
)
2483 scm_c_issue_deprecation_warning
2484 ("`scm_macroexp' is deprecated.");
2485 return macroexp (x
, env
);
2491 #if (SCM_ENABLE_DEPRECATED == 1)
2494 scm_unmemocar (SCM form
, SCM env
)
2496 scm_c_issue_deprecation_warning
2497 ("`scm_unmemocar' is deprecated.");
2499 if (!scm_is_pair (form
))
2503 SCM c
= SCM_CAR (form
);
2504 if (SCM_VARIABLEP (c
))
2506 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
2507 if (scm_is_false (sym
))
2508 sym
= sym_three_question_marks
;
2509 SCM_SETCAR (form
, sym
);
2511 else if (SCM_ILOCP (c
))
2513 unsigned long int ir
;
2515 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
2516 env
= SCM_CDR (env
);
2517 env
= SCM_CAAR (env
);
2518 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
2519 env
= SCM_CDR (env
);
2521 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
2529 /*****************************************************************************/
2530 /*****************************************************************************/
2531 /* The definitions for execution start here. */
2532 /*****************************************************************************/
2533 /*****************************************************************************/
2535 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
2536 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
2537 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
2538 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
2540 /* A function object to implement "apply" for non-closure functions. */
2542 /* An endless list consisting of #<undefined> objects: */
2543 static SCM undefineds
;
2547 scm_badargsp (SCM formals
, SCM args
)
2549 while (!scm_is_null (formals
))
2551 if (!scm_is_pair (formals
))
2553 if (scm_is_null (args
))
2555 formals
= SCM_CDR (formals
);
2556 args
= SCM_CDR (args
);
2558 return !scm_is_null (args
) ? 1 : 0;
2563 /* The evaluator contains a plethora of EVAL symbols. This is an attempt at
2566 * The following macros should be used in code which is read twice (where the
2567 * choice of evaluator is hard soldered):
2569 * CEVAL is the symbol used within one evaluator to call itself.
2570 * Originally, it is defined to ceval, but is redefined to deval during the
2573 * SCM_I_EVALIM is used when it is known that the expression is an
2574 * immediate. (This macro never calls an evaluator.)
2576 * EVAL evaluates an expression that is expected to have its symbols already
2577 * memoized. Expressions that are not of the form '(<form> <form> ...)' are
2578 * evaluated inline without calling an evaluator.
2580 * EVALCAR evaluates the car of an expression 'X:(Y:<form> <form> ...)',
2581 * potentially replacing a symbol at the position Y:<form> by its memoized
2582 * variable. If Y:<form> is not of the form '(<form> <form> ...)', the
2583 * evaluation is performed inline without calling an evaluator.
2585 * The following macros should be used in code which is read once
2586 * (where the choice of evaluator is dynamic):
2588 * SCM_I_XEVAL corresponds to EVAL, but uses ceval *or* deval depending on the
2591 * SCM_I_XEVALCAR corresponds to EVALCAR, but uses ceval *or* deval depending
2592 * on the debugging mode.
2594 * The main motivation for keeping this plethora is efficiency
2595 * together with maintainability (=> locality of code).
2598 static SCM
ceval (SCM x
, SCM env
);
2599 static SCM
deval (SCM x
, SCM env
);
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) \
2615 ? SCM_I_EVALIM2 (x) \
2616 : (SCM_VARIABLEP (x) \
2617 ? SCM_VARIABLE_REF (x) \
2618 : (scm_is_pair (x) \
2619 ? (scm_debug_mode_p \
2620 ? deval ((x), (env)) \
2621 : ceval ((x), (env))) \
2624 #define SCM_I_XEVALCAR(x, env) \
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)) \
2630 ? (scm_debug_mode_p \
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 #define EVAL(x, env) \
2639 ? SCM_I_EVALIM ((x), (env)) \
2640 : (SCM_VARIABLEP (x) \
2641 ? SCM_VARIABLE_REF (x) \
2642 : (scm_is_pair (x) \
2643 ? CEVAL ((x), (env)) \
2646 #define EVALCAR(x, env) \
2647 (SCM_IMP (SCM_CAR (x)) \
2648 ? SCM_I_EVALIM (SCM_CAR (x), (env)) \
2649 : (SCM_VARIABLEP (SCM_CAR (x)) \
2650 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2651 : (scm_is_pair (SCM_CAR (x)) \
2652 ? CEVAL (SCM_CAR (x), (env)) \
2653 : (!scm_is_symbol (SCM_CAR (x)) \
2655 : *scm_lookupcar ((x), (env), 1)))))
2657 scm_i_pthread_mutex_t source_mutex
= SCM_I_PTHREAD_RECURSIVE_MUTEX_INITIALIZER
;
2660 /* Lookup a given local variable in an environment. The local variable is
2661 * given as an iloc, that is a triple <frame, binding, last?>, where frame
2662 * indicates the relative number of the environment frame (counting upwards
2663 * from the innermost environment frame), binding indicates the number of the
2664 * binding within the frame, and last? (which is extracted from the iloc using
2665 * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
2666 * very end of the improper list of bindings. */
2668 scm_ilookup (SCM iloc
, SCM env
)
2670 unsigned int frame_nr
= SCM_IFRAME (iloc
);
2671 unsigned int binding_nr
= SCM_IDIST (iloc
);
2675 for (; 0 != frame_nr
; --frame_nr
)
2676 frames
= SCM_CDR (frames
);
2678 bindings
= SCM_CAR (frames
);
2679 for (; 0 != binding_nr
; --binding_nr
)
2680 bindings
= SCM_CDR (bindings
);
2682 if (SCM_ICDRP (iloc
))
2683 return SCM_CDRLOC (bindings
);
2684 return SCM_CARLOC (SCM_CDR (bindings
));
2688 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
2690 static void error_unbound_variable (SCM symbol
) SCM_NORETURN
;
2691 static void error_defined_variable (SCM symbol
) SCM_NORETURN
;
2693 /* Call this for variables that are unfound.
2696 error_unbound_variable (SCM symbol
)
2698 scm_error (scm_unbound_variable_key
, NULL
,
2699 "Unbound variable: ~S",
2700 scm_list_1 (symbol
), SCM_BOOL_F
);
2703 /* Call this for variables that are found but contain SCM_UNDEFINED.
2706 error_defined_variable (SCM symbol
)
2708 /* We use the 'unbound-variable' key here as well, since it
2709 basically is the same kind of error, with a slight variation in
2710 the displayed message.
2712 scm_error (scm_unbound_variable_key
, NULL
,
2713 "Variable used before given a value: ~S",
2714 scm_list_1 (symbol
), SCM_BOOL_F
);
2718 /* The Lookup Car Race
2721 Memoization of variables and special forms is done while executing
2722 the code for the first time. As long as there is only one thread
2723 everything is fine, but as soon as two threads execute the same
2724 code concurrently `for the first time' they can come into conflict.
2726 This memoization includes rewriting variable references into more
2727 efficient forms and expanding macros. Furthermore, macro expansion
2728 includes `compiling' special forms like `let', `cond', etc. into
2729 tree-code instructions.
2731 There shouldn't normally be a problem with memoizing local and
2732 global variable references (into ilocs and variables), because all
2733 threads will mutate the code in *exactly* the same way and (if I
2734 read the C code correctly) it is not possible to observe a half-way
2735 mutated cons cell. The lookup procedure can handle this
2736 transparently without any critical sections.
2738 It is different with macro expansion, because macro expansion
2739 happens outside of the lookup procedure and can't be
2740 undone. Therefore the lookup procedure can't cope with it. It has
2741 to indicate failure when it detects a lost race and hope that the
2742 caller can handle it. Luckily, it turns out that this is the case.
2744 An example to illustrate this: Suppose that the following form will
2745 be memoized concurrently by two threads
2749 Let's first examine the lookup of X in the body. The first thread
2750 decides that it has to find the symbol "x" in the environment and
2751 starts to scan it. Then the other thread takes over and actually
2752 overtakes the first. It looks up "x" and substitutes an
2753 appropriate iloc for it. Now the first thread continues and
2754 completes its lookup. It comes to exactly the same conclusions as
2755 the second one and could - without much ado - just overwrite the
2756 iloc with the same iloc.
2758 But let's see what will happen when the race occurs while looking
2759 up the symbol "let" at the start of the form. It could happen that
2760 the second thread interrupts the lookup of the first thread and not
2761 only substitutes a variable for it but goes right ahead and
2762 replaces it with the compiled form (#@let* (x 12) x). Now, when
2763 the first thread completes its lookup, it would replace the #@let*
2764 with a variable containing the "let" binding, effectively reverting
2765 the form to (let (x 12) x). This is wrong. It has to detect that
2766 it has lost the race and the evaluator has to reconsider the
2767 changed form completely.
2769 This race condition could be resolved with some kind of traffic
2770 light (like mutexes) around scm_lookupcar, but I think that it is
2771 best to avoid them in this case. They would serialize memoization
2772 completely and because lookup involves calling arbitrary Scheme
2773 code (via the lookup-thunk), threads could be blocked for an
2774 arbitrary amount of time or even deadlock. But with the current
2775 solution a lot of unnecessary work is potentially done. */
2777 /* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
2778 return NULL to indicate a failed lookup due to some race conditions
2779 between threads. This only happens when VLOC is the first cell of
2780 a special form that will eventually be memoized (like `let', etc.)
2781 In that case the whole lookup is bogus and the caller has to
2782 reconsider the complete special form.
2784 SCM_LOOKUPCAR is still there, of course. It just calls
2785 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
2786 should only be called when it is known that VLOC is not the first
2787 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
2788 for NULL. I think I've found the only places where this
2792 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
2795 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
2796 register SCM iloc
= SCM_ILOC00
;
2797 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
2799 if (!scm_is_pair (SCM_CAR (env
)))
2801 al
= SCM_CARLOC (env
);
2802 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
2804 if (!scm_is_pair (fl
))
2806 if (scm_is_eq (fl
, var
))
2808 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2810 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
2811 return SCM_CDRLOC (*al
);
2816 al
= SCM_CDRLOC (*al
);
2817 if (scm_is_eq (SCM_CAR (fl
), var
))
2819 if (SCM_UNBNDP (SCM_CAR (*al
)))
2820 error_defined_variable (var
);
2821 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2823 SCM_SETCAR (vloc
, iloc
);
2824 return SCM_CARLOC (*al
);
2826 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
2828 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
2831 SCM top_thunk
, real_var
;
2834 top_thunk
= SCM_CAR (env
); /* env now refers to a
2835 top level env thunk */
2836 env
= SCM_CDR (env
);
2839 top_thunk
= SCM_BOOL_F
;
2840 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
2841 if (scm_is_false (real_var
))
2844 if (!scm_is_null (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
2849 if (scm_is_null (env
))
2850 error_unbound_variable (var
);
2852 scm_misc_error (NULL
, "Damaged environment: ~S",
2857 /* A variable could not be found, but we shall
2858 not throw an error. */
2859 static SCM undef_object
= SCM_UNDEFINED
;
2860 return &undef_object
;
2864 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2866 /* Some other thread has changed the very cell we are working
2867 on. In effect, it must have done our job or messed it up
2870 var
= SCM_CAR (vloc
);
2871 if (SCM_VARIABLEP (var
))
2872 return SCM_VARIABLE_LOC (var
);
2873 if (SCM_ILOCP (var
))
2874 return scm_ilookup (var
, genv
);
2875 /* We can't cope with anything else than variables and ilocs. When
2876 a special form has been memoized (i.e. `let' into `#@let') we
2877 return NULL and expect the calling function to do the right
2878 thing. For the evaluator, this means going back and redoing
2879 the dispatch on the car of the form. */
2883 SCM_SETCAR (vloc
, real_var
);
2884 return SCM_VARIABLE_LOC (real_var
);
2889 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
2891 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
2898 /* During execution, look up a symbol in the top level of the given local
2899 * environment and return the corresponding variable object. If no binding
2900 * for the symbol can be found, an 'Unbound variable' error is signalled. */
2902 lazy_memoize_variable (const SCM symbol
, const SCM environment
)
2904 const SCM top_level
= scm_env_top_level (environment
);
2905 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
2907 if (scm_is_false (variable
))
2908 error_unbound_variable (symbol
);
2915 scm_eval_car (SCM pair
, SCM env
)
2917 return SCM_I_XEVALCAR (pair
, env
);
2922 scm_eval_args (SCM l
, SCM env
, SCM proc
)
2924 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
2925 while (scm_is_pair (l
))
2927 res
= EVALCAR (l
, env
);
2929 *lloc
= scm_list_1 (res
);
2930 lloc
= SCM_CDRLOC (*lloc
);
2933 if (!scm_is_null (l
))
2934 scm_wrong_num_args (proc
);
2940 scm_eval_body (SCM code
, SCM env
)
2945 next
= SCM_CDR (code
);
2946 while (!scm_is_null (next
))
2948 if (SCM_IMP (SCM_CAR (code
)))
2950 if (SCM_ISYMP (SCM_CAR (code
)))
2952 scm_i_scm_pthread_mutex_lock (&source_mutex
);
2953 /* check for race condition */
2954 if (SCM_ISYMP (SCM_CAR (code
)))
2955 m_expand_body (code
, env
);
2956 scm_i_pthread_mutex_unlock (&source_mutex
);
2961 SCM_I_XEVAL (SCM_CAR (code
), env
);
2963 next
= SCM_CDR (code
);
2965 return SCM_I_XEVALCAR (code
, env
);
2971 /* SECTION: This code is specific for the debugging support. One
2972 * branch is read when DEVAL isn't defined, the other when DEVAL is
2978 #define SCM_APPLY scm_apply
2979 #define PREP_APPLY(proc, args)
2981 #define RETURN(x) do { return x; } while (0)
2982 #ifdef STACK_CHECKING
2983 #ifndef NO_CEVAL_STACK_CHECKING
2984 #define EVAL_STACK_CHECKING
2991 #define CEVAL deval /* Substitute all uses of ceval */
2994 #define SCM_APPLY scm_dapply
2997 #define PREP_APPLY(p, l) \
2998 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
3001 #define ENTER_APPLY \
3003 SCM_SET_ARGSREADY (debug);\
3004 if (scm_check_apply_p && SCM_TRAPS_P)\
3005 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
3007 SCM tmp, tail = scm_from_bool(SCM_TRACED_FRAME_P (debug)); \
3008 SCM_SET_TRACED_FRAME (debug); \
3010 if (SCM_CHEAPTRAPS_P)\
3012 tmp = scm_make_debugobj (&debug);\
3013 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
3018 tmp = scm_make_continuation (&first);\
3020 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
3027 #define RETURN(e) do { proc = (e); goto exit; } while (0)
3029 #ifdef STACK_CHECKING
3030 #ifndef EVAL_STACK_CHECKING
3031 #define EVAL_STACK_CHECKING
3036 /* scm_last_debug_frame contains a pointer to the last debugging information
3037 * stack frame. It is accessed very often from the debugging evaluator, so it
3038 * should probably not be indirectly addressed. Better to save and restore it
3039 * from the current root at any stack swaps.
3042 /* scm_debug_eframe_size is the number of slots available for pseudo
3043 * stack frames at each real stack frame.
3046 long scm_debug_eframe_size
;
3048 int scm_debug_mode_p
;
3049 int scm_check_entry_p
;
3050 int scm_check_apply_p
;
3051 int scm_check_exit_p
;
3053 long scm_eval_stack
;
3055 scm_t_option scm_eval_opts
[] = {
3056 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
3059 scm_t_option scm_debug_opts
[] = {
3060 { SCM_OPTION_BOOLEAN
, "cheap", 1,
3061 "*Flyweight representation of the stack at traps." },
3062 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
3063 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
3064 { SCM_OPTION_BOOLEAN
, "procnames", 1,
3065 "Record procedure names at definition." },
3066 { SCM_OPTION_BOOLEAN
, "backwards", 0,
3067 "Display backtrace in anti-chronological order." },
3068 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
3069 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
3070 { SCM_OPTION_INTEGER
, "frames", 3,
3071 "Maximum number of tail-recursive frames in backtrace." },
3072 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
3073 "Maximal number of stored backtrace frames." },
3074 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
3075 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
3076 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
3077 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
3078 { SCM_OPTION_SCM
, "show-file-name", (unsigned long)SCM_BOOL_T
, "Show file names and line numbers in backtraces when not `#f'. A value of `base' displays only base names, while `#t' displays full names."},
3079 { SCM_OPTION_BOOLEAN
, "warn-deprecated", 0, "Warn when deprecated features are used." }
3082 scm_t_option scm_evaluator_trap_table
[] = {
3083 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
3084 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
3085 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
3086 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
3087 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
3088 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
3089 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
3092 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
3094 "Option interface for the evaluation options. Instead of using\n"
3095 "this procedure directly, use the procedures @code{eval-enable},\n"
3096 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
3097 #define FUNC_NAME s_scm_eval_options_interface
3100 SCM_CRITICAL_SECTION_START
;
3101 ans
= scm_options (setting
,
3105 /* njrev: There are several ways that scm_options can signal an
3106 error: scm_cons, scm_malloc_obj, scm_misc_error; so should use a
3107 critical section frame here. */
3108 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
3109 SCM_CRITICAL_SECTION_END
;
3115 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
3117 "Option interface for the evaluator trap options.")
3118 #define FUNC_NAME s_scm_evaluator_traps
3121 SCM_CRITICAL_SECTION_START
;
3122 ans
= scm_options (setting
,
3123 scm_evaluator_trap_table
,
3124 SCM_N_EVALUATOR_TRAPS
,
3126 /* njrev: same again. */
3127 SCM_RESET_DEBUG_MODE
;
3128 SCM_CRITICAL_SECTION_END
;
3135 deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
3137 SCM
*results
= lloc
;
3138 while (scm_is_pair (l
))
3140 const SCM res
= EVALCAR (l
, env
);
3142 *lloc
= scm_list_1 (res
);
3143 lloc
= SCM_CDRLOC (*lloc
);
3146 if (!scm_is_null (l
))
3147 scm_wrong_num_args (proc
);
3154 /* SECTION: This code is compiled twice.
3158 /* Update the toplevel environment frame ENV so that it refers to the
3159 * current module. */
3160 #define UPDATE_TOPLEVEL_ENV(env) \
3162 SCM p = scm_current_module_lookup_closure (); \
3163 if (p != SCM_CAR (env)) \
3164 env = scm_top_level_env (p); \
3168 #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
3169 ASSERT_SYNTAX (!scm_is_eq ((x), SCM_EOL), s_empty_combination, x)
3172 /* This is the evaluator. Like any real monster, it has three heads:
3174 * ceval is the non-debugging evaluator, deval is the debugging version. Both
3175 * are implemented using a common code base, using the following mechanism:
3176 * CEVAL is a macro, which is either defined to ceval or deval. Thus, there
3177 * is no function CEVAL, but the code for CEVAL actually compiles to either
3178 * ceval or deval. When CEVAL is defined to ceval, it is known that the macro
3179 * DEVAL is not defined. When CEVAL is defined to deval, then the macro DEVAL
3180 * is known to be defined. Thus, in CEVAL parts for the debugging evaluator
3181 * are enclosed within #ifdef DEVAL ... #endif.
3183 * All three (ceval, deval and their common implementation CEVAL) take two
3184 * input parameters, x and env: x is a single expression to be evalutated.
3185 * env is the environment in which bindings are searched.
3187 * x is known to be a pair. Since x is a single expression, it is necessarily
3188 * in a tail position. If x is just a call to another function like in the
3189 * expression (foo exp1 exp2 ...), the realization of that call therefore
3190 * _must_not_ increase stack usage (the evaluation of exp1, exp2 etc.,
3191 * however, may do so). This is realized by making extensive use of 'goto'
3192 * statements within the evaluator: The gotos replace recursive calls to
3193 * CEVAL, thus re-using the same stack frame that CEVAL was already using.
3194 * If, however, x represents some form that requires to evaluate a sequence of
3195 * expressions like (begin exp1 exp2 ...), then recursive calls to CEVAL are
3196 * performed for all but the last expression of that sequence. */
3199 CEVAL (SCM x
, SCM env
)
3203 scm_t_debug_frame debug
;
3204 scm_t_debug_info
*debug_info_end
;
3205 debug
.prev
= scm_i_last_debug_frame ();
3208 * The debug.vect contains twice as much scm_t_debug_info frames as the
3209 * user has specified with (debug-set! frames <n>).
3211 * Even frames are eval frames, odd frames are apply frames.
3213 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
3214 * sizeof (scm_t_debug_info
));
3215 debug
.info
= debug
.vect
;
3216 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
3217 scm_i_set_last_debug_frame (&debug
);
3219 #ifdef EVAL_STACK_CHECKING
3220 if (scm_stack_checking_enabled_p
&& SCM_STACK_OVERFLOW_P (&proc
))
3223 debug
.info
->e
.exp
= x
;
3224 debug
.info
->e
.env
= env
;
3226 scm_report_stack_overflow ();
3236 SCM_CLEAR_ARGSREADY (debug
);
3237 if (SCM_OVERFLOWP (debug
))
3240 * In theory, this should be the only place where it is necessary to
3241 * check for space in debug.vect since both eval frames and
3242 * available space are even.
3244 * For this to be the case, however, it is necessary that primitive
3245 * special forms which jump back to `loop', `begin' or some similar
3246 * label call PREP_APPLY.
3248 else if (++debug
.info
>= debug_info_end
)
3250 SCM_SET_OVERFLOW (debug
);
3255 debug
.info
->e
.exp
= x
;
3256 debug
.info
->e
.env
= env
;
3257 if (scm_check_entry_p
&& SCM_TRAPS_P
)
3259 if (SCM_ENTER_FRAME_P
3260 || (SCM_BREAKPOINTS_P
&& scm_c_source_property_breakpoint_p (x
)))
3263 SCM tail
= scm_from_bool (SCM_TAILRECP (debug
));
3264 SCM_SET_TAILREC (debug
);
3265 if (SCM_CHEAPTRAPS_P
)
3266 stackrep
= scm_make_debugobj (&debug
);
3270 SCM val
= scm_make_continuation (&first
);
3280 /* This gives the possibility for the debugger to
3281 modify the source expression before evaluation. */
3286 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
3287 scm_sym_enter_frame
,
3290 unmemoize_expression (x
, env
));
3297 if (SCM_ISYMP (SCM_CAR (x
)))
3299 switch (ISYMNUM (SCM_CAR (x
)))
3301 case (ISYMNUM (SCM_IM_AND
)):
3303 while (!scm_is_null (SCM_CDR (x
)))
3305 SCM test_result
= EVALCAR (x
, env
);
3306 if (scm_is_false (test_result
) || SCM_NILP (test_result
))
3307 RETURN (SCM_BOOL_F
);
3311 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3314 case (ISYMNUM (SCM_IM_BEGIN
)):
3316 if (scm_is_null (x
))
3317 RETURN (SCM_UNSPECIFIED
);
3319 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3322 /* If we are on toplevel with a lookup closure, we need to sync
3323 with the current module. */
3324 if (scm_is_pair (env
) && !scm_is_pair (SCM_CAR (env
)))
3326 UPDATE_TOPLEVEL_ENV (env
);
3327 while (!scm_is_null (SCM_CDR (x
)))
3330 UPDATE_TOPLEVEL_ENV (env
);
3336 goto nontoplevel_begin
;
3339 while (!scm_is_null (SCM_CDR (x
)))
3341 const SCM form
= SCM_CAR (x
);
3344 if (SCM_ISYMP (form
))
3346 scm_i_scm_pthread_mutex_lock (&source_mutex
);
3347 /* check for race condition */
3348 if (SCM_ISYMP (SCM_CAR (x
)))
3349 m_expand_body (x
, env
);
3350 scm_i_pthread_mutex_unlock (&source_mutex
);
3351 goto nontoplevel_begin
;
3354 SCM_VALIDATE_NON_EMPTY_COMBINATION (form
);
3357 (void) EVAL (form
, env
);
3363 /* scm_eval last form in list */
3364 const SCM last_form
= SCM_CAR (x
);
3366 if (scm_is_pair (last_form
))
3368 /* This is by far the most frequent case. */
3370 goto loop
; /* tail recurse */
3372 else if (SCM_IMP (last_form
))
3373 RETURN (SCM_I_EVALIM (last_form
, env
));
3374 else if (SCM_VARIABLEP (last_form
))
3375 RETURN (SCM_VARIABLE_REF (last_form
));
3376 else if (scm_is_symbol (last_form
))
3377 RETURN (*scm_lookupcar (x
, env
, 1));
3383 case (ISYMNUM (SCM_IM_CASE
)):
3386 const SCM key
= EVALCAR (x
, env
);
3388 while (!scm_is_null (x
))
3390 const SCM clause
= SCM_CAR (x
);
3391 SCM labels
= SCM_CAR (clause
);
3392 if (scm_is_eq (labels
, SCM_IM_ELSE
))
3394 x
= SCM_CDR (clause
);
3395 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3398 while (!scm_is_null (labels
))
3400 const SCM label
= SCM_CAR (labels
);
3401 if (scm_is_eq (label
, key
)
3402 || scm_is_true (scm_eqv_p (label
, key
)))
3404 x
= SCM_CDR (clause
);
3405 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3408 labels
= SCM_CDR (labels
);
3413 RETURN (SCM_UNSPECIFIED
);
3416 case (ISYMNUM (SCM_IM_COND
)):
3418 while (!scm_is_null (x
))
3420 const SCM clause
= SCM_CAR (x
);
3421 if (scm_is_eq (SCM_CAR (clause
), SCM_IM_ELSE
))
3423 x
= SCM_CDR (clause
);
3424 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3429 arg1
= EVALCAR (clause
, env
);
3430 if (scm_is_true (arg1
) && !SCM_NILP (arg1
))
3432 x
= SCM_CDR (clause
);
3433 if (scm_is_null (x
))
3435 else if (!scm_is_eq (SCM_CAR (x
), SCM_IM_ARROW
))
3437 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3443 proc
= EVALCAR (proc
, env
);
3444 PREP_APPLY (proc
, scm_list_1 (arg1
));
3452 RETURN (SCM_UNSPECIFIED
);
3455 case (ISYMNUM (SCM_IM_DO
)):
3458 /* Compute the initialization values and the initial environment. */
3459 SCM init_forms
= SCM_CAR (x
);
3460 SCM init_values
= SCM_EOL
;
3461 while (!scm_is_null (init_forms
))
3463 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3464 init_forms
= SCM_CDR (init_forms
);
3467 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
3471 SCM test_form
= SCM_CAR (x
);
3472 SCM body_forms
= SCM_CADR (x
);
3473 SCM step_forms
= SCM_CDDR (x
);
3475 SCM test_result
= EVALCAR (test_form
, env
);
3477 while (scm_is_false (test_result
) || SCM_NILP (test_result
))
3480 /* Evaluate body forms. */
3482 for (temp_forms
= body_forms
;
3483 !scm_is_null (temp_forms
);
3484 temp_forms
= SCM_CDR (temp_forms
))
3486 SCM form
= SCM_CAR (temp_forms
);
3487 /* Dirk:FIXME: We only need to eval forms that may have
3488 * a side effect here. This is only true for forms that
3489 * start with a pair. All others are just constants.
3490 * Since with the current memoizer 'form' may hold a
3491 * constant, we call EVAL here to handle the constant
3492 * cases. In the long run it would make sense to have
3493 * the macro transformer of 'do' eliminate all forms
3494 * that have no sideeffect. Then instead of EVAL we
3495 * could call CEVAL directly here. */
3496 (void) EVAL (form
, env
);
3501 /* Evaluate the step expressions. */
3503 SCM step_values
= SCM_EOL
;
3504 for (temp_forms
= step_forms
;
3505 !scm_is_null (temp_forms
);
3506 temp_forms
= SCM_CDR (temp_forms
))
3508 const SCM value
= EVALCAR (temp_forms
, env
);
3509 step_values
= scm_cons (value
, step_values
);
3511 env
= SCM_EXTEND_ENV (SCM_CAAR (env
),
3516 test_result
= EVALCAR (test_form
, env
);
3520 if (scm_is_null (x
))
3521 RETURN (SCM_UNSPECIFIED
);
3522 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3523 goto nontoplevel_begin
;
3526 case (ISYMNUM (SCM_IM_IF
)):
3529 SCM test_result
= EVALCAR (x
, env
);
3530 x
= SCM_CDR (x
); /* then expression */
3531 if (scm_is_false (test_result
) || SCM_NILP (test_result
))
3533 x
= SCM_CDR (x
); /* else expression */
3534 if (scm_is_null (x
))
3535 RETURN (SCM_UNSPECIFIED
);
3538 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3542 case (ISYMNUM (SCM_IM_LET
)):
3545 SCM init_forms
= SCM_CADR (x
);
3546 SCM init_values
= SCM_EOL
;
3549 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3550 init_forms
= SCM_CDR (init_forms
);
3552 while (!scm_is_null (init_forms
));
3553 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
3556 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3557 goto nontoplevel_begin
;
3560 case (ISYMNUM (SCM_IM_LETREC
)):
3562 env
= SCM_EXTEND_ENV (SCM_CAR (x
), undefineds
, env
);
3565 SCM init_forms
= SCM_CAR (x
);
3566 SCM init_values
= SCM_EOL
;
3569 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3570 init_forms
= SCM_CDR (init_forms
);
3572 while (!scm_is_null (init_forms
));
3574 /* In order to make case 1.1 of the R5RS pitfall testsuite
3575 succeed, we would need to copy init_values here like
3578 init_values = scm_list_copy (init_values);
3580 SCM_SETCDR (SCM_CAR (env
), init_values
);
3583 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3584 goto nontoplevel_begin
;
3587 case (ISYMNUM (SCM_IM_LETSTAR
)):
3590 SCM bindings
= SCM_CAR (x
);
3591 if (!scm_is_null (bindings
))
3595 SCM name
= SCM_CAR (bindings
);
3596 SCM init
= SCM_CDR (bindings
);
3597 env
= SCM_EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
3598 bindings
= SCM_CDR (init
);
3600 while (!scm_is_null (bindings
));
3604 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3605 goto nontoplevel_begin
;
3608 case (ISYMNUM (SCM_IM_OR
)):
3610 while (!scm_is_null (SCM_CDR (x
)))
3612 SCM val
= EVALCAR (x
, env
);
3613 if (scm_is_true (val
) && !SCM_NILP (val
))
3618 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3622 case (ISYMNUM (SCM_IM_LAMBDA
)):
3623 RETURN (scm_closure (SCM_CDR (x
), env
));
3626 case (ISYMNUM (SCM_IM_QUOTE
)):
3627 RETURN (SCM_CDR (x
));
3630 case (ISYMNUM (SCM_IM_SET_X
)):
3634 SCM variable
= SCM_CAR (x
);
3635 if (SCM_ILOCP (variable
))
3636 location
= scm_ilookup (variable
, env
);
3637 else if (SCM_VARIABLEP (variable
))
3638 location
= SCM_VARIABLE_LOC (variable
);
3641 /* (scm_is_symbol (variable)) is known to be true */
3642 variable
= lazy_memoize_variable (variable
, env
);
3643 SCM_SETCAR (x
, variable
);
3644 location
= SCM_VARIABLE_LOC (variable
);
3647 *location
= EVALCAR (x
, env
);
3649 RETURN (SCM_UNSPECIFIED
);
3652 case (ISYMNUM (SCM_IM_APPLY
)):
3653 /* Evaluate the procedure to be applied. */
3655 proc
= EVALCAR (x
, env
);
3656 PREP_APPLY (proc
, SCM_EOL
);
3658 /* Evaluate the argument holding the list of arguments */
3660 arg1
= EVALCAR (x
, env
);
3663 /* Go here to tail-apply a procedure. PROC is the procedure and
3664 * ARG1 is the list of arguments. PREP_APPLY must have been called
3665 * before jumping to apply_proc. */
3666 if (SCM_CLOSUREP (proc
))
3668 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3670 debug
.info
->a
.args
= arg1
;
3672 if (scm_badargsp (formals
, arg1
))
3673 scm_wrong_num_args (proc
);
3675 /* Copy argument list */
3676 if (SCM_NULL_OR_NIL_P (arg1
))
3677 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
3680 SCM args
= scm_list_1 (SCM_CAR (arg1
));
3682 arg1
= SCM_CDR (arg1
);
3683 while (!SCM_NULL_OR_NIL_P (arg1
))
3685 SCM new_tail
= scm_list_1 (SCM_CAR (arg1
));
3686 SCM_SETCDR (tail
, new_tail
);
3688 arg1
= SCM_CDR (arg1
);
3690 env
= SCM_EXTEND_ENV (formals
, args
, SCM_ENV (proc
));
3693 x
= SCM_CLOSURE_BODY (proc
);
3694 goto nontoplevel_begin
;
3699 RETURN (SCM_APPLY (proc
, arg1
, SCM_EOL
));
3703 case (ISYMNUM (SCM_IM_CONT
)):
3706 SCM val
= scm_make_continuation (&first
);
3714 proc
= EVALCAR (proc
, env
);
3715 PREP_APPLY (proc
, scm_list_1 (arg1
));
3722 case (ISYMNUM (SCM_IM_DELAY
)):
3723 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
3726 case (ISYMNUM (SCM_IM_FUTURE
)):
3727 RETURN (scm_i_make_future (scm_closure (SCM_CDR (x
), env
)));
3730 /* PLACEHOLDER for case (ISYMNUM (SCM_IM_DISPATCH)): The following
3731 code (type_dispatch) is intended to be the tail of the case
3732 clause for the internal macro SCM_IM_DISPATCH. Please don't
3733 remove it from this location without discussing it with Mikael
3734 <djurfeldt@nada.kth.se> */
3736 /* The type dispatch code is duplicated below
3737 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
3738 * cuts down execution time for type dispatch to 50%. */
3739 type_dispatch
: /* inputs: x, arg1 */
3740 /* Type dispatch means to determine from the types of the function
3741 * arguments (i. e. the 'signature' of the call), which method from
3742 * a generic function is to be called. This process of selecting
3743 * the right method takes some time. To speed it up, guile uses
3744 * caching: Together with the macro call to dispatch the signatures
3745 * of some previous calls to that generic function from the same
3746 * place are stored (in the code!) in a cache that we call the
3747 * 'method cache'. This is done since it is likely, that
3748 * consecutive calls to dispatch from that position in the code will
3749 * have the same signature. Thus, the type dispatch works as
3750 * follows: First, determine a hash value from the signature of the
3751 * actual arguments. Second, use this hash value as an index to
3752 * find that same signature in the method cache stored at this
3753 * position in the code. If found, you have also found the
3754 * corresponding method that belongs to that signature. If the
3755 * signature is not found in the method cache, you have to perform a
3756 * full search over all signatures stored with the generic
3759 unsigned long int specializers
;
3760 unsigned long int hash_value
;
3761 unsigned long int cache_end_pos
;
3762 unsigned long int mask
;
3766 SCM z
= SCM_CDDR (x
);
3767 SCM tmp
= SCM_CADR (z
);
3768 specializers
= scm_to_ulong (SCM_CAR (z
));
3770 /* Compute a hash value for searching the method cache. There
3771 * are two variants for computing the hash value, a (rather)
3772 * complicated one, and a simple one. For the complicated one
3773 * explained below, tmp holds a number that is used in the
3775 if (scm_is_simple_vector (tmp
))
3777 /* This method of determining the hash value is much
3778 * simpler: Set the hash value to zero and just perform a
3779 * linear search through the method cache. */
3781 mask
= (unsigned long int) ((long) -1);
3783 cache_end_pos
= SCM_SIMPLE_VECTOR_LENGTH (method_cache
);
3787 /* Use the signature of the actual arguments to determine
3788 * the hash value. This is done as follows: Each class has
3789 * an array of random numbers, that are determined when the
3790 * class is created. The integer 'hashset' is an index into
3791 * that array of random numbers. Now, from all classes that
3792 * are part of the signature of the actual arguments, the
3793 * random numbers at index 'hashset' are taken and summed
3794 * up, giving the hash value. The value of 'hashset' is
3795 * stored at the call to dispatch. This allows to have
3796 * different 'formulas' for calculating the hash value at
3797 * different places where dispatch is called. This allows
3798 * to optimize the hash formula at every individual place
3799 * where dispatch is called, such that hopefully the hash
3800 * value that is computed will directly point to the right
3801 * method in the method cache. */
3802 unsigned long int hashset
= scm_to_ulong (tmp
);
3803 unsigned long int counter
= specializers
+ 1;
3806 while (!scm_is_null (tmp_arg
) && counter
!= 0)
3808 SCM
class = scm_class_of (SCM_CAR (tmp_arg
));
3809 hash_value
+= SCM_INSTANCE_HASH (class, hashset
);
3810 tmp_arg
= SCM_CDR (tmp_arg
);
3814 method_cache
= SCM_CADR (z
);
3815 mask
= scm_to_ulong (SCM_CAR (z
));
3817 cache_end_pos
= hash_value
;
3822 /* Search the method cache for a method with a matching
3823 * signature. Start the search at position 'hash_value'. The
3824 * hashing implementation uses linear probing for conflict
3825 * resolution, that is, if the signature in question is not
3826 * found at the starting index in the hash table, the next table
3827 * entry is tried, and so on, until in the worst case the whole
3828 * cache has been searched, but still the signature has not been
3833 SCM args
= arg1
; /* list of arguments */
3834 z
= SCM_SIMPLE_VECTOR_REF (method_cache
, hash_value
);
3835 while (!scm_is_null (args
))
3837 /* More arguments than specifiers => CLASS != ENV */
3838 SCM class_of_arg
= scm_class_of (SCM_CAR (args
));
3839 if (!scm_is_eq (class_of_arg
, SCM_CAR (z
)))
3841 args
= SCM_CDR (args
);
3844 /* Fewer arguments than specifiers => CAR != ENV */
3845 if (scm_is_null (SCM_CAR (z
)) || scm_is_pair (SCM_CAR (z
)))
3848 hash_value
= (hash_value
+ 1) & mask
;
3849 } while (hash_value
!= cache_end_pos
);
3851 /* No appropriate method was found in the cache. */
3852 z
= scm_memoize_method (x
, arg1
);
3854 apply_cmethod
: /* inputs: z, arg1 */
3856 SCM formals
= SCM_CMETHOD_FORMALS (z
);
3857 env
= SCM_EXTEND_ENV (formals
, arg1
, SCM_CMETHOD_ENV (z
));
3858 x
= SCM_CMETHOD_BODY (z
);
3859 goto nontoplevel_begin
;
3865 case (ISYMNUM (SCM_IM_SLOT_REF
)):
3868 SCM instance
= EVALCAR (x
, env
);
3869 unsigned long int slot
= SCM_I_INUM (SCM_CDR (x
));
3870 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance
) [slot
]));
3874 case (ISYMNUM (SCM_IM_SLOT_SET_X
)):
3877 SCM instance
= EVALCAR (x
, env
);
3878 unsigned long int slot
= SCM_I_INUM (SCM_CADR (x
));
3879 SCM value
= EVALCAR (SCM_CDDR (x
), env
);
3880 SCM_STRUCT_DATA (instance
) [slot
] = SCM_UNPACK (value
);
3881 RETURN (SCM_UNSPECIFIED
);
3885 #if SCM_ENABLE_ELISP
3887 case (ISYMNUM (SCM_IM_NIL_COND
)):
3889 SCM test_form
= SCM_CDR (x
);
3890 x
= SCM_CDR (test_form
);
3891 while (!SCM_NULL_OR_NIL_P (x
))
3893 SCM test_result
= EVALCAR (test_form
, env
);
3894 if (!(scm_is_false (test_result
)
3895 || SCM_NULL_OR_NIL_P (test_result
)))
3897 if (scm_is_eq (SCM_CAR (x
), SCM_UNSPECIFIED
))
3898 RETURN (test_result
);
3899 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3904 test_form
= SCM_CDR (x
);
3905 x
= SCM_CDR (test_form
);
3909 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3913 #endif /* SCM_ENABLE_ELISP */
3915 case (ISYMNUM (SCM_IM_BIND
)):
3917 SCM vars
, exps
, vals
;
3920 vars
= SCM_CAAR (x
);
3921 exps
= SCM_CDAR (x
);
3923 while (!scm_is_null (exps
))
3925 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
3926 exps
= SCM_CDR (exps
);
3929 scm_swap_bindings (vars
, vals
);
3930 scm_i_set_dynwinds (scm_acons (vars
, vals
, scm_i_dynwinds ()));
3932 /* Ignore all but the last evaluation result. */
3933 for (x
= SCM_CDR (x
); !scm_is_null (SCM_CDR (x
)); x
= SCM_CDR (x
))
3935 if (scm_is_pair (SCM_CAR (x
)))
3936 CEVAL (SCM_CAR (x
), env
);
3938 proc
= EVALCAR (x
, env
);
3940 scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
3941 scm_swap_bindings (vars
, vals
);
3947 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
3952 producer
= EVALCAR (x
, env
);
3954 proc
= EVALCAR (x
, env
); /* proc is the consumer. */
3955 arg1
= SCM_APPLY (producer
, SCM_EOL
, SCM_EOL
);
3956 if (SCM_VALUESP (arg1
))
3958 /* The list of arguments is not copied. Rather, it is assumed
3959 * that this has been done by the 'values' procedure. */
3960 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
3964 arg1
= scm_list_1 (arg1
);
3966 PREP_APPLY (proc
, arg1
);
3977 if (SCM_VARIABLEP (SCM_CAR (x
)))
3978 proc
= SCM_VARIABLE_REF (SCM_CAR (x
));
3979 else if (SCM_ILOCP (SCM_CAR (x
)))
3980 proc
= *scm_ilookup (SCM_CAR (x
), env
);
3981 else if (scm_is_pair (SCM_CAR (x
)))
3982 proc
= CEVAL (SCM_CAR (x
), env
);
3983 else if (scm_is_symbol (SCM_CAR (x
)))
3985 SCM orig_sym
= SCM_CAR (x
);
3987 SCM
*location
= scm_lookupcar1 (x
, env
, 1);
3988 if (location
== NULL
)
3990 /* we have lost the race, start again. */
3996 if (SCM_MACROP (proc
))
3998 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
4000 handle_a_macro
: /* inputs: x, env, proc */
4002 /* Set a flag during macro expansion so that macro
4003 application frames can be deleted from the backtrace. */
4004 SCM_SET_MACROEXP (debug
);
4006 arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
4007 scm_cons (env
, scm_listofnull
));
4009 SCM_CLEAR_MACROEXP (debug
);
4011 switch (SCM_MACRO_TYPE (proc
))
4015 if (!scm_is_pair (arg1
))
4016 arg1
= scm_list_2 (SCM_IM_BEGIN
, arg1
);
4018 assert (!scm_is_eq (x
, SCM_CAR (arg1
))
4019 && !scm_is_eq (x
, SCM_CDR (arg1
)));
4022 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
4024 SCM_CRITICAL_SECTION_START
;
4025 SCM_SETCAR (x
, SCM_CAR (arg1
));
4026 SCM_SETCDR (x
, SCM_CDR (arg1
));
4027 SCM_CRITICAL_SECTION_END
;
4030 /* Prevent memoizing of debug info expression. */
4031 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
4035 SCM_CRITICAL_SECTION_START
;
4036 SCM_SETCAR (x
, SCM_CAR (arg1
));
4037 SCM_SETCDR (x
, SCM_CDR (arg1
));
4038 SCM_CRITICAL_SECTION_END
;
4039 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
4041 #if SCM_ENABLE_DEPRECATED == 1
4046 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
4060 if (SCM_MACROP (proc
))
4061 goto handle_a_macro
;
4065 /* When reaching this part of the code, the following is granted: Variable x
4066 * holds the first pair of an expression of the form (<function> arg ...).
4067 * Variable proc holds the object that resulted from the evaluation of
4068 * <function>. In the following, the arguments (if any) will be evaluated,
4069 * and proc will be applied to them. If proc does not really hold a
4070 * function object, this will be signalled as an error on the scheme
4071 * level. If the number of arguments does not match the number of arguments
4072 * that are allowed to be passed to proc, also an error on the scheme level
4073 * will be signalled. */
4074 PREP_APPLY (proc
, SCM_EOL
);
4075 if (scm_is_null (SCM_CDR (x
))) {
4078 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4079 switch (SCM_TYP7 (proc
))
4080 { /* no arguments given */
4081 case scm_tc7_subr_0
:
4082 RETURN (SCM_SUBRF (proc
) ());
4083 case scm_tc7_subr_1o
:
4084 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
4086 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
4087 case scm_tc7_rpsubr
:
4088 RETURN (SCM_BOOL_T
);
4090 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
4092 if (!SCM_SMOB_APPLICABLE_P (proc
))
4094 RETURN (SCM_SMOB_APPLY_0 (proc
));
4097 proc
= SCM_CCLO_SUBR (proc
);
4099 debug
.info
->a
.proc
= proc
;
4100 debug
.info
->a
.args
= scm_list_1 (arg1
);
4104 proc
= SCM_PROCEDURE (proc
);
4106 debug
.info
->a
.proc
= proc
;
4108 if (!SCM_CLOSUREP (proc
))
4111 case scm_tcs_closures
:
4113 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4114 if (scm_is_pair (formals
))
4116 x
= SCM_CLOSURE_BODY (proc
);
4117 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
4118 goto nontoplevel_begin
;
4120 case scm_tcs_struct
:
4121 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4123 x
= SCM_ENTITY_PROCEDURE (proc
);
4127 else if (SCM_I_OPERATORP (proc
))
4130 proc
= (SCM_I_ENTITYP (proc
)
4131 ? SCM_ENTITY_PROCEDURE (proc
)
4132 : SCM_OPERATOR_PROCEDURE (proc
));
4134 debug
.info
->a
.proc
= proc
;
4135 debug
.info
->a
.args
= scm_list_1 (arg1
);
4141 case scm_tc7_subr_1
:
4142 case scm_tc7_subr_2
:
4143 case scm_tc7_subr_2o
:
4146 case scm_tc7_subr_3
:
4147 case scm_tc7_lsubr_2
:
4149 scm_wrong_num_args (proc
);
4152 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
4156 /* must handle macros by here */
4158 if (scm_is_pair (x
))
4159 arg1
= EVALCAR (x
, env
);
4161 scm_wrong_num_args (proc
);
4163 debug
.info
->a
.args
= scm_list_1 (arg1
);
4168 if (scm_is_null (x
))
4171 evap1
: /* inputs: proc, arg1 */
4172 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4173 switch (SCM_TYP7 (proc
))
4174 { /* have one argument in arg1 */
4175 case scm_tc7_subr_2o
:
4176 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4177 case scm_tc7_subr_1
:
4178 case scm_tc7_subr_1o
:
4179 RETURN (SCM_SUBRF (proc
) (arg1
));
4181 if (SCM_I_INUMP (arg1
))
4183 RETURN (scm_from_double (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
))));
4185 else if (SCM_REALP (arg1
))
4187 RETURN (scm_from_double (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4189 else if (SCM_BIGP (arg1
))
4191 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4193 else if (SCM_FRACTIONP (arg1
))
4195 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4197 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4199 scm_i_symbol_chars (SCM_SNAME (proc
)));
4201 RETURN (scm_i_chase_pairs (arg1
, (scm_t_bits
) SCM_SUBRF (proc
)));
4202 case scm_tc7_rpsubr
:
4203 RETURN (SCM_BOOL_T
);
4205 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4208 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4210 RETURN (SCM_SUBRF (proc
) (scm_list_1 (arg1
)));
4213 if (!SCM_SMOB_APPLICABLE_P (proc
))
4215 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
4219 proc
= SCM_CCLO_SUBR (proc
);
4221 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
4222 debug
.info
->a
.proc
= proc
;
4226 proc
= SCM_PROCEDURE (proc
);
4228 debug
.info
->a
.proc
= proc
;
4230 if (!SCM_CLOSUREP (proc
))
4233 case scm_tcs_closures
:
4236 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4237 if (scm_is_null (formals
)
4238 || (scm_is_pair (formals
) && scm_is_pair (SCM_CDR (formals
))))
4240 x
= SCM_CLOSURE_BODY (proc
);
4242 env
= SCM_EXTEND_ENV (formals
,
4246 env
= SCM_EXTEND_ENV (formals
,
4250 goto nontoplevel_begin
;
4252 case scm_tcs_struct
:
4253 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4255 x
= SCM_ENTITY_PROCEDURE (proc
);
4257 arg1
= debug
.info
->a
.args
;
4259 arg1
= scm_list_1 (arg1
);
4263 else if (SCM_I_OPERATORP (proc
))
4267 proc
= (SCM_I_ENTITYP (proc
)
4268 ? SCM_ENTITY_PROCEDURE (proc
)
4269 : SCM_OPERATOR_PROCEDURE (proc
));
4271 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
4272 debug
.info
->a
.proc
= proc
;
4278 case scm_tc7_subr_2
:
4279 case scm_tc7_subr_0
:
4280 case scm_tc7_subr_3
:
4281 case scm_tc7_lsubr_2
:
4282 scm_wrong_num_args (proc
);
4287 if (scm_is_pair (x
))
4288 arg2
= EVALCAR (x
, env
);
4290 scm_wrong_num_args (proc
);
4292 { /* have two or more arguments */
4294 debug
.info
->a
.args
= scm_list_2 (arg1
, arg2
);
4297 if (scm_is_null (x
)) {
4300 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4301 switch (SCM_TYP7 (proc
))
4302 { /* have two arguments */
4303 case scm_tc7_subr_2
:
4304 case scm_tc7_subr_2o
:
4305 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
4308 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4310 RETURN (SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
)));
4312 case scm_tc7_lsubr_2
:
4313 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
));
4314 case scm_tc7_rpsubr
:
4316 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
4318 if (!SCM_SMOB_APPLICABLE_P (proc
))
4320 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
));
4324 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
4325 scm_cons (proc
, debug
.info
->a
.args
),
4328 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
4329 scm_cons2 (proc
, arg1
,
4336 case scm_tcs_struct
:
4337 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4339 x
= SCM_ENTITY_PROCEDURE (proc
);
4341 arg1
= debug
.info
->a
.args
;
4343 arg1
= scm_list_2 (arg1
, arg2
);
4347 else if (SCM_I_OPERATORP (proc
))
4351 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
4352 ? SCM_ENTITY_PROCEDURE (proc
)
4353 : SCM_OPERATOR_PROCEDURE (proc
),
4354 scm_cons (proc
, debug
.info
->a
.args
),
4357 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
4358 ? SCM_ENTITY_PROCEDURE (proc
)
4359 : SCM_OPERATOR_PROCEDURE (proc
),
4360 scm_cons2 (proc
, arg1
,
4370 case scm_tc7_subr_0
:
4373 case scm_tc7_subr_1o
:
4374 case scm_tc7_subr_1
:
4375 case scm_tc7_subr_3
:
4376 scm_wrong_num_args (proc
);
4380 proc
= SCM_PROCEDURE (proc
);
4382 debug
.info
->a
.proc
= proc
;
4384 if (!SCM_CLOSUREP (proc
))
4387 case scm_tcs_closures
:
4390 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4391 if (scm_is_null (formals
)
4392 || (scm_is_pair (formals
)
4393 && (scm_is_null (SCM_CDR (formals
))
4394 || (scm_is_pair (SCM_CDR (formals
))
4395 && scm_is_pair (SCM_CDDR (formals
))))))
4398 env
= SCM_EXTEND_ENV (formals
,
4402 env
= SCM_EXTEND_ENV (formals
,
4403 scm_list_2 (arg1
, arg2
),
4406 x
= SCM_CLOSURE_BODY (proc
);
4407 goto nontoplevel_begin
;
4411 if (!scm_is_pair (x
))
4412 scm_wrong_num_args (proc
);
4414 debug
.info
->a
.args
= scm_cons2 (arg1
, arg2
,
4415 deval_args (x
, env
, proc
,
4416 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
4420 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4421 switch (SCM_TYP7 (proc
))
4422 { /* have 3 or more arguments */
4424 case scm_tc7_subr_3
:
4425 if (!scm_is_null (SCM_CDR (x
)))
4426 scm_wrong_num_args (proc
);
4428 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4429 SCM_CADDR (debug
.info
->a
.args
)));
4431 arg1
= SCM_SUBRF(proc
)(arg1
, arg2
);
4432 arg2
= SCM_CDDR (debug
.info
->a
.args
);
4435 arg1
= SCM_SUBRF(proc
)(arg1
, SCM_CAR (arg2
));
4436 arg2
= SCM_CDR (arg2
);
4438 while (SCM_NIMP (arg2
));
4440 case scm_tc7_rpsubr
:
4441 if (scm_is_false (SCM_SUBRF (proc
) (arg1
, arg2
)))
4442 RETURN (SCM_BOOL_F
);
4443 arg1
= SCM_CDDR (debug
.info
->a
.args
);
4446 if (scm_is_false (SCM_SUBRF (proc
) (arg2
, SCM_CAR (arg1
))))
4447 RETURN (SCM_BOOL_F
);
4448 arg2
= SCM_CAR (arg1
);
4449 arg1
= SCM_CDR (arg1
);
4451 while (SCM_NIMP (arg1
));
4452 RETURN (SCM_BOOL_T
);
4453 case scm_tc7_lsubr_2
:
4454 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4455 SCM_CDDR (debug
.info
->a
.args
)));
4457 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4459 if (!SCM_SMOB_APPLICABLE_P (proc
))
4461 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4462 SCM_CDDR (debug
.info
->a
.args
)));
4466 proc
= SCM_PROCEDURE (proc
);
4467 debug
.info
->a
.proc
= proc
;
4468 if (!SCM_CLOSUREP (proc
))
4471 case scm_tcs_closures
:
4473 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4474 if (scm_is_null (formals
)
4475 || (scm_is_pair (formals
)
4476 && (scm_is_null (SCM_CDR (formals
))
4477 || (scm_is_pair (SCM_CDR (formals
))
4478 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4480 SCM_SET_ARGSREADY (debug
);
4481 env
= SCM_EXTEND_ENV (formals
,
4484 x
= SCM_CLOSURE_BODY (proc
);
4485 goto nontoplevel_begin
;
4488 case scm_tc7_subr_3
:
4489 if (!scm_is_null (SCM_CDR (x
)))
4490 scm_wrong_num_args (proc
);
4492 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, EVALCAR (x
, env
)));
4494 arg1
= SCM_SUBRF (proc
) (arg1
, arg2
);
4497 arg1
= SCM_SUBRF(proc
)(arg1
, EVALCAR(x
, env
));
4500 while (!scm_is_null (x
));
4502 case scm_tc7_rpsubr
:
4503 if (scm_is_false (SCM_SUBRF (proc
) (arg1
, arg2
)))
4504 RETURN (SCM_BOOL_F
);
4507 arg1
= EVALCAR (x
, env
);
4508 if (scm_is_false (SCM_SUBRF (proc
) (arg2
, arg1
)))
4509 RETURN (SCM_BOOL_F
);
4513 while (!scm_is_null (x
));
4514 RETURN (SCM_BOOL_T
);
4515 case scm_tc7_lsubr_2
:
4516 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
4518 RETURN (SCM_SUBRF (proc
) (scm_cons2 (arg1
,
4520 scm_eval_args (x
, env
, proc
))));
4522 if (!SCM_SMOB_APPLICABLE_P (proc
))
4524 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4525 scm_eval_args (x
, env
, proc
)));
4529 proc
= SCM_PROCEDURE (proc
);
4530 if (!SCM_CLOSUREP (proc
))
4533 case scm_tcs_closures
:
4535 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4536 if (scm_is_null (formals
)
4537 || (scm_is_pair (formals
)
4538 && (scm_is_null (SCM_CDR (formals
))
4539 || (scm_is_pair (SCM_CDR (formals
))
4540 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4542 env
= SCM_EXTEND_ENV (formals
,
4545 scm_eval_args (x
, env
, proc
)),
4547 x
= SCM_CLOSURE_BODY (proc
);
4548 goto nontoplevel_begin
;
4551 case scm_tcs_struct
:
4552 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4555 arg1
= debug
.info
->a
.args
;
4557 arg1
= scm_cons2 (arg1
, arg2
, scm_eval_args (x
, env
, proc
));
4559 x
= SCM_ENTITY_PROCEDURE (proc
);
4562 else if (SCM_I_OPERATORP (proc
))
4566 case scm_tc7_subr_2
:
4567 case scm_tc7_subr_1o
:
4568 case scm_tc7_subr_2o
:
4569 case scm_tc7_subr_0
:
4572 case scm_tc7_subr_1
:
4573 scm_wrong_num_args (proc
);
4581 if (scm_check_exit_p
&& SCM_TRAPS_P
)
4582 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
4584 SCM_CLEAR_TRACED_FRAME (debug
);
4585 if (SCM_CHEAPTRAPS_P
)
4586 arg1
= scm_make_debugobj (&debug
);
4590 SCM val
= scm_make_continuation (&first
);
4601 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
4605 scm_i_set_last_debug_frame (debug
.prev
);
4611 /* SECTION: This code is compiled once.
4618 /* Simple procedure calls
4622 scm_call_0 (SCM proc
)
4624 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
4628 scm_call_1 (SCM proc
, SCM arg1
)
4630 return scm_apply (proc
, arg1
, scm_listofnull
);
4634 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
4636 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
4640 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
4642 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
4646 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
4648 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
4649 scm_cons (arg4
, scm_listofnull
)));
4652 /* Simple procedure applies
4656 scm_apply_0 (SCM proc
, SCM args
)
4658 return scm_apply (proc
, args
, SCM_EOL
);
4662 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
4664 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
4668 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
4670 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
4674 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
4676 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
4680 /* This code processes the arguments to apply:
4682 (apply PROC ARG1 ... ARGS)
4684 Given a list (ARG1 ... ARGS), this function conses the ARG1
4685 ... arguments onto the front of ARGS, and returns the resulting
4686 list. Note that ARGS is a list; thus, the argument to this
4687 function is a list whose last element is a list.
4689 Apply calls this function, and applies PROC to the elements of the
4690 result. apply:nconc2last takes care of building the list of
4691 arguments, given (ARG1 ... ARGS).
4693 Rather than do new consing, apply:nconc2last destroys its argument.
4694 On that topic, this code came into my care with the following
4695 beautifully cryptic comment on that topic: "This will only screw
4696 you if you do (scm_apply scm_apply '( ... ))" If you know what
4697 they're referring to, send me a patch to this comment. */
4699 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
4701 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
4702 "conses the @var{arg1} @dots{} arguments onto the front of\n"
4703 "@var{args}, and returns the resulting list. Note that\n"
4704 "@var{args} is a list; thus, the argument to this function is\n"
4705 "a list whose last element is a list.\n"
4706 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
4707 "destroys its argument, so use with care.")
4708 #define FUNC_NAME s_scm_nconc2last
4711 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
4713 while (!scm_is_null (SCM_CDR (*lloc
))) /* Perhaps should be
4714 SCM_NULL_OR_NIL_P, but not
4715 needed in 99.99% of cases,
4716 and it could seriously hurt
4717 performance. - Neil */
4718 lloc
= SCM_CDRLOC (*lloc
);
4719 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
4720 *lloc
= SCM_CAR (*lloc
);
4728 /* SECTION: When DEVAL is defined this code yields scm_dapply.
4729 * It is compiled twice.
4734 scm_apply (SCM proc
, SCM arg1
, SCM args
)
4740 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
4745 /* Apply a function to a list of arguments.
4747 This function is exported to the Scheme level as taking two
4748 required arguments and a tail argument, as if it were:
4749 (lambda (proc arg1 . args) ...)
4750 Thus, if you just have a list of arguments to pass to a procedure,
4751 pass the list as ARG1, and '() for ARGS. If you have some fixed
4752 args, pass the first as ARG1, then cons any remaining fixed args
4753 onto the front of your argument list, and pass that as ARGS. */
4756 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
4759 scm_t_debug_frame debug
;
4760 scm_t_debug_info debug_vect_body
;
4761 debug
.prev
= scm_i_last_debug_frame ();
4762 debug
.status
= SCM_APPLYFRAME
;
4763 debug
.vect
= &debug_vect_body
;
4764 debug
.vect
[0].a
.proc
= proc
;
4765 debug
.vect
[0].a
.args
= SCM_EOL
;
4766 scm_i_set_last_debug_frame (&debug
);
4768 if (scm_debug_mode_p
)
4769 return scm_dapply (proc
, arg1
, args
);
4772 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
4774 /* If ARGS is the empty list, then we're calling apply with only two
4775 arguments --- ARG1 is the list of arguments for PROC. Whatever
4776 the case, futz with things so that ARG1 is the first argument to
4777 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
4780 Setting the debug apply frame args this way is pretty messy.
4781 Perhaps we should store arg1 and args directly in the frame as
4782 received, and let scm_frame_arguments unpack them, because that's
4783 a relatively rare operation. This works for now; if the Guile
4784 developer archives are still around, see Mikael's post of
4786 if (scm_is_null (args
))
4788 if (scm_is_null (arg1
))
4790 arg1
= SCM_UNDEFINED
;
4792 debug
.vect
[0].a
.args
= SCM_EOL
;
4798 debug
.vect
[0].a
.args
= arg1
;
4800 args
= SCM_CDR (arg1
);
4801 arg1
= SCM_CAR (arg1
);
4806 args
= scm_nconc2last (args
);
4808 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4812 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
4815 if (SCM_CHEAPTRAPS_P
)
4816 tmp
= scm_make_debugobj (&debug
);
4821 tmp
= scm_make_continuation (&first
);
4826 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
4833 switch (SCM_TYP7 (proc
))
4835 case scm_tc7_subr_2o
:
4836 args
= scm_is_null (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
4837 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4838 case scm_tc7_subr_2
:
4839 if (scm_is_null (args
) || !scm_is_null (SCM_CDR (args
)))
4840 scm_wrong_num_args (proc
);
4841 args
= SCM_CAR (args
);
4842 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4843 case scm_tc7_subr_0
:
4844 if (!SCM_UNBNDP (arg1
))
4845 scm_wrong_num_args (proc
);
4847 RETURN (SCM_SUBRF (proc
) ());
4848 case scm_tc7_subr_1
:
4849 if (SCM_UNBNDP (arg1
))
4850 scm_wrong_num_args (proc
);
4851 case scm_tc7_subr_1o
:
4852 if (!scm_is_null (args
))
4853 scm_wrong_num_args (proc
);
4855 RETURN (SCM_SUBRF (proc
) (arg1
));
4857 if (SCM_UNBNDP (arg1
) || !scm_is_null (args
))
4858 scm_wrong_num_args (proc
);
4859 if (SCM_I_INUMP (arg1
))
4861 RETURN (scm_from_double (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
))));
4863 else if (SCM_REALP (arg1
))
4865 RETURN (scm_from_double (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4867 else if (SCM_BIGP (arg1
))
4869 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4871 else if (SCM_FRACTIONP (arg1
))
4873 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4875 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4876 SCM_ARG1
, scm_i_symbol_chars (SCM_SNAME (proc
)));
4878 if (SCM_UNBNDP (arg1
) || !scm_is_null (args
))
4879 scm_wrong_num_args (proc
);
4880 RETURN (scm_i_chase_pairs (arg1
, (scm_t_bits
) SCM_SUBRF (proc
)));
4881 case scm_tc7_subr_3
:
4882 if (scm_is_null (args
)
4883 || scm_is_null (SCM_CDR (args
))
4884 || !scm_is_null (SCM_CDDR (args
)))
4885 scm_wrong_num_args (proc
);
4887 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
4890 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
4892 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
4894 case scm_tc7_lsubr_2
:
4895 if (!scm_is_pair (args
))
4896 scm_wrong_num_args (proc
);
4898 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4900 if (scm_is_null (args
))
4901 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4902 while (SCM_NIMP (args
))
4904 SCM_ASSERT (scm_is_pair (args
), args
, SCM_ARG2
, "apply");
4905 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
4906 args
= SCM_CDR (args
);
4909 case scm_tc7_rpsubr
:
4910 if (scm_is_null (args
))
4911 RETURN (SCM_BOOL_T
);
4912 while (SCM_NIMP (args
))
4914 SCM_ASSERT (scm_is_pair (args
), args
, SCM_ARG2
, "apply");
4915 if (scm_is_false (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
4916 RETURN (SCM_BOOL_F
);
4917 arg1
= SCM_CAR (args
);
4918 args
= SCM_CDR (args
);
4920 RETURN (SCM_BOOL_T
);
4921 case scm_tcs_closures
:
4923 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4925 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4927 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
4928 scm_wrong_num_args (proc
);
4930 /* Copy argument list */
4935 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
4936 for (arg1
= SCM_CDR (arg1
); scm_is_pair (arg1
); arg1
= SCM_CDR (arg1
))
4938 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
));
4941 SCM_SETCDR (tl
, arg1
);
4944 args
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4947 proc
= SCM_CLOSURE_BODY (proc
);
4949 arg1
= SCM_CDR (proc
);
4950 while (!scm_is_null (arg1
))
4952 if (SCM_IMP (SCM_CAR (proc
)))
4954 if (SCM_ISYMP (SCM_CAR (proc
)))
4956 scm_i_scm_pthread_mutex_lock (&source_mutex
);
4957 /* check for race condition */
4958 if (SCM_ISYMP (SCM_CAR (proc
)))
4959 m_expand_body (proc
, args
);
4960 scm_i_pthread_mutex_unlock (&source_mutex
);
4964 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
4967 (void) EVAL (SCM_CAR (proc
), args
);
4969 arg1
= SCM_CDR (proc
);
4971 RETURN (EVALCAR (proc
, args
));
4973 if (!SCM_SMOB_APPLICABLE_P (proc
))
4975 if (SCM_UNBNDP (arg1
))
4976 RETURN (SCM_SMOB_APPLY_0 (proc
));
4977 else if (scm_is_null (args
))
4978 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
4979 else if (scm_is_null (SCM_CDR (args
)))
4980 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
4982 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4985 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4987 proc
= SCM_CCLO_SUBR (proc
);
4988 debug
.vect
[0].a
.proc
= proc
;
4989 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4991 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4993 proc
= SCM_CCLO_SUBR (proc
);
4997 proc
= SCM_PROCEDURE (proc
);
4999 debug
.vect
[0].a
.proc
= proc
;
5002 case scm_tcs_struct
:
5003 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5006 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
5008 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
5010 RETURN (scm_apply_generic (proc
, args
));
5012 else if (SCM_I_OPERATORP (proc
))
5016 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
5018 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
5021 proc
= (SCM_I_ENTITYP (proc
)
5022 ? SCM_ENTITY_PROCEDURE (proc
)
5023 : SCM_OPERATOR_PROCEDURE (proc
));
5025 debug
.vect
[0].a
.proc
= proc
;
5026 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
5028 if (SCM_NIMP (proc
))
5037 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
5041 if (scm_check_exit_p
&& SCM_TRAPS_P
)
5042 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
5044 SCM_CLEAR_TRACED_FRAME (debug
);
5045 if (SCM_CHEAPTRAPS_P
)
5046 arg1
= scm_make_debugobj (&debug
);
5050 SCM val
= scm_make_continuation (&first
);
5061 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
5065 scm_i_set_last_debug_frame (debug
.prev
);
5071 /* SECTION: The rest of this file is only read once.
5078 * Trampolines make it possible to move procedure application dispatch
5079 * outside inner loops. The motivation was clean implementation of
5080 * efficient replacements of R5RS primitives in SRFI-1.
5082 * The semantics is clear: scm_trampoline_N returns an optimized
5083 * version of scm_call_N (or NULL if the procedure isn't applicable
5086 * Applying the optimization to map and for-each increased efficiency
5087 * noticeably. For example, (map abs ls) is now 8 times faster than
5092 call_subr0_0 (SCM proc
)
5094 return SCM_SUBRF (proc
) ();
5098 call_subr1o_0 (SCM proc
)
5100 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
5104 call_lsubr_0 (SCM proc
)
5106 return SCM_SUBRF (proc
) (SCM_EOL
);
5110 scm_i_call_closure_0 (SCM proc
)
5112 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
5115 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
5120 scm_trampoline_0 (SCM proc
)
5122 scm_t_trampoline_0 trampoline
;
5127 switch (SCM_TYP7 (proc
))
5129 case scm_tc7_subr_0
:
5130 trampoline
= call_subr0_0
;
5132 case scm_tc7_subr_1o
:
5133 trampoline
= call_subr1o_0
;
5136 trampoline
= call_lsubr_0
;
5138 case scm_tcs_closures
:
5140 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5141 if (scm_is_null (formals
) || !scm_is_pair (formals
))
5142 trampoline
= scm_i_call_closure_0
;
5147 case scm_tcs_struct
:
5148 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5149 trampoline
= scm_call_generic_0
;
5150 else if (SCM_I_OPERATORP (proc
))
5151 trampoline
= scm_call_0
;
5156 if (SCM_SMOB_APPLICABLE_P (proc
))
5157 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
5162 case scm_tc7_rpsubr
:
5165 trampoline
= scm_call_0
;
5168 return NULL
; /* not applicable on zero arguments */
5170 /* We only reach this point if a valid trampoline was determined. */
5172 /* If debugging is enabled, we want to see all calls to proc on the stack.
5173 * Thus, we replace the trampoline shortcut with scm_call_0. */
5174 if (scm_debug_mode_p
)
5181 call_subr1_1 (SCM proc
, SCM arg1
)
5183 return SCM_SUBRF (proc
) (arg1
);
5187 call_subr2o_1 (SCM proc
, SCM arg1
)
5189 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
5193 call_lsubr_1 (SCM proc
, SCM arg1
)
5195 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
5199 call_dsubr_1 (SCM proc
, SCM arg1
)
5201 if (SCM_I_INUMP (arg1
))
5203 RETURN (scm_from_double (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
))));
5205 else if (SCM_REALP (arg1
))
5207 RETURN (scm_from_double (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
5209 else if (SCM_BIGP (arg1
))
5211 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
5213 else if (SCM_FRACTIONP (arg1
))
5215 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
5217 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
5218 SCM_ARG1
, scm_i_symbol_chars (SCM_SNAME (proc
)));
5222 call_cxr_1 (SCM proc
, SCM arg1
)
5224 return scm_i_chase_pairs (arg1
, (scm_t_bits
) SCM_SUBRF (proc
));
5228 call_closure_1 (SCM proc
, SCM arg1
)
5230 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
5233 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
5238 scm_trampoline_1 (SCM proc
)
5240 scm_t_trampoline_1 trampoline
;
5245 switch (SCM_TYP7 (proc
))
5247 case scm_tc7_subr_1
:
5248 case scm_tc7_subr_1o
:
5249 trampoline
= call_subr1_1
;
5251 case scm_tc7_subr_2o
:
5252 trampoline
= call_subr2o_1
;
5255 trampoline
= call_lsubr_1
;
5258 trampoline
= call_dsubr_1
;
5261 trampoline
= call_cxr_1
;
5263 case scm_tcs_closures
:
5265 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5266 if (!scm_is_null (formals
)
5267 && (!scm_is_pair (formals
) || !scm_is_pair (SCM_CDR (formals
))))
5268 trampoline
= call_closure_1
;
5273 case scm_tcs_struct
:
5274 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5275 trampoline
= scm_call_generic_1
;
5276 else if (SCM_I_OPERATORP (proc
))
5277 trampoline
= scm_call_1
;
5282 if (SCM_SMOB_APPLICABLE_P (proc
))
5283 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
5288 case scm_tc7_rpsubr
:
5291 trampoline
= scm_call_1
;
5294 return NULL
; /* not applicable on one arg */
5296 /* We only reach this point if a valid trampoline was determined. */
5298 /* If debugging is enabled, we want to see all calls to proc on the stack.
5299 * Thus, we replace the trampoline shortcut with scm_call_1. */
5300 if (scm_debug_mode_p
)
5307 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
5309 return SCM_SUBRF (proc
) (arg1
, arg2
);
5313 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
5315 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
5319 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
5321 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
5325 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
5327 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
5328 scm_list_2 (arg1
, arg2
),
5330 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
5335 scm_trampoline_2 (SCM proc
)
5337 scm_t_trampoline_2 trampoline
;
5342 switch (SCM_TYP7 (proc
))
5344 case scm_tc7_subr_2
:
5345 case scm_tc7_subr_2o
:
5346 case scm_tc7_rpsubr
:
5348 trampoline
= call_subr2_2
;
5350 case scm_tc7_lsubr_2
:
5351 trampoline
= call_lsubr2_2
;
5354 trampoline
= call_lsubr_2
;
5356 case scm_tcs_closures
:
5358 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5359 if (!scm_is_null (formals
)
5360 && (!scm_is_pair (formals
)
5361 || (!scm_is_null (SCM_CDR (formals
))
5362 && (!scm_is_pair (SCM_CDR (formals
))
5363 || !scm_is_pair (SCM_CDDR (formals
))))))
5364 trampoline
= call_closure_2
;
5369 case scm_tcs_struct
:
5370 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5371 trampoline
= scm_call_generic_2
;
5372 else if (SCM_I_OPERATORP (proc
))
5373 trampoline
= scm_call_2
;
5378 if (SCM_SMOB_APPLICABLE_P (proc
))
5379 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
5385 trampoline
= scm_call_2
;
5388 return NULL
; /* not applicable on two args */
5390 /* We only reach this point if a valid trampoline was determined. */
5392 /* If debugging is enabled, we want to see all calls to proc on the stack.
5393 * Thus, we replace the trampoline shortcut with scm_call_2. */
5394 if (scm_debug_mode_p
)
5400 /* Typechecking for multi-argument MAP and FOR-EACH.
5402 Verify that each element of the vector ARGV, except for the first,
5403 is a proper list whose length is LEN. Attribute errors to WHO,
5404 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
5406 check_map_args (SCM argv
,
5415 for (i
= SCM_SIMPLE_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
5417 SCM elt
= SCM_SIMPLE_VECTOR_REF (argv
, i
);
5418 long elt_len
= scm_ilength (elt
);
5423 scm_apply_generic (gf
, scm_cons (proc
, args
));
5425 scm_wrong_type_arg (who
, i
+ 2, elt
);
5429 scm_out_of_range_pos (who
, elt
, scm_from_long (i
+ 2));
5434 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
5436 /* Note: Currently, scm_map applies PROC to the argument list(s)
5437 sequentially, starting with the first element(s). This is used in
5438 evalext.c where the Scheme procedure `map-in-order', which guarantees
5439 sequential behaviour, is implemented using scm_map. If the
5440 behaviour changes, we need to update `map-in-order'.
5444 scm_map (SCM proc
, SCM arg1
, SCM args
)
5445 #define FUNC_NAME s_map
5451 len
= scm_ilength (arg1
);
5452 SCM_GASSERTn (len
>= 0,
5453 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
5454 SCM_VALIDATE_REST_ARGUMENT (args
);
5455 if (scm_is_null (args
))
5457 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5458 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
5459 while (SCM_NIMP (arg1
))
5461 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
5462 pres
= SCM_CDRLOC (*pres
);
5463 arg1
= SCM_CDR (arg1
);
5467 if (scm_is_null (SCM_CDR (args
)))
5469 SCM arg2
= SCM_CAR (args
);
5470 int len2
= scm_ilength (arg2
);
5471 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5473 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
5474 SCM_GASSERTn (len2
>= 0,
5475 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
5477 SCM_OUT_OF_RANGE (3, arg2
);
5478 while (SCM_NIMP (arg1
))
5480 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
5481 pres
= SCM_CDRLOC (*pres
);
5482 arg1
= SCM_CDR (arg1
);
5483 arg2
= SCM_CDR (arg2
);
5487 arg1
= scm_cons (arg1
, args
);
5488 args
= scm_vector (arg1
);
5489 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
5493 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5495 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
5498 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
5499 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
5501 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
5502 pres
= SCM_CDRLOC (*pres
);
5508 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
5511 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
5512 #define FUNC_NAME s_for_each
5515 len
= scm_ilength (arg1
);
5516 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
5517 SCM_ARG2
, s_for_each
);
5518 SCM_VALIDATE_REST_ARGUMENT (args
);
5519 if (scm_is_null (args
))
5521 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5522 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
5523 while (SCM_NIMP (arg1
))
5525 call (proc
, SCM_CAR (arg1
));
5526 arg1
= SCM_CDR (arg1
);
5528 return SCM_UNSPECIFIED
;
5530 if (scm_is_null (SCM_CDR (args
)))
5532 SCM arg2
= SCM_CAR (args
);
5533 int len2
= scm_ilength (arg2
);
5534 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5535 SCM_GASSERTn (call
, g_for_each
,
5536 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
5537 SCM_GASSERTn (len2
>= 0, g_for_each
,
5538 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
5540 SCM_OUT_OF_RANGE (3, arg2
);
5541 while (SCM_NIMP (arg1
))
5543 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
5544 arg1
= SCM_CDR (arg1
);
5545 arg2
= SCM_CDR (arg2
);
5547 return SCM_UNSPECIFIED
;
5549 arg1
= scm_cons (arg1
, args
);
5550 args
= scm_vector (arg1
);
5551 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
5555 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5557 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
5559 return SCM_UNSPECIFIED
;
5560 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
5561 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
5563 scm_apply (proc
, arg1
, SCM_EOL
);
5570 scm_closure (SCM code
, SCM env
)
5573 SCM closcar
= scm_cons (code
, SCM_EOL
);
5574 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
5575 scm_remember_upto_here (closcar
);
5580 scm_t_bits scm_tc16_promise
;
5583 scm_makprom (SCM code
)
5585 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
5587 scm_make_recursive_mutex ());
5591 promise_mark (SCM promise
)
5593 scm_gc_mark (SCM_PROMISE_MUTEX (promise
));
5594 return SCM_PROMISE_DATA (promise
);
5598 promise_free (SCM promise
)
5604 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
5606 int writingp
= SCM_WRITINGP (pstate
);
5607 scm_puts ("#<promise ", port
);
5608 SCM_SET_WRITINGP (pstate
, 1);
5609 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
5610 SCM_SET_WRITINGP (pstate
, writingp
);
5611 scm_putc ('>', port
);
5615 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
5617 "If the promise @var{x} has not been computed yet, compute and\n"
5618 "return @var{x}, otherwise just return the previously computed\n"
5620 #define FUNC_NAME s_scm_force
5622 SCM_VALIDATE_SMOB (1, promise
, promise
);
5623 scm_lock_mutex (SCM_PROMISE_MUTEX (promise
));
5624 if (!SCM_PROMISE_COMPUTED_P (promise
))
5626 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
5627 if (!SCM_PROMISE_COMPUTED_P (promise
))
5629 SCM_SET_PROMISE_DATA (promise
, ans
);
5630 SCM_SET_PROMISE_COMPUTED (promise
);
5633 scm_unlock_mutex (SCM_PROMISE_MUTEX (promise
));
5634 return SCM_PROMISE_DATA (promise
);
5639 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
5641 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
5642 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
5643 #define FUNC_NAME s_scm_promise_p
5645 return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
5650 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
5651 (SCM xorig
, SCM x
, SCM y
),
5652 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
5653 "Any source properties associated with @var{xorig} are also associated\n"
5654 "with the new pair.")
5655 #define FUNC_NAME s_scm_cons_source
5658 z
= scm_cons (x
, y
);
5659 /* Copy source properties possibly associated with xorig. */
5660 p
= scm_whash_lookup (scm_source_whash
, xorig
);
5661 if (scm_is_true (p
))
5662 scm_whash_insert (scm_source_whash
, z
, p
);
5668 /* The function scm_copy_tree is used to copy an expression tree to allow the
5669 * memoizer to modify the expression during memoization. scm_copy_tree
5670 * creates deep copies of pairs and vectors, but not of any other data types,
5671 * since only pairs and vectors will be parsed by the memoizer.
5673 * To avoid infinite recursion due to cyclic structures, the hare-and-tortoise
5674 * pattern is used to detect cycles. In fact, the pattern is used in two
5675 * dimensions, vertical (indicated in the code by the variable names 'hare'
5676 * and 'tortoise') and horizontal ('rabbit' and 'turtle'). In both
5677 * dimensions, the hare/rabbit will take two steps when the tortoise/turtle
5680 * The vertical dimension corresponds to recursive calls to function
5681 * copy_tree: This happens when descending into vector elements, into cars of
5682 * lists and into the cdr of an improper list. In this dimension, the
5683 * tortoise follows the hare by using the processor stack: Every stack frame
5684 * will hold an instance of struct t_trace. These instances are connected in
5685 * a way that represents the trace of the hare, which thus can be followed by
5686 * the tortoise. The tortoise will always point to struct t_trace instances
5687 * relating to SCM objects that have already been copied. Thus, a cycle is
5688 * detected if the tortoise and the hare point to the same object,
5690 * The horizontal dimension is within one execution of copy_tree, when the
5691 * function cdr's along the pairs of a list. This is the standard
5692 * hare-and-tortoise implementation, found several times in guile. */
5695 struct t_trace
*trace
; // These pointers form a trace along the stack.
5696 SCM obj
; // The object handled at the respective stack frame.
5701 struct t_trace
*const hare
,
5702 struct t_trace
*tortoise
,
5703 unsigned int tortoise_delay
)
5705 if (!scm_is_pair (hare
->obj
) && !scm_is_simple_vector (hare
->obj
))
5711 /* Prepare the trace along the stack. */
5712 struct t_trace new_hare
;
5713 hare
->trace
= &new_hare
;
5715 /* The tortoise will make its step after the delay has elapsed. Note
5716 * that in contrast to the typical hare-and-tortoise pattern, the step
5717 * of the tortoise happens before the hare takes its steps. This is, in
5718 * principle, no problem, except for the start of the algorithm: Then,
5719 * it has to be made sure that the hare actually gets its advantage of
5721 if (tortoise_delay
== 0)
5724 tortoise
= tortoise
->trace
;
5725 ASSERT_SYNTAX (!scm_is_eq (hare
->obj
, tortoise
->obj
),
5726 s_bad_expression
, hare
->obj
);
5733 if (scm_is_simple_vector (hare
->obj
))
5735 size_t length
= SCM_SIMPLE_VECTOR_LENGTH (hare
->obj
);
5736 SCM new_vector
= scm_c_make_vector (length
, SCM_UNSPECIFIED
);
5738 /* Each vector element is copied by recursing into copy_tree, having
5739 * the tortoise follow the hare into the depths of the stack. */
5740 unsigned long int i
;
5741 for (i
= 0; i
< length
; ++i
)
5744 new_hare
.obj
= SCM_SIMPLE_VECTOR_REF (hare
->obj
, i
);
5745 new_element
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5746 SCM_SIMPLE_VECTOR_SET (new_vector
, i
, new_element
);
5751 else // scm_is_pair (hare->obj)
5756 SCM rabbit
= hare
->obj
;
5757 SCM turtle
= hare
->obj
;
5761 /* The first pair of the list is treated specially, in order to
5762 * preserve a potential source code position. */
5763 result
= tail
= scm_cons_source (rabbit
, SCM_EOL
, SCM_EOL
);
5764 new_hare
.obj
= SCM_CAR (rabbit
);
5765 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5766 SCM_SETCAR (tail
, copy
);
5768 /* The remaining pairs of the list are copied by, horizontally,
5769 * having the turtle follow the rabbit, and, vertically, having the
5770 * tortoise follow the hare into the depths of the stack. */
5771 rabbit
= SCM_CDR (rabbit
);
5772 while (scm_is_pair (rabbit
))
5774 new_hare
.obj
= SCM_CAR (rabbit
);
5775 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5776 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
5777 tail
= SCM_CDR (tail
);
5779 rabbit
= SCM_CDR (rabbit
);
5780 if (scm_is_pair (rabbit
))
5782 new_hare
.obj
= SCM_CAR (rabbit
);
5783 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5784 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
5785 tail
= SCM_CDR (tail
);
5786 rabbit
= SCM_CDR (rabbit
);
5788 turtle
= SCM_CDR (turtle
);
5789 ASSERT_SYNTAX (!scm_is_eq (rabbit
, turtle
),
5790 s_bad_expression
, rabbit
);
5794 /* We have to recurse into copy_tree again for the last cdr, in
5795 * order to handle the situation that it holds a vector. */
5796 new_hare
.obj
= rabbit
;
5797 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5798 SCM_SETCDR (tail
, copy
);
5805 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
5807 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
5808 "the new data structure. @code{copy-tree} recurses down the\n"
5809 "contents of both pairs and vectors (since both cons cells and vector\n"
5810 "cells may point to arbitrary objects), and stops recursing when it hits\n"
5811 "any other object.")
5812 #define FUNC_NAME s_scm_copy_tree
5814 /* Prepare the trace along the stack. */
5815 struct t_trace trace
;
5818 /* In function copy_tree, if the tortoise makes its step, it will do this
5819 * before the hare has the chance to move. Thus, we have to make sure that
5820 * the very first step of the tortoise will not happen after the hare has
5821 * really made two steps. This is achieved by passing '2' as the initial
5822 * delay for the tortoise. NOTE: Since cycles are unlikely, giving the hare
5823 * a bigger advantage may improve performance slightly. */
5824 return copy_tree (&trace
, &trace
, 2);
5829 /* We have three levels of EVAL here:
5831 - scm_i_eval (exp, env)
5833 evaluates EXP in environment ENV. ENV is a lexical environment
5834 structure as used by the actual tree code evaluator. When ENV is
5835 a top-level environment, then changes to the current module are
5836 tracked by updating ENV so that it continues to be in sync with
5839 - scm_primitive_eval (exp)
5841 evaluates EXP in the top-level environment as determined by the
5842 current module. This is done by constructing a suitable
5843 environment and calling scm_i_eval. Thus, changes to the
5844 top-level module are tracked normally.
5846 - scm_eval (exp, mod_or_state)
5848 evaluates EXP while MOD_OR_STATE is the current module or current
5849 dynamic state (as appropriate). This is done by setting the
5850 current module (or dynamic state) to MOD_OR_STATE, invoking
5851 scm_primitive_eval on EXP, and then restoring the current module
5852 (or dynamic state) to the value it had previously. That is,
5853 while EXP is evaluated, changes to the current module (or dynamic
5854 state) are tracked, but these changes do not persist when
5857 For each level of evals, there are two variants, distinguished by a
5858 _x suffix: the ordinary variant does not modify EXP while the _x
5859 variant can destructively modify EXP into something completely
5860 unintelligible. A Scheme data structure passed as EXP to one of the
5861 _x variants should not ever be used again for anything. So when in
5862 doubt, use the ordinary variant.
5867 scm_i_eval_x (SCM exp
, SCM env
)
5869 if (scm_is_symbol (exp
))
5870 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
5872 return SCM_I_XEVAL (exp
, env
);
5876 scm_i_eval (SCM exp
, SCM env
)
5878 exp
= scm_copy_tree (exp
);
5879 if (scm_is_symbol (exp
))
5880 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
5882 return SCM_I_XEVAL (exp
, env
);
5886 scm_primitive_eval_x (SCM exp
)
5889 SCM transformer
= scm_current_module_transformer ();
5890 if (SCM_NIMP (transformer
))
5891 exp
= scm_call_1 (transformer
, exp
);
5892 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5893 return scm_i_eval_x (exp
, env
);
5896 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
5898 "Evaluate @var{exp} in the top-level environment specified by\n"
5899 "the current module.")
5900 #define FUNC_NAME s_scm_primitive_eval
5903 SCM transformer
= scm_current_module_transformer ();
5904 if (scm_is_true (transformer
))
5905 exp
= scm_call_1 (transformer
, exp
);
5906 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5907 return scm_i_eval (exp
, env
);
5912 /* Eval does not take the second arg optionally. This is intentional
5913 * in order to be R5RS compatible, and to prepare for the new module
5914 * system, where we would like to make the choice of evaluation
5915 * environment explicit. */
5918 scm_eval_x (SCM exp
, SCM module_or_state
)
5922 scm_frame_begin (SCM_F_FRAME_REWINDABLE
);
5923 if (scm_is_dynamic_state (module_or_state
))
5924 scm_frame_current_dynamic_state (module_or_state
);
5926 scm_frame_current_module (module_or_state
);
5928 res
= scm_primitive_eval_x (exp
);
5934 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
5935 (SCM exp
, SCM module_or_state
),
5936 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
5937 "in the top-level environment specified by\n"
5938 "@var{module_or_state}.\n"
5939 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
5940 "@var{module_or_state} is made the current module when\n"
5941 "it is a module, or the current dynamic state when it is\n"
5943 "Example: (eval '(+ 1 2) (interaction-environment))")
5944 #define FUNC_NAME s_scm_eval
5948 scm_frame_begin (SCM_F_FRAME_REWINDABLE
);
5949 if (scm_is_dynamic_state (module_or_state
))
5950 scm_frame_current_dynamic_state (module_or_state
);
5952 scm_frame_current_module (module_or_state
);
5954 res
= scm_primitive_eval (exp
);
5962 /* At this point, deval and scm_dapply are generated.
5969 #if (SCM_ENABLE_DEPRECATED == 1)
5971 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5972 SCM
scm_ceval (SCM x
, SCM env
)
5974 if (scm_is_pair (x
))
5975 return ceval (x
, env
);
5976 else if (scm_is_symbol (x
))
5977 return *scm_lookupcar (scm_cons (x
, SCM_UNDEFINED
), env
, 1);
5979 return SCM_I_XEVAL (x
, env
);
5982 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5983 SCM
scm_deval (SCM x
, SCM env
)
5985 if (scm_is_pair (x
))
5986 return deval (x
, env
);
5987 else if (scm_is_symbol (x
))
5988 return *scm_lookupcar (scm_cons (x
, SCM_UNDEFINED
), env
, 1);
5990 return SCM_I_XEVAL (x
, env
);
5994 dispatching_eval (SCM x
, SCM env
)
5996 if (scm_debug_mode_p
)
5997 return scm_deval (x
, env
);
5999 return scm_ceval (x
, env
);
6002 /* Deprecated in guile 1.7.0 on 2004-03-29. */
6003 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
) = dispatching_eval
;
6011 scm_init_opts (scm_evaluator_traps
,
6012 scm_evaluator_trap_table
,
6013 SCM_N_EVALUATOR_TRAPS
);
6014 scm_init_opts (scm_eval_options_interface
,
6016 SCM_N_EVAL_OPTIONS
);
6018 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
6019 scm_set_smob_mark (scm_tc16_promise
, promise_mark
);
6020 scm_set_smob_free (scm_tc16_promise
, promise_free
);
6021 scm_set_smob_print (scm_tc16_promise
, promise_print
);
6023 undefineds
= scm_list_1 (SCM_UNDEFINED
);
6024 SCM_SETCDR (undefineds
, undefineds
);
6025 scm_permanent_object (undefineds
);
6027 scm_listofnull
= scm_list_1 (SCM_EOL
);
6029 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
6030 scm_permanent_object (f_apply
);
6032 #include "libguile/eval.x"
6034 scm_add_feature ("delay");