1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004
2 * Free Software Foundation, Inc.
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public
6 * License as published by the Free Software Foundation; either
7 * version 2.1 of the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
21 /* This file is read twice in order to produce debugging versions of ceval and
22 * scm_apply. These functions, deval and scm_dapply, are produced when we
23 * define the preprocessor macro DEVAL. The file is divided into sections
24 * which are treated differently with respect to DEVAL. The heads of these
25 * sections are marked with the string "SECTION:". */
27 /* SECTION: This code is compiled once.
34 #include "libguile/__scm.h"
38 /* AIX requires this to be the first thing in the file. The #pragma
39 directive is indented so pre-ANSI compilers will ignore it, rather
48 # ifndef alloca /* predefined by HP cc +Olibcalls */
56 #include "libguile/_scm.h"
57 #include "libguile/alist.h"
58 #include "libguile/async.h"
59 #include "libguile/continuations.h"
60 #include "libguile/debug.h"
61 #include "libguile/deprecation.h"
62 #include "libguile/dynwind.h"
63 #include "libguile/eq.h"
64 #include "libguile/feature.h"
65 #include "libguile/fluids.h"
66 #include "libguile/futures.h"
67 #include "libguile/goops.h"
68 #include "libguile/hash.h"
69 #include "libguile/hashtab.h"
70 #include "libguile/lang.h"
71 #include "libguile/list.h"
72 #include "libguile/macros.h"
73 #include "libguile/modules.h"
74 #include "libguile/objects.h"
75 #include "libguile/ports.h"
76 #include "libguile/print.h"
77 #include "libguile/procprop.h"
78 #include "libguile/root.h"
79 #include "libguile/smob.h"
80 #include "libguile/srcprop.h"
81 #include "libguile/stackchk.h"
82 #include "libguile/strings.h"
83 #include "libguile/throw.h"
84 #include "libguile/validate.h"
85 #include "libguile/values.h"
86 #include "libguile/vectors.h"
88 #include "libguile/eval.h"
92 static SCM
canonicalize_define (SCM expr
);
93 static SCM
*scm_lookupcar1 (SCM vloc
, SCM genv
, int check
);
99 * This section defines the message strings for the syntax errors that can be
100 * detected during memoization and the functions and macros that shall be
101 * called by the memoizer code to signal syntax errors. */
104 /* Syntax errors that can be detected during memoization: */
106 /* Circular or improper lists do not form valid scheme expressions. If a
107 * circular list or an improper list is detected in a place where a scheme
108 * expression is expected, a 'Bad expression' error is signalled. */
109 static const char s_bad_expression
[] = "Bad expression";
111 /* If a form is detected that holds a different number of expressions than are
112 * required in that context, a 'Missing or extra expression' error is
114 static const char s_expression
[] = "Missing or extra expression in";
116 /* If a form is detected that holds less expressions than are required in that
117 * context, a 'Missing expression' error is signalled. */
118 static const char s_missing_expression
[] = "Missing expression in";
120 /* If a form is detected that holds more expressions than are allowed in that
121 * context, an 'Extra expression' error is signalled. */
122 static const char s_extra_expression
[] = "Extra expression in";
124 /* The empty combination '()' is not allowed as an expression in scheme. If
125 * it is detected in a place where an expression is expected, an 'Illegal
126 * empty combination' error is signalled. Note: If you encounter this error
127 * message, it is very likely that you intended to denote the empty list. To
128 * do so, you need to quote the empty list like (quote ()) or '(). */
129 static const char s_empty_combination
[] = "Illegal empty combination";
131 /* A body may hold an arbitrary number of internal defines, followed by a
132 * non-empty sequence of expressions. If a body with an empty sequence of
133 * expressions is detected, a 'Missing body expression' error is signalled.
135 static const char s_missing_body_expression
[] = "Missing body expression in";
137 /* A body may hold an arbitrary number of internal defines, followed by a
138 * non-empty sequence of expressions. Each the definitions and the
139 * expressions may be grouped arbitraryly with begin, but it is not allowed to
140 * mix definitions and expressions. If a define form in a body mixes
141 * definitions and expressions, a 'Mixed definitions and expressions' error is
143 static const char s_mixed_body_forms
[] = "Mixed definitions and expressions in";
144 /* Definitions are only allowed on the top level and at the start of a body.
145 * If a definition is detected anywhere else, a 'Bad define placement' error
147 static const char s_bad_define
[] = "Bad define placement";
149 /* Case or cond expressions must have at least one clause. If a case or cond
150 * expression without any clauses is detected, a 'Missing clauses' error is
152 static const char s_missing_clauses
[] = "Missing clauses";
154 /* If there is an 'else' clause in a case or a cond statement, it must be the
155 * last clause. If after the 'else' case clause further clauses are detected,
156 * a 'Misplaced else clause' error is signalled. */
157 static const char s_misplaced_else_clause
[] = "Misplaced else clause";
159 /* If a case clause is detected that is not in the format
160 * (<label(s)> <expression1> <expression2> ...)
161 * a 'Bad case clause' error is signalled. */
162 static const char s_bad_case_clause
[] = "Bad case clause";
164 /* If a case clause is detected where the <label(s)> element is neither a
165 * proper list nor (in case of the last clause) the syntactic keyword 'else',
166 * a 'Bad case labels' error is signalled. Note: If you encounter this error
167 * for an else-clause which seems to be syntactically correct, check if 'else'
168 * is really a syntactic keyword in that context. If 'else' is bound in the
169 * local or global environment, it is not considered a syntactic keyword, but
170 * will be treated as any other variable. */
171 static const char s_bad_case_labels
[] = "Bad case labels";
173 /* In a case statement all labels have to be distinct. If in a case statement
174 * a label occurs more than once, a 'Duplicate case label' error is
176 static const char s_duplicate_case_label
[] = "Duplicate case label";
178 /* If a cond clause is detected that is not in one of the formats
179 * (<test> <expression1> ...) or (else <expression1> <expression2> ...)
180 * a 'Bad cond clause' error is signalled. */
181 static const char s_bad_cond_clause
[] = "Bad cond clause";
183 /* If a cond clause is detected that uses the alternate '=>' form, but does
184 * not hold a recipient element for the test result, a 'Missing recipient'
185 * error is signalled. */
186 static const char s_missing_recipient
[] = "Missing recipient in";
188 /* If in a position where a variable name is required some other object is
189 * detected, a 'Bad variable' error is signalled. */
190 static const char s_bad_variable
[] = "Bad variable";
192 /* Bindings for forms like 'let' and 'do' have to be given in a proper,
193 * possibly empty list. If any other object is detected in a place where a
194 * list of bindings was required, a 'Bad bindings' error is signalled. */
195 static const char s_bad_bindings
[] = "Bad bindings";
197 /* Depending on the syntactic context, a binding has to be in the format
198 * (<variable> <expression>) or (<variable> <expression1> <expression2>).
199 * If anything else is detected in a place where a binding was expected, a
200 * 'Bad binding' error is signalled. */
201 static const char s_bad_binding
[] = "Bad binding";
203 /* Some syntactic forms don't allow variable names to appear more than once in
204 * a list of bindings. If such a situation is nevertheless detected, a
205 * 'Duplicate binding' error is signalled. */
206 static const char s_duplicate_binding
[] = "Duplicate binding";
208 /* If the exit form of a 'do' expression is not in the format
209 * (<test> <expression> ...)
210 * a 'Bad exit clause' error is signalled. */
211 static const char s_bad_exit_clause
[] = "Bad exit clause";
213 /* The formal function arguments of a lambda expression have to be either a
214 * single symbol or a non-cyclic list. For anything else a 'Bad formals'
215 * error is signalled. */
216 static const char s_bad_formals
[] = "Bad formals";
218 /* If in a lambda expression something else than a symbol is detected at a
219 * place where a formal function argument is required, a 'Bad formal' error is
221 static const char s_bad_formal
[] = "Bad formal";
223 /* If in the arguments list of a lambda expression an argument name occurs
224 * more than once, a 'Duplicate formal' error is signalled. */
225 static const char s_duplicate_formal
[] = "Duplicate formal";
227 /* If the evaluation of an unquote-splicing expression gives something else
228 * than a proper list, a 'Non-list result for unquote-splicing' error is
230 static const char s_splicing
[] = "Non-list result for unquote-splicing";
232 /* If something else than an exact integer is detected as the argument for
233 * @slot-ref and @slot-set!, a 'Bad slot number' error is signalled. */
234 static const char s_bad_slot_number
[] = "Bad slot number";
237 /* Signal a syntax error. We distinguish between the form that caused the
238 * error and the enclosing expression. The error message will print out as
239 * shown in the following pattern. The file name and line number are only
240 * given when they can be determined from the erroneous form or from the
241 * enclosing expression.
243 * <filename>: In procedure memoization:
244 * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
246 SCM_SYMBOL (syntax_error_key
, "syntax-error");
248 /* The prototype is needed to indicate that the function does not return. */
250 syntax_error (const char* const, const SCM
, const SCM
) SCM_NORETURN
;
253 syntax_error (const char* const msg
, const SCM form
, const SCM expr
)
255 const SCM msg_string
= scm_makfrom0str (msg
);
256 SCM filename
= SCM_BOOL_F
;
257 SCM linenr
= SCM_BOOL_F
;
261 if (SCM_CONSP (form
))
263 filename
= scm_source_property (form
, scm_sym_filename
);
264 linenr
= scm_source_property (form
, scm_sym_line
);
267 if (SCM_FALSEP (filename
) && SCM_FALSEP (linenr
) && SCM_CONSP (expr
))
269 filename
= scm_source_property (expr
, scm_sym_filename
);
270 linenr
= scm_source_property (expr
, scm_sym_line
);
273 if (!SCM_UNBNDP (expr
))
275 if (!SCM_FALSEP (filename
))
277 format
= "In file ~S, line ~S: ~A ~S in expression ~S.";
278 args
= scm_list_5 (filename
, linenr
, msg_string
, form
, expr
);
280 else if (!SCM_FALSEP (linenr
))
282 format
= "In line ~S: ~A ~S in expression ~S.";
283 args
= scm_list_4 (linenr
, msg_string
, form
, expr
);
287 format
= "~A ~S in expression ~S.";
288 args
= scm_list_3 (msg_string
, form
, expr
);
293 if (!SCM_FALSEP (filename
))
295 format
= "In file ~S, line ~S: ~A ~S.";
296 args
= scm_list_4 (filename
, linenr
, msg_string
, form
);
298 else if (!SCM_FALSEP (linenr
))
300 format
= "In line ~S: ~A ~S.";
301 args
= scm_list_3 (linenr
, msg_string
, form
);
306 args
= scm_list_2 (msg_string
, form
);
310 scm_error (syntax_error_key
, "memoization", format
, args
, SCM_BOOL_F
);
314 /* Shortcut macros to simplify syntax error handling. */
315 #define ASSERT_SYNTAX(cond, message, form) \
316 { if (!(cond)) syntax_error (message, form, SCM_UNDEFINED); }
317 #define ASSERT_SYNTAX_2(cond, message, form, expr) \
318 { if (!(cond)) syntax_error (message, form, expr); }
324 * Ilocs are memoized references to variables in local environment frames.
325 * They are represented as three values: The relative offset of the
326 * environment frame, the number of the binding within that frame, and a
327 * boolean value indicating whether the binding is the last binding in the
331 #define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc)
332 #define SCM_IFRINC (0x00000100L)
333 #define SCM_ICDR (0x00080000L)
334 #define SCM_IDINC (0x00100000L)
335 #define SCM_IFRAME(n) ((long)((SCM_ICDR-SCM_IFRINC)>>8) \
336 & (SCM_UNPACK (n) >> 8))
337 #define SCM_IDIST(n) (SCM_UNPACK (n) >> 20)
338 #define SCM_ICDRP(n) (SCM_ICDR & SCM_UNPACK (n))
339 #define SCM_IDSTMSK (-SCM_IDINC)
340 #define SCM_MAKE_ILOC(frame_nr, binding_nr, last_p) \
343 + ((binding_nr) << 20) \
344 + ((last_p) ? SCM_ICDR : 0) \
348 scm_i_print_iloc (SCM iloc
, SCM port
)
350 scm_puts ("#@", port
);
351 scm_intprint ((long) SCM_IFRAME (iloc
), 10, port
);
352 scm_putc (SCM_ICDRP (iloc
) ? '-' : '+', port
);
353 scm_intprint ((long) SCM_IDIST (iloc
), 10, port
);
356 #if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
358 SCM
scm_dbg_make_iloc (SCM frame
, SCM binding
, SCM cdrp
);
359 SCM_DEFINE (scm_dbg_make_iloc
, "dbg-make-iloc", 3, 0, 0,
360 (SCM frame
, SCM binding
, SCM cdrp
),
361 "Return a new iloc with frame offset @var{frame}, binding\n"
362 "offset @var{binding} and the cdr flag @var{cdrp}.")
363 #define FUNC_NAME s_scm_dbg_make_iloc
365 SCM_VALIDATE_INUM (1, frame
);
366 SCM_VALIDATE_INUM (2, binding
);
367 return SCM_MAKE_ILOC (SCM_INUM (frame
),
373 SCM
scm_dbg_iloc_p (SCM obj
);
374 SCM_DEFINE (scm_dbg_iloc_p
, "dbg-iloc?", 1, 0, 0,
376 "Return @code{#t} if @var{obj} is an iloc.")
377 #define FUNC_NAME s_scm_dbg_iloc_p
379 return SCM_BOOL (SCM_ILOCP (obj
));
387 /* {Evaluator byte codes (isyms)}
390 #define ISYMNUM(n) (SCM_ITAG8_DATA (n))
392 /* This table must agree with the list of SCM_IM_ constants in tags.h */
393 static const char *const isymnames
[] =
410 "#@call-with-current-continuation",
416 "#@call-with-values",
424 scm_i_print_isym (SCM isym
, SCM port
)
426 const size_t isymnum
= ISYMNUM (isym
);
427 if (isymnum
< (sizeof isymnames
/ sizeof (char *)))
428 scm_puts (isymnames
[isymnum
], port
);
430 scm_ipruk ("isym", isym
, port
);
435 /* The function lookup_symbol is used during memoization: Lookup the symbol in
436 * the environment. If there is no binding for the symbol, SCM_UNDEFINED is
437 * returned. If the symbol is a global variable, the variable object to which
438 * the symbol is bound is returned. Finally, if the symbol is a local
439 * variable the corresponding iloc object is returned. */
441 /* A helper function for lookup_symbol: Try to find the symbol in the top
442 * level environment frame. The function returns SCM_UNDEFINED if the symbol
443 * is unbound and it returns a variable object if the symbol is a global
446 lookup_global_symbol (const SCM symbol
, const SCM top_level
)
448 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
449 if (SCM_FALSEP (variable
))
450 return SCM_UNDEFINED
;
456 lookup_symbol (const SCM symbol
, const SCM env
)
459 unsigned int frame_nr
;
461 for (frame_idx
= env
, frame_nr
= 0;
462 !SCM_NULLP (frame_idx
);
463 frame_idx
= SCM_CDR (frame_idx
), ++frame_nr
)
465 const SCM frame
= SCM_CAR (frame_idx
);
466 if (SCM_CONSP (frame
))
468 /* frame holds a local environment frame */
470 unsigned int symbol_nr
;
472 for (symbol_idx
= SCM_CAR (frame
), symbol_nr
= 0;
473 SCM_CONSP (symbol_idx
);
474 symbol_idx
= SCM_CDR (symbol_idx
), ++symbol_nr
)
476 if (SCM_EQ_P (SCM_CAR (symbol_idx
), symbol
))
477 /* found the symbol, therefore return the iloc */
478 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 0);
480 if (SCM_EQ_P (symbol_idx
, symbol
))
481 /* found the symbol as the last element of the current frame */
482 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 1);
486 /* no more local environment frames */
487 return lookup_global_symbol (symbol
, frame
);
491 return lookup_global_symbol (symbol
, SCM_BOOL_F
);
495 /* Return true if the symbol is - from the point of view of a macro
496 * transformer - a literal in the sense specified in chapter "pattern
497 * language" of R5RS. In the code below, however, we don't match the
498 * definition of R5RS exactly: It returns true if the identifier has no
499 * binding or if it is a syntactic keyword. */
501 literal_p (const SCM symbol
, const SCM env
)
503 const SCM variable
= lookup_symbol (symbol
, env
);
504 if (SCM_UNBNDP (variable
))
506 if (SCM_VARIABLEP (variable
) && SCM_MACROP (SCM_VARIABLE_REF (variable
)))
513 /* Return true if the expression is self-quoting in the memoized code. Thus,
514 * some other objects (like e. g. vectors) are reported as self-quoting, which
515 * according to R5RS would need to be quoted. */
517 is_self_quoting_p (const SCM expr
)
519 if (SCM_CONSP (expr
))
521 else if (SCM_SYMBOLP (expr
))
523 else if (SCM_NULLP (expr
))
529 /* Rewrite the body (which is given as the list of expressions forming the
530 * body) into its internal form. The internal form of a body (<expr> ...) is
531 * just the body itself, but prefixed with an ISYM that denotes to what kind
532 * of outer construct this body belongs: (<ISYM> <expr> ...). A lambda body
533 * starts with SCM_IM_LAMBDA, for example, a body of a let starts with
536 * It is assumed that the calling expression has already made sure that the
537 * body is a proper list. */
539 m_body (SCM op
, SCM exprs
)
541 /* Don't add another ISYM if one is present already. */
542 if (SCM_ISYMP (SCM_CAR (exprs
)))
545 return scm_cons (op
, exprs
);
549 /* The function m_expand_body memoizes a proper list of expressions forming a
550 * body. This function takes care of dealing with internal defines and
551 * transforming them into an equivalent letrec expression. The list of
552 * expressions is rewritten in place. */
554 /* This is a helper function for m_expand_body. If the argument expression is
555 * a symbol that denotes a syntactic keyword, the corresponding macro object
556 * is returned, in all other cases the function returns SCM_UNDEFINED. */
558 try_macro_lookup (const SCM expr
, const SCM env
)
560 if (SCM_SYMBOLP (expr
))
562 const SCM variable
= lookup_symbol (expr
, env
);
563 if (SCM_VARIABLEP (variable
))
565 const SCM value
= SCM_VARIABLE_REF (variable
);
566 if (SCM_MACROP (value
))
571 return SCM_UNDEFINED
;
574 /* This is a helper function for m_expand_body. It expands user macros,
575 * because for the correct translation of a body we need to know whether they
576 * expand to a definition. */
578 expand_user_macros (SCM expr
, const SCM env
)
580 while (SCM_CONSP (expr
))
582 const SCM car_expr
= SCM_CAR (expr
);
583 const SCM new_car
= expand_user_macros (car_expr
, env
);
584 const SCM value
= try_macro_lookup (new_car
, env
);
586 if (SCM_MACROP (value
) && SCM_MACRO_TYPE (value
) == 2)
588 /* User macros transform code into code. */
589 expr
= scm_call_2 (SCM_MACRO_CODE (value
), expr
, env
);
590 /* We need to reiterate on the transformed code. */
594 /* No user macro: return. */
595 SCM_SETCAR (expr
, new_car
);
603 /* This is a helper function for m_expand_body. It determines if a given form
604 * represents an application of a given built-in macro. The built-in macro to
605 * check for is identified by its syntactic keyword. The form is an
606 * application of the given macro if looking up the car of the form in the
607 * given environment actually returns the built-in macro. */
609 is_system_macro_p (const SCM syntactic_keyword
, const SCM form
, const SCM env
)
611 if (SCM_CONSP (form
))
613 const SCM car_form
= SCM_CAR (form
);
614 const SCM value
= try_macro_lookup (car_form
, env
);
615 if (SCM_BUILTIN_MACRO_P (value
))
617 const SCM macro_name
= scm_macro_name (value
);
618 return SCM_EQ_P (macro_name
, syntactic_keyword
);
626 m_expand_body (const SCM forms
, const SCM env
)
628 /* The first body form can be skipped since it is known to be the ISYM that
629 * was prepended to the body by m_body. */
630 SCM cdr_forms
= SCM_CDR (forms
);
631 SCM form_idx
= cdr_forms
;
632 SCM definitions
= SCM_EOL
;
633 SCM sequence
= SCM_EOL
;
635 /* According to R5RS, the list of body forms consists of two parts: a number
636 * (maybe zero) of definitions, followed by a non-empty sequence of
637 * expressions. Each the definitions and the expressions may be grouped
638 * arbitrarily with begin, but it is not allowed to mix definitions and
639 * expressions. The task of the following loop therefore is to split the
640 * list of body forms into the list of definitions and the sequence of
642 while (!SCM_NULLP (form_idx
))
644 const SCM form
= SCM_CAR (form_idx
);
645 const SCM new_form
= expand_user_macros (form
, env
);
646 if (is_system_macro_p (scm_sym_define
, new_form
, env
))
648 definitions
= scm_cons (new_form
, definitions
);
649 form_idx
= SCM_CDR (form_idx
);
651 else if (is_system_macro_p (scm_sym_begin
, new_form
, env
))
653 /* We have encountered a group of forms. This has to be either a
654 * (possibly empty) group of (possibly further grouped) definitions,
655 * or a non-empty group of (possibly further grouped)
657 const SCM grouped_forms
= SCM_CDR (new_form
);
658 unsigned int found_definition
= 0;
659 unsigned int found_expression
= 0;
660 SCM grouped_form_idx
= grouped_forms
;
661 while (!found_expression
&& !SCM_NULLP (grouped_form_idx
))
663 const SCM inner_form
= SCM_CAR (grouped_form_idx
);
664 const SCM new_inner_form
= expand_user_macros (inner_form
, env
);
665 if (is_system_macro_p (scm_sym_define
, new_inner_form
, env
))
667 found_definition
= 1;
668 definitions
= scm_cons (new_inner_form
, definitions
);
669 grouped_form_idx
= SCM_CDR (grouped_form_idx
);
671 else if (is_system_macro_p (scm_sym_begin
, new_inner_form
, env
))
673 const SCM inner_group
= SCM_CDR (new_inner_form
);
675 = scm_append (scm_list_2 (inner_group
,
676 SCM_CDR (grouped_form_idx
)));
680 /* The group marks the start of the expressions of the body.
681 * We have to make sure that within the same group we have
682 * not encountered a definition before. */
683 ASSERT_SYNTAX (!found_definition
, s_mixed_body_forms
, form
);
684 found_expression
= 1;
685 grouped_form_idx
= SCM_EOL
;
689 /* We have finished processing the group. If we have not yet
690 * encountered an expression we continue processing the forms of the
691 * body to collect further definition forms. Otherwise, the group
692 * marks the start of the sequence of expressions of the body. */
693 if (!found_expression
)
695 form_idx
= SCM_CDR (form_idx
);
705 /* We have detected a form which is no definition. This marks the
706 * start of the sequence of expressions of the body. */
712 /* FIXME: forms does not hold information about the file location. */
713 ASSERT_SYNTAX (SCM_CONSP (sequence
), s_missing_body_expression
, cdr_forms
);
715 if (!SCM_NULLP (definitions
))
719 SCM letrec_expression
;
720 SCM new_letrec_expression
;
722 SCM bindings
= SCM_EOL
;
723 for (definition_idx
= definitions
;
724 !SCM_NULLP (definition_idx
);
725 definition_idx
= SCM_CDR (definition_idx
))
727 const SCM definition
= SCM_CAR (definition_idx
);
728 const SCM canonical_definition
= canonicalize_define (definition
);
729 const SCM binding
= SCM_CDR (canonical_definition
);
730 bindings
= scm_cons (binding
, bindings
);
733 letrec_tail
= scm_cons (bindings
, sequence
);
734 /* FIXME: forms does not hold information about the file location. */
735 letrec_expression
= scm_cons_source (forms
, scm_sym_letrec
, letrec_tail
);
736 new_letrec_expression
= scm_m_letrec (letrec_expression
, env
);
737 SCM_SETCAR (forms
, new_letrec_expression
);
738 SCM_SETCDR (forms
, SCM_EOL
);
742 SCM_SETCAR (forms
, SCM_CAR (sequence
));
743 SCM_SETCDR (forms
, SCM_CDR (sequence
));
748 macroexp (SCM x
, SCM env
)
750 SCM res
, proc
, orig_sym
;
752 /* Don't bother to produce error messages here. We get them when we
753 eventually execute the code for real. */
756 orig_sym
= SCM_CAR (x
);
757 if (!SCM_SYMBOLP (orig_sym
))
761 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
762 if (proc_ptr
== NULL
)
764 /* We have lost the race. */
770 /* Only handle memoizing macros. `Acros' and `macros' are really
771 special forms and should not be evaluated here. */
773 if (!SCM_MACROP (proc
)
774 || (SCM_MACRO_TYPE (proc
) != 2 && !SCM_BUILTIN_MACRO_P (proc
)))
777 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
778 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
780 if (scm_ilength (res
) <= 0)
781 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
784 SCM_SETCAR (x
, SCM_CAR (res
));
785 SCM_SETCDR (x
, SCM_CDR (res
));
791 /* Start of the memoizers for the standard R5RS builtin macros. */
794 SCM_SYNTAX (s_and
, "and", scm_i_makbimacro
, scm_m_and
);
795 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
798 scm_m_and (SCM expr
, SCM env SCM_UNUSED
)
800 const SCM cdr_expr
= SCM_CDR (expr
);
801 const long length
= scm_ilength (cdr_expr
);
803 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
807 /* Special case: (and) is replaced by #t. */
812 SCM_SETCAR (expr
, SCM_IM_AND
);
818 SCM_SYNTAX (s_begin
, "begin", scm_i_makbimacro
, scm_m_begin
);
819 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
822 scm_m_begin (SCM expr
, SCM env SCM_UNUSED
)
824 const SCM cdr_expr
= SCM_CDR (expr
);
825 /* Dirk:FIXME:: An empty begin clause is not generally allowed by R5RS.
826 * That means, there should be a distinction between uses of begin where an
827 * empty clause is OK and where it is not. */
828 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
830 SCM_SETCAR (expr
, SCM_IM_BEGIN
);
835 SCM_SYNTAX (s_case
, "case", scm_i_makbimacro
, scm_m_case
);
836 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
837 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
840 scm_m_case (SCM expr
, SCM env
)
843 SCM all_labels
= SCM_EOL
;
845 /* Check, whether 'else is a literal, i. e. not bound to a value. */
846 const int else_literal_p
= literal_p (scm_sym_else
, env
);
848 const SCM cdr_expr
= SCM_CDR (expr
);
849 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
850 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_clauses
, expr
);
852 clauses
= SCM_CDR (cdr_expr
);
853 while (!SCM_NULLP (clauses
))
857 const SCM clause
= SCM_CAR (clauses
);
858 ASSERT_SYNTAX_2 (scm_ilength (clause
) >= 2,
859 s_bad_case_clause
, clause
, expr
);
861 labels
= SCM_CAR (clause
);
862 if (SCM_CONSP (labels
))
864 ASSERT_SYNTAX_2 (scm_ilength (labels
) >= 0,
865 s_bad_case_labels
, labels
, expr
);
866 all_labels
= scm_append (scm_list_2 (labels
, all_labels
));
868 else if (SCM_NULLP (labels
))
870 /* The list of labels is empty. According to R5RS this is allowed.
871 * It means that the sequence of expressions will never be executed.
872 * Therefore, as an optimization, we could remove the whole
877 ASSERT_SYNTAX_2 (SCM_EQ_P (labels
, scm_sym_else
) && else_literal_p
,
878 s_bad_case_labels
, labels
, expr
);
879 ASSERT_SYNTAX_2 (SCM_NULLP (SCM_CDR (clauses
)),
880 s_misplaced_else_clause
, clause
, expr
);
883 /* build the new clause */
884 if (SCM_EQ_P (labels
, scm_sym_else
))
885 SCM_SETCAR (clause
, SCM_IM_ELSE
);
887 clauses
= SCM_CDR (clauses
);
890 /* Check whether all case labels are distinct. */
891 for (; !SCM_NULLP (all_labels
); all_labels
= SCM_CDR (all_labels
))
893 const SCM label
= SCM_CAR (all_labels
);
894 ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (label
, SCM_CDR (all_labels
))),
895 s_duplicate_case_label
, label
, expr
);
898 SCM_SETCAR (expr
, SCM_IM_CASE
);
903 SCM_SYNTAX (s_cond
, "cond", scm_i_makbimacro
, scm_m_cond
);
904 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
905 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
908 scm_m_cond (SCM expr
, SCM env
)
910 /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
911 const int else_literal_p
= literal_p (scm_sym_else
, env
);
912 const int arrow_literal_p
= literal_p (scm_sym_arrow
, env
);
914 const SCM clauses
= SCM_CDR (expr
);
917 ASSERT_SYNTAX (scm_ilength (clauses
) >= 0, s_bad_expression
, expr
);
918 ASSERT_SYNTAX (scm_ilength (clauses
) >= 1, s_missing_clauses
, expr
);
920 for (clause_idx
= clauses
;
921 !SCM_NULLP (clause_idx
);
922 clause_idx
= SCM_CDR (clause_idx
))
926 const SCM clause
= SCM_CAR (clause_idx
);
927 const long length
= scm_ilength (clause
);
928 ASSERT_SYNTAX_2 (length
>= 1, s_bad_cond_clause
, clause
, expr
);
930 test
= SCM_CAR (clause
);
931 if (SCM_EQ_P (test
, scm_sym_else
) && else_literal_p
)
933 const int last_clause_p
= SCM_NULLP (SCM_CDR (clause_idx
));
934 ASSERT_SYNTAX_2 (length
>= 2,
935 s_bad_cond_clause
, clause
, expr
);
936 ASSERT_SYNTAX_2 (last_clause_p
,
937 s_misplaced_else_clause
, clause
, expr
);
938 SCM_SETCAR (clause
, SCM_IM_ELSE
);
941 && SCM_EQ_P (SCM_CADR (clause
), scm_sym_arrow
)
944 ASSERT_SYNTAX_2 (length
> 2, s_missing_recipient
, clause
, expr
);
945 ASSERT_SYNTAX_2 (length
== 3, s_extra_expression
, clause
, expr
);
946 SCM_SETCAR (SCM_CDR (clause
), SCM_IM_ARROW
);
950 SCM_SETCAR (expr
, SCM_IM_COND
);
955 SCM_SYNTAX (s_define
, "define", scm_i_makbimacro
, scm_m_define
);
956 SCM_GLOBAL_SYMBOL (scm_sym_define
, s_define
);
958 /* Guile provides an extension to R5RS' define syntax to represent function
959 * currying in a compact way. With this extension, it is allowed to write
960 * (define <nested-variable> <body>), where <nested-variable> has of one of
961 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
962 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
963 * should be either a sequence of zero or more variables, or a sequence of one
964 * or more variables followed by a space-delimited period and another
965 * variable. Each level of argument nesting wraps the <body> within another
966 * lambda expression. For example, the following forms are allowed, each one
967 * followed by an equivalent, more explicit implementation.
969 * (define ((a b . c) . d) <body>) is equivalent to
970 * (define a (lambda (b . c) (lambda d <body>)))
972 * (define (((a) b) c . d) <body>) is equivalent to
973 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
975 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
976 * module that does not implement this extension. */
978 canonicalize_define (const SCM expr
)
983 const SCM cdr_expr
= SCM_CDR (expr
);
984 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
985 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
987 body
= SCM_CDR (cdr_expr
);
988 variable
= SCM_CAR (cdr_expr
);
989 while (SCM_CONSP (variable
))
991 /* This while loop realizes function currying by variable nesting.
992 * Variable is known to be a nested-variable. In every iteration of the
993 * loop another level of lambda expression is created, starting with the
994 * innermost one. Note that we don't check for duplicate formals here:
995 * This will be done by the memoizer of the lambda expression. */
996 const SCM formals
= SCM_CDR (variable
);
997 const SCM tail
= scm_cons (formals
, body
);
999 /* Add source properties to each new lambda expression: */
1000 const SCM lambda
= scm_cons_source (variable
, scm_sym_lambda
, tail
);
1002 body
= scm_list_1 (lambda
);
1003 variable
= SCM_CAR (variable
);
1005 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
), s_bad_variable
, variable
, expr
);
1006 ASSERT_SYNTAX (scm_ilength (body
) == 1, s_expression
, expr
);
1008 SCM_SETCAR (cdr_expr
, variable
);
1009 SCM_SETCDR (cdr_expr
, body
);
1013 /* According to section 5.2.1 of R5RS we first have to make sure that the
1014 * variable is bound, and then perform the (set! variable expression)
1015 * operation. This means, that within the expression we may already assign
1016 * values to variable: (define foo (begin (set! foo 1) (+ foo 1))) */
1018 scm_m_define (SCM expr
, SCM env
)
1020 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), s_bad_define
, expr
);
1023 const SCM canonical_definition
= canonicalize_define (expr
);
1024 const SCM cdr_canonical_definition
= SCM_CDR (canonical_definition
);
1025 const SCM variable
= SCM_CAR (cdr_canonical_definition
);
1027 = scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_T
);
1028 const SCM value
= scm_eval_car (SCM_CDR (cdr_canonical_definition
), env
);
1030 if (SCM_REC_PROCNAMES_P
)
1033 while (SCM_MACROP (tmp
))
1034 tmp
= SCM_MACRO_CODE (tmp
);
1035 if (SCM_CLOSUREP (tmp
)
1036 /* Only the first definition determines the name. */
1037 && SCM_FALSEP (scm_procedure_property (tmp
, scm_sym_name
)))
1038 scm_set_procedure_property_x (tmp
, scm_sym_name
, variable
);
1041 SCM_VARIABLE_SET (location
, value
);
1043 return SCM_UNSPECIFIED
;
1048 /* This is a helper function for forms (<keyword> <expression>) that are
1049 * transformed into (#@<keyword> '() <memoized_expression>) in order to allow
1050 * for easy creation of a thunk (i. e. a closure without arguments) using the
1051 * ('() <memoized_expression>) tail of the memoized form. */
1053 memoize_as_thunk_prototype (const SCM expr
, const SCM env SCM_UNUSED
)
1055 const SCM cdr_expr
= SCM_CDR (expr
);
1056 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1057 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1059 SCM_SETCDR (expr
, scm_cons (SCM_EOL
, cdr_expr
));
1065 SCM_SYNTAX (s_delay
, "delay", scm_i_makbimacro
, scm_m_delay
);
1066 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
1068 /* Promises are implemented as closures with an empty parameter list. Thus,
1069 * (delay <expression>) is transformed into (#@delay '() <expression>), where
1070 * the empty list represents the empty parameter list. This representation
1071 * allows for easy creation of the closure during evaluation. */
1073 scm_m_delay (SCM expr
, SCM env
)
1075 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1076 SCM_SETCAR (new_expr
, SCM_IM_DELAY
);
1081 SCM_SYNTAX(s_do
, "do", scm_i_makbimacro
, scm_m_do
);
1082 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
1084 /* DO gets the most radically altered syntax. The order of the vars is
1085 * reversed here. During the evaluation this allows for simple consing of the
1086 * results of the inits and steps:
1088 (do ((<var1> <init1> <step1>)
1096 (#@do (<init1> <init2> ... <initn>)
1097 (varn ... var2 var1)
1100 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
1103 scm_m_do (SCM expr
, SCM env SCM_UNUSED
)
1105 SCM variables
= SCM_EOL
;
1106 SCM init_forms
= SCM_EOL
;
1107 SCM step_forms
= SCM_EOL
;
1114 const SCM cdr_expr
= SCM_CDR (expr
);
1115 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1116 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1118 /* Collect variables, init and step forms. */
1119 binding_idx
= SCM_CAR (cdr_expr
);
1120 ASSERT_SYNTAX_2 (scm_ilength (binding_idx
) >= 0,
1121 s_bad_bindings
, binding_idx
, expr
);
1122 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1124 const SCM binding
= SCM_CAR (binding_idx
);
1125 const long length
= scm_ilength (binding
);
1126 ASSERT_SYNTAX_2 (length
== 2 || length
== 3,
1127 s_bad_binding
, binding
, expr
);
1130 const SCM name
= SCM_CAR (binding
);
1131 const SCM init
= SCM_CADR (binding
);
1132 const SCM step
= (length
== 2) ? name
: SCM_CADDR (binding
);
1133 ASSERT_SYNTAX_2 (SCM_SYMBOLP (name
), s_bad_variable
, name
, expr
);
1134 ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (name
, variables
)),
1135 s_duplicate_binding
, name
, expr
);
1137 variables
= scm_cons (name
, variables
);
1138 init_forms
= scm_cons (init
, init_forms
);
1139 step_forms
= scm_cons (step
, step_forms
);
1142 init_forms
= scm_reverse_x (init_forms
, SCM_UNDEFINED
);
1143 step_forms
= scm_reverse_x (step_forms
, SCM_UNDEFINED
);
1145 /* Memoize the test form and the exit sequence. */
1146 cddr_expr
= SCM_CDR (cdr_expr
);
1147 exit_clause
= SCM_CAR (cddr_expr
);
1148 ASSERT_SYNTAX_2 (scm_ilength (exit_clause
) >= 1,
1149 s_bad_exit_clause
, exit_clause
, expr
);
1151 commands
= SCM_CDR (cddr_expr
);
1152 tail
= scm_cons2 (exit_clause
, commands
, step_forms
);
1153 tail
= scm_cons2 (init_forms
, variables
, tail
);
1154 SCM_SETCAR (expr
, SCM_IM_DO
);
1155 SCM_SETCDR (expr
, tail
);
1160 SCM_SYNTAX (s_if
, "if", scm_i_makbimacro
, scm_m_if
);
1161 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
1164 scm_m_if (SCM expr
, SCM env SCM_UNUSED
)
1166 const SCM cdr_expr
= SCM_CDR (expr
);
1167 const long length
= scm_ilength (cdr_expr
);
1168 ASSERT_SYNTAX (length
== 2 || length
== 3, s_expression
, expr
);
1169 SCM_SETCAR (expr
, SCM_IM_IF
);
1174 SCM_SYNTAX (s_lambda
, "lambda", scm_i_makbimacro
, scm_m_lambda
);
1175 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
1177 /* A helper function for memoize_lambda to support checking for duplicate
1178 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
1179 * LIST or to the cdr of the last cons. Therefore, LIST may have any of the
1180 * forms that a formal argument can have:
1181 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
1183 c_improper_memq (SCM obj
, SCM list
)
1185 for (; SCM_CONSP (list
); list
= SCM_CDR (list
))
1187 if (SCM_EQ_P (SCM_CAR (list
), obj
))
1190 return SCM_EQ_P (list
, obj
);
1194 scm_m_lambda (SCM expr
, SCM env SCM_UNUSED
)
1203 const SCM cdr_expr
= SCM_CDR (expr
);
1204 const long length
= scm_ilength (cdr_expr
);
1205 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1206 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1208 /* Before iterating the list of formal arguments, make sure the formals
1209 * actually are given as either a symbol or a non-cyclic list. */
1210 formals
= SCM_CAR (cdr_expr
);
1211 if (SCM_CONSP (formals
))
1213 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
1214 * detected, report a 'Bad formals' error. */
1218 ASSERT_SYNTAX_2 (SCM_SYMBOLP (formals
) || SCM_NULLP (formals
),
1219 s_bad_formals
, formals
, expr
);
1222 /* Now iterate the list of formal arguments to check if all formals are
1223 * symbols, and that there are no duplicates. */
1224 formals_idx
= formals
;
1225 while (SCM_CONSP (formals_idx
))
1227 const SCM formal
= SCM_CAR (formals_idx
);
1228 const SCM next_idx
= SCM_CDR (formals_idx
);
1229 ASSERT_SYNTAX_2 (SCM_SYMBOLP (formal
), s_bad_formal
, formal
, expr
);
1230 ASSERT_SYNTAX_2 (!c_improper_memq (formal
, next_idx
),
1231 s_duplicate_formal
, formal
, expr
);
1232 formals_idx
= next_idx
;
1234 ASSERT_SYNTAX_2 (SCM_NULLP (formals_idx
) || SCM_SYMBOLP (formals_idx
),
1235 s_bad_formal
, formals_idx
, expr
);
1237 /* Memoize the body. Keep a potential documentation string. */
1238 /* Dirk:FIXME:: We should probably extract the documentation string to
1239 * some external database. Otherwise it will slow down execution, since
1240 * the documentation string will have to be skipped with every execution
1241 * of the closure. */
1242 cddr_expr
= SCM_CDR (cdr_expr
);
1243 documentation
= (length
>= 3 && SCM_STRINGP (SCM_CAR (cddr_expr
)));
1244 body
= documentation
? SCM_CDR (cddr_expr
) : cddr_expr
;
1245 new_body
= m_body (SCM_IM_LAMBDA
, body
);
1247 SCM_SETCAR (expr
, SCM_IM_LAMBDA
);
1249 SCM_SETCDR (cddr_expr
, new_body
);
1251 SCM_SETCDR (cdr_expr
, new_body
);
1256 /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
1258 check_bindings (const SCM bindings
, const SCM expr
)
1262 ASSERT_SYNTAX_2 (scm_ilength (bindings
) >= 0,
1263 s_bad_bindings
, bindings
, expr
);
1265 binding_idx
= bindings
;
1266 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1268 SCM name
; /* const */
1270 const SCM binding
= SCM_CAR (binding_idx
);
1271 ASSERT_SYNTAX_2 (scm_ilength (binding
) == 2,
1272 s_bad_binding
, binding
, expr
);
1274 name
= SCM_CAR (binding
);
1275 ASSERT_SYNTAX_2 (SCM_SYMBOLP (name
), s_bad_variable
, name
, expr
);
1280 /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
1281 * transformed to the lists (vn ... v2 v1) and (i1 i2 ... in). That is, the
1282 * variables are returned in a list with their order reversed, and the init
1283 * forms are returned in a list in the same order as they are given in the
1284 * bindings. If a duplicate variable name is detected, an error is
1287 transform_bindings (
1288 const SCM bindings
, const SCM expr
,
1289 SCM
*const rvarptr
, SCM
*const initptr
)
1291 SCM rvariables
= SCM_EOL
;
1292 SCM rinits
= SCM_EOL
;
1293 SCM binding_idx
= bindings
;
1294 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1296 const SCM binding
= SCM_CAR (binding_idx
);
1297 const SCM cdr_binding
= SCM_CDR (binding
);
1298 const SCM name
= SCM_CAR (binding
);
1299 ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (name
, rvariables
)),
1300 s_duplicate_binding
, name
, expr
);
1301 rvariables
= scm_cons (name
, rvariables
);
1302 rinits
= scm_cons (SCM_CAR (cdr_binding
), rinits
);
1304 *rvarptr
= rvariables
;
1305 *initptr
= scm_reverse_x (rinits
, SCM_UNDEFINED
);
1309 SCM_SYNTAX(s_let
, "let", scm_i_makbimacro
, scm_m_let
);
1310 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
1312 /* This function is a helper function for memoize_let. It transforms
1313 * (let name ((var init) ...) body ...) into
1314 * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
1315 * and memoizes the expression. It is assumed that the caller has checked
1316 * that name is a symbol and that there are bindings and a body. */
1318 memoize_named_let (const SCM expr
, const SCM env SCM_UNUSED
)
1324 const SCM cdr_expr
= SCM_CDR (expr
);
1325 const SCM name
= SCM_CAR (cdr_expr
);
1326 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1327 const SCM bindings
= SCM_CAR (cddr_expr
);
1328 check_bindings (bindings
, expr
);
1330 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1331 variables
= scm_reverse_x (rvariables
, SCM_UNDEFINED
);
1334 const SCM let_body
= SCM_CDR (cddr_expr
);
1335 const SCM lambda_body
= m_body (SCM_IM_LET
, let_body
);
1336 const SCM lambda_tail
= scm_cons (variables
, lambda_body
);
1337 const SCM lambda_form
= scm_cons_source (expr
, scm_sym_lambda
, lambda_tail
);
1339 const SCM rvar
= scm_list_1 (name
);
1340 const SCM init
= scm_list_1 (lambda_form
);
1341 const SCM body
= m_body (SCM_IM_LET
, scm_list_1 (name
));
1342 const SCM letrec_tail
= scm_cons (rvar
, scm_cons (init
, body
));
1343 const SCM letrec_form
= scm_cons_source (expr
, SCM_IM_LETREC
, letrec_tail
);
1344 return scm_cons_source (expr
, letrec_form
, inits
);
1348 /* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1349 * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
1351 scm_m_let (SCM expr
, SCM env
)
1355 const SCM cdr_expr
= SCM_CDR (expr
);
1356 const long length
= scm_ilength (cdr_expr
);
1357 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1358 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1360 bindings
= SCM_CAR (cdr_expr
);
1361 if (SCM_SYMBOLP (bindings
))
1363 ASSERT_SYNTAX (length
>= 3, s_missing_expression
, expr
);
1364 return memoize_named_let (expr
, env
);
1367 check_bindings (bindings
, expr
);
1368 if (SCM_NULLP (bindings
) || SCM_NULLP (SCM_CDR (bindings
)))
1370 /* Special case: no bindings or single binding => let* is faster. */
1371 const SCM body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1372 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), bindings
, body
), env
);
1379 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1382 const SCM new_body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1383 const SCM new_tail
= scm_cons2 (rvariables
, inits
, new_body
);
1384 SCM_SETCAR (expr
, SCM_IM_LET
);
1385 SCM_SETCDR (expr
, new_tail
);
1392 SCM_SYNTAX (s_letstar
, "let*", scm_i_makbimacro
, scm_m_letstar
);
1393 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
1395 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1396 * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
1398 scm_m_letstar (SCM expr
, SCM env SCM_UNUSED
)
1403 const SCM cdr_expr
= SCM_CDR (expr
);
1404 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1405 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1407 binding_idx
= SCM_CAR (cdr_expr
);
1408 check_bindings (binding_idx
, expr
);
1410 /* Transform ((v1 i1) (v2 i2) ...) into (v1 i1 v2 i2 ...). The
1411 * transformation is done in place. At the beginning of one iteration of
1412 * the loop the variable binding_idx holds the form
1413 * P1:( (vn . P2:(in . ())) . P3:( (vn+1 in+1) ... ) ),
1414 * where P1, P2 and P3 indicate the pairs, that are relevant for the
1415 * transformation. P1 and P2 are modified in the loop, P3 remains
1416 * untouched. After the execution of the loop, P1 will hold
1417 * P1:( vn . P2:(in . P3:( (vn+1 in+1) ... )) )
1418 * and binding_idx will hold P3. */
1419 while (!SCM_NULLP (binding_idx
))
1421 const SCM cdr_binding_idx
= SCM_CDR (binding_idx
); /* remember P3 */
1422 const SCM binding
= SCM_CAR (binding_idx
);
1423 const SCM name
= SCM_CAR (binding
);
1424 const SCM cdr_binding
= SCM_CDR (binding
);
1426 SCM_SETCDR (cdr_binding
, cdr_binding_idx
); /* update P2 */
1427 SCM_SETCAR (binding_idx
, name
); /* update P1 */
1428 SCM_SETCDR (binding_idx
, cdr_binding
); /* update P1 */
1430 binding_idx
= cdr_binding_idx
; /* continue with P3 */
1433 new_body
= m_body (SCM_IM_LETSTAR
, SCM_CDR (cdr_expr
));
1434 SCM_SETCAR (expr
, SCM_IM_LETSTAR
);
1435 /* the bindings have been changed in place */
1436 SCM_SETCDR (cdr_expr
, new_body
);
1441 SCM_SYNTAX(s_letrec
, "letrec", scm_i_makbimacro
, scm_m_letrec
);
1442 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
1445 scm_m_letrec (SCM expr
, SCM env
)
1449 const SCM cdr_expr
= SCM_CDR (expr
);
1450 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1451 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1453 bindings
= SCM_CAR (cdr_expr
);
1454 if (SCM_NULLP (bindings
))
1456 /* no bindings, let* is executed faster */
1457 SCM body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1458 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), SCM_EOL
, body
), env
);
1466 check_bindings (bindings
, expr
);
1467 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1468 new_body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1469 return scm_cons2 (SCM_IM_LETREC
, rvariables
, scm_cons (inits
, new_body
));
1474 SCM_SYNTAX (s_or
, "or", scm_i_makbimacro
, scm_m_or
);
1475 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
1478 scm_m_or (SCM expr
, SCM env SCM_UNUSED
)
1480 const SCM cdr_expr
= SCM_CDR (expr
);
1481 const long length
= scm_ilength (cdr_expr
);
1483 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1487 /* Special case: (or) is replaced by #f. */
1492 SCM_SETCAR (expr
, SCM_IM_OR
);
1498 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
1499 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
1500 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
1501 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
1503 /* Internal function to handle a quasiquotation: 'form' is the parameter in
1504 * the call (quasiquotation form), 'env' is the environment where unquoted
1505 * expressions will be evaluated, and 'depth' is the current quasiquotation
1506 * nesting level and is known to be greater than zero. */
1508 iqq (SCM form
, SCM env
, unsigned long int depth
)
1510 if (SCM_CONSP (form
))
1512 const SCM tmp
= SCM_CAR (form
);
1513 if (SCM_EQ_P (tmp
, scm_sym_quasiquote
))
1515 const SCM args
= SCM_CDR (form
);
1516 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1517 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
1519 else if (SCM_EQ_P (tmp
, scm_sym_unquote
))
1521 const SCM args
= SCM_CDR (form
);
1522 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1524 return scm_eval_car (args
, env
);
1526 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
1528 else if (SCM_CONSP (tmp
)
1529 && SCM_EQ_P (SCM_CAR (tmp
), scm_sym_uq_splicing
))
1531 const SCM args
= SCM_CDR (tmp
);
1532 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1535 const SCM list
= scm_eval_car (args
, env
);
1536 const SCM rest
= SCM_CDR (form
);
1537 ASSERT_SYNTAX_2 (scm_ilength (list
) >= 0,
1538 s_splicing
, list
, form
);
1539 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
1542 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
1543 iqq (SCM_CDR (form
), env
, depth
));
1546 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
1547 iqq (SCM_CDR (form
), env
, depth
));
1549 else if (SCM_VECTORP (form
))
1551 size_t i
= SCM_VECTOR_LENGTH (form
);
1552 SCM
const *const data
= SCM_VELTS (form
);
1555 tmp
= scm_cons (data
[--i
], tmp
);
1556 scm_remember_upto_here_1 (form
);
1557 return scm_vector (iqq (tmp
, env
, depth
));
1564 scm_m_quasiquote (SCM expr
, SCM env
)
1566 const SCM cdr_expr
= SCM_CDR (expr
);
1567 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1568 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1569 return iqq (SCM_CAR (cdr_expr
), env
, 1);
1573 SCM_SYNTAX (s_quote
, "quote", scm_i_makbimacro
, scm_m_quote
);
1574 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
1577 scm_m_quote (SCM expr
, SCM env SCM_UNUSED
)
1581 const SCM cdr_expr
= SCM_CDR (expr
);
1582 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1583 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1584 quotee
= SCM_CAR (cdr_expr
);
1585 if (is_self_quoting_p (quotee
))
1588 SCM_SETCAR (expr
, SCM_IM_QUOTE
);
1589 SCM_SETCDR (expr
, quotee
);
1594 unmemoize_quote (const SCM expr
, const SCM env SCM_UNUSED
)
1596 return scm_list_2 (scm_sym_quote
, SCM_CDR (expr
));
1600 /* Will go into the RnRS module when Guile is factorized.
1601 SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
1602 static const char s_set_x
[] = "set!";
1603 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, s_set_x
);
1606 scm_m_set_x (SCM expr
, SCM env SCM_UNUSED
)
1611 const SCM cdr_expr
= SCM_CDR (expr
);
1612 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1613 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1614 variable
= SCM_CAR (cdr_expr
);
1616 /* Memoize the variable form. */
1617 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
), s_bad_variable
, variable
, expr
);
1618 new_variable
= lookup_symbol (variable
, env
);
1619 /* Leave the memoization of unbound symbols to lazy memoization: */
1620 if (SCM_UNBNDP (new_variable
))
1621 new_variable
= variable
;
1623 SCM_SETCAR (expr
, SCM_IM_SET_X
);
1624 SCM_SETCAR (cdr_expr
, new_variable
);
1629 /* Start of the memoizers for non-R5RS builtin macros. */
1632 SCM_SYNTAX (s_atapply
, "@apply", scm_i_makbimacro
, scm_m_apply
);
1633 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1634 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1637 scm_m_apply (SCM expr
, SCM env SCM_UNUSED
)
1639 const SCM cdr_expr
= SCM_CDR (expr
);
1640 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1641 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_missing_expression
, expr
);
1643 SCM_SETCAR (expr
, SCM_IM_APPLY
);
1648 SCM_SYNTAX (s_atbind
, "@bind", scm_i_makbimacro
, scm_m_atbind
);
1650 /* FIXME: The following explanation should go into the documentation: */
1651 /* (@bind ((var init) ...) body ...) will assign the values of the `init's to
1652 * the global variables named by `var's (symbols, not evaluated), creating
1653 * them if they don't exist, executes body, and then restores the previous
1654 * values of the `var's. Additionally, whenever control leaves body, the
1655 * values of the `var's are saved and restored when control returns. It is an
1656 * error when a symbol appears more than once among the `var's. All `init's
1657 * are evaluated before any `var' is set.
1659 * Think of this as `let' for dynamic scope.
1662 /* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into
1663 * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...).
1665 * FIXME - also implement `@bind*'.
1668 scm_m_atbind (SCM expr
, SCM env
)
1675 const SCM top_level
= scm_env_top_level (env
);
1677 const SCM cdr_expr
= SCM_CDR (expr
);
1678 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1679 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1680 bindings
= SCM_CAR (cdr_expr
);
1681 check_bindings (bindings
, expr
);
1682 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1684 for (variable_idx
= rvariables
;
1685 !SCM_NULLP (variable_idx
);
1686 variable_idx
= SCM_CDR (variable_idx
))
1688 /* The first call to scm_sym2var will look beyond the current module,
1689 * while the second call wont. */
1690 const SCM variable
= SCM_CAR (variable_idx
);
1691 SCM new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_F
);
1692 if (SCM_FALSEP (new_variable
))
1693 new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_T
);
1694 SCM_SETCAR (variable_idx
, new_variable
);
1697 SCM_SETCAR (expr
, SCM_IM_BIND
);
1698 SCM_SETCAR (cdr_expr
, scm_cons (rvariables
, inits
));
1703 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_i_makbimacro
, scm_m_cont
);
1704 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, s_atcall_cc
);
1707 scm_m_cont (SCM expr
, SCM env SCM_UNUSED
)
1709 const SCM cdr_expr
= SCM_CDR (expr
);
1710 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1711 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1713 SCM_SETCAR (expr
, SCM_IM_CONT
);
1718 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_i_makbimacro
, scm_m_at_call_with_values
);
1719 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
1722 scm_m_at_call_with_values (SCM expr
, SCM env SCM_UNUSED
)
1724 const SCM cdr_expr
= SCM_CDR (expr
);
1725 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1726 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1728 SCM_SETCAR (expr
, SCM_IM_CALL_WITH_VALUES
);
1733 SCM_SYNTAX (s_future
, "future", scm_i_makbimacro
, scm_m_future
);
1734 SCM_GLOBAL_SYMBOL (scm_sym_future
, s_future
);
1736 /* Like promises, futures are implemented as closures with an empty
1737 * parameter list. Thus, (future <expression>) is transformed into
1738 * (#@future '() <expression>), where the empty list represents the
1739 * empty parameter list. This representation allows for easy creation
1740 * of the closure during evaluation. */
1742 scm_m_future (SCM expr
, SCM env
)
1744 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1745 SCM_SETCAR (new_expr
, SCM_IM_FUTURE
);
1750 SCM_SYNTAX (s_gset_x
, "set!", scm_i_makbimacro
, scm_m_generalized_set_x
);
1751 SCM_SYMBOL (scm_sym_setter
, "setter");
1754 scm_m_generalized_set_x (SCM expr
, SCM env
)
1756 SCM target
, exp_target
;
1758 const SCM cdr_expr
= SCM_CDR (expr
);
1759 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1760 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1762 target
= SCM_CAR (cdr_expr
);
1763 if (!SCM_CONSP (target
))
1766 return scm_m_set_x (expr
, env
);
1770 /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */
1771 /* Macroexpanding the target might return things of the form
1772 (begin <atom>). In that case, <atom> must be a symbol or a
1773 variable and we memoize to (set! <atom> ...).
1775 exp_target
= macroexp (target
, env
);
1776 if (SCM_EQ_P (SCM_CAR (exp_target
), SCM_IM_BEGIN
)
1777 && !SCM_NULLP (SCM_CDR (exp_target
))
1778 && SCM_NULLP (SCM_CDDR (exp_target
)))
1780 exp_target
= SCM_CADR (exp_target
);
1781 ASSERT_SYNTAX_2 (SCM_SYMBOLP (exp_target
)
1782 || SCM_VARIABLEP (exp_target
),
1783 s_bad_variable
, exp_target
, expr
);
1784 return scm_cons (SCM_IM_SET_X
, scm_cons (exp_target
,
1785 SCM_CDR (cdr_expr
)));
1789 const SCM setter_proc_tail
= scm_list_1 (SCM_CAR (target
));
1790 const SCM setter_proc
= scm_cons_source (expr
, scm_sym_setter
,
1793 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1794 const SCM setter_args
= scm_append_x (scm_list_2 (SCM_CDR (target
),
1797 SCM_SETCAR (expr
, setter_proc
);
1798 SCM_SETCDR (expr
, setter_args
);
1805 /* @slot-ref is bound privately in the (oop goops) module from goops.c. As
1806 * soon as the module system allows us to more freely create bindings in
1807 * arbitrary modules during the startup phase, the code from goops.c should be
1810 scm_m_atslot_ref (SCM expr
, SCM env SCM_UNUSED
)
1814 const SCM cdr_expr
= SCM_CDR (expr
);
1815 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1816 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1817 slot_nr
= SCM_CADR (cdr_expr
);
1818 ASSERT_SYNTAX_2 (SCM_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
1820 SCM_SETCAR (expr
, SCM_IM_SLOT_REF
);
1821 SCM_SETCDR (cdr_expr
, slot_nr
);
1826 /* @slot-set! is bound privately in the (oop goops) module from goops.c. As
1827 * soon as the module system allows us to more freely create bindings in
1828 * arbitrary modules during the startup phase, the code from goops.c should be
1831 scm_m_atslot_set_x (SCM expr
, SCM env SCM_UNUSED
)
1835 const SCM cdr_expr
= SCM_CDR (expr
);
1836 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1837 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 3, s_expression
, expr
);
1838 slot_nr
= SCM_CADR (cdr_expr
);
1839 ASSERT_SYNTAX_2 (SCM_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
1841 SCM_SETCAR (expr
, SCM_IM_SLOT_SET_X
);
1846 #if SCM_ENABLE_ELISP
1848 static const char s_defun
[] = "Symbol's function definition is void";
1850 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_i_makbimacro
, scm_m_nil_cond
);
1852 /* nil-cond expressions have the form
1853 * (nil-cond COND VAL COND VAL ... ELSEVAL) */
1855 scm_m_nil_cond (SCM expr
, SCM env SCM_UNUSED
)
1857 const long length
= scm_ilength (SCM_CDR (expr
));
1858 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1859 ASSERT_SYNTAX (length
>= 1 && (length
% 2) == 1, s_expression
, expr
);
1861 SCM_SETCAR (expr
, SCM_IM_NIL_COND
);
1866 SCM_SYNTAX (s_atfop
, "@fop", scm_i_makbimacro
, scm_m_atfop
);
1868 /* The @fop-macro handles procedure and macro applications for elisp. The
1869 * input expression must have the form
1870 * (@fop <var> (transformer-macro <expr> ...))
1871 * where <var> must be a symbol. The expression is transformed into the
1872 * memoized form of either
1873 * (apply <un-aliased var> (transformer-macro <expr> ...))
1874 * if the value of var (across all aliasing) is not a macro, or
1875 * (<un-aliased var> <expr> ...)
1876 * if var is a macro. */
1878 scm_m_atfop (SCM expr
, SCM env SCM_UNUSED
)
1883 const SCM cdr_expr
= SCM_CDR (expr
);
1884 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1885 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 1, s_missing_expression
, expr
);
1887 symbol
= SCM_CAR (cdr_expr
);
1888 ASSERT_SYNTAX_2 (SCM_SYMBOLP (symbol
), s_bad_variable
, symbol
, expr
);
1890 location
= scm_symbol_fref (symbol
);
1891 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
1893 /* The elisp function `defalias' allows to define aliases for symbols. To
1894 * look up such definitions, the chain of symbol definitions has to be
1895 * followed up to the terminal symbol. */
1896 while (SCM_SYMBOLP (SCM_VARIABLE_REF (location
)))
1898 const SCM alias
= SCM_VARIABLE_REF (location
);
1899 location
= scm_symbol_fref (alias
);
1900 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
1903 /* Memoize the value location belonging to the terminal symbol. */
1904 SCM_SETCAR (cdr_expr
, location
);
1906 if (!SCM_MACROP (SCM_VARIABLE_REF (location
)))
1908 /* Since the location does not contain a macro, the form is a procedure
1909 * application. Replace `@fop' by `@apply' and transform the expression
1910 * including the `transformer-macro'. */
1911 SCM_SETCAR (expr
, SCM_IM_APPLY
);
1916 /* Since the location contains a macro, the arguments should not be
1917 * transformed, so the `transformer-macro' is cut out. The resulting
1918 * expression starts with the memoized variable, that is at the cdr of
1919 * the input expression. */
1920 SCM_SETCDR (cdr_expr
, SCM_CDADR (cdr_expr
));
1925 #endif /* SCM_ENABLE_ELISP */
1928 #if (SCM_ENABLE_DEPRECATED == 1)
1930 /* Deprecated in guile 1.7.0 on 2003-11-09. */
1932 scm_m_expand_body (SCM exprs
, SCM env
)
1934 scm_c_issue_deprecation_warning
1935 ("`scm_m_expand_body' is deprecated.");
1936 m_expand_body (exprs
, env
);
1941 SCM_SYNTAX (s_undefine
, "undefine", scm_makacro
, scm_m_undefine
);
1944 scm_m_undefine (SCM expr
, SCM env
)
1949 const SCM cdr_expr
= SCM_CDR (expr
);
1950 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), "Bad undefine placement in", expr
);
1951 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1952 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1954 scm_c_issue_deprecation_warning
1955 ("`undefine' is deprecated.\n");
1957 variable
= SCM_CAR (cdr_expr
);
1958 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
), s_bad_variable
, variable
, expr
);
1959 location
= scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_F
);
1960 ASSERT_SYNTAX_2 (!SCM_FALSEP (location
)
1961 && !SCM_UNBNDP (SCM_VARIABLE_REF (location
)),
1962 "variable already unbound ", variable
, expr
);
1963 SCM_VARIABLE_SET (location
, SCM_UNDEFINED
);
1964 return SCM_UNSPECIFIED
;
1968 scm_macroexp (SCM x
, SCM env
)
1970 scm_c_issue_deprecation_warning
1971 ("`scm_macroexp' is deprecated.");
1972 return macroexp (x
, env
);
1977 /*****************************************************************************/
1978 /*****************************************************************************/
1979 /* The definitions for unmemoization start here. */
1980 /*****************************************************************************/
1981 /*****************************************************************************/
1983 #define SCM_BIT7(x) (127 & SCM_UNPACK (x))
1985 SCM_SYMBOL (sym_three_question_marks
, "???");
1988 /* scm_unmemocopy takes a memoized expression together with its
1989 * environment and rewrites it to its original form. Thus, it is the
1990 * inversion of the rewrite rules above. The procedure is not
1991 * optimized for speed. It's used in scm_iprin1 when printing the
1992 * code of a closure, in scm_procedure_source, in display_frame when
1993 * generating the source for a stackframe in a backtrace, and in
1994 * display_expression.
1996 * Unmemoizing is not a reliable process. You cannot in general
1997 * expect to get the original source back.
1999 * However, GOOPS currently relies on this for method compilation.
2000 * This ought to change.
2004 build_binding_list (SCM rnames
, SCM rinits
)
2006 SCM bindings
= SCM_EOL
;
2007 while (!SCM_NULLP (rnames
))
2009 SCM binding
= scm_list_2 (SCM_CAR (rnames
), SCM_CAR (rinits
));
2010 bindings
= scm_cons (binding
, bindings
);
2011 rnames
= SCM_CDR (rnames
);
2012 rinits
= SCM_CDR (rinits
);
2019 unmemocar (SCM form
, SCM env
)
2021 if (!SCM_CONSP (form
))
2025 SCM c
= SCM_CAR (form
);
2026 if (SCM_VARIABLEP (c
))
2028 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
2029 if (SCM_FALSEP (sym
))
2030 sym
= sym_three_question_marks
;
2031 SCM_SETCAR (form
, sym
);
2033 else if (SCM_ILOCP (c
))
2035 unsigned long int ir
;
2037 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
2038 env
= SCM_CDR (env
);
2039 env
= SCM_CAAR (env
);
2040 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
2041 env
= SCM_CDR (env
);
2043 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
2051 scm_unmemocopy (SCM x
, SCM env
)
2056 if (SCM_VECTORP (x
))
2058 return scm_list_2 (scm_sym_quote
, x
);
2060 else if (!SCM_CONSP (x
))
2063 p
= scm_whash_lookup (scm_source_whash
, x
);
2064 if (SCM_ISYMP (SCM_CAR (x
)))
2066 switch (ISYMNUM (SCM_CAR (x
)))
2068 case (ISYMNUM (SCM_IM_AND
)):
2069 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
2071 case (ISYMNUM (SCM_IM_BEGIN
)):
2072 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
2074 case (ISYMNUM (SCM_IM_CASE
)):
2075 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
2077 case (ISYMNUM (SCM_IM_COND
)):
2078 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
2080 case (ISYMNUM (SCM_IM_DO
)):
2082 /* format: (#@do (i1 ... ik) (nk ... n1) (test) (body) s1 ... sk),
2083 * where ix is an initializer for a local variable, nx is the name
2084 * of the local variable, test is the test clause of the do loop,
2085 * body is the body of the do loop and sx are the step clauses for
2086 * the local variables. */
2087 SCM names
, inits
, test
, memoized_body
, steps
, bindings
;
2090 inits
= scm_reverse (scm_unmemocopy (SCM_CAR (x
), env
));
2092 names
= SCM_CAR (x
);
2093 env
= SCM_EXTEND_ENV (names
, SCM_EOL
, env
);
2095 test
= scm_unmemocopy (SCM_CAR (x
), env
);
2097 memoized_body
= SCM_CAR (x
);
2099 steps
= scm_reverse (scm_unmemocopy (x
, env
));
2101 /* build transformed binding list */
2103 while (!SCM_NULLP (names
))
2105 SCM name
= SCM_CAR (names
);
2106 SCM init
= SCM_CAR (inits
);
2107 SCM step
= SCM_CAR (steps
);
2108 step
= SCM_EQ_P (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
2110 bindings
= scm_cons (scm_cons2 (name
, init
, step
), bindings
);
2112 names
= SCM_CDR (names
);
2113 inits
= SCM_CDR (inits
);
2114 steps
= SCM_CDR (steps
);
2116 z
= scm_cons (test
, SCM_UNSPECIFIED
);
2117 ls
= scm_cons2 (scm_sym_do
, bindings
, z
);
2119 x
= scm_cons (SCM_BOOL_F
, memoized_body
);
2122 case (ISYMNUM (SCM_IM_IF
)):
2123 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
2125 case (ISYMNUM (SCM_IM_LET
)):
2127 /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),
2128 * where nx is the name of a local variable, ix is an initializer
2129 * for the local variable and by are the body clauses. */
2130 SCM rnames
, rinits
, bindings
;
2133 rnames
= SCM_CAR (x
);
2135 rinits
= scm_reverse (scm_unmemocopy (SCM_CAR (x
), env
));
2136 env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
2138 bindings
= build_binding_list (rnames
, rinits
);
2139 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
2140 ls
= scm_cons (scm_sym_let
, z
);
2143 case (ISYMNUM (SCM_IM_LETREC
)):
2145 /* format: (#@letrec (vn ... v2 v1) (i1 i2 ... in) b1 ...),
2146 * where vx is the name of a local variable, ix is an initializer
2147 * for the local variable and by are the body clauses. */
2148 SCM rnames
, rinits
, bindings
;
2151 rnames
= SCM_CAR (x
);
2152 env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
2154 rinits
= scm_reverse (scm_unmemocopy (SCM_CAR (x
), env
));
2156 bindings
= build_binding_list (rnames
, rinits
);
2157 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
2158 ls
= scm_cons (scm_sym_letrec
, z
);
2161 case (ISYMNUM (SCM_IM_LETSTAR
)):
2169 env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2173 SCM copy
= scm_unmemocopy (SCM_CADR (b
), env
);
2174 SCM initializer
= unmemocar (scm_list_1 (copy
), env
);
2175 y
= z
= scm_acons (SCM_CAR (b
), initializer
, SCM_UNSPECIFIED
);
2176 env
= SCM_EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
2180 SCM_SETCDR (y
, SCM_EOL
);
2181 z
= scm_cons (y
, SCM_UNSPECIFIED
);
2182 ls
= scm_cons (scm_sym_let
, z
);
2187 copy
= scm_unmemocopy (SCM_CADR (b
), env
);
2188 initializer
= unmemocar (scm_list_1 (copy
), env
);
2189 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
2193 env
= SCM_EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
2196 while (!SCM_NULLP (b
));
2197 SCM_SETCDR (z
, SCM_EOL
);
2199 z
= scm_cons (y
, SCM_UNSPECIFIED
);
2200 ls
= scm_cons (scm_sym_letstar
, z
);
2203 case (ISYMNUM (SCM_IM_OR
)):
2204 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
2206 case (ISYMNUM (SCM_IM_LAMBDA
)):
2208 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
);
2209 ls
= scm_cons (scm_sym_lambda
, z
);
2210 env
= SCM_EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
2213 case (ISYMNUM (SCM_IM_QUOTE
)):
2214 return unmemoize_quote (x
, env
);
2216 case (ISYMNUM (SCM_IM_SET_X
)):
2217 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
2219 case (ISYMNUM (SCM_IM_APPLY
)):
2220 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
2222 case (ISYMNUM (SCM_IM_CONT
)):
2223 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
2225 case (ISYMNUM (SCM_IM_DELAY
)):
2226 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
2229 case (ISYMNUM (SCM_IM_FUTURE
)):
2230 ls
= z
= scm_cons (scm_sym_future
, SCM_UNSPECIFIED
);
2233 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2234 ls
= z
= scm_cons (scm_sym_at_call_with_values
, SCM_UNSPECIFIED
);
2236 case (ISYMNUM (SCM_IM_ELSE
)):
2237 ls
= z
= scm_cons (scm_sym_else
, SCM_UNSPECIFIED
);
2240 ls
= z
= unmemocar (scm_cons (scm_unmemocopy (SCM_CAR (x
), env
),
2247 ls
= z
= unmemocar (scm_cons (scm_unmemocopy (SCM_CAR (x
), env
),
2253 while (SCM_CONSP (x
))
2255 SCM form
= SCM_CAR (x
);
2256 if (!SCM_ISYMP (form
))
2258 SCM copy
= scm_cons (scm_unmemocopy (form
, env
), SCM_UNSPECIFIED
);
2259 SCM_SETCDR (z
, unmemocar (copy
, env
));
2262 else if (SCM_EQ_P (form
, SCM_IM_ARROW
))
2264 SCM_SETCDR (z
, scm_cons (scm_sym_arrow
, SCM_UNSPECIFIED
));
2270 if (!SCM_FALSEP (p
))
2271 scm_whash_insert (scm_source_whash
, ls
, p
);
2276 #if (SCM_ENABLE_DEPRECATED == 1)
2279 scm_unmemocar (SCM form
, SCM env
)
2281 return unmemocar (form
, env
);
2286 /*****************************************************************************/
2287 /*****************************************************************************/
2288 /* The definitions for execution start here. */
2289 /*****************************************************************************/
2290 /*****************************************************************************/
2292 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
2293 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
2294 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
2295 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
2297 /* A function object to implement "apply" for non-closure functions. */
2299 /* An endless list consisting of #<undefined> objects: */
2300 static SCM undefineds
;
2304 scm_badargsp (SCM formals
, SCM args
)
2306 while (!SCM_NULLP (formals
))
2308 if (!SCM_CONSP (formals
))
2310 if (SCM_NULLP (args
))
2312 formals
= SCM_CDR (formals
);
2313 args
= SCM_CDR (args
);
2315 return !SCM_NULLP (args
) ? 1 : 0;
2320 /* The evaluator contains a plethora of EVAL symbols. This is an attempt at
2323 * The following macros should be used in code which is read twice (where the
2324 * choice of evaluator is hard soldered):
2326 * CEVAL is the symbol used within one evaluator to call itself.
2327 * Originally, it is defined to ceval, but is redefined to deval during the
2330 * SCM_EVALIM is used when it is known that the expression is an
2331 * immediate. (This macro never calls an evaluator.)
2333 * EVAL evaluates an expression that is expected to have its symbols already
2334 * memoized. Expressions that are not of the form '(<form> <form> ...)' are
2335 * evaluated inline without calling an evaluator.
2337 * EVALCAR evaluates the car of an expression 'X:(Y:<form> <form> ...)',
2338 * potentially replacing a symbol at the position Y:<form> by its memoized
2339 * variable. If Y:<form> is not of the form '(<form> <form> ...)', the
2340 * evaluation is performed inline without calling an evaluator.
2342 * The following macros should be used in code which is read once
2343 * (where the choice of evaluator is dynamic):
2345 * SCM_XEVAL corresponds to EVAL, but uses ceval *or* deval depending on the
2348 * SCM_XEVALCAR corresponds to EVALCAR, but uses ceval *or* deval depending
2349 * on the debugging mode.
2351 * The main motivation for keeping this plethora is efficiency
2352 * together with maintainability (=> locality of code).
2355 static SCM
ceval (SCM x
, SCM env
);
2356 static SCM
deval (SCM x
, SCM env
);
2360 #define SCM_EVALIM2(x) \
2361 ((SCM_EQ_P ((x), SCM_EOL) \
2362 ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \
2366 #define SCM_EVALIM(x, env) (SCM_ILOCP (x) \
2367 ? *scm_ilookup ((x), (env)) \
2370 #define SCM_XEVAL(x, env) \
2373 : (SCM_VARIABLEP (x) \
2374 ? SCM_VARIABLE_REF (x) \
2376 ? (scm_debug_mode_p \
2377 ? deval ((x), (env)) \
2378 : ceval ((x), (env))) \
2381 #define SCM_XEVALCAR(x, env) \
2382 (SCM_IMP (SCM_CAR (x)) \
2383 ? SCM_EVALIM (SCM_CAR (x), (env)) \
2384 : (SCM_VARIABLEP (SCM_CAR (x)) \
2385 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2386 : (SCM_CONSP (SCM_CAR (x)) \
2387 ? (scm_debug_mode_p \
2388 ? deval (SCM_CAR (x), (env)) \
2389 : ceval (SCM_CAR (x), (env))) \
2390 : (!SCM_SYMBOLP (SCM_CAR (x)) \
2392 : *scm_lookupcar ((x), (env), 1)))))
2394 #define EVAL(x, env) \
2396 ? SCM_EVALIM ((x), (env)) \
2397 : (SCM_VARIABLEP (x) \
2398 ? SCM_VARIABLE_REF (x) \
2400 ? CEVAL ((x), (env)) \
2403 #define EVALCAR(x, env) \
2404 (SCM_IMP (SCM_CAR (x)) \
2405 ? SCM_EVALIM (SCM_CAR (x), (env)) \
2406 : (SCM_VARIABLEP (SCM_CAR (x)) \
2407 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2408 : (SCM_CONSP (SCM_CAR (x)) \
2409 ? CEVAL (SCM_CAR (x), (env)) \
2410 : (!SCM_SYMBOLP (SCM_CAR (x)) \
2412 : *scm_lookupcar ((x), (env), 1)))))
2414 SCM_REC_MUTEX (source_mutex
);
2417 /* Lookup a given local variable in an environment. The local variable is
2418 * given as an iloc, that is a triple <frame, binding, last?>, where frame
2419 * indicates the relative number of the environment frame (counting upwards
2420 * from the innermost environment frame), binding indicates the number of the
2421 * binding within the frame, and last? (which is extracted from the iloc using
2422 * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
2423 * very end of the improper list of bindings. */
2425 scm_ilookup (SCM iloc
, SCM env
)
2427 unsigned int frame_nr
= SCM_IFRAME (iloc
);
2428 unsigned int binding_nr
= SCM_IDIST (iloc
);
2432 for (; 0 != frame_nr
; --frame_nr
)
2433 frames
= SCM_CDR (frames
);
2435 bindings
= SCM_CAR (frames
);
2436 for (; 0 != binding_nr
; --binding_nr
)
2437 bindings
= SCM_CDR (bindings
);
2439 if (SCM_ICDRP (iloc
))
2440 return SCM_CDRLOC (bindings
);
2441 return SCM_CARLOC (SCM_CDR (bindings
));
2445 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
2447 static void error_unbound_variable (SCM symbol
) SCM_NORETURN
;
2449 error_unbound_variable (SCM symbol
)
2451 scm_error (scm_unbound_variable_key
, NULL
,
2452 "Unbound variable: ~S",
2453 scm_list_1 (symbol
), SCM_BOOL_F
);
2457 /* The Lookup Car Race
2460 Memoization of variables and special forms is done while executing
2461 the code for the first time. As long as there is only one thread
2462 everything is fine, but as soon as two threads execute the same
2463 code concurrently `for the first time' they can come into conflict.
2465 This memoization includes rewriting variable references into more
2466 efficient forms and expanding macros. Furthermore, macro expansion
2467 includes `compiling' special forms like `let', `cond', etc. into
2468 tree-code instructions.
2470 There shouldn't normally be a problem with memoizing local and
2471 global variable references (into ilocs and variables), because all
2472 threads will mutate the code in *exactly* the same way and (if I
2473 read the C code correctly) it is not possible to observe a half-way
2474 mutated cons cell. The lookup procedure can handle this
2475 transparently without any critical sections.
2477 It is different with macro expansion, because macro expansion
2478 happens outside of the lookup procedure and can't be
2479 undone. Therefore the lookup procedure can't cope with it. It has
2480 to indicate failure when it detects a lost race and hope that the
2481 caller can handle it. Luckily, it turns out that this is the case.
2483 An example to illustrate this: Suppose that the following form will
2484 be memoized concurrently by two threads
2488 Let's first examine the lookup of X in the body. The first thread
2489 decides that it has to find the symbol "x" in the environment and
2490 starts to scan it. Then the other thread takes over and actually
2491 overtakes the first. It looks up "x" and substitutes an
2492 appropriate iloc for it. Now the first thread continues and
2493 completes its lookup. It comes to exactly the same conclusions as
2494 the second one and could - without much ado - just overwrite the
2495 iloc with the same iloc.
2497 But let's see what will happen when the race occurs while looking
2498 up the symbol "let" at the start of the form. It could happen that
2499 the second thread interrupts the lookup of the first thread and not
2500 only substitutes a variable for it but goes right ahead and
2501 replaces it with the compiled form (#@let* (x 12) x). Now, when
2502 the first thread completes its lookup, it would replace the #@let*
2503 with a variable containing the "let" binding, effectively reverting
2504 the form to (let (x 12) x). This is wrong. It has to detect that
2505 it has lost the race and the evaluator has to reconsider the
2506 changed form completely.
2508 This race condition could be resolved with some kind of traffic
2509 light (like mutexes) around scm_lookupcar, but I think that it is
2510 best to avoid them in this case. They would serialize memoization
2511 completely and because lookup involves calling arbitrary Scheme
2512 code (via the lookup-thunk), threads could be blocked for an
2513 arbitrary amount of time or even deadlock. But with the current
2514 solution a lot of unnecessary work is potentially done. */
2516 /* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
2517 return NULL to indicate a failed lookup due to some race conditions
2518 between threads. This only happens when VLOC is the first cell of
2519 a special form that will eventually be memoized (like `let', etc.)
2520 In that case the whole lookup is bogus and the caller has to
2521 reconsider the complete special form.
2523 SCM_LOOKUPCAR is still there, of course. It just calls
2524 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
2525 should only be called when it is known that VLOC is not the first
2526 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
2527 for NULL. I think I've found the only places where this
2531 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
2534 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
2535 register SCM iloc
= SCM_ILOC00
;
2536 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
2538 if (!SCM_CONSP (SCM_CAR (env
)))
2540 al
= SCM_CARLOC (env
);
2541 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
2543 if (!SCM_CONSP (fl
))
2545 if (SCM_EQ_P (fl
, var
))
2547 if (! SCM_EQ_P (SCM_CAR (vloc
), var
))
2549 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
2550 return SCM_CDRLOC (*al
);
2555 al
= SCM_CDRLOC (*al
);
2556 if (SCM_EQ_P (SCM_CAR (fl
), var
))
2558 if (SCM_UNBNDP (SCM_CAR (*al
)))
2563 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
2565 SCM_SETCAR (vloc
, iloc
);
2566 return SCM_CARLOC (*al
);
2568 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
2570 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
2573 SCM top_thunk
, real_var
;
2576 top_thunk
= SCM_CAR (env
); /* env now refers to a
2577 top level env thunk */
2578 env
= SCM_CDR (env
);
2581 top_thunk
= SCM_BOOL_F
;
2582 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
2583 if (SCM_FALSEP (real_var
))
2586 if (!SCM_NULLP (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
2591 if (SCM_NULLP (env
))
2592 error_unbound_variable (var
);
2594 scm_misc_error (NULL
, "Damaged environment: ~S",
2599 /* A variable could not be found, but we shall
2600 not throw an error. */
2601 static SCM undef_object
= SCM_UNDEFINED
;
2602 return &undef_object
;
2606 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
2608 /* Some other thread has changed the very cell we are working
2609 on. In effect, it must have done our job or messed it up
2612 var
= SCM_CAR (vloc
);
2613 if (SCM_VARIABLEP (var
))
2614 return SCM_VARIABLE_LOC (var
);
2615 if (SCM_ILOCP (var
))
2616 return scm_ilookup (var
, genv
);
2617 /* We can't cope with anything else than variables and ilocs. When
2618 a special form has been memoized (i.e. `let' into `#@let') we
2619 return NULL and expect the calling function to do the right
2620 thing. For the evaluator, this means going back and redoing
2621 the dispatch on the car of the form. */
2625 SCM_SETCAR (vloc
, real_var
);
2626 return SCM_VARIABLE_LOC (real_var
);
2631 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
2633 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
2640 /* During execution, look up a symbol in the top level of the given local
2641 * environment and return the corresponding variable object. If no binding
2642 * for the symbol can be found, an 'Unbound variable' error is signalled. */
2644 lazy_memoize_variable (const SCM symbol
, const SCM environment
)
2646 const SCM top_level
= scm_env_top_level (environment
);
2647 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
2649 if (SCM_FALSEP (variable
))
2650 error_unbound_variable (symbol
);
2657 scm_eval_car (SCM pair
, SCM env
)
2659 return SCM_XEVALCAR (pair
, env
);
2664 scm_eval_args (SCM l
, SCM env
, SCM proc
)
2666 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
2667 while (SCM_CONSP (l
))
2669 res
= EVALCAR (l
, env
);
2671 *lloc
= scm_list_1 (res
);
2672 lloc
= SCM_CDRLOC (*lloc
);
2676 scm_wrong_num_args (proc
);
2682 scm_eval_body (SCM code
, SCM env
)
2687 next
= SCM_CDR (code
);
2688 while (!SCM_NULLP (next
))
2690 if (SCM_IMP (SCM_CAR (code
)))
2692 if (SCM_ISYMP (SCM_CAR (code
)))
2694 scm_rec_mutex_lock (&source_mutex
);
2695 /* check for race condition */
2696 if (SCM_ISYMP (SCM_CAR (code
)))
2697 m_expand_body (code
, env
);
2698 scm_rec_mutex_unlock (&source_mutex
);
2703 SCM_XEVAL (SCM_CAR (code
), env
);
2705 next
= SCM_CDR (code
);
2707 return SCM_XEVALCAR (code
, env
);
2713 /* SECTION: This code is specific for the debugging support. One
2714 * branch is read when DEVAL isn't defined, the other when DEVAL is
2720 #define SCM_APPLY scm_apply
2721 #define PREP_APPLY(proc, args)
2723 #define RETURN(x) do { return x; } while (0)
2724 #ifdef STACK_CHECKING
2725 #ifndef NO_CEVAL_STACK_CHECKING
2726 #define EVAL_STACK_CHECKING
2733 #define CEVAL deval /* Substitute all uses of ceval */
2736 #define SCM_APPLY scm_dapply
2739 #define PREP_APPLY(p, l) \
2740 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
2743 #define ENTER_APPLY \
2745 SCM_SET_ARGSREADY (debug);\
2746 if (scm_check_apply_p && SCM_TRAPS_P)\
2747 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
2749 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
2750 SCM_SET_TRACED_FRAME (debug); \
2752 if (SCM_CHEAPTRAPS_P)\
2754 tmp = scm_make_debugobj (&debug);\
2755 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
2760 tmp = scm_make_continuation (&first);\
2762 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
2769 #define RETURN(e) do { proc = (e); goto exit; } while (0)
2771 #ifdef STACK_CHECKING
2772 #ifndef EVAL_STACK_CHECKING
2773 #define EVAL_STACK_CHECKING
2778 /* scm_last_debug_frame contains a pointer to the last debugging information
2779 * stack frame. It is accessed very often from the debugging evaluator, so it
2780 * should probably not be indirectly addressed. Better to save and restore it
2781 * from the current root at any stack swaps.
2784 /* scm_debug_eframe_size is the number of slots available for pseudo
2785 * stack frames at each real stack frame.
2788 long scm_debug_eframe_size
;
2790 int scm_debug_mode_p
;
2791 int scm_check_entry_p
;
2792 int scm_check_apply_p
;
2793 int scm_check_exit_p
;
2795 long scm_eval_stack
;
2797 scm_t_option scm_eval_opts
[] = {
2798 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
2801 scm_t_option scm_debug_opts
[] = {
2802 { SCM_OPTION_BOOLEAN
, "cheap", 1,
2803 "*Flyweight representation of the stack at traps." },
2804 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
2805 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
2806 { SCM_OPTION_BOOLEAN
, "procnames", 1,
2807 "Record procedure names at definition." },
2808 { SCM_OPTION_BOOLEAN
, "backwards", 0,
2809 "Display backtrace in anti-chronological order." },
2810 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
2811 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
2812 { SCM_OPTION_INTEGER
, "frames", 3,
2813 "Maximum number of tail-recursive frames in backtrace." },
2814 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
2815 "Maximal number of stored backtrace frames." },
2816 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
2817 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
2818 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
2819 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
2820 { SCM_OPTION_SCM
, "show-file-name", (unsigned long)SCM_BOOL_T
, "Show file names and line numbers in backtraces when not `#f'. A value of `base' displays only base names, while `#t' displays full names."}
2823 scm_t_option scm_evaluator_trap_table
[] = {
2824 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
2825 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
2826 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
2827 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
2828 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
2829 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
2830 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
2833 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
2835 "Option interface for the evaluation options. Instead of using\n"
2836 "this procedure directly, use the procedures @code{eval-enable},\n"
2837 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
2838 #define FUNC_NAME s_scm_eval_options_interface
2842 ans
= scm_options (setting
,
2846 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
2853 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
2855 "Option interface for the evaluator trap options.")
2856 #define FUNC_NAME s_scm_evaluator_traps
2860 ans
= scm_options (setting
,
2861 scm_evaluator_trap_table
,
2862 SCM_N_EVALUATOR_TRAPS
,
2864 SCM_RESET_DEBUG_MODE
;
2872 deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
2874 SCM
*results
= lloc
;
2875 while (SCM_CONSP (l
))
2877 const SCM res
= EVALCAR (l
, env
);
2879 *lloc
= scm_list_1 (res
);
2880 lloc
= SCM_CDRLOC (*lloc
);
2884 scm_wrong_num_args (proc
);
2891 /* SECTION: This code is compiled twice.
2895 /* Update the toplevel environment frame ENV so that it refers to the
2896 * current module. */
2897 #define UPDATE_TOPLEVEL_ENV(env) \
2899 SCM p = scm_current_module_lookup_closure (); \
2900 if (p != SCM_CAR (env)) \
2901 env = scm_top_level_env (p); \
2905 #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
2906 ASSERT_SYNTAX (!SCM_EQ_P ((x), SCM_EOL), s_empty_combination, x)
2909 /* This is the evaluator. Like any real monster, it has three heads:
2911 * ceval is the non-debugging evaluator, deval is the debugging version. Both
2912 * are implemented using a common code base, using the following mechanism:
2913 * CEVAL is a macro, which is either defined to ceval or deval. Thus, there
2914 * is no function CEVAL, but the code for CEVAL actually compiles to either
2915 * ceval or deval. When CEVAL is defined to ceval, it is known that the macro
2916 * DEVAL is not defined. When CEVAL is defined to deval, then the macro DEVAL
2917 * is known to be defined. Thus, in CEVAL parts for the debugging evaluator
2918 * are enclosed within #ifdef DEVAL ... #endif.
2920 * All three (ceval, deval and their common implementation CEVAL) take two
2921 * input parameters, x and env: x is a single expression to be evalutated.
2922 * env is the environment in which bindings are searched.
2924 * x is known to be a pair. Since x is a single expression, it is necessarily
2925 * in a tail position. If x is just a call to another function like in the
2926 * expression (foo exp1 exp2 ...), the realization of that call therefore
2927 * _must_not_ increase stack usage (the evaluation of exp1, exp2 etc.,
2928 * however, may do so). This is realized by making extensive use of 'goto'
2929 * statements within the evaluator: The gotos replace recursive calls to
2930 * CEVAL, thus re-using the same stack frame that CEVAL was already using.
2931 * If, however, x represents some form that requires to evaluate a sequence of
2932 * expressions like (begin exp1 exp2 ...), then recursive calls to CEVAL are
2933 * performed for all but the last expression of that sequence. */
2936 CEVAL (SCM x
, SCM env
)
2940 scm_t_debug_frame debug
;
2941 scm_t_debug_info
*debug_info_end
;
2942 debug
.prev
= scm_last_debug_frame
;
2945 * The debug.vect contains twice as much scm_t_debug_info frames as the
2946 * user has specified with (debug-set! frames <n>).
2948 * Even frames are eval frames, odd frames are apply frames.
2950 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
2951 * sizeof (scm_t_debug_info
));
2952 debug
.info
= debug
.vect
;
2953 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
2954 scm_last_debug_frame
= &debug
;
2956 #ifdef EVAL_STACK_CHECKING
2957 if (scm_stack_checking_enabled_p
&& SCM_STACK_OVERFLOW_P (&proc
))
2960 debug
.info
->e
.exp
= x
;
2961 debug
.info
->e
.env
= env
;
2963 scm_report_stack_overflow ();
2973 SCM_CLEAR_ARGSREADY (debug
);
2974 if (SCM_OVERFLOWP (debug
))
2977 * In theory, this should be the only place where it is necessary to
2978 * check for space in debug.vect since both eval frames and
2979 * available space are even.
2981 * For this to be the case, however, it is necessary that primitive
2982 * special forms which jump back to `loop', `begin' or some similar
2983 * label call PREP_APPLY.
2985 else if (++debug
.info
>= debug_info_end
)
2987 SCM_SET_OVERFLOW (debug
);
2992 debug
.info
->e
.exp
= x
;
2993 debug
.info
->e
.env
= env
;
2994 if (scm_check_entry_p
&& SCM_TRAPS_P
)
2996 if (SCM_ENTER_FRAME_P
2997 || (SCM_BREAKPOINTS_P
&& scm_c_source_property_breakpoint_p (x
)))
3000 SCM tail
= SCM_BOOL (SCM_TAILRECP (debug
));
3001 SCM_SET_TAILREC (debug
);
3002 if (SCM_CHEAPTRAPS_P
)
3003 stackrep
= scm_make_debugobj (&debug
);
3007 SCM val
= scm_make_continuation (&first
);
3017 /* This gives the possibility for the debugger to
3018 modify the source expression before evaluation. */
3023 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
3024 scm_sym_enter_frame
,
3027 scm_unmemocopy (x
, env
));
3034 if (SCM_ISYMP (SCM_CAR (x
)))
3036 switch (ISYMNUM (SCM_CAR (x
)))
3038 case (ISYMNUM (SCM_IM_AND
)):
3040 while (!SCM_NULLP (SCM_CDR (x
)))
3042 SCM test_result
= EVALCAR (x
, env
);
3043 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
3044 RETURN (SCM_BOOL_F
);
3048 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3051 case (ISYMNUM (SCM_IM_BEGIN
)):
3054 RETURN (SCM_UNSPECIFIED
);
3056 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3059 /* If we are on toplevel with a lookup closure, we need to sync
3060 with the current module. */
3061 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
3063 UPDATE_TOPLEVEL_ENV (env
);
3064 while (!SCM_NULLP (SCM_CDR (x
)))
3067 UPDATE_TOPLEVEL_ENV (env
);
3073 goto nontoplevel_begin
;
3076 while (!SCM_NULLP (SCM_CDR (x
)))
3078 const SCM form
= SCM_CAR (x
);
3081 if (SCM_ISYMP (form
))
3083 scm_rec_mutex_lock (&source_mutex
);
3084 /* check for race condition */
3085 if (SCM_ISYMP (SCM_CAR (x
)))
3086 m_expand_body (x
, env
);
3087 scm_rec_mutex_unlock (&source_mutex
);
3088 goto nontoplevel_begin
;
3091 SCM_VALIDATE_NON_EMPTY_COMBINATION (form
);
3094 (void) EVAL (form
, env
);
3100 /* scm_eval last form in list */
3101 const SCM last_form
= SCM_CAR (x
);
3103 if (SCM_CONSP (last_form
))
3105 /* This is by far the most frequent case. */
3107 goto loop
; /* tail recurse */
3109 else if (SCM_IMP (last_form
))
3110 RETURN (SCM_EVALIM (last_form
, env
));
3111 else if (SCM_VARIABLEP (last_form
))
3112 RETURN (SCM_VARIABLE_REF (last_form
));
3113 else if (SCM_SYMBOLP (last_form
))
3114 RETURN (*scm_lookupcar (x
, env
, 1));
3120 case (ISYMNUM (SCM_IM_CASE
)):
3123 const SCM key
= EVALCAR (x
, env
);
3125 while (!SCM_NULLP (x
))
3127 const SCM clause
= SCM_CAR (x
);
3128 SCM labels
= SCM_CAR (clause
);
3129 if (SCM_EQ_P (labels
, SCM_IM_ELSE
))
3131 x
= SCM_CDR (clause
);
3132 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3135 while (!SCM_NULLP (labels
))
3137 const SCM label
= SCM_CAR (labels
);
3138 if (SCM_EQ_P (label
, key
)
3139 || !SCM_FALSEP (scm_eqv_p (label
, key
)))
3141 x
= SCM_CDR (clause
);
3142 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3145 labels
= SCM_CDR (labels
);
3150 RETURN (SCM_UNSPECIFIED
);
3153 case (ISYMNUM (SCM_IM_COND
)):
3155 while (!SCM_NULLP (x
))
3157 const SCM clause
= SCM_CAR (x
);
3158 if (SCM_EQ_P (SCM_CAR (clause
), SCM_IM_ELSE
))
3160 x
= SCM_CDR (clause
);
3161 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3166 arg1
= EVALCAR (clause
, env
);
3167 if (!SCM_FALSEP (arg1
) && !SCM_NILP (arg1
))
3169 x
= SCM_CDR (clause
);
3172 else if (!SCM_EQ_P (SCM_CAR (x
), SCM_IM_ARROW
))
3174 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3180 proc
= EVALCAR (proc
, env
);
3181 PREP_APPLY (proc
, scm_list_1 (arg1
));
3189 RETURN (SCM_UNSPECIFIED
);
3192 case (ISYMNUM (SCM_IM_DO
)):
3195 /* Compute the initialization values and the initial environment. */
3196 SCM init_forms
= SCM_CAR (x
);
3197 SCM init_values
= SCM_EOL
;
3198 while (!SCM_NULLP (init_forms
))
3200 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3201 init_forms
= SCM_CDR (init_forms
);
3204 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
3208 SCM test_form
= SCM_CAR (x
);
3209 SCM body_forms
= SCM_CADR (x
);
3210 SCM step_forms
= SCM_CDDR (x
);
3212 SCM test_result
= EVALCAR (test_form
, env
);
3214 while (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
3217 /* Evaluate body forms. */
3219 for (temp_forms
= body_forms
;
3220 !SCM_NULLP (temp_forms
);
3221 temp_forms
= SCM_CDR (temp_forms
))
3223 SCM form
= SCM_CAR (temp_forms
);
3224 /* Dirk:FIXME: We only need to eval forms that may have
3225 * a side effect here. This is only true for forms that
3226 * start with a pair. All others are just constants.
3227 * Since with the current memoizer 'form' may hold a
3228 * constant, we call EVAL here to handle the constant
3229 * cases. In the long run it would make sense to have
3230 * the macro transformer of 'do' eliminate all forms
3231 * that have no sideeffect. Then instead of EVAL we
3232 * could call CEVAL directly here. */
3233 (void) EVAL (form
, env
);
3238 /* Evaluate the step expressions. */
3240 SCM step_values
= SCM_EOL
;
3241 for (temp_forms
= step_forms
;
3242 !SCM_NULLP (temp_forms
);
3243 temp_forms
= SCM_CDR (temp_forms
))
3245 const SCM value
= EVALCAR (temp_forms
, env
);
3246 step_values
= scm_cons (value
, step_values
);
3248 env
= SCM_EXTEND_ENV (SCM_CAAR (env
),
3253 test_result
= EVALCAR (test_form
, env
);
3258 RETURN (SCM_UNSPECIFIED
);
3259 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3260 goto nontoplevel_begin
;
3263 case (ISYMNUM (SCM_IM_IF
)):
3266 SCM test_result
= EVALCAR (x
, env
);
3267 x
= SCM_CDR (x
); /* then expression */
3268 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
3270 x
= SCM_CDR (x
); /* else expression */
3272 RETURN (SCM_UNSPECIFIED
);
3275 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3279 case (ISYMNUM (SCM_IM_LET
)):
3282 SCM init_forms
= SCM_CADR (x
);
3283 SCM init_values
= SCM_EOL
;
3286 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3287 init_forms
= SCM_CDR (init_forms
);
3289 while (!SCM_NULLP (init_forms
));
3290 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
3293 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3294 goto nontoplevel_begin
;
3297 case (ISYMNUM (SCM_IM_LETREC
)):
3299 env
= SCM_EXTEND_ENV (SCM_CAR (x
), undefineds
, env
);
3302 SCM init_forms
= SCM_CAR (x
);
3303 SCM init_values
= SCM_EOL
;
3306 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3307 init_forms
= SCM_CDR (init_forms
);
3309 while (!SCM_NULLP (init_forms
));
3310 SCM_SETCDR (SCM_CAR (env
), init_values
);
3313 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3314 goto nontoplevel_begin
;
3317 case (ISYMNUM (SCM_IM_LETSTAR
)):
3320 SCM bindings
= SCM_CAR (x
);
3321 if (SCM_NULLP (bindings
))
3322 env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
3327 SCM name
= SCM_CAR (bindings
);
3328 SCM init
= SCM_CDR (bindings
);
3329 env
= SCM_EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
3330 bindings
= SCM_CDR (init
);
3332 while (!SCM_NULLP (bindings
));
3336 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3337 goto nontoplevel_begin
;
3340 case (ISYMNUM (SCM_IM_OR
)):
3342 while (!SCM_NULLP (SCM_CDR (x
)))
3344 SCM val
= EVALCAR (x
, env
);
3345 if (!SCM_FALSEP (val
) && !SCM_NILP (val
))
3350 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3354 case (ISYMNUM (SCM_IM_LAMBDA
)):
3355 RETURN (scm_closure (SCM_CDR (x
), env
));
3358 case (ISYMNUM (SCM_IM_QUOTE
)):
3359 RETURN (SCM_CDR (x
));
3362 case (ISYMNUM (SCM_IM_SET_X
)):
3366 SCM variable
= SCM_CAR (x
);
3367 if (SCM_ILOCP (variable
))
3368 location
= scm_ilookup (variable
, env
);
3369 else if (SCM_VARIABLEP (variable
))
3370 location
= SCM_VARIABLE_LOC (variable
);
3373 /* (SCM_SYMBOLP (variable)) is known to be true */
3374 variable
= lazy_memoize_variable (variable
, env
);
3375 SCM_SETCAR (x
, variable
);
3376 location
= SCM_VARIABLE_LOC (variable
);
3379 *location
= EVALCAR (x
, env
);
3381 RETURN (SCM_UNSPECIFIED
);
3384 case (ISYMNUM (SCM_IM_APPLY
)):
3385 /* Evaluate the procedure to be applied. */
3387 proc
= EVALCAR (x
, env
);
3388 PREP_APPLY (proc
, SCM_EOL
);
3390 /* Evaluate the argument holding the list of arguments */
3392 arg1
= EVALCAR (x
, env
);
3395 /* Go here to tail-apply a procedure. PROC is the procedure and
3396 * ARG1 is the list of arguments. PREP_APPLY must have been called
3397 * before jumping to apply_proc. */
3398 if (SCM_CLOSUREP (proc
))
3400 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3402 debug
.info
->a
.args
= arg1
;
3404 if (scm_badargsp (formals
, arg1
))
3405 scm_wrong_num_args (proc
);
3407 /* Copy argument list */
3408 if (SCM_NULL_OR_NIL_P (arg1
))
3409 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
3412 SCM args
= scm_list_1 (SCM_CAR (arg1
));
3414 arg1
= SCM_CDR (arg1
);
3415 while (!SCM_NULL_OR_NIL_P (arg1
))
3417 SCM new_tail
= scm_list_1 (SCM_CAR (arg1
));
3418 SCM_SETCDR (tail
, new_tail
);
3420 arg1
= SCM_CDR (arg1
);
3422 env
= SCM_EXTEND_ENV (formals
, args
, SCM_ENV (proc
));
3425 x
= SCM_CLOSURE_BODY (proc
);
3426 goto nontoplevel_begin
;
3431 RETURN (SCM_APPLY (proc
, arg1
, SCM_EOL
));
3435 case (ISYMNUM (SCM_IM_CONT
)):
3438 SCM val
= scm_make_continuation (&first
);
3446 proc
= EVALCAR (proc
, env
);
3447 PREP_APPLY (proc
, scm_list_1 (arg1
));
3454 case (ISYMNUM (SCM_IM_DELAY
)):
3455 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
3458 case (ISYMNUM (SCM_IM_FUTURE
)):
3459 RETURN (scm_i_make_future (scm_closure (SCM_CDR (x
), env
)));
3462 /* PLACEHOLDER for case (ISYMNUM (SCM_IM_DISPATCH)): The following
3463 code (type_dispatch) is intended to be the tail of the case
3464 clause for the internal macro SCM_IM_DISPATCH. Please don't
3465 remove it from this location without discussing it with Mikael
3466 <djurfeldt@nada.kth.se> */
3468 /* The type dispatch code is duplicated below
3469 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
3470 * cuts down execution time for type dispatch to 50%. */
3471 type_dispatch
: /* inputs: x, arg1 */
3472 /* Type dispatch means to determine from the types of the function
3473 * arguments (i. e. the 'signature' of the call), which method from
3474 * a generic function is to be called. This process of selecting
3475 * the right method takes some time. To speed it up, guile uses
3476 * caching: Together with the macro call to dispatch the signatures
3477 * of some previous calls to that generic function from the same
3478 * place are stored (in the code!) in a cache that we call the
3479 * 'method cache'. This is done since it is likely, that
3480 * consecutive calls to dispatch from that position in the code will
3481 * have the same signature. Thus, the type dispatch works as
3482 * follows: First, determine a hash value from the signature of the
3483 * actual arguments. Second, use this hash value as an index to
3484 * find that same signature in the method cache stored at this
3485 * position in the code. If found, you have also found the
3486 * corresponding method that belongs to that signature. If the
3487 * signature is not found in the method cache, you have to perform a
3488 * full search over all signatures stored with the generic
3491 unsigned long int specializers
;
3492 unsigned long int hash_value
;
3493 unsigned long int cache_end_pos
;
3494 unsigned long int mask
;
3498 SCM z
= SCM_CDDR (x
);
3499 SCM tmp
= SCM_CADR (z
);
3500 specializers
= SCM_INUM (SCM_CAR (z
));
3502 /* Compute a hash value for searching the method cache. There
3503 * are two variants for computing the hash value, a (rather)
3504 * complicated one, and a simple one. For the complicated one
3505 * explained below, tmp holds a number that is used in the
3507 if (SCM_INUMP (tmp
))
3509 /* Use the signature of the actual arguments to determine
3510 * the hash value. This is done as follows: Each class has
3511 * an array of random numbers, that are determined when the
3512 * class is created. The integer 'hashset' is an index into
3513 * that array of random numbers. Now, from all classes that
3514 * are part of the signature of the actual arguments, the
3515 * random numbers at index 'hashset' are taken and summed
3516 * up, giving the hash value. The value of 'hashset' is
3517 * stored at the call to dispatch. This allows to have
3518 * different 'formulas' for calculating the hash value at
3519 * different places where dispatch is called. This allows
3520 * to optimize the hash formula at every individual place
3521 * where dispatch is called, such that hopefully the hash
3522 * value that is computed will directly point to the right
3523 * method in the method cache. */
3524 unsigned long int hashset
= SCM_INUM (tmp
);
3525 unsigned long int counter
= specializers
+ 1;
3528 while (!SCM_NULLP (tmp_arg
) && counter
!= 0)
3530 SCM
class = scm_class_of (SCM_CAR (tmp_arg
));
3531 hash_value
+= SCM_INSTANCE_HASH (class, hashset
);
3532 tmp_arg
= SCM_CDR (tmp_arg
);
3536 method_cache
= SCM_CADR (z
);
3537 mask
= SCM_INUM (SCM_CAR (z
));
3539 cache_end_pos
= hash_value
;
3543 /* This method of determining the hash value is much
3544 * simpler: Set the hash value to zero and just perform a
3545 * linear search through the method cache. */
3547 mask
= (unsigned long int) ((long) -1);
3549 cache_end_pos
= SCM_VECTOR_LENGTH (method_cache
);
3554 /* Search the method cache for a method with a matching
3555 * signature. Start the search at position 'hash_value'. The
3556 * hashing implementation uses linear probing for conflict
3557 * resolution, that is, if the signature in question is not
3558 * found at the starting index in the hash table, the next table
3559 * entry is tried, and so on, until in the worst case the whole
3560 * cache has been searched, but still the signature has not been
3565 SCM args
= arg1
; /* list of arguments */
3566 z
= SCM_VELTS (method_cache
)[hash_value
];
3567 while (!SCM_NULLP (args
))
3569 /* More arguments than specifiers => CLASS != ENV */
3570 SCM class_of_arg
= scm_class_of (SCM_CAR (args
));
3571 if (!SCM_EQ_P (class_of_arg
, SCM_CAR (z
)))
3573 args
= SCM_CDR (args
);
3576 /* Fewer arguments than specifiers => CAR != ENV */
3577 if (SCM_NULLP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
)))
3580 hash_value
= (hash_value
+ 1) & mask
;
3581 } while (hash_value
!= cache_end_pos
);
3583 /* No appropriate method was found in the cache. */
3584 z
= scm_memoize_method (x
, arg1
);
3586 apply_cmethod
: /* inputs: z, arg1 */
3588 SCM formals
= SCM_CMETHOD_FORMALS (z
);
3589 env
= SCM_EXTEND_ENV (formals
, arg1
, SCM_CMETHOD_ENV (z
));
3590 x
= SCM_CMETHOD_BODY (z
);
3591 goto nontoplevel_begin
;
3597 case (ISYMNUM (SCM_IM_SLOT_REF
)):
3600 SCM instance
= EVALCAR (x
, env
);
3601 unsigned long int slot
= SCM_INUM (SCM_CDR (x
));
3602 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance
) [slot
]));
3606 case (ISYMNUM (SCM_IM_SLOT_SET_X
)):
3609 SCM instance
= EVALCAR (x
, env
);
3610 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
3611 SCM value
= EVALCAR (SCM_CDDR (x
), env
);
3612 SCM_STRUCT_DATA (instance
) [slot
] = SCM_UNPACK (value
);
3613 RETURN (SCM_UNSPECIFIED
);
3617 #if SCM_ENABLE_ELISP
3619 case (ISYMNUM (SCM_IM_NIL_COND
)):
3621 SCM test_form
= SCM_CDR (x
);
3622 x
= SCM_CDR (test_form
);
3623 while (!SCM_NULL_OR_NIL_P (x
))
3625 SCM test_result
= EVALCAR (test_form
, env
);
3626 if (!(SCM_FALSEP (test_result
)
3627 || SCM_NULL_OR_NIL_P (test_result
)))
3629 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
3630 RETURN (test_result
);
3631 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3636 test_form
= SCM_CDR (x
);
3637 x
= SCM_CDR (test_form
);
3641 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3645 #endif /* SCM_ENABLE_ELISP */
3647 case (ISYMNUM (SCM_IM_BIND
)):
3649 SCM vars
, exps
, vals
;
3652 vars
= SCM_CAAR (x
);
3653 exps
= SCM_CDAR (x
);
3655 while (!SCM_NULLP (exps
))
3657 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
3658 exps
= SCM_CDR (exps
);
3661 scm_swap_bindings (vars
, vals
);
3662 scm_dynwinds
= scm_acons (vars
, vals
, scm_dynwinds
);
3664 /* Ignore all but the last evaluation result. */
3665 for (x
= SCM_CDR (x
); !SCM_NULLP (SCM_CDR (x
)); x
= SCM_CDR (x
))
3667 if (SCM_CONSP (SCM_CAR (x
)))
3668 CEVAL (SCM_CAR (x
), env
);
3670 proc
= EVALCAR (x
, env
);
3672 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
3673 scm_swap_bindings (vars
, vals
);
3679 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
3684 producer
= EVALCAR (x
, env
);
3686 proc
= EVALCAR (x
, env
); /* proc is the consumer. */
3687 arg1
= SCM_APPLY (producer
, SCM_EOL
, SCM_EOL
);
3688 if (SCM_VALUESP (arg1
))
3690 /* The list of arguments is not copied. Rather, it is assumed
3691 * that this has been done by the 'values' procedure. */
3692 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
3696 arg1
= scm_list_1 (arg1
);
3698 PREP_APPLY (proc
, arg1
);
3709 if (SCM_VARIABLEP (SCM_CAR (x
)))
3710 proc
= SCM_VARIABLE_REF (SCM_CAR (x
));
3711 else if (SCM_ILOCP (SCM_CAR (x
)))
3712 proc
= *scm_ilookup (SCM_CAR (x
), env
);
3713 else if (SCM_CONSP (SCM_CAR (x
)))
3714 proc
= CEVAL (SCM_CAR (x
), env
);
3715 else if (SCM_SYMBOLP (SCM_CAR (x
)))
3717 SCM orig_sym
= SCM_CAR (x
);
3719 SCM
*location
= scm_lookupcar1 (x
, env
, 1);
3720 if (location
== NULL
)
3722 /* we have lost the race, start again. */
3728 if (SCM_MACROP (proc
))
3730 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
3732 handle_a_macro
: /* inputs: x, env, proc */
3734 /* Set a flag during macro expansion so that macro
3735 application frames can be deleted from the backtrace. */
3736 SCM_SET_MACROEXP (debug
);
3738 arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
3739 scm_cons (env
, scm_listofnull
));
3741 SCM_CLEAR_MACROEXP (debug
);
3743 switch (SCM_MACRO_TYPE (proc
))
3747 if (!SCM_CONSP (arg1
))
3748 arg1
= scm_list_2 (SCM_IM_BEGIN
, arg1
);
3750 assert (!SCM_EQ_P (x
, SCM_CAR (arg1
))
3751 && !SCM_EQ_P (x
, SCM_CDR (arg1
)));
3754 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
3757 SCM_SETCAR (x
, SCM_CAR (arg1
));
3758 SCM_SETCDR (x
, SCM_CDR (arg1
));
3762 /* Prevent memoizing of debug info expression. */
3763 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
3768 SCM_SETCAR (x
, SCM_CAR (arg1
));
3769 SCM_SETCDR (x
, SCM_CDR (arg1
));
3771 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3773 #if SCM_ENABLE_DEPRECATED == 1
3778 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3792 if (SCM_MACROP (proc
))
3793 goto handle_a_macro
;
3797 /* When reaching this part of the code, the following is granted: Variable x
3798 * holds the first pair of an expression of the form (<function> arg ...).
3799 * Variable proc holds the object that resulted from the evaluation of
3800 * <function>. In the following, the arguments (if any) will be evaluated,
3801 * and proc will be applied to them. If proc does not really hold a
3802 * function object, this will be signalled as an error on the scheme
3803 * level. If the number of arguments does not match the number of arguments
3804 * that are allowed to be passed to proc, also an error on the scheme level
3805 * will be signalled. */
3806 PREP_APPLY (proc
, SCM_EOL
);
3807 if (SCM_NULLP (SCM_CDR (x
))) {
3810 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3811 switch (SCM_TYP7 (proc
))
3812 { /* no arguments given */
3813 case scm_tc7_subr_0
:
3814 RETURN (SCM_SUBRF (proc
) ());
3815 case scm_tc7_subr_1o
:
3816 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
3818 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
3819 case scm_tc7_rpsubr
:
3820 RETURN (SCM_BOOL_T
);
3822 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
3824 if (!SCM_SMOB_APPLICABLE_P (proc
))
3826 RETURN (SCM_SMOB_APPLY_0 (proc
));
3829 proc
= SCM_CCLO_SUBR (proc
);
3831 debug
.info
->a
.proc
= proc
;
3832 debug
.info
->a
.args
= scm_list_1 (arg1
);
3836 proc
= SCM_PROCEDURE (proc
);
3838 debug
.info
->a
.proc
= proc
;
3840 if (!SCM_CLOSUREP (proc
))
3843 case scm_tcs_closures
:
3845 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3846 if (SCM_CONSP (formals
))
3847 goto umwrongnumargs
;
3848 x
= SCM_CLOSURE_BODY (proc
);
3849 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
3850 goto nontoplevel_begin
;
3852 case scm_tcs_struct
:
3853 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3855 x
= SCM_ENTITY_PROCEDURE (proc
);
3859 else if (SCM_I_OPERATORP (proc
))
3862 proc
= (SCM_I_ENTITYP (proc
)
3863 ? SCM_ENTITY_PROCEDURE (proc
)
3864 : SCM_OPERATOR_PROCEDURE (proc
));
3866 debug
.info
->a
.proc
= proc
;
3867 debug
.info
->a
.args
= scm_list_1 (arg1
);
3873 case scm_tc7_subr_1
:
3874 case scm_tc7_subr_2
:
3875 case scm_tc7_subr_2o
:
3878 case scm_tc7_subr_3
:
3879 case scm_tc7_lsubr_2
:
3882 scm_wrong_num_args (proc
);
3885 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
3889 /* must handle macros by here */
3892 arg1
= EVALCAR (x
, env
);
3894 scm_wrong_num_args (proc
);
3896 debug
.info
->a
.args
= scm_list_1 (arg1
);
3904 evap1
: /* inputs: proc, arg1 */
3905 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3906 switch (SCM_TYP7 (proc
))
3907 { /* have one argument in arg1 */
3908 case scm_tc7_subr_2o
:
3909 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3910 case scm_tc7_subr_1
:
3911 case scm_tc7_subr_1o
:
3912 RETURN (SCM_SUBRF (proc
) (arg1
));
3914 if (SCM_INUMP (arg1
))
3916 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3918 else if (SCM_REALP (arg1
))
3920 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3922 else if (SCM_BIGP (arg1
))
3924 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3926 else if (SCM_FRACTIONP (arg1
))
3928 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
3930 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3931 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3934 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
3937 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
3938 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3939 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3944 case scm_tc7_rpsubr
:
3945 RETURN (SCM_BOOL_T
);
3947 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3950 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3952 RETURN (SCM_SUBRF (proc
) (scm_list_1 (arg1
)));
3955 if (!SCM_SMOB_APPLICABLE_P (proc
))
3957 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
3961 proc
= SCM_CCLO_SUBR (proc
);
3963 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
3964 debug
.info
->a
.proc
= proc
;
3968 proc
= SCM_PROCEDURE (proc
);
3970 debug
.info
->a
.proc
= proc
;
3972 if (!SCM_CLOSUREP (proc
))
3975 case scm_tcs_closures
:
3978 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3979 if (SCM_NULLP (formals
)
3980 || (SCM_CONSP (formals
) && SCM_CONSP (SCM_CDR (formals
))))
3981 goto umwrongnumargs
;
3982 x
= SCM_CLOSURE_BODY (proc
);
3984 env
= SCM_EXTEND_ENV (formals
,
3988 env
= SCM_EXTEND_ENV (formals
,
3992 goto nontoplevel_begin
;
3994 case scm_tcs_struct
:
3995 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3997 x
= SCM_ENTITY_PROCEDURE (proc
);
3999 arg1
= debug
.info
->a
.args
;
4001 arg1
= scm_list_1 (arg1
);
4005 else if (SCM_I_OPERATORP (proc
))
4009 proc
= (SCM_I_ENTITYP (proc
)
4010 ? SCM_ENTITY_PROCEDURE (proc
)
4011 : SCM_OPERATOR_PROCEDURE (proc
));
4013 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
4014 debug
.info
->a
.proc
= proc
;
4020 case scm_tc7_subr_2
:
4021 case scm_tc7_subr_0
:
4022 case scm_tc7_subr_3
:
4023 case scm_tc7_lsubr_2
:
4024 scm_wrong_num_args (proc
);
4030 arg2
= EVALCAR (x
, env
);
4032 scm_wrong_num_args (proc
);
4034 { /* have two or more arguments */
4036 debug
.info
->a
.args
= scm_list_2 (arg1
, arg2
);
4039 if (SCM_NULLP (x
)) {
4042 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4043 switch (SCM_TYP7 (proc
))
4044 { /* have two arguments */
4045 case scm_tc7_subr_2
:
4046 case scm_tc7_subr_2o
:
4047 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
4050 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4052 RETURN (SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
)));
4054 case scm_tc7_lsubr_2
:
4055 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
));
4056 case scm_tc7_rpsubr
:
4058 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
4060 if (!SCM_SMOB_APPLICABLE_P (proc
))
4062 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
));
4066 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
4067 scm_cons (proc
, debug
.info
->a
.args
),
4070 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
4071 scm_cons2 (proc
, arg1
,
4078 case scm_tcs_struct
:
4079 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4081 x
= SCM_ENTITY_PROCEDURE (proc
);
4083 arg1
= debug
.info
->a
.args
;
4085 arg1
= scm_list_2 (arg1
, arg2
);
4089 else if (SCM_I_OPERATORP (proc
))
4093 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
4094 ? SCM_ENTITY_PROCEDURE (proc
)
4095 : SCM_OPERATOR_PROCEDURE (proc
),
4096 scm_cons (proc
, debug
.info
->a
.args
),
4099 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
4100 ? SCM_ENTITY_PROCEDURE (proc
)
4101 : SCM_OPERATOR_PROCEDURE (proc
),
4102 scm_cons2 (proc
, arg1
,
4112 case scm_tc7_subr_0
:
4115 case scm_tc7_subr_1o
:
4116 case scm_tc7_subr_1
:
4117 case scm_tc7_subr_3
:
4118 scm_wrong_num_args (proc
);
4122 proc
= SCM_PROCEDURE (proc
);
4124 debug
.info
->a
.proc
= proc
;
4126 if (!SCM_CLOSUREP (proc
))
4129 case scm_tcs_closures
:
4132 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4133 if (SCM_NULLP (formals
)
4134 || (SCM_CONSP (formals
)
4135 && (SCM_NULLP (SCM_CDR (formals
))
4136 || (SCM_CONSP (SCM_CDR (formals
))
4137 && SCM_CONSP (SCM_CDDR (formals
))))))
4138 goto umwrongnumargs
;
4140 env
= SCM_EXTEND_ENV (formals
,
4144 env
= SCM_EXTEND_ENV (formals
,
4145 scm_list_2 (arg1
, arg2
),
4148 x
= SCM_CLOSURE_BODY (proc
);
4149 goto nontoplevel_begin
;
4154 scm_wrong_num_args (proc
);
4156 debug
.info
->a
.args
= scm_cons2 (arg1
, arg2
,
4157 deval_args (x
, env
, proc
,
4158 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
4162 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4163 switch (SCM_TYP7 (proc
))
4164 { /* have 3 or more arguments */
4166 case scm_tc7_subr_3
:
4167 if (!SCM_NULLP (SCM_CDR (x
)))
4168 scm_wrong_num_args (proc
);
4170 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4171 SCM_CADDR (debug
.info
->a
.args
)));
4173 arg1
= SCM_SUBRF(proc
)(arg1
, arg2
);
4174 arg2
= SCM_CDDR (debug
.info
->a
.args
);
4177 arg1
= SCM_SUBRF(proc
)(arg1
, SCM_CAR (arg2
));
4178 arg2
= SCM_CDR (arg2
);
4180 while (SCM_NIMP (arg2
));
4182 case scm_tc7_rpsubr
:
4183 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
4184 RETURN (SCM_BOOL_F
);
4185 arg1
= SCM_CDDR (debug
.info
->a
.args
);
4188 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (arg1
))))
4189 RETURN (SCM_BOOL_F
);
4190 arg2
= SCM_CAR (arg1
);
4191 arg1
= SCM_CDR (arg1
);
4193 while (SCM_NIMP (arg1
));
4194 RETURN (SCM_BOOL_T
);
4195 case scm_tc7_lsubr_2
:
4196 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4197 SCM_CDDR (debug
.info
->a
.args
)));
4199 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4201 if (!SCM_SMOB_APPLICABLE_P (proc
))
4203 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4204 SCM_CDDR (debug
.info
->a
.args
)));
4208 proc
= SCM_PROCEDURE (proc
);
4209 debug
.info
->a
.proc
= proc
;
4210 if (!SCM_CLOSUREP (proc
))
4213 case scm_tcs_closures
:
4215 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4216 if (SCM_NULLP (formals
)
4217 || (SCM_CONSP (formals
)
4218 && (SCM_NULLP (SCM_CDR (formals
))
4219 || (SCM_CONSP (SCM_CDR (formals
))
4220 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4221 goto umwrongnumargs
;
4222 SCM_SET_ARGSREADY (debug
);
4223 env
= SCM_EXTEND_ENV (formals
,
4226 x
= SCM_CLOSURE_BODY (proc
);
4227 goto nontoplevel_begin
;
4230 case scm_tc7_subr_3
:
4231 if (!SCM_NULLP (SCM_CDR (x
)))
4232 scm_wrong_num_args (proc
);
4234 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, EVALCAR (x
, env
)));
4236 arg1
= SCM_SUBRF (proc
) (arg1
, arg2
);
4239 arg1
= SCM_SUBRF(proc
)(arg1
, EVALCAR(x
, env
));
4242 while (!SCM_NULLP (x
));
4244 case scm_tc7_rpsubr
:
4245 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
4246 RETURN (SCM_BOOL_F
);
4249 arg1
= EVALCAR (x
, env
);
4250 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, arg1
)))
4251 RETURN (SCM_BOOL_F
);
4255 while (!SCM_NULLP (x
));
4256 RETURN (SCM_BOOL_T
);
4257 case scm_tc7_lsubr_2
:
4258 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
4260 RETURN (SCM_SUBRF (proc
) (scm_cons2 (arg1
,
4262 scm_eval_args (x
, env
, proc
))));
4264 if (!SCM_SMOB_APPLICABLE_P (proc
))
4266 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4267 scm_eval_args (x
, env
, proc
)));
4271 proc
= SCM_PROCEDURE (proc
);
4272 if (!SCM_CLOSUREP (proc
))
4275 case scm_tcs_closures
:
4277 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4278 if (SCM_NULLP (formals
)
4279 || (SCM_CONSP (formals
)
4280 && (SCM_NULLP (SCM_CDR (formals
))
4281 || (SCM_CONSP (SCM_CDR (formals
))
4282 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4283 goto umwrongnumargs
;
4284 env
= SCM_EXTEND_ENV (formals
,
4287 scm_eval_args (x
, env
, proc
)),
4289 x
= SCM_CLOSURE_BODY (proc
);
4290 goto nontoplevel_begin
;
4293 case scm_tcs_struct
:
4294 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4297 arg1
= debug
.info
->a
.args
;
4299 arg1
= scm_cons2 (arg1
, arg2
, scm_eval_args (x
, env
, proc
));
4301 x
= SCM_ENTITY_PROCEDURE (proc
);
4304 else if (SCM_I_OPERATORP (proc
))
4308 case scm_tc7_subr_2
:
4309 case scm_tc7_subr_1o
:
4310 case scm_tc7_subr_2o
:
4311 case scm_tc7_subr_0
:
4314 case scm_tc7_subr_1
:
4315 scm_wrong_num_args (proc
);
4323 if (scm_check_exit_p
&& SCM_TRAPS_P
)
4324 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
4326 SCM_CLEAR_TRACED_FRAME (debug
);
4327 if (SCM_CHEAPTRAPS_P
)
4328 arg1
= scm_make_debugobj (&debug
);
4332 SCM val
= scm_make_continuation (&first
);
4343 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
4347 scm_last_debug_frame
= debug
.prev
;
4353 /* SECTION: This code is compiled once.
4360 /* Simple procedure calls
4364 scm_call_0 (SCM proc
)
4366 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
4370 scm_call_1 (SCM proc
, SCM arg1
)
4372 return scm_apply (proc
, arg1
, scm_listofnull
);
4376 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
4378 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
4382 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
4384 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
4388 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
4390 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
4391 scm_cons (arg4
, scm_listofnull
)));
4394 /* Simple procedure applies
4398 scm_apply_0 (SCM proc
, SCM args
)
4400 return scm_apply (proc
, args
, SCM_EOL
);
4404 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
4406 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
4410 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
4412 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
4416 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
4418 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
4422 /* This code processes the arguments to apply:
4424 (apply PROC ARG1 ... ARGS)
4426 Given a list (ARG1 ... ARGS), this function conses the ARG1
4427 ... arguments onto the front of ARGS, and returns the resulting
4428 list. Note that ARGS is a list; thus, the argument to this
4429 function is a list whose last element is a list.
4431 Apply calls this function, and applies PROC to the elements of the
4432 result. apply:nconc2last takes care of building the list of
4433 arguments, given (ARG1 ... ARGS).
4435 Rather than do new consing, apply:nconc2last destroys its argument.
4436 On that topic, this code came into my care with the following
4437 beautifully cryptic comment on that topic: "This will only screw
4438 you if you do (scm_apply scm_apply '( ... ))" If you know what
4439 they're referring to, send me a patch to this comment. */
4441 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
4443 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
4444 "conses the @var{arg1} @dots{} arguments onto the front of\n"
4445 "@var{args}, and returns the resulting list. Note that\n"
4446 "@var{args} is a list; thus, the argument to this function is\n"
4447 "a list whose last element is a list.\n"
4448 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
4449 "destroys its argument, so use with care.")
4450 #define FUNC_NAME s_scm_nconc2last
4453 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
4455 while (!SCM_NULLP (SCM_CDR (*lloc
))) /* Perhaps should be
4456 SCM_NULL_OR_NIL_P, but not
4457 needed in 99.99% of cases,
4458 and it could seriously hurt
4459 performance. - Neil */
4460 lloc
= SCM_CDRLOC (*lloc
);
4461 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
4462 *lloc
= SCM_CAR (*lloc
);
4470 /* SECTION: When DEVAL is defined this code yields scm_dapply.
4471 * It is compiled twice.
4476 scm_apply (SCM proc
, SCM arg1
, SCM args
)
4482 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
4487 /* Apply a function to a list of arguments.
4489 This function is exported to the Scheme level as taking two
4490 required arguments and a tail argument, as if it were:
4491 (lambda (proc arg1 . args) ...)
4492 Thus, if you just have a list of arguments to pass to a procedure,
4493 pass the list as ARG1, and '() for ARGS. If you have some fixed
4494 args, pass the first as ARG1, then cons any remaining fixed args
4495 onto the front of your argument list, and pass that as ARGS. */
4498 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
4501 scm_t_debug_frame debug
;
4502 scm_t_debug_info debug_vect_body
;
4503 debug
.prev
= scm_last_debug_frame
;
4504 debug
.status
= SCM_APPLYFRAME
;
4505 debug
.vect
= &debug_vect_body
;
4506 debug
.vect
[0].a
.proc
= proc
;
4507 debug
.vect
[0].a
.args
= SCM_EOL
;
4508 scm_last_debug_frame
= &debug
;
4510 if (scm_debug_mode_p
)
4511 return scm_dapply (proc
, arg1
, args
);
4514 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
4516 /* If ARGS is the empty list, then we're calling apply with only two
4517 arguments --- ARG1 is the list of arguments for PROC. Whatever
4518 the case, futz with things so that ARG1 is the first argument to
4519 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
4522 Setting the debug apply frame args this way is pretty messy.
4523 Perhaps we should store arg1 and args directly in the frame as
4524 received, and let scm_frame_arguments unpack them, because that's
4525 a relatively rare operation. This works for now; if the Guile
4526 developer archives are still around, see Mikael's post of
4528 if (SCM_NULLP (args
))
4530 if (SCM_NULLP (arg1
))
4532 arg1
= SCM_UNDEFINED
;
4534 debug
.vect
[0].a
.args
= SCM_EOL
;
4540 debug
.vect
[0].a
.args
= arg1
;
4542 args
= SCM_CDR (arg1
);
4543 arg1
= SCM_CAR (arg1
);
4548 args
= scm_nconc2last (args
);
4550 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4554 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
4557 if (SCM_CHEAPTRAPS_P
)
4558 tmp
= scm_make_debugobj (&debug
);
4563 tmp
= scm_make_continuation (&first
);
4568 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
4575 switch (SCM_TYP7 (proc
))
4577 case scm_tc7_subr_2o
:
4578 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
4579 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4580 case scm_tc7_subr_2
:
4581 if (SCM_NULLP (args
) || !SCM_NULLP (SCM_CDR (args
)))
4582 scm_wrong_num_args (proc
);
4583 args
= SCM_CAR (args
);
4584 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4585 case scm_tc7_subr_0
:
4586 if (!SCM_UNBNDP (arg1
))
4587 scm_wrong_num_args (proc
);
4589 RETURN (SCM_SUBRF (proc
) ());
4590 case scm_tc7_subr_1
:
4591 if (SCM_UNBNDP (arg1
))
4592 scm_wrong_num_args (proc
);
4593 case scm_tc7_subr_1o
:
4594 if (!SCM_NULLP (args
))
4595 scm_wrong_num_args (proc
);
4597 RETURN (SCM_SUBRF (proc
) (arg1
));
4599 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
4600 scm_wrong_num_args (proc
);
4601 if (SCM_INUMP (arg1
))
4603 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
4605 else if (SCM_REALP (arg1
))
4607 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4609 else if (SCM_BIGP (arg1
))
4611 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4613 else if (SCM_FRACTIONP (arg1
))
4615 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4617 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4618 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4620 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
4621 scm_wrong_num_args (proc
);
4623 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
4626 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
4627 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4628 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
4633 case scm_tc7_subr_3
:
4634 if (SCM_NULLP (args
)
4635 || SCM_NULLP (SCM_CDR (args
))
4636 || !SCM_NULLP (SCM_CDDR (args
)))
4637 scm_wrong_num_args (proc
);
4639 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
4642 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
4644 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
4646 case scm_tc7_lsubr_2
:
4647 if (!SCM_CONSP (args
))
4648 scm_wrong_num_args (proc
);
4650 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4652 if (SCM_NULLP (args
))
4653 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4654 while (SCM_NIMP (args
))
4656 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
4657 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
4658 args
= SCM_CDR (args
);
4661 case scm_tc7_rpsubr
:
4662 if (SCM_NULLP (args
))
4663 RETURN (SCM_BOOL_T
);
4664 while (SCM_NIMP (args
))
4666 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
4667 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
4668 RETURN (SCM_BOOL_F
);
4669 arg1
= SCM_CAR (args
);
4670 args
= SCM_CDR (args
);
4672 RETURN (SCM_BOOL_T
);
4673 case scm_tcs_closures
:
4675 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4677 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4679 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
4680 scm_wrong_num_args (proc
);
4682 /* Copy argument list */
4687 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
4688 for (arg1
= SCM_CDR (arg1
); SCM_CONSP (arg1
); arg1
= SCM_CDR (arg1
))
4690 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
));
4693 SCM_SETCDR (tl
, arg1
);
4696 args
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4699 proc
= SCM_CLOSURE_BODY (proc
);
4701 arg1
= SCM_CDR (proc
);
4702 while (!SCM_NULLP (arg1
))
4704 if (SCM_IMP (SCM_CAR (proc
)))
4706 if (SCM_ISYMP (SCM_CAR (proc
)))
4708 scm_rec_mutex_lock (&source_mutex
);
4709 /* check for race condition */
4710 if (SCM_ISYMP (SCM_CAR (proc
)))
4711 m_expand_body (proc
, args
);
4712 scm_rec_mutex_unlock (&source_mutex
);
4716 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
4719 (void) EVAL (SCM_CAR (proc
), args
);
4721 arg1
= SCM_CDR (proc
);
4723 RETURN (EVALCAR (proc
, args
));
4725 if (!SCM_SMOB_APPLICABLE_P (proc
))
4727 if (SCM_UNBNDP (arg1
))
4728 RETURN (SCM_SMOB_APPLY_0 (proc
));
4729 else if (SCM_NULLP (args
))
4730 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
4731 else if (SCM_NULLP (SCM_CDR (args
)))
4732 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
4734 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4737 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4739 proc
= SCM_CCLO_SUBR (proc
);
4740 debug
.vect
[0].a
.proc
= proc
;
4741 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4743 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4745 proc
= SCM_CCLO_SUBR (proc
);
4749 proc
= SCM_PROCEDURE (proc
);
4751 debug
.vect
[0].a
.proc
= proc
;
4754 case scm_tcs_struct
:
4755 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4758 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4760 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4762 RETURN (scm_apply_generic (proc
, args
));
4764 else if (SCM_I_OPERATORP (proc
))
4768 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4770 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4773 proc
= (SCM_I_ENTITYP (proc
)
4774 ? SCM_ENTITY_PROCEDURE (proc
)
4775 : SCM_OPERATOR_PROCEDURE (proc
));
4777 debug
.vect
[0].a
.proc
= proc
;
4778 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4780 if (SCM_NIMP (proc
))
4789 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
4793 if (scm_check_exit_p
&& SCM_TRAPS_P
)
4794 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
4796 SCM_CLEAR_TRACED_FRAME (debug
);
4797 if (SCM_CHEAPTRAPS_P
)
4798 arg1
= scm_make_debugobj (&debug
);
4802 SCM val
= scm_make_continuation (&first
);
4813 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
4817 scm_last_debug_frame
= debug
.prev
;
4823 /* SECTION: The rest of this file is only read once.
4830 * Trampolines make it possible to move procedure application dispatch
4831 * outside inner loops. The motivation was clean implementation of
4832 * efficient replacements of R5RS primitives in SRFI-1.
4834 * The semantics is clear: scm_trampoline_N returns an optimized
4835 * version of scm_call_N (or NULL if the procedure isn't applicable
4838 * Applying the optimization to map and for-each increased efficiency
4839 * noticeably. For example, (map abs ls) is now 8 times faster than
4844 call_subr0_0 (SCM proc
)
4846 return SCM_SUBRF (proc
) ();
4850 call_subr1o_0 (SCM proc
)
4852 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
4856 call_lsubr_0 (SCM proc
)
4858 return SCM_SUBRF (proc
) (SCM_EOL
);
4862 scm_i_call_closure_0 (SCM proc
)
4864 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4867 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
4872 scm_trampoline_0 (SCM proc
)
4874 scm_t_trampoline_0 trampoline
;
4879 switch (SCM_TYP7 (proc
))
4881 case scm_tc7_subr_0
:
4882 trampoline
= call_subr0_0
;
4884 case scm_tc7_subr_1o
:
4885 trampoline
= call_subr1o_0
;
4888 trampoline
= call_lsubr_0
;
4890 case scm_tcs_closures
:
4892 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4893 if (SCM_NULLP (formals
) || !SCM_CONSP (formals
))
4894 trampoline
= scm_i_call_closure_0
;
4899 case scm_tcs_struct
:
4900 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4901 trampoline
= scm_call_generic_0
;
4902 else if (SCM_I_OPERATORP (proc
))
4903 trampoline
= scm_call_0
;
4908 if (SCM_SMOB_APPLICABLE_P (proc
))
4909 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
4914 case scm_tc7_rpsubr
:
4917 trampoline
= scm_call_0
;
4920 return NULL
; /* not applicable on zero arguments */
4922 /* We only reach this point if a valid trampoline was determined. */
4924 /* If debugging is enabled, we want to see all calls to proc on the stack.
4925 * Thus, we replace the trampoline shortcut with scm_call_0. */
4926 if (scm_debug_mode_p
)
4933 call_subr1_1 (SCM proc
, SCM arg1
)
4935 return SCM_SUBRF (proc
) (arg1
);
4939 call_subr2o_1 (SCM proc
, SCM arg1
)
4941 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
4945 call_lsubr_1 (SCM proc
, SCM arg1
)
4947 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
4951 call_dsubr_1 (SCM proc
, SCM arg1
)
4953 if (SCM_INUMP (arg1
))
4955 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
4957 else if (SCM_REALP (arg1
))
4959 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4961 else if (SCM_BIGP (arg1
))
4963 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4965 else if (SCM_FRACTIONP (arg1
))
4967 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4969 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4970 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4974 call_cxr_1 (SCM proc
, SCM arg1
)
4976 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
4979 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
4980 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4981 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
4988 call_closure_1 (SCM proc
, SCM arg1
)
4990 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4993 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
4998 scm_trampoline_1 (SCM proc
)
5000 scm_t_trampoline_1 trampoline
;
5005 switch (SCM_TYP7 (proc
))
5007 case scm_tc7_subr_1
:
5008 case scm_tc7_subr_1o
:
5009 trampoline
= call_subr1_1
;
5011 case scm_tc7_subr_2o
:
5012 trampoline
= call_subr2o_1
;
5015 trampoline
= call_lsubr_1
;
5018 trampoline
= call_dsubr_1
;
5021 trampoline
= call_cxr_1
;
5023 case scm_tcs_closures
:
5025 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5026 if (!SCM_NULLP (formals
)
5027 && (!SCM_CONSP (formals
) || !SCM_CONSP (SCM_CDR (formals
))))
5028 trampoline
= call_closure_1
;
5033 case scm_tcs_struct
:
5034 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5035 trampoline
= scm_call_generic_1
;
5036 else if (SCM_I_OPERATORP (proc
))
5037 trampoline
= scm_call_1
;
5042 if (SCM_SMOB_APPLICABLE_P (proc
))
5043 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
5048 case scm_tc7_rpsubr
:
5051 trampoline
= scm_call_1
;
5054 return NULL
; /* not applicable on one arg */
5056 /* We only reach this point if a valid trampoline was determined. */
5058 /* If debugging is enabled, we want to see all calls to proc on the stack.
5059 * Thus, we replace the trampoline shortcut with scm_call_1. */
5060 if (scm_debug_mode_p
)
5067 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
5069 return SCM_SUBRF (proc
) (arg1
, arg2
);
5073 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
5075 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
5079 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
5081 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
5085 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
5087 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
5088 scm_list_2 (arg1
, arg2
),
5090 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
5095 scm_trampoline_2 (SCM proc
)
5097 scm_t_trampoline_2 trampoline
;
5102 switch (SCM_TYP7 (proc
))
5104 case scm_tc7_subr_2
:
5105 case scm_tc7_subr_2o
:
5106 case scm_tc7_rpsubr
:
5108 trampoline
= call_subr2_2
;
5110 case scm_tc7_lsubr_2
:
5111 trampoline
= call_lsubr2_2
;
5114 trampoline
= call_lsubr_2
;
5116 case scm_tcs_closures
:
5118 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5119 if (!SCM_NULLP (formals
)
5120 && (!SCM_CONSP (formals
)
5121 || (!SCM_NULLP (SCM_CDR (formals
))
5122 && (!SCM_CONSP (SCM_CDR (formals
))
5123 || !SCM_CONSP (SCM_CDDR (formals
))))))
5124 trampoline
= call_closure_2
;
5129 case scm_tcs_struct
:
5130 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5131 trampoline
= scm_call_generic_2
;
5132 else if (SCM_I_OPERATORP (proc
))
5133 trampoline
= scm_call_2
;
5138 if (SCM_SMOB_APPLICABLE_P (proc
))
5139 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
5145 trampoline
= scm_call_2
;
5148 return NULL
; /* not applicable on two args */
5150 /* We only reach this point if a valid trampoline was determined. */
5152 /* If debugging is enabled, we want to see all calls to proc on the stack.
5153 * Thus, we replace the trampoline shortcut with scm_call_2. */
5154 if (scm_debug_mode_p
)
5160 /* Typechecking for multi-argument MAP and FOR-EACH.
5162 Verify that each element of the vector ARGV, except for the first,
5163 is a proper list whose length is LEN. Attribute errors to WHO,
5164 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
5166 check_map_args (SCM argv
,
5173 SCM
const *ve
= SCM_VELTS (argv
);
5176 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
5178 long elt_len
= scm_ilength (ve
[i
]);
5183 scm_apply_generic (gf
, scm_cons (proc
, args
));
5185 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
5189 scm_out_of_range_pos (who
, ve
[i
], SCM_MAKINUM (i
+ 2));
5192 scm_remember_upto_here_1 (argv
);
5196 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
5198 /* Note: Currently, scm_map applies PROC to the argument list(s)
5199 sequentially, starting with the first element(s). This is used in
5200 evalext.c where the Scheme procedure `map-in-order', which guarantees
5201 sequential behaviour, is implemented using scm_map. If the
5202 behaviour changes, we need to update `map-in-order'.
5206 scm_map (SCM proc
, SCM arg1
, SCM args
)
5207 #define FUNC_NAME s_map
5212 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
5214 len
= scm_ilength (arg1
);
5215 SCM_GASSERTn (len
>= 0,
5216 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
5217 SCM_VALIDATE_REST_ARGUMENT (args
);
5218 if (SCM_NULLP (args
))
5220 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5221 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
5222 while (SCM_NIMP (arg1
))
5224 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
5225 pres
= SCM_CDRLOC (*pres
);
5226 arg1
= SCM_CDR (arg1
);
5230 if (SCM_NULLP (SCM_CDR (args
)))
5232 SCM arg2
= SCM_CAR (args
);
5233 int len2
= scm_ilength (arg2
);
5234 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5236 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
5237 SCM_GASSERTn (len2
>= 0,
5238 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
5240 SCM_OUT_OF_RANGE (3, arg2
);
5241 while (SCM_NIMP (arg1
))
5243 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
5244 pres
= SCM_CDRLOC (*pres
);
5245 arg1
= SCM_CDR (arg1
);
5246 arg2
= SCM_CDR (arg2
);
5250 arg1
= scm_cons (arg1
, args
);
5251 args
= scm_vector (arg1
);
5252 ve
= SCM_VELTS (args
);
5253 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
5257 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5259 if (SCM_IMP (ve
[i
]))
5261 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
5262 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
5264 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
5265 pres
= SCM_CDRLOC (*pres
);
5271 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
5274 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
5275 #define FUNC_NAME s_for_each
5277 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
5279 len
= scm_ilength (arg1
);
5280 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
5281 SCM_ARG2
, s_for_each
);
5282 SCM_VALIDATE_REST_ARGUMENT (args
);
5283 if (SCM_NULLP (args
))
5285 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5286 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
5287 while (SCM_NIMP (arg1
))
5289 call (proc
, SCM_CAR (arg1
));
5290 arg1
= SCM_CDR (arg1
);
5292 return SCM_UNSPECIFIED
;
5294 if (SCM_NULLP (SCM_CDR (args
)))
5296 SCM arg2
= SCM_CAR (args
);
5297 int len2
= scm_ilength (arg2
);
5298 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5299 SCM_GASSERTn (call
, g_for_each
,
5300 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
5301 SCM_GASSERTn (len2
>= 0, g_for_each
,
5302 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
5304 SCM_OUT_OF_RANGE (3, arg2
);
5305 while (SCM_NIMP (arg1
))
5307 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
5308 arg1
= SCM_CDR (arg1
);
5309 arg2
= SCM_CDR (arg2
);
5311 return SCM_UNSPECIFIED
;
5313 arg1
= scm_cons (arg1
, args
);
5314 args
= scm_vector (arg1
);
5315 ve
= SCM_VELTS (args
);
5316 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
5320 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5322 if (SCM_IMP (ve
[i
]))
5323 return SCM_UNSPECIFIED
;
5324 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
5325 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
5327 scm_apply (proc
, arg1
, SCM_EOL
);
5334 scm_closure (SCM code
, SCM env
)
5337 SCM closcar
= scm_cons (code
, SCM_EOL
);
5338 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
5339 scm_remember_upto_here (closcar
);
5344 scm_t_bits scm_tc16_promise
;
5347 scm_makprom (SCM code
)
5349 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
5351 scm_make_rec_mutex ());
5355 promise_free (SCM promise
)
5357 scm_rec_mutex_free (SCM_PROMISE_MUTEX (promise
));
5362 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
5364 int writingp
= SCM_WRITINGP (pstate
);
5365 scm_puts ("#<promise ", port
);
5366 SCM_SET_WRITINGP (pstate
, 1);
5367 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
5368 SCM_SET_WRITINGP (pstate
, writingp
);
5369 scm_putc ('>', port
);
5373 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
5375 "If the promise @var{x} has not been computed yet, compute and\n"
5376 "return @var{x}, otherwise just return the previously computed\n"
5378 #define FUNC_NAME s_scm_force
5380 SCM_VALIDATE_SMOB (1, promise
, promise
);
5381 scm_rec_mutex_lock (SCM_PROMISE_MUTEX (promise
));
5382 if (!SCM_PROMISE_COMPUTED_P (promise
))
5384 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
5385 if (!SCM_PROMISE_COMPUTED_P (promise
))
5387 SCM_SET_PROMISE_DATA (promise
, ans
);
5388 SCM_SET_PROMISE_COMPUTED (promise
);
5391 scm_rec_mutex_unlock (SCM_PROMISE_MUTEX (promise
));
5392 return SCM_PROMISE_DATA (promise
);
5397 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
5399 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
5400 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
5401 #define FUNC_NAME s_scm_promise_p
5403 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
5408 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
5409 (SCM xorig
, SCM x
, SCM y
),
5410 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
5411 "Any source properties associated with @var{xorig} are also associated\n"
5412 "with the new pair.")
5413 #define FUNC_NAME s_scm_cons_source
5416 z
= scm_cons (x
, y
);
5417 /* Copy source properties possibly associated with xorig. */
5418 p
= scm_whash_lookup (scm_source_whash
, xorig
);
5420 scm_whash_insert (scm_source_whash
, z
, p
);
5426 /* The function scm_copy_tree is used to copy an expression tree to allow the
5427 * memoizer to modify the expression during memoization. scm_copy_tree
5428 * creates deep copies of pairs and vectors, but not of any other data types,
5429 * since only pairs and vectors will be parsed by the memoizer.
5431 * To avoid infinite recursion due to cyclic structures, the hare-and-tortoise
5432 * pattern is used to detect cycles. In fact, the pattern is used in two
5433 * dimensions, vertical (indicated in the code by the variable names 'hare'
5434 * and 'tortoise') and horizontal ('rabbit' and 'turtle'). In both
5435 * dimensions, the hare/rabbit will take two steps when the tortoise/turtle
5438 * The vertical dimension corresponds to recursive calls to function
5439 * copy_tree: This happens when descending into vector elements, into cars of
5440 * lists and into the cdr of an improper list. In this dimension, the
5441 * tortoise follows the hare by using the processor stack: Every stack frame
5442 * will hold an instance of struct t_trace. These instances are connected in
5443 * a way that represents the trace of the hare, which thus can be followed by
5444 * the tortoise. The tortoise will always point to struct t_trace instances
5445 * relating to SCM objects that have already been copied. Thus, a cycle is
5446 * detected if the tortoise and the hare point to the same object,
5448 * The horizontal dimension is within one execution of copy_tree, when the
5449 * function cdr's along the pairs of a list. This is the standard
5450 * hare-and-tortoise implementation, found several times in guile. */
5453 struct t_trace
*trace
; // These pointers form a trace along the stack.
5454 SCM obj
; // The object handled at the respective stack frame.
5459 struct t_trace
*const hare
,
5460 struct t_trace
*tortoise
,
5461 unsigned int tortoise_delay
)
5463 if (!SCM_CONSP (hare
->obj
) && !SCM_VECTORP (hare
->obj
))
5469 /* Prepare the trace along the stack. */
5470 struct t_trace new_hare
;
5471 hare
->trace
= &new_hare
;
5473 /* The tortoise will make its step after the delay has elapsed. Note
5474 * that in contrast to the typical hare-and-tortoise pattern, the step
5475 * of the tortoise happens before the hare takes its steps. This is, in
5476 * principle, no problem, except for the start of the algorithm: Then,
5477 * it has to be made sure that the hare actually gets its advantage of
5479 if (tortoise_delay
== 0)
5482 tortoise
= tortoise
->trace
;
5483 ASSERT_SYNTAX (!SCM_EQ_P (hare
->obj
, tortoise
->obj
),
5484 s_bad_expression
, hare
->obj
);
5491 if (SCM_VECTORP (hare
->obj
))
5493 const unsigned long int length
= SCM_VECTOR_LENGTH (hare
->obj
);
5494 const SCM new_vector
= scm_c_make_vector (length
, SCM_UNSPECIFIED
);
5496 /* Each vector element is copied by recursing into copy_tree, having
5497 * the tortoise follow the hare into the depths of the stack. */
5498 unsigned long int i
;
5499 for (i
= 0; i
< length
; ++i
)
5502 new_hare
.obj
= SCM_VECTOR_REF (hare
->obj
, i
);
5503 new_element
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5504 SCM_VECTOR_SET (new_vector
, i
, new_element
);
5509 else // SCM_CONSP (hare->obj)
5514 SCM rabbit
= hare
->obj
;
5515 SCM turtle
= hare
->obj
;
5519 /* The first pair of the list is treated specially, in order to
5520 * preserve a potential source code position. */
5521 result
= tail
= scm_cons_source (rabbit
, SCM_EOL
, SCM_EOL
);
5522 new_hare
.obj
= SCM_CAR (rabbit
);
5523 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5524 SCM_SETCAR (tail
, copy
);
5526 /* The remaining pairs of the list are copied by, horizontally,
5527 * having the turtle follow the rabbit, and, vertically, having the
5528 * tortoise follow the hare into the depths of the stack. */
5529 rabbit
= SCM_CDR (rabbit
);
5530 while (SCM_CONSP (rabbit
))
5532 new_hare
.obj
= SCM_CAR (rabbit
);
5533 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5534 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
5535 tail
= SCM_CDR (tail
);
5537 rabbit
= SCM_CDR (rabbit
);
5538 if (SCM_CONSP (rabbit
))
5540 new_hare
.obj
= SCM_CAR (rabbit
);
5541 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5542 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
5543 tail
= SCM_CDR (tail
);
5544 rabbit
= SCM_CDR (rabbit
);
5546 turtle
= SCM_CDR (turtle
);
5547 ASSERT_SYNTAX (!SCM_EQ_P (rabbit
, turtle
),
5548 s_bad_expression
, rabbit
);
5552 /* We have to recurse into copy_tree again for the last cdr, in
5553 * order to handle the situation that it holds a vector. */
5554 new_hare
.obj
= rabbit
;
5555 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5556 SCM_SETCDR (tail
, copy
);
5563 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
5565 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
5566 "the new data structure. @code{copy-tree} recurses down the\n"
5567 "contents of both pairs and vectors (since both cons cells and vector\n"
5568 "cells may point to arbitrary objects), and stops recursing when it hits\n"
5569 "any other object.")
5570 #define FUNC_NAME s_scm_copy_tree
5572 /* Prepare the trace along the stack. */
5573 struct t_trace trace
;
5576 /* In function copy_tree, if the tortoise makes its step, it will do this
5577 * before the hare has the chance to move. Thus, we have to make sure that
5578 * the very first step of the tortoise will not happen after the hare has
5579 * really made two steps. This is achieved by passing '2' as the initial
5580 * delay for the tortoise. NOTE: Since cycles are unlikely, giving the hare
5581 * a bigger advantage may improve performance slightly. */
5582 return copy_tree (&trace
, &trace
, 2);
5587 /* We have three levels of EVAL here:
5589 - scm_i_eval (exp, env)
5591 evaluates EXP in environment ENV. ENV is a lexical environment
5592 structure as used by the actual tree code evaluator. When ENV is
5593 a top-level environment, then changes to the current module are
5594 tracked by updating ENV so that it continues to be in sync with
5597 - scm_primitive_eval (exp)
5599 evaluates EXP in the top-level environment as determined by the
5600 current module. This is done by constructing a suitable
5601 environment and calling scm_i_eval. Thus, changes to the
5602 top-level module are tracked normally.
5604 - scm_eval (exp, mod)
5606 evaluates EXP while MOD is the current module. This is done by
5607 setting the current module to MOD, invoking scm_primitive_eval on
5608 EXP, and then restoring the current module to the value it had
5609 previously. That is, while EXP is evaluated, changes to the
5610 current module are tracked, but these changes do not persist when
5613 For each level of evals, there are two variants, distinguished by a
5614 _x suffix: the ordinary variant does not modify EXP while the _x
5615 variant can destructively modify EXP into something completely
5616 unintelligible. A Scheme data structure passed as EXP to one of the
5617 _x variants should not ever be used again for anything. So when in
5618 doubt, use the ordinary variant.
5623 scm_i_eval_x (SCM exp
, SCM env
)
5625 if (SCM_SYMBOLP (exp
))
5626 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
5628 return SCM_XEVAL (exp
, env
);
5632 scm_i_eval (SCM exp
, SCM env
)
5634 exp
= scm_copy_tree (exp
);
5635 if (SCM_SYMBOLP (exp
))
5636 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
5638 return SCM_XEVAL (exp
, env
);
5642 scm_primitive_eval_x (SCM exp
)
5645 SCM transformer
= scm_current_module_transformer ();
5646 if (SCM_NIMP (transformer
))
5647 exp
= scm_call_1 (transformer
, exp
);
5648 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5649 return scm_i_eval_x (exp
, env
);
5652 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
5654 "Evaluate @var{exp} in the top-level environment specified by\n"
5655 "the current module.")
5656 #define FUNC_NAME s_scm_primitive_eval
5659 SCM transformer
= scm_current_module_transformer ();
5660 if (SCM_NIMP (transformer
))
5661 exp
= scm_call_1 (transformer
, exp
);
5662 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5663 return scm_i_eval (exp
, env
);
5668 /* Eval does not take the second arg optionally. This is intentional
5669 * in order to be R5RS compatible, and to prepare for the new module
5670 * system, where we would like to make the choice of evaluation
5671 * environment explicit. */
5674 change_environment (void *data
)
5676 SCM pair
= SCM_PACK (data
);
5677 SCM new_module
= SCM_CAR (pair
);
5678 SCM old_module
= scm_current_module ();
5679 SCM_SETCDR (pair
, old_module
);
5680 scm_set_current_module (new_module
);
5684 restore_environment (void *data
)
5686 SCM pair
= SCM_PACK (data
);
5687 SCM old_module
= SCM_CDR (pair
);
5688 SCM new_module
= scm_current_module ();
5689 SCM_SETCAR (pair
, new_module
);
5690 scm_set_current_module (old_module
);
5694 inner_eval_x (void *data
)
5696 return scm_primitive_eval_x (SCM_PACK(data
));
5700 scm_eval_x (SCM exp
, SCM module
)
5701 #define FUNC_NAME "eval!"
5703 SCM_VALIDATE_MODULE (2, module
);
5705 return scm_internal_dynamic_wind
5706 (change_environment
, inner_eval_x
, restore_environment
,
5707 (void *) SCM_UNPACK (exp
),
5708 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
5713 inner_eval (void *data
)
5715 return scm_primitive_eval (SCM_PACK(data
));
5718 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
5719 (SCM exp
, SCM module
),
5720 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
5721 "in the top-level environment specified by @var{module}.\n"
5722 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
5723 "@var{module} is made the current module. The current module\n"
5724 "is reset to its previous value when @var{eval} returns.")
5725 #define FUNC_NAME s_scm_eval
5727 SCM_VALIDATE_MODULE (2, module
);
5729 return scm_internal_dynamic_wind
5730 (change_environment
, inner_eval
, restore_environment
,
5731 (void *) SCM_UNPACK (exp
),
5732 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
5737 /* At this point, deval and scm_dapply are generated.
5744 #if (SCM_ENABLE_DEPRECATED == 1)
5746 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5747 SCM
scm_ceval (SCM x
, SCM env
)
5750 return ceval (x
, env
);
5751 else if (SCM_SYMBOLP (x
))
5752 return *scm_lookupcar (scm_cons (x
, SCM_UNDEFINED
), env
, 1);
5754 return SCM_XEVAL (x
, env
);
5757 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5758 SCM
scm_deval (SCM x
, SCM env
)
5761 return deval (x
, env
);
5762 else if (SCM_SYMBOLP (x
))
5763 return *scm_lookupcar (scm_cons (x
, SCM_UNDEFINED
), env
, 1);
5765 return SCM_XEVAL (x
, env
);
5769 dispatching_eval (SCM x
, SCM env
)
5771 if (scm_debug_mode_p
)
5772 return scm_deval (x
, env
);
5774 return scm_ceval (x
, env
);
5777 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5778 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
) = dispatching_eval
;
5786 scm_init_opts (scm_evaluator_traps
,
5787 scm_evaluator_trap_table
,
5788 SCM_N_EVALUATOR_TRAPS
);
5789 scm_init_opts (scm_eval_options_interface
,
5791 SCM_N_EVAL_OPTIONS
);
5793 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
5794 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
5795 scm_set_smob_free (scm_tc16_promise
, promise_free
);
5796 scm_set_smob_print (scm_tc16_promise
, promise_print
);
5798 undefineds
= scm_list_1 (SCM_UNDEFINED
);
5799 SCM_SETCDR (undefineds
, undefineds
);
5800 scm_permanent_object (undefineds
);
5802 scm_listofnull
= scm_list_1 (SCM_EOL
);
5804 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
5805 scm_permanent_object (f_apply
);
5807 #include "libguile/eval.x"
5809 scm_add_feature ("delay");