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
);
95 /* prototype in eval.h is not given under --disable-deprecated */
96 SCM_API SCM
scm_macroexp (SCM x
, SCM env
);
102 * This section defines the message strings for the syntax errors that can be
103 * detected during memoization and the functions and macros that shall be
104 * called by the memoizer code to signal syntax errors. */
107 /* Syntax errors that can be detected during memoization: */
109 /* Circular or improper lists do not form valid scheme expressions. If a
110 * circular list or an improper list is detected in a place where a scheme
111 * expression is expected, a 'Bad expression' error is signalled. */
112 static const char s_bad_expression
[] = "Bad expression";
114 /* If a form is detected that holds a different number of expressions than are
115 * required in that context, a 'Missing or extra expression' error is
117 static const char s_expression
[] = "Missing or extra expression in";
119 /* If a form is detected that holds less expressions than are required in that
120 * context, a 'Missing expression' error is signalled. */
121 static const char s_missing_expression
[] = "Missing expression in";
123 /* If a form is detected that holds more expressions than are allowed in that
124 * context, an 'Extra expression' error is signalled. */
125 static const char s_extra_expression
[] = "Extra expression in";
127 /* The empty combination '()' is not allowed as an expression in scheme. If
128 * it is detected in a place where an expression is expected, an 'Illegal
129 * empty combination' error is signalled. Note: If you encounter this error
130 * message, it is very likely that you intended to denote the empty list. To
131 * do so, you need to quote the empty list like (quote ()) or '(). */
132 static const char s_empty_combination
[] = "Illegal empty combination";
134 /* A body may hold an arbitrary number of internal defines, followed by a
135 * non-empty sequence of expressions. If a body with an empty sequence of
136 * expressions is detected, a 'Missing body expression' error is signalled.
138 static const char s_missing_body_expression
[] = "Missing body expression in";
140 /* A body may hold an arbitrary number of internal defines, followed by a
141 * non-empty sequence of expressions. Each the definitions and the
142 * expressions may be grouped arbitraryly with begin, but it is not allowed to
143 * mix definitions and expressions. If a define form in a body mixes
144 * definitions and expressions, a 'Mixed definitions and expressions' error is
146 static const char s_mixed_body_forms
[] = "Mixed definitions and expressions in";
147 /* Definitions are only allowed on the top level and at the start of a body.
148 * If a definition is detected anywhere else, a 'Bad define placement' error
150 static const char s_bad_define
[] = "Bad define placement";
152 /* Case or cond expressions must have at least one clause. If a case or cond
153 * expression without any clauses is detected, a 'Missing clauses' error is
155 static const char s_missing_clauses
[] = "Missing clauses";
157 /* If there is an 'else' clause in a case or a cond statement, it must be the
158 * last clause. If after the 'else' case clause further clauses are detected,
159 * a 'Misplaced else clause' error is signalled. */
160 static const char s_misplaced_else_clause
[] = "Misplaced else clause";
162 /* If a case clause is detected that is not in the format
163 * (<label(s)> <expression1> <expression2> ...)
164 * a 'Bad case clause' error is signalled. */
165 static const char s_bad_case_clause
[] = "Bad case clause";
167 /* If a case clause is detected where the <label(s)> element is neither a
168 * proper list nor (in case of the last clause) the syntactic keyword 'else',
169 * a 'Bad case labels' error is signalled. Note: If you encounter this error
170 * for an else-clause which seems to be syntactically correct, check if 'else'
171 * is really a syntactic keyword in that context. If 'else' is bound in the
172 * local or global environment, it is not considered a syntactic keyword, but
173 * will be treated as any other variable. */
174 static const char s_bad_case_labels
[] = "Bad case labels";
176 /* In a case statement all labels have to be distinct. If in a case statement
177 * a label occurs more than once, a 'Duplicate case label' error is
179 static const char s_duplicate_case_label
[] = "Duplicate case label";
181 /* If a cond clause is detected that is not in one of the formats
182 * (<test> <expression1> ...) or (else <expression1> <expression2> ...)
183 * a 'Bad cond clause' error is signalled. */
184 static const char s_bad_cond_clause
[] = "Bad cond clause";
186 /* If a cond clause is detected that uses the alternate '=>' form, but does
187 * not hold a recipient element for the test result, a 'Missing recipient'
188 * error is signalled. */
189 static const char s_missing_recipient
[] = "Missing recipient in";
191 /* If in a position where a variable name is required some other object is
192 * detected, a 'Bad variable' error is signalled. */
193 static const char s_bad_variable
[] = "Bad variable";
195 /* Bindings for forms like 'let' and 'do' have to be given in a proper,
196 * possibly empty list. If any other object is detected in a place where a
197 * list of bindings was required, a 'Bad bindings' error is signalled. */
198 static const char s_bad_bindings
[] = "Bad bindings";
200 /* Depending on the syntactic context, a binding has to be in the format
201 * (<variable> <expression>) or (<variable> <expression1> <expression2>).
202 * If anything else is detected in a place where a binding was expected, a
203 * 'Bad binding' error is signalled. */
204 static const char s_bad_binding
[] = "Bad binding";
206 /* Some syntactic forms don't allow variable names to appear more than once in
207 * a list of bindings. If such a situation is nevertheless detected, a
208 * 'Duplicate binding' error is signalled. */
209 static const char s_duplicate_binding
[] = "Duplicate binding";
211 /* If the exit form of a 'do' expression is not in the format
212 * (<test> <expression> ...)
213 * a 'Bad exit clause' error is signalled. */
214 static const char s_bad_exit_clause
[] = "Bad exit clause";
216 /* The formal function arguments of a lambda expression have to be either a
217 * single symbol or a non-cyclic list. For anything else a 'Bad formals'
218 * error is signalled. */
219 static const char s_bad_formals
[] = "Bad formals";
221 /* If in a lambda expression something else than a symbol is detected at a
222 * place where a formal function argument is required, a 'Bad formal' error is
224 static const char s_bad_formal
[] = "Bad formal";
226 /* If in the arguments list of a lambda expression an argument name occurs
227 * more than once, a 'Duplicate formal' error is signalled. */
228 static const char s_duplicate_formal
[] = "Duplicate formal";
230 /* If the evaluation of an unquote-splicing expression gives something else
231 * than a proper list, a 'Non-list result for unquote-splicing' error is
233 static const char s_splicing
[] = "Non-list result for unquote-splicing";
235 /* If something else than an exact integer is detected as the argument for
236 * @slot-ref and @slot-set!, a 'Bad slot number' error is signalled. */
237 static const char s_bad_slot_number
[] = "Bad slot number";
240 /* Signal a syntax error. We distinguish between the form that caused the
241 * error and the enclosing expression. The error message will print out as
242 * shown in the following pattern. The file name and line number are only
243 * given when they can be determined from the erroneous form or from the
244 * enclosing expression.
246 * <filename>: In procedure memoization:
247 * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
249 SCM_SYMBOL (syntax_error_key
, "syntax-error");
251 /* The prototype is needed to indicate that the function does not return. */
253 syntax_error (const char* const, const SCM
, const SCM
) SCM_NORETURN
;
256 syntax_error (const char* const msg
, const SCM form
, const SCM expr
)
258 const SCM msg_string
= scm_makfrom0str (msg
);
259 SCM filename
= SCM_BOOL_F
;
260 SCM linenr
= SCM_BOOL_F
;
264 if (SCM_CONSP (form
))
266 filename
= scm_source_property (form
, scm_sym_filename
);
267 linenr
= scm_source_property (form
, scm_sym_line
);
270 if (SCM_FALSEP (filename
) && SCM_FALSEP (linenr
) && SCM_CONSP (expr
))
272 filename
= scm_source_property (expr
, scm_sym_filename
);
273 linenr
= scm_source_property (expr
, scm_sym_line
);
276 if (!SCM_UNBNDP (expr
))
278 if (!SCM_FALSEP (filename
))
280 format
= "In file ~S, line ~S: ~A ~S in expression ~S.";
281 args
= scm_list_5 (filename
, linenr
, msg_string
, form
, expr
);
283 else if (!SCM_FALSEP (linenr
))
285 format
= "In line ~S: ~A ~S in expression ~S.";
286 args
= scm_list_4 (linenr
, msg_string
, form
, expr
);
290 format
= "~A ~S in expression ~S.";
291 args
= scm_list_3 (msg_string
, form
, expr
);
296 if (!SCM_FALSEP (filename
))
298 format
= "In file ~S, line ~S: ~A ~S.";
299 args
= scm_list_4 (filename
, linenr
, msg_string
, form
);
301 else if (!SCM_FALSEP (linenr
))
303 format
= "In line ~S: ~A ~S.";
304 args
= scm_list_3 (linenr
, msg_string
, form
);
309 args
= scm_list_2 (msg_string
, form
);
313 scm_error (syntax_error_key
, "memoization", format
, args
, SCM_BOOL_F
);
317 /* Shortcut macros to simplify syntax error handling. */
318 #define ASSERT_SYNTAX(cond, message, form) \
319 { if (!(cond)) syntax_error (message, form, SCM_UNDEFINED); }
320 #define ASSERT_SYNTAX_2(cond, message, form, expr) \
321 { if (!(cond)) syntax_error (message, form, expr); }
327 * Ilocs are memoized references to variables in local environment frames.
328 * They are represented as three values: The relative offset of the
329 * environment frame, the number of the binding within that frame, and a
330 * boolean value indicating whether the binding is the last binding in the
334 #define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc)
335 #define SCM_IFRINC (0x00000100L)
336 #define SCM_ICDR (0x00080000L)
337 #define SCM_IDINC (0x00100000L)
338 #define SCM_IFRAME(n) ((long)((SCM_ICDR-SCM_IFRINC)>>8) \
339 & (SCM_UNPACK (n) >> 8))
340 #define SCM_IDIST(n) (SCM_UNPACK (n) >> 20)
341 #define SCM_ICDRP(n) (SCM_ICDR & SCM_UNPACK (n))
342 #define SCM_IDSTMSK (-SCM_IDINC)
343 #define SCM_MAKE_ILOC(frame_nr, binding_nr, last_p) \
346 + ((binding_nr) << 20) \
347 + ((last_p) ? SCM_ICDR : 0) \
351 scm_i_print_iloc (SCM iloc
, SCM port
)
353 scm_puts ("#@", port
);
354 scm_intprint ((long) SCM_IFRAME (iloc
), 10, port
);
355 scm_putc (SCM_ICDRP (iloc
) ? '-' : '+', port
);
356 scm_intprint ((long) SCM_IDIST (iloc
), 10, port
);
359 #if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
361 SCM
scm_dbg_make_iloc (SCM frame
, SCM binding
, SCM cdrp
);
362 SCM_DEFINE (scm_dbg_make_iloc
, "dbg-make-iloc", 3, 0, 0,
363 (SCM frame
, SCM binding
, SCM cdrp
),
364 "Return a new iloc with frame offset @var{frame}, binding\n"
365 "offset @var{binding} and the cdr flag @var{cdrp}.")
366 #define FUNC_NAME s_scm_dbg_make_iloc
368 SCM_VALIDATE_INUM (1, frame
);
369 SCM_VALIDATE_INUM (2, binding
);
370 return SCM_MAKE_ILOC (SCM_INUM (frame
),
376 SCM
scm_dbg_iloc_p (SCM obj
);
377 SCM_DEFINE (scm_dbg_iloc_p
, "dbg-iloc?", 1, 0, 0,
379 "Return @code{#t} if @var{obj} is an iloc.")
380 #define FUNC_NAME s_scm_dbg_iloc_p
382 return SCM_BOOL (SCM_ILOCP (obj
));
390 /* {Evaluator byte codes (isyms)}
393 #define ISYMNUM(n) (SCM_ITAG8_DATA (n))
395 /* This table must agree with the list of SCM_IM_ constants in tags.h */
396 static const char *const isymnames
[] =
413 "#@call-with-current-continuation",
419 "#@call-with-values",
427 scm_i_print_isym (SCM isym
, SCM port
)
429 const size_t isymnum
= ISYMNUM (isym
);
430 if (isymnum
< (sizeof isymnames
/ sizeof (char *)))
431 scm_puts (isymnames
[isymnum
], port
);
433 scm_ipruk ("isym", isym
, port
);
438 /* The function lookup_symbol is used during memoization: Lookup the symbol in
439 * the environment. If there is no binding for the symbol, SCM_UNDEFINED is
440 * returned. If the symbol is a syntactic keyword, the macro object to which
441 * the symbol is bound is returned. If the symbol is a global variable, the
442 * variable object to which the symbol is bound is returned. Finally, if the
443 * symbol is a local variable the corresponding iloc object is returned. */
445 /* A helper function for lookup_symbol: Try to find the symbol in the top
446 * level environment frame. The function returns SCM_UNDEFINED if the symbol
447 * is unbound, it returns a macro object if the symbol is a syntactic keyword
448 * and it returns a variable object if the symbol is a global variable. */
450 lookup_global_symbol (const SCM symbol
, const SCM top_level
)
452 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
453 if (SCM_FALSEP (variable
))
455 return SCM_UNDEFINED
;
459 const SCM value
= SCM_VARIABLE_REF (variable
);
460 if (SCM_MACROP (value
))
468 lookup_symbol (const SCM symbol
, const SCM env
)
471 unsigned int frame_nr
;
473 for (frame_idx
= env
, frame_nr
= 0;
474 !SCM_NULLP (frame_idx
);
475 frame_idx
= SCM_CDR (frame_idx
), ++frame_nr
)
477 const SCM frame
= SCM_CAR (frame_idx
);
478 if (SCM_CONSP (frame
))
480 /* frame holds a local environment frame */
482 unsigned int symbol_nr
;
484 for (symbol_idx
= SCM_CAR (frame
), symbol_nr
= 0;
485 SCM_CONSP (symbol_idx
);
486 symbol_idx
= SCM_CDR (symbol_idx
), ++symbol_nr
)
488 if (SCM_EQ_P (SCM_CAR (symbol_idx
), symbol
))
489 /* found the symbol, therefore return the iloc */
490 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 0);
492 if (SCM_EQ_P (symbol_idx
, symbol
))
493 /* found the symbol as the last element of the current frame */
494 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 1);
498 /* no more local environment frames */
499 return lookup_global_symbol (symbol
, frame
);
503 return lookup_global_symbol (symbol
, SCM_BOOL_F
);
507 /* Return true if the symbol is - from the point of view of a macro
508 * transformer - a literal in the sense specified in chapter "pattern
509 * language" of R5RS. In the code below, however, we don't match the
510 * definition of R5RS exactly: It returns true if the identifier has no
511 * binding or if it is a syntactic keyword. */
513 literal_p (const SCM symbol
, const SCM env
)
515 const SCM value
= lookup_symbol (symbol
, env
);
516 if (SCM_UNBNDP (value
) || SCM_MACROP (value
))
523 /* Return true if the expression is self-quoting in the memoized code. Thus,
524 * some other objects (like e. g. vectors) are reported as self-quoting, which
525 * according to R5RS would need to be quoted. */
527 is_self_quoting_p (const SCM expr
)
529 if (SCM_CONSP (expr
))
531 else if (SCM_SYMBOLP (expr
))
533 else if (SCM_NULLP (expr
))
539 /* Rewrite the body (which is given as the list of expressions forming the
540 * body) into its internal form. The internal form of a body (<expr> ...) is
541 * just the body itself, but prefixed with an ISYM that denotes to what kind
542 * of outer construct this body belongs: (<ISYM> <expr> ...). A lambda body
543 * starts with SCM_IM_LAMBDA, for example, a body of a let starts with
546 * It is assumed that the calling expression has already made sure that the
547 * body is a proper list. */
549 m_body (SCM op
, SCM exprs
)
551 /* Don't add another ISYM if one is present already. */
552 if (SCM_ISYMP (SCM_CAR (exprs
)))
555 return scm_cons (op
, exprs
);
559 /* The function m_expand_body memoizes a proper list of expressions
560 * forming a body. This function takes care of dealing with internal
561 * defines and transforming them into an equivalent letrec expression.
562 * The list of expressions is rewritten in place. */
564 /* This is a helper function for m_expand_body. It helps to figure out whether
565 * an expression denotes a syntactic keyword. */
567 try_macro_lookup (const SCM expr
, const SCM env
)
569 if (SCM_SYMBOLP (expr
))
571 const SCM value
= lookup_symbol (expr
, env
);
576 return SCM_UNDEFINED
;
580 /* This is a helper function for m_expand_body. It expands user macros,
581 * because for the correct translation of a body we need to know whether they
582 * expand to a definition. */
584 expand_user_macros (SCM expr
, const SCM env
)
586 while (SCM_CONSP (expr
))
588 const SCM car_expr
= SCM_CAR (expr
);
589 const SCM new_car
= expand_user_macros (car_expr
, env
);
590 const SCM value
= try_macro_lookup (new_car
, env
);
592 if (SCM_MACROP (value
) && SCM_MACRO_TYPE (value
) == 2)
594 /* User macros transform code into code. */
595 expr
= scm_call_2 (SCM_MACRO_CODE (value
), expr
, env
);
596 /* We need to reiterate on the transformed code. */
600 /* No user macro: return. */
601 SCM_SETCAR (expr
, new_car
);
609 /* This is a helper function for m_expand_body. It determines if a given form
610 * represents an application of a given built-in macro. The built-in macro to
611 * check for is identified by its syntactic keyword. The form is an
612 * application of the given macro if looking up the car of the form in the
613 * given environment actually returns the built-in macro. */
615 is_system_macro_p (const SCM syntactic_keyword
, const SCM form
, const SCM env
)
617 if (SCM_CONSP (form
))
619 const SCM car_form
= SCM_CAR (form
);
620 const SCM value
= try_macro_lookup (car_form
, env
);
621 if (SCM_BUILTIN_MACRO_P (value
))
623 const SCM macro_name
= scm_macro_name (value
);
624 return SCM_EQ_P (macro_name
, syntactic_keyword
);
632 m_expand_body (const SCM forms
, const SCM env
)
634 /* The first body form can be skipped since it is known to be the ISYM that
635 * was prepended to the body by m_body. */
636 SCM cdr_forms
= SCM_CDR (forms
);
637 SCM form_idx
= cdr_forms
;
638 SCM definitions
= SCM_EOL
;
639 SCM sequence
= SCM_EOL
;
641 /* According to R5RS, the list of body forms consists of two parts: a number
642 * (maybe zero) of definitions, followed by a non-empty sequence of
643 * expressions. Each the definitions and the expressions may be grouped
644 * arbitrarily with begin, but it is not allowed to mix definitions and
645 * expressions. The task of the following loop therefore is to split the
646 * list of body forms into the list of definitions and the sequence of
648 while (!SCM_NULLP (form_idx
))
650 const SCM form
= SCM_CAR (form_idx
);
651 const SCM new_form
= expand_user_macros (form
, env
);
652 if (is_system_macro_p (scm_sym_define
, new_form
, env
))
654 definitions
= scm_cons (new_form
, definitions
);
655 form_idx
= SCM_CDR (form_idx
);
657 else if (is_system_macro_p (scm_sym_begin
, new_form
, env
))
659 /* We have encountered a group of forms. This has to be either a
660 * (possibly empty) group of (possibly further grouped) definitions,
661 * or a non-empty group of (possibly further grouped)
663 const SCM grouped_forms
= SCM_CDR (new_form
);
664 unsigned int found_definition
= 0;
665 unsigned int found_expression
= 0;
666 SCM grouped_form_idx
= grouped_forms
;
667 while (!found_expression
&& !SCM_NULLP (grouped_form_idx
))
669 const SCM inner_form
= SCM_CAR (grouped_form_idx
);
670 const SCM new_inner_form
= expand_user_macros (inner_form
, env
);
671 if (is_system_macro_p (scm_sym_define
, new_inner_form
, env
))
673 found_definition
= 1;
674 definitions
= scm_cons (new_inner_form
, definitions
);
675 grouped_form_idx
= SCM_CDR (grouped_form_idx
);
677 else if (is_system_macro_p (scm_sym_begin
, new_inner_form
, env
))
679 const SCM inner_group
= SCM_CDR (new_inner_form
);
681 = scm_append (scm_list_2 (inner_group
,
682 SCM_CDR (grouped_form_idx
)));
686 /* The group marks the start of the expressions of the body.
687 * We have to make sure that within the same group we have
688 * not encountered a definition before. */
689 ASSERT_SYNTAX (!found_definition
, s_mixed_body_forms
, form
);
690 found_expression
= 1;
691 grouped_form_idx
= SCM_EOL
;
695 /* We have finished processing the group. If we have not yet
696 * encountered an expression we continue processing the forms of the
697 * body to collect further definition forms. Otherwise, the group
698 * marks the start of the sequence of expressions of the body. */
699 if (!found_expression
)
701 form_idx
= SCM_CDR (form_idx
);
711 /* We have detected a form which is no definition. This marks the
712 * start of the sequence of expressions of the body. */
718 /* FIXME: forms does not hold information about the file location. */
719 ASSERT_SYNTAX (SCM_CONSP (sequence
), s_missing_body_expression
, cdr_forms
);
721 if (!SCM_NULLP (definitions
))
725 SCM letrec_expression
;
726 SCM new_letrec_expression
;
728 SCM bindings
= SCM_EOL
;
729 for (definition_idx
= definitions
;
730 !SCM_NULLP (definition_idx
);
731 definition_idx
= SCM_CDR (definition_idx
))
733 const SCM definition
= SCM_CAR (definition_idx
);
734 const SCM canonical_definition
= canonicalize_define (definition
);
735 const SCM binding
= SCM_CDR (canonical_definition
);
736 bindings
= scm_cons (binding
, bindings
);
739 letrec_tail
= scm_cons (bindings
, sequence
);
740 /* FIXME: forms does not hold information about the file location. */
741 letrec_expression
= scm_cons_source (forms
, scm_sym_letrec
, letrec_tail
);
742 new_letrec_expression
= scm_m_letrec (letrec_expression
, env
);
743 SCM_SETCAR (forms
, new_letrec_expression
);
744 SCM_SETCDR (forms
, SCM_EOL
);
748 SCM_SETCAR (forms
, SCM_CAR (sequence
));
749 SCM_SETCDR (forms
, SCM_CDR (sequence
));
754 /* Start of the memoizers for the standard R5RS builtin macros. */
757 SCM_SYNTAX (s_and
, "and", scm_i_makbimacro
, scm_m_and
);
758 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
761 scm_m_and (SCM expr
, SCM env SCM_UNUSED
)
763 const SCM cdr_expr
= SCM_CDR (expr
);
764 const long length
= scm_ilength (cdr_expr
);
766 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
770 /* Special case: (and) is replaced by #t. */
775 SCM_SETCAR (expr
, SCM_IM_AND
);
781 SCM_SYNTAX (s_begin
, "begin", scm_i_makbimacro
, scm_m_begin
);
782 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
785 scm_m_begin (SCM expr
, SCM env SCM_UNUSED
)
787 const SCM cdr_expr
= SCM_CDR (expr
);
788 /* Dirk:FIXME:: An empty begin clause is not generally allowed by R5RS.
789 * That means, there should be a distinction between uses of begin where an
790 * empty clause is OK and where it is not. */
791 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
793 SCM_SETCAR (expr
, SCM_IM_BEGIN
);
798 SCM_SYNTAX (s_case
, "case", scm_i_makbimacro
, scm_m_case
);
799 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
800 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
803 scm_m_case (SCM expr
, SCM env
)
806 SCM all_labels
= SCM_EOL
;
808 /* Check, whether 'else is a literal, i. e. not bound to a value. */
809 const int else_literal_p
= literal_p (scm_sym_else
, env
);
811 const SCM cdr_expr
= SCM_CDR (expr
);
812 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
813 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_clauses
, expr
);
815 clauses
= SCM_CDR (cdr_expr
);
816 while (!SCM_NULLP (clauses
))
820 const SCM clause
= SCM_CAR (clauses
);
821 ASSERT_SYNTAX_2 (scm_ilength (clause
) >= 2,
822 s_bad_case_clause
, clause
, expr
);
824 labels
= SCM_CAR (clause
);
825 if (SCM_CONSP (labels
))
827 ASSERT_SYNTAX_2 (scm_ilength (labels
) >= 0,
828 s_bad_case_labels
, labels
, expr
);
829 all_labels
= scm_append (scm_list_2 (labels
, all_labels
));
831 else if (SCM_NULLP (labels
))
833 /* The list of labels is empty. According to R5RS this is allowed.
834 * It means that the sequence of expressions will never be executed.
835 * Therefore, as an optimization, we could remove the whole
840 ASSERT_SYNTAX_2 (SCM_EQ_P (labels
, scm_sym_else
) && else_literal_p
,
841 s_bad_case_labels
, labels
, expr
);
842 ASSERT_SYNTAX_2 (SCM_NULLP (SCM_CDR (clauses
)),
843 s_misplaced_else_clause
, clause
, expr
);
846 /* build the new clause */
847 if (SCM_EQ_P (labels
, scm_sym_else
))
848 SCM_SETCAR (clause
, SCM_IM_ELSE
);
850 clauses
= SCM_CDR (clauses
);
853 /* Check whether all case labels are distinct. */
854 for (; !SCM_NULLP (all_labels
); all_labels
= SCM_CDR (all_labels
))
856 const SCM label
= SCM_CAR (all_labels
);
857 ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (label
, SCM_CDR (all_labels
))),
858 s_duplicate_case_label
, label
, expr
);
861 SCM_SETCAR (expr
, SCM_IM_CASE
);
866 SCM_SYNTAX (s_cond
, "cond", scm_i_makbimacro
, scm_m_cond
);
867 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
868 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
871 scm_m_cond (SCM expr
, SCM env
)
873 /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
874 const int else_literal_p
= literal_p (scm_sym_else
, env
);
875 const int arrow_literal_p
= literal_p (scm_sym_arrow
, env
);
877 const SCM clauses
= SCM_CDR (expr
);
880 ASSERT_SYNTAX (scm_ilength (clauses
) >= 0, s_bad_expression
, expr
);
881 ASSERT_SYNTAX (scm_ilength (clauses
) >= 1, s_missing_clauses
, expr
);
883 for (clause_idx
= clauses
;
884 !SCM_NULLP (clause_idx
);
885 clause_idx
= SCM_CDR (clause_idx
))
889 const SCM clause
= SCM_CAR (clause_idx
);
890 const long length
= scm_ilength (clause
);
891 ASSERT_SYNTAX_2 (length
>= 1, s_bad_cond_clause
, clause
, expr
);
893 test
= SCM_CAR (clause
);
894 if (SCM_EQ_P (test
, scm_sym_else
) && else_literal_p
)
896 const int last_clause_p
= SCM_NULLP (SCM_CDR (clause_idx
));
897 ASSERT_SYNTAX_2 (length
>= 2,
898 s_bad_cond_clause
, clause
, expr
);
899 ASSERT_SYNTAX_2 (last_clause_p
,
900 s_misplaced_else_clause
, clause
, expr
);
901 SCM_SETCAR (clause
, SCM_IM_ELSE
);
904 && SCM_EQ_P (SCM_CADR (clause
), scm_sym_arrow
)
907 ASSERT_SYNTAX_2 (length
> 2, s_missing_recipient
, clause
, expr
);
908 ASSERT_SYNTAX_2 (length
== 3, s_extra_expression
, clause
, expr
);
909 SCM_SETCAR (SCM_CDR (clause
), SCM_IM_ARROW
);
913 SCM_SETCAR (expr
, SCM_IM_COND
);
918 SCM_SYNTAX (s_define
, "define", scm_i_makbimacro
, scm_m_define
);
919 SCM_GLOBAL_SYMBOL (scm_sym_define
, s_define
);
921 /* Guile provides an extension to R5RS' define syntax to represent function
922 * currying in a compact way. With this extension, it is allowed to write
923 * (define <nested-variable> <body>), where <nested-variable> has of one of
924 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
925 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
926 * should be either a sequence of zero or more variables, or a sequence of one
927 * or more variables followed by a space-delimited period and another
928 * variable. Each level of argument nesting wraps the <body> within another
929 * lambda expression. For example, the following forms are allowed, each one
930 * followed by an equivalent, more explicit implementation.
932 * (define ((a b . c) . d) <body>) is equivalent to
933 * (define a (lambda (b . c) (lambda d <body>)))
935 * (define (((a) b) c . d) <body>) is equivalent to
936 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
938 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
939 * module that does not implement this extension. */
941 canonicalize_define (const SCM expr
)
946 const SCM cdr_expr
= SCM_CDR (expr
);
947 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
948 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
950 body
= SCM_CDR (cdr_expr
);
951 variable
= SCM_CAR (cdr_expr
);
952 while (SCM_CONSP (variable
))
954 /* This while loop realizes function currying by variable nesting.
955 * Variable is known to be a nested-variable. In every iteration of the
956 * loop another level of lambda expression is created, starting with the
957 * innermost one. Note that we don't check for duplicate formals here:
958 * This will be done by the memoizer of the lambda expression. */
959 const SCM formals
= SCM_CDR (variable
);
960 const SCM tail
= scm_cons (formals
, body
);
962 /* Add source properties to each new lambda expression: */
963 const SCM lambda
= scm_cons_source (variable
, scm_sym_lambda
, tail
);
965 body
= scm_list_1 (lambda
);
966 variable
= SCM_CAR (variable
);
968 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
), s_bad_variable
, variable
, expr
);
969 ASSERT_SYNTAX (scm_ilength (body
) == 1, s_expression
, expr
);
971 SCM_SETCAR (cdr_expr
, variable
);
972 SCM_SETCDR (cdr_expr
, body
);
976 /* According to section 5.2.1 of R5RS we first have to make sure that the
977 * variable is bound, and then perform the (set! variable expression)
978 * operation. This means, that within the expression we may already assign
979 * values to variable: (define foo (begin (set! foo 1) (+ foo 1))) */
981 scm_m_define (SCM expr
, SCM env
)
983 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), s_bad_define
, expr
);
986 const SCM canonical_definition
= canonicalize_define (expr
);
987 const SCM cdr_canonical_definition
= SCM_CDR (canonical_definition
);
988 const SCM variable
= SCM_CAR (cdr_canonical_definition
);
990 = scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_T
);
991 const SCM value
= scm_eval_car (SCM_CDR (cdr_canonical_definition
), env
);
993 if (SCM_REC_PROCNAMES_P
)
996 while (SCM_MACROP (tmp
))
997 tmp
= SCM_MACRO_CODE (tmp
);
998 if (SCM_CLOSUREP (tmp
)
999 /* Only the first definition determines the name. */
1000 && SCM_FALSEP (scm_procedure_property (tmp
, scm_sym_name
)))
1001 scm_set_procedure_property_x (tmp
, scm_sym_name
, variable
);
1004 SCM_VARIABLE_SET (location
, value
);
1006 return SCM_UNSPECIFIED
;
1011 /* This is a helper function for forms (<keyword> <expression>) that are
1012 * transformed into (#@<keyword> '() <memoized_expression>) in order to allow
1013 * for easy creation of a thunk (i. e. a closure without arguments) using the
1014 * ('() <memoized_expression>) tail of the memoized form. */
1016 memoize_as_thunk_prototype (const SCM expr
, const SCM env SCM_UNUSED
)
1018 const SCM cdr_expr
= SCM_CDR (expr
);
1019 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1020 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1022 SCM_SETCDR (expr
, scm_cons (SCM_EOL
, cdr_expr
));
1028 SCM_SYNTAX (s_delay
, "delay", scm_i_makbimacro
, scm_m_delay
);
1029 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
1031 /* Promises are implemented as closures with an empty parameter list. Thus,
1032 * (delay <expression>) is transformed into (#@delay '() <expression>), where
1033 * the empty list represents the empty parameter list. This representation
1034 * allows for easy creation of the closure during evaluation. */
1036 scm_m_delay (SCM expr
, SCM env
)
1038 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1039 SCM_SETCAR (new_expr
, SCM_IM_DELAY
);
1044 SCM_SYNTAX(s_do
, "do", scm_i_makbimacro
, scm_m_do
);
1045 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
1047 /* DO gets the most radically altered syntax. The order of the vars is
1048 * reversed here. During the evaluation this allows for simple consing of the
1049 * results of the inits and steps:
1051 (do ((<var1> <init1> <step1>)
1059 (#@do (<init1> <init2> ... <initn>)
1060 (varn ... var2 var1)
1063 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
1066 scm_m_do (SCM expr
, SCM env SCM_UNUSED
)
1068 SCM variables
= SCM_EOL
;
1069 SCM init_forms
= SCM_EOL
;
1070 SCM step_forms
= SCM_EOL
;
1077 const SCM cdr_expr
= SCM_CDR (expr
);
1078 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1079 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1081 /* Collect variables, init and step forms. */
1082 binding_idx
= SCM_CAR (cdr_expr
);
1083 ASSERT_SYNTAX_2 (scm_ilength (binding_idx
) >= 0,
1084 s_bad_bindings
, binding_idx
, expr
);
1085 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1087 const SCM binding
= SCM_CAR (binding_idx
);
1088 const long length
= scm_ilength (binding
);
1089 ASSERT_SYNTAX_2 (length
== 2 || length
== 3,
1090 s_bad_binding
, binding
, expr
);
1093 const SCM name
= SCM_CAR (binding
);
1094 const SCM init
= SCM_CADR (binding
);
1095 const SCM step
= (length
== 2) ? name
: SCM_CADDR (binding
);
1096 ASSERT_SYNTAX_2 (SCM_SYMBOLP (name
), s_bad_variable
, name
, expr
);
1097 ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (name
, variables
)),
1098 s_duplicate_binding
, name
, expr
);
1100 variables
= scm_cons (name
, variables
);
1101 init_forms
= scm_cons (init
, init_forms
);
1102 step_forms
= scm_cons (step
, step_forms
);
1105 init_forms
= scm_reverse_x (init_forms
, SCM_UNDEFINED
);
1106 step_forms
= scm_reverse_x (step_forms
, SCM_UNDEFINED
);
1108 /* Memoize the test form and the exit sequence. */
1109 cddr_expr
= SCM_CDR (cdr_expr
);
1110 exit_clause
= SCM_CAR (cddr_expr
);
1111 ASSERT_SYNTAX_2 (scm_ilength (exit_clause
) >= 1,
1112 s_bad_exit_clause
, exit_clause
, expr
);
1114 commands
= SCM_CDR (cddr_expr
);
1115 tail
= scm_cons2 (exit_clause
, commands
, step_forms
);
1116 tail
= scm_cons2 (init_forms
, variables
, tail
);
1117 SCM_SETCAR (expr
, SCM_IM_DO
);
1118 SCM_SETCDR (expr
, tail
);
1123 SCM_SYNTAX (s_if
, "if", scm_i_makbimacro
, scm_m_if
);
1124 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
1127 scm_m_if (SCM expr
, SCM env SCM_UNUSED
)
1129 const SCM cdr_expr
= SCM_CDR (expr
);
1130 const long length
= scm_ilength (cdr_expr
);
1131 ASSERT_SYNTAX (length
== 2 || length
== 3, s_expression
, expr
);
1132 SCM_SETCAR (expr
, SCM_IM_IF
);
1137 SCM_SYNTAX (s_lambda
, "lambda", scm_i_makbimacro
, scm_m_lambda
);
1138 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
1140 /* A helper function for memoize_lambda to support checking for duplicate
1141 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
1142 * LIST or to the cdr of the last cons. Therefore, LIST may have any of the
1143 * forms that a formal argument can have:
1144 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
1146 c_improper_memq (SCM obj
, SCM list
)
1148 for (; SCM_CONSP (list
); list
= SCM_CDR (list
))
1150 if (SCM_EQ_P (SCM_CAR (list
), obj
))
1153 return SCM_EQ_P (list
, obj
);
1157 scm_m_lambda (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
>= 0, s_bad_expression
, expr
);
1169 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1171 /* Before iterating the list of formal arguments, make sure the formals
1172 * actually are given as either a symbol or a non-cyclic list. */
1173 formals
= SCM_CAR (cdr_expr
);
1174 if (SCM_CONSP (formals
))
1176 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
1177 * detected, report a 'Bad formals' error. */
1181 ASSERT_SYNTAX_2 (SCM_SYMBOLP (formals
) || SCM_NULLP (formals
),
1182 s_bad_formals
, formals
, expr
);
1185 /* Now iterate the list of formal arguments to check if all formals are
1186 * symbols, and that there are no duplicates. */
1187 formals_idx
= formals
;
1188 while (SCM_CONSP (formals_idx
))
1190 const SCM formal
= SCM_CAR (formals_idx
);
1191 const SCM next_idx
= SCM_CDR (formals_idx
);
1192 ASSERT_SYNTAX_2 (SCM_SYMBOLP (formal
), s_bad_formal
, formal
, expr
);
1193 ASSERT_SYNTAX_2 (!c_improper_memq (formal
, next_idx
),
1194 s_duplicate_formal
, formal
, expr
);
1195 formals_idx
= next_idx
;
1197 ASSERT_SYNTAX_2 (SCM_NULLP (formals_idx
) || SCM_SYMBOLP (formals_idx
),
1198 s_bad_formal
, formals_idx
, expr
);
1200 /* Memoize the body. Keep a potential documentation string. */
1201 /* Dirk:FIXME:: We should probably extract the documentation string to
1202 * some external database. Otherwise it will slow down execution, since
1203 * the documentation string will have to be skipped with every execution
1204 * of the closure. */
1205 cddr_expr
= SCM_CDR (cdr_expr
);
1206 documentation
= (length
>= 3 && SCM_STRINGP (SCM_CAR (cddr_expr
)));
1207 body
= documentation
? SCM_CDR (cddr_expr
) : cddr_expr
;
1208 new_body
= m_body (SCM_IM_LAMBDA
, body
);
1210 SCM_SETCAR (expr
, SCM_IM_LAMBDA
);
1212 SCM_SETCDR (cddr_expr
, new_body
);
1214 SCM_SETCDR (cdr_expr
, new_body
);
1219 /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
1221 check_bindings (const SCM bindings
, const SCM expr
)
1225 ASSERT_SYNTAX_2 (scm_ilength (bindings
) >= 0,
1226 s_bad_bindings
, bindings
, expr
);
1228 binding_idx
= bindings
;
1229 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1231 SCM name
; /* const */
1233 const SCM binding
= SCM_CAR (binding_idx
);
1234 ASSERT_SYNTAX_2 (scm_ilength (binding
) == 2,
1235 s_bad_binding
, binding
, expr
);
1237 name
= SCM_CAR (binding
);
1238 ASSERT_SYNTAX_2 (SCM_SYMBOLP (name
), s_bad_variable
, name
, expr
);
1243 /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
1244 * transformed to the lists (vn ... v2 v1) and (i1 i2 ... in). That is, the
1245 * variables are returned in a list with their order reversed, and the init
1246 * forms are returned in a list in the same order as they are given in the
1247 * bindings. If a duplicate variable name is detected, an error is
1250 transform_bindings (
1251 const SCM bindings
, const SCM expr
,
1252 SCM
*const rvarptr
, SCM
*const initptr
)
1254 SCM rvariables
= SCM_EOL
;
1255 SCM rinits
= SCM_EOL
;
1256 SCM binding_idx
= bindings
;
1257 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1259 const SCM binding
= SCM_CAR (binding_idx
);
1260 const SCM cdr_binding
= SCM_CDR (binding
);
1261 const SCM name
= SCM_CAR (binding
);
1262 ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (name
, rvariables
)),
1263 s_duplicate_binding
, name
, expr
);
1264 rvariables
= scm_cons (name
, rvariables
);
1265 rinits
= scm_cons (SCM_CAR (cdr_binding
), rinits
);
1267 *rvarptr
= rvariables
;
1268 *initptr
= scm_reverse_x (rinits
, SCM_UNDEFINED
);
1272 SCM_SYNTAX(s_let
, "let", scm_i_makbimacro
, scm_m_let
);
1273 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
1275 /* This function is a helper function for memoize_let. It transforms
1276 * (let name ((var init) ...) body ...) into
1277 * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
1278 * and memoizes the expression. It is assumed that the caller has checked
1279 * that name is a symbol and that there are bindings and a body. */
1281 memoize_named_let (const SCM expr
, const SCM env SCM_UNUSED
)
1287 const SCM cdr_expr
= SCM_CDR (expr
);
1288 const SCM name
= SCM_CAR (cdr_expr
);
1289 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1290 const SCM bindings
= SCM_CAR (cddr_expr
);
1291 check_bindings (bindings
, expr
);
1293 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1294 variables
= scm_reverse_x (rvariables
, SCM_UNDEFINED
);
1297 const SCM let_body
= SCM_CDR (cddr_expr
);
1298 const SCM lambda_body
= m_body (SCM_IM_LET
, let_body
);
1299 const SCM lambda_tail
= scm_cons (variables
, lambda_body
);
1300 const SCM lambda_form
= scm_cons_source (expr
, scm_sym_lambda
, lambda_tail
);
1302 const SCM rvar
= scm_list_1 (name
);
1303 const SCM init
= scm_list_1 (lambda_form
);
1304 const SCM body
= m_body (SCM_IM_LET
, scm_list_1 (name
));
1305 const SCM letrec_tail
= scm_cons (rvar
, scm_cons (init
, body
));
1306 const SCM letrec_form
= scm_cons_source (expr
, SCM_IM_LETREC
, letrec_tail
);
1307 return scm_cons_source (expr
, letrec_form
, inits
);
1311 /* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1312 * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
1314 scm_m_let (SCM expr
, SCM env
)
1318 const SCM cdr_expr
= SCM_CDR (expr
);
1319 const long length
= scm_ilength (cdr_expr
);
1320 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1321 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1323 bindings
= SCM_CAR (cdr_expr
);
1324 if (SCM_SYMBOLP (bindings
))
1326 ASSERT_SYNTAX (length
>= 3, s_missing_expression
, expr
);
1327 return memoize_named_let (expr
, env
);
1330 check_bindings (bindings
, expr
);
1331 if (SCM_NULLP (bindings
) || SCM_NULLP (SCM_CDR (bindings
)))
1333 /* Special case: no bindings or single binding => let* is faster. */
1334 const SCM body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1335 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), bindings
, body
), env
);
1342 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1345 const SCM new_body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1346 const SCM new_tail
= scm_cons2 (rvariables
, inits
, new_body
);
1347 SCM_SETCAR (expr
, SCM_IM_LET
);
1348 SCM_SETCDR (expr
, new_tail
);
1355 SCM_SYNTAX (s_letstar
, "let*", scm_i_makbimacro
, scm_m_letstar
);
1356 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
1358 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1359 * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
1361 scm_m_letstar (SCM expr
, SCM env SCM_UNUSED
)
1366 const SCM cdr_expr
= SCM_CDR (expr
);
1367 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1368 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1370 binding_idx
= SCM_CAR (cdr_expr
);
1371 check_bindings (binding_idx
, expr
);
1373 /* Transform ((v1 i1) (v2 i2) ...) into (v1 i1 v2 i2 ...). The
1374 * transformation is done in place. At the beginning of one iteration of
1375 * the loop the variable binding_idx holds the form
1376 * P1:( (vn . P2:(in . ())) . P3:( (vn+1 in+1) ... ) ),
1377 * where P1, P2 and P3 indicate the pairs, that are relevant for the
1378 * transformation. P1 and P2 are modified in the loop, P3 remains
1379 * untouched. After the execution of the loop, P1 will hold
1380 * P1:( vn . P2:(in . P3:( (vn+1 in+1) ... )) )
1381 * and binding_idx will hold P3. */
1382 while (!SCM_NULLP (binding_idx
))
1384 const SCM cdr_binding_idx
= SCM_CDR (binding_idx
); /* remember P3 */
1385 const SCM binding
= SCM_CAR (binding_idx
);
1386 const SCM name
= SCM_CAR (binding
);
1387 const SCM cdr_binding
= SCM_CDR (binding
);
1389 SCM_SETCDR (cdr_binding
, cdr_binding_idx
); /* update P2 */
1390 SCM_SETCAR (binding_idx
, name
); /* update P1 */
1391 SCM_SETCDR (binding_idx
, cdr_binding
); /* update P1 */
1393 binding_idx
= cdr_binding_idx
; /* continue with P3 */
1396 new_body
= m_body (SCM_IM_LETSTAR
, SCM_CDR (cdr_expr
));
1397 SCM_SETCAR (expr
, SCM_IM_LETSTAR
);
1398 /* the bindings have been changed in place */
1399 SCM_SETCDR (cdr_expr
, new_body
);
1404 SCM_SYNTAX(s_letrec
, "letrec", scm_i_makbimacro
, scm_m_letrec
);
1405 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
1408 scm_m_letrec (SCM expr
, SCM env
)
1412 const SCM cdr_expr
= SCM_CDR (expr
);
1413 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1414 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1416 bindings
= SCM_CAR (cdr_expr
);
1417 if (SCM_NULLP (bindings
))
1419 /* no bindings, let* is executed faster */
1420 SCM body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1421 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), SCM_EOL
, body
), env
);
1429 check_bindings (bindings
, expr
);
1430 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1431 new_body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1432 return scm_cons2 (SCM_IM_LETREC
, rvariables
, scm_cons (inits
, new_body
));
1437 SCM_SYNTAX (s_or
, "or", scm_i_makbimacro
, scm_m_or
);
1438 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
1441 scm_m_or (SCM expr
, SCM env SCM_UNUSED
)
1443 const SCM cdr_expr
= SCM_CDR (expr
);
1444 const long length
= scm_ilength (cdr_expr
);
1446 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1450 /* Special case: (or) is replaced by #f. */
1455 SCM_SETCAR (expr
, SCM_IM_OR
);
1461 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
1462 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
1463 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
1464 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
1466 /* Internal function to handle a quasiquotation: 'form' is the parameter in
1467 * the call (quasiquotation form), 'env' is the environment where unquoted
1468 * expressions will be evaluated, and 'depth' is the current quasiquotation
1469 * nesting level and is known to be greater than zero. */
1471 iqq (SCM form
, SCM env
, unsigned long int depth
)
1473 if (SCM_CONSP (form
))
1475 const SCM tmp
= SCM_CAR (form
);
1476 if (SCM_EQ_P (tmp
, scm_sym_quasiquote
))
1478 const SCM args
= SCM_CDR (form
);
1479 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1480 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
1482 else if (SCM_EQ_P (tmp
, scm_sym_unquote
))
1484 const SCM args
= SCM_CDR (form
);
1485 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1487 return scm_eval_car (args
, env
);
1489 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
1491 else if (SCM_CONSP (tmp
)
1492 && SCM_EQ_P (SCM_CAR (tmp
), scm_sym_uq_splicing
))
1494 const SCM args
= SCM_CDR (tmp
);
1495 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1498 const SCM list
= scm_eval_car (args
, env
);
1499 const SCM rest
= SCM_CDR (form
);
1500 ASSERT_SYNTAX_2 (scm_ilength (list
) >= 0,
1501 s_splicing
, list
, form
);
1502 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
1505 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
1506 iqq (SCM_CDR (form
), env
, depth
));
1509 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
1510 iqq (SCM_CDR (form
), env
, depth
));
1512 else if (SCM_VECTORP (form
))
1514 size_t i
= SCM_VECTOR_LENGTH (form
);
1515 SCM
const *const data
= SCM_VELTS (form
);
1518 tmp
= scm_cons (data
[--i
], tmp
);
1519 scm_remember_upto_here_1 (form
);
1520 return scm_vector (iqq (tmp
, env
, depth
));
1527 scm_m_quasiquote (SCM expr
, SCM env
)
1529 const SCM cdr_expr
= SCM_CDR (expr
);
1530 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1531 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1532 return iqq (SCM_CAR (cdr_expr
), env
, 1);
1536 SCM_SYNTAX (s_quote
, "quote", scm_i_makbimacro
, scm_m_quote
);
1537 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
1540 scm_m_quote (SCM expr
, SCM env SCM_UNUSED
)
1544 const SCM cdr_expr
= SCM_CDR (expr
);
1545 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1546 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1547 quotee
= SCM_CAR (cdr_expr
);
1548 if (is_self_quoting_p (quotee
))
1551 SCM_SETCAR (expr
, SCM_IM_QUOTE
);
1552 SCM_SETCDR (expr
, quotee
);
1557 unmemoize_quote (const SCM expr
, const SCM env SCM_UNUSED
)
1559 return scm_list_2 (scm_sym_quote
, SCM_CDR (expr
));
1563 /* Will go into the RnRS module when Guile is factorized.
1564 SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
1565 static const char s_set_x
[] = "set!";
1566 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, s_set_x
);
1569 scm_m_set_x (SCM expr
, SCM env SCM_UNUSED
)
1574 const SCM cdr_expr
= SCM_CDR (expr
);
1575 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1576 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1577 variable
= SCM_CAR (cdr_expr
);
1579 /* Memoize the variable form. */
1580 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
), s_bad_variable
, variable
, expr
);
1581 new_variable
= lookup_symbol (variable
, env
);
1582 /* Leave the memoization of unbound symbols to lazy memoization: */
1583 if (SCM_UNBNDP (new_variable
))
1584 new_variable
= variable
;
1586 SCM_SETCAR (expr
, SCM_IM_SET_X
);
1587 SCM_SETCAR (cdr_expr
, new_variable
);
1592 /* Start of the memoizers for non-R5RS builtin macros. */
1595 SCM_SYNTAX (s_atapply
, "@apply", scm_i_makbimacro
, scm_m_apply
);
1596 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1597 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1600 scm_m_apply (SCM expr
, SCM env SCM_UNUSED
)
1602 const SCM cdr_expr
= SCM_CDR (expr
);
1603 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1604 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_missing_expression
, expr
);
1606 SCM_SETCAR (expr
, SCM_IM_APPLY
);
1611 SCM_SYNTAX (s_atbind
, "@bind", scm_i_makbimacro
, scm_m_atbind
);
1613 /* FIXME: The following explanation should go into the documentation: */
1614 /* (@bind ((var init) ...) body ...) will assign the values of the `init's to
1615 * the global variables named by `var's (symbols, not evaluated), creating
1616 * them if they don't exist, executes body, and then restores the previous
1617 * values of the `var's. Additionally, whenever control leaves body, the
1618 * values of the `var's are saved and restored when control returns. It is an
1619 * error when a symbol appears more than once among the `var's. All `init's
1620 * are evaluated before any `var' is set.
1622 * Think of this as `let' for dynamic scope.
1625 /* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into
1626 * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...).
1628 * FIXME - also implement `@bind*'.
1631 scm_m_atbind (SCM expr
, SCM env
)
1638 const SCM top_level
= scm_env_top_level (env
);
1640 const SCM cdr_expr
= SCM_CDR (expr
);
1641 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1642 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1643 bindings
= SCM_CAR (cdr_expr
);
1644 check_bindings (bindings
, expr
);
1645 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1647 for (variable_idx
= rvariables
;
1648 !SCM_NULLP (variable_idx
);
1649 variable_idx
= SCM_CDR (variable_idx
))
1651 /* The first call to scm_sym2var will look beyond the current module,
1652 * while the second call wont. */
1653 const SCM variable
= SCM_CAR (variable_idx
);
1654 SCM new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_F
);
1655 if (SCM_FALSEP (new_variable
))
1656 new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_T
);
1657 SCM_SETCAR (variable_idx
, new_variable
);
1660 SCM_SETCAR (expr
, SCM_IM_BIND
);
1661 SCM_SETCAR (cdr_expr
, scm_cons (rvariables
, inits
));
1666 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_i_makbimacro
, scm_m_cont
);
1667 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, s_atcall_cc
);
1670 scm_m_cont (SCM expr
, SCM env SCM_UNUSED
)
1672 const SCM cdr_expr
= SCM_CDR (expr
);
1673 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1674 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1676 SCM_SETCAR (expr
, SCM_IM_CONT
);
1681 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_i_makbimacro
, scm_m_at_call_with_values
);
1682 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
1685 scm_m_at_call_with_values (SCM expr
, SCM env SCM_UNUSED
)
1687 const SCM cdr_expr
= SCM_CDR (expr
);
1688 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1689 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1691 SCM_SETCAR (expr
, SCM_IM_CALL_WITH_VALUES
);
1696 SCM_SYNTAX (s_future
, "future", scm_i_makbimacro
, scm_m_future
);
1697 SCM_GLOBAL_SYMBOL (scm_sym_future
, s_future
);
1699 /* Like promises, futures are implemented as closures with an empty
1700 * parameter list. Thus, (future <expression>) is transformed into
1701 * (#@future '() <expression>), where the empty list represents the
1702 * empty parameter list. This representation allows for easy creation
1703 * of the closure during evaluation. */
1705 scm_m_future (SCM expr
, SCM env
)
1707 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1708 SCM_SETCAR (new_expr
, SCM_IM_FUTURE
);
1713 SCM_SYNTAX (s_gset_x
, "set!", scm_i_makbimacro
, scm_m_generalized_set_x
);
1714 SCM_SYMBOL (scm_sym_setter
, "setter");
1717 scm_m_generalized_set_x (SCM expr
, SCM env
)
1719 SCM target
, exp_target
;
1721 const SCM cdr_expr
= SCM_CDR (expr
);
1722 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1723 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1725 target
= SCM_CAR (cdr_expr
);
1726 if (!SCM_CONSP (target
))
1729 return scm_m_set_x (expr
, env
);
1733 /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */
1734 /* Macroexpanding the target might return things of the form
1735 (begin <atom>). In that case, <atom> must be a symbol or a
1736 variable and we memoize to (set! <atom> ...).
1738 exp_target
= scm_macroexp (target
, env
);
1739 if (SCM_EQ_P (SCM_CAR (exp_target
), SCM_IM_BEGIN
)
1740 && !SCM_NULLP (SCM_CDR (exp_target
))
1741 && SCM_NULLP (SCM_CDDR (exp_target
)))
1743 exp_target
= SCM_CADR (exp_target
);
1744 ASSERT_SYNTAX_2 (SCM_SYMBOLP (exp_target
)
1745 || SCM_VARIABLEP (exp_target
),
1746 s_bad_variable
, exp_target
, expr
);
1747 return scm_cons (SCM_IM_SET_X
, scm_cons (exp_target
,
1748 SCM_CDR (cdr_expr
)));
1752 const SCM setter_proc_tail
= scm_list_1 (SCM_CAR (target
));
1753 const SCM setter_proc
= scm_cons_source (expr
, scm_sym_setter
,
1756 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1757 const SCM setter_args
= scm_append_x (scm_list_2 (SCM_CDR (target
),
1760 SCM_SETCAR (expr
, setter_proc
);
1761 SCM_SETCDR (expr
, setter_args
);
1768 /* @slot-ref is bound privately in the (oop goops) module from goops.c. As
1769 * soon as the module system allows us to more freely create bindings in
1770 * arbitrary modules during the startup phase, the code from goops.c should be
1773 scm_m_atslot_ref (SCM expr
, SCM env SCM_UNUSED
)
1777 const SCM cdr_expr
= SCM_CDR (expr
);
1778 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1779 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1780 slot_nr
= SCM_CADR (cdr_expr
);
1781 ASSERT_SYNTAX_2 (SCM_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
1783 SCM_SETCAR (expr
, SCM_IM_SLOT_REF
);
1784 SCM_SETCDR (cdr_expr
, slot_nr
);
1789 /* @slot-set! is bound privately in the (oop goops) module from goops.c. As
1790 * soon as the module system allows us to more freely create bindings in
1791 * arbitrary modules during the startup phase, the code from goops.c should be
1794 scm_m_atslot_set_x (SCM expr
, SCM env SCM_UNUSED
)
1798 const SCM cdr_expr
= SCM_CDR (expr
);
1799 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1800 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 3, s_expression
, expr
);
1801 slot_nr
= SCM_CADR (cdr_expr
);
1802 ASSERT_SYNTAX_2 (SCM_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
1804 SCM_SETCAR (expr
, SCM_IM_SLOT_SET_X
);
1809 #if SCM_ENABLE_ELISP
1811 static const char s_defun
[] = "Symbol's function definition is void";
1813 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_i_makbimacro
, scm_m_nil_cond
);
1815 /* nil-cond expressions have the form
1816 * (nil-cond COND VAL COND VAL ... ELSEVAL) */
1818 scm_m_nil_cond (SCM expr
, SCM env SCM_UNUSED
)
1820 const long length
= scm_ilength (SCM_CDR (expr
));
1821 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1822 ASSERT_SYNTAX (length
>= 1 && (length
% 2) == 1, s_expression
, expr
);
1824 SCM_SETCAR (expr
, SCM_IM_NIL_COND
);
1829 SCM_SYNTAX (s_atfop
, "@fop", scm_i_makbimacro
, scm_m_atfop
);
1831 /* The @fop-macro handles procedure and macro applications for elisp. The
1832 * input expression must have the form
1833 * (@fop <var> (transformer-macro <expr> ...))
1834 * where <var> must be a symbol. The expression is transformed into the
1835 * memoized form of either
1836 * (apply <un-aliased var> (transformer-macro <expr> ...))
1837 * if the value of var (across all aliasing) is not a macro, or
1838 * (<un-aliased var> <expr> ...)
1839 * if var is a macro. */
1841 scm_m_atfop (SCM expr
, SCM env SCM_UNUSED
)
1846 const SCM cdr_expr
= SCM_CDR (expr
);
1847 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1848 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 1, s_missing_expression
, expr
);
1850 symbol
= SCM_CAR (cdr_expr
);
1851 ASSERT_SYNTAX_2 (SCM_SYMBOLP (symbol
), s_bad_variable
, symbol
, expr
);
1853 location
= scm_symbol_fref (symbol
);
1854 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
1856 /* The elisp function `defalias' allows to define aliases for symbols. To
1857 * look up such definitions, the chain of symbol definitions has to be
1858 * followed up to the terminal symbol. */
1859 while (SCM_SYMBOLP (SCM_VARIABLE_REF (location
)))
1861 const SCM alias
= SCM_VARIABLE_REF (location
);
1862 location
= scm_symbol_fref (alias
);
1863 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
1866 /* Memoize the value location belonging to the terminal symbol. */
1867 SCM_SETCAR (cdr_expr
, location
);
1869 if (!SCM_MACROP (SCM_VARIABLE_REF (location
)))
1871 /* Since the location does not contain a macro, the form is a procedure
1872 * application. Replace `@fop' by `@apply' and transform the expression
1873 * including the `transformer-macro'. */
1874 SCM_SETCAR (expr
, SCM_IM_APPLY
);
1879 /* Since the location contains a macro, the arguments should not be
1880 * transformed, so the `transformer-macro' is cut out. The resulting
1881 * expression starts with the memoized variable, that is at the cdr of
1882 * the input expression. */
1883 SCM_SETCDR (cdr_expr
, SCM_CDADR (cdr_expr
));
1888 #endif /* SCM_ENABLE_ELISP */
1891 #if (SCM_ENABLE_DEPRECATED == 1)
1893 /* Deprecated in guile 1.7.0 on 2003-11-09. */
1895 scm_m_expand_body (SCM exprs
, SCM env
)
1897 scm_c_issue_deprecation_warning
1898 ("`scm_m_expand_body' is deprecated.");
1899 m_expand_body (exprs
, env
);
1904 SCM_SYNTAX (s_undefine
, "undefine", scm_makacro
, scm_m_undefine
);
1907 scm_m_undefine (SCM expr
, SCM env
)
1912 const SCM cdr_expr
= SCM_CDR (expr
);
1913 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), "Bad undefine placement in", expr
);
1914 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1915 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1917 variable
= SCM_CAR (cdr_expr
);
1918 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
), s_bad_variable
, variable
, expr
);
1919 location
= scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_F
);
1920 ASSERT_SYNTAX_2 (!SCM_FALSEP (location
)
1921 && !SCM_UNBNDP (SCM_VARIABLE_REF (location
)),
1922 "variable already unbound ", variable
, expr
);
1923 SCM_VARIABLE_SET (location
, SCM_UNDEFINED
);
1924 return SCM_UNSPECIFIED
;
1929 scm_macroexp (SCM x
, SCM env
)
1931 SCM res
, proc
, orig_sym
;
1933 /* Don't bother to produce error messages here. We get them when we
1934 eventually execute the code for real. */
1937 orig_sym
= SCM_CAR (x
);
1938 if (!SCM_SYMBOLP (orig_sym
))
1942 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1943 if (proc_ptr
== NULL
)
1945 /* We have lost the race. */
1951 /* Only handle memoizing macros. `Acros' and `macros' are really
1952 special forms and should not be evaluated here. */
1954 if (!SCM_MACROP (proc
)
1955 || (SCM_MACRO_TYPE (proc
) != 2 && !SCM_BUILTIN_MACRO_P (proc
)))
1958 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
1959 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
1961 if (scm_ilength (res
) <= 0)
1962 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
1965 SCM_SETCAR (x
, SCM_CAR (res
));
1966 SCM_SETCDR (x
, SCM_CDR (res
));
1974 /*****************************************************************************/
1975 /*****************************************************************************/
1976 /* The definitions for unmemoization start here. */
1977 /*****************************************************************************/
1978 /*****************************************************************************/
1980 #define SCM_BIT7(x) (127 & SCM_UNPACK (x))
1982 SCM_SYMBOL (sym_three_question_marks
, "???");
1985 /* scm_unmemocopy takes a memoized expression together with its
1986 * environment and rewrites it to its original form. Thus, it is the
1987 * inversion of the rewrite rules above. The procedure is not
1988 * optimized for speed. It's used in scm_iprin1 when printing the
1989 * code of a closure, in scm_procedure_source, in display_frame when
1990 * generating the source for a stackframe in a backtrace, and in
1991 * display_expression.
1993 * Unmemoizing is not a reliable process. You cannot in general
1994 * expect to get the original source back.
1996 * However, GOOPS currently relies on this for method compilation.
1997 * This ought to change.
2001 build_binding_list (SCM rnames
, SCM rinits
)
2003 SCM bindings
= SCM_EOL
;
2004 while (!SCM_NULLP (rnames
))
2006 SCM binding
= scm_list_2 (SCM_CAR (rnames
), SCM_CAR (rinits
));
2007 bindings
= scm_cons (binding
, bindings
);
2008 rnames
= SCM_CDR (rnames
);
2009 rinits
= SCM_CDR (rinits
);
2016 unmemocar (SCM form
, SCM env
)
2018 if (!SCM_CONSP (form
))
2022 SCM c
= SCM_CAR (form
);
2023 if (SCM_VARIABLEP (c
))
2025 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
2026 if (SCM_FALSEP (sym
))
2027 sym
= sym_three_question_marks
;
2028 SCM_SETCAR (form
, sym
);
2030 else if (SCM_ILOCP (c
))
2032 unsigned long int ir
;
2034 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
2035 env
= SCM_CDR (env
);
2036 env
= SCM_CAAR (env
);
2037 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
2038 env
= SCM_CDR (env
);
2040 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
2048 scm_unmemocopy (SCM x
, SCM env
)
2053 if (SCM_VECTORP (x
))
2055 return scm_list_2 (scm_sym_quote
, x
);
2057 else if (!SCM_CONSP (x
))
2060 p
= scm_whash_lookup (scm_source_whash
, x
);
2061 if (SCM_ISYMP (SCM_CAR (x
)))
2063 switch (ISYMNUM (SCM_CAR (x
)))
2065 case (ISYMNUM (SCM_IM_AND
)):
2066 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
2068 case (ISYMNUM (SCM_IM_BEGIN
)):
2069 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
2071 case (ISYMNUM (SCM_IM_CASE
)):
2072 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
2074 case (ISYMNUM (SCM_IM_COND
)):
2075 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
2077 case (ISYMNUM (SCM_IM_DO
)):
2079 /* format: (#@do (i1 ... ik) (nk ... n1) (test) (body) s1 ... sk),
2080 * where ix is an initializer for a local variable, nx is the name
2081 * of the local variable, test is the test clause of the do loop,
2082 * body is the body of the do loop and sx are the step clauses for
2083 * the local variables. */
2084 SCM names
, inits
, test
, memoized_body
, steps
, bindings
;
2087 inits
= scm_reverse (scm_unmemocopy (SCM_CAR (x
), env
));
2089 names
= SCM_CAR (x
);
2090 env
= SCM_EXTEND_ENV (names
, SCM_EOL
, env
);
2092 test
= scm_unmemocopy (SCM_CAR (x
), env
);
2094 memoized_body
= SCM_CAR (x
);
2096 steps
= scm_reverse (scm_unmemocopy (x
, env
));
2098 /* build transformed binding list */
2100 while (!SCM_NULLP (names
))
2102 SCM name
= SCM_CAR (names
);
2103 SCM init
= SCM_CAR (inits
);
2104 SCM step
= SCM_CAR (steps
);
2105 step
= SCM_EQ_P (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
2107 bindings
= scm_cons (scm_cons2 (name
, init
, step
), bindings
);
2109 names
= SCM_CDR (names
);
2110 inits
= SCM_CDR (inits
);
2111 steps
= SCM_CDR (steps
);
2113 z
= scm_cons (test
, SCM_UNSPECIFIED
);
2114 ls
= scm_cons2 (scm_sym_do
, bindings
, z
);
2116 x
= scm_cons (SCM_BOOL_F
, memoized_body
);
2119 case (ISYMNUM (SCM_IM_IF
)):
2120 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
2122 case (ISYMNUM (SCM_IM_LET
)):
2124 /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),
2125 * where nx is the name of a local variable, ix is an initializer
2126 * for the local variable and by are the body clauses. */
2127 SCM rnames
, rinits
, bindings
;
2130 rnames
= SCM_CAR (x
);
2132 rinits
= scm_reverse (scm_unmemocopy (SCM_CAR (x
), env
));
2133 env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
2135 bindings
= build_binding_list (rnames
, rinits
);
2136 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
2137 ls
= scm_cons (scm_sym_let
, z
);
2140 case (ISYMNUM (SCM_IM_LETREC
)):
2142 /* format: (#@letrec (vn ... v2 v1) (i1 i2 ... in) b1 ...),
2143 * where vx is the name of a local variable, ix is an initializer
2144 * for the local variable and by are the body clauses. */
2145 SCM rnames
, rinits
, bindings
;
2148 rnames
= SCM_CAR (x
);
2149 env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
2151 rinits
= scm_reverse (scm_unmemocopy (SCM_CAR (x
), env
));
2153 bindings
= build_binding_list (rnames
, rinits
);
2154 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
2155 ls
= scm_cons (scm_sym_letrec
, z
);
2158 case (ISYMNUM (SCM_IM_LETSTAR
)):
2166 env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2170 SCM copy
= scm_unmemocopy (SCM_CADR (b
), env
);
2171 SCM initializer
= unmemocar (scm_list_1 (copy
), env
);
2172 y
= z
= scm_acons (SCM_CAR (b
), initializer
, SCM_UNSPECIFIED
);
2173 env
= SCM_EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
2177 SCM_SETCDR (y
, SCM_EOL
);
2178 z
= scm_cons (y
, SCM_UNSPECIFIED
);
2179 ls
= scm_cons (scm_sym_let
, z
);
2184 copy
= scm_unmemocopy (SCM_CADR (b
), env
);
2185 initializer
= unmemocar (scm_list_1 (copy
), env
);
2186 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
2190 env
= SCM_EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
2193 while (!SCM_NULLP (b
));
2194 SCM_SETCDR (z
, SCM_EOL
);
2196 z
= scm_cons (y
, SCM_UNSPECIFIED
);
2197 ls
= scm_cons (scm_sym_letstar
, z
);
2200 case (ISYMNUM (SCM_IM_OR
)):
2201 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
2203 case (ISYMNUM (SCM_IM_LAMBDA
)):
2205 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
);
2206 ls
= scm_cons (scm_sym_lambda
, z
);
2207 env
= SCM_EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
2210 case (ISYMNUM (SCM_IM_QUOTE
)):
2211 return unmemoize_quote (x
, env
);
2213 case (ISYMNUM (SCM_IM_SET_X
)):
2214 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
2216 case (ISYMNUM (SCM_IM_APPLY
)):
2217 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
2219 case (ISYMNUM (SCM_IM_CONT
)):
2220 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
2222 case (ISYMNUM (SCM_IM_DELAY
)):
2223 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
2226 case (ISYMNUM (SCM_IM_FUTURE
)):
2227 ls
= z
= scm_cons (scm_sym_future
, SCM_UNSPECIFIED
);
2230 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2231 ls
= z
= scm_cons (scm_sym_at_call_with_values
, SCM_UNSPECIFIED
);
2233 case (ISYMNUM (SCM_IM_ELSE
)):
2234 ls
= z
= scm_cons (scm_sym_else
, SCM_UNSPECIFIED
);
2237 ls
= z
= unmemocar (scm_cons (scm_unmemocopy (SCM_CAR (x
), env
),
2244 ls
= z
= unmemocar (scm_cons (scm_unmemocopy (SCM_CAR (x
), env
),
2250 while (SCM_CONSP (x
))
2252 SCM form
= SCM_CAR (x
);
2253 if (!SCM_ISYMP (form
))
2255 SCM copy
= scm_cons (scm_unmemocopy (form
, env
), SCM_UNSPECIFIED
);
2256 SCM_SETCDR (z
, unmemocar (copy
, env
));
2259 else if (SCM_EQ_P (form
, SCM_IM_ARROW
))
2261 SCM_SETCDR (z
, scm_cons (scm_sym_arrow
, SCM_UNSPECIFIED
));
2267 if (!SCM_FALSEP (p
))
2268 scm_whash_insert (scm_source_whash
, ls
, p
);
2273 #if (SCM_ENABLE_DEPRECATED == 1)
2276 scm_unmemocar (SCM form
, SCM env
)
2278 return unmemocar (form
, env
);
2283 /*****************************************************************************/
2284 /*****************************************************************************/
2285 /* The definitions for execution start here. */
2286 /*****************************************************************************/
2287 /*****************************************************************************/
2289 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
2290 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
2291 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
2292 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
2294 /* A function object to implement "apply" for non-closure functions. */
2296 /* An endless list consisting of #<undefined> objects: */
2297 static SCM undefineds
;
2301 scm_badargsp (SCM formals
, SCM args
)
2303 while (!SCM_NULLP (formals
))
2305 if (!SCM_CONSP (formals
))
2307 if (SCM_NULLP (args
))
2309 formals
= SCM_CDR (formals
);
2310 args
= SCM_CDR (args
);
2312 return !SCM_NULLP (args
) ? 1 : 0;
2317 /* The evaluator contains a plethora of EVAL symbols. This is an attempt at
2320 * The following macros should be used in code which is read twice (where the
2321 * choice of evaluator is hard soldered):
2323 * CEVAL is the symbol used within one evaluator to call itself.
2324 * Originally, it is defined to ceval, but is redefined to deval during the
2327 * SCM_EVALIM is used when it is known that the expression is an
2328 * immediate. (This macro never calls an evaluator.)
2330 * EVAL evaluates an expression that is expected to have its symbols already
2331 * memoized. Expressions that are not of the form '(<form> <form> ...)' are
2332 * evaluated inline without calling an evaluator.
2334 * EVALCAR evaluates the car of an expression 'X:(Y:<form> <form> ...)',
2335 * potentially replacing a symbol at the position Y:<form> by its memoized
2336 * variable. If Y:<form> is not of the form '(<form> <form> ...)', the
2337 * evaluation is performed inline without calling an evaluator.
2339 * The following macros should be used in code which is read once
2340 * (where the choice of evaluator is dynamic):
2342 * SCM_XEVAL corresponds to EVAL, but uses ceval *or* deval depending on the
2345 * SCM_XEVALCAR corresponds to EVALCAR, but uses ceval *or* deval depending
2346 * on the debugging mode.
2348 * The main motivation for keeping this plethora is efficiency
2349 * together with maintainability (=> locality of code).
2352 static SCM
ceval (SCM x
, SCM env
);
2353 static SCM
deval (SCM x
, SCM env
);
2357 #define SCM_EVALIM2(x) \
2358 ((SCM_EQ_P ((x), SCM_EOL) \
2359 ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \
2363 #define SCM_EVALIM(x, env) (SCM_ILOCP (x) \
2364 ? *scm_ilookup ((x), (env)) \
2367 #define SCM_XEVAL(x, env) \
2370 : (SCM_VARIABLEP (x) \
2371 ? SCM_VARIABLE_REF (x) \
2373 ? (scm_debug_mode_p \
2374 ? deval ((x), (env)) \
2375 : ceval ((x), (env))) \
2378 #define SCM_XEVALCAR(x, env) \
2379 (SCM_IMP (SCM_CAR (x)) \
2380 ? SCM_EVALIM (SCM_CAR (x), (env)) \
2381 : (SCM_VARIABLEP (SCM_CAR (x)) \
2382 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2383 : (SCM_CONSP (SCM_CAR (x)) \
2384 ? (scm_debug_mode_p \
2385 ? deval (SCM_CAR (x), (env)) \
2386 : ceval (SCM_CAR (x), (env))) \
2387 : (!SCM_SYMBOLP (SCM_CAR (x)) \
2389 : *scm_lookupcar ((x), (env), 1)))))
2391 #define EVAL(x, env) \
2393 ? SCM_EVALIM ((x), (env)) \
2394 : (SCM_VARIABLEP (x) \
2395 ? SCM_VARIABLE_REF (x) \
2397 ? CEVAL ((x), (env)) \
2400 #define EVALCAR(x, env) \
2401 (SCM_IMP (SCM_CAR (x)) \
2402 ? SCM_EVALIM (SCM_CAR (x), (env)) \
2403 : (SCM_VARIABLEP (SCM_CAR (x)) \
2404 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2405 : (SCM_CONSP (SCM_CAR (x)) \
2406 ? CEVAL (SCM_CAR (x), (env)) \
2407 : (!SCM_SYMBOLP (SCM_CAR (x)) \
2409 : *scm_lookupcar ((x), (env), 1)))))
2411 SCM_REC_MUTEX (source_mutex
);
2414 /* Lookup a given local variable in an environment. The local variable is
2415 * given as an iloc, that is a triple <frame, binding, last?>, where frame
2416 * indicates the relative number of the environment frame (counting upwards
2417 * from the innermost environment frame), binding indicates the number of the
2418 * binding within the frame, and last? (which is extracted from the iloc using
2419 * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
2420 * very end of the improper list of bindings. */
2422 scm_ilookup (SCM iloc
, SCM env
)
2424 unsigned int frame_nr
= SCM_IFRAME (iloc
);
2425 unsigned int binding_nr
= SCM_IDIST (iloc
);
2429 for (; 0 != frame_nr
; --frame_nr
)
2430 frames
= SCM_CDR (frames
);
2432 bindings
= SCM_CAR (frames
);
2433 for (; 0 != binding_nr
; --binding_nr
)
2434 bindings
= SCM_CDR (bindings
);
2436 if (SCM_ICDRP (iloc
))
2437 return SCM_CDRLOC (bindings
);
2438 return SCM_CARLOC (SCM_CDR (bindings
));
2442 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
2444 static void error_unbound_variable (SCM symbol
) SCM_NORETURN
;
2446 error_unbound_variable (SCM symbol
)
2448 scm_error (scm_unbound_variable_key
, NULL
,
2449 "Unbound variable: ~S",
2450 scm_list_1 (symbol
), SCM_BOOL_F
);
2454 /* The Lookup Car Race
2457 Memoization of variables and special forms is done while executing
2458 the code for the first time. As long as there is only one thread
2459 everything is fine, but as soon as two threads execute the same
2460 code concurrently `for the first time' they can come into conflict.
2462 This memoization includes rewriting variable references into more
2463 efficient forms and expanding macros. Furthermore, macro expansion
2464 includes `compiling' special forms like `let', `cond', etc. into
2465 tree-code instructions.
2467 There shouldn't normally be a problem with memoizing local and
2468 global variable references (into ilocs and variables), because all
2469 threads will mutate the code in *exactly* the same way and (if I
2470 read the C code correctly) it is not possible to observe a half-way
2471 mutated cons cell. The lookup procedure can handle this
2472 transparently without any critical sections.
2474 It is different with macro expansion, because macro expansion
2475 happens outside of the lookup procedure and can't be
2476 undone. Therefore the lookup procedure can't cope with it. It has
2477 to indicate failure when it detects a lost race and hope that the
2478 caller can handle it. Luckily, it turns out that this is the case.
2480 An example to illustrate this: Suppose that the following form will
2481 be memoized concurrently by two threads
2485 Let's first examine the lookup of X in the body. The first thread
2486 decides that it has to find the symbol "x" in the environment and
2487 starts to scan it. Then the other thread takes over and actually
2488 overtakes the first. It looks up "x" and substitutes an
2489 appropriate iloc for it. Now the first thread continues and
2490 completes its lookup. It comes to exactly the same conclusions as
2491 the second one and could - without much ado - just overwrite the
2492 iloc with the same iloc.
2494 But let's see what will happen when the race occurs while looking
2495 up the symbol "let" at the start of the form. It could happen that
2496 the second thread interrupts the lookup of the first thread and not
2497 only substitutes a variable for it but goes right ahead and
2498 replaces it with the compiled form (#@let* (x 12) x). Now, when
2499 the first thread completes its lookup, it would replace the #@let*
2500 with a variable containing the "let" binding, effectively reverting
2501 the form to (let (x 12) x). This is wrong. It has to detect that
2502 it has lost the race and the evaluator has to reconsider the
2503 changed form completely.
2505 This race condition could be resolved with some kind of traffic
2506 light (like mutexes) around scm_lookupcar, but I think that it is
2507 best to avoid them in this case. They would serialize memoization
2508 completely and because lookup involves calling arbitrary Scheme
2509 code (via the lookup-thunk), threads could be blocked for an
2510 arbitrary amount of time or even deadlock. But with the current
2511 solution a lot of unnecessary work is potentially done. */
2513 /* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
2514 return NULL to indicate a failed lookup due to some race conditions
2515 between threads. This only happens when VLOC is the first cell of
2516 a special form that will eventually be memoized (like `let', etc.)
2517 In that case the whole lookup is bogus and the caller has to
2518 reconsider the complete special form.
2520 SCM_LOOKUPCAR is still there, of course. It just calls
2521 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
2522 should only be called when it is known that VLOC is not the first
2523 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
2524 for NULL. I think I've found the only places where this
2528 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
2531 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
2532 register SCM iloc
= SCM_ILOC00
;
2533 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
2535 if (!SCM_CONSP (SCM_CAR (env
)))
2537 al
= SCM_CARLOC (env
);
2538 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
2540 if (!SCM_CONSP (fl
))
2542 if (SCM_EQ_P (fl
, var
))
2544 if (! SCM_EQ_P (SCM_CAR (vloc
), var
))
2546 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
2547 return SCM_CDRLOC (*al
);
2552 al
= SCM_CDRLOC (*al
);
2553 if (SCM_EQ_P (SCM_CAR (fl
), var
))
2555 if (SCM_UNBNDP (SCM_CAR (*al
)))
2560 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
2562 SCM_SETCAR (vloc
, iloc
);
2563 return SCM_CARLOC (*al
);
2565 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
2567 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
2570 SCM top_thunk
, real_var
;
2573 top_thunk
= SCM_CAR (env
); /* env now refers to a
2574 top level env thunk */
2575 env
= SCM_CDR (env
);
2578 top_thunk
= SCM_BOOL_F
;
2579 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
2580 if (SCM_FALSEP (real_var
))
2583 if (!SCM_NULLP (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
2588 if (SCM_NULLP (env
))
2589 error_unbound_variable (var
);
2591 scm_misc_error (NULL
, "Damaged environment: ~S",
2596 /* A variable could not be found, but we shall
2597 not throw an error. */
2598 static SCM undef_object
= SCM_UNDEFINED
;
2599 return &undef_object
;
2603 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
2605 /* Some other thread has changed the very cell we are working
2606 on. In effect, it must have done our job or messed it up
2609 var
= SCM_CAR (vloc
);
2610 if (SCM_VARIABLEP (var
))
2611 return SCM_VARIABLE_LOC (var
);
2612 if (SCM_ILOCP (var
))
2613 return scm_ilookup (var
, genv
);
2614 /* We can't cope with anything else than variables and ilocs. When
2615 a special form has been memoized (i.e. `let' into `#@let') we
2616 return NULL and expect the calling function to do the right
2617 thing. For the evaluator, this means going back and redoing
2618 the dispatch on the car of the form. */
2622 SCM_SETCAR (vloc
, real_var
);
2623 return SCM_VARIABLE_LOC (real_var
);
2628 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
2630 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
2637 /* During execution, look up a symbol in the top level of the given local
2638 * environment and return the corresponding variable object. If no binding
2639 * for the symbol can be found, an 'Unbound variable' error is signalled. */
2641 lazy_memoize_variable (const SCM symbol
, const SCM environment
)
2643 const SCM top_level
= scm_env_top_level (environment
);
2644 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
2646 if (SCM_FALSEP (variable
))
2647 error_unbound_variable (symbol
);
2654 scm_eval_car (SCM pair
, SCM env
)
2656 return SCM_XEVALCAR (pair
, env
);
2661 scm_eval_args (SCM l
, SCM env
, SCM proc
)
2663 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
2664 while (SCM_CONSP (l
))
2666 res
= EVALCAR (l
, env
);
2668 *lloc
= scm_list_1 (res
);
2669 lloc
= SCM_CDRLOC (*lloc
);
2673 scm_wrong_num_args (proc
);
2679 scm_eval_body (SCM code
, SCM env
)
2684 next
= SCM_CDR (code
);
2685 while (!SCM_NULLP (next
))
2687 if (SCM_IMP (SCM_CAR (code
)))
2689 if (SCM_ISYMP (SCM_CAR (code
)))
2691 scm_rec_mutex_lock (&source_mutex
);
2692 /* check for race condition */
2693 if (SCM_ISYMP (SCM_CAR (code
)))
2694 m_expand_body (code
, env
);
2695 scm_rec_mutex_unlock (&source_mutex
);
2700 SCM_XEVAL (SCM_CAR (code
), env
);
2702 next
= SCM_CDR (code
);
2704 return SCM_XEVALCAR (code
, env
);
2710 /* SECTION: This code is specific for the debugging support. One
2711 * branch is read when DEVAL isn't defined, the other when DEVAL is
2717 #define SCM_APPLY scm_apply
2718 #define PREP_APPLY(proc, args)
2720 #define RETURN(x) do { return x; } while (0)
2721 #ifdef STACK_CHECKING
2722 #ifndef NO_CEVAL_STACK_CHECKING
2723 #define EVAL_STACK_CHECKING
2730 #define CEVAL deval /* Substitute all uses of ceval */
2733 #define SCM_APPLY scm_dapply
2736 #define PREP_APPLY(p, l) \
2737 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
2740 #define ENTER_APPLY \
2742 SCM_SET_ARGSREADY (debug);\
2743 if (scm_check_apply_p && SCM_TRAPS_P)\
2744 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
2746 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
2747 SCM_SET_TRACED_FRAME (debug); \
2749 if (SCM_CHEAPTRAPS_P)\
2751 tmp = scm_make_debugobj (&debug);\
2752 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
2757 tmp = scm_make_continuation (&first);\
2759 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
2766 #define RETURN(e) do { proc = (e); goto exit; } while (0)
2768 #ifdef STACK_CHECKING
2769 #ifndef EVAL_STACK_CHECKING
2770 #define EVAL_STACK_CHECKING
2775 /* scm_last_debug_frame contains a pointer to the last debugging information
2776 * stack frame. It is accessed very often from the debugging evaluator, so it
2777 * should probably not be indirectly addressed. Better to save and restore it
2778 * from the current root at any stack swaps.
2781 /* scm_debug_eframe_size is the number of slots available for pseudo
2782 * stack frames at each real stack frame.
2785 long scm_debug_eframe_size
;
2787 int scm_debug_mode_p
;
2788 int scm_check_entry_p
;
2789 int scm_check_apply_p
;
2790 int scm_check_exit_p
;
2792 long scm_eval_stack
;
2794 scm_t_option scm_eval_opts
[] = {
2795 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
2798 scm_t_option scm_debug_opts
[] = {
2799 { SCM_OPTION_BOOLEAN
, "cheap", 1,
2800 "*Flyweight representation of the stack at traps." },
2801 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
2802 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
2803 { SCM_OPTION_BOOLEAN
, "procnames", 1,
2804 "Record procedure names at definition." },
2805 { SCM_OPTION_BOOLEAN
, "backwards", 0,
2806 "Display backtrace in anti-chronological order." },
2807 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
2808 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
2809 { SCM_OPTION_INTEGER
, "frames", 3,
2810 "Maximum number of tail-recursive frames in backtrace." },
2811 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
2812 "Maximal number of stored backtrace frames." },
2813 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
2814 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
2815 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
2816 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
2817 { 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."}
2820 scm_t_option scm_evaluator_trap_table
[] = {
2821 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
2822 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
2823 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
2824 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
2825 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
2826 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
2827 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
2830 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
2832 "Option interface for the evaluation options. Instead of using\n"
2833 "this procedure directly, use the procedures @code{eval-enable},\n"
2834 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
2835 #define FUNC_NAME s_scm_eval_options_interface
2839 ans
= scm_options (setting
,
2843 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
2850 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
2852 "Option interface for the evaluator trap options.")
2853 #define FUNC_NAME s_scm_evaluator_traps
2857 ans
= scm_options (setting
,
2858 scm_evaluator_trap_table
,
2859 SCM_N_EVALUATOR_TRAPS
,
2861 SCM_RESET_DEBUG_MODE
;
2869 deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
2871 SCM
*results
= lloc
;
2872 while (SCM_CONSP (l
))
2874 const SCM res
= EVALCAR (l
, env
);
2876 *lloc
= scm_list_1 (res
);
2877 lloc
= SCM_CDRLOC (*lloc
);
2881 scm_wrong_num_args (proc
);
2888 /* SECTION: This code is compiled twice.
2892 /* Update the toplevel environment frame ENV so that it refers to the
2893 * current module. */
2894 #define UPDATE_TOPLEVEL_ENV(env) \
2896 SCM p = scm_current_module_lookup_closure (); \
2897 if (p != SCM_CAR (env)) \
2898 env = scm_top_level_env (p); \
2902 #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
2903 ASSERT_SYNTAX (!SCM_EQ_P ((x), SCM_EOL), s_empty_combination, x)
2906 /* This is the evaluator. Like any real monster, it has three heads:
2908 * ceval is the non-debugging evaluator, deval is the debugging version. Both
2909 * are implemented using a common code base, using the following mechanism:
2910 * CEVAL is a macro, which is either defined to ceval or deval. Thus, there
2911 * is no function CEVAL, but the code for CEVAL actually compiles to either
2912 * ceval or deval. When CEVAL is defined to ceval, it is known that the macro
2913 * DEVAL is not defined. When CEVAL is defined to deval, then the macro DEVAL
2914 * is known to be defined. Thus, in CEVAL parts for the debugging evaluator
2915 * are enclosed within #ifdef DEVAL ... #endif.
2917 * All three (ceval, deval and their common implementation CEVAL) take two
2918 * input parameters, x and env: x is a single expression to be evalutated.
2919 * env is the environment in which bindings are searched.
2921 * x is known to be a pair. Since x is a single expression, it is necessarily
2922 * in a tail position. If x is just a call to another function like in the
2923 * expression (foo exp1 exp2 ...), the realization of that call therefore
2924 * _must_not_ increase stack usage (the evaluation of exp1, exp2 etc.,
2925 * however, may do so). This is realized by making extensive use of 'goto'
2926 * statements within the evaluator: The gotos replace recursive calls to
2927 * CEVAL, thus re-using the same stack frame that CEVAL was already using.
2928 * If, however, x represents some form that requires to evaluate a sequence of
2929 * expressions like (begin exp1 exp2 ...), then recursive calls to CEVAL are
2930 * performed for all but the last expression of that sequence. */
2933 CEVAL (SCM x
, SCM env
)
2937 scm_t_debug_frame debug
;
2938 scm_t_debug_info
*debug_info_end
;
2939 debug
.prev
= scm_last_debug_frame
;
2942 * The debug.vect contains twice as much scm_t_debug_info frames as the
2943 * user has specified with (debug-set! frames <n>).
2945 * Even frames are eval frames, odd frames are apply frames.
2947 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
2948 * sizeof (scm_t_debug_info
));
2949 debug
.info
= debug
.vect
;
2950 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
2951 scm_last_debug_frame
= &debug
;
2953 #ifdef EVAL_STACK_CHECKING
2954 if (scm_stack_checking_enabled_p
&& SCM_STACK_OVERFLOW_P (&proc
))
2957 debug
.info
->e
.exp
= x
;
2958 debug
.info
->e
.env
= env
;
2960 scm_report_stack_overflow ();
2970 SCM_CLEAR_ARGSREADY (debug
);
2971 if (SCM_OVERFLOWP (debug
))
2974 * In theory, this should be the only place where it is necessary to
2975 * check for space in debug.vect since both eval frames and
2976 * available space are even.
2978 * For this to be the case, however, it is necessary that primitive
2979 * special forms which jump back to `loop', `begin' or some similar
2980 * label call PREP_APPLY.
2982 else if (++debug
.info
>= debug_info_end
)
2984 SCM_SET_OVERFLOW (debug
);
2989 debug
.info
->e
.exp
= x
;
2990 debug
.info
->e
.env
= env
;
2991 if (scm_check_entry_p
&& SCM_TRAPS_P
)
2993 if (SCM_ENTER_FRAME_P
2994 || (SCM_BREAKPOINTS_P
&& scm_c_source_property_breakpoint_p (x
)))
2997 SCM tail
= SCM_BOOL (SCM_TAILRECP (debug
));
2998 SCM_SET_TAILREC (debug
);
2999 if (SCM_CHEAPTRAPS_P
)
3000 stackrep
= scm_make_debugobj (&debug
);
3004 SCM val
= scm_make_continuation (&first
);
3014 /* This gives the possibility for the debugger to
3015 modify the source expression before evaluation. */
3020 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
3021 scm_sym_enter_frame
,
3024 scm_unmemocopy (x
, env
));
3031 if (SCM_ISYMP (SCM_CAR (x
)))
3033 switch (ISYMNUM (SCM_CAR (x
)))
3035 case (ISYMNUM (SCM_IM_AND
)):
3037 while (!SCM_NULLP (SCM_CDR (x
)))
3039 SCM test_result
= EVALCAR (x
, env
);
3040 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
3041 RETURN (SCM_BOOL_F
);
3045 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3048 case (ISYMNUM (SCM_IM_BEGIN
)):
3051 RETURN (SCM_UNSPECIFIED
);
3053 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3056 /* If we are on toplevel with a lookup closure, we need to sync
3057 with the current module. */
3058 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
3060 UPDATE_TOPLEVEL_ENV (env
);
3061 while (!SCM_NULLP (SCM_CDR (x
)))
3064 UPDATE_TOPLEVEL_ENV (env
);
3070 goto nontoplevel_begin
;
3073 while (!SCM_NULLP (SCM_CDR (x
)))
3075 const SCM form
= SCM_CAR (x
);
3078 if (SCM_ISYMP (form
))
3080 scm_rec_mutex_lock (&source_mutex
);
3081 /* check for race condition */
3082 if (SCM_ISYMP (SCM_CAR (x
)))
3083 m_expand_body (x
, env
);
3084 scm_rec_mutex_unlock (&source_mutex
);
3085 goto nontoplevel_begin
;
3088 SCM_VALIDATE_NON_EMPTY_COMBINATION (form
);
3091 (void) EVAL (form
, env
);
3097 /* scm_eval last form in list */
3098 const SCM last_form
= SCM_CAR (x
);
3100 if (SCM_CONSP (last_form
))
3102 /* This is by far the most frequent case. */
3104 goto loop
; /* tail recurse */
3106 else if (SCM_IMP (last_form
))
3107 RETURN (SCM_EVALIM (last_form
, env
));
3108 else if (SCM_VARIABLEP (last_form
))
3109 RETURN (SCM_VARIABLE_REF (last_form
));
3110 else if (SCM_SYMBOLP (last_form
))
3111 RETURN (*scm_lookupcar (x
, env
, 1));
3117 case (ISYMNUM (SCM_IM_CASE
)):
3120 const SCM key
= EVALCAR (x
, env
);
3122 while (!SCM_NULLP (x
))
3124 const SCM clause
= SCM_CAR (x
);
3125 SCM labels
= SCM_CAR (clause
);
3126 if (SCM_EQ_P (labels
, SCM_IM_ELSE
))
3128 x
= SCM_CDR (clause
);
3129 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3132 while (!SCM_NULLP (labels
))
3134 const SCM label
= SCM_CAR (labels
);
3135 if (SCM_EQ_P (label
, key
)
3136 || !SCM_FALSEP (scm_eqv_p (label
, key
)))
3138 x
= SCM_CDR (clause
);
3139 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3142 labels
= SCM_CDR (labels
);
3147 RETURN (SCM_UNSPECIFIED
);
3150 case (ISYMNUM (SCM_IM_COND
)):
3152 while (!SCM_NULLP (x
))
3154 const SCM clause
= SCM_CAR (x
);
3155 if (SCM_EQ_P (SCM_CAR (clause
), SCM_IM_ELSE
))
3157 x
= SCM_CDR (clause
);
3158 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3163 arg1
= EVALCAR (clause
, env
);
3164 if (!SCM_FALSEP (arg1
) && !SCM_NILP (arg1
))
3166 x
= SCM_CDR (clause
);
3169 else if (!SCM_EQ_P (SCM_CAR (x
), SCM_IM_ARROW
))
3171 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3177 proc
= EVALCAR (proc
, env
);
3178 PREP_APPLY (proc
, scm_list_1 (arg1
));
3186 RETURN (SCM_UNSPECIFIED
);
3189 case (ISYMNUM (SCM_IM_DO
)):
3192 /* Compute the initialization values and the initial environment. */
3193 SCM init_forms
= SCM_CAR (x
);
3194 SCM init_values
= SCM_EOL
;
3195 while (!SCM_NULLP (init_forms
))
3197 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3198 init_forms
= SCM_CDR (init_forms
);
3201 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
3205 SCM test_form
= SCM_CAR (x
);
3206 SCM body_forms
= SCM_CADR (x
);
3207 SCM step_forms
= SCM_CDDR (x
);
3209 SCM test_result
= EVALCAR (test_form
, env
);
3211 while (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
3214 /* Evaluate body forms. */
3216 for (temp_forms
= body_forms
;
3217 !SCM_NULLP (temp_forms
);
3218 temp_forms
= SCM_CDR (temp_forms
))
3220 SCM form
= SCM_CAR (temp_forms
);
3221 /* Dirk:FIXME: We only need to eval forms that may have
3222 * a side effect here. This is only true for forms that
3223 * start with a pair. All others are just constants.
3224 * Since with the current memoizer 'form' may hold a
3225 * constant, we call EVAL here to handle the constant
3226 * cases. In the long run it would make sense to have
3227 * the macro transformer of 'do' eliminate all forms
3228 * that have no sideeffect. Then instead of EVAL we
3229 * could call CEVAL directly here. */
3230 (void) EVAL (form
, env
);
3235 /* Evaluate the step expressions. */
3237 SCM step_values
= SCM_EOL
;
3238 for (temp_forms
= step_forms
;
3239 !SCM_NULLP (temp_forms
);
3240 temp_forms
= SCM_CDR (temp_forms
))
3242 const SCM value
= EVALCAR (temp_forms
, env
);
3243 step_values
= scm_cons (value
, step_values
);
3245 env
= SCM_EXTEND_ENV (SCM_CAAR (env
),
3250 test_result
= EVALCAR (test_form
, env
);
3255 RETURN (SCM_UNSPECIFIED
);
3256 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3257 goto nontoplevel_begin
;
3260 case (ISYMNUM (SCM_IM_IF
)):
3263 SCM test_result
= EVALCAR (x
, env
);
3264 x
= SCM_CDR (x
); /* then expression */
3265 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
3267 x
= SCM_CDR (x
); /* else expression */
3269 RETURN (SCM_UNSPECIFIED
);
3272 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3276 case (ISYMNUM (SCM_IM_LET
)):
3279 SCM init_forms
= SCM_CADR (x
);
3280 SCM init_values
= SCM_EOL
;
3283 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3284 init_forms
= SCM_CDR (init_forms
);
3286 while (!SCM_NULLP (init_forms
));
3287 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
3290 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3291 goto nontoplevel_begin
;
3294 case (ISYMNUM (SCM_IM_LETREC
)):
3296 env
= SCM_EXTEND_ENV (SCM_CAR (x
), undefineds
, env
);
3299 SCM init_forms
= SCM_CAR (x
);
3300 SCM init_values
= SCM_EOL
;
3303 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3304 init_forms
= SCM_CDR (init_forms
);
3306 while (!SCM_NULLP (init_forms
));
3307 SCM_SETCDR (SCM_CAR (env
), init_values
);
3310 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3311 goto nontoplevel_begin
;
3314 case (ISYMNUM (SCM_IM_LETSTAR
)):
3317 SCM bindings
= SCM_CAR (x
);
3318 if (SCM_NULLP (bindings
))
3319 env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
3324 SCM name
= SCM_CAR (bindings
);
3325 SCM init
= SCM_CDR (bindings
);
3326 env
= SCM_EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
3327 bindings
= SCM_CDR (init
);
3329 while (!SCM_NULLP (bindings
));
3333 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3334 goto nontoplevel_begin
;
3337 case (ISYMNUM (SCM_IM_OR
)):
3339 while (!SCM_NULLP (SCM_CDR (x
)))
3341 SCM val
= EVALCAR (x
, env
);
3342 if (!SCM_FALSEP (val
) && !SCM_NILP (val
))
3347 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3351 case (ISYMNUM (SCM_IM_LAMBDA
)):
3352 RETURN (scm_closure (SCM_CDR (x
), env
));
3355 case (ISYMNUM (SCM_IM_QUOTE
)):
3356 RETURN (SCM_CDR (x
));
3359 case (ISYMNUM (SCM_IM_SET_X
)):
3363 SCM variable
= SCM_CAR (x
);
3364 if (SCM_ILOCP (variable
))
3365 location
= scm_ilookup (variable
, env
);
3366 else if (SCM_VARIABLEP (variable
))
3367 location
= SCM_VARIABLE_LOC (variable
);
3370 /* (SCM_SYMBOLP (variable)) is known to be true */
3371 variable
= lazy_memoize_variable (variable
, env
);
3372 SCM_SETCAR (x
, variable
);
3373 location
= SCM_VARIABLE_LOC (variable
);
3376 *location
= EVALCAR (x
, env
);
3378 RETURN (SCM_UNSPECIFIED
);
3381 case (ISYMNUM (SCM_IM_APPLY
)):
3382 /* Evaluate the procedure to be applied. */
3384 proc
= EVALCAR (x
, env
);
3385 PREP_APPLY (proc
, SCM_EOL
);
3387 /* Evaluate the argument holding the list of arguments */
3389 arg1
= EVALCAR (x
, env
);
3392 /* Go here to tail-apply a procedure. PROC is the procedure and
3393 * ARG1 is the list of arguments. PREP_APPLY must have been called
3394 * before jumping to apply_proc. */
3395 if (SCM_CLOSUREP (proc
))
3397 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3399 debug
.info
->a
.args
= arg1
;
3401 if (scm_badargsp (formals
, arg1
))
3402 scm_wrong_num_args (proc
);
3404 /* Copy argument list */
3405 if (SCM_NULL_OR_NIL_P (arg1
))
3406 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
3409 SCM args
= scm_list_1 (SCM_CAR (arg1
));
3411 arg1
= SCM_CDR (arg1
);
3412 while (!SCM_NULL_OR_NIL_P (arg1
))
3414 SCM new_tail
= scm_list_1 (SCM_CAR (arg1
));
3415 SCM_SETCDR (tail
, new_tail
);
3417 arg1
= SCM_CDR (arg1
);
3419 env
= SCM_EXTEND_ENV (formals
, args
, SCM_ENV (proc
));
3422 x
= SCM_CLOSURE_BODY (proc
);
3423 goto nontoplevel_begin
;
3428 RETURN (SCM_APPLY (proc
, arg1
, SCM_EOL
));
3432 case (ISYMNUM (SCM_IM_CONT
)):
3435 SCM val
= scm_make_continuation (&first
);
3443 proc
= EVALCAR (proc
, env
);
3444 PREP_APPLY (proc
, scm_list_1 (arg1
));
3451 case (ISYMNUM (SCM_IM_DELAY
)):
3452 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
3455 case (ISYMNUM (SCM_IM_FUTURE
)):
3456 RETURN (scm_i_make_future (scm_closure (SCM_CDR (x
), env
)));
3459 /* PLACEHOLDER for case (ISYMNUM (SCM_IM_DISPATCH)): The following
3460 code (type_dispatch) is intended to be the tail of the case
3461 clause for the internal macro SCM_IM_DISPATCH. Please don't
3462 remove it from this location without discussing it with Mikael
3463 <djurfeldt@nada.kth.se> */
3465 /* The type dispatch code is duplicated below
3466 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
3467 * cuts down execution time for type dispatch to 50%. */
3468 type_dispatch
: /* inputs: x, arg1 */
3469 /* Type dispatch means to determine from the types of the function
3470 * arguments (i. e. the 'signature' of the call), which method from
3471 * a generic function is to be called. This process of selecting
3472 * the right method takes some time. To speed it up, guile uses
3473 * caching: Together with the macro call to dispatch the signatures
3474 * of some previous calls to that generic function from the same
3475 * place are stored (in the code!) in a cache that we call the
3476 * 'method cache'. This is done since it is likely, that
3477 * consecutive calls to dispatch from that position in the code will
3478 * have the same signature. Thus, the type dispatch works as
3479 * follows: First, determine a hash value from the signature of the
3480 * actual arguments. Second, use this hash value as an index to
3481 * find that same signature in the method cache stored at this
3482 * position in the code. If found, you have also found the
3483 * corresponding method that belongs to that signature. If the
3484 * signature is not found in the method cache, you have to perform a
3485 * full search over all signatures stored with the generic
3488 unsigned long int specializers
;
3489 unsigned long int hash_value
;
3490 unsigned long int cache_end_pos
;
3491 unsigned long int mask
;
3495 SCM z
= SCM_CDDR (x
);
3496 SCM tmp
= SCM_CADR (z
);
3497 specializers
= SCM_INUM (SCM_CAR (z
));
3499 /* Compute a hash value for searching the method cache. There
3500 * are two variants for computing the hash value, a (rather)
3501 * complicated one, and a simple one. For the complicated one
3502 * explained below, tmp holds a number that is used in the
3504 if (SCM_INUMP (tmp
))
3506 /* Use the signature of the actual arguments to determine
3507 * the hash value. This is done as follows: Each class has
3508 * an array of random numbers, that are determined when the
3509 * class is created. The integer 'hashset' is an index into
3510 * that array of random numbers. Now, from all classes that
3511 * are part of the signature of the actual arguments, the
3512 * random numbers at index 'hashset' are taken and summed
3513 * up, giving the hash value. The value of 'hashset' is
3514 * stored at the call to dispatch. This allows to have
3515 * different 'formulas' for calculating the hash value at
3516 * different places where dispatch is called. This allows
3517 * to optimize the hash formula at every individual place
3518 * where dispatch is called, such that hopefully the hash
3519 * value that is computed will directly point to the right
3520 * method in the method cache. */
3521 unsigned long int hashset
= SCM_INUM (tmp
);
3522 unsigned long int counter
= specializers
+ 1;
3525 while (!SCM_NULLP (tmp_arg
) && counter
!= 0)
3527 SCM
class = scm_class_of (SCM_CAR (tmp_arg
));
3528 hash_value
+= SCM_INSTANCE_HASH (class, hashset
);
3529 tmp_arg
= SCM_CDR (tmp_arg
);
3533 method_cache
= SCM_CADR (z
);
3534 mask
= SCM_INUM (SCM_CAR (z
));
3536 cache_end_pos
= hash_value
;
3540 /* This method of determining the hash value is much
3541 * simpler: Set the hash value to zero and just perform a
3542 * linear search through the method cache. */
3544 mask
= (unsigned long int) ((long) -1);
3546 cache_end_pos
= SCM_VECTOR_LENGTH (method_cache
);
3551 /* Search the method cache for a method with a matching
3552 * signature. Start the search at position 'hash_value'. The
3553 * hashing implementation uses linear probing for conflict
3554 * resolution, that is, if the signature in question is not
3555 * found at the starting index in the hash table, the next table
3556 * entry is tried, and so on, until in the worst case the whole
3557 * cache has been searched, but still the signature has not been
3562 SCM args
= arg1
; /* list of arguments */
3563 z
= SCM_VELTS (method_cache
)[hash_value
];
3564 while (!SCM_NULLP (args
))
3566 /* More arguments than specifiers => CLASS != ENV */
3567 SCM class_of_arg
= scm_class_of (SCM_CAR (args
));
3568 if (!SCM_EQ_P (class_of_arg
, SCM_CAR (z
)))
3570 args
= SCM_CDR (args
);
3573 /* Fewer arguments than specifiers => CAR != ENV */
3574 if (SCM_NULLP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
)))
3577 hash_value
= (hash_value
+ 1) & mask
;
3578 } while (hash_value
!= cache_end_pos
);
3580 /* No appropriate method was found in the cache. */
3581 z
= scm_memoize_method (x
, arg1
);
3583 apply_cmethod
: /* inputs: z, arg1 */
3585 SCM formals
= SCM_CMETHOD_FORMALS (z
);
3586 env
= SCM_EXTEND_ENV (formals
, arg1
, SCM_CMETHOD_ENV (z
));
3587 x
= SCM_CMETHOD_BODY (z
);
3588 goto nontoplevel_begin
;
3594 case (ISYMNUM (SCM_IM_SLOT_REF
)):
3597 SCM instance
= EVALCAR (x
, env
);
3598 unsigned long int slot
= SCM_INUM (SCM_CDR (x
));
3599 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance
) [slot
]));
3603 case (ISYMNUM (SCM_IM_SLOT_SET_X
)):
3606 SCM instance
= EVALCAR (x
, env
);
3607 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
3608 SCM value
= EVALCAR (SCM_CDDR (x
), env
);
3609 SCM_STRUCT_DATA (instance
) [slot
] = SCM_UNPACK (value
);
3610 RETURN (SCM_UNSPECIFIED
);
3614 #if SCM_ENABLE_ELISP
3616 case (ISYMNUM (SCM_IM_NIL_COND
)):
3618 SCM test_form
= SCM_CDR (x
);
3619 x
= SCM_CDR (test_form
);
3620 while (!SCM_NULL_OR_NIL_P (x
))
3622 SCM test_result
= EVALCAR (test_form
, env
);
3623 if (!(SCM_FALSEP (test_result
)
3624 || SCM_NULL_OR_NIL_P (test_result
)))
3626 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
3627 RETURN (test_result
);
3628 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3633 test_form
= SCM_CDR (x
);
3634 x
= SCM_CDR (test_form
);
3638 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3642 #endif /* SCM_ENABLE_ELISP */
3644 case (ISYMNUM (SCM_IM_BIND
)):
3646 SCM vars
, exps
, vals
;
3649 vars
= SCM_CAAR (x
);
3650 exps
= SCM_CDAR (x
);
3652 while (!SCM_NULLP (exps
))
3654 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
3655 exps
= SCM_CDR (exps
);
3658 scm_swap_bindings (vars
, vals
);
3659 scm_dynwinds
= scm_acons (vars
, vals
, scm_dynwinds
);
3661 /* Ignore all but the last evaluation result. */
3662 for (x
= SCM_CDR (x
); !SCM_NULLP (SCM_CDR (x
)); x
= SCM_CDR (x
))
3664 if (SCM_CONSP (SCM_CAR (x
)))
3665 CEVAL (SCM_CAR (x
), env
);
3667 proc
= EVALCAR (x
, env
);
3669 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
3670 scm_swap_bindings (vars
, vals
);
3676 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
3681 producer
= EVALCAR (x
, env
);
3683 proc
= EVALCAR (x
, env
); /* proc is the consumer. */
3684 arg1
= SCM_APPLY (producer
, SCM_EOL
, SCM_EOL
);
3685 if (SCM_VALUESP (arg1
))
3687 /* The list of arguments is not copied. Rather, it is assumed
3688 * that this has been done by the 'values' procedure. */
3689 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
3693 arg1
= scm_list_1 (arg1
);
3695 PREP_APPLY (proc
, arg1
);
3706 if (SCM_VARIABLEP (SCM_CAR (x
)))
3707 proc
= SCM_VARIABLE_REF (SCM_CAR (x
));
3708 else if (SCM_ILOCP (SCM_CAR (x
)))
3709 proc
= *scm_ilookup (SCM_CAR (x
), env
);
3710 else if (SCM_CONSP (SCM_CAR (x
)))
3711 proc
= CEVAL (SCM_CAR (x
), env
);
3712 else if (SCM_SYMBOLP (SCM_CAR (x
)))
3714 SCM orig_sym
= SCM_CAR (x
);
3716 SCM
*location
= scm_lookupcar1 (x
, env
, 1);
3717 if (location
== NULL
)
3719 /* we have lost the race, start again. */
3725 if (SCM_MACROP (proc
))
3727 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
3729 handle_a_macro
: /* inputs: x, env, proc */
3731 /* Set a flag during macro expansion so that macro
3732 application frames can be deleted from the backtrace. */
3733 SCM_SET_MACROEXP (debug
);
3735 arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
3736 scm_cons (env
, scm_listofnull
));
3738 SCM_CLEAR_MACROEXP (debug
);
3740 switch (SCM_MACRO_TYPE (proc
))
3744 if (!SCM_CONSP (arg1
))
3745 arg1
= scm_list_2 (SCM_IM_BEGIN
, arg1
);
3747 assert (!SCM_EQ_P (x
, SCM_CAR (arg1
))
3748 && !SCM_EQ_P (x
, SCM_CDR (arg1
)));
3751 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
3754 SCM_SETCAR (x
, SCM_CAR (arg1
));
3755 SCM_SETCDR (x
, SCM_CDR (arg1
));
3759 /* Prevent memoizing of debug info expression. */
3760 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
3765 SCM_SETCAR (x
, SCM_CAR (arg1
));
3766 SCM_SETCDR (x
, SCM_CDR (arg1
));
3768 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3770 #if SCM_ENABLE_DEPRECATED == 1
3775 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3789 if (SCM_MACROP (proc
))
3790 goto handle_a_macro
;
3794 /* When reaching this part of the code, the following is granted: Variable x
3795 * holds the first pair of an expression of the form (<function> arg ...).
3796 * Variable proc holds the object that resulted from the evaluation of
3797 * <function>. In the following, the arguments (if any) will be evaluated,
3798 * and proc will be applied to them. If proc does not really hold a
3799 * function object, this will be signalled as an error on the scheme
3800 * level. If the number of arguments does not match the number of arguments
3801 * that are allowed to be passed to proc, also an error on the scheme level
3802 * will be signalled. */
3803 PREP_APPLY (proc
, SCM_EOL
);
3804 if (SCM_NULLP (SCM_CDR (x
))) {
3807 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3808 switch (SCM_TYP7 (proc
))
3809 { /* no arguments given */
3810 case scm_tc7_subr_0
:
3811 RETURN (SCM_SUBRF (proc
) ());
3812 case scm_tc7_subr_1o
:
3813 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
3815 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
3816 case scm_tc7_rpsubr
:
3817 RETURN (SCM_BOOL_T
);
3819 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
3821 if (!SCM_SMOB_APPLICABLE_P (proc
))
3823 RETURN (SCM_SMOB_APPLY_0 (proc
));
3826 proc
= SCM_CCLO_SUBR (proc
);
3828 debug
.info
->a
.proc
= proc
;
3829 debug
.info
->a
.args
= scm_list_1 (arg1
);
3833 proc
= SCM_PROCEDURE (proc
);
3835 debug
.info
->a
.proc
= proc
;
3837 if (!SCM_CLOSUREP (proc
))
3840 case scm_tcs_closures
:
3842 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3843 if (SCM_CONSP (formals
))
3844 goto umwrongnumargs
;
3845 x
= SCM_CLOSURE_BODY (proc
);
3846 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
3847 goto nontoplevel_begin
;
3849 case scm_tcs_struct
:
3850 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3852 x
= SCM_ENTITY_PROCEDURE (proc
);
3856 else if (SCM_I_OPERATORP (proc
))
3859 proc
= (SCM_I_ENTITYP (proc
)
3860 ? SCM_ENTITY_PROCEDURE (proc
)
3861 : SCM_OPERATOR_PROCEDURE (proc
));
3863 debug
.info
->a
.proc
= proc
;
3864 debug
.info
->a
.args
= scm_list_1 (arg1
);
3870 case scm_tc7_subr_1
:
3871 case scm_tc7_subr_2
:
3872 case scm_tc7_subr_2o
:
3875 case scm_tc7_subr_3
:
3876 case scm_tc7_lsubr_2
:
3879 scm_wrong_num_args (proc
);
3882 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
3886 /* must handle macros by here */
3889 arg1
= EVALCAR (x
, env
);
3891 scm_wrong_num_args (proc
);
3893 debug
.info
->a
.args
= scm_list_1 (arg1
);
3901 evap1
: /* inputs: proc, arg1 */
3902 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3903 switch (SCM_TYP7 (proc
))
3904 { /* have one argument in arg1 */
3905 case scm_tc7_subr_2o
:
3906 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3907 case scm_tc7_subr_1
:
3908 case scm_tc7_subr_1o
:
3909 RETURN (SCM_SUBRF (proc
) (arg1
));
3911 if (SCM_INUMP (arg1
))
3913 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3915 else if (SCM_REALP (arg1
))
3917 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3919 else if (SCM_BIGP (arg1
))
3921 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3923 else if (SCM_FRACTIONP (arg1
))
3925 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
3927 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3928 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3931 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
3934 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
3935 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3936 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3941 case scm_tc7_rpsubr
:
3942 RETURN (SCM_BOOL_T
);
3944 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3947 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3949 RETURN (SCM_SUBRF (proc
) (scm_list_1 (arg1
)));
3952 if (!SCM_SMOB_APPLICABLE_P (proc
))
3954 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
3958 proc
= SCM_CCLO_SUBR (proc
);
3960 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
3961 debug
.info
->a
.proc
= proc
;
3965 proc
= SCM_PROCEDURE (proc
);
3967 debug
.info
->a
.proc
= proc
;
3969 if (!SCM_CLOSUREP (proc
))
3972 case scm_tcs_closures
:
3975 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3976 if (SCM_NULLP (formals
)
3977 || (SCM_CONSP (formals
) && SCM_CONSP (SCM_CDR (formals
))))
3978 goto umwrongnumargs
;
3979 x
= SCM_CLOSURE_BODY (proc
);
3981 env
= SCM_EXTEND_ENV (formals
,
3985 env
= SCM_EXTEND_ENV (formals
,
3989 goto nontoplevel_begin
;
3991 case scm_tcs_struct
:
3992 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3994 x
= SCM_ENTITY_PROCEDURE (proc
);
3996 arg1
= debug
.info
->a
.args
;
3998 arg1
= scm_list_1 (arg1
);
4002 else if (SCM_I_OPERATORP (proc
))
4006 proc
= (SCM_I_ENTITYP (proc
)
4007 ? SCM_ENTITY_PROCEDURE (proc
)
4008 : SCM_OPERATOR_PROCEDURE (proc
));
4010 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
4011 debug
.info
->a
.proc
= proc
;
4017 case scm_tc7_subr_2
:
4018 case scm_tc7_subr_0
:
4019 case scm_tc7_subr_3
:
4020 case scm_tc7_lsubr_2
:
4021 scm_wrong_num_args (proc
);
4027 arg2
= EVALCAR (x
, env
);
4029 scm_wrong_num_args (proc
);
4031 { /* have two or more arguments */
4033 debug
.info
->a
.args
= scm_list_2 (arg1
, arg2
);
4036 if (SCM_NULLP (x
)) {
4039 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4040 switch (SCM_TYP7 (proc
))
4041 { /* have two arguments */
4042 case scm_tc7_subr_2
:
4043 case scm_tc7_subr_2o
:
4044 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
4047 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4049 RETURN (SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
)));
4051 case scm_tc7_lsubr_2
:
4052 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
));
4053 case scm_tc7_rpsubr
:
4055 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
4057 if (!SCM_SMOB_APPLICABLE_P (proc
))
4059 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
));
4063 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
4064 scm_cons (proc
, debug
.info
->a
.args
),
4067 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
4068 scm_cons2 (proc
, arg1
,
4075 case scm_tcs_struct
:
4076 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4078 x
= SCM_ENTITY_PROCEDURE (proc
);
4080 arg1
= debug
.info
->a
.args
;
4082 arg1
= scm_list_2 (arg1
, arg2
);
4086 else if (SCM_I_OPERATORP (proc
))
4090 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
4091 ? SCM_ENTITY_PROCEDURE (proc
)
4092 : SCM_OPERATOR_PROCEDURE (proc
),
4093 scm_cons (proc
, debug
.info
->a
.args
),
4096 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
4097 ? SCM_ENTITY_PROCEDURE (proc
)
4098 : SCM_OPERATOR_PROCEDURE (proc
),
4099 scm_cons2 (proc
, arg1
,
4109 case scm_tc7_subr_0
:
4112 case scm_tc7_subr_1o
:
4113 case scm_tc7_subr_1
:
4114 case scm_tc7_subr_3
:
4115 scm_wrong_num_args (proc
);
4119 proc
= SCM_PROCEDURE (proc
);
4121 debug
.info
->a
.proc
= proc
;
4123 if (!SCM_CLOSUREP (proc
))
4126 case scm_tcs_closures
:
4129 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4130 if (SCM_NULLP (formals
)
4131 || (SCM_CONSP (formals
)
4132 && (SCM_NULLP (SCM_CDR (formals
))
4133 || (SCM_CONSP (SCM_CDR (formals
))
4134 && SCM_CONSP (SCM_CDDR (formals
))))))
4135 goto umwrongnumargs
;
4137 env
= SCM_EXTEND_ENV (formals
,
4141 env
= SCM_EXTEND_ENV (formals
,
4142 scm_list_2 (arg1
, arg2
),
4145 x
= SCM_CLOSURE_BODY (proc
);
4146 goto nontoplevel_begin
;
4151 scm_wrong_num_args (proc
);
4153 debug
.info
->a
.args
= scm_cons2 (arg1
, arg2
,
4154 deval_args (x
, env
, proc
,
4155 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
4159 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4160 switch (SCM_TYP7 (proc
))
4161 { /* have 3 or more arguments */
4163 case scm_tc7_subr_3
:
4164 if (!SCM_NULLP (SCM_CDR (x
)))
4165 scm_wrong_num_args (proc
);
4167 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4168 SCM_CADDR (debug
.info
->a
.args
)));
4170 arg1
= SCM_SUBRF(proc
)(arg1
, arg2
);
4171 arg2
= SCM_CDDR (debug
.info
->a
.args
);
4174 arg1
= SCM_SUBRF(proc
)(arg1
, SCM_CAR (arg2
));
4175 arg2
= SCM_CDR (arg2
);
4177 while (SCM_NIMP (arg2
));
4179 case scm_tc7_rpsubr
:
4180 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
4181 RETURN (SCM_BOOL_F
);
4182 arg1
= SCM_CDDR (debug
.info
->a
.args
);
4185 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (arg1
))))
4186 RETURN (SCM_BOOL_F
);
4187 arg2
= SCM_CAR (arg1
);
4188 arg1
= SCM_CDR (arg1
);
4190 while (SCM_NIMP (arg1
));
4191 RETURN (SCM_BOOL_T
);
4192 case scm_tc7_lsubr_2
:
4193 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4194 SCM_CDDR (debug
.info
->a
.args
)));
4196 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4198 if (!SCM_SMOB_APPLICABLE_P (proc
))
4200 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4201 SCM_CDDR (debug
.info
->a
.args
)));
4205 proc
= SCM_PROCEDURE (proc
);
4206 debug
.info
->a
.proc
= proc
;
4207 if (!SCM_CLOSUREP (proc
))
4210 case scm_tcs_closures
:
4212 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4213 if (SCM_NULLP (formals
)
4214 || (SCM_CONSP (formals
)
4215 && (SCM_NULLP (SCM_CDR (formals
))
4216 || (SCM_CONSP (SCM_CDR (formals
))
4217 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4218 goto umwrongnumargs
;
4219 SCM_SET_ARGSREADY (debug
);
4220 env
= SCM_EXTEND_ENV (formals
,
4223 x
= SCM_CLOSURE_BODY (proc
);
4224 goto nontoplevel_begin
;
4227 case scm_tc7_subr_3
:
4228 if (!SCM_NULLP (SCM_CDR (x
)))
4229 scm_wrong_num_args (proc
);
4231 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, EVALCAR (x
, env
)));
4233 arg1
= SCM_SUBRF (proc
) (arg1
, arg2
);
4236 arg1
= SCM_SUBRF(proc
)(arg1
, EVALCAR(x
, env
));
4239 while (!SCM_NULLP (x
));
4241 case scm_tc7_rpsubr
:
4242 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
4243 RETURN (SCM_BOOL_F
);
4246 arg1
= EVALCAR (x
, env
);
4247 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, arg1
)))
4248 RETURN (SCM_BOOL_F
);
4252 while (!SCM_NULLP (x
));
4253 RETURN (SCM_BOOL_T
);
4254 case scm_tc7_lsubr_2
:
4255 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
4257 RETURN (SCM_SUBRF (proc
) (scm_cons2 (arg1
,
4259 scm_eval_args (x
, env
, proc
))));
4261 if (!SCM_SMOB_APPLICABLE_P (proc
))
4263 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4264 scm_eval_args (x
, env
, proc
)));
4268 proc
= SCM_PROCEDURE (proc
);
4269 if (!SCM_CLOSUREP (proc
))
4272 case scm_tcs_closures
:
4274 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4275 if (SCM_NULLP (formals
)
4276 || (SCM_CONSP (formals
)
4277 && (SCM_NULLP (SCM_CDR (formals
))
4278 || (SCM_CONSP (SCM_CDR (formals
))
4279 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4280 goto umwrongnumargs
;
4281 env
= SCM_EXTEND_ENV (formals
,
4284 scm_eval_args (x
, env
, proc
)),
4286 x
= SCM_CLOSURE_BODY (proc
);
4287 goto nontoplevel_begin
;
4290 case scm_tcs_struct
:
4291 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4294 arg1
= debug
.info
->a
.args
;
4296 arg1
= scm_cons2 (arg1
, arg2
, scm_eval_args (x
, env
, proc
));
4298 x
= SCM_ENTITY_PROCEDURE (proc
);
4301 else if (SCM_I_OPERATORP (proc
))
4305 case scm_tc7_subr_2
:
4306 case scm_tc7_subr_1o
:
4307 case scm_tc7_subr_2o
:
4308 case scm_tc7_subr_0
:
4311 case scm_tc7_subr_1
:
4312 scm_wrong_num_args (proc
);
4320 if (scm_check_exit_p
&& SCM_TRAPS_P
)
4321 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
4323 SCM_CLEAR_TRACED_FRAME (debug
);
4324 if (SCM_CHEAPTRAPS_P
)
4325 arg1
= scm_make_debugobj (&debug
);
4329 SCM val
= scm_make_continuation (&first
);
4340 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
4344 scm_last_debug_frame
= debug
.prev
;
4350 /* SECTION: This code is compiled once.
4357 /* Simple procedure calls
4361 scm_call_0 (SCM proc
)
4363 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
4367 scm_call_1 (SCM proc
, SCM arg1
)
4369 return scm_apply (proc
, arg1
, scm_listofnull
);
4373 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
4375 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
4379 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
4381 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
4385 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
4387 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
4388 scm_cons (arg4
, scm_listofnull
)));
4391 /* Simple procedure applies
4395 scm_apply_0 (SCM proc
, SCM args
)
4397 return scm_apply (proc
, args
, SCM_EOL
);
4401 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
4403 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
4407 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
4409 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
4413 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
4415 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
4419 /* This code processes the arguments to apply:
4421 (apply PROC ARG1 ... ARGS)
4423 Given a list (ARG1 ... ARGS), this function conses the ARG1
4424 ... arguments onto the front of ARGS, and returns the resulting
4425 list. Note that ARGS is a list; thus, the argument to this
4426 function is a list whose last element is a list.
4428 Apply calls this function, and applies PROC to the elements of the
4429 result. apply:nconc2last takes care of building the list of
4430 arguments, given (ARG1 ... ARGS).
4432 Rather than do new consing, apply:nconc2last destroys its argument.
4433 On that topic, this code came into my care with the following
4434 beautifully cryptic comment on that topic: "This will only screw
4435 you if you do (scm_apply scm_apply '( ... ))" If you know what
4436 they're referring to, send me a patch to this comment. */
4438 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
4440 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
4441 "conses the @var{arg1} @dots{} arguments onto the front of\n"
4442 "@var{args}, and returns the resulting list. Note that\n"
4443 "@var{args} is a list; thus, the argument to this function is\n"
4444 "a list whose last element is a list.\n"
4445 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
4446 "destroys its argument, so use with care.")
4447 #define FUNC_NAME s_scm_nconc2last
4450 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
4452 while (!SCM_NULLP (SCM_CDR (*lloc
))) /* Perhaps should be
4453 SCM_NULL_OR_NIL_P, but not
4454 needed in 99.99% of cases,
4455 and it could seriously hurt
4456 performance. - Neil */
4457 lloc
= SCM_CDRLOC (*lloc
);
4458 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
4459 *lloc
= SCM_CAR (*lloc
);
4467 /* SECTION: When DEVAL is defined this code yields scm_dapply.
4468 * It is compiled twice.
4473 scm_apply (SCM proc
, SCM arg1
, SCM args
)
4479 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
4484 /* Apply a function to a list of arguments.
4486 This function is exported to the Scheme level as taking two
4487 required arguments and a tail argument, as if it were:
4488 (lambda (proc arg1 . args) ...)
4489 Thus, if you just have a list of arguments to pass to a procedure,
4490 pass the list as ARG1, and '() for ARGS. If you have some fixed
4491 args, pass the first as ARG1, then cons any remaining fixed args
4492 onto the front of your argument list, and pass that as ARGS. */
4495 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
4498 scm_t_debug_frame debug
;
4499 scm_t_debug_info debug_vect_body
;
4500 debug
.prev
= scm_last_debug_frame
;
4501 debug
.status
= SCM_APPLYFRAME
;
4502 debug
.vect
= &debug_vect_body
;
4503 debug
.vect
[0].a
.proc
= proc
;
4504 debug
.vect
[0].a
.args
= SCM_EOL
;
4505 scm_last_debug_frame
= &debug
;
4507 if (scm_debug_mode_p
)
4508 return scm_dapply (proc
, arg1
, args
);
4511 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
4513 /* If ARGS is the empty list, then we're calling apply with only two
4514 arguments --- ARG1 is the list of arguments for PROC. Whatever
4515 the case, futz with things so that ARG1 is the first argument to
4516 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
4519 Setting the debug apply frame args this way is pretty messy.
4520 Perhaps we should store arg1 and args directly in the frame as
4521 received, and let scm_frame_arguments unpack them, because that's
4522 a relatively rare operation. This works for now; if the Guile
4523 developer archives are still around, see Mikael's post of
4525 if (SCM_NULLP (args
))
4527 if (SCM_NULLP (arg1
))
4529 arg1
= SCM_UNDEFINED
;
4531 debug
.vect
[0].a
.args
= SCM_EOL
;
4537 debug
.vect
[0].a
.args
= arg1
;
4539 args
= SCM_CDR (arg1
);
4540 arg1
= SCM_CAR (arg1
);
4545 args
= scm_nconc2last (args
);
4547 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4551 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
4554 if (SCM_CHEAPTRAPS_P
)
4555 tmp
= scm_make_debugobj (&debug
);
4560 tmp
= scm_make_continuation (&first
);
4565 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
4572 switch (SCM_TYP7 (proc
))
4574 case scm_tc7_subr_2o
:
4575 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
4576 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4577 case scm_tc7_subr_2
:
4578 if (SCM_NULLP (args
) || !SCM_NULLP (SCM_CDR (args
)))
4579 scm_wrong_num_args (proc
);
4580 args
= SCM_CAR (args
);
4581 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4582 case scm_tc7_subr_0
:
4583 if (!SCM_UNBNDP (arg1
))
4584 scm_wrong_num_args (proc
);
4586 RETURN (SCM_SUBRF (proc
) ());
4587 case scm_tc7_subr_1
:
4588 if (SCM_UNBNDP (arg1
))
4589 scm_wrong_num_args (proc
);
4590 case scm_tc7_subr_1o
:
4591 if (!SCM_NULLP (args
))
4592 scm_wrong_num_args (proc
);
4594 RETURN (SCM_SUBRF (proc
) (arg1
));
4596 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
4597 scm_wrong_num_args (proc
);
4598 if (SCM_INUMP (arg1
))
4600 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
4602 else if (SCM_REALP (arg1
))
4604 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4606 else if (SCM_BIGP (arg1
))
4608 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4610 else if (SCM_FRACTIONP (arg1
))
4612 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4614 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4615 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4617 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
4618 scm_wrong_num_args (proc
);
4620 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
4623 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
4624 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4625 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
4630 case scm_tc7_subr_3
:
4631 if (SCM_NULLP (args
)
4632 || SCM_NULLP (SCM_CDR (args
))
4633 || !SCM_NULLP (SCM_CDDR (args
)))
4634 scm_wrong_num_args (proc
);
4636 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
4639 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
4641 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
4643 case scm_tc7_lsubr_2
:
4644 if (!SCM_CONSP (args
))
4645 scm_wrong_num_args (proc
);
4647 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4649 if (SCM_NULLP (args
))
4650 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4651 while (SCM_NIMP (args
))
4653 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
4654 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
4655 args
= SCM_CDR (args
);
4658 case scm_tc7_rpsubr
:
4659 if (SCM_NULLP (args
))
4660 RETURN (SCM_BOOL_T
);
4661 while (SCM_NIMP (args
))
4663 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
4664 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
4665 RETURN (SCM_BOOL_F
);
4666 arg1
= SCM_CAR (args
);
4667 args
= SCM_CDR (args
);
4669 RETURN (SCM_BOOL_T
);
4670 case scm_tcs_closures
:
4672 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4674 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4676 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
4677 scm_wrong_num_args (proc
);
4679 /* Copy argument list */
4684 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
4685 for (arg1
= SCM_CDR (arg1
); SCM_CONSP (arg1
); arg1
= SCM_CDR (arg1
))
4687 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
));
4690 SCM_SETCDR (tl
, arg1
);
4693 args
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4696 proc
= SCM_CLOSURE_BODY (proc
);
4698 arg1
= SCM_CDR (proc
);
4699 while (!SCM_NULLP (arg1
))
4701 if (SCM_IMP (SCM_CAR (proc
)))
4703 if (SCM_ISYMP (SCM_CAR (proc
)))
4705 scm_rec_mutex_lock (&source_mutex
);
4706 /* check for race condition */
4707 if (SCM_ISYMP (SCM_CAR (proc
)))
4708 m_expand_body (proc
, args
);
4709 scm_rec_mutex_unlock (&source_mutex
);
4713 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
4716 (void) EVAL (SCM_CAR (proc
), args
);
4718 arg1
= SCM_CDR (proc
);
4720 RETURN (EVALCAR (proc
, args
));
4722 if (!SCM_SMOB_APPLICABLE_P (proc
))
4724 if (SCM_UNBNDP (arg1
))
4725 RETURN (SCM_SMOB_APPLY_0 (proc
));
4726 else if (SCM_NULLP (args
))
4727 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
4728 else if (SCM_NULLP (SCM_CDR (args
)))
4729 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
4731 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4734 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4736 proc
= SCM_CCLO_SUBR (proc
);
4737 debug
.vect
[0].a
.proc
= proc
;
4738 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4740 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4742 proc
= SCM_CCLO_SUBR (proc
);
4746 proc
= SCM_PROCEDURE (proc
);
4748 debug
.vect
[0].a
.proc
= proc
;
4751 case scm_tcs_struct
:
4752 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4755 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4757 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4759 RETURN (scm_apply_generic (proc
, args
));
4761 else if (SCM_I_OPERATORP (proc
))
4765 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4767 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4770 proc
= (SCM_I_ENTITYP (proc
)
4771 ? SCM_ENTITY_PROCEDURE (proc
)
4772 : SCM_OPERATOR_PROCEDURE (proc
));
4774 debug
.vect
[0].a
.proc
= proc
;
4775 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4777 if (SCM_NIMP (proc
))
4786 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
4790 if (scm_check_exit_p
&& SCM_TRAPS_P
)
4791 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
4793 SCM_CLEAR_TRACED_FRAME (debug
);
4794 if (SCM_CHEAPTRAPS_P
)
4795 arg1
= scm_make_debugobj (&debug
);
4799 SCM val
= scm_make_continuation (&first
);
4810 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
4814 scm_last_debug_frame
= debug
.prev
;
4820 /* SECTION: The rest of this file is only read once.
4827 * Trampolines make it possible to move procedure application dispatch
4828 * outside inner loops. The motivation was clean implementation of
4829 * efficient replacements of R5RS primitives in SRFI-1.
4831 * The semantics is clear: scm_trampoline_N returns an optimized
4832 * version of scm_call_N (or NULL if the procedure isn't applicable
4835 * Applying the optimization to map and for-each increased efficiency
4836 * noticeably. For example, (map abs ls) is now 8 times faster than
4841 call_subr0_0 (SCM proc
)
4843 return SCM_SUBRF (proc
) ();
4847 call_subr1o_0 (SCM proc
)
4849 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
4853 call_lsubr_0 (SCM proc
)
4855 return SCM_SUBRF (proc
) (SCM_EOL
);
4859 scm_i_call_closure_0 (SCM proc
)
4861 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4864 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
4869 scm_trampoline_0 (SCM proc
)
4871 scm_t_trampoline_0 trampoline
;
4876 switch (SCM_TYP7 (proc
))
4878 case scm_tc7_subr_0
:
4879 trampoline
= call_subr0_0
;
4881 case scm_tc7_subr_1o
:
4882 trampoline
= call_subr1o_0
;
4885 trampoline
= call_lsubr_0
;
4887 case scm_tcs_closures
:
4889 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4890 if (SCM_NULLP (formals
) || !SCM_CONSP (formals
))
4891 trampoline
= scm_i_call_closure_0
;
4896 case scm_tcs_struct
:
4897 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4898 trampoline
= scm_call_generic_0
;
4899 else if (SCM_I_OPERATORP (proc
))
4900 trampoline
= scm_call_0
;
4905 if (SCM_SMOB_APPLICABLE_P (proc
))
4906 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
4911 case scm_tc7_rpsubr
:
4914 trampoline
= scm_call_0
;
4917 return NULL
; /* not applicable on zero arguments */
4919 /* We only reach this point if a valid trampoline was determined. */
4921 /* If debugging is enabled, we want to see all calls to proc on the stack.
4922 * Thus, we replace the trampoline shortcut with scm_call_0. */
4923 if (scm_debug_mode_p
)
4930 call_subr1_1 (SCM proc
, SCM arg1
)
4932 return SCM_SUBRF (proc
) (arg1
);
4936 call_subr2o_1 (SCM proc
, SCM arg1
)
4938 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
4942 call_lsubr_1 (SCM proc
, SCM arg1
)
4944 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
4948 call_dsubr_1 (SCM proc
, SCM arg1
)
4950 if (SCM_INUMP (arg1
))
4952 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
4954 else if (SCM_REALP (arg1
))
4956 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4958 else if (SCM_BIGP (arg1
))
4960 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4962 else if (SCM_FRACTIONP (arg1
))
4964 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4966 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4967 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4971 call_cxr_1 (SCM proc
, SCM arg1
)
4973 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
4976 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
4977 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4978 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
4985 call_closure_1 (SCM proc
, SCM arg1
)
4987 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4990 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
4995 scm_trampoline_1 (SCM proc
)
4997 scm_t_trampoline_1 trampoline
;
5002 switch (SCM_TYP7 (proc
))
5004 case scm_tc7_subr_1
:
5005 case scm_tc7_subr_1o
:
5006 trampoline
= call_subr1_1
;
5008 case scm_tc7_subr_2o
:
5009 trampoline
= call_subr2o_1
;
5012 trampoline
= call_lsubr_1
;
5015 trampoline
= call_dsubr_1
;
5018 trampoline
= call_cxr_1
;
5020 case scm_tcs_closures
:
5022 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5023 if (!SCM_NULLP (formals
)
5024 && (!SCM_CONSP (formals
) || !SCM_CONSP (SCM_CDR (formals
))))
5025 trampoline
= call_closure_1
;
5030 case scm_tcs_struct
:
5031 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5032 trampoline
= scm_call_generic_1
;
5033 else if (SCM_I_OPERATORP (proc
))
5034 trampoline
= scm_call_1
;
5039 if (SCM_SMOB_APPLICABLE_P (proc
))
5040 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
5045 case scm_tc7_rpsubr
:
5048 trampoline
= scm_call_1
;
5051 return NULL
; /* not applicable on one arg */
5053 /* We only reach this point if a valid trampoline was determined. */
5055 /* If debugging is enabled, we want to see all calls to proc on the stack.
5056 * Thus, we replace the trampoline shortcut with scm_call_1. */
5057 if (scm_debug_mode_p
)
5064 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
5066 return SCM_SUBRF (proc
) (arg1
, arg2
);
5070 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
5072 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
5076 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
5078 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
5082 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
5084 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
5085 scm_list_2 (arg1
, arg2
),
5087 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
5092 scm_trampoline_2 (SCM proc
)
5094 scm_t_trampoline_2 trampoline
;
5099 switch (SCM_TYP7 (proc
))
5101 case scm_tc7_subr_2
:
5102 case scm_tc7_subr_2o
:
5103 case scm_tc7_rpsubr
:
5105 trampoline
= call_subr2_2
;
5107 case scm_tc7_lsubr_2
:
5108 trampoline
= call_lsubr2_2
;
5111 trampoline
= call_lsubr_2
;
5113 case scm_tcs_closures
:
5115 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5116 if (!SCM_NULLP (formals
)
5117 && (!SCM_CONSP (formals
)
5118 || (!SCM_NULLP (SCM_CDR (formals
))
5119 && (!SCM_CONSP (SCM_CDR (formals
))
5120 || !SCM_CONSP (SCM_CDDR (formals
))))))
5121 trampoline
= call_closure_2
;
5126 case scm_tcs_struct
:
5127 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5128 trampoline
= scm_call_generic_2
;
5129 else if (SCM_I_OPERATORP (proc
))
5130 trampoline
= scm_call_2
;
5135 if (SCM_SMOB_APPLICABLE_P (proc
))
5136 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
5142 trampoline
= scm_call_2
;
5145 return NULL
; /* not applicable on two args */
5147 /* We only reach this point if a valid trampoline was determined. */
5149 /* If debugging is enabled, we want to see all calls to proc on the stack.
5150 * Thus, we replace the trampoline shortcut with scm_call_2. */
5151 if (scm_debug_mode_p
)
5157 /* Typechecking for multi-argument MAP and FOR-EACH.
5159 Verify that each element of the vector ARGV, except for the first,
5160 is a proper list whose length is LEN. Attribute errors to WHO,
5161 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
5163 check_map_args (SCM argv
,
5170 SCM
const *ve
= SCM_VELTS (argv
);
5173 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
5175 long elt_len
= scm_ilength (ve
[i
]);
5180 scm_apply_generic (gf
, scm_cons (proc
, args
));
5182 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
5186 scm_out_of_range_pos (who
, ve
[i
], SCM_MAKINUM (i
+ 2));
5189 scm_remember_upto_here_1 (argv
);
5193 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
5195 /* Note: Currently, scm_map applies PROC to the argument list(s)
5196 sequentially, starting with the first element(s). This is used in
5197 evalext.c where the Scheme procedure `map-in-order', which guarantees
5198 sequential behaviour, is implemented using scm_map. If the
5199 behaviour changes, we need to update `map-in-order'.
5203 scm_map (SCM proc
, SCM arg1
, SCM args
)
5204 #define FUNC_NAME s_map
5209 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
5211 len
= scm_ilength (arg1
);
5212 SCM_GASSERTn (len
>= 0,
5213 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
5214 SCM_VALIDATE_REST_ARGUMENT (args
);
5215 if (SCM_NULLP (args
))
5217 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5218 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
5219 while (SCM_NIMP (arg1
))
5221 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
5222 pres
= SCM_CDRLOC (*pres
);
5223 arg1
= SCM_CDR (arg1
);
5227 if (SCM_NULLP (SCM_CDR (args
)))
5229 SCM arg2
= SCM_CAR (args
);
5230 int len2
= scm_ilength (arg2
);
5231 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5233 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
5234 SCM_GASSERTn (len2
>= 0,
5235 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
5237 SCM_OUT_OF_RANGE (3, arg2
);
5238 while (SCM_NIMP (arg1
))
5240 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
5241 pres
= SCM_CDRLOC (*pres
);
5242 arg1
= SCM_CDR (arg1
);
5243 arg2
= SCM_CDR (arg2
);
5247 arg1
= scm_cons (arg1
, args
);
5248 args
= scm_vector (arg1
);
5249 ve
= SCM_VELTS (args
);
5250 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
5254 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5256 if (SCM_IMP (ve
[i
]))
5258 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
5259 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
5261 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
5262 pres
= SCM_CDRLOC (*pres
);
5268 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
5271 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
5272 #define FUNC_NAME s_for_each
5274 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
5276 len
= scm_ilength (arg1
);
5277 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
5278 SCM_ARG2
, s_for_each
);
5279 SCM_VALIDATE_REST_ARGUMENT (args
);
5280 if (SCM_NULLP (args
))
5282 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5283 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
5284 while (SCM_NIMP (arg1
))
5286 call (proc
, SCM_CAR (arg1
));
5287 arg1
= SCM_CDR (arg1
);
5289 return SCM_UNSPECIFIED
;
5291 if (SCM_NULLP (SCM_CDR (args
)))
5293 SCM arg2
= SCM_CAR (args
);
5294 int len2
= scm_ilength (arg2
);
5295 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5296 SCM_GASSERTn (call
, g_for_each
,
5297 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
5298 SCM_GASSERTn (len2
>= 0, g_for_each
,
5299 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
5301 SCM_OUT_OF_RANGE (3, arg2
);
5302 while (SCM_NIMP (arg1
))
5304 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
5305 arg1
= SCM_CDR (arg1
);
5306 arg2
= SCM_CDR (arg2
);
5308 return SCM_UNSPECIFIED
;
5310 arg1
= scm_cons (arg1
, args
);
5311 args
= scm_vector (arg1
);
5312 ve
= SCM_VELTS (args
);
5313 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
5317 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5319 if (SCM_IMP (ve
[i
]))
5320 return SCM_UNSPECIFIED
;
5321 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
5322 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
5324 scm_apply (proc
, arg1
, SCM_EOL
);
5331 scm_closure (SCM code
, SCM env
)
5334 SCM closcar
= scm_cons (code
, SCM_EOL
);
5335 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
5336 scm_remember_upto_here (closcar
);
5341 scm_t_bits scm_tc16_promise
;
5344 scm_makprom (SCM code
)
5346 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
5348 scm_make_rec_mutex ());
5352 promise_free (SCM promise
)
5354 scm_rec_mutex_free (SCM_PROMISE_MUTEX (promise
));
5359 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
5361 int writingp
= SCM_WRITINGP (pstate
);
5362 scm_puts ("#<promise ", port
);
5363 SCM_SET_WRITINGP (pstate
, 1);
5364 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
5365 SCM_SET_WRITINGP (pstate
, writingp
);
5366 scm_putc ('>', port
);
5370 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
5372 "If the promise @var{x} has not been computed yet, compute and\n"
5373 "return @var{x}, otherwise just return the previously computed\n"
5375 #define FUNC_NAME s_scm_force
5377 SCM_VALIDATE_SMOB (1, promise
, promise
);
5378 scm_rec_mutex_lock (SCM_PROMISE_MUTEX (promise
));
5379 if (!SCM_PROMISE_COMPUTED_P (promise
))
5381 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
5382 if (!SCM_PROMISE_COMPUTED_P (promise
))
5384 SCM_SET_PROMISE_DATA (promise
, ans
);
5385 SCM_SET_PROMISE_COMPUTED (promise
);
5388 scm_rec_mutex_unlock (SCM_PROMISE_MUTEX (promise
));
5389 return SCM_PROMISE_DATA (promise
);
5394 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
5396 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
5397 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
5398 #define FUNC_NAME s_scm_promise_p
5400 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
5405 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
5406 (SCM xorig
, SCM x
, SCM y
),
5407 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
5408 "Any source properties associated with @var{xorig} are also associated\n"
5409 "with the new pair.")
5410 #define FUNC_NAME s_scm_cons_source
5413 z
= scm_cons (x
, y
);
5414 /* Copy source properties possibly associated with xorig. */
5415 p
= scm_whash_lookup (scm_source_whash
, xorig
);
5417 scm_whash_insert (scm_source_whash
, z
, p
);
5423 /* The function scm_copy_tree is used to copy an expression tree to allow the
5424 * memoizer to modify the expression during memoization. scm_copy_tree
5425 * creates deep copies of pairs and vectors, but not of any other data types,
5426 * since only pairs and vectors will be parsed by the memoizer.
5428 * To avoid infinite recursion due to cyclic structures, the hare-and-tortoise
5429 * pattern is used to detect cycles. In fact, the pattern is used in two
5430 * dimensions, vertical (indicated in the code by the variable names 'hare'
5431 * and 'tortoise') and horizontal ('rabbit' and 'turtle'). In both
5432 * dimensions, the hare/rabbit will take two steps when the tortoise/turtle
5435 * The vertical dimension corresponds to recursive calls to function
5436 * copy_tree: This happens when descending into vector elements, into cars of
5437 * lists and into the cdr of an improper list. In this dimension, the
5438 * tortoise follows the hare by using the processor stack: Every stack frame
5439 * will hold an instance of struct t_trace. These instances are connected in
5440 * a way that represents the trace of the hare, which thus can be followed by
5441 * the tortoise. The tortoise will always point to struct t_trace instances
5442 * relating to SCM objects that have already been copied. Thus, a cycle is
5443 * detected if the tortoise and the hare point to the same object,
5445 * The horizontal dimension is within one execution of copy_tree, when the
5446 * function cdr's along the pairs of a list. This is the standard
5447 * hare-and-tortoise implementation, found several times in guile. */
5450 struct t_trace
*trace
; // These pointers form a trace along the stack.
5451 SCM obj
; // The object handled at the respective stack frame.
5456 struct t_trace
*const hare
,
5457 struct t_trace
*tortoise
,
5458 unsigned int tortoise_delay
)
5460 if (!SCM_CONSP (hare
->obj
) && !SCM_VECTORP (hare
->obj
))
5466 /* Prepare the trace along the stack. */
5467 struct t_trace new_hare
;
5468 hare
->trace
= &new_hare
;
5470 /* The tortoise will make its step after the delay has elapsed. Note
5471 * that in contrast to the typical hare-and-tortoise pattern, the step
5472 * of the tortoise happens before the hare takes its steps. This is, in
5473 * principle, no problem, except for the start of the algorithm: Then,
5474 * it has to be made sure that the hare actually gets its advantage of
5476 if (tortoise_delay
== 0)
5479 tortoise
= tortoise
->trace
;
5480 ASSERT_SYNTAX (!SCM_EQ_P (hare
->obj
, tortoise
->obj
),
5481 s_bad_expression
, hare
->obj
);
5488 if (SCM_VECTORP (hare
->obj
))
5490 const unsigned long int length
= SCM_VECTOR_LENGTH (hare
->obj
);
5491 const SCM new_vector
= scm_c_make_vector (length
, SCM_UNSPECIFIED
);
5493 /* Each vector element is copied by recursing into copy_tree, having
5494 * the tortoise follow the hare into the depths of the stack. */
5495 unsigned long int i
;
5496 for (i
= 0; i
< length
; ++i
)
5499 new_hare
.obj
= SCM_VECTOR_REF (hare
->obj
, i
);
5500 new_element
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5501 SCM_VECTOR_SET (new_vector
, i
, new_element
);
5506 else // SCM_CONSP (hare->obj)
5511 SCM rabbit
= hare
->obj
;
5512 SCM turtle
= hare
->obj
;
5516 /* The first pair of the list is treated specially, in order to
5517 * preserve a potential source code position. */
5518 result
= tail
= scm_cons_source (rabbit
, SCM_EOL
, SCM_EOL
);
5519 new_hare
.obj
= SCM_CAR (rabbit
);
5520 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5521 SCM_SETCAR (tail
, copy
);
5523 /* The remaining pairs of the list are copied by, horizontally,
5524 * having the turtle follow the rabbit, and, vertically, having the
5525 * tortoise follow the hare into the depths of the stack. */
5526 rabbit
= SCM_CDR (rabbit
);
5527 while (SCM_CONSP (rabbit
))
5529 new_hare
.obj
= SCM_CAR (rabbit
);
5530 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5531 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
5532 tail
= SCM_CDR (tail
);
5534 rabbit
= SCM_CDR (rabbit
);
5535 if (SCM_CONSP (rabbit
))
5537 new_hare
.obj
= SCM_CAR (rabbit
);
5538 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5539 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
5540 tail
= SCM_CDR (tail
);
5541 rabbit
= SCM_CDR (rabbit
);
5543 turtle
= SCM_CDR (turtle
);
5544 ASSERT_SYNTAX (!SCM_EQ_P (rabbit
, turtle
),
5545 s_bad_expression
, rabbit
);
5549 /* We have to recurse into copy_tree again for the last cdr, in
5550 * order to handle the situation that it holds a vector. */
5551 new_hare
.obj
= rabbit
;
5552 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5553 SCM_SETCDR (tail
, copy
);
5560 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
5562 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
5563 "the new data structure. @code{copy-tree} recurses down the\n"
5564 "contents of both pairs and vectors (since both cons cells and vector\n"
5565 "cells may point to arbitrary objects), and stops recursing when it hits\n"
5566 "any other object.")
5567 #define FUNC_NAME s_scm_copy_tree
5569 /* Prepare the trace along the stack. */
5570 struct t_trace trace
;
5573 /* In function copy_tree, if the tortoise makes its step, it will do this
5574 * before the hare has the chance to move. Thus, we have to make sure that
5575 * the very first step of the tortoise will not happen after the hare has
5576 * really made two steps. This is achieved by passing '2' as the initial
5577 * delay for the tortoise. NOTE: Since cycles are unlikely, giving the hare
5578 * a bigger advantage may improve performance slightly. */
5579 return copy_tree (&trace
, &trace
, 2);
5584 /* We have three levels of EVAL here:
5586 - scm_i_eval (exp, env)
5588 evaluates EXP in environment ENV. ENV is a lexical environment
5589 structure as used by the actual tree code evaluator. When ENV is
5590 a top-level environment, then changes to the current module are
5591 tracked by updating ENV so that it continues to be in sync with
5594 - scm_primitive_eval (exp)
5596 evaluates EXP in the top-level environment as determined by the
5597 current module. This is done by constructing a suitable
5598 environment and calling scm_i_eval. Thus, changes to the
5599 top-level module are tracked normally.
5601 - scm_eval (exp, mod)
5603 evaluates EXP while MOD is the current module. This is done by
5604 setting the current module to MOD, invoking scm_primitive_eval on
5605 EXP, and then restoring the current module to the value it had
5606 previously. That is, while EXP is evaluated, changes to the
5607 current module are tracked, but these changes do not persist when
5610 For each level of evals, there are two variants, distinguished by a
5611 _x suffix: the ordinary variant does not modify EXP while the _x
5612 variant can destructively modify EXP into something completely
5613 unintelligible. A Scheme data structure passed as EXP to one of the
5614 _x variants should not ever be used again for anything. So when in
5615 doubt, use the ordinary variant.
5620 scm_i_eval_x (SCM exp
, SCM env
)
5622 if (SCM_SYMBOLP (exp
))
5623 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
5625 return SCM_XEVAL (exp
, env
);
5629 scm_i_eval (SCM exp
, SCM env
)
5631 exp
= scm_copy_tree (exp
);
5632 if (SCM_SYMBOLP (exp
))
5633 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
5635 return SCM_XEVAL (exp
, env
);
5639 scm_primitive_eval_x (SCM exp
)
5642 SCM transformer
= scm_current_module_transformer ();
5643 if (SCM_NIMP (transformer
))
5644 exp
= scm_call_1 (transformer
, exp
);
5645 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5646 return scm_i_eval_x (exp
, env
);
5649 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
5651 "Evaluate @var{exp} in the top-level environment specified by\n"
5652 "the current module.")
5653 #define FUNC_NAME s_scm_primitive_eval
5656 SCM transformer
= scm_current_module_transformer ();
5657 if (SCM_NIMP (transformer
))
5658 exp
= scm_call_1 (transformer
, exp
);
5659 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5660 return scm_i_eval (exp
, env
);
5665 /* Eval does not take the second arg optionally. This is intentional
5666 * in order to be R5RS compatible, and to prepare for the new module
5667 * system, where we would like to make the choice of evaluation
5668 * environment explicit. */
5671 change_environment (void *data
)
5673 SCM pair
= SCM_PACK (data
);
5674 SCM new_module
= SCM_CAR (pair
);
5675 SCM old_module
= scm_current_module ();
5676 SCM_SETCDR (pair
, old_module
);
5677 scm_set_current_module (new_module
);
5681 restore_environment (void *data
)
5683 SCM pair
= SCM_PACK (data
);
5684 SCM old_module
= SCM_CDR (pair
);
5685 SCM new_module
= scm_current_module ();
5686 SCM_SETCAR (pair
, new_module
);
5687 scm_set_current_module (old_module
);
5691 inner_eval_x (void *data
)
5693 return scm_primitive_eval_x (SCM_PACK(data
));
5697 scm_eval_x (SCM exp
, SCM module
)
5698 #define FUNC_NAME "eval!"
5700 SCM_VALIDATE_MODULE (2, module
);
5702 return scm_internal_dynamic_wind
5703 (change_environment
, inner_eval_x
, restore_environment
,
5704 (void *) SCM_UNPACK (exp
),
5705 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
5710 inner_eval (void *data
)
5712 return scm_primitive_eval (SCM_PACK(data
));
5715 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
5716 (SCM exp
, SCM module
),
5717 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
5718 "in the top-level environment specified by @var{module}.\n"
5719 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
5720 "@var{module} is made the current module. The current module\n"
5721 "is reset to its previous value when @var{eval} returns.")
5722 #define FUNC_NAME s_scm_eval
5724 SCM_VALIDATE_MODULE (2, module
);
5726 return scm_internal_dynamic_wind
5727 (change_environment
, inner_eval
, restore_environment
,
5728 (void *) SCM_UNPACK (exp
),
5729 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
5734 /* At this point, deval and scm_dapply are generated.
5741 #if (SCM_ENABLE_DEPRECATED == 1)
5743 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5744 SCM
scm_ceval (SCM x
, SCM env
)
5747 return ceval (x
, env
);
5748 else if (SCM_SYMBOLP (x
))
5749 return *scm_lookupcar (scm_cons (x
, SCM_UNDEFINED
), env
, 1);
5751 return SCM_XEVAL (x
, env
);
5754 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5755 SCM
scm_deval (SCM x
, SCM env
)
5758 return deval (x
, env
);
5759 else if (SCM_SYMBOLP (x
))
5760 return *scm_lookupcar (scm_cons (x
, SCM_UNDEFINED
), env
, 1);
5762 return SCM_XEVAL (x
, env
);
5766 dispatching_eval (SCM x
, SCM env
)
5768 if (scm_debug_mode_p
)
5769 return scm_deval (x
, env
);
5771 return scm_ceval (x
, env
);
5774 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5775 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
) = dispatching_eval
;
5783 scm_init_opts (scm_evaluator_traps
,
5784 scm_evaluator_trap_table
,
5785 SCM_N_EVALUATOR_TRAPS
);
5786 scm_init_opts (scm_eval_options_interface
,
5788 SCM_N_EVAL_OPTIONS
);
5790 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
5791 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
5792 scm_set_smob_free (scm_tc16_promise
, promise_free
);
5793 scm_set_smob_print (scm_tc16_promise
, promise_print
);
5795 undefineds
= scm_list_1 (SCM_UNDEFINED
);
5796 SCM_SETCDR (undefineds
, undefineds
);
5797 scm_permanent_object (undefineds
);
5799 scm_listofnull
= scm_list_1 (SCM_EOL
);
5801 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
5802 scm_permanent_object (f_apply
);
5804 #include "libguile/eval.x"
5806 scm_add_feature ("delay");