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, lists of expressions that stem from
590 * a body form may start with an ISYM if the body itself has not yet been
591 * memoized. This isym is just an internal marker to indicate that the body
592 * still needs to be memoized. It is dropped during unmemoization. */
593 if (SCM_CONSP (expr_idx
) && SCM_ISYMP (SCM_CAR (expr_idx
)))
594 expr_idx
= SCM_CDR (expr_idx
);
596 /* Moreover, in partially memoized code we have to expect improper lists of
597 * expressions: On the one hand, for such code syntax checks have not yet
598 * fully been performed, on the other hand, there may be even legal code
599 * like '(a . b) appear as an improper list of expressions as long as the
600 * quote expression is still in its unmemoized form. For this reason, the
601 * following code handles improper lists of expressions until memoization
602 * and execution have been completely separated. */
603 for (; SCM_CONSP (expr_idx
); expr_idx
= SCM_CDR (expr_idx
))
605 const SCM expr
= SCM_CAR (expr_idx
);
606 um_expr
= unmemoize_expression (expr
, env
);
607 r_result
= scm_cons (um_expr
, r_result
);
609 um_expr
= unmemoize_expression (expr_idx
, env
);
610 if (!SCM_NULLP (r_result
))
612 const SCM result
= scm_reverse_x (r_result
, SCM_UNDEFINED
);
613 SCM_SETCDR (r_result
, um_expr
);
623 /* Rewrite the body (which is given as the list of expressions forming the
624 * body) into its internal form. The internal form of a body (<expr> ...) is
625 * just the body itself, but prefixed with an ISYM that denotes to what kind
626 * of outer construct this body belongs: (<ISYM> <expr> ...). A lambda body
627 * starts with SCM_IM_LAMBDA, for example, a body of a let starts with
630 * It is assumed that the calling expression has already made sure that the
631 * body is a proper list. */
633 m_body (SCM op
, SCM exprs
)
635 /* Don't add another ISYM if one is present already. */
636 if (SCM_ISYMP (SCM_CAR (exprs
)))
639 return scm_cons (op
, exprs
);
643 /* The function m_expand_body memoizes a proper list of expressions forming a
644 * body. This function takes care of dealing with internal defines and
645 * transforming them into an equivalent letrec expression. The list of
646 * expressions is rewritten in place. */
648 /* This is a helper function for m_expand_body. If the argument expression is
649 * a symbol that denotes a syntactic keyword, the corresponding macro object
650 * is returned, in all other cases the function returns SCM_UNDEFINED. */
652 try_macro_lookup (const SCM expr
, const SCM env
)
654 if (scm_is_symbol (expr
))
656 const SCM variable
= lookup_symbol (expr
, env
);
657 if (SCM_VARIABLEP (variable
))
659 const SCM value
= SCM_VARIABLE_REF (variable
);
660 if (SCM_MACROP (value
))
665 return SCM_UNDEFINED
;
668 /* This is a helper function for m_expand_body. It expands user macros,
669 * because for the correct translation of a body we need to know whether they
670 * expand to a definition. */
672 expand_user_macros (SCM expr
, const SCM env
)
674 while (SCM_CONSP (expr
))
676 const SCM car_expr
= SCM_CAR (expr
);
677 const SCM new_car
= expand_user_macros (car_expr
, env
);
678 const SCM value
= try_macro_lookup (new_car
, env
);
680 if (SCM_MACROP (value
) && SCM_MACRO_TYPE (value
) == 2)
682 /* User macros transform code into code. */
683 expr
= scm_call_2 (SCM_MACRO_CODE (value
), expr
, env
);
684 /* We need to reiterate on the transformed code. */
688 /* No user macro: return. */
689 SCM_SETCAR (expr
, new_car
);
697 /* This is a helper function for m_expand_body. It determines if a given form
698 * represents an application of a given built-in macro. The built-in macro to
699 * check for is identified by its syntactic keyword. The form is an
700 * application of the given macro if looking up the car of the form in the
701 * given environment actually returns the built-in macro. */
703 is_system_macro_p (const SCM syntactic_keyword
, const SCM form
, const SCM env
)
705 if (SCM_CONSP (form
))
707 const SCM car_form
= SCM_CAR (form
);
708 const SCM value
= try_macro_lookup (car_form
, env
);
709 if (SCM_BUILTIN_MACRO_P (value
))
711 const SCM macro_name
= scm_macro_name (value
);
712 return scm_is_eq (macro_name
, syntactic_keyword
);
720 m_expand_body (const SCM forms
, const SCM env
)
722 /* The first body form can be skipped since it is known to be the ISYM that
723 * was prepended to the body by m_body. */
724 SCM cdr_forms
= SCM_CDR (forms
);
725 SCM form_idx
= cdr_forms
;
726 SCM definitions
= SCM_EOL
;
727 SCM sequence
= SCM_EOL
;
729 /* According to R5RS, the list of body forms consists of two parts: a number
730 * (maybe zero) of definitions, followed by a non-empty sequence of
731 * expressions. Each the definitions and the expressions may be grouped
732 * arbitrarily with begin, but it is not allowed to mix definitions and
733 * expressions. The task of the following loop therefore is to split the
734 * list of body forms into the list of definitions and the sequence of
736 while (!SCM_NULLP (form_idx
))
738 const SCM form
= SCM_CAR (form_idx
);
739 const SCM new_form
= expand_user_macros (form
, env
);
740 if (is_system_macro_p (scm_sym_define
, new_form
, env
))
742 definitions
= scm_cons (new_form
, definitions
);
743 form_idx
= SCM_CDR (form_idx
);
745 else if (is_system_macro_p (scm_sym_begin
, new_form
, env
))
747 /* We have encountered a group of forms. This has to be either a
748 * (possibly empty) group of (possibly further grouped) definitions,
749 * or a non-empty group of (possibly further grouped)
751 const SCM grouped_forms
= SCM_CDR (new_form
);
752 unsigned int found_definition
= 0;
753 unsigned int found_expression
= 0;
754 SCM grouped_form_idx
= grouped_forms
;
755 while (!found_expression
&& !SCM_NULLP (grouped_form_idx
))
757 const SCM inner_form
= SCM_CAR (grouped_form_idx
);
758 const SCM new_inner_form
= expand_user_macros (inner_form
, env
);
759 if (is_system_macro_p (scm_sym_define
, new_inner_form
, env
))
761 found_definition
= 1;
762 definitions
= scm_cons (new_inner_form
, definitions
);
763 grouped_form_idx
= SCM_CDR (grouped_form_idx
);
765 else if (is_system_macro_p (scm_sym_begin
, new_inner_form
, env
))
767 const SCM inner_group
= SCM_CDR (new_inner_form
);
769 = scm_append (scm_list_2 (inner_group
,
770 SCM_CDR (grouped_form_idx
)));
774 /* The group marks the start of the expressions of the body.
775 * We have to make sure that within the same group we have
776 * not encountered a definition before. */
777 ASSERT_SYNTAX (!found_definition
, s_mixed_body_forms
, form
);
778 found_expression
= 1;
779 grouped_form_idx
= SCM_EOL
;
783 /* We have finished processing the group. If we have not yet
784 * encountered an expression we continue processing the forms of the
785 * body to collect further definition forms. Otherwise, the group
786 * marks the start of the sequence of expressions of the body. */
787 if (!found_expression
)
789 form_idx
= SCM_CDR (form_idx
);
799 /* We have detected a form which is no definition. This marks the
800 * start of the sequence of expressions of the body. */
806 /* FIXME: forms does not hold information about the file location. */
807 ASSERT_SYNTAX (SCM_CONSP (sequence
), s_missing_body_expression
, cdr_forms
);
809 if (!SCM_NULLP (definitions
))
813 SCM letrec_expression
;
814 SCM new_letrec_expression
;
816 SCM bindings
= SCM_EOL
;
817 for (definition_idx
= definitions
;
818 !SCM_NULLP (definition_idx
);
819 definition_idx
= SCM_CDR (definition_idx
))
821 const SCM definition
= SCM_CAR (definition_idx
);
822 const SCM canonical_definition
= canonicalize_define (definition
);
823 const SCM binding
= SCM_CDR (canonical_definition
);
824 bindings
= scm_cons (binding
, bindings
);
827 letrec_tail
= scm_cons (bindings
, sequence
);
828 /* FIXME: forms does not hold information about the file location. */
829 letrec_expression
= scm_cons_source (forms
, scm_sym_letrec
, letrec_tail
);
830 new_letrec_expression
= scm_m_letrec (letrec_expression
, env
);
831 SCM_SETCAR (forms
, new_letrec_expression
);
832 SCM_SETCDR (forms
, SCM_EOL
);
836 SCM_SETCAR (forms
, SCM_CAR (sequence
));
837 SCM_SETCDR (forms
, SCM_CDR (sequence
));
842 macroexp (SCM x
, SCM env
)
844 SCM res
, proc
, orig_sym
;
846 /* Don't bother to produce error messages here. We get them when we
847 eventually execute the code for real. */
850 orig_sym
= SCM_CAR (x
);
851 if (!scm_is_symbol (orig_sym
))
855 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
856 if (proc_ptr
== NULL
)
858 /* We have lost the race. */
864 /* Only handle memoizing macros. `Acros' and `macros' are really
865 special forms and should not be evaluated here. */
867 if (!SCM_MACROP (proc
)
868 || (SCM_MACRO_TYPE (proc
) != 2 && !SCM_BUILTIN_MACRO_P (proc
)))
871 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
872 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
874 if (scm_ilength (res
) <= 0)
875 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
878 SCM_SETCAR (x
, SCM_CAR (res
));
879 SCM_SETCDR (x
, SCM_CDR (res
));
885 /* Start of the memoizers for the standard R5RS builtin macros. */
888 SCM_SYNTAX (s_and
, "and", scm_i_makbimacro
, scm_m_and
);
889 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
892 scm_m_and (SCM expr
, SCM env SCM_UNUSED
)
894 const SCM cdr_expr
= SCM_CDR (expr
);
895 const long length
= scm_ilength (cdr_expr
);
897 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
901 /* Special case: (and) is replaced by #t. */
906 SCM_SETCAR (expr
, SCM_IM_AND
);
912 unmemoize_and (const SCM expr
, const SCM env
)
914 return scm_cons (scm_sym_and
, unmemoize_exprs (SCM_CDR (expr
), env
));
918 SCM_SYNTAX (s_begin
, "begin", scm_i_makbimacro
, scm_m_begin
);
919 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
922 scm_m_begin (SCM expr
, SCM env SCM_UNUSED
)
924 const SCM cdr_expr
= SCM_CDR (expr
);
925 /* Dirk:FIXME:: An empty begin clause is not generally allowed by R5RS.
926 * That means, there should be a distinction between uses of begin where an
927 * empty clause is OK and where it is not. */
928 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
930 SCM_SETCAR (expr
, SCM_IM_BEGIN
);
935 unmemoize_begin (const SCM expr
, const SCM env
)
937 return scm_cons (scm_sym_begin
, unmemoize_exprs (SCM_CDR (expr
), env
));
941 SCM_SYNTAX (s_case
, "case", scm_i_makbimacro
, scm_m_case
);
942 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
943 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
946 scm_m_case (SCM expr
, SCM env
)
949 SCM all_labels
= SCM_EOL
;
951 /* Check, whether 'else is a literal, i. e. not bound to a value. */
952 const int else_literal_p
= literal_p (scm_sym_else
, env
);
954 const SCM cdr_expr
= SCM_CDR (expr
);
955 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
956 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_clauses
, expr
);
958 clauses
= SCM_CDR (cdr_expr
);
959 while (!SCM_NULLP (clauses
))
963 const SCM clause
= SCM_CAR (clauses
);
964 ASSERT_SYNTAX_2 (scm_ilength (clause
) >= 2,
965 s_bad_case_clause
, clause
, expr
);
967 labels
= SCM_CAR (clause
);
968 if (SCM_CONSP (labels
))
970 ASSERT_SYNTAX_2 (scm_ilength (labels
) >= 0,
971 s_bad_case_labels
, labels
, expr
);
972 all_labels
= scm_append (scm_list_2 (labels
, all_labels
));
974 else if (SCM_NULLP (labels
))
976 /* The list of labels is empty. According to R5RS this is allowed.
977 * It means that the sequence of expressions will never be executed.
978 * Therefore, as an optimization, we could remove the whole
983 ASSERT_SYNTAX_2 (scm_is_eq (labels
, scm_sym_else
) && else_literal_p
,
984 s_bad_case_labels
, labels
, expr
);
985 ASSERT_SYNTAX_2 (SCM_NULLP (SCM_CDR (clauses
)),
986 s_misplaced_else_clause
, clause
, expr
);
989 /* build the new clause */
990 if (scm_is_eq (labels
, scm_sym_else
))
991 SCM_SETCAR (clause
, SCM_IM_ELSE
);
993 clauses
= SCM_CDR (clauses
);
996 /* Check whether all case labels are distinct. */
997 for (; !SCM_NULLP (all_labels
); all_labels
= SCM_CDR (all_labels
))
999 const SCM label
= SCM_CAR (all_labels
);
1000 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (label
, SCM_CDR (all_labels
))),
1001 s_duplicate_case_label
, label
, expr
);
1004 SCM_SETCAR (expr
, SCM_IM_CASE
);
1009 unmemoize_case (const SCM expr
, const SCM env
)
1011 const SCM um_key_expr
= unmemoize_expression (SCM_CADR (expr
), env
);
1012 SCM um_clauses
= SCM_EOL
;
1015 for (clause_idx
= SCM_CDDR (expr
);
1016 !SCM_NULLP (clause_idx
);
1017 clause_idx
= SCM_CDR (clause_idx
))
1019 const SCM clause
= SCM_CAR (clause_idx
);
1020 const SCM labels
= SCM_CAR (clause
);
1021 const SCM exprs
= SCM_CDR (clause
);
1023 const SCM um_exprs
= unmemoize_exprs (exprs
, env
);
1024 const SCM um_labels
= (scm_is_eq (labels
, SCM_IM_ELSE
))
1026 : scm_i_finite_list_copy (labels
);
1027 const SCM um_clause
= scm_cons (um_labels
, um_exprs
);
1029 um_clauses
= scm_cons (um_clause
, um_clauses
);
1031 um_clauses
= scm_reverse_x (um_clauses
, SCM_UNDEFINED
);
1033 return scm_cons2 (scm_sym_case
, um_key_expr
, um_clauses
);
1037 SCM_SYNTAX (s_cond
, "cond", scm_i_makbimacro
, scm_m_cond
);
1038 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
1039 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
1042 scm_m_cond (SCM expr
, SCM env
)
1044 /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
1045 const int else_literal_p
= literal_p (scm_sym_else
, env
);
1046 const int arrow_literal_p
= literal_p (scm_sym_arrow
, env
);
1048 const SCM clauses
= SCM_CDR (expr
);
1051 ASSERT_SYNTAX (scm_ilength (clauses
) >= 0, s_bad_expression
, expr
);
1052 ASSERT_SYNTAX (scm_ilength (clauses
) >= 1, s_missing_clauses
, expr
);
1054 for (clause_idx
= clauses
;
1055 !SCM_NULLP (clause_idx
);
1056 clause_idx
= SCM_CDR (clause_idx
))
1060 const SCM clause
= SCM_CAR (clause_idx
);
1061 const long length
= scm_ilength (clause
);
1062 ASSERT_SYNTAX_2 (length
>= 1, s_bad_cond_clause
, clause
, expr
);
1064 test
= SCM_CAR (clause
);
1065 if (scm_is_eq (test
, scm_sym_else
) && else_literal_p
)
1067 const int last_clause_p
= SCM_NULLP (SCM_CDR (clause_idx
));
1068 ASSERT_SYNTAX_2 (length
>= 2,
1069 s_bad_cond_clause
, clause
, expr
);
1070 ASSERT_SYNTAX_2 (last_clause_p
,
1071 s_misplaced_else_clause
, clause
, expr
);
1072 SCM_SETCAR (clause
, SCM_IM_ELSE
);
1074 else if (length
>= 2
1075 && scm_is_eq (SCM_CADR (clause
), scm_sym_arrow
)
1078 ASSERT_SYNTAX_2 (length
> 2, s_missing_recipient
, clause
, expr
);
1079 ASSERT_SYNTAX_2 (length
== 3, s_extra_expression
, clause
, expr
);
1080 SCM_SETCAR (SCM_CDR (clause
), SCM_IM_ARROW
);
1084 SCM_SETCAR (expr
, SCM_IM_COND
);
1089 unmemoize_cond (const SCM expr
, const SCM env
)
1091 SCM um_clauses
= SCM_EOL
;
1094 for (clause_idx
= SCM_CDR (expr
);
1095 !SCM_NULLP (clause_idx
);
1096 clause_idx
= SCM_CDR (clause_idx
))
1098 const SCM clause
= SCM_CAR (clause_idx
);
1099 const SCM sequence
= SCM_CDR (clause
);
1100 const SCM test
= SCM_CAR (clause
);
1105 if (scm_is_eq (test
, SCM_IM_ELSE
))
1106 um_test
= scm_sym_else
;
1108 um_test
= unmemoize_expression (test
, env
);
1110 if (!SCM_NULLP (sequence
) && scm_is_eq (SCM_CAR (sequence
),
1113 const SCM target
= SCM_CADR (sequence
);
1114 const SCM um_target
= unmemoize_expression (target
, env
);
1115 um_sequence
= scm_list_2 (scm_sym_arrow
, um_target
);
1119 um_sequence
= unmemoize_exprs (sequence
, env
);
1122 um_clause
= scm_cons (um_test
, um_sequence
);
1123 um_clauses
= scm_cons (um_clause
, um_clauses
);
1125 um_clauses
= scm_reverse_x (um_clauses
, SCM_UNDEFINED
);
1127 return scm_cons (scm_sym_cond
, um_clauses
);
1131 SCM_SYNTAX (s_define
, "define", scm_i_makbimacro
, scm_m_define
);
1132 SCM_GLOBAL_SYMBOL (scm_sym_define
, s_define
);
1134 /* Guile provides an extension to R5RS' define syntax to represent function
1135 * currying in a compact way. With this extension, it is allowed to write
1136 * (define <nested-variable> <body>), where <nested-variable> has of one of
1137 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
1138 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
1139 * should be either a sequence of zero or more variables, or a sequence of one
1140 * or more variables followed by a space-delimited period and another
1141 * variable. Each level of argument nesting wraps the <body> within another
1142 * lambda expression. For example, the following forms are allowed, each one
1143 * followed by an equivalent, more explicit implementation.
1145 * (define ((a b . c) . d) <body>) is equivalent to
1146 * (define a (lambda (b . c) (lambda d <body>)))
1148 * (define (((a) b) c . d) <body>) is equivalent to
1149 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
1151 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
1152 * module that does not implement this extension. */
1154 canonicalize_define (const SCM expr
)
1159 const SCM cdr_expr
= SCM_CDR (expr
);
1160 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1161 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1163 body
= SCM_CDR (cdr_expr
);
1164 variable
= SCM_CAR (cdr_expr
);
1165 while (SCM_CONSP (variable
))
1167 /* This while loop realizes function currying by variable nesting.
1168 * Variable is known to be a nested-variable. In every iteration of the
1169 * loop another level of lambda expression is created, starting with the
1170 * innermost one. Note that we don't check for duplicate formals here:
1171 * This will be done by the memoizer of the lambda expression. */
1172 const SCM formals
= SCM_CDR (variable
);
1173 const SCM tail
= scm_cons (formals
, body
);
1175 /* Add source properties to each new lambda expression: */
1176 const SCM lambda
= scm_cons_source (variable
, scm_sym_lambda
, tail
);
1178 body
= scm_list_1 (lambda
);
1179 variable
= SCM_CAR (variable
);
1181 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
1182 ASSERT_SYNTAX (scm_ilength (body
) == 1, s_expression
, expr
);
1184 SCM_SETCAR (cdr_expr
, variable
);
1185 SCM_SETCDR (cdr_expr
, body
);
1189 /* According to section 5.2.1 of R5RS we first have to make sure that the
1190 * variable is bound, and then perform the (set! variable expression)
1191 * operation. This means, that within the expression we may already assign
1192 * values to variable: (define foo (begin (set! foo 1) (+ foo 1))) */
1194 scm_m_define (SCM expr
, SCM env
)
1196 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), s_bad_define
, expr
);
1199 const SCM canonical_definition
= canonicalize_define (expr
);
1200 const SCM cdr_canonical_definition
= SCM_CDR (canonical_definition
);
1201 const SCM variable
= SCM_CAR (cdr_canonical_definition
);
1203 = scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_T
);
1204 const SCM value
= scm_eval_car (SCM_CDR (cdr_canonical_definition
), env
);
1206 if (SCM_REC_PROCNAMES_P
)
1209 while (SCM_MACROP (tmp
))
1210 tmp
= SCM_MACRO_CODE (tmp
);
1211 if (SCM_CLOSUREP (tmp
)
1212 /* Only the first definition determines the name. */
1213 && scm_is_false (scm_procedure_property (tmp
, scm_sym_name
)))
1214 scm_set_procedure_property_x (tmp
, scm_sym_name
, variable
);
1217 SCM_VARIABLE_SET (location
, value
);
1219 return SCM_UNSPECIFIED
;
1224 /* This is a helper function for forms (<keyword> <expression>) that are
1225 * transformed into (#@<keyword> '() <memoized_expression>) in order to allow
1226 * for easy creation of a thunk (i. e. a closure without arguments) using the
1227 * ('() <memoized_expression>) tail of the memoized form. */
1229 memoize_as_thunk_prototype (const SCM expr
, const SCM env SCM_UNUSED
)
1231 const SCM cdr_expr
= SCM_CDR (expr
);
1232 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1233 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1235 SCM_SETCDR (expr
, scm_cons (SCM_EOL
, cdr_expr
));
1241 SCM_SYNTAX (s_delay
, "delay", scm_i_makbimacro
, scm_m_delay
);
1242 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
1244 /* Promises are implemented as closures with an empty parameter list. Thus,
1245 * (delay <expression>) is transformed into (#@delay '() <expression>), where
1246 * the empty list represents the empty parameter list. This representation
1247 * allows for easy creation of the closure during evaluation. */
1249 scm_m_delay (SCM expr
, SCM env
)
1251 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1252 SCM_SETCAR (new_expr
, SCM_IM_DELAY
);
1257 unmemoize_delay (const SCM expr
, const SCM env
)
1259 const SCM thunk_expr
= SCM_CADDR (expr
);
1260 return scm_list_2 (scm_sym_delay
, unmemoize_expression (thunk_expr
, env
));
1264 SCM_SYNTAX(s_do
, "do", scm_i_makbimacro
, scm_m_do
);
1265 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
1267 /* DO gets the most radically altered syntax. The order of the vars is
1268 * reversed here. During the evaluation this allows for simple consing of the
1269 * results of the inits and steps:
1271 (do ((<var1> <init1> <step1>)
1279 (#@do (<init1> <init2> ... <initn>)
1280 (varn ... var2 var1)
1283 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
1286 scm_m_do (SCM expr
, SCM env SCM_UNUSED
)
1288 SCM variables
= SCM_EOL
;
1289 SCM init_forms
= SCM_EOL
;
1290 SCM step_forms
= SCM_EOL
;
1297 const SCM cdr_expr
= SCM_CDR (expr
);
1298 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1299 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1301 /* Collect variables, init and step forms. */
1302 binding_idx
= SCM_CAR (cdr_expr
);
1303 ASSERT_SYNTAX_2 (scm_ilength (binding_idx
) >= 0,
1304 s_bad_bindings
, binding_idx
, expr
);
1305 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1307 const SCM binding
= SCM_CAR (binding_idx
);
1308 const long length
= scm_ilength (binding
);
1309 ASSERT_SYNTAX_2 (length
== 2 || length
== 3,
1310 s_bad_binding
, binding
, expr
);
1313 const SCM name
= SCM_CAR (binding
);
1314 const SCM init
= SCM_CADR (binding
);
1315 const SCM step
= (length
== 2) ? name
: SCM_CADDR (binding
);
1316 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
1317 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, variables
)),
1318 s_duplicate_binding
, name
, expr
);
1320 variables
= scm_cons (name
, variables
);
1321 init_forms
= scm_cons (init
, init_forms
);
1322 step_forms
= scm_cons (step
, step_forms
);
1325 init_forms
= scm_reverse_x (init_forms
, SCM_UNDEFINED
);
1326 step_forms
= scm_reverse_x (step_forms
, SCM_UNDEFINED
);
1328 /* Memoize the test form and the exit sequence. */
1329 cddr_expr
= SCM_CDR (cdr_expr
);
1330 exit_clause
= SCM_CAR (cddr_expr
);
1331 ASSERT_SYNTAX_2 (scm_ilength (exit_clause
) >= 1,
1332 s_bad_exit_clause
, exit_clause
, expr
);
1334 commands
= SCM_CDR (cddr_expr
);
1335 tail
= scm_cons2 (exit_clause
, commands
, step_forms
);
1336 tail
= scm_cons2 (init_forms
, variables
, tail
);
1337 SCM_SETCAR (expr
, SCM_IM_DO
);
1338 SCM_SETCDR (expr
, tail
);
1343 unmemoize_do (const SCM expr
, const SCM env
)
1345 const SCM cdr_expr
= SCM_CDR (expr
);
1346 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1347 const SCM rnames
= SCM_CAR (cddr_expr
);
1348 const SCM extended_env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
1349 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
1350 const SCM exit_sequence
= SCM_CAR (cdddr_expr
);
1351 const SCM um_exit_sequence
= unmemoize_exprs (exit_sequence
, extended_env
);
1352 const SCM cddddr_expr
= SCM_CDR (cdddr_expr
);
1353 const SCM um_body
= unmemoize_exprs (SCM_CAR (cddddr_expr
), extended_env
);
1355 /* build transformed binding list */
1356 SCM um_names
= scm_reverse (rnames
);
1357 SCM um_inits
= unmemoize_exprs (SCM_CAR (cdr_expr
), env
);
1358 SCM um_steps
= unmemoize_exprs (SCM_CDR (cddddr_expr
), extended_env
);
1359 SCM um_bindings
= SCM_EOL
;
1360 while (!SCM_NULLP (um_names
))
1362 const SCM name
= SCM_CAR (um_names
);
1363 const SCM init
= SCM_CAR (um_inits
);
1364 SCM step
= SCM_CAR (um_steps
);
1365 step
= scm_is_eq (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
1367 um_bindings
= scm_cons (scm_cons2 (name
, init
, step
), um_bindings
);
1369 um_names
= SCM_CDR (um_names
);
1370 um_inits
= SCM_CDR (um_inits
);
1371 um_steps
= SCM_CDR (um_steps
);
1373 um_bindings
= scm_reverse_x (um_bindings
, SCM_UNDEFINED
);
1375 return scm_cons (scm_sym_do
,
1376 scm_cons2 (um_bindings
, um_exit_sequence
, um_body
));
1380 SCM_SYNTAX (s_if
, "if", scm_i_makbimacro
, scm_m_if
);
1381 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
1384 scm_m_if (SCM expr
, SCM env SCM_UNUSED
)
1386 const SCM cdr_expr
= SCM_CDR (expr
);
1387 const long length
= scm_ilength (cdr_expr
);
1388 ASSERT_SYNTAX (length
== 2 || length
== 3, s_expression
, expr
);
1389 SCM_SETCAR (expr
, SCM_IM_IF
);
1394 unmemoize_if (const SCM expr
, const SCM env
)
1396 const SCM cdr_expr
= SCM_CDR (expr
);
1397 const SCM um_condition
= unmemoize_expression (SCM_CAR (cdr_expr
), env
);
1398 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1399 const SCM um_then
= unmemoize_expression (SCM_CAR (cddr_expr
), env
);
1400 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
1402 if (SCM_NULLP (cdddr_expr
))
1404 return scm_list_3 (scm_sym_if
, um_condition
, um_then
);
1408 const SCM um_else
= unmemoize_expression (SCM_CAR (cdddr_expr
), env
);
1409 return scm_list_4 (scm_sym_if
, um_condition
, um_then
, um_else
);
1414 SCM_SYNTAX (s_lambda
, "lambda", scm_i_makbimacro
, scm_m_lambda
);
1415 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
1417 /* A helper function for memoize_lambda to support checking for duplicate
1418 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
1419 * LIST or to the cdr of the last cons. Therefore, LIST may have any of the
1420 * forms that a formal argument can have:
1421 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
1423 c_improper_memq (SCM obj
, SCM list
)
1425 for (; SCM_CONSP (list
); list
= SCM_CDR (list
))
1427 if (scm_is_eq (SCM_CAR (list
), obj
))
1430 return scm_is_eq (list
, obj
);
1434 scm_m_lambda (SCM expr
, SCM env SCM_UNUSED
)
1443 const SCM cdr_expr
= SCM_CDR (expr
);
1444 const long length
= scm_ilength (cdr_expr
);
1445 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1446 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1448 /* Before iterating the list of formal arguments, make sure the formals
1449 * actually are given as either a symbol or a non-cyclic list. */
1450 formals
= SCM_CAR (cdr_expr
);
1451 if (SCM_CONSP (formals
))
1453 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
1454 * detected, report a 'Bad formals' error. */
1458 ASSERT_SYNTAX_2 (scm_is_symbol (formals
) || SCM_NULLP (formals
),
1459 s_bad_formals
, formals
, expr
);
1462 /* Now iterate the list of formal arguments to check if all formals are
1463 * symbols, and that there are no duplicates. */
1464 formals_idx
= formals
;
1465 while (SCM_CONSP (formals_idx
))
1467 const SCM formal
= SCM_CAR (formals_idx
);
1468 const SCM next_idx
= SCM_CDR (formals_idx
);
1469 ASSERT_SYNTAX_2 (scm_is_symbol (formal
), s_bad_formal
, formal
, expr
);
1470 ASSERT_SYNTAX_2 (!c_improper_memq (formal
, next_idx
),
1471 s_duplicate_formal
, formal
, expr
);
1472 formals_idx
= next_idx
;
1474 ASSERT_SYNTAX_2 (SCM_NULLP (formals_idx
) || scm_is_symbol (formals_idx
),
1475 s_bad_formal
, formals_idx
, expr
);
1477 /* Memoize the body. Keep a potential documentation string. */
1478 /* Dirk:FIXME:: We should probably extract the documentation string to
1479 * some external database. Otherwise it will slow down execution, since
1480 * the documentation string will have to be skipped with every execution
1481 * of the closure. */
1482 cddr_expr
= SCM_CDR (cdr_expr
);
1483 documentation
= (length
>= 3 && scm_is_string (SCM_CAR (cddr_expr
)));
1484 body
= documentation
? SCM_CDR (cddr_expr
) : cddr_expr
;
1485 new_body
= m_body (SCM_IM_LAMBDA
, body
);
1487 SCM_SETCAR (expr
, SCM_IM_LAMBDA
);
1489 SCM_SETCDR (cddr_expr
, new_body
);
1491 SCM_SETCDR (cdr_expr
, new_body
);
1496 unmemoize_lambda (const SCM expr
, const SCM env
)
1498 const SCM formals
= SCM_CADR (expr
);
1499 const SCM body
= SCM_CDDR (expr
);
1501 const SCM new_env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, env
);
1502 const SCM um_formals
= scm_i_finite_list_copy (formals
);
1503 const SCM um_body
= unmemoize_exprs (body
, new_env
);
1505 return scm_cons2 (scm_sym_lambda
, um_formals
, um_body
);
1509 /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
1511 check_bindings (const SCM bindings
, const SCM expr
)
1515 ASSERT_SYNTAX_2 (scm_ilength (bindings
) >= 0,
1516 s_bad_bindings
, bindings
, expr
);
1518 binding_idx
= bindings
;
1519 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1521 SCM name
; /* const */
1523 const SCM binding
= SCM_CAR (binding_idx
);
1524 ASSERT_SYNTAX_2 (scm_ilength (binding
) == 2,
1525 s_bad_binding
, binding
, expr
);
1527 name
= SCM_CAR (binding
);
1528 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
1533 /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
1534 * transformed to the lists (vn ... v2 v1) and (i1 i2 ... in). That is, the
1535 * variables are returned in a list with their order reversed, and the init
1536 * forms are returned in a list in the same order as they are given in the
1537 * bindings. If a duplicate variable name is detected, an error is
1540 transform_bindings (
1541 const SCM bindings
, const SCM expr
,
1542 SCM
*const rvarptr
, SCM
*const initptr
)
1544 SCM rvariables
= SCM_EOL
;
1545 SCM rinits
= SCM_EOL
;
1546 SCM binding_idx
= bindings
;
1547 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1549 const SCM binding
= SCM_CAR (binding_idx
);
1550 const SCM cdr_binding
= SCM_CDR (binding
);
1551 const SCM name
= SCM_CAR (binding
);
1552 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, rvariables
)),
1553 s_duplicate_binding
, name
, expr
);
1554 rvariables
= scm_cons (name
, rvariables
);
1555 rinits
= scm_cons (SCM_CAR (cdr_binding
), rinits
);
1557 *rvarptr
= rvariables
;
1558 *initptr
= scm_reverse_x (rinits
, SCM_UNDEFINED
);
1562 SCM_SYNTAX(s_let
, "let", scm_i_makbimacro
, scm_m_let
);
1563 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
1565 /* This function is a helper function for memoize_let. It transforms
1566 * (let name ((var init) ...) body ...) into
1567 * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
1568 * and memoizes the expression. It is assumed that the caller has checked
1569 * that name is a symbol and that there are bindings and a body. */
1571 memoize_named_let (const SCM expr
, const SCM env SCM_UNUSED
)
1577 const SCM cdr_expr
= SCM_CDR (expr
);
1578 const SCM name
= SCM_CAR (cdr_expr
);
1579 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1580 const SCM bindings
= SCM_CAR (cddr_expr
);
1581 check_bindings (bindings
, expr
);
1583 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1584 variables
= scm_reverse_x (rvariables
, SCM_UNDEFINED
);
1587 const SCM let_body
= SCM_CDR (cddr_expr
);
1588 const SCM lambda_body
= m_body (SCM_IM_LET
, let_body
);
1589 const SCM lambda_tail
= scm_cons (variables
, lambda_body
);
1590 const SCM lambda_form
= scm_cons_source (expr
, scm_sym_lambda
, lambda_tail
);
1592 const SCM rvar
= scm_list_1 (name
);
1593 const SCM init
= scm_list_1 (lambda_form
);
1594 const SCM body
= m_body (SCM_IM_LET
, scm_list_1 (name
));
1595 const SCM letrec_tail
= scm_cons (rvar
, scm_cons (init
, body
));
1596 const SCM letrec_form
= scm_cons_source (expr
, SCM_IM_LETREC
, letrec_tail
);
1597 return scm_cons_source (expr
, letrec_form
, inits
);
1601 /* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1602 * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
1604 scm_m_let (SCM expr
, SCM env
)
1608 const SCM cdr_expr
= SCM_CDR (expr
);
1609 const long length
= scm_ilength (cdr_expr
);
1610 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1611 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1613 bindings
= SCM_CAR (cdr_expr
);
1614 if (scm_is_symbol (bindings
))
1616 ASSERT_SYNTAX (length
>= 3, s_missing_expression
, expr
);
1617 return memoize_named_let (expr
, env
);
1620 check_bindings (bindings
, expr
);
1621 if (SCM_NULLP (bindings
) || SCM_NULLP (SCM_CDR (bindings
)))
1623 /* Special case: no bindings or single binding => let* is faster. */
1624 const SCM body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1625 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), bindings
, body
), env
);
1632 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1635 const SCM new_body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1636 const SCM new_tail
= scm_cons2 (rvariables
, inits
, new_body
);
1637 SCM_SETCAR (expr
, SCM_IM_LET
);
1638 SCM_SETCDR (expr
, new_tail
);
1645 build_binding_list (SCM rnames
, SCM rinits
)
1647 SCM bindings
= SCM_EOL
;
1648 while (!SCM_NULLP (rnames
))
1650 const SCM binding
= scm_list_2 (SCM_CAR (rnames
), SCM_CAR (rinits
));
1651 bindings
= scm_cons (binding
, bindings
);
1652 rnames
= SCM_CDR (rnames
);
1653 rinits
= SCM_CDR (rinits
);
1659 unmemoize_let (const SCM expr
, const SCM env
)
1661 const SCM cdr_expr
= SCM_CDR (expr
);
1662 const SCM um_rnames
= SCM_CAR (cdr_expr
);
1663 const SCM extended_env
= SCM_EXTEND_ENV (um_rnames
, SCM_EOL
, env
);
1664 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1665 const SCM um_inits
= unmemoize_exprs (SCM_CAR (cddr_expr
), env
);
1666 const SCM um_rinits
= scm_reverse_x (um_inits
, SCM_UNDEFINED
);
1667 const SCM um_bindings
= build_binding_list (um_rnames
, um_rinits
);
1668 const SCM um_body
= unmemoize_exprs (SCM_CDR (cddr_expr
), extended_env
);
1670 return scm_cons2 (scm_sym_let
, um_bindings
, um_body
);
1674 SCM_SYNTAX(s_letrec
, "letrec", scm_i_makbimacro
, scm_m_letrec
);
1675 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
1678 scm_m_letrec (SCM expr
, SCM env
)
1682 const SCM cdr_expr
= SCM_CDR (expr
);
1683 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1684 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1686 bindings
= SCM_CAR (cdr_expr
);
1687 if (SCM_NULLP (bindings
))
1689 /* no bindings, let* is executed faster */
1690 SCM body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1691 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), SCM_EOL
, body
), env
);
1699 check_bindings (bindings
, expr
);
1700 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1701 new_body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1702 return scm_cons2 (SCM_IM_LETREC
, rvariables
, scm_cons (inits
, new_body
));
1707 unmemoize_letrec (const SCM expr
, const SCM env
)
1709 const SCM cdr_expr
= SCM_CDR (expr
);
1710 const SCM um_rnames
= SCM_CAR (cdr_expr
);
1711 const SCM extended_env
= SCM_EXTEND_ENV (um_rnames
, SCM_EOL
, env
);
1712 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1713 const SCM um_inits
= unmemoize_exprs (SCM_CAR (cddr_expr
), extended_env
);
1714 const SCM um_rinits
= scm_reverse_x (um_inits
, SCM_UNDEFINED
);
1715 const SCM um_bindings
= build_binding_list (um_rnames
, um_rinits
);
1716 const SCM um_body
= unmemoize_exprs (SCM_CDR (cddr_expr
), extended_env
);
1718 return scm_cons2 (scm_sym_letrec
, um_bindings
, um_body
);
1723 SCM_SYNTAX (s_letstar
, "let*", scm_i_makbimacro
, scm_m_letstar
);
1724 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
1726 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1727 * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
1729 scm_m_letstar (SCM expr
, SCM env SCM_UNUSED
)
1734 const SCM cdr_expr
= SCM_CDR (expr
);
1735 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1736 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1738 binding_idx
= SCM_CAR (cdr_expr
);
1739 check_bindings (binding_idx
, expr
);
1741 /* Transform ((v1 i1) (v2 i2) ...) into (v1 i1 v2 i2 ...). The
1742 * transformation is done in place. At the beginning of one iteration of
1743 * the loop the variable binding_idx holds the form
1744 * P1:( (vn . P2:(in . ())) . P3:( (vn+1 in+1) ... ) ),
1745 * where P1, P2 and P3 indicate the pairs, that are relevant for the
1746 * transformation. P1 and P2 are modified in the loop, P3 remains
1747 * untouched. After the execution of the loop, P1 will hold
1748 * P1:( vn . P2:(in . P3:( (vn+1 in+1) ... )) )
1749 * and binding_idx will hold P3. */
1750 while (!SCM_NULLP (binding_idx
))
1752 const SCM cdr_binding_idx
= SCM_CDR (binding_idx
); /* remember P3 */
1753 const SCM binding
= SCM_CAR (binding_idx
);
1754 const SCM name
= SCM_CAR (binding
);
1755 const SCM cdr_binding
= SCM_CDR (binding
);
1757 SCM_SETCDR (cdr_binding
, cdr_binding_idx
); /* update P2 */
1758 SCM_SETCAR (binding_idx
, name
); /* update P1 */
1759 SCM_SETCDR (binding_idx
, cdr_binding
); /* update P1 */
1761 binding_idx
= cdr_binding_idx
; /* continue with P3 */
1764 new_body
= m_body (SCM_IM_LETSTAR
, SCM_CDR (cdr_expr
));
1765 SCM_SETCAR (expr
, SCM_IM_LETSTAR
);
1766 /* the bindings have been changed in place */
1767 SCM_SETCDR (cdr_expr
, new_body
);
1772 unmemoize_letstar (const SCM expr
, const SCM env
)
1774 const SCM cdr_expr
= SCM_CDR (expr
);
1775 const SCM body
= SCM_CDR (cdr_expr
);
1776 SCM bindings
= SCM_CAR (cdr_expr
);
1777 SCM um_bindings
= SCM_EOL
;
1778 SCM extended_env
= env
;
1781 while (!SCM_NULLP (bindings
))
1783 const SCM variable
= SCM_CAR (bindings
);
1784 const SCM init
= SCM_CADR (bindings
);
1785 const SCM um_init
= unmemoize_expression (init
, extended_env
);
1786 um_bindings
= scm_cons (scm_list_2 (variable
, um_init
), um_bindings
);
1787 extended_env
= SCM_EXTEND_ENV (variable
, SCM_BOOL_F
, extended_env
);
1788 bindings
= SCM_CDDR (bindings
);
1790 um_bindings
= scm_reverse_x (um_bindings
, SCM_UNDEFINED
);
1792 um_body
= unmemoize_exprs (body
, extended_env
);
1794 return scm_cons2 (scm_sym_letstar
, um_bindings
, um_body
);
1798 SCM_SYNTAX (s_or
, "or", scm_i_makbimacro
, scm_m_or
);
1799 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
1802 scm_m_or (SCM expr
, SCM env SCM_UNUSED
)
1804 const SCM cdr_expr
= SCM_CDR (expr
);
1805 const long length
= scm_ilength (cdr_expr
);
1807 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1811 /* Special case: (or) is replaced by #f. */
1816 SCM_SETCAR (expr
, SCM_IM_OR
);
1822 unmemoize_or (const SCM expr
, const SCM env
)
1824 return scm_cons (scm_sym_or
, unmemoize_exprs (SCM_CDR (expr
), env
));
1828 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
1829 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
1830 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
1831 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
1833 /* Internal function to handle a quasiquotation: 'form' is the parameter in
1834 * the call (quasiquotation form), 'env' is the environment where unquoted
1835 * expressions will be evaluated, and 'depth' is the current quasiquotation
1836 * nesting level and is known to be greater than zero. */
1838 iqq (SCM form
, SCM env
, unsigned long int depth
)
1840 if (SCM_CONSP (form
))
1842 const SCM tmp
= SCM_CAR (form
);
1843 if (scm_is_eq (tmp
, scm_sym_quasiquote
))
1845 const SCM args
= SCM_CDR (form
);
1846 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1847 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
1849 else if (scm_is_eq (tmp
, scm_sym_unquote
))
1851 const SCM args
= SCM_CDR (form
);
1852 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1854 return scm_eval_car (args
, env
);
1856 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
1858 else if (SCM_CONSP (tmp
)
1859 && scm_is_eq (SCM_CAR (tmp
), scm_sym_uq_splicing
))
1861 const SCM args
= SCM_CDR (tmp
);
1862 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1865 const SCM list
= scm_eval_car (args
, env
);
1866 const SCM rest
= SCM_CDR (form
);
1867 ASSERT_SYNTAX_2 (scm_ilength (list
) >= 0,
1868 s_splicing
, list
, form
);
1869 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
1872 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
1873 iqq (SCM_CDR (form
), env
, depth
));
1876 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
1877 iqq (SCM_CDR (form
), env
, depth
));
1879 else if (SCM_VECTORP (form
))
1881 size_t i
= SCM_VECTOR_LENGTH (form
);
1882 SCM
const *const data
= SCM_VELTS (form
);
1885 tmp
= scm_cons (data
[--i
], tmp
);
1886 scm_remember_upto_here_1 (form
);
1887 return scm_vector (iqq (tmp
, env
, depth
));
1894 scm_m_quasiquote (SCM expr
, SCM env
)
1896 const SCM cdr_expr
= SCM_CDR (expr
);
1897 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1898 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1899 return iqq (SCM_CAR (cdr_expr
), env
, 1);
1903 SCM_SYNTAX (s_quote
, "quote", scm_i_makbimacro
, scm_m_quote
);
1904 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
1907 scm_m_quote (SCM expr
, SCM env SCM_UNUSED
)
1911 const SCM cdr_expr
= SCM_CDR (expr
);
1912 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1913 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1914 quotee
= SCM_CAR (cdr_expr
);
1915 if (is_self_quoting_p (quotee
))
1918 SCM_SETCAR (expr
, SCM_IM_QUOTE
);
1919 SCM_SETCDR (expr
, quotee
);
1924 unmemoize_quote (const SCM expr
, const SCM env SCM_UNUSED
)
1926 return scm_list_2 (scm_sym_quote
, SCM_CDR (expr
));
1930 /* Will go into the RnRS module when Guile is factorized.
1931 SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
1932 static const char s_set_x
[] = "set!";
1933 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, s_set_x
);
1936 scm_m_set_x (SCM expr
, SCM env SCM_UNUSED
)
1941 const SCM cdr_expr
= SCM_CDR (expr
);
1942 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1943 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1944 variable
= SCM_CAR (cdr_expr
);
1946 /* Memoize the variable form. */
1947 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
1948 new_variable
= lookup_symbol (variable
, env
);
1949 /* Leave the memoization of unbound symbols to lazy memoization: */
1950 if (SCM_UNBNDP (new_variable
))
1951 new_variable
= variable
;
1953 SCM_SETCAR (expr
, SCM_IM_SET_X
);
1954 SCM_SETCAR (cdr_expr
, new_variable
);
1959 unmemoize_set_x (const SCM expr
, const SCM env
)
1961 return scm_cons (scm_sym_set_x
, unmemoize_exprs (SCM_CDR (expr
), env
));
1965 /* Start of the memoizers for non-R5RS builtin macros. */
1968 SCM_SYNTAX (s_atapply
, "@apply", scm_i_makbimacro
, scm_m_apply
);
1969 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1970 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1973 scm_m_apply (SCM expr
, SCM env SCM_UNUSED
)
1975 const SCM cdr_expr
= SCM_CDR (expr
);
1976 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1977 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_missing_expression
, expr
);
1979 SCM_SETCAR (expr
, SCM_IM_APPLY
);
1984 unmemoize_apply (const SCM expr
, const SCM env
)
1986 return scm_list_2 (scm_sym_atapply
, unmemoize_exprs (SCM_CDR (expr
), env
));
1990 SCM_SYNTAX (s_atbind
, "@bind", scm_i_makbimacro
, scm_m_atbind
);
1992 /* FIXME: The following explanation should go into the documentation: */
1993 /* (@bind ((var init) ...) body ...) will assign the values of the `init's to
1994 * the global variables named by `var's (symbols, not evaluated), creating
1995 * them if they don't exist, executes body, and then restores the previous
1996 * values of the `var's. Additionally, whenever control leaves body, the
1997 * values of the `var's are saved and restored when control returns. It is an
1998 * error when a symbol appears more than once among the `var's. All `init's
1999 * are evaluated before any `var' is set.
2001 * Think of this as `let' for dynamic scope.
2004 /* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into
2005 * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...).
2007 * FIXME - also implement `@bind*'.
2010 scm_m_atbind (SCM expr
, SCM env
)
2017 const SCM top_level
= scm_env_top_level (env
);
2019 const SCM cdr_expr
= SCM_CDR (expr
);
2020 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2021 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
2022 bindings
= SCM_CAR (cdr_expr
);
2023 check_bindings (bindings
, expr
);
2024 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
2026 for (variable_idx
= rvariables
;
2027 !SCM_NULLP (variable_idx
);
2028 variable_idx
= SCM_CDR (variable_idx
))
2030 /* The first call to scm_sym2var will look beyond the current module,
2031 * while the second call wont. */
2032 const SCM variable
= SCM_CAR (variable_idx
);
2033 SCM new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_F
);
2034 if (scm_is_false (new_variable
))
2035 new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_T
);
2036 SCM_SETCAR (variable_idx
, new_variable
);
2039 SCM_SETCAR (expr
, SCM_IM_BIND
);
2040 SCM_SETCAR (cdr_expr
, scm_cons (rvariables
, inits
));
2045 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_i_makbimacro
, scm_m_cont
);
2046 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, s_atcall_cc
);
2049 scm_m_cont (SCM expr
, SCM env SCM_UNUSED
)
2051 const SCM cdr_expr
= SCM_CDR (expr
);
2052 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2053 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2055 SCM_SETCAR (expr
, SCM_IM_CONT
);
2060 unmemoize_atcall_cc (const SCM expr
, const SCM env
)
2062 return scm_list_2 (scm_sym_atcall_cc
, unmemoize_exprs (SCM_CDR (expr
), env
));
2066 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_i_makbimacro
, scm_m_at_call_with_values
);
2067 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
2070 scm_m_at_call_with_values (SCM expr
, SCM env SCM_UNUSED
)
2072 const SCM cdr_expr
= SCM_CDR (expr
);
2073 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2074 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2076 SCM_SETCAR (expr
, SCM_IM_CALL_WITH_VALUES
);
2081 unmemoize_at_call_with_values (const SCM expr
, const SCM env
)
2083 return scm_list_2 (scm_sym_at_call_with_values
,
2084 unmemoize_exprs (SCM_CDR (expr
), env
));
2088 SCM_SYNTAX (s_future
, "future", scm_i_makbimacro
, scm_m_future
);
2089 SCM_GLOBAL_SYMBOL (scm_sym_future
, s_future
);
2091 /* Like promises, futures are implemented as closures with an empty
2092 * parameter list. Thus, (future <expression>) is transformed into
2093 * (#@future '() <expression>), where the empty list represents the
2094 * empty parameter list. This representation allows for easy creation
2095 * of the closure during evaluation. */
2097 scm_m_future (SCM expr
, SCM env
)
2099 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
2100 SCM_SETCAR (new_expr
, SCM_IM_FUTURE
);
2105 unmemoize_future (const SCM expr
, const SCM env
)
2107 const SCM thunk_expr
= SCM_CADDR (expr
);
2108 return scm_list_2 (scm_sym_future
, unmemoize_expression (thunk_expr
, env
));
2112 SCM_SYNTAX (s_gset_x
, "set!", scm_i_makbimacro
, scm_m_generalized_set_x
);
2113 SCM_SYMBOL (scm_sym_setter
, "setter");
2116 scm_m_generalized_set_x (SCM expr
, SCM env
)
2118 SCM target
, exp_target
;
2120 const SCM cdr_expr
= SCM_CDR (expr
);
2121 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2122 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2124 target
= SCM_CAR (cdr_expr
);
2125 if (!SCM_CONSP (target
))
2128 return scm_m_set_x (expr
, env
);
2132 /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */
2133 /* Macroexpanding the target might return things of the form
2134 (begin <atom>). In that case, <atom> must be a symbol or a
2135 variable and we memoize to (set! <atom> ...).
2137 exp_target
= macroexp (target
, env
);
2138 if (scm_is_eq (SCM_CAR (exp_target
), SCM_IM_BEGIN
)
2139 && !SCM_NULLP (SCM_CDR (exp_target
))
2140 && SCM_NULLP (SCM_CDDR (exp_target
)))
2142 exp_target
= SCM_CADR (exp_target
);
2143 ASSERT_SYNTAX_2 (scm_is_symbol (exp_target
)
2144 || SCM_VARIABLEP (exp_target
),
2145 s_bad_variable
, exp_target
, expr
);
2146 return scm_cons (SCM_IM_SET_X
, scm_cons (exp_target
,
2147 SCM_CDR (cdr_expr
)));
2151 const SCM setter_proc_tail
= scm_list_1 (SCM_CAR (target
));
2152 const SCM setter_proc
= scm_cons_source (expr
, scm_sym_setter
,
2155 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
2156 const SCM setter_args
= scm_append_x (scm_list_2 (SCM_CDR (target
),
2159 SCM_SETCAR (expr
, setter_proc
);
2160 SCM_SETCDR (expr
, setter_args
);
2167 /* @slot-ref is bound privately in the (oop goops) module from goops.c. As
2168 * soon as the module system allows us to more freely create bindings in
2169 * arbitrary modules during the startup phase, the code from goops.c should be
2172 SCM_SYMBOL (sym_atslot_ref
, "@slot-ref");
2175 scm_m_atslot_ref (SCM expr
, SCM env SCM_UNUSED
)
2179 const SCM cdr_expr
= SCM_CDR (expr
);
2180 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2181 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2182 slot_nr
= SCM_CADR (cdr_expr
);
2183 ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2185 SCM_SETCAR (expr
, SCM_IM_SLOT_REF
);
2186 SCM_SETCDR (cdr_expr
, slot_nr
);
2191 unmemoize_atslot_ref (const SCM expr
, const SCM env
)
2193 const SCM instance
= SCM_CADR (expr
);
2194 const SCM um_instance
= unmemoize_expression (instance
, env
);
2195 const SCM slot_nr
= SCM_CDDR (expr
);
2196 return scm_list_3 (sym_atslot_ref
, um_instance
, slot_nr
);
2200 /* @slot-set! is bound privately in the (oop goops) module from goops.c. As
2201 * soon as the module system allows us to more freely create bindings in
2202 * arbitrary modules during the startup phase, the code from goops.c should be
2205 SCM_SYMBOL (sym_atslot_set_x
, "@slot-set!");
2208 scm_m_atslot_set_x (SCM expr
, SCM env SCM_UNUSED
)
2212 const SCM cdr_expr
= SCM_CDR (expr
);
2213 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2214 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 3, s_expression
, expr
);
2215 slot_nr
= SCM_CADR (cdr_expr
);
2216 ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2218 SCM_SETCAR (expr
, SCM_IM_SLOT_SET_X
);
2223 unmemoize_atslot_set_x (const SCM expr
, const SCM env
)
2225 const SCM cdr_expr
= SCM_CDR (expr
);
2226 const SCM instance
= SCM_CAR (cdr_expr
);
2227 const SCM um_instance
= unmemoize_expression (instance
, env
);
2228 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
2229 const SCM slot_nr
= SCM_CAR (cddr_expr
);
2230 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
2231 const SCM value
= SCM_CAR (cdddr_expr
);
2232 const SCM um_value
= unmemoize_expression (value
, env
);
2233 return scm_list_4 (sym_atslot_set_x
, um_instance
, slot_nr
, um_value
);
2237 #if SCM_ENABLE_ELISP
2239 static const char s_defun
[] = "Symbol's function definition is void";
2241 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_i_makbimacro
, scm_m_nil_cond
);
2243 /* nil-cond expressions have the form
2244 * (nil-cond COND VAL COND VAL ... ELSEVAL) */
2246 scm_m_nil_cond (SCM expr
, SCM env SCM_UNUSED
)
2248 const long length
= scm_ilength (SCM_CDR (expr
));
2249 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
2250 ASSERT_SYNTAX (length
>= 1 && (length
% 2) == 1, s_expression
, expr
);
2252 SCM_SETCAR (expr
, SCM_IM_NIL_COND
);
2257 SCM_SYNTAX (s_atfop
, "@fop", scm_i_makbimacro
, scm_m_atfop
);
2259 /* The @fop-macro handles procedure and macro applications for elisp. The
2260 * input expression must have the form
2261 * (@fop <var> (transformer-macro <expr> ...))
2262 * where <var> must be a symbol. The expression is transformed into the
2263 * memoized form of either
2264 * (apply <un-aliased var> (transformer-macro <expr> ...))
2265 * if the value of var (across all aliasing) is not a macro, or
2266 * (<un-aliased var> <expr> ...)
2267 * if var is a macro. */
2269 scm_m_atfop (SCM expr
, SCM env SCM_UNUSED
)
2274 const SCM cdr_expr
= SCM_CDR (expr
);
2275 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2276 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 1, s_missing_expression
, expr
);
2278 symbol
= SCM_CAR (cdr_expr
);
2279 ASSERT_SYNTAX_2 (scm_is_symbol (symbol
), s_bad_variable
, symbol
, expr
);
2281 location
= scm_symbol_fref (symbol
);
2282 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2284 /* The elisp function `defalias' allows to define aliases for symbols. To
2285 * look up such definitions, the chain of symbol definitions has to be
2286 * followed up to the terminal symbol. */
2287 while (scm_is_symbol (SCM_VARIABLE_REF (location
)))
2289 const SCM alias
= SCM_VARIABLE_REF (location
);
2290 location
= scm_symbol_fref (alias
);
2291 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2294 /* Memoize the value location belonging to the terminal symbol. */
2295 SCM_SETCAR (cdr_expr
, location
);
2297 if (!SCM_MACROP (SCM_VARIABLE_REF (location
)))
2299 /* Since the location does not contain a macro, the form is a procedure
2300 * application. Replace `@fop' by `@apply' and transform the expression
2301 * including the `transformer-macro'. */
2302 SCM_SETCAR (expr
, SCM_IM_APPLY
);
2307 /* Since the location contains a macro, the arguments should not be
2308 * transformed, so the `transformer-macro' is cut out. The resulting
2309 * expression starts with the memoized variable, that is at the cdr of
2310 * the input expression. */
2311 SCM_SETCDR (cdr_expr
, SCM_CDADR (cdr_expr
));
2316 #endif /* SCM_ENABLE_ELISP */
2320 unmemoize_builtin_macro (const SCM expr
, const SCM env
)
2322 switch (ISYMNUM (SCM_CAR (expr
)))
2324 case (ISYMNUM (SCM_IM_AND
)):
2325 return unmemoize_and (expr
, env
);
2327 case (ISYMNUM (SCM_IM_BEGIN
)):
2328 return unmemoize_begin (expr
, env
);
2330 case (ISYMNUM (SCM_IM_CASE
)):
2331 return unmemoize_case (expr
, env
);
2333 case (ISYMNUM (SCM_IM_COND
)):
2334 return unmemoize_cond (expr
, env
);
2336 case (ISYMNUM (SCM_IM_DELAY
)):
2337 return unmemoize_delay (expr
, env
);
2339 case (ISYMNUM (SCM_IM_DO
)):
2340 return unmemoize_do (expr
, env
);
2342 case (ISYMNUM (SCM_IM_IF
)):
2343 return unmemoize_if (expr
, env
);
2345 case (ISYMNUM (SCM_IM_LAMBDA
)):
2346 return unmemoize_lambda (expr
, env
);
2348 case (ISYMNUM (SCM_IM_LET
)):
2349 return unmemoize_let (expr
, env
);
2351 case (ISYMNUM (SCM_IM_LETREC
)):
2352 return unmemoize_letrec (expr
, env
);
2354 case (ISYMNUM (SCM_IM_LETSTAR
)):
2355 return unmemoize_letstar (expr
, env
);
2357 case (ISYMNUM (SCM_IM_OR
)):
2358 return unmemoize_or (expr
, env
);
2360 case (ISYMNUM (SCM_IM_QUOTE
)):
2361 return unmemoize_quote (expr
, env
);
2363 case (ISYMNUM (SCM_IM_SET_X
)):
2364 return unmemoize_set_x (expr
, env
);
2366 case (ISYMNUM (SCM_IM_APPLY
)):
2367 return unmemoize_apply (expr
, env
);
2369 case (ISYMNUM (SCM_IM_BIND
)):
2370 return unmemoize_exprs (expr
, env
); /* FIXME */
2372 case (ISYMNUM (SCM_IM_CONT
)):
2373 return unmemoize_atcall_cc (expr
, env
);
2375 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2376 return unmemoize_at_call_with_values (expr
, env
);
2378 case (ISYMNUM (SCM_IM_FUTURE
)):
2379 return unmemoize_future (expr
, env
);
2381 case (ISYMNUM (SCM_IM_SLOT_REF
)):
2382 return unmemoize_atslot_ref (expr
, env
);
2384 case (ISYMNUM (SCM_IM_SLOT_SET_X
)):
2385 return unmemoize_atslot_set_x (expr
, env
);
2387 case (ISYMNUM (SCM_IM_NIL_COND
)):
2388 return unmemoize_exprs (expr
, env
); /* FIXME */
2391 return unmemoize_exprs (expr
, env
); /* FIXME */
2396 /* scm_i_unmemocopy_expr and scm_i_unmemocopy_body take a memoized expression
2397 * respectively a memoized body together with its environment and rewrite it
2398 * to its original form. Thus, these functions are the inversion of the
2399 * rewrite rules above. The procedure is not optimized for speed. It's used
2400 * in scm_i_unmemoize_expr, scm_procedure_source, macro_print and scm_iprin1.
2402 * Unmemoizing is not a reliable process. You cannot in general expect to get
2403 * the original source back.
2405 * However, GOOPS currently relies on this for method compilation. This ought
2409 scm_i_unmemocopy_expr (SCM expr
, SCM env
)
2411 const SCM source_properties
= scm_whash_lookup (scm_source_whash
, expr
);
2412 const SCM um_expr
= unmemoize_expression (expr
, env
);
2414 if (scm_is_true (source_properties
))
2415 scm_whash_insert (scm_source_whash
, um_expr
, source_properties
);
2421 scm_i_unmemocopy_body (SCM forms
, SCM env
)
2423 const SCM source_properties
= scm_whash_lookup (scm_source_whash
, forms
);
2424 const SCM um_forms
= unmemoize_exprs (forms
, env
);
2426 if (scm_is_true (source_properties
))
2427 scm_whash_insert (scm_source_whash
, um_forms
, source_properties
);
2433 #if (SCM_ENABLE_DEPRECATED == 1)
2435 /* Deprecated in guile 1.7.0 on 2003-11-09. */
2437 scm_m_expand_body (SCM exprs
, SCM env
)
2439 scm_c_issue_deprecation_warning
2440 ("`scm_m_expand_body' is deprecated.");
2441 m_expand_body (exprs
, env
);
2446 SCM_SYNTAX (s_undefine
, "undefine", scm_makacro
, scm_m_undefine
);
2449 scm_m_undefine (SCM expr
, SCM env
)
2454 const SCM cdr_expr
= SCM_CDR (expr
);
2455 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), "Bad undefine placement in", expr
);
2456 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2457 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2459 scm_c_issue_deprecation_warning
2460 ("`undefine' is deprecated.\n");
2462 variable
= SCM_CAR (cdr_expr
);
2463 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
2464 location
= scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_F
);
2465 ASSERT_SYNTAX_2 (scm_is_true (location
)
2466 && !SCM_UNBNDP (SCM_VARIABLE_REF (location
)),
2467 "variable already unbound ", variable
, expr
);
2468 SCM_VARIABLE_SET (location
, SCM_UNDEFINED
);
2469 return SCM_UNSPECIFIED
;
2473 scm_macroexp (SCM x
, SCM env
)
2475 scm_c_issue_deprecation_warning
2476 ("`scm_macroexp' is deprecated.");
2477 return macroexp (x
, env
);
2483 #if (SCM_ENABLE_DEPRECATED == 1)
2486 scm_unmemocar (SCM form
, SCM env
)
2488 scm_c_issue_deprecation_warning
2489 ("`scm_unmemocar' is deprecated.");
2491 if (!SCM_CONSP (form
))
2495 SCM c
= SCM_CAR (form
);
2496 if (SCM_VARIABLEP (c
))
2498 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
2499 if (scm_is_false (sym
))
2500 sym
= sym_three_question_marks
;
2501 SCM_SETCAR (form
, sym
);
2503 else if (SCM_ILOCP (c
))
2505 unsigned long int ir
;
2507 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
2508 env
= SCM_CDR (env
);
2509 env
= SCM_CAAR (env
);
2510 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
2511 env
= SCM_CDR (env
);
2513 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
2521 /*****************************************************************************/
2522 /*****************************************************************************/
2523 /* The definitions for execution start here. */
2524 /*****************************************************************************/
2525 /*****************************************************************************/
2527 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
2528 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
2529 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
2530 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
2532 /* A function object to implement "apply" for non-closure functions. */
2534 /* An endless list consisting of #<undefined> objects: */
2535 static SCM undefineds
;
2539 scm_badargsp (SCM formals
, SCM args
)
2541 while (!SCM_NULLP (formals
))
2543 if (!SCM_CONSP (formals
))
2545 if (SCM_NULLP (args
))
2547 formals
= SCM_CDR (formals
);
2548 args
= SCM_CDR (args
);
2550 return !SCM_NULLP (args
) ? 1 : 0;
2555 /* The evaluator contains a plethora of EVAL symbols. This is an attempt at
2558 * The following macros should be used in code which is read twice (where the
2559 * choice of evaluator is hard soldered):
2561 * CEVAL is the symbol used within one evaluator to call itself.
2562 * Originally, it is defined to ceval, but is redefined to deval during the
2565 * SCM_I_EVALIM is used when it is known that the expression is an
2566 * immediate. (This macro never calls an evaluator.)
2568 * EVAL evaluates an expression that is expected to have its symbols already
2569 * memoized. Expressions that are not of the form '(<form> <form> ...)' are
2570 * evaluated inline without calling an evaluator.
2572 * EVALCAR evaluates the car of an expression 'X:(Y:<form> <form> ...)',
2573 * potentially replacing a symbol at the position Y:<form> by its memoized
2574 * variable. If Y:<form> is not of the form '(<form> <form> ...)', the
2575 * evaluation is performed inline without calling an evaluator.
2577 * The following macros should be used in code which is read once
2578 * (where the choice of evaluator is dynamic):
2580 * SCM_I_XEVAL corresponds to EVAL, but uses ceval *or* deval depending on the
2583 * SCM_I_XEVALCAR corresponds to EVALCAR, but uses ceval *or* deval depending
2584 * on the debugging mode.
2586 * The main motivation for keeping this plethora is efficiency
2587 * together with maintainability (=> locality of code).
2590 static SCM
ceval (SCM x
, SCM env
);
2591 static SCM
deval (SCM x
, SCM env
);
2595 #define SCM_I_EVALIM2(x) \
2596 ((scm_is_eq ((x), SCM_EOL) \
2597 ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \
2601 #define SCM_I_EVALIM(x, env) (SCM_ILOCP (x) \
2602 ? *scm_ilookup ((x), (env)) \
2605 #define SCM_I_XEVAL(x, env) \
2607 ? SCM_I_EVALIM2 (x) \
2608 : (SCM_VARIABLEP (x) \
2609 ? SCM_VARIABLE_REF (x) \
2611 ? (scm_debug_mode_p \
2612 ? deval ((x), (env)) \
2613 : ceval ((x), (env))) \
2616 #define SCM_I_XEVALCAR(x, env) \
2617 (SCM_IMP (SCM_CAR (x)) \
2618 ? SCM_I_EVALIM (SCM_CAR (x), (env)) \
2619 : (SCM_VARIABLEP (SCM_CAR (x)) \
2620 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2621 : (SCM_CONSP (SCM_CAR (x)) \
2622 ? (scm_debug_mode_p \
2623 ? deval (SCM_CAR (x), (env)) \
2624 : ceval (SCM_CAR (x), (env))) \
2625 : (!scm_is_symbol (SCM_CAR (x)) \
2627 : *scm_lookupcar ((x), (env), 1)))))
2629 #define EVAL(x, env) \
2631 ? SCM_I_EVALIM ((x), (env)) \
2632 : (SCM_VARIABLEP (x) \
2633 ? SCM_VARIABLE_REF (x) \
2635 ? CEVAL ((x), (env)) \
2638 #define EVALCAR(x, env) \
2639 (SCM_IMP (SCM_CAR (x)) \
2640 ? SCM_I_EVALIM (SCM_CAR (x), (env)) \
2641 : (SCM_VARIABLEP (SCM_CAR (x)) \
2642 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2643 : (SCM_CONSP (SCM_CAR (x)) \
2644 ? CEVAL (SCM_CAR (x), (env)) \
2645 : (!scm_is_symbol (SCM_CAR (x)) \
2647 : *scm_lookupcar ((x), (env), 1)))))
2649 SCM_REC_MUTEX (source_mutex
);
2652 /* Lookup a given local variable in an environment. The local variable is
2653 * given as an iloc, that is a triple <frame, binding, last?>, where frame
2654 * indicates the relative number of the environment frame (counting upwards
2655 * from the innermost environment frame), binding indicates the number of the
2656 * binding within the frame, and last? (which is extracted from the iloc using
2657 * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
2658 * very end of the improper list of bindings. */
2660 scm_ilookup (SCM iloc
, SCM env
)
2662 unsigned int frame_nr
= SCM_IFRAME (iloc
);
2663 unsigned int binding_nr
= SCM_IDIST (iloc
);
2667 for (; 0 != frame_nr
; --frame_nr
)
2668 frames
= SCM_CDR (frames
);
2670 bindings
= SCM_CAR (frames
);
2671 for (; 0 != binding_nr
; --binding_nr
)
2672 bindings
= SCM_CDR (bindings
);
2674 if (SCM_ICDRP (iloc
))
2675 return SCM_CDRLOC (bindings
);
2676 return SCM_CARLOC (SCM_CDR (bindings
));
2680 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
2682 static void error_unbound_variable (SCM symbol
) SCM_NORETURN
;
2683 static void error_defined_variable (SCM symbol
) SCM_NORETURN
;
2685 /* Call this for variables that are unfound.
2688 error_unbound_variable (SCM symbol
)
2690 scm_error (scm_unbound_variable_key
, NULL
,
2691 "Unbound variable: ~S",
2692 scm_list_1 (symbol
), SCM_BOOL_F
);
2695 /* Call this for variables that are found but contain SCM_UNDEFINED.
2698 error_defined_variable (SCM symbol
)
2700 /* We use the 'unbound-variable' key here as well, since it
2701 basically is the same kind of error, with a slight variation in
2702 the displayed message.
2704 scm_error (scm_unbound_variable_key
, NULL
,
2705 "Undefined variable: ~S",
2706 scm_list_1 (symbol
), SCM_BOOL_F
);
2710 /* The Lookup Car Race
2713 Memoization of variables and special forms is done while executing
2714 the code for the first time. As long as there is only one thread
2715 everything is fine, but as soon as two threads execute the same
2716 code concurrently `for the first time' they can come into conflict.
2718 This memoization includes rewriting variable references into more
2719 efficient forms and expanding macros. Furthermore, macro expansion
2720 includes `compiling' special forms like `let', `cond', etc. into
2721 tree-code instructions.
2723 There shouldn't normally be a problem with memoizing local and
2724 global variable references (into ilocs and variables), because all
2725 threads will mutate the code in *exactly* the same way and (if I
2726 read the C code correctly) it is not possible to observe a half-way
2727 mutated cons cell. The lookup procedure can handle this
2728 transparently without any critical sections.
2730 It is different with macro expansion, because macro expansion
2731 happens outside of the lookup procedure and can't be
2732 undone. Therefore the lookup procedure can't cope with it. It has
2733 to indicate failure when it detects a lost race and hope that the
2734 caller can handle it. Luckily, it turns out that this is the case.
2736 An example to illustrate this: Suppose that the following form will
2737 be memoized concurrently by two threads
2741 Let's first examine the lookup of X in the body. The first thread
2742 decides that it has to find the symbol "x" in the environment and
2743 starts to scan it. Then the other thread takes over and actually
2744 overtakes the first. It looks up "x" and substitutes an
2745 appropriate iloc for it. Now the first thread continues and
2746 completes its lookup. It comes to exactly the same conclusions as
2747 the second one and could - without much ado - just overwrite the
2748 iloc with the same iloc.
2750 But let's see what will happen when the race occurs while looking
2751 up the symbol "let" at the start of the form. It could happen that
2752 the second thread interrupts the lookup of the first thread and not
2753 only substitutes a variable for it but goes right ahead and
2754 replaces it with the compiled form (#@let* (x 12) x). Now, when
2755 the first thread completes its lookup, it would replace the #@let*
2756 with a variable containing the "let" binding, effectively reverting
2757 the form to (let (x 12) x). This is wrong. It has to detect that
2758 it has lost the race and the evaluator has to reconsider the
2759 changed form completely.
2761 This race condition could be resolved with some kind of traffic
2762 light (like mutexes) around scm_lookupcar, but I think that it is
2763 best to avoid them in this case. They would serialize memoization
2764 completely and because lookup involves calling arbitrary Scheme
2765 code (via the lookup-thunk), threads could be blocked for an
2766 arbitrary amount of time or even deadlock. But with the current
2767 solution a lot of unnecessary work is potentially done. */
2769 /* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
2770 return NULL to indicate a failed lookup due to some race conditions
2771 between threads. This only happens when VLOC is the first cell of
2772 a special form that will eventually be memoized (like `let', etc.)
2773 In that case the whole lookup is bogus and the caller has to
2774 reconsider the complete special form.
2776 SCM_LOOKUPCAR is still there, of course. It just calls
2777 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
2778 should only be called when it is known that VLOC is not the first
2779 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
2780 for NULL. I think I've found the only places where this
2784 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
2787 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
2788 register SCM iloc
= SCM_ILOC00
;
2789 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
2791 if (!SCM_CONSP (SCM_CAR (env
)))
2793 al
= SCM_CARLOC (env
);
2794 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
2796 if (!SCM_CONSP (fl
))
2798 if (scm_is_eq (fl
, var
))
2800 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2802 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
2803 return SCM_CDRLOC (*al
);
2808 al
= SCM_CDRLOC (*al
);
2809 if (scm_is_eq (SCM_CAR (fl
), var
))
2811 if (SCM_UNBNDP (SCM_CAR (*al
)))
2812 error_defined_variable (var
);
2813 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2815 SCM_SETCAR (vloc
, iloc
);
2816 return SCM_CARLOC (*al
);
2818 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
2820 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
2823 SCM top_thunk
, real_var
;
2826 top_thunk
= SCM_CAR (env
); /* env now refers to a
2827 top level env thunk */
2828 env
= SCM_CDR (env
);
2831 top_thunk
= SCM_BOOL_F
;
2832 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
2833 if (scm_is_false (real_var
))
2836 if (!SCM_NULLP (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
2841 if (SCM_NULLP (env
))
2842 error_unbound_variable (var
);
2844 scm_misc_error (NULL
, "Damaged environment: ~S",
2849 /* A variable could not be found, but we shall
2850 not throw an error. */
2851 static SCM undef_object
= SCM_UNDEFINED
;
2852 return &undef_object
;
2856 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2858 /* Some other thread has changed the very cell we are working
2859 on. In effect, it must have done our job or messed it up
2862 var
= SCM_CAR (vloc
);
2863 if (SCM_VARIABLEP (var
))
2864 return SCM_VARIABLE_LOC (var
);
2865 if (SCM_ILOCP (var
))
2866 return scm_ilookup (var
, genv
);
2867 /* We can't cope with anything else than variables and ilocs. When
2868 a special form has been memoized (i.e. `let' into `#@let') we
2869 return NULL and expect the calling function to do the right
2870 thing. For the evaluator, this means going back and redoing
2871 the dispatch on the car of the form. */
2875 SCM_SETCAR (vloc
, real_var
);
2876 return SCM_VARIABLE_LOC (real_var
);
2881 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
2883 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
2890 /* During execution, look up a symbol in the top level of the given local
2891 * environment and return the corresponding variable object. If no binding
2892 * for the symbol can be found, an 'Unbound variable' error is signalled. */
2894 lazy_memoize_variable (const SCM symbol
, const SCM environment
)
2896 const SCM top_level
= scm_env_top_level (environment
);
2897 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
2899 if (scm_is_false (variable
))
2900 error_unbound_variable (symbol
);
2907 scm_eval_car (SCM pair
, SCM env
)
2909 return SCM_I_XEVALCAR (pair
, env
);
2914 scm_eval_args (SCM l
, SCM env
, SCM proc
)
2916 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
2917 while (SCM_CONSP (l
))
2919 res
= EVALCAR (l
, env
);
2921 *lloc
= scm_list_1 (res
);
2922 lloc
= SCM_CDRLOC (*lloc
);
2926 scm_wrong_num_args (proc
);
2932 scm_eval_body (SCM code
, SCM env
)
2937 next
= SCM_CDR (code
);
2938 while (!SCM_NULLP (next
))
2940 if (SCM_IMP (SCM_CAR (code
)))
2942 if (SCM_ISYMP (SCM_CAR (code
)))
2944 scm_rec_mutex_lock (&source_mutex
);
2945 /* check for race condition */
2946 if (SCM_ISYMP (SCM_CAR (code
)))
2947 m_expand_body (code
, env
);
2948 scm_rec_mutex_unlock (&source_mutex
);
2953 SCM_I_XEVAL (SCM_CAR (code
), env
);
2955 next
= SCM_CDR (code
);
2957 return SCM_I_XEVALCAR (code
, env
);
2963 /* SECTION: This code is specific for the debugging support. One
2964 * branch is read when DEVAL isn't defined, the other when DEVAL is
2970 #define SCM_APPLY scm_apply
2971 #define PREP_APPLY(proc, args)
2973 #define RETURN(x) do { return x; } while (0)
2974 #ifdef STACK_CHECKING
2975 #ifndef NO_CEVAL_STACK_CHECKING
2976 #define EVAL_STACK_CHECKING
2983 #define CEVAL deval /* Substitute all uses of ceval */
2986 #define SCM_APPLY scm_dapply
2989 #define PREP_APPLY(p, l) \
2990 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
2993 #define ENTER_APPLY \
2995 SCM_SET_ARGSREADY (debug);\
2996 if (scm_check_apply_p && SCM_TRAPS_P)\
2997 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
2999 SCM tmp, tail = scm_from_bool(SCM_TRACED_FRAME_P (debug)); \
3000 SCM_SET_TRACED_FRAME (debug); \
3002 if (SCM_CHEAPTRAPS_P)\
3004 tmp = scm_make_debugobj (&debug);\
3005 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
3010 tmp = scm_make_continuation (&first);\
3012 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
3019 #define RETURN(e) do { proc = (e); goto exit; } while (0)
3021 #ifdef STACK_CHECKING
3022 #ifndef EVAL_STACK_CHECKING
3023 #define EVAL_STACK_CHECKING
3028 /* scm_last_debug_frame contains a pointer to the last debugging information
3029 * stack frame. It is accessed very often from the debugging evaluator, so it
3030 * should probably not be indirectly addressed. Better to save and restore it
3031 * from the current root at any stack swaps.
3034 /* scm_debug_eframe_size is the number of slots available for pseudo
3035 * stack frames at each real stack frame.
3038 long scm_debug_eframe_size
;
3040 int scm_debug_mode_p
;
3041 int scm_check_entry_p
;
3042 int scm_check_apply_p
;
3043 int scm_check_exit_p
;
3045 long scm_eval_stack
;
3047 scm_t_option scm_eval_opts
[] = {
3048 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
3051 scm_t_option scm_debug_opts
[] = {
3052 { SCM_OPTION_BOOLEAN
, "cheap", 1,
3053 "*Flyweight representation of the stack at traps." },
3054 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
3055 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
3056 { SCM_OPTION_BOOLEAN
, "procnames", 1,
3057 "Record procedure names at definition." },
3058 { SCM_OPTION_BOOLEAN
, "backwards", 0,
3059 "Display backtrace in anti-chronological order." },
3060 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
3061 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
3062 { SCM_OPTION_INTEGER
, "frames", 3,
3063 "Maximum number of tail-recursive frames in backtrace." },
3064 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
3065 "Maximal number of stored backtrace frames." },
3066 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
3067 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
3068 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
3069 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
3070 { 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."}
3073 scm_t_option scm_evaluator_trap_table
[] = {
3074 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
3075 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
3076 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
3077 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
3078 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
3079 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
3080 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
3083 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
3085 "Option interface for the evaluation options. Instead of using\n"
3086 "this procedure directly, use the procedures @code{eval-enable},\n"
3087 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
3088 #define FUNC_NAME s_scm_eval_options_interface
3092 ans
= scm_options (setting
,
3096 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
3103 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
3105 "Option interface for the evaluator trap options.")
3106 #define FUNC_NAME s_scm_evaluator_traps
3110 ans
= scm_options (setting
,
3111 scm_evaluator_trap_table
,
3112 SCM_N_EVALUATOR_TRAPS
,
3114 SCM_RESET_DEBUG_MODE
;
3122 deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
3124 SCM
*results
= lloc
;
3125 while (SCM_CONSP (l
))
3127 const SCM res
= EVALCAR (l
, env
);
3129 *lloc
= scm_list_1 (res
);
3130 lloc
= SCM_CDRLOC (*lloc
);
3134 scm_wrong_num_args (proc
);
3141 /* SECTION: This code is compiled twice.
3145 /* Update the toplevel environment frame ENV so that it refers to the
3146 * current module. */
3147 #define UPDATE_TOPLEVEL_ENV(env) \
3149 SCM p = scm_current_module_lookup_closure (); \
3150 if (p != SCM_CAR (env)) \
3151 env = scm_top_level_env (p); \
3155 #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
3156 ASSERT_SYNTAX (!scm_is_eq ((x), SCM_EOL), s_empty_combination, x)
3159 /* This is the evaluator. Like any real monster, it has three heads:
3161 * ceval is the non-debugging evaluator, deval is the debugging version. Both
3162 * are implemented using a common code base, using the following mechanism:
3163 * CEVAL is a macro, which is either defined to ceval or deval. Thus, there
3164 * is no function CEVAL, but the code for CEVAL actually compiles to either
3165 * ceval or deval. When CEVAL is defined to ceval, it is known that the macro
3166 * DEVAL is not defined. When CEVAL is defined to deval, then the macro DEVAL
3167 * is known to be defined. Thus, in CEVAL parts for the debugging evaluator
3168 * are enclosed within #ifdef DEVAL ... #endif.
3170 * All three (ceval, deval and their common implementation CEVAL) take two
3171 * input parameters, x and env: x is a single expression to be evalutated.
3172 * env is the environment in which bindings are searched.
3174 * x is known to be a pair. Since x is a single expression, it is necessarily
3175 * in a tail position. If x is just a call to another function like in the
3176 * expression (foo exp1 exp2 ...), the realization of that call therefore
3177 * _must_not_ increase stack usage (the evaluation of exp1, exp2 etc.,
3178 * however, may do so). This is realized by making extensive use of 'goto'
3179 * statements within the evaluator: The gotos replace recursive calls to
3180 * CEVAL, thus re-using the same stack frame that CEVAL was already using.
3181 * If, however, x represents some form that requires to evaluate a sequence of
3182 * expressions like (begin exp1 exp2 ...), then recursive calls to CEVAL are
3183 * performed for all but the last expression of that sequence. */
3186 CEVAL (SCM x
, SCM env
)
3190 scm_t_debug_frame debug
;
3191 scm_t_debug_info
*debug_info_end
;
3192 debug
.prev
= scm_last_debug_frame
;
3195 * The debug.vect contains twice as much scm_t_debug_info frames as the
3196 * user has specified with (debug-set! frames <n>).
3198 * Even frames are eval frames, odd frames are apply frames.
3200 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
3201 * sizeof (scm_t_debug_info
));
3202 debug
.info
= debug
.vect
;
3203 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
3204 scm_last_debug_frame
= &debug
;
3206 #ifdef EVAL_STACK_CHECKING
3207 if (scm_stack_checking_enabled_p
&& SCM_STACK_OVERFLOW_P (&proc
))
3210 debug
.info
->e
.exp
= x
;
3211 debug
.info
->e
.env
= env
;
3213 scm_report_stack_overflow ();
3223 SCM_CLEAR_ARGSREADY (debug
);
3224 if (SCM_OVERFLOWP (debug
))
3227 * In theory, this should be the only place where it is necessary to
3228 * check for space in debug.vect since both eval frames and
3229 * available space are even.
3231 * For this to be the case, however, it is necessary that primitive
3232 * special forms which jump back to `loop', `begin' or some similar
3233 * label call PREP_APPLY.
3235 else if (++debug
.info
>= debug_info_end
)
3237 SCM_SET_OVERFLOW (debug
);
3242 debug
.info
->e
.exp
= x
;
3243 debug
.info
->e
.env
= env
;
3244 if (scm_check_entry_p
&& SCM_TRAPS_P
)
3246 if (SCM_ENTER_FRAME_P
3247 || (SCM_BREAKPOINTS_P
&& scm_c_source_property_breakpoint_p (x
)))
3250 SCM tail
= scm_from_bool (SCM_TAILRECP (debug
));
3251 SCM_SET_TAILREC (debug
);
3252 if (SCM_CHEAPTRAPS_P
)
3253 stackrep
= scm_make_debugobj (&debug
);
3257 SCM val
= scm_make_continuation (&first
);
3267 /* This gives the possibility for the debugger to
3268 modify the source expression before evaluation. */
3273 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
3274 scm_sym_enter_frame
,
3277 unmemoize_expression (x
, env
));
3284 if (SCM_ISYMP (SCM_CAR (x
)))
3286 switch (ISYMNUM (SCM_CAR (x
)))
3288 case (ISYMNUM (SCM_IM_AND
)):
3290 while (!SCM_NULLP (SCM_CDR (x
)))
3292 SCM test_result
= EVALCAR (x
, env
);
3293 if (scm_is_false (test_result
) || SCM_NILP (test_result
))
3294 RETURN (SCM_BOOL_F
);
3298 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3301 case (ISYMNUM (SCM_IM_BEGIN
)):
3304 RETURN (SCM_UNSPECIFIED
);
3306 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3309 /* If we are on toplevel with a lookup closure, we need to sync
3310 with the current module. */
3311 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
3313 UPDATE_TOPLEVEL_ENV (env
);
3314 while (!SCM_NULLP (SCM_CDR (x
)))
3317 UPDATE_TOPLEVEL_ENV (env
);
3323 goto nontoplevel_begin
;
3326 while (!SCM_NULLP (SCM_CDR (x
)))
3328 const SCM form
= SCM_CAR (x
);
3331 if (SCM_ISYMP (form
))
3333 scm_rec_mutex_lock (&source_mutex
);
3334 /* check for race condition */
3335 if (SCM_ISYMP (SCM_CAR (x
)))
3336 m_expand_body (x
, env
);
3337 scm_rec_mutex_unlock (&source_mutex
);
3338 goto nontoplevel_begin
;
3341 SCM_VALIDATE_NON_EMPTY_COMBINATION (form
);
3344 (void) EVAL (form
, env
);
3350 /* scm_eval last form in list */
3351 const SCM last_form
= SCM_CAR (x
);
3353 if (SCM_CONSP (last_form
))
3355 /* This is by far the most frequent case. */
3357 goto loop
; /* tail recurse */
3359 else if (SCM_IMP (last_form
))
3360 RETURN (SCM_I_EVALIM (last_form
, env
));
3361 else if (SCM_VARIABLEP (last_form
))
3362 RETURN (SCM_VARIABLE_REF (last_form
));
3363 else if (scm_is_symbol (last_form
))
3364 RETURN (*scm_lookupcar (x
, env
, 1));
3370 case (ISYMNUM (SCM_IM_CASE
)):
3373 const SCM key
= EVALCAR (x
, env
);
3375 while (!SCM_NULLP (x
))
3377 const SCM clause
= SCM_CAR (x
);
3378 SCM labels
= SCM_CAR (clause
);
3379 if (scm_is_eq (labels
, SCM_IM_ELSE
))
3381 x
= SCM_CDR (clause
);
3382 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3385 while (!SCM_NULLP (labels
))
3387 const SCM label
= SCM_CAR (labels
);
3388 if (scm_is_eq (label
, key
)
3389 || scm_is_true (scm_eqv_p (label
, key
)))
3391 x
= SCM_CDR (clause
);
3392 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3395 labels
= SCM_CDR (labels
);
3400 RETURN (SCM_UNSPECIFIED
);
3403 case (ISYMNUM (SCM_IM_COND
)):
3405 while (!SCM_NULLP (x
))
3407 const SCM clause
= SCM_CAR (x
);
3408 if (scm_is_eq (SCM_CAR (clause
), SCM_IM_ELSE
))
3410 x
= SCM_CDR (clause
);
3411 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3416 arg1
= EVALCAR (clause
, env
);
3417 if (scm_is_true (arg1
) && !SCM_NILP (arg1
))
3419 x
= SCM_CDR (clause
);
3422 else if (!scm_is_eq (SCM_CAR (x
), SCM_IM_ARROW
))
3424 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3430 proc
= EVALCAR (proc
, env
);
3431 PREP_APPLY (proc
, scm_list_1 (arg1
));
3439 RETURN (SCM_UNSPECIFIED
);
3442 case (ISYMNUM (SCM_IM_DO
)):
3445 /* Compute the initialization values and the initial environment. */
3446 SCM init_forms
= SCM_CAR (x
);
3447 SCM init_values
= SCM_EOL
;
3448 while (!SCM_NULLP (init_forms
))
3450 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3451 init_forms
= SCM_CDR (init_forms
);
3454 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
3458 SCM test_form
= SCM_CAR (x
);
3459 SCM body_forms
= SCM_CADR (x
);
3460 SCM step_forms
= SCM_CDDR (x
);
3462 SCM test_result
= EVALCAR (test_form
, env
);
3464 while (scm_is_false (test_result
) || SCM_NILP (test_result
))
3467 /* Evaluate body forms. */
3469 for (temp_forms
= body_forms
;
3470 !SCM_NULLP (temp_forms
);
3471 temp_forms
= SCM_CDR (temp_forms
))
3473 SCM form
= SCM_CAR (temp_forms
);
3474 /* Dirk:FIXME: We only need to eval forms that may have
3475 * a side effect here. This is only true for forms that
3476 * start with a pair. All others are just constants.
3477 * Since with the current memoizer 'form' may hold a
3478 * constant, we call EVAL here to handle the constant
3479 * cases. In the long run it would make sense to have
3480 * the macro transformer of 'do' eliminate all forms
3481 * that have no sideeffect. Then instead of EVAL we
3482 * could call CEVAL directly here. */
3483 (void) EVAL (form
, env
);
3488 /* Evaluate the step expressions. */
3490 SCM step_values
= SCM_EOL
;
3491 for (temp_forms
= step_forms
;
3492 !SCM_NULLP (temp_forms
);
3493 temp_forms
= SCM_CDR (temp_forms
))
3495 const SCM value
= EVALCAR (temp_forms
, env
);
3496 step_values
= scm_cons (value
, step_values
);
3498 env
= SCM_EXTEND_ENV (SCM_CAAR (env
),
3503 test_result
= EVALCAR (test_form
, env
);
3508 RETURN (SCM_UNSPECIFIED
);
3509 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3510 goto nontoplevel_begin
;
3513 case (ISYMNUM (SCM_IM_IF
)):
3516 SCM test_result
= EVALCAR (x
, env
);
3517 x
= SCM_CDR (x
); /* then expression */
3518 if (scm_is_false (test_result
) || SCM_NILP (test_result
))
3520 x
= SCM_CDR (x
); /* else expression */
3522 RETURN (SCM_UNSPECIFIED
);
3525 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3529 case (ISYMNUM (SCM_IM_LET
)):
3532 SCM init_forms
= SCM_CADR (x
);
3533 SCM init_values
= SCM_EOL
;
3536 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3537 init_forms
= SCM_CDR (init_forms
);
3539 while (!SCM_NULLP (init_forms
));
3540 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
3543 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3544 goto nontoplevel_begin
;
3547 case (ISYMNUM (SCM_IM_LETREC
)):
3549 env
= SCM_EXTEND_ENV (SCM_CAR (x
), undefineds
, env
);
3552 SCM init_forms
= SCM_CAR (x
);
3553 SCM init_values
= SCM_EOL
;
3556 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3557 init_forms
= SCM_CDR (init_forms
);
3559 while (!SCM_NULLP (init_forms
));
3560 SCM_SETCDR (SCM_CAR (env
), init_values
);
3563 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3564 goto nontoplevel_begin
;
3567 case (ISYMNUM (SCM_IM_LETSTAR
)):
3570 SCM bindings
= SCM_CAR (x
);
3571 if (!SCM_NULLP (bindings
))
3575 SCM name
= SCM_CAR (bindings
);
3576 SCM init
= SCM_CDR (bindings
);
3577 env
= SCM_EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
3578 bindings
= SCM_CDR (init
);
3580 while (!SCM_NULLP (bindings
));
3584 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3585 goto nontoplevel_begin
;
3588 case (ISYMNUM (SCM_IM_OR
)):
3590 while (!SCM_NULLP (SCM_CDR (x
)))
3592 SCM val
= EVALCAR (x
, env
);
3593 if (scm_is_true (val
) && !SCM_NILP (val
))
3598 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3602 case (ISYMNUM (SCM_IM_LAMBDA
)):
3603 RETURN (scm_closure (SCM_CDR (x
), env
));
3606 case (ISYMNUM (SCM_IM_QUOTE
)):
3607 RETURN (SCM_CDR (x
));
3610 case (ISYMNUM (SCM_IM_SET_X
)):
3614 SCM variable
= SCM_CAR (x
);
3615 if (SCM_ILOCP (variable
))
3616 location
= scm_ilookup (variable
, env
);
3617 else if (SCM_VARIABLEP (variable
))
3618 location
= SCM_VARIABLE_LOC (variable
);
3621 /* (scm_is_symbol (variable)) is known to be true */
3622 variable
= lazy_memoize_variable (variable
, env
);
3623 SCM_SETCAR (x
, variable
);
3624 location
= SCM_VARIABLE_LOC (variable
);
3627 *location
= EVALCAR (x
, env
);
3629 RETURN (SCM_UNSPECIFIED
);
3632 case (ISYMNUM (SCM_IM_APPLY
)):
3633 /* Evaluate the procedure to be applied. */
3635 proc
= EVALCAR (x
, env
);
3636 PREP_APPLY (proc
, SCM_EOL
);
3638 /* Evaluate the argument holding the list of arguments */
3640 arg1
= EVALCAR (x
, env
);
3643 /* Go here to tail-apply a procedure. PROC is the procedure and
3644 * ARG1 is the list of arguments. PREP_APPLY must have been called
3645 * before jumping to apply_proc. */
3646 if (SCM_CLOSUREP (proc
))
3648 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3650 debug
.info
->a
.args
= arg1
;
3652 if (scm_badargsp (formals
, arg1
))
3653 scm_wrong_num_args (proc
);
3655 /* Copy argument list */
3656 if (SCM_NULL_OR_NIL_P (arg1
))
3657 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
3660 SCM args
= scm_list_1 (SCM_CAR (arg1
));
3662 arg1
= SCM_CDR (arg1
);
3663 while (!SCM_NULL_OR_NIL_P (arg1
))
3665 SCM new_tail
= scm_list_1 (SCM_CAR (arg1
));
3666 SCM_SETCDR (tail
, new_tail
);
3668 arg1
= SCM_CDR (arg1
);
3670 env
= SCM_EXTEND_ENV (formals
, args
, SCM_ENV (proc
));
3673 x
= SCM_CLOSURE_BODY (proc
);
3674 goto nontoplevel_begin
;
3679 RETURN (SCM_APPLY (proc
, arg1
, SCM_EOL
));
3683 case (ISYMNUM (SCM_IM_CONT
)):
3686 SCM val
= scm_make_continuation (&first
);
3694 proc
= EVALCAR (proc
, env
);
3695 PREP_APPLY (proc
, scm_list_1 (arg1
));
3702 case (ISYMNUM (SCM_IM_DELAY
)):
3703 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
3706 case (ISYMNUM (SCM_IM_FUTURE
)):
3707 RETURN (scm_i_make_future (scm_closure (SCM_CDR (x
), env
)));
3710 /* PLACEHOLDER for case (ISYMNUM (SCM_IM_DISPATCH)): The following
3711 code (type_dispatch) is intended to be the tail of the case
3712 clause for the internal macro SCM_IM_DISPATCH. Please don't
3713 remove it from this location without discussing it with Mikael
3714 <djurfeldt@nada.kth.se> */
3716 /* The type dispatch code is duplicated below
3717 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
3718 * cuts down execution time for type dispatch to 50%. */
3719 type_dispatch
: /* inputs: x, arg1 */
3720 /* Type dispatch means to determine from the types of the function
3721 * arguments (i. e. the 'signature' of the call), which method from
3722 * a generic function is to be called. This process of selecting
3723 * the right method takes some time. To speed it up, guile uses
3724 * caching: Together with the macro call to dispatch the signatures
3725 * of some previous calls to that generic function from the same
3726 * place are stored (in the code!) in a cache that we call the
3727 * 'method cache'. This is done since it is likely, that
3728 * consecutive calls to dispatch from that position in the code will
3729 * have the same signature. Thus, the type dispatch works as
3730 * follows: First, determine a hash value from the signature of the
3731 * actual arguments. Second, use this hash value as an index to
3732 * find that same signature in the method cache stored at this
3733 * position in the code. If found, you have also found the
3734 * corresponding method that belongs to that signature. If the
3735 * signature is not found in the method cache, you have to perform a
3736 * full search over all signatures stored with the generic
3739 unsigned long int specializers
;
3740 unsigned long int hash_value
;
3741 unsigned long int cache_end_pos
;
3742 unsigned long int mask
;
3746 SCM z
= SCM_CDDR (x
);
3747 SCM tmp
= SCM_CADR (z
);
3748 specializers
= scm_to_ulong (SCM_CAR (z
));
3750 /* Compute a hash value for searching the method cache. There
3751 * are two variants for computing the hash value, a (rather)
3752 * complicated one, and a simple one. For the complicated one
3753 * explained below, tmp holds a number that is used in the
3755 if (SCM_VECTORP (tmp
))
3757 /* This method of determining the hash value is much
3758 * simpler: Set the hash value to zero and just perform a
3759 * linear search through the method cache. */
3761 mask
= (unsigned long int) ((long) -1);
3763 cache_end_pos
= SCM_VECTOR_LENGTH (method_cache
);
3767 /* Use the signature of the actual arguments to determine
3768 * the hash value. This is done as follows: Each class has
3769 * an array of random numbers, that are determined when the
3770 * class is created. The integer 'hashset' is an index into
3771 * that array of random numbers. Now, from all classes that
3772 * are part of the signature of the actual arguments, the
3773 * random numbers at index 'hashset' are taken and summed
3774 * up, giving the hash value. The value of 'hashset' is
3775 * stored at the call to dispatch. This allows to have
3776 * different 'formulas' for calculating the hash value at
3777 * different places where dispatch is called. This allows
3778 * to optimize the hash formula at every individual place
3779 * where dispatch is called, such that hopefully the hash
3780 * value that is computed will directly point to the right
3781 * method in the method cache. */
3782 unsigned long int hashset
= scm_to_ulong (tmp
);
3783 unsigned long int counter
= specializers
+ 1;
3786 while (!SCM_NULLP (tmp_arg
) && counter
!= 0)
3788 SCM
class = scm_class_of (SCM_CAR (tmp_arg
));
3789 hash_value
+= SCM_INSTANCE_HASH (class, hashset
);
3790 tmp_arg
= SCM_CDR (tmp_arg
);
3794 method_cache
= SCM_CADR (z
);
3795 mask
= scm_to_ulong (SCM_CAR (z
));
3797 cache_end_pos
= hash_value
;
3802 /* Search the method cache for a method with a matching
3803 * signature. Start the search at position 'hash_value'. The
3804 * hashing implementation uses linear probing for conflict
3805 * resolution, that is, if the signature in question is not
3806 * found at the starting index in the hash table, the next table
3807 * entry is tried, and so on, until in the worst case the whole
3808 * cache has been searched, but still the signature has not been
3813 SCM args
= arg1
; /* list of arguments */
3814 z
= SCM_VELTS (method_cache
)[hash_value
];
3815 while (!SCM_NULLP (args
))
3817 /* More arguments than specifiers => CLASS != ENV */
3818 SCM class_of_arg
= scm_class_of (SCM_CAR (args
));
3819 if (!scm_is_eq (class_of_arg
, SCM_CAR (z
)))
3821 args
= SCM_CDR (args
);
3824 /* Fewer arguments than specifiers => CAR != ENV */
3825 if (SCM_NULLP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
)))
3828 hash_value
= (hash_value
+ 1) & mask
;
3829 } while (hash_value
!= cache_end_pos
);
3831 /* No appropriate method was found in the cache. */
3832 z
= scm_memoize_method (x
, arg1
);
3834 apply_cmethod
: /* inputs: z, arg1 */
3836 SCM formals
= SCM_CMETHOD_FORMALS (z
);
3837 env
= SCM_EXTEND_ENV (formals
, arg1
, SCM_CMETHOD_ENV (z
));
3838 x
= SCM_CMETHOD_BODY (z
);
3839 goto nontoplevel_begin
;
3845 case (ISYMNUM (SCM_IM_SLOT_REF
)):
3848 SCM instance
= EVALCAR (x
, env
);
3849 unsigned long int slot
= SCM_I_INUM (SCM_CDR (x
));
3850 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance
) [slot
]));
3854 case (ISYMNUM (SCM_IM_SLOT_SET_X
)):
3857 SCM instance
= EVALCAR (x
, env
);
3858 unsigned long int slot
= SCM_I_INUM (SCM_CADR (x
));
3859 SCM value
= EVALCAR (SCM_CDDR (x
), env
);
3860 SCM_STRUCT_DATA (instance
) [slot
] = SCM_UNPACK (value
);
3861 RETURN (SCM_UNSPECIFIED
);
3865 #if SCM_ENABLE_ELISP
3867 case (ISYMNUM (SCM_IM_NIL_COND
)):
3869 SCM test_form
= SCM_CDR (x
);
3870 x
= SCM_CDR (test_form
);
3871 while (!SCM_NULL_OR_NIL_P (x
))
3873 SCM test_result
= EVALCAR (test_form
, env
);
3874 if (!(scm_is_false (test_result
)
3875 || SCM_NULL_OR_NIL_P (test_result
)))
3877 if (scm_is_eq (SCM_CAR (x
), SCM_UNSPECIFIED
))
3878 RETURN (test_result
);
3879 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3884 test_form
= SCM_CDR (x
);
3885 x
= SCM_CDR (test_form
);
3889 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3893 #endif /* SCM_ENABLE_ELISP */
3895 case (ISYMNUM (SCM_IM_BIND
)):
3897 SCM vars
, exps
, vals
;
3900 vars
= SCM_CAAR (x
);
3901 exps
= SCM_CDAR (x
);
3903 while (!SCM_NULLP (exps
))
3905 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
3906 exps
= SCM_CDR (exps
);
3909 scm_swap_bindings (vars
, vals
);
3910 scm_dynwinds
= scm_acons (vars
, vals
, scm_dynwinds
);
3912 /* Ignore all but the last evaluation result. */
3913 for (x
= SCM_CDR (x
); !SCM_NULLP (SCM_CDR (x
)); x
= SCM_CDR (x
))
3915 if (SCM_CONSP (SCM_CAR (x
)))
3916 CEVAL (SCM_CAR (x
), env
);
3918 proc
= EVALCAR (x
, env
);
3920 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
3921 scm_swap_bindings (vars
, vals
);
3927 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
3932 producer
= EVALCAR (x
, env
);
3934 proc
= EVALCAR (x
, env
); /* proc is the consumer. */
3935 arg1
= SCM_APPLY (producer
, SCM_EOL
, SCM_EOL
);
3936 if (SCM_VALUESP (arg1
))
3938 /* The list of arguments is not copied. Rather, it is assumed
3939 * that this has been done by the 'values' procedure. */
3940 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
3944 arg1
= scm_list_1 (arg1
);
3946 PREP_APPLY (proc
, arg1
);
3957 if (SCM_VARIABLEP (SCM_CAR (x
)))
3958 proc
= SCM_VARIABLE_REF (SCM_CAR (x
));
3959 else if (SCM_ILOCP (SCM_CAR (x
)))
3960 proc
= *scm_ilookup (SCM_CAR (x
), env
);
3961 else if (SCM_CONSP (SCM_CAR (x
)))
3962 proc
= CEVAL (SCM_CAR (x
), env
);
3963 else if (scm_is_symbol (SCM_CAR (x
)))
3965 SCM orig_sym
= SCM_CAR (x
);
3967 SCM
*location
= scm_lookupcar1 (x
, env
, 1);
3968 if (location
== NULL
)
3970 /* we have lost the race, start again. */
3976 if (SCM_MACROP (proc
))
3978 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
3980 handle_a_macro
: /* inputs: x, env, proc */
3982 /* Set a flag during macro expansion so that macro
3983 application frames can be deleted from the backtrace. */
3984 SCM_SET_MACROEXP (debug
);
3986 arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
3987 scm_cons (env
, scm_listofnull
));
3989 SCM_CLEAR_MACROEXP (debug
);
3991 switch (SCM_MACRO_TYPE (proc
))
3995 if (!SCM_CONSP (arg1
))
3996 arg1
= scm_list_2 (SCM_IM_BEGIN
, arg1
);
3998 assert (!scm_is_eq (x
, SCM_CAR (arg1
))
3999 && !scm_is_eq (x
, SCM_CDR (arg1
)));
4002 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
4005 SCM_SETCAR (x
, SCM_CAR (arg1
));
4006 SCM_SETCDR (x
, SCM_CDR (arg1
));
4010 /* Prevent memoizing of debug info expression. */
4011 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
4016 SCM_SETCAR (x
, SCM_CAR (arg1
));
4017 SCM_SETCDR (x
, SCM_CDR (arg1
));
4019 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
4021 #if SCM_ENABLE_DEPRECATED == 1
4026 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
4040 if (SCM_MACROP (proc
))
4041 goto handle_a_macro
;
4045 /* When reaching this part of the code, the following is granted: Variable x
4046 * holds the first pair of an expression of the form (<function> arg ...).
4047 * Variable proc holds the object that resulted from the evaluation of
4048 * <function>. In the following, the arguments (if any) will be evaluated,
4049 * and proc will be applied to them. If proc does not really hold a
4050 * function object, this will be signalled as an error on the scheme
4051 * level. If the number of arguments does not match the number of arguments
4052 * that are allowed to be passed to proc, also an error on the scheme level
4053 * will be signalled. */
4054 PREP_APPLY (proc
, SCM_EOL
);
4055 if (SCM_NULLP (SCM_CDR (x
))) {
4058 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4059 switch (SCM_TYP7 (proc
))
4060 { /* no arguments given */
4061 case scm_tc7_subr_0
:
4062 RETURN (SCM_SUBRF (proc
) ());
4063 case scm_tc7_subr_1o
:
4064 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
4066 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
4067 case scm_tc7_rpsubr
:
4068 RETURN (SCM_BOOL_T
);
4070 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
4072 if (!SCM_SMOB_APPLICABLE_P (proc
))
4074 RETURN (SCM_SMOB_APPLY_0 (proc
));
4077 proc
= SCM_CCLO_SUBR (proc
);
4079 debug
.info
->a
.proc
= proc
;
4080 debug
.info
->a
.args
= scm_list_1 (arg1
);
4084 proc
= SCM_PROCEDURE (proc
);
4086 debug
.info
->a
.proc
= proc
;
4088 if (!SCM_CLOSUREP (proc
))
4091 case scm_tcs_closures
:
4093 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4094 if (SCM_CONSP (formals
))
4096 x
= SCM_CLOSURE_BODY (proc
);
4097 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
4098 goto nontoplevel_begin
;
4100 case scm_tcs_struct
:
4101 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4103 x
= SCM_ENTITY_PROCEDURE (proc
);
4107 else if (SCM_I_OPERATORP (proc
))
4110 proc
= (SCM_I_ENTITYP (proc
)
4111 ? SCM_ENTITY_PROCEDURE (proc
)
4112 : SCM_OPERATOR_PROCEDURE (proc
));
4114 debug
.info
->a
.proc
= proc
;
4115 debug
.info
->a
.args
= scm_list_1 (arg1
);
4121 case scm_tc7_subr_1
:
4122 case scm_tc7_subr_2
:
4123 case scm_tc7_subr_2o
:
4126 case scm_tc7_subr_3
:
4127 case scm_tc7_lsubr_2
:
4129 scm_wrong_num_args (proc
);
4132 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
4136 /* must handle macros by here */
4139 arg1
= EVALCAR (x
, env
);
4141 scm_wrong_num_args (proc
);
4143 debug
.info
->a
.args
= scm_list_1 (arg1
);
4151 evap1
: /* inputs: proc, arg1 */
4152 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4153 switch (SCM_TYP7 (proc
))
4154 { /* have one argument in arg1 */
4155 case scm_tc7_subr_2o
:
4156 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4157 case scm_tc7_subr_1
:
4158 case scm_tc7_subr_1o
:
4159 RETURN (SCM_SUBRF (proc
) (arg1
));
4161 if (SCM_I_INUMP (arg1
))
4163 RETURN (scm_from_double (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
))));
4165 else if (SCM_REALP (arg1
))
4167 RETURN (scm_from_double (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4169 else if (SCM_BIGP (arg1
))
4171 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4173 else if (SCM_FRACTIONP (arg1
))
4175 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4177 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4179 scm_i_symbol_chars (SCM_SNAME (proc
)));
4182 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
4185 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
4186 scm_i_symbol_chars (SCM_SNAME (proc
)));
4187 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
4192 case scm_tc7_rpsubr
:
4193 RETURN (SCM_BOOL_T
);
4195 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4198 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4200 RETURN (SCM_SUBRF (proc
) (scm_list_1 (arg1
)));
4203 if (!SCM_SMOB_APPLICABLE_P (proc
))
4205 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
4209 proc
= SCM_CCLO_SUBR (proc
);
4211 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
4212 debug
.info
->a
.proc
= proc
;
4216 proc
= SCM_PROCEDURE (proc
);
4218 debug
.info
->a
.proc
= proc
;
4220 if (!SCM_CLOSUREP (proc
))
4223 case scm_tcs_closures
:
4226 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4227 if (SCM_NULLP (formals
)
4228 || (SCM_CONSP (formals
) && SCM_CONSP (SCM_CDR (formals
))))
4230 x
= SCM_CLOSURE_BODY (proc
);
4232 env
= SCM_EXTEND_ENV (formals
,
4236 env
= SCM_EXTEND_ENV (formals
,
4240 goto nontoplevel_begin
;
4242 case scm_tcs_struct
:
4243 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4245 x
= SCM_ENTITY_PROCEDURE (proc
);
4247 arg1
= debug
.info
->a
.args
;
4249 arg1
= scm_list_1 (arg1
);
4253 else if (SCM_I_OPERATORP (proc
))
4257 proc
= (SCM_I_ENTITYP (proc
)
4258 ? SCM_ENTITY_PROCEDURE (proc
)
4259 : SCM_OPERATOR_PROCEDURE (proc
));
4261 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
4262 debug
.info
->a
.proc
= proc
;
4268 case scm_tc7_subr_2
:
4269 case scm_tc7_subr_0
:
4270 case scm_tc7_subr_3
:
4271 case scm_tc7_lsubr_2
:
4272 scm_wrong_num_args (proc
);
4278 arg2
= EVALCAR (x
, env
);
4280 scm_wrong_num_args (proc
);
4282 { /* have two or more arguments */
4284 debug
.info
->a
.args
= scm_list_2 (arg1
, arg2
);
4287 if (SCM_NULLP (x
)) {
4290 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4291 switch (SCM_TYP7 (proc
))
4292 { /* have two arguments */
4293 case scm_tc7_subr_2
:
4294 case scm_tc7_subr_2o
:
4295 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
4298 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4300 RETURN (SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
)));
4302 case scm_tc7_lsubr_2
:
4303 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
));
4304 case scm_tc7_rpsubr
:
4306 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
4308 if (!SCM_SMOB_APPLICABLE_P (proc
))
4310 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
));
4314 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
4315 scm_cons (proc
, debug
.info
->a
.args
),
4318 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
4319 scm_cons2 (proc
, arg1
,
4326 case scm_tcs_struct
:
4327 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4329 x
= SCM_ENTITY_PROCEDURE (proc
);
4331 arg1
= debug
.info
->a
.args
;
4333 arg1
= scm_list_2 (arg1
, arg2
);
4337 else if (SCM_I_OPERATORP (proc
))
4341 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
4342 ? SCM_ENTITY_PROCEDURE (proc
)
4343 : SCM_OPERATOR_PROCEDURE (proc
),
4344 scm_cons (proc
, debug
.info
->a
.args
),
4347 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
4348 ? SCM_ENTITY_PROCEDURE (proc
)
4349 : SCM_OPERATOR_PROCEDURE (proc
),
4350 scm_cons2 (proc
, arg1
,
4360 case scm_tc7_subr_0
:
4363 case scm_tc7_subr_1o
:
4364 case scm_tc7_subr_1
:
4365 case scm_tc7_subr_3
:
4366 scm_wrong_num_args (proc
);
4370 proc
= SCM_PROCEDURE (proc
);
4372 debug
.info
->a
.proc
= proc
;
4374 if (!SCM_CLOSUREP (proc
))
4377 case scm_tcs_closures
:
4380 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4381 if (SCM_NULLP (formals
)
4382 || (SCM_CONSP (formals
)
4383 && (SCM_NULLP (SCM_CDR (formals
))
4384 || (SCM_CONSP (SCM_CDR (formals
))
4385 && SCM_CONSP (SCM_CDDR (formals
))))))
4388 env
= SCM_EXTEND_ENV (formals
,
4392 env
= SCM_EXTEND_ENV (formals
,
4393 scm_list_2 (arg1
, arg2
),
4396 x
= SCM_CLOSURE_BODY (proc
);
4397 goto nontoplevel_begin
;
4402 scm_wrong_num_args (proc
);
4404 debug
.info
->a
.args
= scm_cons2 (arg1
, arg2
,
4405 deval_args (x
, env
, proc
,
4406 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
4410 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4411 switch (SCM_TYP7 (proc
))
4412 { /* have 3 or more arguments */
4414 case scm_tc7_subr_3
:
4415 if (!SCM_NULLP (SCM_CDR (x
)))
4416 scm_wrong_num_args (proc
);
4418 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4419 SCM_CADDR (debug
.info
->a
.args
)));
4421 arg1
= SCM_SUBRF(proc
)(arg1
, arg2
);
4422 arg2
= SCM_CDDR (debug
.info
->a
.args
);
4425 arg1
= SCM_SUBRF(proc
)(arg1
, SCM_CAR (arg2
));
4426 arg2
= SCM_CDR (arg2
);
4428 while (SCM_NIMP (arg2
));
4430 case scm_tc7_rpsubr
:
4431 if (scm_is_false (SCM_SUBRF (proc
) (arg1
, arg2
)))
4432 RETURN (SCM_BOOL_F
);
4433 arg1
= SCM_CDDR (debug
.info
->a
.args
);
4436 if (scm_is_false (SCM_SUBRF (proc
) (arg2
, SCM_CAR (arg1
))))
4437 RETURN (SCM_BOOL_F
);
4438 arg2
= SCM_CAR (arg1
);
4439 arg1
= SCM_CDR (arg1
);
4441 while (SCM_NIMP (arg1
));
4442 RETURN (SCM_BOOL_T
);
4443 case scm_tc7_lsubr_2
:
4444 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4445 SCM_CDDR (debug
.info
->a
.args
)));
4447 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4449 if (!SCM_SMOB_APPLICABLE_P (proc
))
4451 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4452 SCM_CDDR (debug
.info
->a
.args
)));
4456 proc
= SCM_PROCEDURE (proc
);
4457 debug
.info
->a
.proc
= proc
;
4458 if (!SCM_CLOSUREP (proc
))
4461 case scm_tcs_closures
:
4463 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4464 if (SCM_NULLP (formals
)
4465 || (SCM_CONSP (formals
)
4466 && (SCM_NULLP (SCM_CDR (formals
))
4467 || (SCM_CONSP (SCM_CDR (formals
))
4468 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4470 SCM_SET_ARGSREADY (debug
);
4471 env
= SCM_EXTEND_ENV (formals
,
4474 x
= SCM_CLOSURE_BODY (proc
);
4475 goto nontoplevel_begin
;
4478 case scm_tc7_subr_3
:
4479 if (!SCM_NULLP (SCM_CDR (x
)))
4480 scm_wrong_num_args (proc
);
4482 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, EVALCAR (x
, env
)));
4484 arg1
= SCM_SUBRF (proc
) (arg1
, arg2
);
4487 arg1
= SCM_SUBRF(proc
)(arg1
, EVALCAR(x
, env
));
4490 while (!SCM_NULLP (x
));
4492 case scm_tc7_rpsubr
:
4493 if (scm_is_false (SCM_SUBRF (proc
) (arg1
, arg2
)))
4494 RETURN (SCM_BOOL_F
);
4497 arg1
= EVALCAR (x
, env
);
4498 if (scm_is_false (SCM_SUBRF (proc
) (arg2
, arg1
)))
4499 RETURN (SCM_BOOL_F
);
4503 while (!SCM_NULLP (x
));
4504 RETURN (SCM_BOOL_T
);
4505 case scm_tc7_lsubr_2
:
4506 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
4508 RETURN (SCM_SUBRF (proc
) (scm_cons2 (arg1
,
4510 scm_eval_args (x
, env
, proc
))));
4512 if (!SCM_SMOB_APPLICABLE_P (proc
))
4514 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4515 scm_eval_args (x
, env
, proc
)));
4519 proc
= SCM_PROCEDURE (proc
);
4520 if (!SCM_CLOSUREP (proc
))
4523 case scm_tcs_closures
:
4525 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4526 if (SCM_NULLP (formals
)
4527 || (SCM_CONSP (formals
)
4528 && (SCM_NULLP (SCM_CDR (formals
))
4529 || (SCM_CONSP (SCM_CDR (formals
))
4530 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4532 env
= SCM_EXTEND_ENV (formals
,
4535 scm_eval_args (x
, env
, proc
)),
4537 x
= SCM_CLOSURE_BODY (proc
);
4538 goto nontoplevel_begin
;
4541 case scm_tcs_struct
:
4542 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4545 arg1
= debug
.info
->a
.args
;
4547 arg1
= scm_cons2 (arg1
, arg2
, scm_eval_args (x
, env
, proc
));
4549 x
= SCM_ENTITY_PROCEDURE (proc
);
4552 else if (SCM_I_OPERATORP (proc
))
4556 case scm_tc7_subr_2
:
4557 case scm_tc7_subr_1o
:
4558 case scm_tc7_subr_2o
:
4559 case scm_tc7_subr_0
:
4562 case scm_tc7_subr_1
:
4563 scm_wrong_num_args (proc
);
4571 if (scm_check_exit_p
&& SCM_TRAPS_P
)
4572 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
4574 SCM_CLEAR_TRACED_FRAME (debug
);
4575 if (SCM_CHEAPTRAPS_P
)
4576 arg1
= scm_make_debugobj (&debug
);
4580 SCM val
= scm_make_continuation (&first
);
4591 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
4595 scm_last_debug_frame
= debug
.prev
;
4601 /* SECTION: This code is compiled once.
4608 /* Simple procedure calls
4612 scm_call_0 (SCM proc
)
4614 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
4618 scm_call_1 (SCM proc
, SCM arg1
)
4620 return scm_apply (proc
, arg1
, scm_listofnull
);
4624 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
4626 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
4630 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
4632 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
4636 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
4638 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
4639 scm_cons (arg4
, scm_listofnull
)));
4642 /* Simple procedure applies
4646 scm_apply_0 (SCM proc
, SCM args
)
4648 return scm_apply (proc
, args
, SCM_EOL
);
4652 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
4654 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
4658 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
4660 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
4664 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
4666 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
4670 /* This code processes the arguments to apply:
4672 (apply PROC ARG1 ... ARGS)
4674 Given a list (ARG1 ... ARGS), this function conses the ARG1
4675 ... arguments onto the front of ARGS, and returns the resulting
4676 list. Note that ARGS is a list; thus, the argument to this
4677 function is a list whose last element is a list.
4679 Apply calls this function, and applies PROC to the elements of the
4680 result. apply:nconc2last takes care of building the list of
4681 arguments, given (ARG1 ... ARGS).
4683 Rather than do new consing, apply:nconc2last destroys its argument.
4684 On that topic, this code came into my care with the following
4685 beautifully cryptic comment on that topic: "This will only screw
4686 you if you do (scm_apply scm_apply '( ... ))" If you know what
4687 they're referring to, send me a patch to this comment. */
4689 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
4691 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
4692 "conses the @var{arg1} @dots{} arguments onto the front of\n"
4693 "@var{args}, and returns the resulting list. Note that\n"
4694 "@var{args} is a list; thus, the argument to this function is\n"
4695 "a list whose last element is a list.\n"
4696 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
4697 "destroys its argument, so use with care.")
4698 #define FUNC_NAME s_scm_nconc2last
4701 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
4703 while (!SCM_NULLP (SCM_CDR (*lloc
))) /* Perhaps should be
4704 SCM_NULL_OR_NIL_P, but not
4705 needed in 99.99% of cases,
4706 and it could seriously hurt
4707 performance. - Neil */
4708 lloc
= SCM_CDRLOC (*lloc
);
4709 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
4710 *lloc
= SCM_CAR (*lloc
);
4718 /* SECTION: When DEVAL is defined this code yields scm_dapply.
4719 * It is compiled twice.
4724 scm_apply (SCM proc
, SCM arg1
, SCM args
)
4730 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
4735 /* Apply a function to a list of arguments.
4737 This function is exported to the Scheme level as taking two
4738 required arguments and a tail argument, as if it were:
4739 (lambda (proc arg1 . args) ...)
4740 Thus, if you just have a list of arguments to pass to a procedure,
4741 pass the list as ARG1, and '() for ARGS. If you have some fixed
4742 args, pass the first as ARG1, then cons any remaining fixed args
4743 onto the front of your argument list, and pass that as ARGS. */
4746 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
4749 scm_t_debug_frame debug
;
4750 scm_t_debug_info debug_vect_body
;
4751 debug
.prev
= scm_last_debug_frame
;
4752 debug
.status
= SCM_APPLYFRAME
;
4753 debug
.vect
= &debug_vect_body
;
4754 debug
.vect
[0].a
.proc
= proc
;
4755 debug
.vect
[0].a
.args
= SCM_EOL
;
4756 scm_last_debug_frame
= &debug
;
4758 if (scm_debug_mode_p
)
4759 return scm_dapply (proc
, arg1
, args
);
4762 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
4764 /* If ARGS is the empty list, then we're calling apply with only two
4765 arguments --- ARG1 is the list of arguments for PROC. Whatever
4766 the case, futz with things so that ARG1 is the first argument to
4767 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
4770 Setting the debug apply frame args this way is pretty messy.
4771 Perhaps we should store arg1 and args directly in the frame as
4772 received, and let scm_frame_arguments unpack them, because that's
4773 a relatively rare operation. This works for now; if the Guile
4774 developer archives are still around, see Mikael's post of
4776 if (SCM_NULLP (args
))
4778 if (SCM_NULLP (arg1
))
4780 arg1
= SCM_UNDEFINED
;
4782 debug
.vect
[0].a
.args
= SCM_EOL
;
4788 debug
.vect
[0].a
.args
= arg1
;
4790 args
= SCM_CDR (arg1
);
4791 arg1
= SCM_CAR (arg1
);
4796 args
= scm_nconc2last (args
);
4798 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4802 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
4805 if (SCM_CHEAPTRAPS_P
)
4806 tmp
= scm_make_debugobj (&debug
);
4811 tmp
= scm_make_continuation (&first
);
4816 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
4823 switch (SCM_TYP7 (proc
))
4825 case scm_tc7_subr_2o
:
4826 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
4827 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4828 case scm_tc7_subr_2
:
4829 if (SCM_NULLP (args
) || !SCM_NULLP (SCM_CDR (args
)))
4830 scm_wrong_num_args (proc
);
4831 args
= SCM_CAR (args
);
4832 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4833 case scm_tc7_subr_0
:
4834 if (!SCM_UNBNDP (arg1
))
4835 scm_wrong_num_args (proc
);
4837 RETURN (SCM_SUBRF (proc
) ());
4838 case scm_tc7_subr_1
:
4839 if (SCM_UNBNDP (arg1
))
4840 scm_wrong_num_args (proc
);
4841 case scm_tc7_subr_1o
:
4842 if (!SCM_NULLP (args
))
4843 scm_wrong_num_args (proc
);
4845 RETURN (SCM_SUBRF (proc
) (arg1
));
4847 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
4848 scm_wrong_num_args (proc
);
4849 if (SCM_I_INUMP (arg1
))
4851 RETURN (scm_from_double (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
))));
4853 else if (SCM_REALP (arg1
))
4855 RETURN (scm_from_double (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4857 else if (SCM_BIGP (arg1
))
4859 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4861 else if (SCM_FRACTIONP (arg1
))
4863 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4865 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4866 SCM_ARG1
, scm_i_symbol_chars (SCM_SNAME (proc
)));
4868 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
4869 scm_wrong_num_args (proc
);
4871 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
4874 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
4875 scm_i_symbol_chars (SCM_SNAME (proc
)));
4876 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
4881 case scm_tc7_subr_3
:
4882 if (SCM_NULLP (args
)
4883 || SCM_NULLP (SCM_CDR (args
))
4884 || !SCM_NULLP (SCM_CDDR (args
)))
4885 scm_wrong_num_args (proc
);
4887 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
4890 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
4892 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
4894 case scm_tc7_lsubr_2
:
4895 if (!SCM_CONSP (args
))
4896 scm_wrong_num_args (proc
);
4898 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4900 if (SCM_NULLP (args
))
4901 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4902 while (SCM_NIMP (args
))
4904 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
4905 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
4906 args
= SCM_CDR (args
);
4909 case scm_tc7_rpsubr
:
4910 if (SCM_NULLP (args
))
4911 RETURN (SCM_BOOL_T
);
4912 while (SCM_NIMP (args
))
4914 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
4915 if (scm_is_false (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
4916 RETURN (SCM_BOOL_F
);
4917 arg1
= SCM_CAR (args
);
4918 args
= SCM_CDR (args
);
4920 RETURN (SCM_BOOL_T
);
4921 case scm_tcs_closures
:
4923 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4925 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4927 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
4928 scm_wrong_num_args (proc
);
4930 /* Copy argument list */
4935 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
4936 for (arg1
= SCM_CDR (arg1
); SCM_CONSP (arg1
); arg1
= SCM_CDR (arg1
))
4938 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
));
4941 SCM_SETCDR (tl
, arg1
);
4944 args
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4947 proc
= SCM_CLOSURE_BODY (proc
);
4949 arg1
= SCM_CDR (proc
);
4950 while (!SCM_NULLP (arg1
))
4952 if (SCM_IMP (SCM_CAR (proc
)))
4954 if (SCM_ISYMP (SCM_CAR (proc
)))
4956 scm_rec_mutex_lock (&source_mutex
);
4957 /* check for race condition */
4958 if (SCM_ISYMP (SCM_CAR (proc
)))
4959 m_expand_body (proc
, args
);
4960 scm_rec_mutex_unlock (&source_mutex
);
4964 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
4967 (void) EVAL (SCM_CAR (proc
), args
);
4969 arg1
= SCM_CDR (proc
);
4971 RETURN (EVALCAR (proc
, args
));
4973 if (!SCM_SMOB_APPLICABLE_P (proc
))
4975 if (SCM_UNBNDP (arg1
))
4976 RETURN (SCM_SMOB_APPLY_0 (proc
));
4977 else if (SCM_NULLP (args
))
4978 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
4979 else if (SCM_NULLP (SCM_CDR (args
)))
4980 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
4982 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4985 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4987 proc
= SCM_CCLO_SUBR (proc
);
4988 debug
.vect
[0].a
.proc
= proc
;
4989 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4991 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4993 proc
= SCM_CCLO_SUBR (proc
);
4997 proc
= SCM_PROCEDURE (proc
);
4999 debug
.vect
[0].a
.proc
= proc
;
5002 case scm_tcs_struct
:
5003 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5006 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
5008 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
5010 RETURN (scm_apply_generic (proc
, args
));
5012 else if (SCM_I_OPERATORP (proc
))
5016 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
5018 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
5021 proc
= (SCM_I_ENTITYP (proc
)
5022 ? SCM_ENTITY_PROCEDURE (proc
)
5023 : SCM_OPERATOR_PROCEDURE (proc
));
5025 debug
.vect
[0].a
.proc
= proc
;
5026 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
5028 if (SCM_NIMP (proc
))
5037 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
5041 if (scm_check_exit_p
&& SCM_TRAPS_P
)
5042 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
5044 SCM_CLEAR_TRACED_FRAME (debug
);
5045 if (SCM_CHEAPTRAPS_P
)
5046 arg1
= scm_make_debugobj (&debug
);
5050 SCM val
= scm_make_continuation (&first
);
5061 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
5065 scm_last_debug_frame
= debug
.prev
;
5071 /* SECTION: The rest of this file is only read once.
5078 * Trampolines make it possible to move procedure application dispatch
5079 * outside inner loops. The motivation was clean implementation of
5080 * efficient replacements of R5RS primitives in SRFI-1.
5082 * The semantics is clear: scm_trampoline_N returns an optimized
5083 * version of scm_call_N (or NULL if the procedure isn't applicable
5086 * Applying the optimization to map and for-each increased efficiency
5087 * noticeably. For example, (map abs ls) is now 8 times faster than
5092 call_subr0_0 (SCM proc
)
5094 return SCM_SUBRF (proc
) ();
5098 call_subr1o_0 (SCM proc
)
5100 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
5104 call_lsubr_0 (SCM proc
)
5106 return SCM_SUBRF (proc
) (SCM_EOL
);
5110 scm_i_call_closure_0 (SCM proc
)
5112 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
5115 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
5120 scm_trampoline_0 (SCM proc
)
5122 scm_t_trampoline_0 trampoline
;
5127 switch (SCM_TYP7 (proc
))
5129 case scm_tc7_subr_0
:
5130 trampoline
= call_subr0_0
;
5132 case scm_tc7_subr_1o
:
5133 trampoline
= call_subr1o_0
;
5136 trampoline
= call_lsubr_0
;
5138 case scm_tcs_closures
:
5140 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5141 if (SCM_NULLP (formals
) || !SCM_CONSP (formals
))
5142 trampoline
= scm_i_call_closure_0
;
5147 case scm_tcs_struct
:
5148 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5149 trampoline
= scm_call_generic_0
;
5150 else if (SCM_I_OPERATORP (proc
))
5151 trampoline
= scm_call_0
;
5156 if (SCM_SMOB_APPLICABLE_P (proc
))
5157 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
5162 case scm_tc7_rpsubr
:
5165 trampoline
= scm_call_0
;
5168 return NULL
; /* not applicable on zero arguments */
5170 /* We only reach this point if a valid trampoline was determined. */
5172 /* If debugging is enabled, we want to see all calls to proc on the stack.
5173 * Thus, we replace the trampoline shortcut with scm_call_0. */
5174 if (scm_debug_mode_p
)
5181 call_subr1_1 (SCM proc
, SCM arg1
)
5183 return SCM_SUBRF (proc
) (arg1
);
5187 call_subr2o_1 (SCM proc
, SCM arg1
)
5189 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
5193 call_lsubr_1 (SCM proc
, SCM arg1
)
5195 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
5199 call_dsubr_1 (SCM proc
, SCM arg1
)
5201 if (SCM_I_INUMP (arg1
))
5203 RETURN (scm_from_double (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
))));
5205 else if (SCM_REALP (arg1
))
5207 RETURN (scm_from_double (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
5209 else if (SCM_BIGP (arg1
))
5211 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
5213 else if (SCM_FRACTIONP (arg1
))
5215 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
5217 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
5218 SCM_ARG1
, scm_i_symbol_chars (SCM_SNAME (proc
)));
5222 call_cxr_1 (SCM proc
, SCM arg1
)
5224 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
5227 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
5228 scm_i_symbol_chars (SCM_SNAME (proc
)));
5229 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
5236 call_closure_1 (SCM proc
, SCM arg1
)
5238 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
5241 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
5246 scm_trampoline_1 (SCM proc
)
5248 scm_t_trampoline_1 trampoline
;
5253 switch (SCM_TYP7 (proc
))
5255 case scm_tc7_subr_1
:
5256 case scm_tc7_subr_1o
:
5257 trampoline
= call_subr1_1
;
5259 case scm_tc7_subr_2o
:
5260 trampoline
= call_subr2o_1
;
5263 trampoline
= call_lsubr_1
;
5266 trampoline
= call_dsubr_1
;
5269 trampoline
= call_cxr_1
;
5271 case scm_tcs_closures
:
5273 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5274 if (!SCM_NULLP (formals
)
5275 && (!SCM_CONSP (formals
) || !SCM_CONSP (SCM_CDR (formals
))))
5276 trampoline
= call_closure_1
;
5281 case scm_tcs_struct
:
5282 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5283 trampoline
= scm_call_generic_1
;
5284 else if (SCM_I_OPERATORP (proc
))
5285 trampoline
= scm_call_1
;
5290 if (SCM_SMOB_APPLICABLE_P (proc
))
5291 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
5296 case scm_tc7_rpsubr
:
5299 trampoline
= scm_call_1
;
5302 return NULL
; /* not applicable on one arg */
5304 /* We only reach this point if a valid trampoline was determined. */
5306 /* If debugging is enabled, we want to see all calls to proc on the stack.
5307 * Thus, we replace the trampoline shortcut with scm_call_1. */
5308 if (scm_debug_mode_p
)
5315 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
5317 return SCM_SUBRF (proc
) (arg1
, arg2
);
5321 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
5323 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
5327 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
5329 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
5333 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
5335 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
5336 scm_list_2 (arg1
, arg2
),
5338 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
5343 scm_trampoline_2 (SCM proc
)
5345 scm_t_trampoline_2 trampoline
;
5350 switch (SCM_TYP7 (proc
))
5352 case scm_tc7_subr_2
:
5353 case scm_tc7_subr_2o
:
5354 case scm_tc7_rpsubr
:
5356 trampoline
= call_subr2_2
;
5358 case scm_tc7_lsubr_2
:
5359 trampoline
= call_lsubr2_2
;
5362 trampoline
= call_lsubr_2
;
5364 case scm_tcs_closures
:
5366 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5367 if (!SCM_NULLP (formals
)
5368 && (!SCM_CONSP (formals
)
5369 || (!SCM_NULLP (SCM_CDR (formals
))
5370 && (!SCM_CONSP (SCM_CDR (formals
))
5371 || !SCM_CONSP (SCM_CDDR (formals
))))))
5372 trampoline
= call_closure_2
;
5377 case scm_tcs_struct
:
5378 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5379 trampoline
= scm_call_generic_2
;
5380 else if (SCM_I_OPERATORP (proc
))
5381 trampoline
= scm_call_2
;
5386 if (SCM_SMOB_APPLICABLE_P (proc
))
5387 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
5393 trampoline
= scm_call_2
;
5396 return NULL
; /* not applicable on two args */
5398 /* We only reach this point if a valid trampoline was determined. */
5400 /* If debugging is enabled, we want to see all calls to proc on the stack.
5401 * Thus, we replace the trampoline shortcut with scm_call_2. */
5402 if (scm_debug_mode_p
)
5408 /* Typechecking for multi-argument MAP and FOR-EACH.
5410 Verify that each element of the vector ARGV, except for the first,
5411 is a proper list whose length is LEN. Attribute errors to WHO,
5412 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
5414 check_map_args (SCM argv
,
5421 SCM
const *ve
= SCM_VELTS (argv
);
5424 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
5426 long elt_len
= scm_ilength (ve
[i
]);
5431 scm_apply_generic (gf
, scm_cons (proc
, args
));
5433 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
5437 scm_out_of_range_pos (who
, ve
[i
], scm_from_long (i
+ 2));
5440 scm_remember_upto_here_1 (argv
);
5444 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
5446 /* Note: Currently, scm_map applies PROC to the argument list(s)
5447 sequentially, starting with the first element(s). This is used in
5448 evalext.c where the Scheme procedure `map-in-order', which guarantees
5449 sequential behaviour, is implemented using scm_map. If the
5450 behaviour changes, we need to update `map-in-order'.
5454 scm_map (SCM proc
, SCM arg1
, SCM args
)
5455 #define FUNC_NAME s_map
5460 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
5462 len
= scm_ilength (arg1
);
5463 SCM_GASSERTn (len
>= 0,
5464 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
5465 SCM_VALIDATE_REST_ARGUMENT (args
);
5466 if (SCM_NULLP (args
))
5468 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5469 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
5470 while (SCM_NIMP (arg1
))
5472 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
5473 pres
= SCM_CDRLOC (*pres
);
5474 arg1
= SCM_CDR (arg1
);
5478 if (SCM_NULLP (SCM_CDR (args
)))
5480 SCM arg2
= SCM_CAR (args
);
5481 int len2
= scm_ilength (arg2
);
5482 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5484 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
5485 SCM_GASSERTn (len2
>= 0,
5486 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
5488 SCM_OUT_OF_RANGE (3, arg2
);
5489 while (SCM_NIMP (arg1
))
5491 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
5492 pres
= SCM_CDRLOC (*pres
);
5493 arg1
= SCM_CDR (arg1
);
5494 arg2
= SCM_CDR (arg2
);
5498 arg1
= scm_cons (arg1
, args
);
5499 args
= scm_vector (arg1
);
5500 ve
= SCM_VELTS (args
);
5501 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
5505 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5507 if (SCM_IMP (ve
[i
]))
5509 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
5510 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
5512 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
5513 pres
= SCM_CDRLOC (*pres
);
5519 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
5522 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
5523 #define FUNC_NAME s_for_each
5525 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
5527 len
= scm_ilength (arg1
);
5528 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
5529 SCM_ARG2
, s_for_each
);
5530 SCM_VALIDATE_REST_ARGUMENT (args
);
5531 if (SCM_NULLP (args
))
5533 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5534 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
5535 while (SCM_NIMP (arg1
))
5537 call (proc
, SCM_CAR (arg1
));
5538 arg1
= SCM_CDR (arg1
);
5540 return SCM_UNSPECIFIED
;
5542 if (SCM_NULLP (SCM_CDR (args
)))
5544 SCM arg2
= SCM_CAR (args
);
5545 int len2
= scm_ilength (arg2
);
5546 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5547 SCM_GASSERTn (call
, g_for_each
,
5548 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
5549 SCM_GASSERTn (len2
>= 0, g_for_each
,
5550 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
5552 SCM_OUT_OF_RANGE (3, arg2
);
5553 while (SCM_NIMP (arg1
))
5555 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
5556 arg1
= SCM_CDR (arg1
);
5557 arg2
= SCM_CDR (arg2
);
5559 return SCM_UNSPECIFIED
;
5561 arg1
= scm_cons (arg1
, args
);
5562 args
= scm_vector (arg1
);
5563 ve
= SCM_VELTS (args
);
5564 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
5568 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5570 if (SCM_IMP (ve
[i
]))
5571 return SCM_UNSPECIFIED
;
5572 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
5573 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
5575 scm_apply (proc
, arg1
, SCM_EOL
);
5582 scm_closure (SCM code
, SCM env
)
5585 SCM closcar
= scm_cons (code
, SCM_EOL
);
5586 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
5587 scm_remember_upto_here (closcar
);
5592 scm_t_bits scm_tc16_promise
;
5595 scm_makprom (SCM code
)
5597 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
5599 scm_make_rec_mutex ());
5603 promise_free (SCM promise
)
5605 scm_rec_mutex_free (SCM_PROMISE_MUTEX (promise
));
5610 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
5612 int writingp
= SCM_WRITINGP (pstate
);
5613 scm_puts ("#<promise ", port
);
5614 SCM_SET_WRITINGP (pstate
, 1);
5615 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
5616 SCM_SET_WRITINGP (pstate
, writingp
);
5617 scm_putc ('>', port
);
5621 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
5623 "If the promise @var{x} has not been computed yet, compute and\n"
5624 "return @var{x}, otherwise just return the previously computed\n"
5626 #define FUNC_NAME s_scm_force
5628 SCM_VALIDATE_SMOB (1, promise
, promise
);
5629 scm_rec_mutex_lock (SCM_PROMISE_MUTEX (promise
));
5630 if (!SCM_PROMISE_COMPUTED_P (promise
))
5632 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
5633 if (!SCM_PROMISE_COMPUTED_P (promise
))
5635 SCM_SET_PROMISE_DATA (promise
, ans
);
5636 SCM_SET_PROMISE_COMPUTED (promise
);
5639 scm_rec_mutex_unlock (SCM_PROMISE_MUTEX (promise
));
5640 return SCM_PROMISE_DATA (promise
);
5645 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
5647 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
5648 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
5649 #define FUNC_NAME s_scm_promise_p
5651 return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
5656 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
5657 (SCM xorig
, SCM x
, SCM y
),
5658 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
5659 "Any source properties associated with @var{xorig} are also associated\n"
5660 "with the new pair.")
5661 #define FUNC_NAME s_scm_cons_source
5664 z
= scm_cons (x
, y
);
5665 /* Copy source properties possibly associated with xorig. */
5666 p
= scm_whash_lookup (scm_source_whash
, xorig
);
5667 if (scm_is_true (p
))
5668 scm_whash_insert (scm_source_whash
, z
, p
);
5674 /* The function scm_copy_tree is used to copy an expression tree to allow the
5675 * memoizer to modify the expression during memoization. scm_copy_tree
5676 * creates deep copies of pairs and vectors, but not of any other data types,
5677 * since only pairs and vectors will be parsed by the memoizer.
5679 * To avoid infinite recursion due to cyclic structures, the hare-and-tortoise
5680 * pattern is used to detect cycles. In fact, the pattern is used in two
5681 * dimensions, vertical (indicated in the code by the variable names 'hare'
5682 * and 'tortoise') and horizontal ('rabbit' and 'turtle'). In both
5683 * dimensions, the hare/rabbit will take two steps when the tortoise/turtle
5686 * The vertical dimension corresponds to recursive calls to function
5687 * copy_tree: This happens when descending into vector elements, into cars of
5688 * lists and into the cdr of an improper list. In this dimension, the
5689 * tortoise follows the hare by using the processor stack: Every stack frame
5690 * will hold an instance of struct t_trace. These instances are connected in
5691 * a way that represents the trace of the hare, which thus can be followed by
5692 * the tortoise. The tortoise will always point to struct t_trace instances
5693 * relating to SCM objects that have already been copied. Thus, a cycle is
5694 * detected if the tortoise and the hare point to the same object,
5696 * The horizontal dimension is within one execution of copy_tree, when the
5697 * function cdr's along the pairs of a list. This is the standard
5698 * hare-and-tortoise implementation, found several times in guile. */
5701 struct t_trace
*trace
; // These pointers form a trace along the stack.
5702 SCM obj
; // The object handled at the respective stack frame.
5707 struct t_trace
*const hare
,
5708 struct t_trace
*tortoise
,
5709 unsigned int tortoise_delay
)
5711 if (!SCM_CONSP (hare
->obj
) && !SCM_VECTORP (hare
->obj
))
5717 /* Prepare the trace along the stack. */
5718 struct t_trace new_hare
;
5719 hare
->trace
= &new_hare
;
5721 /* The tortoise will make its step after the delay has elapsed. Note
5722 * that in contrast to the typical hare-and-tortoise pattern, the step
5723 * of the tortoise happens before the hare takes its steps. This is, in
5724 * principle, no problem, except for the start of the algorithm: Then,
5725 * it has to be made sure that the hare actually gets its advantage of
5727 if (tortoise_delay
== 0)
5730 tortoise
= tortoise
->trace
;
5731 ASSERT_SYNTAX (!scm_is_eq (hare
->obj
, tortoise
->obj
),
5732 s_bad_expression
, hare
->obj
);
5739 if (SCM_VECTORP (hare
->obj
))
5741 const unsigned long int length
= SCM_VECTOR_LENGTH (hare
->obj
);
5742 const SCM new_vector
= scm_c_make_vector (length
, SCM_UNSPECIFIED
);
5744 /* Each vector element is copied by recursing into copy_tree, having
5745 * the tortoise follow the hare into the depths of the stack. */
5746 unsigned long int i
;
5747 for (i
= 0; i
< length
; ++i
)
5750 new_hare
.obj
= SCM_VECTOR_REF (hare
->obj
, i
);
5751 new_element
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5752 SCM_VECTOR_SET (new_vector
, i
, new_element
);
5757 else // SCM_CONSP (hare->obj)
5762 SCM rabbit
= hare
->obj
;
5763 SCM turtle
= hare
->obj
;
5767 /* The first pair of the list is treated specially, in order to
5768 * preserve a potential source code position. */
5769 result
= tail
= scm_cons_source (rabbit
, SCM_EOL
, SCM_EOL
);
5770 new_hare
.obj
= SCM_CAR (rabbit
);
5771 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5772 SCM_SETCAR (tail
, copy
);
5774 /* The remaining pairs of the list are copied by, horizontally,
5775 * having the turtle follow the rabbit, and, vertically, having the
5776 * tortoise follow the hare into the depths of the stack. */
5777 rabbit
= SCM_CDR (rabbit
);
5778 while (SCM_CONSP (rabbit
))
5780 new_hare
.obj
= SCM_CAR (rabbit
);
5781 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5782 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
5783 tail
= SCM_CDR (tail
);
5785 rabbit
= SCM_CDR (rabbit
);
5786 if (SCM_CONSP (rabbit
))
5788 new_hare
.obj
= SCM_CAR (rabbit
);
5789 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5790 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
5791 tail
= SCM_CDR (tail
);
5792 rabbit
= SCM_CDR (rabbit
);
5794 turtle
= SCM_CDR (turtle
);
5795 ASSERT_SYNTAX (!scm_is_eq (rabbit
, turtle
),
5796 s_bad_expression
, rabbit
);
5800 /* We have to recurse into copy_tree again for the last cdr, in
5801 * order to handle the situation that it holds a vector. */
5802 new_hare
.obj
= rabbit
;
5803 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5804 SCM_SETCDR (tail
, copy
);
5811 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
5813 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
5814 "the new data structure. @code{copy-tree} recurses down the\n"
5815 "contents of both pairs and vectors (since both cons cells and vector\n"
5816 "cells may point to arbitrary objects), and stops recursing when it hits\n"
5817 "any other object.")
5818 #define FUNC_NAME s_scm_copy_tree
5820 /* Prepare the trace along the stack. */
5821 struct t_trace trace
;
5824 /* In function copy_tree, if the tortoise makes its step, it will do this
5825 * before the hare has the chance to move. Thus, we have to make sure that
5826 * the very first step of the tortoise will not happen after the hare has
5827 * really made two steps. This is achieved by passing '2' as the initial
5828 * delay for the tortoise. NOTE: Since cycles are unlikely, giving the hare
5829 * a bigger advantage may improve performance slightly. */
5830 return copy_tree (&trace
, &trace
, 2);
5835 /* We have three levels of EVAL here:
5837 - scm_i_eval (exp, env)
5839 evaluates EXP in environment ENV. ENV is a lexical environment
5840 structure as used by the actual tree code evaluator. When ENV is
5841 a top-level environment, then changes to the current module are
5842 tracked by updating ENV so that it continues to be in sync with
5845 - scm_primitive_eval (exp)
5847 evaluates EXP in the top-level environment as determined by the
5848 current module. This is done by constructing a suitable
5849 environment and calling scm_i_eval. Thus, changes to the
5850 top-level module are tracked normally.
5852 - scm_eval (exp, mod)
5854 evaluates EXP while MOD is the current module. This is done by
5855 setting the current module to MOD, invoking scm_primitive_eval on
5856 EXP, and then restoring the current module to the value it had
5857 previously. That is, while EXP is evaluated, changes to the
5858 current module are tracked, but these changes do not persist when
5861 For each level of evals, there are two variants, distinguished by a
5862 _x suffix: the ordinary variant does not modify EXP while the _x
5863 variant can destructively modify EXP into something completely
5864 unintelligible. A Scheme data structure passed as EXP to one of the
5865 _x variants should not ever be used again for anything. So when in
5866 doubt, use the ordinary variant.
5871 scm_i_eval_x (SCM exp
, SCM env
)
5873 if (scm_is_symbol (exp
))
5874 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
5876 return SCM_I_XEVAL (exp
, env
);
5880 scm_i_eval (SCM exp
, SCM env
)
5882 exp
= scm_copy_tree (exp
);
5883 if (scm_is_symbol (exp
))
5884 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
5886 return SCM_I_XEVAL (exp
, env
);
5890 scm_primitive_eval_x (SCM exp
)
5893 SCM transformer
= scm_current_module_transformer ();
5894 if (SCM_NIMP (transformer
))
5895 exp
= scm_call_1 (transformer
, exp
);
5896 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5897 return scm_i_eval_x (exp
, env
);
5900 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
5902 "Evaluate @var{exp} in the top-level environment specified by\n"
5903 "the current module.")
5904 #define FUNC_NAME s_scm_primitive_eval
5907 SCM transformer
= scm_current_module_transformer ();
5908 if (scm_is_true (transformer
))
5909 exp
= scm_call_1 (transformer
, exp
);
5910 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5911 return scm_i_eval (exp
, env
);
5916 /* Eval does not take the second arg optionally. This is intentional
5917 * in order to be R5RS compatible, and to prepare for the new module
5918 * system, where we would like to make the choice of evaluation
5919 * environment explicit. */
5922 change_environment (void *data
)
5924 SCM pair
= SCM_PACK (data
);
5925 SCM new_module
= SCM_CAR (pair
);
5926 SCM old_module
= scm_current_module ();
5927 SCM_SETCDR (pair
, old_module
);
5928 scm_set_current_module (new_module
);
5932 restore_environment (void *data
)
5934 SCM pair
= SCM_PACK (data
);
5935 SCM old_module
= SCM_CDR (pair
);
5936 SCM new_module
= scm_current_module ();
5937 SCM_SETCAR (pair
, new_module
);
5938 scm_set_current_module (old_module
);
5942 inner_eval_x (void *data
)
5944 return scm_primitive_eval_x (SCM_PACK(data
));
5948 scm_eval_x (SCM exp
, SCM module
)
5949 #define FUNC_NAME "eval!"
5951 SCM_VALIDATE_MODULE (2, module
);
5953 return scm_internal_dynamic_wind
5954 (change_environment
, inner_eval_x
, restore_environment
,
5955 (void *) SCM_UNPACK (exp
),
5956 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
5961 inner_eval (void *data
)
5963 return scm_primitive_eval (SCM_PACK(data
));
5966 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
5967 (SCM exp
, SCM module
),
5968 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
5969 "in the top-level environment specified by @var{module}.\n"
5970 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
5971 "@var{module} is made the current module. The current module\n"
5972 "is reset to its previous value when @var{eval} returns.")
5973 #define FUNC_NAME s_scm_eval
5975 SCM_VALIDATE_MODULE (2, module
);
5977 return scm_internal_dynamic_wind
5978 (change_environment
, inner_eval
, restore_environment
,
5979 (void *) SCM_UNPACK (exp
),
5980 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
5985 /* At this point, deval and scm_dapply are generated.
5992 #if (SCM_ENABLE_DEPRECATED == 1)
5994 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5995 SCM
scm_ceval (SCM x
, SCM env
)
5998 return ceval (x
, env
);
5999 else if (scm_is_symbol (x
))
6000 return *scm_lookupcar (scm_cons (x
, SCM_UNDEFINED
), env
, 1);
6002 return SCM_I_XEVAL (x
, env
);
6005 /* Deprecated in guile 1.7.0 on 2004-03-29. */
6006 SCM
scm_deval (SCM x
, SCM env
)
6009 return deval (x
, env
);
6010 else if (scm_is_symbol (x
))
6011 return *scm_lookupcar (scm_cons (x
, SCM_UNDEFINED
), env
, 1);
6013 return SCM_I_XEVAL (x
, env
);
6017 dispatching_eval (SCM x
, SCM env
)
6019 if (scm_debug_mode_p
)
6020 return scm_deval (x
, env
);
6022 return scm_ceval (x
, env
);
6025 /* Deprecated in guile 1.7.0 on 2004-03-29. */
6026 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
) = dispatching_eval
;
6034 scm_init_opts (scm_evaluator_traps
,
6035 scm_evaluator_trap_table
,
6036 SCM_N_EVALUATOR_TRAPS
);
6037 scm_init_opts (scm_eval_options_interface
,
6039 SCM_N_EVAL_OPTIONS
);
6041 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
6042 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
6043 scm_set_smob_free (scm_tc16_promise
, promise_free
);
6044 scm_set_smob_print (scm_tc16_promise
, promise_print
);
6046 undefineds
= scm_list_1 (SCM_UNDEFINED
);
6047 SCM_SETCDR (undefineds
, undefineds
);
6048 scm_permanent_object (undefineds
);
6050 scm_listofnull
= scm_list_1 (SCM_EOL
);
6052 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
6053 scm_permanent_object (f_apply
);
6055 #include "libguile/eval.x"
6057 scm_add_feature ("delay");