1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004
2 * Free Software Foundation, Inc.
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public
6 * License as published by the Free Software Foundation; either
7 * version 2.1 of the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
21 /* This file is read twice in order to produce debugging versions of ceval and
22 * scm_apply. These functions, deval and scm_dapply, are produced when we
23 * define the preprocessor macro DEVAL. The file is divided into sections
24 * which are treated differently with respect to DEVAL. The heads of these
25 * sections are marked with the string "SECTION:". */
27 /* SECTION: This code is compiled once.
34 #include "libguile/__scm.h"
38 /* AIX requires this to be the first thing in the file. The #pragma
39 directive is indented so pre-ANSI compilers will ignore it, rather
48 # ifndef alloca /* predefined by HP cc +Olibcalls */
56 #include "libguile/_scm.h"
57 #include "libguile/alist.h"
58 #include "libguile/async.h"
59 #include "libguile/continuations.h"
60 #include "libguile/debug.h"
61 #include "libguile/deprecation.h"
62 #include "libguile/dynwind.h"
63 #include "libguile/eq.h"
64 #include "libguile/feature.h"
65 #include "libguile/fluids.h"
66 #include "libguile/futures.h"
67 #include "libguile/goops.h"
68 #include "libguile/hash.h"
69 #include "libguile/hashtab.h"
70 #include "libguile/lang.h"
71 #include "libguile/list.h"
72 #include "libguile/macros.h"
73 #include "libguile/modules.h"
74 #include "libguile/objects.h"
75 #include "libguile/ports.h"
76 #include "libguile/print.h"
77 #include "libguile/procprop.h"
78 #include "libguile/root.h"
79 #include "libguile/smob.h"
80 #include "libguile/srcprop.h"
81 #include "libguile/stackchk.h"
82 #include "libguile/strings.h"
83 #include "libguile/throw.h"
84 #include "libguile/validate.h"
85 #include "libguile/values.h"
86 #include "libguile/vectors.h"
88 #include "libguile/eval.h"
92 static SCM
unmemoize_exprs (SCM expr
, SCM env
);
93 static SCM
canonicalize_define (SCM expr
);
94 static SCM
*scm_lookupcar1 (SCM vloc
, SCM genv
, int check
);
95 static SCM
unmemoize_builtin_macro (SCM expr
, SCM env
);
101 * This section defines the message strings for the syntax errors that can be
102 * detected during memoization and the functions and macros that shall be
103 * called by the memoizer code to signal syntax errors. */
106 /* Syntax errors that can be detected during memoization: */
108 /* Circular or improper lists do not form valid scheme expressions. If a
109 * circular list or an improper list is detected in a place where a scheme
110 * expression is expected, a 'Bad expression' error is signalled. */
111 static const char s_bad_expression
[] = "Bad expression";
113 /* If a form is detected that holds a different number of expressions than are
114 * required in that context, a 'Missing or extra expression' error is
116 static const char s_expression
[] = "Missing or extra expression in";
118 /* If a form is detected that holds less expressions than are required in that
119 * context, a 'Missing expression' error is signalled. */
120 static const char s_missing_expression
[] = "Missing expression in";
122 /* If a form is detected that holds more expressions than are allowed in that
123 * context, an 'Extra expression' error is signalled. */
124 static const char s_extra_expression
[] = "Extra expression in";
126 /* The empty combination '()' is not allowed as an expression in scheme. If
127 * it is detected in a place where an expression is expected, an 'Illegal
128 * empty combination' error is signalled. Note: If you encounter this error
129 * message, it is very likely that you intended to denote the empty list. To
130 * do so, you need to quote the empty list like (quote ()) or '(). */
131 static const char s_empty_combination
[] = "Illegal empty combination";
133 /* A body may hold an arbitrary number of internal defines, followed by a
134 * non-empty sequence of expressions. If a body with an empty sequence of
135 * expressions is detected, a 'Missing body expression' error is signalled.
137 static const char s_missing_body_expression
[] = "Missing body expression in";
139 /* A body may hold an arbitrary number of internal defines, followed by a
140 * non-empty sequence of expressions. Each the definitions and the
141 * expressions may be grouped arbitraryly with begin, but it is not allowed to
142 * mix definitions and expressions. If a define form in a body mixes
143 * definitions and expressions, a 'Mixed definitions and expressions' error is
145 static const char s_mixed_body_forms
[] = "Mixed definitions and expressions in";
146 /* Definitions are only allowed on the top level and at the start of a body.
147 * If a definition is detected anywhere else, a 'Bad define placement' error
149 static const char s_bad_define
[] = "Bad define placement";
151 /* Case or cond expressions must have at least one clause. If a case or cond
152 * expression without any clauses is detected, a 'Missing clauses' error is
154 static const char s_missing_clauses
[] = "Missing clauses";
156 /* If there is an 'else' clause in a case or a cond statement, it must be the
157 * last clause. If after the 'else' case clause further clauses are detected,
158 * a 'Misplaced else clause' error is signalled. */
159 static const char s_misplaced_else_clause
[] = "Misplaced else clause";
161 /* If a case clause is detected that is not in the format
162 * (<label(s)> <expression1> <expression2> ...)
163 * a 'Bad case clause' error is signalled. */
164 static const char s_bad_case_clause
[] = "Bad case clause";
166 /* If a case clause is detected where the <label(s)> element is neither a
167 * proper list nor (in case of the last clause) the syntactic keyword 'else',
168 * a 'Bad case labels' error is signalled. Note: If you encounter this error
169 * for an else-clause which seems to be syntactically correct, check if 'else'
170 * is really a syntactic keyword in that context. If 'else' is bound in the
171 * local or global environment, it is not considered a syntactic keyword, but
172 * will be treated as any other variable. */
173 static const char s_bad_case_labels
[] = "Bad case labels";
175 /* In a case statement all labels have to be distinct. If in a case statement
176 * a label occurs more than once, a 'Duplicate case label' error is
178 static const char s_duplicate_case_label
[] = "Duplicate case label";
180 /* If a cond clause is detected that is not in one of the formats
181 * (<test> <expression1> ...) or (else <expression1> <expression2> ...)
182 * a 'Bad cond clause' error is signalled. */
183 static const char s_bad_cond_clause
[] = "Bad cond clause";
185 /* If a cond clause is detected that uses the alternate '=>' form, but does
186 * not hold a recipient element for the test result, a 'Missing recipient'
187 * error is signalled. */
188 static const char s_missing_recipient
[] = "Missing recipient in";
190 /* If in a position where a variable name is required some other object is
191 * detected, a 'Bad variable' error is signalled. */
192 static const char s_bad_variable
[] = "Bad variable";
194 /* Bindings for forms like 'let' and 'do' have to be given in a proper,
195 * possibly empty list. If any other object is detected in a place where a
196 * list of bindings was required, a 'Bad bindings' error is signalled. */
197 static const char s_bad_bindings
[] = "Bad bindings";
199 /* Depending on the syntactic context, a binding has to be in the format
200 * (<variable> <expression>) or (<variable> <expression1> <expression2>).
201 * If anything else is detected in a place where a binding was expected, a
202 * 'Bad binding' error is signalled. */
203 static const char s_bad_binding
[] = "Bad binding";
205 /* Some syntactic forms don't allow variable names to appear more than once in
206 * a list of bindings. If such a situation is nevertheless detected, a
207 * 'Duplicate binding' error is signalled. */
208 static const char s_duplicate_binding
[] = "Duplicate binding";
210 /* If the exit form of a 'do' expression is not in the format
211 * (<test> <expression> ...)
212 * a 'Bad exit clause' error is signalled. */
213 static const char s_bad_exit_clause
[] = "Bad exit clause";
215 /* The formal function arguments of a lambda expression have to be either a
216 * single symbol or a non-cyclic list. For anything else a 'Bad formals'
217 * error is signalled. */
218 static const char s_bad_formals
[] = "Bad formals";
220 /* If in a lambda expression something else than a symbol is detected at a
221 * place where a formal function argument is required, a 'Bad formal' error is
223 static const char s_bad_formal
[] = "Bad formal";
225 /* If in the arguments list of a lambda expression an argument name occurs
226 * more than once, a 'Duplicate formal' error is signalled. */
227 static const char s_duplicate_formal
[] = "Duplicate formal";
229 /* If the evaluation of an unquote-splicing expression gives something else
230 * than a proper list, a 'Non-list result for unquote-splicing' error is
232 static const char s_splicing
[] = "Non-list result for unquote-splicing";
234 /* If something else than an exact integer is detected as the argument for
235 * @slot-ref and @slot-set!, a 'Bad slot number' error is signalled. */
236 static const char s_bad_slot_number
[] = "Bad slot number";
239 /* Signal a syntax error. We distinguish between the form that caused the
240 * error and the enclosing expression. The error message will print out as
241 * shown in the following pattern. The file name and line number are only
242 * given when they can be determined from the erroneous form or from the
243 * enclosing expression.
245 * <filename>: In procedure memoization:
246 * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
248 SCM_SYMBOL (syntax_error_key
, "syntax-error");
250 /* The prototype is needed to indicate that the function does not return. */
252 syntax_error (const char* const, const SCM
, const SCM
) SCM_NORETURN
;
255 syntax_error (const char* const msg
, const SCM form
, const SCM expr
)
257 SCM msg_string
= scm_from_locale_string (msg
);
258 SCM filename
= SCM_BOOL_F
;
259 SCM linenr
= SCM_BOOL_F
;
263 if (SCM_CONSP (form
))
265 filename
= scm_source_property (form
, scm_sym_filename
);
266 linenr
= scm_source_property (form
, scm_sym_line
);
269 if (scm_is_false (filename
) && scm_is_false (linenr
) && SCM_CONSP (expr
))
271 filename
= scm_source_property (expr
, scm_sym_filename
);
272 linenr
= scm_source_property (expr
, scm_sym_line
);
275 if (!SCM_UNBNDP (expr
))
277 if (scm_is_true (filename
))
279 format
= "In file ~S, line ~S: ~A ~S in expression ~S.";
280 args
= scm_list_5 (filename
, linenr
, msg_string
, form
, expr
);
282 else if (scm_is_true (linenr
))
284 format
= "In line ~S: ~A ~S in expression ~S.";
285 args
= scm_list_4 (linenr
, msg_string
, form
, expr
);
289 format
= "~A ~S in expression ~S.";
290 args
= scm_list_3 (msg_string
, form
, expr
);
295 if (scm_is_true (filename
))
297 format
= "In file ~S, line ~S: ~A ~S.";
298 args
= scm_list_4 (filename
, linenr
, msg_string
, form
);
300 else if (scm_is_true (linenr
))
302 format
= "In line ~S: ~A ~S.";
303 args
= scm_list_3 (linenr
, msg_string
, form
);
308 args
= scm_list_2 (msg_string
, form
);
312 scm_error (syntax_error_key
, "memoization", format
, args
, SCM_BOOL_F
);
316 /* Shortcut macros to simplify syntax error handling. */
317 #define ASSERT_SYNTAX(cond, message, form) \
318 { if (!(cond)) syntax_error (message, form, SCM_UNDEFINED); }
319 #define ASSERT_SYNTAX_2(cond, message, form, expr) \
320 { if (!(cond)) syntax_error (message, form, expr); }
326 * Ilocs are memoized references to variables in local environment frames.
327 * They are represented as three values: The relative offset of the
328 * environment frame, the number of the binding within that frame, and a
329 * boolean value indicating whether the binding is the last binding in the
332 * Frame numbers have 11 bits, relative offsets have 12 bits.
335 #define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc)
336 #define SCM_IFRINC (0x00000100L)
337 #define SCM_ICDR (0x00080000L)
338 #define SCM_IDINC (0x00100000L)
339 #define SCM_IFRAME(n) ((long)((SCM_ICDR-SCM_IFRINC)>>8) \
340 & (SCM_UNPACK (n) >> 8))
341 #define SCM_IDIST(n) (SCM_UNPACK (n) >> 20)
342 #define SCM_ICDRP(n) (SCM_ICDR & SCM_UNPACK (n))
343 #define SCM_IDSTMSK (-SCM_IDINC)
344 #define SCM_IFRAMEMAX ((1<<11)-1)
345 #define SCM_IDISTMAX ((1<<12)-1)
346 #define SCM_MAKE_ILOC(frame_nr, binding_nr, last_p) \
349 + ((binding_nr) << 20) \
350 + ((last_p) ? SCM_ICDR : 0) \
354 scm_i_print_iloc (SCM iloc
, SCM port
)
356 scm_puts ("#@", port
);
357 scm_intprint ((long) SCM_IFRAME (iloc
), 10, port
);
358 scm_putc (SCM_ICDRP (iloc
) ? '-' : '+', port
);
359 scm_intprint ((long) SCM_IDIST (iloc
), 10, port
);
362 #if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
364 SCM
scm_dbg_make_iloc (SCM frame
, SCM binding
, SCM cdrp
);
366 SCM_DEFINE (scm_dbg_make_iloc
, "dbg-make-iloc", 3, 0, 0,
367 (SCM frame
, SCM binding
, SCM cdrp
),
368 "Return a new iloc with frame offset @var{frame}, binding\n"
369 "offset @var{binding} and the cdr flag @var{cdrp}.")
370 #define FUNC_NAME s_scm_dbg_make_iloc
372 return SCM_MAKE_ILOC (scm_to_unsigned_integer (frame
, 0, SCM_IFRAME_MAX
),
373 scm_to_unsigned_integer (binding
, 0, SCM_IDIST_MAX
),
378 SCM
scm_dbg_iloc_p (SCM obj
);
380 SCM_DEFINE (scm_dbg_iloc_p
, "dbg-iloc?", 1, 0, 0,
382 "Return @code{#t} if @var{obj} is an iloc.")
383 #define FUNC_NAME s_scm_dbg_iloc_p
385 return scm_from_bool (SCM_ILOCP (obj
));
393 /* {Evaluator byte codes (isyms)}
396 #define ISYMNUM(n) (SCM_ITAG8_DATA (n))
398 /* This table must agree with the list of SCM_IM_ constants in tags.h */
399 static const char *const isymnames
[] =
416 "#@call-with-current-continuation",
422 "#@call-with-values",
430 scm_i_print_isym (SCM isym
, SCM port
)
432 const size_t isymnum
= ISYMNUM (isym
);
433 if (isymnum
< (sizeof isymnames
/ sizeof (char *)))
434 scm_puts (isymnames
[isymnum
], port
);
436 scm_ipruk ("isym", isym
, port
);
441 /* The function lookup_symbol is used during memoization: Lookup the symbol in
442 * the environment. If there is no binding for the symbol, SCM_UNDEFINED is
443 * returned. If the symbol is a global variable, the variable object to which
444 * the symbol is bound is returned. Finally, if the symbol is a local
445 * variable the corresponding iloc object is returned. */
447 /* A helper function for lookup_symbol: Try to find the symbol in the top
448 * level environment frame. The function returns SCM_UNDEFINED if the symbol
449 * is unbound and it returns a variable object if the symbol is a global
452 lookup_global_symbol (const SCM symbol
, const SCM top_level
)
454 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
455 if (scm_is_false (variable
))
456 return SCM_UNDEFINED
;
462 lookup_symbol (const SCM symbol
, const SCM env
)
465 unsigned int frame_nr
;
467 for (frame_idx
= env
, frame_nr
= 0;
468 !SCM_NULLP (frame_idx
);
469 frame_idx
= SCM_CDR (frame_idx
), ++frame_nr
)
471 const SCM frame
= SCM_CAR (frame_idx
);
472 if (SCM_CONSP (frame
))
474 /* frame holds a local environment frame */
476 unsigned int symbol_nr
;
478 for (symbol_idx
= SCM_CAR (frame
), symbol_nr
= 0;
479 SCM_CONSP (symbol_idx
);
480 symbol_idx
= SCM_CDR (symbol_idx
), ++symbol_nr
)
482 if (scm_is_eq (SCM_CAR (symbol_idx
), symbol
))
483 /* found the symbol, therefore return the iloc */
484 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 0);
486 if (scm_is_eq (symbol_idx
, symbol
))
487 /* found the symbol as the last element of the current frame */
488 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 1);
492 /* no more local environment frames */
493 return lookup_global_symbol (symbol
, frame
);
497 return lookup_global_symbol (symbol
, SCM_BOOL_F
);
501 /* Return true if the symbol is - from the point of view of a macro
502 * transformer - a literal in the sense specified in chapter "pattern
503 * language" of R5RS. In the code below, however, we don't match the
504 * definition of R5RS exactly: It returns true if the identifier has no
505 * binding or if it is a syntactic keyword. */
507 literal_p (const SCM symbol
, const SCM env
)
509 const SCM variable
= lookup_symbol (symbol
, env
);
510 if (SCM_UNBNDP (variable
))
512 if (SCM_VARIABLEP (variable
) && SCM_MACROP (SCM_VARIABLE_REF (variable
)))
519 /* Return true if the expression is self-quoting in the memoized code. Thus,
520 * some other objects (like e. g. vectors) are reported as self-quoting, which
521 * according to R5RS would need to be quoted. */
523 is_self_quoting_p (const SCM expr
)
525 if (SCM_CONSP (expr
))
527 else if (scm_is_symbol (expr
))
529 else if (SCM_NULLP (expr
))
535 SCM_SYMBOL (sym_three_question_marks
, "???");
538 unmemoize_expression (const SCM expr
, const SCM env
)
540 if (SCM_ILOCP (expr
))
543 unsigned long int frame_nr
;
545 unsigned long int symbol_nr
;
547 for (frame_idx
= env
, frame_nr
= SCM_IFRAME (expr
);
549 frame_idx
= SCM_CDR (frame_idx
), --frame_nr
)
551 for (symbol_idx
= SCM_CAAR (frame_idx
), symbol_nr
= SCM_IDIST (expr
);
553 symbol_idx
= SCM_CDR (symbol_idx
), --symbol_nr
)
555 return SCM_ICDRP (expr
) ? symbol_idx
: SCM_CAR (symbol_idx
);
557 else if (SCM_VARIABLEP (expr
))
559 const SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), expr
);
560 return scm_is_true (sym
) ? sym
: sym_three_question_marks
;
562 else if (SCM_VECTORP (expr
))
564 return scm_list_2 (scm_sym_quote
, expr
);
566 else if (!SCM_CONSP (expr
))
570 else if (SCM_ISYMP (SCM_CAR (expr
)))
572 return unmemoize_builtin_macro (expr
, env
);
576 return unmemoize_exprs (expr
, env
);
582 unmemoize_exprs (const SCM exprs
, const SCM env
)
584 SCM r_result
= SCM_EOL
;
585 SCM expr_idx
= exprs
;
588 /* Note that due to the current lazy memoizer we may find partially memoized
589 * code during execution. In such code, lists of expressions that stem from
590 * a body form may start with an ISYM if the body itself has not yet been
591 * memoized. This isym is just an internal marker to indicate that the body
592 * still needs to be memoized. It is dropped during unmemoization. */
593 if (SCM_CONSP (expr_idx
) && SCM_ISYMP (SCM_CAR (expr_idx
)))
594 expr_idx
= SCM_CDR (expr_idx
);
596 /* Moreover, in partially memoized code we have to expect improper lists of
597 * expressions: On the one hand, for such code syntax checks have not yet
598 * fully been performed, on the other hand, there may be even legal code
599 * like '(a . b) appear as an improper list of expressions as long as the
600 * quote expression is still in its unmemoized form. For this reason, the
601 * following code handles improper lists of expressions until memoization
602 * and execution have been completely separated. */
603 for (; SCM_CONSP (expr_idx
); expr_idx
= SCM_CDR (expr_idx
))
605 const SCM expr
= SCM_CAR (expr_idx
);
606 um_expr
= unmemoize_expression (expr
, env
);
607 r_result
= scm_cons (um_expr
, r_result
);
609 um_expr
= unmemoize_expression (expr_idx
, env
);
610 if (!SCM_NULLP (r_result
))
612 const SCM result
= scm_reverse_x (r_result
, SCM_UNDEFINED
);
613 SCM_SETCDR (r_result
, um_expr
);
623 /* Rewrite the body (which is given as the list of expressions forming the
624 * body) into its internal form. The internal form of a body (<expr> ...) is
625 * just the body itself, but prefixed with an ISYM that denotes to what kind
626 * of outer construct this body belongs: (<ISYM> <expr> ...). A lambda body
627 * starts with SCM_IM_LAMBDA, for example, a body of a let starts with
630 * It is assumed that the calling expression has already made sure that the
631 * body is a proper list. */
633 m_body (SCM op
, SCM exprs
)
635 /* Don't add another ISYM if one is present already. */
636 if (SCM_ISYMP (SCM_CAR (exprs
)))
639 return scm_cons (op
, exprs
);
643 /* The function m_expand_body memoizes a proper list of expressions forming a
644 * body. This function takes care of dealing with internal defines and
645 * transforming them into an equivalent letrec expression. The list of
646 * expressions is rewritten in place. */
648 /* This is a helper function for m_expand_body. If the argument expression is
649 * a symbol that denotes a syntactic keyword, the corresponding macro object
650 * is returned, in all other cases the function returns SCM_UNDEFINED. */
652 try_macro_lookup (const SCM expr
, const SCM env
)
654 if (scm_is_symbol (expr
))
656 const SCM variable
= lookup_symbol (expr
, env
);
657 if (SCM_VARIABLEP (variable
))
659 const SCM value
= SCM_VARIABLE_REF (variable
);
660 if (SCM_MACROP (value
))
665 return SCM_UNDEFINED
;
668 /* This is a helper function for m_expand_body. It expands user macros,
669 * because for the correct translation of a body we need to know whether they
670 * expand to a definition. */
672 expand_user_macros (SCM expr
, const SCM env
)
674 while (SCM_CONSP (expr
))
676 const SCM car_expr
= SCM_CAR (expr
);
677 const SCM new_car
= expand_user_macros (car_expr
, env
);
678 const SCM value
= try_macro_lookup (new_car
, env
);
680 if (SCM_MACROP (value
) && SCM_MACRO_TYPE (value
) == 2)
682 /* User macros transform code into code. */
683 expr
= scm_call_2 (SCM_MACRO_CODE (value
), expr
, env
);
684 /* We need to reiterate on the transformed code. */
688 /* No user macro: return. */
689 SCM_SETCAR (expr
, new_car
);
697 /* This is a helper function for m_expand_body. It determines if a given form
698 * represents an application of a given built-in macro. The built-in macro to
699 * check for is identified by its syntactic keyword. The form is an
700 * application of the given macro if looking up the car of the form in the
701 * given environment actually returns the built-in macro. */
703 is_system_macro_p (const SCM syntactic_keyword
, const SCM form
, const SCM env
)
705 if (SCM_CONSP (form
))
707 const SCM car_form
= SCM_CAR (form
);
708 const SCM value
= try_macro_lookup (car_form
, env
);
709 if (SCM_BUILTIN_MACRO_P (value
))
711 const SCM macro_name
= scm_macro_name (value
);
712 return scm_is_eq (macro_name
, syntactic_keyword
);
720 m_expand_body (const SCM forms
, const SCM env
)
722 /* The first body form can be skipped since it is known to be the ISYM that
723 * was prepended to the body by m_body. */
724 SCM cdr_forms
= SCM_CDR (forms
);
725 SCM form_idx
= cdr_forms
;
726 SCM definitions
= SCM_EOL
;
727 SCM sequence
= SCM_EOL
;
729 /* According to R5RS, the list of body forms consists of two parts: a number
730 * (maybe zero) of definitions, followed by a non-empty sequence of
731 * expressions. Each the definitions and the expressions may be grouped
732 * arbitrarily with begin, but it is not allowed to mix definitions and
733 * expressions. The task of the following loop therefore is to split the
734 * list of body forms into the list of definitions and the sequence of
736 while (!SCM_NULLP (form_idx
))
738 const SCM form
= SCM_CAR (form_idx
);
739 const SCM new_form
= expand_user_macros (form
, env
);
740 if (is_system_macro_p (scm_sym_define
, new_form
, env
))
742 definitions
= scm_cons (new_form
, definitions
);
743 form_idx
= SCM_CDR (form_idx
);
745 else if (is_system_macro_p (scm_sym_begin
, new_form
, env
))
747 /* We have encountered a group of forms. This has to be either a
748 * (possibly empty) group of (possibly further grouped) definitions,
749 * or a non-empty group of (possibly further grouped)
751 const SCM grouped_forms
= SCM_CDR (new_form
);
752 unsigned int found_definition
= 0;
753 unsigned int found_expression
= 0;
754 SCM grouped_form_idx
= grouped_forms
;
755 while (!found_expression
&& !SCM_NULLP (grouped_form_idx
))
757 const SCM inner_form
= SCM_CAR (grouped_form_idx
);
758 const SCM new_inner_form
= expand_user_macros (inner_form
, env
);
759 if (is_system_macro_p (scm_sym_define
, new_inner_form
, env
))
761 found_definition
= 1;
762 definitions
= scm_cons (new_inner_form
, definitions
);
763 grouped_form_idx
= SCM_CDR (grouped_form_idx
);
765 else if (is_system_macro_p (scm_sym_begin
, new_inner_form
, env
))
767 const SCM inner_group
= SCM_CDR (new_inner_form
);
769 = scm_append (scm_list_2 (inner_group
,
770 SCM_CDR (grouped_form_idx
)));
774 /* The group marks the start of the expressions of the body.
775 * We have to make sure that within the same group we have
776 * not encountered a definition before. */
777 ASSERT_SYNTAX (!found_definition
, s_mixed_body_forms
, form
);
778 found_expression
= 1;
779 grouped_form_idx
= SCM_EOL
;
783 /* We have finished processing the group. If we have not yet
784 * encountered an expression we continue processing the forms of the
785 * body to collect further definition forms. Otherwise, the group
786 * marks the start of the sequence of expressions of the body. */
787 if (!found_expression
)
789 form_idx
= SCM_CDR (form_idx
);
799 /* We have detected a form which is no definition. This marks the
800 * start of the sequence of expressions of the body. */
806 /* FIXME: forms does not hold information about the file location. */
807 ASSERT_SYNTAX (SCM_CONSP (sequence
), s_missing_body_expression
, cdr_forms
);
809 if (!SCM_NULLP (definitions
))
813 SCM letrec_expression
;
814 SCM new_letrec_expression
;
816 SCM bindings
= SCM_EOL
;
817 for (definition_idx
= definitions
;
818 !SCM_NULLP (definition_idx
);
819 definition_idx
= SCM_CDR (definition_idx
))
821 const SCM definition
= SCM_CAR (definition_idx
);
822 const SCM canonical_definition
= canonicalize_define (definition
);
823 const SCM binding
= SCM_CDR (canonical_definition
);
824 bindings
= scm_cons (binding
, bindings
);
827 letrec_tail
= scm_cons (bindings
, sequence
);
828 /* FIXME: forms does not hold information about the file location. */
829 letrec_expression
= scm_cons_source (forms
, scm_sym_letrec
, letrec_tail
);
830 new_letrec_expression
= scm_m_letrec (letrec_expression
, env
);
831 SCM_SETCAR (forms
, new_letrec_expression
);
832 SCM_SETCDR (forms
, SCM_EOL
);
836 SCM_SETCAR (forms
, SCM_CAR (sequence
));
837 SCM_SETCDR (forms
, SCM_CDR (sequence
));
842 macroexp (SCM x
, SCM env
)
844 SCM res
, proc
, orig_sym
;
846 /* Don't bother to produce error messages here. We get them when we
847 eventually execute the code for real. */
850 orig_sym
= SCM_CAR (x
);
851 if (!scm_is_symbol (orig_sym
))
855 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
856 if (proc_ptr
== NULL
)
858 /* We have lost the race. */
864 /* Only handle memoizing macros. `Acros' and `macros' are really
865 special forms and should not be evaluated here. */
867 if (!SCM_MACROP (proc
)
868 || (SCM_MACRO_TYPE (proc
) != 2 && !SCM_BUILTIN_MACRO_P (proc
)))
871 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
872 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
874 if (scm_ilength (res
) <= 0)
875 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
878 SCM_SETCAR (x
, SCM_CAR (res
));
879 SCM_SETCDR (x
, SCM_CDR (res
));
885 /* Start of the memoizers for the standard R5RS builtin macros. */
888 SCM_SYNTAX (s_and
, "and", scm_i_makbimacro
, scm_m_and
);
889 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
892 scm_m_and (SCM expr
, SCM env SCM_UNUSED
)
894 const SCM cdr_expr
= SCM_CDR (expr
);
895 const long length
= scm_ilength (cdr_expr
);
897 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
901 /* Special case: (and) is replaced by #t. */
906 SCM_SETCAR (expr
, SCM_IM_AND
);
912 unmemoize_and (const SCM expr
, const SCM env
)
914 return scm_cons (scm_sym_and
, unmemoize_exprs (SCM_CDR (expr
), env
));
918 SCM_SYNTAX (s_begin
, "begin", scm_i_makbimacro
, scm_m_begin
);
919 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
922 scm_m_begin (SCM expr
, SCM env SCM_UNUSED
)
924 const SCM cdr_expr
= SCM_CDR (expr
);
925 /* Dirk:FIXME:: An empty begin clause is not generally allowed by R5RS.
926 * That means, there should be a distinction between uses of begin where an
927 * empty clause is OK and where it is not. */
928 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
930 SCM_SETCAR (expr
, SCM_IM_BEGIN
);
935 unmemoize_begin (const SCM expr
, const SCM env
)
937 return scm_cons (scm_sym_begin
, unmemoize_exprs (SCM_CDR (expr
), env
));
941 SCM_SYNTAX (s_case
, "case", scm_i_makbimacro
, scm_m_case
);
942 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
943 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
946 scm_m_case (SCM expr
, SCM env
)
949 SCM all_labels
= SCM_EOL
;
951 /* Check, whether 'else is a literal, i. e. not bound to a value. */
952 const int else_literal_p
= literal_p (scm_sym_else
, env
);
954 const SCM cdr_expr
= SCM_CDR (expr
);
955 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
956 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_clauses
, expr
);
958 clauses
= SCM_CDR (cdr_expr
);
959 while (!SCM_NULLP (clauses
))
963 const SCM clause
= SCM_CAR (clauses
);
964 ASSERT_SYNTAX_2 (scm_ilength (clause
) >= 2,
965 s_bad_case_clause
, clause
, expr
);
967 labels
= SCM_CAR (clause
);
968 if (SCM_CONSP (labels
))
970 ASSERT_SYNTAX_2 (scm_ilength (labels
) >= 0,
971 s_bad_case_labels
, labels
, expr
);
972 all_labels
= scm_append (scm_list_2 (labels
, all_labels
));
974 else if (SCM_NULLP (labels
))
976 /* The list of labels is empty. According to R5RS this is allowed.
977 * It means that the sequence of expressions will never be executed.
978 * Therefore, as an optimization, we could remove the whole
983 ASSERT_SYNTAX_2 (scm_is_eq (labels
, scm_sym_else
) && else_literal_p
,
984 s_bad_case_labels
, labels
, expr
);
985 ASSERT_SYNTAX_2 (SCM_NULLP (SCM_CDR (clauses
)),
986 s_misplaced_else_clause
, clause
, expr
);
989 /* build the new clause */
990 if (scm_is_eq (labels
, scm_sym_else
))
991 SCM_SETCAR (clause
, SCM_IM_ELSE
);
993 clauses
= SCM_CDR (clauses
);
996 /* Check whether all case labels are distinct. */
997 for (; !SCM_NULLP (all_labels
); all_labels
= SCM_CDR (all_labels
))
999 const SCM label
= SCM_CAR (all_labels
);
1000 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (label
, SCM_CDR (all_labels
))),
1001 s_duplicate_case_label
, label
, expr
);
1004 SCM_SETCAR (expr
, SCM_IM_CASE
);
1009 unmemoize_case (const SCM expr
, const SCM env
)
1011 const SCM um_key_expr
= unmemoize_expression (SCM_CADR (expr
), env
);
1012 SCM um_clauses
= SCM_EOL
;
1015 for (clause_idx
= SCM_CDDR (expr
);
1016 !SCM_NULLP (clause_idx
);
1017 clause_idx
= SCM_CDR (clause_idx
))
1019 const SCM clause
= SCM_CAR (clause_idx
);
1020 const SCM labels
= SCM_CAR (clause
);
1021 const SCM exprs
= SCM_CDR (clause
);
1023 const SCM um_exprs
= unmemoize_exprs (exprs
, env
);
1024 const SCM um_labels
= (scm_is_eq (labels
, SCM_IM_ELSE
))
1026 : scm_i_finite_list_copy (labels
);
1027 const SCM um_clause
= scm_cons (um_labels
, um_exprs
);
1029 um_clauses
= scm_cons (um_clause
, um_clauses
);
1031 um_clauses
= scm_reverse_x (um_clauses
, SCM_UNDEFINED
);
1033 return scm_cons2 (scm_sym_case
, um_key_expr
, um_clauses
);
1037 SCM_SYNTAX (s_cond
, "cond", scm_i_makbimacro
, scm_m_cond
);
1038 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
1039 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
1042 scm_m_cond (SCM expr
, SCM env
)
1044 /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
1045 const int else_literal_p
= literal_p (scm_sym_else
, env
);
1046 const int arrow_literal_p
= literal_p (scm_sym_arrow
, env
);
1048 const SCM clauses
= SCM_CDR (expr
);
1051 ASSERT_SYNTAX (scm_ilength (clauses
) >= 0, s_bad_expression
, expr
);
1052 ASSERT_SYNTAX (scm_ilength (clauses
) >= 1, s_missing_clauses
, expr
);
1054 for (clause_idx
= clauses
;
1055 !SCM_NULLP (clause_idx
);
1056 clause_idx
= SCM_CDR (clause_idx
))
1060 const SCM clause
= SCM_CAR (clause_idx
);
1061 const long length
= scm_ilength (clause
);
1062 ASSERT_SYNTAX_2 (length
>= 1, s_bad_cond_clause
, clause
, expr
);
1064 test
= SCM_CAR (clause
);
1065 if (scm_is_eq (test
, scm_sym_else
) && else_literal_p
)
1067 const int last_clause_p
= SCM_NULLP (SCM_CDR (clause_idx
));
1068 ASSERT_SYNTAX_2 (length
>= 2,
1069 s_bad_cond_clause
, clause
, expr
);
1070 ASSERT_SYNTAX_2 (last_clause_p
,
1071 s_misplaced_else_clause
, clause
, expr
);
1072 SCM_SETCAR (clause
, SCM_IM_ELSE
);
1074 else if (length
>= 2
1075 && scm_is_eq (SCM_CADR (clause
), scm_sym_arrow
)
1078 ASSERT_SYNTAX_2 (length
> 2, s_missing_recipient
, clause
, expr
);
1079 ASSERT_SYNTAX_2 (length
== 3, s_extra_expression
, clause
, expr
);
1080 SCM_SETCAR (SCM_CDR (clause
), SCM_IM_ARROW
);
1084 SCM_SETCAR (expr
, SCM_IM_COND
);
1089 unmemoize_cond (const SCM expr
, const SCM env
)
1091 SCM um_clauses
= SCM_EOL
;
1094 for (clause_idx
= SCM_CDR (expr
);
1095 !SCM_NULLP (clause_idx
);
1096 clause_idx
= SCM_CDR (clause_idx
))
1098 const SCM clause
= SCM_CAR (clause_idx
);
1099 const SCM sequence
= SCM_CDR (clause
);
1100 const SCM test
= SCM_CAR (clause
);
1105 if (scm_is_eq (test
, SCM_IM_ELSE
))
1106 um_test
= scm_sym_else
;
1108 um_test
= unmemoize_expression (test
, env
);
1110 if (!SCM_NULLP (sequence
) && scm_is_eq (SCM_CAR (sequence
),
1113 const SCM target
= SCM_CADR (sequence
);
1114 const SCM um_target
= unmemoize_expression (target
, env
);
1115 um_sequence
= scm_list_2 (scm_sym_arrow
, um_target
);
1119 um_sequence
= unmemoize_exprs (sequence
, env
);
1122 um_clause
= scm_cons (um_test
, um_sequence
);
1123 um_clauses
= scm_cons (um_clause
, um_clauses
);
1125 um_clauses
= scm_reverse_x (um_clauses
, SCM_UNDEFINED
);
1127 return scm_cons (scm_sym_cond
, um_clauses
);
1131 SCM_SYNTAX (s_define
, "define", scm_i_makbimacro
, scm_m_define
);
1132 SCM_GLOBAL_SYMBOL (scm_sym_define
, s_define
);
1134 /* Guile provides an extension to R5RS' define syntax to represent function
1135 * currying in a compact way. With this extension, it is allowed to write
1136 * (define <nested-variable> <body>), where <nested-variable> has of one of
1137 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
1138 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
1139 * should be either a sequence of zero or more variables, or a sequence of one
1140 * or more variables followed by a space-delimited period and another
1141 * variable. Each level of argument nesting wraps the <body> within another
1142 * lambda expression. For example, the following forms are allowed, each one
1143 * followed by an equivalent, more explicit implementation.
1145 * (define ((a b . c) . d) <body>) is equivalent to
1146 * (define a (lambda (b . c) (lambda d <body>)))
1148 * (define (((a) b) c . d) <body>) is equivalent to
1149 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
1151 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
1152 * module that does not implement this extension. */
1154 canonicalize_define (const SCM expr
)
1159 const SCM cdr_expr
= SCM_CDR (expr
);
1160 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1161 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1163 body
= SCM_CDR (cdr_expr
);
1164 variable
= SCM_CAR (cdr_expr
);
1165 while (SCM_CONSP (variable
))
1167 /* This while loop realizes function currying by variable nesting.
1168 * Variable is known to be a nested-variable. In every iteration of the
1169 * loop another level of lambda expression is created, starting with the
1170 * innermost one. Note that we don't check for duplicate formals here:
1171 * This will be done by the memoizer of the lambda expression. */
1172 const SCM formals
= SCM_CDR (variable
);
1173 const SCM tail
= scm_cons (formals
, body
);
1175 /* Add source properties to each new lambda expression: */
1176 const SCM lambda
= scm_cons_source (variable
, scm_sym_lambda
, tail
);
1178 body
= scm_list_1 (lambda
);
1179 variable
= SCM_CAR (variable
);
1181 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
1182 ASSERT_SYNTAX (scm_ilength (body
) == 1, s_expression
, expr
);
1184 SCM_SETCAR (cdr_expr
, variable
);
1185 SCM_SETCDR (cdr_expr
, body
);
1189 /* According to section 5.2.1 of R5RS we first have to make sure that the
1190 * variable is bound, and then perform the (set! variable expression)
1191 * operation. This means, that within the expression we may already assign
1192 * values to variable: (define foo (begin (set! foo 1) (+ foo 1))) */
1194 scm_m_define (SCM expr
, SCM env
)
1196 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), s_bad_define
, expr
);
1199 const SCM canonical_definition
= canonicalize_define (expr
);
1200 const SCM cdr_canonical_definition
= SCM_CDR (canonical_definition
);
1201 const SCM variable
= SCM_CAR (cdr_canonical_definition
);
1203 = scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_T
);
1204 const SCM value
= scm_eval_car (SCM_CDR (cdr_canonical_definition
), env
);
1206 if (SCM_REC_PROCNAMES_P
)
1209 while (SCM_MACROP (tmp
))
1210 tmp
= SCM_MACRO_CODE (tmp
);
1211 if (SCM_CLOSUREP (tmp
)
1212 /* Only the first definition determines the name. */
1213 && scm_is_false (scm_procedure_property (tmp
, scm_sym_name
)))
1214 scm_set_procedure_property_x (tmp
, scm_sym_name
, variable
);
1217 SCM_VARIABLE_SET (location
, value
);
1219 return SCM_UNSPECIFIED
;
1224 /* This is a helper function for forms (<keyword> <expression>) that are
1225 * transformed into (#@<keyword> '() <memoized_expression>) in order to allow
1226 * for easy creation of a thunk (i. e. a closure without arguments) using the
1227 * ('() <memoized_expression>) tail of the memoized form. */
1229 memoize_as_thunk_prototype (const SCM expr
, const SCM env SCM_UNUSED
)
1231 const SCM cdr_expr
= SCM_CDR (expr
);
1232 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1233 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1235 SCM_SETCDR (expr
, scm_cons (SCM_EOL
, cdr_expr
));
1241 SCM_SYNTAX (s_delay
, "delay", scm_i_makbimacro
, scm_m_delay
);
1242 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
1244 /* Promises are implemented as closures with an empty parameter list. Thus,
1245 * (delay <expression>) is transformed into (#@delay '() <expression>), where
1246 * the empty list represents the empty parameter list. This representation
1247 * allows for easy creation of the closure during evaluation. */
1249 scm_m_delay (SCM expr
, SCM env
)
1251 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1252 SCM_SETCAR (new_expr
, SCM_IM_DELAY
);
1257 unmemoize_delay (const SCM expr
, const SCM env
)
1259 const SCM thunk_expr
= SCM_CADDR (expr
);
1260 return scm_list_2 (scm_sym_delay
, unmemoize_expression (thunk_expr
, env
));
1264 SCM_SYNTAX(s_do
, "do", scm_i_makbimacro
, scm_m_do
);
1265 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
1267 /* DO gets the most radically altered syntax. The order of the vars is
1268 * reversed here. During the evaluation this allows for simple consing of the
1269 * results of the inits and steps:
1271 (do ((<var1> <init1> <step1>)
1279 (#@do (<init1> <init2> ... <initn>)
1280 (varn ... var2 var1)
1283 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
1286 scm_m_do (SCM expr
, SCM env SCM_UNUSED
)
1288 SCM variables
= SCM_EOL
;
1289 SCM init_forms
= SCM_EOL
;
1290 SCM step_forms
= SCM_EOL
;
1297 const SCM cdr_expr
= SCM_CDR (expr
);
1298 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1299 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1301 /* Collect variables, init and step forms. */
1302 binding_idx
= SCM_CAR (cdr_expr
);
1303 ASSERT_SYNTAX_2 (scm_ilength (binding_idx
) >= 0,
1304 s_bad_bindings
, binding_idx
, expr
);
1305 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1307 const SCM binding
= SCM_CAR (binding_idx
);
1308 const long length
= scm_ilength (binding
);
1309 ASSERT_SYNTAX_2 (length
== 2 || length
== 3,
1310 s_bad_binding
, binding
, expr
);
1313 const SCM name
= SCM_CAR (binding
);
1314 const SCM init
= SCM_CADR (binding
);
1315 const SCM step
= (length
== 2) ? name
: SCM_CADDR (binding
);
1316 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
1317 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, variables
)),
1318 s_duplicate_binding
, name
, expr
);
1320 variables
= scm_cons (name
, variables
);
1321 init_forms
= scm_cons (init
, init_forms
);
1322 step_forms
= scm_cons (step
, step_forms
);
1325 init_forms
= scm_reverse_x (init_forms
, SCM_UNDEFINED
);
1326 step_forms
= scm_reverse_x (step_forms
, SCM_UNDEFINED
);
1328 /* Memoize the test form and the exit sequence. */
1329 cddr_expr
= SCM_CDR (cdr_expr
);
1330 exit_clause
= SCM_CAR (cddr_expr
);
1331 ASSERT_SYNTAX_2 (scm_ilength (exit_clause
) >= 1,
1332 s_bad_exit_clause
, exit_clause
, expr
);
1334 commands
= SCM_CDR (cddr_expr
);
1335 tail
= scm_cons2 (exit_clause
, commands
, step_forms
);
1336 tail
= scm_cons2 (init_forms
, variables
, tail
);
1337 SCM_SETCAR (expr
, SCM_IM_DO
);
1338 SCM_SETCDR (expr
, tail
);
1343 unmemoize_do (const SCM expr
, const SCM env
)
1345 const SCM cdr_expr
= SCM_CDR (expr
);
1346 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1347 const SCM rnames
= SCM_CAR (cddr_expr
);
1348 const SCM extended_env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
1349 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
1350 const SCM exit_sequence
= SCM_CAR (cdddr_expr
);
1351 const SCM um_exit_sequence
= unmemoize_exprs (exit_sequence
, extended_env
);
1352 const SCM cddddr_expr
= SCM_CDR (cdddr_expr
);
1353 const SCM um_body
= unmemoize_exprs (SCM_CAR (cddddr_expr
), extended_env
);
1355 /* build transformed binding list */
1356 SCM um_names
= scm_reverse (rnames
);
1357 SCM um_inits
= unmemoize_exprs (SCM_CAR (cdr_expr
), env
);
1358 SCM um_steps
= unmemoize_exprs (SCM_CDR (cddddr_expr
), extended_env
);
1359 SCM um_bindings
= SCM_EOL
;
1360 while (!SCM_NULLP (um_names
))
1362 const SCM name
= SCM_CAR (um_names
);
1363 const SCM init
= SCM_CAR (um_inits
);
1364 SCM step
= SCM_CAR (um_steps
);
1365 step
= scm_is_eq (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
1367 um_bindings
= scm_cons (scm_cons2 (name
, init
, step
), um_bindings
);
1369 um_names
= SCM_CDR (um_names
);
1370 um_inits
= SCM_CDR (um_inits
);
1371 um_steps
= SCM_CDR (um_steps
);
1373 um_bindings
= scm_reverse_x (um_bindings
, SCM_UNDEFINED
);
1375 return scm_cons (scm_sym_do
,
1376 scm_cons2 (um_bindings
, um_exit_sequence
, um_body
));
1380 SCM_SYNTAX (s_if
, "if", scm_i_makbimacro
, scm_m_if
);
1381 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
1384 scm_m_if (SCM expr
, SCM env SCM_UNUSED
)
1386 const SCM cdr_expr
= SCM_CDR (expr
);
1387 const long length
= scm_ilength (cdr_expr
);
1388 ASSERT_SYNTAX (length
== 2 || length
== 3, s_expression
, expr
);
1389 SCM_SETCAR (expr
, SCM_IM_IF
);
1394 unmemoize_if (const SCM expr
, const SCM env
)
1396 const SCM cdr_expr
= SCM_CDR (expr
);
1397 const SCM um_condition
= unmemoize_expression (SCM_CAR (cdr_expr
), env
);
1398 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1399 const SCM um_then
= unmemoize_expression (SCM_CAR (cddr_expr
), env
);
1400 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
1402 if (SCM_NULLP (cdddr_expr
))
1404 return scm_list_3 (scm_sym_if
, um_condition
, um_then
);
1408 const SCM um_else
= unmemoize_expression (SCM_CAR (cdddr_expr
), env
);
1409 return scm_list_4 (scm_sym_if
, um_condition
, um_then
, um_else
);
1414 SCM_SYNTAX (s_lambda
, "lambda", scm_i_makbimacro
, scm_m_lambda
);
1415 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
1417 /* A helper function for memoize_lambda to support checking for duplicate
1418 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
1419 * LIST or to the cdr of the last cons. Therefore, LIST may have any of the
1420 * forms that a formal argument can have:
1421 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
1423 c_improper_memq (SCM obj
, SCM list
)
1425 for (; SCM_CONSP (list
); list
= SCM_CDR (list
))
1427 if (scm_is_eq (SCM_CAR (list
), obj
))
1430 return scm_is_eq (list
, obj
);
1434 scm_m_lambda (SCM expr
, SCM env SCM_UNUSED
)
1443 const SCM cdr_expr
= SCM_CDR (expr
);
1444 const long length
= scm_ilength (cdr_expr
);
1445 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1446 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1448 /* Before iterating the list of formal arguments, make sure the formals
1449 * actually are given as either a symbol or a non-cyclic list. */
1450 formals
= SCM_CAR (cdr_expr
);
1451 if (SCM_CONSP (formals
))
1453 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
1454 * detected, report a 'Bad formals' error. */
1458 ASSERT_SYNTAX_2 (scm_is_symbol (formals
) || SCM_NULLP (formals
),
1459 s_bad_formals
, formals
, expr
);
1462 /* Now iterate the list of formal arguments to check if all formals are
1463 * symbols, and that there are no duplicates. */
1464 formals_idx
= formals
;
1465 while (SCM_CONSP (formals_idx
))
1467 const SCM formal
= SCM_CAR (formals_idx
);
1468 const SCM next_idx
= SCM_CDR (formals_idx
);
1469 ASSERT_SYNTAX_2 (scm_is_symbol (formal
), s_bad_formal
, formal
, expr
);
1470 ASSERT_SYNTAX_2 (!c_improper_memq (formal
, next_idx
),
1471 s_duplicate_formal
, formal
, expr
);
1472 formals_idx
= next_idx
;
1474 ASSERT_SYNTAX_2 (SCM_NULLP (formals_idx
) || scm_is_symbol (formals_idx
),
1475 s_bad_formal
, formals_idx
, expr
);
1477 /* Memoize the body. Keep a potential documentation string. */
1478 /* Dirk:FIXME:: We should probably extract the documentation string to
1479 * some external database. Otherwise it will slow down execution, since
1480 * the documentation string will have to be skipped with every execution
1481 * of the closure. */
1482 cddr_expr
= SCM_CDR (cdr_expr
);
1483 documentation
= (length
>= 3 && scm_is_string (SCM_CAR (cddr_expr
)));
1484 body
= documentation
? SCM_CDR (cddr_expr
) : cddr_expr
;
1485 new_body
= m_body (SCM_IM_LAMBDA
, body
);
1487 SCM_SETCAR (expr
, SCM_IM_LAMBDA
);
1489 SCM_SETCDR (cddr_expr
, new_body
);
1491 SCM_SETCDR (cdr_expr
, new_body
);
1496 unmemoize_lambda (const SCM expr
, const SCM env
)
1498 const SCM formals
= SCM_CADR (expr
);
1499 const SCM body
= SCM_CDDR (expr
);
1501 const SCM new_env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, env
);
1502 const SCM um_formals
= scm_i_finite_list_copy (formals
);
1503 const SCM um_body
= unmemoize_exprs (body
, new_env
);
1505 return scm_cons2 (scm_sym_lambda
, um_formals
, um_body
);
1509 /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
1511 check_bindings (const SCM bindings
, const SCM expr
)
1515 ASSERT_SYNTAX_2 (scm_ilength (bindings
) >= 0,
1516 s_bad_bindings
, bindings
, expr
);
1518 binding_idx
= bindings
;
1519 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1521 SCM name
; /* const */
1523 const SCM binding
= SCM_CAR (binding_idx
);
1524 ASSERT_SYNTAX_2 (scm_ilength (binding
) == 2,
1525 s_bad_binding
, binding
, expr
);
1527 name
= SCM_CAR (binding
);
1528 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
1533 /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
1534 * transformed to the lists (vn ... v2 v1) and (i1 i2 ... in). That is, the
1535 * variables are returned in a list with their order reversed, and the init
1536 * forms are returned in a list in the same order as they are given in the
1537 * bindings. If a duplicate variable name is detected, an error is
1540 transform_bindings (
1541 const SCM bindings
, const SCM expr
,
1542 SCM
*const rvarptr
, SCM
*const initptr
)
1544 SCM rvariables
= SCM_EOL
;
1545 SCM rinits
= SCM_EOL
;
1546 SCM binding_idx
= bindings
;
1547 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1549 const SCM binding
= SCM_CAR (binding_idx
);
1550 const SCM cdr_binding
= SCM_CDR (binding
);
1551 const SCM name
= SCM_CAR (binding
);
1552 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, rvariables
)),
1553 s_duplicate_binding
, name
, expr
);
1554 rvariables
= scm_cons (name
, rvariables
);
1555 rinits
= scm_cons (SCM_CAR (cdr_binding
), rinits
);
1557 *rvarptr
= rvariables
;
1558 *initptr
= scm_reverse_x (rinits
, SCM_UNDEFINED
);
1562 SCM_SYNTAX(s_let
, "let", scm_i_makbimacro
, scm_m_let
);
1563 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
1565 /* This function is a helper function for memoize_let. It transforms
1566 * (let name ((var init) ...) body ...) into
1567 * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
1568 * and memoizes the expression. It is assumed that the caller has checked
1569 * that name is a symbol and that there are bindings and a body. */
1571 memoize_named_let (const SCM expr
, const SCM env SCM_UNUSED
)
1577 const SCM cdr_expr
= SCM_CDR (expr
);
1578 const SCM name
= SCM_CAR (cdr_expr
);
1579 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1580 const SCM bindings
= SCM_CAR (cddr_expr
);
1581 check_bindings (bindings
, expr
);
1583 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1584 variables
= scm_reverse_x (rvariables
, SCM_UNDEFINED
);
1587 const SCM let_body
= SCM_CDR (cddr_expr
);
1588 const SCM lambda_body
= m_body (SCM_IM_LET
, let_body
);
1589 const SCM lambda_tail
= scm_cons (variables
, lambda_body
);
1590 const SCM lambda_form
= scm_cons_source (expr
, scm_sym_lambda
, lambda_tail
);
1592 const SCM rvar
= scm_list_1 (name
);
1593 const SCM init
= scm_list_1 (lambda_form
);
1594 const SCM body
= m_body (SCM_IM_LET
, scm_list_1 (name
));
1595 const SCM letrec_tail
= scm_cons (rvar
, scm_cons (init
, body
));
1596 const SCM letrec_form
= scm_cons_source (expr
, SCM_IM_LETREC
, letrec_tail
);
1597 return scm_cons_source (expr
, letrec_form
, inits
);
1601 /* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1602 * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
1604 scm_m_let (SCM expr
, SCM env
)
1608 const SCM cdr_expr
= SCM_CDR (expr
);
1609 const long length
= scm_ilength (cdr_expr
);
1610 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1611 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1613 bindings
= SCM_CAR (cdr_expr
);
1614 if (scm_is_symbol (bindings
))
1616 ASSERT_SYNTAX (length
>= 3, s_missing_expression
, expr
);
1617 return memoize_named_let (expr
, env
);
1620 check_bindings (bindings
, expr
);
1621 if (SCM_NULLP (bindings
) || SCM_NULLP (SCM_CDR (bindings
)))
1623 /* Special case: no bindings or single binding => let* is faster. */
1624 const SCM body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1625 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), bindings
, body
), env
);
1632 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1635 const SCM new_body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1636 const SCM new_tail
= scm_cons2 (rvariables
, inits
, new_body
);
1637 SCM_SETCAR (expr
, SCM_IM_LET
);
1638 SCM_SETCDR (expr
, new_tail
);
1645 build_binding_list (SCM rnames
, SCM rinits
)
1647 SCM bindings
= SCM_EOL
;
1648 while (!SCM_NULLP (rnames
))
1650 const SCM binding
= scm_list_2 (SCM_CAR (rnames
), SCM_CAR (rinits
));
1651 bindings
= scm_cons (binding
, bindings
);
1652 rnames
= SCM_CDR (rnames
);
1653 rinits
= SCM_CDR (rinits
);
1659 unmemoize_let (const SCM expr
, const SCM env
)
1661 const SCM cdr_expr
= SCM_CDR (expr
);
1662 const SCM um_rnames
= SCM_CAR (cdr_expr
);
1663 const SCM extended_env
= SCM_EXTEND_ENV (um_rnames
, SCM_EOL
, env
);
1664 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1665 const SCM um_inits
= unmemoize_exprs (SCM_CAR (cddr_expr
), env
);
1666 const SCM um_rinits
= scm_reverse_x (um_inits
, SCM_UNDEFINED
);
1667 const SCM um_bindings
= build_binding_list (um_rnames
, um_rinits
);
1668 const SCM um_body
= unmemoize_exprs (SCM_CDR (cddr_expr
), extended_env
);
1670 return scm_cons2 (scm_sym_let
, um_bindings
, um_body
);
1674 SCM_SYNTAX(s_letrec
, "letrec", scm_i_makbimacro
, scm_m_letrec
);
1675 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
1678 scm_m_letrec (SCM expr
, SCM env
)
1682 const SCM cdr_expr
= SCM_CDR (expr
);
1683 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1684 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1686 bindings
= SCM_CAR (cdr_expr
);
1687 if (SCM_NULLP (bindings
))
1689 /* no bindings, let* is executed faster */
1690 SCM body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1691 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), SCM_EOL
, body
), env
);
1699 check_bindings (bindings
, expr
);
1700 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1701 new_body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1702 return scm_cons2 (SCM_IM_LETREC
, rvariables
, scm_cons (inits
, new_body
));
1707 unmemoize_letrec (const SCM expr
, const SCM env
)
1709 const SCM cdr_expr
= SCM_CDR (expr
);
1710 const SCM um_rnames
= SCM_CAR (cdr_expr
);
1711 const SCM extended_env
= SCM_EXTEND_ENV (um_rnames
, SCM_EOL
, env
);
1712 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1713 const SCM um_inits
= unmemoize_exprs (SCM_CAR (cddr_expr
), extended_env
);
1714 const SCM um_rinits
= scm_reverse_x (um_inits
, SCM_UNDEFINED
);
1715 const SCM um_bindings
= build_binding_list (um_rnames
, um_rinits
);
1716 const SCM um_body
= unmemoize_exprs (SCM_CDR (cddr_expr
), extended_env
);
1718 return scm_cons2 (scm_sym_letrec
, um_bindings
, um_body
);
1723 SCM_SYNTAX (s_letstar
, "let*", scm_i_makbimacro
, scm_m_letstar
);
1724 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
1726 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1727 * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
1729 scm_m_letstar (SCM expr
, SCM env SCM_UNUSED
)
1734 const SCM cdr_expr
= SCM_CDR (expr
);
1735 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1736 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1738 binding_idx
= SCM_CAR (cdr_expr
);
1739 check_bindings (binding_idx
, expr
);
1741 /* Transform ((v1 i1) (v2 i2) ...) into (v1 i1 v2 i2 ...). The
1742 * transformation is done in place. At the beginning of one iteration of
1743 * the loop the variable binding_idx holds the form
1744 * P1:( (vn . P2:(in . ())) . P3:( (vn+1 in+1) ... ) ),
1745 * where P1, P2 and P3 indicate the pairs, that are relevant for the
1746 * transformation. P1 and P2 are modified in the loop, P3 remains
1747 * untouched. After the execution of the loop, P1 will hold
1748 * P1:( vn . P2:(in . P3:( (vn+1 in+1) ... )) )
1749 * and binding_idx will hold P3. */
1750 while (!SCM_NULLP (binding_idx
))
1752 const SCM cdr_binding_idx
= SCM_CDR (binding_idx
); /* remember P3 */
1753 const SCM binding
= SCM_CAR (binding_idx
);
1754 const SCM name
= SCM_CAR (binding
);
1755 const SCM cdr_binding
= SCM_CDR (binding
);
1757 SCM_SETCDR (cdr_binding
, cdr_binding_idx
); /* update P2 */
1758 SCM_SETCAR (binding_idx
, name
); /* update P1 */
1759 SCM_SETCDR (binding_idx
, cdr_binding
); /* update P1 */
1761 binding_idx
= cdr_binding_idx
; /* continue with P3 */
1764 new_body
= m_body (SCM_IM_LETSTAR
, SCM_CDR (cdr_expr
));
1765 SCM_SETCAR (expr
, SCM_IM_LETSTAR
);
1766 /* the bindings have been changed in place */
1767 SCM_SETCDR (cdr_expr
, new_body
);
1772 unmemoize_letstar (const SCM expr
, const SCM env
)
1774 const SCM cdr_expr
= SCM_CDR (expr
);
1775 const SCM body
= SCM_CDR (cdr_expr
);
1776 SCM bindings
= SCM_CAR (cdr_expr
);
1777 SCM um_bindings
= SCM_EOL
;
1778 SCM extended_env
= env
;
1781 while (!SCM_NULLP (bindings
))
1783 const SCM variable
= SCM_CAR (bindings
);
1784 const SCM init
= SCM_CADR (bindings
);
1785 const SCM um_init
= unmemoize_expression (init
, extended_env
);
1786 um_bindings
= scm_cons (scm_list_2 (variable
, um_init
), um_bindings
);
1787 extended_env
= SCM_EXTEND_ENV (variable
, SCM_BOOL_F
, extended_env
);
1788 bindings
= SCM_CDDR (bindings
);
1790 um_bindings
= scm_reverse_x (um_bindings
, SCM_UNDEFINED
);
1792 um_body
= unmemoize_exprs (body
, extended_env
);
1794 return scm_cons2 (scm_sym_letstar
, um_bindings
, um_body
);
1798 SCM_SYNTAX (s_or
, "or", scm_i_makbimacro
, scm_m_or
);
1799 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
1802 scm_m_or (SCM expr
, SCM env SCM_UNUSED
)
1804 const SCM cdr_expr
= SCM_CDR (expr
);
1805 const long length
= scm_ilength (cdr_expr
);
1807 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1811 /* Special case: (or) is replaced by #f. */
1816 SCM_SETCAR (expr
, SCM_IM_OR
);
1822 unmemoize_or (const SCM expr
, const SCM env
)
1824 return scm_cons (scm_sym_or
, unmemoize_exprs (SCM_CDR (expr
), env
));
1828 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
1829 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
1830 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
1831 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
1833 /* Internal function to handle a quasiquotation: 'form' is the parameter in
1834 * the call (quasiquotation form), 'env' is the environment where unquoted
1835 * expressions will be evaluated, and 'depth' is the current quasiquotation
1836 * nesting level and is known to be greater than zero. */
1838 iqq (SCM form
, SCM env
, unsigned long int depth
)
1840 if (SCM_CONSP (form
))
1842 const SCM tmp
= SCM_CAR (form
);
1843 if (scm_is_eq (tmp
, scm_sym_quasiquote
))
1845 const SCM args
= SCM_CDR (form
);
1846 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1847 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
1849 else if (scm_is_eq (tmp
, scm_sym_unquote
))
1851 const SCM args
= SCM_CDR (form
);
1852 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1854 return scm_eval_car (args
, env
);
1856 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
1858 else if (SCM_CONSP (tmp
)
1859 && scm_is_eq (SCM_CAR (tmp
), scm_sym_uq_splicing
))
1861 const SCM args
= SCM_CDR (tmp
);
1862 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1865 const SCM list
= scm_eval_car (args
, env
);
1866 const SCM rest
= SCM_CDR (form
);
1867 ASSERT_SYNTAX_2 (scm_ilength (list
) >= 0,
1868 s_splicing
, list
, form
);
1869 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
1872 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
1873 iqq (SCM_CDR (form
), env
, depth
));
1876 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
1877 iqq (SCM_CDR (form
), env
, depth
));
1879 else if (SCM_VECTORP (form
))
1881 size_t i
= SCM_VECTOR_LENGTH (form
);
1882 SCM
const *const data
= SCM_VELTS (form
);
1885 tmp
= scm_cons (data
[--i
], tmp
);
1886 scm_remember_upto_here_1 (form
);
1887 return scm_vector (iqq (tmp
, env
, depth
));
1894 scm_m_quasiquote (SCM expr
, SCM env
)
1896 const SCM cdr_expr
= SCM_CDR (expr
);
1897 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1898 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1899 return iqq (SCM_CAR (cdr_expr
), env
, 1);
1903 SCM_SYNTAX (s_quote
, "quote", scm_i_makbimacro
, scm_m_quote
);
1904 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
1907 scm_m_quote (SCM expr
, SCM env SCM_UNUSED
)
1911 const SCM cdr_expr
= SCM_CDR (expr
);
1912 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1913 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1914 quotee
= SCM_CAR (cdr_expr
);
1915 if (is_self_quoting_p (quotee
))
1918 SCM_SETCAR (expr
, SCM_IM_QUOTE
);
1919 SCM_SETCDR (expr
, quotee
);
1924 unmemoize_quote (const SCM expr
, const SCM env SCM_UNUSED
)
1926 return scm_list_2 (scm_sym_quote
, SCM_CDR (expr
));
1930 /* Will go into the RnRS module when Guile is factorized.
1931 SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
1932 static const char s_set_x
[] = "set!";
1933 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, s_set_x
);
1936 scm_m_set_x (SCM expr
, SCM env SCM_UNUSED
)
1941 const SCM cdr_expr
= SCM_CDR (expr
);
1942 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1943 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1944 variable
= SCM_CAR (cdr_expr
);
1946 /* Memoize the variable form. */
1947 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
1948 new_variable
= lookup_symbol (variable
, env
);
1949 /* Leave the memoization of unbound symbols to lazy memoization: */
1950 if (SCM_UNBNDP (new_variable
))
1951 new_variable
= variable
;
1953 SCM_SETCAR (expr
, SCM_IM_SET_X
);
1954 SCM_SETCAR (cdr_expr
, new_variable
);
1959 unmemoize_set_x (const SCM expr
, const SCM env
)
1961 return scm_cons (scm_sym_set_x
, unmemoize_exprs (SCM_CDR (expr
), env
));
1965 /* Start of the memoizers for non-R5RS builtin macros. */
1968 SCM_SYNTAX (s_atapply
, "@apply", scm_i_makbimacro
, scm_m_apply
);
1969 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1970 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1973 scm_m_apply (SCM expr
, SCM env SCM_UNUSED
)
1975 const SCM cdr_expr
= SCM_CDR (expr
);
1976 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1977 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_missing_expression
, expr
);
1979 SCM_SETCAR (expr
, SCM_IM_APPLY
);
1984 unmemoize_apply (const SCM expr
, const SCM env
)
1986 return scm_list_2 (scm_sym_atapply
, unmemoize_exprs (SCM_CDR (expr
), env
));
1990 SCM_SYNTAX (s_atbind
, "@bind", scm_i_makbimacro
, scm_m_atbind
);
1992 /* FIXME: The following explanation should go into the documentation: */
1993 /* (@bind ((var init) ...) body ...) will assign the values of the `init's to
1994 * the global variables named by `var's (symbols, not evaluated), creating
1995 * them if they don't exist, executes body, and then restores the previous
1996 * values of the `var's. Additionally, whenever control leaves body, the
1997 * values of the `var's are saved and restored when control returns. It is an
1998 * error when a symbol appears more than once among the `var's. All `init's
1999 * are evaluated before any `var' is set.
2001 * Think of this as `let' for dynamic scope.
2004 /* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into
2005 * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...).
2007 * FIXME - also implement `@bind*'.
2010 scm_m_atbind (SCM expr
, SCM env
)
2017 const SCM top_level
= scm_env_top_level (env
);
2019 const SCM cdr_expr
= SCM_CDR (expr
);
2020 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2021 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
2022 bindings
= SCM_CAR (cdr_expr
);
2023 check_bindings (bindings
, expr
);
2024 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
2026 for (variable_idx
= rvariables
;
2027 !SCM_NULLP (variable_idx
);
2028 variable_idx
= SCM_CDR (variable_idx
))
2030 /* The first call to scm_sym2var will look beyond the current module,
2031 * while the second call wont. */
2032 const SCM variable
= SCM_CAR (variable_idx
);
2033 SCM new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_F
);
2034 if (scm_is_false (new_variable
))
2035 new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_T
);
2036 SCM_SETCAR (variable_idx
, new_variable
);
2039 SCM_SETCAR (expr
, SCM_IM_BIND
);
2040 SCM_SETCAR (cdr_expr
, scm_cons (rvariables
, inits
));
2045 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_i_makbimacro
, scm_m_cont
);
2046 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, s_atcall_cc
);
2049 scm_m_cont (SCM expr
, SCM env SCM_UNUSED
)
2051 const SCM cdr_expr
= SCM_CDR (expr
);
2052 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2053 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2055 SCM_SETCAR (expr
, SCM_IM_CONT
);
2060 unmemoize_atcall_cc (const SCM expr
, const SCM env
)
2062 return scm_list_2 (scm_sym_atcall_cc
, unmemoize_exprs (SCM_CDR (expr
), env
));
2066 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_i_makbimacro
, scm_m_at_call_with_values
);
2067 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
2070 scm_m_at_call_with_values (SCM expr
, SCM env SCM_UNUSED
)
2072 const SCM cdr_expr
= SCM_CDR (expr
);
2073 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2074 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2076 SCM_SETCAR (expr
, SCM_IM_CALL_WITH_VALUES
);
2081 unmemoize_at_call_with_values (const SCM expr
, const SCM env
)
2083 return scm_list_2 (scm_sym_at_call_with_values
,
2084 unmemoize_exprs (SCM_CDR (expr
), env
));
2088 SCM_SYNTAX (s_future
, "future", scm_i_makbimacro
, scm_m_future
);
2089 SCM_GLOBAL_SYMBOL (scm_sym_future
, s_future
);
2091 /* Like promises, futures are implemented as closures with an empty
2092 * parameter list. Thus, (future <expression>) is transformed into
2093 * (#@future '() <expression>), where the empty list represents the
2094 * empty parameter list. This representation allows for easy creation
2095 * of the closure during evaluation. */
2097 scm_m_future (SCM expr
, SCM env
)
2099 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
2100 SCM_SETCAR (new_expr
, SCM_IM_FUTURE
);
2105 unmemoize_future (const SCM expr
, const SCM env
)
2107 const SCM thunk_expr
= SCM_CADDR (expr
);
2108 return scm_list_2 (scm_sym_future
, unmemoize_expression (thunk_expr
, env
));
2112 SCM_SYNTAX (s_gset_x
, "set!", scm_i_makbimacro
, scm_m_generalized_set_x
);
2113 SCM_SYMBOL (scm_sym_setter
, "setter");
2116 scm_m_generalized_set_x (SCM expr
, SCM env
)
2118 SCM target
, exp_target
;
2120 const SCM cdr_expr
= SCM_CDR (expr
);
2121 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2122 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2124 target
= SCM_CAR (cdr_expr
);
2125 if (!SCM_CONSP (target
))
2128 return scm_m_set_x (expr
, env
);
2132 /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */
2133 /* Macroexpanding the target might return things of the form
2134 (begin <atom>). In that case, <atom> must be a symbol or a
2135 variable and we memoize to (set! <atom> ...).
2137 exp_target
= macroexp (target
, env
);
2138 if (scm_is_eq (SCM_CAR (exp_target
), SCM_IM_BEGIN
)
2139 && !SCM_NULLP (SCM_CDR (exp_target
))
2140 && SCM_NULLP (SCM_CDDR (exp_target
)))
2142 exp_target
= SCM_CADR (exp_target
);
2143 ASSERT_SYNTAX_2 (scm_is_symbol (exp_target
)
2144 || SCM_VARIABLEP (exp_target
),
2145 s_bad_variable
, exp_target
, expr
);
2146 return scm_cons (SCM_IM_SET_X
, scm_cons (exp_target
,
2147 SCM_CDR (cdr_expr
)));
2151 const SCM setter_proc_tail
= scm_list_1 (SCM_CAR (target
));
2152 const SCM setter_proc
= scm_cons_source (expr
, scm_sym_setter
,
2155 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
2156 const SCM setter_args
= scm_append_x (scm_list_2 (SCM_CDR (target
),
2159 SCM_SETCAR (expr
, setter_proc
);
2160 SCM_SETCDR (expr
, setter_args
);
2167 /* @slot-ref is bound privately in the (oop goops) module from goops.c. As
2168 * soon as the module system allows us to more freely create bindings in
2169 * arbitrary modules during the startup phase, the code from goops.c should be
2172 SCM_SYMBOL (sym_atslot_ref
, "@slot-ref");
2175 scm_m_atslot_ref (SCM expr
, SCM env SCM_UNUSED
)
2179 const SCM cdr_expr
= SCM_CDR (expr
);
2180 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2181 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2182 slot_nr
= SCM_CADR (cdr_expr
);
2183 ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2185 SCM_SETCAR (expr
, SCM_IM_SLOT_REF
);
2186 SCM_SETCDR (cdr_expr
, slot_nr
);
2191 unmemoize_atslot_ref (const SCM expr
, const SCM env
)
2193 const SCM instance
= SCM_CADR (expr
);
2194 const SCM um_instance
= unmemoize_expression (instance
, env
);
2195 const SCM slot_nr
= SCM_CDDR (expr
);
2196 return scm_list_3 (sym_atslot_ref
, um_instance
, slot_nr
);
2200 /* @slot-set! is bound privately in the (oop goops) module from goops.c. As
2201 * soon as the module system allows us to more freely create bindings in
2202 * arbitrary modules during the startup phase, the code from goops.c should be
2205 SCM_SYMBOL (sym_atslot_set_x
, "@slot-set!");
2208 scm_m_atslot_set_x (SCM expr
, SCM env SCM_UNUSED
)
2212 const SCM cdr_expr
= SCM_CDR (expr
);
2213 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2214 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 3, s_expression
, expr
);
2215 slot_nr
= SCM_CADR (cdr_expr
);
2216 ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2218 SCM_SETCAR (expr
, SCM_IM_SLOT_SET_X
);
2223 unmemoize_atslot_set_x (const SCM expr
, const SCM env
)
2225 const SCM cdr_expr
= SCM_CDR (expr
);
2226 const SCM instance
= SCM_CAR (cdr_expr
);
2227 const SCM um_instance
= unmemoize_expression (instance
, env
);
2228 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
2229 const SCM slot_nr
= SCM_CAR (cddr_expr
);
2230 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
2231 const SCM value
= SCM_CAR (cdddr_expr
);
2232 const SCM um_value
= unmemoize_expression (value
, env
);
2233 return scm_list_4 (sym_atslot_set_x
, um_instance
, slot_nr
, um_value
);
2237 #if SCM_ENABLE_ELISP
2239 static const char s_defun
[] = "Symbol's function definition is void";
2241 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_i_makbimacro
, scm_m_nil_cond
);
2243 /* nil-cond expressions have the form
2244 * (nil-cond COND VAL COND VAL ... ELSEVAL) */
2246 scm_m_nil_cond (SCM expr
, SCM env SCM_UNUSED
)
2248 const long length
= scm_ilength (SCM_CDR (expr
));
2249 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
2250 ASSERT_SYNTAX (length
>= 1 && (length
% 2) == 1, s_expression
, expr
);
2252 SCM_SETCAR (expr
, SCM_IM_NIL_COND
);
2257 SCM_SYNTAX (s_atfop
, "@fop", scm_i_makbimacro
, scm_m_atfop
);
2259 /* The @fop-macro handles procedure and macro applications for elisp. The
2260 * input expression must have the form
2261 * (@fop <var> (transformer-macro <expr> ...))
2262 * where <var> must be a symbol. The expression is transformed into the
2263 * memoized form of either
2264 * (apply <un-aliased var> (transformer-macro <expr> ...))
2265 * if the value of var (across all aliasing) is not a macro, or
2266 * (<un-aliased var> <expr> ...)
2267 * if var is a macro. */
2269 scm_m_atfop (SCM expr
, SCM env SCM_UNUSED
)
2274 const SCM cdr_expr
= SCM_CDR (expr
);
2275 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2276 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 1, s_missing_expression
, expr
);
2278 symbol
= SCM_CAR (cdr_expr
);
2279 ASSERT_SYNTAX_2 (scm_is_symbol (symbol
), s_bad_variable
, symbol
, expr
);
2281 location
= scm_symbol_fref (symbol
);
2282 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2284 /* The elisp function `defalias' allows to define aliases for symbols. To
2285 * look up such definitions, the chain of symbol definitions has to be
2286 * followed up to the terminal symbol. */
2287 while (scm_is_symbol (SCM_VARIABLE_REF (location
)))
2289 const SCM alias
= SCM_VARIABLE_REF (location
);
2290 location
= scm_symbol_fref (alias
);
2291 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2294 /* Memoize the value location belonging to the terminal symbol. */
2295 SCM_SETCAR (cdr_expr
, location
);
2297 if (!SCM_MACROP (SCM_VARIABLE_REF (location
)))
2299 /* Since the location does not contain a macro, the form is a procedure
2300 * application. Replace `@fop' by `@apply' and transform the expression
2301 * including the `transformer-macro'. */
2302 SCM_SETCAR (expr
, SCM_IM_APPLY
);
2307 /* Since the location contains a macro, the arguments should not be
2308 * transformed, so the `transformer-macro' is cut out. The resulting
2309 * expression starts with the memoized variable, that is at the cdr of
2310 * the input expression. */
2311 SCM_SETCDR (cdr_expr
, SCM_CDADR (cdr_expr
));
2316 #endif /* SCM_ENABLE_ELISP */
2320 unmemoize_builtin_macro (const SCM expr
, const SCM env
)
2322 switch (ISYMNUM (SCM_CAR (expr
)))
2324 case (ISYMNUM (SCM_IM_AND
)):
2325 return unmemoize_and (expr
, env
);
2327 case (ISYMNUM (SCM_IM_BEGIN
)):
2328 return unmemoize_begin (expr
, env
);
2330 case (ISYMNUM (SCM_IM_CASE
)):
2331 return unmemoize_case (expr
, env
);
2333 case (ISYMNUM (SCM_IM_COND
)):
2334 return unmemoize_cond (expr
, env
);
2336 case (ISYMNUM (SCM_IM_DELAY
)):
2337 return unmemoize_delay (expr
, env
);
2339 case (ISYMNUM (SCM_IM_DO
)):
2340 return unmemoize_do (expr
, env
);
2342 case (ISYMNUM (SCM_IM_IF
)):
2343 return unmemoize_if (expr
, env
);
2345 case (ISYMNUM (SCM_IM_LAMBDA
)):
2346 return unmemoize_lambda (expr
, env
);
2348 case (ISYMNUM (SCM_IM_LET
)):
2349 return unmemoize_let (expr
, env
);
2351 case (ISYMNUM (SCM_IM_LETREC
)):
2352 return unmemoize_letrec (expr
, env
);
2354 case (ISYMNUM (SCM_IM_LETSTAR
)):
2355 return unmemoize_letstar (expr
, env
);
2357 case (ISYMNUM (SCM_IM_OR
)):
2358 return unmemoize_or (expr
, env
);
2360 case (ISYMNUM (SCM_IM_QUOTE
)):
2361 return unmemoize_quote (expr
, env
);
2363 case (ISYMNUM (SCM_IM_SET_X
)):
2364 return unmemoize_set_x (expr
, env
);
2366 case (ISYMNUM (SCM_IM_APPLY
)):
2367 return unmemoize_apply (expr
, env
);
2369 case (ISYMNUM (SCM_IM_BIND
)):
2370 return unmemoize_exprs (expr
, env
); /* FIXME */
2372 case (ISYMNUM (SCM_IM_CONT
)):
2373 return unmemoize_atcall_cc (expr
, env
);
2375 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2376 return unmemoize_at_call_with_values (expr
, env
);
2378 case (ISYMNUM (SCM_IM_FUTURE
)):
2379 return unmemoize_future (expr
, env
);
2381 case (ISYMNUM (SCM_IM_SLOT_REF
)):
2382 return unmemoize_atslot_ref (expr
, env
);
2384 case (ISYMNUM (SCM_IM_SLOT_SET_X
)):
2385 return unmemoize_atslot_set_x (expr
, env
);
2387 case (ISYMNUM (SCM_IM_NIL_COND
)):
2388 return unmemoize_exprs (expr
, env
); /* FIXME */
2391 return unmemoize_exprs (expr
, env
); /* FIXME */
2396 /* scm_i_unmemocopy_expr and scm_i_unmemocopy_body take a memoized expression
2397 * respectively a memoized body together with its environment and rewrite it
2398 * to its original form. Thus, these functions are the inversion of the
2399 * rewrite rules above. The procedure is not optimized for speed. It's used
2400 * in scm_i_unmemoize_expr, scm_procedure_source, macro_print and scm_iprin1.
2402 * Unmemoizing is not a reliable process. You cannot in general expect to get
2403 * the original source back.
2405 * However, GOOPS currently relies on this for method compilation. This ought
2409 scm_i_unmemocopy_expr (SCM expr
, SCM env
)
2411 const SCM source_properties
= scm_whash_lookup (scm_source_whash
, expr
);
2412 const SCM um_expr
= unmemoize_expression (expr
, env
);
2414 if (scm_is_true (source_properties
))
2415 scm_whash_insert (scm_source_whash
, um_expr
, source_properties
);
2421 scm_i_unmemocopy_body (SCM forms
, SCM env
)
2423 const SCM source_properties
= scm_whash_lookup (scm_source_whash
, forms
);
2424 const SCM um_forms
= unmemoize_exprs (forms
, env
);
2426 if (scm_is_true (source_properties
))
2427 scm_whash_insert (scm_source_whash
, um_forms
, source_properties
);
2433 #if (SCM_ENABLE_DEPRECATED == 1)
2435 /* Deprecated in guile 1.7.0 on 2003-11-09. */
2437 scm_m_expand_body (SCM exprs
, SCM env
)
2439 scm_c_issue_deprecation_warning
2440 ("`scm_m_expand_body' is deprecated.");
2441 m_expand_body (exprs
, env
);
2446 SCM_SYNTAX (s_undefine
, "undefine", scm_makacro
, scm_m_undefine
);
2449 scm_m_undefine (SCM expr
, SCM env
)
2454 const SCM cdr_expr
= SCM_CDR (expr
);
2455 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), "Bad undefine placement in", expr
);
2456 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2457 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2459 scm_c_issue_deprecation_warning
2460 ("`undefine' is deprecated.\n");
2462 variable
= SCM_CAR (cdr_expr
);
2463 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
2464 location
= scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_F
);
2465 ASSERT_SYNTAX_2 (scm_is_true (location
)
2466 && !SCM_UNBNDP (SCM_VARIABLE_REF (location
)),
2467 "variable already unbound ", variable
, expr
);
2468 SCM_VARIABLE_SET (location
, SCM_UNDEFINED
);
2469 return SCM_UNSPECIFIED
;
2473 scm_macroexp (SCM x
, SCM env
)
2475 scm_c_issue_deprecation_warning
2476 ("`scm_macroexp' is deprecated.");
2477 return macroexp (x
, env
);
2483 #if (SCM_ENABLE_DEPRECATED == 1)
2486 scm_unmemocar (SCM form
, SCM env
)
2488 scm_c_issue_deprecation_warning
2489 ("`scm_unmemocar' is deprecated.");
2491 if (!SCM_CONSP (form
))
2495 SCM c
= SCM_CAR (form
);
2496 if (SCM_VARIABLEP (c
))
2498 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
2499 if (scm_is_false (sym
))
2500 sym
= sym_three_question_marks
;
2501 SCM_SETCAR (form
, sym
);
2503 else if (SCM_ILOCP (c
))
2505 unsigned long int ir
;
2507 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
2508 env
= SCM_CDR (env
);
2509 env
= SCM_CAAR (env
);
2510 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
2511 env
= SCM_CDR (env
);
2513 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
2521 /*****************************************************************************/
2522 /*****************************************************************************/
2523 /* The definitions for execution start here. */
2524 /*****************************************************************************/
2525 /*****************************************************************************/
2527 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
2528 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
2529 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
2530 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
2532 /* A function object to implement "apply" for non-closure functions. */
2534 /* An endless list consisting of #<undefined> objects: */
2535 static SCM undefineds
;
2539 scm_badargsp (SCM formals
, SCM args
)
2541 while (!SCM_NULLP (formals
))
2543 if (!SCM_CONSP (formals
))
2545 if (SCM_NULLP (args
))
2547 formals
= SCM_CDR (formals
);
2548 args
= SCM_CDR (args
);
2550 return !SCM_NULLP (args
) ? 1 : 0;
2555 /* The evaluator contains a plethora of EVAL symbols. This is an attempt at
2558 * The following macros should be used in code which is read twice (where the
2559 * choice of evaluator is hard soldered):
2561 * CEVAL is the symbol used within one evaluator to call itself.
2562 * Originally, it is defined to ceval, but is redefined to deval during the
2565 * SCM_I_EVALIM is used when it is known that the expression is an
2566 * immediate. (This macro never calls an evaluator.)
2568 * EVAL evaluates an expression that is expected to have its symbols already
2569 * memoized. Expressions that are not of the form '(<form> <form> ...)' are
2570 * evaluated inline without calling an evaluator.
2572 * EVALCAR evaluates the car of an expression 'X:(Y:<form> <form> ...)',
2573 * potentially replacing a symbol at the position Y:<form> by its memoized
2574 * variable. If Y:<form> is not of the form '(<form> <form> ...)', the
2575 * evaluation is performed inline without calling an evaluator.
2577 * The following macros should be used in code which is read once
2578 * (where the choice of evaluator is dynamic):
2580 * SCM_I_XEVAL corresponds to EVAL, but uses ceval *or* deval depending on the
2583 * SCM_I_XEVALCAR corresponds to EVALCAR, but uses ceval *or* deval depending
2584 * on the debugging mode.
2586 * The main motivation for keeping this plethora is efficiency
2587 * together with maintainability (=> locality of code).
2590 static SCM
ceval (SCM x
, SCM env
);
2591 static SCM
deval (SCM x
, SCM env
);
2595 #define SCM_I_EVALIM2(x) \
2596 ((scm_is_eq ((x), SCM_EOL) \
2597 ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \
2601 #define SCM_I_EVALIM(x, env) (SCM_ILOCP (x) \
2602 ? *scm_ilookup ((x), (env)) \
2605 #define SCM_I_XEVAL(x, env) \
2607 ? SCM_I_EVALIM2 (x) \
2608 : (SCM_VARIABLEP (x) \
2609 ? SCM_VARIABLE_REF (x) \
2611 ? (scm_debug_mode_p \
2612 ? deval ((x), (env)) \
2613 : ceval ((x), (env))) \
2616 #define SCM_I_XEVALCAR(x, env) \
2617 (SCM_IMP (SCM_CAR (x)) \
2618 ? SCM_I_EVALIM (SCM_CAR (x), (env)) \
2619 : (SCM_VARIABLEP (SCM_CAR (x)) \
2620 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2621 : (SCM_CONSP (SCM_CAR (x)) \
2622 ? (scm_debug_mode_p \
2623 ? deval (SCM_CAR (x), (env)) \
2624 : ceval (SCM_CAR (x), (env))) \
2625 : (!scm_is_symbol (SCM_CAR (x)) \
2627 : *scm_lookupcar ((x), (env), 1)))))
2629 #define EVAL(x, env) \
2631 ? SCM_I_EVALIM ((x), (env)) \
2632 : (SCM_VARIABLEP (x) \
2633 ? SCM_VARIABLE_REF (x) \
2635 ? CEVAL ((x), (env)) \
2638 #define EVALCAR(x, env) \
2639 (SCM_IMP (SCM_CAR (x)) \
2640 ? SCM_I_EVALIM (SCM_CAR (x), (env)) \
2641 : (SCM_VARIABLEP (SCM_CAR (x)) \
2642 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2643 : (SCM_CONSP (SCM_CAR (x)) \
2644 ? CEVAL (SCM_CAR (x), (env)) \
2645 : (!scm_is_symbol (SCM_CAR (x)) \
2647 : *scm_lookupcar ((x), (env), 1)))))
2649 SCM_REC_MUTEX (source_mutex
);
2652 /* Lookup a given local variable in an environment. The local variable is
2653 * given as an iloc, that is a triple <frame, binding, last?>, where frame
2654 * indicates the relative number of the environment frame (counting upwards
2655 * from the innermost environment frame), binding indicates the number of the
2656 * binding within the frame, and last? (which is extracted from the iloc using
2657 * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
2658 * very end of the improper list of bindings. */
2660 scm_ilookup (SCM iloc
, SCM env
)
2662 unsigned int frame_nr
= SCM_IFRAME (iloc
);
2663 unsigned int binding_nr
= SCM_IDIST (iloc
);
2667 for (; 0 != frame_nr
; --frame_nr
)
2668 frames
= SCM_CDR (frames
);
2670 bindings
= SCM_CAR (frames
);
2671 for (; 0 != binding_nr
; --binding_nr
)
2672 bindings
= SCM_CDR (bindings
);
2674 if (SCM_ICDRP (iloc
))
2675 return SCM_CDRLOC (bindings
);
2676 return SCM_CARLOC (SCM_CDR (bindings
));
2680 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
2682 static void error_unbound_variable (SCM symbol
) SCM_NORETURN
;
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_is_symbol (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_is_symbol (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_is_symbol (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_from_double (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
))));
4150 else if (SCM_REALP (arg1
))
4152 RETURN (scm_from_double (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4154 else if (SCM_BIGP (arg1
))
4156 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4158 else if (SCM_FRACTIONP (arg1
))
4160 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4162 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4164 scm_i_symbol_chars (SCM_SNAME (proc
)));
4167 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
4170 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
4171 scm_i_symbol_chars (SCM_SNAME (proc
)));
4172 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
4177 case scm_tc7_rpsubr
:
4178 RETURN (SCM_BOOL_T
);
4180 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4183 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4185 RETURN (SCM_SUBRF (proc
) (scm_list_1 (arg1
)));
4188 if (!SCM_SMOB_APPLICABLE_P (proc
))
4190 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
4194 proc
= SCM_CCLO_SUBR (proc
);
4196 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
4197 debug
.info
->a
.proc
= proc
;
4201 proc
= SCM_PROCEDURE (proc
);
4203 debug
.info
->a
.proc
= proc
;
4205 if (!SCM_CLOSUREP (proc
))
4208 case scm_tcs_closures
:
4211 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4212 if (SCM_NULLP (formals
)
4213 || (SCM_CONSP (formals
) && SCM_CONSP (SCM_CDR (formals
))))
4215 x
= SCM_CLOSURE_BODY (proc
);
4217 env
= SCM_EXTEND_ENV (formals
,
4221 env
= SCM_EXTEND_ENV (formals
,
4225 goto nontoplevel_begin
;
4227 case scm_tcs_struct
:
4228 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4230 x
= SCM_ENTITY_PROCEDURE (proc
);
4232 arg1
= debug
.info
->a
.args
;
4234 arg1
= scm_list_1 (arg1
);
4238 else if (SCM_I_OPERATORP (proc
))
4242 proc
= (SCM_I_ENTITYP (proc
)
4243 ? SCM_ENTITY_PROCEDURE (proc
)
4244 : SCM_OPERATOR_PROCEDURE (proc
));
4246 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
4247 debug
.info
->a
.proc
= proc
;
4253 case scm_tc7_subr_2
:
4254 case scm_tc7_subr_0
:
4255 case scm_tc7_subr_3
:
4256 case scm_tc7_lsubr_2
:
4257 scm_wrong_num_args (proc
);
4263 arg2
= EVALCAR (x
, env
);
4265 scm_wrong_num_args (proc
);
4267 { /* have two or more arguments */
4269 debug
.info
->a
.args
= scm_list_2 (arg1
, arg2
);
4272 if (SCM_NULLP (x
)) {
4275 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4276 switch (SCM_TYP7 (proc
))
4277 { /* have two arguments */
4278 case scm_tc7_subr_2
:
4279 case scm_tc7_subr_2o
:
4280 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
4283 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4285 RETURN (SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
)));
4287 case scm_tc7_lsubr_2
:
4288 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
));
4289 case scm_tc7_rpsubr
:
4291 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
4293 if (!SCM_SMOB_APPLICABLE_P (proc
))
4295 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
));
4299 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
4300 scm_cons (proc
, debug
.info
->a
.args
),
4303 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
4304 scm_cons2 (proc
, arg1
,
4311 case scm_tcs_struct
:
4312 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4314 x
= SCM_ENTITY_PROCEDURE (proc
);
4316 arg1
= debug
.info
->a
.args
;
4318 arg1
= scm_list_2 (arg1
, arg2
);
4322 else if (SCM_I_OPERATORP (proc
))
4326 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
4327 ? SCM_ENTITY_PROCEDURE (proc
)
4328 : SCM_OPERATOR_PROCEDURE (proc
),
4329 scm_cons (proc
, debug
.info
->a
.args
),
4332 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
4333 ? SCM_ENTITY_PROCEDURE (proc
)
4334 : SCM_OPERATOR_PROCEDURE (proc
),
4335 scm_cons2 (proc
, arg1
,
4345 case scm_tc7_subr_0
:
4348 case scm_tc7_subr_1o
:
4349 case scm_tc7_subr_1
:
4350 case scm_tc7_subr_3
:
4351 scm_wrong_num_args (proc
);
4355 proc
= SCM_PROCEDURE (proc
);
4357 debug
.info
->a
.proc
= proc
;
4359 if (!SCM_CLOSUREP (proc
))
4362 case scm_tcs_closures
:
4365 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4366 if (SCM_NULLP (formals
)
4367 || (SCM_CONSP (formals
)
4368 && (SCM_NULLP (SCM_CDR (formals
))
4369 || (SCM_CONSP (SCM_CDR (formals
))
4370 && SCM_CONSP (SCM_CDDR (formals
))))))
4373 env
= SCM_EXTEND_ENV (formals
,
4377 env
= SCM_EXTEND_ENV (formals
,
4378 scm_list_2 (arg1
, arg2
),
4381 x
= SCM_CLOSURE_BODY (proc
);
4382 goto nontoplevel_begin
;
4387 scm_wrong_num_args (proc
);
4389 debug
.info
->a
.args
= scm_cons2 (arg1
, arg2
,
4390 deval_args (x
, env
, proc
,
4391 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
4395 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4396 switch (SCM_TYP7 (proc
))
4397 { /* have 3 or more arguments */
4399 case scm_tc7_subr_3
:
4400 if (!SCM_NULLP (SCM_CDR (x
)))
4401 scm_wrong_num_args (proc
);
4403 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4404 SCM_CADDR (debug
.info
->a
.args
)));
4406 arg1
= SCM_SUBRF(proc
)(arg1
, arg2
);
4407 arg2
= SCM_CDDR (debug
.info
->a
.args
);
4410 arg1
= SCM_SUBRF(proc
)(arg1
, SCM_CAR (arg2
));
4411 arg2
= SCM_CDR (arg2
);
4413 while (SCM_NIMP (arg2
));
4415 case scm_tc7_rpsubr
:
4416 if (scm_is_false (SCM_SUBRF (proc
) (arg1
, arg2
)))
4417 RETURN (SCM_BOOL_F
);
4418 arg1
= SCM_CDDR (debug
.info
->a
.args
);
4421 if (scm_is_false (SCM_SUBRF (proc
) (arg2
, SCM_CAR (arg1
))))
4422 RETURN (SCM_BOOL_F
);
4423 arg2
= SCM_CAR (arg1
);
4424 arg1
= SCM_CDR (arg1
);
4426 while (SCM_NIMP (arg1
));
4427 RETURN (SCM_BOOL_T
);
4428 case scm_tc7_lsubr_2
:
4429 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4430 SCM_CDDR (debug
.info
->a
.args
)));
4432 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4434 if (!SCM_SMOB_APPLICABLE_P (proc
))
4436 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4437 SCM_CDDR (debug
.info
->a
.args
)));
4441 proc
= SCM_PROCEDURE (proc
);
4442 debug
.info
->a
.proc
= proc
;
4443 if (!SCM_CLOSUREP (proc
))
4446 case scm_tcs_closures
:
4448 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4449 if (SCM_NULLP (formals
)
4450 || (SCM_CONSP (formals
)
4451 && (SCM_NULLP (SCM_CDR (formals
))
4452 || (SCM_CONSP (SCM_CDR (formals
))
4453 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4455 SCM_SET_ARGSREADY (debug
);
4456 env
= SCM_EXTEND_ENV (formals
,
4459 x
= SCM_CLOSURE_BODY (proc
);
4460 goto nontoplevel_begin
;
4463 case scm_tc7_subr_3
:
4464 if (!SCM_NULLP (SCM_CDR (x
)))
4465 scm_wrong_num_args (proc
);
4467 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, EVALCAR (x
, env
)));
4469 arg1
= SCM_SUBRF (proc
) (arg1
, arg2
);
4472 arg1
= SCM_SUBRF(proc
)(arg1
, EVALCAR(x
, env
));
4475 while (!SCM_NULLP (x
));
4477 case scm_tc7_rpsubr
:
4478 if (scm_is_false (SCM_SUBRF (proc
) (arg1
, arg2
)))
4479 RETURN (SCM_BOOL_F
);
4482 arg1
= EVALCAR (x
, env
);
4483 if (scm_is_false (SCM_SUBRF (proc
) (arg2
, arg1
)))
4484 RETURN (SCM_BOOL_F
);
4488 while (!SCM_NULLP (x
));
4489 RETURN (SCM_BOOL_T
);
4490 case scm_tc7_lsubr_2
:
4491 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
4493 RETURN (SCM_SUBRF (proc
) (scm_cons2 (arg1
,
4495 scm_eval_args (x
, env
, proc
))));
4497 if (!SCM_SMOB_APPLICABLE_P (proc
))
4499 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4500 scm_eval_args (x
, env
, proc
)));
4504 proc
= SCM_PROCEDURE (proc
);
4505 if (!SCM_CLOSUREP (proc
))
4508 case scm_tcs_closures
:
4510 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4511 if (SCM_NULLP (formals
)
4512 || (SCM_CONSP (formals
)
4513 && (SCM_NULLP (SCM_CDR (formals
))
4514 || (SCM_CONSP (SCM_CDR (formals
))
4515 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4517 env
= SCM_EXTEND_ENV (formals
,
4520 scm_eval_args (x
, env
, proc
)),
4522 x
= SCM_CLOSURE_BODY (proc
);
4523 goto nontoplevel_begin
;
4526 case scm_tcs_struct
:
4527 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4530 arg1
= debug
.info
->a
.args
;
4532 arg1
= scm_cons2 (arg1
, arg2
, scm_eval_args (x
, env
, proc
));
4534 x
= SCM_ENTITY_PROCEDURE (proc
);
4537 else if (SCM_I_OPERATORP (proc
))
4541 case scm_tc7_subr_2
:
4542 case scm_tc7_subr_1o
:
4543 case scm_tc7_subr_2o
:
4544 case scm_tc7_subr_0
:
4547 case scm_tc7_subr_1
:
4548 scm_wrong_num_args (proc
);
4556 if (scm_check_exit_p
&& SCM_TRAPS_P
)
4557 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
4559 SCM_CLEAR_TRACED_FRAME (debug
);
4560 if (SCM_CHEAPTRAPS_P
)
4561 arg1
= scm_make_debugobj (&debug
);
4565 SCM val
= scm_make_continuation (&first
);
4576 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
4580 scm_last_debug_frame
= debug
.prev
;
4586 /* SECTION: This code is compiled once.
4593 /* Simple procedure calls
4597 scm_call_0 (SCM proc
)
4599 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
4603 scm_call_1 (SCM proc
, SCM arg1
)
4605 return scm_apply (proc
, arg1
, scm_listofnull
);
4609 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
4611 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
4615 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
4617 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
4621 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
4623 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
4624 scm_cons (arg4
, scm_listofnull
)));
4627 /* Simple procedure applies
4631 scm_apply_0 (SCM proc
, SCM args
)
4633 return scm_apply (proc
, args
, SCM_EOL
);
4637 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
4639 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
4643 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
4645 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
4649 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
4651 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
4655 /* This code processes the arguments to apply:
4657 (apply PROC ARG1 ... ARGS)
4659 Given a list (ARG1 ... ARGS), this function conses the ARG1
4660 ... arguments onto the front of ARGS, and returns the resulting
4661 list. Note that ARGS is a list; thus, the argument to this
4662 function is a list whose last element is a list.
4664 Apply calls this function, and applies PROC to the elements of the
4665 result. apply:nconc2last takes care of building the list of
4666 arguments, given (ARG1 ... ARGS).
4668 Rather than do new consing, apply:nconc2last destroys its argument.
4669 On that topic, this code came into my care with the following
4670 beautifully cryptic comment on that topic: "This will only screw
4671 you if you do (scm_apply scm_apply '( ... ))" If you know what
4672 they're referring to, send me a patch to this comment. */
4674 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
4676 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
4677 "conses the @var{arg1} @dots{} arguments onto the front of\n"
4678 "@var{args}, and returns the resulting list. Note that\n"
4679 "@var{args} is a list; thus, the argument to this function is\n"
4680 "a list whose last element is a list.\n"
4681 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
4682 "destroys its argument, so use with care.")
4683 #define FUNC_NAME s_scm_nconc2last
4686 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
4688 while (!SCM_NULLP (SCM_CDR (*lloc
))) /* Perhaps should be
4689 SCM_NULL_OR_NIL_P, but not
4690 needed in 99.99% of cases,
4691 and it could seriously hurt
4692 performance. - Neil */
4693 lloc
= SCM_CDRLOC (*lloc
);
4694 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
4695 *lloc
= SCM_CAR (*lloc
);
4703 /* SECTION: When DEVAL is defined this code yields scm_dapply.
4704 * It is compiled twice.
4709 scm_apply (SCM proc
, SCM arg1
, SCM args
)
4715 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
4720 /* Apply a function to a list of arguments.
4722 This function is exported to the Scheme level as taking two
4723 required arguments and a tail argument, as if it were:
4724 (lambda (proc arg1 . args) ...)
4725 Thus, if you just have a list of arguments to pass to a procedure,
4726 pass the list as ARG1, and '() for ARGS. If you have some fixed
4727 args, pass the first as ARG1, then cons any remaining fixed args
4728 onto the front of your argument list, and pass that as ARGS. */
4731 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
4734 scm_t_debug_frame debug
;
4735 scm_t_debug_info debug_vect_body
;
4736 debug
.prev
= scm_last_debug_frame
;
4737 debug
.status
= SCM_APPLYFRAME
;
4738 debug
.vect
= &debug_vect_body
;
4739 debug
.vect
[0].a
.proc
= proc
;
4740 debug
.vect
[0].a
.args
= SCM_EOL
;
4741 scm_last_debug_frame
= &debug
;
4743 if (scm_debug_mode_p
)
4744 return scm_dapply (proc
, arg1
, args
);
4747 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
4749 /* If ARGS is the empty list, then we're calling apply with only two
4750 arguments --- ARG1 is the list of arguments for PROC. Whatever
4751 the case, futz with things so that ARG1 is the first argument to
4752 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
4755 Setting the debug apply frame args this way is pretty messy.
4756 Perhaps we should store arg1 and args directly in the frame as
4757 received, and let scm_frame_arguments unpack them, because that's
4758 a relatively rare operation. This works for now; if the Guile
4759 developer archives are still around, see Mikael's post of
4761 if (SCM_NULLP (args
))
4763 if (SCM_NULLP (arg1
))
4765 arg1
= SCM_UNDEFINED
;
4767 debug
.vect
[0].a
.args
= SCM_EOL
;
4773 debug
.vect
[0].a
.args
= arg1
;
4775 args
= SCM_CDR (arg1
);
4776 arg1
= SCM_CAR (arg1
);
4781 args
= scm_nconc2last (args
);
4783 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4787 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
4790 if (SCM_CHEAPTRAPS_P
)
4791 tmp
= scm_make_debugobj (&debug
);
4796 tmp
= scm_make_continuation (&first
);
4801 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
4808 switch (SCM_TYP7 (proc
))
4810 case scm_tc7_subr_2o
:
4811 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
4812 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4813 case scm_tc7_subr_2
:
4814 if (SCM_NULLP (args
) || !SCM_NULLP (SCM_CDR (args
)))
4815 scm_wrong_num_args (proc
);
4816 args
= SCM_CAR (args
);
4817 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4818 case scm_tc7_subr_0
:
4819 if (!SCM_UNBNDP (arg1
))
4820 scm_wrong_num_args (proc
);
4822 RETURN (SCM_SUBRF (proc
) ());
4823 case scm_tc7_subr_1
:
4824 if (SCM_UNBNDP (arg1
))
4825 scm_wrong_num_args (proc
);
4826 case scm_tc7_subr_1o
:
4827 if (!SCM_NULLP (args
))
4828 scm_wrong_num_args (proc
);
4830 RETURN (SCM_SUBRF (proc
) (arg1
));
4832 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
4833 scm_wrong_num_args (proc
);
4834 if (SCM_I_INUMP (arg1
))
4836 RETURN (scm_from_double (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
))));
4838 else if (SCM_REALP (arg1
))
4840 RETURN (scm_from_double (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4842 else if (SCM_BIGP (arg1
))
4844 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4846 else if (SCM_FRACTIONP (arg1
))
4848 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4850 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4851 SCM_ARG1
, scm_i_symbol_chars (SCM_SNAME (proc
)));
4853 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
4854 scm_wrong_num_args (proc
);
4856 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
4859 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
4860 scm_i_symbol_chars (SCM_SNAME (proc
)));
4861 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
4866 case scm_tc7_subr_3
:
4867 if (SCM_NULLP (args
)
4868 || SCM_NULLP (SCM_CDR (args
))
4869 || !SCM_NULLP (SCM_CDDR (args
)))
4870 scm_wrong_num_args (proc
);
4872 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
4875 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
4877 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
4879 case scm_tc7_lsubr_2
:
4880 if (!SCM_CONSP (args
))
4881 scm_wrong_num_args (proc
);
4883 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4885 if (SCM_NULLP (args
))
4886 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4887 while (SCM_NIMP (args
))
4889 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
4890 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
4891 args
= SCM_CDR (args
);
4894 case scm_tc7_rpsubr
:
4895 if (SCM_NULLP (args
))
4896 RETURN (SCM_BOOL_T
);
4897 while (SCM_NIMP (args
))
4899 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
4900 if (scm_is_false (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
4901 RETURN (SCM_BOOL_F
);
4902 arg1
= SCM_CAR (args
);
4903 args
= SCM_CDR (args
);
4905 RETURN (SCM_BOOL_T
);
4906 case scm_tcs_closures
:
4908 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4910 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4912 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
4913 scm_wrong_num_args (proc
);
4915 /* Copy argument list */
4920 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
4921 for (arg1
= SCM_CDR (arg1
); SCM_CONSP (arg1
); arg1
= SCM_CDR (arg1
))
4923 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
));
4926 SCM_SETCDR (tl
, arg1
);
4929 args
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4932 proc
= SCM_CLOSURE_BODY (proc
);
4934 arg1
= SCM_CDR (proc
);
4935 while (!SCM_NULLP (arg1
))
4937 if (SCM_IMP (SCM_CAR (proc
)))
4939 if (SCM_ISYMP (SCM_CAR (proc
)))
4941 scm_rec_mutex_lock (&source_mutex
);
4942 /* check for race condition */
4943 if (SCM_ISYMP (SCM_CAR (proc
)))
4944 m_expand_body (proc
, args
);
4945 scm_rec_mutex_unlock (&source_mutex
);
4949 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
4952 (void) EVAL (SCM_CAR (proc
), args
);
4954 arg1
= SCM_CDR (proc
);
4956 RETURN (EVALCAR (proc
, args
));
4958 if (!SCM_SMOB_APPLICABLE_P (proc
))
4960 if (SCM_UNBNDP (arg1
))
4961 RETURN (SCM_SMOB_APPLY_0 (proc
));
4962 else if (SCM_NULLP (args
))
4963 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
4964 else if (SCM_NULLP (SCM_CDR (args
)))
4965 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
4967 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4970 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4972 proc
= SCM_CCLO_SUBR (proc
);
4973 debug
.vect
[0].a
.proc
= proc
;
4974 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4976 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4978 proc
= SCM_CCLO_SUBR (proc
);
4982 proc
= SCM_PROCEDURE (proc
);
4984 debug
.vect
[0].a
.proc
= proc
;
4987 case scm_tcs_struct
:
4988 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4991 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4993 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4995 RETURN (scm_apply_generic (proc
, args
));
4997 else if (SCM_I_OPERATORP (proc
))
5001 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
5003 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
5006 proc
= (SCM_I_ENTITYP (proc
)
5007 ? SCM_ENTITY_PROCEDURE (proc
)
5008 : SCM_OPERATOR_PROCEDURE (proc
));
5010 debug
.vect
[0].a
.proc
= proc
;
5011 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
5013 if (SCM_NIMP (proc
))
5022 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
5026 if (scm_check_exit_p
&& SCM_TRAPS_P
)
5027 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
5029 SCM_CLEAR_TRACED_FRAME (debug
);
5030 if (SCM_CHEAPTRAPS_P
)
5031 arg1
= scm_make_debugobj (&debug
);
5035 SCM val
= scm_make_continuation (&first
);
5046 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
5050 scm_last_debug_frame
= debug
.prev
;
5056 /* SECTION: The rest of this file is only read once.
5063 * Trampolines make it possible to move procedure application dispatch
5064 * outside inner loops. The motivation was clean implementation of
5065 * efficient replacements of R5RS primitives in SRFI-1.
5067 * The semantics is clear: scm_trampoline_N returns an optimized
5068 * version of scm_call_N (or NULL if the procedure isn't applicable
5071 * Applying the optimization to map and for-each increased efficiency
5072 * noticeably. For example, (map abs ls) is now 8 times faster than
5077 call_subr0_0 (SCM proc
)
5079 return SCM_SUBRF (proc
) ();
5083 call_subr1o_0 (SCM proc
)
5085 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
5089 call_lsubr_0 (SCM proc
)
5091 return SCM_SUBRF (proc
) (SCM_EOL
);
5095 scm_i_call_closure_0 (SCM proc
)
5097 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
5100 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
5105 scm_trampoline_0 (SCM proc
)
5107 scm_t_trampoline_0 trampoline
;
5112 switch (SCM_TYP7 (proc
))
5114 case scm_tc7_subr_0
:
5115 trampoline
= call_subr0_0
;
5117 case scm_tc7_subr_1o
:
5118 trampoline
= call_subr1o_0
;
5121 trampoline
= call_lsubr_0
;
5123 case scm_tcs_closures
:
5125 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5126 if (SCM_NULLP (formals
) || !SCM_CONSP (formals
))
5127 trampoline
= scm_i_call_closure_0
;
5132 case scm_tcs_struct
:
5133 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5134 trampoline
= scm_call_generic_0
;
5135 else if (SCM_I_OPERATORP (proc
))
5136 trampoline
= scm_call_0
;
5141 if (SCM_SMOB_APPLICABLE_P (proc
))
5142 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
5147 case scm_tc7_rpsubr
:
5150 trampoline
= scm_call_0
;
5153 return NULL
; /* not applicable on zero arguments */
5155 /* We only reach this point if a valid trampoline was determined. */
5157 /* If debugging is enabled, we want to see all calls to proc on the stack.
5158 * Thus, we replace the trampoline shortcut with scm_call_0. */
5159 if (scm_debug_mode_p
)
5166 call_subr1_1 (SCM proc
, SCM arg1
)
5168 return SCM_SUBRF (proc
) (arg1
);
5172 call_subr2o_1 (SCM proc
, SCM arg1
)
5174 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
5178 call_lsubr_1 (SCM proc
, SCM arg1
)
5180 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
5184 call_dsubr_1 (SCM proc
, SCM arg1
)
5186 if (SCM_I_INUMP (arg1
))
5188 RETURN (scm_from_double (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
))));
5190 else if (SCM_REALP (arg1
))
5192 RETURN (scm_from_double (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
5194 else if (SCM_BIGP (arg1
))
5196 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
5198 else if (SCM_FRACTIONP (arg1
))
5200 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
5202 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
5203 SCM_ARG1
, scm_i_symbol_chars (SCM_SNAME (proc
)));
5207 call_cxr_1 (SCM proc
, SCM arg1
)
5209 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
5212 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
5213 scm_i_symbol_chars (SCM_SNAME (proc
)));
5214 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
5221 call_closure_1 (SCM proc
, SCM arg1
)
5223 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
5226 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
5231 scm_trampoline_1 (SCM proc
)
5233 scm_t_trampoline_1 trampoline
;
5238 switch (SCM_TYP7 (proc
))
5240 case scm_tc7_subr_1
:
5241 case scm_tc7_subr_1o
:
5242 trampoline
= call_subr1_1
;
5244 case scm_tc7_subr_2o
:
5245 trampoline
= call_subr2o_1
;
5248 trampoline
= call_lsubr_1
;
5251 trampoline
= call_dsubr_1
;
5254 trampoline
= call_cxr_1
;
5256 case scm_tcs_closures
:
5258 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5259 if (!SCM_NULLP (formals
)
5260 && (!SCM_CONSP (formals
) || !SCM_CONSP (SCM_CDR (formals
))))
5261 trampoline
= call_closure_1
;
5266 case scm_tcs_struct
:
5267 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5268 trampoline
= scm_call_generic_1
;
5269 else if (SCM_I_OPERATORP (proc
))
5270 trampoline
= scm_call_1
;
5275 if (SCM_SMOB_APPLICABLE_P (proc
))
5276 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
5281 case scm_tc7_rpsubr
:
5284 trampoline
= scm_call_1
;
5287 return NULL
; /* not applicable on one arg */
5289 /* We only reach this point if a valid trampoline was determined. */
5291 /* If debugging is enabled, we want to see all calls to proc on the stack.
5292 * Thus, we replace the trampoline shortcut with scm_call_1. */
5293 if (scm_debug_mode_p
)
5300 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
5302 return SCM_SUBRF (proc
) (arg1
, arg2
);
5306 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
5308 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
5312 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
5314 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
5318 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
5320 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
5321 scm_list_2 (arg1
, arg2
),
5323 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
5328 scm_trampoline_2 (SCM proc
)
5330 scm_t_trampoline_2 trampoline
;
5335 switch (SCM_TYP7 (proc
))
5337 case scm_tc7_subr_2
:
5338 case scm_tc7_subr_2o
:
5339 case scm_tc7_rpsubr
:
5341 trampoline
= call_subr2_2
;
5343 case scm_tc7_lsubr_2
:
5344 trampoline
= call_lsubr2_2
;
5347 trampoline
= call_lsubr_2
;
5349 case scm_tcs_closures
:
5351 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5352 if (!SCM_NULLP (formals
)
5353 && (!SCM_CONSP (formals
)
5354 || (!SCM_NULLP (SCM_CDR (formals
))
5355 && (!SCM_CONSP (SCM_CDR (formals
))
5356 || !SCM_CONSP (SCM_CDDR (formals
))))))
5357 trampoline
= call_closure_2
;
5362 case scm_tcs_struct
:
5363 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5364 trampoline
= scm_call_generic_2
;
5365 else if (SCM_I_OPERATORP (proc
))
5366 trampoline
= scm_call_2
;
5371 if (SCM_SMOB_APPLICABLE_P (proc
))
5372 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
5378 trampoline
= scm_call_2
;
5381 return NULL
; /* not applicable on two args */
5383 /* We only reach this point if a valid trampoline was determined. */
5385 /* If debugging is enabled, we want to see all calls to proc on the stack.
5386 * Thus, we replace the trampoline shortcut with scm_call_2. */
5387 if (scm_debug_mode_p
)
5393 /* Typechecking for multi-argument MAP and FOR-EACH.
5395 Verify that each element of the vector ARGV, except for the first,
5396 is a proper list whose length is LEN. Attribute errors to WHO,
5397 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
5399 check_map_args (SCM argv
,
5406 SCM
const *ve
= SCM_VELTS (argv
);
5409 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
5411 long elt_len
= scm_ilength (ve
[i
]);
5416 scm_apply_generic (gf
, scm_cons (proc
, args
));
5418 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
5422 scm_out_of_range_pos (who
, ve
[i
], scm_from_long (i
+ 2));
5425 scm_remember_upto_here_1 (argv
);
5429 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
5431 /* Note: Currently, scm_map applies PROC to the argument list(s)
5432 sequentially, starting with the first element(s). This is used in
5433 evalext.c where the Scheme procedure `map-in-order', which guarantees
5434 sequential behaviour, is implemented using scm_map. If the
5435 behaviour changes, we need to update `map-in-order'.
5439 scm_map (SCM proc
, SCM arg1
, SCM args
)
5440 #define FUNC_NAME s_map
5445 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
5447 len
= scm_ilength (arg1
);
5448 SCM_GASSERTn (len
>= 0,
5449 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
5450 SCM_VALIDATE_REST_ARGUMENT (args
);
5451 if (SCM_NULLP (args
))
5453 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5454 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
5455 while (SCM_NIMP (arg1
))
5457 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
5458 pres
= SCM_CDRLOC (*pres
);
5459 arg1
= SCM_CDR (arg1
);
5463 if (SCM_NULLP (SCM_CDR (args
)))
5465 SCM arg2
= SCM_CAR (args
);
5466 int len2
= scm_ilength (arg2
);
5467 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5469 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
5470 SCM_GASSERTn (len2
>= 0,
5471 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
5473 SCM_OUT_OF_RANGE (3, arg2
);
5474 while (SCM_NIMP (arg1
))
5476 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
5477 pres
= SCM_CDRLOC (*pres
);
5478 arg1
= SCM_CDR (arg1
);
5479 arg2
= SCM_CDR (arg2
);
5483 arg1
= scm_cons (arg1
, args
);
5484 args
= scm_vector (arg1
);
5485 ve
= SCM_VELTS (args
);
5486 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
5490 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5492 if (SCM_IMP (ve
[i
]))
5494 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
5495 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
5497 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
5498 pres
= SCM_CDRLOC (*pres
);
5504 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
5507 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
5508 #define FUNC_NAME s_for_each
5510 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
5512 len
= scm_ilength (arg1
);
5513 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
5514 SCM_ARG2
, s_for_each
);
5515 SCM_VALIDATE_REST_ARGUMENT (args
);
5516 if (SCM_NULLP (args
))
5518 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5519 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
5520 while (SCM_NIMP (arg1
))
5522 call (proc
, SCM_CAR (arg1
));
5523 arg1
= SCM_CDR (arg1
);
5525 return SCM_UNSPECIFIED
;
5527 if (SCM_NULLP (SCM_CDR (args
)))
5529 SCM arg2
= SCM_CAR (args
);
5530 int len2
= scm_ilength (arg2
);
5531 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5532 SCM_GASSERTn (call
, g_for_each
,
5533 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
5534 SCM_GASSERTn (len2
>= 0, g_for_each
,
5535 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
5537 SCM_OUT_OF_RANGE (3, arg2
);
5538 while (SCM_NIMP (arg1
))
5540 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
5541 arg1
= SCM_CDR (arg1
);
5542 arg2
= SCM_CDR (arg2
);
5544 return SCM_UNSPECIFIED
;
5546 arg1
= scm_cons (arg1
, args
);
5547 args
= scm_vector (arg1
);
5548 ve
= SCM_VELTS (args
);
5549 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
5553 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5555 if (SCM_IMP (ve
[i
]))
5556 return SCM_UNSPECIFIED
;
5557 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
5558 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
5560 scm_apply (proc
, arg1
, SCM_EOL
);
5567 scm_closure (SCM code
, SCM env
)
5570 SCM closcar
= scm_cons (code
, SCM_EOL
);
5571 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
5572 scm_remember_upto_here (closcar
);
5577 scm_t_bits scm_tc16_promise
;
5580 scm_makprom (SCM code
)
5582 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
5584 scm_make_rec_mutex ());
5588 promise_free (SCM promise
)
5590 scm_rec_mutex_free (SCM_PROMISE_MUTEX (promise
));
5595 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
5597 int writingp
= SCM_WRITINGP (pstate
);
5598 scm_puts ("#<promise ", port
);
5599 SCM_SET_WRITINGP (pstate
, 1);
5600 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
5601 SCM_SET_WRITINGP (pstate
, writingp
);
5602 scm_putc ('>', port
);
5606 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
5608 "If the promise @var{x} has not been computed yet, compute and\n"
5609 "return @var{x}, otherwise just return the previously computed\n"
5611 #define FUNC_NAME s_scm_force
5613 SCM_VALIDATE_SMOB (1, promise
, promise
);
5614 scm_rec_mutex_lock (SCM_PROMISE_MUTEX (promise
));
5615 if (!SCM_PROMISE_COMPUTED_P (promise
))
5617 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
5618 if (!SCM_PROMISE_COMPUTED_P (promise
))
5620 SCM_SET_PROMISE_DATA (promise
, ans
);
5621 SCM_SET_PROMISE_COMPUTED (promise
);
5624 scm_rec_mutex_unlock (SCM_PROMISE_MUTEX (promise
));
5625 return SCM_PROMISE_DATA (promise
);
5630 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
5632 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
5633 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
5634 #define FUNC_NAME s_scm_promise_p
5636 return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
5641 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
5642 (SCM xorig
, SCM x
, SCM y
),
5643 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
5644 "Any source properties associated with @var{xorig} are also associated\n"
5645 "with the new pair.")
5646 #define FUNC_NAME s_scm_cons_source
5649 z
= scm_cons (x
, y
);
5650 /* Copy source properties possibly associated with xorig. */
5651 p
= scm_whash_lookup (scm_source_whash
, xorig
);
5652 if (scm_is_true (p
))
5653 scm_whash_insert (scm_source_whash
, z
, p
);
5659 /* The function scm_copy_tree is used to copy an expression tree to allow the
5660 * memoizer to modify the expression during memoization. scm_copy_tree
5661 * creates deep copies of pairs and vectors, but not of any other data types,
5662 * since only pairs and vectors will be parsed by the memoizer.
5664 * To avoid infinite recursion due to cyclic structures, the hare-and-tortoise
5665 * pattern is used to detect cycles. In fact, the pattern is used in two
5666 * dimensions, vertical (indicated in the code by the variable names 'hare'
5667 * and 'tortoise') and horizontal ('rabbit' and 'turtle'). In both
5668 * dimensions, the hare/rabbit will take two steps when the tortoise/turtle
5671 * The vertical dimension corresponds to recursive calls to function
5672 * copy_tree: This happens when descending into vector elements, into cars of
5673 * lists and into the cdr of an improper list. In this dimension, the
5674 * tortoise follows the hare by using the processor stack: Every stack frame
5675 * will hold an instance of struct t_trace. These instances are connected in
5676 * a way that represents the trace of the hare, which thus can be followed by
5677 * the tortoise. The tortoise will always point to struct t_trace instances
5678 * relating to SCM objects that have already been copied. Thus, a cycle is
5679 * detected if the tortoise and the hare point to the same object,
5681 * The horizontal dimension is within one execution of copy_tree, when the
5682 * function cdr's along the pairs of a list. This is the standard
5683 * hare-and-tortoise implementation, found several times in guile. */
5686 struct t_trace
*trace
; // These pointers form a trace along the stack.
5687 SCM obj
; // The object handled at the respective stack frame.
5692 struct t_trace
*const hare
,
5693 struct t_trace
*tortoise
,
5694 unsigned int tortoise_delay
)
5696 if (!SCM_CONSP (hare
->obj
) && !SCM_VECTORP (hare
->obj
))
5702 /* Prepare the trace along the stack. */
5703 struct t_trace new_hare
;
5704 hare
->trace
= &new_hare
;
5706 /* The tortoise will make its step after the delay has elapsed. Note
5707 * that in contrast to the typical hare-and-tortoise pattern, the step
5708 * of the tortoise happens before the hare takes its steps. This is, in
5709 * principle, no problem, except for the start of the algorithm: Then,
5710 * it has to be made sure that the hare actually gets its advantage of
5712 if (tortoise_delay
== 0)
5715 tortoise
= tortoise
->trace
;
5716 ASSERT_SYNTAX (!scm_is_eq (hare
->obj
, tortoise
->obj
),
5717 s_bad_expression
, hare
->obj
);
5724 if (SCM_VECTORP (hare
->obj
))
5726 const unsigned long int length
= SCM_VECTOR_LENGTH (hare
->obj
);
5727 const SCM new_vector
= scm_c_make_vector (length
, SCM_UNSPECIFIED
);
5729 /* Each vector element is copied by recursing into copy_tree, having
5730 * the tortoise follow the hare into the depths of the stack. */
5731 unsigned long int i
;
5732 for (i
= 0; i
< length
; ++i
)
5735 new_hare
.obj
= SCM_VECTOR_REF (hare
->obj
, i
);
5736 new_element
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5737 SCM_VECTOR_SET (new_vector
, i
, new_element
);
5742 else // SCM_CONSP (hare->obj)
5747 SCM rabbit
= hare
->obj
;
5748 SCM turtle
= hare
->obj
;
5752 /* The first pair of the list is treated specially, in order to
5753 * preserve a potential source code position. */
5754 result
= tail
= scm_cons_source (rabbit
, SCM_EOL
, SCM_EOL
);
5755 new_hare
.obj
= SCM_CAR (rabbit
);
5756 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5757 SCM_SETCAR (tail
, copy
);
5759 /* The remaining pairs of the list are copied by, horizontally,
5760 * having the turtle follow the rabbit, and, vertically, having the
5761 * tortoise follow the hare into the depths of the stack. */
5762 rabbit
= SCM_CDR (rabbit
);
5763 while (SCM_CONSP (rabbit
))
5765 new_hare
.obj
= SCM_CAR (rabbit
);
5766 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5767 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
5768 tail
= SCM_CDR (tail
);
5770 rabbit
= SCM_CDR (rabbit
);
5771 if (SCM_CONSP (rabbit
))
5773 new_hare
.obj
= SCM_CAR (rabbit
);
5774 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5775 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
5776 tail
= SCM_CDR (tail
);
5777 rabbit
= SCM_CDR (rabbit
);
5779 turtle
= SCM_CDR (turtle
);
5780 ASSERT_SYNTAX (!scm_is_eq (rabbit
, turtle
),
5781 s_bad_expression
, rabbit
);
5785 /* We have to recurse into copy_tree again for the last cdr, in
5786 * order to handle the situation that it holds a vector. */
5787 new_hare
.obj
= rabbit
;
5788 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5789 SCM_SETCDR (tail
, copy
);
5796 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
5798 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
5799 "the new data structure. @code{copy-tree} recurses down the\n"
5800 "contents of both pairs and vectors (since both cons cells and vector\n"
5801 "cells may point to arbitrary objects), and stops recursing when it hits\n"
5802 "any other object.")
5803 #define FUNC_NAME s_scm_copy_tree
5805 /* Prepare the trace along the stack. */
5806 struct t_trace trace
;
5809 /* In function copy_tree, if the tortoise makes its step, it will do this
5810 * before the hare has the chance to move. Thus, we have to make sure that
5811 * the very first step of the tortoise will not happen after the hare has
5812 * really made two steps. This is achieved by passing '2' as the initial
5813 * delay for the tortoise. NOTE: Since cycles are unlikely, giving the hare
5814 * a bigger advantage may improve performance slightly. */
5815 return copy_tree (&trace
, &trace
, 2);
5820 /* We have three levels of EVAL here:
5822 - scm_i_eval (exp, env)
5824 evaluates EXP in environment ENV. ENV is a lexical environment
5825 structure as used by the actual tree code evaluator. When ENV is
5826 a top-level environment, then changes to the current module are
5827 tracked by updating ENV so that it continues to be in sync with
5830 - scm_primitive_eval (exp)
5832 evaluates EXP in the top-level environment as determined by the
5833 current module. This is done by constructing a suitable
5834 environment and calling scm_i_eval. Thus, changes to the
5835 top-level module are tracked normally.
5837 - scm_eval (exp, mod)
5839 evaluates EXP while MOD is the current module. This is done by
5840 setting the current module to MOD, invoking scm_primitive_eval on
5841 EXP, and then restoring the current module to the value it had
5842 previously. That is, while EXP is evaluated, changes to the
5843 current module are tracked, but these changes do not persist when
5846 For each level of evals, there are two variants, distinguished by a
5847 _x suffix: the ordinary variant does not modify EXP while the _x
5848 variant can destructively modify EXP into something completely
5849 unintelligible. A Scheme data structure passed as EXP to one of the
5850 _x variants should not ever be used again for anything. So when in
5851 doubt, use the ordinary variant.
5856 scm_i_eval_x (SCM exp
, SCM env
)
5858 if (scm_is_symbol (exp
))
5859 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
5861 return SCM_I_XEVAL (exp
, env
);
5865 scm_i_eval (SCM exp
, SCM env
)
5867 exp
= scm_copy_tree (exp
);
5868 if (scm_is_symbol (exp
))
5869 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
5871 return SCM_I_XEVAL (exp
, env
);
5875 scm_primitive_eval_x (SCM exp
)
5878 SCM transformer
= scm_current_module_transformer ();
5879 if (SCM_NIMP (transformer
))
5880 exp
= scm_call_1 (transformer
, exp
);
5881 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5882 return scm_i_eval_x (exp
, env
);
5885 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
5887 "Evaluate @var{exp} in the top-level environment specified by\n"
5888 "the current module.")
5889 #define FUNC_NAME s_scm_primitive_eval
5892 SCM transformer
= scm_current_module_transformer ();
5893 if (scm_is_true (transformer
))
5894 exp
= scm_call_1 (transformer
, exp
);
5895 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5896 return scm_i_eval (exp
, env
);
5901 /* Eval does not take the second arg optionally. This is intentional
5902 * in order to be R5RS compatible, and to prepare for the new module
5903 * system, where we would like to make the choice of evaluation
5904 * environment explicit. */
5907 change_environment (void *data
)
5909 SCM pair
= SCM_PACK (data
);
5910 SCM new_module
= SCM_CAR (pair
);
5911 SCM old_module
= scm_current_module ();
5912 SCM_SETCDR (pair
, old_module
);
5913 scm_set_current_module (new_module
);
5917 restore_environment (void *data
)
5919 SCM pair
= SCM_PACK (data
);
5920 SCM old_module
= SCM_CDR (pair
);
5921 SCM new_module
= scm_current_module ();
5922 SCM_SETCAR (pair
, new_module
);
5923 scm_set_current_module (old_module
);
5927 inner_eval_x (void *data
)
5929 return scm_primitive_eval_x (SCM_PACK(data
));
5933 scm_eval_x (SCM exp
, SCM module
)
5934 #define FUNC_NAME "eval!"
5936 SCM_VALIDATE_MODULE (2, module
);
5938 return scm_internal_dynamic_wind
5939 (change_environment
, inner_eval_x
, restore_environment
,
5940 (void *) SCM_UNPACK (exp
),
5941 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
5946 inner_eval (void *data
)
5948 return scm_primitive_eval (SCM_PACK(data
));
5951 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
5952 (SCM exp
, SCM module
),
5953 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
5954 "in the top-level environment specified by @var{module}.\n"
5955 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
5956 "@var{module} is made the current module. The current module\n"
5957 "is reset to its previous value when @var{eval} returns.")
5958 #define FUNC_NAME s_scm_eval
5960 SCM_VALIDATE_MODULE (2, module
);
5962 return scm_internal_dynamic_wind
5963 (change_environment
, inner_eval
, restore_environment
,
5964 (void *) SCM_UNPACK (exp
),
5965 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
5970 /* At this point, deval and scm_dapply are generated.
5977 #if (SCM_ENABLE_DEPRECATED == 1)
5979 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5980 SCM
scm_ceval (SCM x
, SCM env
)
5983 return ceval (x
, env
);
5984 else if (scm_is_symbol (x
))
5985 return *scm_lookupcar (scm_cons (x
, SCM_UNDEFINED
), env
, 1);
5987 return SCM_I_XEVAL (x
, env
);
5990 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5991 SCM
scm_deval (SCM x
, SCM env
)
5994 return deval (x
, env
);
5995 else if (scm_is_symbol (x
))
5996 return *scm_lookupcar (scm_cons (x
, SCM_UNDEFINED
), env
, 1);
5998 return SCM_I_XEVAL (x
, env
);
6002 dispatching_eval (SCM x
, SCM env
)
6004 if (scm_debug_mode_p
)
6005 return scm_deval (x
, env
);
6007 return scm_ceval (x
, env
);
6010 /* Deprecated in guile 1.7.0 on 2004-03-29. */
6011 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
) = dispatching_eval
;
6019 scm_init_opts (scm_evaluator_traps
,
6020 scm_evaluator_trap_table
,
6021 SCM_N_EVALUATOR_TRAPS
);
6022 scm_init_opts (scm_eval_options_interface
,
6024 SCM_N_EVAL_OPTIONS
);
6026 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
6027 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
6028 scm_set_smob_free (scm_tc16_promise
, promise_free
);
6029 scm_set_smob_print (scm_tc16_promise
, promise_print
);
6031 undefineds
= scm_list_1 (SCM_UNDEFINED
);
6032 SCM_SETCDR (undefineds
, undefineds
);
6033 scm_permanent_object (undefineds
);
6035 scm_listofnull
= scm_list_1 (SCM_EOL
);
6037 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
6038 scm_permanent_object (f_apply
);
6040 #include "libguile/eval.x"
6042 scm_add_feature ("delay");