1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003, 2004 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
))
455 /* Return true if the expression is self-quoting in the memoized code. Thus,
456 * some other objects (like e. g. vectors) are reported as self-quoting, which
457 * according to R5RS would need to be quoted. */
459 is_self_quoting_p (const SCM expr
)
461 if (SCM_CONSP (expr
))
463 else if (SCM_SYMBOLP (expr
))
465 else if (SCM_NULLP (expr
))
472 /* Lookup a given local variable in an environment. The local variable is
473 * given as an iloc, that is a triple <frame, binding, last?>, where frame
474 * indicates the relative number of the environment frame (counting upwards
475 * from the innermost environment frame), binding indicates the number of the
476 * binding within the frame, and last? (which is extracted from the iloc using
477 * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
478 * very end of the improper list of bindings. */
480 scm_ilookup (SCM iloc
, SCM env
)
482 unsigned int frame_nr
= SCM_IFRAME (iloc
);
483 unsigned int binding_nr
= SCM_IDIST (iloc
);
487 for (; 0 != frame_nr
; --frame_nr
)
488 frames
= SCM_CDR (frames
);
490 bindings
= SCM_CAR (frames
);
491 for (; 0 != binding_nr
; --binding_nr
)
492 bindings
= SCM_CDR (bindings
);
494 if (SCM_ICDRP (iloc
))
495 return SCM_CDRLOC (bindings
);
496 return SCM_CARLOC (SCM_CDR (bindings
));
500 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
502 static void error_unbound_variable (SCM symbol
) SCM_NORETURN
;
504 error_unbound_variable (SCM symbol
)
506 scm_error (scm_unbound_variable_key
, NULL
,
507 "Unbound variable: ~S",
508 scm_list_1 (symbol
), SCM_BOOL_F
);
512 /* The Lookup Car Race
515 Memoization of variables and special forms is done while executing
516 the code for the first time. As long as there is only one thread
517 everything is fine, but as soon as two threads execute the same
518 code concurrently `for the first time' they can come into conflict.
520 This memoization includes rewriting variable references into more
521 efficient forms and expanding macros. Furthermore, macro expansion
522 includes `compiling' special forms like `let', `cond', etc. into
523 tree-code instructions.
525 There shouldn't normally be a problem with memoizing local and
526 global variable references (into ilocs and variables), because all
527 threads will mutate the code in *exactly* the same way and (if I
528 read the C code correctly) it is not possible to observe a half-way
529 mutated cons cell. The lookup procedure can handle this
530 transparently without any critical sections.
532 It is different with macro expansion, because macro expansion
533 happens outside of the lookup procedure and can't be
534 undone. Therefore the lookup procedure can't cope with it. It has
535 to indicate failure when it detects a lost race and hope that the
536 caller can handle it. Luckily, it turns out that this is the case.
538 An example to illustrate this: Suppose that the following form will
539 be memoized concurrently by two threads
543 Let's first examine the lookup of X in the body. The first thread
544 decides that it has to find the symbol "x" in the environment and
545 starts to scan it. Then the other thread takes over and actually
546 overtakes the first. It looks up "x" and substitutes an
547 appropriate iloc for it. Now the first thread continues and
548 completes its lookup. It comes to exactly the same conclusions as
549 the second one and could - without much ado - just overwrite the
550 iloc with the same iloc.
552 But let's see what will happen when the race occurs while looking
553 up the symbol "let" at the start of the form. It could happen that
554 the second thread interrupts the lookup of the first thread and not
555 only substitutes a variable for it but goes right ahead and
556 replaces it with the compiled form (#@let* (x 12) x). Now, when
557 the first thread completes its lookup, it would replace the #@let*
558 with a variable containing the "let" binding, effectively reverting
559 the form to (let (x 12) x). This is wrong. It has to detect that
560 it has lost the race and the evaluator has to reconsider the
561 changed form completely.
563 This race condition could be resolved with some kind of traffic
564 light (like mutexes) around scm_lookupcar, but I think that it is
565 best to avoid them in this case. They would serialize memoization
566 completely and because lookup involves calling arbitrary Scheme
567 code (via the lookup-thunk), threads could be blocked for an
568 arbitrary amount of time or even deadlock. But with the current
569 solution a lot of unnecessary work is potentially done. */
571 /* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
572 return NULL to indicate a failed lookup due to some race conditions
573 between threads. This only happens when VLOC is the first cell of
574 a special form that will eventually be memoized (like `let', etc.)
575 In that case the whole lookup is bogus and the caller has to
576 reconsider the complete special form.
578 SCM_LOOKUPCAR is still there, of course. It just calls
579 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
580 should only be called when it is known that VLOC is not the first
581 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
582 for NULL. I think I've found the only places where this
586 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
589 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
590 register SCM iloc
= SCM_ILOC00
;
591 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
593 if (!SCM_CONSP (SCM_CAR (env
)))
595 al
= SCM_CARLOC (env
);
596 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
600 if (SCM_EQ_P (fl
, var
))
602 if (! SCM_EQ_P (SCM_CAR (vloc
), var
))
604 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
605 return SCM_CDRLOC (*al
);
610 al
= SCM_CDRLOC (*al
);
611 if (SCM_EQ_P (SCM_CAR (fl
), var
))
613 if (SCM_UNBNDP (SCM_CAR (*al
)))
618 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
620 SCM_SETCAR (vloc
, iloc
);
621 return SCM_CARLOC (*al
);
623 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
625 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
628 SCM top_thunk
, real_var
;
631 top_thunk
= SCM_CAR (env
); /* env now refers to a
632 top level env thunk */
636 top_thunk
= SCM_BOOL_F
;
637 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
638 if (SCM_FALSEP (real_var
))
641 if (!SCM_NULLP (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
647 error_unbound_variable (var
);
649 scm_misc_error (NULL
, "Damaged environment: ~S",
654 /* A variable could not be found, but we shall
655 not throw an error. */
656 static SCM undef_object
= SCM_UNDEFINED
;
657 return &undef_object
;
661 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
663 /* Some other thread has changed the very cell we are working
664 on. In effect, it must have done our job or messed it up
667 var
= SCM_CAR (vloc
);
668 if (SCM_VARIABLEP (var
))
669 return SCM_VARIABLE_LOC (var
);
670 if (SCM_ITAG7 (var
) == SCM_ITAG7 (SCM_ILOC00
))
671 return scm_ilookup (var
, genv
);
672 /* We can't cope with anything else than variables and ilocs. When
673 a special form has been memoized (i.e. `let' into `#@let') we
674 return NULL and expect the calling function to do the right
675 thing. For the evaluator, this means going back and redoing
676 the dispatch on the car of the form. */
680 SCM_SETCAR (vloc
, real_var
);
681 return SCM_VARIABLE_LOC (real_var
);
686 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
688 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
696 /* Rewrite the body (which is given as the list of expressions forming the
697 * body) into its internal form. The internal form of a body (<expr> ...) is
698 * just the body itself, but prefixed with an ISYM that denotes to what kind
699 * of outer construct this body belongs: (<ISYM> <expr> ...). A lambda body
700 * starts with SCM_IM_LAMBDA, for example, a body of a let starts with
703 * It is assumed that the calling expression has already made sure that the
704 * body is a proper list. */
706 m_body (SCM op
, SCM exprs
)
708 /* Don't add another ISYM if one is present already. */
709 if (SCM_ISYMP (SCM_CAR (exprs
)))
712 return scm_cons (op
, exprs
);
716 /* The function m_expand_body memoizes a proper list of expressions
717 * forming a body. This function takes care of dealing with internal
718 * defines and transforming them into an equivalent letrec expression.
719 * The list of expressions is rewritten in place. */
721 /* This is a helper function for m_expand_body. It helps to figure out whether
722 * an expression denotes a syntactic keyword. */
724 try_macro_lookup (const SCM expr
, const SCM env
)
726 if (SCM_SYMBOLP (expr
))
728 const SCM value
= lookup_symbol (expr
, env
);
733 return SCM_UNDEFINED
;
737 /* This is a helper function for m_expand_body. It expands user macros,
738 * because for the correct translation of a body we need to know whether they
739 * expand to a definition. */
741 expand_user_macros (SCM expr
, const SCM env
)
743 while (SCM_CONSP (expr
))
745 const SCM car_expr
= SCM_CAR (expr
);
746 const SCM new_car
= expand_user_macros (car_expr
, env
);
747 const SCM value
= try_macro_lookup (new_car
, env
);
749 if (SCM_MACROP (value
) && SCM_MACRO_TYPE (value
) == 2)
751 /* User macros transform code into code. */
752 expr
= scm_call_2 (SCM_MACRO_CODE (value
), expr
, env
);
753 /* We need to reiterate on the transformed code. */
757 /* No user macro: return. */
758 SCM_SETCAR (expr
, new_car
);
766 /* This is a helper function for m_expand_body. It determines if a given form
767 * represents an application of a given built-in macro. The built-in macro to
768 * check for is identified by its syntactic keyword. The form is an
769 * application of the given macro if looking up the car of the form in the
770 * given environment actually returns the built-in macro. */
772 is_system_macro_p (const SCM syntactic_keyword
, const SCM form
, const SCM env
)
774 if (SCM_CONSP (form
))
776 const SCM car_form
= SCM_CAR (form
);
777 const SCM value
= try_macro_lookup (car_form
, env
);
778 if (SCM_BUILTIN_MACRO_P (value
))
780 const SCM macro_name
= scm_macro_name (value
);
781 return SCM_EQ_P (macro_name
, syntactic_keyword
);
789 m_expand_body (const SCM forms
, const SCM env
)
791 /* The first body form can be skipped since it is known to be the ISYM that
792 * was prepended to the body by m_body. */
793 SCM cdr_forms
= SCM_CDR (forms
);
794 SCM form_idx
= cdr_forms
;
795 SCM definitions
= SCM_EOL
;
796 SCM sequence
= SCM_EOL
;
798 /* According to R5RS, the list of body forms consists of two parts: a number
799 * (maybe zero) of definitions, followed by a non-empty sequence of
800 * expressions. Each the definitions and the expressions may be grouped
801 * arbitrarily with begin, but it is not allowed to mix definitions and
802 * expressions. The task of the following loop therefore is to split the
803 * list of body forms into the list of definitions and the sequence of
805 while (!SCM_NULLP (form_idx
))
807 const SCM form
= SCM_CAR (form_idx
);
808 const SCM new_form
= expand_user_macros (form
, env
);
809 if (is_system_macro_p (scm_sym_define
, new_form
, env
))
811 definitions
= scm_cons (new_form
, definitions
);
812 form_idx
= SCM_CDR (form_idx
);
814 else if (is_system_macro_p (scm_sym_begin
, new_form
, env
))
816 /* We have encountered a group of forms. This has to be either a
817 * (possibly empty) group of (possibly further grouped) definitions,
818 * or a non-empty group of (possibly further grouped)
820 const SCM grouped_forms
= SCM_CDR (new_form
);
821 unsigned int found_definition
= 0;
822 unsigned int found_expression
= 0;
823 SCM grouped_form_idx
= grouped_forms
;
824 while (!found_expression
&& !SCM_NULLP (grouped_form_idx
))
826 const SCM inner_form
= SCM_CAR (grouped_form_idx
);
827 const SCM new_inner_form
= expand_user_macros (inner_form
, env
);
828 if (is_system_macro_p (scm_sym_define
, new_inner_form
, env
))
830 found_definition
= 1;
831 definitions
= scm_cons (new_inner_form
, definitions
);
832 grouped_form_idx
= SCM_CDR (grouped_form_idx
);
834 else if (is_system_macro_p (scm_sym_begin
, new_inner_form
, env
))
836 const SCM inner_group
= SCM_CDR (new_inner_form
);
838 = scm_append (scm_list_2 (inner_group
,
839 SCM_CDR (grouped_form_idx
)));
843 /* The group marks the start of the expressions of the body.
844 * We have to make sure that within the same group we have
845 * not encountered a definition before. */
846 ASSERT_SYNTAX (!found_definition
, s_mixed_body_forms
, form
);
847 found_expression
= 1;
848 grouped_form_idx
= SCM_EOL
;
852 /* We have finished processing the group. If we have not yet
853 * encountered an expression we continue processing the forms of the
854 * body to collect further definition forms. Otherwise, the group
855 * marks the start of the sequence of expressions of the body. */
856 if (!found_expression
)
858 form_idx
= SCM_CDR (form_idx
);
868 /* We have detected a form which is no definition. This marks the
869 * start of the sequence of expressions of the body. */
875 /* FIXME: forms does not hold information about the file location. */
876 ASSERT_SYNTAX (SCM_CONSP (sequence
), s_missing_body_expression
, cdr_forms
);
878 if (!SCM_NULLP (definitions
))
882 SCM letrec_expression
;
883 SCM new_letrec_expression
;
885 SCM bindings
= SCM_EOL
;
886 for (definition_idx
= definitions
;
887 !SCM_NULLP (definition_idx
);
888 definition_idx
= SCM_CDR (definition_idx
))
890 const SCM definition
= SCM_CAR (definition_idx
);
891 const SCM canonical_definition
= canonicalize_define (definition
);
892 const SCM binding
= SCM_CDR (canonical_definition
);
893 bindings
= scm_cons (binding
, bindings
);
896 letrec_tail
= scm_cons (bindings
, sequence
);
897 /* FIXME: forms does not hold information about the file location. */
898 letrec_expression
= scm_cons_source (forms
, scm_sym_letrec
, letrec_tail
);
899 new_letrec_expression
= scm_m_letrec (letrec_expression
, env
);
900 SCM_SETCAR (forms
, new_letrec_expression
);
901 SCM_SETCDR (forms
, SCM_EOL
);
905 SCM_SETCAR (forms
, SCM_CAR (sequence
));
906 SCM_SETCDR (forms
, SCM_CDR (sequence
));
910 #if (SCM_ENABLE_DEPRECATED == 1)
912 /* Deprecated in guile 1.7.0 on 2003-11-09. */
914 scm_m_expand_body (SCM exprs
, SCM env
)
916 scm_c_issue_deprecation_warning
917 ("`scm_m_expand_body' is deprecated.");
918 m_expand_body (exprs
, env
);
925 /* Start of the memoizers for the standard R5RS builtin macros. */
928 SCM_SYNTAX (s_and
, "and", scm_i_makbimacro
, scm_m_and
);
929 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
932 scm_m_and (SCM expr
, SCM env SCM_UNUSED
)
934 const SCM cdr_expr
= SCM_CDR (expr
);
935 const long length
= scm_ilength (cdr_expr
);
937 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
941 /* Special case: (and) is replaced by #t. */
946 SCM_SETCAR (expr
, SCM_IM_AND
);
952 SCM_SYNTAX (s_begin
, "begin", scm_i_makbimacro
, scm_m_begin
);
953 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
956 scm_m_begin (SCM expr
, SCM env SCM_UNUSED
)
958 const SCM cdr_expr
= SCM_CDR (expr
);
959 /* Dirk:FIXME:: An empty begin clause is not generally allowed by R5RS.
960 * That means, there should be a distinction between uses of begin where an
961 * empty clause is OK and where it is not. */
962 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
964 SCM_SETCAR (expr
, SCM_IM_BEGIN
);
969 SCM_SYNTAX (s_case
, "case", scm_i_makbimacro
, scm_m_case
);
970 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
971 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
974 scm_m_case (SCM expr
, SCM env
)
977 SCM all_labels
= SCM_EOL
;
979 /* Check, whether 'else is a literal, i. e. not bound to a value. */
980 const int else_literal_p
= literal_p (scm_sym_else
, env
);
982 const SCM cdr_expr
= SCM_CDR (expr
);
983 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
984 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_clauses
, expr
);
986 clauses
= SCM_CDR (cdr_expr
);
987 while (!SCM_NULLP (clauses
))
991 const SCM clause
= SCM_CAR (clauses
);
992 ASSERT_SYNTAX_2 (scm_ilength (clause
) >= 2,
993 s_bad_case_clause
, clause
, expr
);
995 labels
= SCM_CAR (clause
);
996 if (SCM_CONSP (labels
))
998 ASSERT_SYNTAX_2 (scm_ilength (labels
) >= 0,
999 s_bad_case_labels
, labels
, expr
);
1000 all_labels
= scm_append_x (scm_list_2 (labels
, all_labels
));
1002 else if (SCM_NULLP (labels
))
1004 /* The list of labels is empty. According to R5RS this is allowed.
1005 * It means that the sequence of expressions will never be executed.
1006 * Therefore, as an optimization, we could remove the whole
1011 ASSERT_SYNTAX_2 (SCM_EQ_P (labels
, scm_sym_else
) && else_literal_p
,
1012 s_bad_case_labels
, labels
, expr
);
1013 ASSERT_SYNTAX_2 (SCM_NULLP (SCM_CDR (clauses
)),
1014 s_misplaced_else_clause
, clause
, expr
);
1017 /* build the new clause */
1018 if (SCM_EQ_P (labels
, scm_sym_else
))
1019 SCM_SETCAR (clause
, SCM_IM_ELSE
);
1021 clauses
= SCM_CDR (clauses
);
1024 /* Check whether all case labels are distinct. */
1025 for (; !SCM_NULLP (all_labels
); all_labels
= SCM_CDR (all_labels
))
1027 const SCM label
= SCM_CAR (all_labels
);
1028 ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (label
, SCM_CDR (all_labels
))),
1029 s_duplicate_case_label
, label
, expr
);
1032 SCM_SETCAR (expr
, SCM_IM_CASE
);
1037 SCM_SYNTAX (s_cond
, "cond", scm_i_makbimacro
, scm_m_cond
);
1038 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
1039 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
1042 scm_m_cond (SCM expr
, SCM env
)
1044 /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
1045 const int else_literal_p
= literal_p (scm_sym_else
, env
);
1046 const int arrow_literal_p
= literal_p (scm_sym_arrow
, env
);
1048 const SCM clauses
= SCM_CDR (expr
);
1051 ASSERT_SYNTAX (scm_ilength (clauses
) >= 0, s_bad_expression
, expr
);
1052 ASSERT_SYNTAX (scm_ilength (clauses
) >= 1, s_missing_clauses
, expr
);
1054 for (clause_idx
= clauses
;
1055 !SCM_NULLP (clause_idx
);
1056 clause_idx
= SCM_CDR (clause_idx
))
1060 const SCM clause
= SCM_CAR (clause_idx
);
1061 const long length
= scm_ilength (clause
);
1062 ASSERT_SYNTAX_2 (length
>= 1, s_bad_cond_clause
, clause
, expr
);
1064 test
= SCM_CAR (clause
);
1065 if (SCM_EQ_P (test
, scm_sym_else
) && else_literal_p
)
1067 const int last_clause_p
= SCM_NULLP (SCM_CDR (clause_idx
));
1068 ASSERT_SYNTAX_2 (length
>= 2,
1069 s_bad_cond_clause
, clause
, expr
);
1070 ASSERT_SYNTAX_2 (last_clause_p
,
1071 s_misplaced_else_clause
, clause
, expr
);
1072 SCM_SETCAR (clause
, SCM_IM_ELSE
);
1074 else if (length
>= 2
1075 && SCM_EQ_P (SCM_CADR (clause
), scm_sym_arrow
)
1078 ASSERT_SYNTAX_2 (length
> 2, s_missing_recipient
, clause
, expr
);
1079 ASSERT_SYNTAX_2 (length
== 3, s_extra_expression
, clause
, expr
);
1080 SCM_SETCAR (SCM_CDR (clause
), SCM_IM_ARROW
);
1084 SCM_SETCAR (expr
, SCM_IM_COND
);
1089 SCM_SYNTAX (s_define
, "define", scm_i_makbimacro
, scm_m_define
);
1090 SCM_GLOBAL_SYMBOL (scm_sym_define
, s_define
);
1092 /* Guile provides an extension to R5RS' define syntax to represent function
1093 * currying in a compact way. With this extension, it is allowed to write
1094 * (define <nested-variable> <body>), where <nested-variable> has of one of
1095 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
1096 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
1097 * should be either a sequence of zero or more variables, or a sequence of one
1098 * or more variables followed by a space-delimited period and another
1099 * variable. Each level of argument nesting wraps the <body> within another
1100 * lambda expression. For example, the following forms are allowed, each one
1101 * followed by an equivalent, more explicit implementation.
1103 * (define ((a b . c) . d) <body>) is equivalent to
1104 * (define a (lambda (b . c) (lambda d <body>)))
1106 * (define (((a) b) c . d) <body>) is equivalent to
1107 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
1109 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
1110 * module that does not implement this extension. */
1112 canonicalize_define (const SCM expr
)
1117 const SCM cdr_expr
= SCM_CDR (expr
);
1118 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1119 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1121 body
= SCM_CDR (cdr_expr
);
1122 variable
= SCM_CAR (cdr_expr
);
1123 while (SCM_CONSP (variable
))
1125 /* This while loop realizes function currying by variable nesting.
1126 * Variable is known to be a nested-variable. In every iteration of the
1127 * loop another level of lambda expression is created, starting with the
1128 * innermost one. Note that we don't check for duplicate formals here:
1129 * This will be done by the memoizer of the lambda expression. */
1130 const SCM formals
= SCM_CDR (variable
);
1131 const SCM tail
= scm_cons (formals
, body
);
1133 /* Add source properties to each new lambda expression: */
1134 const SCM lambda
= scm_cons_source (variable
, scm_sym_lambda
, tail
);
1136 body
= scm_list_1 (lambda
);
1137 variable
= SCM_CAR (variable
);
1139 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
), s_bad_variable
, variable
, expr
);
1140 ASSERT_SYNTAX (scm_ilength (body
) == 1, s_expression
, expr
);
1142 SCM_SETCAR (cdr_expr
, variable
);
1143 SCM_SETCDR (cdr_expr
, body
);
1148 scm_m_define (SCM expr
, SCM env
)
1150 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), s_bad_define
, expr
);
1153 const SCM canonical_definition
= canonicalize_define (expr
);
1154 const SCM cdr_canonical_definition
= SCM_CDR (canonical_definition
);
1155 const SCM variable
= SCM_CAR (cdr_canonical_definition
);
1156 const SCM body
= SCM_CDR (cdr_canonical_definition
);
1157 const SCM value
= scm_eval_car (body
, env
);
1160 if (SCM_REC_PROCNAMES_P
)
1163 while (SCM_MACROP (tmp
))
1164 tmp
= SCM_MACRO_CODE (tmp
);
1165 if (SCM_CLOSUREP (tmp
)
1166 /* Only the first definition determines the name. */
1167 && SCM_FALSEP (scm_procedure_property (tmp
, scm_sym_name
)))
1168 scm_set_procedure_property_x (tmp
, scm_sym_name
, variable
);
1171 var
= scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_T
);
1172 SCM_VARIABLE_SET (var
, value
);
1174 return SCM_UNSPECIFIED
;
1179 /* This is a helper function for forms (<keyword> <expression>) that are
1180 * transformed into (#@<keyword> '() <memoized_expression>) in order to allow
1181 * for easy creation of a thunk (i. e. a closure without arguments) using the
1182 * ('() <memoized_expression>) tail of the memoized form. */
1184 memoize_as_thunk_prototype (const SCM expr
, const SCM env SCM_UNUSED
)
1186 const SCM cdr_expr
= SCM_CDR (expr
);
1187 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1188 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1190 SCM_SETCDR (expr
, scm_cons (SCM_EOL
, cdr_expr
));
1196 SCM_SYNTAX (s_delay
, "delay", scm_i_makbimacro
, scm_m_delay
);
1197 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
1199 /* Promises are implemented as closures with an empty parameter list. Thus,
1200 * (delay <expression>) is transformed into (#@delay '() <expression>), where
1201 * the empty list represents the empty parameter list. This representation
1202 * allows for easy creation of the closure during evaluation. */
1204 scm_m_delay (SCM expr
, SCM env
)
1206 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1207 SCM_SETCAR (new_expr
, SCM_IM_DELAY
);
1212 SCM_SYNTAX(s_do
, "do", scm_i_makbimacro
, scm_m_do
);
1213 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
1215 /* DO gets the most radically altered syntax. The order of the vars is
1216 * reversed here. During the evaluation this allows for simple consing of the
1217 * results of the inits and steps:
1219 (do ((<var1> <init1> <step1>)
1227 (#@do (<init1> <init2> ... <initn>)
1228 (varn ... var2 var1)
1231 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
1234 scm_m_do (SCM expr
, SCM env SCM_UNUSED
)
1236 SCM variables
= SCM_EOL
;
1237 SCM init_forms
= SCM_EOL
;
1238 SCM step_forms
= SCM_EOL
;
1245 const SCM cdr_expr
= SCM_CDR (expr
);
1246 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1247 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1249 /* Collect variables, init and step forms. */
1250 binding_idx
= SCM_CAR (cdr_expr
);
1251 ASSERT_SYNTAX_2 (scm_ilength (binding_idx
) >= 0,
1252 s_bad_bindings
, binding_idx
, expr
);
1253 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1255 const SCM binding
= SCM_CAR (binding_idx
);
1256 const long length
= scm_ilength (binding
);
1257 ASSERT_SYNTAX_2 (length
== 2 || length
== 3,
1258 s_bad_binding
, binding
, expr
);
1261 const SCM name
= SCM_CAR (binding
);
1262 const SCM init
= SCM_CADR (binding
);
1263 const SCM step
= (length
== 2) ? name
: SCM_CADDR (binding
);
1264 ASSERT_SYNTAX_2 (SCM_SYMBOLP (name
), s_bad_variable
, name
, expr
);
1265 ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (name
, variables
)),
1266 s_duplicate_binding
, name
, expr
);
1268 variables
= scm_cons (name
, variables
);
1269 init_forms
= scm_cons (init
, init_forms
);
1270 step_forms
= scm_cons (step
, step_forms
);
1273 init_forms
= scm_reverse_x (init_forms
, SCM_UNDEFINED
);
1274 step_forms
= scm_reverse_x (step_forms
, SCM_UNDEFINED
);
1276 /* Memoize the test form and the exit sequence. */
1277 cddr_expr
= SCM_CDR (cdr_expr
);
1278 exit_clause
= SCM_CAR (cddr_expr
);
1279 ASSERT_SYNTAX_2 (scm_ilength (exit_clause
) >= 1,
1280 s_bad_exit_clause
, exit_clause
, expr
);
1282 commands
= SCM_CDR (cddr_expr
);
1283 tail
= scm_cons2 (exit_clause
, commands
, step_forms
);
1284 tail
= scm_cons2 (init_forms
, variables
, tail
);
1285 SCM_SETCAR (expr
, SCM_IM_DO
);
1286 SCM_SETCDR (expr
, tail
);
1291 SCM_SYNTAX (s_if
, "if", scm_i_makbimacro
, scm_m_if
);
1292 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
1295 scm_m_if (SCM expr
, SCM env SCM_UNUSED
)
1297 const SCM cdr_expr
= SCM_CDR (expr
);
1298 const long length
= scm_ilength (cdr_expr
);
1299 ASSERT_SYNTAX (length
== 2 || length
== 3, s_expression
, expr
);
1300 SCM_SETCAR (expr
, SCM_IM_IF
);
1305 SCM_SYNTAX (s_lambda
, "lambda", scm_i_makbimacro
, scm_m_lambda
);
1306 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
1308 /* A helper function for memoize_lambda to support checking for duplicate
1309 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
1310 * LIST or to the cdr of the last cons. Therefore, LIST may have any of the
1311 * forms that a formal argument can have:
1312 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
1314 c_improper_memq (SCM obj
, SCM list
)
1316 for (; SCM_CONSP (list
); list
= SCM_CDR (list
))
1318 if (SCM_EQ_P (SCM_CAR (list
), obj
))
1321 return SCM_EQ_P (list
, obj
);
1325 scm_m_lambda (SCM expr
, SCM env SCM_UNUSED
)
1334 const SCM cdr_expr
= SCM_CDR (expr
);
1335 const long length
= scm_ilength (cdr_expr
);
1336 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1337 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1339 /* Before iterating the list of formal arguments, make sure the formals
1340 * actually are given as either a symbol or a non-cyclic list. */
1341 formals
= SCM_CAR (cdr_expr
);
1342 if (SCM_CONSP (formals
))
1344 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
1345 * detected, report a 'Bad formals' error. */
1349 ASSERT_SYNTAX_2 (SCM_SYMBOLP (formals
) || SCM_NULLP (formals
),
1350 s_bad_formals
, formals
, expr
);
1353 /* Now iterate the list of formal arguments to check if all formals are
1354 * symbols, and that there are no duplicates. */
1355 formals_idx
= formals
;
1356 while (SCM_CONSP (formals_idx
))
1358 const SCM formal
= SCM_CAR (formals_idx
);
1359 const SCM next_idx
= SCM_CDR (formals_idx
);
1360 ASSERT_SYNTAX_2 (SCM_SYMBOLP (formal
), s_bad_formal
, formal
, expr
);
1361 ASSERT_SYNTAX_2 (!c_improper_memq (formal
, next_idx
),
1362 s_duplicate_formal
, formal
, expr
);
1363 formals_idx
= next_idx
;
1365 ASSERT_SYNTAX_2 (SCM_NULLP (formals_idx
) || SCM_SYMBOLP (formals_idx
),
1366 s_bad_formal
, formals_idx
, expr
);
1368 /* Memoize the body. Keep a potential documentation string. */
1369 /* Dirk:FIXME:: We should probably extract the documentation string to
1370 * some external database. Otherwise it will slow down execution, since
1371 * the documentation string will have to be skipped with every execution
1372 * of the closure. */
1373 cddr_expr
= SCM_CDR (cdr_expr
);
1374 documentation
= (length
>= 3 && SCM_STRINGP (SCM_CAR (cddr_expr
)));
1375 body
= documentation
? SCM_CDR (cddr_expr
) : cddr_expr
;
1376 new_body
= m_body (SCM_IM_LAMBDA
, body
);
1378 SCM_SETCAR (expr
, SCM_IM_LAMBDA
);
1380 SCM_SETCDR (cddr_expr
, new_body
);
1382 SCM_SETCDR (cdr_expr
, new_body
);
1387 /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
1389 check_bindings (const SCM bindings
, const SCM expr
)
1393 ASSERT_SYNTAX_2 (scm_ilength (bindings
) >= 0,
1394 s_bad_bindings
, bindings
, expr
);
1396 binding_idx
= bindings
;
1397 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1399 SCM name
; /* const */
1401 const SCM binding
= SCM_CAR (binding_idx
);
1402 ASSERT_SYNTAX_2 (scm_ilength (binding
) == 2,
1403 s_bad_binding
, binding
, expr
);
1405 name
= SCM_CAR (binding
);
1406 ASSERT_SYNTAX_2 (SCM_SYMBOLP (name
), s_bad_variable
, name
, expr
);
1411 /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
1412 * transformed to the lists (vn ... v2 v1) and (i1 i2 ... in). That is, the
1413 * variables are returned in a list with their order reversed, and the init
1414 * forms are returned in a list in the same order as they are given in the
1415 * bindings. If a duplicate variable name is detected, an error is
1418 transform_bindings (
1419 const SCM bindings
, const SCM expr
,
1420 SCM
*const rvarptr
, SCM
*const initptr
)
1422 SCM rvariables
= SCM_EOL
;
1423 SCM rinits
= SCM_EOL
;
1424 SCM binding_idx
= bindings
;
1425 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1427 const SCM binding
= SCM_CAR (binding_idx
);
1428 const SCM cdr_binding
= SCM_CDR (binding
);
1429 const SCM name
= SCM_CAR (binding
);
1430 ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (name
, rvariables
)),
1431 s_duplicate_binding
, name
, expr
);
1432 rvariables
= scm_cons (name
, rvariables
);
1433 rinits
= scm_cons (SCM_CAR (cdr_binding
), rinits
);
1435 *rvarptr
= rvariables
;
1436 *initptr
= scm_reverse_x (rinits
, SCM_UNDEFINED
);
1440 SCM_SYNTAX(s_let
, "let", scm_i_makbimacro
, scm_m_let
);
1441 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
1443 /* This function is a helper function for memoize_let. It transforms
1444 * (let name ((var init) ...) body ...) into
1445 * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
1446 * and memoizes the expression. It is assumed that the caller has checked
1447 * that name is a symbol and that there are bindings and a body. */
1449 memoize_named_let (const SCM expr
, const SCM env SCM_UNUSED
)
1455 const SCM cdr_expr
= SCM_CDR (expr
);
1456 const SCM name
= SCM_CAR (cdr_expr
);
1457 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1458 const SCM bindings
= SCM_CAR (cddr_expr
);
1459 check_bindings (bindings
, expr
);
1461 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1462 variables
= scm_reverse_x (rvariables
, SCM_UNDEFINED
);
1465 const SCM let_body
= SCM_CDR (cddr_expr
);
1466 const SCM lambda_body
= m_body (SCM_IM_LET
, let_body
);
1467 const SCM lambda_tail
= scm_cons (variables
, lambda_body
);
1468 const SCM lambda_form
= scm_cons_source (expr
, scm_sym_lambda
, lambda_tail
);
1470 const SCM rvar
= scm_list_1 (name
);
1471 const SCM init
= scm_list_1 (lambda_form
);
1472 const SCM body
= m_body (SCM_IM_LET
, scm_list_1 (name
));
1473 const SCM letrec_tail
= scm_cons (rvar
, scm_cons (init
, body
));
1474 const SCM letrec_form
= scm_cons_source (expr
, SCM_IM_LETREC
, letrec_tail
);
1475 return scm_cons_source (expr
, letrec_form
, inits
);
1479 /* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1480 * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
1482 scm_m_let (SCM expr
, SCM env
)
1486 const SCM cdr_expr
= SCM_CDR (expr
);
1487 const long length
= scm_ilength (cdr_expr
);
1488 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1489 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1491 bindings
= SCM_CAR (cdr_expr
);
1492 if (SCM_SYMBOLP (bindings
))
1494 ASSERT_SYNTAX (length
>= 3, s_missing_expression
, expr
);
1495 return memoize_named_let (expr
, env
);
1498 check_bindings (bindings
, expr
);
1499 if (SCM_NULLP (bindings
) || SCM_NULLP (SCM_CDR (bindings
)))
1501 /* Special case: no bindings or single binding => let* is faster. */
1502 const SCM body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1503 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), bindings
, body
), env
);
1510 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1513 const SCM new_body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1514 const SCM new_tail
= scm_cons2 (rvariables
, inits
, new_body
);
1515 SCM_SETCAR (expr
, SCM_IM_LET
);
1516 SCM_SETCDR (expr
, new_tail
);
1523 SCM_SYNTAX (s_letstar
, "let*", scm_i_makbimacro
, scm_m_letstar
);
1524 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
1526 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1527 * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
1529 scm_m_letstar (SCM expr
, SCM env SCM_UNUSED
)
1534 const SCM cdr_expr
= SCM_CDR (expr
);
1535 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1536 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1538 binding_idx
= SCM_CAR (cdr_expr
);
1539 check_bindings (binding_idx
, expr
);
1541 /* Transform ((v1 i1) (v2 i2) ...) into (v1 i1 v2 i2 ...). The
1542 * transformation is done in place. At the beginning of one iteration of
1543 * the loop the variable binding_idx holds the form
1544 * P1:( (vn . P2:(in . ())) . P3:( (vn+1 in+1) ... ) ),
1545 * where P1, P2 and P3 indicate the pairs, that are relevant for the
1546 * transformation. P1 and P2 are modified in the loop, P3 remains
1547 * untouched. After the execution of the loop, P1 will hold
1548 * P1:( vn . P2:(in . P3:( (vn+1 in+1) ... )) )
1549 * and binding_idx will hold P3. */
1550 while (!SCM_NULLP (binding_idx
))
1552 const SCM cdr_binding_idx
= SCM_CDR (binding_idx
); /* remember P3 */
1553 const SCM binding
= SCM_CAR (binding_idx
);
1554 const SCM name
= SCM_CAR (binding
);
1555 const SCM cdr_binding
= SCM_CDR (binding
);
1557 SCM_SETCDR (cdr_binding
, cdr_binding_idx
); /* update P2 */
1558 SCM_SETCAR (binding_idx
, name
); /* update P1 */
1559 SCM_SETCDR (binding_idx
, cdr_binding
); /* update P1 */
1561 binding_idx
= cdr_binding_idx
; /* continue with P3 */
1564 new_body
= m_body (SCM_IM_LETSTAR
, SCM_CDR (cdr_expr
));
1565 SCM_SETCAR (expr
, SCM_IM_LETSTAR
);
1566 /* the bindings have been changed in place */
1567 SCM_SETCDR (cdr_expr
, new_body
);
1572 SCM_SYNTAX(s_letrec
, "letrec", scm_i_makbimacro
, scm_m_letrec
);
1573 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
1576 scm_m_letrec (SCM expr
, SCM env
)
1580 const SCM cdr_expr
= SCM_CDR (expr
);
1581 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1582 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1584 bindings
= SCM_CAR (cdr_expr
);
1585 if (SCM_NULLP (bindings
))
1587 /* no bindings, let* is executed faster */
1588 SCM body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1589 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), SCM_EOL
, body
), env
);
1597 check_bindings (bindings
, expr
);
1598 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1599 new_body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1600 return scm_cons2 (SCM_IM_LETREC
, rvariables
, scm_cons (inits
, new_body
));
1605 SCM_SYNTAX (s_or
, "or", scm_i_makbimacro
, scm_m_or
);
1606 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
1609 scm_m_or (SCM expr
, SCM env SCM_UNUSED
)
1611 const SCM cdr_expr
= SCM_CDR (expr
);
1612 const long length
= scm_ilength (cdr_expr
);
1614 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1618 /* Special case: (or) is replaced by #f. */
1623 SCM_SETCAR (expr
, SCM_IM_OR
);
1629 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
1630 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
1631 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
1632 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
1634 /* Internal function to handle a quasiquotation: 'form' is the parameter in
1635 * the call (quasiquotation form), 'env' is the environment where unquoted
1636 * expressions will be evaluated, and 'depth' is the current quasiquotation
1637 * nesting level and is known to be greater than zero. */
1639 iqq (SCM form
, SCM env
, unsigned long int depth
)
1641 if (SCM_CONSP (form
))
1643 const SCM tmp
= SCM_CAR (form
);
1644 if (SCM_EQ_P (tmp
, scm_sym_quasiquote
))
1646 const SCM args
= SCM_CDR (form
);
1647 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1648 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
1650 else if (SCM_EQ_P (tmp
, scm_sym_unquote
))
1652 const SCM args
= SCM_CDR (form
);
1653 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1655 return scm_eval_car (args
, env
);
1657 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
1659 else if (SCM_CONSP (tmp
)
1660 && SCM_EQ_P (SCM_CAR (tmp
), scm_sym_uq_splicing
))
1662 const SCM args
= SCM_CDR (tmp
);
1663 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1666 const SCM list
= scm_eval_car (args
, env
);
1667 const SCM rest
= SCM_CDR (form
);
1668 ASSERT_SYNTAX_2 (scm_ilength (list
) >= 0,
1669 s_splicing
, list
, form
);
1670 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
1673 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
1674 iqq (SCM_CDR (form
), env
, depth
));
1677 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
1678 iqq (SCM_CDR (form
), env
, depth
));
1680 else if (SCM_VECTORP (form
))
1682 size_t i
= SCM_VECTOR_LENGTH (form
);
1683 SCM
const *const data
= SCM_VELTS (form
);
1686 tmp
= scm_cons (data
[--i
], tmp
);
1687 scm_remember_upto_here_1 (form
);
1688 return scm_vector (iqq (tmp
, env
, depth
));
1695 scm_m_quasiquote (SCM expr
, SCM env
)
1697 const SCM cdr_expr
= SCM_CDR (expr
);
1698 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1699 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1700 return iqq (SCM_CAR (cdr_expr
), env
, 1);
1704 SCM_SYNTAX (s_quote
, "quote", scm_i_makbimacro
, scm_m_quote
);
1705 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
1708 scm_m_quote (SCM expr
, SCM env SCM_UNUSED
)
1712 const SCM cdr_expr
= SCM_CDR (expr
);
1713 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1714 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1715 quotee
= SCM_CAR (cdr_expr
);
1716 if (is_self_quoting_p (quotee
))
1718 SCM_SETCAR (expr
, SCM_IM_QUOTE
);
1723 /* Will go into the RnRS module when Guile is factorized.
1724 SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
1725 static const char s_set_x
[] = "set!";
1726 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, s_set_x
);
1729 scm_m_set_x (SCM expr
, SCM env SCM_UNUSED
)
1733 const SCM cdr_expr
= SCM_CDR (expr
);
1734 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1735 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1736 variable
= SCM_CAR (cdr_expr
);
1737 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
) || SCM_VARIABLEP (variable
),
1738 s_bad_variable
, variable
, expr
);
1740 SCM_SETCAR (expr
, SCM_IM_SET_X
);
1745 /* Start of the memoizers for non-R5RS builtin macros. */
1748 SCM_SYNTAX (s_atapply
, "@apply", scm_i_makbimacro
, scm_m_apply
);
1749 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1750 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1753 scm_m_apply (SCM expr
, SCM env SCM_UNUSED
)
1755 const SCM cdr_expr
= SCM_CDR (expr
);
1756 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1757 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_missing_expression
, expr
);
1759 SCM_SETCAR (expr
, SCM_IM_APPLY
);
1764 SCM_SYNTAX (s_atbind
, "@bind", scm_i_makbimacro
, scm_m_atbind
);
1766 /* FIXME: The following explanation should go into the documentation: */
1767 /* (@bind ((var init) ...) body ...) will assign the values of the `init's to
1768 * the global variables named by `var's (symbols, not evaluated), creating
1769 * them if they don't exist, executes body, and then restores the previous
1770 * values of the `var's. Additionally, whenever control leaves body, the
1771 * values of the `var's are saved and restored when control returns. It is an
1772 * error when a symbol appears more than once among the `var's. All `init's
1773 * are evaluated before any `var' is set.
1775 * Think of this as `let' for dynamic scope.
1778 /* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into
1779 * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...).
1781 * FIXME - also implement `@bind*'.
1784 scm_m_atbind (SCM expr
, SCM env
)
1791 const SCM top_level
= scm_env_top_level (env
);
1793 const SCM cdr_expr
= SCM_CDR (expr
);
1794 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1795 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1796 bindings
= SCM_CAR (cdr_expr
);
1797 check_bindings (bindings
, expr
);
1798 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1800 for (variable_idx
= rvariables
;
1801 !SCM_NULLP (variable_idx
);
1802 variable_idx
= SCM_CDR (variable_idx
))
1804 /* The first call to scm_sym2var will look beyond the current module,
1805 * while the second call wont. */
1806 const SCM variable
= SCM_CAR (variable_idx
);
1807 SCM new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_F
);
1808 if (SCM_FALSEP (new_variable
))
1809 new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_T
);
1810 SCM_SETCAR (variable_idx
, new_variable
);
1813 SCM_SETCAR (expr
, SCM_IM_BIND
);
1814 SCM_SETCAR (cdr_expr
, scm_cons (rvariables
, inits
));
1819 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_i_makbimacro
, scm_m_cont
);
1820 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, s_atcall_cc
);
1823 scm_m_cont (SCM expr
, SCM env SCM_UNUSED
)
1825 const SCM cdr_expr
= SCM_CDR (expr
);
1826 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1827 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1829 SCM_SETCAR (expr
, SCM_IM_CONT
);
1834 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_i_makbimacro
, scm_m_at_call_with_values
);
1835 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
1838 scm_m_at_call_with_values (SCM expr
, SCM env SCM_UNUSED
)
1840 const SCM cdr_expr
= SCM_CDR (expr
);
1841 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1842 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1844 SCM_SETCAR (expr
, SCM_IM_CALL_WITH_VALUES
);
1849 SCM_SYNTAX (s_future
, "future", scm_i_makbimacro
, scm_m_future
);
1850 SCM_GLOBAL_SYMBOL (scm_sym_future
, s_future
);
1852 /* Like promises, futures are implemented as closures with an empty
1853 * parameter list. Thus, (future <expression>) is transformed into
1854 * (#@future '() <expression>), where the empty list represents the
1855 * empty parameter list. This representation allows for easy creation
1856 * of the closure during evaluation. */
1858 scm_m_future (SCM expr
, SCM env
)
1860 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1861 SCM_SETCAR (new_expr
, SCM_IM_FUTURE
);
1866 SCM_SYNTAX (s_gset_x
, "set!", scm_i_makbimacro
, scm_m_generalized_set_x
);
1867 SCM_SYMBOL (scm_sym_setter
, "setter");
1870 scm_m_generalized_set_x (SCM expr
, SCM env
)
1872 SCM target
, exp_target
;
1874 const SCM cdr_expr
= SCM_CDR (expr
);
1875 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1876 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1878 target
= SCM_CAR (cdr_expr
);
1879 if (!SCM_CONSP (target
))
1882 return scm_m_set_x (expr
, env
);
1886 /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */
1887 /* Macroexpanding the target might return things of the form
1888 (begin <atom>). In that case, <atom> must be a symbol or a
1889 variable and we memoize to (set! <atom> ...).
1891 exp_target
= scm_macroexp (target
, env
);
1892 if (SCM_EQ_P (SCM_CAR (exp_target
), SCM_IM_BEGIN
)
1893 && !SCM_NULLP (SCM_CDR (exp_target
))
1894 && SCM_NULLP (SCM_CDDR (exp_target
)))
1896 exp_target
= SCM_CADR (exp_target
);
1897 ASSERT_SYNTAX_2 (SCM_SYMBOLP (exp_target
)
1898 || SCM_VARIABLEP (exp_target
),
1899 s_bad_variable
, exp_target
, expr
);
1900 return scm_cons (SCM_IM_SET_X
, scm_cons (exp_target
,
1901 SCM_CDR (cdr_expr
)));
1905 const SCM setter_proc_tail
= scm_list_1 (SCM_CAR (target
));
1906 const SCM setter_proc
= scm_cons_source (expr
, scm_sym_setter
,
1909 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1910 const SCM setter_args
= scm_append_x (scm_list_2 (SCM_CDR (target
),
1913 SCM_SETCAR (expr
, setter_proc
);
1914 SCM_SETCDR (expr
, setter_args
);
1921 /* @slot-ref is bound privately in the (oop goops) module from goops.c. As
1922 * soon as the module system allows us to more freely create bindings in
1923 * arbitrary modules during the startup phase, the code from goops.c should be
1926 scm_m_atslot_ref (SCM expr
, SCM env SCM_UNUSED
)
1930 const SCM cdr_expr
= SCM_CDR (expr
);
1931 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1932 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1933 slot_nr
= SCM_CADR (cdr_expr
);
1934 ASSERT_SYNTAX_2 (SCM_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
1936 SCM_SETCAR (expr
, SCM_IM_SLOT_REF
);
1941 /* @slot-set! is bound privately in the (oop goops) module from goops.c. As
1942 * soon as the module system allows us to more freely create bindings in
1943 * arbitrary modules during the startup phase, the code from goops.c should be
1946 scm_m_atslot_set_x (SCM expr
, SCM env SCM_UNUSED
)
1950 const SCM cdr_expr
= SCM_CDR (expr
);
1951 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1952 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 3, s_expression
, expr
);
1953 slot_nr
= SCM_CADR (cdr_expr
);
1954 ASSERT_SYNTAX_2 (SCM_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
1956 SCM_SETCAR (expr
, SCM_IM_SLOT_SET_X
);
1961 #if SCM_ENABLE_ELISP
1963 static const char s_defun
[] = "Symbol's function definition is void";
1965 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_i_makbimacro
, scm_m_nil_cond
);
1967 /* nil-cond expressions have the form
1968 * (nil-cond COND VAL COND VAL ... ELSEVAL) */
1970 scm_m_nil_cond (SCM expr
, SCM env SCM_UNUSED
)
1972 const long length
= scm_ilength (SCM_CDR (expr
));
1973 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1974 ASSERT_SYNTAX (length
>= 1 && (length
% 2) == 1, s_expression
, expr
);
1976 SCM_SETCAR (expr
, SCM_IM_NIL_COND
);
1981 SCM_SYNTAX (s_atfop
, "@fop", scm_i_makbimacro
, scm_m_atfop
);
1983 /* The @fop-macro handles procedure and macro applications for elisp. The
1984 * input expression must have the form
1985 * (@fop <var> (transformer-macro <expr> ...))
1986 * where <var> must be a symbol. The expression is transformed into the
1987 * memoized form of either
1988 * (apply <un-aliased var> (transformer-macro <expr> ...))
1989 * if the value of var (across all aliasing) is not a macro, or
1990 * (<un-aliased var> <expr> ...)
1991 * if var is a macro. */
1993 scm_m_atfop (SCM expr
, SCM env SCM_UNUSED
)
1998 const SCM cdr_expr
= SCM_CDR (expr
);
1999 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2000 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 1, s_missing_expression
, expr
);
2002 symbol
= SCM_CAR (cdr_expr
);
2003 ASSERT_SYNTAX_2 (SCM_SYMBOLP (symbol
), s_bad_variable
, symbol
, expr
);
2005 location
= scm_symbol_fref (symbol
);
2006 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2008 /* The elisp function `defalias' allows to define aliases for symbols. To
2009 * look up such definitions, the chain of symbol definitions has to be
2010 * followed up to the terminal symbol. */
2011 while (SCM_SYMBOLP (SCM_VARIABLE_REF (location
)))
2013 const SCM alias
= SCM_VARIABLE_REF (location
);
2014 location
= scm_symbol_fref (alias
);
2015 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2018 /* Memoize the value location belonging to the terminal symbol. */
2019 SCM_SETCAR (cdr_expr
, location
);
2021 if (!SCM_MACROP (SCM_VARIABLE_REF (location
)))
2023 /* Since the location does not contain a macro, the form is a procedure
2024 * application. Replace `@fop' by `@apply' and transform the expression
2025 * including the `transformer-macro'. */
2026 SCM_SETCAR (expr
, SCM_IM_APPLY
);
2031 /* Since the location contains a macro, the arguments should not be
2032 * transformed, so the `transformer-macro' is cut out. The resulting
2033 * expression starts with the memoized variable, that is at the cdr of
2034 * the input expression. */
2035 SCM_SETCDR (cdr_expr
, SCM_CDADR (cdr_expr
));
2040 #endif /* SCM_ENABLE_ELISP */
2043 /* Start of the memoizers for deprecated macros. */
2046 #if (SCM_ENABLE_DEPRECATED == 1)
2048 SCM_SYNTAX (s_undefine
, "undefine", scm_makacro
, scm_m_undefine
);
2051 scm_m_undefine (SCM expr
, SCM env
)
2056 const SCM cdr_expr
= SCM_CDR (expr
);
2057 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), "Bad undefine placement in", expr
);
2058 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2059 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2061 variable
= SCM_CAR (cdr_expr
);
2062 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
), s_bad_variable
, variable
, expr
);
2063 location
= scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_F
);
2064 ASSERT_SYNTAX_2 (!SCM_FALSEP (location
)
2065 && !SCM_UNBNDP (SCM_VARIABLE_REF (location
)),
2066 "variable already unbound ", variable
, expr
);
2067 SCM_VARIABLE_SET (location
, SCM_UNDEFINED
);
2068 return SCM_UNSPECIFIED
;
2074 #if (SCM_ENABLE_DEPRECATED == 1)
2077 scm_macroexp (SCM x
, SCM env
)
2079 SCM res
, proc
, orig_sym
;
2081 /* Don't bother to produce error messages here. We get them when we
2082 eventually execute the code for real. */
2085 orig_sym
= SCM_CAR (x
);
2086 if (!SCM_SYMBOLP (orig_sym
))
2090 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
2091 if (proc_ptr
== NULL
)
2093 /* We have lost the race. */
2099 /* Only handle memoizing macros. `Acros' and `macros' are really
2100 special forms and should not be evaluated here. */
2102 if (!SCM_MACROP (proc
)
2103 || (SCM_MACRO_TYPE (proc
) != 2 && !SCM_BUILTIN_MACRO_P (proc
)))
2106 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
2107 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
2109 if (scm_ilength (res
) <= 0)
2110 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
2113 SCM_SETCAR (x
, SCM_CAR (res
));
2114 SCM_SETCDR (x
, SCM_CDR (res
));
2122 /*****************************************************************************/
2123 /*****************************************************************************/
2124 /* The definitions for unmemoization start here. */
2125 /*****************************************************************************/
2126 /*****************************************************************************/
2128 #define SCM_BIT7(x) (127 & SCM_UNPACK (x))
2130 SCM_SYMBOL (sym_three_question_marks
, "???");
2133 /* scm_unmemocopy takes a memoized expression together with its
2134 * environment and rewrites it to its original form. Thus, it is the
2135 * inversion of the rewrite rules above. The procedure is not
2136 * optimized for speed. It's used in scm_iprin1 when printing the
2137 * code of a closure, in scm_procedure_source, in display_frame when
2138 * generating the source for a stackframe in a backtrace, and in
2139 * display_expression.
2141 * Unmemoizing is not a reliable process. You cannot in general
2142 * expect to get the original source back.
2144 * However, GOOPS currently relies on this for method compilation.
2145 * This ought to change.
2149 build_binding_list (SCM rnames
, SCM rinits
)
2151 SCM bindings
= SCM_EOL
;
2152 while (!SCM_NULLP (rnames
))
2154 SCM binding
= scm_list_2 (SCM_CAR (rnames
), SCM_CAR (rinits
));
2155 bindings
= scm_cons (binding
, bindings
);
2156 rnames
= SCM_CDR (rnames
);
2157 rinits
= SCM_CDR (rinits
);
2164 unmemocar (SCM form
, SCM env
)
2166 if (!SCM_CONSP (form
))
2170 SCM c
= SCM_CAR (form
);
2171 if (SCM_VARIABLEP (c
))
2173 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
2174 if (SCM_FALSEP (sym
))
2175 sym
= sym_three_question_marks
;
2176 SCM_SETCAR (form
, sym
);
2178 else if (SCM_ILOCP (c
))
2180 unsigned long int ir
;
2182 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
2183 env
= SCM_CDR (env
);
2184 env
= SCM_CAAR (env
);
2185 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
2186 env
= SCM_CDR (env
);
2188 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
2195 #if (SCM_ENABLE_DEPRECATED == 1)
2198 scm_unmemocar (SCM form
, SCM env
)
2200 return unmemocar (form
, env
);
2207 scm_unmemocopy (SCM x
, SCM env
)
2212 if (SCM_VECTORP (x
))
2214 return scm_list_2 (scm_sym_quote
, x
);
2216 else if (!SCM_CONSP (x
))
2219 p
= scm_whash_lookup (scm_source_whash
, x
);
2220 switch (SCM_ITAG7 (SCM_CAR (x
)))
2222 case SCM_BIT7 (SCM_IM_AND
):
2223 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
2225 case SCM_BIT7 (SCM_IM_BEGIN
):
2226 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
2228 case SCM_BIT7 (SCM_IM_CASE
):
2229 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
2231 case SCM_BIT7 (SCM_IM_COND
):
2232 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
2234 case SCM_BIT7 (SCM_IM_DO
):
2236 /* format: (#@do (i1 ... ik) (nk nk-1 ...) (test) (body) s1 ... sk),
2237 * where ix is an initializer for a local variable, nx is the name of
2238 * the local variable, test is the test clause of the do loop, body is
2239 * the body of the do loop and sx are the step clauses for the local
2241 SCM names
, inits
, test
, memoized_body
, steps
, bindings
;
2244 inits
= scm_reverse (scm_unmemocopy (SCM_CAR (x
), env
));
2246 names
= SCM_CAR (x
);
2247 env
= SCM_EXTEND_ENV (names
, SCM_EOL
, env
);
2249 test
= scm_unmemocopy (SCM_CAR (x
), env
);
2251 memoized_body
= SCM_CAR (x
);
2253 steps
= scm_reverse (scm_unmemocopy (x
, env
));
2255 /* build transformed binding list */
2257 while (!SCM_NULLP (names
))
2259 SCM name
= SCM_CAR (names
);
2260 SCM init
= SCM_CAR (inits
);
2261 SCM step
= SCM_CAR (steps
);
2262 step
= SCM_EQ_P (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
2264 bindings
= scm_cons (scm_cons2 (name
, init
, step
), bindings
);
2266 names
= SCM_CDR (names
);
2267 inits
= SCM_CDR (inits
);
2268 steps
= SCM_CDR (steps
);
2270 z
= scm_cons (test
, SCM_UNSPECIFIED
);
2271 ls
= scm_cons2 (scm_sym_do
, bindings
, z
);
2273 x
= scm_cons (SCM_BOOL_F
, memoized_body
);
2276 case SCM_BIT7 (SCM_IM_IF
):
2277 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
2279 case SCM_BIT7 (SCM_IM_LET
):
2281 /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),
2282 * where nx is the name of a local variable, ix is an initializer for
2283 * the local variable and by are the body clauses. */
2284 SCM rnames
, rinits
, bindings
;
2287 rnames
= SCM_CAR (x
);
2289 rinits
= scm_reverse (scm_unmemocopy (SCM_CAR (x
), env
));
2290 env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
2292 bindings
= build_binding_list (rnames
, rinits
);
2293 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
2294 ls
= scm_cons (scm_sym_let
, z
);
2297 case SCM_BIT7 (SCM_IM_LETREC
):
2299 /* format: (#@letrec (vn ... v2 v1) (i1 i2 ... in) b1 ...),
2300 * where vx is the name of a local variable, ix is an initializer for
2301 * the local variable and by are the body clauses. */
2302 SCM rnames
, rinits
, bindings
;
2305 rnames
= SCM_CAR (x
);
2306 env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
2308 rinits
= scm_reverse (scm_unmemocopy (SCM_CAR (x
), env
));
2310 bindings
= build_binding_list (rnames
, rinits
);
2311 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
2312 ls
= scm_cons (scm_sym_letrec
, z
);
2315 case SCM_BIT7 (SCM_IM_LETSTAR
):
2323 env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2326 y
= z
= scm_acons (SCM_CAR (b
),
2328 scm_cons (scm_unmemocopy (SCM_CADR (b
), env
), SCM_EOL
), env
),
2330 env
= SCM_EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
2334 SCM_SETCDR (y
, SCM_EOL
);
2335 z
= scm_cons (y
, SCM_UNSPECIFIED
);
2336 ls
= scm_cons (scm_sym_let
, z
);
2341 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
2343 scm_list_1 (scm_unmemocopy (SCM_CADR (b
), env
)), env
),
2346 env
= SCM_EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
2349 while (SCM_NIMP (b
));
2350 SCM_SETCDR (z
, SCM_EOL
);
2352 z
= scm_cons (y
, SCM_UNSPECIFIED
);
2353 ls
= scm_cons (scm_sym_letstar
, z
);
2356 case SCM_BIT7 (SCM_IM_OR
):
2357 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
2359 case SCM_BIT7 (SCM_IM_LAMBDA
):
2361 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
);
2362 ls
= scm_cons (scm_sym_lambda
, z
);
2363 env
= SCM_EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
2365 case SCM_BIT7 (SCM_IM_QUOTE
):
2366 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
2368 case SCM_BIT7 (SCM_IM_SET_X
):
2369 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
2371 case SCM_BIT7 (SCM_MAKISYM (0)):
2373 switch (SCM_ISYMNUM (z
))
2375 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2376 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
2378 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2379 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
2381 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2382 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
2385 case (SCM_ISYMNUM (SCM_IM_FUTURE
)):
2386 ls
= z
= scm_cons (scm_sym_future
, SCM_UNSPECIFIED
);
2389 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2390 ls
= z
= scm_cons (scm_sym_at_call_with_values
, SCM_UNSPECIFIED
);
2392 case (SCM_ISYMNUM (SCM_IM_ELSE
)):
2393 ls
= z
= scm_cons (scm_sym_else
, SCM_UNSPECIFIED
);
2396 /* appease the Sun compiler god: */ ;
2399 ls
= z
= unmemocar (scm_cons (scm_unmemocopy (SCM_CAR (x
), env
),
2405 while (SCM_CONSP (x
))
2407 SCM form
= SCM_CAR (x
);
2408 if (!SCM_ISYMP (form
))
2410 SCM copy
= scm_cons (scm_unmemocopy (form
, env
), SCM_UNSPECIFIED
);
2411 SCM_SETCDR (z
, unmemocar (copy
, env
));
2414 else if (SCM_EQ_P (form
, SCM_IM_ARROW
))
2416 SCM_SETCDR (z
, scm_cons (scm_sym_arrow
, SCM_UNSPECIFIED
));
2422 if (!SCM_FALSEP (p
))
2423 scm_whash_insert (scm_source_whash
, ls
, p
);
2428 /*****************************************************************************/
2429 /*****************************************************************************/
2430 /* The definitions for execution start here. */
2431 /*****************************************************************************/
2432 /*****************************************************************************/
2434 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
2435 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
2436 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
2437 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
2439 /* A function object to implement "apply" for non-closure functions. */
2441 /* An endless list consisting of #<undefined> objects: */
2442 static SCM undefineds
;
2446 scm_badargsp (SCM formals
, SCM args
)
2448 while (!SCM_NULLP (formals
))
2450 if (!SCM_CONSP (formals
))
2452 if (SCM_NULLP (args
))
2454 formals
= SCM_CDR (formals
);
2455 args
= SCM_CDR (args
);
2457 return !SCM_NULLP (args
) ? 1 : 0;
2462 /* The evaluator contains a plethora of EVAL symbols.
2463 * This is an attempt at explanation.
2465 * The following macros should be used in code which is read twice
2466 * (where the choice of evaluator is hard soldered):
2468 * SCM_CEVAL is the symbol used within one evaluator to call itself.
2469 * Originally, it is defined to scm_ceval, but is redefined to
2470 * scm_deval during the second pass.
2472 * SCM_EVALIM is used when it is known that the expression is an
2473 * immediate. (This macro never calls an evaluator.)
2475 * EVALCAR evaluates the car of an expression.
2477 * The following macros should be used in code which is read once
2478 * (where the choice of evaluator is dynamic):
2480 * SCM_XEVAL takes care of immediates without calling an evaluator. It
2481 * then calls scm_ceval *or* scm_deval, depending on the debugging
2484 * SCM_XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
2485 * depending on the debugging mode.
2487 * The main motivation for keeping this plethora is efficiency
2488 * together with maintainability (=> locality of code).
2491 #define SCM_CEVAL scm_ceval
2493 #define SCM_EVALIM2(x) \
2494 ((SCM_EQ_P ((x), SCM_EOL) \
2495 ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \
2499 #define SCM_EVALIM(x, env) (SCM_ILOCP (x) \
2500 ? *scm_ilookup ((x), env) \
2503 #define SCM_XEVAL(x, env) (SCM_IMP (x) \
2505 : (*scm_ceval_ptr) ((x), (env)))
2507 #define SCM_XEVALCAR(x, env) (SCM_IMP (SCM_CAR (x)) \
2508 ? SCM_EVALIM (SCM_CAR (x), env) \
2509 : (SCM_SYMBOLP (SCM_CAR (x)) \
2510 ? *scm_lookupcar (x, env, 1) \
2511 : (*scm_ceval_ptr) (SCM_CAR (x), env)))
2513 #define EVALCAR(x, env) (SCM_IMP (SCM_CAR (x)) \
2514 ? SCM_EVALIM (SCM_CAR (x), env) \
2515 : (SCM_SYMBOLP (SCM_CAR (x)) \
2516 ? *scm_lookupcar (x, env, 1) \
2517 : SCM_CEVAL (SCM_CAR (x), env)))
2519 SCM_REC_MUTEX (source_mutex
);
2523 scm_eval_car (SCM pair
, SCM env
)
2525 return SCM_XEVALCAR (pair
, env
);
2530 scm_eval_args (SCM l
, SCM env
, SCM proc
)
2532 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
2533 while (SCM_CONSP (l
))
2535 res
= EVALCAR (l
, env
);
2537 *lloc
= scm_list_1 (res
);
2538 lloc
= SCM_CDRLOC (*lloc
);
2542 scm_wrong_num_args (proc
);
2548 scm_eval_body (SCM code
, SCM env
)
2552 next
= SCM_CDR (code
);
2553 while (!SCM_NULLP (next
))
2555 if (SCM_IMP (SCM_CAR (code
)))
2557 if (SCM_ISYMP (SCM_CAR (code
)))
2559 scm_rec_mutex_lock (&source_mutex
);
2560 /* check for race condition */
2561 if (SCM_ISYMP (SCM_CAR (code
)))
2562 m_expand_body (code
, env
);
2563 scm_rec_mutex_unlock (&source_mutex
);
2568 SCM_XEVAL (SCM_CAR (code
), env
);
2570 next
= SCM_CDR (code
);
2572 return SCM_XEVALCAR (code
, env
);
2578 /* SECTION: This code is specific for the debugging support. One
2579 * branch is read when DEVAL isn't defined, the other when DEVAL is
2585 #define SCM_APPLY scm_apply
2586 #define PREP_APPLY(proc, args)
2588 #define RETURN(x) do { return x; } while (0)
2589 #ifdef STACK_CHECKING
2590 #ifndef NO_CEVAL_STACK_CHECKING
2591 #define EVAL_STACK_CHECKING
2598 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
2600 #define SCM_APPLY scm_dapply
2602 #define PREP_APPLY(p, l) \
2603 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
2605 #define ENTER_APPLY \
2607 SCM_SET_ARGSREADY (debug);\
2608 if (scm_check_apply_p && SCM_TRAPS_P)\
2609 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
2611 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
2612 SCM_SET_TRACED_FRAME (debug); \
2614 if (SCM_CHEAPTRAPS_P)\
2616 tmp = scm_make_debugobj (&debug);\
2617 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
2622 tmp = scm_make_continuation (&first);\
2624 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
2630 #define RETURN(e) do { proc = (e); goto exit; } while (0)
2631 #ifdef STACK_CHECKING
2632 #ifndef EVAL_STACK_CHECKING
2633 #define EVAL_STACK_CHECKING
2637 /* scm_ceval_ptr points to the currently selected evaluator.
2638 * *fixme*: Although efficiency is important here, this state variable
2639 * should probably not be a global. It should be related to the
2644 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
2646 /* scm_last_debug_frame contains a pointer to the last debugging
2647 * information stack frame. It is accessed very often from the
2648 * debugging evaluator, so it should probably not be indirectly
2649 * addressed. Better to save and restore it from the current root at
2653 /* scm_debug_eframe_size is the number of slots available for pseudo
2654 * stack frames at each real stack frame.
2657 long scm_debug_eframe_size
;
2659 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
2661 long scm_eval_stack
;
2663 scm_t_option scm_eval_opts
[] = {
2664 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
2667 scm_t_option scm_debug_opts
[] = {
2668 { SCM_OPTION_BOOLEAN
, "cheap", 1,
2669 "*Flyweight representation of the stack at traps." },
2670 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
2671 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
2672 { SCM_OPTION_BOOLEAN
, "procnames", 1,
2673 "Record procedure names at definition." },
2674 { SCM_OPTION_BOOLEAN
, "backwards", 0,
2675 "Display backtrace in anti-chronological order." },
2676 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
2677 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
2678 { SCM_OPTION_INTEGER
, "frames", 3,
2679 "Maximum number of tail-recursive frames in backtrace." },
2680 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
2681 "Maximal number of stored backtrace frames." },
2682 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
2683 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
2684 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
2685 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
2686 { 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."}
2689 scm_t_option scm_evaluator_trap_table
[] = {
2690 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
2691 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
2692 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
2693 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
2694 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
2695 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
2696 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
2699 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
2701 "Option interface for the evaluation options. Instead of using\n"
2702 "this procedure directly, use the procedures @code{eval-enable},\n"
2703 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
2704 #define FUNC_NAME s_scm_eval_options_interface
2708 ans
= scm_options (setting
,
2712 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
2719 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
2721 "Option interface for the evaluator trap options.")
2722 #define FUNC_NAME s_scm_evaluator_traps
2726 ans
= scm_options (setting
,
2727 scm_evaluator_trap_table
,
2728 SCM_N_EVALUATOR_TRAPS
,
2730 SCM_RESET_DEBUG_MODE
;
2738 deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
2740 SCM
*results
= lloc
, res
;
2741 while (SCM_CONSP (l
))
2743 res
= EVALCAR (l
, env
);
2745 *lloc
= scm_list_1 (res
);
2746 lloc
= SCM_CDRLOC (*lloc
);
2750 scm_wrong_num_args (proc
);
2757 /* SECTION: This code is compiled twice.
2761 /* Update the toplevel environment frame ENV so that it refers to the
2762 * current module. */
2763 #define UPDATE_TOPLEVEL_ENV(env) \
2765 SCM p = scm_current_module_lookup_closure (); \
2766 if (p != SCM_CAR (env)) \
2767 env = scm_top_level_env (p); \
2771 #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
2772 ASSERT_SYNTAX (!SCM_EQ_P ((x), SCM_EOL), s_empty_combination, x)
2775 /* This is the evaluator. Like any real monster, it has three heads:
2777 * scm_ceval is the non-debugging evaluator, scm_deval is the debugging
2778 * version. Both are implemented using a common code base, using the
2779 * following mechanism: SCM_CEVAL is a macro, which is either defined to
2780 * scm_ceval or scm_deval. Thus, there is no function SCM_CEVAL, but the code
2781 * for SCM_CEVAL actually compiles to either scm_ceval or scm_deval. When
2782 * SCM_CEVAL is defined to scm_ceval, it is known that the macro DEVAL is not
2783 * defined. When SCM_CEVAL is defined to scm_deval, then the macro DEVAL is
2784 * known to be defined. Thus, in SCM_CEVAL parts for the debugging evaluator
2785 * are enclosed within #ifdef DEVAL ... #endif.
2787 * All three (scm_ceval, scm_deval and their common implementation SCM_CEVAL)
2788 * take two input parameters, x and env: x is a single expression to be
2789 * evalutated. env is the environment in which bindings are searched.
2791 * x is known to be a cell (i. e. a pair or any other non-immediate). Since x
2792 * is a single expression, it is necessarily in a tail position. If x is just
2793 * a call to another function like in the expression (foo exp1 exp2 ...), the
2794 * realization of that call therefore _must_not_ increase stack usage (the
2795 * evaluation of exp1, exp2 etc., however, may do so). This is realized by
2796 * making extensive use of 'goto' statements within the evaluator: The gotos
2797 * replace recursive calls to SCM_CEVAL, thus re-using the same stack frame
2798 * that SCM_CEVAL was already using. If, however, x represents some form that
2799 * requires to evaluate a sequence of expressions like (begin exp1 exp2 ...),
2800 * then recursive calls to SCM_CEVAL are performed for all but the last
2801 * expression of that sequence. */
2805 scm_ceval (SCM x
, SCM env
)
2811 scm_deval (SCM x
, SCM env
)
2816 SCM_CEVAL (SCM x
, SCM env
)
2820 scm_t_debug_frame debug
;
2821 scm_t_debug_info
*debug_info_end
;
2822 debug
.prev
= scm_last_debug_frame
;
2825 * The debug.vect contains twice as much scm_t_debug_info frames as the
2826 * user has specified with (debug-set! frames <n>).
2828 * Even frames are eval frames, odd frames are apply frames.
2830 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
2831 * sizeof (scm_t_debug_info
));
2832 debug
.info
= debug
.vect
;
2833 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
2834 scm_last_debug_frame
= &debug
;
2836 #ifdef EVAL_STACK_CHECKING
2837 if (scm_stack_checking_enabled_p
&& SCM_STACK_OVERFLOW_P (&proc
))
2840 debug
.info
->e
.exp
= x
;
2841 debug
.info
->e
.env
= env
;
2843 scm_report_stack_overflow ();
2853 SCM_CLEAR_ARGSREADY (debug
);
2854 if (SCM_OVERFLOWP (debug
))
2857 * In theory, this should be the only place where it is necessary to
2858 * check for space in debug.vect since both eval frames and
2859 * available space are even.
2861 * For this to be the case, however, it is necessary that primitive
2862 * special forms which jump back to `loop', `begin' or some similar
2863 * label call PREP_APPLY.
2865 else if (++debug
.info
>= debug_info_end
)
2867 SCM_SET_OVERFLOW (debug
);
2872 debug
.info
->e
.exp
= x
;
2873 debug
.info
->e
.env
= env
;
2874 if (scm_check_entry_p
&& SCM_TRAPS_P
)
2876 if (SCM_ENTER_FRAME_P
2877 || (SCM_BREAKPOINTS_P
&& scm_c_source_property_breakpoint_p (x
)))
2880 SCM tail
= SCM_BOOL (SCM_TAILRECP (debug
));
2881 SCM_SET_TAILREC (debug
);
2882 if (SCM_CHEAPTRAPS_P
)
2883 stackrep
= scm_make_debugobj (&debug
);
2887 SCM val
= scm_make_continuation (&first
);
2897 /* This gives the possibility for the debugger to
2898 modify the source expression before evaluation. */
2903 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
2904 scm_sym_enter_frame
,
2907 scm_unmemocopy (x
, env
));
2914 switch (SCM_TYP7 (x
))
2916 case SCM_BIT7 (SCM_IM_AND
):
2918 while (!SCM_NULLP (SCM_CDR (x
)))
2920 SCM test_result
= EVALCAR (x
, env
);
2921 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
2922 RETURN (SCM_BOOL_F
);
2926 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2929 case SCM_BIT7 (SCM_IM_BEGIN
):
2932 RETURN (SCM_UNSPECIFIED
);
2934 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2937 /* If we are on toplevel with a lookup closure, we need to sync
2938 with the current module. */
2939 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
2941 UPDATE_TOPLEVEL_ENV (env
);
2942 while (!SCM_NULLP (SCM_CDR (x
)))
2945 UPDATE_TOPLEVEL_ENV (env
);
2951 goto nontoplevel_begin
;
2954 while (!SCM_NULLP (SCM_CDR (x
)))
2956 SCM form
= SCM_CAR (x
);
2959 if (SCM_ISYMP (form
))
2961 scm_rec_mutex_lock (&source_mutex
);
2962 /* check for race condition */
2963 if (SCM_ISYMP (SCM_CAR (x
)))
2964 m_expand_body (x
, env
);
2965 scm_rec_mutex_unlock (&source_mutex
);
2966 goto nontoplevel_begin
;
2969 SCM_VALIDATE_NON_EMPTY_COMBINATION (form
);
2972 SCM_CEVAL (form
, env
);
2978 /* scm_eval last form in list */
2979 SCM last_form
= SCM_CAR (x
);
2981 if (SCM_CONSP (last_form
))
2983 /* This is by far the most frequent case. */
2985 goto loop
; /* tail recurse */
2987 else if (SCM_IMP (last_form
))
2988 RETURN (SCM_EVALIM (last_form
, env
));
2989 else if (SCM_VARIABLEP (last_form
))
2990 RETURN (SCM_VARIABLE_REF (last_form
));
2991 else if (SCM_SYMBOLP (last_form
))
2992 RETURN (*scm_lookupcar (x
, env
, 1));
2998 case SCM_BIT7 (SCM_IM_CASE
):
3001 SCM key
= EVALCAR (x
, env
);
3003 while (!SCM_NULLP (x
))
3005 SCM clause
= SCM_CAR (x
);
3006 SCM labels
= SCM_CAR (clause
);
3007 if (SCM_EQ_P (labels
, SCM_IM_ELSE
))
3009 x
= SCM_CDR (clause
);
3010 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3013 while (!SCM_NULLP (labels
))
3015 SCM label
= SCM_CAR (labels
);
3016 if (SCM_EQ_P (label
, key
) || !SCM_FALSEP (scm_eqv_p (label
, key
)))
3018 x
= SCM_CDR (clause
);
3019 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3022 labels
= SCM_CDR (labels
);
3027 RETURN (SCM_UNSPECIFIED
);
3030 case SCM_BIT7 (SCM_IM_COND
):
3032 while (!SCM_NULLP (x
))
3034 SCM clause
= SCM_CAR (x
);
3035 if (SCM_EQ_P (SCM_CAR (clause
), SCM_IM_ELSE
))
3037 x
= SCM_CDR (clause
);
3038 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3043 arg1
= EVALCAR (clause
, env
);
3044 if (!SCM_FALSEP (arg1
) && !SCM_NILP (arg1
))
3046 x
= SCM_CDR (clause
);
3049 else if (!SCM_EQ_P (SCM_CAR (x
), SCM_IM_ARROW
))
3051 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3057 proc
= EVALCAR (proc
, env
);
3058 PREP_APPLY (proc
, scm_list_1 (arg1
));
3066 RETURN (SCM_UNSPECIFIED
);
3069 case SCM_BIT7 (SCM_IM_DO
):
3072 /* Compute the initialization values and the initial environment. */
3073 SCM init_forms
= SCM_CAR (x
);
3074 SCM init_values
= SCM_EOL
;
3075 while (!SCM_NULLP (init_forms
))
3077 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3078 init_forms
= SCM_CDR (init_forms
);
3081 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
3085 SCM test_form
= SCM_CAR (x
);
3086 SCM body_forms
= SCM_CADR (x
);
3087 SCM step_forms
= SCM_CDDR (x
);
3089 SCM test_result
= EVALCAR (test_form
, env
);
3091 while (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
3094 /* Evaluate body forms. */
3096 for (temp_forms
= body_forms
;
3097 !SCM_NULLP (temp_forms
);
3098 temp_forms
= SCM_CDR (temp_forms
))
3100 SCM form
= SCM_CAR (temp_forms
);
3101 /* Dirk:FIXME: We only need to eval forms, that may have a
3102 * side effect here. This is only true for forms that start
3103 * with a pair. All others are just constants. However,
3104 * since in the common case there is no constant expression
3105 * in a body of a do form, we just check for immediates here
3106 * and have SCM_CEVAL take care of other cases. In the long
3107 * run it would make sense to get rid of this test and have
3108 * the macro transformer of 'do' eliminate all forms that
3109 * have no sideeffect. */
3110 if (!SCM_IMP (form
))
3111 SCM_CEVAL (form
, env
);
3116 /* Evaluate the step expressions. */
3118 SCM step_values
= SCM_EOL
;
3119 for (temp_forms
= step_forms
;
3120 !SCM_NULLP (temp_forms
);
3121 temp_forms
= SCM_CDR (temp_forms
))
3123 SCM value
= EVALCAR (temp_forms
, env
);
3124 step_values
= scm_cons (value
, step_values
);
3126 env
= SCM_EXTEND_ENV (SCM_CAAR (env
),
3131 test_result
= EVALCAR (test_form
, env
);
3136 RETURN (SCM_UNSPECIFIED
);
3137 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3138 goto nontoplevel_begin
;
3141 case SCM_BIT7 (SCM_IM_IF
):
3144 SCM test_result
= EVALCAR (x
, env
);
3145 x
= SCM_CDR (x
); /* then expression */
3146 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
3148 x
= SCM_CDR (x
); /* else expression */
3150 RETURN (SCM_UNSPECIFIED
);
3153 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3157 case SCM_BIT7 (SCM_IM_LET
):
3160 SCM init_forms
= SCM_CADR (x
);
3161 SCM init_values
= SCM_EOL
;
3164 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3165 init_forms
= SCM_CDR (init_forms
);
3167 while (!SCM_NULLP (init_forms
));
3168 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
3171 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3172 goto nontoplevel_begin
;
3175 case SCM_BIT7 (SCM_IM_LETREC
):
3177 env
= SCM_EXTEND_ENV (SCM_CAR (x
), undefineds
, env
);
3180 SCM init_forms
= SCM_CAR (x
);
3181 SCM init_values
= SCM_EOL
;
3184 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3185 init_forms
= SCM_CDR (init_forms
);
3187 while (!SCM_NULLP (init_forms
));
3188 SCM_SETCDR (SCM_CAR (env
), init_values
);
3191 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3192 goto nontoplevel_begin
;
3195 case SCM_BIT7 (SCM_IM_LETSTAR
):
3198 SCM bindings
= SCM_CAR (x
);
3199 if (SCM_NULLP (bindings
))
3200 env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
3205 SCM name
= SCM_CAR (bindings
);
3206 SCM init
= SCM_CDR (bindings
);
3207 env
= SCM_EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
3208 bindings
= SCM_CDR (init
);
3210 while (!SCM_NULLP (bindings
));
3214 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3215 goto nontoplevel_begin
;
3218 case SCM_BIT7 (SCM_IM_OR
):
3220 while (!SCM_NULLP (SCM_CDR (x
)))
3222 SCM val
= EVALCAR (x
, env
);
3223 if (!SCM_FALSEP (val
) && !SCM_NILP (val
))
3228 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3232 case SCM_BIT7 (SCM_IM_LAMBDA
):
3233 RETURN (scm_closure (SCM_CDR (x
), env
));
3236 case SCM_BIT7 (SCM_IM_QUOTE
):
3237 RETURN (SCM_CADR (x
));
3240 case SCM_BIT7 (SCM_IM_SET_X
):
3244 SCM variable
= SCM_CAR (x
);
3245 if (SCM_ILOCP (variable
))
3246 location
= scm_ilookup (variable
, env
);
3247 else if (SCM_VARIABLEP (variable
))
3248 location
= SCM_VARIABLE_LOC (variable
);
3249 else /* (SCM_SYMBOLP (variable)) is known to be true */
3250 location
= scm_lookupcar (x
, env
, 1);
3252 *location
= EVALCAR (x
, env
);
3254 RETURN (SCM_UNSPECIFIED
);
3257 /* new syntactic forms go here. */
3258 case SCM_BIT7 (SCM_MAKISYM (0)):
3260 switch (SCM_ISYMNUM (proc
))
3264 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
3265 /* Evaluate the procedure to be applied. */
3267 proc
= EVALCAR (x
, env
);
3268 PREP_APPLY (proc
, SCM_EOL
);
3270 /* Evaluate the argument holding the list of arguments */
3272 arg1
= EVALCAR (x
, env
);
3275 /* Go here to tail-apply a procedure. PROC is the procedure and
3276 * ARG1 is the list of arguments. PREP_APPLY must have been called
3277 * before jumping to apply_proc. */
3278 if (SCM_CLOSUREP (proc
))
3280 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3282 debug
.info
->a
.args
= arg1
;
3284 if (scm_badargsp (formals
, arg1
))
3285 scm_wrong_num_args (proc
);
3287 /* Copy argument list */
3288 if (SCM_NULL_OR_NIL_P (arg1
))
3289 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
3292 SCM args
= scm_list_1 (SCM_CAR (arg1
));
3294 arg1
= SCM_CDR (arg1
);
3295 while (!SCM_NULL_OR_NIL_P (arg1
))
3297 SCM new_tail
= scm_list_1 (SCM_CAR (arg1
));
3298 SCM_SETCDR (tail
, new_tail
);
3300 arg1
= SCM_CDR (arg1
);
3302 env
= SCM_EXTEND_ENV (formals
, args
, SCM_ENV (proc
));
3305 x
= SCM_CLOSURE_BODY (proc
);
3306 goto nontoplevel_begin
;
3311 RETURN (SCM_APPLY (proc
, arg1
, SCM_EOL
));
3315 case (SCM_ISYMNUM (SCM_IM_CONT
)):
3318 SCM val
= scm_make_continuation (&first
);
3326 proc
= EVALCAR (proc
, env
);
3327 PREP_APPLY (proc
, scm_list_1 (arg1
));
3334 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
3335 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
3338 case (SCM_ISYMNUM (SCM_IM_FUTURE
)):
3339 RETURN (scm_i_make_future (scm_closure (SCM_CDR (x
), env
)));
3342 /* PLACEHOLDER for case (SCM_ISYMNUM (SCM_IM_DISPATCH)): The
3343 following code (type_dispatch) is intended to be the tail
3344 of the case clause for the internal macro
3345 SCM_IM_DISPATCH. Please don't remove it from this
3346 location without discussing it with Mikael
3347 <djurfeldt@nada.kth.se> */
3349 /* The type dispatch code is duplicated below
3350 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
3351 * cuts down execution time for type dispatch to 50%. */
3352 type_dispatch
: /* inputs: x, arg1 */
3353 /* Type dispatch means to determine from the types of the function
3354 * arguments (i. e. the 'signature' of the call), which method from
3355 * a generic function is to be called. This process of selecting
3356 * the right method takes some time. To speed it up, guile uses
3357 * caching: Together with the macro call to dispatch the signatures
3358 * of some previous calls to that generic function from the same
3359 * place are stored (in the code!) in a cache that we call the
3360 * 'method cache'. This is done since it is likely, that
3361 * consecutive calls to dispatch from that position in the code will
3362 * have the same signature. Thus, the type dispatch works as
3363 * follows: First, determine a hash value from the signature of the
3364 * actual arguments. Second, use this hash value as an index to
3365 * find that same signature in the method cache stored at this
3366 * position in the code. If found, you have also found the
3367 * corresponding method that belongs to that signature. If the
3368 * signature is not found in the method cache, you have to perform a
3369 * full search over all signatures stored with the generic
3372 unsigned long int specializers
;
3373 unsigned long int hash_value
;
3374 unsigned long int cache_end_pos
;
3375 unsigned long int mask
;
3379 SCM z
= SCM_CDDR (x
);
3380 SCM tmp
= SCM_CADR (z
);
3381 specializers
= SCM_INUM (SCM_CAR (z
));
3383 /* Compute a hash value for searching the method cache. There
3384 * are two variants for computing the hash value, a (rather)
3385 * complicated one, and a simple one. For the complicated one
3386 * explained below, tmp holds a number that is used in the
3388 if (SCM_INUMP (tmp
))
3390 /* Use the signature of the actual arguments to determine
3391 * the hash value. This is done as follows: Each class has
3392 * an array of random numbers, that are determined when the
3393 * class is created. The integer 'hashset' is an index into
3394 * that array of random numbers. Now, from all classes that
3395 * are part of the signature of the actual arguments, the
3396 * random numbers at index 'hashset' are taken and summed
3397 * up, giving the hash value. The value of 'hashset' is
3398 * stored at the call to dispatch. This allows to have
3399 * different 'formulas' for calculating the hash value at
3400 * different places where dispatch is called. This allows
3401 * to optimize the hash formula at every individual place
3402 * where dispatch is called, such that hopefully the hash
3403 * value that is computed will directly point to the right
3404 * method in the method cache. */
3405 unsigned long int hashset
= SCM_INUM (tmp
);
3406 unsigned long int counter
= specializers
+ 1;
3409 while (!SCM_NULLP (tmp_arg
) && counter
!= 0)
3411 SCM
class = scm_class_of (SCM_CAR (tmp_arg
));
3412 hash_value
+= SCM_INSTANCE_HASH (class, hashset
);
3413 tmp_arg
= SCM_CDR (tmp_arg
);
3417 method_cache
= SCM_CADR (z
);
3418 mask
= SCM_INUM (SCM_CAR (z
));
3420 cache_end_pos
= hash_value
;
3424 /* This method of determining the hash value is much
3425 * simpler: Set the hash value to zero and just perform a
3426 * linear search through the method cache. */
3428 mask
= (unsigned long int) ((long) -1);
3430 cache_end_pos
= SCM_VECTOR_LENGTH (method_cache
);
3435 /* Search the method cache for a method with a matching
3436 * signature. Start the search at position 'hash_value'. The
3437 * hashing implementation uses linear probing for conflict
3438 * resolution, that is, if the signature in question is not
3439 * found at the starting index in the hash table, the next table
3440 * entry is tried, and so on, until in the worst case the whole
3441 * cache has been searched, but still the signature has not been
3446 SCM args
= arg1
; /* list of arguments */
3447 z
= SCM_VELTS (method_cache
)[hash_value
];
3448 while (!SCM_NULLP (args
))
3450 /* More arguments than specifiers => CLASS != ENV */
3451 SCM class_of_arg
= scm_class_of (SCM_CAR (args
));
3452 if (!SCM_EQ_P (class_of_arg
, SCM_CAR (z
)))
3454 args
= SCM_CDR (args
);
3457 /* Fewer arguments than specifiers => CAR != ENV */
3458 if (SCM_NULLP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
)))
3461 hash_value
= (hash_value
+ 1) & mask
;
3462 } while (hash_value
!= cache_end_pos
);
3464 /* No appropriate method was found in the cache. */
3465 z
= scm_memoize_method (x
, arg1
);
3467 apply_cmethod
: /* inputs: z, arg1 */
3469 SCM formals
= SCM_CMETHOD_FORMALS (z
);
3470 env
= SCM_EXTEND_ENV (formals
, arg1
, SCM_CMETHOD_ENV (z
));
3471 x
= SCM_CMETHOD_BODY (z
);
3472 goto nontoplevel_begin
;
3478 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
3481 SCM instance
= EVALCAR (x
, env
);
3482 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
3483 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance
) [slot
]));
3487 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
3490 SCM instance
= EVALCAR (x
, env
);
3491 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
3492 SCM value
= EVALCAR (SCM_CDDR (x
), env
);
3493 SCM_STRUCT_DATA (instance
) [slot
] = SCM_UNPACK (value
);
3494 RETURN (SCM_UNSPECIFIED
);
3498 #if SCM_ENABLE_ELISP
3500 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
3502 SCM test_form
= SCM_CDR (x
);
3503 x
= SCM_CDR (test_form
);
3504 while (!SCM_NULL_OR_NIL_P (x
))
3506 SCM test_result
= EVALCAR (test_form
, env
);
3507 if (!(SCM_FALSEP (test_result
)
3508 || SCM_NULL_OR_NIL_P (test_result
)))
3510 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
3511 RETURN (test_result
);
3512 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3517 test_form
= SCM_CDR (x
);
3518 x
= SCM_CDR (test_form
);
3522 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3526 #endif /* SCM_ENABLE_ELISP */
3528 case (SCM_ISYMNUM (SCM_IM_BIND
)):
3530 SCM vars
, exps
, vals
;
3533 vars
= SCM_CAAR (x
);
3534 exps
= SCM_CDAR (x
);
3536 while (!SCM_NULLP (exps
))
3538 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
3539 exps
= SCM_CDR (exps
);
3542 scm_swap_bindings (vars
, vals
);
3543 scm_dynwinds
= scm_acons (vars
, vals
, scm_dynwinds
);
3545 /* Ignore all but the last evaluation result. */
3546 for (x
= SCM_CDR (x
); !SCM_NULLP (SCM_CDR (x
)); x
= SCM_CDR (x
))
3548 if (SCM_CONSP (SCM_CAR (x
)))
3549 SCM_CEVAL (SCM_CAR (x
), env
);
3551 proc
= EVALCAR (x
, env
);
3553 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
3554 scm_swap_bindings (vars
, vals
);
3560 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
3565 producer
= EVALCAR (x
, env
);
3567 proc
= EVALCAR (x
, env
); /* proc is the consumer. */
3568 arg1
= SCM_APPLY (producer
, SCM_EOL
, SCM_EOL
);
3569 if (SCM_VALUESP (arg1
))
3571 /* The list of arguments is not copied. Rather, it is assumed
3572 * that this has been done by the 'values' procedure. */
3573 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
3577 arg1
= scm_list_1 (arg1
);
3579 PREP_APPLY (proc
, arg1
);
3594 case scm_tc7_vector
:
3598 case scm_tc7_byvect
:
3605 #if SCM_SIZEOF_LONG_LONG != 0
3606 case scm_tc7_llvect
:
3609 case scm_tc7_number
:
3610 case scm_tc7_string
:
3612 case scm_tcs_closures
:
3616 case scm_tcs_struct
:
3620 case scm_tc7_symbol
:
3621 /* Only happens when called at top level. */
3622 x
= scm_cons (x
, SCM_UNDEFINED
);
3623 RETURN (*scm_lookupcar (x
, env
, 1));
3625 case scm_tc7_variable
:
3626 RETURN (SCM_VARIABLE_REF(x
));
3628 case SCM_BIT7 (SCM_ILOC00
):
3629 proc
= *scm_ilookup (SCM_CAR (x
), env
);
3632 case scm_tcs_cons_nimcar
:
3633 if (SCM_SYMBOLP (SCM_CAR (x
)))
3635 SCM orig_sym
= SCM_CAR (x
);
3637 SCM
*location
= scm_lookupcar1 (x
, env
, 1);
3638 if (location
== NULL
)
3640 /* we have lost the race, start again. */
3646 if (SCM_MACROP (proc
))
3648 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
3650 handle_a_macro
: /* inputs: x, env, proc */
3652 /* Set a flag during macro expansion so that macro
3653 application frames can be deleted from the backtrace. */
3654 SCM_SET_MACROEXP (debug
);
3656 arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
3657 scm_cons (env
, scm_listofnull
));
3659 SCM_CLEAR_MACROEXP (debug
);
3661 switch (SCM_MACRO_TYPE (proc
))
3665 if (scm_ilength (arg1
) <= 0)
3666 arg1
= scm_list_2 (SCM_IM_BEGIN
, arg1
);
3668 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
3671 SCM_SETCAR (x
, SCM_CAR (arg1
));
3672 SCM_SETCDR (x
, SCM_CDR (arg1
));
3676 /* Prevent memoizing of debug info expression. */
3677 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
3682 SCM_SETCAR (x
, SCM_CAR (arg1
));
3683 SCM_SETCDR (x
, SCM_CDR (arg1
));
3685 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3687 #if SCM_ENABLE_DEPRECATED == 1
3692 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3704 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
3707 if (SCM_MACROP (proc
))
3708 goto handle_a_macro
;
3712 evapply
: /* inputs: x, proc */
3713 PREP_APPLY (proc
, SCM_EOL
);
3714 if (SCM_NULLP (SCM_CDR (x
))) {
3717 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3718 switch (SCM_TYP7 (proc
))
3719 { /* no arguments given */
3720 case scm_tc7_subr_0
:
3721 RETURN (SCM_SUBRF (proc
) ());
3722 case scm_tc7_subr_1o
:
3723 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
3725 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
3726 case scm_tc7_rpsubr
:
3727 RETURN (SCM_BOOL_T
);
3729 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
3731 if (!SCM_SMOB_APPLICABLE_P (proc
))
3733 RETURN (SCM_SMOB_APPLY_0 (proc
));
3736 proc
= SCM_CCLO_SUBR (proc
);
3738 debug
.info
->a
.proc
= proc
;
3739 debug
.info
->a
.args
= scm_list_1 (arg1
);
3743 proc
= SCM_PROCEDURE (proc
);
3745 debug
.info
->a
.proc
= proc
;
3747 if (!SCM_CLOSUREP (proc
))
3750 case scm_tcs_closures
:
3752 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3753 if (SCM_CONSP (formals
))
3754 goto umwrongnumargs
;
3755 x
= SCM_CLOSURE_BODY (proc
);
3756 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
3757 goto nontoplevel_begin
;
3759 case scm_tcs_struct
:
3760 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3762 x
= SCM_ENTITY_PROCEDURE (proc
);
3766 else if (SCM_I_OPERATORP (proc
))
3769 proc
= (SCM_I_ENTITYP (proc
)
3770 ? SCM_ENTITY_PROCEDURE (proc
)
3771 : SCM_OPERATOR_PROCEDURE (proc
));
3773 debug
.info
->a
.proc
= proc
;
3774 debug
.info
->a
.args
= scm_list_1 (arg1
);
3780 case scm_tc7_subr_1
:
3781 case scm_tc7_subr_2
:
3782 case scm_tc7_subr_2o
:
3785 case scm_tc7_subr_3
:
3786 case scm_tc7_lsubr_2
:
3789 scm_wrong_num_args (proc
);
3792 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
3796 /* must handle macros by here */
3799 arg1
= EVALCAR (x
, env
);
3801 scm_wrong_num_args (proc
);
3803 debug
.info
->a
.args
= scm_list_1 (arg1
);
3811 evap1
: /* inputs: proc, arg1 */
3812 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3813 switch (SCM_TYP7 (proc
))
3814 { /* have one argument in arg1 */
3815 case scm_tc7_subr_2o
:
3816 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3817 case scm_tc7_subr_1
:
3818 case scm_tc7_subr_1o
:
3819 RETURN (SCM_SUBRF (proc
) (arg1
));
3821 if (SCM_INUMP (arg1
))
3823 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3825 else if (SCM_REALP (arg1
))
3827 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3829 else if (SCM_BIGP (arg1
))
3831 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3833 else if (SCM_FRACTIONP (arg1
))
3835 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
3837 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3838 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3841 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
3844 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
3845 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3846 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3851 case scm_tc7_rpsubr
:
3852 RETURN (SCM_BOOL_T
);
3854 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3857 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3859 RETURN (SCM_SUBRF (proc
) (scm_list_1 (arg1
)));
3862 if (!SCM_SMOB_APPLICABLE_P (proc
))
3864 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
3868 proc
= SCM_CCLO_SUBR (proc
);
3870 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
3871 debug
.info
->a
.proc
= proc
;
3875 proc
= SCM_PROCEDURE (proc
);
3877 debug
.info
->a
.proc
= proc
;
3879 if (!SCM_CLOSUREP (proc
))
3882 case scm_tcs_closures
:
3885 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3886 if (SCM_NULLP (formals
)
3887 || (SCM_CONSP (formals
) && SCM_CONSP (SCM_CDR (formals
))))
3888 goto umwrongnumargs
;
3889 x
= SCM_CLOSURE_BODY (proc
);
3891 env
= SCM_EXTEND_ENV (formals
,
3895 env
= SCM_EXTEND_ENV (formals
,
3899 goto nontoplevel_begin
;
3901 case scm_tcs_struct
:
3902 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3904 x
= SCM_ENTITY_PROCEDURE (proc
);
3906 arg1
= debug
.info
->a
.args
;
3908 arg1
= scm_list_1 (arg1
);
3912 else if (SCM_I_OPERATORP (proc
))
3916 proc
= (SCM_I_ENTITYP (proc
)
3917 ? SCM_ENTITY_PROCEDURE (proc
)
3918 : SCM_OPERATOR_PROCEDURE (proc
));
3920 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
3921 debug
.info
->a
.proc
= proc
;
3927 case scm_tc7_subr_2
:
3928 case scm_tc7_subr_0
:
3929 case scm_tc7_subr_3
:
3930 case scm_tc7_lsubr_2
:
3931 scm_wrong_num_args (proc
);
3937 arg2
= EVALCAR (x
, env
);
3939 scm_wrong_num_args (proc
);
3941 { /* have two or more arguments */
3943 debug
.info
->a
.args
= scm_list_2 (arg1
, arg2
);
3946 if (SCM_NULLP (x
)) {
3949 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3950 switch (SCM_TYP7 (proc
))
3951 { /* have two arguments */
3952 case scm_tc7_subr_2
:
3953 case scm_tc7_subr_2o
:
3954 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3957 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3959 RETURN (SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
)));
3961 case scm_tc7_lsubr_2
:
3962 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
));
3963 case scm_tc7_rpsubr
:
3965 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3967 if (!SCM_SMOB_APPLICABLE_P (proc
))
3969 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
));
3973 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3974 scm_cons (proc
, debug
.info
->a
.args
),
3977 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3978 scm_cons2 (proc
, arg1
,
3985 case scm_tcs_struct
:
3986 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3988 x
= SCM_ENTITY_PROCEDURE (proc
);
3990 arg1
= debug
.info
->a
.args
;
3992 arg1
= scm_list_2 (arg1
, arg2
);
3996 else if (SCM_I_OPERATORP (proc
))
4000 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
4001 ? SCM_ENTITY_PROCEDURE (proc
)
4002 : SCM_OPERATOR_PROCEDURE (proc
),
4003 scm_cons (proc
, debug
.info
->a
.args
),
4006 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
4007 ? SCM_ENTITY_PROCEDURE (proc
)
4008 : SCM_OPERATOR_PROCEDURE (proc
),
4009 scm_cons2 (proc
, arg1
,
4019 case scm_tc7_subr_0
:
4022 case scm_tc7_subr_1o
:
4023 case scm_tc7_subr_1
:
4024 case scm_tc7_subr_3
:
4025 scm_wrong_num_args (proc
);
4029 proc
= SCM_PROCEDURE (proc
);
4031 debug
.info
->a
.proc
= proc
;
4033 if (!SCM_CLOSUREP (proc
))
4036 case scm_tcs_closures
:
4039 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4040 if (SCM_NULLP (formals
)
4041 || (SCM_CONSP (formals
)
4042 && (SCM_NULLP (SCM_CDR (formals
))
4043 || (SCM_CONSP (SCM_CDR (formals
))
4044 && SCM_CONSP (SCM_CDDR (formals
))))))
4045 goto umwrongnumargs
;
4047 env
= SCM_EXTEND_ENV (formals
,
4051 env
= SCM_EXTEND_ENV (formals
,
4052 scm_list_2 (arg1
, arg2
),
4055 x
= SCM_CLOSURE_BODY (proc
);
4056 goto nontoplevel_begin
;
4061 scm_wrong_num_args (proc
);
4063 debug
.info
->a
.args
= scm_cons2 (arg1
, arg2
,
4064 deval_args (x
, env
, proc
,
4065 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
4069 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4070 switch (SCM_TYP7 (proc
))
4071 { /* have 3 or more arguments */
4073 case scm_tc7_subr_3
:
4074 if (!SCM_NULLP (SCM_CDR (x
)))
4075 scm_wrong_num_args (proc
);
4077 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4078 SCM_CADDR (debug
.info
->a
.args
)));
4080 arg1
= SCM_SUBRF(proc
)(arg1
, arg2
);
4081 arg2
= SCM_CDDR (debug
.info
->a
.args
);
4084 arg1
= SCM_SUBRF(proc
)(arg1
, SCM_CAR (arg2
));
4085 arg2
= SCM_CDR (arg2
);
4087 while (SCM_NIMP (arg2
));
4089 case scm_tc7_rpsubr
:
4090 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
4091 RETURN (SCM_BOOL_F
);
4092 arg1
= SCM_CDDR (debug
.info
->a
.args
);
4095 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (arg1
))))
4096 RETURN (SCM_BOOL_F
);
4097 arg2
= SCM_CAR (arg1
);
4098 arg1
= SCM_CDR (arg1
);
4100 while (SCM_NIMP (arg1
));
4101 RETURN (SCM_BOOL_T
);
4102 case scm_tc7_lsubr_2
:
4103 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4104 SCM_CDDR (debug
.info
->a
.args
)));
4106 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4108 if (!SCM_SMOB_APPLICABLE_P (proc
))
4110 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4111 SCM_CDDR (debug
.info
->a
.args
)));
4115 proc
= SCM_PROCEDURE (proc
);
4116 debug
.info
->a
.proc
= proc
;
4117 if (!SCM_CLOSUREP (proc
))
4120 case scm_tcs_closures
:
4122 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4123 if (SCM_NULLP (formals
)
4124 || (SCM_CONSP (formals
)
4125 && (SCM_NULLP (SCM_CDR (formals
))
4126 || (SCM_CONSP (SCM_CDR (formals
))
4127 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4128 goto umwrongnumargs
;
4129 SCM_SET_ARGSREADY (debug
);
4130 env
= SCM_EXTEND_ENV (formals
,
4133 x
= SCM_CLOSURE_BODY (proc
);
4134 goto nontoplevel_begin
;
4137 case scm_tc7_subr_3
:
4138 if (!SCM_NULLP (SCM_CDR (x
)))
4139 scm_wrong_num_args (proc
);
4141 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, EVALCAR (x
, env
)));
4143 arg1
= SCM_SUBRF (proc
) (arg1
, arg2
);
4146 arg1
= SCM_SUBRF(proc
)(arg1
, EVALCAR(x
, env
));
4149 while (!SCM_NULLP (x
));
4151 case scm_tc7_rpsubr
:
4152 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
4153 RETURN (SCM_BOOL_F
);
4156 arg1
= EVALCAR (x
, env
);
4157 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, arg1
)))
4158 RETURN (SCM_BOOL_F
);
4162 while (!SCM_NULLP (x
));
4163 RETURN (SCM_BOOL_T
);
4164 case scm_tc7_lsubr_2
:
4165 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
4167 RETURN (SCM_SUBRF (proc
) (scm_cons2 (arg1
,
4169 scm_eval_args (x
, env
, proc
))));
4171 if (!SCM_SMOB_APPLICABLE_P (proc
))
4173 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4174 scm_eval_args (x
, env
, proc
)));
4178 proc
= SCM_PROCEDURE (proc
);
4179 if (!SCM_CLOSUREP (proc
))
4182 case scm_tcs_closures
:
4184 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4185 if (SCM_NULLP (formals
)
4186 || (SCM_CONSP (formals
)
4187 && (SCM_NULLP (SCM_CDR (formals
))
4188 || (SCM_CONSP (SCM_CDR (formals
))
4189 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4190 goto umwrongnumargs
;
4191 env
= SCM_EXTEND_ENV (formals
,
4194 scm_eval_args (x
, env
, proc
)),
4196 x
= SCM_CLOSURE_BODY (proc
);
4197 goto nontoplevel_begin
;
4200 case scm_tcs_struct
:
4201 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4204 arg1
= debug
.info
->a
.args
;
4206 arg1
= scm_cons2 (arg1
, arg2
, scm_eval_args (x
, env
, proc
));
4208 x
= SCM_ENTITY_PROCEDURE (proc
);
4211 else if (SCM_I_OPERATORP (proc
))
4215 case scm_tc7_subr_2
:
4216 case scm_tc7_subr_1o
:
4217 case scm_tc7_subr_2o
:
4218 case scm_tc7_subr_0
:
4221 case scm_tc7_subr_1
:
4222 scm_wrong_num_args (proc
);
4230 if (scm_check_exit_p
&& SCM_TRAPS_P
)
4231 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
4233 SCM_CLEAR_TRACED_FRAME (debug
);
4234 if (SCM_CHEAPTRAPS_P
)
4235 arg1
= scm_make_debugobj (&debug
);
4239 SCM val
= scm_make_continuation (&first
);
4250 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
4254 scm_last_debug_frame
= debug
.prev
;
4260 /* SECTION: This code is compiled once.
4267 /* Simple procedure calls
4271 scm_call_0 (SCM proc
)
4273 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
4277 scm_call_1 (SCM proc
, SCM arg1
)
4279 return scm_apply (proc
, arg1
, scm_listofnull
);
4283 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
4285 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
4289 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
4291 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
4295 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
4297 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
4298 scm_cons (arg4
, scm_listofnull
)));
4301 /* Simple procedure applies
4305 scm_apply_0 (SCM proc
, SCM args
)
4307 return scm_apply (proc
, args
, SCM_EOL
);
4311 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
4313 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
4317 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
4319 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
4323 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
4325 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
4329 /* This code processes the arguments to apply:
4331 (apply PROC ARG1 ... ARGS)
4333 Given a list (ARG1 ... ARGS), this function conses the ARG1
4334 ... arguments onto the front of ARGS, and returns the resulting
4335 list. Note that ARGS is a list; thus, the argument to this
4336 function is a list whose last element is a list.
4338 Apply calls this function, and applies PROC to the elements of the
4339 result. apply:nconc2last takes care of building the list of
4340 arguments, given (ARG1 ... ARGS).
4342 Rather than do new consing, apply:nconc2last destroys its argument.
4343 On that topic, this code came into my care with the following
4344 beautifully cryptic comment on that topic: "This will only screw
4345 you if you do (scm_apply scm_apply '( ... ))" If you know what
4346 they're referring to, send me a patch to this comment. */
4348 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
4350 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
4351 "conses the @var{arg1} @dots{} arguments onto the front of\n"
4352 "@var{args}, and returns the resulting list. Note that\n"
4353 "@var{args} is a list; thus, the argument to this function is\n"
4354 "a list whose last element is a list.\n"
4355 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
4356 "destroys its argument, so use with care.")
4357 #define FUNC_NAME s_scm_nconc2last
4360 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
4362 while (!SCM_NULLP (SCM_CDR (*lloc
))) /* Perhaps should be
4363 SCM_NULL_OR_NIL_P, but not
4364 needed in 99.99% of cases,
4365 and it could seriously hurt
4366 performance. - Neil */
4367 lloc
= SCM_CDRLOC (*lloc
);
4368 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
4369 *lloc
= SCM_CAR (*lloc
);
4377 /* SECTION: When DEVAL is defined this code yields scm_dapply.
4378 * It is compiled twice.
4383 scm_apply (SCM proc
, SCM arg1
, SCM args
)
4389 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
4394 /* Apply a function to a list of arguments.
4396 This function is exported to the Scheme level as taking two
4397 required arguments and a tail argument, as if it were:
4398 (lambda (proc arg1 . args) ...)
4399 Thus, if you just have a list of arguments to pass to a procedure,
4400 pass the list as ARG1, and '() for ARGS. If you have some fixed
4401 args, pass the first as ARG1, then cons any remaining fixed args
4402 onto the front of your argument list, and pass that as ARGS. */
4405 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
4408 scm_t_debug_frame debug
;
4409 scm_t_debug_info debug_vect_body
;
4410 debug
.prev
= scm_last_debug_frame
;
4411 debug
.status
= SCM_APPLYFRAME
;
4412 debug
.vect
= &debug_vect_body
;
4413 debug
.vect
[0].a
.proc
= proc
;
4414 debug
.vect
[0].a
.args
= SCM_EOL
;
4415 scm_last_debug_frame
= &debug
;
4418 return scm_dapply (proc
, arg1
, args
);
4421 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
4423 /* If ARGS is the empty list, then we're calling apply with only two
4424 arguments --- ARG1 is the list of arguments for PROC. Whatever
4425 the case, futz with things so that ARG1 is the first argument to
4426 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
4429 Setting the debug apply frame args this way is pretty messy.
4430 Perhaps we should store arg1 and args directly in the frame as
4431 received, and let scm_frame_arguments unpack them, because that's
4432 a relatively rare operation. This works for now; if the Guile
4433 developer archives are still around, see Mikael's post of
4435 if (SCM_NULLP (args
))
4437 if (SCM_NULLP (arg1
))
4439 arg1
= SCM_UNDEFINED
;
4441 debug
.vect
[0].a
.args
= SCM_EOL
;
4447 debug
.vect
[0].a
.args
= arg1
;
4449 args
= SCM_CDR (arg1
);
4450 arg1
= SCM_CAR (arg1
);
4455 args
= scm_nconc2last (args
);
4457 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4461 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
4464 if (SCM_CHEAPTRAPS_P
)
4465 tmp
= scm_make_debugobj (&debug
);
4470 tmp
= scm_make_continuation (&first
);
4475 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
4482 switch (SCM_TYP7 (proc
))
4484 case scm_tc7_subr_2o
:
4485 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
4486 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4487 case scm_tc7_subr_2
:
4488 if (SCM_NULLP (args
) || !SCM_NULLP (SCM_CDR (args
)))
4489 scm_wrong_num_args (proc
);
4490 args
= SCM_CAR (args
);
4491 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4492 case scm_tc7_subr_0
:
4493 if (!SCM_UNBNDP (arg1
))
4494 scm_wrong_num_args (proc
);
4496 RETURN (SCM_SUBRF (proc
) ());
4497 case scm_tc7_subr_1
:
4498 if (SCM_UNBNDP (arg1
))
4499 scm_wrong_num_args (proc
);
4500 case scm_tc7_subr_1o
:
4501 if (!SCM_NULLP (args
))
4502 scm_wrong_num_args (proc
);
4504 RETURN (SCM_SUBRF (proc
) (arg1
));
4506 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
4507 scm_wrong_num_args (proc
);
4508 if (SCM_INUMP (arg1
))
4510 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
4512 else if (SCM_REALP (arg1
))
4514 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4516 else if (SCM_BIGP (arg1
))
4518 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4520 else if (SCM_FRACTIONP (arg1
))
4522 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4524 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4525 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4527 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
4528 scm_wrong_num_args (proc
);
4530 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
4533 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
4534 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4535 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
4540 case scm_tc7_subr_3
:
4541 if (SCM_NULLP (args
)
4542 || SCM_NULLP (SCM_CDR (args
))
4543 || !SCM_NULLP (SCM_CDDR (args
)))
4544 scm_wrong_num_args (proc
);
4546 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
4549 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
4551 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
4553 case scm_tc7_lsubr_2
:
4554 if (!SCM_CONSP (args
))
4555 scm_wrong_num_args (proc
);
4557 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4559 if (SCM_NULLP (args
))
4560 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4561 while (SCM_NIMP (args
))
4563 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
4564 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
4565 args
= SCM_CDR (args
);
4568 case scm_tc7_rpsubr
:
4569 if (SCM_NULLP (args
))
4570 RETURN (SCM_BOOL_T
);
4571 while (SCM_NIMP (args
))
4573 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
4574 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
4575 RETURN (SCM_BOOL_F
);
4576 arg1
= SCM_CAR (args
);
4577 args
= SCM_CDR (args
);
4579 RETURN (SCM_BOOL_T
);
4580 case scm_tcs_closures
:
4582 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4584 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4586 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
4587 scm_wrong_num_args (proc
);
4589 /* Copy argument list */
4594 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
4595 for (arg1
= SCM_CDR (arg1
); SCM_CONSP (arg1
); arg1
= SCM_CDR (arg1
))
4597 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
));
4600 SCM_SETCDR (tl
, arg1
);
4603 args
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4606 proc
= SCM_CLOSURE_BODY (proc
);
4608 arg1
= SCM_CDR (proc
);
4609 while (!SCM_NULLP (arg1
))
4611 if (SCM_IMP (SCM_CAR (proc
)))
4613 if (SCM_ISYMP (SCM_CAR (proc
)))
4615 scm_rec_mutex_lock (&source_mutex
);
4616 /* check for race condition */
4617 if (SCM_ISYMP (SCM_CAR (proc
)))
4618 m_expand_body (proc
, args
);
4619 scm_rec_mutex_unlock (&source_mutex
);
4623 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
4626 SCM_CEVAL (SCM_CAR (proc
), args
);
4628 arg1
= SCM_CDR (proc
);
4630 RETURN (EVALCAR (proc
, args
));
4632 if (!SCM_SMOB_APPLICABLE_P (proc
))
4634 if (SCM_UNBNDP (arg1
))
4635 RETURN (SCM_SMOB_APPLY_0 (proc
));
4636 else if (SCM_NULLP (args
))
4637 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
4638 else if (SCM_NULLP (SCM_CDR (args
)))
4639 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
4641 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4644 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4646 proc
= SCM_CCLO_SUBR (proc
);
4647 debug
.vect
[0].a
.proc
= proc
;
4648 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4650 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4652 proc
= SCM_CCLO_SUBR (proc
);
4656 proc
= SCM_PROCEDURE (proc
);
4658 debug
.vect
[0].a
.proc
= proc
;
4661 case scm_tcs_struct
:
4662 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4665 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4667 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4669 RETURN (scm_apply_generic (proc
, args
));
4671 else if (SCM_I_OPERATORP (proc
))
4675 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4677 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4680 proc
= (SCM_I_ENTITYP (proc
)
4681 ? SCM_ENTITY_PROCEDURE (proc
)
4682 : SCM_OPERATOR_PROCEDURE (proc
));
4684 debug
.vect
[0].a
.proc
= proc
;
4685 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4687 if (SCM_NIMP (proc
))
4696 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
4700 if (scm_check_exit_p
&& SCM_TRAPS_P
)
4701 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
4703 SCM_CLEAR_TRACED_FRAME (debug
);
4704 if (SCM_CHEAPTRAPS_P
)
4705 arg1
= scm_make_debugobj (&debug
);
4709 SCM val
= scm_make_continuation (&first
);
4720 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
4724 scm_last_debug_frame
= debug
.prev
;
4730 /* SECTION: The rest of this file is only read once.
4737 * Trampolines make it possible to move procedure application dispatch
4738 * outside inner loops. The motivation was clean implementation of
4739 * efficient replacements of R5RS primitives in SRFI-1.
4741 * The semantics is clear: scm_trampoline_N returns an optimized
4742 * version of scm_call_N (or NULL if the procedure isn't applicable
4745 * Applying the optimization to map and for-each increased efficiency
4746 * noticeably. For example, (map abs ls) is now 8 times faster than
4751 call_subr0_0 (SCM proc
)
4753 return SCM_SUBRF (proc
) ();
4757 call_subr1o_0 (SCM proc
)
4759 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
4763 call_lsubr_0 (SCM proc
)
4765 return SCM_SUBRF (proc
) (SCM_EOL
);
4769 scm_i_call_closure_0 (SCM proc
)
4771 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4774 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
4779 scm_trampoline_0 (SCM proc
)
4781 scm_t_trampoline_0 trampoline
;
4786 switch (SCM_TYP7 (proc
))
4788 case scm_tc7_subr_0
:
4789 trampoline
= call_subr0_0
;
4791 case scm_tc7_subr_1o
:
4792 trampoline
= call_subr1o_0
;
4795 trampoline
= call_lsubr_0
;
4797 case scm_tcs_closures
:
4799 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4800 if (SCM_NULLP (formals
) || !SCM_CONSP (formals
))
4801 trampoline
= scm_i_call_closure_0
;
4806 case scm_tcs_struct
:
4807 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4808 trampoline
= scm_call_generic_0
;
4809 else if (SCM_I_OPERATORP (proc
))
4810 trampoline
= scm_call_0
;
4815 if (SCM_SMOB_APPLICABLE_P (proc
))
4816 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
4821 case scm_tc7_rpsubr
:
4824 trampoline
= scm_call_0
;
4827 return NULL
; /* not applicable on zero arguments */
4829 /* We only reach this point if a valid trampoline was determined. */
4831 /* If debugging is enabled, we want to see all calls to proc on the stack.
4832 * Thus, we replace the trampoline shortcut with scm_call_0. */
4840 call_subr1_1 (SCM proc
, SCM arg1
)
4842 return SCM_SUBRF (proc
) (arg1
);
4846 call_subr2o_1 (SCM proc
, SCM arg1
)
4848 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
4852 call_lsubr_1 (SCM proc
, SCM arg1
)
4854 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
4858 call_dsubr_1 (SCM proc
, SCM arg1
)
4860 if (SCM_INUMP (arg1
))
4862 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
4864 else if (SCM_REALP (arg1
))
4866 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4868 else if (SCM_BIGP (arg1
))
4870 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4872 else if (SCM_FRACTIONP (arg1
))
4874 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4876 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4877 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4881 call_cxr_1 (SCM proc
, SCM arg1
)
4883 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
4886 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
4887 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4888 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
4895 call_closure_1 (SCM proc
, SCM arg1
)
4897 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4900 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
4905 scm_trampoline_1 (SCM proc
)
4907 scm_t_trampoline_1 trampoline
;
4912 switch (SCM_TYP7 (proc
))
4914 case scm_tc7_subr_1
:
4915 case scm_tc7_subr_1o
:
4916 trampoline
= call_subr1_1
;
4918 case scm_tc7_subr_2o
:
4919 trampoline
= call_subr2o_1
;
4922 trampoline
= call_lsubr_1
;
4925 trampoline
= call_dsubr_1
;
4928 trampoline
= call_cxr_1
;
4930 case scm_tcs_closures
:
4932 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4933 if (!SCM_NULLP (formals
)
4934 && (!SCM_CONSP (formals
) || !SCM_CONSP (SCM_CDR (formals
))))
4935 trampoline
= call_closure_1
;
4940 case scm_tcs_struct
:
4941 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4942 trampoline
= scm_call_generic_1
;
4943 else if (SCM_I_OPERATORP (proc
))
4944 trampoline
= scm_call_1
;
4949 if (SCM_SMOB_APPLICABLE_P (proc
))
4950 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
4955 case scm_tc7_rpsubr
:
4958 trampoline
= scm_call_1
;
4961 return NULL
; /* not applicable on one arg */
4963 /* We only reach this point if a valid trampoline was determined. */
4965 /* If debugging is enabled, we want to see all calls to proc on the stack.
4966 * Thus, we replace the trampoline shortcut with scm_call_1. */
4974 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
4976 return SCM_SUBRF (proc
) (arg1
, arg2
);
4980 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
4982 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
4986 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
4988 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
4992 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
4994 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4995 scm_list_2 (arg1
, arg2
),
4997 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
5002 scm_trampoline_2 (SCM proc
)
5004 scm_t_trampoline_2 trampoline
;
5009 switch (SCM_TYP7 (proc
))
5011 case scm_tc7_subr_2
:
5012 case scm_tc7_subr_2o
:
5013 case scm_tc7_rpsubr
:
5015 trampoline
= call_subr2_2
;
5017 case scm_tc7_lsubr_2
:
5018 trampoline
= call_lsubr2_2
;
5021 trampoline
= call_lsubr_2
;
5023 case scm_tcs_closures
:
5025 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5026 if (!SCM_NULLP (formals
)
5027 && (!SCM_CONSP (formals
)
5028 || (!SCM_NULLP (SCM_CDR (formals
))
5029 && (!SCM_CONSP (SCM_CDR (formals
))
5030 || !SCM_CONSP (SCM_CDDR (formals
))))))
5031 trampoline
= call_closure_2
;
5036 case scm_tcs_struct
:
5037 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5038 trampoline
= scm_call_generic_2
;
5039 else if (SCM_I_OPERATORP (proc
))
5040 trampoline
= scm_call_2
;
5045 if (SCM_SMOB_APPLICABLE_P (proc
))
5046 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
5052 trampoline
= scm_call_2
;
5055 return NULL
; /* not applicable on two args */
5057 /* We only reach this point if a valid trampoline was determined. */
5059 /* If debugging is enabled, we want to see all calls to proc on the stack.
5060 * Thus, we replace the trampoline shortcut with scm_call_2. */
5067 /* Typechecking for multi-argument MAP and FOR-EACH.
5069 Verify that each element of the vector ARGV, except for the first,
5070 is a proper list whose length is LEN. Attribute errors to WHO,
5071 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
5073 check_map_args (SCM argv
,
5080 SCM
const *ve
= SCM_VELTS (argv
);
5083 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
5085 long elt_len
= scm_ilength (ve
[i
]);
5090 scm_apply_generic (gf
, scm_cons (proc
, args
));
5092 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
5096 scm_out_of_range_pos (who
, ve
[i
], SCM_MAKINUM (i
+ 2));
5099 scm_remember_upto_here_1 (argv
);
5103 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
5105 /* Note: Currently, scm_map applies PROC to the argument list(s)
5106 sequentially, starting with the first element(s). This is used in
5107 evalext.c where the Scheme procedure `map-in-order', which guarantees
5108 sequential behaviour, is implemented using scm_map. If the
5109 behaviour changes, we need to update `map-in-order'.
5113 scm_map (SCM proc
, SCM arg1
, SCM args
)
5114 #define FUNC_NAME s_map
5119 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
5121 len
= scm_ilength (arg1
);
5122 SCM_GASSERTn (len
>= 0,
5123 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
5124 SCM_VALIDATE_REST_ARGUMENT (args
);
5125 if (SCM_NULLP (args
))
5127 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5128 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
5129 while (SCM_NIMP (arg1
))
5131 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
5132 pres
= SCM_CDRLOC (*pres
);
5133 arg1
= SCM_CDR (arg1
);
5137 if (SCM_NULLP (SCM_CDR (args
)))
5139 SCM arg2
= SCM_CAR (args
);
5140 int len2
= scm_ilength (arg2
);
5141 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5143 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
5144 SCM_GASSERTn (len2
>= 0,
5145 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
5147 SCM_OUT_OF_RANGE (3, arg2
);
5148 while (SCM_NIMP (arg1
))
5150 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
5151 pres
= SCM_CDRLOC (*pres
);
5152 arg1
= SCM_CDR (arg1
);
5153 arg2
= SCM_CDR (arg2
);
5157 arg1
= scm_cons (arg1
, args
);
5158 args
= scm_vector (arg1
);
5159 ve
= SCM_VELTS (args
);
5160 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
5164 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5166 if (SCM_IMP (ve
[i
]))
5168 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
5169 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
5171 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
5172 pres
= SCM_CDRLOC (*pres
);
5178 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
5181 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
5182 #define FUNC_NAME s_for_each
5184 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
5186 len
= scm_ilength (arg1
);
5187 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
5188 SCM_ARG2
, s_for_each
);
5189 SCM_VALIDATE_REST_ARGUMENT (args
);
5190 if (SCM_NULLP (args
))
5192 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5193 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
5194 while (SCM_NIMP (arg1
))
5196 call (proc
, SCM_CAR (arg1
));
5197 arg1
= SCM_CDR (arg1
);
5199 return SCM_UNSPECIFIED
;
5201 if (SCM_NULLP (SCM_CDR (args
)))
5203 SCM arg2
= SCM_CAR (args
);
5204 int len2
= scm_ilength (arg2
);
5205 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5206 SCM_GASSERTn (call
, g_for_each
,
5207 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
5208 SCM_GASSERTn (len2
>= 0, g_for_each
,
5209 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
5211 SCM_OUT_OF_RANGE (3, arg2
);
5212 while (SCM_NIMP (arg1
))
5214 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
5215 arg1
= SCM_CDR (arg1
);
5216 arg2
= SCM_CDR (arg2
);
5218 return SCM_UNSPECIFIED
;
5220 arg1
= scm_cons (arg1
, args
);
5221 args
= scm_vector (arg1
);
5222 ve
= SCM_VELTS (args
);
5223 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
5227 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5229 if (SCM_IMP (ve
[i
]))
5230 return SCM_UNSPECIFIED
;
5231 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
5232 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
5234 scm_apply (proc
, arg1
, SCM_EOL
);
5241 scm_closure (SCM code
, SCM env
)
5244 SCM closcar
= scm_cons (code
, SCM_EOL
);
5245 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
5246 scm_remember_upto_here (closcar
);
5251 scm_t_bits scm_tc16_promise
;
5254 scm_makprom (SCM code
)
5256 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
5258 scm_make_rec_mutex ());
5262 promise_free (SCM promise
)
5264 scm_rec_mutex_free (SCM_PROMISE_MUTEX (promise
));
5269 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
5271 int writingp
= SCM_WRITINGP (pstate
);
5272 scm_puts ("#<promise ", port
);
5273 SCM_SET_WRITINGP (pstate
, 1);
5274 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
5275 SCM_SET_WRITINGP (pstate
, writingp
);
5276 scm_putc ('>', port
);
5280 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
5282 "If the promise @var{x} has not been computed yet, compute and\n"
5283 "return @var{x}, otherwise just return the previously computed\n"
5285 #define FUNC_NAME s_scm_force
5287 SCM_VALIDATE_SMOB (1, promise
, promise
);
5288 scm_rec_mutex_lock (SCM_PROMISE_MUTEX (promise
));
5289 if (!SCM_PROMISE_COMPUTED_P (promise
))
5291 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
5292 if (!SCM_PROMISE_COMPUTED_P (promise
))
5294 SCM_SET_PROMISE_DATA (promise
, ans
);
5295 SCM_SET_PROMISE_COMPUTED (promise
);
5298 scm_rec_mutex_unlock (SCM_PROMISE_MUTEX (promise
));
5299 return SCM_PROMISE_DATA (promise
);
5304 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
5306 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
5307 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
5308 #define FUNC_NAME s_scm_promise_p
5310 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
5315 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
5316 (SCM xorig
, SCM x
, SCM y
),
5317 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
5318 "Any source properties associated with @var{xorig} are also associated\n"
5319 "with the new pair.")
5320 #define FUNC_NAME s_scm_cons_source
5323 z
= scm_cons (x
, y
);
5324 /* Copy source properties possibly associated with xorig. */
5325 p
= scm_whash_lookup (scm_source_whash
, xorig
);
5327 scm_whash_insert (scm_source_whash
, z
, p
);
5333 /* The function scm_copy_tree is used to copy an expression tree to allow the
5334 * memoizer to modify the expression during memoization. scm_copy_tree
5335 * creates deep copies of pairs and vectors, but not of any other data types,
5336 * since only pairs and vectors will be parsed by the memoizer.
5338 * To avoid infinite recursion due to cyclic structures, the hare-and-tortoise
5339 * pattern is used to detect cycles. In fact, the pattern is used in two
5340 * dimensions, vertical (indicated in the code by the variable names 'hare'
5341 * and 'tortoise') and horizontal ('rabbit' and 'turtle'). In both
5342 * dimensions, the hare/rabbit will take two steps when the tortoise/turtle
5345 * The vertical dimension corresponds to recursive calls to function
5346 * copy_tree: This happens when descending into vector elements, into cars of
5347 * lists and into the cdr of an improper list. In this dimension, the
5348 * tortoise follows the hare by using the processor stack: Every stack frame
5349 * will hold an instance of struct t_trace. These instances are connected in
5350 * a way that represents the trace of the hare, which thus can be followed by
5351 * the tortoise. The tortoise will always point to struct t_trace instances
5352 * relating to SCM objects that have already been copied. Thus, a cycle is
5353 * detected if the tortoise and the hare point to the same object,
5355 * The horizontal dimension is within one execution of copy_tree, when the
5356 * function cdr's along the pairs of a list. This is the standard
5357 * hare-and-tortoise implementation, found several times in guile. */
5360 struct t_trace
*trace
; // These pointers form a trace along the stack.
5361 SCM obj
; // The object handled at the respective stack frame.
5366 struct t_trace
*const hare
,
5367 struct t_trace
*tortoise
,
5368 unsigned int tortoise_delay
)
5370 if (!SCM_CONSP (hare
->obj
) && !SCM_VECTORP (hare
->obj
))
5376 /* Prepare the trace along the stack. */
5377 struct t_trace new_hare
;
5378 hare
->trace
= &new_hare
;
5380 /* The tortoise will make its step after the delay has elapsed. Note
5381 * that in contrast to the typical hare-and-tortoise pattern, the step
5382 * of the tortoise happens before the hare takes its steps. This is, in
5383 * principle, no problem, except for the start of the algorithm: Then,
5384 * it has to be made sure that the hare actually gets its advantage of
5386 if (tortoise_delay
== 0)
5389 tortoise
= tortoise
->trace
;
5390 ASSERT_SYNTAX (!SCM_EQ_P (hare
->obj
, tortoise
->obj
),
5391 s_bad_expression
, hare
->obj
);
5398 if (SCM_VECTORP (hare
->obj
))
5400 const unsigned long int length
= SCM_VECTOR_LENGTH (hare
->obj
);
5401 const SCM new_vector
= scm_c_make_vector (length
, SCM_UNSPECIFIED
);
5403 /* Each vector element is copied by recursing into copy_tree, having
5404 * the tortoise follow the hare into the depths of the stack. */
5405 unsigned long int i
;
5406 for (i
= 0; i
< length
; ++i
)
5409 new_hare
.obj
= SCM_VECTOR_REF (hare
->obj
, i
);
5410 new_element
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5411 SCM_VECTOR_SET (new_vector
, i
, new_element
);
5416 else // SCM_CONSP (hare->obj)
5421 SCM rabbit
= hare
->obj
;
5422 SCM turtle
= hare
->obj
;
5426 /* The first pair of the list is treated specially, in order to
5427 * preserve a potential source code position. */
5428 result
= tail
= scm_cons_source (rabbit
, SCM_EOL
, SCM_EOL
);
5429 new_hare
.obj
= SCM_CAR (rabbit
);
5430 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5431 SCM_SETCAR (tail
, copy
);
5433 /* The remaining pairs of the list are copied by, horizontally,
5434 * having the turtle follow the rabbit, and, vertically, having the
5435 * tortoise follow the hare into the depths of the stack. */
5436 rabbit
= SCM_CDR (rabbit
);
5437 while (SCM_CONSP (rabbit
))
5439 new_hare
.obj
= SCM_CAR (rabbit
);
5440 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5441 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
5442 tail
= SCM_CDR (tail
);
5444 rabbit
= SCM_CDR (rabbit
);
5445 if (SCM_CONSP (rabbit
))
5447 new_hare
.obj
= SCM_CAR (rabbit
);
5448 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5449 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
5450 tail
= SCM_CDR (tail
);
5451 rabbit
= SCM_CDR (rabbit
);
5453 turtle
= SCM_CDR (turtle
);
5454 ASSERT_SYNTAX (!SCM_EQ_P (rabbit
, turtle
),
5455 s_bad_expression
, rabbit
);
5459 /* We have to recurse into copy_tree again for the last cdr, in
5460 * order to handle the situation that it holds a vector. */
5461 new_hare
.obj
= rabbit
;
5462 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5463 SCM_SETCDR (tail
, copy
);
5470 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
5472 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
5473 "the new data structure. @code{copy-tree} recurses down the\n"
5474 "contents of both pairs and vectors (since both cons cells and vector\n"
5475 "cells may point to arbitrary objects), and stops recursing when it hits\n"
5476 "any other object.")
5477 #define FUNC_NAME s_scm_copy_tree
5479 /* Prepare the trace along the stack. */
5480 struct t_trace trace
;
5483 /* In function copy_tree, if the tortoise makes its step, it will do this
5484 * before the hare has the chance to move. Thus, we have to make sure that
5485 * the very first step of the tortoise will not happen after the hare has
5486 * really made two steps. This is achieved by passing '2' as the initial
5487 * delay for the tortoise. NOTE: Since cycles are unlikely, giving the hare
5488 * a bigger advantage may improve performance slightly. */
5489 return copy_tree (&trace
, &trace
, 2);
5494 /* We have three levels of EVAL here:
5496 - scm_i_eval (exp, env)
5498 evaluates EXP in environment ENV. ENV is a lexical environment
5499 structure as used by the actual tree code evaluator. When ENV is
5500 a top-level environment, then changes to the current module are
5501 tracked by updating ENV so that it continues to be in sync with
5504 - scm_primitive_eval (exp)
5506 evaluates EXP in the top-level environment as determined by the
5507 current module. This is done by constructing a suitable
5508 environment and calling scm_i_eval. Thus, changes to the
5509 top-level module are tracked normally.
5511 - scm_eval (exp, mod)
5513 evaluates EXP while MOD is the current module. This is done by
5514 setting the current module to MOD, invoking scm_primitive_eval on
5515 EXP, and then restoring the current module to the value it had
5516 previously. That is, while EXP is evaluated, changes to the
5517 current module are tracked, but these changes do not persist when
5520 For each level of evals, there are two variants, distinguished by a
5521 _x suffix: the ordinary variant does not modify EXP while the _x
5522 variant can destructively modify EXP into something completely
5523 unintelligible. A Scheme data structure passed as EXP to one of the
5524 _x variants should not ever be used again for anything. So when in
5525 doubt, use the ordinary variant.
5530 scm_i_eval_x (SCM exp
, SCM env
)
5532 return SCM_XEVAL (exp
, env
);
5536 scm_i_eval (SCM exp
, SCM env
)
5538 exp
= scm_copy_tree (exp
);
5539 return SCM_XEVAL (exp
, env
);
5543 scm_primitive_eval_x (SCM exp
)
5546 SCM transformer
= scm_current_module_transformer ();
5547 if (SCM_NIMP (transformer
))
5548 exp
= scm_call_1 (transformer
, exp
);
5549 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5550 return scm_i_eval_x (exp
, env
);
5553 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
5555 "Evaluate @var{exp} in the top-level environment specified by\n"
5556 "the current module.")
5557 #define FUNC_NAME s_scm_primitive_eval
5560 SCM transformer
= scm_current_module_transformer ();
5561 if (SCM_NIMP (transformer
))
5562 exp
= scm_call_1 (transformer
, exp
);
5563 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5564 return scm_i_eval (exp
, env
);
5569 /* Eval does not take the second arg optionally. This is intentional
5570 * in order to be R5RS compatible, and to prepare for the new module
5571 * system, where we would like to make the choice of evaluation
5572 * environment explicit. */
5575 change_environment (void *data
)
5577 SCM pair
= SCM_PACK (data
);
5578 SCM new_module
= SCM_CAR (pair
);
5579 SCM old_module
= scm_current_module ();
5580 SCM_SETCDR (pair
, old_module
);
5581 scm_set_current_module (new_module
);
5585 restore_environment (void *data
)
5587 SCM pair
= SCM_PACK (data
);
5588 SCM old_module
= SCM_CDR (pair
);
5589 SCM new_module
= scm_current_module ();
5590 SCM_SETCAR (pair
, new_module
);
5591 scm_set_current_module (old_module
);
5595 inner_eval_x (void *data
)
5597 return scm_primitive_eval_x (SCM_PACK(data
));
5601 scm_eval_x (SCM exp
, SCM module
)
5602 #define FUNC_NAME "eval!"
5604 SCM_VALIDATE_MODULE (2, module
);
5606 return scm_internal_dynamic_wind
5607 (change_environment
, inner_eval_x
, restore_environment
,
5608 (void *) SCM_UNPACK (exp
),
5609 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
5614 inner_eval (void *data
)
5616 return scm_primitive_eval (SCM_PACK(data
));
5619 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
5620 (SCM exp
, SCM module
),
5621 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
5622 "in the top-level environment specified by @var{module}.\n"
5623 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
5624 "@var{module} is made the current module. The current module\n"
5625 "is reset to its previous value when @var{eval} returns.")
5626 #define FUNC_NAME s_scm_eval
5628 SCM_VALIDATE_MODULE (2, module
);
5630 return scm_internal_dynamic_wind
5631 (change_environment
, inner_eval
, restore_environment
,
5632 (void *) SCM_UNPACK (exp
),
5633 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
5638 /* At this point, scm_deval and scm_dapply are generated.
5648 scm_init_opts (scm_evaluator_traps
,
5649 scm_evaluator_trap_table
,
5650 SCM_N_EVALUATOR_TRAPS
);
5651 scm_init_opts (scm_eval_options_interface
,
5653 SCM_N_EVAL_OPTIONS
);
5655 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
5656 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
5657 scm_set_smob_free (scm_tc16_promise
, promise_free
);
5658 scm_set_smob_print (scm_tc16_promise
, promise_print
);
5660 undefineds
= scm_list_1 (SCM_UNDEFINED
);
5661 SCM_SETCDR (undefineds
, undefineds
);
5662 scm_permanent_object (undefineds
);
5664 scm_listofnull
= scm_list_1 (SCM_EOL
);
5666 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
5667 scm_permanent_object (f_apply
);
5669 #include "libguile/eval.x"
5671 scm_add_feature ("delay");