1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004
2 * Free Software Foundation, Inc.
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public
6 * License as published by the Free Software Foundation; either
7 * version 2.1 of the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
21 /* This file is read twice in order to produce debugging versions of ceval and
22 * scm_apply. These functions, deval and scm_dapply, are produced when we
23 * define the preprocessor macro DEVAL. The file is divided into sections
24 * which are treated differently with respect to DEVAL. The heads of these
25 * sections are marked with the string "SECTION:". */
27 /* SECTION: This code is compiled once.
34 #include "libguile/__scm.h"
38 /* AIX requires this to be the first thing in the file. The #pragma
39 directive is indented so pre-ANSI compilers will ignore it, rather
48 # ifndef alloca /* predefined by HP cc +Olibcalls */
56 #include "libguile/_scm.h"
57 #include "libguile/alist.h"
58 #include "libguile/async.h"
59 #include "libguile/continuations.h"
60 #include "libguile/debug.h"
61 #include "libguile/deprecation.h"
62 #include "libguile/dynwind.h"
63 #include "libguile/eq.h"
64 #include "libguile/feature.h"
65 #include "libguile/fluids.h"
66 #include "libguile/futures.h"
67 #include "libguile/goops.h"
68 #include "libguile/hash.h"
69 #include "libguile/hashtab.h"
70 #include "libguile/lang.h"
71 #include "libguile/list.h"
72 #include "libguile/macros.h"
73 #include "libguile/modules.h"
74 #include "libguile/objects.h"
75 #include "libguile/ports.h"
76 #include "libguile/print.h"
77 #include "libguile/procprop.h"
78 #include "libguile/root.h"
79 #include "libguile/smob.h"
80 #include "libguile/srcprop.h"
81 #include "libguile/stackchk.h"
82 #include "libguile/strings.h"
83 #include "libguile/throw.h"
84 #include "libguile/validate.h"
85 #include "libguile/values.h"
86 #include "libguile/vectors.h"
88 #include "libguile/eval.h"
92 static SCM
unmemoize_exprs (SCM expr
, SCM env
);
93 static SCM
canonicalize_define (SCM expr
);
94 static SCM
*scm_lookupcar1 (SCM vloc
, SCM genv
, int check
);
95 static SCM
unmemoize_builtin_macro (SCM expr
, SCM env
);
101 * This section defines the message strings for the syntax errors that can be
102 * detected during memoization and the functions and macros that shall be
103 * called by the memoizer code to signal syntax errors. */
106 /* Syntax errors that can be detected during memoization: */
108 /* Circular or improper lists do not form valid scheme expressions. If a
109 * circular list or an improper list is detected in a place where a scheme
110 * expression is expected, a 'Bad expression' error is signalled. */
111 static const char s_bad_expression
[] = "Bad expression";
113 /* If a form is detected that holds a different number of expressions than are
114 * required in that context, a 'Missing or extra expression' error is
116 static const char s_expression
[] = "Missing or extra expression in";
118 /* If a form is detected that holds less expressions than are required in that
119 * context, a 'Missing expression' error is signalled. */
120 static const char s_missing_expression
[] = "Missing expression in";
122 /* If a form is detected that holds more expressions than are allowed in that
123 * context, an 'Extra expression' error is signalled. */
124 static const char s_extra_expression
[] = "Extra expression in";
126 /* The empty combination '()' is not allowed as an expression in scheme. If
127 * it is detected in a place where an expression is expected, an 'Illegal
128 * empty combination' error is signalled. Note: If you encounter this error
129 * message, it is very likely that you intended to denote the empty list. To
130 * do so, you need to quote the empty list like (quote ()) or '(). */
131 static const char s_empty_combination
[] = "Illegal empty combination";
133 /* A body may hold an arbitrary number of internal defines, followed by a
134 * non-empty sequence of expressions. If a body with an empty sequence of
135 * expressions is detected, a 'Missing body expression' error is signalled.
137 static const char s_missing_body_expression
[] = "Missing body expression in";
139 /* A body may hold an arbitrary number of internal defines, followed by a
140 * non-empty sequence of expressions. Each the definitions and the
141 * expressions may be grouped arbitraryly with begin, but it is not allowed to
142 * mix definitions and expressions. If a define form in a body mixes
143 * definitions and expressions, a 'Mixed definitions and expressions' error is
145 static const char s_mixed_body_forms
[] = "Mixed definitions and expressions in";
146 /* Definitions are only allowed on the top level and at the start of a body.
147 * If a definition is detected anywhere else, a 'Bad define placement' error
149 static const char s_bad_define
[] = "Bad define placement";
151 /* Case or cond expressions must have at least one clause. If a case or cond
152 * expression without any clauses is detected, a 'Missing clauses' error is
154 static const char s_missing_clauses
[] = "Missing clauses";
156 /* If there is an 'else' clause in a case or a cond statement, it must be the
157 * last clause. If after the 'else' case clause further clauses are detected,
158 * a 'Misplaced else clause' error is signalled. */
159 static const char s_misplaced_else_clause
[] = "Misplaced else clause";
161 /* If a case clause is detected that is not in the format
162 * (<label(s)> <expression1> <expression2> ...)
163 * a 'Bad case clause' error is signalled. */
164 static const char s_bad_case_clause
[] = "Bad case clause";
166 /* If a case clause is detected where the <label(s)> element is neither a
167 * proper list nor (in case of the last clause) the syntactic keyword 'else',
168 * a 'Bad case labels' error is signalled. Note: If you encounter this error
169 * for an else-clause which seems to be syntactically correct, check if 'else'
170 * is really a syntactic keyword in that context. If 'else' is bound in the
171 * local or global environment, it is not considered a syntactic keyword, but
172 * will be treated as any other variable. */
173 static const char s_bad_case_labels
[] = "Bad case labels";
175 /* In a case statement all labels have to be distinct. If in a case statement
176 * a label occurs more than once, a 'Duplicate case label' error is
178 static const char s_duplicate_case_label
[] = "Duplicate case label";
180 /* If a cond clause is detected that is not in one of the formats
181 * (<test> <expression1> ...) or (else <expression1> <expression2> ...)
182 * a 'Bad cond clause' error is signalled. */
183 static const char s_bad_cond_clause
[] = "Bad cond clause";
185 /* If a cond clause is detected that uses the alternate '=>' form, but does
186 * not hold a recipient element for the test result, a 'Missing recipient'
187 * error is signalled. */
188 static const char s_missing_recipient
[] = "Missing recipient in";
190 /* If in a position where a variable name is required some other object is
191 * detected, a 'Bad variable' error is signalled. */
192 static const char s_bad_variable
[] = "Bad variable";
194 /* Bindings for forms like 'let' and 'do' have to be given in a proper,
195 * possibly empty list. If any other object is detected in a place where a
196 * list of bindings was required, a 'Bad bindings' error is signalled. */
197 static const char s_bad_bindings
[] = "Bad bindings";
199 /* Depending on the syntactic context, a binding has to be in the format
200 * (<variable> <expression>) or (<variable> <expression1> <expression2>).
201 * If anything else is detected in a place where a binding was expected, a
202 * 'Bad binding' error is signalled. */
203 static const char s_bad_binding
[] = "Bad binding";
205 /* Some syntactic forms don't allow variable names to appear more than once in
206 * a list of bindings. If such a situation is nevertheless detected, a
207 * 'Duplicate binding' error is signalled. */
208 static const char s_duplicate_binding
[] = "Duplicate binding";
210 /* If the exit form of a 'do' expression is not in the format
211 * (<test> <expression> ...)
212 * a 'Bad exit clause' error is signalled. */
213 static const char s_bad_exit_clause
[] = "Bad exit clause";
215 /* The formal function arguments of a lambda expression have to be either a
216 * single symbol or a non-cyclic list. For anything else a 'Bad formals'
217 * error is signalled. */
218 static const char s_bad_formals
[] = "Bad formals";
220 /* If in a lambda expression something else than a symbol is detected at a
221 * place where a formal function argument is required, a 'Bad formal' error is
223 static const char s_bad_formal
[] = "Bad formal";
225 /* If in the arguments list of a lambda expression an argument name occurs
226 * more than once, a 'Duplicate formal' error is signalled. */
227 static const char s_duplicate_formal
[] = "Duplicate formal";
229 /* If the evaluation of an unquote-splicing expression gives something else
230 * than a proper list, a 'Non-list result for unquote-splicing' error is
232 static const char s_splicing
[] = "Non-list result for unquote-splicing";
234 /* If something else than an exact integer is detected as the argument for
235 * @slot-ref and @slot-set!, a 'Bad slot number' error is signalled. */
236 static const char s_bad_slot_number
[] = "Bad slot number";
239 /* Signal a syntax error. We distinguish between the form that caused the
240 * error and the enclosing expression. The error message will print out as
241 * shown in the following pattern. The file name and line number are only
242 * given when they can be determined from the erroneous form or from the
243 * enclosing expression.
245 * <filename>: In procedure memoization:
246 * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
248 SCM_SYMBOL (syntax_error_key
, "syntax-error");
250 /* The prototype is needed to indicate that the function does not return. */
252 syntax_error (const char* const, const SCM
, const SCM
) SCM_NORETURN
;
255 syntax_error (const char* const msg
, const SCM form
, const SCM expr
)
257 const SCM msg_string
= scm_makfrom0str (msg
);
258 SCM filename
= SCM_BOOL_F
;
259 SCM linenr
= SCM_BOOL_F
;
263 if (SCM_CONSP (form
))
265 filename
= scm_source_property (form
, scm_sym_filename
);
266 linenr
= scm_source_property (form
, scm_sym_line
);
269 if (scm_is_false (filename
) && scm_is_false (linenr
) && SCM_CONSP (expr
))
271 filename
= scm_source_property (expr
, scm_sym_filename
);
272 linenr
= scm_source_property (expr
, scm_sym_line
);
275 if (!SCM_UNBNDP (expr
))
277 if (scm_is_true (filename
))
279 format
= "In file ~S, line ~S: ~A ~S in expression ~S.";
280 args
= scm_list_5 (filename
, linenr
, msg_string
, form
, expr
);
282 else if (scm_is_true (linenr
))
284 format
= "In line ~S: ~A ~S in expression ~S.";
285 args
= scm_list_4 (linenr
, msg_string
, form
, expr
);
289 format
= "~A ~S in expression ~S.";
290 args
= scm_list_3 (msg_string
, form
, expr
);
295 if (scm_is_true (filename
))
297 format
= "In file ~S, line ~S: ~A ~S.";
298 args
= scm_list_4 (filename
, linenr
, msg_string
, form
);
300 else if (scm_is_true (linenr
))
302 format
= "In line ~S: ~A ~S.";
303 args
= scm_list_3 (linenr
, msg_string
, form
);
308 args
= scm_list_2 (msg_string
, form
);
312 scm_error (syntax_error_key
, "memoization", format
, args
, SCM_BOOL_F
);
316 /* Shortcut macros to simplify syntax error handling. */
317 #define ASSERT_SYNTAX(cond, message, form) \
318 { if (!(cond)) syntax_error (message, form, SCM_UNDEFINED); }
319 #define ASSERT_SYNTAX_2(cond, message, form, expr) \
320 { if (!(cond)) syntax_error (message, form, expr); }
326 * Ilocs are memoized references to variables in local environment frames.
327 * They are represented as three values: The relative offset of the
328 * environment frame, the number of the binding within that frame, and a
329 * boolean value indicating whether the binding is the last binding in the
332 * Frame numbers have 11 bits, relative offsets have 12 bits.
335 #define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc)
336 #define SCM_IFRINC (0x00000100L)
337 #define SCM_ICDR (0x00080000L)
338 #define SCM_IDINC (0x00100000L)
339 #define SCM_IFRAME(n) ((long)((SCM_ICDR-SCM_IFRINC)>>8) \
340 & (SCM_UNPACK (n) >> 8))
341 #define SCM_IDIST(n) (SCM_UNPACK (n) >> 20)
342 #define SCM_ICDRP(n) (SCM_ICDR & SCM_UNPACK (n))
343 #define SCM_IDSTMSK (-SCM_IDINC)
344 #define SCM_IFRAMEMAX ((1<<11)-1)
345 #define SCM_IDISTMAX ((1<<12)-1)
346 #define SCM_MAKE_ILOC(frame_nr, binding_nr, last_p) \
349 + ((binding_nr) << 20) \
350 + ((last_p) ? SCM_ICDR : 0) \
354 scm_i_print_iloc (SCM iloc
, SCM port
)
356 scm_puts ("#@", port
);
357 scm_intprint ((long) SCM_IFRAME (iloc
), 10, port
);
358 scm_putc (SCM_ICDRP (iloc
) ? '-' : '+', port
);
359 scm_intprint ((long) SCM_IDIST (iloc
), 10, port
);
362 #if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
364 SCM
scm_dbg_make_iloc (SCM frame
, SCM binding
, SCM cdrp
);
366 SCM_DEFINE (scm_dbg_make_iloc
, "dbg-make-iloc", 3, 0, 0,
367 (SCM frame
, SCM binding
, SCM cdrp
),
368 "Return a new iloc with frame offset @var{frame}, binding\n"
369 "offset @var{binding} and the cdr flag @var{cdrp}.")
370 #define FUNC_NAME s_scm_dbg_make_iloc
372 return SCM_MAKE_ILOC (scm_to_unsigned_integer (frame
, 0, SCM_IFRAME_MAX
),
373 scm_to_unsigned_integer (binding
, 0, SCM_IDIST_MAX
),
378 SCM
scm_dbg_iloc_p (SCM obj
);
380 SCM_DEFINE (scm_dbg_iloc_p
, "dbg-iloc?", 1, 0, 0,
382 "Return @code{#t} if @var{obj} is an iloc.")
383 #define FUNC_NAME s_scm_dbg_iloc_p
385 return scm_from_bool (SCM_ILOCP (obj
));
393 /* {Evaluator byte codes (isyms)}
396 #define ISYMNUM(n) (SCM_ITAG8_DATA (n))
398 /* This table must agree with the list of SCM_IM_ constants in tags.h */
399 static const char *const isymnames
[] =
416 "#@call-with-current-continuation",
422 "#@call-with-values",
430 scm_i_print_isym (SCM isym
, SCM port
)
432 const size_t isymnum
= ISYMNUM (isym
);
433 if (isymnum
< (sizeof isymnames
/ sizeof (char *)))
434 scm_puts (isymnames
[isymnum
], port
);
436 scm_ipruk ("isym", isym
, port
);
441 /* The function lookup_symbol is used during memoization: Lookup the symbol in
442 * the environment. If there is no binding for the symbol, SCM_UNDEFINED is
443 * returned. If the symbol is a global variable, the variable object to which
444 * the symbol is bound is returned. Finally, if the symbol is a local
445 * variable the corresponding iloc object is returned. */
447 /* A helper function for lookup_symbol: Try to find the symbol in the top
448 * level environment frame. The function returns SCM_UNDEFINED if the symbol
449 * is unbound and it returns a variable object if the symbol is a global
452 lookup_global_symbol (const SCM symbol
, const SCM top_level
)
454 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
455 if (scm_is_false (variable
))
456 return SCM_UNDEFINED
;
462 lookup_symbol (const SCM symbol
, const SCM env
)
465 unsigned int frame_nr
;
467 for (frame_idx
= env
, frame_nr
= 0;
468 !SCM_NULLP (frame_idx
);
469 frame_idx
= SCM_CDR (frame_idx
), ++frame_nr
)
471 const SCM frame
= SCM_CAR (frame_idx
);
472 if (SCM_CONSP (frame
))
474 /* frame holds a local environment frame */
476 unsigned int symbol_nr
;
478 for (symbol_idx
= SCM_CAR (frame
), symbol_nr
= 0;
479 SCM_CONSP (symbol_idx
);
480 symbol_idx
= SCM_CDR (symbol_idx
), ++symbol_nr
)
482 if (SCM_EQ_P (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_EQ_P (symbol_idx
, symbol
))
487 /* found the symbol as the last element of the current frame */
488 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 1);
492 /* no more local environment frames */
493 return lookup_global_symbol (symbol
, frame
);
497 return lookup_global_symbol (symbol
, SCM_BOOL_F
);
501 /* Return true if the symbol is - from the point of view of a macro
502 * transformer - a literal in the sense specified in chapter "pattern
503 * language" of R5RS. In the code below, however, we don't match the
504 * definition of R5RS exactly: It returns true if the identifier has no
505 * binding or if it is a syntactic keyword. */
507 literal_p (const SCM symbol
, const SCM env
)
509 const SCM variable
= lookup_symbol (symbol
, env
);
510 if (SCM_UNBNDP (variable
))
512 if (SCM_VARIABLEP (variable
) && SCM_MACROP (SCM_VARIABLE_REF (variable
)))
519 /* Return true if the expression is self-quoting in the memoized code. Thus,
520 * some other objects (like e. g. vectors) are reported as self-quoting, which
521 * according to R5RS would need to be quoted. */
523 is_self_quoting_p (const SCM expr
)
525 if (SCM_CONSP (expr
))
527 else if (SCM_SYMBOLP (expr
))
529 else if (SCM_NULLP (expr
))
535 SCM_SYMBOL (sym_three_question_marks
, "???");
538 unmemoize_expression (const SCM expr
, const SCM env
)
540 if (SCM_ILOCP (expr
))
543 unsigned long int frame_nr
;
545 unsigned long int symbol_nr
;
547 for (frame_idx
= env
, frame_nr
= SCM_IFRAME (expr
);
549 frame_idx
= SCM_CDR (frame_idx
), --frame_nr
)
551 for (symbol_idx
= SCM_CAAR (frame_idx
), symbol_nr
= SCM_IDIST (expr
);
553 symbol_idx
= SCM_CDR (symbol_idx
), --symbol_nr
)
555 return SCM_ICDRP (expr
) ? symbol_idx
: SCM_CAR (symbol_idx
);
557 else if (SCM_VARIABLEP (expr
))
559 const SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), expr
);
560 return scm_is_true (sym
) ? sym
: sym_three_question_marks
;
562 else if (SCM_VECTORP (expr
))
564 return scm_list_2 (scm_sym_quote
, expr
);
566 else if (!SCM_CONSP (expr
))
570 else if (SCM_ISYMP (SCM_CAR (expr
)))
572 return unmemoize_builtin_macro (expr
, env
);
576 return unmemoize_exprs (expr
, env
);
582 unmemoize_exprs (const SCM exprs
, const SCM env
)
584 SCM r_result
= SCM_EOL
;
585 SCM expr_idx
= exprs
;
588 /* Note that due to the current lazy memoizer we may find partially memoized
589 * code during execution. In such code, lists of expressions that stem from
590 * a body form may start with an ISYM if the body itself has not yet been
591 * memoized. This isym is just an internal marker to indicate that the body
592 * still needs to be memoized. It is dropped during unmemoization. */
593 if (SCM_CONSP (expr_idx
) && SCM_ISYMP (SCM_CAR (expr_idx
)))
594 expr_idx
= SCM_CDR (expr_idx
);
596 /* Moreover, in partially memoized code we have to expect improper lists of
597 * expressions: On the one hand, for such code syntax checks have not yet
598 * fully been performed, on the other hand, there may be even legal code
599 * like '(a . b) appear as an improper list of expressions as long as the
600 * quote expression is still in its unmemoized form. For this reason, the
601 * following code handles improper lists of expressions until memoization
602 * and execution have been completely separated. */
603 for (; SCM_CONSP (expr_idx
); expr_idx
= SCM_CDR (expr_idx
))
605 const SCM expr
= SCM_CAR (expr_idx
);
606 um_expr
= unmemoize_expression (expr
, env
);
607 r_result
= scm_cons (um_expr
, r_result
);
609 um_expr
= unmemoize_expression (expr_idx
, env
);
610 if (!SCM_NULLP (r_result
))
612 const SCM result
= scm_reverse_x (r_result
, SCM_UNDEFINED
);
613 SCM_SETCDR (r_result
, um_expr
);
623 /* Rewrite the body (which is given as the list of expressions forming the
624 * body) into its internal form. The internal form of a body (<expr> ...) is
625 * just the body itself, but prefixed with an ISYM that denotes to what kind
626 * of outer construct this body belongs: (<ISYM> <expr> ...). A lambda body
627 * starts with SCM_IM_LAMBDA, for example, a body of a let starts with
630 * It is assumed that the calling expression has already made sure that the
631 * body is a proper list. */
633 m_body (SCM op
, SCM exprs
)
635 /* Don't add another ISYM if one is present already. */
636 if (SCM_ISYMP (SCM_CAR (exprs
)))
639 return scm_cons (op
, exprs
);
643 /* The function m_expand_body memoizes a proper list of expressions forming a
644 * body. This function takes care of dealing with internal defines and
645 * transforming them into an equivalent letrec expression. The list of
646 * expressions is rewritten in place. */
648 /* This is a helper function for m_expand_body. If the argument expression is
649 * a symbol that denotes a syntactic keyword, the corresponding macro object
650 * is returned, in all other cases the function returns SCM_UNDEFINED. */
652 try_macro_lookup (const SCM expr
, const SCM env
)
654 if (SCM_SYMBOLP (expr
))
656 const SCM variable
= lookup_symbol (expr
, env
);
657 if (SCM_VARIABLEP (variable
))
659 const SCM value
= SCM_VARIABLE_REF (variable
);
660 if (SCM_MACROP (value
))
665 return SCM_UNDEFINED
;
668 /* This is a helper function for m_expand_body. It expands user macros,
669 * because for the correct translation of a body we need to know whether they
670 * expand to a definition. */
672 expand_user_macros (SCM expr
, const SCM env
)
674 while (SCM_CONSP (expr
))
676 const SCM car_expr
= SCM_CAR (expr
);
677 const SCM new_car
= expand_user_macros (car_expr
, env
);
678 const SCM value
= try_macro_lookup (new_car
, env
);
680 if (SCM_MACROP (value
) && SCM_MACRO_TYPE (value
) == 2)
682 /* User macros transform code into code. */
683 expr
= scm_call_2 (SCM_MACRO_CODE (value
), expr
, env
);
684 /* We need to reiterate on the transformed code. */
688 /* No user macro: return. */
689 SCM_SETCAR (expr
, new_car
);
697 /* This is a helper function for m_expand_body. It determines if a given form
698 * represents an application of a given built-in macro. The built-in macro to
699 * check for is identified by its syntactic keyword. The form is an
700 * application of the given macro if looking up the car of the form in the
701 * given environment actually returns the built-in macro. */
703 is_system_macro_p (const SCM syntactic_keyword
, const SCM form
, const SCM env
)
705 if (SCM_CONSP (form
))
707 const SCM car_form
= SCM_CAR (form
);
708 const SCM value
= try_macro_lookup (car_form
, env
);
709 if (SCM_BUILTIN_MACRO_P (value
))
711 const SCM macro_name
= scm_macro_name (value
);
712 return SCM_EQ_P (macro_name
, syntactic_keyword
);
720 m_expand_body (const SCM forms
, const SCM env
)
722 /* The first body form can be skipped since it is known to be the ISYM that
723 * was prepended to the body by m_body. */
724 SCM cdr_forms
= SCM_CDR (forms
);
725 SCM form_idx
= cdr_forms
;
726 SCM definitions
= SCM_EOL
;
727 SCM sequence
= SCM_EOL
;
729 /* According to R5RS, the list of body forms consists of two parts: a number
730 * (maybe zero) of definitions, followed by a non-empty sequence of
731 * expressions. Each the definitions and the expressions may be grouped
732 * arbitrarily with begin, but it is not allowed to mix definitions and
733 * expressions. The task of the following loop therefore is to split the
734 * list of body forms into the list of definitions and the sequence of
736 while (!SCM_NULLP (form_idx
))
738 const SCM form
= SCM_CAR (form_idx
);
739 const SCM new_form
= expand_user_macros (form
, env
);
740 if (is_system_macro_p (scm_sym_define
, new_form
, env
))
742 definitions
= scm_cons (new_form
, definitions
);
743 form_idx
= SCM_CDR (form_idx
);
745 else if (is_system_macro_p (scm_sym_begin
, new_form
, env
))
747 /* We have encountered a group of forms. This has to be either a
748 * (possibly empty) group of (possibly further grouped) definitions,
749 * or a non-empty group of (possibly further grouped)
751 const SCM grouped_forms
= SCM_CDR (new_form
);
752 unsigned int found_definition
= 0;
753 unsigned int found_expression
= 0;
754 SCM grouped_form_idx
= grouped_forms
;
755 while (!found_expression
&& !SCM_NULLP (grouped_form_idx
))
757 const SCM inner_form
= SCM_CAR (grouped_form_idx
);
758 const SCM new_inner_form
= expand_user_macros (inner_form
, env
);
759 if (is_system_macro_p (scm_sym_define
, new_inner_form
, env
))
761 found_definition
= 1;
762 definitions
= scm_cons (new_inner_form
, definitions
);
763 grouped_form_idx
= SCM_CDR (grouped_form_idx
);
765 else if (is_system_macro_p (scm_sym_begin
, new_inner_form
, env
))
767 const SCM inner_group
= SCM_CDR (new_inner_form
);
769 = scm_append (scm_list_2 (inner_group
,
770 SCM_CDR (grouped_form_idx
)));
774 /* The group marks the start of the expressions of the body.
775 * We have to make sure that within the same group we have
776 * not encountered a definition before. */
777 ASSERT_SYNTAX (!found_definition
, s_mixed_body_forms
, form
);
778 found_expression
= 1;
779 grouped_form_idx
= SCM_EOL
;
783 /* We have finished processing the group. If we have not yet
784 * encountered an expression we continue processing the forms of the
785 * body to collect further definition forms. Otherwise, the group
786 * marks the start of the sequence of expressions of the body. */
787 if (!found_expression
)
789 form_idx
= SCM_CDR (form_idx
);
799 /* We have detected a form which is no definition. This marks the
800 * start of the sequence of expressions of the body. */
806 /* FIXME: forms does not hold information about the file location. */
807 ASSERT_SYNTAX (SCM_CONSP (sequence
), s_missing_body_expression
, cdr_forms
);
809 if (!SCM_NULLP (definitions
))
813 SCM letrec_expression
;
814 SCM new_letrec_expression
;
816 SCM bindings
= SCM_EOL
;
817 for (definition_idx
= definitions
;
818 !SCM_NULLP (definition_idx
);
819 definition_idx
= SCM_CDR (definition_idx
))
821 const SCM definition
= SCM_CAR (definition_idx
);
822 const SCM canonical_definition
= canonicalize_define (definition
);
823 const SCM binding
= SCM_CDR (canonical_definition
);
824 bindings
= scm_cons (binding
, bindings
);
827 letrec_tail
= scm_cons (bindings
, sequence
);
828 /* FIXME: forms does not hold information about the file location. */
829 letrec_expression
= scm_cons_source (forms
, scm_sym_letrec
, letrec_tail
);
830 new_letrec_expression
= scm_m_letrec (letrec_expression
, env
);
831 SCM_SETCAR (forms
, new_letrec_expression
);
832 SCM_SETCDR (forms
, SCM_EOL
);
836 SCM_SETCAR (forms
, SCM_CAR (sequence
));
837 SCM_SETCDR (forms
, SCM_CDR (sequence
));
842 macroexp (SCM x
, SCM env
)
844 SCM res
, proc
, orig_sym
;
846 /* Don't bother to produce error messages here. We get them when we
847 eventually execute the code for real. */
850 orig_sym
= SCM_CAR (x
);
851 if (!SCM_SYMBOLP (orig_sym
))
855 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
856 if (proc_ptr
== NULL
)
858 /* We have lost the race. */
864 /* Only handle memoizing macros. `Acros' and `macros' are really
865 special forms and should not be evaluated here. */
867 if (!SCM_MACROP (proc
)
868 || (SCM_MACRO_TYPE (proc
) != 2 && !SCM_BUILTIN_MACRO_P (proc
)))
871 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
872 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
874 if (scm_ilength (res
) <= 0)
875 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
878 SCM_SETCAR (x
, SCM_CAR (res
));
879 SCM_SETCDR (x
, SCM_CDR (res
));
885 /* Start of the memoizers for the standard R5RS builtin macros. */
888 SCM_SYNTAX (s_and
, "and", scm_i_makbimacro
, scm_m_and
);
889 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
892 scm_m_and (SCM expr
, SCM env SCM_UNUSED
)
894 const SCM cdr_expr
= SCM_CDR (expr
);
895 const long length
= scm_ilength (cdr_expr
);
897 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
901 /* Special case: (and) is replaced by #t. */
906 SCM_SETCAR (expr
, SCM_IM_AND
);
912 unmemoize_and (const SCM expr
, const SCM env
)
914 return scm_cons (scm_sym_and
, unmemoize_exprs (SCM_CDR (expr
), env
));
918 SCM_SYNTAX (s_begin
, "begin", scm_i_makbimacro
, scm_m_begin
);
919 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
922 scm_m_begin (SCM expr
, SCM env SCM_UNUSED
)
924 const SCM cdr_expr
= SCM_CDR (expr
);
925 /* Dirk:FIXME:: An empty begin clause is not generally allowed by R5RS.
926 * That means, there should be a distinction between uses of begin where an
927 * empty clause is OK and where it is not. */
928 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
930 SCM_SETCAR (expr
, SCM_IM_BEGIN
);
935 unmemoize_begin (const SCM expr
, const SCM env
)
937 return scm_cons (scm_sym_begin
, unmemoize_exprs (SCM_CDR (expr
), env
));
941 SCM_SYNTAX (s_case
, "case", scm_i_makbimacro
, scm_m_case
);
942 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
943 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
946 scm_m_case (SCM expr
, SCM env
)
949 SCM all_labels
= SCM_EOL
;
951 /* Check, whether 'else is a literal, i. e. not bound to a value. */
952 const int else_literal_p
= literal_p (scm_sym_else
, env
);
954 const SCM cdr_expr
= SCM_CDR (expr
);
955 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
956 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_clauses
, expr
);
958 clauses
= SCM_CDR (cdr_expr
);
959 while (!SCM_NULLP (clauses
))
963 const SCM clause
= SCM_CAR (clauses
);
964 ASSERT_SYNTAX_2 (scm_ilength (clause
) >= 2,
965 s_bad_case_clause
, clause
, expr
);
967 labels
= SCM_CAR (clause
);
968 if (SCM_CONSP (labels
))
970 ASSERT_SYNTAX_2 (scm_ilength (labels
) >= 0,
971 s_bad_case_labels
, labels
, expr
);
972 all_labels
= scm_append (scm_list_2 (labels
, all_labels
));
974 else if (SCM_NULLP (labels
))
976 /* The list of labels is empty. According to R5RS this is allowed.
977 * It means that the sequence of expressions will never be executed.
978 * Therefore, as an optimization, we could remove the whole
983 ASSERT_SYNTAX_2 (SCM_EQ_P (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_EQ_P (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_EQ_P (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_EQ_P (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_EQ_P (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_EQ_P (test
, SCM_IM_ELSE
))
1106 um_test
= scm_sym_else
;
1108 um_test
= unmemoize_expression (test
, env
);
1110 if (!SCM_NULLP (sequence
) && SCM_EQ_P (SCM_CAR (sequence
), SCM_IM_ARROW
))
1112 const SCM target
= SCM_CADR (sequence
);
1113 const SCM um_target
= unmemoize_expression (target
, env
);
1114 um_sequence
= scm_list_2 (scm_sym_arrow
, um_target
);
1118 um_sequence
= unmemoize_exprs (sequence
, env
);
1121 um_clause
= scm_cons (um_test
, um_sequence
);
1122 um_clauses
= scm_cons (um_clause
, um_clauses
);
1124 um_clauses
= scm_reverse_x (um_clauses
, SCM_UNDEFINED
);
1126 return scm_cons (scm_sym_cond
, um_clauses
);
1130 SCM_SYNTAX (s_define
, "define", scm_i_makbimacro
, scm_m_define
);
1131 SCM_GLOBAL_SYMBOL (scm_sym_define
, s_define
);
1133 /* Guile provides an extension to R5RS' define syntax to represent function
1134 * currying in a compact way. With this extension, it is allowed to write
1135 * (define <nested-variable> <body>), where <nested-variable> has of one of
1136 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
1137 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
1138 * should be either a sequence of zero or more variables, or a sequence of one
1139 * or more variables followed by a space-delimited period and another
1140 * variable. Each level of argument nesting wraps the <body> within another
1141 * lambda expression. For example, the following forms are allowed, each one
1142 * followed by an equivalent, more explicit implementation.
1144 * (define ((a b . c) . d) <body>) is equivalent to
1145 * (define a (lambda (b . c) (lambda d <body>)))
1147 * (define (((a) b) c . d) <body>) is equivalent to
1148 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
1150 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
1151 * module that does not implement this extension. */
1153 canonicalize_define (const SCM expr
)
1158 const SCM cdr_expr
= SCM_CDR (expr
);
1159 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1160 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1162 body
= SCM_CDR (cdr_expr
);
1163 variable
= SCM_CAR (cdr_expr
);
1164 while (SCM_CONSP (variable
))
1166 /* This while loop realizes function currying by variable nesting.
1167 * Variable is known to be a nested-variable. In every iteration of the
1168 * loop another level of lambda expression is created, starting with the
1169 * innermost one. Note that we don't check for duplicate formals here:
1170 * This will be done by the memoizer of the lambda expression. */
1171 const SCM formals
= SCM_CDR (variable
);
1172 const SCM tail
= scm_cons (formals
, body
);
1174 /* Add source properties to each new lambda expression: */
1175 const SCM lambda
= scm_cons_source (variable
, scm_sym_lambda
, tail
);
1177 body
= scm_list_1 (lambda
);
1178 variable
= SCM_CAR (variable
);
1180 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
), s_bad_variable
, variable
, expr
);
1181 ASSERT_SYNTAX (scm_ilength (body
) == 1, s_expression
, expr
);
1183 SCM_SETCAR (cdr_expr
, variable
);
1184 SCM_SETCDR (cdr_expr
, body
);
1188 /* According to section 5.2.1 of R5RS we first have to make sure that the
1189 * variable is bound, and then perform the (set! variable expression)
1190 * operation. This means, that within the expression we may already assign
1191 * values to variable: (define foo (begin (set! foo 1) (+ foo 1))) */
1193 scm_m_define (SCM expr
, SCM env
)
1195 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), s_bad_define
, expr
);
1198 const SCM canonical_definition
= canonicalize_define (expr
);
1199 const SCM cdr_canonical_definition
= SCM_CDR (canonical_definition
);
1200 const SCM variable
= SCM_CAR (cdr_canonical_definition
);
1202 = scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_T
);
1203 const SCM value
= scm_eval_car (SCM_CDR (cdr_canonical_definition
), env
);
1205 if (SCM_REC_PROCNAMES_P
)
1208 while (SCM_MACROP (tmp
))
1209 tmp
= SCM_MACRO_CODE (tmp
);
1210 if (SCM_CLOSUREP (tmp
)
1211 /* Only the first definition determines the name. */
1212 && scm_is_false (scm_procedure_property (tmp
, scm_sym_name
)))
1213 scm_set_procedure_property_x (tmp
, scm_sym_name
, variable
);
1216 SCM_VARIABLE_SET (location
, value
);
1218 return SCM_UNSPECIFIED
;
1223 /* This is a helper function for forms (<keyword> <expression>) that are
1224 * transformed into (#@<keyword> '() <memoized_expression>) in order to allow
1225 * for easy creation of a thunk (i. e. a closure without arguments) using the
1226 * ('() <memoized_expression>) tail of the memoized form. */
1228 memoize_as_thunk_prototype (const SCM expr
, const SCM env SCM_UNUSED
)
1230 const SCM cdr_expr
= SCM_CDR (expr
);
1231 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1232 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1234 SCM_SETCDR (expr
, scm_cons (SCM_EOL
, cdr_expr
));
1240 SCM_SYNTAX (s_delay
, "delay", scm_i_makbimacro
, scm_m_delay
);
1241 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
1243 /* Promises are implemented as closures with an empty parameter list. Thus,
1244 * (delay <expression>) is transformed into (#@delay '() <expression>), where
1245 * the empty list represents the empty parameter list. This representation
1246 * allows for easy creation of the closure during evaluation. */
1248 scm_m_delay (SCM expr
, SCM env
)
1250 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1251 SCM_SETCAR (new_expr
, SCM_IM_DELAY
);
1256 unmemoize_delay (const SCM expr
, const SCM env
)
1258 const SCM thunk_expr
= SCM_CADDR (expr
);
1259 return scm_list_2 (scm_sym_delay
, unmemoize_expression (thunk_expr
, env
));
1263 SCM_SYNTAX(s_do
, "do", scm_i_makbimacro
, scm_m_do
);
1264 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
1266 /* DO gets the most radically altered syntax. The order of the vars is
1267 * reversed here. During the evaluation this allows for simple consing of the
1268 * results of the inits and steps:
1270 (do ((<var1> <init1> <step1>)
1278 (#@do (<init1> <init2> ... <initn>)
1279 (varn ... var2 var1)
1282 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
1285 scm_m_do (SCM expr
, SCM env SCM_UNUSED
)
1287 SCM variables
= SCM_EOL
;
1288 SCM init_forms
= SCM_EOL
;
1289 SCM step_forms
= SCM_EOL
;
1296 const SCM cdr_expr
= SCM_CDR (expr
);
1297 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1298 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1300 /* Collect variables, init and step forms. */
1301 binding_idx
= SCM_CAR (cdr_expr
);
1302 ASSERT_SYNTAX_2 (scm_ilength (binding_idx
) >= 0,
1303 s_bad_bindings
, binding_idx
, expr
);
1304 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1306 const SCM binding
= SCM_CAR (binding_idx
);
1307 const long length
= scm_ilength (binding
);
1308 ASSERT_SYNTAX_2 (length
== 2 || length
== 3,
1309 s_bad_binding
, binding
, expr
);
1312 const SCM name
= SCM_CAR (binding
);
1313 const SCM init
= SCM_CADR (binding
);
1314 const SCM step
= (length
== 2) ? name
: SCM_CADDR (binding
);
1315 ASSERT_SYNTAX_2 (SCM_SYMBOLP (name
), s_bad_variable
, name
, expr
);
1316 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, variables
)),
1317 s_duplicate_binding
, name
, expr
);
1319 variables
= scm_cons (name
, variables
);
1320 init_forms
= scm_cons (init
, init_forms
);
1321 step_forms
= scm_cons (step
, step_forms
);
1324 init_forms
= scm_reverse_x (init_forms
, SCM_UNDEFINED
);
1325 step_forms
= scm_reverse_x (step_forms
, SCM_UNDEFINED
);
1327 /* Memoize the test form and the exit sequence. */
1328 cddr_expr
= SCM_CDR (cdr_expr
);
1329 exit_clause
= SCM_CAR (cddr_expr
);
1330 ASSERT_SYNTAX_2 (scm_ilength (exit_clause
) >= 1,
1331 s_bad_exit_clause
, exit_clause
, expr
);
1333 commands
= SCM_CDR (cddr_expr
);
1334 tail
= scm_cons2 (exit_clause
, commands
, step_forms
);
1335 tail
= scm_cons2 (init_forms
, variables
, tail
);
1336 SCM_SETCAR (expr
, SCM_IM_DO
);
1337 SCM_SETCDR (expr
, tail
);
1342 unmemoize_do (const SCM expr
, const SCM env
)
1344 const SCM cdr_expr
= SCM_CDR (expr
);
1345 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1346 const SCM rnames
= SCM_CAR (cddr_expr
);
1347 const SCM extended_env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
1348 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
1349 const SCM exit_sequence
= SCM_CAR (cdddr_expr
);
1350 const SCM um_exit_sequence
= unmemoize_exprs (exit_sequence
, extended_env
);
1351 const SCM cddddr_expr
= SCM_CDR (cdddr_expr
);
1352 const SCM um_body
= unmemoize_exprs (SCM_CAR (cddddr_expr
), extended_env
);
1354 /* build transformed binding list */
1355 SCM um_names
= scm_reverse (rnames
);
1356 SCM um_inits
= unmemoize_exprs (SCM_CAR (cdr_expr
), env
);
1357 SCM um_steps
= unmemoize_exprs (SCM_CDR (cddddr_expr
), extended_env
);
1358 SCM um_bindings
= SCM_EOL
;
1359 while (!SCM_NULLP (um_names
))
1361 const SCM name
= SCM_CAR (um_names
);
1362 const SCM init
= SCM_CAR (um_inits
);
1363 SCM step
= SCM_CAR (um_steps
);
1364 step
= SCM_EQ_P (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
1366 um_bindings
= scm_cons (scm_cons2 (name
, init
, step
), um_bindings
);
1368 um_names
= SCM_CDR (um_names
);
1369 um_inits
= SCM_CDR (um_inits
);
1370 um_steps
= SCM_CDR (um_steps
);
1372 um_bindings
= scm_reverse_x (um_bindings
, SCM_UNDEFINED
);
1374 return scm_cons (scm_sym_do
,
1375 scm_cons2 (um_bindings
, um_exit_sequence
, um_body
));
1379 SCM_SYNTAX (s_if
, "if", scm_i_makbimacro
, scm_m_if
);
1380 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
1383 scm_m_if (SCM expr
, SCM env SCM_UNUSED
)
1385 const SCM cdr_expr
= SCM_CDR (expr
);
1386 const long length
= scm_ilength (cdr_expr
);
1387 ASSERT_SYNTAX (length
== 2 || length
== 3, s_expression
, expr
);
1388 SCM_SETCAR (expr
, SCM_IM_IF
);
1393 unmemoize_if (const SCM expr
, const SCM env
)
1395 const SCM cdr_expr
= SCM_CDR (expr
);
1396 const SCM um_condition
= unmemoize_expression (SCM_CAR (cdr_expr
), env
);
1397 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1398 const SCM um_then
= unmemoize_expression (SCM_CAR (cddr_expr
), env
);
1399 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
1401 if (SCM_NULLP (cdddr_expr
))
1403 return scm_list_3 (scm_sym_if
, um_condition
, um_then
);
1407 const SCM um_else
= unmemoize_expression (SCM_CAR (cdddr_expr
), env
);
1408 return scm_list_4 (scm_sym_if
, um_condition
, um_then
, um_else
);
1413 SCM_SYNTAX (s_lambda
, "lambda", scm_i_makbimacro
, scm_m_lambda
);
1414 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
1416 /* A helper function for memoize_lambda to support checking for duplicate
1417 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
1418 * LIST or to the cdr of the last cons. Therefore, LIST may have any of the
1419 * forms that a formal argument can have:
1420 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
1422 c_improper_memq (SCM obj
, SCM list
)
1424 for (; SCM_CONSP (list
); list
= SCM_CDR (list
))
1426 if (SCM_EQ_P (SCM_CAR (list
), obj
))
1429 return SCM_EQ_P (list
, obj
);
1433 scm_m_lambda (SCM expr
, SCM env SCM_UNUSED
)
1442 const SCM cdr_expr
= SCM_CDR (expr
);
1443 const long length
= scm_ilength (cdr_expr
);
1444 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1445 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1447 /* Before iterating the list of formal arguments, make sure the formals
1448 * actually are given as either a symbol or a non-cyclic list. */
1449 formals
= SCM_CAR (cdr_expr
);
1450 if (SCM_CONSP (formals
))
1452 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
1453 * detected, report a 'Bad formals' error. */
1457 ASSERT_SYNTAX_2 (SCM_SYMBOLP (formals
) || SCM_NULLP (formals
),
1458 s_bad_formals
, formals
, expr
);
1461 /* Now iterate the list of formal arguments to check if all formals are
1462 * symbols, and that there are no duplicates. */
1463 formals_idx
= formals
;
1464 while (SCM_CONSP (formals_idx
))
1466 const SCM formal
= SCM_CAR (formals_idx
);
1467 const SCM next_idx
= SCM_CDR (formals_idx
);
1468 ASSERT_SYNTAX_2 (SCM_SYMBOLP (formal
), s_bad_formal
, formal
, expr
);
1469 ASSERT_SYNTAX_2 (!c_improper_memq (formal
, next_idx
),
1470 s_duplicate_formal
, formal
, expr
);
1471 formals_idx
= next_idx
;
1473 ASSERT_SYNTAX_2 (SCM_NULLP (formals_idx
) || SCM_SYMBOLP (formals_idx
),
1474 s_bad_formal
, formals_idx
, expr
);
1476 /* Memoize the body. Keep a potential documentation string. */
1477 /* Dirk:FIXME:: We should probably extract the documentation string to
1478 * some external database. Otherwise it will slow down execution, since
1479 * the documentation string will have to be skipped with every execution
1480 * of the closure. */
1481 cddr_expr
= SCM_CDR (cdr_expr
);
1482 documentation
= (length
>= 3 && SCM_STRINGP (SCM_CAR (cddr_expr
)));
1483 body
= documentation
? SCM_CDR (cddr_expr
) : cddr_expr
;
1484 new_body
= m_body (SCM_IM_LAMBDA
, body
);
1486 SCM_SETCAR (expr
, SCM_IM_LAMBDA
);
1488 SCM_SETCDR (cddr_expr
, new_body
);
1490 SCM_SETCDR (cdr_expr
, new_body
);
1495 unmemoize_lambda (const SCM expr
, const SCM env
)
1497 const SCM formals
= SCM_CADR (expr
);
1498 const SCM body
= SCM_CDDR (expr
);
1500 const SCM new_env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, env
);
1501 const SCM um_formals
= scm_i_finite_list_copy (formals
);
1502 const SCM um_body
= unmemoize_exprs (body
, new_env
);
1504 return scm_cons2 (scm_sym_lambda
, um_formals
, um_body
);
1508 /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
1510 check_bindings (const SCM bindings
, const SCM expr
)
1514 ASSERT_SYNTAX_2 (scm_ilength (bindings
) >= 0,
1515 s_bad_bindings
, bindings
, expr
);
1517 binding_idx
= bindings
;
1518 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1520 SCM name
; /* const */
1522 const SCM binding
= SCM_CAR (binding_idx
);
1523 ASSERT_SYNTAX_2 (scm_ilength (binding
) == 2,
1524 s_bad_binding
, binding
, expr
);
1526 name
= SCM_CAR (binding
);
1527 ASSERT_SYNTAX_2 (SCM_SYMBOLP (name
), s_bad_variable
, name
, expr
);
1532 /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
1533 * transformed to the lists (vn ... v2 v1) and (i1 i2 ... in). That is, the
1534 * variables are returned in a list with their order reversed, and the init
1535 * forms are returned in a list in the same order as they are given in the
1536 * bindings. If a duplicate variable name is detected, an error is
1539 transform_bindings (
1540 const SCM bindings
, const SCM expr
,
1541 SCM
*const rvarptr
, SCM
*const initptr
)
1543 SCM rvariables
= SCM_EOL
;
1544 SCM rinits
= SCM_EOL
;
1545 SCM binding_idx
= bindings
;
1546 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1548 const SCM binding
= SCM_CAR (binding_idx
);
1549 const SCM cdr_binding
= SCM_CDR (binding
);
1550 const SCM name
= SCM_CAR (binding
);
1551 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, rvariables
)),
1552 s_duplicate_binding
, name
, expr
);
1553 rvariables
= scm_cons (name
, rvariables
);
1554 rinits
= scm_cons (SCM_CAR (cdr_binding
), rinits
);
1556 *rvarptr
= rvariables
;
1557 *initptr
= scm_reverse_x (rinits
, SCM_UNDEFINED
);
1561 SCM_SYNTAX(s_let
, "let", scm_i_makbimacro
, scm_m_let
);
1562 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
1564 /* This function is a helper function for memoize_let. It transforms
1565 * (let name ((var init) ...) body ...) into
1566 * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
1567 * and memoizes the expression. It is assumed that the caller has checked
1568 * that name is a symbol and that there are bindings and a body. */
1570 memoize_named_let (const SCM expr
, const SCM env SCM_UNUSED
)
1576 const SCM cdr_expr
= SCM_CDR (expr
);
1577 const SCM name
= SCM_CAR (cdr_expr
);
1578 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1579 const SCM bindings
= SCM_CAR (cddr_expr
);
1580 check_bindings (bindings
, expr
);
1582 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1583 variables
= scm_reverse_x (rvariables
, SCM_UNDEFINED
);
1586 const SCM let_body
= SCM_CDR (cddr_expr
);
1587 const SCM lambda_body
= m_body (SCM_IM_LET
, let_body
);
1588 const SCM lambda_tail
= scm_cons (variables
, lambda_body
);
1589 const SCM lambda_form
= scm_cons_source (expr
, scm_sym_lambda
, lambda_tail
);
1591 const SCM rvar
= scm_list_1 (name
);
1592 const SCM init
= scm_list_1 (lambda_form
);
1593 const SCM body
= m_body (SCM_IM_LET
, scm_list_1 (name
));
1594 const SCM letrec_tail
= scm_cons (rvar
, scm_cons (init
, body
));
1595 const SCM letrec_form
= scm_cons_source (expr
, SCM_IM_LETREC
, letrec_tail
);
1596 return scm_cons_source (expr
, letrec_form
, inits
);
1600 /* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1601 * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
1603 scm_m_let (SCM expr
, SCM env
)
1607 const SCM cdr_expr
= SCM_CDR (expr
);
1608 const long length
= scm_ilength (cdr_expr
);
1609 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1610 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1612 bindings
= SCM_CAR (cdr_expr
);
1613 if (SCM_SYMBOLP (bindings
))
1615 ASSERT_SYNTAX (length
>= 3, s_missing_expression
, expr
);
1616 return memoize_named_let (expr
, env
);
1619 check_bindings (bindings
, expr
);
1620 if (SCM_NULLP (bindings
) || SCM_NULLP (SCM_CDR (bindings
)))
1622 /* Special case: no bindings or single binding => let* is faster. */
1623 const SCM body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1624 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), bindings
, body
), env
);
1631 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1634 const SCM new_body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1635 const SCM new_tail
= scm_cons2 (rvariables
, inits
, new_body
);
1636 SCM_SETCAR (expr
, SCM_IM_LET
);
1637 SCM_SETCDR (expr
, new_tail
);
1644 build_binding_list (SCM rnames
, SCM rinits
)
1646 SCM bindings
= SCM_EOL
;
1647 while (!SCM_NULLP (rnames
))
1649 const SCM binding
= scm_list_2 (SCM_CAR (rnames
), SCM_CAR (rinits
));
1650 bindings
= scm_cons (binding
, bindings
);
1651 rnames
= SCM_CDR (rnames
);
1652 rinits
= SCM_CDR (rinits
);
1658 unmemoize_let (const SCM expr
, const SCM env
)
1660 const SCM cdr_expr
= SCM_CDR (expr
);
1661 const SCM um_rnames
= SCM_CAR (cdr_expr
);
1662 const SCM extended_env
= SCM_EXTEND_ENV (um_rnames
, SCM_EOL
, env
);
1663 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1664 const SCM um_inits
= unmemoize_exprs (SCM_CAR (cddr_expr
), env
);
1665 const SCM um_rinits
= scm_reverse_x (um_inits
, SCM_UNDEFINED
);
1666 const SCM um_bindings
= build_binding_list (um_rnames
, um_rinits
);
1667 const SCM um_body
= unmemoize_exprs (SCM_CDR (cddr_expr
), extended_env
);
1669 return scm_cons2 (scm_sym_let
, um_bindings
, um_body
);
1673 SCM_SYNTAX(s_letrec
, "letrec", scm_i_makbimacro
, scm_m_letrec
);
1674 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
1677 scm_m_letrec (SCM expr
, SCM env
)
1681 const SCM cdr_expr
= SCM_CDR (expr
);
1682 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1683 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1685 bindings
= SCM_CAR (cdr_expr
);
1686 if (SCM_NULLP (bindings
))
1688 /* no bindings, let* is executed faster */
1689 SCM body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1690 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), SCM_EOL
, body
), env
);
1698 check_bindings (bindings
, expr
);
1699 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1700 new_body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1701 return scm_cons2 (SCM_IM_LETREC
, rvariables
, scm_cons (inits
, new_body
));
1706 unmemoize_letrec (const SCM expr
, const SCM env
)
1708 const SCM cdr_expr
= SCM_CDR (expr
);
1709 const SCM um_rnames
= SCM_CAR (cdr_expr
);
1710 const SCM extended_env
= SCM_EXTEND_ENV (um_rnames
, SCM_EOL
, env
);
1711 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1712 const SCM um_inits
= unmemoize_exprs (SCM_CAR (cddr_expr
), extended_env
);
1713 const SCM um_rinits
= scm_reverse_x (um_inits
, SCM_UNDEFINED
);
1714 const SCM um_bindings
= build_binding_list (um_rnames
, um_rinits
);
1715 const SCM um_body
= unmemoize_exprs (SCM_CDR (cddr_expr
), extended_env
);
1717 return scm_cons2 (scm_sym_letrec
, um_bindings
, um_body
);
1722 SCM_SYNTAX (s_letstar
, "let*", scm_i_makbimacro
, scm_m_letstar
);
1723 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
1725 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1726 * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
1728 scm_m_letstar (SCM expr
, SCM env SCM_UNUSED
)
1733 const SCM cdr_expr
= SCM_CDR (expr
);
1734 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1735 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1737 binding_idx
= SCM_CAR (cdr_expr
);
1738 check_bindings (binding_idx
, expr
);
1740 /* Transform ((v1 i1) (v2 i2) ...) into (v1 i1 v2 i2 ...). The
1741 * transformation is done in place. At the beginning of one iteration of
1742 * the loop the variable binding_idx holds the form
1743 * P1:( (vn . P2:(in . ())) . P3:( (vn+1 in+1) ... ) ),
1744 * where P1, P2 and P3 indicate the pairs, that are relevant for the
1745 * transformation. P1 and P2 are modified in the loop, P3 remains
1746 * untouched. After the execution of the loop, P1 will hold
1747 * P1:( vn . P2:(in . P3:( (vn+1 in+1) ... )) )
1748 * and binding_idx will hold P3. */
1749 while (!SCM_NULLP (binding_idx
))
1751 const SCM cdr_binding_idx
= SCM_CDR (binding_idx
); /* remember P3 */
1752 const SCM binding
= SCM_CAR (binding_idx
);
1753 const SCM name
= SCM_CAR (binding
);
1754 const SCM cdr_binding
= SCM_CDR (binding
);
1756 SCM_SETCDR (cdr_binding
, cdr_binding_idx
); /* update P2 */
1757 SCM_SETCAR (binding_idx
, name
); /* update P1 */
1758 SCM_SETCDR (binding_idx
, cdr_binding
); /* update P1 */
1760 binding_idx
= cdr_binding_idx
; /* continue with P3 */
1763 new_body
= m_body (SCM_IM_LETSTAR
, SCM_CDR (cdr_expr
));
1764 SCM_SETCAR (expr
, SCM_IM_LETSTAR
);
1765 /* the bindings have been changed in place */
1766 SCM_SETCDR (cdr_expr
, new_body
);
1771 unmemoize_letstar (const SCM expr
, const SCM env
)
1773 const SCM cdr_expr
= SCM_CDR (expr
);
1774 const SCM body
= SCM_CDR (cdr_expr
);
1775 SCM bindings
= SCM_CAR (cdr_expr
);
1776 SCM um_bindings
= SCM_EOL
;
1777 SCM extended_env
= env
;
1780 while (!SCM_NULLP (bindings
))
1782 const SCM variable
= SCM_CAR (bindings
);
1783 const SCM init
= SCM_CADR (bindings
);
1784 const SCM um_init
= unmemoize_expression (init
, extended_env
);
1785 um_bindings
= scm_cons (scm_list_2 (variable
, um_init
), um_bindings
);
1786 extended_env
= SCM_EXTEND_ENV (variable
, SCM_BOOL_F
, extended_env
);
1787 bindings
= SCM_CDDR (bindings
);
1789 um_bindings
= scm_reverse_x (um_bindings
, SCM_UNDEFINED
);
1791 um_body
= unmemoize_exprs (body
, extended_env
);
1793 return scm_cons2 (scm_sym_letstar
, um_bindings
, um_body
);
1797 SCM_SYNTAX (s_or
, "or", scm_i_makbimacro
, scm_m_or
);
1798 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
1801 scm_m_or (SCM expr
, SCM env SCM_UNUSED
)
1803 const SCM cdr_expr
= SCM_CDR (expr
);
1804 const long length
= scm_ilength (cdr_expr
);
1806 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1810 /* Special case: (or) is replaced by #f. */
1815 SCM_SETCAR (expr
, SCM_IM_OR
);
1821 unmemoize_or (const SCM expr
, const SCM env
)
1823 return scm_cons (scm_sym_or
, unmemoize_exprs (SCM_CDR (expr
), env
));
1827 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
1828 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
1829 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
1830 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
1832 /* Internal function to handle a quasiquotation: 'form' is the parameter in
1833 * the call (quasiquotation form), 'env' is the environment where unquoted
1834 * expressions will be evaluated, and 'depth' is the current quasiquotation
1835 * nesting level and is known to be greater than zero. */
1837 iqq (SCM form
, SCM env
, unsigned long int depth
)
1839 if (SCM_CONSP (form
))
1841 const SCM tmp
= SCM_CAR (form
);
1842 if (SCM_EQ_P (tmp
, scm_sym_quasiquote
))
1844 const SCM args
= SCM_CDR (form
);
1845 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1846 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
1848 else if (SCM_EQ_P (tmp
, scm_sym_unquote
))
1850 const SCM args
= SCM_CDR (form
);
1851 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1853 return scm_eval_car (args
, env
);
1855 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
1857 else if (SCM_CONSP (tmp
)
1858 && SCM_EQ_P (SCM_CAR (tmp
), scm_sym_uq_splicing
))
1860 const SCM args
= SCM_CDR (tmp
);
1861 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1864 const SCM list
= scm_eval_car (args
, env
);
1865 const SCM rest
= SCM_CDR (form
);
1866 ASSERT_SYNTAX_2 (scm_ilength (list
) >= 0,
1867 s_splicing
, list
, form
);
1868 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
1871 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
1872 iqq (SCM_CDR (form
), env
, depth
));
1875 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
1876 iqq (SCM_CDR (form
), env
, depth
));
1878 else if (SCM_VECTORP (form
))
1880 size_t i
= SCM_VECTOR_LENGTH (form
);
1881 SCM
const *const data
= SCM_VELTS (form
);
1884 tmp
= scm_cons (data
[--i
], tmp
);
1885 scm_remember_upto_here_1 (form
);
1886 return scm_vector (iqq (tmp
, env
, depth
));
1893 scm_m_quasiquote (SCM expr
, SCM env
)
1895 const SCM cdr_expr
= SCM_CDR (expr
);
1896 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1897 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1898 return iqq (SCM_CAR (cdr_expr
), env
, 1);
1902 SCM_SYNTAX (s_quote
, "quote", scm_i_makbimacro
, scm_m_quote
);
1903 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
1906 scm_m_quote (SCM expr
, SCM env SCM_UNUSED
)
1910 const SCM cdr_expr
= SCM_CDR (expr
);
1911 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1912 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1913 quotee
= SCM_CAR (cdr_expr
);
1914 if (is_self_quoting_p (quotee
))
1917 SCM_SETCAR (expr
, SCM_IM_QUOTE
);
1918 SCM_SETCDR (expr
, quotee
);
1923 unmemoize_quote (const SCM expr
, const SCM env SCM_UNUSED
)
1925 return scm_list_2 (scm_sym_quote
, SCM_CDR (expr
));
1929 /* Will go into the RnRS module when Guile is factorized.
1930 SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
1931 static const char s_set_x
[] = "set!";
1932 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, s_set_x
);
1935 scm_m_set_x (SCM expr
, SCM env SCM_UNUSED
)
1940 const SCM cdr_expr
= SCM_CDR (expr
);
1941 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1942 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1943 variable
= SCM_CAR (cdr_expr
);
1945 /* Memoize the variable form. */
1946 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
), s_bad_variable
, variable
, expr
);
1947 new_variable
= lookup_symbol (variable
, env
);
1948 /* Leave the memoization of unbound symbols to lazy memoization: */
1949 if (SCM_UNBNDP (new_variable
))
1950 new_variable
= variable
;
1952 SCM_SETCAR (expr
, SCM_IM_SET_X
);
1953 SCM_SETCAR (cdr_expr
, new_variable
);
1958 unmemoize_set_x (const SCM expr
, const SCM env
)
1960 return scm_cons (scm_sym_set_x
, unmemoize_exprs (SCM_CDR (expr
), env
));
1964 /* Start of the memoizers for non-R5RS builtin macros. */
1967 SCM_SYNTAX (s_atapply
, "@apply", scm_i_makbimacro
, scm_m_apply
);
1968 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1969 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1972 scm_m_apply (SCM expr
, SCM env SCM_UNUSED
)
1974 const SCM cdr_expr
= SCM_CDR (expr
);
1975 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1976 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_missing_expression
, expr
);
1978 SCM_SETCAR (expr
, SCM_IM_APPLY
);
1983 unmemoize_apply (const SCM expr
, const SCM env
)
1985 return scm_list_2 (scm_sym_atapply
, unmemoize_exprs (SCM_CDR (expr
), env
));
1989 SCM_SYNTAX (s_atbind
, "@bind", scm_i_makbimacro
, scm_m_atbind
);
1991 /* FIXME: The following explanation should go into the documentation: */
1992 /* (@bind ((var init) ...) body ...) will assign the values of the `init's to
1993 * the global variables named by `var's (symbols, not evaluated), creating
1994 * them if they don't exist, executes body, and then restores the previous
1995 * values of the `var's. Additionally, whenever control leaves body, the
1996 * values of the `var's are saved and restored when control returns. It is an
1997 * error when a symbol appears more than once among the `var's. All `init's
1998 * are evaluated before any `var' is set.
2000 * Think of this as `let' for dynamic scope.
2003 /* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into
2004 * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...).
2006 * FIXME - also implement `@bind*'.
2009 scm_m_atbind (SCM expr
, SCM env
)
2016 const SCM top_level
= scm_env_top_level (env
);
2018 const SCM cdr_expr
= SCM_CDR (expr
);
2019 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2020 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
2021 bindings
= SCM_CAR (cdr_expr
);
2022 check_bindings (bindings
, expr
);
2023 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
2025 for (variable_idx
= rvariables
;
2026 !SCM_NULLP (variable_idx
);
2027 variable_idx
= SCM_CDR (variable_idx
))
2029 /* The first call to scm_sym2var will look beyond the current module,
2030 * while the second call wont. */
2031 const SCM variable
= SCM_CAR (variable_idx
);
2032 SCM new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_F
);
2033 if (scm_is_false (new_variable
))
2034 new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_T
);
2035 SCM_SETCAR (variable_idx
, new_variable
);
2038 SCM_SETCAR (expr
, SCM_IM_BIND
);
2039 SCM_SETCAR (cdr_expr
, scm_cons (rvariables
, inits
));
2044 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_i_makbimacro
, scm_m_cont
);
2045 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, s_atcall_cc
);
2048 scm_m_cont (SCM expr
, SCM env SCM_UNUSED
)
2050 const SCM cdr_expr
= SCM_CDR (expr
);
2051 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2052 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2054 SCM_SETCAR (expr
, SCM_IM_CONT
);
2059 unmemoize_atcall_cc (const SCM expr
, const SCM env
)
2061 return scm_list_2 (scm_sym_atcall_cc
, unmemoize_exprs (SCM_CDR (expr
), env
));
2065 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_i_makbimacro
, scm_m_at_call_with_values
);
2066 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
2069 scm_m_at_call_with_values (SCM expr
, SCM env SCM_UNUSED
)
2071 const SCM cdr_expr
= SCM_CDR (expr
);
2072 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2073 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2075 SCM_SETCAR (expr
, SCM_IM_CALL_WITH_VALUES
);
2080 unmemoize_at_call_with_values (const SCM expr
, const SCM env
)
2082 return scm_list_2 (scm_sym_at_call_with_values
,
2083 unmemoize_exprs (SCM_CDR (expr
), env
));
2087 SCM_SYNTAX (s_future
, "future", scm_i_makbimacro
, scm_m_future
);
2088 SCM_GLOBAL_SYMBOL (scm_sym_future
, s_future
);
2090 /* Like promises, futures are implemented as closures with an empty
2091 * parameter list. Thus, (future <expression>) is transformed into
2092 * (#@future '() <expression>), where the empty list represents the
2093 * empty parameter list. This representation allows for easy creation
2094 * of the closure during evaluation. */
2096 scm_m_future (SCM expr
, SCM env
)
2098 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
2099 SCM_SETCAR (new_expr
, SCM_IM_FUTURE
);
2104 unmemoize_future (const SCM expr
, const SCM env
)
2106 const SCM thunk_expr
= SCM_CADDR (expr
);
2107 return scm_list_2 (scm_sym_future
, unmemoize_expression (thunk_expr
, env
));
2111 SCM_SYNTAX (s_gset_x
, "set!", scm_i_makbimacro
, scm_m_generalized_set_x
);
2112 SCM_SYMBOL (scm_sym_setter
, "setter");
2115 scm_m_generalized_set_x (SCM expr
, SCM env
)
2117 SCM target
, exp_target
;
2119 const SCM cdr_expr
= SCM_CDR (expr
);
2120 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2121 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2123 target
= SCM_CAR (cdr_expr
);
2124 if (!SCM_CONSP (target
))
2127 return scm_m_set_x (expr
, env
);
2131 /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */
2132 /* Macroexpanding the target might return things of the form
2133 (begin <atom>). In that case, <atom> must be a symbol or a
2134 variable and we memoize to (set! <atom> ...).
2136 exp_target
= macroexp (target
, env
);
2137 if (SCM_EQ_P (SCM_CAR (exp_target
), SCM_IM_BEGIN
)
2138 && !SCM_NULLP (SCM_CDR (exp_target
))
2139 && SCM_NULLP (SCM_CDDR (exp_target
)))
2141 exp_target
= SCM_CADR (exp_target
);
2142 ASSERT_SYNTAX_2 (SCM_SYMBOLP (exp_target
)
2143 || SCM_VARIABLEP (exp_target
),
2144 s_bad_variable
, exp_target
, expr
);
2145 return scm_cons (SCM_IM_SET_X
, scm_cons (exp_target
,
2146 SCM_CDR (cdr_expr
)));
2150 const SCM setter_proc_tail
= scm_list_1 (SCM_CAR (target
));
2151 const SCM setter_proc
= scm_cons_source (expr
, scm_sym_setter
,
2154 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
2155 const SCM setter_args
= scm_append_x (scm_list_2 (SCM_CDR (target
),
2158 SCM_SETCAR (expr
, setter_proc
);
2159 SCM_SETCDR (expr
, setter_args
);
2166 /* @slot-ref is bound privately in the (oop goops) module from goops.c. As
2167 * soon as the module system allows us to more freely create bindings in
2168 * arbitrary modules during the startup phase, the code from goops.c should be
2171 SCM_SYMBOL (sym_atslot_ref
, "@slot-ref");
2174 scm_m_atslot_ref (SCM expr
, SCM env SCM_UNUSED
)
2178 const SCM cdr_expr
= SCM_CDR (expr
);
2179 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2180 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2181 slot_nr
= SCM_CADR (cdr_expr
);
2182 ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2184 SCM_SETCAR (expr
, SCM_IM_SLOT_REF
);
2185 SCM_SETCDR (cdr_expr
, slot_nr
);
2190 unmemoize_atslot_ref (const SCM expr
, const SCM env
)
2192 const SCM instance
= SCM_CADR (expr
);
2193 const SCM um_instance
= unmemoize_expression (instance
, env
);
2194 const SCM slot_nr
= SCM_CDDR (expr
);
2195 return scm_list_3 (sym_atslot_ref
, um_instance
, slot_nr
);
2199 /* @slot-set! is bound privately in the (oop goops) module from goops.c. As
2200 * soon as the module system allows us to more freely create bindings in
2201 * arbitrary modules during the startup phase, the code from goops.c should be
2204 SCM_SYMBOL (sym_atslot_set_x
, "@slot-set!");
2207 scm_m_atslot_set_x (SCM expr
, SCM env SCM_UNUSED
)
2211 const SCM cdr_expr
= SCM_CDR (expr
);
2212 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2213 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 3, s_expression
, expr
);
2214 slot_nr
= SCM_CADR (cdr_expr
);
2215 ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2217 SCM_SETCAR (expr
, SCM_IM_SLOT_SET_X
);
2222 unmemoize_atslot_set_x (const SCM expr
, const SCM env
)
2224 const SCM cdr_expr
= SCM_CDR (expr
);
2225 const SCM instance
= SCM_CAR (cdr_expr
);
2226 const SCM um_instance
= unmemoize_expression (instance
, env
);
2227 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
2228 const SCM slot_nr
= SCM_CAR (cddr_expr
);
2229 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
2230 const SCM value
= SCM_CAR (cdddr_expr
);
2231 const SCM um_value
= unmemoize_expression (value
, env
);
2232 return scm_list_4 (sym_atslot_set_x
, um_instance
, slot_nr
, um_value
);
2236 #if SCM_ENABLE_ELISP
2238 static const char s_defun
[] = "Symbol's function definition is void";
2240 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_i_makbimacro
, scm_m_nil_cond
);
2242 /* nil-cond expressions have the form
2243 * (nil-cond COND VAL COND VAL ... ELSEVAL) */
2245 scm_m_nil_cond (SCM expr
, SCM env SCM_UNUSED
)
2247 const long length
= scm_ilength (SCM_CDR (expr
));
2248 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
2249 ASSERT_SYNTAX (length
>= 1 && (length
% 2) == 1, s_expression
, expr
);
2251 SCM_SETCAR (expr
, SCM_IM_NIL_COND
);
2256 SCM_SYNTAX (s_atfop
, "@fop", scm_i_makbimacro
, scm_m_atfop
);
2258 /* The @fop-macro handles procedure and macro applications for elisp. The
2259 * input expression must have the form
2260 * (@fop <var> (transformer-macro <expr> ...))
2261 * where <var> must be a symbol. The expression is transformed into the
2262 * memoized form of either
2263 * (apply <un-aliased var> (transformer-macro <expr> ...))
2264 * if the value of var (across all aliasing) is not a macro, or
2265 * (<un-aliased var> <expr> ...)
2266 * if var is a macro. */
2268 scm_m_atfop (SCM expr
, SCM env SCM_UNUSED
)
2273 const SCM cdr_expr
= SCM_CDR (expr
);
2274 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2275 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 1, s_missing_expression
, expr
);
2277 symbol
= SCM_CAR (cdr_expr
);
2278 ASSERT_SYNTAX_2 (SCM_SYMBOLP (symbol
), s_bad_variable
, symbol
, expr
);
2280 location
= scm_symbol_fref (symbol
);
2281 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2283 /* The elisp function `defalias' allows to define aliases for symbols. To
2284 * look up such definitions, the chain of symbol definitions has to be
2285 * followed up to the terminal symbol. */
2286 while (SCM_SYMBOLP (SCM_VARIABLE_REF (location
)))
2288 const SCM alias
= SCM_VARIABLE_REF (location
);
2289 location
= scm_symbol_fref (alias
);
2290 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2293 /* Memoize the value location belonging to the terminal symbol. */
2294 SCM_SETCAR (cdr_expr
, location
);
2296 if (!SCM_MACROP (SCM_VARIABLE_REF (location
)))
2298 /* Since the location does not contain a macro, the form is a procedure
2299 * application. Replace `@fop' by `@apply' and transform the expression
2300 * including the `transformer-macro'. */
2301 SCM_SETCAR (expr
, SCM_IM_APPLY
);
2306 /* Since the location contains a macro, the arguments should not be
2307 * transformed, so the `transformer-macro' is cut out. The resulting
2308 * expression starts with the memoized variable, that is at the cdr of
2309 * the input expression. */
2310 SCM_SETCDR (cdr_expr
, SCM_CDADR (cdr_expr
));
2315 #endif /* SCM_ENABLE_ELISP */
2319 unmemoize_builtin_macro (const SCM expr
, const SCM env
)
2321 switch (ISYMNUM (SCM_CAR (expr
)))
2323 case (ISYMNUM (SCM_IM_AND
)):
2324 return unmemoize_and (expr
, env
);
2326 case (ISYMNUM (SCM_IM_BEGIN
)):
2327 return unmemoize_begin (expr
, env
);
2329 case (ISYMNUM (SCM_IM_CASE
)):
2330 return unmemoize_case (expr
, env
);
2332 case (ISYMNUM (SCM_IM_COND
)):
2333 return unmemoize_cond (expr
, env
);
2335 case (ISYMNUM (SCM_IM_DELAY
)):
2336 return unmemoize_delay (expr
, env
);
2338 case (ISYMNUM (SCM_IM_DO
)):
2339 return unmemoize_do (expr
, env
);
2341 case (ISYMNUM (SCM_IM_IF
)):
2342 return unmemoize_if (expr
, env
);
2344 case (ISYMNUM (SCM_IM_LAMBDA
)):
2345 return unmemoize_lambda (expr
, env
);
2347 case (ISYMNUM (SCM_IM_LET
)):
2348 return unmemoize_let (expr
, env
);
2350 case (ISYMNUM (SCM_IM_LETREC
)):
2351 return unmemoize_letrec (expr
, env
);
2353 case (ISYMNUM (SCM_IM_LETSTAR
)):
2354 return unmemoize_letstar (expr
, env
);
2356 case (ISYMNUM (SCM_IM_OR
)):
2357 return unmemoize_or (expr
, env
);
2359 case (ISYMNUM (SCM_IM_QUOTE
)):
2360 return unmemoize_quote (expr
, env
);
2362 case (ISYMNUM (SCM_IM_SET_X
)):
2363 return unmemoize_set_x (expr
, env
);
2365 case (ISYMNUM (SCM_IM_APPLY
)):
2366 return unmemoize_apply (expr
, env
);
2368 case (ISYMNUM (SCM_IM_BIND
)):
2369 return unmemoize_exprs (expr
, env
); /* FIXME */
2371 case (ISYMNUM (SCM_IM_CONT
)):
2372 return unmemoize_atcall_cc (expr
, env
);
2374 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2375 return unmemoize_at_call_with_values (expr
, env
);
2377 case (ISYMNUM (SCM_IM_FUTURE
)):
2378 return unmemoize_future (expr
, env
);
2380 case (ISYMNUM (SCM_IM_SLOT_REF
)):
2381 return unmemoize_atslot_ref (expr
, env
);
2383 case (ISYMNUM (SCM_IM_SLOT_SET_X
)):
2384 return unmemoize_atslot_set_x (expr
, env
);
2386 case (ISYMNUM (SCM_IM_NIL_COND
)):
2387 return unmemoize_exprs (expr
, env
); /* FIXME */
2390 return unmemoize_exprs (expr
, env
); /* FIXME */
2395 /* scm_i_unmemocopy_expr and scm_i_unmemocopy_body take a memoized expression
2396 * respectively a memoized body together with its environment and rewrite it
2397 * to its original form. Thus, these functions are the inversion of the
2398 * rewrite rules above. The procedure is not optimized for speed. It's used
2399 * in scm_i_unmemoize_expr, scm_procedure_source, macro_print and scm_iprin1.
2401 * Unmemoizing is not a reliable process. You cannot in general expect to get
2402 * the original source back.
2404 * However, GOOPS currently relies on this for method compilation. This ought
2408 scm_i_unmemocopy_expr (SCM expr
, SCM env
)
2410 const SCM source_properties
= scm_whash_lookup (scm_source_whash
, expr
);
2411 const SCM um_expr
= unmemoize_expression (expr
, env
);
2413 if (scm_is_true (source_properties
))
2414 scm_whash_insert (scm_source_whash
, um_expr
, source_properties
);
2420 scm_i_unmemocopy_body (SCM forms
, SCM env
)
2422 const SCM source_properties
= scm_whash_lookup (scm_source_whash
, forms
);
2423 const SCM um_forms
= unmemoize_exprs (forms
, env
);
2425 if (scm_is_true (source_properties
))
2426 scm_whash_insert (scm_source_whash
, um_forms
, source_properties
);
2432 #if (SCM_ENABLE_DEPRECATED == 1)
2434 /* Deprecated in guile 1.7.0 on 2003-11-09. */
2436 scm_m_expand_body (SCM exprs
, SCM env
)
2438 scm_c_issue_deprecation_warning
2439 ("`scm_m_expand_body' is deprecated.");
2440 m_expand_body (exprs
, env
);
2445 SCM_SYNTAX (s_undefine
, "undefine", scm_makacro
, scm_m_undefine
);
2448 scm_m_undefine (SCM expr
, SCM env
)
2453 const SCM cdr_expr
= SCM_CDR (expr
);
2454 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), "Bad undefine placement in", expr
);
2455 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2456 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2458 scm_c_issue_deprecation_warning
2459 ("`undefine' is deprecated.\n");
2461 variable
= SCM_CAR (cdr_expr
);
2462 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
), s_bad_variable
, variable
, expr
);
2463 location
= scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_F
);
2464 ASSERT_SYNTAX_2 (scm_is_true (location
)
2465 && !SCM_UNBNDP (SCM_VARIABLE_REF (location
)),
2466 "variable already unbound ", variable
, expr
);
2467 SCM_VARIABLE_SET (location
, SCM_UNDEFINED
);
2468 return SCM_UNSPECIFIED
;
2472 scm_macroexp (SCM x
, SCM env
)
2474 scm_c_issue_deprecation_warning
2475 ("`scm_macroexp' is deprecated.");
2476 return macroexp (x
, env
);
2482 #if (SCM_ENABLE_DEPRECATED == 1)
2485 scm_unmemocar (SCM form
, SCM env
)
2487 scm_c_issue_deprecation_warning
2488 ("`scm_unmemocar' is deprecated.");
2490 if (!SCM_CONSP (form
))
2494 SCM c
= SCM_CAR (form
);
2495 if (SCM_VARIABLEP (c
))
2497 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
2498 if (scm_is_false (sym
))
2499 sym
= sym_three_question_marks
;
2500 SCM_SETCAR (form
, sym
);
2502 else if (SCM_ILOCP (c
))
2504 unsigned long int ir
;
2506 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
2507 env
= SCM_CDR (env
);
2508 env
= SCM_CAAR (env
);
2509 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
2510 env
= SCM_CDR (env
);
2512 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
2520 /*****************************************************************************/
2521 /*****************************************************************************/
2522 /* The definitions for execution start here. */
2523 /*****************************************************************************/
2524 /*****************************************************************************/
2526 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
2527 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
2528 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
2529 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
2531 /* A function object to implement "apply" for non-closure functions. */
2533 /* An endless list consisting of #<undefined> objects: */
2534 static SCM undefineds
;
2538 scm_badargsp (SCM formals
, SCM args
)
2540 while (!SCM_NULLP (formals
))
2542 if (!SCM_CONSP (formals
))
2544 if (SCM_NULLP (args
))
2546 formals
= SCM_CDR (formals
);
2547 args
= SCM_CDR (args
);
2549 return !SCM_NULLP (args
) ? 1 : 0;
2554 /* The evaluator contains a plethora of EVAL symbols. This is an attempt at
2557 * The following macros should be used in code which is read twice (where the
2558 * choice of evaluator is hard soldered):
2560 * CEVAL is the symbol used within one evaluator to call itself.
2561 * Originally, it is defined to ceval, but is redefined to deval during the
2564 * SCM_EVALIM is used when it is known that the expression is an
2565 * immediate. (This macro never calls an evaluator.)
2567 * EVAL evaluates an expression that is expected to have its symbols already
2568 * memoized. Expressions that are not of the form '(<form> <form> ...)' are
2569 * evaluated inline without calling an evaluator.
2571 * EVALCAR evaluates the car of an expression 'X:(Y:<form> <form> ...)',
2572 * potentially replacing a symbol at the position Y:<form> by its memoized
2573 * variable. If Y:<form> is not of the form '(<form> <form> ...)', the
2574 * evaluation is performed inline without calling an evaluator.
2576 * The following macros should be used in code which is read once
2577 * (where the choice of evaluator is dynamic):
2579 * SCM_XEVAL corresponds to EVAL, but uses ceval *or* deval depending on the
2582 * SCM_XEVALCAR corresponds to EVALCAR, but uses ceval *or* deval depending
2583 * on the debugging mode.
2585 * The main motivation for keeping this plethora is efficiency
2586 * together with maintainability (=> locality of code).
2589 static SCM
ceval (SCM x
, SCM env
);
2590 static SCM
deval (SCM x
, SCM env
);
2594 #define SCM_EVALIM2(x) \
2595 ((SCM_EQ_P ((x), SCM_EOL) \
2596 ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \
2600 #define SCM_EVALIM(x, env) (SCM_ILOCP (x) \
2601 ? *scm_ilookup ((x), (env)) \
2604 #define SCM_XEVAL(x, env) \
2607 : (SCM_VARIABLEP (x) \
2608 ? SCM_VARIABLE_REF (x) \
2610 ? (scm_debug_mode_p \
2611 ? deval ((x), (env)) \
2612 : ceval ((x), (env))) \
2615 #define SCM_XEVALCAR(x, env) \
2616 (SCM_IMP (SCM_CAR (x)) \
2617 ? SCM_EVALIM (SCM_CAR (x), (env)) \
2618 : (SCM_VARIABLEP (SCM_CAR (x)) \
2619 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2620 : (SCM_CONSP (SCM_CAR (x)) \
2621 ? (scm_debug_mode_p \
2622 ? deval (SCM_CAR (x), (env)) \
2623 : ceval (SCM_CAR (x), (env))) \
2624 : (!SCM_SYMBOLP (SCM_CAR (x)) \
2626 : *scm_lookupcar ((x), (env), 1)))))
2628 #define EVAL(x, env) \
2630 ? SCM_EVALIM ((x), (env)) \
2631 : (SCM_VARIABLEP (x) \
2632 ? SCM_VARIABLE_REF (x) \
2634 ? CEVAL ((x), (env)) \
2637 #define EVALCAR(x, env) \
2638 (SCM_IMP (SCM_CAR (x)) \
2639 ? SCM_EVALIM (SCM_CAR (x), (env)) \
2640 : (SCM_VARIABLEP (SCM_CAR (x)) \
2641 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2642 : (SCM_CONSP (SCM_CAR (x)) \
2643 ? CEVAL (SCM_CAR (x), (env)) \
2644 : (!SCM_SYMBOLP (SCM_CAR (x)) \
2646 : *scm_lookupcar ((x), (env), 1)))))
2648 SCM_REC_MUTEX (source_mutex
);
2651 /* Lookup a given local variable in an environment. The local variable is
2652 * given as an iloc, that is a triple <frame, binding, last?>, where frame
2653 * indicates the relative number of the environment frame (counting upwards
2654 * from the innermost environment frame), binding indicates the number of the
2655 * binding within the frame, and last? (which is extracted from the iloc using
2656 * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
2657 * very end of the improper list of bindings. */
2659 scm_ilookup (SCM iloc
, SCM env
)
2661 unsigned int frame_nr
= SCM_IFRAME (iloc
);
2662 unsigned int binding_nr
= SCM_IDIST (iloc
);
2666 for (; 0 != frame_nr
; --frame_nr
)
2667 frames
= SCM_CDR (frames
);
2669 bindings
= SCM_CAR (frames
);
2670 for (; 0 != binding_nr
; --binding_nr
)
2671 bindings
= SCM_CDR (bindings
);
2673 if (SCM_ICDRP (iloc
))
2674 return SCM_CDRLOC (bindings
);
2675 return SCM_CARLOC (SCM_CDR (bindings
));
2679 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
2681 static void error_unbound_variable (SCM symbol
) SCM_NORETURN
;
2683 error_unbound_variable (SCM symbol
)
2685 scm_error (scm_unbound_variable_key
, NULL
,
2686 "Unbound variable: ~S",
2687 scm_list_1 (symbol
), SCM_BOOL_F
);
2691 /* The Lookup Car Race
2694 Memoization of variables and special forms is done while executing
2695 the code for the first time. As long as there is only one thread
2696 everything is fine, but as soon as two threads execute the same
2697 code concurrently `for the first time' they can come into conflict.
2699 This memoization includes rewriting variable references into more
2700 efficient forms and expanding macros. Furthermore, macro expansion
2701 includes `compiling' special forms like `let', `cond', etc. into
2702 tree-code instructions.
2704 There shouldn't normally be a problem with memoizing local and
2705 global variable references (into ilocs and variables), because all
2706 threads will mutate the code in *exactly* the same way and (if I
2707 read the C code correctly) it is not possible to observe a half-way
2708 mutated cons cell. The lookup procedure can handle this
2709 transparently without any critical sections.
2711 It is different with macro expansion, because macro expansion
2712 happens outside of the lookup procedure and can't be
2713 undone. Therefore the lookup procedure can't cope with it. It has
2714 to indicate failure when it detects a lost race and hope that the
2715 caller can handle it. Luckily, it turns out that this is the case.
2717 An example to illustrate this: Suppose that the following form will
2718 be memoized concurrently by two threads
2722 Let's first examine the lookup of X in the body. The first thread
2723 decides that it has to find the symbol "x" in the environment and
2724 starts to scan it. Then the other thread takes over and actually
2725 overtakes the first. It looks up "x" and substitutes an
2726 appropriate iloc for it. Now the first thread continues and
2727 completes its lookup. It comes to exactly the same conclusions as
2728 the second one and could - without much ado - just overwrite the
2729 iloc with the same iloc.
2731 But let's see what will happen when the race occurs while looking
2732 up the symbol "let" at the start of the form. It could happen that
2733 the second thread interrupts the lookup of the first thread and not
2734 only substitutes a variable for it but goes right ahead and
2735 replaces it with the compiled form (#@let* (x 12) x). Now, when
2736 the first thread completes its lookup, it would replace the #@let*
2737 with a variable containing the "let" binding, effectively reverting
2738 the form to (let (x 12) x). This is wrong. It has to detect that
2739 it has lost the race and the evaluator has to reconsider the
2740 changed form completely.
2742 This race condition could be resolved with some kind of traffic
2743 light (like mutexes) around scm_lookupcar, but I think that it is
2744 best to avoid them in this case. They would serialize memoization
2745 completely and because lookup involves calling arbitrary Scheme
2746 code (via the lookup-thunk), threads could be blocked for an
2747 arbitrary amount of time or even deadlock. But with the current
2748 solution a lot of unnecessary work is potentially done. */
2750 /* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
2751 return NULL to indicate a failed lookup due to some race conditions
2752 between threads. This only happens when VLOC is the first cell of
2753 a special form that will eventually be memoized (like `let', etc.)
2754 In that case the whole lookup is bogus and the caller has to
2755 reconsider the complete special form.
2757 SCM_LOOKUPCAR is still there, of course. It just calls
2758 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
2759 should only be called when it is known that VLOC is not the first
2760 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
2761 for NULL. I think I've found the only places where this
2765 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
2768 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
2769 register SCM iloc
= SCM_ILOC00
;
2770 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
2772 if (!SCM_CONSP (SCM_CAR (env
)))
2774 al
= SCM_CARLOC (env
);
2775 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
2777 if (!SCM_CONSP (fl
))
2779 if (SCM_EQ_P (fl
, var
))
2781 if (! SCM_EQ_P (SCM_CAR (vloc
), var
))
2783 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
2784 return SCM_CDRLOC (*al
);
2789 al
= SCM_CDRLOC (*al
);
2790 if (SCM_EQ_P (SCM_CAR (fl
), var
))
2792 if (SCM_UNBNDP (SCM_CAR (*al
)))
2797 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
2799 SCM_SETCAR (vloc
, iloc
);
2800 return SCM_CARLOC (*al
);
2802 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
2804 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
2807 SCM top_thunk
, real_var
;
2810 top_thunk
= SCM_CAR (env
); /* env now refers to a
2811 top level env thunk */
2812 env
= SCM_CDR (env
);
2815 top_thunk
= SCM_BOOL_F
;
2816 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
2817 if (scm_is_false (real_var
))
2820 if (!SCM_NULLP (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
2825 if (SCM_NULLP (env
))
2826 error_unbound_variable (var
);
2828 scm_misc_error (NULL
, "Damaged environment: ~S",
2833 /* A variable could not be found, but we shall
2834 not throw an error. */
2835 static SCM undef_object
= SCM_UNDEFINED
;
2836 return &undef_object
;
2840 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
2842 /* Some other thread has changed the very cell we are working
2843 on. In effect, it must have done our job or messed it up
2846 var
= SCM_CAR (vloc
);
2847 if (SCM_VARIABLEP (var
))
2848 return SCM_VARIABLE_LOC (var
);
2849 if (SCM_ILOCP (var
))
2850 return scm_ilookup (var
, genv
);
2851 /* We can't cope with anything else than variables and ilocs. When
2852 a special form has been memoized (i.e. `let' into `#@let') we
2853 return NULL and expect the calling function to do the right
2854 thing. For the evaluator, this means going back and redoing
2855 the dispatch on the car of the form. */
2859 SCM_SETCAR (vloc
, real_var
);
2860 return SCM_VARIABLE_LOC (real_var
);
2865 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
2867 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
2874 /* During execution, look up a symbol in the top level of the given local
2875 * environment and return the corresponding variable object. If no binding
2876 * for the symbol can be found, an 'Unbound variable' error is signalled. */
2878 lazy_memoize_variable (const SCM symbol
, const SCM environment
)
2880 const SCM top_level
= scm_env_top_level (environment
);
2881 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
2883 if (scm_is_false (variable
))
2884 error_unbound_variable (symbol
);
2891 scm_eval_car (SCM pair
, SCM env
)
2893 return SCM_XEVALCAR (pair
, env
);
2898 scm_eval_args (SCM l
, SCM env
, SCM proc
)
2900 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
2901 while (SCM_CONSP (l
))
2903 res
= EVALCAR (l
, env
);
2905 *lloc
= scm_list_1 (res
);
2906 lloc
= SCM_CDRLOC (*lloc
);
2910 scm_wrong_num_args (proc
);
2916 scm_eval_body (SCM code
, SCM env
)
2921 next
= SCM_CDR (code
);
2922 while (!SCM_NULLP (next
))
2924 if (SCM_IMP (SCM_CAR (code
)))
2926 if (SCM_ISYMP (SCM_CAR (code
)))
2928 scm_rec_mutex_lock (&source_mutex
);
2929 /* check for race condition */
2930 if (SCM_ISYMP (SCM_CAR (code
)))
2931 m_expand_body (code
, env
);
2932 scm_rec_mutex_unlock (&source_mutex
);
2937 SCM_XEVAL (SCM_CAR (code
), env
);
2939 next
= SCM_CDR (code
);
2941 return SCM_XEVALCAR (code
, env
);
2947 /* SECTION: This code is specific for the debugging support. One
2948 * branch is read when DEVAL isn't defined, the other when DEVAL is
2954 #define SCM_APPLY scm_apply
2955 #define PREP_APPLY(proc, args)
2957 #define RETURN(x) do { return x; } while (0)
2958 #ifdef STACK_CHECKING
2959 #ifndef NO_CEVAL_STACK_CHECKING
2960 #define EVAL_STACK_CHECKING
2967 #define CEVAL deval /* Substitute all uses of ceval */
2970 #define SCM_APPLY scm_dapply
2973 #define PREP_APPLY(p, l) \
2974 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
2977 #define ENTER_APPLY \
2979 SCM_SET_ARGSREADY (debug);\
2980 if (scm_check_apply_p && SCM_TRAPS_P)\
2981 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
2983 SCM tmp, tail = scm_from_bool(SCM_TRACED_FRAME_P (debug)); \
2984 SCM_SET_TRACED_FRAME (debug); \
2986 if (SCM_CHEAPTRAPS_P)\
2988 tmp = scm_make_debugobj (&debug);\
2989 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
2994 tmp = scm_make_continuation (&first);\
2996 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
3003 #define RETURN(e) do { proc = (e); goto exit; } while (0)
3005 #ifdef STACK_CHECKING
3006 #ifndef EVAL_STACK_CHECKING
3007 #define EVAL_STACK_CHECKING
3012 /* scm_last_debug_frame contains a pointer to the last debugging information
3013 * stack frame. It is accessed very often from the debugging evaluator, so it
3014 * should probably not be indirectly addressed. Better to save and restore it
3015 * from the current root at any stack swaps.
3018 /* scm_debug_eframe_size is the number of slots available for pseudo
3019 * stack frames at each real stack frame.
3022 long scm_debug_eframe_size
;
3024 int scm_debug_mode_p
;
3025 int scm_check_entry_p
;
3026 int scm_check_apply_p
;
3027 int scm_check_exit_p
;
3029 long scm_eval_stack
;
3031 scm_t_option scm_eval_opts
[] = {
3032 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
3035 scm_t_option scm_debug_opts
[] = {
3036 { SCM_OPTION_BOOLEAN
, "cheap", 1,
3037 "*Flyweight representation of the stack at traps." },
3038 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
3039 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
3040 { SCM_OPTION_BOOLEAN
, "procnames", 1,
3041 "Record procedure names at definition." },
3042 { SCM_OPTION_BOOLEAN
, "backwards", 0,
3043 "Display backtrace in anti-chronological order." },
3044 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
3045 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
3046 { SCM_OPTION_INTEGER
, "frames", 3,
3047 "Maximum number of tail-recursive frames in backtrace." },
3048 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
3049 "Maximal number of stored backtrace frames." },
3050 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
3051 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
3052 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
3053 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
3054 { 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."}
3057 scm_t_option scm_evaluator_trap_table
[] = {
3058 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
3059 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
3060 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
3061 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
3062 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
3063 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
3064 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
3067 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
3069 "Option interface for the evaluation options. Instead of using\n"
3070 "this procedure directly, use the procedures @code{eval-enable},\n"
3071 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
3072 #define FUNC_NAME s_scm_eval_options_interface
3076 ans
= scm_options (setting
,
3080 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
3087 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
3089 "Option interface for the evaluator trap options.")
3090 #define FUNC_NAME s_scm_evaluator_traps
3094 ans
= scm_options (setting
,
3095 scm_evaluator_trap_table
,
3096 SCM_N_EVALUATOR_TRAPS
,
3098 SCM_RESET_DEBUG_MODE
;
3106 deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
3108 SCM
*results
= lloc
;
3109 while (SCM_CONSP (l
))
3111 const SCM res
= EVALCAR (l
, env
);
3113 *lloc
= scm_list_1 (res
);
3114 lloc
= SCM_CDRLOC (*lloc
);
3118 scm_wrong_num_args (proc
);
3125 /* SECTION: This code is compiled twice.
3129 /* Update the toplevel environment frame ENV so that it refers to the
3130 * current module. */
3131 #define UPDATE_TOPLEVEL_ENV(env) \
3133 SCM p = scm_current_module_lookup_closure (); \
3134 if (p != SCM_CAR (env)) \
3135 env = scm_top_level_env (p); \
3139 #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
3140 ASSERT_SYNTAX (!SCM_EQ_P ((x), SCM_EOL), s_empty_combination, x)
3143 /* This is the evaluator. Like any real monster, it has three heads:
3145 * ceval is the non-debugging evaluator, deval is the debugging version. Both
3146 * are implemented using a common code base, using the following mechanism:
3147 * CEVAL is a macro, which is either defined to ceval or deval. Thus, there
3148 * is no function CEVAL, but the code for CEVAL actually compiles to either
3149 * ceval or deval. When CEVAL is defined to ceval, it is known that the macro
3150 * DEVAL is not defined. When CEVAL is defined to deval, then the macro DEVAL
3151 * is known to be defined. Thus, in CEVAL parts for the debugging evaluator
3152 * are enclosed within #ifdef DEVAL ... #endif.
3154 * All three (ceval, deval and their common implementation CEVAL) take two
3155 * input parameters, x and env: x is a single expression to be evalutated.
3156 * env is the environment in which bindings are searched.
3158 * x is known to be a pair. Since x is a single expression, it is necessarily
3159 * in a tail position. If x is just a call to another function like in the
3160 * expression (foo exp1 exp2 ...), the realization of that call therefore
3161 * _must_not_ increase stack usage (the evaluation of exp1, exp2 etc.,
3162 * however, may do so). This is realized by making extensive use of 'goto'
3163 * statements within the evaluator: The gotos replace recursive calls to
3164 * CEVAL, thus re-using the same stack frame that CEVAL was already using.
3165 * If, however, x represents some form that requires to evaluate a sequence of
3166 * expressions like (begin exp1 exp2 ...), then recursive calls to CEVAL are
3167 * performed for all but the last expression of that sequence. */
3170 CEVAL (SCM x
, SCM env
)
3174 scm_t_debug_frame debug
;
3175 scm_t_debug_info
*debug_info_end
;
3176 debug
.prev
= scm_last_debug_frame
;
3179 * The debug.vect contains twice as much scm_t_debug_info frames as the
3180 * user has specified with (debug-set! frames <n>).
3182 * Even frames are eval frames, odd frames are apply frames.
3184 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
3185 * sizeof (scm_t_debug_info
));
3186 debug
.info
= debug
.vect
;
3187 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
3188 scm_last_debug_frame
= &debug
;
3190 #ifdef EVAL_STACK_CHECKING
3191 if (scm_stack_checking_enabled_p
&& SCM_STACK_OVERFLOW_P (&proc
))
3194 debug
.info
->e
.exp
= x
;
3195 debug
.info
->e
.env
= env
;
3197 scm_report_stack_overflow ();
3207 SCM_CLEAR_ARGSREADY (debug
);
3208 if (SCM_OVERFLOWP (debug
))
3211 * In theory, this should be the only place where it is necessary to
3212 * check for space in debug.vect since both eval frames and
3213 * available space are even.
3215 * For this to be the case, however, it is necessary that primitive
3216 * special forms which jump back to `loop', `begin' or some similar
3217 * label call PREP_APPLY.
3219 else if (++debug
.info
>= debug_info_end
)
3221 SCM_SET_OVERFLOW (debug
);
3226 debug
.info
->e
.exp
= x
;
3227 debug
.info
->e
.env
= env
;
3228 if (scm_check_entry_p
&& SCM_TRAPS_P
)
3230 if (SCM_ENTER_FRAME_P
3231 || (SCM_BREAKPOINTS_P
&& scm_c_source_property_breakpoint_p (x
)))
3234 SCM tail
= scm_from_bool (SCM_TAILRECP (debug
));
3235 SCM_SET_TAILREC (debug
);
3236 if (SCM_CHEAPTRAPS_P
)
3237 stackrep
= scm_make_debugobj (&debug
);
3241 SCM val
= scm_make_continuation (&first
);
3251 /* This gives the possibility for the debugger to
3252 modify the source expression before evaluation. */
3257 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
3258 scm_sym_enter_frame
,
3261 unmemoize_expression (x
, env
));
3268 if (SCM_ISYMP (SCM_CAR (x
)))
3270 switch (ISYMNUM (SCM_CAR (x
)))
3272 case (ISYMNUM (SCM_IM_AND
)):
3274 while (!SCM_NULLP (SCM_CDR (x
)))
3276 SCM test_result
= EVALCAR (x
, env
);
3277 if (scm_is_false (test_result
) || SCM_NILP (test_result
))
3278 RETURN (SCM_BOOL_F
);
3282 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3285 case (ISYMNUM (SCM_IM_BEGIN
)):
3288 RETURN (SCM_UNSPECIFIED
);
3290 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3293 /* If we are on toplevel with a lookup closure, we need to sync
3294 with the current module. */
3295 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
3297 UPDATE_TOPLEVEL_ENV (env
);
3298 while (!SCM_NULLP (SCM_CDR (x
)))
3301 UPDATE_TOPLEVEL_ENV (env
);
3307 goto nontoplevel_begin
;
3310 while (!SCM_NULLP (SCM_CDR (x
)))
3312 const SCM form
= SCM_CAR (x
);
3315 if (SCM_ISYMP (form
))
3317 scm_rec_mutex_lock (&source_mutex
);
3318 /* check for race condition */
3319 if (SCM_ISYMP (SCM_CAR (x
)))
3320 m_expand_body (x
, env
);
3321 scm_rec_mutex_unlock (&source_mutex
);
3322 goto nontoplevel_begin
;
3325 SCM_VALIDATE_NON_EMPTY_COMBINATION (form
);
3328 (void) EVAL (form
, env
);
3334 /* scm_eval last form in list */
3335 const SCM last_form
= SCM_CAR (x
);
3337 if (SCM_CONSP (last_form
))
3339 /* This is by far the most frequent case. */
3341 goto loop
; /* tail recurse */
3343 else if (SCM_IMP (last_form
))
3344 RETURN (SCM_EVALIM (last_form
, env
));
3345 else if (SCM_VARIABLEP (last_form
))
3346 RETURN (SCM_VARIABLE_REF (last_form
));
3347 else if (SCM_SYMBOLP (last_form
))
3348 RETURN (*scm_lookupcar (x
, env
, 1));
3354 case (ISYMNUM (SCM_IM_CASE
)):
3357 const SCM key
= EVALCAR (x
, env
);
3359 while (!SCM_NULLP (x
))
3361 const SCM clause
= SCM_CAR (x
);
3362 SCM labels
= SCM_CAR (clause
);
3363 if (SCM_EQ_P (labels
, SCM_IM_ELSE
))
3365 x
= SCM_CDR (clause
);
3366 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3369 while (!SCM_NULLP (labels
))
3371 const SCM label
= SCM_CAR (labels
);
3372 if (SCM_EQ_P (label
, key
)
3373 || scm_is_true (scm_eqv_p (label
, key
)))
3375 x
= SCM_CDR (clause
);
3376 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3379 labels
= SCM_CDR (labels
);
3384 RETURN (SCM_UNSPECIFIED
);
3387 case (ISYMNUM (SCM_IM_COND
)):
3389 while (!SCM_NULLP (x
))
3391 const SCM clause
= SCM_CAR (x
);
3392 if (SCM_EQ_P (SCM_CAR (clause
), SCM_IM_ELSE
))
3394 x
= SCM_CDR (clause
);
3395 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3400 arg1
= EVALCAR (clause
, env
);
3401 if (scm_is_true (arg1
) && !SCM_NILP (arg1
))
3403 x
= SCM_CDR (clause
);
3406 else if (!SCM_EQ_P (SCM_CAR (x
), SCM_IM_ARROW
))
3408 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3414 proc
= EVALCAR (proc
, env
);
3415 PREP_APPLY (proc
, scm_list_1 (arg1
));
3423 RETURN (SCM_UNSPECIFIED
);
3426 case (ISYMNUM (SCM_IM_DO
)):
3429 /* Compute the initialization values and the initial environment. */
3430 SCM init_forms
= SCM_CAR (x
);
3431 SCM init_values
= SCM_EOL
;
3432 while (!SCM_NULLP (init_forms
))
3434 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3435 init_forms
= SCM_CDR (init_forms
);
3438 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
3442 SCM test_form
= SCM_CAR (x
);
3443 SCM body_forms
= SCM_CADR (x
);
3444 SCM step_forms
= SCM_CDDR (x
);
3446 SCM test_result
= EVALCAR (test_form
, env
);
3448 while (scm_is_false (test_result
) || SCM_NILP (test_result
))
3451 /* Evaluate body forms. */
3453 for (temp_forms
= body_forms
;
3454 !SCM_NULLP (temp_forms
);
3455 temp_forms
= SCM_CDR (temp_forms
))
3457 SCM form
= SCM_CAR (temp_forms
);
3458 /* Dirk:FIXME: We only need to eval forms that may have
3459 * a side effect here. This is only true for forms that
3460 * start with a pair. All others are just constants.
3461 * Since with the current memoizer 'form' may hold a
3462 * constant, we call EVAL here to handle the constant
3463 * cases. In the long run it would make sense to have
3464 * the macro transformer of 'do' eliminate all forms
3465 * that have no sideeffect. Then instead of EVAL we
3466 * could call CEVAL directly here. */
3467 (void) EVAL (form
, env
);
3472 /* Evaluate the step expressions. */
3474 SCM step_values
= SCM_EOL
;
3475 for (temp_forms
= step_forms
;
3476 !SCM_NULLP (temp_forms
);
3477 temp_forms
= SCM_CDR (temp_forms
))
3479 const SCM value
= EVALCAR (temp_forms
, env
);
3480 step_values
= scm_cons (value
, step_values
);
3482 env
= SCM_EXTEND_ENV (SCM_CAAR (env
),
3487 test_result
= EVALCAR (test_form
, env
);
3492 RETURN (SCM_UNSPECIFIED
);
3493 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3494 goto nontoplevel_begin
;
3497 case (ISYMNUM (SCM_IM_IF
)):
3500 SCM test_result
= EVALCAR (x
, env
);
3501 x
= SCM_CDR (x
); /* then expression */
3502 if (scm_is_false (test_result
) || SCM_NILP (test_result
))
3504 x
= SCM_CDR (x
); /* else expression */
3506 RETURN (SCM_UNSPECIFIED
);
3509 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3513 case (ISYMNUM (SCM_IM_LET
)):
3516 SCM init_forms
= SCM_CADR (x
);
3517 SCM init_values
= SCM_EOL
;
3520 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3521 init_forms
= SCM_CDR (init_forms
);
3523 while (!SCM_NULLP (init_forms
));
3524 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
3527 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3528 goto nontoplevel_begin
;
3531 case (ISYMNUM (SCM_IM_LETREC
)):
3533 env
= SCM_EXTEND_ENV (SCM_CAR (x
), undefineds
, env
);
3536 SCM init_forms
= SCM_CAR (x
);
3537 SCM init_values
= SCM_EOL
;
3540 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3541 init_forms
= SCM_CDR (init_forms
);
3543 while (!SCM_NULLP (init_forms
));
3544 SCM_SETCDR (SCM_CAR (env
), init_values
);
3547 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3548 goto nontoplevel_begin
;
3551 case (ISYMNUM (SCM_IM_LETSTAR
)):
3554 SCM bindings
= SCM_CAR (x
);
3555 if (!SCM_NULLP (bindings
))
3559 SCM name
= SCM_CAR (bindings
);
3560 SCM init
= SCM_CDR (bindings
);
3561 env
= SCM_EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
3562 bindings
= SCM_CDR (init
);
3564 while (!SCM_NULLP (bindings
));
3568 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3569 goto nontoplevel_begin
;
3572 case (ISYMNUM (SCM_IM_OR
)):
3574 while (!SCM_NULLP (SCM_CDR (x
)))
3576 SCM val
= EVALCAR (x
, env
);
3577 if (scm_is_true (val
) && !SCM_NILP (val
))
3582 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3586 case (ISYMNUM (SCM_IM_LAMBDA
)):
3587 RETURN (scm_closure (SCM_CDR (x
), env
));
3590 case (ISYMNUM (SCM_IM_QUOTE
)):
3591 RETURN (SCM_CDR (x
));
3594 case (ISYMNUM (SCM_IM_SET_X
)):
3598 SCM variable
= SCM_CAR (x
);
3599 if (SCM_ILOCP (variable
))
3600 location
= scm_ilookup (variable
, env
);
3601 else if (SCM_VARIABLEP (variable
))
3602 location
= SCM_VARIABLE_LOC (variable
);
3605 /* (SCM_SYMBOLP (variable)) is known to be true */
3606 variable
= lazy_memoize_variable (variable
, env
);
3607 SCM_SETCAR (x
, variable
);
3608 location
= SCM_VARIABLE_LOC (variable
);
3611 *location
= EVALCAR (x
, env
);
3613 RETURN (SCM_UNSPECIFIED
);
3616 case (ISYMNUM (SCM_IM_APPLY
)):
3617 /* Evaluate the procedure to be applied. */
3619 proc
= EVALCAR (x
, env
);
3620 PREP_APPLY (proc
, SCM_EOL
);
3622 /* Evaluate the argument holding the list of arguments */
3624 arg1
= EVALCAR (x
, env
);
3627 /* Go here to tail-apply a procedure. PROC is the procedure and
3628 * ARG1 is the list of arguments. PREP_APPLY must have been called
3629 * before jumping to apply_proc. */
3630 if (SCM_CLOSUREP (proc
))
3632 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3634 debug
.info
->a
.args
= arg1
;
3636 if (scm_badargsp (formals
, arg1
))
3637 scm_wrong_num_args (proc
);
3639 /* Copy argument list */
3640 if (SCM_NULL_OR_NIL_P (arg1
))
3641 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
3644 SCM args
= scm_list_1 (SCM_CAR (arg1
));
3646 arg1
= SCM_CDR (arg1
);
3647 while (!SCM_NULL_OR_NIL_P (arg1
))
3649 SCM new_tail
= scm_list_1 (SCM_CAR (arg1
));
3650 SCM_SETCDR (tail
, new_tail
);
3652 arg1
= SCM_CDR (arg1
);
3654 env
= SCM_EXTEND_ENV (formals
, args
, SCM_ENV (proc
));
3657 x
= SCM_CLOSURE_BODY (proc
);
3658 goto nontoplevel_begin
;
3663 RETURN (SCM_APPLY (proc
, arg1
, SCM_EOL
));
3667 case (ISYMNUM (SCM_IM_CONT
)):
3670 SCM val
= scm_make_continuation (&first
);
3678 proc
= EVALCAR (proc
, env
);
3679 PREP_APPLY (proc
, scm_list_1 (arg1
));
3686 case (ISYMNUM (SCM_IM_DELAY
)):
3687 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
3690 case (ISYMNUM (SCM_IM_FUTURE
)):
3691 RETURN (scm_i_make_future (scm_closure (SCM_CDR (x
), env
)));
3694 /* PLACEHOLDER for case (ISYMNUM (SCM_IM_DISPATCH)): The following
3695 code (type_dispatch) is intended to be the tail of the case
3696 clause for the internal macro SCM_IM_DISPATCH. Please don't
3697 remove it from this location without discussing it with Mikael
3698 <djurfeldt@nada.kth.se> */
3700 /* The type dispatch code is duplicated below
3701 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
3702 * cuts down execution time for type dispatch to 50%. */
3703 type_dispatch
: /* inputs: x, arg1 */
3704 /* Type dispatch means to determine from the types of the function
3705 * arguments (i. e. the 'signature' of the call), which method from
3706 * a generic function is to be called. This process of selecting
3707 * the right method takes some time. To speed it up, guile uses
3708 * caching: Together with the macro call to dispatch the signatures
3709 * of some previous calls to that generic function from the same
3710 * place are stored (in the code!) in a cache that we call the
3711 * 'method cache'. This is done since it is likely, that
3712 * consecutive calls to dispatch from that position in the code will
3713 * have the same signature. Thus, the type dispatch works as
3714 * follows: First, determine a hash value from the signature of the
3715 * actual arguments. Second, use this hash value as an index to
3716 * find that same signature in the method cache stored at this
3717 * position in the code. If found, you have also found the
3718 * corresponding method that belongs to that signature. If the
3719 * signature is not found in the method cache, you have to perform a
3720 * full search over all signatures stored with the generic
3723 unsigned long int specializers
;
3724 unsigned long int hash_value
;
3725 unsigned long int cache_end_pos
;
3726 unsigned long int mask
;
3730 SCM z
= SCM_CDDR (x
);
3731 SCM tmp
= SCM_CADR (z
);
3732 specializers
= scm_to_ulong (SCM_CAR (z
));
3734 /* Compute a hash value for searching the method cache. There
3735 * are two variants for computing the hash value, a (rather)
3736 * complicated one, and a simple one. For the complicated one
3737 * explained below, tmp holds a number that is used in the
3739 if (SCM_VECTORP (tmp
))
3741 /* This method of determining the hash value is much
3742 * simpler: Set the hash value to zero and just perform a
3743 * linear search through the method cache. */
3745 mask
= (unsigned long int) ((long) -1);
3747 cache_end_pos
= SCM_VECTOR_LENGTH (method_cache
);
3751 /* Use the signature of the actual arguments to determine
3752 * the hash value. This is done as follows: Each class has
3753 * an array of random numbers, that are determined when the
3754 * class is created. The integer 'hashset' is an index into
3755 * that array of random numbers. Now, from all classes that
3756 * are part of the signature of the actual arguments, the
3757 * random numbers at index 'hashset' are taken and summed
3758 * up, giving the hash value. The value of 'hashset' is
3759 * stored at the call to dispatch. This allows to have
3760 * different 'formulas' for calculating the hash value at
3761 * different places where dispatch is called. This allows
3762 * to optimize the hash formula at every individual place
3763 * where dispatch is called, such that hopefully the hash
3764 * value that is computed will directly point to the right
3765 * method in the method cache. */
3766 unsigned long int hashset
= scm_to_ulong (tmp
);
3767 unsigned long int counter
= specializers
+ 1;
3770 while (!SCM_NULLP (tmp_arg
) && counter
!= 0)
3772 SCM
class = scm_class_of (SCM_CAR (tmp_arg
));
3773 hash_value
+= SCM_INSTANCE_HASH (class, hashset
);
3774 tmp_arg
= SCM_CDR (tmp_arg
);
3778 method_cache
= SCM_CADR (z
);
3779 mask
= scm_to_ulong (SCM_CAR (z
));
3781 cache_end_pos
= hash_value
;
3786 /* Search the method cache for a method with a matching
3787 * signature. Start the search at position 'hash_value'. The
3788 * hashing implementation uses linear probing for conflict
3789 * resolution, that is, if the signature in question is not
3790 * found at the starting index in the hash table, the next table
3791 * entry is tried, and so on, until in the worst case the whole
3792 * cache has been searched, but still the signature has not been
3797 SCM args
= arg1
; /* list of arguments */
3798 z
= SCM_VELTS (method_cache
)[hash_value
];
3799 while (!SCM_NULLP (args
))
3801 /* More arguments than specifiers => CLASS != ENV */
3802 SCM class_of_arg
= scm_class_of (SCM_CAR (args
));
3803 if (!SCM_EQ_P (class_of_arg
, SCM_CAR (z
)))
3805 args
= SCM_CDR (args
);
3808 /* Fewer arguments than specifiers => CAR != ENV */
3809 if (SCM_NULLP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
)))
3812 hash_value
= (hash_value
+ 1) & mask
;
3813 } while (hash_value
!= cache_end_pos
);
3815 /* No appropriate method was found in the cache. */
3816 z
= scm_memoize_method (x
, arg1
);
3818 apply_cmethod
: /* inputs: z, arg1 */
3820 SCM formals
= SCM_CMETHOD_FORMALS (z
);
3821 env
= SCM_EXTEND_ENV (formals
, arg1
, SCM_CMETHOD_ENV (z
));
3822 x
= SCM_CMETHOD_BODY (z
);
3823 goto nontoplevel_begin
;
3829 case (ISYMNUM (SCM_IM_SLOT_REF
)):
3832 SCM instance
= EVALCAR (x
, env
);
3833 unsigned long int slot
= SCM_I_INUM (SCM_CDR (x
));
3834 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance
) [slot
]));
3838 case (ISYMNUM (SCM_IM_SLOT_SET_X
)):
3841 SCM instance
= EVALCAR (x
, env
);
3842 unsigned long int slot
= SCM_I_INUM (SCM_CADR (x
));
3843 SCM value
= EVALCAR (SCM_CDDR (x
), env
);
3844 SCM_STRUCT_DATA (instance
) [slot
] = SCM_UNPACK (value
);
3845 RETURN (SCM_UNSPECIFIED
);
3849 #if SCM_ENABLE_ELISP
3851 case (ISYMNUM (SCM_IM_NIL_COND
)):
3853 SCM test_form
= SCM_CDR (x
);
3854 x
= SCM_CDR (test_form
);
3855 while (!SCM_NULL_OR_NIL_P (x
))
3857 SCM test_result
= EVALCAR (test_form
, env
);
3858 if (!(scm_is_false (test_result
)
3859 || SCM_NULL_OR_NIL_P (test_result
)))
3861 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
3862 RETURN (test_result
);
3863 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3868 test_form
= SCM_CDR (x
);
3869 x
= SCM_CDR (test_form
);
3873 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3877 #endif /* SCM_ENABLE_ELISP */
3879 case (ISYMNUM (SCM_IM_BIND
)):
3881 SCM vars
, exps
, vals
;
3884 vars
= SCM_CAAR (x
);
3885 exps
= SCM_CDAR (x
);
3887 while (!SCM_NULLP (exps
))
3889 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
3890 exps
= SCM_CDR (exps
);
3893 scm_swap_bindings (vars
, vals
);
3894 scm_dynwinds
= scm_acons (vars
, vals
, scm_dynwinds
);
3896 /* Ignore all but the last evaluation result. */
3897 for (x
= SCM_CDR (x
); !SCM_NULLP (SCM_CDR (x
)); x
= SCM_CDR (x
))
3899 if (SCM_CONSP (SCM_CAR (x
)))
3900 CEVAL (SCM_CAR (x
), env
);
3902 proc
= EVALCAR (x
, env
);
3904 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
3905 scm_swap_bindings (vars
, vals
);
3911 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
3916 producer
= EVALCAR (x
, env
);
3918 proc
= EVALCAR (x
, env
); /* proc is the consumer. */
3919 arg1
= SCM_APPLY (producer
, SCM_EOL
, SCM_EOL
);
3920 if (SCM_VALUESP (arg1
))
3922 /* The list of arguments is not copied. Rather, it is assumed
3923 * that this has been done by the 'values' procedure. */
3924 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
3928 arg1
= scm_list_1 (arg1
);
3930 PREP_APPLY (proc
, arg1
);
3941 if (SCM_VARIABLEP (SCM_CAR (x
)))
3942 proc
= SCM_VARIABLE_REF (SCM_CAR (x
));
3943 else if (SCM_ILOCP (SCM_CAR (x
)))
3944 proc
= *scm_ilookup (SCM_CAR (x
), env
);
3945 else if (SCM_CONSP (SCM_CAR (x
)))
3946 proc
= CEVAL (SCM_CAR (x
), env
);
3947 else if (SCM_SYMBOLP (SCM_CAR (x
)))
3949 SCM orig_sym
= SCM_CAR (x
);
3951 SCM
*location
= scm_lookupcar1 (x
, env
, 1);
3952 if (location
== NULL
)
3954 /* we have lost the race, start again. */
3960 if (SCM_MACROP (proc
))
3962 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
3964 handle_a_macro
: /* inputs: x, env, proc */
3966 /* Set a flag during macro expansion so that macro
3967 application frames can be deleted from the backtrace. */
3968 SCM_SET_MACROEXP (debug
);
3970 arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
3971 scm_cons (env
, scm_listofnull
));
3973 SCM_CLEAR_MACROEXP (debug
);
3975 switch (SCM_MACRO_TYPE (proc
))
3979 if (!SCM_CONSP (arg1
))
3980 arg1
= scm_list_2 (SCM_IM_BEGIN
, arg1
);
3982 assert (!SCM_EQ_P (x
, SCM_CAR (arg1
))
3983 && !SCM_EQ_P (x
, SCM_CDR (arg1
)));
3986 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
3989 SCM_SETCAR (x
, SCM_CAR (arg1
));
3990 SCM_SETCDR (x
, SCM_CDR (arg1
));
3994 /* Prevent memoizing of debug info expression. */
3995 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
4000 SCM_SETCAR (x
, SCM_CAR (arg1
));
4001 SCM_SETCDR (x
, SCM_CDR (arg1
));
4003 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
4005 #if SCM_ENABLE_DEPRECATED == 1
4010 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
4024 if (SCM_MACROP (proc
))
4025 goto handle_a_macro
;
4029 /* When reaching this part of the code, the following is granted: Variable x
4030 * holds the first pair of an expression of the form (<function> arg ...).
4031 * Variable proc holds the object that resulted from the evaluation of
4032 * <function>. In the following, the arguments (if any) will be evaluated,
4033 * and proc will be applied to them. If proc does not really hold a
4034 * function object, this will be signalled as an error on the scheme
4035 * level. If the number of arguments does not match the number of arguments
4036 * that are allowed to be passed to proc, also an error on the scheme level
4037 * will be signalled. */
4038 PREP_APPLY (proc
, SCM_EOL
);
4039 if (SCM_NULLP (SCM_CDR (x
))) {
4042 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4043 switch (SCM_TYP7 (proc
))
4044 { /* no arguments given */
4045 case scm_tc7_subr_0
:
4046 RETURN (SCM_SUBRF (proc
) ());
4047 case scm_tc7_subr_1o
:
4048 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
4050 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
4051 case scm_tc7_rpsubr
:
4052 RETURN (SCM_BOOL_T
);
4054 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
4056 if (!SCM_SMOB_APPLICABLE_P (proc
))
4058 RETURN (SCM_SMOB_APPLY_0 (proc
));
4061 proc
= SCM_CCLO_SUBR (proc
);
4063 debug
.info
->a
.proc
= proc
;
4064 debug
.info
->a
.args
= scm_list_1 (arg1
);
4068 proc
= SCM_PROCEDURE (proc
);
4070 debug
.info
->a
.proc
= proc
;
4072 if (!SCM_CLOSUREP (proc
))
4075 case scm_tcs_closures
:
4077 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4078 if (SCM_CONSP (formals
))
4080 x
= SCM_CLOSURE_BODY (proc
);
4081 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
4082 goto nontoplevel_begin
;
4084 case scm_tcs_struct
:
4085 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4087 x
= SCM_ENTITY_PROCEDURE (proc
);
4091 else if (SCM_I_OPERATORP (proc
))
4094 proc
= (SCM_I_ENTITYP (proc
)
4095 ? SCM_ENTITY_PROCEDURE (proc
)
4096 : SCM_OPERATOR_PROCEDURE (proc
));
4098 debug
.info
->a
.proc
= proc
;
4099 debug
.info
->a
.args
= scm_list_1 (arg1
);
4105 case scm_tc7_subr_1
:
4106 case scm_tc7_subr_2
:
4107 case scm_tc7_subr_2o
:
4110 case scm_tc7_subr_3
:
4111 case scm_tc7_lsubr_2
:
4113 scm_wrong_num_args (proc
);
4116 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
4120 /* must handle macros by here */
4123 arg1
= EVALCAR (x
, env
);
4125 scm_wrong_num_args (proc
);
4127 debug
.info
->a
.args
= scm_list_1 (arg1
);
4135 evap1
: /* inputs: proc, arg1 */
4136 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4137 switch (SCM_TYP7 (proc
))
4138 { /* have one argument in arg1 */
4139 case scm_tc7_subr_2o
:
4140 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4141 case scm_tc7_subr_1
:
4142 case scm_tc7_subr_1o
:
4143 RETURN (SCM_SUBRF (proc
) (arg1
));
4145 if (SCM_I_INUMP (arg1
))
4147 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
))));
4149 else if (SCM_REALP (arg1
))
4151 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4153 else if (SCM_BIGP (arg1
))
4155 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4157 else if (SCM_FRACTIONP (arg1
))
4159 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4161 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4162 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4165 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
4168 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
4169 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4170 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
4175 case scm_tc7_rpsubr
:
4176 RETURN (SCM_BOOL_T
);
4178 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4181 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4183 RETURN (SCM_SUBRF (proc
) (scm_list_1 (arg1
)));
4186 if (!SCM_SMOB_APPLICABLE_P (proc
))
4188 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
4192 proc
= SCM_CCLO_SUBR (proc
);
4194 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
4195 debug
.info
->a
.proc
= proc
;
4199 proc
= SCM_PROCEDURE (proc
);
4201 debug
.info
->a
.proc
= proc
;
4203 if (!SCM_CLOSUREP (proc
))
4206 case scm_tcs_closures
:
4209 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4210 if (SCM_NULLP (formals
)
4211 || (SCM_CONSP (formals
) && SCM_CONSP (SCM_CDR (formals
))))
4213 x
= SCM_CLOSURE_BODY (proc
);
4215 env
= SCM_EXTEND_ENV (formals
,
4219 env
= SCM_EXTEND_ENV (formals
,
4223 goto nontoplevel_begin
;
4225 case scm_tcs_struct
:
4226 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4228 x
= SCM_ENTITY_PROCEDURE (proc
);
4230 arg1
= debug
.info
->a
.args
;
4232 arg1
= scm_list_1 (arg1
);
4236 else if (SCM_I_OPERATORP (proc
))
4240 proc
= (SCM_I_ENTITYP (proc
)
4241 ? SCM_ENTITY_PROCEDURE (proc
)
4242 : SCM_OPERATOR_PROCEDURE (proc
));
4244 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
4245 debug
.info
->a
.proc
= proc
;
4251 case scm_tc7_subr_2
:
4252 case scm_tc7_subr_0
:
4253 case scm_tc7_subr_3
:
4254 case scm_tc7_lsubr_2
:
4255 scm_wrong_num_args (proc
);
4261 arg2
= EVALCAR (x
, env
);
4263 scm_wrong_num_args (proc
);
4265 { /* have two or more arguments */
4267 debug
.info
->a
.args
= scm_list_2 (arg1
, arg2
);
4270 if (SCM_NULLP (x
)) {
4273 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4274 switch (SCM_TYP7 (proc
))
4275 { /* have two arguments */
4276 case scm_tc7_subr_2
:
4277 case scm_tc7_subr_2o
:
4278 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
4281 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4283 RETURN (SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
)));
4285 case scm_tc7_lsubr_2
:
4286 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
));
4287 case scm_tc7_rpsubr
:
4289 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
4291 if (!SCM_SMOB_APPLICABLE_P (proc
))
4293 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
));
4297 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
4298 scm_cons (proc
, debug
.info
->a
.args
),
4301 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
4302 scm_cons2 (proc
, arg1
,
4309 case scm_tcs_struct
:
4310 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4312 x
= SCM_ENTITY_PROCEDURE (proc
);
4314 arg1
= debug
.info
->a
.args
;
4316 arg1
= scm_list_2 (arg1
, arg2
);
4320 else if (SCM_I_OPERATORP (proc
))
4324 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
4325 ? SCM_ENTITY_PROCEDURE (proc
)
4326 : SCM_OPERATOR_PROCEDURE (proc
),
4327 scm_cons (proc
, debug
.info
->a
.args
),
4330 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
4331 ? SCM_ENTITY_PROCEDURE (proc
)
4332 : SCM_OPERATOR_PROCEDURE (proc
),
4333 scm_cons2 (proc
, arg1
,
4343 case scm_tc7_subr_0
:
4346 case scm_tc7_subr_1o
:
4347 case scm_tc7_subr_1
:
4348 case scm_tc7_subr_3
:
4349 scm_wrong_num_args (proc
);
4353 proc
= SCM_PROCEDURE (proc
);
4355 debug
.info
->a
.proc
= proc
;
4357 if (!SCM_CLOSUREP (proc
))
4360 case scm_tcs_closures
:
4363 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4364 if (SCM_NULLP (formals
)
4365 || (SCM_CONSP (formals
)
4366 && (SCM_NULLP (SCM_CDR (formals
))
4367 || (SCM_CONSP (SCM_CDR (formals
))
4368 && SCM_CONSP (SCM_CDDR (formals
))))))
4371 env
= SCM_EXTEND_ENV (formals
,
4375 env
= SCM_EXTEND_ENV (formals
,
4376 scm_list_2 (arg1
, arg2
),
4379 x
= SCM_CLOSURE_BODY (proc
);
4380 goto nontoplevel_begin
;
4385 scm_wrong_num_args (proc
);
4387 debug
.info
->a
.args
= scm_cons2 (arg1
, arg2
,
4388 deval_args (x
, env
, proc
,
4389 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
4393 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4394 switch (SCM_TYP7 (proc
))
4395 { /* have 3 or more arguments */
4397 case scm_tc7_subr_3
:
4398 if (!SCM_NULLP (SCM_CDR (x
)))
4399 scm_wrong_num_args (proc
);
4401 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4402 SCM_CADDR (debug
.info
->a
.args
)));
4404 arg1
= SCM_SUBRF(proc
)(arg1
, arg2
);
4405 arg2
= SCM_CDDR (debug
.info
->a
.args
);
4408 arg1
= SCM_SUBRF(proc
)(arg1
, SCM_CAR (arg2
));
4409 arg2
= SCM_CDR (arg2
);
4411 while (SCM_NIMP (arg2
));
4413 case scm_tc7_rpsubr
:
4414 if (scm_is_false (SCM_SUBRF (proc
) (arg1
, arg2
)))
4415 RETURN (SCM_BOOL_F
);
4416 arg1
= SCM_CDDR (debug
.info
->a
.args
);
4419 if (scm_is_false (SCM_SUBRF (proc
) (arg2
, SCM_CAR (arg1
))))
4420 RETURN (SCM_BOOL_F
);
4421 arg2
= SCM_CAR (arg1
);
4422 arg1
= SCM_CDR (arg1
);
4424 while (SCM_NIMP (arg1
));
4425 RETURN (SCM_BOOL_T
);
4426 case scm_tc7_lsubr_2
:
4427 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4428 SCM_CDDR (debug
.info
->a
.args
)));
4430 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4432 if (!SCM_SMOB_APPLICABLE_P (proc
))
4434 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4435 SCM_CDDR (debug
.info
->a
.args
)));
4439 proc
= SCM_PROCEDURE (proc
);
4440 debug
.info
->a
.proc
= proc
;
4441 if (!SCM_CLOSUREP (proc
))
4444 case scm_tcs_closures
:
4446 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4447 if (SCM_NULLP (formals
)
4448 || (SCM_CONSP (formals
)
4449 && (SCM_NULLP (SCM_CDR (formals
))
4450 || (SCM_CONSP (SCM_CDR (formals
))
4451 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4453 SCM_SET_ARGSREADY (debug
);
4454 env
= SCM_EXTEND_ENV (formals
,
4457 x
= SCM_CLOSURE_BODY (proc
);
4458 goto nontoplevel_begin
;
4461 case scm_tc7_subr_3
:
4462 if (!SCM_NULLP (SCM_CDR (x
)))
4463 scm_wrong_num_args (proc
);
4465 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, EVALCAR (x
, env
)));
4467 arg1
= SCM_SUBRF (proc
) (arg1
, arg2
);
4470 arg1
= SCM_SUBRF(proc
)(arg1
, EVALCAR(x
, env
));
4473 while (!SCM_NULLP (x
));
4475 case scm_tc7_rpsubr
:
4476 if (scm_is_false (SCM_SUBRF (proc
) (arg1
, arg2
)))
4477 RETURN (SCM_BOOL_F
);
4480 arg1
= EVALCAR (x
, env
);
4481 if (scm_is_false (SCM_SUBRF (proc
) (arg2
, arg1
)))
4482 RETURN (SCM_BOOL_F
);
4486 while (!SCM_NULLP (x
));
4487 RETURN (SCM_BOOL_T
);
4488 case scm_tc7_lsubr_2
:
4489 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
4491 RETURN (SCM_SUBRF (proc
) (scm_cons2 (arg1
,
4493 scm_eval_args (x
, env
, proc
))));
4495 if (!SCM_SMOB_APPLICABLE_P (proc
))
4497 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4498 scm_eval_args (x
, env
, proc
)));
4502 proc
= SCM_PROCEDURE (proc
);
4503 if (!SCM_CLOSUREP (proc
))
4506 case scm_tcs_closures
:
4508 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4509 if (SCM_NULLP (formals
)
4510 || (SCM_CONSP (formals
)
4511 && (SCM_NULLP (SCM_CDR (formals
))
4512 || (SCM_CONSP (SCM_CDR (formals
))
4513 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4515 env
= SCM_EXTEND_ENV (formals
,
4518 scm_eval_args (x
, env
, proc
)),
4520 x
= SCM_CLOSURE_BODY (proc
);
4521 goto nontoplevel_begin
;
4524 case scm_tcs_struct
:
4525 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4528 arg1
= debug
.info
->a
.args
;
4530 arg1
= scm_cons2 (arg1
, arg2
, scm_eval_args (x
, env
, proc
));
4532 x
= SCM_ENTITY_PROCEDURE (proc
);
4535 else if (SCM_I_OPERATORP (proc
))
4539 case scm_tc7_subr_2
:
4540 case scm_tc7_subr_1o
:
4541 case scm_tc7_subr_2o
:
4542 case scm_tc7_subr_0
:
4545 case scm_tc7_subr_1
:
4546 scm_wrong_num_args (proc
);
4554 if (scm_check_exit_p
&& SCM_TRAPS_P
)
4555 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
4557 SCM_CLEAR_TRACED_FRAME (debug
);
4558 if (SCM_CHEAPTRAPS_P
)
4559 arg1
= scm_make_debugobj (&debug
);
4563 SCM val
= scm_make_continuation (&first
);
4574 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
4578 scm_last_debug_frame
= debug
.prev
;
4584 /* SECTION: This code is compiled once.
4591 /* Simple procedure calls
4595 scm_call_0 (SCM proc
)
4597 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
4601 scm_call_1 (SCM proc
, SCM arg1
)
4603 return scm_apply (proc
, arg1
, scm_listofnull
);
4607 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
4609 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
4613 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
4615 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
4619 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
4621 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
4622 scm_cons (arg4
, scm_listofnull
)));
4625 /* Simple procedure applies
4629 scm_apply_0 (SCM proc
, SCM args
)
4631 return scm_apply (proc
, args
, SCM_EOL
);
4635 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
4637 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
4641 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
4643 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
4647 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
4649 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
4653 /* This code processes the arguments to apply:
4655 (apply PROC ARG1 ... ARGS)
4657 Given a list (ARG1 ... ARGS), this function conses the ARG1
4658 ... arguments onto the front of ARGS, and returns the resulting
4659 list. Note that ARGS is a list; thus, the argument to this
4660 function is a list whose last element is a list.
4662 Apply calls this function, and applies PROC to the elements of the
4663 result. apply:nconc2last takes care of building the list of
4664 arguments, given (ARG1 ... ARGS).
4666 Rather than do new consing, apply:nconc2last destroys its argument.
4667 On that topic, this code came into my care with the following
4668 beautifully cryptic comment on that topic: "This will only screw
4669 you if you do (scm_apply scm_apply '( ... ))" If you know what
4670 they're referring to, send me a patch to this comment. */
4672 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
4674 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
4675 "conses the @var{arg1} @dots{} arguments onto the front of\n"
4676 "@var{args}, and returns the resulting list. Note that\n"
4677 "@var{args} is a list; thus, the argument to this function is\n"
4678 "a list whose last element is a list.\n"
4679 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
4680 "destroys its argument, so use with care.")
4681 #define FUNC_NAME s_scm_nconc2last
4684 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
4686 while (!SCM_NULLP (SCM_CDR (*lloc
))) /* Perhaps should be
4687 SCM_NULL_OR_NIL_P, but not
4688 needed in 99.99% of cases,
4689 and it could seriously hurt
4690 performance. - Neil */
4691 lloc
= SCM_CDRLOC (*lloc
);
4692 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
4693 *lloc
= SCM_CAR (*lloc
);
4701 /* SECTION: When DEVAL is defined this code yields scm_dapply.
4702 * It is compiled twice.
4707 scm_apply (SCM proc
, SCM arg1
, SCM args
)
4713 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
4718 /* Apply a function to a list of arguments.
4720 This function is exported to the Scheme level as taking two
4721 required arguments and a tail argument, as if it were:
4722 (lambda (proc arg1 . args) ...)
4723 Thus, if you just have a list of arguments to pass to a procedure,
4724 pass the list as ARG1, and '() for ARGS. If you have some fixed
4725 args, pass the first as ARG1, then cons any remaining fixed args
4726 onto the front of your argument list, and pass that as ARGS. */
4729 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
4732 scm_t_debug_frame debug
;
4733 scm_t_debug_info debug_vect_body
;
4734 debug
.prev
= scm_last_debug_frame
;
4735 debug
.status
= SCM_APPLYFRAME
;
4736 debug
.vect
= &debug_vect_body
;
4737 debug
.vect
[0].a
.proc
= proc
;
4738 debug
.vect
[0].a
.args
= SCM_EOL
;
4739 scm_last_debug_frame
= &debug
;
4741 if (scm_debug_mode_p
)
4742 return scm_dapply (proc
, arg1
, args
);
4745 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
4747 /* If ARGS is the empty list, then we're calling apply with only two
4748 arguments --- ARG1 is the list of arguments for PROC. Whatever
4749 the case, futz with things so that ARG1 is the first argument to
4750 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
4753 Setting the debug apply frame args this way is pretty messy.
4754 Perhaps we should store arg1 and args directly in the frame as
4755 received, and let scm_frame_arguments unpack them, because that's
4756 a relatively rare operation. This works for now; if the Guile
4757 developer archives are still around, see Mikael's post of
4759 if (SCM_NULLP (args
))
4761 if (SCM_NULLP (arg1
))
4763 arg1
= SCM_UNDEFINED
;
4765 debug
.vect
[0].a
.args
= SCM_EOL
;
4771 debug
.vect
[0].a
.args
= arg1
;
4773 args
= SCM_CDR (arg1
);
4774 arg1
= SCM_CAR (arg1
);
4779 args
= scm_nconc2last (args
);
4781 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4785 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
4788 if (SCM_CHEAPTRAPS_P
)
4789 tmp
= scm_make_debugobj (&debug
);
4794 tmp
= scm_make_continuation (&first
);
4799 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
4806 switch (SCM_TYP7 (proc
))
4808 case scm_tc7_subr_2o
:
4809 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
4810 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4811 case scm_tc7_subr_2
:
4812 if (SCM_NULLP (args
) || !SCM_NULLP (SCM_CDR (args
)))
4813 scm_wrong_num_args (proc
);
4814 args
= SCM_CAR (args
);
4815 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4816 case scm_tc7_subr_0
:
4817 if (!SCM_UNBNDP (arg1
))
4818 scm_wrong_num_args (proc
);
4820 RETURN (SCM_SUBRF (proc
) ());
4821 case scm_tc7_subr_1
:
4822 if (SCM_UNBNDP (arg1
))
4823 scm_wrong_num_args (proc
);
4824 case scm_tc7_subr_1o
:
4825 if (!SCM_NULLP (args
))
4826 scm_wrong_num_args (proc
);
4828 RETURN (SCM_SUBRF (proc
) (arg1
));
4830 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
4831 scm_wrong_num_args (proc
);
4832 if (SCM_I_INUMP (arg1
))
4834 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
))));
4836 else if (SCM_REALP (arg1
))
4838 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4840 else if (SCM_BIGP (arg1
))
4842 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4844 else if (SCM_FRACTIONP (arg1
))
4846 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4848 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4849 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4851 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
4852 scm_wrong_num_args (proc
);
4854 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
4857 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
4858 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4859 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
4864 case scm_tc7_subr_3
:
4865 if (SCM_NULLP (args
)
4866 || SCM_NULLP (SCM_CDR (args
))
4867 || !SCM_NULLP (SCM_CDDR (args
)))
4868 scm_wrong_num_args (proc
);
4870 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
4873 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
4875 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
4877 case scm_tc7_lsubr_2
:
4878 if (!SCM_CONSP (args
))
4879 scm_wrong_num_args (proc
);
4881 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4883 if (SCM_NULLP (args
))
4884 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4885 while (SCM_NIMP (args
))
4887 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
4888 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
4889 args
= SCM_CDR (args
);
4892 case scm_tc7_rpsubr
:
4893 if (SCM_NULLP (args
))
4894 RETURN (SCM_BOOL_T
);
4895 while (SCM_NIMP (args
))
4897 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
4898 if (scm_is_false (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
4899 RETURN (SCM_BOOL_F
);
4900 arg1
= SCM_CAR (args
);
4901 args
= SCM_CDR (args
);
4903 RETURN (SCM_BOOL_T
);
4904 case scm_tcs_closures
:
4906 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4908 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4910 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
4911 scm_wrong_num_args (proc
);
4913 /* Copy argument list */
4918 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
4919 for (arg1
= SCM_CDR (arg1
); SCM_CONSP (arg1
); arg1
= SCM_CDR (arg1
))
4921 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
));
4924 SCM_SETCDR (tl
, arg1
);
4927 args
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4930 proc
= SCM_CLOSURE_BODY (proc
);
4932 arg1
= SCM_CDR (proc
);
4933 while (!SCM_NULLP (arg1
))
4935 if (SCM_IMP (SCM_CAR (proc
)))
4937 if (SCM_ISYMP (SCM_CAR (proc
)))
4939 scm_rec_mutex_lock (&source_mutex
);
4940 /* check for race condition */
4941 if (SCM_ISYMP (SCM_CAR (proc
)))
4942 m_expand_body (proc
, args
);
4943 scm_rec_mutex_unlock (&source_mutex
);
4947 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
4950 (void) EVAL (SCM_CAR (proc
), args
);
4952 arg1
= SCM_CDR (proc
);
4954 RETURN (EVALCAR (proc
, args
));
4956 if (!SCM_SMOB_APPLICABLE_P (proc
))
4958 if (SCM_UNBNDP (arg1
))
4959 RETURN (SCM_SMOB_APPLY_0 (proc
));
4960 else if (SCM_NULLP (args
))
4961 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
4962 else if (SCM_NULLP (SCM_CDR (args
)))
4963 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
4965 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4968 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4970 proc
= SCM_CCLO_SUBR (proc
);
4971 debug
.vect
[0].a
.proc
= proc
;
4972 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4974 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4976 proc
= SCM_CCLO_SUBR (proc
);
4980 proc
= SCM_PROCEDURE (proc
);
4982 debug
.vect
[0].a
.proc
= proc
;
4985 case scm_tcs_struct
:
4986 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4989 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4991 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4993 RETURN (scm_apply_generic (proc
, args
));
4995 else if (SCM_I_OPERATORP (proc
))
4999 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
5001 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
5004 proc
= (SCM_I_ENTITYP (proc
)
5005 ? SCM_ENTITY_PROCEDURE (proc
)
5006 : SCM_OPERATOR_PROCEDURE (proc
));
5008 debug
.vect
[0].a
.proc
= proc
;
5009 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
5011 if (SCM_NIMP (proc
))
5020 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
5024 if (scm_check_exit_p
&& SCM_TRAPS_P
)
5025 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
5027 SCM_CLEAR_TRACED_FRAME (debug
);
5028 if (SCM_CHEAPTRAPS_P
)
5029 arg1
= scm_make_debugobj (&debug
);
5033 SCM val
= scm_make_continuation (&first
);
5044 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
5048 scm_last_debug_frame
= debug
.prev
;
5054 /* SECTION: The rest of this file is only read once.
5061 * Trampolines make it possible to move procedure application dispatch
5062 * outside inner loops. The motivation was clean implementation of
5063 * efficient replacements of R5RS primitives in SRFI-1.
5065 * The semantics is clear: scm_trampoline_N returns an optimized
5066 * version of scm_call_N (or NULL if the procedure isn't applicable
5069 * Applying the optimization to map and for-each increased efficiency
5070 * noticeably. For example, (map abs ls) is now 8 times faster than
5075 call_subr0_0 (SCM proc
)
5077 return SCM_SUBRF (proc
) ();
5081 call_subr1o_0 (SCM proc
)
5083 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
5087 call_lsubr_0 (SCM proc
)
5089 return SCM_SUBRF (proc
) (SCM_EOL
);
5093 scm_i_call_closure_0 (SCM proc
)
5095 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
5098 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
5103 scm_trampoline_0 (SCM proc
)
5105 scm_t_trampoline_0 trampoline
;
5110 switch (SCM_TYP7 (proc
))
5112 case scm_tc7_subr_0
:
5113 trampoline
= call_subr0_0
;
5115 case scm_tc7_subr_1o
:
5116 trampoline
= call_subr1o_0
;
5119 trampoline
= call_lsubr_0
;
5121 case scm_tcs_closures
:
5123 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5124 if (SCM_NULLP (formals
) || !SCM_CONSP (formals
))
5125 trampoline
= scm_i_call_closure_0
;
5130 case scm_tcs_struct
:
5131 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5132 trampoline
= scm_call_generic_0
;
5133 else if (SCM_I_OPERATORP (proc
))
5134 trampoline
= scm_call_0
;
5139 if (SCM_SMOB_APPLICABLE_P (proc
))
5140 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
5145 case scm_tc7_rpsubr
:
5148 trampoline
= scm_call_0
;
5151 return NULL
; /* not applicable on zero arguments */
5153 /* We only reach this point if a valid trampoline was determined. */
5155 /* If debugging is enabled, we want to see all calls to proc on the stack.
5156 * Thus, we replace the trampoline shortcut with scm_call_0. */
5157 if (scm_debug_mode_p
)
5164 call_subr1_1 (SCM proc
, SCM arg1
)
5166 return SCM_SUBRF (proc
) (arg1
);
5170 call_subr2o_1 (SCM proc
, SCM arg1
)
5172 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
5176 call_lsubr_1 (SCM proc
, SCM arg1
)
5178 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
5182 call_dsubr_1 (SCM proc
, SCM arg1
)
5184 if (SCM_I_INUMP (arg1
))
5186 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
))));
5188 else if (SCM_REALP (arg1
))
5190 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
5192 else if (SCM_BIGP (arg1
))
5194 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
5196 else if (SCM_FRACTIONP (arg1
))
5198 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
5200 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
5201 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
5205 call_cxr_1 (SCM proc
, SCM arg1
)
5207 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
5210 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
5211 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
5212 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
5219 call_closure_1 (SCM proc
, SCM arg1
)
5221 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
5224 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
5229 scm_trampoline_1 (SCM proc
)
5231 scm_t_trampoline_1 trampoline
;
5236 switch (SCM_TYP7 (proc
))
5238 case scm_tc7_subr_1
:
5239 case scm_tc7_subr_1o
:
5240 trampoline
= call_subr1_1
;
5242 case scm_tc7_subr_2o
:
5243 trampoline
= call_subr2o_1
;
5246 trampoline
= call_lsubr_1
;
5249 trampoline
= call_dsubr_1
;
5252 trampoline
= call_cxr_1
;
5254 case scm_tcs_closures
:
5256 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5257 if (!SCM_NULLP (formals
)
5258 && (!SCM_CONSP (formals
) || !SCM_CONSP (SCM_CDR (formals
))))
5259 trampoline
= call_closure_1
;
5264 case scm_tcs_struct
:
5265 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5266 trampoline
= scm_call_generic_1
;
5267 else if (SCM_I_OPERATORP (proc
))
5268 trampoline
= scm_call_1
;
5273 if (SCM_SMOB_APPLICABLE_P (proc
))
5274 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
5279 case scm_tc7_rpsubr
:
5282 trampoline
= scm_call_1
;
5285 return NULL
; /* not applicable on one arg */
5287 /* We only reach this point if a valid trampoline was determined. */
5289 /* If debugging is enabled, we want to see all calls to proc on the stack.
5290 * Thus, we replace the trampoline shortcut with scm_call_1. */
5291 if (scm_debug_mode_p
)
5298 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
5300 return SCM_SUBRF (proc
) (arg1
, arg2
);
5304 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
5306 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
5310 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
5312 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
5316 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
5318 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
5319 scm_list_2 (arg1
, arg2
),
5321 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
5326 scm_trampoline_2 (SCM proc
)
5328 scm_t_trampoline_2 trampoline
;
5333 switch (SCM_TYP7 (proc
))
5335 case scm_tc7_subr_2
:
5336 case scm_tc7_subr_2o
:
5337 case scm_tc7_rpsubr
:
5339 trampoline
= call_subr2_2
;
5341 case scm_tc7_lsubr_2
:
5342 trampoline
= call_lsubr2_2
;
5345 trampoline
= call_lsubr_2
;
5347 case scm_tcs_closures
:
5349 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5350 if (!SCM_NULLP (formals
)
5351 && (!SCM_CONSP (formals
)
5352 || (!SCM_NULLP (SCM_CDR (formals
))
5353 && (!SCM_CONSP (SCM_CDR (formals
))
5354 || !SCM_CONSP (SCM_CDDR (formals
))))))
5355 trampoline
= call_closure_2
;
5360 case scm_tcs_struct
:
5361 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5362 trampoline
= scm_call_generic_2
;
5363 else if (SCM_I_OPERATORP (proc
))
5364 trampoline
= scm_call_2
;
5369 if (SCM_SMOB_APPLICABLE_P (proc
))
5370 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
5376 trampoline
= scm_call_2
;
5379 return NULL
; /* not applicable on two args */
5381 /* We only reach this point if a valid trampoline was determined. */
5383 /* If debugging is enabled, we want to see all calls to proc on the stack.
5384 * Thus, we replace the trampoline shortcut with scm_call_2. */
5385 if (scm_debug_mode_p
)
5391 /* Typechecking for multi-argument MAP and FOR-EACH.
5393 Verify that each element of the vector ARGV, except for the first,
5394 is a proper list whose length is LEN. Attribute errors to WHO,
5395 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
5397 check_map_args (SCM argv
,
5404 SCM
const *ve
= SCM_VELTS (argv
);
5407 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
5409 long elt_len
= scm_ilength (ve
[i
]);
5414 scm_apply_generic (gf
, scm_cons (proc
, args
));
5416 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
5420 scm_out_of_range_pos (who
, ve
[i
], scm_from_long (i
+ 2));
5423 scm_remember_upto_here_1 (argv
);
5427 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
5429 /* Note: Currently, scm_map applies PROC to the argument list(s)
5430 sequentially, starting with the first element(s). This is used in
5431 evalext.c where the Scheme procedure `map-in-order', which guarantees
5432 sequential behaviour, is implemented using scm_map. If the
5433 behaviour changes, we need to update `map-in-order'.
5437 scm_map (SCM proc
, SCM arg1
, SCM args
)
5438 #define FUNC_NAME s_map
5443 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
5445 len
= scm_ilength (arg1
);
5446 SCM_GASSERTn (len
>= 0,
5447 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
5448 SCM_VALIDATE_REST_ARGUMENT (args
);
5449 if (SCM_NULLP (args
))
5451 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5452 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
5453 while (SCM_NIMP (arg1
))
5455 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
5456 pres
= SCM_CDRLOC (*pres
);
5457 arg1
= SCM_CDR (arg1
);
5461 if (SCM_NULLP (SCM_CDR (args
)))
5463 SCM arg2
= SCM_CAR (args
);
5464 int len2
= scm_ilength (arg2
);
5465 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5467 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
5468 SCM_GASSERTn (len2
>= 0,
5469 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
5471 SCM_OUT_OF_RANGE (3, arg2
);
5472 while (SCM_NIMP (arg1
))
5474 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
5475 pres
= SCM_CDRLOC (*pres
);
5476 arg1
= SCM_CDR (arg1
);
5477 arg2
= SCM_CDR (arg2
);
5481 arg1
= scm_cons (arg1
, args
);
5482 args
= scm_vector (arg1
);
5483 ve
= SCM_VELTS (args
);
5484 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
5488 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5490 if (SCM_IMP (ve
[i
]))
5492 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
5493 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
5495 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
5496 pres
= SCM_CDRLOC (*pres
);
5502 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
5505 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
5506 #define FUNC_NAME s_for_each
5508 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
5510 len
= scm_ilength (arg1
);
5511 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
5512 SCM_ARG2
, s_for_each
);
5513 SCM_VALIDATE_REST_ARGUMENT (args
);
5514 if (SCM_NULLP (args
))
5516 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5517 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
5518 while (SCM_NIMP (arg1
))
5520 call (proc
, SCM_CAR (arg1
));
5521 arg1
= SCM_CDR (arg1
);
5523 return SCM_UNSPECIFIED
;
5525 if (SCM_NULLP (SCM_CDR (args
)))
5527 SCM arg2
= SCM_CAR (args
);
5528 int len2
= scm_ilength (arg2
);
5529 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5530 SCM_GASSERTn (call
, g_for_each
,
5531 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
5532 SCM_GASSERTn (len2
>= 0, g_for_each
,
5533 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
5535 SCM_OUT_OF_RANGE (3, arg2
);
5536 while (SCM_NIMP (arg1
))
5538 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
5539 arg1
= SCM_CDR (arg1
);
5540 arg2
= SCM_CDR (arg2
);
5542 return SCM_UNSPECIFIED
;
5544 arg1
= scm_cons (arg1
, args
);
5545 args
= scm_vector (arg1
);
5546 ve
= SCM_VELTS (args
);
5547 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
5551 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5553 if (SCM_IMP (ve
[i
]))
5554 return SCM_UNSPECIFIED
;
5555 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
5556 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
5558 scm_apply (proc
, arg1
, SCM_EOL
);
5565 scm_closure (SCM code
, SCM env
)
5568 SCM closcar
= scm_cons (code
, SCM_EOL
);
5569 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
5570 scm_remember_upto_here (closcar
);
5575 scm_t_bits scm_tc16_promise
;
5578 scm_makprom (SCM code
)
5580 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
5582 scm_make_rec_mutex ());
5586 promise_free (SCM promise
)
5588 scm_rec_mutex_free (SCM_PROMISE_MUTEX (promise
));
5593 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
5595 int writingp
= SCM_WRITINGP (pstate
);
5596 scm_puts ("#<promise ", port
);
5597 SCM_SET_WRITINGP (pstate
, 1);
5598 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
5599 SCM_SET_WRITINGP (pstate
, writingp
);
5600 scm_putc ('>', port
);
5604 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
5606 "If the promise @var{x} has not been computed yet, compute and\n"
5607 "return @var{x}, otherwise just return the previously computed\n"
5609 #define FUNC_NAME s_scm_force
5611 SCM_VALIDATE_SMOB (1, promise
, promise
);
5612 scm_rec_mutex_lock (SCM_PROMISE_MUTEX (promise
));
5613 if (!SCM_PROMISE_COMPUTED_P (promise
))
5615 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
5616 if (!SCM_PROMISE_COMPUTED_P (promise
))
5618 SCM_SET_PROMISE_DATA (promise
, ans
);
5619 SCM_SET_PROMISE_COMPUTED (promise
);
5622 scm_rec_mutex_unlock (SCM_PROMISE_MUTEX (promise
));
5623 return SCM_PROMISE_DATA (promise
);
5628 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
5630 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
5631 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
5632 #define FUNC_NAME s_scm_promise_p
5634 return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
5639 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
5640 (SCM xorig
, SCM x
, SCM y
),
5641 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
5642 "Any source properties associated with @var{xorig} are also associated\n"
5643 "with the new pair.")
5644 #define FUNC_NAME s_scm_cons_source
5647 z
= scm_cons (x
, y
);
5648 /* Copy source properties possibly associated with xorig. */
5649 p
= scm_whash_lookup (scm_source_whash
, xorig
);
5650 if (scm_is_true (p
))
5651 scm_whash_insert (scm_source_whash
, z
, p
);
5657 /* The function scm_copy_tree is used to copy an expression tree to allow the
5658 * memoizer to modify the expression during memoization. scm_copy_tree
5659 * creates deep copies of pairs and vectors, but not of any other data types,
5660 * since only pairs and vectors will be parsed by the memoizer.
5662 * To avoid infinite recursion due to cyclic structures, the hare-and-tortoise
5663 * pattern is used to detect cycles. In fact, the pattern is used in two
5664 * dimensions, vertical (indicated in the code by the variable names 'hare'
5665 * and 'tortoise') and horizontal ('rabbit' and 'turtle'). In both
5666 * dimensions, the hare/rabbit will take two steps when the tortoise/turtle
5669 * The vertical dimension corresponds to recursive calls to function
5670 * copy_tree: This happens when descending into vector elements, into cars of
5671 * lists and into the cdr of an improper list. In this dimension, the
5672 * tortoise follows the hare by using the processor stack: Every stack frame
5673 * will hold an instance of struct t_trace. These instances are connected in
5674 * a way that represents the trace of the hare, which thus can be followed by
5675 * the tortoise. The tortoise will always point to struct t_trace instances
5676 * relating to SCM objects that have already been copied. Thus, a cycle is
5677 * detected if the tortoise and the hare point to the same object,
5679 * The horizontal dimension is within one execution of copy_tree, when the
5680 * function cdr's along the pairs of a list. This is the standard
5681 * hare-and-tortoise implementation, found several times in guile. */
5684 struct t_trace
*trace
; // These pointers form a trace along the stack.
5685 SCM obj
; // The object handled at the respective stack frame.
5690 struct t_trace
*const hare
,
5691 struct t_trace
*tortoise
,
5692 unsigned int tortoise_delay
)
5694 if (!SCM_CONSP (hare
->obj
) && !SCM_VECTORP (hare
->obj
))
5700 /* Prepare the trace along the stack. */
5701 struct t_trace new_hare
;
5702 hare
->trace
= &new_hare
;
5704 /* The tortoise will make its step after the delay has elapsed. Note
5705 * that in contrast to the typical hare-and-tortoise pattern, the step
5706 * of the tortoise happens before the hare takes its steps. This is, in
5707 * principle, no problem, except for the start of the algorithm: Then,
5708 * it has to be made sure that the hare actually gets its advantage of
5710 if (tortoise_delay
== 0)
5713 tortoise
= tortoise
->trace
;
5714 ASSERT_SYNTAX (!SCM_EQ_P (hare
->obj
, tortoise
->obj
),
5715 s_bad_expression
, hare
->obj
);
5722 if (SCM_VECTORP (hare
->obj
))
5724 const unsigned long int length
= SCM_VECTOR_LENGTH (hare
->obj
);
5725 const SCM new_vector
= scm_c_make_vector (length
, SCM_UNSPECIFIED
);
5727 /* Each vector element is copied by recursing into copy_tree, having
5728 * the tortoise follow the hare into the depths of the stack. */
5729 unsigned long int i
;
5730 for (i
= 0; i
< length
; ++i
)
5733 new_hare
.obj
= SCM_VECTOR_REF (hare
->obj
, i
);
5734 new_element
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5735 SCM_VECTOR_SET (new_vector
, i
, new_element
);
5740 else // SCM_CONSP (hare->obj)
5745 SCM rabbit
= hare
->obj
;
5746 SCM turtle
= hare
->obj
;
5750 /* The first pair of the list is treated specially, in order to
5751 * preserve a potential source code position. */
5752 result
= tail
= scm_cons_source (rabbit
, SCM_EOL
, SCM_EOL
);
5753 new_hare
.obj
= SCM_CAR (rabbit
);
5754 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5755 SCM_SETCAR (tail
, copy
);
5757 /* The remaining pairs of the list are copied by, horizontally,
5758 * having the turtle follow the rabbit, and, vertically, having the
5759 * tortoise follow the hare into the depths of the stack. */
5760 rabbit
= SCM_CDR (rabbit
);
5761 while (SCM_CONSP (rabbit
))
5763 new_hare
.obj
= SCM_CAR (rabbit
);
5764 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5765 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
5766 tail
= SCM_CDR (tail
);
5768 rabbit
= SCM_CDR (rabbit
);
5769 if (SCM_CONSP (rabbit
))
5771 new_hare
.obj
= SCM_CAR (rabbit
);
5772 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5773 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
5774 tail
= SCM_CDR (tail
);
5775 rabbit
= SCM_CDR (rabbit
);
5777 turtle
= SCM_CDR (turtle
);
5778 ASSERT_SYNTAX (!SCM_EQ_P (rabbit
, turtle
),
5779 s_bad_expression
, rabbit
);
5783 /* We have to recurse into copy_tree again for the last cdr, in
5784 * order to handle the situation that it holds a vector. */
5785 new_hare
.obj
= rabbit
;
5786 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5787 SCM_SETCDR (tail
, copy
);
5794 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
5796 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
5797 "the new data structure. @code{copy-tree} recurses down the\n"
5798 "contents of both pairs and vectors (since both cons cells and vector\n"
5799 "cells may point to arbitrary objects), and stops recursing when it hits\n"
5800 "any other object.")
5801 #define FUNC_NAME s_scm_copy_tree
5803 /* Prepare the trace along the stack. */
5804 struct t_trace trace
;
5807 /* In function copy_tree, if the tortoise makes its step, it will do this
5808 * before the hare has the chance to move. Thus, we have to make sure that
5809 * the very first step of the tortoise will not happen after the hare has
5810 * really made two steps. This is achieved by passing '2' as the initial
5811 * delay for the tortoise. NOTE: Since cycles are unlikely, giving the hare
5812 * a bigger advantage may improve performance slightly. */
5813 return copy_tree (&trace
, &trace
, 2);
5818 /* We have three levels of EVAL here:
5820 - scm_i_eval (exp, env)
5822 evaluates EXP in environment ENV. ENV is a lexical environment
5823 structure as used by the actual tree code evaluator. When ENV is
5824 a top-level environment, then changes to the current module are
5825 tracked by updating ENV so that it continues to be in sync with
5828 - scm_primitive_eval (exp)
5830 evaluates EXP in the top-level environment as determined by the
5831 current module. This is done by constructing a suitable
5832 environment and calling scm_i_eval. Thus, changes to the
5833 top-level module are tracked normally.
5835 - scm_eval (exp, mod)
5837 evaluates EXP while MOD is the current module. This is done by
5838 setting the current module to MOD, invoking scm_primitive_eval on
5839 EXP, and then restoring the current module to the value it had
5840 previously. That is, while EXP is evaluated, changes to the
5841 current module are tracked, but these changes do not persist when
5844 For each level of evals, there are two variants, distinguished by a
5845 _x suffix: the ordinary variant does not modify EXP while the _x
5846 variant can destructively modify EXP into something completely
5847 unintelligible. A Scheme data structure passed as EXP to one of the
5848 _x variants should not ever be used again for anything. So when in
5849 doubt, use the ordinary variant.
5854 scm_i_eval_x (SCM exp
, SCM env
)
5856 if (SCM_SYMBOLP (exp
))
5857 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
5859 return SCM_XEVAL (exp
, env
);
5863 scm_i_eval (SCM exp
, SCM env
)
5865 exp
= scm_copy_tree (exp
);
5866 if (SCM_SYMBOLP (exp
))
5867 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
5869 return SCM_XEVAL (exp
, env
);
5873 scm_primitive_eval_x (SCM exp
)
5876 SCM transformer
= scm_current_module_transformer ();
5877 if (SCM_NIMP (transformer
))
5878 exp
= scm_call_1 (transformer
, exp
);
5879 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5880 return scm_i_eval_x (exp
, env
);
5883 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
5885 "Evaluate @var{exp} in the top-level environment specified by\n"
5886 "the current module.")
5887 #define FUNC_NAME s_scm_primitive_eval
5890 SCM transformer
= scm_current_module_transformer ();
5891 if (scm_is_true (transformer
))
5892 exp
= scm_call_1 (transformer
, exp
);
5893 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5894 return scm_i_eval (exp
, env
);
5899 /* Eval does not take the second arg optionally. This is intentional
5900 * in order to be R5RS compatible, and to prepare for the new module
5901 * system, where we would like to make the choice of evaluation
5902 * environment explicit. */
5905 change_environment (void *data
)
5907 SCM pair
= SCM_PACK (data
);
5908 SCM new_module
= SCM_CAR (pair
);
5909 SCM old_module
= scm_current_module ();
5910 SCM_SETCDR (pair
, old_module
);
5911 scm_set_current_module (new_module
);
5915 restore_environment (void *data
)
5917 SCM pair
= SCM_PACK (data
);
5918 SCM old_module
= SCM_CDR (pair
);
5919 SCM new_module
= scm_current_module ();
5920 SCM_SETCAR (pair
, new_module
);
5921 scm_set_current_module (old_module
);
5925 inner_eval_x (void *data
)
5927 return scm_primitive_eval_x (SCM_PACK(data
));
5931 scm_eval_x (SCM exp
, SCM module
)
5932 #define FUNC_NAME "eval!"
5934 SCM_VALIDATE_MODULE (2, module
);
5936 return scm_internal_dynamic_wind
5937 (change_environment
, inner_eval_x
, restore_environment
,
5938 (void *) SCM_UNPACK (exp
),
5939 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
5944 inner_eval (void *data
)
5946 return scm_primitive_eval (SCM_PACK(data
));
5949 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
5950 (SCM exp
, SCM module
),
5951 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
5952 "in the top-level environment specified by @var{module}.\n"
5953 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
5954 "@var{module} is made the current module. The current module\n"
5955 "is reset to its previous value when @var{eval} returns.")
5956 #define FUNC_NAME s_scm_eval
5958 SCM_VALIDATE_MODULE (2, module
);
5960 return scm_internal_dynamic_wind
5961 (change_environment
, inner_eval
, restore_environment
,
5962 (void *) SCM_UNPACK (exp
),
5963 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
5968 /* At this point, deval and scm_dapply are generated.
5975 #if (SCM_ENABLE_DEPRECATED == 1)
5977 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5978 SCM
scm_ceval (SCM x
, SCM env
)
5981 return ceval (x
, env
);
5982 else if (SCM_SYMBOLP (x
))
5983 return *scm_lookupcar (scm_cons (x
, SCM_UNDEFINED
), env
, 1);
5985 return SCM_XEVAL (x
, env
);
5988 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5989 SCM
scm_deval (SCM x
, SCM env
)
5992 return deval (x
, env
);
5993 else if (SCM_SYMBOLP (x
))
5994 return *scm_lookupcar (scm_cons (x
, SCM_UNDEFINED
), env
, 1);
5996 return SCM_XEVAL (x
, env
);
6000 dispatching_eval (SCM x
, SCM env
)
6002 if (scm_debug_mode_p
)
6003 return scm_deval (x
, env
);
6005 return scm_ceval (x
, env
);
6008 /* Deprecated in guile 1.7.0 on 2004-03-29. */
6009 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
) = dispatching_eval
;
6017 scm_init_opts (scm_evaluator_traps
,
6018 scm_evaluator_trap_table
,
6019 SCM_N_EVALUATOR_TRAPS
);
6020 scm_init_opts (scm_eval_options_interface
,
6022 SCM_N_EVAL_OPTIONS
);
6024 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
6025 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
6026 scm_set_smob_free (scm_tc16_promise
, promise_free
);
6027 scm_set_smob_print (scm_tc16_promise
, promise_print
);
6029 undefineds
= scm_list_1 (SCM_UNDEFINED
);
6030 SCM_SETCDR (undefineds
, undefineds
);
6031 scm_permanent_object (undefineds
);
6033 scm_listofnull
= scm_list_1 (SCM_EOL
);
6035 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
6036 scm_permanent_object (f_apply
);
6038 #include "libguile/eval.x"
6040 scm_add_feature ("delay");