1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004
2 * Free Software Foundation, Inc.
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public
6 * License as published by the Free Software Foundation; either
7 * version 2.1 of the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
21 /* This file is read twice in order to produce debugging versions of ceval and
22 * scm_apply. These functions, deval and scm_dapply, are produced when we
23 * define the preprocessor macro DEVAL. The file is divided into sections
24 * which are treated differently with respect to DEVAL. The heads of these
25 * sections are marked with the string "SECTION:". */
27 /* SECTION: This code is compiled once.
34 #include "libguile/__scm.h"
38 /* AIX requires this to be the first thing in the file. The #pragma
39 directive is indented so pre-ANSI compilers will ignore it, rather
48 # ifndef alloca /* predefined by HP cc +Olibcalls */
56 #include "libguile/_scm.h"
57 #include "libguile/alist.h"
58 #include "libguile/async.h"
59 #include "libguile/continuations.h"
60 #include "libguile/debug.h"
61 #include "libguile/deprecation.h"
62 #include "libguile/dynwind.h"
63 #include "libguile/eq.h"
64 #include "libguile/feature.h"
65 #include "libguile/fluids.h"
66 #include "libguile/futures.h"
67 #include "libguile/goops.h"
68 #include "libguile/hash.h"
69 #include "libguile/hashtab.h"
70 #include "libguile/lang.h"
71 #include "libguile/list.h"
72 #include "libguile/macros.h"
73 #include "libguile/modules.h"
74 #include "libguile/objects.h"
75 #include "libguile/ports.h"
76 #include "libguile/print.h"
77 #include "libguile/procprop.h"
78 #include "libguile/root.h"
79 #include "libguile/smob.h"
80 #include "libguile/srcprop.h"
81 #include "libguile/stackchk.h"
82 #include "libguile/strings.h"
83 #include "libguile/throw.h"
84 #include "libguile/validate.h"
85 #include "libguile/values.h"
86 #include "libguile/vectors.h"
88 #include "libguile/eval.h"
92 static SCM
canonicalize_define (SCM expr
);
93 static SCM
*scm_lookupcar1 (SCM vloc
, SCM genv
, int check
);
95 /* prototype in eval.h is not given under --disable-deprecated */
96 SCM_API SCM
scm_macroexp (SCM x
, SCM env
);
102 * This section defines the message strings for the syntax errors that can be
103 * detected during memoization and the functions and macros that shall be
104 * called by the memoizer code to signal syntax errors. */
107 /* Syntax errors that can be detected during memoization: */
109 /* Circular or improper lists do not form valid scheme expressions. If a
110 * circular list or an improper list is detected in a place where a scheme
111 * expression is expected, a 'Bad expression' error is signalled. */
112 static const char s_bad_expression
[] = "Bad expression";
114 /* If a form is detected that holds a different number of expressions than are
115 * required in that context, a 'Missing or extra expression' error is
117 static const char s_expression
[] = "Missing or extra expression in";
119 /* If a form is detected that holds less expressions than are required in that
120 * context, a 'Missing expression' error is signalled. */
121 static const char s_missing_expression
[] = "Missing expression in";
123 /* If a form is detected that holds more expressions than are allowed in that
124 * context, an 'Extra expression' error is signalled. */
125 static const char s_extra_expression
[] = "Extra expression in";
127 /* The empty combination '()' is not allowed as an expression in scheme. If
128 * it is detected in a place where an expression is expected, an 'Illegal
129 * empty combination' error is signalled. Note: If you encounter this error
130 * message, it is very likely that you intended to denote the empty list. To
131 * do so, you need to quote the empty list like (quote ()) or '(). */
132 static const char s_empty_combination
[] = "Illegal empty combination";
134 /* A body may hold an arbitrary number of internal defines, followed by a
135 * non-empty sequence of expressions. If a body with an empty sequence of
136 * expressions is detected, a 'Missing body expression' error is signalled.
138 static const char s_missing_body_expression
[] = "Missing body expression in";
140 /* A body may hold an arbitrary number of internal defines, followed by a
141 * non-empty sequence of expressions. Each the definitions and the
142 * expressions may be grouped arbitraryly with begin, but it is not allowed to
143 * mix definitions and expressions. If a define form in a body mixes
144 * definitions and expressions, a 'Mixed definitions and expressions' error is
146 static const char s_mixed_body_forms
[] = "Mixed definitions and expressions in";
147 /* Definitions are only allowed on the top level and at the start of a body.
148 * If a definition is detected anywhere else, a 'Bad define placement' error
150 static const char s_bad_define
[] = "Bad define placement";
152 /* Case or cond expressions must have at least one clause. If a case or cond
153 * expression without any clauses is detected, a 'Missing clauses' error is
155 static const char s_missing_clauses
[] = "Missing clauses";
157 /* If there is an 'else' clause in a case or a cond statement, it must be the
158 * last clause. If after the 'else' case clause further clauses are detected,
159 * a 'Misplaced else clause' error is signalled. */
160 static const char s_misplaced_else_clause
[] = "Misplaced else clause";
162 /* If a case clause is detected that is not in the format
163 * (<label(s)> <expression1> <expression2> ...)
164 * a 'Bad case clause' error is signalled. */
165 static const char s_bad_case_clause
[] = "Bad case clause";
167 /* If a case clause is detected where the <label(s)> element is neither a
168 * proper list nor (in case of the last clause) the syntactic keyword 'else',
169 * a 'Bad case labels' error is signalled. Note: If you encounter this error
170 * for an else-clause which seems to be syntactically correct, check if 'else'
171 * is really a syntactic keyword in that context. If 'else' is bound in the
172 * local or global environment, it is not considered a syntactic keyword, but
173 * will be treated as any other variable. */
174 static const char s_bad_case_labels
[] = "Bad case labels";
176 /* In a case statement all labels have to be distinct. If in a case statement
177 * a label occurs more than once, a 'Duplicate case label' error is
179 static const char s_duplicate_case_label
[] = "Duplicate case label";
181 /* If a cond clause is detected that is not in one of the formats
182 * (<test> <expression1> ...) or (else <expression1> <expression2> ...)
183 * a 'Bad cond clause' error is signalled. */
184 static const char s_bad_cond_clause
[] = "Bad cond clause";
186 /* If a cond clause is detected that uses the alternate '=>' form, but does
187 * not hold a recipient element for the test result, a 'Missing recipient'
188 * error is signalled. */
189 static const char s_missing_recipient
[] = "Missing recipient in";
191 /* If in a position where a variable name is required some other object is
192 * detected, a 'Bad variable' error is signalled. */
193 static const char s_bad_variable
[] = "Bad variable";
195 /* Bindings for forms like 'let' and 'do' have to be given in a proper,
196 * possibly empty list. If any other object is detected in a place where a
197 * list of bindings was required, a 'Bad bindings' error is signalled. */
198 static const char s_bad_bindings
[] = "Bad bindings";
200 /* Depending on the syntactic context, a binding has to be in the format
201 * (<variable> <expression>) or (<variable> <expression1> <expression2>).
202 * If anything else is detected in a place where a binding was expected, a
203 * 'Bad binding' error is signalled. */
204 static const char s_bad_binding
[] = "Bad binding";
206 /* Some syntactic forms don't allow variable names to appear more than once in
207 * a list of bindings. If such a situation is nevertheless detected, a
208 * 'Duplicate binding' error is signalled. */
209 static const char s_duplicate_binding
[] = "Duplicate binding";
211 /* If the exit form of a 'do' expression is not in the format
212 * (<test> <expression> ...)
213 * a 'Bad exit clause' error is signalled. */
214 static const char s_bad_exit_clause
[] = "Bad exit clause";
216 /* The formal function arguments of a lambda expression have to be either a
217 * single symbol or a non-cyclic list. For anything else a 'Bad formals'
218 * error is signalled. */
219 static const char s_bad_formals
[] = "Bad formals";
221 /* If in a lambda expression something else than a symbol is detected at a
222 * place where a formal function argument is required, a 'Bad formal' error is
224 static const char s_bad_formal
[] = "Bad formal";
226 /* If in the arguments list of a lambda expression an argument name occurs
227 * more than once, a 'Duplicate formal' error is signalled. */
228 static const char s_duplicate_formal
[] = "Duplicate formal";
230 /* If the evaluation of an unquote-splicing expression gives something else
231 * than a proper list, a 'Non-list result for unquote-splicing' error is
233 static const char s_splicing
[] = "Non-list result for unquote-splicing";
235 /* If something else than an exact integer is detected as the argument for
236 * @slot-ref and @slot-set!, a 'Bad slot number' error is signalled. */
237 static const char s_bad_slot_number
[] = "Bad slot number";
240 /* Signal a syntax error. We distinguish between the form that caused the
241 * error and the enclosing expression. The error message will print out as
242 * shown in the following pattern. The file name and line number are only
243 * given when they can be determined from the erroneous form or from the
244 * enclosing expression.
246 * <filename>: In procedure memoization:
247 * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
249 SCM_SYMBOL (syntax_error_key
, "syntax-error");
251 /* The prototype is needed to indicate that the function does not return. */
253 syntax_error (const char* const, const SCM
, const SCM
) SCM_NORETURN
;
256 syntax_error (const char* const msg
, const SCM form
, const SCM expr
)
258 const SCM msg_string
= scm_makfrom0str (msg
);
259 SCM filename
= SCM_BOOL_F
;
260 SCM linenr
= SCM_BOOL_F
;
264 if (SCM_CONSP (form
))
266 filename
= scm_source_property (form
, scm_sym_filename
);
267 linenr
= scm_source_property (form
, scm_sym_line
);
270 if (SCM_FALSEP (filename
) && SCM_FALSEP (linenr
) && SCM_CONSP (expr
))
272 filename
= scm_source_property (expr
, scm_sym_filename
);
273 linenr
= scm_source_property (expr
, scm_sym_line
);
276 if (!SCM_UNBNDP (expr
))
278 if (!SCM_FALSEP (filename
))
280 format
= "In file ~S, line ~S: ~A ~S in expression ~S.";
281 args
= scm_list_5 (filename
, linenr
, msg_string
, form
, expr
);
283 else if (!SCM_FALSEP (linenr
))
285 format
= "In line ~S: ~A ~S in expression ~S.";
286 args
= scm_list_4 (linenr
, msg_string
, form
, expr
);
290 format
= "~A ~S in expression ~S.";
291 args
= scm_list_3 (msg_string
, form
, expr
);
296 if (!SCM_FALSEP (filename
))
298 format
= "In file ~S, line ~S: ~A ~S.";
299 args
= scm_list_4 (filename
, linenr
, msg_string
, form
);
301 else if (!SCM_FALSEP (linenr
))
303 format
= "In line ~S: ~A ~S.";
304 args
= scm_list_3 (linenr
, msg_string
, form
);
309 args
= scm_list_2 (msg_string
, form
);
313 scm_error (syntax_error_key
, "memoization", format
, args
, SCM_BOOL_F
);
317 /* Shortcut macros to simplify syntax error handling. */
318 #define ASSERT_SYNTAX(cond, message, form) \
319 { if (!(cond)) syntax_error (message, form, SCM_UNDEFINED); }
320 #define ASSERT_SYNTAX_2(cond, message, form, expr) \
321 { if (!(cond)) syntax_error (message, form, expr); }
327 * Ilocs are memoized references to variables in local environment frames.
328 * They are represented as three values: The relative offset of the
329 * environment frame, the number of the binding within that frame, and a
330 * boolean value indicating whether the binding is the last binding in the
334 #define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc)
335 #define SCM_IFRINC (0x00000100L)
336 #define SCM_ICDR (0x00080000L)
337 #define SCM_IDINC (0x00100000L)
338 #define SCM_IFRAME(n) ((long)((SCM_ICDR-SCM_IFRINC)>>8) \
339 & (SCM_UNPACK (n) >> 8))
340 #define SCM_IDIST(n) (SCM_UNPACK (n) >> 20)
341 #define SCM_ICDRP(n) (SCM_ICDR & SCM_UNPACK (n))
342 #define SCM_IDSTMSK (-SCM_IDINC)
343 #define SCM_MAKE_ILOC(frame_nr, binding_nr, last_p) \
346 + ((binding_nr) << 20) \
347 + ((last_p) ? SCM_ICDR : 0) \
351 scm_i_print_iloc (SCM iloc
, SCM port
)
353 scm_puts ("#@", port
);
354 scm_intprint ((long) SCM_IFRAME (iloc
), 10, port
);
355 scm_putc (SCM_ICDRP (iloc
) ? '-' : '+', port
);
356 scm_intprint ((long) SCM_IDIST (iloc
), 10, port
);
359 #if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
361 SCM
scm_dbg_make_iloc (SCM frame
, SCM binding
, SCM cdrp
);
362 SCM_DEFINE (scm_dbg_make_iloc
, "dbg-make-iloc", 3, 0, 0,
363 (SCM frame
, SCM binding
, SCM cdrp
),
364 "Return a new iloc with frame offset @var{frame}, binding\n"
365 "offset @var{binding} and the cdr flag @var{cdrp}.")
366 #define FUNC_NAME s_scm_dbg_make_iloc
368 SCM_VALIDATE_INUM (1, frame
);
369 SCM_VALIDATE_INUM (2, binding
);
370 return SCM_MAKE_ILOC (SCM_INUM (frame
),
376 SCM
scm_dbg_iloc_p (SCM obj
);
377 SCM_DEFINE (scm_dbg_iloc_p
, "dbg-iloc?", 1, 0, 0,
379 "Return @code{#t} if @var{obj} is an iloc.")
380 #define FUNC_NAME s_scm_dbg_iloc_p
382 return SCM_BOOL (SCM_ILOCP (obj
));
390 /* {Evaluator byte codes (isyms)}
393 #define ISYMNUM(n) (SCM_ITAG8_DATA (n))
395 /* This table must agree with the list of SCM_IM_ constants in tags.h */
396 static const char *const isymnames
[] =
413 "#@call-with-current-continuation",
419 "#@call-with-values",
427 scm_i_print_isym (SCM isym
, SCM port
)
429 const size_t isymnum
= ISYMNUM (isym
);
430 if (isymnum
< (sizeof isymnames
/ sizeof (char *)))
431 scm_puts (isymnames
[isymnum
], port
);
433 scm_ipruk ("isym", isym
, port
);
438 /* The function lookup_symbol is used during memoization: Lookup the symbol in
439 * the environment. If there is no binding for the symbol, SCM_UNDEFINED is
440 * returned. If the symbol is a global variable, the variable object to which
441 * the symbol is bound is returned. Finally, if the symbol is a local
442 * variable the corresponding iloc object is returned. */
444 /* A helper function for lookup_symbol: Try to find the symbol in the top
445 * level environment frame. The function returns SCM_UNDEFINED if the symbol
446 * is unbound and it returns a variable object if the symbol is a global
449 lookup_global_symbol (const SCM symbol
, const SCM top_level
)
451 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
452 if (SCM_FALSEP (variable
))
453 return SCM_UNDEFINED
;
459 lookup_symbol (const SCM symbol
, const SCM env
)
462 unsigned int frame_nr
;
464 for (frame_idx
= env
, frame_nr
= 0;
465 !SCM_NULLP (frame_idx
);
466 frame_idx
= SCM_CDR (frame_idx
), ++frame_nr
)
468 const SCM frame
= SCM_CAR (frame_idx
);
469 if (SCM_CONSP (frame
))
471 /* frame holds a local environment frame */
473 unsigned int symbol_nr
;
475 for (symbol_idx
= SCM_CAR (frame
), symbol_nr
= 0;
476 SCM_CONSP (symbol_idx
);
477 symbol_idx
= SCM_CDR (symbol_idx
), ++symbol_nr
)
479 if (SCM_EQ_P (SCM_CAR (symbol_idx
), symbol
))
480 /* found the symbol, therefore return the iloc */
481 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 0);
483 if (SCM_EQ_P (symbol_idx
, symbol
))
484 /* found the symbol as the last element of the current frame */
485 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 1);
489 /* no more local environment frames */
490 return lookup_global_symbol (symbol
, frame
);
494 return lookup_global_symbol (symbol
, SCM_BOOL_F
);
498 /* Return true if the symbol is - from the point of view of a macro
499 * transformer - a literal in the sense specified in chapter "pattern
500 * language" of R5RS. In the code below, however, we don't match the
501 * definition of R5RS exactly: It returns true if the identifier has no
502 * binding or if it is a syntactic keyword. */
504 literal_p (const SCM symbol
, const SCM env
)
506 const SCM variable
= lookup_symbol (symbol
, env
);
507 if (SCM_UNBNDP (variable
))
509 if (SCM_VARIABLEP (variable
) && SCM_MACROP (SCM_VARIABLE_REF (variable
)))
516 /* Return true if the expression is self-quoting in the memoized code. Thus,
517 * some other objects (like e. g. vectors) are reported as self-quoting, which
518 * according to R5RS would need to be quoted. */
520 is_self_quoting_p (const SCM expr
)
522 if (SCM_CONSP (expr
))
524 else if (SCM_SYMBOLP (expr
))
526 else if (SCM_NULLP (expr
))
532 /* Rewrite the body (which is given as the list of expressions forming the
533 * body) into its internal form. The internal form of a body (<expr> ...) is
534 * just the body itself, but prefixed with an ISYM that denotes to what kind
535 * of outer construct this body belongs: (<ISYM> <expr> ...). A lambda body
536 * starts with SCM_IM_LAMBDA, for example, a body of a let starts with
539 * It is assumed that the calling expression has already made sure that the
540 * body is a proper list. */
542 m_body (SCM op
, SCM exprs
)
544 /* Don't add another ISYM if one is present already. */
545 if (SCM_ISYMP (SCM_CAR (exprs
)))
548 return scm_cons (op
, exprs
);
552 /* The function m_expand_body memoizes a proper list of expressions forming a
553 * body. This function takes care of dealing with internal defines and
554 * transforming them into an equivalent letrec expression. The list of
555 * expressions is rewritten in place. */
557 /* This is a helper function for m_expand_body. If the argument expression is
558 * a symbol that denotes a syntactic keyword, the corresponding macro object
559 * is returned, in all other cases the function returns SCM_UNDEFINED. */
561 try_macro_lookup (const SCM expr
, const SCM env
)
563 if (SCM_SYMBOLP (expr
))
565 const SCM variable
= lookup_symbol (expr
, env
);
566 if (SCM_VARIABLEP (variable
))
568 const SCM value
= SCM_VARIABLE_REF (variable
);
569 if (SCM_MACROP (value
))
574 return SCM_UNDEFINED
;
577 /* This is a helper function for m_expand_body. It expands user macros,
578 * because for the correct translation of a body we need to know whether they
579 * expand to a definition. */
581 expand_user_macros (SCM expr
, const SCM env
)
583 while (SCM_CONSP (expr
))
585 const SCM car_expr
= SCM_CAR (expr
);
586 const SCM new_car
= expand_user_macros (car_expr
, env
);
587 const SCM value
= try_macro_lookup (new_car
, env
);
589 if (SCM_MACROP (value
) && SCM_MACRO_TYPE (value
) == 2)
591 /* User macros transform code into code. */
592 expr
= scm_call_2 (SCM_MACRO_CODE (value
), expr
, env
);
593 /* We need to reiterate on the transformed code. */
597 /* No user macro: return. */
598 SCM_SETCAR (expr
, new_car
);
606 /* This is a helper function for m_expand_body. It determines if a given form
607 * represents an application of a given built-in macro. The built-in macro to
608 * check for is identified by its syntactic keyword. The form is an
609 * application of the given macro if looking up the car of the form in the
610 * given environment actually returns the built-in macro. */
612 is_system_macro_p (const SCM syntactic_keyword
, const SCM form
, const SCM env
)
614 if (SCM_CONSP (form
))
616 const SCM car_form
= SCM_CAR (form
);
617 const SCM value
= try_macro_lookup (car_form
, env
);
618 if (SCM_BUILTIN_MACRO_P (value
))
620 const SCM macro_name
= scm_macro_name (value
);
621 return SCM_EQ_P (macro_name
, syntactic_keyword
);
629 m_expand_body (const SCM forms
, const SCM env
)
631 /* The first body form can be skipped since it is known to be the ISYM that
632 * was prepended to the body by m_body. */
633 SCM cdr_forms
= SCM_CDR (forms
);
634 SCM form_idx
= cdr_forms
;
635 SCM definitions
= SCM_EOL
;
636 SCM sequence
= SCM_EOL
;
638 /* According to R5RS, the list of body forms consists of two parts: a number
639 * (maybe zero) of definitions, followed by a non-empty sequence of
640 * expressions. Each the definitions and the expressions may be grouped
641 * arbitrarily with begin, but it is not allowed to mix definitions and
642 * expressions. The task of the following loop therefore is to split the
643 * list of body forms into the list of definitions and the sequence of
645 while (!SCM_NULLP (form_idx
))
647 const SCM form
= SCM_CAR (form_idx
);
648 const SCM new_form
= expand_user_macros (form
, env
);
649 if (is_system_macro_p (scm_sym_define
, new_form
, env
))
651 definitions
= scm_cons (new_form
, definitions
);
652 form_idx
= SCM_CDR (form_idx
);
654 else if (is_system_macro_p (scm_sym_begin
, new_form
, env
))
656 /* We have encountered a group of forms. This has to be either a
657 * (possibly empty) group of (possibly further grouped) definitions,
658 * or a non-empty group of (possibly further grouped)
660 const SCM grouped_forms
= SCM_CDR (new_form
);
661 unsigned int found_definition
= 0;
662 unsigned int found_expression
= 0;
663 SCM grouped_form_idx
= grouped_forms
;
664 while (!found_expression
&& !SCM_NULLP (grouped_form_idx
))
666 const SCM inner_form
= SCM_CAR (grouped_form_idx
);
667 const SCM new_inner_form
= expand_user_macros (inner_form
, env
);
668 if (is_system_macro_p (scm_sym_define
, new_inner_form
, env
))
670 found_definition
= 1;
671 definitions
= scm_cons (new_inner_form
, definitions
);
672 grouped_form_idx
= SCM_CDR (grouped_form_idx
);
674 else if (is_system_macro_p (scm_sym_begin
, new_inner_form
, env
))
676 const SCM inner_group
= SCM_CDR (new_inner_form
);
678 = scm_append (scm_list_2 (inner_group
,
679 SCM_CDR (grouped_form_idx
)));
683 /* The group marks the start of the expressions of the body.
684 * We have to make sure that within the same group we have
685 * not encountered a definition before. */
686 ASSERT_SYNTAX (!found_definition
, s_mixed_body_forms
, form
);
687 found_expression
= 1;
688 grouped_form_idx
= SCM_EOL
;
692 /* We have finished processing the group. If we have not yet
693 * encountered an expression we continue processing the forms of the
694 * body to collect further definition forms. Otherwise, the group
695 * marks the start of the sequence of expressions of the body. */
696 if (!found_expression
)
698 form_idx
= SCM_CDR (form_idx
);
708 /* We have detected a form which is no definition. This marks the
709 * start of the sequence of expressions of the body. */
715 /* FIXME: forms does not hold information about the file location. */
716 ASSERT_SYNTAX (SCM_CONSP (sequence
), s_missing_body_expression
, cdr_forms
);
718 if (!SCM_NULLP (definitions
))
722 SCM letrec_expression
;
723 SCM new_letrec_expression
;
725 SCM bindings
= SCM_EOL
;
726 for (definition_idx
= definitions
;
727 !SCM_NULLP (definition_idx
);
728 definition_idx
= SCM_CDR (definition_idx
))
730 const SCM definition
= SCM_CAR (definition_idx
);
731 const SCM canonical_definition
= canonicalize_define (definition
);
732 const SCM binding
= SCM_CDR (canonical_definition
);
733 bindings
= scm_cons (binding
, bindings
);
736 letrec_tail
= scm_cons (bindings
, sequence
);
737 /* FIXME: forms does not hold information about the file location. */
738 letrec_expression
= scm_cons_source (forms
, scm_sym_letrec
, letrec_tail
);
739 new_letrec_expression
= scm_m_letrec (letrec_expression
, env
);
740 SCM_SETCAR (forms
, new_letrec_expression
);
741 SCM_SETCDR (forms
, SCM_EOL
);
745 SCM_SETCAR (forms
, SCM_CAR (sequence
));
746 SCM_SETCDR (forms
, SCM_CDR (sequence
));
751 /* Start of the memoizers for the standard R5RS builtin macros. */
754 SCM_SYNTAX (s_and
, "and", scm_i_makbimacro
, scm_m_and
);
755 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
758 scm_m_and (SCM expr
, SCM env SCM_UNUSED
)
760 const SCM cdr_expr
= SCM_CDR (expr
);
761 const long length
= scm_ilength (cdr_expr
);
763 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
767 /* Special case: (and) is replaced by #t. */
772 SCM_SETCAR (expr
, SCM_IM_AND
);
778 SCM_SYNTAX (s_begin
, "begin", scm_i_makbimacro
, scm_m_begin
);
779 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
782 scm_m_begin (SCM expr
, SCM env SCM_UNUSED
)
784 const SCM cdr_expr
= SCM_CDR (expr
);
785 /* Dirk:FIXME:: An empty begin clause is not generally allowed by R5RS.
786 * That means, there should be a distinction between uses of begin where an
787 * empty clause is OK and where it is not. */
788 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
790 SCM_SETCAR (expr
, SCM_IM_BEGIN
);
795 SCM_SYNTAX (s_case
, "case", scm_i_makbimacro
, scm_m_case
);
796 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
797 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
800 scm_m_case (SCM expr
, SCM env
)
803 SCM all_labels
= SCM_EOL
;
805 /* Check, whether 'else is a literal, i. e. not bound to a value. */
806 const int else_literal_p
= literal_p (scm_sym_else
, env
);
808 const SCM cdr_expr
= SCM_CDR (expr
);
809 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
810 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_clauses
, expr
);
812 clauses
= SCM_CDR (cdr_expr
);
813 while (!SCM_NULLP (clauses
))
817 const SCM clause
= SCM_CAR (clauses
);
818 ASSERT_SYNTAX_2 (scm_ilength (clause
) >= 2,
819 s_bad_case_clause
, clause
, expr
);
821 labels
= SCM_CAR (clause
);
822 if (SCM_CONSP (labels
))
824 ASSERT_SYNTAX_2 (scm_ilength (labels
) >= 0,
825 s_bad_case_labels
, labels
, expr
);
826 all_labels
= scm_append (scm_list_2 (labels
, all_labels
));
828 else if (SCM_NULLP (labels
))
830 /* The list of labels is empty. According to R5RS this is allowed.
831 * It means that the sequence of expressions will never be executed.
832 * Therefore, as an optimization, we could remove the whole
837 ASSERT_SYNTAX_2 (SCM_EQ_P (labels
, scm_sym_else
) && else_literal_p
,
838 s_bad_case_labels
, labels
, expr
);
839 ASSERT_SYNTAX_2 (SCM_NULLP (SCM_CDR (clauses
)),
840 s_misplaced_else_clause
, clause
, expr
);
843 /* build the new clause */
844 if (SCM_EQ_P (labels
, scm_sym_else
))
845 SCM_SETCAR (clause
, SCM_IM_ELSE
);
847 clauses
= SCM_CDR (clauses
);
850 /* Check whether all case labels are distinct. */
851 for (; !SCM_NULLP (all_labels
); all_labels
= SCM_CDR (all_labels
))
853 const SCM label
= SCM_CAR (all_labels
);
854 ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (label
, SCM_CDR (all_labels
))),
855 s_duplicate_case_label
, label
, expr
);
858 SCM_SETCAR (expr
, SCM_IM_CASE
);
863 SCM_SYNTAX (s_cond
, "cond", scm_i_makbimacro
, scm_m_cond
);
864 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
865 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
868 scm_m_cond (SCM expr
, SCM env
)
870 /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
871 const int else_literal_p
= literal_p (scm_sym_else
, env
);
872 const int arrow_literal_p
= literal_p (scm_sym_arrow
, env
);
874 const SCM clauses
= SCM_CDR (expr
);
877 ASSERT_SYNTAX (scm_ilength (clauses
) >= 0, s_bad_expression
, expr
);
878 ASSERT_SYNTAX (scm_ilength (clauses
) >= 1, s_missing_clauses
, expr
);
880 for (clause_idx
= clauses
;
881 !SCM_NULLP (clause_idx
);
882 clause_idx
= SCM_CDR (clause_idx
))
886 const SCM clause
= SCM_CAR (clause_idx
);
887 const long length
= scm_ilength (clause
);
888 ASSERT_SYNTAX_2 (length
>= 1, s_bad_cond_clause
, clause
, expr
);
890 test
= SCM_CAR (clause
);
891 if (SCM_EQ_P (test
, scm_sym_else
) && else_literal_p
)
893 const int last_clause_p
= SCM_NULLP (SCM_CDR (clause_idx
));
894 ASSERT_SYNTAX_2 (length
>= 2,
895 s_bad_cond_clause
, clause
, expr
);
896 ASSERT_SYNTAX_2 (last_clause_p
,
897 s_misplaced_else_clause
, clause
, expr
);
898 SCM_SETCAR (clause
, SCM_IM_ELSE
);
901 && SCM_EQ_P (SCM_CADR (clause
), scm_sym_arrow
)
904 ASSERT_SYNTAX_2 (length
> 2, s_missing_recipient
, clause
, expr
);
905 ASSERT_SYNTAX_2 (length
== 3, s_extra_expression
, clause
, expr
);
906 SCM_SETCAR (SCM_CDR (clause
), SCM_IM_ARROW
);
910 SCM_SETCAR (expr
, SCM_IM_COND
);
915 SCM_SYNTAX (s_define
, "define", scm_i_makbimacro
, scm_m_define
);
916 SCM_GLOBAL_SYMBOL (scm_sym_define
, s_define
);
918 /* Guile provides an extension to R5RS' define syntax to represent function
919 * currying in a compact way. With this extension, it is allowed to write
920 * (define <nested-variable> <body>), where <nested-variable> has of one of
921 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
922 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
923 * should be either a sequence of zero or more variables, or a sequence of one
924 * or more variables followed by a space-delimited period and another
925 * variable. Each level of argument nesting wraps the <body> within another
926 * lambda expression. For example, the following forms are allowed, each one
927 * followed by an equivalent, more explicit implementation.
929 * (define ((a b . c) . d) <body>) is equivalent to
930 * (define a (lambda (b . c) (lambda d <body>)))
932 * (define (((a) b) c . d) <body>) is equivalent to
933 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
935 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
936 * module that does not implement this extension. */
938 canonicalize_define (const SCM expr
)
943 const SCM cdr_expr
= SCM_CDR (expr
);
944 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
945 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
947 body
= SCM_CDR (cdr_expr
);
948 variable
= SCM_CAR (cdr_expr
);
949 while (SCM_CONSP (variable
))
951 /* This while loop realizes function currying by variable nesting.
952 * Variable is known to be a nested-variable. In every iteration of the
953 * loop another level of lambda expression is created, starting with the
954 * innermost one. Note that we don't check for duplicate formals here:
955 * This will be done by the memoizer of the lambda expression. */
956 const SCM formals
= SCM_CDR (variable
);
957 const SCM tail
= scm_cons (formals
, body
);
959 /* Add source properties to each new lambda expression: */
960 const SCM lambda
= scm_cons_source (variable
, scm_sym_lambda
, tail
);
962 body
= scm_list_1 (lambda
);
963 variable
= SCM_CAR (variable
);
965 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
), s_bad_variable
, variable
, expr
);
966 ASSERT_SYNTAX (scm_ilength (body
) == 1, s_expression
, expr
);
968 SCM_SETCAR (cdr_expr
, variable
);
969 SCM_SETCDR (cdr_expr
, body
);
973 /* According to section 5.2.1 of R5RS we first have to make sure that the
974 * variable is bound, and then perform the (set! variable expression)
975 * operation. This means, that within the expression we may already assign
976 * values to variable: (define foo (begin (set! foo 1) (+ foo 1))) */
978 scm_m_define (SCM expr
, SCM env
)
980 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), s_bad_define
, expr
);
983 const SCM canonical_definition
= canonicalize_define (expr
);
984 const SCM cdr_canonical_definition
= SCM_CDR (canonical_definition
);
985 const SCM variable
= SCM_CAR (cdr_canonical_definition
);
987 = scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_T
);
988 const SCM value
= scm_eval_car (SCM_CDR (cdr_canonical_definition
), env
);
990 if (SCM_REC_PROCNAMES_P
)
993 while (SCM_MACROP (tmp
))
994 tmp
= SCM_MACRO_CODE (tmp
);
995 if (SCM_CLOSUREP (tmp
)
996 /* Only the first definition determines the name. */
997 && SCM_FALSEP (scm_procedure_property (tmp
, scm_sym_name
)))
998 scm_set_procedure_property_x (tmp
, scm_sym_name
, variable
);
1001 SCM_VARIABLE_SET (location
, value
);
1003 return SCM_UNSPECIFIED
;
1008 /* This is a helper function for forms (<keyword> <expression>) that are
1009 * transformed into (#@<keyword> '() <memoized_expression>) in order to allow
1010 * for easy creation of a thunk (i. e. a closure without arguments) using the
1011 * ('() <memoized_expression>) tail of the memoized form. */
1013 memoize_as_thunk_prototype (const SCM expr
, const SCM env SCM_UNUSED
)
1015 const SCM cdr_expr
= SCM_CDR (expr
);
1016 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1017 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1019 SCM_SETCDR (expr
, scm_cons (SCM_EOL
, cdr_expr
));
1025 SCM_SYNTAX (s_delay
, "delay", scm_i_makbimacro
, scm_m_delay
);
1026 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
1028 /* Promises are implemented as closures with an empty parameter list. Thus,
1029 * (delay <expression>) is transformed into (#@delay '() <expression>), where
1030 * the empty list represents the empty parameter list. This representation
1031 * allows for easy creation of the closure during evaluation. */
1033 scm_m_delay (SCM expr
, SCM env
)
1035 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1036 SCM_SETCAR (new_expr
, SCM_IM_DELAY
);
1041 SCM_SYNTAX(s_do
, "do", scm_i_makbimacro
, scm_m_do
);
1042 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
1044 /* DO gets the most radically altered syntax. The order of the vars is
1045 * reversed here. During the evaluation this allows for simple consing of the
1046 * results of the inits and steps:
1048 (do ((<var1> <init1> <step1>)
1056 (#@do (<init1> <init2> ... <initn>)
1057 (varn ... var2 var1)
1060 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
1063 scm_m_do (SCM expr
, SCM env SCM_UNUSED
)
1065 SCM variables
= SCM_EOL
;
1066 SCM init_forms
= SCM_EOL
;
1067 SCM step_forms
= SCM_EOL
;
1074 const SCM cdr_expr
= SCM_CDR (expr
);
1075 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1076 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1078 /* Collect variables, init and step forms. */
1079 binding_idx
= SCM_CAR (cdr_expr
);
1080 ASSERT_SYNTAX_2 (scm_ilength (binding_idx
) >= 0,
1081 s_bad_bindings
, binding_idx
, expr
);
1082 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1084 const SCM binding
= SCM_CAR (binding_idx
);
1085 const long length
= scm_ilength (binding
);
1086 ASSERT_SYNTAX_2 (length
== 2 || length
== 3,
1087 s_bad_binding
, binding
, expr
);
1090 const SCM name
= SCM_CAR (binding
);
1091 const SCM init
= SCM_CADR (binding
);
1092 const SCM step
= (length
== 2) ? name
: SCM_CADDR (binding
);
1093 ASSERT_SYNTAX_2 (SCM_SYMBOLP (name
), s_bad_variable
, name
, expr
);
1094 ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (name
, variables
)),
1095 s_duplicate_binding
, name
, expr
);
1097 variables
= scm_cons (name
, variables
);
1098 init_forms
= scm_cons (init
, init_forms
);
1099 step_forms
= scm_cons (step
, step_forms
);
1102 init_forms
= scm_reverse_x (init_forms
, SCM_UNDEFINED
);
1103 step_forms
= scm_reverse_x (step_forms
, SCM_UNDEFINED
);
1105 /* Memoize the test form and the exit sequence. */
1106 cddr_expr
= SCM_CDR (cdr_expr
);
1107 exit_clause
= SCM_CAR (cddr_expr
);
1108 ASSERT_SYNTAX_2 (scm_ilength (exit_clause
) >= 1,
1109 s_bad_exit_clause
, exit_clause
, expr
);
1111 commands
= SCM_CDR (cddr_expr
);
1112 tail
= scm_cons2 (exit_clause
, commands
, step_forms
);
1113 tail
= scm_cons2 (init_forms
, variables
, tail
);
1114 SCM_SETCAR (expr
, SCM_IM_DO
);
1115 SCM_SETCDR (expr
, tail
);
1120 SCM_SYNTAX (s_if
, "if", scm_i_makbimacro
, scm_m_if
);
1121 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
1124 scm_m_if (SCM expr
, SCM env SCM_UNUSED
)
1126 const SCM cdr_expr
= SCM_CDR (expr
);
1127 const long length
= scm_ilength (cdr_expr
);
1128 ASSERT_SYNTAX (length
== 2 || length
== 3, s_expression
, expr
);
1129 SCM_SETCAR (expr
, SCM_IM_IF
);
1134 SCM_SYNTAX (s_lambda
, "lambda", scm_i_makbimacro
, scm_m_lambda
);
1135 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
1137 /* A helper function for memoize_lambda to support checking for duplicate
1138 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
1139 * LIST or to the cdr of the last cons. Therefore, LIST may have any of the
1140 * forms that a formal argument can have:
1141 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
1143 c_improper_memq (SCM obj
, SCM list
)
1145 for (; SCM_CONSP (list
); list
= SCM_CDR (list
))
1147 if (SCM_EQ_P (SCM_CAR (list
), obj
))
1150 return SCM_EQ_P (list
, obj
);
1154 scm_m_lambda (SCM expr
, SCM env SCM_UNUSED
)
1163 const SCM cdr_expr
= SCM_CDR (expr
);
1164 const long length
= scm_ilength (cdr_expr
);
1165 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1166 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1168 /* Before iterating the list of formal arguments, make sure the formals
1169 * actually are given as either a symbol or a non-cyclic list. */
1170 formals
= SCM_CAR (cdr_expr
);
1171 if (SCM_CONSP (formals
))
1173 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
1174 * detected, report a 'Bad formals' error. */
1178 ASSERT_SYNTAX_2 (SCM_SYMBOLP (formals
) || SCM_NULLP (formals
),
1179 s_bad_formals
, formals
, expr
);
1182 /* Now iterate the list of formal arguments to check if all formals are
1183 * symbols, and that there are no duplicates. */
1184 formals_idx
= formals
;
1185 while (SCM_CONSP (formals_idx
))
1187 const SCM formal
= SCM_CAR (formals_idx
);
1188 const SCM next_idx
= SCM_CDR (formals_idx
);
1189 ASSERT_SYNTAX_2 (SCM_SYMBOLP (formal
), s_bad_formal
, formal
, expr
);
1190 ASSERT_SYNTAX_2 (!c_improper_memq (formal
, next_idx
),
1191 s_duplicate_formal
, formal
, expr
);
1192 formals_idx
= next_idx
;
1194 ASSERT_SYNTAX_2 (SCM_NULLP (formals_idx
) || SCM_SYMBOLP (formals_idx
),
1195 s_bad_formal
, formals_idx
, expr
);
1197 /* Memoize the body. Keep a potential documentation string. */
1198 /* Dirk:FIXME:: We should probably extract the documentation string to
1199 * some external database. Otherwise it will slow down execution, since
1200 * the documentation string will have to be skipped with every execution
1201 * of the closure. */
1202 cddr_expr
= SCM_CDR (cdr_expr
);
1203 documentation
= (length
>= 3 && SCM_STRINGP (SCM_CAR (cddr_expr
)));
1204 body
= documentation
? SCM_CDR (cddr_expr
) : cddr_expr
;
1205 new_body
= m_body (SCM_IM_LAMBDA
, body
);
1207 SCM_SETCAR (expr
, SCM_IM_LAMBDA
);
1209 SCM_SETCDR (cddr_expr
, new_body
);
1211 SCM_SETCDR (cdr_expr
, new_body
);
1216 /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
1218 check_bindings (const SCM bindings
, const SCM expr
)
1222 ASSERT_SYNTAX_2 (scm_ilength (bindings
) >= 0,
1223 s_bad_bindings
, bindings
, expr
);
1225 binding_idx
= bindings
;
1226 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1228 SCM name
; /* const */
1230 const SCM binding
= SCM_CAR (binding_idx
);
1231 ASSERT_SYNTAX_2 (scm_ilength (binding
) == 2,
1232 s_bad_binding
, binding
, expr
);
1234 name
= SCM_CAR (binding
);
1235 ASSERT_SYNTAX_2 (SCM_SYMBOLP (name
), s_bad_variable
, name
, expr
);
1240 /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
1241 * transformed to the lists (vn ... v2 v1) and (i1 i2 ... in). That is, the
1242 * variables are returned in a list with their order reversed, and the init
1243 * forms are returned in a list in the same order as they are given in the
1244 * bindings. If a duplicate variable name is detected, an error is
1247 transform_bindings (
1248 const SCM bindings
, const SCM expr
,
1249 SCM
*const rvarptr
, SCM
*const initptr
)
1251 SCM rvariables
= SCM_EOL
;
1252 SCM rinits
= SCM_EOL
;
1253 SCM binding_idx
= bindings
;
1254 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1256 const SCM binding
= SCM_CAR (binding_idx
);
1257 const SCM cdr_binding
= SCM_CDR (binding
);
1258 const SCM name
= SCM_CAR (binding
);
1259 ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (name
, rvariables
)),
1260 s_duplicate_binding
, name
, expr
);
1261 rvariables
= scm_cons (name
, rvariables
);
1262 rinits
= scm_cons (SCM_CAR (cdr_binding
), rinits
);
1264 *rvarptr
= rvariables
;
1265 *initptr
= scm_reverse_x (rinits
, SCM_UNDEFINED
);
1269 SCM_SYNTAX(s_let
, "let", scm_i_makbimacro
, scm_m_let
);
1270 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
1272 /* This function is a helper function for memoize_let. It transforms
1273 * (let name ((var init) ...) body ...) into
1274 * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
1275 * and memoizes the expression. It is assumed that the caller has checked
1276 * that name is a symbol and that there are bindings and a body. */
1278 memoize_named_let (const SCM expr
, const SCM env SCM_UNUSED
)
1284 const SCM cdr_expr
= SCM_CDR (expr
);
1285 const SCM name
= SCM_CAR (cdr_expr
);
1286 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1287 const SCM bindings
= SCM_CAR (cddr_expr
);
1288 check_bindings (bindings
, expr
);
1290 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1291 variables
= scm_reverse_x (rvariables
, SCM_UNDEFINED
);
1294 const SCM let_body
= SCM_CDR (cddr_expr
);
1295 const SCM lambda_body
= m_body (SCM_IM_LET
, let_body
);
1296 const SCM lambda_tail
= scm_cons (variables
, lambda_body
);
1297 const SCM lambda_form
= scm_cons_source (expr
, scm_sym_lambda
, lambda_tail
);
1299 const SCM rvar
= scm_list_1 (name
);
1300 const SCM init
= scm_list_1 (lambda_form
);
1301 const SCM body
= m_body (SCM_IM_LET
, scm_list_1 (name
));
1302 const SCM letrec_tail
= scm_cons (rvar
, scm_cons (init
, body
));
1303 const SCM letrec_form
= scm_cons_source (expr
, SCM_IM_LETREC
, letrec_tail
);
1304 return scm_cons_source (expr
, letrec_form
, inits
);
1308 /* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1309 * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
1311 scm_m_let (SCM expr
, SCM env
)
1315 const SCM cdr_expr
= SCM_CDR (expr
);
1316 const long length
= scm_ilength (cdr_expr
);
1317 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1318 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1320 bindings
= SCM_CAR (cdr_expr
);
1321 if (SCM_SYMBOLP (bindings
))
1323 ASSERT_SYNTAX (length
>= 3, s_missing_expression
, expr
);
1324 return memoize_named_let (expr
, env
);
1327 check_bindings (bindings
, expr
);
1328 if (SCM_NULLP (bindings
) || SCM_NULLP (SCM_CDR (bindings
)))
1330 /* Special case: no bindings or single binding => let* is faster. */
1331 const SCM body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1332 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), bindings
, body
), env
);
1339 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1342 const SCM new_body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1343 const SCM new_tail
= scm_cons2 (rvariables
, inits
, new_body
);
1344 SCM_SETCAR (expr
, SCM_IM_LET
);
1345 SCM_SETCDR (expr
, new_tail
);
1352 SCM_SYNTAX (s_letstar
, "let*", scm_i_makbimacro
, scm_m_letstar
);
1353 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
1355 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1356 * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
1358 scm_m_letstar (SCM expr
, SCM env SCM_UNUSED
)
1363 const SCM cdr_expr
= SCM_CDR (expr
);
1364 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1365 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1367 binding_idx
= SCM_CAR (cdr_expr
);
1368 check_bindings (binding_idx
, expr
);
1370 /* Transform ((v1 i1) (v2 i2) ...) into (v1 i1 v2 i2 ...). The
1371 * transformation is done in place. At the beginning of one iteration of
1372 * the loop the variable binding_idx holds the form
1373 * P1:( (vn . P2:(in . ())) . P3:( (vn+1 in+1) ... ) ),
1374 * where P1, P2 and P3 indicate the pairs, that are relevant for the
1375 * transformation. P1 and P2 are modified in the loop, P3 remains
1376 * untouched. After the execution of the loop, P1 will hold
1377 * P1:( vn . P2:(in . P3:( (vn+1 in+1) ... )) )
1378 * and binding_idx will hold P3. */
1379 while (!SCM_NULLP (binding_idx
))
1381 const SCM cdr_binding_idx
= SCM_CDR (binding_idx
); /* remember P3 */
1382 const SCM binding
= SCM_CAR (binding_idx
);
1383 const SCM name
= SCM_CAR (binding
);
1384 const SCM cdr_binding
= SCM_CDR (binding
);
1386 SCM_SETCDR (cdr_binding
, cdr_binding_idx
); /* update P2 */
1387 SCM_SETCAR (binding_idx
, name
); /* update P1 */
1388 SCM_SETCDR (binding_idx
, cdr_binding
); /* update P1 */
1390 binding_idx
= cdr_binding_idx
; /* continue with P3 */
1393 new_body
= m_body (SCM_IM_LETSTAR
, SCM_CDR (cdr_expr
));
1394 SCM_SETCAR (expr
, SCM_IM_LETSTAR
);
1395 /* the bindings have been changed in place */
1396 SCM_SETCDR (cdr_expr
, new_body
);
1401 SCM_SYNTAX(s_letrec
, "letrec", scm_i_makbimacro
, scm_m_letrec
);
1402 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
1405 scm_m_letrec (SCM expr
, SCM env
)
1409 const SCM cdr_expr
= SCM_CDR (expr
);
1410 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1411 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1413 bindings
= SCM_CAR (cdr_expr
);
1414 if (SCM_NULLP (bindings
))
1416 /* no bindings, let* is executed faster */
1417 SCM body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1418 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), SCM_EOL
, body
), env
);
1426 check_bindings (bindings
, expr
);
1427 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1428 new_body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1429 return scm_cons2 (SCM_IM_LETREC
, rvariables
, scm_cons (inits
, new_body
));
1434 SCM_SYNTAX (s_or
, "or", scm_i_makbimacro
, scm_m_or
);
1435 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
1438 scm_m_or (SCM expr
, SCM env SCM_UNUSED
)
1440 const SCM cdr_expr
= SCM_CDR (expr
);
1441 const long length
= scm_ilength (cdr_expr
);
1443 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1447 /* Special case: (or) is replaced by #f. */
1452 SCM_SETCAR (expr
, SCM_IM_OR
);
1458 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
1459 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
1460 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
1461 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
1463 /* Internal function to handle a quasiquotation: 'form' is the parameter in
1464 * the call (quasiquotation form), 'env' is the environment where unquoted
1465 * expressions will be evaluated, and 'depth' is the current quasiquotation
1466 * nesting level and is known to be greater than zero. */
1468 iqq (SCM form
, SCM env
, unsigned long int depth
)
1470 if (SCM_CONSP (form
))
1472 const SCM tmp
= SCM_CAR (form
);
1473 if (SCM_EQ_P (tmp
, scm_sym_quasiquote
))
1475 const SCM args
= SCM_CDR (form
);
1476 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1477 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
1479 else if (SCM_EQ_P (tmp
, scm_sym_unquote
))
1481 const SCM args
= SCM_CDR (form
);
1482 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1484 return scm_eval_car (args
, env
);
1486 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
1488 else if (SCM_CONSP (tmp
)
1489 && SCM_EQ_P (SCM_CAR (tmp
), scm_sym_uq_splicing
))
1491 const SCM args
= SCM_CDR (tmp
);
1492 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1495 const SCM list
= scm_eval_car (args
, env
);
1496 const SCM rest
= SCM_CDR (form
);
1497 ASSERT_SYNTAX_2 (scm_ilength (list
) >= 0,
1498 s_splicing
, list
, form
);
1499 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
1502 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
1503 iqq (SCM_CDR (form
), env
, depth
));
1506 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
1507 iqq (SCM_CDR (form
), env
, depth
));
1509 else if (SCM_VECTORP (form
))
1511 size_t i
= SCM_VECTOR_LENGTH (form
);
1512 SCM
const *const data
= SCM_VELTS (form
);
1515 tmp
= scm_cons (data
[--i
], tmp
);
1516 scm_remember_upto_here_1 (form
);
1517 return scm_vector (iqq (tmp
, env
, depth
));
1524 scm_m_quasiquote (SCM expr
, SCM env
)
1526 const SCM cdr_expr
= SCM_CDR (expr
);
1527 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1528 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1529 return iqq (SCM_CAR (cdr_expr
), env
, 1);
1533 SCM_SYNTAX (s_quote
, "quote", scm_i_makbimacro
, scm_m_quote
);
1534 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
1537 scm_m_quote (SCM expr
, SCM env SCM_UNUSED
)
1541 const SCM cdr_expr
= SCM_CDR (expr
);
1542 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1543 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1544 quotee
= SCM_CAR (cdr_expr
);
1545 if (is_self_quoting_p (quotee
))
1548 SCM_SETCAR (expr
, SCM_IM_QUOTE
);
1549 SCM_SETCDR (expr
, quotee
);
1554 unmemoize_quote (const SCM expr
, const SCM env SCM_UNUSED
)
1556 return scm_list_2 (scm_sym_quote
, SCM_CDR (expr
));
1560 /* Will go into the RnRS module when Guile is factorized.
1561 SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
1562 static const char s_set_x
[] = "set!";
1563 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, s_set_x
);
1566 scm_m_set_x (SCM expr
, SCM env SCM_UNUSED
)
1571 const SCM cdr_expr
= SCM_CDR (expr
);
1572 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1573 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1574 variable
= SCM_CAR (cdr_expr
);
1576 /* Memoize the variable form. */
1577 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
), s_bad_variable
, variable
, expr
);
1578 new_variable
= lookup_symbol (variable
, env
);
1579 /* Leave the memoization of unbound symbols to lazy memoization: */
1580 if (SCM_UNBNDP (new_variable
))
1581 new_variable
= variable
;
1583 SCM_SETCAR (expr
, SCM_IM_SET_X
);
1584 SCM_SETCAR (cdr_expr
, new_variable
);
1589 /* Start of the memoizers for non-R5RS builtin macros. */
1592 SCM_SYNTAX (s_atapply
, "@apply", scm_i_makbimacro
, scm_m_apply
);
1593 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1594 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1597 scm_m_apply (SCM expr
, SCM env SCM_UNUSED
)
1599 const SCM cdr_expr
= SCM_CDR (expr
);
1600 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1601 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_missing_expression
, expr
);
1603 SCM_SETCAR (expr
, SCM_IM_APPLY
);
1608 SCM_SYNTAX (s_atbind
, "@bind", scm_i_makbimacro
, scm_m_atbind
);
1610 /* FIXME: The following explanation should go into the documentation: */
1611 /* (@bind ((var init) ...) body ...) will assign the values of the `init's to
1612 * the global variables named by `var's (symbols, not evaluated), creating
1613 * them if they don't exist, executes body, and then restores the previous
1614 * values of the `var's. Additionally, whenever control leaves body, the
1615 * values of the `var's are saved and restored when control returns. It is an
1616 * error when a symbol appears more than once among the `var's. All `init's
1617 * are evaluated before any `var' is set.
1619 * Think of this as `let' for dynamic scope.
1622 /* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into
1623 * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...).
1625 * FIXME - also implement `@bind*'.
1628 scm_m_atbind (SCM expr
, SCM env
)
1635 const SCM top_level
= scm_env_top_level (env
);
1637 const SCM cdr_expr
= SCM_CDR (expr
);
1638 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1639 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1640 bindings
= SCM_CAR (cdr_expr
);
1641 check_bindings (bindings
, expr
);
1642 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1644 for (variable_idx
= rvariables
;
1645 !SCM_NULLP (variable_idx
);
1646 variable_idx
= SCM_CDR (variable_idx
))
1648 /* The first call to scm_sym2var will look beyond the current module,
1649 * while the second call wont. */
1650 const SCM variable
= SCM_CAR (variable_idx
);
1651 SCM new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_F
);
1652 if (SCM_FALSEP (new_variable
))
1653 new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_T
);
1654 SCM_SETCAR (variable_idx
, new_variable
);
1657 SCM_SETCAR (expr
, SCM_IM_BIND
);
1658 SCM_SETCAR (cdr_expr
, scm_cons (rvariables
, inits
));
1663 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_i_makbimacro
, scm_m_cont
);
1664 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, s_atcall_cc
);
1667 scm_m_cont (SCM expr
, SCM env SCM_UNUSED
)
1669 const SCM cdr_expr
= SCM_CDR (expr
);
1670 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1671 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1673 SCM_SETCAR (expr
, SCM_IM_CONT
);
1678 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_i_makbimacro
, scm_m_at_call_with_values
);
1679 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
1682 scm_m_at_call_with_values (SCM expr
, SCM env SCM_UNUSED
)
1684 const SCM cdr_expr
= SCM_CDR (expr
);
1685 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1686 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1688 SCM_SETCAR (expr
, SCM_IM_CALL_WITH_VALUES
);
1693 SCM_SYNTAX (s_future
, "future", scm_i_makbimacro
, scm_m_future
);
1694 SCM_GLOBAL_SYMBOL (scm_sym_future
, s_future
);
1696 /* Like promises, futures are implemented as closures with an empty
1697 * parameter list. Thus, (future <expression>) is transformed into
1698 * (#@future '() <expression>), where the empty list represents the
1699 * empty parameter list. This representation allows for easy creation
1700 * of the closure during evaluation. */
1702 scm_m_future (SCM expr
, SCM env
)
1704 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1705 SCM_SETCAR (new_expr
, SCM_IM_FUTURE
);
1710 SCM_SYNTAX (s_gset_x
, "set!", scm_i_makbimacro
, scm_m_generalized_set_x
);
1711 SCM_SYMBOL (scm_sym_setter
, "setter");
1714 scm_m_generalized_set_x (SCM expr
, SCM env
)
1716 SCM target
, exp_target
;
1718 const SCM cdr_expr
= SCM_CDR (expr
);
1719 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1720 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1722 target
= SCM_CAR (cdr_expr
);
1723 if (!SCM_CONSP (target
))
1726 return scm_m_set_x (expr
, env
);
1730 /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */
1731 /* Macroexpanding the target might return things of the form
1732 (begin <atom>). In that case, <atom> must be a symbol or a
1733 variable and we memoize to (set! <atom> ...).
1735 exp_target
= scm_macroexp (target
, env
);
1736 if (SCM_EQ_P (SCM_CAR (exp_target
), SCM_IM_BEGIN
)
1737 && !SCM_NULLP (SCM_CDR (exp_target
))
1738 && SCM_NULLP (SCM_CDDR (exp_target
)))
1740 exp_target
= SCM_CADR (exp_target
);
1741 ASSERT_SYNTAX_2 (SCM_SYMBOLP (exp_target
)
1742 || SCM_VARIABLEP (exp_target
),
1743 s_bad_variable
, exp_target
, expr
);
1744 return scm_cons (SCM_IM_SET_X
, scm_cons (exp_target
,
1745 SCM_CDR (cdr_expr
)));
1749 const SCM setter_proc_tail
= scm_list_1 (SCM_CAR (target
));
1750 const SCM setter_proc
= scm_cons_source (expr
, scm_sym_setter
,
1753 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1754 const SCM setter_args
= scm_append_x (scm_list_2 (SCM_CDR (target
),
1757 SCM_SETCAR (expr
, setter_proc
);
1758 SCM_SETCDR (expr
, setter_args
);
1765 /* @slot-ref is bound privately in the (oop goops) module from goops.c. As
1766 * soon as the module system allows us to more freely create bindings in
1767 * arbitrary modules during the startup phase, the code from goops.c should be
1770 scm_m_atslot_ref (SCM expr
, SCM env SCM_UNUSED
)
1774 const SCM cdr_expr
= SCM_CDR (expr
);
1775 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1776 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1777 slot_nr
= SCM_CADR (cdr_expr
);
1778 ASSERT_SYNTAX_2 (SCM_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
1780 SCM_SETCAR (expr
, SCM_IM_SLOT_REF
);
1781 SCM_SETCDR (cdr_expr
, slot_nr
);
1786 /* @slot-set! is bound privately in the (oop goops) module from goops.c. As
1787 * soon as the module system allows us to more freely create bindings in
1788 * arbitrary modules during the startup phase, the code from goops.c should be
1791 scm_m_atslot_set_x (SCM expr
, SCM env SCM_UNUSED
)
1795 const SCM cdr_expr
= SCM_CDR (expr
);
1796 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1797 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 3, s_expression
, expr
);
1798 slot_nr
= SCM_CADR (cdr_expr
);
1799 ASSERT_SYNTAX_2 (SCM_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
1801 SCM_SETCAR (expr
, SCM_IM_SLOT_SET_X
);
1806 #if SCM_ENABLE_ELISP
1808 static const char s_defun
[] = "Symbol's function definition is void";
1810 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_i_makbimacro
, scm_m_nil_cond
);
1812 /* nil-cond expressions have the form
1813 * (nil-cond COND VAL COND VAL ... ELSEVAL) */
1815 scm_m_nil_cond (SCM expr
, SCM env SCM_UNUSED
)
1817 const long length
= scm_ilength (SCM_CDR (expr
));
1818 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1819 ASSERT_SYNTAX (length
>= 1 && (length
% 2) == 1, s_expression
, expr
);
1821 SCM_SETCAR (expr
, SCM_IM_NIL_COND
);
1826 SCM_SYNTAX (s_atfop
, "@fop", scm_i_makbimacro
, scm_m_atfop
);
1828 /* The @fop-macro handles procedure and macro applications for elisp. The
1829 * input expression must have the form
1830 * (@fop <var> (transformer-macro <expr> ...))
1831 * where <var> must be a symbol. The expression is transformed into the
1832 * memoized form of either
1833 * (apply <un-aliased var> (transformer-macro <expr> ...))
1834 * if the value of var (across all aliasing) is not a macro, or
1835 * (<un-aliased var> <expr> ...)
1836 * if var is a macro. */
1838 scm_m_atfop (SCM expr
, SCM env SCM_UNUSED
)
1843 const SCM cdr_expr
= SCM_CDR (expr
);
1844 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1845 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 1, s_missing_expression
, expr
);
1847 symbol
= SCM_CAR (cdr_expr
);
1848 ASSERT_SYNTAX_2 (SCM_SYMBOLP (symbol
), s_bad_variable
, symbol
, expr
);
1850 location
= scm_symbol_fref (symbol
);
1851 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
1853 /* The elisp function `defalias' allows to define aliases for symbols. To
1854 * look up such definitions, the chain of symbol definitions has to be
1855 * followed up to the terminal symbol. */
1856 while (SCM_SYMBOLP (SCM_VARIABLE_REF (location
)))
1858 const SCM alias
= SCM_VARIABLE_REF (location
);
1859 location
= scm_symbol_fref (alias
);
1860 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
1863 /* Memoize the value location belonging to the terminal symbol. */
1864 SCM_SETCAR (cdr_expr
, location
);
1866 if (!SCM_MACROP (SCM_VARIABLE_REF (location
)))
1868 /* Since the location does not contain a macro, the form is a procedure
1869 * application. Replace `@fop' by `@apply' and transform the expression
1870 * including the `transformer-macro'. */
1871 SCM_SETCAR (expr
, SCM_IM_APPLY
);
1876 /* Since the location contains a macro, the arguments should not be
1877 * transformed, so the `transformer-macro' is cut out. The resulting
1878 * expression starts with the memoized variable, that is at the cdr of
1879 * the input expression. */
1880 SCM_SETCDR (cdr_expr
, SCM_CDADR (cdr_expr
));
1885 #endif /* SCM_ENABLE_ELISP */
1888 #if (SCM_ENABLE_DEPRECATED == 1)
1890 /* Deprecated in guile 1.7.0 on 2003-11-09. */
1892 scm_m_expand_body (SCM exprs
, SCM env
)
1894 scm_c_issue_deprecation_warning
1895 ("`scm_m_expand_body' is deprecated.");
1896 m_expand_body (exprs
, env
);
1901 SCM_SYNTAX (s_undefine
, "undefine", scm_makacro
, scm_m_undefine
);
1904 scm_m_undefine (SCM expr
, SCM env
)
1909 const SCM cdr_expr
= SCM_CDR (expr
);
1910 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), "Bad undefine placement in", expr
);
1911 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1912 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1914 variable
= SCM_CAR (cdr_expr
);
1915 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
), s_bad_variable
, variable
, expr
);
1916 location
= scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_F
);
1917 ASSERT_SYNTAX_2 (!SCM_FALSEP (location
)
1918 && !SCM_UNBNDP (SCM_VARIABLE_REF (location
)),
1919 "variable already unbound ", variable
, expr
);
1920 SCM_VARIABLE_SET (location
, SCM_UNDEFINED
);
1921 return SCM_UNSPECIFIED
;
1926 scm_macroexp (SCM x
, SCM env
)
1928 SCM res
, proc
, orig_sym
;
1930 /* Don't bother to produce error messages here. We get them when we
1931 eventually execute the code for real. */
1934 orig_sym
= SCM_CAR (x
);
1935 if (!SCM_SYMBOLP (orig_sym
))
1939 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1940 if (proc_ptr
== NULL
)
1942 /* We have lost the race. */
1948 /* Only handle memoizing macros. `Acros' and `macros' are really
1949 special forms and should not be evaluated here. */
1951 if (!SCM_MACROP (proc
)
1952 || (SCM_MACRO_TYPE (proc
) != 2 && !SCM_BUILTIN_MACRO_P (proc
)))
1955 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
1956 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
1958 if (scm_ilength (res
) <= 0)
1959 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
1962 SCM_SETCAR (x
, SCM_CAR (res
));
1963 SCM_SETCDR (x
, SCM_CDR (res
));
1971 /*****************************************************************************/
1972 /*****************************************************************************/
1973 /* The definitions for unmemoization start here. */
1974 /*****************************************************************************/
1975 /*****************************************************************************/
1977 #define SCM_BIT7(x) (127 & SCM_UNPACK (x))
1979 SCM_SYMBOL (sym_three_question_marks
, "???");
1982 /* scm_unmemocopy takes a memoized expression together with its
1983 * environment and rewrites it to its original form. Thus, it is the
1984 * inversion of the rewrite rules above. The procedure is not
1985 * optimized for speed. It's used in scm_iprin1 when printing the
1986 * code of a closure, in scm_procedure_source, in display_frame when
1987 * generating the source for a stackframe in a backtrace, and in
1988 * display_expression.
1990 * Unmemoizing is not a reliable process. You cannot in general
1991 * expect to get the original source back.
1993 * However, GOOPS currently relies on this for method compilation.
1994 * This ought to change.
1998 build_binding_list (SCM rnames
, SCM rinits
)
2000 SCM bindings
= SCM_EOL
;
2001 while (!SCM_NULLP (rnames
))
2003 SCM binding
= scm_list_2 (SCM_CAR (rnames
), SCM_CAR (rinits
));
2004 bindings
= scm_cons (binding
, bindings
);
2005 rnames
= SCM_CDR (rnames
);
2006 rinits
= SCM_CDR (rinits
);
2013 unmemocar (SCM form
, SCM env
)
2015 if (!SCM_CONSP (form
))
2019 SCM c
= SCM_CAR (form
);
2020 if (SCM_VARIABLEP (c
))
2022 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
2023 if (SCM_FALSEP (sym
))
2024 sym
= sym_three_question_marks
;
2025 SCM_SETCAR (form
, sym
);
2027 else if (SCM_ILOCP (c
))
2029 unsigned long int ir
;
2031 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
2032 env
= SCM_CDR (env
);
2033 env
= SCM_CAAR (env
);
2034 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
2035 env
= SCM_CDR (env
);
2037 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
2045 scm_unmemocopy (SCM x
, SCM env
)
2050 if (SCM_VECTORP (x
))
2052 return scm_list_2 (scm_sym_quote
, x
);
2054 else if (!SCM_CONSP (x
))
2057 p
= scm_whash_lookup (scm_source_whash
, x
);
2058 if (SCM_ISYMP (SCM_CAR (x
)))
2060 switch (ISYMNUM (SCM_CAR (x
)))
2062 case (ISYMNUM (SCM_IM_AND
)):
2063 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
2065 case (ISYMNUM (SCM_IM_BEGIN
)):
2066 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
2068 case (ISYMNUM (SCM_IM_CASE
)):
2069 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
2071 case (ISYMNUM (SCM_IM_COND
)):
2072 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
2074 case (ISYMNUM (SCM_IM_DO
)):
2076 /* format: (#@do (i1 ... ik) (nk ... n1) (test) (body) s1 ... sk),
2077 * where ix is an initializer for a local variable, nx is the name
2078 * of the local variable, test is the test clause of the do loop,
2079 * body is the body of the do loop and sx are the step clauses for
2080 * the local variables. */
2081 SCM names
, inits
, test
, memoized_body
, steps
, bindings
;
2084 inits
= scm_reverse (scm_unmemocopy (SCM_CAR (x
), env
));
2086 names
= SCM_CAR (x
);
2087 env
= SCM_EXTEND_ENV (names
, SCM_EOL
, env
);
2089 test
= scm_unmemocopy (SCM_CAR (x
), env
);
2091 memoized_body
= SCM_CAR (x
);
2093 steps
= scm_reverse (scm_unmemocopy (x
, env
));
2095 /* build transformed binding list */
2097 while (!SCM_NULLP (names
))
2099 SCM name
= SCM_CAR (names
);
2100 SCM init
= SCM_CAR (inits
);
2101 SCM step
= SCM_CAR (steps
);
2102 step
= SCM_EQ_P (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
2104 bindings
= scm_cons (scm_cons2 (name
, init
, step
), bindings
);
2106 names
= SCM_CDR (names
);
2107 inits
= SCM_CDR (inits
);
2108 steps
= SCM_CDR (steps
);
2110 z
= scm_cons (test
, SCM_UNSPECIFIED
);
2111 ls
= scm_cons2 (scm_sym_do
, bindings
, z
);
2113 x
= scm_cons (SCM_BOOL_F
, memoized_body
);
2116 case (ISYMNUM (SCM_IM_IF
)):
2117 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
2119 case (ISYMNUM (SCM_IM_LET
)):
2121 /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),
2122 * where nx is the name of a local variable, ix is an initializer
2123 * for the local variable and by are the body clauses. */
2124 SCM rnames
, rinits
, bindings
;
2127 rnames
= SCM_CAR (x
);
2129 rinits
= scm_reverse (scm_unmemocopy (SCM_CAR (x
), env
));
2130 env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
2132 bindings
= build_binding_list (rnames
, rinits
);
2133 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
2134 ls
= scm_cons (scm_sym_let
, z
);
2137 case (ISYMNUM (SCM_IM_LETREC
)):
2139 /* format: (#@letrec (vn ... v2 v1) (i1 i2 ... in) b1 ...),
2140 * where vx is the name of a local variable, ix is an initializer
2141 * for the local variable and by are the body clauses. */
2142 SCM rnames
, rinits
, bindings
;
2145 rnames
= SCM_CAR (x
);
2146 env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
2148 rinits
= scm_reverse (scm_unmemocopy (SCM_CAR (x
), env
));
2150 bindings
= build_binding_list (rnames
, rinits
);
2151 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
2152 ls
= scm_cons (scm_sym_letrec
, z
);
2155 case (ISYMNUM (SCM_IM_LETSTAR
)):
2163 env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2167 SCM copy
= scm_unmemocopy (SCM_CADR (b
), env
);
2168 SCM initializer
= unmemocar (scm_list_1 (copy
), env
);
2169 y
= z
= scm_acons (SCM_CAR (b
), initializer
, SCM_UNSPECIFIED
);
2170 env
= SCM_EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
2174 SCM_SETCDR (y
, SCM_EOL
);
2175 z
= scm_cons (y
, SCM_UNSPECIFIED
);
2176 ls
= scm_cons (scm_sym_let
, z
);
2181 copy
= scm_unmemocopy (SCM_CADR (b
), env
);
2182 initializer
= unmemocar (scm_list_1 (copy
), env
);
2183 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
2187 env
= SCM_EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
2190 while (!SCM_NULLP (b
));
2191 SCM_SETCDR (z
, SCM_EOL
);
2193 z
= scm_cons (y
, SCM_UNSPECIFIED
);
2194 ls
= scm_cons (scm_sym_letstar
, z
);
2197 case (ISYMNUM (SCM_IM_OR
)):
2198 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
2200 case (ISYMNUM (SCM_IM_LAMBDA
)):
2202 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
);
2203 ls
= scm_cons (scm_sym_lambda
, z
);
2204 env
= SCM_EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
2207 case (ISYMNUM (SCM_IM_QUOTE
)):
2208 return unmemoize_quote (x
, env
);
2210 case (ISYMNUM (SCM_IM_SET_X
)):
2211 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
2213 case (ISYMNUM (SCM_IM_APPLY
)):
2214 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
2216 case (ISYMNUM (SCM_IM_CONT
)):
2217 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
2219 case (ISYMNUM (SCM_IM_DELAY
)):
2220 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
2223 case (ISYMNUM (SCM_IM_FUTURE
)):
2224 ls
= z
= scm_cons (scm_sym_future
, SCM_UNSPECIFIED
);
2227 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2228 ls
= z
= scm_cons (scm_sym_at_call_with_values
, SCM_UNSPECIFIED
);
2230 case (ISYMNUM (SCM_IM_ELSE
)):
2231 ls
= z
= scm_cons (scm_sym_else
, SCM_UNSPECIFIED
);
2234 ls
= z
= unmemocar (scm_cons (scm_unmemocopy (SCM_CAR (x
), env
),
2241 ls
= z
= unmemocar (scm_cons (scm_unmemocopy (SCM_CAR (x
), env
),
2247 while (SCM_CONSP (x
))
2249 SCM form
= SCM_CAR (x
);
2250 if (!SCM_ISYMP (form
))
2252 SCM copy
= scm_cons (scm_unmemocopy (form
, env
), SCM_UNSPECIFIED
);
2253 SCM_SETCDR (z
, unmemocar (copy
, env
));
2256 else if (SCM_EQ_P (form
, SCM_IM_ARROW
))
2258 SCM_SETCDR (z
, scm_cons (scm_sym_arrow
, SCM_UNSPECIFIED
));
2264 if (!SCM_FALSEP (p
))
2265 scm_whash_insert (scm_source_whash
, ls
, p
);
2270 #if (SCM_ENABLE_DEPRECATED == 1)
2273 scm_unmemocar (SCM form
, SCM env
)
2275 return unmemocar (form
, env
);
2280 /*****************************************************************************/
2281 /*****************************************************************************/
2282 /* The definitions for execution start here. */
2283 /*****************************************************************************/
2284 /*****************************************************************************/
2286 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
2287 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
2288 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
2289 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
2291 /* A function object to implement "apply" for non-closure functions. */
2293 /* An endless list consisting of #<undefined> objects: */
2294 static SCM undefineds
;
2298 scm_badargsp (SCM formals
, SCM args
)
2300 while (!SCM_NULLP (formals
))
2302 if (!SCM_CONSP (formals
))
2304 if (SCM_NULLP (args
))
2306 formals
= SCM_CDR (formals
);
2307 args
= SCM_CDR (args
);
2309 return !SCM_NULLP (args
) ? 1 : 0;
2314 /* The evaluator contains a plethora of EVAL symbols. This is an attempt at
2317 * The following macros should be used in code which is read twice (where the
2318 * choice of evaluator is hard soldered):
2320 * CEVAL is the symbol used within one evaluator to call itself.
2321 * Originally, it is defined to ceval, but is redefined to deval during the
2324 * SCM_EVALIM is used when it is known that the expression is an
2325 * immediate. (This macro never calls an evaluator.)
2327 * EVAL evaluates an expression that is expected to have its symbols already
2328 * memoized. Expressions that are not of the form '(<form> <form> ...)' are
2329 * evaluated inline without calling an evaluator.
2331 * EVALCAR evaluates the car of an expression 'X:(Y:<form> <form> ...)',
2332 * potentially replacing a symbol at the position Y:<form> by its memoized
2333 * variable. If Y:<form> is not of the form '(<form> <form> ...)', the
2334 * evaluation is performed inline without calling an evaluator.
2336 * The following macros should be used in code which is read once
2337 * (where the choice of evaluator is dynamic):
2339 * SCM_XEVAL corresponds to EVAL, but uses ceval *or* deval depending on the
2342 * SCM_XEVALCAR corresponds to EVALCAR, but uses ceval *or* deval depending
2343 * on the debugging mode.
2345 * The main motivation for keeping this plethora is efficiency
2346 * together with maintainability (=> locality of code).
2349 static SCM
ceval (SCM x
, SCM env
);
2350 static SCM
deval (SCM x
, SCM env
);
2354 #define SCM_EVALIM2(x) \
2355 ((SCM_EQ_P ((x), SCM_EOL) \
2356 ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \
2360 #define SCM_EVALIM(x, env) (SCM_ILOCP (x) \
2361 ? *scm_ilookup ((x), (env)) \
2364 #define SCM_XEVAL(x, env) \
2367 : (SCM_VARIABLEP (x) \
2368 ? SCM_VARIABLE_REF (x) \
2370 ? (scm_debug_mode_p \
2371 ? deval ((x), (env)) \
2372 : ceval ((x), (env))) \
2375 #define SCM_XEVALCAR(x, env) \
2376 (SCM_IMP (SCM_CAR (x)) \
2377 ? SCM_EVALIM (SCM_CAR (x), (env)) \
2378 : (SCM_VARIABLEP (SCM_CAR (x)) \
2379 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2380 : (SCM_CONSP (SCM_CAR (x)) \
2381 ? (scm_debug_mode_p \
2382 ? deval (SCM_CAR (x), (env)) \
2383 : ceval (SCM_CAR (x), (env))) \
2384 : (!SCM_SYMBOLP (SCM_CAR (x)) \
2386 : *scm_lookupcar ((x), (env), 1)))))
2388 #define EVAL(x, env) \
2390 ? SCM_EVALIM ((x), (env)) \
2391 : (SCM_VARIABLEP (x) \
2392 ? SCM_VARIABLE_REF (x) \
2394 ? CEVAL ((x), (env)) \
2397 #define EVALCAR(x, env) \
2398 (SCM_IMP (SCM_CAR (x)) \
2399 ? SCM_EVALIM (SCM_CAR (x), (env)) \
2400 : (SCM_VARIABLEP (SCM_CAR (x)) \
2401 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2402 : (SCM_CONSP (SCM_CAR (x)) \
2403 ? CEVAL (SCM_CAR (x), (env)) \
2404 : (!SCM_SYMBOLP (SCM_CAR (x)) \
2406 : *scm_lookupcar ((x), (env), 1)))))
2408 SCM_REC_MUTEX (source_mutex
);
2411 /* Lookup a given local variable in an environment. The local variable is
2412 * given as an iloc, that is a triple <frame, binding, last?>, where frame
2413 * indicates the relative number of the environment frame (counting upwards
2414 * from the innermost environment frame), binding indicates the number of the
2415 * binding within the frame, and last? (which is extracted from the iloc using
2416 * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
2417 * very end of the improper list of bindings. */
2419 scm_ilookup (SCM iloc
, SCM env
)
2421 unsigned int frame_nr
= SCM_IFRAME (iloc
);
2422 unsigned int binding_nr
= SCM_IDIST (iloc
);
2426 for (; 0 != frame_nr
; --frame_nr
)
2427 frames
= SCM_CDR (frames
);
2429 bindings
= SCM_CAR (frames
);
2430 for (; 0 != binding_nr
; --binding_nr
)
2431 bindings
= SCM_CDR (bindings
);
2433 if (SCM_ICDRP (iloc
))
2434 return SCM_CDRLOC (bindings
);
2435 return SCM_CARLOC (SCM_CDR (bindings
));
2439 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
2441 static void error_unbound_variable (SCM symbol
) SCM_NORETURN
;
2443 error_unbound_variable (SCM symbol
)
2445 scm_error (scm_unbound_variable_key
, NULL
,
2446 "Unbound variable: ~S",
2447 scm_list_1 (symbol
), SCM_BOOL_F
);
2451 /* The Lookup Car Race
2454 Memoization of variables and special forms is done while executing
2455 the code for the first time. As long as there is only one thread
2456 everything is fine, but as soon as two threads execute the same
2457 code concurrently `for the first time' they can come into conflict.
2459 This memoization includes rewriting variable references into more
2460 efficient forms and expanding macros. Furthermore, macro expansion
2461 includes `compiling' special forms like `let', `cond', etc. into
2462 tree-code instructions.
2464 There shouldn't normally be a problem with memoizing local and
2465 global variable references (into ilocs and variables), because all
2466 threads will mutate the code in *exactly* the same way and (if I
2467 read the C code correctly) it is not possible to observe a half-way
2468 mutated cons cell. The lookup procedure can handle this
2469 transparently without any critical sections.
2471 It is different with macro expansion, because macro expansion
2472 happens outside of the lookup procedure and can't be
2473 undone. Therefore the lookup procedure can't cope with it. It has
2474 to indicate failure when it detects a lost race and hope that the
2475 caller can handle it. Luckily, it turns out that this is the case.
2477 An example to illustrate this: Suppose that the following form will
2478 be memoized concurrently by two threads
2482 Let's first examine the lookup of X in the body. The first thread
2483 decides that it has to find the symbol "x" in the environment and
2484 starts to scan it. Then the other thread takes over and actually
2485 overtakes the first. It looks up "x" and substitutes an
2486 appropriate iloc for it. Now the first thread continues and
2487 completes its lookup. It comes to exactly the same conclusions as
2488 the second one and could - without much ado - just overwrite the
2489 iloc with the same iloc.
2491 But let's see what will happen when the race occurs while looking
2492 up the symbol "let" at the start of the form. It could happen that
2493 the second thread interrupts the lookup of the first thread and not
2494 only substitutes a variable for it but goes right ahead and
2495 replaces it with the compiled form (#@let* (x 12) x). Now, when
2496 the first thread completes its lookup, it would replace the #@let*
2497 with a variable containing the "let" binding, effectively reverting
2498 the form to (let (x 12) x). This is wrong. It has to detect that
2499 it has lost the race and the evaluator has to reconsider the
2500 changed form completely.
2502 This race condition could be resolved with some kind of traffic
2503 light (like mutexes) around scm_lookupcar, but I think that it is
2504 best to avoid them in this case. They would serialize memoization
2505 completely and because lookup involves calling arbitrary Scheme
2506 code (via the lookup-thunk), threads could be blocked for an
2507 arbitrary amount of time or even deadlock. But with the current
2508 solution a lot of unnecessary work is potentially done. */
2510 /* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
2511 return NULL to indicate a failed lookup due to some race conditions
2512 between threads. This only happens when VLOC is the first cell of
2513 a special form that will eventually be memoized (like `let', etc.)
2514 In that case the whole lookup is bogus and the caller has to
2515 reconsider the complete special form.
2517 SCM_LOOKUPCAR is still there, of course. It just calls
2518 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
2519 should only be called when it is known that VLOC is not the first
2520 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
2521 for NULL. I think I've found the only places where this
2525 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
2528 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
2529 register SCM iloc
= SCM_ILOC00
;
2530 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
2532 if (!SCM_CONSP (SCM_CAR (env
)))
2534 al
= SCM_CARLOC (env
);
2535 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
2537 if (!SCM_CONSP (fl
))
2539 if (SCM_EQ_P (fl
, var
))
2541 if (! SCM_EQ_P (SCM_CAR (vloc
), var
))
2543 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
2544 return SCM_CDRLOC (*al
);
2549 al
= SCM_CDRLOC (*al
);
2550 if (SCM_EQ_P (SCM_CAR (fl
), var
))
2552 if (SCM_UNBNDP (SCM_CAR (*al
)))
2557 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
2559 SCM_SETCAR (vloc
, iloc
);
2560 return SCM_CARLOC (*al
);
2562 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
2564 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
2567 SCM top_thunk
, real_var
;
2570 top_thunk
= SCM_CAR (env
); /* env now refers to a
2571 top level env thunk */
2572 env
= SCM_CDR (env
);
2575 top_thunk
= SCM_BOOL_F
;
2576 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
2577 if (SCM_FALSEP (real_var
))
2580 if (!SCM_NULLP (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
2585 if (SCM_NULLP (env
))
2586 error_unbound_variable (var
);
2588 scm_misc_error (NULL
, "Damaged environment: ~S",
2593 /* A variable could not be found, but we shall
2594 not throw an error. */
2595 static SCM undef_object
= SCM_UNDEFINED
;
2596 return &undef_object
;
2600 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
2602 /* Some other thread has changed the very cell we are working
2603 on. In effect, it must have done our job or messed it up
2606 var
= SCM_CAR (vloc
);
2607 if (SCM_VARIABLEP (var
))
2608 return SCM_VARIABLE_LOC (var
);
2609 if (SCM_ILOCP (var
))
2610 return scm_ilookup (var
, genv
);
2611 /* We can't cope with anything else than variables and ilocs. When
2612 a special form has been memoized (i.e. `let' into `#@let') we
2613 return NULL and expect the calling function to do the right
2614 thing. For the evaluator, this means going back and redoing
2615 the dispatch on the car of the form. */
2619 SCM_SETCAR (vloc
, real_var
);
2620 return SCM_VARIABLE_LOC (real_var
);
2625 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
2627 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
2634 /* During execution, look up a symbol in the top level of the given local
2635 * environment and return the corresponding variable object. If no binding
2636 * for the symbol can be found, an 'Unbound variable' error is signalled. */
2638 lazy_memoize_variable (const SCM symbol
, const SCM environment
)
2640 const SCM top_level
= scm_env_top_level (environment
);
2641 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
2643 if (SCM_FALSEP (variable
))
2644 error_unbound_variable (symbol
);
2651 scm_eval_car (SCM pair
, SCM env
)
2653 return SCM_XEVALCAR (pair
, env
);
2658 scm_eval_args (SCM l
, SCM env
, SCM proc
)
2660 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
2661 while (SCM_CONSP (l
))
2663 res
= EVALCAR (l
, env
);
2665 *lloc
= scm_list_1 (res
);
2666 lloc
= SCM_CDRLOC (*lloc
);
2670 scm_wrong_num_args (proc
);
2676 scm_eval_body (SCM code
, SCM env
)
2681 next
= SCM_CDR (code
);
2682 while (!SCM_NULLP (next
))
2684 if (SCM_IMP (SCM_CAR (code
)))
2686 if (SCM_ISYMP (SCM_CAR (code
)))
2688 scm_rec_mutex_lock (&source_mutex
);
2689 /* check for race condition */
2690 if (SCM_ISYMP (SCM_CAR (code
)))
2691 m_expand_body (code
, env
);
2692 scm_rec_mutex_unlock (&source_mutex
);
2697 SCM_XEVAL (SCM_CAR (code
), env
);
2699 next
= SCM_CDR (code
);
2701 return SCM_XEVALCAR (code
, env
);
2707 /* SECTION: This code is specific for the debugging support. One
2708 * branch is read when DEVAL isn't defined, the other when DEVAL is
2714 #define SCM_APPLY scm_apply
2715 #define PREP_APPLY(proc, args)
2717 #define RETURN(x) do { return x; } while (0)
2718 #ifdef STACK_CHECKING
2719 #ifndef NO_CEVAL_STACK_CHECKING
2720 #define EVAL_STACK_CHECKING
2727 #define CEVAL deval /* Substitute all uses of ceval */
2730 #define SCM_APPLY scm_dapply
2733 #define PREP_APPLY(p, l) \
2734 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
2737 #define ENTER_APPLY \
2739 SCM_SET_ARGSREADY (debug);\
2740 if (scm_check_apply_p && SCM_TRAPS_P)\
2741 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
2743 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
2744 SCM_SET_TRACED_FRAME (debug); \
2746 if (SCM_CHEAPTRAPS_P)\
2748 tmp = scm_make_debugobj (&debug);\
2749 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
2754 tmp = scm_make_continuation (&first);\
2756 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
2763 #define RETURN(e) do { proc = (e); goto exit; } while (0)
2765 #ifdef STACK_CHECKING
2766 #ifndef EVAL_STACK_CHECKING
2767 #define EVAL_STACK_CHECKING
2772 /* scm_last_debug_frame contains a pointer to the last debugging information
2773 * stack frame. It is accessed very often from the debugging evaluator, so it
2774 * should probably not be indirectly addressed. Better to save and restore it
2775 * from the current root at any stack swaps.
2778 /* scm_debug_eframe_size is the number of slots available for pseudo
2779 * stack frames at each real stack frame.
2782 long scm_debug_eframe_size
;
2784 int scm_debug_mode_p
;
2785 int scm_check_entry_p
;
2786 int scm_check_apply_p
;
2787 int scm_check_exit_p
;
2789 long scm_eval_stack
;
2791 scm_t_option scm_eval_opts
[] = {
2792 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
2795 scm_t_option scm_debug_opts
[] = {
2796 { SCM_OPTION_BOOLEAN
, "cheap", 1,
2797 "*Flyweight representation of the stack at traps." },
2798 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
2799 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
2800 { SCM_OPTION_BOOLEAN
, "procnames", 1,
2801 "Record procedure names at definition." },
2802 { SCM_OPTION_BOOLEAN
, "backwards", 0,
2803 "Display backtrace in anti-chronological order." },
2804 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
2805 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
2806 { SCM_OPTION_INTEGER
, "frames", 3,
2807 "Maximum number of tail-recursive frames in backtrace." },
2808 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
2809 "Maximal number of stored backtrace frames." },
2810 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
2811 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
2812 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
2813 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
2814 { 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."}
2817 scm_t_option scm_evaluator_trap_table
[] = {
2818 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
2819 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
2820 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
2821 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
2822 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
2823 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
2824 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
2827 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
2829 "Option interface for the evaluation options. Instead of using\n"
2830 "this procedure directly, use the procedures @code{eval-enable},\n"
2831 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
2832 #define FUNC_NAME s_scm_eval_options_interface
2836 ans
= scm_options (setting
,
2840 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
2847 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
2849 "Option interface for the evaluator trap options.")
2850 #define FUNC_NAME s_scm_evaluator_traps
2854 ans
= scm_options (setting
,
2855 scm_evaluator_trap_table
,
2856 SCM_N_EVALUATOR_TRAPS
,
2858 SCM_RESET_DEBUG_MODE
;
2866 deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
2868 SCM
*results
= lloc
;
2869 while (SCM_CONSP (l
))
2871 const SCM res
= EVALCAR (l
, env
);
2873 *lloc
= scm_list_1 (res
);
2874 lloc
= SCM_CDRLOC (*lloc
);
2878 scm_wrong_num_args (proc
);
2885 /* SECTION: This code is compiled twice.
2889 /* Update the toplevel environment frame ENV so that it refers to the
2890 * current module. */
2891 #define UPDATE_TOPLEVEL_ENV(env) \
2893 SCM p = scm_current_module_lookup_closure (); \
2894 if (p != SCM_CAR (env)) \
2895 env = scm_top_level_env (p); \
2899 #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
2900 ASSERT_SYNTAX (!SCM_EQ_P ((x), SCM_EOL), s_empty_combination, x)
2903 /* This is the evaluator. Like any real monster, it has three heads:
2905 * ceval is the non-debugging evaluator, deval is the debugging version. Both
2906 * are implemented using a common code base, using the following mechanism:
2907 * CEVAL is a macro, which is either defined to ceval or deval. Thus, there
2908 * is no function CEVAL, but the code for CEVAL actually compiles to either
2909 * ceval or deval. When CEVAL is defined to ceval, it is known that the macro
2910 * DEVAL is not defined. When CEVAL is defined to deval, then the macro DEVAL
2911 * is known to be defined. Thus, in CEVAL parts for the debugging evaluator
2912 * are enclosed within #ifdef DEVAL ... #endif.
2914 * All three (ceval, deval and their common implementation CEVAL) take two
2915 * input parameters, x and env: x is a single expression to be evalutated.
2916 * env is the environment in which bindings are searched.
2918 * x is known to be a pair. Since x is a single expression, it is necessarily
2919 * in a tail position. If x is just a call to another function like in the
2920 * expression (foo exp1 exp2 ...), the realization of that call therefore
2921 * _must_not_ increase stack usage (the evaluation of exp1, exp2 etc.,
2922 * however, may do so). This is realized by making extensive use of 'goto'
2923 * statements within the evaluator: The gotos replace recursive calls to
2924 * CEVAL, thus re-using the same stack frame that CEVAL was already using.
2925 * If, however, x represents some form that requires to evaluate a sequence of
2926 * expressions like (begin exp1 exp2 ...), then recursive calls to CEVAL are
2927 * performed for all but the last expression of that sequence. */
2930 CEVAL (SCM x
, SCM env
)
2934 scm_t_debug_frame debug
;
2935 scm_t_debug_info
*debug_info_end
;
2936 debug
.prev
= scm_last_debug_frame
;
2939 * The debug.vect contains twice as much scm_t_debug_info frames as the
2940 * user has specified with (debug-set! frames <n>).
2942 * Even frames are eval frames, odd frames are apply frames.
2944 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
2945 * sizeof (scm_t_debug_info
));
2946 debug
.info
= debug
.vect
;
2947 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
2948 scm_last_debug_frame
= &debug
;
2950 #ifdef EVAL_STACK_CHECKING
2951 if (scm_stack_checking_enabled_p
&& SCM_STACK_OVERFLOW_P (&proc
))
2954 debug
.info
->e
.exp
= x
;
2955 debug
.info
->e
.env
= env
;
2957 scm_report_stack_overflow ();
2967 SCM_CLEAR_ARGSREADY (debug
);
2968 if (SCM_OVERFLOWP (debug
))
2971 * In theory, this should be the only place where it is necessary to
2972 * check for space in debug.vect since both eval frames and
2973 * available space are even.
2975 * For this to be the case, however, it is necessary that primitive
2976 * special forms which jump back to `loop', `begin' or some similar
2977 * label call PREP_APPLY.
2979 else if (++debug
.info
>= debug_info_end
)
2981 SCM_SET_OVERFLOW (debug
);
2986 debug
.info
->e
.exp
= x
;
2987 debug
.info
->e
.env
= env
;
2988 if (scm_check_entry_p
&& SCM_TRAPS_P
)
2990 if (SCM_ENTER_FRAME_P
2991 || (SCM_BREAKPOINTS_P
&& scm_c_source_property_breakpoint_p (x
)))
2994 SCM tail
= SCM_BOOL (SCM_TAILRECP (debug
));
2995 SCM_SET_TAILREC (debug
);
2996 if (SCM_CHEAPTRAPS_P
)
2997 stackrep
= scm_make_debugobj (&debug
);
3001 SCM val
= scm_make_continuation (&first
);
3011 /* This gives the possibility for the debugger to
3012 modify the source expression before evaluation. */
3017 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
3018 scm_sym_enter_frame
,
3021 scm_unmemocopy (x
, env
));
3028 if (SCM_ISYMP (SCM_CAR (x
)))
3030 switch (ISYMNUM (SCM_CAR (x
)))
3032 case (ISYMNUM (SCM_IM_AND
)):
3034 while (!SCM_NULLP (SCM_CDR (x
)))
3036 SCM test_result
= EVALCAR (x
, env
);
3037 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
3038 RETURN (SCM_BOOL_F
);
3042 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3045 case (ISYMNUM (SCM_IM_BEGIN
)):
3048 RETURN (SCM_UNSPECIFIED
);
3050 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3053 /* If we are on toplevel with a lookup closure, we need to sync
3054 with the current module. */
3055 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
3057 UPDATE_TOPLEVEL_ENV (env
);
3058 while (!SCM_NULLP (SCM_CDR (x
)))
3061 UPDATE_TOPLEVEL_ENV (env
);
3067 goto nontoplevel_begin
;
3070 while (!SCM_NULLP (SCM_CDR (x
)))
3072 const SCM form
= SCM_CAR (x
);
3075 if (SCM_ISYMP (form
))
3077 scm_rec_mutex_lock (&source_mutex
);
3078 /* check for race condition */
3079 if (SCM_ISYMP (SCM_CAR (x
)))
3080 m_expand_body (x
, env
);
3081 scm_rec_mutex_unlock (&source_mutex
);
3082 goto nontoplevel_begin
;
3085 SCM_VALIDATE_NON_EMPTY_COMBINATION (form
);
3088 (void) EVAL (form
, env
);
3094 /* scm_eval last form in list */
3095 const SCM last_form
= SCM_CAR (x
);
3097 if (SCM_CONSP (last_form
))
3099 /* This is by far the most frequent case. */
3101 goto loop
; /* tail recurse */
3103 else if (SCM_IMP (last_form
))
3104 RETURN (SCM_EVALIM (last_form
, env
));
3105 else if (SCM_VARIABLEP (last_form
))
3106 RETURN (SCM_VARIABLE_REF (last_form
));
3107 else if (SCM_SYMBOLP (last_form
))
3108 RETURN (*scm_lookupcar (x
, env
, 1));
3114 case (ISYMNUM (SCM_IM_CASE
)):
3117 const SCM key
= EVALCAR (x
, env
);
3119 while (!SCM_NULLP (x
))
3121 const SCM clause
= SCM_CAR (x
);
3122 SCM labels
= SCM_CAR (clause
);
3123 if (SCM_EQ_P (labels
, SCM_IM_ELSE
))
3125 x
= SCM_CDR (clause
);
3126 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3129 while (!SCM_NULLP (labels
))
3131 const SCM label
= SCM_CAR (labels
);
3132 if (SCM_EQ_P (label
, key
)
3133 || !SCM_FALSEP (scm_eqv_p (label
, key
)))
3135 x
= SCM_CDR (clause
);
3136 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3139 labels
= SCM_CDR (labels
);
3144 RETURN (SCM_UNSPECIFIED
);
3147 case (ISYMNUM (SCM_IM_COND
)):
3149 while (!SCM_NULLP (x
))
3151 const SCM clause
= SCM_CAR (x
);
3152 if (SCM_EQ_P (SCM_CAR (clause
), SCM_IM_ELSE
))
3154 x
= SCM_CDR (clause
);
3155 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3160 arg1
= EVALCAR (clause
, env
);
3161 if (!SCM_FALSEP (arg1
) && !SCM_NILP (arg1
))
3163 x
= SCM_CDR (clause
);
3166 else if (!SCM_EQ_P (SCM_CAR (x
), SCM_IM_ARROW
))
3168 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3174 proc
= EVALCAR (proc
, env
);
3175 PREP_APPLY (proc
, scm_list_1 (arg1
));
3183 RETURN (SCM_UNSPECIFIED
);
3186 case (ISYMNUM (SCM_IM_DO
)):
3189 /* Compute the initialization values and the initial environment. */
3190 SCM init_forms
= SCM_CAR (x
);
3191 SCM init_values
= SCM_EOL
;
3192 while (!SCM_NULLP (init_forms
))
3194 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3195 init_forms
= SCM_CDR (init_forms
);
3198 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
3202 SCM test_form
= SCM_CAR (x
);
3203 SCM body_forms
= SCM_CADR (x
);
3204 SCM step_forms
= SCM_CDDR (x
);
3206 SCM test_result
= EVALCAR (test_form
, env
);
3208 while (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
3211 /* Evaluate body forms. */
3213 for (temp_forms
= body_forms
;
3214 !SCM_NULLP (temp_forms
);
3215 temp_forms
= SCM_CDR (temp_forms
))
3217 SCM form
= SCM_CAR (temp_forms
);
3218 /* Dirk:FIXME: We only need to eval forms that may have
3219 * a side effect here. This is only true for forms that
3220 * start with a pair. All others are just constants.
3221 * Since with the current memoizer 'form' may hold a
3222 * constant, we call EVAL here to handle the constant
3223 * cases. In the long run it would make sense to have
3224 * the macro transformer of 'do' eliminate all forms
3225 * that have no sideeffect. Then instead of EVAL we
3226 * could call CEVAL directly here. */
3227 (void) EVAL (form
, env
);
3232 /* Evaluate the step expressions. */
3234 SCM step_values
= SCM_EOL
;
3235 for (temp_forms
= step_forms
;
3236 !SCM_NULLP (temp_forms
);
3237 temp_forms
= SCM_CDR (temp_forms
))
3239 const SCM value
= EVALCAR (temp_forms
, env
);
3240 step_values
= scm_cons (value
, step_values
);
3242 env
= SCM_EXTEND_ENV (SCM_CAAR (env
),
3247 test_result
= EVALCAR (test_form
, env
);
3252 RETURN (SCM_UNSPECIFIED
);
3253 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3254 goto nontoplevel_begin
;
3257 case (ISYMNUM (SCM_IM_IF
)):
3260 SCM test_result
= EVALCAR (x
, env
);
3261 x
= SCM_CDR (x
); /* then expression */
3262 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
3264 x
= SCM_CDR (x
); /* else expression */
3266 RETURN (SCM_UNSPECIFIED
);
3269 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3273 case (ISYMNUM (SCM_IM_LET
)):
3276 SCM init_forms
= SCM_CADR (x
);
3277 SCM init_values
= SCM_EOL
;
3280 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3281 init_forms
= SCM_CDR (init_forms
);
3283 while (!SCM_NULLP (init_forms
));
3284 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
3287 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3288 goto nontoplevel_begin
;
3291 case (ISYMNUM (SCM_IM_LETREC
)):
3293 env
= SCM_EXTEND_ENV (SCM_CAR (x
), undefineds
, env
);
3296 SCM init_forms
= SCM_CAR (x
);
3297 SCM init_values
= SCM_EOL
;
3300 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3301 init_forms
= SCM_CDR (init_forms
);
3303 while (!SCM_NULLP (init_forms
));
3304 SCM_SETCDR (SCM_CAR (env
), init_values
);
3307 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3308 goto nontoplevel_begin
;
3311 case (ISYMNUM (SCM_IM_LETSTAR
)):
3314 SCM bindings
= SCM_CAR (x
);
3315 if (SCM_NULLP (bindings
))
3316 env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
3321 SCM name
= SCM_CAR (bindings
);
3322 SCM init
= SCM_CDR (bindings
);
3323 env
= SCM_EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
3324 bindings
= SCM_CDR (init
);
3326 while (!SCM_NULLP (bindings
));
3330 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3331 goto nontoplevel_begin
;
3334 case (ISYMNUM (SCM_IM_OR
)):
3336 while (!SCM_NULLP (SCM_CDR (x
)))
3338 SCM val
= EVALCAR (x
, env
);
3339 if (!SCM_FALSEP (val
) && !SCM_NILP (val
))
3344 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3348 case (ISYMNUM (SCM_IM_LAMBDA
)):
3349 RETURN (scm_closure (SCM_CDR (x
), env
));
3352 case (ISYMNUM (SCM_IM_QUOTE
)):
3353 RETURN (SCM_CDR (x
));
3356 case (ISYMNUM (SCM_IM_SET_X
)):
3360 SCM variable
= SCM_CAR (x
);
3361 if (SCM_ILOCP (variable
))
3362 location
= scm_ilookup (variable
, env
);
3363 else if (SCM_VARIABLEP (variable
))
3364 location
= SCM_VARIABLE_LOC (variable
);
3367 /* (SCM_SYMBOLP (variable)) is known to be true */
3368 variable
= lazy_memoize_variable (variable
, env
);
3369 SCM_SETCAR (x
, variable
);
3370 location
= SCM_VARIABLE_LOC (variable
);
3373 *location
= EVALCAR (x
, env
);
3375 RETURN (SCM_UNSPECIFIED
);
3378 case (ISYMNUM (SCM_IM_APPLY
)):
3379 /* Evaluate the procedure to be applied. */
3381 proc
= EVALCAR (x
, env
);
3382 PREP_APPLY (proc
, SCM_EOL
);
3384 /* Evaluate the argument holding the list of arguments */
3386 arg1
= EVALCAR (x
, env
);
3389 /* Go here to tail-apply a procedure. PROC is the procedure and
3390 * ARG1 is the list of arguments. PREP_APPLY must have been called
3391 * before jumping to apply_proc. */
3392 if (SCM_CLOSUREP (proc
))
3394 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3396 debug
.info
->a
.args
= arg1
;
3398 if (scm_badargsp (formals
, arg1
))
3399 scm_wrong_num_args (proc
);
3401 /* Copy argument list */
3402 if (SCM_NULL_OR_NIL_P (arg1
))
3403 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
3406 SCM args
= scm_list_1 (SCM_CAR (arg1
));
3408 arg1
= SCM_CDR (arg1
);
3409 while (!SCM_NULL_OR_NIL_P (arg1
))
3411 SCM new_tail
= scm_list_1 (SCM_CAR (arg1
));
3412 SCM_SETCDR (tail
, new_tail
);
3414 arg1
= SCM_CDR (arg1
);
3416 env
= SCM_EXTEND_ENV (formals
, args
, SCM_ENV (proc
));
3419 x
= SCM_CLOSURE_BODY (proc
);
3420 goto nontoplevel_begin
;
3425 RETURN (SCM_APPLY (proc
, arg1
, SCM_EOL
));
3429 case (ISYMNUM (SCM_IM_CONT
)):
3432 SCM val
= scm_make_continuation (&first
);
3440 proc
= EVALCAR (proc
, env
);
3441 PREP_APPLY (proc
, scm_list_1 (arg1
));
3448 case (ISYMNUM (SCM_IM_DELAY
)):
3449 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
3452 case (ISYMNUM (SCM_IM_FUTURE
)):
3453 RETURN (scm_i_make_future (scm_closure (SCM_CDR (x
), env
)));
3456 /* PLACEHOLDER for case (ISYMNUM (SCM_IM_DISPATCH)): The following
3457 code (type_dispatch) is intended to be the tail of the case
3458 clause for the internal macro SCM_IM_DISPATCH. Please don't
3459 remove it from this location without discussing it with Mikael
3460 <djurfeldt@nada.kth.se> */
3462 /* The type dispatch code is duplicated below
3463 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
3464 * cuts down execution time for type dispatch to 50%. */
3465 type_dispatch
: /* inputs: x, arg1 */
3466 /* Type dispatch means to determine from the types of the function
3467 * arguments (i. e. the 'signature' of the call), which method from
3468 * a generic function is to be called. This process of selecting
3469 * the right method takes some time. To speed it up, guile uses
3470 * caching: Together with the macro call to dispatch the signatures
3471 * of some previous calls to that generic function from the same
3472 * place are stored (in the code!) in a cache that we call the
3473 * 'method cache'. This is done since it is likely, that
3474 * consecutive calls to dispatch from that position in the code will
3475 * have the same signature. Thus, the type dispatch works as
3476 * follows: First, determine a hash value from the signature of the
3477 * actual arguments. Second, use this hash value as an index to
3478 * find that same signature in the method cache stored at this
3479 * position in the code. If found, you have also found the
3480 * corresponding method that belongs to that signature. If the
3481 * signature is not found in the method cache, you have to perform a
3482 * full search over all signatures stored with the generic
3485 unsigned long int specializers
;
3486 unsigned long int hash_value
;
3487 unsigned long int cache_end_pos
;
3488 unsigned long int mask
;
3492 SCM z
= SCM_CDDR (x
);
3493 SCM tmp
= SCM_CADR (z
);
3494 specializers
= SCM_INUM (SCM_CAR (z
));
3496 /* Compute a hash value for searching the method cache. There
3497 * are two variants for computing the hash value, a (rather)
3498 * complicated one, and a simple one. For the complicated one
3499 * explained below, tmp holds a number that is used in the
3501 if (SCM_INUMP (tmp
))
3503 /* Use the signature of the actual arguments to determine
3504 * the hash value. This is done as follows: Each class has
3505 * an array of random numbers, that are determined when the
3506 * class is created. The integer 'hashset' is an index into
3507 * that array of random numbers. Now, from all classes that
3508 * are part of the signature of the actual arguments, the
3509 * random numbers at index 'hashset' are taken and summed
3510 * up, giving the hash value. The value of 'hashset' is
3511 * stored at the call to dispatch. This allows to have
3512 * different 'formulas' for calculating the hash value at
3513 * different places where dispatch is called. This allows
3514 * to optimize the hash formula at every individual place
3515 * where dispatch is called, such that hopefully the hash
3516 * value that is computed will directly point to the right
3517 * method in the method cache. */
3518 unsigned long int hashset
= SCM_INUM (tmp
);
3519 unsigned long int counter
= specializers
+ 1;
3522 while (!SCM_NULLP (tmp_arg
) && counter
!= 0)
3524 SCM
class = scm_class_of (SCM_CAR (tmp_arg
));
3525 hash_value
+= SCM_INSTANCE_HASH (class, hashset
);
3526 tmp_arg
= SCM_CDR (tmp_arg
);
3530 method_cache
= SCM_CADR (z
);
3531 mask
= SCM_INUM (SCM_CAR (z
));
3533 cache_end_pos
= hash_value
;
3537 /* This method of determining the hash value is much
3538 * simpler: Set the hash value to zero and just perform a
3539 * linear search through the method cache. */
3541 mask
= (unsigned long int) ((long) -1);
3543 cache_end_pos
= SCM_VECTOR_LENGTH (method_cache
);
3548 /* Search the method cache for a method with a matching
3549 * signature. Start the search at position 'hash_value'. The
3550 * hashing implementation uses linear probing for conflict
3551 * resolution, that is, if the signature in question is not
3552 * found at the starting index in the hash table, the next table
3553 * entry is tried, and so on, until in the worst case the whole
3554 * cache has been searched, but still the signature has not been
3559 SCM args
= arg1
; /* list of arguments */
3560 z
= SCM_VELTS (method_cache
)[hash_value
];
3561 while (!SCM_NULLP (args
))
3563 /* More arguments than specifiers => CLASS != ENV */
3564 SCM class_of_arg
= scm_class_of (SCM_CAR (args
));
3565 if (!SCM_EQ_P (class_of_arg
, SCM_CAR (z
)))
3567 args
= SCM_CDR (args
);
3570 /* Fewer arguments than specifiers => CAR != ENV */
3571 if (SCM_NULLP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
)))
3574 hash_value
= (hash_value
+ 1) & mask
;
3575 } while (hash_value
!= cache_end_pos
);
3577 /* No appropriate method was found in the cache. */
3578 z
= scm_memoize_method (x
, arg1
);
3580 apply_cmethod
: /* inputs: z, arg1 */
3582 SCM formals
= SCM_CMETHOD_FORMALS (z
);
3583 env
= SCM_EXTEND_ENV (formals
, arg1
, SCM_CMETHOD_ENV (z
));
3584 x
= SCM_CMETHOD_BODY (z
);
3585 goto nontoplevel_begin
;
3591 case (ISYMNUM (SCM_IM_SLOT_REF
)):
3594 SCM instance
= EVALCAR (x
, env
);
3595 unsigned long int slot
= SCM_INUM (SCM_CDR (x
));
3596 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance
) [slot
]));
3600 case (ISYMNUM (SCM_IM_SLOT_SET_X
)):
3603 SCM instance
= EVALCAR (x
, env
);
3604 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
3605 SCM value
= EVALCAR (SCM_CDDR (x
), env
);
3606 SCM_STRUCT_DATA (instance
) [slot
] = SCM_UNPACK (value
);
3607 RETURN (SCM_UNSPECIFIED
);
3611 #if SCM_ENABLE_ELISP
3613 case (ISYMNUM (SCM_IM_NIL_COND
)):
3615 SCM test_form
= SCM_CDR (x
);
3616 x
= SCM_CDR (test_form
);
3617 while (!SCM_NULL_OR_NIL_P (x
))
3619 SCM test_result
= EVALCAR (test_form
, env
);
3620 if (!(SCM_FALSEP (test_result
)
3621 || SCM_NULL_OR_NIL_P (test_result
)))
3623 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
3624 RETURN (test_result
);
3625 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3630 test_form
= SCM_CDR (x
);
3631 x
= SCM_CDR (test_form
);
3635 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3639 #endif /* SCM_ENABLE_ELISP */
3641 case (ISYMNUM (SCM_IM_BIND
)):
3643 SCM vars
, exps
, vals
;
3646 vars
= SCM_CAAR (x
);
3647 exps
= SCM_CDAR (x
);
3649 while (!SCM_NULLP (exps
))
3651 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
3652 exps
= SCM_CDR (exps
);
3655 scm_swap_bindings (vars
, vals
);
3656 scm_dynwinds
= scm_acons (vars
, vals
, scm_dynwinds
);
3658 /* Ignore all but the last evaluation result. */
3659 for (x
= SCM_CDR (x
); !SCM_NULLP (SCM_CDR (x
)); x
= SCM_CDR (x
))
3661 if (SCM_CONSP (SCM_CAR (x
)))
3662 CEVAL (SCM_CAR (x
), env
);
3664 proc
= EVALCAR (x
, env
);
3666 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
3667 scm_swap_bindings (vars
, vals
);
3673 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
3678 producer
= EVALCAR (x
, env
);
3680 proc
= EVALCAR (x
, env
); /* proc is the consumer. */
3681 arg1
= SCM_APPLY (producer
, SCM_EOL
, SCM_EOL
);
3682 if (SCM_VALUESP (arg1
))
3684 /* The list of arguments is not copied. Rather, it is assumed
3685 * that this has been done by the 'values' procedure. */
3686 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
3690 arg1
= scm_list_1 (arg1
);
3692 PREP_APPLY (proc
, arg1
);
3703 if (SCM_VARIABLEP (SCM_CAR (x
)))
3704 proc
= SCM_VARIABLE_REF (SCM_CAR (x
));
3705 else if (SCM_ILOCP (SCM_CAR (x
)))
3706 proc
= *scm_ilookup (SCM_CAR (x
), env
);
3707 else if (SCM_CONSP (SCM_CAR (x
)))
3708 proc
= CEVAL (SCM_CAR (x
), env
);
3709 else if (SCM_SYMBOLP (SCM_CAR (x
)))
3711 SCM orig_sym
= SCM_CAR (x
);
3713 SCM
*location
= scm_lookupcar1 (x
, env
, 1);
3714 if (location
== NULL
)
3716 /* we have lost the race, start again. */
3722 if (SCM_MACROP (proc
))
3724 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
3726 handle_a_macro
: /* inputs: x, env, proc */
3728 /* Set a flag during macro expansion so that macro
3729 application frames can be deleted from the backtrace. */
3730 SCM_SET_MACROEXP (debug
);
3732 arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
3733 scm_cons (env
, scm_listofnull
));
3735 SCM_CLEAR_MACROEXP (debug
);
3737 switch (SCM_MACRO_TYPE (proc
))
3741 if (!SCM_CONSP (arg1
))
3742 arg1
= scm_list_2 (SCM_IM_BEGIN
, arg1
);
3744 assert (!SCM_EQ_P (x
, SCM_CAR (arg1
))
3745 && !SCM_EQ_P (x
, SCM_CDR (arg1
)));
3748 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
3751 SCM_SETCAR (x
, SCM_CAR (arg1
));
3752 SCM_SETCDR (x
, SCM_CDR (arg1
));
3756 /* Prevent memoizing of debug info expression. */
3757 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
3762 SCM_SETCAR (x
, SCM_CAR (arg1
));
3763 SCM_SETCDR (x
, SCM_CDR (arg1
));
3765 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3767 #if SCM_ENABLE_DEPRECATED == 1
3772 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3786 if (SCM_MACROP (proc
))
3787 goto handle_a_macro
;
3791 /* When reaching this part of the code, the following is granted: Variable x
3792 * holds the first pair of an expression of the form (<function> arg ...).
3793 * Variable proc holds the object that resulted from the evaluation of
3794 * <function>. In the following, the arguments (if any) will be evaluated,
3795 * and proc will be applied to them. If proc does not really hold a
3796 * function object, this will be signalled as an error on the scheme
3797 * level. If the number of arguments does not match the number of arguments
3798 * that are allowed to be passed to proc, also an error on the scheme level
3799 * will be signalled. */
3800 PREP_APPLY (proc
, SCM_EOL
);
3801 if (SCM_NULLP (SCM_CDR (x
))) {
3804 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3805 switch (SCM_TYP7 (proc
))
3806 { /* no arguments given */
3807 case scm_tc7_subr_0
:
3808 RETURN (SCM_SUBRF (proc
) ());
3809 case scm_tc7_subr_1o
:
3810 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
3812 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
3813 case scm_tc7_rpsubr
:
3814 RETURN (SCM_BOOL_T
);
3816 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
3818 if (!SCM_SMOB_APPLICABLE_P (proc
))
3820 RETURN (SCM_SMOB_APPLY_0 (proc
));
3823 proc
= SCM_CCLO_SUBR (proc
);
3825 debug
.info
->a
.proc
= proc
;
3826 debug
.info
->a
.args
= scm_list_1 (arg1
);
3830 proc
= SCM_PROCEDURE (proc
);
3832 debug
.info
->a
.proc
= proc
;
3834 if (!SCM_CLOSUREP (proc
))
3837 case scm_tcs_closures
:
3839 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3840 if (SCM_CONSP (formals
))
3841 goto umwrongnumargs
;
3842 x
= SCM_CLOSURE_BODY (proc
);
3843 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
3844 goto nontoplevel_begin
;
3846 case scm_tcs_struct
:
3847 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3849 x
= SCM_ENTITY_PROCEDURE (proc
);
3853 else if (SCM_I_OPERATORP (proc
))
3856 proc
= (SCM_I_ENTITYP (proc
)
3857 ? SCM_ENTITY_PROCEDURE (proc
)
3858 : SCM_OPERATOR_PROCEDURE (proc
));
3860 debug
.info
->a
.proc
= proc
;
3861 debug
.info
->a
.args
= scm_list_1 (arg1
);
3867 case scm_tc7_subr_1
:
3868 case scm_tc7_subr_2
:
3869 case scm_tc7_subr_2o
:
3872 case scm_tc7_subr_3
:
3873 case scm_tc7_lsubr_2
:
3876 scm_wrong_num_args (proc
);
3879 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
3883 /* must handle macros by here */
3886 arg1
= EVALCAR (x
, env
);
3888 scm_wrong_num_args (proc
);
3890 debug
.info
->a
.args
= scm_list_1 (arg1
);
3898 evap1
: /* inputs: proc, arg1 */
3899 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3900 switch (SCM_TYP7 (proc
))
3901 { /* have one argument in arg1 */
3902 case scm_tc7_subr_2o
:
3903 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3904 case scm_tc7_subr_1
:
3905 case scm_tc7_subr_1o
:
3906 RETURN (SCM_SUBRF (proc
) (arg1
));
3908 if (SCM_INUMP (arg1
))
3910 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3912 else if (SCM_REALP (arg1
))
3914 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3916 else if (SCM_BIGP (arg1
))
3918 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3920 else if (SCM_FRACTIONP (arg1
))
3922 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
3924 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3925 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3928 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
3931 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
3932 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3933 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3938 case scm_tc7_rpsubr
:
3939 RETURN (SCM_BOOL_T
);
3941 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3944 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3946 RETURN (SCM_SUBRF (proc
) (scm_list_1 (arg1
)));
3949 if (!SCM_SMOB_APPLICABLE_P (proc
))
3951 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
3955 proc
= SCM_CCLO_SUBR (proc
);
3957 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
3958 debug
.info
->a
.proc
= proc
;
3962 proc
= SCM_PROCEDURE (proc
);
3964 debug
.info
->a
.proc
= proc
;
3966 if (!SCM_CLOSUREP (proc
))
3969 case scm_tcs_closures
:
3972 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3973 if (SCM_NULLP (formals
)
3974 || (SCM_CONSP (formals
) && SCM_CONSP (SCM_CDR (formals
))))
3975 goto umwrongnumargs
;
3976 x
= SCM_CLOSURE_BODY (proc
);
3978 env
= SCM_EXTEND_ENV (formals
,
3982 env
= SCM_EXTEND_ENV (formals
,
3986 goto nontoplevel_begin
;
3988 case scm_tcs_struct
:
3989 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3991 x
= SCM_ENTITY_PROCEDURE (proc
);
3993 arg1
= debug
.info
->a
.args
;
3995 arg1
= scm_list_1 (arg1
);
3999 else if (SCM_I_OPERATORP (proc
))
4003 proc
= (SCM_I_ENTITYP (proc
)
4004 ? SCM_ENTITY_PROCEDURE (proc
)
4005 : SCM_OPERATOR_PROCEDURE (proc
));
4007 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
4008 debug
.info
->a
.proc
= proc
;
4014 case scm_tc7_subr_2
:
4015 case scm_tc7_subr_0
:
4016 case scm_tc7_subr_3
:
4017 case scm_tc7_lsubr_2
:
4018 scm_wrong_num_args (proc
);
4024 arg2
= EVALCAR (x
, env
);
4026 scm_wrong_num_args (proc
);
4028 { /* have two or more arguments */
4030 debug
.info
->a
.args
= scm_list_2 (arg1
, arg2
);
4033 if (SCM_NULLP (x
)) {
4036 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4037 switch (SCM_TYP7 (proc
))
4038 { /* have two arguments */
4039 case scm_tc7_subr_2
:
4040 case scm_tc7_subr_2o
:
4041 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
4044 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4046 RETURN (SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
)));
4048 case scm_tc7_lsubr_2
:
4049 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
));
4050 case scm_tc7_rpsubr
:
4052 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
4054 if (!SCM_SMOB_APPLICABLE_P (proc
))
4056 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
));
4060 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
4061 scm_cons (proc
, debug
.info
->a
.args
),
4064 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
4065 scm_cons2 (proc
, arg1
,
4072 case scm_tcs_struct
:
4073 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4075 x
= SCM_ENTITY_PROCEDURE (proc
);
4077 arg1
= debug
.info
->a
.args
;
4079 arg1
= scm_list_2 (arg1
, arg2
);
4083 else if (SCM_I_OPERATORP (proc
))
4087 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
4088 ? SCM_ENTITY_PROCEDURE (proc
)
4089 : SCM_OPERATOR_PROCEDURE (proc
),
4090 scm_cons (proc
, debug
.info
->a
.args
),
4093 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
4094 ? SCM_ENTITY_PROCEDURE (proc
)
4095 : SCM_OPERATOR_PROCEDURE (proc
),
4096 scm_cons2 (proc
, arg1
,
4106 case scm_tc7_subr_0
:
4109 case scm_tc7_subr_1o
:
4110 case scm_tc7_subr_1
:
4111 case scm_tc7_subr_3
:
4112 scm_wrong_num_args (proc
);
4116 proc
= SCM_PROCEDURE (proc
);
4118 debug
.info
->a
.proc
= proc
;
4120 if (!SCM_CLOSUREP (proc
))
4123 case scm_tcs_closures
:
4126 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4127 if (SCM_NULLP (formals
)
4128 || (SCM_CONSP (formals
)
4129 && (SCM_NULLP (SCM_CDR (formals
))
4130 || (SCM_CONSP (SCM_CDR (formals
))
4131 && SCM_CONSP (SCM_CDDR (formals
))))))
4132 goto umwrongnumargs
;
4134 env
= SCM_EXTEND_ENV (formals
,
4138 env
= SCM_EXTEND_ENV (formals
,
4139 scm_list_2 (arg1
, arg2
),
4142 x
= SCM_CLOSURE_BODY (proc
);
4143 goto nontoplevel_begin
;
4148 scm_wrong_num_args (proc
);
4150 debug
.info
->a
.args
= scm_cons2 (arg1
, arg2
,
4151 deval_args (x
, env
, proc
,
4152 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
4156 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4157 switch (SCM_TYP7 (proc
))
4158 { /* have 3 or more arguments */
4160 case scm_tc7_subr_3
:
4161 if (!SCM_NULLP (SCM_CDR (x
)))
4162 scm_wrong_num_args (proc
);
4164 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4165 SCM_CADDR (debug
.info
->a
.args
)));
4167 arg1
= SCM_SUBRF(proc
)(arg1
, arg2
);
4168 arg2
= SCM_CDDR (debug
.info
->a
.args
);
4171 arg1
= SCM_SUBRF(proc
)(arg1
, SCM_CAR (arg2
));
4172 arg2
= SCM_CDR (arg2
);
4174 while (SCM_NIMP (arg2
));
4176 case scm_tc7_rpsubr
:
4177 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
4178 RETURN (SCM_BOOL_F
);
4179 arg1
= SCM_CDDR (debug
.info
->a
.args
);
4182 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (arg1
))))
4183 RETURN (SCM_BOOL_F
);
4184 arg2
= SCM_CAR (arg1
);
4185 arg1
= SCM_CDR (arg1
);
4187 while (SCM_NIMP (arg1
));
4188 RETURN (SCM_BOOL_T
);
4189 case scm_tc7_lsubr_2
:
4190 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4191 SCM_CDDR (debug
.info
->a
.args
)));
4193 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4195 if (!SCM_SMOB_APPLICABLE_P (proc
))
4197 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4198 SCM_CDDR (debug
.info
->a
.args
)));
4202 proc
= SCM_PROCEDURE (proc
);
4203 debug
.info
->a
.proc
= proc
;
4204 if (!SCM_CLOSUREP (proc
))
4207 case scm_tcs_closures
:
4209 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4210 if (SCM_NULLP (formals
)
4211 || (SCM_CONSP (formals
)
4212 && (SCM_NULLP (SCM_CDR (formals
))
4213 || (SCM_CONSP (SCM_CDR (formals
))
4214 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4215 goto umwrongnumargs
;
4216 SCM_SET_ARGSREADY (debug
);
4217 env
= SCM_EXTEND_ENV (formals
,
4220 x
= SCM_CLOSURE_BODY (proc
);
4221 goto nontoplevel_begin
;
4224 case scm_tc7_subr_3
:
4225 if (!SCM_NULLP (SCM_CDR (x
)))
4226 scm_wrong_num_args (proc
);
4228 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, EVALCAR (x
, env
)));
4230 arg1
= SCM_SUBRF (proc
) (arg1
, arg2
);
4233 arg1
= SCM_SUBRF(proc
)(arg1
, EVALCAR(x
, env
));
4236 while (!SCM_NULLP (x
));
4238 case scm_tc7_rpsubr
:
4239 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
4240 RETURN (SCM_BOOL_F
);
4243 arg1
= EVALCAR (x
, env
);
4244 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, arg1
)))
4245 RETURN (SCM_BOOL_F
);
4249 while (!SCM_NULLP (x
));
4250 RETURN (SCM_BOOL_T
);
4251 case scm_tc7_lsubr_2
:
4252 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
4254 RETURN (SCM_SUBRF (proc
) (scm_cons2 (arg1
,
4256 scm_eval_args (x
, env
, proc
))));
4258 if (!SCM_SMOB_APPLICABLE_P (proc
))
4260 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4261 scm_eval_args (x
, env
, proc
)));
4265 proc
= SCM_PROCEDURE (proc
);
4266 if (!SCM_CLOSUREP (proc
))
4269 case scm_tcs_closures
:
4271 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4272 if (SCM_NULLP (formals
)
4273 || (SCM_CONSP (formals
)
4274 && (SCM_NULLP (SCM_CDR (formals
))
4275 || (SCM_CONSP (SCM_CDR (formals
))
4276 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4277 goto umwrongnumargs
;
4278 env
= SCM_EXTEND_ENV (formals
,
4281 scm_eval_args (x
, env
, proc
)),
4283 x
= SCM_CLOSURE_BODY (proc
);
4284 goto nontoplevel_begin
;
4287 case scm_tcs_struct
:
4288 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4291 arg1
= debug
.info
->a
.args
;
4293 arg1
= scm_cons2 (arg1
, arg2
, scm_eval_args (x
, env
, proc
));
4295 x
= SCM_ENTITY_PROCEDURE (proc
);
4298 else if (SCM_I_OPERATORP (proc
))
4302 case scm_tc7_subr_2
:
4303 case scm_tc7_subr_1o
:
4304 case scm_tc7_subr_2o
:
4305 case scm_tc7_subr_0
:
4308 case scm_tc7_subr_1
:
4309 scm_wrong_num_args (proc
);
4317 if (scm_check_exit_p
&& SCM_TRAPS_P
)
4318 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
4320 SCM_CLEAR_TRACED_FRAME (debug
);
4321 if (SCM_CHEAPTRAPS_P
)
4322 arg1
= scm_make_debugobj (&debug
);
4326 SCM val
= scm_make_continuation (&first
);
4337 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
4341 scm_last_debug_frame
= debug
.prev
;
4347 /* SECTION: This code is compiled once.
4354 /* Simple procedure calls
4358 scm_call_0 (SCM proc
)
4360 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
4364 scm_call_1 (SCM proc
, SCM arg1
)
4366 return scm_apply (proc
, arg1
, scm_listofnull
);
4370 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
4372 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
4376 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
4378 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
4382 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
4384 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
4385 scm_cons (arg4
, scm_listofnull
)));
4388 /* Simple procedure applies
4392 scm_apply_0 (SCM proc
, SCM args
)
4394 return scm_apply (proc
, args
, SCM_EOL
);
4398 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
4400 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
4404 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
4406 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
4410 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
4412 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
4416 /* This code processes the arguments to apply:
4418 (apply PROC ARG1 ... ARGS)
4420 Given a list (ARG1 ... ARGS), this function conses the ARG1
4421 ... arguments onto the front of ARGS, and returns the resulting
4422 list. Note that ARGS is a list; thus, the argument to this
4423 function is a list whose last element is a list.
4425 Apply calls this function, and applies PROC to the elements of the
4426 result. apply:nconc2last takes care of building the list of
4427 arguments, given (ARG1 ... ARGS).
4429 Rather than do new consing, apply:nconc2last destroys its argument.
4430 On that topic, this code came into my care with the following
4431 beautifully cryptic comment on that topic: "This will only screw
4432 you if you do (scm_apply scm_apply '( ... ))" If you know what
4433 they're referring to, send me a patch to this comment. */
4435 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
4437 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
4438 "conses the @var{arg1} @dots{} arguments onto the front of\n"
4439 "@var{args}, and returns the resulting list. Note that\n"
4440 "@var{args} is a list; thus, the argument to this function is\n"
4441 "a list whose last element is a list.\n"
4442 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
4443 "destroys its argument, so use with care.")
4444 #define FUNC_NAME s_scm_nconc2last
4447 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
4449 while (!SCM_NULLP (SCM_CDR (*lloc
))) /* Perhaps should be
4450 SCM_NULL_OR_NIL_P, but not
4451 needed in 99.99% of cases,
4452 and it could seriously hurt
4453 performance. - Neil */
4454 lloc
= SCM_CDRLOC (*lloc
);
4455 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
4456 *lloc
= SCM_CAR (*lloc
);
4464 /* SECTION: When DEVAL is defined this code yields scm_dapply.
4465 * It is compiled twice.
4470 scm_apply (SCM proc
, SCM arg1
, SCM args
)
4476 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
4481 /* Apply a function to a list of arguments.
4483 This function is exported to the Scheme level as taking two
4484 required arguments and a tail argument, as if it were:
4485 (lambda (proc arg1 . args) ...)
4486 Thus, if you just have a list of arguments to pass to a procedure,
4487 pass the list as ARG1, and '() for ARGS. If you have some fixed
4488 args, pass the first as ARG1, then cons any remaining fixed args
4489 onto the front of your argument list, and pass that as ARGS. */
4492 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
4495 scm_t_debug_frame debug
;
4496 scm_t_debug_info debug_vect_body
;
4497 debug
.prev
= scm_last_debug_frame
;
4498 debug
.status
= SCM_APPLYFRAME
;
4499 debug
.vect
= &debug_vect_body
;
4500 debug
.vect
[0].a
.proc
= proc
;
4501 debug
.vect
[0].a
.args
= SCM_EOL
;
4502 scm_last_debug_frame
= &debug
;
4504 if (scm_debug_mode_p
)
4505 return scm_dapply (proc
, arg1
, args
);
4508 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
4510 /* If ARGS is the empty list, then we're calling apply with only two
4511 arguments --- ARG1 is the list of arguments for PROC. Whatever
4512 the case, futz with things so that ARG1 is the first argument to
4513 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
4516 Setting the debug apply frame args this way is pretty messy.
4517 Perhaps we should store arg1 and args directly in the frame as
4518 received, and let scm_frame_arguments unpack them, because that's
4519 a relatively rare operation. This works for now; if the Guile
4520 developer archives are still around, see Mikael's post of
4522 if (SCM_NULLP (args
))
4524 if (SCM_NULLP (arg1
))
4526 arg1
= SCM_UNDEFINED
;
4528 debug
.vect
[0].a
.args
= SCM_EOL
;
4534 debug
.vect
[0].a
.args
= arg1
;
4536 args
= SCM_CDR (arg1
);
4537 arg1
= SCM_CAR (arg1
);
4542 args
= scm_nconc2last (args
);
4544 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4548 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
4551 if (SCM_CHEAPTRAPS_P
)
4552 tmp
= scm_make_debugobj (&debug
);
4557 tmp
= scm_make_continuation (&first
);
4562 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
4569 switch (SCM_TYP7 (proc
))
4571 case scm_tc7_subr_2o
:
4572 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
4573 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4574 case scm_tc7_subr_2
:
4575 if (SCM_NULLP (args
) || !SCM_NULLP (SCM_CDR (args
)))
4576 scm_wrong_num_args (proc
);
4577 args
= SCM_CAR (args
);
4578 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4579 case scm_tc7_subr_0
:
4580 if (!SCM_UNBNDP (arg1
))
4581 scm_wrong_num_args (proc
);
4583 RETURN (SCM_SUBRF (proc
) ());
4584 case scm_tc7_subr_1
:
4585 if (SCM_UNBNDP (arg1
))
4586 scm_wrong_num_args (proc
);
4587 case scm_tc7_subr_1o
:
4588 if (!SCM_NULLP (args
))
4589 scm_wrong_num_args (proc
);
4591 RETURN (SCM_SUBRF (proc
) (arg1
));
4593 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
4594 scm_wrong_num_args (proc
);
4595 if (SCM_INUMP (arg1
))
4597 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
4599 else if (SCM_REALP (arg1
))
4601 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4603 else if (SCM_BIGP (arg1
))
4605 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4607 else if (SCM_FRACTIONP (arg1
))
4609 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4611 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4612 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4614 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
4615 scm_wrong_num_args (proc
);
4617 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
4620 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
4621 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4622 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
4627 case scm_tc7_subr_3
:
4628 if (SCM_NULLP (args
)
4629 || SCM_NULLP (SCM_CDR (args
))
4630 || !SCM_NULLP (SCM_CDDR (args
)))
4631 scm_wrong_num_args (proc
);
4633 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
4636 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
4638 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
4640 case scm_tc7_lsubr_2
:
4641 if (!SCM_CONSP (args
))
4642 scm_wrong_num_args (proc
);
4644 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4646 if (SCM_NULLP (args
))
4647 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4648 while (SCM_NIMP (args
))
4650 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
4651 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
4652 args
= SCM_CDR (args
);
4655 case scm_tc7_rpsubr
:
4656 if (SCM_NULLP (args
))
4657 RETURN (SCM_BOOL_T
);
4658 while (SCM_NIMP (args
))
4660 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
4661 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
4662 RETURN (SCM_BOOL_F
);
4663 arg1
= SCM_CAR (args
);
4664 args
= SCM_CDR (args
);
4666 RETURN (SCM_BOOL_T
);
4667 case scm_tcs_closures
:
4669 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4671 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4673 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
4674 scm_wrong_num_args (proc
);
4676 /* Copy argument list */
4681 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
4682 for (arg1
= SCM_CDR (arg1
); SCM_CONSP (arg1
); arg1
= SCM_CDR (arg1
))
4684 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
));
4687 SCM_SETCDR (tl
, arg1
);
4690 args
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4693 proc
= SCM_CLOSURE_BODY (proc
);
4695 arg1
= SCM_CDR (proc
);
4696 while (!SCM_NULLP (arg1
))
4698 if (SCM_IMP (SCM_CAR (proc
)))
4700 if (SCM_ISYMP (SCM_CAR (proc
)))
4702 scm_rec_mutex_lock (&source_mutex
);
4703 /* check for race condition */
4704 if (SCM_ISYMP (SCM_CAR (proc
)))
4705 m_expand_body (proc
, args
);
4706 scm_rec_mutex_unlock (&source_mutex
);
4710 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
4713 (void) EVAL (SCM_CAR (proc
), args
);
4715 arg1
= SCM_CDR (proc
);
4717 RETURN (EVALCAR (proc
, args
));
4719 if (!SCM_SMOB_APPLICABLE_P (proc
))
4721 if (SCM_UNBNDP (arg1
))
4722 RETURN (SCM_SMOB_APPLY_0 (proc
));
4723 else if (SCM_NULLP (args
))
4724 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
4725 else if (SCM_NULLP (SCM_CDR (args
)))
4726 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
4728 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4731 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4733 proc
= SCM_CCLO_SUBR (proc
);
4734 debug
.vect
[0].a
.proc
= proc
;
4735 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4737 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4739 proc
= SCM_CCLO_SUBR (proc
);
4743 proc
= SCM_PROCEDURE (proc
);
4745 debug
.vect
[0].a
.proc
= proc
;
4748 case scm_tcs_struct
:
4749 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4752 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4754 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4756 RETURN (scm_apply_generic (proc
, args
));
4758 else if (SCM_I_OPERATORP (proc
))
4762 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4764 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4767 proc
= (SCM_I_ENTITYP (proc
)
4768 ? SCM_ENTITY_PROCEDURE (proc
)
4769 : SCM_OPERATOR_PROCEDURE (proc
));
4771 debug
.vect
[0].a
.proc
= proc
;
4772 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4774 if (SCM_NIMP (proc
))
4783 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
4787 if (scm_check_exit_p
&& SCM_TRAPS_P
)
4788 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
4790 SCM_CLEAR_TRACED_FRAME (debug
);
4791 if (SCM_CHEAPTRAPS_P
)
4792 arg1
= scm_make_debugobj (&debug
);
4796 SCM val
= scm_make_continuation (&first
);
4807 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
4811 scm_last_debug_frame
= debug
.prev
;
4817 /* SECTION: The rest of this file is only read once.
4824 * Trampolines make it possible to move procedure application dispatch
4825 * outside inner loops. The motivation was clean implementation of
4826 * efficient replacements of R5RS primitives in SRFI-1.
4828 * The semantics is clear: scm_trampoline_N returns an optimized
4829 * version of scm_call_N (or NULL if the procedure isn't applicable
4832 * Applying the optimization to map and for-each increased efficiency
4833 * noticeably. For example, (map abs ls) is now 8 times faster than
4838 call_subr0_0 (SCM proc
)
4840 return SCM_SUBRF (proc
) ();
4844 call_subr1o_0 (SCM proc
)
4846 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
4850 call_lsubr_0 (SCM proc
)
4852 return SCM_SUBRF (proc
) (SCM_EOL
);
4856 scm_i_call_closure_0 (SCM proc
)
4858 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4861 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
4866 scm_trampoline_0 (SCM proc
)
4868 scm_t_trampoline_0 trampoline
;
4873 switch (SCM_TYP7 (proc
))
4875 case scm_tc7_subr_0
:
4876 trampoline
= call_subr0_0
;
4878 case scm_tc7_subr_1o
:
4879 trampoline
= call_subr1o_0
;
4882 trampoline
= call_lsubr_0
;
4884 case scm_tcs_closures
:
4886 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4887 if (SCM_NULLP (formals
) || !SCM_CONSP (formals
))
4888 trampoline
= scm_i_call_closure_0
;
4893 case scm_tcs_struct
:
4894 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4895 trampoline
= scm_call_generic_0
;
4896 else if (SCM_I_OPERATORP (proc
))
4897 trampoline
= scm_call_0
;
4902 if (SCM_SMOB_APPLICABLE_P (proc
))
4903 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
4908 case scm_tc7_rpsubr
:
4911 trampoline
= scm_call_0
;
4914 return NULL
; /* not applicable on zero arguments */
4916 /* We only reach this point if a valid trampoline was determined. */
4918 /* If debugging is enabled, we want to see all calls to proc on the stack.
4919 * Thus, we replace the trampoline shortcut with scm_call_0. */
4920 if (scm_debug_mode_p
)
4927 call_subr1_1 (SCM proc
, SCM arg1
)
4929 return SCM_SUBRF (proc
) (arg1
);
4933 call_subr2o_1 (SCM proc
, SCM arg1
)
4935 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
4939 call_lsubr_1 (SCM proc
, SCM arg1
)
4941 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
4945 call_dsubr_1 (SCM proc
, SCM arg1
)
4947 if (SCM_INUMP (arg1
))
4949 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
4951 else if (SCM_REALP (arg1
))
4953 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4955 else if (SCM_BIGP (arg1
))
4957 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4959 else if (SCM_FRACTIONP (arg1
))
4961 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4963 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4964 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4968 call_cxr_1 (SCM proc
, SCM arg1
)
4970 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
4973 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
4974 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4975 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
4982 call_closure_1 (SCM proc
, SCM arg1
)
4984 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4987 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
4992 scm_trampoline_1 (SCM proc
)
4994 scm_t_trampoline_1 trampoline
;
4999 switch (SCM_TYP7 (proc
))
5001 case scm_tc7_subr_1
:
5002 case scm_tc7_subr_1o
:
5003 trampoline
= call_subr1_1
;
5005 case scm_tc7_subr_2o
:
5006 trampoline
= call_subr2o_1
;
5009 trampoline
= call_lsubr_1
;
5012 trampoline
= call_dsubr_1
;
5015 trampoline
= call_cxr_1
;
5017 case scm_tcs_closures
:
5019 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5020 if (!SCM_NULLP (formals
)
5021 && (!SCM_CONSP (formals
) || !SCM_CONSP (SCM_CDR (formals
))))
5022 trampoline
= call_closure_1
;
5027 case scm_tcs_struct
:
5028 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5029 trampoline
= scm_call_generic_1
;
5030 else if (SCM_I_OPERATORP (proc
))
5031 trampoline
= scm_call_1
;
5036 if (SCM_SMOB_APPLICABLE_P (proc
))
5037 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
5042 case scm_tc7_rpsubr
:
5045 trampoline
= scm_call_1
;
5048 return NULL
; /* not applicable on one arg */
5050 /* We only reach this point if a valid trampoline was determined. */
5052 /* If debugging is enabled, we want to see all calls to proc on the stack.
5053 * Thus, we replace the trampoline shortcut with scm_call_1. */
5054 if (scm_debug_mode_p
)
5061 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
5063 return SCM_SUBRF (proc
) (arg1
, arg2
);
5067 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
5069 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
5073 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
5075 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
5079 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
5081 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
5082 scm_list_2 (arg1
, arg2
),
5084 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
5089 scm_trampoline_2 (SCM proc
)
5091 scm_t_trampoline_2 trampoline
;
5096 switch (SCM_TYP7 (proc
))
5098 case scm_tc7_subr_2
:
5099 case scm_tc7_subr_2o
:
5100 case scm_tc7_rpsubr
:
5102 trampoline
= call_subr2_2
;
5104 case scm_tc7_lsubr_2
:
5105 trampoline
= call_lsubr2_2
;
5108 trampoline
= call_lsubr_2
;
5110 case scm_tcs_closures
:
5112 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5113 if (!SCM_NULLP (formals
)
5114 && (!SCM_CONSP (formals
)
5115 || (!SCM_NULLP (SCM_CDR (formals
))
5116 && (!SCM_CONSP (SCM_CDR (formals
))
5117 || !SCM_CONSP (SCM_CDDR (formals
))))))
5118 trampoline
= call_closure_2
;
5123 case scm_tcs_struct
:
5124 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5125 trampoline
= scm_call_generic_2
;
5126 else if (SCM_I_OPERATORP (proc
))
5127 trampoline
= scm_call_2
;
5132 if (SCM_SMOB_APPLICABLE_P (proc
))
5133 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
5139 trampoline
= scm_call_2
;
5142 return NULL
; /* not applicable on two args */
5144 /* We only reach this point if a valid trampoline was determined. */
5146 /* If debugging is enabled, we want to see all calls to proc on the stack.
5147 * Thus, we replace the trampoline shortcut with scm_call_2. */
5148 if (scm_debug_mode_p
)
5154 /* Typechecking for multi-argument MAP and FOR-EACH.
5156 Verify that each element of the vector ARGV, except for the first,
5157 is a proper list whose length is LEN. Attribute errors to WHO,
5158 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
5160 check_map_args (SCM argv
,
5167 SCM
const *ve
= SCM_VELTS (argv
);
5170 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
5172 long elt_len
= scm_ilength (ve
[i
]);
5177 scm_apply_generic (gf
, scm_cons (proc
, args
));
5179 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
5183 scm_out_of_range_pos (who
, ve
[i
], SCM_MAKINUM (i
+ 2));
5186 scm_remember_upto_here_1 (argv
);
5190 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
5192 /* Note: Currently, scm_map applies PROC to the argument list(s)
5193 sequentially, starting with the first element(s). This is used in
5194 evalext.c where the Scheme procedure `map-in-order', which guarantees
5195 sequential behaviour, is implemented using scm_map. If the
5196 behaviour changes, we need to update `map-in-order'.
5200 scm_map (SCM proc
, SCM arg1
, SCM args
)
5201 #define FUNC_NAME s_map
5206 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
5208 len
= scm_ilength (arg1
);
5209 SCM_GASSERTn (len
>= 0,
5210 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
5211 SCM_VALIDATE_REST_ARGUMENT (args
);
5212 if (SCM_NULLP (args
))
5214 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5215 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
5216 while (SCM_NIMP (arg1
))
5218 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
5219 pres
= SCM_CDRLOC (*pres
);
5220 arg1
= SCM_CDR (arg1
);
5224 if (SCM_NULLP (SCM_CDR (args
)))
5226 SCM arg2
= SCM_CAR (args
);
5227 int len2
= scm_ilength (arg2
);
5228 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5230 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
5231 SCM_GASSERTn (len2
>= 0,
5232 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
5234 SCM_OUT_OF_RANGE (3, arg2
);
5235 while (SCM_NIMP (arg1
))
5237 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
5238 pres
= SCM_CDRLOC (*pres
);
5239 arg1
= SCM_CDR (arg1
);
5240 arg2
= SCM_CDR (arg2
);
5244 arg1
= scm_cons (arg1
, args
);
5245 args
= scm_vector (arg1
);
5246 ve
= SCM_VELTS (args
);
5247 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
5251 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5253 if (SCM_IMP (ve
[i
]))
5255 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
5256 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
5258 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
5259 pres
= SCM_CDRLOC (*pres
);
5265 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
5268 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
5269 #define FUNC_NAME s_for_each
5271 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
5273 len
= scm_ilength (arg1
);
5274 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
5275 SCM_ARG2
, s_for_each
);
5276 SCM_VALIDATE_REST_ARGUMENT (args
);
5277 if (SCM_NULLP (args
))
5279 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5280 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
5281 while (SCM_NIMP (arg1
))
5283 call (proc
, SCM_CAR (arg1
));
5284 arg1
= SCM_CDR (arg1
);
5286 return SCM_UNSPECIFIED
;
5288 if (SCM_NULLP (SCM_CDR (args
)))
5290 SCM arg2
= SCM_CAR (args
);
5291 int len2
= scm_ilength (arg2
);
5292 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5293 SCM_GASSERTn (call
, g_for_each
,
5294 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
5295 SCM_GASSERTn (len2
>= 0, g_for_each
,
5296 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
5298 SCM_OUT_OF_RANGE (3, arg2
);
5299 while (SCM_NIMP (arg1
))
5301 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
5302 arg1
= SCM_CDR (arg1
);
5303 arg2
= SCM_CDR (arg2
);
5305 return SCM_UNSPECIFIED
;
5307 arg1
= scm_cons (arg1
, args
);
5308 args
= scm_vector (arg1
);
5309 ve
= SCM_VELTS (args
);
5310 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
5314 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5316 if (SCM_IMP (ve
[i
]))
5317 return SCM_UNSPECIFIED
;
5318 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
5319 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
5321 scm_apply (proc
, arg1
, SCM_EOL
);
5328 scm_closure (SCM code
, SCM env
)
5331 SCM closcar
= scm_cons (code
, SCM_EOL
);
5332 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
5333 scm_remember_upto_here (closcar
);
5338 scm_t_bits scm_tc16_promise
;
5341 scm_makprom (SCM code
)
5343 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
5345 scm_make_rec_mutex ());
5349 promise_free (SCM promise
)
5351 scm_rec_mutex_free (SCM_PROMISE_MUTEX (promise
));
5356 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
5358 int writingp
= SCM_WRITINGP (pstate
);
5359 scm_puts ("#<promise ", port
);
5360 SCM_SET_WRITINGP (pstate
, 1);
5361 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
5362 SCM_SET_WRITINGP (pstate
, writingp
);
5363 scm_putc ('>', port
);
5367 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
5369 "If the promise @var{x} has not been computed yet, compute and\n"
5370 "return @var{x}, otherwise just return the previously computed\n"
5372 #define FUNC_NAME s_scm_force
5374 SCM_VALIDATE_SMOB (1, promise
, promise
);
5375 scm_rec_mutex_lock (SCM_PROMISE_MUTEX (promise
));
5376 if (!SCM_PROMISE_COMPUTED_P (promise
))
5378 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
5379 if (!SCM_PROMISE_COMPUTED_P (promise
))
5381 SCM_SET_PROMISE_DATA (promise
, ans
);
5382 SCM_SET_PROMISE_COMPUTED (promise
);
5385 scm_rec_mutex_unlock (SCM_PROMISE_MUTEX (promise
));
5386 return SCM_PROMISE_DATA (promise
);
5391 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
5393 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
5394 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
5395 #define FUNC_NAME s_scm_promise_p
5397 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
5402 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
5403 (SCM xorig
, SCM x
, SCM y
),
5404 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
5405 "Any source properties associated with @var{xorig} are also associated\n"
5406 "with the new pair.")
5407 #define FUNC_NAME s_scm_cons_source
5410 z
= scm_cons (x
, y
);
5411 /* Copy source properties possibly associated with xorig. */
5412 p
= scm_whash_lookup (scm_source_whash
, xorig
);
5414 scm_whash_insert (scm_source_whash
, z
, p
);
5420 /* The function scm_copy_tree is used to copy an expression tree to allow the
5421 * memoizer to modify the expression during memoization. scm_copy_tree
5422 * creates deep copies of pairs and vectors, but not of any other data types,
5423 * since only pairs and vectors will be parsed by the memoizer.
5425 * To avoid infinite recursion due to cyclic structures, the hare-and-tortoise
5426 * pattern is used to detect cycles. In fact, the pattern is used in two
5427 * dimensions, vertical (indicated in the code by the variable names 'hare'
5428 * and 'tortoise') and horizontal ('rabbit' and 'turtle'). In both
5429 * dimensions, the hare/rabbit will take two steps when the tortoise/turtle
5432 * The vertical dimension corresponds to recursive calls to function
5433 * copy_tree: This happens when descending into vector elements, into cars of
5434 * lists and into the cdr of an improper list. In this dimension, the
5435 * tortoise follows the hare by using the processor stack: Every stack frame
5436 * will hold an instance of struct t_trace. These instances are connected in
5437 * a way that represents the trace of the hare, which thus can be followed by
5438 * the tortoise. The tortoise will always point to struct t_trace instances
5439 * relating to SCM objects that have already been copied. Thus, a cycle is
5440 * detected if the tortoise and the hare point to the same object,
5442 * The horizontal dimension is within one execution of copy_tree, when the
5443 * function cdr's along the pairs of a list. This is the standard
5444 * hare-and-tortoise implementation, found several times in guile. */
5447 struct t_trace
*trace
; // These pointers form a trace along the stack.
5448 SCM obj
; // The object handled at the respective stack frame.
5453 struct t_trace
*const hare
,
5454 struct t_trace
*tortoise
,
5455 unsigned int tortoise_delay
)
5457 if (!SCM_CONSP (hare
->obj
) && !SCM_VECTORP (hare
->obj
))
5463 /* Prepare the trace along the stack. */
5464 struct t_trace new_hare
;
5465 hare
->trace
= &new_hare
;
5467 /* The tortoise will make its step after the delay has elapsed. Note
5468 * that in contrast to the typical hare-and-tortoise pattern, the step
5469 * of the tortoise happens before the hare takes its steps. This is, in
5470 * principle, no problem, except for the start of the algorithm: Then,
5471 * it has to be made sure that the hare actually gets its advantage of
5473 if (tortoise_delay
== 0)
5476 tortoise
= tortoise
->trace
;
5477 ASSERT_SYNTAX (!SCM_EQ_P (hare
->obj
, tortoise
->obj
),
5478 s_bad_expression
, hare
->obj
);
5485 if (SCM_VECTORP (hare
->obj
))
5487 const unsigned long int length
= SCM_VECTOR_LENGTH (hare
->obj
);
5488 const SCM new_vector
= scm_c_make_vector (length
, SCM_UNSPECIFIED
);
5490 /* Each vector element is copied by recursing into copy_tree, having
5491 * the tortoise follow the hare into the depths of the stack. */
5492 unsigned long int i
;
5493 for (i
= 0; i
< length
; ++i
)
5496 new_hare
.obj
= SCM_VECTOR_REF (hare
->obj
, i
);
5497 new_element
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5498 SCM_VECTOR_SET (new_vector
, i
, new_element
);
5503 else // SCM_CONSP (hare->obj)
5508 SCM rabbit
= hare
->obj
;
5509 SCM turtle
= hare
->obj
;
5513 /* The first pair of the list is treated specially, in order to
5514 * preserve a potential source code position. */
5515 result
= tail
= scm_cons_source (rabbit
, SCM_EOL
, SCM_EOL
);
5516 new_hare
.obj
= SCM_CAR (rabbit
);
5517 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5518 SCM_SETCAR (tail
, copy
);
5520 /* The remaining pairs of the list are copied by, horizontally,
5521 * having the turtle follow the rabbit, and, vertically, having the
5522 * tortoise follow the hare into the depths of the stack. */
5523 rabbit
= SCM_CDR (rabbit
);
5524 while (SCM_CONSP (rabbit
))
5526 new_hare
.obj
= SCM_CAR (rabbit
);
5527 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5528 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
5529 tail
= SCM_CDR (tail
);
5531 rabbit
= SCM_CDR (rabbit
);
5532 if (SCM_CONSP (rabbit
))
5534 new_hare
.obj
= SCM_CAR (rabbit
);
5535 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5536 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
5537 tail
= SCM_CDR (tail
);
5538 rabbit
= SCM_CDR (rabbit
);
5540 turtle
= SCM_CDR (turtle
);
5541 ASSERT_SYNTAX (!SCM_EQ_P (rabbit
, turtle
),
5542 s_bad_expression
, rabbit
);
5546 /* We have to recurse into copy_tree again for the last cdr, in
5547 * order to handle the situation that it holds a vector. */
5548 new_hare
.obj
= rabbit
;
5549 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5550 SCM_SETCDR (tail
, copy
);
5557 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
5559 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
5560 "the new data structure. @code{copy-tree} recurses down the\n"
5561 "contents of both pairs and vectors (since both cons cells and vector\n"
5562 "cells may point to arbitrary objects), and stops recursing when it hits\n"
5563 "any other object.")
5564 #define FUNC_NAME s_scm_copy_tree
5566 /* Prepare the trace along the stack. */
5567 struct t_trace trace
;
5570 /* In function copy_tree, if the tortoise makes its step, it will do this
5571 * before the hare has the chance to move. Thus, we have to make sure that
5572 * the very first step of the tortoise will not happen after the hare has
5573 * really made two steps. This is achieved by passing '2' as the initial
5574 * delay for the tortoise. NOTE: Since cycles are unlikely, giving the hare
5575 * a bigger advantage may improve performance slightly. */
5576 return copy_tree (&trace
, &trace
, 2);
5581 /* We have three levels of EVAL here:
5583 - scm_i_eval (exp, env)
5585 evaluates EXP in environment ENV. ENV is a lexical environment
5586 structure as used by the actual tree code evaluator. When ENV is
5587 a top-level environment, then changes to the current module are
5588 tracked by updating ENV so that it continues to be in sync with
5591 - scm_primitive_eval (exp)
5593 evaluates EXP in the top-level environment as determined by the
5594 current module. This is done by constructing a suitable
5595 environment and calling scm_i_eval. Thus, changes to the
5596 top-level module are tracked normally.
5598 - scm_eval (exp, mod)
5600 evaluates EXP while MOD is the current module. This is done by
5601 setting the current module to MOD, invoking scm_primitive_eval on
5602 EXP, and then restoring the current module to the value it had
5603 previously. That is, while EXP is evaluated, changes to the
5604 current module are tracked, but these changes do not persist when
5607 For each level of evals, there are two variants, distinguished by a
5608 _x suffix: the ordinary variant does not modify EXP while the _x
5609 variant can destructively modify EXP into something completely
5610 unintelligible. A Scheme data structure passed as EXP to one of the
5611 _x variants should not ever be used again for anything. So when in
5612 doubt, use the ordinary variant.
5617 scm_i_eval_x (SCM exp
, SCM env
)
5619 if (SCM_SYMBOLP (exp
))
5620 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
5622 return SCM_XEVAL (exp
, env
);
5626 scm_i_eval (SCM exp
, SCM env
)
5628 exp
= scm_copy_tree (exp
);
5629 if (SCM_SYMBOLP (exp
))
5630 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
5632 return SCM_XEVAL (exp
, env
);
5636 scm_primitive_eval_x (SCM exp
)
5639 SCM transformer
= scm_current_module_transformer ();
5640 if (SCM_NIMP (transformer
))
5641 exp
= scm_call_1 (transformer
, exp
);
5642 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5643 return scm_i_eval_x (exp
, env
);
5646 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
5648 "Evaluate @var{exp} in the top-level environment specified by\n"
5649 "the current module.")
5650 #define FUNC_NAME s_scm_primitive_eval
5653 SCM transformer
= scm_current_module_transformer ();
5654 if (SCM_NIMP (transformer
))
5655 exp
= scm_call_1 (transformer
, exp
);
5656 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5657 return scm_i_eval (exp
, env
);
5662 /* Eval does not take the second arg optionally. This is intentional
5663 * in order to be R5RS compatible, and to prepare for the new module
5664 * system, where we would like to make the choice of evaluation
5665 * environment explicit. */
5668 change_environment (void *data
)
5670 SCM pair
= SCM_PACK (data
);
5671 SCM new_module
= SCM_CAR (pair
);
5672 SCM old_module
= scm_current_module ();
5673 SCM_SETCDR (pair
, old_module
);
5674 scm_set_current_module (new_module
);
5678 restore_environment (void *data
)
5680 SCM pair
= SCM_PACK (data
);
5681 SCM old_module
= SCM_CDR (pair
);
5682 SCM new_module
= scm_current_module ();
5683 SCM_SETCAR (pair
, new_module
);
5684 scm_set_current_module (old_module
);
5688 inner_eval_x (void *data
)
5690 return scm_primitive_eval_x (SCM_PACK(data
));
5694 scm_eval_x (SCM exp
, SCM module
)
5695 #define FUNC_NAME "eval!"
5697 SCM_VALIDATE_MODULE (2, module
);
5699 return scm_internal_dynamic_wind
5700 (change_environment
, inner_eval_x
, restore_environment
,
5701 (void *) SCM_UNPACK (exp
),
5702 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
5707 inner_eval (void *data
)
5709 return scm_primitive_eval (SCM_PACK(data
));
5712 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
5713 (SCM exp
, SCM module
),
5714 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
5715 "in the top-level environment specified by @var{module}.\n"
5716 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
5717 "@var{module} is made the current module. The current module\n"
5718 "is reset to its previous value when @var{eval} returns.")
5719 #define FUNC_NAME s_scm_eval
5721 SCM_VALIDATE_MODULE (2, module
);
5723 return scm_internal_dynamic_wind
5724 (change_environment
, inner_eval
, restore_environment
,
5725 (void *) SCM_UNPACK (exp
),
5726 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
5731 /* At this point, deval and scm_dapply are generated.
5738 #if (SCM_ENABLE_DEPRECATED == 1)
5740 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5741 SCM
scm_ceval (SCM x
, SCM env
)
5744 return ceval (x
, env
);
5745 else if (SCM_SYMBOLP (x
))
5746 return *scm_lookupcar (scm_cons (x
, SCM_UNDEFINED
), env
, 1);
5748 return SCM_XEVAL (x
, env
);
5751 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5752 SCM
scm_deval (SCM x
, SCM env
)
5755 return deval (x
, env
);
5756 else if (SCM_SYMBOLP (x
))
5757 return *scm_lookupcar (scm_cons (x
, SCM_UNDEFINED
), env
, 1);
5759 return SCM_XEVAL (x
, env
);
5763 dispatching_eval (SCM x
, SCM env
)
5765 if (scm_debug_mode_p
)
5766 return scm_deval (x
, env
);
5768 return scm_ceval (x
, env
);
5771 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5772 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
) = dispatching_eval
;
5780 scm_init_opts (scm_evaluator_traps
,
5781 scm_evaluator_trap_table
,
5782 SCM_N_EVALUATOR_TRAPS
);
5783 scm_init_opts (scm_eval_options_interface
,
5785 SCM_N_EVAL_OPTIONS
);
5787 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
5788 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
5789 scm_set_smob_free (scm_tc16_promise
, promise_free
);
5790 scm_set_smob_print (scm_tc16_promise
, promise_print
);
5792 undefineds
= scm_list_1 (SCM_UNDEFINED
);
5793 SCM_SETCDR (undefineds
, undefineds
);
5794 scm_permanent_object (undefineds
);
5796 scm_listofnull
= scm_list_1 (SCM_EOL
);
5798 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
5799 scm_permanent_object (f_apply
);
5801 #include "libguile/eval.x"
5803 scm_add_feature ("delay");