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 const SCM msg_string
= scm_makfrom0str (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_SYMBOLP (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_SYMBOLP (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_SYMBOLP (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_SYMBOLP (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_SYMBOLP (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_SYMBOLP (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_SYMBOLP (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_SYMBOLP (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_STRINGP (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_SYMBOLP (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_SYMBOLP (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_SYMBOLP (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_SYMBOLP (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_SYMBOLP (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_SYMBOLP (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_SYMBOLP (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_SYMBOLP (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_SYMBOLP (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
;
2684 error_unbound_variable (SCM symbol
)
2686 scm_error (scm_unbound_variable_key
, NULL
,
2687 "Unbound variable: ~S",
2688 scm_list_1 (symbol
), SCM_BOOL_F
);
2692 /* The Lookup Car Race
2695 Memoization of variables and special forms is done while executing
2696 the code for the first time. As long as there is only one thread
2697 everything is fine, but as soon as two threads execute the same
2698 code concurrently `for the first time' they can come into conflict.
2700 This memoization includes rewriting variable references into more
2701 efficient forms and expanding macros. Furthermore, macro expansion
2702 includes `compiling' special forms like `let', `cond', etc. into
2703 tree-code instructions.
2705 There shouldn't normally be a problem with memoizing local and
2706 global variable references (into ilocs and variables), because all
2707 threads will mutate the code in *exactly* the same way and (if I
2708 read the C code correctly) it is not possible to observe a half-way
2709 mutated cons cell. The lookup procedure can handle this
2710 transparently without any critical sections.
2712 It is different with macro expansion, because macro expansion
2713 happens outside of the lookup procedure and can't be
2714 undone. Therefore the lookup procedure can't cope with it. It has
2715 to indicate failure when it detects a lost race and hope that the
2716 caller can handle it. Luckily, it turns out that this is the case.
2718 An example to illustrate this: Suppose that the following form will
2719 be memoized concurrently by two threads
2723 Let's first examine the lookup of X in the body. The first thread
2724 decides that it has to find the symbol "x" in the environment and
2725 starts to scan it. Then the other thread takes over and actually
2726 overtakes the first. It looks up "x" and substitutes an
2727 appropriate iloc for it. Now the first thread continues and
2728 completes its lookup. It comes to exactly the same conclusions as
2729 the second one and could - without much ado - just overwrite the
2730 iloc with the same iloc.
2732 But let's see what will happen when the race occurs while looking
2733 up the symbol "let" at the start of the form. It could happen that
2734 the second thread interrupts the lookup of the first thread and not
2735 only substitutes a variable for it but goes right ahead and
2736 replaces it with the compiled form (#@let* (x 12) x). Now, when
2737 the first thread completes its lookup, it would replace the #@let*
2738 with a variable containing the "let" binding, effectively reverting
2739 the form to (let (x 12) x). This is wrong. It has to detect that
2740 it has lost the race and the evaluator has to reconsider the
2741 changed form completely.
2743 This race condition could be resolved with some kind of traffic
2744 light (like mutexes) around scm_lookupcar, but I think that it is
2745 best to avoid them in this case. They would serialize memoization
2746 completely and because lookup involves calling arbitrary Scheme
2747 code (via the lookup-thunk), threads could be blocked for an
2748 arbitrary amount of time or even deadlock. But with the current
2749 solution a lot of unnecessary work is potentially done. */
2751 /* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
2752 return NULL to indicate a failed lookup due to some race conditions
2753 between threads. This only happens when VLOC is the first cell of
2754 a special form that will eventually be memoized (like `let', etc.)
2755 In that case the whole lookup is bogus and the caller has to
2756 reconsider the complete special form.
2758 SCM_LOOKUPCAR is still there, of course. It just calls
2759 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
2760 should only be called when it is known that VLOC is not the first
2761 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
2762 for NULL. I think I've found the only places where this
2766 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
2769 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
2770 register SCM iloc
= SCM_ILOC00
;
2771 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
2773 if (!SCM_CONSP (SCM_CAR (env
)))
2775 al
= SCM_CARLOC (env
);
2776 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
2778 if (!SCM_CONSP (fl
))
2780 if (scm_is_eq (fl
, var
))
2782 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2784 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
2785 return SCM_CDRLOC (*al
);
2790 al
= SCM_CDRLOC (*al
);
2791 if (scm_is_eq (SCM_CAR (fl
), var
))
2793 if (SCM_UNBNDP (SCM_CAR (*al
)))
2798 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2800 SCM_SETCAR (vloc
, iloc
);
2801 return SCM_CARLOC (*al
);
2803 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
2805 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
2808 SCM top_thunk
, real_var
;
2811 top_thunk
= SCM_CAR (env
); /* env now refers to a
2812 top level env thunk */
2813 env
= SCM_CDR (env
);
2816 top_thunk
= SCM_BOOL_F
;
2817 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
2818 if (scm_is_false (real_var
))
2821 if (!SCM_NULLP (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
2826 if (SCM_NULLP (env
))
2827 error_unbound_variable (var
);
2829 scm_misc_error (NULL
, "Damaged environment: ~S",
2834 /* A variable could not be found, but we shall
2835 not throw an error. */
2836 static SCM undef_object
= SCM_UNDEFINED
;
2837 return &undef_object
;
2841 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2843 /* Some other thread has changed the very cell we are working
2844 on. In effect, it must have done our job or messed it up
2847 var
= SCM_CAR (vloc
);
2848 if (SCM_VARIABLEP (var
))
2849 return SCM_VARIABLE_LOC (var
);
2850 if (SCM_ILOCP (var
))
2851 return scm_ilookup (var
, genv
);
2852 /* We can't cope with anything else than variables and ilocs. When
2853 a special form has been memoized (i.e. `let' into `#@let') we
2854 return NULL and expect the calling function to do the right
2855 thing. For the evaluator, this means going back and redoing
2856 the dispatch on the car of the form. */
2860 SCM_SETCAR (vloc
, real_var
);
2861 return SCM_VARIABLE_LOC (real_var
);
2866 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
2868 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
2875 /* During execution, look up a symbol in the top level of the given local
2876 * environment and return the corresponding variable object. If no binding
2877 * for the symbol can be found, an 'Unbound variable' error is signalled. */
2879 lazy_memoize_variable (const SCM symbol
, const SCM environment
)
2881 const SCM top_level
= scm_env_top_level (environment
);
2882 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
2884 if (scm_is_false (variable
))
2885 error_unbound_variable (symbol
);
2892 scm_eval_car (SCM pair
, SCM env
)
2894 return SCM_I_XEVALCAR (pair
, env
);
2899 scm_eval_args (SCM l
, SCM env
, SCM proc
)
2901 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
2902 while (SCM_CONSP (l
))
2904 res
= EVALCAR (l
, env
);
2906 *lloc
= scm_list_1 (res
);
2907 lloc
= SCM_CDRLOC (*lloc
);
2911 scm_wrong_num_args (proc
);
2917 scm_eval_body (SCM code
, SCM env
)
2922 next
= SCM_CDR (code
);
2923 while (!SCM_NULLP (next
))
2925 if (SCM_IMP (SCM_CAR (code
)))
2927 if (SCM_ISYMP (SCM_CAR (code
)))
2929 scm_rec_mutex_lock (&source_mutex
);
2930 /* check for race condition */
2931 if (SCM_ISYMP (SCM_CAR (code
)))
2932 m_expand_body (code
, env
);
2933 scm_rec_mutex_unlock (&source_mutex
);
2938 SCM_I_XEVAL (SCM_CAR (code
), env
);
2940 next
= SCM_CDR (code
);
2942 return SCM_I_XEVALCAR (code
, env
);
2948 /* SECTION: This code is specific for the debugging support. One
2949 * branch is read when DEVAL isn't defined, the other when DEVAL is
2955 #define SCM_APPLY scm_apply
2956 #define PREP_APPLY(proc, args)
2958 #define RETURN(x) do { return x; } while (0)
2959 #ifdef STACK_CHECKING
2960 #ifndef NO_CEVAL_STACK_CHECKING
2961 #define EVAL_STACK_CHECKING
2968 #define CEVAL deval /* Substitute all uses of ceval */
2971 #define SCM_APPLY scm_dapply
2974 #define PREP_APPLY(p, l) \
2975 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
2978 #define ENTER_APPLY \
2980 SCM_SET_ARGSREADY (debug);\
2981 if (scm_check_apply_p && SCM_TRAPS_P)\
2982 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
2984 SCM tmp, tail = scm_from_bool(SCM_TRACED_FRAME_P (debug)); \
2985 SCM_SET_TRACED_FRAME (debug); \
2987 if (SCM_CHEAPTRAPS_P)\
2989 tmp = scm_make_debugobj (&debug);\
2990 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
2995 tmp = scm_make_continuation (&first);\
2997 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
3004 #define RETURN(e) do { proc = (e); goto exit; } while (0)
3006 #ifdef STACK_CHECKING
3007 #ifndef EVAL_STACK_CHECKING
3008 #define EVAL_STACK_CHECKING
3013 /* scm_last_debug_frame contains a pointer to the last debugging information
3014 * stack frame. It is accessed very often from the debugging evaluator, so it
3015 * should probably not be indirectly addressed. Better to save and restore it
3016 * from the current root at any stack swaps.
3019 /* scm_debug_eframe_size is the number of slots available for pseudo
3020 * stack frames at each real stack frame.
3023 long scm_debug_eframe_size
;
3025 int scm_debug_mode_p
;
3026 int scm_check_entry_p
;
3027 int scm_check_apply_p
;
3028 int scm_check_exit_p
;
3030 long scm_eval_stack
;
3032 scm_t_option scm_eval_opts
[] = {
3033 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
3036 scm_t_option scm_debug_opts
[] = {
3037 { SCM_OPTION_BOOLEAN
, "cheap", 1,
3038 "*Flyweight representation of the stack at traps." },
3039 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
3040 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
3041 { SCM_OPTION_BOOLEAN
, "procnames", 1,
3042 "Record procedure names at definition." },
3043 { SCM_OPTION_BOOLEAN
, "backwards", 0,
3044 "Display backtrace in anti-chronological order." },
3045 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
3046 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
3047 { SCM_OPTION_INTEGER
, "frames", 3,
3048 "Maximum number of tail-recursive frames in backtrace." },
3049 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
3050 "Maximal number of stored backtrace frames." },
3051 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
3052 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
3053 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
3054 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
3055 { 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."}
3058 scm_t_option scm_evaluator_trap_table
[] = {
3059 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
3060 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
3061 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
3062 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
3063 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
3064 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
3065 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
3068 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
3070 "Option interface for the evaluation options. Instead of using\n"
3071 "this procedure directly, use the procedures @code{eval-enable},\n"
3072 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
3073 #define FUNC_NAME s_scm_eval_options_interface
3077 ans
= scm_options (setting
,
3081 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
3088 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
3090 "Option interface for the evaluator trap options.")
3091 #define FUNC_NAME s_scm_evaluator_traps
3095 ans
= scm_options (setting
,
3096 scm_evaluator_trap_table
,
3097 SCM_N_EVALUATOR_TRAPS
,
3099 SCM_RESET_DEBUG_MODE
;
3107 deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
3109 SCM
*results
= lloc
;
3110 while (SCM_CONSP (l
))
3112 const SCM res
= EVALCAR (l
, env
);
3114 *lloc
= scm_list_1 (res
);
3115 lloc
= SCM_CDRLOC (*lloc
);
3119 scm_wrong_num_args (proc
);
3126 /* SECTION: This code is compiled twice.
3130 /* Update the toplevel environment frame ENV so that it refers to the
3131 * current module. */
3132 #define UPDATE_TOPLEVEL_ENV(env) \
3134 SCM p = scm_current_module_lookup_closure (); \
3135 if (p != SCM_CAR (env)) \
3136 env = scm_top_level_env (p); \
3140 #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
3141 ASSERT_SYNTAX (!scm_is_eq ((x), SCM_EOL), s_empty_combination, x)
3144 /* This is the evaluator. Like any real monster, it has three heads:
3146 * ceval is the non-debugging evaluator, deval is the debugging version. Both
3147 * are implemented using a common code base, using the following mechanism:
3148 * CEVAL is a macro, which is either defined to ceval or deval. Thus, there
3149 * is no function CEVAL, but the code for CEVAL actually compiles to either
3150 * ceval or deval. When CEVAL is defined to ceval, it is known that the macro
3151 * DEVAL is not defined. When CEVAL is defined to deval, then the macro DEVAL
3152 * is known to be defined. Thus, in CEVAL parts for the debugging evaluator
3153 * are enclosed within #ifdef DEVAL ... #endif.
3155 * All three (ceval, deval and their common implementation CEVAL) take two
3156 * input parameters, x and env: x is a single expression to be evalutated.
3157 * env is the environment in which bindings are searched.
3159 * x is known to be a pair. Since x is a single expression, it is necessarily
3160 * in a tail position. If x is just a call to another function like in the
3161 * expression (foo exp1 exp2 ...), the realization of that call therefore
3162 * _must_not_ increase stack usage (the evaluation of exp1, exp2 etc.,
3163 * however, may do so). This is realized by making extensive use of 'goto'
3164 * statements within the evaluator: The gotos replace recursive calls to
3165 * CEVAL, thus re-using the same stack frame that CEVAL was already using.
3166 * If, however, x represents some form that requires to evaluate a sequence of
3167 * expressions like (begin exp1 exp2 ...), then recursive calls to CEVAL are
3168 * performed for all but the last expression of that sequence. */
3171 CEVAL (SCM x
, SCM env
)
3175 scm_t_debug_frame debug
;
3176 scm_t_debug_info
*debug_info_end
;
3177 debug
.prev
= scm_last_debug_frame
;
3180 * The debug.vect contains twice as much scm_t_debug_info frames as the
3181 * user has specified with (debug-set! frames <n>).
3183 * Even frames are eval frames, odd frames are apply frames.
3185 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
3186 * sizeof (scm_t_debug_info
));
3187 debug
.info
= debug
.vect
;
3188 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
3189 scm_last_debug_frame
= &debug
;
3191 #ifdef EVAL_STACK_CHECKING
3192 if (scm_stack_checking_enabled_p
&& SCM_STACK_OVERFLOW_P (&proc
))
3195 debug
.info
->e
.exp
= x
;
3196 debug
.info
->e
.env
= env
;
3198 scm_report_stack_overflow ();
3208 SCM_CLEAR_ARGSREADY (debug
);
3209 if (SCM_OVERFLOWP (debug
))
3212 * In theory, this should be the only place where it is necessary to
3213 * check for space in debug.vect since both eval frames and
3214 * available space are even.
3216 * For this to be the case, however, it is necessary that primitive
3217 * special forms which jump back to `loop', `begin' or some similar
3218 * label call PREP_APPLY.
3220 else if (++debug
.info
>= debug_info_end
)
3222 SCM_SET_OVERFLOW (debug
);
3227 debug
.info
->e
.exp
= x
;
3228 debug
.info
->e
.env
= env
;
3229 if (scm_check_entry_p
&& SCM_TRAPS_P
)
3231 if (SCM_ENTER_FRAME_P
3232 || (SCM_BREAKPOINTS_P
&& scm_c_source_property_breakpoint_p (x
)))
3235 SCM tail
= scm_from_bool (SCM_TAILRECP (debug
));
3236 SCM_SET_TAILREC (debug
);
3237 if (SCM_CHEAPTRAPS_P
)
3238 stackrep
= scm_make_debugobj (&debug
);
3242 SCM val
= scm_make_continuation (&first
);
3252 /* This gives the possibility for the debugger to
3253 modify the source expression before evaluation. */
3258 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
3259 scm_sym_enter_frame
,
3262 unmemoize_expression (x
, env
));
3269 if (SCM_ISYMP (SCM_CAR (x
)))
3271 switch (ISYMNUM (SCM_CAR (x
)))
3273 case (ISYMNUM (SCM_IM_AND
)):
3275 while (!SCM_NULLP (SCM_CDR (x
)))
3277 SCM test_result
= EVALCAR (x
, env
);
3278 if (scm_is_false (test_result
) || SCM_NILP (test_result
))
3279 RETURN (SCM_BOOL_F
);
3283 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3286 case (ISYMNUM (SCM_IM_BEGIN
)):
3289 RETURN (SCM_UNSPECIFIED
);
3291 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3294 /* If we are on toplevel with a lookup closure, we need to sync
3295 with the current module. */
3296 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
3298 UPDATE_TOPLEVEL_ENV (env
);
3299 while (!SCM_NULLP (SCM_CDR (x
)))
3302 UPDATE_TOPLEVEL_ENV (env
);
3308 goto nontoplevel_begin
;
3311 while (!SCM_NULLP (SCM_CDR (x
)))
3313 const SCM form
= SCM_CAR (x
);
3316 if (SCM_ISYMP (form
))
3318 scm_rec_mutex_lock (&source_mutex
);
3319 /* check for race condition */
3320 if (SCM_ISYMP (SCM_CAR (x
)))
3321 m_expand_body (x
, env
);
3322 scm_rec_mutex_unlock (&source_mutex
);
3323 goto nontoplevel_begin
;
3326 SCM_VALIDATE_NON_EMPTY_COMBINATION (form
);
3329 (void) EVAL (form
, env
);
3335 /* scm_eval last form in list */
3336 const SCM last_form
= SCM_CAR (x
);
3338 if (SCM_CONSP (last_form
))
3340 /* This is by far the most frequent case. */
3342 goto loop
; /* tail recurse */
3344 else if (SCM_IMP (last_form
))
3345 RETURN (SCM_I_EVALIM (last_form
, env
));
3346 else if (SCM_VARIABLEP (last_form
))
3347 RETURN (SCM_VARIABLE_REF (last_form
));
3348 else if (SCM_SYMBOLP (last_form
))
3349 RETURN (*scm_lookupcar (x
, env
, 1));
3355 case (ISYMNUM (SCM_IM_CASE
)):
3358 const SCM key
= EVALCAR (x
, env
);
3360 while (!SCM_NULLP (x
))
3362 const SCM clause
= SCM_CAR (x
);
3363 SCM labels
= SCM_CAR (clause
);
3364 if (scm_is_eq (labels
, SCM_IM_ELSE
))
3366 x
= SCM_CDR (clause
);
3367 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3370 while (!SCM_NULLP (labels
))
3372 const SCM label
= SCM_CAR (labels
);
3373 if (scm_is_eq (label
, key
)
3374 || scm_is_true (scm_eqv_p (label
, key
)))
3376 x
= SCM_CDR (clause
);
3377 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3380 labels
= SCM_CDR (labels
);
3385 RETURN (SCM_UNSPECIFIED
);
3388 case (ISYMNUM (SCM_IM_COND
)):
3390 while (!SCM_NULLP (x
))
3392 const SCM clause
= SCM_CAR (x
);
3393 if (scm_is_eq (SCM_CAR (clause
), SCM_IM_ELSE
))
3395 x
= SCM_CDR (clause
);
3396 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3401 arg1
= EVALCAR (clause
, env
);
3402 if (scm_is_true (arg1
) && !SCM_NILP (arg1
))
3404 x
= SCM_CDR (clause
);
3407 else if (!scm_is_eq (SCM_CAR (x
), SCM_IM_ARROW
))
3409 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3415 proc
= EVALCAR (proc
, env
);
3416 PREP_APPLY (proc
, scm_list_1 (arg1
));
3424 RETURN (SCM_UNSPECIFIED
);
3427 case (ISYMNUM (SCM_IM_DO
)):
3430 /* Compute the initialization values and the initial environment. */
3431 SCM init_forms
= SCM_CAR (x
);
3432 SCM init_values
= SCM_EOL
;
3433 while (!SCM_NULLP (init_forms
))
3435 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3436 init_forms
= SCM_CDR (init_forms
);
3439 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
3443 SCM test_form
= SCM_CAR (x
);
3444 SCM body_forms
= SCM_CADR (x
);
3445 SCM step_forms
= SCM_CDDR (x
);
3447 SCM test_result
= EVALCAR (test_form
, env
);
3449 while (scm_is_false (test_result
) || SCM_NILP (test_result
))
3452 /* Evaluate body forms. */
3454 for (temp_forms
= body_forms
;
3455 !SCM_NULLP (temp_forms
);
3456 temp_forms
= SCM_CDR (temp_forms
))
3458 SCM form
= SCM_CAR (temp_forms
);
3459 /* Dirk:FIXME: We only need to eval forms that may have
3460 * a side effect here. This is only true for forms that
3461 * start with a pair. All others are just constants.
3462 * Since with the current memoizer 'form' may hold a
3463 * constant, we call EVAL here to handle the constant
3464 * cases. In the long run it would make sense to have
3465 * the macro transformer of 'do' eliminate all forms
3466 * that have no sideeffect. Then instead of EVAL we
3467 * could call CEVAL directly here. */
3468 (void) EVAL (form
, env
);
3473 /* Evaluate the step expressions. */
3475 SCM step_values
= SCM_EOL
;
3476 for (temp_forms
= step_forms
;
3477 !SCM_NULLP (temp_forms
);
3478 temp_forms
= SCM_CDR (temp_forms
))
3480 const SCM value
= EVALCAR (temp_forms
, env
);
3481 step_values
= scm_cons (value
, step_values
);
3483 env
= SCM_EXTEND_ENV (SCM_CAAR (env
),
3488 test_result
= EVALCAR (test_form
, env
);
3493 RETURN (SCM_UNSPECIFIED
);
3494 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3495 goto nontoplevel_begin
;
3498 case (ISYMNUM (SCM_IM_IF
)):
3501 SCM test_result
= EVALCAR (x
, env
);
3502 x
= SCM_CDR (x
); /* then expression */
3503 if (scm_is_false (test_result
) || SCM_NILP (test_result
))
3505 x
= SCM_CDR (x
); /* else expression */
3507 RETURN (SCM_UNSPECIFIED
);
3510 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3514 case (ISYMNUM (SCM_IM_LET
)):
3517 SCM init_forms
= SCM_CADR (x
);
3518 SCM init_values
= SCM_EOL
;
3521 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3522 init_forms
= SCM_CDR (init_forms
);
3524 while (!SCM_NULLP (init_forms
));
3525 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
3528 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3529 goto nontoplevel_begin
;
3532 case (ISYMNUM (SCM_IM_LETREC
)):
3534 env
= SCM_EXTEND_ENV (SCM_CAR (x
), undefineds
, env
);
3537 SCM init_forms
= SCM_CAR (x
);
3538 SCM init_values
= SCM_EOL
;
3541 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3542 init_forms
= SCM_CDR (init_forms
);
3544 while (!SCM_NULLP (init_forms
));
3545 SCM_SETCDR (SCM_CAR (env
), init_values
);
3548 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3549 goto nontoplevel_begin
;
3552 case (ISYMNUM (SCM_IM_LETSTAR
)):
3555 SCM bindings
= SCM_CAR (x
);
3556 if (!SCM_NULLP (bindings
))
3560 SCM name
= SCM_CAR (bindings
);
3561 SCM init
= SCM_CDR (bindings
);
3562 env
= SCM_EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
3563 bindings
= SCM_CDR (init
);
3565 while (!SCM_NULLP (bindings
));
3569 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3570 goto nontoplevel_begin
;
3573 case (ISYMNUM (SCM_IM_OR
)):
3575 while (!SCM_NULLP (SCM_CDR (x
)))
3577 SCM val
= EVALCAR (x
, env
);
3578 if (scm_is_true (val
) && !SCM_NILP (val
))
3583 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3587 case (ISYMNUM (SCM_IM_LAMBDA
)):
3588 RETURN (scm_closure (SCM_CDR (x
), env
));
3591 case (ISYMNUM (SCM_IM_QUOTE
)):
3592 RETURN (SCM_CDR (x
));
3595 case (ISYMNUM (SCM_IM_SET_X
)):
3599 SCM variable
= SCM_CAR (x
);
3600 if (SCM_ILOCP (variable
))
3601 location
= scm_ilookup (variable
, env
);
3602 else if (SCM_VARIABLEP (variable
))
3603 location
= SCM_VARIABLE_LOC (variable
);
3606 /* (SCM_SYMBOLP (variable)) is known to be true */
3607 variable
= lazy_memoize_variable (variable
, env
);
3608 SCM_SETCAR (x
, variable
);
3609 location
= SCM_VARIABLE_LOC (variable
);
3612 *location
= EVALCAR (x
, env
);
3614 RETURN (SCM_UNSPECIFIED
);
3617 case (ISYMNUM (SCM_IM_APPLY
)):
3618 /* Evaluate the procedure to be applied. */
3620 proc
= EVALCAR (x
, env
);
3621 PREP_APPLY (proc
, SCM_EOL
);
3623 /* Evaluate the argument holding the list of arguments */
3625 arg1
= EVALCAR (x
, env
);
3628 /* Go here to tail-apply a procedure. PROC is the procedure and
3629 * ARG1 is the list of arguments. PREP_APPLY must have been called
3630 * before jumping to apply_proc. */
3631 if (SCM_CLOSUREP (proc
))
3633 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3635 debug
.info
->a
.args
= arg1
;
3637 if (scm_badargsp (formals
, arg1
))
3638 scm_wrong_num_args (proc
);
3640 /* Copy argument list */
3641 if (SCM_NULL_OR_NIL_P (arg1
))
3642 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
3645 SCM args
= scm_list_1 (SCM_CAR (arg1
));
3647 arg1
= SCM_CDR (arg1
);
3648 while (!SCM_NULL_OR_NIL_P (arg1
))
3650 SCM new_tail
= scm_list_1 (SCM_CAR (arg1
));
3651 SCM_SETCDR (tail
, new_tail
);
3653 arg1
= SCM_CDR (arg1
);
3655 env
= SCM_EXTEND_ENV (formals
, args
, SCM_ENV (proc
));
3658 x
= SCM_CLOSURE_BODY (proc
);
3659 goto nontoplevel_begin
;
3664 RETURN (SCM_APPLY (proc
, arg1
, SCM_EOL
));
3668 case (ISYMNUM (SCM_IM_CONT
)):
3671 SCM val
= scm_make_continuation (&first
);
3679 proc
= EVALCAR (proc
, env
);
3680 PREP_APPLY (proc
, scm_list_1 (arg1
));
3687 case (ISYMNUM (SCM_IM_DELAY
)):
3688 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
3691 case (ISYMNUM (SCM_IM_FUTURE
)):
3692 RETURN (scm_i_make_future (scm_closure (SCM_CDR (x
), env
)));
3695 /* PLACEHOLDER for case (ISYMNUM (SCM_IM_DISPATCH)): The following
3696 code (type_dispatch) is intended to be the tail of the case
3697 clause for the internal macro SCM_IM_DISPATCH. Please don't
3698 remove it from this location without discussing it with Mikael
3699 <djurfeldt@nada.kth.se> */
3701 /* The type dispatch code is duplicated below
3702 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
3703 * cuts down execution time for type dispatch to 50%. */
3704 type_dispatch
: /* inputs: x, arg1 */
3705 /* Type dispatch means to determine from the types of the function
3706 * arguments (i. e. the 'signature' of the call), which method from
3707 * a generic function is to be called. This process of selecting
3708 * the right method takes some time. To speed it up, guile uses
3709 * caching: Together with the macro call to dispatch the signatures
3710 * of some previous calls to that generic function from the same
3711 * place are stored (in the code!) in a cache that we call the
3712 * 'method cache'. This is done since it is likely, that
3713 * consecutive calls to dispatch from that position in the code will
3714 * have the same signature. Thus, the type dispatch works as
3715 * follows: First, determine a hash value from the signature of the
3716 * actual arguments. Second, use this hash value as an index to
3717 * find that same signature in the method cache stored at this
3718 * position in the code. If found, you have also found the
3719 * corresponding method that belongs to that signature. If the
3720 * signature is not found in the method cache, you have to perform a
3721 * full search over all signatures stored with the generic
3724 unsigned long int specializers
;
3725 unsigned long int hash_value
;
3726 unsigned long int cache_end_pos
;
3727 unsigned long int mask
;
3731 SCM z
= SCM_CDDR (x
);
3732 SCM tmp
= SCM_CADR (z
);
3733 specializers
= scm_to_ulong (SCM_CAR (z
));
3735 /* Compute a hash value for searching the method cache. There
3736 * are two variants for computing the hash value, a (rather)
3737 * complicated one, and a simple one. For the complicated one
3738 * explained below, tmp holds a number that is used in the
3740 if (SCM_VECTORP (tmp
))
3742 /* This method of determining the hash value is much
3743 * simpler: Set the hash value to zero and just perform a
3744 * linear search through the method cache. */
3746 mask
= (unsigned long int) ((long) -1);
3748 cache_end_pos
= SCM_VECTOR_LENGTH (method_cache
);
3752 /* Use the signature of the actual arguments to determine
3753 * the hash value. This is done as follows: Each class has
3754 * an array of random numbers, that are determined when the
3755 * class is created. The integer 'hashset' is an index into
3756 * that array of random numbers. Now, from all classes that
3757 * are part of the signature of the actual arguments, the
3758 * random numbers at index 'hashset' are taken and summed
3759 * up, giving the hash value. The value of 'hashset' is
3760 * stored at the call to dispatch. This allows to have
3761 * different 'formulas' for calculating the hash value at
3762 * different places where dispatch is called. This allows
3763 * to optimize the hash formula at every individual place
3764 * where dispatch is called, such that hopefully the hash
3765 * value that is computed will directly point to the right
3766 * method in the method cache. */
3767 unsigned long int hashset
= scm_to_ulong (tmp
);
3768 unsigned long int counter
= specializers
+ 1;
3771 while (!SCM_NULLP (tmp_arg
) && counter
!= 0)
3773 SCM
class = scm_class_of (SCM_CAR (tmp_arg
));
3774 hash_value
+= SCM_INSTANCE_HASH (class, hashset
);
3775 tmp_arg
= SCM_CDR (tmp_arg
);
3779 method_cache
= SCM_CADR (z
);
3780 mask
= scm_to_ulong (SCM_CAR (z
));
3782 cache_end_pos
= hash_value
;
3787 /* Search the method cache for a method with a matching
3788 * signature. Start the search at position 'hash_value'. The
3789 * hashing implementation uses linear probing for conflict
3790 * resolution, that is, if the signature in question is not
3791 * found at the starting index in the hash table, the next table
3792 * entry is tried, and so on, until in the worst case the whole
3793 * cache has been searched, but still the signature has not been
3798 SCM args
= arg1
; /* list of arguments */
3799 z
= SCM_VELTS (method_cache
)[hash_value
];
3800 while (!SCM_NULLP (args
))
3802 /* More arguments than specifiers => CLASS != ENV */
3803 SCM class_of_arg
= scm_class_of (SCM_CAR (args
));
3804 if (!scm_is_eq (class_of_arg
, SCM_CAR (z
)))
3806 args
= SCM_CDR (args
);
3809 /* Fewer arguments than specifiers => CAR != ENV */
3810 if (SCM_NULLP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
)))
3813 hash_value
= (hash_value
+ 1) & mask
;
3814 } while (hash_value
!= cache_end_pos
);
3816 /* No appropriate method was found in the cache. */
3817 z
= scm_memoize_method (x
, arg1
);
3819 apply_cmethod
: /* inputs: z, arg1 */
3821 SCM formals
= SCM_CMETHOD_FORMALS (z
);
3822 env
= SCM_EXTEND_ENV (formals
, arg1
, SCM_CMETHOD_ENV (z
));
3823 x
= SCM_CMETHOD_BODY (z
);
3824 goto nontoplevel_begin
;
3830 case (ISYMNUM (SCM_IM_SLOT_REF
)):
3833 SCM instance
= EVALCAR (x
, env
);
3834 unsigned long int slot
= SCM_I_INUM (SCM_CDR (x
));
3835 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance
) [slot
]));
3839 case (ISYMNUM (SCM_IM_SLOT_SET_X
)):
3842 SCM instance
= EVALCAR (x
, env
);
3843 unsigned long int slot
= SCM_I_INUM (SCM_CADR (x
));
3844 SCM value
= EVALCAR (SCM_CDDR (x
), env
);
3845 SCM_STRUCT_DATA (instance
) [slot
] = SCM_UNPACK (value
);
3846 RETURN (SCM_UNSPECIFIED
);
3850 #if SCM_ENABLE_ELISP
3852 case (ISYMNUM (SCM_IM_NIL_COND
)):
3854 SCM test_form
= SCM_CDR (x
);
3855 x
= SCM_CDR (test_form
);
3856 while (!SCM_NULL_OR_NIL_P (x
))
3858 SCM test_result
= EVALCAR (test_form
, env
);
3859 if (!(scm_is_false (test_result
)
3860 || SCM_NULL_OR_NIL_P (test_result
)))
3862 if (scm_is_eq (SCM_CAR (x
), SCM_UNSPECIFIED
))
3863 RETURN (test_result
);
3864 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3869 test_form
= SCM_CDR (x
);
3870 x
= SCM_CDR (test_form
);
3874 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3878 #endif /* SCM_ENABLE_ELISP */
3880 case (ISYMNUM (SCM_IM_BIND
)):
3882 SCM vars
, exps
, vals
;
3885 vars
= SCM_CAAR (x
);
3886 exps
= SCM_CDAR (x
);
3888 while (!SCM_NULLP (exps
))
3890 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
3891 exps
= SCM_CDR (exps
);
3894 scm_swap_bindings (vars
, vals
);
3895 scm_dynwinds
= scm_acons (vars
, vals
, scm_dynwinds
);
3897 /* Ignore all but the last evaluation result. */
3898 for (x
= SCM_CDR (x
); !SCM_NULLP (SCM_CDR (x
)); x
= SCM_CDR (x
))
3900 if (SCM_CONSP (SCM_CAR (x
)))
3901 CEVAL (SCM_CAR (x
), env
);
3903 proc
= EVALCAR (x
, env
);
3905 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
3906 scm_swap_bindings (vars
, vals
);
3912 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
3917 producer
= EVALCAR (x
, env
);
3919 proc
= EVALCAR (x
, env
); /* proc is the consumer. */
3920 arg1
= SCM_APPLY (producer
, SCM_EOL
, SCM_EOL
);
3921 if (SCM_VALUESP (arg1
))
3923 /* The list of arguments is not copied. Rather, it is assumed
3924 * that this has been done by the 'values' procedure. */
3925 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
3929 arg1
= scm_list_1 (arg1
);
3931 PREP_APPLY (proc
, arg1
);
3942 if (SCM_VARIABLEP (SCM_CAR (x
)))
3943 proc
= SCM_VARIABLE_REF (SCM_CAR (x
));
3944 else if (SCM_ILOCP (SCM_CAR (x
)))
3945 proc
= *scm_ilookup (SCM_CAR (x
), env
);
3946 else if (SCM_CONSP (SCM_CAR (x
)))
3947 proc
= CEVAL (SCM_CAR (x
), env
);
3948 else if (SCM_SYMBOLP (SCM_CAR (x
)))
3950 SCM orig_sym
= SCM_CAR (x
);
3952 SCM
*location
= scm_lookupcar1 (x
, env
, 1);
3953 if (location
== NULL
)
3955 /* we have lost the race, start again. */
3961 if (SCM_MACROP (proc
))
3963 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
3965 handle_a_macro
: /* inputs: x, env, proc */
3967 /* Set a flag during macro expansion so that macro
3968 application frames can be deleted from the backtrace. */
3969 SCM_SET_MACROEXP (debug
);
3971 arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
3972 scm_cons (env
, scm_listofnull
));
3974 SCM_CLEAR_MACROEXP (debug
);
3976 switch (SCM_MACRO_TYPE (proc
))
3980 if (!SCM_CONSP (arg1
))
3981 arg1
= scm_list_2 (SCM_IM_BEGIN
, arg1
);
3983 assert (!scm_is_eq (x
, SCM_CAR (arg1
))
3984 && !scm_is_eq (x
, SCM_CDR (arg1
)));
3987 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
3990 SCM_SETCAR (x
, SCM_CAR (arg1
));
3991 SCM_SETCDR (x
, SCM_CDR (arg1
));
3995 /* Prevent memoizing of debug info expression. */
3996 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
4001 SCM_SETCAR (x
, SCM_CAR (arg1
));
4002 SCM_SETCDR (x
, SCM_CDR (arg1
));
4004 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
4006 #if SCM_ENABLE_DEPRECATED == 1
4011 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
4025 if (SCM_MACROP (proc
))
4026 goto handle_a_macro
;
4030 /* When reaching this part of the code, the following is granted: Variable x
4031 * holds the first pair of an expression of the form (<function> arg ...).
4032 * Variable proc holds the object that resulted from the evaluation of
4033 * <function>. In the following, the arguments (if any) will be evaluated,
4034 * and proc will be applied to them. If proc does not really hold a
4035 * function object, this will be signalled as an error on the scheme
4036 * level. If the number of arguments does not match the number of arguments
4037 * that are allowed to be passed to proc, also an error on the scheme level
4038 * will be signalled. */
4039 PREP_APPLY (proc
, SCM_EOL
);
4040 if (SCM_NULLP (SCM_CDR (x
))) {
4043 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4044 switch (SCM_TYP7 (proc
))
4045 { /* no arguments given */
4046 case scm_tc7_subr_0
:
4047 RETURN (SCM_SUBRF (proc
) ());
4048 case scm_tc7_subr_1o
:
4049 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
4051 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
4052 case scm_tc7_rpsubr
:
4053 RETURN (SCM_BOOL_T
);
4055 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
4057 if (!SCM_SMOB_APPLICABLE_P (proc
))
4059 RETURN (SCM_SMOB_APPLY_0 (proc
));
4062 proc
= SCM_CCLO_SUBR (proc
);
4064 debug
.info
->a
.proc
= proc
;
4065 debug
.info
->a
.args
= scm_list_1 (arg1
);
4069 proc
= SCM_PROCEDURE (proc
);
4071 debug
.info
->a
.proc
= proc
;
4073 if (!SCM_CLOSUREP (proc
))
4076 case scm_tcs_closures
:
4078 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4079 if (SCM_CONSP (formals
))
4081 x
= SCM_CLOSURE_BODY (proc
);
4082 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
4083 goto nontoplevel_begin
;
4085 case scm_tcs_struct
:
4086 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4088 x
= SCM_ENTITY_PROCEDURE (proc
);
4092 else if (SCM_I_OPERATORP (proc
))
4095 proc
= (SCM_I_ENTITYP (proc
)
4096 ? SCM_ENTITY_PROCEDURE (proc
)
4097 : SCM_OPERATOR_PROCEDURE (proc
));
4099 debug
.info
->a
.proc
= proc
;
4100 debug
.info
->a
.args
= scm_list_1 (arg1
);
4106 case scm_tc7_subr_1
:
4107 case scm_tc7_subr_2
:
4108 case scm_tc7_subr_2o
:
4111 case scm_tc7_subr_3
:
4112 case scm_tc7_lsubr_2
:
4114 scm_wrong_num_args (proc
);
4117 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
4121 /* must handle macros by here */
4124 arg1
= EVALCAR (x
, env
);
4126 scm_wrong_num_args (proc
);
4128 debug
.info
->a
.args
= scm_list_1 (arg1
);
4136 evap1
: /* inputs: proc, arg1 */
4137 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4138 switch (SCM_TYP7 (proc
))
4139 { /* have one argument in arg1 */
4140 case scm_tc7_subr_2o
:
4141 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4142 case scm_tc7_subr_1
:
4143 case scm_tc7_subr_1o
:
4144 RETURN (SCM_SUBRF (proc
) (arg1
));
4146 if (SCM_I_INUMP (arg1
))
4148 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
))));
4150 else if (SCM_REALP (arg1
))
4152 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4154 else if (SCM_BIGP (arg1
))
4156 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4158 else if (SCM_FRACTIONP (arg1
))
4160 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4162 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4163 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4166 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
4169 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
4170 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4171 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
4176 case scm_tc7_rpsubr
:
4177 RETURN (SCM_BOOL_T
);
4179 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4182 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4184 RETURN (SCM_SUBRF (proc
) (scm_list_1 (arg1
)));
4187 if (!SCM_SMOB_APPLICABLE_P (proc
))
4189 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
4193 proc
= SCM_CCLO_SUBR (proc
);
4195 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
4196 debug
.info
->a
.proc
= proc
;
4200 proc
= SCM_PROCEDURE (proc
);
4202 debug
.info
->a
.proc
= proc
;
4204 if (!SCM_CLOSUREP (proc
))
4207 case scm_tcs_closures
:
4210 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4211 if (SCM_NULLP (formals
)
4212 || (SCM_CONSP (formals
) && SCM_CONSP (SCM_CDR (formals
))))
4214 x
= SCM_CLOSURE_BODY (proc
);
4216 env
= SCM_EXTEND_ENV (formals
,
4220 env
= SCM_EXTEND_ENV (formals
,
4224 goto nontoplevel_begin
;
4226 case scm_tcs_struct
:
4227 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4229 x
= SCM_ENTITY_PROCEDURE (proc
);
4231 arg1
= debug
.info
->a
.args
;
4233 arg1
= scm_list_1 (arg1
);
4237 else if (SCM_I_OPERATORP (proc
))
4241 proc
= (SCM_I_ENTITYP (proc
)
4242 ? SCM_ENTITY_PROCEDURE (proc
)
4243 : SCM_OPERATOR_PROCEDURE (proc
));
4245 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
4246 debug
.info
->a
.proc
= proc
;
4252 case scm_tc7_subr_2
:
4253 case scm_tc7_subr_0
:
4254 case scm_tc7_subr_3
:
4255 case scm_tc7_lsubr_2
:
4256 scm_wrong_num_args (proc
);
4262 arg2
= EVALCAR (x
, env
);
4264 scm_wrong_num_args (proc
);
4266 { /* have two or more arguments */
4268 debug
.info
->a
.args
= scm_list_2 (arg1
, arg2
);
4271 if (SCM_NULLP (x
)) {
4274 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4275 switch (SCM_TYP7 (proc
))
4276 { /* have two arguments */
4277 case scm_tc7_subr_2
:
4278 case scm_tc7_subr_2o
:
4279 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
4282 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4284 RETURN (SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
)));
4286 case scm_tc7_lsubr_2
:
4287 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
));
4288 case scm_tc7_rpsubr
:
4290 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
4292 if (!SCM_SMOB_APPLICABLE_P (proc
))
4294 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
));
4298 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
4299 scm_cons (proc
, debug
.info
->a
.args
),
4302 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
4303 scm_cons2 (proc
, arg1
,
4310 case scm_tcs_struct
:
4311 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4313 x
= SCM_ENTITY_PROCEDURE (proc
);
4315 arg1
= debug
.info
->a
.args
;
4317 arg1
= scm_list_2 (arg1
, arg2
);
4321 else if (SCM_I_OPERATORP (proc
))
4325 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
4326 ? SCM_ENTITY_PROCEDURE (proc
)
4327 : SCM_OPERATOR_PROCEDURE (proc
),
4328 scm_cons (proc
, debug
.info
->a
.args
),
4331 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
4332 ? SCM_ENTITY_PROCEDURE (proc
)
4333 : SCM_OPERATOR_PROCEDURE (proc
),
4334 scm_cons2 (proc
, arg1
,
4344 case scm_tc7_subr_0
:
4347 case scm_tc7_subr_1o
:
4348 case scm_tc7_subr_1
:
4349 case scm_tc7_subr_3
:
4350 scm_wrong_num_args (proc
);
4354 proc
= SCM_PROCEDURE (proc
);
4356 debug
.info
->a
.proc
= proc
;
4358 if (!SCM_CLOSUREP (proc
))
4361 case scm_tcs_closures
:
4364 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4365 if (SCM_NULLP (formals
)
4366 || (SCM_CONSP (formals
)
4367 && (SCM_NULLP (SCM_CDR (formals
))
4368 || (SCM_CONSP (SCM_CDR (formals
))
4369 && SCM_CONSP (SCM_CDDR (formals
))))))
4372 env
= SCM_EXTEND_ENV (formals
,
4376 env
= SCM_EXTEND_ENV (formals
,
4377 scm_list_2 (arg1
, arg2
),
4380 x
= SCM_CLOSURE_BODY (proc
);
4381 goto nontoplevel_begin
;
4386 scm_wrong_num_args (proc
);
4388 debug
.info
->a
.args
= scm_cons2 (arg1
, arg2
,
4389 deval_args (x
, env
, proc
,
4390 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
4394 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4395 switch (SCM_TYP7 (proc
))
4396 { /* have 3 or more arguments */
4398 case scm_tc7_subr_3
:
4399 if (!SCM_NULLP (SCM_CDR (x
)))
4400 scm_wrong_num_args (proc
);
4402 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4403 SCM_CADDR (debug
.info
->a
.args
)));
4405 arg1
= SCM_SUBRF(proc
)(arg1
, arg2
);
4406 arg2
= SCM_CDDR (debug
.info
->a
.args
);
4409 arg1
= SCM_SUBRF(proc
)(arg1
, SCM_CAR (arg2
));
4410 arg2
= SCM_CDR (arg2
);
4412 while (SCM_NIMP (arg2
));
4414 case scm_tc7_rpsubr
:
4415 if (scm_is_false (SCM_SUBRF (proc
) (arg1
, arg2
)))
4416 RETURN (SCM_BOOL_F
);
4417 arg1
= SCM_CDDR (debug
.info
->a
.args
);
4420 if (scm_is_false (SCM_SUBRF (proc
) (arg2
, SCM_CAR (arg1
))))
4421 RETURN (SCM_BOOL_F
);
4422 arg2
= SCM_CAR (arg1
);
4423 arg1
= SCM_CDR (arg1
);
4425 while (SCM_NIMP (arg1
));
4426 RETURN (SCM_BOOL_T
);
4427 case scm_tc7_lsubr_2
:
4428 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4429 SCM_CDDR (debug
.info
->a
.args
)));
4431 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4433 if (!SCM_SMOB_APPLICABLE_P (proc
))
4435 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4436 SCM_CDDR (debug
.info
->a
.args
)));
4440 proc
= SCM_PROCEDURE (proc
);
4441 debug
.info
->a
.proc
= proc
;
4442 if (!SCM_CLOSUREP (proc
))
4445 case scm_tcs_closures
:
4447 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4448 if (SCM_NULLP (formals
)
4449 || (SCM_CONSP (formals
)
4450 && (SCM_NULLP (SCM_CDR (formals
))
4451 || (SCM_CONSP (SCM_CDR (formals
))
4452 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4454 SCM_SET_ARGSREADY (debug
);
4455 env
= SCM_EXTEND_ENV (formals
,
4458 x
= SCM_CLOSURE_BODY (proc
);
4459 goto nontoplevel_begin
;
4462 case scm_tc7_subr_3
:
4463 if (!SCM_NULLP (SCM_CDR (x
)))
4464 scm_wrong_num_args (proc
);
4466 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, EVALCAR (x
, env
)));
4468 arg1
= SCM_SUBRF (proc
) (arg1
, arg2
);
4471 arg1
= SCM_SUBRF(proc
)(arg1
, EVALCAR(x
, env
));
4474 while (!SCM_NULLP (x
));
4476 case scm_tc7_rpsubr
:
4477 if (scm_is_false (SCM_SUBRF (proc
) (arg1
, arg2
)))
4478 RETURN (SCM_BOOL_F
);
4481 arg1
= EVALCAR (x
, env
);
4482 if (scm_is_false (SCM_SUBRF (proc
) (arg2
, arg1
)))
4483 RETURN (SCM_BOOL_F
);
4487 while (!SCM_NULLP (x
));
4488 RETURN (SCM_BOOL_T
);
4489 case scm_tc7_lsubr_2
:
4490 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
4492 RETURN (SCM_SUBRF (proc
) (scm_cons2 (arg1
,
4494 scm_eval_args (x
, env
, proc
))));
4496 if (!SCM_SMOB_APPLICABLE_P (proc
))
4498 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4499 scm_eval_args (x
, env
, proc
)));
4503 proc
= SCM_PROCEDURE (proc
);
4504 if (!SCM_CLOSUREP (proc
))
4507 case scm_tcs_closures
:
4509 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4510 if (SCM_NULLP (formals
)
4511 || (SCM_CONSP (formals
)
4512 && (SCM_NULLP (SCM_CDR (formals
))
4513 || (SCM_CONSP (SCM_CDR (formals
))
4514 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4516 env
= SCM_EXTEND_ENV (formals
,
4519 scm_eval_args (x
, env
, proc
)),
4521 x
= SCM_CLOSURE_BODY (proc
);
4522 goto nontoplevel_begin
;
4525 case scm_tcs_struct
:
4526 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4529 arg1
= debug
.info
->a
.args
;
4531 arg1
= scm_cons2 (arg1
, arg2
, scm_eval_args (x
, env
, proc
));
4533 x
= SCM_ENTITY_PROCEDURE (proc
);
4536 else if (SCM_I_OPERATORP (proc
))
4540 case scm_tc7_subr_2
:
4541 case scm_tc7_subr_1o
:
4542 case scm_tc7_subr_2o
:
4543 case scm_tc7_subr_0
:
4546 case scm_tc7_subr_1
:
4547 scm_wrong_num_args (proc
);
4555 if (scm_check_exit_p
&& SCM_TRAPS_P
)
4556 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
4558 SCM_CLEAR_TRACED_FRAME (debug
);
4559 if (SCM_CHEAPTRAPS_P
)
4560 arg1
= scm_make_debugobj (&debug
);
4564 SCM val
= scm_make_continuation (&first
);
4575 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
4579 scm_last_debug_frame
= debug
.prev
;
4585 /* SECTION: This code is compiled once.
4592 /* Simple procedure calls
4596 scm_call_0 (SCM proc
)
4598 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
4602 scm_call_1 (SCM proc
, SCM arg1
)
4604 return scm_apply (proc
, arg1
, scm_listofnull
);
4608 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
4610 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
4614 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
4616 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
4620 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
4622 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
4623 scm_cons (arg4
, scm_listofnull
)));
4626 /* Simple procedure applies
4630 scm_apply_0 (SCM proc
, SCM args
)
4632 return scm_apply (proc
, args
, SCM_EOL
);
4636 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
4638 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
4642 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
4644 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
4648 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
4650 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
4654 /* This code processes the arguments to apply:
4656 (apply PROC ARG1 ... ARGS)
4658 Given a list (ARG1 ... ARGS), this function conses the ARG1
4659 ... arguments onto the front of ARGS, and returns the resulting
4660 list. Note that ARGS is a list; thus, the argument to this
4661 function is a list whose last element is a list.
4663 Apply calls this function, and applies PROC to the elements of the
4664 result. apply:nconc2last takes care of building the list of
4665 arguments, given (ARG1 ... ARGS).
4667 Rather than do new consing, apply:nconc2last destroys its argument.
4668 On that topic, this code came into my care with the following
4669 beautifully cryptic comment on that topic: "This will only screw
4670 you if you do (scm_apply scm_apply '( ... ))" If you know what
4671 they're referring to, send me a patch to this comment. */
4673 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
4675 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
4676 "conses the @var{arg1} @dots{} arguments onto the front of\n"
4677 "@var{args}, and returns the resulting list. Note that\n"
4678 "@var{args} is a list; thus, the argument to this function is\n"
4679 "a list whose last element is a list.\n"
4680 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
4681 "destroys its argument, so use with care.")
4682 #define FUNC_NAME s_scm_nconc2last
4685 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
4687 while (!SCM_NULLP (SCM_CDR (*lloc
))) /* Perhaps should be
4688 SCM_NULL_OR_NIL_P, but not
4689 needed in 99.99% of cases,
4690 and it could seriously hurt
4691 performance. - Neil */
4692 lloc
= SCM_CDRLOC (*lloc
);
4693 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
4694 *lloc
= SCM_CAR (*lloc
);
4702 /* SECTION: When DEVAL is defined this code yields scm_dapply.
4703 * It is compiled twice.
4708 scm_apply (SCM proc
, SCM arg1
, SCM args
)
4714 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
4719 /* Apply a function to a list of arguments.
4721 This function is exported to the Scheme level as taking two
4722 required arguments and a tail argument, as if it were:
4723 (lambda (proc arg1 . args) ...)
4724 Thus, if you just have a list of arguments to pass to a procedure,
4725 pass the list as ARG1, and '() for ARGS. If you have some fixed
4726 args, pass the first as ARG1, then cons any remaining fixed args
4727 onto the front of your argument list, and pass that as ARGS. */
4730 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
4733 scm_t_debug_frame debug
;
4734 scm_t_debug_info debug_vect_body
;
4735 debug
.prev
= scm_last_debug_frame
;
4736 debug
.status
= SCM_APPLYFRAME
;
4737 debug
.vect
= &debug_vect_body
;
4738 debug
.vect
[0].a
.proc
= proc
;
4739 debug
.vect
[0].a
.args
= SCM_EOL
;
4740 scm_last_debug_frame
= &debug
;
4742 if (scm_debug_mode_p
)
4743 return scm_dapply (proc
, arg1
, args
);
4746 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
4748 /* If ARGS is the empty list, then we're calling apply with only two
4749 arguments --- ARG1 is the list of arguments for PROC. Whatever
4750 the case, futz with things so that ARG1 is the first argument to
4751 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
4754 Setting the debug apply frame args this way is pretty messy.
4755 Perhaps we should store arg1 and args directly in the frame as
4756 received, and let scm_frame_arguments unpack them, because that's
4757 a relatively rare operation. This works for now; if the Guile
4758 developer archives are still around, see Mikael's post of
4760 if (SCM_NULLP (args
))
4762 if (SCM_NULLP (arg1
))
4764 arg1
= SCM_UNDEFINED
;
4766 debug
.vect
[0].a
.args
= SCM_EOL
;
4772 debug
.vect
[0].a
.args
= arg1
;
4774 args
= SCM_CDR (arg1
);
4775 arg1
= SCM_CAR (arg1
);
4780 args
= scm_nconc2last (args
);
4782 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4786 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
4789 if (SCM_CHEAPTRAPS_P
)
4790 tmp
= scm_make_debugobj (&debug
);
4795 tmp
= scm_make_continuation (&first
);
4800 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
4807 switch (SCM_TYP7 (proc
))
4809 case scm_tc7_subr_2o
:
4810 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
4811 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4812 case scm_tc7_subr_2
:
4813 if (SCM_NULLP (args
) || !SCM_NULLP (SCM_CDR (args
)))
4814 scm_wrong_num_args (proc
);
4815 args
= SCM_CAR (args
);
4816 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4817 case scm_tc7_subr_0
:
4818 if (!SCM_UNBNDP (arg1
))
4819 scm_wrong_num_args (proc
);
4821 RETURN (SCM_SUBRF (proc
) ());
4822 case scm_tc7_subr_1
:
4823 if (SCM_UNBNDP (arg1
))
4824 scm_wrong_num_args (proc
);
4825 case scm_tc7_subr_1o
:
4826 if (!SCM_NULLP (args
))
4827 scm_wrong_num_args (proc
);
4829 RETURN (SCM_SUBRF (proc
) (arg1
));
4831 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
4832 scm_wrong_num_args (proc
);
4833 if (SCM_I_INUMP (arg1
))
4835 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
))));
4837 else if (SCM_REALP (arg1
))
4839 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4841 else if (SCM_BIGP (arg1
))
4843 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4845 else if (SCM_FRACTIONP (arg1
))
4847 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4849 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4850 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4852 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
4853 scm_wrong_num_args (proc
);
4855 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
4858 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
4859 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4860 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
4865 case scm_tc7_subr_3
:
4866 if (SCM_NULLP (args
)
4867 || SCM_NULLP (SCM_CDR (args
))
4868 || !SCM_NULLP (SCM_CDDR (args
)))
4869 scm_wrong_num_args (proc
);
4871 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
4874 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
4876 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
4878 case scm_tc7_lsubr_2
:
4879 if (!SCM_CONSP (args
))
4880 scm_wrong_num_args (proc
);
4882 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4884 if (SCM_NULLP (args
))
4885 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4886 while (SCM_NIMP (args
))
4888 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
4889 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
4890 args
= SCM_CDR (args
);
4893 case scm_tc7_rpsubr
:
4894 if (SCM_NULLP (args
))
4895 RETURN (SCM_BOOL_T
);
4896 while (SCM_NIMP (args
))
4898 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
4899 if (scm_is_false (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
4900 RETURN (SCM_BOOL_F
);
4901 arg1
= SCM_CAR (args
);
4902 args
= SCM_CDR (args
);
4904 RETURN (SCM_BOOL_T
);
4905 case scm_tcs_closures
:
4907 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4909 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4911 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
4912 scm_wrong_num_args (proc
);
4914 /* Copy argument list */
4919 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
4920 for (arg1
= SCM_CDR (arg1
); SCM_CONSP (arg1
); arg1
= SCM_CDR (arg1
))
4922 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
));
4925 SCM_SETCDR (tl
, arg1
);
4928 args
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4931 proc
= SCM_CLOSURE_BODY (proc
);
4933 arg1
= SCM_CDR (proc
);
4934 while (!SCM_NULLP (arg1
))
4936 if (SCM_IMP (SCM_CAR (proc
)))
4938 if (SCM_ISYMP (SCM_CAR (proc
)))
4940 scm_rec_mutex_lock (&source_mutex
);
4941 /* check for race condition */
4942 if (SCM_ISYMP (SCM_CAR (proc
)))
4943 m_expand_body (proc
, args
);
4944 scm_rec_mutex_unlock (&source_mutex
);
4948 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
4951 (void) EVAL (SCM_CAR (proc
), args
);
4953 arg1
= SCM_CDR (proc
);
4955 RETURN (EVALCAR (proc
, args
));
4957 if (!SCM_SMOB_APPLICABLE_P (proc
))
4959 if (SCM_UNBNDP (arg1
))
4960 RETURN (SCM_SMOB_APPLY_0 (proc
));
4961 else if (SCM_NULLP (args
))
4962 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
4963 else if (SCM_NULLP (SCM_CDR (args
)))
4964 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
4966 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4969 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4971 proc
= SCM_CCLO_SUBR (proc
);
4972 debug
.vect
[0].a
.proc
= proc
;
4973 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4975 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4977 proc
= SCM_CCLO_SUBR (proc
);
4981 proc
= SCM_PROCEDURE (proc
);
4983 debug
.vect
[0].a
.proc
= proc
;
4986 case scm_tcs_struct
:
4987 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4990 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4992 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4994 RETURN (scm_apply_generic (proc
, args
));
4996 else if (SCM_I_OPERATORP (proc
))
5000 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
5002 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
5005 proc
= (SCM_I_ENTITYP (proc
)
5006 ? SCM_ENTITY_PROCEDURE (proc
)
5007 : SCM_OPERATOR_PROCEDURE (proc
));
5009 debug
.vect
[0].a
.proc
= proc
;
5010 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
5012 if (SCM_NIMP (proc
))
5021 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
5025 if (scm_check_exit_p
&& SCM_TRAPS_P
)
5026 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
5028 SCM_CLEAR_TRACED_FRAME (debug
);
5029 if (SCM_CHEAPTRAPS_P
)
5030 arg1
= scm_make_debugobj (&debug
);
5034 SCM val
= scm_make_continuation (&first
);
5045 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
5049 scm_last_debug_frame
= debug
.prev
;
5055 /* SECTION: The rest of this file is only read once.
5062 * Trampolines make it possible to move procedure application dispatch
5063 * outside inner loops. The motivation was clean implementation of
5064 * efficient replacements of R5RS primitives in SRFI-1.
5066 * The semantics is clear: scm_trampoline_N returns an optimized
5067 * version of scm_call_N (or NULL if the procedure isn't applicable
5070 * Applying the optimization to map and for-each increased efficiency
5071 * noticeably. For example, (map abs ls) is now 8 times faster than
5076 call_subr0_0 (SCM proc
)
5078 return SCM_SUBRF (proc
) ();
5082 call_subr1o_0 (SCM proc
)
5084 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
5088 call_lsubr_0 (SCM proc
)
5090 return SCM_SUBRF (proc
) (SCM_EOL
);
5094 scm_i_call_closure_0 (SCM proc
)
5096 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
5099 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
5104 scm_trampoline_0 (SCM proc
)
5106 scm_t_trampoline_0 trampoline
;
5111 switch (SCM_TYP7 (proc
))
5113 case scm_tc7_subr_0
:
5114 trampoline
= call_subr0_0
;
5116 case scm_tc7_subr_1o
:
5117 trampoline
= call_subr1o_0
;
5120 trampoline
= call_lsubr_0
;
5122 case scm_tcs_closures
:
5124 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5125 if (SCM_NULLP (formals
) || !SCM_CONSP (formals
))
5126 trampoline
= scm_i_call_closure_0
;
5131 case scm_tcs_struct
:
5132 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5133 trampoline
= scm_call_generic_0
;
5134 else if (SCM_I_OPERATORP (proc
))
5135 trampoline
= scm_call_0
;
5140 if (SCM_SMOB_APPLICABLE_P (proc
))
5141 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
5146 case scm_tc7_rpsubr
:
5149 trampoline
= scm_call_0
;
5152 return NULL
; /* not applicable on zero arguments */
5154 /* We only reach this point if a valid trampoline was determined. */
5156 /* If debugging is enabled, we want to see all calls to proc on the stack.
5157 * Thus, we replace the trampoline shortcut with scm_call_0. */
5158 if (scm_debug_mode_p
)
5165 call_subr1_1 (SCM proc
, SCM arg1
)
5167 return SCM_SUBRF (proc
) (arg1
);
5171 call_subr2o_1 (SCM proc
, SCM arg1
)
5173 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
5177 call_lsubr_1 (SCM proc
, SCM arg1
)
5179 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
5183 call_dsubr_1 (SCM proc
, SCM arg1
)
5185 if (SCM_I_INUMP (arg1
))
5187 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
))));
5189 else if (SCM_REALP (arg1
))
5191 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
5193 else if (SCM_BIGP (arg1
))
5195 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
5197 else if (SCM_FRACTIONP (arg1
))
5199 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
5201 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
5202 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
5206 call_cxr_1 (SCM proc
, SCM arg1
)
5208 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
5211 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
5212 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
5213 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
5220 call_closure_1 (SCM proc
, SCM arg1
)
5222 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
5225 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
5230 scm_trampoline_1 (SCM proc
)
5232 scm_t_trampoline_1 trampoline
;
5237 switch (SCM_TYP7 (proc
))
5239 case scm_tc7_subr_1
:
5240 case scm_tc7_subr_1o
:
5241 trampoline
= call_subr1_1
;
5243 case scm_tc7_subr_2o
:
5244 trampoline
= call_subr2o_1
;
5247 trampoline
= call_lsubr_1
;
5250 trampoline
= call_dsubr_1
;
5253 trampoline
= call_cxr_1
;
5255 case scm_tcs_closures
:
5257 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5258 if (!SCM_NULLP (formals
)
5259 && (!SCM_CONSP (formals
) || !SCM_CONSP (SCM_CDR (formals
))))
5260 trampoline
= call_closure_1
;
5265 case scm_tcs_struct
:
5266 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5267 trampoline
= scm_call_generic_1
;
5268 else if (SCM_I_OPERATORP (proc
))
5269 trampoline
= scm_call_1
;
5274 if (SCM_SMOB_APPLICABLE_P (proc
))
5275 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
5280 case scm_tc7_rpsubr
:
5283 trampoline
= scm_call_1
;
5286 return NULL
; /* not applicable on one arg */
5288 /* We only reach this point if a valid trampoline was determined. */
5290 /* If debugging is enabled, we want to see all calls to proc on the stack.
5291 * Thus, we replace the trampoline shortcut with scm_call_1. */
5292 if (scm_debug_mode_p
)
5299 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
5301 return SCM_SUBRF (proc
) (arg1
, arg2
);
5305 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
5307 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
5311 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
5313 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
5317 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
5319 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
5320 scm_list_2 (arg1
, arg2
),
5322 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
5327 scm_trampoline_2 (SCM proc
)
5329 scm_t_trampoline_2 trampoline
;
5334 switch (SCM_TYP7 (proc
))
5336 case scm_tc7_subr_2
:
5337 case scm_tc7_subr_2o
:
5338 case scm_tc7_rpsubr
:
5340 trampoline
= call_subr2_2
;
5342 case scm_tc7_lsubr_2
:
5343 trampoline
= call_lsubr2_2
;
5346 trampoline
= call_lsubr_2
;
5348 case scm_tcs_closures
:
5350 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5351 if (!SCM_NULLP (formals
)
5352 && (!SCM_CONSP (formals
)
5353 || (!SCM_NULLP (SCM_CDR (formals
))
5354 && (!SCM_CONSP (SCM_CDR (formals
))
5355 || !SCM_CONSP (SCM_CDDR (formals
))))))
5356 trampoline
= call_closure_2
;
5361 case scm_tcs_struct
:
5362 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5363 trampoline
= scm_call_generic_2
;
5364 else if (SCM_I_OPERATORP (proc
))
5365 trampoline
= scm_call_2
;
5370 if (SCM_SMOB_APPLICABLE_P (proc
))
5371 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
5377 trampoline
= scm_call_2
;
5380 return NULL
; /* not applicable on two args */
5382 /* We only reach this point if a valid trampoline was determined. */
5384 /* If debugging is enabled, we want to see all calls to proc on the stack.
5385 * Thus, we replace the trampoline shortcut with scm_call_2. */
5386 if (scm_debug_mode_p
)
5392 /* Typechecking for multi-argument MAP and FOR-EACH.
5394 Verify that each element of the vector ARGV, except for the first,
5395 is a proper list whose length is LEN. Attribute errors to WHO,
5396 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
5398 check_map_args (SCM argv
,
5405 SCM
const *ve
= SCM_VELTS (argv
);
5408 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
5410 long elt_len
= scm_ilength (ve
[i
]);
5415 scm_apply_generic (gf
, scm_cons (proc
, args
));
5417 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
5421 scm_out_of_range_pos (who
, ve
[i
], scm_from_long (i
+ 2));
5424 scm_remember_upto_here_1 (argv
);
5428 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
5430 /* Note: Currently, scm_map applies PROC to the argument list(s)
5431 sequentially, starting with the first element(s). This is used in
5432 evalext.c where the Scheme procedure `map-in-order', which guarantees
5433 sequential behaviour, is implemented using scm_map. If the
5434 behaviour changes, we need to update `map-in-order'.
5438 scm_map (SCM proc
, SCM arg1
, SCM args
)
5439 #define FUNC_NAME s_map
5444 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
5446 len
= scm_ilength (arg1
);
5447 SCM_GASSERTn (len
>= 0,
5448 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
5449 SCM_VALIDATE_REST_ARGUMENT (args
);
5450 if (SCM_NULLP (args
))
5452 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5453 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
5454 while (SCM_NIMP (arg1
))
5456 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
5457 pres
= SCM_CDRLOC (*pres
);
5458 arg1
= SCM_CDR (arg1
);
5462 if (SCM_NULLP (SCM_CDR (args
)))
5464 SCM arg2
= SCM_CAR (args
);
5465 int len2
= scm_ilength (arg2
);
5466 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5468 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
5469 SCM_GASSERTn (len2
>= 0,
5470 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
5472 SCM_OUT_OF_RANGE (3, arg2
);
5473 while (SCM_NIMP (arg1
))
5475 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
5476 pres
= SCM_CDRLOC (*pres
);
5477 arg1
= SCM_CDR (arg1
);
5478 arg2
= SCM_CDR (arg2
);
5482 arg1
= scm_cons (arg1
, args
);
5483 args
= scm_vector (arg1
);
5484 ve
= SCM_VELTS (args
);
5485 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
5489 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5491 if (SCM_IMP (ve
[i
]))
5493 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
5494 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
5496 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
5497 pres
= SCM_CDRLOC (*pres
);
5503 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
5506 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
5507 #define FUNC_NAME s_for_each
5509 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
5511 len
= scm_ilength (arg1
);
5512 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
5513 SCM_ARG2
, s_for_each
);
5514 SCM_VALIDATE_REST_ARGUMENT (args
);
5515 if (SCM_NULLP (args
))
5517 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5518 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
5519 while (SCM_NIMP (arg1
))
5521 call (proc
, SCM_CAR (arg1
));
5522 arg1
= SCM_CDR (arg1
);
5524 return SCM_UNSPECIFIED
;
5526 if (SCM_NULLP (SCM_CDR (args
)))
5528 SCM arg2
= SCM_CAR (args
);
5529 int len2
= scm_ilength (arg2
);
5530 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5531 SCM_GASSERTn (call
, g_for_each
,
5532 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
5533 SCM_GASSERTn (len2
>= 0, g_for_each
,
5534 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
5536 SCM_OUT_OF_RANGE (3, arg2
);
5537 while (SCM_NIMP (arg1
))
5539 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
5540 arg1
= SCM_CDR (arg1
);
5541 arg2
= SCM_CDR (arg2
);
5543 return SCM_UNSPECIFIED
;
5545 arg1
= scm_cons (arg1
, args
);
5546 args
= scm_vector (arg1
);
5547 ve
= SCM_VELTS (args
);
5548 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
5552 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5554 if (SCM_IMP (ve
[i
]))
5555 return SCM_UNSPECIFIED
;
5556 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
5557 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
5559 scm_apply (proc
, arg1
, SCM_EOL
);
5566 scm_closure (SCM code
, SCM env
)
5569 SCM closcar
= scm_cons (code
, SCM_EOL
);
5570 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
5571 scm_remember_upto_here (closcar
);
5576 scm_t_bits scm_tc16_promise
;
5579 scm_makprom (SCM code
)
5581 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
5583 scm_make_rec_mutex ());
5587 promise_free (SCM promise
)
5589 scm_rec_mutex_free (SCM_PROMISE_MUTEX (promise
));
5594 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
5596 int writingp
= SCM_WRITINGP (pstate
);
5597 scm_puts ("#<promise ", port
);
5598 SCM_SET_WRITINGP (pstate
, 1);
5599 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
5600 SCM_SET_WRITINGP (pstate
, writingp
);
5601 scm_putc ('>', port
);
5605 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
5607 "If the promise @var{x} has not been computed yet, compute and\n"
5608 "return @var{x}, otherwise just return the previously computed\n"
5610 #define FUNC_NAME s_scm_force
5612 SCM_VALIDATE_SMOB (1, promise
, promise
);
5613 scm_rec_mutex_lock (SCM_PROMISE_MUTEX (promise
));
5614 if (!SCM_PROMISE_COMPUTED_P (promise
))
5616 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
5617 if (!SCM_PROMISE_COMPUTED_P (promise
))
5619 SCM_SET_PROMISE_DATA (promise
, ans
);
5620 SCM_SET_PROMISE_COMPUTED (promise
);
5623 scm_rec_mutex_unlock (SCM_PROMISE_MUTEX (promise
));
5624 return SCM_PROMISE_DATA (promise
);
5629 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
5631 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
5632 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
5633 #define FUNC_NAME s_scm_promise_p
5635 return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
5640 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
5641 (SCM xorig
, SCM x
, SCM y
),
5642 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
5643 "Any source properties associated with @var{xorig} are also associated\n"
5644 "with the new pair.")
5645 #define FUNC_NAME s_scm_cons_source
5648 z
= scm_cons (x
, y
);
5649 /* Copy source properties possibly associated with xorig. */
5650 p
= scm_whash_lookup (scm_source_whash
, xorig
);
5651 if (scm_is_true (p
))
5652 scm_whash_insert (scm_source_whash
, z
, p
);
5658 /* The function scm_copy_tree is used to copy an expression tree to allow the
5659 * memoizer to modify the expression during memoization. scm_copy_tree
5660 * creates deep copies of pairs and vectors, but not of any other data types,
5661 * since only pairs and vectors will be parsed by the memoizer.
5663 * To avoid infinite recursion due to cyclic structures, the hare-and-tortoise
5664 * pattern is used to detect cycles. In fact, the pattern is used in two
5665 * dimensions, vertical (indicated in the code by the variable names 'hare'
5666 * and 'tortoise') and horizontal ('rabbit' and 'turtle'). In both
5667 * dimensions, the hare/rabbit will take two steps when the tortoise/turtle
5670 * The vertical dimension corresponds to recursive calls to function
5671 * copy_tree: This happens when descending into vector elements, into cars of
5672 * lists and into the cdr of an improper list. In this dimension, the
5673 * tortoise follows the hare by using the processor stack: Every stack frame
5674 * will hold an instance of struct t_trace. These instances are connected in
5675 * a way that represents the trace of the hare, which thus can be followed by
5676 * the tortoise. The tortoise will always point to struct t_trace instances
5677 * relating to SCM objects that have already been copied. Thus, a cycle is
5678 * detected if the tortoise and the hare point to the same object,
5680 * The horizontal dimension is within one execution of copy_tree, when the
5681 * function cdr's along the pairs of a list. This is the standard
5682 * hare-and-tortoise implementation, found several times in guile. */
5685 struct t_trace
*trace
; // These pointers form a trace along the stack.
5686 SCM obj
; // The object handled at the respective stack frame.
5691 struct t_trace
*const hare
,
5692 struct t_trace
*tortoise
,
5693 unsigned int tortoise_delay
)
5695 if (!SCM_CONSP (hare
->obj
) && !SCM_VECTORP (hare
->obj
))
5701 /* Prepare the trace along the stack. */
5702 struct t_trace new_hare
;
5703 hare
->trace
= &new_hare
;
5705 /* The tortoise will make its step after the delay has elapsed. Note
5706 * that in contrast to the typical hare-and-tortoise pattern, the step
5707 * of the tortoise happens before the hare takes its steps. This is, in
5708 * principle, no problem, except for the start of the algorithm: Then,
5709 * it has to be made sure that the hare actually gets its advantage of
5711 if (tortoise_delay
== 0)
5714 tortoise
= tortoise
->trace
;
5715 ASSERT_SYNTAX (!scm_is_eq (hare
->obj
, tortoise
->obj
),
5716 s_bad_expression
, hare
->obj
);
5723 if (SCM_VECTORP (hare
->obj
))
5725 const unsigned long int length
= SCM_VECTOR_LENGTH (hare
->obj
);
5726 const SCM new_vector
= scm_c_make_vector (length
, SCM_UNSPECIFIED
);
5728 /* Each vector element is copied by recursing into copy_tree, having
5729 * the tortoise follow the hare into the depths of the stack. */
5730 unsigned long int i
;
5731 for (i
= 0; i
< length
; ++i
)
5734 new_hare
.obj
= SCM_VECTOR_REF (hare
->obj
, i
);
5735 new_element
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5736 SCM_VECTOR_SET (new_vector
, i
, new_element
);
5741 else // SCM_CONSP (hare->obj)
5746 SCM rabbit
= hare
->obj
;
5747 SCM turtle
= hare
->obj
;
5751 /* The first pair of the list is treated specially, in order to
5752 * preserve a potential source code position. */
5753 result
= tail
= scm_cons_source (rabbit
, SCM_EOL
, SCM_EOL
);
5754 new_hare
.obj
= SCM_CAR (rabbit
);
5755 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5756 SCM_SETCAR (tail
, copy
);
5758 /* The remaining pairs of the list are copied by, horizontally,
5759 * having the turtle follow the rabbit, and, vertically, having the
5760 * tortoise follow the hare into the depths of the stack. */
5761 rabbit
= SCM_CDR (rabbit
);
5762 while (SCM_CONSP (rabbit
))
5764 new_hare
.obj
= SCM_CAR (rabbit
);
5765 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5766 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
5767 tail
= SCM_CDR (tail
);
5769 rabbit
= SCM_CDR (rabbit
);
5770 if (SCM_CONSP (rabbit
))
5772 new_hare
.obj
= SCM_CAR (rabbit
);
5773 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5774 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
5775 tail
= SCM_CDR (tail
);
5776 rabbit
= SCM_CDR (rabbit
);
5778 turtle
= SCM_CDR (turtle
);
5779 ASSERT_SYNTAX (!scm_is_eq (rabbit
, turtle
),
5780 s_bad_expression
, rabbit
);
5784 /* We have to recurse into copy_tree again for the last cdr, in
5785 * order to handle the situation that it holds a vector. */
5786 new_hare
.obj
= rabbit
;
5787 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5788 SCM_SETCDR (tail
, copy
);
5795 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
5797 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
5798 "the new data structure. @code{copy-tree} recurses down the\n"
5799 "contents of both pairs and vectors (since both cons cells and vector\n"
5800 "cells may point to arbitrary objects), and stops recursing when it hits\n"
5801 "any other object.")
5802 #define FUNC_NAME s_scm_copy_tree
5804 /* Prepare the trace along the stack. */
5805 struct t_trace trace
;
5808 /* In function copy_tree, if the tortoise makes its step, it will do this
5809 * before the hare has the chance to move. Thus, we have to make sure that
5810 * the very first step of the tortoise will not happen after the hare has
5811 * really made two steps. This is achieved by passing '2' as the initial
5812 * delay for the tortoise. NOTE: Since cycles are unlikely, giving the hare
5813 * a bigger advantage may improve performance slightly. */
5814 return copy_tree (&trace
, &trace
, 2);
5819 /* We have three levels of EVAL here:
5821 - scm_i_eval (exp, env)
5823 evaluates EXP in environment ENV. ENV is a lexical environment
5824 structure as used by the actual tree code evaluator. When ENV is
5825 a top-level environment, then changes to the current module are
5826 tracked by updating ENV so that it continues to be in sync with
5829 - scm_primitive_eval (exp)
5831 evaluates EXP in the top-level environment as determined by the
5832 current module. This is done by constructing a suitable
5833 environment and calling scm_i_eval. Thus, changes to the
5834 top-level module are tracked normally.
5836 - scm_eval (exp, mod)
5838 evaluates EXP while MOD is the current module. This is done by
5839 setting the current module to MOD, invoking scm_primitive_eval on
5840 EXP, and then restoring the current module to the value it had
5841 previously. That is, while EXP is evaluated, changes to the
5842 current module are tracked, but these changes do not persist when
5845 For each level of evals, there are two variants, distinguished by a
5846 _x suffix: the ordinary variant does not modify EXP while the _x
5847 variant can destructively modify EXP into something completely
5848 unintelligible. A Scheme data structure passed as EXP to one of the
5849 _x variants should not ever be used again for anything. So when in
5850 doubt, use the ordinary variant.
5855 scm_i_eval_x (SCM exp
, SCM env
)
5857 if (SCM_SYMBOLP (exp
))
5858 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
5860 return SCM_I_XEVAL (exp
, env
);
5864 scm_i_eval (SCM exp
, SCM env
)
5866 exp
= scm_copy_tree (exp
);
5867 if (SCM_SYMBOLP (exp
))
5868 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
5870 return SCM_I_XEVAL (exp
, env
);
5874 scm_primitive_eval_x (SCM exp
)
5877 SCM transformer
= scm_current_module_transformer ();
5878 if (SCM_NIMP (transformer
))
5879 exp
= scm_call_1 (transformer
, exp
);
5880 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5881 return scm_i_eval_x (exp
, env
);
5884 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
5886 "Evaluate @var{exp} in the top-level environment specified by\n"
5887 "the current module.")
5888 #define FUNC_NAME s_scm_primitive_eval
5891 SCM transformer
= scm_current_module_transformer ();
5892 if (scm_is_true (transformer
))
5893 exp
= scm_call_1 (transformer
, exp
);
5894 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5895 return scm_i_eval (exp
, env
);
5900 /* Eval does not take the second arg optionally. This is intentional
5901 * in order to be R5RS compatible, and to prepare for the new module
5902 * system, where we would like to make the choice of evaluation
5903 * environment explicit. */
5906 change_environment (void *data
)
5908 SCM pair
= SCM_PACK (data
);
5909 SCM new_module
= SCM_CAR (pair
);
5910 SCM old_module
= scm_current_module ();
5911 SCM_SETCDR (pair
, old_module
);
5912 scm_set_current_module (new_module
);
5916 restore_environment (void *data
)
5918 SCM pair
= SCM_PACK (data
);
5919 SCM old_module
= SCM_CDR (pair
);
5920 SCM new_module
= scm_current_module ();
5921 SCM_SETCAR (pair
, new_module
);
5922 scm_set_current_module (old_module
);
5926 inner_eval_x (void *data
)
5928 return scm_primitive_eval_x (SCM_PACK(data
));
5932 scm_eval_x (SCM exp
, SCM module
)
5933 #define FUNC_NAME "eval!"
5935 SCM_VALIDATE_MODULE (2, module
);
5937 return scm_internal_dynamic_wind
5938 (change_environment
, inner_eval_x
, restore_environment
,
5939 (void *) SCM_UNPACK (exp
),
5940 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
5945 inner_eval (void *data
)
5947 return scm_primitive_eval (SCM_PACK(data
));
5950 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
5951 (SCM exp
, SCM module
),
5952 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
5953 "in the top-level environment specified by @var{module}.\n"
5954 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
5955 "@var{module} is made the current module. The current module\n"
5956 "is reset to its previous value when @var{eval} returns.")
5957 #define FUNC_NAME s_scm_eval
5959 SCM_VALIDATE_MODULE (2, module
);
5961 return scm_internal_dynamic_wind
5962 (change_environment
, inner_eval
, restore_environment
,
5963 (void *) SCM_UNPACK (exp
),
5964 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
5969 /* At this point, deval and scm_dapply are generated.
5976 #if (SCM_ENABLE_DEPRECATED == 1)
5978 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5979 SCM
scm_ceval (SCM x
, SCM env
)
5982 return ceval (x
, env
);
5983 else if (SCM_SYMBOLP (x
))
5984 return *scm_lookupcar (scm_cons (x
, SCM_UNDEFINED
), env
, 1);
5986 return SCM_I_XEVAL (x
, env
);
5989 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5990 SCM
scm_deval (SCM x
, SCM env
)
5993 return deval (x
, env
);
5994 else if (SCM_SYMBOLP (x
))
5995 return *scm_lookupcar (scm_cons (x
, SCM_UNDEFINED
), env
, 1);
5997 return SCM_I_XEVAL (x
, env
);
6001 dispatching_eval (SCM x
, SCM env
)
6003 if (scm_debug_mode_p
)
6004 return scm_deval (x
, env
);
6006 return scm_ceval (x
, env
);
6009 /* Deprecated in guile 1.7.0 on 2004-03-29. */
6010 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
) = dispatching_eval
;
6018 scm_init_opts (scm_evaluator_traps
,
6019 scm_evaluator_trap_table
,
6020 SCM_N_EVALUATOR_TRAPS
);
6021 scm_init_opts (scm_eval_options_interface
,
6023 SCM_N_EVAL_OPTIONS
);
6025 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
6026 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
6027 scm_set_smob_free (scm_tc16_promise
, promise_free
);
6028 scm_set_smob_print (scm_tc16_promise
, promise_print
);
6030 undefineds
= scm_list_1 (SCM_UNDEFINED
);
6031 SCM_SETCDR (undefineds
, undefineds
);
6032 scm_permanent_object (undefineds
);
6034 scm_listofnull
= scm_list_1 (SCM_EOL
);
6036 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
6037 scm_permanent_object (f_apply
);
6039 #include "libguile/eval.x"
6041 scm_add_feature ("delay");