1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
20 /* This file is read twice in order to produce debugging versions of
21 * scm_ceval and scm_apply. These functions, scm_deval and
22 * scm_dapply, are produced when we define the preprocessor macro
23 * DEVAL. The file is divided into sections which are treated
24 * differently with respect to DEVAL. The heads of these sections are
25 * marked with the string "SECTION:".
28 /* SECTION: This code is compiled once.
35 #include "libguile/__scm.h"
39 /* AIX requires this to be the first thing in the file. The #pragma
40 directive is indented so pre-ANSI compilers will ignore it, rather
49 # ifndef alloca /* predefined by HP cc +Olibcalls */
56 #include "libguile/_scm.h"
57 #include "libguile/alist.h"
58 #include "libguile/async.h"
59 #include "libguile/continuations.h"
60 #include "libguile/debug.h"
61 #include "libguile/deprecation.h"
62 #include "libguile/dynwind.h"
63 #include "libguile/eq.h"
64 #include "libguile/feature.h"
65 #include "libguile/fluids.h"
66 #include "libguile/futures.h"
67 #include "libguile/goops.h"
68 #include "libguile/hash.h"
69 #include "libguile/hashtab.h"
70 #include "libguile/lang.h"
71 #include "libguile/list.h"
72 #include "libguile/macros.h"
73 #include "libguile/modules.h"
74 #include "libguile/objects.h"
75 #include "libguile/ports.h"
76 #include "libguile/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
142 static const char s_mixed_body_forms
[] = "Mixed definitions and expressions in";
144 /* Case or cond expressions must have at least one clause. If a case or cond
145 * expression without any clauses is detected, a 'Missing clauses' error is
147 static const char s_missing_clauses
[] = "Missing clauses";
149 /* If there is an 'else' clause in a case or a cond statement, it must be the
150 * last clause. If after the 'else' case clause further clauses are detected,
151 * a 'Misplaced else clause' error is signalled. */
152 static const char s_misplaced_else_clause
[] = "Misplaced else clause";
154 /* If a case clause is detected that is not in the format
155 * (<label(s)> <expression1> <expression2> ...)
156 * a 'Bad case clause' error is signalled. */
157 static const char s_bad_case_clause
[] = "Bad case clause";
159 /* If a case clause is detected where the <label(s)> element is neither a
160 * proper list nor (in case of the last clause) the syntactic keyword 'else',
161 * a 'Bad case labels' error is signalled. Note: If you encounter this error
162 * for an else-clause which seems to be syntactically correct, check if 'else'
163 * is really a syntactic keyword in that context. If 'else' is bound in the
164 * local or global environment, it is not considered a syntactic keyword, but
165 * will be treated as any other variable. */
166 static const char s_bad_case_labels
[] = "Bad case labels";
168 /* In a case statement all labels have to be distinct. If in a case statement
169 * a label occurs more than once, a 'Duplicate case label' error is
171 static const char s_duplicate_case_label
[] = "Duplicate case label";
173 /* If a cond clause is detected that is not in one of the formats
174 * (<test> <expression1> ...) or (else <expression1> <expression2> ...)
175 * a 'Bad cond clause' error is signalled. */
176 static const char s_bad_cond_clause
[] = "Bad cond clause";
178 /* If a cond clause is detected that uses the alternate '=>' form, but does
179 * not hold a recipient element for the test result, a 'Missing recipient'
180 * error is signalled. */
181 static const char s_missing_recipient
[] = "Missing recipient in";
183 /* If in a position where a variable name is required some other object is
184 * detected, a 'Bad variable' error is signalled. */
185 static const char s_bad_variable
[] = "Bad variable";
187 /* Bindings for forms like 'let' and 'do' have to be given in a proper,
188 * possibly empty list. If any other object is detected in a place where a
189 * list of bindings was required, a 'Bad bindings' error is signalled. */
190 static const char s_bad_bindings
[] = "Bad bindings";
192 /* Depending on the syntactic context, a binding has to be in the format
193 * (<variable> <expression>) or (<variable> <expression1> <expression2>).
194 * If anything else is detected in a place where a binding was expected, a
195 * 'Bad binding' error is signalled. */
196 static const char s_bad_binding
[] = "Bad binding";
198 /* Some syntactic forms don't allow variable names to appear more than once in
199 * a list of bindings. If such a situation is nevertheless detected, a
200 * 'Duplicate binding' error is signalled. */
201 static const char s_duplicate_binding
[] = "Duplicate binding";
203 /* If the exit form of a 'do' expression is not in the format
204 * (<test> <expression> ...)
205 * a 'Bad exit clause' error is signalled. */
206 static const char s_bad_exit_clause
[] = "Bad exit clause";
208 /* The formal function arguments of a lambda expression have to be either a
209 * single symbol or a non-cyclic list. For anything else a 'Bad formals'
210 * error is signalled. */
211 static const char s_bad_formals
[] = "Bad formals";
213 /* If in a lambda expression something else than a symbol is detected at a
214 * place where a formal function argument is required, a 'Bad formal' error is
216 static const char s_bad_formal
[] = "Bad formal";
218 /* If in the arguments list of a lambda expression an argument name occurs
219 * more than once, a 'Duplicate formal' error is signalled. */
220 static const char s_duplicate_formal
[] = "Duplicate formal";
222 /* If the evaluation of an unquote-splicing expression gives something else
223 * than a proper list, a 'Non-list result for unquote-splicing' error is
225 static const char s_splicing
[] = "Non-list result for unquote-splicing";
227 /* If something else than an exact integer is detected as the argument for
228 * @slot-ref and @slot-set!, a 'Bad slot number' error is signalled. */
229 static const char s_bad_slot_number
[] = "Bad slot number";
232 /* Signal a syntax error. We distinguish between the form that caused the
233 * error and the enclosing expression. The error message will print out as
234 * shown in the following pattern. The file name and line number are only
235 * given when they can be determined from the erroneous form or from the
236 * enclosing expression.
238 * <filename>: In procedure memoization:
239 * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
241 SCM_SYMBOL (syntax_error_key
, "syntax-error");
243 /* The prototype is needed to indicate that the function does not return. */
245 syntax_error (const char* const, const SCM
, const SCM
) SCM_NORETURN
;
248 syntax_error (const char* const msg
, const SCM form
, const SCM expr
)
250 const SCM msg_string
= scm_makfrom0str (msg
);
251 SCM filename
= SCM_BOOL_F
;
252 SCM linenr
= SCM_BOOL_F
;
256 if (SCM_CONSP (form
))
258 filename
= scm_source_property (form
, scm_sym_filename
);
259 linenr
= scm_source_property (form
, scm_sym_line
);
262 if (SCM_FALSEP (filename
) && SCM_FALSEP (linenr
) && SCM_CONSP (expr
))
264 filename
= scm_source_property (expr
, scm_sym_filename
);
265 linenr
= scm_source_property (expr
, scm_sym_line
);
268 if (!SCM_UNBNDP (expr
))
270 if (!SCM_FALSEP (filename
))
272 format
= "In file ~S, line ~S: ~A ~S in expression ~S.";
273 args
= scm_list_5 (filename
, linenr
, msg_string
, form
, expr
);
275 else if (!SCM_FALSEP (linenr
))
277 format
= "In line ~S: ~A ~S in expression ~S.";
278 args
= scm_list_4 (linenr
, msg_string
, form
, expr
);
282 format
= "~A ~S in expression ~S.";
283 args
= scm_list_3 (msg_string
, form
, expr
);
288 if (!SCM_FALSEP (filename
))
290 format
= "In file ~S, line ~S: ~A ~S.";
291 args
= scm_list_4 (filename
, linenr
, msg_string
, form
);
293 else if (!SCM_FALSEP (linenr
))
295 format
= "In line ~S: ~A ~S.";
296 args
= scm_list_3 (linenr
, msg_string
, form
);
301 args
= scm_list_2 (msg_string
, form
);
305 scm_error (syntax_error_key
, "memoization", format
, args
, SCM_BOOL_F
);
309 /* Shortcut macros to simplify syntax error handling. */
310 #define ASSERT_SYNTAX(cond, message, form) \
311 { if (!(cond)) syntax_error (message, form, SCM_UNDEFINED); }
312 #define ASSERT_SYNTAX_2(cond, message, form, expr) \
313 { if (!(cond)) syntax_error (message, form, expr); }
319 * Ilocs are memoized references to variables in local environment frames.
320 * They are represented as three values: The relative offset of the
321 * environment frame, the number of the binding within that frame, and a
322 * boolean value indicating whether the binding is the last binding in the
325 #define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc)
326 #define SCM_IDINC (0x00100000L)
327 #define SCM_IDSTMSK (-SCM_IDINC)
328 #define SCM_MAKE_ILOC(frame_nr, binding_nr, last_p) \
331 + ((binding_nr) << 20) \
332 + ((last_p) ? SCM_ICDR : 0) \
335 #if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
337 SCM
scm_dbg_make_iloc (SCM frame
, SCM binding
, SCM cdrp
);
338 SCM_DEFINE (scm_dbg_make_iloc
, "dbg-make-iloc", 3, 0, 0,
339 (SCM frame
, SCM binding
, SCM cdrp
),
340 "Return a new iloc with frame offset @var{frame}, binding\n"
341 "offset @var{binding} and the cdr flag @var{cdrp}.")
342 #define FUNC_NAME s_scm_dbg_make_iloc
344 SCM_VALIDATE_INUM (1, frame
);
345 SCM_VALIDATE_INUM (2, binding
);
346 return SCM_MAKE_ILOC (SCM_INUM (frame
),
352 SCM
scm_dbg_iloc_p (SCM obj
);
353 SCM_DEFINE (scm_dbg_iloc_p
, "dbg-iloc?", 1, 0, 0,
355 "Return @code{#t} if @var{obj} is an iloc.")
356 #define FUNC_NAME s_scm_dbg_iloc_p
358 return SCM_BOOL (SCM_ILOCP (obj
));
366 /* The function lookup_symbol is used during memoization: Lookup the symbol
367 * in the environment. If there is no binding for the symbol, SCM_UNDEFINED
368 * is returned. If the symbol is a syntactic keyword, the macro object to
369 * which the symbol is bound is returned. If the symbol is a global variable,
370 * the variable object to which the symbol is bound is returned. Finally, if
371 * the symbol is a local variable the corresponding iloc object is returned.
374 /* A helper function for lookup_symbol: Try to find the symbol in the top
375 * level environment frame. The function returns SCM_UNDEFINED if the symbol
376 * is unbound, it returns a macro object if the symbol is a syntactic keyword
377 * and it returns a variable object if the symbol is a global variable. */
379 lookup_global_symbol (const SCM symbol
, const SCM top_level
)
381 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
382 if (SCM_FALSEP (variable
))
384 return SCM_UNDEFINED
;
388 const SCM value
= SCM_VARIABLE_REF (variable
);
389 if (SCM_MACROP (value
))
397 lookup_symbol (const SCM symbol
, const SCM env
)
400 unsigned int frame_nr
;
402 for (frame_idx
= env
, frame_nr
= 0;
403 !SCM_NULLP (frame_idx
);
404 frame_idx
= SCM_CDR (frame_idx
), ++frame_nr
)
406 const SCM frame
= SCM_CAR (frame_idx
);
407 if (SCM_CONSP (frame
))
409 /* frame holds a local environment frame */
411 unsigned int symbol_nr
;
413 for (symbol_idx
= SCM_CAR (frame
), symbol_nr
= 0;
414 SCM_CONSP (symbol_idx
);
415 symbol_idx
= SCM_CDR (symbol_idx
), ++symbol_nr
)
417 if (SCM_EQ_P (SCM_CAR (symbol_idx
), symbol
))
418 /* found the symbol, therefore return the iloc */
419 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 0);
421 if (SCM_EQ_P (symbol_idx
, symbol
))
422 /* found the symbol as the last element of the current frame */
423 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 1);
427 /* no more local environment frames */
428 return lookup_global_symbol (symbol
, frame
);
432 return lookup_global_symbol (symbol
, SCM_BOOL_F
);
436 /* Return true if the symbol is - from the point of view of a macro
437 * transformer - a literal in the sense specified in chapter "pattern
438 * language" of R5RS. In the code below, however, we don't match the
439 * definition of R5RS exactly: It returns true if the identifier has no
440 * binding or if it is a syntactic keyword. */
442 literal_p (const SCM symbol
, const SCM env
)
444 const SCM value
= lookup_symbol (symbol
, env
);
445 if (SCM_UNBNDP (value
) || SCM_MACROP (value
))
453 /* The evaluator contains a plethora of EVAL symbols.
454 * This is an attempt at explanation.
456 * The following macros should be used in code which is read twice
457 * (where the choice of evaluator is hard soldered):
459 * SCM_CEVAL is the symbol used within one evaluator to call itself.
460 * Originally, it is defined to scm_ceval, but is redefined to
461 * scm_deval during the second pass.
463 * SCM_EVALIM is used when it is known that the expression is an
464 * immediate. (This macro never calls an evaluator.)
466 * EVALCAR evaluates the car of an expression.
468 * The following macros should be used in code which is read once
469 * (where the choice of evaluator is dynamic):
471 * SCM_XEVAL takes care of immediates without calling an evaluator. It
472 * then calls scm_ceval *or* scm_deval, depending on the debugging
475 * SCM_XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
476 * depending on the debugging mode.
478 * The main motivation for keeping this plethora is efficiency
479 * together with maintainability (=> locality of code).
482 #define SCM_CEVAL scm_ceval
484 #define SCM_EVALIM2(x) \
485 ((SCM_EQ_P ((x), SCM_EOL) \
486 ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \
490 #define SCM_EVALIM(x, env) (SCM_ILOCP (x) \
491 ? *scm_ilookup ((x), env) \
494 #define SCM_XEVAL(x, env) (SCM_IMP (x) \
496 : (*scm_ceval_ptr) ((x), (env)))
498 #define SCM_XEVALCAR(x, env) (SCM_IMP (SCM_CAR (x)) \
499 ? SCM_EVALIM (SCM_CAR (x), env) \
500 : (SCM_SYMBOLP (SCM_CAR (x)) \
501 ? *scm_lookupcar (x, env, 1) \
502 : (*scm_ceval_ptr) (SCM_CAR (x), env)))
504 #define EVALCAR(x, env) (SCM_IMP (SCM_CAR (x)) \
505 ? SCM_EVALIM (SCM_CAR (x), env) \
506 : (SCM_SYMBOLP (SCM_CAR (x)) \
507 ? *scm_lookupcar (x, env, 1) \
508 : SCM_CEVAL (SCM_CAR (x), env)))
510 SCM_REC_MUTEX (source_mutex
);
513 /* Lookup a given local variable in an environment. The local variable is
514 * given as an iloc, that is a triple <frame, binding, last?>, where frame
515 * indicates the relative number of the environment frame (counting upwards
516 * from the innermost environment frame), binding indicates the number of the
517 * binding within the frame, and last? (which is extracted from the iloc using
518 * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
519 * very end of the improper list of bindings. */
521 scm_ilookup (SCM iloc
, SCM env
)
523 unsigned int frame_nr
= SCM_IFRAME (iloc
);
524 unsigned int binding_nr
= SCM_IDIST (iloc
);
528 for (; 0 != frame_nr
; --frame_nr
)
529 frames
= SCM_CDR (frames
);
531 bindings
= SCM_CAR (frames
);
532 for (; 0 != binding_nr
; --binding_nr
)
533 bindings
= SCM_CDR (bindings
);
535 if (SCM_ICDRP (iloc
))
536 return SCM_CDRLOC (bindings
);
537 return SCM_CARLOC (SCM_CDR (bindings
));
541 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
543 static void error_unbound_variable (SCM symbol
) SCM_NORETURN
;
545 error_unbound_variable (SCM symbol
)
547 scm_error (scm_unbound_variable_key
, NULL
,
548 "Unbound variable: ~S",
549 scm_list_1 (symbol
), SCM_BOOL_F
);
553 /* The Lookup Car Race
556 Memoization of variables and special forms is done while executing
557 the code for the first time. As long as there is only one thread
558 everything is fine, but as soon as two threads execute the same
559 code concurrently `for the first time' they can come into conflict.
561 This memoization includes rewriting variable references into more
562 efficient forms and expanding macros. Furthermore, macro expansion
563 includes `compiling' special forms like `let', `cond', etc. into
564 tree-code instructions.
566 There shouldn't normally be a problem with memoizing local and
567 global variable references (into ilocs and variables), because all
568 threads will mutate the code in *exactly* the same way and (if I
569 read the C code correctly) it is not possible to observe a half-way
570 mutated cons cell. The lookup procedure can handle this
571 transparently without any critical sections.
573 It is different with macro expansion, because macro expansion
574 happens outside of the lookup procedure and can't be
575 undone. Therefore the lookup procedure can't cope with it. It has
576 to indicate failure when it detects a lost race and hope that the
577 caller can handle it. Luckily, it turns out that this is the case.
579 An example to illustrate this: Suppose that the following form will
580 be memoized concurrently by two threads
584 Let's first examine the lookup of X in the body. The first thread
585 decides that it has to find the symbol "x" in the environment and
586 starts to scan it. Then the other thread takes over and actually
587 overtakes the first. It looks up "x" and substitutes an
588 appropriate iloc for it. Now the first thread continues and
589 completes its lookup. It comes to exactly the same conclusions as
590 the second one and could - without much ado - just overwrite the
591 iloc with the same iloc.
593 But let's see what will happen when the race occurs while looking
594 up the symbol "let" at the start of the form. It could happen that
595 the second thread interrupts the lookup of the first thread and not
596 only substitutes a variable for it but goes right ahead and
597 replaces it with the compiled form (#@let* (x 12) x). Now, when
598 the first thread completes its lookup, it would replace the #@let*
599 with a variable containing the "let" binding, effectively reverting
600 the form to (let (x 12) x). This is wrong. It has to detect that
601 it has lost the race and the evaluator has to reconsider the
602 changed form completely.
604 This race condition could be resolved with some kind of traffic
605 light (like mutexes) around scm_lookupcar, but I think that it is
606 best to avoid them in this case. They would serialize memoization
607 completely and because lookup involves calling arbitrary Scheme
608 code (via the lookup-thunk), threads could be blocked for an
609 arbitrary amount of time or even deadlock. But with the current
610 solution a lot of unnecessary work is potentially done. */
612 /* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
613 return NULL to indicate a failed lookup due to some race conditions
614 between threads. This only happens when VLOC is the first cell of
615 a special form that will eventually be memoized (like `let', etc.)
616 In that case the whole lookup is bogus and the caller has to
617 reconsider the complete special form.
619 SCM_LOOKUPCAR is still there, of course. It just calls
620 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
621 should only be called when it is known that VLOC is not the first
622 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
623 for NULL. I think I've found the only places where this
627 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
630 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
631 register SCM iloc
= SCM_ILOC00
;
632 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
634 if (!SCM_CONSP (SCM_CAR (env
)))
636 al
= SCM_CARLOC (env
);
637 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
641 if (SCM_EQ_P (fl
, var
))
643 if (! SCM_EQ_P (SCM_CAR (vloc
), var
))
645 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
646 return SCM_CDRLOC (*al
);
651 al
= SCM_CDRLOC (*al
);
652 if (SCM_EQ_P (SCM_CAR (fl
), var
))
654 if (SCM_UNBNDP (SCM_CAR (*al
)))
659 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
661 SCM_SETCAR (vloc
, iloc
);
662 return SCM_CARLOC (*al
);
664 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
666 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
669 SCM top_thunk
, real_var
;
672 top_thunk
= SCM_CAR (env
); /* env now refers to a
673 top level env thunk */
677 top_thunk
= SCM_BOOL_F
;
678 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
679 if (SCM_FALSEP (real_var
))
682 if (!SCM_NULLP (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
688 error_unbound_variable (var
);
690 scm_misc_error (NULL
, "Damaged environment: ~S",
695 /* A variable could not be found, but we shall
696 not throw an error. */
697 static SCM undef_object
= SCM_UNDEFINED
;
698 return &undef_object
;
702 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
704 /* Some other thread has changed the very cell we are working
705 on. In effect, it must have done our job or messed it up
708 var
= SCM_CAR (vloc
);
709 if (SCM_VARIABLEP (var
))
710 return SCM_VARIABLE_LOC (var
);
711 if (SCM_ITAG7 (var
) == SCM_ITAG7 (SCM_ILOC00
))
712 return scm_ilookup (var
, genv
);
713 /* We can't cope with anything else than variables and ilocs. When
714 a special form has been memoized (i.e. `let' into `#@let') we
715 return NULL and expect the calling function to do the right
716 thing. For the evaluator, this means going back and redoing
717 the dispatch on the car of the form. */
721 SCM_SETCAR (vloc
, real_var
);
722 return SCM_VARIABLE_LOC (real_var
);
727 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
729 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
737 scm_eval_car (SCM pair
, SCM env
)
739 return SCM_XEVALCAR (pair
, env
);
744 /* Rewrite the body (which is given as the list of expressions forming the
745 * body) into its internal form. The internal form of a body (<expr> ...) is
746 * just the body itself, but prefixed with an ISYM that denotes to what kind
747 * of outer construct this body belongs: (<ISYM> <expr> ...). A lambda body
748 * starts with SCM_IM_LAMBDA, for example, a body of a let starts with
749 * SCM_IM_LET, etc. The one exception is a body that belongs to a letrec that
750 * has been formed by rewriting internal defines: It starts with SCM_IM_DEFINE
751 * (instead of SCM_IM_LETREC).
753 * It is assumed that the calling expression has already made sure that the
754 * body is a proper list. */
756 m_body (SCM op
, SCM exprs
)
758 /* Don't add another ISYM if one is present already. */
759 if (SCM_ISYMP (SCM_CAR (exprs
)))
762 return scm_cons (op
, exprs
);
766 /* The function m_expand_body memoizes a proper list of expressions forming a
767 * body. This function takes care of dealing with internal defines and
768 * transforming them into an equivalent letrec expression. */
770 /* This is a helper function for m_expand_body. It helps to figure out whether
771 * an expression denotes a syntactic keyword. */
773 try_macro_lookup (const SCM expr
, const SCM env
)
775 if (SCM_SYMBOLP (expr
))
777 const SCM value
= lookup_symbol (expr
, env
);
782 return SCM_UNDEFINED
;
786 /* This is a helper function for m_expand_body. It expands user macros,
787 * because for the correct translation of a body we need to know whether they
788 * expand to a definition. */
790 expand_user_macros (SCM expr
, const SCM env
)
792 while (SCM_CONSP (expr
))
794 const SCM car_expr
= SCM_CAR (expr
);
795 const SCM new_car
= expand_user_macros (car_expr
, env
);
796 const SCM value
= try_macro_lookup (new_car
, env
);
798 if (SCM_MACROP (value
) && SCM_MACRO_TYPE (value
) == 2)
800 /* User macros transform code into code. */
801 expr
= scm_call_2 (SCM_MACRO_CODE (value
), expr
, env
);
802 /* We need to reiterate on the transformed code. */
806 /* No user macro: return. */
807 SCM_SETCAR (expr
, new_car
);
815 /* This is a helper function for m_expand_body. It determines if a given form
816 * represents an application of a given built-in macro. The built-in macro to
817 * check for is identified by its syntactic keyword. The form is an
818 * application of the given macro if looking up the car of the form in the
819 * given environment actually returns the built-in macro. */
821 is_system_macro_p (const SCM syntactic_keyword
, const SCM form
, const SCM env
)
823 if (SCM_CONSP (form
))
825 const SCM car_form
= SCM_CAR (form
);
826 const SCM value
= try_macro_lookup (car_form
, env
);
827 if (SCM_BUILTIN_MACRO_P (value
))
829 const SCM macro_name
= scm_macro_name (value
);
830 return SCM_EQ_P (macro_name
, syntactic_keyword
);
838 m_expand_body (const SCM forms
, const SCM env
)
840 /* The first body form can be skipped since it is known to be the ISYM that
841 * was prepended to the body by m_body. */
842 SCM cdr_forms
= SCM_CDR (forms
);
843 SCM form_idx
= cdr_forms
;
844 SCM definitions
= SCM_EOL
;
845 SCM sequence
= SCM_EOL
;
847 /* According to R5RS, the list of body forms consists of two parts: a number
848 * (maybe zero) of definitions, followed by a non-empty sequence of
849 * expressions. Each the definitions and the expressions may be grouped
850 * arbitrarily with begin, but it is not allowed to mix definitions and
851 * expressions. The task of the following loop therefore is to split the
852 * list of body forms into the list of definitions and the sequence of
854 while (!SCM_NULLP (form_idx
))
856 const SCM form
= SCM_CAR (form_idx
);
857 const SCM new_form
= expand_user_macros (form
, env
);
858 if (is_system_macro_p (scm_sym_define
, new_form
, env
))
860 definitions
= scm_cons (new_form
, definitions
);
861 form_idx
= SCM_CDR (form_idx
);
863 else if (is_system_macro_p (scm_sym_begin
, new_form
, env
))
865 /* We have encountered a group of forms. This has to be either a
866 * (possibly empty) group of (possibly further grouped) definitions,
867 * or a non-empty group of (possibly further grouped)
869 const SCM grouped_forms
= SCM_CDR (new_form
);
870 unsigned int found_definition
= 0;
871 unsigned int found_expression
= 0;
872 SCM grouped_form_idx
= grouped_forms
;
873 while (!found_expression
&& !SCM_NULLP (grouped_form_idx
))
875 const SCM inner_form
= SCM_CAR (grouped_form_idx
);
876 const SCM new_inner_form
= expand_user_macros (inner_form
, env
);
877 if (is_system_macro_p (scm_sym_define
, new_inner_form
, env
))
879 found_definition
= 1;
880 definitions
= scm_cons (new_inner_form
, definitions
);
881 grouped_form_idx
= SCM_CDR (grouped_form_idx
);
883 else if (is_system_macro_p (scm_sym_begin
, new_inner_form
, env
))
885 const SCM inner_group
= SCM_CDR (new_inner_form
);
887 = scm_append (scm_list_2 (inner_group
,
888 SCM_CDR (grouped_form_idx
)));
892 /* The group marks the start of the expressions of the body.
893 * We have to make sure that within the same group we have
894 * not encountered a definition before. */
895 ASSERT_SYNTAX (!found_definition
, s_mixed_body_forms
, form
);
896 found_expression
= 1;
897 grouped_form_idx
= SCM_EOL
;
901 /* We have finished processing the group. If we have not yet
902 * encountered an expression we continue processing the forms of the
903 * body to collect further definition forms. Otherwise, the group
904 * marks the start of the sequence of expressions of the body. */
905 if (!found_expression
)
907 form_idx
= SCM_CDR (form_idx
);
917 /* We have detected a form which is no definition. This marks the
918 * start of the sequence of expressions of the body. */
924 /* FIXME: forms does not hold information about the file location. */
925 ASSERT_SYNTAX (SCM_CONSP (sequence
), s_missing_body_expression
, cdr_forms
);
927 if (!SCM_NULLP (definitions
))
931 SCM letrec_expression
;
932 SCM new_letrec_expression
;
935 SCM bindings
= SCM_EOL
;
936 for (definition_idx
= definitions
;
937 !SCM_NULLP (definition_idx
);
938 definition_idx
= SCM_CDR (definition_idx
))
940 const SCM definition
= SCM_CAR (definition_idx
);
941 const SCM canonical_definition
= canonicalize_define (definition
);
942 const SCM binding
= SCM_CDR (canonical_definition
);
943 bindings
= scm_cons (binding
, bindings
);
946 letrec_tail
= scm_cons (bindings
, sequence
);
947 /* FIXME: forms does not hold information about the file location. */
948 letrec_expression
= scm_cons_source (forms
, scm_sym_letrec
, letrec_tail
);
949 new_letrec_expression
= scm_m_letrec (letrec_expression
, env
);
950 new_body
= scm_list_1 (new_letrec_expression
);
955 SCM_SETCAR (forms
, SCM_CAR (sequence
));
956 SCM_SETCDR (forms
, SCM_CDR (sequence
));
961 #if (SCM_ENABLE_DEPRECATED == 1)
963 /* Deprecated in guile 1.7.0 on 2003-11-09. */
965 scm_m_expand_body (SCM exprs
, SCM env
)
967 scm_c_issue_deprecation_warning
968 ("`scm_m_expand_body' is deprecated.");
969 return m_expand_body (exprs
, env
);
975 /* Start of the memoizers for the standard R5RS builtin macros. */
978 SCM_SYNTAX (s_and
, "and", scm_i_makbimacro
, scm_m_and
);
979 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
982 scm_m_and (SCM expr
, SCM env SCM_UNUSED
)
984 const SCM cdr_expr
= SCM_CDR (expr
);
985 const long length
= scm_ilength (cdr_expr
);
987 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
991 /* Special case: (and) is replaced by #t. */
996 SCM_SETCAR (expr
, SCM_IM_AND
);
1002 SCM_SYNTAX (s_begin
, "begin", scm_i_makbimacro
, scm_m_begin
);
1003 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
1006 scm_m_begin (SCM expr
, SCM env SCM_UNUSED
)
1008 const SCM cdr_expr
= SCM_CDR (expr
);
1009 /* Dirk:FIXME:: An empty begin clause is not generally allowed by R5RS.
1010 * That means, there should be a distinction between uses of begin where an
1011 * empty clause is OK and where it is not. */
1012 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1014 SCM_SETCAR (expr
, SCM_IM_BEGIN
);
1019 SCM_SYNTAX (s_case
, "case", scm_i_makbimacro
, scm_m_case
);
1020 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
1021 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
1024 scm_m_case (SCM expr
, SCM env
)
1027 SCM all_labels
= SCM_EOL
;
1029 /* Check, whether 'else is a literal, i. e. not bound to a value. */
1030 const int else_literal_p
= literal_p (scm_sym_else
, env
);
1032 const SCM cdr_expr
= SCM_CDR (expr
);
1033 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1034 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_clauses
, expr
);
1036 clauses
= SCM_CDR (cdr_expr
);
1037 while (!SCM_NULLP (clauses
))
1041 const SCM clause
= SCM_CAR (clauses
);
1042 ASSERT_SYNTAX_2 (scm_ilength (clause
) >= 2,
1043 s_bad_case_clause
, clause
, expr
);
1045 labels
= SCM_CAR (clause
);
1046 if (SCM_CONSP (labels
))
1048 ASSERT_SYNTAX_2 (scm_ilength (labels
) >= 0,
1049 s_bad_case_labels
, labels
, expr
);
1050 all_labels
= scm_append_x (scm_list_2 (labels
, all_labels
));
1052 else if (SCM_NULLP (labels
))
1054 /* The list of labels is empty. According to R5RS this is allowed.
1055 * It means that the sequence of expressions will never be executed.
1056 * Therefore, as an optimization, we could remove the whole
1061 ASSERT_SYNTAX_2 (SCM_EQ_P (labels
, scm_sym_else
) && else_literal_p
,
1062 s_bad_case_labels
, labels
, expr
);
1063 ASSERT_SYNTAX_2 (SCM_NULLP (SCM_CDR (clauses
)),
1064 s_misplaced_else_clause
, clause
, expr
);
1067 /* build the new clause */
1068 if (SCM_EQ_P (labels
, scm_sym_else
))
1069 SCM_SETCAR (clause
, SCM_IM_ELSE
);
1071 clauses
= SCM_CDR (clauses
);
1074 /* Check whether all case labels are distinct. */
1075 for (; !SCM_NULLP (all_labels
); all_labels
= SCM_CDR (all_labels
))
1077 const SCM label
= SCM_CAR (all_labels
);
1078 ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (label
, SCM_CDR (all_labels
))),
1079 s_duplicate_case_label
, label
, expr
);
1082 SCM_SETCAR (expr
, SCM_IM_CASE
);
1087 SCM_SYNTAX (s_cond
, "cond", scm_i_makbimacro
, scm_m_cond
);
1088 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
1089 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
1092 scm_m_cond (SCM expr
, SCM env
)
1094 /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
1095 const int else_literal_p
= literal_p (scm_sym_else
, env
);
1096 const int arrow_literal_p
= literal_p (scm_sym_arrow
, env
);
1098 const SCM clauses
= SCM_CDR (expr
);
1101 ASSERT_SYNTAX (scm_ilength (clauses
) >= 0, s_bad_expression
, expr
);
1102 ASSERT_SYNTAX (scm_ilength (clauses
) >= 1, s_missing_clauses
, expr
);
1104 for (clause_idx
= clauses
;
1105 !SCM_NULLP (clause_idx
);
1106 clause_idx
= SCM_CDR (clause_idx
))
1110 const SCM clause
= SCM_CAR (clause_idx
);
1111 const long length
= scm_ilength (clause
);
1112 ASSERT_SYNTAX_2 (length
>= 1, s_bad_cond_clause
, clause
, expr
);
1114 test
= SCM_CAR (clause
);
1115 if (SCM_EQ_P (test
, scm_sym_else
) && else_literal_p
)
1117 const int last_clause_p
= SCM_NULLP (SCM_CDR (clause_idx
));
1118 ASSERT_SYNTAX_2 (length
>= 2,
1119 s_bad_cond_clause
, clause
, expr
);
1120 ASSERT_SYNTAX_2 (last_clause_p
,
1121 s_misplaced_else_clause
, clause
, expr
);
1122 SCM_SETCAR (clause
, SCM_IM_ELSE
);
1124 else if (length
>= 2
1125 && SCM_EQ_P (SCM_CADR (clause
), scm_sym_arrow
)
1128 ASSERT_SYNTAX_2 (length
> 2, s_missing_recipient
, clause
, expr
);
1129 ASSERT_SYNTAX_2 (length
== 3, s_extra_expression
, clause
, expr
);
1130 SCM_SETCAR (SCM_CDR (clause
), SCM_IM_ARROW
);
1134 SCM_SETCAR (expr
, SCM_IM_COND
);
1139 SCM_SYNTAX (s_define
, "define", scm_i_makbimacro
, scm_m_define
);
1140 SCM_GLOBAL_SYMBOL (scm_sym_define
, s_define
);
1142 /* Guile provides an extension to R5RS' define syntax to represent function
1143 * currying in a compact way. With this extension, it is allowed to write
1144 * (define <nested-variable> <body>), where <nested-variable> has of one of
1145 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
1146 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
1147 * should be either a sequence of zero or more variables, or a sequence of one
1148 * or more variables followed by a space-delimited period and another
1149 * variable. Each level of argument nesting wraps the <body> within another
1150 * lambda expression. For example, the following forms are allowed, each one
1151 * followed by an equivalent, more explicit implementation.
1153 * (define ((a b . c) . d) <body>) is equivalent to
1154 * (define a (lambda (b . c) (lambda d <body>)))
1156 * (define (((a) b) c . d) <body>) is equivalent to
1157 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
1159 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
1160 * module that does not implement this extension. */
1162 canonicalize_define (const SCM expr
)
1167 const SCM cdr_expr
= SCM_CDR (expr
);
1168 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1169 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1171 body
= SCM_CDR (cdr_expr
);
1172 variable
= SCM_CAR (cdr_expr
);
1173 while (SCM_CONSP (variable
))
1175 /* This while loop realizes function currying by variable nesting.
1176 * Variable is known to be a nested-variable. In every iteration of the
1177 * loop another level of lambda expression is created, starting with the
1178 * innermost one. Note that we don't check for duplicate formals here:
1179 * This will be done by the memoizer of the lambda expression. */
1180 const SCM formals
= SCM_CDR (variable
);
1181 const SCM tail
= scm_cons (formals
, body
);
1183 /* Add source properties to each new lambda expression: */
1184 const SCM lambda
= scm_cons_source (variable
, scm_sym_lambda
, tail
);
1186 body
= scm_list_1 (lambda
);
1187 variable
= SCM_CAR (variable
);
1189 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
), s_bad_variable
, variable
, expr
);
1190 ASSERT_SYNTAX (scm_ilength (body
) == 1, s_expression
, expr
);
1192 SCM_SETCAR (cdr_expr
, variable
);
1193 SCM_SETCDR (cdr_expr
, body
);
1198 scm_m_define (SCM expr
, SCM env
)
1200 SCM canonical_definition
;
1201 SCM cdr_canonical_definition
;
1204 canonical_definition
= canonicalize_define (expr
);
1205 cdr_canonical_definition
= SCM_CDR (canonical_definition
);
1206 body
= SCM_CDR (cdr_canonical_definition
);
1208 if (SCM_TOP_LEVEL (env
))
1211 const SCM variable
= SCM_CAR (cdr_canonical_definition
);
1212 const SCM value
= scm_eval_car (body
, env
);
1213 if (SCM_REC_PROCNAMES_P
)
1216 while (SCM_MACROP (tmp
))
1217 tmp
= SCM_MACRO_CODE (tmp
);
1218 if (SCM_CLOSUREP (tmp
)
1219 /* Only the first definition determines the name. */
1220 && SCM_FALSEP (scm_procedure_property (tmp
, scm_sym_name
)))
1221 scm_set_procedure_property_x (tmp
, scm_sym_name
, variable
);
1223 var
= scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_T
);
1224 SCM_VARIABLE_SET (var
, value
);
1225 return SCM_UNSPECIFIED
;
1229 SCM_SETCAR (canonical_definition
, SCM_IM_DEFINE
);
1230 return canonical_definition
;
1235 /* This is a helper function for forms (<keyword> <expression>) that are
1236 * transformed into (#@<keyword> '() <memoized_expression>) in order to allow
1237 * for easy creation of a thunk (i. e. a closure without arguments) using the
1238 * ('() <memoized_expression>) tail of the memoized form. */
1240 memoize_as_thunk_prototype (const SCM expr
, const SCM env SCM_UNUSED
)
1242 const SCM cdr_expr
= SCM_CDR (expr
);
1243 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1244 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1246 SCM_SETCDR (expr
, scm_cons (SCM_EOL
, cdr_expr
));
1252 SCM_SYNTAX (s_delay
, "delay", scm_i_makbimacro
, scm_m_delay
);
1253 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
1255 /* Promises are implemented as closures with an empty parameter list. Thus,
1256 * (delay <expression>) is transformed into (#@delay '() <expression>), where
1257 * the empty list represents the empty parameter list. This representation
1258 * allows for easy creation of the closure during evaluation. */
1260 scm_m_delay (SCM expr
, SCM env
)
1262 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1263 SCM_SETCAR (new_expr
, SCM_IM_DELAY
);
1268 SCM_SYNTAX(s_do
, "do", scm_i_makbimacro
, scm_m_do
);
1269 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
1271 /* DO gets the most radically altered syntax. The order of the vars is
1272 * reversed here. During the evaluation this allows for simple consing of the
1273 * results of the inits and steps:
1275 (do ((<var1> <init1> <step1>)
1283 (#@do (<init1> <init2> ... <initn>)
1284 (varn ... var2 var1)
1287 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
1290 scm_m_do (SCM expr
, SCM env SCM_UNUSED
)
1292 SCM variables
= SCM_EOL
;
1293 SCM init_forms
= SCM_EOL
;
1294 SCM step_forms
= SCM_EOL
;
1301 const SCM cdr_expr
= SCM_CDR (expr
);
1302 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1303 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1305 /* Collect variables, init and step forms. */
1306 binding_idx
= SCM_CAR (cdr_expr
);
1307 ASSERT_SYNTAX_2 (scm_ilength (binding_idx
) >= 0,
1308 s_bad_bindings
, binding_idx
, expr
);
1309 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1311 const SCM binding
= SCM_CAR (binding_idx
);
1312 const long length
= scm_ilength (binding
);
1313 ASSERT_SYNTAX_2 (length
== 2 || length
== 3,
1314 s_bad_binding
, binding
, expr
);
1317 const SCM name
= SCM_CAR (binding
);
1318 const SCM init
= SCM_CADR (binding
);
1319 const SCM step
= (length
== 2) ? name
: SCM_CADDR (binding
);
1320 ASSERT_SYNTAX_2 (SCM_SYMBOLP (name
), s_bad_variable
, name
, expr
);
1321 ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (name
, variables
)),
1322 s_duplicate_binding
, name
, expr
);
1324 variables
= scm_cons (name
, variables
);
1325 init_forms
= scm_cons (init
, init_forms
);
1326 step_forms
= scm_cons (step
, step_forms
);
1329 init_forms
= scm_reverse_x (init_forms
, SCM_UNDEFINED
);
1330 step_forms
= scm_reverse_x (step_forms
, SCM_UNDEFINED
);
1332 /* Memoize the test form and the exit sequence. */
1333 cddr_expr
= SCM_CDR (cdr_expr
);
1334 exit_clause
= SCM_CAR (cddr_expr
);
1335 ASSERT_SYNTAX_2 (scm_ilength (exit_clause
) >= 1,
1336 s_bad_exit_clause
, exit_clause
, expr
);
1338 commands
= SCM_CDR (cddr_expr
);
1339 tail
= scm_cons2 (exit_clause
, commands
, step_forms
);
1340 tail
= scm_cons2 (init_forms
, variables
, tail
);
1341 SCM_SETCAR (expr
, SCM_IM_DO
);
1342 SCM_SETCDR (expr
, tail
);
1347 SCM_SYNTAX (s_if
, "if", scm_i_makbimacro
, scm_m_if
);
1348 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
1351 scm_m_if (SCM expr
, SCM env SCM_UNUSED
)
1353 const SCM cdr_expr
= SCM_CDR (expr
);
1354 const long length
= scm_ilength (cdr_expr
);
1355 ASSERT_SYNTAX (length
== 2 || length
== 3, s_expression
, expr
);
1356 SCM_SETCAR (expr
, SCM_IM_IF
);
1361 SCM_SYNTAX (s_lambda
, "lambda", scm_i_makbimacro
, scm_m_lambda
);
1362 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
1364 /* A helper function for memoize_lambda to support checking for duplicate
1365 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
1366 * LIST or to the cdr of the last cons. Therefore, LIST may have any of the
1367 * forms that a formal argument can have:
1368 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
1370 c_improper_memq (SCM obj
, SCM list
)
1372 for (; SCM_CONSP (list
); list
= SCM_CDR (list
))
1374 if (SCM_EQ_P (SCM_CAR (list
), obj
))
1377 return SCM_EQ_P (list
, obj
);
1381 scm_m_lambda (SCM expr
, SCM env SCM_UNUSED
)
1390 const SCM cdr_expr
= SCM_CDR (expr
);
1391 const long length
= scm_ilength (cdr_expr
);
1392 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1393 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1395 /* Before iterating the list of formal arguments, make sure the formals
1396 * actually are given as either a symbol or a non-cyclic list. */
1397 formals
= SCM_CAR (cdr_expr
);
1398 if (SCM_CONSP (formals
))
1400 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
1401 * detected, report a 'Bad formals' error. */
1405 ASSERT_SYNTAX_2 (SCM_SYMBOLP (formals
) || SCM_NULLP (formals
),
1406 s_bad_formals
, formals
, expr
);
1409 /* Now iterate the list of formal arguments to check if all formals are
1410 * symbols, and that there are no duplicates. */
1411 formals_idx
= formals
;
1412 while (SCM_CONSP (formals_idx
))
1414 const SCM formal
= SCM_CAR (formals_idx
);
1415 const SCM next_idx
= SCM_CDR (formals_idx
);
1416 ASSERT_SYNTAX_2 (SCM_SYMBOLP (formal
), s_bad_formal
, formal
, expr
);
1417 ASSERT_SYNTAX_2 (!c_improper_memq (formal
, next_idx
),
1418 s_duplicate_formal
, formal
, expr
);
1419 formals_idx
= next_idx
;
1421 ASSERT_SYNTAX_2 (SCM_NULLP (formals_idx
) || SCM_SYMBOLP (formals_idx
),
1422 s_bad_formal
, formals_idx
, expr
);
1424 /* Memoize the body. Keep a potential documentation string. */
1425 /* Dirk:FIXME:: We should probably extract the documentation string to
1426 * some external database. Otherwise it will slow down execution, since
1427 * the documentation string will have to be skipped with every execution
1428 * of the closure. */
1429 cddr_expr
= SCM_CDR (cdr_expr
);
1430 documentation
= (length
>= 3 && SCM_STRINGP (SCM_CAR (cddr_expr
)));
1431 body
= documentation
? SCM_CDR (cddr_expr
) : cddr_expr
;
1432 new_body
= m_body (SCM_IM_LAMBDA
, body
);
1434 SCM_SETCAR (expr
, SCM_IM_LAMBDA
);
1436 SCM_SETCDR (cddr_expr
, new_body
);
1438 SCM_SETCDR (cdr_expr
, new_body
);
1443 /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
1445 check_bindings (const SCM bindings
, const SCM expr
)
1449 ASSERT_SYNTAX_2 (scm_ilength (bindings
) >= 0,
1450 s_bad_bindings
, bindings
, expr
);
1452 binding_idx
= bindings
;
1453 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1455 SCM name
; /* const */
1457 const SCM binding
= SCM_CAR (binding_idx
);
1458 ASSERT_SYNTAX_2 (scm_ilength (binding
) == 2,
1459 s_bad_binding
, binding
, expr
);
1461 name
= SCM_CAR (binding
);
1462 ASSERT_SYNTAX_2 (SCM_SYMBOLP (name
), s_bad_variable
, name
, expr
);
1467 /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
1468 * transformed to the lists (vn ... v2 v1) and (i1 i2 ... in). That is, the
1469 * variables are returned in a list with their order reversed, and the init
1470 * forms are returned in a list in the same order as they are given in the
1471 * bindings. If a duplicate variable name is detected, an error is
1474 transform_bindings (
1475 const SCM bindings
, const SCM expr
,
1476 SCM
*const rvarptr
, SCM
*const initptr
)
1478 SCM rvariables
= SCM_EOL
;
1479 SCM rinits
= SCM_EOL
;
1480 SCM binding_idx
= bindings
;
1481 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1483 const SCM binding
= SCM_CAR (binding_idx
);
1484 const SCM cdr_binding
= SCM_CDR (binding
);
1485 const SCM name
= SCM_CAR (binding
);
1486 ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (name
, rvariables
)),
1487 s_duplicate_binding
, name
, expr
);
1488 rvariables
= scm_cons (name
, rvariables
);
1489 rinits
= scm_cons (SCM_CAR (cdr_binding
), rinits
);
1491 *rvarptr
= rvariables
;
1492 *initptr
= scm_reverse_x (rinits
, SCM_UNDEFINED
);
1496 SCM_SYNTAX(s_let
, "let", scm_i_makbimacro
, scm_m_let
);
1497 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
1499 /* This function is a helper function for memoize_let. It transforms
1500 * (let name ((var init) ...) body ...) into
1501 * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
1502 * and memoizes the expression. It is assumed that the caller has checked
1503 * that name is a symbol and that there are bindings and a body. */
1505 memoize_named_let (const SCM expr
, const SCM env SCM_UNUSED
)
1511 const SCM cdr_expr
= SCM_CDR (expr
);
1512 const SCM name
= SCM_CAR (cdr_expr
);
1513 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1514 const SCM bindings
= SCM_CAR (cddr_expr
);
1515 check_bindings (bindings
, expr
);
1517 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1518 variables
= scm_reverse_x (rvariables
, SCM_UNDEFINED
);
1521 const SCM let_body
= SCM_CDR (cddr_expr
);
1522 const SCM lambda_body
= m_body (SCM_IM_LET
, let_body
);
1523 const SCM lambda_tail
= scm_cons (variables
, lambda_body
);
1524 const SCM lambda_form
= scm_cons_source (expr
, scm_sym_lambda
, lambda_tail
);
1526 const SCM rvar
= scm_list_1 (name
);
1527 const SCM init
= scm_list_1 (lambda_form
);
1528 const SCM body
= m_body (SCM_IM_LET
, scm_list_1 (name
));
1529 const SCM letrec_tail
= scm_cons (rvar
, scm_cons (init
, body
));
1530 const SCM letrec_form
= scm_cons_source (expr
, SCM_IM_LETREC
, letrec_tail
);
1531 return scm_cons_source (expr
, letrec_form
, inits
);
1535 /* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1536 * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
1538 scm_m_let (SCM expr
, SCM env
)
1542 const SCM cdr_expr
= SCM_CDR (expr
);
1543 const long length
= scm_ilength (cdr_expr
);
1544 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1545 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1547 bindings
= SCM_CAR (cdr_expr
);
1548 if (SCM_SYMBOLP (bindings
))
1550 ASSERT_SYNTAX (length
>= 3, s_missing_expression
, expr
);
1551 return memoize_named_let (expr
, env
);
1554 check_bindings (bindings
, expr
);
1555 if (SCM_NULLP (bindings
) || SCM_NULLP (SCM_CDR (bindings
)))
1557 /* Special case: no bindings or single binding => let* is faster. */
1558 const SCM body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1559 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), bindings
, body
), env
);
1566 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1569 const SCM new_body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1570 const SCM new_tail
= scm_cons2 (rvariables
, inits
, new_body
);
1571 SCM_SETCAR (expr
, SCM_IM_LET
);
1572 SCM_SETCDR (expr
, new_tail
);
1579 SCM_SYNTAX (s_letstar
, "let*", scm_i_makbimacro
, scm_m_letstar
);
1580 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
1582 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1583 * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
1585 scm_m_letstar (SCM expr
, SCM env SCM_UNUSED
)
1590 const SCM cdr_expr
= SCM_CDR (expr
);
1591 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1592 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1594 binding_idx
= SCM_CAR (cdr_expr
);
1595 check_bindings (binding_idx
, expr
);
1597 /* Transform ((v1 i1) (v2 i2) ...) into (v1 i1 v2 i2 ...). The
1598 * transformation is done in place. At the beginning of one iteration of
1599 * the loop the variable binding_idx holds the form
1600 * P1:( (vn . P2:(in . ())) . P3:( (vn+1 in+1) ... ) ),
1601 * where P1, P2 and P3 indicate the pairs, that are relevant for the
1602 * transformation. P1 and P2 are modified in the loop, P3 remains
1603 * untouched. After the execution of the loop, P1 will hold
1604 * P1:( vn . P2:(in . P3:( (vn+1 in+1) ... )) )
1605 * and binding_idx will hold P3. */
1606 while (!SCM_NULLP (binding_idx
))
1608 const SCM cdr_binding_idx
= SCM_CDR (binding_idx
); /* remember P3 */
1609 const SCM binding
= SCM_CAR (binding_idx
);
1610 const SCM name
= SCM_CAR (binding
);
1611 const SCM cdr_binding
= SCM_CDR (binding
);
1613 SCM_SETCDR (cdr_binding
, cdr_binding_idx
); /* update P2 */
1614 SCM_SETCAR (binding_idx
, name
); /* update P1 */
1615 SCM_SETCDR (binding_idx
, cdr_binding
); /* update P1 */
1617 binding_idx
= cdr_binding_idx
; /* continue with P3 */
1620 new_body
= m_body (SCM_IM_LETSTAR
, SCM_CDR (cdr_expr
));
1621 SCM_SETCAR (expr
, SCM_IM_LETSTAR
);
1622 /* the bindings have been changed in place */
1623 SCM_SETCDR (cdr_expr
, new_body
);
1628 SCM_SYNTAX(s_letrec
, "letrec", scm_i_makbimacro
, scm_m_letrec
);
1629 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
1632 scm_m_letrec (SCM expr
, SCM env
)
1636 const SCM cdr_expr
= SCM_CDR (expr
);
1637 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1638 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1640 bindings
= SCM_CAR (cdr_expr
);
1641 if (SCM_NULLP (bindings
))
1643 /* no bindings, let* is executed faster */
1644 SCM body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1645 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), SCM_EOL
, body
), env
);
1653 check_bindings (bindings
, expr
);
1654 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1655 new_body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1656 return scm_cons2 (SCM_IM_LETREC
, rvariables
, scm_cons (inits
, new_body
));
1661 SCM_SYNTAX (s_or
, "or", scm_i_makbimacro
, scm_m_or
);
1662 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
1665 scm_m_or (SCM expr
, SCM env SCM_UNUSED
)
1667 const SCM cdr_expr
= SCM_CDR (expr
);
1668 const long length
= scm_ilength (cdr_expr
);
1670 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1674 /* Special case: (or) is replaced by #f. */
1679 SCM_SETCAR (expr
, SCM_IM_OR
);
1685 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
1686 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
1687 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
1688 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
1690 /* Internal function to handle a quasiquotation: 'form' is the parameter in
1691 * the call (quasiquotation form), 'env' is the environment where unquoted
1692 * expressions will be evaluated, and 'depth' is the current quasiquotation
1693 * nesting level and is known to be greater than zero. */
1695 iqq (SCM form
, SCM env
, unsigned long int depth
)
1697 if (SCM_CONSP (form
))
1699 const SCM tmp
= SCM_CAR (form
);
1700 if (SCM_EQ_P (tmp
, scm_sym_quasiquote
))
1702 const SCM args
= SCM_CDR (form
);
1703 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1704 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
1706 else if (SCM_EQ_P (tmp
, scm_sym_unquote
))
1708 const SCM args
= SCM_CDR (form
);
1709 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1711 return scm_eval_car (args
, env
);
1713 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
1715 else if (SCM_CONSP (tmp
)
1716 && SCM_EQ_P (SCM_CAR (tmp
), scm_sym_uq_splicing
))
1718 const SCM args
= SCM_CDR (tmp
);
1719 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1722 const SCM list
= scm_eval_car (args
, env
);
1723 const SCM rest
= SCM_CDR (form
);
1724 ASSERT_SYNTAX_2 (scm_ilength (list
) >= 0,
1725 s_splicing
, list
, form
);
1726 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
1729 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
1730 iqq (SCM_CDR (form
), env
, depth
));
1733 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
1734 iqq (SCM_CDR (form
), env
, depth
));
1736 else if (SCM_VECTORP (form
))
1738 size_t i
= SCM_VECTOR_LENGTH (form
);
1739 SCM
const *const data
= SCM_VELTS (form
);
1742 tmp
= scm_cons (data
[--i
], tmp
);
1743 scm_remember_upto_here_1 (form
);
1744 return scm_vector (iqq (tmp
, env
, depth
));
1751 scm_m_quasiquote (SCM expr
, SCM env
)
1753 const SCM cdr_expr
= SCM_CDR (expr
);
1754 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1755 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1756 return iqq (SCM_CAR (cdr_expr
), env
, 1);
1760 SCM_SYNTAX (s_quote
, "quote", scm_i_makbimacro
, scm_m_quote
);
1761 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
1764 scm_m_quote (SCM expr
, SCM env SCM_UNUSED
)
1768 const SCM cdr_expr
= SCM_CDR (expr
);
1769 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1770 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1771 quotee
= SCM_CAR (cdr_expr
);
1772 if (SCM_IMP (quotee
) && !SCM_NULLP (quotee
))
1774 else if (SCM_VECTORP (quotee
))
1777 /* The following optimization would be possible if all variable references
1778 * were resolved during memoization: */
1779 else if (SCM_SYMBOLP (quotee
))
1782 SCM_SETCAR (expr
, SCM_IM_QUOTE
);
1787 /* Will go into the RnRS module when Guile is factorized.
1788 SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
1789 static const char s_set_x
[] = "set!";
1790 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, s_set_x
);
1793 scm_m_set_x (SCM expr
, SCM env SCM_UNUSED
)
1797 const SCM cdr_expr
= SCM_CDR (expr
);
1798 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1799 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1800 variable
= SCM_CAR (cdr_expr
);
1801 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
) || SCM_VARIABLEP (variable
),
1802 s_bad_variable
, variable
, expr
);
1804 SCM_SETCAR (expr
, SCM_IM_SET_X
);
1809 /* Start of the memoizers for non-R5RS builtin macros. */
1812 SCM_SYNTAX (s_atapply
, "@apply", scm_i_makbimacro
, scm_m_apply
);
1813 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1814 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1817 scm_m_apply (SCM expr
, SCM env SCM_UNUSED
)
1819 const SCM cdr_expr
= SCM_CDR (expr
);
1820 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1821 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_missing_expression
, expr
);
1823 SCM_SETCAR (expr
, SCM_IM_APPLY
);
1828 SCM_SYNTAX (s_atbind
, "@bind", scm_i_makbimacro
, scm_m_atbind
);
1830 /* FIXME: The following explanation should go into the documentation: */
1831 /* (@bind ((var init) ...) body ...) will assign the values of the `init's to
1832 * the global variables named by `var's (symbols, not evaluated), creating
1833 * them if they don't exist, executes body, and then restores the previous
1834 * values of the `var's. Additionally, whenever control leaves body, the
1835 * values of the `var's are saved and restored when control returns. It is an
1836 * error when a symbol appears more than once among the `var's. All `init's
1837 * are evaluated before any `var' is set.
1839 * Think of this as `let' for dynamic scope.
1842 /* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into
1843 * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...).
1845 * FIXME - also implement `@bind*'.
1848 scm_m_atbind (SCM expr
, SCM env
)
1855 const SCM top_level
= scm_env_top_level (env
);
1857 const SCM cdr_expr
= SCM_CDR (expr
);
1858 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1859 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1860 bindings
= SCM_CAR (cdr_expr
);
1861 check_bindings (bindings
, expr
);
1862 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1864 for (variable_idx
= rvariables
;
1865 !SCM_NULLP (variable_idx
);
1866 variable_idx
= SCM_CDR (variable_idx
))
1868 /* The first call to scm_sym2var will look beyond the current module,
1869 * while the second call wont. */
1870 const SCM variable
= SCM_CAR (variable_idx
);
1871 SCM new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_F
);
1872 if (SCM_FALSEP (new_variable
))
1873 new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_T
);
1874 SCM_SETCAR (variable_idx
, new_variable
);
1877 SCM_SETCAR (expr
, SCM_IM_BIND
);
1878 SCM_SETCAR (cdr_expr
, scm_cons (rvariables
, inits
));
1883 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_i_makbimacro
, scm_m_cont
);
1884 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, s_atcall_cc
);
1887 scm_m_cont (SCM expr
, SCM env SCM_UNUSED
)
1889 const SCM cdr_expr
= SCM_CDR (expr
);
1890 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1891 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1893 SCM_SETCAR (expr
, SCM_IM_CONT
);
1898 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_i_makbimacro
, scm_m_at_call_with_values
);
1899 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
1902 scm_m_at_call_with_values (SCM expr
, SCM env SCM_UNUSED
)
1904 const SCM cdr_expr
= SCM_CDR (expr
);
1905 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1906 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1908 SCM_SETCAR (expr
, SCM_IM_CALL_WITH_VALUES
);
1913 SCM_SYNTAX (s_future
, "future", scm_i_makbimacro
, scm_m_future
);
1914 SCM_GLOBAL_SYMBOL (scm_sym_future
, s_future
);
1916 /* Like promises, futures are implemented as closures with an empty
1917 * parameter list. Thus, (future <expression>) is transformed into
1918 * (#@future '() <expression>), where the empty list represents the
1919 * empty parameter list. This representation allows for easy creation
1920 * of the closure during evaluation. */
1922 scm_m_future (SCM expr
, SCM env
)
1924 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1925 SCM_SETCAR (new_expr
, SCM_IM_FUTURE
);
1930 SCM_SYNTAX (s_gset_x
, "set!", scm_i_makbimacro
, scm_m_generalized_set_x
);
1931 SCM_SYMBOL (scm_sym_setter
, "setter");
1934 scm_m_generalized_set_x (SCM expr
, SCM env
)
1936 SCM target
, exp_target
;
1938 const SCM cdr_expr
= SCM_CDR (expr
);
1939 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1940 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1942 target
= SCM_CAR (cdr_expr
);
1943 if (!SCM_CONSP (target
))
1946 return scm_m_set_x (expr
, env
);
1950 /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */
1951 /* Macroexpanding the target might return things of the form
1952 (begin <atom>). In that case, <atom> must be a symbol or a
1953 variable and we memoize to (set! <atom> ...).
1955 exp_target
= scm_macroexp (target
, env
);
1956 if (SCM_EQ_P (SCM_CAR (exp_target
), SCM_IM_BEGIN
)
1957 && !SCM_NULLP (SCM_CDR (exp_target
))
1958 && SCM_NULLP (SCM_CDDR (exp_target
)))
1960 exp_target
= SCM_CADR (exp_target
);
1961 ASSERT_SYNTAX_2 (SCM_SYMBOLP (exp_target
)
1962 || SCM_VARIABLEP (exp_target
),
1963 s_bad_variable
, exp_target
, expr
);
1964 return scm_cons (SCM_IM_SET_X
, scm_cons (exp_target
,
1965 SCM_CDR (cdr_expr
)));
1969 const SCM setter_proc_tail
= scm_list_1 (SCM_CAR (target
));
1970 const SCM setter_proc
= scm_cons_source (expr
, scm_sym_setter
,
1973 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1974 const SCM setter_args
= scm_append_x (scm_list_2 (SCM_CDR (target
),
1977 SCM_SETCAR (expr
, setter_proc
);
1978 SCM_SETCDR (expr
, setter_args
);
1985 /* @slot-ref is bound privately in the (oop goops) module from goops.c. As
1986 * soon as the module system allows us to more freely create bindings in
1987 * arbitrary modules during the startup phase, the code from goops.c should be
1990 scm_m_atslot_ref (SCM expr
, SCM env SCM_UNUSED
)
1994 const SCM cdr_expr
= SCM_CDR (expr
);
1995 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1996 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1997 slot_nr
= SCM_CADR (cdr_expr
);
1998 ASSERT_SYNTAX_2 (SCM_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2000 SCM_SETCAR (expr
, SCM_IM_SLOT_REF
);
2005 /* @slot-set! is bound privately in the (oop goops) module from goops.c. As
2006 * soon as the module system allows us to more freely create bindings in
2007 * arbitrary modules during the startup phase, the code from goops.c should be
2010 scm_m_atslot_set_x (SCM expr
, SCM env SCM_UNUSED
)
2014 const SCM cdr_expr
= SCM_CDR (expr
);
2015 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2016 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 3, s_expression
, expr
);
2017 slot_nr
= SCM_CADR (cdr_expr
);
2018 ASSERT_SYNTAX_2 (SCM_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2020 SCM_SETCAR (expr
, SCM_IM_SLOT_SET_X
);
2025 #if SCM_ENABLE_ELISP
2027 static const char s_defun
[] = "Symbol's function definition is void";
2029 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_i_makbimacro
, scm_m_nil_cond
);
2031 /* nil-cond expressions have the form
2032 * (nil-cond COND VAL COND VAL ... ELSEVAL) */
2034 scm_m_nil_cond (SCM expr
, SCM env SCM_UNUSED
)
2036 const long length
= scm_ilength (SCM_CDR (expr
));
2037 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
2038 ASSERT_SYNTAX (length
>= 1 && (length
% 2) == 1, s_expression
, expr
);
2040 SCM_SETCAR (expr
, SCM_IM_NIL_COND
);
2045 SCM_SYNTAX (s_atfop
, "@fop", scm_i_makbimacro
, scm_m_atfop
);
2047 /* The @fop-macro handles procedure and macro applications for elisp. The
2048 * input expression must have the form
2049 * (@fop <var> (transformer-macro <expr> ...))
2050 * where <var> must be a symbol. The expression is transformed into the
2051 * memoized form of either
2052 * (apply <un-aliased var> (transformer-macro <expr> ...))
2053 * if the value of var (across all aliasing) is not a macro, or
2054 * (<un-aliased var> <expr> ...)
2055 * if var is a macro. */
2057 scm_m_atfop (SCM expr
, SCM env SCM_UNUSED
)
2062 const SCM cdr_expr
= SCM_CDR (expr
);
2063 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2064 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 1, s_missing_expression
, expr
);
2066 symbol
= SCM_CAR (cdr_expr
);
2067 ASSERT_SYNTAX_2 (SCM_SYMBOLP (symbol
), s_bad_variable
, symbol
, expr
);
2069 location
= scm_symbol_fref (symbol
);
2070 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2072 /* The elisp function `defalias' allows to define aliases for symbols. To
2073 * look up such definitions, the chain of symbol definitions has to be
2074 * followed up to the terminal symbol. */
2075 while (SCM_SYMBOLP (SCM_VARIABLE_REF (location
)))
2077 const SCM alias
= SCM_VARIABLE_REF (location
);
2078 location
= scm_symbol_fref (alias
);
2079 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2082 /* Memoize the value location belonging to the terminal symbol. */
2083 SCM_SETCAR (cdr_expr
, location
);
2085 if (!SCM_MACROP (SCM_VARIABLE_REF (location
)))
2087 /* Since the location does not contain a macro, the form is a procedure
2088 * application. Replace `@fop' by `@apply' and transform the expression
2089 * including the `transformer-macro'. */
2090 SCM_SETCAR (expr
, SCM_IM_APPLY
);
2095 /* Since the location contains a macro, the arguments should not be
2096 * transformed, so the `transformer-macro' is cut out. The resulting
2097 * expression starts with the memoized variable, that is at the cdr of
2098 * the input expression. */
2099 SCM_SETCDR (cdr_expr
, SCM_CDADR (cdr_expr
));
2104 #endif /* SCM_ENABLE_ELISP */
2107 /* Start of the memoizers for deprecated macros. */
2110 #if (SCM_ENABLE_DEPRECATED == 1)
2112 SCM_SYNTAX (s_undefine
, "undefine", scm_makacro
, scm_m_undefine
);
2115 scm_m_undefine (SCM expr
, SCM env
)
2120 const SCM cdr_expr
= SCM_CDR (expr
);
2121 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), "Bad undefine placement in", expr
);
2122 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2123 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2125 variable
= SCM_CAR (cdr_expr
);
2126 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
), s_bad_variable
, variable
, expr
);
2127 location
= scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_F
);
2128 ASSERT_SYNTAX_2 (!SCM_FALSEP (location
)
2129 && !SCM_UNBNDP (SCM_VARIABLE_REF (location
)),
2130 "variable already unbound ", variable
, expr
);
2131 SCM_VARIABLE_SET (location
, SCM_UNDEFINED
);
2132 return SCM_UNSPECIFIED
;
2138 #if (SCM_ENABLE_DEPRECATED == 1)
2141 scm_macroexp (SCM x
, SCM env
)
2143 SCM res
, proc
, orig_sym
;
2145 /* Don't bother to produce error messages here. We get them when we
2146 eventually execute the code for real. */
2149 orig_sym
= SCM_CAR (x
);
2150 if (!SCM_SYMBOLP (orig_sym
))
2154 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
2155 if (proc_ptr
== NULL
)
2157 /* We have lost the race. */
2163 /* Only handle memoizing macros. `Acros' and `macros' are really
2164 special forms and should not be evaluated here. */
2166 if (!SCM_MACROP (proc
)
2167 || (SCM_MACRO_TYPE (proc
) != 2 && !SCM_BUILTIN_MACRO_P (proc
)))
2170 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
2171 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
2173 if (scm_ilength (res
) <= 0)
2174 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
2177 SCM_SETCAR (x
, SCM_CAR (res
));
2178 SCM_SETCDR (x
, SCM_CDR (res
));
2186 /*****************************************************************************/
2187 /*****************************************************************************/
2188 /* The definitions for unmemoization start here. */
2189 /*****************************************************************************/
2190 /*****************************************************************************/
2192 #define SCM_BIT7(x) (127 & SCM_UNPACK (x))
2194 SCM_SYMBOL (sym_three_question_marks
, "???");
2197 /* scm_unmemocopy takes a memoized expression together with its
2198 * environment and rewrites it to its original form. Thus, it is the
2199 * inversion of the rewrite rules above. The procedure is not
2200 * optimized for speed. It's used in scm_iprin1 when printing the
2201 * code of a closure, in scm_procedure_source, in display_frame when
2202 * generating the source for a stackframe in a backtrace, and in
2203 * display_expression.
2205 * Unmemoizing is not a reliable process. You cannot in general
2206 * expect to get the original source back.
2208 * However, GOOPS currently relies on this for method compilation.
2209 * This ought to change.
2213 build_binding_list (SCM rnames
, SCM rinits
)
2215 SCM bindings
= SCM_EOL
;
2216 while (!SCM_NULLP (rnames
))
2218 SCM binding
= scm_list_2 (SCM_CAR (rnames
), SCM_CAR (rinits
));
2219 bindings
= scm_cons (binding
, bindings
);
2220 rnames
= SCM_CDR (rnames
);
2221 rinits
= SCM_CDR (rinits
);
2228 unmemocar (SCM form
, SCM env
)
2230 if (!SCM_CONSP (form
))
2234 SCM c
= SCM_CAR (form
);
2235 if (SCM_VARIABLEP (c
))
2237 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
2238 if (SCM_FALSEP (sym
))
2239 sym
= sym_three_question_marks
;
2240 SCM_SETCAR (form
, sym
);
2242 else if (SCM_ILOCP (c
))
2244 unsigned long int ir
;
2246 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
2247 env
= SCM_CDR (env
);
2248 env
= SCM_CAAR (env
);
2249 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
2250 env
= SCM_CDR (env
);
2251 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
2258 #if (SCM_ENABLE_DEPRECATED == 1)
2261 scm_unmemocar (SCM form
, SCM env
)
2263 return unmemocar (form
, env
);
2270 unmemocopy (SCM x
, SCM env
)
2275 if (SCM_VECTORP (x
))
2277 return scm_list_2 (scm_sym_quote
, x
);
2279 else if (!SCM_CONSP (x
))
2282 p
= scm_whash_lookup (scm_source_whash
, x
);
2283 switch (SCM_ITAG7 (SCM_CAR (x
)))
2285 case SCM_BIT7 (SCM_IM_AND
):
2286 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
2288 case SCM_BIT7 (SCM_IM_BEGIN
):
2289 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
2291 case SCM_BIT7 (SCM_IM_CASE
):
2292 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
2294 case SCM_BIT7 (SCM_IM_COND
):
2295 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
2297 case SCM_BIT7 (SCM_IM_DO
):
2299 /* format: (#@do (i1 ... ik) (nk nk-1 ...) (test) (body) s1 ... sk),
2300 * where ix is an initializer for a local variable, nx is the name of
2301 * the local variable, test is the test clause of the do loop, body is
2302 * the body of the do loop and sx are the step clauses for the local
2304 SCM names
, inits
, test
, memoized_body
, steps
, bindings
;
2307 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
2309 names
= SCM_CAR (x
);
2310 env
= SCM_EXTEND_ENV (names
, SCM_EOL
, env
);
2312 test
= unmemocopy (SCM_CAR (x
), env
);
2314 memoized_body
= SCM_CAR (x
);
2316 steps
= scm_reverse (unmemocopy (x
, env
));
2318 /* build transformed binding list */
2320 while (!SCM_NULLP (names
))
2322 SCM name
= SCM_CAR (names
);
2323 SCM init
= SCM_CAR (inits
);
2324 SCM step
= SCM_CAR (steps
);
2325 step
= SCM_EQ_P (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
2327 bindings
= scm_cons (scm_cons2 (name
, init
, step
), bindings
);
2329 names
= SCM_CDR (names
);
2330 inits
= SCM_CDR (inits
);
2331 steps
= SCM_CDR (steps
);
2333 z
= scm_cons (test
, SCM_UNSPECIFIED
);
2334 ls
= scm_cons2 (scm_sym_do
, bindings
, z
);
2336 x
= scm_cons (SCM_BOOL_F
, memoized_body
);
2339 case SCM_BIT7 (SCM_IM_IF
):
2340 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
2342 case SCM_BIT7 (SCM_IM_LET
):
2344 /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),
2345 * where nx is the name of a local variable, ix is an initializer for
2346 * the local variable and by are the body clauses. */
2347 SCM rnames
, rinits
, bindings
;
2350 rnames
= SCM_CAR (x
);
2352 rinits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
2353 env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
2355 bindings
= build_binding_list (rnames
, rinits
);
2356 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
2357 ls
= scm_cons (scm_sym_let
, z
);
2360 case SCM_BIT7 (SCM_IM_LETREC
):
2362 /* format: (#@letrec (vn ... v2 v1) (i1 i2 ... in) b1 ...),
2363 * where vx is the name of a local variable, ix is an initializer for
2364 * the local variable and by are the body clauses. */
2365 SCM rnames
, rinits
, bindings
;
2368 rnames
= SCM_CAR (x
);
2369 env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
2371 rinits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
2373 bindings
= build_binding_list (rnames
, rinits
);
2374 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
2375 ls
= scm_cons (scm_sym_letrec
, z
);
2378 case SCM_BIT7 (SCM_IM_LETSTAR
):
2386 env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2389 y
= z
= scm_acons (SCM_CAR (b
),
2391 scm_cons (unmemocopy (SCM_CADR (b
), env
), SCM_EOL
), env
),
2393 env
= SCM_EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
2397 SCM_SETCDR (y
, SCM_EOL
);
2398 z
= scm_cons (y
, SCM_UNSPECIFIED
);
2399 ls
= scm_cons (scm_sym_let
, z
);
2404 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
2406 scm_list_1 (unmemocopy (SCM_CADR (b
), env
)), env
),
2409 env
= SCM_EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
2412 while (SCM_NIMP (b
));
2413 SCM_SETCDR (z
, SCM_EOL
);
2415 z
= scm_cons (y
, SCM_UNSPECIFIED
);
2416 ls
= scm_cons (scm_sym_letstar
, z
);
2419 case SCM_BIT7 (SCM_IM_OR
):
2420 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
2422 case SCM_BIT7 (SCM_IM_LAMBDA
):
2424 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
);
2425 ls
= scm_cons (scm_sym_lambda
, z
);
2426 env
= SCM_EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
2428 case SCM_BIT7 (SCM_IM_QUOTE
):
2429 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
2431 case SCM_BIT7 (SCM_IM_SET_X
):
2432 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
2434 case SCM_BIT7 (SCM_MAKISYM (0)):
2436 switch (SCM_ISYMNUM (z
))
2438 case (SCM_ISYMNUM (SCM_IM_DEFINE
)):
2443 z
= scm_cons (n
, SCM_UNSPECIFIED
);
2444 ls
= scm_cons (scm_sym_define
, z
);
2445 if (!SCM_NULLP (env
))
2446 env
= scm_cons (scm_cons (scm_cons (n
, SCM_CAAR (env
)),
2451 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2452 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
2454 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2455 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
2457 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2458 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
2461 case (SCM_ISYMNUM (SCM_IM_FUTURE
)):
2462 ls
= z
= scm_cons (scm_sym_future
, SCM_UNSPECIFIED
);
2465 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2466 ls
= z
= scm_cons (scm_sym_at_call_with_values
, SCM_UNSPECIFIED
);
2468 case (SCM_ISYMNUM (SCM_IM_ELSE
)):
2469 ls
= z
= scm_cons (scm_sym_else
, SCM_UNSPECIFIED
);
2472 /* appease the Sun compiler god: */ ;
2475 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
2481 while (SCM_CONSP (x
))
2483 SCM form
= SCM_CAR (x
);
2484 if (!SCM_ISYMP (form
))
2486 SCM copy
= scm_cons (unmemocopy (form
, env
), SCM_UNSPECIFIED
);
2487 SCM_SETCDR (z
, unmemocar (copy
, env
));
2490 else if (SCM_EQ_P (form
, SCM_IM_ARROW
))
2492 SCM_SETCDR (z
, scm_cons (scm_sym_arrow
, SCM_UNSPECIFIED
));
2498 if (!SCM_FALSEP (p
))
2499 scm_whash_insert (scm_source_whash
, ls
, p
);
2504 scm_unmemocopy (SCM x
, SCM env
)
2506 if (!SCM_NULLP (env
))
2507 /* Make a copy of the lowest frame to protect it from
2508 modifications by SCM_IM_DEFINE */
2509 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
2511 return unmemocopy (x
, env
);
2515 /*****************************************************************************/
2516 /*****************************************************************************/
2517 /* The definitions for execution start here. */
2518 /*****************************************************************************/
2519 /*****************************************************************************/
2521 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
2522 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
2523 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
2524 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
2526 /* A function object to implement "apply" for non-closure functions. */
2528 /* An endless list consisting of #<undefined> objects: */
2529 static SCM undefineds
;
2533 scm_badargsp (SCM formals
, SCM args
)
2535 while (!SCM_NULLP (formals
))
2537 if (!SCM_CONSP (formals
))
2539 if (SCM_NULLP (args
))
2541 formals
= SCM_CDR (formals
);
2542 args
= SCM_CDR (args
);
2544 return !SCM_NULLP (args
) ? 1 : 0;
2549 scm_eval_args (SCM l
, SCM env
, SCM proc
)
2551 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
2552 while (SCM_CONSP (l
))
2554 res
= EVALCAR (l
, env
);
2556 *lloc
= scm_list_1 (res
);
2557 lloc
= SCM_CDRLOC (*lloc
);
2561 scm_wrong_num_args (proc
);
2567 scm_eval_body (SCM code
, SCM env
)
2571 next
= SCM_CDR (code
);
2572 while (!SCM_NULLP (next
))
2574 if (SCM_IMP (SCM_CAR (code
)))
2576 if (SCM_ISYMP (SCM_CAR (code
)))
2578 scm_rec_mutex_lock (&source_mutex
);
2579 /* check for race condition */
2580 if (SCM_ISYMP (SCM_CAR (code
)))
2581 code
= m_expand_body (code
, env
);
2582 scm_rec_mutex_unlock (&source_mutex
);
2587 SCM_XEVAL (SCM_CAR (code
), env
);
2589 next
= SCM_CDR (code
);
2591 return SCM_XEVALCAR (code
, env
);
2597 /* SECTION: This code is specific for the debugging support. One
2598 * branch is read when DEVAL isn't defined, the other when DEVAL is
2604 #define SCM_APPLY scm_apply
2605 #define PREP_APPLY(proc, args)
2607 #define RETURN(x) do { return x; } while (0)
2608 #ifdef STACK_CHECKING
2609 #ifndef NO_CEVAL_STACK_CHECKING
2610 #define EVAL_STACK_CHECKING
2617 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
2619 #define SCM_APPLY scm_dapply
2621 #define PREP_APPLY(p, l) \
2622 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
2624 #define ENTER_APPLY \
2626 SCM_SET_ARGSREADY (debug);\
2627 if (scm_check_apply_p && SCM_TRAPS_P)\
2628 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
2630 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
2631 SCM_SET_TRACED_FRAME (debug); \
2633 if (SCM_CHEAPTRAPS_P)\
2635 tmp = scm_make_debugobj (&debug);\
2636 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
2641 tmp = scm_make_continuation (&first);\
2643 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
2649 #define RETURN(e) do { proc = (e); goto exit; } while (0)
2650 #ifdef STACK_CHECKING
2651 #ifndef EVAL_STACK_CHECKING
2652 #define EVAL_STACK_CHECKING
2656 /* scm_ceval_ptr points to the currently selected evaluator.
2657 * *fixme*: Although efficiency is important here, this state variable
2658 * should probably not be a global. It should be related to the
2663 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
2665 /* scm_last_debug_frame contains a pointer to the last debugging
2666 * information stack frame. It is accessed very often from the
2667 * debugging evaluator, so it should probably not be indirectly
2668 * addressed. Better to save and restore it from the current root at
2672 /* scm_debug_eframe_size is the number of slots available for pseudo
2673 * stack frames at each real stack frame.
2676 long scm_debug_eframe_size
;
2678 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
2680 long scm_eval_stack
;
2682 scm_t_option scm_eval_opts
[] = {
2683 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
2686 scm_t_option scm_debug_opts
[] = {
2687 { SCM_OPTION_BOOLEAN
, "cheap", 1,
2688 "*Flyweight representation of the stack at traps." },
2689 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
2690 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
2691 { SCM_OPTION_BOOLEAN
, "procnames", 1,
2692 "Record procedure names at definition." },
2693 { SCM_OPTION_BOOLEAN
, "backwards", 0,
2694 "Display backtrace in anti-chronological order." },
2695 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
2696 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
2697 { SCM_OPTION_INTEGER
, "frames", 3,
2698 "Maximum number of tail-recursive frames in backtrace." },
2699 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
2700 "Maximal number of stored backtrace frames." },
2701 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
2702 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
2703 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
2704 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
2705 { 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."}
2708 scm_t_option scm_evaluator_trap_table
[] = {
2709 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
2710 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
2711 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
2712 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
2713 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
2714 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
2715 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
2718 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
2720 "Option interface for the evaluation options. Instead of using\n"
2721 "this procedure directly, use the procedures @code{eval-enable},\n"
2722 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
2723 #define FUNC_NAME s_scm_eval_options_interface
2727 ans
= scm_options (setting
,
2731 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
2738 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
2740 "Option interface for the evaluator trap options.")
2741 #define FUNC_NAME s_scm_evaluator_traps
2745 ans
= scm_options (setting
,
2746 scm_evaluator_trap_table
,
2747 SCM_N_EVALUATOR_TRAPS
,
2749 SCM_RESET_DEBUG_MODE
;
2757 deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
2759 SCM
*results
= lloc
, res
;
2760 while (SCM_CONSP (l
))
2762 res
= EVALCAR (l
, env
);
2764 *lloc
= scm_list_1 (res
);
2765 lloc
= SCM_CDRLOC (*lloc
);
2769 scm_wrong_num_args (proc
);
2776 /* SECTION: This code is compiled twice.
2780 /* Update the toplevel environment frame ENV so that it refers to the
2781 * current module. */
2782 #define UPDATE_TOPLEVEL_ENV(env) \
2784 SCM p = scm_current_module_lookup_closure (); \
2785 if (p != SCM_CAR (env)) \
2786 env = scm_top_level_env (p); \
2790 #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
2791 ASSERT_SYNTAX (!SCM_EQ_P ((x), SCM_EOL), s_empty_combination, x)
2794 /* This is the evaluator. Like any real monster, it has three heads:
2796 * scm_ceval is the non-debugging evaluator, scm_deval is the debugging
2797 * version. Both are implemented using a common code base, using the
2798 * following mechanism: SCM_CEVAL is a macro, which is either defined to
2799 * scm_ceval or scm_deval. Thus, there is no function SCM_CEVAL, but the code
2800 * for SCM_CEVAL actually compiles to either scm_ceval or scm_deval. When
2801 * SCM_CEVAL is defined to scm_ceval, it is known that the macro DEVAL is not
2802 * defined. When SCM_CEVAL is defined to scm_deval, then the macro DEVAL is
2803 * known to be defined. Thus, in SCM_CEVAL parts for the debugging evaluator
2804 * are enclosed within #ifdef DEVAL ... #endif.
2806 * All three (scm_ceval, scm_deval and their common implementation SCM_CEVAL)
2807 * take two input parameters, x and env: x is a single expression to be
2808 * evalutated. env is the environment in which bindings are searched.
2810 * x is known to be a cell (i. e. a pair or any other non-immediate). Since x
2811 * is a single expression, it is necessarily in a tail position. If x is just
2812 * a call to another function like in the expression (foo exp1 exp2 ...), the
2813 * realization of that call therefore _must_not_ increase stack usage (the
2814 * evaluation of exp1, exp2 etc., however, may do so). This is realized by
2815 * making extensive use of 'goto' statements within the evaluator: The gotos
2816 * replace recursive calls to SCM_CEVAL, thus re-using the same stack frame
2817 * that SCM_CEVAL was already using. If, however, x represents some form that
2818 * requires to evaluate a sequence of expressions like (begin exp1 exp2 ...),
2819 * then recursive calls to SCM_CEVAL are performed for all but the last
2820 * expression of that sequence. */
2824 scm_ceval (SCM x
, SCM env
)
2830 scm_deval (SCM x
, SCM env
)
2835 SCM_CEVAL (SCM x
, SCM env
)
2839 scm_t_debug_frame debug
;
2840 scm_t_debug_info
*debug_info_end
;
2841 debug
.prev
= scm_last_debug_frame
;
2844 * The debug.vect contains twice as much scm_t_debug_info frames as the
2845 * user has specified with (debug-set! frames <n>).
2847 * Even frames are eval frames, odd frames are apply frames.
2849 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
2850 * sizeof (scm_t_debug_info
));
2851 debug
.info
= debug
.vect
;
2852 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
2853 scm_last_debug_frame
= &debug
;
2855 #ifdef EVAL_STACK_CHECKING
2856 if (scm_stack_checking_enabled_p
&& SCM_STACK_OVERFLOW_P (&proc
))
2859 debug
.info
->e
.exp
= x
;
2860 debug
.info
->e
.env
= env
;
2862 scm_report_stack_overflow ();
2872 SCM_CLEAR_ARGSREADY (debug
);
2873 if (SCM_OVERFLOWP (debug
))
2876 * In theory, this should be the only place where it is necessary to
2877 * check for space in debug.vect since both eval frames and
2878 * available space are even.
2880 * For this to be the case, however, it is necessary that primitive
2881 * special forms which jump back to `loop', `begin' or some similar
2882 * label call PREP_APPLY.
2884 else if (++debug
.info
>= debug_info_end
)
2886 SCM_SET_OVERFLOW (debug
);
2891 debug
.info
->e
.exp
= x
;
2892 debug
.info
->e
.env
= env
;
2893 if (scm_check_entry_p
&& SCM_TRAPS_P
)
2895 if (SCM_ENTER_FRAME_P
2896 || (SCM_BREAKPOINTS_P
&& scm_c_source_property_breakpoint_p (x
)))
2899 SCM tail
= SCM_BOOL (SCM_TAILRECP (debug
));
2900 SCM_SET_TAILREC (debug
);
2901 if (SCM_CHEAPTRAPS_P
)
2902 stackrep
= scm_make_debugobj (&debug
);
2906 SCM val
= scm_make_continuation (&first
);
2916 /* This gives the possibility for the debugger to
2917 modify the source expression before evaluation. */
2922 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
2923 scm_sym_enter_frame
,
2926 scm_unmemocopy (x
, env
));
2933 switch (SCM_TYP7 (x
))
2935 case SCM_BIT7 (SCM_IM_AND
):
2937 while (!SCM_NULLP (SCM_CDR (x
)))
2939 SCM test_result
= EVALCAR (x
, env
);
2940 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
2941 RETURN (SCM_BOOL_F
);
2945 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2948 case SCM_BIT7 (SCM_IM_BEGIN
):
2951 RETURN (SCM_UNSPECIFIED
);
2953 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2956 /* If we are on toplevel with a lookup closure, we need to sync
2957 with the current module. */
2958 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
2960 UPDATE_TOPLEVEL_ENV (env
);
2961 while (!SCM_NULLP (SCM_CDR (x
)))
2964 UPDATE_TOPLEVEL_ENV (env
);
2970 goto nontoplevel_begin
;
2973 while (!SCM_NULLP (SCM_CDR (x
)))
2975 SCM form
= SCM_CAR (x
);
2978 if (SCM_ISYMP (form
))
2980 scm_rec_mutex_lock (&source_mutex
);
2981 /* check for race condition */
2982 if (SCM_ISYMP (SCM_CAR (x
)))
2983 x
= m_expand_body (x
, env
);
2984 scm_rec_mutex_unlock (&source_mutex
);
2985 goto nontoplevel_begin
;
2988 SCM_VALIDATE_NON_EMPTY_COMBINATION (form
);
2991 SCM_CEVAL (form
, env
);
2997 /* scm_eval last form in list */
2998 SCM last_form
= SCM_CAR (x
);
3000 if (SCM_CONSP (last_form
))
3002 /* This is by far the most frequent case. */
3004 goto loop
; /* tail recurse */
3006 else if (SCM_IMP (last_form
))
3007 RETURN (SCM_EVALIM (last_form
, env
));
3008 else if (SCM_VARIABLEP (last_form
))
3009 RETURN (SCM_VARIABLE_REF (last_form
));
3010 else if (SCM_SYMBOLP (last_form
))
3011 RETURN (*scm_lookupcar (x
, env
, 1));
3017 case SCM_BIT7 (SCM_IM_CASE
):
3020 SCM key
= EVALCAR (x
, env
);
3022 while (!SCM_NULLP (x
))
3024 SCM clause
= SCM_CAR (x
);
3025 SCM labels
= SCM_CAR (clause
);
3026 if (SCM_EQ_P (labels
, SCM_IM_ELSE
))
3028 x
= SCM_CDR (clause
);
3029 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3032 while (!SCM_NULLP (labels
))
3034 SCM label
= SCM_CAR (labels
);
3035 if (SCM_EQ_P (label
, key
) || !SCM_FALSEP (scm_eqv_p (label
, key
)))
3037 x
= SCM_CDR (clause
);
3038 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3041 labels
= SCM_CDR (labels
);
3046 RETURN (SCM_UNSPECIFIED
);
3049 case SCM_BIT7 (SCM_IM_COND
):
3051 while (!SCM_NULLP (x
))
3053 SCM clause
= SCM_CAR (x
);
3054 if (SCM_EQ_P (SCM_CAR (clause
), SCM_IM_ELSE
))
3056 x
= SCM_CDR (clause
);
3057 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3062 arg1
= EVALCAR (clause
, env
);
3063 if (!SCM_FALSEP (arg1
) && !SCM_NILP (arg1
))
3065 x
= SCM_CDR (clause
);
3068 else if (!SCM_EQ_P (SCM_CAR (x
), SCM_IM_ARROW
))
3070 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3076 proc
= EVALCAR (proc
, env
);
3077 PREP_APPLY (proc
, scm_list_1 (arg1
));
3085 RETURN (SCM_UNSPECIFIED
);
3088 case SCM_BIT7 (SCM_IM_DO
):
3091 /* Compute the initialization values and the initial environment. */
3092 SCM init_forms
= SCM_CAR (x
);
3093 SCM init_values
= SCM_EOL
;
3094 while (!SCM_NULLP (init_forms
))
3096 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3097 init_forms
= SCM_CDR (init_forms
);
3100 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
3104 SCM test_form
= SCM_CAR (x
);
3105 SCM body_forms
= SCM_CADR (x
);
3106 SCM step_forms
= SCM_CDDR (x
);
3108 SCM test_result
= EVALCAR (test_form
, env
);
3110 while (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
3113 /* Evaluate body forms. */
3115 for (temp_forms
= body_forms
;
3116 !SCM_NULLP (temp_forms
);
3117 temp_forms
= SCM_CDR (temp_forms
))
3119 SCM form
= SCM_CAR (temp_forms
);
3120 /* Dirk:FIXME: We only need to eval forms, that may have a
3121 * side effect here. This is only true for forms that start
3122 * with a pair. All others are just constants. However,
3123 * since in the common case there is no constant expression
3124 * in a body of a do form, we just check for immediates here
3125 * and have SCM_CEVAL take care of other cases. In the long
3126 * run it would make sense to get rid of this test and have
3127 * the macro transformer of 'do' eliminate all forms that
3128 * have no sideeffect. */
3129 if (!SCM_IMP (form
))
3130 SCM_CEVAL (form
, env
);
3135 /* Evaluate the step expressions. */
3137 SCM step_values
= SCM_EOL
;
3138 for (temp_forms
= step_forms
;
3139 !SCM_NULLP (temp_forms
);
3140 temp_forms
= SCM_CDR (temp_forms
))
3142 SCM value
= EVALCAR (temp_forms
, env
);
3143 step_values
= scm_cons (value
, step_values
);
3145 env
= SCM_EXTEND_ENV (SCM_CAAR (env
),
3150 test_result
= EVALCAR (test_form
, env
);
3155 RETURN (SCM_UNSPECIFIED
);
3156 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3157 goto nontoplevel_begin
;
3160 case SCM_BIT7 (SCM_IM_IF
):
3163 SCM test_result
= EVALCAR (x
, env
);
3164 x
= SCM_CDR (x
); /* then expression */
3165 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
3167 x
= SCM_CDR (x
); /* else expression */
3169 RETURN (SCM_UNSPECIFIED
);
3172 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3176 case SCM_BIT7 (SCM_IM_LET
):
3179 SCM init_forms
= SCM_CADR (x
);
3180 SCM init_values
= SCM_EOL
;
3183 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3184 init_forms
= SCM_CDR (init_forms
);
3186 while (!SCM_NULLP (init_forms
));
3187 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
3190 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3191 goto nontoplevel_begin
;
3194 case SCM_BIT7 (SCM_IM_LETREC
):
3196 env
= SCM_EXTEND_ENV (SCM_CAR (x
), undefineds
, env
);
3199 SCM init_forms
= SCM_CAR (x
);
3200 SCM init_values
= SCM_EOL
;
3203 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3204 init_forms
= SCM_CDR (init_forms
);
3206 while (!SCM_NULLP (init_forms
));
3207 SCM_SETCDR (SCM_CAR (env
), init_values
);
3210 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3211 goto nontoplevel_begin
;
3214 case SCM_BIT7 (SCM_IM_LETSTAR
):
3217 SCM bindings
= SCM_CAR (x
);
3218 if (SCM_NULLP (bindings
))
3219 env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
3224 SCM name
= SCM_CAR (bindings
);
3225 SCM init
= SCM_CDR (bindings
);
3226 env
= SCM_EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
3227 bindings
= SCM_CDR (init
);
3229 while (!SCM_NULLP (bindings
));
3233 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3234 goto nontoplevel_begin
;
3237 case SCM_BIT7 (SCM_IM_OR
):
3239 while (!SCM_NULLP (SCM_CDR (x
)))
3241 SCM val
= EVALCAR (x
, env
);
3242 if (!SCM_FALSEP (val
) && !SCM_NILP (val
))
3247 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3251 case SCM_BIT7 (SCM_IM_LAMBDA
):
3252 RETURN (scm_closure (SCM_CDR (x
), env
));
3255 case SCM_BIT7 (SCM_IM_QUOTE
):
3256 RETURN (SCM_CADR (x
));
3259 case SCM_BIT7 (SCM_IM_SET_X
):
3263 SCM variable
= SCM_CAR (x
);
3264 if (SCM_ILOCP (variable
))
3265 location
= scm_ilookup (variable
, env
);
3266 else if (SCM_VARIABLEP (variable
))
3267 location
= SCM_VARIABLE_LOC (variable
);
3268 else /* (SCM_SYMBOLP (variable)) is known to be true */
3269 location
= scm_lookupcar (x
, env
, 1);
3271 *location
= EVALCAR (x
, env
);
3273 RETURN (SCM_UNSPECIFIED
);
3276 /* new syntactic forms go here. */
3277 case SCM_BIT7 (SCM_MAKISYM (0)):
3279 switch (SCM_ISYMNUM (proc
))
3283 case (SCM_ISYMNUM (SCM_IM_DEFINE
)):
3284 /* Top level defines are handled directly by the memoizer and thus
3285 * will never generate memoized code with SCM_IM_DEFINE. Internal
3286 * defines which occur at valid positions will be transformed into
3287 * letrec expressions. Thus, whenever the executor detects
3288 * SCM_IM_DEFINE, this must come from an internal definition at an
3289 * illegal position. */
3290 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
3293 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
3295 proc
= EVALCAR (x
, env
);
3296 PREP_APPLY (proc
, SCM_EOL
);
3298 arg1
= EVALCAR (x
, env
);
3301 /* Go here to tail-apply a procedure. PROC is the procedure and
3302 * ARG1 is the list of arguments. PREP_APPLY must have been called
3303 * before jumping to apply_proc. */
3304 if (SCM_CLOSUREP (proc
))
3306 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3308 debug
.info
->a
.args
= arg1
;
3310 if (scm_badargsp (formals
, arg1
))
3311 scm_wrong_num_args (proc
);
3313 /* Copy argument list */
3314 if (SCM_NULL_OR_NIL_P (arg1
))
3315 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
3318 SCM args
= scm_list_1 (SCM_CAR (arg1
));
3320 arg1
= SCM_CDR (arg1
);
3321 while (!SCM_NULL_OR_NIL_P (arg1
))
3323 SCM new_tail
= scm_list_1 (SCM_CAR (arg1
));
3324 SCM_SETCDR (tail
, new_tail
);
3326 arg1
= SCM_CDR (arg1
);
3328 env
= SCM_EXTEND_ENV (formals
, args
, SCM_ENV (proc
));
3331 x
= SCM_CLOSURE_BODY (proc
);
3332 goto nontoplevel_begin
;
3337 RETURN (SCM_APPLY (proc
, arg1
, SCM_EOL
));
3341 case (SCM_ISYMNUM (SCM_IM_CONT
)):
3344 SCM val
= scm_make_continuation (&first
);
3352 proc
= scm_eval_car (proc
, env
);
3353 PREP_APPLY (proc
, scm_list_1 (arg1
));
3360 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
3361 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
3364 case (SCM_ISYMNUM (SCM_IM_FUTURE
)):
3365 RETURN (scm_i_make_future (scm_closure (SCM_CDR (x
), env
)));
3368 /* PLACEHOLDER for case (SCM_ISYMNUM (SCM_IM_DISPATCH)): The
3369 following code (type_dispatch) is intended to be the tail
3370 of the case clause for the internal macro
3371 SCM_IM_DISPATCH. Please don't remove it from this
3372 location without discussing it with Mikael
3373 <djurfeldt@nada.kth.se> */
3375 /* The type dispatch code is duplicated below
3376 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
3377 * cuts down execution time for type dispatch to 50%. */
3378 type_dispatch
: /* inputs: x, arg1 */
3379 /* Type dispatch means to determine from the types of the function
3380 * arguments (i. e. the 'signature' of the call), which method from
3381 * a generic function is to be called. This process of selecting
3382 * the right method takes some time. To speed it up, guile uses
3383 * caching: Together with the macro call to dispatch the signatures
3384 * of some previous calls to that generic function from the same
3385 * place are stored (in the code!) in a cache that we call the
3386 * 'method cache'. This is done since it is likely, that
3387 * consecutive calls to dispatch from that position in the code will
3388 * have the same signature. Thus, the type dispatch works as
3389 * follows: First, determine a hash value from the signature of the
3390 * actual arguments. Second, use this hash value as an index to
3391 * find that same signature in the method cache stored at this
3392 * position in the code. If found, you have also found the
3393 * corresponding method that belongs to that signature. If the
3394 * signature is not found in the method cache, you have to perform a
3395 * full search over all signatures stored with the generic
3398 unsigned long int specializers
;
3399 unsigned long int hash_value
;
3400 unsigned long int cache_end_pos
;
3401 unsigned long int mask
;
3405 SCM z
= SCM_CDDR (x
);
3406 SCM tmp
= SCM_CADR (z
);
3407 specializers
= SCM_INUM (SCM_CAR (z
));
3409 /* Compute a hash value for searching the method cache. There
3410 * are two variants for computing the hash value, a (rather)
3411 * complicated one, and a simple one. For the complicated one
3412 * explained below, tmp holds a number that is used in the
3414 if (SCM_INUMP (tmp
))
3416 /* Use the signature of the actual arguments to determine
3417 * the hash value. This is done as follows: Each class has
3418 * an array of random numbers, that are determined when the
3419 * class is created. The integer 'hashset' is an index into
3420 * that array of random numbers. Now, from all classes that
3421 * are part of the signature of the actual arguments, the
3422 * random numbers at index 'hashset' are taken and summed
3423 * up, giving the hash value. The value of 'hashset' is
3424 * stored at the call to dispatch. This allows to have
3425 * different 'formulas' for calculating the hash value at
3426 * different places where dispatch is called. This allows
3427 * to optimize the hash formula at every individual place
3428 * where dispatch is called, such that hopefully the hash
3429 * value that is computed will directly point to the right
3430 * method in the method cache. */
3431 unsigned long int hashset
= SCM_INUM (tmp
);
3432 unsigned long int counter
= specializers
+ 1;
3435 while (!SCM_NULLP (tmp_arg
) && counter
!= 0)
3437 SCM
class = scm_class_of (SCM_CAR (tmp_arg
));
3438 hash_value
+= SCM_INSTANCE_HASH (class, hashset
);
3439 tmp_arg
= SCM_CDR (tmp_arg
);
3443 method_cache
= SCM_CADR (z
);
3444 mask
= SCM_INUM (SCM_CAR (z
));
3446 cache_end_pos
= hash_value
;
3450 /* This method of determining the hash value is much
3451 * simpler: Set the hash value to zero and just perform a
3452 * linear search through the method cache. */
3454 mask
= (unsigned long int) ((long) -1);
3456 cache_end_pos
= SCM_VECTOR_LENGTH (method_cache
);
3461 /* Search the method cache for a method with a matching
3462 * signature. Start the search at position 'hash_value'. The
3463 * hashing implementation uses linear probing for conflict
3464 * resolution, that is, if the signature in question is not
3465 * found at the starting index in the hash table, the next table
3466 * entry is tried, and so on, until in the worst case the whole
3467 * cache has been searched, but still the signature has not been
3472 SCM args
= arg1
; /* list of arguments */
3473 z
= SCM_VELTS (method_cache
)[hash_value
];
3474 while (!SCM_NULLP (args
))
3476 /* More arguments than specifiers => CLASS != ENV */
3477 SCM class_of_arg
= scm_class_of (SCM_CAR (args
));
3478 if (!SCM_EQ_P (class_of_arg
, SCM_CAR (z
)))
3480 args
= SCM_CDR (args
);
3483 /* Fewer arguments than specifiers => CAR != ENV */
3484 if (SCM_NULLP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
)))
3487 hash_value
= (hash_value
+ 1) & mask
;
3488 } while (hash_value
!= cache_end_pos
);
3490 /* No appropriate method was found in the cache. */
3491 z
= scm_memoize_method (x
, arg1
);
3493 apply_cmethod
: /* inputs: z, arg1 */
3495 SCM formals
= SCM_CMETHOD_FORMALS (z
);
3496 env
= SCM_EXTEND_ENV (formals
, arg1
, SCM_CMETHOD_ENV (z
));
3497 x
= SCM_CMETHOD_BODY (z
);
3498 goto nontoplevel_begin
;
3504 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
3507 SCM instance
= EVALCAR (x
, env
);
3508 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
3509 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance
) [slot
]));
3513 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
3516 SCM instance
= EVALCAR (x
, env
);
3517 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
3518 SCM value
= EVALCAR (SCM_CDDR (x
), env
);
3519 SCM_STRUCT_DATA (instance
) [slot
] = SCM_UNPACK (value
);
3520 RETURN (SCM_UNSPECIFIED
);
3524 #if SCM_ENABLE_ELISP
3526 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
3528 SCM test_form
= SCM_CDR (x
);
3529 x
= SCM_CDR (test_form
);
3530 while (!SCM_NULL_OR_NIL_P (x
))
3532 SCM test_result
= EVALCAR (test_form
, env
);
3533 if (!(SCM_FALSEP (test_result
)
3534 || SCM_NULL_OR_NIL_P (test_result
)))
3536 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
3537 RETURN (test_result
);
3538 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3543 test_form
= SCM_CDR (x
);
3544 x
= SCM_CDR (test_form
);
3548 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3552 #endif /* SCM_ENABLE_ELISP */
3554 case (SCM_ISYMNUM (SCM_IM_BIND
)):
3556 SCM vars
, exps
, vals
;
3559 vars
= SCM_CAAR (x
);
3560 exps
= SCM_CDAR (x
);
3562 while (!SCM_NULLP (exps
))
3564 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
3565 exps
= SCM_CDR (exps
);
3568 scm_swap_bindings (vars
, vals
);
3569 scm_dynwinds
= scm_acons (vars
, vals
, scm_dynwinds
);
3571 /* Ignore all but the last evaluation result. */
3572 for (x
= SCM_CDR (x
); !SCM_NULLP (SCM_CDR (x
)); x
= SCM_CDR (x
))
3574 if (SCM_CONSP (SCM_CAR (x
)))
3575 SCM_CEVAL (SCM_CAR (x
), env
);
3577 proc
= EVALCAR (x
, env
);
3579 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
3580 scm_swap_bindings (vars
, vals
);
3586 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
3591 producer
= EVALCAR (x
, env
);
3593 proc
= EVALCAR (x
, env
); /* proc is the consumer. */
3594 arg1
= SCM_APPLY (producer
, SCM_EOL
, SCM_EOL
);
3595 if (SCM_VALUESP (arg1
))
3597 /* The list of arguments is not copied. Rather, it is assumed
3598 * that this has been done by the 'values' procedure. */
3599 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
3603 arg1
= scm_list_1 (arg1
);
3605 PREP_APPLY (proc
, arg1
);
3620 case scm_tc7_vector
:
3624 case scm_tc7_byvect
:
3631 #if SCM_SIZEOF_LONG_LONG != 0
3632 case scm_tc7_llvect
:
3635 case scm_tc7_number
:
3636 case scm_tc7_string
:
3638 case scm_tcs_closures
:
3642 case scm_tcs_struct
:
3645 case scm_tc7_symbol
:
3646 /* Only happens when called at top level. */
3647 x
= scm_cons (x
, SCM_UNDEFINED
);
3648 RETURN (*scm_lookupcar (x
, env
, 1));
3650 case scm_tc7_variable
:
3651 RETURN (SCM_VARIABLE_REF(x
));
3653 case SCM_BIT7 (SCM_ILOC00
):
3654 proc
= *scm_ilookup (SCM_CAR (x
), env
);
3657 case scm_tcs_cons_nimcar
:
3658 if (SCM_SYMBOLP (SCM_CAR (x
)))
3660 SCM orig_sym
= SCM_CAR (x
);
3662 SCM
*location
= scm_lookupcar1 (x
, env
, 1);
3663 if (location
== NULL
)
3665 /* we have lost the race, start again. */
3671 if (SCM_MACROP (proc
))
3673 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
3675 handle_a_macro
: /* inputs: x, env, proc */
3677 /* Set a flag during macro expansion so that macro
3678 application frames can be deleted from the backtrace. */
3679 SCM_SET_MACROEXP (debug
);
3681 arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
3682 scm_cons (env
, scm_listofnull
));
3685 SCM_CLEAR_MACROEXP (debug
);
3687 switch (SCM_MACRO_TYPE (proc
))
3691 if (scm_ilength (arg1
) <= 0)
3692 arg1
= scm_list_2 (SCM_IM_BEGIN
, arg1
);
3694 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
3697 SCM_SETCAR (x
, SCM_CAR (arg1
));
3698 SCM_SETCDR (x
, SCM_CDR (arg1
));
3702 /* Prevent memoizing of debug info expression. */
3703 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
3708 SCM_SETCAR (x
, SCM_CAR (arg1
));
3709 SCM_SETCDR (x
, SCM_CDR (arg1
));
3711 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3713 #if SCM_ENABLE_DEPRECATED == 1
3718 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3730 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
3733 if (SCM_MACROP (proc
))
3734 goto handle_a_macro
;
3738 evapply
: /* inputs: x, proc */
3739 PREP_APPLY (proc
, SCM_EOL
);
3740 if (SCM_NULLP (SCM_CDR (x
))) {
3743 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3744 switch (SCM_TYP7 (proc
))
3745 { /* no arguments given */
3746 case scm_tc7_subr_0
:
3747 RETURN (SCM_SUBRF (proc
) ());
3748 case scm_tc7_subr_1o
:
3749 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
3751 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
3752 case scm_tc7_rpsubr
:
3753 RETURN (SCM_BOOL_T
);
3755 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
3757 if (!SCM_SMOB_APPLICABLE_P (proc
))
3759 RETURN (SCM_SMOB_APPLY_0 (proc
));
3762 proc
= SCM_CCLO_SUBR (proc
);
3764 debug
.info
->a
.proc
= proc
;
3765 debug
.info
->a
.args
= scm_list_1 (arg1
);
3769 proc
= SCM_PROCEDURE (proc
);
3771 debug
.info
->a
.proc
= proc
;
3773 if (!SCM_CLOSUREP (proc
))
3776 case scm_tcs_closures
:
3778 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3779 if (SCM_CONSP (formals
))
3780 goto umwrongnumargs
;
3781 x
= SCM_CLOSURE_BODY (proc
);
3782 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
3783 goto nontoplevel_begin
;
3785 case scm_tcs_struct
:
3786 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3788 x
= SCM_ENTITY_PROCEDURE (proc
);
3792 else if (SCM_I_OPERATORP (proc
))
3795 proc
= (SCM_I_ENTITYP (proc
)
3796 ? SCM_ENTITY_PROCEDURE (proc
)
3797 : SCM_OPERATOR_PROCEDURE (proc
));
3799 debug
.info
->a
.proc
= proc
;
3800 debug
.info
->a
.args
= scm_list_1 (arg1
);
3806 case scm_tc7_subr_1
:
3807 case scm_tc7_subr_2
:
3808 case scm_tc7_subr_2o
:
3811 case scm_tc7_subr_3
:
3812 case scm_tc7_lsubr_2
:
3815 scm_wrong_num_args (proc
);
3818 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
3822 /* must handle macros by here */
3825 arg1
= EVALCAR (x
, env
);
3827 scm_wrong_num_args (proc
);
3829 debug
.info
->a
.args
= scm_list_1 (arg1
);
3837 evap1
: /* inputs: proc, arg1 */
3838 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3839 switch (SCM_TYP7 (proc
))
3840 { /* have one argument in arg1 */
3841 case scm_tc7_subr_2o
:
3842 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3843 case scm_tc7_subr_1
:
3844 case scm_tc7_subr_1o
:
3845 RETURN (SCM_SUBRF (proc
) (arg1
));
3847 if (SCM_INUMP (arg1
))
3849 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3851 else if (SCM_REALP (arg1
))
3853 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3855 else if (SCM_BIGP (arg1
))
3857 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3859 else if (SCM_FRACTIONP (arg1
))
3861 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
3863 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3864 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3867 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
3870 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
3871 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3872 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3877 case scm_tc7_rpsubr
:
3878 RETURN (SCM_BOOL_T
);
3880 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3883 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3885 RETURN (SCM_SUBRF (proc
) (scm_list_1 (arg1
)));
3888 if (!SCM_SMOB_APPLICABLE_P (proc
))
3890 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
3894 proc
= SCM_CCLO_SUBR (proc
);
3896 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
3897 debug
.info
->a
.proc
= proc
;
3901 proc
= SCM_PROCEDURE (proc
);
3903 debug
.info
->a
.proc
= proc
;
3905 if (!SCM_CLOSUREP (proc
))
3908 case scm_tcs_closures
:
3911 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3912 if (SCM_NULLP (formals
)
3913 || (SCM_CONSP (formals
) && SCM_CONSP (SCM_CDR (formals
))))
3914 goto umwrongnumargs
;
3915 x
= SCM_CLOSURE_BODY (proc
);
3917 env
= SCM_EXTEND_ENV (formals
,
3921 env
= SCM_EXTEND_ENV (formals
,
3925 goto nontoplevel_begin
;
3927 case scm_tcs_struct
:
3928 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3930 x
= SCM_ENTITY_PROCEDURE (proc
);
3932 arg1
= debug
.info
->a
.args
;
3934 arg1
= scm_list_1 (arg1
);
3938 else if (SCM_I_OPERATORP (proc
))
3942 proc
= (SCM_I_ENTITYP (proc
)
3943 ? SCM_ENTITY_PROCEDURE (proc
)
3944 : SCM_OPERATOR_PROCEDURE (proc
));
3946 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
3947 debug
.info
->a
.proc
= proc
;
3953 case scm_tc7_subr_2
:
3954 case scm_tc7_subr_0
:
3955 case scm_tc7_subr_3
:
3956 case scm_tc7_lsubr_2
:
3957 scm_wrong_num_args (proc
);
3963 arg2
= EVALCAR (x
, env
);
3965 scm_wrong_num_args (proc
);
3967 { /* have two or more arguments */
3969 debug
.info
->a
.args
= scm_list_2 (arg1
, arg2
);
3972 if (SCM_NULLP (x
)) {
3975 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3976 switch (SCM_TYP7 (proc
))
3977 { /* have two arguments */
3978 case scm_tc7_subr_2
:
3979 case scm_tc7_subr_2o
:
3980 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3983 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3985 RETURN (SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
)));
3987 case scm_tc7_lsubr_2
:
3988 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
));
3989 case scm_tc7_rpsubr
:
3991 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3993 if (!SCM_SMOB_APPLICABLE_P (proc
))
3995 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
));
3999 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
4000 scm_cons (proc
, debug
.info
->a
.args
),
4003 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
4004 scm_cons2 (proc
, arg1
,
4011 case scm_tcs_struct
:
4012 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4014 x
= SCM_ENTITY_PROCEDURE (proc
);
4016 arg1
= debug
.info
->a
.args
;
4018 arg1
= scm_list_2 (arg1
, arg2
);
4022 else if (SCM_I_OPERATORP (proc
))
4026 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
4027 ? SCM_ENTITY_PROCEDURE (proc
)
4028 : SCM_OPERATOR_PROCEDURE (proc
),
4029 scm_cons (proc
, debug
.info
->a
.args
),
4032 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
4033 ? SCM_ENTITY_PROCEDURE (proc
)
4034 : SCM_OPERATOR_PROCEDURE (proc
),
4035 scm_cons2 (proc
, arg1
,
4045 case scm_tc7_subr_0
:
4048 case scm_tc7_subr_1o
:
4049 case scm_tc7_subr_1
:
4050 case scm_tc7_subr_3
:
4051 scm_wrong_num_args (proc
);
4055 proc
= SCM_PROCEDURE (proc
);
4057 debug
.info
->a
.proc
= proc
;
4059 if (!SCM_CLOSUREP (proc
))
4062 case scm_tcs_closures
:
4065 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4066 if (SCM_NULLP (formals
)
4067 || (SCM_CONSP (formals
)
4068 && (SCM_NULLP (SCM_CDR (formals
))
4069 || (SCM_CONSP (SCM_CDR (formals
))
4070 && SCM_CONSP (SCM_CDDR (formals
))))))
4071 goto umwrongnumargs
;
4073 env
= SCM_EXTEND_ENV (formals
,
4077 env
= SCM_EXTEND_ENV (formals
,
4078 scm_list_2 (arg1
, arg2
),
4081 x
= SCM_CLOSURE_BODY (proc
);
4082 goto nontoplevel_begin
;
4087 scm_wrong_num_args (proc
);
4089 debug
.info
->a
.args
= scm_cons2 (arg1
, arg2
,
4090 deval_args (x
, env
, proc
,
4091 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
4095 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4096 switch (SCM_TYP7 (proc
))
4097 { /* have 3 or more arguments */
4099 case scm_tc7_subr_3
:
4100 if (!SCM_NULLP (SCM_CDR (x
)))
4101 scm_wrong_num_args (proc
);
4103 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4104 SCM_CADDR (debug
.info
->a
.args
)));
4106 arg1
= SCM_SUBRF(proc
)(arg1
, arg2
);
4107 arg2
= SCM_CDDR (debug
.info
->a
.args
);
4110 arg1
= SCM_SUBRF(proc
)(arg1
, SCM_CAR (arg2
));
4111 arg2
= SCM_CDR (arg2
);
4113 while (SCM_NIMP (arg2
));
4115 case scm_tc7_rpsubr
:
4116 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
4117 RETURN (SCM_BOOL_F
);
4118 arg1
= SCM_CDDR (debug
.info
->a
.args
);
4121 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (arg1
))))
4122 RETURN (SCM_BOOL_F
);
4123 arg2
= SCM_CAR (arg1
);
4124 arg1
= SCM_CDR (arg1
);
4126 while (SCM_NIMP (arg1
));
4127 RETURN (SCM_BOOL_T
);
4128 case scm_tc7_lsubr_2
:
4129 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4130 SCM_CDDR (debug
.info
->a
.args
)));
4132 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4134 if (!SCM_SMOB_APPLICABLE_P (proc
))
4136 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4137 SCM_CDDR (debug
.info
->a
.args
)));
4141 proc
= SCM_PROCEDURE (proc
);
4142 debug
.info
->a
.proc
= proc
;
4143 if (!SCM_CLOSUREP (proc
))
4146 case scm_tcs_closures
:
4148 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4149 if (SCM_NULLP (formals
)
4150 || (SCM_CONSP (formals
)
4151 && (SCM_NULLP (SCM_CDR (formals
))
4152 || (SCM_CONSP (SCM_CDR (formals
))
4153 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4154 goto umwrongnumargs
;
4155 SCM_SET_ARGSREADY (debug
);
4156 env
= SCM_EXTEND_ENV (formals
,
4159 x
= SCM_CLOSURE_BODY (proc
);
4160 goto nontoplevel_begin
;
4163 case scm_tc7_subr_3
:
4164 if (!SCM_NULLP (SCM_CDR (x
)))
4165 scm_wrong_num_args (proc
);
4167 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, EVALCAR (x
, env
)));
4169 arg1
= SCM_SUBRF (proc
) (arg1
, arg2
);
4172 arg1
= SCM_SUBRF(proc
)(arg1
, EVALCAR(x
, env
));
4175 while (SCM_NIMP (x
));
4177 case scm_tc7_rpsubr
:
4178 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
4179 RETURN (SCM_BOOL_F
);
4182 arg1
= EVALCAR (x
, env
);
4183 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, arg1
)))
4184 RETURN (SCM_BOOL_F
);
4188 while (SCM_NIMP (x
));
4189 RETURN (SCM_BOOL_T
);
4190 case scm_tc7_lsubr_2
:
4191 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
4193 RETURN (SCM_SUBRF (proc
) (scm_cons2 (arg1
,
4195 scm_eval_args (x
, env
, proc
))));
4197 if (!SCM_SMOB_APPLICABLE_P (proc
))
4199 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4200 scm_eval_args (x
, env
, proc
)));
4204 proc
= SCM_PROCEDURE (proc
);
4205 if (!SCM_CLOSUREP (proc
))
4208 case scm_tcs_closures
:
4210 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4211 if (SCM_NULLP (formals
)
4212 || (SCM_CONSP (formals
)
4213 && (SCM_NULLP (SCM_CDR (formals
))
4214 || (SCM_CONSP (SCM_CDR (formals
))
4215 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4216 goto umwrongnumargs
;
4217 env
= SCM_EXTEND_ENV (formals
,
4220 scm_eval_args (x
, env
, proc
)),
4222 x
= SCM_CLOSURE_BODY (proc
);
4223 goto nontoplevel_begin
;
4226 case scm_tcs_struct
:
4227 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4230 arg1
= debug
.info
->a
.args
;
4232 arg1
= scm_cons2 (arg1
, arg2
, scm_eval_args (x
, env
, proc
));
4234 x
= SCM_ENTITY_PROCEDURE (proc
);
4237 else if (SCM_I_OPERATORP (proc
))
4241 case scm_tc7_subr_2
:
4242 case scm_tc7_subr_1o
:
4243 case scm_tc7_subr_2o
:
4244 case scm_tc7_subr_0
:
4247 case scm_tc7_subr_1
:
4248 scm_wrong_num_args (proc
);
4256 if (scm_check_exit_p
&& SCM_TRAPS_P
)
4257 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
4259 SCM_CLEAR_TRACED_FRAME (debug
);
4260 if (SCM_CHEAPTRAPS_P
)
4261 arg1
= scm_make_debugobj (&debug
);
4265 SCM val
= scm_make_continuation (&first
);
4276 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
4280 scm_last_debug_frame
= debug
.prev
;
4286 /* SECTION: This code is compiled once.
4293 /* Simple procedure calls
4297 scm_call_0 (SCM proc
)
4299 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
4303 scm_call_1 (SCM proc
, SCM arg1
)
4305 return scm_apply (proc
, arg1
, scm_listofnull
);
4309 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
4311 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
4315 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
4317 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
4321 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
4323 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
4324 scm_cons (arg4
, scm_listofnull
)));
4327 /* Simple procedure applies
4331 scm_apply_0 (SCM proc
, SCM args
)
4333 return scm_apply (proc
, args
, SCM_EOL
);
4337 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
4339 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
4343 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
4345 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
4349 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
4351 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
4355 /* This code processes the arguments to apply:
4357 (apply PROC ARG1 ... ARGS)
4359 Given a list (ARG1 ... ARGS), this function conses the ARG1
4360 ... arguments onto the front of ARGS, and returns the resulting
4361 list. Note that ARGS is a list; thus, the argument to this
4362 function is a list whose last element is a list.
4364 Apply calls this function, and applies PROC to the elements of the
4365 result. apply:nconc2last takes care of building the list of
4366 arguments, given (ARG1 ... ARGS).
4368 Rather than do new consing, apply:nconc2last destroys its argument.
4369 On that topic, this code came into my care with the following
4370 beautifully cryptic comment on that topic: "This will only screw
4371 you if you do (scm_apply scm_apply '( ... ))" If you know what
4372 they're referring to, send me a patch to this comment. */
4374 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
4376 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
4377 "conses the @var{arg1} @dots{} arguments onto the front of\n"
4378 "@var{args}, and returns the resulting list. Note that\n"
4379 "@var{args} is a list; thus, the argument to this function is\n"
4380 "a list whose last element is a list.\n"
4381 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
4382 "destroys its argument, so use with care.")
4383 #define FUNC_NAME s_scm_nconc2last
4386 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
4388 while (!SCM_NULLP (SCM_CDR (*lloc
))) /* Perhaps should be
4389 SCM_NULL_OR_NIL_P, but not
4390 needed in 99.99% of cases,
4391 and it could seriously hurt
4392 performance. - Neil */
4393 lloc
= SCM_CDRLOC (*lloc
);
4394 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
4395 *lloc
= SCM_CAR (*lloc
);
4403 /* SECTION: When DEVAL is defined this code yields scm_dapply.
4404 * It is compiled twice.
4409 scm_apply (SCM proc
, SCM arg1
, SCM args
)
4415 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
4420 /* Apply a function to a list of arguments.
4422 This function is exported to the Scheme level as taking two
4423 required arguments and a tail argument, as if it were:
4424 (lambda (proc arg1 . args) ...)
4425 Thus, if you just have a list of arguments to pass to a procedure,
4426 pass the list as ARG1, and '() for ARGS. If you have some fixed
4427 args, pass the first as ARG1, then cons any remaining fixed args
4428 onto the front of your argument list, and pass that as ARGS. */
4431 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
4434 scm_t_debug_frame debug
;
4435 scm_t_debug_info debug_vect_body
;
4436 debug
.prev
= scm_last_debug_frame
;
4437 debug
.status
= SCM_APPLYFRAME
;
4438 debug
.vect
= &debug_vect_body
;
4439 debug
.vect
[0].a
.proc
= proc
;
4440 debug
.vect
[0].a
.args
= SCM_EOL
;
4441 scm_last_debug_frame
= &debug
;
4444 return scm_dapply (proc
, arg1
, args
);
4447 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
4449 /* If ARGS is the empty list, then we're calling apply with only two
4450 arguments --- ARG1 is the list of arguments for PROC. Whatever
4451 the case, futz with things so that ARG1 is the first argument to
4452 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
4455 Setting the debug apply frame args this way is pretty messy.
4456 Perhaps we should store arg1 and args directly in the frame as
4457 received, and let scm_frame_arguments unpack them, because that's
4458 a relatively rare operation. This works for now; if the Guile
4459 developer archives are still around, see Mikael's post of
4461 if (SCM_NULLP (args
))
4463 if (SCM_NULLP (arg1
))
4465 arg1
= SCM_UNDEFINED
;
4467 debug
.vect
[0].a
.args
= SCM_EOL
;
4473 debug
.vect
[0].a
.args
= arg1
;
4475 args
= SCM_CDR (arg1
);
4476 arg1
= SCM_CAR (arg1
);
4481 args
= scm_nconc2last (args
);
4483 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4487 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
4490 if (SCM_CHEAPTRAPS_P
)
4491 tmp
= scm_make_debugobj (&debug
);
4496 tmp
= scm_make_continuation (&first
);
4501 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
4508 switch (SCM_TYP7 (proc
))
4510 case scm_tc7_subr_2o
:
4511 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
4512 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4513 case scm_tc7_subr_2
:
4514 if (SCM_NULLP (args
) || !SCM_NULLP (SCM_CDR (args
)))
4515 scm_wrong_num_args (proc
);
4516 args
= SCM_CAR (args
);
4517 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4518 case scm_tc7_subr_0
:
4519 if (!SCM_UNBNDP (arg1
))
4520 scm_wrong_num_args (proc
);
4522 RETURN (SCM_SUBRF (proc
) ());
4523 case scm_tc7_subr_1
:
4524 if (SCM_UNBNDP (arg1
))
4525 scm_wrong_num_args (proc
);
4526 case scm_tc7_subr_1o
:
4527 if (!SCM_NULLP (args
))
4528 scm_wrong_num_args (proc
);
4530 RETURN (SCM_SUBRF (proc
) (arg1
));
4532 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
4533 scm_wrong_num_args (proc
);
4534 if (SCM_INUMP (arg1
))
4536 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
4538 else if (SCM_REALP (arg1
))
4540 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4542 else if (SCM_BIGP (arg1
))
4544 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4546 else if (SCM_FRACTIONP (arg1
))
4548 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4550 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4551 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4553 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
4554 scm_wrong_num_args (proc
);
4556 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
4559 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
4560 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4561 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
4566 case scm_tc7_subr_3
:
4567 if (SCM_NULLP (args
)
4568 || SCM_NULLP (SCM_CDR (args
))
4569 || !SCM_NULLP (SCM_CDDR (args
)))
4570 scm_wrong_num_args (proc
);
4572 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
4575 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
4577 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
4579 case scm_tc7_lsubr_2
:
4580 if (!SCM_CONSP (args
))
4581 scm_wrong_num_args (proc
);
4583 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4585 if (SCM_NULLP (args
))
4586 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4587 while (SCM_NIMP (args
))
4589 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
4590 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
4591 args
= SCM_CDR (args
);
4594 case scm_tc7_rpsubr
:
4595 if (SCM_NULLP (args
))
4596 RETURN (SCM_BOOL_T
);
4597 while (SCM_NIMP (args
))
4599 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
4600 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
4601 RETURN (SCM_BOOL_F
);
4602 arg1
= SCM_CAR (args
);
4603 args
= SCM_CDR (args
);
4605 RETURN (SCM_BOOL_T
);
4606 case scm_tcs_closures
:
4608 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4610 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4612 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
4613 scm_wrong_num_args (proc
);
4615 /* Copy argument list */
4620 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
4621 for (arg1
= SCM_CDR (arg1
); SCM_CONSP (arg1
); arg1
= SCM_CDR (arg1
))
4623 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
));
4626 SCM_SETCDR (tl
, arg1
);
4629 args
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4632 proc
= SCM_CLOSURE_BODY (proc
);
4634 arg1
= SCM_CDR (proc
);
4635 while (!SCM_NULLP (arg1
))
4637 if (SCM_IMP (SCM_CAR (proc
)))
4639 if (SCM_ISYMP (SCM_CAR (proc
)))
4641 scm_rec_mutex_lock (&source_mutex
);
4642 /* check for race condition */
4643 if (SCM_ISYMP (SCM_CAR (proc
)))
4644 proc
= m_expand_body (proc
, args
);
4645 scm_rec_mutex_unlock (&source_mutex
);
4649 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
4652 SCM_CEVAL (SCM_CAR (proc
), args
);
4654 arg1
= SCM_CDR (proc
);
4656 RETURN (EVALCAR (proc
, args
));
4658 if (!SCM_SMOB_APPLICABLE_P (proc
))
4660 if (SCM_UNBNDP (arg1
))
4661 RETURN (SCM_SMOB_APPLY_0 (proc
));
4662 else if (SCM_NULLP (args
))
4663 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
4664 else if (SCM_NULLP (SCM_CDR (args
)))
4665 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
4667 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4670 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4672 proc
= SCM_CCLO_SUBR (proc
);
4673 debug
.vect
[0].a
.proc
= proc
;
4674 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4676 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4678 proc
= SCM_CCLO_SUBR (proc
);
4682 proc
= SCM_PROCEDURE (proc
);
4684 debug
.vect
[0].a
.proc
= proc
;
4687 case scm_tcs_struct
:
4688 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4691 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4693 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4695 RETURN (scm_apply_generic (proc
, args
));
4697 else if (SCM_I_OPERATORP (proc
))
4701 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4703 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4706 proc
= (SCM_I_ENTITYP (proc
)
4707 ? SCM_ENTITY_PROCEDURE (proc
)
4708 : SCM_OPERATOR_PROCEDURE (proc
));
4710 debug
.vect
[0].a
.proc
= proc
;
4711 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4713 if (SCM_NIMP (proc
))
4722 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
4726 if (scm_check_exit_p
&& SCM_TRAPS_P
)
4727 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
4729 SCM_CLEAR_TRACED_FRAME (debug
);
4730 if (SCM_CHEAPTRAPS_P
)
4731 arg1
= scm_make_debugobj (&debug
);
4735 SCM val
= scm_make_continuation (&first
);
4746 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
4750 scm_last_debug_frame
= debug
.prev
;
4756 /* SECTION: The rest of this file is only read once.
4763 * Trampolines make it possible to move procedure application dispatch
4764 * outside inner loops. The motivation was clean implementation of
4765 * efficient replacements of R5RS primitives in SRFI-1.
4767 * The semantics is clear: scm_trampoline_N returns an optimized
4768 * version of scm_call_N (or NULL if the procedure isn't applicable
4771 * Applying the optimization to map and for-each increased efficiency
4772 * noticeably. For example, (map abs ls) is now 8 times faster than
4777 call_subr0_0 (SCM proc
)
4779 return SCM_SUBRF (proc
) ();
4783 call_subr1o_0 (SCM proc
)
4785 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
4789 call_lsubr_0 (SCM proc
)
4791 return SCM_SUBRF (proc
) (SCM_EOL
);
4795 scm_i_call_closure_0 (SCM proc
)
4797 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4800 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
4805 scm_trampoline_0 (SCM proc
)
4807 scm_t_trampoline_0 trampoline
;
4812 switch (SCM_TYP7 (proc
))
4814 case scm_tc7_subr_0
:
4815 trampoline
= call_subr0_0
;
4817 case scm_tc7_subr_1o
:
4818 trampoline
= call_subr1o_0
;
4821 trampoline
= call_lsubr_0
;
4823 case scm_tcs_closures
:
4825 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4826 if (SCM_NULLP (formals
) || !SCM_CONSP (formals
))
4827 trampoline
= scm_i_call_closure_0
;
4832 case scm_tcs_struct
:
4833 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4834 trampoline
= scm_call_generic_0
;
4835 else if (SCM_I_OPERATORP (proc
))
4836 trampoline
= scm_call_0
;
4841 if (SCM_SMOB_APPLICABLE_P (proc
))
4842 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
4847 case scm_tc7_rpsubr
:
4850 trampoline
= scm_call_0
;
4853 return NULL
; /* not applicable on zero arguments */
4855 /* We only reach this point if a valid trampoline was determined. */
4857 /* If debugging is enabled, we want to see all calls to proc on the stack.
4858 * Thus, we replace the trampoline shortcut with scm_call_0. */
4866 call_subr1_1 (SCM proc
, SCM arg1
)
4868 return SCM_SUBRF (proc
) (arg1
);
4872 call_subr2o_1 (SCM proc
, SCM arg1
)
4874 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
4878 call_lsubr_1 (SCM proc
, SCM arg1
)
4880 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
4884 call_dsubr_1 (SCM proc
, SCM arg1
)
4886 if (SCM_INUMP (arg1
))
4888 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
4890 else if (SCM_REALP (arg1
))
4892 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4894 else if (SCM_BIGP (arg1
))
4896 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4898 else if (SCM_FRACTIONP (arg1
))
4900 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4902 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4903 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4907 call_cxr_1 (SCM proc
, SCM arg1
)
4909 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
4912 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
4913 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4914 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
4921 call_closure_1 (SCM proc
, SCM arg1
)
4923 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4926 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
4931 scm_trampoline_1 (SCM proc
)
4933 scm_t_trampoline_1 trampoline
;
4938 switch (SCM_TYP7 (proc
))
4940 case scm_tc7_subr_1
:
4941 case scm_tc7_subr_1o
:
4942 trampoline
= call_subr1_1
;
4944 case scm_tc7_subr_2o
:
4945 trampoline
= call_subr2o_1
;
4948 trampoline
= call_lsubr_1
;
4951 trampoline
= call_dsubr_1
;
4954 trampoline
= call_cxr_1
;
4956 case scm_tcs_closures
:
4958 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4959 if (!SCM_NULLP (formals
)
4960 && (!SCM_CONSP (formals
) || !SCM_CONSP (SCM_CDR (formals
))))
4961 trampoline
= call_closure_1
;
4966 case scm_tcs_struct
:
4967 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4968 trampoline
= scm_call_generic_1
;
4969 else if (SCM_I_OPERATORP (proc
))
4970 trampoline
= scm_call_1
;
4975 if (SCM_SMOB_APPLICABLE_P (proc
))
4976 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
4981 case scm_tc7_rpsubr
:
4984 trampoline
= scm_call_1
;
4987 return NULL
; /* not applicable on one arg */
4989 /* We only reach this point if a valid trampoline was determined. */
4991 /* If debugging is enabled, we want to see all calls to proc on the stack.
4992 * Thus, we replace the trampoline shortcut with scm_call_1. */
5000 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
5002 return SCM_SUBRF (proc
) (arg1
, arg2
);
5006 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
5008 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
5012 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
5014 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
5018 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
5020 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
5021 scm_list_2 (arg1
, arg2
),
5023 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
5028 scm_trampoline_2 (SCM proc
)
5030 scm_t_trampoline_2 trampoline
;
5035 switch (SCM_TYP7 (proc
))
5037 case scm_tc7_subr_2
:
5038 case scm_tc7_subr_2o
:
5039 case scm_tc7_rpsubr
:
5041 trampoline
= call_subr2_2
;
5043 case scm_tc7_lsubr_2
:
5044 trampoline
= call_lsubr2_2
;
5047 trampoline
= call_lsubr_2
;
5049 case scm_tcs_closures
:
5051 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5052 if (!SCM_NULLP (formals
)
5053 && (!SCM_CONSP (formals
)
5054 || (!SCM_NULLP (SCM_CDR (formals
))
5055 && (!SCM_CONSP (SCM_CDR (formals
))
5056 || !SCM_CONSP (SCM_CDDR (formals
))))))
5057 trampoline
= call_closure_2
;
5062 case scm_tcs_struct
:
5063 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5064 trampoline
= scm_call_generic_2
;
5065 else if (SCM_I_OPERATORP (proc
))
5066 trampoline
= scm_call_2
;
5071 if (SCM_SMOB_APPLICABLE_P (proc
))
5072 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
5078 trampoline
= scm_call_2
;
5081 return NULL
; /* not applicable on two args */
5083 /* We only reach this point if a valid trampoline was determined. */
5085 /* If debugging is enabled, we want to see all calls to proc on the stack.
5086 * Thus, we replace the trampoline shortcut with scm_call_2. */
5093 /* Typechecking for multi-argument MAP and FOR-EACH.
5095 Verify that each element of the vector ARGV, except for the first,
5096 is a proper list whose length is LEN. Attribute errors to WHO,
5097 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
5099 check_map_args (SCM argv
,
5106 SCM
const *ve
= SCM_VELTS (argv
);
5109 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
5111 long elt_len
= scm_ilength (ve
[i
]);
5116 scm_apply_generic (gf
, scm_cons (proc
, args
));
5118 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
5122 scm_out_of_range_pos (who
, ve
[i
], SCM_MAKINUM (i
+ 2));
5125 scm_remember_upto_here_1 (argv
);
5129 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
5131 /* Note: Currently, scm_map applies PROC to the argument list(s)
5132 sequentially, starting with the first element(s). This is used in
5133 evalext.c where the Scheme procedure `map-in-order', which guarantees
5134 sequential behaviour, is implemented using scm_map. If the
5135 behaviour changes, we need to update `map-in-order'.
5139 scm_map (SCM proc
, SCM arg1
, SCM args
)
5140 #define FUNC_NAME s_map
5145 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
5147 len
= scm_ilength (arg1
);
5148 SCM_GASSERTn (len
>= 0,
5149 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
5150 SCM_VALIDATE_REST_ARGUMENT (args
);
5151 if (SCM_NULLP (args
))
5153 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5154 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
5155 while (SCM_NIMP (arg1
))
5157 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
5158 pres
= SCM_CDRLOC (*pres
);
5159 arg1
= SCM_CDR (arg1
);
5163 if (SCM_NULLP (SCM_CDR (args
)))
5165 SCM arg2
= SCM_CAR (args
);
5166 int len2
= scm_ilength (arg2
);
5167 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5169 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
5170 SCM_GASSERTn (len2
>= 0,
5171 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
5173 SCM_OUT_OF_RANGE (3, arg2
);
5174 while (SCM_NIMP (arg1
))
5176 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
5177 pres
= SCM_CDRLOC (*pres
);
5178 arg1
= SCM_CDR (arg1
);
5179 arg2
= SCM_CDR (arg2
);
5183 arg1
= scm_cons (arg1
, args
);
5184 args
= scm_vector (arg1
);
5185 ve
= SCM_VELTS (args
);
5186 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
5190 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5192 if (SCM_IMP (ve
[i
]))
5194 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
5195 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
5197 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
5198 pres
= SCM_CDRLOC (*pres
);
5204 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
5207 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
5208 #define FUNC_NAME s_for_each
5210 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
5212 len
= scm_ilength (arg1
);
5213 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
5214 SCM_ARG2
, s_for_each
);
5215 SCM_VALIDATE_REST_ARGUMENT (args
);
5216 if (SCM_NULLP (args
))
5218 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5219 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
5220 while (SCM_NIMP (arg1
))
5222 call (proc
, SCM_CAR (arg1
));
5223 arg1
= SCM_CDR (arg1
);
5225 return SCM_UNSPECIFIED
;
5227 if (SCM_NULLP (SCM_CDR (args
)))
5229 SCM arg2
= SCM_CAR (args
);
5230 int len2
= scm_ilength (arg2
);
5231 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5232 SCM_GASSERTn (call
, g_for_each
,
5233 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
5234 SCM_GASSERTn (len2
>= 0, g_for_each
,
5235 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
5237 SCM_OUT_OF_RANGE (3, arg2
);
5238 while (SCM_NIMP (arg1
))
5240 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
5241 arg1
= SCM_CDR (arg1
);
5242 arg2
= SCM_CDR (arg2
);
5244 return SCM_UNSPECIFIED
;
5246 arg1
= scm_cons (arg1
, args
);
5247 args
= scm_vector (arg1
);
5248 ve
= SCM_VELTS (args
);
5249 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
5253 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5255 if (SCM_IMP (ve
[i
]))
5256 return SCM_UNSPECIFIED
;
5257 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
5258 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
5260 scm_apply (proc
, arg1
, SCM_EOL
);
5267 scm_closure (SCM code
, SCM env
)
5270 SCM closcar
= scm_cons (code
, SCM_EOL
);
5271 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
5272 scm_remember_upto_here (closcar
);
5277 scm_t_bits scm_tc16_promise
;
5280 scm_makprom (SCM code
)
5282 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
5284 scm_make_rec_mutex ());
5288 promise_free (SCM promise
)
5290 scm_rec_mutex_free (SCM_PROMISE_MUTEX (promise
));
5295 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
5297 int writingp
= SCM_WRITINGP (pstate
);
5298 scm_puts ("#<promise ", port
);
5299 SCM_SET_WRITINGP (pstate
, 1);
5300 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
5301 SCM_SET_WRITINGP (pstate
, writingp
);
5302 scm_putc ('>', port
);
5306 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
5308 "If the promise @var{x} has not been computed yet, compute and\n"
5309 "return @var{x}, otherwise just return the previously computed\n"
5311 #define FUNC_NAME s_scm_force
5313 SCM_VALIDATE_SMOB (1, promise
, promise
);
5314 scm_rec_mutex_lock (SCM_PROMISE_MUTEX (promise
));
5315 if (!SCM_PROMISE_COMPUTED_P (promise
))
5317 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
5318 if (!SCM_PROMISE_COMPUTED_P (promise
))
5320 SCM_SET_PROMISE_DATA (promise
, ans
);
5321 SCM_SET_PROMISE_COMPUTED (promise
);
5324 scm_rec_mutex_unlock (SCM_PROMISE_MUTEX (promise
));
5325 return SCM_PROMISE_DATA (promise
);
5330 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
5332 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
5333 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
5334 #define FUNC_NAME s_scm_promise_p
5336 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
5341 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
5342 (SCM xorig
, SCM x
, SCM y
),
5343 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
5344 "Any source properties associated with @var{xorig} are also associated\n"
5345 "with the new pair.")
5346 #define FUNC_NAME s_scm_cons_source
5349 z
= scm_cons (x
, y
);
5350 /* Copy source properties possibly associated with xorig. */
5351 p
= scm_whash_lookup (scm_source_whash
, xorig
);
5353 scm_whash_insert (scm_source_whash
, z
, p
);
5359 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
5361 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
5362 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
5363 "contents of both pairs and vectors (since both cons cells and vector\n"
5364 "cells may point to arbitrary objects), and stops recursing when it hits\n"
5365 "any other object.")
5366 #define FUNC_NAME s_scm_copy_tree
5371 if (SCM_VECTORP (obj
))
5373 unsigned long i
= SCM_VECTOR_LENGTH (obj
);
5374 ans
= scm_c_make_vector (i
, SCM_UNSPECIFIED
);
5376 SCM_VECTOR_SET (ans
, i
, scm_copy_tree (SCM_VELTS (obj
)[i
]));
5379 if (!SCM_CONSP (obj
))
5381 ans
= tl
= scm_cons_source (obj
,
5382 scm_copy_tree (SCM_CAR (obj
)),
5384 for (obj
= SCM_CDR (obj
); SCM_CONSP (obj
); obj
= SCM_CDR (obj
))
5386 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
5390 SCM_SETCDR (tl
, obj
);
5396 /* We have three levels of EVAL here:
5398 - scm_i_eval (exp, env)
5400 evaluates EXP in environment ENV. ENV is a lexical environment
5401 structure as used by the actual tree code evaluator. When ENV is
5402 a top-level environment, then changes to the current module are
5403 tracked by updating ENV so that it continues to be in sync with
5406 - scm_primitive_eval (exp)
5408 evaluates EXP in the top-level environment as determined by the
5409 current module. This is done by constructing a suitable
5410 environment and calling scm_i_eval. Thus, changes to the
5411 top-level module are tracked normally.
5413 - scm_eval (exp, mod)
5415 evaluates EXP while MOD is the current module. This is done by
5416 setting the current module to MOD, invoking scm_primitive_eval on
5417 EXP, and then restoring the current module to the value it had
5418 previously. That is, while EXP is evaluated, changes to the
5419 current module are tracked, but these changes do not persist when
5422 For each level of evals, there are two variants, distinguished by a
5423 _x suffix: the ordinary variant does not modify EXP while the _x
5424 variant can destructively modify EXP into something completely
5425 unintelligible. A Scheme data structure passed as EXP to one of the
5426 _x variants should not ever be used again for anything. So when in
5427 doubt, use the ordinary variant.
5432 scm_i_eval_x (SCM exp
, SCM env
)
5434 return SCM_XEVAL (exp
, env
);
5438 scm_i_eval (SCM exp
, SCM env
)
5440 exp
= scm_copy_tree (exp
);
5441 return SCM_XEVAL (exp
, env
);
5445 scm_primitive_eval_x (SCM exp
)
5448 SCM transformer
= scm_current_module_transformer ();
5449 if (SCM_NIMP (transformer
))
5450 exp
= scm_call_1 (transformer
, exp
);
5451 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5452 return scm_i_eval_x (exp
, env
);
5455 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
5457 "Evaluate @var{exp} in the top-level environment specified by\n"
5458 "the current module.")
5459 #define FUNC_NAME s_scm_primitive_eval
5462 SCM transformer
= scm_current_module_transformer ();
5463 if (SCM_NIMP (transformer
))
5464 exp
= scm_call_1 (transformer
, exp
);
5465 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5466 return scm_i_eval (exp
, env
);
5470 /* Eval does not take the second arg optionally. This is intentional
5471 * in order to be R5RS compatible, and to prepare for the new module
5472 * system, where we would like to make the choice of evaluation
5473 * environment explicit. */
5476 change_environment (void *data
)
5478 SCM pair
= SCM_PACK (data
);
5479 SCM new_module
= SCM_CAR (pair
);
5480 SCM old_module
= scm_current_module ();
5481 SCM_SETCDR (pair
, old_module
);
5482 scm_set_current_module (new_module
);
5487 restore_environment (void *data
)
5489 SCM pair
= SCM_PACK (data
);
5490 SCM old_module
= SCM_CDR (pair
);
5491 SCM new_module
= scm_current_module ();
5492 SCM_SETCAR (pair
, new_module
);
5493 scm_set_current_module (old_module
);
5497 inner_eval_x (void *data
)
5499 return scm_primitive_eval_x (SCM_PACK(data
));
5503 scm_eval_x (SCM exp
, SCM module
)
5504 #define FUNC_NAME "eval!"
5506 SCM_VALIDATE_MODULE (2, module
);
5508 return scm_internal_dynamic_wind
5509 (change_environment
, inner_eval_x
, restore_environment
,
5510 (void *) SCM_UNPACK (exp
),
5511 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
5516 inner_eval (void *data
)
5518 return scm_primitive_eval (SCM_PACK(data
));
5521 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
5522 (SCM exp
, SCM module
),
5523 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
5524 "in the top-level environment specified by @var{module}.\n"
5525 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
5526 "@var{module} is made the current module. The current module\n"
5527 "is reset to its previous value when @var{eval} returns.")
5528 #define FUNC_NAME s_scm_eval
5530 SCM_VALIDATE_MODULE (2, module
);
5532 return scm_internal_dynamic_wind
5533 (change_environment
, inner_eval
, restore_environment
,
5534 (void *) SCM_UNPACK (exp
),
5535 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
5540 /* At this point, scm_deval and scm_dapply are generated.
5550 scm_init_opts (scm_evaluator_traps
,
5551 scm_evaluator_trap_table
,
5552 SCM_N_EVALUATOR_TRAPS
);
5553 scm_init_opts (scm_eval_options_interface
,
5555 SCM_N_EVAL_OPTIONS
);
5557 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
5558 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
5559 scm_set_smob_free (scm_tc16_promise
, promise_free
);
5560 scm_set_smob_print (scm_tc16_promise
, promise_print
);
5562 undefineds
= scm_list_1 (SCM_UNDEFINED
);
5563 SCM_SETCDR (undefineds
, undefineds
);
5564 scm_permanent_object (undefineds
);
5566 scm_listofnull
= scm_list_1 (SCM_EOL
);
5568 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
5569 scm_permanent_object (f_apply
);
5571 #include "libguile/eval.x"
5573 scm_add_feature ("delay");