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:". */
29 /* SECTION: This code is compiled once.
36 #include "libguile/__scm.h"
40 /* AIX requires this to be the first thing in the file. The #pragma
41 directive is indented so pre-ANSI compilers will ignore it, rather
50 # ifndef alloca /* predefined by HP cc +Olibcalls */
58 #include "libguile/_scm.h"
59 #include "libguile/alist.h"
60 #include "libguile/async.h"
61 #include "libguile/continuations.h"
62 #include "libguile/debug.h"
63 #include "libguile/deprecation.h"
64 #include "libguile/dynwind.h"
65 #include "libguile/eq.h"
66 #include "libguile/feature.h"
67 #include "libguile/fluids.h"
68 #include "libguile/futures.h"
69 #include "libguile/goops.h"
70 #include "libguile/hash.h"
71 #include "libguile/hashtab.h"
72 #include "libguile/lang.h"
73 #include "libguile/list.h"
74 #include "libguile/macros.h"
75 #include "libguile/modules.h"
76 #include "libguile/objects.h"
77 #include "libguile/ports.h"
78 #include "libguile/print.h"
79 #include "libguile/procprop.h"
80 #include "libguile/root.h"
81 #include "libguile/smob.h"
82 #include "libguile/srcprop.h"
83 #include "libguile/stackchk.h"
84 #include "libguile/strings.h"
85 #include "libguile/throw.h"
86 #include "libguile/validate.h"
87 #include "libguile/values.h"
88 #include "libguile/vectors.h"
90 #include "libguile/eval.h"
96 static SCM
unmemoize_exprs (SCM expr
, SCM env
);
97 static SCM
canonicalize_define (SCM expr
);
98 static SCM
*scm_lookupcar1 (SCM vloc
, SCM genv
, int check
);
99 static SCM
unmemoize_builtin_macro (SCM expr
, SCM env
);
105 * This section defines the message strings for the syntax errors that can be
106 * detected during memoization and the functions and macros that shall be
107 * called by the memoizer code to signal syntax errors. */
110 /* Syntax errors that can be detected during memoization: */
112 /* Circular or improper lists do not form valid scheme expressions. If a
113 * circular list or an improper list is detected in a place where a scheme
114 * expression is expected, a 'Bad expression' error is signalled. */
115 static const char s_bad_expression
[] = "Bad expression";
117 /* If a form is detected that holds a different number of expressions than are
118 * required in that context, a 'Missing or extra expression' error is
120 static const char s_expression
[] = "Missing or extra expression in";
122 /* If a form is detected that holds less expressions than are required in that
123 * context, a 'Missing expression' error is signalled. */
124 static const char s_missing_expression
[] = "Missing expression in";
126 /* If a form is detected that holds more expressions than are allowed in that
127 * context, an 'Extra expression' error is signalled. */
128 static const char s_extra_expression
[] = "Extra expression in";
130 /* The empty combination '()' is not allowed as an expression in scheme. If
131 * it is detected in a place where an expression is expected, an 'Illegal
132 * empty combination' error is signalled. Note: If you encounter this error
133 * message, it is very likely that you intended to denote the empty list. To
134 * do so, you need to quote the empty list like (quote ()) or '(). */
135 static const char s_empty_combination
[] = "Illegal empty combination";
137 /* A body may hold an arbitrary number of internal defines, followed by a
138 * non-empty sequence of expressions. If a body with an empty sequence of
139 * expressions is detected, a 'Missing body expression' error is signalled.
141 static const char s_missing_body_expression
[] = "Missing body expression in";
143 /* A body may hold an arbitrary number of internal defines, followed by a
144 * non-empty sequence of expressions. Each the definitions and the
145 * expressions may be grouped arbitraryly with begin, but it is not allowed to
146 * mix definitions and expressions. If a define form in a body mixes
147 * definitions and expressions, a 'Mixed definitions and expressions' error is
149 static const char s_mixed_body_forms
[] = "Mixed definitions and expressions in";
150 /* Definitions are only allowed on the top level and at the start of a body.
151 * If a definition is detected anywhere else, a 'Bad define placement' error
153 static const char s_bad_define
[] = "Bad define placement";
155 /* Case or cond expressions must have at least one clause. If a case or cond
156 * expression without any clauses is detected, a 'Missing clauses' error is
158 static const char s_missing_clauses
[] = "Missing clauses";
160 /* If there is an 'else' clause in a case or a cond statement, it must be the
161 * last clause. If after the 'else' case clause further clauses are detected,
162 * a 'Misplaced else clause' error is signalled. */
163 static const char s_misplaced_else_clause
[] = "Misplaced else clause";
165 /* If a case clause is detected that is not in the format
166 * (<label(s)> <expression1> <expression2> ...)
167 * a 'Bad case clause' error is signalled. */
168 static const char s_bad_case_clause
[] = "Bad case clause";
170 /* If a case clause is detected where the <label(s)> element is neither a
171 * proper list nor (in case of the last clause) the syntactic keyword 'else',
172 * a 'Bad case labels' error is signalled. Note: If you encounter this error
173 * for an else-clause which seems to be syntactically correct, check if 'else'
174 * is really a syntactic keyword in that context. If 'else' is bound in the
175 * local or global environment, it is not considered a syntactic keyword, but
176 * will be treated as any other variable. */
177 static const char s_bad_case_labels
[] = "Bad case labels";
179 /* In a case statement all labels have to be distinct. If in a case statement
180 * a label occurs more than once, a 'Duplicate case label' error is
182 static const char s_duplicate_case_label
[] = "Duplicate case label";
184 /* If a cond clause is detected that is not in one of the formats
185 * (<test> <expression1> ...) or (else <expression1> <expression2> ...)
186 * a 'Bad cond clause' error is signalled. */
187 static const char s_bad_cond_clause
[] = "Bad cond clause";
189 /* If a cond clause is detected that uses the alternate '=>' form, but does
190 * not hold a recipient element for the test result, a 'Missing recipient'
191 * error is signalled. */
192 static const char s_missing_recipient
[] = "Missing recipient in";
194 /* If in a position where a variable name is required some other object is
195 * detected, a 'Bad variable' error is signalled. */
196 static const char s_bad_variable
[] = "Bad variable";
198 /* Bindings for forms like 'let' and 'do' have to be given in a proper,
199 * possibly empty list. If any other object is detected in a place where a
200 * list of bindings was required, a 'Bad bindings' error is signalled. */
201 static const char s_bad_bindings
[] = "Bad bindings";
203 /* Depending on the syntactic context, a binding has to be in the format
204 * (<variable> <expression>) or (<variable> <expression1> <expression2>).
205 * If anything else is detected in a place where a binding was expected, a
206 * 'Bad binding' error is signalled. */
207 static const char s_bad_binding
[] = "Bad binding";
209 /* Some syntactic forms don't allow variable names to appear more than once in
210 * a list of bindings. If such a situation is nevertheless detected, a
211 * 'Duplicate binding' error is signalled. */
212 static const char s_duplicate_binding
[] = "Duplicate binding";
214 /* If the exit form of a 'do' expression is not in the format
215 * (<test> <expression> ...)
216 * a 'Bad exit clause' error is signalled. */
217 static const char s_bad_exit_clause
[] = "Bad exit clause";
219 /* The formal function arguments of a lambda expression have to be either a
220 * single symbol or a non-cyclic list. For anything else a 'Bad formals'
221 * error is signalled. */
222 static const char s_bad_formals
[] = "Bad formals";
224 /* If in a lambda expression something else than a symbol is detected at a
225 * place where a formal function argument is required, a 'Bad formal' error is
227 static const char s_bad_formal
[] = "Bad formal";
229 /* If in the arguments list of a lambda expression an argument name occurs
230 * more than once, a 'Duplicate formal' error is signalled. */
231 static const char s_duplicate_formal
[] = "Duplicate formal";
233 /* If the evaluation of an unquote-splicing expression gives something else
234 * than a proper list, a 'Non-list result for unquote-splicing' error is
236 static const char s_splicing
[] = "Non-list result for unquote-splicing";
238 /* If something else than an exact integer is detected as the argument for
239 * @slot-ref and @slot-set!, a 'Bad slot number' error is signalled. */
240 static const char s_bad_slot_number
[] = "Bad slot number";
243 /* Signal a syntax error. We distinguish between the form that caused the
244 * error and the enclosing expression. The error message will print out as
245 * shown in the following pattern. The file name and line number are only
246 * given when they can be determined from the erroneous form or from the
247 * enclosing expression.
249 * <filename>: In procedure memoization:
250 * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
252 SCM_SYMBOL (syntax_error_key
, "syntax-error");
254 /* The prototype is needed to indicate that the function does not return. */
256 syntax_error (const char* const, const SCM
, const SCM
) SCM_NORETURN
;
259 syntax_error (const char* const msg
, const SCM form
, const SCM expr
)
261 SCM msg_string
= scm_from_locale_string (msg
);
262 SCM filename
= SCM_BOOL_F
;
263 SCM linenr
= SCM_BOOL_F
;
267 if (scm_is_pair (form
))
269 filename
= scm_source_property (form
, scm_sym_filename
);
270 linenr
= scm_source_property (form
, scm_sym_line
);
273 if (scm_is_false (filename
) && scm_is_false (linenr
) && scm_is_pair (expr
))
275 filename
= scm_source_property (expr
, scm_sym_filename
);
276 linenr
= scm_source_property (expr
, scm_sym_line
);
279 if (!SCM_UNBNDP (expr
))
281 if (scm_is_true (filename
))
283 format
= "In file ~S, line ~S: ~A ~S in expression ~S.";
284 args
= scm_list_5 (filename
, linenr
, msg_string
, form
, expr
);
286 else if (scm_is_true (linenr
))
288 format
= "In line ~S: ~A ~S in expression ~S.";
289 args
= scm_list_4 (linenr
, msg_string
, form
, expr
);
293 format
= "~A ~S in expression ~S.";
294 args
= scm_list_3 (msg_string
, form
, expr
);
299 if (scm_is_true (filename
))
301 format
= "In file ~S, line ~S: ~A ~S.";
302 args
= scm_list_4 (filename
, linenr
, msg_string
, form
);
304 else if (scm_is_true (linenr
))
306 format
= "In line ~S: ~A ~S.";
307 args
= scm_list_3 (linenr
, msg_string
, form
);
312 args
= scm_list_2 (msg_string
, form
);
316 scm_error (syntax_error_key
, "memoization", format
, args
, SCM_BOOL_F
);
320 /* Shortcut macros to simplify syntax error handling. */
321 #define ASSERT_SYNTAX(cond, message, form) \
322 { if (!(cond)) syntax_error (message, form, SCM_UNDEFINED); }
323 #define ASSERT_SYNTAX_2(cond, message, form, expr) \
324 { if (!(cond)) syntax_error (message, form, expr); }
330 * Ilocs are memoized references to variables in local environment frames.
331 * They are represented as three values: The relative offset of the
332 * environment frame, the number of the binding within that frame, and a
333 * boolean value indicating whether the binding is the last binding in the
336 * Frame numbers have 11 bits, relative offsets have 12 bits.
339 #define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc)
340 #define SCM_IFRINC (0x00000100L)
341 #define SCM_ICDR (0x00080000L)
342 #define SCM_IDINC (0x00100000L)
343 #define SCM_IFRAME(n) ((long)((SCM_ICDR-SCM_IFRINC)>>8) \
344 & (SCM_UNPACK (n) >> 8))
345 #define SCM_IDIST(n) (SCM_UNPACK (n) >> 20)
346 #define SCM_ICDRP(n) (SCM_ICDR & SCM_UNPACK (n))
347 #define SCM_IDSTMSK (-SCM_IDINC)
348 #define SCM_IFRAMEMAX ((1<<11)-1)
349 #define SCM_IDISTMAX ((1<<12)-1)
350 #define SCM_MAKE_ILOC(frame_nr, binding_nr, last_p) \
353 + ((binding_nr) << 20) \
354 + ((last_p) ? SCM_ICDR : 0) \
358 scm_i_print_iloc (SCM iloc
, SCM port
)
360 scm_puts ("#@", port
);
361 scm_intprint ((long) SCM_IFRAME (iloc
), 10, port
);
362 scm_putc (SCM_ICDRP (iloc
) ? '-' : '+', port
);
363 scm_intprint ((long) SCM_IDIST (iloc
), 10, port
);
366 #if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
368 SCM
scm_dbg_make_iloc (SCM frame
, SCM binding
, SCM cdrp
);
370 SCM_DEFINE (scm_dbg_make_iloc
, "dbg-make-iloc", 3, 0, 0,
371 (SCM frame
, SCM binding
, SCM cdrp
),
372 "Return a new iloc with frame offset @var{frame}, binding\n"
373 "offset @var{binding} and the cdr flag @var{cdrp}.")
374 #define FUNC_NAME s_scm_dbg_make_iloc
376 return SCM_MAKE_ILOC (scm_to_unsigned_integer (frame
, 0, SCM_IFRAME_MAX
),
377 scm_to_unsigned_integer (binding
, 0, SCM_IDIST_MAX
),
382 SCM
scm_dbg_iloc_p (SCM obj
);
384 SCM_DEFINE (scm_dbg_iloc_p
, "dbg-iloc?", 1, 0, 0,
386 "Return @code{#t} if @var{obj} is an iloc.")
387 #define FUNC_NAME s_scm_dbg_iloc_p
389 return scm_from_bool (SCM_ILOCP (obj
));
397 /* {Evaluator byte codes (isyms)}
400 #define ISYMNUM(n) (SCM_ITAG8_DATA (n))
402 /* This table must agree with the list of SCM_IM_ constants in tags.h */
403 static const char *const isymnames
[] =
420 "#@call-with-current-continuation",
426 "#@call-with-values",
434 scm_i_print_isym (SCM isym
, SCM port
)
436 const size_t isymnum
= ISYMNUM (isym
);
437 if (isymnum
< (sizeof isymnames
/ sizeof (char *)))
438 scm_puts (isymnames
[isymnum
], port
);
440 scm_ipruk ("isym", isym
, port
);
445 /* The function lookup_symbol is used during memoization: Lookup the symbol in
446 * the environment. If there is no binding for the symbol, SCM_UNDEFINED is
447 * returned. If the symbol is a global variable, the variable object to which
448 * the symbol is bound is returned. Finally, if the symbol is a local
449 * variable the corresponding iloc object is returned. */
451 /* A helper function for lookup_symbol: Try to find the symbol in the top
452 * level environment frame. The function returns SCM_UNDEFINED if the symbol
453 * is unbound and it returns a variable object if the symbol is a global
456 lookup_global_symbol (const SCM symbol
, const SCM top_level
)
458 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
459 if (scm_is_false (variable
))
460 return SCM_UNDEFINED
;
466 lookup_symbol (const SCM symbol
, const SCM env
)
469 unsigned int frame_nr
;
471 for (frame_idx
= env
, frame_nr
= 0;
472 !scm_is_null (frame_idx
);
473 frame_idx
= SCM_CDR (frame_idx
), ++frame_nr
)
475 const SCM frame
= SCM_CAR (frame_idx
);
476 if (scm_is_pair (frame
))
478 /* frame holds a local environment frame */
480 unsigned int symbol_nr
;
482 for (symbol_idx
= SCM_CAR (frame
), symbol_nr
= 0;
483 scm_is_pair (symbol_idx
);
484 symbol_idx
= SCM_CDR (symbol_idx
), ++symbol_nr
)
486 if (scm_is_eq (SCM_CAR (symbol_idx
), symbol
))
487 /* found the symbol, therefore return the iloc */
488 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 0);
490 if (scm_is_eq (symbol_idx
, symbol
))
491 /* found the symbol as the last element of the current frame */
492 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 1);
496 /* no more local environment frames */
497 return lookup_global_symbol (symbol
, frame
);
501 return lookup_global_symbol (symbol
, SCM_BOOL_F
);
505 /* Return true if the symbol is - from the point of view of a macro
506 * transformer - a literal in the sense specified in chapter "pattern
507 * language" of R5RS. In the code below, however, we don't match the
508 * definition of R5RS exactly: It returns true if the identifier has no
509 * binding or if it is a syntactic keyword. */
511 literal_p (const SCM symbol
, const SCM env
)
513 const SCM variable
= lookup_symbol (symbol
, env
);
514 if (SCM_UNBNDP (variable
))
516 if (SCM_VARIABLEP (variable
) && SCM_MACROP (SCM_VARIABLE_REF (variable
)))
523 /* Return true if the expression is self-quoting in the memoized code. Thus,
524 * some other objects (like e. g. vectors) are reported as self-quoting, which
525 * according to R5RS would need to be quoted. */
527 is_self_quoting_p (const SCM expr
)
529 if (scm_is_pair (expr
))
531 else if (scm_is_symbol (expr
))
533 else if (scm_is_null (expr
))
539 SCM_SYMBOL (sym_three_question_marks
, "???");
542 unmemoize_expression (const SCM expr
, const SCM env
)
544 if (SCM_ILOCP (expr
))
547 unsigned long int frame_nr
;
549 unsigned long int symbol_nr
;
551 for (frame_idx
= env
, frame_nr
= SCM_IFRAME (expr
);
553 frame_idx
= SCM_CDR (frame_idx
), --frame_nr
)
555 for (symbol_idx
= SCM_CAAR (frame_idx
), symbol_nr
= SCM_IDIST (expr
);
557 symbol_idx
= SCM_CDR (symbol_idx
), --symbol_nr
)
559 return SCM_ICDRP (expr
) ? symbol_idx
: SCM_CAR (symbol_idx
);
561 else if (SCM_VARIABLEP (expr
))
563 const SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), expr
);
564 return scm_is_true (sym
) ? sym
: sym_three_question_marks
;
566 else if (scm_is_simple_vector (expr
))
568 return scm_list_2 (scm_sym_quote
, expr
);
570 else if (!scm_is_pair (expr
))
574 else if (SCM_ISYMP (SCM_CAR (expr
)))
576 return unmemoize_builtin_macro (expr
, env
);
580 return unmemoize_exprs (expr
, env
);
586 unmemoize_exprs (const SCM exprs
, const SCM env
)
588 SCM r_result
= SCM_EOL
;
589 SCM expr_idx
= exprs
;
592 /* Note that due to the current lazy memoizer we may find partially memoized
593 * code during execution. In such code we have to expect improper lists of
594 * expressions: On the one hand, for such code syntax checks have not yet
595 * fully been performed, on the other hand, there may be even legal code
596 * like '(a . b) appear as an improper list of expressions as long as the
597 * quote expression is still in its unmemoized form. For this reason, the
598 * following code handles improper lists of expressions until memoization
599 * and execution have been completely separated. */
600 for (; scm_is_pair (expr_idx
); expr_idx
= SCM_CDR (expr_idx
))
602 const SCM expr
= SCM_CAR (expr_idx
);
604 /* In partially memoized code, lists of expressions that stem from a
605 * body form may start with an ISYM if the body itself has not yet been
606 * memoized. This isym is just an internal marker to indicate that the
607 * body still needs to be memoized. An isym may occur at the very
608 * beginning of the body or after one or more comment strings. It is
609 * dropped during unmemoization. */
610 if (!SCM_ISYMP (expr
))
612 um_expr
= unmemoize_expression (expr
, env
);
613 r_result
= scm_cons (um_expr
, r_result
);
616 um_expr
= unmemoize_expression (expr_idx
, env
);
617 if (!scm_is_null (r_result
))
619 const SCM result
= scm_reverse_x (r_result
, SCM_UNDEFINED
);
620 SCM_SETCDR (r_result
, um_expr
);
630 /* Rewrite the body (which is given as the list of expressions forming the
631 * body) into its internal form. The internal form of a body (<expr> ...) is
632 * just the body itself, but prefixed with an ISYM that denotes to what kind
633 * of outer construct this body belongs: (<ISYM> <expr> ...). A lambda body
634 * starts with SCM_IM_LAMBDA, for example, a body of a let starts with
637 * It is assumed that the calling expression has already made sure that the
638 * body is a proper list. */
640 m_body (SCM op
, SCM exprs
)
642 /* Don't add another ISYM if one is present already. */
643 if (SCM_ISYMP (SCM_CAR (exprs
)))
646 return scm_cons (op
, exprs
);
650 /* The function m_expand_body memoizes a proper list of expressions forming a
651 * body. This function takes care of dealing with internal defines and
652 * transforming them into an equivalent letrec expression. The list of
653 * expressions is rewritten in place. */
655 /* This is a helper function for m_expand_body. If the argument expression is
656 * a symbol that denotes a syntactic keyword, the corresponding macro object
657 * is returned, in all other cases the function returns SCM_UNDEFINED. */
659 try_macro_lookup (const SCM expr
, const SCM env
)
661 if (scm_is_symbol (expr
))
663 const SCM variable
= lookup_symbol (expr
, env
);
664 if (SCM_VARIABLEP (variable
))
666 const SCM value
= SCM_VARIABLE_REF (variable
);
667 if (SCM_MACROP (value
))
672 return SCM_UNDEFINED
;
675 /* This is a helper function for m_expand_body. It expands user macros,
676 * because for the correct translation of a body we need to know whether they
677 * expand to a definition. */
679 expand_user_macros (SCM expr
, const SCM env
)
681 while (scm_is_pair (expr
))
683 const SCM car_expr
= SCM_CAR (expr
);
684 const SCM new_car
= expand_user_macros (car_expr
, env
);
685 const SCM value
= try_macro_lookup (new_car
, env
);
687 if (SCM_MACROP (value
) && SCM_MACRO_TYPE (value
) == 2)
689 /* User macros transform code into code. */
690 expr
= scm_call_2 (SCM_MACRO_CODE (value
), expr
, env
);
691 /* We need to reiterate on the transformed code. */
695 /* No user macro: return. */
696 SCM_SETCAR (expr
, new_car
);
704 /* This is a helper function for m_expand_body. It determines if a given form
705 * represents an application of a given built-in macro. The built-in macro to
706 * check for is identified by its syntactic keyword. The form is an
707 * application of the given macro if looking up the car of the form in the
708 * given environment actually returns the built-in macro. */
710 is_system_macro_p (const SCM syntactic_keyword
, const SCM form
, const SCM env
)
712 if (scm_is_pair (form
))
714 const SCM car_form
= SCM_CAR (form
);
715 const SCM value
= try_macro_lookup (car_form
, env
);
716 if (SCM_BUILTIN_MACRO_P (value
))
718 const SCM macro_name
= scm_macro_name (value
);
719 return scm_is_eq (macro_name
, syntactic_keyword
);
727 m_expand_body (const SCM forms
, const SCM env
)
729 /* The first body form can be skipped since it is known to be the ISYM that
730 * was prepended to the body by m_body. */
731 SCM cdr_forms
= SCM_CDR (forms
);
732 SCM form_idx
= cdr_forms
;
733 SCM definitions
= SCM_EOL
;
734 SCM sequence
= SCM_EOL
;
736 /* According to R5RS, the list of body forms consists of two parts: a number
737 * (maybe zero) of definitions, followed by a non-empty sequence of
738 * expressions. Each the definitions and the expressions may be grouped
739 * arbitrarily with begin, but it is not allowed to mix definitions and
740 * expressions. The task of the following loop therefore is to split the
741 * list of body forms into the list of definitions and the sequence of
743 while (!scm_is_null (form_idx
))
745 const SCM form
= SCM_CAR (form_idx
);
746 const SCM new_form
= expand_user_macros (form
, env
);
747 if (is_system_macro_p (scm_sym_define
, new_form
, env
))
749 definitions
= scm_cons (new_form
, definitions
);
750 form_idx
= SCM_CDR (form_idx
);
752 else if (is_system_macro_p (scm_sym_begin
, new_form
, env
))
754 /* We have encountered a group of forms. This has to be either a
755 * (possibly empty) group of (possibly further grouped) definitions,
756 * or a non-empty group of (possibly further grouped)
758 const SCM grouped_forms
= SCM_CDR (new_form
);
759 unsigned int found_definition
= 0;
760 unsigned int found_expression
= 0;
761 SCM grouped_form_idx
= grouped_forms
;
762 while (!found_expression
&& !scm_is_null (grouped_form_idx
))
764 const SCM inner_form
= SCM_CAR (grouped_form_idx
);
765 const SCM new_inner_form
= expand_user_macros (inner_form
, env
);
766 if (is_system_macro_p (scm_sym_define
, new_inner_form
, env
))
768 found_definition
= 1;
769 definitions
= scm_cons (new_inner_form
, definitions
);
770 grouped_form_idx
= SCM_CDR (grouped_form_idx
);
772 else if (is_system_macro_p (scm_sym_begin
, new_inner_form
, env
))
774 const SCM inner_group
= SCM_CDR (new_inner_form
);
776 = scm_append (scm_list_2 (inner_group
,
777 SCM_CDR (grouped_form_idx
)));
781 /* The group marks the start of the expressions of the body.
782 * We have to make sure that within the same group we have
783 * not encountered a definition before. */
784 ASSERT_SYNTAX (!found_definition
, s_mixed_body_forms
, form
);
785 found_expression
= 1;
786 grouped_form_idx
= SCM_EOL
;
790 /* We have finished processing the group. If we have not yet
791 * encountered an expression we continue processing the forms of the
792 * body to collect further definition forms. Otherwise, the group
793 * marks the start of the sequence of expressions of the body. */
794 if (!found_expression
)
796 form_idx
= SCM_CDR (form_idx
);
806 /* We have detected a form which is no definition. This marks the
807 * start of the sequence of expressions of the body. */
813 /* FIXME: forms does not hold information about the file location. */
814 ASSERT_SYNTAX (scm_is_pair (sequence
), s_missing_body_expression
, cdr_forms
);
816 if (!scm_is_null (definitions
))
820 SCM letrec_expression
;
821 SCM new_letrec_expression
;
823 SCM bindings
= SCM_EOL
;
824 for (definition_idx
= definitions
;
825 !scm_is_null (definition_idx
);
826 definition_idx
= SCM_CDR (definition_idx
))
828 const SCM definition
= SCM_CAR (definition_idx
);
829 const SCM canonical_definition
= canonicalize_define (definition
);
830 const SCM binding
= SCM_CDR (canonical_definition
);
831 bindings
= scm_cons (binding
, bindings
);
834 letrec_tail
= scm_cons (bindings
, sequence
);
835 /* FIXME: forms does not hold information about the file location. */
836 letrec_expression
= scm_cons_source (forms
, scm_sym_letrec
, letrec_tail
);
837 new_letrec_expression
= scm_m_letrec (letrec_expression
, env
);
838 SCM_SETCAR (forms
, new_letrec_expression
);
839 SCM_SETCDR (forms
, SCM_EOL
);
843 SCM_SETCAR (forms
, SCM_CAR (sequence
));
844 SCM_SETCDR (forms
, SCM_CDR (sequence
));
849 macroexp (SCM x
, SCM env
)
851 SCM res
, proc
, orig_sym
;
853 /* Don't bother to produce error messages here. We get them when we
854 eventually execute the code for real. */
857 orig_sym
= SCM_CAR (x
);
858 if (!scm_is_symbol (orig_sym
))
862 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
863 if (proc_ptr
== NULL
)
865 /* We have lost the race. */
871 /* Only handle memoizing macros. `Acros' and `macros' are really
872 special forms and should not be evaluated here. */
874 if (!SCM_MACROP (proc
)
875 || (SCM_MACRO_TYPE (proc
) != 2 && !SCM_BUILTIN_MACRO_P (proc
)))
878 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
879 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
881 if (scm_ilength (res
) <= 0)
882 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
885 SCM_SETCAR (x
, SCM_CAR (res
));
886 SCM_SETCDR (x
, SCM_CDR (res
));
892 /* Start of the memoizers for the standard R5RS builtin macros. */
895 SCM_SYNTAX (s_and
, "and", scm_i_makbimacro
, scm_m_and
);
896 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
899 scm_m_and (SCM expr
, SCM env SCM_UNUSED
)
901 const SCM cdr_expr
= SCM_CDR (expr
);
902 const long length
= scm_ilength (cdr_expr
);
904 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
908 /* Special case: (and) is replaced by #t. */
913 SCM_SETCAR (expr
, SCM_IM_AND
);
919 unmemoize_and (const SCM expr
, const SCM env
)
921 return scm_cons (scm_sym_and
, unmemoize_exprs (SCM_CDR (expr
), env
));
925 SCM_SYNTAX (s_begin
, "begin", scm_i_makbimacro
, scm_m_begin
);
926 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
929 scm_m_begin (SCM expr
, SCM env SCM_UNUSED
)
931 const SCM cdr_expr
= SCM_CDR (expr
);
932 /* Dirk:FIXME:: An empty begin clause is not generally allowed by R5RS.
933 * That means, there should be a distinction between uses of begin where an
934 * empty clause is OK and where it is not. */
935 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
937 SCM_SETCAR (expr
, SCM_IM_BEGIN
);
942 unmemoize_begin (const SCM expr
, const SCM env
)
944 return scm_cons (scm_sym_begin
, unmemoize_exprs (SCM_CDR (expr
), env
));
948 SCM_SYNTAX (s_case
, "case", scm_i_makbimacro
, scm_m_case
);
949 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
950 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
953 scm_m_case (SCM expr
, SCM env
)
956 SCM all_labels
= SCM_EOL
;
958 /* Check, whether 'else is a literal, i. e. not bound to a value. */
959 const int else_literal_p
= literal_p (scm_sym_else
, env
);
961 const SCM cdr_expr
= SCM_CDR (expr
);
962 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
963 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_clauses
, expr
);
965 clauses
= SCM_CDR (cdr_expr
);
966 while (!scm_is_null (clauses
))
970 const SCM clause
= SCM_CAR (clauses
);
971 ASSERT_SYNTAX_2 (scm_ilength (clause
) >= 2,
972 s_bad_case_clause
, clause
, expr
);
974 labels
= SCM_CAR (clause
);
975 if (scm_is_pair (labels
))
977 ASSERT_SYNTAX_2 (scm_ilength (labels
) >= 0,
978 s_bad_case_labels
, labels
, expr
);
979 all_labels
= scm_append (scm_list_2 (labels
, all_labels
));
981 else if (scm_is_null (labels
))
983 /* The list of labels is empty. According to R5RS this is allowed.
984 * It means that the sequence of expressions will never be executed.
985 * Therefore, as an optimization, we could remove the whole
990 ASSERT_SYNTAX_2 (scm_is_eq (labels
, scm_sym_else
) && else_literal_p
,
991 s_bad_case_labels
, labels
, expr
);
992 ASSERT_SYNTAX_2 (scm_is_null (SCM_CDR (clauses
)),
993 s_misplaced_else_clause
, clause
, expr
);
996 /* build the new clause */
997 if (scm_is_eq (labels
, scm_sym_else
))
998 SCM_SETCAR (clause
, SCM_IM_ELSE
);
1000 clauses
= SCM_CDR (clauses
);
1003 /* Check whether all case labels are distinct. */
1004 for (; !scm_is_null (all_labels
); all_labels
= SCM_CDR (all_labels
))
1006 const SCM label
= SCM_CAR (all_labels
);
1007 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (label
, SCM_CDR (all_labels
))),
1008 s_duplicate_case_label
, label
, expr
);
1011 SCM_SETCAR (expr
, SCM_IM_CASE
);
1016 unmemoize_case (const SCM expr
, const SCM env
)
1018 const SCM um_key_expr
= unmemoize_expression (SCM_CADR (expr
), env
);
1019 SCM um_clauses
= SCM_EOL
;
1022 for (clause_idx
= SCM_CDDR (expr
);
1023 !scm_is_null (clause_idx
);
1024 clause_idx
= SCM_CDR (clause_idx
))
1026 const SCM clause
= SCM_CAR (clause_idx
);
1027 const SCM labels
= SCM_CAR (clause
);
1028 const SCM exprs
= SCM_CDR (clause
);
1030 const SCM um_exprs
= unmemoize_exprs (exprs
, env
);
1031 const SCM um_labels
= (scm_is_eq (labels
, SCM_IM_ELSE
))
1033 : scm_i_finite_list_copy (labels
);
1034 const SCM um_clause
= scm_cons (um_labels
, um_exprs
);
1036 um_clauses
= scm_cons (um_clause
, um_clauses
);
1038 um_clauses
= scm_reverse_x (um_clauses
, SCM_UNDEFINED
);
1040 return scm_cons2 (scm_sym_case
, um_key_expr
, um_clauses
);
1044 SCM_SYNTAX (s_cond
, "cond", scm_i_makbimacro
, scm_m_cond
);
1045 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
1046 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
1049 scm_m_cond (SCM expr
, SCM env
)
1051 /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
1052 const int else_literal_p
= literal_p (scm_sym_else
, env
);
1053 const int arrow_literal_p
= literal_p (scm_sym_arrow
, env
);
1055 const SCM clauses
= SCM_CDR (expr
);
1058 ASSERT_SYNTAX (scm_ilength (clauses
) >= 0, s_bad_expression
, expr
);
1059 ASSERT_SYNTAX (scm_ilength (clauses
) >= 1, s_missing_clauses
, expr
);
1061 for (clause_idx
= clauses
;
1062 !scm_is_null (clause_idx
);
1063 clause_idx
= SCM_CDR (clause_idx
))
1067 const SCM clause
= SCM_CAR (clause_idx
);
1068 const long length
= scm_ilength (clause
);
1069 ASSERT_SYNTAX_2 (length
>= 1, s_bad_cond_clause
, clause
, expr
);
1071 test
= SCM_CAR (clause
);
1072 if (scm_is_eq (test
, scm_sym_else
) && else_literal_p
)
1074 const int last_clause_p
= scm_is_null (SCM_CDR (clause_idx
));
1075 ASSERT_SYNTAX_2 (length
>= 2,
1076 s_bad_cond_clause
, clause
, expr
);
1077 ASSERT_SYNTAX_2 (last_clause_p
,
1078 s_misplaced_else_clause
, clause
, expr
);
1079 SCM_SETCAR (clause
, SCM_IM_ELSE
);
1081 else if (length
>= 2
1082 && scm_is_eq (SCM_CADR (clause
), scm_sym_arrow
)
1085 ASSERT_SYNTAX_2 (length
> 2, s_missing_recipient
, clause
, expr
);
1086 ASSERT_SYNTAX_2 (length
== 3, s_extra_expression
, clause
, expr
);
1087 SCM_SETCAR (SCM_CDR (clause
), SCM_IM_ARROW
);
1091 SCM_SETCAR (expr
, SCM_IM_COND
);
1096 unmemoize_cond (const SCM expr
, const SCM env
)
1098 SCM um_clauses
= SCM_EOL
;
1101 for (clause_idx
= SCM_CDR (expr
);
1102 !scm_is_null (clause_idx
);
1103 clause_idx
= SCM_CDR (clause_idx
))
1105 const SCM clause
= SCM_CAR (clause_idx
);
1106 const SCM sequence
= SCM_CDR (clause
);
1107 const SCM test
= SCM_CAR (clause
);
1112 if (scm_is_eq (test
, SCM_IM_ELSE
))
1113 um_test
= scm_sym_else
;
1115 um_test
= unmemoize_expression (test
, env
);
1117 if (!scm_is_null (sequence
) && scm_is_eq (SCM_CAR (sequence
),
1120 const SCM target
= SCM_CADR (sequence
);
1121 const SCM um_target
= unmemoize_expression (target
, env
);
1122 um_sequence
= scm_list_2 (scm_sym_arrow
, um_target
);
1126 um_sequence
= unmemoize_exprs (sequence
, env
);
1129 um_clause
= scm_cons (um_test
, um_sequence
);
1130 um_clauses
= scm_cons (um_clause
, um_clauses
);
1132 um_clauses
= scm_reverse_x (um_clauses
, SCM_UNDEFINED
);
1134 return scm_cons (scm_sym_cond
, um_clauses
);
1138 SCM_SYNTAX (s_define
, "define", scm_i_makbimacro
, scm_m_define
);
1139 SCM_GLOBAL_SYMBOL (scm_sym_define
, s_define
);
1141 /* Guile provides an extension to R5RS' define syntax to represent function
1142 * currying in a compact way. With this extension, it is allowed to write
1143 * (define <nested-variable> <body>), where <nested-variable> has of one of
1144 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
1145 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
1146 * should be either a sequence of zero or more variables, or a sequence of one
1147 * or more variables followed by a space-delimited period and another
1148 * variable. Each level of argument nesting wraps the <body> within another
1149 * lambda expression. For example, the following forms are allowed, each one
1150 * followed by an equivalent, more explicit implementation.
1152 * (define ((a b . c) . d) <body>) is equivalent to
1153 * (define a (lambda (b . c) (lambda d <body>)))
1155 * (define (((a) b) c . d) <body>) is equivalent to
1156 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
1158 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
1159 * module that does not implement this extension. */
1161 canonicalize_define (const SCM expr
)
1166 const SCM cdr_expr
= SCM_CDR (expr
);
1167 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1168 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1170 body
= SCM_CDR (cdr_expr
);
1171 variable
= SCM_CAR (cdr_expr
);
1172 while (scm_is_pair (variable
))
1174 /* This while loop realizes function currying by variable nesting.
1175 * Variable is known to be a nested-variable. In every iteration of the
1176 * loop another level of lambda expression is created, starting with the
1177 * innermost one. Note that we don't check for duplicate formals here:
1178 * This will be done by the memoizer of the lambda expression. */
1179 const SCM formals
= SCM_CDR (variable
);
1180 const SCM tail
= scm_cons (formals
, body
);
1182 /* Add source properties to each new lambda expression: */
1183 const SCM lambda
= scm_cons_source (variable
, scm_sym_lambda
, tail
);
1185 body
= scm_list_1 (lambda
);
1186 variable
= SCM_CAR (variable
);
1188 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
1189 ASSERT_SYNTAX (scm_ilength (body
) == 1, s_expression
, expr
);
1191 SCM_SETCAR (cdr_expr
, variable
);
1192 SCM_SETCDR (cdr_expr
, body
);
1196 /* According to section 5.2.1 of R5RS we first have to make sure that the
1197 * variable is bound, and then perform the (set! variable expression)
1198 * operation. This means, that within the expression we may already assign
1199 * values to variable: (define foo (begin (set! foo 1) (+ foo 1))) */
1201 scm_m_define (SCM expr
, SCM env
)
1203 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), s_bad_define
, expr
);
1206 const SCM canonical_definition
= canonicalize_define (expr
);
1207 const SCM cdr_canonical_definition
= SCM_CDR (canonical_definition
);
1208 const SCM variable
= SCM_CAR (cdr_canonical_definition
);
1210 = scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_T
);
1211 const SCM value
= scm_eval_car (SCM_CDR (cdr_canonical_definition
), env
);
1213 if (SCM_REC_PROCNAMES_P
)
1216 while (SCM_MACROP (tmp
))
1217 tmp
= SCM_MACRO_CODE (tmp
);
1218 if (SCM_CLOSUREP (tmp
)
1219 /* Only the first definition determines the name. */
1220 && scm_is_false (scm_procedure_property (tmp
, scm_sym_name
)))
1221 scm_set_procedure_property_x (tmp
, scm_sym_name
, variable
);
1224 SCM_VARIABLE_SET (location
, value
);
1226 return SCM_UNSPECIFIED
;
1231 /* This is a helper function for forms (<keyword> <expression>) that are
1232 * transformed into (#@<keyword> '() <memoized_expression>) in order to allow
1233 * for easy creation of a thunk (i. e. a closure without arguments) using the
1234 * ('() <memoized_expression>) tail of the memoized form. */
1236 memoize_as_thunk_prototype (const SCM expr
, const SCM env SCM_UNUSED
)
1238 const SCM cdr_expr
= SCM_CDR (expr
);
1239 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1240 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1242 SCM_SETCDR (expr
, scm_cons (SCM_EOL
, cdr_expr
));
1248 SCM_SYNTAX (s_delay
, "delay", scm_i_makbimacro
, scm_m_delay
);
1249 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
1251 /* Promises are implemented as closures with an empty parameter list. Thus,
1252 * (delay <expression>) is transformed into (#@delay '() <expression>), where
1253 * the empty list represents the empty parameter list. This representation
1254 * allows for easy creation of the closure during evaluation. */
1256 scm_m_delay (SCM expr
, SCM env
)
1258 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1259 SCM_SETCAR (new_expr
, SCM_IM_DELAY
);
1264 unmemoize_delay (const SCM expr
, const SCM env
)
1266 const SCM thunk_expr
= SCM_CADDR (expr
);
1267 return scm_list_2 (scm_sym_delay
, unmemoize_expression (thunk_expr
, env
));
1271 SCM_SYNTAX(s_do
, "do", scm_i_makbimacro
, scm_m_do
);
1272 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
1274 /* DO gets the most radically altered syntax. The order of the vars is
1275 * reversed here. During the evaluation this allows for simple consing of the
1276 * results of the inits and steps:
1278 (do ((<var1> <init1> <step1>)
1286 (#@do (<init1> <init2> ... <initn>)
1287 (varn ... var2 var1)
1290 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
1293 scm_m_do (SCM expr
, SCM env SCM_UNUSED
)
1295 SCM variables
= SCM_EOL
;
1296 SCM init_forms
= SCM_EOL
;
1297 SCM step_forms
= SCM_EOL
;
1304 const SCM cdr_expr
= SCM_CDR (expr
);
1305 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1306 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1308 /* Collect variables, init and step forms. */
1309 binding_idx
= SCM_CAR (cdr_expr
);
1310 ASSERT_SYNTAX_2 (scm_ilength (binding_idx
) >= 0,
1311 s_bad_bindings
, binding_idx
, expr
);
1312 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1314 const SCM binding
= SCM_CAR (binding_idx
);
1315 const long length
= scm_ilength (binding
);
1316 ASSERT_SYNTAX_2 (length
== 2 || length
== 3,
1317 s_bad_binding
, binding
, expr
);
1320 const SCM name
= SCM_CAR (binding
);
1321 const SCM init
= SCM_CADR (binding
);
1322 const SCM step
= (length
== 2) ? name
: SCM_CADDR (binding
);
1323 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
1324 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, variables
)),
1325 s_duplicate_binding
, name
, expr
);
1327 variables
= scm_cons (name
, variables
);
1328 init_forms
= scm_cons (init
, init_forms
);
1329 step_forms
= scm_cons (step
, step_forms
);
1332 init_forms
= scm_reverse_x (init_forms
, SCM_UNDEFINED
);
1333 step_forms
= scm_reverse_x (step_forms
, SCM_UNDEFINED
);
1335 /* Memoize the test form and the exit sequence. */
1336 cddr_expr
= SCM_CDR (cdr_expr
);
1337 exit_clause
= SCM_CAR (cddr_expr
);
1338 ASSERT_SYNTAX_2 (scm_ilength (exit_clause
) >= 1,
1339 s_bad_exit_clause
, exit_clause
, expr
);
1341 commands
= SCM_CDR (cddr_expr
);
1342 tail
= scm_cons2 (exit_clause
, commands
, step_forms
);
1343 tail
= scm_cons2 (init_forms
, variables
, tail
);
1344 SCM_SETCAR (expr
, SCM_IM_DO
);
1345 SCM_SETCDR (expr
, tail
);
1350 unmemoize_do (const SCM expr
, const SCM env
)
1352 const SCM cdr_expr
= SCM_CDR (expr
);
1353 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1354 const SCM rnames
= SCM_CAR (cddr_expr
);
1355 const SCM extended_env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
1356 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
1357 const SCM exit_sequence
= SCM_CAR (cdddr_expr
);
1358 const SCM um_exit_sequence
= unmemoize_exprs (exit_sequence
, extended_env
);
1359 const SCM cddddr_expr
= SCM_CDR (cdddr_expr
);
1360 const SCM um_body
= unmemoize_exprs (SCM_CAR (cddddr_expr
), extended_env
);
1362 /* build transformed binding list */
1363 SCM um_names
= scm_reverse (rnames
);
1364 SCM um_inits
= unmemoize_exprs (SCM_CAR (cdr_expr
), env
);
1365 SCM um_steps
= unmemoize_exprs (SCM_CDR (cddddr_expr
), extended_env
);
1366 SCM um_bindings
= SCM_EOL
;
1367 while (!scm_is_null (um_names
))
1369 const SCM name
= SCM_CAR (um_names
);
1370 const SCM init
= SCM_CAR (um_inits
);
1371 SCM step
= SCM_CAR (um_steps
);
1372 step
= scm_is_eq (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
1374 um_bindings
= scm_cons (scm_cons2 (name
, init
, step
), um_bindings
);
1376 um_names
= SCM_CDR (um_names
);
1377 um_inits
= SCM_CDR (um_inits
);
1378 um_steps
= SCM_CDR (um_steps
);
1380 um_bindings
= scm_reverse_x (um_bindings
, SCM_UNDEFINED
);
1382 return scm_cons (scm_sym_do
,
1383 scm_cons2 (um_bindings
, um_exit_sequence
, um_body
));
1387 SCM_SYNTAX (s_if
, "if", scm_i_makbimacro
, scm_m_if
);
1388 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
1391 scm_m_if (SCM expr
, SCM env SCM_UNUSED
)
1393 const SCM cdr_expr
= SCM_CDR (expr
);
1394 const long length
= scm_ilength (cdr_expr
);
1395 ASSERT_SYNTAX (length
== 2 || length
== 3, s_expression
, expr
);
1396 SCM_SETCAR (expr
, SCM_IM_IF
);
1401 unmemoize_if (const SCM expr
, const SCM env
)
1403 const SCM cdr_expr
= SCM_CDR (expr
);
1404 const SCM um_condition
= unmemoize_expression (SCM_CAR (cdr_expr
), env
);
1405 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1406 const SCM um_then
= unmemoize_expression (SCM_CAR (cddr_expr
), env
);
1407 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
1409 if (scm_is_null (cdddr_expr
))
1411 return scm_list_3 (scm_sym_if
, um_condition
, um_then
);
1415 const SCM um_else
= unmemoize_expression (SCM_CAR (cdddr_expr
), env
);
1416 return scm_list_4 (scm_sym_if
, um_condition
, um_then
, um_else
);
1421 SCM_SYNTAX (s_lambda
, "lambda", scm_i_makbimacro
, scm_m_lambda
);
1422 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
1424 /* A helper function for memoize_lambda to support checking for duplicate
1425 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
1426 * LIST or to the cdr of the last cons. Therefore, LIST may have any of the
1427 * forms that a formal argument can have:
1428 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
1430 c_improper_memq (SCM obj
, SCM list
)
1432 for (; scm_is_pair (list
); list
= SCM_CDR (list
))
1434 if (scm_is_eq (SCM_CAR (list
), obj
))
1437 return scm_is_eq (list
, obj
);
1441 scm_m_lambda (SCM expr
, SCM env SCM_UNUSED
)
1450 const SCM cdr_expr
= SCM_CDR (expr
);
1451 const long length
= scm_ilength (cdr_expr
);
1452 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1453 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1455 /* Before iterating the list of formal arguments, make sure the formals
1456 * actually are given as either a symbol or a non-cyclic list. */
1457 formals
= SCM_CAR (cdr_expr
);
1458 if (scm_is_pair (formals
))
1460 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
1461 * detected, report a 'Bad formals' error. */
1465 ASSERT_SYNTAX_2 (scm_is_symbol (formals
) || scm_is_null (formals
),
1466 s_bad_formals
, formals
, expr
);
1469 /* Now iterate the list of formal arguments to check if all formals are
1470 * symbols, and that there are no duplicates. */
1471 formals_idx
= formals
;
1472 while (scm_is_pair (formals_idx
))
1474 const SCM formal
= SCM_CAR (formals_idx
);
1475 const SCM next_idx
= SCM_CDR (formals_idx
);
1476 ASSERT_SYNTAX_2 (scm_is_symbol (formal
), s_bad_formal
, formal
, expr
);
1477 ASSERT_SYNTAX_2 (!c_improper_memq (formal
, next_idx
),
1478 s_duplicate_formal
, formal
, expr
);
1479 formals_idx
= next_idx
;
1481 ASSERT_SYNTAX_2 (scm_is_null (formals_idx
) || scm_is_symbol (formals_idx
),
1482 s_bad_formal
, formals_idx
, expr
);
1484 /* Memoize the body. Keep a potential documentation string. */
1485 /* Dirk:FIXME:: We should probably extract the documentation string to
1486 * some external database. Otherwise it will slow down execution, since
1487 * the documentation string will have to be skipped with every execution
1488 * of the closure. */
1489 cddr_expr
= SCM_CDR (cdr_expr
);
1490 documentation
= (length
>= 3 && scm_is_string (SCM_CAR (cddr_expr
)));
1491 body
= documentation
? SCM_CDR (cddr_expr
) : cddr_expr
;
1492 new_body
= m_body (SCM_IM_LAMBDA
, body
);
1494 SCM_SETCAR (expr
, SCM_IM_LAMBDA
);
1496 SCM_SETCDR (cddr_expr
, new_body
);
1498 SCM_SETCDR (cdr_expr
, new_body
);
1503 unmemoize_lambda (const SCM expr
, const SCM env
)
1505 const SCM formals
= SCM_CADR (expr
);
1506 const SCM body
= SCM_CDDR (expr
);
1508 const SCM new_env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, env
);
1509 const SCM um_formals
= scm_i_finite_list_copy (formals
);
1510 const SCM um_body
= unmemoize_exprs (body
, new_env
);
1512 return scm_cons2 (scm_sym_lambda
, um_formals
, um_body
);
1516 /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
1518 check_bindings (const SCM bindings
, const SCM expr
)
1522 ASSERT_SYNTAX_2 (scm_ilength (bindings
) >= 0,
1523 s_bad_bindings
, bindings
, expr
);
1525 binding_idx
= bindings
;
1526 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1528 SCM name
; /* const */
1530 const SCM binding
= SCM_CAR (binding_idx
);
1531 ASSERT_SYNTAX_2 (scm_ilength (binding
) == 2,
1532 s_bad_binding
, binding
, expr
);
1534 name
= SCM_CAR (binding
);
1535 ASSERT_SYNTAX_2 (scm_is_symbol (name
), s_bad_variable
, name
, expr
);
1540 /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
1541 * transformed to the lists (vn ... v2 v1) and (i1 i2 ... in). That is, the
1542 * variables are returned in a list with their order reversed, and the init
1543 * forms are returned in a list in the same order as they are given in the
1544 * bindings. If a duplicate variable name is detected, an error is
1547 transform_bindings (
1548 const SCM bindings
, const SCM expr
,
1549 SCM
*const rvarptr
, SCM
*const initptr
)
1551 SCM rvariables
= SCM_EOL
;
1552 SCM rinits
= SCM_EOL
;
1553 SCM binding_idx
= bindings
;
1554 for (; !scm_is_null (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1556 const SCM binding
= SCM_CAR (binding_idx
);
1557 const SCM cdr_binding
= SCM_CDR (binding
);
1558 const SCM name
= SCM_CAR (binding
);
1559 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name
, rvariables
)),
1560 s_duplicate_binding
, name
, expr
);
1561 rvariables
= scm_cons (name
, rvariables
);
1562 rinits
= scm_cons (SCM_CAR (cdr_binding
), rinits
);
1564 *rvarptr
= rvariables
;
1565 *initptr
= scm_reverse_x (rinits
, SCM_UNDEFINED
);
1569 SCM_SYNTAX(s_let
, "let", scm_i_makbimacro
, scm_m_let
);
1570 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
1572 /* This function is a helper function for memoize_let. It transforms
1573 * (let name ((var init) ...) body ...) into
1574 * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
1575 * and memoizes the expression. It is assumed that the caller has checked
1576 * that name is a symbol and that there are bindings and a body. */
1578 memoize_named_let (const SCM expr
, const SCM env SCM_UNUSED
)
1584 const SCM cdr_expr
= SCM_CDR (expr
);
1585 const SCM name
= SCM_CAR (cdr_expr
);
1586 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1587 const SCM bindings
= SCM_CAR (cddr_expr
);
1588 check_bindings (bindings
, expr
);
1590 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1591 variables
= scm_reverse_x (rvariables
, SCM_UNDEFINED
);
1594 const SCM let_body
= SCM_CDR (cddr_expr
);
1595 const SCM lambda_body
= m_body (SCM_IM_LET
, let_body
);
1596 const SCM lambda_tail
= scm_cons (variables
, lambda_body
);
1597 const SCM lambda_form
= scm_cons_source (expr
, scm_sym_lambda
, lambda_tail
);
1599 const SCM rvar
= scm_list_1 (name
);
1600 const SCM init
= scm_list_1 (lambda_form
);
1601 const SCM body
= m_body (SCM_IM_LET
, scm_list_1 (name
));
1602 const SCM letrec_tail
= scm_cons (rvar
, scm_cons (init
, body
));
1603 const SCM letrec_form
= scm_cons_source (expr
, SCM_IM_LETREC
, letrec_tail
);
1604 return scm_cons_source (expr
, letrec_form
, inits
);
1608 /* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1609 * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
1611 scm_m_let (SCM expr
, SCM env
)
1615 const SCM cdr_expr
= SCM_CDR (expr
);
1616 const long length
= scm_ilength (cdr_expr
);
1617 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1618 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1620 bindings
= SCM_CAR (cdr_expr
);
1621 if (scm_is_symbol (bindings
))
1623 ASSERT_SYNTAX (length
>= 3, s_missing_expression
, expr
);
1624 return memoize_named_let (expr
, env
);
1627 check_bindings (bindings
, expr
);
1628 if (scm_is_null (bindings
) || scm_is_null (SCM_CDR (bindings
)))
1630 /* Special case: no bindings or single binding => let* is faster. */
1631 const SCM body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1632 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), bindings
, body
), env
);
1639 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1642 const SCM new_body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1643 const SCM new_tail
= scm_cons2 (rvariables
, inits
, new_body
);
1644 SCM_SETCAR (expr
, SCM_IM_LET
);
1645 SCM_SETCDR (expr
, new_tail
);
1652 build_binding_list (SCM rnames
, SCM rinits
)
1654 SCM bindings
= SCM_EOL
;
1655 while (!scm_is_null (rnames
))
1657 const SCM binding
= scm_list_2 (SCM_CAR (rnames
), SCM_CAR (rinits
));
1658 bindings
= scm_cons (binding
, bindings
);
1659 rnames
= SCM_CDR (rnames
);
1660 rinits
= SCM_CDR (rinits
);
1666 unmemoize_let (const SCM expr
, const SCM env
)
1668 const SCM cdr_expr
= SCM_CDR (expr
);
1669 const SCM um_rnames
= SCM_CAR (cdr_expr
);
1670 const SCM extended_env
= SCM_EXTEND_ENV (um_rnames
, SCM_EOL
, env
);
1671 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1672 const SCM um_inits
= unmemoize_exprs (SCM_CAR (cddr_expr
), env
);
1673 const SCM um_rinits
= scm_reverse_x (um_inits
, SCM_UNDEFINED
);
1674 const SCM um_bindings
= build_binding_list (um_rnames
, um_rinits
);
1675 const SCM um_body
= unmemoize_exprs (SCM_CDR (cddr_expr
), extended_env
);
1677 return scm_cons2 (scm_sym_let
, um_bindings
, um_body
);
1681 SCM_SYNTAX(s_letrec
, "letrec", scm_i_makbimacro
, scm_m_letrec
);
1682 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
1685 scm_m_letrec (SCM expr
, SCM env
)
1689 const SCM cdr_expr
= SCM_CDR (expr
);
1690 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1691 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1693 bindings
= SCM_CAR (cdr_expr
);
1694 if (scm_is_null (bindings
))
1696 /* no bindings, let* is executed faster */
1697 SCM body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1698 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), SCM_EOL
, body
), env
);
1706 check_bindings (bindings
, expr
);
1707 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1708 new_body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1709 return scm_cons2 (SCM_IM_LETREC
, rvariables
, scm_cons (inits
, new_body
));
1714 unmemoize_letrec (const SCM expr
, const SCM env
)
1716 const SCM cdr_expr
= SCM_CDR (expr
);
1717 const SCM um_rnames
= SCM_CAR (cdr_expr
);
1718 const SCM extended_env
= SCM_EXTEND_ENV (um_rnames
, SCM_EOL
, env
);
1719 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1720 const SCM um_inits
= unmemoize_exprs (SCM_CAR (cddr_expr
), extended_env
);
1721 const SCM um_rinits
= scm_reverse_x (um_inits
, SCM_UNDEFINED
);
1722 const SCM um_bindings
= build_binding_list (um_rnames
, um_rinits
);
1723 const SCM um_body
= unmemoize_exprs (SCM_CDR (cddr_expr
), extended_env
);
1725 return scm_cons2 (scm_sym_letrec
, um_bindings
, um_body
);
1730 SCM_SYNTAX (s_letstar
, "let*", scm_i_makbimacro
, scm_m_letstar
);
1731 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
1733 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1734 * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
1736 scm_m_letstar (SCM expr
, SCM env SCM_UNUSED
)
1741 const SCM cdr_expr
= SCM_CDR (expr
);
1742 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1743 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1745 binding_idx
= SCM_CAR (cdr_expr
);
1746 check_bindings (binding_idx
, expr
);
1748 /* Transform ((v1 i1) (v2 i2) ...) into (v1 i1 v2 i2 ...). The
1749 * transformation is done in place. At the beginning of one iteration of
1750 * the loop the variable binding_idx holds the form
1751 * P1:( (vn . P2:(in . ())) . P3:( (vn+1 in+1) ... ) ),
1752 * where P1, P2 and P3 indicate the pairs, that are relevant for the
1753 * transformation. P1 and P2 are modified in the loop, P3 remains
1754 * untouched. After the execution of the loop, P1 will hold
1755 * P1:( vn . P2:(in . P3:( (vn+1 in+1) ... )) )
1756 * and binding_idx will hold P3. */
1757 while (!scm_is_null (binding_idx
))
1759 const SCM cdr_binding_idx
= SCM_CDR (binding_idx
); /* remember P3 */
1760 const SCM binding
= SCM_CAR (binding_idx
);
1761 const SCM name
= SCM_CAR (binding
);
1762 const SCM cdr_binding
= SCM_CDR (binding
);
1764 SCM_SETCDR (cdr_binding
, cdr_binding_idx
); /* update P2 */
1765 SCM_SETCAR (binding_idx
, name
); /* update P1 */
1766 SCM_SETCDR (binding_idx
, cdr_binding
); /* update P1 */
1768 binding_idx
= cdr_binding_idx
; /* continue with P3 */
1771 new_body
= m_body (SCM_IM_LETSTAR
, SCM_CDR (cdr_expr
));
1772 SCM_SETCAR (expr
, SCM_IM_LETSTAR
);
1773 /* the bindings have been changed in place */
1774 SCM_SETCDR (cdr_expr
, new_body
);
1779 unmemoize_letstar (const SCM expr
, const SCM env
)
1781 const SCM cdr_expr
= SCM_CDR (expr
);
1782 const SCM body
= SCM_CDR (cdr_expr
);
1783 SCM bindings
= SCM_CAR (cdr_expr
);
1784 SCM um_bindings
= SCM_EOL
;
1785 SCM extended_env
= env
;
1788 while (!scm_is_null (bindings
))
1790 const SCM variable
= SCM_CAR (bindings
);
1791 const SCM init
= SCM_CADR (bindings
);
1792 const SCM um_init
= unmemoize_expression (init
, extended_env
);
1793 um_bindings
= scm_cons (scm_list_2 (variable
, um_init
), um_bindings
);
1794 extended_env
= SCM_EXTEND_ENV (variable
, SCM_BOOL_F
, extended_env
);
1795 bindings
= SCM_CDDR (bindings
);
1797 um_bindings
= scm_reverse_x (um_bindings
, SCM_UNDEFINED
);
1799 um_body
= unmemoize_exprs (body
, extended_env
);
1801 return scm_cons2 (scm_sym_letstar
, um_bindings
, um_body
);
1805 SCM_SYNTAX (s_or
, "or", scm_i_makbimacro
, scm_m_or
);
1806 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
1809 scm_m_or (SCM expr
, SCM env SCM_UNUSED
)
1811 const SCM cdr_expr
= SCM_CDR (expr
);
1812 const long length
= scm_ilength (cdr_expr
);
1814 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1818 /* Special case: (or) is replaced by #f. */
1823 SCM_SETCAR (expr
, SCM_IM_OR
);
1829 unmemoize_or (const SCM expr
, const SCM env
)
1831 return scm_cons (scm_sym_or
, unmemoize_exprs (SCM_CDR (expr
), env
));
1835 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
1836 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
1837 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
1838 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
1840 /* Internal function to handle a quasiquotation: 'form' is the parameter in
1841 * the call (quasiquotation form), 'env' is the environment where unquoted
1842 * expressions will be evaluated, and 'depth' is the current quasiquotation
1843 * nesting level and is known to be greater than zero. */
1845 iqq (SCM form
, SCM env
, unsigned long int depth
)
1847 if (scm_is_pair (form
))
1849 const SCM tmp
= SCM_CAR (form
);
1850 if (scm_is_eq (tmp
, scm_sym_quasiquote
))
1852 const SCM args
= SCM_CDR (form
);
1853 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1854 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
1856 else if (scm_is_eq (tmp
, scm_sym_unquote
))
1858 const SCM args
= SCM_CDR (form
);
1859 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1861 return scm_eval_car (args
, env
);
1863 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
1865 else if (scm_is_pair (tmp
)
1866 && scm_is_eq (SCM_CAR (tmp
), scm_sym_uq_splicing
))
1868 const SCM args
= SCM_CDR (tmp
);
1869 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1872 const SCM list
= scm_eval_car (args
, env
);
1873 const SCM rest
= SCM_CDR (form
);
1874 ASSERT_SYNTAX_2 (scm_ilength (list
) >= 0,
1875 s_splicing
, list
, form
);
1876 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
1879 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
1880 iqq (SCM_CDR (form
), env
, depth
));
1883 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
1884 iqq (SCM_CDR (form
), env
, depth
));
1886 else if (scm_is_vector (form
))
1887 return scm_vector (iqq (scm_vector_to_list (form
), env
, depth
));
1893 scm_m_quasiquote (SCM expr
, SCM env
)
1895 const SCM cdr_expr
= SCM_CDR (expr
);
1896 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1897 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1898 return iqq (SCM_CAR (cdr_expr
), env
, 1);
1902 SCM_SYNTAX (s_quote
, "quote", scm_i_makbimacro
, scm_m_quote
);
1903 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
1906 scm_m_quote (SCM expr
, SCM env SCM_UNUSED
)
1910 const SCM cdr_expr
= SCM_CDR (expr
);
1911 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1912 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1913 quotee
= SCM_CAR (cdr_expr
);
1914 if (is_self_quoting_p (quotee
))
1917 SCM_SETCAR (expr
, SCM_IM_QUOTE
);
1918 SCM_SETCDR (expr
, quotee
);
1923 unmemoize_quote (const SCM expr
, const SCM env SCM_UNUSED
)
1925 return scm_list_2 (scm_sym_quote
, SCM_CDR (expr
));
1929 /* Will go into the RnRS module when Guile is factorized.
1930 SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
1931 static const char s_set_x
[] = "set!";
1932 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, s_set_x
);
1935 scm_m_set_x (SCM expr
, SCM env SCM_UNUSED
)
1940 const SCM cdr_expr
= SCM_CDR (expr
);
1941 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1942 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1943 variable
= SCM_CAR (cdr_expr
);
1945 /* Memoize the variable form. */
1946 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
1947 new_variable
= lookup_symbol (variable
, env
);
1948 /* Leave the memoization of unbound symbols to lazy memoization: */
1949 if (SCM_UNBNDP (new_variable
))
1950 new_variable
= variable
;
1952 SCM_SETCAR (expr
, SCM_IM_SET_X
);
1953 SCM_SETCAR (cdr_expr
, new_variable
);
1958 unmemoize_set_x (const SCM expr
, const SCM env
)
1960 return scm_cons (scm_sym_set_x
, unmemoize_exprs (SCM_CDR (expr
), env
));
1964 /* Start of the memoizers for non-R5RS builtin macros. */
1967 SCM_SYNTAX (s_atapply
, "@apply", scm_i_makbimacro
, scm_m_apply
);
1968 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1969 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1972 scm_m_apply (SCM expr
, SCM env SCM_UNUSED
)
1974 const SCM cdr_expr
= SCM_CDR (expr
);
1975 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1976 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_missing_expression
, expr
);
1978 SCM_SETCAR (expr
, SCM_IM_APPLY
);
1983 unmemoize_apply (const SCM expr
, const SCM env
)
1985 return scm_list_2 (scm_sym_atapply
, unmemoize_exprs (SCM_CDR (expr
), env
));
1989 SCM_SYNTAX (s_atbind
, "@bind", scm_i_makbimacro
, scm_m_atbind
);
1991 /* FIXME: The following explanation should go into the documentation: */
1992 /* (@bind ((var init) ...) body ...) will assign the values of the `init's to
1993 * the global variables named by `var's (symbols, not evaluated), creating
1994 * them if they don't exist, executes body, and then restores the previous
1995 * values of the `var's. Additionally, whenever control leaves body, the
1996 * values of the `var's are saved and restored when control returns. It is an
1997 * error when a symbol appears more than once among the `var's. All `init's
1998 * are evaluated before any `var' is set.
2000 * Think of this as `let' for dynamic scope.
2003 /* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into
2004 * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...).
2006 * FIXME - also implement `@bind*'.
2009 scm_m_atbind (SCM expr
, SCM env
)
2016 const SCM top_level
= scm_env_top_level (env
);
2018 const SCM cdr_expr
= SCM_CDR (expr
);
2019 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2020 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
2021 bindings
= SCM_CAR (cdr_expr
);
2022 check_bindings (bindings
, expr
);
2023 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
2025 for (variable_idx
= rvariables
;
2026 !scm_is_null (variable_idx
);
2027 variable_idx
= SCM_CDR (variable_idx
))
2029 /* The first call to scm_sym2var will look beyond the current module,
2030 * while the second call wont. */
2031 const SCM variable
= SCM_CAR (variable_idx
);
2032 SCM new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_F
);
2033 if (scm_is_false (new_variable
))
2034 new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_T
);
2035 SCM_SETCAR (variable_idx
, new_variable
);
2038 SCM_SETCAR (expr
, SCM_IM_BIND
);
2039 SCM_SETCAR (cdr_expr
, scm_cons (rvariables
, inits
));
2044 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_i_makbimacro
, scm_m_cont
);
2045 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, s_atcall_cc
);
2048 scm_m_cont (SCM expr
, SCM env SCM_UNUSED
)
2050 const SCM cdr_expr
= SCM_CDR (expr
);
2051 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2052 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2054 SCM_SETCAR (expr
, SCM_IM_CONT
);
2059 unmemoize_atcall_cc (const SCM expr
, const SCM env
)
2061 return scm_list_2 (scm_sym_atcall_cc
, unmemoize_exprs (SCM_CDR (expr
), env
));
2065 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_i_makbimacro
, scm_m_at_call_with_values
);
2066 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
2069 scm_m_at_call_with_values (SCM expr
, SCM env SCM_UNUSED
)
2071 const SCM cdr_expr
= SCM_CDR (expr
);
2072 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2073 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2075 SCM_SETCAR (expr
, SCM_IM_CALL_WITH_VALUES
);
2080 unmemoize_at_call_with_values (const SCM expr
, const SCM env
)
2082 return scm_list_2 (scm_sym_at_call_with_values
,
2083 unmemoize_exprs (SCM_CDR (expr
), env
));
2087 SCM_SYNTAX (s_future
, "future", scm_i_makbimacro
, scm_m_future
);
2088 SCM_GLOBAL_SYMBOL (scm_sym_future
, s_future
);
2090 /* Like promises, futures are implemented as closures with an empty
2091 * parameter list. Thus, (future <expression>) is transformed into
2092 * (#@future '() <expression>), where the empty list represents the
2093 * empty parameter list. This representation allows for easy creation
2094 * of the closure during evaluation. */
2096 scm_m_future (SCM expr
, SCM env
)
2098 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
2099 SCM_SETCAR (new_expr
, SCM_IM_FUTURE
);
2104 unmemoize_future (const SCM expr
, const SCM env
)
2106 const SCM thunk_expr
= SCM_CADDR (expr
);
2107 return scm_list_2 (scm_sym_future
, unmemoize_expression (thunk_expr
, env
));
2111 SCM_SYNTAX (s_gset_x
, "set!", scm_i_makbimacro
, scm_m_generalized_set_x
);
2112 SCM_SYMBOL (scm_sym_setter
, "setter");
2115 scm_m_generalized_set_x (SCM expr
, SCM env
)
2117 SCM target
, exp_target
;
2119 const SCM cdr_expr
= SCM_CDR (expr
);
2120 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2121 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2123 target
= SCM_CAR (cdr_expr
);
2124 if (!scm_is_pair (target
))
2127 return scm_m_set_x (expr
, env
);
2131 /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */
2132 /* Macroexpanding the target might return things of the form
2133 (begin <atom>). In that case, <atom> must be a symbol or a
2134 variable and we memoize to (set! <atom> ...).
2136 exp_target
= macroexp (target
, env
);
2137 if (scm_is_eq (SCM_CAR (exp_target
), SCM_IM_BEGIN
)
2138 && !scm_is_null (SCM_CDR (exp_target
))
2139 && scm_is_null (SCM_CDDR (exp_target
)))
2141 exp_target
= SCM_CADR (exp_target
);
2142 ASSERT_SYNTAX_2 (scm_is_symbol (exp_target
)
2143 || SCM_VARIABLEP (exp_target
),
2144 s_bad_variable
, exp_target
, expr
);
2145 return scm_cons (SCM_IM_SET_X
, scm_cons (exp_target
,
2146 SCM_CDR (cdr_expr
)));
2150 const SCM setter_proc_tail
= scm_list_1 (SCM_CAR (target
));
2151 const SCM setter_proc
= scm_cons_source (expr
, scm_sym_setter
,
2154 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
2155 const SCM setter_args
= scm_append_x (scm_list_2 (SCM_CDR (target
),
2158 SCM_SETCAR (expr
, setter_proc
);
2159 SCM_SETCDR (expr
, setter_args
);
2166 /* @slot-ref is bound privately in the (oop goops) module from goops.c. As
2167 * soon as the module system allows us to more freely create bindings in
2168 * arbitrary modules during the startup phase, the code from goops.c should be
2171 SCM_SYMBOL (sym_atslot_ref
, "@slot-ref");
2174 scm_m_atslot_ref (SCM expr
, SCM env SCM_UNUSED
)
2178 const SCM cdr_expr
= SCM_CDR (expr
);
2179 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2180 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
2181 slot_nr
= SCM_CADR (cdr_expr
);
2182 ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2184 SCM_SETCAR (expr
, SCM_IM_SLOT_REF
);
2185 SCM_SETCDR (cdr_expr
, slot_nr
);
2190 unmemoize_atslot_ref (const SCM expr
, const SCM env
)
2192 const SCM instance
= SCM_CADR (expr
);
2193 const SCM um_instance
= unmemoize_expression (instance
, env
);
2194 const SCM slot_nr
= SCM_CDDR (expr
);
2195 return scm_list_3 (sym_atslot_ref
, um_instance
, slot_nr
);
2199 /* @slot-set! is bound privately in the (oop goops) module from goops.c. As
2200 * soon as the module system allows us to more freely create bindings in
2201 * arbitrary modules during the startup phase, the code from goops.c should be
2204 SCM_SYMBOL (sym_atslot_set_x
, "@slot-set!");
2207 scm_m_atslot_set_x (SCM expr
, SCM env SCM_UNUSED
)
2211 const SCM cdr_expr
= SCM_CDR (expr
);
2212 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2213 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 3, s_expression
, expr
);
2214 slot_nr
= SCM_CADR (cdr_expr
);
2215 ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2217 SCM_SETCAR (expr
, SCM_IM_SLOT_SET_X
);
2222 unmemoize_atslot_set_x (const SCM expr
, const SCM env
)
2224 const SCM cdr_expr
= SCM_CDR (expr
);
2225 const SCM instance
= SCM_CAR (cdr_expr
);
2226 const SCM um_instance
= unmemoize_expression (instance
, env
);
2227 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
2228 const SCM slot_nr
= SCM_CAR (cddr_expr
);
2229 const SCM cdddr_expr
= SCM_CDR (cddr_expr
);
2230 const SCM value
= SCM_CAR (cdddr_expr
);
2231 const SCM um_value
= unmemoize_expression (value
, env
);
2232 return scm_list_4 (sym_atslot_set_x
, um_instance
, slot_nr
, um_value
);
2236 #if SCM_ENABLE_ELISP
2238 static const char s_defun
[] = "Symbol's function definition is void";
2240 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_i_makbimacro
, scm_m_nil_cond
);
2242 /* nil-cond expressions have the form
2243 * (nil-cond COND VAL COND VAL ... ELSEVAL) */
2245 scm_m_nil_cond (SCM expr
, SCM env SCM_UNUSED
)
2247 const long length
= scm_ilength (SCM_CDR (expr
));
2248 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
2249 ASSERT_SYNTAX (length
>= 1 && (length
% 2) == 1, s_expression
, expr
);
2251 SCM_SETCAR (expr
, SCM_IM_NIL_COND
);
2256 SCM_SYNTAX (s_atfop
, "@fop", scm_i_makbimacro
, scm_m_atfop
);
2258 /* The @fop-macro handles procedure and macro applications for elisp. The
2259 * input expression must have the form
2260 * (@fop <var> (transformer-macro <expr> ...))
2261 * where <var> must be a symbol. The expression is transformed into the
2262 * memoized form of either
2263 * (apply <un-aliased var> (transformer-macro <expr> ...))
2264 * if the value of var (across all aliasing) is not a macro, or
2265 * (<un-aliased var> <expr> ...)
2266 * if var is a macro. */
2268 scm_m_atfop (SCM expr
, SCM env SCM_UNUSED
)
2273 const SCM cdr_expr
= SCM_CDR (expr
);
2274 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2275 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 1, s_missing_expression
, expr
);
2277 symbol
= SCM_CAR (cdr_expr
);
2278 ASSERT_SYNTAX_2 (scm_is_symbol (symbol
), s_bad_variable
, symbol
, expr
);
2280 location
= scm_symbol_fref (symbol
);
2281 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2283 /* The elisp function `defalias' allows to define aliases for symbols. To
2284 * look up such definitions, the chain of symbol definitions has to be
2285 * followed up to the terminal symbol. */
2286 while (scm_is_symbol (SCM_VARIABLE_REF (location
)))
2288 const SCM alias
= SCM_VARIABLE_REF (location
);
2289 location
= scm_symbol_fref (alias
);
2290 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2293 /* Memoize the value location belonging to the terminal symbol. */
2294 SCM_SETCAR (cdr_expr
, location
);
2296 if (!SCM_MACROP (SCM_VARIABLE_REF (location
)))
2298 /* Since the location does not contain a macro, the form is a procedure
2299 * application. Replace `@fop' by `@apply' and transform the expression
2300 * including the `transformer-macro'. */
2301 SCM_SETCAR (expr
, SCM_IM_APPLY
);
2306 /* Since the location contains a macro, the arguments should not be
2307 * transformed, so the `transformer-macro' is cut out. The resulting
2308 * expression starts with the memoized variable, that is at the cdr of
2309 * the input expression. */
2310 SCM_SETCDR (cdr_expr
, SCM_CDADR (cdr_expr
));
2315 #endif /* SCM_ENABLE_ELISP */
2319 unmemoize_builtin_macro (const SCM expr
, const SCM env
)
2321 switch (ISYMNUM (SCM_CAR (expr
)))
2323 case (ISYMNUM (SCM_IM_AND
)):
2324 return unmemoize_and (expr
, env
);
2326 case (ISYMNUM (SCM_IM_BEGIN
)):
2327 return unmemoize_begin (expr
, env
);
2329 case (ISYMNUM (SCM_IM_CASE
)):
2330 return unmemoize_case (expr
, env
);
2332 case (ISYMNUM (SCM_IM_COND
)):
2333 return unmemoize_cond (expr
, env
);
2335 case (ISYMNUM (SCM_IM_DELAY
)):
2336 return unmemoize_delay (expr
, env
);
2338 case (ISYMNUM (SCM_IM_DO
)):
2339 return unmemoize_do (expr
, env
);
2341 case (ISYMNUM (SCM_IM_IF
)):
2342 return unmemoize_if (expr
, env
);
2344 case (ISYMNUM (SCM_IM_LAMBDA
)):
2345 return unmemoize_lambda (expr
, env
);
2347 case (ISYMNUM (SCM_IM_LET
)):
2348 return unmemoize_let (expr
, env
);
2350 case (ISYMNUM (SCM_IM_LETREC
)):
2351 return unmemoize_letrec (expr
, env
);
2353 case (ISYMNUM (SCM_IM_LETSTAR
)):
2354 return unmemoize_letstar (expr
, env
);
2356 case (ISYMNUM (SCM_IM_OR
)):
2357 return unmemoize_or (expr
, env
);
2359 case (ISYMNUM (SCM_IM_QUOTE
)):
2360 return unmemoize_quote (expr
, env
);
2362 case (ISYMNUM (SCM_IM_SET_X
)):
2363 return unmemoize_set_x (expr
, env
);
2365 case (ISYMNUM (SCM_IM_APPLY
)):
2366 return unmemoize_apply (expr
, env
);
2368 case (ISYMNUM (SCM_IM_BIND
)):
2369 return unmemoize_exprs (expr
, env
); /* FIXME */
2371 case (ISYMNUM (SCM_IM_CONT
)):
2372 return unmemoize_atcall_cc (expr
, env
);
2374 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2375 return unmemoize_at_call_with_values (expr
, env
);
2377 case (ISYMNUM (SCM_IM_FUTURE
)):
2378 return unmemoize_future (expr
, env
);
2380 case (ISYMNUM (SCM_IM_SLOT_REF
)):
2381 return unmemoize_atslot_ref (expr
, env
);
2383 case (ISYMNUM (SCM_IM_SLOT_SET_X
)):
2384 return unmemoize_atslot_set_x (expr
, env
);
2386 case (ISYMNUM (SCM_IM_NIL_COND
)):
2387 return unmemoize_exprs (expr
, env
); /* FIXME */
2390 return unmemoize_exprs (expr
, env
); /* FIXME */
2395 /* scm_i_unmemocopy_expr and scm_i_unmemocopy_body take a memoized expression
2396 * respectively a memoized body together with its environment and rewrite it
2397 * to its original form. Thus, these functions are the inversion of the
2398 * rewrite rules above. The procedure is not optimized for speed. It's used
2399 * in scm_i_unmemoize_expr, scm_procedure_source, macro_print and scm_iprin1.
2401 * Unmemoizing is not a reliable process. You cannot in general expect to get
2402 * the original source back.
2404 * However, GOOPS currently relies on this for method compilation. This ought
2408 scm_i_unmemocopy_expr (SCM expr
, SCM env
)
2410 const SCM source_properties
= scm_whash_lookup (scm_source_whash
, expr
);
2411 const SCM um_expr
= unmemoize_expression (expr
, env
);
2413 if (scm_is_true (source_properties
))
2414 scm_whash_insert (scm_source_whash
, um_expr
, source_properties
);
2420 scm_i_unmemocopy_body (SCM forms
, SCM env
)
2422 const SCM source_properties
= scm_whash_lookup (scm_source_whash
, forms
);
2423 const SCM um_forms
= unmemoize_exprs (forms
, env
);
2425 if (scm_is_true (source_properties
))
2426 scm_whash_insert (scm_source_whash
, um_forms
, source_properties
);
2432 #if (SCM_ENABLE_DEPRECATED == 1)
2434 /* Deprecated in guile 1.7.0 on 2003-11-09. */
2436 scm_m_expand_body (SCM exprs
, SCM env
)
2438 scm_c_issue_deprecation_warning
2439 ("`scm_m_expand_body' is deprecated.");
2440 m_expand_body (exprs
, env
);
2445 SCM_SYNTAX (s_undefine
, "undefine", scm_makacro
, scm_m_undefine
);
2448 scm_m_undefine (SCM expr
, SCM env
)
2453 const SCM cdr_expr
= SCM_CDR (expr
);
2454 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), "Bad undefine placement in", expr
);
2455 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2456 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2458 scm_c_issue_deprecation_warning
2459 ("`undefine' is deprecated.\n");
2461 variable
= SCM_CAR (cdr_expr
);
2462 ASSERT_SYNTAX_2 (scm_is_symbol (variable
), s_bad_variable
, variable
, expr
);
2463 location
= scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_F
);
2464 ASSERT_SYNTAX_2 (scm_is_true (location
)
2465 && !SCM_UNBNDP (SCM_VARIABLE_REF (location
)),
2466 "variable already unbound ", variable
, expr
);
2467 SCM_VARIABLE_SET (location
, SCM_UNDEFINED
);
2468 return SCM_UNSPECIFIED
;
2472 scm_macroexp (SCM x
, SCM env
)
2474 scm_c_issue_deprecation_warning
2475 ("`scm_macroexp' is deprecated.");
2476 return macroexp (x
, env
);
2482 #if (SCM_ENABLE_DEPRECATED == 1)
2485 scm_unmemocar (SCM form
, SCM env
)
2487 scm_c_issue_deprecation_warning
2488 ("`scm_unmemocar' is deprecated.");
2490 if (!scm_is_pair (form
))
2494 SCM c
= SCM_CAR (form
);
2495 if (SCM_VARIABLEP (c
))
2497 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
2498 if (scm_is_false (sym
))
2499 sym
= sym_three_question_marks
;
2500 SCM_SETCAR (form
, sym
);
2502 else if (SCM_ILOCP (c
))
2504 unsigned long int ir
;
2506 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
2507 env
= SCM_CDR (env
);
2508 env
= SCM_CAAR (env
);
2509 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
2510 env
= SCM_CDR (env
);
2512 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
2520 /*****************************************************************************/
2521 /*****************************************************************************/
2522 /* The definitions for execution start here. */
2523 /*****************************************************************************/
2524 /*****************************************************************************/
2526 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
2527 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
2528 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
2529 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
2531 /* A function object to implement "apply" for non-closure functions. */
2533 /* An endless list consisting of #<undefined> objects: */
2534 static SCM undefineds
;
2538 scm_badargsp (SCM formals
, SCM args
)
2540 while (!scm_is_null (formals
))
2542 if (!scm_is_pair (formals
))
2544 if (scm_is_null (args
))
2546 formals
= SCM_CDR (formals
);
2547 args
= SCM_CDR (args
);
2549 return !scm_is_null (args
) ? 1 : 0;
2554 /* The evaluator contains a plethora of EVAL symbols. This is an attempt at
2557 * The following macros should be used in code which is read twice (where the
2558 * choice of evaluator is hard soldered):
2560 * CEVAL is the symbol used within one evaluator to call itself.
2561 * Originally, it is defined to ceval, but is redefined to deval during the
2564 * SCM_I_EVALIM is used when it is known that the expression is an
2565 * immediate. (This macro never calls an evaluator.)
2567 * EVAL evaluates an expression that is expected to have its symbols already
2568 * memoized. Expressions that are not of the form '(<form> <form> ...)' are
2569 * evaluated inline without calling an evaluator.
2571 * EVALCAR evaluates the car of an expression 'X:(Y:<form> <form> ...)',
2572 * potentially replacing a symbol at the position Y:<form> by its memoized
2573 * variable. If Y:<form> is not of the form '(<form> <form> ...)', the
2574 * evaluation is performed inline without calling an evaluator.
2576 * The following macros should be used in code which is read once
2577 * (where the choice of evaluator is dynamic):
2579 * SCM_I_XEVAL corresponds to EVAL, but uses ceval *or* deval depending on the
2582 * SCM_I_XEVALCAR corresponds to EVALCAR, but uses ceval *or* deval depending
2583 * on the debugging mode.
2585 * The main motivation for keeping this plethora is efficiency
2586 * together with maintainability (=> locality of code).
2589 static SCM
ceval (SCM x
, SCM env
);
2590 static SCM
deval (SCM x
, SCM env
);
2594 #define SCM_I_EVALIM2(x) \
2595 ((scm_is_eq ((x), SCM_EOL) \
2596 ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \
2600 #define SCM_I_EVALIM(x, env) (SCM_ILOCP (x) \
2601 ? *scm_ilookup ((x), (env)) \
2604 #define SCM_I_XEVAL(x, env) \
2606 ? SCM_I_EVALIM2 (x) \
2607 : (SCM_VARIABLEP (x) \
2608 ? SCM_VARIABLE_REF (x) \
2609 : (scm_is_pair (x) \
2610 ? (scm_debug_mode_p \
2611 ? deval ((x), (env)) \
2612 : ceval ((x), (env))) \
2615 #define SCM_I_XEVALCAR(x, env) \
2616 (SCM_IMP (SCM_CAR (x)) \
2617 ? SCM_I_EVALIM (SCM_CAR (x), (env)) \
2618 : (SCM_VARIABLEP (SCM_CAR (x)) \
2619 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2620 : (scm_is_pair (SCM_CAR (x)) \
2621 ? (scm_debug_mode_p \
2622 ? deval (SCM_CAR (x), (env)) \
2623 : ceval (SCM_CAR (x), (env))) \
2624 : (!scm_is_symbol (SCM_CAR (x)) \
2626 : *scm_lookupcar ((x), (env), 1)))))
2628 #define EVAL(x, env) \
2630 ? SCM_I_EVALIM ((x), (env)) \
2631 : (SCM_VARIABLEP (x) \
2632 ? SCM_VARIABLE_REF (x) \
2633 : (scm_is_pair (x) \
2634 ? CEVAL ((x), (env)) \
2637 #define EVALCAR(x, env) \
2638 (SCM_IMP (SCM_CAR (x)) \
2639 ? SCM_I_EVALIM (SCM_CAR (x), (env)) \
2640 : (SCM_VARIABLEP (SCM_CAR (x)) \
2641 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2642 : (scm_is_pair (SCM_CAR (x)) \
2643 ? CEVAL (SCM_CAR (x), (env)) \
2644 : (!scm_is_symbol (SCM_CAR (x)) \
2646 : *scm_lookupcar ((x), (env), 1)))))
2648 pthread_mutex_t source_mutex
= PTHREAD_RECURSIVE_MUTEX_INITIALIZER_NP
;
2651 /* Lookup a given local variable in an environment. The local variable is
2652 * given as an iloc, that is a triple <frame, binding, last?>, where frame
2653 * indicates the relative number of the environment frame (counting upwards
2654 * from the innermost environment frame), binding indicates the number of the
2655 * binding within the frame, and last? (which is extracted from the iloc using
2656 * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
2657 * very end of the improper list of bindings. */
2659 scm_ilookup (SCM iloc
, SCM env
)
2661 unsigned int frame_nr
= SCM_IFRAME (iloc
);
2662 unsigned int binding_nr
= SCM_IDIST (iloc
);
2666 for (; 0 != frame_nr
; --frame_nr
)
2667 frames
= SCM_CDR (frames
);
2669 bindings
= SCM_CAR (frames
);
2670 for (; 0 != binding_nr
; --binding_nr
)
2671 bindings
= SCM_CDR (bindings
);
2673 if (SCM_ICDRP (iloc
))
2674 return SCM_CDRLOC (bindings
);
2675 return SCM_CARLOC (SCM_CDR (bindings
));
2679 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
2681 static void error_unbound_variable (SCM symbol
) SCM_NORETURN
;
2682 static void error_defined_variable (SCM symbol
) SCM_NORETURN
;
2684 /* Call this for variables that are unfound.
2687 error_unbound_variable (SCM symbol
)
2689 scm_error (scm_unbound_variable_key
, NULL
,
2690 "Unbound variable: ~S",
2691 scm_list_1 (symbol
), SCM_BOOL_F
);
2694 /* Call this for variables that are found but contain SCM_UNDEFINED.
2697 error_defined_variable (SCM symbol
)
2699 /* We use the 'unbound-variable' key here as well, since it
2700 basically is the same kind of error, with a slight variation in
2701 the displayed message.
2703 scm_error (scm_unbound_variable_key
, NULL
,
2704 "Variable used before given a value: ~S",
2705 scm_list_1 (symbol
), SCM_BOOL_F
);
2709 /* The Lookup Car Race
2712 Memoization of variables and special forms is done while executing
2713 the code for the first time. As long as there is only one thread
2714 everything is fine, but as soon as two threads execute the same
2715 code concurrently `for the first time' they can come into conflict.
2717 This memoization includes rewriting variable references into more
2718 efficient forms and expanding macros. Furthermore, macro expansion
2719 includes `compiling' special forms like `let', `cond', etc. into
2720 tree-code instructions.
2722 There shouldn't normally be a problem with memoizing local and
2723 global variable references (into ilocs and variables), because all
2724 threads will mutate the code in *exactly* the same way and (if I
2725 read the C code correctly) it is not possible to observe a half-way
2726 mutated cons cell. The lookup procedure can handle this
2727 transparently without any critical sections.
2729 It is different with macro expansion, because macro expansion
2730 happens outside of the lookup procedure and can't be
2731 undone. Therefore the lookup procedure can't cope with it. It has
2732 to indicate failure when it detects a lost race and hope that the
2733 caller can handle it. Luckily, it turns out that this is the case.
2735 An example to illustrate this: Suppose that the following form will
2736 be memoized concurrently by two threads
2740 Let's first examine the lookup of X in the body. The first thread
2741 decides that it has to find the symbol "x" in the environment and
2742 starts to scan it. Then the other thread takes over and actually
2743 overtakes the first. It looks up "x" and substitutes an
2744 appropriate iloc for it. Now the first thread continues and
2745 completes its lookup. It comes to exactly the same conclusions as
2746 the second one and could - without much ado - just overwrite the
2747 iloc with the same iloc.
2749 But let's see what will happen when the race occurs while looking
2750 up the symbol "let" at the start of the form. It could happen that
2751 the second thread interrupts the lookup of the first thread and not
2752 only substitutes a variable for it but goes right ahead and
2753 replaces it with the compiled form (#@let* (x 12) x). Now, when
2754 the first thread completes its lookup, it would replace the #@let*
2755 with a variable containing the "let" binding, effectively reverting
2756 the form to (let (x 12) x). This is wrong. It has to detect that
2757 it has lost the race and the evaluator has to reconsider the
2758 changed form completely.
2760 This race condition could be resolved with some kind of traffic
2761 light (like mutexes) around scm_lookupcar, but I think that it is
2762 best to avoid them in this case. They would serialize memoization
2763 completely and because lookup involves calling arbitrary Scheme
2764 code (via the lookup-thunk), threads could be blocked for an
2765 arbitrary amount of time or even deadlock. But with the current
2766 solution a lot of unnecessary work is potentially done. */
2768 /* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
2769 return NULL to indicate a failed lookup due to some race conditions
2770 between threads. This only happens when VLOC is the first cell of
2771 a special form that will eventually be memoized (like `let', etc.)
2772 In that case the whole lookup is bogus and the caller has to
2773 reconsider the complete special form.
2775 SCM_LOOKUPCAR is still there, of course. It just calls
2776 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
2777 should only be called when it is known that VLOC is not the first
2778 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
2779 for NULL. I think I've found the only places where this
2783 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
2786 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
2787 register SCM iloc
= SCM_ILOC00
;
2788 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
2790 if (!scm_is_pair (SCM_CAR (env
)))
2792 al
= SCM_CARLOC (env
);
2793 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
2795 if (!scm_is_pair (fl
))
2797 if (scm_is_eq (fl
, var
))
2799 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2801 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
2802 return SCM_CDRLOC (*al
);
2807 al
= SCM_CDRLOC (*al
);
2808 if (scm_is_eq (SCM_CAR (fl
), var
))
2810 if (SCM_UNBNDP (SCM_CAR (*al
)))
2811 error_defined_variable (var
);
2812 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2814 SCM_SETCAR (vloc
, iloc
);
2815 return SCM_CARLOC (*al
);
2817 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
2819 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
2822 SCM top_thunk
, real_var
;
2825 top_thunk
= SCM_CAR (env
); /* env now refers to a
2826 top level env thunk */
2827 env
= SCM_CDR (env
);
2830 top_thunk
= SCM_BOOL_F
;
2831 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
2832 if (scm_is_false (real_var
))
2835 if (!scm_is_null (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
2840 if (scm_is_null (env
))
2841 error_unbound_variable (var
);
2843 scm_misc_error (NULL
, "Damaged environment: ~S",
2848 /* A variable could not be found, but we shall
2849 not throw an error. */
2850 static SCM undef_object
= SCM_UNDEFINED
;
2851 return &undef_object
;
2855 if (!scm_is_eq (SCM_CAR (vloc
), var
))
2857 /* Some other thread has changed the very cell we are working
2858 on. In effect, it must have done our job or messed it up
2861 var
= SCM_CAR (vloc
);
2862 if (SCM_VARIABLEP (var
))
2863 return SCM_VARIABLE_LOC (var
);
2864 if (SCM_ILOCP (var
))
2865 return scm_ilookup (var
, genv
);
2866 /* We can't cope with anything else than variables and ilocs. When
2867 a special form has been memoized (i.e. `let' into `#@let') we
2868 return NULL and expect the calling function to do the right
2869 thing. For the evaluator, this means going back and redoing
2870 the dispatch on the car of the form. */
2874 SCM_SETCAR (vloc
, real_var
);
2875 return SCM_VARIABLE_LOC (real_var
);
2880 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
2882 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
2889 /* During execution, look up a symbol in the top level of the given local
2890 * environment and return the corresponding variable object. If no binding
2891 * for the symbol can be found, an 'Unbound variable' error is signalled. */
2893 lazy_memoize_variable (const SCM symbol
, const SCM environment
)
2895 const SCM top_level
= scm_env_top_level (environment
);
2896 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
2898 if (scm_is_false (variable
))
2899 error_unbound_variable (symbol
);
2906 scm_eval_car (SCM pair
, SCM env
)
2908 return SCM_I_XEVALCAR (pair
, env
);
2913 scm_eval_args (SCM l
, SCM env
, SCM proc
)
2915 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
2916 while (scm_is_pair (l
))
2918 res
= EVALCAR (l
, env
);
2920 *lloc
= scm_list_1 (res
);
2921 lloc
= SCM_CDRLOC (*lloc
);
2924 if (!scm_is_null (l
))
2925 scm_wrong_num_args (proc
);
2931 scm_eval_body (SCM code
, SCM env
)
2936 next
= SCM_CDR (code
);
2937 while (!scm_is_null (next
))
2939 if (SCM_IMP (SCM_CAR (code
)))
2941 if (SCM_ISYMP (SCM_CAR (code
)))
2943 scm_pthread_mutex_lock (&source_mutex
);
2944 /* check for race condition */
2945 if (SCM_ISYMP (SCM_CAR (code
)))
2946 m_expand_body (code
, env
);
2947 pthread_mutex_unlock (&source_mutex
);
2952 SCM_I_XEVAL (SCM_CAR (code
), env
);
2954 next
= SCM_CDR (code
);
2956 return SCM_I_XEVALCAR (code
, env
);
2962 /* SECTION: This code is specific for the debugging support. One
2963 * branch is read when DEVAL isn't defined, the other when DEVAL is
2969 #define SCM_APPLY scm_apply
2970 #define PREP_APPLY(proc, args)
2972 #define RETURN(x) do { return x; } while (0)
2973 #ifdef STACK_CHECKING
2974 #ifndef NO_CEVAL_STACK_CHECKING
2975 #define EVAL_STACK_CHECKING
2982 #define CEVAL deval /* Substitute all uses of ceval */
2985 #define SCM_APPLY scm_dapply
2988 #define PREP_APPLY(p, l) \
2989 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
2992 #define ENTER_APPLY \
2994 SCM_SET_ARGSREADY (debug);\
2995 if (scm_check_apply_p && SCM_TRAPS_P)\
2996 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
2998 SCM tmp, tail = scm_from_bool(SCM_TRACED_FRAME_P (debug)); \
2999 SCM_SET_TRACED_FRAME (debug); \
3001 if (SCM_CHEAPTRAPS_P)\
3003 tmp = scm_make_debugobj (&debug);\
3004 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
3009 tmp = scm_make_continuation (&first);\
3011 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
3018 #define RETURN(e) do { proc = (e); goto exit; } while (0)
3020 #ifdef STACK_CHECKING
3021 #ifndef EVAL_STACK_CHECKING
3022 #define EVAL_STACK_CHECKING
3027 /* scm_last_debug_frame contains a pointer to the last debugging information
3028 * stack frame. It is accessed very often from the debugging evaluator, so it
3029 * should probably not be indirectly addressed. Better to save and restore it
3030 * from the current root at any stack swaps.
3033 /* scm_debug_eframe_size is the number of slots available for pseudo
3034 * stack frames at each real stack frame.
3037 long scm_debug_eframe_size
;
3039 int scm_debug_mode_p
;
3040 int scm_check_entry_p
;
3041 int scm_check_apply_p
;
3042 int scm_check_exit_p
;
3044 long scm_eval_stack
;
3046 scm_t_option scm_eval_opts
[] = {
3047 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
3050 scm_t_option scm_debug_opts
[] = {
3051 { SCM_OPTION_BOOLEAN
, "cheap", 1,
3052 "*Flyweight representation of the stack at traps." },
3053 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
3054 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
3055 { SCM_OPTION_BOOLEAN
, "procnames", 1,
3056 "Record procedure names at definition." },
3057 { SCM_OPTION_BOOLEAN
, "backwards", 0,
3058 "Display backtrace in anti-chronological order." },
3059 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
3060 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
3061 { SCM_OPTION_INTEGER
, "frames", 3,
3062 "Maximum number of tail-recursive frames in backtrace." },
3063 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
3064 "Maximal number of stored backtrace frames." },
3065 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
3066 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
3067 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
3068 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
3069 { 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."},
3070 { SCM_OPTION_BOOLEAN
, "warn-deprecated", 0, "Warn when deprecated features are used." }
3073 scm_t_option scm_evaluator_trap_table
[] = {
3074 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
3075 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
3076 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
3077 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
3078 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
3079 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
3080 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
3083 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
3085 "Option interface for the evaluation options. Instead of using\n"
3086 "this procedure directly, use the procedures @code{eval-enable},\n"
3087 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
3088 #define FUNC_NAME s_scm_eval_options_interface
3092 ans
= scm_options (setting
,
3096 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
3103 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
3105 "Option interface for the evaluator trap options.")
3106 #define FUNC_NAME s_scm_evaluator_traps
3110 ans
= scm_options (setting
,
3111 scm_evaluator_trap_table
,
3112 SCM_N_EVALUATOR_TRAPS
,
3114 SCM_RESET_DEBUG_MODE
;
3122 deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
3124 SCM
*results
= lloc
;
3125 while (scm_is_pair (l
))
3127 const SCM res
= EVALCAR (l
, env
);
3129 *lloc
= scm_list_1 (res
);
3130 lloc
= SCM_CDRLOC (*lloc
);
3133 if (!scm_is_null (l
))
3134 scm_wrong_num_args (proc
);
3141 /* SECTION: This code is compiled twice.
3145 /* Update the toplevel environment frame ENV so that it refers to the
3146 * current module. */
3147 #define UPDATE_TOPLEVEL_ENV(env) \
3149 SCM p = scm_current_module_lookup_closure (); \
3150 if (p != SCM_CAR (env)) \
3151 env = scm_top_level_env (p); \
3155 #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
3156 ASSERT_SYNTAX (!scm_is_eq ((x), SCM_EOL), s_empty_combination, x)
3159 /* This is the evaluator. Like any real monster, it has three heads:
3161 * ceval is the non-debugging evaluator, deval is the debugging version. Both
3162 * are implemented using a common code base, using the following mechanism:
3163 * CEVAL is a macro, which is either defined to ceval or deval. Thus, there
3164 * is no function CEVAL, but the code for CEVAL actually compiles to either
3165 * ceval or deval. When CEVAL is defined to ceval, it is known that the macro
3166 * DEVAL is not defined. When CEVAL is defined to deval, then the macro DEVAL
3167 * is known to be defined. Thus, in CEVAL parts for the debugging evaluator
3168 * are enclosed within #ifdef DEVAL ... #endif.
3170 * All three (ceval, deval and their common implementation CEVAL) take two
3171 * input parameters, x and env: x is a single expression to be evalutated.
3172 * env is the environment in which bindings are searched.
3174 * x is known to be a pair. Since x is a single expression, it is necessarily
3175 * in a tail position. If x is just a call to another function like in the
3176 * expression (foo exp1 exp2 ...), the realization of that call therefore
3177 * _must_not_ increase stack usage (the evaluation of exp1, exp2 etc.,
3178 * however, may do so). This is realized by making extensive use of 'goto'
3179 * statements within the evaluator: The gotos replace recursive calls to
3180 * CEVAL, thus re-using the same stack frame that CEVAL was already using.
3181 * If, however, x represents some form that requires to evaluate a sequence of
3182 * expressions like (begin exp1 exp2 ...), then recursive calls to CEVAL are
3183 * performed for all but the last expression of that sequence. */
3186 CEVAL (SCM x
, SCM env
)
3190 scm_t_debug_frame debug
;
3191 scm_t_debug_info
*debug_info_end
;
3192 debug
.prev
= scm_last_debug_frame
;
3195 * The debug.vect contains twice as much scm_t_debug_info frames as the
3196 * user has specified with (debug-set! frames <n>).
3198 * Even frames are eval frames, odd frames are apply frames.
3200 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
3201 * sizeof (scm_t_debug_info
));
3202 debug
.info
= debug
.vect
;
3203 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
3204 scm_last_debug_frame
= &debug
;
3206 #ifdef EVAL_STACK_CHECKING
3207 if (scm_stack_checking_enabled_p
&& SCM_STACK_OVERFLOW_P (&proc
))
3210 debug
.info
->e
.exp
= x
;
3211 debug
.info
->e
.env
= env
;
3213 scm_report_stack_overflow ();
3223 SCM_CLEAR_ARGSREADY (debug
);
3224 if (SCM_OVERFLOWP (debug
))
3227 * In theory, this should be the only place where it is necessary to
3228 * check for space in debug.vect since both eval frames and
3229 * available space are even.
3231 * For this to be the case, however, it is necessary that primitive
3232 * special forms which jump back to `loop', `begin' or some similar
3233 * label call PREP_APPLY.
3235 else if (++debug
.info
>= debug_info_end
)
3237 SCM_SET_OVERFLOW (debug
);
3242 debug
.info
->e
.exp
= x
;
3243 debug
.info
->e
.env
= env
;
3244 if (scm_check_entry_p
&& SCM_TRAPS_P
)
3246 if (SCM_ENTER_FRAME_P
3247 || (SCM_BREAKPOINTS_P
&& scm_c_source_property_breakpoint_p (x
)))
3250 SCM tail
= scm_from_bool (SCM_TAILRECP (debug
));
3251 SCM_SET_TAILREC (debug
);
3252 if (SCM_CHEAPTRAPS_P
)
3253 stackrep
= scm_make_debugobj (&debug
);
3257 SCM val
= scm_make_continuation (&first
);
3267 /* This gives the possibility for the debugger to
3268 modify the source expression before evaluation. */
3273 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
3274 scm_sym_enter_frame
,
3277 unmemoize_expression (x
, env
));
3284 if (SCM_ISYMP (SCM_CAR (x
)))
3286 switch (ISYMNUM (SCM_CAR (x
)))
3288 case (ISYMNUM (SCM_IM_AND
)):
3290 while (!scm_is_null (SCM_CDR (x
)))
3292 SCM test_result
= EVALCAR (x
, env
);
3293 if (scm_is_false (test_result
) || SCM_NILP (test_result
))
3294 RETURN (SCM_BOOL_F
);
3298 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3301 case (ISYMNUM (SCM_IM_BEGIN
)):
3303 if (scm_is_null (x
))
3304 RETURN (SCM_UNSPECIFIED
);
3306 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3309 /* If we are on toplevel with a lookup closure, we need to sync
3310 with the current module. */
3311 if (scm_is_pair (env
) && !scm_is_pair (SCM_CAR (env
)))
3313 UPDATE_TOPLEVEL_ENV (env
);
3314 while (!scm_is_null (SCM_CDR (x
)))
3317 UPDATE_TOPLEVEL_ENV (env
);
3323 goto nontoplevel_begin
;
3326 while (!scm_is_null (SCM_CDR (x
)))
3328 const SCM form
= SCM_CAR (x
);
3331 if (SCM_ISYMP (form
))
3333 scm_pthread_mutex_lock (&source_mutex
);
3334 /* check for race condition */
3335 if (SCM_ISYMP (SCM_CAR (x
)))
3336 m_expand_body (x
, env
);
3337 pthread_mutex_unlock (&source_mutex
);
3338 goto nontoplevel_begin
;
3341 SCM_VALIDATE_NON_EMPTY_COMBINATION (form
);
3344 (void) EVAL (form
, env
);
3350 /* scm_eval last form in list */
3351 const SCM last_form
= SCM_CAR (x
);
3353 if (scm_is_pair (last_form
))
3355 /* This is by far the most frequent case. */
3357 goto loop
; /* tail recurse */
3359 else if (SCM_IMP (last_form
))
3360 RETURN (SCM_I_EVALIM (last_form
, env
));
3361 else if (SCM_VARIABLEP (last_form
))
3362 RETURN (SCM_VARIABLE_REF (last_form
));
3363 else if (scm_is_symbol (last_form
))
3364 RETURN (*scm_lookupcar (x
, env
, 1));
3370 case (ISYMNUM (SCM_IM_CASE
)):
3373 const SCM key
= EVALCAR (x
, env
);
3375 while (!scm_is_null (x
))
3377 const SCM clause
= SCM_CAR (x
);
3378 SCM labels
= SCM_CAR (clause
);
3379 if (scm_is_eq (labels
, SCM_IM_ELSE
))
3381 x
= SCM_CDR (clause
);
3382 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3385 while (!scm_is_null (labels
))
3387 const SCM label
= SCM_CAR (labels
);
3388 if (scm_is_eq (label
, key
)
3389 || scm_is_true (scm_eqv_p (label
, key
)))
3391 x
= SCM_CDR (clause
);
3392 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3395 labels
= SCM_CDR (labels
);
3400 RETURN (SCM_UNSPECIFIED
);
3403 case (ISYMNUM (SCM_IM_COND
)):
3405 while (!scm_is_null (x
))
3407 const SCM clause
= SCM_CAR (x
);
3408 if (scm_is_eq (SCM_CAR (clause
), SCM_IM_ELSE
))
3410 x
= SCM_CDR (clause
);
3411 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3416 arg1
= EVALCAR (clause
, env
);
3417 if (scm_is_true (arg1
) && !SCM_NILP (arg1
))
3419 x
= SCM_CDR (clause
);
3420 if (scm_is_null (x
))
3422 else if (!scm_is_eq (SCM_CAR (x
), SCM_IM_ARROW
))
3424 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3430 proc
= EVALCAR (proc
, env
);
3431 PREP_APPLY (proc
, scm_list_1 (arg1
));
3439 RETURN (SCM_UNSPECIFIED
);
3442 case (ISYMNUM (SCM_IM_DO
)):
3445 /* Compute the initialization values and the initial environment. */
3446 SCM init_forms
= SCM_CAR (x
);
3447 SCM init_values
= SCM_EOL
;
3448 while (!scm_is_null (init_forms
))
3450 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3451 init_forms
= SCM_CDR (init_forms
);
3454 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
3458 SCM test_form
= SCM_CAR (x
);
3459 SCM body_forms
= SCM_CADR (x
);
3460 SCM step_forms
= SCM_CDDR (x
);
3462 SCM test_result
= EVALCAR (test_form
, env
);
3464 while (scm_is_false (test_result
) || SCM_NILP (test_result
))
3467 /* Evaluate body forms. */
3469 for (temp_forms
= body_forms
;
3470 !scm_is_null (temp_forms
);
3471 temp_forms
= SCM_CDR (temp_forms
))
3473 SCM form
= SCM_CAR (temp_forms
);
3474 /* Dirk:FIXME: We only need to eval forms that may have
3475 * a side effect here. This is only true for forms that
3476 * start with a pair. All others are just constants.
3477 * Since with the current memoizer 'form' may hold a
3478 * constant, we call EVAL here to handle the constant
3479 * cases. In the long run it would make sense to have
3480 * the macro transformer of 'do' eliminate all forms
3481 * that have no sideeffect. Then instead of EVAL we
3482 * could call CEVAL directly here. */
3483 (void) EVAL (form
, env
);
3488 /* Evaluate the step expressions. */
3490 SCM step_values
= SCM_EOL
;
3491 for (temp_forms
= step_forms
;
3492 !scm_is_null (temp_forms
);
3493 temp_forms
= SCM_CDR (temp_forms
))
3495 const SCM value
= EVALCAR (temp_forms
, env
);
3496 step_values
= scm_cons (value
, step_values
);
3498 env
= SCM_EXTEND_ENV (SCM_CAAR (env
),
3503 test_result
= EVALCAR (test_form
, env
);
3507 if (scm_is_null (x
))
3508 RETURN (SCM_UNSPECIFIED
);
3509 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3510 goto nontoplevel_begin
;
3513 case (ISYMNUM (SCM_IM_IF
)):
3516 SCM test_result
= EVALCAR (x
, env
);
3517 x
= SCM_CDR (x
); /* then expression */
3518 if (scm_is_false (test_result
) || SCM_NILP (test_result
))
3520 x
= SCM_CDR (x
); /* else expression */
3521 if (scm_is_null (x
))
3522 RETURN (SCM_UNSPECIFIED
);
3525 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3529 case (ISYMNUM (SCM_IM_LET
)):
3532 SCM init_forms
= SCM_CADR (x
);
3533 SCM init_values
= SCM_EOL
;
3536 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3537 init_forms
= SCM_CDR (init_forms
);
3539 while (!scm_is_null (init_forms
));
3540 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
3543 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3544 goto nontoplevel_begin
;
3547 case (ISYMNUM (SCM_IM_LETREC
)):
3549 env
= SCM_EXTEND_ENV (SCM_CAR (x
), undefineds
, env
);
3552 SCM init_forms
= SCM_CAR (x
);
3553 SCM init_values
= SCM_EOL
;
3556 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3557 init_forms
= SCM_CDR (init_forms
);
3559 while (!scm_is_null (init_forms
));
3560 SCM_SETCDR (SCM_CAR (env
), init_values
);
3563 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3564 goto nontoplevel_begin
;
3567 case (ISYMNUM (SCM_IM_LETSTAR
)):
3570 SCM bindings
= SCM_CAR (x
);
3571 if (!scm_is_null (bindings
))
3575 SCM name
= SCM_CAR (bindings
);
3576 SCM init
= SCM_CDR (bindings
);
3577 env
= SCM_EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
3578 bindings
= SCM_CDR (init
);
3580 while (!scm_is_null (bindings
));
3584 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3585 goto nontoplevel_begin
;
3588 case (ISYMNUM (SCM_IM_OR
)):
3590 while (!scm_is_null (SCM_CDR (x
)))
3592 SCM val
= EVALCAR (x
, env
);
3593 if (scm_is_true (val
) && !SCM_NILP (val
))
3598 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3602 case (ISYMNUM (SCM_IM_LAMBDA
)):
3603 RETURN (scm_closure (SCM_CDR (x
), env
));
3606 case (ISYMNUM (SCM_IM_QUOTE
)):
3607 RETURN (SCM_CDR (x
));
3610 case (ISYMNUM (SCM_IM_SET_X
)):
3614 SCM variable
= SCM_CAR (x
);
3615 if (SCM_ILOCP (variable
))
3616 location
= scm_ilookup (variable
, env
);
3617 else if (SCM_VARIABLEP (variable
))
3618 location
= SCM_VARIABLE_LOC (variable
);
3621 /* (scm_is_symbol (variable)) is known to be true */
3622 variable
= lazy_memoize_variable (variable
, env
);
3623 SCM_SETCAR (x
, variable
);
3624 location
= SCM_VARIABLE_LOC (variable
);
3627 *location
= EVALCAR (x
, env
);
3629 RETURN (SCM_UNSPECIFIED
);
3632 case (ISYMNUM (SCM_IM_APPLY
)):
3633 /* Evaluate the procedure to be applied. */
3635 proc
= EVALCAR (x
, env
);
3636 PREP_APPLY (proc
, SCM_EOL
);
3638 /* Evaluate the argument holding the list of arguments */
3640 arg1
= EVALCAR (x
, env
);
3643 /* Go here to tail-apply a procedure. PROC is the procedure and
3644 * ARG1 is the list of arguments. PREP_APPLY must have been called
3645 * before jumping to apply_proc. */
3646 if (SCM_CLOSUREP (proc
))
3648 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3650 debug
.info
->a
.args
= arg1
;
3652 if (scm_badargsp (formals
, arg1
))
3653 scm_wrong_num_args (proc
);
3655 /* Copy argument list */
3656 if (SCM_NULL_OR_NIL_P (arg1
))
3657 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
3660 SCM args
= scm_list_1 (SCM_CAR (arg1
));
3662 arg1
= SCM_CDR (arg1
);
3663 while (!SCM_NULL_OR_NIL_P (arg1
))
3665 SCM new_tail
= scm_list_1 (SCM_CAR (arg1
));
3666 SCM_SETCDR (tail
, new_tail
);
3668 arg1
= SCM_CDR (arg1
);
3670 env
= SCM_EXTEND_ENV (formals
, args
, SCM_ENV (proc
));
3673 x
= SCM_CLOSURE_BODY (proc
);
3674 goto nontoplevel_begin
;
3679 RETURN (SCM_APPLY (proc
, arg1
, SCM_EOL
));
3683 case (ISYMNUM (SCM_IM_CONT
)):
3686 SCM val
= scm_make_continuation (&first
);
3694 proc
= EVALCAR (proc
, env
);
3695 PREP_APPLY (proc
, scm_list_1 (arg1
));
3702 case (ISYMNUM (SCM_IM_DELAY
)):
3703 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
3706 case (ISYMNUM (SCM_IM_FUTURE
)):
3707 RETURN (scm_i_make_future (scm_closure (SCM_CDR (x
), env
)));
3710 /* PLACEHOLDER for case (ISYMNUM (SCM_IM_DISPATCH)): The following
3711 code (type_dispatch) is intended to be the tail of the case
3712 clause for the internal macro SCM_IM_DISPATCH. Please don't
3713 remove it from this location without discussing it with Mikael
3714 <djurfeldt@nada.kth.se> */
3716 /* The type dispatch code is duplicated below
3717 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
3718 * cuts down execution time for type dispatch to 50%. */
3719 type_dispatch
: /* inputs: x, arg1 */
3720 /* Type dispatch means to determine from the types of the function
3721 * arguments (i. e. the 'signature' of the call), which method from
3722 * a generic function is to be called. This process of selecting
3723 * the right method takes some time. To speed it up, guile uses
3724 * caching: Together with the macro call to dispatch the signatures
3725 * of some previous calls to that generic function from the same
3726 * place are stored (in the code!) in a cache that we call the
3727 * 'method cache'. This is done since it is likely, that
3728 * consecutive calls to dispatch from that position in the code will
3729 * have the same signature. Thus, the type dispatch works as
3730 * follows: First, determine a hash value from the signature of the
3731 * actual arguments. Second, use this hash value as an index to
3732 * find that same signature in the method cache stored at this
3733 * position in the code. If found, you have also found the
3734 * corresponding method that belongs to that signature. If the
3735 * signature is not found in the method cache, you have to perform a
3736 * full search over all signatures stored with the generic
3739 unsigned long int specializers
;
3740 unsigned long int hash_value
;
3741 unsigned long int cache_end_pos
;
3742 unsigned long int mask
;
3746 SCM z
= SCM_CDDR (x
);
3747 SCM tmp
= SCM_CADR (z
);
3748 specializers
= scm_to_ulong (SCM_CAR (z
));
3750 /* Compute a hash value for searching the method cache. There
3751 * are two variants for computing the hash value, a (rather)
3752 * complicated one, and a simple one. For the complicated one
3753 * explained below, tmp holds a number that is used in the
3755 if (scm_is_simple_vector (tmp
))
3757 /* This method of determining the hash value is much
3758 * simpler: Set the hash value to zero and just perform a
3759 * linear search through the method cache. */
3761 mask
= (unsigned long int) ((long) -1);
3763 cache_end_pos
= SCM_SIMPLE_VECTOR_LENGTH (method_cache
);
3767 /* Use the signature of the actual arguments to determine
3768 * the hash value. This is done as follows: Each class has
3769 * an array of random numbers, that are determined when the
3770 * class is created. The integer 'hashset' is an index into
3771 * that array of random numbers. Now, from all classes that
3772 * are part of the signature of the actual arguments, the
3773 * random numbers at index 'hashset' are taken and summed
3774 * up, giving the hash value. The value of 'hashset' is
3775 * stored at the call to dispatch. This allows to have
3776 * different 'formulas' for calculating the hash value at
3777 * different places where dispatch is called. This allows
3778 * to optimize the hash formula at every individual place
3779 * where dispatch is called, such that hopefully the hash
3780 * value that is computed will directly point to the right
3781 * method in the method cache. */
3782 unsigned long int hashset
= scm_to_ulong (tmp
);
3783 unsigned long int counter
= specializers
+ 1;
3786 while (!scm_is_null (tmp_arg
) && counter
!= 0)
3788 SCM
class = scm_class_of (SCM_CAR (tmp_arg
));
3789 hash_value
+= SCM_INSTANCE_HASH (class, hashset
);
3790 tmp_arg
= SCM_CDR (tmp_arg
);
3794 method_cache
= SCM_CADR (z
);
3795 mask
= scm_to_ulong (SCM_CAR (z
));
3797 cache_end_pos
= hash_value
;
3802 /* Search the method cache for a method with a matching
3803 * signature. Start the search at position 'hash_value'. The
3804 * hashing implementation uses linear probing for conflict
3805 * resolution, that is, if the signature in question is not
3806 * found at the starting index in the hash table, the next table
3807 * entry is tried, and so on, until in the worst case the whole
3808 * cache has been searched, but still the signature has not been
3813 SCM args
= arg1
; /* list of arguments */
3814 z
= SCM_SIMPLE_VECTOR_REF (method_cache
, hash_value
);
3815 while (!scm_is_null (args
))
3817 /* More arguments than specifiers => CLASS != ENV */
3818 SCM class_of_arg
= scm_class_of (SCM_CAR (args
));
3819 if (!scm_is_eq (class_of_arg
, SCM_CAR (z
)))
3821 args
= SCM_CDR (args
);
3824 /* Fewer arguments than specifiers => CAR != ENV */
3825 if (scm_is_null (SCM_CAR (z
)) || scm_is_pair (SCM_CAR (z
)))
3828 hash_value
= (hash_value
+ 1) & mask
;
3829 } while (hash_value
!= cache_end_pos
);
3831 /* No appropriate method was found in the cache. */
3832 z
= scm_memoize_method (x
, arg1
);
3834 apply_cmethod
: /* inputs: z, arg1 */
3836 SCM formals
= SCM_CMETHOD_FORMALS (z
);
3837 env
= SCM_EXTEND_ENV (formals
, arg1
, SCM_CMETHOD_ENV (z
));
3838 x
= SCM_CMETHOD_BODY (z
);
3839 goto nontoplevel_begin
;
3845 case (ISYMNUM (SCM_IM_SLOT_REF
)):
3848 SCM instance
= EVALCAR (x
, env
);
3849 unsigned long int slot
= SCM_I_INUM (SCM_CDR (x
));
3850 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance
) [slot
]));
3854 case (ISYMNUM (SCM_IM_SLOT_SET_X
)):
3857 SCM instance
= EVALCAR (x
, env
);
3858 unsigned long int slot
= SCM_I_INUM (SCM_CADR (x
));
3859 SCM value
= EVALCAR (SCM_CDDR (x
), env
);
3860 SCM_STRUCT_DATA (instance
) [slot
] = SCM_UNPACK (value
);
3861 RETURN (SCM_UNSPECIFIED
);
3865 #if SCM_ENABLE_ELISP
3867 case (ISYMNUM (SCM_IM_NIL_COND
)):
3869 SCM test_form
= SCM_CDR (x
);
3870 x
= SCM_CDR (test_form
);
3871 while (!SCM_NULL_OR_NIL_P (x
))
3873 SCM test_result
= EVALCAR (test_form
, env
);
3874 if (!(scm_is_false (test_result
)
3875 || SCM_NULL_OR_NIL_P (test_result
)))
3877 if (scm_is_eq (SCM_CAR (x
), SCM_UNSPECIFIED
))
3878 RETURN (test_result
);
3879 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3884 test_form
= SCM_CDR (x
);
3885 x
= SCM_CDR (test_form
);
3889 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3893 #endif /* SCM_ENABLE_ELISP */
3895 case (ISYMNUM (SCM_IM_BIND
)):
3897 SCM vars
, exps
, vals
;
3900 vars
= SCM_CAAR (x
);
3901 exps
= SCM_CDAR (x
);
3903 while (!scm_is_null (exps
))
3905 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
3906 exps
= SCM_CDR (exps
);
3909 scm_swap_bindings (vars
, vals
);
3910 scm_dynwinds
= scm_acons (vars
, vals
, scm_dynwinds
);
3912 /* Ignore all but the last evaluation result. */
3913 for (x
= SCM_CDR (x
); !scm_is_null (SCM_CDR (x
)); x
= SCM_CDR (x
))
3915 if (scm_is_pair (SCM_CAR (x
)))
3916 CEVAL (SCM_CAR (x
), env
);
3918 proc
= EVALCAR (x
, env
);
3920 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
3921 scm_swap_bindings (vars
, vals
);
3927 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
3932 producer
= EVALCAR (x
, env
);
3934 proc
= EVALCAR (x
, env
); /* proc is the consumer. */
3935 arg1
= SCM_APPLY (producer
, SCM_EOL
, SCM_EOL
);
3936 if (SCM_VALUESP (arg1
))
3938 /* The list of arguments is not copied. Rather, it is assumed
3939 * that this has been done by the 'values' procedure. */
3940 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
3944 arg1
= scm_list_1 (arg1
);
3946 PREP_APPLY (proc
, arg1
);
3957 if (SCM_VARIABLEP (SCM_CAR (x
)))
3958 proc
= SCM_VARIABLE_REF (SCM_CAR (x
));
3959 else if (SCM_ILOCP (SCM_CAR (x
)))
3960 proc
= *scm_ilookup (SCM_CAR (x
), env
);
3961 else if (scm_is_pair (SCM_CAR (x
)))
3962 proc
= CEVAL (SCM_CAR (x
), env
);
3963 else if (scm_is_symbol (SCM_CAR (x
)))
3965 SCM orig_sym
= SCM_CAR (x
);
3967 SCM
*location
= scm_lookupcar1 (x
, env
, 1);
3968 if (location
== NULL
)
3970 /* we have lost the race, start again. */
3976 if (SCM_MACROP (proc
))
3978 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
3980 handle_a_macro
: /* inputs: x, env, proc */
3982 /* Set a flag during macro expansion so that macro
3983 application frames can be deleted from the backtrace. */
3984 SCM_SET_MACROEXP (debug
);
3986 arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
3987 scm_cons (env
, scm_listofnull
));
3989 SCM_CLEAR_MACROEXP (debug
);
3991 switch (SCM_MACRO_TYPE (proc
))
3995 if (!scm_is_pair (arg1
))
3996 arg1
= scm_list_2 (SCM_IM_BEGIN
, arg1
);
3998 assert (!scm_is_eq (x
, SCM_CAR (arg1
))
3999 && !scm_is_eq (x
, SCM_CDR (arg1
)));
4002 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
4005 SCM_SETCAR (x
, SCM_CAR (arg1
));
4006 SCM_SETCDR (x
, SCM_CDR (arg1
));
4010 /* Prevent memoizing of debug info expression. */
4011 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
4016 SCM_SETCAR (x
, SCM_CAR (arg1
));
4017 SCM_SETCDR (x
, SCM_CDR (arg1
));
4019 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
4021 #if SCM_ENABLE_DEPRECATED == 1
4026 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
4040 if (SCM_MACROP (proc
))
4041 goto handle_a_macro
;
4045 /* When reaching this part of the code, the following is granted: Variable x
4046 * holds the first pair of an expression of the form (<function> arg ...).
4047 * Variable proc holds the object that resulted from the evaluation of
4048 * <function>. In the following, the arguments (if any) will be evaluated,
4049 * and proc will be applied to them. If proc does not really hold a
4050 * function object, this will be signalled as an error on the scheme
4051 * level. If the number of arguments does not match the number of arguments
4052 * that are allowed to be passed to proc, also an error on the scheme level
4053 * will be signalled. */
4054 PREP_APPLY (proc
, SCM_EOL
);
4055 if (scm_is_null (SCM_CDR (x
))) {
4058 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4059 switch (SCM_TYP7 (proc
))
4060 { /* no arguments given */
4061 case scm_tc7_subr_0
:
4062 RETURN (SCM_SUBRF (proc
) ());
4063 case scm_tc7_subr_1o
:
4064 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
4066 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
4067 case scm_tc7_rpsubr
:
4068 RETURN (SCM_BOOL_T
);
4070 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
4072 if (!SCM_SMOB_APPLICABLE_P (proc
))
4074 RETURN (SCM_SMOB_APPLY_0 (proc
));
4077 proc
= SCM_CCLO_SUBR (proc
);
4079 debug
.info
->a
.proc
= proc
;
4080 debug
.info
->a
.args
= scm_list_1 (arg1
);
4084 proc
= SCM_PROCEDURE (proc
);
4086 debug
.info
->a
.proc
= proc
;
4088 if (!SCM_CLOSUREP (proc
))
4091 case scm_tcs_closures
:
4093 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4094 if (scm_is_pair (formals
))
4096 x
= SCM_CLOSURE_BODY (proc
);
4097 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
4098 goto nontoplevel_begin
;
4100 case scm_tcs_struct
:
4101 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4103 x
= SCM_ENTITY_PROCEDURE (proc
);
4107 else if (SCM_I_OPERATORP (proc
))
4110 proc
= (SCM_I_ENTITYP (proc
)
4111 ? SCM_ENTITY_PROCEDURE (proc
)
4112 : SCM_OPERATOR_PROCEDURE (proc
));
4114 debug
.info
->a
.proc
= proc
;
4115 debug
.info
->a
.args
= scm_list_1 (arg1
);
4121 case scm_tc7_subr_1
:
4122 case scm_tc7_subr_2
:
4123 case scm_tc7_subr_2o
:
4126 case scm_tc7_subr_3
:
4127 case scm_tc7_lsubr_2
:
4129 scm_wrong_num_args (proc
);
4132 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
4136 /* must handle macros by here */
4138 if (scm_is_pair (x
))
4139 arg1
= EVALCAR (x
, env
);
4141 scm_wrong_num_args (proc
);
4143 debug
.info
->a
.args
= scm_list_1 (arg1
);
4148 if (scm_is_null (x
))
4151 evap1
: /* inputs: proc, arg1 */
4152 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4153 switch (SCM_TYP7 (proc
))
4154 { /* have one argument in arg1 */
4155 case scm_tc7_subr_2o
:
4156 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4157 case scm_tc7_subr_1
:
4158 case scm_tc7_subr_1o
:
4159 RETURN (SCM_SUBRF (proc
) (arg1
));
4161 if (SCM_I_INUMP (arg1
))
4163 RETURN (scm_from_double (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
))));
4165 else if (SCM_REALP (arg1
))
4167 RETURN (scm_from_double (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4169 else if (SCM_BIGP (arg1
))
4171 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4173 else if (SCM_FRACTIONP (arg1
))
4175 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4177 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4179 scm_i_symbol_chars (SCM_SNAME (proc
)));
4181 RETURN (scm_i_chase_pairs (arg1
, (scm_t_bits
) SCM_SUBRF (proc
)));
4182 case scm_tc7_rpsubr
:
4183 RETURN (SCM_BOOL_T
);
4185 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4188 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4190 RETURN (SCM_SUBRF (proc
) (scm_list_1 (arg1
)));
4193 if (!SCM_SMOB_APPLICABLE_P (proc
))
4195 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
4199 proc
= SCM_CCLO_SUBR (proc
);
4201 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
4202 debug
.info
->a
.proc
= proc
;
4206 proc
= SCM_PROCEDURE (proc
);
4208 debug
.info
->a
.proc
= proc
;
4210 if (!SCM_CLOSUREP (proc
))
4213 case scm_tcs_closures
:
4216 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4217 if (scm_is_null (formals
)
4218 || (scm_is_pair (formals
) && scm_is_pair (SCM_CDR (formals
))))
4220 x
= SCM_CLOSURE_BODY (proc
);
4222 env
= SCM_EXTEND_ENV (formals
,
4226 env
= SCM_EXTEND_ENV (formals
,
4230 goto nontoplevel_begin
;
4232 case scm_tcs_struct
:
4233 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4235 x
= SCM_ENTITY_PROCEDURE (proc
);
4237 arg1
= debug
.info
->a
.args
;
4239 arg1
= scm_list_1 (arg1
);
4243 else if (SCM_I_OPERATORP (proc
))
4247 proc
= (SCM_I_ENTITYP (proc
)
4248 ? SCM_ENTITY_PROCEDURE (proc
)
4249 : SCM_OPERATOR_PROCEDURE (proc
));
4251 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
4252 debug
.info
->a
.proc
= proc
;
4258 case scm_tc7_subr_2
:
4259 case scm_tc7_subr_0
:
4260 case scm_tc7_subr_3
:
4261 case scm_tc7_lsubr_2
:
4262 scm_wrong_num_args (proc
);
4267 if (scm_is_pair (x
))
4268 arg2
= EVALCAR (x
, env
);
4270 scm_wrong_num_args (proc
);
4272 { /* have two or more arguments */
4274 debug
.info
->a
.args
= scm_list_2 (arg1
, arg2
);
4277 if (scm_is_null (x
)) {
4280 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4281 switch (SCM_TYP7 (proc
))
4282 { /* have two arguments */
4283 case scm_tc7_subr_2
:
4284 case scm_tc7_subr_2o
:
4285 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
4288 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4290 RETURN (SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
)));
4292 case scm_tc7_lsubr_2
:
4293 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
));
4294 case scm_tc7_rpsubr
:
4296 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
4298 if (!SCM_SMOB_APPLICABLE_P (proc
))
4300 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
));
4304 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
4305 scm_cons (proc
, debug
.info
->a
.args
),
4308 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
4309 scm_cons2 (proc
, arg1
,
4316 case scm_tcs_struct
:
4317 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4319 x
= SCM_ENTITY_PROCEDURE (proc
);
4321 arg1
= debug
.info
->a
.args
;
4323 arg1
= scm_list_2 (arg1
, arg2
);
4327 else if (SCM_I_OPERATORP (proc
))
4331 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
4332 ? SCM_ENTITY_PROCEDURE (proc
)
4333 : SCM_OPERATOR_PROCEDURE (proc
),
4334 scm_cons (proc
, debug
.info
->a
.args
),
4337 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
4338 ? SCM_ENTITY_PROCEDURE (proc
)
4339 : SCM_OPERATOR_PROCEDURE (proc
),
4340 scm_cons2 (proc
, arg1
,
4350 case scm_tc7_subr_0
:
4353 case scm_tc7_subr_1o
:
4354 case scm_tc7_subr_1
:
4355 case scm_tc7_subr_3
:
4356 scm_wrong_num_args (proc
);
4360 proc
= SCM_PROCEDURE (proc
);
4362 debug
.info
->a
.proc
= proc
;
4364 if (!SCM_CLOSUREP (proc
))
4367 case scm_tcs_closures
:
4370 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4371 if (scm_is_null (formals
)
4372 || (scm_is_pair (formals
)
4373 && (scm_is_null (SCM_CDR (formals
))
4374 || (scm_is_pair (SCM_CDR (formals
))
4375 && scm_is_pair (SCM_CDDR (formals
))))))
4378 env
= SCM_EXTEND_ENV (formals
,
4382 env
= SCM_EXTEND_ENV (formals
,
4383 scm_list_2 (arg1
, arg2
),
4386 x
= SCM_CLOSURE_BODY (proc
);
4387 goto nontoplevel_begin
;
4391 if (!scm_is_pair (x
))
4392 scm_wrong_num_args (proc
);
4394 debug
.info
->a
.args
= scm_cons2 (arg1
, arg2
,
4395 deval_args (x
, env
, proc
,
4396 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
4400 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4401 switch (SCM_TYP7 (proc
))
4402 { /* have 3 or more arguments */
4404 case scm_tc7_subr_3
:
4405 if (!scm_is_null (SCM_CDR (x
)))
4406 scm_wrong_num_args (proc
);
4408 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4409 SCM_CADDR (debug
.info
->a
.args
)));
4411 arg1
= SCM_SUBRF(proc
)(arg1
, arg2
);
4412 arg2
= SCM_CDDR (debug
.info
->a
.args
);
4415 arg1
= SCM_SUBRF(proc
)(arg1
, SCM_CAR (arg2
));
4416 arg2
= SCM_CDR (arg2
);
4418 while (SCM_NIMP (arg2
));
4420 case scm_tc7_rpsubr
:
4421 if (scm_is_false (SCM_SUBRF (proc
) (arg1
, arg2
)))
4422 RETURN (SCM_BOOL_F
);
4423 arg1
= SCM_CDDR (debug
.info
->a
.args
);
4426 if (scm_is_false (SCM_SUBRF (proc
) (arg2
, SCM_CAR (arg1
))))
4427 RETURN (SCM_BOOL_F
);
4428 arg2
= SCM_CAR (arg1
);
4429 arg1
= SCM_CDR (arg1
);
4431 while (SCM_NIMP (arg1
));
4432 RETURN (SCM_BOOL_T
);
4433 case scm_tc7_lsubr_2
:
4434 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4435 SCM_CDDR (debug
.info
->a
.args
)));
4437 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4439 if (!SCM_SMOB_APPLICABLE_P (proc
))
4441 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4442 SCM_CDDR (debug
.info
->a
.args
)));
4446 proc
= SCM_PROCEDURE (proc
);
4447 debug
.info
->a
.proc
= proc
;
4448 if (!SCM_CLOSUREP (proc
))
4451 case scm_tcs_closures
:
4453 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4454 if (scm_is_null (formals
)
4455 || (scm_is_pair (formals
)
4456 && (scm_is_null (SCM_CDR (formals
))
4457 || (scm_is_pair (SCM_CDR (formals
))
4458 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4460 SCM_SET_ARGSREADY (debug
);
4461 env
= SCM_EXTEND_ENV (formals
,
4464 x
= SCM_CLOSURE_BODY (proc
);
4465 goto nontoplevel_begin
;
4468 case scm_tc7_subr_3
:
4469 if (!scm_is_null (SCM_CDR (x
)))
4470 scm_wrong_num_args (proc
);
4472 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, EVALCAR (x
, env
)));
4474 arg1
= SCM_SUBRF (proc
) (arg1
, arg2
);
4477 arg1
= SCM_SUBRF(proc
)(arg1
, EVALCAR(x
, env
));
4480 while (!scm_is_null (x
));
4482 case scm_tc7_rpsubr
:
4483 if (scm_is_false (SCM_SUBRF (proc
) (arg1
, arg2
)))
4484 RETURN (SCM_BOOL_F
);
4487 arg1
= EVALCAR (x
, env
);
4488 if (scm_is_false (SCM_SUBRF (proc
) (arg2
, arg1
)))
4489 RETURN (SCM_BOOL_F
);
4493 while (!scm_is_null (x
));
4494 RETURN (SCM_BOOL_T
);
4495 case scm_tc7_lsubr_2
:
4496 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
4498 RETURN (SCM_SUBRF (proc
) (scm_cons2 (arg1
,
4500 scm_eval_args (x
, env
, proc
))));
4502 if (!SCM_SMOB_APPLICABLE_P (proc
))
4504 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4505 scm_eval_args (x
, env
, proc
)));
4509 proc
= SCM_PROCEDURE (proc
);
4510 if (!SCM_CLOSUREP (proc
))
4513 case scm_tcs_closures
:
4515 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4516 if (scm_is_null (formals
)
4517 || (scm_is_pair (formals
)
4518 && (scm_is_null (SCM_CDR (formals
))
4519 || (scm_is_pair (SCM_CDR (formals
))
4520 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4522 env
= SCM_EXTEND_ENV (formals
,
4525 scm_eval_args (x
, env
, proc
)),
4527 x
= SCM_CLOSURE_BODY (proc
);
4528 goto nontoplevel_begin
;
4531 case scm_tcs_struct
:
4532 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4535 arg1
= debug
.info
->a
.args
;
4537 arg1
= scm_cons2 (arg1
, arg2
, scm_eval_args (x
, env
, proc
));
4539 x
= SCM_ENTITY_PROCEDURE (proc
);
4542 else if (SCM_I_OPERATORP (proc
))
4546 case scm_tc7_subr_2
:
4547 case scm_tc7_subr_1o
:
4548 case scm_tc7_subr_2o
:
4549 case scm_tc7_subr_0
:
4552 case scm_tc7_subr_1
:
4553 scm_wrong_num_args (proc
);
4561 if (scm_check_exit_p
&& SCM_TRAPS_P
)
4562 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
4564 SCM_CLEAR_TRACED_FRAME (debug
);
4565 if (SCM_CHEAPTRAPS_P
)
4566 arg1
= scm_make_debugobj (&debug
);
4570 SCM val
= scm_make_continuation (&first
);
4581 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
4585 scm_last_debug_frame
= debug
.prev
;
4591 /* SECTION: This code is compiled once.
4598 /* Simple procedure calls
4602 scm_call_0 (SCM proc
)
4604 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
4608 scm_call_1 (SCM proc
, SCM arg1
)
4610 return scm_apply (proc
, arg1
, scm_listofnull
);
4614 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
4616 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
4620 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
4622 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
4626 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
4628 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
4629 scm_cons (arg4
, scm_listofnull
)));
4632 /* Simple procedure applies
4636 scm_apply_0 (SCM proc
, SCM args
)
4638 return scm_apply (proc
, args
, SCM_EOL
);
4642 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
4644 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
4648 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
4650 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
4654 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
4656 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
4660 /* This code processes the arguments to apply:
4662 (apply PROC ARG1 ... ARGS)
4664 Given a list (ARG1 ... ARGS), this function conses the ARG1
4665 ... arguments onto the front of ARGS, and returns the resulting
4666 list. Note that ARGS is a list; thus, the argument to this
4667 function is a list whose last element is a list.
4669 Apply calls this function, and applies PROC to the elements of the
4670 result. apply:nconc2last takes care of building the list of
4671 arguments, given (ARG1 ... ARGS).
4673 Rather than do new consing, apply:nconc2last destroys its argument.
4674 On that topic, this code came into my care with the following
4675 beautifully cryptic comment on that topic: "This will only screw
4676 you if you do (scm_apply scm_apply '( ... ))" If you know what
4677 they're referring to, send me a patch to this comment. */
4679 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
4681 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
4682 "conses the @var{arg1} @dots{} arguments onto the front of\n"
4683 "@var{args}, and returns the resulting list. Note that\n"
4684 "@var{args} is a list; thus, the argument to this function is\n"
4685 "a list whose last element is a list.\n"
4686 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
4687 "destroys its argument, so use with care.")
4688 #define FUNC_NAME s_scm_nconc2last
4691 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
4693 while (!scm_is_null (SCM_CDR (*lloc
))) /* Perhaps should be
4694 SCM_NULL_OR_NIL_P, but not
4695 needed in 99.99% of cases,
4696 and it could seriously hurt
4697 performance. - Neil */
4698 lloc
= SCM_CDRLOC (*lloc
);
4699 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
4700 *lloc
= SCM_CAR (*lloc
);
4708 /* SECTION: When DEVAL is defined this code yields scm_dapply.
4709 * It is compiled twice.
4714 scm_apply (SCM proc
, SCM arg1
, SCM args
)
4720 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
4725 /* Apply a function to a list of arguments.
4727 This function is exported to the Scheme level as taking two
4728 required arguments and a tail argument, as if it were:
4729 (lambda (proc arg1 . args) ...)
4730 Thus, if you just have a list of arguments to pass to a procedure,
4731 pass the list as ARG1, and '() for ARGS. If you have some fixed
4732 args, pass the first as ARG1, then cons any remaining fixed args
4733 onto the front of your argument list, and pass that as ARGS. */
4736 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
4739 scm_t_debug_frame debug
;
4740 scm_t_debug_info debug_vect_body
;
4741 debug
.prev
= scm_last_debug_frame
;
4742 debug
.status
= SCM_APPLYFRAME
;
4743 debug
.vect
= &debug_vect_body
;
4744 debug
.vect
[0].a
.proc
= proc
;
4745 debug
.vect
[0].a
.args
= SCM_EOL
;
4746 scm_last_debug_frame
= &debug
;
4748 if (scm_debug_mode_p
)
4749 return scm_dapply (proc
, arg1
, args
);
4752 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
4754 /* If ARGS is the empty list, then we're calling apply with only two
4755 arguments --- ARG1 is the list of arguments for PROC. Whatever
4756 the case, futz with things so that ARG1 is the first argument to
4757 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
4760 Setting the debug apply frame args this way is pretty messy.
4761 Perhaps we should store arg1 and args directly in the frame as
4762 received, and let scm_frame_arguments unpack them, because that's
4763 a relatively rare operation. This works for now; if the Guile
4764 developer archives are still around, see Mikael's post of
4766 if (scm_is_null (args
))
4768 if (scm_is_null (arg1
))
4770 arg1
= SCM_UNDEFINED
;
4772 debug
.vect
[0].a
.args
= SCM_EOL
;
4778 debug
.vect
[0].a
.args
= arg1
;
4780 args
= SCM_CDR (arg1
);
4781 arg1
= SCM_CAR (arg1
);
4786 args
= scm_nconc2last (args
);
4788 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4792 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
4795 if (SCM_CHEAPTRAPS_P
)
4796 tmp
= scm_make_debugobj (&debug
);
4801 tmp
= scm_make_continuation (&first
);
4806 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
4813 switch (SCM_TYP7 (proc
))
4815 case scm_tc7_subr_2o
:
4816 args
= scm_is_null (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
4817 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4818 case scm_tc7_subr_2
:
4819 if (scm_is_null (args
) || !scm_is_null (SCM_CDR (args
)))
4820 scm_wrong_num_args (proc
);
4821 args
= SCM_CAR (args
);
4822 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4823 case scm_tc7_subr_0
:
4824 if (!SCM_UNBNDP (arg1
))
4825 scm_wrong_num_args (proc
);
4827 RETURN (SCM_SUBRF (proc
) ());
4828 case scm_tc7_subr_1
:
4829 if (SCM_UNBNDP (arg1
))
4830 scm_wrong_num_args (proc
);
4831 case scm_tc7_subr_1o
:
4832 if (!scm_is_null (args
))
4833 scm_wrong_num_args (proc
);
4835 RETURN (SCM_SUBRF (proc
) (arg1
));
4837 if (SCM_UNBNDP (arg1
) || !scm_is_null (args
))
4838 scm_wrong_num_args (proc
);
4839 if (SCM_I_INUMP (arg1
))
4841 RETURN (scm_from_double (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
))));
4843 else if (SCM_REALP (arg1
))
4845 RETURN (scm_from_double (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4847 else if (SCM_BIGP (arg1
))
4849 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4851 else if (SCM_FRACTIONP (arg1
))
4853 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4855 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4856 SCM_ARG1
, scm_i_symbol_chars (SCM_SNAME (proc
)));
4858 if (SCM_UNBNDP (arg1
) || !scm_is_null (args
))
4859 scm_wrong_num_args (proc
);
4860 RETURN (scm_i_chase_pairs (arg1
, (scm_t_bits
) SCM_SUBRF (proc
)));
4861 case scm_tc7_subr_3
:
4862 if (scm_is_null (args
)
4863 || scm_is_null (SCM_CDR (args
))
4864 || !scm_is_null (SCM_CDDR (args
)))
4865 scm_wrong_num_args (proc
);
4867 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
4870 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
4872 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
4874 case scm_tc7_lsubr_2
:
4875 if (!scm_is_pair (args
))
4876 scm_wrong_num_args (proc
);
4878 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4880 if (scm_is_null (args
))
4881 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4882 while (SCM_NIMP (args
))
4884 SCM_ASSERT (scm_is_pair (args
), args
, SCM_ARG2
, "apply");
4885 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
4886 args
= SCM_CDR (args
);
4889 case scm_tc7_rpsubr
:
4890 if (scm_is_null (args
))
4891 RETURN (SCM_BOOL_T
);
4892 while (SCM_NIMP (args
))
4894 SCM_ASSERT (scm_is_pair (args
), args
, SCM_ARG2
, "apply");
4895 if (scm_is_false (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
4896 RETURN (SCM_BOOL_F
);
4897 arg1
= SCM_CAR (args
);
4898 args
= SCM_CDR (args
);
4900 RETURN (SCM_BOOL_T
);
4901 case scm_tcs_closures
:
4903 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4905 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4907 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
4908 scm_wrong_num_args (proc
);
4910 /* Copy argument list */
4915 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
4916 for (arg1
= SCM_CDR (arg1
); scm_is_pair (arg1
); arg1
= SCM_CDR (arg1
))
4918 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
));
4921 SCM_SETCDR (tl
, arg1
);
4924 args
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4927 proc
= SCM_CLOSURE_BODY (proc
);
4929 arg1
= SCM_CDR (proc
);
4930 while (!scm_is_null (arg1
))
4932 if (SCM_IMP (SCM_CAR (proc
)))
4934 if (SCM_ISYMP (SCM_CAR (proc
)))
4936 scm_pthread_mutex_lock (&source_mutex
);
4937 /* check for race condition */
4938 if (SCM_ISYMP (SCM_CAR (proc
)))
4939 m_expand_body (proc
, args
);
4940 pthread_mutex_unlock (&source_mutex
);
4944 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
4947 (void) EVAL (SCM_CAR (proc
), args
);
4949 arg1
= SCM_CDR (proc
);
4951 RETURN (EVALCAR (proc
, args
));
4953 if (!SCM_SMOB_APPLICABLE_P (proc
))
4955 if (SCM_UNBNDP (arg1
))
4956 RETURN (SCM_SMOB_APPLY_0 (proc
));
4957 else if (scm_is_null (args
))
4958 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
4959 else if (scm_is_null (SCM_CDR (args
)))
4960 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
4962 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4965 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4967 proc
= SCM_CCLO_SUBR (proc
);
4968 debug
.vect
[0].a
.proc
= proc
;
4969 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4971 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4973 proc
= SCM_CCLO_SUBR (proc
);
4977 proc
= SCM_PROCEDURE (proc
);
4979 debug
.vect
[0].a
.proc
= proc
;
4982 case scm_tcs_struct
:
4983 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4986 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4988 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4990 RETURN (scm_apply_generic (proc
, args
));
4992 else if (SCM_I_OPERATORP (proc
))
4996 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4998 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
5001 proc
= (SCM_I_ENTITYP (proc
)
5002 ? SCM_ENTITY_PROCEDURE (proc
)
5003 : SCM_OPERATOR_PROCEDURE (proc
));
5005 debug
.vect
[0].a
.proc
= proc
;
5006 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
5008 if (SCM_NIMP (proc
))
5017 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
5021 if (scm_check_exit_p
&& SCM_TRAPS_P
)
5022 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
5024 SCM_CLEAR_TRACED_FRAME (debug
);
5025 if (SCM_CHEAPTRAPS_P
)
5026 arg1
= scm_make_debugobj (&debug
);
5030 SCM val
= scm_make_continuation (&first
);
5041 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
5045 scm_last_debug_frame
= debug
.prev
;
5051 /* SECTION: The rest of this file is only read once.
5058 * Trampolines make it possible to move procedure application dispatch
5059 * outside inner loops. The motivation was clean implementation of
5060 * efficient replacements of R5RS primitives in SRFI-1.
5062 * The semantics is clear: scm_trampoline_N returns an optimized
5063 * version of scm_call_N (or NULL if the procedure isn't applicable
5066 * Applying the optimization to map and for-each increased efficiency
5067 * noticeably. For example, (map abs ls) is now 8 times faster than
5072 call_subr0_0 (SCM proc
)
5074 return SCM_SUBRF (proc
) ();
5078 call_subr1o_0 (SCM proc
)
5080 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
5084 call_lsubr_0 (SCM proc
)
5086 return SCM_SUBRF (proc
) (SCM_EOL
);
5090 scm_i_call_closure_0 (SCM proc
)
5092 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
5095 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
5100 scm_trampoline_0 (SCM proc
)
5102 scm_t_trampoline_0 trampoline
;
5107 switch (SCM_TYP7 (proc
))
5109 case scm_tc7_subr_0
:
5110 trampoline
= call_subr0_0
;
5112 case scm_tc7_subr_1o
:
5113 trampoline
= call_subr1o_0
;
5116 trampoline
= call_lsubr_0
;
5118 case scm_tcs_closures
:
5120 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5121 if (scm_is_null (formals
) || !scm_is_pair (formals
))
5122 trampoline
= scm_i_call_closure_0
;
5127 case scm_tcs_struct
:
5128 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5129 trampoline
= scm_call_generic_0
;
5130 else if (SCM_I_OPERATORP (proc
))
5131 trampoline
= scm_call_0
;
5136 if (SCM_SMOB_APPLICABLE_P (proc
))
5137 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
5142 case scm_tc7_rpsubr
:
5145 trampoline
= scm_call_0
;
5148 return NULL
; /* not applicable on zero arguments */
5150 /* We only reach this point if a valid trampoline was determined. */
5152 /* If debugging is enabled, we want to see all calls to proc on the stack.
5153 * Thus, we replace the trampoline shortcut with scm_call_0. */
5154 if (scm_debug_mode_p
)
5161 call_subr1_1 (SCM proc
, SCM arg1
)
5163 return SCM_SUBRF (proc
) (arg1
);
5167 call_subr2o_1 (SCM proc
, SCM arg1
)
5169 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
5173 call_lsubr_1 (SCM proc
, SCM arg1
)
5175 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
5179 call_dsubr_1 (SCM proc
, SCM arg1
)
5181 if (SCM_I_INUMP (arg1
))
5183 RETURN (scm_from_double (SCM_DSUBRF (proc
) ((double) SCM_I_INUM (arg1
))));
5185 else if (SCM_REALP (arg1
))
5187 RETURN (scm_from_double (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
5189 else if (SCM_BIGP (arg1
))
5191 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
5193 else if (SCM_FRACTIONP (arg1
))
5195 RETURN (scm_from_double (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
5197 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
5198 SCM_ARG1
, scm_i_symbol_chars (SCM_SNAME (proc
)));
5202 call_cxr_1 (SCM proc
, SCM arg1
)
5204 return scm_i_chase_pairs (arg1
, (scm_t_bits
) SCM_SUBRF (proc
));
5208 call_closure_1 (SCM proc
, SCM arg1
)
5210 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
5213 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
5218 scm_trampoline_1 (SCM proc
)
5220 scm_t_trampoline_1 trampoline
;
5225 switch (SCM_TYP7 (proc
))
5227 case scm_tc7_subr_1
:
5228 case scm_tc7_subr_1o
:
5229 trampoline
= call_subr1_1
;
5231 case scm_tc7_subr_2o
:
5232 trampoline
= call_subr2o_1
;
5235 trampoline
= call_lsubr_1
;
5238 trampoline
= call_dsubr_1
;
5241 trampoline
= call_cxr_1
;
5243 case scm_tcs_closures
:
5245 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5246 if (!scm_is_null (formals
)
5247 && (!scm_is_pair (formals
) || !scm_is_pair (SCM_CDR (formals
))))
5248 trampoline
= call_closure_1
;
5253 case scm_tcs_struct
:
5254 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5255 trampoline
= scm_call_generic_1
;
5256 else if (SCM_I_OPERATORP (proc
))
5257 trampoline
= scm_call_1
;
5262 if (SCM_SMOB_APPLICABLE_P (proc
))
5263 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
5268 case scm_tc7_rpsubr
:
5271 trampoline
= scm_call_1
;
5274 return NULL
; /* not applicable on one arg */
5276 /* We only reach this point if a valid trampoline was determined. */
5278 /* If debugging is enabled, we want to see all calls to proc on the stack.
5279 * Thus, we replace the trampoline shortcut with scm_call_1. */
5280 if (scm_debug_mode_p
)
5287 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
5289 return SCM_SUBRF (proc
) (arg1
, arg2
);
5293 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
5295 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
5299 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
5301 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
5305 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
5307 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
5308 scm_list_2 (arg1
, arg2
),
5310 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
5315 scm_trampoline_2 (SCM proc
)
5317 scm_t_trampoline_2 trampoline
;
5322 switch (SCM_TYP7 (proc
))
5324 case scm_tc7_subr_2
:
5325 case scm_tc7_subr_2o
:
5326 case scm_tc7_rpsubr
:
5328 trampoline
= call_subr2_2
;
5330 case scm_tc7_lsubr_2
:
5331 trampoline
= call_lsubr2_2
;
5334 trampoline
= call_lsubr_2
;
5336 case scm_tcs_closures
:
5338 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5339 if (!scm_is_null (formals
)
5340 && (!scm_is_pair (formals
)
5341 || (!scm_is_null (SCM_CDR (formals
))
5342 && (!scm_is_pair (SCM_CDR (formals
))
5343 || !scm_is_pair (SCM_CDDR (formals
))))))
5344 trampoline
= call_closure_2
;
5349 case scm_tcs_struct
:
5350 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5351 trampoline
= scm_call_generic_2
;
5352 else if (SCM_I_OPERATORP (proc
))
5353 trampoline
= scm_call_2
;
5358 if (SCM_SMOB_APPLICABLE_P (proc
))
5359 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
5365 trampoline
= scm_call_2
;
5368 return NULL
; /* not applicable on two args */
5370 /* We only reach this point if a valid trampoline was determined. */
5372 /* If debugging is enabled, we want to see all calls to proc on the stack.
5373 * Thus, we replace the trampoline shortcut with scm_call_2. */
5374 if (scm_debug_mode_p
)
5380 /* Typechecking for multi-argument MAP and FOR-EACH.
5382 Verify that each element of the vector ARGV, except for the first,
5383 is a proper list whose length is LEN. Attribute errors to WHO,
5384 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
5386 check_map_args (SCM argv
,
5395 for (i
= SCM_SIMPLE_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
5397 SCM elt
= SCM_SIMPLE_VECTOR_REF (argv
, i
);
5398 long elt_len
= scm_ilength (elt
);
5403 scm_apply_generic (gf
, scm_cons (proc
, args
));
5405 scm_wrong_type_arg (who
, i
+ 2, elt
);
5409 scm_out_of_range_pos (who
, elt
, scm_from_long (i
+ 2));
5414 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
5416 /* Note: Currently, scm_map applies PROC to the argument list(s)
5417 sequentially, starting with the first element(s). This is used in
5418 evalext.c where the Scheme procedure `map-in-order', which guarantees
5419 sequential behaviour, is implemented using scm_map. If the
5420 behaviour changes, we need to update `map-in-order'.
5424 scm_map (SCM proc
, SCM arg1
, SCM args
)
5425 #define FUNC_NAME s_map
5431 len
= scm_ilength (arg1
);
5432 SCM_GASSERTn (len
>= 0,
5433 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
5434 SCM_VALIDATE_REST_ARGUMENT (args
);
5435 if (scm_is_null (args
))
5437 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5438 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
5439 while (SCM_NIMP (arg1
))
5441 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
5442 pres
= SCM_CDRLOC (*pres
);
5443 arg1
= SCM_CDR (arg1
);
5447 if (scm_is_null (SCM_CDR (args
)))
5449 SCM arg2
= SCM_CAR (args
);
5450 int len2
= scm_ilength (arg2
);
5451 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5453 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
5454 SCM_GASSERTn (len2
>= 0,
5455 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
5457 SCM_OUT_OF_RANGE (3, arg2
);
5458 while (SCM_NIMP (arg1
))
5460 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
5461 pres
= SCM_CDRLOC (*pres
);
5462 arg1
= SCM_CDR (arg1
);
5463 arg2
= SCM_CDR (arg2
);
5467 arg1
= scm_cons (arg1
, args
);
5468 args
= scm_vector (arg1
);
5469 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
5473 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5475 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
5478 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
5479 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
5481 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
5482 pres
= SCM_CDRLOC (*pres
);
5488 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
5491 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
5492 #define FUNC_NAME s_for_each
5495 len
= scm_ilength (arg1
);
5496 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
5497 SCM_ARG2
, s_for_each
);
5498 SCM_VALIDATE_REST_ARGUMENT (args
);
5499 if (scm_is_null (args
))
5501 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5502 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
5503 while (SCM_NIMP (arg1
))
5505 call (proc
, SCM_CAR (arg1
));
5506 arg1
= SCM_CDR (arg1
);
5508 return SCM_UNSPECIFIED
;
5510 if (scm_is_null (SCM_CDR (args
)))
5512 SCM arg2
= SCM_CAR (args
);
5513 int len2
= scm_ilength (arg2
);
5514 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5515 SCM_GASSERTn (call
, g_for_each
,
5516 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
5517 SCM_GASSERTn (len2
>= 0, g_for_each
,
5518 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
5520 SCM_OUT_OF_RANGE (3, arg2
);
5521 while (SCM_NIMP (arg1
))
5523 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
5524 arg1
= SCM_CDR (arg1
);
5525 arg2
= SCM_CDR (arg2
);
5527 return SCM_UNSPECIFIED
;
5529 arg1
= scm_cons (arg1
, args
);
5530 args
= scm_vector (arg1
);
5531 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
5535 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5537 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
5539 return SCM_UNSPECIFIED
;
5540 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
5541 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
5543 scm_apply (proc
, arg1
, SCM_EOL
);
5550 scm_closure (SCM code
, SCM env
)
5553 SCM closcar
= scm_cons (code
, SCM_EOL
);
5554 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
5555 scm_remember_upto_here (closcar
);
5560 scm_t_bits scm_tc16_promise
;
5563 scm_makprom (SCM code
)
5565 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
5567 scm_make_recursive_mutex ());
5571 promise_mark (SCM promise
)
5573 scm_gc_mark (SCM_PROMISE_MUTEX (promise
));
5574 return SCM_PROMISE_DATA (promise
);
5578 promise_free (SCM promise
)
5584 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
5586 int writingp
= SCM_WRITINGP (pstate
);
5587 scm_puts ("#<promise ", port
);
5588 SCM_SET_WRITINGP (pstate
, 1);
5589 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
5590 SCM_SET_WRITINGP (pstate
, writingp
);
5591 scm_putc ('>', port
);
5595 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
5597 "If the promise @var{x} has not been computed yet, compute and\n"
5598 "return @var{x}, otherwise just return the previously computed\n"
5600 #define FUNC_NAME s_scm_force
5602 SCM_VALIDATE_SMOB (1, promise
, promise
);
5603 scm_lock_mutex (SCM_PROMISE_MUTEX (promise
));
5604 if (!SCM_PROMISE_COMPUTED_P (promise
))
5606 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
5607 if (!SCM_PROMISE_COMPUTED_P (promise
))
5609 SCM_SET_PROMISE_DATA (promise
, ans
);
5610 SCM_SET_PROMISE_COMPUTED (promise
);
5613 scm_unlock_mutex (SCM_PROMISE_MUTEX (promise
));
5614 return SCM_PROMISE_DATA (promise
);
5619 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
5621 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
5622 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
5623 #define FUNC_NAME s_scm_promise_p
5625 return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
5630 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
5631 (SCM xorig
, SCM x
, SCM y
),
5632 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
5633 "Any source properties associated with @var{xorig} are also associated\n"
5634 "with the new pair.")
5635 #define FUNC_NAME s_scm_cons_source
5638 z
= scm_cons (x
, y
);
5639 /* Copy source properties possibly associated with xorig. */
5640 p
= scm_whash_lookup (scm_source_whash
, xorig
);
5641 if (scm_is_true (p
))
5642 scm_whash_insert (scm_source_whash
, z
, p
);
5648 /* The function scm_copy_tree is used to copy an expression tree to allow the
5649 * memoizer to modify the expression during memoization. scm_copy_tree
5650 * creates deep copies of pairs and vectors, but not of any other data types,
5651 * since only pairs and vectors will be parsed by the memoizer.
5653 * To avoid infinite recursion due to cyclic structures, the hare-and-tortoise
5654 * pattern is used to detect cycles. In fact, the pattern is used in two
5655 * dimensions, vertical (indicated in the code by the variable names 'hare'
5656 * and 'tortoise') and horizontal ('rabbit' and 'turtle'). In both
5657 * dimensions, the hare/rabbit will take two steps when the tortoise/turtle
5660 * The vertical dimension corresponds to recursive calls to function
5661 * copy_tree: This happens when descending into vector elements, into cars of
5662 * lists and into the cdr of an improper list. In this dimension, the
5663 * tortoise follows the hare by using the processor stack: Every stack frame
5664 * will hold an instance of struct t_trace. These instances are connected in
5665 * a way that represents the trace of the hare, which thus can be followed by
5666 * the tortoise. The tortoise will always point to struct t_trace instances
5667 * relating to SCM objects that have already been copied. Thus, a cycle is
5668 * detected if the tortoise and the hare point to the same object,
5670 * The horizontal dimension is within one execution of copy_tree, when the
5671 * function cdr's along the pairs of a list. This is the standard
5672 * hare-and-tortoise implementation, found several times in guile. */
5675 struct t_trace
*trace
; // These pointers form a trace along the stack.
5676 SCM obj
; // The object handled at the respective stack frame.
5681 struct t_trace
*const hare
,
5682 struct t_trace
*tortoise
,
5683 unsigned int tortoise_delay
)
5685 if (!scm_is_pair (hare
->obj
) && !scm_is_simple_vector (hare
->obj
))
5691 /* Prepare the trace along the stack. */
5692 struct t_trace new_hare
;
5693 hare
->trace
= &new_hare
;
5695 /* The tortoise will make its step after the delay has elapsed. Note
5696 * that in contrast to the typical hare-and-tortoise pattern, the step
5697 * of the tortoise happens before the hare takes its steps. This is, in
5698 * principle, no problem, except for the start of the algorithm: Then,
5699 * it has to be made sure that the hare actually gets its advantage of
5701 if (tortoise_delay
== 0)
5704 tortoise
= tortoise
->trace
;
5705 ASSERT_SYNTAX (!scm_is_eq (hare
->obj
, tortoise
->obj
),
5706 s_bad_expression
, hare
->obj
);
5713 if (scm_is_simple_vector (hare
->obj
))
5715 size_t length
= SCM_SIMPLE_VECTOR_LENGTH (hare
->obj
);
5716 SCM new_vector
= scm_c_make_vector (length
, SCM_UNSPECIFIED
);
5718 /* Each vector element is copied by recursing into copy_tree, having
5719 * the tortoise follow the hare into the depths of the stack. */
5720 unsigned long int i
;
5721 for (i
= 0; i
< length
; ++i
)
5724 new_hare
.obj
= SCM_SIMPLE_VECTOR_REF (hare
->obj
, i
);
5725 new_element
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5726 SCM_SIMPLE_VECTOR_SET (new_vector
, i
, new_element
);
5731 else // scm_is_pair (hare->obj)
5736 SCM rabbit
= hare
->obj
;
5737 SCM turtle
= hare
->obj
;
5741 /* The first pair of the list is treated specially, in order to
5742 * preserve a potential source code position. */
5743 result
= tail
= scm_cons_source (rabbit
, SCM_EOL
, SCM_EOL
);
5744 new_hare
.obj
= SCM_CAR (rabbit
);
5745 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5746 SCM_SETCAR (tail
, copy
);
5748 /* The remaining pairs of the list are copied by, horizontally,
5749 * having the turtle follow the rabbit, and, vertically, having the
5750 * tortoise follow the hare into the depths of the stack. */
5751 rabbit
= SCM_CDR (rabbit
);
5752 while (scm_is_pair (rabbit
))
5754 new_hare
.obj
= SCM_CAR (rabbit
);
5755 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5756 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
5757 tail
= SCM_CDR (tail
);
5759 rabbit
= SCM_CDR (rabbit
);
5760 if (scm_is_pair (rabbit
))
5762 new_hare
.obj
= SCM_CAR (rabbit
);
5763 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5764 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
5765 tail
= SCM_CDR (tail
);
5766 rabbit
= SCM_CDR (rabbit
);
5768 turtle
= SCM_CDR (turtle
);
5769 ASSERT_SYNTAX (!scm_is_eq (rabbit
, turtle
),
5770 s_bad_expression
, rabbit
);
5774 /* We have to recurse into copy_tree again for the last cdr, in
5775 * order to handle the situation that it holds a vector. */
5776 new_hare
.obj
= rabbit
;
5777 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5778 SCM_SETCDR (tail
, copy
);
5785 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
5787 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
5788 "the new data structure. @code{copy-tree} recurses down the\n"
5789 "contents of both pairs and vectors (since both cons cells and vector\n"
5790 "cells may point to arbitrary objects), and stops recursing when it hits\n"
5791 "any other object.")
5792 #define FUNC_NAME s_scm_copy_tree
5794 /* Prepare the trace along the stack. */
5795 struct t_trace trace
;
5798 /* In function copy_tree, if the tortoise makes its step, it will do this
5799 * before the hare has the chance to move. Thus, we have to make sure that
5800 * the very first step of the tortoise will not happen after the hare has
5801 * really made two steps. This is achieved by passing '2' as the initial
5802 * delay for the tortoise. NOTE: Since cycles are unlikely, giving the hare
5803 * a bigger advantage may improve performance slightly. */
5804 return copy_tree (&trace
, &trace
, 2);
5809 /* We have three levels of EVAL here:
5811 - scm_i_eval (exp, env)
5813 evaluates EXP in environment ENV. ENV is a lexical environment
5814 structure as used by the actual tree code evaluator. When ENV is
5815 a top-level environment, then changes to the current module are
5816 tracked by updating ENV so that it continues to be in sync with
5819 - scm_primitive_eval (exp)
5821 evaluates EXP in the top-level environment as determined by the
5822 current module. This is done by constructing a suitable
5823 environment and calling scm_i_eval. Thus, changes to the
5824 top-level module are tracked normally.
5826 - scm_eval (exp, mod)
5828 evaluates EXP while MOD is the current module. This is done by
5829 setting the current module to MOD, invoking scm_primitive_eval on
5830 EXP, and then restoring the current module to the value it had
5831 previously. That is, while EXP is evaluated, changes to the
5832 current module are tracked, but these changes do not persist when
5835 For each level of evals, there are two variants, distinguished by a
5836 _x suffix: the ordinary variant does not modify EXP while the _x
5837 variant can destructively modify EXP into something completely
5838 unintelligible. A Scheme data structure passed as EXP to one of the
5839 _x variants should not ever be used again for anything. So when in
5840 doubt, use the ordinary variant.
5845 scm_i_eval_x (SCM exp
, SCM env
)
5847 if (scm_is_symbol (exp
))
5848 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
5850 return SCM_I_XEVAL (exp
, env
);
5854 scm_i_eval (SCM exp
, SCM env
)
5856 exp
= scm_copy_tree (exp
);
5857 if (scm_is_symbol (exp
))
5858 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
5860 return SCM_I_XEVAL (exp
, env
);
5864 scm_primitive_eval_x (SCM exp
)
5867 SCM transformer
= scm_current_module_transformer ();
5868 if (SCM_NIMP (transformer
))
5869 exp
= scm_call_1 (transformer
, exp
);
5870 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5871 return scm_i_eval_x (exp
, env
);
5874 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
5876 "Evaluate @var{exp} in the top-level environment specified by\n"
5877 "the current module.")
5878 #define FUNC_NAME s_scm_primitive_eval
5881 SCM transformer
= scm_current_module_transformer ();
5882 if (scm_is_true (transformer
))
5883 exp
= scm_call_1 (transformer
, exp
);
5884 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5885 return scm_i_eval (exp
, env
);
5890 /* Eval does not take the second arg optionally. This is intentional
5891 * in order to be R5RS compatible, and to prepare for the new module
5892 * system, where we would like to make the choice of evaluation
5893 * environment explicit. */
5896 change_environment (void *data
)
5898 SCM pair
= SCM_PACK (data
);
5899 SCM new_module
= SCM_CAR (pair
);
5900 SCM old_module
= scm_current_module ();
5901 SCM_SETCDR (pair
, old_module
);
5902 scm_set_current_module (new_module
);
5906 restore_environment (void *data
)
5908 SCM pair
= SCM_PACK (data
);
5909 SCM old_module
= SCM_CDR (pair
);
5910 SCM new_module
= scm_current_module ();
5911 SCM_SETCAR (pair
, new_module
);
5912 scm_set_current_module (old_module
);
5916 inner_eval_x (void *data
)
5918 return scm_primitive_eval_x (SCM_PACK(data
));
5922 scm_eval_x (SCM exp
, SCM module
)
5923 #define FUNC_NAME "eval!"
5925 SCM_VALIDATE_MODULE (2, module
);
5927 return scm_internal_dynamic_wind
5928 (change_environment
, inner_eval_x
, restore_environment
,
5929 (void *) SCM_UNPACK (exp
),
5930 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
5935 inner_eval (void *data
)
5937 return scm_primitive_eval (SCM_PACK(data
));
5940 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
5941 (SCM exp
, SCM module
),
5942 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
5943 "in the top-level environment specified by @var{module}.\n"
5944 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
5945 "@var{module} is made the current module. The current module\n"
5946 "is reset to its previous value when @var{eval} returns.\n"
5947 "Example: (eval '(+ 1 2) (interaction-environment))")
5948 #define FUNC_NAME s_scm_eval
5950 SCM_VALIDATE_MODULE (2, module
);
5952 return scm_internal_dynamic_wind
5953 (change_environment
, inner_eval
, restore_environment
,
5954 (void *) SCM_UNPACK (exp
),
5955 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
5960 /* At this point, deval and scm_dapply are generated.
5967 #if (SCM_ENABLE_DEPRECATED == 1)
5969 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5970 SCM
scm_ceval (SCM x
, SCM env
)
5972 if (scm_is_pair (x
))
5973 return ceval (x
, env
);
5974 else if (scm_is_symbol (x
))
5975 return *scm_lookupcar (scm_cons (x
, SCM_UNDEFINED
), env
, 1);
5977 return SCM_I_XEVAL (x
, env
);
5980 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5981 SCM
scm_deval (SCM x
, SCM env
)
5983 if (scm_is_pair (x
))
5984 return deval (x
, env
);
5985 else if (scm_is_symbol (x
))
5986 return *scm_lookupcar (scm_cons (x
, SCM_UNDEFINED
), env
, 1);
5988 return SCM_I_XEVAL (x
, env
);
5992 dispatching_eval (SCM x
, SCM env
)
5994 if (scm_debug_mode_p
)
5995 return scm_deval (x
, env
);
5997 return scm_ceval (x
, env
);
6000 /* Deprecated in guile 1.7.0 on 2004-03-29. */
6001 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
) = dispatching_eval
;
6009 scm_init_opts (scm_evaluator_traps
,
6010 scm_evaluator_trap_table
,
6011 SCM_N_EVALUATOR_TRAPS
);
6012 scm_init_opts (scm_eval_options_interface
,
6014 SCM_N_EVAL_OPTIONS
);
6016 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
6017 scm_set_smob_mark (scm_tc16_promise
, promise_mark
);
6018 scm_set_smob_free (scm_tc16_promise
, promise_free
);
6019 scm_set_smob_print (scm_tc16_promise
, promise_print
);
6021 undefineds
= scm_list_1 (SCM_UNDEFINED
);
6022 SCM_SETCDR (undefineds
, undefineds
);
6023 scm_permanent_object (undefineds
);
6025 scm_listofnull
= scm_list_1 (SCM_EOL
);
6027 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
6028 scm_permanent_object (f_apply
);
6030 #include "libguile/eval.x"
6032 scm_add_feature ("delay");