1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004
2 * Free Software Foundation, Inc.
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public
6 * License as published by the Free Software Foundation; either
7 * version 2.1 of the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
21 /* This file is read twice in order to produce debugging versions of ceval and
22 * scm_apply. These functions, deval and scm_dapply, are produced when we
23 * define the preprocessor macro DEVAL. The file is divided into sections
24 * which are treated differently with respect to DEVAL. The heads of these
25 * sections are marked with the string "SECTION:". */
27 /* SECTION: This code is compiled once.
34 #include "libguile/__scm.h"
38 /* AIX requires this to be the first thing in the file. The #pragma
39 directive is indented so pre-ANSI compilers will ignore it, rather
48 # ifndef alloca /* predefined by HP cc +Olibcalls */
56 #include "libguile/_scm.h"
57 #include "libguile/alist.h"
58 #include "libguile/async.h"
59 #include "libguile/continuations.h"
60 #include "libguile/debug.h"
61 #include "libguile/deprecation.h"
62 #include "libguile/dynwind.h"
63 #include "libguile/eq.h"
64 #include "libguile/feature.h"
65 #include "libguile/fluids.h"
66 #include "libguile/futures.h"
67 #include "libguile/goops.h"
68 #include "libguile/hash.h"
69 #include "libguile/hashtab.h"
70 #include "libguile/lang.h"
71 #include "libguile/list.h"
72 #include "libguile/macros.h"
73 #include "libguile/modules.h"
74 #include "libguile/objects.h"
75 #include "libguile/ports.h"
76 #include "libguile/print.h"
77 #include "libguile/procprop.h"
78 #include "libguile/root.h"
79 #include "libguile/smob.h"
80 #include "libguile/srcprop.h"
81 #include "libguile/stackchk.h"
82 #include "libguile/strings.h"
83 #include "libguile/throw.h"
84 #include "libguile/validate.h"
85 #include "libguile/values.h"
86 #include "libguile/vectors.h"
88 #include "libguile/eval.h"
92 static SCM
unmemoize_exprs (SCM expr
, SCM env
);
93 static SCM
canonicalize_define (SCM expr
);
94 static SCM
*scm_lookupcar1 (SCM vloc
, SCM genv
, int check
);
95 static SCM
unmemoize_builtin_macro (SCM expr
, SCM env
);
101 * This section defines the message strings for the syntax errors that can be
102 * detected during memoization and the functions and macros that shall be
103 * called by the memoizer code to signal syntax errors. */
106 /* Syntax errors that can be detected during memoization: */
108 /* Circular or improper lists do not form valid scheme expressions. If a
109 * circular list or an improper list is detected in a place where a scheme
110 * expression is expected, a 'Bad expression' error is signalled. */
111 static const char s_bad_expression
[] = "Bad expression";
113 /* If a form is detected that holds a different number of expressions than are
114 * required in that context, a 'Missing or extra expression' error is
116 static const char s_expression
[] = "Missing or extra expression in";
118 /* If a form is detected that holds less expressions than are required in that
119 * context, a 'Missing expression' error is signalled. */
120 static const char s_missing_expression
[] = "Missing expression in";
122 /* If a form is detected that holds more expressions than are allowed in that
123 * context, an 'Extra expression' error is signalled. */
124 static const char s_extra_expression
[] = "Extra expression in";
126 /* The empty combination '()' is not allowed as an expression in scheme. If
127 * it is detected in a place where an expression is expected, an 'Illegal
128 * empty combination' error is signalled. Note: If you encounter this error
129 * message, it is very likely that you intended to denote the empty list. To
130 * do so, you need to quote the empty list like (quote ()) or '(). */
131 static const char s_empty_combination
[] = "Illegal empty combination";
133 /* A body may hold an arbitrary number of internal defines, followed by a
134 * non-empty sequence of expressions. If a body with an empty sequence of
135 * expressions is detected, a 'Missing body expression' error is signalled.
137 static const char s_missing_body_expression
[] = "Missing body expression in";
139 /* A body may hold an arbitrary number of internal defines, followed by a
140 * non-empty sequence of expressions. Each the definitions and the
141 * expressions may be grouped arbitraryly with begin, but it is not allowed to
142 * mix definitions and expressions. If a define form in a body mixes
143 * definitions and expressions, a 'Mixed definitions and expressions' error is
145 static const char s_mixed_body_forms
[] = "Mixed definitions and expressions in";
146 /* Definitions are only allowed on the top level and at the start of a body.
147 * If a definition is detected anywhere else, a 'Bad define placement' error
149 static const char s_bad_define
[] = "Bad define placement";
151 /* Case or cond expressions must have at least one clause. If a case or cond
152 * expression without any clauses is detected, a 'Missing clauses' error is
154 static const char s_missing_clauses
[] = "Missing clauses";
156 /* If there is an 'else' clause in a case or a cond statement, it must be the
157 * last clause. If after the 'else' case clause further clauses are detected,
158 * a 'Misplaced else clause' error is signalled. */
159 static const char s_misplaced_else_clause
[] = "Misplaced else clause";
161 /* If a case clause is detected that is not in the format
162 * (<label(s)> <expression1> <expression2> ...)
163 * a 'Bad case clause' error is signalled. */
164 static const char s_bad_case_clause
[] = "Bad case clause";
166 /* If a case clause is detected where the <label(s)> element is neither a
167 * proper list nor (in case of the last clause) the syntactic keyword 'else',
168 * a 'Bad case labels' error is signalled. Note: If you encounter this error
169 * for an else-clause which seems to be syntactically correct, check if 'else'
170 * is really a syntactic keyword in that context. If 'else' is bound in the
171 * local or global environment, it is not considered a syntactic keyword, but
172 * will be treated as any other variable. */
173 static const char s_bad_case_labels
[] = "Bad case labels";
175 /* In a case statement all labels have to be distinct. If in a case statement
176 * a label occurs more than once, a 'Duplicate case label' error is
178 static const char s_duplicate_case_label
[] = "Duplicate case label";
180 /* If a cond clause is detected that is not in one of the formats
181 * (<test> <expression1> ...) or (else <expression1> <expression2> ...)
182 * a 'Bad cond clause' error is signalled. */
183 static const char s_bad_cond_clause
[] = "Bad cond clause";
185 /* If a cond clause is detected that uses the alternate '=>' form, but does
186 * not hold a recipient element for the test result, a 'Missing recipient'
187 * error is signalled. */
188 static const char s_missing_recipient
[] = "Missing recipient in";
190 /* If in a position where a variable name is required some other object is
191 * detected, a 'Bad variable' error is signalled. */
192 static const char s_bad_variable
[] = "Bad variable";
194 /* Bindings for forms like 'let' and 'do' have to be given in a proper,
195 * possibly empty list. If any other object is detected in a place where a
196 * list of bindings was required, a 'Bad bindings' error is signalled. */
197 static const char s_bad_bindings
[] = "Bad bindings";
199 /* Depending on the syntactic context, a binding has to be in the format
200 * (<variable> <expression>) or (<variable> <expression1> <expression2>).
201 * If anything else is detected in a place where a binding was expected, a
202 * 'Bad binding' error is signalled. */
203 static const char s_bad_binding
[] = "Bad binding";
205 /* Some syntactic forms don't allow variable names to appear more than once in
206 * a list of bindings. If such a situation is nevertheless detected, a
207 * 'Duplicate binding' error is signalled. */
208 static const char s_duplicate_binding
[] = "Duplicate binding";
210 /* If the exit form of a 'do' expression is not in the format
211 * (<test> <expression> ...)
212 * a 'Bad exit clause' error is signalled. */
213 static const char s_bad_exit_clause
[] = "Bad exit clause";
215 /* The formal function arguments of a lambda expression have to be either a
216 * single symbol or a non-cyclic list. For anything else a 'Bad formals'
217 * error is signalled. */
218 static const char s_bad_formals
[] = "Bad formals";
220 /* If in a lambda expression something else than a symbol is detected at a
221 * place where a formal function argument is required, a 'Bad formal' error is
223 static const char s_bad_formal
[] = "Bad formal";
225 /* If in the arguments list of a lambda expression an argument name occurs
226 * more than once, a 'Duplicate formal' error is signalled. */
227 static const char s_duplicate_formal
[] = "Duplicate formal";
229 /* If the evaluation of an unquote-splicing expression gives something else
230 * than a proper list, a 'Non-list result for unquote-splicing' error is
232 static const char s_splicing
[] = "Non-list result for unquote-splicing";
234 /* If something else than an exact integer is detected as the argument for
235 * @slot-ref and @slot-set!, a 'Bad slot number' error is signalled. */
236 static const char s_bad_slot_number
[] = "Bad slot number";
239 /* Signal a syntax error. We distinguish between the form that caused the
240 * error and the enclosing expression. The error message will print out as
241 * shown in the following pattern. The file name and line number are only
242 * given when they can be determined from the erroneous form or from the
243 * enclosing expression.
245 * <filename>: In procedure memoization:
246 * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
248 SCM_SYMBOL (syntax_error_key
, "syntax-error");
250 /* The prototype is needed to indicate that the function does not return. */
252 syntax_error (const char* const, const SCM
, const SCM
) SCM_NORETURN
;
255 syntax_error (const char* const msg
, const SCM form
, const SCM expr
)
257 const SCM msg_string
= scm_makfrom0str (msg
);
258 SCM filename
= SCM_BOOL_F
;
259 SCM linenr
= SCM_BOOL_F
;
263 if (SCM_CONSP (form
))
265 filename
= scm_source_property (form
, scm_sym_filename
);
266 linenr
= scm_source_property (form
, scm_sym_line
);
269 if (SCM_FALSEP (filename
) && SCM_FALSEP (linenr
) && SCM_CONSP (expr
))
271 filename
= scm_source_property (expr
, scm_sym_filename
);
272 linenr
= scm_source_property (expr
, scm_sym_line
);
275 if (!SCM_UNBNDP (expr
))
277 if (!SCM_FALSEP (filename
))
279 format
= "In file ~S, line ~S: ~A ~S in expression ~S.";
280 args
= scm_list_5 (filename
, linenr
, msg_string
, form
, expr
);
282 else if (!SCM_FALSEP (linenr
))
284 format
= "In line ~S: ~A ~S in expression ~S.";
285 args
= scm_list_4 (linenr
, msg_string
, form
, expr
);
289 format
= "~A ~S in expression ~S.";
290 args
= scm_list_3 (msg_string
, form
, expr
);
295 if (!SCM_FALSEP (filename
))
297 format
= "In file ~S, line ~S: ~A ~S.";
298 args
= scm_list_4 (filename
, linenr
, msg_string
, form
);
300 else if (!SCM_FALSEP (linenr
))
302 format
= "In line ~S: ~A ~S.";
303 args
= scm_list_3 (linenr
, msg_string
, form
);
308 args
= scm_list_2 (msg_string
, form
);
312 scm_error (syntax_error_key
, "memoization", format
, args
, SCM_BOOL_F
);
316 /* Shortcut macros to simplify syntax error handling. */
317 #define ASSERT_SYNTAX(cond, message, form) \
318 { if (!(cond)) syntax_error (message, form, SCM_UNDEFINED); }
319 #define ASSERT_SYNTAX_2(cond, message, form, expr) \
320 { if (!(cond)) syntax_error (message, form, expr); }
326 * Ilocs are memoized references to variables in local environment frames.
327 * They are represented as three values: The relative offset of the
328 * environment frame, the number of the binding within that frame, and a
329 * boolean value indicating whether the binding is the last binding in the
333 #define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc)
334 #define SCM_IFRINC (0x00000100L)
335 #define SCM_ICDR (0x00080000L)
336 #define SCM_IDINC (0x00100000L)
337 #define SCM_IFRAME(n) ((long)((SCM_ICDR-SCM_IFRINC)>>8) \
338 & (SCM_UNPACK (n) >> 8))
339 #define SCM_IDIST(n) (SCM_UNPACK (n) >> 20)
340 #define SCM_ICDRP(n) (SCM_ICDR & SCM_UNPACK (n))
341 #define SCM_IDSTMSK (-SCM_IDINC)
342 #define SCM_MAKE_ILOC(frame_nr, binding_nr, last_p) \
345 + ((binding_nr) << 20) \
346 + ((last_p) ? SCM_ICDR : 0) \
350 scm_i_print_iloc (SCM iloc
, SCM port
)
352 scm_puts ("#@", port
);
353 scm_intprint ((long) SCM_IFRAME (iloc
), 10, port
);
354 scm_putc (SCM_ICDRP (iloc
) ? '-' : '+', port
);
355 scm_intprint ((long) SCM_IDIST (iloc
), 10, port
);
358 #if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
360 SCM
scm_dbg_make_iloc (SCM frame
, SCM binding
, SCM cdrp
);
361 SCM_DEFINE (scm_dbg_make_iloc
, "dbg-make-iloc", 3, 0, 0,
362 (SCM frame
, SCM binding
, SCM cdrp
),
363 "Return a new iloc with frame offset @var{frame}, binding\n"
364 "offset @var{binding} and the cdr flag @var{cdrp}.")
365 #define FUNC_NAME s_scm_dbg_make_iloc
367 SCM_VALIDATE_INUM (1, frame
);
368 SCM_VALIDATE_INUM (2, binding
);
369 return SCM_MAKE_ILOC (SCM_INUM (frame
),
375 SCM
scm_dbg_iloc_p (SCM obj
);
376 SCM_DEFINE (scm_dbg_iloc_p
, "dbg-iloc?", 1, 0, 0,
378 "Return @code{#t} if @var{obj} is an iloc.")
379 #define FUNC_NAME s_scm_dbg_iloc_p
381 return SCM_BOOL (SCM_ILOCP (obj
));
389 /* {Evaluator byte codes (isyms)}
392 #define ISYMNUM(n) (SCM_ITAG8_DATA (n))
394 /* This table must agree with the list of SCM_IM_ constants in tags.h */
395 static const char *const isymnames
[] =
412 "#@call-with-current-continuation",
418 "#@call-with-values",
426 scm_i_print_isym (SCM isym
, SCM port
)
428 const size_t isymnum
= ISYMNUM (isym
);
429 if (isymnum
< (sizeof isymnames
/ sizeof (char *)))
430 scm_puts (isymnames
[isymnum
], port
);
432 scm_ipruk ("isym", isym
, port
);
437 /* The function lookup_symbol is used during memoization: Lookup the symbol in
438 * the environment. If there is no binding for the symbol, SCM_UNDEFINED is
439 * returned. If the symbol is a global variable, the variable object to which
440 * the symbol is bound is returned. Finally, if the symbol is a local
441 * variable the corresponding iloc object is returned. */
443 /* A helper function for lookup_symbol: Try to find the symbol in the top
444 * level environment frame. The function returns SCM_UNDEFINED if the symbol
445 * is unbound and it returns a variable object if the symbol is a global
448 lookup_global_symbol (const SCM symbol
, const SCM top_level
)
450 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
451 if (SCM_FALSEP (variable
))
452 return SCM_UNDEFINED
;
458 lookup_symbol (const SCM symbol
, const SCM env
)
461 unsigned int frame_nr
;
463 for (frame_idx
= env
, frame_nr
= 0;
464 !SCM_NULLP (frame_idx
);
465 frame_idx
= SCM_CDR (frame_idx
), ++frame_nr
)
467 const SCM frame
= SCM_CAR (frame_idx
);
468 if (SCM_CONSP (frame
))
470 /* frame holds a local environment frame */
472 unsigned int symbol_nr
;
474 for (symbol_idx
= SCM_CAR (frame
), symbol_nr
= 0;
475 SCM_CONSP (symbol_idx
);
476 symbol_idx
= SCM_CDR (symbol_idx
), ++symbol_nr
)
478 if (SCM_EQ_P (SCM_CAR (symbol_idx
), symbol
))
479 /* found the symbol, therefore return the iloc */
480 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 0);
482 if (SCM_EQ_P (symbol_idx
, symbol
))
483 /* found the symbol as the last element of the current frame */
484 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 1);
488 /* no more local environment frames */
489 return lookup_global_symbol (symbol
, frame
);
493 return lookup_global_symbol (symbol
, SCM_BOOL_F
);
497 /* Return true if the symbol is - from the point of view of a macro
498 * transformer - a literal in the sense specified in chapter "pattern
499 * language" of R5RS. In the code below, however, we don't match the
500 * definition of R5RS exactly: It returns true if the identifier has no
501 * binding or if it is a syntactic keyword. */
503 literal_p (const SCM symbol
, const SCM env
)
505 const SCM variable
= lookup_symbol (symbol
, env
);
506 if (SCM_UNBNDP (variable
))
508 if (SCM_VARIABLEP (variable
) && SCM_MACROP (SCM_VARIABLE_REF (variable
)))
515 /* Return true if the expression is self-quoting in the memoized code. Thus,
516 * some other objects (like e. g. vectors) are reported as self-quoting, which
517 * according to R5RS would need to be quoted. */
519 is_self_quoting_p (const SCM expr
)
521 if (SCM_CONSP (expr
))
523 else if (SCM_SYMBOLP (expr
))
525 else if (SCM_NULLP (expr
))
531 SCM_SYMBOL (sym_three_question_marks
, "???");
534 unmemoize_expression (const SCM expr
, const SCM env
)
536 if (SCM_ILOCP (expr
))
539 unsigned long int frame_nr
;
541 unsigned long int symbol_nr
;
543 for (frame_idx
= env
, frame_nr
= SCM_IFRAME (expr
);
545 frame_idx
= SCM_CDR (frame_idx
), --frame_nr
)
547 for (symbol_idx
= SCM_CAAR (frame_idx
), symbol_nr
= SCM_IDIST (expr
);
549 symbol_idx
= SCM_CDR (symbol_idx
), --symbol_nr
)
551 return SCM_ICDRP (expr
) ? symbol_idx
: SCM_CAR (symbol_idx
);
553 else if (SCM_VARIABLEP (expr
))
555 const SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), expr
);
556 return !SCM_FALSEP (sym
) ? sym
: sym_three_question_marks
;
558 else if (SCM_VECTORP (expr
))
560 return scm_list_2 (scm_sym_quote
, expr
);
562 else if (!SCM_CONSP (expr
))
566 else if (SCM_ISYMP (SCM_CAR (expr
)))
568 return unmemoize_builtin_macro (expr
, env
);
572 return unmemoize_exprs (expr
, env
);
578 unmemoize_exprs (const SCM exprs
, const SCM env
)
580 SCM result
= SCM_EOL
;
583 for (expr_idx
= exprs
; SCM_CONSP (expr_idx
); expr_idx
= SCM_CDR (expr_idx
))
585 const SCM expr
= SCM_CAR (expr_idx
);
586 const SCM um_expr
= unmemoize_expression (expr
, env
);
587 result
= scm_cons (um_expr
, result
);
590 return scm_reverse_x (result
, SCM_UNDEFINED
);
594 /* Rewrite the body (which is given as the list of expressions forming the
595 * body) into its internal form. The internal form of a body (<expr> ...) is
596 * just the body itself, but prefixed with an ISYM that denotes to what kind
597 * of outer construct this body belongs: (<ISYM> <expr> ...). A lambda body
598 * starts with SCM_IM_LAMBDA, for example, a body of a let starts with
601 * It is assumed that the calling expression has already made sure that the
602 * body is a proper list. */
604 m_body (SCM op
, SCM exprs
)
606 /* Don't add another ISYM if one is present already. */
607 if (SCM_ISYMP (SCM_CAR (exprs
)))
610 return scm_cons (op
, exprs
);
614 /* The function m_expand_body memoizes a proper list of expressions forming a
615 * body. This function takes care of dealing with internal defines and
616 * transforming them into an equivalent letrec expression. The list of
617 * expressions is rewritten in place. */
619 /* This is a helper function for m_expand_body. If the argument expression is
620 * a symbol that denotes a syntactic keyword, the corresponding macro object
621 * is returned, in all other cases the function returns SCM_UNDEFINED. */
623 try_macro_lookup (const SCM expr
, const SCM env
)
625 if (SCM_SYMBOLP (expr
))
627 const SCM variable
= lookup_symbol (expr
, env
);
628 if (SCM_VARIABLEP (variable
))
630 const SCM value
= SCM_VARIABLE_REF (variable
);
631 if (SCM_MACROP (value
))
636 return SCM_UNDEFINED
;
639 /* This is a helper function for m_expand_body. It expands user macros,
640 * because for the correct translation of a body we need to know whether they
641 * expand to a definition. */
643 expand_user_macros (SCM expr
, const SCM env
)
645 while (SCM_CONSP (expr
))
647 const SCM car_expr
= SCM_CAR (expr
);
648 const SCM new_car
= expand_user_macros (car_expr
, env
);
649 const SCM value
= try_macro_lookup (new_car
, env
);
651 if (SCM_MACROP (value
) && SCM_MACRO_TYPE (value
) == 2)
653 /* User macros transform code into code. */
654 expr
= scm_call_2 (SCM_MACRO_CODE (value
), expr
, env
);
655 /* We need to reiterate on the transformed code. */
659 /* No user macro: return. */
660 SCM_SETCAR (expr
, new_car
);
668 /* This is a helper function for m_expand_body. It determines if a given form
669 * represents an application of a given built-in macro. The built-in macro to
670 * check for is identified by its syntactic keyword. The form is an
671 * application of the given macro if looking up the car of the form in the
672 * given environment actually returns the built-in macro. */
674 is_system_macro_p (const SCM syntactic_keyword
, const SCM form
, const SCM env
)
676 if (SCM_CONSP (form
))
678 const SCM car_form
= SCM_CAR (form
);
679 const SCM value
= try_macro_lookup (car_form
, env
);
680 if (SCM_BUILTIN_MACRO_P (value
))
682 const SCM macro_name
= scm_macro_name (value
);
683 return SCM_EQ_P (macro_name
, syntactic_keyword
);
691 m_expand_body (const SCM forms
, const SCM env
)
693 /* The first body form can be skipped since it is known to be the ISYM that
694 * was prepended to the body by m_body. */
695 SCM cdr_forms
= SCM_CDR (forms
);
696 SCM form_idx
= cdr_forms
;
697 SCM definitions
= SCM_EOL
;
698 SCM sequence
= SCM_EOL
;
700 /* According to R5RS, the list of body forms consists of two parts: a number
701 * (maybe zero) of definitions, followed by a non-empty sequence of
702 * expressions. Each the definitions and the expressions may be grouped
703 * arbitrarily with begin, but it is not allowed to mix definitions and
704 * expressions. The task of the following loop therefore is to split the
705 * list of body forms into the list of definitions and the sequence of
707 while (!SCM_NULLP (form_idx
))
709 const SCM form
= SCM_CAR (form_idx
);
710 const SCM new_form
= expand_user_macros (form
, env
);
711 if (is_system_macro_p (scm_sym_define
, new_form
, env
))
713 definitions
= scm_cons (new_form
, definitions
);
714 form_idx
= SCM_CDR (form_idx
);
716 else if (is_system_macro_p (scm_sym_begin
, new_form
, env
))
718 /* We have encountered a group of forms. This has to be either a
719 * (possibly empty) group of (possibly further grouped) definitions,
720 * or a non-empty group of (possibly further grouped)
722 const SCM grouped_forms
= SCM_CDR (new_form
);
723 unsigned int found_definition
= 0;
724 unsigned int found_expression
= 0;
725 SCM grouped_form_idx
= grouped_forms
;
726 while (!found_expression
&& !SCM_NULLP (grouped_form_idx
))
728 const SCM inner_form
= SCM_CAR (grouped_form_idx
);
729 const SCM new_inner_form
= expand_user_macros (inner_form
, env
);
730 if (is_system_macro_p (scm_sym_define
, new_inner_form
, env
))
732 found_definition
= 1;
733 definitions
= scm_cons (new_inner_form
, definitions
);
734 grouped_form_idx
= SCM_CDR (grouped_form_idx
);
736 else if (is_system_macro_p (scm_sym_begin
, new_inner_form
, env
))
738 const SCM inner_group
= SCM_CDR (new_inner_form
);
740 = scm_append (scm_list_2 (inner_group
,
741 SCM_CDR (grouped_form_idx
)));
745 /* The group marks the start of the expressions of the body.
746 * We have to make sure that within the same group we have
747 * not encountered a definition before. */
748 ASSERT_SYNTAX (!found_definition
, s_mixed_body_forms
, form
);
749 found_expression
= 1;
750 grouped_form_idx
= SCM_EOL
;
754 /* We have finished processing the group. If we have not yet
755 * encountered an expression we continue processing the forms of the
756 * body to collect further definition forms. Otherwise, the group
757 * marks the start of the sequence of expressions of the body. */
758 if (!found_expression
)
760 form_idx
= SCM_CDR (form_idx
);
770 /* We have detected a form which is no definition. This marks the
771 * start of the sequence of expressions of the body. */
777 /* FIXME: forms does not hold information about the file location. */
778 ASSERT_SYNTAX (SCM_CONSP (sequence
), s_missing_body_expression
, cdr_forms
);
780 if (!SCM_NULLP (definitions
))
784 SCM letrec_expression
;
785 SCM new_letrec_expression
;
787 SCM bindings
= SCM_EOL
;
788 for (definition_idx
= definitions
;
789 !SCM_NULLP (definition_idx
);
790 definition_idx
= SCM_CDR (definition_idx
))
792 const SCM definition
= SCM_CAR (definition_idx
);
793 const SCM canonical_definition
= canonicalize_define (definition
);
794 const SCM binding
= SCM_CDR (canonical_definition
);
795 bindings
= scm_cons (binding
, bindings
);
798 letrec_tail
= scm_cons (bindings
, sequence
);
799 /* FIXME: forms does not hold information about the file location. */
800 letrec_expression
= scm_cons_source (forms
, scm_sym_letrec
, letrec_tail
);
801 new_letrec_expression
= scm_m_letrec (letrec_expression
, env
);
802 SCM_SETCAR (forms
, new_letrec_expression
);
803 SCM_SETCDR (forms
, SCM_EOL
);
807 SCM_SETCAR (forms
, SCM_CAR (sequence
));
808 SCM_SETCDR (forms
, SCM_CDR (sequence
));
813 macroexp (SCM x
, SCM env
)
815 SCM res
, proc
, orig_sym
;
817 /* Don't bother to produce error messages here. We get them when we
818 eventually execute the code for real. */
821 orig_sym
= SCM_CAR (x
);
822 if (!SCM_SYMBOLP (orig_sym
))
826 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
827 if (proc_ptr
== NULL
)
829 /* We have lost the race. */
835 /* Only handle memoizing macros. `Acros' and `macros' are really
836 special forms and should not be evaluated here. */
838 if (!SCM_MACROP (proc
)
839 || (SCM_MACRO_TYPE (proc
) != 2 && !SCM_BUILTIN_MACRO_P (proc
)))
842 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
843 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
845 if (scm_ilength (res
) <= 0)
846 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
849 SCM_SETCAR (x
, SCM_CAR (res
));
850 SCM_SETCDR (x
, SCM_CDR (res
));
856 /* Start of the memoizers for the standard R5RS builtin macros. */
859 SCM_SYNTAX (s_and
, "and", scm_i_makbimacro
, scm_m_and
);
860 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
863 scm_m_and (SCM expr
, SCM env SCM_UNUSED
)
865 const SCM cdr_expr
= SCM_CDR (expr
);
866 const long length
= scm_ilength (cdr_expr
);
868 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
872 /* Special case: (and) is replaced by #t. */
877 SCM_SETCAR (expr
, SCM_IM_AND
);
883 unmemoize_and (const SCM expr
, const SCM env
)
885 return scm_cons (scm_sym_and
, unmemoize_exprs (SCM_CDR (expr
), env
));
889 SCM_SYNTAX (s_begin
, "begin", scm_i_makbimacro
, scm_m_begin
);
890 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
893 scm_m_begin (SCM expr
, SCM env SCM_UNUSED
)
895 const SCM cdr_expr
= SCM_CDR (expr
);
896 /* Dirk:FIXME:: An empty begin clause is not generally allowed by R5RS.
897 * That means, there should be a distinction between uses of begin where an
898 * empty clause is OK and where it is not. */
899 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
901 SCM_SETCAR (expr
, SCM_IM_BEGIN
);
906 unmemoize_begin (const SCM expr
, const SCM env
)
908 return scm_cons (scm_sym_begin
, unmemoize_exprs (SCM_CDR (expr
), env
));
912 SCM_SYNTAX (s_case
, "case", scm_i_makbimacro
, scm_m_case
);
913 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
914 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
917 scm_m_case (SCM expr
, SCM env
)
920 SCM all_labels
= SCM_EOL
;
922 /* Check, whether 'else is a literal, i. e. not bound to a value. */
923 const int else_literal_p
= literal_p (scm_sym_else
, env
);
925 const SCM cdr_expr
= SCM_CDR (expr
);
926 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
927 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_clauses
, expr
);
929 clauses
= SCM_CDR (cdr_expr
);
930 while (!SCM_NULLP (clauses
))
934 const SCM clause
= SCM_CAR (clauses
);
935 ASSERT_SYNTAX_2 (scm_ilength (clause
) >= 2,
936 s_bad_case_clause
, clause
, expr
);
938 labels
= SCM_CAR (clause
);
939 if (SCM_CONSP (labels
))
941 ASSERT_SYNTAX_2 (scm_ilength (labels
) >= 0,
942 s_bad_case_labels
, labels
, expr
);
943 all_labels
= scm_append (scm_list_2 (labels
, all_labels
));
945 else if (SCM_NULLP (labels
))
947 /* The list of labels is empty. According to R5RS this is allowed.
948 * It means that the sequence of expressions will never be executed.
949 * Therefore, as an optimization, we could remove the whole
954 ASSERT_SYNTAX_2 (SCM_EQ_P (labels
, scm_sym_else
) && else_literal_p
,
955 s_bad_case_labels
, labels
, expr
);
956 ASSERT_SYNTAX_2 (SCM_NULLP (SCM_CDR (clauses
)),
957 s_misplaced_else_clause
, clause
, expr
);
960 /* build the new clause */
961 if (SCM_EQ_P (labels
, scm_sym_else
))
962 SCM_SETCAR (clause
, SCM_IM_ELSE
);
964 clauses
= SCM_CDR (clauses
);
967 /* Check whether all case labels are distinct. */
968 for (; !SCM_NULLP (all_labels
); all_labels
= SCM_CDR (all_labels
))
970 const SCM label
= SCM_CAR (all_labels
);
971 ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (label
, SCM_CDR (all_labels
))),
972 s_duplicate_case_label
, label
, expr
);
975 SCM_SETCAR (expr
, SCM_IM_CASE
);
980 unmemoize_case (const SCM expr
, const SCM env
)
982 const SCM um_key_expr
= unmemoize_expression (SCM_CADR (expr
), env
);
983 SCM um_clauses
= SCM_EOL
;
986 for (clause_idx
= SCM_CDDR (expr
);
987 !SCM_NULLP (clause_idx
);
988 clause_idx
= SCM_CDR (clause_idx
))
990 const SCM clause
= SCM_CAR (clause_idx
);
991 const SCM labels
= SCM_CAR (clause
);
992 const SCM exprs
= SCM_CDR (clause
);
994 const SCM um_exprs
= unmemoize_exprs (exprs
, env
);
995 const SCM um_labels
= (SCM_EQ_P (labels
, SCM_IM_ELSE
))
997 : scm_i_finite_list_copy (labels
);
998 const SCM um_clause
= scm_cons (um_labels
, um_exprs
);
1000 um_clauses
= scm_cons (um_clause
, um_clauses
);
1002 um_clauses
= scm_reverse_x (um_clauses
, SCM_UNDEFINED
);
1004 return scm_cons2 (scm_sym_case
, um_key_expr
, um_clauses
);
1008 SCM_SYNTAX (s_cond
, "cond", scm_i_makbimacro
, scm_m_cond
);
1009 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
1010 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
1013 scm_m_cond (SCM expr
, SCM env
)
1015 /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
1016 const int else_literal_p
= literal_p (scm_sym_else
, env
);
1017 const int arrow_literal_p
= literal_p (scm_sym_arrow
, env
);
1019 const SCM clauses
= SCM_CDR (expr
);
1022 ASSERT_SYNTAX (scm_ilength (clauses
) >= 0, s_bad_expression
, expr
);
1023 ASSERT_SYNTAX (scm_ilength (clauses
) >= 1, s_missing_clauses
, expr
);
1025 for (clause_idx
= clauses
;
1026 !SCM_NULLP (clause_idx
);
1027 clause_idx
= SCM_CDR (clause_idx
))
1031 const SCM clause
= SCM_CAR (clause_idx
);
1032 const long length
= scm_ilength (clause
);
1033 ASSERT_SYNTAX_2 (length
>= 1, s_bad_cond_clause
, clause
, expr
);
1035 test
= SCM_CAR (clause
);
1036 if (SCM_EQ_P (test
, scm_sym_else
) && else_literal_p
)
1038 const int last_clause_p
= SCM_NULLP (SCM_CDR (clause_idx
));
1039 ASSERT_SYNTAX_2 (length
>= 2,
1040 s_bad_cond_clause
, clause
, expr
);
1041 ASSERT_SYNTAX_2 (last_clause_p
,
1042 s_misplaced_else_clause
, clause
, expr
);
1043 SCM_SETCAR (clause
, SCM_IM_ELSE
);
1045 else if (length
>= 2
1046 && SCM_EQ_P (SCM_CADR (clause
), scm_sym_arrow
)
1049 ASSERT_SYNTAX_2 (length
> 2, s_missing_recipient
, clause
, expr
);
1050 ASSERT_SYNTAX_2 (length
== 3, s_extra_expression
, clause
, expr
);
1051 SCM_SETCAR (SCM_CDR (clause
), SCM_IM_ARROW
);
1055 SCM_SETCAR (expr
, SCM_IM_COND
);
1060 unmemoize_cond (const SCM expr
, const SCM env
)
1062 SCM um_clauses
= SCM_EOL
;
1065 for (clause_idx
= SCM_CDR (expr
);
1066 !SCM_NULLP (clause_idx
);
1067 clause_idx
= SCM_CDR (clause_idx
))
1069 const SCM clause
= SCM_CAR (clause_idx
);
1070 const SCM sequence
= SCM_CDR (clause
);
1071 const SCM test
= SCM_CAR (clause
);
1076 if (SCM_EQ_P (test
, SCM_IM_ELSE
))
1077 um_test
= scm_sym_else
;
1079 um_test
= unmemoize_expression (test
, env
);
1081 if (!SCM_NULLP (sequence
) && SCM_EQ_P (SCM_CAR (sequence
), SCM_IM_ARROW
))
1083 const SCM target
= SCM_CADR (sequence
);
1084 const SCM um_target
= unmemoize_expression (target
, env
);
1085 um_sequence
= scm_list_2 (scm_sym_arrow
, um_target
);
1089 um_sequence
= unmemoize_exprs (sequence
, env
);
1092 um_clause
= scm_cons (um_test
, um_sequence
);
1093 um_clauses
= scm_cons (um_clause
, um_clauses
);
1095 um_clauses
= scm_reverse_x (um_clauses
, SCM_UNDEFINED
);
1097 return scm_cons (scm_sym_cond
, um_clauses
);
1101 SCM_SYNTAX (s_define
, "define", scm_i_makbimacro
, scm_m_define
);
1102 SCM_GLOBAL_SYMBOL (scm_sym_define
, s_define
);
1104 /* Guile provides an extension to R5RS' define syntax to represent function
1105 * currying in a compact way. With this extension, it is allowed to write
1106 * (define <nested-variable> <body>), where <nested-variable> has of one of
1107 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
1108 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
1109 * should be either a sequence of zero or more variables, or a sequence of one
1110 * or more variables followed by a space-delimited period and another
1111 * variable. Each level of argument nesting wraps the <body> within another
1112 * lambda expression. For example, the following forms are allowed, each one
1113 * followed by an equivalent, more explicit implementation.
1115 * (define ((a b . c) . d) <body>) is equivalent to
1116 * (define a (lambda (b . c) (lambda d <body>)))
1118 * (define (((a) b) c . d) <body>) is equivalent to
1119 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
1121 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
1122 * module that does not implement this extension. */
1124 canonicalize_define (const SCM expr
)
1129 const SCM cdr_expr
= SCM_CDR (expr
);
1130 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1131 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1133 body
= SCM_CDR (cdr_expr
);
1134 variable
= SCM_CAR (cdr_expr
);
1135 while (SCM_CONSP (variable
))
1137 /* This while loop realizes function currying by variable nesting.
1138 * Variable is known to be a nested-variable. In every iteration of the
1139 * loop another level of lambda expression is created, starting with the
1140 * innermost one. Note that we don't check for duplicate formals here:
1141 * This will be done by the memoizer of the lambda expression. */
1142 const SCM formals
= SCM_CDR (variable
);
1143 const SCM tail
= scm_cons (formals
, body
);
1145 /* Add source properties to each new lambda expression: */
1146 const SCM lambda
= scm_cons_source (variable
, scm_sym_lambda
, tail
);
1148 body
= scm_list_1 (lambda
);
1149 variable
= SCM_CAR (variable
);
1151 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
), s_bad_variable
, variable
, expr
);
1152 ASSERT_SYNTAX (scm_ilength (body
) == 1, s_expression
, expr
);
1154 SCM_SETCAR (cdr_expr
, variable
);
1155 SCM_SETCDR (cdr_expr
, body
);
1159 /* According to section 5.2.1 of R5RS we first have to make sure that the
1160 * variable is bound, and then perform the (set! variable expression)
1161 * operation. This means, that within the expression we may already assign
1162 * values to variable: (define foo (begin (set! foo 1) (+ foo 1))) */
1164 scm_m_define (SCM expr
, SCM env
)
1166 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), s_bad_define
, expr
);
1169 const SCM canonical_definition
= canonicalize_define (expr
);
1170 const SCM cdr_canonical_definition
= SCM_CDR (canonical_definition
);
1171 const SCM variable
= SCM_CAR (cdr_canonical_definition
);
1173 = scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_T
);
1174 const SCM value
= scm_eval_car (SCM_CDR (cdr_canonical_definition
), env
);
1176 if (SCM_REC_PROCNAMES_P
)
1179 while (SCM_MACROP (tmp
))
1180 tmp
= SCM_MACRO_CODE (tmp
);
1181 if (SCM_CLOSUREP (tmp
)
1182 /* Only the first definition determines the name. */
1183 && SCM_FALSEP (scm_procedure_property (tmp
, scm_sym_name
)))
1184 scm_set_procedure_property_x (tmp
, scm_sym_name
, variable
);
1187 SCM_VARIABLE_SET (location
, value
);
1189 return SCM_UNSPECIFIED
;
1194 /* This is a helper function for forms (<keyword> <expression>) that are
1195 * transformed into (#@<keyword> '() <memoized_expression>) in order to allow
1196 * for easy creation of a thunk (i. e. a closure without arguments) using the
1197 * ('() <memoized_expression>) tail of the memoized form. */
1199 memoize_as_thunk_prototype (const SCM expr
, const SCM env SCM_UNUSED
)
1201 const SCM cdr_expr
= SCM_CDR (expr
);
1202 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1203 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1205 SCM_SETCDR (expr
, scm_cons (SCM_EOL
, cdr_expr
));
1211 SCM_SYNTAX (s_delay
, "delay", scm_i_makbimacro
, scm_m_delay
);
1212 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
1214 /* Promises are implemented as closures with an empty parameter list. Thus,
1215 * (delay <expression>) is transformed into (#@delay '() <expression>), where
1216 * the empty list represents the empty parameter list. This representation
1217 * allows for easy creation of the closure during evaluation. */
1219 scm_m_delay (SCM expr
, SCM env
)
1221 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1222 SCM_SETCAR (new_expr
, SCM_IM_DELAY
);
1227 unmemoize_delay (const SCM expr
, const SCM env
)
1229 const SCM thunk_expr
= SCM_CADDR (expr
);
1230 return scm_list_2 (scm_sym_delay
, unmemoize_expression (thunk_expr
, env
));
1234 SCM_SYNTAX(s_do
, "do", scm_i_makbimacro
, scm_m_do
);
1235 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
1237 /* DO gets the most radically altered syntax. The order of the vars is
1238 * reversed here. During the evaluation this allows for simple consing of the
1239 * results of the inits and steps:
1241 (do ((<var1> <init1> <step1>)
1249 (#@do (<init1> <init2> ... <initn>)
1250 (varn ... var2 var1)
1253 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
1256 scm_m_do (SCM expr
, SCM env SCM_UNUSED
)
1258 SCM variables
= SCM_EOL
;
1259 SCM init_forms
= SCM_EOL
;
1260 SCM step_forms
= SCM_EOL
;
1267 const SCM cdr_expr
= SCM_CDR (expr
);
1268 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1269 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1271 /* Collect variables, init and step forms. */
1272 binding_idx
= SCM_CAR (cdr_expr
);
1273 ASSERT_SYNTAX_2 (scm_ilength (binding_idx
) >= 0,
1274 s_bad_bindings
, binding_idx
, expr
);
1275 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1277 const SCM binding
= SCM_CAR (binding_idx
);
1278 const long length
= scm_ilength (binding
);
1279 ASSERT_SYNTAX_2 (length
== 2 || length
== 3,
1280 s_bad_binding
, binding
, expr
);
1283 const SCM name
= SCM_CAR (binding
);
1284 const SCM init
= SCM_CADR (binding
);
1285 const SCM step
= (length
== 2) ? name
: SCM_CADDR (binding
);
1286 ASSERT_SYNTAX_2 (SCM_SYMBOLP (name
), s_bad_variable
, name
, expr
);
1287 ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (name
, variables
)),
1288 s_duplicate_binding
, name
, expr
);
1290 variables
= scm_cons (name
, variables
);
1291 init_forms
= scm_cons (init
, init_forms
);
1292 step_forms
= scm_cons (step
, step_forms
);
1295 init_forms
= scm_reverse_x (init_forms
, SCM_UNDEFINED
);
1296 step_forms
= scm_reverse_x (step_forms
, SCM_UNDEFINED
);
1298 /* Memoize the test form and the exit sequence. */
1299 cddr_expr
= SCM_CDR (cdr_expr
);
1300 exit_clause
= SCM_CAR (cddr_expr
);
1301 ASSERT_SYNTAX_2 (scm_ilength (exit_clause
) >= 1,
1302 s_bad_exit_clause
, exit_clause
, expr
);
1304 commands
= SCM_CDR (cddr_expr
);
1305 tail
= scm_cons2 (exit_clause
, commands
, step_forms
);
1306 tail
= scm_cons2 (init_forms
, variables
, tail
);
1307 SCM_SETCAR (expr
, SCM_IM_DO
);
1308 SCM_SETCDR (expr
, tail
);
1313 unmemoize_do (const SCM expr
, const SCM env
)
1315 const SCM cdr_expr
= SCM_CDR (expr
);
1316 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1317 const SCM rnames
= SCM_CAR (cddr_expr
);
1318 const SCM extended_env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
1319 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
1320 const SCM exit_sequence
= SCM_CAR (cdddr_expr
);
1321 const SCM um_exit_sequence
= unmemoize_exprs (exit_sequence
, extended_env
);
1322 const SCM cddddr_expr
= SCM_CDR (cdddr_expr
);
1323 const SCM um_body
= unmemoize_exprs (SCM_CAR (cddddr_expr
), extended_env
);
1325 /* build transformed binding list */
1326 SCM um_names
= scm_reverse (rnames
);
1327 SCM um_inits
= unmemoize_exprs (SCM_CAR (cdr_expr
), env
);
1328 SCM um_steps
= unmemoize_exprs (SCM_CDR (cddddr_expr
), extended_env
);
1329 SCM um_bindings
= SCM_EOL
;
1330 while (!SCM_NULLP (um_names
))
1332 const SCM name
= SCM_CAR (um_names
);
1333 const SCM init
= SCM_CAR (um_inits
);
1334 SCM step
= SCM_CAR (um_steps
);
1335 step
= SCM_EQ_P (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
1337 um_bindings
= scm_cons (scm_cons2 (name
, init
, step
), um_bindings
);
1339 um_names
= SCM_CDR (um_names
);
1340 um_inits
= SCM_CDR (um_inits
);
1341 um_steps
= SCM_CDR (um_steps
);
1343 um_bindings
= scm_reverse_x (um_bindings
, SCM_UNDEFINED
);
1345 return scm_cons (scm_sym_do
,
1346 scm_cons2 (um_bindings
, um_exit_sequence
, um_body
));
1350 SCM_SYNTAX (s_if
, "if", scm_i_makbimacro
, scm_m_if
);
1351 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
1354 scm_m_if (SCM expr
, SCM env SCM_UNUSED
)
1356 const SCM cdr_expr
= SCM_CDR (expr
);
1357 const long length
= scm_ilength (cdr_expr
);
1358 ASSERT_SYNTAX (length
== 2 || length
== 3, s_expression
, expr
);
1359 SCM_SETCAR (expr
, SCM_IM_IF
);
1364 unmemoize_if (const SCM expr
, const SCM env
)
1366 const SCM cdr_expr
= SCM_CDR (expr
);
1367 const SCM um_condition
= unmemoize_expression (SCM_CAR (cdr_expr
), env
);
1368 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1369 const SCM um_then
= unmemoize_expression (SCM_CAR (cddr_expr
), env
);
1370 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
1372 if (SCM_NULLP (cdddr_expr
))
1374 return scm_list_3 (scm_sym_if
, um_condition
, um_then
);
1378 const SCM um_else
= unmemoize_expression (SCM_CAR (cdddr_expr
), env
);
1379 return scm_list_4 (scm_sym_if
, um_condition
, um_then
, um_else
);
1384 SCM_SYNTAX (s_lambda
, "lambda", scm_i_makbimacro
, scm_m_lambda
);
1385 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
1387 /* A helper function for memoize_lambda to support checking for duplicate
1388 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
1389 * LIST or to the cdr of the last cons. Therefore, LIST may have any of the
1390 * forms that a formal argument can have:
1391 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
1393 c_improper_memq (SCM obj
, SCM list
)
1395 for (; SCM_CONSP (list
); list
= SCM_CDR (list
))
1397 if (SCM_EQ_P (SCM_CAR (list
), obj
))
1400 return SCM_EQ_P (list
, obj
);
1404 scm_m_lambda (SCM expr
, SCM env SCM_UNUSED
)
1413 const SCM cdr_expr
= SCM_CDR (expr
);
1414 const long length
= scm_ilength (cdr_expr
);
1415 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1416 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1418 /* Before iterating the list of formal arguments, make sure the formals
1419 * actually are given as either a symbol or a non-cyclic list. */
1420 formals
= SCM_CAR (cdr_expr
);
1421 if (SCM_CONSP (formals
))
1423 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
1424 * detected, report a 'Bad formals' error. */
1428 ASSERT_SYNTAX_2 (SCM_SYMBOLP (formals
) || SCM_NULLP (formals
),
1429 s_bad_formals
, formals
, expr
);
1432 /* Now iterate the list of formal arguments to check if all formals are
1433 * symbols, and that there are no duplicates. */
1434 formals_idx
= formals
;
1435 while (SCM_CONSP (formals_idx
))
1437 const SCM formal
= SCM_CAR (formals_idx
);
1438 const SCM next_idx
= SCM_CDR (formals_idx
);
1439 ASSERT_SYNTAX_2 (SCM_SYMBOLP (formal
), s_bad_formal
, formal
, expr
);
1440 ASSERT_SYNTAX_2 (!c_improper_memq (formal
, next_idx
),
1441 s_duplicate_formal
, formal
, expr
);
1442 formals_idx
= next_idx
;
1444 ASSERT_SYNTAX_2 (SCM_NULLP (formals_idx
) || SCM_SYMBOLP (formals_idx
),
1445 s_bad_formal
, formals_idx
, expr
);
1447 /* Memoize the body. Keep a potential documentation string. */
1448 /* Dirk:FIXME:: We should probably extract the documentation string to
1449 * some external database. Otherwise it will slow down execution, since
1450 * the documentation string will have to be skipped with every execution
1451 * of the closure. */
1452 cddr_expr
= SCM_CDR (cdr_expr
);
1453 documentation
= (length
>= 3 && SCM_STRINGP (SCM_CAR (cddr_expr
)));
1454 body
= documentation
? SCM_CDR (cddr_expr
) : cddr_expr
;
1455 new_body
= m_body (SCM_IM_LAMBDA
, body
);
1457 SCM_SETCAR (expr
, SCM_IM_LAMBDA
);
1459 SCM_SETCDR (cddr_expr
, new_body
);
1461 SCM_SETCDR (cdr_expr
, new_body
);
1466 unmemoize_lambda (const SCM expr
, const SCM env
)
1468 const SCM formals
= SCM_CADR (expr
);
1469 const SCM body
= SCM_CDDR (expr
);
1471 const SCM new_env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, env
);
1472 const SCM um_formals
= scm_i_finite_list_copy (formals
);
1473 const SCM um_body
= unmemoize_exprs (body
, new_env
);
1475 return scm_cons2 (scm_sym_lambda
, um_formals
, um_body
);
1479 /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
1481 check_bindings (const SCM bindings
, const SCM expr
)
1485 ASSERT_SYNTAX_2 (scm_ilength (bindings
) >= 0,
1486 s_bad_bindings
, bindings
, expr
);
1488 binding_idx
= bindings
;
1489 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1491 SCM name
; /* const */
1493 const SCM binding
= SCM_CAR (binding_idx
);
1494 ASSERT_SYNTAX_2 (scm_ilength (binding
) == 2,
1495 s_bad_binding
, binding
, expr
);
1497 name
= SCM_CAR (binding
);
1498 ASSERT_SYNTAX_2 (SCM_SYMBOLP (name
), s_bad_variable
, name
, expr
);
1503 /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
1504 * transformed to the lists (vn ... v2 v1) and (i1 i2 ... in). That is, the
1505 * variables are returned in a list with their order reversed, and the init
1506 * forms are returned in a list in the same order as they are given in the
1507 * bindings. If a duplicate variable name is detected, an error is
1510 transform_bindings (
1511 const SCM bindings
, const SCM expr
,
1512 SCM
*const rvarptr
, SCM
*const initptr
)
1514 SCM rvariables
= SCM_EOL
;
1515 SCM rinits
= SCM_EOL
;
1516 SCM binding_idx
= bindings
;
1517 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1519 const SCM binding
= SCM_CAR (binding_idx
);
1520 const SCM cdr_binding
= SCM_CDR (binding
);
1521 const SCM name
= SCM_CAR (binding
);
1522 ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (name
, rvariables
)),
1523 s_duplicate_binding
, name
, expr
);
1524 rvariables
= scm_cons (name
, rvariables
);
1525 rinits
= scm_cons (SCM_CAR (cdr_binding
), rinits
);
1527 *rvarptr
= rvariables
;
1528 *initptr
= scm_reverse_x (rinits
, SCM_UNDEFINED
);
1532 SCM_SYNTAX(s_let
, "let", scm_i_makbimacro
, scm_m_let
);
1533 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
1535 /* This function is a helper function for memoize_let. It transforms
1536 * (let name ((var init) ...) body ...) into
1537 * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
1538 * and memoizes the expression. It is assumed that the caller has checked
1539 * that name is a symbol and that there are bindings and a body. */
1541 memoize_named_let (const SCM expr
, const SCM env SCM_UNUSED
)
1547 const SCM cdr_expr
= SCM_CDR (expr
);
1548 const SCM name
= SCM_CAR (cdr_expr
);
1549 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1550 const SCM bindings
= SCM_CAR (cddr_expr
);
1551 check_bindings (bindings
, expr
);
1553 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1554 variables
= scm_reverse_x (rvariables
, SCM_UNDEFINED
);
1557 const SCM let_body
= SCM_CDR (cddr_expr
);
1558 const SCM lambda_body
= m_body (SCM_IM_LET
, let_body
);
1559 const SCM lambda_tail
= scm_cons (variables
, lambda_body
);
1560 const SCM lambda_form
= scm_cons_source (expr
, scm_sym_lambda
, lambda_tail
);
1562 const SCM rvar
= scm_list_1 (name
);
1563 const SCM init
= scm_list_1 (lambda_form
);
1564 const SCM body
= m_body (SCM_IM_LET
, scm_list_1 (name
));
1565 const SCM letrec_tail
= scm_cons (rvar
, scm_cons (init
, body
));
1566 const SCM letrec_form
= scm_cons_source (expr
, SCM_IM_LETREC
, letrec_tail
);
1567 return scm_cons_source (expr
, letrec_form
, inits
);
1571 /* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1572 * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
1574 scm_m_let (SCM expr
, SCM env
)
1578 const SCM cdr_expr
= SCM_CDR (expr
);
1579 const long length
= scm_ilength (cdr_expr
);
1580 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1581 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1583 bindings
= SCM_CAR (cdr_expr
);
1584 if (SCM_SYMBOLP (bindings
))
1586 ASSERT_SYNTAX (length
>= 3, s_missing_expression
, expr
);
1587 return memoize_named_let (expr
, env
);
1590 check_bindings (bindings
, expr
);
1591 if (SCM_NULLP (bindings
) || SCM_NULLP (SCM_CDR (bindings
)))
1593 /* Special case: no bindings or single binding => let* is faster. */
1594 const SCM body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1595 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), bindings
, body
), env
);
1602 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1605 const SCM new_body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1606 const SCM new_tail
= scm_cons2 (rvariables
, inits
, new_body
);
1607 SCM_SETCAR (expr
, SCM_IM_LET
);
1608 SCM_SETCDR (expr
, new_tail
);
1615 build_binding_list (SCM rnames
, SCM rinits
)
1617 SCM bindings
= SCM_EOL
;
1618 while (!SCM_NULLP (rnames
))
1620 const SCM binding
= scm_list_2 (SCM_CAR (rnames
), SCM_CAR (rinits
));
1621 bindings
= scm_cons (binding
, bindings
);
1622 rnames
= SCM_CDR (rnames
);
1623 rinits
= SCM_CDR (rinits
);
1629 unmemoize_let (const SCM expr
, const SCM env
)
1631 const SCM cdr_expr
= SCM_CDR (expr
);
1632 const SCM um_rnames
= SCM_CAR (cdr_expr
);
1633 const SCM extended_env
= SCM_EXTEND_ENV (um_rnames
, SCM_EOL
, env
);
1634 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1635 const SCM um_inits
= unmemoize_exprs (SCM_CAR (cddr_expr
), env
);
1636 const SCM um_rinits
= scm_reverse_x (um_inits
, SCM_UNDEFINED
);
1637 const SCM um_bindings
= build_binding_list (um_rnames
, um_rinits
);
1638 const SCM um_body
= unmemoize_exprs (SCM_CDR (cddr_expr
), extended_env
);
1640 return scm_cons2 (scm_sym_let
, um_bindings
, um_body
);
1644 SCM_SYNTAX(s_letrec
, "letrec", scm_i_makbimacro
, scm_m_letrec
);
1645 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
1648 scm_m_letrec (SCM expr
, SCM env
)
1652 const SCM cdr_expr
= SCM_CDR (expr
);
1653 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1654 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1656 bindings
= SCM_CAR (cdr_expr
);
1657 if (SCM_NULLP (bindings
))
1659 /* no bindings, let* is executed faster */
1660 SCM body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1661 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), SCM_EOL
, body
), env
);
1669 check_bindings (bindings
, expr
);
1670 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1671 new_body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1672 return scm_cons2 (SCM_IM_LETREC
, rvariables
, scm_cons (inits
, new_body
));
1677 unmemoize_letrec (const SCM expr
, const SCM env
)
1679 const SCM cdr_expr
= SCM_CDR (expr
);
1680 const SCM um_rnames
= SCM_CAR (cdr_expr
);
1681 const SCM extended_env
= SCM_EXTEND_ENV (um_rnames
, SCM_EOL
, env
);
1682 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1683 const SCM um_inits
= unmemoize_exprs (SCM_CAR (cddr_expr
), extended_env
);
1684 const SCM um_rinits
= scm_reverse_x (um_inits
, SCM_UNDEFINED
);
1685 const SCM um_bindings
= build_binding_list (um_rnames
, um_rinits
);
1686 const SCM um_body
= unmemoize_exprs (SCM_CDR (cddr_expr
), extended_env
);
1688 return scm_cons2 (scm_sym_letrec
, um_bindings
, um_body
);
1693 SCM_SYNTAX (s_letstar
, "let*", scm_i_makbimacro
, scm_m_letstar
);
1694 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
1696 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1697 * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
1699 scm_m_letstar (SCM expr
, SCM env SCM_UNUSED
)
1704 const SCM cdr_expr
= SCM_CDR (expr
);
1705 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1706 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1708 binding_idx
= SCM_CAR (cdr_expr
);
1709 check_bindings (binding_idx
, expr
);
1711 /* Transform ((v1 i1) (v2 i2) ...) into (v1 i1 v2 i2 ...). The
1712 * transformation is done in place. At the beginning of one iteration of
1713 * the loop the variable binding_idx holds the form
1714 * P1:( (vn . P2:(in . ())) . P3:( (vn+1 in+1) ... ) ),
1715 * where P1, P2 and P3 indicate the pairs, that are relevant for the
1716 * transformation. P1 and P2 are modified in the loop, P3 remains
1717 * untouched. After the execution of the loop, P1 will hold
1718 * P1:( vn . P2:(in . P3:( (vn+1 in+1) ... )) )
1719 * and binding_idx will hold P3. */
1720 while (!SCM_NULLP (binding_idx
))
1722 const SCM cdr_binding_idx
= SCM_CDR (binding_idx
); /* remember P3 */
1723 const SCM binding
= SCM_CAR (binding_idx
);
1724 const SCM name
= SCM_CAR (binding
);
1725 const SCM cdr_binding
= SCM_CDR (binding
);
1727 SCM_SETCDR (cdr_binding
, cdr_binding_idx
); /* update P2 */
1728 SCM_SETCAR (binding_idx
, name
); /* update P1 */
1729 SCM_SETCDR (binding_idx
, cdr_binding
); /* update P1 */
1731 binding_idx
= cdr_binding_idx
; /* continue with P3 */
1734 new_body
= m_body (SCM_IM_LETSTAR
, SCM_CDR (cdr_expr
));
1735 SCM_SETCAR (expr
, SCM_IM_LETSTAR
);
1736 /* the bindings have been changed in place */
1737 SCM_SETCDR (cdr_expr
, new_body
);
1742 unmemoize_letstar (const SCM expr
, const SCM env
)
1744 const SCM cdr_expr
= SCM_CDR (expr
);
1745 const SCM body
= SCM_CDR (cdr_expr
);
1746 SCM bindings
= SCM_CAR (cdr_expr
);
1747 SCM um_bindings
= SCM_EOL
;
1748 SCM extended_env
= env
;
1751 while (!SCM_NULLP (bindings
))
1753 const SCM variable
= SCM_CAR (bindings
);
1754 const SCM init
= SCM_CADR (bindings
);
1755 const SCM um_init
= unmemoize_expression (init
, extended_env
);
1756 um_bindings
= scm_cons (scm_list_2 (variable
, um_init
), um_bindings
);
1757 extended_env
= SCM_EXTEND_ENV (variable
, SCM_BOOL_F
, extended_env
);
1758 bindings
= SCM_CDDR (bindings
);
1760 um_bindings
= scm_reverse_x (um_bindings
, SCM_UNDEFINED
);
1762 um_body
= unmemoize_exprs (body
, extended_env
);
1764 return scm_cons2 (scm_sym_letstar
, um_bindings
, um_body
);
1768 SCM_SYNTAX (s_or
, "or", scm_i_makbimacro
, scm_m_or
);
1769 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
1772 scm_m_or (SCM expr
, SCM env SCM_UNUSED
)
1774 const SCM cdr_expr
= SCM_CDR (expr
);
1775 const long length
= scm_ilength (cdr_expr
);
1777 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1781 /* Special case: (or) is replaced by #f. */
1786 SCM_SETCAR (expr
, SCM_IM_OR
);
1792 unmemoize_or (const SCM expr
, const SCM env
)
1794 return scm_cons (scm_sym_or
, unmemoize_exprs (SCM_CDR (expr
), env
));
1798 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
1799 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
1800 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
1801 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
1803 /* Internal function to handle a quasiquotation: 'form' is the parameter in
1804 * the call (quasiquotation form), 'env' is the environment where unquoted
1805 * expressions will be evaluated, and 'depth' is the current quasiquotation
1806 * nesting level and is known to be greater than zero. */
1808 iqq (SCM form
, SCM env
, unsigned long int depth
)
1810 if (SCM_CONSP (form
))
1812 const SCM tmp
= SCM_CAR (form
);
1813 if (SCM_EQ_P (tmp
, scm_sym_quasiquote
))
1815 const SCM args
= SCM_CDR (form
);
1816 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1817 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
1819 else if (SCM_EQ_P (tmp
, scm_sym_unquote
))
1821 const SCM args
= SCM_CDR (form
);
1822 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1824 return scm_eval_car (args
, env
);
1826 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
1828 else if (SCM_CONSP (tmp
)
1829 && SCM_EQ_P (SCM_CAR (tmp
), scm_sym_uq_splicing
))
1831 const SCM args
= SCM_CDR (tmp
);
1832 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1835 const SCM list
= scm_eval_car (args
, env
);
1836 const SCM rest
= SCM_CDR (form
);
1837 ASSERT_SYNTAX_2 (scm_ilength (list
) >= 0,
1838 s_splicing
, list
, form
);
1839 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
1842 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
1843 iqq (SCM_CDR (form
), env
, depth
));
1846 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
1847 iqq (SCM_CDR (form
), env
, depth
));
1849 else if (SCM_VECTORP (form
))
1851 size_t i
= SCM_VECTOR_LENGTH (form
);
1852 SCM
const *const data
= SCM_VELTS (form
);
1855 tmp
= scm_cons (data
[--i
], tmp
);
1856 scm_remember_upto_here_1 (form
);
1857 return scm_vector (iqq (tmp
, env
, depth
));
1864 scm_m_quasiquote (SCM expr
, SCM env
)
1866 const SCM cdr_expr
= SCM_CDR (expr
);
1867 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1868 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1869 return iqq (SCM_CAR (cdr_expr
), env
, 1);
1873 SCM_SYNTAX (s_quote
, "quote", scm_i_makbimacro
, scm_m_quote
);
1874 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
1877 scm_m_quote (SCM expr
, SCM env SCM_UNUSED
)
1881 const SCM cdr_expr
= SCM_CDR (expr
);
1882 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1883 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1884 quotee
= SCM_CAR (cdr_expr
);
1885 if (is_self_quoting_p (quotee
))
1888 SCM_SETCAR (expr
, SCM_IM_QUOTE
);
1889 SCM_SETCDR (expr
, quotee
);
1894 unmemoize_quote (const SCM expr
, const SCM env SCM_UNUSED
)
1896 return scm_list_2 (scm_sym_quote
, SCM_CDR (expr
));
1900 /* Will go into the RnRS module when Guile is factorized.
1901 SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
1902 static const char s_set_x
[] = "set!";
1903 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, s_set_x
);
1906 scm_m_set_x (SCM expr
, SCM env SCM_UNUSED
)
1911 const SCM cdr_expr
= SCM_CDR (expr
);
1912 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1913 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1914 variable
= SCM_CAR (cdr_expr
);
1916 /* Memoize the variable form. */
1917 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
), s_bad_variable
, variable
, expr
);
1918 new_variable
= lookup_symbol (variable
, env
);
1919 /* Leave the memoization of unbound symbols to lazy memoization: */
1920 if (SCM_UNBNDP (new_variable
))
1921 new_variable
= variable
;
1923 SCM_SETCAR (expr
, SCM_IM_SET_X
);
1924 SCM_SETCAR (cdr_expr
, new_variable
);
1929 unmemoize_set_x (const SCM expr
, const SCM env
)
1931 return scm_cons (scm_sym_set_x
, unmemoize_exprs (SCM_CDR (expr
), env
));
1935 /* Start of the memoizers for non-R5RS builtin macros. */
1938 SCM_SYNTAX (s_atapply
, "@apply", scm_i_makbimacro
, scm_m_apply
);
1939 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1940 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1943 scm_m_apply (SCM expr
, SCM env SCM_UNUSED
)
1945 const SCM cdr_expr
= SCM_CDR (expr
);
1946 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1947 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_missing_expression
, expr
);
1949 SCM_SETCAR (expr
, SCM_IM_APPLY
);
1954 unmemoize_apply (const SCM expr
, const SCM env
)
1956 return scm_list_2 (scm_sym_atapply
, unmemoize_exprs (SCM_CDR (expr
), env
));
1960 SCM_SYNTAX (s_atbind
, "@bind", scm_i_makbimacro
, scm_m_atbind
);
1962 /* FIXME: The following explanation should go into the documentation: */
1963 /* (@bind ((var init) ...) body ...) will assign the values of the `init's to
1964 * the global variables named by `var's (symbols, not evaluated), creating
1965 * them if they don't exist, executes body, and then restores the previous
1966 * values of the `var's. Additionally, whenever control leaves body, the
1967 * values of the `var's are saved and restored when control returns. It is an
1968 * error when a symbol appears more than once among the `var's. All `init's
1969 * are evaluated before any `var' is set.
1971 * Think of this as `let' for dynamic scope.
1974 /* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into
1975 * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...).
1977 * FIXME - also implement `@bind*'.
1980 scm_m_atbind (SCM expr
, SCM env
)
1987 const SCM top_level
= scm_env_top_level (env
);
1989 const SCM cdr_expr
= SCM_CDR (expr
);
1990 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1991 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1992 bindings
= SCM_CAR (cdr_expr
);
1993 check_bindings (bindings
, expr
);
1994 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1996 for (variable_idx
= rvariables
;
1997 !SCM_NULLP (variable_idx
);
1998 variable_idx
= SCM_CDR (variable_idx
))
2000 /* The first call to scm_sym2var will look beyond the current module,
2001 * while the second call wont. */
2002 const SCM variable
= SCM_CAR (variable_idx
);
2003 SCM new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_F
);
2004 if (SCM_FALSEP (new_variable
))
2005 new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_T
);
2006 SCM_SETCAR (variable_idx
, new_variable
);
2009 SCM_SETCAR (expr
, SCM_IM_BIND
);
2010 SCM_SETCAR (cdr_expr
, scm_cons (rvariables
, inits
));
2015 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_i_makbimacro
, scm_m_cont
);
2016 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, s_atcall_cc
);
2019 scm_m_cont (SCM expr
, SCM env SCM_UNUSED
)
2021 const SCM cdr_expr
= SCM_CDR (expr
);
2022 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2023 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2025 SCM_SETCAR (expr
, SCM_IM_CONT
);
2030 unmemoize_atcall_cc (const SCM expr
, const SCM env
)
2032 return scm_list_2 (scm_sym_atcall_cc
, unmemoize_exprs (SCM_CDR (expr
), env
));
2036 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_i_makbimacro
, scm_m_at_call_with_values
);
2037 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
2040 scm_m_at_call_with_values (SCM expr
, SCM env SCM_UNUSED
)
2042 const SCM cdr_expr
= SCM_CDR (expr
);
2043 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2044 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2046 SCM_SETCAR (expr
, SCM_IM_CALL_WITH_VALUES
);
2051 unmemoize_at_call_with_values (const SCM expr
, const SCM env
)
2053 return scm_list_2 (scm_sym_at_call_with_values
,
2054 unmemoize_exprs (SCM_CDR (expr
), env
));
2058 SCM_SYNTAX (s_future
, "future", scm_i_makbimacro
, scm_m_future
);
2059 SCM_GLOBAL_SYMBOL (scm_sym_future
, s_future
);
2061 /* Like promises, futures are implemented as closures with an empty
2062 * parameter list. Thus, (future <expression>) is transformed into
2063 * (#@future '() <expression>), where the empty list represents the
2064 * empty parameter list. This representation allows for easy creation
2065 * of the closure during evaluation. */
2067 scm_m_future (SCM expr
, SCM env
)
2069 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
2070 SCM_SETCAR (new_expr
, SCM_IM_FUTURE
);
2075 unmemoize_future (const SCM expr
, const SCM env
)
2077 const SCM thunk_expr
= SCM_CADDR (expr
);
2078 return scm_list_2 (scm_sym_future
, unmemoize_expression (thunk_expr
, env
));
2082 SCM_SYNTAX (s_gset_x
, "set!", scm_i_makbimacro
, scm_m_generalized_set_x
);
2083 SCM_SYMBOL (scm_sym_setter
, "setter");
2086 scm_m_generalized_set_x (SCM expr
, SCM env
)
2088 SCM target
, exp_target
;
2090 const SCM cdr_expr
= SCM_CDR (expr
);
2091 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2092 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2094 target
= SCM_CAR (cdr_expr
);
2095 if (!SCM_CONSP (target
))
2098 return scm_m_set_x (expr
, env
);
2102 /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */
2103 /* Macroexpanding the target might return things of the form
2104 (begin <atom>). In that case, <atom> must be a symbol or a
2105 variable and we memoize to (set! <atom> ...).
2107 exp_target
= macroexp (target
, env
);
2108 if (SCM_EQ_P (SCM_CAR (exp_target
), SCM_IM_BEGIN
)
2109 && !SCM_NULLP (SCM_CDR (exp_target
))
2110 && SCM_NULLP (SCM_CDDR (exp_target
)))
2112 exp_target
= SCM_CADR (exp_target
);
2113 ASSERT_SYNTAX_2 (SCM_SYMBOLP (exp_target
)
2114 || SCM_VARIABLEP (exp_target
),
2115 s_bad_variable
, exp_target
, expr
);
2116 return scm_cons (SCM_IM_SET_X
, scm_cons (exp_target
,
2117 SCM_CDR (cdr_expr
)));
2121 const SCM setter_proc_tail
= scm_list_1 (SCM_CAR (target
));
2122 const SCM setter_proc
= scm_cons_source (expr
, scm_sym_setter
,
2125 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
2126 const SCM setter_args
= scm_append_x (scm_list_2 (SCM_CDR (target
),
2129 SCM_SETCAR (expr
, setter_proc
);
2130 SCM_SETCDR (expr
, setter_args
);
2137 /* @slot-ref is bound privately in the (oop goops) module from goops.c. As
2138 * soon as the module system allows us to more freely create bindings in
2139 * arbitrary modules during the startup phase, the code from goops.c should be
2142 SCM_SYMBOL (sym_atslot_ref
, "@slot-ref");
2145 scm_m_atslot_ref (SCM expr
, SCM env SCM_UNUSED
)
2149 const SCM cdr_expr
= SCM_CDR (expr
);
2150 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2151 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2152 slot_nr
= SCM_CADR (cdr_expr
);
2153 ASSERT_SYNTAX_2 (SCM_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2155 SCM_SETCAR (expr
, SCM_IM_SLOT_REF
);
2156 SCM_SETCDR (cdr_expr
, slot_nr
);
2161 unmemoize_atslot_ref (const SCM expr
, const SCM env
)
2163 const SCM instance
= SCM_CADR (expr
);
2164 const SCM um_instance
= unmemoize_expression (instance
, env
);
2165 const SCM slot_nr
= SCM_CDDR (expr
);
2166 return scm_list_3 (sym_atslot_ref
, um_instance
, slot_nr
);
2170 /* @slot-set! is bound privately in the (oop goops) module from goops.c. As
2171 * soon as the module system allows us to more freely create bindings in
2172 * arbitrary modules during the startup phase, the code from goops.c should be
2175 SCM_SYMBOL (sym_atslot_set_x
, "@slot-set!");
2178 scm_m_atslot_set_x (SCM expr
, SCM env SCM_UNUSED
)
2182 const SCM cdr_expr
= SCM_CDR (expr
);
2183 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2184 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 3, s_expression
, expr
);
2185 slot_nr
= SCM_CADR (cdr_expr
);
2186 ASSERT_SYNTAX_2 (SCM_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2188 SCM_SETCAR (expr
, SCM_IM_SLOT_SET_X
);
2193 unmemoize_atslot_set_x (const SCM expr
, const SCM env
)
2195 const SCM cdr_expr
= SCM_CDR (expr
);
2196 const SCM instance
= SCM_CAR (cdr_expr
);
2197 const SCM um_instance
= unmemoize_expression (instance
, env
);
2198 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
2199 const SCM slot_nr
= SCM_CAR (cddr_expr
);
2200 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
2201 const SCM value
= SCM_CAR (cdddr_expr
);
2202 const SCM um_value
= unmemoize_expression (value
, env
);
2203 return scm_list_4 (sym_atslot_set_x
, um_instance
, slot_nr
, um_value
);
2207 #if SCM_ENABLE_ELISP
2209 static const char s_defun
[] = "Symbol's function definition is void";
2211 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_i_makbimacro
, scm_m_nil_cond
);
2213 /* nil-cond expressions have the form
2214 * (nil-cond COND VAL COND VAL ... ELSEVAL) */
2216 scm_m_nil_cond (SCM expr
, SCM env SCM_UNUSED
)
2218 const long length
= scm_ilength (SCM_CDR (expr
));
2219 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
2220 ASSERT_SYNTAX (length
>= 1 && (length
% 2) == 1, s_expression
, expr
);
2222 SCM_SETCAR (expr
, SCM_IM_NIL_COND
);
2227 SCM_SYNTAX (s_atfop
, "@fop", scm_i_makbimacro
, scm_m_atfop
);
2229 /* The @fop-macro handles procedure and macro applications for elisp. The
2230 * input expression must have the form
2231 * (@fop <var> (transformer-macro <expr> ...))
2232 * where <var> must be a symbol. The expression is transformed into the
2233 * memoized form of either
2234 * (apply <un-aliased var> (transformer-macro <expr> ...))
2235 * if the value of var (across all aliasing) is not a macro, or
2236 * (<un-aliased var> <expr> ...)
2237 * if var is a macro. */
2239 scm_m_atfop (SCM expr
, SCM env SCM_UNUSED
)
2244 const SCM cdr_expr
= SCM_CDR (expr
);
2245 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2246 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 1, s_missing_expression
, expr
);
2248 symbol
= SCM_CAR (cdr_expr
);
2249 ASSERT_SYNTAX_2 (SCM_SYMBOLP (symbol
), s_bad_variable
, symbol
, expr
);
2251 location
= scm_symbol_fref (symbol
);
2252 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2254 /* The elisp function `defalias' allows to define aliases for symbols. To
2255 * look up such definitions, the chain of symbol definitions has to be
2256 * followed up to the terminal symbol. */
2257 while (SCM_SYMBOLP (SCM_VARIABLE_REF (location
)))
2259 const SCM alias
= SCM_VARIABLE_REF (location
);
2260 location
= scm_symbol_fref (alias
);
2261 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2264 /* Memoize the value location belonging to the terminal symbol. */
2265 SCM_SETCAR (cdr_expr
, location
);
2267 if (!SCM_MACROP (SCM_VARIABLE_REF (location
)))
2269 /* Since the location does not contain a macro, the form is a procedure
2270 * application. Replace `@fop' by `@apply' and transform the expression
2271 * including the `transformer-macro'. */
2272 SCM_SETCAR (expr
, SCM_IM_APPLY
);
2277 /* Since the location contains a macro, the arguments should not be
2278 * transformed, so the `transformer-macro' is cut out. The resulting
2279 * expression starts with the memoized variable, that is at the cdr of
2280 * the input expression. */
2281 SCM_SETCDR (cdr_expr
, SCM_CDADR (cdr_expr
));
2286 #endif /* SCM_ENABLE_ELISP */
2290 unmemoize_builtin_macro (const SCM expr
, const SCM env
)
2292 switch (ISYMNUM (SCM_CAR (expr
)))
2294 case (ISYMNUM (SCM_IM_AND
)):
2295 return unmemoize_and (expr
, env
);
2297 case (ISYMNUM (SCM_IM_BEGIN
)):
2298 return unmemoize_begin (expr
, env
);
2300 case (ISYMNUM (SCM_IM_CASE
)):
2301 return unmemoize_case (expr
, env
);
2303 case (ISYMNUM (SCM_IM_COND
)):
2304 return unmemoize_cond (expr
, env
);
2306 case (ISYMNUM (SCM_IM_DELAY
)):
2307 return unmemoize_delay (expr
, env
);
2309 case (ISYMNUM (SCM_IM_DO
)):
2310 return unmemoize_do (expr
, env
);
2312 case (ISYMNUM (SCM_IM_IF
)):
2313 return unmemoize_if (expr
, env
);
2315 case (ISYMNUM (SCM_IM_LAMBDA
)):
2316 return unmemoize_lambda (expr
, env
);
2318 case (ISYMNUM (SCM_IM_LET
)):
2319 return unmemoize_let (expr
, env
);
2321 case (ISYMNUM (SCM_IM_LETREC
)):
2322 return unmemoize_letrec (expr
, env
);
2324 case (ISYMNUM (SCM_IM_LETSTAR
)):
2325 return unmemoize_letstar (expr
, env
);
2327 case (ISYMNUM (SCM_IM_OR
)):
2328 return unmemoize_or (expr
, env
);
2330 case (ISYMNUM (SCM_IM_QUOTE
)):
2331 return unmemoize_quote (expr
, env
);
2333 case (ISYMNUM (SCM_IM_SET_X
)):
2334 return unmemoize_set_x (expr
, env
);
2336 case (ISYMNUM (SCM_IM_APPLY
)):
2337 return unmemoize_apply (expr
, env
);
2339 case (ISYMNUM (SCM_IM_BIND
)):
2340 return unmemoize_exprs (expr
, env
); /* FIXME */
2342 case (ISYMNUM (SCM_IM_CONT
)):
2343 return unmemoize_atcall_cc (expr
, env
);
2345 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2346 return unmemoize_at_call_with_values (expr
, env
);
2348 case (ISYMNUM (SCM_IM_FUTURE
)):
2349 return unmemoize_future (expr
, env
);
2351 case (ISYMNUM (SCM_IM_SLOT_REF
)):
2352 return unmemoize_atslot_ref (expr
, env
);
2354 case (ISYMNUM (SCM_IM_SLOT_SET_X
)):
2355 return unmemoize_atslot_set_x (expr
, env
);
2357 case (ISYMNUM (SCM_IM_NIL_COND
)):
2358 return unmemoize_exprs (expr
, env
); /* FIXME */
2361 return unmemoize_exprs (expr
, env
); /* FIXME */
2366 /* scm_unmemocopy takes a memoized body together with its environment and
2367 * rewrites it to its original form. Thus, it is the inversion of the rewrite
2368 * rules above. The procedure is not optimized for speed. It's used in
2369 * scm_unmemoize, scm_procedure_source, macro_print and scm_iprin1.
2371 * Unmemoizing is not a reliable process. You cannot in general expect to get
2372 * the original source back.
2374 * However, GOOPS currently relies on this for method compilation. This ought
2378 scm_unmemocopy (SCM forms
, SCM env
)
2380 const SCM source_properties
= scm_whash_lookup (scm_source_whash
, forms
);
2381 const SCM um_forms
= unmemoize_exprs (forms
, env
);
2383 if (!SCM_FALSEP (source_properties
))
2384 scm_whash_insert (scm_source_whash
, um_forms
, source_properties
);
2390 #if (SCM_ENABLE_DEPRECATED == 1)
2392 /* Deprecated in guile 1.7.0 on 2003-11-09. */
2394 scm_m_expand_body (SCM exprs
, SCM env
)
2396 scm_c_issue_deprecation_warning
2397 ("`scm_m_expand_body' is deprecated.");
2398 m_expand_body (exprs
, env
);
2403 SCM_SYNTAX (s_undefine
, "undefine", scm_makacro
, scm_m_undefine
);
2406 scm_m_undefine (SCM expr
, SCM env
)
2411 const SCM cdr_expr
= SCM_CDR (expr
);
2412 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), "Bad undefine placement in", expr
);
2413 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2414 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2416 scm_c_issue_deprecation_warning
2417 ("`undefine' is deprecated.\n");
2419 variable
= SCM_CAR (cdr_expr
);
2420 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
), s_bad_variable
, variable
, expr
);
2421 location
= scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_F
);
2422 ASSERT_SYNTAX_2 (!SCM_FALSEP (location
)
2423 && !SCM_UNBNDP (SCM_VARIABLE_REF (location
)),
2424 "variable already unbound ", variable
, expr
);
2425 SCM_VARIABLE_SET (location
, SCM_UNDEFINED
);
2426 return SCM_UNSPECIFIED
;
2430 scm_macroexp (SCM x
, SCM env
)
2432 scm_c_issue_deprecation_warning
2433 ("`scm_macroexp' is deprecated.");
2434 return macroexp (x
, env
);
2440 #if (SCM_ENABLE_DEPRECATED == 1)
2443 scm_unmemocar (SCM form
, SCM env
)
2445 scm_c_issue_deprecation_warning
2446 ("`scm_unmemocar' is deprecated.");
2448 if (!SCM_CONSP (form
))
2452 SCM c
= SCM_CAR (form
);
2453 if (SCM_VARIABLEP (c
))
2455 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
2456 if (SCM_FALSEP (sym
))
2457 sym
= sym_three_question_marks
;
2458 SCM_SETCAR (form
, sym
);
2460 else if (SCM_ILOCP (c
))
2462 unsigned long int ir
;
2464 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
2465 env
= SCM_CDR (env
);
2466 env
= SCM_CAAR (env
);
2467 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
2468 env
= SCM_CDR (env
);
2470 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
2478 /*****************************************************************************/
2479 /*****************************************************************************/
2480 /* The definitions for execution start here. */
2481 /*****************************************************************************/
2482 /*****************************************************************************/
2484 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
2485 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
2486 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
2487 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
2489 /* A function object to implement "apply" for non-closure functions. */
2491 /* An endless list consisting of #<undefined> objects: */
2492 static SCM undefineds
;
2496 scm_badargsp (SCM formals
, SCM args
)
2498 while (!SCM_NULLP (formals
))
2500 if (!SCM_CONSP (formals
))
2502 if (SCM_NULLP (args
))
2504 formals
= SCM_CDR (formals
);
2505 args
= SCM_CDR (args
);
2507 return !SCM_NULLP (args
) ? 1 : 0;
2512 /* The evaluator contains a plethora of EVAL symbols. This is an attempt at
2515 * The following macros should be used in code which is read twice (where the
2516 * choice of evaluator is hard soldered):
2518 * CEVAL is the symbol used within one evaluator to call itself.
2519 * Originally, it is defined to ceval, but is redefined to deval during the
2522 * SCM_EVALIM is used when it is known that the expression is an
2523 * immediate. (This macro never calls an evaluator.)
2525 * EVAL evaluates an expression that is expected to have its symbols already
2526 * memoized. Expressions that are not of the form '(<form> <form> ...)' are
2527 * evaluated inline without calling an evaluator.
2529 * EVALCAR evaluates the car of an expression 'X:(Y:<form> <form> ...)',
2530 * potentially replacing a symbol at the position Y:<form> by its memoized
2531 * variable. If Y:<form> is not of the form '(<form> <form> ...)', the
2532 * evaluation is performed inline without calling an evaluator.
2534 * The following macros should be used in code which is read once
2535 * (where the choice of evaluator is dynamic):
2537 * SCM_XEVAL corresponds to EVAL, but uses ceval *or* deval depending on the
2540 * SCM_XEVALCAR corresponds to EVALCAR, but uses ceval *or* deval depending
2541 * on the debugging mode.
2543 * The main motivation for keeping this plethora is efficiency
2544 * together with maintainability (=> locality of code).
2547 static SCM
ceval (SCM x
, SCM env
);
2548 static SCM
deval (SCM x
, SCM env
);
2552 #define SCM_EVALIM2(x) \
2553 ((SCM_EQ_P ((x), SCM_EOL) \
2554 ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \
2558 #define SCM_EVALIM(x, env) (SCM_ILOCP (x) \
2559 ? *scm_ilookup ((x), (env)) \
2562 #define SCM_XEVAL(x, env) \
2565 : (SCM_VARIABLEP (x) \
2566 ? SCM_VARIABLE_REF (x) \
2568 ? (scm_debug_mode_p \
2569 ? deval ((x), (env)) \
2570 : ceval ((x), (env))) \
2573 #define SCM_XEVALCAR(x, env) \
2574 (SCM_IMP (SCM_CAR (x)) \
2575 ? SCM_EVALIM (SCM_CAR (x), (env)) \
2576 : (SCM_VARIABLEP (SCM_CAR (x)) \
2577 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2578 : (SCM_CONSP (SCM_CAR (x)) \
2579 ? (scm_debug_mode_p \
2580 ? deval (SCM_CAR (x), (env)) \
2581 : ceval (SCM_CAR (x), (env))) \
2582 : (!SCM_SYMBOLP (SCM_CAR (x)) \
2584 : *scm_lookupcar ((x), (env), 1)))))
2586 #define EVAL(x, env) \
2588 ? SCM_EVALIM ((x), (env)) \
2589 : (SCM_VARIABLEP (x) \
2590 ? SCM_VARIABLE_REF (x) \
2592 ? CEVAL ((x), (env)) \
2595 #define EVALCAR(x, env) \
2596 (SCM_IMP (SCM_CAR (x)) \
2597 ? SCM_EVALIM (SCM_CAR (x), (env)) \
2598 : (SCM_VARIABLEP (SCM_CAR (x)) \
2599 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2600 : (SCM_CONSP (SCM_CAR (x)) \
2601 ? CEVAL (SCM_CAR (x), (env)) \
2602 : (!SCM_SYMBOLP (SCM_CAR (x)) \
2604 : *scm_lookupcar ((x), (env), 1)))))
2606 SCM_REC_MUTEX (source_mutex
);
2609 /* Lookup a given local variable in an environment. The local variable is
2610 * given as an iloc, that is a triple <frame, binding, last?>, where frame
2611 * indicates the relative number of the environment frame (counting upwards
2612 * from the innermost environment frame), binding indicates the number of the
2613 * binding within the frame, and last? (which is extracted from the iloc using
2614 * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
2615 * very end of the improper list of bindings. */
2617 scm_ilookup (SCM iloc
, SCM env
)
2619 unsigned int frame_nr
= SCM_IFRAME (iloc
);
2620 unsigned int binding_nr
= SCM_IDIST (iloc
);
2624 for (; 0 != frame_nr
; --frame_nr
)
2625 frames
= SCM_CDR (frames
);
2627 bindings
= SCM_CAR (frames
);
2628 for (; 0 != binding_nr
; --binding_nr
)
2629 bindings
= SCM_CDR (bindings
);
2631 if (SCM_ICDRP (iloc
))
2632 return SCM_CDRLOC (bindings
);
2633 return SCM_CARLOC (SCM_CDR (bindings
));
2637 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
2639 static void error_unbound_variable (SCM symbol
) SCM_NORETURN
;
2641 error_unbound_variable (SCM symbol
)
2643 scm_error (scm_unbound_variable_key
, NULL
,
2644 "Unbound variable: ~S",
2645 scm_list_1 (symbol
), SCM_BOOL_F
);
2649 /* The Lookup Car Race
2652 Memoization of variables and special forms is done while executing
2653 the code for the first time. As long as there is only one thread
2654 everything is fine, but as soon as two threads execute the same
2655 code concurrently `for the first time' they can come into conflict.
2657 This memoization includes rewriting variable references into more
2658 efficient forms and expanding macros. Furthermore, macro expansion
2659 includes `compiling' special forms like `let', `cond', etc. into
2660 tree-code instructions.
2662 There shouldn't normally be a problem with memoizing local and
2663 global variable references (into ilocs and variables), because all
2664 threads will mutate the code in *exactly* the same way and (if I
2665 read the C code correctly) it is not possible to observe a half-way
2666 mutated cons cell. The lookup procedure can handle this
2667 transparently without any critical sections.
2669 It is different with macro expansion, because macro expansion
2670 happens outside of the lookup procedure and can't be
2671 undone. Therefore the lookup procedure can't cope with it. It has
2672 to indicate failure when it detects a lost race and hope that the
2673 caller can handle it. Luckily, it turns out that this is the case.
2675 An example to illustrate this: Suppose that the following form will
2676 be memoized concurrently by two threads
2680 Let's first examine the lookup of X in the body. The first thread
2681 decides that it has to find the symbol "x" in the environment and
2682 starts to scan it. Then the other thread takes over and actually
2683 overtakes the first. It looks up "x" and substitutes an
2684 appropriate iloc for it. Now the first thread continues and
2685 completes its lookup. It comes to exactly the same conclusions as
2686 the second one and could - without much ado - just overwrite the
2687 iloc with the same iloc.
2689 But let's see what will happen when the race occurs while looking
2690 up the symbol "let" at the start of the form. It could happen that
2691 the second thread interrupts the lookup of the first thread and not
2692 only substitutes a variable for it but goes right ahead and
2693 replaces it with the compiled form (#@let* (x 12) x). Now, when
2694 the first thread completes its lookup, it would replace the #@let*
2695 with a variable containing the "let" binding, effectively reverting
2696 the form to (let (x 12) x). This is wrong. It has to detect that
2697 it has lost the race and the evaluator has to reconsider the
2698 changed form completely.
2700 This race condition could be resolved with some kind of traffic
2701 light (like mutexes) around scm_lookupcar, but I think that it is
2702 best to avoid them in this case. They would serialize memoization
2703 completely and because lookup involves calling arbitrary Scheme
2704 code (via the lookup-thunk), threads could be blocked for an
2705 arbitrary amount of time or even deadlock. But with the current
2706 solution a lot of unnecessary work is potentially done. */
2708 /* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
2709 return NULL to indicate a failed lookup due to some race conditions
2710 between threads. This only happens when VLOC is the first cell of
2711 a special form that will eventually be memoized (like `let', etc.)
2712 In that case the whole lookup is bogus and the caller has to
2713 reconsider the complete special form.
2715 SCM_LOOKUPCAR is still there, of course. It just calls
2716 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
2717 should only be called when it is known that VLOC is not the first
2718 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
2719 for NULL. I think I've found the only places where this
2723 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
2726 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
2727 register SCM iloc
= SCM_ILOC00
;
2728 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
2730 if (!SCM_CONSP (SCM_CAR (env
)))
2732 al
= SCM_CARLOC (env
);
2733 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
2735 if (!SCM_CONSP (fl
))
2737 if (SCM_EQ_P (fl
, var
))
2739 if (! SCM_EQ_P (SCM_CAR (vloc
), var
))
2741 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
2742 return SCM_CDRLOC (*al
);
2747 al
= SCM_CDRLOC (*al
);
2748 if (SCM_EQ_P (SCM_CAR (fl
), var
))
2750 if (SCM_UNBNDP (SCM_CAR (*al
)))
2755 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
2757 SCM_SETCAR (vloc
, iloc
);
2758 return SCM_CARLOC (*al
);
2760 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
2762 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
2765 SCM top_thunk
, real_var
;
2768 top_thunk
= SCM_CAR (env
); /* env now refers to a
2769 top level env thunk */
2770 env
= SCM_CDR (env
);
2773 top_thunk
= SCM_BOOL_F
;
2774 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
2775 if (SCM_FALSEP (real_var
))
2778 if (!SCM_NULLP (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
2783 if (SCM_NULLP (env
))
2784 error_unbound_variable (var
);
2786 scm_misc_error (NULL
, "Damaged environment: ~S",
2791 /* A variable could not be found, but we shall
2792 not throw an error. */
2793 static SCM undef_object
= SCM_UNDEFINED
;
2794 return &undef_object
;
2798 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
2800 /* Some other thread has changed the very cell we are working
2801 on. In effect, it must have done our job or messed it up
2804 var
= SCM_CAR (vloc
);
2805 if (SCM_VARIABLEP (var
))
2806 return SCM_VARIABLE_LOC (var
);
2807 if (SCM_ILOCP (var
))
2808 return scm_ilookup (var
, genv
);
2809 /* We can't cope with anything else than variables and ilocs. When
2810 a special form has been memoized (i.e. `let' into `#@let') we
2811 return NULL and expect the calling function to do the right
2812 thing. For the evaluator, this means going back and redoing
2813 the dispatch on the car of the form. */
2817 SCM_SETCAR (vloc
, real_var
);
2818 return SCM_VARIABLE_LOC (real_var
);
2823 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
2825 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
2832 /* During execution, look up a symbol in the top level of the given local
2833 * environment and return the corresponding variable object. If no binding
2834 * for the symbol can be found, an 'Unbound variable' error is signalled. */
2836 lazy_memoize_variable (const SCM symbol
, const SCM environment
)
2838 const SCM top_level
= scm_env_top_level (environment
);
2839 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
2841 if (SCM_FALSEP (variable
))
2842 error_unbound_variable (symbol
);
2849 scm_eval_car (SCM pair
, SCM env
)
2851 return SCM_XEVALCAR (pair
, env
);
2856 scm_eval_args (SCM l
, SCM env
, SCM proc
)
2858 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
2859 while (SCM_CONSP (l
))
2861 res
= EVALCAR (l
, env
);
2863 *lloc
= scm_list_1 (res
);
2864 lloc
= SCM_CDRLOC (*lloc
);
2868 scm_wrong_num_args (proc
);
2874 scm_eval_body (SCM code
, SCM env
)
2879 next
= SCM_CDR (code
);
2880 while (!SCM_NULLP (next
))
2882 if (SCM_IMP (SCM_CAR (code
)))
2884 if (SCM_ISYMP (SCM_CAR (code
)))
2886 scm_rec_mutex_lock (&source_mutex
);
2887 /* check for race condition */
2888 if (SCM_ISYMP (SCM_CAR (code
)))
2889 m_expand_body (code
, env
);
2890 scm_rec_mutex_unlock (&source_mutex
);
2895 SCM_XEVAL (SCM_CAR (code
), env
);
2897 next
= SCM_CDR (code
);
2899 return SCM_XEVALCAR (code
, env
);
2905 /* SECTION: This code is specific for the debugging support. One
2906 * branch is read when DEVAL isn't defined, the other when DEVAL is
2912 #define SCM_APPLY scm_apply
2913 #define PREP_APPLY(proc, args)
2915 #define RETURN(x) do { return x; } while (0)
2916 #ifdef STACK_CHECKING
2917 #ifndef NO_CEVAL_STACK_CHECKING
2918 #define EVAL_STACK_CHECKING
2925 #define CEVAL deval /* Substitute all uses of ceval */
2928 #define SCM_APPLY scm_dapply
2931 #define PREP_APPLY(p, l) \
2932 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
2935 #define ENTER_APPLY \
2937 SCM_SET_ARGSREADY (debug);\
2938 if (scm_check_apply_p && SCM_TRAPS_P)\
2939 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
2941 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
2942 SCM_SET_TRACED_FRAME (debug); \
2944 if (SCM_CHEAPTRAPS_P)\
2946 tmp = scm_make_debugobj (&debug);\
2947 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
2952 tmp = scm_make_continuation (&first);\
2954 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
2961 #define RETURN(e) do { proc = (e); goto exit; } while (0)
2963 #ifdef STACK_CHECKING
2964 #ifndef EVAL_STACK_CHECKING
2965 #define EVAL_STACK_CHECKING
2970 /* scm_last_debug_frame contains a pointer to the last debugging information
2971 * stack frame. It is accessed very often from the debugging evaluator, so it
2972 * should probably not be indirectly addressed. Better to save and restore it
2973 * from the current root at any stack swaps.
2976 /* scm_debug_eframe_size is the number of slots available for pseudo
2977 * stack frames at each real stack frame.
2980 long scm_debug_eframe_size
;
2982 int scm_debug_mode_p
;
2983 int scm_check_entry_p
;
2984 int scm_check_apply_p
;
2985 int scm_check_exit_p
;
2987 long scm_eval_stack
;
2989 scm_t_option scm_eval_opts
[] = {
2990 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
2993 scm_t_option scm_debug_opts
[] = {
2994 { SCM_OPTION_BOOLEAN
, "cheap", 1,
2995 "*Flyweight representation of the stack at traps." },
2996 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
2997 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
2998 { SCM_OPTION_BOOLEAN
, "procnames", 1,
2999 "Record procedure names at definition." },
3000 { SCM_OPTION_BOOLEAN
, "backwards", 0,
3001 "Display backtrace in anti-chronological order." },
3002 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
3003 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
3004 { SCM_OPTION_INTEGER
, "frames", 3,
3005 "Maximum number of tail-recursive frames in backtrace." },
3006 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
3007 "Maximal number of stored backtrace frames." },
3008 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
3009 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
3010 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
3011 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
3012 { 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."}
3015 scm_t_option scm_evaluator_trap_table
[] = {
3016 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
3017 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
3018 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
3019 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
3020 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
3021 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
3022 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
3025 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
3027 "Option interface for the evaluation options. Instead of using\n"
3028 "this procedure directly, use the procedures @code{eval-enable},\n"
3029 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
3030 #define FUNC_NAME s_scm_eval_options_interface
3034 ans
= scm_options (setting
,
3038 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
3045 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
3047 "Option interface for the evaluator trap options.")
3048 #define FUNC_NAME s_scm_evaluator_traps
3052 ans
= scm_options (setting
,
3053 scm_evaluator_trap_table
,
3054 SCM_N_EVALUATOR_TRAPS
,
3056 SCM_RESET_DEBUG_MODE
;
3064 deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
3066 SCM
*results
= lloc
;
3067 while (SCM_CONSP (l
))
3069 const SCM res
= EVALCAR (l
, env
);
3071 *lloc
= scm_list_1 (res
);
3072 lloc
= SCM_CDRLOC (*lloc
);
3076 scm_wrong_num_args (proc
);
3083 /* SECTION: This code is compiled twice.
3087 /* Update the toplevel environment frame ENV so that it refers to the
3088 * current module. */
3089 #define UPDATE_TOPLEVEL_ENV(env) \
3091 SCM p = scm_current_module_lookup_closure (); \
3092 if (p != SCM_CAR (env)) \
3093 env = scm_top_level_env (p); \
3097 #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
3098 ASSERT_SYNTAX (!SCM_EQ_P ((x), SCM_EOL), s_empty_combination, x)
3101 /* This is the evaluator. Like any real monster, it has three heads:
3103 * ceval is the non-debugging evaluator, deval is the debugging version. Both
3104 * are implemented using a common code base, using the following mechanism:
3105 * CEVAL is a macro, which is either defined to ceval or deval. Thus, there
3106 * is no function CEVAL, but the code for CEVAL actually compiles to either
3107 * ceval or deval. When CEVAL is defined to ceval, it is known that the macro
3108 * DEVAL is not defined. When CEVAL is defined to deval, then the macro DEVAL
3109 * is known to be defined. Thus, in CEVAL parts for the debugging evaluator
3110 * are enclosed within #ifdef DEVAL ... #endif.
3112 * All three (ceval, deval and their common implementation CEVAL) take two
3113 * input parameters, x and env: x is a single expression to be evalutated.
3114 * env is the environment in which bindings are searched.
3116 * x is known to be a pair. Since x is a single expression, it is necessarily
3117 * in a tail position. If x is just a call to another function like in the
3118 * expression (foo exp1 exp2 ...), the realization of that call therefore
3119 * _must_not_ increase stack usage (the evaluation of exp1, exp2 etc.,
3120 * however, may do so). This is realized by making extensive use of 'goto'
3121 * statements within the evaluator: The gotos replace recursive calls to
3122 * CEVAL, thus re-using the same stack frame that CEVAL was already using.
3123 * If, however, x represents some form that requires to evaluate a sequence of
3124 * expressions like (begin exp1 exp2 ...), then recursive calls to CEVAL are
3125 * performed for all but the last expression of that sequence. */
3128 CEVAL (SCM x
, SCM env
)
3132 scm_t_debug_frame debug
;
3133 scm_t_debug_info
*debug_info_end
;
3134 debug
.prev
= scm_last_debug_frame
;
3137 * The debug.vect contains twice as much scm_t_debug_info frames as the
3138 * user has specified with (debug-set! frames <n>).
3140 * Even frames are eval frames, odd frames are apply frames.
3142 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
3143 * sizeof (scm_t_debug_info
));
3144 debug
.info
= debug
.vect
;
3145 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
3146 scm_last_debug_frame
= &debug
;
3148 #ifdef EVAL_STACK_CHECKING
3149 if (scm_stack_checking_enabled_p
&& SCM_STACK_OVERFLOW_P (&proc
))
3152 debug
.info
->e
.exp
= x
;
3153 debug
.info
->e
.env
= env
;
3155 scm_report_stack_overflow ();
3165 SCM_CLEAR_ARGSREADY (debug
);
3166 if (SCM_OVERFLOWP (debug
))
3169 * In theory, this should be the only place where it is necessary to
3170 * check for space in debug.vect since both eval frames and
3171 * available space are even.
3173 * For this to be the case, however, it is necessary that primitive
3174 * special forms which jump back to `loop', `begin' or some similar
3175 * label call PREP_APPLY.
3177 else if (++debug
.info
>= debug_info_end
)
3179 SCM_SET_OVERFLOW (debug
);
3184 debug
.info
->e
.exp
= x
;
3185 debug
.info
->e
.env
= env
;
3186 if (scm_check_entry_p
&& SCM_TRAPS_P
)
3188 if (SCM_ENTER_FRAME_P
3189 || (SCM_BREAKPOINTS_P
&& scm_c_source_property_breakpoint_p (x
)))
3192 SCM tail
= SCM_BOOL (SCM_TAILRECP (debug
));
3193 SCM_SET_TAILREC (debug
);
3194 if (SCM_CHEAPTRAPS_P
)
3195 stackrep
= scm_make_debugobj (&debug
);
3199 SCM val
= scm_make_continuation (&first
);
3209 /* This gives the possibility for the debugger to
3210 modify the source expression before evaluation. */
3215 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
3216 scm_sym_enter_frame
,
3219 unmemoize_expression (x
, env
));
3226 if (SCM_ISYMP (SCM_CAR (x
)))
3228 switch (ISYMNUM (SCM_CAR (x
)))
3230 case (ISYMNUM (SCM_IM_AND
)):
3232 while (!SCM_NULLP (SCM_CDR (x
)))
3234 SCM test_result
= EVALCAR (x
, env
);
3235 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
3236 RETURN (SCM_BOOL_F
);
3240 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3243 case (ISYMNUM (SCM_IM_BEGIN
)):
3246 RETURN (SCM_UNSPECIFIED
);
3248 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3251 /* If we are on toplevel with a lookup closure, we need to sync
3252 with the current module. */
3253 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
3255 UPDATE_TOPLEVEL_ENV (env
);
3256 while (!SCM_NULLP (SCM_CDR (x
)))
3259 UPDATE_TOPLEVEL_ENV (env
);
3265 goto nontoplevel_begin
;
3268 while (!SCM_NULLP (SCM_CDR (x
)))
3270 const SCM form
= SCM_CAR (x
);
3273 if (SCM_ISYMP (form
))
3275 scm_rec_mutex_lock (&source_mutex
);
3276 /* check for race condition */
3277 if (SCM_ISYMP (SCM_CAR (x
)))
3278 m_expand_body (x
, env
);
3279 scm_rec_mutex_unlock (&source_mutex
);
3280 goto nontoplevel_begin
;
3283 SCM_VALIDATE_NON_EMPTY_COMBINATION (form
);
3286 (void) EVAL (form
, env
);
3292 /* scm_eval last form in list */
3293 const SCM last_form
= SCM_CAR (x
);
3295 if (SCM_CONSP (last_form
))
3297 /* This is by far the most frequent case. */
3299 goto loop
; /* tail recurse */
3301 else if (SCM_IMP (last_form
))
3302 RETURN (SCM_EVALIM (last_form
, env
));
3303 else if (SCM_VARIABLEP (last_form
))
3304 RETURN (SCM_VARIABLE_REF (last_form
));
3305 else if (SCM_SYMBOLP (last_form
))
3306 RETURN (*scm_lookupcar (x
, env
, 1));
3312 case (ISYMNUM (SCM_IM_CASE
)):
3315 const SCM key
= EVALCAR (x
, env
);
3317 while (!SCM_NULLP (x
))
3319 const SCM clause
= SCM_CAR (x
);
3320 SCM labels
= SCM_CAR (clause
);
3321 if (SCM_EQ_P (labels
, SCM_IM_ELSE
))
3323 x
= SCM_CDR (clause
);
3324 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3327 while (!SCM_NULLP (labels
))
3329 const SCM label
= SCM_CAR (labels
);
3330 if (SCM_EQ_P (label
, key
)
3331 || !SCM_FALSEP (scm_eqv_p (label
, key
)))
3333 x
= SCM_CDR (clause
);
3334 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3337 labels
= SCM_CDR (labels
);
3342 RETURN (SCM_UNSPECIFIED
);
3345 case (ISYMNUM (SCM_IM_COND
)):
3347 while (!SCM_NULLP (x
))
3349 const SCM clause
= SCM_CAR (x
);
3350 if (SCM_EQ_P (SCM_CAR (clause
), SCM_IM_ELSE
))
3352 x
= SCM_CDR (clause
);
3353 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3358 arg1
= EVALCAR (clause
, env
);
3359 if (!SCM_FALSEP (arg1
) && !SCM_NILP (arg1
))
3361 x
= SCM_CDR (clause
);
3364 else if (!SCM_EQ_P (SCM_CAR (x
), SCM_IM_ARROW
))
3366 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3372 proc
= EVALCAR (proc
, env
);
3373 PREP_APPLY (proc
, scm_list_1 (arg1
));
3381 RETURN (SCM_UNSPECIFIED
);
3384 case (ISYMNUM (SCM_IM_DO
)):
3387 /* Compute the initialization values and the initial environment. */
3388 SCM init_forms
= SCM_CAR (x
);
3389 SCM init_values
= SCM_EOL
;
3390 while (!SCM_NULLP (init_forms
))
3392 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3393 init_forms
= SCM_CDR (init_forms
);
3396 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
3400 SCM test_form
= SCM_CAR (x
);
3401 SCM body_forms
= SCM_CADR (x
);
3402 SCM step_forms
= SCM_CDDR (x
);
3404 SCM test_result
= EVALCAR (test_form
, env
);
3406 while (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
3409 /* Evaluate body forms. */
3411 for (temp_forms
= body_forms
;
3412 !SCM_NULLP (temp_forms
);
3413 temp_forms
= SCM_CDR (temp_forms
))
3415 SCM form
= SCM_CAR (temp_forms
);
3416 /* Dirk:FIXME: We only need to eval forms that may have
3417 * a side effect here. This is only true for forms that
3418 * start with a pair. All others are just constants.
3419 * Since with the current memoizer 'form' may hold a
3420 * constant, we call EVAL here to handle the constant
3421 * cases. In the long run it would make sense to have
3422 * the macro transformer of 'do' eliminate all forms
3423 * that have no sideeffect. Then instead of EVAL we
3424 * could call CEVAL directly here. */
3425 (void) EVAL (form
, env
);
3430 /* Evaluate the step expressions. */
3432 SCM step_values
= SCM_EOL
;
3433 for (temp_forms
= step_forms
;
3434 !SCM_NULLP (temp_forms
);
3435 temp_forms
= SCM_CDR (temp_forms
))
3437 const SCM value
= EVALCAR (temp_forms
, env
);
3438 step_values
= scm_cons (value
, step_values
);
3440 env
= SCM_EXTEND_ENV (SCM_CAAR (env
),
3445 test_result
= EVALCAR (test_form
, env
);
3450 RETURN (SCM_UNSPECIFIED
);
3451 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3452 goto nontoplevel_begin
;
3455 case (ISYMNUM (SCM_IM_IF
)):
3458 SCM test_result
= EVALCAR (x
, env
);
3459 x
= SCM_CDR (x
); /* then expression */
3460 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
3462 x
= SCM_CDR (x
); /* else expression */
3464 RETURN (SCM_UNSPECIFIED
);
3467 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3471 case (ISYMNUM (SCM_IM_LET
)):
3474 SCM init_forms
= SCM_CADR (x
);
3475 SCM init_values
= SCM_EOL
;
3478 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3479 init_forms
= SCM_CDR (init_forms
);
3481 while (!SCM_NULLP (init_forms
));
3482 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
3485 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3486 goto nontoplevel_begin
;
3489 case (ISYMNUM (SCM_IM_LETREC
)):
3491 env
= SCM_EXTEND_ENV (SCM_CAR (x
), undefineds
, env
);
3494 SCM init_forms
= SCM_CAR (x
);
3495 SCM init_values
= SCM_EOL
;
3498 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3499 init_forms
= SCM_CDR (init_forms
);
3501 while (!SCM_NULLP (init_forms
));
3502 SCM_SETCDR (SCM_CAR (env
), init_values
);
3505 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3506 goto nontoplevel_begin
;
3509 case (ISYMNUM (SCM_IM_LETSTAR
)):
3512 SCM bindings
= SCM_CAR (x
);
3513 if (!SCM_NULLP (bindings
))
3517 SCM name
= SCM_CAR (bindings
);
3518 SCM init
= SCM_CDR (bindings
);
3519 env
= SCM_EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
3520 bindings
= SCM_CDR (init
);
3522 while (!SCM_NULLP (bindings
));
3526 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3527 goto nontoplevel_begin
;
3530 case (ISYMNUM (SCM_IM_OR
)):
3532 while (!SCM_NULLP (SCM_CDR (x
)))
3534 SCM val
= EVALCAR (x
, env
);
3535 if (!SCM_FALSEP (val
) && !SCM_NILP (val
))
3540 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3544 case (ISYMNUM (SCM_IM_LAMBDA
)):
3545 RETURN (scm_closure (SCM_CDR (x
), env
));
3548 case (ISYMNUM (SCM_IM_QUOTE
)):
3549 RETURN (SCM_CDR (x
));
3552 case (ISYMNUM (SCM_IM_SET_X
)):
3556 SCM variable
= SCM_CAR (x
);
3557 if (SCM_ILOCP (variable
))
3558 location
= scm_ilookup (variable
, env
);
3559 else if (SCM_VARIABLEP (variable
))
3560 location
= SCM_VARIABLE_LOC (variable
);
3563 /* (SCM_SYMBOLP (variable)) is known to be true */
3564 variable
= lazy_memoize_variable (variable
, env
);
3565 SCM_SETCAR (x
, variable
);
3566 location
= SCM_VARIABLE_LOC (variable
);
3569 *location
= EVALCAR (x
, env
);
3571 RETURN (SCM_UNSPECIFIED
);
3574 case (ISYMNUM (SCM_IM_APPLY
)):
3575 /* Evaluate the procedure to be applied. */
3577 proc
= EVALCAR (x
, env
);
3578 PREP_APPLY (proc
, SCM_EOL
);
3580 /* Evaluate the argument holding the list of arguments */
3582 arg1
= EVALCAR (x
, env
);
3585 /* Go here to tail-apply a procedure. PROC is the procedure and
3586 * ARG1 is the list of arguments. PREP_APPLY must have been called
3587 * before jumping to apply_proc. */
3588 if (SCM_CLOSUREP (proc
))
3590 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3592 debug
.info
->a
.args
= arg1
;
3594 if (scm_badargsp (formals
, arg1
))
3595 scm_wrong_num_args (proc
);
3597 /* Copy argument list */
3598 if (SCM_NULL_OR_NIL_P (arg1
))
3599 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
3602 SCM args
= scm_list_1 (SCM_CAR (arg1
));
3604 arg1
= SCM_CDR (arg1
);
3605 while (!SCM_NULL_OR_NIL_P (arg1
))
3607 SCM new_tail
= scm_list_1 (SCM_CAR (arg1
));
3608 SCM_SETCDR (tail
, new_tail
);
3610 arg1
= SCM_CDR (arg1
);
3612 env
= SCM_EXTEND_ENV (formals
, args
, SCM_ENV (proc
));
3615 x
= SCM_CLOSURE_BODY (proc
);
3616 goto nontoplevel_begin
;
3621 RETURN (SCM_APPLY (proc
, arg1
, SCM_EOL
));
3625 case (ISYMNUM (SCM_IM_CONT
)):
3628 SCM val
= scm_make_continuation (&first
);
3636 proc
= EVALCAR (proc
, env
);
3637 PREP_APPLY (proc
, scm_list_1 (arg1
));
3644 case (ISYMNUM (SCM_IM_DELAY
)):
3645 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
3648 case (ISYMNUM (SCM_IM_FUTURE
)):
3649 RETURN (scm_i_make_future (scm_closure (SCM_CDR (x
), env
)));
3652 /* PLACEHOLDER for case (ISYMNUM (SCM_IM_DISPATCH)): The following
3653 code (type_dispatch) is intended to be the tail of the case
3654 clause for the internal macro SCM_IM_DISPATCH. Please don't
3655 remove it from this location without discussing it with Mikael
3656 <djurfeldt@nada.kth.se> */
3658 /* The type dispatch code is duplicated below
3659 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
3660 * cuts down execution time for type dispatch to 50%. */
3661 type_dispatch
: /* inputs: x, arg1 */
3662 /* Type dispatch means to determine from the types of the function
3663 * arguments (i. e. the 'signature' of the call), which method from
3664 * a generic function is to be called. This process of selecting
3665 * the right method takes some time. To speed it up, guile uses
3666 * caching: Together with the macro call to dispatch the signatures
3667 * of some previous calls to that generic function from the same
3668 * place are stored (in the code!) in a cache that we call the
3669 * 'method cache'. This is done since it is likely, that
3670 * consecutive calls to dispatch from that position in the code will
3671 * have the same signature. Thus, the type dispatch works as
3672 * follows: First, determine a hash value from the signature of the
3673 * actual arguments. Second, use this hash value as an index to
3674 * find that same signature in the method cache stored at this
3675 * position in the code. If found, you have also found the
3676 * corresponding method that belongs to that signature. If the
3677 * signature is not found in the method cache, you have to perform a
3678 * full search over all signatures stored with the generic
3681 unsigned long int specializers
;
3682 unsigned long int hash_value
;
3683 unsigned long int cache_end_pos
;
3684 unsigned long int mask
;
3688 SCM z
= SCM_CDDR (x
);
3689 SCM tmp
= SCM_CADR (z
);
3690 specializers
= SCM_INUM (SCM_CAR (z
));
3692 /* Compute a hash value for searching the method cache. There
3693 * are two variants for computing the hash value, a (rather)
3694 * complicated one, and a simple one. For the complicated one
3695 * explained below, tmp holds a number that is used in the
3697 if (SCM_INUMP (tmp
))
3699 /* Use the signature of the actual arguments to determine
3700 * the hash value. This is done as follows: Each class has
3701 * an array of random numbers, that are determined when the
3702 * class is created. The integer 'hashset' is an index into
3703 * that array of random numbers. Now, from all classes that
3704 * are part of the signature of the actual arguments, the
3705 * random numbers at index 'hashset' are taken and summed
3706 * up, giving the hash value. The value of 'hashset' is
3707 * stored at the call to dispatch. This allows to have
3708 * different 'formulas' for calculating the hash value at
3709 * different places where dispatch is called. This allows
3710 * to optimize the hash formula at every individual place
3711 * where dispatch is called, such that hopefully the hash
3712 * value that is computed will directly point to the right
3713 * method in the method cache. */
3714 unsigned long int hashset
= SCM_INUM (tmp
);
3715 unsigned long int counter
= specializers
+ 1;
3718 while (!SCM_NULLP (tmp_arg
) && counter
!= 0)
3720 SCM
class = scm_class_of (SCM_CAR (tmp_arg
));
3721 hash_value
+= SCM_INSTANCE_HASH (class, hashset
);
3722 tmp_arg
= SCM_CDR (tmp_arg
);
3726 method_cache
= SCM_CADR (z
);
3727 mask
= SCM_INUM (SCM_CAR (z
));
3729 cache_end_pos
= hash_value
;
3733 /* This method of determining the hash value is much
3734 * simpler: Set the hash value to zero and just perform a
3735 * linear search through the method cache. */
3737 mask
= (unsigned long int) ((long) -1);
3739 cache_end_pos
= SCM_VECTOR_LENGTH (method_cache
);
3744 /* Search the method cache for a method with a matching
3745 * signature. Start the search at position 'hash_value'. The
3746 * hashing implementation uses linear probing for conflict
3747 * resolution, that is, if the signature in question is not
3748 * found at the starting index in the hash table, the next table
3749 * entry is tried, and so on, until in the worst case the whole
3750 * cache has been searched, but still the signature has not been
3755 SCM args
= arg1
; /* list of arguments */
3756 z
= SCM_VELTS (method_cache
)[hash_value
];
3757 while (!SCM_NULLP (args
))
3759 /* More arguments than specifiers => CLASS != ENV */
3760 SCM class_of_arg
= scm_class_of (SCM_CAR (args
));
3761 if (!SCM_EQ_P (class_of_arg
, SCM_CAR (z
)))
3763 args
= SCM_CDR (args
);
3766 /* Fewer arguments than specifiers => CAR != ENV */
3767 if (SCM_NULLP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
)))
3770 hash_value
= (hash_value
+ 1) & mask
;
3771 } while (hash_value
!= cache_end_pos
);
3773 /* No appropriate method was found in the cache. */
3774 z
= scm_memoize_method (x
, arg1
);
3776 apply_cmethod
: /* inputs: z, arg1 */
3778 SCM formals
= SCM_CMETHOD_FORMALS (z
);
3779 env
= SCM_EXTEND_ENV (formals
, arg1
, SCM_CMETHOD_ENV (z
));
3780 x
= SCM_CMETHOD_BODY (z
);
3781 goto nontoplevel_begin
;
3787 case (ISYMNUM (SCM_IM_SLOT_REF
)):
3790 SCM instance
= EVALCAR (x
, env
);
3791 unsigned long int slot
= SCM_INUM (SCM_CDR (x
));
3792 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance
) [slot
]));
3796 case (ISYMNUM (SCM_IM_SLOT_SET_X
)):
3799 SCM instance
= EVALCAR (x
, env
);
3800 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
3801 SCM value
= EVALCAR (SCM_CDDR (x
), env
);
3802 SCM_STRUCT_DATA (instance
) [slot
] = SCM_UNPACK (value
);
3803 RETURN (SCM_UNSPECIFIED
);
3807 #if SCM_ENABLE_ELISP
3809 case (ISYMNUM (SCM_IM_NIL_COND
)):
3811 SCM test_form
= SCM_CDR (x
);
3812 x
= SCM_CDR (test_form
);
3813 while (!SCM_NULL_OR_NIL_P (x
))
3815 SCM test_result
= EVALCAR (test_form
, env
);
3816 if (!(SCM_FALSEP (test_result
)
3817 || SCM_NULL_OR_NIL_P (test_result
)))
3819 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
3820 RETURN (test_result
);
3821 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3826 test_form
= SCM_CDR (x
);
3827 x
= SCM_CDR (test_form
);
3831 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3835 #endif /* SCM_ENABLE_ELISP */
3837 case (ISYMNUM (SCM_IM_BIND
)):
3839 SCM vars
, exps
, vals
;
3842 vars
= SCM_CAAR (x
);
3843 exps
= SCM_CDAR (x
);
3845 while (!SCM_NULLP (exps
))
3847 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
3848 exps
= SCM_CDR (exps
);
3851 scm_swap_bindings (vars
, vals
);
3852 scm_dynwinds
= scm_acons (vars
, vals
, scm_dynwinds
);
3854 /* Ignore all but the last evaluation result. */
3855 for (x
= SCM_CDR (x
); !SCM_NULLP (SCM_CDR (x
)); x
= SCM_CDR (x
))
3857 if (SCM_CONSP (SCM_CAR (x
)))
3858 CEVAL (SCM_CAR (x
), env
);
3860 proc
= EVALCAR (x
, env
);
3862 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
3863 scm_swap_bindings (vars
, vals
);
3869 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
3874 producer
= EVALCAR (x
, env
);
3876 proc
= EVALCAR (x
, env
); /* proc is the consumer. */
3877 arg1
= SCM_APPLY (producer
, SCM_EOL
, SCM_EOL
);
3878 if (SCM_VALUESP (arg1
))
3880 /* The list of arguments is not copied. Rather, it is assumed
3881 * that this has been done by the 'values' procedure. */
3882 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
3886 arg1
= scm_list_1 (arg1
);
3888 PREP_APPLY (proc
, arg1
);
3899 if (SCM_VARIABLEP (SCM_CAR (x
)))
3900 proc
= SCM_VARIABLE_REF (SCM_CAR (x
));
3901 else if (SCM_ILOCP (SCM_CAR (x
)))
3902 proc
= *scm_ilookup (SCM_CAR (x
), env
);
3903 else if (SCM_CONSP (SCM_CAR (x
)))
3904 proc
= CEVAL (SCM_CAR (x
), env
);
3905 else if (SCM_SYMBOLP (SCM_CAR (x
)))
3907 SCM orig_sym
= SCM_CAR (x
);
3909 SCM
*location
= scm_lookupcar1 (x
, env
, 1);
3910 if (location
== NULL
)
3912 /* we have lost the race, start again. */
3918 if (SCM_MACROP (proc
))
3920 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
3922 handle_a_macro
: /* inputs: x, env, proc */
3924 /* Set a flag during macro expansion so that macro
3925 application frames can be deleted from the backtrace. */
3926 SCM_SET_MACROEXP (debug
);
3928 arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
3929 scm_cons (env
, scm_listofnull
));
3931 SCM_CLEAR_MACROEXP (debug
);
3933 switch (SCM_MACRO_TYPE (proc
))
3937 if (!SCM_CONSP (arg1
))
3938 arg1
= scm_list_2 (SCM_IM_BEGIN
, arg1
);
3940 assert (!SCM_EQ_P (x
, SCM_CAR (arg1
))
3941 && !SCM_EQ_P (x
, SCM_CDR (arg1
)));
3944 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
3947 SCM_SETCAR (x
, SCM_CAR (arg1
));
3948 SCM_SETCDR (x
, SCM_CDR (arg1
));
3952 /* Prevent memoizing of debug info expression. */
3953 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
3958 SCM_SETCAR (x
, SCM_CAR (arg1
));
3959 SCM_SETCDR (x
, SCM_CDR (arg1
));
3961 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3963 #if SCM_ENABLE_DEPRECATED == 1
3968 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3982 if (SCM_MACROP (proc
))
3983 goto handle_a_macro
;
3987 /* When reaching this part of the code, the following is granted: Variable x
3988 * holds the first pair of an expression of the form (<function> arg ...).
3989 * Variable proc holds the object that resulted from the evaluation of
3990 * <function>. In the following, the arguments (if any) will be evaluated,
3991 * and proc will be applied to them. If proc does not really hold a
3992 * function object, this will be signalled as an error on the scheme
3993 * level. If the number of arguments does not match the number of arguments
3994 * that are allowed to be passed to proc, also an error on the scheme level
3995 * will be signalled. */
3996 PREP_APPLY (proc
, SCM_EOL
);
3997 if (SCM_NULLP (SCM_CDR (x
))) {
4000 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4001 switch (SCM_TYP7 (proc
))
4002 { /* no arguments given */
4003 case scm_tc7_subr_0
:
4004 RETURN (SCM_SUBRF (proc
) ());
4005 case scm_tc7_subr_1o
:
4006 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
4008 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
4009 case scm_tc7_rpsubr
:
4010 RETURN (SCM_BOOL_T
);
4012 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
4014 if (!SCM_SMOB_APPLICABLE_P (proc
))
4016 RETURN (SCM_SMOB_APPLY_0 (proc
));
4019 proc
= SCM_CCLO_SUBR (proc
);
4021 debug
.info
->a
.proc
= proc
;
4022 debug
.info
->a
.args
= scm_list_1 (arg1
);
4026 proc
= SCM_PROCEDURE (proc
);
4028 debug
.info
->a
.proc
= proc
;
4030 if (!SCM_CLOSUREP (proc
))
4033 case scm_tcs_closures
:
4035 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4036 if (SCM_CONSP (formals
))
4038 x
= SCM_CLOSURE_BODY (proc
);
4039 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
4040 goto nontoplevel_begin
;
4042 case scm_tcs_struct
:
4043 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4045 x
= SCM_ENTITY_PROCEDURE (proc
);
4049 else if (SCM_I_OPERATORP (proc
))
4052 proc
= (SCM_I_ENTITYP (proc
)
4053 ? SCM_ENTITY_PROCEDURE (proc
)
4054 : SCM_OPERATOR_PROCEDURE (proc
));
4056 debug
.info
->a
.proc
= proc
;
4057 debug
.info
->a
.args
= scm_list_1 (arg1
);
4063 case scm_tc7_subr_1
:
4064 case scm_tc7_subr_2
:
4065 case scm_tc7_subr_2o
:
4068 case scm_tc7_subr_3
:
4069 case scm_tc7_lsubr_2
:
4071 scm_wrong_num_args (proc
);
4074 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
4078 /* must handle macros by here */
4081 arg1
= EVALCAR (x
, env
);
4083 scm_wrong_num_args (proc
);
4085 debug
.info
->a
.args
= scm_list_1 (arg1
);
4093 evap1
: /* inputs: proc, arg1 */
4094 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4095 switch (SCM_TYP7 (proc
))
4096 { /* have one argument in arg1 */
4097 case scm_tc7_subr_2o
:
4098 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4099 case scm_tc7_subr_1
:
4100 case scm_tc7_subr_1o
:
4101 RETURN (SCM_SUBRF (proc
) (arg1
));
4103 if (SCM_INUMP (arg1
))
4105 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
4107 else if (SCM_REALP (arg1
))
4109 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4111 else if (SCM_BIGP (arg1
))
4113 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4115 else if (SCM_FRACTIONP (arg1
))
4117 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4119 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4120 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4123 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
4126 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
4127 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4128 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
4133 case scm_tc7_rpsubr
:
4134 RETURN (SCM_BOOL_T
);
4136 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4139 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4141 RETURN (SCM_SUBRF (proc
) (scm_list_1 (arg1
)));
4144 if (!SCM_SMOB_APPLICABLE_P (proc
))
4146 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
4150 proc
= SCM_CCLO_SUBR (proc
);
4152 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
4153 debug
.info
->a
.proc
= proc
;
4157 proc
= SCM_PROCEDURE (proc
);
4159 debug
.info
->a
.proc
= proc
;
4161 if (!SCM_CLOSUREP (proc
))
4164 case scm_tcs_closures
:
4167 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4168 if (SCM_NULLP (formals
)
4169 || (SCM_CONSP (formals
) && SCM_CONSP (SCM_CDR (formals
))))
4171 x
= SCM_CLOSURE_BODY (proc
);
4173 env
= SCM_EXTEND_ENV (formals
,
4177 env
= SCM_EXTEND_ENV (formals
,
4181 goto nontoplevel_begin
;
4183 case scm_tcs_struct
:
4184 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4186 x
= SCM_ENTITY_PROCEDURE (proc
);
4188 arg1
= debug
.info
->a
.args
;
4190 arg1
= scm_list_1 (arg1
);
4194 else if (SCM_I_OPERATORP (proc
))
4198 proc
= (SCM_I_ENTITYP (proc
)
4199 ? SCM_ENTITY_PROCEDURE (proc
)
4200 : SCM_OPERATOR_PROCEDURE (proc
));
4202 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
4203 debug
.info
->a
.proc
= proc
;
4209 case scm_tc7_subr_2
:
4210 case scm_tc7_subr_0
:
4211 case scm_tc7_subr_3
:
4212 case scm_tc7_lsubr_2
:
4213 scm_wrong_num_args (proc
);
4219 arg2
= EVALCAR (x
, env
);
4221 scm_wrong_num_args (proc
);
4223 { /* have two or more arguments */
4225 debug
.info
->a
.args
= scm_list_2 (arg1
, arg2
);
4228 if (SCM_NULLP (x
)) {
4231 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4232 switch (SCM_TYP7 (proc
))
4233 { /* have two arguments */
4234 case scm_tc7_subr_2
:
4235 case scm_tc7_subr_2o
:
4236 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
4239 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4241 RETURN (SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
)));
4243 case scm_tc7_lsubr_2
:
4244 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
));
4245 case scm_tc7_rpsubr
:
4247 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
4249 if (!SCM_SMOB_APPLICABLE_P (proc
))
4251 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
));
4255 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
4256 scm_cons (proc
, debug
.info
->a
.args
),
4259 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
4260 scm_cons2 (proc
, arg1
,
4267 case scm_tcs_struct
:
4268 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4270 x
= SCM_ENTITY_PROCEDURE (proc
);
4272 arg1
= debug
.info
->a
.args
;
4274 arg1
= scm_list_2 (arg1
, arg2
);
4278 else if (SCM_I_OPERATORP (proc
))
4282 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
4283 ? SCM_ENTITY_PROCEDURE (proc
)
4284 : SCM_OPERATOR_PROCEDURE (proc
),
4285 scm_cons (proc
, debug
.info
->a
.args
),
4288 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
4289 ? SCM_ENTITY_PROCEDURE (proc
)
4290 : SCM_OPERATOR_PROCEDURE (proc
),
4291 scm_cons2 (proc
, arg1
,
4301 case scm_tc7_subr_0
:
4304 case scm_tc7_subr_1o
:
4305 case scm_tc7_subr_1
:
4306 case scm_tc7_subr_3
:
4307 scm_wrong_num_args (proc
);
4311 proc
= SCM_PROCEDURE (proc
);
4313 debug
.info
->a
.proc
= proc
;
4315 if (!SCM_CLOSUREP (proc
))
4318 case scm_tcs_closures
:
4321 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4322 if (SCM_NULLP (formals
)
4323 || (SCM_CONSP (formals
)
4324 && (SCM_NULLP (SCM_CDR (formals
))
4325 || (SCM_CONSP (SCM_CDR (formals
))
4326 && SCM_CONSP (SCM_CDDR (formals
))))))
4329 env
= SCM_EXTEND_ENV (formals
,
4333 env
= SCM_EXTEND_ENV (formals
,
4334 scm_list_2 (arg1
, arg2
),
4337 x
= SCM_CLOSURE_BODY (proc
);
4338 goto nontoplevel_begin
;
4343 scm_wrong_num_args (proc
);
4345 debug
.info
->a
.args
= scm_cons2 (arg1
, arg2
,
4346 deval_args (x
, env
, proc
,
4347 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
4351 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4352 switch (SCM_TYP7 (proc
))
4353 { /* have 3 or more arguments */
4355 case scm_tc7_subr_3
:
4356 if (!SCM_NULLP (SCM_CDR (x
)))
4357 scm_wrong_num_args (proc
);
4359 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4360 SCM_CADDR (debug
.info
->a
.args
)));
4362 arg1
= SCM_SUBRF(proc
)(arg1
, arg2
);
4363 arg2
= SCM_CDDR (debug
.info
->a
.args
);
4366 arg1
= SCM_SUBRF(proc
)(arg1
, SCM_CAR (arg2
));
4367 arg2
= SCM_CDR (arg2
);
4369 while (SCM_NIMP (arg2
));
4371 case scm_tc7_rpsubr
:
4372 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
4373 RETURN (SCM_BOOL_F
);
4374 arg1
= SCM_CDDR (debug
.info
->a
.args
);
4377 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (arg1
))))
4378 RETURN (SCM_BOOL_F
);
4379 arg2
= SCM_CAR (arg1
);
4380 arg1
= SCM_CDR (arg1
);
4382 while (SCM_NIMP (arg1
));
4383 RETURN (SCM_BOOL_T
);
4384 case scm_tc7_lsubr_2
:
4385 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4386 SCM_CDDR (debug
.info
->a
.args
)));
4388 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4390 if (!SCM_SMOB_APPLICABLE_P (proc
))
4392 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4393 SCM_CDDR (debug
.info
->a
.args
)));
4397 proc
= SCM_PROCEDURE (proc
);
4398 debug
.info
->a
.proc
= proc
;
4399 if (!SCM_CLOSUREP (proc
))
4402 case scm_tcs_closures
:
4404 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4405 if (SCM_NULLP (formals
)
4406 || (SCM_CONSP (formals
)
4407 && (SCM_NULLP (SCM_CDR (formals
))
4408 || (SCM_CONSP (SCM_CDR (formals
))
4409 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4411 SCM_SET_ARGSREADY (debug
);
4412 env
= SCM_EXTEND_ENV (formals
,
4415 x
= SCM_CLOSURE_BODY (proc
);
4416 goto nontoplevel_begin
;
4419 case scm_tc7_subr_3
:
4420 if (!SCM_NULLP (SCM_CDR (x
)))
4421 scm_wrong_num_args (proc
);
4423 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, EVALCAR (x
, env
)));
4425 arg1
= SCM_SUBRF (proc
) (arg1
, arg2
);
4428 arg1
= SCM_SUBRF(proc
)(arg1
, EVALCAR(x
, env
));
4431 while (!SCM_NULLP (x
));
4433 case scm_tc7_rpsubr
:
4434 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
4435 RETURN (SCM_BOOL_F
);
4438 arg1
= EVALCAR (x
, env
);
4439 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, arg1
)))
4440 RETURN (SCM_BOOL_F
);
4444 while (!SCM_NULLP (x
));
4445 RETURN (SCM_BOOL_T
);
4446 case scm_tc7_lsubr_2
:
4447 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
4449 RETURN (SCM_SUBRF (proc
) (scm_cons2 (arg1
,
4451 scm_eval_args (x
, env
, proc
))));
4453 if (!SCM_SMOB_APPLICABLE_P (proc
))
4455 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4456 scm_eval_args (x
, env
, proc
)));
4460 proc
= SCM_PROCEDURE (proc
);
4461 if (!SCM_CLOSUREP (proc
))
4464 case scm_tcs_closures
:
4466 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4467 if (SCM_NULLP (formals
)
4468 || (SCM_CONSP (formals
)
4469 && (SCM_NULLP (SCM_CDR (formals
))
4470 || (SCM_CONSP (SCM_CDR (formals
))
4471 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4473 env
= SCM_EXTEND_ENV (formals
,
4476 scm_eval_args (x
, env
, proc
)),
4478 x
= SCM_CLOSURE_BODY (proc
);
4479 goto nontoplevel_begin
;
4482 case scm_tcs_struct
:
4483 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4486 arg1
= debug
.info
->a
.args
;
4488 arg1
= scm_cons2 (arg1
, arg2
, scm_eval_args (x
, env
, proc
));
4490 x
= SCM_ENTITY_PROCEDURE (proc
);
4493 else if (SCM_I_OPERATORP (proc
))
4497 case scm_tc7_subr_2
:
4498 case scm_tc7_subr_1o
:
4499 case scm_tc7_subr_2o
:
4500 case scm_tc7_subr_0
:
4503 case scm_tc7_subr_1
:
4504 scm_wrong_num_args (proc
);
4512 if (scm_check_exit_p
&& SCM_TRAPS_P
)
4513 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
4515 SCM_CLEAR_TRACED_FRAME (debug
);
4516 if (SCM_CHEAPTRAPS_P
)
4517 arg1
= scm_make_debugobj (&debug
);
4521 SCM val
= scm_make_continuation (&first
);
4532 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
4536 scm_last_debug_frame
= debug
.prev
;
4542 /* SECTION: This code is compiled once.
4549 /* Simple procedure calls
4553 scm_call_0 (SCM proc
)
4555 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
4559 scm_call_1 (SCM proc
, SCM arg1
)
4561 return scm_apply (proc
, arg1
, scm_listofnull
);
4565 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
4567 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
4571 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
4573 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
4577 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
4579 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
4580 scm_cons (arg4
, scm_listofnull
)));
4583 /* Simple procedure applies
4587 scm_apply_0 (SCM proc
, SCM args
)
4589 return scm_apply (proc
, args
, SCM_EOL
);
4593 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
4595 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
4599 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
4601 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
4605 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
4607 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
4611 /* This code processes the arguments to apply:
4613 (apply PROC ARG1 ... ARGS)
4615 Given a list (ARG1 ... ARGS), this function conses the ARG1
4616 ... arguments onto the front of ARGS, and returns the resulting
4617 list. Note that ARGS is a list; thus, the argument to this
4618 function is a list whose last element is a list.
4620 Apply calls this function, and applies PROC to the elements of the
4621 result. apply:nconc2last takes care of building the list of
4622 arguments, given (ARG1 ... ARGS).
4624 Rather than do new consing, apply:nconc2last destroys its argument.
4625 On that topic, this code came into my care with the following
4626 beautifully cryptic comment on that topic: "This will only screw
4627 you if you do (scm_apply scm_apply '( ... ))" If you know what
4628 they're referring to, send me a patch to this comment. */
4630 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
4632 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
4633 "conses the @var{arg1} @dots{} arguments onto the front of\n"
4634 "@var{args}, and returns the resulting list. Note that\n"
4635 "@var{args} is a list; thus, the argument to this function is\n"
4636 "a list whose last element is a list.\n"
4637 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
4638 "destroys its argument, so use with care.")
4639 #define FUNC_NAME s_scm_nconc2last
4642 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
4644 while (!SCM_NULLP (SCM_CDR (*lloc
))) /* Perhaps should be
4645 SCM_NULL_OR_NIL_P, but not
4646 needed in 99.99% of cases,
4647 and it could seriously hurt
4648 performance. - Neil */
4649 lloc
= SCM_CDRLOC (*lloc
);
4650 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
4651 *lloc
= SCM_CAR (*lloc
);
4659 /* SECTION: When DEVAL is defined this code yields scm_dapply.
4660 * It is compiled twice.
4665 scm_apply (SCM proc
, SCM arg1
, SCM args
)
4671 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
4676 /* Apply a function to a list of arguments.
4678 This function is exported to the Scheme level as taking two
4679 required arguments and a tail argument, as if it were:
4680 (lambda (proc arg1 . args) ...)
4681 Thus, if you just have a list of arguments to pass to a procedure,
4682 pass the list as ARG1, and '() for ARGS. If you have some fixed
4683 args, pass the first as ARG1, then cons any remaining fixed args
4684 onto the front of your argument list, and pass that as ARGS. */
4687 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
4690 scm_t_debug_frame debug
;
4691 scm_t_debug_info debug_vect_body
;
4692 debug
.prev
= scm_last_debug_frame
;
4693 debug
.status
= SCM_APPLYFRAME
;
4694 debug
.vect
= &debug_vect_body
;
4695 debug
.vect
[0].a
.proc
= proc
;
4696 debug
.vect
[0].a
.args
= SCM_EOL
;
4697 scm_last_debug_frame
= &debug
;
4699 if (scm_debug_mode_p
)
4700 return scm_dapply (proc
, arg1
, args
);
4703 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
4705 /* If ARGS is the empty list, then we're calling apply with only two
4706 arguments --- ARG1 is the list of arguments for PROC. Whatever
4707 the case, futz with things so that ARG1 is the first argument to
4708 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
4711 Setting the debug apply frame args this way is pretty messy.
4712 Perhaps we should store arg1 and args directly in the frame as
4713 received, and let scm_frame_arguments unpack them, because that's
4714 a relatively rare operation. This works for now; if the Guile
4715 developer archives are still around, see Mikael's post of
4717 if (SCM_NULLP (args
))
4719 if (SCM_NULLP (arg1
))
4721 arg1
= SCM_UNDEFINED
;
4723 debug
.vect
[0].a
.args
= SCM_EOL
;
4729 debug
.vect
[0].a
.args
= arg1
;
4731 args
= SCM_CDR (arg1
);
4732 arg1
= SCM_CAR (arg1
);
4737 args
= scm_nconc2last (args
);
4739 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4743 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
4746 if (SCM_CHEAPTRAPS_P
)
4747 tmp
= scm_make_debugobj (&debug
);
4752 tmp
= scm_make_continuation (&first
);
4757 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
4764 switch (SCM_TYP7 (proc
))
4766 case scm_tc7_subr_2o
:
4767 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
4768 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4769 case scm_tc7_subr_2
:
4770 if (SCM_NULLP (args
) || !SCM_NULLP (SCM_CDR (args
)))
4771 scm_wrong_num_args (proc
);
4772 args
= SCM_CAR (args
);
4773 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4774 case scm_tc7_subr_0
:
4775 if (!SCM_UNBNDP (arg1
))
4776 scm_wrong_num_args (proc
);
4778 RETURN (SCM_SUBRF (proc
) ());
4779 case scm_tc7_subr_1
:
4780 if (SCM_UNBNDP (arg1
))
4781 scm_wrong_num_args (proc
);
4782 case scm_tc7_subr_1o
:
4783 if (!SCM_NULLP (args
))
4784 scm_wrong_num_args (proc
);
4786 RETURN (SCM_SUBRF (proc
) (arg1
));
4788 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
4789 scm_wrong_num_args (proc
);
4790 if (SCM_INUMP (arg1
))
4792 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
4794 else if (SCM_REALP (arg1
))
4796 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4798 else if (SCM_BIGP (arg1
))
4800 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4802 else if (SCM_FRACTIONP (arg1
))
4804 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4806 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4807 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4809 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
4810 scm_wrong_num_args (proc
);
4812 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
4815 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
4816 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4817 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
4822 case scm_tc7_subr_3
:
4823 if (SCM_NULLP (args
)
4824 || SCM_NULLP (SCM_CDR (args
))
4825 || !SCM_NULLP (SCM_CDDR (args
)))
4826 scm_wrong_num_args (proc
);
4828 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
4831 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
4833 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
4835 case scm_tc7_lsubr_2
:
4836 if (!SCM_CONSP (args
))
4837 scm_wrong_num_args (proc
);
4839 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4841 if (SCM_NULLP (args
))
4842 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4843 while (SCM_NIMP (args
))
4845 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
4846 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
4847 args
= SCM_CDR (args
);
4850 case scm_tc7_rpsubr
:
4851 if (SCM_NULLP (args
))
4852 RETURN (SCM_BOOL_T
);
4853 while (SCM_NIMP (args
))
4855 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
4856 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
4857 RETURN (SCM_BOOL_F
);
4858 arg1
= SCM_CAR (args
);
4859 args
= SCM_CDR (args
);
4861 RETURN (SCM_BOOL_T
);
4862 case scm_tcs_closures
:
4864 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4866 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4868 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
4869 scm_wrong_num_args (proc
);
4871 /* Copy argument list */
4876 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
4877 for (arg1
= SCM_CDR (arg1
); SCM_CONSP (arg1
); arg1
= SCM_CDR (arg1
))
4879 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
));
4882 SCM_SETCDR (tl
, arg1
);
4885 args
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4888 proc
= SCM_CLOSURE_BODY (proc
);
4890 arg1
= SCM_CDR (proc
);
4891 while (!SCM_NULLP (arg1
))
4893 if (SCM_IMP (SCM_CAR (proc
)))
4895 if (SCM_ISYMP (SCM_CAR (proc
)))
4897 scm_rec_mutex_lock (&source_mutex
);
4898 /* check for race condition */
4899 if (SCM_ISYMP (SCM_CAR (proc
)))
4900 m_expand_body (proc
, args
);
4901 scm_rec_mutex_unlock (&source_mutex
);
4905 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
4908 (void) EVAL (SCM_CAR (proc
), args
);
4910 arg1
= SCM_CDR (proc
);
4912 RETURN (EVALCAR (proc
, args
));
4914 if (!SCM_SMOB_APPLICABLE_P (proc
))
4916 if (SCM_UNBNDP (arg1
))
4917 RETURN (SCM_SMOB_APPLY_0 (proc
));
4918 else if (SCM_NULLP (args
))
4919 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
4920 else if (SCM_NULLP (SCM_CDR (args
)))
4921 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
4923 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4926 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4928 proc
= SCM_CCLO_SUBR (proc
);
4929 debug
.vect
[0].a
.proc
= proc
;
4930 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4932 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4934 proc
= SCM_CCLO_SUBR (proc
);
4938 proc
= SCM_PROCEDURE (proc
);
4940 debug
.vect
[0].a
.proc
= proc
;
4943 case scm_tcs_struct
:
4944 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4947 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4949 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4951 RETURN (scm_apply_generic (proc
, args
));
4953 else if (SCM_I_OPERATORP (proc
))
4957 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4959 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4962 proc
= (SCM_I_ENTITYP (proc
)
4963 ? SCM_ENTITY_PROCEDURE (proc
)
4964 : SCM_OPERATOR_PROCEDURE (proc
));
4966 debug
.vect
[0].a
.proc
= proc
;
4967 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4969 if (SCM_NIMP (proc
))
4978 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
4982 if (scm_check_exit_p
&& SCM_TRAPS_P
)
4983 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
4985 SCM_CLEAR_TRACED_FRAME (debug
);
4986 if (SCM_CHEAPTRAPS_P
)
4987 arg1
= scm_make_debugobj (&debug
);
4991 SCM val
= scm_make_continuation (&first
);
5002 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
5006 scm_last_debug_frame
= debug
.prev
;
5012 /* SECTION: The rest of this file is only read once.
5019 * Trampolines make it possible to move procedure application dispatch
5020 * outside inner loops. The motivation was clean implementation of
5021 * efficient replacements of R5RS primitives in SRFI-1.
5023 * The semantics is clear: scm_trampoline_N returns an optimized
5024 * version of scm_call_N (or NULL if the procedure isn't applicable
5027 * Applying the optimization to map and for-each increased efficiency
5028 * noticeably. For example, (map abs ls) is now 8 times faster than
5033 call_subr0_0 (SCM proc
)
5035 return SCM_SUBRF (proc
) ();
5039 call_subr1o_0 (SCM proc
)
5041 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
5045 call_lsubr_0 (SCM proc
)
5047 return SCM_SUBRF (proc
) (SCM_EOL
);
5051 scm_i_call_closure_0 (SCM proc
)
5053 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
5056 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
5061 scm_trampoline_0 (SCM proc
)
5063 scm_t_trampoline_0 trampoline
;
5068 switch (SCM_TYP7 (proc
))
5070 case scm_tc7_subr_0
:
5071 trampoline
= call_subr0_0
;
5073 case scm_tc7_subr_1o
:
5074 trampoline
= call_subr1o_0
;
5077 trampoline
= call_lsubr_0
;
5079 case scm_tcs_closures
:
5081 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5082 if (SCM_NULLP (formals
) || !SCM_CONSP (formals
))
5083 trampoline
= scm_i_call_closure_0
;
5088 case scm_tcs_struct
:
5089 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5090 trampoline
= scm_call_generic_0
;
5091 else if (SCM_I_OPERATORP (proc
))
5092 trampoline
= scm_call_0
;
5097 if (SCM_SMOB_APPLICABLE_P (proc
))
5098 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
5103 case scm_tc7_rpsubr
:
5106 trampoline
= scm_call_0
;
5109 return NULL
; /* not applicable on zero arguments */
5111 /* We only reach this point if a valid trampoline was determined. */
5113 /* If debugging is enabled, we want to see all calls to proc on the stack.
5114 * Thus, we replace the trampoline shortcut with scm_call_0. */
5115 if (scm_debug_mode_p
)
5122 call_subr1_1 (SCM proc
, SCM arg1
)
5124 return SCM_SUBRF (proc
) (arg1
);
5128 call_subr2o_1 (SCM proc
, SCM arg1
)
5130 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
5134 call_lsubr_1 (SCM proc
, SCM arg1
)
5136 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
5140 call_dsubr_1 (SCM proc
, SCM arg1
)
5142 if (SCM_INUMP (arg1
))
5144 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
5146 else if (SCM_REALP (arg1
))
5148 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
5150 else if (SCM_BIGP (arg1
))
5152 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
5154 else if (SCM_FRACTIONP (arg1
))
5156 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
5158 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
5159 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
5163 call_cxr_1 (SCM proc
, SCM arg1
)
5165 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
5168 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
5169 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
5170 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
5177 call_closure_1 (SCM proc
, SCM arg1
)
5179 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
5182 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
5187 scm_trampoline_1 (SCM proc
)
5189 scm_t_trampoline_1 trampoline
;
5194 switch (SCM_TYP7 (proc
))
5196 case scm_tc7_subr_1
:
5197 case scm_tc7_subr_1o
:
5198 trampoline
= call_subr1_1
;
5200 case scm_tc7_subr_2o
:
5201 trampoline
= call_subr2o_1
;
5204 trampoline
= call_lsubr_1
;
5207 trampoline
= call_dsubr_1
;
5210 trampoline
= call_cxr_1
;
5212 case scm_tcs_closures
:
5214 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5215 if (!SCM_NULLP (formals
)
5216 && (!SCM_CONSP (formals
) || !SCM_CONSP (SCM_CDR (formals
))))
5217 trampoline
= call_closure_1
;
5222 case scm_tcs_struct
:
5223 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5224 trampoline
= scm_call_generic_1
;
5225 else if (SCM_I_OPERATORP (proc
))
5226 trampoline
= scm_call_1
;
5231 if (SCM_SMOB_APPLICABLE_P (proc
))
5232 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
5237 case scm_tc7_rpsubr
:
5240 trampoline
= scm_call_1
;
5243 return NULL
; /* not applicable on one arg */
5245 /* We only reach this point if a valid trampoline was determined. */
5247 /* If debugging is enabled, we want to see all calls to proc on the stack.
5248 * Thus, we replace the trampoline shortcut with scm_call_1. */
5249 if (scm_debug_mode_p
)
5256 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
5258 return SCM_SUBRF (proc
) (arg1
, arg2
);
5262 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
5264 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
5268 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
5270 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
5274 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
5276 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
5277 scm_list_2 (arg1
, arg2
),
5279 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
5284 scm_trampoline_2 (SCM proc
)
5286 scm_t_trampoline_2 trampoline
;
5291 switch (SCM_TYP7 (proc
))
5293 case scm_tc7_subr_2
:
5294 case scm_tc7_subr_2o
:
5295 case scm_tc7_rpsubr
:
5297 trampoline
= call_subr2_2
;
5299 case scm_tc7_lsubr_2
:
5300 trampoline
= call_lsubr2_2
;
5303 trampoline
= call_lsubr_2
;
5305 case scm_tcs_closures
:
5307 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5308 if (!SCM_NULLP (formals
)
5309 && (!SCM_CONSP (formals
)
5310 || (!SCM_NULLP (SCM_CDR (formals
))
5311 && (!SCM_CONSP (SCM_CDR (formals
))
5312 || !SCM_CONSP (SCM_CDDR (formals
))))))
5313 trampoline
= call_closure_2
;
5318 case scm_tcs_struct
:
5319 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5320 trampoline
= scm_call_generic_2
;
5321 else if (SCM_I_OPERATORP (proc
))
5322 trampoline
= scm_call_2
;
5327 if (SCM_SMOB_APPLICABLE_P (proc
))
5328 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
5334 trampoline
= scm_call_2
;
5337 return NULL
; /* not applicable on two args */
5339 /* We only reach this point if a valid trampoline was determined. */
5341 /* If debugging is enabled, we want to see all calls to proc on the stack.
5342 * Thus, we replace the trampoline shortcut with scm_call_2. */
5343 if (scm_debug_mode_p
)
5349 /* Typechecking for multi-argument MAP and FOR-EACH.
5351 Verify that each element of the vector ARGV, except for the first,
5352 is a proper list whose length is LEN. Attribute errors to WHO,
5353 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
5355 check_map_args (SCM argv
,
5362 SCM
const *ve
= SCM_VELTS (argv
);
5365 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
5367 long elt_len
= scm_ilength (ve
[i
]);
5372 scm_apply_generic (gf
, scm_cons (proc
, args
));
5374 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
5378 scm_out_of_range_pos (who
, ve
[i
], SCM_MAKINUM (i
+ 2));
5381 scm_remember_upto_here_1 (argv
);
5385 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
5387 /* Note: Currently, scm_map applies PROC to the argument list(s)
5388 sequentially, starting with the first element(s). This is used in
5389 evalext.c where the Scheme procedure `map-in-order', which guarantees
5390 sequential behaviour, is implemented using scm_map. If the
5391 behaviour changes, we need to update `map-in-order'.
5395 scm_map (SCM proc
, SCM arg1
, SCM args
)
5396 #define FUNC_NAME s_map
5401 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
5403 len
= scm_ilength (arg1
);
5404 SCM_GASSERTn (len
>= 0,
5405 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
5406 SCM_VALIDATE_REST_ARGUMENT (args
);
5407 if (SCM_NULLP (args
))
5409 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5410 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
5411 while (SCM_NIMP (arg1
))
5413 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
5414 pres
= SCM_CDRLOC (*pres
);
5415 arg1
= SCM_CDR (arg1
);
5419 if (SCM_NULLP (SCM_CDR (args
)))
5421 SCM arg2
= SCM_CAR (args
);
5422 int len2
= scm_ilength (arg2
);
5423 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5425 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
5426 SCM_GASSERTn (len2
>= 0,
5427 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
5429 SCM_OUT_OF_RANGE (3, arg2
);
5430 while (SCM_NIMP (arg1
))
5432 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
5433 pres
= SCM_CDRLOC (*pres
);
5434 arg1
= SCM_CDR (arg1
);
5435 arg2
= SCM_CDR (arg2
);
5439 arg1
= scm_cons (arg1
, args
);
5440 args
= scm_vector (arg1
);
5441 ve
= SCM_VELTS (args
);
5442 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
5446 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5448 if (SCM_IMP (ve
[i
]))
5450 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
5451 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
5453 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
5454 pres
= SCM_CDRLOC (*pres
);
5460 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
5463 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
5464 #define FUNC_NAME s_for_each
5466 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
5468 len
= scm_ilength (arg1
);
5469 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
5470 SCM_ARG2
, s_for_each
);
5471 SCM_VALIDATE_REST_ARGUMENT (args
);
5472 if (SCM_NULLP (args
))
5474 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5475 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
5476 while (SCM_NIMP (arg1
))
5478 call (proc
, SCM_CAR (arg1
));
5479 arg1
= SCM_CDR (arg1
);
5481 return SCM_UNSPECIFIED
;
5483 if (SCM_NULLP (SCM_CDR (args
)))
5485 SCM arg2
= SCM_CAR (args
);
5486 int len2
= scm_ilength (arg2
);
5487 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5488 SCM_GASSERTn (call
, g_for_each
,
5489 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
5490 SCM_GASSERTn (len2
>= 0, g_for_each
,
5491 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
5493 SCM_OUT_OF_RANGE (3, arg2
);
5494 while (SCM_NIMP (arg1
))
5496 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
5497 arg1
= SCM_CDR (arg1
);
5498 arg2
= SCM_CDR (arg2
);
5500 return SCM_UNSPECIFIED
;
5502 arg1
= scm_cons (arg1
, args
);
5503 args
= scm_vector (arg1
);
5504 ve
= SCM_VELTS (args
);
5505 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
5509 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5511 if (SCM_IMP (ve
[i
]))
5512 return SCM_UNSPECIFIED
;
5513 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
5514 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
5516 scm_apply (proc
, arg1
, SCM_EOL
);
5523 scm_closure (SCM code
, SCM env
)
5526 SCM closcar
= scm_cons (code
, SCM_EOL
);
5527 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
5528 scm_remember_upto_here (closcar
);
5533 scm_t_bits scm_tc16_promise
;
5536 scm_makprom (SCM code
)
5538 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
5540 scm_make_rec_mutex ());
5544 promise_free (SCM promise
)
5546 scm_rec_mutex_free (SCM_PROMISE_MUTEX (promise
));
5551 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
5553 int writingp
= SCM_WRITINGP (pstate
);
5554 scm_puts ("#<promise ", port
);
5555 SCM_SET_WRITINGP (pstate
, 1);
5556 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
5557 SCM_SET_WRITINGP (pstate
, writingp
);
5558 scm_putc ('>', port
);
5562 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
5564 "If the promise @var{x} has not been computed yet, compute and\n"
5565 "return @var{x}, otherwise just return the previously computed\n"
5567 #define FUNC_NAME s_scm_force
5569 SCM_VALIDATE_SMOB (1, promise
, promise
);
5570 scm_rec_mutex_lock (SCM_PROMISE_MUTEX (promise
));
5571 if (!SCM_PROMISE_COMPUTED_P (promise
))
5573 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
5574 if (!SCM_PROMISE_COMPUTED_P (promise
))
5576 SCM_SET_PROMISE_DATA (promise
, ans
);
5577 SCM_SET_PROMISE_COMPUTED (promise
);
5580 scm_rec_mutex_unlock (SCM_PROMISE_MUTEX (promise
));
5581 return SCM_PROMISE_DATA (promise
);
5586 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
5588 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
5589 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
5590 #define FUNC_NAME s_scm_promise_p
5592 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
5597 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
5598 (SCM xorig
, SCM x
, SCM y
),
5599 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
5600 "Any source properties associated with @var{xorig} are also associated\n"
5601 "with the new pair.")
5602 #define FUNC_NAME s_scm_cons_source
5605 z
= scm_cons (x
, y
);
5606 /* Copy source properties possibly associated with xorig. */
5607 p
= scm_whash_lookup (scm_source_whash
, xorig
);
5609 scm_whash_insert (scm_source_whash
, z
, p
);
5615 /* The function scm_copy_tree is used to copy an expression tree to allow the
5616 * memoizer to modify the expression during memoization. scm_copy_tree
5617 * creates deep copies of pairs and vectors, but not of any other data types,
5618 * since only pairs and vectors will be parsed by the memoizer.
5620 * To avoid infinite recursion due to cyclic structures, the hare-and-tortoise
5621 * pattern is used to detect cycles. In fact, the pattern is used in two
5622 * dimensions, vertical (indicated in the code by the variable names 'hare'
5623 * and 'tortoise') and horizontal ('rabbit' and 'turtle'). In both
5624 * dimensions, the hare/rabbit will take two steps when the tortoise/turtle
5627 * The vertical dimension corresponds to recursive calls to function
5628 * copy_tree: This happens when descending into vector elements, into cars of
5629 * lists and into the cdr of an improper list. In this dimension, the
5630 * tortoise follows the hare by using the processor stack: Every stack frame
5631 * will hold an instance of struct t_trace. These instances are connected in
5632 * a way that represents the trace of the hare, which thus can be followed by
5633 * the tortoise. The tortoise will always point to struct t_trace instances
5634 * relating to SCM objects that have already been copied. Thus, a cycle is
5635 * detected if the tortoise and the hare point to the same object,
5637 * The horizontal dimension is within one execution of copy_tree, when the
5638 * function cdr's along the pairs of a list. This is the standard
5639 * hare-and-tortoise implementation, found several times in guile. */
5642 struct t_trace
*trace
; // These pointers form a trace along the stack.
5643 SCM obj
; // The object handled at the respective stack frame.
5648 struct t_trace
*const hare
,
5649 struct t_trace
*tortoise
,
5650 unsigned int tortoise_delay
)
5652 if (!SCM_CONSP (hare
->obj
) && !SCM_VECTORP (hare
->obj
))
5658 /* Prepare the trace along the stack. */
5659 struct t_trace new_hare
;
5660 hare
->trace
= &new_hare
;
5662 /* The tortoise will make its step after the delay has elapsed. Note
5663 * that in contrast to the typical hare-and-tortoise pattern, the step
5664 * of the tortoise happens before the hare takes its steps. This is, in
5665 * principle, no problem, except for the start of the algorithm: Then,
5666 * it has to be made sure that the hare actually gets its advantage of
5668 if (tortoise_delay
== 0)
5671 tortoise
= tortoise
->trace
;
5672 ASSERT_SYNTAX (!SCM_EQ_P (hare
->obj
, tortoise
->obj
),
5673 s_bad_expression
, hare
->obj
);
5680 if (SCM_VECTORP (hare
->obj
))
5682 const unsigned long int length
= SCM_VECTOR_LENGTH (hare
->obj
);
5683 const SCM new_vector
= scm_c_make_vector (length
, SCM_UNSPECIFIED
);
5685 /* Each vector element is copied by recursing into copy_tree, having
5686 * the tortoise follow the hare into the depths of the stack. */
5687 unsigned long int i
;
5688 for (i
= 0; i
< length
; ++i
)
5691 new_hare
.obj
= SCM_VECTOR_REF (hare
->obj
, i
);
5692 new_element
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5693 SCM_VECTOR_SET (new_vector
, i
, new_element
);
5698 else // SCM_CONSP (hare->obj)
5703 SCM rabbit
= hare
->obj
;
5704 SCM turtle
= hare
->obj
;
5708 /* The first pair of the list is treated specially, in order to
5709 * preserve a potential source code position. */
5710 result
= tail
= scm_cons_source (rabbit
, SCM_EOL
, SCM_EOL
);
5711 new_hare
.obj
= SCM_CAR (rabbit
);
5712 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5713 SCM_SETCAR (tail
, copy
);
5715 /* The remaining pairs of the list are copied by, horizontally,
5716 * having the turtle follow the rabbit, and, vertically, having the
5717 * tortoise follow the hare into the depths of the stack. */
5718 rabbit
= SCM_CDR (rabbit
);
5719 while (SCM_CONSP (rabbit
))
5721 new_hare
.obj
= SCM_CAR (rabbit
);
5722 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5723 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
5724 tail
= SCM_CDR (tail
);
5726 rabbit
= SCM_CDR (rabbit
);
5727 if (SCM_CONSP (rabbit
))
5729 new_hare
.obj
= SCM_CAR (rabbit
);
5730 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5731 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
5732 tail
= SCM_CDR (tail
);
5733 rabbit
= SCM_CDR (rabbit
);
5735 turtle
= SCM_CDR (turtle
);
5736 ASSERT_SYNTAX (!SCM_EQ_P (rabbit
, turtle
),
5737 s_bad_expression
, rabbit
);
5741 /* We have to recurse into copy_tree again for the last cdr, in
5742 * order to handle the situation that it holds a vector. */
5743 new_hare
.obj
= rabbit
;
5744 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5745 SCM_SETCDR (tail
, copy
);
5752 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
5754 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
5755 "the new data structure. @code{copy-tree} recurses down the\n"
5756 "contents of both pairs and vectors (since both cons cells and vector\n"
5757 "cells may point to arbitrary objects), and stops recursing when it hits\n"
5758 "any other object.")
5759 #define FUNC_NAME s_scm_copy_tree
5761 /* Prepare the trace along the stack. */
5762 struct t_trace trace
;
5765 /* In function copy_tree, if the tortoise makes its step, it will do this
5766 * before the hare has the chance to move. Thus, we have to make sure that
5767 * the very first step of the tortoise will not happen after the hare has
5768 * really made two steps. This is achieved by passing '2' as the initial
5769 * delay for the tortoise. NOTE: Since cycles are unlikely, giving the hare
5770 * a bigger advantage may improve performance slightly. */
5771 return copy_tree (&trace
, &trace
, 2);
5776 /* We have three levels of EVAL here:
5778 - scm_i_eval (exp, env)
5780 evaluates EXP in environment ENV. ENV is a lexical environment
5781 structure as used by the actual tree code evaluator. When ENV is
5782 a top-level environment, then changes to the current module are
5783 tracked by updating ENV so that it continues to be in sync with
5786 - scm_primitive_eval (exp)
5788 evaluates EXP in the top-level environment as determined by the
5789 current module. This is done by constructing a suitable
5790 environment and calling scm_i_eval. Thus, changes to the
5791 top-level module are tracked normally.
5793 - scm_eval (exp, mod)
5795 evaluates EXP while MOD is the current module. This is done by
5796 setting the current module to MOD, invoking scm_primitive_eval on
5797 EXP, and then restoring the current module to the value it had
5798 previously. That is, while EXP is evaluated, changes to the
5799 current module are tracked, but these changes do not persist when
5802 For each level of evals, there are two variants, distinguished by a
5803 _x suffix: the ordinary variant does not modify EXP while the _x
5804 variant can destructively modify EXP into something completely
5805 unintelligible. A Scheme data structure passed as EXP to one of the
5806 _x variants should not ever be used again for anything. So when in
5807 doubt, use the ordinary variant.
5812 scm_i_eval_x (SCM exp
, SCM env
)
5814 if (SCM_SYMBOLP (exp
))
5815 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
5817 return SCM_XEVAL (exp
, env
);
5821 scm_i_eval (SCM exp
, SCM env
)
5823 exp
= scm_copy_tree (exp
);
5824 if (SCM_SYMBOLP (exp
))
5825 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
5827 return SCM_XEVAL (exp
, env
);
5831 scm_primitive_eval_x (SCM exp
)
5834 SCM transformer
= scm_current_module_transformer ();
5835 if (SCM_NIMP (transformer
))
5836 exp
= scm_call_1 (transformer
, exp
);
5837 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5838 return scm_i_eval_x (exp
, env
);
5841 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
5843 "Evaluate @var{exp} in the top-level environment specified by\n"
5844 "the current module.")
5845 #define FUNC_NAME s_scm_primitive_eval
5848 SCM transformer
= scm_current_module_transformer ();
5849 if (SCM_NIMP (transformer
))
5850 exp
= scm_call_1 (transformer
, exp
);
5851 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5852 return scm_i_eval (exp
, env
);
5857 /* Eval does not take the second arg optionally. This is intentional
5858 * in order to be R5RS compatible, and to prepare for the new module
5859 * system, where we would like to make the choice of evaluation
5860 * environment explicit. */
5863 change_environment (void *data
)
5865 SCM pair
= SCM_PACK (data
);
5866 SCM new_module
= SCM_CAR (pair
);
5867 SCM old_module
= scm_current_module ();
5868 SCM_SETCDR (pair
, old_module
);
5869 scm_set_current_module (new_module
);
5873 restore_environment (void *data
)
5875 SCM pair
= SCM_PACK (data
);
5876 SCM old_module
= SCM_CDR (pair
);
5877 SCM new_module
= scm_current_module ();
5878 SCM_SETCAR (pair
, new_module
);
5879 scm_set_current_module (old_module
);
5883 inner_eval_x (void *data
)
5885 return scm_primitive_eval_x (SCM_PACK(data
));
5889 scm_eval_x (SCM exp
, SCM module
)
5890 #define FUNC_NAME "eval!"
5892 SCM_VALIDATE_MODULE (2, module
);
5894 return scm_internal_dynamic_wind
5895 (change_environment
, inner_eval_x
, restore_environment
,
5896 (void *) SCM_UNPACK (exp
),
5897 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
5902 inner_eval (void *data
)
5904 return scm_primitive_eval (SCM_PACK(data
));
5907 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
5908 (SCM exp
, SCM module
),
5909 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
5910 "in the top-level environment specified by @var{module}.\n"
5911 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
5912 "@var{module} is made the current module. The current module\n"
5913 "is reset to its previous value when @var{eval} returns.")
5914 #define FUNC_NAME s_scm_eval
5916 SCM_VALIDATE_MODULE (2, module
);
5918 return scm_internal_dynamic_wind
5919 (change_environment
, inner_eval
, restore_environment
,
5920 (void *) SCM_UNPACK (exp
),
5921 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
5926 /* At this point, deval and scm_dapply are generated.
5933 #if (SCM_ENABLE_DEPRECATED == 1)
5935 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5936 SCM
scm_ceval (SCM x
, SCM env
)
5939 return ceval (x
, env
);
5940 else if (SCM_SYMBOLP (x
))
5941 return *scm_lookupcar (scm_cons (x
, SCM_UNDEFINED
), env
, 1);
5943 return SCM_XEVAL (x
, env
);
5946 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5947 SCM
scm_deval (SCM x
, SCM env
)
5950 return deval (x
, env
);
5951 else if (SCM_SYMBOLP (x
))
5952 return *scm_lookupcar (scm_cons (x
, SCM_UNDEFINED
), env
, 1);
5954 return SCM_XEVAL (x
, env
);
5958 dispatching_eval (SCM x
, SCM env
)
5960 if (scm_debug_mode_p
)
5961 return scm_deval (x
, env
);
5963 return scm_ceval (x
, env
);
5966 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5967 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
) = dispatching_eval
;
5975 scm_init_opts (scm_evaluator_traps
,
5976 scm_evaluator_trap_table
,
5977 SCM_N_EVALUATOR_TRAPS
);
5978 scm_init_opts (scm_eval_options_interface
,
5980 SCM_N_EVAL_OPTIONS
);
5982 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
5983 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
5984 scm_set_smob_free (scm_tc16_promise
, promise_free
);
5985 scm_set_smob_print (scm_tc16_promise
, promise_print
);
5987 undefineds
= scm_list_1 (SCM_UNDEFINED
);
5988 SCM_SETCDR (undefineds
, undefineds
);
5989 scm_permanent_object (undefineds
);
5991 scm_listofnull
= scm_list_1 (SCM_EOL
);
5993 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
5994 scm_permanent_object (f_apply
);
5996 #include "libguile/eval.x"
5998 scm_add_feature ("delay");