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
));
2107 /* See futures.h for a comment why futures are not enabled.
2110 SCM_SYNTAX (s_future
, "future", scm_i_makbimacro
, scm_m_future
);
2111 SCM_GLOBAL_SYMBOL (scm_sym_future
, s_future
);
2113 /* Like promises, futures are implemented as closures with an empty
2114 * parameter list. Thus, (future <expression>) is transformed into
2115 * (#@future '() <expression>), where the empty list represents the
2116 * empty parameter list. This representation allows for easy creation
2117 * of the closure during evaluation. */
2119 scm_m_future (SCM expr
, SCM env
)
2121 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
2122 SCM_SETCAR (new_expr
, SCM_IM_FUTURE
);
2127 unmemoize_future (const SCM expr
, const SCM env
)
2129 const SCM thunk_expr
= SCM_CADDR (expr
);
2130 return scm_list_2 (scm_sym_future
, unmemoize_expression (thunk_expr
, env
));
2135 SCM_SYNTAX (s_gset_x
, "set!", scm_i_makbimacro
, scm_m_generalized_set_x
);
2136 SCM_SYMBOL (scm_sym_setter
, "setter");
2139 scm_m_generalized_set_x (SCM expr
, SCM env
)
2141 SCM target
, exp_target
;
2143 const SCM cdr_expr
= SCM_CDR (expr
);
2144 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2145 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2147 target
= SCM_CAR (cdr_expr
);
2148 if (!scm_is_pair (target
))
2151 return scm_m_set_x (expr
, env
);
2155 /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */
2156 /* Macroexpanding the target might return things of the form
2157 (begin <atom>). In that case, <atom> must be a symbol or a
2158 variable and we memoize to (set! <atom> ...).
2160 exp_target
= macroexp (target
, env
);
2161 if (scm_is_eq (SCM_CAR (exp_target
), SCM_IM_BEGIN
)
2162 && !scm_is_null (SCM_CDR (exp_target
))
2163 && scm_is_null (SCM_CDDR (exp_target
)))
2165 exp_target
= SCM_CADR (exp_target
);
2166 ASSERT_SYNTAX_2 (scm_is_symbol (exp_target
)
2167 || SCM_VARIABLEP (exp_target
),
2168 s_bad_variable
, exp_target
, expr
);
2169 return scm_cons (SCM_IM_SET_X
, scm_cons (exp_target
,
2170 SCM_CDR (cdr_expr
)));
2174 const SCM setter_proc_tail
= scm_list_1 (SCM_CAR (target
));
2175 const SCM setter_proc
= scm_cons_source (expr
, scm_sym_setter
,
2178 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
2179 const SCM setter_args
= scm_append_x (scm_list_2 (SCM_CDR (target
),
2182 SCM_SETCAR (expr
, setter_proc
);
2183 SCM_SETCDR (expr
, setter_args
);
2190 /* @slot-ref is bound privately in the (oop goops) module from goops.c. As
2191 * soon as the module system allows us to more freely create bindings in
2192 * arbitrary modules during the startup phase, the code from goops.c should be
2195 SCM_SYMBOL (sym_atslot_ref
, "@slot-ref");
2198 scm_m_atslot_ref (SCM expr
, SCM env SCM_UNUSED
)
2202 const SCM cdr_expr
= SCM_CDR (expr
);
2203 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2204 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2205 slot_nr
= SCM_CADR (cdr_expr
);
2206 ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2208 SCM_SETCAR (expr
, SCM_IM_SLOT_REF
);
2209 SCM_SETCDR (cdr_expr
, slot_nr
);
2214 unmemoize_atslot_ref (const SCM expr
, const SCM env
)
2216 const SCM instance
= SCM_CADR (expr
);
2217 const SCM um_instance
= unmemoize_expression (instance
, env
);
2218 const SCM slot_nr
= SCM_CDDR (expr
);
2219 return scm_list_3 (sym_atslot_ref
, um_instance
, slot_nr
);
2223 /* @slot-set! is bound privately in the (oop goops) module from goops.c. As
2224 * soon as the module system allows us to more freely create bindings in
2225 * arbitrary modules during the startup phase, the code from goops.c should be
2228 SCM_SYMBOL (sym_atslot_set_x
, "@slot-set!");
2231 scm_m_atslot_set_x (SCM expr
, SCM env SCM_UNUSED
)
2235 const SCM cdr_expr
= SCM_CDR (expr
);
2236 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2237 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 3, s_expression
, expr
);
2238 slot_nr
= SCM_CADR (cdr_expr
);
2239 ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2241 SCM_SETCAR (expr
, SCM_IM_SLOT_SET_X
);
2246 unmemoize_atslot_set_x (const SCM expr
, const SCM env
)
2248 const SCM cdr_expr
= SCM_CDR (expr
);
2249 const SCM instance
= SCM_CAR (cdr_expr
);
2250 const SCM um_instance
= unmemoize_expression (instance
, env
);
2251 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
2252 const SCM slot_nr
= SCM_CAR (cddr_expr
);
2253 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
2254 const SCM value
= SCM_CAR (cdddr_expr
);
2255 const SCM um_value
= unmemoize_expression (value
, env
);
2256 return scm_list_4 (sym_atslot_set_x
, um_instance
, slot_nr
, um_value
);
2260 #if SCM_ENABLE_ELISP
2262 static const char s_defun
[] = "Symbol's function definition is void";
2264 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_i_makbimacro
, scm_m_nil_cond
);
2266 /* nil-cond expressions have the form
2267 * (nil-cond COND VAL COND VAL ... ELSEVAL) */
2269 scm_m_nil_cond (SCM expr
, SCM env SCM_UNUSED
)
2271 const long length
= scm_ilength (SCM_CDR (expr
));
2272 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
2273 ASSERT_SYNTAX (length
>= 1 && (length
% 2) == 1, s_expression
, expr
);
2275 SCM_SETCAR (expr
, SCM_IM_NIL_COND
);
2280 SCM_SYNTAX (s_atfop
, "@fop", scm_i_makbimacro
, scm_m_atfop
);
2282 /* The @fop-macro handles procedure and macro applications for elisp. The
2283 * input expression must have the form
2284 * (@fop <var> (transformer-macro <expr> ...))
2285 * where <var> must be a symbol. The expression is transformed into the
2286 * memoized form of either
2287 * (apply <un-aliased var> (transformer-macro <expr> ...))
2288 * if the value of var (across all aliasing) is not a macro, or
2289 * (<un-aliased var> <expr> ...)
2290 * if var is a macro. */
2292 scm_m_atfop (SCM expr
, SCM env SCM_UNUSED
)
2297 const SCM cdr_expr
= SCM_CDR (expr
);
2298 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2299 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 1, s_missing_expression
, expr
);
2301 symbol
= SCM_CAR (cdr_expr
);
2302 ASSERT_SYNTAX_2 (scm_is_symbol (symbol
), s_bad_variable
, symbol
, expr
);
2304 location
= scm_symbol_fref (symbol
);
2305 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2307 /* The elisp function `defalias' allows to define aliases for symbols. To
2308 * look up such definitions, the chain of symbol definitions has to be
2309 * followed up to the terminal symbol. */
2310 while (scm_is_symbol (SCM_VARIABLE_REF (location
)))
2312 const SCM alias
= SCM_VARIABLE_REF (location
);
2313 location
= scm_symbol_fref (alias
);
2314 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2317 /* Memoize the value location belonging to the terminal symbol. */
2318 SCM_SETCAR (cdr_expr
, location
);
2320 if (!SCM_MACROP (SCM_VARIABLE_REF (location
)))
2322 /* Since the location does not contain a macro, the form is a procedure
2323 * application. Replace `@fop' by `@apply' and transform the expression
2324 * including the `transformer-macro'. */
2325 SCM_SETCAR (expr
, SCM_IM_APPLY
);
2330 /* Since the location contains a macro, the arguments should not be
2331 * transformed, so the `transformer-macro' is cut out. The resulting
2332 * expression starts with the memoized variable, that is at the cdr of
2333 * the input expression. */
2334 SCM_SETCDR (cdr_expr
, SCM_CDADR (cdr_expr
));
2339 #endif /* SCM_ENABLE_ELISP */
2343 unmemoize_builtin_macro (const SCM expr
, const SCM env
)
2345 switch (ISYMNUM (SCM_CAR (expr
)))
2347 case (ISYMNUM (SCM_IM_AND
)):
2348 return unmemoize_and (expr
, env
);
2350 case (ISYMNUM (SCM_IM_BEGIN
)):
2351 return unmemoize_begin (expr
, env
);
2353 case (ISYMNUM (SCM_IM_CASE
)):
2354 return unmemoize_case (expr
, env
);
2356 case (ISYMNUM (SCM_IM_COND
)):
2357 return unmemoize_cond (expr
, env
);
2359 case (ISYMNUM (SCM_IM_DELAY
)):
2360 return unmemoize_delay (expr
, env
);
2362 case (ISYMNUM (SCM_IM_DO
)):
2363 return unmemoize_do (expr
, env
);
2365 case (ISYMNUM (SCM_IM_IF
)):
2366 return unmemoize_if (expr
, env
);
2368 case (ISYMNUM (SCM_IM_LAMBDA
)):
2369 return unmemoize_lambda (expr
, env
);
2371 case (ISYMNUM (SCM_IM_LET
)):
2372 return unmemoize_let (expr
, env
);
2374 case (ISYMNUM (SCM_IM_LETREC
)):
2375 return unmemoize_letrec (expr
, env
);
2377 case (ISYMNUM (SCM_IM_LETSTAR
)):
2378 return unmemoize_letstar (expr
, env
);
2380 case (ISYMNUM (SCM_IM_OR
)):
2381 return unmemoize_or (expr
, env
);
2383 case (ISYMNUM (SCM_IM_QUOTE
)):
2384 return unmemoize_quote (expr
, env
);
2386 case (ISYMNUM (SCM_IM_SET_X
)):
2387 return unmemoize_set_x (expr
, env
);
2389 case (ISYMNUM (SCM_IM_APPLY
)):
2390 return unmemoize_apply (expr
, env
);
2392 case (ISYMNUM (SCM_IM_BIND
)):
2393 return unmemoize_exprs (expr
, env
); /* FIXME */
2395 case (ISYMNUM (SCM_IM_CONT
)):
2396 return unmemoize_atcall_cc (expr
, env
);
2398 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2399 return unmemoize_at_call_with_values (expr
, env
);
2402 /* See futures.h for a comment why futures are not enabled.
2404 case (ISYMNUM (SCM_IM_FUTURE
)):
2405 return unmemoize_future (expr
, env
);
2408 case (ISYMNUM (SCM_IM_SLOT_REF
)):
2409 return unmemoize_atslot_ref (expr
, env
);
2411 case (ISYMNUM (SCM_IM_SLOT_SET_X
)):
2412 return unmemoize_atslot_set_x (expr
, env
);
2414 case (ISYMNUM (SCM_IM_NIL_COND
)):
2415 return unmemoize_exprs (expr
, env
); /* FIXME */
2418 return unmemoize_exprs (expr
, env
); /* FIXME */
2423 /* scm_i_unmemocopy_expr and scm_i_unmemocopy_body take a memoized expression
2424 * respectively a memoized body together with its environment and rewrite it
2425 * to its original form. Thus, these functions are the inversion of the
2426 * rewrite rules above. The procedure is not optimized for speed. It's used
2427 * in scm_i_unmemoize_expr, scm_procedure_source, macro_print and scm_iprin1.
2429 * Unmemoizing is not a reliable process. You cannot in general expect to get
2430 * the original source back.
2432 * However, GOOPS currently relies on this for method compilation. This ought
2436 scm_i_unmemocopy_expr (SCM expr
, SCM env
)
2438 const SCM source_properties
= scm_whash_lookup (scm_source_whash
, expr
);
2439 const SCM um_expr
= unmemoize_expression (expr
, env
);
2441 if (scm_is_true (source_properties
))
2442 scm_whash_insert (scm_source_whash
, um_expr
, source_properties
);
2448 scm_i_unmemocopy_body (SCM forms
, SCM env
)
2450 const SCM source_properties
= scm_whash_lookup (scm_source_whash
, forms
);
2451 const SCM um_forms
= unmemoize_exprs (forms
, env
);
2453 if (scm_is_true (source_properties
))
2454 scm_whash_insert (scm_source_whash
, um_forms
, source_properties
);
2460 #if (SCM_ENABLE_DEPRECATED == 1)
2462 /* Deprecated in guile 1.7.0 on 2003-11-09. */
2464 scm_m_expand_body (SCM exprs
, SCM env
)
2466 scm_c_issue_deprecation_warning
2467 ("`scm_m_expand_body' is deprecated.");
2468 m_expand_body (exprs
, env
);
2473 SCM_SYNTAX (s_undefine
, "undefine", scm_makacro
, scm_m_undefine
);
2476 scm_m_undefine (SCM expr
, SCM env
)
2481 const SCM cdr_expr
= SCM_CDR (expr
);
2482 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), "Bad undefine placement in", expr
);
2483 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2484 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2486 scm_c_issue_deprecation_warning
2487 ("`undefine' is deprecated.\n");
2489 variable
= SCM_CAR (cdr_expr
);
2490 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
2491 location
= scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_F
);
2492 ASSERT_SYNTAX_2 (scm_is_true (location
)
2493 && !SCM_UNBNDP (SCM_VARIABLE_REF (location
)),
2494 "variable already unbound ", variable
, expr
);
2495 SCM_VARIABLE_SET (location
, SCM_UNDEFINED
);
2496 return SCM_UNSPECIFIED
;
2500 scm_macroexp (SCM x
, SCM env
)
2502 scm_c_issue_deprecation_warning
2503 ("`scm_macroexp' is deprecated.");
2504 return macroexp (x
, env
);
2510 #if (SCM_ENABLE_DEPRECATED == 1)
2513 scm_unmemocar (SCM form
, SCM env
)
2515 scm_c_issue_deprecation_warning
2516 ("`scm_unmemocar' is deprecated.");
2518 if (!scm_is_pair (form
))
2522 SCM c
= SCM_CAR (form
);
2523 if (SCM_VARIABLEP (c
))
2525 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
2526 if (scm_is_false (sym
))
2527 sym
= sym_three_question_marks
;
2528 SCM_SETCAR (form
, sym
);
2530 else if (SCM_ILOCP (c
))
2532 unsigned long int ir
;
2534 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
2535 env
= SCM_CDR (env
);
2536 env
= SCM_CAAR (env
);
2537 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
2538 env
= SCM_CDR (env
);
2540 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
2548 /*****************************************************************************/
2549 /*****************************************************************************/
2550 /* The definitions for execution start here. */
2551 /*****************************************************************************/
2552 /*****************************************************************************/
2554 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
2555 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
2556 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
2557 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
2558 SCM_SYMBOL (sym_instead
, "instead");
2560 /* A function object to implement "apply" for non-closure functions. */
2562 /* An endless list consisting of #<undefined> objects: */
2563 static SCM undefineds
;
2567 scm_badargsp (SCM formals
, SCM args
)
2569 while (!scm_is_null (formals
))
2571 if (!scm_is_pair (formals
))
2573 if (scm_is_null (args
))
2575 formals
= SCM_CDR (formals
);
2576 args
= SCM_CDR (args
);
2578 return !scm_is_null (args
) ? 1 : 0;
2583 /* The evaluator contains a plethora of EVAL symbols. This is an attempt at
2586 * The following macros should be used in code which is read twice (where the
2587 * choice of evaluator is hard soldered):
2589 * CEVAL is the symbol used within one evaluator to call itself.
2590 * Originally, it is defined to ceval, but is redefined to deval during the
2593 * SCM_I_EVALIM is used when it is known that the expression is an
2594 * immediate. (This macro never calls an evaluator.)
2596 * EVAL evaluates an expression that is expected to have its symbols already
2597 * memoized. Expressions that are not of the form '(<form> <form> ...)' are
2598 * evaluated inline without calling an evaluator.
2600 * EVALCAR evaluates the car of an expression 'X:(Y:<form> <form> ...)',
2601 * potentially replacing a symbol at the position Y:<form> by its memoized
2602 * variable. If Y:<form> is not of the form '(<form> <form> ...)', the
2603 * evaluation is performed inline without calling an evaluator.
2605 * The following macros should be used in code which is read once
2606 * (where the choice of evaluator is dynamic):
2608 * SCM_I_XEVAL corresponds to EVAL, but uses ceval *or* deval depending on the
2611 * SCM_I_XEVALCAR corresponds to EVALCAR, but uses ceval *or* deval depending
2612 * on the debugging mode.
2614 * The main motivation for keeping this plethora is efficiency
2615 * together with maintainability (=> locality of code).
2618 static SCM
ceval (SCM x
, SCM env
);
2619 static SCM
deval (SCM x
, SCM env
);
2623 #define SCM_I_EVALIM2(x) \
2624 ((scm_is_eq ((x), SCM_EOL) \
2625 ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \
2629 #define SCM_I_EVALIM(x, env) (SCM_ILOCP (x) \
2630 ? *scm_ilookup ((x), (env)) \
2633 #define SCM_I_XEVAL(x, env) \
2635 ? SCM_I_EVALIM2 (x) \
2636 : (SCM_VARIABLEP (x) \
2637 ? SCM_VARIABLE_REF (x) \
2638 : (scm_is_pair (x) \
2639 ? (scm_debug_mode_p \
2640 ? deval ((x), (env)) \
2641 : ceval ((x), (env))) \
2644 #define SCM_I_XEVALCAR(x, env) \
2645 (SCM_IMP (SCM_CAR (x)) \
2646 ? SCM_I_EVALIM (SCM_CAR (x), (env)) \
2647 : (SCM_VARIABLEP (SCM_CAR (x)) \
2648 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2649 : (scm_is_pair (SCM_CAR (x)) \
2650 ? (scm_debug_mode_p \
2651 ? deval (SCM_CAR (x), (env)) \
2652 : ceval (SCM_CAR (x), (env))) \
2653 : (!scm_is_symbol (SCM_CAR (x)) \
2655 : *scm_lookupcar ((x), (env), 1)))))
2657 #define EVAL(x, env) \
2659 ? SCM_I_EVALIM ((x), (env)) \
2660 : (SCM_VARIABLEP (x) \
2661 ? SCM_VARIABLE_REF (x) \
2662 : (scm_is_pair (x) \
2663 ? CEVAL ((x), (env)) \
2666 #define EVALCAR(x, env) \
2667 (SCM_IMP (SCM_CAR (x)) \
2668 ? SCM_I_EVALIM (SCM_CAR (x), (env)) \
2669 : (SCM_VARIABLEP (SCM_CAR (x)) \
2670 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2671 : (scm_is_pair (SCM_CAR (x)) \
2672 ? CEVAL (SCM_CAR (x), (env)) \
2673 : (!scm_is_symbol (SCM_CAR (x)) \
2675 : *scm_lookupcar ((x), (env), 1)))))
2677 scm_i_pthread_mutex_t source_mutex
;
2680 /* Lookup a given local variable in an environment. The local variable is
2681 * given as an iloc, that is a triple <frame, binding, last?>, where frame
2682 * indicates the relative number of the environment frame (counting upwards
2683 * from the innermost environment frame), binding indicates the number of the
2684 * binding within the frame, and last? (which is extracted from the iloc using
2685 * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
2686 * very end of the improper list of bindings. */
2688 scm_ilookup (SCM iloc
, SCM env
)
2690 unsigned int frame_nr
= SCM_IFRAME (iloc
);
2691 unsigned int binding_nr
= SCM_IDIST (iloc
);
2695 for (; 0 != frame_nr
; --frame_nr
)
2696 frames
= SCM_CDR (frames
);
2698 bindings
= SCM_CAR (frames
);
2699 for (; 0 != binding_nr
; --binding_nr
)
2700 bindings
= SCM_CDR (bindings
);
2702 if (SCM_ICDRP (iloc
))
2703 return SCM_CDRLOC (bindings
);
2704 return SCM_CARLOC (SCM_CDR (bindings
));
2708 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
2710 static void error_unbound_variable (SCM symbol
) SCM_NORETURN
;
2711 static void error_defined_variable (SCM symbol
) SCM_NORETURN
;
2713 /* Call this for variables that are unfound.
2716 error_unbound_variable (SCM symbol
)
2718 scm_error (scm_unbound_variable_key
, NULL
,
2719 "Unbound variable: ~S",
2720 scm_list_1 (symbol
), SCM_BOOL_F
);
2723 /* Call this for variables that are found but contain SCM_UNDEFINED.
2726 error_defined_variable (SCM symbol
)
2728 /* We use the 'unbound-variable' key here as well, since it
2729 basically is the same kind of error, with a slight variation in
2730 the displayed message.
2732 scm_error (scm_unbound_variable_key
, NULL
,
2733 "Variable used before given a value: ~S",
2734 scm_list_1 (symbol
), SCM_BOOL_F
);
2738 /* The Lookup Car Race
2741 Memoization of variables and special forms is done while executing
2742 the code for the first time. As long as there is only one thread
2743 everything is fine, but as soon as two threads execute the same
2744 code concurrently `for the first time' they can come into conflict.
2746 This memoization includes rewriting variable references into more
2747 efficient forms and expanding macros. Furthermore, macro expansion
2748 includes `compiling' special forms like `let', `cond', etc. into
2749 tree-code instructions.
2751 There shouldn't normally be a problem with memoizing local and
2752 global variable references (into ilocs and variables), because all
2753 threads will mutate the code in *exactly* the same way and (if I
2754 read the C code correctly) it is not possible to observe a half-way
2755 mutated cons cell. The lookup procedure can handle this
2756 transparently without any critical sections.
2758 It is different with macro expansion, because macro expansion
2759 happens outside of the lookup procedure and can't be
2760 undone. Therefore the lookup procedure can't cope with it. It has
2761 to indicate failure when it detects a lost race and hope that the
2762 caller can handle it. Luckily, it turns out that this is the case.
2764 An example to illustrate this: Suppose that the following form will
2765 be memoized concurrently by two threads
2769 Let's first examine the lookup of X in the body. The first thread
2770 decides that it has to find the symbol "x" in the environment and
2771 starts to scan it. Then the other thread takes over and actually
2772 overtakes the first. It looks up "x" and substitutes an
2773 appropriate iloc for it. Now the first thread continues and
2774 completes its lookup. It comes to exactly the same conclusions as
2775 the second one and could - without much ado - just overwrite the
2776 iloc with the same iloc.
2778 But let's see what will happen when the race occurs while looking
2779 up the symbol "let" at the start of the form. It could happen that
2780 the second thread interrupts the lookup of the first thread and not
2781 only substitutes a variable for it but goes right ahead and
2782 replaces it with the compiled form (#@let* (x 12) x). Now, when
2783 the first thread completes its lookup, it would replace the #@let*
2784 with a variable containing the "let" binding, effectively reverting
2785 the form to (let (x 12) x). This is wrong. It has to detect that
2786 it has lost the race and the evaluator has to reconsider the
2787 changed form completely.
2789 This race condition could be resolved with some kind of traffic
2790 light (like mutexes) around scm_lookupcar, but I think that it is
2791 best to avoid them in this case. They would serialize memoization
2792 completely and because lookup involves calling arbitrary Scheme
2793 code (via the lookup-thunk), threads could be blocked for an
2794 arbitrary amount of time or even deadlock. But with the current
2795 solution a lot of unnecessary work is potentially done. */
2797 /* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
2798 return NULL to indicate a failed lookup due to some race conditions
2799 between threads. This only happens when VLOC is the first cell of
2800 a special form that will eventually be memoized (like `let', etc.)
2801 In that case the whole lookup is bogus and the caller has to
2802 reconsider the complete special form.
2804 SCM_LOOKUPCAR is still there, of course. It just calls
2805 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
2806 should only be called when it is known that VLOC is not the first
2807 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
2808 for NULL. I think I've found the only places where this
2812 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
2815 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
2816 register SCM iloc
= SCM_ILOC00
;
2817 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
2819 if (!scm_is_pair (SCM_CAR (env
)))
2821 al
= SCM_CARLOC (env
);
2822 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
2824 if (!scm_is_pair (fl
))
2826 if (scm_is_eq (fl
, var
))
2828 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2830 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
2831 return SCM_CDRLOC (*al
);
2836 al
= SCM_CDRLOC (*al
);
2837 if (scm_is_eq (SCM_CAR (fl
), var
))
2839 if (SCM_UNBNDP (SCM_CAR (*al
)))
2840 error_defined_variable (var
);
2841 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2843 SCM_SETCAR (vloc
, iloc
);
2844 return SCM_CARLOC (*al
);
2846 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
2848 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
2851 SCM top_thunk
, real_var
;
2854 top_thunk
= SCM_CAR (env
); /* env now refers to a
2855 top level env thunk */
2856 env
= SCM_CDR (env
);
2859 top_thunk
= SCM_BOOL_F
;
2860 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
2861 if (scm_is_false (real_var
))
2864 if (!scm_is_null (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
2869 if (scm_is_null (env
))
2870 error_unbound_variable (var
);
2872 scm_misc_error (NULL
, "Damaged environment: ~S",
2877 /* A variable could not be found, but we shall
2878 not throw an error. */
2879 static SCM undef_object
= SCM_UNDEFINED
;
2880 return &undef_object
;
2884 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2886 /* Some other thread has changed the very cell we are working
2887 on. In effect, it must have done our job or messed it up
2890 var
= SCM_CAR (vloc
);
2891 if (SCM_VARIABLEP (var
))
2892 return SCM_VARIABLE_LOC (var
);
2893 if (SCM_ILOCP (var
))
2894 return scm_ilookup (var
, genv
);
2895 /* We can't cope with anything else than variables and ilocs. When
2896 a special form has been memoized (i.e. `let' into `#@let') we
2897 return NULL and expect the calling function to do the right
2898 thing. For the evaluator, this means going back and redoing
2899 the dispatch on the car of the form. */
2903 SCM_SETCAR (vloc
, real_var
);
2904 return SCM_VARIABLE_LOC (real_var
);
2909 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
2911 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
2918 /* During execution, look up a symbol in the top level of the given local
2919 * environment and return the corresponding variable object. If no binding
2920 * for the symbol can be found, an 'Unbound variable' error is signalled. */
2922 lazy_memoize_variable (const SCM symbol
, const SCM environment
)
2924 const SCM top_level
= scm_env_top_level (environment
);
2925 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
2927 if (scm_is_false (variable
))
2928 error_unbound_variable (symbol
);
2935 scm_eval_car (SCM pair
, SCM env
)
2937 return SCM_I_XEVALCAR (pair
, env
);
2942 scm_eval_args (SCM l
, SCM env
, SCM proc
)
2944 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
2945 while (scm_is_pair (l
))
2947 res
= EVALCAR (l
, env
);
2949 *lloc
= scm_list_1 (res
);
2950 lloc
= SCM_CDRLOC (*lloc
);
2953 if (!scm_is_null (l
))
2954 scm_wrong_num_args (proc
);
2960 scm_eval_body (SCM code
, SCM env
)
2965 next
= SCM_CDR (code
);
2966 while (!scm_is_null (next
))
2968 if (SCM_IMP (SCM_CAR (code
)))
2970 if (SCM_ISYMP (SCM_CAR (code
)))
2972 scm_i_scm_pthread_mutex_lock (&source_mutex
);
2973 /* check for race condition */
2974 if (SCM_ISYMP (SCM_CAR (code
)))
2975 m_expand_body (code
, env
);
2976 scm_i_pthread_mutex_unlock (&source_mutex
);
2981 SCM_I_XEVAL (SCM_CAR (code
), env
);
2983 next
= SCM_CDR (code
);
2985 return SCM_I_XEVALCAR (code
, env
);
2991 /* SECTION: This code is specific for the debugging support. One
2992 * branch is read when DEVAL isn't defined, the other when DEVAL is
2998 #define SCM_APPLY scm_apply
2999 #define PREP_APPLY(proc, args)
3001 #define RETURN(x) do { return x; } while (0)
3002 #ifdef STACK_CHECKING
3003 #ifndef NO_CEVAL_STACK_CHECKING
3004 #define EVAL_STACK_CHECKING
3011 #define CEVAL deval /* Substitute all uses of ceval */
3014 #define SCM_APPLY scm_dapply
3017 #define PREP_APPLY(p, l) \
3018 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
3021 #define ENTER_APPLY \
3023 SCM_SET_ARGSREADY (debug);\
3024 if (scm_check_apply_p && SCM_TRAPS_P)\
3025 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
3027 SCM tmp, tail = scm_from_bool(SCM_TRACED_FRAME_P (debug)); \
3028 SCM_SET_TRACED_FRAME (debug); \
3030 tmp = scm_make_debugobj (&debug);\
3031 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
3037 #define RETURN(e) do { proc = (e); goto exit; } while (0)
3039 #ifdef STACK_CHECKING
3040 #ifndef EVAL_STACK_CHECKING
3041 #define EVAL_STACK_CHECKING
3046 /* scm_last_debug_frame contains a pointer to the last debugging information
3047 * stack frame. It is accessed very often from the debugging evaluator, so it
3048 * should probably not be indirectly addressed. Better to save and restore it
3049 * from the current root at any stack swaps.
3052 /* scm_debug_eframe_size is the number of slots available for pseudo
3053 * stack frames at each real stack frame.
3056 long scm_debug_eframe_size
;
3058 int scm_debug_mode_p
;
3059 int scm_check_entry_p
;
3060 int scm_check_apply_p
;
3061 int scm_check_exit_p
;
3063 long scm_eval_stack
;
3065 scm_t_option scm_eval_opts
[] = {
3066 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
3069 scm_t_option scm_debug_opts
[] = {
3070 { SCM_OPTION_BOOLEAN
, "cheap", 1,
3071 "*This option is now obsolete. Setting it has no effect." },
3072 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
3073 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
3074 { SCM_OPTION_BOOLEAN
, "procnames", 1,
3075 "Record procedure names at definition." },
3076 { SCM_OPTION_BOOLEAN
, "backwards", 0,
3077 "Display backtrace in anti-chronological order." },
3078 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
3079 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
3080 { SCM_OPTION_INTEGER
, "frames", 3,
3081 "Maximum number of tail-recursive frames in backtrace." },
3082 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
3083 "Maximal number of stored backtrace frames." },
3084 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
3085 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
3086 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
3087 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
3088 { 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."},
3089 { SCM_OPTION_BOOLEAN
, "warn-deprecated", 0, "Warn when deprecated features are used." }
3092 scm_t_option scm_evaluator_trap_table
[] = {
3093 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
3094 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
3095 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
3096 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
3097 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
3098 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
3099 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
3102 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
3104 "Option interface for the evaluation options. Instead of using\n"
3105 "this procedure directly, use the procedures @code{eval-enable},\n"
3106 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
3107 #define FUNC_NAME s_scm_eval_options_interface
3111 scm_dynwind_begin (0);
3112 scm_dynwind_critical_section (SCM_BOOL_F
);
3113 ans
= scm_options (setting
,
3117 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
3125 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
3127 "Option interface for the evaluator trap options.")
3128 #define FUNC_NAME s_scm_evaluator_traps
3131 SCM_CRITICAL_SECTION_START
;
3132 ans
= scm_options (setting
,
3133 scm_evaluator_trap_table
,
3134 SCM_N_EVALUATOR_TRAPS
,
3136 /* njrev: same again. */
3137 SCM_RESET_DEBUG_MODE
;
3138 SCM_CRITICAL_SECTION_END
;
3145 deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
3147 SCM
*results
= lloc
;
3148 while (scm_is_pair (l
))
3150 const SCM res
= EVALCAR (l
, env
);
3152 *lloc
= scm_list_1 (res
);
3153 lloc
= SCM_CDRLOC (*lloc
);
3156 if (!scm_is_null (l
))
3157 scm_wrong_num_args (proc
);
3162 eval_letrec_inits (SCM env
, SCM init_forms
, SCM
**init_values_eol
)
3165 int i
= 0, imax
= sizeof (argv
) / sizeof (SCM
);
3167 while (!scm_is_null (init_forms
))
3171 eval_letrec_inits (env
, init_forms
, init_values_eol
);
3174 argv
[i
++] = EVALCAR (init_forms
, env
);
3175 init_forms
= SCM_CDR (init_forms
);
3178 for (i
--; i
>= 0; i
--)
3180 **init_values_eol
= scm_list_1 (argv
[i
]);
3181 *init_values_eol
= SCM_CDRLOC (**init_values_eol
);
3188 /* SECTION: This code is compiled twice.
3192 /* Update the toplevel environment frame ENV so that it refers to the
3193 * current module. */
3194 #define UPDATE_TOPLEVEL_ENV(env) \
3196 SCM p = scm_current_module_lookup_closure (); \
3197 if (p != SCM_CAR (env)) \
3198 env = scm_top_level_env (p); \
3202 #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
3203 ASSERT_SYNTAX (!scm_is_eq ((x), SCM_EOL), s_empty_combination, x)
3206 /* This is the evaluator. Like any real monster, it has three heads:
3208 * ceval is the non-debugging evaluator, deval is the debugging version. Both
3209 * are implemented using a common code base, using the following mechanism:
3210 * CEVAL is a macro, which is either defined to ceval or deval. Thus, there
3211 * is no function CEVAL, but the code for CEVAL actually compiles to either
3212 * ceval or deval. When CEVAL is defined to ceval, it is known that the macro
3213 * DEVAL is not defined. When CEVAL is defined to deval, then the macro DEVAL
3214 * is known to be defined. Thus, in CEVAL parts for the debugging evaluator
3215 * are enclosed within #ifdef DEVAL ... #endif.
3217 * All three (ceval, deval and their common implementation CEVAL) take two
3218 * input parameters, x and env: x is a single expression to be evalutated.
3219 * env is the environment in which bindings are searched.
3221 * x is known to be a pair. Since x is a single expression, it is necessarily
3222 * in a tail position. If x is just a call to another function like in the
3223 * expression (foo exp1 exp2 ...), the realization of that call therefore
3224 * _must_not_ increase stack usage (the evaluation of exp1, exp2 etc.,
3225 * however, may do so). This is realized by making extensive use of 'goto'
3226 * statements within the evaluator: The gotos replace recursive calls to
3227 * CEVAL, thus re-using the same stack frame that CEVAL was already using.
3228 * If, however, x represents some form that requires to evaluate a sequence of
3229 * expressions like (begin exp1 exp2 ...), then recursive calls to CEVAL are
3230 * performed for all but the last expression of that sequence. */
3233 CEVAL (SCM x
, SCM env
)
3237 scm_t_debug_frame debug
;
3238 scm_t_debug_info
*debug_info_end
;
3239 debug
.prev
= scm_i_last_debug_frame ();
3242 * The debug.vect contains twice as much scm_t_debug_info frames as the
3243 * user has specified with (debug-set! frames <n>).
3245 * Even frames are eval frames, odd frames are apply frames.
3247 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
3248 * sizeof (scm_t_debug_info
));
3249 debug
.info
= debug
.vect
;
3250 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
3251 scm_i_set_last_debug_frame (&debug
);
3253 #ifdef EVAL_STACK_CHECKING
3254 if (scm_stack_checking_enabled_p
&& SCM_STACK_OVERFLOW_P (&proc
))
3257 debug
.info
->e
.exp
= x
;
3258 debug
.info
->e
.env
= env
;
3260 scm_report_stack_overflow ();
3270 SCM_CLEAR_ARGSREADY (debug
);
3271 if (SCM_OVERFLOWP (debug
))
3274 * In theory, this should be the only place where it is necessary to
3275 * check for space in debug.vect since both eval frames and
3276 * available space are even.
3278 * For this to be the case, however, it is necessary that primitive
3279 * special forms which jump back to `loop', `begin' or some similar
3280 * label call PREP_APPLY.
3282 else if (++debug
.info
>= debug_info_end
)
3284 SCM_SET_OVERFLOW (debug
);
3289 debug
.info
->e
.exp
= x
;
3290 debug
.info
->e
.env
= env
;
3291 if (scm_check_entry_p
&& SCM_TRAPS_P
)
3293 if (SCM_ENTER_FRAME_P
3294 || (SCM_BREAKPOINTS_P
&& scm_c_source_property_breakpoint_p (x
)))
3297 SCM tail
= scm_from_bool (SCM_TAILRECP (debug
));
3298 SCM_SET_TAILREC (debug
);
3299 stackrep
= scm_make_debugobj (&debug
);
3301 stackrep
= scm_call_4 (SCM_ENTER_FRAME_HDLR
,
3302 scm_sym_enter_frame
,
3305 unmemoize_expression (x
, env
));
3307 if (scm_is_pair (stackrep
) &&
3308 scm_is_eq (SCM_CAR (stackrep
), sym_instead
))
3310 /* This gives the possibility for the debugger to modify
3311 the source expression before evaluation. */
3312 x
= SCM_CDR (stackrep
);
3321 if (SCM_ISYMP (SCM_CAR (x
)))
3323 switch (ISYMNUM (SCM_CAR (x
)))
3325 case (ISYMNUM (SCM_IM_AND
)):
3327 while (!scm_is_null (SCM_CDR (x
)))
3329 SCM test_result
= EVALCAR (x
, env
);
3330 if (scm_is_false (test_result
) || SCM_NILP (test_result
))
3331 RETURN (SCM_BOOL_F
);
3335 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3338 case (ISYMNUM (SCM_IM_BEGIN
)):
3340 if (scm_is_null (x
))
3341 RETURN (SCM_UNSPECIFIED
);
3343 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3346 /* If we are on toplevel with a lookup closure, we need to sync
3347 with the current module. */
3348 if (scm_is_pair (env
) && !scm_is_pair (SCM_CAR (env
)))
3350 UPDATE_TOPLEVEL_ENV (env
);
3351 while (!scm_is_null (SCM_CDR (x
)))
3354 UPDATE_TOPLEVEL_ENV (env
);
3360 goto nontoplevel_begin
;
3363 while (!scm_is_null (SCM_CDR (x
)))
3365 const SCM form
= SCM_CAR (x
);
3368 if (SCM_ISYMP (form
))
3370 scm_i_scm_pthread_mutex_lock (&source_mutex
);
3371 /* check for race condition */
3372 if (SCM_ISYMP (SCM_CAR (x
)))
3373 m_expand_body (x
, env
);
3374 scm_i_pthread_mutex_unlock (&source_mutex
);
3375 goto nontoplevel_begin
;
3378 SCM_VALIDATE_NON_EMPTY_COMBINATION (form
);
3381 (void) EVAL (form
, env
);
3387 /* scm_eval last form in list */
3388 const SCM last_form
= SCM_CAR (x
);
3390 if (scm_is_pair (last_form
))
3392 /* This is by far the most frequent case. */
3394 goto loop
; /* tail recurse */
3396 else if (SCM_IMP (last_form
))
3397 RETURN (SCM_I_EVALIM (last_form
, env
));
3398 else if (SCM_VARIABLEP (last_form
))
3399 RETURN (SCM_VARIABLE_REF (last_form
));
3400 else if (scm_is_symbol (last_form
))
3401 RETURN (*scm_lookupcar (x
, env
, 1));
3407 case (ISYMNUM (SCM_IM_CASE
)):
3410 const SCM key
= EVALCAR (x
, env
);
3412 while (!scm_is_null (x
))
3414 const SCM clause
= SCM_CAR (x
);
3415 SCM labels
= SCM_CAR (clause
);
3416 if (scm_is_eq (labels
, SCM_IM_ELSE
))
3418 x
= SCM_CDR (clause
);
3419 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3422 while (!scm_is_null (labels
))
3424 const SCM label
= SCM_CAR (labels
);
3425 if (scm_is_eq (label
, key
)
3426 || scm_is_true (scm_eqv_p (label
, key
)))
3428 x
= SCM_CDR (clause
);
3429 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3432 labels
= SCM_CDR (labels
);
3437 RETURN (SCM_UNSPECIFIED
);
3440 case (ISYMNUM (SCM_IM_COND
)):
3442 while (!scm_is_null (x
))
3444 const SCM clause
= SCM_CAR (x
);
3445 if (scm_is_eq (SCM_CAR (clause
), SCM_IM_ELSE
))
3447 x
= SCM_CDR (clause
);
3448 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3453 arg1
= EVALCAR (clause
, env
);
3454 /* SRFI 61 extended cond */
3455 if (!scm_is_null (SCM_CDR (clause
))
3456 && !scm_is_null (SCM_CDDR (clause
))
3457 && scm_is_eq (SCM_CADDR (clause
), SCM_IM_ARROW
))
3459 SCM xx
, guard_result
;
3460 if (SCM_VALUESP (arg1
))
3461 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
3463 arg1
= scm_list_1 (arg1
);
3464 xx
= SCM_CDR (clause
);
3465 proc
= EVALCAR (xx
, env
);
3466 guard_result
= SCM_APPLY (proc
, arg1
, SCM_EOL
);
3467 if (scm_is_true (guard_result
)
3468 && !SCM_NILP (guard_result
))
3470 proc
= SCM_CDDR (xx
);
3471 proc
= EVALCAR (proc
, env
);
3472 PREP_APPLY (proc
, arg1
);
3476 else if (scm_is_true (arg1
) && !SCM_NILP (arg1
))
3478 x
= SCM_CDR (clause
);
3479 if (scm_is_null (x
))
3481 else if (!scm_is_eq (SCM_CAR (x
), SCM_IM_ARROW
))
3483 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3489 proc
= EVALCAR (proc
, env
);
3490 PREP_APPLY (proc
, scm_list_1 (arg1
));
3498 RETURN (SCM_UNSPECIFIED
);
3501 case (ISYMNUM (SCM_IM_DO
)):
3504 /* Compute the initialization values and the initial environment. */
3505 SCM init_forms
= SCM_CAR (x
);
3506 SCM init_values
= SCM_EOL
;
3507 while (!scm_is_null (init_forms
))
3509 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3510 init_forms
= SCM_CDR (init_forms
);
3513 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
3517 SCM test_form
= SCM_CAR (x
);
3518 SCM body_forms
= SCM_CADR (x
);
3519 SCM step_forms
= SCM_CDDR (x
);
3521 SCM test_result
= EVALCAR (test_form
, env
);
3523 while (scm_is_false (test_result
) || SCM_NILP (test_result
))
3526 /* Evaluate body forms. */
3528 for (temp_forms
= body_forms
;
3529 !scm_is_null (temp_forms
);
3530 temp_forms
= SCM_CDR (temp_forms
))
3532 SCM form
= SCM_CAR (temp_forms
);
3533 /* Dirk:FIXME: We only need to eval forms that may have
3534 * a side effect here. This is only true for forms that
3535 * start with a pair. All others are just constants.
3536 * Since with the current memoizer 'form' may hold a
3537 * constant, we call EVAL here to handle the constant
3538 * cases. In the long run it would make sense to have
3539 * the macro transformer of 'do' eliminate all forms
3540 * that have no sideeffect. Then instead of EVAL we
3541 * could call CEVAL directly here. */
3542 (void) EVAL (form
, env
);
3547 /* Evaluate the step expressions. */
3549 SCM step_values
= SCM_EOL
;
3550 for (temp_forms
= step_forms
;
3551 !scm_is_null (temp_forms
);
3552 temp_forms
= SCM_CDR (temp_forms
))
3554 const SCM value
= EVALCAR (temp_forms
, env
);
3555 step_values
= scm_cons (value
, step_values
);
3557 env
= SCM_EXTEND_ENV (SCM_CAAR (env
),
3562 test_result
= EVALCAR (test_form
, env
);
3566 if (scm_is_null (x
))
3567 RETURN (SCM_UNSPECIFIED
);
3568 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3569 goto nontoplevel_begin
;
3572 case (ISYMNUM (SCM_IM_IF
)):
3575 SCM test_result
= EVALCAR (x
, env
);
3576 x
= SCM_CDR (x
); /* then expression */
3577 if (scm_is_false (test_result
) || SCM_NILP (test_result
))
3579 x
= SCM_CDR (x
); /* else expression */
3580 if (scm_is_null (x
))
3581 RETURN (SCM_UNSPECIFIED
);
3584 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3588 case (ISYMNUM (SCM_IM_LET
)):
3591 SCM init_forms
= SCM_CADR (x
);
3592 SCM init_values
= SCM_EOL
;
3595 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3596 init_forms
= SCM_CDR (init_forms
);
3598 while (!scm_is_null (init_forms
));
3599 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
3602 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3603 goto nontoplevel_begin
;
3606 case (ISYMNUM (SCM_IM_LETREC
)):
3608 env
= SCM_EXTEND_ENV (SCM_CAR (x
), undefineds
, env
);
3611 SCM init_forms
= SCM_CAR (x
);
3612 SCM init_values
= scm_list_1 (SCM_BOOL_T
);
3613 SCM
*init_values_eol
= SCM_CDRLOC (init_values
);
3614 eval_letrec_inits (env
, init_forms
, &init_values_eol
);
3615 SCM_SETCDR (SCM_CAR (env
), SCM_CDR (init_values
));
3618 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3619 goto nontoplevel_begin
;
3622 case (ISYMNUM (SCM_IM_LETSTAR
)):
3625 SCM bindings
= SCM_CAR (x
);
3626 if (!scm_is_null (bindings
))
3630 SCM name
= SCM_CAR (bindings
);
3631 SCM init
= SCM_CDR (bindings
);
3632 env
= SCM_EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
3633 bindings
= SCM_CDR (init
);
3635 while (!scm_is_null (bindings
));
3639 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3640 goto nontoplevel_begin
;
3643 case (ISYMNUM (SCM_IM_OR
)):
3645 while (!scm_is_null (SCM_CDR (x
)))
3647 SCM val
= EVALCAR (x
, env
);
3648 if (scm_is_true (val
) && !SCM_NILP (val
))
3653 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3657 case (ISYMNUM (SCM_IM_LAMBDA
)):
3658 RETURN (scm_closure (SCM_CDR (x
), env
));
3661 case (ISYMNUM (SCM_IM_QUOTE
)):
3662 RETURN (SCM_CDR (x
));
3665 case (ISYMNUM (SCM_IM_SET_X
)):
3669 SCM variable
= SCM_CAR (x
);
3670 if (SCM_ILOCP (variable
))
3671 location
= scm_ilookup (variable
, env
);
3672 else if (SCM_VARIABLEP (variable
))
3673 location
= SCM_VARIABLE_LOC (variable
);
3676 /* (scm_is_symbol (variable)) is known to be true */
3677 variable
= lazy_memoize_variable (variable
, env
);
3678 SCM_SETCAR (x
, variable
);
3679 location
= SCM_VARIABLE_LOC (variable
);
3682 *location
= EVALCAR (x
, env
);
3684 RETURN (SCM_UNSPECIFIED
);
3687 case (ISYMNUM (SCM_IM_APPLY
)):
3688 /* Evaluate the procedure to be applied. */
3690 proc
= EVALCAR (x
, env
);
3691 PREP_APPLY (proc
, SCM_EOL
);
3693 /* Evaluate the argument holding the list of arguments */
3695 arg1
= EVALCAR (x
, env
);
3698 /* Go here to tail-apply a procedure. PROC is the procedure and
3699 * ARG1 is the list of arguments. PREP_APPLY must have been called
3700 * before jumping to apply_proc. */
3701 if (SCM_CLOSUREP (proc
))
3703 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3705 debug
.info
->a
.args
= arg1
;
3707 if (scm_badargsp (formals
, arg1
))
3708 scm_wrong_num_args (proc
);
3710 /* Copy argument list */
3711 if (SCM_NULL_OR_NIL_P (arg1
))
3712 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
3715 SCM args
= scm_list_1 (SCM_CAR (arg1
));
3717 arg1
= SCM_CDR (arg1
);
3718 while (!SCM_NULL_OR_NIL_P (arg1
))
3720 SCM new_tail
= scm_list_1 (SCM_CAR (arg1
));
3721 SCM_SETCDR (tail
, new_tail
);
3723 arg1
= SCM_CDR (arg1
);
3725 env
= SCM_EXTEND_ENV (formals
, args
, SCM_ENV (proc
));
3728 x
= SCM_CLOSURE_BODY (proc
);
3729 goto nontoplevel_begin
;
3734 RETURN (SCM_APPLY (proc
, arg1
, SCM_EOL
));
3738 case (ISYMNUM (SCM_IM_CONT
)):
3741 SCM val
= scm_make_continuation (&first
);
3749 proc
= EVALCAR (proc
, env
);
3750 PREP_APPLY (proc
, scm_list_1 (arg1
));
3757 case (ISYMNUM (SCM_IM_DELAY
)):
3758 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
3761 /* See futures.h for a comment why futures are not enabled.
3763 case (ISYMNUM (SCM_IM_FUTURE
)):
3764 RETURN (scm_i_make_future (scm_closure (SCM_CDR (x
), env
)));
3767 /* PLACEHOLDER for case (ISYMNUM (SCM_IM_DISPATCH)): The following
3768 code (type_dispatch) is intended to be the tail of the case
3769 clause for the internal macro SCM_IM_DISPATCH. Please don't
3770 remove it from this location without discussing it with Mikael
3771 <djurfeldt@nada.kth.se> */
3773 /* The type dispatch code is duplicated below
3774 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
3775 * cuts down execution time for type dispatch to 50%. */
3776 type_dispatch
: /* inputs: x, arg1 */
3777 /* Type dispatch means to determine from the types of the function
3778 * arguments (i. e. the 'signature' of the call), which method from
3779 * a generic function is to be called. This process of selecting
3780 * the right method takes some time. To speed it up, guile uses
3781 * caching: Together with the macro call to dispatch the signatures
3782 * of some previous calls to that generic function from the same
3783 * place are stored (in the code!) in a cache that we call the
3784 * 'method cache'. This is done since it is likely, that
3785 * consecutive calls to dispatch from that position in the code will
3786 * have the same signature. Thus, the type dispatch works as
3787 * follows: First, determine a hash value from the signature of the
3788 * actual arguments. Second, use this hash value as an index to
3789 * find that same signature in the method cache stored at this
3790 * position in the code. If found, you have also found the
3791 * corresponding method that belongs to that signature. If the
3792 * signature is not found in the method cache, you have to perform a
3793 * full search over all signatures stored with the generic
3796 unsigned long int specializers
;
3797 unsigned long int hash_value
;
3798 unsigned long int cache_end_pos
;
3799 unsigned long int mask
;
3803 SCM z
= SCM_CDDR (x
);
3804 SCM tmp
= SCM_CADR (z
);
3805 specializers
= scm_to_ulong (SCM_CAR (z
));
3807 /* Compute a hash value for searching the method cache. There
3808 * are two variants for computing the hash value, a (rather)
3809 * complicated one, and a simple one. For the complicated one
3810 * explained below, tmp holds a number that is used in the
3812 if (scm_is_simple_vector (tmp
))
3814 /* This method of determining the hash value is much
3815 * simpler: Set the hash value to zero and just perform a
3816 * linear search through the method cache. */
3818 mask
= (unsigned long int) ((long) -1);
3820 cache_end_pos
= SCM_SIMPLE_VECTOR_LENGTH (method_cache
);
3824 /* Use the signature of the actual arguments to determine
3825 * the hash value. This is done as follows: Each class has
3826 * an array of random numbers, that are determined when the
3827 * class is created. The integer 'hashset' is an index into
3828 * that array of random numbers. Now, from all classes that
3829 * are part of the signature of the actual arguments, the
3830 * random numbers at index 'hashset' are taken and summed
3831 * up, giving the hash value. The value of 'hashset' is
3832 * stored at the call to dispatch. This allows to have
3833 * different 'formulas' for calculating the hash value at
3834 * different places where dispatch is called. This allows
3835 * to optimize the hash formula at every individual place
3836 * where dispatch is called, such that hopefully the hash
3837 * value that is computed will directly point to the right
3838 * method in the method cache. */
3839 unsigned long int hashset
= scm_to_ulong (tmp
);
3840 unsigned long int counter
= specializers
+ 1;
3843 while (!scm_is_null (tmp_arg
) && counter
!= 0)
3845 SCM
class = scm_class_of (SCM_CAR (tmp_arg
));
3846 hash_value
+= SCM_INSTANCE_HASH (class, hashset
);
3847 tmp_arg
= SCM_CDR (tmp_arg
);
3851 method_cache
= SCM_CADR (z
);
3852 mask
= scm_to_ulong (SCM_CAR (z
));
3854 cache_end_pos
= hash_value
;
3859 /* Search the method cache for a method with a matching
3860 * signature. Start the search at position 'hash_value'. The
3861 * hashing implementation uses linear probing for conflict
3862 * resolution, that is, if the signature in question is not
3863 * found at the starting index in the hash table, the next table
3864 * entry is tried, and so on, until in the worst case the whole
3865 * cache has been searched, but still the signature has not been
3870 SCM args
= arg1
; /* list of arguments */
3871 z
= SCM_SIMPLE_VECTOR_REF (method_cache
, hash_value
);
3872 while (!scm_is_null (args
))
3874 /* More arguments than specifiers => CLASS != ENV */
3875 SCM class_of_arg
= scm_class_of (SCM_CAR (args
));
3876 if (!scm_is_eq (class_of_arg
, SCM_CAR (z
)))
3878 args
= SCM_CDR (args
);
3881 /* Fewer arguments than specifiers => CAR != ENV */
3882 if (scm_is_null (SCM_CAR (z
)) || scm_is_pair (SCM_CAR (z
)))
3885 hash_value
= (hash_value
+ 1) & mask
;
3886 } while (hash_value
!= cache_end_pos
);
3888 /* No appropriate method was found in the cache. */
3889 z
= scm_memoize_method (x
, arg1
);
3891 apply_cmethod
: /* inputs: z, arg1 */
3893 SCM formals
= SCM_CMETHOD_FORMALS (z
);
3894 env
= SCM_EXTEND_ENV (formals
, arg1
, SCM_CMETHOD_ENV (z
));
3895 x
= SCM_CMETHOD_BODY (z
);
3896 goto nontoplevel_begin
;
3902 case (ISYMNUM (SCM_IM_SLOT_REF
)):
3905 SCM instance
= EVALCAR (x
, env
);
3906 unsigned long int slot
= SCM_I_INUM (SCM_CDR (x
));
3907 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance
) [slot
]));
3911 case (ISYMNUM (SCM_IM_SLOT_SET_X
)):
3914 SCM instance
= EVALCAR (x
, env
);
3915 unsigned long int slot
= SCM_I_INUM (SCM_CADR (x
));
3916 SCM value
= EVALCAR (SCM_CDDR (x
), env
);
3917 SCM_STRUCT_DATA (instance
) [slot
] = SCM_UNPACK (value
);
3918 RETURN (SCM_UNSPECIFIED
);
3922 #if SCM_ENABLE_ELISP
3924 case (ISYMNUM (SCM_IM_NIL_COND
)):
3926 SCM test_form
= SCM_CDR (x
);
3927 x
= SCM_CDR (test_form
);
3928 while (!SCM_NULL_OR_NIL_P (x
))
3930 SCM test_result
= EVALCAR (test_form
, env
);
3931 if (!(scm_is_false (test_result
)
3932 || SCM_NULL_OR_NIL_P (test_result
)))
3934 if (scm_is_eq (SCM_CAR (x
), SCM_UNSPECIFIED
))
3935 RETURN (test_result
);
3936 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3941 test_form
= SCM_CDR (x
);
3942 x
= SCM_CDR (test_form
);
3946 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3950 #endif /* SCM_ENABLE_ELISP */
3952 case (ISYMNUM (SCM_IM_BIND
)):
3954 SCM vars
, exps
, vals
;
3957 vars
= SCM_CAAR (x
);
3958 exps
= SCM_CDAR (x
);
3960 while (!scm_is_null (exps
))
3962 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
3963 exps
= SCM_CDR (exps
);
3966 scm_swap_bindings (vars
, vals
);
3967 scm_i_set_dynwinds (scm_acons (vars
, vals
, scm_i_dynwinds ()));
3969 /* Ignore all but the last evaluation result. */
3970 for (x
= SCM_CDR (x
); !scm_is_null (SCM_CDR (x
)); x
= SCM_CDR (x
))
3972 if (scm_is_pair (SCM_CAR (x
)))
3973 CEVAL (SCM_CAR (x
), env
);
3975 proc
= EVALCAR (x
, env
);
3977 scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
3978 scm_swap_bindings (vars
, vals
);
3984 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
3989 producer
= EVALCAR (x
, env
);
3991 proc
= EVALCAR (x
, env
); /* proc is the consumer. */
3992 arg1
= SCM_APPLY (producer
, SCM_EOL
, SCM_EOL
);
3993 if (SCM_VALUESP (arg1
))
3995 /* The list of arguments is not copied. Rather, it is assumed
3996 * that this has been done by the 'values' procedure. */
3997 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
4001 arg1
= scm_list_1 (arg1
);
4003 PREP_APPLY (proc
, arg1
);
4014 if (SCM_VARIABLEP (SCM_CAR (x
)))
4015 proc
= SCM_VARIABLE_REF (SCM_CAR (x
));
4016 else if (SCM_ILOCP (SCM_CAR (x
)))
4017 proc
= *scm_ilookup (SCM_CAR (x
), env
);
4018 else if (scm_is_pair (SCM_CAR (x
)))
4019 proc
= CEVAL (SCM_CAR (x
), env
);
4020 else if (scm_is_symbol (SCM_CAR (x
)))
4022 SCM orig_sym
= SCM_CAR (x
);
4024 SCM
*location
= scm_lookupcar1 (x
, env
, 1);
4025 if (location
== NULL
)
4027 /* we have lost the race, start again. */
4033 if (SCM_MACROP (proc
))
4035 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
4037 handle_a_macro
: /* inputs: x, env, proc */
4039 /* Set a flag during macro expansion so that macro
4040 application frames can be deleted from the backtrace. */
4041 SCM_SET_MACROEXP (debug
);
4043 arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
4044 scm_cons (env
, scm_listofnull
));
4046 SCM_CLEAR_MACROEXP (debug
);
4048 switch (SCM_MACRO_TYPE (proc
))
4052 if (!scm_is_pair (arg1
))
4053 arg1
= scm_list_2 (SCM_IM_BEGIN
, arg1
);
4055 assert (!scm_is_eq (x
, SCM_CAR (arg1
))
4056 && !scm_is_eq (x
, SCM_CDR (arg1
)));
4059 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
4061 SCM_CRITICAL_SECTION_START
;
4062 SCM_SETCAR (x
, SCM_CAR (arg1
));
4063 SCM_SETCDR (x
, SCM_CDR (arg1
));
4064 SCM_CRITICAL_SECTION_END
;
4067 /* Prevent memoizing of debug info expression. */
4068 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
4072 SCM_CRITICAL_SECTION_START
;
4073 SCM_SETCAR (x
, SCM_CAR (arg1
));
4074 SCM_SETCDR (x
, SCM_CDR (arg1
));
4075 SCM_CRITICAL_SECTION_END
;
4076 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
4078 #if SCM_ENABLE_DEPRECATED == 1
4083 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
4097 if (SCM_MACROP (proc
))
4098 goto handle_a_macro
;
4102 /* When reaching this part of the code, the following is granted: Variable x
4103 * holds the first pair of an expression of the form (<function> arg ...).
4104 * Variable proc holds the object that resulted from the evaluation of
4105 * <function>. In the following, the arguments (if any) will be evaluated,
4106 * and proc will be applied to them. If proc does not really hold a
4107 * function object, this will be signalled as an error on the scheme
4108 * level. If the number of arguments does not match the number of arguments
4109 * that are allowed to be passed to proc, also an error on the scheme level
4110 * will be signalled. */
4111 PREP_APPLY (proc
, SCM_EOL
);
4112 if (scm_is_null (SCM_CDR (x
))) {
4115 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4116 switch (SCM_TYP7 (proc
))
4117 { /* no arguments given */
4118 case scm_tc7_subr_0
:
4119 RETURN (SCM_SUBRF (proc
) ());
4120 case scm_tc7_subr_1o
:
4121 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
4123 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
4124 case scm_tc7_rpsubr
:
4125 RETURN (SCM_BOOL_T
);
4127 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
4129 if (!SCM_SMOB_APPLICABLE_P (proc
))
4131 RETURN (SCM_SMOB_APPLY_0 (proc
));
4134 proc
= SCM_CCLO_SUBR (proc
);
4136 debug
.info
->a
.proc
= proc
;
4137 debug
.info
->a
.args
= scm_list_1 (arg1
);
4141 proc
= SCM_PROCEDURE (proc
);
4143 debug
.info
->a
.proc
= proc
;
4145 if (!SCM_CLOSUREP (proc
))
4148 case scm_tcs_closures
:
4150 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4151 if (scm_is_pair (formals
))
4153 x
= SCM_CLOSURE_BODY (proc
);
4154 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
4155 goto nontoplevel_begin
;
4157 case scm_tcs_struct
:
4158 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4160 x
= SCM_ENTITY_PROCEDURE (proc
);
4164 else if (SCM_I_OPERATORP (proc
))
4167 proc
= (SCM_I_ENTITYP (proc
)
4168 ? SCM_ENTITY_PROCEDURE (proc
)
4169 : SCM_OPERATOR_PROCEDURE (proc
));
4171 debug
.info
->a
.proc
= proc
;
4172 debug
.info
->a
.args
= scm_list_1 (arg1
);
4178 case scm_tc7_subr_1
:
4179 case scm_tc7_subr_2
:
4180 case scm_tc7_subr_2o
:
4183 case scm_tc7_subr_3
:
4184 case scm_tc7_lsubr_2
:
4186 scm_wrong_num_args (proc
);
4189 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
4193 /* must handle macros by here */
4195 if (scm_is_pair (x
))
4196 arg1
= EVALCAR (x
, env
);
4198 scm_wrong_num_args (proc
);
4200 debug
.info
->a
.args
= scm_list_1 (arg1
);
4205 if (scm_is_null (x
))
4208 evap1
: /* inputs: proc, arg1 */
4209 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4210 switch (SCM_TYP7 (proc
))
4211 { /* have one argument in arg1 */
4212 case scm_tc7_subr_2o
:
4213 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4214 case scm_tc7_subr_1
:
4215 case scm_tc7_subr_1o
:
4216 RETURN (SCM_SUBRF (proc
) (arg1
));
4218 if (SCM_I_INUMP (arg1
))
4220 RETURN (scm_from_double (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
))));
4222 else if (SCM_REALP (arg1
))
4224 RETURN (scm_from_double (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4226 else if (SCM_BIGP (arg1
))
4228 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4230 else if (SCM_FRACTIONP (arg1
))
4232 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4234 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4236 scm_i_symbol_chars (SCM_SNAME (proc
)));
4238 RETURN (scm_i_chase_pairs (arg1
, (scm_t_bits
) SCM_SUBRF (proc
)));
4239 case scm_tc7_rpsubr
:
4240 RETURN (SCM_BOOL_T
);
4242 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4245 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4247 RETURN (SCM_SUBRF (proc
) (scm_list_1 (arg1
)));
4250 if (!SCM_SMOB_APPLICABLE_P (proc
))
4252 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
4256 proc
= SCM_CCLO_SUBR (proc
);
4258 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
4259 debug
.info
->a
.proc
= proc
;
4263 proc
= SCM_PROCEDURE (proc
);
4265 debug
.info
->a
.proc
= proc
;
4267 if (!SCM_CLOSUREP (proc
))
4270 case scm_tcs_closures
:
4273 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4274 if (scm_is_null (formals
)
4275 || (scm_is_pair (formals
) && scm_is_pair (SCM_CDR (formals
))))
4277 x
= SCM_CLOSURE_BODY (proc
);
4279 env
= SCM_EXTEND_ENV (formals
,
4283 env
= SCM_EXTEND_ENV (formals
,
4287 goto nontoplevel_begin
;
4289 case scm_tcs_struct
:
4290 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4292 x
= SCM_ENTITY_PROCEDURE (proc
);
4294 arg1
= debug
.info
->a
.args
;
4296 arg1
= scm_list_1 (arg1
);
4300 else if (SCM_I_OPERATORP (proc
))
4304 proc
= (SCM_I_ENTITYP (proc
)
4305 ? SCM_ENTITY_PROCEDURE (proc
)
4306 : SCM_OPERATOR_PROCEDURE (proc
));
4308 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
4309 debug
.info
->a
.proc
= proc
;
4315 case scm_tc7_subr_2
:
4316 case scm_tc7_subr_0
:
4317 case scm_tc7_subr_3
:
4318 case scm_tc7_lsubr_2
:
4319 scm_wrong_num_args (proc
);
4324 if (scm_is_pair (x
))
4325 arg2
= EVALCAR (x
, env
);
4327 scm_wrong_num_args (proc
);
4329 { /* have two or more arguments */
4331 debug
.info
->a
.args
= scm_list_2 (arg1
, arg2
);
4334 if (scm_is_null (x
)) {
4337 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4338 switch (SCM_TYP7 (proc
))
4339 { /* have two arguments */
4340 case scm_tc7_subr_2
:
4341 case scm_tc7_subr_2o
:
4342 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
4345 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4347 RETURN (SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
)));
4349 case scm_tc7_lsubr_2
:
4350 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
));
4351 case scm_tc7_rpsubr
:
4353 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
4355 if (!SCM_SMOB_APPLICABLE_P (proc
))
4357 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
));
4361 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
4362 scm_cons (proc
, debug
.info
->a
.args
),
4365 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
4366 scm_cons2 (proc
, arg1
,
4373 case scm_tcs_struct
:
4374 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4376 x
= SCM_ENTITY_PROCEDURE (proc
);
4378 arg1
= debug
.info
->a
.args
;
4380 arg1
= scm_list_2 (arg1
, arg2
);
4384 else if (SCM_I_OPERATORP (proc
))
4388 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
4389 ? SCM_ENTITY_PROCEDURE (proc
)
4390 : SCM_OPERATOR_PROCEDURE (proc
),
4391 scm_cons (proc
, debug
.info
->a
.args
),
4394 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
4395 ? SCM_ENTITY_PROCEDURE (proc
)
4396 : SCM_OPERATOR_PROCEDURE (proc
),
4397 scm_cons2 (proc
, arg1
,
4407 case scm_tc7_subr_0
:
4410 case scm_tc7_subr_1o
:
4411 case scm_tc7_subr_1
:
4412 case scm_tc7_subr_3
:
4413 scm_wrong_num_args (proc
);
4417 proc
= SCM_PROCEDURE (proc
);
4419 debug
.info
->a
.proc
= proc
;
4421 if (!SCM_CLOSUREP (proc
))
4424 case scm_tcs_closures
:
4427 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4428 if (scm_is_null (formals
)
4429 || (scm_is_pair (formals
)
4430 && (scm_is_null (SCM_CDR (formals
))
4431 || (scm_is_pair (SCM_CDR (formals
))
4432 && scm_is_pair (SCM_CDDR (formals
))))))
4435 env
= SCM_EXTEND_ENV (formals
,
4439 env
= SCM_EXTEND_ENV (formals
,
4440 scm_list_2 (arg1
, arg2
),
4443 x
= SCM_CLOSURE_BODY (proc
);
4444 goto nontoplevel_begin
;
4448 if (!scm_is_pair (x
))
4449 scm_wrong_num_args (proc
);
4451 debug
.info
->a
.args
= scm_cons2 (arg1
, arg2
,
4452 deval_args (x
, env
, proc
,
4453 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
4457 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4458 switch (SCM_TYP7 (proc
))
4459 { /* have 3 or more arguments */
4461 case scm_tc7_subr_3
:
4462 if (!scm_is_null (SCM_CDR (x
)))
4463 scm_wrong_num_args (proc
);
4465 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4466 SCM_CADDR (debug
.info
->a
.args
)));
4468 arg1
= SCM_SUBRF(proc
)(arg1
, arg2
);
4469 arg2
= SCM_CDDR (debug
.info
->a
.args
);
4472 arg1
= SCM_SUBRF(proc
)(arg1
, SCM_CAR (arg2
));
4473 arg2
= SCM_CDR (arg2
);
4475 while (SCM_NIMP (arg2
));
4477 case scm_tc7_rpsubr
:
4478 if (scm_is_false (SCM_SUBRF (proc
) (arg1
, arg2
)))
4479 RETURN (SCM_BOOL_F
);
4480 arg1
= SCM_CDDR (debug
.info
->a
.args
);
4483 if (scm_is_false (SCM_SUBRF (proc
) (arg2
, SCM_CAR (arg1
))))
4484 RETURN (SCM_BOOL_F
);
4485 arg2
= SCM_CAR (arg1
);
4486 arg1
= SCM_CDR (arg1
);
4488 while (SCM_NIMP (arg1
));
4489 RETURN (SCM_BOOL_T
);
4490 case scm_tc7_lsubr_2
:
4491 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4492 SCM_CDDR (debug
.info
->a
.args
)));
4494 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4496 if (!SCM_SMOB_APPLICABLE_P (proc
))
4498 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4499 SCM_CDDR (debug
.info
->a
.args
)));
4503 proc
= SCM_PROCEDURE (proc
);
4504 debug
.info
->a
.proc
= proc
;
4505 if (!SCM_CLOSUREP (proc
))
4508 case scm_tcs_closures
:
4510 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4511 if (scm_is_null (formals
)
4512 || (scm_is_pair (formals
)
4513 && (scm_is_null (SCM_CDR (formals
))
4514 || (scm_is_pair (SCM_CDR (formals
))
4515 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4517 SCM_SET_ARGSREADY (debug
);
4518 env
= SCM_EXTEND_ENV (formals
,
4521 x
= SCM_CLOSURE_BODY (proc
);
4522 goto nontoplevel_begin
;
4525 case scm_tc7_subr_3
:
4526 if (!scm_is_null (SCM_CDR (x
)))
4527 scm_wrong_num_args (proc
);
4529 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, EVALCAR (x
, env
)));
4531 arg1
= SCM_SUBRF (proc
) (arg1
, arg2
);
4534 arg1
= SCM_SUBRF(proc
)(arg1
, EVALCAR(x
, env
));
4537 while (!scm_is_null (x
));
4539 case scm_tc7_rpsubr
:
4540 if (scm_is_false (SCM_SUBRF (proc
) (arg1
, arg2
)))
4541 RETURN (SCM_BOOL_F
);
4544 arg1
= EVALCAR (x
, env
);
4545 if (scm_is_false (SCM_SUBRF (proc
) (arg2
, arg1
)))
4546 RETURN (SCM_BOOL_F
);
4550 while (!scm_is_null (x
));
4551 RETURN (SCM_BOOL_T
);
4552 case scm_tc7_lsubr_2
:
4553 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
4555 RETURN (SCM_SUBRF (proc
) (scm_cons2 (arg1
,
4557 scm_eval_args (x
, env
, proc
))));
4559 if (!SCM_SMOB_APPLICABLE_P (proc
))
4561 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4562 scm_eval_args (x
, env
, proc
)));
4566 proc
= SCM_PROCEDURE (proc
);
4567 if (!SCM_CLOSUREP (proc
))
4570 case scm_tcs_closures
:
4572 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4573 if (scm_is_null (formals
)
4574 || (scm_is_pair (formals
)
4575 && (scm_is_null (SCM_CDR (formals
))
4576 || (scm_is_pair (SCM_CDR (formals
))
4577 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4579 env
= SCM_EXTEND_ENV (formals
,
4582 scm_eval_args (x
, env
, proc
)),
4584 x
= SCM_CLOSURE_BODY (proc
);
4585 goto nontoplevel_begin
;
4588 case scm_tcs_struct
:
4589 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4592 arg1
= debug
.info
->a
.args
;
4594 arg1
= scm_cons2 (arg1
, arg2
, scm_eval_args (x
, env
, proc
));
4596 x
= SCM_ENTITY_PROCEDURE (proc
);
4599 else if (SCM_I_OPERATORP (proc
))
4603 case scm_tc7_subr_2
:
4604 case scm_tc7_subr_1o
:
4605 case scm_tc7_subr_2o
:
4606 case scm_tc7_subr_0
:
4609 case scm_tc7_subr_1
:
4610 scm_wrong_num_args (proc
);
4618 if (scm_check_exit_p
&& SCM_TRAPS_P
)
4619 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
4621 SCM_CLEAR_TRACED_FRAME (debug
);
4622 arg1
= scm_make_debugobj (&debug
);
4624 arg1
= scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
4626 if (scm_is_pair (arg1
) && scm_is_eq (SCM_CAR (arg1
), sym_instead
))
4627 proc
= SCM_CDR (arg1
);
4629 scm_i_set_last_debug_frame (debug
.prev
);
4635 /* SECTION: This code is compiled once.
4642 /* Simple procedure calls
4646 scm_call_0 (SCM proc
)
4648 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
4652 scm_call_1 (SCM proc
, SCM arg1
)
4654 return scm_apply (proc
, arg1
, scm_listofnull
);
4658 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
4660 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
4664 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
4666 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
4670 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
4672 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
4673 scm_cons (arg4
, scm_listofnull
)));
4676 /* Simple procedure applies
4680 scm_apply_0 (SCM proc
, SCM args
)
4682 return scm_apply (proc
, args
, SCM_EOL
);
4686 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
4688 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
4692 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
4694 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
4698 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
4700 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
4704 /* This code processes the arguments to apply:
4706 (apply PROC ARG1 ... ARGS)
4708 Given a list (ARG1 ... ARGS), this function conses the ARG1
4709 ... arguments onto the front of ARGS, and returns the resulting
4710 list. Note that ARGS is a list; thus, the argument to this
4711 function is a list whose last element is a list.
4713 Apply calls this function, and applies PROC to the elements of the
4714 result. apply:nconc2last takes care of building the list of
4715 arguments, given (ARG1 ... ARGS).
4717 Rather than do new consing, apply:nconc2last destroys its argument.
4718 On that topic, this code came into my care with the following
4719 beautifully cryptic comment on that topic: "This will only screw
4720 you if you do (scm_apply scm_apply '( ... ))" If you know what
4721 they're referring to, send me a patch to this comment. */
4723 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
4725 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
4726 "conses the @var{arg1} @dots{} arguments onto the front of\n"
4727 "@var{args}, and returns the resulting list. Note that\n"
4728 "@var{args} is a list; thus, the argument to this function is\n"
4729 "a list whose last element is a list.\n"
4730 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
4731 "destroys its argument, so use with care.")
4732 #define FUNC_NAME s_scm_nconc2last
4735 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
4737 while (!scm_is_null (SCM_CDR (*lloc
))) /* Perhaps should be
4738 SCM_NULL_OR_NIL_P, but not
4739 needed in 99.99% of cases,
4740 and it could seriously hurt
4741 performance. - Neil */
4742 lloc
= SCM_CDRLOC (*lloc
);
4743 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
4744 *lloc
= SCM_CAR (*lloc
);
4752 /* SECTION: When DEVAL is defined this code yields scm_dapply.
4753 * It is compiled twice.
4758 scm_apply (SCM proc
, SCM arg1
, SCM args
)
4764 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
4769 /* Apply a function to a list of arguments.
4771 This function is exported to the Scheme level as taking two
4772 required arguments and a tail argument, as if it were:
4773 (lambda (proc arg1 . args) ...)
4774 Thus, if you just have a list of arguments to pass to a procedure,
4775 pass the list as ARG1, and '() for ARGS. If you have some fixed
4776 args, pass the first as ARG1, then cons any remaining fixed args
4777 onto the front of your argument list, and pass that as ARGS. */
4780 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
4783 scm_t_debug_frame debug
;
4784 scm_t_debug_info debug_vect_body
;
4785 debug
.prev
= scm_i_last_debug_frame ();
4786 debug
.status
= SCM_APPLYFRAME
;
4787 debug
.vect
= &debug_vect_body
;
4788 debug
.vect
[0].a
.proc
= proc
;
4789 debug
.vect
[0].a
.args
= SCM_EOL
;
4790 scm_i_set_last_debug_frame (&debug
);
4792 if (scm_debug_mode_p
)
4793 return scm_dapply (proc
, arg1
, args
);
4796 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
4798 /* If ARGS is the empty list, then we're calling apply with only two
4799 arguments --- ARG1 is the list of arguments for PROC. Whatever
4800 the case, futz with things so that ARG1 is the first argument to
4801 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
4804 Setting the debug apply frame args this way is pretty messy.
4805 Perhaps we should store arg1 and args directly in the frame as
4806 received, and let scm_frame_arguments unpack them, because that's
4807 a relatively rare operation. This works for now; if the Guile
4808 developer archives are still around, see Mikael's post of
4810 if (scm_is_null (args
))
4812 if (scm_is_null (arg1
))
4814 arg1
= SCM_UNDEFINED
;
4816 debug
.vect
[0].a
.args
= SCM_EOL
;
4822 debug
.vect
[0].a
.args
= arg1
;
4824 args
= SCM_CDR (arg1
);
4825 arg1
= SCM_CAR (arg1
);
4830 args
= scm_nconc2last (args
);
4832 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4836 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
4838 SCM tmp
= scm_make_debugobj (&debug
);
4840 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
4846 switch (SCM_TYP7 (proc
))
4848 case scm_tc7_subr_2o
:
4849 args
= scm_is_null (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
4850 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4851 case scm_tc7_subr_2
:
4852 if (scm_is_null (args
) || !scm_is_null (SCM_CDR (args
)))
4853 scm_wrong_num_args (proc
);
4854 args
= SCM_CAR (args
);
4855 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4856 case scm_tc7_subr_0
:
4857 if (!SCM_UNBNDP (arg1
))
4858 scm_wrong_num_args (proc
);
4860 RETURN (SCM_SUBRF (proc
) ());
4861 case scm_tc7_subr_1
:
4862 if (SCM_UNBNDP (arg1
))
4863 scm_wrong_num_args (proc
);
4864 case scm_tc7_subr_1o
:
4865 if (!scm_is_null (args
))
4866 scm_wrong_num_args (proc
);
4868 RETURN (SCM_SUBRF (proc
) (arg1
));
4870 if (SCM_UNBNDP (arg1
) || !scm_is_null (args
))
4871 scm_wrong_num_args (proc
);
4872 if (SCM_I_INUMP (arg1
))
4874 RETURN (scm_from_double (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
))));
4876 else if (SCM_REALP (arg1
))
4878 RETURN (scm_from_double (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4880 else if (SCM_BIGP (arg1
))
4882 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4884 else if (SCM_FRACTIONP (arg1
))
4886 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4888 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4889 SCM_ARG1
, scm_i_symbol_chars (SCM_SNAME (proc
)));
4891 if (SCM_UNBNDP (arg1
) || !scm_is_null (args
))
4892 scm_wrong_num_args (proc
);
4893 RETURN (scm_i_chase_pairs (arg1
, (scm_t_bits
) SCM_SUBRF (proc
)));
4894 case scm_tc7_subr_3
:
4895 if (scm_is_null (args
)
4896 || scm_is_null (SCM_CDR (args
))
4897 || !scm_is_null (SCM_CDDR (args
)))
4898 scm_wrong_num_args (proc
);
4900 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
4903 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
4905 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
4907 case scm_tc7_lsubr_2
:
4908 if (!scm_is_pair (args
))
4909 scm_wrong_num_args (proc
);
4911 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4913 if (scm_is_null (args
))
4914 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4915 while (SCM_NIMP (args
))
4917 SCM_ASSERT (scm_is_pair (args
), args
, SCM_ARG2
, "apply");
4918 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
4919 args
= SCM_CDR (args
);
4922 case scm_tc7_rpsubr
:
4923 if (scm_is_null (args
))
4924 RETURN (SCM_BOOL_T
);
4925 while (SCM_NIMP (args
))
4927 SCM_ASSERT (scm_is_pair (args
), args
, SCM_ARG2
, "apply");
4928 if (scm_is_false (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
4929 RETURN (SCM_BOOL_F
);
4930 arg1
= SCM_CAR (args
);
4931 args
= SCM_CDR (args
);
4933 RETURN (SCM_BOOL_T
);
4934 case scm_tcs_closures
:
4936 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4938 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4940 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
4941 scm_wrong_num_args (proc
);
4943 /* Copy argument list */
4948 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
4949 for (arg1
= SCM_CDR (arg1
); scm_is_pair (arg1
); arg1
= SCM_CDR (arg1
))
4951 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
));
4954 SCM_SETCDR (tl
, arg1
);
4957 args
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4960 proc
= SCM_CLOSURE_BODY (proc
);
4962 arg1
= SCM_CDR (proc
);
4963 while (!scm_is_null (arg1
))
4965 if (SCM_IMP (SCM_CAR (proc
)))
4967 if (SCM_ISYMP (SCM_CAR (proc
)))
4969 scm_i_scm_pthread_mutex_lock (&source_mutex
);
4970 /* check for race condition */
4971 if (SCM_ISYMP (SCM_CAR (proc
)))
4972 m_expand_body (proc
, args
);
4973 scm_i_pthread_mutex_unlock (&source_mutex
);
4977 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
4980 (void) EVAL (SCM_CAR (proc
), args
);
4982 arg1
= SCM_CDR (proc
);
4984 RETURN (EVALCAR (proc
, args
));
4986 if (!SCM_SMOB_APPLICABLE_P (proc
))
4988 if (SCM_UNBNDP (arg1
))
4989 RETURN (SCM_SMOB_APPLY_0 (proc
));
4990 else if (scm_is_null (args
))
4991 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
4992 else if (scm_is_null (SCM_CDR (args
)))
4993 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
4995 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4998 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
5000 proc
= SCM_CCLO_SUBR (proc
);
5001 debug
.vect
[0].a
.proc
= proc
;
5002 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
5004 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
5006 proc
= SCM_CCLO_SUBR (proc
);
5010 proc
= SCM_PROCEDURE (proc
);
5012 debug
.vect
[0].a
.proc
= proc
;
5015 case scm_tcs_struct
:
5016 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5019 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
5021 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
5023 RETURN (scm_apply_generic (proc
, args
));
5025 else if (SCM_I_OPERATORP (proc
))
5029 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
5031 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
5034 proc
= (SCM_I_ENTITYP (proc
)
5035 ? SCM_ENTITY_PROCEDURE (proc
)
5036 : SCM_OPERATOR_PROCEDURE (proc
));
5038 debug
.vect
[0].a
.proc
= proc
;
5039 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
5041 if (SCM_NIMP (proc
))
5050 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
5054 if (scm_check_exit_p
&& SCM_TRAPS_P
)
5055 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
5057 SCM_CLEAR_TRACED_FRAME (debug
);
5058 arg1
= scm_make_debugobj (&debug
);
5060 arg1
= scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
5062 if (scm_is_pair (arg1
) && scm_is_eq (SCM_CAR (arg1
), sym_instead
))
5063 proc
= SCM_CDR (arg1
);
5065 scm_i_set_last_debug_frame (debug
.prev
);
5071 /* SECTION: The rest of this file is only read once.
5078 * Trampolines make it possible to move procedure application dispatch
5079 * outside inner loops. The motivation was clean implementation of
5080 * efficient replacements of R5RS primitives in SRFI-1.
5082 * The semantics is clear: scm_trampoline_N returns an optimized
5083 * version of scm_call_N (or NULL if the procedure isn't applicable
5086 * Applying the optimization to map and for-each increased efficiency
5087 * noticeably. For example, (map abs ls) is now 8 times faster than
5092 call_subr0_0 (SCM proc
)
5094 return SCM_SUBRF (proc
) ();
5098 call_subr1o_0 (SCM proc
)
5100 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
5104 call_lsubr_0 (SCM proc
)
5106 return SCM_SUBRF (proc
) (SCM_EOL
);
5110 scm_i_call_closure_0 (SCM proc
)
5112 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
5115 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
5120 scm_trampoline_0 (SCM proc
)
5122 scm_t_trampoline_0 trampoline
;
5127 switch (SCM_TYP7 (proc
))
5129 case scm_tc7_subr_0
:
5130 trampoline
= call_subr0_0
;
5132 case scm_tc7_subr_1o
:
5133 trampoline
= call_subr1o_0
;
5136 trampoline
= call_lsubr_0
;
5138 case scm_tcs_closures
:
5140 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5141 if (scm_is_null (formals
) || !scm_is_pair (formals
))
5142 trampoline
= scm_i_call_closure_0
;
5147 case scm_tcs_struct
:
5148 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5149 trampoline
= scm_call_generic_0
;
5150 else if (SCM_I_OPERATORP (proc
))
5151 trampoline
= scm_call_0
;
5156 if (SCM_SMOB_APPLICABLE_P (proc
))
5157 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
5162 case scm_tc7_rpsubr
:
5165 trampoline
= scm_call_0
;
5168 return NULL
; /* not applicable on zero arguments */
5170 /* We only reach this point if a valid trampoline was determined. */
5172 /* If debugging is enabled, we want to see all calls to proc on the stack.
5173 * Thus, we replace the trampoline shortcut with scm_call_0. */
5174 if (scm_debug_mode_p
)
5181 call_subr1_1 (SCM proc
, SCM arg1
)
5183 return SCM_SUBRF (proc
) (arg1
);
5187 call_subr2o_1 (SCM proc
, SCM arg1
)
5189 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
5193 call_lsubr_1 (SCM proc
, SCM arg1
)
5195 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
5199 call_dsubr_1 (SCM proc
, SCM arg1
)
5201 if (SCM_I_INUMP (arg1
))
5203 RETURN (scm_from_double (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
))));
5205 else if (SCM_REALP (arg1
))
5207 RETURN (scm_from_double (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
5209 else if (SCM_BIGP (arg1
))
5211 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
5213 else if (SCM_FRACTIONP (arg1
))
5215 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
5217 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
5218 SCM_ARG1
, scm_i_symbol_chars (SCM_SNAME (proc
)));
5222 call_cxr_1 (SCM proc
, SCM arg1
)
5224 return scm_i_chase_pairs (arg1
, (scm_t_bits
) SCM_SUBRF (proc
));
5228 call_closure_1 (SCM proc
, SCM arg1
)
5230 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
5233 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
5238 scm_trampoline_1 (SCM proc
)
5240 scm_t_trampoline_1 trampoline
;
5245 switch (SCM_TYP7 (proc
))
5247 case scm_tc7_subr_1
:
5248 case scm_tc7_subr_1o
:
5249 trampoline
= call_subr1_1
;
5251 case scm_tc7_subr_2o
:
5252 trampoline
= call_subr2o_1
;
5255 trampoline
= call_lsubr_1
;
5258 trampoline
= call_dsubr_1
;
5261 trampoline
= call_cxr_1
;
5263 case scm_tcs_closures
:
5265 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5266 if (!scm_is_null (formals
)
5267 && (!scm_is_pair (formals
) || !scm_is_pair (SCM_CDR (formals
))))
5268 trampoline
= call_closure_1
;
5273 case scm_tcs_struct
:
5274 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5275 trampoline
= scm_call_generic_1
;
5276 else if (SCM_I_OPERATORP (proc
))
5277 trampoline
= scm_call_1
;
5282 if (SCM_SMOB_APPLICABLE_P (proc
))
5283 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
5288 case scm_tc7_rpsubr
:
5291 trampoline
= scm_call_1
;
5294 return NULL
; /* not applicable on one arg */
5296 /* We only reach this point if a valid trampoline was determined. */
5298 /* If debugging is enabled, we want to see all calls to proc on the stack.
5299 * Thus, we replace the trampoline shortcut with scm_call_1. */
5300 if (scm_debug_mode_p
)
5307 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
5309 return SCM_SUBRF (proc
) (arg1
, arg2
);
5313 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
5315 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
5319 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
5321 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
5325 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
5327 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
5328 scm_list_2 (arg1
, arg2
),
5330 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
5335 scm_trampoline_2 (SCM proc
)
5337 scm_t_trampoline_2 trampoline
;
5342 switch (SCM_TYP7 (proc
))
5344 case scm_tc7_subr_2
:
5345 case scm_tc7_subr_2o
:
5346 case scm_tc7_rpsubr
:
5348 trampoline
= call_subr2_2
;
5350 case scm_tc7_lsubr_2
:
5351 trampoline
= call_lsubr2_2
;
5354 trampoline
= call_lsubr_2
;
5356 case scm_tcs_closures
:
5358 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5359 if (!scm_is_null (formals
)
5360 && (!scm_is_pair (formals
)
5361 || (!scm_is_null (SCM_CDR (formals
))
5362 && (!scm_is_pair (SCM_CDR (formals
))
5363 || !scm_is_pair (SCM_CDDR (formals
))))))
5364 trampoline
= call_closure_2
;
5369 case scm_tcs_struct
:
5370 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5371 trampoline
= scm_call_generic_2
;
5372 else if (SCM_I_OPERATORP (proc
))
5373 trampoline
= scm_call_2
;
5378 if (SCM_SMOB_APPLICABLE_P (proc
))
5379 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
5385 trampoline
= scm_call_2
;
5388 return NULL
; /* not applicable on two args */
5390 /* We only reach this point if a valid trampoline was determined. */
5392 /* If debugging is enabled, we want to see all calls to proc on the stack.
5393 * Thus, we replace the trampoline shortcut with scm_call_2. */
5394 if (scm_debug_mode_p
)
5400 /* Typechecking for multi-argument MAP and FOR-EACH.
5402 Verify that each element of the vector ARGV, except for the first,
5403 is a proper list whose length is LEN. Attribute errors to WHO,
5404 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
5406 check_map_args (SCM argv
,
5415 for (i
= SCM_SIMPLE_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
5417 SCM elt
= SCM_SIMPLE_VECTOR_REF (argv
, i
);
5418 long elt_len
= scm_ilength (elt
);
5423 scm_apply_generic (gf
, scm_cons (proc
, args
));
5425 scm_wrong_type_arg (who
, i
+ 2, elt
);
5429 scm_out_of_range_pos (who
, elt
, scm_from_long (i
+ 2));
5434 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
5436 /* Note: Currently, scm_map applies PROC to the argument list(s)
5437 sequentially, starting with the first element(s). This is used in
5438 evalext.c where the Scheme procedure `map-in-order', which guarantees
5439 sequential behaviour, is implemented using scm_map. If the
5440 behaviour changes, we need to update `map-in-order'.
5444 scm_map (SCM proc
, SCM arg1
, SCM args
)
5445 #define FUNC_NAME s_map
5451 len
= scm_ilength (arg1
);
5452 SCM_GASSERTn (len
>= 0,
5453 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
5454 SCM_VALIDATE_REST_ARGUMENT (args
);
5455 if (scm_is_null (args
))
5457 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5458 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
5459 while (SCM_NIMP (arg1
))
5461 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
5462 pres
= SCM_CDRLOC (*pres
);
5463 arg1
= SCM_CDR (arg1
);
5467 if (scm_is_null (SCM_CDR (args
)))
5469 SCM arg2
= SCM_CAR (args
);
5470 int len2
= scm_ilength (arg2
);
5471 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5473 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
5474 SCM_GASSERTn (len2
>= 0,
5475 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
5477 SCM_OUT_OF_RANGE (3, arg2
);
5478 while (SCM_NIMP (arg1
))
5480 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
5481 pres
= SCM_CDRLOC (*pres
);
5482 arg1
= SCM_CDR (arg1
);
5483 arg2
= SCM_CDR (arg2
);
5487 arg1
= scm_cons (arg1
, args
);
5488 args
= scm_vector (arg1
);
5489 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
5493 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5495 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
5498 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
5499 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
5501 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
5502 pres
= SCM_CDRLOC (*pres
);
5508 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
5511 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
5512 #define FUNC_NAME s_for_each
5515 len
= scm_ilength (arg1
);
5516 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
5517 SCM_ARG2
, s_for_each
);
5518 SCM_VALIDATE_REST_ARGUMENT (args
);
5519 if (scm_is_null (args
))
5521 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5522 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
5523 while (SCM_NIMP (arg1
))
5525 call (proc
, SCM_CAR (arg1
));
5526 arg1
= SCM_CDR (arg1
);
5528 return SCM_UNSPECIFIED
;
5530 if (scm_is_null (SCM_CDR (args
)))
5532 SCM arg2
= SCM_CAR (args
);
5533 int len2
= scm_ilength (arg2
);
5534 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5535 SCM_GASSERTn (call
, g_for_each
,
5536 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
5537 SCM_GASSERTn (len2
>= 0, g_for_each
,
5538 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
5540 SCM_OUT_OF_RANGE (3, arg2
);
5541 while (SCM_NIMP (arg1
))
5543 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
5544 arg1
= SCM_CDR (arg1
);
5545 arg2
= SCM_CDR (arg2
);
5547 return SCM_UNSPECIFIED
;
5549 arg1
= scm_cons (arg1
, args
);
5550 args
= scm_vector (arg1
);
5551 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
5555 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5557 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
5559 return SCM_UNSPECIFIED
;
5560 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
5561 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
5563 scm_apply (proc
, arg1
, SCM_EOL
);
5570 scm_closure (SCM code
, SCM env
)
5573 SCM closcar
= scm_cons (code
, SCM_EOL
);
5574 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
5575 scm_remember_upto_here (closcar
);
5580 scm_t_bits scm_tc16_promise
;
5583 scm_makprom (SCM code
)
5585 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
5587 scm_make_recursive_mutex ());
5591 promise_mark (SCM promise
)
5593 scm_gc_mark (SCM_PROMISE_MUTEX (promise
));
5594 return SCM_PROMISE_DATA (promise
);
5598 promise_free (SCM promise
)
5604 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
5606 int writingp
= SCM_WRITINGP (pstate
);
5607 scm_puts ("#<promise ", port
);
5608 SCM_SET_WRITINGP (pstate
, 1);
5609 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
5610 SCM_SET_WRITINGP (pstate
, writingp
);
5611 scm_putc ('>', port
);
5615 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
5617 "If the promise @var{x} has not been computed yet, compute and\n"
5618 "return @var{x}, otherwise just return the previously computed\n"
5620 #define FUNC_NAME s_scm_force
5622 SCM_VALIDATE_SMOB (1, promise
, promise
);
5623 scm_lock_mutex (SCM_PROMISE_MUTEX (promise
));
5624 if (!SCM_PROMISE_COMPUTED_P (promise
))
5626 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
5627 if (!SCM_PROMISE_COMPUTED_P (promise
))
5629 SCM_SET_PROMISE_DATA (promise
, ans
);
5630 SCM_SET_PROMISE_COMPUTED (promise
);
5633 scm_unlock_mutex (SCM_PROMISE_MUTEX (promise
));
5634 return SCM_PROMISE_DATA (promise
);
5639 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
5641 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
5642 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
5643 #define FUNC_NAME s_scm_promise_p
5645 return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
5650 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
5651 (SCM xorig
, SCM x
, SCM y
),
5652 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
5653 "Any source properties associated with @var{xorig} are also associated\n"
5654 "with the new pair.")
5655 #define FUNC_NAME s_scm_cons_source
5658 z
= scm_cons (x
, y
);
5659 /* Copy source properties possibly associated with xorig. */
5660 p
= scm_whash_lookup (scm_source_whash
, xorig
);
5661 if (scm_is_true (p
))
5662 scm_whash_insert (scm_source_whash
, z
, p
);
5668 /* The function scm_copy_tree is used to copy an expression tree to allow the
5669 * memoizer to modify the expression during memoization. scm_copy_tree
5670 * creates deep copies of pairs and vectors, but not of any other data types,
5671 * since only pairs and vectors will be parsed by the memoizer.
5673 * To avoid infinite recursion due to cyclic structures, the hare-and-tortoise
5674 * pattern is used to detect cycles. In fact, the pattern is used in two
5675 * dimensions, vertical (indicated in the code by the variable names 'hare'
5676 * and 'tortoise') and horizontal ('rabbit' and 'turtle'). In both
5677 * dimensions, the hare/rabbit will take two steps when the tortoise/turtle
5680 * The vertical dimension corresponds to recursive calls to function
5681 * copy_tree: This happens when descending into vector elements, into cars of
5682 * lists and into the cdr of an improper list. In this dimension, the
5683 * tortoise follows the hare by using the processor stack: Every stack frame
5684 * will hold an instance of struct t_trace. These instances are connected in
5685 * a way that represents the trace of the hare, which thus can be followed by
5686 * the tortoise. The tortoise will always point to struct t_trace instances
5687 * relating to SCM objects that have already been copied. Thus, a cycle is
5688 * detected if the tortoise and the hare point to the same object,
5690 * The horizontal dimension is within one execution of copy_tree, when the
5691 * function cdr's along the pairs of a list. This is the standard
5692 * hare-and-tortoise implementation, found several times in guile. */
5695 struct t_trace
*trace
; // These pointers form a trace along the stack.
5696 SCM obj
; // The object handled at the respective stack frame.
5701 struct t_trace
*const hare
,
5702 struct t_trace
*tortoise
,
5703 unsigned int tortoise_delay
)
5705 if (!scm_is_pair (hare
->obj
) && !scm_is_simple_vector (hare
->obj
))
5711 /* Prepare the trace along the stack. */
5712 struct t_trace new_hare
;
5713 hare
->trace
= &new_hare
;
5715 /* The tortoise will make its step after the delay has elapsed. Note
5716 * that in contrast to the typical hare-and-tortoise pattern, the step
5717 * of the tortoise happens before the hare takes its steps. This is, in
5718 * principle, no problem, except for the start of the algorithm: Then,
5719 * it has to be made sure that the hare actually gets its advantage of
5721 if (tortoise_delay
== 0)
5724 tortoise
= tortoise
->trace
;
5725 ASSERT_SYNTAX (!scm_is_eq (hare
->obj
, tortoise
->obj
),
5726 s_bad_expression
, hare
->obj
);
5733 if (scm_is_simple_vector (hare
->obj
))
5735 size_t length
= SCM_SIMPLE_VECTOR_LENGTH (hare
->obj
);
5736 SCM new_vector
= scm_c_make_vector (length
, SCM_UNSPECIFIED
);
5738 /* Each vector element is copied by recursing into copy_tree, having
5739 * the tortoise follow the hare into the depths of the stack. */
5740 unsigned long int i
;
5741 for (i
= 0; i
< length
; ++i
)
5744 new_hare
.obj
= SCM_SIMPLE_VECTOR_REF (hare
->obj
, i
);
5745 new_element
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5746 SCM_SIMPLE_VECTOR_SET (new_vector
, i
, new_element
);
5751 else // scm_is_pair (hare->obj)
5756 SCM rabbit
= hare
->obj
;
5757 SCM turtle
= hare
->obj
;
5761 /* The first pair of the list is treated specially, in order to
5762 * preserve a potential source code position. */
5763 result
= tail
= scm_cons_source (rabbit
, SCM_EOL
, SCM_EOL
);
5764 new_hare
.obj
= SCM_CAR (rabbit
);
5765 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5766 SCM_SETCAR (tail
, copy
);
5768 /* The remaining pairs of the list are copied by, horizontally,
5769 * having the turtle follow the rabbit, and, vertically, having the
5770 * tortoise follow the hare into the depths of the stack. */
5771 rabbit
= SCM_CDR (rabbit
);
5772 while (scm_is_pair (rabbit
))
5774 new_hare
.obj
= SCM_CAR (rabbit
);
5775 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5776 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
5777 tail
= SCM_CDR (tail
);
5779 rabbit
= SCM_CDR (rabbit
);
5780 if (scm_is_pair (rabbit
))
5782 new_hare
.obj
= SCM_CAR (rabbit
);
5783 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5784 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
5785 tail
= SCM_CDR (tail
);
5786 rabbit
= SCM_CDR (rabbit
);
5788 turtle
= SCM_CDR (turtle
);
5789 ASSERT_SYNTAX (!scm_is_eq (rabbit
, turtle
),
5790 s_bad_expression
, rabbit
);
5794 /* We have to recurse into copy_tree again for the last cdr, in
5795 * order to handle the situation that it holds a vector. */
5796 new_hare
.obj
= rabbit
;
5797 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5798 SCM_SETCDR (tail
, copy
);
5805 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
5807 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
5808 "the new data structure. @code{copy-tree} recurses down the\n"
5809 "contents of both pairs and vectors (since both cons cells and vector\n"
5810 "cells may point to arbitrary objects), and stops recursing when it hits\n"
5811 "any other object.")
5812 #define FUNC_NAME s_scm_copy_tree
5814 /* Prepare the trace along the stack. */
5815 struct t_trace trace
;
5818 /* In function copy_tree, if the tortoise makes its step, it will do this
5819 * before the hare has the chance to move. Thus, we have to make sure that
5820 * the very first step of the tortoise will not happen after the hare has
5821 * really made two steps. This is achieved by passing '2' as the initial
5822 * delay for the tortoise. NOTE: Since cycles are unlikely, giving the hare
5823 * a bigger advantage may improve performance slightly. */
5824 return copy_tree (&trace
, &trace
, 2);
5829 /* We have three levels of EVAL here:
5831 - scm_i_eval (exp, env)
5833 evaluates EXP in environment ENV. ENV is a lexical environment
5834 structure as used by the actual tree code evaluator. When ENV is
5835 a top-level environment, then changes to the current module are
5836 tracked by updating ENV so that it continues to be in sync with
5839 - scm_primitive_eval (exp)
5841 evaluates EXP in the top-level environment as determined by the
5842 current module. This is done by constructing a suitable
5843 environment and calling scm_i_eval. Thus, changes to the
5844 top-level module are tracked normally.
5846 - scm_eval (exp, mod_or_state)
5848 evaluates EXP while MOD_OR_STATE is the current module or current
5849 dynamic state (as appropriate). This is done by setting the
5850 current module (or dynamic state) to MOD_OR_STATE, invoking
5851 scm_primitive_eval on EXP, and then restoring the current module
5852 (or dynamic state) to the value it had previously. That is,
5853 while EXP is evaluated, changes to the current module (or dynamic
5854 state) are tracked, but these changes do not persist when
5857 For each level of evals, there are two variants, distinguished by a
5858 _x suffix: the ordinary variant does not modify EXP while the _x
5859 variant can destructively modify EXP into something completely
5860 unintelligible. A Scheme data structure passed as EXP to one of the
5861 _x variants should not ever be used again for anything. So when in
5862 doubt, use the ordinary variant.
5867 scm_i_eval_x (SCM exp
, SCM env
)
5869 if (scm_is_symbol (exp
))
5870 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
5872 return SCM_I_XEVAL (exp
, env
);
5876 scm_i_eval (SCM exp
, SCM env
)
5878 exp
= scm_copy_tree (exp
);
5879 if (scm_is_symbol (exp
))
5880 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
5882 return SCM_I_XEVAL (exp
, env
);
5886 scm_primitive_eval_x (SCM exp
)
5889 SCM transformer
= scm_current_module_transformer ();
5890 if (SCM_NIMP (transformer
))
5891 exp
= scm_call_1 (transformer
, exp
);
5892 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5893 return scm_i_eval_x (exp
, env
);
5896 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
5898 "Evaluate @var{exp} in the top-level environment specified by\n"
5899 "the current module.")
5900 #define FUNC_NAME s_scm_primitive_eval
5903 SCM transformer
= scm_current_module_transformer ();
5904 if (scm_is_true (transformer
))
5905 exp
= scm_call_1 (transformer
, exp
);
5906 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5907 return scm_i_eval (exp
, env
);
5912 /* Eval does not take the second arg optionally. This is intentional
5913 * in order to be R5RS compatible, and to prepare for the new module
5914 * system, where we would like to make the choice of evaluation
5915 * environment explicit. */
5918 scm_eval_x (SCM exp
, SCM module_or_state
)
5922 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
5923 if (scm_is_dynamic_state (module_or_state
))
5924 scm_dynwind_current_dynamic_state (module_or_state
);
5926 scm_dynwind_current_module (module_or_state
);
5928 res
= scm_primitive_eval_x (exp
);
5934 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
5935 (SCM exp
, SCM module_or_state
),
5936 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
5937 "in the top-level environment specified by\n"
5938 "@var{module_or_state}.\n"
5939 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
5940 "@var{module_or_state} is made the current module when\n"
5941 "it is a module, or the current dynamic state when it is\n"
5943 "Example: (eval '(+ 1 2) (interaction-environment))")
5944 #define FUNC_NAME s_scm_eval
5948 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
5949 if (scm_is_dynamic_state (module_or_state
))
5950 scm_dynwind_current_dynamic_state (module_or_state
);
5952 scm_dynwind_current_module (module_or_state
);
5954 res
= scm_primitive_eval (exp
);
5962 /* At this point, deval and scm_dapply are generated.
5969 #if (SCM_ENABLE_DEPRECATED == 1)
5971 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5972 SCM
scm_ceval (SCM x
, SCM env
)
5974 if (scm_is_pair (x
))
5975 return ceval (x
, env
);
5976 else if (scm_is_symbol (x
))
5977 return *scm_lookupcar (scm_cons (x
, SCM_UNDEFINED
), env
, 1);
5979 return SCM_I_XEVAL (x
, env
);
5982 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5983 SCM
scm_deval (SCM x
, SCM env
)
5985 if (scm_is_pair (x
))
5986 return deval (x
, env
);
5987 else if (scm_is_symbol (x
))
5988 return *scm_lookupcar (scm_cons (x
, SCM_UNDEFINED
), env
, 1);
5990 return SCM_I_XEVAL (x
, env
);
5994 dispatching_eval (SCM x
, SCM env
)
5996 if (scm_debug_mode_p
)
5997 return scm_deval (x
, env
);
5999 return scm_ceval (x
, env
);
6002 /* Deprecated in guile 1.7.0 on 2004-03-29. */
6003 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
) = dispatching_eval
;
6011 scm_i_pthread_mutex_init (&source_mutex
,
6012 scm_i_pthread_mutexattr_recursive
);
6014 scm_init_opts (scm_evaluator_traps
,
6015 scm_evaluator_trap_table
,
6016 SCM_N_EVALUATOR_TRAPS
);
6017 scm_init_opts (scm_eval_options_interface
,
6019 SCM_N_EVAL_OPTIONS
);
6021 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
6022 scm_set_smob_mark (scm_tc16_promise
, promise_mark
);
6023 scm_set_smob_free (scm_tc16_promise
, promise_free
);
6024 scm_set_smob_print (scm_tc16_promise
, promise_print
);
6026 undefineds
= scm_list_1 (SCM_UNDEFINED
);
6027 SCM_SETCDR (undefineds
, undefineds
);
6028 scm_permanent_object (undefineds
);
6030 scm_listofnull
= scm_list_1 (SCM_EOL
);
6032 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
6033 scm_permanent_object (f_apply
);
6035 #include "libguile/eval.x"
6037 scm_add_feature ("delay");