1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004
2 * Free Software Foundation, Inc.
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public
6 * License as published by the Free Software Foundation; either
7 * version 2.1 of the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
21 /* This file is read twice in order to produce debugging versions of ceval and
22 * scm_apply. These functions, deval and scm_dapply, are produced when we
23 * define the preprocessor macro DEVAL. The file is divided into sections
24 * which are treated differently with respect to DEVAL. The heads of these
25 * sections are marked with the string "SECTION:". */
27 /* SECTION: This code is compiled once.
34 #include "libguile/__scm.h"
38 /* AIX requires this to be the first thing in the file. The #pragma
39 directive is indented so pre-ANSI compilers will ignore it, rather
48 # ifndef alloca /* predefined by HP cc +Olibcalls */
55 #include "libguile/_scm.h"
56 #include "libguile/alist.h"
57 #include "libguile/async.h"
58 #include "libguile/continuations.h"
59 #include "libguile/debug.h"
60 #include "libguile/deprecation.h"
61 #include "libguile/dynwind.h"
62 #include "libguile/eq.h"
63 #include "libguile/feature.h"
64 #include "libguile/fluids.h"
65 #include "libguile/futures.h"
66 #include "libguile/goops.h"
67 #include "libguile/hash.h"
68 #include "libguile/hashtab.h"
69 #include "libguile/lang.h"
70 #include "libguile/list.h"
71 #include "libguile/macros.h"
72 #include "libguile/modules.h"
73 #include "libguile/objects.h"
74 #include "libguile/ports.h"
75 #include "libguile/print.h"
76 #include "libguile/procprop.h"
77 #include "libguile/root.h"
78 #include "libguile/smob.h"
79 #include "libguile/srcprop.h"
80 #include "libguile/stackchk.h"
81 #include "libguile/strings.h"
82 #include "libguile/throw.h"
83 #include "libguile/validate.h"
84 #include "libguile/values.h"
85 #include "libguile/vectors.h"
87 #include "libguile/eval.h"
91 static SCM
canonicalize_define (SCM expr
);
97 * This section defines the message strings for the syntax errors that can be
98 * detected during memoization and the functions and macros that shall be
99 * called by the memoizer code to signal syntax errors. */
102 /* Syntax errors that can be detected during memoization: */
104 /* Circular or improper lists do not form valid scheme expressions. If a
105 * circular list or an improper list is detected in a place where a scheme
106 * expression is expected, a 'Bad expression' error is signalled. */
107 static const char s_bad_expression
[] = "Bad expression";
109 /* If a form is detected that holds a different number of expressions than are
110 * required in that context, a 'Missing or extra expression' error is
112 static const char s_expression
[] = "Missing or extra expression in";
114 /* If a form is detected that holds less expressions than are required in that
115 * context, a 'Missing expression' error is signalled. */
116 static const char s_missing_expression
[] = "Missing expression in";
118 /* If a form is detected that holds more expressions than are allowed in that
119 * context, an 'Extra expression' error is signalled. */
120 static const char s_extra_expression
[] = "Extra expression in";
122 /* The empty combination '()' is not allowed as an expression in scheme. If
123 * it is detected in a place where an expression is expected, an 'Illegal
124 * empty combination' error is signalled. Note: If you encounter this error
125 * message, it is very likely that you intended to denote the empty list. To
126 * do so, you need to quote the empty list like (quote ()) or '(). */
127 static const char s_empty_combination
[] = "Illegal empty combination";
129 /* A body may hold an arbitrary number of internal defines, followed by a
130 * non-empty sequence of expressions. If a body with an empty sequence of
131 * expressions is detected, a 'Missing body expression' error is signalled.
133 static const char s_missing_body_expression
[] = "Missing body expression in";
135 /* A body may hold an arbitrary number of internal defines, followed by a
136 * non-empty sequence of expressions. Each the definitions and the
137 * expressions may be grouped arbitraryly with begin, but it is not allowed to
138 * mix definitions and expressions. If a define form in a body mixes
139 * definitions and expressions, a 'Mixed definitions and expressions' error is
141 static const char s_mixed_body_forms
[] = "Mixed definitions and expressions in";
142 /* Definitions are only allowed on the top level and at the start of a body.
143 * If a definition is detected anywhere else, a 'Bad define placement' error
145 static const char s_bad_define
[] = "Bad define placement";
147 /* If a macro keyword is detected in a place where macro keywords are not
148 * allowed, a 'Misplaced syntactic keyword' error is signalled. */
149 static const char s_macro_keyword
[] = "Misplaced syntactic keyword";
151 /* Case or cond expressions must have at least one clause. If a case or cond
152 * expression without any clauses is detected, a 'Missing clauses' error is
154 static const char s_missing_clauses
[] = "Missing clauses";
156 /* If there is an 'else' clause in a case or a cond statement, it must be the
157 * last clause. If after the 'else' case clause further clauses are detected,
158 * a 'Misplaced else clause' error is signalled. */
159 static const char s_misplaced_else_clause
[] = "Misplaced else clause";
161 /* If a case clause is detected that is not in the format
162 * (<label(s)> <expression1> <expression2> ...)
163 * a 'Bad case clause' error is signalled. */
164 static const char s_bad_case_clause
[] = "Bad case clause";
166 /* If a case clause is detected where the <label(s)> element is neither a
167 * proper list nor (in case of the last clause) the syntactic keyword 'else',
168 * a 'Bad case labels' error is signalled. Note: If you encounter this error
169 * for an else-clause which seems to be syntactically correct, check if 'else'
170 * is really a syntactic keyword in that context. If 'else' is bound in the
171 * local or global environment, it is not considered a syntactic keyword, but
172 * will be treated as any other variable. */
173 static const char s_bad_case_labels
[] = "Bad case labels";
175 /* In a case statement all labels have to be distinct. If in a case statement
176 * a label occurs more than once, a 'Duplicate case label' error is
178 static const char s_duplicate_case_label
[] = "Duplicate case label";
180 /* If a cond clause is detected that is not in one of the formats
181 * (<test> <expression1> ...) or (else <expression1> <expression2> ...)
182 * a 'Bad cond clause' error is signalled. */
183 static const char s_bad_cond_clause
[] = "Bad cond clause";
185 /* If a cond clause is detected that uses the alternate '=>' form, but does
186 * not hold a recipient element for the test result, a 'Missing recipient'
187 * error is signalled. */
188 static const char s_missing_recipient
[] = "Missing recipient in";
190 /* If in a position where a variable name is required some other object is
191 * detected, a 'Bad variable' error is signalled. */
192 static const char s_bad_variable
[] = "Bad variable";
194 /* Bindings for forms like 'let' and 'do' have to be given in a proper,
195 * possibly empty list. If any other object is detected in a place where a
196 * list of bindings was required, a 'Bad bindings' error is signalled. */
197 static const char s_bad_bindings
[] = "Bad bindings";
199 /* Depending on the syntactic context, a binding has to be in the format
200 * (<variable> <expression>) or (<variable> <expression1> <expression2>).
201 * If anything else is detected in a place where a binding was expected, a
202 * 'Bad binding' error is signalled. */
203 static const char s_bad_binding
[] = "Bad binding";
205 /* Some syntactic forms don't allow variable names to appear more than once in
206 * a list of bindings. If such a situation is nevertheless detected, a
207 * 'Duplicate binding' error is signalled. */
208 static const char s_duplicate_binding
[] = "Duplicate binding";
210 /* If the exit form of a 'do' expression is not in the format
211 * (<test> <expression> ...)
212 * a 'Bad exit clause' error is signalled. */
213 static const char s_bad_exit_clause
[] = "Bad exit clause";
215 /* The formal function arguments of a lambda expression have to be either a
216 * single symbol or a non-cyclic list. For anything else a 'Bad formals'
217 * error is signalled. */
218 static const char s_bad_formals
[] = "Bad formals";
220 /* If in a lambda expression something else than a symbol is detected at a
221 * place where a formal function argument is required, a 'Bad formal' error is
223 static const char s_bad_formal
[] = "Bad formal";
225 /* If in the arguments list of a lambda expression an argument name occurs
226 * more than once, a 'Duplicate formal' error is signalled. */
227 static const char s_duplicate_formal
[] = "Duplicate formal";
229 /* If the evaluation of an unquote-splicing expression gives something else
230 * than a proper list, a 'Non-list result for unquote-splicing' error is
232 static const char s_splicing
[] = "Non-list result for unquote-splicing";
234 /* If something else than an exact integer is detected as the argument for
235 * @slot-ref and @slot-set!, a 'Bad slot number' error is signalled. */
236 static const char s_bad_slot_number
[] = "Bad slot number";
239 /* Signal a syntax error. We distinguish between the form that caused the
240 * error and the enclosing expression. The error message will print out as
241 * shown in the following pattern. The file name and line number are only
242 * given when they can be determined from the erroneous form or from the
243 * enclosing expression.
245 * <filename>: In procedure memoization:
246 * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
248 SCM_SYMBOL (syntax_error_key
, "syntax-error");
250 /* The prototype is needed to indicate that the function does not return. */
252 syntax_error (const char* const, const SCM
, const SCM
) SCM_NORETURN
;
255 syntax_error (const char* const msg
, const SCM form
, const SCM expr
)
257 const SCM msg_string
= scm_makfrom0str (msg
);
258 SCM filename
= SCM_BOOL_F
;
259 SCM linenr
= SCM_BOOL_F
;
263 if (SCM_CONSP (form
))
265 filename
= scm_source_property (form
, scm_sym_filename
);
266 linenr
= scm_source_property (form
, scm_sym_line
);
269 if (SCM_FALSEP (filename
) && SCM_FALSEP (linenr
) && SCM_CONSP (expr
))
271 filename
= scm_source_property (expr
, scm_sym_filename
);
272 linenr
= scm_source_property (expr
, scm_sym_line
);
275 if (!SCM_UNBNDP (expr
))
277 if (!SCM_FALSEP (filename
))
279 format
= "In file ~S, line ~S: ~A ~S in expression ~S.";
280 args
= scm_list_5 (filename
, linenr
, msg_string
, form
, expr
);
282 else if (!SCM_FALSEP (linenr
))
284 format
= "In line ~S: ~A ~S in expression ~S.";
285 args
= scm_list_4 (linenr
, msg_string
, form
, expr
);
289 format
= "~A ~S in expression ~S.";
290 args
= scm_list_3 (msg_string
, form
, expr
);
295 if (!SCM_FALSEP (filename
))
297 format
= "In file ~S, line ~S: ~A ~S.";
298 args
= scm_list_4 (filename
, linenr
, msg_string
, form
);
300 else if (!SCM_FALSEP (linenr
))
302 format
= "In line ~S: ~A ~S.";
303 args
= scm_list_3 (linenr
, msg_string
, form
);
308 args
= scm_list_2 (msg_string
, form
);
312 scm_error (syntax_error_key
, "memoization", format
, args
, SCM_BOOL_F
);
316 /* Shortcut macros to simplify syntax error handling. */
317 #define ASSERT_SYNTAX(cond, message, form) \
318 { if (!(cond)) syntax_error (message, form, SCM_UNDEFINED); }
319 #define ASSERT_SYNTAX_2(cond, message, form, expr) \
320 { if (!(cond)) syntax_error (message, form, expr); }
326 * Ilocs are memoized references to variables in local environment frames.
327 * They are represented as three values: The relative offset of the
328 * environment frame, the number of the binding within that frame, and a
329 * boolean value indicating whether the binding is the last binding in the
333 #define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc)
334 #define SCM_IFRINC (0x00000100L)
335 #define SCM_ICDR (0x00080000L)
336 #define SCM_IDINC (0x00100000L)
337 #define SCM_IFRAME(n) ((long)((SCM_ICDR-SCM_IFRINC)>>8) \
338 & (SCM_UNPACK (n) >> 8))
339 #define SCM_IDIST(n) (SCM_UNPACK (n) >> 20)
340 #define SCM_ICDRP(n) (SCM_ICDR & SCM_UNPACK (n))
341 #define SCM_IDSTMSK (-SCM_IDINC)
342 #define SCM_MAKE_ILOC(frame_nr, binding_nr, last_p) \
345 + ((binding_nr) << 20) \
346 + ((last_p) ? SCM_ICDR : 0) \
350 scm_i_print_iloc (SCM iloc
, SCM port
)
352 scm_puts ("#@", port
);
353 scm_intprint ((long) SCM_IFRAME (iloc
), 10, port
);
354 scm_putc (SCM_ICDRP (iloc
) ? '-' : '+', port
);
355 scm_intprint ((long) SCM_IDIST (iloc
), 10, port
);
358 #if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
360 SCM
scm_dbg_make_iloc (SCM frame
, SCM binding
, SCM cdrp
);
361 SCM_DEFINE (scm_dbg_make_iloc
, "dbg-make-iloc", 3, 0, 0,
362 (SCM frame
, SCM binding
, SCM cdrp
),
363 "Return a new iloc with frame offset @var{frame}, binding\n"
364 "offset @var{binding} and the cdr flag @var{cdrp}.")
365 #define FUNC_NAME s_scm_dbg_make_iloc
367 SCM_VALIDATE_INUM (1, frame
);
368 SCM_VALIDATE_INUM (2, binding
);
369 return SCM_MAKE_ILOC (SCM_INUM (frame
),
375 SCM
scm_dbg_iloc_p (SCM obj
);
376 SCM_DEFINE (scm_dbg_iloc_p
, "dbg-iloc?", 1, 0, 0,
378 "Return @code{#t} if @var{obj} is an iloc.")
379 #define FUNC_NAME s_scm_dbg_iloc_p
381 return SCM_BOOL (SCM_ILOCP (obj
));
389 /* {Evaluator byte codes (isyms)}
392 #define ISYMNUM(n) (SCM_ITAG8_DATA (n))
394 /* This table must agree with the list of SCM_IM_ constants in tags.h */
395 static const char *const isymnames
[] =
412 "#@call-with-current-continuation",
418 "#@call-with-values",
426 scm_i_print_isym (SCM isym
, SCM port
)
428 const size_t isymnum
= ISYMNUM (isym
);
429 if (isymnum
< (sizeof isymnames
/ sizeof (char *)))
430 scm_puts (isymnames
[isymnum
], port
);
432 scm_ipruk ("isym", isym
, port
);
437 /* The function lookup_symbol is used during memoization: Lookup the symbol
438 * in the environment. If there is no binding for the symbol, SCM_UNDEFINED
439 * is returned. If the symbol is a syntactic keyword, the macro object to
440 * which the symbol is bound is returned. If the symbol is a global variable,
441 * the variable object to which the symbol is bound is returned. Finally, if
442 * the symbol is a local variable the corresponding iloc object is returned.
445 /* A helper function for lookup_symbol: Try to find the symbol in the top
446 * level environment frame. The function returns SCM_UNDEFINED if the symbol
447 * is unbound, it returns a macro object if the symbol is a syntactic keyword
448 * and it returns a variable object if the symbol is a global variable. */
450 lookup_global_symbol (const SCM symbol
, const SCM top_level
)
452 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
453 if (SCM_FALSEP (variable
))
455 return SCM_UNDEFINED
;
459 const SCM value
= SCM_VARIABLE_REF (variable
);
460 if (SCM_MACROP (value
))
468 lookup_symbol (const SCM symbol
, const SCM env
)
471 unsigned int frame_nr
;
473 for (frame_idx
= env
, frame_nr
= 0;
474 !SCM_NULLP (frame_idx
);
475 frame_idx
= SCM_CDR (frame_idx
), ++frame_nr
)
477 const SCM frame
= SCM_CAR (frame_idx
);
478 if (SCM_CONSP (frame
))
480 /* frame holds a local environment frame */
482 unsigned int symbol_nr
;
484 for (symbol_idx
= SCM_CAR (frame
), symbol_nr
= 0;
485 SCM_CONSP (symbol_idx
);
486 symbol_idx
= SCM_CDR (symbol_idx
), ++symbol_nr
)
488 if (SCM_EQ_P (SCM_CAR (symbol_idx
), symbol
))
489 /* found the symbol, therefore return the iloc */
490 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 0);
492 if (SCM_EQ_P (symbol_idx
, symbol
))
493 /* found the symbol as the last element of the current frame */
494 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 1);
498 /* no more local environment frames */
499 return lookup_global_symbol (symbol
, frame
);
503 return lookup_global_symbol (symbol
, SCM_BOOL_F
);
507 /* Return true if the symbol is - from the point of view of a macro
508 * transformer - a literal in the sense specified in chapter "pattern
509 * language" of R5RS. In the code below, however, we don't match the
510 * definition of R5RS exactly: It returns true if the identifier has no
511 * binding or if it is a syntactic keyword. */
513 literal_p (const SCM symbol
, const SCM env
)
515 const SCM value
= lookup_symbol (symbol
, env
);
516 if (SCM_UNBNDP (value
) || SCM_MACROP (value
))
523 /* Return true if the expression is self-quoting in the memoized code. Thus,
524 * some other objects (like e. g. vectors) are reported as self-quoting, which
525 * according to R5RS would need to be quoted. */
527 is_self_quoting_p (const SCM expr
)
529 if (SCM_CONSP (expr
))
531 else if (SCM_SYMBOLP (expr
))
533 else if (SCM_NULLP (expr
))
540 /* Lookup a given local variable in an environment. The local variable is
541 * given as an iloc, that is a triple <frame, binding, last?>, where frame
542 * indicates the relative number of the environment frame (counting upwards
543 * from the innermost environment frame), binding indicates the number of the
544 * binding within the frame, and last? (which is extracted from the iloc using
545 * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
546 * very end of the improper list of bindings. */
548 scm_ilookup (SCM iloc
, SCM env
)
550 unsigned int frame_nr
= SCM_IFRAME (iloc
);
551 unsigned int binding_nr
= SCM_IDIST (iloc
);
555 for (; 0 != frame_nr
; --frame_nr
)
556 frames
= SCM_CDR (frames
);
558 bindings
= SCM_CAR (frames
);
559 for (; 0 != binding_nr
; --binding_nr
)
560 bindings
= SCM_CDR (bindings
);
562 if (SCM_ICDRP (iloc
))
563 return SCM_CDRLOC (bindings
);
564 return SCM_CARLOC (SCM_CDR (bindings
));
568 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
570 static void error_unbound_variable (SCM symbol
) SCM_NORETURN
;
572 error_unbound_variable (SCM symbol
)
574 scm_error (scm_unbound_variable_key
, NULL
,
575 "Unbound variable: ~S",
576 scm_list_1 (symbol
), SCM_BOOL_F
);
580 /* The Lookup Car Race
583 Memoization of variables and special forms is done while executing
584 the code for the first time. As long as there is only one thread
585 everything is fine, but as soon as two threads execute the same
586 code concurrently `for the first time' they can come into conflict.
588 This memoization includes rewriting variable references into more
589 efficient forms and expanding macros. Furthermore, macro expansion
590 includes `compiling' special forms like `let', `cond', etc. into
591 tree-code instructions.
593 There shouldn't normally be a problem with memoizing local and
594 global variable references (into ilocs and variables), because all
595 threads will mutate the code in *exactly* the same way and (if I
596 read the C code correctly) it is not possible to observe a half-way
597 mutated cons cell. The lookup procedure can handle this
598 transparently without any critical sections.
600 It is different with macro expansion, because macro expansion
601 happens outside of the lookup procedure and can't be
602 undone. Therefore the lookup procedure can't cope with it. It has
603 to indicate failure when it detects a lost race and hope that the
604 caller can handle it. Luckily, it turns out that this is the case.
606 An example to illustrate this: Suppose that the following form will
607 be memoized concurrently by two threads
611 Let's first examine the lookup of X in the body. The first thread
612 decides that it has to find the symbol "x" in the environment and
613 starts to scan it. Then the other thread takes over and actually
614 overtakes the first. It looks up "x" and substitutes an
615 appropriate iloc for it. Now the first thread continues and
616 completes its lookup. It comes to exactly the same conclusions as
617 the second one and could - without much ado - just overwrite the
618 iloc with the same iloc.
620 But let's see what will happen when the race occurs while looking
621 up the symbol "let" at the start of the form. It could happen that
622 the second thread interrupts the lookup of the first thread and not
623 only substitutes a variable for it but goes right ahead and
624 replaces it with the compiled form (#@let* (x 12) x). Now, when
625 the first thread completes its lookup, it would replace the #@let*
626 with a variable containing the "let" binding, effectively reverting
627 the form to (let (x 12) x). This is wrong. It has to detect that
628 it has lost the race and the evaluator has to reconsider the
629 changed form completely.
631 This race condition could be resolved with some kind of traffic
632 light (like mutexes) around scm_lookupcar, but I think that it is
633 best to avoid them in this case. They would serialize memoization
634 completely and because lookup involves calling arbitrary Scheme
635 code (via the lookup-thunk), threads could be blocked for an
636 arbitrary amount of time or even deadlock. But with the current
637 solution a lot of unnecessary work is potentially done. */
639 /* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
640 return NULL to indicate a failed lookup due to some race conditions
641 between threads. This only happens when VLOC is the first cell of
642 a special form that will eventually be memoized (like `let', etc.)
643 In that case the whole lookup is bogus and the caller has to
644 reconsider the complete special form.
646 SCM_LOOKUPCAR is still there, of course. It just calls
647 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
648 should only be called when it is known that VLOC is not the first
649 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
650 for NULL. I think I've found the only places where this
654 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
657 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
658 register SCM iloc
= SCM_ILOC00
;
659 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
661 if (!SCM_CONSP (SCM_CAR (env
)))
663 al
= SCM_CARLOC (env
);
664 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
668 if (SCM_EQ_P (fl
, var
))
670 if (! SCM_EQ_P (SCM_CAR (vloc
), var
))
672 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
673 return SCM_CDRLOC (*al
);
678 al
= SCM_CDRLOC (*al
);
679 if (SCM_EQ_P (SCM_CAR (fl
), var
))
681 if (SCM_UNBNDP (SCM_CAR (*al
)))
686 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
688 SCM_SETCAR (vloc
, iloc
);
689 return SCM_CARLOC (*al
);
691 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
693 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
696 SCM top_thunk
, real_var
;
699 top_thunk
= SCM_CAR (env
); /* env now refers to a
700 top level env thunk */
704 top_thunk
= SCM_BOOL_F
;
705 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
706 if (SCM_FALSEP (real_var
))
709 if (!SCM_NULLP (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
715 error_unbound_variable (var
);
717 scm_misc_error (NULL
, "Damaged environment: ~S",
722 /* A variable could not be found, but we shall
723 not throw an error. */
724 static SCM undef_object
= SCM_UNDEFINED
;
725 return &undef_object
;
729 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
731 /* Some other thread has changed the very cell we are working
732 on. In effect, it must have done our job or messed it up
735 var
= SCM_CAR (vloc
);
736 if (SCM_VARIABLEP (var
))
737 return SCM_VARIABLE_LOC (var
);
739 return scm_ilookup (var
, genv
);
740 /* We can't cope with anything else than variables and ilocs. When
741 a special form has been memoized (i.e. `let' into `#@let') we
742 return NULL and expect the calling function to do the right
743 thing. For the evaluator, this means going back and redoing
744 the dispatch on the car of the form. */
748 SCM_SETCAR (vloc
, real_var
);
749 return SCM_VARIABLE_LOC (real_var
);
754 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
756 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
764 /* Rewrite the body (which is given as the list of expressions forming the
765 * body) into its internal form. The internal form of a body (<expr> ...) is
766 * just the body itself, but prefixed with an ISYM that denotes to what kind
767 * of outer construct this body belongs: (<ISYM> <expr> ...). A lambda body
768 * starts with SCM_IM_LAMBDA, for example, a body of a let starts with
771 * It is assumed that the calling expression has already made sure that the
772 * body is a proper list. */
774 m_body (SCM op
, SCM exprs
)
776 /* Don't add another ISYM if one is present already. */
777 if (SCM_ISYMP (SCM_CAR (exprs
)))
780 return scm_cons (op
, exprs
);
784 /* The function m_expand_body memoizes a proper list of expressions
785 * forming a body. This function takes care of dealing with internal
786 * defines and transforming them into an equivalent letrec expression.
787 * The list of expressions is rewritten in place. */
789 /* This is a helper function for m_expand_body. It helps to figure out whether
790 * an expression denotes a syntactic keyword. */
792 try_macro_lookup (const SCM expr
, const SCM env
)
794 if (SCM_SYMBOLP (expr
))
796 const SCM value
= lookup_symbol (expr
, env
);
801 return SCM_UNDEFINED
;
805 /* This is a helper function for m_expand_body. It expands user macros,
806 * because for the correct translation of a body we need to know whether they
807 * expand to a definition. */
809 expand_user_macros (SCM expr
, const SCM env
)
811 while (SCM_CONSP (expr
))
813 const SCM car_expr
= SCM_CAR (expr
);
814 const SCM new_car
= expand_user_macros (car_expr
, env
);
815 const SCM value
= try_macro_lookup (new_car
, env
);
817 if (SCM_MACROP (value
) && SCM_MACRO_TYPE (value
) == 2)
819 /* User macros transform code into code. */
820 expr
= scm_call_2 (SCM_MACRO_CODE (value
), expr
, env
);
821 /* We need to reiterate on the transformed code. */
825 /* No user macro: return. */
826 SCM_SETCAR (expr
, new_car
);
834 /* This is a helper function for m_expand_body. It determines if a given form
835 * represents an application of a given built-in macro. The built-in macro to
836 * check for is identified by its syntactic keyword. The form is an
837 * application of the given macro if looking up the car of the form in the
838 * given environment actually returns the built-in macro. */
840 is_system_macro_p (const SCM syntactic_keyword
, const SCM form
, const SCM env
)
842 if (SCM_CONSP (form
))
844 const SCM car_form
= SCM_CAR (form
);
845 const SCM value
= try_macro_lookup (car_form
, env
);
846 if (SCM_BUILTIN_MACRO_P (value
))
848 const SCM macro_name
= scm_macro_name (value
);
849 return SCM_EQ_P (macro_name
, syntactic_keyword
);
857 m_expand_body (const SCM forms
, const SCM env
)
859 /* The first body form can be skipped since it is known to be the ISYM that
860 * was prepended to the body by m_body. */
861 SCM cdr_forms
= SCM_CDR (forms
);
862 SCM form_idx
= cdr_forms
;
863 SCM definitions
= SCM_EOL
;
864 SCM sequence
= SCM_EOL
;
866 /* According to R5RS, the list of body forms consists of two parts: a number
867 * (maybe zero) of definitions, followed by a non-empty sequence of
868 * expressions. Each the definitions and the expressions may be grouped
869 * arbitrarily with begin, but it is not allowed to mix definitions and
870 * expressions. The task of the following loop therefore is to split the
871 * list of body forms into the list of definitions and the sequence of
873 while (!SCM_NULLP (form_idx
))
875 const SCM form
= SCM_CAR (form_idx
);
876 const SCM new_form
= expand_user_macros (form
, env
);
877 if (is_system_macro_p (scm_sym_define
, new_form
, env
))
879 definitions
= scm_cons (new_form
, definitions
);
880 form_idx
= SCM_CDR (form_idx
);
882 else if (is_system_macro_p (scm_sym_begin
, new_form
, env
))
884 /* We have encountered a group of forms. This has to be either a
885 * (possibly empty) group of (possibly further grouped) definitions,
886 * or a non-empty group of (possibly further grouped)
888 const SCM grouped_forms
= SCM_CDR (new_form
);
889 unsigned int found_definition
= 0;
890 unsigned int found_expression
= 0;
891 SCM grouped_form_idx
= grouped_forms
;
892 while (!found_expression
&& !SCM_NULLP (grouped_form_idx
))
894 const SCM inner_form
= SCM_CAR (grouped_form_idx
);
895 const SCM new_inner_form
= expand_user_macros (inner_form
, env
);
896 if (is_system_macro_p (scm_sym_define
, new_inner_form
, env
))
898 found_definition
= 1;
899 definitions
= scm_cons (new_inner_form
, definitions
);
900 grouped_form_idx
= SCM_CDR (grouped_form_idx
);
902 else if (is_system_macro_p (scm_sym_begin
, new_inner_form
, env
))
904 const SCM inner_group
= SCM_CDR (new_inner_form
);
906 = scm_append (scm_list_2 (inner_group
,
907 SCM_CDR (grouped_form_idx
)));
911 /* The group marks the start of the expressions of the body.
912 * We have to make sure that within the same group we have
913 * not encountered a definition before. */
914 ASSERT_SYNTAX (!found_definition
, s_mixed_body_forms
, form
);
915 found_expression
= 1;
916 grouped_form_idx
= SCM_EOL
;
920 /* We have finished processing the group. If we have not yet
921 * encountered an expression we continue processing the forms of the
922 * body to collect further definition forms. Otherwise, the group
923 * marks the start of the sequence of expressions of the body. */
924 if (!found_expression
)
926 form_idx
= SCM_CDR (form_idx
);
936 /* We have detected a form which is no definition. This marks the
937 * start of the sequence of expressions of the body. */
943 /* FIXME: forms does not hold information about the file location. */
944 ASSERT_SYNTAX (SCM_CONSP (sequence
), s_missing_body_expression
, cdr_forms
);
946 if (!SCM_NULLP (definitions
))
950 SCM letrec_expression
;
951 SCM new_letrec_expression
;
953 SCM bindings
= SCM_EOL
;
954 for (definition_idx
= definitions
;
955 !SCM_NULLP (definition_idx
);
956 definition_idx
= SCM_CDR (definition_idx
))
958 const SCM definition
= SCM_CAR (definition_idx
);
959 const SCM canonical_definition
= canonicalize_define (definition
);
960 const SCM binding
= SCM_CDR (canonical_definition
);
961 bindings
= scm_cons (binding
, bindings
);
964 letrec_tail
= scm_cons (bindings
, sequence
);
965 /* FIXME: forms does not hold information about the file location. */
966 letrec_expression
= scm_cons_source (forms
, scm_sym_letrec
, letrec_tail
);
967 new_letrec_expression
= scm_m_letrec (letrec_expression
, env
);
968 SCM_SETCAR (forms
, new_letrec_expression
);
969 SCM_SETCDR (forms
, SCM_EOL
);
973 SCM_SETCAR (forms
, SCM_CAR (sequence
));
974 SCM_SETCDR (forms
, SCM_CDR (sequence
));
979 /* Start of the memoizers for the standard R5RS builtin macros. */
982 SCM_SYNTAX (s_and
, "and", scm_i_makbimacro
, scm_m_and
);
983 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
986 scm_m_and (SCM expr
, SCM env SCM_UNUSED
)
988 const SCM cdr_expr
= SCM_CDR (expr
);
989 const long length
= scm_ilength (cdr_expr
);
991 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
995 /* Special case: (and) is replaced by #t. */
1000 SCM_SETCAR (expr
, SCM_IM_AND
);
1006 SCM_SYNTAX (s_begin
, "begin", scm_i_makbimacro
, scm_m_begin
);
1007 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
1010 scm_m_begin (SCM expr
, SCM env SCM_UNUSED
)
1012 const SCM cdr_expr
= SCM_CDR (expr
);
1013 /* Dirk:FIXME:: An empty begin clause is not generally allowed by R5RS.
1014 * That means, there should be a distinction between uses of begin where an
1015 * empty clause is OK and where it is not. */
1016 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1018 SCM_SETCAR (expr
, SCM_IM_BEGIN
);
1023 SCM_SYNTAX (s_case
, "case", scm_i_makbimacro
, scm_m_case
);
1024 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
1025 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
1028 scm_m_case (SCM expr
, SCM env
)
1031 SCM all_labels
= SCM_EOL
;
1033 /* Check, whether 'else is a literal, i. e. not bound to a value. */
1034 const int else_literal_p
= literal_p (scm_sym_else
, env
);
1036 const SCM cdr_expr
= SCM_CDR (expr
);
1037 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1038 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_clauses
, expr
);
1040 clauses
= SCM_CDR (cdr_expr
);
1041 while (!SCM_NULLP (clauses
))
1045 const SCM clause
= SCM_CAR (clauses
);
1046 ASSERT_SYNTAX_2 (scm_ilength (clause
) >= 2,
1047 s_bad_case_clause
, clause
, expr
);
1049 labels
= SCM_CAR (clause
);
1050 if (SCM_CONSP (labels
))
1052 ASSERT_SYNTAX_2 (scm_ilength (labels
) >= 0,
1053 s_bad_case_labels
, labels
, expr
);
1054 all_labels
= scm_append_x (scm_list_2 (labels
, all_labels
));
1056 else if (SCM_NULLP (labels
))
1058 /* The list of labels is empty. According to R5RS this is allowed.
1059 * It means that the sequence of expressions will never be executed.
1060 * Therefore, as an optimization, we could remove the whole
1065 ASSERT_SYNTAX_2 (SCM_EQ_P (labels
, scm_sym_else
) && else_literal_p
,
1066 s_bad_case_labels
, labels
, expr
);
1067 ASSERT_SYNTAX_2 (SCM_NULLP (SCM_CDR (clauses
)),
1068 s_misplaced_else_clause
, clause
, expr
);
1071 /* build the new clause */
1072 if (SCM_EQ_P (labels
, scm_sym_else
))
1073 SCM_SETCAR (clause
, SCM_IM_ELSE
);
1075 clauses
= SCM_CDR (clauses
);
1078 /* Check whether all case labels are distinct. */
1079 for (; !SCM_NULLP (all_labels
); all_labels
= SCM_CDR (all_labels
))
1081 const SCM label
= SCM_CAR (all_labels
);
1082 ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (label
, SCM_CDR (all_labels
))),
1083 s_duplicate_case_label
, label
, expr
);
1086 SCM_SETCAR (expr
, SCM_IM_CASE
);
1091 SCM_SYNTAX (s_cond
, "cond", scm_i_makbimacro
, scm_m_cond
);
1092 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
1093 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
1096 scm_m_cond (SCM expr
, SCM env
)
1098 /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
1099 const int else_literal_p
= literal_p (scm_sym_else
, env
);
1100 const int arrow_literal_p
= literal_p (scm_sym_arrow
, env
);
1102 const SCM clauses
= SCM_CDR (expr
);
1105 ASSERT_SYNTAX (scm_ilength (clauses
) >= 0, s_bad_expression
, expr
);
1106 ASSERT_SYNTAX (scm_ilength (clauses
) >= 1, s_missing_clauses
, expr
);
1108 for (clause_idx
= clauses
;
1109 !SCM_NULLP (clause_idx
);
1110 clause_idx
= SCM_CDR (clause_idx
))
1114 const SCM clause
= SCM_CAR (clause_idx
);
1115 const long length
= scm_ilength (clause
);
1116 ASSERT_SYNTAX_2 (length
>= 1, s_bad_cond_clause
, clause
, expr
);
1118 test
= SCM_CAR (clause
);
1119 if (SCM_EQ_P (test
, scm_sym_else
) && else_literal_p
)
1121 const int last_clause_p
= SCM_NULLP (SCM_CDR (clause_idx
));
1122 ASSERT_SYNTAX_2 (length
>= 2,
1123 s_bad_cond_clause
, clause
, expr
);
1124 ASSERT_SYNTAX_2 (last_clause_p
,
1125 s_misplaced_else_clause
, clause
, expr
);
1126 SCM_SETCAR (clause
, SCM_IM_ELSE
);
1128 else if (length
>= 2
1129 && SCM_EQ_P (SCM_CADR (clause
), scm_sym_arrow
)
1132 ASSERT_SYNTAX_2 (length
> 2, s_missing_recipient
, clause
, expr
);
1133 ASSERT_SYNTAX_2 (length
== 3, s_extra_expression
, clause
, expr
);
1134 SCM_SETCAR (SCM_CDR (clause
), SCM_IM_ARROW
);
1138 SCM_SETCAR (expr
, SCM_IM_COND
);
1143 SCM_SYNTAX (s_define
, "define", scm_i_makbimacro
, scm_m_define
);
1144 SCM_GLOBAL_SYMBOL (scm_sym_define
, s_define
);
1146 /* Guile provides an extension to R5RS' define syntax to represent function
1147 * currying in a compact way. With this extension, it is allowed to write
1148 * (define <nested-variable> <body>), where <nested-variable> has of one of
1149 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
1150 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
1151 * should be either a sequence of zero or more variables, or a sequence of one
1152 * or more variables followed by a space-delimited period and another
1153 * variable. Each level of argument nesting wraps the <body> within another
1154 * lambda expression. For example, the following forms are allowed, each one
1155 * followed by an equivalent, more explicit implementation.
1157 * (define ((a b . c) . d) <body>) is equivalent to
1158 * (define a (lambda (b . c) (lambda d <body>)))
1160 * (define (((a) b) c . d) <body>) is equivalent to
1161 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
1163 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
1164 * module that does not implement this extension. */
1166 canonicalize_define (const SCM expr
)
1171 const SCM cdr_expr
= SCM_CDR (expr
);
1172 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1173 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1175 body
= SCM_CDR (cdr_expr
);
1176 variable
= SCM_CAR (cdr_expr
);
1177 while (SCM_CONSP (variable
))
1179 /* This while loop realizes function currying by variable nesting.
1180 * Variable is known to be a nested-variable. In every iteration of the
1181 * loop another level of lambda expression is created, starting with the
1182 * innermost one. Note that we don't check for duplicate formals here:
1183 * This will be done by the memoizer of the lambda expression. */
1184 const SCM formals
= SCM_CDR (variable
);
1185 const SCM tail
= scm_cons (formals
, body
);
1187 /* Add source properties to each new lambda expression: */
1188 const SCM lambda
= scm_cons_source (variable
, scm_sym_lambda
, tail
);
1190 body
= scm_list_1 (lambda
);
1191 variable
= SCM_CAR (variable
);
1193 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
), s_bad_variable
, variable
, expr
);
1194 ASSERT_SYNTAX (scm_ilength (body
) == 1, s_expression
, expr
);
1196 SCM_SETCAR (cdr_expr
, variable
);
1197 SCM_SETCDR (cdr_expr
, body
);
1201 /* According to section 5.2.1 of R5RS we first have to make sure that the
1202 * variable is bound, and then perform the (set! variable expression)
1203 * operation. This means, that within the expression we may already assign
1204 * values to variable: (define foo (begin (set! foo 1) (+ foo 1))) */
1206 scm_m_define (SCM expr
, SCM env
)
1208 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), s_bad_define
, expr
);
1211 const SCM canonical_definition
= canonicalize_define (expr
);
1212 const SCM cdr_canonical_definition
= SCM_CDR (canonical_definition
);
1213 const SCM variable
= SCM_CAR (cdr_canonical_definition
);
1215 = scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_T
);
1216 const SCM value
= scm_eval_car (SCM_CDR (cdr_canonical_definition
), env
);
1218 if (SCM_REC_PROCNAMES_P
)
1221 while (SCM_MACROP (tmp
))
1222 tmp
= SCM_MACRO_CODE (tmp
);
1223 if (SCM_CLOSUREP (tmp
)
1224 /* Only the first definition determines the name. */
1225 && SCM_FALSEP (scm_procedure_property (tmp
, scm_sym_name
)))
1226 scm_set_procedure_property_x (tmp
, scm_sym_name
, variable
);
1229 SCM_VARIABLE_SET (location
, value
);
1231 return SCM_UNSPECIFIED
;
1236 /* This is a helper function for forms (<keyword> <expression>) that are
1237 * transformed into (#@<keyword> '() <memoized_expression>) in order to allow
1238 * for easy creation of a thunk (i. e. a closure without arguments) using the
1239 * ('() <memoized_expression>) tail of the memoized form. */
1241 memoize_as_thunk_prototype (const SCM expr
, const SCM env SCM_UNUSED
)
1243 const SCM cdr_expr
= SCM_CDR (expr
);
1244 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1245 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1247 SCM_SETCDR (expr
, scm_cons (SCM_EOL
, cdr_expr
));
1253 SCM_SYNTAX (s_delay
, "delay", scm_i_makbimacro
, scm_m_delay
);
1254 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
1256 /* Promises are implemented as closures with an empty parameter list. Thus,
1257 * (delay <expression>) is transformed into (#@delay '() <expression>), where
1258 * the empty list represents the empty parameter list. This representation
1259 * allows for easy creation of the closure during evaluation. */
1261 scm_m_delay (SCM expr
, SCM env
)
1263 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1264 SCM_SETCAR (new_expr
, SCM_IM_DELAY
);
1269 SCM_SYNTAX(s_do
, "do", scm_i_makbimacro
, scm_m_do
);
1270 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
1272 /* DO gets the most radically altered syntax. The order of the vars is
1273 * reversed here. During the evaluation this allows for simple consing of the
1274 * results of the inits and steps:
1276 (do ((<var1> <init1> <step1>)
1284 (#@do (<init1> <init2> ... <initn>)
1285 (varn ... var2 var1)
1288 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
1291 scm_m_do (SCM expr
, SCM env SCM_UNUSED
)
1293 SCM variables
= SCM_EOL
;
1294 SCM init_forms
= SCM_EOL
;
1295 SCM step_forms
= SCM_EOL
;
1302 const SCM cdr_expr
= SCM_CDR (expr
);
1303 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1304 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1306 /* Collect variables, init and step forms. */
1307 binding_idx
= SCM_CAR (cdr_expr
);
1308 ASSERT_SYNTAX_2 (scm_ilength (binding_idx
) >= 0,
1309 s_bad_bindings
, binding_idx
, expr
);
1310 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1312 const SCM binding
= SCM_CAR (binding_idx
);
1313 const long length
= scm_ilength (binding
);
1314 ASSERT_SYNTAX_2 (length
== 2 || length
== 3,
1315 s_bad_binding
, binding
, expr
);
1318 const SCM name
= SCM_CAR (binding
);
1319 const SCM init
= SCM_CADR (binding
);
1320 const SCM step
= (length
== 2) ? name
: SCM_CADDR (binding
);
1321 ASSERT_SYNTAX_2 (SCM_SYMBOLP (name
), s_bad_variable
, name
, expr
);
1322 ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (name
, variables
)),
1323 s_duplicate_binding
, name
, expr
);
1325 variables
= scm_cons (name
, variables
);
1326 init_forms
= scm_cons (init
, init_forms
);
1327 step_forms
= scm_cons (step
, step_forms
);
1330 init_forms
= scm_reverse_x (init_forms
, SCM_UNDEFINED
);
1331 step_forms
= scm_reverse_x (step_forms
, SCM_UNDEFINED
);
1333 /* Memoize the test form and the exit sequence. */
1334 cddr_expr
= SCM_CDR (cdr_expr
);
1335 exit_clause
= SCM_CAR (cddr_expr
);
1336 ASSERT_SYNTAX_2 (scm_ilength (exit_clause
) >= 1,
1337 s_bad_exit_clause
, exit_clause
, expr
);
1339 commands
= SCM_CDR (cddr_expr
);
1340 tail
= scm_cons2 (exit_clause
, commands
, step_forms
);
1341 tail
= scm_cons2 (init_forms
, variables
, tail
);
1342 SCM_SETCAR (expr
, SCM_IM_DO
);
1343 SCM_SETCDR (expr
, tail
);
1348 SCM_SYNTAX (s_if
, "if", scm_i_makbimacro
, scm_m_if
);
1349 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
1352 scm_m_if (SCM expr
, SCM env SCM_UNUSED
)
1354 const SCM cdr_expr
= SCM_CDR (expr
);
1355 const long length
= scm_ilength (cdr_expr
);
1356 ASSERT_SYNTAX (length
== 2 || length
== 3, s_expression
, expr
);
1357 SCM_SETCAR (expr
, SCM_IM_IF
);
1362 SCM_SYNTAX (s_lambda
, "lambda", scm_i_makbimacro
, scm_m_lambda
);
1363 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
1365 /* A helper function for memoize_lambda to support checking for duplicate
1366 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
1367 * LIST or to the cdr of the last cons. Therefore, LIST may have any of the
1368 * forms that a formal argument can have:
1369 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
1371 c_improper_memq (SCM obj
, SCM list
)
1373 for (; SCM_CONSP (list
); list
= SCM_CDR (list
))
1375 if (SCM_EQ_P (SCM_CAR (list
), obj
))
1378 return SCM_EQ_P (list
, obj
);
1382 scm_m_lambda (SCM expr
, SCM env SCM_UNUSED
)
1391 const SCM cdr_expr
= SCM_CDR (expr
);
1392 const long length
= scm_ilength (cdr_expr
);
1393 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1394 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1396 /* Before iterating the list of formal arguments, make sure the formals
1397 * actually are given as either a symbol or a non-cyclic list. */
1398 formals
= SCM_CAR (cdr_expr
);
1399 if (SCM_CONSP (formals
))
1401 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
1402 * detected, report a 'Bad formals' error. */
1406 ASSERT_SYNTAX_2 (SCM_SYMBOLP (formals
) || SCM_NULLP (formals
),
1407 s_bad_formals
, formals
, expr
);
1410 /* Now iterate the list of formal arguments to check if all formals are
1411 * symbols, and that there are no duplicates. */
1412 formals_idx
= formals
;
1413 while (SCM_CONSP (formals_idx
))
1415 const SCM formal
= SCM_CAR (formals_idx
);
1416 const SCM next_idx
= SCM_CDR (formals_idx
);
1417 ASSERT_SYNTAX_2 (SCM_SYMBOLP (formal
), s_bad_formal
, formal
, expr
);
1418 ASSERT_SYNTAX_2 (!c_improper_memq (formal
, next_idx
),
1419 s_duplicate_formal
, formal
, expr
);
1420 formals_idx
= next_idx
;
1422 ASSERT_SYNTAX_2 (SCM_NULLP (formals_idx
) || SCM_SYMBOLP (formals_idx
),
1423 s_bad_formal
, formals_idx
, expr
);
1425 /* Memoize the body. Keep a potential documentation string. */
1426 /* Dirk:FIXME:: We should probably extract the documentation string to
1427 * some external database. Otherwise it will slow down execution, since
1428 * the documentation string will have to be skipped with every execution
1429 * of the closure. */
1430 cddr_expr
= SCM_CDR (cdr_expr
);
1431 documentation
= (length
>= 3 && SCM_STRINGP (SCM_CAR (cddr_expr
)));
1432 body
= documentation
? SCM_CDR (cddr_expr
) : cddr_expr
;
1433 new_body
= m_body (SCM_IM_LAMBDA
, body
);
1435 SCM_SETCAR (expr
, SCM_IM_LAMBDA
);
1437 SCM_SETCDR (cddr_expr
, new_body
);
1439 SCM_SETCDR (cdr_expr
, new_body
);
1444 /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
1446 check_bindings (const SCM bindings
, const SCM expr
)
1450 ASSERT_SYNTAX_2 (scm_ilength (bindings
) >= 0,
1451 s_bad_bindings
, bindings
, expr
);
1453 binding_idx
= bindings
;
1454 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1456 SCM name
; /* const */
1458 const SCM binding
= SCM_CAR (binding_idx
);
1459 ASSERT_SYNTAX_2 (scm_ilength (binding
) == 2,
1460 s_bad_binding
, binding
, expr
);
1462 name
= SCM_CAR (binding
);
1463 ASSERT_SYNTAX_2 (SCM_SYMBOLP (name
), s_bad_variable
, name
, expr
);
1468 /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
1469 * transformed to the lists (vn ... v2 v1) and (i1 i2 ... in). That is, the
1470 * variables are returned in a list with their order reversed, and the init
1471 * forms are returned in a list in the same order as they are given in the
1472 * bindings. If a duplicate variable name is detected, an error is
1475 transform_bindings (
1476 const SCM bindings
, const SCM expr
,
1477 SCM
*const rvarptr
, SCM
*const initptr
)
1479 SCM rvariables
= SCM_EOL
;
1480 SCM rinits
= SCM_EOL
;
1481 SCM binding_idx
= bindings
;
1482 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1484 const SCM binding
= SCM_CAR (binding_idx
);
1485 const SCM cdr_binding
= SCM_CDR (binding
);
1486 const SCM name
= SCM_CAR (binding
);
1487 ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (name
, rvariables
)),
1488 s_duplicate_binding
, name
, expr
);
1489 rvariables
= scm_cons (name
, rvariables
);
1490 rinits
= scm_cons (SCM_CAR (cdr_binding
), rinits
);
1492 *rvarptr
= rvariables
;
1493 *initptr
= scm_reverse_x (rinits
, SCM_UNDEFINED
);
1497 SCM_SYNTAX(s_let
, "let", scm_i_makbimacro
, scm_m_let
);
1498 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
1500 /* This function is a helper function for memoize_let. It transforms
1501 * (let name ((var init) ...) body ...) into
1502 * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
1503 * and memoizes the expression. It is assumed that the caller has checked
1504 * that name is a symbol and that there are bindings and a body. */
1506 memoize_named_let (const SCM expr
, const SCM env SCM_UNUSED
)
1512 const SCM cdr_expr
= SCM_CDR (expr
);
1513 const SCM name
= SCM_CAR (cdr_expr
);
1514 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1515 const SCM bindings
= SCM_CAR (cddr_expr
);
1516 check_bindings (bindings
, expr
);
1518 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1519 variables
= scm_reverse_x (rvariables
, SCM_UNDEFINED
);
1522 const SCM let_body
= SCM_CDR (cddr_expr
);
1523 const SCM lambda_body
= m_body (SCM_IM_LET
, let_body
);
1524 const SCM lambda_tail
= scm_cons (variables
, lambda_body
);
1525 const SCM lambda_form
= scm_cons_source (expr
, scm_sym_lambda
, lambda_tail
);
1527 const SCM rvar
= scm_list_1 (name
);
1528 const SCM init
= scm_list_1 (lambda_form
);
1529 const SCM body
= m_body (SCM_IM_LET
, scm_list_1 (name
));
1530 const SCM letrec_tail
= scm_cons (rvar
, scm_cons (init
, body
));
1531 const SCM letrec_form
= scm_cons_source (expr
, SCM_IM_LETREC
, letrec_tail
);
1532 return scm_cons_source (expr
, letrec_form
, inits
);
1536 /* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1537 * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
1539 scm_m_let (SCM expr
, SCM env
)
1543 const SCM cdr_expr
= SCM_CDR (expr
);
1544 const long length
= scm_ilength (cdr_expr
);
1545 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1546 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1548 bindings
= SCM_CAR (cdr_expr
);
1549 if (SCM_SYMBOLP (bindings
))
1551 ASSERT_SYNTAX (length
>= 3, s_missing_expression
, expr
);
1552 return memoize_named_let (expr
, env
);
1555 check_bindings (bindings
, expr
);
1556 if (SCM_NULLP (bindings
) || SCM_NULLP (SCM_CDR (bindings
)))
1558 /* Special case: no bindings or single binding => let* is faster. */
1559 const SCM body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1560 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), bindings
, body
), env
);
1567 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1570 const SCM new_body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1571 const SCM new_tail
= scm_cons2 (rvariables
, inits
, new_body
);
1572 SCM_SETCAR (expr
, SCM_IM_LET
);
1573 SCM_SETCDR (expr
, new_tail
);
1580 SCM_SYNTAX (s_letstar
, "let*", scm_i_makbimacro
, scm_m_letstar
);
1581 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
1583 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1584 * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
1586 scm_m_letstar (SCM expr
, SCM env SCM_UNUSED
)
1591 const SCM cdr_expr
= SCM_CDR (expr
);
1592 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1593 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1595 binding_idx
= SCM_CAR (cdr_expr
);
1596 check_bindings (binding_idx
, expr
);
1598 /* Transform ((v1 i1) (v2 i2) ...) into (v1 i1 v2 i2 ...). The
1599 * transformation is done in place. At the beginning of one iteration of
1600 * the loop the variable binding_idx holds the form
1601 * P1:( (vn . P2:(in . ())) . P3:( (vn+1 in+1) ... ) ),
1602 * where P1, P2 and P3 indicate the pairs, that are relevant for the
1603 * transformation. P1 and P2 are modified in the loop, P3 remains
1604 * untouched. After the execution of the loop, P1 will hold
1605 * P1:( vn . P2:(in . P3:( (vn+1 in+1) ... )) )
1606 * and binding_idx will hold P3. */
1607 while (!SCM_NULLP (binding_idx
))
1609 const SCM cdr_binding_idx
= SCM_CDR (binding_idx
); /* remember P3 */
1610 const SCM binding
= SCM_CAR (binding_idx
);
1611 const SCM name
= SCM_CAR (binding
);
1612 const SCM cdr_binding
= SCM_CDR (binding
);
1614 SCM_SETCDR (cdr_binding
, cdr_binding_idx
); /* update P2 */
1615 SCM_SETCAR (binding_idx
, name
); /* update P1 */
1616 SCM_SETCDR (binding_idx
, cdr_binding
); /* update P1 */
1618 binding_idx
= cdr_binding_idx
; /* continue with P3 */
1621 new_body
= m_body (SCM_IM_LETSTAR
, SCM_CDR (cdr_expr
));
1622 SCM_SETCAR (expr
, SCM_IM_LETSTAR
);
1623 /* the bindings have been changed in place */
1624 SCM_SETCDR (cdr_expr
, new_body
);
1629 SCM_SYNTAX(s_letrec
, "letrec", scm_i_makbimacro
, scm_m_letrec
);
1630 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
1633 scm_m_letrec (SCM expr
, SCM env
)
1637 const SCM cdr_expr
= SCM_CDR (expr
);
1638 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1639 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1641 bindings
= SCM_CAR (cdr_expr
);
1642 if (SCM_NULLP (bindings
))
1644 /* no bindings, let* is executed faster */
1645 SCM body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1646 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), SCM_EOL
, body
), env
);
1654 check_bindings (bindings
, expr
);
1655 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1656 new_body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1657 return scm_cons2 (SCM_IM_LETREC
, rvariables
, scm_cons (inits
, new_body
));
1662 SCM_SYNTAX (s_or
, "or", scm_i_makbimacro
, scm_m_or
);
1663 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
1666 scm_m_or (SCM expr
, SCM env SCM_UNUSED
)
1668 const SCM cdr_expr
= SCM_CDR (expr
);
1669 const long length
= scm_ilength (cdr_expr
);
1671 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1675 /* Special case: (or) is replaced by #f. */
1680 SCM_SETCAR (expr
, SCM_IM_OR
);
1686 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
1687 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
1688 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
1689 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
1691 /* Internal function to handle a quasiquotation: 'form' is the parameter in
1692 * the call (quasiquotation form), 'env' is the environment where unquoted
1693 * expressions will be evaluated, and 'depth' is the current quasiquotation
1694 * nesting level and is known to be greater than zero. */
1696 iqq (SCM form
, SCM env
, unsigned long int depth
)
1698 if (SCM_CONSP (form
))
1700 const SCM tmp
= SCM_CAR (form
);
1701 if (SCM_EQ_P (tmp
, scm_sym_quasiquote
))
1703 const SCM args
= SCM_CDR (form
);
1704 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1705 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
1707 else if (SCM_EQ_P (tmp
, scm_sym_unquote
))
1709 const SCM args
= SCM_CDR (form
);
1710 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1712 return scm_eval_car (args
, env
);
1714 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
1716 else if (SCM_CONSP (tmp
)
1717 && SCM_EQ_P (SCM_CAR (tmp
), scm_sym_uq_splicing
))
1719 const SCM args
= SCM_CDR (tmp
);
1720 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1723 const SCM list
= scm_eval_car (args
, env
);
1724 const SCM rest
= SCM_CDR (form
);
1725 ASSERT_SYNTAX_2 (scm_ilength (list
) >= 0,
1726 s_splicing
, list
, form
);
1727 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
1730 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
1731 iqq (SCM_CDR (form
), env
, depth
));
1734 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
1735 iqq (SCM_CDR (form
), env
, depth
));
1737 else if (SCM_VECTORP (form
))
1739 size_t i
= SCM_VECTOR_LENGTH (form
);
1740 SCM
const *const data
= SCM_VELTS (form
);
1743 tmp
= scm_cons (data
[--i
], tmp
);
1744 scm_remember_upto_here_1 (form
);
1745 return scm_vector (iqq (tmp
, env
, depth
));
1752 scm_m_quasiquote (SCM expr
, SCM env
)
1754 const SCM cdr_expr
= SCM_CDR (expr
);
1755 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1756 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1757 return iqq (SCM_CAR (cdr_expr
), env
, 1);
1761 SCM_SYNTAX (s_quote
, "quote", scm_i_makbimacro
, scm_m_quote
);
1762 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
1765 scm_m_quote (SCM expr
, SCM env SCM_UNUSED
)
1769 const SCM cdr_expr
= SCM_CDR (expr
);
1770 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1771 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1772 quotee
= SCM_CAR (cdr_expr
);
1773 if (is_self_quoting_p (quotee
))
1775 SCM_SETCAR (expr
, SCM_IM_QUOTE
);
1780 /* Will go into the RnRS module when Guile is factorized.
1781 SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
1782 static const char s_set_x
[] = "set!";
1783 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, s_set_x
);
1786 scm_m_set_x (SCM expr
, SCM env SCM_UNUSED
)
1791 const SCM cdr_expr
= SCM_CDR (expr
);
1792 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1793 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1794 variable
= SCM_CAR (cdr_expr
);
1796 /* Memoize the variable form. */
1797 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
), s_bad_variable
, variable
, expr
);
1798 new_variable
= lookup_symbol (variable
, env
);
1799 ASSERT_SYNTAX (!SCM_MACROP (new_variable
), s_macro_keyword
, variable
);
1800 /* Leave the memoization of unbound symbols to lazy memoization: */
1801 if (SCM_UNBNDP (new_variable
))
1802 new_variable
= variable
;
1804 SCM_SETCAR (expr
, SCM_IM_SET_X
);
1805 SCM_SETCAR (cdr_expr
, new_variable
);
1810 /* Start of the memoizers for non-R5RS builtin macros. */
1813 SCM_SYNTAX (s_atapply
, "@apply", scm_i_makbimacro
, scm_m_apply
);
1814 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1815 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1818 scm_m_apply (SCM expr
, SCM env SCM_UNUSED
)
1820 const SCM cdr_expr
= SCM_CDR (expr
);
1821 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1822 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_missing_expression
, expr
);
1824 SCM_SETCAR (expr
, SCM_IM_APPLY
);
1829 SCM_SYNTAX (s_atbind
, "@bind", scm_i_makbimacro
, scm_m_atbind
);
1831 /* FIXME: The following explanation should go into the documentation: */
1832 /* (@bind ((var init) ...) body ...) will assign the values of the `init's to
1833 * the global variables named by `var's (symbols, not evaluated), creating
1834 * them if they don't exist, executes body, and then restores the previous
1835 * values of the `var's. Additionally, whenever control leaves body, the
1836 * values of the `var's are saved and restored when control returns. It is an
1837 * error when a symbol appears more than once among the `var's. All `init's
1838 * are evaluated before any `var' is set.
1840 * Think of this as `let' for dynamic scope.
1843 /* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into
1844 * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...).
1846 * FIXME - also implement `@bind*'.
1849 scm_m_atbind (SCM expr
, SCM env
)
1856 const SCM top_level
= scm_env_top_level (env
);
1858 const SCM cdr_expr
= SCM_CDR (expr
);
1859 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1860 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1861 bindings
= SCM_CAR (cdr_expr
);
1862 check_bindings (bindings
, expr
);
1863 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1865 for (variable_idx
= rvariables
;
1866 !SCM_NULLP (variable_idx
);
1867 variable_idx
= SCM_CDR (variable_idx
))
1869 /* The first call to scm_sym2var will look beyond the current module,
1870 * while the second call wont. */
1871 const SCM variable
= SCM_CAR (variable_idx
);
1872 SCM new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_F
);
1873 if (SCM_FALSEP (new_variable
))
1874 new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_T
);
1875 SCM_SETCAR (variable_idx
, new_variable
);
1878 SCM_SETCAR (expr
, SCM_IM_BIND
);
1879 SCM_SETCAR (cdr_expr
, scm_cons (rvariables
, inits
));
1884 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_i_makbimacro
, scm_m_cont
);
1885 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, s_atcall_cc
);
1888 scm_m_cont (SCM expr
, SCM env SCM_UNUSED
)
1890 const SCM cdr_expr
= SCM_CDR (expr
);
1891 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1892 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1894 SCM_SETCAR (expr
, SCM_IM_CONT
);
1899 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_i_makbimacro
, scm_m_at_call_with_values
);
1900 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
1903 scm_m_at_call_with_values (SCM expr
, SCM env SCM_UNUSED
)
1905 const SCM cdr_expr
= SCM_CDR (expr
);
1906 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1907 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1909 SCM_SETCAR (expr
, SCM_IM_CALL_WITH_VALUES
);
1914 SCM_SYNTAX (s_future
, "future", scm_i_makbimacro
, scm_m_future
);
1915 SCM_GLOBAL_SYMBOL (scm_sym_future
, s_future
);
1917 /* Like promises, futures are implemented as closures with an empty
1918 * parameter list. Thus, (future <expression>) is transformed into
1919 * (#@future '() <expression>), where the empty list represents the
1920 * empty parameter list. This representation allows for easy creation
1921 * of the closure during evaluation. */
1923 scm_m_future (SCM expr
, SCM env
)
1925 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1926 SCM_SETCAR (new_expr
, SCM_IM_FUTURE
);
1931 SCM_SYNTAX (s_gset_x
, "set!", scm_i_makbimacro
, scm_m_generalized_set_x
);
1932 SCM_SYMBOL (scm_sym_setter
, "setter");
1935 scm_m_generalized_set_x (SCM expr
, SCM env
)
1937 SCM target
, exp_target
;
1939 const SCM cdr_expr
= SCM_CDR (expr
);
1940 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1941 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1943 target
= SCM_CAR (cdr_expr
);
1944 if (!SCM_CONSP (target
))
1947 return scm_m_set_x (expr
, env
);
1951 /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */
1952 /* Macroexpanding the target might return things of the form
1953 (begin <atom>). In that case, <atom> must be a symbol or a
1954 variable and we memoize to (set! <atom> ...).
1956 exp_target
= scm_macroexp (target
, env
);
1957 if (SCM_EQ_P (SCM_CAR (exp_target
), SCM_IM_BEGIN
)
1958 && !SCM_NULLP (SCM_CDR (exp_target
))
1959 && SCM_NULLP (SCM_CDDR (exp_target
)))
1961 exp_target
= SCM_CADR (exp_target
);
1962 ASSERT_SYNTAX_2 (SCM_SYMBOLP (exp_target
)
1963 || SCM_VARIABLEP (exp_target
),
1964 s_bad_variable
, exp_target
, expr
);
1965 return scm_cons (SCM_IM_SET_X
, scm_cons (exp_target
,
1966 SCM_CDR (cdr_expr
)));
1970 const SCM setter_proc_tail
= scm_list_1 (SCM_CAR (target
));
1971 const SCM setter_proc
= scm_cons_source (expr
, scm_sym_setter
,
1974 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1975 const SCM setter_args
= scm_append_x (scm_list_2 (SCM_CDR (target
),
1978 SCM_SETCAR (expr
, setter_proc
);
1979 SCM_SETCDR (expr
, setter_args
);
1986 /* @slot-ref is bound privately in the (oop goops) module from goops.c. As
1987 * soon as the module system allows us to more freely create bindings in
1988 * arbitrary modules during the startup phase, the code from goops.c should be
1991 scm_m_atslot_ref (SCM expr
, SCM env SCM_UNUSED
)
1995 const SCM cdr_expr
= SCM_CDR (expr
);
1996 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1997 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1998 slot_nr
= SCM_CADR (cdr_expr
);
1999 ASSERT_SYNTAX_2 (SCM_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2001 SCM_SETCAR (expr
, SCM_IM_SLOT_REF
);
2006 /* @slot-set! is bound privately in the (oop goops) module from goops.c. As
2007 * soon as the module system allows us to more freely create bindings in
2008 * arbitrary modules during the startup phase, the code from goops.c should be
2011 scm_m_atslot_set_x (SCM expr
, SCM env SCM_UNUSED
)
2015 const SCM cdr_expr
= SCM_CDR (expr
);
2016 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2017 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 3, s_expression
, expr
);
2018 slot_nr
= SCM_CADR (cdr_expr
);
2019 ASSERT_SYNTAX_2 (SCM_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2021 SCM_SETCAR (expr
, SCM_IM_SLOT_SET_X
);
2026 #if SCM_ENABLE_ELISP
2028 static const char s_defun
[] = "Symbol's function definition is void";
2030 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_i_makbimacro
, scm_m_nil_cond
);
2032 /* nil-cond expressions have the form
2033 * (nil-cond COND VAL COND VAL ... ELSEVAL) */
2035 scm_m_nil_cond (SCM expr
, SCM env SCM_UNUSED
)
2037 const long length
= scm_ilength (SCM_CDR (expr
));
2038 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
2039 ASSERT_SYNTAX (length
>= 1 && (length
% 2) == 1, s_expression
, expr
);
2041 SCM_SETCAR (expr
, SCM_IM_NIL_COND
);
2046 SCM_SYNTAX (s_atfop
, "@fop", scm_i_makbimacro
, scm_m_atfop
);
2048 /* The @fop-macro handles procedure and macro applications for elisp. The
2049 * input expression must have the form
2050 * (@fop <var> (transformer-macro <expr> ...))
2051 * where <var> must be a symbol. The expression is transformed into the
2052 * memoized form of either
2053 * (apply <un-aliased var> (transformer-macro <expr> ...))
2054 * if the value of var (across all aliasing) is not a macro, or
2055 * (<un-aliased var> <expr> ...)
2056 * if var is a macro. */
2058 scm_m_atfop (SCM expr
, SCM env SCM_UNUSED
)
2063 const SCM cdr_expr
= SCM_CDR (expr
);
2064 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2065 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 1, s_missing_expression
, expr
);
2067 symbol
= SCM_CAR (cdr_expr
);
2068 ASSERT_SYNTAX_2 (SCM_SYMBOLP (symbol
), s_bad_variable
, symbol
, expr
);
2070 location
= scm_symbol_fref (symbol
);
2071 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2073 /* The elisp function `defalias' allows to define aliases for symbols. To
2074 * look up such definitions, the chain of symbol definitions has to be
2075 * followed up to the terminal symbol. */
2076 while (SCM_SYMBOLP (SCM_VARIABLE_REF (location
)))
2078 const SCM alias
= SCM_VARIABLE_REF (location
);
2079 location
= scm_symbol_fref (alias
);
2080 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2083 /* Memoize the value location belonging to the terminal symbol. */
2084 SCM_SETCAR (cdr_expr
, location
);
2086 if (!SCM_MACROP (SCM_VARIABLE_REF (location
)))
2088 /* Since the location does not contain a macro, the form is a procedure
2089 * application. Replace `@fop' by `@apply' and transform the expression
2090 * including the `transformer-macro'. */
2091 SCM_SETCAR (expr
, SCM_IM_APPLY
);
2096 /* Since the location contains a macro, the arguments should not be
2097 * transformed, so the `transformer-macro' is cut out. The resulting
2098 * expression starts with the memoized variable, that is at the cdr of
2099 * the input expression. */
2100 SCM_SETCDR (cdr_expr
, SCM_CDADR (cdr_expr
));
2105 #endif /* SCM_ENABLE_ELISP */
2108 #if (SCM_ENABLE_DEPRECATED == 1)
2110 /* Deprecated in guile 1.7.0 on 2003-11-09. */
2112 scm_m_expand_body (SCM exprs
, SCM env
)
2114 scm_c_issue_deprecation_warning
2115 ("`scm_m_expand_body' is deprecated.");
2116 m_expand_body (exprs
, env
);
2121 SCM_SYNTAX (s_undefine
, "undefine", scm_makacro
, scm_m_undefine
);
2124 scm_m_undefine (SCM expr
, SCM env
)
2129 const SCM cdr_expr
= SCM_CDR (expr
);
2130 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), "Bad undefine placement in", expr
);
2131 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2132 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2134 variable
= SCM_CAR (cdr_expr
);
2135 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
), s_bad_variable
, variable
, expr
);
2136 location
= scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_F
);
2137 ASSERT_SYNTAX_2 (!SCM_FALSEP (location
)
2138 && !SCM_UNBNDP (SCM_VARIABLE_REF (location
)),
2139 "variable already unbound ", variable
, expr
);
2140 SCM_VARIABLE_SET (location
, SCM_UNDEFINED
);
2141 return SCM_UNSPECIFIED
;
2146 scm_macroexp (SCM x
, SCM env
)
2148 SCM res
, proc
, orig_sym
;
2150 /* Don't bother to produce error messages here. We get them when we
2151 eventually execute the code for real. */
2154 orig_sym
= SCM_CAR (x
);
2155 if (!SCM_SYMBOLP (orig_sym
))
2159 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
2160 if (proc_ptr
== NULL
)
2162 /* We have lost the race. */
2168 /* Only handle memoizing macros. `Acros' and `macros' are really
2169 special forms and should not be evaluated here. */
2171 if (!SCM_MACROP (proc
)
2172 || (SCM_MACRO_TYPE (proc
) != 2 && !SCM_BUILTIN_MACRO_P (proc
)))
2175 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
2176 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
2178 if (scm_ilength (res
) <= 0)
2179 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
2182 SCM_SETCAR (x
, SCM_CAR (res
));
2183 SCM_SETCDR (x
, SCM_CDR (res
));
2191 /*****************************************************************************/
2192 /*****************************************************************************/
2193 /* The definitions for unmemoization start here. */
2194 /*****************************************************************************/
2195 /*****************************************************************************/
2197 #define SCM_BIT7(x) (127 & SCM_UNPACK (x))
2199 SCM_SYMBOL (sym_three_question_marks
, "???");
2202 /* scm_unmemocopy takes a memoized expression together with its
2203 * environment and rewrites it to its original form. Thus, it is the
2204 * inversion of the rewrite rules above. The procedure is not
2205 * optimized for speed. It's used in scm_iprin1 when printing the
2206 * code of a closure, in scm_procedure_source, in display_frame when
2207 * generating the source for a stackframe in a backtrace, and in
2208 * display_expression.
2210 * Unmemoizing is not a reliable process. You cannot in general
2211 * expect to get the original source back.
2213 * However, GOOPS currently relies on this for method compilation.
2214 * This ought to change.
2218 build_binding_list (SCM rnames
, SCM rinits
)
2220 SCM bindings
= SCM_EOL
;
2221 while (!SCM_NULLP (rnames
))
2223 SCM binding
= scm_list_2 (SCM_CAR (rnames
), SCM_CAR (rinits
));
2224 bindings
= scm_cons (binding
, bindings
);
2225 rnames
= SCM_CDR (rnames
);
2226 rinits
= SCM_CDR (rinits
);
2233 unmemocar (SCM form
, SCM env
)
2235 if (!SCM_CONSP (form
))
2239 SCM c
= SCM_CAR (form
);
2240 if (SCM_VARIABLEP (c
))
2242 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
2243 if (SCM_FALSEP (sym
))
2244 sym
= sym_three_question_marks
;
2245 SCM_SETCAR (form
, sym
);
2247 else if (SCM_ILOCP (c
))
2249 unsigned long int ir
;
2251 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
2252 env
= SCM_CDR (env
);
2253 env
= SCM_CAAR (env
);
2254 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
2255 env
= SCM_CDR (env
);
2257 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
2265 scm_unmemocopy (SCM x
, SCM env
)
2270 if (SCM_VECTORP (x
))
2272 return scm_list_2 (scm_sym_quote
, x
);
2274 else if (!SCM_CONSP (x
))
2277 p
= scm_whash_lookup (scm_source_whash
, x
);
2278 if (SCM_ISYMP (SCM_CAR (x
)))
2280 switch (ISYMNUM (SCM_CAR (x
)))
2282 case (ISYMNUM (SCM_IM_AND
)):
2283 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
2285 case (ISYMNUM (SCM_IM_BEGIN
)):
2286 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
2288 case (ISYMNUM (SCM_IM_CASE
)):
2289 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
2291 case (ISYMNUM (SCM_IM_COND
)):
2292 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
2294 case (ISYMNUM (SCM_IM_DO
)):
2296 /* format: (#@do (i1 ... ik) (nk ... n1) (test) (body) s1 ... sk),
2297 * where ix is an initializer for a local variable, nx is the name
2298 * of the local variable, test is the test clause of the do loop,
2299 * body is the body of the do loop and sx are the step clauses for
2300 * the local variables. */
2301 SCM names
, inits
, test
, memoized_body
, steps
, bindings
;
2304 inits
= scm_reverse (scm_unmemocopy (SCM_CAR (x
), env
));
2306 names
= SCM_CAR (x
);
2307 env
= SCM_EXTEND_ENV (names
, SCM_EOL
, env
);
2309 test
= scm_unmemocopy (SCM_CAR (x
), env
);
2311 memoized_body
= SCM_CAR (x
);
2313 steps
= scm_reverse (scm_unmemocopy (x
, env
));
2315 /* build transformed binding list */
2317 while (!SCM_NULLP (names
))
2319 SCM name
= SCM_CAR (names
);
2320 SCM init
= SCM_CAR (inits
);
2321 SCM step
= SCM_CAR (steps
);
2322 step
= SCM_EQ_P (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
2324 bindings
= scm_cons (scm_cons2 (name
, init
, step
), bindings
);
2326 names
= SCM_CDR (names
);
2327 inits
= SCM_CDR (inits
);
2328 steps
= SCM_CDR (steps
);
2330 z
= scm_cons (test
, SCM_UNSPECIFIED
);
2331 ls
= scm_cons2 (scm_sym_do
, bindings
, z
);
2333 x
= scm_cons (SCM_BOOL_F
, memoized_body
);
2336 case (ISYMNUM (SCM_IM_IF
)):
2337 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
2339 case (ISYMNUM (SCM_IM_LET
)):
2341 /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),
2342 * where nx is the name of a local variable, ix is an initializer
2343 * for the local variable and by are the body clauses. */
2344 SCM rnames
, rinits
, bindings
;
2347 rnames
= SCM_CAR (x
);
2349 rinits
= scm_reverse (scm_unmemocopy (SCM_CAR (x
), env
));
2350 env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
2352 bindings
= build_binding_list (rnames
, rinits
);
2353 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
2354 ls
= scm_cons (scm_sym_let
, z
);
2357 case (ISYMNUM (SCM_IM_LETREC
)):
2359 /* format: (#@letrec (vn ... v2 v1) (i1 i2 ... in) b1 ...),
2360 * where vx is the name of a local variable, ix is an initializer
2361 * for the local variable and by are the body clauses. */
2362 SCM rnames
, rinits
, bindings
;
2365 rnames
= SCM_CAR (x
);
2366 env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
2368 rinits
= scm_reverse (scm_unmemocopy (SCM_CAR (x
), env
));
2370 bindings
= build_binding_list (rnames
, rinits
);
2371 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
2372 ls
= scm_cons (scm_sym_letrec
, z
);
2375 case (ISYMNUM (SCM_IM_LETSTAR
)):
2383 env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2387 SCM copy
= scm_unmemocopy (SCM_CADR (b
), env
);
2388 SCM initializer
= unmemocar (scm_list_1 (copy
), env
);
2389 y
= z
= scm_acons (SCM_CAR (b
), initializer
, SCM_UNSPECIFIED
);
2390 env
= SCM_EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
2394 SCM_SETCDR (y
, SCM_EOL
);
2395 z
= scm_cons (y
, SCM_UNSPECIFIED
);
2396 ls
= scm_cons (scm_sym_let
, z
);
2401 copy
= scm_unmemocopy (SCM_CADR (b
), env
);
2402 initializer
= unmemocar (scm_list_1 (copy
), env
);
2403 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
2407 env
= SCM_EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
2410 while (!SCM_NULLP (b
));
2411 SCM_SETCDR (z
, SCM_EOL
);
2413 z
= scm_cons (y
, SCM_UNSPECIFIED
);
2414 ls
= scm_cons (scm_sym_letstar
, z
);
2417 case (ISYMNUM (SCM_IM_OR
)):
2418 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
2420 case (ISYMNUM (SCM_IM_LAMBDA
)):
2422 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
);
2423 ls
= scm_cons (scm_sym_lambda
, z
);
2424 env
= SCM_EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
2426 case (ISYMNUM (SCM_IM_QUOTE
)):
2427 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
2429 case (ISYMNUM (SCM_IM_SET_X
)):
2430 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
2432 case (ISYMNUM (SCM_IM_APPLY
)):
2433 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
2435 case (ISYMNUM (SCM_IM_CONT
)):
2436 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
2438 case (ISYMNUM (SCM_IM_DELAY
)):
2439 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
2442 case (ISYMNUM (SCM_IM_FUTURE
)):
2443 ls
= z
= scm_cons (scm_sym_future
, SCM_UNSPECIFIED
);
2446 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2447 ls
= z
= scm_cons (scm_sym_at_call_with_values
, SCM_UNSPECIFIED
);
2449 case (ISYMNUM (SCM_IM_ELSE
)):
2450 ls
= z
= scm_cons (scm_sym_else
, SCM_UNSPECIFIED
);
2453 ls
= z
= unmemocar (scm_cons (scm_unmemocopy (SCM_CAR (x
), env
),
2460 ls
= z
= unmemocar (scm_cons (scm_unmemocopy (SCM_CAR (x
), env
),
2466 while (SCM_CONSP (x
))
2468 SCM form
= SCM_CAR (x
);
2469 if (!SCM_ISYMP (form
))
2471 SCM copy
= scm_cons (scm_unmemocopy (form
, env
), SCM_UNSPECIFIED
);
2472 SCM_SETCDR (z
, unmemocar (copy
, env
));
2475 else if (SCM_EQ_P (form
, SCM_IM_ARROW
))
2477 SCM_SETCDR (z
, scm_cons (scm_sym_arrow
, SCM_UNSPECIFIED
));
2483 if (!SCM_FALSEP (p
))
2484 scm_whash_insert (scm_source_whash
, ls
, p
);
2489 #if (SCM_ENABLE_DEPRECATED == 1)
2492 scm_unmemocar (SCM form
, SCM env
)
2494 return unmemocar (form
, env
);
2499 /*****************************************************************************/
2500 /*****************************************************************************/
2501 /* The definitions for execution start here. */
2502 /*****************************************************************************/
2503 /*****************************************************************************/
2505 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
2506 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
2507 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
2508 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
2510 /* A function object to implement "apply" for non-closure functions. */
2512 /* An endless list consisting of #<undefined> objects: */
2513 static SCM undefineds
;
2517 scm_badargsp (SCM formals
, SCM args
)
2519 while (!SCM_NULLP (formals
))
2521 if (!SCM_CONSP (formals
))
2523 if (SCM_NULLP (args
))
2525 formals
= SCM_CDR (formals
);
2526 args
= SCM_CDR (args
);
2528 return !SCM_NULLP (args
) ? 1 : 0;
2533 /* The evaluator contains a plethora of EVAL symbols. This is an attempt at
2536 * The following macros should be used in code which is read twice (where the
2537 * choice of evaluator is hard soldered):
2539 * CEVAL is the symbol used within one evaluator to call itself.
2540 * Originally, it is defined to ceval, but is redefined to deval during the
2543 * SCM_EVALIM is used when it is known that the expression is an
2544 * immediate. (This macro never calls an evaluator.)
2546 * EVAL evaluates an expression that is expected to have its symbols already
2547 * memoized. Expressions that are not of the form '(<form> <form> ...)' are
2548 * evaluated inline without calling an evaluator.
2550 * EVALCAR evaluates the car of an expression 'X:(Y:<form> <form> ...)',
2551 * potentially replacing a symbol at the position Y:<form> by its memoized
2552 * variable. If Y:<form> is not of the form '(<form> <form> ...)', the
2553 * evaluation is performed inline without calling an evaluator.
2555 * The following macros should be used in code which is read once
2556 * (where the choice of evaluator is dynamic):
2558 * SCM_XEVAL corresponds to EVAL, but uses ceval *or* deval depending on the
2561 * SCM_XEVALCAR corresponds to EVALCAR, but uses ceval *or* deval depending
2562 * on the debugging mode.
2564 * The main motivation for keeping this plethora is efficiency
2565 * together with maintainability (=> locality of code).
2568 static SCM
ceval (SCM x
, SCM env
);
2569 static SCM
deval (SCM x
, SCM env
);
2573 #define SCM_EVALIM2(x) \
2574 ((SCM_EQ_P ((x), SCM_EOL) \
2575 ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \
2579 #define SCM_EVALIM(x, env) (SCM_ILOCP (x) \
2580 ? *scm_ilookup ((x), (env)) \
2583 #define SCM_XEVAL(x, env) \
2586 : (SCM_VARIABLEP (x) \
2587 ? SCM_VARIABLE_REF (x) \
2589 ? (scm_debug_mode_p \
2590 ? deval ((x), (env)) \
2591 : ceval ((x), (env))) \
2594 #define SCM_XEVALCAR(x, env) \
2595 (SCM_IMP (SCM_CAR (x)) \
2596 ? SCM_EVALIM (SCM_CAR (x), (env)) \
2597 : (SCM_VARIABLEP (SCM_CAR (x)) \
2598 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2599 : (SCM_CONSP (SCM_CAR (x)) \
2600 ? (scm_debug_mode_p \
2601 ? deval (SCM_CAR (x), (env)) \
2602 : ceval (SCM_CAR (x), (env))) \
2603 : (!SCM_SYMBOLP (SCM_CAR (x)) \
2605 : *scm_lookupcar ((x), (env), 1)))))
2607 #define EVAL(x, env) \
2609 ? SCM_EVALIM ((x), (env)) \
2610 : (SCM_VARIABLEP (x) \
2611 ? SCM_VARIABLE_REF (x) \
2613 ? CEVAL ((x), (env)) \
2616 #define EVALCAR(x, env) \
2617 (SCM_IMP (SCM_CAR (x)) \
2618 ? SCM_EVALIM (SCM_CAR (x), (env)) \
2619 : (SCM_VARIABLEP (SCM_CAR (x)) \
2620 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2621 : (SCM_CONSP (SCM_CAR (x)) \
2622 ? CEVAL (SCM_CAR (x), (env)) \
2623 : (!SCM_SYMBOLP (SCM_CAR (x)) \
2625 : *scm_lookupcar ((x), (env), 1)))))
2627 SCM_REC_MUTEX (source_mutex
);
2630 /* During execution, look up a symbol in the top level of the given local
2631 * environment and return the corresponding variable object. If no binding
2632 * for the symbol can be found, an 'Unbound variable' error is signalled. */
2634 lazy_memoize_variable (const SCM symbol
, const SCM environment
)
2636 const SCM top_level
= scm_env_top_level (environment
);
2637 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
2639 if (SCM_FALSEP (variable
))
2640 error_unbound_variable (symbol
);
2647 scm_eval_car (SCM pair
, SCM env
)
2649 return SCM_XEVALCAR (pair
, env
);
2654 scm_eval_args (SCM l
, SCM env
, SCM proc
)
2656 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
2657 while (SCM_CONSP (l
))
2659 res
= EVALCAR (l
, env
);
2661 *lloc
= scm_list_1 (res
);
2662 lloc
= SCM_CDRLOC (*lloc
);
2666 scm_wrong_num_args (proc
);
2672 scm_eval_body (SCM code
, SCM env
)
2677 next
= SCM_CDR (code
);
2678 while (!SCM_NULLP (next
))
2680 if (SCM_IMP (SCM_CAR (code
)))
2682 if (SCM_ISYMP (SCM_CAR (code
)))
2684 scm_rec_mutex_lock (&source_mutex
);
2685 /* check for race condition */
2686 if (SCM_ISYMP (SCM_CAR (code
)))
2687 m_expand_body (code
, env
);
2688 scm_rec_mutex_unlock (&source_mutex
);
2693 SCM_XEVAL (SCM_CAR (code
), env
);
2695 next
= SCM_CDR (code
);
2697 return SCM_XEVALCAR (code
, env
);
2703 /* SECTION: This code is specific for the debugging support. One
2704 * branch is read when DEVAL isn't defined, the other when DEVAL is
2710 #define SCM_APPLY scm_apply
2711 #define PREP_APPLY(proc, args)
2713 #define RETURN(x) do { return x; } while (0)
2714 #ifdef STACK_CHECKING
2715 #ifndef NO_CEVAL_STACK_CHECKING
2716 #define EVAL_STACK_CHECKING
2723 #define CEVAL deval /* Substitute all uses of ceval */
2726 #define SCM_APPLY scm_dapply
2729 #define PREP_APPLY(p, l) \
2730 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
2733 #define ENTER_APPLY \
2735 SCM_SET_ARGSREADY (debug);\
2736 if (scm_check_apply_p && SCM_TRAPS_P)\
2737 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
2739 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
2740 SCM_SET_TRACED_FRAME (debug); \
2742 if (SCM_CHEAPTRAPS_P)\
2744 tmp = scm_make_debugobj (&debug);\
2745 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
2750 tmp = scm_make_continuation (&first);\
2752 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
2759 #define RETURN(e) do { proc = (e); goto exit; } while (0)
2761 #ifdef STACK_CHECKING
2762 #ifndef EVAL_STACK_CHECKING
2763 #define EVAL_STACK_CHECKING
2768 /* scm_last_debug_frame contains a pointer to the last debugging information
2769 * stack frame. It is accessed very often from the debugging evaluator, so it
2770 * should probably not be indirectly addressed. Better to save and restore it
2771 * from the current root at any stack swaps.
2774 /* scm_debug_eframe_size is the number of slots available for pseudo
2775 * stack frames at each real stack frame.
2778 long scm_debug_eframe_size
;
2780 int scm_debug_mode_p
;
2781 int scm_check_entry_p
;
2782 int scm_check_apply_p
;
2783 int scm_check_exit_p
;
2785 long scm_eval_stack
;
2787 scm_t_option scm_eval_opts
[] = {
2788 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
2791 scm_t_option scm_debug_opts
[] = {
2792 { SCM_OPTION_BOOLEAN
, "cheap", 1,
2793 "*Flyweight representation of the stack at traps." },
2794 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
2795 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
2796 { SCM_OPTION_BOOLEAN
, "procnames", 1,
2797 "Record procedure names at definition." },
2798 { SCM_OPTION_BOOLEAN
, "backwards", 0,
2799 "Display backtrace in anti-chronological order." },
2800 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
2801 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
2802 { SCM_OPTION_INTEGER
, "frames", 3,
2803 "Maximum number of tail-recursive frames in backtrace." },
2804 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
2805 "Maximal number of stored backtrace frames." },
2806 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
2807 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
2808 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
2809 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
2810 { 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."}
2813 scm_t_option scm_evaluator_trap_table
[] = {
2814 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
2815 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
2816 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
2817 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
2818 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
2819 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
2820 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
2823 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
2825 "Option interface for the evaluation options. Instead of using\n"
2826 "this procedure directly, use the procedures @code{eval-enable},\n"
2827 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
2828 #define FUNC_NAME s_scm_eval_options_interface
2832 ans
= scm_options (setting
,
2836 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
2843 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
2845 "Option interface for the evaluator trap options.")
2846 #define FUNC_NAME s_scm_evaluator_traps
2850 ans
= scm_options (setting
,
2851 scm_evaluator_trap_table
,
2852 SCM_N_EVALUATOR_TRAPS
,
2854 SCM_RESET_DEBUG_MODE
;
2862 deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
2864 SCM
*results
= lloc
;
2865 while (SCM_CONSP (l
))
2867 const SCM res
= EVALCAR (l
, env
);
2869 *lloc
= scm_list_1 (res
);
2870 lloc
= SCM_CDRLOC (*lloc
);
2874 scm_wrong_num_args (proc
);
2881 /* SECTION: This code is compiled twice.
2885 /* Update the toplevel environment frame ENV so that it refers to the
2886 * current module. */
2887 #define UPDATE_TOPLEVEL_ENV(env) \
2889 SCM p = scm_current_module_lookup_closure (); \
2890 if (p != SCM_CAR (env)) \
2891 env = scm_top_level_env (p); \
2895 #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
2896 ASSERT_SYNTAX (!SCM_EQ_P ((x), SCM_EOL), s_empty_combination, x)
2899 /* This is the evaluator. Like any real monster, it has three heads:
2901 * ceval is the non-debugging evaluator, deval is the debugging version. Both
2902 * are implemented using a common code base, using the following mechanism:
2903 * CEVAL is a macro, which is either defined to ceval or deval. Thus, there
2904 * is no function CEVAL, but the code for CEVAL actually compiles to either
2905 * ceval or deval. When CEVAL is defined to ceval, it is known that the macro
2906 * DEVAL is not defined. When CEVAL is defined to deval, then the macro DEVAL
2907 * is known to be defined. Thus, in CEVAL parts for the debugging evaluator
2908 * are enclosed within #ifdef DEVAL ... #endif.
2910 * All three (ceval, deval and their common implementation CEVAL) take two
2911 * input parameters, x and env: x is a single expression to be evalutated.
2912 * env is the environment in which bindings are searched.
2914 * x is known to be a pair. Since x is a single expression, it is necessarily
2915 * in a tail position. If x is just a call to another function like in the
2916 * expression (foo exp1 exp2 ...), the realization of that call therefore
2917 * _must_not_ increase stack usage (the evaluation of exp1, exp2 etc.,
2918 * however, may do so). This is realized by making extensive use of 'goto'
2919 * statements within the evaluator: The gotos replace recursive calls to
2920 * CEVAL, thus re-using the same stack frame that CEVAL was already using.
2921 * If, however, x represents some form that requires to evaluate a sequence of
2922 * expressions like (begin exp1 exp2 ...), then recursive calls to CEVAL are
2923 * performed for all but the last expression of that sequence. */
2926 CEVAL (SCM x
, SCM env
)
2930 scm_t_debug_frame debug
;
2931 scm_t_debug_info
*debug_info_end
;
2932 debug
.prev
= scm_last_debug_frame
;
2935 * The debug.vect contains twice as much scm_t_debug_info frames as the
2936 * user has specified with (debug-set! frames <n>).
2938 * Even frames are eval frames, odd frames are apply frames.
2940 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
2941 * sizeof (scm_t_debug_info
));
2942 debug
.info
= debug
.vect
;
2943 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
2944 scm_last_debug_frame
= &debug
;
2946 #ifdef EVAL_STACK_CHECKING
2947 if (scm_stack_checking_enabled_p
&& SCM_STACK_OVERFLOW_P (&proc
))
2950 debug
.info
->e
.exp
= x
;
2951 debug
.info
->e
.env
= env
;
2953 scm_report_stack_overflow ();
2963 SCM_CLEAR_ARGSREADY (debug
);
2964 if (SCM_OVERFLOWP (debug
))
2967 * In theory, this should be the only place where it is necessary to
2968 * check for space in debug.vect since both eval frames and
2969 * available space are even.
2971 * For this to be the case, however, it is necessary that primitive
2972 * special forms which jump back to `loop', `begin' or some similar
2973 * label call PREP_APPLY.
2975 else if (++debug
.info
>= debug_info_end
)
2977 SCM_SET_OVERFLOW (debug
);
2982 debug
.info
->e
.exp
= x
;
2983 debug
.info
->e
.env
= env
;
2984 if (scm_check_entry_p
&& SCM_TRAPS_P
)
2986 if (SCM_ENTER_FRAME_P
2987 || (SCM_BREAKPOINTS_P
&& scm_c_source_property_breakpoint_p (x
)))
2990 SCM tail
= SCM_BOOL (SCM_TAILRECP (debug
));
2991 SCM_SET_TAILREC (debug
);
2992 if (SCM_CHEAPTRAPS_P
)
2993 stackrep
= scm_make_debugobj (&debug
);
2997 SCM val
= scm_make_continuation (&first
);
3007 /* This gives the possibility for the debugger to
3008 modify the source expression before evaluation. */
3013 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
3014 scm_sym_enter_frame
,
3017 scm_unmemocopy (x
, env
));
3024 if (SCM_ISYMP (SCM_CAR (x
)))
3026 switch (ISYMNUM (SCM_CAR (x
)))
3028 case (ISYMNUM (SCM_IM_AND
)):
3030 while (!SCM_NULLP (SCM_CDR (x
)))
3032 SCM test_result
= EVALCAR (x
, env
);
3033 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
3034 RETURN (SCM_BOOL_F
);
3038 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3041 case (ISYMNUM (SCM_IM_BEGIN
)):
3044 RETURN (SCM_UNSPECIFIED
);
3046 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3049 /* If we are on toplevel with a lookup closure, we need to sync
3050 with the current module. */
3051 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
3053 UPDATE_TOPLEVEL_ENV (env
);
3054 while (!SCM_NULLP (SCM_CDR (x
)))
3057 UPDATE_TOPLEVEL_ENV (env
);
3063 goto nontoplevel_begin
;
3066 while (!SCM_NULLP (SCM_CDR (x
)))
3068 const SCM form
= SCM_CAR (x
);
3071 if (SCM_ISYMP (form
))
3073 scm_rec_mutex_lock (&source_mutex
);
3074 /* check for race condition */
3075 if (SCM_ISYMP (SCM_CAR (x
)))
3076 m_expand_body (x
, env
);
3077 scm_rec_mutex_unlock (&source_mutex
);
3078 goto nontoplevel_begin
;
3081 SCM_VALIDATE_NON_EMPTY_COMBINATION (form
);
3084 (void) EVAL (form
, env
);
3090 /* scm_eval last form in list */
3091 const SCM last_form
= SCM_CAR (x
);
3093 if (SCM_CONSP (last_form
))
3095 /* This is by far the most frequent case. */
3097 goto loop
; /* tail recurse */
3099 else if (SCM_IMP (last_form
))
3100 RETURN (SCM_EVALIM (last_form
, env
));
3101 else if (SCM_VARIABLEP (last_form
))
3102 RETURN (SCM_VARIABLE_REF (last_form
));
3103 else if (SCM_SYMBOLP (last_form
))
3104 RETURN (*scm_lookupcar (x
, env
, 1));
3110 case (ISYMNUM (SCM_IM_CASE
)):
3113 const SCM key
= EVALCAR (x
, env
);
3115 while (!SCM_NULLP (x
))
3117 const SCM clause
= SCM_CAR (x
);
3118 SCM labels
= SCM_CAR (clause
);
3119 if (SCM_EQ_P (labels
, SCM_IM_ELSE
))
3121 x
= SCM_CDR (clause
);
3122 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3125 while (!SCM_NULLP (labels
))
3127 const SCM label
= SCM_CAR (labels
);
3128 if (SCM_EQ_P (label
, key
)
3129 || !SCM_FALSEP (scm_eqv_p (label
, key
)))
3131 x
= SCM_CDR (clause
);
3132 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3135 labels
= SCM_CDR (labels
);
3140 RETURN (SCM_UNSPECIFIED
);
3143 case (ISYMNUM (SCM_IM_COND
)):
3145 while (!SCM_NULLP (x
))
3147 const SCM clause
= SCM_CAR (x
);
3148 if (SCM_EQ_P (SCM_CAR (clause
), SCM_IM_ELSE
))
3150 x
= SCM_CDR (clause
);
3151 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3156 arg1
= EVALCAR (clause
, env
);
3157 if (!SCM_FALSEP (arg1
) && !SCM_NILP (arg1
))
3159 x
= SCM_CDR (clause
);
3162 else if (!SCM_EQ_P (SCM_CAR (x
), SCM_IM_ARROW
))
3164 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3170 proc
= EVALCAR (proc
, env
);
3171 PREP_APPLY (proc
, scm_list_1 (arg1
));
3179 RETURN (SCM_UNSPECIFIED
);
3182 case (ISYMNUM (SCM_IM_DO
)):
3185 /* Compute the initialization values and the initial environment. */
3186 SCM init_forms
= SCM_CAR (x
);
3187 SCM init_values
= SCM_EOL
;
3188 while (!SCM_NULLP (init_forms
))
3190 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3191 init_forms
= SCM_CDR (init_forms
);
3194 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
3198 SCM test_form
= SCM_CAR (x
);
3199 SCM body_forms
= SCM_CADR (x
);
3200 SCM step_forms
= SCM_CDDR (x
);
3202 SCM test_result
= EVALCAR (test_form
, env
);
3204 while (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
3207 /* Evaluate body forms. */
3209 for (temp_forms
= body_forms
;
3210 !SCM_NULLP (temp_forms
);
3211 temp_forms
= SCM_CDR (temp_forms
))
3213 SCM form
= SCM_CAR (temp_forms
);
3214 /* Dirk:FIXME: We only need to eval forms that may have
3215 * a side effect here. This is only true for forms that
3216 * start with a pair. All others are just constants.
3217 * Since with the current memoizer 'form' may hold a
3218 * constant, we call EVAL here to handle the constant
3219 * cases. In the long run it would make sense to have
3220 * the macro transformer of 'do' eliminate all forms
3221 * that have no sideeffect. Then instead of EVAL we
3222 * could call CEVAL directly here. */
3223 (void) EVAL (form
, env
);
3228 /* Evaluate the step expressions. */
3230 SCM step_values
= SCM_EOL
;
3231 for (temp_forms
= step_forms
;
3232 !SCM_NULLP (temp_forms
);
3233 temp_forms
= SCM_CDR (temp_forms
))
3235 const SCM value
= EVALCAR (temp_forms
, env
);
3236 step_values
= scm_cons (value
, step_values
);
3238 env
= SCM_EXTEND_ENV (SCM_CAAR (env
),
3243 test_result
= EVALCAR (test_form
, env
);
3248 RETURN (SCM_UNSPECIFIED
);
3249 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3250 goto nontoplevel_begin
;
3253 case (ISYMNUM (SCM_IM_IF
)):
3256 SCM test_result
= EVALCAR (x
, env
);
3257 x
= SCM_CDR (x
); /* then expression */
3258 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
3260 x
= SCM_CDR (x
); /* else expression */
3262 RETURN (SCM_UNSPECIFIED
);
3265 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3269 case (ISYMNUM (SCM_IM_LET
)):
3272 SCM init_forms
= SCM_CADR (x
);
3273 SCM init_values
= SCM_EOL
;
3276 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3277 init_forms
= SCM_CDR (init_forms
);
3279 while (!SCM_NULLP (init_forms
));
3280 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
3283 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3284 goto nontoplevel_begin
;
3287 case (ISYMNUM (SCM_IM_LETREC
)):
3289 env
= SCM_EXTEND_ENV (SCM_CAR (x
), undefineds
, env
);
3292 SCM init_forms
= SCM_CAR (x
);
3293 SCM init_values
= SCM_EOL
;
3296 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3297 init_forms
= SCM_CDR (init_forms
);
3299 while (!SCM_NULLP (init_forms
));
3300 SCM_SETCDR (SCM_CAR (env
), init_values
);
3303 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3304 goto nontoplevel_begin
;
3307 case (ISYMNUM (SCM_IM_LETSTAR
)):
3310 SCM bindings
= SCM_CAR (x
);
3311 if (SCM_NULLP (bindings
))
3312 env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
3317 SCM name
= SCM_CAR (bindings
);
3318 SCM init
= SCM_CDR (bindings
);
3319 env
= SCM_EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
3320 bindings
= SCM_CDR (init
);
3322 while (!SCM_NULLP (bindings
));
3326 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3327 goto nontoplevel_begin
;
3330 case (ISYMNUM (SCM_IM_OR
)):
3332 while (!SCM_NULLP (SCM_CDR (x
)))
3334 SCM val
= EVALCAR (x
, env
);
3335 if (!SCM_FALSEP (val
) && !SCM_NILP (val
))
3340 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3344 case (ISYMNUM (SCM_IM_LAMBDA
)):
3345 RETURN (scm_closure (SCM_CDR (x
), env
));
3348 case (ISYMNUM (SCM_IM_QUOTE
)):
3349 RETURN (SCM_CADR (x
));
3352 case (ISYMNUM (SCM_IM_SET_X
)):
3356 SCM variable
= SCM_CAR (x
);
3357 if (SCM_ILOCP (variable
))
3358 location
= scm_ilookup (variable
, env
);
3359 else if (SCM_VARIABLEP (variable
))
3360 location
= SCM_VARIABLE_LOC (variable
);
3363 /* (SCM_SYMBOLP (variable)) is known to be true */
3364 variable
= lazy_memoize_variable (variable
, env
);
3365 SCM_SETCAR (x
, variable
);
3366 location
= SCM_VARIABLE_LOC (variable
);
3369 *location
= EVALCAR (x
, env
);
3371 RETURN (SCM_UNSPECIFIED
);
3374 case (ISYMNUM (SCM_IM_APPLY
)):
3375 /* Evaluate the procedure to be applied. */
3377 proc
= EVALCAR (x
, env
);
3378 PREP_APPLY (proc
, SCM_EOL
);
3380 /* Evaluate the argument holding the list of arguments */
3382 arg1
= EVALCAR (x
, env
);
3385 /* Go here to tail-apply a procedure. PROC is the procedure and
3386 * ARG1 is the list of arguments. PREP_APPLY must have been called
3387 * before jumping to apply_proc. */
3388 if (SCM_CLOSUREP (proc
))
3390 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3392 debug
.info
->a
.args
= arg1
;
3394 if (scm_badargsp (formals
, arg1
))
3395 scm_wrong_num_args (proc
);
3397 /* Copy argument list */
3398 if (SCM_NULL_OR_NIL_P (arg1
))
3399 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
3402 SCM args
= scm_list_1 (SCM_CAR (arg1
));
3404 arg1
= SCM_CDR (arg1
);
3405 while (!SCM_NULL_OR_NIL_P (arg1
))
3407 SCM new_tail
= scm_list_1 (SCM_CAR (arg1
));
3408 SCM_SETCDR (tail
, new_tail
);
3410 arg1
= SCM_CDR (arg1
);
3412 env
= SCM_EXTEND_ENV (formals
, args
, SCM_ENV (proc
));
3415 x
= SCM_CLOSURE_BODY (proc
);
3416 goto nontoplevel_begin
;
3421 RETURN (SCM_APPLY (proc
, arg1
, SCM_EOL
));
3425 case (ISYMNUM (SCM_IM_CONT
)):
3428 SCM val
= scm_make_continuation (&first
);
3436 proc
= EVALCAR (proc
, env
);
3437 PREP_APPLY (proc
, scm_list_1 (arg1
));
3444 case (ISYMNUM (SCM_IM_DELAY
)):
3445 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
3448 case (ISYMNUM (SCM_IM_FUTURE
)):
3449 RETURN (scm_i_make_future (scm_closure (SCM_CDR (x
), env
)));
3452 /* PLACEHOLDER for case (ISYMNUM (SCM_IM_DISPATCH)): The following
3453 code (type_dispatch) is intended to be the tail of the case
3454 clause for the internal macro SCM_IM_DISPATCH. Please don't
3455 remove it from this location without discussing it with Mikael
3456 <djurfeldt@nada.kth.se> */
3458 /* The type dispatch code is duplicated below
3459 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
3460 * cuts down execution time for type dispatch to 50%. */
3461 type_dispatch
: /* inputs: x, arg1 */
3462 /* Type dispatch means to determine from the types of the function
3463 * arguments (i. e. the 'signature' of the call), which method from
3464 * a generic function is to be called. This process of selecting
3465 * the right method takes some time. To speed it up, guile uses
3466 * caching: Together with the macro call to dispatch the signatures
3467 * of some previous calls to that generic function from the same
3468 * place are stored (in the code!) in a cache that we call the
3469 * 'method cache'. This is done since it is likely, that
3470 * consecutive calls to dispatch from that position in the code will
3471 * have the same signature. Thus, the type dispatch works as
3472 * follows: First, determine a hash value from the signature of the
3473 * actual arguments. Second, use this hash value as an index to
3474 * find that same signature in the method cache stored at this
3475 * position in the code. If found, you have also found the
3476 * corresponding method that belongs to that signature. If the
3477 * signature is not found in the method cache, you have to perform a
3478 * full search over all signatures stored with the generic
3481 unsigned long int specializers
;
3482 unsigned long int hash_value
;
3483 unsigned long int cache_end_pos
;
3484 unsigned long int mask
;
3488 SCM z
= SCM_CDDR (x
);
3489 SCM tmp
= SCM_CADR (z
);
3490 specializers
= SCM_INUM (SCM_CAR (z
));
3492 /* Compute a hash value for searching the method cache. There
3493 * are two variants for computing the hash value, a (rather)
3494 * complicated one, and a simple one. For the complicated one
3495 * explained below, tmp holds a number that is used in the
3497 if (SCM_INUMP (tmp
))
3499 /* Use the signature of the actual arguments to determine
3500 * the hash value. This is done as follows: Each class has
3501 * an array of random numbers, that are determined when the
3502 * class is created. The integer 'hashset' is an index into
3503 * that array of random numbers. Now, from all classes that
3504 * are part of the signature of the actual arguments, the
3505 * random numbers at index 'hashset' are taken and summed
3506 * up, giving the hash value. The value of 'hashset' is
3507 * stored at the call to dispatch. This allows to have
3508 * different 'formulas' for calculating the hash value at
3509 * different places where dispatch is called. This allows
3510 * to optimize the hash formula at every individual place
3511 * where dispatch is called, such that hopefully the hash
3512 * value that is computed will directly point to the right
3513 * method in the method cache. */
3514 unsigned long int hashset
= SCM_INUM (tmp
);
3515 unsigned long int counter
= specializers
+ 1;
3518 while (!SCM_NULLP (tmp_arg
) && counter
!= 0)
3520 SCM
class = scm_class_of (SCM_CAR (tmp_arg
));
3521 hash_value
+= SCM_INSTANCE_HASH (class, hashset
);
3522 tmp_arg
= SCM_CDR (tmp_arg
);
3526 method_cache
= SCM_CADR (z
);
3527 mask
= SCM_INUM (SCM_CAR (z
));
3529 cache_end_pos
= hash_value
;
3533 /* This method of determining the hash value is much
3534 * simpler: Set the hash value to zero and just perform a
3535 * linear search through the method cache. */
3537 mask
= (unsigned long int) ((long) -1);
3539 cache_end_pos
= SCM_VECTOR_LENGTH (method_cache
);
3544 /* Search the method cache for a method with a matching
3545 * signature. Start the search at position 'hash_value'. The
3546 * hashing implementation uses linear probing for conflict
3547 * resolution, that is, if the signature in question is not
3548 * found at the starting index in the hash table, the next table
3549 * entry is tried, and so on, until in the worst case the whole
3550 * cache has been searched, but still the signature has not been
3555 SCM args
= arg1
; /* list of arguments */
3556 z
= SCM_VELTS (method_cache
)[hash_value
];
3557 while (!SCM_NULLP (args
))
3559 /* More arguments than specifiers => CLASS != ENV */
3560 SCM class_of_arg
= scm_class_of (SCM_CAR (args
));
3561 if (!SCM_EQ_P (class_of_arg
, SCM_CAR (z
)))
3563 args
= SCM_CDR (args
);
3566 /* Fewer arguments than specifiers => CAR != ENV */
3567 if (SCM_NULLP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
)))
3570 hash_value
= (hash_value
+ 1) & mask
;
3571 } while (hash_value
!= cache_end_pos
);
3573 /* No appropriate method was found in the cache. */
3574 z
= scm_memoize_method (x
, arg1
);
3576 apply_cmethod
: /* inputs: z, arg1 */
3578 SCM formals
= SCM_CMETHOD_FORMALS (z
);
3579 env
= SCM_EXTEND_ENV (formals
, arg1
, SCM_CMETHOD_ENV (z
));
3580 x
= SCM_CMETHOD_BODY (z
);
3581 goto nontoplevel_begin
;
3587 case (ISYMNUM (SCM_IM_SLOT_REF
)):
3590 SCM instance
= EVALCAR (x
, env
);
3591 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
3592 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance
) [slot
]));
3596 case (ISYMNUM (SCM_IM_SLOT_SET_X
)):
3599 SCM instance
= EVALCAR (x
, env
);
3600 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
3601 SCM value
= EVALCAR (SCM_CDDR (x
), env
);
3602 SCM_STRUCT_DATA (instance
) [slot
] = SCM_UNPACK (value
);
3603 RETURN (SCM_UNSPECIFIED
);
3607 #if SCM_ENABLE_ELISP
3609 case (ISYMNUM (SCM_IM_NIL_COND
)):
3611 SCM test_form
= SCM_CDR (x
);
3612 x
= SCM_CDR (test_form
);
3613 while (!SCM_NULL_OR_NIL_P (x
))
3615 SCM test_result
= EVALCAR (test_form
, env
);
3616 if (!(SCM_FALSEP (test_result
)
3617 || SCM_NULL_OR_NIL_P (test_result
)))
3619 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
3620 RETURN (test_result
);
3621 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3626 test_form
= SCM_CDR (x
);
3627 x
= SCM_CDR (test_form
);
3631 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3635 #endif /* SCM_ENABLE_ELISP */
3637 case (ISYMNUM (SCM_IM_BIND
)):
3639 SCM vars
, exps
, vals
;
3642 vars
= SCM_CAAR (x
);
3643 exps
= SCM_CDAR (x
);
3645 while (!SCM_NULLP (exps
))
3647 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
3648 exps
= SCM_CDR (exps
);
3651 scm_swap_bindings (vars
, vals
);
3652 scm_dynwinds
= scm_acons (vars
, vals
, scm_dynwinds
);
3654 /* Ignore all but the last evaluation result. */
3655 for (x
= SCM_CDR (x
); !SCM_NULLP (SCM_CDR (x
)); x
= SCM_CDR (x
))
3657 if (SCM_CONSP (SCM_CAR (x
)))
3658 CEVAL (SCM_CAR (x
), env
);
3660 proc
= EVALCAR (x
, env
);
3662 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
3663 scm_swap_bindings (vars
, vals
);
3669 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
3674 producer
= EVALCAR (x
, env
);
3676 proc
= EVALCAR (x
, env
); /* proc is the consumer. */
3677 arg1
= SCM_APPLY (producer
, SCM_EOL
, SCM_EOL
);
3678 if (SCM_VALUESP (arg1
))
3680 /* The list of arguments is not copied. Rather, it is assumed
3681 * that this has been done by the 'values' procedure. */
3682 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
3686 arg1
= scm_list_1 (arg1
);
3688 PREP_APPLY (proc
, arg1
);
3699 if (SCM_VARIABLEP (SCM_CAR (x
)))
3700 proc
= SCM_VARIABLE_REF (SCM_CAR (x
));
3701 else if (SCM_ILOCP (SCM_CAR (x
)))
3702 proc
= *scm_ilookup (SCM_CAR (x
), env
);
3703 else if (SCM_CONSP (SCM_CAR (x
)))
3704 proc
= CEVAL (SCM_CAR (x
), env
);
3705 else if (SCM_SYMBOLP (SCM_CAR (x
)))
3707 SCM orig_sym
= SCM_CAR (x
);
3709 SCM
*location
= scm_lookupcar1 (x
, env
, 1);
3710 if (location
== NULL
)
3712 /* we have lost the race, start again. */
3718 if (SCM_MACROP (proc
))
3720 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
3722 handle_a_macro
: /* inputs: x, env, proc */
3724 /* Set a flag during macro expansion so that macro
3725 application frames can be deleted from the backtrace. */
3726 SCM_SET_MACROEXP (debug
);
3728 arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
3729 scm_cons (env
, scm_listofnull
));
3731 SCM_CLEAR_MACROEXP (debug
);
3733 switch (SCM_MACRO_TYPE (proc
))
3737 if (scm_ilength (arg1
) <= 0)
3738 arg1
= scm_list_2 (SCM_IM_BEGIN
, arg1
);
3740 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
3743 SCM_SETCAR (x
, SCM_CAR (arg1
));
3744 SCM_SETCDR (x
, SCM_CDR (arg1
));
3748 /* Prevent memoizing of debug info expression. */
3749 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
3754 SCM_SETCAR (x
, SCM_CAR (arg1
));
3755 SCM_SETCDR (x
, SCM_CDR (arg1
));
3757 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3759 #if SCM_ENABLE_DEPRECATED == 1
3764 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3778 if (SCM_MACROP (proc
))
3779 goto handle_a_macro
;
3783 /* When reaching this part of the code, the following is granted: Variable x
3784 * holds the first pair of an expression of the form (<function> arg ...).
3785 * Variable proc holds the object that resulted from the evaluation of
3786 * <function>. In the following, the arguments (if any) will be evaluated,
3787 * and proc will be applied to them. If proc does not really hold a
3788 * function object, this will be signalled as an error on the scheme
3789 * level. If the number of arguments does not match the number of arguments
3790 * that are allowed to be passed to proc, also an error on the scheme level
3791 * will be signalled. */
3792 PREP_APPLY (proc
, SCM_EOL
);
3793 if (SCM_NULLP (SCM_CDR (x
))) {
3796 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3797 switch (SCM_TYP7 (proc
))
3798 { /* no arguments given */
3799 case scm_tc7_subr_0
:
3800 RETURN (SCM_SUBRF (proc
) ());
3801 case scm_tc7_subr_1o
:
3802 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
3804 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
3805 case scm_tc7_rpsubr
:
3806 RETURN (SCM_BOOL_T
);
3808 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
3810 if (!SCM_SMOB_APPLICABLE_P (proc
))
3812 RETURN (SCM_SMOB_APPLY_0 (proc
));
3815 proc
= SCM_CCLO_SUBR (proc
);
3817 debug
.info
->a
.proc
= proc
;
3818 debug
.info
->a
.args
= scm_list_1 (arg1
);
3822 proc
= SCM_PROCEDURE (proc
);
3824 debug
.info
->a
.proc
= proc
;
3826 if (!SCM_CLOSUREP (proc
))
3829 case scm_tcs_closures
:
3831 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3832 if (SCM_CONSP (formals
))
3833 goto umwrongnumargs
;
3834 x
= SCM_CLOSURE_BODY (proc
);
3835 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
3836 goto nontoplevel_begin
;
3838 case scm_tcs_struct
:
3839 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3841 x
= SCM_ENTITY_PROCEDURE (proc
);
3845 else if (SCM_I_OPERATORP (proc
))
3848 proc
= (SCM_I_ENTITYP (proc
)
3849 ? SCM_ENTITY_PROCEDURE (proc
)
3850 : SCM_OPERATOR_PROCEDURE (proc
));
3852 debug
.info
->a
.proc
= proc
;
3853 debug
.info
->a
.args
= scm_list_1 (arg1
);
3859 case scm_tc7_subr_1
:
3860 case scm_tc7_subr_2
:
3861 case scm_tc7_subr_2o
:
3864 case scm_tc7_subr_3
:
3865 case scm_tc7_lsubr_2
:
3868 scm_wrong_num_args (proc
);
3871 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
3875 /* must handle macros by here */
3878 arg1
= EVALCAR (x
, env
);
3880 scm_wrong_num_args (proc
);
3882 debug
.info
->a
.args
= scm_list_1 (arg1
);
3890 evap1
: /* inputs: proc, arg1 */
3891 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3892 switch (SCM_TYP7 (proc
))
3893 { /* have one argument in arg1 */
3894 case scm_tc7_subr_2o
:
3895 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3896 case scm_tc7_subr_1
:
3897 case scm_tc7_subr_1o
:
3898 RETURN (SCM_SUBRF (proc
) (arg1
));
3900 if (SCM_INUMP (arg1
))
3902 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3904 else if (SCM_REALP (arg1
))
3906 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3908 else if (SCM_BIGP (arg1
))
3910 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3912 else if (SCM_FRACTIONP (arg1
))
3914 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
3916 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3917 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3920 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
3923 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
3924 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3925 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3930 case scm_tc7_rpsubr
:
3931 RETURN (SCM_BOOL_T
);
3933 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3936 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3938 RETURN (SCM_SUBRF (proc
) (scm_list_1 (arg1
)));
3941 if (!SCM_SMOB_APPLICABLE_P (proc
))
3943 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
3947 proc
= SCM_CCLO_SUBR (proc
);
3949 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
3950 debug
.info
->a
.proc
= proc
;
3954 proc
= SCM_PROCEDURE (proc
);
3956 debug
.info
->a
.proc
= proc
;
3958 if (!SCM_CLOSUREP (proc
))
3961 case scm_tcs_closures
:
3964 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3965 if (SCM_NULLP (formals
)
3966 || (SCM_CONSP (formals
) && SCM_CONSP (SCM_CDR (formals
))))
3967 goto umwrongnumargs
;
3968 x
= SCM_CLOSURE_BODY (proc
);
3970 env
= SCM_EXTEND_ENV (formals
,
3974 env
= SCM_EXTEND_ENV (formals
,
3978 goto nontoplevel_begin
;
3980 case scm_tcs_struct
:
3981 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3983 x
= SCM_ENTITY_PROCEDURE (proc
);
3985 arg1
= debug
.info
->a
.args
;
3987 arg1
= scm_list_1 (arg1
);
3991 else if (SCM_I_OPERATORP (proc
))
3995 proc
= (SCM_I_ENTITYP (proc
)
3996 ? SCM_ENTITY_PROCEDURE (proc
)
3997 : SCM_OPERATOR_PROCEDURE (proc
));
3999 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
4000 debug
.info
->a
.proc
= proc
;
4006 case scm_tc7_subr_2
:
4007 case scm_tc7_subr_0
:
4008 case scm_tc7_subr_3
:
4009 case scm_tc7_lsubr_2
:
4010 scm_wrong_num_args (proc
);
4016 arg2
= EVALCAR (x
, env
);
4018 scm_wrong_num_args (proc
);
4020 { /* have two or more arguments */
4022 debug
.info
->a
.args
= scm_list_2 (arg1
, arg2
);
4025 if (SCM_NULLP (x
)) {
4028 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4029 switch (SCM_TYP7 (proc
))
4030 { /* have two arguments */
4031 case scm_tc7_subr_2
:
4032 case scm_tc7_subr_2o
:
4033 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
4036 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4038 RETURN (SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
)));
4040 case scm_tc7_lsubr_2
:
4041 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
));
4042 case scm_tc7_rpsubr
:
4044 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
4046 if (!SCM_SMOB_APPLICABLE_P (proc
))
4048 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
));
4052 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
4053 scm_cons (proc
, debug
.info
->a
.args
),
4056 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
4057 scm_cons2 (proc
, arg1
,
4064 case scm_tcs_struct
:
4065 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4067 x
= SCM_ENTITY_PROCEDURE (proc
);
4069 arg1
= debug
.info
->a
.args
;
4071 arg1
= scm_list_2 (arg1
, arg2
);
4075 else if (SCM_I_OPERATORP (proc
))
4079 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
4080 ? SCM_ENTITY_PROCEDURE (proc
)
4081 : SCM_OPERATOR_PROCEDURE (proc
),
4082 scm_cons (proc
, debug
.info
->a
.args
),
4085 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
4086 ? SCM_ENTITY_PROCEDURE (proc
)
4087 : SCM_OPERATOR_PROCEDURE (proc
),
4088 scm_cons2 (proc
, arg1
,
4098 case scm_tc7_subr_0
:
4101 case scm_tc7_subr_1o
:
4102 case scm_tc7_subr_1
:
4103 case scm_tc7_subr_3
:
4104 scm_wrong_num_args (proc
);
4108 proc
= SCM_PROCEDURE (proc
);
4110 debug
.info
->a
.proc
= proc
;
4112 if (!SCM_CLOSUREP (proc
))
4115 case scm_tcs_closures
:
4118 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4119 if (SCM_NULLP (formals
)
4120 || (SCM_CONSP (formals
)
4121 && (SCM_NULLP (SCM_CDR (formals
))
4122 || (SCM_CONSP (SCM_CDR (formals
))
4123 && SCM_CONSP (SCM_CDDR (formals
))))))
4124 goto umwrongnumargs
;
4126 env
= SCM_EXTEND_ENV (formals
,
4130 env
= SCM_EXTEND_ENV (formals
,
4131 scm_list_2 (arg1
, arg2
),
4134 x
= SCM_CLOSURE_BODY (proc
);
4135 goto nontoplevel_begin
;
4140 scm_wrong_num_args (proc
);
4142 debug
.info
->a
.args
= scm_cons2 (arg1
, arg2
,
4143 deval_args (x
, env
, proc
,
4144 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
4148 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4149 switch (SCM_TYP7 (proc
))
4150 { /* have 3 or more arguments */
4152 case scm_tc7_subr_3
:
4153 if (!SCM_NULLP (SCM_CDR (x
)))
4154 scm_wrong_num_args (proc
);
4156 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4157 SCM_CADDR (debug
.info
->a
.args
)));
4159 arg1
= SCM_SUBRF(proc
)(arg1
, arg2
);
4160 arg2
= SCM_CDDR (debug
.info
->a
.args
);
4163 arg1
= SCM_SUBRF(proc
)(arg1
, SCM_CAR (arg2
));
4164 arg2
= SCM_CDR (arg2
);
4166 while (SCM_NIMP (arg2
));
4168 case scm_tc7_rpsubr
:
4169 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
4170 RETURN (SCM_BOOL_F
);
4171 arg1
= SCM_CDDR (debug
.info
->a
.args
);
4174 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (arg1
))))
4175 RETURN (SCM_BOOL_F
);
4176 arg2
= SCM_CAR (arg1
);
4177 arg1
= SCM_CDR (arg1
);
4179 while (SCM_NIMP (arg1
));
4180 RETURN (SCM_BOOL_T
);
4181 case scm_tc7_lsubr_2
:
4182 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4183 SCM_CDDR (debug
.info
->a
.args
)));
4185 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4187 if (!SCM_SMOB_APPLICABLE_P (proc
))
4189 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4190 SCM_CDDR (debug
.info
->a
.args
)));
4194 proc
= SCM_PROCEDURE (proc
);
4195 debug
.info
->a
.proc
= proc
;
4196 if (!SCM_CLOSUREP (proc
))
4199 case scm_tcs_closures
:
4201 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4202 if (SCM_NULLP (formals
)
4203 || (SCM_CONSP (formals
)
4204 && (SCM_NULLP (SCM_CDR (formals
))
4205 || (SCM_CONSP (SCM_CDR (formals
))
4206 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4207 goto umwrongnumargs
;
4208 SCM_SET_ARGSREADY (debug
);
4209 env
= SCM_EXTEND_ENV (formals
,
4212 x
= SCM_CLOSURE_BODY (proc
);
4213 goto nontoplevel_begin
;
4216 case scm_tc7_subr_3
:
4217 if (!SCM_NULLP (SCM_CDR (x
)))
4218 scm_wrong_num_args (proc
);
4220 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, EVALCAR (x
, env
)));
4222 arg1
= SCM_SUBRF (proc
) (arg1
, arg2
);
4225 arg1
= SCM_SUBRF(proc
)(arg1
, EVALCAR(x
, env
));
4228 while (!SCM_NULLP (x
));
4230 case scm_tc7_rpsubr
:
4231 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
4232 RETURN (SCM_BOOL_F
);
4235 arg1
= EVALCAR (x
, env
);
4236 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, arg1
)))
4237 RETURN (SCM_BOOL_F
);
4241 while (!SCM_NULLP (x
));
4242 RETURN (SCM_BOOL_T
);
4243 case scm_tc7_lsubr_2
:
4244 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
4246 RETURN (SCM_SUBRF (proc
) (scm_cons2 (arg1
,
4248 scm_eval_args (x
, env
, proc
))));
4250 if (!SCM_SMOB_APPLICABLE_P (proc
))
4252 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4253 scm_eval_args (x
, env
, proc
)));
4257 proc
= SCM_PROCEDURE (proc
);
4258 if (!SCM_CLOSUREP (proc
))
4261 case scm_tcs_closures
:
4263 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4264 if (SCM_NULLP (formals
)
4265 || (SCM_CONSP (formals
)
4266 && (SCM_NULLP (SCM_CDR (formals
))
4267 || (SCM_CONSP (SCM_CDR (formals
))
4268 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4269 goto umwrongnumargs
;
4270 env
= SCM_EXTEND_ENV (formals
,
4273 scm_eval_args (x
, env
, proc
)),
4275 x
= SCM_CLOSURE_BODY (proc
);
4276 goto nontoplevel_begin
;
4279 case scm_tcs_struct
:
4280 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4283 arg1
= debug
.info
->a
.args
;
4285 arg1
= scm_cons2 (arg1
, arg2
, scm_eval_args (x
, env
, proc
));
4287 x
= SCM_ENTITY_PROCEDURE (proc
);
4290 else if (SCM_I_OPERATORP (proc
))
4294 case scm_tc7_subr_2
:
4295 case scm_tc7_subr_1o
:
4296 case scm_tc7_subr_2o
:
4297 case scm_tc7_subr_0
:
4300 case scm_tc7_subr_1
:
4301 scm_wrong_num_args (proc
);
4309 if (scm_check_exit_p
&& SCM_TRAPS_P
)
4310 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
4312 SCM_CLEAR_TRACED_FRAME (debug
);
4313 if (SCM_CHEAPTRAPS_P
)
4314 arg1
= scm_make_debugobj (&debug
);
4318 SCM val
= scm_make_continuation (&first
);
4329 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
4333 scm_last_debug_frame
= debug
.prev
;
4339 /* SECTION: This code is compiled once.
4346 /* Simple procedure calls
4350 scm_call_0 (SCM proc
)
4352 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
4356 scm_call_1 (SCM proc
, SCM arg1
)
4358 return scm_apply (proc
, arg1
, scm_listofnull
);
4362 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
4364 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
4368 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
4370 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
4374 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
4376 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
4377 scm_cons (arg4
, scm_listofnull
)));
4380 /* Simple procedure applies
4384 scm_apply_0 (SCM proc
, SCM args
)
4386 return scm_apply (proc
, args
, SCM_EOL
);
4390 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
4392 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
4396 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
4398 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
4402 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
4404 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
4408 /* This code processes the arguments to apply:
4410 (apply PROC ARG1 ... ARGS)
4412 Given a list (ARG1 ... ARGS), this function conses the ARG1
4413 ... arguments onto the front of ARGS, and returns the resulting
4414 list. Note that ARGS is a list; thus, the argument to this
4415 function is a list whose last element is a list.
4417 Apply calls this function, and applies PROC to the elements of the
4418 result. apply:nconc2last takes care of building the list of
4419 arguments, given (ARG1 ... ARGS).
4421 Rather than do new consing, apply:nconc2last destroys its argument.
4422 On that topic, this code came into my care with the following
4423 beautifully cryptic comment on that topic: "This will only screw
4424 you if you do (scm_apply scm_apply '( ... ))" If you know what
4425 they're referring to, send me a patch to this comment. */
4427 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
4429 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
4430 "conses the @var{arg1} @dots{} arguments onto the front of\n"
4431 "@var{args}, and returns the resulting list. Note that\n"
4432 "@var{args} is a list; thus, the argument to this function is\n"
4433 "a list whose last element is a list.\n"
4434 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
4435 "destroys its argument, so use with care.")
4436 #define FUNC_NAME s_scm_nconc2last
4439 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
4441 while (!SCM_NULLP (SCM_CDR (*lloc
))) /* Perhaps should be
4442 SCM_NULL_OR_NIL_P, but not
4443 needed in 99.99% of cases,
4444 and it could seriously hurt
4445 performance. - Neil */
4446 lloc
= SCM_CDRLOC (*lloc
);
4447 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
4448 *lloc
= SCM_CAR (*lloc
);
4456 /* SECTION: When DEVAL is defined this code yields scm_dapply.
4457 * It is compiled twice.
4462 scm_apply (SCM proc
, SCM arg1
, SCM args
)
4468 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
4473 /* Apply a function to a list of arguments.
4475 This function is exported to the Scheme level as taking two
4476 required arguments and a tail argument, as if it were:
4477 (lambda (proc arg1 . args) ...)
4478 Thus, if you just have a list of arguments to pass to a procedure,
4479 pass the list as ARG1, and '() for ARGS. If you have some fixed
4480 args, pass the first as ARG1, then cons any remaining fixed args
4481 onto the front of your argument list, and pass that as ARGS. */
4484 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
4487 scm_t_debug_frame debug
;
4488 scm_t_debug_info debug_vect_body
;
4489 debug
.prev
= scm_last_debug_frame
;
4490 debug
.status
= SCM_APPLYFRAME
;
4491 debug
.vect
= &debug_vect_body
;
4492 debug
.vect
[0].a
.proc
= proc
;
4493 debug
.vect
[0].a
.args
= SCM_EOL
;
4494 scm_last_debug_frame
= &debug
;
4496 if (scm_debug_mode_p
)
4497 return scm_dapply (proc
, arg1
, args
);
4500 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
4502 /* If ARGS is the empty list, then we're calling apply with only two
4503 arguments --- ARG1 is the list of arguments for PROC. Whatever
4504 the case, futz with things so that ARG1 is the first argument to
4505 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
4508 Setting the debug apply frame args this way is pretty messy.
4509 Perhaps we should store arg1 and args directly in the frame as
4510 received, and let scm_frame_arguments unpack them, because that's
4511 a relatively rare operation. This works for now; if the Guile
4512 developer archives are still around, see Mikael's post of
4514 if (SCM_NULLP (args
))
4516 if (SCM_NULLP (arg1
))
4518 arg1
= SCM_UNDEFINED
;
4520 debug
.vect
[0].a
.args
= SCM_EOL
;
4526 debug
.vect
[0].a
.args
= arg1
;
4528 args
= SCM_CDR (arg1
);
4529 arg1
= SCM_CAR (arg1
);
4534 args
= scm_nconc2last (args
);
4536 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4540 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
4543 if (SCM_CHEAPTRAPS_P
)
4544 tmp
= scm_make_debugobj (&debug
);
4549 tmp
= scm_make_continuation (&first
);
4554 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
4561 switch (SCM_TYP7 (proc
))
4563 case scm_tc7_subr_2o
:
4564 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
4565 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4566 case scm_tc7_subr_2
:
4567 if (SCM_NULLP (args
) || !SCM_NULLP (SCM_CDR (args
)))
4568 scm_wrong_num_args (proc
);
4569 args
= SCM_CAR (args
);
4570 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4571 case scm_tc7_subr_0
:
4572 if (!SCM_UNBNDP (arg1
))
4573 scm_wrong_num_args (proc
);
4575 RETURN (SCM_SUBRF (proc
) ());
4576 case scm_tc7_subr_1
:
4577 if (SCM_UNBNDP (arg1
))
4578 scm_wrong_num_args (proc
);
4579 case scm_tc7_subr_1o
:
4580 if (!SCM_NULLP (args
))
4581 scm_wrong_num_args (proc
);
4583 RETURN (SCM_SUBRF (proc
) (arg1
));
4585 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
4586 scm_wrong_num_args (proc
);
4587 if (SCM_INUMP (arg1
))
4589 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
4591 else if (SCM_REALP (arg1
))
4593 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4595 else if (SCM_BIGP (arg1
))
4597 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4599 else if (SCM_FRACTIONP (arg1
))
4601 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4603 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4604 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4606 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
4607 scm_wrong_num_args (proc
);
4609 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
4612 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
4613 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4614 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
4619 case scm_tc7_subr_3
:
4620 if (SCM_NULLP (args
)
4621 || SCM_NULLP (SCM_CDR (args
))
4622 || !SCM_NULLP (SCM_CDDR (args
)))
4623 scm_wrong_num_args (proc
);
4625 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
4628 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
4630 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
4632 case scm_tc7_lsubr_2
:
4633 if (!SCM_CONSP (args
))
4634 scm_wrong_num_args (proc
);
4636 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4638 if (SCM_NULLP (args
))
4639 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4640 while (SCM_NIMP (args
))
4642 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
4643 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
4644 args
= SCM_CDR (args
);
4647 case scm_tc7_rpsubr
:
4648 if (SCM_NULLP (args
))
4649 RETURN (SCM_BOOL_T
);
4650 while (SCM_NIMP (args
))
4652 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
4653 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
4654 RETURN (SCM_BOOL_F
);
4655 arg1
= SCM_CAR (args
);
4656 args
= SCM_CDR (args
);
4658 RETURN (SCM_BOOL_T
);
4659 case scm_tcs_closures
:
4661 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4663 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4665 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
4666 scm_wrong_num_args (proc
);
4668 /* Copy argument list */
4673 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
4674 for (arg1
= SCM_CDR (arg1
); SCM_CONSP (arg1
); arg1
= SCM_CDR (arg1
))
4676 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
));
4679 SCM_SETCDR (tl
, arg1
);
4682 args
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4685 proc
= SCM_CLOSURE_BODY (proc
);
4687 arg1
= SCM_CDR (proc
);
4688 while (!SCM_NULLP (arg1
))
4690 if (SCM_IMP (SCM_CAR (proc
)))
4692 if (SCM_ISYMP (SCM_CAR (proc
)))
4694 scm_rec_mutex_lock (&source_mutex
);
4695 /* check for race condition */
4696 if (SCM_ISYMP (SCM_CAR (proc
)))
4697 m_expand_body (proc
, args
);
4698 scm_rec_mutex_unlock (&source_mutex
);
4702 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
4705 (void) EVAL (SCM_CAR (proc
), args
);
4707 arg1
= SCM_CDR (proc
);
4709 RETURN (EVALCAR (proc
, args
));
4711 if (!SCM_SMOB_APPLICABLE_P (proc
))
4713 if (SCM_UNBNDP (arg1
))
4714 RETURN (SCM_SMOB_APPLY_0 (proc
));
4715 else if (SCM_NULLP (args
))
4716 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
4717 else if (SCM_NULLP (SCM_CDR (args
)))
4718 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
4720 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4723 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4725 proc
= SCM_CCLO_SUBR (proc
);
4726 debug
.vect
[0].a
.proc
= proc
;
4727 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4729 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4731 proc
= SCM_CCLO_SUBR (proc
);
4735 proc
= SCM_PROCEDURE (proc
);
4737 debug
.vect
[0].a
.proc
= proc
;
4740 case scm_tcs_struct
:
4741 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4744 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4746 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4748 RETURN (scm_apply_generic (proc
, args
));
4750 else if (SCM_I_OPERATORP (proc
))
4754 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4756 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4759 proc
= (SCM_I_ENTITYP (proc
)
4760 ? SCM_ENTITY_PROCEDURE (proc
)
4761 : SCM_OPERATOR_PROCEDURE (proc
));
4763 debug
.vect
[0].a
.proc
= proc
;
4764 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4766 if (SCM_NIMP (proc
))
4775 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
4779 if (scm_check_exit_p
&& SCM_TRAPS_P
)
4780 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
4782 SCM_CLEAR_TRACED_FRAME (debug
);
4783 if (SCM_CHEAPTRAPS_P
)
4784 arg1
= scm_make_debugobj (&debug
);
4788 SCM val
= scm_make_continuation (&first
);
4799 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
4803 scm_last_debug_frame
= debug
.prev
;
4809 /* SECTION: The rest of this file is only read once.
4816 * Trampolines make it possible to move procedure application dispatch
4817 * outside inner loops. The motivation was clean implementation of
4818 * efficient replacements of R5RS primitives in SRFI-1.
4820 * The semantics is clear: scm_trampoline_N returns an optimized
4821 * version of scm_call_N (or NULL if the procedure isn't applicable
4824 * Applying the optimization to map and for-each increased efficiency
4825 * noticeably. For example, (map abs ls) is now 8 times faster than
4830 call_subr0_0 (SCM proc
)
4832 return SCM_SUBRF (proc
) ();
4836 call_subr1o_0 (SCM proc
)
4838 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
4842 call_lsubr_0 (SCM proc
)
4844 return SCM_SUBRF (proc
) (SCM_EOL
);
4848 scm_i_call_closure_0 (SCM proc
)
4850 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4853 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
4858 scm_trampoline_0 (SCM proc
)
4860 scm_t_trampoline_0 trampoline
;
4865 switch (SCM_TYP7 (proc
))
4867 case scm_tc7_subr_0
:
4868 trampoline
= call_subr0_0
;
4870 case scm_tc7_subr_1o
:
4871 trampoline
= call_subr1o_0
;
4874 trampoline
= call_lsubr_0
;
4876 case scm_tcs_closures
:
4878 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4879 if (SCM_NULLP (formals
) || !SCM_CONSP (formals
))
4880 trampoline
= scm_i_call_closure_0
;
4885 case scm_tcs_struct
:
4886 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4887 trampoline
= scm_call_generic_0
;
4888 else if (SCM_I_OPERATORP (proc
))
4889 trampoline
= scm_call_0
;
4894 if (SCM_SMOB_APPLICABLE_P (proc
))
4895 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
4900 case scm_tc7_rpsubr
:
4903 trampoline
= scm_call_0
;
4906 return NULL
; /* not applicable on zero arguments */
4908 /* We only reach this point if a valid trampoline was determined. */
4910 /* If debugging is enabled, we want to see all calls to proc on the stack.
4911 * Thus, we replace the trampoline shortcut with scm_call_0. */
4912 if (scm_debug_mode_p
)
4919 call_subr1_1 (SCM proc
, SCM arg1
)
4921 return SCM_SUBRF (proc
) (arg1
);
4925 call_subr2o_1 (SCM proc
, SCM arg1
)
4927 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
4931 call_lsubr_1 (SCM proc
, SCM arg1
)
4933 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
4937 call_dsubr_1 (SCM proc
, SCM arg1
)
4939 if (SCM_INUMP (arg1
))
4941 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
4943 else if (SCM_REALP (arg1
))
4945 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4947 else if (SCM_BIGP (arg1
))
4949 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4951 else if (SCM_FRACTIONP (arg1
))
4953 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4955 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4956 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4960 call_cxr_1 (SCM proc
, SCM arg1
)
4962 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
4965 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
4966 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4967 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
4974 call_closure_1 (SCM proc
, SCM arg1
)
4976 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4979 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
4984 scm_trampoline_1 (SCM proc
)
4986 scm_t_trampoline_1 trampoline
;
4991 switch (SCM_TYP7 (proc
))
4993 case scm_tc7_subr_1
:
4994 case scm_tc7_subr_1o
:
4995 trampoline
= call_subr1_1
;
4997 case scm_tc7_subr_2o
:
4998 trampoline
= call_subr2o_1
;
5001 trampoline
= call_lsubr_1
;
5004 trampoline
= call_dsubr_1
;
5007 trampoline
= call_cxr_1
;
5009 case scm_tcs_closures
:
5011 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5012 if (!SCM_NULLP (formals
)
5013 && (!SCM_CONSP (formals
) || !SCM_CONSP (SCM_CDR (formals
))))
5014 trampoline
= call_closure_1
;
5019 case scm_tcs_struct
:
5020 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5021 trampoline
= scm_call_generic_1
;
5022 else if (SCM_I_OPERATORP (proc
))
5023 trampoline
= scm_call_1
;
5028 if (SCM_SMOB_APPLICABLE_P (proc
))
5029 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
5034 case scm_tc7_rpsubr
:
5037 trampoline
= scm_call_1
;
5040 return NULL
; /* not applicable on one arg */
5042 /* We only reach this point if a valid trampoline was determined. */
5044 /* If debugging is enabled, we want to see all calls to proc on the stack.
5045 * Thus, we replace the trampoline shortcut with scm_call_1. */
5046 if (scm_debug_mode_p
)
5053 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
5055 return SCM_SUBRF (proc
) (arg1
, arg2
);
5059 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
5061 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
5065 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
5067 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
5071 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
5073 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
5074 scm_list_2 (arg1
, arg2
),
5076 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
5081 scm_trampoline_2 (SCM proc
)
5083 scm_t_trampoline_2 trampoline
;
5088 switch (SCM_TYP7 (proc
))
5090 case scm_tc7_subr_2
:
5091 case scm_tc7_subr_2o
:
5092 case scm_tc7_rpsubr
:
5094 trampoline
= call_subr2_2
;
5096 case scm_tc7_lsubr_2
:
5097 trampoline
= call_lsubr2_2
;
5100 trampoline
= call_lsubr_2
;
5102 case scm_tcs_closures
:
5104 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5105 if (!SCM_NULLP (formals
)
5106 && (!SCM_CONSP (formals
)
5107 || (!SCM_NULLP (SCM_CDR (formals
))
5108 && (!SCM_CONSP (SCM_CDR (formals
))
5109 || !SCM_CONSP (SCM_CDDR (formals
))))))
5110 trampoline
= call_closure_2
;
5115 case scm_tcs_struct
:
5116 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5117 trampoline
= scm_call_generic_2
;
5118 else if (SCM_I_OPERATORP (proc
))
5119 trampoline
= scm_call_2
;
5124 if (SCM_SMOB_APPLICABLE_P (proc
))
5125 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
5131 trampoline
= scm_call_2
;
5134 return NULL
; /* not applicable on two args */
5136 /* We only reach this point if a valid trampoline was determined. */
5138 /* If debugging is enabled, we want to see all calls to proc on the stack.
5139 * Thus, we replace the trampoline shortcut with scm_call_2. */
5140 if (scm_debug_mode_p
)
5146 /* Typechecking for multi-argument MAP and FOR-EACH.
5148 Verify that each element of the vector ARGV, except for the first,
5149 is a proper list whose length is LEN. Attribute errors to WHO,
5150 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
5152 check_map_args (SCM argv
,
5159 SCM
const *ve
= SCM_VELTS (argv
);
5162 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
5164 long elt_len
= scm_ilength (ve
[i
]);
5169 scm_apply_generic (gf
, scm_cons (proc
, args
));
5171 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
5175 scm_out_of_range_pos (who
, ve
[i
], SCM_MAKINUM (i
+ 2));
5178 scm_remember_upto_here_1 (argv
);
5182 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
5184 /* Note: Currently, scm_map applies PROC to the argument list(s)
5185 sequentially, starting with the first element(s). This is used in
5186 evalext.c where the Scheme procedure `map-in-order', which guarantees
5187 sequential behaviour, is implemented using scm_map. If the
5188 behaviour changes, we need to update `map-in-order'.
5192 scm_map (SCM proc
, SCM arg1
, SCM args
)
5193 #define FUNC_NAME s_map
5198 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
5200 len
= scm_ilength (arg1
);
5201 SCM_GASSERTn (len
>= 0,
5202 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
5203 SCM_VALIDATE_REST_ARGUMENT (args
);
5204 if (SCM_NULLP (args
))
5206 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5207 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
5208 while (SCM_NIMP (arg1
))
5210 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
5211 pres
= SCM_CDRLOC (*pres
);
5212 arg1
= SCM_CDR (arg1
);
5216 if (SCM_NULLP (SCM_CDR (args
)))
5218 SCM arg2
= SCM_CAR (args
);
5219 int len2
= scm_ilength (arg2
);
5220 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5222 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
5223 SCM_GASSERTn (len2
>= 0,
5224 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
5226 SCM_OUT_OF_RANGE (3, arg2
);
5227 while (SCM_NIMP (arg1
))
5229 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
5230 pres
= SCM_CDRLOC (*pres
);
5231 arg1
= SCM_CDR (arg1
);
5232 arg2
= SCM_CDR (arg2
);
5236 arg1
= scm_cons (arg1
, args
);
5237 args
= scm_vector (arg1
);
5238 ve
= SCM_VELTS (args
);
5239 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
5243 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5245 if (SCM_IMP (ve
[i
]))
5247 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
5248 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
5250 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
5251 pres
= SCM_CDRLOC (*pres
);
5257 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
5260 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
5261 #define FUNC_NAME s_for_each
5263 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
5265 len
= scm_ilength (arg1
);
5266 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
5267 SCM_ARG2
, s_for_each
);
5268 SCM_VALIDATE_REST_ARGUMENT (args
);
5269 if (SCM_NULLP (args
))
5271 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5272 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
5273 while (SCM_NIMP (arg1
))
5275 call (proc
, SCM_CAR (arg1
));
5276 arg1
= SCM_CDR (arg1
);
5278 return SCM_UNSPECIFIED
;
5280 if (SCM_NULLP (SCM_CDR (args
)))
5282 SCM arg2
= SCM_CAR (args
);
5283 int len2
= scm_ilength (arg2
);
5284 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5285 SCM_GASSERTn (call
, g_for_each
,
5286 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
5287 SCM_GASSERTn (len2
>= 0, g_for_each
,
5288 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
5290 SCM_OUT_OF_RANGE (3, arg2
);
5291 while (SCM_NIMP (arg1
))
5293 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
5294 arg1
= SCM_CDR (arg1
);
5295 arg2
= SCM_CDR (arg2
);
5297 return SCM_UNSPECIFIED
;
5299 arg1
= scm_cons (arg1
, args
);
5300 args
= scm_vector (arg1
);
5301 ve
= SCM_VELTS (args
);
5302 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
5306 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5308 if (SCM_IMP (ve
[i
]))
5309 return SCM_UNSPECIFIED
;
5310 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
5311 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
5313 scm_apply (proc
, arg1
, SCM_EOL
);
5320 scm_closure (SCM code
, SCM env
)
5323 SCM closcar
= scm_cons (code
, SCM_EOL
);
5324 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
5325 scm_remember_upto_here (closcar
);
5330 scm_t_bits scm_tc16_promise
;
5333 scm_makprom (SCM code
)
5335 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
5337 scm_make_rec_mutex ());
5341 promise_free (SCM promise
)
5343 scm_rec_mutex_free (SCM_PROMISE_MUTEX (promise
));
5348 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
5350 int writingp
= SCM_WRITINGP (pstate
);
5351 scm_puts ("#<promise ", port
);
5352 SCM_SET_WRITINGP (pstate
, 1);
5353 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
5354 SCM_SET_WRITINGP (pstate
, writingp
);
5355 scm_putc ('>', port
);
5359 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
5361 "If the promise @var{x} has not been computed yet, compute and\n"
5362 "return @var{x}, otherwise just return the previously computed\n"
5364 #define FUNC_NAME s_scm_force
5366 SCM_VALIDATE_SMOB (1, promise
, promise
);
5367 scm_rec_mutex_lock (SCM_PROMISE_MUTEX (promise
));
5368 if (!SCM_PROMISE_COMPUTED_P (promise
))
5370 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
5371 if (!SCM_PROMISE_COMPUTED_P (promise
))
5373 SCM_SET_PROMISE_DATA (promise
, ans
);
5374 SCM_SET_PROMISE_COMPUTED (promise
);
5377 scm_rec_mutex_unlock (SCM_PROMISE_MUTEX (promise
));
5378 return SCM_PROMISE_DATA (promise
);
5383 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
5385 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
5386 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
5387 #define FUNC_NAME s_scm_promise_p
5389 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
5394 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
5395 (SCM xorig
, SCM x
, SCM y
),
5396 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
5397 "Any source properties associated with @var{xorig} are also associated\n"
5398 "with the new pair.")
5399 #define FUNC_NAME s_scm_cons_source
5402 z
= scm_cons (x
, y
);
5403 /* Copy source properties possibly associated with xorig. */
5404 p
= scm_whash_lookup (scm_source_whash
, xorig
);
5406 scm_whash_insert (scm_source_whash
, z
, p
);
5412 /* The function scm_copy_tree is used to copy an expression tree to allow the
5413 * memoizer to modify the expression during memoization. scm_copy_tree
5414 * creates deep copies of pairs and vectors, but not of any other data types,
5415 * since only pairs and vectors will be parsed by the memoizer.
5417 * To avoid infinite recursion due to cyclic structures, the hare-and-tortoise
5418 * pattern is used to detect cycles. In fact, the pattern is used in two
5419 * dimensions, vertical (indicated in the code by the variable names 'hare'
5420 * and 'tortoise') and horizontal ('rabbit' and 'turtle'). In both
5421 * dimensions, the hare/rabbit will take two steps when the tortoise/turtle
5424 * The vertical dimension corresponds to recursive calls to function
5425 * copy_tree: This happens when descending into vector elements, into cars of
5426 * lists and into the cdr of an improper list. In this dimension, the
5427 * tortoise follows the hare by using the processor stack: Every stack frame
5428 * will hold an instance of struct t_trace. These instances are connected in
5429 * a way that represents the trace of the hare, which thus can be followed by
5430 * the tortoise. The tortoise will always point to struct t_trace instances
5431 * relating to SCM objects that have already been copied. Thus, a cycle is
5432 * detected if the tortoise and the hare point to the same object,
5434 * The horizontal dimension is within one execution of copy_tree, when the
5435 * function cdr's along the pairs of a list. This is the standard
5436 * hare-and-tortoise implementation, found several times in guile. */
5439 struct t_trace
*trace
; // These pointers form a trace along the stack.
5440 SCM obj
; // The object handled at the respective stack frame.
5445 struct t_trace
*const hare
,
5446 struct t_trace
*tortoise
,
5447 unsigned int tortoise_delay
)
5449 if (!SCM_CONSP (hare
->obj
) && !SCM_VECTORP (hare
->obj
))
5455 /* Prepare the trace along the stack. */
5456 struct t_trace new_hare
;
5457 hare
->trace
= &new_hare
;
5459 /* The tortoise will make its step after the delay has elapsed. Note
5460 * that in contrast to the typical hare-and-tortoise pattern, the step
5461 * of the tortoise happens before the hare takes its steps. This is, in
5462 * principle, no problem, except for the start of the algorithm: Then,
5463 * it has to be made sure that the hare actually gets its advantage of
5465 if (tortoise_delay
== 0)
5468 tortoise
= tortoise
->trace
;
5469 ASSERT_SYNTAX (!SCM_EQ_P (hare
->obj
, tortoise
->obj
),
5470 s_bad_expression
, hare
->obj
);
5477 if (SCM_VECTORP (hare
->obj
))
5479 const unsigned long int length
= SCM_VECTOR_LENGTH (hare
->obj
);
5480 const SCM new_vector
= scm_c_make_vector (length
, SCM_UNSPECIFIED
);
5482 /* Each vector element is copied by recursing into copy_tree, having
5483 * the tortoise follow the hare into the depths of the stack. */
5484 unsigned long int i
;
5485 for (i
= 0; i
< length
; ++i
)
5488 new_hare
.obj
= SCM_VECTOR_REF (hare
->obj
, i
);
5489 new_element
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5490 SCM_VECTOR_SET (new_vector
, i
, new_element
);
5495 else // SCM_CONSP (hare->obj)
5500 SCM rabbit
= hare
->obj
;
5501 SCM turtle
= hare
->obj
;
5505 /* The first pair of the list is treated specially, in order to
5506 * preserve a potential source code position. */
5507 result
= tail
= scm_cons_source (rabbit
, SCM_EOL
, SCM_EOL
);
5508 new_hare
.obj
= SCM_CAR (rabbit
);
5509 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5510 SCM_SETCAR (tail
, copy
);
5512 /* The remaining pairs of the list are copied by, horizontally,
5513 * having the turtle follow the rabbit, and, vertically, having the
5514 * tortoise follow the hare into the depths of the stack. */
5515 rabbit
= SCM_CDR (rabbit
);
5516 while (SCM_CONSP (rabbit
))
5518 new_hare
.obj
= SCM_CAR (rabbit
);
5519 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5520 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
5521 tail
= SCM_CDR (tail
);
5523 rabbit
= SCM_CDR (rabbit
);
5524 if (SCM_CONSP (rabbit
))
5526 new_hare
.obj
= SCM_CAR (rabbit
);
5527 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5528 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
5529 tail
= SCM_CDR (tail
);
5530 rabbit
= SCM_CDR (rabbit
);
5532 turtle
= SCM_CDR (turtle
);
5533 ASSERT_SYNTAX (!SCM_EQ_P (rabbit
, turtle
),
5534 s_bad_expression
, rabbit
);
5538 /* We have to recurse into copy_tree again for the last cdr, in
5539 * order to handle the situation that it holds a vector. */
5540 new_hare
.obj
= rabbit
;
5541 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5542 SCM_SETCDR (tail
, copy
);
5549 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
5551 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
5552 "the new data structure. @code{copy-tree} recurses down the\n"
5553 "contents of both pairs and vectors (since both cons cells and vector\n"
5554 "cells may point to arbitrary objects), and stops recursing when it hits\n"
5555 "any other object.")
5556 #define FUNC_NAME s_scm_copy_tree
5558 /* Prepare the trace along the stack. */
5559 struct t_trace trace
;
5562 /* In function copy_tree, if the tortoise makes its step, it will do this
5563 * before the hare has the chance to move. Thus, we have to make sure that
5564 * the very first step of the tortoise will not happen after the hare has
5565 * really made two steps. This is achieved by passing '2' as the initial
5566 * delay for the tortoise. NOTE: Since cycles are unlikely, giving the hare
5567 * a bigger advantage may improve performance slightly. */
5568 return copy_tree (&trace
, &trace
, 2);
5573 /* We have three levels of EVAL here:
5575 - scm_i_eval (exp, env)
5577 evaluates EXP in environment ENV. ENV is a lexical environment
5578 structure as used by the actual tree code evaluator. When ENV is
5579 a top-level environment, then changes to the current module are
5580 tracked by updating ENV so that it continues to be in sync with
5583 - scm_primitive_eval (exp)
5585 evaluates EXP in the top-level environment as determined by the
5586 current module. This is done by constructing a suitable
5587 environment and calling scm_i_eval. Thus, changes to the
5588 top-level module are tracked normally.
5590 - scm_eval (exp, mod)
5592 evaluates EXP while MOD is the current module. This is done by
5593 setting the current module to MOD, invoking scm_primitive_eval on
5594 EXP, and then restoring the current module to the value it had
5595 previously. That is, while EXP is evaluated, changes to the
5596 current module are tracked, but these changes do not persist when
5599 For each level of evals, there are two variants, distinguished by a
5600 _x suffix: the ordinary variant does not modify EXP while the _x
5601 variant can destructively modify EXP into something completely
5602 unintelligible. A Scheme data structure passed as EXP to one of the
5603 _x variants should not ever be used again for anything. So when in
5604 doubt, use the ordinary variant.
5609 scm_i_eval_x (SCM exp
, SCM env
)
5611 if (SCM_SYMBOLP (exp
))
5612 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
5614 return SCM_XEVAL (exp
, env
);
5618 scm_i_eval (SCM exp
, SCM env
)
5620 exp
= scm_copy_tree (exp
);
5621 if (SCM_SYMBOLP (exp
))
5622 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
5624 return SCM_XEVAL (exp
, env
);
5628 scm_primitive_eval_x (SCM exp
)
5631 SCM transformer
= scm_current_module_transformer ();
5632 if (SCM_NIMP (transformer
))
5633 exp
= scm_call_1 (transformer
, exp
);
5634 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5635 return scm_i_eval_x (exp
, env
);
5638 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
5640 "Evaluate @var{exp} in the top-level environment specified by\n"
5641 "the current module.")
5642 #define FUNC_NAME s_scm_primitive_eval
5645 SCM transformer
= scm_current_module_transformer ();
5646 if (SCM_NIMP (transformer
))
5647 exp
= scm_call_1 (transformer
, exp
);
5648 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5649 return scm_i_eval (exp
, env
);
5654 /* Eval does not take the second arg optionally. This is intentional
5655 * in order to be R5RS compatible, and to prepare for the new module
5656 * system, where we would like to make the choice of evaluation
5657 * environment explicit. */
5660 change_environment (void *data
)
5662 SCM pair
= SCM_PACK (data
);
5663 SCM new_module
= SCM_CAR (pair
);
5664 SCM old_module
= scm_current_module ();
5665 SCM_SETCDR (pair
, old_module
);
5666 scm_set_current_module (new_module
);
5670 restore_environment (void *data
)
5672 SCM pair
= SCM_PACK (data
);
5673 SCM old_module
= SCM_CDR (pair
);
5674 SCM new_module
= scm_current_module ();
5675 SCM_SETCAR (pair
, new_module
);
5676 scm_set_current_module (old_module
);
5680 inner_eval_x (void *data
)
5682 return scm_primitive_eval_x (SCM_PACK(data
));
5686 scm_eval_x (SCM exp
, SCM module
)
5687 #define FUNC_NAME "eval!"
5689 SCM_VALIDATE_MODULE (2, module
);
5691 return scm_internal_dynamic_wind
5692 (change_environment
, inner_eval_x
, restore_environment
,
5693 (void *) SCM_UNPACK (exp
),
5694 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
5699 inner_eval (void *data
)
5701 return scm_primitive_eval (SCM_PACK(data
));
5704 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
5705 (SCM exp
, SCM module
),
5706 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
5707 "in the top-level environment specified by @var{module}.\n"
5708 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
5709 "@var{module} is made the current module. The current module\n"
5710 "is reset to its previous value when @var{eval} returns.")
5711 #define FUNC_NAME s_scm_eval
5713 SCM_VALIDATE_MODULE (2, module
);
5715 return scm_internal_dynamic_wind
5716 (change_environment
, inner_eval
, restore_environment
,
5717 (void *) SCM_UNPACK (exp
),
5718 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
5723 /* At this point, deval and scm_dapply are generated.
5730 #if (SCM_ENABLE_DEPRECATED == 1)
5732 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5733 SCM
scm_ceval (SCM x
, SCM env
)
5736 return ceval (x
, env
);
5737 else if (SCM_SYMBOLP (x
))
5738 return *scm_lookupcar (scm_cons (x
, SCM_UNDEFINED
), env
, 1);
5740 return SCM_XEVAL (x
, env
);
5743 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5744 SCM
scm_deval (SCM x
, SCM env
)
5747 return deval (x
, env
);
5748 else if (SCM_SYMBOLP (x
))
5749 return *scm_lookupcar (scm_cons (x
, SCM_UNDEFINED
), env
, 1);
5751 return SCM_XEVAL (x
, env
);
5755 dispatching_eval (SCM x
, SCM env
)
5757 if (scm_debug_mode_p
)
5758 return scm_deval (x
, env
);
5760 return scm_ceval (x
, env
);
5763 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5764 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
) = dispatching_eval
;
5772 scm_init_opts (scm_evaluator_traps
,
5773 scm_evaluator_trap_table
,
5774 SCM_N_EVALUATOR_TRAPS
);
5775 scm_init_opts (scm_eval_options_interface
,
5777 SCM_N_EVAL_OPTIONS
);
5779 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
5780 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
5781 scm_set_smob_free (scm_tc16_promise
, promise_free
);
5782 scm_set_smob_print (scm_tc16_promise
, promise_print
);
5784 undefineds
= scm_list_1 (SCM_UNDEFINED
);
5785 SCM_SETCDR (undefineds
, undefineds
);
5786 scm_permanent_object (undefineds
);
5788 scm_listofnull
= scm_list_1 (SCM_EOL
);
5790 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
5791 scm_permanent_object (f_apply
);
5793 #include "libguile/eval.x"
5795 scm_add_feature ("delay");