1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004
2 * Free Software Foundation, Inc.
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public
6 * License as published by the Free Software Foundation; either
7 * version 2.1 of the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
21 /* This file is read twice in order to produce debugging versions of ceval and
22 * scm_apply. These functions, deval and scm_dapply, are produced when we
23 * define the preprocessor macro DEVAL. The file is divided into sections
24 * which are treated differently with respect to DEVAL. The heads of these
25 * sections are marked with the string "SECTION:". */
27 /* SECTION: This code is compiled once.
34 #include "libguile/__scm.h"
38 /* AIX requires this to be the first thing in the file. The #pragma
39 directive is indented so pre-ANSI compilers will ignore it, rather
48 # ifndef alloca /* predefined by HP cc +Olibcalls */
56 #include "libguile/_scm.h"
57 #include "libguile/alist.h"
58 #include "libguile/async.h"
59 #include "libguile/continuations.h"
60 #include "libguile/debug.h"
61 #include "libguile/deprecation.h"
62 #include "libguile/dynwind.h"
63 #include "libguile/eq.h"
64 #include "libguile/feature.h"
65 #include "libguile/fluids.h"
66 #include "libguile/futures.h"
67 #include "libguile/goops.h"
68 #include "libguile/hash.h"
69 #include "libguile/hashtab.h"
70 #include "libguile/lang.h"
71 #include "libguile/list.h"
72 #include "libguile/macros.h"
73 #include "libguile/modules.h"
74 #include "libguile/objects.h"
75 #include "libguile/ports.h"
76 #include "libguile/print.h"
77 #include "libguile/procprop.h"
78 #include "libguile/root.h"
79 #include "libguile/smob.h"
80 #include "libguile/srcprop.h"
81 #include "libguile/stackchk.h"
82 #include "libguile/strings.h"
83 #include "libguile/throw.h"
84 #include "libguile/validate.h"
85 #include "libguile/values.h"
86 #include "libguile/vectors.h"
88 #include "libguile/eval.h"
92 static SCM
unmemoize_exprs (SCM expr
, SCM env
);
93 static SCM
canonicalize_define (SCM expr
);
94 static SCM
*scm_lookupcar1 (SCM vloc
, SCM genv
, int check
);
95 static SCM
unmemoize_builtin_macro (SCM expr
, 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 /* Case or cond expressions must have at least one clause. If a case or cond
152 * expression without any clauses is detected, a 'Missing clauses' error is
154 static const char s_missing_clauses
[] = "Missing clauses";
156 /* If there is an 'else' clause in a case or a cond statement, it must be the
157 * last clause. If after the 'else' case clause further clauses are detected,
158 * a 'Misplaced else clause' error is signalled. */
159 static const char s_misplaced_else_clause
[] = "Misplaced else clause";
161 /* If a case clause is detected that is not in the format
162 * (<label(s)> <expression1> <expression2> ...)
163 * a 'Bad case clause' error is signalled. */
164 static const char s_bad_case_clause
[] = "Bad case clause";
166 /* If a case clause is detected where the <label(s)> element is neither a
167 * proper list nor (in case of the last clause) the syntactic keyword 'else',
168 * a 'Bad case labels' error is signalled. Note: If you encounter this error
169 * for an else-clause which seems to be syntactically correct, check if 'else'
170 * is really a syntactic keyword in that context. If 'else' is bound in the
171 * local or global environment, it is not considered a syntactic keyword, but
172 * will be treated as any other variable. */
173 static const char s_bad_case_labels
[] = "Bad case labels";
175 /* In a case statement all labels have to be distinct. If in a case statement
176 * a label occurs more than once, a 'Duplicate case label' error is
178 static const char s_duplicate_case_label
[] = "Duplicate case label";
180 /* If a cond clause is detected that is not in one of the formats
181 * (<test> <expression1> ...) or (else <expression1> <expression2> ...)
182 * a 'Bad cond clause' error is signalled. */
183 static const char s_bad_cond_clause
[] = "Bad cond clause";
185 /* If a cond clause is detected that uses the alternate '=>' form, but does
186 * not hold a recipient element for the test result, a 'Missing recipient'
187 * error is signalled. */
188 static const char s_missing_recipient
[] = "Missing recipient in";
190 /* If in a position where a variable name is required some other object is
191 * detected, a 'Bad variable' error is signalled. */
192 static const char s_bad_variable
[] = "Bad variable";
194 /* Bindings for forms like 'let' and 'do' have to be given in a proper,
195 * possibly empty list. If any other object is detected in a place where a
196 * list of bindings was required, a 'Bad bindings' error is signalled. */
197 static const char s_bad_bindings
[] = "Bad bindings";
199 /* Depending on the syntactic context, a binding has to be in the format
200 * (<variable> <expression>) or (<variable> <expression1> <expression2>).
201 * If anything else is detected in a place where a binding was expected, a
202 * 'Bad binding' error is signalled. */
203 static const char s_bad_binding
[] = "Bad binding";
205 /* Some syntactic forms don't allow variable names to appear more than once in
206 * a list of bindings. If such a situation is nevertheless detected, a
207 * 'Duplicate binding' error is signalled. */
208 static const char s_duplicate_binding
[] = "Duplicate binding";
210 /* If the exit form of a 'do' expression is not in the format
211 * (<test> <expression> ...)
212 * a 'Bad exit clause' error is signalled. */
213 static const char s_bad_exit_clause
[] = "Bad exit clause";
215 /* The formal function arguments of a lambda expression have to be either a
216 * single symbol or a non-cyclic list. For anything else a 'Bad formals'
217 * error is signalled. */
218 static const char s_bad_formals
[] = "Bad formals";
220 /* If in a lambda expression something else than a symbol is detected at a
221 * place where a formal function argument is required, a 'Bad formal' error is
223 static const char s_bad_formal
[] = "Bad formal";
225 /* If in the arguments list of a lambda expression an argument name occurs
226 * more than once, a 'Duplicate formal' error is signalled. */
227 static const char s_duplicate_formal
[] = "Duplicate formal";
229 /* If the evaluation of an unquote-splicing expression gives something else
230 * than a proper list, a 'Non-list result for unquote-splicing' error is
232 static const char s_splicing
[] = "Non-list result for unquote-splicing";
234 /* If something else than an exact integer is detected as the argument for
235 * @slot-ref and @slot-set!, a 'Bad slot number' error is signalled. */
236 static const char s_bad_slot_number
[] = "Bad slot number";
239 /* Signal a syntax error. We distinguish between the form that caused the
240 * error and the enclosing expression. The error message will print out as
241 * shown in the following pattern. The file name and line number are only
242 * given when they can be determined from the erroneous form or from the
243 * enclosing expression.
245 * <filename>: In procedure memoization:
246 * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
248 SCM_SYMBOL (syntax_error_key
, "syntax-error");
250 /* The prototype is needed to indicate that the function does not return. */
252 syntax_error (const char* const, const SCM
, const SCM
) SCM_NORETURN
;
255 syntax_error (const char* const msg
, const SCM form
, const SCM expr
)
257 SCM msg_string
= scm_from_locale_string (msg
);
258 SCM filename
= SCM_BOOL_F
;
259 SCM linenr
= SCM_BOOL_F
;
263 if (SCM_CONSP (form
))
265 filename
= scm_source_property (form
, scm_sym_filename
);
266 linenr
= scm_source_property (form
, scm_sym_line
);
269 if (scm_is_false (filename
) && scm_is_false (linenr
) && SCM_CONSP (expr
))
271 filename
= scm_source_property (expr
, scm_sym_filename
);
272 linenr
= scm_source_property (expr
, scm_sym_line
);
275 if (!SCM_UNBNDP (expr
))
277 if (scm_is_true (filename
))
279 format
= "In file ~S, line ~S: ~A ~S in expression ~S.";
280 args
= scm_list_5 (filename
, linenr
, msg_string
, form
, expr
);
282 else if (scm_is_true (linenr
))
284 format
= "In line ~S: ~A ~S in expression ~S.";
285 args
= scm_list_4 (linenr
, msg_string
, form
, expr
);
289 format
= "~A ~S in expression ~S.";
290 args
= scm_list_3 (msg_string
, form
, expr
);
295 if (scm_is_true (filename
))
297 format
= "In file ~S, line ~S: ~A ~S.";
298 args
= scm_list_4 (filename
, linenr
, msg_string
, form
);
300 else if (scm_is_true (linenr
))
302 format
= "In line ~S: ~A ~S.";
303 args
= scm_list_3 (linenr
, msg_string
, form
);
308 args
= scm_list_2 (msg_string
, form
);
312 scm_error (syntax_error_key
, "memoization", format
, args
, SCM_BOOL_F
);
316 /* Shortcut macros to simplify syntax error handling. */
317 #define ASSERT_SYNTAX(cond, message, form) \
318 { if (!(cond)) syntax_error (message, form, SCM_UNDEFINED); }
319 #define ASSERT_SYNTAX_2(cond, message, form, expr) \
320 { if (!(cond)) syntax_error (message, form, expr); }
326 * Ilocs are memoized references to variables in local environment frames.
327 * They are represented as three values: The relative offset of the
328 * environment frame, the number of the binding within that frame, and a
329 * boolean value indicating whether the binding is the last binding in the
332 * Frame numbers have 11 bits, relative offsets have 12 bits.
335 #define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc)
336 #define SCM_IFRINC (0x00000100L)
337 #define SCM_ICDR (0x00080000L)
338 #define SCM_IDINC (0x00100000L)
339 #define SCM_IFRAME(n) ((long)((SCM_ICDR-SCM_IFRINC)>>8) \
340 & (SCM_UNPACK (n) >> 8))
341 #define SCM_IDIST(n) (SCM_UNPACK (n) >> 20)
342 #define SCM_ICDRP(n) (SCM_ICDR & SCM_UNPACK (n))
343 #define SCM_IDSTMSK (-SCM_IDINC)
344 #define SCM_IFRAMEMAX ((1<<11)-1)
345 #define SCM_IDISTMAX ((1<<12)-1)
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
);
366 SCM_DEFINE (scm_dbg_make_iloc
, "dbg-make-iloc", 3, 0, 0,
367 (SCM frame
, SCM binding
, SCM cdrp
),
368 "Return a new iloc with frame offset @var{frame}, binding\n"
369 "offset @var{binding} and the cdr flag @var{cdrp}.")
370 #define FUNC_NAME s_scm_dbg_make_iloc
372 return SCM_MAKE_ILOC (scm_to_unsigned_integer (frame
, 0, SCM_IFRAME_MAX
),
373 scm_to_unsigned_integer (binding
, 0, SCM_IDIST_MAX
),
378 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_from_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 global variable, the variable object to which
444 * the symbol is bound is returned. Finally, if the symbol is a local
445 * variable the corresponding iloc object is returned. */
447 /* A helper function for lookup_symbol: Try to find the symbol in the top
448 * level environment frame. The function returns SCM_UNDEFINED if the symbol
449 * is unbound and it returns a variable object if the symbol is a global
452 lookup_global_symbol (const SCM symbol
, const SCM top_level
)
454 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
455 if (scm_is_false (variable
))
456 return SCM_UNDEFINED
;
462 lookup_symbol (const SCM symbol
, const SCM env
)
465 unsigned int frame_nr
;
467 for (frame_idx
= env
, frame_nr
= 0;
468 !SCM_NULLP (frame_idx
);
469 frame_idx
= SCM_CDR (frame_idx
), ++frame_nr
)
471 const SCM frame
= SCM_CAR (frame_idx
);
472 if (SCM_CONSP (frame
))
474 /* frame holds a local environment frame */
476 unsigned int symbol_nr
;
478 for (symbol_idx
= SCM_CAR (frame
), symbol_nr
= 0;
479 SCM_CONSP (symbol_idx
);
480 symbol_idx
= SCM_CDR (symbol_idx
), ++symbol_nr
)
482 if (scm_is_eq (SCM_CAR (symbol_idx
), symbol
))
483 /* found the symbol, therefore return the iloc */
484 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 0);
486 if (scm_is_eq (symbol_idx
, symbol
))
487 /* found the symbol as the last element of the current frame */
488 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 1);
492 /* no more local environment frames */
493 return lookup_global_symbol (symbol
, frame
);
497 return lookup_global_symbol (symbol
, SCM_BOOL_F
);
501 /* Return true if the symbol is - from the point of view of a macro
502 * transformer - a literal in the sense specified in chapter "pattern
503 * language" of R5RS. In the code below, however, we don't match the
504 * definition of R5RS exactly: It returns true if the identifier has no
505 * binding or if it is a syntactic keyword. */
507 literal_p (const SCM symbol
, const SCM env
)
509 const SCM variable
= lookup_symbol (symbol
, env
);
510 if (SCM_UNBNDP (variable
))
512 if (SCM_VARIABLEP (variable
) && SCM_MACROP (SCM_VARIABLE_REF (variable
)))
519 /* Return true if the expression is self-quoting in the memoized code. Thus,
520 * some other objects (like e. g. vectors) are reported as self-quoting, which
521 * according to R5RS would need to be quoted. */
523 is_self_quoting_p (const SCM expr
)
525 if (SCM_CONSP (expr
))
527 else if (scm_is_symbol (expr
))
529 else if (SCM_NULLP (expr
))
535 SCM_SYMBOL (sym_three_question_marks
, "???");
538 unmemoize_expression (const SCM expr
, const SCM env
)
540 if (SCM_ILOCP (expr
))
543 unsigned long int frame_nr
;
545 unsigned long int symbol_nr
;
547 for (frame_idx
= env
, frame_nr
= SCM_IFRAME (expr
);
549 frame_idx
= SCM_CDR (frame_idx
), --frame_nr
)
551 for (symbol_idx
= SCM_CAAR (frame_idx
), symbol_nr
= SCM_IDIST (expr
);
553 symbol_idx
= SCM_CDR (symbol_idx
), --symbol_nr
)
555 return SCM_ICDRP (expr
) ? symbol_idx
: SCM_CAR (symbol_idx
);
557 else if (SCM_VARIABLEP (expr
))
559 const SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), expr
);
560 return scm_is_true (sym
) ? sym
: sym_three_question_marks
;
562 else if (SCM_VECTORP (expr
))
564 return scm_list_2 (scm_sym_quote
, expr
);
566 else if (!SCM_CONSP (expr
))
570 else if (SCM_ISYMP (SCM_CAR (expr
)))
572 return unmemoize_builtin_macro (expr
, env
);
576 return unmemoize_exprs (expr
, env
);
582 unmemoize_exprs (const SCM exprs
, const SCM env
)
584 SCM r_result
= SCM_EOL
;
585 SCM expr_idx
= exprs
;
588 /* Note that due to the current lazy memoizer we may find partially memoized
589 * code during execution. In such code we have to expect improper lists of
590 * expressions: On the one hand, for such code syntax checks have not yet
591 * fully been performed, on the other hand, there may be even legal code
592 * like '(a . b) appear as an improper list of expressions as long as the
593 * quote expression is still in its unmemoized form. For this reason, the
594 * following code handles improper lists of expressions until memoization
595 * and execution have been completely separated. */
596 for (; SCM_CONSP (expr_idx
); expr_idx
= SCM_CDR (expr_idx
))
598 const SCM expr
= SCM_CAR (expr_idx
);
600 /* In partially memoized code, lists of expressions that stem from a
601 * body form may start with an ISYM if the body itself has not yet been
602 * memoized. This isym is just an internal marker to indicate that the
603 * body still needs to be memoized. An isym may occur at the very
604 * beginning of the body or after one or more comment strings. It is
605 * dropped during unmemoization. */
606 if (!SCM_ISYMP (expr
))
608 um_expr
= unmemoize_expression (expr
, env
);
609 r_result
= scm_cons (um_expr
, r_result
);
612 um_expr
= unmemoize_expression (expr_idx
, env
);
613 if (!SCM_NULLP (r_result
))
615 const SCM result
= scm_reverse_x (r_result
, SCM_UNDEFINED
);
616 SCM_SETCDR (r_result
, um_expr
);
626 /* Rewrite the body (which is given as the list of expressions forming the
627 * body) into its internal form. The internal form of a body (<expr> ...) is
628 * just the body itself, but prefixed with an ISYM that denotes to what kind
629 * of outer construct this body belongs: (<ISYM> <expr> ...). A lambda body
630 * starts with SCM_IM_LAMBDA, for example, a body of a let starts with
633 * It is assumed that the calling expression has already made sure that the
634 * body is a proper list. */
636 m_body (SCM op
, SCM exprs
)
638 /* Don't add another ISYM if one is present already. */
639 if (SCM_ISYMP (SCM_CAR (exprs
)))
642 return scm_cons (op
, exprs
);
646 /* The function m_expand_body memoizes a proper list of expressions forming a
647 * body. This function takes care of dealing with internal defines and
648 * transforming them into an equivalent letrec expression. The list of
649 * expressions is rewritten in place. */
651 /* This is a helper function for m_expand_body. If the argument expression is
652 * a symbol that denotes a syntactic keyword, the corresponding macro object
653 * is returned, in all other cases the function returns SCM_UNDEFINED. */
655 try_macro_lookup (const SCM expr
, const SCM env
)
657 if (scm_is_symbol (expr
))
659 const SCM variable
= lookup_symbol (expr
, env
);
660 if (SCM_VARIABLEP (variable
))
662 const SCM value
= SCM_VARIABLE_REF (variable
);
663 if (SCM_MACROP (value
))
668 return SCM_UNDEFINED
;
671 /* This is a helper function for m_expand_body. It expands user macros,
672 * because for the correct translation of a body we need to know whether they
673 * expand to a definition. */
675 expand_user_macros (SCM expr
, const SCM env
)
677 while (SCM_CONSP (expr
))
679 const SCM car_expr
= SCM_CAR (expr
);
680 const SCM new_car
= expand_user_macros (car_expr
, env
);
681 const SCM value
= try_macro_lookup (new_car
, env
);
683 if (SCM_MACROP (value
) && SCM_MACRO_TYPE (value
) == 2)
685 /* User macros transform code into code. */
686 expr
= scm_call_2 (SCM_MACRO_CODE (value
), expr
, env
);
687 /* We need to reiterate on the transformed code. */
691 /* No user macro: return. */
692 SCM_SETCAR (expr
, new_car
);
700 /* This is a helper function for m_expand_body. It determines if a given form
701 * represents an application of a given built-in macro. The built-in macro to
702 * check for is identified by its syntactic keyword. The form is an
703 * application of the given macro if looking up the car of the form in the
704 * given environment actually returns the built-in macro. */
706 is_system_macro_p (const SCM syntactic_keyword
, const SCM form
, const SCM env
)
708 if (SCM_CONSP (form
))
710 const SCM car_form
= SCM_CAR (form
);
711 const SCM value
= try_macro_lookup (car_form
, env
);
712 if (SCM_BUILTIN_MACRO_P (value
))
714 const SCM macro_name
= scm_macro_name (value
);
715 return scm_is_eq (macro_name
, syntactic_keyword
);
723 m_expand_body (const SCM forms
, const SCM env
)
725 /* The first body form can be skipped since it is known to be the ISYM that
726 * was prepended to the body by m_body. */
727 SCM cdr_forms
= SCM_CDR (forms
);
728 SCM form_idx
= cdr_forms
;
729 SCM definitions
= SCM_EOL
;
730 SCM sequence
= SCM_EOL
;
732 /* According to R5RS, the list of body forms consists of two parts: a number
733 * (maybe zero) of definitions, followed by a non-empty sequence of
734 * expressions. Each the definitions and the expressions may be grouped
735 * arbitrarily with begin, but it is not allowed to mix definitions and
736 * expressions. The task of the following loop therefore is to split the
737 * list of body forms into the list of definitions and the sequence of
739 while (!SCM_NULLP (form_idx
))
741 const SCM form
= SCM_CAR (form_idx
);
742 const SCM new_form
= expand_user_macros (form
, env
);
743 if (is_system_macro_p (scm_sym_define
, new_form
, env
))
745 definitions
= scm_cons (new_form
, definitions
);
746 form_idx
= SCM_CDR (form_idx
);
748 else if (is_system_macro_p (scm_sym_begin
, new_form
, env
))
750 /* We have encountered a group of forms. This has to be either a
751 * (possibly empty) group of (possibly further grouped) definitions,
752 * or a non-empty group of (possibly further grouped)
754 const SCM grouped_forms
= SCM_CDR (new_form
);
755 unsigned int found_definition
= 0;
756 unsigned int found_expression
= 0;
757 SCM grouped_form_idx
= grouped_forms
;
758 while (!found_expression
&& !SCM_NULLP (grouped_form_idx
))
760 const SCM inner_form
= SCM_CAR (grouped_form_idx
);
761 const SCM new_inner_form
= expand_user_macros (inner_form
, env
);
762 if (is_system_macro_p (scm_sym_define
, new_inner_form
, env
))
764 found_definition
= 1;
765 definitions
= scm_cons (new_inner_form
, definitions
);
766 grouped_form_idx
= SCM_CDR (grouped_form_idx
);
768 else if (is_system_macro_p (scm_sym_begin
, new_inner_form
, env
))
770 const SCM inner_group
= SCM_CDR (new_inner_form
);
772 = scm_append (scm_list_2 (inner_group
,
773 SCM_CDR (grouped_form_idx
)));
777 /* The group marks the start of the expressions of the body.
778 * We have to make sure that within the same group we have
779 * not encountered a definition before. */
780 ASSERT_SYNTAX (!found_definition
, s_mixed_body_forms
, form
);
781 found_expression
= 1;
782 grouped_form_idx
= SCM_EOL
;
786 /* We have finished processing the group. If we have not yet
787 * encountered an expression we continue processing the forms of the
788 * body to collect further definition forms. Otherwise, the group
789 * marks the start of the sequence of expressions of the body. */
790 if (!found_expression
)
792 form_idx
= SCM_CDR (form_idx
);
802 /* We have detected a form which is no definition. This marks the
803 * start of the sequence of expressions of the body. */
809 /* FIXME: forms does not hold information about the file location. */
810 ASSERT_SYNTAX (SCM_CONSP (sequence
), s_missing_body_expression
, cdr_forms
);
812 if (!SCM_NULLP (definitions
))
816 SCM letrec_expression
;
817 SCM new_letrec_expression
;
819 SCM bindings
= SCM_EOL
;
820 for (definition_idx
= definitions
;
821 !SCM_NULLP (definition_idx
);
822 definition_idx
= SCM_CDR (definition_idx
))
824 const SCM definition
= SCM_CAR (definition_idx
);
825 const SCM canonical_definition
= canonicalize_define (definition
);
826 const SCM binding
= SCM_CDR (canonical_definition
);
827 bindings
= scm_cons (binding
, bindings
);
830 letrec_tail
= scm_cons (bindings
, sequence
);
831 /* FIXME: forms does not hold information about the file location. */
832 letrec_expression
= scm_cons_source (forms
, scm_sym_letrec
, letrec_tail
);
833 new_letrec_expression
= scm_m_letrec (letrec_expression
, env
);
834 SCM_SETCAR (forms
, new_letrec_expression
);
835 SCM_SETCDR (forms
, SCM_EOL
);
839 SCM_SETCAR (forms
, SCM_CAR (sequence
));
840 SCM_SETCDR (forms
, SCM_CDR (sequence
));
845 macroexp (SCM x
, SCM env
)
847 SCM res
, proc
, orig_sym
;
849 /* Don't bother to produce error messages here. We get them when we
850 eventually execute the code for real. */
853 orig_sym
= SCM_CAR (x
);
854 if (!scm_is_symbol (orig_sym
))
858 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
859 if (proc_ptr
== NULL
)
861 /* We have lost the race. */
867 /* Only handle memoizing macros. `Acros' and `macros' are really
868 special forms and should not be evaluated here. */
870 if (!SCM_MACROP (proc
)
871 || (SCM_MACRO_TYPE (proc
) != 2 && !SCM_BUILTIN_MACRO_P (proc
)))
874 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
875 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
877 if (scm_ilength (res
) <= 0)
878 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
881 SCM_SETCAR (x
, SCM_CAR (res
));
882 SCM_SETCDR (x
, SCM_CDR (res
));
888 /* Start of the memoizers for the standard R5RS builtin macros. */
891 SCM_SYNTAX (s_and
, "and", scm_i_makbimacro
, scm_m_and
);
892 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
895 scm_m_and (SCM expr
, SCM env SCM_UNUSED
)
897 const SCM cdr_expr
= SCM_CDR (expr
);
898 const long length
= scm_ilength (cdr_expr
);
900 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
904 /* Special case: (and) is replaced by #t. */
909 SCM_SETCAR (expr
, SCM_IM_AND
);
915 unmemoize_and (const SCM expr
, const SCM env
)
917 return scm_cons (scm_sym_and
, unmemoize_exprs (SCM_CDR (expr
), env
));
921 SCM_SYNTAX (s_begin
, "begin", scm_i_makbimacro
, scm_m_begin
);
922 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
925 scm_m_begin (SCM expr
, SCM env SCM_UNUSED
)
927 const SCM cdr_expr
= SCM_CDR (expr
);
928 /* Dirk:FIXME:: An empty begin clause is not generally allowed by R5RS.
929 * That means, there should be a distinction between uses of begin where an
930 * empty clause is OK and where it is not. */
931 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
933 SCM_SETCAR (expr
, SCM_IM_BEGIN
);
938 unmemoize_begin (const SCM expr
, const SCM env
)
940 return scm_cons (scm_sym_begin
, unmemoize_exprs (SCM_CDR (expr
), env
));
944 SCM_SYNTAX (s_case
, "case", scm_i_makbimacro
, scm_m_case
);
945 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
946 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
949 scm_m_case (SCM expr
, SCM env
)
952 SCM all_labels
= SCM_EOL
;
954 /* Check, whether 'else is a literal, i. e. not bound to a value. */
955 const int else_literal_p
= literal_p (scm_sym_else
, env
);
957 const SCM cdr_expr
= SCM_CDR (expr
);
958 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
959 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_clauses
, expr
);
961 clauses
= SCM_CDR (cdr_expr
);
962 while (!SCM_NULLP (clauses
))
966 const SCM clause
= SCM_CAR (clauses
);
967 ASSERT_SYNTAX_2 (scm_ilength (clause
) >= 2,
968 s_bad_case_clause
, clause
, expr
);
970 labels
= SCM_CAR (clause
);
971 if (SCM_CONSP (labels
))
973 ASSERT_SYNTAX_2 (scm_ilength (labels
) >= 0,
974 s_bad_case_labels
, labels
, expr
);
975 all_labels
= scm_append (scm_list_2 (labels
, all_labels
));
977 else if (SCM_NULLP (labels
))
979 /* The list of labels is empty. According to R5RS this is allowed.
980 * It means that the sequence of expressions will never be executed.
981 * Therefore, as an optimization, we could remove the whole
986 ASSERT_SYNTAX_2 (scm_is_eq (labels
, scm_sym_else
) && else_literal_p
,
987 s_bad_case_labels
, labels
, expr
);
988 ASSERT_SYNTAX_2 (SCM_NULLP (SCM_CDR (clauses
)),
989 s_misplaced_else_clause
, clause
, expr
);
992 /* build the new clause */
993 if (scm_is_eq (labels
, scm_sym_else
))
994 SCM_SETCAR (clause
, SCM_IM_ELSE
);
996 clauses
= SCM_CDR (clauses
);
999 /* Check whether all case labels are distinct. */
1000 for (; !SCM_NULLP (all_labels
); all_labels
= SCM_CDR (all_labels
))
1002 const SCM label
= SCM_CAR (all_labels
);
1003 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (label
, SCM_CDR (all_labels
))),
1004 s_duplicate_case_label
, label
, expr
);
1007 SCM_SETCAR (expr
, SCM_IM_CASE
);
1012 unmemoize_case (const SCM expr
, const SCM env
)
1014 const SCM um_key_expr
= unmemoize_expression (SCM_CADR (expr
), env
);
1015 SCM um_clauses
= SCM_EOL
;
1018 for (clause_idx
= SCM_CDDR (expr
);
1019 !SCM_NULLP (clause_idx
);
1020 clause_idx
= SCM_CDR (clause_idx
))
1022 const SCM clause
= SCM_CAR (clause_idx
);
1023 const SCM labels
= SCM_CAR (clause
);
1024 const SCM exprs
= SCM_CDR (clause
);
1026 const SCM um_exprs
= unmemoize_exprs (exprs
, env
);
1027 const SCM um_labels
= (scm_is_eq (labels
, SCM_IM_ELSE
))
1029 : scm_i_finite_list_copy (labels
);
1030 const SCM um_clause
= scm_cons (um_labels
, um_exprs
);
1032 um_clauses
= scm_cons (um_clause
, um_clauses
);
1034 um_clauses
= scm_reverse_x (um_clauses
, SCM_UNDEFINED
);
1036 return scm_cons2 (scm_sym_case
, um_key_expr
, um_clauses
);
1040 SCM_SYNTAX (s_cond
, "cond", scm_i_makbimacro
, scm_m_cond
);
1041 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
1042 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
1045 scm_m_cond (SCM expr
, SCM env
)
1047 /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
1048 const int else_literal_p
= literal_p (scm_sym_else
, env
);
1049 const int arrow_literal_p
= literal_p (scm_sym_arrow
, env
);
1051 const SCM clauses
= SCM_CDR (expr
);
1054 ASSERT_SYNTAX (scm_ilength (clauses
) >= 0, s_bad_expression
, expr
);
1055 ASSERT_SYNTAX (scm_ilength (clauses
) >= 1, s_missing_clauses
, expr
);
1057 for (clause_idx
= clauses
;
1058 !SCM_NULLP (clause_idx
);
1059 clause_idx
= SCM_CDR (clause_idx
))
1063 const SCM clause
= SCM_CAR (clause_idx
);
1064 const long length
= scm_ilength (clause
);
1065 ASSERT_SYNTAX_2 (length
>= 1, s_bad_cond_clause
, clause
, expr
);
1067 test
= SCM_CAR (clause
);
1068 if (scm_is_eq (test
, scm_sym_else
) && else_literal_p
)
1070 const int last_clause_p
= SCM_NULLP (SCM_CDR (clause_idx
));
1071 ASSERT_SYNTAX_2 (length
>= 2,
1072 s_bad_cond_clause
, clause
, expr
);
1073 ASSERT_SYNTAX_2 (last_clause_p
,
1074 s_misplaced_else_clause
, clause
, expr
);
1075 SCM_SETCAR (clause
, SCM_IM_ELSE
);
1077 else if (length
>= 2
1078 && scm_is_eq (SCM_CADR (clause
), scm_sym_arrow
)
1081 ASSERT_SYNTAX_2 (length
> 2, s_missing_recipient
, clause
, expr
);
1082 ASSERT_SYNTAX_2 (length
== 3, s_extra_expression
, clause
, expr
);
1083 SCM_SETCAR (SCM_CDR (clause
), SCM_IM_ARROW
);
1087 SCM_SETCAR (expr
, SCM_IM_COND
);
1092 unmemoize_cond (const SCM expr
, const SCM env
)
1094 SCM um_clauses
= SCM_EOL
;
1097 for (clause_idx
= SCM_CDR (expr
);
1098 !SCM_NULLP (clause_idx
);
1099 clause_idx
= SCM_CDR (clause_idx
))
1101 const SCM clause
= SCM_CAR (clause_idx
);
1102 const SCM sequence
= SCM_CDR (clause
);
1103 const SCM test
= SCM_CAR (clause
);
1108 if (scm_is_eq (test
, SCM_IM_ELSE
))
1109 um_test
= scm_sym_else
;
1111 um_test
= unmemoize_expression (test
, env
);
1113 if (!SCM_NULLP (sequence
) && scm_is_eq (SCM_CAR (sequence
),
1116 const SCM target
= SCM_CADR (sequence
);
1117 const SCM um_target
= unmemoize_expression (target
, env
);
1118 um_sequence
= scm_list_2 (scm_sym_arrow
, um_target
);
1122 um_sequence
= unmemoize_exprs (sequence
, env
);
1125 um_clause
= scm_cons (um_test
, um_sequence
);
1126 um_clauses
= scm_cons (um_clause
, um_clauses
);
1128 um_clauses
= scm_reverse_x (um_clauses
, SCM_UNDEFINED
);
1130 return scm_cons (scm_sym_cond
, um_clauses
);
1134 SCM_SYNTAX (s_define
, "define", scm_i_makbimacro
, scm_m_define
);
1135 SCM_GLOBAL_SYMBOL (scm_sym_define
, s_define
);
1137 /* Guile provides an extension to R5RS' define syntax to represent function
1138 * currying in a compact way. With this extension, it is allowed to write
1139 * (define <nested-variable> <body>), where <nested-variable> has of one of
1140 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
1141 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
1142 * should be either a sequence of zero or more variables, or a sequence of one
1143 * or more variables followed by a space-delimited period and another
1144 * variable. Each level of argument nesting wraps the <body> within another
1145 * lambda expression. For example, the following forms are allowed, each one
1146 * followed by an equivalent, more explicit implementation.
1148 * (define ((a b . c) . d) <body>) is equivalent to
1149 * (define a (lambda (b . c) (lambda d <body>)))
1151 * (define (((a) b) c . d) <body>) is equivalent to
1152 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
1154 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
1155 * module that does not implement this extension. */
1157 canonicalize_define (const SCM expr
)
1162 const SCM cdr_expr
= SCM_CDR (expr
);
1163 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1164 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1166 body
= SCM_CDR (cdr_expr
);
1167 variable
= SCM_CAR (cdr_expr
);
1168 while (SCM_CONSP (variable
))
1170 /* This while loop realizes function currying by variable nesting.
1171 * Variable is known to be a nested-variable. In every iteration of the
1172 * loop another level of lambda expression is created, starting with the
1173 * innermost one. Note that we don't check for duplicate formals here:
1174 * This will be done by the memoizer of the lambda expression. */
1175 const SCM formals
= SCM_CDR (variable
);
1176 const SCM tail
= scm_cons (formals
, body
);
1178 /* Add source properties to each new lambda expression: */
1179 const SCM lambda
= scm_cons_source (variable
, scm_sym_lambda
, tail
);
1181 body
= scm_list_1 (lambda
);
1182 variable
= SCM_CAR (variable
);
1184 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
1185 ASSERT_SYNTAX (scm_ilength (body
) == 1, s_expression
, expr
);
1187 SCM_SETCAR (cdr_expr
, variable
);
1188 SCM_SETCDR (cdr_expr
, body
);
1192 /* According to section 5.2.1 of R5RS we first have to make sure that the
1193 * variable is bound, and then perform the (set! variable expression)
1194 * operation. This means, that within the expression we may already assign
1195 * values to variable: (define foo (begin (set! foo 1) (+ foo 1))) */
1197 scm_m_define (SCM expr
, SCM env
)
1199 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), s_bad_define
, expr
);
1202 const SCM canonical_definition
= canonicalize_define (expr
);
1203 const SCM cdr_canonical_definition
= SCM_CDR (canonical_definition
);
1204 const SCM variable
= SCM_CAR (cdr_canonical_definition
);
1206 = scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_T
);
1207 const SCM value
= scm_eval_car (SCM_CDR (cdr_canonical_definition
), env
);
1209 if (SCM_REC_PROCNAMES_P
)
1212 while (SCM_MACROP (tmp
))
1213 tmp
= SCM_MACRO_CODE (tmp
);
1214 if (SCM_CLOSUREP (tmp
)
1215 /* Only the first definition determines the name. */
1216 && scm_is_false (scm_procedure_property (tmp
, scm_sym_name
)))
1217 scm_set_procedure_property_x (tmp
, scm_sym_name
, variable
);
1220 SCM_VARIABLE_SET (location
, value
);
1222 return SCM_UNSPECIFIED
;
1227 /* This is a helper function for forms (<keyword> <expression>) that are
1228 * transformed into (#@<keyword> '() <memoized_expression>) in order to allow
1229 * for easy creation of a thunk (i. e. a closure without arguments) using the
1230 * ('() <memoized_expression>) tail of the memoized form. */
1232 memoize_as_thunk_prototype (const SCM expr
, const SCM env SCM_UNUSED
)
1234 const SCM cdr_expr
= SCM_CDR (expr
);
1235 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1236 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1238 SCM_SETCDR (expr
, scm_cons (SCM_EOL
, cdr_expr
));
1244 SCM_SYNTAX (s_delay
, "delay", scm_i_makbimacro
, scm_m_delay
);
1245 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
1247 /* Promises are implemented as closures with an empty parameter list. Thus,
1248 * (delay <expression>) is transformed into (#@delay '() <expression>), where
1249 * the empty list represents the empty parameter list. This representation
1250 * allows for easy creation of the closure during evaluation. */
1252 scm_m_delay (SCM expr
, SCM env
)
1254 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1255 SCM_SETCAR (new_expr
, SCM_IM_DELAY
);
1260 unmemoize_delay (const SCM expr
, const SCM env
)
1262 const SCM thunk_expr
= SCM_CADDR (expr
);
1263 return scm_list_2 (scm_sym_delay
, unmemoize_expression (thunk_expr
, env
));
1267 SCM_SYNTAX(s_do
, "do", scm_i_makbimacro
, scm_m_do
);
1268 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
1270 /* DO gets the most radically altered syntax. The order of the vars is
1271 * reversed here. During the evaluation this allows for simple consing of the
1272 * results of the inits and steps:
1274 (do ((<var1> <init1> <step1>)
1282 (#@do (<init1> <init2> ... <initn>)
1283 (varn ... var2 var1)
1286 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
1289 scm_m_do (SCM expr
, SCM env SCM_UNUSED
)
1291 SCM variables
= SCM_EOL
;
1292 SCM init_forms
= SCM_EOL
;
1293 SCM step_forms
= SCM_EOL
;
1300 const SCM cdr_expr
= SCM_CDR (expr
);
1301 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1302 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1304 /* Collect variables, init and step forms. */
1305 binding_idx
= SCM_CAR (cdr_expr
);
1306 ASSERT_SYNTAX_2 (scm_ilength (binding_idx
) >= 0,
1307 s_bad_bindings
, binding_idx
, expr
);
1308 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1310 const SCM binding
= SCM_CAR (binding_idx
);
1311 const long length
= scm_ilength (binding
);
1312 ASSERT_SYNTAX_2 (length
== 2 || length
== 3,
1313 s_bad_binding
, binding
, expr
);
1316 const SCM name
= SCM_CAR (binding
);
1317 const SCM init
= SCM_CADR (binding
);
1318 const SCM step
= (length
== 2) ? name
: SCM_CADDR (binding
);
1319 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
1320 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, variables
)),
1321 s_duplicate_binding
, name
, expr
);
1323 variables
= scm_cons (name
, variables
);
1324 init_forms
= scm_cons (init
, init_forms
);
1325 step_forms
= scm_cons (step
, step_forms
);
1328 init_forms
= scm_reverse_x (init_forms
, SCM_UNDEFINED
);
1329 step_forms
= scm_reverse_x (step_forms
, SCM_UNDEFINED
);
1331 /* Memoize the test form and the exit sequence. */
1332 cddr_expr
= SCM_CDR (cdr_expr
);
1333 exit_clause
= SCM_CAR (cddr_expr
);
1334 ASSERT_SYNTAX_2 (scm_ilength (exit_clause
) >= 1,
1335 s_bad_exit_clause
, exit_clause
, expr
);
1337 commands
= SCM_CDR (cddr_expr
);
1338 tail
= scm_cons2 (exit_clause
, commands
, step_forms
);
1339 tail
= scm_cons2 (init_forms
, variables
, tail
);
1340 SCM_SETCAR (expr
, SCM_IM_DO
);
1341 SCM_SETCDR (expr
, tail
);
1346 unmemoize_do (const SCM expr
, const SCM env
)
1348 const SCM cdr_expr
= SCM_CDR (expr
);
1349 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1350 const SCM rnames
= SCM_CAR (cddr_expr
);
1351 const SCM extended_env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
1352 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
1353 const SCM exit_sequence
= SCM_CAR (cdddr_expr
);
1354 const SCM um_exit_sequence
= unmemoize_exprs (exit_sequence
, extended_env
);
1355 const SCM cddddr_expr
= SCM_CDR (cdddr_expr
);
1356 const SCM um_body
= unmemoize_exprs (SCM_CAR (cddddr_expr
), extended_env
);
1358 /* build transformed binding list */
1359 SCM um_names
= scm_reverse (rnames
);
1360 SCM um_inits
= unmemoize_exprs (SCM_CAR (cdr_expr
), env
);
1361 SCM um_steps
= unmemoize_exprs (SCM_CDR (cddddr_expr
), extended_env
);
1362 SCM um_bindings
= SCM_EOL
;
1363 while (!SCM_NULLP (um_names
))
1365 const SCM name
= SCM_CAR (um_names
);
1366 const SCM init
= SCM_CAR (um_inits
);
1367 SCM step
= SCM_CAR (um_steps
);
1368 step
= scm_is_eq (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
1370 um_bindings
= scm_cons (scm_cons2 (name
, init
, step
), um_bindings
);
1372 um_names
= SCM_CDR (um_names
);
1373 um_inits
= SCM_CDR (um_inits
);
1374 um_steps
= SCM_CDR (um_steps
);
1376 um_bindings
= scm_reverse_x (um_bindings
, SCM_UNDEFINED
);
1378 return scm_cons (scm_sym_do
,
1379 scm_cons2 (um_bindings
, um_exit_sequence
, um_body
));
1383 SCM_SYNTAX (s_if
, "if", scm_i_makbimacro
, scm_m_if
);
1384 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
1387 scm_m_if (SCM expr
, SCM env SCM_UNUSED
)
1389 const SCM cdr_expr
= SCM_CDR (expr
);
1390 const long length
= scm_ilength (cdr_expr
);
1391 ASSERT_SYNTAX (length
== 2 || length
== 3, s_expression
, expr
);
1392 SCM_SETCAR (expr
, SCM_IM_IF
);
1397 unmemoize_if (const SCM expr
, const SCM env
)
1399 const SCM cdr_expr
= SCM_CDR (expr
);
1400 const SCM um_condition
= unmemoize_expression (SCM_CAR (cdr_expr
), env
);
1401 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1402 const SCM um_then
= unmemoize_expression (SCM_CAR (cddr_expr
), env
);
1403 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
1405 if (SCM_NULLP (cdddr_expr
))
1407 return scm_list_3 (scm_sym_if
, um_condition
, um_then
);
1411 const SCM um_else
= unmemoize_expression (SCM_CAR (cdddr_expr
), env
);
1412 return scm_list_4 (scm_sym_if
, um_condition
, um_then
, um_else
);
1417 SCM_SYNTAX (s_lambda
, "lambda", scm_i_makbimacro
, scm_m_lambda
);
1418 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
1420 /* A helper function for memoize_lambda to support checking for duplicate
1421 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
1422 * LIST or to the cdr of the last cons. Therefore, LIST may have any of the
1423 * forms that a formal argument can have:
1424 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
1426 c_improper_memq (SCM obj
, SCM list
)
1428 for (; SCM_CONSP (list
); list
= SCM_CDR (list
))
1430 if (scm_is_eq (SCM_CAR (list
), obj
))
1433 return scm_is_eq (list
, obj
);
1437 scm_m_lambda (SCM expr
, SCM env SCM_UNUSED
)
1446 const SCM cdr_expr
= SCM_CDR (expr
);
1447 const long length
= scm_ilength (cdr_expr
);
1448 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1449 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1451 /* Before iterating the list of formal arguments, make sure the formals
1452 * actually are given as either a symbol or a non-cyclic list. */
1453 formals
= SCM_CAR (cdr_expr
);
1454 if (SCM_CONSP (formals
))
1456 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
1457 * detected, report a 'Bad formals' error. */
1461 ASSERT_SYNTAX_2 (scm_is_symbol (formals
) || SCM_NULLP (formals
),
1462 s_bad_formals
, formals
, expr
);
1465 /* Now iterate the list of formal arguments to check if all formals are
1466 * symbols, and that there are no duplicates. */
1467 formals_idx
= formals
;
1468 while (SCM_CONSP (formals_idx
))
1470 const SCM formal
= SCM_CAR (formals_idx
);
1471 const SCM next_idx
= SCM_CDR (formals_idx
);
1472 ASSERT_SYNTAX_2 (scm_is_symbol (formal
), s_bad_formal
, formal
, expr
);
1473 ASSERT_SYNTAX_2 (!c_improper_memq (formal
, next_idx
),
1474 s_duplicate_formal
, formal
, expr
);
1475 formals_idx
= next_idx
;
1477 ASSERT_SYNTAX_2 (SCM_NULLP (formals_idx
) || scm_is_symbol (formals_idx
),
1478 s_bad_formal
, formals_idx
, expr
);
1480 /* Memoize the body. Keep a potential documentation string. */
1481 /* Dirk:FIXME:: We should probably extract the documentation string to
1482 * some external database. Otherwise it will slow down execution, since
1483 * the documentation string will have to be skipped with every execution
1484 * of the closure. */
1485 cddr_expr
= SCM_CDR (cdr_expr
);
1486 documentation
= (length
>= 3 && scm_is_string (SCM_CAR (cddr_expr
)));
1487 body
= documentation
? SCM_CDR (cddr_expr
) : cddr_expr
;
1488 new_body
= m_body (SCM_IM_LAMBDA
, body
);
1490 SCM_SETCAR (expr
, SCM_IM_LAMBDA
);
1492 SCM_SETCDR (cddr_expr
, new_body
);
1494 SCM_SETCDR (cdr_expr
, new_body
);
1499 unmemoize_lambda (const SCM expr
, const SCM env
)
1501 const SCM formals
= SCM_CADR (expr
);
1502 const SCM body
= SCM_CDDR (expr
);
1504 const SCM new_env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, env
);
1505 const SCM um_formals
= scm_i_finite_list_copy (formals
);
1506 const SCM um_body
= unmemoize_exprs (body
, new_env
);
1508 return scm_cons2 (scm_sym_lambda
, um_formals
, um_body
);
1512 /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
1514 check_bindings (const SCM bindings
, const SCM expr
)
1518 ASSERT_SYNTAX_2 (scm_ilength (bindings
) >= 0,
1519 s_bad_bindings
, bindings
, expr
);
1521 binding_idx
= bindings
;
1522 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1524 SCM name
; /* const */
1526 const SCM binding
= SCM_CAR (binding_idx
);
1527 ASSERT_SYNTAX_2 (scm_ilength (binding
) == 2,
1528 s_bad_binding
, binding
, expr
);
1530 name
= SCM_CAR (binding
);
1531 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
1536 /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
1537 * transformed to the lists (vn ... v2 v1) and (i1 i2 ... in). That is, the
1538 * variables are returned in a list with their order reversed, and the init
1539 * forms are returned in a list in the same order as they are given in the
1540 * bindings. If a duplicate variable name is detected, an error is
1543 transform_bindings (
1544 const SCM bindings
, const SCM expr
,
1545 SCM
*const rvarptr
, SCM
*const initptr
)
1547 SCM rvariables
= SCM_EOL
;
1548 SCM rinits
= SCM_EOL
;
1549 SCM binding_idx
= bindings
;
1550 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1552 const SCM binding
= SCM_CAR (binding_idx
);
1553 const SCM cdr_binding
= SCM_CDR (binding
);
1554 const SCM name
= SCM_CAR (binding
);
1555 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, rvariables
)),
1556 s_duplicate_binding
, name
, expr
);
1557 rvariables
= scm_cons (name
, rvariables
);
1558 rinits
= scm_cons (SCM_CAR (cdr_binding
), rinits
);
1560 *rvarptr
= rvariables
;
1561 *initptr
= scm_reverse_x (rinits
, SCM_UNDEFINED
);
1565 SCM_SYNTAX(s_let
, "let", scm_i_makbimacro
, scm_m_let
);
1566 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
1568 /* This function is a helper function for memoize_let. It transforms
1569 * (let name ((var init) ...) body ...) into
1570 * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
1571 * and memoizes the expression. It is assumed that the caller has checked
1572 * that name is a symbol and that there are bindings and a body. */
1574 memoize_named_let (const SCM expr
, const SCM env SCM_UNUSED
)
1580 const SCM cdr_expr
= SCM_CDR (expr
);
1581 const SCM name
= SCM_CAR (cdr_expr
);
1582 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1583 const SCM bindings
= SCM_CAR (cddr_expr
);
1584 check_bindings (bindings
, expr
);
1586 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1587 variables
= scm_reverse_x (rvariables
, SCM_UNDEFINED
);
1590 const SCM let_body
= SCM_CDR (cddr_expr
);
1591 const SCM lambda_body
= m_body (SCM_IM_LET
, let_body
);
1592 const SCM lambda_tail
= scm_cons (variables
, lambda_body
);
1593 const SCM lambda_form
= scm_cons_source (expr
, scm_sym_lambda
, lambda_tail
);
1595 const SCM rvar
= scm_list_1 (name
);
1596 const SCM init
= scm_list_1 (lambda_form
);
1597 const SCM body
= m_body (SCM_IM_LET
, scm_list_1 (name
));
1598 const SCM letrec_tail
= scm_cons (rvar
, scm_cons (init
, body
));
1599 const SCM letrec_form
= scm_cons_source (expr
, SCM_IM_LETREC
, letrec_tail
);
1600 return scm_cons_source (expr
, letrec_form
, inits
);
1604 /* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1605 * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
1607 scm_m_let (SCM expr
, SCM env
)
1611 const SCM cdr_expr
= SCM_CDR (expr
);
1612 const long length
= scm_ilength (cdr_expr
);
1613 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1614 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1616 bindings
= SCM_CAR (cdr_expr
);
1617 if (scm_is_symbol (bindings
))
1619 ASSERT_SYNTAX (length
>= 3, s_missing_expression
, expr
);
1620 return memoize_named_let (expr
, env
);
1623 check_bindings (bindings
, expr
);
1624 if (SCM_NULLP (bindings
) || SCM_NULLP (SCM_CDR (bindings
)))
1626 /* Special case: no bindings or single binding => let* is faster. */
1627 const SCM body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1628 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), bindings
, body
), env
);
1635 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1638 const SCM new_body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1639 const SCM new_tail
= scm_cons2 (rvariables
, inits
, new_body
);
1640 SCM_SETCAR (expr
, SCM_IM_LET
);
1641 SCM_SETCDR (expr
, new_tail
);
1648 build_binding_list (SCM rnames
, SCM rinits
)
1650 SCM bindings
= SCM_EOL
;
1651 while (!SCM_NULLP (rnames
))
1653 const SCM binding
= scm_list_2 (SCM_CAR (rnames
), SCM_CAR (rinits
));
1654 bindings
= scm_cons (binding
, bindings
);
1655 rnames
= SCM_CDR (rnames
);
1656 rinits
= SCM_CDR (rinits
);
1662 unmemoize_let (const SCM expr
, const SCM env
)
1664 const SCM cdr_expr
= SCM_CDR (expr
);
1665 const SCM um_rnames
= SCM_CAR (cdr_expr
);
1666 const SCM extended_env
= SCM_EXTEND_ENV (um_rnames
, SCM_EOL
, env
);
1667 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1668 const SCM um_inits
= unmemoize_exprs (SCM_CAR (cddr_expr
), env
);
1669 const SCM um_rinits
= scm_reverse_x (um_inits
, SCM_UNDEFINED
);
1670 const SCM um_bindings
= build_binding_list (um_rnames
, um_rinits
);
1671 const SCM um_body
= unmemoize_exprs (SCM_CDR (cddr_expr
), extended_env
);
1673 return scm_cons2 (scm_sym_let
, um_bindings
, um_body
);
1677 SCM_SYNTAX(s_letrec
, "letrec", scm_i_makbimacro
, scm_m_letrec
);
1678 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
1681 scm_m_letrec (SCM expr
, SCM env
)
1685 const SCM cdr_expr
= SCM_CDR (expr
);
1686 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1687 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1689 bindings
= SCM_CAR (cdr_expr
);
1690 if (SCM_NULLP (bindings
))
1692 /* no bindings, let* is executed faster */
1693 SCM body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1694 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), SCM_EOL
, body
), env
);
1702 check_bindings (bindings
, expr
);
1703 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1704 new_body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1705 return scm_cons2 (SCM_IM_LETREC
, rvariables
, scm_cons (inits
, new_body
));
1710 unmemoize_letrec (const SCM expr
, const SCM env
)
1712 const SCM cdr_expr
= SCM_CDR (expr
);
1713 const SCM um_rnames
= SCM_CAR (cdr_expr
);
1714 const SCM extended_env
= SCM_EXTEND_ENV (um_rnames
, SCM_EOL
, env
);
1715 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1716 const SCM um_inits
= unmemoize_exprs (SCM_CAR (cddr_expr
), extended_env
);
1717 const SCM um_rinits
= scm_reverse_x (um_inits
, SCM_UNDEFINED
);
1718 const SCM um_bindings
= build_binding_list (um_rnames
, um_rinits
);
1719 const SCM um_body
= unmemoize_exprs (SCM_CDR (cddr_expr
), extended_env
);
1721 return scm_cons2 (scm_sym_letrec
, um_bindings
, um_body
);
1726 SCM_SYNTAX (s_letstar
, "let*", scm_i_makbimacro
, scm_m_letstar
);
1727 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
1729 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1730 * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
1732 scm_m_letstar (SCM expr
, SCM env SCM_UNUSED
)
1737 const SCM cdr_expr
= SCM_CDR (expr
);
1738 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1739 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1741 binding_idx
= SCM_CAR (cdr_expr
);
1742 check_bindings (binding_idx
, expr
);
1744 /* Transform ((v1 i1) (v2 i2) ...) into (v1 i1 v2 i2 ...). The
1745 * transformation is done in place. At the beginning of one iteration of
1746 * the loop the variable binding_idx holds the form
1747 * P1:( (vn . P2:(in . ())) . P3:( (vn+1 in+1) ... ) ),
1748 * where P1, P2 and P3 indicate the pairs, that are relevant for the
1749 * transformation. P1 and P2 are modified in the loop, P3 remains
1750 * untouched. After the execution of the loop, P1 will hold
1751 * P1:( vn . P2:(in . P3:( (vn+1 in+1) ... )) )
1752 * and binding_idx will hold P3. */
1753 while (!SCM_NULLP (binding_idx
))
1755 const SCM cdr_binding_idx
= SCM_CDR (binding_idx
); /* remember P3 */
1756 const SCM binding
= SCM_CAR (binding_idx
);
1757 const SCM name
= SCM_CAR (binding
);
1758 const SCM cdr_binding
= SCM_CDR (binding
);
1760 SCM_SETCDR (cdr_binding
, cdr_binding_idx
); /* update P2 */
1761 SCM_SETCAR (binding_idx
, name
); /* update P1 */
1762 SCM_SETCDR (binding_idx
, cdr_binding
); /* update P1 */
1764 binding_idx
= cdr_binding_idx
; /* continue with P3 */
1767 new_body
= m_body (SCM_IM_LETSTAR
, SCM_CDR (cdr_expr
));
1768 SCM_SETCAR (expr
, SCM_IM_LETSTAR
);
1769 /* the bindings have been changed in place */
1770 SCM_SETCDR (cdr_expr
, new_body
);
1775 unmemoize_letstar (const SCM expr
, const SCM env
)
1777 const SCM cdr_expr
= SCM_CDR (expr
);
1778 const SCM body
= SCM_CDR (cdr_expr
);
1779 SCM bindings
= SCM_CAR (cdr_expr
);
1780 SCM um_bindings
= SCM_EOL
;
1781 SCM extended_env
= env
;
1784 while (!SCM_NULLP (bindings
))
1786 const SCM variable
= SCM_CAR (bindings
);
1787 const SCM init
= SCM_CADR (bindings
);
1788 const SCM um_init
= unmemoize_expression (init
, extended_env
);
1789 um_bindings
= scm_cons (scm_list_2 (variable
, um_init
), um_bindings
);
1790 extended_env
= SCM_EXTEND_ENV (variable
, SCM_BOOL_F
, extended_env
);
1791 bindings
= SCM_CDDR (bindings
);
1793 um_bindings
= scm_reverse_x (um_bindings
, SCM_UNDEFINED
);
1795 um_body
= unmemoize_exprs (body
, extended_env
);
1797 return scm_cons2 (scm_sym_letstar
, um_bindings
, um_body
);
1801 SCM_SYNTAX (s_or
, "or", scm_i_makbimacro
, scm_m_or
);
1802 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
1805 scm_m_or (SCM expr
, SCM env SCM_UNUSED
)
1807 const SCM cdr_expr
= SCM_CDR (expr
);
1808 const long length
= scm_ilength (cdr_expr
);
1810 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1814 /* Special case: (or) is replaced by #f. */
1819 SCM_SETCAR (expr
, SCM_IM_OR
);
1825 unmemoize_or (const SCM expr
, const SCM env
)
1827 return scm_cons (scm_sym_or
, unmemoize_exprs (SCM_CDR (expr
), env
));
1831 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
1832 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
1833 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
1834 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
1836 /* Internal function to handle a quasiquotation: 'form' is the parameter in
1837 * the call (quasiquotation form), 'env' is the environment where unquoted
1838 * expressions will be evaluated, and 'depth' is the current quasiquotation
1839 * nesting level and is known to be greater than zero. */
1841 iqq (SCM form
, SCM env
, unsigned long int depth
)
1843 if (SCM_CONSP (form
))
1845 const SCM tmp
= SCM_CAR (form
);
1846 if (scm_is_eq (tmp
, scm_sym_quasiquote
))
1848 const SCM args
= SCM_CDR (form
);
1849 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1850 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
1852 else if (scm_is_eq (tmp
, scm_sym_unquote
))
1854 const SCM args
= SCM_CDR (form
);
1855 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1857 return scm_eval_car (args
, env
);
1859 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
1861 else if (SCM_CONSP (tmp
)
1862 && scm_is_eq (SCM_CAR (tmp
), scm_sym_uq_splicing
))
1864 const SCM args
= SCM_CDR (tmp
);
1865 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1868 const SCM list
= scm_eval_car (args
, env
);
1869 const SCM rest
= SCM_CDR (form
);
1870 ASSERT_SYNTAX_2 (scm_ilength (list
) >= 0,
1871 s_splicing
, list
, form
);
1872 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
1875 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
1876 iqq (SCM_CDR (form
), env
, depth
));
1879 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
1880 iqq (SCM_CDR (form
), env
, depth
));
1882 else if (SCM_VECTORP (form
))
1884 size_t i
= SCM_VECTOR_LENGTH (form
);
1885 SCM
const *const data
= SCM_VELTS (form
);
1888 tmp
= scm_cons (data
[--i
], tmp
);
1889 scm_remember_upto_here_1 (form
);
1890 return scm_vector (iqq (tmp
, env
, depth
));
1897 scm_m_quasiquote (SCM expr
, SCM env
)
1899 const SCM cdr_expr
= SCM_CDR (expr
);
1900 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1901 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1902 return iqq (SCM_CAR (cdr_expr
), env
, 1);
1906 SCM_SYNTAX (s_quote
, "quote", scm_i_makbimacro
, scm_m_quote
);
1907 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
1910 scm_m_quote (SCM expr
, SCM env SCM_UNUSED
)
1914 const SCM cdr_expr
= SCM_CDR (expr
);
1915 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1916 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1917 quotee
= SCM_CAR (cdr_expr
);
1918 if (is_self_quoting_p (quotee
))
1921 SCM_SETCAR (expr
, SCM_IM_QUOTE
);
1922 SCM_SETCDR (expr
, quotee
);
1927 unmemoize_quote (const SCM expr
, const SCM env SCM_UNUSED
)
1929 return scm_list_2 (scm_sym_quote
, SCM_CDR (expr
));
1933 /* Will go into the RnRS module when Guile is factorized.
1934 SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
1935 static const char s_set_x
[] = "set!";
1936 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, s_set_x
);
1939 scm_m_set_x (SCM expr
, SCM env SCM_UNUSED
)
1944 const SCM cdr_expr
= SCM_CDR (expr
);
1945 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1946 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1947 variable
= SCM_CAR (cdr_expr
);
1949 /* Memoize the variable form. */
1950 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
1951 new_variable
= lookup_symbol (variable
, env
);
1952 /* Leave the memoization of unbound symbols to lazy memoization: */
1953 if (SCM_UNBNDP (new_variable
))
1954 new_variable
= variable
;
1956 SCM_SETCAR (expr
, SCM_IM_SET_X
);
1957 SCM_SETCAR (cdr_expr
, new_variable
);
1962 unmemoize_set_x (const SCM expr
, const SCM env
)
1964 return scm_cons (scm_sym_set_x
, unmemoize_exprs (SCM_CDR (expr
), env
));
1968 /* Start of the memoizers for non-R5RS builtin macros. */
1971 SCM_SYNTAX (s_atapply
, "@apply", scm_i_makbimacro
, scm_m_apply
);
1972 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1973 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1976 scm_m_apply (SCM expr
, SCM env SCM_UNUSED
)
1978 const SCM cdr_expr
= SCM_CDR (expr
);
1979 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1980 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_missing_expression
, expr
);
1982 SCM_SETCAR (expr
, SCM_IM_APPLY
);
1987 unmemoize_apply (const SCM expr
, const SCM env
)
1989 return scm_list_2 (scm_sym_atapply
, unmemoize_exprs (SCM_CDR (expr
), env
));
1993 SCM_SYNTAX (s_atbind
, "@bind", scm_i_makbimacro
, scm_m_atbind
);
1995 /* FIXME: The following explanation should go into the documentation: */
1996 /* (@bind ((var init) ...) body ...) will assign the values of the `init's to
1997 * the global variables named by `var's (symbols, not evaluated), creating
1998 * them if they don't exist, executes body, and then restores the previous
1999 * values of the `var's. Additionally, whenever control leaves body, the
2000 * values of the `var's are saved and restored when control returns. It is an
2001 * error when a symbol appears more than once among the `var's. All `init's
2002 * are evaluated before any `var' is set.
2004 * Think of this as `let' for dynamic scope.
2007 /* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into
2008 * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...).
2010 * FIXME - also implement `@bind*'.
2013 scm_m_atbind (SCM expr
, SCM env
)
2020 const SCM top_level
= scm_env_top_level (env
);
2022 const SCM cdr_expr
= SCM_CDR (expr
);
2023 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2024 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
2025 bindings
= SCM_CAR (cdr_expr
);
2026 check_bindings (bindings
, expr
);
2027 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
2029 for (variable_idx
= rvariables
;
2030 !SCM_NULLP (variable_idx
);
2031 variable_idx
= SCM_CDR (variable_idx
))
2033 /* The first call to scm_sym2var will look beyond the current module,
2034 * while the second call wont. */
2035 const SCM variable
= SCM_CAR (variable_idx
);
2036 SCM new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_F
);
2037 if (scm_is_false (new_variable
))
2038 new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_T
);
2039 SCM_SETCAR (variable_idx
, new_variable
);
2042 SCM_SETCAR (expr
, SCM_IM_BIND
);
2043 SCM_SETCAR (cdr_expr
, scm_cons (rvariables
, inits
));
2048 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_i_makbimacro
, scm_m_cont
);
2049 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, s_atcall_cc
);
2052 scm_m_cont (SCM expr
, SCM env SCM_UNUSED
)
2054 const SCM cdr_expr
= SCM_CDR (expr
);
2055 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2056 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2058 SCM_SETCAR (expr
, SCM_IM_CONT
);
2063 unmemoize_atcall_cc (const SCM expr
, const SCM env
)
2065 return scm_list_2 (scm_sym_atcall_cc
, unmemoize_exprs (SCM_CDR (expr
), env
));
2069 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_i_makbimacro
, scm_m_at_call_with_values
);
2070 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
2073 scm_m_at_call_with_values (SCM expr
, SCM env SCM_UNUSED
)
2075 const SCM cdr_expr
= SCM_CDR (expr
);
2076 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2077 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2079 SCM_SETCAR (expr
, SCM_IM_CALL_WITH_VALUES
);
2084 unmemoize_at_call_with_values (const SCM expr
, const SCM env
)
2086 return scm_list_2 (scm_sym_at_call_with_values
,
2087 unmemoize_exprs (SCM_CDR (expr
), env
));
2091 SCM_SYNTAX (s_future
, "future", scm_i_makbimacro
, scm_m_future
);
2092 SCM_GLOBAL_SYMBOL (scm_sym_future
, s_future
);
2094 /* Like promises, futures are implemented as closures with an empty
2095 * parameter list. Thus, (future <expression>) is transformed into
2096 * (#@future '() <expression>), where the empty list represents the
2097 * empty parameter list. This representation allows for easy creation
2098 * of the closure during evaluation. */
2100 scm_m_future (SCM expr
, SCM env
)
2102 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
2103 SCM_SETCAR (new_expr
, SCM_IM_FUTURE
);
2108 unmemoize_future (const SCM expr
, const SCM env
)
2110 const SCM thunk_expr
= SCM_CADDR (expr
);
2111 return scm_list_2 (scm_sym_future
, unmemoize_expression (thunk_expr
, env
));
2115 SCM_SYNTAX (s_gset_x
, "set!", scm_i_makbimacro
, scm_m_generalized_set_x
);
2116 SCM_SYMBOL (scm_sym_setter
, "setter");
2119 scm_m_generalized_set_x (SCM expr
, SCM env
)
2121 SCM target
, exp_target
;
2123 const SCM cdr_expr
= SCM_CDR (expr
);
2124 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2125 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2127 target
= SCM_CAR (cdr_expr
);
2128 if (!SCM_CONSP (target
))
2131 return scm_m_set_x (expr
, env
);
2135 /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */
2136 /* Macroexpanding the target might return things of the form
2137 (begin <atom>). In that case, <atom> must be a symbol or a
2138 variable and we memoize to (set! <atom> ...).
2140 exp_target
= macroexp (target
, env
);
2141 if (scm_is_eq (SCM_CAR (exp_target
), SCM_IM_BEGIN
)
2142 && !SCM_NULLP (SCM_CDR (exp_target
))
2143 && SCM_NULLP (SCM_CDDR (exp_target
)))
2145 exp_target
= SCM_CADR (exp_target
);
2146 ASSERT_SYNTAX_2 (scm_is_symbol (exp_target
)
2147 || SCM_VARIABLEP (exp_target
),
2148 s_bad_variable
, exp_target
, expr
);
2149 return scm_cons (SCM_IM_SET_X
, scm_cons (exp_target
,
2150 SCM_CDR (cdr_expr
)));
2154 const SCM setter_proc_tail
= scm_list_1 (SCM_CAR (target
));
2155 const SCM setter_proc
= scm_cons_source (expr
, scm_sym_setter
,
2158 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
2159 const SCM setter_args
= scm_append_x (scm_list_2 (SCM_CDR (target
),
2162 SCM_SETCAR (expr
, setter_proc
);
2163 SCM_SETCDR (expr
, setter_args
);
2170 /* @slot-ref is bound privately in the (oop goops) module from goops.c. As
2171 * soon as the module system allows us to more freely create bindings in
2172 * arbitrary modules during the startup phase, the code from goops.c should be
2175 SCM_SYMBOL (sym_atslot_ref
, "@slot-ref");
2178 scm_m_atslot_ref (SCM expr
, SCM env SCM_UNUSED
)
2182 const SCM cdr_expr
= SCM_CDR (expr
);
2183 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2184 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2185 slot_nr
= SCM_CADR (cdr_expr
);
2186 ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2188 SCM_SETCAR (expr
, SCM_IM_SLOT_REF
);
2189 SCM_SETCDR (cdr_expr
, slot_nr
);
2194 unmemoize_atslot_ref (const SCM expr
, const SCM env
)
2196 const SCM instance
= SCM_CADR (expr
);
2197 const SCM um_instance
= unmemoize_expression (instance
, env
);
2198 const SCM slot_nr
= SCM_CDDR (expr
);
2199 return scm_list_3 (sym_atslot_ref
, um_instance
, slot_nr
);
2203 /* @slot-set! is bound privately in the (oop goops) module from goops.c. As
2204 * soon as the module system allows us to more freely create bindings in
2205 * arbitrary modules during the startup phase, the code from goops.c should be
2208 SCM_SYMBOL (sym_atslot_set_x
, "@slot-set!");
2211 scm_m_atslot_set_x (SCM expr
, SCM env SCM_UNUSED
)
2215 const SCM cdr_expr
= SCM_CDR (expr
);
2216 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2217 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 3, s_expression
, expr
);
2218 slot_nr
= SCM_CADR (cdr_expr
);
2219 ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2221 SCM_SETCAR (expr
, SCM_IM_SLOT_SET_X
);
2226 unmemoize_atslot_set_x (const SCM expr
, const SCM env
)
2228 const SCM cdr_expr
= SCM_CDR (expr
);
2229 const SCM instance
= SCM_CAR (cdr_expr
);
2230 const SCM um_instance
= unmemoize_expression (instance
, env
);
2231 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
2232 const SCM slot_nr
= SCM_CAR (cddr_expr
);
2233 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
2234 const SCM value
= SCM_CAR (cdddr_expr
);
2235 const SCM um_value
= unmemoize_expression (value
, env
);
2236 return scm_list_4 (sym_atslot_set_x
, um_instance
, slot_nr
, um_value
);
2240 #if SCM_ENABLE_ELISP
2242 static const char s_defun
[] = "Symbol's function definition is void";
2244 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_i_makbimacro
, scm_m_nil_cond
);
2246 /* nil-cond expressions have the form
2247 * (nil-cond COND VAL COND VAL ... ELSEVAL) */
2249 scm_m_nil_cond (SCM expr
, SCM env SCM_UNUSED
)
2251 const long length
= scm_ilength (SCM_CDR (expr
));
2252 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
2253 ASSERT_SYNTAX (length
>= 1 && (length
% 2) == 1, s_expression
, expr
);
2255 SCM_SETCAR (expr
, SCM_IM_NIL_COND
);
2260 SCM_SYNTAX (s_atfop
, "@fop", scm_i_makbimacro
, scm_m_atfop
);
2262 /* The @fop-macro handles procedure and macro applications for elisp. The
2263 * input expression must have the form
2264 * (@fop <var> (transformer-macro <expr> ...))
2265 * where <var> must be a symbol. The expression is transformed into the
2266 * memoized form of either
2267 * (apply <un-aliased var> (transformer-macro <expr> ...))
2268 * if the value of var (across all aliasing) is not a macro, or
2269 * (<un-aliased var> <expr> ...)
2270 * if var is a macro. */
2272 scm_m_atfop (SCM expr
, SCM env SCM_UNUSED
)
2277 const SCM cdr_expr
= SCM_CDR (expr
);
2278 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2279 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 1, s_missing_expression
, expr
);
2281 symbol
= SCM_CAR (cdr_expr
);
2282 ASSERT_SYNTAX_2 (scm_is_symbol (symbol
), s_bad_variable
, symbol
, expr
);
2284 location
= scm_symbol_fref (symbol
);
2285 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2287 /* The elisp function `defalias' allows to define aliases for symbols. To
2288 * look up such definitions, the chain of symbol definitions has to be
2289 * followed up to the terminal symbol. */
2290 while (scm_is_symbol (SCM_VARIABLE_REF (location
)))
2292 const SCM alias
= SCM_VARIABLE_REF (location
);
2293 location
= scm_symbol_fref (alias
);
2294 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2297 /* Memoize the value location belonging to the terminal symbol. */
2298 SCM_SETCAR (cdr_expr
, location
);
2300 if (!SCM_MACROP (SCM_VARIABLE_REF (location
)))
2302 /* Since the location does not contain a macro, the form is a procedure
2303 * application. Replace `@fop' by `@apply' and transform the expression
2304 * including the `transformer-macro'. */
2305 SCM_SETCAR (expr
, SCM_IM_APPLY
);
2310 /* Since the location contains a macro, the arguments should not be
2311 * transformed, so the `transformer-macro' is cut out. The resulting
2312 * expression starts with the memoized variable, that is at the cdr of
2313 * the input expression. */
2314 SCM_SETCDR (cdr_expr
, SCM_CDADR (cdr_expr
));
2319 #endif /* SCM_ENABLE_ELISP */
2323 unmemoize_builtin_macro (const SCM expr
, const SCM env
)
2325 switch (ISYMNUM (SCM_CAR (expr
)))
2327 case (ISYMNUM (SCM_IM_AND
)):
2328 return unmemoize_and (expr
, env
);
2330 case (ISYMNUM (SCM_IM_BEGIN
)):
2331 return unmemoize_begin (expr
, env
);
2333 case (ISYMNUM (SCM_IM_CASE
)):
2334 return unmemoize_case (expr
, env
);
2336 case (ISYMNUM (SCM_IM_COND
)):
2337 return unmemoize_cond (expr
, env
);
2339 case (ISYMNUM (SCM_IM_DELAY
)):
2340 return unmemoize_delay (expr
, env
);
2342 case (ISYMNUM (SCM_IM_DO
)):
2343 return unmemoize_do (expr
, env
);
2345 case (ISYMNUM (SCM_IM_IF
)):
2346 return unmemoize_if (expr
, env
);
2348 case (ISYMNUM (SCM_IM_LAMBDA
)):
2349 return unmemoize_lambda (expr
, env
);
2351 case (ISYMNUM (SCM_IM_LET
)):
2352 return unmemoize_let (expr
, env
);
2354 case (ISYMNUM (SCM_IM_LETREC
)):
2355 return unmemoize_letrec (expr
, env
);
2357 case (ISYMNUM (SCM_IM_LETSTAR
)):
2358 return unmemoize_letstar (expr
, env
);
2360 case (ISYMNUM (SCM_IM_OR
)):
2361 return unmemoize_or (expr
, env
);
2363 case (ISYMNUM (SCM_IM_QUOTE
)):
2364 return unmemoize_quote (expr
, env
);
2366 case (ISYMNUM (SCM_IM_SET_X
)):
2367 return unmemoize_set_x (expr
, env
);
2369 case (ISYMNUM (SCM_IM_APPLY
)):
2370 return unmemoize_apply (expr
, env
);
2372 case (ISYMNUM (SCM_IM_BIND
)):
2373 return unmemoize_exprs (expr
, env
); /* FIXME */
2375 case (ISYMNUM (SCM_IM_CONT
)):
2376 return unmemoize_atcall_cc (expr
, env
);
2378 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2379 return unmemoize_at_call_with_values (expr
, env
);
2381 case (ISYMNUM (SCM_IM_FUTURE
)):
2382 return unmemoize_future (expr
, env
);
2384 case (ISYMNUM (SCM_IM_SLOT_REF
)):
2385 return unmemoize_atslot_ref (expr
, env
);
2387 case (ISYMNUM (SCM_IM_SLOT_SET_X
)):
2388 return unmemoize_atslot_set_x (expr
, env
);
2390 case (ISYMNUM (SCM_IM_NIL_COND
)):
2391 return unmemoize_exprs (expr
, env
); /* FIXME */
2394 return unmemoize_exprs (expr
, env
); /* FIXME */
2399 /* scm_i_unmemocopy_expr and scm_i_unmemocopy_body take a memoized expression
2400 * respectively a memoized body together with its environment and rewrite it
2401 * to its original form. Thus, these functions are the inversion of the
2402 * rewrite rules above. The procedure is not optimized for speed. It's used
2403 * in scm_i_unmemoize_expr, scm_procedure_source, macro_print and scm_iprin1.
2405 * Unmemoizing is not a reliable process. You cannot in general expect to get
2406 * the original source back.
2408 * However, GOOPS currently relies on this for method compilation. This ought
2412 scm_i_unmemocopy_expr (SCM expr
, SCM env
)
2414 const SCM source_properties
= scm_whash_lookup (scm_source_whash
, expr
);
2415 const SCM um_expr
= unmemoize_expression (expr
, env
);
2417 if (scm_is_true (source_properties
))
2418 scm_whash_insert (scm_source_whash
, um_expr
, source_properties
);
2424 scm_i_unmemocopy_body (SCM forms
, SCM env
)
2426 const SCM source_properties
= scm_whash_lookup (scm_source_whash
, forms
);
2427 const SCM um_forms
= unmemoize_exprs (forms
, env
);
2429 if (scm_is_true (source_properties
))
2430 scm_whash_insert (scm_source_whash
, um_forms
, source_properties
);
2436 #if (SCM_ENABLE_DEPRECATED == 1)
2438 /* Deprecated in guile 1.7.0 on 2003-11-09. */
2440 scm_m_expand_body (SCM exprs
, SCM env
)
2442 scm_c_issue_deprecation_warning
2443 ("`scm_m_expand_body' is deprecated.");
2444 m_expand_body (exprs
, env
);
2449 SCM_SYNTAX (s_undefine
, "undefine", scm_makacro
, scm_m_undefine
);
2452 scm_m_undefine (SCM expr
, SCM env
)
2457 const SCM cdr_expr
= SCM_CDR (expr
);
2458 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), "Bad undefine placement in", expr
);
2459 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2460 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2462 scm_c_issue_deprecation_warning
2463 ("`undefine' is deprecated.\n");
2465 variable
= SCM_CAR (cdr_expr
);
2466 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
2467 location
= scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_F
);
2468 ASSERT_SYNTAX_2 (scm_is_true (location
)
2469 && !SCM_UNBNDP (SCM_VARIABLE_REF (location
)),
2470 "variable already unbound ", variable
, expr
);
2471 SCM_VARIABLE_SET (location
, SCM_UNDEFINED
);
2472 return SCM_UNSPECIFIED
;
2476 scm_macroexp (SCM x
, SCM env
)
2478 scm_c_issue_deprecation_warning
2479 ("`scm_macroexp' is deprecated.");
2480 return macroexp (x
, env
);
2486 #if (SCM_ENABLE_DEPRECATED == 1)
2489 scm_unmemocar (SCM form
, SCM env
)
2491 scm_c_issue_deprecation_warning
2492 ("`scm_unmemocar' is deprecated.");
2494 if (!SCM_CONSP (form
))
2498 SCM c
= SCM_CAR (form
);
2499 if (SCM_VARIABLEP (c
))
2501 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
2502 if (scm_is_false (sym
))
2503 sym
= sym_three_question_marks
;
2504 SCM_SETCAR (form
, sym
);
2506 else if (SCM_ILOCP (c
))
2508 unsigned long int ir
;
2510 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
2511 env
= SCM_CDR (env
);
2512 env
= SCM_CAAR (env
);
2513 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
2514 env
= SCM_CDR (env
);
2516 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
2524 /*****************************************************************************/
2525 /*****************************************************************************/
2526 /* The definitions for execution start here. */
2527 /*****************************************************************************/
2528 /*****************************************************************************/
2530 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
2531 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
2532 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
2533 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
2535 /* A function object to implement "apply" for non-closure functions. */
2537 /* An endless list consisting of #<undefined> objects: */
2538 static SCM undefineds
;
2542 scm_badargsp (SCM formals
, SCM args
)
2544 while (!SCM_NULLP (formals
))
2546 if (!SCM_CONSP (formals
))
2548 if (SCM_NULLP (args
))
2550 formals
= SCM_CDR (formals
);
2551 args
= SCM_CDR (args
);
2553 return !SCM_NULLP (args
) ? 1 : 0;
2558 /* The evaluator contains a plethora of EVAL symbols. This is an attempt at
2561 * The following macros should be used in code which is read twice (where the
2562 * choice of evaluator is hard soldered):
2564 * CEVAL is the symbol used within one evaluator to call itself.
2565 * Originally, it is defined to ceval, but is redefined to deval during the
2568 * SCM_I_EVALIM is used when it is known that the expression is an
2569 * immediate. (This macro never calls an evaluator.)
2571 * EVAL evaluates an expression that is expected to have its symbols already
2572 * memoized. Expressions that are not of the form '(<form> <form> ...)' are
2573 * evaluated inline without calling an evaluator.
2575 * EVALCAR evaluates the car of an expression 'X:(Y:<form> <form> ...)',
2576 * potentially replacing a symbol at the position Y:<form> by its memoized
2577 * variable. If Y:<form> is not of the form '(<form> <form> ...)', the
2578 * evaluation is performed inline without calling an evaluator.
2580 * The following macros should be used in code which is read once
2581 * (where the choice of evaluator is dynamic):
2583 * SCM_I_XEVAL corresponds to EVAL, but uses ceval *or* deval depending on the
2586 * SCM_I_XEVALCAR corresponds to EVALCAR, but uses ceval *or* deval depending
2587 * on the debugging mode.
2589 * The main motivation for keeping this plethora is efficiency
2590 * together with maintainability (=> locality of code).
2593 static SCM
ceval (SCM x
, SCM env
);
2594 static SCM
deval (SCM x
, SCM env
);
2598 #define SCM_I_EVALIM2(x) \
2599 ((scm_is_eq ((x), SCM_EOL) \
2600 ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \
2604 #define SCM_I_EVALIM(x, env) (SCM_ILOCP (x) \
2605 ? *scm_ilookup ((x), (env)) \
2608 #define SCM_I_XEVAL(x, env) \
2610 ? SCM_I_EVALIM2 (x) \
2611 : (SCM_VARIABLEP (x) \
2612 ? SCM_VARIABLE_REF (x) \
2614 ? (scm_debug_mode_p \
2615 ? deval ((x), (env)) \
2616 : ceval ((x), (env))) \
2619 #define SCM_I_XEVALCAR(x, env) \
2620 (SCM_IMP (SCM_CAR (x)) \
2621 ? SCM_I_EVALIM (SCM_CAR (x), (env)) \
2622 : (SCM_VARIABLEP (SCM_CAR (x)) \
2623 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2624 : (SCM_CONSP (SCM_CAR (x)) \
2625 ? (scm_debug_mode_p \
2626 ? deval (SCM_CAR (x), (env)) \
2627 : ceval (SCM_CAR (x), (env))) \
2628 : (!scm_is_symbol (SCM_CAR (x)) \
2630 : *scm_lookupcar ((x), (env), 1)))))
2632 #define EVAL(x, env) \
2634 ? SCM_I_EVALIM ((x), (env)) \
2635 : (SCM_VARIABLEP (x) \
2636 ? SCM_VARIABLE_REF (x) \
2638 ? CEVAL ((x), (env)) \
2641 #define EVALCAR(x, env) \
2642 (SCM_IMP (SCM_CAR (x)) \
2643 ? SCM_I_EVALIM (SCM_CAR (x), (env)) \
2644 : (SCM_VARIABLEP (SCM_CAR (x)) \
2645 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2646 : (SCM_CONSP (SCM_CAR (x)) \
2647 ? CEVAL (SCM_CAR (x), (env)) \
2648 : (!scm_is_symbol (SCM_CAR (x)) \
2650 : *scm_lookupcar ((x), (env), 1)))))
2652 SCM_REC_MUTEX (source_mutex
);
2655 /* Lookup a given local variable in an environment. The local variable is
2656 * given as an iloc, that is a triple <frame, binding, last?>, where frame
2657 * indicates the relative number of the environment frame (counting upwards
2658 * from the innermost environment frame), binding indicates the number of the
2659 * binding within the frame, and last? (which is extracted from the iloc using
2660 * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
2661 * very end of the improper list of bindings. */
2663 scm_ilookup (SCM iloc
, SCM env
)
2665 unsigned int frame_nr
= SCM_IFRAME (iloc
);
2666 unsigned int binding_nr
= SCM_IDIST (iloc
);
2670 for (; 0 != frame_nr
; --frame_nr
)
2671 frames
= SCM_CDR (frames
);
2673 bindings
= SCM_CAR (frames
);
2674 for (; 0 != binding_nr
; --binding_nr
)
2675 bindings
= SCM_CDR (bindings
);
2677 if (SCM_ICDRP (iloc
))
2678 return SCM_CDRLOC (bindings
);
2679 return SCM_CARLOC (SCM_CDR (bindings
));
2683 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
2685 static void error_unbound_variable (SCM symbol
) SCM_NORETURN
;
2686 static void error_defined_variable (SCM symbol
) SCM_NORETURN
;
2688 /* Call this for variables that are unfound.
2691 error_unbound_variable (SCM symbol
)
2693 scm_error (scm_unbound_variable_key
, NULL
,
2694 "Unbound variable: ~S",
2695 scm_list_1 (symbol
), SCM_BOOL_F
);
2698 /* Call this for variables that are found but contain SCM_UNDEFINED.
2701 error_defined_variable (SCM symbol
)
2703 /* We use the 'unbound-variable' key here as well, since it
2704 basically is the same kind of error, with a slight variation in
2705 the displayed message.
2707 scm_error (scm_unbound_variable_key
, NULL
,
2708 "Variable used before given a value: ~S",
2709 scm_list_1 (symbol
), SCM_BOOL_F
);
2713 /* The Lookup Car Race
2716 Memoization of variables and special forms is done while executing
2717 the code for the first time. As long as there is only one thread
2718 everything is fine, but as soon as two threads execute the same
2719 code concurrently `for the first time' they can come into conflict.
2721 This memoization includes rewriting variable references into more
2722 efficient forms and expanding macros. Furthermore, macro expansion
2723 includes `compiling' special forms like `let', `cond', etc. into
2724 tree-code instructions.
2726 There shouldn't normally be a problem with memoizing local and
2727 global variable references (into ilocs and variables), because all
2728 threads will mutate the code in *exactly* the same way and (if I
2729 read the C code correctly) it is not possible to observe a half-way
2730 mutated cons cell. The lookup procedure can handle this
2731 transparently without any critical sections.
2733 It is different with macro expansion, because macro expansion
2734 happens outside of the lookup procedure and can't be
2735 undone. Therefore the lookup procedure can't cope with it. It has
2736 to indicate failure when it detects a lost race and hope that the
2737 caller can handle it. Luckily, it turns out that this is the case.
2739 An example to illustrate this: Suppose that the following form will
2740 be memoized concurrently by two threads
2744 Let's first examine the lookup of X in the body. The first thread
2745 decides that it has to find the symbol "x" in the environment and
2746 starts to scan it. Then the other thread takes over and actually
2747 overtakes the first. It looks up "x" and substitutes an
2748 appropriate iloc for it. Now the first thread continues and
2749 completes its lookup. It comes to exactly the same conclusions as
2750 the second one and could - without much ado - just overwrite the
2751 iloc with the same iloc.
2753 But let's see what will happen when the race occurs while looking
2754 up the symbol "let" at the start of the form. It could happen that
2755 the second thread interrupts the lookup of the first thread and not
2756 only substitutes a variable for it but goes right ahead and
2757 replaces it with the compiled form (#@let* (x 12) x). Now, when
2758 the first thread completes its lookup, it would replace the #@let*
2759 with a variable containing the "let" binding, effectively reverting
2760 the form to (let (x 12) x). This is wrong. It has to detect that
2761 it has lost the race and the evaluator has to reconsider the
2762 changed form completely.
2764 This race condition could be resolved with some kind of traffic
2765 light (like mutexes) around scm_lookupcar, but I think that it is
2766 best to avoid them in this case. They would serialize memoization
2767 completely and because lookup involves calling arbitrary Scheme
2768 code (via the lookup-thunk), threads could be blocked for an
2769 arbitrary amount of time or even deadlock. But with the current
2770 solution a lot of unnecessary work is potentially done. */
2772 /* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
2773 return NULL to indicate a failed lookup due to some race conditions
2774 between threads. This only happens when VLOC is the first cell of
2775 a special form that will eventually be memoized (like `let', etc.)
2776 In that case the whole lookup is bogus and the caller has to
2777 reconsider the complete special form.
2779 SCM_LOOKUPCAR is still there, of course. It just calls
2780 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
2781 should only be called when it is known that VLOC is not the first
2782 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
2783 for NULL. I think I've found the only places where this
2787 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
2790 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
2791 register SCM iloc
= SCM_ILOC00
;
2792 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
2794 if (!SCM_CONSP (SCM_CAR (env
)))
2796 al
= SCM_CARLOC (env
);
2797 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
2799 if (!SCM_CONSP (fl
))
2801 if (scm_is_eq (fl
, var
))
2803 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2805 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
2806 return SCM_CDRLOC (*al
);
2811 al
= SCM_CDRLOC (*al
);
2812 if (scm_is_eq (SCM_CAR (fl
), var
))
2814 if (SCM_UNBNDP (SCM_CAR (*al
)))
2815 error_defined_variable (var
);
2816 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2818 SCM_SETCAR (vloc
, iloc
);
2819 return SCM_CARLOC (*al
);
2821 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
2823 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
2826 SCM top_thunk
, real_var
;
2829 top_thunk
= SCM_CAR (env
); /* env now refers to a
2830 top level env thunk */
2831 env
= SCM_CDR (env
);
2834 top_thunk
= SCM_BOOL_F
;
2835 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
2836 if (scm_is_false (real_var
))
2839 if (!SCM_NULLP (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
2844 if (SCM_NULLP (env
))
2845 error_unbound_variable (var
);
2847 scm_misc_error (NULL
, "Damaged environment: ~S",
2852 /* A variable could not be found, but we shall
2853 not throw an error. */
2854 static SCM undef_object
= SCM_UNDEFINED
;
2855 return &undef_object
;
2859 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2861 /* Some other thread has changed the very cell we are working
2862 on. In effect, it must have done our job or messed it up
2865 var
= SCM_CAR (vloc
);
2866 if (SCM_VARIABLEP (var
))
2867 return SCM_VARIABLE_LOC (var
);
2868 if (SCM_ILOCP (var
))
2869 return scm_ilookup (var
, genv
);
2870 /* We can't cope with anything else than variables and ilocs. When
2871 a special form has been memoized (i.e. `let' into `#@let') we
2872 return NULL and expect the calling function to do the right
2873 thing. For the evaluator, this means going back and redoing
2874 the dispatch on the car of the form. */
2878 SCM_SETCAR (vloc
, real_var
);
2879 return SCM_VARIABLE_LOC (real_var
);
2884 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
2886 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
2893 /* During execution, look up a symbol in the top level of the given local
2894 * environment and return the corresponding variable object. If no binding
2895 * for the symbol can be found, an 'Unbound variable' error is signalled. */
2897 lazy_memoize_variable (const SCM symbol
, const SCM environment
)
2899 const SCM top_level
= scm_env_top_level (environment
);
2900 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
2902 if (scm_is_false (variable
))
2903 error_unbound_variable (symbol
);
2910 scm_eval_car (SCM pair
, SCM env
)
2912 return SCM_I_XEVALCAR (pair
, env
);
2917 scm_eval_args (SCM l
, SCM env
, SCM proc
)
2919 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
2920 while (SCM_CONSP (l
))
2922 res
= EVALCAR (l
, env
);
2924 *lloc
= scm_list_1 (res
);
2925 lloc
= SCM_CDRLOC (*lloc
);
2929 scm_wrong_num_args (proc
);
2935 scm_eval_body (SCM code
, SCM env
)
2940 next
= SCM_CDR (code
);
2941 while (!SCM_NULLP (next
))
2943 if (SCM_IMP (SCM_CAR (code
)))
2945 if (SCM_ISYMP (SCM_CAR (code
)))
2947 scm_rec_mutex_lock (&source_mutex
);
2948 /* check for race condition */
2949 if (SCM_ISYMP (SCM_CAR (code
)))
2950 m_expand_body (code
, env
);
2951 scm_rec_mutex_unlock (&source_mutex
);
2956 SCM_I_XEVAL (SCM_CAR (code
), env
);
2958 next
= SCM_CDR (code
);
2960 return SCM_I_XEVALCAR (code
, env
);
2966 /* SECTION: This code is specific for the debugging support. One
2967 * branch is read when DEVAL isn't defined, the other when DEVAL is
2973 #define SCM_APPLY scm_apply
2974 #define PREP_APPLY(proc, args)
2976 #define RETURN(x) do { return x; } while (0)
2977 #ifdef STACK_CHECKING
2978 #ifndef NO_CEVAL_STACK_CHECKING
2979 #define EVAL_STACK_CHECKING
2986 #define CEVAL deval /* Substitute all uses of ceval */
2989 #define SCM_APPLY scm_dapply
2992 #define PREP_APPLY(p, l) \
2993 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
2996 #define ENTER_APPLY \
2998 SCM_SET_ARGSREADY (debug);\
2999 if (scm_check_apply_p && SCM_TRAPS_P)\
3000 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
3002 SCM tmp, tail = scm_from_bool(SCM_TRACED_FRAME_P (debug)); \
3003 SCM_SET_TRACED_FRAME (debug); \
3005 if (SCM_CHEAPTRAPS_P)\
3007 tmp = scm_make_debugobj (&debug);\
3008 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
3013 tmp = scm_make_continuation (&first);\
3015 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
3022 #define RETURN(e) do { proc = (e); goto exit; } while (0)
3024 #ifdef STACK_CHECKING
3025 #ifndef EVAL_STACK_CHECKING
3026 #define EVAL_STACK_CHECKING
3031 /* scm_last_debug_frame contains a pointer to the last debugging information
3032 * stack frame. It is accessed very often from the debugging evaluator, so it
3033 * should probably not be indirectly addressed. Better to save and restore it
3034 * from the current root at any stack swaps.
3037 /* scm_debug_eframe_size is the number of slots available for pseudo
3038 * stack frames at each real stack frame.
3041 long scm_debug_eframe_size
;
3043 int scm_debug_mode_p
;
3044 int scm_check_entry_p
;
3045 int scm_check_apply_p
;
3046 int scm_check_exit_p
;
3048 long scm_eval_stack
;
3050 scm_t_option scm_eval_opts
[] = {
3051 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
3054 scm_t_option scm_debug_opts
[] = {
3055 { SCM_OPTION_BOOLEAN
, "cheap", 1,
3056 "*Flyweight representation of the stack at traps." },
3057 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
3058 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
3059 { SCM_OPTION_BOOLEAN
, "procnames", 1,
3060 "Record procedure names at definition." },
3061 { SCM_OPTION_BOOLEAN
, "backwards", 0,
3062 "Display backtrace in anti-chronological order." },
3063 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
3064 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
3065 { SCM_OPTION_INTEGER
, "frames", 3,
3066 "Maximum number of tail-recursive frames in backtrace." },
3067 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
3068 "Maximal number of stored backtrace frames." },
3069 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
3070 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
3071 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
3072 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
3073 { 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."}
3076 scm_t_option scm_evaluator_trap_table
[] = {
3077 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
3078 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
3079 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
3080 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
3081 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
3082 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
3083 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
3086 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
3088 "Option interface for the evaluation options. Instead of using\n"
3089 "this procedure directly, use the procedures @code{eval-enable},\n"
3090 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
3091 #define FUNC_NAME s_scm_eval_options_interface
3095 ans
= scm_options (setting
,
3099 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
3106 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
3108 "Option interface for the evaluator trap options.")
3109 #define FUNC_NAME s_scm_evaluator_traps
3113 ans
= scm_options (setting
,
3114 scm_evaluator_trap_table
,
3115 SCM_N_EVALUATOR_TRAPS
,
3117 SCM_RESET_DEBUG_MODE
;
3125 deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
3127 SCM
*results
= lloc
;
3128 while (SCM_CONSP (l
))
3130 const SCM res
= EVALCAR (l
, env
);
3132 *lloc
= scm_list_1 (res
);
3133 lloc
= SCM_CDRLOC (*lloc
);
3137 scm_wrong_num_args (proc
);
3144 /* SECTION: This code is compiled twice.
3148 /* Update the toplevel environment frame ENV so that it refers to the
3149 * current module. */
3150 #define UPDATE_TOPLEVEL_ENV(env) \
3152 SCM p = scm_current_module_lookup_closure (); \
3153 if (p != SCM_CAR (env)) \
3154 env = scm_top_level_env (p); \
3158 #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
3159 ASSERT_SYNTAX (!scm_is_eq ((x), SCM_EOL), s_empty_combination, x)
3162 /* This is the evaluator. Like any real monster, it has three heads:
3164 * ceval is the non-debugging evaluator, deval is the debugging version. Both
3165 * are implemented using a common code base, using the following mechanism:
3166 * CEVAL is a macro, which is either defined to ceval or deval. Thus, there
3167 * is no function CEVAL, but the code for CEVAL actually compiles to either
3168 * ceval or deval. When CEVAL is defined to ceval, it is known that the macro
3169 * DEVAL is not defined. When CEVAL is defined to deval, then the macro DEVAL
3170 * is known to be defined. Thus, in CEVAL parts for the debugging evaluator
3171 * are enclosed within #ifdef DEVAL ... #endif.
3173 * All three (ceval, deval and their common implementation CEVAL) take two
3174 * input parameters, x and env: x is a single expression to be evalutated.
3175 * env is the environment in which bindings are searched.
3177 * x is known to be a pair. Since x is a single expression, it is necessarily
3178 * in a tail position. If x is just a call to another function like in the
3179 * expression (foo exp1 exp2 ...), the realization of that call therefore
3180 * _must_not_ increase stack usage (the evaluation of exp1, exp2 etc.,
3181 * however, may do so). This is realized by making extensive use of 'goto'
3182 * statements within the evaluator: The gotos replace recursive calls to
3183 * CEVAL, thus re-using the same stack frame that CEVAL was already using.
3184 * If, however, x represents some form that requires to evaluate a sequence of
3185 * expressions like (begin exp1 exp2 ...), then recursive calls to CEVAL are
3186 * performed for all but the last expression of that sequence. */
3189 CEVAL (SCM x
, SCM env
)
3193 scm_t_debug_frame debug
;
3194 scm_t_debug_info
*debug_info_end
;
3195 debug
.prev
= scm_last_debug_frame
;
3198 * The debug.vect contains twice as much scm_t_debug_info frames as the
3199 * user has specified with (debug-set! frames <n>).
3201 * Even frames are eval frames, odd frames are apply frames.
3203 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
3204 * sizeof (scm_t_debug_info
));
3205 debug
.info
= debug
.vect
;
3206 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
3207 scm_last_debug_frame
= &debug
;
3209 #ifdef EVAL_STACK_CHECKING
3210 if (scm_stack_checking_enabled_p
&& SCM_STACK_OVERFLOW_P (&proc
))
3213 debug
.info
->e
.exp
= x
;
3214 debug
.info
->e
.env
= env
;
3216 scm_report_stack_overflow ();
3226 SCM_CLEAR_ARGSREADY (debug
);
3227 if (SCM_OVERFLOWP (debug
))
3230 * In theory, this should be the only place where it is necessary to
3231 * check for space in debug.vect since both eval frames and
3232 * available space are even.
3234 * For this to be the case, however, it is necessary that primitive
3235 * special forms which jump back to `loop', `begin' or some similar
3236 * label call PREP_APPLY.
3238 else if (++debug
.info
>= debug_info_end
)
3240 SCM_SET_OVERFLOW (debug
);
3245 debug
.info
->e
.exp
= x
;
3246 debug
.info
->e
.env
= env
;
3247 if (scm_check_entry_p
&& SCM_TRAPS_P
)
3249 if (SCM_ENTER_FRAME_P
3250 || (SCM_BREAKPOINTS_P
&& scm_c_source_property_breakpoint_p (x
)))
3253 SCM tail
= scm_from_bool (SCM_TAILRECP (debug
));
3254 SCM_SET_TAILREC (debug
);
3255 if (SCM_CHEAPTRAPS_P
)
3256 stackrep
= scm_make_debugobj (&debug
);
3260 SCM val
= scm_make_continuation (&first
);
3270 /* This gives the possibility for the debugger to
3271 modify the source expression before evaluation. */
3276 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
3277 scm_sym_enter_frame
,
3280 unmemoize_expression (x
, env
));
3287 if (SCM_ISYMP (SCM_CAR (x
)))
3289 switch (ISYMNUM (SCM_CAR (x
)))
3291 case (ISYMNUM (SCM_IM_AND
)):
3293 while (!SCM_NULLP (SCM_CDR (x
)))
3295 SCM test_result
= EVALCAR (x
, env
);
3296 if (scm_is_false (test_result
) || SCM_NILP (test_result
))
3297 RETURN (SCM_BOOL_F
);
3301 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3304 case (ISYMNUM (SCM_IM_BEGIN
)):
3307 RETURN (SCM_UNSPECIFIED
);
3309 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3312 /* If we are on toplevel with a lookup closure, we need to sync
3313 with the current module. */
3314 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
3316 UPDATE_TOPLEVEL_ENV (env
);
3317 while (!SCM_NULLP (SCM_CDR (x
)))
3320 UPDATE_TOPLEVEL_ENV (env
);
3326 goto nontoplevel_begin
;
3329 while (!SCM_NULLP (SCM_CDR (x
)))
3331 const SCM form
= SCM_CAR (x
);
3334 if (SCM_ISYMP (form
))
3336 scm_rec_mutex_lock (&source_mutex
);
3337 /* check for race condition */
3338 if (SCM_ISYMP (SCM_CAR (x
)))
3339 m_expand_body (x
, env
);
3340 scm_rec_mutex_unlock (&source_mutex
);
3341 goto nontoplevel_begin
;
3344 SCM_VALIDATE_NON_EMPTY_COMBINATION (form
);
3347 (void) EVAL (form
, env
);
3353 /* scm_eval last form in list */
3354 const SCM last_form
= SCM_CAR (x
);
3356 if (SCM_CONSP (last_form
))
3358 /* This is by far the most frequent case. */
3360 goto loop
; /* tail recurse */
3362 else if (SCM_IMP (last_form
))
3363 RETURN (SCM_I_EVALIM (last_form
, env
));
3364 else if (SCM_VARIABLEP (last_form
))
3365 RETURN (SCM_VARIABLE_REF (last_form
));
3366 else if (scm_is_symbol (last_form
))
3367 RETURN (*scm_lookupcar (x
, env
, 1));
3373 case (ISYMNUM (SCM_IM_CASE
)):
3376 const SCM key
= EVALCAR (x
, env
);
3378 while (!SCM_NULLP (x
))
3380 const SCM clause
= SCM_CAR (x
);
3381 SCM labels
= SCM_CAR (clause
);
3382 if (scm_is_eq (labels
, SCM_IM_ELSE
))
3384 x
= SCM_CDR (clause
);
3385 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3388 while (!SCM_NULLP (labels
))
3390 const SCM label
= SCM_CAR (labels
);
3391 if (scm_is_eq (label
, key
)
3392 || scm_is_true (scm_eqv_p (label
, key
)))
3394 x
= SCM_CDR (clause
);
3395 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3398 labels
= SCM_CDR (labels
);
3403 RETURN (SCM_UNSPECIFIED
);
3406 case (ISYMNUM (SCM_IM_COND
)):
3408 while (!SCM_NULLP (x
))
3410 const SCM clause
= SCM_CAR (x
);
3411 if (scm_is_eq (SCM_CAR (clause
), SCM_IM_ELSE
))
3413 x
= SCM_CDR (clause
);
3414 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3419 arg1
= EVALCAR (clause
, env
);
3420 if (scm_is_true (arg1
) && !SCM_NILP (arg1
))
3422 x
= SCM_CDR (clause
);
3425 else if (!scm_is_eq (SCM_CAR (x
), SCM_IM_ARROW
))
3427 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3433 proc
= EVALCAR (proc
, env
);
3434 PREP_APPLY (proc
, scm_list_1 (arg1
));
3442 RETURN (SCM_UNSPECIFIED
);
3445 case (ISYMNUM (SCM_IM_DO
)):
3448 /* Compute the initialization values and the initial environment. */
3449 SCM init_forms
= SCM_CAR (x
);
3450 SCM init_values
= SCM_EOL
;
3451 while (!SCM_NULLP (init_forms
))
3453 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3454 init_forms
= SCM_CDR (init_forms
);
3457 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
3461 SCM test_form
= SCM_CAR (x
);
3462 SCM body_forms
= SCM_CADR (x
);
3463 SCM step_forms
= SCM_CDDR (x
);
3465 SCM test_result
= EVALCAR (test_form
, env
);
3467 while (scm_is_false (test_result
) || SCM_NILP (test_result
))
3470 /* Evaluate body forms. */
3472 for (temp_forms
= body_forms
;
3473 !SCM_NULLP (temp_forms
);
3474 temp_forms
= SCM_CDR (temp_forms
))
3476 SCM form
= SCM_CAR (temp_forms
);
3477 /* Dirk:FIXME: We only need to eval forms that may have
3478 * a side effect here. This is only true for forms that
3479 * start with a pair. All others are just constants.
3480 * Since with the current memoizer 'form' may hold a
3481 * constant, we call EVAL here to handle the constant
3482 * cases. In the long run it would make sense to have
3483 * the macro transformer of 'do' eliminate all forms
3484 * that have no sideeffect. Then instead of EVAL we
3485 * could call CEVAL directly here. */
3486 (void) EVAL (form
, env
);
3491 /* Evaluate the step expressions. */
3493 SCM step_values
= SCM_EOL
;
3494 for (temp_forms
= step_forms
;
3495 !SCM_NULLP (temp_forms
);
3496 temp_forms
= SCM_CDR (temp_forms
))
3498 const SCM value
= EVALCAR (temp_forms
, env
);
3499 step_values
= scm_cons (value
, step_values
);
3501 env
= SCM_EXTEND_ENV (SCM_CAAR (env
),
3506 test_result
= EVALCAR (test_form
, env
);
3511 RETURN (SCM_UNSPECIFIED
);
3512 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3513 goto nontoplevel_begin
;
3516 case (ISYMNUM (SCM_IM_IF
)):
3519 SCM test_result
= EVALCAR (x
, env
);
3520 x
= SCM_CDR (x
); /* then expression */
3521 if (scm_is_false (test_result
) || SCM_NILP (test_result
))
3523 x
= SCM_CDR (x
); /* else expression */
3525 RETURN (SCM_UNSPECIFIED
);
3528 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3532 case (ISYMNUM (SCM_IM_LET
)):
3535 SCM init_forms
= SCM_CADR (x
);
3536 SCM init_values
= SCM_EOL
;
3539 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3540 init_forms
= SCM_CDR (init_forms
);
3542 while (!SCM_NULLP (init_forms
));
3543 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
3546 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3547 goto nontoplevel_begin
;
3550 case (ISYMNUM (SCM_IM_LETREC
)):
3552 env
= SCM_EXTEND_ENV (SCM_CAR (x
), undefineds
, env
);
3555 SCM init_forms
= SCM_CAR (x
);
3556 SCM init_values
= SCM_EOL
;
3559 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3560 init_forms
= SCM_CDR (init_forms
);
3562 while (!SCM_NULLP (init_forms
));
3563 SCM_SETCDR (SCM_CAR (env
), init_values
);
3566 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3567 goto nontoplevel_begin
;
3570 case (ISYMNUM (SCM_IM_LETSTAR
)):
3573 SCM bindings
= SCM_CAR (x
);
3574 if (!SCM_NULLP (bindings
))
3578 SCM name
= SCM_CAR (bindings
);
3579 SCM init
= SCM_CDR (bindings
);
3580 env
= SCM_EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
3581 bindings
= SCM_CDR (init
);
3583 while (!SCM_NULLP (bindings
));
3587 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3588 goto nontoplevel_begin
;
3591 case (ISYMNUM (SCM_IM_OR
)):
3593 while (!SCM_NULLP (SCM_CDR (x
)))
3595 SCM val
= EVALCAR (x
, env
);
3596 if (scm_is_true (val
) && !SCM_NILP (val
))
3601 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3605 case (ISYMNUM (SCM_IM_LAMBDA
)):
3606 RETURN (scm_closure (SCM_CDR (x
), env
));
3609 case (ISYMNUM (SCM_IM_QUOTE
)):
3610 RETURN (SCM_CDR (x
));
3613 case (ISYMNUM (SCM_IM_SET_X
)):
3617 SCM variable
= SCM_CAR (x
);
3618 if (SCM_ILOCP (variable
))
3619 location
= scm_ilookup (variable
, env
);
3620 else if (SCM_VARIABLEP (variable
))
3621 location
= SCM_VARIABLE_LOC (variable
);
3624 /* (scm_is_symbol (variable)) is known to be true */
3625 variable
= lazy_memoize_variable (variable
, env
);
3626 SCM_SETCAR (x
, variable
);
3627 location
= SCM_VARIABLE_LOC (variable
);
3630 *location
= EVALCAR (x
, env
);
3632 RETURN (SCM_UNSPECIFIED
);
3635 case (ISYMNUM (SCM_IM_APPLY
)):
3636 /* Evaluate the procedure to be applied. */
3638 proc
= EVALCAR (x
, env
);
3639 PREP_APPLY (proc
, SCM_EOL
);
3641 /* Evaluate the argument holding the list of arguments */
3643 arg1
= EVALCAR (x
, env
);
3646 /* Go here to tail-apply a procedure. PROC is the procedure and
3647 * ARG1 is the list of arguments. PREP_APPLY must have been called
3648 * before jumping to apply_proc. */
3649 if (SCM_CLOSUREP (proc
))
3651 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3653 debug
.info
->a
.args
= arg1
;
3655 if (scm_badargsp (formals
, arg1
))
3656 scm_wrong_num_args (proc
);
3658 /* Copy argument list */
3659 if (SCM_NULL_OR_NIL_P (arg1
))
3660 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
3663 SCM args
= scm_list_1 (SCM_CAR (arg1
));
3665 arg1
= SCM_CDR (arg1
);
3666 while (!SCM_NULL_OR_NIL_P (arg1
))
3668 SCM new_tail
= scm_list_1 (SCM_CAR (arg1
));
3669 SCM_SETCDR (tail
, new_tail
);
3671 arg1
= SCM_CDR (arg1
);
3673 env
= SCM_EXTEND_ENV (formals
, args
, SCM_ENV (proc
));
3676 x
= SCM_CLOSURE_BODY (proc
);
3677 goto nontoplevel_begin
;
3682 RETURN (SCM_APPLY (proc
, arg1
, SCM_EOL
));
3686 case (ISYMNUM (SCM_IM_CONT
)):
3689 SCM val
= scm_make_continuation (&first
);
3697 proc
= EVALCAR (proc
, env
);
3698 PREP_APPLY (proc
, scm_list_1 (arg1
));
3705 case (ISYMNUM (SCM_IM_DELAY
)):
3706 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
3709 case (ISYMNUM (SCM_IM_FUTURE
)):
3710 RETURN (scm_i_make_future (scm_closure (SCM_CDR (x
), env
)));
3713 /* PLACEHOLDER for case (ISYMNUM (SCM_IM_DISPATCH)): The following
3714 code (type_dispatch) is intended to be the tail of the case
3715 clause for the internal macro SCM_IM_DISPATCH. Please don't
3716 remove it from this location without discussing it with Mikael
3717 <djurfeldt@nada.kth.se> */
3719 /* The type dispatch code is duplicated below
3720 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
3721 * cuts down execution time for type dispatch to 50%. */
3722 type_dispatch
: /* inputs: x, arg1 */
3723 /* Type dispatch means to determine from the types of the function
3724 * arguments (i. e. the 'signature' of the call), which method from
3725 * a generic function is to be called. This process of selecting
3726 * the right method takes some time. To speed it up, guile uses
3727 * caching: Together with the macro call to dispatch the signatures
3728 * of some previous calls to that generic function from the same
3729 * place are stored (in the code!) in a cache that we call the
3730 * 'method cache'. This is done since it is likely, that
3731 * consecutive calls to dispatch from that position in the code will
3732 * have the same signature. Thus, the type dispatch works as
3733 * follows: First, determine a hash value from the signature of the
3734 * actual arguments. Second, use this hash value as an index to
3735 * find that same signature in the method cache stored at this
3736 * position in the code. If found, you have also found the
3737 * corresponding method that belongs to that signature. If the
3738 * signature is not found in the method cache, you have to perform a
3739 * full search over all signatures stored with the generic
3742 unsigned long int specializers
;
3743 unsigned long int hash_value
;
3744 unsigned long int cache_end_pos
;
3745 unsigned long int mask
;
3749 SCM z
= SCM_CDDR (x
);
3750 SCM tmp
= SCM_CADR (z
);
3751 specializers
= scm_to_ulong (SCM_CAR (z
));
3753 /* Compute a hash value for searching the method cache. There
3754 * are two variants for computing the hash value, a (rather)
3755 * complicated one, and a simple one. For the complicated one
3756 * explained below, tmp holds a number that is used in the
3758 if (SCM_VECTORP (tmp
))
3760 /* This method of determining the hash value is much
3761 * simpler: Set the hash value to zero and just perform a
3762 * linear search through the method cache. */
3764 mask
= (unsigned long int) ((long) -1);
3766 cache_end_pos
= SCM_VECTOR_LENGTH (method_cache
);
3770 /* Use the signature of the actual arguments to determine
3771 * the hash value. This is done as follows: Each class has
3772 * an array of random numbers, that are determined when the
3773 * class is created. The integer 'hashset' is an index into
3774 * that array of random numbers. Now, from all classes that
3775 * are part of the signature of the actual arguments, the
3776 * random numbers at index 'hashset' are taken and summed
3777 * up, giving the hash value. The value of 'hashset' is
3778 * stored at the call to dispatch. This allows to have
3779 * different 'formulas' for calculating the hash value at
3780 * different places where dispatch is called. This allows
3781 * to optimize the hash formula at every individual place
3782 * where dispatch is called, such that hopefully the hash
3783 * value that is computed will directly point to the right
3784 * method in the method cache. */
3785 unsigned long int hashset
= scm_to_ulong (tmp
);
3786 unsigned long int counter
= specializers
+ 1;
3789 while (!SCM_NULLP (tmp_arg
) && counter
!= 0)
3791 SCM
class = scm_class_of (SCM_CAR (tmp_arg
));
3792 hash_value
+= SCM_INSTANCE_HASH (class, hashset
);
3793 tmp_arg
= SCM_CDR (tmp_arg
);
3797 method_cache
= SCM_CADR (z
);
3798 mask
= scm_to_ulong (SCM_CAR (z
));
3800 cache_end_pos
= hash_value
;
3805 /* Search the method cache for a method with a matching
3806 * signature. Start the search at position 'hash_value'. The
3807 * hashing implementation uses linear probing for conflict
3808 * resolution, that is, if the signature in question is not
3809 * found at the starting index in the hash table, the next table
3810 * entry is tried, and so on, until in the worst case the whole
3811 * cache has been searched, but still the signature has not been
3816 SCM args
= arg1
; /* list of arguments */
3817 z
= SCM_VELTS (method_cache
)[hash_value
];
3818 while (!SCM_NULLP (args
))
3820 /* More arguments than specifiers => CLASS != ENV */
3821 SCM class_of_arg
= scm_class_of (SCM_CAR (args
));
3822 if (!scm_is_eq (class_of_arg
, SCM_CAR (z
)))
3824 args
= SCM_CDR (args
);
3827 /* Fewer arguments than specifiers => CAR != ENV */
3828 if (SCM_NULLP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
)))
3831 hash_value
= (hash_value
+ 1) & mask
;
3832 } while (hash_value
!= cache_end_pos
);
3834 /* No appropriate method was found in the cache. */
3835 z
= scm_memoize_method (x
, arg1
);
3837 apply_cmethod
: /* inputs: z, arg1 */
3839 SCM formals
= SCM_CMETHOD_FORMALS (z
);
3840 env
= SCM_EXTEND_ENV (formals
, arg1
, SCM_CMETHOD_ENV (z
));
3841 x
= SCM_CMETHOD_BODY (z
);
3842 goto nontoplevel_begin
;
3848 case (ISYMNUM (SCM_IM_SLOT_REF
)):
3851 SCM instance
= EVALCAR (x
, env
);
3852 unsigned long int slot
= SCM_I_INUM (SCM_CDR (x
));
3853 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance
) [slot
]));
3857 case (ISYMNUM (SCM_IM_SLOT_SET_X
)):
3860 SCM instance
= EVALCAR (x
, env
);
3861 unsigned long int slot
= SCM_I_INUM (SCM_CADR (x
));
3862 SCM value
= EVALCAR (SCM_CDDR (x
), env
);
3863 SCM_STRUCT_DATA (instance
) [slot
] = SCM_UNPACK (value
);
3864 RETURN (SCM_UNSPECIFIED
);
3868 #if SCM_ENABLE_ELISP
3870 case (ISYMNUM (SCM_IM_NIL_COND
)):
3872 SCM test_form
= SCM_CDR (x
);
3873 x
= SCM_CDR (test_form
);
3874 while (!SCM_NULL_OR_NIL_P (x
))
3876 SCM test_result
= EVALCAR (test_form
, env
);
3877 if (!(scm_is_false (test_result
)
3878 || SCM_NULL_OR_NIL_P (test_result
)))
3880 if (scm_is_eq (SCM_CAR (x
), SCM_UNSPECIFIED
))
3881 RETURN (test_result
);
3882 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3887 test_form
= SCM_CDR (x
);
3888 x
= SCM_CDR (test_form
);
3892 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3896 #endif /* SCM_ENABLE_ELISP */
3898 case (ISYMNUM (SCM_IM_BIND
)):
3900 SCM vars
, exps
, vals
;
3903 vars
= SCM_CAAR (x
);
3904 exps
= SCM_CDAR (x
);
3906 while (!SCM_NULLP (exps
))
3908 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
3909 exps
= SCM_CDR (exps
);
3912 scm_swap_bindings (vars
, vals
);
3913 scm_dynwinds
= scm_acons (vars
, vals
, scm_dynwinds
);
3915 /* Ignore all but the last evaluation result. */
3916 for (x
= SCM_CDR (x
); !SCM_NULLP (SCM_CDR (x
)); x
= SCM_CDR (x
))
3918 if (SCM_CONSP (SCM_CAR (x
)))
3919 CEVAL (SCM_CAR (x
), env
);
3921 proc
= EVALCAR (x
, env
);
3923 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
3924 scm_swap_bindings (vars
, vals
);
3930 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
3935 producer
= EVALCAR (x
, env
);
3937 proc
= EVALCAR (x
, env
); /* proc is the consumer. */
3938 arg1
= SCM_APPLY (producer
, SCM_EOL
, SCM_EOL
);
3939 if (SCM_VALUESP (arg1
))
3941 /* The list of arguments is not copied. Rather, it is assumed
3942 * that this has been done by the 'values' procedure. */
3943 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
3947 arg1
= scm_list_1 (arg1
);
3949 PREP_APPLY (proc
, arg1
);
3960 if (SCM_VARIABLEP (SCM_CAR (x
)))
3961 proc
= SCM_VARIABLE_REF (SCM_CAR (x
));
3962 else if (SCM_ILOCP (SCM_CAR (x
)))
3963 proc
= *scm_ilookup (SCM_CAR (x
), env
);
3964 else if (SCM_CONSP (SCM_CAR (x
)))
3965 proc
= CEVAL (SCM_CAR (x
), env
);
3966 else if (scm_is_symbol (SCM_CAR (x
)))
3968 SCM orig_sym
= SCM_CAR (x
);
3970 SCM
*location
= scm_lookupcar1 (x
, env
, 1);
3971 if (location
== NULL
)
3973 /* we have lost the race, start again. */
3979 if (SCM_MACROP (proc
))
3981 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
3983 handle_a_macro
: /* inputs: x, env, proc */
3985 /* Set a flag during macro expansion so that macro
3986 application frames can be deleted from the backtrace. */
3987 SCM_SET_MACROEXP (debug
);
3989 arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
3990 scm_cons (env
, scm_listofnull
));
3992 SCM_CLEAR_MACROEXP (debug
);
3994 switch (SCM_MACRO_TYPE (proc
))
3998 if (!SCM_CONSP (arg1
))
3999 arg1
= scm_list_2 (SCM_IM_BEGIN
, arg1
);
4001 assert (!scm_is_eq (x
, SCM_CAR (arg1
))
4002 && !scm_is_eq (x
, SCM_CDR (arg1
)));
4005 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
4008 SCM_SETCAR (x
, SCM_CAR (arg1
));
4009 SCM_SETCDR (x
, SCM_CDR (arg1
));
4013 /* Prevent memoizing of debug info expression. */
4014 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
4019 SCM_SETCAR (x
, SCM_CAR (arg1
));
4020 SCM_SETCDR (x
, SCM_CDR (arg1
));
4022 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
4024 #if SCM_ENABLE_DEPRECATED == 1
4029 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
4043 if (SCM_MACROP (proc
))
4044 goto handle_a_macro
;
4048 /* When reaching this part of the code, the following is granted: Variable x
4049 * holds the first pair of an expression of the form (<function> arg ...).
4050 * Variable proc holds the object that resulted from the evaluation of
4051 * <function>. In the following, the arguments (if any) will be evaluated,
4052 * and proc will be applied to them. If proc does not really hold a
4053 * function object, this will be signalled as an error on the scheme
4054 * level. If the number of arguments does not match the number of arguments
4055 * that are allowed to be passed to proc, also an error on the scheme level
4056 * will be signalled. */
4057 PREP_APPLY (proc
, SCM_EOL
);
4058 if (SCM_NULLP (SCM_CDR (x
))) {
4061 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4062 switch (SCM_TYP7 (proc
))
4063 { /* no arguments given */
4064 case scm_tc7_subr_0
:
4065 RETURN (SCM_SUBRF (proc
) ());
4066 case scm_tc7_subr_1o
:
4067 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
4069 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
4070 case scm_tc7_rpsubr
:
4071 RETURN (SCM_BOOL_T
);
4073 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
4075 if (!SCM_SMOB_APPLICABLE_P (proc
))
4077 RETURN (SCM_SMOB_APPLY_0 (proc
));
4080 proc
= SCM_CCLO_SUBR (proc
);
4082 debug
.info
->a
.proc
= proc
;
4083 debug
.info
->a
.args
= scm_list_1 (arg1
);
4087 proc
= SCM_PROCEDURE (proc
);
4089 debug
.info
->a
.proc
= proc
;
4091 if (!SCM_CLOSUREP (proc
))
4094 case scm_tcs_closures
:
4096 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4097 if (SCM_CONSP (formals
))
4099 x
= SCM_CLOSURE_BODY (proc
);
4100 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
4101 goto nontoplevel_begin
;
4103 case scm_tcs_struct
:
4104 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4106 x
= SCM_ENTITY_PROCEDURE (proc
);
4110 else if (SCM_I_OPERATORP (proc
))
4113 proc
= (SCM_I_ENTITYP (proc
)
4114 ? SCM_ENTITY_PROCEDURE (proc
)
4115 : SCM_OPERATOR_PROCEDURE (proc
));
4117 debug
.info
->a
.proc
= proc
;
4118 debug
.info
->a
.args
= scm_list_1 (arg1
);
4124 case scm_tc7_subr_1
:
4125 case scm_tc7_subr_2
:
4126 case scm_tc7_subr_2o
:
4129 case scm_tc7_subr_3
:
4130 case scm_tc7_lsubr_2
:
4132 scm_wrong_num_args (proc
);
4135 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
4139 /* must handle macros by here */
4142 arg1
= EVALCAR (x
, env
);
4144 scm_wrong_num_args (proc
);
4146 debug
.info
->a
.args
= scm_list_1 (arg1
);
4154 evap1
: /* inputs: proc, arg1 */
4155 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4156 switch (SCM_TYP7 (proc
))
4157 { /* have one argument in arg1 */
4158 case scm_tc7_subr_2o
:
4159 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4160 case scm_tc7_subr_1
:
4161 case scm_tc7_subr_1o
:
4162 RETURN (SCM_SUBRF (proc
) (arg1
));
4164 if (SCM_I_INUMP (arg1
))
4166 RETURN (scm_from_double (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
))));
4168 else if (SCM_REALP (arg1
))
4170 RETURN (scm_from_double (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4172 else if (SCM_BIGP (arg1
))
4174 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4176 else if (SCM_FRACTIONP (arg1
))
4178 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4180 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4182 scm_i_symbol_chars (SCM_SNAME (proc
)));
4185 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
4188 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
4189 scm_i_symbol_chars (SCM_SNAME (proc
)));
4190 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
4195 case scm_tc7_rpsubr
:
4196 RETURN (SCM_BOOL_T
);
4198 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4201 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4203 RETURN (SCM_SUBRF (proc
) (scm_list_1 (arg1
)));
4206 if (!SCM_SMOB_APPLICABLE_P (proc
))
4208 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
4212 proc
= SCM_CCLO_SUBR (proc
);
4214 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
4215 debug
.info
->a
.proc
= proc
;
4219 proc
= SCM_PROCEDURE (proc
);
4221 debug
.info
->a
.proc
= proc
;
4223 if (!SCM_CLOSUREP (proc
))
4226 case scm_tcs_closures
:
4229 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4230 if (SCM_NULLP (formals
)
4231 || (SCM_CONSP (formals
) && SCM_CONSP (SCM_CDR (formals
))))
4233 x
= SCM_CLOSURE_BODY (proc
);
4235 env
= SCM_EXTEND_ENV (formals
,
4239 env
= SCM_EXTEND_ENV (formals
,
4243 goto nontoplevel_begin
;
4245 case scm_tcs_struct
:
4246 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4248 x
= SCM_ENTITY_PROCEDURE (proc
);
4250 arg1
= debug
.info
->a
.args
;
4252 arg1
= scm_list_1 (arg1
);
4256 else if (SCM_I_OPERATORP (proc
))
4260 proc
= (SCM_I_ENTITYP (proc
)
4261 ? SCM_ENTITY_PROCEDURE (proc
)
4262 : SCM_OPERATOR_PROCEDURE (proc
));
4264 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
4265 debug
.info
->a
.proc
= proc
;
4271 case scm_tc7_subr_2
:
4272 case scm_tc7_subr_0
:
4273 case scm_tc7_subr_3
:
4274 case scm_tc7_lsubr_2
:
4275 scm_wrong_num_args (proc
);
4281 arg2
= EVALCAR (x
, env
);
4283 scm_wrong_num_args (proc
);
4285 { /* have two or more arguments */
4287 debug
.info
->a
.args
= scm_list_2 (arg1
, arg2
);
4290 if (SCM_NULLP (x
)) {
4293 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4294 switch (SCM_TYP7 (proc
))
4295 { /* have two arguments */
4296 case scm_tc7_subr_2
:
4297 case scm_tc7_subr_2o
:
4298 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
4301 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4303 RETURN (SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
)));
4305 case scm_tc7_lsubr_2
:
4306 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
));
4307 case scm_tc7_rpsubr
:
4309 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
4311 if (!SCM_SMOB_APPLICABLE_P (proc
))
4313 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
));
4317 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
4318 scm_cons (proc
, debug
.info
->a
.args
),
4321 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
4322 scm_cons2 (proc
, arg1
,
4329 case scm_tcs_struct
:
4330 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4332 x
= SCM_ENTITY_PROCEDURE (proc
);
4334 arg1
= debug
.info
->a
.args
;
4336 arg1
= scm_list_2 (arg1
, arg2
);
4340 else if (SCM_I_OPERATORP (proc
))
4344 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
4345 ? SCM_ENTITY_PROCEDURE (proc
)
4346 : SCM_OPERATOR_PROCEDURE (proc
),
4347 scm_cons (proc
, debug
.info
->a
.args
),
4350 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
4351 ? SCM_ENTITY_PROCEDURE (proc
)
4352 : SCM_OPERATOR_PROCEDURE (proc
),
4353 scm_cons2 (proc
, arg1
,
4363 case scm_tc7_subr_0
:
4366 case scm_tc7_subr_1o
:
4367 case scm_tc7_subr_1
:
4368 case scm_tc7_subr_3
:
4369 scm_wrong_num_args (proc
);
4373 proc
= SCM_PROCEDURE (proc
);
4375 debug
.info
->a
.proc
= proc
;
4377 if (!SCM_CLOSUREP (proc
))
4380 case scm_tcs_closures
:
4383 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4384 if (SCM_NULLP (formals
)
4385 || (SCM_CONSP (formals
)
4386 && (SCM_NULLP (SCM_CDR (formals
))
4387 || (SCM_CONSP (SCM_CDR (formals
))
4388 && SCM_CONSP (SCM_CDDR (formals
))))))
4391 env
= SCM_EXTEND_ENV (formals
,
4395 env
= SCM_EXTEND_ENV (formals
,
4396 scm_list_2 (arg1
, arg2
),
4399 x
= SCM_CLOSURE_BODY (proc
);
4400 goto nontoplevel_begin
;
4405 scm_wrong_num_args (proc
);
4407 debug
.info
->a
.args
= scm_cons2 (arg1
, arg2
,
4408 deval_args (x
, env
, proc
,
4409 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
4413 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4414 switch (SCM_TYP7 (proc
))
4415 { /* have 3 or more arguments */
4417 case scm_tc7_subr_3
:
4418 if (!SCM_NULLP (SCM_CDR (x
)))
4419 scm_wrong_num_args (proc
);
4421 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4422 SCM_CADDR (debug
.info
->a
.args
)));
4424 arg1
= SCM_SUBRF(proc
)(arg1
, arg2
);
4425 arg2
= SCM_CDDR (debug
.info
->a
.args
);
4428 arg1
= SCM_SUBRF(proc
)(arg1
, SCM_CAR (arg2
));
4429 arg2
= SCM_CDR (arg2
);
4431 while (SCM_NIMP (arg2
));
4433 case scm_tc7_rpsubr
:
4434 if (scm_is_false (SCM_SUBRF (proc
) (arg1
, arg2
)))
4435 RETURN (SCM_BOOL_F
);
4436 arg1
= SCM_CDDR (debug
.info
->a
.args
);
4439 if (scm_is_false (SCM_SUBRF (proc
) (arg2
, SCM_CAR (arg1
))))
4440 RETURN (SCM_BOOL_F
);
4441 arg2
= SCM_CAR (arg1
);
4442 arg1
= SCM_CDR (arg1
);
4444 while (SCM_NIMP (arg1
));
4445 RETURN (SCM_BOOL_T
);
4446 case scm_tc7_lsubr_2
:
4447 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4448 SCM_CDDR (debug
.info
->a
.args
)));
4450 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4452 if (!SCM_SMOB_APPLICABLE_P (proc
))
4454 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4455 SCM_CDDR (debug
.info
->a
.args
)));
4459 proc
= SCM_PROCEDURE (proc
);
4460 debug
.info
->a
.proc
= proc
;
4461 if (!SCM_CLOSUREP (proc
))
4464 case scm_tcs_closures
:
4466 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4467 if (SCM_NULLP (formals
)
4468 || (SCM_CONSP (formals
)
4469 && (SCM_NULLP (SCM_CDR (formals
))
4470 || (SCM_CONSP (SCM_CDR (formals
))
4471 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4473 SCM_SET_ARGSREADY (debug
);
4474 env
= SCM_EXTEND_ENV (formals
,
4477 x
= SCM_CLOSURE_BODY (proc
);
4478 goto nontoplevel_begin
;
4481 case scm_tc7_subr_3
:
4482 if (!SCM_NULLP (SCM_CDR (x
)))
4483 scm_wrong_num_args (proc
);
4485 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, EVALCAR (x
, env
)));
4487 arg1
= SCM_SUBRF (proc
) (arg1
, arg2
);
4490 arg1
= SCM_SUBRF(proc
)(arg1
, EVALCAR(x
, env
));
4493 while (!SCM_NULLP (x
));
4495 case scm_tc7_rpsubr
:
4496 if (scm_is_false (SCM_SUBRF (proc
) (arg1
, arg2
)))
4497 RETURN (SCM_BOOL_F
);
4500 arg1
= EVALCAR (x
, env
);
4501 if (scm_is_false (SCM_SUBRF (proc
) (arg2
, arg1
)))
4502 RETURN (SCM_BOOL_F
);
4506 while (!SCM_NULLP (x
));
4507 RETURN (SCM_BOOL_T
);
4508 case scm_tc7_lsubr_2
:
4509 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
4511 RETURN (SCM_SUBRF (proc
) (scm_cons2 (arg1
,
4513 scm_eval_args (x
, env
, proc
))));
4515 if (!SCM_SMOB_APPLICABLE_P (proc
))
4517 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4518 scm_eval_args (x
, env
, proc
)));
4522 proc
= SCM_PROCEDURE (proc
);
4523 if (!SCM_CLOSUREP (proc
))
4526 case scm_tcs_closures
:
4528 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4529 if (SCM_NULLP (formals
)
4530 || (SCM_CONSP (formals
)
4531 && (SCM_NULLP (SCM_CDR (formals
))
4532 || (SCM_CONSP (SCM_CDR (formals
))
4533 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4535 env
= SCM_EXTEND_ENV (formals
,
4538 scm_eval_args (x
, env
, proc
)),
4540 x
= SCM_CLOSURE_BODY (proc
);
4541 goto nontoplevel_begin
;
4544 case scm_tcs_struct
:
4545 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4548 arg1
= debug
.info
->a
.args
;
4550 arg1
= scm_cons2 (arg1
, arg2
, scm_eval_args (x
, env
, proc
));
4552 x
= SCM_ENTITY_PROCEDURE (proc
);
4555 else if (SCM_I_OPERATORP (proc
))
4559 case scm_tc7_subr_2
:
4560 case scm_tc7_subr_1o
:
4561 case scm_tc7_subr_2o
:
4562 case scm_tc7_subr_0
:
4565 case scm_tc7_subr_1
:
4566 scm_wrong_num_args (proc
);
4574 if (scm_check_exit_p
&& SCM_TRAPS_P
)
4575 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
4577 SCM_CLEAR_TRACED_FRAME (debug
);
4578 if (SCM_CHEAPTRAPS_P
)
4579 arg1
= scm_make_debugobj (&debug
);
4583 SCM val
= scm_make_continuation (&first
);
4594 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
4598 scm_last_debug_frame
= debug
.prev
;
4604 /* SECTION: This code is compiled once.
4611 /* Simple procedure calls
4615 scm_call_0 (SCM proc
)
4617 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
4621 scm_call_1 (SCM proc
, SCM arg1
)
4623 return scm_apply (proc
, arg1
, scm_listofnull
);
4627 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
4629 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
4633 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
4635 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
4639 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
4641 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
4642 scm_cons (arg4
, scm_listofnull
)));
4645 /* Simple procedure applies
4649 scm_apply_0 (SCM proc
, SCM args
)
4651 return scm_apply (proc
, args
, SCM_EOL
);
4655 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
4657 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
4661 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
4663 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
4667 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
4669 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
4673 /* This code processes the arguments to apply:
4675 (apply PROC ARG1 ... ARGS)
4677 Given a list (ARG1 ... ARGS), this function conses the ARG1
4678 ... arguments onto the front of ARGS, and returns the resulting
4679 list. Note that ARGS is a list; thus, the argument to this
4680 function is a list whose last element is a list.
4682 Apply calls this function, and applies PROC to the elements of the
4683 result. apply:nconc2last takes care of building the list of
4684 arguments, given (ARG1 ... ARGS).
4686 Rather than do new consing, apply:nconc2last destroys its argument.
4687 On that topic, this code came into my care with the following
4688 beautifully cryptic comment on that topic: "This will only screw
4689 you if you do (scm_apply scm_apply '( ... ))" If you know what
4690 they're referring to, send me a patch to this comment. */
4692 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
4694 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
4695 "conses the @var{arg1} @dots{} arguments onto the front of\n"
4696 "@var{args}, and returns the resulting list. Note that\n"
4697 "@var{args} is a list; thus, the argument to this function is\n"
4698 "a list whose last element is a list.\n"
4699 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
4700 "destroys its argument, so use with care.")
4701 #define FUNC_NAME s_scm_nconc2last
4704 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
4706 while (!SCM_NULLP (SCM_CDR (*lloc
))) /* Perhaps should be
4707 SCM_NULL_OR_NIL_P, but not
4708 needed in 99.99% of cases,
4709 and it could seriously hurt
4710 performance. - Neil */
4711 lloc
= SCM_CDRLOC (*lloc
);
4712 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
4713 *lloc
= SCM_CAR (*lloc
);
4721 /* SECTION: When DEVAL is defined this code yields scm_dapply.
4722 * It is compiled twice.
4727 scm_apply (SCM proc
, SCM arg1
, SCM args
)
4733 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
4738 /* Apply a function to a list of arguments.
4740 This function is exported to the Scheme level as taking two
4741 required arguments and a tail argument, as if it were:
4742 (lambda (proc arg1 . args) ...)
4743 Thus, if you just have a list of arguments to pass to a procedure,
4744 pass the list as ARG1, and '() for ARGS. If you have some fixed
4745 args, pass the first as ARG1, then cons any remaining fixed args
4746 onto the front of your argument list, and pass that as ARGS. */
4749 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
4752 scm_t_debug_frame debug
;
4753 scm_t_debug_info debug_vect_body
;
4754 debug
.prev
= scm_last_debug_frame
;
4755 debug
.status
= SCM_APPLYFRAME
;
4756 debug
.vect
= &debug_vect_body
;
4757 debug
.vect
[0].a
.proc
= proc
;
4758 debug
.vect
[0].a
.args
= SCM_EOL
;
4759 scm_last_debug_frame
= &debug
;
4761 if (scm_debug_mode_p
)
4762 return scm_dapply (proc
, arg1
, args
);
4765 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
4767 /* If ARGS is the empty list, then we're calling apply with only two
4768 arguments --- ARG1 is the list of arguments for PROC. Whatever
4769 the case, futz with things so that ARG1 is the first argument to
4770 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
4773 Setting the debug apply frame args this way is pretty messy.
4774 Perhaps we should store arg1 and args directly in the frame as
4775 received, and let scm_frame_arguments unpack them, because that's
4776 a relatively rare operation. This works for now; if the Guile
4777 developer archives are still around, see Mikael's post of
4779 if (SCM_NULLP (args
))
4781 if (SCM_NULLP (arg1
))
4783 arg1
= SCM_UNDEFINED
;
4785 debug
.vect
[0].a
.args
= SCM_EOL
;
4791 debug
.vect
[0].a
.args
= arg1
;
4793 args
= SCM_CDR (arg1
);
4794 arg1
= SCM_CAR (arg1
);
4799 args
= scm_nconc2last (args
);
4801 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4805 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
4808 if (SCM_CHEAPTRAPS_P
)
4809 tmp
= scm_make_debugobj (&debug
);
4814 tmp
= scm_make_continuation (&first
);
4819 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
4826 switch (SCM_TYP7 (proc
))
4828 case scm_tc7_subr_2o
:
4829 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
4830 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4831 case scm_tc7_subr_2
:
4832 if (SCM_NULLP (args
) || !SCM_NULLP (SCM_CDR (args
)))
4833 scm_wrong_num_args (proc
);
4834 args
= SCM_CAR (args
);
4835 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4836 case scm_tc7_subr_0
:
4837 if (!SCM_UNBNDP (arg1
))
4838 scm_wrong_num_args (proc
);
4840 RETURN (SCM_SUBRF (proc
) ());
4841 case scm_tc7_subr_1
:
4842 if (SCM_UNBNDP (arg1
))
4843 scm_wrong_num_args (proc
);
4844 case scm_tc7_subr_1o
:
4845 if (!SCM_NULLP (args
))
4846 scm_wrong_num_args (proc
);
4848 RETURN (SCM_SUBRF (proc
) (arg1
));
4850 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
4851 scm_wrong_num_args (proc
);
4852 if (SCM_I_INUMP (arg1
))
4854 RETURN (scm_from_double (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
))));
4856 else if (SCM_REALP (arg1
))
4858 RETURN (scm_from_double (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4860 else if (SCM_BIGP (arg1
))
4862 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4864 else if (SCM_FRACTIONP (arg1
))
4866 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4868 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4869 SCM_ARG1
, scm_i_symbol_chars (SCM_SNAME (proc
)));
4871 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
4872 scm_wrong_num_args (proc
);
4874 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
4877 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
4878 scm_i_symbol_chars (SCM_SNAME (proc
)));
4879 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
4884 case scm_tc7_subr_3
:
4885 if (SCM_NULLP (args
)
4886 || SCM_NULLP (SCM_CDR (args
))
4887 || !SCM_NULLP (SCM_CDDR (args
)))
4888 scm_wrong_num_args (proc
);
4890 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
4893 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
4895 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
4897 case scm_tc7_lsubr_2
:
4898 if (!SCM_CONSP (args
))
4899 scm_wrong_num_args (proc
);
4901 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4903 if (SCM_NULLP (args
))
4904 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4905 while (SCM_NIMP (args
))
4907 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
4908 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
4909 args
= SCM_CDR (args
);
4912 case scm_tc7_rpsubr
:
4913 if (SCM_NULLP (args
))
4914 RETURN (SCM_BOOL_T
);
4915 while (SCM_NIMP (args
))
4917 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
4918 if (scm_is_false (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
4919 RETURN (SCM_BOOL_F
);
4920 arg1
= SCM_CAR (args
);
4921 args
= SCM_CDR (args
);
4923 RETURN (SCM_BOOL_T
);
4924 case scm_tcs_closures
:
4926 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4928 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4930 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
4931 scm_wrong_num_args (proc
);
4933 /* Copy argument list */
4938 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
4939 for (arg1
= SCM_CDR (arg1
); SCM_CONSP (arg1
); arg1
= SCM_CDR (arg1
))
4941 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
));
4944 SCM_SETCDR (tl
, arg1
);
4947 args
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4950 proc
= SCM_CLOSURE_BODY (proc
);
4952 arg1
= SCM_CDR (proc
);
4953 while (!SCM_NULLP (arg1
))
4955 if (SCM_IMP (SCM_CAR (proc
)))
4957 if (SCM_ISYMP (SCM_CAR (proc
)))
4959 scm_rec_mutex_lock (&source_mutex
);
4960 /* check for race condition */
4961 if (SCM_ISYMP (SCM_CAR (proc
)))
4962 m_expand_body (proc
, args
);
4963 scm_rec_mutex_unlock (&source_mutex
);
4967 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
4970 (void) EVAL (SCM_CAR (proc
), args
);
4972 arg1
= SCM_CDR (proc
);
4974 RETURN (EVALCAR (proc
, args
));
4976 if (!SCM_SMOB_APPLICABLE_P (proc
))
4978 if (SCM_UNBNDP (arg1
))
4979 RETURN (SCM_SMOB_APPLY_0 (proc
));
4980 else if (SCM_NULLP (args
))
4981 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
4982 else if (SCM_NULLP (SCM_CDR (args
)))
4983 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
4985 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4988 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4990 proc
= SCM_CCLO_SUBR (proc
);
4991 debug
.vect
[0].a
.proc
= proc
;
4992 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4994 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4996 proc
= SCM_CCLO_SUBR (proc
);
5000 proc
= SCM_PROCEDURE (proc
);
5002 debug
.vect
[0].a
.proc
= proc
;
5005 case scm_tcs_struct
:
5006 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5009 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
5011 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
5013 RETURN (scm_apply_generic (proc
, args
));
5015 else if (SCM_I_OPERATORP (proc
))
5019 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
5021 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
5024 proc
= (SCM_I_ENTITYP (proc
)
5025 ? SCM_ENTITY_PROCEDURE (proc
)
5026 : SCM_OPERATOR_PROCEDURE (proc
));
5028 debug
.vect
[0].a
.proc
= proc
;
5029 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
5031 if (SCM_NIMP (proc
))
5040 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
5044 if (scm_check_exit_p
&& SCM_TRAPS_P
)
5045 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
5047 SCM_CLEAR_TRACED_FRAME (debug
);
5048 if (SCM_CHEAPTRAPS_P
)
5049 arg1
= scm_make_debugobj (&debug
);
5053 SCM val
= scm_make_continuation (&first
);
5064 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
5068 scm_last_debug_frame
= debug
.prev
;
5074 /* SECTION: The rest of this file is only read once.
5081 * Trampolines make it possible to move procedure application dispatch
5082 * outside inner loops. The motivation was clean implementation of
5083 * efficient replacements of R5RS primitives in SRFI-1.
5085 * The semantics is clear: scm_trampoline_N returns an optimized
5086 * version of scm_call_N (or NULL if the procedure isn't applicable
5089 * Applying the optimization to map and for-each increased efficiency
5090 * noticeably. For example, (map abs ls) is now 8 times faster than
5095 call_subr0_0 (SCM proc
)
5097 return SCM_SUBRF (proc
) ();
5101 call_subr1o_0 (SCM proc
)
5103 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
5107 call_lsubr_0 (SCM proc
)
5109 return SCM_SUBRF (proc
) (SCM_EOL
);
5113 scm_i_call_closure_0 (SCM proc
)
5115 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
5118 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
5123 scm_trampoline_0 (SCM proc
)
5125 scm_t_trampoline_0 trampoline
;
5130 switch (SCM_TYP7 (proc
))
5132 case scm_tc7_subr_0
:
5133 trampoline
= call_subr0_0
;
5135 case scm_tc7_subr_1o
:
5136 trampoline
= call_subr1o_0
;
5139 trampoline
= call_lsubr_0
;
5141 case scm_tcs_closures
:
5143 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5144 if (SCM_NULLP (formals
) || !SCM_CONSP (formals
))
5145 trampoline
= scm_i_call_closure_0
;
5150 case scm_tcs_struct
:
5151 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5152 trampoline
= scm_call_generic_0
;
5153 else if (SCM_I_OPERATORP (proc
))
5154 trampoline
= scm_call_0
;
5159 if (SCM_SMOB_APPLICABLE_P (proc
))
5160 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
5165 case scm_tc7_rpsubr
:
5168 trampoline
= scm_call_0
;
5171 return NULL
; /* not applicable on zero arguments */
5173 /* We only reach this point if a valid trampoline was determined. */
5175 /* If debugging is enabled, we want to see all calls to proc on the stack.
5176 * Thus, we replace the trampoline shortcut with scm_call_0. */
5177 if (scm_debug_mode_p
)
5184 call_subr1_1 (SCM proc
, SCM arg1
)
5186 return SCM_SUBRF (proc
) (arg1
);
5190 call_subr2o_1 (SCM proc
, SCM arg1
)
5192 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
5196 call_lsubr_1 (SCM proc
, SCM arg1
)
5198 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
5202 call_dsubr_1 (SCM proc
, SCM arg1
)
5204 if (SCM_I_INUMP (arg1
))
5206 RETURN (scm_from_double (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
))));
5208 else if (SCM_REALP (arg1
))
5210 RETURN (scm_from_double (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
5212 else if (SCM_BIGP (arg1
))
5214 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
5216 else if (SCM_FRACTIONP (arg1
))
5218 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
5220 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
5221 SCM_ARG1
, scm_i_symbol_chars (SCM_SNAME (proc
)));
5225 call_cxr_1 (SCM proc
, SCM arg1
)
5227 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
5230 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
5231 scm_i_symbol_chars (SCM_SNAME (proc
)));
5232 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
5239 call_closure_1 (SCM proc
, SCM arg1
)
5241 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
5244 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
5249 scm_trampoline_1 (SCM proc
)
5251 scm_t_trampoline_1 trampoline
;
5256 switch (SCM_TYP7 (proc
))
5258 case scm_tc7_subr_1
:
5259 case scm_tc7_subr_1o
:
5260 trampoline
= call_subr1_1
;
5262 case scm_tc7_subr_2o
:
5263 trampoline
= call_subr2o_1
;
5266 trampoline
= call_lsubr_1
;
5269 trampoline
= call_dsubr_1
;
5272 trampoline
= call_cxr_1
;
5274 case scm_tcs_closures
:
5276 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5277 if (!SCM_NULLP (formals
)
5278 && (!SCM_CONSP (formals
) || !SCM_CONSP (SCM_CDR (formals
))))
5279 trampoline
= call_closure_1
;
5284 case scm_tcs_struct
:
5285 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5286 trampoline
= scm_call_generic_1
;
5287 else if (SCM_I_OPERATORP (proc
))
5288 trampoline
= scm_call_1
;
5293 if (SCM_SMOB_APPLICABLE_P (proc
))
5294 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
5299 case scm_tc7_rpsubr
:
5302 trampoline
= scm_call_1
;
5305 return NULL
; /* not applicable on one arg */
5307 /* We only reach this point if a valid trampoline was determined. */
5309 /* If debugging is enabled, we want to see all calls to proc on the stack.
5310 * Thus, we replace the trampoline shortcut with scm_call_1. */
5311 if (scm_debug_mode_p
)
5318 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
5320 return SCM_SUBRF (proc
) (arg1
, arg2
);
5324 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
5326 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
5330 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
5332 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
5336 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
5338 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
5339 scm_list_2 (arg1
, arg2
),
5341 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
5346 scm_trampoline_2 (SCM proc
)
5348 scm_t_trampoline_2 trampoline
;
5353 switch (SCM_TYP7 (proc
))
5355 case scm_tc7_subr_2
:
5356 case scm_tc7_subr_2o
:
5357 case scm_tc7_rpsubr
:
5359 trampoline
= call_subr2_2
;
5361 case scm_tc7_lsubr_2
:
5362 trampoline
= call_lsubr2_2
;
5365 trampoline
= call_lsubr_2
;
5367 case scm_tcs_closures
:
5369 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5370 if (!SCM_NULLP (formals
)
5371 && (!SCM_CONSP (formals
)
5372 || (!SCM_NULLP (SCM_CDR (formals
))
5373 && (!SCM_CONSP (SCM_CDR (formals
))
5374 || !SCM_CONSP (SCM_CDDR (formals
))))))
5375 trampoline
= call_closure_2
;
5380 case scm_tcs_struct
:
5381 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5382 trampoline
= scm_call_generic_2
;
5383 else if (SCM_I_OPERATORP (proc
))
5384 trampoline
= scm_call_2
;
5389 if (SCM_SMOB_APPLICABLE_P (proc
))
5390 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
5396 trampoline
= scm_call_2
;
5399 return NULL
; /* not applicable on two args */
5401 /* We only reach this point if a valid trampoline was determined. */
5403 /* If debugging is enabled, we want to see all calls to proc on the stack.
5404 * Thus, we replace the trampoline shortcut with scm_call_2. */
5405 if (scm_debug_mode_p
)
5411 /* Typechecking for multi-argument MAP and FOR-EACH.
5413 Verify that each element of the vector ARGV, except for the first,
5414 is a proper list whose length is LEN. Attribute errors to WHO,
5415 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
5417 check_map_args (SCM argv
,
5424 SCM
const *ve
= SCM_VELTS (argv
);
5427 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
5429 long elt_len
= scm_ilength (ve
[i
]);
5434 scm_apply_generic (gf
, scm_cons (proc
, args
));
5436 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
5440 scm_out_of_range_pos (who
, ve
[i
], scm_from_long (i
+ 2));
5443 scm_remember_upto_here_1 (argv
);
5447 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
5449 /* Note: Currently, scm_map applies PROC to the argument list(s)
5450 sequentially, starting with the first element(s). This is used in
5451 evalext.c where the Scheme procedure `map-in-order', which guarantees
5452 sequential behaviour, is implemented using scm_map. If the
5453 behaviour changes, we need to update `map-in-order'.
5457 scm_map (SCM proc
, SCM arg1
, SCM args
)
5458 #define FUNC_NAME s_map
5463 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
5465 len
= scm_ilength (arg1
);
5466 SCM_GASSERTn (len
>= 0,
5467 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
5468 SCM_VALIDATE_REST_ARGUMENT (args
);
5469 if (SCM_NULLP (args
))
5471 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5472 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
5473 while (SCM_NIMP (arg1
))
5475 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
5476 pres
= SCM_CDRLOC (*pres
);
5477 arg1
= SCM_CDR (arg1
);
5481 if (SCM_NULLP (SCM_CDR (args
)))
5483 SCM arg2
= SCM_CAR (args
);
5484 int len2
= scm_ilength (arg2
);
5485 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5487 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
5488 SCM_GASSERTn (len2
>= 0,
5489 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
5491 SCM_OUT_OF_RANGE (3, arg2
);
5492 while (SCM_NIMP (arg1
))
5494 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
5495 pres
= SCM_CDRLOC (*pres
);
5496 arg1
= SCM_CDR (arg1
);
5497 arg2
= SCM_CDR (arg2
);
5501 arg1
= scm_cons (arg1
, args
);
5502 args
= scm_vector (arg1
);
5503 ve
= SCM_VELTS (args
);
5504 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
5508 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5510 if (SCM_IMP (ve
[i
]))
5512 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
5513 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
5515 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
5516 pres
= SCM_CDRLOC (*pres
);
5522 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
5525 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
5526 #define FUNC_NAME s_for_each
5528 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
5530 len
= scm_ilength (arg1
);
5531 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
5532 SCM_ARG2
, s_for_each
);
5533 SCM_VALIDATE_REST_ARGUMENT (args
);
5534 if (SCM_NULLP (args
))
5536 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5537 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
5538 while (SCM_NIMP (arg1
))
5540 call (proc
, SCM_CAR (arg1
));
5541 arg1
= SCM_CDR (arg1
);
5543 return SCM_UNSPECIFIED
;
5545 if (SCM_NULLP (SCM_CDR (args
)))
5547 SCM arg2
= SCM_CAR (args
);
5548 int len2
= scm_ilength (arg2
);
5549 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5550 SCM_GASSERTn (call
, g_for_each
,
5551 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
5552 SCM_GASSERTn (len2
>= 0, g_for_each
,
5553 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
5555 SCM_OUT_OF_RANGE (3, arg2
);
5556 while (SCM_NIMP (arg1
))
5558 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
5559 arg1
= SCM_CDR (arg1
);
5560 arg2
= SCM_CDR (arg2
);
5562 return SCM_UNSPECIFIED
;
5564 arg1
= scm_cons (arg1
, args
);
5565 args
= scm_vector (arg1
);
5566 ve
= SCM_VELTS (args
);
5567 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
5571 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5573 if (SCM_IMP (ve
[i
]))
5574 return SCM_UNSPECIFIED
;
5575 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
5576 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
5578 scm_apply (proc
, arg1
, SCM_EOL
);
5585 scm_closure (SCM code
, SCM env
)
5588 SCM closcar
= scm_cons (code
, SCM_EOL
);
5589 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
5590 scm_remember_upto_here (closcar
);
5595 scm_t_bits scm_tc16_promise
;
5598 scm_makprom (SCM code
)
5600 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
5602 scm_make_rec_mutex ());
5606 promise_free (SCM promise
)
5608 scm_rec_mutex_free (SCM_PROMISE_MUTEX (promise
));
5613 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
5615 int writingp
= SCM_WRITINGP (pstate
);
5616 scm_puts ("#<promise ", port
);
5617 SCM_SET_WRITINGP (pstate
, 1);
5618 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
5619 SCM_SET_WRITINGP (pstate
, writingp
);
5620 scm_putc ('>', port
);
5624 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
5626 "If the promise @var{x} has not been computed yet, compute and\n"
5627 "return @var{x}, otherwise just return the previously computed\n"
5629 #define FUNC_NAME s_scm_force
5631 SCM_VALIDATE_SMOB (1, promise
, promise
);
5632 scm_rec_mutex_lock (SCM_PROMISE_MUTEX (promise
));
5633 if (!SCM_PROMISE_COMPUTED_P (promise
))
5635 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
5636 if (!SCM_PROMISE_COMPUTED_P (promise
))
5638 SCM_SET_PROMISE_DATA (promise
, ans
);
5639 SCM_SET_PROMISE_COMPUTED (promise
);
5642 scm_rec_mutex_unlock (SCM_PROMISE_MUTEX (promise
));
5643 return SCM_PROMISE_DATA (promise
);
5648 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
5650 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
5651 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
5652 #define FUNC_NAME s_scm_promise_p
5654 return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
5659 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
5660 (SCM xorig
, SCM x
, SCM y
),
5661 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
5662 "Any source properties associated with @var{xorig} are also associated\n"
5663 "with the new pair.")
5664 #define FUNC_NAME s_scm_cons_source
5667 z
= scm_cons (x
, y
);
5668 /* Copy source properties possibly associated with xorig. */
5669 p
= scm_whash_lookup (scm_source_whash
, xorig
);
5670 if (scm_is_true (p
))
5671 scm_whash_insert (scm_source_whash
, z
, p
);
5677 /* The function scm_copy_tree is used to copy an expression tree to allow the
5678 * memoizer to modify the expression during memoization. scm_copy_tree
5679 * creates deep copies of pairs and vectors, but not of any other data types,
5680 * since only pairs and vectors will be parsed by the memoizer.
5682 * To avoid infinite recursion due to cyclic structures, the hare-and-tortoise
5683 * pattern is used to detect cycles. In fact, the pattern is used in two
5684 * dimensions, vertical (indicated in the code by the variable names 'hare'
5685 * and 'tortoise') and horizontal ('rabbit' and 'turtle'). In both
5686 * dimensions, the hare/rabbit will take two steps when the tortoise/turtle
5689 * The vertical dimension corresponds to recursive calls to function
5690 * copy_tree: This happens when descending into vector elements, into cars of
5691 * lists and into the cdr of an improper list. In this dimension, the
5692 * tortoise follows the hare by using the processor stack: Every stack frame
5693 * will hold an instance of struct t_trace. These instances are connected in
5694 * a way that represents the trace of the hare, which thus can be followed by
5695 * the tortoise. The tortoise will always point to struct t_trace instances
5696 * relating to SCM objects that have already been copied. Thus, a cycle is
5697 * detected if the tortoise and the hare point to the same object,
5699 * The horizontal dimension is within one execution of copy_tree, when the
5700 * function cdr's along the pairs of a list. This is the standard
5701 * hare-and-tortoise implementation, found several times in guile. */
5704 struct t_trace
*trace
; // These pointers form a trace along the stack.
5705 SCM obj
; // The object handled at the respective stack frame.
5710 struct t_trace
*const hare
,
5711 struct t_trace
*tortoise
,
5712 unsigned int tortoise_delay
)
5714 if (!SCM_CONSP (hare
->obj
) && !SCM_VECTORP (hare
->obj
))
5720 /* Prepare the trace along the stack. */
5721 struct t_trace new_hare
;
5722 hare
->trace
= &new_hare
;
5724 /* The tortoise will make its step after the delay has elapsed. Note
5725 * that in contrast to the typical hare-and-tortoise pattern, the step
5726 * of the tortoise happens before the hare takes its steps. This is, in
5727 * principle, no problem, except for the start of the algorithm: Then,
5728 * it has to be made sure that the hare actually gets its advantage of
5730 if (tortoise_delay
== 0)
5733 tortoise
= tortoise
->trace
;
5734 ASSERT_SYNTAX (!scm_is_eq (hare
->obj
, tortoise
->obj
),
5735 s_bad_expression
, hare
->obj
);
5742 if (SCM_VECTORP (hare
->obj
))
5744 const unsigned long int length
= SCM_VECTOR_LENGTH (hare
->obj
);
5745 const SCM new_vector
= scm_c_make_vector (length
, SCM_UNSPECIFIED
);
5747 /* Each vector element is copied by recursing into copy_tree, having
5748 * the tortoise follow the hare into the depths of the stack. */
5749 unsigned long int i
;
5750 for (i
= 0; i
< length
; ++i
)
5753 new_hare
.obj
= SCM_VECTOR_REF (hare
->obj
, i
);
5754 new_element
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5755 SCM_VECTOR_SET (new_vector
, i
, new_element
);
5760 else // SCM_CONSP (hare->obj)
5765 SCM rabbit
= hare
->obj
;
5766 SCM turtle
= hare
->obj
;
5770 /* The first pair of the list is treated specially, in order to
5771 * preserve a potential source code position. */
5772 result
= tail
= scm_cons_source (rabbit
, SCM_EOL
, SCM_EOL
);
5773 new_hare
.obj
= SCM_CAR (rabbit
);
5774 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5775 SCM_SETCAR (tail
, copy
);
5777 /* The remaining pairs of the list are copied by, horizontally,
5778 * having the turtle follow the rabbit, and, vertically, having the
5779 * tortoise follow the hare into the depths of the stack. */
5780 rabbit
= SCM_CDR (rabbit
);
5781 while (SCM_CONSP (rabbit
))
5783 new_hare
.obj
= SCM_CAR (rabbit
);
5784 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5785 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
5786 tail
= SCM_CDR (tail
);
5788 rabbit
= SCM_CDR (rabbit
);
5789 if (SCM_CONSP (rabbit
))
5791 new_hare
.obj
= SCM_CAR (rabbit
);
5792 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5793 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
5794 tail
= SCM_CDR (tail
);
5795 rabbit
= SCM_CDR (rabbit
);
5797 turtle
= SCM_CDR (turtle
);
5798 ASSERT_SYNTAX (!scm_is_eq (rabbit
, turtle
),
5799 s_bad_expression
, rabbit
);
5803 /* We have to recurse into copy_tree again for the last cdr, in
5804 * order to handle the situation that it holds a vector. */
5805 new_hare
.obj
= rabbit
;
5806 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5807 SCM_SETCDR (tail
, copy
);
5814 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
5816 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
5817 "the new data structure. @code{copy-tree} recurses down the\n"
5818 "contents of both pairs and vectors (since both cons cells and vector\n"
5819 "cells may point to arbitrary objects), and stops recursing when it hits\n"
5820 "any other object.")
5821 #define FUNC_NAME s_scm_copy_tree
5823 /* Prepare the trace along the stack. */
5824 struct t_trace trace
;
5827 /* In function copy_tree, if the tortoise makes its step, it will do this
5828 * before the hare has the chance to move. Thus, we have to make sure that
5829 * the very first step of the tortoise will not happen after the hare has
5830 * really made two steps. This is achieved by passing '2' as the initial
5831 * delay for the tortoise. NOTE: Since cycles are unlikely, giving the hare
5832 * a bigger advantage may improve performance slightly. */
5833 return copy_tree (&trace
, &trace
, 2);
5838 /* We have three levels of EVAL here:
5840 - scm_i_eval (exp, env)
5842 evaluates EXP in environment ENV. ENV is a lexical environment
5843 structure as used by the actual tree code evaluator. When ENV is
5844 a top-level environment, then changes to the current module are
5845 tracked by updating ENV so that it continues to be in sync with
5848 - scm_primitive_eval (exp)
5850 evaluates EXP in the top-level environment as determined by the
5851 current module. This is done by constructing a suitable
5852 environment and calling scm_i_eval. Thus, changes to the
5853 top-level module are tracked normally.
5855 - scm_eval (exp, mod)
5857 evaluates EXP while MOD is the current module. This is done by
5858 setting the current module to MOD, invoking scm_primitive_eval on
5859 EXP, and then restoring the current module to the value it had
5860 previously. That is, while EXP is evaluated, changes to the
5861 current module are tracked, but these changes do not persist when
5864 For each level of evals, there are two variants, distinguished by a
5865 _x suffix: the ordinary variant does not modify EXP while the _x
5866 variant can destructively modify EXP into something completely
5867 unintelligible. A Scheme data structure passed as EXP to one of the
5868 _x variants should not ever be used again for anything. So when in
5869 doubt, use the ordinary variant.
5874 scm_i_eval_x (SCM exp
, SCM env
)
5876 if (scm_is_symbol (exp
))
5877 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
5879 return SCM_I_XEVAL (exp
, env
);
5883 scm_i_eval (SCM exp
, SCM env
)
5885 exp
= scm_copy_tree (exp
);
5886 if (scm_is_symbol (exp
))
5887 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
5889 return SCM_I_XEVAL (exp
, env
);
5893 scm_primitive_eval_x (SCM exp
)
5896 SCM transformer
= scm_current_module_transformer ();
5897 if (SCM_NIMP (transformer
))
5898 exp
= scm_call_1 (transformer
, exp
);
5899 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5900 return scm_i_eval_x (exp
, env
);
5903 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
5905 "Evaluate @var{exp} in the top-level environment specified by\n"
5906 "the current module.")
5907 #define FUNC_NAME s_scm_primitive_eval
5910 SCM transformer
= scm_current_module_transformer ();
5911 if (scm_is_true (transformer
))
5912 exp
= scm_call_1 (transformer
, exp
);
5913 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5914 return scm_i_eval (exp
, env
);
5919 /* Eval does not take the second arg optionally. This is intentional
5920 * in order to be R5RS compatible, and to prepare for the new module
5921 * system, where we would like to make the choice of evaluation
5922 * environment explicit. */
5925 change_environment (void *data
)
5927 SCM pair
= SCM_PACK (data
);
5928 SCM new_module
= SCM_CAR (pair
);
5929 SCM old_module
= scm_current_module ();
5930 SCM_SETCDR (pair
, old_module
);
5931 scm_set_current_module (new_module
);
5935 restore_environment (void *data
)
5937 SCM pair
= SCM_PACK (data
);
5938 SCM old_module
= SCM_CDR (pair
);
5939 SCM new_module
= scm_current_module ();
5940 SCM_SETCAR (pair
, new_module
);
5941 scm_set_current_module (old_module
);
5945 inner_eval_x (void *data
)
5947 return scm_primitive_eval_x (SCM_PACK(data
));
5951 scm_eval_x (SCM exp
, SCM module
)
5952 #define FUNC_NAME "eval!"
5954 SCM_VALIDATE_MODULE (2, module
);
5956 return scm_internal_dynamic_wind
5957 (change_environment
, inner_eval_x
, restore_environment
,
5958 (void *) SCM_UNPACK (exp
),
5959 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
5964 inner_eval (void *data
)
5966 return scm_primitive_eval (SCM_PACK(data
));
5969 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
5970 (SCM exp
, SCM module
),
5971 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
5972 "in the top-level environment specified by @var{module}.\n"
5973 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
5974 "@var{module} is made the current module. The current module\n"
5975 "is reset to its previous value when @var{eval} returns.")
5976 #define FUNC_NAME s_scm_eval
5978 SCM_VALIDATE_MODULE (2, module
);
5980 return scm_internal_dynamic_wind
5981 (change_environment
, inner_eval
, restore_environment
,
5982 (void *) SCM_UNPACK (exp
),
5983 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
5988 /* At this point, deval and scm_dapply are generated.
5995 #if (SCM_ENABLE_DEPRECATED == 1)
5997 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5998 SCM
scm_ceval (SCM x
, SCM env
)
6001 return ceval (x
, env
);
6002 else if (scm_is_symbol (x
))
6003 return *scm_lookupcar (scm_cons (x
, SCM_UNDEFINED
), env
, 1);
6005 return SCM_I_XEVAL (x
, env
);
6008 /* Deprecated in guile 1.7.0 on 2004-03-29. */
6009 SCM
scm_deval (SCM x
, SCM env
)
6012 return deval (x
, env
);
6013 else if (scm_is_symbol (x
))
6014 return *scm_lookupcar (scm_cons (x
, SCM_UNDEFINED
), env
, 1);
6016 return SCM_I_XEVAL (x
, env
);
6020 dispatching_eval (SCM x
, SCM env
)
6022 if (scm_debug_mode_p
)
6023 return scm_deval (x
, env
);
6025 return scm_ceval (x
, env
);
6028 /* Deprecated in guile 1.7.0 on 2004-03-29. */
6029 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
) = dispatching_eval
;
6037 scm_init_opts (scm_evaluator_traps
,
6038 scm_evaluator_trap_table
,
6039 SCM_N_EVALUATOR_TRAPS
);
6040 scm_init_opts (scm_eval_options_interface
,
6042 SCM_N_EVAL_OPTIONS
);
6044 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
6045 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
6046 scm_set_smob_free (scm_tc16_promise
, promise_free
);
6047 scm_set_smob_print (scm_tc16_promise
, promise_print
);
6049 undefineds
= scm_list_1 (SCM_UNDEFINED
);
6050 SCM_SETCDR (undefineds
, undefineds
);
6051 scm_permanent_object (undefineds
);
6053 scm_listofnull
= scm_list_1 (SCM_EOL
);
6055 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
6056 scm_permanent_object (f_apply
);
6058 #include "libguile/eval.x"
6060 scm_add_feature ("delay");