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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 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 SCM_CRITICAL_SECTION_START
;
884 SCM_SETCAR (x
, SCM_CAR (res
));
885 SCM_SETCDR (x
, SCM_CDR (res
));
886 SCM_CRITICAL_SECTION_END
;
891 /* Start of the memoizers for the standard R5RS builtin macros. */
894 SCM_SYNTAX (s_and
, "and", scm_i_makbimacro
, scm_m_and
);
895 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
898 scm_m_and (SCM expr
, SCM env SCM_UNUSED
)
900 const SCM cdr_expr
= SCM_CDR (expr
);
901 const long length
= scm_ilength (cdr_expr
);
903 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
907 /* Special case: (and) is replaced by #t. */
912 SCM_SETCAR (expr
, SCM_IM_AND
);
918 unmemoize_and (const SCM expr
, const SCM env
)
920 return scm_cons (scm_sym_and
, unmemoize_exprs (SCM_CDR (expr
), env
));
924 SCM_SYNTAX (s_begin
, "begin", scm_i_makbimacro
, scm_m_begin
);
925 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
928 scm_m_begin (SCM expr
, SCM env SCM_UNUSED
)
930 const SCM cdr_expr
= SCM_CDR (expr
);
931 /* Dirk:FIXME:: An empty begin clause is not generally allowed by R5RS.
932 * That means, there should be a distinction between uses of begin where an
933 * empty clause is OK and where it is not. */
934 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
936 SCM_SETCAR (expr
, SCM_IM_BEGIN
);
941 unmemoize_begin (const SCM expr
, const SCM env
)
943 return scm_cons (scm_sym_begin
, unmemoize_exprs (SCM_CDR (expr
), env
));
947 SCM_SYNTAX (s_case
, "case", scm_i_makbimacro
, scm_m_case
);
948 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
949 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
952 scm_m_case (SCM expr
, SCM env
)
955 SCM all_labels
= SCM_EOL
;
957 /* Check, whether 'else is a literal, i. e. not bound to a value. */
958 const int else_literal_p
= literal_p (scm_sym_else
, env
);
960 const SCM cdr_expr
= SCM_CDR (expr
);
961 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
962 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_clauses
, expr
);
964 clauses
= SCM_CDR (cdr_expr
);
965 while (!scm_is_null (clauses
))
969 const SCM clause
= SCM_CAR (clauses
);
970 ASSERT_SYNTAX_2 (scm_ilength (clause
) >= 2,
971 s_bad_case_clause
, clause
, expr
);
973 labels
= SCM_CAR (clause
);
974 if (scm_is_pair (labels
))
976 ASSERT_SYNTAX_2 (scm_ilength (labels
) >= 0,
977 s_bad_case_labels
, labels
, expr
);
978 all_labels
= scm_append (scm_list_2 (labels
, all_labels
));
980 else if (scm_is_null (labels
))
982 /* The list of labels is empty. According to R5RS this is allowed.
983 * It means that the sequence of expressions will never be executed.
984 * Therefore, as an optimization, we could remove the whole
989 ASSERT_SYNTAX_2 (scm_is_eq (labels
, scm_sym_else
) && else_literal_p
,
990 s_bad_case_labels
, labels
, expr
);
991 ASSERT_SYNTAX_2 (scm_is_null (SCM_CDR (clauses
)),
992 s_misplaced_else_clause
, clause
, expr
);
995 /* build the new clause */
996 if (scm_is_eq (labels
, scm_sym_else
))
997 SCM_SETCAR (clause
, SCM_IM_ELSE
);
999 clauses
= SCM_CDR (clauses
);
1002 /* Check whether all case labels are distinct. */
1003 for (; !scm_is_null (all_labels
); all_labels
= SCM_CDR (all_labels
))
1005 const SCM label
= SCM_CAR (all_labels
);
1006 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (label
, SCM_CDR (all_labels
))),
1007 s_duplicate_case_label
, label
, expr
);
1010 SCM_SETCAR (expr
, SCM_IM_CASE
);
1015 unmemoize_case (const SCM expr
, const SCM env
)
1017 const SCM um_key_expr
= unmemoize_expression (SCM_CADR (expr
), env
);
1018 SCM um_clauses
= SCM_EOL
;
1021 for (clause_idx
= SCM_CDDR (expr
);
1022 !scm_is_null (clause_idx
);
1023 clause_idx
= SCM_CDR (clause_idx
))
1025 const SCM clause
= SCM_CAR (clause_idx
);
1026 const SCM labels
= SCM_CAR (clause
);
1027 const SCM exprs
= SCM_CDR (clause
);
1029 const SCM um_exprs
= unmemoize_exprs (exprs
, env
);
1030 const SCM um_labels
= (scm_is_eq (labels
, SCM_IM_ELSE
))
1032 : scm_i_finite_list_copy (labels
);
1033 const SCM um_clause
= scm_cons (um_labels
, um_exprs
);
1035 um_clauses
= scm_cons (um_clause
, um_clauses
);
1037 um_clauses
= scm_reverse_x (um_clauses
, SCM_UNDEFINED
);
1039 return scm_cons2 (scm_sym_case
, um_key_expr
, um_clauses
);
1043 SCM_SYNTAX (s_cond
, "cond", scm_i_makbimacro
, scm_m_cond
);
1044 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
1045 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
1048 scm_m_cond (SCM expr
, SCM env
)
1050 /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
1051 const int else_literal_p
= literal_p (scm_sym_else
, env
);
1052 const int arrow_literal_p
= literal_p (scm_sym_arrow
, env
);
1054 const SCM clauses
= SCM_CDR (expr
);
1057 ASSERT_SYNTAX (scm_ilength (clauses
) >= 0, s_bad_expression
, expr
);
1058 ASSERT_SYNTAX (scm_ilength (clauses
) >= 1, s_missing_clauses
, expr
);
1060 for (clause_idx
= clauses
;
1061 !scm_is_null (clause_idx
);
1062 clause_idx
= SCM_CDR (clause_idx
))
1066 const SCM clause
= SCM_CAR (clause_idx
);
1067 const long length
= scm_ilength (clause
);
1068 ASSERT_SYNTAX_2 (length
>= 1, s_bad_cond_clause
, clause
, expr
);
1070 test
= SCM_CAR (clause
);
1071 if (scm_is_eq (test
, scm_sym_else
) && else_literal_p
)
1073 const int last_clause_p
= scm_is_null (SCM_CDR (clause_idx
));
1074 ASSERT_SYNTAX_2 (length
>= 2,
1075 s_bad_cond_clause
, clause
, expr
);
1076 ASSERT_SYNTAX_2 (last_clause_p
,
1077 s_misplaced_else_clause
, clause
, expr
);
1078 SCM_SETCAR (clause
, SCM_IM_ELSE
);
1080 else if (length
>= 2
1081 && scm_is_eq (SCM_CADR (clause
), scm_sym_arrow
)
1084 ASSERT_SYNTAX_2 (length
> 2, s_missing_recipient
, clause
, expr
);
1085 ASSERT_SYNTAX_2 (length
== 3, s_extra_expression
, clause
, expr
);
1086 SCM_SETCAR (SCM_CDR (clause
), SCM_IM_ARROW
);
1090 SCM_SETCAR (expr
, SCM_IM_COND
);
1095 unmemoize_cond (const SCM expr
, const SCM env
)
1097 SCM um_clauses
= SCM_EOL
;
1100 for (clause_idx
= SCM_CDR (expr
);
1101 !scm_is_null (clause_idx
);
1102 clause_idx
= SCM_CDR (clause_idx
))
1104 const SCM clause
= SCM_CAR (clause_idx
);
1105 const SCM sequence
= SCM_CDR (clause
);
1106 const SCM test
= SCM_CAR (clause
);
1111 if (scm_is_eq (test
, SCM_IM_ELSE
))
1112 um_test
= scm_sym_else
;
1114 um_test
= unmemoize_expression (test
, env
);
1116 if (!scm_is_null (sequence
) && scm_is_eq (SCM_CAR (sequence
),
1119 const SCM target
= SCM_CADR (sequence
);
1120 const SCM um_target
= unmemoize_expression (target
, env
);
1121 um_sequence
= scm_list_2 (scm_sym_arrow
, um_target
);
1125 um_sequence
= unmemoize_exprs (sequence
, env
);
1128 um_clause
= scm_cons (um_test
, um_sequence
);
1129 um_clauses
= scm_cons (um_clause
, um_clauses
);
1131 um_clauses
= scm_reverse_x (um_clauses
, SCM_UNDEFINED
);
1133 return scm_cons (scm_sym_cond
, um_clauses
);
1137 SCM_SYNTAX (s_define
, "define", scm_i_makbimacro
, scm_m_define
);
1138 SCM_GLOBAL_SYMBOL (scm_sym_define
, s_define
);
1140 /* Guile provides an extension to R5RS' define syntax to represent function
1141 * currying in a compact way. With this extension, it is allowed to write
1142 * (define <nested-variable> <body>), where <nested-variable> has of one of
1143 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
1144 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
1145 * should be either a sequence of zero or more variables, or a sequence of one
1146 * or more variables followed by a space-delimited period and another
1147 * variable. Each level of argument nesting wraps the <body> within another
1148 * lambda expression. For example, the following forms are allowed, each one
1149 * followed by an equivalent, more explicit implementation.
1151 * (define ((a b . c) . d) <body>) is equivalent to
1152 * (define a (lambda (b . c) (lambda d <body>)))
1154 * (define (((a) b) c . d) <body>) is equivalent to
1155 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
1157 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
1158 * module that does not implement this extension. */
1160 canonicalize_define (const SCM expr
)
1165 const SCM cdr_expr
= SCM_CDR (expr
);
1166 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1167 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1169 body
= SCM_CDR (cdr_expr
);
1170 variable
= SCM_CAR (cdr_expr
);
1171 while (scm_is_pair (variable
))
1173 /* This while loop realizes function currying by variable nesting.
1174 * Variable is known to be a nested-variable. In every iteration of the
1175 * loop another level of lambda expression is created, starting with the
1176 * innermost one. Note that we don't check for duplicate formals here:
1177 * This will be done by the memoizer of the lambda expression. */
1178 const SCM formals
= SCM_CDR (variable
);
1179 const SCM tail
= scm_cons (formals
, body
);
1181 /* Add source properties to each new lambda expression: */
1182 const SCM lambda
= scm_cons_source (variable
, scm_sym_lambda
, tail
);
1184 body
= scm_list_1 (lambda
);
1185 variable
= SCM_CAR (variable
);
1187 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
1188 ASSERT_SYNTAX (scm_ilength (body
) == 1, s_expression
, expr
);
1190 SCM_SETCAR (cdr_expr
, variable
);
1191 SCM_SETCDR (cdr_expr
, body
);
1195 /* According to section 5.2.1 of R5RS we first have to make sure that the
1196 * variable is bound, and then perform the (set! variable expression)
1197 * operation. This means, that within the expression we may already assign
1198 * values to variable: (define foo (begin (set! foo 1) (+ foo 1))) */
1200 scm_m_define (SCM expr
, SCM env
)
1202 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), s_bad_define
, expr
);
1205 const SCM canonical_definition
= canonicalize_define (expr
);
1206 const SCM cdr_canonical_definition
= SCM_CDR (canonical_definition
);
1207 const SCM variable
= SCM_CAR (cdr_canonical_definition
);
1209 = scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_T
);
1210 const SCM value
= scm_eval_car (SCM_CDR (cdr_canonical_definition
), env
);
1212 if (SCM_REC_PROCNAMES_P
)
1215 while (SCM_MACROP (tmp
))
1216 tmp
= SCM_MACRO_CODE (tmp
);
1217 if (SCM_CLOSUREP (tmp
)
1218 /* Only the first definition determines the name. */
1219 && scm_is_false (scm_procedure_property (tmp
, scm_sym_name
)))
1220 scm_set_procedure_property_x (tmp
, scm_sym_name
, variable
);
1223 SCM_VARIABLE_SET (location
, value
);
1225 return SCM_UNSPECIFIED
;
1230 /* This is a helper function for forms (<keyword> <expression>) that are
1231 * transformed into (#@<keyword> '() <memoized_expression>) in order to allow
1232 * for easy creation of a thunk (i. e. a closure without arguments) using the
1233 * ('() <memoized_expression>) tail of the memoized form. */
1235 memoize_as_thunk_prototype (const SCM expr
, const SCM env SCM_UNUSED
)
1237 const SCM cdr_expr
= SCM_CDR (expr
);
1238 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1239 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1241 SCM_SETCDR (expr
, scm_cons (SCM_EOL
, cdr_expr
));
1247 SCM_SYNTAX (s_delay
, "delay", scm_i_makbimacro
, scm_m_delay
);
1248 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
1250 /* Promises are implemented as closures with an empty parameter list. Thus,
1251 * (delay <expression>) is transformed into (#@delay '() <expression>), where
1252 * the empty list represents the empty parameter list. This representation
1253 * allows for easy creation of the closure during evaluation. */
1255 scm_m_delay (SCM expr
, SCM env
)
1257 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1258 SCM_SETCAR (new_expr
, SCM_IM_DELAY
);
1263 unmemoize_delay (const SCM expr
, const SCM env
)
1265 const SCM thunk_expr
= SCM_CADDR (expr
);
1266 return scm_list_2 (scm_sym_delay
, unmemoize_expression (thunk_expr
, env
));
1270 SCM_SYNTAX(s_do
, "do", scm_i_makbimacro
, scm_m_do
);
1271 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
1273 /* DO gets the most radically altered syntax. The order of the vars is
1274 * reversed here. During the evaluation this allows for simple consing of the
1275 * results of the inits and steps:
1277 (do ((<var1> <init1> <step1>)
1285 (#@do (<init1> <init2> ... <initn>)
1286 (varn ... var2 var1)
1289 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
1292 scm_m_do (SCM expr
, SCM env SCM_UNUSED
)
1294 SCM variables
= SCM_EOL
;
1295 SCM init_forms
= SCM_EOL
;
1296 SCM step_forms
= SCM_EOL
;
1303 const SCM cdr_expr
= SCM_CDR (expr
);
1304 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1305 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1307 /* Collect variables, init and step forms. */
1308 binding_idx
= SCM_CAR (cdr_expr
);
1309 ASSERT_SYNTAX_2 (scm_ilength (binding_idx
) >= 0,
1310 s_bad_bindings
, binding_idx
, expr
);
1311 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1313 const SCM binding
= SCM_CAR (binding_idx
);
1314 const long length
= scm_ilength (binding
);
1315 ASSERT_SYNTAX_2 (length
== 2 || length
== 3,
1316 s_bad_binding
, binding
, expr
);
1319 const SCM name
= SCM_CAR (binding
);
1320 const SCM init
= SCM_CADR (binding
);
1321 const SCM step
= (length
== 2) ? name
: SCM_CADDR (binding
);
1322 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
1323 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, variables
)),
1324 s_duplicate_binding
, name
, expr
);
1326 variables
= scm_cons (name
, variables
);
1327 init_forms
= scm_cons (init
, init_forms
);
1328 step_forms
= scm_cons (step
, step_forms
);
1331 init_forms
= scm_reverse_x (init_forms
, SCM_UNDEFINED
);
1332 step_forms
= scm_reverse_x (step_forms
, SCM_UNDEFINED
);
1334 /* Memoize the test form and the exit sequence. */
1335 cddr_expr
= SCM_CDR (cdr_expr
);
1336 exit_clause
= SCM_CAR (cddr_expr
);
1337 ASSERT_SYNTAX_2 (scm_ilength (exit_clause
) >= 1,
1338 s_bad_exit_clause
, exit_clause
, expr
);
1340 commands
= SCM_CDR (cddr_expr
);
1341 tail
= scm_cons2 (exit_clause
, commands
, step_forms
);
1342 tail
= scm_cons2 (init_forms
, variables
, tail
);
1343 SCM_SETCAR (expr
, SCM_IM_DO
);
1344 SCM_SETCDR (expr
, tail
);
1349 unmemoize_do (const SCM expr
, const SCM env
)
1351 const SCM cdr_expr
= SCM_CDR (expr
);
1352 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1353 const SCM rnames
= SCM_CAR (cddr_expr
);
1354 const SCM extended_env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
1355 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
1356 const SCM exit_sequence
= SCM_CAR (cdddr_expr
);
1357 const SCM um_exit_sequence
= unmemoize_exprs (exit_sequence
, extended_env
);
1358 const SCM cddddr_expr
= SCM_CDR (cdddr_expr
);
1359 const SCM um_body
= unmemoize_exprs (SCM_CAR (cddddr_expr
), extended_env
);
1361 /* build transformed binding list */
1362 SCM um_names
= scm_reverse (rnames
);
1363 SCM um_inits
= unmemoize_exprs (SCM_CAR (cdr_expr
), env
);
1364 SCM um_steps
= unmemoize_exprs (SCM_CDR (cddddr_expr
), extended_env
);
1365 SCM um_bindings
= SCM_EOL
;
1366 while (!scm_is_null (um_names
))
1368 const SCM name
= SCM_CAR (um_names
);
1369 const SCM init
= SCM_CAR (um_inits
);
1370 SCM step
= SCM_CAR (um_steps
);
1371 step
= scm_is_eq (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
1373 um_bindings
= scm_cons (scm_cons2 (name
, init
, step
), um_bindings
);
1375 um_names
= SCM_CDR (um_names
);
1376 um_inits
= SCM_CDR (um_inits
);
1377 um_steps
= SCM_CDR (um_steps
);
1379 um_bindings
= scm_reverse_x (um_bindings
, SCM_UNDEFINED
);
1381 return scm_cons (scm_sym_do
,
1382 scm_cons2 (um_bindings
, um_exit_sequence
, um_body
));
1386 SCM_SYNTAX (s_if
, "if", scm_i_makbimacro
, scm_m_if
);
1387 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
1390 scm_m_if (SCM expr
, SCM env SCM_UNUSED
)
1392 const SCM cdr_expr
= SCM_CDR (expr
);
1393 const long length
= scm_ilength (cdr_expr
);
1394 ASSERT_SYNTAX (length
== 2 || length
== 3, s_expression
, expr
);
1395 SCM_SETCAR (expr
, SCM_IM_IF
);
1400 unmemoize_if (const SCM expr
, const SCM env
)
1402 const SCM cdr_expr
= SCM_CDR (expr
);
1403 const SCM um_condition
= unmemoize_expression (SCM_CAR (cdr_expr
), env
);
1404 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1405 const SCM um_then
= unmemoize_expression (SCM_CAR (cddr_expr
), env
);
1406 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
1408 if (scm_is_null (cdddr_expr
))
1410 return scm_list_3 (scm_sym_if
, um_condition
, um_then
);
1414 const SCM um_else
= unmemoize_expression (SCM_CAR (cdddr_expr
), env
);
1415 return scm_list_4 (scm_sym_if
, um_condition
, um_then
, um_else
);
1420 SCM_SYNTAX (s_lambda
, "lambda", scm_i_makbimacro
, scm_m_lambda
);
1421 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
1423 /* A helper function for memoize_lambda to support checking for duplicate
1424 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
1425 * LIST or to the cdr of the last cons. Therefore, LIST may have any of the
1426 * forms that a formal argument can have:
1427 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
1429 c_improper_memq (SCM obj
, SCM list
)
1431 for (; scm_is_pair (list
); list
= SCM_CDR (list
))
1433 if (scm_is_eq (SCM_CAR (list
), obj
))
1436 return scm_is_eq (list
, obj
);
1440 scm_m_lambda (SCM expr
, SCM env SCM_UNUSED
)
1449 const SCM cdr_expr
= SCM_CDR (expr
);
1450 const long length
= scm_ilength (cdr_expr
);
1451 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1452 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1454 /* Before iterating the list of formal arguments, make sure the formals
1455 * actually are given as either a symbol or a non-cyclic list. */
1456 formals
= SCM_CAR (cdr_expr
);
1457 if (scm_is_pair (formals
))
1459 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
1460 * detected, report a 'Bad formals' error. */
1464 ASSERT_SYNTAX_2 (scm_is_symbol (formals
) || scm_is_null (formals
),
1465 s_bad_formals
, formals
, expr
);
1468 /* Now iterate the list of formal arguments to check if all formals are
1469 * symbols, and that there are no duplicates. */
1470 formals_idx
= formals
;
1471 while (scm_is_pair (formals_idx
))
1473 const SCM formal
= SCM_CAR (formals_idx
);
1474 const SCM next_idx
= SCM_CDR (formals_idx
);
1475 ASSERT_SYNTAX_2 (scm_is_symbol (formal
), s_bad_formal
, formal
, expr
);
1476 ASSERT_SYNTAX_2 (!c_improper_memq (formal
, next_idx
),
1477 s_duplicate_formal
, formal
, expr
);
1478 formals_idx
= next_idx
;
1480 ASSERT_SYNTAX_2 (scm_is_null (formals_idx
) || scm_is_symbol (formals_idx
),
1481 s_bad_formal
, formals_idx
, expr
);
1483 /* Memoize the body. Keep a potential documentation string. */
1484 /* Dirk:FIXME:: We should probably extract the documentation string to
1485 * some external database. Otherwise it will slow down execution, since
1486 * the documentation string will have to be skipped with every execution
1487 * of the closure. */
1488 cddr_expr
= SCM_CDR (cdr_expr
);
1489 documentation
= (length
>= 3 && scm_is_string (SCM_CAR (cddr_expr
)));
1490 body
= documentation
? SCM_CDR (cddr_expr
) : cddr_expr
;
1491 new_body
= m_body (SCM_IM_LAMBDA
, body
);
1493 SCM_SETCAR (expr
, SCM_IM_LAMBDA
);
1495 SCM_SETCDR (cddr_expr
, new_body
);
1497 SCM_SETCDR (cdr_expr
, new_body
);
1502 unmemoize_lambda (const SCM expr
, const SCM env
)
1504 const SCM formals
= SCM_CADR (expr
);
1505 const SCM body
= SCM_CDDR (expr
);
1507 const SCM new_env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, env
);
1508 const SCM um_formals
= scm_i_finite_list_copy (formals
);
1509 const SCM um_body
= unmemoize_exprs (body
, new_env
);
1511 return scm_cons2 (scm_sym_lambda
, um_formals
, um_body
);
1515 /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
1517 check_bindings (const SCM bindings
, const SCM expr
)
1521 ASSERT_SYNTAX_2 (scm_ilength (bindings
) >= 0,
1522 s_bad_bindings
, bindings
, expr
);
1524 binding_idx
= bindings
;
1525 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1527 SCM name
; /* const */
1529 const SCM binding
= SCM_CAR (binding_idx
);
1530 ASSERT_SYNTAX_2 (scm_ilength (binding
) == 2,
1531 s_bad_binding
, binding
, expr
);
1533 name
= SCM_CAR (binding
);
1534 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
1539 /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
1540 * transformed to the lists (vn ... v2 v1) and (i1 i2 ... in). That is, the
1541 * variables are returned in a list with their order reversed, and the init
1542 * forms are returned in a list in the same order as they are given in the
1543 * bindings. If a duplicate variable name is detected, an error is
1546 transform_bindings (
1547 const SCM bindings
, const SCM expr
,
1548 SCM
*const rvarptr
, SCM
*const initptr
)
1550 SCM rvariables
= SCM_EOL
;
1551 SCM rinits
= SCM_EOL
;
1552 SCM binding_idx
= bindings
;
1553 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1555 const SCM binding
= SCM_CAR (binding_idx
);
1556 const SCM cdr_binding
= SCM_CDR (binding
);
1557 const SCM name
= SCM_CAR (binding
);
1558 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, rvariables
)),
1559 s_duplicate_binding
, name
, expr
);
1560 rvariables
= scm_cons (name
, rvariables
);
1561 rinits
= scm_cons (SCM_CAR (cdr_binding
), rinits
);
1563 *rvarptr
= rvariables
;
1564 *initptr
= scm_reverse_x (rinits
, SCM_UNDEFINED
);
1568 SCM_SYNTAX(s_let
, "let", scm_i_makbimacro
, scm_m_let
);
1569 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
1571 /* This function is a helper function for memoize_let. It transforms
1572 * (let name ((var init) ...) body ...) into
1573 * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
1574 * and memoizes the expression. It is assumed that the caller has checked
1575 * that name is a symbol and that there are bindings and a body. */
1577 memoize_named_let (const SCM expr
, const SCM env SCM_UNUSED
)
1583 const SCM cdr_expr
= SCM_CDR (expr
);
1584 const SCM name
= SCM_CAR (cdr_expr
);
1585 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1586 const SCM bindings
= SCM_CAR (cddr_expr
);
1587 check_bindings (bindings
, expr
);
1589 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1590 variables
= scm_reverse_x (rvariables
, SCM_UNDEFINED
);
1593 const SCM let_body
= SCM_CDR (cddr_expr
);
1594 const SCM lambda_body
= m_body (SCM_IM_LET
, let_body
);
1595 const SCM lambda_tail
= scm_cons (variables
, lambda_body
);
1596 const SCM lambda_form
= scm_cons_source (expr
, scm_sym_lambda
, lambda_tail
);
1598 const SCM rvar
= scm_list_1 (name
);
1599 const SCM init
= scm_list_1 (lambda_form
);
1600 const SCM body
= m_body (SCM_IM_LET
, scm_list_1 (name
));
1601 const SCM letrec_tail
= scm_cons (rvar
, scm_cons (init
, body
));
1602 const SCM letrec_form
= scm_cons_source (expr
, SCM_IM_LETREC
, letrec_tail
);
1603 return scm_cons_source (expr
, letrec_form
, inits
);
1607 /* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1608 * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
1610 scm_m_let (SCM expr
, SCM env
)
1614 const SCM cdr_expr
= SCM_CDR (expr
);
1615 const long length
= scm_ilength (cdr_expr
);
1616 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1617 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1619 bindings
= SCM_CAR (cdr_expr
);
1620 if (scm_is_symbol (bindings
))
1622 ASSERT_SYNTAX (length
>= 3, s_missing_expression
, expr
);
1623 return memoize_named_let (expr
, env
);
1626 check_bindings (bindings
, expr
);
1627 if (scm_is_null (bindings
) || scm_is_null (SCM_CDR (bindings
)))
1629 /* Special case: no bindings or single binding => let* is faster. */
1630 const SCM body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1631 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), bindings
, body
), env
);
1638 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1641 const SCM new_body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1642 const SCM new_tail
= scm_cons2 (rvariables
, inits
, new_body
);
1643 SCM_SETCAR (expr
, SCM_IM_LET
);
1644 SCM_SETCDR (expr
, new_tail
);
1651 build_binding_list (SCM rnames
, SCM rinits
)
1653 SCM bindings
= SCM_EOL
;
1654 while (!scm_is_null (rnames
))
1656 const SCM binding
= scm_list_2 (SCM_CAR (rnames
), SCM_CAR (rinits
));
1657 bindings
= scm_cons (binding
, bindings
);
1658 rnames
= SCM_CDR (rnames
);
1659 rinits
= SCM_CDR (rinits
);
1665 unmemoize_let (const SCM expr
, const SCM env
)
1667 const SCM cdr_expr
= SCM_CDR (expr
);
1668 const SCM um_rnames
= SCM_CAR (cdr_expr
);
1669 const SCM extended_env
= SCM_EXTEND_ENV (um_rnames
, SCM_EOL
, env
);
1670 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1671 const SCM um_inits
= unmemoize_exprs (SCM_CAR (cddr_expr
), env
);
1672 const SCM um_rinits
= scm_reverse_x (um_inits
, SCM_UNDEFINED
);
1673 const SCM um_bindings
= build_binding_list (um_rnames
, um_rinits
);
1674 const SCM um_body
= unmemoize_exprs (SCM_CDR (cddr_expr
), extended_env
);
1676 return scm_cons2 (scm_sym_let
, um_bindings
, um_body
);
1680 SCM_SYNTAX(s_letrec
, "letrec", scm_i_makbimacro
, scm_m_letrec
);
1681 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
1684 scm_m_letrec (SCM expr
, SCM env
)
1688 const SCM cdr_expr
= SCM_CDR (expr
);
1689 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1690 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1692 bindings
= SCM_CAR (cdr_expr
);
1693 if (scm_is_null (bindings
))
1695 /* no bindings, let* is executed faster */
1696 SCM body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1697 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), SCM_EOL
, body
), env
);
1705 check_bindings (bindings
, expr
);
1706 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1707 new_body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1708 return scm_cons2 (SCM_IM_LETREC
, rvariables
, scm_cons (inits
, new_body
));
1713 unmemoize_letrec (const SCM expr
, const SCM env
)
1715 const SCM cdr_expr
= SCM_CDR (expr
);
1716 const SCM um_rnames
= SCM_CAR (cdr_expr
);
1717 const SCM extended_env
= SCM_EXTEND_ENV (um_rnames
, SCM_EOL
, env
);
1718 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1719 const SCM um_inits
= unmemoize_exprs (SCM_CAR (cddr_expr
), extended_env
);
1720 const SCM um_rinits
= scm_reverse_x (um_inits
, SCM_UNDEFINED
);
1721 const SCM um_bindings
= build_binding_list (um_rnames
, um_rinits
);
1722 const SCM um_body
= unmemoize_exprs (SCM_CDR (cddr_expr
), extended_env
);
1724 return scm_cons2 (scm_sym_letrec
, um_bindings
, um_body
);
1729 SCM_SYNTAX (s_letstar
, "let*", scm_i_makbimacro
, scm_m_letstar
);
1730 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
1732 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1733 * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
1735 scm_m_letstar (SCM expr
, SCM env SCM_UNUSED
)
1740 const SCM cdr_expr
= SCM_CDR (expr
);
1741 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1742 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1744 binding_idx
= SCM_CAR (cdr_expr
);
1745 check_bindings (binding_idx
, expr
);
1747 /* Transform ((v1 i1) (v2 i2) ...) into (v1 i1 v2 i2 ...). The
1748 * transformation is done in place. At the beginning of one iteration of
1749 * the loop the variable binding_idx holds the form
1750 * P1:( (vn . P2:(in . ())) . P3:( (vn+1 in+1) ... ) ),
1751 * where P1, P2 and P3 indicate the pairs, that are relevant for the
1752 * transformation. P1 and P2 are modified in the loop, P3 remains
1753 * untouched. After the execution of the loop, P1 will hold
1754 * P1:( vn . P2:(in . P3:( (vn+1 in+1) ... )) )
1755 * and binding_idx will hold P3. */
1756 while (!scm_is_null (binding_idx
))
1758 const SCM cdr_binding_idx
= SCM_CDR (binding_idx
); /* remember P3 */
1759 const SCM binding
= SCM_CAR (binding_idx
);
1760 const SCM name
= SCM_CAR (binding
);
1761 const SCM cdr_binding
= SCM_CDR (binding
);
1763 SCM_SETCDR (cdr_binding
, cdr_binding_idx
); /* update P2 */
1764 SCM_SETCAR (binding_idx
, name
); /* update P1 */
1765 SCM_SETCDR (binding_idx
, cdr_binding
); /* update P1 */
1767 binding_idx
= cdr_binding_idx
; /* continue with P3 */
1770 new_body
= m_body (SCM_IM_LETSTAR
, SCM_CDR (cdr_expr
));
1771 SCM_SETCAR (expr
, SCM_IM_LETSTAR
);
1772 /* the bindings have been changed in place */
1773 SCM_SETCDR (cdr_expr
, new_body
);
1778 unmemoize_letstar (const SCM expr
, const SCM env
)
1780 const SCM cdr_expr
= SCM_CDR (expr
);
1781 const SCM body
= SCM_CDR (cdr_expr
);
1782 SCM bindings
= SCM_CAR (cdr_expr
);
1783 SCM um_bindings
= SCM_EOL
;
1784 SCM extended_env
= env
;
1787 while (!scm_is_null (bindings
))
1789 const SCM variable
= SCM_CAR (bindings
);
1790 const SCM init
= SCM_CADR (bindings
);
1791 const SCM um_init
= unmemoize_expression (init
, extended_env
);
1792 um_bindings
= scm_cons (scm_list_2 (variable
, um_init
), um_bindings
);
1793 extended_env
= SCM_EXTEND_ENV (variable
, SCM_BOOL_F
, extended_env
);
1794 bindings
= SCM_CDDR (bindings
);
1796 um_bindings
= scm_reverse_x (um_bindings
, SCM_UNDEFINED
);
1798 um_body
= unmemoize_exprs (body
, extended_env
);
1800 return scm_cons2 (scm_sym_letstar
, um_bindings
, um_body
);
1804 SCM_SYNTAX (s_or
, "or", scm_i_makbimacro
, scm_m_or
);
1805 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
1808 scm_m_or (SCM expr
, SCM env SCM_UNUSED
)
1810 const SCM cdr_expr
= SCM_CDR (expr
);
1811 const long length
= scm_ilength (cdr_expr
);
1813 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1817 /* Special case: (or) is replaced by #f. */
1822 SCM_SETCAR (expr
, SCM_IM_OR
);
1828 unmemoize_or (const SCM expr
, const SCM env
)
1830 return scm_cons (scm_sym_or
, unmemoize_exprs (SCM_CDR (expr
), env
));
1834 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
1835 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
1836 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
1837 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
1839 /* Internal function to handle a quasiquotation: 'form' is the parameter in
1840 * the call (quasiquotation form), 'env' is the environment where unquoted
1841 * expressions will be evaluated, and 'depth' is the current quasiquotation
1842 * nesting level and is known to be greater than zero. */
1844 iqq (SCM form
, SCM env
, unsigned long int depth
)
1846 if (scm_is_pair (form
))
1848 const SCM tmp
= SCM_CAR (form
);
1849 if (scm_is_eq (tmp
, scm_sym_quasiquote
))
1851 const SCM args
= SCM_CDR (form
);
1852 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1853 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
1855 else if (scm_is_eq (tmp
, scm_sym_unquote
))
1857 const SCM args
= SCM_CDR (form
);
1858 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1860 return scm_eval_car (args
, env
);
1862 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
1864 else if (scm_is_pair (tmp
)
1865 && scm_is_eq (SCM_CAR (tmp
), scm_sym_uq_splicing
))
1867 const SCM args
= SCM_CDR (tmp
);
1868 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1871 const SCM list
= scm_eval_car (args
, env
);
1872 const SCM rest
= SCM_CDR (form
);
1873 ASSERT_SYNTAX_2 (scm_ilength (list
) >= 0,
1874 s_splicing
, list
, form
);
1875 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
1878 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
1879 iqq (SCM_CDR (form
), env
, depth
));
1882 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
1883 iqq (SCM_CDR (form
), env
, depth
));
1885 else if (scm_is_vector (form
))
1886 return scm_vector (iqq (scm_vector_to_list (form
), env
, depth
));
1892 scm_m_quasiquote (SCM expr
, SCM env
)
1894 const SCM cdr_expr
= SCM_CDR (expr
);
1895 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1896 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1897 return iqq (SCM_CAR (cdr_expr
), env
, 1);
1901 SCM_SYNTAX (s_quote
, "quote", scm_i_makbimacro
, scm_m_quote
);
1902 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
1905 scm_m_quote (SCM expr
, SCM env SCM_UNUSED
)
1909 const SCM cdr_expr
= SCM_CDR (expr
);
1910 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1911 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1912 quotee
= SCM_CAR (cdr_expr
);
1913 if (is_self_quoting_p (quotee
))
1916 SCM_SETCAR (expr
, SCM_IM_QUOTE
);
1917 SCM_SETCDR (expr
, quotee
);
1922 unmemoize_quote (const SCM expr
, const SCM env SCM_UNUSED
)
1924 return scm_list_2 (scm_sym_quote
, SCM_CDR (expr
));
1928 /* Will go into the RnRS module when Guile is factorized.
1929 SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
1930 static const char s_set_x
[] = "set!";
1931 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, s_set_x
);
1934 scm_m_set_x (SCM expr
, SCM env SCM_UNUSED
)
1939 const SCM cdr_expr
= SCM_CDR (expr
);
1940 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1941 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1942 variable
= SCM_CAR (cdr_expr
);
1944 /* Memoize the variable form. */
1945 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
1946 new_variable
= lookup_symbol (variable
, env
);
1947 /* Leave the memoization of unbound symbols to lazy memoization: */
1948 if (SCM_UNBNDP (new_variable
))
1949 new_variable
= variable
;
1951 SCM_SETCAR (expr
, SCM_IM_SET_X
);
1952 SCM_SETCAR (cdr_expr
, new_variable
);
1957 unmemoize_set_x (const SCM expr
, const SCM env
)
1959 return scm_cons (scm_sym_set_x
, unmemoize_exprs (SCM_CDR (expr
), env
));
1963 /* Start of the memoizers for non-R5RS builtin macros. */
1966 SCM_SYNTAX (s_atapply
, "@apply", scm_i_makbimacro
, scm_m_apply
);
1967 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1968 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1971 scm_m_apply (SCM expr
, SCM env SCM_UNUSED
)
1973 const SCM cdr_expr
= SCM_CDR (expr
);
1974 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1975 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_missing_expression
, expr
);
1977 SCM_SETCAR (expr
, SCM_IM_APPLY
);
1982 unmemoize_apply (const SCM expr
, const SCM env
)
1984 return scm_list_2 (scm_sym_atapply
, unmemoize_exprs (SCM_CDR (expr
), env
));
1988 SCM_SYNTAX (s_atbind
, "@bind", scm_i_makbimacro
, scm_m_atbind
);
1990 /* FIXME: The following explanation should go into the documentation: */
1991 /* (@bind ((var init) ...) body ...) will assign the values of the `init's to
1992 * the global variables named by `var's (symbols, not evaluated), creating
1993 * them if they don't exist, executes body, and then restores the previous
1994 * values of the `var's. Additionally, whenever control leaves body, the
1995 * values of the `var's are saved and restored when control returns. It is an
1996 * error when a symbol appears more than once among the `var's. All `init's
1997 * are evaluated before any `var' is set.
1999 * Think of this as `let' for dynamic scope.
2002 /* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into
2003 * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...).
2005 * FIXME - also implement `@bind*'.
2008 scm_m_atbind (SCM expr
, SCM env
)
2015 const SCM top_level
= scm_env_top_level (env
);
2017 const SCM cdr_expr
= SCM_CDR (expr
);
2018 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2019 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
2020 bindings
= SCM_CAR (cdr_expr
);
2021 check_bindings (bindings
, expr
);
2022 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
2024 for (variable_idx
= rvariables
;
2025 !scm_is_null (variable_idx
);
2026 variable_idx
= SCM_CDR (variable_idx
))
2028 /* The first call to scm_sym2var will look beyond the current module,
2029 * while the second call wont. */
2030 const SCM variable
= SCM_CAR (variable_idx
);
2031 SCM new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_F
);
2032 if (scm_is_false (new_variable
))
2033 new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_T
);
2034 SCM_SETCAR (variable_idx
, new_variable
);
2037 SCM_SETCAR (expr
, SCM_IM_BIND
);
2038 SCM_SETCAR (cdr_expr
, scm_cons (rvariables
, inits
));
2043 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_i_makbimacro
, scm_m_cont
);
2044 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, s_atcall_cc
);
2047 scm_m_cont (SCM expr
, SCM env SCM_UNUSED
)
2049 const SCM cdr_expr
= SCM_CDR (expr
);
2050 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2051 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2053 SCM_SETCAR (expr
, SCM_IM_CONT
);
2058 unmemoize_atcall_cc (const SCM expr
, const SCM env
)
2060 return scm_list_2 (scm_sym_atcall_cc
, unmemoize_exprs (SCM_CDR (expr
), env
));
2064 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_i_makbimacro
, scm_m_at_call_with_values
);
2065 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
2068 scm_m_at_call_with_values (SCM expr
, SCM env SCM_UNUSED
)
2070 const SCM cdr_expr
= SCM_CDR (expr
);
2071 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2072 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2074 SCM_SETCAR (expr
, SCM_IM_CALL_WITH_VALUES
);
2079 unmemoize_at_call_with_values (const SCM expr
, const SCM env
)
2081 return scm_list_2 (scm_sym_at_call_with_values
,
2082 unmemoize_exprs (SCM_CDR (expr
), env
));
2086 SCM_SYNTAX (s_future
, "future", scm_i_makbimacro
, scm_m_future
);
2087 SCM_GLOBAL_SYMBOL (scm_sym_future
, s_future
);
2089 /* Like promises, futures are implemented as closures with an empty
2090 * parameter list. Thus, (future <expression>) is transformed into
2091 * (#@future '() <expression>), where the empty list represents the
2092 * empty parameter list. This representation allows for easy creation
2093 * of the closure during evaluation. */
2095 scm_m_future (SCM expr
, SCM env
)
2097 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
2098 SCM_SETCAR (new_expr
, SCM_IM_FUTURE
);
2103 unmemoize_future (const SCM expr
, const SCM env
)
2105 const SCM thunk_expr
= SCM_CADDR (expr
);
2106 return scm_list_2 (scm_sym_future
, unmemoize_expression (thunk_expr
, env
));
2110 SCM_SYNTAX (s_gset_x
, "set!", scm_i_makbimacro
, scm_m_generalized_set_x
);
2111 SCM_SYMBOL (scm_sym_setter
, "setter");
2114 scm_m_generalized_set_x (SCM expr
, SCM env
)
2116 SCM target
, exp_target
;
2118 const SCM cdr_expr
= SCM_CDR (expr
);
2119 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2120 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2122 target
= SCM_CAR (cdr_expr
);
2123 if (!scm_is_pair (target
))
2126 return scm_m_set_x (expr
, env
);
2130 /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */
2131 /* Macroexpanding the target might return things of the form
2132 (begin <atom>). In that case, <atom> must be a symbol or a
2133 variable and we memoize to (set! <atom> ...).
2135 exp_target
= macroexp (target
, env
);
2136 if (scm_is_eq (SCM_CAR (exp_target
), SCM_IM_BEGIN
)
2137 && !scm_is_null (SCM_CDR (exp_target
))
2138 && scm_is_null (SCM_CDDR (exp_target
)))
2140 exp_target
= SCM_CADR (exp_target
);
2141 ASSERT_SYNTAX_2 (scm_is_symbol (exp_target
)
2142 || SCM_VARIABLEP (exp_target
),
2143 s_bad_variable
, exp_target
, expr
);
2144 return scm_cons (SCM_IM_SET_X
, scm_cons (exp_target
,
2145 SCM_CDR (cdr_expr
)));
2149 const SCM setter_proc_tail
= scm_list_1 (SCM_CAR (target
));
2150 const SCM setter_proc
= scm_cons_source (expr
, scm_sym_setter
,
2153 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
2154 const SCM setter_args
= scm_append_x (scm_list_2 (SCM_CDR (target
),
2157 SCM_SETCAR (expr
, setter_proc
);
2158 SCM_SETCDR (expr
, setter_args
);
2165 /* @slot-ref is bound privately in the (oop goops) module from goops.c. As
2166 * soon as the module system allows us to more freely create bindings in
2167 * arbitrary modules during the startup phase, the code from goops.c should be
2170 SCM_SYMBOL (sym_atslot_ref
, "@slot-ref");
2173 scm_m_atslot_ref (SCM expr
, SCM env SCM_UNUSED
)
2177 const SCM cdr_expr
= SCM_CDR (expr
);
2178 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2179 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2180 slot_nr
= SCM_CADR (cdr_expr
);
2181 ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2183 SCM_SETCAR (expr
, SCM_IM_SLOT_REF
);
2184 SCM_SETCDR (cdr_expr
, slot_nr
);
2189 unmemoize_atslot_ref (const SCM expr
, const SCM env
)
2191 const SCM instance
= SCM_CADR (expr
);
2192 const SCM um_instance
= unmemoize_expression (instance
, env
);
2193 const SCM slot_nr
= SCM_CDDR (expr
);
2194 return scm_list_3 (sym_atslot_ref
, um_instance
, slot_nr
);
2198 /* @slot-set! is bound privately in the (oop goops) module from goops.c. As
2199 * soon as the module system allows us to more freely create bindings in
2200 * arbitrary modules during the startup phase, the code from goops.c should be
2203 SCM_SYMBOL (sym_atslot_set_x
, "@slot-set!");
2206 scm_m_atslot_set_x (SCM expr
, SCM env SCM_UNUSED
)
2210 const SCM cdr_expr
= SCM_CDR (expr
);
2211 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2212 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 3, s_expression
, expr
);
2213 slot_nr
= SCM_CADR (cdr_expr
);
2214 ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2216 SCM_SETCAR (expr
, SCM_IM_SLOT_SET_X
);
2221 unmemoize_atslot_set_x (const SCM expr
, const SCM env
)
2223 const SCM cdr_expr
= SCM_CDR (expr
);
2224 const SCM instance
= SCM_CAR (cdr_expr
);
2225 const SCM um_instance
= unmemoize_expression (instance
, env
);
2226 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
2227 const SCM slot_nr
= SCM_CAR (cddr_expr
);
2228 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
2229 const SCM value
= SCM_CAR (cdddr_expr
);
2230 const SCM um_value
= unmemoize_expression (value
, env
);
2231 return scm_list_4 (sym_atslot_set_x
, um_instance
, slot_nr
, um_value
);
2235 #if SCM_ENABLE_ELISP
2237 static const char s_defun
[] = "Symbol's function definition is void";
2239 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_i_makbimacro
, scm_m_nil_cond
);
2241 /* nil-cond expressions have the form
2242 * (nil-cond COND VAL COND VAL ... ELSEVAL) */
2244 scm_m_nil_cond (SCM expr
, SCM env SCM_UNUSED
)
2246 const long length
= scm_ilength (SCM_CDR (expr
));
2247 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
2248 ASSERT_SYNTAX (length
>= 1 && (length
% 2) == 1, s_expression
, expr
);
2250 SCM_SETCAR (expr
, SCM_IM_NIL_COND
);
2255 SCM_SYNTAX (s_atfop
, "@fop", scm_i_makbimacro
, scm_m_atfop
);
2257 /* The @fop-macro handles procedure and macro applications for elisp. The
2258 * input expression must have the form
2259 * (@fop <var> (transformer-macro <expr> ...))
2260 * where <var> must be a symbol. The expression is transformed into the
2261 * memoized form of either
2262 * (apply <un-aliased var> (transformer-macro <expr> ...))
2263 * if the value of var (across all aliasing) is not a macro, or
2264 * (<un-aliased var> <expr> ...)
2265 * if var is a macro. */
2267 scm_m_atfop (SCM expr
, SCM env SCM_UNUSED
)
2272 const SCM cdr_expr
= SCM_CDR (expr
);
2273 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2274 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 1, s_missing_expression
, expr
);
2276 symbol
= SCM_CAR (cdr_expr
);
2277 ASSERT_SYNTAX_2 (scm_is_symbol (symbol
), s_bad_variable
, symbol
, expr
);
2279 location
= scm_symbol_fref (symbol
);
2280 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2282 /* The elisp function `defalias' allows to define aliases for symbols. To
2283 * look up such definitions, the chain of symbol definitions has to be
2284 * followed up to the terminal symbol. */
2285 while (scm_is_symbol (SCM_VARIABLE_REF (location
)))
2287 const SCM alias
= SCM_VARIABLE_REF (location
);
2288 location
= scm_symbol_fref (alias
);
2289 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2292 /* Memoize the value location belonging to the terminal symbol. */
2293 SCM_SETCAR (cdr_expr
, location
);
2295 if (!SCM_MACROP (SCM_VARIABLE_REF (location
)))
2297 /* Since the location does not contain a macro, the form is a procedure
2298 * application. Replace `@fop' by `@apply' and transform the expression
2299 * including the `transformer-macro'. */
2300 SCM_SETCAR (expr
, SCM_IM_APPLY
);
2305 /* Since the location contains a macro, the arguments should not be
2306 * transformed, so the `transformer-macro' is cut out. The resulting
2307 * expression starts with the memoized variable, that is at the cdr of
2308 * the input expression. */
2309 SCM_SETCDR (cdr_expr
, SCM_CDADR (cdr_expr
));
2314 #endif /* SCM_ENABLE_ELISP */
2318 unmemoize_builtin_macro (const SCM expr
, const SCM env
)
2320 switch (ISYMNUM (SCM_CAR (expr
)))
2322 case (ISYMNUM (SCM_IM_AND
)):
2323 return unmemoize_and (expr
, env
);
2325 case (ISYMNUM (SCM_IM_BEGIN
)):
2326 return unmemoize_begin (expr
, env
);
2328 case (ISYMNUM (SCM_IM_CASE
)):
2329 return unmemoize_case (expr
, env
);
2331 case (ISYMNUM (SCM_IM_COND
)):
2332 return unmemoize_cond (expr
, env
);
2334 case (ISYMNUM (SCM_IM_DELAY
)):
2335 return unmemoize_delay (expr
, env
);
2337 case (ISYMNUM (SCM_IM_DO
)):
2338 return unmemoize_do (expr
, env
);
2340 case (ISYMNUM (SCM_IM_IF
)):
2341 return unmemoize_if (expr
, env
);
2343 case (ISYMNUM (SCM_IM_LAMBDA
)):
2344 return unmemoize_lambda (expr
, env
);
2346 case (ISYMNUM (SCM_IM_LET
)):
2347 return unmemoize_let (expr
, env
);
2349 case (ISYMNUM (SCM_IM_LETREC
)):
2350 return unmemoize_letrec (expr
, env
);
2352 case (ISYMNUM (SCM_IM_LETSTAR
)):
2353 return unmemoize_letstar (expr
, env
);
2355 case (ISYMNUM (SCM_IM_OR
)):
2356 return unmemoize_or (expr
, env
);
2358 case (ISYMNUM (SCM_IM_QUOTE
)):
2359 return unmemoize_quote (expr
, env
);
2361 case (ISYMNUM (SCM_IM_SET_X
)):
2362 return unmemoize_set_x (expr
, env
);
2364 case (ISYMNUM (SCM_IM_APPLY
)):
2365 return unmemoize_apply (expr
, env
);
2367 case (ISYMNUM (SCM_IM_BIND
)):
2368 return unmemoize_exprs (expr
, env
); /* FIXME */
2370 case (ISYMNUM (SCM_IM_CONT
)):
2371 return unmemoize_atcall_cc (expr
, env
);
2373 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2374 return unmemoize_at_call_with_values (expr
, env
);
2376 case (ISYMNUM (SCM_IM_FUTURE
)):
2377 return unmemoize_future (expr
, env
);
2379 case (ISYMNUM (SCM_IM_SLOT_REF
)):
2380 return unmemoize_atslot_ref (expr
, env
);
2382 case (ISYMNUM (SCM_IM_SLOT_SET_X
)):
2383 return unmemoize_atslot_set_x (expr
, env
);
2385 case (ISYMNUM (SCM_IM_NIL_COND
)):
2386 return unmemoize_exprs (expr
, env
); /* FIXME */
2389 return unmemoize_exprs (expr
, env
); /* FIXME */
2394 /* scm_i_unmemocopy_expr and scm_i_unmemocopy_body take a memoized expression
2395 * respectively a memoized body together with its environment and rewrite it
2396 * to its original form. Thus, these functions are the inversion of the
2397 * rewrite rules above. The procedure is not optimized for speed. It's used
2398 * in scm_i_unmemoize_expr, scm_procedure_source, macro_print and scm_iprin1.
2400 * Unmemoizing is not a reliable process. You cannot in general expect to get
2401 * the original source back.
2403 * However, GOOPS currently relies on this for method compilation. This ought
2407 scm_i_unmemocopy_expr (SCM expr
, SCM env
)
2409 const SCM source_properties
= scm_whash_lookup (scm_source_whash
, expr
);
2410 const SCM um_expr
= unmemoize_expression (expr
, env
);
2412 if (scm_is_true (source_properties
))
2413 scm_whash_insert (scm_source_whash
, um_expr
, source_properties
);
2419 scm_i_unmemocopy_body (SCM forms
, SCM env
)
2421 const SCM source_properties
= scm_whash_lookup (scm_source_whash
, forms
);
2422 const SCM um_forms
= unmemoize_exprs (forms
, env
);
2424 if (scm_is_true (source_properties
))
2425 scm_whash_insert (scm_source_whash
, um_forms
, source_properties
);
2431 #if (SCM_ENABLE_DEPRECATED == 1)
2433 /* Deprecated in guile 1.7.0 on 2003-11-09. */
2435 scm_m_expand_body (SCM exprs
, SCM env
)
2437 scm_c_issue_deprecation_warning
2438 ("`scm_m_expand_body' is deprecated.");
2439 m_expand_body (exprs
, env
);
2444 SCM_SYNTAX (s_undefine
, "undefine", scm_makacro
, scm_m_undefine
);
2447 scm_m_undefine (SCM expr
, SCM env
)
2452 const SCM cdr_expr
= SCM_CDR (expr
);
2453 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), "Bad undefine placement in", expr
);
2454 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2455 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2457 scm_c_issue_deprecation_warning
2458 ("`undefine' is deprecated.\n");
2460 variable
= SCM_CAR (cdr_expr
);
2461 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
2462 location
= scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_F
);
2463 ASSERT_SYNTAX_2 (scm_is_true (location
)
2464 && !SCM_UNBNDP (SCM_VARIABLE_REF (location
)),
2465 "variable already unbound ", variable
, expr
);
2466 SCM_VARIABLE_SET (location
, SCM_UNDEFINED
);
2467 return SCM_UNSPECIFIED
;
2471 scm_macroexp (SCM x
, SCM env
)
2473 scm_c_issue_deprecation_warning
2474 ("`scm_macroexp' is deprecated.");
2475 return macroexp (x
, env
);
2481 #if (SCM_ENABLE_DEPRECATED == 1)
2484 scm_unmemocar (SCM form
, SCM env
)
2486 scm_c_issue_deprecation_warning
2487 ("`scm_unmemocar' is deprecated.");
2489 if (!scm_is_pair (form
))
2493 SCM c
= SCM_CAR (form
);
2494 if (SCM_VARIABLEP (c
))
2496 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
2497 if (scm_is_false (sym
))
2498 sym
= sym_three_question_marks
;
2499 SCM_SETCAR (form
, sym
);
2501 else if (SCM_ILOCP (c
))
2503 unsigned long int ir
;
2505 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
2506 env
= SCM_CDR (env
);
2507 env
= SCM_CAAR (env
);
2508 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
2509 env
= SCM_CDR (env
);
2511 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
2519 /*****************************************************************************/
2520 /*****************************************************************************/
2521 /* The definitions for execution start here. */
2522 /*****************************************************************************/
2523 /*****************************************************************************/
2525 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
2526 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
2527 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
2528 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
2530 /* A function object to implement "apply" for non-closure functions. */
2532 /* An endless list consisting of #<undefined> objects: */
2533 static SCM undefineds
;
2537 scm_badargsp (SCM formals
, SCM args
)
2539 while (!scm_is_null (formals
))
2541 if (!scm_is_pair (formals
))
2543 if (scm_is_null (args
))
2545 formals
= SCM_CDR (formals
);
2546 args
= SCM_CDR (args
);
2548 return !scm_is_null (args
) ? 1 : 0;
2553 /* The evaluator contains a plethora of EVAL symbols. This is an attempt at
2556 * The following macros should be used in code which is read twice (where the
2557 * choice of evaluator is hard soldered):
2559 * CEVAL is the symbol used within one evaluator to call itself.
2560 * Originally, it is defined to ceval, but is redefined to deval during the
2563 * SCM_I_EVALIM is used when it is known that the expression is an
2564 * immediate. (This macro never calls an evaluator.)
2566 * EVAL evaluates an expression that is expected to have its symbols already
2567 * memoized. Expressions that are not of the form '(<form> <form> ...)' are
2568 * evaluated inline without calling an evaluator.
2570 * EVALCAR evaluates the car of an expression 'X:(Y:<form> <form> ...)',
2571 * potentially replacing a symbol at the position Y:<form> by its memoized
2572 * variable. If Y:<form> is not of the form '(<form> <form> ...)', the
2573 * evaluation is performed inline without calling an evaluator.
2575 * The following macros should be used in code which is read once
2576 * (where the choice of evaluator is dynamic):
2578 * SCM_I_XEVAL corresponds to EVAL, but uses ceval *or* deval depending on the
2581 * SCM_I_XEVALCAR corresponds to EVALCAR, but uses ceval *or* deval depending
2582 * on the debugging mode.
2584 * The main motivation for keeping this plethora is efficiency
2585 * together with maintainability (=> locality of code).
2588 static SCM
ceval (SCM x
, SCM env
);
2589 static SCM
deval (SCM x
, SCM env
);
2593 #define SCM_I_EVALIM2(x) \
2594 ((scm_is_eq ((x), SCM_EOL) \
2595 ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \
2599 #define SCM_I_EVALIM(x, env) (SCM_ILOCP (x) \
2600 ? *scm_ilookup ((x), (env)) \
2603 #define SCM_I_XEVAL(x, env) \
2605 ? SCM_I_EVALIM2 (x) \
2606 : (SCM_VARIABLEP (x) \
2607 ? SCM_VARIABLE_REF (x) \
2608 : (scm_is_pair (x) \
2609 ? (scm_debug_mode_p \
2610 ? deval ((x), (env)) \
2611 : ceval ((x), (env))) \
2614 #define SCM_I_XEVALCAR(x, env) \
2615 (SCM_IMP (SCM_CAR (x)) \
2616 ? SCM_I_EVALIM (SCM_CAR (x), (env)) \
2617 : (SCM_VARIABLEP (SCM_CAR (x)) \
2618 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2619 : (scm_is_pair (SCM_CAR (x)) \
2620 ? (scm_debug_mode_p \
2621 ? deval (SCM_CAR (x), (env)) \
2622 : ceval (SCM_CAR (x), (env))) \
2623 : (!scm_is_symbol (SCM_CAR (x)) \
2625 : *scm_lookupcar ((x), (env), 1)))))
2627 #define EVAL(x, env) \
2629 ? SCM_I_EVALIM ((x), (env)) \
2630 : (SCM_VARIABLEP (x) \
2631 ? SCM_VARIABLE_REF (x) \
2632 : (scm_is_pair (x) \
2633 ? CEVAL ((x), (env)) \
2636 #define EVALCAR(x, env) \
2637 (SCM_IMP (SCM_CAR (x)) \
2638 ? SCM_I_EVALIM (SCM_CAR (x), (env)) \
2639 : (SCM_VARIABLEP (SCM_CAR (x)) \
2640 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2641 : (scm_is_pair (SCM_CAR (x)) \
2642 ? CEVAL (SCM_CAR (x), (env)) \
2643 : (!scm_is_symbol (SCM_CAR (x)) \
2645 : *scm_lookupcar ((x), (env), 1)))))
2647 scm_i_pthread_mutex_t source_mutex
= SCM_I_PTHREAD_RECURSIVE_MUTEX_INITIALIZER
;
2650 /* Lookup a given local variable in an environment. The local variable is
2651 * given as an iloc, that is a triple <frame, binding, last?>, where frame
2652 * indicates the relative number of the environment frame (counting upwards
2653 * from the innermost environment frame), binding indicates the number of the
2654 * binding within the frame, and last? (which is extracted from the iloc using
2655 * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
2656 * very end of the improper list of bindings. */
2658 scm_ilookup (SCM iloc
, SCM env
)
2660 unsigned int frame_nr
= SCM_IFRAME (iloc
);
2661 unsigned int binding_nr
= SCM_IDIST (iloc
);
2665 for (; 0 != frame_nr
; --frame_nr
)
2666 frames
= SCM_CDR (frames
);
2668 bindings
= SCM_CAR (frames
);
2669 for (; 0 != binding_nr
; --binding_nr
)
2670 bindings
= SCM_CDR (bindings
);
2672 if (SCM_ICDRP (iloc
))
2673 return SCM_CDRLOC (bindings
);
2674 return SCM_CARLOC (SCM_CDR (bindings
));
2678 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
2680 static void error_unbound_variable (SCM symbol
) SCM_NORETURN
;
2681 static void error_defined_variable (SCM symbol
) SCM_NORETURN
;
2683 /* Call this for variables that are unfound.
2686 error_unbound_variable (SCM symbol
)
2688 scm_error (scm_unbound_variable_key
, NULL
,
2689 "Unbound variable: ~S",
2690 scm_list_1 (symbol
), SCM_BOOL_F
);
2693 /* Call this for variables that are found but contain SCM_UNDEFINED.
2696 error_defined_variable (SCM symbol
)
2698 /* We use the 'unbound-variable' key here as well, since it
2699 basically is the same kind of error, with a slight variation in
2700 the displayed message.
2702 scm_error (scm_unbound_variable_key
, NULL
,
2703 "Variable used before given a value: ~S",
2704 scm_list_1 (symbol
), SCM_BOOL_F
);
2708 /* The Lookup Car Race
2711 Memoization of variables and special forms is done while executing
2712 the code for the first time. As long as there is only one thread
2713 everything is fine, but as soon as two threads execute the same
2714 code concurrently `for the first time' they can come into conflict.
2716 This memoization includes rewriting variable references into more
2717 efficient forms and expanding macros. Furthermore, macro expansion
2718 includes `compiling' special forms like `let', `cond', etc. into
2719 tree-code instructions.
2721 There shouldn't normally be a problem with memoizing local and
2722 global variable references (into ilocs and variables), because all
2723 threads will mutate the code in *exactly* the same way and (if I
2724 read the C code correctly) it is not possible to observe a half-way
2725 mutated cons cell. The lookup procedure can handle this
2726 transparently without any critical sections.
2728 It is different with macro expansion, because macro expansion
2729 happens outside of the lookup procedure and can't be
2730 undone. Therefore the lookup procedure can't cope with it. It has
2731 to indicate failure when it detects a lost race and hope that the
2732 caller can handle it. Luckily, it turns out that this is the case.
2734 An example to illustrate this: Suppose that the following form will
2735 be memoized concurrently by two threads
2739 Let's first examine the lookup of X in the body. The first thread
2740 decides that it has to find the symbol "x" in the environment and
2741 starts to scan it. Then the other thread takes over and actually
2742 overtakes the first. It looks up "x" and substitutes an
2743 appropriate iloc for it. Now the first thread continues and
2744 completes its lookup. It comes to exactly the same conclusions as
2745 the second one and could - without much ado - just overwrite the
2746 iloc with the same iloc.
2748 But let's see what will happen when the race occurs while looking
2749 up the symbol "let" at the start of the form. It could happen that
2750 the second thread interrupts the lookup of the first thread and not
2751 only substitutes a variable for it but goes right ahead and
2752 replaces it with the compiled form (#@let* (x 12) x). Now, when
2753 the first thread completes its lookup, it would replace the #@let*
2754 with a variable containing the "let" binding, effectively reverting
2755 the form to (let (x 12) x). This is wrong. It has to detect that
2756 it has lost the race and the evaluator has to reconsider the
2757 changed form completely.
2759 This race condition could be resolved with some kind of traffic
2760 light (like mutexes) around scm_lookupcar, but I think that it is
2761 best to avoid them in this case. They would serialize memoization
2762 completely and because lookup involves calling arbitrary Scheme
2763 code (via the lookup-thunk), threads could be blocked for an
2764 arbitrary amount of time or even deadlock. But with the current
2765 solution a lot of unnecessary work is potentially done. */
2767 /* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
2768 return NULL to indicate a failed lookup due to some race conditions
2769 between threads. This only happens when VLOC is the first cell of
2770 a special form that will eventually be memoized (like `let', etc.)
2771 In that case the whole lookup is bogus and the caller has to
2772 reconsider the complete special form.
2774 SCM_LOOKUPCAR is still there, of course. It just calls
2775 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
2776 should only be called when it is known that VLOC is not the first
2777 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
2778 for NULL. I think I've found the only places where this
2782 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
2785 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
2786 register SCM iloc
= SCM_ILOC00
;
2787 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
2789 if (!scm_is_pair (SCM_CAR (env
)))
2791 al
= SCM_CARLOC (env
);
2792 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
2794 if (!scm_is_pair (fl
))
2796 if (scm_is_eq (fl
, var
))
2798 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2800 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
2801 return SCM_CDRLOC (*al
);
2806 al
= SCM_CDRLOC (*al
);
2807 if (scm_is_eq (SCM_CAR (fl
), var
))
2809 if (SCM_UNBNDP (SCM_CAR (*al
)))
2810 error_defined_variable (var
);
2811 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2813 SCM_SETCAR (vloc
, iloc
);
2814 return SCM_CARLOC (*al
);
2816 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
2818 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
2821 SCM top_thunk
, real_var
;
2824 top_thunk
= SCM_CAR (env
); /* env now refers to a
2825 top level env thunk */
2826 env
= SCM_CDR (env
);
2829 top_thunk
= SCM_BOOL_F
;
2830 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
2831 if (scm_is_false (real_var
))
2834 if (!scm_is_null (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
2839 if (scm_is_null (env
))
2840 error_unbound_variable (var
);
2842 scm_misc_error (NULL
, "Damaged environment: ~S",
2847 /* A variable could not be found, but we shall
2848 not throw an error. */
2849 static SCM undef_object
= SCM_UNDEFINED
;
2850 return &undef_object
;
2854 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2856 /* Some other thread has changed the very cell we are working
2857 on. In effect, it must have done our job or messed it up
2860 var
= SCM_CAR (vloc
);
2861 if (SCM_VARIABLEP (var
))
2862 return SCM_VARIABLE_LOC (var
);
2863 if (SCM_ILOCP (var
))
2864 return scm_ilookup (var
, genv
);
2865 /* We can't cope with anything else than variables and ilocs. When
2866 a special form has been memoized (i.e. `let' into `#@let') we
2867 return NULL and expect the calling function to do the right
2868 thing. For the evaluator, this means going back and redoing
2869 the dispatch on the car of the form. */
2873 SCM_SETCAR (vloc
, real_var
);
2874 return SCM_VARIABLE_LOC (real_var
);
2879 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
2881 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
2888 /* During execution, look up a symbol in the top level of the given local
2889 * environment and return the corresponding variable object. If no binding
2890 * for the symbol can be found, an 'Unbound variable' error is signalled. */
2892 lazy_memoize_variable (const SCM symbol
, const SCM environment
)
2894 const SCM top_level
= scm_env_top_level (environment
);
2895 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
2897 if (scm_is_false (variable
))
2898 error_unbound_variable (symbol
);
2905 scm_eval_car (SCM pair
, SCM env
)
2907 return SCM_I_XEVALCAR (pair
, env
);
2912 scm_eval_args (SCM l
, SCM env
, SCM proc
)
2914 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
2915 while (scm_is_pair (l
))
2917 res
= EVALCAR (l
, env
);
2919 *lloc
= scm_list_1 (res
);
2920 lloc
= SCM_CDRLOC (*lloc
);
2923 if (!scm_is_null (l
))
2924 scm_wrong_num_args (proc
);
2930 scm_eval_body (SCM code
, SCM env
)
2935 next
= SCM_CDR (code
);
2936 while (!scm_is_null (next
))
2938 if (SCM_IMP (SCM_CAR (code
)))
2940 if (SCM_ISYMP (SCM_CAR (code
)))
2942 scm_i_scm_pthread_mutex_lock (&source_mutex
);
2943 /* check for race condition */
2944 if (SCM_ISYMP (SCM_CAR (code
)))
2945 m_expand_body (code
, env
);
2946 scm_i_pthread_mutex_unlock (&source_mutex
);
2951 SCM_I_XEVAL (SCM_CAR (code
), env
);
2953 next
= SCM_CDR (code
);
2955 return SCM_I_XEVALCAR (code
, env
);
2961 /* SECTION: This code is specific for the debugging support. One
2962 * branch is read when DEVAL isn't defined, the other when DEVAL is
2968 #define SCM_APPLY scm_apply
2969 #define PREP_APPLY(proc, args)
2971 #define RETURN(x) do { return x; } while (0)
2972 #ifdef STACK_CHECKING
2973 #ifndef NO_CEVAL_STACK_CHECKING
2974 #define EVAL_STACK_CHECKING
2981 #define CEVAL deval /* Substitute all uses of ceval */
2984 #define SCM_APPLY scm_dapply
2987 #define PREP_APPLY(p, l) \
2988 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
2991 #define ENTER_APPLY \
2993 SCM_SET_ARGSREADY (debug);\
2994 if (scm_check_apply_p && SCM_TRAPS_P)\
2995 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
2997 SCM tmp, tail = scm_from_bool(SCM_TRACED_FRAME_P (debug)); \
2998 SCM_SET_TRACED_FRAME (debug); \
3000 if (SCM_CHEAPTRAPS_P)\
3002 tmp = scm_make_debugobj (&debug);\
3003 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
3008 tmp = scm_make_continuation (&first);\
3010 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
3017 #define RETURN(e) do { proc = (e); goto exit; } while (0)
3019 #ifdef STACK_CHECKING
3020 #ifndef EVAL_STACK_CHECKING
3021 #define EVAL_STACK_CHECKING
3026 /* scm_last_debug_frame contains a pointer to the last debugging information
3027 * stack frame. It is accessed very often from the debugging evaluator, so it
3028 * should probably not be indirectly addressed. Better to save and restore it
3029 * from the current root at any stack swaps.
3032 /* scm_debug_eframe_size is the number of slots available for pseudo
3033 * stack frames at each real stack frame.
3036 long scm_debug_eframe_size
;
3038 int scm_debug_mode_p
;
3039 int scm_check_entry_p
;
3040 int scm_check_apply_p
;
3041 int scm_check_exit_p
;
3043 long scm_eval_stack
;
3045 scm_t_option scm_eval_opts
[] = {
3046 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
3049 scm_t_option scm_debug_opts
[] = {
3050 { SCM_OPTION_BOOLEAN
, "cheap", 1,
3051 "*Flyweight representation of the stack at traps." },
3052 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
3053 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
3054 { SCM_OPTION_BOOLEAN
, "procnames", 1,
3055 "Record procedure names at definition." },
3056 { SCM_OPTION_BOOLEAN
, "backwards", 0,
3057 "Display backtrace in anti-chronological order." },
3058 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
3059 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
3060 { SCM_OPTION_INTEGER
, "frames", 3,
3061 "Maximum number of tail-recursive frames in backtrace." },
3062 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
3063 "Maximal number of stored backtrace frames." },
3064 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
3065 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
3066 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
3067 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
3068 { 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."},
3069 { SCM_OPTION_BOOLEAN
, "warn-deprecated", 0, "Warn when deprecated features are used." }
3072 scm_t_option scm_evaluator_trap_table
[] = {
3073 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
3074 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
3075 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
3076 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
3077 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
3078 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
3079 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
3082 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
3084 "Option interface for the evaluation options. Instead of using\n"
3085 "this procedure directly, use the procedures @code{eval-enable},\n"
3086 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
3087 #define FUNC_NAME s_scm_eval_options_interface
3090 SCM_CRITICAL_SECTION_START
;
3091 ans
= scm_options (setting
,
3095 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
3096 SCM_CRITICAL_SECTION_END
;
3102 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
3104 "Option interface for the evaluator trap options.")
3105 #define FUNC_NAME s_scm_evaluator_traps
3108 SCM_CRITICAL_SECTION_START
;
3109 ans
= scm_options (setting
,
3110 scm_evaluator_trap_table
,
3111 SCM_N_EVALUATOR_TRAPS
,
3113 SCM_RESET_DEBUG_MODE
;
3114 SCM_CRITICAL_SECTION_END
;
3121 deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
3123 SCM
*results
= lloc
;
3124 while (scm_is_pair (l
))
3126 const SCM res
= EVALCAR (l
, env
);
3128 *lloc
= scm_list_1 (res
);
3129 lloc
= SCM_CDRLOC (*lloc
);
3132 if (!scm_is_null (l
))
3133 scm_wrong_num_args (proc
);
3140 /* SECTION: This code is compiled twice.
3144 /* Update the toplevel environment frame ENV so that it refers to the
3145 * current module. */
3146 #define UPDATE_TOPLEVEL_ENV(env) \
3148 SCM p = scm_current_module_lookup_closure (); \
3149 if (p != SCM_CAR (env)) \
3150 env = scm_top_level_env (p); \
3154 #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
3155 ASSERT_SYNTAX (!scm_is_eq ((x), SCM_EOL), s_empty_combination, x)
3158 /* This is the evaluator. Like any real monster, it has three heads:
3160 * ceval is the non-debugging evaluator, deval is the debugging version. Both
3161 * are implemented using a common code base, using the following mechanism:
3162 * CEVAL is a macro, which is either defined to ceval or deval. Thus, there
3163 * is no function CEVAL, but the code for CEVAL actually compiles to either
3164 * ceval or deval. When CEVAL is defined to ceval, it is known that the macro
3165 * DEVAL is not defined. When CEVAL is defined to deval, then the macro DEVAL
3166 * is known to be defined. Thus, in CEVAL parts for the debugging evaluator
3167 * are enclosed within #ifdef DEVAL ... #endif.
3169 * All three (ceval, deval and their common implementation CEVAL) take two
3170 * input parameters, x and env: x is a single expression to be evalutated.
3171 * env is the environment in which bindings are searched.
3173 * x is known to be a pair. Since x is a single expression, it is necessarily
3174 * in a tail position. If x is just a call to another function like in the
3175 * expression (foo exp1 exp2 ...), the realization of that call therefore
3176 * _must_not_ increase stack usage (the evaluation of exp1, exp2 etc.,
3177 * however, may do so). This is realized by making extensive use of 'goto'
3178 * statements within the evaluator: The gotos replace recursive calls to
3179 * CEVAL, thus re-using the same stack frame that CEVAL was already using.
3180 * If, however, x represents some form that requires to evaluate a sequence of
3181 * expressions like (begin exp1 exp2 ...), then recursive calls to CEVAL are
3182 * performed for all but the last expression of that sequence. */
3185 CEVAL (SCM x
, SCM env
)
3189 scm_t_debug_frame debug
;
3190 scm_t_debug_info
*debug_info_end
;
3191 debug
.prev
= scm_i_last_debug_frame ();
3194 * The debug.vect contains twice as much scm_t_debug_info frames as the
3195 * user has specified with (debug-set! frames <n>).
3197 * Even frames are eval frames, odd frames are apply frames.
3199 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
3200 * sizeof (scm_t_debug_info
));
3201 debug
.info
= debug
.vect
;
3202 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
3203 scm_i_set_last_debug_frame (&debug
);
3205 #ifdef EVAL_STACK_CHECKING
3206 if (scm_stack_checking_enabled_p
&& SCM_STACK_OVERFLOW_P (&proc
))
3209 debug
.info
->e
.exp
= x
;
3210 debug
.info
->e
.env
= env
;
3212 scm_report_stack_overflow ();
3222 SCM_CLEAR_ARGSREADY (debug
);
3223 if (SCM_OVERFLOWP (debug
))
3226 * In theory, this should be the only place where it is necessary to
3227 * check for space in debug.vect since both eval frames and
3228 * available space are even.
3230 * For this to be the case, however, it is necessary that primitive
3231 * special forms which jump back to `loop', `begin' or some similar
3232 * label call PREP_APPLY.
3234 else if (++debug
.info
>= debug_info_end
)
3236 SCM_SET_OVERFLOW (debug
);
3241 debug
.info
->e
.exp
= x
;
3242 debug
.info
->e
.env
= env
;
3243 if (scm_check_entry_p
&& SCM_TRAPS_P
)
3245 if (SCM_ENTER_FRAME_P
3246 || (SCM_BREAKPOINTS_P
&& scm_c_source_property_breakpoint_p (x
)))
3249 SCM tail
= scm_from_bool (SCM_TAILRECP (debug
));
3250 SCM_SET_TAILREC (debug
);
3251 if (SCM_CHEAPTRAPS_P
)
3252 stackrep
= scm_make_debugobj (&debug
);
3256 SCM val
= scm_make_continuation (&first
);
3266 /* This gives the possibility for the debugger to
3267 modify the source expression before evaluation. */
3272 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
3273 scm_sym_enter_frame
,
3276 unmemoize_expression (x
, env
));
3283 if (SCM_ISYMP (SCM_CAR (x
)))
3285 switch (ISYMNUM (SCM_CAR (x
)))
3287 case (ISYMNUM (SCM_IM_AND
)):
3289 while (!scm_is_null (SCM_CDR (x
)))
3291 SCM test_result
= EVALCAR (x
, env
);
3292 if (scm_is_false (test_result
) || SCM_NILP (test_result
))
3293 RETURN (SCM_BOOL_F
);
3297 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3300 case (ISYMNUM (SCM_IM_BEGIN
)):
3302 if (scm_is_null (x
))
3303 RETURN (SCM_UNSPECIFIED
);
3305 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3308 /* If we are on toplevel with a lookup closure, we need to sync
3309 with the current module. */
3310 if (scm_is_pair (env
) && !scm_is_pair (SCM_CAR (env
)))
3312 UPDATE_TOPLEVEL_ENV (env
);
3313 while (!scm_is_null (SCM_CDR (x
)))
3316 UPDATE_TOPLEVEL_ENV (env
);
3322 goto nontoplevel_begin
;
3325 while (!scm_is_null (SCM_CDR (x
)))
3327 const SCM form
= SCM_CAR (x
);
3330 if (SCM_ISYMP (form
))
3332 scm_i_scm_pthread_mutex_lock (&source_mutex
);
3333 /* check for race condition */
3334 if (SCM_ISYMP (SCM_CAR (x
)))
3335 m_expand_body (x
, env
);
3336 scm_i_pthread_mutex_unlock (&source_mutex
);
3337 goto nontoplevel_begin
;
3340 SCM_VALIDATE_NON_EMPTY_COMBINATION (form
);
3343 (void) EVAL (form
, env
);
3349 /* scm_eval last form in list */
3350 const SCM last_form
= SCM_CAR (x
);
3352 if (scm_is_pair (last_form
))
3354 /* This is by far the most frequent case. */
3356 goto loop
; /* tail recurse */
3358 else if (SCM_IMP (last_form
))
3359 RETURN (SCM_I_EVALIM (last_form
, env
));
3360 else if (SCM_VARIABLEP (last_form
))
3361 RETURN (SCM_VARIABLE_REF (last_form
));
3362 else if (scm_is_symbol (last_form
))
3363 RETURN (*scm_lookupcar (x
, env
, 1));
3369 case (ISYMNUM (SCM_IM_CASE
)):
3372 const SCM key
= EVALCAR (x
, env
);
3374 while (!scm_is_null (x
))
3376 const SCM clause
= SCM_CAR (x
);
3377 SCM labels
= SCM_CAR (clause
);
3378 if (scm_is_eq (labels
, SCM_IM_ELSE
))
3380 x
= SCM_CDR (clause
);
3381 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3384 while (!scm_is_null (labels
))
3386 const SCM label
= SCM_CAR (labels
);
3387 if (scm_is_eq (label
, key
)
3388 || scm_is_true (scm_eqv_p (label
, key
)))
3390 x
= SCM_CDR (clause
);
3391 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3394 labels
= SCM_CDR (labels
);
3399 RETURN (SCM_UNSPECIFIED
);
3402 case (ISYMNUM (SCM_IM_COND
)):
3404 while (!scm_is_null (x
))
3406 const SCM clause
= SCM_CAR (x
);
3407 if (scm_is_eq (SCM_CAR (clause
), SCM_IM_ELSE
))
3409 x
= SCM_CDR (clause
);
3410 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3415 arg1
= EVALCAR (clause
, env
);
3416 if (scm_is_true (arg1
) && !SCM_NILP (arg1
))
3418 x
= SCM_CDR (clause
);
3419 if (scm_is_null (x
))
3421 else if (!scm_is_eq (SCM_CAR (x
), SCM_IM_ARROW
))
3423 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3429 proc
= EVALCAR (proc
, env
);
3430 PREP_APPLY (proc
, scm_list_1 (arg1
));
3438 RETURN (SCM_UNSPECIFIED
);
3441 case (ISYMNUM (SCM_IM_DO
)):
3444 /* Compute the initialization values and the initial environment. */
3445 SCM init_forms
= SCM_CAR (x
);
3446 SCM init_values
= SCM_EOL
;
3447 while (!scm_is_null (init_forms
))
3449 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3450 init_forms
= SCM_CDR (init_forms
);
3453 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
3457 SCM test_form
= SCM_CAR (x
);
3458 SCM body_forms
= SCM_CADR (x
);
3459 SCM step_forms
= SCM_CDDR (x
);
3461 SCM test_result
= EVALCAR (test_form
, env
);
3463 while (scm_is_false (test_result
) || SCM_NILP (test_result
))
3466 /* Evaluate body forms. */
3468 for (temp_forms
= body_forms
;
3469 !scm_is_null (temp_forms
);
3470 temp_forms
= SCM_CDR (temp_forms
))
3472 SCM form
= SCM_CAR (temp_forms
);
3473 /* Dirk:FIXME: We only need to eval forms that may have
3474 * a side effect here. This is only true for forms that
3475 * start with a pair. All others are just constants.
3476 * Since with the current memoizer 'form' may hold a
3477 * constant, we call EVAL here to handle the constant
3478 * cases. In the long run it would make sense to have
3479 * the macro transformer of 'do' eliminate all forms
3480 * that have no sideeffect. Then instead of EVAL we
3481 * could call CEVAL directly here. */
3482 (void) EVAL (form
, env
);
3487 /* Evaluate the step expressions. */
3489 SCM step_values
= SCM_EOL
;
3490 for (temp_forms
= step_forms
;
3491 !scm_is_null (temp_forms
);
3492 temp_forms
= SCM_CDR (temp_forms
))
3494 const SCM value
= EVALCAR (temp_forms
, env
);
3495 step_values
= scm_cons (value
, step_values
);
3497 env
= SCM_EXTEND_ENV (SCM_CAAR (env
),
3502 test_result
= EVALCAR (test_form
, env
);
3506 if (scm_is_null (x
))
3507 RETURN (SCM_UNSPECIFIED
);
3508 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3509 goto nontoplevel_begin
;
3512 case (ISYMNUM (SCM_IM_IF
)):
3515 SCM test_result
= EVALCAR (x
, env
);
3516 x
= SCM_CDR (x
); /* then expression */
3517 if (scm_is_false (test_result
) || SCM_NILP (test_result
))
3519 x
= SCM_CDR (x
); /* else expression */
3520 if (scm_is_null (x
))
3521 RETURN (SCM_UNSPECIFIED
);
3524 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3528 case (ISYMNUM (SCM_IM_LET
)):
3531 SCM init_forms
= SCM_CADR (x
);
3532 SCM init_values
= SCM_EOL
;
3535 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3536 init_forms
= SCM_CDR (init_forms
);
3538 while (!scm_is_null (init_forms
));
3539 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
3542 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3543 goto nontoplevel_begin
;
3546 case (ISYMNUM (SCM_IM_LETREC
)):
3548 env
= SCM_EXTEND_ENV (SCM_CAR (x
), undefineds
, env
);
3551 SCM init_forms
= SCM_CAR (x
);
3552 SCM init_values
= SCM_EOL
;
3555 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3556 init_forms
= SCM_CDR (init_forms
);
3558 while (!scm_is_null (init_forms
));
3559 SCM_SETCDR (SCM_CAR (env
), init_values
);
3562 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3563 goto nontoplevel_begin
;
3566 case (ISYMNUM (SCM_IM_LETSTAR
)):
3569 SCM bindings
= SCM_CAR (x
);
3570 if (!scm_is_null (bindings
))
3574 SCM name
= SCM_CAR (bindings
);
3575 SCM init
= SCM_CDR (bindings
);
3576 env
= SCM_EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
3577 bindings
= SCM_CDR (init
);
3579 while (!scm_is_null (bindings
));
3583 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3584 goto nontoplevel_begin
;
3587 case (ISYMNUM (SCM_IM_OR
)):
3589 while (!scm_is_null (SCM_CDR (x
)))
3591 SCM val
= EVALCAR (x
, env
);
3592 if (scm_is_true (val
) && !SCM_NILP (val
))
3597 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3601 case (ISYMNUM (SCM_IM_LAMBDA
)):
3602 RETURN (scm_closure (SCM_CDR (x
), env
));
3605 case (ISYMNUM (SCM_IM_QUOTE
)):
3606 RETURN (SCM_CDR (x
));
3609 case (ISYMNUM (SCM_IM_SET_X
)):
3613 SCM variable
= SCM_CAR (x
);
3614 if (SCM_ILOCP (variable
))
3615 location
= scm_ilookup (variable
, env
);
3616 else if (SCM_VARIABLEP (variable
))
3617 location
= SCM_VARIABLE_LOC (variable
);
3620 /* (scm_is_symbol (variable)) is known to be true */
3621 variable
= lazy_memoize_variable (variable
, env
);
3622 SCM_SETCAR (x
, variable
);
3623 location
= SCM_VARIABLE_LOC (variable
);
3626 *location
= EVALCAR (x
, env
);
3628 RETURN (SCM_UNSPECIFIED
);
3631 case (ISYMNUM (SCM_IM_APPLY
)):
3632 /* Evaluate the procedure to be applied. */
3634 proc
= EVALCAR (x
, env
);
3635 PREP_APPLY (proc
, SCM_EOL
);
3637 /* Evaluate the argument holding the list of arguments */
3639 arg1
= EVALCAR (x
, env
);
3642 /* Go here to tail-apply a procedure. PROC is the procedure and
3643 * ARG1 is the list of arguments. PREP_APPLY must have been called
3644 * before jumping to apply_proc. */
3645 if (SCM_CLOSUREP (proc
))
3647 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3649 debug
.info
->a
.args
= arg1
;
3651 if (scm_badargsp (formals
, arg1
))
3652 scm_wrong_num_args (proc
);
3654 /* Copy argument list */
3655 if (SCM_NULL_OR_NIL_P (arg1
))
3656 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
3659 SCM args
= scm_list_1 (SCM_CAR (arg1
));
3661 arg1
= SCM_CDR (arg1
);
3662 while (!SCM_NULL_OR_NIL_P (arg1
))
3664 SCM new_tail
= scm_list_1 (SCM_CAR (arg1
));
3665 SCM_SETCDR (tail
, new_tail
);
3667 arg1
= SCM_CDR (arg1
);
3669 env
= SCM_EXTEND_ENV (formals
, args
, SCM_ENV (proc
));
3672 x
= SCM_CLOSURE_BODY (proc
);
3673 goto nontoplevel_begin
;
3678 RETURN (SCM_APPLY (proc
, arg1
, SCM_EOL
));
3682 case (ISYMNUM (SCM_IM_CONT
)):
3685 SCM val
= scm_make_continuation (&first
);
3693 proc
= EVALCAR (proc
, env
);
3694 PREP_APPLY (proc
, scm_list_1 (arg1
));
3701 case (ISYMNUM (SCM_IM_DELAY
)):
3702 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
3705 case (ISYMNUM (SCM_IM_FUTURE
)):
3706 RETURN (scm_i_make_future (scm_closure (SCM_CDR (x
), env
)));
3709 /* PLACEHOLDER for case (ISYMNUM (SCM_IM_DISPATCH)): The following
3710 code (type_dispatch) is intended to be the tail of the case
3711 clause for the internal macro SCM_IM_DISPATCH. Please don't
3712 remove it from this location without discussing it with Mikael
3713 <djurfeldt@nada.kth.se> */
3715 /* The type dispatch code is duplicated below
3716 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
3717 * cuts down execution time for type dispatch to 50%. */
3718 type_dispatch
: /* inputs: x, arg1 */
3719 /* Type dispatch means to determine from the types of the function
3720 * arguments (i. e. the 'signature' of the call), which method from
3721 * a generic function is to be called. This process of selecting
3722 * the right method takes some time. To speed it up, guile uses
3723 * caching: Together with the macro call to dispatch the signatures
3724 * of some previous calls to that generic function from the same
3725 * place are stored (in the code!) in a cache that we call the
3726 * 'method cache'. This is done since it is likely, that
3727 * consecutive calls to dispatch from that position in the code will
3728 * have the same signature. Thus, the type dispatch works as
3729 * follows: First, determine a hash value from the signature of the
3730 * actual arguments. Second, use this hash value as an index to
3731 * find that same signature in the method cache stored at this
3732 * position in the code. If found, you have also found the
3733 * corresponding method that belongs to that signature. If the
3734 * signature is not found in the method cache, you have to perform a
3735 * full search over all signatures stored with the generic
3738 unsigned long int specializers
;
3739 unsigned long int hash_value
;
3740 unsigned long int cache_end_pos
;
3741 unsigned long int mask
;
3745 SCM z
= SCM_CDDR (x
);
3746 SCM tmp
= SCM_CADR (z
);
3747 specializers
= scm_to_ulong (SCM_CAR (z
));
3749 /* Compute a hash value for searching the method cache. There
3750 * are two variants for computing the hash value, a (rather)
3751 * complicated one, and a simple one. For the complicated one
3752 * explained below, tmp holds a number that is used in the
3754 if (scm_is_simple_vector (tmp
))
3756 /* This method of determining the hash value is much
3757 * simpler: Set the hash value to zero and just perform a
3758 * linear search through the method cache. */
3760 mask
= (unsigned long int) ((long) -1);
3762 cache_end_pos
= SCM_SIMPLE_VECTOR_LENGTH (method_cache
);
3766 /* Use the signature of the actual arguments to determine
3767 * the hash value. This is done as follows: Each class has
3768 * an array of random numbers, that are determined when the
3769 * class is created. The integer 'hashset' is an index into
3770 * that array of random numbers. Now, from all classes that
3771 * are part of the signature of the actual arguments, the
3772 * random numbers at index 'hashset' are taken and summed
3773 * up, giving the hash value. The value of 'hashset' is
3774 * stored at the call to dispatch. This allows to have
3775 * different 'formulas' for calculating the hash value at
3776 * different places where dispatch is called. This allows
3777 * to optimize the hash formula at every individual place
3778 * where dispatch is called, such that hopefully the hash
3779 * value that is computed will directly point to the right
3780 * method in the method cache. */
3781 unsigned long int hashset
= scm_to_ulong (tmp
);
3782 unsigned long int counter
= specializers
+ 1;
3785 while (!scm_is_null (tmp_arg
) && counter
!= 0)
3787 SCM
class = scm_class_of (SCM_CAR (tmp_arg
));
3788 hash_value
+= SCM_INSTANCE_HASH (class, hashset
);
3789 tmp_arg
= SCM_CDR (tmp_arg
);
3793 method_cache
= SCM_CADR (z
);
3794 mask
= scm_to_ulong (SCM_CAR (z
));
3796 cache_end_pos
= hash_value
;
3801 /* Search the method cache for a method with a matching
3802 * signature. Start the search at position 'hash_value'. The
3803 * hashing implementation uses linear probing for conflict
3804 * resolution, that is, if the signature in question is not
3805 * found at the starting index in the hash table, the next table
3806 * entry is tried, and so on, until in the worst case the whole
3807 * cache has been searched, but still the signature has not been
3812 SCM args
= arg1
; /* list of arguments */
3813 z
= SCM_SIMPLE_VECTOR_REF (method_cache
, hash_value
);
3814 while (!scm_is_null (args
))
3816 /* More arguments than specifiers => CLASS != ENV */
3817 SCM class_of_arg
= scm_class_of (SCM_CAR (args
));
3818 if (!scm_is_eq (class_of_arg
, SCM_CAR (z
)))
3820 args
= SCM_CDR (args
);
3823 /* Fewer arguments than specifiers => CAR != ENV */
3824 if (scm_is_null (SCM_CAR (z
)) || scm_is_pair (SCM_CAR (z
)))
3827 hash_value
= (hash_value
+ 1) & mask
;
3828 } while (hash_value
!= cache_end_pos
);
3830 /* No appropriate method was found in the cache. */
3831 z
= scm_memoize_method (x
, arg1
);
3833 apply_cmethod
: /* inputs: z, arg1 */
3835 SCM formals
= SCM_CMETHOD_FORMALS (z
);
3836 env
= SCM_EXTEND_ENV (formals
, arg1
, SCM_CMETHOD_ENV (z
));
3837 x
= SCM_CMETHOD_BODY (z
);
3838 goto nontoplevel_begin
;
3844 case (ISYMNUM (SCM_IM_SLOT_REF
)):
3847 SCM instance
= EVALCAR (x
, env
);
3848 unsigned long int slot
= SCM_I_INUM (SCM_CDR (x
));
3849 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance
) [slot
]));
3853 case (ISYMNUM (SCM_IM_SLOT_SET_X
)):
3856 SCM instance
= EVALCAR (x
, env
);
3857 unsigned long int slot
= SCM_I_INUM (SCM_CADR (x
));
3858 SCM value
= EVALCAR (SCM_CDDR (x
), env
);
3859 SCM_STRUCT_DATA (instance
) [slot
] = SCM_UNPACK (value
);
3860 RETURN (SCM_UNSPECIFIED
);
3864 #if SCM_ENABLE_ELISP
3866 case (ISYMNUM (SCM_IM_NIL_COND
)):
3868 SCM test_form
= SCM_CDR (x
);
3869 x
= SCM_CDR (test_form
);
3870 while (!SCM_NULL_OR_NIL_P (x
))
3872 SCM test_result
= EVALCAR (test_form
, env
);
3873 if (!(scm_is_false (test_result
)
3874 || SCM_NULL_OR_NIL_P (test_result
)))
3876 if (scm_is_eq (SCM_CAR (x
), SCM_UNSPECIFIED
))
3877 RETURN (test_result
);
3878 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3883 test_form
= SCM_CDR (x
);
3884 x
= SCM_CDR (test_form
);
3888 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3892 #endif /* SCM_ENABLE_ELISP */
3894 case (ISYMNUM (SCM_IM_BIND
)):
3896 SCM vars
, exps
, vals
;
3899 vars
= SCM_CAAR (x
);
3900 exps
= SCM_CDAR (x
);
3902 while (!scm_is_null (exps
))
3904 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
3905 exps
= SCM_CDR (exps
);
3908 scm_swap_bindings (vars
, vals
);
3909 scm_i_set_dynwinds (scm_acons (vars
, vals
, scm_i_dynwinds ()));
3911 /* Ignore all but the last evaluation result. */
3912 for (x
= SCM_CDR (x
); !scm_is_null (SCM_CDR (x
)); x
= SCM_CDR (x
))
3914 if (scm_is_pair (SCM_CAR (x
)))
3915 CEVAL (SCM_CAR (x
), env
);
3917 proc
= EVALCAR (x
, env
);
3919 scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
3920 scm_swap_bindings (vars
, vals
);
3926 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
3931 producer
= EVALCAR (x
, env
);
3933 proc
= EVALCAR (x
, env
); /* proc is the consumer. */
3934 arg1
= SCM_APPLY (producer
, SCM_EOL
, SCM_EOL
);
3935 if (SCM_VALUESP (arg1
))
3937 /* The list of arguments is not copied. Rather, it is assumed
3938 * that this has been done by the 'values' procedure. */
3939 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
3943 arg1
= scm_list_1 (arg1
);
3945 PREP_APPLY (proc
, arg1
);
3956 if (SCM_VARIABLEP (SCM_CAR (x
)))
3957 proc
= SCM_VARIABLE_REF (SCM_CAR (x
));
3958 else if (SCM_ILOCP (SCM_CAR (x
)))
3959 proc
= *scm_ilookup (SCM_CAR (x
), env
);
3960 else if (scm_is_pair (SCM_CAR (x
)))
3961 proc
= CEVAL (SCM_CAR (x
), env
);
3962 else if (scm_is_symbol (SCM_CAR (x
)))
3964 SCM orig_sym
= SCM_CAR (x
);
3966 SCM
*location
= scm_lookupcar1 (x
, env
, 1);
3967 if (location
== NULL
)
3969 /* we have lost the race, start again. */
3975 if (SCM_MACROP (proc
))
3977 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
3979 handle_a_macro
: /* inputs: x, env, proc */
3981 /* Set a flag during macro expansion so that macro
3982 application frames can be deleted from the backtrace. */
3983 SCM_SET_MACROEXP (debug
);
3985 arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
3986 scm_cons (env
, scm_listofnull
));
3988 SCM_CLEAR_MACROEXP (debug
);
3990 switch (SCM_MACRO_TYPE (proc
))
3994 if (!scm_is_pair (arg1
))
3995 arg1
= scm_list_2 (SCM_IM_BEGIN
, arg1
);
3997 assert (!scm_is_eq (x
, SCM_CAR (arg1
))
3998 && !scm_is_eq (x
, SCM_CDR (arg1
)));
4001 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
4003 SCM_CRITICAL_SECTION_START
;
4004 SCM_SETCAR (x
, SCM_CAR (arg1
));
4005 SCM_SETCDR (x
, SCM_CDR (arg1
));
4006 SCM_CRITICAL_SECTION_END
;
4009 /* Prevent memoizing of debug info expression. */
4010 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
4014 SCM_CRITICAL_SECTION_START
;
4015 SCM_SETCAR (x
, SCM_CAR (arg1
));
4016 SCM_SETCDR (x
, SCM_CDR (arg1
));
4017 SCM_CRITICAL_SECTION_END
;
4018 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
4020 #if SCM_ENABLE_DEPRECATED == 1
4025 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
4039 if (SCM_MACROP (proc
))
4040 goto handle_a_macro
;
4044 /* When reaching this part of the code, the following is granted: Variable x
4045 * holds the first pair of an expression of the form (<function> arg ...).
4046 * Variable proc holds the object that resulted from the evaluation of
4047 * <function>. In the following, the arguments (if any) will be evaluated,
4048 * and proc will be applied to them. If proc does not really hold a
4049 * function object, this will be signalled as an error on the scheme
4050 * level. If the number of arguments does not match the number of arguments
4051 * that are allowed to be passed to proc, also an error on the scheme level
4052 * will be signalled. */
4053 PREP_APPLY (proc
, SCM_EOL
);
4054 if (scm_is_null (SCM_CDR (x
))) {
4057 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4058 switch (SCM_TYP7 (proc
))
4059 { /* no arguments given */
4060 case scm_tc7_subr_0
:
4061 RETURN (SCM_SUBRF (proc
) ());
4062 case scm_tc7_subr_1o
:
4063 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
4065 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
4066 case scm_tc7_rpsubr
:
4067 RETURN (SCM_BOOL_T
);
4069 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
4071 if (!SCM_SMOB_APPLICABLE_P (proc
))
4073 RETURN (SCM_SMOB_APPLY_0 (proc
));
4076 proc
= SCM_CCLO_SUBR (proc
);
4078 debug
.info
->a
.proc
= proc
;
4079 debug
.info
->a
.args
= scm_list_1 (arg1
);
4083 proc
= SCM_PROCEDURE (proc
);
4085 debug
.info
->a
.proc
= proc
;
4087 if (!SCM_CLOSUREP (proc
))
4090 case scm_tcs_closures
:
4092 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4093 if (scm_is_pair (formals
))
4095 x
= SCM_CLOSURE_BODY (proc
);
4096 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
4097 goto nontoplevel_begin
;
4099 case scm_tcs_struct
:
4100 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4102 x
= SCM_ENTITY_PROCEDURE (proc
);
4106 else if (SCM_I_OPERATORP (proc
))
4109 proc
= (SCM_I_ENTITYP (proc
)
4110 ? SCM_ENTITY_PROCEDURE (proc
)
4111 : SCM_OPERATOR_PROCEDURE (proc
));
4113 debug
.info
->a
.proc
= proc
;
4114 debug
.info
->a
.args
= scm_list_1 (arg1
);
4120 case scm_tc7_subr_1
:
4121 case scm_tc7_subr_2
:
4122 case scm_tc7_subr_2o
:
4125 case scm_tc7_subr_3
:
4126 case scm_tc7_lsubr_2
:
4128 scm_wrong_num_args (proc
);
4131 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
4135 /* must handle macros by here */
4137 if (scm_is_pair (x
))
4138 arg1
= EVALCAR (x
, env
);
4140 scm_wrong_num_args (proc
);
4142 debug
.info
->a
.args
= scm_list_1 (arg1
);
4147 if (scm_is_null (x
))
4150 evap1
: /* inputs: proc, arg1 */
4151 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4152 switch (SCM_TYP7 (proc
))
4153 { /* have one argument in arg1 */
4154 case scm_tc7_subr_2o
:
4155 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4156 case scm_tc7_subr_1
:
4157 case scm_tc7_subr_1o
:
4158 RETURN (SCM_SUBRF (proc
) (arg1
));
4160 if (SCM_I_INUMP (arg1
))
4162 RETURN (scm_from_double (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
))));
4164 else if (SCM_REALP (arg1
))
4166 RETURN (scm_from_double (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4168 else if (SCM_BIGP (arg1
))
4170 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4172 else if (SCM_FRACTIONP (arg1
))
4174 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4176 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4178 scm_i_symbol_chars (SCM_SNAME (proc
)));
4180 RETURN (scm_i_chase_pairs (arg1
, (scm_t_bits
) SCM_SUBRF (proc
)));
4181 case scm_tc7_rpsubr
:
4182 RETURN (SCM_BOOL_T
);
4184 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4187 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4189 RETURN (SCM_SUBRF (proc
) (scm_list_1 (arg1
)));
4192 if (!SCM_SMOB_APPLICABLE_P (proc
))
4194 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
4198 proc
= SCM_CCLO_SUBR (proc
);
4200 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
4201 debug
.info
->a
.proc
= proc
;
4205 proc
= SCM_PROCEDURE (proc
);
4207 debug
.info
->a
.proc
= proc
;
4209 if (!SCM_CLOSUREP (proc
))
4212 case scm_tcs_closures
:
4215 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4216 if (scm_is_null (formals
)
4217 || (scm_is_pair (formals
) && scm_is_pair (SCM_CDR (formals
))))
4219 x
= SCM_CLOSURE_BODY (proc
);
4221 env
= SCM_EXTEND_ENV (formals
,
4225 env
= SCM_EXTEND_ENV (formals
,
4229 goto nontoplevel_begin
;
4231 case scm_tcs_struct
:
4232 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4234 x
= SCM_ENTITY_PROCEDURE (proc
);
4236 arg1
= debug
.info
->a
.args
;
4238 arg1
= scm_list_1 (arg1
);
4242 else if (SCM_I_OPERATORP (proc
))
4246 proc
= (SCM_I_ENTITYP (proc
)
4247 ? SCM_ENTITY_PROCEDURE (proc
)
4248 : SCM_OPERATOR_PROCEDURE (proc
));
4250 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
4251 debug
.info
->a
.proc
= proc
;
4257 case scm_tc7_subr_2
:
4258 case scm_tc7_subr_0
:
4259 case scm_tc7_subr_3
:
4260 case scm_tc7_lsubr_2
:
4261 scm_wrong_num_args (proc
);
4266 if (scm_is_pair (x
))
4267 arg2
= EVALCAR (x
, env
);
4269 scm_wrong_num_args (proc
);
4271 { /* have two or more arguments */
4273 debug
.info
->a
.args
= scm_list_2 (arg1
, arg2
);
4276 if (scm_is_null (x
)) {
4279 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4280 switch (SCM_TYP7 (proc
))
4281 { /* have two arguments */
4282 case scm_tc7_subr_2
:
4283 case scm_tc7_subr_2o
:
4284 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
4287 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4289 RETURN (SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
)));
4291 case scm_tc7_lsubr_2
:
4292 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
));
4293 case scm_tc7_rpsubr
:
4295 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
4297 if (!SCM_SMOB_APPLICABLE_P (proc
))
4299 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
));
4303 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
4304 scm_cons (proc
, debug
.info
->a
.args
),
4307 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
4308 scm_cons2 (proc
, arg1
,
4315 case scm_tcs_struct
:
4316 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4318 x
= SCM_ENTITY_PROCEDURE (proc
);
4320 arg1
= debug
.info
->a
.args
;
4322 arg1
= scm_list_2 (arg1
, arg2
);
4326 else if (SCM_I_OPERATORP (proc
))
4330 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
4331 ? SCM_ENTITY_PROCEDURE (proc
)
4332 : SCM_OPERATOR_PROCEDURE (proc
),
4333 scm_cons (proc
, debug
.info
->a
.args
),
4336 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
4337 ? SCM_ENTITY_PROCEDURE (proc
)
4338 : SCM_OPERATOR_PROCEDURE (proc
),
4339 scm_cons2 (proc
, arg1
,
4349 case scm_tc7_subr_0
:
4352 case scm_tc7_subr_1o
:
4353 case scm_tc7_subr_1
:
4354 case scm_tc7_subr_3
:
4355 scm_wrong_num_args (proc
);
4359 proc
= SCM_PROCEDURE (proc
);
4361 debug
.info
->a
.proc
= proc
;
4363 if (!SCM_CLOSUREP (proc
))
4366 case scm_tcs_closures
:
4369 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4370 if (scm_is_null (formals
)
4371 || (scm_is_pair (formals
)
4372 && (scm_is_null (SCM_CDR (formals
))
4373 || (scm_is_pair (SCM_CDR (formals
))
4374 && scm_is_pair (SCM_CDDR (formals
))))))
4377 env
= SCM_EXTEND_ENV (formals
,
4381 env
= SCM_EXTEND_ENV (formals
,
4382 scm_list_2 (arg1
, arg2
),
4385 x
= SCM_CLOSURE_BODY (proc
);
4386 goto nontoplevel_begin
;
4390 if (!scm_is_pair (x
))
4391 scm_wrong_num_args (proc
);
4393 debug
.info
->a
.args
= scm_cons2 (arg1
, arg2
,
4394 deval_args (x
, env
, proc
,
4395 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
4399 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4400 switch (SCM_TYP7 (proc
))
4401 { /* have 3 or more arguments */
4403 case scm_tc7_subr_3
:
4404 if (!scm_is_null (SCM_CDR (x
)))
4405 scm_wrong_num_args (proc
);
4407 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4408 SCM_CADDR (debug
.info
->a
.args
)));
4410 arg1
= SCM_SUBRF(proc
)(arg1
, arg2
);
4411 arg2
= SCM_CDDR (debug
.info
->a
.args
);
4414 arg1
= SCM_SUBRF(proc
)(arg1
, SCM_CAR (arg2
));
4415 arg2
= SCM_CDR (arg2
);
4417 while (SCM_NIMP (arg2
));
4419 case scm_tc7_rpsubr
:
4420 if (scm_is_false (SCM_SUBRF (proc
) (arg1
, arg2
)))
4421 RETURN (SCM_BOOL_F
);
4422 arg1
= SCM_CDDR (debug
.info
->a
.args
);
4425 if (scm_is_false (SCM_SUBRF (proc
) (arg2
, SCM_CAR (arg1
))))
4426 RETURN (SCM_BOOL_F
);
4427 arg2
= SCM_CAR (arg1
);
4428 arg1
= SCM_CDR (arg1
);
4430 while (SCM_NIMP (arg1
));
4431 RETURN (SCM_BOOL_T
);
4432 case scm_tc7_lsubr_2
:
4433 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4434 SCM_CDDR (debug
.info
->a
.args
)));
4436 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4438 if (!SCM_SMOB_APPLICABLE_P (proc
))
4440 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4441 SCM_CDDR (debug
.info
->a
.args
)));
4445 proc
= SCM_PROCEDURE (proc
);
4446 debug
.info
->a
.proc
= proc
;
4447 if (!SCM_CLOSUREP (proc
))
4450 case scm_tcs_closures
:
4452 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4453 if (scm_is_null (formals
)
4454 || (scm_is_pair (formals
)
4455 && (scm_is_null (SCM_CDR (formals
))
4456 || (scm_is_pair (SCM_CDR (formals
))
4457 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4459 SCM_SET_ARGSREADY (debug
);
4460 env
= SCM_EXTEND_ENV (formals
,
4463 x
= SCM_CLOSURE_BODY (proc
);
4464 goto nontoplevel_begin
;
4467 case scm_tc7_subr_3
:
4468 if (!scm_is_null (SCM_CDR (x
)))
4469 scm_wrong_num_args (proc
);
4471 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, EVALCAR (x
, env
)));
4473 arg1
= SCM_SUBRF (proc
) (arg1
, arg2
);
4476 arg1
= SCM_SUBRF(proc
)(arg1
, EVALCAR(x
, env
));
4479 while (!scm_is_null (x
));
4481 case scm_tc7_rpsubr
:
4482 if (scm_is_false (SCM_SUBRF (proc
) (arg1
, arg2
)))
4483 RETURN (SCM_BOOL_F
);
4486 arg1
= EVALCAR (x
, env
);
4487 if (scm_is_false (SCM_SUBRF (proc
) (arg2
, arg1
)))
4488 RETURN (SCM_BOOL_F
);
4492 while (!scm_is_null (x
));
4493 RETURN (SCM_BOOL_T
);
4494 case scm_tc7_lsubr_2
:
4495 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
4497 RETURN (SCM_SUBRF (proc
) (scm_cons2 (arg1
,
4499 scm_eval_args (x
, env
, proc
))));
4501 if (!SCM_SMOB_APPLICABLE_P (proc
))
4503 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4504 scm_eval_args (x
, env
, proc
)));
4508 proc
= SCM_PROCEDURE (proc
);
4509 if (!SCM_CLOSUREP (proc
))
4512 case scm_tcs_closures
:
4514 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4515 if (scm_is_null (formals
)
4516 || (scm_is_pair (formals
)
4517 && (scm_is_null (SCM_CDR (formals
))
4518 || (scm_is_pair (SCM_CDR (formals
))
4519 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4521 env
= SCM_EXTEND_ENV (formals
,
4524 scm_eval_args (x
, env
, proc
)),
4526 x
= SCM_CLOSURE_BODY (proc
);
4527 goto nontoplevel_begin
;
4530 case scm_tcs_struct
:
4531 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4534 arg1
= debug
.info
->a
.args
;
4536 arg1
= scm_cons2 (arg1
, arg2
, scm_eval_args (x
, env
, proc
));
4538 x
= SCM_ENTITY_PROCEDURE (proc
);
4541 else if (SCM_I_OPERATORP (proc
))
4545 case scm_tc7_subr_2
:
4546 case scm_tc7_subr_1o
:
4547 case scm_tc7_subr_2o
:
4548 case scm_tc7_subr_0
:
4551 case scm_tc7_subr_1
:
4552 scm_wrong_num_args (proc
);
4560 if (scm_check_exit_p
&& SCM_TRAPS_P
)
4561 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
4563 SCM_CLEAR_TRACED_FRAME (debug
);
4564 if (SCM_CHEAPTRAPS_P
)
4565 arg1
= scm_make_debugobj (&debug
);
4569 SCM val
= scm_make_continuation (&first
);
4580 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
4584 scm_i_set_last_debug_frame (debug
.prev
);
4590 /* SECTION: This code is compiled once.
4597 /* Simple procedure calls
4601 scm_call_0 (SCM proc
)
4603 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
4607 scm_call_1 (SCM proc
, SCM arg1
)
4609 return scm_apply (proc
, arg1
, scm_listofnull
);
4613 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
4615 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
4619 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
4621 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
4625 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
4627 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
4628 scm_cons (arg4
, scm_listofnull
)));
4631 /* Simple procedure applies
4635 scm_apply_0 (SCM proc
, SCM args
)
4637 return scm_apply (proc
, args
, SCM_EOL
);
4641 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
4643 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
4647 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
4649 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
4653 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
4655 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
4659 /* This code processes the arguments to apply:
4661 (apply PROC ARG1 ... ARGS)
4663 Given a list (ARG1 ... ARGS), this function conses the ARG1
4664 ... arguments onto the front of ARGS, and returns the resulting
4665 list. Note that ARGS is a list; thus, the argument to this
4666 function is a list whose last element is a list.
4668 Apply calls this function, and applies PROC to the elements of the
4669 result. apply:nconc2last takes care of building the list of
4670 arguments, given (ARG1 ... ARGS).
4672 Rather than do new consing, apply:nconc2last destroys its argument.
4673 On that topic, this code came into my care with the following
4674 beautifully cryptic comment on that topic: "This will only screw
4675 you if you do (scm_apply scm_apply '( ... ))" If you know what
4676 they're referring to, send me a patch to this comment. */
4678 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
4680 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
4681 "conses the @var{arg1} @dots{} arguments onto the front of\n"
4682 "@var{args}, and returns the resulting list. Note that\n"
4683 "@var{args} is a list; thus, the argument to this function is\n"
4684 "a list whose last element is a list.\n"
4685 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
4686 "destroys its argument, so use with care.")
4687 #define FUNC_NAME s_scm_nconc2last
4690 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
4692 while (!scm_is_null (SCM_CDR (*lloc
))) /* Perhaps should be
4693 SCM_NULL_OR_NIL_P, but not
4694 needed in 99.99% of cases,
4695 and it could seriously hurt
4696 performance. - Neil */
4697 lloc
= SCM_CDRLOC (*lloc
);
4698 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
4699 *lloc
= SCM_CAR (*lloc
);
4707 /* SECTION: When DEVAL is defined this code yields scm_dapply.
4708 * It is compiled twice.
4713 scm_apply (SCM proc
, SCM arg1
, SCM args
)
4719 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
4724 /* Apply a function to a list of arguments.
4726 This function is exported to the Scheme level as taking two
4727 required arguments and a tail argument, as if it were:
4728 (lambda (proc arg1 . args) ...)
4729 Thus, if you just have a list of arguments to pass to a procedure,
4730 pass the list as ARG1, and '() for ARGS. If you have some fixed
4731 args, pass the first as ARG1, then cons any remaining fixed args
4732 onto the front of your argument list, and pass that as ARGS. */
4735 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
4738 scm_t_debug_frame debug
;
4739 scm_t_debug_info debug_vect_body
;
4740 debug
.prev
= scm_i_last_debug_frame ();
4741 debug
.status
= SCM_APPLYFRAME
;
4742 debug
.vect
= &debug_vect_body
;
4743 debug
.vect
[0].a
.proc
= proc
;
4744 debug
.vect
[0].a
.args
= SCM_EOL
;
4745 scm_i_set_last_debug_frame (&debug
);
4747 if (scm_debug_mode_p
)
4748 return scm_dapply (proc
, arg1
, args
);
4751 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
4753 /* If ARGS is the empty list, then we're calling apply with only two
4754 arguments --- ARG1 is the list of arguments for PROC. Whatever
4755 the case, futz with things so that ARG1 is the first argument to
4756 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
4759 Setting the debug apply frame args this way is pretty messy.
4760 Perhaps we should store arg1 and args directly in the frame as
4761 received, and let scm_frame_arguments unpack them, because that's
4762 a relatively rare operation. This works for now; if the Guile
4763 developer archives are still around, see Mikael's post of
4765 if (scm_is_null (args
))
4767 if (scm_is_null (arg1
))
4769 arg1
= SCM_UNDEFINED
;
4771 debug
.vect
[0].a
.args
= SCM_EOL
;
4777 debug
.vect
[0].a
.args
= arg1
;
4779 args
= SCM_CDR (arg1
);
4780 arg1
= SCM_CAR (arg1
);
4785 args
= scm_nconc2last (args
);
4787 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4791 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
4794 if (SCM_CHEAPTRAPS_P
)
4795 tmp
= scm_make_debugobj (&debug
);
4800 tmp
= scm_make_continuation (&first
);
4805 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
4812 switch (SCM_TYP7 (proc
))
4814 case scm_tc7_subr_2o
:
4815 args
= scm_is_null (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
4816 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4817 case scm_tc7_subr_2
:
4818 if (scm_is_null (args
) || !scm_is_null (SCM_CDR (args
)))
4819 scm_wrong_num_args (proc
);
4820 args
= SCM_CAR (args
);
4821 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4822 case scm_tc7_subr_0
:
4823 if (!SCM_UNBNDP (arg1
))
4824 scm_wrong_num_args (proc
);
4826 RETURN (SCM_SUBRF (proc
) ());
4827 case scm_tc7_subr_1
:
4828 if (SCM_UNBNDP (arg1
))
4829 scm_wrong_num_args (proc
);
4830 case scm_tc7_subr_1o
:
4831 if (!scm_is_null (args
))
4832 scm_wrong_num_args (proc
);
4834 RETURN (SCM_SUBRF (proc
) (arg1
));
4836 if (SCM_UNBNDP (arg1
) || !scm_is_null (args
))
4837 scm_wrong_num_args (proc
);
4838 if (SCM_I_INUMP (arg1
))
4840 RETURN (scm_from_double (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
))));
4842 else if (SCM_REALP (arg1
))
4844 RETURN (scm_from_double (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4846 else if (SCM_BIGP (arg1
))
4848 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4850 else if (SCM_FRACTIONP (arg1
))
4852 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4854 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4855 SCM_ARG1
, scm_i_symbol_chars (SCM_SNAME (proc
)));
4857 if (SCM_UNBNDP (arg1
) || !scm_is_null (args
))
4858 scm_wrong_num_args (proc
);
4859 RETURN (scm_i_chase_pairs (arg1
, (scm_t_bits
) SCM_SUBRF (proc
)));
4860 case scm_tc7_subr_3
:
4861 if (scm_is_null (args
)
4862 || scm_is_null (SCM_CDR (args
))
4863 || !scm_is_null (SCM_CDDR (args
)))
4864 scm_wrong_num_args (proc
);
4866 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
4869 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
4871 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
4873 case scm_tc7_lsubr_2
:
4874 if (!scm_is_pair (args
))
4875 scm_wrong_num_args (proc
);
4877 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4879 if (scm_is_null (args
))
4880 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4881 while (SCM_NIMP (args
))
4883 SCM_ASSERT (scm_is_pair (args
), args
, SCM_ARG2
, "apply");
4884 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
4885 args
= SCM_CDR (args
);
4888 case scm_tc7_rpsubr
:
4889 if (scm_is_null (args
))
4890 RETURN (SCM_BOOL_T
);
4891 while (SCM_NIMP (args
))
4893 SCM_ASSERT (scm_is_pair (args
), args
, SCM_ARG2
, "apply");
4894 if (scm_is_false (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
4895 RETURN (SCM_BOOL_F
);
4896 arg1
= SCM_CAR (args
);
4897 args
= SCM_CDR (args
);
4899 RETURN (SCM_BOOL_T
);
4900 case scm_tcs_closures
:
4902 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4904 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4906 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
4907 scm_wrong_num_args (proc
);
4909 /* Copy argument list */
4914 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
4915 for (arg1
= SCM_CDR (arg1
); scm_is_pair (arg1
); arg1
= SCM_CDR (arg1
))
4917 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
));
4920 SCM_SETCDR (tl
, arg1
);
4923 args
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4926 proc
= SCM_CLOSURE_BODY (proc
);
4928 arg1
= SCM_CDR (proc
);
4929 while (!scm_is_null (arg1
))
4931 if (SCM_IMP (SCM_CAR (proc
)))
4933 if (SCM_ISYMP (SCM_CAR (proc
)))
4935 scm_i_scm_pthread_mutex_lock (&source_mutex
);
4936 /* check for race condition */
4937 if (SCM_ISYMP (SCM_CAR (proc
)))
4938 m_expand_body (proc
, args
);
4939 scm_i_pthread_mutex_unlock (&source_mutex
);
4943 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
4946 (void) EVAL (SCM_CAR (proc
), args
);
4948 arg1
= SCM_CDR (proc
);
4950 RETURN (EVALCAR (proc
, args
));
4952 if (!SCM_SMOB_APPLICABLE_P (proc
))
4954 if (SCM_UNBNDP (arg1
))
4955 RETURN (SCM_SMOB_APPLY_0 (proc
));
4956 else if (scm_is_null (args
))
4957 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
4958 else if (scm_is_null (SCM_CDR (args
)))
4959 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
4961 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4964 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4966 proc
= SCM_CCLO_SUBR (proc
);
4967 debug
.vect
[0].a
.proc
= proc
;
4968 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4970 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4972 proc
= SCM_CCLO_SUBR (proc
);
4976 proc
= SCM_PROCEDURE (proc
);
4978 debug
.vect
[0].a
.proc
= proc
;
4981 case scm_tcs_struct
:
4982 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4985 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4987 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4989 RETURN (scm_apply_generic (proc
, args
));
4991 else if (SCM_I_OPERATORP (proc
))
4995 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4997 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
5000 proc
= (SCM_I_ENTITYP (proc
)
5001 ? SCM_ENTITY_PROCEDURE (proc
)
5002 : SCM_OPERATOR_PROCEDURE (proc
));
5004 debug
.vect
[0].a
.proc
= proc
;
5005 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
5007 if (SCM_NIMP (proc
))
5016 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
5020 if (scm_check_exit_p
&& SCM_TRAPS_P
)
5021 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
5023 SCM_CLEAR_TRACED_FRAME (debug
);
5024 if (SCM_CHEAPTRAPS_P
)
5025 arg1
= scm_make_debugobj (&debug
);
5029 SCM val
= scm_make_continuation (&first
);
5040 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
5044 scm_i_set_last_debug_frame (debug
.prev
);
5050 /* SECTION: The rest of this file is only read once.
5057 * Trampolines make it possible to move procedure application dispatch
5058 * outside inner loops. The motivation was clean implementation of
5059 * efficient replacements of R5RS primitives in SRFI-1.
5061 * The semantics is clear: scm_trampoline_N returns an optimized
5062 * version of scm_call_N (or NULL if the procedure isn't applicable
5065 * Applying the optimization to map and for-each increased efficiency
5066 * noticeably. For example, (map abs ls) is now 8 times faster than
5071 call_subr0_0 (SCM proc
)
5073 return SCM_SUBRF (proc
) ();
5077 call_subr1o_0 (SCM proc
)
5079 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
5083 call_lsubr_0 (SCM proc
)
5085 return SCM_SUBRF (proc
) (SCM_EOL
);
5089 scm_i_call_closure_0 (SCM proc
)
5091 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
5094 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
5099 scm_trampoline_0 (SCM proc
)
5101 scm_t_trampoline_0 trampoline
;
5106 switch (SCM_TYP7 (proc
))
5108 case scm_tc7_subr_0
:
5109 trampoline
= call_subr0_0
;
5111 case scm_tc7_subr_1o
:
5112 trampoline
= call_subr1o_0
;
5115 trampoline
= call_lsubr_0
;
5117 case scm_tcs_closures
:
5119 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5120 if (scm_is_null (formals
) || !scm_is_pair (formals
))
5121 trampoline
= scm_i_call_closure_0
;
5126 case scm_tcs_struct
:
5127 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5128 trampoline
= scm_call_generic_0
;
5129 else if (SCM_I_OPERATORP (proc
))
5130 trampoline
= scm_call_0
;
5135 if (SCM_SMOB_APPLICABLE_P (proc
))
5136 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
5141 case scm_tc7_rpsubr
:
5144 trampoline
= scm_call_0
;
5147 return NULL
; /* not applicable on zero arguments */
5149 /* We only reach this point if a valid trampoline was determined. */
5151 /* If debugging is enabled, we want to see all calls to proc on the stack.
5152 * Thus, we replace the trampoline shortcut with scm_call_0. */
5153 if (scm_debug_mode_p
)
5160 call_subr1_1 (SCM proc
, SCM arg1
)
5162 return SCM_SUBRF (proc
) (arg1
);
5166 call_subr2o_1 (SCM proc
, SCM arg1
)
5168 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
5172 call_lsubr_1 (SCM proc
, SCM arg1
)
5174 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
5178 call_dsubr_1 (SCM proc
, SCM arg1
)
5180 if (SCM_I_INUMP (arg1
))
5182 RETURN (scm_from_double (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
))));
5184 else if (SCM_REALP (arg1
))
5186 RETURN (scm_from_double (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
5188 else if (SCM_BIGP (arg1
))
5190 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
5192 else if (SCM_FRACTIONP (arg1
))
5194 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
5196 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
5197 SCM_ARG1
, scm_i_symbol_chars (SCM_SNAME (proc
)));
5201 call_cxr_1 (SCM proc
, SCM arg1
)
5203 return scm_i_chase_pairs (arg1
, (scm_t_bits
) SCM_SUBRF (proc
));
5207 call_closure_1 (SCM proc
, SCM arg1
)
5209 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
5212 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
5217 scm_trampoline_1 (SCM proc
)
5219 scm_t_trampoline_1 trampoline
;
5224 switch (SCM_TYP7 (proc
))
5226 case scm_tc7_subr_1
:
5227 case scm_tc7_subr_1o
:
5228 trampoline
= call_subr1_1
;
5230 case scm_tc7_subr_2o
:
5231 trampoline
= call_subr2o_1
;
5234 trampoline
= call_lsubr_1
;
5237 trampoline
= call_dsubr_1
;
5240 trampoline
= call_cxr_1
;
5242 case scm_tcs_closures
:
5244 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5245 if (!scm_is_null (formals
)
5246 && (!scm_is_pair (formals
) || !scm_is_pair (SCM_CDR (formals
))))
5247 trampoline
= call_closure_1
;
5252 case scm_tcs_struct
:
5253 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5254 trampoline
= scm_call_generic_1
;
5255 else if (SCM_I_OPERATORP (proc
))
5256 trampoline
= scm_call_1
;
5261 if (SCM_SMOB_APPLICABLE_P (proc
))
5262 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
5267 case scm_tc7_rpsubr
:
5270 trampoline
= scm_call_1
;
5273 return NULL
; /* not applicable on one arg */
5275 /* We only reach this point if a valid trampoline was determined. */
5277 /* If debugging is enabled, we want to see all calls to proc on the stack.
5278 * Thus, we replace the trampoline shortcut with scm_call_1. */
5279 if (scm_debug_mode_p
)
5286 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
5288 return SCM_SUBRF (proc
) (arg1
, arg2
);
5292 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
5294 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
5298 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
5300 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
5304 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
5306 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
5307 scm_list_2 (arg1
, arg2
),
5309 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
5314 scm_trampoline_2 (SCM proc
)
5316 scm_t_trampoline_2 trampoline
;
5321 switch (SCM_TYP7 (proc
))
5323 case scm_tc7_subr_2
:
5324 case scm_tc7_subr_2o
:
5325 case scm_tc7_rpsubr
:
5327 trampoline
= call_subr2_2
;
5329 case scm_tc7_lsubr_2
:
5330 trampoline
= call_lsubr2_2
;
5333 trampoline
= call_lsubr_2
;
5335 case scm_tcs_closures
:
5337 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5338 if (!scm_is_null (formals
)
5339 && (!scm_is_pair (formals
)
5340 || (!scm_is_null (SCM_CDR (formals
))
5341 && (!scm_is_pair (SCM_CDR (formals
))
5342 || !scm_is_pair (SCM_CDDR (formals
))))))
5343 trampoline
= call_closure_2
;
5348 case scm_tcs_struct
:
5349 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5350 trampoline
= scm_call_generic_2
;
5351 else if (SCM_I_OPERATORP (proc
))
5352 trampoline
= scm_call_2
;
5357 if (SCM_SMOB_APPLICABLE_P (proc
))
5358 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
5364 trampoline
= scm_call_2
;
5367 return NULL
; /* not applicable on two args */
5369 /* We only reach this point if a valid trampoline was determined. */
5371 /* If debugging is enabled, we want to see all calls to proc on the stack.
5372 * Thus, we replace the trampoline shortcut with scm_call_2. */
5373 if (scm_debug_mode_p
)
5379 /* Typechecking for multi-argument MAP and FOR-EACH.
5381 Verify that each element of the vector ARGV, except for the first,
5382 is a proper list whose length is LEN. Attribute errors to WHO,
5383 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
5385 check_map_args (SCM argv
,
5394 for (i
= SCM_SIMPLE_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
5396 SCM elt
= SCM_SIMPLE_VECTOR_REF (argv
, i
);
5397 long elt_len
= scm_ilength (elt
);
5402 scm_apply_generic (gf
, scm_cons (proc
, args
));
5404 scm_wrong_type_arg (who
, i
+ 2, elt
);
5408 scm_out_of_range_pos (who
, elt
, scm_from_long (i
+ 2));
5413 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
5415 /* Note: Currently, scm_map applies PROC to the argument list(s)
5416 sequentially, starting with the first element(s). This is used in
5417 evalext.c where the Scheme procedure `map-in-order', which guarantees
5418 sequential behaviour, is implemented using scm_map. If the
5419 behaviour changes, we need to update `map-in-order'.
5423 scm_map (SCM proc
, SCM arg1
, SCM args
)
5424 #define FUNC_NAME s_map
5430 len
= scm_ilength (arg1
);
5431 SCM_GASSERTn (len
>= 0,
5432 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
5433 SCM_VALIDATE_REST_ARGUMENT (args
);
5434 if (scm_is_null (args
))
5436 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5437 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
5438 while (SCM_NIMP (arg1
))
5440 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
5441 pres
= SCM_CDRLOC (*pres
);
5442 arg1
= SCM_CDR (arg1
);
5446 if (scm_is_null (SCM_CDR (args
)))
5448 SCM arg2
= SCM_CAR (args
);
5449 int len2
= scm_ilength (arg2
);
5450 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5452 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
5453 SCM_GASSERTn (len2
>= 0,
5454 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
5456 SCM_OUT_OF_RANGE (3, arg2
);
5457 while (SCM_NIMP (arg1
))
5459 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
5460 pres
= SCM_CDRLOC (*pres
);
5461 arg1
= SCM_CDR (arg1
);
5462 arg2
= SCM_CDR (arg2
);
5466 arg1
= scm_cons (arg1
, args
);
5467 args
= scm_vector (arg1
);
5468 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
5472 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5474 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
5477 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
5478 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
5480 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
5481 pres
= SCM_CDRLOC (*pres
);
5487 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
5490 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
5491 #define FUNC_NAME s_for_each
5494 len
= scm_ilength (arg1
);
5495 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
5496 SCM_ARG2
, s_for_each
);
5497 SCM_VALIDATE_REST_ARGUMENT (args
);
5498 if (scm_is_null (args
))
5500 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5501 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
5502 while (SCM_NIMP (arg1
))
5504 call (proc
, SCM_CAR (arg1
));
5505 arg1
= SCM_CDR (arg1
);
5507 return SCM_UNSPECIFIED
;
5509 if (scm_is_null (SCM_CDR (args
)))
5511 SCM arg2
= SCM_CAR (args
);
5512 int len2
= scm_ilength (arg2
);
5513 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5514 SCM_GASSERTn (call
, g_for_each
,
5515 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
5516 SCM_GASSERTn (len2
>= 0, g_for_each
,
5517 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
5519 SCM_OUT_OF_RANGE (3, arg2
);
5520 while (SCM_NIMP (arg1
))
5522 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
5523 arg1
= SCM_CDR (arg1
);
5524 arg2
= SCM_CDR (arg2
);
5526 return SCM_UNSPECIFIED
;
5528 arg1
= scm_cons (arg1
, args
);
5529 args
= scm_vector (arg1
);
5530 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
5534 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5536 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
5538 return SCM_UNSPECIFIED
;
5539 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
5540 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
5542 scm_apply (proc
, arg1
, SCM_EOL
);
5549 scm_closure (SCM code
, SCM env
)
5552 SCM closcar
= scm_cons (code
, SCM_EOL
);
5553 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
5554 scm_remember_upto_here (closcar
);
5559 scm_t_bits scm_tc16_promise
;
5562 scm_makprom (SCM code
)
5564 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
5566 scm_make_recursive_mutex ());
5570 promise_mark (SCM promise
)
5572 scm_gc_mark (SCM_PROMISE_MUTEX (promise
));
5573 return SCM_PROMISE_DATA (promise
);
5577 promise_free (SCM promise
)
5583 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
5585 int writingp
= SCM_WRITINGP (pstate
);
5586 scm_puts ("#<promise ", port
);
5587 SCM_SET_WRITINGP (pstate
, 1);
5588 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
5589 SCM_SET_WRITINGP (pstate
, writingp
);
5590 scm_putc ('>', port
);
5594 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
5596 "If the promise @var{x} has not been computed yet, compute and\n"
5597 "return @var{x}, otherwise just return the previously computed\n"
5599 #define FUNC_NAME s_scm_force
5601 SCM_VALIDATE_SMOB (1, promise
, promise
);
5602 scm_lock_mutex (SCM_PROMISE_MUTEX (promise
));
5603 if (!SCM_PROMISE_COMPUTED_P (promise
))
5605 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
5606 if (!SCM_PROMISE_COMPUTED_P (promise
))
5608 SCM_SET_PROMISE_DATA (promise
, ans
);
5609 SCM_SET_PROMISE_COMPUTED (promise
);
5612 scm_unlock_mutex (SCM_PROMISE_MUTEX (promise
));
5613 return SCM_PROMISE_DATA (promise
);
5618 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
5620 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
5621 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
5622 #define FUNC_NAME s_scm_promise_p
5624 return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
5629 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
5630 (SCM xorig
, SCM x
, SCM y
),
5631 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
5632 "Any source properties associated with @var{xorig} are also associated\n"
5633 "with the new pair.")
5634 #define FUNC_NAME s_scm_cons_source
5637 z
= scm_cons (x
, y
);
5638 /* Copy source properties possibly associated with xorig. */
5639 p
= scm_whash_lookup (scm_source_whash
, xorig
);
5640 if (scm_is_true (p
))
5641 scm_whash_insert (scm_source_whash
, z
, p
);
5647 /* The function scm_copy_tree is used to copy an expression tree to allow the
5648 * memoizer to modify the expression during memoization. scm_copy_tree
5649 * creates deep copies of pairs and vectors, but not of any other data types,
5650 * since only pairs and vectors will be parsed by the memoizer.
5652 * To avoid infinite recursion due to cyclic structures, the hare-and-tortoise
5653 * pattern is used to detect cycles. In fact, the pattern is used in two
5654 * dimensions, vertical (indicated in the code by the variable names 'hare'
5655 * and 'tortoise') and horizontal ('rabbit' and 'turtle'). In both
5656 * dimensions, the hare/rabbit will take two steps when the tortoise/turtle
5659 * The vertical dimension corresponds to recursive calls to function
5660 * copy_tree: This happens when descending into vector elements, into cars of
5661 * lists and into the cdr of an improper list. In this dimension, the
5662 * tortoise follows the hare by using the processor stack: Every stack frame
5663 * will hold an instance of struct t_trace. These instances are connected in
5664 * a way that represents the trace of the hare, which thus can be followed by
5665 * the tortoise. The tortoise will always point to struct t_trace instances
5666 * relating to SCM objects that have already been copied. Thus, a cycle is
5667 * detected if the tortoise and the hare point to the same object,
5669 * The horizontal dimension is within one execution of copy_tree, when the
5670 * function cdr's along the pairs of a list. This is the standard
5671 * hare-and-tortoise implementation, found several times in guile. */
5674 struct t_trace
*trace
; // These pointers form a trace along the stack.
5675 SCM obj
; // The object handled at the respective stack frame.
5680 struct t_trace
*const hare
,
5681 struct t_trace
*tortoise
,
5682 unsigned int tortoise_delay
)
5684 if (!scm_is_pair (hare
->obj
) && !scm_is_simple_vector (hare
->obj
))
5690 /* Prepare the trace along the stack. */
5691 struct t_trace new_hare
;
5692 hare
->trace
= &new_hare
;
5694 /* The tortoise will make its step after the delay has elapsed. Note
5695 * that in contrast to the typical hare-and-tortoise pattern, the step
5696 * of the tortoise happens before the hare takes its steps. This is, in
5697 * principle, no problem, except for the start of the algorithm: Then,
5698 * it has to be made sure that the hare actually gets its advantage of
5700 if (tortoise_delay
== 0)
5703 tortoise
= tortoise
->trace
;
5704 ASSERT_SYNTAX (!scm_is_eq (hare
->obj
, tortoise
->obj
),
5705 s_bad_expression
, hare
->obj
);
5712 if (scm_is_simple_vector (hare
->obj
))
5714 size_t length
= SCM_SIMPLE_VECTOR_LENGTH (hare
->obj
);
5715 SCM new_vector
= scm_c_make_vector (length
, SCM_UNSPECIFIED
);
5717 /* Each vector element is copied by recursing into copy_tree, having
5718 * the tortoise follow the hare into the depths of the stack. */
5719 unsigned long int i
;
5720 for (i
= 0; i
< length
; ++i
)
5723 new_hare
.obj
= SCM_SIMPLE_VECTOR_REF (hare
->obj
, i
);
5724 new_element
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5725 SCM_SIMPLE_VECTOR_SET (new_vector
, i
, new_element
);
5730 else // scm_is_pair (hare->obj)
5735 SCM rabbit
= hare
->obj
;
5736 SCM turtle
= hare
->obj
;
5740 /* The first pair of the list is treated specially, in order to
5741 * preserve a potential source code position. */
5742 result
= tail
= scm_cons_source (rabbit
, SCM_EOL
, SCM_EOL
);
5743 new_hare
.obj
= SCM_CAR (rabbit
);
5744 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5745 SCM_SETCAR (tail
, copy
);
5747 /* The remaining pairs of the list are copied by, horizontally,
5748 * having the turtle follow the rabbit, and, vertically, having the
5749 * tortoise follow the hare into the depths of the stack. */
5750 rabbit
= SCM_CDR (rabbit
);
5751 while (scm_is_pair (rabbit
))
5753 new_hare
.obj
= SCM_CAR (rabbit
);
5754 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5755 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
5756 tail
= SCM_CDR (tail
);
5758 rabbit
= SCM_CDR (rabbit
);
5759 if (scm_is_pair (rabbit
))
5761 new_hare
.obj
= SCM_CAR (rabbit
);
5762 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5763 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
5764 tail
= SCM_CDR (tail
);
5765 rabbit
= SCM_CDR (rabbit
);
5767 turtle
= SCM_CDR (turtle
);
5768 ASSERT_SYNTAX (!scm_is_eq (rabbit
, turtle
),
5769 s_bad_expression
, rabbit
);
5773 /* We have to recurse into copy_tree again for the last cdr, in
5774 * order to handle the situation that it holds a vector. */
5775 new_hare
.obj
= rabbit
;
5776 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5777 SCM_SETCDR (tail
, copy
);
5784 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
5786 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
5787 "the new data structure. @code{copy-tree} recurses down the\n"
5788 "contents of both pairs and vectors (since both cons cells and vector\n"
5789 "cells may point to arbitrary objects), and stops recursing when it hits\n"
5790 "any other object.")
5791 #define FUNC_NAME s_scm_copy_tree
5793 /* Prepare the trace along the stack. */
5794 struct t_trace trace
;
5797 /* In function copy_tree, if the tortoise makes its step, it will do this
5798 * before the hare has the chance to move. Thus, we have to make sure that
5799 * the very first step of the tortoise will not happen after the hare has
5800 * really made two steps. This is achieved by passing '2' as the initial
5801 * delay for the tortoise. NOTE: Since cycles are unlikely, giving the hare
5802 * a bigger advantage may improve performance slightly. */
5803 return copy_tree (&trace
, &trace
, 2);
5808 /* We have three levels of EVAL here:
5810 - scm_i_eval (exp, env)
5812 evaluates EXP in environment ENV. ENV is a lexical environment
5813 structure as used by the actual tree code evaluator. When ENV is
5814 a top-level environment, then changes to the current module are
5815 tracked by updating ENV so that it continues to be in sync with
5818 - scm_primitive_eval (exp)
5820 evaluates EXP in the top-level environment as determined by the
5821 current module. This is done by constructing a suitable
5822 environment and calling scm_i_eval. Thus, changes to the
5823 top-level module are tracked normally.
5825 - scm_eval (exp, mod_or_state)
5827 evaluates EXP while MOD_OR_STATE is the current module or current
5828 dynamic state (as appropriate). This is done by setting the
5829 current module (or dynamic state) to MOD_OR_STATE, invoking
5830 scm_primitive_eval on EXP, and then restoring the current module
5831 (or dynamic state) to the value it had previously. That is,
5832 while EXP is evaluated, changes to the current module (or dynamic
5833 state) are tracked, but these changes do not persist when
5836 For each level of evals, there are two variants, distinguished by a
5837 _x suffix: the ordinary variant does not modify EXP while the _x
5838 variant can destructively modify EXP into something completely
5839 unintelligible. A Scheme data structure passed as EXP to one of the
5840 _x variants should not ever be used again for anything. So when in
5841 doubt, use the ordinary variant.
5846 scm_i_eval_x (SCM exp
, SCM env
)
5848 if (scm_is_symbol (exp
))
5849 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
5851 return SCM_I_XEVAL (exp
, env
);
5855 scm_i_eval (SCM exp
, SCM env
)
5857 exp
= scm_copy_tree (exp
);
5858 if (scm_is_symbol (exp
))
5859 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
5861 return SCM_I_XEVAL (exp
, env
);
5865 scm_primitive_eval_x (SCM exp
)
5868 SCM transformer
= scm_current_module_transformer ();
5869 if (SCM_NIMP (transformer
))
5870 exp
= scm_call_1 (transformer
, exp
);
5871 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5872 return scm_i_eval_x (exp
, env
);
5875 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
5877 "Evaluate @var{exp} in the top-level environment specified by\n"
5878 "the current module.")
5879 #define FUNC_NAME s_scm_primitive_eval
5882 SCM transformer
= scm_current_module_transformer ();
5883 if (scm_is_true (transformer
))
5884 exp
= scm_call_1 (transformer
, exp
);
5885 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5886 return scm_i_eval (exp
, env
);
5891 /* Eval does not take the second arg optionally. This is intentional
5892 * in order to be R5RS compatible, and to prepare for the new module
5893 * system, where we would like to make the choice of evaluation
5894 * environment explicit. */
5897 scm_eval_x (SCM exp
, SCM module_or_state
)
5901 scm_frame_begin (SCM_F_FRAME_REWINDABLE
);
5902 if (scm_is_dynamic_state (module_or_state
))
5903 scm_frame_current_dynamic_state (module_or_state
);
5905 scm_frame_current_module (module_or_state
);
5907 res
= scm_primitive_eval_x (exp
);
5913 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
5914 (SCM exp
, SCM module_or_state
),
5915 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
5916 "in the top-level environment specified by\n"
5917 "@var{module_or_state}.\n"
5918 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
5919 "@var{module_or_state} is made the current module when\n"
5920 "it is a module, or the current dynamic state when it is\n"
5922 "Example: (eval '(+ 1 2) (interaction-environment))")
5923 #define FUNC_NAME s_scm_eval
5927 scm_frame_begin (SCM_F_FRAME_REWINDABLE
);
5928 if (scm_is_dynamic_state (module_or_state
))
5929 scm_frame_current_dynamic_state (module_or_state
);
5931 scm_frame_current_module (module_or_state
);
5933 res
= scm_primitive_eval (exp
);
5941 /* At this point, deval and scm_dapply are generated.
5948 #if (SCM_ENABLE_DEPRECATED == 1)
5950 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5951 SCM
scm_ceval (SCM x
, SCM env
)
5953 if (scm_is_pair (x
))
5954 return ceval (x
, env
);
5955 else if (scm_is_symbol (x
))
5956 return *scm_lookupcar (scm_cons (x
, SCM_UNDEFINED
), env
, 1);
5958 return SCM_I_XEVAL (x
, env
);
5961 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5962 SCM
scm_deval (SCM x
, SCM env
)
5964 if (scm_is_pair (x
))
5965 return deval (x
, env
);
5966 else if (scm_is_symbol (x
))
5967 return *scm_lookupcar (scm_cons (x
, SCM_UNDEFINED
), env
, 1);
5969 return SCM_I_XEVAL (x
, env
);
5973 dispatching_eval (SCM x
, SCM env
)
5975 if (scm_debug_mode_p
)
5976 return scm_deval (x
, env
);
5978 return scm_ceval (x
, env
);
5981 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5982 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
) = dispatching_eval
;
5990 scm_init_opts (scm_evaluator_traps
,
5991 scm_evaluator_trap_table
,
5992 SCM_N_EVALUATOR_TRAPS
);
5993 scm_init_opts (scm_eval_options_interface
,
5995 SCM_N_EVAL_OPTIONS
);
5997 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
5998 scm_set_smob_mark (scm_tc16_promise
, promise_mark
);
5999 scm_set_smob_free (scm_tc16_promise
, promise_free
);
6000 scm_set_smob_print (scm_tc16_promise
, promise_print
);
6002 undefineds
= scm_list_1 (SCM_UNDEFINED
);
6003 SCM_SETCDR (undefineds
, undefineds
);
6004 scm_permanent_object (undefineds
);
6006 scm_listofnull
= scm_list_1 (SCM_EOL
);
6008 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
6009 scm_permanent_object (f_apply
);
6011 #include "libguile/eval.x"
6013 scm_add_feature ("delay");