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 */
55 #include "libguile/_scm.h"
56 #include "libguile/alist.h"
57 #include "libguile/async.h"
58 #include "libguile/continuations.h"
59 #include "libguile/debug.h"
60 #include "libguile/deprecation.h"
61 #include "libguile/dynwind.h"
62 #include "libguile/eq.h"
63 #include "libguile/feature.h"
64 #include "libguile/fluids.h"
65 #include "libguile/futures.h"
66 #include "libguile/goops.h"
67 #include "libguile/hash.h"
68 #include "libguile/hashtab.h"
69 #include "libguile/lang.h"
70 #include "libguile/list.h"
71 #include "libguile/macros.h"
72 #include "libguile/modules.h"
73 #include "libguile/objects.h"
74 #include "libguile/ports.h"
75 #include "libguile/print.h"
76 #include "libguile/procprop.h"
77 #include "libguile/root.h"
78 #include "libguile/smob.h"
79 #include "libguile/srcprop.h"
80 #include "libguile/stackchk.h"
81 #include "libguile/strings.h"
82 #include "libguile/throw.h"
83 #include "libguile/validate.h"
84 #include "libguile/values.h"
85 #include "libguile/vectors.h"
87 #include "libguile/eval.h"
91 static SCM
canonicalize_define (SCM expr
);
92 static SCM
*scm_lookupcar1 (SCM vloc
, SCM genv
, int check
);
94 /* prototype in eval.h is not given under --disable-deprecated */
95 SCM_API SCM
scm_macroexp (SCM x
, SCM env
);
101 * This section defines the message strings for the syntax errors that can be
102 * detected during memoization and the functions and macros that shall be
103 * called by the memoizer code to signal syntax errors. */
106 /* Syntax errors that can be detected during memoization: */
108 /* Circular or improper lists do not form valid scheme expressions. If a
109 * circular list or an improper list is detected in a place where a scheme
110 * expression is expected, a 'Bad expression' error is signalled. */
111 static const char s_bad_expression
[] = "Bad expression";
113 /* If a form is detected that holds a different number of expressions than are
114 * required in that context, a 'Missing or extra expression' error is
116 static const char s_expression
[] = "Missing or extra expression in";
118 /* If a form is detected that holds less expressions than are required in that
119 * context, a 'Missing expression' error is signalled. */
120 static const char s_missing_expression
[] = "Missing expression in";
122 /* If a form is detected that holds more expressions than are allowed in that
123 * context, an 'Extra expression' error is signalled. */
124 static const char s_extra_expression
[] = "Extra expression in";
126 /* The empty combination '()' is not allowed as an expression in scheme. If
127 * it is detected in a place where an expression is expected, an 'Illegal
128 * empty combination' error is signalled. Note: If you encounter this error
129 * message, it is very likely that you intended to denote the empty list. To
130 * do so, you need to quote the empty list like (quote ()) or '(). */
131 static const char s_empty_combination
[] = "Illegal empty combination";
133 /* A body may hold an arbitrary number of internal defines, followed by a
134 * non-empty sequence of expressions. If a body with an empty sequence of
135 * expressions is detected, a 'Missing body expression' error is signalled.
137 static const char s_missing_body_expression
[] = "Missing body expression in";
139 /* A body may hold an arbitrary number of internal defines, followed by a
140 * non-empty sequence of expressions. Each the definitions and the
141 * expressions may be grouped arbitraryly with begin, but it is not allowed to
142 * mix definitions and expressions. If a define form in a body mixes
143 * definitions and expressions, a 'Mixed definitions and expressions' error is
145 static const char s_mixed_body_forms
[] = "Mixed definitions and expressions in";
146 /* Definitions are only allowed on the top level and at the start of a body.
147 * If a definition is detected anywhere else, a 'Bad define placement' error
149 static const char s_bad_define
[] = "Bad define placement";
151 /* If a macro keyword is detected in a place where macro keywords are not
152 * allowed, a 'Misplaced syntactic keyword' error is signalled. */
153 static const char s_macro_keyword
[] = "Misplaced syntactic keyword";
155 /* Case or cond expressions must have at least one clause. If a case or cond
156 * expression without any clauses is detected, a 'Missing clauses' error is
158 static const char s_missing_clauses
[] = "Missing clauses";
160 /* If there is an 'else' clause in a case or a cond statement, it must be the
161 * last clause. If after the 'else' case clause further clauses are detected,
162 * a 'Misplaced else clause' error is signalled. */
163 static const char s_misplaced_else_clause
[] = "Misplaced else clause";
165 /* If a case clause is detected that is not in the format
166 * (<label(s)> <expression1> <expression2> ...)
167 * a 'Bad case clause' error is signalled. */
168 static const char s_bad_case_clause
[] = "Bad case clause";
170 /* If a case clause is detected where the <label(s)> element is neither a
171 * proper list nor (in case of the last clause) the syntactic keyword 'else',
172 * a 'Bad case labels' error is signalled. Note: If you encounter this error
173 * for an else-clause which seems to be syntactically correct, check if 'else'
174 * is really a syntactic keyword in that context. If 'else' is bound in the
175 * local or global environment, it is not considered a syntactic keyword, but
176 * will be treated as any other variable. */
177 static const char s_bad_case_labels
[] = "Bad case labels";
179 /* In a case statement all labels have to be distinct. If in a case statement
180 * a label occurs more than once, a 'Duplicate case label' error is
182 static const char s_duplicate_case_label
[] = "Duplicate case label";
184 /* If a cond clause is detected that is not in one of the formats
185 * (<test> <expression1> ...) or (else <expression1> <expression2> ...)
186 * a 'Bad cond clause' error is signalled. */
187 static const char s_bad_cond_clause
[] = "Bad cond clause";
189 /* If a cond clause is detected that uses the alternate '=>' form, but does
190 * not hold a recipient element for the test result, a 'Missing recipient'
191 * error is signalled. */
192 static const char s_missing_recipient
[] = "Missing recipient in";
194 /* If in a position where a variable name is required some other object is
195 * detected, a 'Bad variable' error is signalled. */
196 static const char s_bad_variable
[] = "Bad variable";
198 /* Bindings for forms like 'let' and 'do' have to be given in a proper,
199 * possibly empty list. If any other object is detected in a place where a
200 * list of bindings was required, a 'Bad bindings' error is signalled. */
201 static const char s_bad_bindings
[] = "Bad bindings";
203 /* Depending on the syntactic context, a binding has to be in the format
204 * (<variable> <expression>) or (<variable> <expression1> <expression2>).
205 * If anything else is detected in a place where a binding was expected, a
206 * 'Bad binding' error is signalled. */
207 static const char s_bad_binding
[] = "Bad binding";
209 /* Some syntactic forms don't allow variable names to appear more than once in
210 * a list of bindings. If such a situation is nevertheless detected, a
211 * 'Duplicate binding' error is signalled. */
212 static const char s_duplicate_binding
[] = "Duplicate binding";
214 /* If the exit form of a 'do' expression is not in the format
215 * (<test> <expression> ...)
216 * a 'Bad exit clause' error is signalled. */
217 static const char s_bad_exit_clause
[] = "Bad exit clause";
219 /* The formal function arguments of a lambda expression have to be either a
220 * single symbol or a non-cyclic list. For anything else a 'Bad formals'
221 * error is signalled. */
222 static const char s_bad_formals
[] = "Bad formals";
224 /* If in a lambda expression something else than a symbol is detected at a
225 * place where a formal function argument is required, a 'Bad formal' error is
227 static const char s_bad_formal
[] = "Bad formal";
229 /* If in the arguments list of a lambda expression an argument name occurs
230 * more than once, a 'Duplicate formal' error is signalled. */
231 static const char s_duplicate_formal
[] = "Duplicate formal";
233 /* If the evaluation of an unquote-splicing expression gives something else
234 * than a proper list, a 'Non-list result for unquote-splicing' error is
236 static const char s_splicing
[] = "Non-list result for unquote-splicing";
238 /* If something else than an exact integer is detected as the argument for
239 * @slot-ref and @slot-set!, a 'Bad slot number' error is signalled. */
240 static const char s_bad_slot_number
[] = "Bad slot number";
243 /* Signal a syntax error. We distinguish between the form that caused the
244 * error and the enclosing expression. The error message will print out as
245 * shown in the following pattern. The file name and line number are only
246 * given when they can be determined from the erroneous form or from the
247 * enclosing expression.
249 * <filename>: In procedure memoization:
250 * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
252 SCM_SYMBOL (syntax_error_key
, "syntax-error");
254 /* The prototype is needed to indicate that the function does not return. */
256 syntax_error (const char* const, const SCM
, const SCM
) SCM_NORETURN
;
259 syntax_error (const char* const msg
, const SCM form
, const SCM expr
)
261 const SCM msg_string
= scm_makfrom0str (msg
);
262 SCM filename
= SCM_BOOL_F
;
263 SCM linenr
= SCM_BOOL_F
;
267 if (SCM_CONSP (form
))
269 filename
= scm_source_property (form
, scm_sym_filename
);
270 linenr
= scm_source_property (form
, scm_sym_line
);
273 if (SCM_FALSEP (filename
) && SCM_FALSEP (linenr
) && SCM_CONSP (expr
))
275 filename
= scm_source_property (expr
, scm_sym_filename
);
276 linenr
= scm_source_property (expr
, scm_sym_line
);
279 if (!SCM_UNBNDP (expr
))
281 if (!SCM_FALSEP (filename
))
283 format
= "In file ~S, line ~S: ~A ~S in expression ~S.";
284 args
= scm_list_5 (filename
, linenr
, msg_string
, form
, expr
);
286 else if (!SCM_FALSEP (linenr
))
288 format
= "In line ~S: ~A ~S in expression ~S.";
289 args
= scm_list_4 (linenr
, msg_string
, form
, expr
);
293 format
= "~A ~S in expression ~S.";
294 args
= scm_list_3 (msg_string
, form
, expr
);
299 if (!SCM_FALSEP (filename
))
301 format
= "In file ~S, line ~S: ~A ~S.";
302 args
= scm_list_4 (filename
, linenr
, msg_string
, form
);
304 else if (!SCM_FALSEP (linenr
))
306 format
= "In line ~S: ~A ~S.";
307 args
= scm_list_3 (linenr
, msg_string
, form
);
312 args
= scm_list_2 (msg_string
, form
);
316 scm_error (syntax_error_key
, "memoization", format
, args
, SCM_BOOL_F
);
320 /* Shortcut macros to simplify syntax error handling. */
321 #define ASSERT_SYNTAX(cond, message, form) \
322 { if (!(cond)) syntax_error (message, form, SCM_UNDEFINED); }
323 #define ASSERT_SYNTAX_2(cond, message, form, expr) \
324 { if (!(cond)) syntax_error (message, form, expr); }
330 * Ilocs are memoized references to variables in local environment frames.
331 * They are represented as three values: The relative offset of the
332 * environment frame, the number of the binding within that frame, and a
333 * boolean value indicating whether the binding is the last binding in the
337 #define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc)
338 #define SCM_IFRINC (0x00000100L)
339 #define SCM_ICDR (0x00080000L)
340 #define SCM_IDINC (0x00100000L)
341 #define SCM_IFRAME(n) ((long)((SCM_ICDR-SCM_IFRINC)>>8) \
342 & (SCM_UNPACK (n) >> 8))
343 #define SCM_IDIST(n) (SCM_UNPACK (n) >> 20)
344 #define SCM_ICDRP(n) (SCM_ICDR & SCM_UNPACK (n))
345 #define SCM_IDSTMSK (-SCM_IDINC)
346 #define SCM_MAKE_ILOC(frame_nr, binding_nr, last_p) \
349 + ((binding_nr) << 20) \
350 + ((last_p) ? SCM_ICDR : 0) \
354 scm_i_print_iloc (SCM iloc
, SCM port
)
356 scm_puts ("#@", port
);
357 scm_intprint ((long) SCM_IFRAME (iloc
), 10, port
);
358 scm_putc (SCM_ICDRP (iloc
) ? '-' : '+', port
);
359 scm_intprint ((long) SCM_IDIST (iloc
), 10, port
);
362 #if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
364 SCM
scm_dbg_make_iloc (SCM frame
, SCM binding
, SCM cdrp
);
365 SCM_DEFINE (scm_dbg_make_iloc
, "dbg-make-iloc", 3, 0, 0,
366 (SCM frame
, SCM binding
, SCM cdrp
),
367 "Return a new iloc with frame offset @var{frame}, binding\n"
368 "offset @var{binding} and the cdr flag @var{cdrp}.")
369 #define FUNC_NAME s_scm_dbg_make_iloc
371 SCM_VALIDATE_INUM (1, frame
);
372 SCM_VALIDATE_INUM (2, binding
);
373 return SCM_MAKE_ILOC (SCM_INUM (frame
),
379 SCM
scm_dbg_iloc_p (SCM obj
);
380 SCM_DEFINE (scm_dbg_iloc_p
, "dbg-iloc?", 1, 0, 0,
382 "Return @code{#t} if @var{obj} is an iloc.")
383 #define FUNC_NAME s_scm_dbg_iloc_p
385 return SCM_BOOL (SCM_ILOCP (obj
));
393 /* {Evaluator byte codes (isyms)}
396 #define ISYMNUM(n) (SCM_ITAG8_DATA (n))
398 /* This table must agree with the list of SCM_IM_ constants in tags.h */
399 static const char *const isymnames
[] =
416 "#@call-with-current-continuation",
422 "#@call-with-values",
430 scm_i_print_isym (SCM isym
, SCM port
)
432 const size_t isymnum
= ISYMNUM (isym
);
433 if (isymnum
< (sizeof isymnames
/ sizeof (char *)))
434 scm_puts (isymnames
[isymnum
], port
);
436 scm_ipruk ("isym", isym
, port
);
441 /* The function lookup_symbol is used during memoization: Lookup the symbol in
442 * the environment. If there is no binding for the symbol, SCM_UNDEFINED is
443 * returned. If the symbol is a syntactic keyword, the macro object to which
444 * the symbol is bound is returned. If the symbol is a global variable, the
445 * variable object to which the symbol is bound is returned. Finally, if the
446 * symbol is a local variable the corresponding iloc object is returned. */
448 /* A helper function for lookup_symbol: Try to find the symbol in the top
449 * level environment frame. The function returns SCM_UNDEFINED if the symbol
450 * is unbound, it returns a macro object if the symbol is a syntactic keyword
451 * and it returns a variable object if the symbol is a global variable. */
453 lookup_global_symbol (const SCM symbol
, const SCM top_level
)
455 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
456 if (SCM_FALSEP (variable
))
458 return SCM_UNDEFINED
;
462 const SCM value
= SCM_VARIABLE_REF (variable
);
463 if (SCM_MACROP (value
))
471 lookup_symbol (const SCM symbol
, const SCM env
)
474 unsigned int frame_nr
;
476 for (frame_idx
= env
, frame_nr
= 0;
477 !SCM_NULLP (frame_idx
);
478 frame_idx
= SCM_CDR (frame_idx
), ++frame_nr
)
480 const SCM frame
= SCM_CAR (frame_idx
);
481 if (SCM_CONSP (frame
))
483 /* frame holds a local environment frame */
485 unsigned int symbol_nr
;
487 for (symbol_idx
= SCM_CAR (frame
), symbol_nr
= 0;
488 SCM_CONSP (symbol_idx
);
489 symbol_idx
= SCM_CDR (symbol_idx
), ++symbol_nr
)
491 if (SCM_EQ_P (SCM_CAR (symbol_idx
), symbol
))
492 /* found the symbol, therefore return the iloc */
493 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 0);
495 if (SCM_EQ_P (symbol_idx
, symbol
))
496 /* found the symbol as the last element of the current frame */
497 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 1);
501 /* no more local environment frames */
502 return lookup_global_symbol (symbol
, frame
);
506 return lookup_global_symbol (symbol
, SCM_BOOL_F
);
510 /* Return true if the symbol is - from the point of view of a macro
511 * transformer - a literal in the sense specified in chapter "pattern
512 * language" of R5RS. In the code below, however, we don't match the
513 * definition of R5RS exactly: It returns true if the identifier has no
514 * binding or if it is a syntactic keyword. */
516 literal_p (const SCM symbol
, const SCM env
)
518 const SCM value
= lookup_symbol (symbol
, env
);
519 if (SCM_UNBNDP (value
) || SCM_MACROP (value
))
526 /* Return true if the expression is self-quoting in the memoized code. Thus,
527 * some other objects (like e. g. vectors) are reported as self-quoting, which
528 * according to R5RS would need to be quoted. */
530 is_self_quoting_p (const SCM expr
)
532 if (SCM_CONSP (expr
))
534 else if (SCM_SYMBOLP (expr
))
536 else if (SCM_NULLP (expr
))
542 /* Rewrite the body (which is given as the list of expressions forming the
543 * body) into its internal form. The internal form of a body (<expr> ...) is
544 * just the body itself, but prefixed with an ISYM that denotes to what kind
545 * of outer construct this body belongs: (<ISYM> <expr> ...). A lambda body
546 * starts with SCM_IM_LAMBDA, for example, a body of a let starts with
549 * It is assumed that the calling expression has already made sure that the
550 * body is a proper list. */
552 m_body (SCM op
, SCM exprs
)
554 /* Don't add another ISYM if one is present already. */
555 if (SCM_ISYMP (SCM_CAR (exprs
)))
558 return scm_cons (op
, exprs
);
562 /* The function m_expand_body memoizes a proper list of expressions
563 * forming a body. This function takes care of dealing with internal
564 * defines and transforming them into an equivalent letrec expression.
565 * The list of expressions is rewritten in place. */
567 /* This is a helper function for m_expand_body. It helps to figure out whether
568 * an expression denotes a syntactic keyword. */
570 try_macro_lookup (const SCM expr
, const SCM env
)
572 if (SCM_SYMBOLP (expr
))
574 const SCM value
= lookup_symbol (expr
, env
);
579 return SCM_UNDEFINED
;
583 /* This is a helper function for m_expand_body. It expands user macros,
584 * because for the correct translation of a body we need to know whether they
585 * expand to a definition. */
587 expand_user_macros (SCM expr
, const SCM env
)
589 while (SCM_CONSP (expr
))
591 const SCM car_expr
= SCM_CAR (expr
);
592 const SCM new_car
= expand_user_macros (car_expr
, env
);
593 const SCM value
= try_macro_lookup (new_car
, env
);
595 if (SCM_MACROP (value
) && SCM_MACRO_TYPE (value
) == 2)
597 /* User macros transform code into code. */
598 expr
= scm_call_2 (SCM_MACRO_CODE (value
), expr
, env
);
599 /* We need to reiterate on the transformed code. */
603 /* No user macro: return. */
604 SCM_SETCAR (expr
, new_car
);
612 /* This is a helper function for m_expand_body. It determines if a given form
613 * represents an application of a given built-in macro. The built-in macro to
614 * check for is identified by its syntactic keyword. The form is an
615 * application of the given macro if looking up the car of the form in the
616 * given environment actually returns the built-in macro. */
618 is_system_macro_p (const SCM syntactic_keyword
, const SCM form
, const SCM env
)
620 if (SCM_CONSP (form
))
622 const SCM car_form
= SCM_CAR (form
);
623 const SCM value
= try_macro_lookup (car_form
, env
);
624 if (SCM_BUILTIN_MACRO_P (value
))
626 const SCM macro_name
= scm_macro_name (value
);
627 return SCM_EQ_P (macro_name
, syntactic_keyword
);
635 m_expand_body (const SCM forms
, const SCM env
)
637 /* The first body form can be skipped since it is known to be the ISYM that
638 * was prepended to the body by m_body. */
639 SCM cdr_forms
= SCM_CDR (forms
);
640 SCM form_idx
= cdr_forms
;
641 SCM definitions
= SCM_EOL
;
642 SCM sequence
= SCM_EOL
;
644 /* According to R5RS, the list of body forms consists of two parts: a number
645 * (maybe zero) of definitions, followed by a non-empty sequence of
646 * expressions. Each the definitions and the expressions may be grouped
647 * arbitrarily with begin, but it is not allowed to mix definitions and
648 * expressions. The task of the following loop therefore is to split the
649 * list of body forms into the list of definitions and the sequence of
651 while (!SCM_NULLP (form_idx
))
653 const SCM form
= SCM_CAR (form_idx
);
654 const SCM new_form
= expand_user_macros (form
, env
);
655 if (is_system_macro_p (scm_sym_define
, new_form
, env
))
657 definitions
= scm_cons (new_form
, definitions
);
658 form_idx
= SCM_CDR (form_idx
);
660 else if (is_system_macro_p (scm_sym_begin
, new_form
, env
))
662 /* We have encountered a group of forms. This has to be either a
663 * (possibly empty) group of (possibly further grouped) definitions,
664 * or a non-empty group of (possibly further grouped)
666 const SCM grouped_forms
= SCM_CDR (new_form
);
667 unsigned int found_definition
= 0;
668 unsigned int found_expression
= 0;
669 SCM grouped_form_idx
= grouped_forms
;
670 while (!found_expression
&& !SCM_NULLP (grouped_form_idx
))
672 const SCM inner_form
= SCM_CAR (grouped_form_idx
);
673 const SCM new_inner_form
= expand_user_macros (inner_form
, env
);
674 if (is_system_macro_p (scm_sym_define
, new_inner_form
, env
))
676 found_definition
= 1;
677 definitions
= scm_cons (new_inner_form
, definitions
);
678 grouped_form_idx
= SCM_CDR (grouped_form_idx
);
680 else if (is_system_macro_p (scm_sym_begin
, new_inner_form
, env
))
682 const SCM inner_group
= SCM_CDR (new_inner_form
);
684 = scm_append (scm_list_2 (inner_group
,
685 SCM_CDR (grouped_form_idx
)));
689 /* The group marks the start of the expressions of the body.
690 * We have to make sure that within the same group we have
691 * not encountered a definition before. */
692 ASSERT_SYNTAX (!found_definition
, s_mixed_body_forms
, form
);
693 found_expression
= 1;
694 grouped_form_idx
= SCM_EOL
;
698 /* We have finished processing the group. If we have not yet
699 * encountered an expression we continue processing the forms of the
700 * body to collect further definition forms. Otherwise, the group
701 * marks the start of the sequence of expressions of the body. */
702 if (!found_expression
)
704 form_idx
= SCM_CDR (form_idx
);
714 /* We have detected a form which is no definition. This marks the
715 * start of the sequence of expressions of the body. */
721 /* FIXME: forms does not hold information about the file location. */
722 ASSERT_SYNTAX (SCM_CONSP (sequence
), s_missing_body_expression
, cdr_forms
);
724 if (!SCM_NULLP (definitions
))
728 SCM letrec_expression
;
729 SCM new_letrec_expression
;
731 SCM bindings
= SCM_EOL
;
732 for (definition_idx
= definitions
;
733 !SCM_NULLP (definition_idx
);
734 definition_idx
= SCM_CDR (definition_idx
))
736 const SCM definition
= SCM_CAR (definition_idx
);
737 const SCM canonical_definition
= canonicalize_define (definition
);
738 const SCM binding
= SCM_CDR (canonical_definition
);
739 bindings
= scm_cons (binding
, bindings
);
742 letrec_tail
= scm_cons (bindings
, sequence
);
743 /* FIXME: forms does not hold information about the file location. */
744 letrec_expression
= scm_cons_source (forms
, scm_sym_letrec
, letrec_tail
);
745 new_letrec_expression
= scm_m_letrec (letrec_expression
, env
);
746 SCM_SETCAR (forms
, new_letrec_expression
);
747 SCM_SETCDR (forms
, SCM_EOL
);
751 SCM_SETCAR (forms
, SCM_CAR (sequence
));
752 SCM_SETCDR (forms
, SCM_CDR (sequence
));
757 /* Start of the memoizers for the standard R5RS builtin macros. */
760 SCM_SYNTAX (s_and
, "and", scm_i_makbimacro
, scm_m_and
);
761 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
764 scm_m_and (SCM expr
, SCM env SCM_UNUSED
)
766 const SCM cdr_expr
= SCM_CDR (expr
);
767 const long length
= scm_ilength (cdr_expr
);
769 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
773 /* Special case: (and) is replaced by #t. */
778 SCM_SETCAR (expr
, SCM_IM_AND
);
784 SCM_SYNTAX (s_begin
, "begin", scm_i_makbimacro
, scm_m_begin
);
785 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
788 scm_m_begin (SCM expr
, SCM env SCM_UNUSED
)
790 const SCM cdr_expr
= SCM_CDR (expr
);
791 /* Dirk:FIXME:: An empty begin clause is not generally allowed by R5RS.
792 * That means, there should be a distinction between uses of begin where an
793 * empty clause is OK and where it is not. */
794 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
796 SCM_SETCAR (expr
, SCM_IM_BEGIN
);
801 SCM_SYNTAX (s_case
, "case", scm_i_makbimacro
, scm_m_case
);
802 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
803 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
806 scm_m_case (SCM expr
, SCM env
)
809 SCM all_labels
= SCM_EOL
;
811 /* Check, whether 'else is a literal, i. e. not bound to a value. */
812 const int else_literal_p
= literal_p (scm_sym_else
, env
);
814 const SCM cdr_expr
= SCM_CDR (expr
);
815 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
816 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_clauses
, expr
);
818 clauses
= SCM_CDR (cdr_expr
);
819 while (!SCM_NULLP (clauses
))
823 const SCM clause
= SCM_CAR (clauses
);
824 ASSERT_SYNTAX_2 (scm_ilength (clause
) >= 2,
825 s_bad_case_clause
, clause
, expr
);
827 labels
= SCM_CAR (clause
);
828 if (SCM_CONSP (labels
))
830 ASSERT_SYNTAX_2 (scm_ilength (labels
) >= 0,
831 s_bad_case_labels
, labels
, expr
);
832 all_labels
= scm_append_x (scm_list_2 (labels
, all_labels
));
834 else if (SCM_NULLP (labels
))
836 /* The list of labels is empty. According to R5RS this is allowed.
837 * It means that the sequence of expressions will never be executed.
838 * Therefore, as an optimization, we could remove the whole
843 ASSERT_SYNTAX_2 (SCM_EQ_P (labels
, scm_sym_else
) && else_literal_p
,
844 s_bad_case_labels
, labels
, expr
);
845 ASSERT_SYNTAX_2 (SCM_NULLP (SCM_CDR (clauses
)),
846 s_misplaced_else_clause
, clause
, expr
);
849 /* build the new clause */
850 if (SCM_EQ_P (labels
, scm_sym_else
))
851 SCM_SETCAR (clause
, SCM_IM_ELSE
);
853 clauses
= SCM_CDR (clauses
);
856 /* Check whether all case labels are distinct. */
857 for (; !SCM_NULLP (all_labels
); all_labels
= SCM_CDR (all_labels
))
859 const SCM label
= SCM_CAR (all_labels
);
860 ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (label
, SCM_CDR (all_labels
))),
861 s_duplicate_case_label
, label
, expr
);
864 SCM_SETCAR (expr
, SCM_IM_CASE
);
869 SCM_SYNTAX (s_cond
, "cond", scm_i_makbimacro
, scm_m_cond
);
870 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
871 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
874 scm_m_cond (SCM expr
, SCM env
)
876 /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
877 const int else_literal_p
= literal_p (scm_sym_else
, env
);
878 const int arrow_literal_p
= literal_p (scm_sym_arrow
, env
);
880 const SCM clauses
= SCM_CDR (expr
);
883 ASSERT_SYNTAX (scm_ilength (clauses
) >= 0, s_bad_expression
, expr
);
884 ASSERT_SYNTAX (scm_ilength (clauses
) >= 1, s_missing_clauses
, expr
);
886 for (clause_idx
= clauses
;
887 !SCM_NULLP (clause_idx
);
888 clause_idx
= SCM_CDR (clause_idx
))
892 const SCM clause
= SCM_CAR (clause_idx
);
893 const long length
= scm_ilength (clause
);
894 ASSERT_SYNTAX_2 (length
>= 1, s_bad_cond_clause
, clause
, expr
);
896 test
= SCM_CAR (clause
);
897 if (SCM_EQ_P (test
, scm_sym_else
) && else_literal_p
)
899 const int last_clause_p
= SCM_NULLP (SCM_CDR (clause_idx
));
900 ASSERT_SYNTAX_2 (length
>= 2,
901 s_bad_cond_clause
, clause
, expr
);
902 ASSERT_SYNTAX_2 (last_clause_p
,
903 s_misplaced_else_clause
, clause
, expr
);
904 SCM_SETCAR (clause
, SCM_IM_ELSE
);
907 && SCM_EQ_P (SCM_CADR (clause
), scm_sym_arrow
)
910 ASSERT_SYNTAX_2 (length
> 2, s_missing_recipient
, clause
, expr
);
911 ASSERT_SYNTAX_2 (length
== 3, s_extra_expression
, clause
, expr
);
912 SCM_SETCAR (SCM_CDR (clause
), SCM_IM_ARROW
);
916 SCM_SETCAR (expr
, SCM_IM_COND
);
921 SCM_SYNTAX (s_define
, "define", scm_i_makbimacro
, scm_m_define
);
922 SCM_GLOBAL_SYMBOL (scm_sym_define
, s_define
);
924 /* Guile provides an extension to R5RS' define syntax to represent function
925 * currying in a compact way. With this extension, it is allowed to write
926 * (define <nested-variable> <body>), where <nested-variable> has of one of
927 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
928 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
929 * should be either a sequence of zero or more variables, or a sequence of one
930 * or more variables followed by a space-delimited period and another
931 * variable. Each level of argument nesting wraps the <body> within another
932 * lambda expression. For example, the following forms are allowed, each one
933 * followed by an equivalent, more explicit implementation.
935 * (define ((a b . c) . d) <body>) is equivalent to
936 * (define a (lambda (b . c) (lambda d <body>)))
938 * (define (((a) b) c . d) <body>) is equivalent to
939 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
941 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
942 * module that does not implement this extension. */
944 canonicalize_define (const SCM expr
)
949 const SCM cdr_expr
= SCM_CDR (expr
);
950 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
951 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
953 body
= SCM_CDR (cdr_expr
);
954 variable
= SCM_CAR (cdr_expr
);
955 while (SCM_CONSP (variable
))
957 /* This while loop realizes function currying by variable nesting.
958 * Variable is known to be a nested-variable. In every iteration of the
959 * loop another level of lambda expression is created, starting with the
960 * innermost one. Note that we don't check for duplicate formals here:
961 * This will be done by the memoizer of the lambda expression. */
962 const SCM formals
= SCM_CDR (variable
);
963 const SCM tail
= scm_cons (formals
, body
);
965 /* Add source properties to each new lambda expression: */
966 const SCM lambda
= scm_cons_source (variable
, scm_sym_lambda
, tail
);
968 body
= scm_list_1 (lambda
);
969 variable
= SCM_CAR (variable
);
971 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
), s_bad_variable
, variable
, expr
);
972 ASSERT_SYNTAX (scm_ilength (body
) == 1, s_expression
, expr
);
974 SCM_SETCAR (cdr_expr
, variable
);
975 SCM_SETCDR (cdr_expr
, body
);
979 /* According to section 5.2.1 of R5RS we first have to make sure that the
980 * variable is bound, and then perform the (set! variable expression)
981 * operation. This means, that within the expression we may already assign
982 * values to variable: (define foo (begin (set! foo 1) (+ foo 1))) */
984 scm_m_define (SCM expr
, SCM env
)
986 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), s_bad_define
, expr
);
989 const SCM canonical_definition
= canonicalize_define (expr
);
990 const SCM cdr_canonical_definition
= SCM_CDR (canonical_definition
);
991 const SCM variable
= SCM_CAR (cdr_canonical_definition
);
993 = scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_T
);
994 const SCM value
= scm_eval_car (SCM_CDR (cdr_canonical_definition
), env
);
996 if (SCM_REC_PROCNAMES_P
)
999 while (SCM_MACROP (tmp
))
1000 tmp
= SCM_MACRO_CODE (tmp
);
1001 if (SCM_CLOSUREP (tmp
)
1002 /* Only the first definition determines the name. */
1003 && SCM_FALSEP (scm_procedure_property (tmp
, scm_sym_name
)))
1004 scm_set_procedure_property_x (tmp
, scm_sym_name
, variable
);
1007 SCM_VARIABLE_SET (location
, value
);
1009 return SCM_UNSPECIFIED
;
1014 /* This is a helper function for forms (<keyword> <expression>) that are
1015 * transformed into (#@<keyword> '() <memoized_expression>) in order to allow
1016 * for easy creation of a thunk (i. e. a closure without arguments) using the
1017 * ('() <memoized_expression>) tail of the memoized form. */
1019 memoize_as_thunk_prototype (const SCM expr
, const SCM env SCM_UNUSED
)
1021 const SCM cdr_expr
= SCM_CDR (expr
);
1022 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1023 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1025 SCM_SETCDR (expr
, scm_cons (SCM_EOL
, cdr_expr
));
1031 SCM_SYNTAX (s_delay
, "delay", scm_i_makbimacro
, scm_m_delay
);
1032 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
1034 /* Promises are implemented as closures with an empty parameter list. Thus,
1035 * (delay <expression>) is transformed into (#@delay '() <expression>), where
1036 * the empty list represents the empty parameter list. This representation
1037 * allows for easy creation of the closure during evaluation. */
1039 scm_m_delay (SCM expr
, SCM env
)
1041 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1042 SCM_SETCAR (new_expr
, SCM_IM_DELAY
);
1047 SCM_SYNTAX(s_do
, "do", scm_i_makbimacro
, scm_m_do
);
1048 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
1050 /* DO gets the most radically altered syntax. The order of the vars is
1051 * reversed here. During the evaluation this allows for simple consing of the
1052 * results of the inits and steps:
1054 (do ((<var1> <init1> <step1>)
1062 (#@do (<init1> <init2> ... <initn>)
1063 (varn ... var2 var1)
1066 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
1069 scm_m_do (SCM expr
, SCM env SCM_UNUSED
)
1071 SCM variables
= SCM_EOL
;
1072 SCM init_forms
= SCM_EOL
;
1073 SCM step_forms
= SCM_EOL
;
1080 const SCM cdr_expr
= SCM_CDR (expr
);
1081 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1082 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1084 /* Collect variables, init and step forms. */
1085 binding_idx
= SCM_CAR (cdr_expr
);
1086 ASSERT_SYNTAX_2 (scm_ilength (binding_idx
) >= 0,
1087 s_bad_bindings
, binding_idx
, expr
);
1088 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1090 const SCM binding
= SCM_CAR (binding_idx
);
1091 const long length
= scm_ilength (binding
);
1092 ASSERT_SYNTAX_2 (length
== 2 || length
== 3,
1093 s_bad_binding
, binding
, expr
);
1096 const SCM name
= SCM_CAR (binding
);
1097 const SCM init
= SCM_CADR (binding
);
1098 const SCM step
= (length
== 2) ? name
: SCM_CADDR (binding
);
1099 ASSERT_SYNTAX_2 (SCM_SYMBOLP (name
), s_bad_variable
, name
, expr
);
1100 ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (name
, variables
)),
1101 s_duplicate_binding
, name
, expr
);
1103 variables
= scm_cons (name
, variables
);
1104 init_forms
= scm_cons (init
, init_forms
);
1105 step_forms
= scm_cons (step
, step_forms
);
1108 init_forms
= scm_reverse_x (init_forms
, SCM_UNDEFINED
);
1109 step_forms
= scm_reverse_x (step_forms
, SCM_UNDEFINED
);
1111 /* Memoize the test form and the exit sequence. */
1112 cddr_expr
= SCM_CDR (cdr_expr
);
1113 exit_clause
= SCM_CAR (cddr_expr
);
1114 ASSERT_SYNTAX_2 (scm_ilength (exit_clause
) >= 1,
1115 s_bad_exit_clause
, exit_clause
, expr
);
1117 commands
= SCM_CDR (cddr_expr
);
1118 tail
= scm_cons2 (exit_clause
, commands
, step_forms
);
1119 tail
= scm_cons2 (init_forms
, variables
, tail
);
1120 SCM_SETCAR (expr
, SCM_IM_DO
);
1121 SCM_SETCDR (expr
, tail
);
1126 SCM_SYNTAX (s_if
, "if", scm_i_makbimacro
, scm_m_if
);
1127 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
1130 scm_m_if (SCM expr
, SCM env SCM_UNUSED
)
1132 const SCM cdr_expr
= SCM_CDR (expr
);
1133 const long length
= scm_ilength (cdr_expr
);
1134 ASSERT_SYNTAX (length
== 2 || length
== 3, s_expression
, expr
);
1135 SCM_SETCAR (expr
, SCM_IM_IF
);
1140 SCM_SYNTAX (s_lambda
, "lambda", scm_i_makbimacro
, scm_m_lambda
);
1141 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
1143 /* A helper function for memoize_lambda to support checking for duplicate
1144 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
1145 * LIST or to the cdr of the last cons. Therefore, LIST may have any of the
1146 * forms that a formal argument can have:
1147 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
1149 c_improper_memq (SCM obj
, SCM list
)
1151 for (; SCM_CONSP (list
); list
= SCM_CDR (list
))
1153 if (SCM_EQ_P (SCM_CAR (list
), obj
))
1156 return SCM_EQ_P (list
, obj
);
1160 scm_m_lambda (SCM expr
, SCM env SCM_UNUSED
)
1169 const SCM cdr_expr
= SCM_CDR (expr
);
1170 const long length
= scm_ilength (cdr_expr
);
1171 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1172 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1174 /* Before iterating the list of formal arguments, make sure the formals
1175 * actually are given as either a symbol or a non-cyclic list. */
1176 formals
= SCM_CAR (cdr_expr
);
1177 if (SCM_CONSP (formals
))
1179 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
1180 * detected, report a 'Bad formals' error. */
1184 ASSERT_SYNTAX_2 (SCM_SYMBOLP (formals
) || SCM_NULLP (formals
),
1185 s_bad_formals
, formals
, expr
);
1188 /* Now iterate the list of formal arguments to check if all formals are
1189 * symbols, and that there are no duplicates. */
1190 formals_idx
= formals
;
1191 while (SCM_CONSP (formals_idx
))
1193 const SCM formal
= SCM_CAR (formals_idx
);
1194 const SCM next_idx
= SCM_CDR (formals_idx
);
1195 ASSERT_SYNTAX_2 (SCM_SYMBOLP (formal
), s_bad_formal
, formal
, expr
);
1196 ASSERT_SYNTAX_2 (!c_improper_memq (formal
, next_idx
),
1197 s_duplicate_formal
, formal
, expr
);
1198 formals_idx
= next_idx
;
1200 ASSERT_SYNTAX_2 (SCM_NULLP (formals_idx
) || SCM_SYMBOLP (formals_idx
),
1201 s_bad_formal
, formals_idx
, expr
);
1203 /* Memoize the body. Keep a potential documentation string. */
1204 /* Dirk:FIXME:: We should probably extract the documentation string to
1205 * some external database. Otherwise it will slow down execution, since
1206 * the documentation string will have to be skipped with every execution
1207 * of the closure. */
1208 cddr_expr
= SCM_CDR (cdr_expr
);
1209 documentation
= (length
>= 3 && SCM_STRINGP (SCM_CAR (cddr_expr
)));
1210 body
= documentation
? SCM_CDR (cddr_expr
) : cddr_expr
;
1211 new_body
= m_body (SCM_IM_LAMBDA
, body
);
1213 SCM_SETCAR (expr
, SCM_IM_LAMBDA
);
1215 SCM_SETCDR (cddr_expr
, new_body
);
1217 SCM_SETCDR (cdr_expr
, new_body
);
1222 /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
1224 check_bindings (const SCM bindings
, const SCM expr
)
1228 ASSERT_SYNTAX_2 (scm_ilength (bindings
) >= 0,
1229 s_bad_bindings
, bindings
, expr
);
1231 binding_idx
= bindings
;
1232 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1234 SCM name
; /* const */
1236 const SCM binding
= SCM_CAR (binding_idx
);
1237 ASSERT_SYNTAX_2 (scm_ilength (binding
) == 2,
1238 s_bad_binding
, binding
, expr
);
1240 name
= SCM_CAR (binding
);
1241 ASSERT_SYNTAX_2 (SCM_SYMBOLP (name
), s_bad_variable
, name
, expr
);
1246 /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
1247 * transformed to the lists (vn ... v2 v1) and (i1 i2 ... in). That is, the
1248 * variables are returned in a list with their order reversed, and the init
1249 * forms are returned in a list in the same order as they are given in the
1250 * bindings. If a duplicate variable name is detected, an error is
1253 transform_bindings (
1254 const SCM bindings
, const SCM expr
,
1255 SCM
*const rvarptr
, SCM
*const initptr
)
1257 SCM rvariables
= SCM_EOL
;
1258 SCM rinits
= SCM_EOL
;
1259 SCM binding_idx
= bindings
;
1260 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1262 const SCM binding
= SCM_CAR (binding_idx
);
1263 const SCM cdr_binding
= SCM_CDR (binding
);
1264 const SCM name
= SCM_CAR (binding
);
1265 ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (name
, rvariables
)),
1266 s_duplicate_binding
, name
, expr
);
1267 rvariables
= scm_cons (name
, rvariables
);
1268 rinits
= scm_cons (SCM_CAR (cdr_binding
), rinits
);
1270 *rvarptr
= rvariables
;
1271 *initptr
= scm_reverse_x (rinits
, SCM_UNDEFINED
);
1275 SCM_SYNTAX(s_let
, "let", scm_i_makbimacro
, scm_m_let
);
1276 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
1278 /* This function is a helper function for memoize_let. It transforms
1279 * (let name ((var init) ...) body ...) into
1280 * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
1281 * and memoizes the expression. It is assumed that the caller has checked
1282 * that name is a symbol and that there are bindings and a body. */
1284 memoize_named_let (const SCM expr
, const SCM env SCM_UNUSED
)
1290 const SCM cdr_expr
= SCM_CDR (expr
);
1291 const SCM name
= SCM_CAR (cdr_expr
);
1292 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1293 const SCM bindings
= SCM_CAR (cddr_expr
);
1294 check_bindings (bindings
, expr
);
1296 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1297 variables
= scm_reverse_x (rvariables
, SCM_UNDEFINED
);
1300 const SCM let_body
= SCM_CDR (cddr_expr
);
1301 const SCM lambda_body
= m_body (SCM_IM_LET
, let_body
);
1302 const SCM lambda_tail
= scm_cons (variables
, lambda_body
);
1303 const SCM lambda_form
= scm_cons_source (expr
, scm_sym_lambda
, lambda_tail
);
1305 const SCM rvar
= scm_list_1 (name
);
1306 const SCM init
= scm_list_1 (lambda_form
);
1307 const SCM body
= m_body (SCM_IM_LET
, scm_list_1 (name
));
1308 const SCM letrec_tail
= scm_cons (rvar
, scm_cons (init
, body
));
1309 const SCM letrec_form
= scm_cons_source (expr
, SCM_IM_LETREC
, letrec_tail
);
1310 return scm_cons_source (expr
, letrec_form
, inits
);
1314 /* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1315 * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
1317 scm_m_let (SCM expr
, SCM env
)
1321 const SCM cdr_expr
= SCM_CDR (expr
);
1322 const long length
= scm_ilength (cdr_expr
);
1323 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1324 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1326 bindings
= SCM_CAR (cdr_expr
);
1327 if (SCM_SYMBOLP (bindings
))
1329 ASSERT_SYNTAX (length
>= 3, s_missing_expression
, expr
);
1330 return memoize_named_let (expr
, env
);
1333 check_bindings (bindings
, expr
);
1334 if (SCM_NULLP (bindings
) || SCM_NULLP (SCM_CDR (bindings
)))
1336 /* Special case: no bindings or single binding => let* is faster. */
1337 const SCM body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1338 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), bindings
, body
), env
);
1345 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1348 const SCM new_body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1349 const SCM new_tail
= scm_cons2 (rvariables
, inits
, new_body
);
1350 SCM_SETCAR (expr
, SCM_IM_LET
);
1351 SCM_SETCDR (expr
, new_tail
);
1358 SCM_SYNTAX (s_letstar
, "let*", scm_i_makbimacro
, scm_m_letstar
);
1359 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
1361 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1362 * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
1364 scm_m_letstar (SCM expr
, SCM env SCM_UNUSED
)
1369 const SCM cdr_expr
= SCM_CDR (expr
);
1370 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1371 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1373 binding_idx
= SCM_CAR (cdr_expr
);
1374 check_bindings (binding_idx
, expr
);
1376 /* Transform ((v1 i1) (v2 i2) ...) into (v1 i1 v2 i2 ...). The
1377 * transformation is done in place. At the beginning of one iteration of
1378 * the loop the variable binding_idx holds the form
1379 * P1:( (vn . P2:(in . ())) . P3:( (vn+1 in+1) ... ) ),
1380 * where P1, P2 and P3 indicate the pairs, that are relevant for the
1381 * transformation. P1 and P2 are modified in the loop, P3 remains
1382 * untouched. After the execution of the loop, P1 will hold
1383 * P1:( vn . P2:(in . P3:( (vn+1 in+1) ... )) )
1384 * and binding_idx will hold P3. */
1385 while (!SCM_NULLP (binding_idx
))
1387 const SCM cdr_binding_idx
= SCM_CDR (binding_idx
); /* remember P3 */
1388 const SCM binding
= SCM_CAR (binding_idx
);
1389 const SCM name
= SCM_CAR (binding
);
1390 const SCM cdr_binding
= SCM_CDR (binding
);
1392 SCM_SETCDR (cdr_binding
, cdr_binding_idx
); /* update P2 */
1393 SCM_SETCAR (binding_idx
, name
); /* update P1 */
1394 SCM_SETCDR (binding_idx
, cdr_binding
); /* update P1 */
1396 binding_idx
= cdr_binding_idx
; /* continue with P3 */
1399 new_body
= m_body (SCM_IM_LETSTAR
, SCM_CDR (cdr_expr
));
1400 SCM_SETCAR (expr
, SCM_IM_LETSTAR
);
1401 /* the bindings have been changed in place */
1402 SCM_SETCDR (cdr_expr
, new_body
);
1407 SCM_SYNTAX(s_letrec
, "letrec", scm_i_makbimacro
, scm_m_letrec
);
1408 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
1411 scm_m_letrec (SCM expr
, SCM env
)
1415 const SCM cdr_expr
= SCM_CDR (expr
);
1416 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1417 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1419 bindings
= SCM_CAR (cdr_expr
);
1420 if (SCM_NULLP (bindings
))
1422 /* no bindings, let* is executed faster */
1423 SCM body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1424 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), SCM_EOL
, body
), env
);
1432 check_bindings (bindings
, expr
);
1433 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1434 new_body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1435 return scm_cons2 (SCM_IM_LETREC
, rvariables
, scm_cons (inits
, new_body
));
1440 SCM_SYNTAX (s_or
, "or", scm_i_makbimacro
, scm_m_or
);
1441 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
1444 scm_m_or (SCM expr
, SCM env SCM_UNUSED
)
1446 const SCM cdr_expr
= SCM_CDR (expr
);
1447 const long length
= scm_ilength (cdr_expr
);
1449 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1453 /* Special case: (or) is replaced by #f. */
1458 SCM_SETCAR (expr
, SCM_IM_OR
);
1464 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
1465 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
1466 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
1467 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
1469 /* Internal function to handle a quasiquotation: 'form' is the parameter in
1470 * the call (quasiquotation form), 'env' is the environment where unquoted
1471 * expressions will be evaluated, and 'depth' is the current quasiquotation
1472 * nesting level and is known to be greater than zero. */
1474 iqq (SCM form
, SCM env
, unsigned long int depth
)
1476 if (SCM_CONSP (form
))
1478 const SCM tmp
= SCM_CAR (form
);
1479 if (SCM_EQ_P (tmp
, scm_sym_quasiquote
))
1481 const SCM args
= SCM_CDR (form
);
1482 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1483 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
1485 else if (SCM_EQ_P (tmp
, scm_sym_unquote
))
1487 const SCM args
= SCM_CDR (form
);
1488 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1490 return scm_eval_car (args
, env
);
1492 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
1494 else if (SCM_CONSP (tmp
)
1495 && SCM_EQ_P (SCM_CAR (tmp
), scm_sym_uq_splicing
))
1497 const SCM args
= SCM_CDR (tmp
);
1498 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1501 const SCM list
= scm_eval_car (args
, env
);
1502 const SCM rest
= SCM_CDR (form
);
1503 ASSERT_SYNTAX_2 (scm_ilength (list
) >= 0,
1504 s_splicing
, list
, form
);
1505 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
1508 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
1509 iqq (SCM_CDR (form
), env
, depth
));
1512 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
1513 iqq (SCM_CDR (form
), env
, depth
));
1515 else if (SCM_VECTORP (form
))
1517 size_t i
= SCM_VECTOR_LENGTH (form
);
1518 SCM
const *const data
= SCM_VELTS (form
);
1521 tmp
= scm_cons (data
[--i
], tmp
);
1522 scm_remember_upto_here_1 (form
);
1523 return scm_vector (iqq (tmp
, env
, depth
));
1530 scm_m_quasiquote (SCM expr
, SCM env
)
1532 const SCM cdr_expr
= SCM_CDR (expr
);
1533 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1534 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1535 return iqq (SCM_CAR (cdr_expr
), env
, 1);
1539 SCM_SYNTAX (s_quote
, "quote", scm_i_makbimacro
, scm_m_quote
);
1540 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
1543 scm_m_quote (SCM expr
, SCM env SCM_UNUSED
)
1547 const SCM cdr_expr
= SCM_CDR (expr
);
1548 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1549 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1550 quotee
= SCM_CAR (cdr_expr
);
1551 if (is_self_quoting_p (quotee
))
1553 SCM_SETCAR (expr
, SCM_IM_QUOTE
);
1558 /* Will go into the RnRS module when Guile is factorized.
1559 SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
1560 static const char s_set_x
[] = "set!";
1561 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, s_set_x
);
1564 scm_m_set_x (SCM expr
, SCM env SCM_UNUSED
)
1569 const SCM cdr_expr
= SCM_CDR (expr
);
1570 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1571 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1572 variable
= SCM_CAR (cdr_expr
);
1574 /* Memoize the variable form. */
1575 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
), s_bad_variable
, variable
, expr
);
1576 new_variable
= lookup_symbol (variable
, env
);
1577 ASSERT_SYNTAX (!SCM_MACROP (new_variable
), s_macro_keyword
, variable
);
1578 /* Leave the memoization of unbound symbols to lazy memoization: */
1579 if (SCM_UNBNDP (new_variable
))
1580 new_variable
= variable
;
1582 SCM_SETCAR (expr
, SCM_IM_SET_X
);
1583 SCM_SETCAR (cdr_expr
, new_variable
);
1588 /* Start of the memoizers for non-R5RS builtin macros. */
1591 SCM_SYNTAX (s_atapply
, "@apply", scm_i_makbimacro
, scm_m_apply
);
1592 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1593 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1596 scm_m_apply (SCM expr
, SCM env SCM_UNUSED
)
1598 const SCM cdr_expr
= SCM_CDR (expr
);
1599 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1600 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_missing_expression
, expr
);
1602 SCM_SETCAR (expr
, SCM_IM_APPLY
);
1607 SCM_SYNTAX (s_atbind
, "@bind", scm_i_makbimacro
, scm_m_atbind
);
1609 /* FIXME: The following explanation should go into the documentation: */
1610 /* (@bind ((var init) ...) body ...) will assign the values of the `init's to
1611 * the global variables named by `var's (symbols, not evaluated), creating
1612 * them if they don't exist, executes body, and then restores the previous
1613 * values of the `var's. Additionally, whenever control leaves body, the
1614 * values of the `var's are saved and restored when control returns. It is an
1615 * error when a symbol appears more than once among the `var's. All `init's
1616 * are evaluated before any `var' is set.
1618 * Think of this as `let' for dynamic scope.
1621 /* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into
1622 * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...).
1624 * FIXME - also implement `@bind*'.
1627 scm_m_atbind (SCM expr
, SCM env
)
1634 const SCM top_level
= scm_env_top_level (env
);
1636 const SCM cdr_expr
= SCM_CDR (expr
);
1637 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1638 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1639 bindings
= SCM_CAR (cdr_expr
);
1640 check_bindings (bindings
, expr
);
1641 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1643 for (variable_idx
= rvariables
;
1644 !SCM_NULLP (variable_idx
);
1645 variable_idx
= SCM_CDR (variable_idx
))
1647 /* The first call to scm_sym2var will look beyond the current module,
1648 * while the second call wont. */
1649 const SCM variable
= SCM_CAR (variable_idx
);
1650 SCM new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_F
);
1651 if (SCM_FALSEP (new_variable
))
1652 new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_T
);
1653 SCM_SETCAR (variable_idx
, new_variable
);
1656 SCM_SETCAR (expr
, SCM_IM_BIND
);
1657 SCM_SETCAR (cdr_expr
, scm_cons (rvariables
, inits
));
1662 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_i_makbimacro
, scm_m_cont
);
1663 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, s_atcall_cc
);
1666 scm_m_cont (SCM expr
, SCM env SCM_UNUSED
)
1668 const SCM cdr_expr
= SCM_CDR (expr
);
1669 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1670 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1672 SCM_SETCAR (expr
, SCM_IM_CONT
);
1677 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_i_makbimacro
, scm_m_at_call_with_values
);
1678 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
1681 scm_m_at_call_with_values (SCM expr
, SCM env SCM_UNUSED
)
1683 const SCM cdr_expr
= SCM_CDR (expr
);
1684 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1685 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1687 SCM_SETCAR (expr
, SCM_IM_CALL_WITH_VALUES
);
1692 SCM_SYNTAX (s_future
, "future", scm_i_makbimacro
, scm_m_future
);
1693 SCM_GLOBAL_SYMBOL (scm_sym_future
, s_future
);
1695 /* Like promises, futures are implemented as closures with an empty
1696 * parameter list. Thus, (future <expression>) is transformed into
1697 * (#@future '() <expression>), where the empty list represents the
1698 * empty parameter list. This representation allows for easy creation
1699 * of the closure during evaluation. */
1701 scm_m_future (SCM expr
, SCM env
)
1703 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1704 SCM_SETCAR (new_expr
, SCM_IM_FUTURE
);
1709 SCM_SYNTAX (s_gset_x
, "set!", scm_i_makbimacro
, scm_m_generalized_set_x
);
1710 SCM_SYMBOL (scm_sym_setter
, "setter");
1713 scm_m_generalized_set_x (SCM expr
, SCM env
)
1715 SCM target
, exp_target
;
1717 const SCM cdr_expr
= SCM_CDR (expr
);
1718 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1719 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1721 target
= SCM_CAR (cdr_expr
);
1722 if (!SCM_CONSP (target
))
1725 return scm_m_set_x (expr
, env
);
1729 /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */
1730 /* Macroexpanding the target might return things of the form
1731 (begin <atom>). In that case, <atom> must be a symbol or a
1732 variable and we memoize to (set! <atom> ...).
1734 exp_target
= scm_macroexp (target
, env
);
1735 if (SCM_EQ_P (SCM_CAR (exp_target
), SCM_IM_BEGIN
)
1736 && !SCM_NULLP (SCM_CDR (exp_target
))
1737 && SCM_NULLP (SCM_CDDR (exp_target
)))
1739 exp_target
= SCM_CADR (exp_target
);
1740 ASSERT_SYNTAX_2 (SCM_SYMBOLP (exp_target
)
1741 || SCM_VARIABLEP (exp_target
),
1742 s_bad_variable
, exp_target
, expr
);
1743 return scm_cons (SCM_IM_SET_X
, scm_cons (exp_target
,
1744 SCM_CDR (cdr_expr
)));
1748 const SCM setter_proc_tail
= scm_list_1 (SCM_CAR (target
));
1749 const SCM setter_proc
= scm_cons_source (expr
, scm_sym_setter
,
1752 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1753 const SCM setter_args
= scm_append_x (scm_list_2 (SCM_CDR (target
),
1756 SCM_SETCAR (expr
, setter_proc
);
1757 SCM_SETCDR (expr
, setter_args
);
1764 /* @slot-ref is bound privately in the (oop goops) module from goops.c. As
1765 * soon as the module system allows us to more freely create bindings in
1766 * arbitrary modules during the startup phase, the code from goops.c should be
1769 scm_m_atslot_ref (SCM expr
, SCM env SCM_UNUSED
)
1773 const SCM cdr_expr
= SCM_CDR (expr
);
1774 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1775 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1776 slot_nr
= SCM_CADR (cdr_expr
);
1777 ASSERT_SYNTAX_2 (SCM_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
1779 SCM_SETCAR (expr
, SCM_IM_SLOT_REF
);
1784 /* @slot-set! is bound privately in the (oop goops) module from goops.c. As
1785 * soon as the module system allows us to more freely create bindings in
1786 * arbitrary modules during the startup phase, the code from goops.c should be
1789 scm_m_atslot_set_x (SCM expr
, SCM env SCM_UNUSED
)
1793 const SCM cdr_expr
= SCM_CDR (expr
);
1794 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1795 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 3, s_expression
, expr
);
1796 slot_nr
= SCM_CADR (cdr_expr
);
1797 ASSERT_SYNTAX_2 (SCM_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
1799 SCM_SETCAR (expr
, SCM_IM_SLOT_SET_X
);
1804 #if SCM_ENABLE_ELISP
1806 static const char s_defun
[] = "Symbol's function definition is void";
1808 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_i_makbimacro
, scm_m_nil_cond
);
1810 /* nil-cond expressions have the form
1811 * (nil-cond COND VAL COND VAL ... ELSEVAL) */
1813 scm_m_nil_cond (SCM expr
, SCM env SCM_UNUSED
)
1815 const long length
= scm_ilength (SCM_CDR (expr
));
1816 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1817 ASSERT_SYNTAX (length
>= 1 && (length
% 2) == 1, s_expression
, expr
);
1819 SCM_SETCAR (expr
, SCM_IM_NIL_COND
);
1824 SCM_SYNTAX (s_atfop
, "@fop", scm_i_makbimacro
, scm_m_atfop
);
1826 /* The @fop-macro handles procedure and macro applications for elisp. The
1827 * input expression must have the form
1828 * (@fop <var> (transformer-macro <expr> ...))
1829 * where <var> must be a symbol. The expression is transformed into the
1830 * memoized form of either
1831 * (apply <un-aliased var> (transformer-macro <expr> ...))
1832 * if the value of var (across all aliasing) is not a macro, or
1833 * (<un-aliased var> <expr> ...)
1834 * if var is a macro. */
1836 scm_m_atfop (SCM expr
, SCM env SCM_UNUSED
)
1841 const SCM cdr_expr
= SCM_CDR (expr
);
1842 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1843 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 1, s_missing_expression
, expr
);
1845 symbol
= SCM_CAR (cdr_expr
);
1846 ASSERT_SYNTAX_2 (SCM_SYMBOLP (symbol
), s_bad_variable
, symbol
, expr
);
1848 location
= scm_symbol_fref (symbol
);
1849 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
1851 /* The elisp function `defalias' allows to define aliases for symbols. To
1852 * look up such definitions, the chain of symbol definitions has to be
1853 * followed up to the terminal symbol. */
1854 while (SCM_SYMBOLP (SCM_VARIABLE_REF (location
)))
1856 const SCM alias
= SCM_VARIABLE_REF (location
);
1857 location
= scm_symbol_fref (alias
);
1858 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
1861 /* Memoize the value location belonging to the terminal symbol. */
1862 SCM_SETCAR (cdr_expr
, location
);
1864 if (!SCM_MACROP (SCM_VARIABLE_REF (location
)))
1866 /* Since the location does not contain a macro, the form is a procedure
1867 * application. Replace `@fop' by `@apply' and transform the expression
1868 * including the `transformer-macro'. */
1869 SCM_SETCAR (expr
, SCM_IM_APPLY
);
1874 /* Since the location contains a macro, the arguments should not be
1875 * transformed, so the `transformer-macro' is cut out. The resulting
1876 * expression starts with the memoized variable, that is at the cdr of
1877 * the input expression. */
1878 SCM_SETCDR (cdr_expr
, SCM_CDADR (cdr_expr
));
1883 #endif /* SCM_ENABLE_ELISP */
1886 #if (SCM_ENABLE_DEPRECATED == 1)
1888 /* Deprecated in guile 1.7.0 on 2003-11-09. */
1890 scm_m_expand_body (SCM exprs
, SCM env
)
1892 scm_c_issue_deprecation_warning
1893 ("`scm_m_expand_body' is deprecated.");
1894 m_expand_body (exprs
, env
);
1899 SCM_SYNTAX (s_undefine
, "undefine", scm_makacro
, scm_m_undefine
);
1902 scm_m_undefine (SCM expr
, SCM env
)
1907 const SCM cdr_expr
= SCM_CDR (expr
);
1908 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), "Bad undefine placement in", expr
);
1909 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1910 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1912 variable
= SCM_CAR (cdr_expr
);
1913 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
), s_bad_variable
, variable
, expr
);
1914 location
= scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_F
);
1915 ASSERT_SYNTAX_2 (!SCM_FALSEP (location
)
1916 && !SCM_UNBNDP (SCM_VARIABLE_REF (location
)),
1917 "variable already unbound ", variable
, expr
);
1918 SCM_VARIABLE_SET (location
, SCM_UNDEFINED
);
1919 return SCM_UNSPECIFIED
;
1924 scm_macroexp (SCM x
, SCM env
)
1926 SCM res
, proc
, orig_sym
;
1928 /* Don't bother to produce error messages here. We get them when we
1929 eventually execute the code for real. */
1932 orig_sym
= SCM_CAR (x
);
1933 if (!SCM_SYMBOLP (orig_sym
))
1937 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1938 if (proc_ptr
== NULL
)
1940 /* We have lost the race. */
1946 /* Only handle memoizing macros. `Acros' and `macros' are really
1947 special forms and should not be evaluated here. */
1949 if (!SCM_MACROP (proc
)
1950 || (SCM_MACRO_TYPE (proc
) != 2 && !SCM_BUILTIN_MACRO_P (proc
)))
1953 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
1954 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
1956 if (scm_ilength (res
) <= 0)
1957 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
1960 SCM_SETCAR (x
, SCM_CAR (res
));
1961 SCM_SETCDR (x
, SCM_CDR (res
));
1969 /*****************************************************************************/
1970 /*****************************************************************************/
1971 /* The definitions for unmemoization start here. */
1972 /*****************************************************************************/
1973 /*****************************************************************************/
1975 #define SCM_BIT7(x) (127 & SCM_UNPACK (x))
1977 SCM_SYMBOL (sym_three_question_marks
, "???");
1980 /* scm_unmemocopy takes a memoized expression together with its
1981 * environment and rewrites it to its original form. Thus, it is the
1982 * inversion of the rewrite rules above. The procedure is not
1983 * optimized for speed. It's used in scm_iprin1 when printing the
1984 * code of a closure, in scm_procedure_source, in display_frame when
1985 * generating the source for a stackframe in a backtrace, and in
1986 * display_expression.
1988 * Unmemoizing is not a reliable process. You cannot in general
1989 * expect to get the original source back.
1991 * However, GOOPS currently relies on this for method compilation.
1992 * This ought to change.
1996 build_binding_list (SCM rnames
, SCM rinits
)
1998 SCM bindings
= SCM_EOL
;
1999 while (!SCM_NULLP (rnames
))
2001 SCM binding
= scm_list_2 (SCM_CAR (rnames
), SCM_CAR (rinits
));
2002 bindings
= scm_cons (binding
, bindings
);
2003 rnames
= SCM_CDR (rnames
);
2004 rinits
= SCM_CDR (rinits
);
2011 unmemocar (SCM form
, SCM env
)
2013 if (!SCM_CONSP (form
))
2017 SCM c
= SCM_CAR (form
);
2018 if (SCM_VARIABLEP (c
))
2020 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
2021 if (SCM_FALSEP (sym
))
2022 sym
= sym_three_question_marks
;
2023 SCM_SETCAR (form
, sym
);
2025 else if (SCM_ILOCP (c
))
2027 unsigned long int ir
;
2029 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
2030 env
= SCM_CDR (env
);
2031 env
= SCM_CAAR (env
);
2032 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
2033 env
= SCM_CDR (env
);
2035 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
2043 scm_unmemocopy (SCM x
, SCM env
)
2048 if (SCM_VECTORP (x
))
2050 return scm_list_2 (scm_sym_quote
, x
);
2052 else if (!SCM_CONSP (x
))
2055 p
= scm_whash_lookup (scm_source_whash
, x
);
2056 if (SCM_ISYMP (SCM_CAR (x
)))
2058 switch (ISYMNUM (SCM_CAR (x
)))
2060 case (ISYMNUM (SCM_IM_AND
)):
2061 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
2063 case (ISYMNUM (SCM_IM_BEGIN
)):
2064 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
2066 case (ISYMNUM (SCM_IM_CASE
)):
2067 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
2069 case (ISYMNUM (SCM_IM_COND
)):
2070 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
2072 case (ISYMNUM (SCM_IM_DO
)):
2074 /* format: (#@do (i1 ... ik) (nk ... n1) (test) (body) s1 ... sk),
2075 * where ix is an initializer for a local variable, nx is the name
2076 * of the local variable, test is the test clause of the do loop,
2077 * body is the body of the do loop and sx are the step clauses for
2078 * the local variables. */
2079 SCM names
, inits
, test
, memoized_body
, steps
, bindings
;
2082 inits
= scm_reverse (scm_unmemocopy (SCM_CAR (x
), env
));
2084 names
= SCM_CAR (x
);
2085 env
= SCM_EXTEND_ENV (names
, SCM_EOL
, env
);
2087 test
= scm_unmemocopy (SCM_CAR (x
), env
);
2089 memoized_body
= SCM_CAR (x
);
2091 steps
= scm_reverse (scm_unmemocopy (x
, env
));
2093 /* build transformed binding list */
2095 while (!SCM_NULLP (names
))
2097 SCM name
= SCM_CAR (names
);
2098 SCM init
= SCM_CAR (inits
);
2099 SCM step
= SCM_CAR (steps
);
2100 step
= SCM_EQ_P (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
2102 bindings
= scm_cons (scm_cons2 (name
, init
, step
), bindings
);
2104 names
= SCM_CDR (names
);
2105 inits
= SCM_CDR (inits
);
2106 steps
= SCM_CDR (steps
);
2108 z
= scm_cons (test
, SCM_UNSPECIFIED
);
2109 ls
= scm_cons2 (scm_sym_do
, bindings
, z
);
2111 x
= scm_cons (SCM_BOOL_F
, memoized_body
);
2114 case (ISYMNUM (SCM_IM_IF
)):
2115 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
2117 case (ISYMNUM (SCM_IM_LET
)):
2119 /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),
2120 * where nx is the name of a local variable, ix is an initializer
2121 * for the local variable and by are the body clauses. */
2122 SCM rnames
, rinits
, bindings
;
2125 rnames
= SCM_CAR (x
);
2127 rinits
= scm_reverse (scm_unmemocopy (SCM_CAR (x
), env
));
2128 env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
2130 bindings
= build_binding_list (rnames
, rinits
);
2131 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
2132 ls
= scm_cons (scm_sym_let
, z
);
2135 case (ISYMNUM (SCM_IM_LETREC
)):
2137 /* format: (#@letrec (vn ... v2 v1) (i1 i2 ... in) b1 ...),
2138 * where vx is the name of a local variable, ix is an initializer
2139 * for the local variable and by are the body clauses. */
2140 SCM rnames
, rinits
, bindings
;
2143 rnames
= SCM_CAR (x
);
2144 env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
2146 rinits
= scm_reverse (scm_unmemocopy (SCM_CAR (x
), env
));
2148 bindings
= build_binding_list (rnames
, rinits
);
2149 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
2150 ls
= scm_cons (scm_sym_letrec
, z
);
2153 case (ISYMNUM (SCM_IM_LETSTAR
)):
2161 env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2165 SCM copy
= scm_unmemocopy (SCM_CADR (b
), env
);
2166 SCM initializer
= unmemocar (scm_list_1 (copy
), env
);
2167 y
= z
= scm_acons (SCM_CAR (b
), initializer
, SCM_UNSPECIFIED
);
2168 env
= SCM_EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
2172 SCM_SETCDR (y
, SCM_EOL
);
2173 z
= scm_cons (y
, SCM_UNSPECIFIED
);
2174 ls
= scm_cons (scm_sym_let
, z
);
2179 copy
= scm_unmemocopy (SCM_CADR (b
), env
);
2180 initializer
= unmemocar (scm_list_1 (copy
), env
);
2181 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
2185 env
= SCM_EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
2188 while (!SCM_NULLP (b
));
2189 SCM_SETCDR (z
, SCM_EOL
);
2191 z
= scm_cons (y
, SCM_UNSPECIFIED
);
2192 ls
= scm_cons (scm_sym_letstar
, z
);
2195 case (ISYMNUM (SCM_IM_OR
)):
2196 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
2198 case (ISYMNUM (SCM_IM_LAMBDA
)):
2200 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
);
2201 ls
= scm_cons (scm_sym_lambda
, z
);
2202 env
= SCM_EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
2204 case (ISYMNUM (SCM_IM_QUOTE
)):
2205 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
2207 case (ISYMNUM (SCM_IM_SET_X
)):
2208 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
2210 case (ISYMNUM (SCM_IM_APPLY
)):
2211 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
2213 case (ISYMNUM (SCM_IM_CONT
)):
2214 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
2216 case (ISYMNUM (SCM_IM_DELAY
)):
2217 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
2220 case (ISYMNUM (SCM_IM_FUTURE
)):
2221 ls
= z
= scm_cons (scm_sym_future
, SCM_UNSPECIFIED
);
2224 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2225 ls
= z
= scm_cons (scm_sym_at_call_with_values
, SCM_UNSPECIFIED
);
2227 case (ISYMNUM (SCM_IM_ELSE
)):
2228 ls
= z
= scm_cons (scm_sym_else
, SCM_UNSPECIFIED
);
2231 ls
= z
= unmemocar (scm_cons (scm_unmemocopy (SCM_CAR (x
), env
),
2238 ls
= z
= unmemocar (scm_cons (scm_unmemocopy (SCM_CAR (x
), env
),
2244 while (SCM_CONSP (x
))
2246 SCM form
= SCM_CAR (x
);
2247 if (!SCM_ISYMP (form
))
2249 SCM copy
= scm_cons (scm_unmemocopy (form
, env
), SCM_UNSPECIFIED
);
2250 SCM_SETCDR (z
, unmemocar (copy
, env
));
2253 else if (SCM_EQ_P (form
, SCM_IM_ARROW
))
2255 SCM_SETCDR (z
, scm_cons (scm_sym_arrow
, SCM_UNSPECIFIED
));
2261 if (!SCM_FALSEP (p
))
2262 scm_whash_insert (scm_source_whash
, ls
, p
);
2267 #if (SCM_ENABLE_DEPRECATED == 1)
2270 scm_unmemocar (SCM form
, SCM env
)
2272 return unmemocar (form
, env
);
2277 /*****************************************************************************/
2278 /*****************************************************************************/
2279 /* The definitions for execution start here. */
2280 /*****************************************************************************/
2281 /*****************************************************************************/
2283 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
2284 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
2285 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
2286 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
2288 /* A function object to implement "apply" for non-closure functions. */
2290 /* An endless list consisting of #<undefined> objects: */
2291 static SCM undefineds
;
2295 scm_badargsp (SCM formals
, SCM args
)
2297 while (!SCM_NULLP (formals
))
2299 if (!SCM_CONSP (formals
))
2301 if (SCM_NULLP (args
))
2303 formals
= SCM_CDR (formals
);
2304 args
= SCM_CDR (args
);
2306 return !SCM_NULLP (args
) ? 1 : 0;
2311 /* The evaluator contains a plethora of EVAL symbols. This is an attempt at
2314 * The following macros should be used in code which is read twice (where the
2315 * choice of evaluator is hard soldered):
2317 * CEVAL is the symbol used within one evaluator to call itself.
2318 * Originally, it is defined to ceval, but is redefined to deval during the
2321 * SCM_EVALIM is used when it is known that the expression is an
2322 * immediate. (This macro never calls an evaluator.)
2324 * EVAL evaluates an expression that is expected to have its symbols already
2325 * memoized. Expressions that are not of the form '(<form> <form> ...)' are
2326 * evaluated inline without calling an evaluator.
2328 * EVALCAR evaluates the car of an expression 'X:(Y:<form> <form> ...)',
2329 * potentially replacing a symbol at the position Y:<form> by its memoized
2330 * variable. If Y:<form> is not of the form '(<form> <form> ...)', the
2331 * evaluation is performed inline without calling an evaluator.
2333 * The following macros should be used in code which is read once
2334 * (where the choice of evaluator is dynamic):
2336 * SCM_XEVAL corresponds to EVAL, but uses ceval *or* deval depending on the
2339 * SCM_XEVALCAR corresponds to EVALCAR, but uses ceval *or* deval depending
2340 * on the debugging mode.
2342 * The main motivation for keeping this plethora is efficiency
2343 * together with maintainability (=> locality of code).
2346 static SCM
ceval (SCM x
, SCM env
);
2347 static SCM
deval (SCM x
, SCM env
);
2351 #define SCM_EVALIM2(x) \
2352 ((SCM_EQ_P ((x), SCM_EOL) \
2353 ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \
2357 #define SCM_EVALIM(x, env) (SCM_ILOCP (x) \
2358 ? *scm_ilookup ((x), (env)) \
2361 #define SCM_XEVAL(x, env) \
2364 : (SCM_VARIABLEP (x) \
2365 ? SCM_VARIABLE_REF (x) \
2367 ? (scm_debug_mode_p \
2368 ? deval ((x), (env)) \
2369 : ceval ((x), (env))) \
2372 #define SCM_XEVALCAR(x, env) \
2373 (SCM_IMP (SCM_CAR (x)) \
2374 ? SCM_EVALIM (SCM_CAR (x), (env)) \
2375 : (SCM_VARIABLEP (SCM_CAR (x)) \
2376 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2377 : (SCM_CONSP (SCM_CAR (x)) \
2378 ? (scm_debug_mode_p \
2379 ? deval (SCM_CAR (x), (env)) \
2380 : ceval (SCM_CAR (x), (env))) \
2381 : (!SCM_SYMBOLP (SCM_CAR (x)) \
2383 : *scm_lookupcar ((x), (env), 1)))))
2385 #define EVAL(x, env) \
2387 ? SCM_EVALIM ((x), (env)) \
2388 : (SCM_VARIABLEP (x) \
2389 ? SCM_VARIABLE_REF (x) \
2391 ? CEVAL ((x), (env)) \
2394 #define EVALCAR(x, env) \
2395 (SCM_IMP (SCM_CAR (x)) \
2396 ? SCM_EVALIM (SCM_CAR (x), (env)) \
2397 : (SCM_VARIABLEP (SCM_CAR (x)) \
2398 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2399 : (SCM_CONSP (SCM_CAR (x)) \
2400 ? CEVAL (SCM_CAR (x), (env)) \
2401 : (!SCM_SYMBOLP (SCM_CAR (x)) \
2403 : *scm_lookupcar ((x), (env), 1)))))
2405 SCM_REC_MUTEX (source_mutex
);
2408 /* Lookup a given local variable in an environment. The local variable is
2409 * given as an iloc, that is a triple <frame, binding, last?>, where frame
2410 * indicates the relative number of the environment frame (counting upwards
2411 * from the innermost environment frame), binding indicates the number of the
2412 * binding within the frame, and last? (which is extracted from the iloc using
2413 * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
2414 * very end of the improper list of bindings. */
2416 scm_ilookup (SCM iloc
, SCM env
)
2418 unsigned int frame_nr
= SCM_IFRAME (iloc
);
2419 unsigned int binding_nr
= SCM_IDIST (iloc
);
2423 for (; 0 != frame_nr
; --frame_nr
)
2424 frames
= SCM_CDR (frames
);
2426 bindings
= SCM_CAR (frames
);
2427 for (; 0 != binding_nr
; --binding_nr
)
2428 bindings
= SCM_CDR (bindings
);
2430 if (SCM_ICDRP (iloc
))
2431 return SCM_CDRLOC (bindings
);
2432 return SCM_CARLOC (SCM_CDR (bindings
));
2436 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
2438 static void error_unbound_variable (SCM symbol
) SCM_NORETURN
;
2440 error_unbound_variable (SCM symbol
)
2442 scm_error (scm_unbound_variable_key
, NULL
,
2443 "Unbound variable: ~S",
2444 scm_list_1 (symbol
), SCM_BOOL_F
);
2448 /* The Lookup Car Race
2451 Memoization of variables and special forms is done while executing
2452 the code for the first time. As long as there is only one thread
2453 everything is fine, but as soon as two threads execute the same
2454 code concurrently `for the first time' they can come into conflict.
2456 This memoization includes rewriting variable references into more
2457 efficient forms and expanding macros. Furthermore, macro expansion
2458 includes `compiling' special forms like `let', `cond', etc. into
2459 tree-code instructions.
2461 There shouldn't normally be a problem with memoizing local and
2462 global variable references (into ilocs and variables), because all
2463 threads will mutate the code in *exactly* the same way and (if I
2464 read the C code correctly) it is not possible to observe a half-way
2465 mutated cons cell. The lookup procedure can handle this
2466 transparently without any critical sections.
2468 It is different with macro expansion, because macro expansion
2469 happens outside of the lookup procedure and can't be
2470 undone. Therefore the lookup procedure can't cope with it. It has
2471 to indicate failure when it detects a lost race and hope that the
2472 caller can handle it. Luckily, it turns out that this is the case.
2474 An example to illustrate this: Suppose that the following form will
2475 be memoized concurrently by two threads
2479 Let's first examine the lookup of X in the body. The first thread
2480 decides that it has to find the symbol "x" in the environment and
2481 starts to scan it. Then the other thread takes over and actually
2482 overtakes the first. It looks up "x" and substitutes an
2483 appropriate iloc for it. Now the first thread continues and
2484 completes its lookup. It comes to exactly the same conclusions as
2485 the second one and could - without much ado - just overwrite the
2486 iloc with the same iloc.
2488 But let's see what will happen when the race occurs while looking
2489 up the symbol "let" at the start of the form. It could happen that
2490 the second thread interrupts the lookup of the first thread and not
2491 only substitutes a variable for it but goes right ahead and
2492 replaces it with the compiled form (#@let* (x 12) x). Now, when
2493 the first thread completes its lookup, it would replace the #@let*
2494 with a variable containing the "let" binding, effectively reverting
2495 the form to (let (x 12) x). This is wrong. It has to detect that
2496 it has lost the race and the evaluator has to reconsider the
2497 changed form completely.
2499 This race condition could be resolved with some kind of traffic
2500 light (like mutexes) around scm_lookupcar, but I think that it is
2501 best to avoid them in this case. They would serialize memoization
2502 completely and because lookup involves calling arbitrary Scheme
2503 code (via the lookup-thunk), threads could be blocked for an
2504 arbitrary amount of time or even deadlock. But with the current
2505 solution a lot of unnecessary work is potentially done. */
2507 /* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
2508 return NULL to indicate a failed lookup due to some race conditions
2509 between threads. This only happens when VLOC is the first cell of
2510 a special form that will eventually be memoized (like `let', etc.)
2511 In that case the whole lookup is bogus and the caller has to
2512 reconsider the complete special form.
2514 SCM_LOOKUPCAR is still there, of course. It just calls
2515 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
2516 should only be called when it is known that VLOC is not the first
2517 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
2518 for NULL. I think I've found the only places where this
2522 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
2525 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
2526 register SCM iloc
= SCM_ILOC00
;
2527 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
2529 if (!SCM_CONSP (SCM_CAR (env
)))
2531 al
= SCM_CARLOC (env
);
2532 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
2534 if (!SCM_CONSP (fl
))
2536 if (SCM_EQ_P (fl
, var
))
2538 if (! SCM_EQ_P (SCM_CAR (vloc
), var
))
2540 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
2541 return SCM_CDRLOC (*al
);
2546 al
= SCM_CDRLOC (*al
);
2547 if (SCM_EQ_P (SCM_CAR (fl
), var
))
2549 if (SCM_UNBNDP (SCM_CAR (*al
)))
2554 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
2556 SCM_SETCAR (vloc
, iloc
);
2557 return SCM_CARLOC (*al
);
2559 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
2561 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
2564 SCM top_thunk
, real_var
;
2567 top_thunk
= SCM_CAR (env
); /* env now refers to a
2568 top level env thunk */
2569 env
= SCM_CDR (env
);
2572 top_thunk
= SCM_BOOL_F
;
2573 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
2574 if (SCM_FALSEP (real_var
))
2577 if (!SCM_NULLP (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
2582 if (SCM_NULLP (env
))
2583 error_unbound_variable (var
);
2585 scm_misc_error (NULL
, "Damaged environment: ~S",
2590 /* A variable could not be found, but we shall
2591 not throw an error. */
2592 static SCM undef_object
= SCM_UNDEFINED
;
2593 return &undef_object
;
2597 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
2599 /* Some other thread has changed the very cell we are working
2600 on. In effect, it must have done our job or messed it up
2603 var
= SCM_CAR (vloc
);
2604 if (SCM_VARIABLEP (var
))
2605 return SCM_VARIABLE_LOC (var
);
2606 if (SCM_ILOCP (var
))
2607 return scm_ilookup (var
, genv
);
2608 /* We can't cope with anything else than variables and ilocs. When
2609 a special form has been memoized (i.e. `let' into `#@let') we
2610 return NULL and expect the calling function to do the right
2611 thing. For the evaluator, this means going back and redoing
2612 the dispatch on the car of the form. */
2616 SCM_SETCAR (vloc
, real_var
);
2617 return SCM_VARIABLE_LOC (real_var
);
2622 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
2624 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
2631 /* During execution, look up a symbol in the top level of the given local
2632 * environment and return the corresponding variable object. If no binding
2633 * for the symbol can be found, an 'Unbound variable' error is signalled. */
2635 lazy_memoize_variable (const SCM symbol
, const SCM environment
)
2637 const SCM top_level
= scm_env_top_level (environment
);
2638 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
2640 if (SCM_FALSEP (variable
))
2641 error_unbound_variable (symbol
);
2648 scm_eval_car (SCM pair
, SCM env
)
2650 return SCM_XEVALCAR (pair
, env
);
2655 scm_eval_args (SCM l
, SCM env
, SCM proc
)
2657 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
2658 while (SCM_CONSP (l
))
2660 res
= EVALCAR (l
, env
);
2662 *lloc
= scm_list_1 (res
);
2663 lloc
= SCM_CDRLOC (*lloc
);
2667 scm_wrong_num_args (proc
);
2673 scm_eval_body (SCM code
, SCM env
)
2678 next
= SCM_CDR (code
);
2679 while (!SCM_NULLP (next
))
2681 if (SCM_IMP (SCM_CAR (code
)))
2683 if (SCM_ISYMP (SCM_CAR (code
)))
2685 scm_rec_mutex_lock (&source_mutex
);
2686 /* check for race condition */
2687 if (SCM_ISYMP (SCM_CAR (code
)))
2688 m_expand_body (code
, env
);
2689 scm_rec_mutex_unlock (&source_mutex
);
2694 SCM_XEVAL (SCM_CAR (code
), env
);
2696 next
= SCM_CDR (code
);
2698 return SCM_XEVALCAR (code
, env
);
2704 /* SECTION: This code is specific for the debugging support. One
2705 * branch is read when DEVAL isn't defined, the other when DEVAL is
2711 #define SCM_APPLY scm_apply
2712 #define PREP_APPLY(proc, args)
2714 #define RETURN(x) do { return x; } while (0)
2715 #ifdef STACK_CHECKING
2716 #ifndef NO_CEVAL_STACK_CHECKING
2717 #define EVAL_STACK_CHECKING
2724 #define CEVAL deval /* Substitute all uses of ceval */
2727 #define SCM_APPLY scm_dapply
2730 #define PREP_APPLY(p, l) \
2731 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
2734 #define ENTER_APPLY \
2736 SCM_SET_ARGSREADY (debug);\
2737 if (scm_check_apply_p && SCM_TRAPS_P)\
2738 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
2740 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
2741 SCM_SET_TRACED_FRAME (debug); \
2743 if (SCM_CHEAPTRAPS_P)\
2745 tmp = scm_make_debugobj (&debug);\
2746 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
2751 tmp = scm_make_continuation (&first);\
2753 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
2760 #define RETURN(e) do { proc = (e); goto exit; } while (0)
2762 #ifdef STACK_CHECKING
2763 #ifndef EVAL_STACK_CHECKING
2764 #define EVAL_STACK_CHECKING
2769 /* scm_last_debug_frame contains a pointer to the last debugging information
2770 * stack frame. It is accessed very often from the debugging evaluator, so it
2771 * should probably not be indirectly addressed. Better to save and restore it
2772 * from the current root at any stack swaps.
2775 /* scm_debug_eframe_size is the number of slots available for pseudo
2776 * stack frames at each real stack frame.
2779 long scm_debug_eframe_size
;
2781 int scm_debug_mode_p
;
2782 int scm_check_entry_p
;
2783 int scm_check_apply_p
;
2784 int scm_check_exit_p
;
2786 long scm_eval_stack
;
2788 scm_t_option scm_eval_opts
[] = {
2789 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
2792 scm_t_option scm_debug_opts
[] = {
2793 { SCM_OPTION_BOOLEAN
, "cheap", 1,
2794 "*Flyweight representation of the stack at traps." },
2795 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
2796 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
2797 { SCM_OPTION_BOOLEAN
, "procnames", 1,
2798 "Record procedure names at definition." },
2799 { SCM_OPTION_BOOLEAN
, "backwards", 0,
2800 "Display backtrace in anti-chronological order." },
2801 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
2802 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
2803 { SCM_OPTION_INTEGER
, "frames", 3,
2804 "Maximum number of tail-recursive frames in backtrace." },
2805 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
2806 "Maximal number of stored backtrace frames." },
2807 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
2808 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
2809 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
2810 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
2811 { 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."}
2814 scm_t_option scm_evaluator_trap_table
[] = {
2815 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
2816 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
2817 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
2818 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
2819 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
2820 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
2821 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
2824 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
2826 "Option interface for the evaluation options. Instead of using\n"
2827 "this procedure directly, use the procedures @code{eval-enable},\n"
2828 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
2829 #define FUNC_NAME s_scm_eval_options_interface
2833 ans
= scm_options (setting
,
2837 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
2844 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
2846 "Option interface for the evaluator trap options.")
2847 #define FUNC_NAME s_scm_evaluator_traps
2851 ans
= scm_options (setting
,
2852 scm_evaluator_trap_table
,
2853 SCM_N_EVALUATOR_TRAPS
,
2855 SCM_RESET_DEBUG_MODE
;
2863 deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
2865 SCM
*results
= lloc
;
2866 while (SCM_CONSP (l
))
2868 const SCM res
= EVALCAR (l
, env
);
2870 *lloc
= scm_list_1 (res
);
2871 lloc
= SCM_CDRLOC (*lloc
);
2875 scm_wrong_num_args (proc
);
2882 /* SECTION: This code is compiled twice.
2886 /* Update the toplevel environment frame ENV so that it refers to the
2887 * current module. */
2888 #define UPDATE_TOPLEVEL_ENV(env) \
2890 SCM p = scm_current_module_lookup_closure (); \
2891 if (p != SCM_CAR (env)) \
2892 env = scm_top_level_env (p); \
2896 #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
2897 ASSERT_SYNTAX (!SCM_EQ_P ((x), SCM_EOL), s_empty_combination, x)
2900 /* This is the evaluator. Like any real monster, it has three heads:
2902 * ceval is the non-debugging evaluator, deval is the debugging version. Both
2903 * are implemented using a common code base, using the following mechanism:
2904 * CEVAL is a macro, which is either defined to ceval or deval. Thus, there
2905 * is no function CEVAL, but the code for CEVAL actually compiles to either
2906 * ceval or deval. When CEVAL is defined to ceval, it is known that the macro
2907 * DEVAL is not defined. When CEVAL is defined to deval, then the macro DEVAL
2908 * is known to be defined. Thus, in CEVAL parts for the debugging evaluator
2909 * are enclosed within #ifdef DEVAL ... #endif.
2911 * All three (ceval, deval and their common implementation CEVAL) take two
2912 * input parameters, x and env: x is a single expression to be evalutated.
2913 * env is the environment in which bindings are searched.
2915 * x is known to be a pair. Since x is a single expression, it is necessarily
2916 * in a tail position. If x is just a call to another function like in the
2917 * expression (foo exp1 exp2 ...), the realization of that call therefore
2918 * _must_not_ increase stack usage (the evaluation of exp1, exp2 etc.,
2919 * however, may do so). This is realized by making extensive use of 'goto'
2920 * statements within the evaluator: The gotos replace recursive calls to
2921 * CEVAL, thus re-using the same stack frame that CEVAL was already using.
2922 * If, however, x represents some form that requires to evaluate a sequence of
2923 * expressions like (begin exp1 exp2 ...), then recursive calls to CEVAL are
2924 * performed for all but the last expression of that sequence. */
2927 CEVAL (SCM x
, SCM env
)
2931 scm_t_debug_frame debug
;
2932 scm_t_debug_info
*debug_info_end
;
2933 debug
.prev
= scm_last_debug_frame
;
2936 * The debug.vect contains twice as much scm_t_debug_info frames as the
2937 * user has specified with (debug-set! frames <n>).
2939 * Even frames are eval frames, odd frames are apply frames.
2941 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
2942 * sizeof (scm_t_debug_info
));
2943 debug
.info
= debug
.vect
;
2944 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
2945 scm_last_debug_frame
= &debug
;
2947 #ifdef EVAL_STACK_CHECKING
2948 if (scm_stack_checking_enabled_p
&& SCM_STACK_OVERFLOW_P (&proc
))
2951 debug
.info
->e
.exp
= x
;
2952 debug
.info
->e
.env
= env
;
2954 scm_report_stack_overflow ();
2964 SCM_CLEAR_ARGSREADY (debug
);
2965 if (SCM_OVERFLOWP (debug
))
2968 * In theory, this should be the only place where it is necessary to
2969 * check for space in debug.vect since both eval frames and
2970 * available space are even.
2972 * For this to be the case, however, it is necessary that primitive
2973 * special forms which jump back to `loop', `begin' or some similar
2974 * label call PREP_APPLY.
2976 else if (++debug
.info
>= debug_info_end
)
2978 SCM_SET_OVERFLOW (debug
);
2983 debug
.info
->e
.exp
= x
;
2984 debug
.info
->e
.env
= env
;
2985 if (scm_check_entry_p
&& SCM_TRAPS_P
)
2987 if (SCM_ENTER_FRAME_P
2988 || (SCM_BREAKPOINTS_P
&& scm_c_source_property_breakpoint_p (x
)))
2991 SCM tail
= SCM_BOOL (SCM_TAILRECP (debug
));
2992 SCM_SET_TAILREC (debug
);
2993 if (SCM_CHEAPTRAPS_P
)
2994 stackrep
= scm_make_debugobj (&debug
);
2998 SCM val
= scm_make_continuation (&first
);
3008 /* This gives the possibility for the debugger to
3009 modify the source expression before evaluation. */
3014 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
3015 scm_sym_enter_frame
,
3018 scm_unmemocopy (x
, env
));
3025 if (SCM_ISYMP (SCM_CAR (x
)))
3027 switch (ISYMNUM (SCM_CAR (x
)))
3029 case (ISYMNUM (SCM_IM_AND
)):
3031 while (!SCM_NULLP (SCM_CDR (x
)))
3033 SCM test_result
= EVALCAR (x
, env
);
3034 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
3035 RETURN (SCM_BOOL_F
);
3039 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3042 case (ISYMNUM (SCM_IM_BEGIN
)):
3045 RETURN (SCM_UNSPECIFIED
);
3047 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3050 /* If we are on toplevel with a lookup closure, we need to sync
3051 with the current module. */
3052 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
3054 UPDATE_TOPLEVEL_ENV (env
);
3055 while (!SCM_NULLP (SCM_CDR (x
)))
3058 UPDATE_TOPLEVEL_ENV (env
);
3064 goto nontoplevel_begin
;
3067 while (!SCM_NULLP (SCM_CDR (x
)))
3069 const SCM form
= SCM_CAR (x
);
3072 if (SCM_ISYMP (form
))
3074 scm_rec_mutex_lock (&source_mutex
);
3075 /* check for race condition */
3076 if (SCM_ISYMP (SCM_CAR (x
)))
3077 m_expand_body (x
, env
);
3078 scm_rec_mutex_unlock (&source_mutex
);
3079 goto nontoplevel_begin
;
3082 SCM_VALIDATE_NON_EMPTY_COMBINATION (form
);
3085 (void) EVAL (form
, env
);
3091 /* scm_eval last form in list */
3092 const SCM last_form
= SCM_CAR (x
);
3094 if (SCM_CONSP (last_form
))
3096 /* This is by far the most frequent case. */
3098 goto loop
; /* tail recurse */
3100 else if (SCM_IMP (last_form
))
3101 RETURN (SCM_EVALIM (last_form
, env
));
3102 else if (SCM_VARIABLEP (last_form
))
3103 RETURN (SCM_VARIABLE_REF (last_form
));
3104 else if (SCM_SYMBOLP (last_form
))
3105 RETURN (*scm_lookupcar (x
, env
, 1));
3111 case (ISYMNUM (SCM_IM_CASE
)):
3114 const SCM key
= EVALCAR (x
, env
);
3116 while (!SCM_NULLP (x
))
3118 const SCM clause
= SCM_CAR (x
);
3119 SCM labels
= SCM_CAR (clause
);
3120 if (SCM_EQ_P (labels
, SCM_IM_ELSE
))
3122 x
= SCM_CDR (clause
);
3123 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3126 while (!SCM_NULLP (labels
))
3128 const SCM label
= SCM_CAR (labels
);
3129 if (SCM_EQ_P (label
, key
)
3130 || !SCM_FALSEP (scm_eqv_p (label
, key
)))
3132 x
= SCM_CDR (clause
);
3133 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3136 labels
= SCM_CDR (labels
);
3141 RETURN (SCM_UNSPECIFIED
);
3144 case (ISYMNUM (SCM_IM_COND
)):
3146 while (!SCM_NULLP (x
))
3148 const SCM clause
= SCM_CAR (x
);
3149 if (SCM_EQ_P (SCM_CAR (clause
), SCM_IM_ELSE
))
3151 x
= SCM_CDR (clause
);
3152 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3157 arg1
= EVALCAR (clause
, env
);
3158 if (!SCM_FALSEP (arg1
) && !SCM_NILP (arg1
))
3160 x
= SCM_CDR (clause
);
3163 else if (!SCM_EQ_P (SCM_CAR (x
), SCM_IM_ARROW
))
3165 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3171 proc
= EVALCAR (proc
, env
);
3172 PREP_APPLY (proc
, scm_list_1 (arg1
));
3180 RETURN (SCM_UNSPECIFIED
);
3183 case (ISYMNUM (SCM_IM_DO
)):
3186 /* Compute the initialization values and the initial environment. */
3187 SCM init_forms
= SCM_CAR (x
);
3188 SCM init_values
= SCM_EOL
;
3189 while (!SCM_NULLP (init_forms
))
3191 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3192 init_forms
= SCM_CDR (init_forms
);
3195 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
3199 SCM test_form
= SCM_CAR (x
);
3200 SCM body_forms
= SCM_CADR (x
);
3201 SCM step_forms
= SCM_CDDR (x
);
3203 SCM test_result
= EVALCAR (test_form
, env
);
3205 while (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
3208 /* Evaluate body forms. */
3210 for (temp_forms
= body_forms
;
3211 !SCM_NULLP (temp_forms
);
3212 temp_forms
= SCM_CDR (temp_forms
))
3214 SCM form
= SCM_CAR (temp_forms
);
3215 /* Dirk:FIXME: We only need to eval forms that may have
3216 * a side effect here. This is only true for forms that
3217 * start with a pair. All others are just constants.
3218 * Since with the current memoizer 'form' may hold a
3219 * constant, we call EVAL here to handle the constant
3220 * cases. In the long run it would make sense to have
3221 * the macro transformer of 'do' eliminate all forms
3222 * that have no sideeffect. Then instead of EVAL we
3223 * could call CEVAL directly here. */
3224 (void) EVAL (form
, env
);
3229 /* Evaluate the step expressions. */
3231 SCM step_values
= SCM_EOL
;
3232 for (temp_forms
= step_forms
;
3233 !SCM_NULLP (temp_forms
);
3234 temp_forms
= SCM_CDR (temp_forms
))
3236 const SCM value
= EVALCAR (temp_forms
, env
);
3237 step_values
= scm_cons (value
, step_values
);
3239 env
= SCM_EXTEND_ENV (SCM_CAAR (env
),
3244 test_result
= EVALCAR (test_form
, env
);
3249 RETURN (SCM_UNSPECIFIED
);
3250 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3251 goto nontoplevel_begin
;
3254 case (ISYMNUM (SCM_IM_IF
)):
3257 SCM test_result
= EVALCAR (x
, env
);
3258 x
= SCM_CDR (x
); /* then expression */
3259 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
3261 x
= SCM_CDR (x
); /* else expression */
3263 RETURN (SCM_UNSPECIFIED
);
3266 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3270 case (ISYMNUM (SCM_IM_LET
)):
3273 SCM init_forms
= SCM_CADR (x
);
3274 SCM init_values
= SCM_EOL
;
3277 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3278 init_forms
= SCM_CDR (init_forms
);
3280 while (!SCM_NULLP (init_forms
));
3281 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
3284 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3285 goto nontoplevel_begin
;
3288 case (ISYMNUM (SCM_IM_LETREC
)):
3290 env
= SCM_EXTEND_ENV (SCM_CAR (x
), undefineds
, env
);
3293 SCM init_forms
= SCM_CAR (x
);
3294 SCM init_values
= SCM_EOL
;
3297 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3298 init_forms
= SCM_CDR (init_forms
);
3300 while (!SCM_NULLP (init_forms
));
3301 SCM_SETCDR (SCM_CAR (env
), init_values
);
3304 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3305 goto nontoplevel_begin
;
3308 case (ISYMNUM (SCM_IM_LETSTAR
)):
3311 SCM bindings
= SCM_CAR (x
);
3312 if (SCM_NULLP (bindings
))
3313 env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
3318 SCM name
= SCM_CAR (bindings
);
3319 SCM init
= SCM_CDR (bindings
);
3320 env
= SCM_EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
3321 bindings
= SCM_CDR (init
);
3323 while (!SCM_NULLP (bindings
));
3327 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3328 goto nontoplevel_begin
;
3331 case (ISYMNUM (SCM_IM_OR
)):
3333 while (!SCM_NULLP (SCM_CDR (x
)))
3335 SCM val
= EVALCAR (x
, env
);
3336 if (!SCM_FALSEP (val
) && !SCM_NILP (val
))
3341 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3345 case (ISYMNUM (SCM_IM_LAMBDA
)):
3346 RETURN (scm_closure (SCM_CDR (x
), env
));
3349 case (ISYMNUM (SCM_IM_QUOTE
)):
3350 RETURN (SCM_CADR (x
));
3353 case (ISYMNUM (SCM_IM_SET_X
)):
3357 SCM variable
= SCM_CAR (x
);
3358 if (SCM_ILOCP (variable
))
3359 location
= scm_ilookup (variable
, env
);
3360 else if (SCM_VARIABLEP (variable
))
3361 location
= SCM_VARIABLE_LOC (variable
);
3364 /* (SCM_SYMBOLP (variable)) is known to be true */
3365 variable
= lazy_memoize_variable (variable
, env
);
3366 SCM_SETCAR (x
, variable
);
3367 location
= SCM_VARIABLE_LOC (variable
);
3370 *location
= EVALCAR (x
, env
);
3372 RETURN (SCM_UNSPECIFIED
);
3375 case (ISYMNUM (SCM_IM_APPLY
)):
3376 /* Evaluate the procedure to be applied. */
3378 proc
= EVALCAR (x
, env
);
3379 PREP_APPLY (proc
, SCM_EOL
);
3381 /* Evaluate the argument holding the list of arguments */
3383 arg1
= EVALCAR (x
, env
);
3386 /* Go here to tail-apply a procedure. PROC is the procedure and
3387 * ARG1 is the list of arguments. PREP_APPLY must have been called
3388 * before jumping to apply_proc. */
3389 if (SCM_CLOSUREP (proc
))
3391 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3393 debug
.info
->a
.args
= arg1
;
3395 if (scm_badargsp (formals
, arg1
))
3396 scm_wrong_num_args (proc
);
3398 /* Copy argument list */
3399 if (SCM_NULL_OR_NIL_P (arg1
))
3400 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
3403 SCM args
= scm_list_1 (SCM_CAR (arg1
));
3405 arg1
= SCM_CDR (arg1
);
3406 while (!SCM_NULL_OR_NIL_P (arg1
))
3408 SCM new_tail
= scm_list_1 (SCM_CAR (arg1
));
3409 SCM_SETCDR (tail
, new_tail
);
3411 arg1
= SCM_CDR (arg1
);
3413 env
= SCM_EXTEND_ENV (formals
, args
, SCM_ENV (proc
));
3416 x
= SCM_CLOSURE_BODY (proc
);
3417 goto nontoplevel_begin
;
3422 RETURN (SCM_APPLY (proc
, arg1
, SCM_EOL
));
3426 case (ISYMNUM (SCM_IM_CONT
)):
3429 SCM val
= scm_make_continuation (&first
);
3437 proc
= EVALCAR (proc
, env
);
3438 PREP_APPLY (proc
, scm_list_1 (arg1
));
3445 case (ISYMNUM (SCM_IM_DELAY
)):
3446 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
3449 case (ISYMNUM (SCM_IM_FUTURE
)):
3450 RETURN (scm_i_make_future (scm_closure (SCM_CDR (x
), env
)));
3453 /* PLACEHOLDER for case (ISYMNUM (SCM_IM_DISPATCH)): The following
3454 code (type_dispatch) is intended to be the tail of the case
3455 clause for the internal macro SCM_IM_DISPATCH. Please don't
3456 remove it from this location without discussing it with Mikael
3457 <djurfeldt@nada.kth.se> */
3459 /* The type dispatch code is duplicated below
3460 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
3461 * cuts down execution time for type dispatch to 50%. */
3462 type_dispatch
: /* inputs: x, arg1 */
3463 /* Type dispatch means to determine from the types of the function
3464 * arguments (i. e. the 'signature' of the call), which method from
3465 * a generic function is to be called. This process of selecting
3466 * the right method takes some time. To speed it up, guile uses
3467 * caching: Together with the macro call to dispatch the signatures
3468 * of some previous calls to that generic function from the same
3469 * place are stored (in the code!) in a cache that we call the
3470 * 'method cache'. This is done since it is likely, that
3471 * consecutive calls to dispatch from that position in the code will
3472 * have the same signature. Thus, the type dispatch works as
3473 * follows: First, determine a hash value from the signature of the
3474 * actual arguments. Second, use this hash value as an index to
3475 * find that same signature in the method cache stored at this
3476 * position in the code. If found, you have also found the
3477 * corresponding method that belongs to that signature. If the
3478 * signature is not found in the method cache, you have to perform a
3479 * full search over all signatures stored with the generic
3482 unsigned long int specializers
;
3483 unsigned long int hash_value
;
3484 unsigned long int cache_end_pos
;
3485 unsigned long int mask
;
3489 SCM z
= SCM_CDDR (x
);
3490 SCM tmp
= SCM_CADR (z
);
3491 specializers
= SCM_INUM (SCM_CAR (z
));
3493 /* Compute a hash value for searching the method cache. There
3494 * are two variants for computing the hash value, a (rather)
3495 * complicated one, and a simple one. For the complicated one
3496 * explained below, tmp holds a number that is used in the
3498 if (SCM_INUMP (tmp
))
3500 /* Use the signature of the actual arguments to determine
3501 * the hash value. This is done as follows: Each class has
3502 * an array of random numbers, that are determined when the
3503 * class is created. The integer 'hashset' is an index into
3504 * that array of random numbers. Now, from all classes that
3505 * are part of the signature of the actual arguments, the
3506 * random numbers at index 'hashset' are taken and summed
3507 * up, giving the hash value. The value of 'hashset' is
3508 * stored at the call to dispatch. This allows to have
3509 * different 'formulas' for calculating the hash value at
3510 * different places where dispatch is called. This allows
3511 * to optimize the hash formula at every individual place
3512 * where dispatch is called, such that hopefully the hash
3513 * value that is computed will directly point to the right
3514 * method in the method cache. */
3515 unsigned long int hashset
= SCM_INUM (tmp
);
3516 unsigned long int counter
= specializers
+ 1;
3519 while (!SCM_NULLP (tmp_arg
) && counter
!= 0)
3521 SCM
class = scm_class_of (SCM_CAR (tmp_arg
));
3522 hash_value
+= SCM_INSTANCE_HASH (class, hashset
);
3523 tmp_arg
= SCM_CDR (tmp_arg
);
3527 method_cache
= SCM_CADR (z
);
3528 mask
= SCM_INUM (SCM_CAR (z
));
3530 cache_end_pos
= hash_value
;
3534 /* This method of determining the hash value is much
3535 * simpler: Set the hash value to zero and just perform a
3536 * linear search through the method cache. */
3538 mask
= (unsigned long int) ((long) -1);
3540 cache_end_pos
= SCM_VECTOR_LENGTH (method_cache
);
3545 /* Search the method cache for a method with a matching
3546 * signature. Start the search at position 'hash_value'. The
3547 * hashing implementation uses linear probing for conflict
3548 * resolution, that is, if the signature in question is not
3549 * found at the starting index in the hash table, the next table
3550 * entry is tried, and so on, until in the worst case the whole
3551 * cache has been searched, but still the signature has not been
3556 SCM args
= arg1
; /* list of arguments */
3557 z
= SCM_VELTS (method_cache
)[hash_value
];
3558 while (!SCM_NULLP (args
))
3560 /* More arguments than specifiers => CLASS != ENV */
3561 SCM class_of_arg
= scm_class_of (SCM_CAR (args
));
3562 if (!SCM_EQ_P (class_of_arg
, SCM_CAR (z
)))
3564 args
= SCM_CDR (args
);
3567 /* Fewer arguments than specifiers => CAR != ENV */
3568 if (SCM_NULLP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
)))
3571 hash_value
= (hash_value
+ 1) & mask
;
3572 } while (hash_value
!= cache_end_pos
);
3574 /* No appropriate method was found in the cache. */
3575 z
= scm_memoize_method (x
, arg1
);
3577 apply_cmethod
: /* inputs: z, arg1 */
3579 SCM formals
= SCM_CMETHOD_FORMALS (z
);
3580 env
= SCM_EXTEND_ENV (formals
, arg1
, SCM_CMETHOD_ENV (z
));
3581 x
= SCM_CMETHOD_BODY (z
);
3582 goto nontoplevel_begin
;
3588 case (ISYMNUM (SCM_IM_SLOT_REF
)):
3591 SCM instance
= EVALCAR (x
, env
);
3592 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
3593 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance
) [slot
]));
3597 case (ISYMNUM (SCM_IM_SLOT_SET_X
)):
3600 SCM instance
= EVALCAR (x
, env
);
3601 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
3602 SCM value
= EVALCAR (SCM_CDDR (x
), env
);
3603 SCM_STRUCT_DATA (instance
) [slot
] = SCM_UNPACK (value
);
3604 RETURN (SCM_UNSPECIFIED
);
3608 #if SCM_ENABLE_ELISP
3610 case (ISYMNUM (SCM_IM_NIL_COND
)):
3612 SCM test_form
= SCM_CDR (x
);
3613 x
= SCM_CDR (test_form
);
3614 while (!SCM_NULL_OR_NIL_P (x
))
3616 SCM test_result
= EVALCAR (test_form
, env
);
3617 if (!(SCM_FALSEP (test_result
)
3618 || SCM_NULL_OR_NIL_P (test_result
)))
3620 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
3621 RETURN (test_result
);
3622 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3627 test_form
= SCM_CDR (x
);
3628 x
= SCM_CDR (test_form
);
3632 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3636 #endif /* SCM_ENABLE_ELISP */
3638 case (ISYMNUM (SCM_IM_BIND
)):
3640 SCM vars
, exps
, vals
;
3643 vars
= SCM_CAAR (x
);
3644 exps
= SCM_CDAR (x
);
3646 while (!SCM_NULLP (exps
))
3648 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
3649 exps
= SCM_CDR (exps
);
3652 scm_swap_bindings (vars
, vals
);
3653 scm_dynwinds
= scm_acons (vars
, vals
, scm_dynwinds
);
3655 /* Ignore all but the last evaluation result. */
3656 for (x
= SCM_CDR (x
); !SCM_NULLP (SCM_CDR (x
)); x
= SCM_CDR (x
))
3658 if (SCM_CONSP (SCM_CAR (x
)))
3659 CEVAL (SCM_CAR (x
), env
);
3661 proc
= EVALCAR (x
, env
);
3663 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
3664 scm_swap_bindings (vars
, vals
);
3670 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
3675 producer
= EVALCAR (x
, env
);
3677 proc
= EVALCAR (x
, env
); /* proc is the consumer. */
3678 arg1
= SCM_APPLY (producer
, SCM_EOL
, SCM_EOL
);
3679 if (SCM_VALUESP (arg1
))
3681 /* The list of arguments is not copied. Rather, it is assumed
3682 * that this has been done by the 'values' procedure. */
3683 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
3687 arg1
= scm_list_1 (arg1
);
3689 PREP_APPLY (proc
, arg1
);
3700 if (SCM_VARIABLEP (SCM_CAR (x
)))
3701 proc
= SCM_VARIABLE_REF (SCM_CAR (x
));
3702 else if (SCM_ILOCP (SCM_CAR (x
)))
3703 proc
= *scm_ilookup (SCM_CAR (x
), env
);
3704 else if (SCM_CONSP (SCM_CAR (x
)))
3705 proc
= CEVAL (SCM_CAR (x
), env
);
3706 else if (SCM_SYMBOLP (SCM_CAR (x
)))
3708 SCM orig_sym
= SCM_CAR (x
);
3710 SCM
*location
= scm_lookupcar1 (x
, env
, 1);
3711 if (location
== NULL
)
3713 /* we have lost the race, start again. */
3719 if (SCM_MACROP (proc
))
3721 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
3723 handle_a_macro
: /* inputs: x, env, proc */
3725 /* Set a flag during macro expansion so that macro
3726 application frames can be deleted from the backtrace. */
3727 SCM_SET_MACROEXP (debug
);
3729 arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
3730 scm_cons (env
, scm_listofnull
));
3732 SCM_CLEAR_MACROEXP (debug
);
3734 switch (SCM_MACRO_TYPE (proc
))
3738 if (scm_ilength (arg1
) <= 0)
3739 arg1
= scm_list_2 (SCM_IM_BEGIN
, arg1
);
3741 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
3744 SCM_SETCAR (x
, SCM_CAR (arg1
));
3745 SCM_SETCDR (x
, SCM_CDR (arg1
));
3749 /* Prevent memoizing of debug info expression. */
3750 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
3755 SCM_SETCAR (x
, SCM_CAR (arg1
));
3756 SCM_SETCDR (x
, SCM_CDR (arg1
));
3758 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3760 #if SCM_ENABLE_DEPRECATED == 1
3765 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3779 if (SCM_MACROP (proc
))
3780 goto handle_a_macro
;
3784 /* When reaching this part of the code, the following is granted: Variable x
3785 * holds the first pair of an expression of the form (<function> arg ...).
3786 * Variable proc holds the object that resulted from the evaluation of
3787 * <function>. In the following, the arguments (if any) will be evaluated,
3788 * and proc will be applied to them. If proc does not really hold a
3789 * function object, this will be signalled as an error on the scheme
3790 * level. If the number of arguments does not match the number of arguments
3791 * that are allowed to be passed to proc, also an error on the scheme level
3792 * will be signalled. */
3793 PREP_APPLY (proc
, SCM_EOL
);
3794 if (SCM_NULLP (SCM_CDR (x
))) {
3797 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3798 switch (SCM_TYP7 (proc
))
3799 { /* no arguments given */
3800 case scm_tc7_subr_0
:
3801 RETURN (SCM_SUBRF (proc
) ());
3802 case scm_tc7_subr_1o
:
3803 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
3805 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
3806 case scm_tc7_rpsubr
:
3807 RETURN (SCM_BOOL_T
);
3809 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
3811 if (!SCM_SMOB_APPLICABLE_P (proc
))
3813 RETURN (SCM_SMOB_APPLY_0 (proc
));
3816 proc
= SCM_CCLO_SUBR (proc
);
3818 debug
.info
->a
.proc
= proc
;
3819 debug
.info
->a
.args
= scm_list_1 (arg1
);
3823 proc
= SCM_PROCEDURE (proc
);
3825 debug
.info
->a
.proc
= proc
;
3827 if (!SCM_CLOSUREP (proc
))
3830 case scm_tcs_closures
:
3832 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3833 if (SCM_CONSP (formals
))
3834 goto umwrongnumargs
;
3835 x
= SCM_CLOSURE_BODY (proc
);
3836 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
3837 goto nontoplevel_begin
;
3839 case scm_tcs_struct
:
3840 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3842 x
= SCM_ENTITY_PROCEDURE (proc
);
3846 else if (SCM_I_OPERATORP (proc
))
3849 proc
= (SCM_I_ENTITYP (proc
)
3850 ? SCM_ENTITY_PROCEDURE (proc
)
3851 : SCM_OPERATOR_PROCEDURE (proc
));
3853 debug
.info
->a
.proc
= proc
;
3854 debug
.info
->a
.args
= scm_list_1 (arg1
);
3860 case scm_tc7_subr_1
:
3861 case scm_tc7_subr_2
:
3862 case scm_tc7_subr_2o
:
3865 case scm_tc7_subr_3
:
3866 case scm_tc7_lsubr_2
:
3869 scm_wrong_num_args (proc
);
3872 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
3876 /* must handle macros by here */
3879 arg1
= EVALCAR (x
, env
);
3881 scm_wrong_num_args (proc
);
3883 debug
.info
->a
.args
= scm_list_1 (arg1
);
3891 evap1
: /* inputs: proc, arg1 */
3892 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3893 switch (SCM_TYP7 (proc
))
3894 { /* have one argument in arg1 */
3895 case scm_tc7_subr_2o
:
3896 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3897 case scm_tc7_subr_1
:
3898 case scm_tc7_subr_1o
:
3899 RETURN (SCM_SUBRF (proc
) (arg1
));
3901 if (SCM_INUMP (arg1
))
3903 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3905 else if (SCM_REALP (arg1
))
3907 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3909 else if (SCM_BIGP (arg1
))
3911 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3913 else if (SCM_FRACTIONP (arg1
))
3915 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
3917 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3918 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3921 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
3924 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
3925 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3926 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3931 case scm_tc7_rpsubr
:
3932 RETURN (SCM_BOOL_T
);
3934 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3937 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3939 RETURN (SCM_SUBRF (proc
) (scm_list_1 (arg1
)));
3942 if (!SCM_SMOB_APPLICABLE_P (proc
))
3944 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
3948 proc
= SCM_CCLO_SUBR (proc
);
3950 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
3951 debug
.info
->a
.proc
= proc
;
3955 proc
= SCM_PROCEDURE (proc
);
3957 debug
.info
->a
.proc
= proc
;
3959 if (!SCM_CLOSUREP (proc
))
3962 case scm_tcs_closures
:
3965 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3966 if (SCM_NULLP (formals
)
3967 || (SCM_CONSP (formals
) && SCM_CONSP (SCM_CDR (formals
))))
3968 goto umwrongnumargs
;
3969 x
= SCM_CLOSURE_BODY (proc
);
3971 env
= SCM_EXTEND_ENV (formals
,
3975 env
= SCM_EXTEND_ENV (formals
,
3979 goto nontoplevel_begin
;
3981 case scm_tcs_struct
:
3982 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3984 x
= SCM_ENTITY_PROCEDURE (proc
);
3986 arg1
= debug
.info
->a
.args
;
3988 arg1
= scm_list_1 (arg1
);
3992 else if (SCM_I_OPERATORP (proc
))
3996 proc
= (SCM_I_ENTITYP (proc
)
3997 ? SCM_ENTITY_PROCEDURE (proc
)
3998 : SCM_OPERATOR_PROCEDURE (proc
));
4000 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
4001 debug
.info
->a
.proc
= proc
;
4007 case scm_tc7_subr_2
:
4008 case scm_tc7_subr_0
:
4009 case scm_tc7_subr_3
:
4010 case scm_tc7_lsubr_2
:
4011 scm_wrong_num_args (proc
);
4017 arg2
= EVALCAR (x
, env
);
4019 scm_wrong_num_args (proc
);
4021 { /* have two or more arguments */
4023 debug
.info
->a
.args
= scm_list_2 (arg1
, arg2
);
4026 if (SCM_NULLP (x
)) {
4029 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4030 switch (SCM_TYP7 (proc
))
4031 { /* have two arguments */
4032 case scm_tc7_subr_2
:
4033 case scm_tc7_subr_2o
:
4034 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
4037 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4039 RETURN (SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
)));
4041 case scm_tc7_lsubr_2
:
4042 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
));
4043 case scm_tc7_rpsubr
:
4045 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
4047 if (!SCM_SMOB_APPLICABLE_P (proc
))
4049 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
));
4053 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
4054 scm_cons (proc
, debug
.info
->a
.args
),
4057 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
4058 scm_cons2 (proc
, arg1
,
4065 case scm_tcs_struct
:
4066 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4068 x
= SCM_ENTITY_PROCEDURE (proc
);
4070 arg1
= debug
.info
->a
.args
;
4072 arg1
= scm_list_2 (arg1
, arg2
);
4076 else if (SCM_I_OPERATORP (proc
))
4080 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
4081 ? SCM_ENTITY_PROCEDURE (proc
)
4082 : SCM_OPERATOR_PROCEDURE (proc
),
4083 scm_cons (proc
, debug
.info
->a
.args
),
4086 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
4087 ? SCM_ENTITY_PROCEDURE (proc
)
4088 : SCM_OPERATOR_PROCEDURE (proc
),
4089 scm_cons2 (proc
, arg1
,
4099 case scm_tc7_subr_0
:
4102 case scm_tc7_subr_1o
:
4103 case scm_tc7_subr_1
:
4104 case scm_tc7_subr_3
:
4105 scm_wrong_num_args (proc
);
4109 proc
= SCM_PROCEDURE (proc
);
4111 debug
.info
->a
.proc
= proc
;
4113 if (!SCM_CLOSUREP (proc
))
4116 case scm_tcs_closures
:
4119 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4120 if (SCM_NULLP (formals
)
4121 || (SCM_CONSP (formals
)
4122 && (SCM_NULLP (SCM_CDR (formals
))
4123 || (SCM_CONSP (SCM_CDR (formals
))
4124 && SCM_CONSP (SCM_CDDR (formals
))))))
4125 goto umwrongnumargs
;
4127 env
= SCM_EXTEND_ENV (formals
,
4131 env
= SCM_EXTEND_ENV (formals
,
4132 scm_list_2 (arg1
, arg2
),
4135 x
= SCM_CLOSURE_BODY (proc
);
4136 goto nontoplevel_begin
;
4141 scm_wrong_num_args (proc
);
4143 debug
.info
->a
.args
= scm_cons2 (arg1
, arg2
,
4144 deval_args (x
, env
, proc
,
4145 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
4149 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4150 switch (SCM_TYP7 (proc
))
4151 { /* have 3 or more arguments */
4153 case scm_tc7_subr_3
:
4154 if (!SCM_NULLP (SCM_CDR (x
)))
4155 scm_wrong_num_args (proc
);
4157 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4158 SCM_CADDR (debug
.info
->a
.args
)));
4160 arg1
= SCM_SUBRF(proc
)(arg1
, arg2
);
4161 arg2
= SCM_CDDR (debug
.info
->a
.args
);
4164 arg1
= SCM_SUBRF(proc
)(arg1
, SCM_CAR (arg2
));
4165 arg2
= SCM_CDR (arg2
);
4167 while (SCM_NIMP (arg2
));
4169 case scm_tc7_rpsubr
:
4170 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
4171 RETURN (SCM_BOOL_F
);
4172 arg1
= SCM_CDDR (debug
.info
->a
.args
);
4175 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (arg1
))))
4176 RETURN (SCM_BOOL_F
);
4177 arg2
= SCM_CAR (arg1
);
4178 arg1
= SCM_CDR (arg1
);
4180 while (SCM_NIMP (arg1
));
4181 RETURN (SCM_BOOL_T
);
4182 case scm_tc7_lsubr_2
:
4183 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4184 SCM_CDDR (debug
.info
->a
.args
)));
4186 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4188 if (!SCM_SMOB_APPLICABLE_P (proc
))
4190 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4191 SCM_CDDR (debug
.info
->a
.args
)));
4195 proc
= SCM_PROCEDURE (proc
);
4196 debug
.info
->a
.proc
= proc
;
4197 if (!SCM_CLOSUREP (proc
))
4200 case scm_tcs_closures
:
4202 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4203 if (SCM_NULLP (formals
)
4204 || (SCM_CONSP (formals
)
4205 && (SCM_NULLP (SCM_CDR (formals
))
4206 || (SCM_CONSP (SCM_CDR (formals
))
4207 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4208 goto umwrongnumargs
;
4209 SCM_SET_ARGSREADY (debug
);
4210 env
= SCM_EXTEND_ENV (formals
,
4213 x
= SCM_CLOSURE_BODY (proc
);
4214 goto nontoplevel_begin
;
4217 case scm_tc7_subr_3
:
4218 if (!SCM_NULLP (SCM_CDR (x
)))
4219 scm_wrong_num_args (proc
);
4221 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, EVALCAR (x
, env
)));
4223 arg1
= SCM_SUBRF (proc
) (arg1
, arg2
);
4226 arg1
= SCM_SUBRF(proc
)(arg1
, EVALCAR(x
, env
));
4229 while (!SCM_NULLP (x
));
4231 case scm_tc7_rpsubr
:
4232 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
4233 RETURN (SCM_BOOL_F
);
4236 arg1
= EVALCAR (x
, env
);
4237 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, arg1
)))
4238 RETURN (SCM_BOOL_F
);
4242 while (!SCM_NULLP (x
));
4243 RETURN (SCM_BOOL_T
);
4244 case scm_tc7_lsubr_2
:
4245 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
4247 RETURN (SCM_SUBRF (proc
) (scm_cons2 (arg1
,
4249 scm_eval_args (x
, env
, proc
))));
4251 if (!SCM_SMOB_APPLICABLE_P (proc
))
4253 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4254 scm_eval_args (x
, env
, proc
)));
4258 proc
= SCM_PROCEDURE (proc
);
4259 if (!SCM_CLOSUREP (proc
))
4262 case scm_tcs_closures
:
4264 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4265 if (SCM_NULLP (formals
)
4266 || (SCM_CONSP (formals
)
4267 && (SCM_NULLP (SCM_CDR (formals
))
4268 || (SCM_CONSP (SCM_CDR (formals
))
4269 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4270 goto umwrongnumargs
;
4271 env
= SCM_EXTEND_ENV (formals
,
4274 scm_eval_args (x
, env
, proc
)),
4276 x
= SCM_CLOSURE_BODY (proc
);
4277 goto nontoplevel_begin
;
4280 case scm_tcs_struct
:
4281 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4284 arg1
= debug
.info
->a
.args
;
4286 arg1
= scm_cons2 (arg1
, arg2
, scm_eval_args (x
, env
, proc
));
4288 x
= SCM_ENTITY_PROCEDURE (proc
);
4291 else if (SCM_I_OPERATORP (proc
))
4295 case scm_tc7_subr_2
:
4296 case scm_tc7_subr_1o
:
4297 case scm_tc7_subr_2o
:
4298 case scm_tc7_subr_0
:
4301 case scm_tc7_subr_1
:
4302 scm_wrong_num_args (proc
);
4310 if (scm_check_exit_p
&& SCM_TRAPS_P
)
4311 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
4313 SCM_CLEAR_TRACED_FRAME (debug
);
4314 if (SCM_CHEAPTRAPS_P
)
4315 arg1
= scm_make_debugobj (&debug
);
4319 SCM val
= scm_make_continuation (&first
);
4330 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
4334 scm_last_debug_frame
= debug
.prev
;
4340 /* SECTION: This code is compiled once.
4347 /* Simple procedure calls
4351 scm_call_0 (SCM proc
)
4353 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
4357 scm_call_1 (SCM proc
, SCM arg1
)
4359 return scm_apply (proc
, arg1
, scm_listofnull
);
4363 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
4365 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
4369 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
4371 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
4375 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
4377 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
4378 scm_cons (arg4
, scm_listofnull
)));
4381 /* Simple procedure applies
4385 scm_apply_0 (SCM proc
, SCM args
)
4387 return scm_apply (proc
, args
, SCM_EOL
);
4391 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
4393 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
4397 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
4399 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
4403 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
4405 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
4409 /* This code processes the arguments to apply:
4411 (apply PROC ARG1 ... ARGS)
4413 Given a list (ARG1 ... ARGS), this function conses the ARG1
4414 ... arguments onto the front of ARGS, and returns the resulting
4415 list. Note that ARGS is a list; thus, the argument to this
4416 function is a list whose last element is a list.
4418 Apply calls this function, and applies PROC to the elements of the
4419 result. apply:nconc2last takes care of building the list of
4420 arguments, given (ARG1 ... ARGS).
4422 Rather than do new consing, apply:nconc2last destroys its argument.
4423 On that topic, this code came into my care with the following
4424 beautifully cryptic comment on that topic: "This will only screw
4425 you if you do (scm_apply scm_apply '( ... ))" If you know what
4426 they're referring to, send me a patch to this comment. */
4428 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
4430 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
4431 "conses the @var{arg1} @dots{} arguments onto the front of\n"
4432 "@var{args}, and returns the resulting list. Note that\n"
4433 "@var{args} is a list; thus, the argument to this function is\n"
4434 "a list whose last element is a list.\n"
4435 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
4436 "destroys its argument, so use with care.")
4437 #define FUNC_NAME s_scm_nconc2last
4440 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
4442 while (!SCM_NULLP (SCM_CDR (*lloc
))) /* Perhaps should be
4443 SCM_NULL_OR_NIL_P, but not
4444 needed in 99.99% of cases,
4445 and it could seriously hurt
4446 performance. - Neil */
4447 lloc
= SCM_CDRLOC (*lloc
);
4448 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
4449 *lloc
= SCM_CAR (*lloc
);
4457 /* SECTION: When DEVAL is defined this code yields scm_dapply.
4458 * It is compiled twice.
4463 scm_apply (SCM proc
, SCM arg1
, SCM args
)
4469 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
4474 /* Apply a function to a list of arguments.
4476 This function is exported to the Scheme level as taking two
4477 required arguments and a tail argument, as if it were:
4478 (lambda (proc arg1 . args) ...)
4479 Thus, if you just have a list of arguments to pass to a procedure,
4480 pass the list as ARG1, and '() for ARGS. If you have some fixed
4481 args, pass the first as ARG1, then cons any remaining fixed args
4482 onto the front of your argument list, and pass that as ARGS. */
4485 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
4488 scm_t_debug_frame debug
;
4489 scm_t_debug_info debug_vect_body
;
4490 debug
.prev
= scm_last_debug_frame
;
4491 debug
.status
= SCM_APPLYFRAME
;
4492 debug
.vect
= &debug_vect_body
;
4493 debug
.vect
[0].a
.proc
= proc
;
4494 debug
.vect
[0].a
.args
= SCM_EOL
;
4495 scm_last_debug_frame
= &debug
;
4497 if (scm_debug_mode_p
)
4498 return scm_dapply (proc
, arg1
, args
);
4501 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
4503 /* If ARGS is the empty list, then we're calling apply with only two
4504 arguments --- ARG1 is the list of arguments for PROC. Whatever
4505 the case, futz with things so that ARG1 is the first argument to
4506 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
4509 Setting the debug apply frame args this way is pretty messy.
4510 Perhaps we should store arg1 and args directly in the frame as
4511 received, and let scm_frame_arguments unpack them, because that's
4512 a relatively rare operation. This works for now; if the Guile
4513 developer archives are still around, see Mikael's post of
4515 if (SCM_NULLP (args
))
4517 if (SCM_NULLP (arg1
))
4519 arg1
= SCM_UNDEFINED
;
4521 debug
.vect
[0].a
.args
= SCM_EOL
;
4527 debug
.vect
[0].a
.args
= arg1
;
4529 args
= SCM_CDR (arg1
);
4530 arg1
= SCM_CAR (arg1
);
4535 args
= scm_nconc2last (args
);
4537 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4541 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
4544 if (SCM_CHEAPTRAPS_P
)
4545 tmp
= scm_make_debugobj (&debug
);
4550 tmp
= scm_make_continuation (&first
);
4555 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
4562 switch (SCM_TYP7 (proc
))
4564 case scm_tc7_subr_2o
:
4565 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
4566 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4567 case scm_tc7_subr_2
:
4568 if (SCM_NULLP (args
) || !SCM_NULLP (SCM_CDR (args
)))
4569 scm_wrong_num_args (proc
);
4570 args
= SCM_CAR (args
);
4571 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4572 case scm_tc7_subr_0
:
4573 if (!SCM_UNBNDP (arg1
))
4574 scm_wrong_num_args (proc
);
4576 RETURN (SCM_SUBRF (proc
) ());
4577 case scm_tc7_subr_1
:
4578 if (SCM_UNBNDP (arg1
))
4579 scm_wrong_num_args (proc
);
4580 case scm_tc7_subr_1o
:
4581 if (!SCM_NULLP (args
))
4582 scm_wrong_num_args (proc
);
4584 RETURN (SCM_SUBRF (proc
) (arg1
));
4586 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
4587 scm_wrong_num_args (proc
);
4588 if (SCM_INUMP (arg1
))
4590 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
4592 else if (SCM_REALP (arg1
))
4594 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4596 else if (SCM_BIGP (arg1
))
4598 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4600 else if (SCM_FRACTIONP (arg1
))
4602 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4604 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4605 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4607 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
4608 scm_wrong_num_args (proc
);
4610 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
4613 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
4614 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4615 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
4620 case scm_tc7_subr_3
:
4621 if (SCM_NULLP (args
)
4622 || SCM_NULLP (SCM_CDR (args
))
4623 || !SCM_NULLP (SCM_CDDR (args
)))
4624 scm_wrong_num_args (proc
);
4626 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
4629 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
4631 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
4633 case scm_tc7_lsubr_2
:
4634 if (!SCM_CONSP (args
))
4635 scm_wrong_num_args (proc
);
4637 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4639 if (SCM_NULLP (args
))
4640 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4641 while (SCM_NIMP (args
))
4643 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
4644 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
4645 args
= SCM_CDR (args
);
4648 case scm_tc7_rpsubr
:
4649 if (SCM_NULLP (args
))
4650 RETURN (SCM_BOOL_T
);
4651 while (SCM_NIMP (args
))
4653 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
4654 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
4655 RETURN (SCM_BOOL_F
);
4656 arg1
= SCM_CAR (args
);
4657 args
= SCM_CDR (args
);
4659 RETURN (SCM_BOOL_T
);
4660 case scm_tcs_closures
:
4662 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4664 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4666 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
4667 scm_wrong_num_args (proc
);
4669 /* Copy argument list */
4674 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
4675 for (arg1
= SCM_CDR (arg1
); SCM_CONSP (arg1
); arg1
= SCM_CDR (arg1
))
4677 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
));
4680 SCM_SETCDR (tl
, arg1
);
4683 args
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4686 proc
= SCM_CLOSURE_BODY (proc
);
4688 arg1
= SCM_CDR (proc
);
4689 while (!SCM_NULLP (arg1
))
4691 if (SCM_IMP (SCM_CAR (proc
)))
4693 if (SCM_ISYMP (SCM_CAR (proc
)))
4695 scm_rec_mutex_lock (&source_mutex
);
4696 /* check for race condition */
4697 if (SCM_ISYMP (SCM_CAR (proc
)))
4698 m_expand_body (proc
, args
);
4699 scm_rec_mutex_unlock (&source_mutex
);
4703 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
4706 (void) EVAL (SCM_CAR (proc
), args
);
4708 arg1
= SCM_CDR (proc
);
4710 RETURN (EVALCAR (proc
, args
));
4712 if (!SCM_SMOB_APPLICABLE_P (proc
))
4714 if (SCM_UNBNDP (arg1
))
4715 RETURN (SCM_SMOB_APPLY_0 (proc
));
4716 else if (SCM_NULLP (args
))
4717 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
4718 else if (SCM_NULLP (SCM_CDR (args
)))
4719 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
4721 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4724 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4726 proc
= SCM_CCLO_SUBR (proc
);
4727 debug
.vect
[0].a
.proc
= proc
;
4728 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4730 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4732 proc
= SCM_CCLO_SUBR (proc
);
4736 proc
= SCM_PROCEDURE (proc
);
4738 debug
.vect
[0].a
.proc
= proc
;
4741 case scm_tcs_struct
:
4742 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4745 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4747 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4749 RETURN (scm_apply_generic (proc
, args
));
4751 else if (SCM_I_OPERATORP (proc
))
4755 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4757 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4760 proc
= (SCM_I_ENTITYP (proc
)
4761 ? SCM_ENTITY_PROCEDURE (proc
)
4762 : SCM_OPERATOR_PROCEDURE (proc
));
4764 debug
.vect
[0].a
.proc
= proc
;
4765 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4767 if (SCM_NIMP (proc
))
4776 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
4780 if (scm_check_exit_p
&& SCM_TRAPS_P
)
4781 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
4783 SCM_CLEAR_TRACED_FRAME (debug
);
4784 if (SCM_CHEAPTRAPS_P
)
4785 arg1
= scm_make_debugobj (&debug
);
4789 SCM val
= scm_make_continuation (&first
);
4800 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
4804 scm_last_debug_frame
= debug
.prev
;
4810 /* SECTION: The rest of this file is only read once.
4817 * Trampolines make it possible to move procedure application dispatch
4818 * outside inner loops. The motivation was clean implementation of
4819 * efficient replacements of R5RS primitives in SRFI-1.
4821 * The semantics is clear: scm_trampoline_N returns an optimized
4822 * version of scm_call_N (or NULL if the procedure isn't applicable
4825 * Applying the optimization to map and for-each increased efficiency
4826 * noticeably. For example, (map abs ls) is now 8 times faster than
4831 call_subr0_0 (SCM proc
)
4833 return SCM_SUBRF (proc
) ();
4837 call_subr1o_0 (SCM proc
)
4839 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
4843 call_lsubr_0 (SCM proc
)
4845 return SCM_SUBRF (proc
) (SCM_EOL
);
4849 scm_i_call_closure_0 (SCM proc
)
4851 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4854 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
4859 scm_trampoline_0 (SCM proc
)
4861 scm_t_trampoline_0 trampoline
;
4866 switch (SCM_TYP7 (proc
))
4868 case scm_tc7_subr_0
:
4869 trampoline
= call_subr0_0
;
4871 case scm_tc7_subr_1o
:
4872 trampoline
= call_subr1o_0
;
4875 trampoline
= call_lsubr_0
;
4877 case scm_tcs_closures
:
4879 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4880 if (SCM_NULLP (formals
) || !SCM_CONSP (formals
))
4881 trampoline
= scm_i_call_closure_0
;
4886 case scm_tcs_struct
:
4887 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4888 trampoline
= scm_call_generic_0
;
4889 else if (SCM_I_OPERATORP (proc
))
4890 trampoline
= scm_call_0
;
4895 if (SCM_SMOB_APPLICABLE_P (proc
))
4896 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
4901 case scm_tc7_rpsubr
:
4904 trampoline
= scm_call_0
;
4907 return NULL
; /* not applicable on zero arguments */
4909 /* We only reach this point if a valid trampoline was determined. */
4911 /* If debugging is enabled, we want to see all calls to proc on the stack.
4912 * Thus, we replace the trampoline shortcut with scm_call_0. */
4913 if (scm_debug_mode_p
)
4920 call_subr1_1 (SCM proc
, SCM arg1
)
4922 return SCM_SUBRF (proc
) (arg1
);
4926 call_subr2o_1 (SCM proc
, SCM arg1
)
4928 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
4932 call_lsubr_1 (SCM proc
, SCM arg1
)
4934 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
4938 call_dsubr_1 (SCM proc
, SCM arg1
)
4940 if (SCM_INUMP (arg1
))
4942 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
4944 else if (SCM_REALP (arg1
))
4946 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4948 else if (SCM_BIGP (arg1
))
4950 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4952 else if (SCM_FRACTIONP (arg1
))
4954 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4956 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4957 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4961 call_cxr_1 (SCM proc
, SCM arg1
)
4963 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
4966 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
4967 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4968 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
4975 call_closure_1 (SCM proc
, SCM arg1
)
4977 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4980 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
4985 scm_trampoline_1 (SCM proc
)
4987 scm_t_trampoline_1 trampoline
;
4992 switch (SCM_TYP7 (proc
))
4994 case scm_tc7_subr_1
:
4995 case scm_tc7_subr_1o
:
4996 trampoline
= call_subr1_1
;
4998 case scm_tc7_subr_2o
:
4999 trampoline
= call_subr2o_1
;
5002 trampoline
= call_lsubr_1
;
5005 trampoline
= call_dsubr_1
;
5008 trampoline
= call_cxr_1
;
5010 case scm_tcs_closures
:
5012 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5013 if (!SCM_NULLP (formals
)
5014 && (!SCM_CONSP (formals
) || !SCM_CONSP (SCM_CDR (formals
))))
5015 trampoline
= call_closure_1
;
5020 case scm_tcs_struct
:
5021 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5022 trampoline
= scm_call_generic_1
;
5023 else if (SCM_I_OPERATORP (proc
))
5024 trampoline
= scm_call_1
;
5029 if (SCM_SMOB_APPLICABLE_P (proc
))
5030 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
5035 case scm_tc7_rpsubr
:
5038 trampoline
= scm_call_1
;
5041 return NULL
; /* not applicable on one arg */
5043 /* We only reach this point if a valid trampoline was determined. */
5045 /* If debugging is enabled, we want to see all calls to proc on the stack.
5046 * Thus, we replace the trampoline shortcut with scm_call_1. */
5047 if (scm_debug_mode_p
)
5054 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
5056 return SCM_SUBRF (proc
) (arg1
, arg2
);
5060 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
5062 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
5066 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
5068 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
5072 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
5074 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
5075 scm_list_2 (arg1
, arg2
),
5077 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
5082 scm_trampoline_2 (SCM proc
)
5084 scm_t_trampoline_2 trampoline
;
5089 switch (SCM_TYP7 (proc
))
5091 case scm_tc7_subr_2
:
5092 case scm_tc7_subr_2o
:
5093 case scm_tc7_rpsubr
:
5095 trampoline
= call_subr2_2
;
5097 case scm_tc7_lsubr_2
:
5098 trampoline
= call_lsubr2_2
;
5101 trampoline
= call_lsubr_2
;
5103 case scm_tcs_closures
:
5105 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5106 if (!SCM_NULLP (formals
)
5107 && (!SCM_CONSP (formals
)
5108 || (!SCM_NULLP (SCM_CDR (formals
))
5109 && (!SCM_CONSP (SCM_CDR (formals
))
5110 || !SCM_CONSP (SCM_CDDR (formals
))))))
5111 trampoline
= call_closure_2
;
5116 case scm_tcs_struct
:
5117 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5118 trampoline
= scm_call_generic_2
;
5119 else if (SCM_I_OPERATORP (proc
))
5120 trampoline
= scm_call_2
;
5125 if (SCM_SMOB_APPLICABLE_P (proc
))
5126 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
5132 trampoline
= scm_call_2
;
5135 return NULL
; /* not applicable on two args */
5137 /* We only reach this point if a valid trampoline was determined. */
5139 /* If debugging is enabled, we want to see all calls to proc on the stack.
5140 * Thus, we replace the trampoline shortcut with scm_call_2. */
5141 if (scm_debug_mode_p
)
5147 /* Typechecking for multi-argument MAP and FOR-EACH.
5149 Verify that each element of the vector ARGV, except for the first,
5150 is a proper list whose length is LEN. Attribute errors to WHO,
5151 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
5153 check_map_args (SCM argv
,
5160 SCM
const *ve
= SCM_VELTS (argv
);
5163 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
5165 long elt_len
= scm_ilength (ve
[i
]);
5170 scm_apply_generic (gf
, scm_cons (proc
, args
));
5172 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
5176 scm_out_of_range_pos (who
, ve
[i
], SCM_MAKINUM (i
+ 2));
5179 scm_remember_upto_here_1 (argv
);
5183 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
5185 /* Note: Currently, scm_map applies PROC to the argument list(s)
5186 sequentially, starting with the first element(s). This is used in
5187 evalext.c where the Scheme procedure `map-in-order', which guarantees
5188 sequential behaviour, is implemented using scm_map. If the
5189 behaviour changes, we need to update `map-in-order'.
5193 scm_map (SCM proc
, SCM arg1
, SCM args
)
5194 #define FUNC_NAME s_map
5199 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
5201 len
= scm_ilength (arg1
);
5202 SCM_GASSERTn (len
>= 0,
5203 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
5204 SCM_VALIDATE_REST_ARGUMENT (args
);
5205 if (SCM_NULLP (args
))
5207 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5208 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
5209 while (SCM_NIMP (arg1
))
5211 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
5212 pres
= SCM_CDRLOC (*pres
);
5213 arg1
= SCM_CDR (arg1
);
5217 if (SCM_NULLP (SCM_CDR (args
)))
5219 SCM arg2
= SCM_CAR (args
);
5220 int len2
= scm_ilength (arg2
);
5221 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5223 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
5224 SCM_GASSERTn (len2
>= 0,
5225 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
5227 SCM_OUT_OF_RANGE (3, arg2
);
5228 while (SCM_NIMP (arg1
))
5230 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
5231 pres
= SCM_CDRLOC (*pres
);
5232 arg1
= SCM_CDR (arg1
);
5233 arg2
= SCM_CDR (arg2
);
5237 arg1
= scm_cons (arg1
, args
);
5238 args
= scm_vector (arg1
);
5239 ve
= SCM_VELTS (args
);
5240 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
5244 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5246 if (SCM_IMP (ve
[i
]))
5248 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
5249 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
5251 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
5252 pres
= SCM_CDRLOC (*pres
);
5258 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
5261 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
5262 #define FUNC_NAME s_for_each
5264 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
5266 len
= scm_ilength (arg1
);
5267 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
5268 SCM_ARG2
, s_for_each
);
5269 SCM_VALIDATE_REST_ARGUMENT (args
);
5270 if (SCM_NULLP (args
))
5272 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5273 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
5274 while (SCM_NIMP (arg1
))
5276 call (proc
, SCM_CAR (arg1
));
5277 arg1
= SCM_CDR (arg1
);
5279 return SCM_UNSPECIFIED
;
5281 if (SCM_NULLP (SCM_CDR (args
)))
5283 SCM arg2
= SCM_CAR (args
);
5284 int len2
= scm_ilength (arg2
);
5285 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5286 SCM_GASSERTn (call
, g_for_each
,
5287 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
5288 SCM_GASSERTn (len2
>= 0, g_for_each
,
5289 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
5291 SCM_OUT_OF_RANGE (3, arg2
);
5292 while (SCM_NIMP (arg1
))
5294 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
5295 arg1
= SCM_CDR (arg1
);
5296 arg2
= SCM_CDR (arg2
);
5298 return SCM_UNSPECIFIED
;
5300 arg1
= scm_cons (arg1
, args
);
5301 args
= scm_vector (arg1
);
5302 ve
= SCM_VELTS (args
);
5303 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
5307 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5309 if (SCM_IMP (ve
[i
]))
5310 return SCM_UNSPECIFIED
;
5311 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
5312 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
5314 scm_apply (proc
, arg1
, SCM_EOL
);
5321 scm_closure (SCM code
, SCM env
)
5324 SCM closcar
= scm_cons (code
, SCM_EOL
);
5325 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
5326 scm_remember_upto_here (closcar
);
5331 scm_t_bits scm_tc16_promise
;
5334 scm_makprom (SCM code
)
5336 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
5338 scm_make_rec_mutex ());
5342 promise_free (SCM promise
)
5344 scm_rec_mutex_free (SCM_PROMISE_MUTEX (promise
));
5349 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
5351 int writingp
= SCM_WRITINGP (pstate
);
5352 scm_puts ("#<promise ", port
);
5353 SCM_SET_WRITINGP (pstate
, 1);
5354 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
5355 SCM_SET_WRITINGP (pstate
, writingp
);
5356 scm_putc ('>', port
);
5360 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
5362 "If the promise @var{x} has not been computed yet, compute and\n"
5363 "return @var{x}, otherwise just return the previously computed\n"
5365 #define FUNC_NAME s_scm_force
5367 SCM_VALIDATE_SMOB (1, promise
, promise
);
5368 scm_rec_mutex_lock (SCM_PROMISE_MUTEX (promise
));
5369 if (!SCM_PROMISE_COMPUTED_P (promise
))
5371 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
5372 if (!SCM_PROMISE_COMPUTED_P (promise
))
5374 SCM_SET_PROMISE_DATA (promise
, ans
);
5375 SCM_SET_PROMISE_COMPUTED (promise
);
5378 scm_rec_mutex_unlock (SCM_PROMISE_MUTEX (promise
));
5379 return SCM_PROMISE_DATA (promise
);
5384 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
5386 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
5387 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
5388 #define FUNC_NAME s_scm_promise_p
5390 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
5395 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
5396 (SCM xorig
, SCM x
, SCM y
),
5397 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
5398 "Any source properties associated with @var{xorig} are also associated\n"
5399 "with the new pair.")
5400 #define FUNC_NAME s_scm_cons_source
5403 z
= scm_cons (x
, y
);
5404 /* Copy source properties possibly associated with xorig. */
5405 p
= scm_whash_lookup (scm_source_whash
, xorig
);
5407 scm_whash_insert (scm_source_whash
, z
, p
);
5413 /* The function scm_copy_tree is used to copy an expression tree to allow the
5414 * memoizer to modify the expression during memoization. scm_copy_tree
5415 * creates deep copies of pairs and vectors, but not of any other data types,
5416 * since only pairs and vectors will be parsed by the memoizer.
5418 * To avoid infinite recursion due to cyclic structures, the hare-and-tortoise
5419 * pattern is used to detect cycles. In fact, the pattern is used in two
5420 * dimensions, vertical (indicated in the code by the variable names 'hare'
5421 * and 'tortoise') and horizontal ('rabbit' and 'turtle'). In both
5422 * dimensions, the hare/rabbit will take two steps when the tortoise/turtle
5425 * The vertical dimension corresponds to recursive calls to function
5426 * copy_tree: This happens when descending into vector elements, into cars of
5427 * lists and into the cdr of an improper list. In this dimension, the
5428 * tortoise follows the hare by using the processor stack: Every stack frame
5429 * will hold an instance of struct t_trace. These instances are connected in
5430 * a way that represents the trace of the hare, which thus can be followed by
5431 * the tortoise. The tortoise will always point to struct t_trace instances
5432 * relating to SCM objects that have already been copied. Thus, a cycle is
5433 * detected if the tortoise and the hare point to the same object,
5435 * The horizontal dimension is within one execution of copy_tree, when the
5436 * function cdr's along the pairs of a list. This is the standard
5437 * hare-and-tortoise implementation, found several times in guile. */
5440 struct t_trace
*trace
; // These pointers form a trace along the stack.
5441 SCM obj
; // The object handled at the respective stack frame.
5446 struct t_trace
*const hare
,
5447 struct t_trace
*tortoise
,
5448 unsigned int tortoise_delay
)
5450 if (!SCM_CONSP (hare
->obj
) && !SCM_VECTORP (hare
->obj
))
5456 /* Prepare the trace along the stack. */
5457 struct t_trace new_hare
;
5458 hare
->trace
= &new_hare
;
5460 /* The tortoise will make its step after the delay has elapsed. Note
5461 * that in contrast to the typical hare-and-tortoise pattern, the step
5462 * of the tortoise happens before the hare takes its steps. This is, in
5463 * principle, no problem, except for the start of the algorithm: Then,
5464 * it has to be made sure that the hare actually gets its advantage of
5466 if (tortoise_delay
== 0)
5469 tortoise
= tortoise
->trace
;
5470 ASSERT_SYNTAX (!SCM_EQ_P (hare
->obj
, tortoise
->obj
),
5471 s_bad_expression
, hare
->obj
);
5478 if (SCM_VECTORP (hare
->obj
))
5480 const unsigned long int length
= SCM_VECTOR_LENGTH (hare
->obj
);
5481 const SCM new_vector
= scm_c_make_vector (length
, SCM_UNSPECIFIED
);
5483 /* Each vector element is copied by recursing into copy_tree, having
5484 * the tortoise follow the hare into the depths of the stack. */
5485 unsigned long int i
;
5486 for (i
= 0; i
< length
; ++i
)
5489 new_hare
.obj
= SCM_VECTOR_REF (hare
->obj
, i
);
5490 new_element
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5491 SCM_VECTOR_SET (new_vector
, i
, new_element
);
5496 else // SCM_CONSP (hare->obj)
5501 SCM rabbit
= hare
->obj
;
5502 SCM turtle
= hare
->obj
;
5506 /* The first pair of the list is treated specially, in order to
5507 * preserve a potential source code position. */
5508 result
= tail
= scm_cons_source (rabbit
, SCM_EOL
, SCM_EOL
);
5509 new_hare
.obj
= SCM_CAR (rabbit
);
5510 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5511 SCM_SETCAR (tail
, copy
);
5513 /* The remaining pairs of the list are copied by, horizontally,
5514 * having the turtle follow the rabbit, and, vertically, having the
5515 * tortoise follow the hare into the depths of the stack. */
5516 rabbit
= SCM_CDR (rabbit
);
5517 while (SCM_CONSP (rabbit
))
5519 new_hare
.obj
= SCM_CAR (rabbit
);
5520 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5521 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
5522 tail
= SCM_CDR (tail
);
5524 rabbit
= SCM_CDR (rabbit
);
5525 if (SCM_CONSP (rabbit
))
5527 new_hare
.obj
= SCM_CAR (rabbit
);
5528 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5529 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
5530 tail
= SCM_CDR (tail
);
5531 rabbit
= SCM_CDR (rabbit
);
5533 turtle
= SCM_CDR (turtle
);
5534 ASSERT_SYNTAX (!SCM_EQ_P (rabbit
, turtle
),
5535 s_bad_expression
, rabbit
);
5539 /* We have to recurse into copy_tree again for the last cdr, in
5540 * order to handle the situation that it holds a vector. */
5541 new_hare
.obj
= rabbit
;
5542 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5543 SCM_SETCDR (tail
, copy
);
5550 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
5552 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
5553 "the new data structure. @code{copy-tree} recurses down the\n"
5554 "contents of both pairs and vectors (since both cons cells and vector\n"
5555 "cells may point to arbitrary objects), and stops recursing when it hits\n"
5556 "any other object.")
5557 #define FUNC_NAME s_scm_copy_tree
5559 /* Prepare the trace along the stack. */
5560 struct t_trace trace
;
5563 /* In function copy_tree, if the tortoise makes its step, it will do this
5564 * before the hare has the chance to move. Thus, we have to make sure that
5565 * the very first step of the tortoise will not happen after the hare has
5566 * really made two steps. This is achieved by passing '2' as the initial
5567 * delay for the tortoise. NOTE: Since cycles are unlikely, giving the hare
5568 * a bigger advantage may improve performance slightly. */
5569 return copy_tree (&trace
, &trace
, 2);
5574 /* We have three levels of EVAL here:
5576 - scm_i_eval (exp, env)
5578 evaluates EXP in environment ENV. ENV is a lexical environment
5579 structure as used by the actual tree code evaluator. When ENV is
5580 a top-level environment, then changes to the current module are
5581 tracked by updating ENV so that it continues to be in sync with
5584 - scm_primitive_eval (exp)
5586 evaluates EXP in the top-level environment as determined by the
5587 current module. This is done by constructing a suitable
5588 environment and calling scm_i_eval. Thus, changes to the
5589 top-level module are tracked normally.
5591 - scm_eval (exp, mod)
5593 evaluates EXP while MOD is the current module. This is done by
5594 setting the current module to MOD, invoking scm_primitive_eval on
5595 EXP, and then restoring the current module to the value it had
5596 previously. That is, while EXP is evaluated, changes to the
5597 current module are tracked, but these changes do not persist when
5600 For each level of evals, there are two variants, distinguished by a
5601 _x suffix: the ordinary variant does not modify EXP while the _x
5602 variant can destructively modify EXP into something completely
5603 unintelligible. A Scheme data structure passed as EXP to one of the
5604 _x variants should not ever be used again for anything. So when in
5605 doubt, use the ordinary variant.
5610 scm_i_eval_x (SCM exp
, SCM env
)
5612 if (SCM_SYMBOLP (exp
))
5613 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
5615 return SCM_XEVAL (exp
, env
);
5619 scm_i_eval (SCM exp
, SCM env
)
5621 exp
= scm_copy_tree (exp
);
5622 if (SCM_SYMBOLP (exp
))
5623 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
5625 return SCM_XEVAL (exp
, env
);
5629 scm_primitive_eval_x (SCM exp
)
5632 SCM transformer
= scm_current_module_transformer ();
5633 if (SCM_NIMP (transformer
))
5634 exp
= scm_call_1 (transformer
, exp
);
5635 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5636 return scm_i_eval_x (exp
, env
);
5639 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
5641 "Evaluate @var{exp} in the top-level environment specified by\n"
5642 "the current module.")
5643 #define FUNC_NAME s_scm_primitive_eval
5646 SCM transformer
= scm_current_module_transformer ();
5647 if (SCM_NIMP (transformer
))
5648 exp
= scm_call_1 (transformer
, exp
);
5649 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5650 return scm_i_eval (exp
, env
);
5655 /* Eval does not take the second arg optionally. This is intentional
5656 * in order to be R5RS compatible, and to prepare for the new module
5657 * system, where we would like to make the choice of evaluation
5658 * environment explicit. */
5661 change_environment (void *data
)
5663 SCM pair
= SCM_PACK (data
);
5664 SCM new_module
= SCM_CAR (pair
);
5665 SCM old_module
= scm_current_module ();
5666 SCM_SETCDR (pair
, old_module
);
5667 scm_set_current_module (new_module
);
5671 restore_environment (void *data
)
5673 SCM pair
= SCM_PACK (data
);
5674 SCM old_module
= SCM_CDR (pair
);
5675 SCM new_module
= scm_current_module ();
5676 SCM_SETCAR (pair
, new_module
);
5677 scm_set_current_module (old_module
);
5681 inner_eval_x (void *data
)
5683 return scm_primitive_eval_x (SCM_PACK(data
));
5687 scm_eval_x (SCM exp
, SCM module
)
5688 #define FUNC_NAME "eval!"
5690 SCM_VALIDATE_MODULE (2, module
);
5692 return scm_internal_dynamic_wind
5693 (change_environment
, inner_eval_x
, restore_environment
,
5694 (void *) SCM_UNPACK (exp
),
5695 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
5700 inner_eval (void *data
)
5702 return scm_primitive_eval (SCM_PACK(data
));
5705 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
5706 (SCM exp
, SCM module
),
5707 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
5708 "in the top-level environment specified by @var{module}.\n"
5709 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
5710 "@var{module} is made the current module. The current module\n"
5711 "is reset to its previous value when @var{eval} returns.")
5712 #define FUNC_NAME s_scm_eval
5714 SCM_VALIDATE_MODULE (2, module
);
5716 return scm_internal_dynamic_wind
5717 (change_environment
, inner_eval
, restore_environment
,
5718 (void *) SCM_UNPACK (exp
),
5719 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
5724 /* At this point, deval and scm_dapply are generated.
5731 #if (SCM_ENABLE_DEPRECATED == 1)
5733 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5734 SCM
scm_ceval (SCM x
, SCM env
)
5737 return ceval (x
, env
);
5738 else if (SCM_SYMBOLP (x
))
5739 return *scm_lookupcar (scm_cons (x
, SCM_UNDEFINED
), env
, 1);
5741 return SCM_XEVAL (x
, env
);
5744 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5745 SCM
scm_deval (SCM x
, SCM env
)
5748 return deval (x
, env
);
5749 else if (SCM_SYMBOLP (x
))
5750 return *scm_lookupcar (scm_cons (x
, SCM_UNDEFINED
), env
, 1);
5752 return SCM_XEVAL (x
, env
);
5756 dispatching_eval (SCM x
, SCM env
)
5758 if (scm_debug_mode_p
)
5759 return scm_deval (x
, env
);
5761 return scm_ceval (x
, env
);
5764 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5765 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
) = dispatching_eval
;
5773 scm_init_opts (scm_evaluator_traps
,
5774 scm_evaluator_trap_table
,
5775 SCM_N_EVALUATOR_TRAPS
);
5776 scm_init_opts (scm_eval_options_interface
,
5778 SCM_N_EVAL_OPTIONS
);
5780 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
5781 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
5782 scm_set_smob_free (scm_tc16_promise
, promise_free
);
5783 scm_set_smob_print (scm_tc16_promise
, promise_print
);
5785 undefineds
= scm_list_1 (SCM_UNDEFINED
);
5786 SCM_SETCDR (undefineds
, undefineds
);
5787 scm_permanent_object (undefineds
);
5789 scm_listofnull
= scm_list_1 (SCM_EOL
);
5791 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
5792 scm_permanent_object (f_apply
);
5794 #include "libguile/eval.x"
5796 scm_add_feature ("delay");