1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009
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 License
6 * as published by the Free Software Foundation; either version 3 of
7 * the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful, but
10 * 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., 51 Franklin Street, Fifth Floor, Boston, MA
28 #include "libguile/__scm.h"
31 #include "libguile/_scm.h"
32 #include "libguile/alist.h"
33 #include "libguile/async.h"
34 #include "libguile/continuations.h"
35 #include "libguile/debug.h"
36 #include "libguile/deprecation.h"
37 #include "libguile/dynwind.h"
38 #include "libguile/eq.h"
39 #include "libguile/feature.h"
40 #include "libguile/fluids.h"
41 #include "libguile/goops.h"
42 #include "libguile/hash.h"
43 #include "libguile/hashtab.h"
44 #include "libguile/lang.h"
45 #include "libguile/list.h"
46 #include "libguile/macros.h"
47 #include "libguile/modules.h"
48 #include "libguile/ports.h"
49 #include "libguile/print.h"
50 #include "libguile/procprop.h"
51 #include "libguile/programs.h"
52 #include "libguile/root.h"
53 #include "libguile/smob.h"
54 #include "libguile/srcprop.h"
55 #include "libguile/stackchk.h"
56 #include "libguile/strings.h"
57 #include "libguile/threads.h"
58 #include "libguile/throw.h"
59 #include "libguile/validate.h"
60 #include "libguile/values.h"
61 #include "libguile/vectors.h"
62 #include "libguile/vm.h"
64 #include "libguile/eval.h"
65 #include "libguile/private-options.h"
70 static SCM
unmemoize_exprs (SCM expr
, SCM env
);
71 static SCM
canonicalize_define (SCM expr
);
72 static SCM
*scm_lookupcar1 (SCM vloc
, SCM genv
, int check
);
73 static SCM
unmemoize_builtin_macro (SCM expr
, SCM env
);
74 static SCM
eval (SCM x
, SCM env
);
80 * This section defines the message strings for the syntax errors that can be
81 * detected during memoization and the functions and macros that shall be
82 * called by the memoizer code to signal syntax errors. */
85 /* Syntax errors that can be detected during memoization: */
87 /* Circular or improper lists do not form valid scheme expressions. If a
88 * circular list or an improper list is detected in a place where a scheme
89 * expression is expected, a 'Bad expression' error is signalled. */
90 static const char s_bad_expression
[] = "Bad expression";
92 /* If a form is detected that holds a different number of expressions than are
93 * required in that context, a 'Missing or extra expression' error is
95 static const char s_expression
[] = "Missing or extra expression in";
97 /* If a form is detected that holds less expressions than are required in that
98 * context, a 'Missing expression' error is signalled. */
99 static const char s_missing_expression
[] = "Missing expression in";
101 /* If a form is detected that holds more expressions than are allowed in that
102 * context, an 'Extra expression' error is signalled. */
103 static const char s_extra_expression
[] = "Extra expression in";
105 /* The empty combination '()' is not allowed as an expression in scheme. If
106 * it is detected in a place where an expression is expected, an 'Illegal
107 * empty combination' error is signalled. Note: If you encounter this error
108 * message, it is very likely that you intended to denote the empty list. To
109 * do so, you need to quote the empty list like (quote ()) or '(). */
110 static const char s_empty_combination
[] = "Illegal empty combination";
112 /* A body may hold an arbitrary number of internal defines, followed by a
113 * non-empty sequence of expressions. If a body with an empty sequence of
114 * expressions is detected, a 'Missing body expression' error is signalled.
116 static const char s_missing_body_expression
[] = "Missing body expression in";
118 /* A body may hold an arbitrary number of internal defines, followed by a
119 * non-empty sequence of expressions. Each the definitions and the
120 * expressions may be grouped arbitraryly with begin, but it is not allowed to
121 * mix definitions and expressions. If a define form in a body mixes
122 * definitions and expressions, a 'Mixed definitions and expressions' error is
124 static const char s_mixed_body_forms
[] = "Mixed definitions and expressions in";
125 /* Definitions are only allowed on the top level and at the start of a body.
126 * If a definition is detected anywhere else, a 'Bad define placement' error
128 static const char s_bad_define
[] = "Bad define placement";
130 /* Case or cond expressions must have at least one clause. If a case or cond
131 * expression without any clauses is detected, a 'Missing clauses' error is
133 static const char s_missing_clauses
[] = "Missing clauses";
135 /* If there is an 'else' clause in a case or a cond statement, it must be the
136 * last clause. If after the 'else' case clause further clauses are detected,
137 * a 'Misplaced else clause' error is signalled. */
138 static const char s_misplaced_else_clause
[] = "Misplaced else clause";
140 /* If a case clause is detected that is not in the format
141 * (<label(s)> <expression1> <expression2> ...)
142 * a 'Bad case clause' error is signalled. */
143 static const char s_bad_case_clause
[] = "Bad case clause";
145 /* If a case clause is detected where the <label(s)> element is neither a
146 * proper list nor (in case of the last clause) the syntactic keyword 'else',
147 * a 'Bad case labels' error is signalled. Note: If you encounter this error
148 * for an else-clause which seems to be syntactically correct, check if 'else'
149 * is really a syntactic keyword in that context. If 'else' is bound in the
150 * local or global environment, it is not considered a syntactic keyword, but
151 * will be treated as any other variable. */
152 static const char s_bad_case_labels
[] = "Bad case labels";
154 /* In a case statement all labels have to be distinct. If in a case statement
155 * a label occurs more than once, a 'Duplicate case label' error is
157 static const char s_duplicate_case_label
[] = "Duplicate case label";
159 /* If a cond clause is detected that is not in one of the formats
160 * (<test> <expression1> ...) or (else <expression1> <expression2> ...)
161 * a 'Bad cond clause' error is signalled. */
162 static const char s_bad_cond_clause
[] = "Bad cond clause";
164 /* If a cond clause is detected that uses the alternate '=>' form, but does
165 * not hold a recipient element for the test result, a 'Missing recipient'
166 * error is signalled. */
167 static const char s_missing_recipient
[] = "Missing recipient in";
169 /* If in a position where a variable name is required some other object is
170 * detected, a 'Bad variable' error is signalled. */
171 static const char s_bad_variable
[] = "Bad variable";
173 /* Bindings for forms like 'let' and 'do' have to be given in a proper,
174 * possibly empty list. If any other object is detected in a place where a
175 * list of bindings was required, a 'Bad bindings' error is signalled. */
176 static const char s_bad_bindings
[] = "Bad bindings";
178 /* Depending on the syntactic context, a binding has to be in the format
179 * (<variable> <expression>) or (<variable> <expression1> <expression2>).
180 * If anything else is detected in a place where a binding was expected, a
181 * 'Bad binding' error is signalled. */
182 static const char s_bad_binding
[] = "Bad binding";
184 /* Some syntactic forms don't allow variable names to appear more than once in
185 * a list of bindings. If such a situation is nevertheless detected, a
186 * 'Duplicate binding' error is signalled. */
187 static const char s_duplicate_binding
[] = "Duplicate binding";
189 /* If the exit form of a 'do' expression is not in the format
190 * (<test> <expression> ...)
191 * a 'Bad exit clause' error is signalled. */
192 static const char s_bad_exit_clause
[] = "Bad exit clause";
194 /* The formal function arguments of a lambda expression have to be either a
195 * single symbol or a non-cyclic list. For anything else a 'Bad formals'
196 * error is signalled. */
197 static const char s_bad_formals
[] = "Bad formals";
199 /* If in a lambda expression something else than a symbol is detected at a
200 * place where a formal function argument is required, a 'Bad formal' error is
202 static const char s_bad_formal
[] = "Bad formal";
204 /* If in the arguments list of a lambda expression an argument name occurs
205 * more than once, a 'Duplicate formal' error is signalled. */
206 static const char s_duplicate_formal
[] = "Duplicate formal";
208 /* If the evaluation of an unquote-splicing expression gives something else
209 * than a proper list, a 'Non-list result for unquote-splicing' error is
211 static const char s_splicing
[] = "Non-list result for unquote-splicing";
213 /* If something else than an exact integer is detected as the argument for
214 * @slot-ref and @slot-set!, a 'Bad slot number' error is signalled. */
215 static const char s_bad_slot_number
[] = "Bad slot number";
218 /* Signal a syntax error. We distinguish between the form that caused the
219 * error and the enclosing expression. The error message will print out as
220 * shown in the following pattern. The file name and line number are only
221 * given when they can be determined from the erroneous form or from the
222 * enclosing expression.
224 * <filename>: In procedure memoization:
225 * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
227 SCM_SYMBOL (syntax_error_key
, "syntax-error");
229 /* The prototype is needed to indicate that the function does not return. */
231 syntax_error (const char* const, const SCM
, const SCM
) SCM_NORETURN
;
234 syntax_error (const char* const msg
, const SCM form
, const SCM expr
)
236 SCM msg_string
= scm_from_locale_string (msg
);
237 SCM filename
= SCM_BOOL_F
;
238 SCM linenr
= SCM_BOOL_F
;
242 if (scm_is_pair (form
))
244 filename
= scm_source_property (form
, scm_sym_filename
);
245 linenr
= scm_source_property (form
, scm_sym_line
);
248 if (scm_is_false (filename
) && scm_is_false (linenr
) && scm_is_pair (expr
))
250 filename
= scm_source_property (expr
, scm_sym_filename
);
251 linenr
= scm_source_property (expr
, scm_sym_line
);
254 if (!SCM_UNBNDP (expr
))
256 if (scm_is_true (filename
))
258 format
= "In file ~S, line ~S: ~A ~S in expression ~S.";
259 args
= scm_list_5 (filename
, linenr
, msg_string
, form
, expr
);
261 else if (scm_is_true (linenr
))
263 format
= "In line ~S: ~A ~S in expression ~S.";
264 args
= scm_list_4 (linenr
, msg_string
, form
, expr
);
268 format
= "~A ~S in expression ~S.";
269 args
= scm_list_3 (msg_string
, form
, expr
);
274 if (scm_is_true (filename
))
276 format
= "In file ~S, line ~S: ~A ~S.";
277 args
= scm_list_4 (filename
, linenr
, msg_string
, form
);
279 else if (scm_is_true (linenr
))
281 format
= "In line ~S: ~A ~S.";
282 args
= scm_list_3 (linenr
, msg_string
, form
);
287 args
= scm_list_2 (msg_string
, form
);
291 scm_error (syntax_error_key
, "memoization", format
, args
, SCM_BOOL_F
);
295 /* Shortcut macros to simplify syntax error handling. */
296 #define ASSERT_SYNTAX(cond, message, form) \
297 { if (SCM_UNLIKELY (!(cond))) \
298 syntax_error (message, form, SCM_UNDEFINED); }
299 #define ASSERT_SYNTAX_2(cond, message, form, expr) \
300 { if (SCM_UNLIKELY (!(cond))) \
301 syntax_error (message, form, expr); }
303 static void error_unbound_variable (SCM symbol
) SCM_NORETURN
;
304 static void error_defined_variable (SCM symbol
) SCM_NORETURN
;
310 * Ilocs are memoized references to variables in local environment frames.
311 * They are represented as three values: The relative offset of the
312 * environment frame, the number of the binding within that frame, and a
313 * boolean value indicating whether the binding is the last binding in the
316 * Frame numbers have 11 bits, relative offsets have 12 bits.
319 #define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc)
320 #define SCM_IFRINC (0x00000100L)
321 #define SCM_ICDR (0x00080000L)
322 #define SCM_IDINC (0x00100000L)
323 #define SCM_IFRAME(n) ((long)((SCM_ICDR-SCM_IFRINC)>>8) \
324 & (SCM_UNPACK (n) >> 8))
325 #define SCM_IDIST(n) (SCM_UNPACK (n) >> 20)
326 #define SCM_ICDRP(n) (SCM_ICDR & SCM_UNPACK (n))
327 #define SCM_IDSTMSK (-SCM_IDINC)
328 #define SCM_IFRAMEMAX ((1<<11)-1)
329 #define SCM_IDISTMAX ((1<<12)-1)
330 #define SCM_MAKE_ILOC(frame_nr, binding_nr, last_p) \
333 + ((binding_nr) << 20) \
334 + ((last_p) ? SCM_ICDR : 0) \
338 scm_i_print_iloc (SCM iloc
, SCM port
)
340 scm_puts ("#@", port
);
341 scm_intprint ((long) SCM_IFRAME (iloc
), 10, port
);
342 scm_putc (SCM_ICDRP (iloc
) ? '-' : '+', port
);
343 scm_intprint ((long) SCM_IDIST (iloc
), 10, port
);
346 #if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
348 SCM
scm_dbg_make_iloc (SCM frame
, SCM binding
, SCM cdrp
);
350 SCM_DEFINE (scm_dbg_make_iloc
, "dbg-make-iloc", 3, 0, 0,
351 (SCM frame
, SCM binding
, SCM cdrp
),
352 "Return a new iloc with frame offset @var{frame}, binding\n"
353 "offset @var{binding} and the cdr flag @var{cdrp}.")
354 #define FUNC_NAME s_scm_dbg_make_iloc
356 return SCM_MAKE_ILOC ((scm_t_bits
) scm_to_unsigned_integer (frame
, 0, SCM_IFRAMEMAX
),
357 (scm_t_bits
) scm_to_unsigned_integer (binding
, 0, SCM_IDISTMAX
),
362 SCM
scm_dbg_iloc_p (SCM obj
);
364 SCM_DEFINE (scm_dbg_iloc_p
, "dbg-iloc?", 1, 0, 0,
366 "Return @code{#t} if @var{obj} is an iloc.")
367 #define FUNC_NAME s_scm_dbg_iloc_p
369 return scm_from_bool (SCM_ILOCP (obj
));
377 /* {Evaluator byte codes (isyms)}
380 #define ISYMNUM(n) (SCM_ITAG8_DATA (n))
382 /* This table must agree with the list of SCM_IM_ constants in tags.h */
383 static const char *const isymnames
[] =
400 "#@call-with-current-continuation",
405 "#@call-with-values",
413 scm_i_print_isym (SCM isym
, SCM port
)
415 const size_t isymnum
= ISYMNUM (isym
);
416 if (isymnum
< (sizeof isymnames
/ sizeof (char *)))
417 scm_puts (isymnames
[isymnum
], port
);
419 scm_ipruk ("isym", isym
, port
);
424 /* The function lookup_symbol is used during memoization: Lookup the symbol in
425 * the environment. If there is no binding for the symbol, SCM_UNDEFINED is
426 * returned. If the symbol is a global variable, the variable object to which
427 * the symbol is bound is returned. Finally, if the symbol is a local
428 * variable the corresponding iloc object is returned. */
430 /* A helper function for lookup_symbol: Try to find the symbol in the top
431 * level environment frame. The function returns SCM_UNDEFINED if the symbol
432 * is unbound and it returns a variable object if the symbol is a global
435 lookup_global_symbol (const SCM symbol
, const SCM top_level
)
437 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
438 if (scm_is_false (variable
))
439 return SCM_UNDEFINED
;
445 lookup_symbol (const SCM symbol
, const SCM env
)
448 unsigned int frame_nr
;
450 for (frame_idx
= env
, frame_nr
= 0;
451 !scm_is_null (frame_idx
);
452 frame_idx
= SCM_CDR (frame_idx
), ++frame_nr
)
454 const SCM frame
= SCM_CAR (frame_idx
);
455 if (scm_is_pair (frame
))
457 /* frame holds a local environment frame */
459 unsigned int symbol_nr
;
461 for (symbol_idx
= SCM_CAR (frame
), symbol_nr
= 0;
462 scm_is_pair (symbol_idx
);
463 symbol_idx
= SCM_CDR (symbol_idx
), ++symbol_nr
)
465 if (scm_is_eq (SCM_CAR (symbol_idx
), symbol
))
466 /* found the symbol, therefore return the iloc */
467 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 0);
469 if (scm_is_eq (symbol_idx
, symbol
))
470 /* found the symbol as the last element of the current frame */
471 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 1);
475 /* no more local environment frames */
476 return lookup_global_symbol (symbol
, frame
);
480 return lookup_global_symbol (symbol
, SCM_BOOL_F
);
484 /* Return true if the symbol is - from the point of view of a macro
485 * transformer - a literal in the sense specified in chapter "pattern
486 * language" of R5RS. In the code below, however, we don't match the
487 * definition of R5RS exactly: It returns true if the identifier has no
488 * binding or if it is a syntactic keyword. */
490 literal_p (const SCM symbol
, const SCM env
)
492 const SCM variable
= lookup_symbol (symbol
, env
);
493 if (SCM_UNBNDP (variable
))
495 if (SCM_VARIABLEP (variable
) && SCM_MACROP (SCM_VARIABLE_REF (variable
)))
502 /* Return true if the expression is self-quoting in the memoized code. Thus,
503 * some other objects (like e. g. vectors) are reported as self-quoting, which
504 * according to R5RS would need to be quoted. */
506 is_self_quoting_p (const SCM expr
)
508 if (scm_is_pair (expr
))
510 else if (scm_is_symbol (expr
))
512 else if (scm_is_null (expr
))
518 SCM_SYMBOL (sym_three_question_marks
, "???");
521 unmemoize_expression (const SCM expr
, const SCM env
)
523 if (SCM_ILOCP (expr
))
526 unsigned long int frame_nr
;
528 unsigned long int symbol_nr
;
530 for (frame_idx
= env
, frame_nr
= SCM_IFRAME (expr
);
532 frame_idx
= SCM_CDR (frame_idx
), --frame_nr
)
534 for (symbol_idx
= SCM_CAAR (frame_idx
), symbol_nr
= SCM_IDIST (expr
);
536 symbol_idx
= SCM_CDR (symbol_idx
), --symbol_nr
)
538 return SCM_ICDRP (expr
) ? symbol_idx
: SCM_CAR (symbol_idx
);
540 else if (SCM_VARIABLEP (expr
))
542 const SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), expr
);
543 return scm_is_true (sym
) ? sym
: sym_three_question_marks
;
545 else if (scm_is_simple_vector (expr
))
547 return scm_list_2 (scm_sym_quote
, expr
);
549 else if (!scm_is_pair (expr
))
553 else if (SCM_ISYMP (SCM_CAR (expr
)))
555 return unmemoize_builtin_macro (expr
, env
);
559 return unmemoize_exprs (expr
, env
);
565 unmemoize_exprs (const SCM exprs
, const SCM env
)
567 SCM r_result
= SCM_EOL
;
568 SCM expr_idx
= exprs
;
571 /* Note that due to the current lazy memoizer we may find partially memoized
572 * code during execution. In such code we have to expect improper lists of
573 * expressions: On the one hand, for such code syntax checks have not yet
574 * fully been performed, on the other hand, there may be even legal code
575 * like '(a . b) appear as an improper list of expressions as long as the
576 * quote expression is still in its unmemoized form. For this reason, the
577 * following code handles improper lists of expressions until memoization
578 * and execution have been completely separated. */
579 for (; scm_is_pair (expr_idx
); expr_idx
= SCM_CDR (expr_idx
))
581 const SCM expr
= SCM_CAR (expr_idx
);
583 /* In partially memoized code, lists of expressions that stem from a
584 * body form may start with an ISYM if the body itself has not yet been
585 * memoized. This isym is just an internal marker to indicate that the
586 * body still needs to be memoized. An isym may occur at the very
587 * beginning of the body or after one or more comment strings. It is
588 * dropped during unmemoization. */
589 if (!SCM_ISYMP (expr
))
591 um_expr
= unmemoize_expression (expr
, env
);
592 r_result
= scm_cons (um_expr
, r_result
);
595 um_expr
= unmemoize_expression (expr_idx
, env
);
596 if (!scm_is_null (r_result
))
598 const SCM result
= scm_reverse_x (r_result
, SCM_UNDEFINED
);
599 SCM_SETCDR (r_result
, um_expr
);
609 /* Rewrite the body (which is given as the list of expressions forming the
610 * body) into its internal form. The internal form of a body (<expr> ...) is
611 * just the body itself, but prefixed with an ISYM that denotes to what kind
612 * of outer construct this body belongs: (<ISYM> <expr> ...). A lambda body
613 * starts with SCM_IM_LAMBDA, for example, a body of a let starts with
616 * It is assumed that the calling expression has already made sure that the
617 * body is a proper list. */
619 m_body (SCM op
, SCM exprs
)
621 /* Don't add another ISYM if one is present already. */
622 if (SCM_ISYMP (SCM_CAR (exprs
)))
625 return scm_cons (op
, exprs
);
629 /* The function m_expand_body memoizes a proper list of expressions forming a
630 * body. This function takes care of dealing with internal defines and
631 * transforming them into an equivalent letrec expression. The list of
632 * expressions is rewritten in place. */
634 /* This is a helper function for m_expand_body. If the argument expression is
635 * a symbol that denotes a syntactic keyword, the corresponding macro object
636 * is returned, in all other cases the function returns SCM_UNDEFINED. */
638 try_macro_lookup (const SCM expr
, const SCM env
)
640 if (scm_is_symbol (expr
))
642 const SCM variable
= lookup_symbol (expr
, env
);
643 if (SCM_VARIABLEP (variable
))
645 const SCM value
= SCM_VARIABLE_REF (variable
);
646 if (SCM_MACROP (value
))
651 return SCM_UNDEFINED
;
654 /* This is a helper function for m_expand_body. It expands user macros,
655 * because for the correct translation of a body we need to know whether they
656 * expand to a definition. */
658 expand_user_macros (SCM expr
, const SCM env
)
660 while (scm_is_pair (expr
))
662 const SCM car_expr
= SCM_CAR (expr
);
663 const SCM new_car
= expand_user_macros (car_expr
, env
);
664 const SCM value
= try_macro_lookup (new_car
, env
);
666 if (SCM_MACROP (value
) && SCM_MACRO_TYPE (value
) == 2)
668 /* User macros transform code into code. */
669 expr
= scm_call_2 (SCM_MACRO_CODE (value
), expr
, env
);
670 /* We need to reiterate on the transformed code. */
674 /* No user macro: return. */
675 SCM_SETCAR (expr
, new_car
);
683 /* This is a helper function for m_expand_body. It determines if a given form
684 * represents an application of a given built-in macro. The built-in macro to
685 * check for is identified by its syntactic keyword. The form is an
686 * application of the given macro if looking up the car of the form in the
687 * given environment actually returns the built-in macro. */
689 is_system_macro_p (const SCM syntactic_keyword
, const SCM form
, const SCM env
)
691 if (scm_is_pair (form
))
693 const SCM car_form
= SCM_CAR (form
);
694 const SCM value
= try_macro_lookup (car_form
, env
);
695 if (SCM_BUILTIN_MACRO_P (value
))
697 const SCM macro_name
= scm_macro_name (value
);
698 return scm_is_eq (macro_name
, syntactic_keyword
);
706 macroexp (SCM x
, SCM env
)
708 SCM res
, proc
, orig_sym
;
710 /* Don't bother to produce error messages here. We get them when we
711 eventually execute the code for real. */
714 orig_sym
= SCM_CAR (x
);
715 if (!scm_is_symbol (orig_sym
))
719 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
720 if (proc_ptr
== NULL
)
722 /* We have lost the race. */
728 /* Only handle memoizing macros. `Acros' and `macros' are really
729 special forms and should not be evaluated here. */
731 if (!SCM_MACROP (proc
)
732 || (SCM_MACRO_TYPE (proc
) != 2 && !SCM_BUILTIN_MACRO_P (proc
)))
735 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
736 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
738 if (scm_ilength (res
) <= 0)
739 /* Result of expansion is not a list. */
740 return (scm_list_2 (SCM_IM_BEGIN
, res
));
743 /* njrev: Several queries here: (1) I don't see how it can be
744 correct that the SCM_SETCAR 2 lines below this comment needs
745 protection, but the SCM_SETCAR 6 lines above does not, so
746 something here is probably wrong. (2) macroexp() is now only
747 used in one place - scm_m_generalized_set_x - whereas all other
748 macro expansion happens through expand_user_macros. Therefore
749 (2.1) perhaps macroexp() could be eliminated completely now?
750 (2.2) Does expand_user_macros need any critical section
753 SCM_CRITICAL_SECTION_START
;
754 SCM_SETCAR (x
, SCM_CAR (res
));
755 SCM_SETCDR (x
, SCM_CDR (res
));
756 SCM_CRITICAL_SECTION_END
;
763 /* Start of the memoizers for the standard R5RS builtin macros. */
765 static SCM
scm_m_quote (SCM xorig
, SCM env
);
766 static SCM
scm_m_begin (SCM xorig
, SCM env
);
767 static SCM
scm_m_if (SCM xorig
, SCM env
);
768 static SCM
scm_m_set_x (SCM xorig
, SCM env
);
769 static SCM
scm_m_and (SCM xorig
, SCM env
);
770 static SCM
scm_m_or (SCM xorig
, SCM env
);
771 static SCM
scm_m_case (SCM xorig
, SCM env
);
772 static SCM
scm_m_cond (SCM xorig
, SCM env
);
773 static SCM
scm_m_lambda (SCM xorig
, SCM env
);
774 static SCM
scm_m_letstar (SCM xorig
, SCM env
);
775 static SCM
scm_m_do (SCM xorig
, SCM env
);
776 static SCM
scm_m_quasiquote (SCM xorig
, SCM env
);
777 static SCM
scm_m_delay (SCM xorig
, SCM env
);
778 static SCM
scm_m_generalized_set_x (SCM xorig
, SCM env
);
779 static SCM
scm_m_define (SCM x
, SCM env
);
780 static SCM
scm_m_letrec (SCM xorig
, SCM env
);
781 static SCM
scm_m_let (SCM xorig
, SCM env
);
782 static SCM
scm_m_at (SCM xorig
, SCM env
);
783 static SCM
scm_m_atat (SCM xorig
, SCM env
);
784 static SCM
scm_m_atslot_ref (SCM xorig
, SCM env
);
785 static SCM
scm_m_atslot_set_x (SCM xorig
, SCM env
);
786 static SCM
scm_m_apply (SCM xorig
, SCM env
);
787 static SCM
scm_m_cont (SCM xorig
, SCM env
);
789 static SCM
scm_m_nil_cond (SCM xorig
, SCM env
);
790 static SCM
scm_m_atfop (SCM xorig
, SCM env
);
791 #endif /* SCM_ENABLE_ELISP */
792 static SCM
scm_m_atbind (SCM xorig
, SCM env
);
793 static SCM
scm_m_at_call_with_values (SCM xorig
, SCM env
);
794 static SCM
scm_m_eval_when (SCM xorig
, SCM env
);
798 m_expand_body (const SCM forms
, const SCM env
)
800 /* The first body form can be skipped since it is known to be the ISYM that
801 * was prepended to the body by m_body. */
802 SCM cdr_forms
= SCM_CDR (forms
);
803 SCM form_idx
= cdr_forms
;
804 SCM definitions
= SCM_EOL
;
805 SCM sequence
= SCM_EOL
;
807 /* According to R5RS, the list of body forms consists of two parts: a number
808 * (maybe zero) of definitions, followed by a non-empty sequence of
809 * expressions. Each the definitions and the expressions may be grouped
810 * arbitrarily with begin, but it is not allowed to mix definitions and
811 * expressions. The task of the following loop therefore is to split the
812 * list of body forms into the list of definitions and the sequence of
814 while (!scm_is_null (form_idx
))
816 const SCM form
= SCM_CAR (form_idx
);
817 const SCM new_form
= expand_user_macros (form
, env
);
818 if (is_system_macro_p (scm_sym_define
, new_form
, env
))
820 definitions
= scm_cons (new_form
, definitions
);
821 form_idx
= SCM_CDR (form_idx
);
823 else if (is_system_macro_p (scm_sym_begin
, new_form
, env
))
825 /* We have encountered a group of forms. This has to be either a
826 * (possibly empty) group of (possibly further grouped) definitions,
827 * or a non-empty group of (possibly further grouped)
829 const SCM grouped_forms
= SCM_CDR (new_form
);
830 unsigned int found_definition
= 0;
831 unsigned int found_expression
= 0;
832 SCM grouped_form_idx
= grouped_forms
;
833 while (!found_expression
&& !scm_is_null (grouped_form_idx
))
835 const SCM inner_form
= SCM_CAR (grouped_form_idx
);
836 const SCM new_inner_form
= expand_user_macros (inner_form
, env
);
837 if (is_system_macro_p (scm_sym_define
, new_inner_form
, env
))
839 found_definition
= 1;
840 definitions
= scm_cons (new_inner_form
, definitions
);
841 grouped_form_idx
= SCM_CDR (grouped_form_idx
);
843 else if (is_system_macro_p (scm_sym_begin
, new_inner_form
, env
))
845 const SCM inner_group
= SCM_CDR (new_inner_form
);
847 = scm_append (scm_list_2 (inner_group
,
848 SCM_CDR (grouped_form_idx
)));
852 /* The group marks the start of the expressions of the body.
853 * We have to make sure that within the same group we have
854 * not encountered a definition before. */
855 ASSERT_SYNTAX (!found_definition
, s_mixed_body_forms
, form
);
856 found_expression
= 1;
857 grouped_form_idx
= SCM_EOL
;
861 /* We have finished processing the group. If we have not yet
862 * encountered an expression we continue processing the forms of the
863 * body to collect further definition forms. Otherwise, the group
864 * marks the start of the sequence of expressions of the body. */
865 if (!found_expression
)
867 form_idx
= SCM_CDR (form_idx
);
877 /* We have detected a form which is no definition. This marks the
878 * start of the sequence of expressions of the body. */
884 /* FIXME: forms does not hold information about the file location. */
885 ASSERT_SYNTAX (scm_is_pair (sequence
), s_missing_body_expression
, cdr_forms
);
887 if (!scm_is_null (definitions
))
891 SCM letrec_expression
;
892 SCM new_letrec_expression
;
894 SCM bindings
= SCM_EOL
;
895 for (definition_idx
= definitions
;
896 !scm_is_null (definition_idx
);
897 definition_idx
= SCM_CDR (definition_idx
))
899 const SCM definition
= SCM_CAR (definition_idx
);
900 const SCM canonical_definition
= canonicalize_define (definition
);
901 const SCM binding
= SCM_CDR (canonical_definition
);
902 bindings
= scm_cons (binding
, bindings
);
905 letrec_tail
= scm_cons (bindings
, sequence
);
906 /* FIXME: forms does not hold information about the file location. */
907 letrec_expression
= scm_cons_source (forms
, scm_sym_letrec
, letrec_tail
);
908 new_letrec_expression
= scm_m_letrec (letrec_expression
, env
);
909 SCM_SETCAR (forms
, new_letrec_expression
);
910 SCM_SETCDR (forms
, SCM_EOL
);
914 SCM_SETCAR (forms
, SCM_CAR (sequence
));
915 SCM_SETCDR (forms
, SCM_CDR (sequence
));
919 SCM_SYNTAX (s_and
, "and", scm_i_makbimacro
, scm_m_and
);
920 SCM_GLOBAL_SYMBOL (scm_sym_and
, "and");
923 scm_m_and (SCM expr
, SCM env SCM_UNUSED
)
925 const SCM cdr_expr
= SCM_CDR (expr
);
926 const long length
= scm_ilength (cdr_expr
);
928 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
932 /* Special case: (and) is replaced by #t. */
937 SCM_SETCAR (expr
, SCM_IM_AND
);
943 unmemoize_and (const SCM expr
, const SCM env
)
945 return scm_cons (scm_sym_and
, unmemoize_exprs (SCM_CDR (expr
), env
));
949 SCM_SYNTAX (s_begin
, "begin", scm_i_makbimacro
, scm_m_begin
);
950 SCM_GLOBAL_SYMBOL (scm_sym_begin
, "begin");
953 scm_m_begin (SCM expr
, SCM env SCM_UNUSED
)
955 const SCM cdr_expr
= SCM_CDR (expr
);
956 /* Dirk:FIXME:: An empty begin clause is not generally allowed by R5RS.
957 * That means, there should be a distinction between uses of begin where an
958 * empty clause is OK and where it is not. */
959 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
961 SCM_SETCAR (expr
, SCM_IM_BEGIN
);
966 unmemoize_begin (const SCM expr
, const SCM env
)
968 return scm_cons (scm_sym_begin
, unmemoize_exprs (SCM_CDR (expr
), env
));
972 SCM_SYNTAX (s_case
, "case", scm_i_makbimacro
, scm_m_case
);
973 SCM_GLOBAL_SYMBOL (scm_sym_case
, "case");
974 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
977 scm_m_case (SCM expr
, SCM env
)
980 SCM all_labels
= SCM_EOL
;
982 /* Check, whether 'else is a literal, i. e. not bound to a value. */
983 const int else_literal_p
= literal_p (scm_sym_else
, env
);
985 const SCM cdr_expr
= SCM_CDR (expr
);
986 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
987 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_clauses
, expr
);
989 clauses
= SCM_CDR (cdr_expr
);
990 while (!scm_is_null (clauses
))
994 const SCM clause
= SCM_CAR (clauses
);
995 ASSERT_SYNTAX_2 (scm_ilength (clause
) >= 2,
996 s_bad_case_clause
, clause
, expr
);
998 labels
= SCM_CAR (clause
);
999 if (scm_is_pair (labels
))
1001 ASSERT_SYNTAX_2 (scm_ilength (labels
) >= 0,
1002 s_bad_case_labels
, labels
, expr
);
1003 all_labels
= scm_append (scm_list_2 (labels
, all_labels
));
1005 else if (scm_is_null (labels
))
1007 /* The list of labels is empty. According to R5RS this is allowed.
1008 * It means that the sequence of expressions will never be executed.
1009 * Therefore, as an optimization, we could remove the whole
1014 ASSERT_SYNTAX_2 (scm_is_eq (labels
, scm_sym_else
) && else_literal_p
,
1015 s_bad_case_labels
, labels
, expr
);
1016 ASSERT_SYNTAX_2 (scm_is_null (SCM_CDR (clauses
)),
1017 s_misplaced_else_clause
, clause
, expr
);
1020 /* build the new clause */
1021 if (scm_is_eq (labels
, scm_sym_else
))
1022 SCM_SETCAR (clause
, SCM_IM_ELSE
);
1024 clauses
= SCM_CDR (clauses
);
1027 /* Check whether all case labels are distinct. */
1028 for (; !scm_is_null (all_labels
); all_labels
= SCM_CDR (all_labels
))
1030 const SCM label
= SCM_CAR (all_labels
);
1031 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (label
, SCM_CDR (all_labels
))),
1032 s_duplicate_case_label
, label
, expr
);
1035 SCM_SETCAR (expr
, SCM_IM_CASE
);
1040 unmemoize_case (const SCM expr
, const SCM env
)
1042 const SCM um_key_expr
= unmemoize_expression (SCM_CADR (expr
), env
);
1043 SCM um_clauses
= SCM_EOL
;
1046 for (clause_idx
= SCM_CDDR (expr
);
1047 !scm_is_null (clause_idx
);
1048 clause_idx
= SCM_CDR (clause_idx
))
1050 const SCM clause
= SCM_CAR (clause_idx
);
1051 const SCM labels
= SCM_CAR (clause
);
1052 const SCM exprs
= SCM_CDR (clause
);
1054 const SCM um_exprs
= unmemoize_exprs (exprs
, env
);
1055 const SCM um_labels
= (scm_is_eq (labels
, SCM_IM_ELSE
))
1057 : scm_i_finite_list_copy (labels
);
1058 const SCM um_clause
= scm_cons (um_labels
, um_exprs
);
1060 um_clauses
= scm_cons (um_clause
, um_clauses
);
1062 um_clauses
= scm_reverse_x (um_clauses
, SCM_UNDEFINED
);
1064 return scm_cons2 (scm_sym_case
, um_key_expr
, um_clauses
);
1068 SCM_SYNTAX (s_cond
, "cond", scm_i_makbimacro
, scm_m_cond
);
1069 SCM_GLOBAL_SYMBOL (scm_sym_cond
, "cond");
1070 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
1073 scm_m_cond (SCM expr
, SCM env
)
1075 /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
1076 const int else_literal_p
= literal_p (scm_sym_else
, env
);
1077 const int arrow_literal_p
= literal_p (scm_sym_arrow
, env
);
1079 const SCM clauses
= SCM_CDR (expr
);
1082 ASSERT_SYNTAX (scm_ilength (clauses
) >= 0, s_bad_expression
, expr
);
1083 ASSERT_SYNTAX (scm_ilength (clauses
) >= 1, s_missing_clauses
, expr
);
1085 for (clause_idx
= clauses
;
1086 !scm_is_null (clause_idx
);
1087 clause_idx
= SCM_CDR (clause_idx
))
1091 const SCM clause
= SCM_CAR (clause_idx
);
1092 const long length
= scm_ilength (clause
);
1093 ASSERT_SYNTAX_2 (length
>= 1, s_bad_cond_clause
, clause
, expr
);
1095 test
= SCM_CAR (clause
);
1096 if (scm_is_eq (test
, scm_sym_else
) && else_literal_p
)
1098 const int last_clause_p
= scm_is_null (SCM_CDR (clause_idx
));
1099 ASSERT_SYNTAX_2 (length
>= 2,
1100 s_bad_cond_clause
, clause
, expr
);
1101 ASSERT_SYNTAX_2 (last_clause_p
,
1102 s_misplaced_else_clause
, clause
, expr
);
1103 SCM_SETCAR (clause
, SCM_IM_ELSE
);
1105 else if (length
>= 2
1106 && scm_is_eq (SCM_CADR (clause
), scm_sym_arrow
)
1109 ASSERT_SYNTAX_2 (length
> 2, s_missing_recipient
, clause
, expr
);
1110 ASSERT_SYNTAX_2 (length
== 3, s_extra_expression
, clause
, expr
);
1111 SCM_SETCAR (SCM_CDR (clause
), SCM_IM_ARROW
);
1113 /* SRFI 61 extended cond */
1114 else if (length
>= 3
1115 && scm_is_eq (SCM_CADDR (clause
), scm_sym_arrow
)
1118 ASSERT_SYNTAX_2 (length
> 3, s_missing_recipient
, clause
, expr
);
1119 ASSERT_SYNTAX_2 (length
== 4, s_extra_expression
, clause
, expr
);
1120 SCM_SETCAR (SCM_CDDR (clause
), SCM_IM_ARROW
);
1124 SCM_SETCAR (expr
, SCM_IM_COND
);
1129 unmemoize_cond (const SCM expr
, const SCM env
)
1131 SCM um_clauses
= SCM_EOL
;
1134 for (clause_idx
= SCM_CDR (expr
);
1135 !scm_is_null (clause_idx
);
1136 clause_idx
= SCM_CDR (clause_idx
))
1138 const SCM clause
= SCM_CAR (clause_idx
);
1139 const SCM sequence
= SCM_CDR (clause
);
1140 const SCM test
= SCM_CAR (clause
);
1145 if (scm_is_eq (test
, SCM_IM_ELSE
))
1146 um_test
= scm_sym_else
;
1148 um_test
= unmemoize_expression (test
, env
);
1150 if (!scm_is_null (sequence
) && scm_is_eq (SCM_CAR (sequence
),
1153 const SCM target
= SCM_CADR (sequence
);
1154 const SCM um_target
= unmemoize_expression (target
, env
);
1155 um_sequence
= scm_list_2 (scm_sym_arrow
, um_target
);
1159 um_sequence
= unmemoize_exprs (sequence
, env
);
1162 um_clause
= scm_cons (um_test
, um_sequence
);
1163 um_clauses
= scm_cons (um_clause
, um_clauses
);
1165 um_clauses
= scm_reverse_x (um_clauses
, SCM_UNDEFINED
);
1167 return scm_cons (scm_sym_cond
, um_clauses
);
1171 SCM_SYNTAX (s_define
, "define", scm_i_makbimacro
, scm_m_define
);
1172 SCM_GLOBAL_SYMBOL (scm_sym_define
, "define");
1174 /* Guile provides an extension to R5RS' define syntax to represent function
1175 * currying in a compact way. With this extension, it is allowed to write
1176 * (define <nested-variable> <body>), where <nested-variable> has of one of
1177 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
1178 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
1179 * should be either a sequence of zero or more variables, or a sequence of one
1180 * or more variables followed by a space-delimited period and another
1181 * variable. Each level of argument nesting wraps the <body> within another
1182 * lambda expression. For example, the following forms are allowed, each one
1183 * followed by an equivalent, more explicit implementation.
1185 * (define ((a b . c) . d) <body>) is equivalent to
1186 * (define a (lambda (b . c) (lambda d <body>)))
1188 * (define (((a) b) c . d) <body>) is equivalent to
1189 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
1191 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
1192 * module that does not implement this extension. */
1194 canonicalize_define (const SCM expr
)
1199 const SCM cdr_expr
= SCM_CDR (expr
);
1200 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1201 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1203 body
= SCM_CDR (cdr_expr
);
1204 variable
= SCM_CAR (cdr_expr
);
1205 while (scm_is_pair (variable
))
1207 /* This while loop realizes function currying by variable nesting.
1208 * Variable is known to be a nested-variable. In every iteration of the
1209 * loop another level of lambda expression is created, starting with the
1210 * innermost one. Note that we don't check for duplicate formals here:
1211 * This will be done by the memoizer of the lambda expression. */
1212 const SCM formals
= SCM_CDR (variable
);
1213 const SCM tail
= scm_cons (formals
, body
);
1215 /* Add source properties to each new lambda expression: */
1216 const SCM lambda
= scm_cons_source (variable
, scm_sym_lambda
, tail
);
1218 body
= scm_list_1 (lambda
);
1219 variable
= SCM_CAR (variable
);
1221 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
1222 ASSERT_SYNTAX (scm_ilength (body
) == 1, s_expression
, expr
);
1224 SCM_SETCAR (cdr_expr
, variable
);
1225 SCM_SETCDR (cdr_expr
, body
);
1229 /* According to Section 5.2.1 of R5RS we first have to make sure that the
1230 variable is bound, and then perform the `(set! variable expression)'
1231 operation. However, EXPRESSION _can_ be evaluated before VARIABLE is
1232 bound. This means that EXPRESSION won't necessarily be able to assign
1233 values to VARIABLE as in `(define foo (begin (set! foo 1) (+ foo 1)))'. */
1235 scm_m_define (SCM expr
, SCM env
)
1237 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), s_bad_define
, expr
);
1240 const SCM canonical_definition
= canonicalize_define (expr
);
1241 const SCM cdr_canonical_definition
= SCM_CDR (canonical_definition
);
1242 const SCM variable
= SCM_CAR (cdr_canonical_definition
);
1243 const SCM value
= scm_eval_car (SCM_CDR (cdr_canonical_definition
), env
);
1245 = scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_T
);
1247 if (SCM_REC_PROCNAMES_P
)
1250 while (SCM_MACROP (tmp
))
1251 tmp
= SCM_MACRO_CODE (tmp
);
1252 if (scm_is_true (scm_procedure_p (tmp
))
1253 /* Only the first definition determines the name. */
1254 && scm_is_false (scm_procedure_property (tmp
, scm_sym_name
)))
1255 scm_set_procedure_property_x (tmp
, scm_sym_name
, variable
);
1258 SCM_VARIABLE_SET (location
, value
);
1260 return SCM_UNSPECIFIED
;
1265 /* This is a helper function for forms (<keyword> <expression>) that are
1266 * transformed into (#@<keyword> '() <memoized_expression>) in order to allow
1267 * for easy creation of a thunk (i. e. a closure without arguments) using the
1268 * ('() <memoized_expression>) tail of the memoized form. */
1270 memoize_as_thunk_prototype (const SCM expr
, const SCM env SCM_UNUSED
)
1272 const SCM cdr_expr
= SCM_CDR (expr
);
1273 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1274 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1276 SCM_SETCDR (expr
, scm_cons (SCM_EOL
, cdr_expr
));
1282 SCM_SYNTAX (s_delay
, "delay", scm_i_makbimacro
, scm_m_delay
);
1283 SCM_GLOBAL_SYMBOL (scm_sym_delay
, "delay");
1285 /* Promises are implemented as closures with an empty parameter list. Thus,
1286 * (delay <expression>) is transformed into (#@delay '() <expression>), where
1287 * the empty list represents the empty parameter list. This representation
1288 * allows for easy creation of the closure during evaluation. */
1290 scm_m_delay (SCM expr
, SCM env
)
1292 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1293 SCM_SETCAR (new_expr
, SCM_IM_DELAY
);
1298 unmemoize_delay (const SCM expr
, const SCM env
)
1300 const SCM thunk_expr
= SCM_CADDR (expr
);
1301 /* A promise is implemented as a closure, and when applying a
1302 closure the evaluator adds a new frame to the environment - even
1303 though, in the case of a promise, the added frame is always
1304 empty. We need to extend the environment here in the same way,
1305 so that any ILOCs in thunk_expr can be unmemoized correctly. */
1306 const SCM new_env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1307 return scm_list_2 (scm_sym_delay
, unmemoize_expression (thunk_expr
, new_env
));
1311 SCM_SYNTAX(s_do
, "do", scm_i_makbimacro
, scm_m_do
);
1312 SCM_GLOBAL_SYMBOL(scm_sym_do
, "do");
1314 /* DO gets the most radically altered syntax. The order of the vars is
1315 * reversed here. During the evaluation this allows for simple consing of the
1316 * results of the inits and steps:
1318 (do ((<var1> <init1> <step1>)
1326 (#@do (<init1> <init2> ... <initn>)
1327 (varn ... var2 var1)
1330 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
1333 scm_m_do (SCM expr
, SCM env SCM_UNUSED
)
1335 SCM variables
= SCM_EOL
;
1336 SCM init_forms
= SCM_EOL
;
1337 SCM step_forms
= SCM_EOL
;
1344 const SCM cdr_expr
= SCM_CDR (expr
);
1345 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1346 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1348 /* Collect variables, init and step forms. */
1349 binding_idx
= SCM_CAR (cdr_expr
);
1350 ASSERT_SYNTAX_2 (scm_ilength (binding_idx
) >= 0,
1351 s_bad_bindings
, binding_idx
, expr
);
1352 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1354 const SCM binding
= SCM_CAR (binding_idx
);
1355 const long length
= scm_ilength (binding
);
1356 ASSERT_SYNTAX_2 (length
== 2 || length
== 3,
1357 s_bad_binding
, binding
, expr
);
1360 const SCM name
= SCM_CAR (binding
);
1361 const SCM init
= SCM_CADR (binding
);
1362 const SCM step
= (length
== 2) ? name
: SCM_CADDR (binding
);
1363 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
1364 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, variables
)),
1365 s_duplicate_binding
, name
, expr
);
1367 variables
= scm_cons (name
, variables
);
1368 init_forms
= scm_cons (init
, init_forms
);
1369 step_forms
= scm_cons (step
, step_forms
);
1372 init_forms
= scm_reverse_x (init_forms
, SCM_UNDEFINED
);
1373 step_forms
= scm_reverse_x (step_forms
, SCM_UNDEFINED
);
1375 /* Memoize the test form and the exit sequence. */
1376 cddr_expr
= SCM_CDR (cdr_expr
);
1377 exit_clause
= SCM_CAR (cddr_expr
);
1378 ASSERT_SYNTAX_2 (scm_ilength (exit_clause
) >= 1,
1379 s_bad_exit_clause
, exit_clause
, expr
);
1381 commands
= SCM_CDR (cddr_expr
);
1382 tail
= scm_cons2 (exit_clause
, commands
, step_forms
);
1383 tail
= scm_cons2 (init_forms
, variables
, tail
);
1384 SCM_SETCAR (expr
, SCM_IM_DO
);
1385 SCM_SETCDR (expr
, tail
);
1390 unmemoize_do (const SCM expr
, const SCM env
)
1392 const SCM cdr_expr
= SCM_CDR (expr
);
1393 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1394 const SCM rnames
= SCM_CAR (cddr_expr
);
1395 const SCM extended_env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
1396 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
1397 const SCM exit_sequence
= SCM_CAR (cdddr_expr
);
1398 const SCM um_exit_sequence
= unmemoize_exprs (exit_sequence
, extended_env
);
1399 const SCM cddddr_expr
= SCM_CDR (cdddr_expr
);
1400 const SCM um_body
= unmemoize_exprs (SCM_CAR (cddddr_expr
), extended_env
);
1402 /* build transformed binding list */
1403 SCM um_names
= scm_reverse (rnames
);
1404 SCM um_inits
= unmemoize_exprs (SCM_CAR (cdr_expr
), env
);
1405 SCM um_steps
= unmemoize_exprs (SCM_CDR (cddddr_expr
), extended_env
);
1406 SCM um_bindings
= SCM_EOL
;
1407 while (!scm_is_null (um_names
))
1409 const SCM name
= SCM_CAR (um_names
);
1410 const SCM init
= SCM_CAR (um_inits
);
1411 SCM step
= SCM_CAR (um_steps
);
1412 step
= scm_is_eq (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
1414 um_bindings
= scm_cons (scm_cons2 (name
, init
, step
), um_bindings
);
1416 um_names
= SCM_CDR (um_names
);
1417 um_inits
= SCM_CDR (um_inits
);
1418 um_steps
= SCM_CDR (um_steps
);
1420 um_bindings
= scm_reverse_x (um_bindings
, SCM_UNDEFINED
);
1422 return scm_cons (scm_sym_do
,
1423 scm_cons2 (um_bindings
, um_exit_sequence
, um_body
));
1427 SCM_SYNTAX (s_if
, "if", scm_i_makbimacro
, scm_m_if
);
1428 SCM_GLOBAL_SYMBOL (scm_sym_if
, "if");
1431 scm_m_if (SCM expr
, SCM env SCM_UNUSED
)
1433 const SCM cdr_expr
= SCM_CDR (expr
);
1434 const long length
= scm_ilength (cdr_expr
);
1435 ASSERT_SYNTAX (length
== 2 || length
== 3, s_expression
, expr
);
1436 SCM_SETCAR (expr
, SCM_IM_IF
);
1441 unmemoize_if (const SCM expr
, const SCM env
)
1443 const SCM cdr_expr
= SCM_CDR (expr
);
1444 const SCM um_condition
= unmemoize_expression (SCM_CAR (cdr_expr
), env
);
1445 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1446 const SCM um_then
= unmemoize_expression (SCM_CAR (cddr_expr
), env
);
1447 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
1449 if (scm_is_null (cdddr_expr
))
1451 return scm_list_3 (scm_sym_if
, um_condition
, um_then
);
1455 const SCM um_else
= unmemoize_expression (SCM_CAR (cdddr_expr
), env
);
1456 return scm_list_4 (scm_sym_if
, um_condition
, um_then
, um_else
);
1461 SCM_SYNTAX (s_lambda
, "lambda", scm_i_makbimacro
, scm_m_lambda
);
1462 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, "lambda");
1464 /* A helper function for memoize_lambda to support checking for duplicate
1465 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
1466 * LIST or to the cdr of the last cons. Therefore, LIST may have any of the
1467 * forms that a formal argument can have:
1468 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
1470 c_improper_memq (SCM obj
, SCM list
)
1472 for (; scm_is_pair (list
); list
= SCM_CDR (list
))
1474 if (scm_is_eq (SCM_CAR (list
), obj
))
1477 return scm_is_eq (list
, obj
);
1481 scm_m_lambda (SCM expr
, SCM env SCM_UNUSED
)
1490 const SCM cdr_expr
= SCM_CDR (expr
);
1491 const long length
= scm_ilength (cdr_expr
);
1492 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1493 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1495 /* Before iterating the list of formal arguments, make sure the formals
1496 * actually are given as either a symbol or a non-cyclic list. */
1497 formals
= SCM_CAR (cdr_expr
);
1498 if (scm_is_pair (formals
))
1500 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
1501 * detected, report a 'Bad formals' error. */
1505 ASSERT_SYNTAX_2 (scm_is_symbol (formals
) || scm_is_null (formals
),
1506 s_bad_formals
, formals
, expr
);
1509 /* Now iterate the list of formal arguments to check if all formals are
1510 * symbols, and that there are no duplicates. */
1511 formals_idx
= formals
;
1512 while (scm_is_pair (formals_idx
))
1514 const SCM formal
= SCM_CAR (formals_idx
);
1515 const SCM next_idx
= SCM_CDR (formals_idx
);
1516 ASSERT_SYNTAX_2 (scm_is_symbol (formal
), s_bad_formal
, formal
, expr
);
1517 ASSERT_SYNTAX_2 (!c_improper_memq (formal
, next_idx
),
1518 s_duplicate_formal
, formal
, expr
);
1519 formals_idx
= next_idx
;
1521 ASSERT_SYNTAX_2 (scm_is_null (formals_idx
) || scm_is_symbol (formals_idx
),
1522 s_bad_formal
, formals_idx
, expr
);
1524 /* Memoize the body. Keep a potential documentation string. */
1525 /* Dirk:FIXME:: We should probably extract the documentation string to
1526 * some external database. Otherwise it will slow down execution, since
1527 * the documentation string will have to be skipped with every execution
1528 * of the closure. */
1529 cddr_expr
= SCM_CDR (cdr_expr
);
1530 documentation
= (length
>= 3 && scm_is_string (SCM_CAR (cddr_expr
)));
1531 body
= documentation
? SCM_CDR (cddr_expr
) : cddr_expr
;
1532 new_body
= m_body (SCM_IM_LAMBDA
, body
);
1534 SCM_SETCAR (expr
, SCM_IM_LAMBDA
);
1536 SCM_SETCDR (cddr_expr
, new_body
);
1538 SCM_SETCDR (cdr_expr
, new_body
);
1543 unmemoize_lambda (const SCM expr
, const SCM env
)
1545 const SCM formals
= SCM_CADR (expr
);
1546 const SCM body
= SCM_CDDR (expr
);
1548 const SCM new_env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, env
);
1549 const SCM um_formals
= scm_i_finite_list_copy (formals
);
1550 const SCM um_body
= unmemoize_exprs (body
, new_env
);
1552 return scm_cons2 (scm_sym_lambda
, um_formals
, um_body
);
1556 /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
1558 check_bindings (const SCM bindings
, const SCM expr
)
1562 ASSERT_SYNTAX_2 (scm_ilength (bindings
) >= 0,
1563 s_bad_bindings
, bindings
, expr
);
1565 binding_idx
= bindings
;
1566 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1568 SCM name
; /* const */
1570 const SCM binding
= SCM_CAR (binding_idx
);
1571 ASSERT_SYNTAX_2 (scm_ilength (binding
) == 2,
1572 s_bad_binding
, binding
, expr
);
1574 name
= SCM_CAR (binding
);
1575 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
1580 /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
1581 * transformed to the lists (vn ... v2 v1) and (i1 i2 ... in). That is, the
1582 * variables are returned in a list with their order reversed, and the init
1583 * forms are returned in a list in the same order as they are given in the
1584 * bindings. If a duplicate variable name is detected, an error is
1587 transform_bindings (
1588 const SCM bindings
, const SCM expr
,
1589 SCM
*const rvarptr
, SCM
*const initptr
)
1591 SCM rvariables
= SCM_EOL
;
1592 SCM rinits
= SCM_EOL
;
1593 SCM binding_idx
= bindings
;
1594 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1596 const SCM binding
= SCM_CAR (binding_idx
);
1597 const SCM cdr_binding
= SCM_CDR (binding
);
1598 const SCM name
= SCM_CAR (binding
);
1599 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, rvariables
)),
1600 s_duplicate_binding
, name
, expr
);
1601 rvariables
= scm_cons (name
, rvariables
);
1602 rinits
= scm_cons (SCM_CAR (cdr_binding
), rinits
);
1604 *rvarptr
= rvariables
;
1605 *initptr
= scm_reverse_x (rinits
, SCM_UNDEFINED
);
1609 SCM_SYNTAX(s_let
, "let", scm_i_makbimacro
, scm_m_let
);
1610 SCM_GLOBAL_SYMBOL(scm_sym_let
, "let");
1612 /* This function is a helper function for memoize_let. It transforms
1613 * (let name ((var init) ...) body ...) into
1614 * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
1615 * and memoizes the expression. It is assumed that the caller has checked
1616 * that name is a symbol and that there are bindings and a body. */
1618 memoize_named_let (const SCM expr
, const SCM env SCM_UNUSED
)
1624 const SCM cdr_expr
= SCM_CDR (expr
);
1625 const SCM name
= SCM_CAR (cdr_expr
);
1626 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1627 const SCM bindings
= SCM_CAR (cddr_expr
);
1628 check_bindings (bindings
, expr
);
1630 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1631 variables
= scm_reverse_x (rvariables
, SCM_UNDEFINED
);
1634 const SCM let_body
= SCM_CDR (cddr_expr
);
1635 const SCM lambda_body
= m_body (SCM_IM_LET
, let_body
);
1636 const SCM lambda_tail
= scm_cons (variables
, lambda_body
);
1637 const SCM lambda_form
= scm_cons_source (expr
, scm_sym_lambda
, lambda_tail
);
1639 const SCM rvar
= scm_list_1 (name
);
1640 const SCM init
= scm_list_1 (lambda_form
);
1641 const SCM body
= m_body (SCM_IM_LET
, scm_list_1 (name
));
1642 const SCM letrec_tail
= scm_cons (rvar
, scm_cons (init
, body
));
1643 const SCM letrec_form
= scm_cons_source (expr
, SCM_IM_LETREC
, letrec_tail
);
1644 return scm_cons_source (expr
, letrec_form
, inits
);
1648 /* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1649 * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
1651 scm_m_let (SCM expr
, SCM env
)
1655 const SCM cdr_expr
= SCM_CDR (expr
);
1656 const long length
= scm_ilength (cdr_expr
);
1657 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1658 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1660 bindings
= SCM_CAR (cdr_expr
);
1661 if (scm_is_symbol (bindings
))
1663 ASSERT_SYNTAX (length
>= 3, s_missing_expression
, expr
);
1664 return memoize_named_let (expr
, env
);
1667 check_bindings (bindings
, expr
);
1668 if (scm_is_null (bindings
) || scm_is_null (SCM_CDR (bindings
)))
1670 /* Special case: no bindings or single binding => let* is faster. */
1671 const SCM body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1672 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), bindings
, body
), env
);
1679 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1682 const SCM new_body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1683 const SCM new_tail
= scm_cons2 (rvariables
, inits
, new_body
);
1684 SCM_SETCAR (expr
, SCM_IM_LET
);
1685 SCM_SETCDR (expr
, new_tail
);
1692 build_binding_list (SCM rnames
, SCM rinits
)
1694 SCM bindings
= SCM_EOL
;
1695 while (!scm_is_null (rnames
))
1697 const SCM binding
= scm_list_2 (SCM_CAR (rnames
), SCM_CAR (rinits
));
1698 bindings
= scm_cons (binding
, bindings
);
1699 rnames
= SCM_CDR (rnames
);
1700 rinits
= SCM_CDR (rinits
);
1706 unmemoize_let (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
), 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_let
, um_bindings
, um_body
);
1721 SCM_SYNTAX(s_letrec
, "letrec", scm_i_makbimacro
, scm_m_letrec
);
1722 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, "letrec");
1725 scm_m_letrec (SCM expr
, SCM env
)
1729 const SCM cdr_expr
= SCM_CDR (expr
);
1730 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1731 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1733 bindings
= SCM_CAR (cdr_expr
);
1734 if (scm_is_null (bindings
))
1736 /* no bindings, let* is executed faster */
1737 SCM body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1738 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), SCM_EOL
, body
), env
);
1746 check_bindings (bindings
, expr
);
1747 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1748 new_body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1749 return scm_cons2 (SCM_IM_LETREC
, rvariables
, scm_cons (inits
, new_body
));
1754 unmemoize_letrec (const SCM expr
, const SCM env
)
1756 const SCM cdr_expr
= SCM_CDR (expr
);
1757 const SCM um_rnames
= SCM_CAR (cdr_expr
);
1758 const SCM extended_env
= SCM_EXTEND_ENV (um_rnames
, SCM_EOL
, env
);
1759 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1760 const SCM um_inits
= unmemoize_exprs (SCM_CAR (cddr_expr
), extended_env
);
1761 const SCM um_rinits
= scm_reverse_x (um_inits
, SCM_UNDEFINED
);
1762 const SCM um_bindings
= build_binding_list (um_rnames
, um_rinits
);
1763 const SCM um_body
= unmemoize_exprs (SCM_CDR (cddr_expr
), extended_env
);
1765 return scm_cons2 (scm_sym_letrec
, um_bindings
, um_body
);
1770 SCM_SYNTAX (s_letstar
, "let*", scm_i_makbimacro
, scm_m_letstar
);
1771 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, "let*");
1773 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1774 * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
1776 scm_m_letstar (SCM expr
, SCM env SCM_UNUSED
)
1781 const SCM cdr_expr
= SCM_CDR (expr
);
1782 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1783 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1785 binding_idx
= SCM_CAR (cdr_expr
);
1786 check_bindings (binding_idx
, expr
);
1788 /* Transform ((v1 i1) (v2 i2) ...) into (v1 i1 v2 i2 ...). The
1789 * transformation is done in place. At the beginning of one iteration of
1790 * the loop the variable binding_idx holds the form
1791 * P1:( (vn . P2:(in . ())) . P3:( (vn+1 in+1) ... ) ),
1792 * where P1, P2 and P3 indicate the pairs, that are relevant for the
1793 * transformation. P1 and P2 are modified in the loop, P3 remains
1794 * untouched. After the execution of the loop, P1 will hold
1795 * P1:( vn . P2:(in . P3:( (vn+1 in+1) ... )) )
1796 * and binding_idx will hold P3. */
1797 while (!scm_is_null (binding_idx
))
1799 const SCM cdr_binding_idx
= SCM_CDR (binding_idx
); /* remember P3 */
1800 const SCM binding
= SCM_CAR (binding_idx
);
1801 const SCM name
= SCM_CAR (binding
);
1802 const SCM cdr_binding
= SCM_CDR (binding
);
1804 SCM_SETCDR (cdr_binding
, cdr_binding_idx
); /* update P2 */
1805 SCM_SETCAR (binding_idx
, name
); /* update P1 */
1806 SCM_SETCDR (binding_idx
, cdr_binding
); /* update P1 */
1808 binding_idx
= cdr_binding_idx
; /* continue with P3 */
1811 new_body
= m_body (SCM_IM_LETSTAR
, SCM_CDR (cdr_expr
));
1812 SCM_SETCAR (expr
, SCM_IM_LETSTAR
);
1813 /* the bindings have been changed in place */
1814 SCM_SETCDR (cdr_expr
, new_body
);
1819 unmemoize_letstar (const SCM expr
, const SCM env
)
1821 const SCM cdr_expr
= SCM_CDR (expr
);
1822 const SCM body
= SCM_CDR (cdr_expr
);
1823 SCM bindings
= SCM_CAR (cdr_expr
);
1824 SCM um_bindings
= SCM_EOL
;
1825 SCM extended_env
= env
;
1828 while (!scm_is_null (bindings
))
1830 const SCM variable
= SCM_CAR (bindings
);
1831 const SCM init
= SCM_CADR (bindings
);
1832 const SCM um_init
= unmemoize_expression (init
, extended_env
);
1833 um_bindings
= scm_cons (scm_list_2 (variable
, um_init
), um_bindings
);
1834 extended_env
= SCM_EXTEND_ENV (variable
, SCM_BOOL_F
, extended_env
);
1835 bindings
= SCM_CDDR (bindings
);
1837 um_bindings
= scm_reverse_x (um_bindings
, SCM_UNDEFINED
);
1839 um_body
= unmemoize_exprs (body
, extended_env
);
1841 return scm_cons2 (scm_sym_letstar
, um_bindings
, um_body
);
1845 SCM_SYNTAX (s_or
, "or", scm_i_makbimacro
, scm_m_or
);
1846 SCM_GLOBAL_SYMBOL (scm_sym_or
, "or");
1849 scm_m_or (SCM expr
, SCM env SCM_UNUSED
)
1851 const SCM cdr_expr
= SCM_CDR (expr
);
1852 const long length
= scm_ilength (cdr_expr
);
1854 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1858 /* Special case: (or) is replaced by #f. */
1863 SCM_SETCAR (expr
, SCM_IM_OR
);
1869 unmemoize_or (const SCM expr
, const SCM env
)
1871 return scm_cons (scm_sym_or
, unmemoize_exprs (SCM_CDR (expr
), env
));
1875 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
1876 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, "quasiquote");
1877 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
1878 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
1880 /* Internal function to handle a quasiquotation: 'form' is the parameter in
1881 * the call (quasiquotation form), 'env' is the environment where unquoted
1882 * expressions will be evaluated, and 'depth' is the current quasiquotation
1883 * nesting level and is known to be greater than zero. */
1885 iqq (SCM form
, SCM env
, unsigned long int depth
)
1887 if (scm_is_pair (form
))
1889 const SCM tmp
= SCM_CAR (form
);
1890 if (scm_is_eq (tmp
, scm_sym_quasiquote
))
1892 const SCM args
= SCM_CDR (form
);
1893 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1894 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
1896 else if (scm_is_eq (tmp
, scm_sym_unquote
))
1898 const SCM args
= SCM_CDR (form
);
1899 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1901 return scm_eval_car (args
, env
);
1903 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
1905 else if (scm_is_pair (tmp
)
1906 && scm_is_eq (SCM_CAR (tmp
), scm_sym_uq_splicing
))
1908 const SCM args
= SCM_CDR (tmp
);
1909 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1912 const SCM list
= scm_eval_car (args
, env
);
1913 const SCM rest
= SCM_CDR (form
);
1914 ASSERT_SYNTAX_2 (scm_ilength (list
) >= 0,
1915 s_splicing
, list
, form
);
1916 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
1919 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
1920 iqq (SCM_CDR (form
), env
, depth
));
1923 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
1924 iqq (SCM_CDR (form
), env
, depth
));
1926 else if (scm_is_vector (form
))
1927 return scm_vector (iqq (scm_vector_to_list (form
), env
, depth
));
1933 scm_m_quasiquote (SCM expr
, SCM env
)
1935 const SCM cdr_expr
= SCM_CDR (expr
);
1936 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1937 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1938 return iqq (SCM_CAR (cdr_expr
), env
, 1);
1942 SCM_SYNTAX (s_quote
, "quote", scm_i_makbimacro
, scm_m_quote
);
1943 SCM_GLOBAL_SYMBOL (scm_sym_quote
, "quote");
1946 scm_m_quote (SCM expr
, SCM env SCM_UNUSED
)
1950 const SCM cdr_expr
= SCM_CDR (expr
);
1951 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1952 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1953 quotee
= SCM_CAR (cdr_expr
);
1954 if (is_self_quoting_p (quotee
))
1957 SCM_SETCAR (expr
, SCM_IM_QUOTE
);
1958 SCM_SETCDR (expr
, quotee
);
1963 unmemoize_quote (const SCM expr
, const SCM env SCM_UNUSED
)
1965 return scm_list_2 (scm_sym_quote
, SCM_CDR (expr
));
1969 /* Will go into the RnRS module when Guile is factorized.
1970 SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
1971 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, "set!");
1974 scm_m_set_x (SCM expr
, SCM env SCM_UNUSED
)
1979 const SCM cdr_expr
= SCM_CDR (expr
);
1980 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1981 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1982 variable
= SCM_CAR (cdr_expr
);
1984 /* Memoize the variable form. */
1985 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
1986 new_variable
= lookup_symbol (variable
, env
);
1987 /* Leave the memoization of unbound symbols to lazy memoization: */
1988 if (SCM_UNBNDP (new_variable
))
1989 new_variable
= variable
;
1991 SCM_SETCAR (expr
, SCM_IM_SET_X
);
1992 SCM_SETCAR (cdr_expr
, new_variable
);
1997 unmemoize_set_x (const SCM expr
, const SCM env
)
1999 return scm_cons (scm_sym_set_x
, unmemoize_exprs (SCM_CDR (expr
), env
));
2004 /* Start of the memoizers for non-R5RS builtin macros. */
2007 SCM_SYNTAX (s_at
, "@", scm_makmmacro
, scm_m_at
);
2008 SCM_GLOBAL_SYMBOL (scm_sym_at
, "@");
2011 scm_m_at (SCM expr
, SCM env SCM_UNUSED
)
2014 ASSERT_SYNTAX (scm_ilength (expr
) == 3, s_bad_expression
, expr
);
2015 ASSERT_SYNTAX (scm_ilength (scm_cadr (expr
)) > 0, s_bad_expression
, expr
);
2016 ASSERT_SYNTAX (scm_is_symbol (scm_caddr (expr
)), s_bad_expression
, expr
);
2018 mod
= scm_resolve_module (scm_cadr (expr
));
2019 if (scm_is_false (mod
))
2020 error_unbound_variable (expr
);
2021 var
= scm_module_variable (scm_module_public_interface (mod
), scm_caddr (expr
));
2022 if (scm_is_false (var
))
2023 error_unbound_variable (expr
);
2028 SCM_SYNTAX (s_atat
, "@@", scm_makmmacro
, scm_m_atat
);
2029 SCM_GLOBAL_SYMBOL (scm_sym_atat
, "@@");
2032 scm_m_atat (SCM expr
, SCM env SCM_UNUSED
)
2035 ASSERT_SYNTAX (scm_ilength (expr
) == 3, s_bad_expression
, expr
);
2036 ASSERT_SYNTAX (scm_ilength (scm_cadr (expr
)) > 0, s_bad_expression
, expr
);
2037 ASSERT_SYNTAX (scm_is_symbol (scm_caddr (expr
)), s_bad_expression
, expr
);
2039 mod
= scm_resolve_module (scm_cadr (expr
));
2040 if (scm_is_false (mod
))
2041 error_unbound_variable (expr
);
2042 var
= scm_module_variable (mod
, scm_caddr (expr
));
2043 if (scm_is_false (var
))
2044 error_unbound_variable (expr
);
2049 SCM_SYNTAX (s_atapply
, "@apply", scm_i_makbimacro
, scm_m_apply
);
2050 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, "@apply");
2051 SCM_GLOBAL_SYMBOL (scm_sym_apply
, "apply");
2054 scm_m_apply (SCM expr
, SCM env SCM_UNUSED
)
2056 const SCM cdr_expr
= SCM_CDR (expr
);
2057 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2058 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_missing_expression
, expr
);
2060 SCM_SETCAR (expr
, SCM_IM_APPLY
);
2065 unmemoize_apply (const SCM expr
, const SCM env
)
2067 return scm_list_2 (scm_sym_atapply
, unmemoize_exprs (SCM_CDR (expr
), env
));
2071 SCM_SYNTAX (s_atbind
, "@bind", scm_i_makbimacro
, scm_m_atbind
);
2073 /* FIXME: The following explanation should go into the documentation: */
2074 /* (@bind ((var init) ...) body ...) will assign the values of the `init's to
2075 * the global variables named by `var's (symbols, not evaluated), creating
2076 * them if they don't exist, executes body, and then restores the previous
2077 * values of the `var's. Additionally, whenever control leaves body, the
2078 * values of the `var's are saved and restored when control returns. It is an
2079 * error when a symbol appears more than once among the `var's. All `init's
2080 * are evaluated before any `var' is set.
2082 * Think of this as `let' for dynamic scope.
2085 /* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into
2086 * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...).
2088 * FIXME - also implement `@bind*'.
2091 scm_m_atbind (SCM expr
, SCM env
)
2098 const SCM top_level
= scm_env_top_level (env
);
2100 const SCM cdr_expr
= SCM_CDR (expr
);
2101 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2102 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
2103 bindings
= SCM_CAR (cdr_expr
);
2104 check_bindings (bindings
, expr
);
2105 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
2107 for (variable_idx
= rvariables
;
2108 !scm_is_null (variable_idx
);
2109 variable_idx
= SCM_CDR (variable_idx
))
2111 /* The first call to scm_sym2var will look beyond the current module,
2112 * while the second call wont. */
2113 const SCM variable
= SCM_CAR (variable_idx
);
2114 SCM new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_F
);
2115 if (scm_is_false (new_variable
))
2116 new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_T
);
2117 SCM_SETCAR (variable_idx
, new_variable
);
2120 SCM_SETCAR (expr
, SCM_IM_BIND
);
2121 SCM_SETCAR (cdr_expr
, scm_cons (rvariables
, inits
));
2126 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_i_makbimacro
, scm_m_cont
);
2127 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, "@call-with-current-continuation");
2130 scm_m_cont (SCM expr
, SCM env SCM_UNUSED
)
2132 const SCM cdr_expr
= SCM_CDR (expr
);
2133 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2134 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2136 SCM_SETCAR (expr
, SCM_IM_CONT
);
2141 unmemoize_atcall_cc (const SCM expr
, const SCM env
)
2143 return scm_list_2 (scm_sym_atcall_cc
, unmemoize_exprs (SCM_CDR (expr
), env
));
2147 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_i_makbimacro
, scm_m_at_call_with_values
);
2148 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, "@call-with-values");
2151 scm_m_at_call_with_values (SCM expr
, SCM env SCM_UNUSED
)
2153 const SCM cdr_expr
= SCM_CDR (expr
);
2154 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2155 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2157 SCM_SETCAR (expr
, SCM_IM_CALL_WITH_VALUES
);
2162 unmemoize_at_call_with_values (const SCM expr
, const SCM env
)
2164 return scm_list_2 (scm_sym_at_call_with_values
,
2165 unmemoize_exprs (SCM_CDR (expr
), env
));
2168 SCM_SYNTAX (s_eval_when
, "eval-when", scm_makmmacro
, scm_m_eval_when
);
2169 SCM_GLOBAL_SYMBOL (scm_sym_eval_when
, "eval-when");
2170 SCM_SYMBOL (sym_eval
, "eval");
2171 SCM_SYMBOL (sym_load
, "load");
2175 scm_m_eval_when (SCM expr
, SCM env SCM_UNUSED
)
2177 ASSERT_SYNTAX (scm_ilength (expr
) >= 3, s_bad_expression
, expr
);
2178 ASSERT_SYNTAX (scm_ilength (scm_cadr (expr
)) > 0, s_bad_expression
, expr
);
2180 if (scm_is_true (scm_memq (sym_eval
, scm_cadr (expr
)))
2181 || scm_is_true (scm_memq (sym_load
, scm_cadr (expr
))))
2182 return scm_cons (SCM_IM_BEGIN
, scm_cddr (expr
));
2184 return scm_list_1 (SCM_IM_BEGIN
);
2187 SCM_SYNTAX (s_gset_x
, "set!", scm_i_makbimacro
, scm_m_generalized_set_x
);
2188 SCM_SYMBOL (scm_sym_setter
, "setter");
2191 scm_m_generalized_set_x (SCM expr
, SCM env
)
2193 SCM target
, exp_target
;
2195 const SCM cdr_expr
= SCM_CDR (expr
);
2196 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2197 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2199 target
= SCM_CAR (cdr_expr
);
2200 if (!scm_is_pair (target
))
2203 return scm_m_set_x (expr
, env
);
2207 /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */
2208 /* Macroexpanding the target might return things of the form
2209 (begin <atom>). In that case, <atom> must be a symbol or a
2210 variable and we memoize to (set! <atom> ...).
2212 exp_target
= macroexp (target
, env
);
2213 if (scm_is_eq (SCM_CAR (exp_target
), SCM_IM_BEGIN
)
2214 && !scm_is_null (SCM_CDR (exp_target
))
2215 && scm_is_null (SCM_CDDR (exp_target
)))
2217 exp_target
= SCM_CADR (exp_target
);
2218 ASSERT_SYNTAX_2 (scm_is_symbol (exp_target
)
2219 || SCM_VARIABLEP (exp_target
),
2220 s_bad_variable
, exp_target
, expr
);
2221 return scm_cons (SCM_IM_SET_X
, scm_cons (exp_target
,
2222 SCM_CDR (cdr_expr
)));
2226 const SCM setter_proc_tail
= scm_list_1 (SCM_CAR (target
));
2227 const SCM setter_proc
= scm_cons_source (expr
, scm_sym_setter
,
2230 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
2231 const SCM setter_args
= scm_append_x (scm_list_2 (SCM_CDR (target
),
2234 SCM_SETCAR (expr
, setter_proc
);
2235 SCM_SETCDR (expr
, setter_args
);
2242 /* @slot-ref is bound privately in the (oop goops) module from goops.c. As
2243 * soon as the module system allows us to more freely create bindings in
2244 * arbitrary modules during the startup phase, the code from goops.c should be
2247 SCM_SYNTAX (s_atslot_ref
, "@slot-ref", scm_i_makbimacro
, scm_m_atslot_ref
);
2248 SCM_SYNTAX (s_atslot_set_x
, "@slot-set!", scm_i_makbimacro
, scm_m_atslot_set_x
);
2249 SCM_SYMBOL (sym_atslot_ref
, "@slot-ref");
2252 scm_m_atslot_ref (SCM expr
, SCM env SCM_UNUSED
)
2256 const SCM cdr_expr
= SCM_CDR (expr
);
2257 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2258 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2259 slot_nr
= SCM_CADR (cdr_expr
);
2260 ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2262 SCM_SETCAR (expr
, SCM_IM_SLOT_REF
);
2263 SCM_SETCDR (cdr_expr
, slot_nr
);
2268 unmemoize_atslot_ref (const SCM expr
, const SCM env
)
2270 const SCM instance
= SCM_CADR (expr
);
2271 const SCM um_instance
= unmemoize_expression (instance
, env
);
2272 const SCM slot_nr
= SCM_CDDR (expr
);
2273 return scm_list_3 (sym_atslot_ref
, um_instance
, slot_nr
);
2277 /* @slot-set! is bound privately in the (oop goops) module from goops.c. As
2278 * soon as the module system allows us to more freely create bindings in
2279 * arbitrary modules during the startup phase, the code from goops.c should be
2282 SCM_SYMBOL (sym_atslot_set_x
, "@slot-set!");
2285 scm_m_atslot_set_x (SCM expr
, SCM env SCM_UNUSED
)
2289 const SCM cdr_expr
= SCM_CDR (expr
);
2290 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2291 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 3, s_expression
, expr
);
2292 slot_nr
= SCM_CADR (cdr_expr
);
2293 ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2295 SCM_SETCAR (expr
, SCM_IM_SLOT_SET_X
);
2300 unmemoize_atslot_set_x (const SCM expr
, const SCM env
)
2302 const SCM cdr_expr
= SCM_CDR (expr
);
2303 const SCM instance
= SCM_CAR (cdr_expr
);
2304 const SCM um_instance
= unmemoize_expression (instance
, env
);
2305 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
2306 const SCM slot_nr
= SCM_CAR (cddr_expr
);
2307 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
2308 const SCM value
= SCM_CAR (cdddr_expr
);
2309 const SCM um_value
= unmemoize_expression (value
, env
);
2310 return scm_list_4 (sym_atslot_set_x
, um_instance
, slot_nr
, um_value
);
2314 #if SCM_ENABLE_ELISP
2316 static const char s_defun
[] = "Symbol's function definition is void";
2318 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_i_makbimacro
, scm_m_nil_cond
);
2320 /* nil-cond expressions have the form
2321 * (nil-cond COND VAL COND VAL ... ELSEVAL) */
2323 scm_m_nil_cond (SCM expr
, SCM env SCM_UNUSED
)
2325 const long length
= scm_ilength (SCM_CDR (expr
));
2326 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
2327 ASSERT_SYNTAX (length
>= 1 && (length
% 2) == 1, s_expression
, expr
);
2329 SCM_SETCAR (expr
, SCM_IM_NIL_COND
);
2334 SCM_SYNTAX (s_atfop
, "@fop", scm_i_makbimacro
, scm_m_atfop
);
2336 /* The @fop-macro handles procedure and macro applications for elisp. The
2337 * input expression must have the form
2338 * (@fop <var> (transformer-macro <expr> ...))
2339 * where <var> must be a symbol. The expression is transformed into the
2340 * memoized form of either
2341 * (apply <un-aliased var> (transformer-macro <expr> ...))
2342 * if the value of var (across all aliasing) is not a macro, or
2343 * (<un-aliased var> <expr> ...)
2344 * if var is a macro. */
2346 scm_m_atfop (SCM expr
, SCM env SCM_UNUSED
)
2351 const SCM cdr_expr
= SCM_CDR (expr
);
2352 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2353 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 1, s_missing_expression
, expr
);
2355 symbol
= SCM_CAR (cdr_expr
);
2356 ASSERT_SYNTAX_2 (scm_is_symbol (symbol
), s_bad_variable
, symbol
, expr
);
2358 location
= scm_symbol_fref (symbol
);
2359 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2361 /* The elisp function `defalias' allows to define aliases for symbols. To
2362 * look up such definitions, the chain of symbol definitions has to be
2363 * followed up to the terminal symbol. */
2364 while (scm_is_symbol (SCM_VARIABLE_REF (location
)))
2366 const SCM alias
= SCM_VARIABLE_REF (location
);
2367 location
= scm_symbol_fref (alias
);
2368 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2371 /* Memoize the value location belonging to the terminal symbol. */
2372 SCM_SETCAR (cdr_expr
, location
);
2374 if (!SCM_MACROP (SCM_VARIABLE_REF (location
)))
2376 /* Since the location does not contain a macro, the form is a procedure
2377 * application. Replace `@fop' by `@apply' and transform the expression
2378 * including the `transformer-macro'. */
2379 SCM_SETCAR (expr
, SCM_IM_APPLY
);
2384 /* Since the location contains a macro, the arguments should not be
2385 * transformed, so the `transformer-macro' is cut out. The resulting
2386 * expression starts with the memoized variable, that is at the cdr of
2387 * the input expression. */
2388 SCM_SETCDR (cdr_expr
, SCM_CDADR (cdr_expr
));
2393 #endif /* SCM_ENABLE_ELISP */
2397 unmemoize_builtin_macro (const SCM expr
, const SCM env
)
2399 switch (ISYMNUM (SCM_CAR (expr
)))
2401 case (ISYMNUM (SCM_IM_AND
)):
2402 return unmemoize_and (expr
, env
);
2404 case (ISYMNUM (SCM_IM_BEGIN
)):
2405 return unmemoize_begin (expr
, env
);
2407 case (ISYMNUM (SCM_IM_CASE
)):
2408 return unmemoize_case (expr
, env
);
2410 case (ISYMNUM (SCM_IM_COND
)):
2411 return unmemoize_cond (expr
, env
);
2413 case (ISYMNUM (SCM_IM_DELAY
)):
2414 return unmemoize_delay (expr
, env
);
2416 case (ISYMNUM (SCM_IM_DO
)):
2417 return unmemoize_do (expr
, env
);
2419 case (ISYMNUM (SCM_IM_IF
)):
2420 return unmemoize_if (expr
, env
);
2422 case (ISYMNUM (SCM_IM_LAMBDA
)):
2423 return unmemoize_lambda (expr
, env
);
2425 case (ISYMNUM (SCM_IM_LET
)):
2426 return unmemoize_let (expr
, env
);
2428 case (ISYMNUM (SCM_IM_LETREC
)):
2429 return unmemoize_letrec (expr
, env
);
2431 case (ISYMNUM (SCM_IM_LETSTAR
)):
2432 return unmemoize_letstar (expr
, env
);
2434 case (ISYMNUM (SCM_IM_OR
)):
2435 return unmemoize_or (expr
, env
);
2437 case (ISYMNUM (SCM_IM_QUOTE
)):
2438 return unmemoize_quote (expr
, env
);
2440 case (ISYMNUM (SCM_IM_SET_X
)):
2441 return unmemoize_set_x (expr
, env
);
2443 case (ISYMNUM (SCM_IM_APPLY
)):
2444 return unmemoize_apply (expr
, env
);
2446 case (ISYMNUM (SCM_IM_BIND
)):
2447 return unmemoize_exprs (expr
, env
); /* FIXME */
2449 case (ISYMNUM (SCM_IM_CONT
)):
2450 return unmemoize_atcall_cc (expr
, env
);
2452 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2453 return unmemoize_at_call_with_values (expr
, env
);
2455 case (ISYMNUM (SCM_IM_SLOT_REF
)):
2456 return unmemoize_atslot_ref (expr
, env
);
2458 case (ISYMNUM (SCM_IM_SLOT_SET_X
)):
2459 return unmemoize_atslot_set_x (expr
, env
);
2461 case (ISYMNUM (SCM_IM_NIL_COND
)):
2462 return unmemoize_exprs (expr
, env
); /* FIXME */
2465 return unmemoize_exprs (expr
, env
); /* FIXME */
2470 /* scm_i_unmemocopy_expr and scm_i_unmemocopy_body take a memoized expression
2471 * respectively a memoized body together with its environment and rewrite it
2472 * to its original form. Thus, these functions are the inversion of the
2473 * rewrite rules above. The procedure is not optimized for speed. It's used
2474 * in scm_i_unmemoize_expr, scm_procedure_source, macro_print and scm_iprin1.
2476 * Unmemoizing is not a reliable process. You cannot in general expect to get
2477 * the original source back.
2479 * However, GOOPS currently relies on this for method compilation. This ought
2483 scm_i_unmemocopy_expr (SCM expr
, SCM env
)
2485 const SCM source_properties
= scm_whash_lookup (scm_source_whash
, expr
);
2486 const SCM um_expr
= unmemoize_expression (expr
, env
);
2488 if (scm_is_true (source_properties
))
2489 scm_whash_insert (scm_source_whash
, um_expr
, source_properties
);
2495 scm_i_unmemocopy_body (SCM forms
, SCM env
)
2497 const SCM source_properties
= scm_whash_lookup (scm_source_whash
, forms
);
2498 const SCM um_forms
= unmemoize_exprs (forms
, env
);
2500 if (scm_is_true (source_properties
))
2501 scm_whash_insert (scm_source_whash
, um_forms
, source_properties
);
2507 #if (SCM_ENABLE_DEPRECATED == 1)
2509 static SCM
scm_m_undefine (SCM expr
, SCM env
);
2511 SCM_SYNTAX (s_undefine
, "undefine", scm_makacro
, scm_m_undefine
);
2514 scm_m_undefine (SCM expr
, SCM env
)
2519 const SCM cdr_expr
= SCM_CDR (expr
);
2520 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), "Bad undefine placement in", expr
);
2521 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2522 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2524 scm_c_issue_deprecation_warning
2525 ("`undefine' is deprecated.\n");
2527 variable
= SCM_CAR (cdr_expr
);
2528 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
2529 location
= scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_F
);
2530 ASSERT_SYNTAX_2 (scm_is_true (location
)
2531 && !SCM_UNBNDP (SCM_VARIABLE_REF (location
)),
2532 "variable already unbound ", variable
, expr
);
2533 SCM_VARIABLE_SET (location
, SCM_UNDEFINED
);
2534 return SCM_UNSPECIFIED
;
2537 #endif /* SCM_ENABLE_DEPRECATED */
2541 /*****************************************************************************/
2542 /*****************************************************************************/
2543 /* The definitions for execution start here. */
2544 /*****************************************************************************/
2545 /*****************************************************************************/
2547 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
2548 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
2549 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
2550 SCM_GLOBAL_SYMBOL (scm_sym_memoize_symbol
, "memoize-symbol");
2551 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
2552 SCM_SYMBOL (sym_instead
, "instead");
2554 /* A function object to implement "apply" for non-closure functions. */
2556 /* An endless list consisting of #<undefined> objects: */
2557 static SCM undefineds
;
2561 scm_badargsp (SCM formals
, SCM args
)
2563 while (!scm_is_null (formals
))
2565 if (!scm_is_pair (formals
))
2567 if (scm_is_null (args
))
2569 formals
= SCM_CDR (formals
);
2570 args
= SCM_CDR (args
);
2572 return !scm_is_null (args
) ? 1 : 0;
2577 /* The evaluator contains a plethora of EVAL symbols.
2580 * EVALIM is used when it is known that the expression is an
2581 * immediate. (This macro never calls an evaluator.)
2583 * EVAL evaluates an expression that is expected to have its symbols already
2584 * memoized. Expressions that are not of the form '(<form> <form> ...)' are
2585 * evaluated inline without calling an evaluator.
2587 * EVALCAR evaluates the car of an expression 'X:(Y:<form> <form> ...)',
2588 * potentially replacing a symbol at the position Y:<form> by its memoized
2589 * variable. If Y:<form> is not of the form '(<form> <form> ...)', the
2590 * evaluation is performed inline without calling an evaluator.
2594 #define EVALIM2(x) \
2595 ((scm_is_eq ((x), SCM_EOL) \
2596 ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \
2600 #define EVALIM(x, env) (SCM_ILOCP (x) \
2601 ? *scm_ilookup ((x), (env)) \
2604 #define EVAL(x, env) \
2607 : (SCM_VARIABLEP (x) \
2608 ? SCM_VARIABLE_REF (x) \
2609 : (scm_is_pair (x) \
2610 ? eval ((x), (env)) \
2613 #define EVALCAR(x, env) \
2614 (SCM_IMP (SCM_CAR (x)) \
2615 ? EVALIM (SCM_CAR (x), (env)) \
2616 : (SCM_VARIABLEP (SCM_CAR (x)) \
2617 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2618 : (scm_is_pair (SCM_CAR (x)) \
2619 ? eval (SCM_CAR (x), (env)) \
2620 : (!scm_is_symbol (SCM_CAR (x)) \
2622 : *scm_lookupcar ((x), (env), 1)))))
2624 scm_i_pthread_mutex_t source_mutex
;
2627 /* Lookup a given local variable in an environment. The local variable is
2628 * given as an iloc, that is a triple <frame, binding, last?>, where frame
2629 * indicates the relative number of the environment frame (counting upwards
2630 * from the innermost environment frame), binding indicates the number of the
2631 * binding within the frame, and last? (which is extracted from the iloc using
2632 * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
2633 * very end of the improper list of bindings. */
2635 scm_ilookup (SCM iloc
, SCM env
)
2637 unsigned int frame_nr
= SCM_IFRAME (iloc
);
2638 unsigned int binding_nr
= SCM_IDIST (iloc
);
2642 for (; 0 != frame_nr
; --frame_nr
)
2643 frames
= SCM_CDR (frames
);
2645 bindings
= SCM_CAR (frames
);
2646 for (; 0 != binding_nr
; --binding_nr
)
2647 bindings
= SCM_CDR (bindings
);
2649 if (SCM_ICDRP (iloc
))
2650 return SCM_CDRLOC (bindings
);
2651 return SCM_CARLOC (SCM_CDR (bindings
));
2655 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
2657 /* Call this for variables that are unfound.
2660 error_unbound_variable (SCM symbol
)
2662 scm_error (scm_unbound_variable_key
, NULL
,
2663 "Unbound variable: ~S",
2664 scm_list_1 (symbol
), SCM_BOOL_F
);
2667 /* Call this for variables that are found but contain SCM_UNDEFINED.
2670 error_defined_variable (SCM symbol
)
2672 /* We use the 'unbound-variable' key here as well, since it
2673 basically is the same kind of error, with a slight variation in
2674 the displayed message.
2676 scm_error (scm_unbound_variable_key
, NULL
,
2677 "Variable used before given a value: ~S",
2678 scm_list_1 (symbol
), SCM_BOOL_F
);
2682 /* The Lookup Car Race
2685 Memoization of variables and special forms is done while executing
2686 the code for the first time. As long as there is only one thread
2687 everything is fine, but as soon as two threads execute the same
2688 code concurrently `for the first time' they can come into conflict.
2690 This memoization includes rewriting variable references into more
2691 efficient forms and expanding macros. Furthermore, macro expansion
2692 includes `compiling' special forms like `let', `cond', etc. into
2693 tree-code instructions.
2695 There shouldn't normally be a problem with memoizing local and
2696 global variable references (into ilocs and variables), because all
2697 threads will mutate the code in *exactly* the same way and (if I
2698 read the C code correctly) it is not possible to observe a half-way
2699 mutated cons cell. The lookup procedure can handle this
2700 transparently without any critical sections.
2702 It is different with macro expansion, because macro expansion
2703 happens outside of the lookup procedure and can't be
2704 undone. Therefore the lookup procedure can't cope with it. It has
2705 to indicate failure when it detects a lost race and hope that the
2706 caller can handle it. Luckily, it turns out that this is the case.
2708 An example to illustrate this: Suppose that the following form will
2709 be memoized concurrently by two threads
2713 Let's first examine the lookup of X in the body. The first thread
2714 decides that it has to find the symbol "x" in the environment and
2715 starts to scan it. Then the other thread takes over and actually
2716 overtakes the first. It looks up "x" and substitutes an
2717 appropriate iloc for it. Now the first thread continues and
2718 completes its lookup. It comes to exactly the same conclusions as
2719 the second one and could - without much ado - just overwrite the
2720 iloc with the same iloc.
2722 But let's see what will happen when the race occurs while looking
2723 up the symbol "let" at the start of the form. It could happen that
2724 the second thread interrupts the lookup of the first thread and not
2725 only substitutes a variable for it but goes right ahead and
2726 replaces it with the compiled form (#@let* (x 12) x). Now, when
2727 the first thread completes its lookup, it would replace the #@let*
2728 with a variable containing the "let" binding, effectively reverting
2729 the form to (let (x 12) x). This is wrong. It has to detect that
2730 it has lost the race and the evaluator has to reconsider the
2731 changed form completely.
2733 This race condition could be resolved with some kind of traffic
2734 light (like mutexes) around scm_lookupcar, but I think that it is
2735 best to avoid them in this case. They would serialize memoization
2736 completely and because lookup involves calling arbitrary Scheme
2737 code (via the lookup-thunk), threads could be blocked for an
2738 arbitrary amount of time or even deadlock. But with the current
2739 solution a lot of unnecessary work is potentially done. */
2741 /* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
2742 return NULL to indicate a failed lookup due to some race conditions
2743 between threads. This only happens when VLOC is the first cell of
2744 a special form that will eventually be memoized (like `let', etc.)
2745 In that case the whole lookup is bogus and the caller has to
2746 reconsider the complete special form.
2748 SCM_LOOKUPCAR is still there, of course. It just calls
2749 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
2750 should only be called when it is known that VLOC is not the first
2751 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
2752 for NULL. I think I've found the only places where this
2756 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
2759 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
2760 register SCM iloc
= SCM_ILOC00
;
2761 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
2763 if (!scm_is_pair (SCM_CAR (env
)))
2765 al
= SCM_CARLOC (env
);
2766 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
2768 if (!scm_is_pair (fl
))
2770 if (scm_is_eq (fl
, var
))
2772 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2774 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
2775 return SCM_CDRLOC (*al
);
2780 al
= SCM_CDRLOC (*al
);
2781 if (scm_is_eq (SCM_CAR (fl
), var
))
2783 if (SCM_UNBNDP (SCM_CAR (*al
)))
2784 error_defined_variable (var
);
2785 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2787 SCM_SETCAR (vloc
, iloc
);
2788 return SCM_CARLOC (*al
);
2790 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
2792 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
2795 SCM top_thunk
, real_var
;
2798 top_thunk
= SCM_CAR (env
); /* env now refers to a
2799 top level env thunk */
2800 env
= SCM_CDR (env
);
2803 top_thunk
= SCM_BOOL_F
;
2804 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
2805 if (scm_is_false (real_var
))
2808 if (!scm_is_null (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
2813 if (scm_is_null (env
))
2814 error_unbound_variable (var
);
2816 scm_misc_error (NULL
, "Damaged environment: ~S",
2821 /* A variable could not be found, but we shall
2822 not throw an error. */
2823 static SCM undef_object
= SCM_UNDEFINED
;
2824 return &undef_object
;
2828 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2830 /* Some other thread has changed the very cell we are working
2831 on. In effect, it must have done our job or messed it up
2834 var
= SCM_CAR (vloc
);
2835 if (SCM_VARIABLEP (var
))
2836 return SCM_VARIABLE_LOC (var
);
2837 if (SCM_ILOCP (var
))
2838 return scm_ilookup (var
, genv
);
2839 /* We can't cope with anything else than variables and ilocs. When
2840 a special form has been memoized (i.e. `let' into `#@let') we
2841 return NULL and expect the calling function to do the right
2842 thing. For the evaluator, this means going back and redoing
2843 the dispatch on the car of the form. */
2847 SCM_SETCAR (vloc
, real_var
);
2848 return SCM_VARIABLE_LOC (real_var
);
2853 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
2855 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
2862 /* During execution, look up a symbol in the top level of the given local
2863 * environment and return the corresponding variable object. If no binding
2864 * for the symbol can be found, an 'Unbound variable' error is signalled. */
2866 lazy_memoize_variable (const SCM symbol
, const SCM environment
)
2868 const SCM top_level
= scm_env_top_level (environment
);
2869 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
2871 if (scm_is_false (variable
))
2872 error_unbound_variable (symbol
);
2879 scm_eval_car (SCM pair
, SCM env
)
2881 return EVALCAR (pair
, env
);
2886 scm_eval_body (SCM code
, SCM env
)
2891 next
= SCM_CDR (code
);
2892 while (!scm_is_null (next
))
2894 if (SCM_IMP (SCM_CAR (code
)))
2896 if (SCM_ISYMP (SCM_CAR (code
)))
2898 scm_dynwind_begin (0);
2899 scm_i_dynwind_pthread_mutex_lock (&source_mutex
);
2900 /* check for race condition */
2901 if (SCM_ISYMP (SCM_CAR (code
)))
2902 m_expand_body (code
, env
);
2908 EVAL (SCM_CAR (code
), env
);
2910 next
= SCM_CDR (code
);
2912 return EVALCAR (code
, env
);
2916 /* scm_last_debug_frame contains a pointer to the last debugging information
2917 * stack frame. It is accessed very often from the debugging evaluator, so it
2918 * should probably not be indirectly addressed. Better to save and restore it
2919 * from the current root at any stack swaps.
2922 /* scm_debug_eframe_size is the number of slots available for pseudo
2923 * stack frames at each real stack frame.
2926 long scm_debug_eframe_size
;
2928 int scm_debug_mode_p
;
2929 int scm_check_entry_p
;
2930 int scm_check_apply_p
;
2931 int scm_check_exit_p
;
2932 int scm_check_memoize_p
;
2934 long scm_eval_stack
;
2936 scm_t_option scm_eval_opts
[] = {
2937 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." },
2941 scm_t_option scm_debug_opts
[] = {
2942 { SCM_OPTION_BOOLEAN
, "cheap", 1,
2943 "*This option is now obsolete. Setting it has no effect." },
2944 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
2945 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
2946 { SCM_OPTION_BOOLEAN
, "procnames", 1,
2947 "Record procedure names at definition." },
2948 { SCM_OPTION_BOOLEAN
, "backwards", 0,
2949 "Display backtrace in anti-chronological order." },
2950 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
2951 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
2952 { SCM_OPTION_INTEGER
, "frames", 3,
2953 "Maximum number of tail-recursive frames in backtrace." },
2954 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
2955 "Maximal number of stored backtrace frames." },
2956 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
2957 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
2958 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
2959 /* This default stack limit will be overridden by debug.c:init_stack_limit(),
2960 if we have getrlimit() and the stack limit is not INFINITY. But it is still
2961 important, as some systems have both the soft and the hard limits set to
2962 INFINITY; in that case we fall back to this value.
2964 The situation is aggravated by certain compilers, which can consume
2965 "beaucoup de stack", as they say in France.
2967 See http://thread.gmane.org/gmane.lisp.guile.devel/8599/focus=8662 for
2968 more discussion. This setting is 640 KB on 32-bit arches (should be enough
2969 for anyone!) or a whoppin' 1280 KB on 64-bit arches.
2971 { SCM_OPTION_INTEGER
, "stack", 160000, "Stack size limit (measured in words; 0 = no check)." },
2972 { SCM_OPTION_SCM
, "show-file-name", (unsigned long)SCM_BOOL_T
,
2973 "Show file names and line numbers "
2974 "in backtraces when not `#f'. A value of `base' "
2975 "displays only base names, while `#t' displays full names."},
2976 { SCM_OPTION_BOOLEAN
, "warn-deprecated", 0,
2977 "Warn when deprecated features are used." },
2983 * this ordering is awkward and illogical, but we maintain it for
2984 * compatibility. --hwn
2986 scm_t_option scm_evaluator_trap_table
[] = {
2987 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
2988 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
2989 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
2990 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
2991 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
2992 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
2993 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." },
2994 { SCM_OPTION_BOOLEAN
, "memoize-symbol", 0, "Trap when memoizing a symbol." },
2995 { SCM_OPTION_SCM
, "memoize-symbol-handler", (unsigned long)SCM_BOOL_F
, "The handler for memoization." },
3000 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
3002 "Option interface for the evaluation options. Instead of using\n"
3003 "this procedure directly, use the procedures @code{eval-enable},\n"
3004 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
3005 #define FUNC_NAME s_scm_eval_options_interface
3009 scm_dynwind_begin (0);
3010 scm_dynwind_critical_section (SCM_BOOL_F
);
3011 ans
= scm_options (setting
,
3014 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
3022 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
3024 "Option interface for the evaluator trap options.")
3025 #define FUNC_NAME s_scm_evaluator_traps
3030 scm_options_try (setting
,
3031 scm_evaluator_trap_table
,
3033 SCM_CRITICAL_SECTION_START
;
3034 ans
= scm_options (setting
,
3035 scm_evaluator_trap_table
,
3038 /* njrev: same again. */
3039 SCM_RESET_DEBUG_MODE
;
3040 SCM_CRITICAL_SECTION_END
;
3049 /* Simple procedure calls
3053 scm_call_0 (SCM proc
)
3055 if (SCM_PROGRAM_P (proc
))
3056 return scm_c_vm_run (scm_the_vm (), proc
, NULL
, 0);
3058 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
3062 scm_call_1 (SCM proc
, SCM arg1
)
3064 if (SCM_PROGRAM_P (proc
))
3065 return scm_c_vm_run (scm_the_vm (), proc
, &arg1
, 1);
3067 return scm_apply (proc
, arg1
, scm_listofnull
);
3071 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
3073 if (SCM_PROGRAM_P (proc
))
3075 SCM args
[] = { arg1
, arg2
};
3076 return scm_c_vm_run (scm_the_vm (), proc
, args
, 2);
3079 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
3083 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
3085 if (SCM_PROGRAM_P (proc
))
3087 SCM args
[] = { arg1
, arg2
, arg3
};
3088 return scm_c_vm_run (scm_the_vm (), proc
, args
, 3);
3091 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
3095 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
3097 if (SCM_PROGRAM_P (proc
))
3099 SCM args
[] = { arg1
, arg2
, arg3
, arg4
};
3100 return scm_c_vm_run (scm_the_vm (), proc
, args
, 4);
3103 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
3104 scm_cons (arg4
, scm_listofnull
)));
3107 /* Simple procedure applies
3111 scm_apply_0 (SCM proc
, SCM args
)
3113 return scm_apply (proc
, args
, SCM_EOL
);
3117 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
3119 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
3123 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
3125 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
3129 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
3131 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
3135 /* This code processes the arguments to apply:
3137 (apply PROC ARG1 ... ARGS)
3139 Given a list (ARG1 ... ARGS), this function conses the ARG1
3140 ... arguments onto the front of ARGS, and returns the resulting
3141 list. Note that ARGS is a list; thus, the argument to this
3142 function is a list whose last element is a list.
3144 Apply calls this function, and applies PROC to the elements of the
3145 result. apply:nconc2last takes care of building the list of
3146 arguments, given (ARG1 ... ARGS).
3148 Rather than do new consing, apply:nconc2last destroys its argument.
3149 On that topic, this code came into my care with the following
3150 beautifully cryptic comment on that topic: "This will only screw
3151 you if you do (scm_apply scm_apply '( ... ))" If you know what
3152 they're referring to, send me a patch to this comment. */
3154 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3156 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
3157 "conses the @var{arg1} @dots{} arguments onto the front of\n"
3158 "@var{args}, and returns the resulting list. Note that\n"
3159 "@var{args} is a list; thus, the argument to this function is\n"
3160 "a list whose last element is a list.\n"
3161 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
3162 "destroys its argument, so use with care.")
3163 #define FUNC_NAME s_scm_nconc2last
3166 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
3168 while (!scm_is_null (SCM_CDR (*lloc
))) /* Perhaps should be
3169 SCM_NULL_OR_NIL_P, but not
3170 needed in 99.99% of cases,
3171 and it could seriously hurt
3172 performance. - Neil */
3173 lloc
= SCM_CDRLOC (*lloc
);
3174 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3175 *lloc
= SCM_CAR (*lloc
);
3182 /* Typechecking for multi-argument MAP and FOR-EACH.
3184 Verify that each element of the vector ARGV, except for the first,
3185 is a proper list whose length is LEN. Attribute errors to WHO,
3186 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3188 check_map_args (SCM argv
,
3197 for (i
= SCM_SIMPLE_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
3199 SCM elt
= SCM_SIMPLE_VECTOR_REF (argv
, i
);
3200 long elt_len
= scm_ilength (elt
);
3205 scm_apply_generic (gf
, scm_cons (proc
, args
));
3207 scm_wrong_type_arg (who
, i
+ 2, elt
);
3211 scm_out_of_range_pos (who
, elt
, scm_from_long (i
+ 2));
3216 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3218 /* Note: Currently, scm_map applies PROC to the argument list(s)
3219 sequentially, starting with the first element(s). This is used in
3220 evalext.c where the Scheme procedure `map-in-order', which guarantees
3221 sequential behaviour, is implemented using scm_map. If the
3222 behaviour changes, we need to update `map-in-order'.
3226 scm_map (SCM proc
, SCM arg1
, SCM args
)
3227 #define FUNC_NAME s_map
3233 len
= scm_ilength (arg1
);
3234 SCM_GASSERTn (len
>= 0,
3235 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
3236 SCM_VALIDATE_REST_ARGUMENT (args
);
3237 if (scm_is_null (args
))
3239 SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc
)), g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
3240 while (SCM_NIMP (arg1
))
3242 *pres
= scm_list_1 (scm_call_1 (proc
, SCM_CAR (arg1
)));
3243 pres
= SCM_CDRLOC (*pres
);
3244 arg1
= SCM_CDR (arg1
);
3248 if (scm_is_null (SCM_CDR (args
)))
3250 SCM arg2
= SCM_CAR (args
);
3251 int len2
= scm_ilength (arg2
);
3252 SCM_GASSERTn (scm_is_true (scm_procedure_p (proc
)), g_map
,
3253 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
3254 SCM_GASSERTn (len2
>= 0,
3255 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
3257 SCM_OUT_OF_RANGE (3, arg2
);
3258 while (SCM_NIMP (arg1
))
3260 *pres
= scm_list_1 (scm_call_2 (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
3261 pres
= SCM_CDRLOC (*pres
);
3262 arg1
= SCM_CDR (arg1
);
3263 arg2
= SCM_CDR (arg2
);
3267 arg1
= scm_cons (arg1
, args
);
3268 args
= scm_vector (arg1
);
3269 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
3273 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3275 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
3278 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
3279 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
3281 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
3282 pres
= SCM_CDRLOC (*pres
);
3288 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
3291 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
3292 #define FUNC_NAME s_for_each
3295 len
= scm_ilength (arg1
);
3296 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
3297 SCM_ARG2
, s_for_each
);
3298 SCM_VALIDATE_REST_ARGUMENT (args
);
3299 if (scm_is_null (args
))
3301 SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc
)), g_for_each
,
3302 proc
, arg1
, SCM_ARG1
, s_for_each
);
3303 while (SCM_NIMP (arg1
))
3305 scm_call_1 (proc
, SCM_CAR (arg1
));
3306 arg1
= SCM_CDR (arg1
);
3308 return SCM_UNSPECIFIED
;
3310 if (scm_is_null (SCM_CDR (args
)))
3312 SCM arg2
= SCM_CAR (args
);
3313 int len2
= scm_ilength (arg2
);
3314 SCM_GASSERTn (scm_is_true (scm_procedure_p (proc
)), g_for_each
,
3315 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
3316 SCM_GASSERTn (len2
>= 0, g_for_each
,
3317 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
3319 SCM_OUT_OF_RANGE (3, arg2
);
3320 while (SCM_NIMP (arg1
))
3322 scm_call_2 (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
3323 arg1
= SCM_CDR (arg1
);
3324 arg2
= SCM_CDR (arg2
);
3326 return SCM_UNSPECIFIED
;
3328 arg1
= scm_cons (arg1
, args
);
3329 args
= scm_vector (arg1
);
3330 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
3334 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3336 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
3338 return SCM_UNSPECIFIED
;
3339 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
3340 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
3342 scm_apply (proc
, arg1
, SCM_EOL
);
3349 scm_closure (SCM code
, SCM env
)
3352 SCM closcar
= scm_cons (code
, SCM_EOL
);
3353 z
= scm_immutable_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
,
3355 scm_remember_upto_here (closcar
);
3360 scm_t_bits scm_tc16_promise
;
3362 SCM_DEFINE (scm_make_promise
, "make-promise", 1, 0, 0,
3364 "Create a new promise object.\n\n"
3365 "@code{make-promise} is a procedural form of @code{delay}.\n"
3366 "These two expressions are equivalent:\n"
3368 "(delay @var{exp})\n"
3369 "(make-promise (lambda () @var{exp}))\n"
3371 #define FUNC_NAME s_scm_make_promise
3373 SCM_VALIDATE_THUNK (1, thunk
);
3374 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
3376 scm_make_recursive_mutex ());
3382 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
3384 int writingp
= SCM_WRITINGP (pstate
);
3385 scm_puts ("#<promise ", port
);
3386 SCM_SET_WRITINGP (pstate
, 1);
3387 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
3388 SCM_SET_WRITINGP (pstate
, writingp
);
3389 scm_putc ('>', port
);
3393 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
3395 "If the promise @var{x} has not been computed yet, compute and\n"
3396 "return @var{x}, otherwise just return the previously computed\n"
3398 #define FUNC_NAME s_scm_force
3400 SCM_VALIDATE_SMOB (1, promise
, promise
);
3401 scm_lock_mutex (SCM_PROMISE_MUTEX (promise
));
3402 if (!SCM_PROMISE_COMPUTED_P (promise
))
3404 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
3405 if (!SCM_PROMISE_COMPUTED_P (promise
))
3407 SCM_SET_PROMISE_DATA (promise
, ans
);
3408 SCM_SET_PROMISE_COMPUTED (promise
);
3411 scm_unlock_mutex (SCM_PROMISE_MUTEX (promise
));
3412 return SCM_PROMISE_DATA (promise
);
3417 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
3419 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
3420 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
3421 #define FUNC_NAME s_scm_promise_p
3423 return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
3428 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
3429 (SCM xorig
, SCM x
, SCM y
),
3430 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
3431 "Any source properties associated with @var{xorig} are also associated\n"
3432 "with the new pair.")
3433 #define FUNC_NAME s_scm_cons_source
3436 z
= scm_cons (x
, y
);
3437 /* Copy source properties possibly associated with xorig. */
3438 p
= scm_whash_lookup (scm_source_whash
, xorig
);
3439 if (scm_is_true (p
))
3440 scm_whash_insert (scm_source_whash
, z
, p
);
3446 /* The function scm_copy_tree is used to copy an expression tree to allow the
3447 * memoizer to modify the expression during memoization. scm_copy_tree
3448 * creates deep copies of pairs and vectors, but not of any other data types,
3449 * since only pairs and vectors will be parsed by the memoizer.
3451 * To avoid infinite recursion due to cyclic structures, the hare-and-tortoise
3452 * pattern is used to detect cycles. In fact, the pattern is used in two
3453 * dimensions, vertical (indicated in the code by the variable names 'hare'
3454 * and 'tortoise') and horizontal ('rabbit' and 'turtle'). In both
3455 * dimensions, the hare/rabbit will take two steps when the tortoise/turtle
3458 * The vertical dimension corresponds to recursive calls to function
3459 * copy_tree: This happens when descending into vector elements, into cars of
3460 * lists and into the cdr of an improper list. In this dimension, the
3461 * tortoise follows the hare by using the processor stack: Every stack frame
3462 * will hold an instance of struct t_trace. These instances are connected in
3463 * a way that represents the trace of the hare, which thus can be followed by
3464 * the tortoise. The tortoise will always point to struct t_trace instances
3465 * relating to SCM objects that have already been copied. Thus, a cycle is
3466 * detected if the tortoise and the hare point to the same object,
3468 * The horizontal dimension is within one execution of copy_tree, when the
3469 * function cdr's along the pairs of a list. This is the standard
3470 * hare-and-tortoise implementation, found several times in guile. */
3473 struct t_trace
*trace
; /* These pointers form a trace along the stack. */
3474 SCM obj
; /* The object handled at the respective stack frame.*/
3479 struct t_trace
*const hare
,
3480 struct t_trace
*tortoise
,
3481 unsigned int tortoise_delay
)
3483 if (!scm_is_pair (hare
->obj
) && !scm_is_simple_vector (hare
->obj
))
3489 /* Prepare the trace along the stack. */
3490 struct t_trace new_hare
;
3491 hare
->trace
= &new_hare
;
3493 /* The tortoise will make its step after the delay has elapsed. Note
3494 * that in contrast to the typical hare-and-tortoise pattern, the step
3495 * of the tortoise happens before the hare takes its steps. This is, in
3496 * principle, no problem, except for the start of the algorithm: Then,
3497 * it has to be made sure that the hare actually gets its advantage of
3499 if (tortoise_delay
== 0)
3502 tortoise
= tortoise
->trace
;
3503 ASSERT_SYNTAX (!scm_is_eq (hare
->obj
, tortoise
->obj
),
3504 s_bad_expression
, hare
->obj
);
3511 if (scm_is_simple_vector (hare
->obj
))
3513 size_t length
= SCM_SIMPLE_VECTOR_LENGTH (hare
->obj
);
3514 SCM new_vector
= scm_c_make_vector (length
, SCM_UNSPECIFIED
);
3516 /* Each vector element is copied by recursing into copy_tree, having
3517 * the tortoise follow the hare into the depths of the stack. */
3518 unsigned long int i
;
3519 for (i
= 0; i
< length
; ++i
)
3522 new_hare
.obj
= SCM_SIMPLE_VECTOR_REF (hare
->obj
, i
);
3523 new_element
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3524 SCM_SIMPLE_VECTOR_SET (new_vector
, i
, new_element
);
3529 else /* scm_is_pair (hare->obj) */
3534 SCM rabbit
= hare
->obj
;
3535 SCM turtle
= hare
->obj
;
3539 /* The first pair of the list is treated specially, in order to
3540 * preserve a potential source code position. */
3541 result
= tail
= scm_cons_source (rabbit
, SCM_EOL
, SCM_EOL
);
3542 new_hare
.obj
= SCM_CAR (rabbit
);
3543 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3544 SCM_SETCAR (tail
, copy
);
3546 /* The remaining pairs of the list are copied by, horizontally,
3547 * having the turtle follow the rabbit, and, vertically, having the
3548 * tortoise follow the hare into the depths of the stack. */
3549 rabbit
= SCM_CDR (rabbit
);
3550 while (scm_is_pair (rabbit
))
3552 new_hare
.obj
= SCM_CAR (rabbit
);
3553 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3554 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
3555 tail
= SCM_CDR (tail
);
3557 rabbit
= SCM_CDR (rabbit
);
3558 if (scm_is_pair (rabbit
))
3560 new_hare
.obj
= SCM_CAR (rabbit
);
3561 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3562 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
3563 tail
= SCM_CDR (tail
);
3564 rabbit
= SCM_CDR (rabbit
);
3566 turtle
= SCM_CDR (turtle
);
3567 ASSERT_SYNTAX (!scm_is_eq (rabbit
, turtle
),
3568 s_bad_expression
, rabbit
);
3572 /* We have to recurse into copy_tree again for the last cdr, in
3573 * order to handle the situation that it holds a vector. */
3574 new_hare
.obj
= rabbit
;
3575 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
3576 SCM_SETCDR (tail
, copy
);
3583 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
3585 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
3586 "the new data structure. @code{copy-tree} recurses down the\n"
3587 "contents of both pairs and vectors (since both cons cells and vector\n"
3588 "cells may point to arbitrary objects), and stops recursing when it hits\n"
3589 "any other object.")
3590 #define FUNC_NAME s_scm_copy_tree
3592 /* Prepare the trace along the stack. */
3593 struct t_trace trace
;
3596 /* In function copy_tree, if the tortoise makes its step, it will do this
3597 * before the hare has the chance to move. Thus, we have to make sure that
3598 * the very first step of the tortoise will not happen after the hare has
3599 * really made two steps. This is achieved by passing '2' as the initial
3600 * delay for the tortoise. NOTE: Since cycles are unlikely, giving the hare
3601 * a bigger advantage may improve performance slightly. */
3602 return copy_tree (&trace
, &trace
, 2);
3607 /* We have three levels of EVAL here:
3609 - scm_i_eval (exp, env)
3611 evaluates EXP in environment ENV. ENV is a lexical environment
3612 structure as used by the actual tree code evaluator. When ENV is
3613 a top-level environment, then changes to the current module are
3614 tracked by updating ENV so that it continues to be in sync with
3617 - scm_primitive_eval (exp)
3619 evaluates EXP in the top-level environment as determined by the
3620 current module. This is done by constructing a suitable
3621 environment and calling scm_i_eval. Thus, changes to the
3622 top-level module are tracked normally.
3624 - scm_eval (exp, mod_or_state)
3626 evaluates EXP while MOD_OR_STATE is the current module or current
3627 dynamic state (as appropriate). This is done by setting the
3628 current module (or dynamic state) to MOD_OR_STATE, invoking
3629 scm_primitive_eval on EXP, and then restoring the current module
3630 (or dynamic state) to the value it had previously. That is,
3631 while EXP is evaluated, changes to the current module (or dynamic
3632 state) are tracked, but these changes do not persist when
3635 For each level of evals, there are two variants, distinguished by a
3636 _x suffix: the ordinary variant does not modify EXP while the _x
3637 variant can destructively modify EXP into something completely
3638 unintelligible. A Scheme data structure passed as EXP to one of the
3639 _x variants should not ever be used again for anything. So when in
3640 doubt, use the ordinary variant.
3645 scm_i_eval_x (SCM exp
, SCM env
)
3647 if (scm_is_symbol (exp
))
3648 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
3650 return EVAL (exp
, env
);
3654 scm_i_eval (SCM exp
, SCM env
)
3656 exp
= scm_copy_tree (exp
);
3657 if (scm_is_symbol (exp
))
3658 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
3660 return EVAL (exp
, env
);
3664 scm_primitive_eval_x (SCM exp
)
3667 SCM transformer
= scm_current_module_transformer ();
3668 if (SCM_NIMP (transformer
))
3669 exp
= scm_call_1 (transformer
, exp
);
3670 env
= scm_top_level_env (scm_current_module_lookup_closure ());
3671 return scm_i_eval_x (exp
, env
);
3674 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
3676 "Evaluate @var{exp} in the top-level environment specified by\n"
3677 "the current module.")
3678 #define FUNC_NAME s_scm_primitive_eval
3681 SCM transformer
= scm_current_module_transformer ();
3682 if (scm_is_true (transformer
))
3683 exp
= scm_call_1 (transformer
, exp
);
3684 env
= scm_top_level_env (scm_current_module_lookup_closure ());
3685 return scm_i_eval (exp
, env
);
3690 /* Eval does not take the second arg optionally. This is intentional
3691 * in order to be R5RS compatible, and to prepare for the new module
3692 * system, where we would like to make the choice of evaluation
3693 * environment explicit. */
3696 scm_eval_x (SCM exp
, SCM module_or_state
)
3700 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
3701 if (scm_is_dynamic_state (module_or_state
))
3702 scm_dynwind_current_dynamic_state (module_or_state
);
3704 scm_dynwind_current_module (module_or_state
);
3706 res
= scm_primitive_eval_x (exp
);
3712 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
3713 (SCM exp
, SCM module_or_state
),
3714 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
3715 "in the top-level environment specified by\n"
3716 "@var{module_or_state}.\n"
3717 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
3718 "@var{module_or_state} is made the current module when\n"
3719 "it is a module, or the current dynamic state when it is\n"
3721 "Example: (eval '(+ 1 2) (interaction-environment))")
3722 #define FUNC_NAME s_scm_eval
3726 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
3727 if (scm_is_dynamic_state (module_or_state
))
3728 scm_dynwind_current_dynamic_state (module_or_state
);
3729 else if (scm_module_system_booted_p
)
3731 SCM_VALIDATE_MODULE (2, module_or_state
);
3732 scm_dynwind_current_module (module_or_state
);
3734 /* otherwise if the module system isn't booted, ignore the module arg */
3736 res
= scm_primitive_eval (exp
);
3744 /* At this point, eval and scm_apply are generated.
3748 eval_letrec_inits (SCM env
, SCM init_forms
, SCM
**init_values_eol
)
3751 int i
= 0, imax
= sizeof (argv
) / sizeof (SCM
);
3753 while (!scm_is_null (init_forms
))
3757 eval_letrec_inits (env
, init_forms
, init_values_eol
);
3760 argv
[i
++] = EVALCAR (init_forms
, env
);
3761 init_forms
= SCM_CDR (init_forms
);
3764 for (i
--; i
>= 0; i
--)
3766 **init_values_eol
= scm_list_1 (argv
[i
]);
3767 *init_values_eol
= SCM_CDRLOC (**init_values_eol
);
3771 #define PREP_APPLY(p, l) \
3772 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
3774 #define ENTER_APPLY \
3776 SCM_SET_ARGSREADY (debug);\
3777 if (scm_check_apply_p && SCM_TRAPS_P)\
3778 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && SCM_PROCTRACEP (proc)))\
3780 SCM tmp, tail = scm_from_bool(SCM_TRACED_FRAME_P (debug)); \
3781 SCM_SET_TRACED_FRAME (debug); \
3783 tmp = scm_make_debugobj (&debug);\
3784 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
3789 #define RETURN(e) do { proc = (e); goto exit; } while (0)
3791 #ifdef STACK_CHECKING
3792 # ifndef EVAL_STACK_CHECKING
3793 # define EVAL_STACK_CHECKING
3794 # endif /* EVAL_STACK_CHECKING */
3795 #endif /* STACK_CHECKING */
3801 eval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
3803 SCM
*results
= lloc
;
3804 while (scm_is_pair (l
))
3806 const SCM res
= EVALCAR (l
, env
);
3808 *lloc
= scm_list_1 (res
);
3809 lloc
= SCM_CDRLOC (*lloc
);
3812 if (!scm_is_null (l
))
3813 scm_wrong_num_args (proc
);
3820 /* Update the toplevel environment frame ENV so that it refers to the
3821 * current module. */
3822 #define UPDATE_TOPLEVEL_ENV(env) \
3824 SCM p = scm_current_module_lookup_closure (); \
3825 if (p != SCM_CAR (env)) \
3826 env = scm_top_level_env (p); \
3830 #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
3831 ASSERT_SYNTAX (!scm_is_eq ((x), SCM_EOL), s_empty_combination, x)
3834 /* This is the evaluator.
3836 * eval takes two input parameters, x and env: x is a single expression to be
3837 * evalutated. env is the environment in which bindings are searched.
3839 * x is known to be a pair. Since x is a single expression, it is necessarily
3840 * in a tail position. If x is just a call to another function like in the
3841 * expression (foo exp1 exp2 ...), the realization of that call therefore
3842 * _must_not_ increase stack usage (the evaluation of exp1, exp2 etc.,
3843 * however, may do so). This is realized by making extensive use of 'goto'
3844 * statements within the evaluator: The gotos replace recursive calls to
3845 * `eval', thus re-using the same stack frame that `eval' was already using.
3846 * If, however, x represents some form that requires to evaluate a sequence of
3847 * expressions like (begin exp1 exp2 ...), then recursive calls to `eval' are
3848 * performed for all but the last expression of that sequence. */
3851 eval (SCM x
, SCM env
)
3854 scm_t_debug_frame debug
;
3855 scm_t_debug_info
*debug_info_end
;
3856 debug
.prev
= scm_i_last_debug_frame ();
3859 * The debug.vect contains twice as much scm_t_debug_info frames as the
3860 * user has specified with (debug-set! frames <n>).
3862 * Even frames are eval frames, odd frames are apply frames.
3864 debug
.vect
= alloca (scm_debug_eframe_size
* sizeof (scm_t_debug_info
));
3865 debug
.info
= debug
.vect
;
3866 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
3867 scm_i_set_last_debug_frame (&debug
);
3868 #ifdef EVAL_STACK_CHECKING
3869 if (scm_stack_checking_enabled_p
&& SCM_STACK_OVERFLOW_P (&proc
))
3871 debug
.info
->e
.exp
= x
;
3872 debug
.info
->e
.env
= env
;
3873 scm_report_stack_overflow ();
3880 SCM_CLEAR_ARGSREADY (debug
);
3881 if (SCM_OVERFLOWP (debug
))
3884 * In theory, this should be the only place where it is necessary to
3885 * check for space in debug.vect since both eval frames and
3886 * available space are even.
3888 * For this to be the case, however, it is necessary that primitive
3889 * special forms which jump back to `loop', `begin' or some similar
3890 * label call PREP_APPLY.
3892 else if (++debug
.info
>= debug_info_end
)
3894 SCM_SET_OVERFLOW (debug
);
3899 debug
.info
->e
.exp
= x
;
3900 debug
.info
->e
.env
= env
;
3901 if (scm_check_entry_p
&& SCM_TRAPS_P
)
3903 if (SCM_ENTER_FRAME_P
3904 || (SCM_BREAKPOINTS_P
&& scm_c_source_property_breakpoint_p (x
)))
3907 SCM tail
= scm_from_bool (SCM_TAILRECP (debug
));
3908 SCM_SET_TAILREC (debug
);
3909 stackrep
= scm_make_debugobj (&debug
);
3911 stackrep
= scm_call_4 (SCM_ENTER_FRAME_HDLR
,
3912 scm_sym_enter_frame
,
3915 unmemoize_expression (x
, env
));
3917 if (scm_is_pair (stackrep
) &&
3918 scm_is_eq (SCM_CAR (stackrep
), sym_instead
))
3920 /* This gives the possibility for the debugger to modify
3921 the source expression before evaluation. */
3922 x
= SCM_CDR (stackrep
);
3930 if (SCM_ISYMP (SCM_CAR (x
)))
3932 switch (ISYMNUM (SCM_CAR (x
)))
3934 case (ISYMNUM (SCM_IM_AND
)):
3936 while (!scm_is_null (SCM_CDR (x
)))
3938 SCM test_result
= EVALCAR (x
, env
);
3939 if (scm_is_false_or_nil (test_result
))
3940 RETURN (SCM_BOOL_F
);
3944 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3947 case (ISYMNUM (SCM_IM_BEGIN
)):
3949 if (scm_is_null (x
))
3950 RETURN (SCM_UNSPECIFIED
);
3952 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3955 /* If we are on toplevel with a lookup closure, we need to sync
3956 with the current module. */
3957 if (scm_is_pair (env
) && !scm_is_pair (SCM_CAR (env
)))
3959 UPDATE_TOPLEVEL_ENV (env
);
3960 while (!scm_is_null (SCM_CDR (x
)))
3963 UPDATE_TOPLEVEL_ENV (env
);
3969 goto nontoplevel_begin
;
3972 while (!scm_is_null (SCM_CDR (x
)))
3974 const SCM form
= SCM_CAR (x
);
3977 if (SCM_ISYMP (form
))
3979 scm_dynwind_begin (0);
3980 scm_i_dynwind_pthread_mutex_lock (&source_mutex
);
3981 /* check for race condition */
3982 if (SCM_ISYMP (SCM_CAR (x
)))
3983 m_expand_body (x
, env
);
3985 goto nontoplevel_begin
;
3988 SCM_VALIDATE_NON_EMPTY_COMBINATION (form
);
3991 (void) EVAL (form
, env
);
3997 /* scm_eval last form in list */
3998 const SCM last_form
= SCM_CAR (x
);
4000 if (scm_is_pair (last_form
))
4002 /* This is by far the most frequent case. */
4004 goto loop
; /* tail recurse */
4006 else if (SCM_IMP (last_form
))
4007 RETURN (EVALIM (last_form
, env
));
4008 else if (SCM_VARIABLEP (last_form
))
4009 RETURN (SCM_VARIABLE_REF (last_form
));
4010 else if (scm_is_symbol (last_form
))
4011 RETURN (*scm_lookupcar (x
, env
, 1));
4017 case (ISYMNUM (SCM_IM_CASE
)):
4020 const SCM key
= EVALCAR (x
, env
);
4022 while (!scm_is_null (x
))
4024 const SCM clause
= SCM_CAR (x
);
4025 SCM labels
= SCM_CAR (clause
);
4026 if (scm_is_eq (labels
, SCM_IM_ELSE
))
4028 x
= SCM_CDR (clause
);
4029 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
4032 while (!scm_is_null (labels
))
4034 const SCM label
= SCM_CAR (labels
);
4035 if (scm_is_eq (label
, key
)
4036 || scm_is_true (scm_eqv_p (label
, key
)))
4038 x
= SCM_CDR (clause
);
4039 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
4042 labels
= SCM_CDR (labels
);
4047 RETURN (SCM_UNSPECIFIED
);
4050 case (ISYMNUM (SCM_IM_COND
)):
4052 while (!scm_is_null (x
))
4054 const SCM clause
= SCM_CAR (x
);
4055 if (scm_is_eq (SCM_CAR (clause
), SCM_IM_ELSE
))
4057 x
= SCM_CDR (clause
);
4058 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
4063 arg1
= EVALCAR (clause
, env
);
4064 /* SRFI 61 extended cond */
4065 if (!scm_is_null (SCM_CDR (clause
))
4066 && !scm_is_null (SCM_CDDR (clause
))
4067 && scm_is_eq (SCM_CADDR (clause
), SCM_IM_ARROW
))
4069 SCM xx
, guard_result
;
4070 if (SCM_VALUESP (arg1
))
4071 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
4073 arg1
= scm_list_1 (arg1
);
4074 xx
= SCM_CDR (clause
);
4075 proc
= EVALCAR (xx
, env
);
4076 guard_result
= scm_apply (proc
, arg1
, SCM_EOL
);
4077 if (scm_is_true_and_not_nil (guard_result
))
4079 proc
= SCM_CDDR (xx
);
4080 proc
= EVALCAR (proc
, env
);
4081 PREP_APPLY (proc
, arg1
);
4085 else if (scm_is_true_and_not_nil (arg1
))
4087 x
= SCM_CDR (clause
);
4088 if (scm_is_null (x
))
4090 else if (!scm_is_eq (SCM_CAR (x
), SCM_IM_ARROW
))
4092 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
4098 proc
= EVALCAR (proc
, env
);
4099 PREP_APPLY (proc
, scm_list_1 (arg1
));
4107 RETURN (SCM_UNSPECIFIED
);
4110 case (ISYMNUM (SCM_IM_DO
)):
4113 /* Compute the initialization values and the initial environment. */
4114 SCM init_forms
= SCM_CAR (x
);
4115 SCM init_values
= SCM_EOL
;
4116 while (!scm_is_null (init_forms
))
4118 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
4119 init_forms
= SCM_CDR (init_forms
);
4122 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
4126 SCM test_form
= SCM_CAR (x
);
4127 SCM body_forms
= SCM_CADR (x
);
4128 SCM step_forms
= SCM_CDDR (x
);
4130 SCM test_result
= EVALCAR (test_form
, env
);
4132 while (scm_is_false_or_nil (test_result
))
4135 /* Evaluate body forms. */
4137 for (temp_forms
= body_forms
;
4138 !scm_is_null (temp_forms
);
4139 temp_forms
= SCM_CDR (temp_forms
))
4141 SCM form
= SCM_CAR (temp_forms
);
4142 /* Dirk:FIXME: We only need to eval forms that may have
4143 * a side effect here. This is only true for forms that
4144 * start with a pair. All others are just constants.
4145 * Since with the current memoizer 'form' may hold a
4146 * constant, we call EVAL here to handle the constant
4147 * cases. In the long run it would make sense to have
4148 * the macro transformer of 'do' eliminate all forms
4149 * that have no sideeffect. Then instead of EVAL we
4150 * could call CEVAL directly here. */
4151 (void) EVAL (form
, env
);
4156 /* Evaluate the step expressions. */
4158 SCM step_values
= SCM_EOL
;
4159 for (temp_forms
= step_forms
;
4160 !scm_is_null (temp_forms
);
4161 temp_forms
= SCM_CDR (temp_forms
))
4163 const SCM value
= EVALCAR (temp_forms
, env
);
4164 step_values
= scm_cons (value
, step_values
);
4166 env
= SCM_EXTEND_ENV (SCM_CAAR (env
),
4171 test_result
= EVALCAR (test_form
, env
);
4175 if (scm_is_null (x
))
4176 RETURN (SCM_UNSPECIFIED
);
4177 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
4178 goto nontoplevel_begin
;
4181 case (ISYMNUM (SCM_IM_IF
)):
4184 SCM test_result
= EVALCAR (x
, env
);
4185 x
= SCM_CDR (x
); /* then expression */
4186 if (scm_is_false_or_nil (test_result
))
4188 x
= SCM_CDR (x
); /* else expression */
4189 if (scm_is_null (x
))
4190 RETURN (SCM_UNSPECIFIED
);
4193 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
4197 case (ISYMNUM (SCM_IM_LET
)):
4200 SCM init_forms
= SCM_CADR (x
);
4201 SCM init_values
= SCM_EOL
;
4204 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
4205 init_forms
= SCM_CDR (init_forms
);
4207 while (!scm_is_null (init_forms
));
4208 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
4211 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
4212 goto nontoplevel_begin
;
4215 case (ISYMNUM (SCM_IM_LETREC
)):
4217 env
= SCM_EXTEND_ENV (SCM_CAR (x
), undefineds
, env
);
4220 SCM init_forms
= SCM_CAR (x
);
4221 SCM init_values
= scm_list_1 (SCM_BOOL_T
);
4222 SCM
*init_values_eol
= SCM_CDRLOC (init_values
);
4223 eval_letrec_inits (env
, init_forms
, &init_values_eol
);
4224 SCM_SETCDR (SCM_CAR (env
), SCM_CDR (init_values
));
4227 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
4228 goto nontoplevel_begin
;
4231 case (ISYMNUM (SCM_IM_LETSTAR
)):
4234 SCM bindings
= SCM_CAR (x
);
4235 if (!scm_is_null (bindings
))
4239 SCM name
= SCM_CAR (bindings
);
4240 SCM init
= SCM_CDR (bindings
);
4241 env
= SCM_EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
4242 bindings
= SCM_CDR (init
);
4244 while (!scm_is_null (bindings
));
4248 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
4249 goto nontoplevel_begin
;
4252 case (ISYMNUM (SCM_IM_OR
)):
4254 while (!scm_is_null (SCM_CDR (x
)))
4256 SCM val
= EVALCAR (x
, env
);
4257 if (scm_is_true_and_not_nil (val
))
4262 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
4266 case (ISYMNUM (SCM_IM_LAMBDA
)):
4267 RETURN (scm_closure (SCM_CDR (x
), env
));
4270 case (ISYMNUM (SCM_IM_QUOTE
)):
4271 RETURN (SCM_CDR (x
));
4274 case (ISYMNUM (SCM_IM_SET_X
)):
4278 SCM variable
= SCM_CAR (x
);
4279 if (SCM_ILOCP (variable
))
4280 location
= scm_ilookup (variable
, env
);
4281 else if (SCM_VARIABLEP (variable
))
4282 location
= SCM_VARIABLE_LOC (variable
);
4285 /* (scm_is_symbol (variable)) is known to be true */
4286 variable
= lazy_memoize_variable (variable
, env
);
4287 SCM_SETCAR (x
, variable
);
4288 location
= SCM_VARIABLE_LOC (variable
);
4291 *location
= EVALCAR (x
, env
);
4293 RETURN (SCM_UNSPECIFIED
);
4296 case (ISYMNUM (SCM_IM_APPLY
)):
4297 /* Evaluate the procedure to be applied. */
4299 proc
= EVALCAR (x
, env
);
4300 PREP_APPLY (proc
, SCM_EOL
);
4302 /* Evaluate the argument holding the list of arguments */
4304 arg1
= EVALCAR (x
, env
);
4307 /* Go here to tail-apply a procedure. PROC is the procedure and
4308 * ARG1 is the list of arguments. PREP_APPLY must have been called
4309 * before jumping to apply_proc. */
4310 if (SCM_CLOSUREP (proc
))
4312 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4313 debug
.info
->a
.args
= arg1
;
4314 if (SCM_UNLIKELY (scm_badargsp (formals
, arg1
)))
4315 scm_wrong_num_args (proc
);
4317 /* Copy argument list */
4318 if (SCM_NULL_OR_NIL_P (arg1
))
4319 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
4322 SCM args
= scm_list_1 (SCM_CAR (arg1
));
4324 arg1
= SCM_CDR (arg1
);
4325 while (!SCM_NULL_OR_NIL_P (arg1
))
4327 SCM new_tail
= scm_list_1 (SCM_CAR (arg1
));
4328 SCM_SETCDR (tail
, new_tail
);
4330 arg1
= SCM_CDR (arg1
);
4332 env
= SCM_EXTEND_ENV (formals
, args
, SCM_ENV (proc
));
4335 x
= SCM_CLOSURE_BODY (proc
);
4336 goto nontoplevel_begin
;
4341 RETURN (scm_apply (proc
, arg1
, SCM_EOL
));
4345 case (ISYMNUM (SCM_IM_CONT
)):
4348 SCM val
= scm_make_continuation (&first
);
4356 proc
= EVALCAR (proc
, env
);
4357 PREP_APPLY (proc
, scm_list_1 (arg1
));
4364 case (ISYMNUM (SCM_IM_DELAY
)):
4365 RETURN (scm_make_promise (scm_closure (SCM_CDR (x
), env
)));
4367 case (ISYMNUM (SCM_IM_SLOT_REF
)):
4370 SCM instance
= EVALCAR (x
, env
);
4371 unsigned long int slot
= SCM_I_INUM (SCM_CDR (x
));
4372 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance
) [slot
]));
4376 case (ISYMNUM (SCM_IM_SLOT_SET_X
)):
4379 SCM instance
= EVALCAR (x
, env
);
4380 unsigned long int slot
= SCM_I_INUM (SCM_CADR (x
));
4381 SCM value
= EVALCAR (SCM_CDDR (x
), env
);
4382 SCM_STRUCT_DATA (instance
) [slot
] = SCM_UNPACK (value
);
4383 RETURN (SCM_UNSPECIFIED
);
4387 #if SCM_ENABLE_ELISP
4389 case (ISYMNUM (SCM_IM_NIL_COND
)):
4391 SCM test_form
= SCM_CDR (x
);
4392 x
= SCM_CDR (test_form
);
4393 while (!SCM_NULL_OR_NIL_P (x
))
4395 SCM test_result
= EVALCAR (test_form
, env
);
4396 if (!(scm_is_false (test_result
)
4397 || SCM_NULL_OR_NIL_P (test_result
)))
4399 if (scm_is_eq (SCM_CAR (x
), SCM_UNSPECIFIED
))
4400 RETURN (test_result
);
4401 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
4406 test_form
= SCM_CDR (x
);
4407 x
= SCM_CDR (test_form
);
4411 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
4415 #endif /* SCM_ENABLE_ELISP */
4417 case (ISYMNUM (SCM_IM_BIND
)):
4419 SCM vars
, exps
, vals
;
4422 vars
= SCM_CAAR (x
);
4423 exps
= SCM_CDAR (x
);
4425 while (!scm_is_null (exps
))
4427 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
4428 exps
= SCM_CDR (exps
);
4431 scm_swap_bindings (vars
, vals
);
4432 scm_i_set_dynwinds (scm_acons (vars
, vals
, scm_i_dynwinds ()));
4434 /* Ignore all but the last evaluation result. */
4435 for (x
= SCM_CDR (x
); !scm_is_null (SCM_CDR (x
)); x
= SCM_CDR (x
))
4437 if (scm_is_pair (SCM_CAR (x
)))
4438 eval (SCM_CAR (x
), env
);
4440 proc
= EVALCAR (x
, env
);
4442 scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
4443 scm_swap_bindings (vars
, vals
);
4449 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
4454 producer
= EVALCAR (x
, env
);
4456 proc
= EVALCAR (x
, env
); /* proc is the consumer. */
4457 arg1
= scm_apply (producer
, SCM_EOL
, SCM_EOL
);
4458 if (SCM_VALUESP (arg1
))
4460 /* The list of arguments is not copied. Rather, it is assumed
4461 * that this has been done by the 'values' procedure. */
4462 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
4466 arg1
= scm_list_1 (arg1
);
4468 PREP_APPLY (proc
, arg1
);
4479 if (SCM_VARIABLEP (SCM_CAR (x
)))
4480 proc
= SCM_VARIABLE_REF (SCM_CAR (x
));
4481 else if (SCM_ILOCP (SCM_CAR (x
)))
4482 proc
= *scm_ilookup (SCM_CAR (x
), env
);
4483 else if (scm_is_pair (SCM_CAR (x
)))
4484 proc
= eval (SCM_CAR (x
), env
);
4485 else if (scm_is_symbol (SCM_CAR (x
)))
4487 SCM orig_sym
= SCM_CAR (x
);
4489 SCM
*location
= scm_lookupcar1 (x
, env
, 1);
4490 if (location
== NULL
)
4492 /* we have lost the race, start again. */
4496 if (scm_check_memoize_p
&& SCM_TRAPS_P
)
4500 SCM_CLEAR_TRACED_FRAME (debug
);
4501 arg1
= scm_make_debugobj (&debug
);
4502 retval
= SCM_BOOL_T
;
4504 retval
= scm_call_4 (SCM_MEMOIZE_HDLR
,
4505 scm_sym_memoize_symbol
,
4509 do something with retval?
4515 if (SCM_MACROP (proc
))
4517 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
4519 handle_a_macro
: /* inputs: x, env, proc */
4520 /* Set a flag during macro expansion so that macro
4521 application frames can be deleted from the backtrace. */
4522 SCM_SET_MACROEXP (debug
);
4523 arg1
= scm_apply (SCM_MACRO_CODE (proc
), x
,
4524 scm_cons (env
, scm_listofnull
));
4525 SCM_CLEAR_MACROEXP (debug
);
4526 switch (SCM_MACRO_TYPE (proc
))
4530 if (!scm_is_pair (arg1
))
4531 arg1
= scm_list_2 (SCM_IM_BEGIN
, arg1
);
4533 assert (!scm_is_eq (x
, SCM_CAR (arg1
))
4534 && !scm_is_eq (x
, SCM_CDR (arg1
)));
4536 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
4538 SCM_CRITICAL_SECTION_START
;
4539 SCM_SETCAR (x
, SCM_CAR (arg1
));
4540 SCM_SETCDR (x
, SCM_CDR (arg1
));
4541 SCM_CRITICAL_SECTION_END
;
4544 /* Prevent memoizing of debug info expression. */
4545 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
4548 SCM_CRITICAL_SECTION_START
;
4549 SCM_SETCAR (x
, SCM_CAR (arg1
));
4550 SCM_SETCDR (x
, SCM_CDR (arg1
));
4551 SCM_CRITICAL_SECTION_END
;
4552 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
4554 #if SCM_ENABLE_DEPRECATED == 1
4559 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
4573 if (SCM_MACROP (proc
))
4574 goto handle_a_macro
;
4578 /* When reaching this part of the code, the following is granted: Variable x
4579 * holds the first pair of an expression of the form (<function> arg ...).
4580 * Variable proc holds the object that resulted from the evaluation of
4581 * <function>. In the following, the arguments (if any) will be evaluated,
4582 * and proc will be applied to them. If proc does not really hold a
4583 * function object, this will be signalled as an error on the scheme
4584 * level. If the number of arguments does not match the number of arguments
4585 * that are allowed to be passed to proc, also an error on the scheme level
4586 * will be signalled. */
4588 PREP_APPLY (proc
, SCM_EOL
);
4589 if (scm_is_null (SCM_CDR (x
))) {
4592 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4593 switch (SCM_TYP7 (proc
))
4594 { /* no arguments given */
4595 case scm_tc7_subr_0
:
4596 RETURN (SCM_SUBRF (proc
) ());
4597 case scm_tc7_subr_1o
:
4598 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
4600 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
4601 case scm_tc7_rpsubr
:
4602 RETURN (SCM_BOOL_T
);
4604 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
4605 case scm_tc7_program
:
4606 RETURN (scm_c_vm_run (scm_the_vm (), proc
, NULL
, 0));
4608 if (!SCM_SMOB_APPLICABLE_P (proc
))
4610 RETURN (SCM_SMOB_APPLY_0 (proc
));
4612 debug
.info
->a
.proc
= proc
;
4613 debug
.info
->a
.args
= SCM_EOL
;
4614 RETURN (scm_i_gsubr_apply (proc
, SCM_UNDEFINED
));
4616 proc
= SCM_PROCEDURE (proc
);
4617 debug
.info
->a
.proc
= proc
;
4618 if (!SCM_CLOSUREP (proc
))
4621 case scm_tcs_closures
:
4623 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4624 if (SCM_UNLIKELY (scm_is_pair (formals
)))
4626 x
= SCM_CLOSURE_BODY (proc
);
4627 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
4628 goto nontoplevel_begin
;
4630 case scm_tcs_struct
:
4631 if (SCM_STRUCT_APPLICABLE_P (proc
))
4633 proc
= SCM_STRUCT_PROCEDURE (proc
);
4634 debug
.info
->a
.proc
= proc
;
4639 case scm_tc7_subr_1
:
4640 case scm_tc7_subr_2
:
4641 case scm_tc7_subr_2o
:
4644 case scm_tc7_subr_3
:
4645 case scm_tc7_lsubr_2
:
4647 scm_wrong_num_args (proc
);
4650 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
4654 /* must handle macros by here */
4656 if (SCM_LIKELY (scm_is_pair (x
)))
4657 arg1
= EVALCAR (x
, env
);
4659 scm_wrong_num_args (proc
);
4660 debug
.info
->a
.args
= scm_list_1 (arg1
);
4664 if (scm_is_null (x
))
4667 evap1
: /* inputs: proc, arg1 */
4668 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4669 switch (SCM_TYP7 (proc
))
4670 { /* have one argument in arg1 */
4671 case scm_tc7_subr_2o
:
4672 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4673 case scm_tc7_subr_1
:
4674 case scm_tc7_subr_1o
:
4675 RETURN (SCM_SUBRF (proc
) (arg1
));
4677 if (SCM_I_INUMP (arg1
))
4679 RETURN (scm_from_double (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
))));
4681 else if (SCM_REALP (arg1
))
4683 RETURN (scm_from_double (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4685 else if (SCM_BIGP (arg1
))
4687 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4689 else if (SCM_FRACTIONP (arg1
))
4691 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4693 SCM_WTA_DISPATCH_1_SUBR (proc
, arg1
, SCM_ARG1
);
4695 RETURN (scm_i_chase_pairs (arg1
, (scm_t_bits
) SCM_SUBRF (proc
)));
4696 case scm_tc7_rpsubr
:
4697 RETURN (SCM_BOOL_T
);
4698 case scm_tc7_program
:
4699 RETURN (scm_c_vm_run (scm_the_vm (), proc
, &arg1
, 1));
4701 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4703 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4705 if (!SCM_SMOB_APPLICABLE_P (proc
))
4707 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
4709 debug
.info
->a
.args
= debug
.info
->a
.args
;
4710 debug
.info
->a
.proc
= proc
;
4711 RETURN (scm_i_gsubr_apply (proc
, arg1
, SCM_UNDEFINED
));
4713 proc
= SCM_PROCEDURE (proc
);
4714 debug
.info
->a
.proc
= proc
;
4715 if (!SCM_CLOSUREP (proc
))
4718 case scm_tcs_closures
:
4721 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4722 if (scm_is_null (formals
)
4723 || (scm_is_pair (formals
) && scm_is_pair (SCM_CDR (formals
))))
4725 x
= SCM_CLOSURE_BODY (proc
);
4726 env
= SCM_EXTEND_ENV (formals
,
4729 goto nontoplevel_begin
;
4731 case scm_tcs_struct
:
4732 if (SCM_STRUCT_APPLICABLE_P (proc
))
4734 proc
= SCM_STRUCT_PROCEDURE (proc
);
4735 debug
.info
->a
.proc
= proc
;
4740 case scm_tc7_subr_2
:
4741 case scm_tc7_subr_0
:
4742 case scm_tc7_subr_3
:
4743 case scm_tc7_lsubr_2
:
4744 scm_wrong_num_args (proc
);
4749 if (SCM_LIKELY (scm_is_pair (x
)))
4750 arg2
= EVALCAR (x
, env
);
4752 scm_wrong_num_args (proc
);
4754 { /* have two or more arguments */
4755 debug
.info
->a
.args
= scm_list_2 (arg1
, arg2
);
4757 if (scm_is_null (x
)) {
4760 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4761 switch (SCM_TYP7 (proc
))
4762 { /* have two arguments */
4763 case scm_tc7_subr_2
:
4764 case scm_tc7_subr_2o
:
4765 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
4767 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4768 case scm_tc7_lsubr_2
:
4769 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
));
4770 case scm_tc7_rpsubr
:
4772 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
4773 case scm_tc7_program
:
4777 RETURN (scm_c_vm_run (scm_the_vm (), proc
, args
, 2));
4780 if (!SCM_SMOB_APPLICABLE_P (proc
))
4782 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
));
4784 RETURN (scm_i_gsubr_apply_list (proc
, debug
.info
->a
.args
));
4785 case scm_tcs_struct
:
4786 if (SCM_STRUCT_APPLICABLE_P (proc
))
4789 RETURN (scm_apply (SCM_STRUCT_PROCEDURE (proc
),
4795 case scm_tc7_subr_0
:
4798 case scm_tc7_subr_1o
:
4799 case scm_tc7_subr_1
:
4800 case scm_tc7_subr_3
:
4801 scm_wrong_num_args (proc
);
4805 proc
= SCM_PROCEDURE (proc
);
4806 debug
.info
->a
.proc
= proc
;
4807 if (!SCM_CLOSUREP (proc
))
4810 case scm_tcs_closures
:
4813 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4814 if (scm_is_null (formals
)
4815 || (scm_is_pair (formals
)
4816 && (scm_is_null (SCM_CDR (formals
))
4817 || (scm_is_pair (SCM_CDR (formals
))
4818 && scm_is_pair (SCM_CDDR (formals
))))))
4820 env
= SCM_EXTEND_ENV (formals
,
4823 x
= SCM_CLOSURE_BODY (proc
);
4824 goto nontoplevel_begin
;
4828 if (SCM_UNLIKELY (!scm_is_pair (x
)))
4829 scm_wrong_num_args (proc
);
4830 debug
.info
->a
.args
= scm_cons2 (arg1
, arg2
,
4831 eval_args (x
, env
, proc
,
4832 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
4835 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4836 switch (SCM_TYP7 (proc
))
4837 { /* have 3 or more arguments */
4838 case scm_tc7_subr_3
:
4839 if (!scm_is_null (SCM_CDR (x
)))
4840 scm_wrong_num_args (proc
);
4842 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4843 SCM_CADDR (debug
.info
->a
.args
)));
4845 arg1
= SCM_SUBRF(proc
)(arg1
, arg2
);
4846 arg2
= SCM_CDDR (debug
.info
->a
.args
);
4849 arg1
= SCM_SUBRF(proc
)(arg1
, SCM_CAR (arg2
));
4850 arg2
= SCM_CDR (arg2
);
4852 while (SCM_NIMP (arg2
));
4854 case scm_tc7_rpsubr
:
4855 if (scm_is_false (SCM_SUBRF (proc
) (arg1
, arg2
)))
4856 RETURN (SCM_BOOL_F
);
4857 arg1
= SCM_CDDR (debug
.info
->a
.args
);
4860 if (scm_is_false (SCM_SUBRF (proc
) (arg2
, SCM_CAR (arg1
))))
4861 RETURN (SCM_BOOL_F
);
4862 arg2
= SCM_CAR (arg1
);
4863 arg1
= SCM_CDR (arg1
);
4865 while (SCM_NIMP (arg1
));
4866 RETURN (SCM_BOOL_T
);
4867 case scm_tc7_lsubr_2
:
4868 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4869 SCM_CDDR (debug
.info
->a
.args
)));
4871 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4873 if (!SCM_SMOB_APPLICABLE_P (proc
))
4875 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4876 SCM_CDDR (debug
.info
->a
.args
)));
4878 RETURN (scm_i_gsubr_apply_list (proc
, debug
.info
->a
.args
));
4879 case scm_tc7_program
:
4880 RETURN (scm_vm_apply (scm_the_vm (), proc
, debug
.info
->a
.args
));
4882 proc
= SCM_PROCEDURE (proc
);
4883 debug
.info
->a
.proc
= proc
;
4884 if (!SCM_CLOSUREP (proc
))
4887 case scm_tcs_closures
:
4889 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4890 if (scm_is_null (formals
)
4891 || (scm_is_pair (formals
)
4892 && (scm_is_null (SCM_CDR (formals
))
4893 || (scm_is_pair (SCM_CDR (formals
))
4894 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4896 SCM_SET_ARGSREADY (debug
);
4897 env
= SCM_EXTEND_ENV (formals
,
4900 x
= SCM_CLOSURE_BODY (proc
);
4901 goto nontoplevel_begin
;
4903 case scm_tcs_struct
:
4904 if (SCM_STRUCT_APPLICABLE_P (proc
))
4908 case scm_tc7_subr_2
:
4909 case scm_tc7_subr_1o
:
4910 case scm_tc7_subr_2o
:
4911 case scm_tc7_subr_0
:
4914 case scm_tc7_subr_1
:
4915 scm_wrong_num_args (proc
);
4922 if (scm_check_exit_p
&& SCM_TRAPS_P
)
4923 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
4925 SCM_CLEAR_TRACED_FRAME (debug
);
4926 arg1
= scm_make_debugobj (&debug
);
4928 arg1
= scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
4930 if (scm_is_pair (arg1
) && scm_is_eq (SCM_CAR (arg1
), sym_instead
))
4931 proc
= SCM_CDR (arg1
);
4933 scm_i_set_last_debug_frame (debug
.prev
);
4940 /* Apply a function to a list of arguments.
4942 This function is exported to the Scheme level as taking two
4943 required arguments and a tail argument, as if it were:
4944 (lambda (proc arg1 . args) ...)
4945 Thus, if you just have a list of arguments to pass to a procedure,
4946 pass the list as ARG1, and '() for ARGS. If you have some fixed
4947 args, pass the first as ARG1, then cons any remaining fixed args
4948 onto the front of your argument list, and pass that as ARGS. */
4951 scm_apply (SCM proc
, SCM arg1
, SCM args
)
4953 scm_t_debug_frame debug
;
4954 scm_t_debug_info debug_vect_body
;
4955 debug
.prev
= scm_i_last_debug_frame ();
4956 debug
.status
= SCM_APPLYFRAME
;
4957 debug
.vect
= &debug_vect_body
;
4958 debug
.vect
[0].a
.proc
= proc
;
4959 debug
.vect
[0].a
.args
= SCM_EOL
;
4960 scm_i_set_last_debug_frame (&debug
);
4962 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
4964 /* If ARGS is the empty list, then we're calling apply with only two
4965 arguments --- ARG1 is the list of arguments for PROC. Whatever
4966 the case, futz with things so that ARG1 is the first argument to
4967 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
4970 Setting the debug apply frame args this way is pretty messy.
4971 Perhaps we should store arg1 and args directly in the frame as
4972 received, and let scm_frame_arguments unpack them, because that's
4973 a relatively rare operation. This works for now; if the Guile
4974 developer archives are still around, see Mikael's post of
4976 if (scm_is_null (args
))
4978 if (scm_is_null (arg1
))
4980 arg1
= SCM_UNDEFINED
;
4981 debug
.vect
[0].a
.args
= SCM_EOL
;
4985 debug
.vect
[0].a
.args
= arg1
;
4986 args
= SCM_CDR (arg1
);
4987 arg1
= SCM_CAR (arg1
);
4992 args
= scm_nconc2last (args
);
4993 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4995 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
4997 SCM tmp
= scm_make_debugobj (&debug
);
4999 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
5004 switch (SCM_TYP7 (proc
))
5006 case scm_tc7_subr_2o
:
5007 if (SCM_UNLIKELY (SCM_UNBNDP (arg1
)))
5008 scm_wrong_num_args (proc
);
5009 if (scm_is_null (args
))
5010 args
= SCM_UNDEFINED
;
5013 if (SCM_UNLIKELY (! scm_is_null (SCM_CDR (args
))))
5014 scm_wrong_num_args (proc
);
5015 args
= SCM_CAR (args
);
5017 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
5018 case scm_tc7_subr_2
:
5019 if (SCM_UNLIKELY (scm_is_null (args
) ||
5020 !scm_is_null (SCM_CDR (args
))))
5021 scm_wrong_num_args (proc
);
5022 args
= SCM_CAR (args
);
5023 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
5024 case scm_tc7_subr_0
:
5025 if (SCM_UNLIKELY (!SCM_UNBNDP (arg1
)))
5026 scm_wrong_num_args (proc
);
5028 RETURN (SCM_SUBRF (proc
) ());
5029 case scm_tc7_subr_1
:
5030 if (SCM_UNLIKELY (SCM_UNBNDP (arg1
)))
5031 scm_wrong_num_args (proc
);
5032 case scm_tc7_subr_1o
:
5033 if (SCM_UNLIKELY (!scm_is_null (args
)))
5034 scm_wrong_num_args (proc
);
5036 RETURN (SCM_SUBRF (proc
) (arg1
));
5038 if (SCM_UNLIKELY (SCM_UNBNDP (arg1
) || !scm_is_null (args
)))
5039 scm_wrong_num_args (proc
);
5040 if (SCM_I_INUMP (arg1
))
5042 RETURN (scm_from_double (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
))));
5044 else if (SCM_REALP (arg1
))
5046 RETURN (scm_from_double (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
5048 else if (SCM_BIGP (arg1
))
5050 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
5052 else if (SCM_FRACTIONP (arg1
))
5054 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
5056 SCM_WTA_DISPATCH_1_SUBR (proc
, arg1
, SCM_ARG1
);
5058 if (SCM_UNLIKELY (SCM_UNBNDP (arg1
) || !scm_is_null (args
)))
5059 scm_wrong_num_args (proc
);
5060 RETURN (scm_i_chase_pairs (arg1
, (scm_t_bits
) SCM_SUBRF (proc
)));
5061 case scm_tc7_subr_3
:
5062 if (SCM_UNLIKELY (scm_is_null (args
)
5063 || scm_is_null (SCM_CDR (args
))
5064 || !scm_is_null (SCM_CDDR (args
))))
5065 scm_wrong_num_args (proc
);
5067 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
5069 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
5070 case scm_tc7_lsubr_2
:
5071 if (SCM_UNLIKELY (!scm_is_pair (args
)))
5072 scm_wrong_num_args (proc
);
5074 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
5076 if (scm_is_null (args
))
5077 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
5078 while (SCM_NIMP (args
))
5080 SCM_ASSERT (scm_is_pair (args
), args
, SCM_ARG2
, "apply");
5081 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
5082 args
= SCM_CDR (args
);
5085 case scm_tc7_program
:
5086 if (SCM_UNBNDP (arg1
))
5087 RETURN (scm_c_vm_run (scm_the_vm (), proc
, NULL
, 0));
5089 RETURN (scm_vm_apply (scm_the_vm (), proc
, scm_cons (arg1
, args
)));
5090 case scm_tc7_rpsubr
:
5091 if (scm_is_null (args
))
5092 RETURN (SCM_BOOL_T
);
5093 while (SCM_NIMP (args
))
5095 SCM_ASSERT (scm_is_pair (args
), args
, SCM_ARG2
, "apply");
5096 if (scm_is_false (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
5097 RETURN (SCM_BOOL_F
);
5098 arg1
= SCM_CAR (args
);
5099 args
= SCM_CDR (args
);
5101 RETURN (SCM_BOOL_T
);
5102 case scm_tcs_closures
:
5103 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
5104 if (SCM_UNLIKELY (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
)))
5105 scm_wrong_num_args (proc
);
5107 /* Copy argument list */
5112 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
5113 for (arg1
= SCM_CDR (arg1
); scm_is_pair (arg1
); arg1
= SCM_CDR (arg1
))
5115 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
));
5118 SCM_SETCDR (tl
, arg1
);
5121 args
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
5124 proc
= SCM_CLOSURE_BODY (proc
);
5126 arg1
= SCM_CDR (proc
);
5127 while (!scm_is_null (arg1
))
5129 if (SCM_IMP (SCM_CAR (proc
)))
5131 if (SCM_ISYMP (SCM_CAR (proc
)))
5133 scm_dynwind_begin (0);
5134 scm_i_dynwind_pthread_mutex_lock (&source_mutex
);
5135 /* check for race condition */
5136 if (SCM_ISYMP (SCM_CAR (proc
)))
5137 m_expand_body (proc
, args
);
5142 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
5145 (void) EVAL (SCM_CAR (proc
), args
);
5147 arg1
= SCM_CDR (proc
);
5149 RETURN (EVALCAR (proc
, args
));
5151 if (!SCM_SMOB_APPLICABLE_P (proc
))
5153 if (SCM_UNBNDP (arg1
))
5154 RETURN (SCM_SMOB_APPLY_0 (proc
));
5155 else if (scm_is_null (args
))
5156 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
5157 else if (scm_is_null (SCM_CDR (args
)))
5158 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
5160 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
5162 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
5163 debug
.vect
[0].a
.proc
= proc
;
5164 debug
.vect
[0].a
.args
= args
;
5165 RETURN (scm_i_gsubr_apply_list (proc
, args
));
5167 proc
= SCM_PROCEDURE (proc
);
5168 debug
.vect
[0].a
.proc
= proc
;
5170 case scm_tcs_struct
:
5171 if (SCM_STRUCT_APPLICABLE_P (proc
))
5173 proc
= SCM_STRUCT_PROCEDURE (proc
);
5174 debug
.vect
[0].a
.proc
= proc
;
5175 if (SCM_NIMP (proc
))
5180 else if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5182 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
5183 RETURN (scm_apply_generic (proc
, args
));
5189 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
5192 if (scm_check_exit_p
&& SCM_TRAPS_P
)
5193 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
5195 SCM_CLEAR_TRACED_FRAME (debug
);
5196 arg1
= scm_make_debugobj (&debug
);
5198 arg1
= scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
5200 if (scm_is_pair (arg1
) && scm_is_eq (SCM_CAR (arg1
), sym_instead
))
5201 proc
= SCM_CDR (arg1
);
5203 scm_i_set_last_debug_frame (debug
.prev
);
5215 scm_i_pthread_mutex_init (&source_mutex
,
5216 scm_i_pthread_mutexattr_recursive
);
5218 scm_init_opts (scm_evaluator_traps
,
5219 scm_evaluator_trap_table
);
5220 scm_init_opts (scm_eval_options_interface
,
5223 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
5224 scm_set_smob_print (scm_tc16_promise
, promise_print
);
5226 undefineds
= scm_list_1 (SCM_UNDEFINED
);
5227 SCM_SETCDR (undefineds
, undefineds
);
5228 scm_permanent_object (undefineds
);
5230 scm_listofnull
= scm_list_1 (SCM_EOL
);
5232 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
5233 scm_permanent_object (f_apply
);
5235 #include "libguile/eval.x"
5237 scm_add_feature ("delay");