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
141 static const char s_mixed_body_forms
[] = "Mixed definitions and expressions in";
142 /* Definitions are only allowed on the top level and at the start of a body.
143 * If a definition is detected anywhere else, a 'Bad define placement' error
145 static const char s_bad_define
[] = "Bad define placement";
147 /* Case or cond expressions must have at least one clause. If a case or cond
148 * expression without any clauses is detected, a 'Missing clauses' error is
150 static const char s_missing_clauses
[] = "Missing clauses";
152 /* If there is an 'else' clause in a case or a cond statement, it must be the
153 * last clause. If after the 'else' case clause further clauses are detected,
154 * a 'Misplaced else clause' error is signalled. */
155 static const char s_misplaced_else_clause
[] = "Misplaced else clause";
157 /* If a case clause is detected that is not in the format
158 * (<label(s)> <expression1> <expression2> ...)
159 * a 'Bad case clause' error is signalled. */
160 static const char s_bad_case_clause
[] = "Bad case clause";
162 /* If a case clause is detected where the <label(s)> element is neither a
163 * proper list nor (in case of the last clause) the syntactic keyword 'else',
164 * a 'Bad case labels' error is signalled. Note: If you encounter this error
165 * for an else-clause which seems to be syntactically correct, check if 'else'
166 * is really a syntactic keyword in that context. If 'else' is bound in the
167 * local or global environment, it is not considered a syntactic keyword, but
168 * will be treated as any other variable. */
169 static const char s_bad_case_labels
[] = "Bad case labels";
171 /* In a case statement all labels have to be distinct. If in a case statement
172 * a label occurs more than once, a 'Duplicate case label' error is
174 static const char s_duplicate_case_label
[] = "Duplicate case label";
176 /* If a cond clause is detected that is not in one of the formats
177 * (<test> <expression1> ...) or (else <expression1> <expression2> ...)
178 * a 'Bad cond clause' error is signalled. */
179 static const char s_bad_cond_clause
[] = "Bad cond clause";
181 /* If a cond clause is detected that uses the alternate '=>' form, but does
182 * not hold a recipient element for the test result, a 'Missing recipient'
183 * error is signalled. */
184 static const char s_missing_recipient
[] = "Missing recipient in";
186 /* If in a position where a variable name is required some other object is
187 * detected, a 'Bad variable' error is signalled. */
188 static const char s_bad_variable
[] = "Bad variable";
190 /* Bindings for forms like 'let' and 'do' have to be given in a proper,
191 * possibly empty list. If any other object is detected in a place where a
192 * list of bindings was required, a 'Bad bindings' error is signalled. */
193 static const char s_bad_bindings
[] = "Bad bindings";
195 /* Depending on the syntactic context, a binding has to be in the format
196 * (<variable> <expression>) or (<variable> <expression1> <expression2>).
197 * If anything else is detected in a place where a binding was expected, a
198 * 'Bad binding' error is signalled. */
199 static const char s_bad_binding
[] = "Bad binding";
201 /* Some syntactic forms don't allow variable names to appear more than once in
202 * a list of bindings. If such a situation is nevertheless detected, a
203 * 'Duplicate binding' error is signalled. */
204 static const char s_duplicate_binding
[] = "Duplicate binding";
206 /* If the exit form of a 'do' expression is not in the format
207 * (<test> <expression> ...)
208 * a 'Bad exit clause' error is signalled. */
209 static const char s_bad_exit_clause
[] = "Bad exit clause";
211 /* The formal function arguments of a lambda expression have to be either a
212 * single symbol or a non-cyclic list. For anything else a 'Bad formals'
213 * error is signalled. */
214 static const char s_bad_formals
[] = "Bad formals";
216 /* If in a lambda expression something else than a symbol is detected at a
217 * place where a formal function argument is required, a 'Bad formal' error is
219 static const char s_bad_formal
[] = "Bad formal";
221 /* If in the arguments list of a lambda expression an argument name occurs
222 * more than once, a 'Duplicate formal' error is signalled. */
223 static const char s_duplicate_formal
[] = "Duplicate formal";
225 /* If the evaluation of an unquote-splicing expression gives something else
226 * than a proper list, a 'Non-list result for unquote-splicing' error is
228 static const char s_splicing
[] = "Non-list result for unquote-splicing";
230 /* If something else than an exact integer is detected as the argument for
231 * @slot-ref and @slot-set!, a 'Bad slot number' error is signalled. */
232 static const char s_bad_slot_number
[] = "Bad slot number";
235 /* Signal a syntax error. We distinguish between the form that caused the
236 * error and the enclosing expression. The error message will print out as
237 * shown in the following pattern. The file name and line number are only
238 * given when they can be determined from the erroneous form or from the
239 * enclosing expression.
241 * <filename>: In procedure memoization:
242 * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
244 SCM_SYMBOL (syntax_error_key
, "syntax-error");
246 /* The prototype is needed to indicate that the function does not return. */
248 syntax_error (const char* const, const SCM
, const SCM
) SCM_NORETURN
;
251 syntax_error (const char* const msg
, const SCM form
, const SCM expr
)
253 const SCM msg_string
= scm_makfrom0str (msg
);
254 SCM filename
= SCM_BOOL_F
;
255 SCM linenr
= SCM_BOOL_F
;
259 if (SCM_CONSP (form
))
261 filename
= scm_source_property (form
, scm_sym_filename
);
262 linenr
= scm_source_property (form
, scm_sym_line
);
265 if (SCM_FALSEP (filename
) && SCM_FALSEP (linenr
) && SCM_CONSP (expr
))
267 filename
= scm_source_property (expr
, scm_sym_filename
);
268 linenr
= scm_source_property (expr
, scm_sym_line
);
271 if (!SCM_UNBNDP (expr
))
273 if (!SCM_FALSEP (filename
))
275 format
= "In file ~S, line ~S: ~A ~S in expression ~S.";
276 args
= scm_list_5 (filename
, linenr
, msg_string
, form
, expr
);
278 else if (!SCM_FALSEP (linenr
))
280 format
= "In line ~S: ~A ~S in expression ~S.";
281 args
= scm_list_4 (linenr
, msg_string
, form
, expr
);
285 format
= "~A ~S in expression ~S.";
286 args
= scm_list_3 (msg_string
, form
, expr
);
291 if (!SCM_FALSEP (filename
))
293 format
= "In file ~S, line ~S: ~A ~S.";
294 args
= scm_list_4 (filename
, linenr
, msg_string
, form
);
296 else if (!SCM_FALSEP (linenr
))
298 format
= "In line ~S: ~A ~S.";
299 args
= scm_list_3 (linenr
, msg_string
, form
);
304 args
= scm_list_2 (msg_string
, form
);
308 scm_error (syntax_error_key
, "memoization", format
, args
, SCM_BOOL_F
);
312 /* Shortcut macros to simplify syntax error handling. */
313 #define ASSERT_SYNTAX(cond, message, form) \
314 { if (!(cond)) syntax_error (message, form, SCM_UNDEFINED); }
315 #define ASSERT_SYNTAX_2(cond, message, form, expr) \
316 { if (!(cond)) syntax_error (message, form, expr); }
322 * Ilocs are memoized references to variables in local environment frames.
323 * They are represented as three values: The relative offset of the
324 * environment frame, the number of the binding within that frame, and a
325 * boolean value indicating whether the binding is the last binding in the
328 #define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc)
329 #define SCM_IDINC (0x00100000L)
330 #define SCM_IDSTMSK (-SCM_IDINC)
331 #define SCM_MAKE_ILOC(frame_nr, binding_nr, last_p) \
334 + ((binding_nr) << 20) \
335 + ((last_p) ? SCM_ICDR : 0) \
338 #if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
340 SCM
scm_dbg_make_iloc (SCM frame
, SCM binding
, SCM cdrp
);
341 SCM_DEFINE (scm_dbg_make_iloc
, "dbg-make-iloc", 3, 0, 0,
342 (SCM frame
, SCM binding
, SCM cdrp
),
343 "Return a new iloc with frame offset @var{frame}, binding\n"
344 "offset @var{binding} and the cdr flag @var{cdrp}.")
345 #define FUNC_NAME s_scm_dbg_make_iloc
347 SCM_VALIDATE_INUM (1, frame
);
348 SCM_VALIDATE_INUM (2, binding
);
349 return SCM_MAKE_ILOC (SCM_INUM (frame
),
355 SCM
scm_dbg_iloc_p (SCM obj
);
356 SCM_DEFINE (scm_dbg_iloc_p
, "dbg-iloc?", 1, 0, 0,
358 "Return @code{#t} if @var{obj} is an iloc.")
359 #define FUNC_NAME s_scm_dbg_iloc_p
361 return SCM_BOOL (SCM_ILOCP (obj
));
369 /* The function lookup_symbol is used during memoization: Lookup the symbol
370 * in the environment. If there is no binding for the symbol, SCM_UNDEFINED
371 * is returned. If the symbol is a syntactic keyword, the macro object to
372 * which the symbol is bound is returned. If the symbol is a global variable,
373 * the variable object to which the symbol is bound is returned. Finally, if
374 * the symbol is a local variable the corresponding iloc object is returned.
377 /* A helper function for lookup_symbol: Try to find the symbol in the top
378 * level environment frame. The function returns SCM_UNDEFINED if the symbol
379 * is unbound, it returns a macro object if the symbol is a syntactic keyword
380 * and it returns a variable object if the symbol is a global variable. */
382 lookup_global_symbol (const SCM symbol
, const SCM top_level
)
384 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
385 if (SCM_FALSEP (variable
))
387 return SCM_UNDEFINED
;
391 const SCM value
= SCM_VARIABLE_REF (variable
);
392 if (SCM_MACROP (value
))
400 lookup_symbol (const SCM symbol
, const SCM env
)
403 unsigned int frame_nr
;
405 for (frame_idx
= env
, frame_nr
= 0;
406 !SCM_NULLP (frame_idx
);
407 frame_idx
= SCM_CDR (frame_idx
), ++frame_nr
)
409 const SCM frame
= SCM_CAR (frame_idx
);
410 if (SCM_CONSP (frame
))
412 /* frame holds a local environment frame */
414 unsigned int symbol_nr
;
416 for (symbol_idx
= SCM_CAR (frame
), symbol_nr
= 0;
417 SCM_CONSP (symbol_idx
);
418 symbol_idx
= SCM_CDR (symbol_idx
), ++symbol_nr
)
420 if (SCM_EQ_P (SCM_CAR (symbol_idx
), symbol
))
421 /* found the symbol, therefore return the iloc */
422 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 0);
424 if (SCM_EQ_P (symbol_idx
, symbol
))
425 /* found the symbol as the last element of the current frame */
426 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 1);
430 /* no more local environment frames */
431 return lookup_global_symbol (symbol
, frame
);
435 return lookup_global_symbol (symbol
, SCM_BOOL_F
);
439 /* Return true if the symbol is - from the point of view of a macro
440 * transformer - a literal in the sense specified in chapter "pattern
441 * language" of R5RS. In the code below, however, we don't match the
442 * definition of R5RS exactly: It returns true if the identifier has no
443 * binding or if it is a syntactic keyword. */
445 literal_p (const SCM symbol
, const SCM env
)
447 const SCM value
= lookup_symbol (symbol
, env
);
448 if (SCM_UNBNDP (value
) || SCM_MACROP (value
))
456 /* The evaluator contains a plethora of EVAL symbols.
457 * This is an attempt at explanation.
459 * The following macros should be used in code which is read twice
460 * (where the choice of evaluator is hard soldered):
462 * SCM_CEVAL is the symbol used within one evaluator to call itself.
463 * Originally, it is defined to scm_ceval, but is redefined to
464 * scm_deval during the second pass.
466 * SCM_EVALIM is used when it is known that the expression is an
467 * immediate. (This macro never calls an evaluator.)
469 * EVALCAR evaluates the car of an expression.
471 * The following macros should be used in code which is read once
472 * (where the choice of evaluator is dynamic):
474 * SCM_XEVAL takes care of immediates without calling an evaluator. It
475 * then calls scm_ceval *or* scm_deval, depending on the debugging
478 * SCM_XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
479 * depending on the debugging mode.
481 * The main motivation for keeping this plethora is efficiency
482 * together with maintainability (=> locality of code).
485 #define SCM_CEVAL scm_ceval
487 #define SCM_EVALIM2(x) \
488 ((SCM_EQ_P ((x), SCM_EOL) \
489 ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \
493 #define SCM_EVALIM(x, env) (SCM_ILOCP (x) \
494 ? *scm_ilookup ((x), env) \
497 #define SCM_XEVAL(x, env) (SCM_IMP (x) \
499 : (*scm_ceval_ptr) ((x), (env)))
501 #define SCM_XEVALCAR(x, env) (SCM_IMP (SCM_CAR (x)) \
502 ? SCM_EVALIM (SCM_CAR (x), env) \
503 : (SCM_SYMBOLP (SCM_CAR (x)) \
504 ? *scm_lookupcar (x, env, 1) \
505 : (*scm_ceval_ptr) (SCM_CAR (x), env)))
507 #define EVALCAR(x, env) (SCM_IMP (SCM_CAR (x)) \
508 ? SCM_EVALIM (SCM_CAR (x), env) \
509 : (SCM_SYMBOLP (SCM_CAR (x)) \
510 ? *scm_lookupcar (x, env, 1) \
511 : SCM_CEVAL (SCM_CAR (x), env)))
513 SCM_REC_MUTEX (source_mutex
);
516 /* Lookup a given local variable in an environment. The local variable is
517 * given as an iloc, that is a triple <frame, binding, last?>, where frame
518 * indicates the relative number of the environment frame (counting upwards
519 * from the innermost environment frame), binding indicates the number of the
520 * binding within the frame, and last? (which is extracted from the iloc using
521 * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
522 * very end of the improper list of bindings. */
524 scm_ilookup (SCM iloc
, SCM env
)
526 unsigned int frame_nr
= SCM_IFRAME (iloc
);
527 unsigned int binding_nr
= SCM_IDIST (iloc
);
531 for (; 0 != frame_nr
; --frame_nr
)
532 frames
= SCM_CDR (frames
);
534 bindings
= SCM_CAR (frames
);
535 for (; 0 != binding_nr
; --binding_nr
)
536 bindings
= SCM_CDR (bindings
);
538 if (SCM_ICDRP (iloc
))
539 return SCM_CDRLOC (bindings
);
540 return SCM_CARLOC (SCM_CDR (bindings
));
544 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
546 static void error_unbound_variable (SCM symbol
) SCM_NORETURN
;
548 error_unbound_variable (SCM symbol
)
550 scm_error (scm_unbound_variable_key
, NULL
,
551 "Unbound variable: ~S",
552 scm_list_1 (symbol
), SCM_BOOL_F
);
556 /* The Lookup Car Race
559 Memoization of variables and special forms is done while executing
560 the code for the first time. As long as there is only one thread
561 everything is fine, but as soon as two threads execute the same
562 code concurrently `for the first time' they can come into conflict.
564 This memoization includes rewriting variable references into more
565 efficient forms and expanding macros. Furthermore, macro expansion
566 includes `compiling' special forms like `let', `cond', etc. into
567 tree-code instructions.
569 There shouldn't normally be a problem with memoizing local and
570 global variable references (into ilocs and variables), because all
571 threads will mutate the code in *exactly* the same way and (if I
572 read the C code correctly) it is not possible to observe a half-way
573 mutated cons cell. The lookup procedure can handle this
574 transparently without any critical sections.
576 It is different with macro expansion, because macro expansion
577 happens outside of the lookup procedure and can't be
578 undone. Therefore the lookup procedure can't cope with it. It has
579 to indicate failure when it detects a lost race and hope that the
580 caller can handle it. Luckily, it turns out that this is the case.
582 An example to illustrate this: Suppose that the following form will
583 be memoized concurrently by two threads
587 Let's first examine the lookup of X in the body. The first thread
588 decides that it has to find the symbol "x" in the environment and
589 starts to scan it. Then the other thread takes over and actually
590 overtakes the first. It looks up "x" and substitutes an
591 appropriate iloc for it. Now the first thread continues and
592 completes its lookup. It comes to exactly the same conclusions as
593 the second one and could - without much ado - just overwrite the
594 iloc with the same iloc.
596 But let's see what will happen when the race occurs while looking
597 up the symbol "let" at the start of the form. It could happen that
598 the second thread interrupts the lookup of the first thread and not
599 only substitutes a variable for it but goes right ahead and
600 replaces it with the compiled form (#@let* (x 12) x). Now, when
601 the first thread completes its lookup, it would replace the #@let*
602 with a variable containing the "let" binding, effectively reverting
603 the form to (let (x 12) x). This is wrong. It has to detect that
604 it has lost the race and the evaluator has to reconsider the
605 changed form completely.
607 This race condition could be resolved with some kind of traffic
608 light (like mutexes) around scm_lookupcar, but I think that it is
609 best to avoid them in this case. They would serialize memoization
610 completely and because lookup involves calling arbitrary Scheme
611 code (via the lookup-thunk), threads could be blocked for an
612 arbitrary amount of time or even deadlock. But with the current
613 solution a lot of unnecessary work is potentially done. */
615 /* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
616 return NULL to indicate a failed lookup due to some race conditions
617 between threads. This only happens when VLOC is the first cell of
618 a special form that will eventually be memoized (like `let', etc.)
619 In that case the whole lookup is bogus and the caller has to
620 reconsider the complete special form.
622 SCM_LOOKUPCAR is still there, of course. It just calls
623 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
624 should only be called when it is known that VLOC is not the first
625 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
626 for NULL. I think I've found the only places where this
630 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
633 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
634 register SCM iloc
= SCM_ILOC00
;
635 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
637 if (!SCM_CONSP (SCM_CAR (env
)))
639 al
= SCM_CARLOC (env
);
640 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
644 if (SCM_EQ_P (fl
, var
))
646 if (! SCM_EQ_P (SCM_CAR (vloc
), var
))
648 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
649 return SCM_CDRLOC (*al
);
654 al
= SCM_CDRLOC (*al
);
655 if (SCM_EQ_P (SCM_CAR (fl
), var
))
657 if (SCM_UNBNDP (SCM_CAR (*al
)))
662 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
664 SCM_SETCAR (vloc
, iloc
);
665 return SCM_CARLOC (*al
);
667 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
669 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
672 SCM top_thunk
, real_var
;
675 top_thunk
= SCM_CAR (env
); /* env now refers to a
676 top level env thunk */
680 top_thunk
= SCM_BOOL_F
;
681 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
682 if (SCM_FALSEP (real_var
))
685 if (!SCM_NULLP (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
691 error_unbound_variable (var
);
693 scm_misc_error (NULL
, "Damaged environment: ~S",
698 /* A variable could not be found, but we shall
699 not throw an error. */
700 static SCM undef_object
= SCM_UNDEFINED
;
701 return &undef_object
;
705 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
707 /* Some other thread has changed the very cell we are working
708 on. In effect, it must have done our job or messed it up
711 var
= SCM_CAR (vloc
);
712 if (SCM_VARIABLEP (var
))
713 return SCM_VARIABLE_LOC (var
);
714 if (SCM_ITAG7 (var
) == SCM_ITAG7 (SCM_ILOC00
))
715 return scm_ilookup (var
, genv
);
716 /* We can't cope with anything else than variables and ilocs. When
717 a special form has been memoized (i.e. `let' into `#@let') we
718 return NULL and expect the calling function to do the right
719 thing. For the evaluator, this means going back and redoing
720 the dispatch on the car of the form. */
724 SCM_SETCAR (vloc
, real_var
);
725 return SCM_VARIABLE_LOC (real_var
);
730 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
732 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
740 scm_eval_car (SCM pair
, SCM env
)
742 return SCM_XEVALCAR (pair
, env
);
747 /* Rewrite the body (which is given as the list of expressions forming the
748 * body) into its internal form. The internal form of a body (<expr> ...) is
749 * just the body itself, but prefixed with an ISYM that denotes to what kind
750 * of outer construct this body belongs: (<ISYM> <expr> ...). A lambda body
751 * starts with SCM_IM_LAMBDA, for example, a body of a let starts with
754 * It is assumed that the calling expression has already made sure that the
755 * body is a proper list. */
757 m_body (SCM op
, SCM exprs
)
759 /* Don't add another ISYM if one is present already. */
760 if (SCM_ISYMP (SCM_CAR (exprs
)))
763 return scm_cons (op
, exprs
);
767 /* The function m_expand_body memoizes a proper list of expressions
768 * forming a body. This function takes care of dealing with internal
769 * defines and transforming them into an equivalent letrec expression.
770 * The list of expressions is rewritten in place. */
772 /* This is a helper function for m_expand_body. It helps to figure out whether
773 * an expression denotes a syntactic keyword. */
775 try_macro_lookup (const SCM expr
, const SCM env
)
777 if (SCM_SYMBOLP (expr
))
779 const SCM value
= lookup_symbol (expr
, env
);
784 return SCM_UNDEFINED
;
788 /* This is a helper function for m_expand_body. It expands user macros,
789 * because for the correct translation of a body we need to know whether they
790 * expand to a definition. */
792 expand_user_macros (SCM expr
, const SCM env
)
794 while (SCM_CONSP (expr
))
796 const SCM car_expr
= SCM_CAR (expr
);
797 const SCM new_car
= expand_user_macros (car_expr
, env
);
798 const SCM value
= try_macro_lookup (new_car
, env
);
800 if (SCM_MACROP (value
) && SCM_MACRO_TYPE (value
) == 2)
802 /* User macros transform code into code. */
803 expr
= scm_call_2 (SCM_MACRO_CODE (value
), expr
, env
);
804 /* We need to reiterate on the transformed code. */
808 /* No user macro: return. */
809 SCM_SETCAR (expr
, new_car
);
817 /* This is a helper function for m_expand_body. It determines if a given form
818 * represents an application of a given built-in macro. The built-in macro to
819 * check for is identified by its syntactic keyword. The form is an
820 * application of the given macro if looking up the car of the form in the
821 * given environment actually returns the built-in macro. */
823 is_system_macro_p (const SCM syntactic_keyword
, const SCM form
, const SCM env
)
825 if (SCM_CONSP (form
))
827 const SCM car_form
= SCM_CAR (form
);
828 const SCM value
= try_macro_lookup (car_form
, env
);
829 if (SCM_BUILTIN_MACRO_P (value
))
831 const SCM macro_name
= scm_macro_name (value
);
832 return SCM_EQ_P (macro_name
, syntactic_keyword
);
840 m_expand_body (const SCM forms
, const SCM env
)
842 /* The first body form can be skipped since it is known to be the ISYM that
843 * was prepended to the body by m_body. */
844 SCM cdr_forms
= SCM_CDR (forms
);
845 SCM form_idx
= cdr_forms
;
846 SCM definitions
= SCM_EOL
;
847 SCM sequence
= SCM_EOL
;
849 /* According to R5RS, the list of body forms consists of two parts: a number
850 * (maybe zero) of definitions, followed by a non-empty sequence of
851 * expressions. Each the definitions and the expressions may be grouped
852 * arbitrarily with begin, but it is not allowed to mix definitions and
853 * expressions. The task of the following loop therefore is to split the
854 * list of body forms into the list of definitions and the sequence of
856 while (!SCM_NULLP (form_idx
))
858 const SCM form
= SCM_CAR (form_idx
);
859 const SCM new_form
= expand_user_macros (form
, env
);
860 if (is_system_macro_p (scm_sym_define
, new_form
, env
))
862 definitions
= scm_cons (new_form
, definitions
);
863 form_idx
= SCM_CDR (form_idx
);
865 else if (is_system_macro_p (scm_sym_begin
, new_form
, env
))
867 /* We have encountered a group of forms. This has to be either a
868 * (possibly empty) group of (possibly further grouped) definitions,
869 * or a non-empty group of (possibly further grouped)
871 const SCM grouped_forms
= SCM_CDR (new_form
);
872 unsigned int found_definition
= 0;
873 unsigned int found_expression
= 0;
874 SCM grouped_form_idx
= grouped_forms
;
875 while (!found_expression
&& !SCM_NULLP (grouped_form_idx
))
877 const SCM inner_form
= SCM_CAR (grouped_form_idx
);
878 const SCM new_inner_form
= expand_user_macros (inner_form
, env
);
879 if (is_system_macro_p (scm_sym_define
, new_inner_form
, env
))
881 found_definition
= 1;
882 definitions
= scm_cons (new_inner_form
, definitions
);
883 grouped_form_idx
= SCM_CDR (grouped_form_idx
);
885 else if (is_system_macro_p (scm_sym_begin
, new_inner_form
, env
))
887 const SCM inner_group
= SCM_CDR (new_inner_form
);
889 = scm_append (scm_list_2 (inner_group
,
890 SCM_CDR (grouped_form_idx
)));
894 /* The group marks the start of the expressions of the body.
895 * We have to make sure that within the same group we have
896 * not encountered a definition before. */
897 ASSERT_SYNTAX (!found_definition
, s_mixed_body_forms
, form
);
898 found_expression
= 1;
899 grouped_form_idx
= SCM_EOL
;
903 /* We have finished processing the group. If we have not yet
904 * encountered an expression we continue processing the forms of the
905 * body to collect further definition forms. Otherwise, the group
906 * marks the start of the sequence of expressions of the body. */
907 if (!found_expression
)
909 form_idx
= SCM_CDR (form_idx
);
919 /* We have detected a form which is no definition. This marks the
920 * start of the sequence of expressions of the body. */
926 /* FIXME: forms does not hold information about the file location. */
927 ASSERT_SYNTAX (SCM_CONSP (sequence
), s_missing_body_expression
, cdr_forms
);
929 if (!SCM_NULLP (definitions
))
933 SCM letrec_expression
;
934 SCM new_letrec_expression
;
936 SCM bindings
= SCM_EOL
;
937 for (definition_idx
= definitions
;
938 !SCM_NULLP (definition_idx
);
939 definition_idx
= SCM_CDR (definition_idx
))
941 const SCM definition
= SCM_CAR (definition_idx
);
942 const SCM canonical_definition
= canonicalize_define (definition
);
943 const SCM binding
= SCM_CDR (canonical_definition
);
944 bindings
= scm_cons (binding
, bindings
);
947 letrec_tail
= scm_cons (bindings
, sequence
);
948 /* FIXME: forms does not hold information about the file location. */
949 letrec_expression
= scm_cons_source (forms
, scm_sym_letrec
, letrec_tail
);
950 new_letrec_expression
= scm_m_letrec (letrec_expression
, env
);
951 SCM_SETCAR (forms
, new_letrec_expression
);
952 SCM_SETCDR (forms
, SCM_EOL
);
956 SCM_SETCAR (forms
, SCM_CAR (sequence
));
957 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 m_expand_body (exprs
, env
);
976 /* Start of the memoizers for the standard R5RS builtin macros. */
979 SCM_SYNTAX (s_and
, "and", scm_i_makbimacro
, scm_m_and
);
980 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
983 scm_m_and (SCM expr
, SCM env SCM_UNUSED
)
985 const SCM cdr_expr
= SCM_CDR (expr
);
986 const long length
= scm_ilength (cdr_expr
);
988 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
992 /* Special case: (and) is replaced by #t. */
997 SCM_SETCAR (expr
, SCM_IM_AND
);
1003 SCM_SYNTAX (s_begin
, "begin", scm_i_makbimacro
, scm_m_begin
);
1004 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
1007 scm_m_begin (SCM expr
, SCM env SCM_UNUSED
)
1009 const SCM cdr_expr
= SCM_CDR (expr
);
1010 /* Dirk:FIXME:: An empty begin clause is not generally allowed by R5RS.
1011 * That means, there should be a distinction between uses of begin where an
1012 * empty clause is OK and where it is not. */
1013 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1015 SCM_SETCAR (expr
, SCM_IM_BEGIN
);
1020 SCM_SYNTAX (s_case
, "case", scm_i_makbimacro
, scm_m_case
);
1021 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
1022 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
1025 scm_m_case (SCM expr
, SCM env
)
1028 SCM all_labels
= SCM_EOL
;
1030 /* Check, whether 'else is a literal, i. e. not bound to a value. */
1031 const int else_literal_p
= literal_p (scm_sym_else
, env
);
1033 const SCM cdr_expr
= SCM_CDR (expr
);
1034 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1035 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_clauses
, expr
);
1037 clauses
= SCM_CDR (cdr_expr
);
1038 while (!SCM_NULLP (clauses
))
1042 const SCM clause
= SCM_CAR (clauses
);
1043 ASSERT_SYNTAX_2 (scm_ilength (clause
) >= 2,
1044 s_bad_case_clause
, clause
, expr
);
1046 labels
= SCM_CAR (clause
);
1047 if (SCM_CONSP (labels
))
1049 ASSERT_SYNTAX_2 (scm_ilength (labels
) >= 0,
1050 s_bad_case_labels
, labels
, expr
);
1051 all_labels
= scm_append_x (scm_list_2 (labels
, all_labels
));
1053 else if (SCM_NULLP (labels
))
1055 /* The list of labels is empty. According to R5RS this is allowed.
1056 * It means that the sequence of expressions will never be executed.
1057 * Therefore, as an optimization, we could remove the whole
1062 ASSERT_SYNTAX_2 (SCM_EQ_P (labels
, scm_sym_else
) && else_literal_p
,
1063 s_bad_case_labels
, labels
, expr
);
1064 ASSERT_SYNTAX_2 (SCM_NULLP (SCM_CDR (clauses
)),
1065 s_misplaced_else_clause
, clause
, expr
);
1068 /* build the new clause */
1069 if (SCM_EQ_P (labels
, scm_sym_else
))
1070 SCM_SETCAR (clause
, SCM_IM_ELSE
);
1072 clauses
= SCM_CDR (clauses
);
1075 /* Check whether all case labels are distinct. */
1076 for (; !SCM_NULLP (all_labels
); all_labels
= SCM_CDR (all_labels
))
1078 const SCM label
= SCM_CAR (all_labels
);
1079 ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (label
, SCM_CDR (all_labels
))),
1080 s_duplicate_case_label
, label
, expr
);
1083 SCM_SETCAR (expr
, SCM_IM_CASE
);
1088 SCM_SYNTAX (s_cond
, "cond", scm_i_makbimacro
, scm_m_cond
);
1089 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
1090 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
1093 scm_m_cond (SCM expr
, SCM env
)
1095 /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
1096 const int else_literal_p
= literal_p (scm_sym_else
, env
);
1097 const int arrow_literal_p
= literal_p (scm_sym_arrow
, env
);
1099 const SCM clauses
= SCM_CDR (expr
);
1102 ASSERT_SYNTAX (scm_ilength (clauses
) >= 0, s_bad_expression
, expr
);
1103 ASSERT_SYNTAX (scm_ilength (clauses
) >= 1, s_missing_clauses
, expr
);
1105 for (clause_idx
= clauses
;
1106 !SCM_NULLP (clause_idx
);
1107 clause_idx
= SCM_CDR (clause_idx
))
1111 const SCM clause
= SCM_CAR (clause_idx
);
1112 const long length
= scm_ilength (clause
);
1113 ASSERT_SYNTAX_2 (length
>= 1, s_bad_cond_clause
, clause
, expr
);
1115 test
= SCM_CAR (clause
);
1116 if (SCM_EQ_P (test
, scm_sym_else
) && else_literal_p
)
1118 const int last_clause_p
= SCM_NULLP (SCM_CDR (clause_idx
));
1119 ASSERT_SYNTAX_2 (length
>= 2,
1120 s_bad_cond_clause
, clause
, expr
);
1121 ASSERT_SYNTAX_2 (last_clause_p
,
1122 s_misplaced_else_clause
, clause
, expr
);
1123 SCM_SETCAR (clause
, SCM_IM_ELSE
);
1125 else if (length
>= 2
1126 && SCM_EQ_P (SCM_CADR (clause
), scm_sym_arrow
)
1129 ASSERT_SYNTAX_2 (length
> 2, s_missing_recipient
, clause
, expr
);
1130 ASSERT_SYNTAX_2 (length
== 3, s_extra_expression
, clause
, expr
);
1131 SCM_SETCAR (SCM_CDR (clause
), SCM_IM_ARROW
);
1135 SCM_SETCAR (expr
, SCM_IM_COND
);
1140 SCM_SYNTAX (s_define
, "define", scm_i_makbimacro
, scm_m_define
);
1141 SCM_GLOBAL_SYMBOL (scm_sym_define
, s_define
);
1143 /* Guile provides an extension to R5RS' define syntax to represent function
1144 * currying in a compact way. With this extension, it is allowed to write
1145 * (define <nested-variable> <body>), where <nested-variable> has of one of
1146 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
1147 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
1148 * should be either a sequence of zero or more variables, or a sequence of one
1149 * or more variables followed by a space-delimited period and another
1150 * variable. Each level of argument nesting wraps the <body> within another
1151 * lambda expression. For example, the following forms are allowed, each one
1152 * followed by an equivalent, more explicit implementation.
1154 * (define ((a b . c) . d) <body>) is equivalent to
1155 * (define a (lambda (b . c) (lambda d <body>)))
1157 * (define (((a) b) c . d) <body>) is equivalent to
1158 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
1160 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
1161 * module that does not implement this extension. */
1163 canonicalize_define (const SCM expr
)
1168 const SCM cdr_expr
= SCM_CDR (expr
);
1169 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1170 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1172 body
= SCM_CDR (cdr_expr
);
1173 variable
= SCM_CAR (cdr_expr
);
1174 while (SCM_CONSP (variable
))
1176 /* This while loop realizes function currying by variable nesting.
1177 * Variable is known to be a nested-variable. In every iteration of the
1178 * loop another level of lambda expression is created, starting with the
1179 * innermost one. Note that we don't check for duplicate formals here:
1180 * This will be done by the memoizer of the lambda expression. */
1181 const SCM formals
= SCM_CDR (variable
);
1182 const SCM tail
= scm_cons (formals
, body
);
1184 /* Add source properties to each new lambda expression: */
1185 const SCM lambda
= scm_cons_source (variable
, scm_sym_lambda
, tail
);
1187 body
= scm_list_1 (lambda
);
1188 variable
= SCM_CAR (variable
);
1190 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
), s_bad_variable
, variable
, expr
);
1191 ASSERT_SYNTAX (scm_ilength (body
) == 1, s_expression
, expr
);
1193 SCM_SETCAR (cdr_expr
, variable
);
1194 SCM_SETCDR (cdr_expr
, body
);
1199 scm_m_define (SCM expr
, SCM env
)
1201 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), s_bad_define
, expr
);
1204 const SCM canonical_definition
= canonicalize_define (expr
);
1205 const SCM cdr_canonical_definition
= SCM_CDR (canonical_definition
);
1206 const SCM variable
= SCM_CAR (cdr_canonical_definition
);
1207 const SCM body
= SCM_CDR (cdr_canonical_definition
);
1208 const SCM value
= scm_eval_car (body
, env
);
1211 if (SCM_REC_PROCNAMES_P
)
1214 while (SCM_MACROP (tmp
))
1215 tmp
= SCM_MACRO_CODE (tmp
);
1216 if (SCM_CLOSUREP (tmp
)
1217 /* Only the first definition determines the name. */
1218 && SCM_FALSEP (scm_procedure_property (tmp
, scm_sym_name
)))
1219 scm_set_procedure_property_x (tmp
, scm_sym_name
, variable
);
1222 var
= scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_T
);
1223 SCM_VARIABLE_SET (var
, value
);
1225 return SCM_UNSPECIFIED
;
1230 /* This is a helper function for forms (<keyword> <expression>) that are
1231 * transformed into (#@<keyword> '() <memoized_expression>) in order to allow
1232 * for easy creation of a thunk (i. e. a closure without arguments) using the
1233 * ('() <memoized_expression>) tail of the memoized form. */
1235 memoize_as_thunk_prototype (const SCM expr
, const SCM env SCM_UNUSED
)
1237 const SCM cdr_expr
= SCM_CDR (expr
);
1238 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1239 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1241 SCM_SETCDR (expr
, scm_cons (SCM_EOL
, cdr_expr
));
1247 SCM_SYNTAX (s_delay
, "delay", scm_i_makbimacro
, scm_m_delay
);
1248 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
1250 /* Promises are implemented as closures with an empty parameter list. Thus,
1251 * (delay <expression>) is transformed into (#@delay '() <expression>), where
1252 * the empty list represents the empty parameter list. This representation
1253 * allows for easy creation of the closure during evaluation. */
1255 scm_m_delay (SCM expr
, SCM env
)
1257 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1258 SCM_SETCAR (new_expr
, SCM_IM_DELAY
);
1263 SCM_SYNTAX(s_do
, "do", scm_i_makbimacro
, scm_m_do
);
1264 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
1266 /* DO gets the most radically altered syntax. The order of the vars is
1267 * reversed here. During the evaluation this allows for simple consing of the
1268 * results of the inits and steps:
1270 (do ((<var1> <init1> <step1>)
1278 (#@do (<init1> <init2> ... <initn>)
1279 (varn ... var2 var1)
1282 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
1285 scm_m_do (SCM expr
, SCM env SCM_UNUSED
)
1287 SCM variables
= SCM_EOL
;
1288 SCM init_forms
= SCM_EOL
;
1289 SCM step_forms
= SCM_EOL
;
1296 const SCM cdr_expr
= SCM_CDR (expr
);
1297 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1298 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1300 /* Collect variables, init and step forms. */
1301 binding_idx
= SCM_CAR (cdr_expr
);
1302 ASSERT_SYNTAX_2 (scm_ilength (binding_idx
) >= 0,
1303 s_bad_bindings
, binding_idx
, expr
);
1304 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1306 const SCM binding
= SCM_CAR (binding_idx
);
1307 const long length
= scm_ilength (binding
);
1308 ASSERT_SYNTAX_2 (length
== 2 || length
== 3,
1309 s_bad_binding
, binding
, expr
);
1312 const SCM name
= SCM_CAR (binding
);
1313 const SCM init
= SCM_CADR (binding
);
1314 const SCM step
= (length
== 2) ? name
: SCM_CADDR (binding
);
1315 ASSERT_SYNTAX_2 (SCM_SYMBOLP (name
), s_bad_variable
, name
, expr
);
1316 ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (name
, variables
)),
1317 s_duplicate_binding
, name
, expr
);
1319 variables
= scm_cons (name
, variables
);
1320 init_forms
= scm_cons (init
, init_forms
);
1321 step_forms
= scm_cons (step
, step_forms
);
1324 init_forms
= scm_reverse_x (init_forms
, SCM_UNDEFINED
);
1325 step_forms
= scm_reverse_x (step_forms
, SCM_UNDEFINED
);
1327 /* Memoize the test form and the exit sequence. */
1328 cddr_expr
= SCM_CDR (cdr_expr
);
1329 exit_clause
= SCM_CAR (cddr_expr
);
1330 ASSERT_SYNTAX_2 (scm_ilength (exit_clause
) >= 1,
1331 s_bad_exit_clause
, exit_clause
, expr
);
1333 commands
= SCM_CDR (cddr_expr
);
1334 tail
= scm_cons2 (exit_clause
, commands
, step_forms
);
1335 tail
= scm_cons2 (init_forms
, variables
, tail
);
1336 SCM_SETCAR (expr
, SCM_IM_DO
);
1337 SCM_SETCDR (expr
, tail
);
1342 SCM_SYNTAX (s_if
, "if", scm_i_makbimacro
, scm_m_if
);
1343 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
1346 scm_m_if (SCM expr
, SCM env SCM_UNUSED
)
1348 const SCM cdr_expr
= SCM_CDR (expr
);
1349 const long length
= scm_ilength (cdr_expr
);
1350 ASSERT_SYNTAX (length
== 2 || length
== 3, s_expression
, expr
);
1351 SCM_SETCAR (expr
, SCM_IM_IF
);
1356 SCM_SYNTAX (s_lambda
, "lambda", scm_i_makbimacro
, scm_m_lambda
);
1357 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
1359 /* A helper function for memoize_lambda to support checking for duplicate
1360 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
1361 * LIST or to the cdr of the last cons. Therefore, LIST may have any of the
1362 * forms that a formal argument can have:
1363 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
1365 c_improper_memq (SCM obj
, SCM list
)
1367 for (; SCM_CONSP (list
); list
= SCM_CDR (list
))
1369 if (SCM_EQ_P (SCM_CAR (list
), obj
))
1372 return SCM_EQ_P (list
, obj
);
1376 scm_m_lambda (SCM expr
, SCM env SCM_UNUSED
)
1385 const SCM cdr_expr
= SCM_CDR (expr
);
1386 const long length
= scm_ilength (cdr_expr
);
1387 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1388 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1390 /* Before iterating the list of formal arguments, make sure the formals
1391 * actually are given as either a symbol or a non-cyclic list. */
1392 formals
= SCM_CAR (cdr_expr
);
1393 if (SCM_CONSP (formals
))
1395 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
1396 * detected, report a 'Bad formals' error. */
1400 ASSERT_SYNTAX_2 (SCM_SYMBOLP (formals
) || SCM_NULLP (formals
),
1401 s_bad_formals
, formals
, expr
);
1404 /* Now iterate the list of formal arguments to check if all formals are
1405 * symbols, and that there are no duplicates. */
1406 formals_idx
= formals
;
1407 while (SCM_CONSP (formals_idx
))
1409 const SCM formal
= SCM_CAR (formals_idx
);
1410 const SCM next_idx
= SCM_CDR (formals_idx
);
1411 ASSERT_SYNTAX_2 (SCM_SYMBOLP (formal
), s_bad_formal
, formal
, expr
);
1412 ASSERT_SYNTAX_2 (!c_improper_memq (formal
, next_idx
),
1413 s_duplicate_formal
, formal
, expr
);
1414 formals_idx
= next_idx
;
1416 ASSERT_SYNTAX_2 (SCM_NULLP (formals_idx
) || SCM_SYMBOLP (formals_idx
),
1417 s_bad_formal
, formals_idx
, expr
);
1419 /* Memoize the body. Keep a potential documentation string. */
1420 /* Dirk:FIXME:: We should probably extract the documentation string to
1421 * some external database. Otherwise it will slow down execution, since
1422 * the documentation string will have to be skipped with every execution
1423 * of the closure. */
1424 cddr_expr
= SCM_CDR (cdr_expr
);
1425 documentation
= (length
>= 3 && SCM_STRINGP (SCM_CAR (cddr_expr
)));
1426 body
= documentation
? SCM_CDR (cddr_expr
) : cddr_expr
;
1427 new_body
= m_body (SCM_IM_LAMBDA
, body
);
1429 SCM_SETCAR (expr
, SCM_IM_LAMBDA
);
1431 SCM_SETCDR (cddr_expr
, new_body
);
1433 SCM_SETCDR (cdr_expr
, new_body
);
1438 /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
1440 check_bindings (const SCM bindings
, const SCM expr
)
1444 ASSERT_SYNTAX_2 (scm_ilength (bindings
) >= 0,
1445 s_bad_bindings
, bindings
, expr
);
1447 binding_idx
= bindings
;
1448 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1450 SCM name
; /* const */
1452 const SCM binding
= SCM_CAR (binding_idx
);
1453 ASSERT_SYNTAX_2 (scm_ilength (binding
) == 2,
1454 s_bad_binding
, binding
, expr
);
1456 name
= SCM_CAR (binding
);
1457 ASSERT_SYNTAX_2 (SCM_SYMBOLP (name
), s_bad_variable
, name
, expr
);
1462 /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
1463 * transformed to the lists (vn ... v2 v1) and (i1 i2 ... in). That is, the
1464 * variables are returned in a list with their order reversed, and the init
1465 * forms are returned in a list in the same order as they are given in the
1466 * bindings. If a duplicate variable name is detected, an error is
1469 transform_bindings (
1470 const SCM bindings
, const SCM expr
,
1471 SCM
*const rvarptr
, SCM
*const initptr
)
1473 SCM rvariables
= SCM_EOL
;
1474 SCM rinits
= SCM_EOL
;
1475 SCM binding_idx
= bindings
;
1476 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1478 const SCM binding
= SCM_CAR (binding_idx
);
1479 const SCM cdr_binding
= SCM_CDR (binding
);
1480 const SCM name
= SCM_CAR (binding
);
1481 ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (name
, rvariables
)),
1482 s_duplicate_binding
, name
, expr
);
1483 rvariables
= scm_cons (name
, rvariables
);
1484 rinits
= scm_cons (SCM_CAR (cdr_binding
), rinits
);
1486 *rvarptr
= rvariables
;
1487 *initptr
= scm_reverse_x (rinits
, SCM_UNDEFINED
);
1491 SCM_SYNTAX(s_let
, "let", scm_i_makbimacro
, scm_m_let
);
1492 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
1494 /* This function is a helper function for memoize_let. It transforms
1495 * (let name ((var init) ...) body ...) into
1496 * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
1497 * and memoizes the expression. It is assumed that the caller has checked
1498 * that name is a symbol and that there are bindings and a body. */
1500 memoize_named_let (const SCM expr
, const SCM env SCM_UNUSED
)
1506 const SCM cdr_expr
= SCM_CDR (expr
);
1507 const SCM name
= SCM_CAR (cdr_expr
);
1508 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1509 const SCM bindings
= SCM_CAR (cddr_expr
);
1510 check_bindings (bindings
, expr
);
1512 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1513 variables
= scm_reverse_x (rvariables
, SCM_UNDEFINED
);
1516 const SCM let_body
= SCM_CDR (cddr_expr
);
1517 const SCM lambda_body
= m_body (SCM_IM_LET
, let_body
);
1518 const SCM lambda_tail
= scm_cons (variables
, lambda_body
);
1519 const SCM lambda_form
= scm_cons_source (expr
, scm_sym_lambda
, lambda_tail
);
1521 const SCM rvar
= scm_list_1 (name
);
1522 const SCM init
= scm_list_1 (lambda_form
);
1523 const SCM body
= m_body (SCM_IM_LET
, scm_list_1 (name
));
1524 const SCM letrec_tail
= scm_cons (rvar
, scm_cons (init
, body
));
1525 const SCM letrec_form
= scm_cons_source (expr
, SCM_IM_LETREC
, letrec_tail
);
1526 return scm_cons_source (expr
, letrec_form
, inits
);
1530 /* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1531 * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
1533 scm_m_let (SCM expr
, SCM env
)
1537 const SCM cdr_expr
= SCM_CDR (expr
);
1538 const long length
= scm_ilength (cdr_expr
);
1539 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1540 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1542 bindings
= SCM_CAR (cdr_expr
);
1543 if (SCM_SYMBOLP (bindings
))
1545 ASSERT_SYNTAX (length
>= 3, s_missing_expression
, expr
);
1546 return memoize_named_let (expr
, env
);
1549 check_bindings (bindings
, expr
);
1550 if (SCM_NULLP (bindings
) || SCM_NULLP (SCM_CDR (bindings
)))
1552 /* Special case: no bindings or single binding => let* is faster. */
1553 const SCM body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1554 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), bindings
, body
), env
);
1561 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1564 const SCM new_body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1565 const SCM new_tail
= scm_cons2 (rvariables
, inits
, new_body
);
1566 SCM_SETCAR (expr
, SCM_IM_LET
);
1567 SCM_SETCDR (expr
, new_tail
);
1574 SCM_SYNTAX (s_letstar
, "let*", scm_i_makbimacro
, scm_m_letstar
);
1575 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
1577 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1578 * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
1580 scm_m_letstar (SCM expr
, SCM env SCM_UNUSED
)
1585 const SCM cdr_expr
= SCM_CDR (expr
);
1586 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1587 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1589 binding_idx
= SCM_CAR (cdr_expr
);
1590 check_bindings (binding_idx
, expr
);
1592 /* Transform ((v1 i1) (v2 i2) ...) into (v1 i1 v2 i2 ...). The
1593 * transformation is done in place. At the beginning of one iteration of
1594 * the loop the variable binding_idx holds the form
1595 * P1:( (vn . P2:(in . ())) . P3:( (vn+1 in+1) ... ) ),
1596 * where P1, P2 and P3 indicate the pairs, that are relevant for the
1597 * transformation. P1 and P2 are modified in the loop, P3 remains
1598 * untouched. After the execution of the loop, P1 will hold
1599 * P1:( vn . P2:(in . P3:( (vn+1 in+1) ... )) )
1600 * and binding_idx will hold P3. */
1601 while (!SCM_NULLP (binding_idx
))
1603 const SCM cdr_binding_idx
= SCM_CDR (binding_idx
); /* remember P3 */
1604 const SCM binding
= SCM_CAR (binding_idx
);
1605 const SCM name
= SCM_CAR (binding
);
1606 const SCM cdr_binding
= SCM_CDR (binding
);
1608 SCM_SETCDR (cdr_binding
, cdr_binding_idx
); /* update P2 */
1609 SCM_SETCAR (binding_idx
, name
); /* update P1 */
1610 SCM_SETCDR (binding_idx
, cdr_binding
); /* update P1 */
1612 binding_idx
= cdr_binding_idx
; /* continue with P3 */
1615 new_body
= m_body (SCM_IM_LETSTAR
, SCM_CDR (cdr_expr
));
1616 SCM_SETCAR (expr
, SCM_IM_LETSTAR
);
1617 /* the bindings have been changed in place */
1618 SCM_SETCDR (cdr_expr
, new_body
);
1623 SCM_SYNTAX(s_letrec
, "letrec", scm_i_makbimacro
, scm_m_letrec
);
1624 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
1627 scm_m_letrec (SCM expr
, SCM env
)
1631 const SCM cdr_expr
= SCM_CDR (expr
);
1632 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1633 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1635 bindings
= SCM_CAR (cdr_expr
);
1636 if (SCM_NULLP (bindings
))
1638 /* no bindings, let* is executed faster */
1639 SCM body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1640 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), SCM_EOL
, body
), env
);
1648 check_bindings (bindings
, expr
);
1649 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1650 new_body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1651 return scm_cons2 (SCM_IM_LETREC
, rvariables
, scm_cons (inits
, new_body
));
1656 SCM_SYNTAX (s_or
, "or", scm_i_makbimacro
, scm_m_or
);
1657 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
1660 scm_m_or (SCM expr
, SCM env SCM_UNUSED
)
1662 const SCM cdr_expr
= SCM_CDR (expr
);
1663 const long length
= scm_ilength (cdr_expr
);
1665 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1669 /* Special case: (or) is replaced by #f. */
1674 SCM_SETCAR (expr
, SCM_IM_OR
);
1680 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
1681 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
1682 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
1683 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
1685 /* Internal function to handle a quasiquotation: 'form' is the parameter in
1686 * the call (quasiquotation form), 'env' is the environment where unquoted
1687 * expressions will be evaluated, and 'depth' is the current quasiquotation
1688 * nesting level and is known to be greater than zero. */
1690 iqq (SCM form
, SCM env
, unsigned long int depth
)
1692 if (SCM_CONSP (form
))
1694 const SCM tmp
= SCM_CAR (form
);
1695 if (SCM_EQ_P (tmp
, scm_sym_quasiquote
))
1697 const SCM args
= SCM_CDR (form
);
1698 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1699 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
1701 else if (SCM_EQ_P (tmp
, scm_sym_unquote
))
1703 const SCM args
= SCM_CDR (form
);
1704 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1706 return scm_eval_car (args
, env
);
1708 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
1710 else if (SCM_CONSP (tmp
)
1711 && SCM_EQ_P (SCM_CAR (tmp
), scm_sym_uq_splicing
))
1713 const SCM args
= SCM_CDR (tmp
);
1714 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1717 const SCM list
= scm_eval_car (args
, env
);
1718 const SCM rest
= SCM_CDR (form
);
1719 ASSERT_SYNTAX_2 (scm_ilength (list
) >= 0,
1720 s_splicing
, list
, form
);
1721 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
1724 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
1725 iqq (SCM_CDR (form
), env
, depth
));
1728 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
1729 iqq (SCM_CDR (form
), env
, depth
));
1731 else if (SCM_VECTORP (form
))
1733 size_t i
= SCM_VECTOR_LENGTH (form
);
1734 SCM
const *const data
= SCM_VELTS (form
);
1737 tmp
= scm_cons (data
[--i
], tmp
);
1738 scm_remember_upto_here_1 (form
);
1739 return scm_vector (iqq (tmp
, env
, depth
));
1746 scm_m_quasiquote (SCM expr
, SCM env
)
1748 const SCM cdr_expr
= SCM_CDR (expr
);
1749 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1750 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1751 return iqq (SCM_CAR (cdr_expr
), env
, 1);
1755 SCM_SYNTAX (s_quote
, "quote", scm_i_makbimacro
, scm_m_quote
);
1756 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
1759 scm_m_quote (SCM expr
, SCM env SCM_UNUSED
)
1763 const SCM cdr_expr
= SCM_CDR (expr
);
1764 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1765 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1766 quotee
= SCM_CAR (cdr_expr
);
1767 if (SCM_IMP (quotee
) && !SCM_NULLP (quotee
))
1769 else if (SCM_VECTORP (quotee
))
1772 /* The following optimization would be possible if all variable references
1773 * were resolved during memoization: */
1774 else if (SCM_SYMBOLP (quotee
))
1777 SCM_SETCAR (expr
, SCM_IM_QUOTE
);
1782 /* Will go into the RnRS module when Guile is factorized.
1783 SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
1784 static const char s_set_x
[] = "set!";
1785 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, s_set_x
);
1788 scm_m_set_x (SCM expr
, SCM env SCM_UNUSED
)
1792 const SCM cdr_expr
= SCM_CDR (expr
);
1793 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1794 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1795 variable
= SCM_CAR (cdr_expr
);
1796 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
) || SCM_VARIABLEP (variable
),
1797 s_bad_variable
, variable
, expr
);
1799 SCM_SETCAR (expr
, SCM_IM_SET_X
);
1804 /* Start of the memoizers for non-R5RS builtin macros. */
1807 SCM_SYNTAX (s_atapply
, "@apply", scm_i_makbimacro
, scm_m_apply
);
1808 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1809 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1812 scm_m_apply (SCM expr
, SCM env SCM_UNUSED
)
1814 const SCM cdr_expr
= SCM_CDR (expr
);
1815 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1816 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_missing_expression
, expr
);
1818 SCM_SETCAR (expr
, SCM_IM_APPLY
);
1823 SCM_SYNTAX (s_atbind
, "@bind", scm_i_makbimacro
, scm_m_atbind
);
1825 /* FIXME: The following explanation should go into the documentation: */
1826 /* (@bind ((var init) ...) body ...) will assign the values of the `init's to
1827 * the global variables named by `var's (symbols, not evaluated), creating
1828 * them if they don't exist, executes body, and then restores the previous
1829 * values of the `var's. Additionally, whenever control leaves body, the
1830 * values of the `var's are saved and restored when control returns. It is an
1831 * error when a symbol appears more than once among the `var's. All `init's
1832 * are evaluated before any `var' is set.
1834 * Think of this as `let' for dynamic scope.
1837 /* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into
1838 * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...).
1840 * FIXME - also implement `@bind*'.
1843 scm_m_atbind (SCM expr
, SCM env
)
1850 const SCM top_level
= scm_env_top_level (env
);
1852 const SCM cdr_expr
= SCM_CDR (expr
);
1853 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1854 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1855 bindings
= SCM_CAR (cdr_expr
);
1856 check_bindings (bindings
, expr
);
1857 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1859 for (variable_idx
= rvariables
;
1860 !SCM_NULLP (variable_idx
);
1861 variable_idx
= SCM_CDR (variable_idx
))
1863 /* The first call to scm_sym2var will look beyond the current module,
1864 * while the second call wont. */
1865 const SCM variable
= SCM_CAR (variable_idx
);
1866 SCM new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_F
);
1867 if (SCM_FALSEP (new_variable
))
1868 new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_T
);
1869 SCM_SETCAR (variable_idx
, new_variable
);
1872 SCM_SETCAR (expr
, SCM_IM_BIND
);
1873 SCM_SETCAR (cdr_expr
, scm_cons (rvariables
, inits
));
1878 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_i_makbimacro
, scm_m_cont
);
1879 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, s_atcall_cc
);
1882 scm_m_cont (SCM expr
, SCM env SCM_UNUSED
)
1884 const SCM cdr_expr
= SCM_CDR (expr
);
1885 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1886 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1888 SCM_SETCAR (expr
, SCM_IM_CONT
);
1893 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_i_makbimacro
, scm_m_at_call_with_values
);
1894 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
1897 scm_m_at_call_with_values (SCM expr
, SCM env SCM_UNUSED
)
1899 const SCM cdr_expr
= SCM_CDR (expr
);
1900 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1901 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1903 SCM_SETCAR (expr
, SCM_IM_CALL_WITH_VALUES
);
1908 SCM_SYNTAX (s_future
, "future", scm_i_makbimacro
, scm_m_future
);
1909 SCM_GLOBAL_SYMBOL (scm_sym_future
, s_future
);
1911 /* Like promises, futures are implemented as closures with an empty
1912 * parameter list. Thus, (future <expression>) is transformed into
1913 * (#@future '() <expression>), where the empty list represents the
1914 * empty parameter list. This representation allows for easy creation
1915 * of the closure during evaluation. */
1917 scm_m_future (SCM expr
, SCM env
)
1919 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1920 SCM_SETCAR (new_expr
, SCM_IM_FUTURE
);
1925 SCM_SYNTAX (s_gset_x
, "set!", scm_i_makbimacro
, scm_m_generalized_set_x
);
1926 SCM_SYMBOL (scm_sym_setter
, "setter");
1929 scm_m_generalized_set_x (SCM expr
, SCM env
)
1931 SCM target
, exp_target
;
1933 const SCM cdr_expr
= SCM_CDR (expr
);
1934 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1935 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1937 target
= SCM_CAR (cdr_expr
);
1938 if (!SCM_CONSP (target
))
1941 return scm_m_set_x (expr
, env
);
1945 /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */
1946 /* Macroexpanding the target might return things of the form
1947 (begin <atom>). In that case, <atom> must be a symbol or a
1948 variable and we memoize to (set! <atom> ...).
1950 exp_target
= scm_macroexp (target
, env
);
1951 if (SCM_EQ_P (SCM_CAR (exp_target
), SCM_IM_BEGIN
)
1952 && !SCM_NULLP (SCM_CDR (exp_target
))
1953 && SCM_NULLP (SCM_CDDR (exp_target
)))
1955 exp_target
= SCM_CADR (exp_target
);
1956 ASSERT_SYNTAX_2 (SCM_SYMBOLP (exp_target
)
1957 || SCM_VARIABLEP (exp_target
),
1958 s_bad_variable
, exp_target
, expr
);
1959 return scm_cons (SCM_IM_SET_X
, scm_cons (exp_target
,
1960 SCM_CDR (cdr_expr
)));
1964 const SCM setter_proc_tail
= scm_list_1 (SCM_CAR (target
));
1965 const SCM setter_proc
= scm_cons_source (expr
, scm_sym_setter
,
1968 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1969 const SCM setter_args
= scm_append_x (scm_list_2 (SCM_CDR (target
),
1972 SCM_SETCAR (expr
, setter_proc
);
1973 SCM_SETCDR (expr
, setter_args
);
1980 /* @slot-ref is bound privately in the (oop goops) module from goops.c. As
1981 * soon as the module system allows us to more freely create bindings in
1982 * arbitrary modules during the startup phase, the code from goops.c should be
1985 scm_m_atslot_ref (SCM expr
, SCM env SCM_UNUSED
)
1989 const SCM cdr_expr
= SCM_CDR (expr
);
1990 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1991 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1992 slot_nr
= SCM_CADR (cdr_expr
);
1993 ASSERT_SYNTAX_2 (SCM_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
1995 SCM_SETCAR (expr
, SCM_IM_SLOT_REF
);
2000 /* @slot-set! is bound privately in the (oop goops) module from goops.c. As
2001 * soon as the module system allows us to more freely create bindings in
2002 * arbitrary modules during the startup phase, the code from goops.c should be
2005 scm_m_atslot_set_x (SCM expr
, SCM env SCM_UNUSED
)
2009 const SCM cdr_expr
= SCM_CDR (expr
);
2010 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2011 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 3, s_expression
, expr
);
2012 slot_nr
= SCM_CADR (cdr_expr
);
2013 ASSERT_SYNTAX_2 (SCM_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2015 SCM_SETCAR (expr
, SCM_IM_SLOT_SET_X
);
2020 #if SCM_ENABLE_ELISP
2022 static const char s_defun
[] = "Symbol's function definition is void";
2024 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_i_makbimacro
, scm_m_nil_cond
);
2026 /* nil-cond expressions have the form
2027 * (nil-cond COND VAL COND VAL ... ELSEVAL) */
2029 scm_m_nil_cond (SCM expr
, SCM env SCM_UNUSED
)
2031 const long length
= scm_ilength (SCM_CDR (expr
));
2032 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
2033 ASSERT_SYNTAX (length
>= 1 && (length
% 2) == 1, s_expression
, expr
);
2035 SCM_SETCAR (expr
, SCM_IM_NIL_COND
);
2040 SCM_SYNTAX (s_atfop
, "@fop", scm_i_makbimacro
, scm_m_atfop
);
2042 /* The @fop-macro handles procedure and macro applications for elisp. The
2043 * input expression must have the form
2044 * (@fop <var> (transformer-macro <expr> ...))
2045 * where <var> must be a symbol. The expression is transformed into the
2046 * memoized form of either
2047 * (apply <un-aliased var> (transformer-macro <expr> ...))
2048 * if the value of var (across all aliasing) is not a macro, or
2049 * (<un-aliased var> <expr> ...)
2050 * if var is a macro. */
2052 scm_m_atfop (SCM expr
, SCM env SCM_UNUSED
)
2057 const SCM cdr_expr
= SCM_CDR (expr
);
2058 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2059 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 1, s_missing_expression
, expr
);
2061 symbol
= SCM_CAR (cdr_expr
);
2062 ASSERT_SYNTAX_2 (SCM_SYMBOLP (symbol
), s_bad_variable
, symbol
, expr
);
2064 location
= scm_symbol_fref (symbol
);
2065 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2067 /* The elisp function `defalias' allows to define aliases for symbols. To
2068 * look up such definitions, the chain of symbol definitions has to be
2069 * followed up to the terminal symbol. */
2070 while (SCM_SYMBOLP (SCM_VARIABLE_REF (location
)))
2072 const SCM alias
= SCM_VARIABLE_REF (location
);
2073 location
= scm_symbol_fref (alias
);
2074 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2077 /* Memoize the value location belonging to the terminal symbol. */
2078 SCM_SETCAR (cdr_expr
, location
);
2080 if (!SCM_MACROP (SCM_VARIABLE_REF (location
)))
2082 /* Since the location does not contain a macro, the form is a procedure
2083 * application. Replace `@fop' by `@apply' and transform the expression
2084 * including the `transformer-macro'. */
2085 SCM_SETCAR (expr
, SCM_IM_APPLY
);
2090 /* Since the location contains a macro, the arguments should not be
2091 * transformed, so the `transformer-macro' is cut out. The resulting
2092 * expression starts with the memoized variable, that is at the cdr of
2093 * the input expression. */
2094 SCM_SETCDR (cdr_expr
, SCM_CDADR (cdr_expr
));
2099 #endif /* SCM_ENABLE_ELISP */
2102 /* Start of the memoizers for deprecated macros. */
2105 #if (SCM_ENABLE_DEPRECATED == 1)
2107 SCM_SYNTAX (s_undefine
, "undefine", scm_makacro
, scm_m_undefine
);
2110 scm_m_undefine (SCM expr
, SCM env
)
2115 const SCM cdr_expr
= SCM_CDR (expr
);
2116 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), "Bad undefine placement in", expr
);
2117 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2118 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2120 variable
= SCM_CAR (cdr_expr
);
2121 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
), s_bad_variable
, variable
, expr
);
2122 location
= scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_F
);
2123 ASSERT_SYNTAX_2 (!SCM_FALSEP (location
)
2124 && !SCM_UNBNDP (SCM_VARIABLE_REF (location
)),
2125 "variable already unbound ", variable
, expr
);
2126 SCM_VARIABLE_SET (location
, SCM_UNDEFINED
);
2127 return SCM_UNSPECIFIED
;
2133 #if (SCM_ENABLE_DEPRECATED == 1)
2136 scm_macroexp (SCM x
, SCM env
)
2138 SCM res
, proc
, orig_sym
;
2140 /* Don't bother to produce error messages here. We get them when we
2141 eventually execute the code for real. */
2144 orig_sym
= SCM_CAR (x
);
2145 if (!SCM_SYMBOLP (orig_sym
))
2149 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
2150 if (proc_ptr
== NULL
)
2152 /* We have lost the race. */
2158 /* Only handle memoizing macros. `Acros' and `macros' are really
2159 special forms and should not be evaluated here. */
2161 if (!SCM_MACROP (proc
)
2162 || (SCM_MACRO_TYPE (proc
) != 2 && !SCM_BUILTIN_MACRO_P (proc
)))
2165 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
2166 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
2168 if (scm_ilength (res
) <= 0)
2169 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
2172 SCM_SETCAR (x
, SCM_CAR (res
));
2173 SCM_SETCDR (x
, SCM_CDR (res
));
2181 /*****************************************************************************/
2182 /*****************************************************************************/
2183 /* The definitions for unmemoization start here. */
2184 /*****************************************************************************/
2185 /*****************************************************************************/
2187 #define SCM_BIT7(x) (127 & SCM_UNPACK (x))
2189 SCM_SYMBOL (sym_three_question_marks
, "???");
2192 /* scm_unmemocopy takes a memoized expression together with its
2193 * environment and rewrites it to its original form. Thus, it is the
2194 * inversion of the rewrite rules above. The procedure is not
2195 * optimized for speed. It's used in scm_iprin1 when printing the
2196 * code of a closure, in scm_procedure_source, in display_frame when
2197 * generating the source for a stackframe in a backtrace, and in
2198 * display_expression.
2200 * Unmemoizing is not a reliable process. You cannot in general
2201 * expect to get the original source back.
2203 * However, GOOPS currently relies on this for method compilation.
2204 * This ought to change.
2208 build_binding_list (SCM rnames
, SCM rinits
)
2210 SCM bindings
= SCM_EOL
;
2211 while (!SCM_NULLP (rnames
))
2213 SCM binding
= scm_list_2 (SCM_CAR (rnames
), SCM_CAR (rinits
));
2214 bindings
= scm_cons (binding
, bindings
);
2215 rnames
= SCM_CDR (rnames
);
2216 rinits
= SCM_CDR (rinits
);
2223 unmemocar (SCM form
, SCM env
)
2225 if (!SCM_CONSP (form
))
2229 SCM c
= SCM_CAR (form
);
2230 if (SCM_VARIABLEP (c
))
2232 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
2233 if (SCM_FALSEP (sym
))
2234 sym
= sym_three_question_marks
;
2235 SCM_SETCAR (form
, sym
);
2237 else if (SCM_ILOCP (c
))
2239 unsigned long int ir
;
2241 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
2242 env
= SCM_CDR (env
);
2243 env
= SCM_CAAR (env
);
2244 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
2245 env
= SCM_CDR (env
);
2247 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
2254 #if (SCM_ENABLE_DEPRECATED == 1)
2257 scm_unmemocar (SCM form
, SCM env
)
2259 return unmemocar (form
, env
);
2266 scm_unmemocopy (SCM x
, SCM env
)
2271 if (SCM_VECTORP (x
))
2273 return scm_list_2 (scm_sym_quote
, x
);
2275 else if (!SCM_CONSP (x
))
2278 p
= scm_whash_lookup (scm_source_whash
, x
);
2279 switch (SCM_ITAG7 (SCM_CAR (x
)))
2281 case SCM_BIT7 (SCM_IM_AND
):
2282 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
2284 case SCM_BIT7 (SCM_IM_BEGIN
):
2285 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
2287 case SCM_BIT7 (SCM_IM_CASE
):
2288 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
2290 case SCM_BIT7 (SCM_IM_COND
):
2291 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
2293 case SCM_BIT7 (SCM_IM_DO
):
2295 /* format: (#@do (i1 ... ik) (nk nk-1 ...) (test) (body) s1 ... sk),
2296 * where ix is an initializer for a local variable, nx is the name of
2297 * the local variable, test is the test clause of the do loop, body is
2298 * the body of the do loop and sx are the step clauses for the local
2300 SCM names
, inits
, test
, memoized_body
, steps
, bindings
;
2303 inits
= scm_reverse (scm_unmemocopy (SCM_CAR (x
), env
));
2305 names
= SCM_CAR (x
);
2306 env
= SCM_EXTEND_ENV (names
, SCM_EOL
, env
);
2308 test
= scm_unmemocopy (SCM_CAR (x
), env
);
2310 memoized_body
= SCM_CAR (x
);
2312 steps
= scm_reverse (scm_unmemocopy (x
, env
));
2314 /* build transformed binding list */
2316 while (!SCM_NULLP (names
))
2318 SCM name
= SCM_CAR (names
);
2319 SCM init
= SCM_CAR (inits
);
2320 SCM step
= SCM_CAR (steps
);
2321 step
= SCM_EQ_P (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
2323 bindings
= scm_cons (scm_cons2 (name
, init
, step
), bindings
);
2325 names
= SCM_CDR (names
);
2326 inits
= SCM_CDR (inits
);
2327 steps
= SCM_CDR (steps
);
2329 z
= scm_cons (test
, SCM_UNSPECIFIED
);
2330 ls
= scm_cons2 (scm_sym_do
, bindings
, z
);
2332 x
= scm_cons (SCM_BOOL_F
, memoized_body
);
2335 case SCM_BIT7 (SCM_IM_IF
):
2336 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
2338 case SCM_BIT7 (SCM_IM_LET
):
2340 /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),
2341 * where nx is the name of a local variable, ix is an initializer for
2342 * the local variable and by are the body clauses. */
2343 SCM rnames
, rinits
, bindings
;
2346 rnames
= SCM_CAR (x
);
2348 rinits
= scm_reverse (scm_unmemocopy (SCM_CAR (x
), env
));
2349 env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
2351 bindings
= build_binding_list (rnames
, rinits
);
2352 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
2353 ls
= scm_cons (scm_sym_let
, z
);
2356 case SCM_BIT7 (SCM_IM_LETREC
):
2358 /* format: (#@letrec (vn ... v2 v1) (i1 i2 ... in) b1 ...),
2359 * where vx is the name of a local variable, ix is an initializer for
2360 * the local variable and by are the body clauses. */
2361 SCM rnames
, rinits
, bindings
;
2364 rnames
= SCM_CAR (x
);
2365 env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
2367 rinits
= scm_reverse (scm_unmemocopy (SCM_CAR (x
), env
));
2369 bindings
= build_binding_list (rnames
, rinits
);
2370 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
2371 ls
= scm_cons (scm_sym_letrec
, z
);
2374 case SCM_BIT7 (SCM_IM_LETSTAR
):
2382 env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2385 y
= z
= scm_acons (SCM_CAR (b
),
2387 scm_cons (scm_unmemocopy (SCM_CADR (b
), env
), SCM_EOL
), env
),
2389 env
= SCM_EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
2393 SCM_SETCDR (y
, SCM_EOL
);
2394 z
= scm_cons (y
, SCM_UNSPECIFIED
);
2395 ls
= scm_cons (scm_sym_let
, z
);
2400 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
2402 scm_list_1 (scm_unmemocopy (SCM_CADR (b
), env
)), env
),
2405 env
= SCM_EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
2408 while (SCM_NIMP (b
));
2409 SCM_SETCDR (z
, SCM_EOL
);
2411 z
= scm_cons (y
, SCM_UNSPECIFIED
);
2412 ls
= scm_cons (scm_sym_letstar
, z
);
2415 case SCM_BIT7 (SCM_IM_OR
):
2416 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
2418 case SCM_BIT7 (SCM_IM_LAMBDA
):
2420 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
);
2421 ls
= scm_cons (scm_sym_lambda
, z
);
2422 env
= SCM_EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
2424 case SCM_BIT7 (SCM_IM_QUOTE
):
2425 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
2427 case SCM_BIT7 (SCM_IM_SET_X
):
2428 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
2430 case SCM_BIT7 (SCM_MAKISYM (0)):
2432 switch (SCM_ISYMNUM (z
))
2434 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2435 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
2437 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2438 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
2440 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2441 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
2444 case (SCM_ISYMNUM (SCM_IM_FUTURE
)):
2445 ls
= z
= scm_cons (scm_sym_future
, SCM_UNSPECIFIED
);
2448 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2449 ls
= z
= scm_cons (scm_sym_at_call_with_values
, SCM_UNSPECIFIED
);
2451 case (SCM_ISYMNUM (SCM_IM_ELSE
)):
2452 ls
= z
= scm_cons (scm_sym_else
, SCM_UNSPECIFIED
);
2455 /* appease the Sun compiler god: */ ;
2458 ls
= z
= unmemocar (scm_cons (scm_unmemocopy (SCM_CAR (x
), env
),
2464 while (SCM_CONSP (x
))
2466 SCM form
= SCM_CAR (x
);
2467 if (!SCM_ISYMP (form
))
2469 SCM copy
= scm_cons (scm_unmemocopy (form
, env
), SCM_UNSPECIFIED
);
2470 SCM_SETCDR (z
, unmemocar (copy
, env
));
2473 else if (SCM_EQ_P (form
, SCM_IM_ARROW
))
2475 SCM_SETCDR (z
, scm_cons (scm_sym_arrow
, SCM_UNSPECIFIED
));
2481 if (!SCM_FALSEP (p
))
2482 scm_whash_insert (scm_source_whash
, ls
, p
);
2487 /*****************************************************************************/
2488 /*****************************************************************************/
2489 /* The definitions for execution start here. */
2490 /*****************************************************************************/
2491 /*****************************************************************************/
2493 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
2494 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
2495 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
2496 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
2498 /* A function object to implement "apply" for non-closure functions. */
2500 /* An endless list consisting of #<undefined> objects: */
2501 static SCM undefineds
;
2505 scm_badargsp (SCM formals
, SCM args
)
2507 while (!SCM_NULLP (formals
))
2509 if (!SCM_CONSP (formals
))
2511 if (SCM_NULLP (args
))
2513 formals
= SCM_CDR (formals
);
2514 args
= SCM_CDR (args
);
2516 return !SCM_NULLP (args
) ? 1 : 0;
2521 scm_eval_args (SCM l
, SCM env
, SCM proc
)
2523 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
2524 while (SCM_CONSP (l
))
2526 res
= EVALCAR (l
, env
);
2528 *lloc
= scm_list_1 (res
);
2529 lloc
= SCM_CDRLOC (*lloc
);
2533 scm_wrong_num_args (proc
);
2539 scm_eval_body (SCM code
, SCM env
)
2543 next
= SCM_CDR (code
);
2544 while (!SCM_NULLP (next
))
2546 if (SCM_IMP (SCM_CAR (code
)))
2548 if (SCM_ISYMP (SCM_CAR (code
)))
2550 scm_rec_mutex_lock (&source_mutex
);
2551 /* check for race condition */
2552 if (SCM_ISYMP (SCM_CAR (code
)))
2553 m_expand_body (code
, env
);
2554 scm_rec_mutex_unlock (&source_mutex
);
2559 SCM_XEVAL (SCM_CAR (code
), env
);
2561 next
= SCM_CDR (code
);
2563 return SCM_XEVALCAR (code
, env
);
2569 /* SECTION: This code is specific for the debugging support. One
2570 * branch is read when DEVAL isn't defined, the other when DEVAL is
2576 #define SCM_APPLY scm_apply
2577 #define PREP_APPLY(proc, args)
2579 #define RETURN(x) do { return x; } while (0)
2580 #ifdef STACK_CHECKING
2581 #ifndef NO_CEVAL_STACK_CHECKING
2582 #define EVAL_STACK_CHECKING
2589 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
2591 #define SCM_APPLY scm_dapply
2593 #define PREP_APPLY(p, l) \
2594 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
2596 #define ENTER_APPLY \
2598 SCM_SET_ARGSREADY (debug);\
2599 if (scm_check_apply_p && SCM_TRAPS_P)\
2600 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
2602 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
2603 SCM_SET_TRACED_FRAME (debug); \
2605 if (SCM_CHEAPTRAPS_P)\
2607 tmp = scm_make_debugobj (&debug);\
2608 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
2613 tmp = scm_make_continuation (&first);\
2615 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
2621 #define RETURN(e) do { proc = (e); goto exit; } while (0)
2622 #ifdef STACK_CHECKING
2623 #ifndef EVAL_STACK_CHECKING
2624 #define EVAL_STACK_CHECKING
2628 /* scm_ceval_ptr points to the currently selected evaluator.
2629 * *fixme*: Although efficiency is important here, this state variable
2630 * should probably not be a global. It should be related to the
2635 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
2637 /* scm_last_debug_frame contains a pointer to the last debugging
2638 * information stack frame. It is accessed very often from the
2639 * debugging evaluator, so it should probably not be indirectly
2640 * addressed. Better to save and restore it from the current root at
2644 /* scm_debug_eframe_size is the number of slots available for pseudo
2645 * stack frames at each real stack frame.
2648 long scm_debug_eframe_size
;
2650 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
2652 long scm_eval_stack
;
2654 scm_t_option scm_eval_opts
[] = {
2655 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
2658 scm_t_option scm_debug_opts
[] = {
2659 { SCM_OPTION_BOOLEAN
, "cheap", 1,
2660 "*Flyweight representation of the stack at traps." },
2661 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
2662 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
2663 { SCM_OPTION_BOOLEAN
, "procnames", 1,
2664 "Record procedure names at definition." },
2665 { SCM_OPTION_BOOLEAN
, "backwards", 0,
2666 "Display backtrace in anti-chronological order." },
2667 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
2668 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
2669 { SCM_OPTION_INTEGER
, "frames", 3,
2670 "Maximum number of tail-recursive frames in backtrace." },
2671 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
2672 "Maximal number of stored backtrace frames." },
2673 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
2674 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
2675 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
2676 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
2677 { 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."}
2680 scm_t_option scm_evaluator_trap_table
[] = {
2681 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
2682 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
2683 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
2684 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
2685 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
2686 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
2687 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
2690 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
2692 "Option interface for the evaluation options. Instead of using\n"
2693 "this procedure directly, use the procedures @code{eval-enable},\n"
2694 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
2695 #define FUNC_NAME s_scm_eval_options_interface
2699 ans
= scm_options (setting
,
2703 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
2710 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
2712 "Option interface for the evaluator trap options.")
2713 #define FUNC_NAME s_scm_evaluator_traps
2717 ans
= scm_options (setting
,
2718 scm_evaluator_trap_table
,
2719 SCM_N_EVALUATOR_TRAPS
,
2721 SCM_RESET_DEBUG_MODE
;
2729 deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
2731 SCM
*results
= lloc
, res
;
2732 while (SCM_CONSP (l
))
2734 res
= EVALCAR (l
, env
);
2736 *lloc
= scm_list_1 (res
);
2737 lloc
= SCM_CDRLOC (*lloc
);
2741 scm_wrong_num_args (proc
);
2748 /* SECTION: This code is compiled twice.
2752 /* Update the toplevel environment frame ENV so that it refers to the
2753 * current module. */
2754 #define UPDATE_TOPLEVEL_ENV(env) \
2756 SCM p = scm_current_module_lookup_closure (); \
2757 if (p != SCM_CAR (env)) \
2758 env = scm_top_level_env (p); \
2762 #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
2763 ASSERT_SYNTAX (!SCM_EQ_P ((x), SCM_EOL), s_empty_combination, x)
2766 /* This is the evaluator. Like any real monster, it has three heads:
2768 * scm_ceval is the non-debugging evaluator, scm_deval is the debugging
2769 * version. Both are implemented using a common code base, using the
2770 * following mechanism: SCM_CEVAL is a macro, which is either defined to
2771 * scm_ceval or scm_deval. Thus, there is no function SCM_CEVAL, but the code
2772 * for SCM_CEVAL actually compiles to either scm_ceval or scm_deval. When
2773 * SCM_CEVAL is defined to scm_ceval, it is known that the macro DEVAL is not
2774 * defined. When SCM_CEVAL is defined to scm_deval, then the macro DEVAL is
2775 * known to be defined. Thus, in SCM_CEVAL parts for the debugging evaluator
2776 * are enclosed within #ifdef DEVAL ... #endif.
2778 * All three (scm_ceval, scm_deval and their common implementation SCM_CEVAL)
2779 * take two input parameters, x and env: x is a single expression to be
2780 * evalutated. env is the environment in which bindings are searched.
2782 * x is known to be a cell (i. e. a pair or any other non-immediate). Since x
2783 * is a single expression, it is necessarily in a tail position. If x is just
2784 * a call to another function like in the expression (foo exp1 exp2 ...), the
2785 * realization of that call therefore _must_not_ increase stack usage (the
2786 * evaluation of exp1, exp2 etc., however, may do so). This is realized by
2787 * making extensive use of 'goto' statements within the evaluator: The gotos
2788 * replace recursive calls to SCM_CEVAL, thus re-using the same stack frame
2789 * that SCM_CEVAL was already using. If, however, x represents some form that
2790 * requires to evaluate a sequence of expressions like (begin exp1 exp2 ...),
2791 * then recursive calls to SCM_CEVAL are performed for all but the last
2792 * expression of that sequence. */
2796 scm_ceval (SCM x
, SCM env
)
2802 scm_deval (SCM x
, SCM env
)
2807 SCM_CEVAL (SCM x
, SCM env
)
2811 scm_t_debug_frame debug
;
2812 scm_t_debug_info
*debug_info_end
;
2813 debug
.prev
= scm_last_debug_frame
;
2816 * The debug.vect contains twice as much scm_t_debug_info frames as the
2817 * user has specified with (debug-set! frames <n>).
2819 * Even frames are eval frames, odd frames are apply frames.
2821 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
2822 * sizeof (scm_t_debug_info
));
2823 debug
.info
= debug
.vect
;
2824 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
2825 scm_last_debug_frame
= &debug
;
2827 #ifdef EVAL_STACK_CHECKING
2828 if (scm_stack_checking_enabled_p
&& SCM_STACK_OVERFLOW_P (&proc
))
2831 debug
.info
->e
.exp
= x
;
2832 debug
.info
->e
.env
= env
;
2834 scm_report_stack_overflow ();
2844 SCM_CLEAR_ARGSREADY (debug
);
2845 if (SCM_OVERFLOWP (debug
))
2848 * In theory, this should be the only place where it is necessary to
2849 * check for space in debug.vect since both eval frames and
2850 * available space are even.
2852 * For this to be the case, however, it is necessary that primitive
2853 * special forms which jump back to `loop', `begin' or some similar
2854 * label call PREP_APPLY.
2856 else if (++debug
.info
>= debug_info_end
)
2858 SCM_SET_OVERFLOW (debug
);
2863 debug
.info
->e
.exp
= x
;
2864 debug
.info
->e
.env
= env
;
2865 if (scm_check_entry_p
&& SCM_TRAPS_P
)
2867 if (SCM_ENTER_FRAME_P
2868 || (SCM_BREAKPOINTS_P
&& scm_c_source_property_breakpoint_p (x
)))
2871 SCM tail
= SCM_BOOL (SCM_TAILRECP (debug
));
2872 SCM_SET_TAILREC (debug
);
2873 if (SCM_CHEAPTRAPS_P
)
2874 stackrep
= scm_make_debugobj (&debug
);
2878 SCM val
= scm_make_continuation (&first
);
2888 /* This gives the possibility for the debugger to
2889 modify the source expression before evaluation. */
2894 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
2895 scm_sym_enter_frame
,
2898 scm_unmemocopy (x
, env
));
2905 switch (SCM_TYP7 (x
))
2907 case SCM_BIT7 (SCM_IM_AND
):
2909 while (!SCM_NULLP (SCM_CDR (x
)))
2911 SCM test_result
= EVALCAR (x
, env
);
2912 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
2913 RETURN (SCM_BOOL_F
);
2917 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2920 case SCM_BIT7 (SCM_IM_BEGIN
):
2923 RETURN (SCM_UNSPECIFIED
);
2925 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2928 /* If we are on toplevel with a lookup closure, we need to sync
2929 with the current module. */
2930 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
2932 UPDATE_TOPLEVEL_ENV (env
);
2933 while (!SCM_NULLP (SCM_CDR (x
)))
2936 UPDATE_TOPLEVEL_ENV (env
);
2942 goto nontoplevel_begin
;
2945 while (!SCM_NULLP (SCM_CDR (x
)))
2947 SCM form
= SCM_CAR (x
);
2950 if (SCM_ISYMP (form
))
2952 scm_rec_mutex_lock (&source_mutex
);
2953 /* check for race condition */
2954 if (SCM_ISYMP (SCM_CAR (x
)))
2955 m_expand_body (x
, env
);
2956 scm_rec_mutex_unlock (&source_mutex
);
2957 goto nontoplevel_begin
;
2960 SCM_VALIDATE_NON_EMPTY_COMBINATION (form
);
2963 SCM_CEVAL (form
, env
);
2969 /* scm_eval last form in list */
2970 SCM last_form
= SCM_CAR (x
);
2972 if (SCM_CONSP (last_form
))
2974 /* This is by far the most frequent case. */
2976 goto loop
; /* tail recurse */
2978 else if (SCM_IMP (last_form
))
2979 RETURN (SCM_EVALIM (last_form
, env
));
2980 else if (SCM_VARIABLEP (last_form
))
2981 RETURN (SCM_VARIABLE_REF (last_form
));
2982 else if (SCM_SYMBOLP (last_form
))
2983 RETURN (*scm_lookupcar (x
, env
, 1));
2989 case SCM_BIT7 (SCM_IM_CASE
):
2992 SCM key
= EVALCAR (x
, env
);
2994 while (!SCM_NULLP (x
))
2996 SCM clause
= SCM_CAR (x
);
2997 SCM labels
= SCM_CAR (clause
);
2998 if (SCM_EQ_P (labels
, SCM_IM_ELSE
))
3000 x
= SCM_CDR (clause
);
3001 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3004 while (!SCM_NULLP (labels
))
3006 SCM label
= SCM_CAR (labels
);
3007 if (SCM_EQ_P (label
, key
) || !SCM_FALSEP (scm_eqv_p (label
, key
)))
3009 x
= SCM_CDR (clause
);
3010 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3013 labels
= SCM_CDR (labels
);
3018 RETURN (SCM_UNSPECIFIED
);
3021 case SCM_BIT7 (SCM_IM_COND
):
3023 while (!SCM_NULLP (x
))
3025 SCM clause
= SCM_CAR (x
);
3026 if (SCM_EQ_P (SCM_CAR (clause
), SCM_IM_ELSE
))
3028 x
= SCM_CDR (clause
);
3029 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3034 arg1
= EVALCAR (clause
, env
);
3035 if (!SCM_FALSEP (arg1
) && !SCM_NILP (arg1
))
3037 x
= SCM_CDR (clause
);
3040 else if (!SCM_EQ_P (SCM_CAR (x
), SCM_IM_ARROW
))
3042 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3048 proc
= EVALCAR (proc
, env
);
3049 PREP_APPLY (proc
, scm_list_1 (arg1
));
3057 RETURN (SCM_UNSPECIFIED
);
3060 case SCM_BIT7 (SCM_IM_DO
):
3063 /* Compute the initialization values and the initial environment. */
3064 SCM init_forms
= SCM_CAR (x
);
3065 SCM init_values
= SCM_EOL
;
3066 while (!SCM_NULLP (init_forms
))
3068 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3069 init_forms
= SCM_CDR (init_forms
);
3072 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
3076 SCM test_form
= SCM_CAR (x
);
3077 SCM body_forms
= SCM_CADR (x
);
3078 SCM step_forms
= SCM_CDDR (x
);
3080 SCM test_result
= EVALCAR (test_form
, env
);
3082 while (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
3085 /* Evaluate body forms. */
3087 for (temp_forms
= body_forms
;
3088 !SCM_NULLP (temp_forms
);
3089 temp_forms
= SCM_CDR (temp_forms
))
3091 SCM form
= SCM_CAR (temp_forms
);
3092 /* Dirk:FIXME: We only need to eval forms, that may have a
3093 * side effect here. This is only true for forms that start
3094 * with a pair. All others are just constants. However,
3095 * since in the common case there is no constant expression
3096 * in a body of a do form, we just check for immediates here
3097 * and have SCM_CEVAL take care of other cases. In the long
3098 * run it would make sense to get rid of this test and have
3099 * the macro transformer of 'do' eliminate all forms that
3100 * have no sideeffect. */
3101 if (!SCM_IMP (form
))
3102 SCM_CEVAL (form
, env
);
3107 /* Evaluate the step expressions. */
3109 SCM step_values
= SCM_EOL
;
3110 for (temp_forms
= step_forms
;
3111 !SCM_NULLP (temp_forms
);
3112 temp_forms
= SCM_CDR (temp_forms
))
3114 SCM value
= EVALCAR (temp_forms
, env
);
3115 step_values
= scm_cons (value
, step_values
);
3117 env
= SCM_EXTEND_ENV (SCM_CAAR (env
),
3122 test_result
= EVALCAR (test_form
, env
);
3127 RETURN (SCM_UNSPECIFIED
);
3128 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3129 goto nontoplevel_begin
;
3132 case SCM_BIT7 (SCM_IM_IF
):
3135 SCM test_result
= EVALCAR (x
, env
);
3136 x
= SCM_CDR (x
); /* then expression */
3137 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
3139 x
= SCM_CDR (x
); /* else expression */
3141 RETURN (SCM_UNSPECIFIED
);
3144 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3148 case SCM_BIT7 (SCM_IM_LET
):
3151 SCM init_forms
= SCM_CADR (x
);
3152 SCM init_values
= SCM_EOL
;
3155 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3156 init_forms
= SCM_CDR (init_forms
);
3158 while (!SCM_NULLP (init_forms
));
3159 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
3162 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3163 goto nontoplevel_begin
;
3166 case SCM_BIT7 (SCM_IM_LETREC
):
3168 env
= SCM_EXTEND_ENV (SCM_CAR (x
), undefineds
, env
);
3171 SCM init_forms
= SCM_CAR (x
);
3172 SCM init_values
= SCM_EOL
;
3175 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3176 init_forms
= SCM_CDR (init_forms
);
3178 while (!SCM_NULLP (init_forms
));
3179 SCM_SETCDR (SCM_CAR (env
), init_values
);
3182 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3183 goto nontoplevel_begin
;
3186 case SCM_BIT7 (SCM_IM_LETSTAR
):
3189 SCM bindings
= SCM_CAR (x
);
3190 if (SCM_NULLP (bindings
))
3191 env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
3196 SCM name
= SCM_CAR (bindings
);
3197 SCM init
= SCM_CDR (bindings
);
3198 env
= SCM_EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
3199 bindings
= SCM_CDR (init
);
3201 while (!SCM_NULLP (bindings
));
3205 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3206 goto nontoplevel_begin
;
3209 case SCM_BIT7 (SCM_IM_OR
):
3211 while (!SCM_NULLP (SCM_CDR (x
)))
3213 SCM val
= EVALCAR (x
, env
);
3214 if (!SCM_FALSEP (val
) && !SCM_NILP (val
))
3219 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3223 case SCM_BIT7 (SCM_IM_LAMBDA
):
3224 RETURN (scm_closure (SCM_CDR (x
), env
));
3227 case SCM_BIT7 (SCM_IM_QUOTE
):
3228 RETURN (SCM_CADR (x
));
3231 case SCM_BIT7 (SCM_IM_SET_X
):
3235 SCM variable
= SCM_CAR (x
);
3236 if (SCM_ILOCP (variable
))
3237 location
= scm_ilookup (variable
, env
);
3238 else if (SCM_VARIABLEP (variable
))
3239 location
= SCM_VARIABLE_LOC (variable
);
3240 else /* (SCM_SYMBOLP (variable)) is known to be true */
3241 location
= scm_lookupcar (x
, env
, 1);
3243 *location
= EVALCAR (x
, env
);
3245 RETURN (SCM_UNSPECIFIED
);
3248 /* new syntactic forms go here. */
3249 case SCM_BIT7 (SCM_MAKISYM (0)):
3251 switch (SCM_ISYMNUM (proc
))
3255 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
3256 /* Evaluate the procedure to be applied. */
3258 proc
= EVALCAR (x
, env
);
3259 PREP_APPLY (proc
, SCM_EOL
);
3261 /* Evaluate the argument holding the list of arguments */
3263 arg1
= EVALCAR (x
, env
);
3266 /* Go here to tail-apply a procedure. PROC is the procedure and
3267 * ARG1 is the list of arguments. PREP_APPLY must have been called
3268 * before jumping to apply_proc. */
3269 if (SCM_CLOSUREP (proc
))
3271 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3273 debug
.info
->a
.args
= arg1
;
3275 if (scm_badargsp (formals
, arg1
))
3276 scm_wrong_num_args (proc
);
3278 /* Copy argument list */
3279 if (SCM_NULL_OR_NIL_P (arg1
))
3280 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
3283 SCM args
= scm_list_1 (SCM_CAR (arg1
));
3285 arg1
= SCM_CDR (arg1
);
3286 while (!SCM_NULL_OR_NIL_P (arg1
))
3288 SCM new_tail
= scm_list_1 (SCM_CAR (arg1
));
3289 SCM_SETCDR (tail
, new_tail
);
3291 arg1
= SCM_CDR (arg1
);
3293 env
= SCM_EXTEND_ENV (formals
, args
, SCM_ENV (proc
));
3296 x
= SCM_CLOSURE_BODY (proc
);
3297 goto nontoplevel_begin
;
3302 RETURN (SCM_APPLY (proc
, arg1
, SCM_EOL
));
3306 case (SCM_ISYMNUM (SCM_IM_CONT
)):
3309 SCM val
= scm_make_continuation (&first
);
3317 proc
= EVALCAR (proc
, env
);
3318 PREP_APPLY (proc
, scm_list_1 (arg1
));
3325 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
3326 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
3329 case (SCM_ISYMNUM (SCM_IM_FUTURE
)):
3330 RETURN (scm_i_make_future (scm_closure (SCM_CDR (x
), env
)));
3333 /* PLACEHOLDER for case (SCM_ISYMNUM (SCM_IM_DISPATCH)): The
3334 following code (type_dispatch) is intended to be the tail
3335 of the case clause for the internal macro
3336 SCM_IM_DISPATCH. Please don't remove it from this
3337 location without discussing it with Mikael
3338 <djurfeldt@nada.kth.se> */
3340 /* The type dispatch code is duplicated below
3341 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
3342 * cuts down execution time for type dispatch to 50%. */
3343 type_dispatch
: /* inputs: x, arg1 */
3344 /* Type dispatch means to determine from the types of the function
3345 * arguments (i. e. the 'signature' of the call), which method from
3346 * a generic function is to be called. This process of selecting
3347 * the right method takes some time. To speed it up, guile uses
3348 * caching: Together with the macro call to dispatch the signatures
3349 * of some previous calls to that generic function from the same
3350 * place are stored (in the code!) in a cache that we call the
3351 * 'method cache'. This is done since it is likely, that
3352 * consecutive calls to dispatch from that position in the code will
3353 * have the same signature. Thus, the type dispatch works as
3354 * follows: First, determine a hash value from the signature of the
3355 * actual arguments. Second, use this hash value as an index to
3356 * find that same signature in the method cache stored at this
3357 * position in the code. If found, you have also found the
3358 * corresponding method that belongs to that signature. If the
3359 * signature is not found in the method cache, you have to perform a
3360 * full search over all signatures stored with the generic
3363 unsigned long int specializers
;
3364 unsigned long int hash_value
;
3365 unsigned long int cache_end_pos
;
3366 unsigned long int mask
;
3370 SCM z
= SCM_CDDR (x
);
3371 SCM tmp
= SCM_CADR (z
);
3372 specializers
= SCM_INUM (SCM_CAR (z
));
3374 /* Compute a hash value for searching the method cache. There
3375 * are two variants for computing the hash value, a (rather)
3376 * complicated one, and a simple one. For the complicated one
3377 * explained below, tmp holds a number that is used in the
3379 if (SCM_INUMP (tmp
))
3381 /* Use the signature of the actual arguments to determine
3382 * the hash value. This is done as follows: Each class has
3383 * an array of random numbers, that are determined when the
3384 * class is created. The integer 'hashset' is an index into
3385 * that array of random numbers. Now, from all classes that
3386 * are part of the signature of the actual arguments, the
3387 * random numbers at index 'hashset' are taken and summed
3388 * up, giving the hash value. The value of 'hashset' is
3389 * stored at the call to dispatch. This allows to have
3390 * different 'formulas' for calculating the hash value at
3391 * different places where dispatch is called. This allows
3392 * to optimize the hash formula at every individual place
3393 * where dispatch is called, such that hopefully the hash
3394 * value that is computed will directly point to the right
3395 * method in the method cache. */
3396 unsigned long int hashset
= SCM_INUM (tmp
);
3397 unsigned long int counter
= specializers
+ 1;
3400 while (!SCM_NULLP (tmp_arg
) && counter
!= 0)
3402 SCM
class = scm_class_of (SCM_CAR (tmp_arg
));
3403 hash_value
+= SCM_INSTANCE_HASH (class, hashset
);
3404 tmp_arg
= SCM_CDR (tmp_arg
);
3408 method_cache
= SCM_CADR (z
);
3409 mask
= SCM_INUM (SCM_CAR (z
));
3411 cache_end_pos
= hash_value
;
3415 /* This method of determining the hash value is much
3416 * simpler: Set the hash value to zero and just perform a
3417 * linear search through the method cache. */
3419 mask
= (unsigned long int) ((long) -1);
3421 cache_end_pos
= SCM_VECTOR_LENGTH (method_cache
);
3426 /* Search the method cache for a method with a matching
3427 * signature. Start the search at position 'hash_value'. The
3428 * hashing implementation uses linear probing for conflict
3429 * resolution, that is, if the signature in question is not
3430 * found at the starting index in the hash table, the next table
3431 * entry is tried, and so on, until in the worst case the whole
3432 * cache has been searched, but still the signature has not been
3437 SCM args
= arg1
; /* list of arguments */
3438 z
= SCM_VELTS (method_cache
)[hash_value
];
3439 while (!SCM_NULLP (args
))
3441 /* More arguments than specifiers => CLASS != ENV */
3442 SCM class_of_arg
= scm_class_of (SCM_CAR (args
));
3443 if (!SCM_EQ_P (class_of_arg
, SCM_CAR (z
)))
3445 args
= SCM_CDR (args
);
3448 /* Fewer arguments than specifiers => CAR != ENV */
3449 if (SCM_NULLP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
)))
3452 hash_value
= (hash_value
+ 1) & mask
;
3453 } while (hash_value
!= cache_end_pos
);
3455 /* No appropriate method was found in the cache. */
3456 z
= scm_memoize_method (x
, arg1
);
3458 apply_cmethod
: /* inputs: z, arg1 */
3460 SCM formals
= SCM_CMETHOD_FORMALS (z
);
3461 env
= SCM_EXTEND_ENV (formals
, arg1
, SCM_CMETHOD_ENV (z
));
3462 x
= SCM_CMETHOD_BODY (z
);
3463 goto nontoplevel_begin
;
3469 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
3472 SCM instance
= EVALCAR (x
, env
);
3473 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
3474 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance
) [slot
]));
3478 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
3481 SCM instance
= EVALCAR (x
, env
);
3482 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
3483 SCM value
= EVALCAR (SCM_CDDR (x
), env
);
3484 SCM_STRUCT_DATA (instance
) [slot
] = SCM_UNPACK (value
);
3485 RETURN (SCM_UNSPECIFIED
);
3489 #if SCM_ENABLE_ELISP
3491 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
3493 SCM test_form
= SCM_CDR (x
);
3494 x
= SCM_CDR (test_form
);
3495 while (!SCM_NULL_OR_NIL_P (x
))
3497 SCM test_result
= EVALCAR (test_form
, env
);
3498 if (!(SCM_FALSEP (test_result
)
3499 || SCM_NULL_OR_NIL_P (test_result
)))
3501 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
3502 RETURN (test_result
);
3503 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3508 test_form
= SCM_CDR (x
);
3509 x
= SCM_CDR (test_form
);
3513 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3517 #endif /* SCM_ENABLE_ELISP */
3519 case (SCM_ISYMNUM (SCM_IM_BIND
)):
3521 SCM vars
, exps
, vals
;
3524 vars
= SCM_CAAR (x
);
3525 exps
= SCM_CDAR (x
);
3527 while (!SCM_NULLP (exps
))
3529 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
3530 exps
= SCM_CDR (exps
);
3533 scm_swap_bindings (vars
, vals
);
3534 scm_dynwinds
= scm_acons (vars
, vals
, scm_dynwinds
);
3536 /* Ignore all but the last evaluation result. */
3537 for (x
= SCM_CDR (x
); !SCM_NULLP (SCM_CDR (x
)); x
= SCM_CDR (x
))
3539 if (SCM_CONSP (SCM_CAR (x
)))
3540 SCM_CEVAL (SCM_CAR (x
), env
);
3542 proc
= EVALCAR (x
, env
);
3544 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
3545 scm_swap_bindings (vars
, vals
);
3551 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
3556 producer
= EVALCAR (x
, env
);
3558 proc
= EVALCAR (x
, env
); /* proc is the consumer. */
3559 arg1
= SCM_APPLY (producer
, SCM_EOL
, SCM_EOL
);
3560 if (SCM_VALUESP (arg1
))
3562 /* The list of arguments is not copied. Rather, it is assumed
3563 * that this has been done by the 'values' procedure. */
3564 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
3568 arg1
= scm_list_1 (arg1
);
3570 PREP_APPLY (proc
, arg1
);
3585 case scm_tc7_vector
:
3589 case scm_tc7_byvect
:
3596 #if SCM_SIZEOF_LONG_LONG != 0
3597 case scm_tc7_llvect
:
3600 case scm_tc7_number
:
3601 case scm_tc7_string
:
3603 case scm_tcs_closures
:
3607 case scm_tcs_struct
:
3610 case scm_tc7_symbol
:
3611 /* Only happens when called at top level. */
3612 x
= scm_cons (x
, SCM_UNDEFINED
);
3613 RETURN (*scm_lookupcar (x
, env
, 1));
3615 case scm_tc7_variable
:
3616 RETURN (SCM_VARIABLE_REF(x
));
3618 case SCM_BIT7 (SCM_ILOC00
):
3619 proc
= *scm_ilookup (SCM_CAR (x
), env
);
3622 case scm_tcs_cons_nimcar
:
3623 if (SCM_SYMBOLP (SCM_CAR (x
)))
3625 SCM orig_sym
= SCM_CAR (x
);
3627 SCM
*location
= scm_lookupcar1 (x
, env
, 1);
3628 if (location
== NULL
)
3630 /* we have lost the race, start again. */
3636 if (SCM_MACROP (proc
))
3638 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
3640 handle_a_macro
: /* inputs: x, env, proc */
3642 /* Set a flag during macro expansion so that macro
3643 application frames can be deleted from the backtrace. */
3644 SCM_SET_MACROEXP (debug
);
3646 arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
3647 scm_cons (env
, scm_listofnull
));
3649 SCM_CLEAR_MACROEXP (debug
);
3651 switch (SCM_MACRO_TYPE (proc
))
3655 if (scm_ilength (arg1
) <= 0)
3656 arg1
= scm_list_2 (SCM_IM_BEGIN
, arg1
);
3658 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
3661 SCM_SETCAR (x
, SCM_CAR (arg1
));
3662 SCM_SETCDR (x
, SCM_CDR (arg1
));
3666 /* Prevent memoizing of debug info expression. */
3667 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
3672 SCM_SETCAR (x
, SCM_CAR (arg1
));
3673 SCM_SETCDR (x
, SCM_CDR (arg1
));
3675 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3677 #if SCM_ENABLE_DEPRECATED == 1
3682 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3694 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
3697 if (SCM_MACROP (proc
))
3698 goto handle_a_macro
;
3702 evapply
: /* inputs: x, proc */
3703 PREP_APPLY (proc
, SCM_EOL
);
3704 if (SCM_NULLP (SCM_CDR (x
))) {
3707 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3708 switch (SCM_TYP7 (proc
))
3709 { /* no arguments given */
3710 case scm_tc7_subr_0
:
3711 RETURN (SCM_SUBRF (proc
) ());
3712 case scm_tc7_subr_1o
:
3713 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
3715 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
3716 case scm_tc7_rpsubr
:
3717 RETURN (SCM_BOOL_T
);
3719 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
3721 if (!SCM_SMOB_APPLICABLE_P (proc
))
3723 RETURN (SCM_SMOB_APPLY_0 (proc
));
3726 proc
= SCM_CCLO_SUBR (proc
);
3728 debug
.info
->a
.proc
= proc
;
3729 debug
.info
->a
.args
= scm_list_1 (arg1
);
3733 proc
= SCM_PROCEDURE (proc
);
3735 debug
.info
->a
.proc
= proc
;
3737 if (!SCM_CLOSUREP (proc
))
3740 case scm_tcs_closures
:
3742 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3743 if (SCM_CONSP (formals
))
3744 goto umwrongnumargs
;
3745 x
= SCM_CLOSURE_BODY (proc
);
3746 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
3747 goto nontoplevel_begin
;
3749 case scm_tcs_struct
:
3750 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3752 x
= SCM_ENTITY_PROCEDURE (proc
);
3756 else if (SCM_I_OPERATORP (proc
))
3759 proc
= (SCM_I_ENTITYP (proc
)
3760 ? SCM_ENTITY_PROCEDURE (proc
)
3761 : SCM_OPERATOR_PROCEDURE (proc
));
3763 debug
.info
->a
.proc
= proc
;
3764 debug
.info
->a
.args
= scm_list_1 (arg1
);
3770 case scm_tc7_subr_1
:
3771 case scm_tc7_subr_2
:
3772 case scm_tc7_subr_2o
:
3775 case scm_tc7_subr_3
:
3776 case scm_tc7_lsubr_2
:
3779 scm_wrong_num_args (proc
);
3782 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
3786 /* must handle macros by here */
3789 arg1
= EVALCAR (x
, env
);
3791 scm_wrong_num_args (proc
);
3793 debug
.info
->a
.args
= scm_list_1 (arg1
);
3801 evap1
: /* inputs: proc, arg1 */
3802 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3803 switch (SCM_TYP7 (proc
))
3804 { /* have one argument in arg1 */
3805 case scm_tc7_subr_2o
:
3806 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3807 case scm_tc7_subr_1
:
3808 case scm_tc7_subr_1o
:
3809 RETURN (SCM_SUBRF (proc
) (arg1
));
3811 if (SCM_INUMP (arg1
))
3813 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3815 else if (SCM_REALP (arg1
))
3817 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3819 else if (SCM_BIGP (arg1
))
3821 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3823 else if (SCM_FRACTIONP (arg1
))
3825 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
3827 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3828 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3831 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
3834 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
3835 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3836 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3841 case scm_tc7_rpsubr
:
3842 RETURN (SCM_BOOL_T
);
3844 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3847 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3849 RETURN (SCM_SUBRF (proc
) (scm_list_1 (arg1
)));
3852 if (!SCM_SMOB_APPLICABLE_P (proc
))
3854 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
3858 proc
= SCM_CCLO_SUBR (proc
);
3860 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
3861 debug
.info
->a
.proc
= proc
;
3865 proc
= SCM_PROCEDURE (proc
);
3867 debug
.info
->a
.proc
= proc
;
3869 if (!SCM_CLOSUREP (proc
))
3872 case scm_tcs_closures
:
3875 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3876 if (SCM_NULLP (formals
)
3877 || (SCM_CONSP (formals
) && SCM_CONSP (SCM_CDR (formals
))))
3878 goto umwrongnumargs
;
3879 x
= SCM_CLOSURE_BODY (proc
);
3881 env
= SCM_EXTEND_ENV (formals
,
3885 env
= SCM_EXTEND_ENV (formals
,
3889 goto nontoplevel_begin
;
3891 case scm_tcs_struct
:
3892 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3894 x
= SCM_ENTITY_PROCEDURE (proc
);
3896 arg1
= debug
.info
->a
.args
;
3898 arg1
= scm_list_1 (arg1
);
3902 else if (SCM_I_OPERATORP (proc
))
3906 proc
= (SCM_I_ENTITYP (proc
)
3907 ? SCM_ENTITY_PROCEDURE (proc
)
3908 : SCM_OPERATOR_PROCEDURE (proc
));
3910 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
3911 debug
.info
->a
.proc
= proc
;
3917 case scm_tc7_subr_2
:
3918 case scm_tc7_subr_0
:
3919 case scm_tc7_subr_3
:
3920 case scm_tc7_lsubr_2
:
3921 scm_wrong_num_args (proc
);
3927 arg2
= EVALCAR (x
, env
);
3929 scm_wrong_num_args (proc
);
3931 { /* have two or more arguments */
3933 debug
.info
->a
.args
= scm_list_2 (arg1
, arg2
);
3936 if (SCM_NULLP (x
)) {
3939 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3940 switch (SCM_TYP7 (proc
))
3941 { /* have two arguments */
3942 case scm_tc7_subr_2
:
3943 case scm_tc7_subr_2o
:
3944 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3947 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3949 RETURN (SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
)));
3951 case scm_tc7_lsubr_2
:
3952 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
));
3953 case scm_tc7_rpsubr
:
3955 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3957 if (!SCM_SMOB_APPLICABLE_P (proc
))
3959 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
));
3963 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3964 scm_cons (proc
, debug
.info
->a
.args
),
3967 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3968 scm_cons2 (proc
, arg1
,
3975 case scm_tcs_struct
:
3976 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3978 x
= SCM_ENTITY_PROCEDURE (proc
);
3980 arg1
= debug
.info
->a
.args
;
3982 arg1
= scm_list_2 (arg1
, arg2
);
3986 else if (SCM_I_OPERATORP (proc
))
3990 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3991 ? SCM_ENTITY_PROCEDURE (proc
)
3992 : SCM_OPERATOR_PROCEDURE (proc
),
3993 scm_cons (proc
, debug
.info
->a
.args
),
3996 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3997 ? SCM_ENTITY_PROCEDURE (proc
)
3998 : SCM_OPERATOR_PROCEDURE (proc
),
3999 scm_cons2 (proc
, arg1
,
4009 case scm_tc7_subr_0
:
4012 case scm_tc7_subr_1o
:
4013 case scm_tc7_subr_1
:
4014 case scm_tc7_subr_3
:
4015 scm_wrong_num_args (proc
);
4019 proc
= SCM_PROCEDURE (proc
);
4021 debug
.info
->a
.proc
= proc
;
4023 if (!SCM_CLOSUREP (proc
))
4026 case scm_tcs_closures
:
4029 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4030 if (SCM_NULLP (formals
)
4031 || (SCM_CONSP (formals
)
4032 && (SCM_NULLP (SCM_CDR (formals
))
4033 || (SCM_CONSP (SCM_CDR (formals
))
4034 && SCM_CONSP (SCM_CDDR (formals
))))))
4035 goto umwrongnumargs
;
4037 env
= SCM_EXTEND_ENV (formals
,
4041 env
= SCM_EXTEND_ENV (formals
,
4042 scm_list_2 (arg1
, arg2
),
4045 x
= SCM_CLOSURE_BODY (proc
);
4046 goto nontoplevel_begin
;
4051 scm_wrong_num_args (proc
);
4053 debug
.info
->a
.args
= scm_cons2 (arg1
, arg2
,
4054 deval_args (x
, env
, proc
,
4055 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
4059 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4060 switch (SCM_TYP7 (proc
))
4061 { /* have 3 or more arguments */
4063 case scm_tc7_subr_3
:
4064 if (!SCM_NULLP (SCM_CDR (x
)))
4065 scm_wrong_num_args (proc
);
4067 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4068 SCM_CADDR (debug
.info
->a
.args
)));
4070 arg1
= SCM_SUBRF(proc
)(arg1
, arg2
);
4071 arg2
= SCM_CDDR (debug
.info
->a
.args
);
4074 arg1
= SCM_SUBRF(proc
)(arg1
, SCM_CAR (arg2
));
4075 arg2
= SCM_CDR (arg2
);
4077 while (SCM_NIMP (arg2
));
4079 case scm_tc7_rpsubr
:
4080 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
4081 RETURN (SCM_BOOL_F
);
4082 arg1
= SCM_CDDR (debug
.info
->a
.args
);
4085 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (arg1
))))
4086 RETURN (SCM_BOOL_F
);
4087 arg2
= SCM_CAR (arg1
);
4088 arg1
= SCM_CDR (arg1
);
4090 while (SCM_NIMP (arg1
));
4091 RETURN (SCM_BOOL_T
);
4092 case scm_tc7_lsubr_2
:
4093 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4094 SCM_CDDR (debug
.info
->a
.args
)));
4096 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4098 if (!SCM_SMOB_APPLICABLE_P (proc
))
4100 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4101 SCM_CDDR (debug
.info
->a
.args
)));
4105 proc
= SCM_PROCEDURE (proc
);
4106 debug
.info
->a
.proc
= proc
;
4107 if (!SCM_CLOSUREP (proc
))
4110 case scm_tcs_closures
:
4112 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4113 if (SCM_NULLP (formals
)
4114 || (SCM_CONSP (formals
)
4115 && (SCM_NULLP (SCM_CDR (formals
))
4116 || (SCM_CONSP (SCM_CDR (formals
))
4117 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4118 goto umwrongnumargs
;
4119 SCM_SET_ARGSREADY (debug
);
4120 env
= SCM_EXTEND_ENV (formals
,
4123 x
= SCM_CLOSURE_BODY (proc
);
4124 goto nontoplevel_begin
;
4127 case scm_tc7_subr_3
:
4128 if (!SCM_NULLP (SCM_CDR (x
)))
4129 scm_wrong_num_args (proc
);
4131 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, EVALCAR (x
, env
)));
4133 arg1
= SCM_SUBRF (proc
) (arg1
, arg2
);
4136 arg1
= SCM_SUBRF(proc
)(arg1
, EVALCAR(x
, env
));
4139 while (!SCM_NULLP (x
));
4141 case scm_tc7_rpsubr
:
4142 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
4143 RETURN (SCM_BOOL_F
);
4146 arg1
= EVALCAR (x
, env
);
4147 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, arg1
)))
4148 RETURN (SCM_BOOL_F
);
4152 while (!SCM_NULLP (x
));
4153 RETURN (SCM_BOOL_T
);
4154 case scm_tc7_lsubr_2
:
4155 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
4157 RETURN (SCM_SUBRF (proc
) (scm_cons2 (arg1
,
4159 scm_eval_args (x
, env
, proc
))));
4161 if (!SCM_SMOB_APPLICABLE_P (proc
))
4163 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4164 scm_eval_args (x
, env
, proc
)));
4168 proc
= SCM_PROCEDURE (proc
);
4169 if (!SCM_CLOSUREP (proc
))
4172 case scm_tcs_closures
:
4174 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4175 if (SCM_NULLP (formals
)
4176 || (SCM_CONSP (formals
)
4177 && (SCM_NULLP (SCM_CDR (formals
))
4178 || (SCM_CONSP (SCM_CDR (formals
))
4179 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4180 goto umwrongnumargs
;
4181 env
= SCM_EXTEND_ENV (formals
,
4184 scm_eval_args (x
, env
, proc
)),
4186 x
= SCM_CLOSURE_BODY (proc
);
4187 goto nontoplevel_begin
;
4190 case scm_tcs_struct
:
4191 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4194 arg1
= debug
.info
->a
.args
;
4196 arg1
= scm_cons2 (arg1
, arg2
, scm_eval_args (x
, env
, proc
));
4198 x
= SCM_ENTITY_PROCEDURE (proc
);
4201 else if (SCM_I_OPERATORP (proc
))
4205 case scm_tc7_subr_2
:
4206 case scm_tc7_subr_1o
:
4207 case scm_tc7_subr_2o
:
4208 case scm_tc7_subr_0
:
4211 case scm_tc7_subr_1
:
4212 scm_wrong_num_args (proc
);
4220 if (scm_check_exit_p
&& SCM_TRAPS_P
)
4221 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
4223 SCM_CLEAR_TRACED_FRAME (debug
);
4224 if (SCM_CHEAPTRAPS_P
)
4225 arg1
= scm_make_debugobj (&debug
);
4229 SCM val
= scm_make_continuation (&first
);
4240 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
4244 scm_last_debug_frame
= debug
.prev
;
4250 /* SECTION: This code is compiled once.
4257 /* Simple procedure calls
4261 scm_call_0 (SCM proc
)
4263 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
4267 scm_call_1 (SCM proc
, SCM arg1
)
4269 return scm_apply (proc
, arg1
, scm_listofnull
);
4273 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
4275 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
4279 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
4281 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
4285 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
4287 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
4288 scm_cons (arg4
, scm_listofnull
)));
4291 /* Simple procedure applies
4295 scm_apply_0 (SCM proc
, SCM args
)
4297 return scm_apply (proc
, args
, SCM_EOL
);
4301 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
4303 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
4307 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
4309 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
4313 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
4315 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
4319 /* This code processes the arguments to apply:
4321 (apply PROC ARG1 ... ARGS)
4323 Given a list (ARG1 ... ARGS), this function conses the ARG1
4324 ... arguments onto the front of ARGS, and returns the resulting
4325 list. Note that ARGS is a list; thus, the argument to this
4326 function is a list whose last element is a list.
4328 Apply calls this function, and applies PROC to the elements of the
4329 result. apply:nconc2last takes care of building the list of
4330 arguments, given (ARG1 ... ARGS).
4332 Rather than do new consing, apply:nconc2last destroys its argument.
4333 On that topic, this code came into my care with the following
4334 beautifully cryptic comment on that topic: "This will only screw
4335 you if you do (scm_apply scm_apply '( ... ))" If you know what
4336 they're referring to, send me a patch to this comment. */
4338 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
4340 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
4341 "conses the @var{arg1} @dots{} arguments onto the front of\n"
4342 "@var{args}, and returns the resulting list. Note that\n"
4343 "@var{args} is a list; thus, the argument to this function is\n"
4344 "a list whose last element is a list.\n"
4345 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
4346 "destroys its argument, so use with care.")
4347 #define FUNC_NAME s_scm_nconc2last
4350 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
4352 while (!SCM_NULLP (SCM_CDR (*lloc
))) /* Perhaps should be
4353 SCM_NULL_OR_NIL_P, but not
4354 needed in 99.99% of cases,
4355 and it could seriously hurt
4356 performance. - Neil */
4357 lloc
= SCM_CDRLOC (*lloc
);
4358 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
4359 *lloc
= SCM_CAR (*lloc
);
4367 /* SECTION: When DEVAL is defined this code yields scm_dapply.
4368 * It is compiled twice.
4373 scm_apply (SCM proc
, SCM arg1
, SCM args
)
4379 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
4384 /* Apply a function to a list of arguments.
4386 This function is exported to the Scheme level as taking two
4387 required arguments and a tail argument, as if it were:
4388 (lambda (proc arg1 . args) ...)
4389 Thus, if you just have a list of arguments to pass to a procedure,
4390 pass the list as ARG1, and '() for ARGS. If you have some fixed
4391 args, pass the first as ARG1, then cons any remaining fixed args
4392 onto the front of your argument list, and pass that as ARGS. */
4395 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
4398 scm_t_debug_frame debug
;
4399 scm_t_debug_info debug_vect_body
;
4400 debug
.prev
= scm_last_debug_frame
;
4401 debug
.status
= SCM_APPLYFRAME
;
4402 debug
.vect
= &debug_vect_body
;
4403 debug
.vect
[0].a
.proc
= proc
;
4404 debug
.vect
[0].a
.args
= SCM_EOL
;
4405 scm_last_debug_frame
= &debug
;
4408 return scm_dapply (proc
, arg1
, args
);
4411 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
4413 /* If ARGS is the empty list, then we're calling apply with only two
4414 arguments --- ARG1 is the list of arguments for PROC. Whatever
4415 the case, futz with things so that ARG1 is the first argument to
4416 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
4419 Setting the debug apply frame args this way is pretty messy.
4420 Perhaps we should store arg1 and args directly in the frame as
4421 received, and let scm_frame_arguments unpack them, because that's
4422 a relatively rare operation. This works for now; if the Guile
4423 developer archives are still around, see Mikael's post of
4425 if (SCM_NULLP (args
))
4427 if (SCM_NULLP (arg1
))
4429 arg1
= SCM_UNDEFINED
;
4431 debug
.vect
[0].a
.args
= SCM_EOL
;
4437 debug
.vect
[0].a
.args
= arg1
;
4439 args
= SCM_CDR (arg1
);
4440 arg1
= SCM_CAR (arg1
);
4445 args
= scm_nconc2last (args
);
4447 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4451 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
4454 if (SCM_CHEAPTRAPS_P
)
4455 tmp
= scm_make_debugobj (&debug
);
4460 tmp
= scm_make_continuation (&first
);
4465 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
4472 switch (SCM_TYP7 (proc
))
4474 case scm_tc7_subr_2o
:
4475 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
4476 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4477 case scm_tc7_subr_2
:
4478 if (SCM_NULLP (args
) || !SCM_NULLP (SCM_CDR (args
)))
4479 scm_wrong_num_args (proc
);
4480 args
= SCM_CAR (args
);
4481 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4482 case scm_tc7_subr_0
:
4483 if (!SCM_UNBNDP (arg1
))
4484 scm_wrong_num_args (proc
);
4486 RETURN (SCM_SUBRF (proc
) ());
4487 case scm_tc7_subr_1
:
4488 if (SCM_UNBNDP (arg1
))
4489 scm_wrong_num_args (proc
);
4490 case scm_tc7_subr_1o
:
4491 if (!SCM_NULLP (args
))
4492 scm_wrong_num_args (proc
);
4494 RETURN (SCM_SUBRF (proc
) (arg1
));
4496 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
4497 scm_wrong_num_args (proc
);
4498 if (SCM_INUMP (arg1
))
4500 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
4502 else if (SCM_REALP (arg1
))
4504 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4506 else if (SCM_BIGP (arg1
))
4508 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4510 else if (SCM_FRACTIONP (arg1
))
4512 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4514 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4515 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4517 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
4518 scm_wrong_num_args (proc
);
4520 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
4523 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
4524 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4525 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
4530 case scm_tc7_subr_3
:
4531 if (SCM_NULLP (args
)
4532 || SCM_NULLP (SCM_CDR (args
))
4533 || !SCM_NULLP (SCM_CDDR (args
)))
4534 scm_wrong_num_args (proc
);
4536 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
4539 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
4541 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
4543 case scm_tc7_lsubr_2
:
4544 if (!SCM_CONSP (args
))
4545 scm_wrong_num_args (proc
);
4547 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4549 if (SCM_NULLP (args
))
4550 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4551 while (SCM_NIMP (args
))
4553 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
4554 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
4555 args
= SCM_CDR (args
);
4558 case scm_tc7_rpsubr
:
4559 if (SCM_NULLP (args
))
4560 RETURN (SCM_BOOL_T
);
4561 while (SCM_NIMP (args
))
4563 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
4564 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
4565 RETURN (SCM_BOOL_F
);
4566 arg1
= SCM_CAR (args
);
4567 args
= SCM_CDR (args
);
4569 RETURN (SCM_BOOL_T
);
4570 case scm_tcs_closures
:
4572 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4574 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4576 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
4577 scm_wrong_num_args (proc
);
4579 /* Copy argument list */
4584 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
4585 for (arg1
= SCM_CDR (arg1
); SCM_CONSP (arg1
); arg1
= SCM_CDR (arg1
))
4587 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
));
4590 SCM_SETCDR (tl
, arg1
);
4593 args
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4596 proc
= SCM_CLOSURE_BODY (proc
);
4598 arg1
= SCM_CDR (proc
);
4599 while (!SCM_NULLP (arg1
))
4601 if (SCM_IMP (SCM_CAR (proc
)))
4603 if (SCM_ISYMP (SCM_CAR (proc
)))
4605 scm_rec_mutex_lock (&source_mutex
);
4606 /* check for race condition */
4607 if (SCM_ISYMP (SCM_CAR (proc
)))
4608 m_expand_body (proc
, args
);
4609 scm_rec_mutex_unlock (&source_mutex
);
4613 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
4616 SCM_CEVAL (SCM_CAR (proc
), args
);
4618 arg1
= SCM_CDR (proc
);
4620 RETURN (EVALCAR (proc
, args
));
4622 if (!SCM_SMOB_APPLICABLE_P (proc
))
4624 if (SCM_UNBNDP (arg1
))
4625 RETURN (SCM_SMOB_APPLY_0 (proc
));
4626 else if (SCM_NULLP (args
))
4627 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
4628 else if (SCM_NULLP (SCM_CDR (args
)))
4629 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
4631 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4634 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4636 proc
= SCM_CCLO_SUBR (proc
);
4637 debug
.vect
[0].a
.proc
= proc
;
4638 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4640 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4642 proc
= SCM_CCLO_SUBR (proc
);
4646 proc
= SCM_PROCEDURE (proc
);
4648 debug
.vect
[0].a
.proc
= proc
;
4651 case scm_tcs_struct
:
4652 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4655 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4657 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4659 RETURN (scm_apply_generic (proc
, args
));
4661 else if (SCM_I_OPERATORP (proc
))
4665 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4667 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4670 proc
= (SCM_I_ENTITYP (proc
)
4671 ? SCM_ENTITY_PROCEDURE (proc
)
4672 : SCM_OPERATOR_PROCEDURE (proc
));
4674 debug
.vect
[0].a
.proc
= proc
;
4675 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4677 if (SCM_NIMP (proc
))
4686 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
4690 if (scm_check_exit_p
&& SCM_TRAPS_P
)
4691 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
4693 SCM_CLEAR_TRACED_FRAME (debug
);
4694 if (SCM_CHEAPTRAPS_P
)
4695 arg1
= scm_make_debugobj (&debug
);
4699 SCM val
= scm_make_continuation (&first
);
4710 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
4714 scm_last_debug_frame
= debug
.prev
;
4720 /* SECTION: The rest of this file is only read once.
4727 * Trampolines make it possible to move procedure application dispatch
4728 * outside inner loops. The motivation was clean implementation of
4729 * efficient replacements of R5RS primitives in SRFI-1.
4731 * The semantics is clear: scm_trampoline_N returns an optimized
4732 * version of scm_call_N (or NULL if the procedure isn't applicable
4735 * Applying the optimization to map and for-each increased efficiency
4736 * noticeably. For example, (map abs ls) is now 8 times faster than
4741 call_subr0_0 (SCM proc
)
4743 return SCM_SUBRF (proc
) ();
4747 call_subr1o_0 (SCM proc
)
4749 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
4753 call_lsubr_0 (SCM proc
)
4755 return SCM_SUBRF (proc
) (SCM_EOL
);
4759 scm_i_call_closure_0 (SCM proc
)
4761 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4764 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
4769 scm_trampoline_0 (SCM proc
)
4771 scm_t_trampoline_0 trampoline
;
4776 switch (SCM_TYP7 (proc
))
4778 case scm_tc7_subr_0
:
4779 trampoline
= call_subr0_0
;
4781 case scm_tc7_subr_1o
:
4782 trampoline
= call_subr1o_0
;
4785 trampoline
= call_lsubr_0
;
4787 case scm_tcs_closures
:
4789 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4790 if (SCM_NULLP (formals
) || !SCM_CONSP (formals
))
4791 trampoline
= scm_i_call_closure_0
;
4796 case scm_tcs_struct
:
4797 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4798 trampoline
= scm_call_generic_0
;
4799 else if (SCM_I_OPERATORP (proc
))
4800 trampoline
= scm_call_0
;
4805 if (SCM_SMOB_APPLICABLE_P (proc
))
4806 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
4811 case scm_tc7_rpsubr
:
4814 trampoline
= scm_call_0
;
4817 return NULL
; /* not applicable on zero arguments */
4819 /* We only reach this point if a valid trampoline was determined. */
4821 /* If debugging is enabled, we want to see all calls to proc on the stack.
4822 * Thus, we replace the trampoline shortcut with scm_call_0. */
4830 call_subr1_1 (SCM proc
, SCM arg1
)
4832 return SCM_SUBRF (proc
) (arg1
);
4836 call_subr2o_1 (SCM proc
, SCM arg1
)
4838 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
4842 call_lsubr_1 (SCM proc
, SCM arg1
)
4844 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
4848 call_dsubr_1 (SCM proc
, SCM arg1
)
4850 if (SCM_INUMP (arg1
))
4852 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
4854 else if (SCM_REALP (arg1
))
4856 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4858 else if (SCM_BIGP (arg1
))
4860 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4862 else if (SCM_FRACTIONP (arg1
))
4864 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4866 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4867 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4871 call_cxr_1 (SCM proc
, SCM arg1
)
4873 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
4876 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
4877 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4878 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
4885 call_closure_1 (SCM proc
, SCM arg1
)
4887 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4890 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
4895 scm_trampoline_1 (SCM proc
)
4897 scm_t_trampoline_1 trampoline
;
4902 switch (SCM_TYP7 (proc
))
4904 case scm_tc7_subr_1
:
4905 case scm_tc7_subr_1o
:
4906 trampoline
= call_subr1_1
;
4908 case scm_tc7_subr_2o
:
4909 trampoline
= call_subr2o_1
;
4912 trampoline
= call_lsubr_1
;
4915 trampoline
= call_dsubr_1
;
4918 trampoline
= call_cxr_1
;
4920 case scm_tcs_closures
:
4922 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4923 if (!SCM_NULLP (formals
)
4924 && (!SCM_CONSP (formals
) || !SCM_CONSP (SCM_CDR (formals
))))
4925 trampoline
= call_closure_1
;
4930 case scm_tcs_struct
:
4931 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4932 trampoline
= scm_call_generic_1
;
4933 else if (SCM_I_OPERATORP (proc
))
4934 trampoline
= scm_call_1
;
4939 if (SCM_SMOB_APPLICABLE_P (proc
))
4940 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
4945 case scm_tc7_rpsubr
:
4948 trampoline
= scm_call_1
;
4951 return NULL
; /* not applicable on one arg */
4953 /* We only reach this point if a valid trampoline was determined. */
4955 /* If debugging is enabled, we want to see all calls to proc on the stack.
4956 * Thus, we replace the trampoline shortcut with scm_call_1. */
4964 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
4966 return SCM_SUBRF (proc
) (arg1
, arg2
);
4970 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
4972 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
4976 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
4978 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
4982 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
4984 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4985 scm_list_2 (arg1
, arg2
),
4987 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
4992 scm_trampoline_2 (SCM proc
)
4994 scm_t_trampoline_2 trampoline
;
4999 switch (SCM_TYP7 (proc
))
5001 case scm_tc7_subr_2
:
5002 case scm_tc7_subr_2o
:
5003 case scm_tc7_rpsubr
:
5005 trampoline
= call_subr2_2
;
5007 case scm_tc7_lsubr_2
:
5008 trampoline
= call_lsubr2_2
;
5011 trampoline
= call_lsubr_2
;
5013 case scm_tcs_closures
:
5015 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5016 if (!SCM_NULLP (formals
)
5017 && (!SCM_CONSP (formals
)
5018 || (!SCM_NULLP (SCM_CDR (formals
))
5019 && (!SCM_CONSP (SCM_CDR (formals
))
5020 || !SCM_CONSP (SCM_CDDR (formals
))))))
5021 trampoline
= call_closure_2
;
5026 case scm_tcs_struct
:
5027 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5028 trampoline
= scm_call_generic_2
;
5029 else if (SCM_I_OPERATORP (proc
))
5030 trampoline
= scm_call_2
;
5035 if (SCM_SMOB_APPLICABLE_P (proc
))
5036 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
5042 trampoline
= scm_call_2
;
5045 return NULL
; /* not applicable on two args */
5047 /* We only reach this point if a valid trampoline was determined. */
5049 /* If debugging is enabled, we want to see all calls to proc on the stack.
5050 * Thus, we replace the trampoline shortcut with scm_call_2. */
5057 /* Typechecking for multi-argument MAP and FOR-EACH.
5059 Verify that each element of the vector ARGV, except for the first,
5060 is a proper list whose length is LEN. Attribute errors to WHO,
5061 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
5063 check_map_args (SCM argv
,
5070 SCM
const *ve
= SCM_VELTS (argv
);
5073 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
5075 long elt_len
= scm_ilength (ve
[i
]);
5080 scm_apply_generic (gf
, scm_cons (proc
, args
));
5082 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
5086 scm_out_of_range_pos (who
, ve
[i
], SCM_MAKINUM (i
+ 2));
5089 scm_remember_upto_here_1 (argv
);
5093 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
5095 /* Note: Currently, scm_map applies PROC to the argument list(s)
5096 sequentially, starting with the first element(s). This is used in
5097 evalext.c where the Scheme procedure `map-in-order', which guarantees
5098 sequential behaviour, is implemented using scm_map. If the
5099 behaviour changes, we need to update `map-in-order'.
5103 scm_map (SCM proc
, SCM arg1
, SCM args
)
5104 #define FUNC_NAME s_map
5109 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
5111 len
= scm_ilength (arg1
);
5112 SCM_GASSERTn (len
>= 0,
5113 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
5114 SCM_VALIDATE_REST_ARGUMENT (args
);
5115 if (SCM_NULLP (args
))
5117 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5118 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
5119 while (SCM_NIMP (arg1
))
5121 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
5122 pres
= SCM_CDRLOC (*pres
);
5123 arg1
= SCM_CDR (arg1
);
5127 if (SCM_NULLP (SCM_CDR (args
)))
5129 SCM arg2
= SCM_CAR (args
);
5130 int len2
= scm_ilength (arg2
);
5131 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5133 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
5134 SCM_GASSERTn (len2
>= 0,
5135 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
5137 SCM_OUT_OF_RANGE (3, arg2
);
5138 while (SCM_NIMP (arg1
))
5140 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
5141 pres
= SCM_CDRLOC (*pres
);
5142 arg1
= SCM_CDR (arg1
);
5143 arg2
= SCM_CDR (arg2
);
5147 arg1
= scm_cons (arg1
, args
);
5148 args
= scm_vector (arg1
);
5149 ve
= SCM_VELTS (args
);
5150 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
5154 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5156 if (SCM_IMP (ve
[i
]))
5158 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
5159 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
5161 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
5162 pres
= SCM_CDRLOC (*pres
);
5168 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
5171 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
5172 #define FUNC_NAME s_for_each
5174 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
5176 len
= scm_ilength (arg1
);
5177 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
5178 SCM_ARG2
, s_for_each
);
5179 SCM_VALIDATE_REST_ARGUMENT (args
);
5180 if (SCM_NULLP (args
))
5182 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5183 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
5184 while (SCM_NIMP (arg1
))
5186 call (proc
, SCM_CAR (arg1
));
5187 arg1
= SCM_CDR (arg1
);
5189 return SCM_UNSPECIFIED
;
5191 if (SCM_NULLP (SCM_CDR (args
)))
5193 SCM arg2
= SCM_CAR (args
);
5194 int len2
= scm_ilength (arg2
);
5195 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5196 SCM_GASSERTn (call
, g_for_each
,
5197 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
5198 SCM_GASSERTn (len2
>= 0, g_for_each
,
5199 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
5201 SCM_OUT_OF_RANGE (3, arg2
);
5202 while (SCM_NIMP (arg1
))
5204 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
5205 arg1
= SCM_CDR (arg1
);
5206 arg2
= SCM_CDR (arg2
);
5208 return SCM_UNSPECIFIED
;
5210 arg1
= scm_cons (arg1
, args
);
5211 args
= scm_vector (arg1
);
5212 ve
= SCM_VELTS (args
);
5213 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
5217 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5219 if (SCM_IMP (ve
[i
]))
5220 return SCM_UNSPECIFIED
;
5221 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
5222 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
5224 scm_apply (proc
, arg1
, SCM_EOL
);
5231 scm_closure (SCM code
, SCM env
)
5234 SCM closcar
= scm_cons (code
, SCM_EOL
);
5235 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
5236 scm_remember_upto_here (closcar
);
5241 scm_t_bits scm_tc16_promise
;
5244 scm_makprom (SCM code
)
5246 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
5248 scm_make_rec_mutex ());
5252 promise_free (SCM promise
)
5254 scm_rec_mutex_free (SCM_PROMISE_MUTEX (promise
));
5259 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
5261 int writingp
= SCM_WRITINGP (pstate
);
5262 scm_puts ("#<promise ", port
);
5263 SCM_SET_WRITINGP (pstate
, 1);
5264 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
5265 SCM_SET_WRITINGP (pstate
, writingp
);
5266 scm_putc ('>', port
);
5270 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
5272 "If the promise @var{x} has not been computed yet, compute and\n"
5273 "return @var{x}, otherwise just return the previously computed\n"
5275 #define FUNC_NAME s_scm_force
5277 SCM_VALIDATE_SMOB (1, promise
, promise
);
5278 scm_rec_mutex_lock (SCM_PROMISE_MUTEX (promise
));
5279 if (!SCM_PROMISE_COMPUTED_P (promise
))
5281 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
5282 if (!SCM_PROMISE_COMPUTED_P (promise
))
5284 SCM_SET_PROMISE_DATA (promise
, ans
);
5285 SCM_SET_PROMISE_COMPUTED (promise
);
5288 scm_rec_mutex_unlock (SCM_PROMISE_MUTEX (promise
));
5289 return SCM_PROMISE_DATA (promise
);
5294 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
5296 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
5297 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
5298 #define FUNC_NAME s_scm_promise_p
5300 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
5305 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
5306 (SCM xorig
, SCM x
, SCM y
),
5307 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
5308 "Any source properties associated with @var{xorig} are also associated\n"
5309 "with the new pair.")
5310 #define FUNC_NAME s_scm_cons_source
5313 z
= scm_cons (x
, y
);
5314 /* Copy source properties possibly associated with xorig. */
5315 p
= scm_whash_lookup (scm_source_whash
, xorig
);
5317 scm_whash_insert (scm_source_whash
, z
, p
);
5323 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
5325 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
5326 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
5327 "contents of both pairs and vectors (since both cons cells and vector\n"
5328 "cells may point to arbitrary objects), and stops recursing when it hits\n"
5329 "any other object.")
5330 #define FUNC_NAME s_scm_copy_tree
5335 if (SCM_VECTORP (obj
))
5337 unsigned long i
= SCM_VECTOR_LENGTH (obj
);
5338 ans
= scm_c_make_vector (i
, SCM_UNSPECIFIED
);
5340 SCM_VECTOR_SET (ans
, i
, scm_copy_tree (SCM_VELTS (obj
)[i
]));
5343 if (!SCM_CONSP (obj
))
5345 ans
= tl
= scm_cons_source (obj
,
5346 scm_copy_tree (SCM_CAR (obj
)),
5348 for (obj
= SCM_CDR (obj
); SCM_CONSP (obj
); obj
= SCM_CDR (obj
))
5350 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
5354 SCM_SETCDR (tl
, obj
);
5360 /* We have three levels of EVAL here:
5362 - scm_i_eval (exp, env)
5364 evaluates EXP in environment ENV. ENV is a lexical environment
5365 structure as used by the actual tree code evaluator. When ENV is
5366 a top-level environment, then changes to the current module are
5367 tracked by updating ENV so that it continues to be in sync with
5370 - scm_primitive_eval (exp)
5372 evaluates EXP in the top-level environment as determined by the
5373 current module. This is done by constructing a suitable
5374 environment and calling scm_i_eval. Thus, changes to the
5375 top-level module are tracked normally.
5377 - scm_eval (exp, mod)
5379 evaluates EXP while MOD is the current module. This is done by
5380 setting the current module to MOD, invoking scm_primitive_eval on
5381 EXP, and then restoring the current module to the value it had
5382 previously. That is, while EXP is evaluated, changes to the
5383 current module are tracked, but these changes do not persist when
5386 For each level of evals, there are two variants, distinguished by a
5387 _x suffix: the ordinary variant does not modify EXP while the _x
5388 variant can destructively modify EXP into something completely
5389 unintelligible. A Scheme data structure passed as EXP to one of the
5390 _x variants should not ever be used again for anything. So when in
5391 doubt, use the ordinary variant.
5396 scm_i_eval_x (SCM exp
, SCM env
)
5398 return SCM_XEVAL (exp
, env
);
5402 scm_i_eval (SCM exp
, SCM env
)
5404 exp
= scm_copy_tree (exp
);
5405 return SCM_XEVAL (exp
, env
);
5409 scm_primitive_eval_x (SCM exp
)
5412 SCM transformer
= scm_current_module_transformer ();
5413 if (SCM_NIMP (transformer
))
5414 exp
= scm_call_1 (transformer
, exp
);
5415 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5416 return scm_i_eval_x (exp
, env
);
5419 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
5421 "Evaluate @var{exp} in the top-level environment specified by\n"
5422 "the current module.")
5423 #define FUNC_NAME s_scm_primitive_eval
5426 SCM transformer
= scm_current_module_transformer ();
5427 if (SCM_NIMP (transformer
))
5428 exp
= scm_call_1 (transformer
, exp
);
5429 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5430 return scm_i_eval (exp
, env
);
5435 /* Eval does not take the second arg optionally. This is intentional
5436 * in order to be R5RS compatible, and to prepare for the new module
5437 * system, where we would like to make the choice of evaluation
5438 * environment explicit. */
5441 change_environment (void *data
)
5443 SCM pair
= SCM_PACK (data
);
5444 SCM new_module
= SCM_CAR (pair
);
5445 SCM old_module
= scm_current_module ();
5446 SCM_SETCDR (pair
, old_module
);
5447 scm_set_current_module (new_module
);
5451 restore_environment (void *data
)
5453 SCM pair
= SCM_PACK (data
);
5454 SCM old_module
= SCM_CDR (pair
);
5455 SCM new_module
= scm_current_module ();
5456 SCM_SETCAR (pair
, new_module
);
5457 scm_set_current_module (old_module
);
5461 inner_eval_x (void *data
)
5463 return scm_primitive_eval_x (SCM_PACK(data
));
5467 scm_eval_x (SCM exp
, SCM module
)
5468 #define FUNC_NAME "eval!"
5470 SCM_VALIDATE_MODULE (2, module
);
5472 return scm_internal_dynamic_wind
5473 (change_environment
, inner_eval_x
, restore_environment
,
5474 (void *) SCM_UNPACK (exp
),
5475 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
5480 inner_eval (void *data
)
5482 return scm_primitive_eval (SCM_PACK(data
));
5485 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
5486 (SCM exp
, SCM module
),
5487 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
5488 "in the top-level environment specified by @var{module}.\n"
5489 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
5490 "@var{module} is made the current module. The current module\n"
5491 "is reset to its previous value when @var{eval} returns.")
5492 #define FUNC_NAME s_scm_eval
5494 SCM_VALIDATE_MODULE (2, module
);
5496 return scm_internal_dynamic_wind
5497 (change_environment
, inner_eval
, restore_environment
,
5498 (void *) SCM_UNPACK (exp
),
5499 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
5504 /* At this point, scm_deval and scm_dapply are generated.
5514 scm_init_opts (scm_evaluator_traps
,
5515 scm_evaluator_trap_table
,
5516 SCM_N_EVALUATOR_TRAPS
);
5517 scm_init_opts (scm_eval_options_interface
,
5519 SCM_N_EVAL_OPTIONS
);
5521 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
5522 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
5523 scm_set_smob_free (scm_tc16_promise
, promise_free
);
5524 scm_set_smob_print (scm_tc16_promise
, promise_print
);
5526 undefineds
= scm_list_1 (SCM_UNDEFINED
);
5527 SCM_SETCDR (undefineds
, undefineds
);
5528 scm_permanent_object (undefineds
);
5530 scm_listofnull
= scm_list_1 (SCM_EOL
);
5532 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
5533 scm_permanent_object (f_apply
);
5535 #include "libguile/eval.x"
5537 scm_add_feature ("delay");