1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005
2 * Free Software Foundation, Inc.
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public
6 * License as published by the Free Software Foundation; either
7 * version 2.1 of the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
23 /* This file is read twice in order to produce debugging versions of ceval and
24 * scm_apply. These functions, deval and scm_dapply, are produced when we
25 * define the preprocessor macro DEVAL. The file is divided into sections
26 * which are treated differently with respect to DEVAL. The heads of these
27 * sections are marked with the string "SECTION:". */
29 /* SECTION: This code is compiled once.
36 #include "libguile/__scm.h"
40 /* AIX requires this to be the first thing in the file. The #pragma
41 directive is indented so pre-ANSI compilers will ignore it, rather
50 # ifndef alloca /* predefined by HP cc +Olibcalls */
58 #include "libguile/_scm.h"
59 #include "libguile/alist.h"
60 #include "libguile/async.h"
61 #include "libguile/continuations.h"
62 #include "libguile/debug.h"
63 #include "libguile/deprecation.h"
64 #include "libguile/dynwind.h"
65 #include "libguile/eq.h"
66 #include "libguile/feature.h"
67 #include "libguile/fluids.h"
68 #include "libguile/futures.h"
69 #include "libguile/goops.h"
70 #include "libguile/hash.h"
71 #include "libguile/hashtab.h"
72 #include "libguile/lang.h"
73 #include "libguile/list.h"
74 #include "libguile/macros.h"
75 #include "libguile/modules.h"
76 #include "libguile/objects.h"
77 #include "libguile/ports.h"
78 #include "libguile/print.h"
79 #include "libguile/procprop.h"
80 #include "libguile/root.h"
81 #include "libguile/smob.h"
82 #include "libguile/srcprop.h"
83 #include "libguile/stackchk.h"
84 #include "libguile/strings.h"
85 #include "libguile/threads.h"
86 #include "libguile/throw.h"
87 #include "libguile/validate.h"
88 #include "libguile/values.h"
89 #include "libguile/vectors.h"
91 #include "libguile/eval.h"
95 static SCM
unmemoize_exprs (SCM expr
, SCM env
);
96 static SCM
canonicalize_define (SCM expr
);
97 static SCM
*scm_lookupcar1 (SCM vloc
, SCM genv
, int check
);
98 static SCM
unmemoize_builtin_macro (SCM expr
, SCM env
);
99 static void eval_letrec_inits (SCM env
, SCM init_forms
, SCM
**init_values_eol
);
105 * This section defines the message strings for the syntax errors that can be
106 * detected during memoization and the functions and macros that shall be
107 * called by the memoizer code to signal syntax errors. */
110 /* Syntax errors that can be detected during memoization: */
112 /* Circular or improper lists do not form valid scheme expressions. If a
113 * circular list or an improper list is detected in a place where a scheme
114 * expression is expected, a 'Bad expression' error is signalled. */
115 static const char s_bad_expression
[] = "Bad expression";
117 /* If a form is detected that holds a different number of expressions than are
118 * required in that context, a 'Missing or extra expression' error is
120 static const char s_expression
[] = "Missing or extra expression in";
122 /* If a form is detected that holds less expressions than are required in that
123 * context, a 'Missing expression' error is signalled. */
124 static const char s_missing_expression
[] = "Missing expression in";
126 /* If a form is detected that holds more expressions than are allowed in that
127 * context, an 'Extra expression' error is signalled. */
128 static const char s_extra_expression
[] = "Extra expression in";
130 /* The empty combination '()' is not allowed as an expression in scheme. If
131 * it is detected in a place where an expression is expected, an 'Illegal
132 * empty combination' error is signalled. Note: If you encounter this error
133 * message, it is very likely that you intended to denote the empty list. To
134 * do so, you need to quote the empty list like (quote ()) or '(). */
135 static const char s_empty_combination
[] = "Illegal empty combination";
137 /* A body may hold an arbitrary number of internal defines, followed by a
138 * non-empty sequence of expressions. If a body with an empty sequence of
139 * expressions is detected, a 'Missing body expression' error is signalled.
141 static const char s_missing_body_expression
[] = "Missing body expression in";
143 /* A body may hold an arbitrary number of internal defines, followed by a
144 * non-empty sequence of expressions. Each the definitions and the
145 * expressions may be grouped arbitraryly with begin, but it is not allowed to
146 * mix definitions and expressions. If a define form in a body mixes
147 * definitions and expressions, a 'Mixed definitions and expressions' error is
149 static const char s_mixed_body_forms
[] = "Mixed definitions and expressions in";
150 /* Definitions are only allowed on the top level and at the start of a body.
151 * If a definition is detected anywhere else, a 'Bad define placement' error
153 static const char s_bad_define
[] = "Bad define placement";
155 /* Case or cond expressions must have at least one clause. If a case or cond
156 * expression without any clauses is detected, a 'Missing clauses' error is
158 static const char s_missing_clauses
[] = "Missing clauses";
160 /* If there is an 'else' clause in a case or a cond statement, it must be the
161 * last clause. If after the 'else' case clause further clauses are detected,
162 * a 'Misplaced else clause' error is signalled. */
163 static const char s_misplaced_else_clause
[] = "Misplaced else clause";
165 /* If a case clause is detected that is not in the format
166 * (<label(s)> <expression1> <expression2> ...)
167 * a 'Bad case clause' error is signalled. */
168 static const char s_bad_case_clause
[] = "Bad case clause";
170 /* If a case clause is detected where the <label(s)> element is neither a
171 * proper list nor (in case of the last clause) the syntactic keyword 'else',
172 * a 'Bad case labels' error is signalled. Note: If you encounter this error
173 * for an else-clause which seems to be syntactically correct, check if 'else'
174 * is really a syntactic keyword in that context. If 'else' is bound in the
175 * local or global environment, it is not considered a syntactic keyword, but
176 * will be treated as any other variable. */
177 static const char s_bad_case_labels
[] = "Bad case labels";
179 /* In a case statement all labels have to be distinct. If in a case statement
180 * a label occurs more than once, a 'Duplicate case label' error is
182 static const char s_duplicate_case_label
[] = "Duplicate case label";
184 /* If a cond clause is detected that is not in one of the formats
185 * (<test> <expression1> ...) or (else <expression1> <expression2> ...)
186 * a 'Bad cond clause' error is signalled. */
187 static const char s_bad_cond_clause
[] = "Bad cond clause";
189 /* If a cond clause is detected that uses the alternate '=>' form, but does
190 * not hold a recipient element for the test result, a 'Missing recipient'
191 * error is signalled. */
192 static const char s_missing_recipient
[] = "Missing recipient in";
194 /* If in a position where a variable name is required some other object is
195 * detected, a 'Bad variable' error is signalled. */
196 static const char s_bad_variable
[] = "Bad variable";
198 /* Bindings for forms like 'let' and 'do' have to be given in a proper,
199 * possibly empty list. If any other object is detected in a place where a
200 * list of bindings was required, a 'Bad bindings' error is signalled. */
201 static const char s_bad_bindings
[] = "Bad bindings";
203 /* Depending on the syntactic context, a binding has to be in the format
204 * (<variable> <expression>) or (<variable> <expression1> <expression2>).
205 * If anything else is detected in a place where a binding was expected, a
206 * 'Bad binding' error is signalled. */
207 static const char s_bad_binding
[] = "Bad binding";
209 /* Some syntactic forms don't allow variable names to appear more than once in
210 * a list of bindings. If such a situation is nevertheless detected, a
211 * 'Duplicate binding' error is signalled. */
212 static const char s_duplicate_binding
[] = "Duplicate binding";
214 /* If the exit form of a 'do' expression is not in the format
215 * (<test> <expression> ...)
216 * a 'Bad exit clause' error is signalled. */
217 static const char s_bad_exit_clause
[] = "Bad exit clause";
219 /* The formal function arguments of a lambda expression have to be either a
220 * single symbol or a non-cyclic list. For anything else a 'Bad formals'
221 * error is signalled. */
222 static const char s_bad_formals
[] = "Bad formals";
224 /* If in a lambda expression something else than a symbol is detected at a
225 * place where a formal function argument is required, a 'Bad formal' error is
227 static const char s_bad_formal
[] = "Bad formal";
229 /* If in the arguments list of a lambda expression an argument name occurs
230 * more than once, a 'Duplicate formal' error is signalled. */
231 static const char s_duplicate_formal
[] = "Duplicate formal";
233 /* If the evaluation of an unquote-splicing expression gives something else
234 * than a proper list, a 'Non-list result for unquote-splicing' error is
236 static const char s_splicing
[] = "Non-list result for unquote-splicing";
238 /* If something else than an exact integer is detected as the argument for
239 * @slot-ref and @slot-set!, a 'Bad slot number' error is signalled. */
240 static const char s_bad_slot_number
[] = "Bad slot number";
243 /* Signal a syntax error. We distinguish between the form that caused the
244 * error and the enclosing expression. The error message will print out as
245 * shown in the following pattern. The file name and line number are only
246 * given when they can be determined from the erroneous form or from the
247 * enclosing expression.
249 * <filename>: In procedure memoization:
250 * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
252 SCM_SYMBOL (syntax_error_key
, "syntax-error");
254 /* The prototype is needed to indicate that the function does not return. */
256 syntax_error (const char* const, const SCM
, const SCM
) SCM_NORETURN
;
259 syntax_error (const char* const msg
, const SCM form
, const SCM expr
)
261 SCM msg_string
= scm_from_locale_string (msg
);
262 SCM filename
= SCM_BOOL_F
;
263 SCM linenr
= SCM_BOOL_F
;
267 if (scm_is_pair (form
))
269 filename
= scm_source_property (form
, scm_sym_filename
);
270 linenr
= scm_source_property (form
, scm_sym_line
);
273 if (scm_is_false (filename
) && scm_is_false (linenr
) && scm_is_pair (expr
))
275 filename
= scm_source_property (expr
, scm_sym_filename
);
276 linenr
= scm_source_property (expr
, scm_sym_line
);
279 if (!SCM_UNBNDP (expr
))
281 if (scm_is_true (filename
))
283 format
= "In file ~S, line ~S: ~A ~S in expression ~S.";
284 args
= scm_list_5 (filename
, linenr
, msg_string
, form
, expr
);
286 else if (scm_is_true (linenr
))
288 format
= "In line ~S: ~A ~S in expression ~S.";
289 args
= scm_list_4 (linenr
, msg_string
, form
, expr
);
293 format
= "~A ~S in expression ~S.";
294 args
= scm_list_3 (msg_string
, form
, expr
);
299 if (scm_is_true (filename
))
301 format
= "In file ~S, line ~S: ~A ~S.";
302 args
= scm_list_4 (filename
, linenr
, msg_string
, form
);
304 else if (scm_is_true (linenr
))
306 format
= "In line ~S: ~A ~S.";
307 args
= scm_list_3 (linenr
, msg_string
, form
);
312 args
= scm_list_2 (msg_string
, form
);
316 scm_error (syntax_error_key
, "memoization", format
, args
, SCM_BOOL_F
);
320 /* Shortcut macros to simplify syntax error handling. */
321 #define ASSERT_SYNTAX(cond, message, form) \
322 { if (!(cond)) syntax_error (message, form, SCM_UNDEFINED); }
323 #define ASSERT_SYNTAX_2(cond, message, form, expr) \
324 { if (!(cond)) syntax_error (message, form, expr); }
330 * Ilocs are memoized references to variables in local environment frames.
331 * They are represented as three values: The relative offset of the
332 * environment frame, the number of the binding within that frame, and a
333 * boolean value indicating whether the binding is the last binding in the
336 * Frame numbers have 11 bits, relative offsets have 12 bits.
339 #define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc)
340 #define SCM_IFRINC (0x00000100L)
341 #define SCM_ICDR (0x00080000L)
342 #define SCM_IDINC (0x00100000L)
343 #define SCM_IFRAME(n) ((long)((SCM_ICDR-SCM_IFRINC)>>8) \
344 & (SCM_UNPACK (n) >> 8))
345 #define SCM_IDIST(n) (SCM_UNPACK (n) >> 20)
346 #define SCM_ICDRP(n) (SCM_ICDR & SCM_UNPACK (n))
347 #define SCM_IDSTMSK (-SCM_IDINC)
348 #define SCM_IFRAMEMAX ((1<<11)-1)
349 #define SCM_IDISTMAX ((1<<12)-1)
350 #define SCM_MAKE_ILOC(frame_nr, binding_nr, last_p) \
353 + ((binding_nr) << 20) \
354 + ((last_p) ? SCM_ICDR : 0) \
358 scm_i_print_iloc (SCM iloc
, SCM port
)
360 scm_puts ("#@", port
);
361 scm_intprint ((long) SCM_IFRAME (iloc
), 10, port
);
362 scm_putc (SCM_ICDRP (iloc
) ? '-' : '+', port
);
363 scm_intprint ((long) SCM_IDIST (iloc
), 10, port
);
366 #if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
368 SCM
scm_dbg_make_iloc (SCM frame
, SCM binding
, SCM cdrp
);
370 SCM_DEFINE (scm_dbg_make_iloc
, "dbg-make-iloc", 3, 0, 0,
371 (SCM frame
, SCM binding
, SCM cdrp
),
372 "Return a new iloc with frame offset @var{frame}, binding\n"
373 "offset @var{binding} and the cdr flag @var{cdrp}.")
374 #define FUNC_NAME s_scm_dbg_make_iloc
376 return SCM_MAKE_ILOC ((scm_t_bits
) scm_to_unsigned_integer (frame
, 0, SCM_IFRAMEMAX
),
377 (scm_t_bits
) scm_to_unsigned_integer (binding
, 0, SCM_IDISTMAX
),
382 SCM
scm_dbg_iloc_p (SCM obj
);
384 SCM_DEFINE (scm_dbg_iloc_p
, "dbg-iloc?", 1, 0, 0,
386 "Return @code{#t} if @var{obj} is an iloc.")
387 #define FUNC_NAME s_scm_dbg_iloc_p
389 return scm_from_bool (SCM_ILOCP (obj
));
397 /* {Evaluator byte codes (isyms)}
400 #define ISYMNUM(n) (SCM_ITAG8_DATA (n))
402 /* This table must agree with the list of SCM_IM_ constants in tags.h */
403 static const char *const isymnames
[] =
420 "#@call-with-current-continuation",
426 "#@call-with-values",
434 scm_i_print_isym (SCM isym
, SCM port
)
436 const size_t isymnum
= ISYMNUM (isym
);
437 if (isymnum
< (sizeof isymnames
/ sizeof (char *)))
438 scm_puts (isymnames
[isymnum
], port
);
440 scm_ipruk ("isym", isym
, port
);
445 /* The function lookup_symbol is used during memoization: Lookup the symbol in
446 * the environment. If there is no binding for the symbol, SCM_UNDEFINED is
447 * returned. If the symbol is a global variable, the variable object to which
448 * the symbol is bound is returned. Finally, if the symbol is a local
449 * variable the corresponding iloc object is returned. */
451 /* A helper function for lookup_symbol: Try to find the symbol in the top
452 * level environment frame. The function returns SCM_UNDEFINED if the symbol
453 * is unbound and it returns a variable object if the symbol is a global
456 lookup_global_symbol (const SCM symbol
, const SCM top_level
)
458 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
459 if (scm_is_false (variable
))
460 return SCM_UNDEFINED
;
466 lookup_symbol (const SCM symbol
, const SCM env
)
469 unsigned int frame_nr
;
471 for (frame_idx
= env
, frame_nr
= 0;
472 !scm_is_null (frame_idx
);
473 frame_idx
= SCM_CDR (frame_idx
), ++frame_nr
)
475 const SCM frame
= SCM_CAR (frame_idx
);
476 if (scm_is_pair (frame
))
478 /* frame holds a local environment frame */
480 unsigned int symbol_nr
;
482 for (symbol_idx
= SCM_CAR (frame
), symbol_nr
= 0;
483 scm_is_pair (symbol_idx
);
484 symbol_idx
= SCM_CDR (symbol_idx
), ++symbol_nr
)
486 if (scm_is_eq (SCM_CAR (symbol_idx
), symbol
))
487 /* found the symbol, therefore return the iloc */
488 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 0);
490 if (scm_is_eq (symbol_idx
, symbol
))
491 /* found the symbol as the last element of the current frame */
492 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 1);
496 /* no more local environment frames */
497 return lookup_global_symbol (symbol
, frame
);
501 return lookup_global_symbol (symbol
, SCM_BOOL_F
);
505 /* Return true if the symbol is - from the point of view of a macro
506 * transformer - a literal in the sense specified in chapter "pattern
507 * language" of R5RS. In the code below, however, we don't match the
508 * definition of R5RS exactly: It returns true if the identifier has no
509 * binding or if it is a syntactic keyword. */
511 literal_p (const SCM symbol
, const SCM env
)
513 const SCM variable
= lookup_symbol (symbol
, env
);
514 if (SCM_UNBNDP (variable
))
516 if (SCM_VARIABLEP (variable
) && SCM_MACROP (SCM_VARIABLE_REF (variable
)))
523 /* Return true if the expression is self-quoting in the memoized code. Thus,
524 * some other objects (like e. g. vectors) are reported as self-quoting, which
525 * according to R5RS would need to be quoted. */
527 is_self_quoting_p (const SCM expr
)
529 if (scm_is_pair (expr
))
531 else if (scm_is_symbol (expr
))
533 else if (scm_is_null (expr
))
539 SCM_SYMBOL (sym_three_question_marks
, "???");
542 unmemoize_expression (const SCM expr
, const SCM env
)
544 if (SCM_ILOCP (expr
))
547 unsigned long int frame_nr
;
549 unsigned long int symbol_nr
;
551 for (frame_idx
= env
, frame_nr
= SCM_IFRAME (expr
);
553 frame_idx
= SCM_CDR (frame_idx
), --frame_nr
)
555 for (symbol_idx
= SCM_CAAR (frame_idx
), symbol_nr
= SCM_IDIST (expr
);
557 symbol_idx
= SCM_CDR (symbol_idx
), --symbol_nr
)
559 return SCM_ICDRP (expr
) ? symbol_idx
: SCM_CAR (symbol_idx
);
561 else if (SCM_VARIABLEP (expr
))
563 const SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), expr
);
564 return scm_is_true (sym
) ? sym
: sym_three_question_marks
;
566 else if (scm_is_simple_vector (expr
))
568 return scm_list_2 (scm_sym_quote
, expr
);
570 else if (!scm_is_pair (expr
))
574 else if (SCM_ISYMP (SCM_CAR (expr
)))
576 return unmemoize_builtin_macro (expr
, env
);
580 return unmemoize_exprs (expr
, env
);
586 unmemoize_exprs (const SCM exprs
, const SCM env
)
588 SCM r_result
= SCM_EOL
;
589 SCM expr_idx
= exprs
;
592 /* Note that due to the current lazy memoizer we may find partially memoized
593 * code during execution. In such code we have to expect improper lists of
594 * expressions: On the one hand, for such code syntax checks have not yet
595 * fully been performed, on the other hand, there may be even legal code
596 * like '(a . b) appear as an improper list of expressions as long as the
597 * quote expression is still in its unmemoized form. For this reason, the
598 * following code handles improper lists of expressions until memoization
599 * and execution have been completely separated. */
600 for (; scm_is_pair (expr_idx
); expr_idx
= SCM_CDR (expr_idx
))
602 const SCM expr
= SCM_CAR (expr_idx
);
604 /* In partially memoized code, lists of expressions that stem from a
605 * body form may start with an ISYM if the body itself has not yet been
606 * memoized. This isym is just an internal marker to indicate that the
607 * body still needs to be memoized. An isym may occur at the very
608 * beginning of the body or after one or more comment strings. It is
609 * dropped during unmemoization. */
610 if (!SCM_ISYMP (expr
))
612 um_expr
= unmemoize_expression (expr
, env
);
613 r_result
= scm_cons (um_expr
, r_result
);
616 um_expr
= unmemoize_expression (expr_idx
, env
);
617 if (!scm_is_null (r_result
))
619 const SCM result
= scm_reverse_x (r_result
, SCM_UNDEFINED
);
620 SCM_SETCDR (r_result
, um_expr
);
630 /* Rewrite the body (which is given as the list of expressions forming the
631 * body) into its internal form. The internal form of a body (<expr> ...) is
632 * just the body itself, but prefixed with an ISYM that denotes to what kind
633 * of outer construct this body belongs: (<ISYM> <expr> ...). A lambda body
634 * starts with SCM_IM_LAMBDA, for example, a body of a let starts with
637 * It is assumed that the calling expression has already made sure that the
638 * body is a proper list. */
640 m_body (SCM op
, SCM exprs
)
642 /* Don't add another ISYM if one is present already. */
643 if (SCM_ISYMP (SCM_CAR (exprs
)))
646 return scm_cons (op
, exprs
);
650 /* The function m_expand_body memoizes a proper list of expressions forming a
651 * body. This function takes care of dealing with internal defines and
652 * transforming them into an equivalent letrec expression. The list of
653 * expressions is rewritten in place. */
655 /* This is a helper function for m_expand_body. If the argument expression is
656 * a symbol that denotes a syntactic keyword, the corresponding macro object
657 * is returned, in all other cases the function returns SCM_UNDEFINED. */
659 try_macro_lookup (const SCM expr
, const SCM env
)
661 if (scm_is_symbol (expr
))
663 const SCM variable
= lookup_symbol (expr
, env
);
664 if (SCM_VARIABLEP (variable
))
666 const SCM value
= SCM_VARIABLE_REF (variable
);
667 if (SCM_MACROP (value
))
672 return SCM_UNDEFINED
;
675 /* This is a helper function for m_expand_body. It expands user macros,
676 * because for the correct translation of a body we need to know whether they
677 * expand to a definition. */
679 expand_user_macros (SCM expr
, const SCM env
)
681 while (scm_is_pair (expr
))
683 const SCM car_expr
= SCM_CAR (expr
);
684 const SCM new_car
= expand_user_macros (car_expr
, env
);
685 const SCM value
= try_macro_lookup (new_car
, env
);
687 if (SCM_MACROP (value
) && SCM_MACRO_TYPE (value
) == 2)
689 /* User macros transform code into code. */
690 expr
= scm_call_2 (SCM_MACRO_CODE (value
), expr
, env
);
691 /* We need to reiterate on the transformed code. */
695 /* No user macro: return. */
696 SCM_SETCAR (expr
, new_car
);
704 /* This is a helper function for m_expand_body. It determines if a given form
705 * represents an application of a given built-in macro. The built-in macro to
706 * check for is identified by its syntactic keyword. The form is an
707 * application of the given macro if looking up the car of the form in the
708 * given environment actually returns the built-in macro. */
710 is_system_macro_p (const SCM syntactic_keyword
, const SCM form
, const SCM env
)
712 if (scm_is_pair (form
))
714 const SCM car_form
= SCM_CAR (form
);
715 const SCM value
= try_macro_lookup (car_form
, env
);
716 if (SCM_BUILTIN_MACRO_P (value
))
718 const SCM macro_name
= scm_macro_name (value
);
719 return scm_is_eq (macro_name
, syntactic_keyword
);
727 m_expand_body (const SCM forms
, const SCM env
)
729 /* The first body form can be skipped since it is known to be the ISYM that
730 * was prepended to the body by m_body. */
731 SCM cdr_forms
= SCM_CDR (forms
);
732 SCM form_idx
= cdr_forms
;
733 SCM definitions
= SCM_EOL
;
734 SCM sequence
= SCM_EOL
;
736 /* According to R5RS, the list of body forms consists of two parts: a number
737 * (maybe zero) of definitions, followed by a non-empty sequence of
738 * expressions. Each the definitions and the expressions may be grouped
739 * arbitrarily with begin, but it is not allowed to mix definitions and
740 * expressions. The task of the following loop therefore is to split the
741 * list of body forms into the list of definitions and the sequence of
743 while (!scm_is_null (form_idx
))
745 const SCM form
= SCM_CAR (form_idx
);
746 const SCM new_form
= expand_user_macros (form
, env
);
747 if (is_system_macro_p (scm_sym_define
, new_form
, env
))
749 definitions
= scm_cons (new_form
, definitions
);
750 form_idx
= SCM_CDR (form_idx
);
752 else if (is_system_macro_p (scm_sym_begin
, new_form
, env
))
754 /* We have encountered a group of forms. This has to be either a
755 * (possibly empty) group of (possibly further grouped) definitions,
756 * or a non-empty group of (possibly further grouped)
758 const SCM grouped_forms
= SCM_CDR (new_form
);
759 unsigned int found_definition
= 0;
760 unsigned int found_expression
= 0;
761 SCM grouped_form_idx
= grouped_forms
;
762 while (!found_expression
&& !scm_is_null (grouped_form_idx
))
764 const SCM inner_form
= SCM_CAR (grouped_form_idx
);
765 const SCM new_inner_form
= expand_user_macros (inner_form
, env
);
766 if (is_system_macro_p (scm_sym_define
, new_inner_form
, env
))
768 found_definition
= 1;
769 definitions
= scm_cons (new_inner_form
, definitions
);
770 grouped_form_idx
= SCM_CDR (grouped_form_idx
);
772 else if (is_system_macro_p (scm_sym_begin
, new_inner_form
, env
))
774 const SCM inner_group
= SCM_CDR (new_inner_form
);
776 = scm_append (scm_list_2 (inner_group
,
777 SCM_CDR (grouped_form_idx
)));
781 /* The group marks the start of the expressions of the body.
782 * We have to make sure that within the same group we have
783 * not encountered a definition before. */
784 ASSERT_SYNTAX (!found_definition
, s_mixed_body_forms
, form
);
785 found_expression
= 1;
786 grouped_form_idx
= SCM_EOL
;
790 /* We have finished processing the group. If we have not yet
791 * encountered an expression we continue processing the forms of the
792 * body to collect further definition forms. Otherwise, the group
793 * marks the start of the sequence of expressions of the body. */
794 if (!found_expression
)
796 form_idx
= SCM_CDR (form_idx
);
806 /* We have detected a form which is no definition. This marks the
807 * start of the sequence of expressions of the body. */
813 /* FIXME: forms does not hold information about the file location. */
814 ASSERT_SYNTAX (scm_is_pair (sequence
), s_missing_body_expression
, cdr_forms
);
816 if (!scm_is_null (definitions
))
820 SCM letrec_expression
;
821 SCM new_letrec_expression
;
823 SCM bindings
= SCM_EOL
;
824 for (definition_idx
= definitions
;
825 !scm_is_null (definition_idx
);
826 definition_idx
= SCM_CDR (definition_idx
))
828 const SCM definition
= SCM_CAR (definition_idx
);
829 const SCM canonical_definition
= canonicalize_define (definition
);
830 const SCM binding
= SCM_CDR (canonical_definition
);
831 bindings
= scm_cons (binding
, bindings
);
834 letrec_tail
= scm_cons (bindings
, sequence
);
835 /* FIXME: forms does not hold information about the file location. */
836 letrec_expression
= scm_cons_source (forms
, scm_sym_letrec
, letrec_tail
);
837 new_letrec_expression
= scm_m_letrec (letrec_expression
, env
);
838 SCM_SETCAR (forms
, new_letrec_expression
);
839 SCM_SETCDR (forms
, SCM_EOL
);
843 SCM_SETCAR (forms
, SCM_CAR (sequence
));
844 SCM_SETCDR (forms
, SCM_CDR (sequence
));
849 macroexp (SCM x
, SCM env
)
851 SCM res
, proc
, orig_sym
;
853 /* Don't bother to produce error messages here. We get them when we
854 eventually execute the code for real. */
857 orig_sym
= SCM_CAR (x
);
858 if (!scm_is_symbol (orig_sym
))
862 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
863 if (proc_ptr
== NULL
)
865 /* We have lost the race. */
871 /* Only handle memoizing macros. `Acros' and `macros' are really
872 special forms and should not be evaluated here. */
874 if (!SCM_MACROP (proc
)
875 || (SCM_MACRO_TYPE (proc
) != 2 && !SCM_BUILTIN_MACRO_P (proc
)))
878 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
879 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
881 if (scm_ilength (res
) <= 0)
882 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
884 /* njrev: Several queries here: (1) I don't see how it can be
885 correct that the SCM_SETCAR 2 lines below this comment needs
886 protection, but the SCM_SETCAR 6 lines above does not, so
887 something here is probably wrong. (2) macroexp() is now only
888 used in one place - scm_m_generalized_set_x - whereas all other
889 macro expansion happens through expand_user_macros. Therefore
890 (2.1) perhaps macroexp() could be eliminated completely now?
891 (2.2) Does expand_user_macros need any critical section
894 SCM_CRITICAL_SECTION_START
;
895 SCM_SETCAR (x
, SCM_CAR (res
));
896 SCM_SETCDR (x
, SCM_CDR (res
));
897 SCM_CRITICAL_SECTION_END
;
902 /* Start of the memoizers for the standard R5RS builtin macros. */
905 SCM_SYNTAX (s_and
, "and", scm_i_makbimacro
, scm_m_and
);
906 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
909 scm_m_and (SCM expr
, SCM env SCM_UNUSED
)
911 const SCM cdr_expr
= SCM_CDR (expr
);
912 const long length
= scm_ilength (cdr_expr
);
914 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
918 /* Special case: (and) is replaced by #t. */
923 SCM_SETCAR (expr
, SCM_IM_AND
);
929 unmemoize_and (const SCM expr
, const SCM env
)
931 return scm_cons (scm_sym_and
, unmemoize_exprs (SCM_CDR (expr
), env
));
935 SCM_SYNTAX (s_begin
, "begin", scm_i_makbimacro
, scm_m_begin
);
936 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
939 scm_m_begin (SCM expr
, SCM env SCM_UNUSED
)
941 const SCM cdr_expr
= SCM_CDR (expr
);
942 /* Dirk:FIXME:: An empty begin clause is not generally allowed by R5RS.
943 * That means, there should be a distinction between uses of begin where an
944 * empty clause is OK and where it is not. */
945 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
947 SCM_SETCAR (expr
, SCM_IM_BEGIN
);
952 unmemoize_begin (const SCM expr
, const SCM env
)
954 return scm_cons (scm_sym_begin
, unmemoize_exprs (SCM_CDR (expr
), env
));
958 SCM_SYNTAX (s_case
, "case", scm_i_makbimacro
, scm_m_case
);
959 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
960 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
963 scm_m_case (SCM expr
, SCM env
)
966 SCM all_labels
= SCM_EOL
;
968 /* Check, whether 'else is a literal, i. e. not bound to a value. */
969 const int else_literal_p
= literal_p (scm_sym_else
, env
);
971 const SCM cdr_expr
= SCM_CDR (expr
);
972 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
973 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_clauses
, expr
);
975 clauses
= SCM_CDR (cdr_expr
);
976 while (!scm_is_null (clauses
))
980 const SCM clause
= SCM_CAR (clauses
);
981 ASSERT_SYNTAX_2 (scm_ilength (clause
) >= 2,
982 s_bad_case_clause
, clause
, expr
);
984 labels
= SCM_CAR (clause
);
985 if (scm_is_pair (labels
))
987 ASSERT_SYNTAX_2 (scm_ilength (labels
) >= 0,
988 s_bad_case_labels
, labels
, expr
);
989 all_labels
= scm_append (scm_list_2 (labels
, all_labels
));
991 else if (scm_is_null (labels
))
993 /* The list of labels is empty. According to R5RS this is allowed.
994 * It means that the sequence of expressions will never be executed.
995 * Therefore, as an optimization, we could remove the whole
1000 ASSERT_SYNTAX_2 (scm_is_eq (labels
, scm_sym_else
) && else_literal_p
,
1001 s_bad_case_labels
, labels
, expr
);
1002 ASSERT_SYNTAX_2 (scm_is_null (SCM_CDR (clauses
)),
1003 s_misplaced_else_clause
, clause
, expr
);
1006 /* build the new clause */
1007 if (scm_is_eq (labels
, scm_sym_else
))
1008 SCM_SETCAR (clause
, SCM_IM_ELSE
);
1010 clauses
= SCM_CDR (clauses
);
1013 /* Check whether all case labels are distinct. */
1014 for (; !scm_is_null (all_labels
); all_labels
= SCM_CDR (all_labels
))
1016 const SCM label
= SCM_CAR (all_labels
);
1017 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (label
, SCM_CDR (all_labels
))),
1018 s_duplicate_case_label
, label
, expr
);
1021 SCM_SETCAR (expr
, SCM_IM_CASE
);
1026 unmemoize_case (const SCM expr
, const SCM env
)
1028 const SCM um_key_expr
= unmemoize_expression (SCM_CADR (expr
), env
);
1029 SCM um_clauses
= SCM_EOL
;
1032 for (clause_idx
= SCM_CDDR (expr
);
1033 !scm_is_null (clause_idx
);
1034 clause_idx
= SCM_CDR (clause_idx
))
1036 const SCM clause
= SCM_CAR (clause_idx
);
1037 const SCM labels
= SCM_CAR (clause
);
1038 const SCM exprs
= SCM_CDR (clause
);
1040 const SCM um_exprs
= unmemoize_exprs (exprs
, env
);
1041 const SCM um_labels
= (scm_is_eq (labels
, SCM_IM_ELSE
))
1043 : scm_i_finite_list_copy (labels
);
1044 const SCM um_clause
= scm_cons (um_labels
, um_exprs
);
1046 um_clauses
= scm_cons (um_clause
, um_clauses
);
1048 um_clauses
= scm_reverse_x (um_clauses
, SCM_UNDEFINED
);
1050 return scm_cons2 (scm_sym_case
, um_key_expr
, um_clauses
);
1054 SCM_SYNTAX (s_cond
, "cond", scm_i_makbimacro
, scm_m_cond
);
1055 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
1056 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
1059 scm_m_cond (SCM expr
, SCM env
)
1061 /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
1062 const int else_literal_p
= literal_p (scm_sym_else
, env
);
1063 const int arrow_literal_p
= literal_p (scm_sym_arrow
, env
);
1065 const SCM clauses
= SCM_CDR (expr
);
1068 ASSERT_SYNTAX (scm_ilength (clauses
) >= 0, s_bad_expression
, expr
);
1069 ASSERT_SYNTAX (scm_ilength (clauses
) >= 1, s_missing_clauses
, expr
);
1071 for (clause_idx
= clauses
;
1072 !scm_is_null (clause_idx
);
1073 clause_idx
= SCM_CDR (clause_idx
))
1077 const SCM clause
= SCM_CAR (clause_idx
);
1078 const long length
= scm_ilength (clause
);
1079 ASSERT_SYNTAX_2 (length
>= 1, s_bad_cond_clause
, clause
, expr
);
1081 test
= SCM_CAR (clause
);
1082 if (scm_is_eq (test
, scm_sym_else
) && else_literal_p
)
1084 const int last_clause_p
= scm_is_null (SCM_CDR (clause_idx
));
1085 ASSERT_SYNTAX_2 (length
>= 2,
1086 s_bad_cond_clause
, clause
, expr
);
1087 ASSERT_SYNTAX_2 (last_clause_p
,
1088 s_misplaced_else_clause
, clause
, expr
);
1089 SCM_SETCAR (clause
, SCM_IM_ELSE
);
1091 else if (length
>= 2
1092 && scm_is_eq (SCM_CADR (clause
), scm_sym_arrow
)
1095 ASSERT_SYNTAX_2 (length
> 2, s_missing_recipient
, clause
, expr
);
1096 ASSERT_SYNTAX_2 (length
== 3, s_extra_expression
, clause
, expr
);
1097 SCM_SETCAR (SCM_CDR (clause
), SCM_IM_ARROW
);
1099 /* SRFI 61 extended cond */
1100 else if (length
>= 3
1101 && scm_is_eq (SCM_CADDR (clause
), scm_sym_arrow
)
1104 ASSERT_SYNTAX_2 (length
> 3, s_missing_recipient
, clause
, expr
);
1105 ASSERT_SYNTAX_2 (length
== 4, s_extra_expression
, clause
, expr
);
1106 SCM_SETCAR (SCM_CDDR (clause
), SCM_IM_ARROW
);
1110 SCM_SETCAR (expr
, SCM_IM_COND
);
1115 unmemoize_cond (const SCM expr
, const SCM env
)
1117 SCM um_clauses
= SCM_EOL
;
1120 for (clause_idx
= SCM_CDR (expr
);
1121 !scm_is_null (clause_idx
);
1122 clause_idx
= SCM_CDR (clause_idx
))
1124 const SCM clause
= SCM_CAR (clause_idx
);
1125 const SCM sequence
= SCM_CDR (clause
);
1126 const SCM test
= SCM_CAR (clause
);
1131 if (scm_is_eq (test
, SCM_IM_ELSE
))
1132 um_test
= scm_sym_else
;
1134 um_test
= unmemoize_expression (test
, env
);
1136 if (!scm_is_null (sequence
) && scm_is_eq (SCM_CAR (sequence
),
1139 const SCM target
= SCM_CADR (sequence
);
1140 const SCM um_target
= unmemoize_expression (target
, env
);
1141 um_sequence
= scm_list_2 (scm_sym_arrow
, um_target
);
1145 um_sequence
= unmemoize_exprs (sequence
, env
);
1148 um_clause
= scm_cons (um_test
, um_sequence
);
1149 um_clauses
= scm_cons (um_clause
, um_clauses
);
1151 um_clauses
= scm_reverse_x (um_clauses
, SCM_UNDEFINED
);
1153 return scm_cons (scm_sym_cond
, um_clauses
);
1157 SCM_SYNTAX (s_define
, "define", scm_i_makbimacro
, scm_m_define
);
1158 SCM_GLOBAL_SYMBOL (scm_sym_define
, s_define
);
1160 /* Guile provides an extension to R5RS' define syntax to represent function
1161 * currying in a compact way. With this extension, it is allowed to write
1162 * (define <nested-variable> <body>), where <nested-variable> has of one of
1163 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
1164 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
1165 * should be either a sequence of zero or more variables, or a sequence of one
1166 * or more variables followed by a space-delimited period and another
1167 * variable. Each level of argument nesting wraps the <body> within another
1168 * lambda expression. For example, the following forms are allowed, each one
1169 * followed by an equivalent, more explicit implementation.
1171 * (define ((a b . c) . d) <body>) is equivalent to
1172 * (define a (lambda (b . c) (lambda d <body>)))
1174 * (define (((a) b) c . d) <body>) is equivalent to
1175 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
1177 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
1178 * module that does not implement this extension. */
1180 canonicalize_define (const SCM expr
)
1185 const SCM cdr_expr
= SCM_CDR (expr
);
1186 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1187 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1189 body
= SCM_CDR (cdr_expr
);
1190 variable
= SCM_CAR (cdr_expr
);
1191 while (scm_is_pair (variable
))
1193 /* This while loop realizes function currying by variable nesting.
1194 * Variable is known to be a nested-variable. In every iteration of the
1195 * loop another level of lambda expression is created, starting with the
1196 * innermost one. Note that we don't check for duplicate formals here:
1197 * This will be done by the memoizer of the lambda expression. */
1198 const SCM formals
= SCM_CDR (variable
);
1199 const SCM tail
= scm_cons (formals
, body
);
1201 /* Add source properties to each new lambda expression: */
1202 const SCM lambda
= scm_cons_source (variable
, scm_sym_lambda
, tail
);
1204 body
= scm_list_1 (lambda
);
1205 variable
= SCM_CAR (variable
);
1207 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
1208 ASSERT_SYNTAX (scm_ilength (body
) == 1, s_expression
, expr
);
1210 SCM_SETCAR (cdr_expr
, variable
);
1211 SCM_SETCDR (cdr_expr
, body
);
1215 /* According to section 5.2.1 of R5RS we first have to make sure that the
1216 * variable is bound, and then perform the (set! variable expression)
1217 * operation. This means, that within the expression we may already assign
1218 * values to variable: (define foo (begin (set! foo 1) (+ foo 1))) */
1220 scm_m_define (SCM expr
, SCM env
)
1222 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), s_bad_define
, expr
);
1225 const SCM canonical_definition
= canonicalize_define (expr
);
1226 const SCM cdr_canonical_definition
= SCM_CDR (canonical_definition
);
1227 const SCM variable
= SCM_CAR (cdr_canonical_definition
);
1229 = scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_T
);
1230 const SCM value
= scm_eval_car (SCM_CDR (cdr_canonical_definition
), env
);
1232 if (SCM_REC_PROCNAMES_P
)
1235 while (SCM_MACROP (tmp
))
1236 tmp
= SCM_MACRO_CODE (tmp
);
1237 if (SCM_CLOSUREP (tmp
)
1238 /* Only the first definition determines the name. */
1239 && scm_is_false (scm_procedure_property (tmp
, scm_sym_name
)))
1240 scm_set_procedure_property_x (tmp
, scm_sym_name
, variable
);
1243 SCM_VARIABLE_SET (location
, value
);
1245 return SCM_UNSPECIFIED
;
1250 /* This is a helper function for forms (<keyword> <expression>) that are
1251 * transformed into (#@<keyword> '() <memoized_expression>) in order to allow
1252 * for easy creation of a thunk (i. e. a closure without arguments) using the
1253 * ('() <memoized_expression>) tail of the memoized form. */
1255 memoize_as_thunk_prototype (const SCM expr
, const SCM env SCM_UNUSED
)
1257 const SCM cdr_expr
= SCM_CDR (expr
);
1258 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1259 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1261 SCM_SETCDR (expr
, scm_cons (SCM_EOL
, cdr_expr
));
1267 SCM_SYNTAX (s_delay
, "delay", scm_i_makbimacro
, scm_m_delay
);
1268 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
1270 /* Promises are implemented as closures with an empty parameter list. Thus,
1271 * (delay <expression>) is transformed into (#@delay '() <expression>), where
1272 * the empty list represents the empty parameter list. This representation
1273 * allows for easy creation of the closure during evaluation. */
1275 scm_m_delay (SCM expr
, SCM env
)
1277 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1278 SCM_SETCAR (new_expr
, SCM_IM_DELAY
);
1283 unmemoize_delay (const SCM expr
, const SCM env
)
1285 const SCM thunk_expr
= SCM_CADDR (expr
);
1286 return scm_list_2 (scm_sym_delay
, unmemoize_expression (thunk_expr
, env
));
1290 SCM_SYNTAX(s_do
, "do", scm_i_makbimacro
, scm_m_do
);
1291 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
1293 /* DO gets the most radically altered syntax. The order of the vars is
1294 * reversed here. During the evaluation this allows for simple consing of the
1295 * results of the inits and steps:
1297 (do ((<var1> <init1> <step1>)
1305 (#@do (<init1> <init2> ... <initn>)
1306 (varn ... var2 var1)
1309 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
1312 scm_m_do (SCM expr
, SCM env SCM_UNUSED
)
1314 SCM variables
= SCM_EOL
;
1315 SCM init_forms
= SCM_EOL
;
1316 SCM step_forms
= SCM_EOL
;
1323 const SCM cdr_expr
= SCM_CDR (expr
);
1324 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1325 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1327 /* Collect variables, init and step forms. */
1328 binding_idx
= SCM_CAR (cdr_expr
);
1329 ASSERT_SYNTAX_2 (scm_ilength (binding_idx
) >= 0,
1330 s_bad_bindings
, binding_idx
, expr
);
1331 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1333 const SCM binding
= SCM_CAR (binding_idx
);
1334 const long length
= scm_ilength (binding
);
1335 ASSERT_SYNTAX_2 (length
== 2 || length
== 3,
1336 s_bad_binding
, binding
, expr
);
1339 const SCM name
= SCM_CAR (binding
);
1340 const SCM init
= SCM_CADR (binding
);
1341 const SCM step
= (length
== 2) ? name
: SCM_CADDR (binding
);
1342 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
1343 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, variables
)),
1344 s_duplicate_binding
, name
, expr
);
1346 variables
= scm_cons (name
, variables
);
1347 init_forms
= scm_cons (init
, init_forms
);
1348 step_forms
= scm_cons (step
, step_forms
);
1351 init_forms
= scm_reverse_x (init_forms
, SCM_UNDEFINED
);
1352 step_forms
= scm_reverse_x (step_forms
, SCM_UNDEFINED
);
1354 /* Memoize the test form and the exit sequence. */
1355 cddr_expr
= SCM_CDR (cdr_expr
);
1356 exit_clause
= SCM_CAR (cddr_expr
);
1357 ASSERT_SYNTAX_2 (scm_ilength (exit_clause
) >= 1,
1358 s_bad_exit_clause
, exit_clause
, expr
);
1360 commands
= SCM_CDR (cddr_expr
);
1361 tail
= scm_cons2 (exit_clause
, commands
, step_forms
);
1362 tail
= scm_cons2 (init_forms
, variables
, tail
);
1363 SCM_SETCAR (expr
, SCM_IM_DO
);
1364 SCM_SETCDR (expr
, tail
);
1369 unmemoize_do (const SCM expr
, const SCM env
)
1371 const SCM cdr_expr
= SCM_CDR (expr
);
1372 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1373 const SCM rnames
= SCM_CAR (cddr_expr
);
1374 const SCM extended_env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
1375 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
1376 const SCM exit_sequence
= SCM_CAR (cdddr_expr
);
1377 const SCM um_exit_sequence
= unmemoize_exprs (exit_sequence
, extended_env
);
1378 const SCM cddddr_expr
= SCM_CDR (cdddr_expr
);
1379 const SCM um_body
= unmemoize_exprs (SCM_CAR (cddddr_expr
), extended_env
);
1381 /* build transformed binding list */
1382 SCM um_names
= scm_reverse (rnames
);
1383 SCM um_inits
= unmemoize_exprs (SCM_CAR (cdr_expr
), env
);
1384 SCM um_steps
= unmemoize_exprs (SCM_CDR (cddddr_expr
), extended_env
);
1385 SCM um_bindings
= SCM_EOL
;
1386 while (!scm_is_null (um_names
))
1388 const SCM name
= SCM_CAR (um_names
);
1389 const SCM init
= SCM_CAR (um_inits
);
1390 SCM step
= SCM_CAR (um_steps
);
1391 step
= scm_is_eq (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
1393 um_bindings
= scm_cons (scm_cons2 (name
, init
, step
), um_bindings
);
1395 um_names
= SCM_CDR (um_names
);
1396 um_inits
= SCM_CDR (um_inits
);
1397 um_steps
= SCM_CDR (um_steps
);
1399 um_bindings
= scm_reverse_x (um_bindings
, SCM_UNDEFINED
);
1401 return scm_cons (scm_sym_do
,
1402 scm_cons2 (um_bindings
, um_exit_sequence
, um_body
));
1406 SCM_SYNTAX (s_if
, "if", scm_i_makbimacro
, scm_m_if
);
1407 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
1410 scm_m_if (SCM expr
, SCM env SCM_UNUSED
)
1412 const SCM cdr_expr
= SCM_CDR (expr
);
1413 const long length
= scm_ilength (cdr_expr
);
1414 ASSERT_SYNTAX (length
== 2 || length
== 3, s_expression
, expr
);
1415 SCM_SETCAR (expr
, SCM_IM_IF
);
1420 unmemoize_if (const SCM expr
, const SCM env
)
1422 const SCM cdr_expr
= SCM_CDR (expr
);
1423 const SCM um_condition
= unmemoize_expression (SCM_CAR (cdr_expr
), env
);
1424 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1425 const SCM um_then
= unmemoize_expression (SCM_CAR (cddr_expr
), env
);
1426 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
1428 if (scm_is_null (cdddr_expr
))
1430 return scm_list_3 (scm_sym_if
, um_condition
, um_then
);
1434 const SCM um_else
= unmemoize_expression (SCM_CAR (cdddr_expr
), env
);
1435 return scm_list_4 (scm_sym_if
, um_condition
, um_then
, um_else
);
1440 SCM_SYNTAX (s_lambda
, "lambda", scm_i_makbimacro
, scm_m_lambda
);
1441 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
1443 /* A helper function for memoize_lambda to support checking for duplicate
1444 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
1445 * LIST or to the cdr of the last cons. Therefore, LIST may have any of the
1446 * forms that a formal argument can have:
1447 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
1449 c_improper_memq (SCM obj
, SCM list
)
1451 for (; scm_is_pair (list
); list
= SCM_CDR (list
))
1453 if (scm_is_eq (SCM_CAR (list
), obj
))
1456 return scm_is_eq (list
, obj
);
1460 scm_m_lambda (SCM expr
, SCM env SCM_UNUSED
)
1469 const SCM cdr_expr
= SCM_CDR (expr
);
1470 const long length
= scm_ilength (cdr_expr
);
1471 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1472 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1474 /* Before iterating the list of formal arguments, make sure the formals
1475 * actually are given as either a symbol or a non-cyclic list. */
1476 formals
= SCM_CAR (cdr_expr
);
1477 if (scm_is_pair (formals
))
1479 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
1480 * detected, report a 'Bad formals' error. */
1484 ASSERT_SYNTAX_2 (scm_is_symbol (formals
) || scm_is_null (formals
),
1485 s_bad_formals
, formals
, expr
);
1488 /* Now iterate the list of formal arguments to check if all formals are
1489 * symbols, and that there are no duplicates. */
1490 formals_idx
= formals
;
1491 while (scm_is_pair (formals_idx
))
1493 const SCM formal
= SCM_CAR (formals_idx
);
1494 const SCM next_idx
= SCM_CDR (formals_idx
);
1495 ASSERT_SYNTAX_2 (scm_is_symbol (formal
), s_bad_formal
, formal
, expr
);
1496 ASSERT_SYNTAX_2 (!c_improper_memq (formal
, next_idx
),
1497 s_duplicate_formal
, formal
, expr
);
1498 formals_idx
= next_idx
;
1500 ASSERT_SYNTAX_2 (scm_is_null (formals_idx
) || scm_is_symbol (formals_idx
),
1501 s_bad_formal
, formals_idx
, expr
);
1503 /* Memoize the body. Keep a potential documentation string. */
1504 /* Dirk:FIXME:: We should probably extract the documentation string to
1505 * some external database. Otherwise it will slow down execution, since
1506 * the documentation string will have to be skipped with every execution
1507 * of the closure. */
1508 cddr_expr
= SCM_CDR (cdr_expr
);
1509 documentation
= (length
>= 3 && scm_is_string (SCM_CAR (cddr_expr
)));
1510 body
= documentation
? SCM_CDR (cddr_expr
) : cddr_expr
;
1511 new_body
= m_body (SCM_IM_LAMBDA
, body
);
1513 SCM_SETCAR (expr
, SCM_IM_LAMBDA
);
1515 SCM_SETCDR (cddr_expr
, new_body
);
1517 SCM_SETCDR (cdr_expr
, new_body
);
1522 unmemoize_lambda (const SCM expr
, const SCM env
)
1524 const SCM formals
= SCM_CADR (expr
);
1525 const SCM body
= SCM_CDDR (expr
);
1527 const SCM new_env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, env
);
1528 const SCM um_formals
= scm_i_finite_list_copy (formals
);
1529 const SCM um_body
= unmemoize_exprs (body
, new_env
);
1531 return scm_cons2 (scm_sym_lambda
, um_formals
, um_body
);
1535 /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
1537 check_bindings (const SCM bindings
, const SCM expr
)
1541 ASSERT_SYNTAX_2 (scm_ilength (bindings
) >= 0,
1542 s_bad_bindings
, bindings
, expr
);
1544 binding_idx
= bindings
;
1545 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1547 SCM name
; /* const */
1549 const SCM binding
= SCM_CAR (binding_idx
);
1550 ASSERT_SYNTAX_2 (scm_ilength (binding
) == 2,
1551 s_bad_binding
, binding
, expr
);
1553 name
= SCM_CAR (binding
);
1554 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
1559 /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
1560 * transformed to the lists (vn ... v2 v1) and (i1 i2 ... in). That is, the
1561 * variables are returned in a list with their order reversed, and the init
1562 * forms are returned in a list in the same order as they are given in the
1563 * bindings. If a duplicate variable name is detected, an error is
1566 transform_bindings (
1567 const SCM bindings
, const SCM expr
,
1568 SCM
*const rvarptr
, SCM
*const initptr
)
1570 SCM rvariables
= SCM_EOL
;
1571 SCM rinits
= SCM_EOL
;
1572 SCM binding_idx
= bindings
;
1573 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1575 const SCM binding
= SCM_CAR (binding_idx
);
1576 const SCM cdr_binding
= SCM_CDR (binding
);
1577 const SCM name
= SCM_CAR (binding
);
1578 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, rvariables
)),
1579 s_duplicate_binding
, name
, expr
);
1580 rvariables
= scm_cons (name
, rvariables
);
1581 rinits
= scm_cons (SCM_CAR (cdr_binding
), rinits
);
1583 *rvarptr
= rvariables
;
1584 *initptr
= scm_reverse_x (rinits
, SCM_UNDEFINED
);
1588 SCM_SYNTAX(s_let
, "let", scm_i_makbimacro
, scm_m_let
);
1589 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
1591 /* This function is a helper function for memoize_let. It transforms
1592 * (let name ((var init) ...) body ...) into
1593 * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
1594 * and memoizes the expression. It is assumed that the caller has checked
1595 * that name is a symbol and that there are bindings and a body. */
1597 memoize_named_let (const SCM expr
, const SCM env SCM_UNUSED
)
1603 const SCM cdr_expr
= SCM_CDR (expr
);
1604 const SCM name
= SCM_CAR (cdr_expr
);
1605 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1606 const SCM bindings
= SCM_CAR (cddr_expr
);
1607 check_bindings (bindings
, expr
);
1609 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1610 variables
= scm_reverse_x (rvariables
, SCM_UNDEFINED
);
1613 const SCM let_body
= SCM_CDR (cddr_expr
);
1614 const SCM lambda_body
= m_body (SCM_IM_LET
, let_body
);
1615 const SCM lambda_tail
= scm_cons (variables
, lambda_body
);
1616 const SCM lambda_form
= scm_cons_source (expr
, scm_sym_lambda
, lambda_tail
);
1618 const SCM rvar
= scm_list_1 (name
);
1619 const SCM init
= scm_list_1 (lambda_form
);
1620 const SCM body
= m_body (SCM_IM_LET
, scm_list_1 (name
));
1621 const SCM letrec_tail
= scm_cons (rvar
, scm_cons (init
, body
));
1622 const SCM letrec_form
= scm_cons_source (expr
, SCM_IM_LETREC
, letrec_tail
);
1623 return scm_cons_source (expr
, letrec_form
, inits
);
1627 /* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1628 * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
1630 scm_m_let (SCM expr
, SCM env
)
1634 const SCM cdr_expr
= SCM_CDR (expr
);
1635 const long length
= scm_ilength (cdr_expr
);
1636 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1637 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1639 bindings
= SCM_CAR (cdr_expr
);
1640 if (scm_is_symbol (bindings
))
1642 ASSERT_SYNTAX (length
>= 3, s_missing_expression
, expr
);
1643 return memoize_named_let (expr
, env
);
1646 check_bindings (bindings
, expr
);
1647 if (scm_is_null (bindings
) || scm_is_null (SCM_CDR (bindings
)))
1649 /* Special case: no bindings or single binding => let* is faster. */
1650 const SCM body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1651 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), bindings
, body
), env
);
1658 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1661 const SCM new_body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1662 const SCM new_tail
= scm_cons2 (rvariables
, inits
, new_body
);
1663 SCM_SETCAR (expr
, SCM_IM_LET
);
1664 SCM_SETCDR (expr
, new_tail
);
1671 build_binding_list (SCM rnames
, SCM rinits
)
1673 SCM bindings
= SCM_EOL
;
1674 while (!scm_is_null (rnames
))
1676 const SCM binding
= scm_list_2 (SCM_CAR (rnames
), SCM_CAR (rinits
));
1677 bindings
= scm_cons (binding
, bindings
);
1678 rnames
= SCM_CDR (rnames
);
1679 rinits
= SCM_CDR (rinits
);
1685 unmemoize_let (const SCM expr
, const SCM env
)
1687 const SCM cdr_expr
= SCM_CDR (expr
);
1688 const SCM um_rnames
= SCM_CAR (cdr_expr
);
1689 const SCM extended_env
= SCM_EXTEND_ENV (um_rnames
, SCM_EOL
, env
);
1690 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1691 const SCM um_inits
= unmemoize_exprs (SCM_CAR (cddr_expr
), env
);
1692 const SCM um_rinits
= scm_reverse_x (um_inits
, SCM_UNDEFINED
);
1693 const SCM um_bindings
= build_binding_list (um_rnames
, um_rinits
);
1694 const SCM um_body
= unmemoize_exprs (SCM_CDR (cddr_expr
), extended_env
);
1696 return scm_cons2 (scm_sym_let
, um_bindings
, um_body
);
1700 SCM_SYNTAX(s_letrec
, "letrec", scm_i_makbimacro
, scm_m_letrec
);
1701 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
1704 scm_m_letrec (SCM expr
, SCM env
)
1708 const SCM cdr_expr
= SCM_CDR (expr
);
1709 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1710 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1712 bindings
= SCM_CAR (cdr_expr
);
1713 if (scm_is_null (bindings
))
1715 /* no bindings, let* is executed faster */
1716 SCM body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1717 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), SCM_EOL
, body
), env
);
1725 check_bindings (bindings
, expr
);
1726 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1727 new_body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1728 return scm_cons2 (SCM_IM_LETREC
, rvariables
, scm_cons (inits
, new_body
));
1733 unmemoize_letrec (const SCM expr
, const SCM env
)
1735 const SCM cdr_expr
= SCM_CDR (expr
);
1736 const SCM um_rnames
= SCM_CAR (cdr_expr
);
1737 const SCM extended_env
= SCM_EXTEND_ENV (um_rnames
, SCM_EOL
, env
);
1738 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1739 const SCM um_inits
= unmemoize_exprs (SCM_CAR (cddr_expr
), extended_env
);
1740 const SCM um_rinits
= scm_reverse_x (um_inits
, SCM_UNDEFINED
);
1741 const SCM um_bindings
= build_binding_list (um_rnames
, um_rinits
);
1742 const SCM um_body
= unmemoize_exprs (SCM_CDR (cddr_expr
), extended_env
);
1744 return scm_cons2 (scm_sym_letrec
, um_bindings
, um_body
);
1749 SCM_SYNTAX (s_letstar
, "let*", scm_i_makbimacro
, scm_m_letstar
);
1750 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
1752 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1753 * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
1755 scm_m_letstar (SCM expr
, SCM env SCM_UNUSED
)
1760 const SCM cdr_expr
= SCM_CDR (expr
);
1761 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1762 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1764 binding_idx
= SCM_CAR (cdr_expr
);
1765 check_bindings (binding_idx
, expr
);
1767 /* Transform ((v1 i1) (v2 i2) ...) into (v1 i1 v2 i2 ...). The
1768 * transformation is done in place. At the beginning of one iteration of
1769 * the loop the variable binding_idx holds the form
1770 * P1:( (vn . P2:(in . ())) . P3:( (vn+1 in+1) ... ) ),
1771 * where P1, P2 and P3 indicate the pairs, that are relevant for the
1772 * transformation. P1 and P2 are modified in the loop, P3 remains
1773 * untouched. After the execution of the loop, P1 will hold
1774 * P1:( vn . P2:(in . P3:( (vn+1 in+1) ... )) )
1775 * and binding_idx will hold P3. */
1776 while (!scm_is_null (binding_idx
))
1778 const SCM cdr_binding_idx
= SCM_CDR (binding_idx
); /* remember P3 */
1779 const SCM binding
= SCM_CAR (binding_idx
);
1780 const SCM name
= SCM_CAR (binding
);
1781 const SCM cdr_binding
= SCM_CDR (binding
);
1783 SCM_SETCDR (cdr_binding
, cdr_binding_idx
); /* update P2 */
1784 SCM_SETCAR (binding_idx
, name
); /* update P1 */
1785 SCM_SETCDR (binding_idx
, cdr_binding
); /* update P1 */
1787 binding_idx
= cdr_binding_idx
; /* continue with P3 */
1790 new_body
= m_body (SCM_IM_LETSTAR
, SCM_CDR (cdr_expr
));
1791 SCM_SETCAR (expr
, SCM_IM_LETSTAR
);
1792 /* the bindings have been changed in place */
1793 SCM_SETCDR (cdr_expr
, new_body
);
1798 unmemoize_letstar (const SCM expr
, const SCM env
)
1800 const SCM cdr_expr
= SCM_CDR (expr
);
1801 const SCM body
= SCM_CDR (cdr_expr
);
1802 SCM bindings
= SCM_CAR (cdr_expr
);
1803 SCM um_bindings
= SCM_EOL
;
1804 SCM extended_env
= env
;
1807 while (!scm_is_null (bindings
))
1809 const SCM variable
= SCM_CAR (bindings
);
1810 const SCM init
= SCM_CADR (bindings
);
1811 const SCM um_init
= unmemoize_expression (init
, extended_env
);
1812 um_bindings
= scm_cons (scm_list_2 (variable
, um_init
), um_bindings
);
1813 extended_env
= SCM_EXTEND_ENV (variable
, SCM_BOOL_F
, extended_env
);
1814 bindings
= SCM_CDDR (bindings
);
1816 um_bindings
= scm_reverse_x (um_bindings
, SCM_UNDEFINED
);
1818 um_body
= unmemoize_exprs (body
, extended_env
);
1820 return scm_cons2 (scm_sym_letstar
, um_bindings
, um_body
);
1824 SCM_SYNTAX (s_or
, "or", scm_i_makbimacro
, scm_m_or
);
1825 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
1828 scm_m_or (SCM expr
, SCM env SCM_UNUSED
)
1830 const SCM cdr_expr
= SCM_CDR (expr
);
1831 const long length
= scm_ilength (cdr_expr
);
1833 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1837 /* Special case: (or) is replaced by #f. */
1842 SCM_SETCAR (expr
, SCM_IM_OR
);
1848 unmemoize_or (const SCM expr
, const SCM env
)
1850 return scm_cons (scm_sym_or
, unmemoize_exprs (SCM_CDR (expr
), env
));
1854 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
1855 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
1856 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
1857 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
1859 /* Internal function to handle a quasiquotation: 'form' is the parameter in
1860 * the call (quasiquotation form), 'env' is the environment where unquoted
1861 * expressions will be evaluated, and 'depth' is the current quasiquotation
1862 * nesting level and is known to be greater than zero. */
1864 iqq (SCM form
, SCM env
, unsigned long int depth
)
1866 if (scm_is_pair (form
))
1868 const SCM tmp
= SCM_CAR (form
);
1869 if (scm_is_eq (tmp
, scm_sym_quasiquote
))
1871 const SCM args
= SCM_CDR (form
);
1872 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1873 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
1875 else if (scm_is_eq (tmp
, scm_sym_unquote
))
1877 const SCM args
= SCM_CDR (form
);
1878 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1880 return scm_eval_car (args
, env
);
1882 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
1884 else if (scm_is_pair (tmp
)
1885 && scm_is_eq (SCM_CAR (tmp
), scm_sym_uq_splicing
))
1887 const SCM args
= SCM_CDR (tmp
);
1888 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1891 const SCM list
= scm_eval_car (args
, env
);
1892 const SCM rest
= SCM_CDR (form
);
1893 ASSERT_SYNTAX_2 (scm_ilength (list
) >= 0,
1894 s_splicing
, list
, form
);
1895 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
1898 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
1899 iqq (SCM_CDR (form
), env
, depth
));
1902 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
1903 iqq (SCM_CDR (form
), env
, depth
));
1905 else if (scm_is_vector (form
))
1906 return scm_vector (iqq (scm_vector_to_list (form
), env
, depth
));
1912 scm_m_quasiquote (SCM expr
, SCM env
)
1914 const SCM cdr_expr
= SCM_CDR (expr
);
1915 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1916 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1917 return iqq (SCM_CAR (cdr_expr
), env
, 1);
1921 SCM_SYNTAX (s_quote
, "quote", scm_i_makbimacro
, scm_m_quote
);
1922 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
1925 scm_m_quote (SCM expr
, SCM env SCM_UNUSED
)
1929 const SCM cdr_expr
= SCM_CDR (expr
);
1930 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1931 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1932 quotee
= SCM_CAR (cdr_expr
);
1933 if (is_self_quoting_p (quotee
))
1936 SCM_SETCAR (expr
, SCM_IM_QUOTE
);
1937 SCM_SETCDR (expr
, quotee
);
1942 unmemoize_quote (const SCM expr
, const SCM env SCM_UNUSED
)
1944 return scm_list_2 (scm_sym_quote
, SCM_CDR (expr
));
1948 /* Will go into the RnRS module when Guile is factorized.
1949 SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
1950 static const char s_set_x
[] = "set!";
1951 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, s_set_x
);
1954 scm_m_set_x (SCM expr
, SCM env SCM_UNUSED
)
1959 const SCM cdr_expr
= SCM_CDR (expr
);
1960 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1961 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1962 variable
= SCM_CAR (cdr_expr
);
1964 /* Memoize the variable form. */
1965 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
1966 new_variable
= lookup_symbol (variable
, env
);
1967 /* Leave the memoization of unbound symbols to lazy memoization: */
1968 if (SCM_UNBNDP (new_variable
))
1969 new_variable
= variable
;
1971 SCM_SETCAR (expr
, SCM_IM_SET_X
);
1972 SCM_SETCAR (cdr_expr
, new_variable
);
1977 unmemoize_set_x (const SCM expr
, const SCM env
)
1979 return scm_cons (scm_sym_set_x
, unmemoize_exprs (SCM_CDR (expr
), env
));
1983 /* Start of the memoizers for non-R5RS builtin macros. */
1986 SCM_SYNTAX (s_atapply
, "@apply", scm_i_makbimacro
, scm_m_apply
);
1987 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1988 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1991 scm_m_apply (SCM expr
, SCM env SCM_UNUSED
)
1993 const SCM cdr_expr
= SCM_CDR (expr
);
1994 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1995 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_missing_expression
, expr
);
1997 SCM_SETCAR (expr
, SCM_IM_APPLY
);
2002 unmemoize_apply (const SCM expr
, const SCM env
)
2004 return scm_list_2 (scm_sym_atapply
, unmemoize_exprs (SCM_CDR (expr
), env
));
2008 SCM_SYNTAX (s_atbind
, "@bind", scm_i_makbimacro
, scm_m_atbind
);
2010 /* FIXME: The following explanation should go into the documentation: */
2011 /* (@bind ((var init) ...) body ...) will assign the values of the `init's to
2012 * the global variables named by `var's (symbols, not evaluated), creating
2013 * them if they don't exist, executes body, and then restores the previous
2014 * values of the `var's. Additionally, whenever control leaves body, the
2015 * values of the `var's are saved and restored when control returns. It is an
2016 * error when a symbol appears more than once among the `var's. All `init's
2017 * are evaluated before any `var' is set.
2019 * Think of this as `let' for dynamic scope.
2022 /* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into
2023 * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...).
2025 * FIXME - also implement `@bind*'.
2028 scm_m_atbind (SCM expr
, SCM env
)
2035 const SCM top_level
= scm_env_top_level (env
);
2037 const SCM cdr_expr
= SCM_CDR (expr
);
2038 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2039 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
2040 bindings
= SCM_CAR (cdr_expr
);
2041 check_bindings (bindings
, expr
);
2042 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
2044 for (variable_idx
= rvariables
;
2045 !scm_is_null (variable_idx
);
2046 variable_idx
= SCM_CDR (variable_idx
))
2048 /* The first call to scm_sym2var will look beyond the current module,
2049 * while the second call wont. */
2050 const SCM variable
= SCM_CAR (variable_idx
);
2051 SCM new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_F
);
2052 if (scm_is_false (new_variable
))
2053 new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_T
);
2054 SCM_SETCAR (variable_idx
, new_variable
);
2057 SCM_SETCAR (expr
, SCM_IM_BIND
);
2058 SCM_SETCAR (cdr_expr
, scm_cons (rvariables
, inits
));
2063 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_i_makbimacro
, scm_m_cont
);
2064 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, s_atcall_cc
);
2067 scm_m_cont (SCM expr
, SCM env SCM_UNUSED
)
2069 const SCM cdr_expr
= SCM_CDR (expr
);
2070 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2071 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2073 SCM_SETCAR (expr
, SCM_IM_CONT
);
2078 unmemoize_atcall_cc (const SCM expr
, const SCM env
)
2080 return scm_list_2 (scm_sym_atcall_cc
, unmemoize_exprs (SCM_CDR (expr
), env
));
2084 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_i_makbimacro
, scm_m_at_call_with_values
);
2085 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
2088 scm_m_at_call_with_values (SCM expr
, SCM env SCM_UNUSED
)
2090 const SCM cdr_expr
= SCM_CDR (expr
);
2091 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2092 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2094 SCM_SETCAR (expr
, SCM_IM_CALL_WITH_VALUES
);
2099 unmemoize_at_call_with_values (const SCM expr
, const SCM env
)
2101 return scm_list_2 (scm_sym_at_call_with_values
,
2102 unmemoize_exprs (SCM_CDR (expr
), env
));
2106 SCM_SYNTAX (s_future
, "future", scm_i_makbimacro
, scm_m_future
);
2107 SCM_GLOBAL_SYMBOL (scm_sym_future
, s_future
);
2109 /* Like promises, futures are implemented as closures with an empty
2110 * parameter list. Thus, (future <expression>) is transformed into
2111 * (#@future '() <expression>), where the empty list represents the
2112 * empty parameter list. This representation allows for easy creation
2113 * of the closure during evaluation. */
2115 scm_m_future (SCM expr
, SCM env
)
2117 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
2118 SCM_SETCAR (new_expr
, SCM_IM_FUTURE
);
2123 unmemoize_future (const SCM expr
, const SCM env
)
2125 const SCM thunk_expr
= SCM_CADDR (expr
);
2126 return scm_list_2 (scm_sym_future
, unmemoize_expression (thunk_expr
, env
));
2130 SCM_SYNTAX (s_gset_x
, "set!", scm_i_makbimacro
, scm_m_generalized_set_x
);
2131 SCM_SYMBOL (scm_sym_setter
, "setter");
2134 scm_m_generalized_set_x (SCM expr
, SCM env
)
2136 SCM target
, exp_target
;
2138 const SCM cdr_expr
= SCM_CDR (expr
);
2139 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2140 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2142 target
= SCM_CAR (cdr_expr
);
2143 if (!scm_is_pair (target
))
2146 return scm_m_set_x (expr
, env
);
2150 /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */
2151 /* Macroexpanding the target might return things of the form
2152 (begin <atom>). In that case, <atom> must be a symbol or a
2153 variable and we memoize to (set! <atom> ...).
2155 exp_target
= macroexp (target
, env
);
2156 if (scm_is_eq (SCM_CAR (exp_target
), SCM_IM_BEGIN
)
2157 && !scm_is_null (SCM_CDR (exp_target
))
2158 && scm_is_null (SCM_CDDR (exp_target
)))
2160 exp_target
= SCM_CADR (exp_target
);
2161 ASSERT_SYNTAX_2 (scm_is_symbol (exp_target
)
2162 || SCM_VARIABLEP (exp_target
),
2163 s_bad_variable
, exp_target
, expr
);
2164 return scm_cons (SCM_IM_SET_X
, scm_cons (exp_target
,
2165 SCM_CDR (cdr_expr
)));
2169 const SCM setter_proc_tail
= scm_list_1 (SCM_CAR (target
));
2170 const SCM setter_proc
= scm_cons_source (expr
, scm_sym_setter
,
2173 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
2174 const SCM setter_args
= scm_append_x (scm_list_2 (SCM_CDR (target
),
2177 SCM_SETCAR (expr
, setter_proc
);
2178 SCM_SETCDR (expr
, setter_args
);
2185 /* @slot-ref is bound privately in the (oop goops) module from goops.c. As
2186 * soon as the module system allows us to more freely create bindings in
2187 * arbitrary modules during the startup phase, the code from goops.c should be
2190 SCM_SYMBOL (sym_atslot_ref
, "@slot-ref");
2193 scm_m_atslot_ref (SCM expr
, SCM env SCM_UNUSED
)
2197 const SCM cdr_expr
= SCM_CDR (expr
);
2198 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2199 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2200 slot_nr
= SCM_CADR (cdr_expr
);
2201 ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2203 SCM_SETCAR (expr
, SCM_IM_SLOT_REF
);
2204 SCM_SETCDR (cdr_expr
, slot_nr
);
2209 unmemoize_atslot_ref (const SCM expr
, const SCM env
)
2211 const SCM instance
= SCM_CADR (expr
);
2212 const SCM um_instance
= unmemoize_expression (instance
, env
);
2213 const SCM slot_nr
= SCM_CDDR (expr
);
2214 return scm_list_3 (sym_atslot_ref
, um_instance
, slot_nr
);
2218 /* @slot-set! is bound privately in the (oop goops) module from goops.c. As
2219 * soon as the module system allows us to more freely create bindings in
2220 * arbitrary modules during the startup phase, the code from goops.c should be
2223 SCM_SYMBOL (sym_atslot_set_x
, "@slot-set!");
2226 scm_m_atslot_set_x (SCM expr
, SCM env SCM_UNUSED
)
2230 const SCM cdr_expr
= SCM_CDR (expr
);
2231 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2232 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 3, s_expression
, expr
);
2233 slot_nr
= SCM_CADR (cdr_expr
);
2234 ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2236 SCM_SETCAR (expr
, SCM_IM_SLOT_SET_X
);
2241 unmemoize_atslot_set_x (const SCM expr
, const SCM env
)
2243 const SCM cdr_expr
= SCM_CDR (expr
);
2244 const SCM instance
= SCM_CAR (cdr_expr
);
2245 const SCM um_instance
= unmemoize_expression (instance
, env
);
2246 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
2247 const SCM slot_nr
= SCM_CAR (cddr_expr
);
2248 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
2249 const SCM value
= SCM_CAR (cdddr_expr
);
2250 const SCM um_value
= unmemoize_expression (value
, env
);
2251 return scm_list_4 (sym_atslot_set_x
, um_instance
, slot_nr
, um_value
);
2255 #if SCM_ENABLE_ELISP
2257 static const char s_defun
[] = "Symbol's function definition is void";
2259 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_i_makbimacro
, scm_m_nil_cond
);
2261 /* nil-cond expressions have the form
2262 * (nil-cond COND VAL COND VAL ... ELSEVAL) */
2264 scm_m_nil_cond (SCM expr
, SCM env SCM_UNUSED
)
2266 const long length
= scm_ilength (SCM_CDR (expr
));
2267 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
2268 ASSERT_SYNTAX (length
>= 1 && (length
% 2) == 1, s_expression
, expr
);
2270 SCM_SETCAR (expr
, SCM_IM_NIL_COND
);
2275 SCM_SYNTAX (s_atfop
, "@fop", scm_i_makbimacro
, scm_m_atfop
);
2277 /* The @fop-macro handles procedure and macro applications for elisp. The
2278 * input expression must have the form
2279 * (@fop <var> (transformer-macro <expr> ...))
2280 * where <var> must be a symbol. The expression is transformed into the
2281 * memoized form of either
2282 * (apply <un-aliased var> (transformer-macro <expr> ...))
2283 * if the value of var (across all aliasing) is not a macro, or
2284 * (<un-aliased var> <expr> ...)
2285 * if var is a macro. */
2287 scm_m_atfop (SCM expr
, SCM env SCM_UNUSED
)
2292 const SCM cdr_expr
= SCM_CDR (expr
);
2293 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2294 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 1, s_missing_expression
, expr
);
2296 symbol
= SCM_CAR (cdr_expr
);
2297 ASSERT_SYNTAX_2 (scm_is_symbol (symbol
), s_bad_variable
, symbol
, expr
);
2299 location
= scm_symbol_fref (symbol
);
2300 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2302 /* The elisp function `defalias' allows to define aliases for symbols. To
2303 * look up such definitions, the chain of symbol definitions has to be
2304 * followed up to the terminal symbol. */
2305 while (scm_is_symbol (SCM_VARIABLE_REF (location
)))
2307 const SCM alias
= SCM_VARIABLE_REF (location
);
2308 location
= scm_symbol_fref (alias
);
2309 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2312 /* Memoize the value location belonging to the terminal symbol. */
2313 SCM_SETCAR (cdr_expr
, location
);
2315 if (!SCM_MACROP (SCM_VARIABLE_REF (location
)))
2317 /* Since the location does not contain a macro, the form is a procedure
2318 * application. Replace `@fop' by `@apply' and transform the expression
2319 * including the `transformer-macro'. */
2320 SCM_SETCAR (expr
, SCM_IM_APPLY
);
2325 /* Since the location contains a macro, the arguments should not be
2326 * transformed, so the `transformer-macro' is cut out. The resulting
2327 * expression starts with the memoized variable, that is at the cdr of
2328 * the input expression. */
2329 SCM_SETCDR (cdr_expr
, SCM_CDADR (cdr_expr
));
2334 #endif /* SCM_ENABLE_ELISP */
2338 unmemoize_builtin_macro (const SCM expr
, const SCM env
)
2340 switch (ISYMNUM (SCM_CAR (expr
)))
2342 case (ISYMNUM (SCM_IM_AND
)):
2343 return unmemoize_and (expr
, env
);
2345 case (ISYMNUM (SCM_IM_BEGIN
)):
2346 return unmemoize_begin (expr
, env
);
2348 case (ISYMNUM (SCM_IM_CASE
)):
2349 return unmemoize_case (expr
, env
);
2351 case (ISYMNUM (SCM_IM_COND
)):
2352 return unmemoize_cond (expr
, env
);
2354 case (ISYMNUM (SCM_IM_DELAY
)):
2355 return unmemoize_delay (expr
, env
);
2357 case (ISYMNUM (SCM_IM_DO
)):
2358 return unmemoize_do (expr
, env
);
2360 case (ISYMNUM (SCM_IM_IF
)):
2361 return unmemoize_if (expr
, env
);
2363 case (ISYMNUM (SCM_IM_LAMBDA
)):
2364 return unmemoize_lambda (expr
, env
);
2366 case (ISYMNUM (SCM_IM_LET
)):
2367 return unmemoize_let (expr
, env
);
2369 case (ISYMNUM (SCM_IM_LETREC
)):
2370 return unmemoize_letrec (expr
, env
);
2372 case (ISYMNUM (SCM_IM_LETSTAR
)):
2373 return unmemoize_letstar (expr
, env
);
2375 case (ISYMNUM (SCM_IM_OR
)):
2376 return unmemoize_or (expr
, env
);
2378 case (ISYMNUM (SCM_IM_QUOTE
)):
2379 return unmemoize_quote (expr
, env
);
2381 case (ISYMNUM (SCM_IM_SET_X
)):
2382 return unmemoize_set_x (expr
, env
);
2384 case (ISYMNUM (SCM_IM_APPLY
)):
2385 return unmemoize_apply (expr
, env
);
2387 case (ISYMNUM (SCM_IM_BIND
)):
2388 return unmemoize_exprs (expr
, env
); /* FIXME */
2390 case (ISYMNUM (SCM_IM_CONT
)):
2391 return unmemoize_atcall_cc (expr
, env
);
2393 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2394 return unmemoize_at_call_with_values (expr
, env
);
2396 case (ISYMNUM (SCM_IM_FUTURE
)):
2397 return unmemoize_future (expr
, env
);
2399 case (ISYMNUM (SCM_IM_SLOT_REF
)):
2400 return unmemoize_atslot_ref (expr
, env
);
2402 case (ISYMNUM (SCM_IM_SLOT_SET_X
)):
2403 return unmemoize_atslot_set_x (expr
, env
);
2405 case (ISYMNUM (SCM_IM_NIL_COND
)):
2406 return unmemoize_exprs (expr
, env
); /* FIXME */
2409 return unmemoize_exprs (expr
, env
); /* FIXME */
2414 /* scm_i_unmemocopy_expr and scm_i_unmemocopy_body take a memoized expression
2415 * respectively a memoized body together with its environment and rewrite it
2416 * to its original form. Thus, these functions are the inversion of the
2417 * rewrite rules above. The procedure is not optimized for speed. It's used
2418 * in scm_i_unmemoize_expr, scm_procedure_source, macro_print and scm_iprin1.
2420 * Unmemoizing is not a reliable process. You cannot in general expect to get
2421 * the original source back.
2423 * However, GOOPS currently relies on this for method compilation. This ought
2427 scm_i_unmemocopy_expr (SCM expr
, SCM env
)
2429 const SCM source_properties
= scm_whash_lookup (scm_source_whash
, expr
);
2430 const SCM um_expr
= unmemoize_expression (expr
, env
);
2432 if (scm_is_true (source_properties
))
2433 scm_whash_insert (scm_source_whash
, um_expr
, source_properties
);
2439 scm_i_unmemocopy_body (SCM forms
, SCM env
)
2441 const SCM source_properties
= scm_whash_lookup (scm_source_whash
, forms
);
2442 const SCM um_forms
= unmemoize_exprs (forms
, env
);
2444 if (scm_is_true (source_properties
))
2445 scm_whash_insert (scm_source_whash
, um_forms
, source_properties
);
2451 #if (SCM_ENABLE_DEPRECATED == 1)
2453 /* Deprecated in guile 1.7.0 on 2003-11-09. */
2455 scm_m_expand_body (SCM exprs
, SCM env
)
2457 scm_c_issue_deprecation_warning
2458 ("`scm_m_expand_body' is deprecated.");
2459 m_expand_body (exprs
, env
);
2464 SCM_SYNTAX (s_undefine
, "undefine", scm_makacro
, scm_m_undefine
);
2467 scm_m_undefine (SCM expr
, SCM env
)
2472 const SCM cdr_expr
= SCM_CDR (expr
);
2473 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), "Bad undefine placement in", expr
);
2474 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2475 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2477 scm_c_issue_deprecation_warning
2478 ("`undefine' is deprecated.\n");
2480 variable
= SCM_CAR (cdr_expr
);
2481 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
2482 location
= scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_F
);
2483 ASSERT_SYNTAX_2 (scm_is_true (location
)
2484 && !SCM_UNBNDP (SCM_VARIABLE_REF (location
)),
2485 "variable already unbound ", variable
, expr
);
2486 SCM_VARIABLE_SET (location
, SCM_UNDEFINED
);
2487 return SCM_UNSPECIFIED
;
2491 scm_macroexp (SCM x
, SCM env
)
2493 scm_c_issue_deprecation_warning
2494 ("`scm_macroexp' is deprecated.");
2495 return macroexp (x
, env
);
2501 #if (SCM_ENABLE_DEPRECATED == 1)
2504 scm_unmemocar (SCM form
, SCM env
)
2506 scm_c_issue_deprecation_warning
2507 ("`scm_unmemocar' is deprecated.");
2509 if (!scm_is_pair (form
))
2513 SCM c
= SCM_CAR (form
);
2514 if (SCM_VARIABLEP (c
))
2516 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
2517 if (scm_is_false (sym
))
2518 sym
= sym_three_question_marks
;
2519 SCM_SETCAR (form
, sym
);
2521 else if (SCM_ILOCP (c
))
2523 unsigned long int ir
;
2525 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
2526 env
= SCM_CDR (env
);
2527 env
= SCM_CAAR (env
);
2528 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
2529 env
= SCM_CDR (env
);
2531 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
2539 /*****************************************************************************/
2540 /*****************************************************************************/
2541 /* The definitions for execution start here. */
2542 /*****************************************************************************/
2543 /*****************************************************************************/
2545 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
2546 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
2547 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
2548 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
2549 SCM_SYMBOL (sym_instead
, "instead");
2551 /* A function object to implement "apply" for non-closure functions. */
2553 /* An endless list consisting of #<undefined> objects: */
2554 static SCM undefineds
;
2558 scm_badargsp (SCM formals
, SCM args
)
2560 while (!scm_is_null (formals
))
2562 if (!scm_is_pair (formals
))
2564 if (scm_is_null (args
))
2566 formals
= SCM_CDR (formals
);
2567 args
= SCM_CDR (args
);
2569 return !scm_is_null (args
) ? 1 : 0;
2574 /* The evaluator contains a plethora of EVAL symbols. This is an attempt at
2577 * The following macros should be used in code which is read twice (where the
2578 * choice of evaluator is hard soldered):
2580 * CEVAL is the symbol used within one evaluator to call itself.
2581 * Originally, it is defined to ceval, but is redefined to deval during the
2584 * SCM_I_EVALIM is used when it is known that the expression is an
2585 * immediate. (This macro never calls an evaluator.)
2587 * EVAL evaluates an expression that is expected to have its symbols already
2588 * memoized. Expressions that are not of the form '(<form> <form> ...)' are
2589 * evaluated inline without calling an evaluator.
2591 * EVALCAR evaluates the car of an expression 'X:(Y:<form> <form> ...)',
2592 * potentially replacing a symbol at the position Y:<form> by its memoized
2593 * variable. If Y:<form> is not of the form '(<form> <form> ...)', the
2594 * evaluation is performed inline without calling an evaluator.
2596 * The following macros should be used in code which is read once
2597 * (where the choice of evaluator is dynamic):
2599 * SCM_I_XEVAL corresponds to EVAL, but uses ceval *or* deval depending on the
2602 * SCM_I_XEVALCAR corresponds to EVALCAR, but uses ceval *or* deval depending
2603 * on the debugging mode.
2605 * The main motivation for keeping this plethora is efficiency
2606 * together with maintainability (=> locality of code).
2609 static SCM
ceval (SCM x
, SCM env
);
2610 static SCM
deval (SCM x
, SCM env
);
2614 #define SCM_I_EVALIM2(x) \
2615 ((scm_is_eq ((x), SCM_EOL) \
2616 ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \
2620 #define SCM_I_EVALIM(x, env) (SCM_ILOCP (x) \
2621 ? *scm_ilookup ((x), (env)) \
2624 #define SCM_I_XEVAL(x, env) \
2626 ? SCM_I_EVALIM2 (x) \
2627 : (SCM_VARIABLEP (x) \
2628 ? SCM_VARIABLE_REF (x) \
2629 : (scm_is_pair (x) \
2630 ? (scm_debug_mode_p \
2631 ? deval ((x), (env)) \
2632 : ceval ((x), (env))) \
2635 #define SCM_I_XEVALCAR(x, env) \
2636 (SCM_IMP (SCM_CAR (x)) \
2637 ? SCM_I_EVALIM (SCM_CAR (x), (env)) \
2638 : (SCM_VARIABLEP (SCM_CAR (x)) \
2639 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2640 : (scm_is_pair (SCM_CAR (x)) \
2641 ? (scm_debug_mode_p \
2642 ? deval (SCM_CAR (x), (env)) \
2643 : ceval (SCM_CAR (x), (env))) \
2644 : (!scm_is_symbol (SCM_CAR (x)) \
2646 : *scm_lookupcar ((x), (env), 1)))))
2648 #define EVAL(x, env) \
2650 ? SCM_I_EVALIM ((x), (env)) \
2651 : (SCM_VARIABLEP (x) \
2652 ? SCM_VARIABLE_REF (x) \
2653 : (scm_is_pair (x) \
2654 ? CEVAL ((x), (env)) \
2657 #define EVALCAR(x, env) \
2658 (SCM_IMP (SCM_CAR (x)) \
2659 ? SCM_I_EVALIM (SCM_CAR (x), (env)) \
2660 : (SCM_VARIABLEP (SCM_CAR (x)) \
2661 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2662 : (scm_is_pair (SCM_CAR (x)) \
2663 ? CEVAL (SCM_CAR (x), (env)) \
2664 : (!scm_is_symbol (SCM_CAR (x)) \
2666 : *scm_lookupcar ((x), (env), 1)))))
2668 scm_i_pthread_mutex_t source_mutex
;
2671 /* Lookup a given local variable in an environment. The local variable is
2672 * given as an iloc, that is a triple <frame, binding, last?>, where frame
2673 * indicates the relative number of the environment frame (counting upwards
2674 * from the innermost environment frame), binding indicates the number of the
2675 * binding within the frame, and last? (which is extracted from the iloc using
2676 * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
2677 * very end of the improper list of bindings. */
2679 scm_ilookup (SCM iloc
, SCM env
)
2681 unsigned int frame_nr
= SCM_IFRAME (iloc
);
2682 unsigned int binding_nr
= SCM_IDIST (iloc
);
2686 for (; 0 != frame_nr
; --frame_nr
)
2687 frames
= SCM_CDR (frames
);
2689 bindings
= SCM_CAR (frames
);
2690 for (; 0 != binding_nr
; --binding_nr
)
2691 bindings
= SCM_CDR (bindings
);
2693 if (SCM_ICDRP (iloc
))
2694 return SCM_CDRLOC (bindings
);
2695 return SCM_CARLOC (SCM_CDR (bindings
));
2699 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
2701 static void error_unbound_variable (SCM symbol
) SCM_NORETURN
;
2702 static void error_defined_variable (SCM symbol
) SCM_NORETURN
;
2704 /* Call this for variables that are unfound.
2707 error_unbound_variable (SCM symbol
)
2709 scm_error (scm_unbound_variable_key
, NULL
,
2710 "Unbound variable: ~S",
2711 scm_list_1 (symbol
), SCM_BOOL_F
);
2714 /* Call this for variables that are found but contain SCM_UNDEFINED.
2717 error_defined_variable (SCM symbol
)
2719 /* We use the 'unbound-variable' key here as well, since it
2720 basically is the same kind of error, with a slight variation in
2721 the displayed message.
2723 scm_error (scm_unbound_variable_key
, NULL
,
2724 "Variable used before given a value: ~S",
2725 scm_list_1 (symbol
), SCM_BOOL_F
);
2729 /* The Lookup Car Race
2732 Memoization of variables and special forms is done while executing
2733 the code for the first time. As long as there is only one thread
2734 everything is fine, but as soon as two threads execute the same
2735 code concurrently `for the first time' they can come into conflict.
2737 This memoization includes rewriting variable references into more
2738 efficient forms and expanding macros. Furthermore, macro expansion
2739 includes `compiling' special forms like `let', `cond', etc. into
2740 tree-code instructions.
2742 There shouldn't normally be a problem with memoizing local and
2743 global variable references (into ilocs and variables), because all
2744 threads will mutate the code in *exactly* the same way and (if I
2745 read the C code correctly) it is not possible to observe a half-way
2746 mutated cons cell. The lookup procedure can handle this
2747 transparently without any critical sections.
2749 It is different with macro expansion, because macro expansion
2750 happens outside of the lookup procedure and can't be
2751 undone. Therefore the lookup procedure can't cope with it. It has
2752 to indicate failure when it detects a lost race and hope that the
2753 caller can handle it. Luckily, it turns out that this is the case.
2755 An example to illustrate this: Suppose that the following form will
2756 be memoized concurrently by two threads
2760 Let's first examine the lookup of X in the body. The first thread
2761 decides that it has to find the symbol "x" in the environment and
2762 starts to scan it. Then the other thread takes over and actually
2763 overtakes the first. It looks up "x" and substitutes an
2764 appropriate iloc for it. Now the first thread continues and
2765 completes its lookup. It comes to exactly the same conclusions as
2766 the second one and could - without much ado - just overwrite the
2767 iloc with the same iloc.
2769 But let's see what will happen when the race occurs while looking
2770 up the symbol "let" at the start of the form. It could happen that
2771 the second thread interrupts the lookup of the first thread and not
2772 only substitutes a variable for it but goes right ahead and
2773 replaces it with the compiled form (#@let* (x 12) x). Now, when
2774 the first thread completes its lookup, it would replace the #@let*
2775 with a variable containing the "let" binding, effectively reverting
2776 the form to (let (x 12) x). This is wrong. It has to detect that
2777 it has lost the race and the evaluator has to reconsider the
2778 changed form completely.
2780 This race condition could be resolved with some kind of traffic
2781 light (like mutexes) around scm_lookupcar, but I think that it is
2782 best to avoid them in this case. They would serialize memoization
2783 completely and because lookup involves calling arbitrary Scheme
2784 code (via the lookup-thunk), threads could be blocked for an
2785 arbitrary amount of time or even deadlock. But with the current
2786 solution a lot of unnecessary work is potentially done. */
2788 /* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
2789 return NULL to indicate a failed lookup due to some race conditions
2790 between threads. This only happens when VLOC is the first cell of
2791 a special form that will eventually be memoized (like `let', etc.)
2792 In that case the whole lookup is bogus and the caller has to
2793 reconsider the complete special form.
2795 SCM_LOOKUPCAR is still there, of course. It just calls
2796 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
2797 should only be called when it is known that VLOC is not the first
2798 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
2799 for NULL. I think I've found the only places where this
2803 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
2806 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
2807 register SCM iloc
= SCM_ILOC00
;
2808 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
2810 if (!scm_is_pair (SCM_CAR (env
)))
2812 al
= SCM_CARLOC (env
);
2813 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
2815 if (!scm_is_pair (fl
))
2817 if (scm_is_eq (fl
, var
))
2819 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2821 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
2822 return SCM_CDRLOC (*al
);
2827 al
= SCM_CDRLOC (*al
);
2828 if (scm_is_eq (SCM_CAR (fl
), var
))
2830 if (SCM_UNBNDP (SCM_CAR (*al
)))
2831 error_defined_variable (var
);
2832 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2834 SCM_SETCAR (vloc
, iloc
);
2835 return SCM_CARLOC (*al
);
2837 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
2839 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
2842 SCM top_thunk
, real_var
;
2845 top_thunk
= SCM_CAR (env
); /* env now refers to a
2846 top level env thunk */
2847 env
= SCM_CDR (env
);
2850 top_thunk
= SCM_BOOL_F
;
2851 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
2852 if (scm_is_false (real_var
))
2855 if (!scm_is_null (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
2860 if (scm_is_null (env
))
2861 error_unbound_variable (var
);
2863 scm_misc_error (NULL
, "Damaged environment: ~S",
2868 /* A variable could not be found, but we shall
2869 not throw an error. */
2870 static SCM undef_object
= SCM_UNDEFINED
;
2871 return &undef_object
;
2875 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2877 /* Some other thread has changed the very cell we are working
2878 on. In effect, it must have done our job or messed it up
2881 var
= SCM_CAR (vloc
);
2882 if (SCM_VARIABLEP (var
))
2883 return SCM_VARIABLE_LOC (var
);
2884 if (SCM_ILOCP (var
))
2885 return scm_ilookup (var
, genv
);
2886 /* We can't cope with anything else than variables and ilocs. When
2887 a special form has been memoized (i.e. `let' into `#@let') we
2888 return NULL and expect the calling function to do the right
2889 thing. For the evaluator, this means going back and redoing
2890 the dispatch on the car of the form. */
2894 SCM_SETCAR (vloc
, real_var
);
2895 return SCM_VARIABLE_LOC (real_var
);
2900 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
2902 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
2909 /* During execution, look up a symbol in the top level of the given local
2910 * environment and return the corresponding variable object. If no binding
2911 * for the symbol can be found, an 'Unbound variable' error is signalled. */
2913 lazy_memoize_variable (const SCM symbol
, const SCM environment
)
2915 const SCM top_level
= scm_env_top_level (environment
);
2916 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
2918 if (scm_is_false (variable
))
2919 error_unbound_variable (symbol
);
2926 scm_eval_car (SCM pair
, SCM env
)
2928 return SCM_I_XEVALCAR (pair
, env
);
2933 scm_eval_args (SCM l
, SCM env
, SCM proc
)
2935 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
2936 while (scm_is_pair (l
))
2938 res
= EVALCAR (l
, env
);
2940 *lloc
= scm_list_1 (res
);
2941 lloc
= SCM_CDRLOC (*lloc
);
2944 if (!scm_is_null (l
))
2945 scm_wrong_num_args (proc
);
2951 scm_eval_body (SCM code
, SCM env
)
2956 next
= SCM_CDR (code
);
2957 while (!scm_is_null (next
))
2959 if (SCM_IMP (SCM_CAR (code
)))
2961 if (SCM_ISYMP (SCM_CAR (code
)))
2963 scm_i_scm_pthread_mutex_lock (&source_mutex
);
2964 /* check for race condition */
2965 if (SCM_ISYMP (SCM_CAR (code
)))
2966 m_expand_body (code
, env
);
2967 scm_i_pthread_mutex_unlock (&source_mutex
);
2972 SCM_I_XEVAL (SCM_CAR (code
), env
);
2974 next
= SCM_CDR (code
);
2976 return SCM_I_XEVALCAR (code
, env
);
2982 /* SECTION: This code is specific for the debugging support. One
2983 * branch is read when DEVAL isn't defined, the other when DEVAL is
2989 #define SCM_APPLY scm_apply
2990 #define PREP_APPLY(proc, args)
2992 #define RETURN(x) do { return x; } while (0)
2993 #ifdef STACK_CHECKING
2994 #ifndef NO_CEVAL_STACK_CHECKING
2995 #define EVAL_STACK_CHECKING
3002 #define CEVAL deval /* Substitute all uses of ceval */
3005 #define SCM_APPLY scm_dapply
3008 #define PREP_APPLY(p, l) \
3009 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
3012 #define ENTER_APPLY \
3014 SCM_SET_ARGSREADY (debug);\
3015 if (scm_check_apply_p && SCM_TRAPS_P)\
3016 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
3018 SCM tmp, tail = scm_from_bool(SCM_TRACED_FRAME_P (debug)); \
3019 SCM_SET_TRACED_FRAME (debug); \
3021 tmp = scm_make_debugobj (&debug);\
3022 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
3028 #define RETURN(e) do { proc = (e); goto exit; } while (0)
3030 #ifdef STACK_CHECKING
3031 #ifndef EVAL_STACK_CHECKING
3032 #define EVAL_STACK_CHECKING
3037 /* scm_last_debug_frame contains a pointer to the last debugging information
3038 * stack frame. It is accessed very often from the debugging evaluator, so it
3039 * should probably not be indirectly addressed. Better to save and restore it
3040 * from the current root at any stack swaps.
3043 /* scm_debug_eframe_size is the number of slots available for pseudo
3044 * stack frames at each real stack frame.
3047 long scm_debug_eframe_size
;
3049 int scm_debug_mode_p
;
3050 int scm_check_entry_p
;
3051 int scm_check_apply_p
;
3052 int scm_check_exit_p
;
3054 long scm_eval_stack
;
3056 scm_t_option scm_eval_opts
[] = {
3057 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
3060 scm_t_option scm_debug_opts
[] = {
3061 { SCM_OPTION_BOOLEAN
, "cheap", 1,
3062 "*This option is now obsolete. Setting it has no effect." },
3063 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
3064 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
3065 { SCM_OPTION_BOOLEAN
, "procnames", 1,
3066 "Record procedure names at definition." },
3067 { SCM_OPTION_BOOLEAN
, "backwards", 0,
3068 "Display backtrace in anti-chronological order." },
3069 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
3070 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
3071 { SCM_OPTION_INTEGER
, "frames", 3,
3072 "Maximum number of tail-recursive frames in backtrace." },
3073 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
3074 "Maximal number of stored backtrace frames." },
3075 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
3076 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
3077 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
3078 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
3079 { 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."},
3080 { SCM_OPTION_BOOLEAN
, "warn-deprecated", 0, "Warn when deprecated features are used." }
3083 scm_t_option scm_evaluator_trap_table
[] = {
3084 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
3085 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
3086 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
3087 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
3088 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
3089 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
3090 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
3093 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
3095 "Option interface for the evaluation options. Instead of using\n"
3096 "this procedure directly, use the procedures @code{eval-enable},\n"
3097 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
3098 #define FUNC_NAME s_scm_eval_options_interface
3102 scm_frame_begin (0);
3103 scm_frame_critical_section (SCM_BOOL_F
);
3104 ans
= scm_options (setting
,
3108 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
3116 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
3118 "Option interface for the evaluator trap options.")
3119 #define FUNC_NAME s_scm_evaluator_traps
3122 SCM_CRITICAL_SECTION_START
;
3123 ans
= scm_options (setting
,
3124 scm_evaluator_trap_table
,
3125 SCM_N_EVALUATOR_TRAPS
,
3127 /* njrev: same again. */
3128 SCM_RESET_DEBUG_MODE
;
3129 SCM_CRITICAL_SECTION_END
;
3136 deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
3138 SCM
*results
= lloc
;
3139 while (scm_is_pair (l
))
3141 const SCM res
= EVALCAR (l
, env
);
3143 *lloc
= scm_list_1 (res
);
3144 lloc
= SCM_CDRLOC (*lloc
);
3147 if (!scm_is_null (l
))
3148 scm_wrong_num_args (proc
);
3153 eval_letrec_inits (SCM env
, SCM init_forms
, SCM
**init_values_eol
)
3156 int i
= 0, imax
= sizeof (argv
) / sizeof (SCM
);
3158 while (!scm_is_null (init_forms
))
3162 eval_letrec_inits (env
, init_forms
, init_values_eol
);
3165 argv
[i
++] = EVALCAR (init_forms
, env
);
3166 init_forms
= SCM_CDR (init_forms
);
3169 for (i
--; i
>= 0; i
--)
3171 **init_values_eol
= scm_list_1 (argv
[i
]);
3172 *init_values_eol
= SCM_CDRLOC (**init_values_eol
);
3179 /* SECTION: This code is compiled twice.
3183 /* Update the toplevel environment frame ENV so that it refers to the
3184 * current module. */
3185 #define UPDATE_TOPLEVEL_ENV(env) \
3187 SCM p = scm_current_module_lookup_closure (); \
3188 if (p != SCM_CAR (env)) \
3189 env = scm_top_level_env (p); \
3193 #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
3194 ASSERT_SYNTAX (!scm_is_eq ((x), SCM_EOL), s_empty_combination, x)
3197 /* This is the evaluator. Like any real monster, it has three heads:
3199 * ceval is the non-debugging evaluator, deval is the debugging version. Both
3200 * are implemented using a common code base, using the following mechanism:
3201 * CEVAL is a macro, which is either defined to ceval or deval. Thus, there
3202 * is no function CEVAL, but the code for CEVAL actually compiles to either
3203 * ceval or deval. When CEVAL is defined to ceval, it is known that the macro
3204 * DEVAL is not defined. When CEVAL is defined to deval, then the macro DEVAL
3205 * is known to be defined. Thus, in CEVAL parts for the debugging evaluator
3206 * are enclosed within #ifdef DEVAL ... #endif.
3208 * All three (ceval, deval and their common implementation CEVAL) take two
3209 * input parameters, x and env: x is a single expression to be evalutated.
3210 * env is the environment in which bindings are searched.
3212 * x is known to be a pair. Since x is a single expression, it is necessarily
3213 * in a tail position. If x is just a call to another function like in the
3214 * expression (foo exp1 exp2 ...), the realization of that call therefore
3215 * _must_not_ increase stack usage (the evaluation of exp1, exp2 etc.,
3216 * however, may do so). This is realized by making extensive use of 'goto'
3217 * statements within the evaluator: The gotos replace recursive calls to
3218 * CEVAL, thus re-using the same stack frame that CEVAL was already using.
3219 * If, however, x represents some form that requires to evaluate a sequence of
3220 * expressions like (begin exp1 exp2 ...), then recursive calls to CEVAL are
3221 * performed for all but the last expression of that sequence. */
3224 CEVAL (SCM x
, SCM env
)
3228 scm_t_debug_frame debug
;
3229 scm_t_debug_info
*debug_info_end
;
3230 debug
.prev
= scm_i_last_debug_frame ();
3233 * The debug.vect contains twice as much scm_t_debug_info frames as the
3234 * user has specified with (debug-set! frames <n>).
3236 * Even frames are eval frames, odd frames are apply frames.
3238 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
3239 * sizeof (scm_t_debug_info
));
3240 debug
.info
= debug
.vect
;
3241 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
3242 scm_i_set_last_debug_frame (&debug
);
3244 #ifdef EVAL_STACK_CHECKING
3245 if (scm_stack_checking_enabled_p
&& SCM_STACK_OVERFLOW_P (&proc
))
3248 debug
.info
->e
.exp
= x
;
3249 debug
.info
->e
.env
= env
;
3251 scm_report_stack_overflow ();
3261 SCM_CLEAR_ARGSREADY (debug
);
3262 if (SCM_OVERFLOWP (debug
))
3265 * In theory, this should be the only place where it is necessary to
3266 * check for space in debug.vect since both eval frames and
3267 * available space are even.
3269 * For this to be the case, however, it is necessary that primitive
3270 * special forms which jump back to `loop', `begin' or some similar
3271 * label call PREP_APPLY.
3273 else if (++debug
.info
>= debug_info_end
)
3275 SCM_SET_OVERFLOW (debug
);
3280 debug
.info
->e
.exp
= x
;
3281 debug
.info
->e
.env
= env
;
3282 if (scm_check_entry_p
&& SCM_TRAPS_P
)
3284 if (SCM_ENTER_FRAME_P
3285 || (SCM_BREAKPOINTS_P
&& scm_c_source_property_breakpoint_p (x
)))
3288 SCM tail
= scm_from_bool (SCM_TAILRECP (debug
));
3289 SCM_SET_TAILREC (debug
);
3290 stackrep
= scm_make_debugobj (&debug
);
3292 stackrep
= scm_call_4 (SCM_ENTER_FRAME_HDLR
,
3293 scm_sym_enter_frame
,
3296 unmemoize_expression (x
, env
));
3298 if (scm_is_pair (stackrep
) &&
3299 scm_is_eq (SCM_CAR (stackrep
), sym_instead
))
3301 /* This gives the possibility for the debugger to modify
3302 the source expression before evaluation. */
3303 x
= SCM_CDR (stackrep
);
3312 if (SCM_ISYMP (SCM_CAR (x
)))
3314 switch (ISYMNUM (SCM_CAR (x
)))
3316 case (ISYMNUM (SCM_IM_AND
)):
3318 while (!scm_is_null (SCM_CDR (x
)))
3320 SCM test_result
= EVALCAR (x
, env
);
3321 if (scm_is_false (test_result
) || SCM_NILP (test_result
))
3322 RETURN (SCM_BOOL_F
);
3326 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3329 case (ISYMNUM (SCM_IM_BEGIN
)):
3331 if (scm_is_null (x
))
3332 RETURN (SCM_UNSPECIFIED
);
3334 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3337 /* If we are on toplevel with a lookup closure, we need to sync
3338 with the current module. */
3339 if (scm_is_pair (env
) && !scm_is_pair (SCM_CAR (env
)))
3341 UPDATE_TOPLEVEL_ENV (env
);
3342 while (!scm_is_null (SCM_CDR (x
)))
3345 UPDATE_TOPLEVEL_ENV (env
);
3351 goto nontoplevel_begin
;
3354 while (!scm_is_null (SCM_CDR (x
)))
3356 const SCM form
= SCM_CAR (x
);
3359 if (SCM_ISYMP (form
))
3361 scm_i_scm_pthread_mutex_lock (&source_mutex
);
3362 /* check for race condition */
3363 if (SCM_ISYMP (SCM_CAR (x
)))
3364 m_expand_body (x
, env
);
3365 scm_i_pthread_mutex_unlock (&source_mutex
);
3366 goto nontoplevel_begin
;
3369 SCM_VALIDATE_NON_EMPTY_COMBINATION (form
);
3372 (void) EVAL (form
, env
);
3378 /* scm_eval last form in list */
3379 const SCM last_form
= SCM_CAR (x
);
3381 if (scm_is_pair (last_form
))
3383 /* This is by far the most frequent case. */
3385 goto loop
; /* tail recurse */
3387 else if (SCM_IMP (last_form
))
3388 RETURN (SCM_I_EVALIM (last_form
, env
));
3389 else if (SCM_VARIABLEP (last_form
))
3390 RETURN (SCM_VARIABLE_REF (last_form
));
3391 else if (scm_is_symbol (last_form
))
3392 RETURN (*scm_lookupcar (x
, env
, 1));
3398 case (ISYMNUM (SCM_IM_CASE
)):
3401 const SCM key
= EVALCAR (x
, env
);
3403 while (!scm_is_null (x
))
3405 const SCM clause
= SCM_CAR (x
);
3406 SCM labels
= SCM_CAR (clause
);
3407 if (scm_is_eq (labels
, SCM_IM_ELSE
))
3409 x
= SCM_CDR (clause
);
3410 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3413 while (!scm_is_null (labels
))
3415 const SCM label
= SCM_CAR (labels
);
3416 if (scm_is_eq (label
, key
)
3417 || scm_is_true (scm_eqv_p (label
, key
)))
3419 x
= SCM_CDR (clause
);
3420 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3423 labels
= SCM_CDR (labels
);
3428 RETURN (SCM_UNSPECIFIED
);
3431 case (ISYMNUM (SCM_IM_COND
)):
3433 while (!scm_is_null (x
))
3435 const SCM clause
= SCM_CAR (x
);
3436 if (scm_is_eq (SCM_CAR (clause
), SCM_IM_ELSE
))
3438 x
= SCM_CDR (clause
);
3439 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3444 arg1
= EVALCAR (clause
, env
);
3445 /* SRFI 61 extended cond */
3446 if (!scm_is_null (SCM_CDR (clause
))
3447 && !scm_is_null (SCM_CDDR (clause
))
3448 && scm_is_eq (SCM_CADDR (clause
), SCM_IM_ARROW
))
3450 SCM xx
, guard_result
;
3451 if (SCM_VALUESP (arg1
))
3452 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
3454 arg1
= scm_list_1 (arg1
);
3455 xx
= SCM_CDR (clause
);
3456 proc
= EVALCAR (xx
, env
);
3457 guard_result
= SCM_APPLY (proc
, arg1
, SCM_EOL
);
3458 if (scm_is_true (guard_result
)
3459 && !SCM_NILP (guard_result
))
3461 proc
= SCM_CDDR (xx
);
3462 proc
= EVALCAR (proc
, env
);
3463 PREP_APPLY (proc
, arg1
);
3467 else if (scm_is_true (arg1
) && !SCM_NILP (arg1
))
3469 x
= SCM_CDR (clause
);
3470 if (scm_is_null (x
))
3472 else if (!scm_is_eq (SCM_CAR (x
), SCM_IM_ARROW
))
3474 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3480 proc
= EVALCAR (proc
, env
);
3481 PREP_APPLY (proc
, scm_list_1 (arg1
));
3489 RETURN (SCM_UNSPECIFIED
);
3492 case (ISYMNUM (SCM_IM_DO
)):
3495 /* Compute the initialization values and the initial environment. */
3496 SCM init_forms
= SCM_CAR (x
);
3497 SCM init_values
= SCM_EOL
;
3498 while (!scm_is_null (init_forms
))
3500 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3501 init_forms
= SCM_CDR (init_forms
);
3504 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
3508 SCM test_form
= SCM_CAR (x
);
3509 SCM body_forms
= SCM_CADR (x
);
3510 SCM step_forms
= SCM_CDDR (x
);
3512 SCM test_result
= EVALCAR (test_form
, env
);
3514 while (scm_is_false (test_result
) || SCM_NILP (test_result
))
3517 /* Evaluate body forms. */
3519 for (temp_forms
= body_forms
;
3520 !scm_is_null (temp_forms
);
3521 temp_forms
= SCM_CDR (temp_forms
))
3523 SCM form
= SCM_CAR (temp_forms
);
3524 /* Dirk:FIXME: We only need to eval forms that may have
3525 * a side effect here. This is only true for forms that
3526 * start with a pair. All others are just constants.
3527 * Since with the current memoizer 'form' may hold a
3528 * constant, we call EVAL here to handle the constant
3529 * cases. In the long run it would make sense to have
3530 * the macro transformer of 'do' eliminate all forms
3531 * that have no sideeffect. Then instead of EVAL we
3532 * could call CEVAL directly here. */
3533 (void) EVAL (form
, env
);
3538 /* Evaluate the step expressions. */
3540 SCM step_values
= SCM_EOL
;
3541 for (temp_forms
= step_forms
;
3542 !scm_is_null (temp_forms
);
3543 temp_forms
= SCM_CDR (temp_forms
))
3545 const SCM value
= EVALCAR (temp_forms
, env
);
3546 step_values
= scm_cons (value
, step_values
);
3548 env
= SCM_EXTEND_ENV (SCM_CAAR (env
),
3553 test_result
= EVALCAR (test_form
, env
);
3557 if (scm_is_null (x
))
3558 RETURN (SCM_UNSPECIFIED
);
3559 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3560 goto nontoplevel_begin
;
3563 case (ISYMNUM (SCM_IM_IF
)):
3566 SCM test_result
= EVALCAR (x
, env
);
3567 x
= SCM_CDR (x
); /* then expression */
3568 if (scm_is_false (test_result
) || SCM_NILP (test_result
))
3570 x
= SCM_CDR (x
); /* else expression */
3571 if (scm_is_null (x
))
3572 RETURN (SCM_UNSPECIFIED
);
3575 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3579 case (ISYMNUM (SCM_IM_LET
)):
3582 SCM init_forms
= SCM_CADR (x
);
3583 SCM init_values
= SCM_EOL
;
3586 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3587 init_forms
= SCM_CDR (init_forms
);
3589 while (!scm_is_null (init_forms
));
3590 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
3593 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3594 goto nontoplevel_begin
;
3597 case (ISYMNUM (SCM_IM_LETREC
)):
3599 env
= SCM_EXTEND_ENV (SCM_CAR (x
), undefineds
, env
);
3602 SCM init_forms
= SCM_CAR (x
);
3603 SCM init_values
= scm_list_1 (SCM_BOOL_T
);
3604 SCM
*init_values_eol
= SCM_CDRLOC (init_values
);
3605 eval_letrec_inits (env
, init_forms
, &init_values_eol
);
3606 SCM_SETCDR (SCM_CAR (env
), SCM_CDR (init_values
));
3609 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3610 goto nontoplevel_begin
;
3613 case (ISYMNUM (SCM_IM_LETSTAR
)):
3616 SCM bindings
= SCM_CAR (x
);
3617 if (!scm_is_null (bindings
))
3621 SCM name
= SCM_CAR (bindings
);
3622 SCM init
= SCM_CDR (bindings
);
3623 env
= SCM_EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
3624 bindings
= SCM_CDR (init
);
3626 while (!scm_is_null (bindings
));
3630 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3631 goto nontoplevel_begin
;
3634 case (ISYMNUM (SCM_IM_OR
)):
3636 while (!scm_is_null (SCM_CDR (x
)))
3638 SCM val
= EVALCAR (x
, env
);
3639 if (scm_is_true (val
) && !SCM_NILP (val
))
3644 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3648 case (ISYMNUM (SCM_IM_LAMBDA
)):
3649 RETURN (scm_closure (SCM_CDR (x
), env
));
3652 case (ISYMNUM (SCM_IM_QUOTE
)):
3653 RETURN (SCM_CDR (x
));
3656 case (ISYMNUM (SCM_IM_SET_X
)):
3660 SCM variable
= SCM_CAR (x
);
3661 if (SCM_ILOCP (variable
))
3662 location
= scm_ilookup (variable
, env
);
3663 else if (SCM_VARIABLEP (variable
))
3664 location
= SCM_VARIABLE_LOC (variable
);
3667 /* (scm_is_symbol (variable)) is known to be true */
3668 variable
= lazy_memoize_variable (variable
, env
);
3669 SCM_SETCAR (x
, variable
);
3670 location
= SCM_VARIABLE_LOC (variable
);
3673 *location
= EVALCAR (x
, env
);
3675 RETURN (SCM_UNSPECIFIED
);
3678 case (ISYMNUM (SCM_IM_APPLY
)):
3679 /* Evaluate the procedure to be applied. */
3681 proc
= EVALCAR (x
, env
);
3682 PREP_APPLY (proc
, SCM_EOL
);
3684 /* Evaluate the argument holding the list of arguments */
3686 arg1
= EVALCAR (x
, env
);
3689 /* Go here to tail-apply a procedure. PROC is the procedure and
3690 * ARG1 is the list of arguments. PREP_APPLY must have been called
3691 * before jumping to apply_proc. */
3692 if (SCM_CLOSUREP (proc
))
3694 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3696 debug
.info
->a
.args
= arg1
;
3698 if (scm_badargsp (formals
, arg1
))
3699 scm_wrong_num_args (proc
);
3701 /* Copy argument list */
3702 if (SCM_NULL_OR_NIL_P (arg1
))
3703 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
3706 SCM args
= scm_list_1 (SCM_CAR (arg1
));
3708 arg1
= SCM_CDR (arg1
);
3709 while (!SCM_NULL_OR_NIL_P (arg1
))
3711 SCM new_tail
= scm_list_1 (SCM_CAR (arg1
));
3712 SCM_SETCDR (tail
, new_tail
);
3714 arg1
= SCM_CDR (arg1
);
3716 env
= SCM_EXTEND_ENV (formals
, args
, SCM_ENV (proc
));
3719 x
= SCM_CLOSURE_BODY (proc
);
3720 goto nontoplevel_begin
;
3725 RETURN (SCM_APPLY (proc
, arg1
, SCM_EOL
));
3729 case (ISYMNUM (SCM_IM_CONT
)):
3732 SCM val
= scm_make_continuation (&first
);
3740 proc
= EVALCAR (proc
, env
);
3741 PREP_APPLY (proc
, scm_list_1 (arg1
));
3748 case (ISYMNUM (SCM_IM_DELAY
)):
3749 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
3752 case (ISYMNUM (SCM_IM_FUTURE
)):
3753 RETURN (scm_i_make_future (scm_closure (SCM_CDR (x
), env
)));
3756 /* PLACEHOLDER for case (ISYMNUM (SCM_IM_DISPATCH)): The following
3757 code (type_dispatch) is intended to be the tail of the case
3758 clause for the internal macro SCM_IM_DISPATCH. Please don't
3759 remove it from this location without discussing it with Mikael
3760 <djurfeldt@nada.kth.se> */
3762 /* The type dispatch code is duplicated below
3763 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
3764 * cuts down execution time for type dispatch to 50%. */
3765 type_dispatch
: /* inputs: x, arg1 */
3766 /* Type dispatch means to determine from the types of the function
3767 * arguments (i. e. the 'signature' of the call), which method from
3768 * a generic function is to be called. This process of selecting
3769 * the right method takes some time. To speed it up, guile uses
3770 * caching: Together with the macro call to dispatch the signatures
3771 * of some previous calls to that generic function from the same
3772 * place are stored (in the code!) in a cache that we call the
3773 * 'method cache'. This is done since it is likely, that
3774 * consecutive calls to dispatch from that position in the code will
3775 * have the same signature. Thus, the type dispatch works as
3776 * follows: First, determine a hash value from the signature of the
3777 * actual arguments. Second, use this hash value as an index to
3778 * find that same signature in the method cache stored at this
3779 * position in the code. If found, you have also found the
3780 * corresponding method that belongs to that signature. If the
3781 * signature is not found in the method cache, you have to perform a
3782 * full search over all signatures stored with the generic
3785 unsigned long int specializers
;
3786 unsigned long int hash_value
;
3787 unsigned long int cache_end_pos
;
3788 unsigned long int mask
;
3792 SCM z
= SCM_CDDR (x
);
3793 SCM tmp
= SCM_CADR (z
);
3794 specializers
= scm_to_ulong (SCM_CAR (z
));
3796 /* Compute a hash value for searching the method cache. There
3797 * are two variants for computing the hash value, a (rather)
3798 * complicated one, and a simple one. For the complicated one
3799 * explained below, tmp holds a number that is used in the
3801 if (scm_is_simple_vector (tmp
))
3803 /* This method of determining the hash value is much
3804 * simpler: Set the hash value to zero and just perform a
3805 * linear search through the method cache. */
3807 mask
= (unsigned long int) ((long) -1);
3809 cache_end_pos
= SCM_SIMPLE_VECTOR_LENGTH (method_cache
);
3813 /* Use the signature of the actual arguments to determine
3814 * the hash value. This is done as follows: Each class has
3815 * an array of random numbers, that are determined when the
3816 * class is created. The integer 'hashset' is an index into
3817 * that array of random numbers. Now, from all classes that
3818 * are part of the signature of the actual arguments, the
3819 * random numbers at index 'hashset' are taken and summed
3820 * up, giving the hash value. The value of 'hashset' is
3821 * stored at the call to dispatch. This allows to have
3822 * different 'formulas' for calculating the hash value at
3823 * different places where dispatch is called. This allows
3824 * to optimize the hash formula at every individual place
3825 * where dispatch is called, such that hopefully the hash
3826 * value that is computed will directly point to the right
3827 * method in the method cache. */
3828 unsigned long int hashset
= scm_to_ulong (tmp
);
3829 unsigned long int counter
= specializers
+ 1;
3832 while (!scm_is_null (tmp_arg
) && counter
!= 0)
3834 SCM
class = scm_class_of (SCM_CAR (tmp_arg
));
3835 hash_value
+= SCM_INSTANCE_HASH (class, hashset
);
3836 tmp_arg
= SCM_CDR (tmp_arg
);
3840 method_cache
= SCM_CADR (z
);
3841 mask
= scm_to_ulong (SCM_CAR (z
));
3843 cache_end_pos
= hash_value
;
3848 /* Search the method cache for a method with a matching
3849 * signature. Start the search at position 'hash_value'. The
3850 * hashing implementation uses linear probing for conflict
3851 * resolution, that is, if the signature in question is not
3852 * found at the starting index in the hash table, the next table
3853 * entry is tried, and so on, until in the worst case the whole
3854 * cache has been searched, but still the signature has not been
3859 SCM args
= arg1
; /* list of arguments */
3860 z
= SCM_SIMPLE_VECTOR_REF (method_cache
, hash_value
);
3861 while (!scm_is_null (args
))
3863 /* More arguments than specifiers => CLASS != ENV */
3864 SCM class_of_arg
= scm_class_of (SCM_CAR (args
));
3865 if (!scm_is_eq (class_of_arg
, SCM_CAR (z
)))
3867 args
= SCM_CDR (args
);
3870 /* Fewer arguments than specifiers => CAR != ENV */
3871 if (scm_is_null (SCM_CAR (z
)) || scm_is_pair (SCM_CAR (z
)))
3874 hash_value
= (hash_value
+ 1) & mask
;
3875 } while (hash_value
!= cache_end_pos
);
3877 /* No appropriate method was found in the cache. */
3878 z
= scm_memoize_method (x
, arg1
);
3880 apply_cmethod
: /* inputs: z, arg1 */
3882 SCM formals
= SCM_CMETHOD_FORMALS (z
);
3883 env
= SCM_EXTEND_ENV (formals
, arg1
, SCM_CMETHOD_ENV (z
));
3884 x
= SCM_CMETHOD_BODY (z
);
3885 goto nontoplevel_begin
;
3891 case (ISYMNUM (SCM_IM_SLOT_REF
)):
3894 SCM instance
= EVALCAR (x
, env
);
3895 unsigned long int slot
= SCM_I_INUM (SCM_CDR (x
));
3896 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance
) [slot
]));
3900 case (ISYMNUM (SCM_IM_SLOT_SET_X
)):
3903 SCM instance
= EVALCAR (x
, env
);
3904 unsigned long int slot
= SCM_I_INUM (SCM_CADR (x
));
3905 SCM value
= EVALCAR (SCM_CDDR (x
), env
);
3906 SCM_STRUCT_DATA (instance
) [slot
] = SCM_UNPACK (value
);
3907 RETURN (SCM_UNSPECIFIED
);
3911 #if SCM_ENABLE_ELISP
3913 case (ISYMNUM (SCM_IM_NIL_COND
)):
3915 SCM test_form
= SCM_CDR (x
);
3916 x
= SCM_CDR (test_form
);
3917 while (!SCM_NULL_OR_NIL_P (x
))
3919 SCM test_result
= EVALCAR (test_form
, env
);
3920 if (!(scm_is_false (test_result
)
3921 || SCM_NULL_OR_NIL_P (test_result
)))
3923 if (scm_is_eq (SCM_CAR (x
), SCM_UNSPECIFIED
))
3924 RETURN (test_result
);
3925 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3930 test_form
= SCM_CDR (x
);
3931 x
= SCM_CDR (test_form
);
3935 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3939 #endif /* SCM_ENABLE_ELISP */
3941 case (ISYMNUM (SCM_IM_BIND
)):
3943 SCM vars
, exps
, vals
;
3946 vars
= SCM_CAAR (x
);
3947 exps
= SCM_CDAR (x
);
3949 while (!scm_is_null (exps
))
3951 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
3952 exps
= SCM_CDR (exps
);
3955 scm_swap_bindings (vars
, vals
);
3956 scm_i_set_dynwinds (scm_acons (vars
, vals
, scm_i_dynwinds ()));
3958 /* Ignore all but the last evaluation result. */
3959 for (x
= SCM_CDR (x
); !scm_is_null (SCM_CDR (x
)); x
= SCM_CDR (x
))
3961 if (scm_is_pair (SCM_CAR (x
)))
3962 CEVAL (SCM_CAR (x
), env
);
3964 proc
= EVALCAR (x
, env
);
3966 scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
3967 scm_swap_bindings (vars
, vals
);
3973 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
3978 producer
= EVALCAR (x
, env
);
3980 proc
= EVALCAR (x
, env
); /* proc is the consumer. */
3981 arg1
= SCM_APPLY (producer
, SCM_EOL
, SCM_EOL
);
3982 if (SCM_VALUESP (arg1
))
3984 /* The list of arguments is not copied. Rather, it is assumed
3985 * that this has been done by the 'values' procedure. */
3986 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
3990 arg1
= scm_list_1 (arg1
);
3992 PREP_APPLY (proc
, arg1
);
4003 if (SCM_VARIABLEP (SCM_CAR (x
)))
4004 proc
= SCM_VARIABLE_REF (SCM_CAR (x
));
4005 else if (SCM_ILOCP (SCM_CAR (x
)))
4006 proc
= *scm_ilookup (SCM_CAR (x
), env
);
4007 else if (scm_is_pair (SCM_CAR (x
)))
4008 proc
= CEVAL (SCM_CAR (x
), env
);
4009 else if (scm_is_symbol (SCM_CAR (x
)))
4011 SCM orig_sym
= SCM_CAR (x
);
4013 SCM
*location
= scm_lookupcar1 (x
, env
, 1);
4014 if (location
== NULL
)
4016 /* we have lost the race, start again. */
4022 if (SCM_MACROP (proc
))
4024 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
4026 handle_a_macro
: /* inputs: x, env, proc */
4028 /* Set a flag during macro expansion so that macro
4029 application frames can be deleted from the backtrace. */
4030 SCM_SET_MACROEXP (debug
);
4032 arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
4033 scm_cons (env
, scm_listofnull
));
4035 SCM_CLEAR_MACROEXP (debug
);
4037 switch (SCM_MACRO_TYPE (proc
))
4041 if (!scm_is_pair (arg1
))
4042 arg1
= scm_list_2 (SCM_IM_BEGIN
, arg1
);
4044 assert (!scm_is_eq (x
, SCM_CAR (arg1
))
4045 && !scm_is_eq (x
, SCM_CDR (arg1
)));
4048 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
4050 SCM_CRITICAL_SECTION_START
;
4051 SCM_SETCAR (x
, SCM_CAR (arg1
));
4052 SCM_SETCDR (x
, SCM_CDR (arg1
));
4053 SCM_CRITICAL_SECTION_END
;
4056 /* Prevent memoizing of debug info expression. */
4057 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
4061 SCM_CRITICAL_SECTION_START
;
4062 SCM_SETCAR (x
, SCM_CAR (arg1
));
4063 SCM_SETCDR (x
, SCM_CDR (arg1
));
4064 SCM_CRITICAL_SECTION_END
;
4065 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
4067 #if SCM_ENABLE_DEPRECATED == 1
4072 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
4086 if (SCM_MACROP (proc
))
4087 goto handle_a_macro
;
4091 /* When reaching this part of the code, the following is granted: Variable x
4092 * holds the first pair of an expression of the form (<function> arg ...).
4093 * Variable proc holds the object that resulted from the evaluation of
4094 * <function>. In the following, the arguments (if any) will be evaluated,
4095 * and proc will be applied to them. If proc does not really hold a
4096 * function object, this will be signalled as an error on the scheme
4097 * level. If the number of arguments does not match the number of arguments
4098 * that are allowed to be passed to proc, also an error on the scheme level
4099 * will be signalled. */
4100 PREP_APPLY (proc
, SCM_EOL
);
4101 if (scm_is_null (SCM_CDR (x
))) {
4104 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4105 switch (SCM_TYP7 (proc
))
4106 { /* no arguments given */
4107 case scm_tc7_subr_0
:
4108 RETURN (SCM_SUBRF (proc
) ());
4109 case scm_tc7_subr_1o
:
4110 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
4112 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
4113 case scm_tc7_rpsubr
:
4114 RETURN (SCM_BOOL_T
);
4116 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
4118 if (!SCM_SMOB_APPLICABLE_P (proc
))
4120 RETURN (SCM_SMOB_APPLY_0 (proc
));
4123 proc
= SCM_CCLO_SUBR (proc
);
4125 debug
.info
->a
.proc
= proc
;
4126 debug
.info
->a
.args
= scm_list_1 (arg1
);
4130 proc
= SCM_PROCEDURE (proc
);
4132 debug
.info
->a
.proc
= proc
;
4134 if (!SCM_CLOSUREP (proc
))
4137 case scm_tcs_closures
:
4139 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4140 if (scm_is_pair (formals
))
4142 x
= SCM_CLOSURE_BODY (proc
);
4143 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
4144 goto nontoplevel_begin
;
4146 case scm_tcs_struct
:
4147 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4149 x
= SCM_ENTITY_PROCEDURE (proc
);
4153 else if (SCM_I_OPERATORP (proc
))
4156 proc
= (SCM_I_ENTITYP (proc
)
4157 ? SCM_ENTITY_PROCEDURE (proc
)
4158 : SCM_OPERATOR_PROCEDURE (proc
));
4160 debug
.info
->a
.proc
= proc
;
4161 debug
.info
->a
.args
= scm_list_1 (arg1
);
4167 case scm_tc7_subr_1
:
4168 case scm_tc7_subr_2
:
4169 case scm_tc7_subr_2o
:
4172 case scm_tc7_subr_3
:
4173 case scm_tc7_lsubr_2
:
4175 scm_wrong_num_args (proc
);
4178 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
4182 /* must handle macros by here */
4184 if (scm_is_pair (x
))
4185 arg1
= EVALCAR (x
, env
);
4187 scm_wrong_num_args (proc
);
4189 debug
.info
->a
.args
= scm_list_1 (arg1
);
4194 if (scm_is_null (x
))
4197 evap1
: /* inputs: proc, arg1 */
4198 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4199 switch (SCM_TYP7 (proc
))
4200 { /* have one argument in arg1 */
4201 case scm_tc7_subr_2o
:
4202 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4203 case scm_tc7_subr_1
:
4204 case scm_tc7_subr_1o
:
4205 RETURN (SCM_SUBRF (proc
) (arg1
));
4207 if (SCM_I_INUMP (arg1
))
4209 RETURN (scm_from_double (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
))));
4211 else if (SCM_REALP (arg1
))
4213 RETURN (scm_from_double (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4215 else if (SCM_BIGP (arg1
))
4217 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4219 else if (SCM_FRACTIONP (arg1
))
4221 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4223 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4225 scm_i_symbol_chars (SCM_SNAME (proc
)));
4227 RETURN (scm_i_chase_pairs (arg1
, (scm_t_bits
) SCM_SUBRF (proc
)));
4228 case scm_tc7_rpsubr
:
4229 RETURN (SCM_BOOL_T
);
4231 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4234 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4236 RETURN (SCM_SUBRF (proc
) (scm_list_1 (arg1
)));
4239 if (!SCM_SMOB_APPLICABLE_P (proc
))
4241 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
4245 proc
= SCM_CCLO_SUBR (proc
);
4247 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
4248 debug
.info
->a
.proc
= proc
;
4252 proc
= SCM_PROCEDURE (proc
);
4254 debug
.info
->a
.proc
= proc
;
4256 if (!SCM_CLOSUREP (proc
))
4259 case scm_tcs_closures
:
4262 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4263 if (scm_is_null (formals
)
4264 || (scm_is_pair (formals
) && scm_is_pair (SCM_CDR (formals
))))
4266 x
= SCM_CLOSURE_BODY (proc
);
4268 env
= SCM_EXTEND_ENV (formals
,
4272 env
= SCM_EXTEND_ENV (formals
,
4276 goto nontoplevel_begin
;
4278 case scm_tcs_struct
:
4279 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4281 x
= SCM_ENTITY_PROCEDURE (proc
);
4283 arg1
= debug
.info
->a
.args
;
4285 arg1
= scm_list_1 (arg1
);
4289 else if (SCM_I_OPERATORP (proc
))
4293 proc
= (SCM_I_ENTITYP (proc
)
4294 ? SCM_ENTITY_PROCEDURE (proc
)
4295 : SCM_OPERATOR_PROCEDURE (proc
));
4297 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
4298 debug
.info
->a
.proc
= proc
;
4304 case scm_tc7_subr_2
:
4305 case scm_tc7_subr_0
:
4306 case scm_tc7_subr_3
:
4307 case scm_tc7_lsubr_2
:
4308 scm_wrong_num_args (proc
);
4313 if (scm_is_pair (x
))
4314 arg2
= EVALCAR (x
, env
);
4316 scm_wrong_num_args (proc
);
4318 { /* have two or more arguments */
4320 debug
.info
->a
.args
= scm_list_2 (arg1
, arg2
);
4323 if (scm_is_null (x
)) {
4326 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4327 switch (SCM_TYP7 (proc
))
4328 { /* have two arguments */
4329 case scm_tc7_subr_2
:
4330 case scm_tc7_subr_2o
:
4331 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
4334 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4336 RETURN (SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
)));
4338 case scm_tc7_lsubr_2
:
4339 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
));
4340 case scm_tc7_rpsubr
:
4342 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
4344 if (!SCM_SMOB_APPLICABLE_P (proc
))
4346 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
));
4350 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
4351 scm_cons (proc
, debug
.info
->a
.args
),
4354 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
4355 scm_cons2 (proc
, arg1
,
4362 case scm_tcs_struct
:
4363 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4365 x
= SCM_ENTITY_PROCEDURE (proc
);
4367 arg1
= debug
.info
->a
.args
;
4369 arg1
= scm_list_2 (arg1
, arg2
);
4373 else if (SCM_I_OPERATORP (proc
))
4377 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
4378 ? SCM_ENTITY_PROCEDURE (proc
)
4379 : SCM_OPERATOR_PROCEDURE (proc
),
4380 scm_cons (proc
, debug
.info
->a
.args
),
4383 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
4384 ? SCM_ENTITY_PROCEDURE (proc
)
4385 : SCM_OPERATOR_PROCEDURE (proc
),
4386 scm_cons2 (proc
, arg1
,
4396 case scm_tc7_subr_0
:
4399 case scm_tc7_subr_1o
:
4400 case scm_tc7_subr_1
:
4401 case scm_tc7_subr_3
:
4402 scm_wrong_num_args (proc
);
4406 proc
= SCM_PROCEDURE (proc
);
4408 debug
.info
->a
.proc
= proc
;
4410 if (!SCM_CLOSUREP (proc
))
4413 case scm_tcs_closures
:
4416 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4417 if (scm_is_null (formals
)
4418 || (scm_is_pair (formals
)
4419 && (scm_is_null (SCM_CDR (formals
))
4420 || (scm_is_pair (SCM_CDR (formals
))
4421 && scm_is_pair (SCM_CDDR (formals
))))))
4424 env
= SCM_EXTEND_ENV (formals
,
4428 env
= SCM_EXTEND_ENV (formals
,
4429 scm_list_2 (arg1
, arg2
),
4432 x
= SCM_CLOSURE_BODY (proc
);
4433 goto nontoplevel_begin
;
4437 if (!scm_is_pair (x
))
4438 scm_wrong_num_args (proc
);
4440 debug
.info
->a
.args
= scm_cons2 (arg1
, arg2
,
4441 deval_args (x
, env
, proc
,
4442 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
4446 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4447 switch (SCM_TYP7 (proc
))
4448 { /* have 3 or more arguments */
4450 case scm_tc7_subr_3
:
4451 if (!scm_is_null (SCM_CDR (x
)))
4452 scm_wrong_num_args (proc
);
4454 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4455 SCM_CADDR (debug
.info
->a
.args
)));
4457 arg1
= SCM_SUBRF(proc
)(arg1
, arg2
);
4458 arg2
= SCM_CDDR (debug
.info
->a
.args
);
4461 arg1
= SCM_SUBRF(proc
)(arg1
, SCM_CAR (arg2
));
4462 arg2
= SCM_CDR (arg2
);
4464 while (SCM_NIMP (arg2
));
4466 case scm_tc7_rpsubr
:
4467 if (scm_is_false (SCM_SUBRF (proc
) (arg1
, arg2
)))
4468 RETURN (SCM_BOOL_F
);
4469 arg1
= SCM_CDDR (debug
.info
->a
.args
);
4472 if (scm_is_false (SCM_SUBRF (proc
) (arg2
, SCM_CAR (arg1
))))
4473 RETURN (SCM_BOOL_F
);
4474 arg2
= SCM_CAR (arg1
);
4475 arg1
= SCM_CDR (arg1
);
4477 while (SCM_NIMP (arg1
));
4478 RETURN (SCM_BOOL_T
);
4479 case scm_tc7_lsubr_2
:
4480 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4481 SCM_CDDR (debug
.info
->a
.args
)));
4483 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4485 if (!SCM_SMOB_APPLICABLE_P (proc
))
4487 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4488 SCM_CDDR (debug
.info
->a
.args
)));
4492 proc
= SCM_PROCEDURE (proc
);
4493 debug
.info
->a
.proc
= proc
;
4494 if (!SCM_CLOSUREP (proc
))
4497 case scm_tcs_closures
:
4499 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4500 if (scm_is_null (formals
)
4501 || (scm_is_pair (formals
)
4502 && (scm_is_null (SCM_CDR (formals
))
4503 || (scm_is_pair (SCM_CDR (formals
))
4504 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4506 SCM_SET_ARGSREADY (debug
);
4507 env
= SCM_EXTEND_ENV (formals
,
4510 x
= SCM_CLOSURE_BODY (proc
);
4511 goto nontoplevel_begin
;
4514 case scm_tc7_subr_3
:
4515 if (!scm_is_null (SCM_CDR (x
)))
4516 scm_wrong_num_args (proc
);
4518 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, EVALCAR (x
, env
)));
4520 arg1
= SCM_SUBRF (proc
) (arg1
, arg2
);
4523 arg1
= SCM_SUBRF(proc
)(arg1
, EVALCAR(x
, env
));
4526 while (!scm_is_null (x
));
4528 case scm_tc7_rpsubr
:
4529 if (scm_is_false (SCM_SUBRF (proc
) (arg1
, arg2
)))
4530 RETURN (SCM_BOOL_F
);
4533 arg1
= EVALCAR (x
, env
);
4534 if (scm_is_false (SCM_SUBRF (proc
) (arg2
, arg1
)))
4535 RETURN (SCM_BOOL_F
);
4539 while (!scm_is_null (x
));
4540 RETURN (SCM_BOOL_T
);
4541 case scm_tc7_lsubr_2
:
4542 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
4544 RETURN (SCM_SUBRF (proc
) (scm_cons2 (arg1
,
4546 scm_eval_args (x
, env
, proc
))));
4548 if (!SCM_SMOB_APPLICABLE_P (proc
))
4550 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4551 scm_eval_args (x
, env
, proc
)));
4555 proc
= SCM_PROCEDURE (proc
);
4556 if (!SCM_CLOSUREP (proc
))
4559 case scm_tcs_closures
:
4561 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4562 if (scm_is_null (formals
)
4563 || (scm_is_pair (formals
)
4564 && (scm_is_null (SCM_CDR (formals
))
4565 || (scm_is_pair (SCM_CDR (formals
))
4566 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4568 env
= SCM_EXTEND_ENV (formals
,
4571 scm_eval_args (x
, env
, proc
)),
4573 x
= SCM_CLOSURE_BODY (proc
);
4574 goto nontoplevel_begin
;
4577 case scm_tcs_struct
:
4578 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4581 arg1
= debug
.info
->a
.args
;
4583 arg1
= scm_cons2 (arg1
, arg2
, scm_eval_args (x
, env
, proc
));
4585 x
= SCM_ENTITY_PROCEDURE (proc
);
4588 else if (SCM_I_OPERATORP (proc
))
4592 case scm_tc7_subr_2
:
4593 case scm_tc7_subr_1o
:
4594 case scm_tc7_subr_2o
:
4595 case scm_tc7_subr_0
:
4598 case scm_tc7_subr_1
:
4599 scm_wrong_num_args (proc
);
4607 if (scm_check_exit_p
&& SCM_TRAPS_P
)
4608 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
4610 SCM_CLEAR_TRACED_FRAME (debug
);
4611 arg1
= scm_make_debugobj (&debug
);
4613 arg1
= scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
4615 if (scm_is_pair (arg1
) && scm_is_eq (SCM_CAR (arg1
), sym_instead
))
4616 proc
= SCM_CDR (arg1
);
4618 scm_i_set_last_debug_frame (debug
.prev
);
4624 /* SECTION: This code is compiled once.
4631 /* Simple procedure calls
4635 scm_call_0 (SCM proc
)
4637 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
4641 scm_call_1 (SCM proc
, SCM arg1
)
4643 return scm_apply (proc
, arg1
, scm_listofnull
);
4647 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
4649 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
4653 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
4655 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
4659 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
4661 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
4662 scm_cons (arg4
, scm_listofnull
)));
4665 /* Simple procedure applies
4669 scm_apply_0 (SCM proc
, SCM args
)
4671 return scm_apply (proc
, args
, SCM_EOL
);
4675 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
4677 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
4681 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
4683 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
4687 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
4689 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
4693 /* This code processes the arguments to apply:
4695 (apply PROC ARG1 ... ARGS)
4697 Given a list (ARG1 ... ARGS), this function conses the ARG1
4698 ... arguments onto the front of ARGS, and returns the resulting
4699 list. Note that ARGS is a list; thus, the argument to this
4700 function is a list whose last element is a list.
4702 Apply calls this function, and applies PROC to the elements of the
4703 result. apply:nconc2last takes care of building the list of
4704 arguments, given (ARG1 ... ARGS).
4706 Rather than do new consing, apply:nconc2last destroys its argument.
4707 On that topic, this code came into my care with the following
4708 beautifully cryptic comment on that topic: "This will only screw
4709 you if you do (scm_apply scm_apply '( ... ))" If you know what
4710 they're referring to, send me a patch to this comment. */
4712 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
4714 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
4715 "conses the @var{arg1} @dots{} arguments onto the front of\n"
4716 "@var{args}, and returns the resulting list. Note that\n"
4717 "@var{args} is a list; thus, the argument to this function is\n"
4718 "a list whose last element is a list.\n"
4719 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
4720 "destroys its argument, so use with care.")
4721 #define FUNC_NAME s_scm_nconc2last
4724 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
4726 while (!scm_is_null (SCM_CDR (*lloc
))) /* Perhaps should be
4727 SCM_NULL_OR_NIL_P, but not
4728 needed in 99.99% of cases,
4729 and it could seriously hurt
4730 performance. - Neil */
4731 lloc
= SCM_CDRLOC (*lloc
);
4732 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
4733 *lloc
= SCM_CAR (*lloc
);
4741 /* SECTION: When DEVAL is defined this code yields scm_dapply.
4742 * It is compiled twice.
4747 scm_apply (SCM proc
, SCM arg1
, SCM args
)
4753 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
4758 /* Apply a function to a list of arguments.
4760 This function is exported to the Scheme level as taking two
4761 required arguments and a tail argument, as if it were:
4762 (lambda (proc arg1 . args) ...)
4763 Thus, if you just have a list of arguments to pass to a procedure,
4764 pass the list as ARG1, and '() for ARGS. If you have some fixed
4765 args, pass the first as ARG1, then cons any remaining fixed args
4766 onto the front of your argument list, and pass that as ARGS. */
4769 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
4772 scm_t_debug_frame debug
;
4773 scm_t_debug_info debug_vect_body
;
4774 debug
.prev
= scm_i_last_debug_frame ();
4775 debug
.status
= SCM_APPLYFRAME
;
4776 debug
.vect
= &debug_vect_body
;
4777 debug
.vect
[0].a
.proc
= proc
;
4778 debug
.vect
[0].a
.args
= SCM_EOL
;
4779 scm_i_set_last_debug_frame (&debug
);
4781 if (scm_debug_mode_p
)
4782 return scm_dapply (proc
, arg1
, args
);
4785 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
4787 /* If ARGS is the empty list, then we're calling apply with only two
4788 arguments --- ARG1 is the list of arguments for PROC. Whatever
4789 the case, futz with things so that ARG1 is the first argument to
4790 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
4793 Setting the debug apply frame args this way is pretty messy.
4794 Perhaps we should store arg1 and args directly in the frame as
4795 received, and let scm_frame_arguments unpack them, because that's
4796 a relatively rare operation. This works for now; if the Guile
4797 developer archives are still around, see Mikael's post of
4799 if (scm_is_null (args
))
4801 if (scm_is_null (arg1
))
4803 arg1
= SCM_UNDEFINED
;
4805 debug
.vect
[0].a
.args
= SCM_EOL
;
4811 debug
.vect
[0].a
.args
= arg1
;
4813 args
= SCM_CDR (arg1
);
4814 arg1
= SCM_CAR (arg1
);
4819 args
= scm_nconc2last (args
);
4821 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4825 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
4827 SCM tmp
= scm_make_debugobj (&debug
);
4829 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
4835 switch (SCM_TYP7 (proc
))
4837 case scm_tc7_subr_2o
:
4838 args
= scm_is_null (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
4839 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4840 case scm_tc7_subr_2
:
4841 if (scm_is_null (args
) || !scm_is_null (SCM_CDR (args
)))
4842 scm_wrong_num_args (proc
);
4843 args
= SCM_CAR (args
);
4844 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4845 case scm_tc7_subr_0
:
4846 if (!SCM_UNBNDP (arg1
))
4847 scm_wrong_num_args (proc
);
4849 RETURN (SCM_SUBRF (proc
) ());
4850 case scm_tc7_subr_1
:
4851 if (SCM_UNBNDP (arg1
))
4852 scm_wrong_num_args (proc
);
4853 case scm_tc7_subr_1o
:
4854 if (!scm_is_null (args
))
4855 scm_wrong_num_args (proc
);
4857 RETURN (SCM_SUBRF (proc
) (arg1
));
4859 if (SCM_UNBNDP (arg1
) || !scm_is_null (args
))
4860 scm_wrong_num_args (proc
);
4861 if (SCM_I_INUMP (arg1
))
4863 RETURN (scm_from_double (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
))));
4865 else if (SCM_REALP (arg1
))
4867 RETURN (scm_from_double (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4869 else if (SCM_BIGP (arg1
))
4871 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4873 else if (SCM_FRACTIONP (arg1
))
4875 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4877 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4878 SCM_ARG1
, scm_i_symbol_chars (SCM_SNAME (proc
)));
4880 if (SCM_UNBNDP (arg1
) || !scm_is_null (args
))
4881 scm_wrong_num_args (proc
);
4882 RETURN (scm_i_chase_pairs (arg1
, (scm_t_bits
) SCM_SUBRF (proc
)));
4883 case scm_tc7_subr_3
:
4884 if (scm_is_null (args
)
4885 || scm_is_null (SCM_CDR (args
))
4886 || !scm_is_null (SCM_CDDR (args
)))
4887 scm_wrong_num_args (proc
);
4889 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
4892 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
4894 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
4896 case scm_tc7_lsubr_2
:
4897 if (!scm_is_pair (args
))
4898 scm_wrong_num_args (proc
);
4900 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4902 if (scm_is_null (args
))
4903 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4904 while (SCM_NIMP (args
))
4906 SCM_ASSERT (scm_is_pair (args
), args
, SCM_ARG2
, "apply");
4907 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
4908 args
= SCM_CDR (args
);
4911 case scm_tc7_rpsubr
:
4912 if (scm_is_null (args
))
4913 RETURN (SCM_BOOL_T
);
4914 while (SCM_NIMP (args
))
4916 SCM_ASSERT (scm_is_pair (args
), args
, SCM_ARG2
, "apply");
4917 if (scm_is_false (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
4918 RETURN (SCM_BOOL_F
);
4919 arg1
= SCM_CAR (args
);
4920 args
= SCM_CDR (args
);
4922 RETURN (SCM_BOOL_T
);
4923 case scm_tcs_closures
:
4925 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4927 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4929 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
4930 scm_wrong_num_args (proc
);
4932 /* Copy argument list */
4937 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
4938 for (arg1
= SCM_CDR (arg1
); scm_is_pair (arg1
); arg1
= SCM_CDR (arg1
))
4940 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
));
4943 SCM_SETCDR (tl
, arg1
);
4946 args
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4949 proc
= SCM_CLOSURE_BODY (proc
);
4951 arg1
= SCM_CDR (proc
);
4952 while (!scm_is_null (arg1
))
4954 if (SCM_IMP (SCM_CAR (proc
)))
4956 if (SCM_ISYMP (SCM_CAR (proc
)))
4958 scm_i_scm_pthread_mutex_lock (&source_mutex
);
4959 /* check for race condition */
4960 if (SCM_ISYMP (SCM_CAR (proc
)))
4961 m_expand_body (proc
, args
);
4962 scm_i_pthread_mutex_unlock (&source_mutex
);
4966 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
4969 (void) EVAL (SCM_CAR (proc
), args
);
4971 arg1
= SCM_CDR (proc
);
4973 RETURN (EVALCAR (proc
, args
));
4975 if (!SCM_SMOB_APPLICABLE_P (proc
))
4977 if (SCM_UNBNDP (arg1
))
4978 RETURN (SCM_SMOB_APPLY_0 (proc
));
4979 else if (scm_is_null (args
))
4980 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
4981 else if (scm_is_null (SCM_CDR (args
)))
4982 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
4984 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4987 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4989 proc
= SCM_CCLO_SUBR (proc
);
4990 debug
.vect
[0].a
.proc
= proc
;
4991 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4993 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4995 proc
= SCM_CCLO_SUBR (proc
);
4999 proc
= SCM_PROCEDURE (proc
);
5001 debug
.vect
[0].a
.proc
= proc
;
5004 case scm_tcs_struct
:
5005 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5008 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
5010 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
5012 RETURN (scm_apply_generic (proc
, args
));
5014 else if (SCM_I_OPERATORP (proc
))
5018 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
5020 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
5023 proc
= (SCM_I_ENTITYP (proc
)
5024 ? SCM_ENTITY_PROCEDURE (proc
)
5025 : SCM_OPERATOR_PROCEDURE (proc
));
5027 debug
.vect
[0].a
.proc
= proc
;
5028 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
5030 if (SCM_NIMP (proc
))
5039 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
5043 if (scm_check_exit_p
&& SCM_TRAPS_P
)
5044 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
5046 SCM_CLEAR_TRACED_FRAME (debug
);
5047 arg1
= scm_make_debugobj (&debug
);
5049 arg1
= scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
5051 if (scm_is_pair (arg1
) && scm_is_eq (SCM_CAR (arg1
), sym_instead
))
5052 proc
= SCM_CDR (arg1
);
5054 scm_i_set_last_debug_frame (debug
.prev
);
5060 /* SECTION: The rest of this file is only read once.
5067 * Trampolines make it possible to move procedure application dispatch
5068 * outside inner loops. The motivation was clean implementation of
5069 * efficient replacements of R5RS primitives in SRFI-1.
5071 * The semantics is clear: scm_trampoline_N returns an optimized
5072 * version of scm_call_N (or NULL if the procedure isn't applicable
5075 * Applying the optimization to map and for-each increased efficiency
5076 * noticeably. For example, (map abs ls) is now 8 times faster than
5081 call_subr0_0 (SCM proc
)
5083 return SCM_SUBRF (proc
) ();
5087 call_subr1o_0 (SCM proc
)
5089 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
5093 call_lsubr_0 (SCM proc
)
5095 return SCM_SUBRF (proc
) (SCM_EOL
);
5099 scm_i_call_closure_0 (SCM proc
)
5101 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
5104 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
5109 scm_trampoline_0 (SCM proc
)
5111 scm_t_trampoline_0 trampoline
;
5116 switch (SCM_TYP7 (proc
))
5118 case scm_tc7_subr_0
:
5119 trampoline
= call_subr0_0
;
5121 case scm_tc7_subr_1o
:
5122 trampoline
= call_subr1o_0
;
5125 trampoline
= call_lsubr_0
;
5127 case scm_tcs_closures
:
5129 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5130 if (scm_is_null (formals
) || !scm_is_pair (formals
))
5131 trampoline
= scm_i_call_closure_0
;
5136 case scm_tcs_struct
:
5137 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5138 trampoline
= scm_call_generic_0
;
5139 else if (SCM_I_OPERATORP (proc
))
5140 trampoline
= scm_call_0
;
5145 if (SCM_SMOB_APPLICABLE_P (proc
))
5146 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
5151 case scm_tc7_rpsubr
:
5154 trampoline
= scm_call_0
;
5157 return NULL
; /* not applicable on zero arguments */
5159 /* We only reach this point if a valid trampoline was determined. */
5161 /* If debugging is enabled, we want to see all calls to proc on the stack.
5162 * Thus, we replace the trampoline shortcut with scm_call_0. */
5163 if (scm_debug_mode_p
)
5170 call_subr1_1 (SCM proc
, SCM arg1
)
5172 return SCM_SUBRF (proc
) (arg1
);
5176 call_subr2o_1 (SCM proc
, SCM arg1
)
5178 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
5182 call_lsubr_1 (SCM proc
, SCM arg1
)
5184 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
5188 call_dsubr_1 (SCM proc
, SCM arg1
)
5190 if (SCM_I_INUMP (arg1
))
5192 RETURN (scm_from_double (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
))));
5194 else if (SCM_REALP (arg1
))
5196 RETURN (scm_from_double (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
5198 else if (SCM_BIGP (arg1
))
5200 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
5202 else if (SCM_FRACTIONP (arg1
))
5204 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
5206 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
5207 SCM_ARG1
, scm_i_symbol_chars (SCM_SNAME (proc
)));
5211 call_cxr_1 (SCM proc
, SCM arg1
)
5213 return scm_i_chase_pairs (arg1
, (scm_t_bits
) SCM_SUBRF (proc
));
5217 call_closure_1 (SCM proc
, SCM arg1
)
5219 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
5222 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
5227 scm_trampoline_1 (SCM proc
)
5229 scm_t_trampoline_1 trampoline
;
5234 switch (SCM_TYP7 (proc
))
5236 case scm_tc7_subr_1
:
5237 case scm_tc7_subr_1o
:
5238 trampoline
= call_subr1_1
;
5240 case scm_tc7_subr_2o
:
5241 trampoline
= call_subr2o_1
;
5244 trampoline
= call_lsubr_1
;
5247 trampoline
= call_dsubr_1
;
5250 trampoline
= call_cxr_1
;
5252 case scm_tcs_closures
:
5254 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5255 if (!scm_is_null (formals
)
5256 && (!scm_is_pair (formals
) || !scm_is_pair (SCM_CDR (formals
))))
5257 trampoline
= call_closure_1
;
5262 case scm_tcs_struct
:
5263 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5264 trampoline
= scm_call_generic_1
;
5265 else if (SCM_I_OPERATORP (proc
))
5266 trampoline
= scm_call_1
;
5271 if (SCM_SMOB_APPLICABLE_P (proc
))
5272 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
5277 case scm_tc7_rpsubr
:
5280 trampoline
= scm_call_1
;
5283 return NULL
; /* not applicable on one arg */
5285 /* We only reach this point if a valid trampoline was determined. */
5287 /* If debugging is enabled, we want to see all calls to proc on the stack.
5288 * Thus, we replace the trampoline shortcut with scm_call_1. */
5289 if (scm_debug_mode_p
)
5296 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
5298 return SCM_SUBRF (proc
) (arg1
, arg2
);
5302 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
5304 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
5308 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
5310 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
5314 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
5316 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
5317 scm_list_2 (arg1
, arg2
),
5319 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
5324 scm_trampoline_2 (SCM proc
)
5326 scm_t_trampoline_2 trampoline
;
5331 switch (SCM_TYP7 (proc
))
5333 case scm_tc7_subr_2
:
5334 case scm_tc7_subr_2o
:
5335 case scm_tc7_rpsubr
:
5337 trampoline
= call_subr2_2
;
5339 case scm_tc7_lsubr_2
:
5340 trampoline
= call_lsubr2_2
;
5343 trampoline
= call_lsubr_2
;
5345 case scm_tcs_closures
:
5347 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5348 if (!scm_is_null (formals
)
5349 && (!scm_is_pair (formals
)
5350 || (!scm_is_null (SCM_CDR (formals
))
5351 && (!scm_is_pair (SCM_CDR (formals
))
5352 || !scm_is_pair (SCM_CDDR (formals
))))))
5353 trampoline
= call_closure_2
;
5358 case scm_tcs_struct
:
5359 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5360 trampoline
= scm_call_generic_2
;
5361 else if (SCM_I_OPERATORP (proc
))
5362 trampoline
= scm_call_2
;
5367 if (SCM_SMOB_APPLICABLE_P (proc
))
5368 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
5374 trampoline
= scm_call_2
;
5377 return NULL
; /* not applicable on two args */
5379 /* We only reach this point if a valid trampoline was determined. */
5381 /* If debugging is enabled, we want to see all calls to proc on the stack.
5382 * Thus, we replace the trampoline shortcut with scm_call_2. */
5383 if (scm_debug_mode_p
)
5389 /* Typechecking for multi-argument MAP and FOR-EACH.
5391 Verify that each element of the vector ARGV, except for the first,
5392 is a proper list whose length is LEN. Attribute errors to WHO,
5393 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
5395 check_map_args (SCM argv
,
5404 for (i
= SCM_SIMPLE_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
5406 SCM elt
= SCM_SIMPLE_VECTOR_REF (argv
, i
);
5407 long elt_len
= scm_ilength (elt
);
5412 scm_apply_generic (gf
, scm_cons (proc
, args
));
5414 scm_wrong_type_arg (who
, i
+ 2, elt
);
5418 scm_out_of_range_pos (who
, elt
, scm_from_long (i
+ 2));
5423 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
5425 /* Note: Currently, scm_map applies PROC to the argument list(s)
5426 sequentially, starting with the first element(s). This is used in
5427 evalext.c where the Scheme procedure `map-in-order', which guarantees
5428 sequential behaviour, is implemented using scm_map. If the
5429 behaviour changes, we need to update `map-in-order'.
5433 scm_map (SCM proc
, SCM arg1
, SCM args
)
5434 #define FUNC_NAME s_map
5440 len
= scm_ilength (arg1
);
5441 SCM_GASSERTn (len
>= 0,
5442 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
5443 SCM_VALIDATE_REST_ARGUMENT (args
);
5444 if (scm_is_null (args
))
5446 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5447 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
5448 while (SCM_NIMP (arg1
))
5450 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
5451 pres
= SCM_CDRLOC (*pres
);
5452 arg1
= SCM_CDR (arg1
);
5456 if (scm_is_null (SCM_CDR (args
)))
5458 SCM arg2
= SCM_CAR (args
);
5459 int len2
= scm_ilength (arg2
);
5460 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5462 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
5463 SCM_GASSERTn (len2
>= 0,
5464 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
5466 SCM_OUT_OF_RANGE (3, arg2
);
5467 while (SCM_NIMP (arg1
))
5469 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
5470 pres
= SCM_CDRLOC (*pres
);
5471 arg1
= SCM_CDR (arg1
);
5472 arg2
= SCM_CDR (arg2
);
5476 arg1
= scm_cons (arg1
, args
);
5477 args
= scm_vector (arg1
);
5478 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
5482 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5484 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
5487 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
5488 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
5490 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
5491 pres
= SCM_CDRLOC (*pres
);
5497 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
5500 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
5501 #define FUNC_NAME s_for_each
5504 len
= scm_ilength (arg1
);
5505 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
5506 SCM_ARG2
, s_for_each
);
5507 SCM_VALIDATE_REST_ARGUMENT (args
);
5508 if (scm_is_null (args
))
5510 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5511 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
5512 while (SCM_NIMP (arg1
))
5514 call (proc
, SCM_CAR (arg1
));
5515 arg1
= SCM_CDR (arg1
);
5517 return SCM_UNSPECIFIED
;
5519 if (scm_is_null (SCM_CDR (args
)))
5521 SCM arg2
= SCM_CAR (args
);
5522 int len2
= scm_ilength (arg2
);
5523 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5524 SCM_GASSERTn (call
, g_for_each
,
5525 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
5526 SCM_GASSERTn (len2
>= 0, g_for_each
,
5527 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
5529 SCM_OUT_OF_RANGE (3, arg2
);
5530 while (SCM_NIMP (arg1
))
5532 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
5533 arg1
= SCM_CDR (arg1
);
5534 arg2
= SCM_CDR (arg2
);
5536 return SCM_UNSPECIFIED
;
5538 arg1
= scm_cons (arg1
, args
);
5539 args
= scm_vector (arg1
);
5540 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
5544 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5546 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
5548 return SCM_UNSPECIFIED
;
5549 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
5550 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
5552 scm_apply (proc
, arg1
, SCM_EOL
);
5559 scm_closure (SCM code
, SCM env
)
5562 SCM closcar
= scm_cons (code
, SCM_EOL
);
5563 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
5564 scm_remember_upto_here (closcar
);
5569 scm_t_bits scm_tc16_promise
;
5572 scm_makprom (SCM code
)
5574 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
5576 scm_make_recursive_mutex ());
5580 promise_mark (SCM promise
)
5582 scm_gc_mark (SCM_PROMISE_MUTEX (promise
));
5583 return SCM_PROMISE_DATA (promise
);
5587 promise_free (SCM promise
)
5593 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
5595 int writingp
= SCM_WRITINGP (pstate
);
5596 scm_puts ("#<promise ", port
);
5597 SCM_SET_WRITINGP (pstate
, 1);
5598 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
5599 SCM_SET_WRITINGP (pstate
, writingp
);
5600 scm_putc ('>', port
);
5604 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
5606 "If the promise @var{x} has not been computed yet, compute and\n"
5607 "return @var{x}, otherwise just return the previously computed\n"
5609 #define FUNC_NAME s_scm_force
5611 SCM_VALIDATE_SMOB (1, promise
, promise
);
5612 scm_lock_mutex (SCM_PROMISE_MUTEX (promise
));
5613 if (!SCM_PROMISE_COMPUTED_P (promise
))
5615 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
5616 if (!SCM_PROMISE_COMPUTED_P (promise
))
5618 SCM_SET_PROMISE_DATA (promise
, ans
);
5619 SCM_SET_PROMISE_COMPUTED (promise
);
5622 scm_unlock_mutex (SCM_PROMISE_MUTEX (promise
));
5623 return SCM_PROMISE_DATA (promise
);
5628 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
5630 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
5631 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
5632 #define FUNC_NAME s_scm_promise_p
5634 return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
5639 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
5640 (SCM xorig
, SCM x
, SCM y
),
5641 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
5642 "Any source properties associated with @var{xorig} are also associated\n"
5643 "with the new pair.")
5644 #define FUNC_NAME s_scm_cons_source
5647 z
= scm_cons (x
, y
);
5648 /* Copy source properties possibly associated with xorig. */
5649 p
= scm_whash_lookup (scm_source_whash
, xorig
);
5650 if (scm_is_true (p
))
5651 scm_whash_insert (scm_source_whash
, z
, p
);
5657 /* The function scm_copy_tree is used to copy an expression tree to allow the
5658 * memoizer to modify the expression during memoization. scm_copy_tree
5659 * creates deep copies of pairs and vectors, but not of any other data types,
5660 * since only pairs and vectors will be parsed by the memoizer.
5662 * To avoid infinite recursion due to cyclic structures, the hare-and-tortoise
5663 * pattern is used to detect cycles. In fact, the pattern is used in two
5664 * dimensions, vertical (indicated in the code by the variable names 'hare'
5665 * and 'tortoise') and horizontal ('rabbit' and 'turtle'). In both
5666 * dimensions, the hare/rabbit will take two steps when the tortoise/turtle
5669 * The vertical dimension corresponds to recursive calls to function
5670 * copy_tree: This happens when descending into vector elements, into cars of
5671 * lists and into the cdr of an improper list. In this dimension, the
5672 * tortoise follows the hare by using the processor stack: Every stack frame
5673 * will hold an instance of struct t_trace. These instances are connected in
5674 * a way that represents the trace of the hare, which thus can be followed by
5675 * the tortoise. The tortoise will always point to struct t_trace instances
5676 * relating to SCM objects that have already been copied. Thus, a cycle is
5677 * detected if the tortoise and the hare point to the same object,
5679 * The horizontal dimension is within one execution of copy_tree, when the
5680 * function cdr's along the pairs of a list. This is the standard
5681 * hare-and-tortoise implementation, found several times in guile. */
5684 struct t_trace
*trace
; // These pointers form a trace along the stack.
5685 SCM obj
; // The object handled at the respective stack frame.
5690 struct t_trace
*const hare
,
5691 struct t_trace
*tortoise
,
5692 unsigned int tortoise_delay
)
5694 if (!scm_is_pair (hare
->obj
) && !scm_is_simple_vector (hare
->obj
))
5700 /* Prepare the trace along the stack. */
5701 struct t_trace new_hare
;
5702 hare
->trace
= &new_hare
;
5704 /* The tortoise will make its step after the delay has elapsed. Note
5705 * that in contrast to the typical hare-and-tortoise pattern, the step
5706 * of the tortoise happens before the hare takes its steps. This is, in
5707 * principle, no problem, except for the start of the algorithm: Then,
5708 * it has to be made sure that the hare actually gets its advantage of
5710 if (tortoise_delay
== 0)
5713 tortoise
= tortoise
->trace
;
5714 ASSERT_SYNTAX (!scm_is_eq (hare
->obj
, tortoise
->obj
),
5715 s_bad_expression
, hare
->obj
);
5722 if (scm_is_simple_vector (hare
->obj
))
5724 size_t length
= SCM_SIMPLE_VECTOR_LENGTH (hare
->obj
);
5725 SCM new_vector
= scm_c_make_vector (length
, SCM_UNSPECIFIED
);
5727 /* Each vector element is copied by recursing into copy_tree, having
5728 * the tortoise follow the hare into the depths of the stack. */
5729 unsigned long int i
;
5730 for (i
= 0; i
< length
; ++i
)
5733 new_hare
.obj
= SCM_SIMPLE_VECTOR_REF (hare
->obj
, i
);
5734 new_element
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5735 SCM_SIMPLE_VECTOR_SET (new_vector
, i
, new_element
);
5740 else // scm_is_pair (hare->obj)
5745 SCM rabbit
= hare
->obj
;
5746 SCM turtle
= hare
->obj
;
5750 /* The first pair of the list is treated specially, in order to
5751 * preserve a potential source code position. */
5752 result
= tail
= scm_cons_source (rabbit
, SCM_EOL
, SCM_EOL
);
5753 new_hare
.obj
= SCM_CAR (rabbit
);
5754 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5755 SCM_SETCAR (tail
, copy
);
5757 /* The remaining pairs of the list are copied by, horizontally,
5758 * having the turtle follow the rabbit, and, vertically, having the
5759 * tortoise follow the hare into the depths of the stack. */
5760 rabbit
= SCM_CDR (rabbit
);
5761 while (scm_is_pair (rabbit
))
5763 new_hare
.obj
= SCM_CAR (rabbit
);
5764 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5765 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
5766 tail
= SCM_CDR (tail
);
5768 rabbit
= SCM_CDR (rabbit
);
5769 if (scm_is_pair (rabbit
))
5771 new_hare
.obj
= SCM_CAR (rabbit
);
5772 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5773 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
5774 tail
= SCM_CDR (tail
);
5775 rabbit
= SCM_CDR (rabbit
);
5777 turtle
= SCM_CDR (turtle
);
5778 ASSERT_SYNTAX (!scm_is_eq (rabbit
, turtle
),
5779 s_bad_expression
, rabbit
);
5783 /* We have to recurse into copy_tree again for the last cdr, in
5784 * order to handle the situation that it holds a vector. */
5785 new_hare
.obj
= rabbit
;
5786 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5787 SCM_SETCDR (tail
, copy
);
5794 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
5796 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
5797 "the new data structure. @code{copy-tree} recurses down the\n"
5798 "contents of both pairs and vectors (since both cons cells and vector\n"
5799 "cells may point to arbitrary objects), and stops recursing when it hits\n"
5800 "any other object.")
5801 #define FUNC_NAME s_scm_copy_tree
5803 /* Prepare the trace along the stack. */
5804 struct t_trace trace
;
5807 /* In function copy_tree, if the tortoise makes its step, it will do this
5808 * before the hare has the chance to move. Thus, we have to make sure that
5809 * the very first step of the tortoise will not happen after the hare has
5810 * really made two steps. This is achieved by passing '2' as the initial
5811 * delay for the tortoise. NOTE: Since cycles are unlikely, giving the hare
5812 * a bigger advantage may improve performance slightly. */
5813 return copy_tree (&trace
, &trace
, 2);
5818 /* We have three levels of EVAL here:
5820 - scm_i_eval (exp, env)
5822 evaluates EXP in environment ENV. ENV is a lexical environment
5823 structure as used by the actual tree code evaluator. When ENV is
5824 a top-level environment, then changes to the current module are
5825 tracked by updating ENV so that it continues to be in sync with
5828 - scm_primitive_eval (exp)
5830 evaluates EXP in the top-level environment as determined by the
5831 current module. This is done by constructing a suitable
5832 environment and calling scm_i_eval. Thus, changes to the
5833 top-level module are tracked normally.
5835 - scm_eval (exp, mod_or_state)
5837 evaluates EXP while MOD_OR_STATE is the current module or current
5838 dynamic state (as appropriate). This is done by setting the
5839 current module (or dynamic state) to MOD_OR_STATE, invoking
5840 scm_primitive_eval on EXP, and then restoring the current module
5841 (or dynamic state) to the value it had previously. That is,
5842 while EXP is evaluated, changes to the current module (or dynamic
5843 state) are tracked, but these changes do not persist when
5846 For each level of evals, there are two variants, distinguished by a
5847 _x suffix: the ordinary variant does not modify EXP while the _x
5848 variant can destructively modify EXP into something completely
5849 unintelligible. A Scheme data structure passed as EXP to one of the
5850 _x variants should not ever be used again for anything. So when in
5851 doubt, use the ordinary variant.
5856 scm_i_eval_x (SCM exp
, SCM env
)
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_i_eval (SCM exp
, SCM env
)
5867 exp
= scm_copy_tree (exp
);
5868 if (scm_is_symbol (exp
))
5869 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
5871 return SCM_I_XEVAL (exp
, env
);
5875 scm_primitive_eval_x (SCM exp
)
5878 SCM transformer
= scm_current_module_transformer ();
5879 if (SCM_NIMP (transformer
))
5880 exp
= scm_call_1 (transformer
, exp
);
5881 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5882 return scm_i_eval_x (exp
, env
);
5885 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
5887 "Evaluate @var{exp} in the top-level environment specified by\n"
5888 "the current module.")
5889 #define FUNC_NAME s_scm_primitive_eval
5892 SCM transformer
= scm_current_module_transformer ();
5893 if (scm_is_true (transformer
))
5894 exp
= scm_call_1 (transformer
, exp
);
5895 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5896 return scm_i_eval (exp
, env
);
5901 /* Eval does not take the second arg optionally. This is intentional
5902 * in order to be R5RS compatible, and to prepare for the new module
5903 * system, where we would like to make the choice of evaluation
5904 * environment explicit. */
5907 scm_eval_x (SCM exp
, SCM module_or_state
)
5911 scm_frame_begin (SCM_F_FRAME_REWINDABLE
);
5912 if (scm_is_dynamic_state (module_or_state
))
5913 scm_frame_current_dynamic_state (module_or_state
);
5915 scm_frame_current_module (module_or_state
);
5917 res
= scm_primitive_eval_x (exp
);
5923 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
5924 (SCM exp
, SCM module_or_state
),
5925 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
5926 "in the top-level environment specified by\n"
5927 "@var{module_or_state}.\n"
5928 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
5929 "@var{module_or_state} is made the current module when\n"
5930 "it is a module, or the current dynamic state when it is\n"
5932 "Example: (eval '(+ 1 2) (interaction-environment))")
5933 #define FUNC_NAME s_scm_eval
5937 scm_frame_begin (SCM_F_FRAME_REWINDABLE
);
5938 if (scm_is_dynamic_state (module_or_state
))
5939 scm_frame_current_dynamic_state (module_or_state
);
5941 scm_frame_current_module (module_or_state
);
5943 res
= scm_primitive_eval (exp
);
5951 /* At this point, deval and scm_dapply are generated.
5958 #if (SCM_ENABLE_DEPRECATED == 1)
5960 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5961 SCM
scm_ceval (SCM x
, SCM env
)
5963 if (scm_is_pair (x
))
5964 return ceval (x
, env
);
5965 else if (scm_is_symbol (x
))
5966 return *scm_lookupcar (scm_cons (x
, SCM_UNDEFINED
), env
, 1);
5968 return SCM_I_XEVAL (x
, env
);
5971 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5972 SCM
scm_deval (SCM x
, SCM env
)
5974 if (scm_is_pair (x
))
5975 return deval (x
, env
);
5976 else if (scm_is_symbol (x
))
5977 return *scm_lookupcar (scm_cons (x
, SCM_UNDEFINED
), env
, 1);
5979 return SCM_I_XEVAL (x
, env
);
5983 dispatching_eval (SCM x
, SCM env
)
5985 if (scm_debug_mode_p
)
5986 return scm_deval (x
, env
);
5988 return scm_ceval (x
, env
);
5991 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5992 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
) = dispatching_eval
;
6000 scm_i_pthread_mutex_init (&source_mutex
,
6001 scm_i_pthread_mutexattr_recursive
);
6003 scm_init_opts (scm_evaluator_traps
,
6004 scm_evaluator_trap_table
,
6005 SCM_N_EVALUATOR_TRAPS
);
6006 scm_init_opts (scm_eval_options_interface
,
6008 SCM_N_EVAL_OPTIONS
);
6010 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
6011 scm_set_smob_mark (scm_tc16_promise
, promise_mark
);
6012 scm_set_smob_free (scm_tc16_promise
, promise_free
);
6013 scm_set_smob_print (scm_tc16_promise
, promise_print
);
6015 undefineds
= scm_list_1 (SCM_UNDEFINED
);
6016 SCM_SETCDR (undefineds
, undefineds
);
6017 scm_permanent_object (undefineds
);
6019 scm_listofnull
= scm_list_1 (SCM_EOL
);
6021 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
6022 scm_permanent_object (f_apply
);
6024 #include "libguile/eval.x"
6026 scm_add_feature ("delay");