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
))
456 /* Lookup a given local variable in an environment. The local variable is
457 * given as an iloc, that is a triple <frame, binding, last?>, where frame
458 * indicates the relative number of the environment frame (counting upwards
459 * from the innermost environment frame), binding indicates the number of the
460 * binding within the frame, and last? (which is extracted from the iloc using
461 * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
462 * very end of the improper list of bindings. */
464 scm_ilookup (SCM iloc
, SCM env
)
466 unsigned int frame_nr
= SCM_IFRAME (iloc
);
467 unsigned int binding_nr
= SCM_IDIST (iloc
);
471 for (; 0 != frame_nr
; --frame_nr
)
472 frames
= SCM_CDR (frames
);
474 bindings
= SCM_CAR (frames
);
475 for (; 0 != binding_nr
; --binding_nr
)
476 bindings
= SCM_CDR (bindings
);
478 if (SCM_ICDRP (iloc
))
479 return SCM_CDRLOC (bindings
);
480 return SCM_CARLOC (SCM_CDR (bindings
));
484 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
486 static void error_unbound_variable (SCM symbol
) SCM_NORETURN
;
488 error_unbound_variable (SCM symbol
)
490 scm_error (scm_unbound_variable_key
, NULL
,
491 "Unbound variable: ~S",
492 scm_list_1 (symbol
), SCM_BOOL_F
);
496 /* The Lookup Car Race
499 Memoization of variables and special forms is done while executing
500 the code for the first time. As long as there is only one thread
501 everything is fine, but as soon as two threads execute the same
502 code concurrently `for the first time' they can come into conflict.
504 This memoization includes rewriting variable references into more
505 efficient forms and expanding macros. Furthermore, macro expansion
506 includes `compiling' special forms like `let', `cond', etc. into
507 tree-code instructions.
509 There shouldn't normally be a problem with memoizing local and
510 global variable references (into ilocs and variables), because all
511 threads will mutate the code in *exactly* the same way and (if I
512 read the C code correctly) it is not possible to observe a half-way
513 mutated cons cell. The lookup procedure can handle this
514 transparently without any critical sections.
516 It is different with macro expansion, because macro expansion
517 happens outside of the lookup procedure and can't be
518 undone. Therefore the lookup procedure can't cope with it. It has
519 to indicate failure when it detects a lost race and hope that the
520 caller can handle it. Luckily, it turns out that this is the case.
522 An example to illustrate this: Suppose that the following form will
523 be memoized concurrently by two threads
527 Let's first examine the lookup of X in the body. The first thread
528 decides that it has to find the symbol "x" in the environment and
529 starts to scan it. Then the other thread takes over and actually
530 overtakes the first. It looks up "x" and substitutes an
531 appropriate iloc for it. Now the first thread continues and
532 completes its lookup. It comes to exactly the same conclusions as
533 the second one and could - without much ado - just overwrite the
534 iloc with the same iloc.
536 But let's see what will happen when the race occurs while looking
537 up the symbol "let" at the start of the form. It could happen that
538 the second thread interrupts the lookup of the first thread and not
539 only substitutes a variable for it but goes right ahead and
540 replaces it with the compiled form (#@let* (x 12) x). Now, when
541 the first thread completes its lookup, it would replace the #@let*
542 with a variable containing the "let" binding, effectively reverting
543 the form to (let (x 12) x). This is wrong. It has to detect that
544 it has lost the race and the evaluator has to reconsider the
545 changed form completely.
547 This race condition could be resolved with some kind of traffic
548 light (like mutexes) around scm_lookupcar, but I think that it is
549 best to avoid them in this case. They would serialize memoization
550 completely and because lookup involves calling arbitrary Scheme
551 code (via the lookup-thunk), threads could be blocked for an
552 arbitrary amount of time or even deadlock. But with the current
553 solution a lot of unnecessary work is potentially done. */
555 /* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
556 return NULL to indicate a failed lookup due to some race conditions
557 between threads. This only happens when VLOC is the first cell of
558 a special form that will eventually be memoized (like `let', etc.)
559 In that case the whole lookup is bogus and the caller has to
560 reconsider the complete special form.
562 SCM_LOOKUPCAR is still there, of course. It just calls
563 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
564 should only be called when it is known that VLOC is not the first
565 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
566 for NULL. I think I've found the only places where this
570 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
573 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
574 register SCM iloc
= SCM_ILOC00
;
575 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
577 if (!SCM_CONSP (SCM_CAR (env
)))
579 al
= SCM_CARLOC (env
);
580 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
584 if (SCM_EQ_P (fl
, var
))
586 if (! SCM_EQ_P (SCM_CAR (vloc
), var
))
588 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
589 return SCM_CDRLOC (*al
);
594 al
= SCM_CDRLOC (*al
);
595 if (SCM_EQ_P (SCM_CAR (fl
), var
))
597 if (SCM_UNBNDP (SCM_CAR (*al
)))
602 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
604 SCM_SETCAR (vloc
, iloc
);
605 return SCM_CARLOC (*al
);
607 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
609 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
612 SCM top_thunk
, real_var
;
615 top_thunk
= SCM_CAR (env
); /* env now refers to a
616 top level env thunk */
620 top_thunk
= SCM_BOOL_F
;
621 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
622 if (SCM_FALSEP (real_var
))
625 if (!SCM_NULLP (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
631 error_unbound_variable (var
);
633 scm_misc_error (NULL
, "Damaged environment: ~S",
638 /* A variable could not be found, but we shall
639 not throw an error. */
640 static SCM undef_object
= SCM_UNDEFINED
;
641 return &undef_object
;
645 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
647 /* Some other thread has changed the very cell we are working
648 on. In effect, it must have done our job or messed it up
651 var
= SCM_CAR (vloc
);
652 if (SCM_VARIABLEP (var
))
653 return SCM_VARIABLE_LOC (var
);
654 if (SCM_ITAG7 (var
) == SCM_ITAG7 (SCM_ILOC00
))
655 return scm_ilookup (var
, genv
);
656 /* We can't cope with anything else than variables and ilocs. When
657 a special form has been memoized (i.e. `let' into `#@let') we
658 return NULL and expect the calling function to do the right
659 thing. For the evaluator, this means going back and redoing
660 the dispatch on the car of the form. */
664 SCM_SETCAR (vloc
, real_var
);
665 return SCM_VARIABLE_LOC (real_var
);
670 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
672 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
680 /* Rewrite the body (which is given as the list of expressions forming the
681 * body) into its internal form. The internal form of a body (<expr> ...) is
682 * just the body itself, but prefixed with an ISYM that denotes to what kind
683 * of outer construct this body belongs: (<ISYM> <expr> ...). A lambda body
684 * starts with SCM_IM_LAMBDA, for example, a body of a let starts with
687 * It is assumed that the calling expression has already made sure that the
688 * body is a proper list. */
690 m_body (SCM op
, SCM exprs
)
692 /* Don't add another ISYM if one is present already. */
693 if (SCM_ISYMP (SCM_CAR (exprs
)))
696 return scm_cons (op
, exprs
);
700 /* The function m_expand_body memoizes a proper list of expressions
701 * forming a body. This function takes care of dealing with internal
702 * defines and transforming them into an equivalent letrec expression.
703 * The list of expressions is rewritten in place. */
705 /* This is a helper function for m_expand_body. It helps to figure out whether
706 * an expression denotes a syntactic keyword. */
708 try_macro_lookup (const SCM expr
, const SCM env
)
710 if (SCM_SYMBOLP (expr
))
712 const SCM value
= lookup_symbol (expr
, env
);
717 return SCM_UNDEFINED
;
721 /* This is a helper function for m_expand_body. It expands user macros,
722 * because for the correct translation of a body we need to know whether they
723 * expand to a definition. */
725 expand_user_macros (SCM expr
, const SCM env
)
727 while (SCM_CONSP (expr
))
729 const SCM car_expr
= SCM_CAR (expr
);
730 const SCM new_car
= expand_user_macros (car_expr
, env
);
731 const SCM value
= try_macro_lookup (new_car
, env
);
733 if (SCM_MACROP (value
) && SCM_MACRO_TYPE (value
) == 2)
735 /* User macros transform code into code. */
736 expr
= scm_call_2 (SCM_MACRO_CODE (value
), expr
, env
);
737 /* We need to reiterate on the transformed code. */
741 /* No user macro: return. */
742 SCM_SETCAR (expr
, new_car
);
750 /* This is a helper function for m_expand_body. It determines if a given form
751 * represents an application of a given built-in macro. The built-in macro to
752 * check for is identified by its syntactic keyword. The form is an
753 * application of the given macro if looking up the car of the form in the
754 * given environment actually returns the built-in macro. */
756 is_system_macro_p (const SCM syntactic_keyword
, const SCM form
, const SCM env
)
758 if (SCM_CONSP (form
))
760 const SCM car_form
= SCM_CAR (form
);
761 const SCM value
= try_macro_lookup (car_form
, env
);
762 if (SCM_BUILTIN_MACRO_P (value
))
764 const SCM macro_name
= scm_macro_name (value
);
765 return SCM_EQ_P (macro_name
, syntactic_keyword
);
773 m_expand_body (const SCM forms
, const SCM env
)
775 /* The first body form can be skipped since it is known to be the ISYM that
776 * was prepended to the body by m_body. */
777 SCM cdr_forms
= SCM_CDR (forms
);
778 SCM form_idx
= cdr_forms
;
779 SCM definitions
= SCM_EOL
;
780 SCM sequence
= SCM_EOL
;
782 /* According to R5RS, the list of body forms consists of two parts: a number
783 * (maybe zero) of definitions, followed by a non-empty sequence of
784 * expressions. Each the definitions and the expressions may be grouped
785 * arbitrarily with begin, but it is not allowed to mix definitions and
786 * expressions. The task of the following loop therefore is to split the
787 * list of body forms into the list of definitions and the sequence of
789 while (!SCM_NULLP (form_idx
))
791 const SCM form
= SCM_CAR (form_idx
);
792 const SCM new_form
= expand_user_macros (form
, env
);
793 if (is_system_macro_p (scm_sym_define
, new_form
, env
))
795 definitions
= scm_cons (new_form
, definitions
);
796 form_idx
= SCM_CDR (form_idx
);
798 else if (is_system_macro_p (scm_sym_begin
, new_form
, env
))
800 /* We have encountered a group of forms. This has to be either a
801 * (possibly empty) group of (possibly further grouped) definitions,
802 * or a non-empty group of (possibly further grouped)
804 const SCM grouped_forms
= SCM_CDR (new_form
);
805 unsigned int found_definition
= 0;
806 unsigned int found_expression
= 0;
807 SCM grouped_form_idx
= grouped_forms
;
808 while (!found_expression
&& !SCM_NULLP (grouped_form_idx
))
810 const SCM inner_form
= SCM_CAR (grouped_form_idx
);
811 const SCM new_inner_form
= expand_user_macros (inner_form
, env
);
812 if (is_system_macro_p (scm_sym_define
, new_inner_form
, env
))
814 found_definition
= 1;
815 definitions
= scm_cons (new_inner_form
, definitions
);
816 grouped_form_idx
= SCM_CDR (grouped_form_idx
);
818 else if (is_system_macro_p (scm_sym_begin
, new_inner_form
, env
))
820 const SCM inner_group
= SCM_CDR (new_inner_form
);
822 = scm_append (scm_list_2 (inner_group
,
823 SCM_CDR (grouped_form_idx
)));
827 /* The group marks the start of the expressions of the body.
828 * We have to make sure that within the same group we have
829 * not encountered a definition before. */
830 ASSERT_SYNTAX (!found_definition
, s_mixed_body_forms
, form
);
831 found_expression
= 1;
832 grouped_form_idx
= SCM_EOL
;
836 /* We have finished processing the group. If we have not yet
837 * encountered an expression we continue processing the forms of the
838 * body to collect further definition forms. Otherwise, the group
839 * marks the start of the sequence of expressions of the body. */
840 if (!found_expression
)
842 form_idx
= SCM_CDR (form_idx
);
852 /* We have detected a form which is no definition. This marks the
853 * start of the sequence of expressions of the body. */
859 /* FIXME: forms does not hold information about the file location. */
860 ASSERT_SYNTAX (SCM_CONSP (sequence
), s_missing_body_expression
, cdr_forms
);
862 if (!SCM_NULLP (definitions
))
866 SCM letrec_expression
;
867 SCM new_letrec_expression
;
869 SCM bindings
= SCM_EOL
;
870 for (definition_idx
= definitions
;
871 !SCM_NULLP (definition_idx
);
872 definition_idx
= SCM_CDR (definition_idx
))
874 const SCM definition
= SCM_CAR (definition_idx
);
875 const SCM canonical_definition
= canonicalize_define (definition
);
876 const SCM binding
= SCM_CDR (canonical_definition
);
877 bindings
= scm_cons (binding
, bindings
);
880 letrec_tail
= scm_cons (bindings
, sequence
);
881 /* FIXME: forms does not hold information about the file location. */
882 letrec_expression
= scm_cons_source (forms
, scm_sym_letrec
, letrec_tail
);
883 new_letrec_expression
= scm_m_letrec (letrec_expression
, env
);
884 SCM_SETCAR (forms
, new_letrec_expression
);
885 SCM_SETCDR (forms
, SCM_EOL
);
889 SCM_SETCAR (forms
, SCM_CAR (sequence
));
890 SCM_SETCDR (forms
, SCM_CDR (sequence
));
894 #if (SCM_ENABLE_DEPRECATED == 1)
896 /* Deprecated in guile 1.7.0 on 2003-11-09. */
898 scm_m_expand_body (SCM exprs
, SCM env
)
900 scm_c_issue_deprecation_warning
901 ("`scm_m_expand_body' is deprecated.");
902 m_expand_body (exprs
, env
);
909 /* Start of the memoizers for the standard R5RS builtin macros. */
912 SCM_SYNTAX (s_and
, "and", scm_i_makbimacro
, scm_m_and
);
913 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
916 scm_m_and (SCM expr
, SCM env SCM_UNUSED
)
918 const SCM cdr_expr
= SCM_CDR (expr
);
919 const long length
= scm_ilength (cdr_expr
);
921 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
925 /* Special case: (and) is replaced by #t. */
930 SCM_SETCAR (expr
, SCM_IM_AND
);
936 SCM_SYNTAX (s_begin
, "begin", scm_i_makbimacro
, scm_m_begin
);
937 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
940 scm_m_begin (SCM expr
, SCM env SCM_UNUSED
)
942 const SCM cdr_expr
= SCM_CDR (expr
);
943 /* Dirk:FIXME:: An empty begin clause is not generally allowed by R5RS.
944 * That means, there should be a distinction between uses of begin where an
945 * empty clause is OK and where it is not. */
946 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
948 SCM_SETCAR (expr
, SCM_IM_BEGIN
);
953 SCM_SYNTAX (s_case
, "case", scm_i_makbimacro
, scm_m_case
);
954 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
955 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
958 scm_m_case (SCM expr
, SCM env
)
961 SCM all_labels
= SCM_EOL
;
963 /* Check, whether 'else is a literal, i. e. not bound to a value. */
964 const int else_literal_p
= literal_p (scm_sym_else
, env
);
966 const SCM cdr_expr
= SCM_CDR (expr
);
967 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
968 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_clauses
, expr
);
970 clauses
= SCM_CDR (cdr_expr
);
971 while (!SCM_NULLP (clauses
))
975 const SCM clause
= SCM_CAR (clauses
);
976 ASSERT_SYNTAX_2 (scm_ilength (clause
) >= 2,
977 s_bad_case_clause
, clause
, expr
);
979 labels
= SCM_CAR (clause
);
980 if (SCM_CONSP (labels
))
982 ASSERT_SYNTAX_2 (scm_ilength (labels
) >= 0,
983 s_bad_case_labels
, labels
, expr
);
984 all_labels
= scm_append_x (scm_list_2 (labels
, all_labels
));
986 else if (SCM_NULLP (labels
))
988 /* The list of labels is empty. According to R5RS this is allowed.
989 * It means that the sequence of expressions will never be executed.
990 * Therefore, as an optimization, we could remove the whole
995 ASSERT_SYNTAX_2 (SCM_EQ_P (labels
, scm_sym_else
) && else_literal_p
,
996 s_bad_case_labels
, labels
, expr
);
997 ASSERT_SYNTAX_2 (SCM_NULLP (SCM_CDR (clauses
)),
998 s_misplaced_else_clause
, clause
, expr
);
1001 /* build the new clause */
1002 if (SCM_EQ_P (labels
, scm_sym_else
))
1003 SCM_SETCAR (clause
, SCM_IM_ELSE
);
1005 clauses
= SCM_CDR (clauses
);
1008 /* Check whether all case labels are distinct. */
1009 for (; !SCM_NULLP (all_labels
); all_labels
= SCM_CDR (all_labels
))
1011 const SCM label
= SCM_CAR (all_labels
);
1012 ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (label
, SCM_CDR (all_labels
))),
1013 s_duplicate_case_label
, label
, expr
);
1016 SCM_SETCAR (expr
, SCM_IM_CASE
);
1021 SCM_SYNTAX (s_cond
, "cond", scm_i_makbimacro
, scm_m_cond
);
1022 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
1023 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
1026 scm_m_cond (SCM expr
, SCM env
)
1028 /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
1029 const int else_literal_p
= literal_p (scm_sym_else
, env
);
1030 const int arrow_literal_p
= literal_p (scm_sym_arrow
, env
);
1032 const SCM clauses
= SCM_CDR (expr
);
1035 ASSERT_SYNTAX (scm_ilength (clauses
) >= 0, s_bad_expression
, expr
);
1036 ASSERT_SYNTAX (scm_ilength (clauses
) >= 1, s_missing_clauses
, expr
);
1038 for (clause_idx
= clauses
;
1039 !SCM_NULLP (clause_idx
);
1040 clause_idx
= SCM_CDR (clause_idx
))
1044 const SCM clause
= SCM_CAR (clause_idx
);
1045 const long length
= scm_ilength (clause
);
1046 ASSERT_SYNTAX_2 (length
>= 1, s_bad_cond_clause
, clause
, expr
);
1048 test
= SCM_CAR (clause
);
1049 if (SCM_EQ_P (test
, scm_sym_else
) && else_literal_p
)
1051 const int last_clause_p
= SCM_NULLP (SCM_CDR (clause_idx
));
1052 ASSERT_SYNTAX_2 (length
>= 2,
1053 s_bad_cond_clause
, clause
, expr
);
1054 ASSERT_SYNTAX_2 (last_clause_p
,
1055 s_misplaced_else_clause
, clause
, expr
);
1056 SCM_SETCAR (clause
, SCM_IM_ELSE
);
1058 else if (length
>= 2
1059 && SCM_EQ_P (SCM_CADR (clause
), scm_sym_arrow
)
1062 ASSERT_SYNTAX_2 (length
> 2, s_missing_recipient
, clause
, expr
);
1063 ASSERT_SYNTAX_2 (length
== 3, s_extra_expression
, clause
, expr
);
1064 SCM_SETCAR (SCM_CDR (clause
), SCM_IM_ARROW
);
1068 SCM_SETCAR (expr
, SCM_IM_COND
);
1073 SCM_SYNTAX (s_define
, "define", scm_i_makbimacro
, scm_m_define
);
1074 SCM_GLOBAL_SYMBOL (scm_sym_define
, s_define
);
1076 /* Guile provides an extension to R5RS' define syntax to represent function
1077 * currying in a compact way. With this extension, it is allowed to write
1078 * (define <nested-variable> <body>), where <nested-variable> has of one of
1079 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
1080 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
1081 * should be either a sequence of zero or more variables, or a sequence of one
1082 * or more variables followed by a space-delimited period and another
1083 * variable. Each level of argument nesting wraps the <body> within another
1084 * lambda expression. For example, the following forms are allowed, each one
1085 * followed by an equivalent, more explicit implementation.
1087 * (define ((a b . c) . d) <body>) is equivalent to
1088 * (define a (lambda (b . c) (lambda d <body>)))
1090 * (define (((a) b) c . d) <body>) is equivalent to
1091 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
1093 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
1094 * module that does not implement this extension. */
1096 canonicalize_define (const SCM expr
)
1101 const SCM cdr_expr
= SCM_CDR (expr
);
1102 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1103 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1105 body
= SCM_CDR (cdr_expr
);
1106 variable
= SCM_CAR (cdr_expr
);
1107 while (SCM_CONSP (variable
))
1109 /* This while loop realizes function currying by variable nesting.
1110 * Variable is known to be a nested-variable. In every iteration of the
1111 * loop another level of lambda expression is created, starting with the
1112 * innermost one. Note that we don't check for duplicate formals here:
1113 * This will be done by the memoizer of the lambda expression. */
1114 const SCM formals
= SCM_CDR (variable
);
1115 const SCM tail
= scm_cons (formals
, body
);
1117 /* Add source properties to each new lambda expression: */
1118 const SCM lambda
= scm_cons_source (variable
, scm_sym_lambda
, tail
);
1120 body
= scm_list_1 (lambda
);
1121 variable
= SCM_CAR (variable
);
1123 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
), s_bad_variable
, variable
, expr
);
1124 ASSERT_SYNTAX (scm_ilength (body
) == 1, s_expression
, expr
);
1126 SCM_SETCAR (cdr_expr
, variable
);
1127 SCM_SETCDR (cdr_expr
, body
);
1132 scm_m_define (SCM expr
, SCM env
)
1134 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), s_bad_define
, expr
);
1137 const SCM canonical_definition
= canonicalize_define (expr
);
1138 const SCM cdr_canonical_definition
= SCM_CDR (canonical_definition
);
1139 const SCM variable
= SCM_CAR (cdr_canonical_definition
);
1140 const SCM body
= SCM_CDR (cdr_canonical_definition
);
1141 const SCM value
= scm_eval_car (body
, env
);
1144 if (SCM_REC_PROCNAMES_P
)
1147 while (SCM_MACROP (tmp
))
1148 tmp
= SCM_MACRO_CODE (tmp
);
1149 if (SCM_CLOSUREP (tmp
)
1150 /* Only the first definition determines the name. */
1151 && SCM_FALSEP (scm_procedure_property (tmp
, scm_sym_name
)))
1152 scm_set_procedure_property_x (tmp
, scm_sym_name
, variable
);
1155 var
= scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_T
);
1156 SCM_VARIABLE_SET (var
, value
);
1158 return SCM_UNSPECIFIED
;
1163 /* This is a helper function for forms (<keyword> <expression>) that are
1164 * transformed into (#@<keyword> '() <memoized_expression>) in order to allow
1165 * for easy creation of a thunk (i. e. a closure without arguments) using the
1166 * ('() <memoized_expression>) tail of the memoized form. */
1168 memoize_as_thunk_prototype (const SCM expr
, const SCM env SCM_UNUSED
)
1170 const SCM cdr_expr
= SCM_CDR (expr
);
1171 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1172 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1174 SCM_SETCDR (expr
, scm_cons (SCM_EOL
, cdr_expr
));
1180 SCM_SYNTAX (s_delay
, "delay", scm_i_makbimacro
, scm_m_delay
);
1181 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
1183 /* Promises are implemented as closures with an empty parameter list. Thus,
1184 * (delay <expression>) is transformed into (#@delay '() <expression>), where
1185 * the empty list represents the empty parameter list. This representation
1186 * allows for easy creation of the closure during evaluation. */
1188 scm_m_delay (SCM expr
, SCM env
)
1190 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1191 SCM_SETCAR (new_expr
, SCM_IM_DELAY
);
1196 SCM_SYNTAX(s_do
, "do", scm_i_makbimacro
, scm_m_do
);
1197 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
1199 /* DO gets the most radically altered syntax. The order of the vars is
1200 * reversed here. During the evaluation this allows for simple consing of the
1201 * results of the inits and steps:
1203 (do ((<var1> <init1> <step1>)
1211 (#@do (<init1> <init2> ... <initn>)
1212 (varn ... var2 var1)
1215 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
1218 scm_m_do (SCM expr
, SCM env SCM_UNUSED
)
1220 SCM variables
= SCM_EOL
;
1221 SCM init_forms
= SCM_EOL
;
1222 SCM step_forms
= SCM_EOL
;
1229 const SCM cdr_expr
= SCM_CDR (expr
);
1230 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1231 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1233 /* Collect variables, init and step forms. */
1234 binding_idx
= SCM_CAR (cdr_expr
);
1235 ASSERT_SYNTAX_2 (scm_ilength (binding_idx
) >= 0,
1236 s_bad_bindings
, binding_idx
, expr
);
1237 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1239 const SCM binding
= SCM_CAR (binding_idx
);
1240 const long length
= scm_ilength (binding
);
1241 ASSERT_SYNTAX_2 (length
== 2 || length
== 3,
1242 s_bad_binding
, binding
, expr
);
1245 const SCM name
= SCM_CAR (binding
);
1246 const SCM init
= SCM_CADR (binding
);
1247 const SCM step
= (length
== 2) ? name
: SCM_CADDR (binding
);
1248 ASSERT_SYNTAX_2 (SCM_SYMBOLP (name
), s_bad_variable
, name
, expr
);
1249 ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (name
, variables
)),
1250 s_duplicate_binding
, name
, expr
);
1252 variables
= scm_cons (name
, variables
);
1253 init_forms
= scm_cons (init
, init_forms
);
1254 step_forms
= scm_cons (step
, step_forms
);
1257 init_forms
= scm_reverse_x (init_forms
, SCM_UNDEFINED
);
1258 step_forms
= scm_reverse_x (step_forms
, SCM_UNDEFINED
);
1260 /* Memoize the test form and the exit sequence. */
1261 cddr_expr
= SCM_CDR (cdr_expr
);
1262 exit_clause
= SCM_CAR (cddr_expr
);
1263 ASSERT_SYNTAX_2 (scm_ilength (exit_clause
) >= 1,
1264 s_bad_exit_clause
, exit_clause
, expr
);
1266 commands
= SCM_CDR (cddr_expr
);
1267 tail
= scm_cons2 (exit_clause
, commands
, step_forms
);
1268 tail
= scm_cons2 (init_forms
, variables
, tail
);
1269 SCM_SETCAR (expr
, SCM_IM_DO
);
1270 SCM_SETCDR (expr
, tail
);
1275 SCM_SYNTAX (s_if
, "if", scm_i_makbimacro
, scm_m_if
);
1276 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
1279 scm_m_if (SCM expr
, SCM env SCM_UNUSED
)
1281 const SCM cdr_expr
= SCM_CDR (expr
);
1282 const long length
= scm_ilength (cdr_expr
);
1283 ASSERT_SYNTAX (length
== 2 || length
== 3, s_expression
, expr
);
1284 SCM_SETCAR (expr
, SCM_IM_IF
);
1289 SCM_SYNTAX (s_lambda
, "lambda", scm_i_makbimacro
, scm_m_lambda
);
1290 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
1292 /* A helper function for memoize_lambda to support checking for duplicate
1293 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
1294 * LIST or to the cdr of the last cons. Therefore, LIST may have any of the
1295 * forms that a formal argument can have:
1296 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
1298 c_improper_memq (SCM obj
, SCM list
)
1300 for (; SCM_CONSP (list
); list
= SCM_CDR (list
))
1302 if (SCM_EQ_P (SCM_CAR (list
), obj
))
1305 return SCM_EQ_P (list
, obj
);
1309 scm_m_lambda (SCM expr
, SCM env SCM_UNUSED
)
1318 const SCM cdr_expr
= SCM_CDR (expr
);
1319 const long length
= scm_ilength (cdr_expr
);
1320 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1321 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1323 /* Before iterating the list of formal arguments, make sure the formals
1324 * actually are given as either a symbol or a non-cyclic list. */
1325 formals
= SCM_CAR (cdr_expr
);
1326 if (SCM_CONSP (formals
))
1328 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
1329 * detected, report a 'Bad formals' error. */
1333 ASSERT_SYNTAX_2 (SCM_SYMBOLP (formals
) || SCM_NULLP (formals
),
1334 s_bad_formals
, formals
, expr
);
1337 /* Now iterate the list of formal arguments to check if all formals are
1338 * symbols, and that there are no duplicates. */
1339 formals_idx
= formals
;
1340 while (SCM_CONSP (formals_idx
))
1342 const SCM formal
= SCM_CAR (formals_idx
);
1343 const SCM next_idx
= SCM_CDR (formals_idx
);
1344 ASSERT_SYNTAX_2 (SCM_SYMBOLP (formal
), s_bad_formal
, formal
, expr
);
1345 ASSERT_SYNTAX_2 (!c_improper_memq (formal
, next_idx
),
1346 s_duplicate_formal
, formal
, expr
);
1347 formals_idx
= next_idx
;
1349 ASSERT_SYNTAX_2 (SCM_NULLP (formals_idx
) || SCM_SYMBOLP (formals_idx
),
1350 s_bad_formal
, formals_idx
, expr
);
1352 /* Memoize the body. Keep a potential documentation string. */
1353 /* Dirk:FIXME:: We should probably extract the documentation string to
1354 * some external database. Otherwise it will slow down execution, since
1355 * the documentation string will have to be skipped with every execution
1356 * of the closure. */
1357 cddr_expr
= SCM_CDR (cdr_expr
);
1358 documentation
= (length
>= 3 && SCM_STRINGP (SCM_CAR (cddr_expr
)));
1359 body
= documentation
? SCM_CDR (cddr_expr
) : cddr_expr
;
1360 new_body
= m_body (SCM_IM_LAMBDA
, body
);
1362 SCM_SETCAR (expr
, SCM_IM_LAMBDA
);
1364 SCM_SETCDR (cddr_expr
, new_body
);
1366 SCM_SETCDR (cdr_expr
, new_body
);
1371 /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
1373 check_bindings (const SCM bindings
, const SCM expr
)
1377 ASSERT_SYNTAX_2 (scm_ilength (bindings
) >= 0,
1378 s_bad_bindings
, bindings
, expr
);
1380 binding_idx
= bindings
;
1381 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1383 SCM name
; /* const */
1385 const SCM binding
= SCM_CAR (binding_idx
);
1386 ASSERT_SYNTAX_2 (scm_ilength (binding
) == 2,
1387 s_bad_binding
, binding
, expr
);
1389 name
= SCM_CAR (binding
);
1390 ASSERT_SYNTAX_2 (SCM_SYMBOLP (name
), s_bad_variable
, name
, expr
);
1395 /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
1396 * transformed to the lists (vn ... v2 v1) and (i1 i2 ... in). That is, the
1397 * variables are returned in a list with their order reversed, and the init
1398 * forms are returned in a list in the same order as they are given in the
1399 * bindings. If a duplicate variable name is detected, an error is
1402 transform_bindings (
1403 const SCM bindings
, const SCM expr
,
1404 SCM
*const rvarptr
, SCM
*const initptr
)
1406 SCM rvariables
= SCM_EOL
;
1407 SCM rinits
= SCM_EOL
;
1408 SCM binding_idx
= bindings
;
1409 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1411 const SCM binding
= SCM_CAR (binding_idx
);
1412 const SCM cdr_binding
= SCM_CDR (binding
);
1413 const SCM name
= SCM_CAR (binding
);
1414 ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (name
, rvariables
)),
1415 s_duplicate_binding
, name
, expr
);
1416 rvariables
= scm_cons (name
, rvariables
);
1417 rinits
= scm_cons (SCM_CAR (cdr_binding
), rinits
);
1419 *rvarptr
= rvariables
;
1420 *initptr
= scm_reverse_x (rinits
, SCM_UNDEFINED
);
1424 SCM_SYNTAX(s_let
, "let", scm_i_makbimacro
, scm_m_let
);
1425 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
1427 /* This function is a helper function for memoize_let. It transforms
1428 * (let name ((var init) ...) body ...) into
1429 * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
1430 * and memoizes the expression. It is assumed that the caller has checked
1431 * that name is a symbol and that there are bindings and a body. */
1433 memoize_named_let (const SCM expr
, const SCM env SCM_UNUSED
)
1439 const SCM cdr_expr
= SCM_CDR (expr
);
1440 const SCM name
= SCM_CAR (cdr_expr
);
1441 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1442 const SCM bindings
= SCM_CAR (cddr_expr
);
1443 check_bindings (bindings
, expr
);
1445 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1446 variables
= scm_reverse_x (rvariables
, SCM_UNDEFINED
);
1449 const SCM let_body
= SCM_CDR (cddr_expr
);
1450 const SCM lambda_body
= m_body (SCM_IM_LET
, let_body
);
1451 const SCM lambda_tail
= scm_cons (variables
, lambda_body
);
1452 const SCM lambda_form
= scm_cons_source (expr
, scm_sym_lambda
, lambda_tail
);
1454 const SCM rvar
= scm_list_1 (name
);
1455 const SCM init
= scm_list_1 (lambda_form
);
1456 const SCM body
= m_body (SCM_IM_LET
, scm_list_1 (name
));
1457 const SCM letrec_tail
= scm_cons (rvar
, scm_cons (init
, body
));
1458 const SCM letrec_form
= scm_cons_source (expr
, SCM_IM_LETREC
, letrec_tail
);
1459 return scm_cons_source (expr
, letrec_form
, inits
);
1463 /* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1464 * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
1466 scm_m_let (SCM expr
, SCM env
)
1470 const SCM cdr_expr
= SCM_CDR (expr
);
1471 const long length
= scm_ilength (cdr_expr
);
1472 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1473 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1475 bindings
= SCM_CAR (cdr_expr
);
1476 if (SCM_SYMBOLP (bindings
))
1478 ASSERT_SYNTAX (length
>= 3, s_missing_expression
, expr
);
1479 return memoize_named_let (expr
, env
);
1482 check_bindings (bindings
, expr
);
1483 if (SCM_NULLP (bindings
) || SCM_NULLP (SCM_CDR (bindings
)))
1485 /* Special case: no bindings or single binding => let* is faster. */
1486 const SCM body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1487 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), bindings
, body
), env
);
1494 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1497 const SCM new_body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1498 const SCM new_tail
= scm_cons2 (rvariables
, inits
, new_body
);
1499 SCM_SETCAR (expr
, SCM_IM_LET
);
1500 SCM_SETCDR (expr
, new_tail
);
1507 SCM_SYNTAX (s_letstar
, "let*", scm_i_makbimacro
, scm_m_letstar
);
1508 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
1510 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1511 * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
1513 scm_m_letstar (SCM expr
, SCM env SCM_UNUSED
)
1518 const SCM cdr_expr
= SCM_CDR (expr
);
1519 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1520 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1522 binding_idx
= SCM_CAR (cdr_expr
);
1523 check_bindings (binding_idx
, expr
);
1525 /* Transform ((v1 i1) (v2 i2) ...) into (v1 i1 v2 i2 ...). The
1526 * transformation is done in place. At the beginning of one iteration of
1527 * the loop the variable binding_idx holds the form
1528 * P1:( (vn . P2:(in . ())) . P3:( (vn+1 in+1) ... ) ),
1529 * where P1, P2 and P3 indicate the pairs, that are relevant for the
1530 * transformation. P1 and P2 are modified in the loop, P3 remains
1531 * untouched. After the execution of the loop, P1 will hold
1532 * P1:( vn . P2:(in . P3:( (vn+1 in+1) ... )) )
1533 * and binding_idx will hold P3. */
1534 while (!SCM_NULLP (binding_idx
))
1536 const SCM cdr_binding_idx
= SCM_CDR (binding_idx
); /* remember P3 */
1537 const SCM binding
= SCM_CAR (binding_idx
);
1538 const SCM name
= SCM_CAR (binding
);
1539 const SCM cdr_binding
= SCM_CDR (binding
);
1541 SCM_SETCDR (cdr_binding
, cdr_binding_idx
); /* update P2 */
1542 SCM_SETCAR (binding_idx
, name
); /* update P1 */
1543 SCM_SETCDR (binding_idx
, cdr_binding
); /* update P1 */
1545 binding_idx
= cdr_binding_idx
; /* continue with P3 */
1548 new_body
= m_body (SCM_IM_LETSTAR
, SCM_CDR (cdr_expr
));
1549 SCM_SETCAR (expr
, SCM_IM_LETSTAR
);
1550 /* the bindings have been changed in place */
1551 SCM_SETCDR (cdr_expr
, new_body
);
1556 SCM_SYNTAX(s_letrec
, "letrec", scm_i_makbimacro
, scm_m_letrec
);
1557 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
1560 scm_m_letrec (SCM expr
, SCM env
)
1564 const SCM cdr_expr
= SCM_CDR (expr
);
1565 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1566 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1568 bindings
= SCM_CAR (cdr_expr
);
1569 if (SCM_NULLP (bindings
))
1571 /* no bindings, let* is executed faster */
1572 SCM body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1573 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), SCM_EOL
, body
), env
);
1581 check_bindings (bindings
, expr
);
1582 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1583 new_body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1584 return scm_cons2 (SCM_IM_LETREC
, rvariables
, scm_cons (inits
, new_body
));
1589 SCM_SYNTAX (s_or
, "or", scm_i_makbimacro
, scm_m_or
);
1590 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
1593 scm_m_or (SCM expr
, SCM env SCM_UNUSED
)
1595 const SCM cdr_expr
= SCM_CDR (expr
);
1596 const long length
= scm_ilength (cdr_expr
);
1598 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1602 /* Special case: (or) is replaced by #f. */
1607 SCM_SETCAR (expr
, SCM_IM_OR
);
1613 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
1614 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
1615 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
1616 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
1618 /* Internal function to handle a quasiquotation: 'form' is the parameter in
1619 * the call (quasiquotation form), 'env' is the environment where unquoted
1620 * expressions will be evaluated, and 'depth' is the current quasiquotation
1621 * nesting level and is known to be greater than zero. */
1623 iqq (SCM form
, SCM env
, unsigned long int depth
)
1625 if (SCM_CONSP (form
))
1627 const SCM tmp
= SCM_CAR (form
);
1628 if (SCM_EQ_P (tmp
, scm_sym_quasiquote
))
1630 const SCM args
= SCM_CDR (form
);
1631 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1632 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
1634 else if (SCM_EQ_P (tmp
, scm_sym_unquote
))
1636 const SCM args
= SCM_CDR (form
);
1637 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1639 return scm_eval_car (args
, env
);
1641 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
1643 else if (SCM_CONSP (tmp
)
1644 && SCM_EQ_P (SCM_CAR (tmp
), scm_sym_uq_splicing
))
1646 const SCM args
= SCM_CDR (tmp
);
1647 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1650 const SCM list
= scm_eval_car (args
, env
);
1651 const SCM rest
= SCM_CDR (form
);
1652 ASSERT_SYNTAX_2 (scm_ilength (list
) >= 0,
1653 s_splicing
, list
, form
);
1654 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
1657 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
1658 iqq (SCM_CDR (form
), env
, depth
));
1661 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
1662 iqq (SCM_CDR (form
), env
, depth
));
1664 else if (SCM_VECTORP (form
))
1666 size_t i
= SCM_VECTOR_LENGTH (form
);
1667 SCM
const *const data
= SCM_VELTS (form
);
1670 tmp
= scm_cons (data
[--i
], tmp
);
1671 scm_remember_upto_here_1 (form
);
1672 return scm_vector (iqq (tmp
, env
, depth
));
1679 scm_m_quasiquote (SCM expr
, SCM env
)
1681 const SCM cdr_expr
= SCM_CDR (expr
);
1682 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1683 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1684 return iqq (SCM_CAR (cdr_expr
), env
, 1);
1688 SCM_SYNTAX (s_quote
, "quote", scm_i_makbimacro
, scm_m_quote
);
1689 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
1692 scm_m_quote (SCM expr
, SCM env SCM_UNUSED
)
1696 const SCM cdr_expr
= SCM_CDR (expr
);
1697 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1698 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1699 quotee
= SCM_CAR (cdr_expr
);
1700 if (SCM_IMP (quotee
) && !SCM_NULLP (quotee
))
1702 else if (SCM_VECTORP (quotee
))
1705 /* The following optimization would be possible if all variable references
1706 * were resolved during memoization: */
1707 else if (SCM_SYMBOLP (quotee
))
1710 SCM_SETCAR (expr
, SCM_IM_QUOTE
);
1715 /* Will go into the RnRS module when Guile is factorized.
1716 SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
1717 static const char s_set_x
[] = "set!";
1718 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, s_set_x
);
1721 scm_m_set_x (SCM expr
, SCM env SCM_UNUSED
)
1725 const SCM cdr_expr
= SCM_CDR (expr
);
1726 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1727 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1728 variable
= SCM_CAR (cdr_expr
);
1729 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
) || SCM_VARIABLEP (variable
),
1730 s_bad_variable
, variable
, expr
);
1732 SCM_SETCAR (expr
, SCM_IM_SET_X
);
1737 /* Start of the memoizers for non-R5RS builtin macros. */
1740 SCM_SYNTAX (s_atapply
, "@apply", scm_i_makbimacro
, scm_m_apply
);
1741 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1742 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1745 scm_m_apply (SCM expr
, SCM env SCM_UNUSED
)
1747 const SCM cdr_expr
= SCM_CDR (expr
);
1748 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1749 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_missing_expression
, expr
);
1751 SCM_SETCAR (expr
, SCM_IM_APPLY
);
1756 SCM_SYNTAX (s_atbind
, "@bind", scm_i_makbimacro
, scm_m_atbind
);
1758 /* FIXME: The following explanation should go into the documentation: */
1759 /* (@bind ((var init) ...) body ...) will assign the values of the `init's to
1760 * the global variables named by `var's (symbols, not evaluated), creating
1761 * them if they don't exist, executes body, and then restores the previous
1762 * values of the `var's. Additionally, whenever control leaves body, the
1763 * values of the `var's are saved and restored when control returns. It is an
1764 * error when a symbol appears more than once among the `var's. All `init's
1765 * are evaluated before any `var' is set.
1767 * Think of this as `let' for dynamic scope.
1770 /* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into
1771 * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...).
1773 * FIXME - also implement `@bind*'.
1776 scm_m_atbind (SCM expr
, SCM env
)
1783 const SCM top_level
= scm_env_top_level (env
);
1785 const SCM cdr_expr
= SCM_CDR (expr
);
1786 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1787 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1788 bindings
= SCM_CAR (cdr_expr
);
1789 check_bindings (bindings
, expr
);
1790 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1792 for (variable_idx
= rvariables
;
1793 !SCM_NULLP (variable_idx
);
1794 variable_idx
= SCM_CDR (variable_idx
))
1796 /* The first call to scm_sym2var will look beyond the current module,
1797 * while the second call wont. */
1798 const SCM variable
= SCM_CAR (variable_idx
);
1799 SCM new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_F
);
1800 if (SCM_FALSEP (new_variable
))
1801 new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_T
);
1802 SCM_SETCAR (variable_idx
, new_variable
);
1805 SCM_SETCAR (expr
, SCM_IM_BIND
);
1806 SCM_SETCAR (cdr_expr
, scm_cons (rvariables
, inits
));
1811 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_i_makbimacro
, scm_m_cont
);
1812 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, s_atcall_cc
);
1815 scm_m_cont (SCM expr
, SCM env SCM_UNUSED
)
1817 const SCM cdr_expr
= SCM_CDR (expr
);
1818 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1819 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1821 SCM_SETCAR (expr
, SCM_IM_CONT
);
1826 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_i_makbimacro
, scm_m_at_call_with_values
);
1827 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
1830 scm_m_at_call_with_values (SCM expr
, SCM env SCM_UNUSED
)
1832 const SCM cdr_expr
= SCM_CDR (expr
);
1833 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1834 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1836 SCM_SETCAR (expr
, SCM_IM_CALL_WITH_VALUES
);
1841 SCM_SYNTAX (s_future
, "future", scm_i_makbimacro
, scm_m_future
);
1842 SCM_GLOBAL_SYMBOL (scm_sym_future
, s_future
);
1844 /* Like promises, futures are implemented as closures with an empty
1845 * parameter list. Thus, (future <expression>) is transformed into
1846 * (#@future '() <expression>), where the empty list represents the
1847 * empty parameter list. This representation allows for easy creation
1848 * of the closure during evaluation. */
1850 scm_m_future (SCM expr
, SCM env
)
1852 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1853 SCM_SETCAR (new_expr
, SCM_IM_FUTURE
);
1858 SCM_SYNTAX (s_gset_x
, "set!", scm_i_makbimacro
, scm_m_generalized_set_x
);
1859 SCM_SYMBOL (scm_sym_setter
, "setter");
1862 scm_m_generalized_set_x (SCM expr
, SCM env
)
1864 SCM target
, exp_target
;
1866 const SCM cdr_expr
= SCM_CDR (expr
);
1867 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1868 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1870 target
= SCM_CAR (cdr_expr
);
1871 if (!SCM_CONSP (target
))
1874 return scm_m_set_x (expr
, env
);
1878 /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */
1879 /* Macroexpanding the target might return things of the form
1880 (begin <atom>). In that case, <atom> must be a symbol or a
1881 variable and we memoize to (set! <atom> ...).
1883 exp_target
= scm_macroexp (target
, env
);
1884 if (SCM_EQ_P (SCM_CAR (exp_target
), SCM_IM_BEGIN
)
1885 && !SCM_NULLP (SCM_CDR (exp_target
))
1886 && SCM_NULLP (SCM_CDDR (exp_target
)))
1888 exp_target
= SCM_CADR (exp_target
);
1889 ASSERT_SYNTAX_2 (SCM_SYMBOLP (exp_target
)
1890 || SCM_VARIABLEP (exp_target
),
1891 s_bad_variable
, exp_target
, expr
);
1892 return scm_cons (SCM_IM_SET_X
, scm_cons (exp_target
,
1893 SCM_CDR (cdr_expr
)));
1897 const SCM setter_proc_tail
= scm_list_1 (SCM_CAR (target
));
1898 const SCM setter_proc
= scm_cons_source (expr
, scm_sym_setter
,
1901 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1902 const SCM setter_args
= scm_append_x (scm_list_2 (SCM_CDR (target
),
1905 SCM_SETCAR (expr
, setter_proc
);
1906 SCM_SETCDR (expr
, setter_args
);
1913 /* @slot-ref is bound privately in the (oop goops) module from goops.c. As
1914 * soon as the module system allows us to more freely create bindings in
1915 * arbitrary modules during the startup phase, the code from goops.c should be
1918 scm_m_atslot_ref (SCM expr
, SCM env SCM_UNUSED
)
1922 const SCM cdr_expr
= SCM_CDR (expr
);
1923 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1924 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1925 slot_nr
= SCM_CADR (cdr_expr
);
1926 ASSERT_SYNTAX_2 (SCM_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
1928 SCM_SETCAR (expr
, SCM_IM_SLOT_REF
);
1933 /* @slot-set! is bound privately in the (oop goops) module from goops.c. As
1934 * soon as the module system allows us to more freely create bindings in
1935 * arbitrary modules during the startup phase, the code from goops.c should be
1938 scm_m_atslot_set_x (SCM expr
, SCM env SCM_UNUSED
)
1942 const SCM cdr_expr
= SCM_CDR (expr
);
1943 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1944 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 3, s_expression
, expr
);
1945 slot_nr
= SCM_CADR (cdr_expr
);
1946 ASSERT_SYNTAX_2 (SCM_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
1948 SCM_SETCAR (expr
, SCM_IM_SLOT_SET_X
);
1953 #if SCM_ENABLE_ELISP
1955 static const char s_defun
[] = "Symbol's function definition is void";
1957 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_i_makbimacro
, scm_m_nil_cond
);
1959 /* nil-cond expressions have the form
1960 * (nil-cond COND VAL COND VAL ... ELSEVAL) */
1962 scm_m_nil_cond (SCM expr
, SCM env SCM_UNUSED
)
1964 const long length
= scm_ilength (SCM_CDR (expr
));
1965 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1966 ASSERT_SYNTAX (length
>= 1 && (length
% 2) == 1, s_expression
, expr
);
1968 SCM_SETCAR (expr
, SCM_IM_NIL_COND
);
1973 SCM_SYNTAX (s_atfop
, "@fop", scm_i_makbimacro
, scm_m_atfop
);
1975 /* The @fop-macro handles procedure and macro applications for elisp. The
1976 * input expression must have the form
1977 * (@fop <var> (transformer-macro <expr> ...))
1978 * where <var> must be a symbol. The expression is transformed into the
1979 * memoized form of either
1980 * (apply <un-aliased var> (transformer-macro <expr> ...))
1981 * if the value of var (across all aliasing) is not a macro, or
1982 * (<un-aliased var> <expr> ...)
1983 * if var is a macro. */
1985 scm_m_atfop (SCM expr
, SCM env SCM_UNUSED
)
1990 const SCM cdr_expr
= SCM_CDR (expr
);
1991 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1992 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 1, s_missing_expression
, expr
);
1994 symbol
= SCM_CAR (cdr_expr
);
1995 ASSERT_SYNTAX_2 (SCM_SYMBOLP (symbol
), s_bad_variable
, symbol
, expr
);
1997 location
= scm_symbol_fref (symbol
);
1998 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2000 /* The elisp function `defalias' allows to define aliases for symbols. To
2001 * look up such definitions, the chain of symbol definitions has to be
2002 * followed up to the terminal symbol. */
2003 while (SCM_SYMBOLP (SCM_VARIABLE_REF (location
)))
2005 const SCM alias
= SCM_VARIABLE_REF (location
);
2006 location
= scm_symbol_fref (alias
);
2007 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2010 /* Memoize the value location belonging to the terminal symbol. */
2011 SCM_SETCAR (cdr_expr
, location
);
2013 if (!SCM_MACROP (SCM_VARIABLE_REF (location
)))
2015 /* Since the location does not contain a macro, the form is a procedure
2016 * application. Replace `@fop' by `@apply' and transform the expression
2017 * including the `transformer-macro'. */
2018 SCM_SETCAR (expr
, SCM_IM_APPLY
);
2023 /* Since the location contains a macro, the arguments should not be
2024 * transformed, so the `transformer-macro' is cut out. The resulting
2025 * expression starts with the memoized variable, that is at the cdr of
2026 * the input expression. */
2027 SCM_SETCDR (cdr_expr
, SCM_CDADR (cdr_expr
));
2032 #endif /* SCM_ENABLE_ELISP */
2035 /* Start of the memoizers for deprecated macros. */
2038 #if (SCM_ENABLE_DEPRECATED == 1)
2040 SCM_SYNTAX (s_undefine
, "undefine", scm_makacro
, scm_m_undefine
);
2043 scm_m_undefine (SCM expr
, SCM env
)
2048 const SCM cdr_expr
= SCM_CDR (expr
);
2049 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), "Bad undefine placement in", expr
);
2050 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2051 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2053 variable
= SCM_CAR (cdr_expr
);
2054 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
), s_bad_variable
, variable
, expr
);
2055 location
= scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_F
);
2056 ASSERT_SYNTAX_2 (!SCM_FALSEP (location
)
2057 && !SCM_UNBNDP (SCM_VARIABLE_REF (location
)),
2058 "variable already unbound ", variable
, expr
);
2059 SCM_VARIABLE_SET (location
, SCM_UNDEFINED
);
2060 return SCM_UNSPECIFIED
;
2066 #if (SCM_ENABLE_DEPRECATED == 1)
2069 scm_macroexp (SCM x
, SCM env
)
2071 SCM res
, proc
, orig_sym
;
2073 /* Don't bother to produce error messages here. We get them when we
2074 eventually execute the code for real. */
2077 orig_sym
= SCM_CAR (x
);
2078 if (!SCM_SYMBOLP (orig_sym
))
2082 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
2083 if (proc_ptr
== NULL
)
2085 /* We have lost the race. */
2091 /* Only handle memoizing macros. `Acros' and `macros' are really
2092 special forms and should not be evaluated here. */
2094 if (!SCM_MACROP (proc
)
2095 || (SCM_MACRO_TYPE (proc
) != 2 && !SCM_BUILTIN_MACRO_P (proc
)))
2098 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
2099 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
2101 if (scm_ilength (res
) <= 0)
2102 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
2105 SCM_SETCAR (x
, SCM_CAR (res
));
2106 SCM_SETCDR (x
, SCM_CDR (res
));
2114 /*****************************************************************************/
2115 /*****************************************************************************/
2116 /* The definitions for unmemoization start here. */
2117 /*****************************************************************************/
2118 /*****************************************************************************/
2120 #define SCM_BIT7(x) (127 & SCM_UNPACK (x))
2122 SCM_SYMBOL (sym_three_question_marks
, "???");
2125 /* scm_unmemocopy takes a memoized expression together with its
2126 * environment and rewrites it to its original form. Thus, it is the
2127 * inversion of the rewrite rules above. The procedure is not
2128 * optimized for speed. It's used in scm_iprin1 when printing the
2129 * code of a closure, in scm_procedure_source, in display_frame when
2130 * generating the source for a stackframe in a backtrace, and in
2131 * display_expression.
2133 * Unmemoizing is not a reliable process. You cannot in general
2134 * expect to get the original source back.
2136 * However, GOOPS currently relies on this for method compilation.
2137 * This ought to change.
2141 build_binding_list (SCM rnames
, SCM rinits
)
2143 SCM bindings
= SCM_EOL
;
2144 while (!SCM_NULLP (rnames
))
2146 SCM binding
= scm_list_2 (SCM_CAR (rnames
), SCM_CAR (rinits
));
2147 bindings
= scm_cons (binding
, bindings
);
2148 rnames
= SCM_CDR (rnames
);
2149 rinits
= SCM_CDR (rinits
);
2156 unmemocar (SCM form
, SCM env
)
2158 if (!SCM_CONSP (form
))
2162 SCM c
= SCM_CAR (form
);
2163 if (SCM_VARIABLEP (c
))
2165 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
2166 if (SCM_FALSEP (sym
))
2167 sym
= sym_three_question_marks
;
2168 SCM_SETCAR (form
, sym
);
2170 else if (SCM_ILOCP (c
))
2172 unsigned long int ir
;
2174 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
2175 env
= SCM_CDR (env
);
2176 env
= SCM_CAAR (env
);
2177 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
2178 env
= SCM_CDR (env
);
2180 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
2187 #if (SCM_ENABLE_DEPRECATED == 1)
2190 scm_unmemocar (SCM form
, SCM env
)
2192 return unmemocar (form
, env
);
2199 scm_unmemocopy (SCM x
, SCM env
)
2204 if (SCM_VECTORP (x
))
2206 return scm_list_2 (scm_sym_quote
, x
);
2208 else if (!SCM_CONSP (x
))
2211 p
= scm_whash_lookup (scm_source_whash
, x
);
2212 switch (SCM_ITAG7 (SCM_CAR (x
)))
2214 case SCM_BIT7 (SCM_IM_AND
):
2215 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
2217 case SCM_BIT7 (SCM_IM_BEGIN
):
2218 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
2220 case SCM_BIT7 (SCM_IM_CASE
):
2221 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
2223 case SCM_BIT7 (SCM_IM_COND
):
2224 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
2226 case SCM_BIT7 (SCM_IM_DO
):
2228 /* format: (#@do (i1 ... ik) (nk nk-1 ...) (test) (body) s1 ... sk),
2229 * where ix is an initializer for a local variable, nx is the name of
2230 * the local variable, test is the test clause of the do loop, body is
2231 * the body of the do loop and sx are the step clauses for the local
2233 SCM names
, inits
, test
, memoized_body
, steps
, bindings
;
2236 inits
= scm_reverse (scm_unmemocopy (SCM_CAR (x
), env
));
2238 names
= SCM_CAR (x
);
2239 env
= SCM_EXTEND_ENV (names
, SCM_EOL
, env
);
2241 test
= scm_unmemocopy (SCM_CAR (x
), env
);
2243 memoized_body
= SCM_CAR (x
);
2245 steps
= scm_reverse (scm_unmemocopy (x
, env
));
2247 /* build transformed binding list */
2249 while (!SCM_NULLP (names
))
2251 SCM name
= SCM_CAR (names
);
2252 SCM init
= SCM_CAR (inits
);
2253 SCM step
= SCM_CAR (steps
);
2254 step
= SCM_EQ_P (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
2256 bindings
= scm_cons (scm_cons2 (name
, init
, step
), bindings
);
2258 names
= SCM_CDR (names
);
2259 inits
= SCM_CDR (inits
);
2260 steps
= SCM_CDR (steps
);
2262 z
= scm_cons (test
, SCM_UNSPECIFIED
);
2263 ls
= scm_cons2 (scm_sym_do
, bindings
, z
);
2265 x
= scm_cons (SCM_BOOL_F
, memoized_body
);
2268 case SCM_BIT7 (SCM_IM_IF
):
2269 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
2271 case SCM_BIT7 (SCM_IM_LET
):
2273 /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),
2274 * where nx is the name of a local variable, ix is an initializer for
2275 * the local variable and by are the body clauses. */
2276 SCM rnames
, rinits
, bindings
;
2279 rnames
= SCM_CAR (x
);
2281 rinits
= scm_reverse (scm_unmemocopy (SCM_CAR (x
), env
));
2282 env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
2284 bindings
= build_binding_list (rnames
, rinits
);
2285 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
2286 ls
= scm_cons (scm_sym_let
, z
);
2289 case SCM_BIT7 (SCM_IM_LETREC
):
2291 /* format: (#@letrec (vn ... v2 v1) (i1 i2 ... in) b1 ...),
2292 * where vx is the name of a local variable, ix is an initializer for
2293 * the local variable and by are the body clauses. */
2294 SCM rnames
, rinits
, bindings
;
2297 rnames
= SCM_CAR (x
);
2298 env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
2300 rinits
= scm_reverse (scm_unmemocopy (SCM_CAR (x
), env
));
2302 bindings
= build_binding_list (rnames
, rinits
);
2303 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
2304 ls
= scm_cons (scm_sym_letrec
, z
);
2307 case SCM_BIT7 (SCM_IM_LETSTAR
):
2315 env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2318 y
= z
= scm_acons (SCM_CAR (b
),
2320 scm_cons (scm_unmemocopy (SCM_CADR (b
), env
), SCM_EOL
), env
),
2322 env
= SCM_EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
2326 SCM_SETCDR (y
, SCM_EOL
);
2327 z
= scm_cons (y
, SCM_UNSPECIFIED
);
2328 ls
= scm_cons (scm_sym_let
, z
);
2333 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
2335 scm_list_1 (scm_unmemocopy (SCM_CADR (b
), env
)), env
),
2338 env
= SCM_EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
2341 while (SCM_NIMP (b
));
2342 SCM_SETCDR (z
, SCM_EOL
);
2344 z
= scm_cons (y
, SCM_UNSPECIFIED
);
2345 ls
= scm_cons (scm_sym_letstar
, z
);
2348 case SCM_BIT7 (SCM_IM_OR
):
2349 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
2351 case SCM_BIT7 (SCM_IM_LAMBDA
):
2353 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
);
2354 ls
= scm_cons (scm_sym_lambda
, z
);
2355 env
= SCM_EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
2357 case SCM_BIT7 (SCM_IM_QUOTE
):
2358 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
2360 case SCM_BIT7 (SCM_IM_SET_X
):
2361 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
2363 case SCM_BIT7 (SCM_MAKISYM (0)):
2365 switch (SCM_ISYMNUM (z
))
2367 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2368 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
2370 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2371 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
2373 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2374 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
2377 case (SCM_ISYMNUM (SCM_IM_FUTURE
)):
2378 ls
= z
= scm_cons (scm_sym_future
, SCM_UNSPECIFIED
);
2381 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2382 ls
= z
= scm_cons (scm_sym_at_call_with_values
, SCM_UNSPECIFIED
);
2384 case (SCM_ISYMNUM (SCM_IM_ELSE
)):
2385 ls
= z
= scm_cons (scm_sym_else
, SCM_UNSPECIFIED
);
2388 /* appease the Sun compiler god: */ ;
2391 ls
= z
= unmemocar (scm_cons (scm_unmemocopy (SCM_CAR (x
), env
),
2397 while (SCM_CONSP (x
))
2399 SCM form
= SCM_CAR (x
);
2400 if (!SCM_ISYMP (form
))
2402 SCM copy
= scm_cons (scm_unmemocopy (form
, env
), SCM_UNSPECIFIED
);
2403 SCM_SETCDR (z
, unmemocar (copy
, env
));
2406 else if (SCM_EQ_P (form
, SCM_IM_ARROW
))
2408 SCM_SETCDR (z
, scm_cons (scm_sym_arrow
, SCM_UNSPECIFIED
));
2414 if (!SCM_FALSEP (p
))
2415 scm_whash_insert (scm_source_whash
, ls
, p
);
2420 /*****************************************************************************/
2421 /*****************************************************************************/
2422 /* The definitions for execution start here. */
2423 /*****************************************************************************/
2424 /*****************************************************************************/
2426 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
2427 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
2428 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
2429 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
2431 /* A function object to implement "apply" for non-closure functions. */
2433 /* An endless list consisting of #<undefined> objects: */
2434 static SCM undefineds
;
2438 scm_badargsp (SCM formals
, SCM args
)
2440 while (!SCM_NULLP (formals
))
2442 if (!SCM_CONSP (formals
))
2444 if (SCM_NULLP (args
))
2446 formals
= SCM_CDR (formals
);
2447 args
= SCM_CDR (args
);
2449 return !SCM_NULLP (args
) ? 1 : 0;
2454 /* The evaluator contains a plethora of EVAL symbols.
2455 * This is an attempt at explanation.
2457 * The following macros should be used in code which is read twice
2458 * (where the choice of evaluator is hard soldered):
2460 * SCM_CEVAL is the symbol used within one evaluator to call itself.
2461 * Originally, it is defined to scm_ceval, but is redefined to
2462 * scm_deval during the second pass.
2464 * SCM_EVALIM is used when it is known that the expression is an
2465 * immediate. (This macro never calls an evaluator.)
2467 * EVALCAR evaluates the car of an expression.
2469 * The following macros should be used in code which is read once
2470 * (where the choice of evaluator is dynamic):
2472 * SCM_XEVAL takes care of immediates without calling an evaluator. It
2473 * then calls scm_ceval *or* scm_deval, depending on the debugging
2476 * SCM_XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
2477 * depending on the debugging mode.
2479 * The main motivation for keeping this plethora is efficiency
2480 * together with maintainability (=> locality of code).
2483 #define SCM_CEVAL scm_ceval
2485 #define SCM_EVALIM2(x) \
2486 ((SCM_EQ_P ((x), SCM_EOL) \
2487 ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \
2491 #define SCM_EVALIM(x, env) (SCM_ILOCP (x) \
2492 ? *scm_ilookup ((x), env) \
2495 #define SCM_XEVAL(x, env) (SCM_IMP (x) \
2497 : (*scm_ceval_ptr) ((x), (env)))
2499 #define SCM_XEVALCAR(x, env) (SCM_IMP (SCM_CAR (x)) \
2500 ? SCM_EVALIM (SCM_CAR (x), env) \
2501 : (SCM_SYMBOLP (SCM_CAR (x)) \
2502 ? *scm_lookupcar (x, env, 1) \
2503 : (*scm_ceval_ptr) (SCM_CAR (x), env)))
2505 #define EVALCAR(x, env) (SCM_IMP (SCM_CAR (x)) \
2506 ? SCM_EVALIM (SCM_CAR (x), env) \
2507 : (SCM_SYMBOLP (SCM_CAR (x)) \
2508 ? *scm_lookupcar (x, env, 1) \
2509 : SCM_CEVAL (SCM_CAR (x), env)))
2511 SCM_REC_MUTEX (source_mutex
);
2515 scm_eval_car (SCM pair
, SCM env
)
2517 return SCM_XEVALCAR (pair
, env
);
2522 scm_eval_args (SCM l
, SCM env
, SCM proc
)
2524 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
2525 while (SCM_CONSP (l
))
2527 res
= EVALCAR (l
, env
);
2529 *lloc
= scm_list_1 (res
);
2530 lloc
= SCM_CDRLOC (*lloc
);
2534 scm_wrong_num_args (proc
);
2540 scm_eval_body (SCM code
, SCM env
)
2544 next
= SCM_CDR (code
);
2545 while (!SCM_NULLP (next
))
2547 if (SCM_IMP (SCM_CAR (code
)))
2549 if (SCM_ISYMP (SCM_CAR (code
)))
2551 scm_rec_mutex_lock (&source_mutex
);
2552 /* check for race condition */
2553 if (SCM_ISYMP (SCM_CAR (code
)))
2554 m_expand_body (code
, env
);
2555 scm_rec_mutex_unlock (&source_mutex
);
2560 SCM_XEVAL (SCM_CAR (code
), env
);
2562 next
= SCM_CDR (code
);
2564 return SCM_XEVALCAR (code
, env
);
2570 /* SECTION: This code is specific for the debugging support. One
2571 * branch is read when DEVAL isn't defined, the other when DEVAL is
2577 #define SCM_APPLY scm_apply
2578 #define PREP_APPLY(proc, args)
2580 #define RETURN(x) do { return x; } while (0)
2581 #ifdef STACK_CHECKING
2582 #ifndef NO_CEVAL_STACK_CHECKING
2583 #define EVAL_STACK_CHECKING
2590 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
2592 #define SCM_APPLY scm_dapply
2594 #define PREP_APPLY(p, l) \
2595 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
2597 #define ENTER_APPLY \
2599 SCM_SET_ARGSREADY (debug);\
2600 if (scm_check_apply_p && SCM_TRAPS_P)\
2601 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
2603 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
2604 SCM_SET_TRACED_FRAME (debug); \
2606 if (SCM_CHEAPTRAPS_P)\
2608 tmp = scm_make_debugobj (&debug);\
2609 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
2614 tmp = scm_make_continuation (&first);\
2616 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
2622 #define RETURN(e) do { proc = (e); goto exit; } while (0)
2623 #ifdef STACK_CHECKING
2624 #ifndef EVAL_STACK_CHECKING
2625 #define EVAL_STACK_CHECKING
2629 /* scm_ceval_ptr points to the currently selected evaluator.
2630 * *fixme*: Although efficiency is important here, this state variable
2631 * should probably not be a global. It should be related to the
2636 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
2638 /* scm_last_debug_frame contains a pointer to the last debugging
2639 * information stack frame. It is accessed very often from the
2640 * debugging evaluator, so it should probably not be indirectly
2641 * addressed. Better to save and restore it from the current root at
2645 /* scm_debug_eframe_size is the number of slots available for pseudo
2646 * stack frames at each real stack frame.
2649 long scm_debug_eframe_size
;
2651 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
2653 long scm_eval_stack
;
2655 scm_t_option scm_eval_opts
[] = {
2656 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
2659 scm_t_option scm_debug_opts
[] = {
2660 { SCM_OPTION_BOOLEAN
, "cheap", 1,
2661 "*Flyweight representation of the stack at traps." },
2662 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
2663 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
2664 { SCM_OPTION_BOOLEAN
, "procnames", 1,
2665 "Record procedure names at definition." },
2666 { SCM_OPTION_BOOLEAN
, "backwards", 0,
2667 "Display backtrace in anti-chronological order." },
2668 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
2669 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
2670 { SCM_OPTION_INTEGER
, "frames", 3,
2671 "Maximum number of tail-recursive frames in backtrace." },
2672 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
2673 "Maximal number of stored backtrace frames." },
2674 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
2675 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
2676 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
2677 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
2678 { 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."}
2681 scm_t_option scm_evaluator_trap_table
[] = {
2682 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
2683 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
2684 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
2685 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
2686 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
2687 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
2688 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
2691 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
2693 "Option interface for the evaluation options. Instead of using\n"
2694 "this procedure directly, use the procedures @code{eval-enable},\n"
2695 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
2696 #define FUNC_NAME s_scm_eval_options_interface
2700 ans
= scm_options (setting
,
2704 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
2711 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
2713 "Option interface for the evaluator trap options.")
2714 #define FUNC_NAME s_scm_evaluator_traps
2718 ans
= scm_options (setting
,
2719 scm_evaluator_trap_table
,
2720 SCM_N_EVALUATOR_TRAPS
,
2722 SCM_RESET_DEBUG_MODE
;
2730 deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
2732 SCM
*results
= lloc
, res
;
2733 while (SCM_CONSP (l
))
2735 res
= EVALCAR (l
, env
);
2737 *lloc
= scm_list_1 (res
);
2738 lloc
= SCM_CDRLOC (*lloc
);
2742 scm_wrong_num_args (proc
);
2749 /* SECTION: This code is compiled twice.
2753 /* Update the toplevel environment frame ENV so that it refers to the
2754 * current module. */
2755 #define UPDATE_TOPLEVEL_ENV(env) \
2757 SCM p = scm_current_module_lookup_closure (); \
2758 if (p != SCM_CAR (env)) \
2759 env = scm_top_level_env (p); \
2763 #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
2764 ASSERT_SYNTAX (!SCM_EQ_P ((x), SCM_EOL), s_empty_combination, x)
2767 /* This is the evaluator. Like any real monster, it has three heads:
2769 * scm_ceval is the non-debugging evaluator, scm_deval is the debugging
2770 * version. Both are implemented using a common code base, using the
2771 * following mechanism: SCM_CEVAL is a macro, which is either defined to
2772 * scm_ceval or scm_deval. Thus, there is no function SCM_CEVAL, but the code
2773 * for SCM_CEVAL actually compiles to either scm_ceval or scm_deval. When
2774 * SCM_CEVAL is defined to scm_ceval, it is known that the macro DEVAL is not
2775 * defined. When SCM_CEVAL is defined to scm_deval, then the macro DEVAL is
2776 * known to be defined. Thus, in SCM_CEVAL parts for the debugging evaluator
2777 * are enclosed within #ifdef DEVAL ... #endif.
2779 * All three (scm_ceval, scm_deval and their common implementation SCM_CEVAL)
2780 * take two input parameters, x and env: x is a single expression to be
2781 * evalutated. env is the environment in which bindings are searched.
2783 * x is known to be a cell (i. e. a pair or any other non-immediate). Since x
2784 * is a single expression, it is necessarily in a tail position. If x is just
2785 * a call to another function like in the expression (foo exp1 exp2 ...), the
2786 * realization of that call therefore _must_not_ increase stack usage (the
2787 * evaluation of exp1, exp2 etc., however, may do so). This is realized by
2788 * making extensive use of 'goto' statements within the evaluator: The gotos
2789 * replace recursive calls to SCM_CEVAL, thus re-using the same stack frame
2790 * that SCM_CEVAL was already using. If, however, x represents some form that
2791 * requires to evaluate a sequence of expressions like (begin exp1 exp2 ...),
2792 * then recursive calls to SCM_CEVAL are performed for all but the last
2793 * expression of that sequence. */
2797 scm_ceval (SCM x
, SCM env
)
2803 scm_deval (SCM x
, SCM env
)
2808 SCM_CEVAL (SCM x
, SCM env
)
2812 scm_t_debug_frame debug
;
2813 scm_t_debug_info
*debug_info_end
;
2814 debug
.prev
= scm_last_debug_frame
;
2817 * The debug.vect contains twice as much scm_t_debug_info frames as the
2818 * user has specified with (debug-set! frames <n>).
2820 * Even frames are eval frames, odd frames are apply frames.
2822 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
2823 * sizeof (scm_t_debug_info
));
2824 debug
.info
= debug
.vect
;
2825 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
2826 scm_last_debug_frame
= &debug
;
2828 #ifdef EVAL_STACK_CHECKING
2829 if (scm_stack_checking_enabled_p
&& SCM_STACK_OVERFLOW_P (&proc
))
2832 debug
.info
->e
.exp
= x
;
2833 debug
.info
->e
.env
= env
;
2835 scm_report_stack_overflow ();
2845 SCM_CLEAR_ARGSREADY (debug
);
2846 if (SCM_OVERFLOWP (debug
))
2849 * In theory, this should be the only place where it is necessary to
2850 * check for space in debug.vect since both eval frames and
2851 * available space are even.
2853 * For this to be the case, however, it is necessary that primitive
2854 * special forms which jump back to `loop', `begin' or some similar
2855 * label call PREP_APPLY.
2857 else if (++debug
.info
>= debug_info_end
)
2859 SCM_SET_OVERFLOW (debug
);
2864 debug
.info
->e
.exp
= x
;
2865 debug
.info
->e
.env
= env
;
2866 if (scm_check_entry_p
&& SCM_TRAPS_P
)
2868 if (SCM_ENTER_FRAME_P
2869 || (SCM_BREAKPOINTS_P
&& scm_c_source_property_breakpoint_p (x
)))
2872 SCM tail
= SCM_BOOL (SCM_TAILRECP (debug
));
2873 SCM_SET_TAILREC (debug
);
2874 if (SCM_CHEAPTRAPS_P
)
2875 stackrep
= scm_make_debugobj (&debug
);
2879 SCM val
= scm_make_continuation (&first
);
2889 /* This gives the possibility for the debugger to
2890 modify the source expression before evaluation. */
2895 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
2896 scm_sym_enter_frame
,
2899 scm_unmemocopy (x
, env
));
2906 switch (SCM_TYP7 (x
))
2908 case SCM_BIT7 (SCM_IM_AND
):
2910 while (!SCM_NULLP (SCM_CDR (x
)))
2912 SCM test_result
= EVALCAR (x
, env
);
2913 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
2914 RETURN (SCM_BOOL_F
);
2918 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2921 case SCM_BIT7 (SCM_IM_BEGIN
):
2924 RETURN (SCM_UNSPECIFIED
);
2926 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2929 /* If we are on toplevel with a lookup closure, we need to sync
2930 with the current module. */
2931 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
2933 UPDATE_TOPLEVEL_ENV (env
);
2934 while (!SCM_NULLP (SCM_CDR (x
)))
2937 UPDATE_TOPLEVEL_ENV (env
);
2943 goto nontoplevel_begin
;
2946 while (!SCM_NULLP (SCM_CDR (x
)))
2948 SCM form
= SCM_CAR (x
);
2951 if (SCM_ISYMP (form
))
2953 scm_rec_mutex_lock (&source_mutex
);
2954 /* check for race condition */
2955 if (SCM_ISYMP (SCM_CAR (x
)))
2956 m_expand_body (x
, env
);
2957 scm_rec_mutex_unlock (&source_mutex
);
2958 goto nontoplevel_begin
;
2961 SCM_VALIDATE_NON_EMPTY_COMBINATION (form
);
2964 SCM_CEVAL (form
, env
);
2970 /* scm_eval last form in list */
2971 SCM last_form
= SCM_CAR (x
);
2973 if (SCM_CONSP (last_form
))
2975 /* This is by far the most frequent case. */
2977 goto loop
; /* tail recurse */
2979 else if (SCM_IMP (last_form
))
2980 RETURN (SCM_EVALIM (last_form
, env
));
2981 else if (SCM_VARIABLEP (last_form
))
2982 RETURN (SCM_VARIABLE_REF (last_form
));
2983 else if (SCM_SYMBOLP (last_form
))
2984 RETURN (*scm_lookupcar (x
, env
, 1));
2990 case SCM_BIT7 (SCM_IM_CASE
):
2993 SCM key
= EVALCAR (x
, env
);
2995 while (!SCM_NULLP (x
))
2997 SCM clause
= SCM_CAR (x
);
2998 SCM labels
= SCM_CAR (clause
);
2999 if (SCM_EQ_P (labels
, SCM_IM_ELSE
))
3001 x
= SCM_CDR (clause
);
3002 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3005 while (!SCM_NULLP (labels
))
3007 SCM label
= SCM_CAR (labels
);
3008 if (SCM_EQ_P (label
, key
) || !SCM_FALSEP (scm_eqv_p (label
, key
)))
3010 x
= SCM_CDR (clause
);
3011 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3014 labels
= SCM_CDR (labels
);
3019 RETURN (SCM_UNSPECIFIED
);
3022 case SCM_BIT7 (SCM_IM_COND
):
3024 while (!SCM_NULLP (x
))
3026 SCM clause
= SCM_CAR (x
);
3027 if (SCM_EQ_P (SCM_CAR (clause
), SCM_IM_ELSE
))
3029 x
= SCM_CDR (clause
);
3030 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3035 arg1
= EVALCAR (clause
, env
);
3036 if (!SCM_FALSEP (arg1
) && !SCM_NILP (arg1
))
3038 x
= SCM_CDR (clause
);
3041 else if (!SCM_EQ_P (SCM_CAR (x
), SCM_IM_ARROW
))
3043 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3049 proc
= EVALCAR (proc
, env
);
3050 PREP_APPLY (proc
, scm_list_1 (arg1
));
3058 RETURN (SCM_UNSPECIFIED
);
3061 case SCM_BIT7 (SCM_IM_DO
):
3064 /* Compute the initialization values and the initial environment. */
3065 SCM init_forms
= SCM_CAR (x
);
3066 SCM init_values
= SCM_EOL
;
3067 while (!SCM_NULLP (init_forms
))
3069 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3070 init_forms
= SCM_CDR (init_forms
);
3073 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
3077 SCM test_form
= SCM_CAR (x
);
3078 SCM body_forms
= SCM_CADR (x
);
3079 SCM step_forms
= SCM_CDDR (x
);
3081 SCM test_result
= EVALCAR (test_form
, env
);
3083 while (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
3086 /* Evaluate body forms. */
3088 for (temp_forms
= body_forms
;
3089 !SCM_NULLP (temp_forms
);
3090 temp_forms
= SCM_CDR (temp_forms
))
3092 SCM form
= SCM_CAR (temp_forms
);
3093 /* Dirk:FIXME: We only need to eval forms, that may have a
3094 * side effect here. This is only true for forms that start
3095 * with a pair. All others are just constants. However,
3096 * since in the common case there is no constant expression
3097 * in a body of a do form, we just check for immediates here
3098 * and have SCM_CEVAL take care of other cases. In the long
3099 * run it would make sense to get rid of this test and have
3100 * the macro transformer of 'do' eliminate all forms that
3101 * have no sideeffect. */
3102 if (!SCM_IMP (form
))
3103 SCM_CEVAL (form
, env
);
3108 /* Evaluate the step expressions. */
3110 SCM step_values
= SCM_EOL
;
3111 for (temp_forms
= step_forms
;
3112 !SCM_NULLP (temp_forms
);
3113 temp_forms
= SCM_CDR (temp_forms
))
3115 SCM value
= EVALCAR (temp_forms
, env
);
3116 step_values
= scm_cons (value
, step_values
);
3118 env
= SCM_EXTEND_ENV (SCM_CAAR (env
),
3123 test_result
= EVALCAR (test_form
, env
);
3128 RETURN (SCM_UNSPECIFIED
);
3129 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3130 goto nontoplevel_begin
;
3133 case SCM_BIT7 (SCM_IM_IF
):
3136 SCM test_result
= EVALCAR (x
, env
);
3137 x
= SCM_CDR (x
); /* then expression */
3138 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
3140 x
= SCM_CDR (x
); /* else expression */
3142 RETURN (SCM_UNSPECIFIED
);
3145 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3149 case SCM_BIT7 (SCM_IM_LET
):
3152 SCM init_forms
= SCM_CADR (x
);
3153 SCM init_values
= SCM_EOL
;
3156 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3157 init_forms
= SCM_CDR (init_forms
);
3159 while (!SCM_NULLP (init_forms
));
3160 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
3163 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3164 goto nontoplevel_begin
;
3167 case SCM_BIT7 (SCM_IM_LETREC
):
3169 env
= SCM_EXTEND_ENV (SCM_CAR (x
), undefineds
, env
);
3172 SCM init_forms
= SCM_CAR (x
);
3173 SCM init_values
= SCM_EOL
;
3176 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3177 init_forms
= SCM_CDR (init_forms
);
3179 while (!SCM_NULLP (init_forms
));
3180 SCM_SETCDR (SCM_CAR (env
), init_values
);
3183 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3184 goto nontoplevel_begin
;
3187 case SCM_BIT7 (SCM_IM_LETSTAR
):
3190 SCM bindings
= SCM_CAR (x
);
3191 if (SCM_NULLP (bindings
))
3192 env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
3197 SCM name
= SCM_CAR (bindings
);
3198 SCM init
= SCM_CDR (bindings
);
3199 env
= SCM_EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
3200 bindings
= SCM_CDR (init
);
3202 while (!SCM_NULLP (bindings
));
3206 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3207 goto nontoplevel_begin
;
3210 case SCM_BIT7 (SCM_IM_OR
):
3212 while (!SCM_NULLP (SCM_CDR (x
)))
3214 SCM val
= EVALCAR (x
, env
);
3215 if (!SCM_FALSEP (val
) && !SCM_NILP (val
))
3220 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3224 case SCM_BIT7 (SCM_IM_LAMBDA
):
3225 RETURN (scm_closure (SCM_CDR (x
), env
));
3228 case SCM_BIT7 (SCM_IM_QUOTE
):
3229 RETURN (SCM_CADR (x
));
3232 case SCM_BIT7 (SCM_IM_SET_X
):
3236 SCM variable
= SCM_CAR (x
);
3237 if (SCM_ILOCP (variable
))
3238 location
= scm_ilookup (variable
, env
);
3239 else if (SCM_VARIABLEP (variable
))
3240 location
= SCM_VARIABLE_LOC (variable
);
3241 else /* (SCM_SYMBOLP (variable)) is known to be true */
3242 location
= scm_lookupcar (x
, env
, 1);
3244 *location
= EVALCAR (x
, env
);
3246 RETURN (SCM_UNSPECIFIED
);
3249 /* new syntactic forms go here. */
3250 case SCM_BIT7 (SCM_MAKISYM (0)):
3252 switch (SCM_ISYMNUM (proc
))
3256 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
3257 /* Evaluate the procedure to be applied. */
3259 proc
= EVALCAR (x
, env
);
3260 PREP_APPLY (proc
, SCM_EOL
);
3262 /* Evaluate the argument holding the list of arguments */
3264 arg1
= EVALCAR (x
, env
);
3267 /* Go here to tail-apply a procedure. PROC is the procedure and
3268 * ARG1 is the list of arguments. PREP_APPLY must have been called
3269 * before jumping to apply_proc. */
3270 if (SCM_CLOSUREP (proc
))
3272 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3274 debug
.info
->a
.args
= arg1
;
3276 if (scm_badargsp (formals
, arg1
))
3277 scm_wrong_num_args (proc
);
3279 /* Copy argument list */
3280 if (SCM_NULL_OR_NIL_P (arg1
))
3281 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
3284 SCM args
= scm_list_1 (SCM_CAR (arg1
));
3286 arg1
= SCM_CDR (arg1
);
3287 while (!SCM_NULL_OR_NIL_P (arg1
))
3289 SCM new_tail
= scm_list_1 (SCM_CAR (arg1
));
3290 SCM_SETCDR (tail
, new_tail
);
3292 arg1
= SCM_CDR (arg1
);
3294 env
= SCM_EXTEND_ENV (formals
, args
, SCM_ENV (proc
));
3297 x
= SCM_CLOSURE_BODY (proc
);
3298 goto nontoplevel_begin
;
3303 RETURN (SCM_APPLY (proc
, arg1
, SCM_EOL
));
3307 case (SCM_ISYMNUM (SCM_IM_CONT
)):
3310 SCM val
= scm_make_continuation (&first
);
3318 proc
= EVALCAR (proc
, env
);
3319 PREP_APPLY (proc
, scm_list_1 (arg1
));
3326 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
3327 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
3330 case (SCM_ISYMNUM (SCM_IM_FUTURE
)):
3331 RETURN (scm_i_make_future (scm_closure (SCM_CDR (x
), env
)));
3334 /* PLACEHOLDER for case (SCM_ISYMNUM (SCM_IM_DISPATCH)): The
3335 following code (type_dispatch) is intended to be the tail
3336 of the case clause for the internal macro
3337 SCM_IM_DISPATCH. Please don't remove it from this
3338 location without discussing it with Mikael
3339 <djurfeldt@nada.kth.se> */
3341 /* The type dispatch code is duplicated below
3342 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
3343 * cuts down execution time for type dispatch to 50%. */
3344 type_dispatch
: /* inputs: x, arg1 */
3345 /* Type dispatch means to determine from the types of the function
3346 * arguments (i. e. the 'signature' of the call), which method from
3347 * a generic function is to be called. This process of selecting
3348 * the right method takes some time. To speed it up, guile uses
3349 * caching: Together with the macro call to dispatch the signatures
3350 * of some previous calls to that generic function from the same
3351 * place are stored (in the code!) in a cache that we call the
3352 * 'method cache'. This is done since it is likely, that
3353 * consecutive calls to dispatch from that position in the code will
3354 * have the same signature. Thus, the type dispatch works as
3355 * follows: First, determine a hash value from the signature of the
3356 * actual arguments. Second, use this hash value as an index to
3357 * find that same signature in the method cache stored at this
3358 * position in the code. If found, you have also found the
3359 * corresponding method that belongs to that signature. If the
3360 * signature is not found in the method cache, you have to perform a
3361 * full search over all signatures stored with the generic
3364 unsigned long int specializers
;
3365 unsigned long int hash_value
;
3366 unsigned long int cache_end_pos
;
3367 unsigned long int mask
;
3371 SCM z
= SCM_CDDR (x
);
3372 SCM tmp
= SCM_CADR (z
);
3373 specializers
= SCM_INUM (SCM_CAR (z
));
3375 /* Compute a hash value for searching the method cache. There
3376 * are two variants for computing the hash value, a (rather)
3377 * complicated one, and a simple one. For the complicated one
3378 * explained below, tmp holds a number that is used in the
3380 if (SCM_INUMP (tmp
))
3382 /* Use the signature of the actual arguments to determine
3383 * the hash value. This is done as follows: Each class has
3384 * an array of random numbers, that are determined when the
3385 * class is created. The integer 'hashset' is an index into
3386 * that array of random numbers. Now, from all classes that
3387 * are part of the signature of the actual arguments, the
3388 * random numbers at index 'hashset' are taken and summed
3389 * up, giving the hash value. The value of 'hashset' is
3390 * stored at the call to dispatch. This allows to have
3391 * different 'formulas' for calculating the hash value at
3392 * different places where dispatch is called. This allows
3393 * to optimize the hash formula at every individual place
3394 * where dispatch is called, such that hopefully the hash
3395 * value that is computed will directly point to the right
3396 * method in the method cache. */
3397 unsigned long int hashset
= SCM_INUM (tmp
);
3398 unsigned long int counter
= specializers
+ 1;
3401 while (!SCM_NULLP (tmp_arg
) && counter
!= 0)
3403 SCM
class = scm_class_of (SCM_CAR (tmp_arg
));
3404 hash_value
+= SCM_INSTANCE_HASH (class, hashset
);
3405 tmp_arg
= SCM_CDR (tmp_arg
);
3409 method_cache
= SCM_CADR (z
);
3410 mask
= SCM_INUM (SCM_CAR (z
));
3412 cache_end_pos
= hash_value
;
3416 /* This method of determining the hash value is much
3417 * simpler: Set the hash value to zero and just perform a
3418 * linear search through the method cache. */
3420 mask
= (unsigned long int) ((long) -1);
3422 cache_end_pos
= SCM_VECTOR_LENGTH (method_cache
);
3427 /* Search the method cache for a method with a matching
3428 * signature. Start the search at position 'hash_value'. The
3429 * hashing implementation uses linear probing for conflict
3430 * resolution, that is, if the signature in question is not
3431 * found at the starting index in the hash table, the next table
3432 * entry is tried, and so on, until in the worst case the whole
3433 * cache has been searched, but still the signature has not been
3438 SCM args
= arg1
; /* list of arguments */
3439 z
= SCM_VELTS (method_cache
)[hash_value
];
3440 while (!SCM_NULLP (args
))
3442 /* More arguments than specifiers => CLASS != ENV */
3443 SCM class_of_arg
= scm_class_of (SCM_CAR (args
));
3444 if (!SCM_EQ_P (class_of_arg
, SCM_CAR (z
)))
3446 args
= SCM_CDR (args
);
3449 /* Fewer arguments than specifiers => CAR != ENV */
3450 if (SCM_NULLP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
)))
3453 hash_value
= (hash_value
+ 1) & mask
;
3454 } while (hash_value
!= cache_end_pos
);
3456 /* No appropriate method was found in the cache. */
3457 z
= scm_memoize_method (x
, arg1
);
3459 apply_cmethod
: /* inputs: z, arg1 */
3461 SCM formals
= SCM_CMETHOD_FORMALS (z
);
3462 env
= SCM_EXTEND_ENV (formals
, arg1
, SCM_CMETHOD_ENV (z
));
3463 x
= SCM_CMETHOD_BODY (z
);
3464 goto nontoplevel_begin
;
3470 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
3473 SCM instance
= EVALCAR (x
, env
);
3474 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
3475 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance
) [slot
]));
3479 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
3482 SCM instance
= EVALCAR (x
, env
);
3483 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
3484 SCM value
= EVALCAR (SCM_CDDR (x
), env
);
3485 SCM_STRUCT_DATA (instance
) [slot
] = SCM_UNPACK (value
);
3486 RETURN (SCM_UNSPECIFIED
);
3490 #if SCM_ENABLE_ELISP
3492 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
3494 SCM test_form
= SCM_CDR (x
);
3495 x
= SCM_CDR (test_form
);
3496 while (!SCM_NULL_OR_NIL_P (x
))
3498 SCM test_result
= EVALCAR (test_form
, env
);
3499 if (!(SCM_FALSEP (test_result
)
3500 || SCM_NULL_OR_NIL_P (test_result
)))
3502 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
3503 RETURN (test_result
);
3504 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3509 test_form
= SCM_CDR (x
);
3510 x
= SCM_CDR (test_form
);
3514 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3518 #endif /* SCM_ENABLE_ELISP */
3520 case (SCM_ISYMNUM (SCM_IM_BIND
)):
3522 SCM vars
, exps
, vals
;
3525 vars
= SCM_CAAR (x
);
3526 exps
= SCM_CDAR (x
);
3528 while (!SCM_NULLP (exps
))
3530 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
3531 exps
= SCM_CDR (exps
);
3534 scm_swap_bindings (vars
, vals
);
3535 scm_dynwinds
= scm_acons (vars
, vals
, scm_dynwinds
);
3537 /* Ignore all but the last evaluation result. */
3538 for (x
= SCM_CDR (x
); !SCM_NULLP (SCM_CDR (x
)); x
= SCM_CDR (x
))
3540 if (SCM_CONSP (SCM_CAR (x
)))
3541 SCM_CEVAL (SCM_CAR (x
), env
);
3543 proc
= EVALCAR (x
, env
);
3545 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
3546 scm_swap_bindings (vars
, vals
);
3552 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
3557 producer
= EVALCAR (x
, env
);
3559 proc
= EVALCAR (x
, env
); /* proc is the consumer. */
3560 arg1
= SCM_APPLY (producer
, SCM_EOL
, SCM_EOL
);
3561 if (SCM_VALUESP (arg1
))
3563 /* The list of arguments is not copied. Rather, it is assumed
3564 * that this has been done by the 'values' procedure. */
3565 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
3569 arg1
= scm_list_1 (arg1
);
3571 PREP_APPLY (proc
, arg1
);
3586 case scm_tc7_vector
:
3590 case scm_tc7_byvect
:
3597 #if SCM_SIZEOF_LONG_LONG != 0
3598 case scm_tc7_llvect
:
3601 case scm_tc7_number
:
3602 case scm_tc7_string
:
3604 case scm_tcs_closures
:
3608 case scm_tcs_struct
:
3612 case scm_tc7_symbol
:
3613 /* Only happens when called at top level. */
3614 x
= scm_cons (x
, SCM_UNDEFINED
);
3615 RETURN (*scm_lookupcar (x
, env
, 1));
3617 case scm_tc7_variable
:
3618 RETURN (SCM_VARIABLE_REF(x
));
3620 case SCM_BIT7 (SCM_ILOC00
):
3621 proc
= *scm_ilookup (SCM_CAR (x
), env
);
3624 case scm_tcs_cons_nimcar
:
3625 if (SCM_SYMBOLP (SCM_CAR (x
)))
3627 SCM orig_sym
= SCM_CAR (x
);
3629 SCM
*location
= scm_lookupcar1 (x
, env
, 1);
3630 if (location
== NULL
)
3632 /* we have lost the race, start again. */
3638 if (SCM_MACROP (proc
))
3640 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
3642 handle_a_macro
: /* inputs: x, env, proc */
3644 /* Set a flag during macro expansion so that macro
3645 application frames can be deleted from the backtrace. */
3646 SCM_SET_MACROEXP (debug
);
3648 arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
3649 scm_cons (env
, scm_listofnull
));
3651 SCM_CLEAR_MACROEXP (debug
);
3653 switch (SCM_MACRO_TYPE (proc
))
3657 if (scm_ilength (arg1
) <= 0)
3658 arg1
= scm_list_2 (SCM_IM_BEGIN
, arg1
);
3660 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
3663 SCM_SETCAR (x
, SCM_CAR (arg1
));
3664 SCM_SETCDR (x
, SCM_CDR (arg1
));
3668 /* Prevent memoizing of debug info expression. */
3669 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
3674 SCM_SETCAR (x
, SCM_CAR (arg1
));
3675 SCM_SETCDR (x
, SCM_CDR (arg1
));
3677 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3679 #if SCM_ENABLE_DEPRECATED == 1
3684 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3696 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
3699 if (SCM_MACROP (proc
))
3700 goto handle_a_macro
;
3704 evapply
: /* inputs: x, proc */
3705 PREP_APPLY (proc
, SCM_EOL
);
3706 if (SCM_NULLP (SCM_CDR (x
))) {
3709 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3710 switch (SCM_TYP7 (proc
))
3711 { /* no arguments given */
3712 case scm_tc7_subr_0
:
3713 RETURN (SCM_SUBRF (proc
) ());
3714 case scm_tc7_subr_1o
:
3715 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
3717 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
3718 case scm_tc7_rpsubr
:
3719 RETURN (SCM_BOOL_T
);
3721 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
3723 if (!SCM_SMOB_APPLICABLE_P (proc
))
3725 RETURN (SCM_SMOB_APPLY_0 (proc
));
3728 proc
= SCM_CCLO_SUBR (proc
);
3730 debug
.info
->a
.proc
= proc
;
3731 debug
.info
->a
.args
= scm_list_1 (arg1
);
3735 proc
= SCM_PROCEDURE (proc
);
3737 debug
.info
->a
.proc
= proc
;
3739 if (!SCM_CLOSUREP (proc
))
3742 case scm_tcs_closures
:
3744 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3745 if (SCM_CONSP (formals
))
3746 goto umwrongnumargs
;
3747 x
= SCM_CLOSURE_BODY (proc
);
3748 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
3749 goto nontoplevel_begin
;
3751 case scm_tcs_struct
:
3752 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3754 x
= SCM_ENTITY_PROCEDURE (proc
);
3758 else if (SCM_I_OPERATORP (proc
))
3761 proc
= (SCM_I_ENTITYP (proc
)
3762 ? SCM_ENTITY_PROCEDURE (proc
)
3763 : SCM_OPERATOR_PROCEDURE (proc
));
3765 debug
.info
->a
.proc
= proc
;
3766 debug
.info
->a
.args
= scm_list_1 (arg1
);
3772 case scm_tc7_subr_1
:
3773 case scm_tc7_subr_2
:
3774 case scm_tc7_subr_2o
:
3777 case scm_tc7_subr_3
:
3778 case scm_tc7_lsubr_2
:
3781 scm_wrong_num_args (proc
);
3784 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
3788 /* must handle macros by here */
3791 arg1
= EVALCAR (x
, env
);
3793 scm_wrong_num_args (proc
);
3795 debug
.info
->a
.args
= scm_list_1 (arg1
);
3803 evap1
: /* inputs: proc, arg1 */
3804 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3805 switch (SCM_TYP7 (proc
))
3806 { /* have one argument in arg1 */
3807 case scm_tc7_subr_2o
:
3808 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3809 case scm_tc7_subr_1
:
3810 case scm_tc7_subr_1o
:
3811 RETURN (SCM_SUBRF (proc
) (arg1
));
3813 if (SCM_INUMP (arg1
))
3815 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3817 else if (SCM_REALP (arg1
))
3819 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3821 else if (SCM_BIGP (arg1
))
3823 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3825 else if (SCM_FRACTIONP (arg1
))
3827 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
3829 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3830 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3833 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
3836 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
3837 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3838 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3843 case scm_tc7_rpsubr
:
3844 RETURN (SCM_BOOL_T
);
3846 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3849 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3851 RETURN (SCM_SUBRF (proc
) (scm_list_1 (arg1
)));
3854 if (!SCM_SMOB_APPLICABLE_P (proc
))
3856 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
3860 proc
= SCM_CCLO_SUBR (proc
);
3862 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
3863 debug
.info
->a
.proc
= proc
;
3867 proc
= SCM_PROCEDURE (proc
);
3869 debug
.info
->a
.proc
= proc
;
3871 if (!SCM_CLOSUREP (proc
))
3874 case scm_tcs_closures
:
3877 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3878 if (SCM_NULLP (formals
)
3879 || (SCM_CONSP (formals
) && SCM_CONSP (SCM_CDR (formals
))))
3880 goto umwrongnumargs
;
3881 x
= SCM_CLOSURE_BODY (proc
);
3883 env
= SCM_EXTEND_ENV (formals
,
3887 env
= SCM_EXTEND_ENV (formals
,
3891 goto nontoplevel_begin
;
3893 case scm_tcs_struct
:
3894 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3896 x
= SCM_ENTITY_PROCEDURE (proc
);
3898 arg1
= debug
.info
->a
.args
;
3900 arg1
= scm_list_1 (arg1
);
3904 else if (SCM_I_OPERATORP (proc
))
3908 proc
= (SCM_I_ENTITYP (proc
)
3909 ? SCM_ENTITY_PROCEDURE (proc
)
3910 : SCM_OPERATOR_PROCEDURE (proc
));
3912 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
3913 debug
.info
->a
.proc
= proc
;
3919 case scm_tc7_subr_2
:
3920 case scm_tc7_subr_0
:
3921 case scm_tc7_subr_3
:
3922 case scm_tc7_lsubr_2
:
3923 scm_wrong_num_args (proc
);
3929 arg2
= EVALCAR (x
, env
);
3931 scm_wrong_num_args (proc
);
3933 { /* have two or more arguments */
3935 debug
.info
->a
.args
= scm_list_2 (arg1
, arg2
);
3938 if (SCM_NULLP (x
)) {
3941 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3942 switch (SCM_TYP7 (proc
))
3943 { /* have two arguments */
3944 case scm_tc7_subr_2
:
3945 case scm_tc7_subr_2o
:
3946 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3949 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3951 RETURN (SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
)));
3953 case scm_tc7_lsubr_2
:
3954 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
));
3955 case scm_tc7_rpsubr
:
3957 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3959 if (!SCM_SMOB_APPLICABLE_P (proc
))
3961 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
));
3965 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3966 scm_cons (proc
, debug
.info
->a
.args
),
3969 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3970 scm_cons2 (proc
, arg1
,
3977 case scm_tcs_struct
:
3978 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3980 x
= SCM_ENTITY_PROCEDURE (proc
);
3982 arg1
= debug
.info
->a
.args
;
3984 arg1
= scm_list_2 (arg1
, arg2
);
3988 else if (SCM_I_OPERATORP (proc
))
3992 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3993 ? SCM_ENTITY_PROCEDURE (proc
)
3994 : SCM_OPERATOR_PROCEDURE (proc
),
3995 scm_cons (proc
, debug
.info
->a
.args
),
3998 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3999 ? SCM_ENTITY_PROCEDURE (proc
)
4000 : SCM_OPERATOR_PROCEDURE (proc
),
4001 scm_cons2 (proc
, arg1
,
4011 case scm_tc7_subr_0
:
4014 case scm_tc7_subr_1o
:
4015 case scm_tc7_subr_1
:
4016 case scm_tc7_subr_3
:
4017 scm_wrong_num_args (proc
);
4021 proc
= SCM_PROCEDURE (proc
);
4023 debug
.info
->a
.proc
= proc
;
4025 if (!SCM_CLOSUREP (proc
))
4028 case scm_tcs_closures
:
4031 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4032 if (SCM_NULLP (formals
)
4033 || (SCM_CONSP (formals
)
4034 && (SCM_NULLP (SCM_CDR (formals
))
4035 || (SCM_CONSP (SCM_CDR (formals
))
4036 && SCM_CONSP (SCM_CDDR (formals
))))))
4037 goto umwrongnumargs
;
4039 env
= SCM_EXTEND_ENV (formals
,
4043 env
= SCM_EXTEND_ENV (formals
,
4044 scm_list_2 (arg1
, arg2
),
4047 x
= SCM_CLOSURE_BODY (proc
);
4048 goto nontoplevel_begin
;
4053 scm_wrong_num_args (proc
);
4055 debug
.info
->a
.args
= scm_cons2 (arg1
, arg2
,
4056 deval_args (x
, env
, proc
,
4057 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
4061 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4062 switch (SCM_TYP7 (proc
))
4063 { /* have 3 or more arguments */
4065 case scm_tc7_subr_3
:
4066 if (!SCM_NULLP (SCM_CDR (x
)))
4067 scm_wrong_num_args (proc
);
4069 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4070 SCM_CADDR (debug
.info
->a
.args
)));
4072 arg1
= SCM_SUBRF(proc
)(arg1
, arg2
);
4073 arg2
= SCM_CDDR (debug
.info
->a
.args
);
4076 arg1
= SCM_SUBRF(proc
)(arg1
, SCM_CAR (arg2
));
4077 arg2
= SCM_CDR (arg2
);
4079 while (SCM_NIMP (arg2
));
4081 case scm_tc7_rpsubr
:
4082 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
4083 RETURN (SCM_BOOL_F
);
4084 arg1
= SCM_CDDR (debug
.info
->a
.args
);
4087 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (arg1
))))
4088 RETURN (SCM_BOOL_F
);
4089 arg2
= SCM_CAR (arg1
);
4090 arg1
= SCM_CDR (arg1
);
4092 while (SCM_NIMP (arg1
));
4093 RETURN (SCM_BOOL_T
);
4094 case scm_tc7_lsubr_2
:
4095 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4096 SCM_CDDR (debug
.info
->a
.args
)));
4098 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4100 if (!SCM_SMOB_APPLICABLE_P (proc
))
4102 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4103 SCM_CDDR (debug
.info
->a
.args
)));
4107 proc
= SCM_PROCEDURE (proc
);
4108 debug
.info
->a
.proc
= proc
;
4109 if (!SCM_CLOSUREP (proc
))
4112 case scm_tcs_closures
:
4114 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4115 if (SCM_NULLP (formals
)
4116 || (SCM_CONSP (formals
)
4117 && (SCM_NULLP (SCM_CDR (formals
))
4118 || (SCM_CONSP (SCM_CDR (formals
))
4119 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4120 goto umwrongnumargs
;
4121 SCM_SET_ARGSREADY (debug
);
4122 env
= SCM_EXTEND_ENV (formals
,
4125 x
= SCM_CLOSURE_BODY (proc
);
4126 goto nontoplevel_begin
;
4129 case scm_tc7_subr_3
:
4130 if (!SCM_NULLP (SCM_CDR (x
)))
4131 scm_wrong_num_args (proc
);
4133 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, EVALCAR (x
, env
)));
4135 arg1
= SCM_SUBRF (proc
) (arg1
, arg2
);
4138 arg1
= SCM_SUBRF(proc
)(arg1
, EVALCAR(x
, env
));
4141 while (!SCM_NULLP (x
));
4143 case scm_tc7_rpsubr
:
4144 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
4145 RETURN (SCM_BOOL_F
);
4148 arg1
= EVALCAR (x
, env
);
4149 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, arg1
)))
4150 RETURN (SCM_BOOL_F
);
4154 while (!SCM_NULLP (x
));
4155 RETURN (SCM_BOOL_T
);
4156 case scm_tc7_lsubr_2
:
4157 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
4159 RETURN (SCM_SUBRF (proc
) (scm_cons2 (arg1
,
4161 scm_eval_args (x
, env
, proc
))));
4163 if (!SCM_SMOB_APPLICABLE_P (proc
))
4165 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4166 scm_eval_args (x
, env
, proc
)));
4170 proc
= SCM_PROCEDURE (proc
);
4171 if (!SCM_CLOSUREP (proc
))
4174 case scm_tcs_closures
:
4176 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4177 if (SCM_NULLP (formals
)
4178 || (SCM_CONSP (formals
)
4179 && (SCM_NULLP (SCM_CDR (formals
))
4180 || (SCM_CONSP (SCM_CDR (formals
))
4181 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4182 goto umwrongnumargs
;
4183 env
= SCM_EXTEND_ENV (formals
,
4186 scm_eval_args (x
, env
, proc
)),
4188 x
= SCM_CLOSURE_BODY (proc
);
4189 goto nontoplevel_begin
;
4192 case scm_tcs_struct
:
4193 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4196 arg1
= debug
.info
->a
.args
;
4198 arg1
= scm_cons2 (arg1
, arg2
, scm_eval_args (x
, env
, proc
));
4200 x
= SCM_ENTITY_PROCEDURE (proc
);
4203 else if (SCM_I_OPERATORP (proc
))
4207 case scm_tc7_subr_2
:
4208 case scm_tc7_subr_1o
:
4209 case scm_tc7_subr_2o
:
4210 case scm_tc7_subr_0
:
4213 case scm_tc7_subr_1
:
4214 scm_wrong_num_args (proc
);
4222 if (scm_check_exit_p
&& SCM_TRAPS_P
)
4223 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
4225 SCM_CLEAR_TRACED_FRAME (debug
);
4226 if (SCM_CHEAPTRAPS_P
)
4227 arg1
= scm_make_debugobj (&debug
);
4231 SCM val
= scm_make_continuation (&first
);
4242 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
4246 scm_last_debug_frame
= debug
.prev
;
4252 /* SECTION: This code is compiled once.
4259 /* Simple procedure calls
4263 scm_call_0 (SCM proc
)
4265 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
4269 scm_call_1 (SCM proc
, SCM arg1
)
4271 return scm_apply (proc
, arg1
, scm_listofnull
);
4275 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
4277 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
4281 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
4283 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
4287 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
4289 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
4290 scm_cons (arg4
, scm_listofnull
)));
4293 /* Simple procedure applies
4297 scm_apply_0 (SCM proc
, SCM args
)
4299 return scm_apply (proc
, args
, SCM_EOL
);
4303 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
4305 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
4309 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
4311 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
4315 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
4317 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
4321 /* This code processes the arguments to apply:
4323 (apply PROC ARG1 ... ARGS)
4325 Given a list (ARG1 ... ARGS), this function conses the ARG1
4326 ... arguments onto the front of ARGS, and returns the resulting
4327 list. Note that ARGS is a list; thus, the argument to this
4328 function is a list whose last element is a list.
4330 Apply calls this function, and applies PROC to the elements of the
4331 result. apply:nconc2last takes care of building the list of
4332 arguments, given (ARG1 ... ARGS).
4334 Rather than do new consing, apply:nconc2last destroys its argument.
4335 On that topic, this code came into my care with the following
4336 beautifully cryptic comment on that topic: "This will only screw
4337 you if you do (scm_apply scm_apply '( ... ))" If you know what
4338 they're referring to, send me a patch to this comment. */
4340 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
4342 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
4343 "conses the @var{arg1} @dots{} arguments onto the front of\n"
4344 "@var{args}, and returns the resulting list. Note that\n"
4345 "@var{args} is a list; thus, the argument to this function is\n"
4346 "a list whose last element is a list.\n"
4347 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
4348 "destroys its argument, so use with care.")
4349 #define FUNC_NAME s_scm_nconc2last
4352 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
4354 while (!SCM_NULLP (SCM_CDR (*lloc
))) /* Perhaps should be
4355 SCM_NULL_OR_NIL_P, but not
4356 needed in 99.99% of cases,
4357 and it could seriously hurt
4358 performance. - Neil */
4359 lloc
= SCM_CDRLOC (*lloc
);
4360 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
4361 *lloc
= SCM_CAR (*lloc
);
4369 /* SECTION: When DEVAL is defined this code yields scm_dapply.
4370 * It is compiled twice.
4375 scm_apply (SCM proc
, SCM arg1
, SCM args
)
4381 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
4386 /* Apply a function to a list of arguments.
4388 This function is exported to the Scheme level as taking two
4389 required arguments and a tail argument, as if it were:
4390 (lambda (proc arg1 . args) ...)
4391 Thus, if you just have a list of arguments to pass to a procedure,
4392 pass the list as ARG1, and '() for ARGS. If you have some fixed
4393 args, pass the first as ARG1, then cons any remaining fixed args
4394 onto the front of your argument list, and pass that as ARGS. */
4397 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
4400 scm_t_debug_frame debug
;
4401 scm_t_debug_info debug_vect_body
;
4402 debug
.prev
= scm_last_debug_frame
;
4403 debug
.status
= SCM_APPLYFRAME
;
4404 debug
.vect
= &debug_vect_body
;
4405 debug
.vect
[0].a
.proc
= proc
;
4406 debug
.vect
[0].a
.args
= SCM_EOL
;
4407 scm_last_debug_frame
= &debug
;
4410 return scm_dapply (proc
, arg1
, args
);
4413 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
4415 /* If ARGS is the empty list, then we're calling apply with only two
4416 arguments --- ARG1 is the list of arguments for PROC. Whatever
4417 the case, futz with things so that ARG1 is the first argument to
4418 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
4421 Setting the debug apply frame args this way is pretty messy.
4422 Perhaps we should store arg1 and args directly in the frame as
4423 received, and let scm_frame_arguments unpack them, because that's
4424 a relatively rare operation. This works for now; if the Guile
4425 developer archives are still around, see Mikael's post of
4427 if (SCM_NULLP (args
))
4429 if (SCM_NULLP (arg1
))
4431 arg1
= SCM_UNDEFINED
;
4433 debug
.vect
[0].a
.args
= SCM_EOL
;
4439 debug
.vect
[0].a
.args
= arg1
;
4441 args
= SCM_CDR (arg1
);
4442 arg1
= SCM_CAR (arg1
);
4447 args
= scm_nconc2last (args
);
4449 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4453 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
4456 if (SCM_CHEAPTRAPS_P
)
4457 tmp
= scm_make_debugobj (&debug
);
4462 tmp
= scm_make_continuation (&first
);
4467 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
4474 switch (SCM_TYP7 (proc
))
4476 case scm_tc7_subr_2o
:
4477 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
4478 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4479 case scm_tc7_subr_2
:
4480 if (SCM_NULLP (args
) || !SCM_NULLP (SCM_CDR (args
)))
4481 scm_wrong_num_args (proc
);
4482 args
= SCM_CAR (args
);
4483 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4484 case scm_tc7_subr_0
:
4485 if (!SCM_UNBNDP (arg1
))
4486 scm_wrong_num_args (proc
);
4488 RETURN (SCM_SUBRF (proc
) ());
4489 case scm_tc7_subr_1
:
4490 if (SCM_UNBNDP (arg1
))
4491 scm_wrong_num_args (proc
);
4492 case scm_tc7_subr_1o
:
4493 if (!SCM_NULLP (args
))
4494 scm_wrong_num_args (proc
);
4496 RETURN (SCM_SUBRF (proc
) (arg1
));
4498 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
4499 scm_wrong_num_args (proc
);
4500 if (SCM_INUMP (arg1
))
4502 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
4504 else if (SCM_REALP (arg1
))
4506 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4508 else if (SCM_BIGP (arg1
))
4510 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4512 else if (SCM_FRACTIONP (arg1
))
4514 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4516 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4517 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4519 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
4520 scm_wrong_num_args (proc
);
4522 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
4525 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
4526 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4527 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
4532 case scm_tc7_subr_3
:
4533 if (SCM_NULLP (args
)
4534 || SCM_NULLP (SCM_CDR (args
))
4535 || !SCM_NULLP (SCM_CDDR (args
)))
4536 scm_wrong_num_args (proc
);
4538 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
4541 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
4543 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
4545 case scm_tc7_lsubr_2
:
4546 if (!SCM_CONSP (args
))
4547 scm_wrong_num_args (proc
);
4549 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4551 if (SCM_NULLP (args
))
4552 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4553 while (SCM_NIMP (args
))
4555 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
4556 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
4557 args
= SCM_CDR (args
);
4560 case scm_tc7_rpsubr
:
4561 if (SCM_NULLP (args
))
4562 RETURN (SCM_BOOL_T
);
4563 while (SCM_NIMP (args
))
4565 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
4566 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
4567 RETURN (SCM_BOOL_F
);
4568 arg1
= SCM_CAR (args
);
4569 args
= SCM_CDR (args
);
4571 RETURN (SCM_BOOL_T
);
4572 case scm_tcs_closures
:
4574 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4576 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4578 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
4579 scm_wrong_num_args (proc
);
4581 /* Copy argument list */
4586 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
4587 for (arg1
= SCM_CDR (arg1
); SCM_CONSP (arg1
); arg1
= SCM_CDR (arg1
))
4589 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
));
4592 SCM_SETCDR (tl
, arg1
);
4595 args
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4598 proc
= SCM_CLOSURE_BODY (proc
);
4600 arg1
= SCM_CDR (proc
);
4601 while (!SCM_NULLP (arg1
))
4603 if (SCM_IMP (SCM_CAR (proc
)))
4605 if (SCM_ISYMP (SCM_CAR (proc
)))
4607 scm_rec_mutex_lock (&source_mutex
);
4608 /* check for race condition */
4609 if (SCM_ISYMP (SCM_CAR (proc
)))
4610 m_expand_body (proc
, args
);
4611 scm_rec_mutex_unlock (&source_mutex
);
4615 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
4618 SCM_CEVAL (SCM_CAR (proc
), args
);
4620 arg1
= SCM_CDR (proc
);
4622 RETURN (EVALCAR (proc
, args
));
4624 if (!SCM_SMOB_APPLICABLE_P (proc
))
4626 if (SCM_UNBNDP (arg1
))
4627 RETURN (SCM_SMOB_APPLY_0 (proc
));
4628 else if (SCM_NULLP (args
))
4629 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
4630 else if (SCM_NULLP (SCM_CDR (args
)))
4631 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
4633 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4636 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4638 proc
= SCM_CCLO_SUBR (proc
);
4639 debug
.vect
[0].a
.proc
= proc
;
4640 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4642 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4644 proc
= SCM_CCLO_SUBR (proc
);
4648 proc
= SCM_PROCEDURE (proc
);
4650 debug
.vect
[0].a
.proc
= proc
;
4653 case scm_tcs_struct
:
4654 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4657 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4659 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4661 RETURN (scm_apply_generic (proc
, args
));
4663 else if (SCM_I_OPERATORP (proc
))
4667 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4669 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4672 proc
= (SCM_I_ENTITYP (proc
)
4673 ? SCM_ENTITY_PROCEDURE (proc
)
4674 : SCM_OPERATOR_PROCEDURE (proc
));
4676 debug
.vect
[0].a
.proc
= proc
;
4677 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4679 if (SCM_NIMP (proc
))
4688 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
4692 if (scm_check_exit_p
&& SCM_TRAPS_P
)
4693 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
4695 SCM_CLEAR_TRACED_FRAME (debug
);
4696 if (SCM_CHEAPTRAPS_P
)
4697 arg1
= scm_make_debugobj (&debug
);
4701 SCM val
= scm_make_continuation (&first
);
4712 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
4716 scm_last_debug_frame
= debug
.prev
;
4722 /* SECTION: The rest of this file is only read once.
4729 * Trampolines make it possible to move procedure application dispatch
4730 * outside inner loops. The motivation was clean implementation of
4731 * efficient replacements of R5RS primitives in SRFI-1.
4733 * The semantics is clear: scm_trampoline_N returns an optimized
4734 * version of scm_call_N (or NULL if the procedure isn't applicable
4737 * Applying the optimization to map and for-each increased efficiency
4738 * noticeably. For example, (map abs ls) is now 8 times faster than
4743 call_subr0_0 (SCM proc
)
4745 return SCM_SUBRF (proc
) ();
4749 call_subr1o_0 (SCM proc
)
4751 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
4755 call_lsubr_0 (SCM proc
)
4757 return SCM_SUBRF (proc
) (SCM_EOL
);
4761 scm_i_call_closure_0 (SCM proc
)
4763 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4766 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
4771 scm_trampoline_0 (SCM proc
)
4773 scm_t_trampoline_0 trampoline
;
4778 switch (SCM_TYP7 (proc
))
4780 case scm_tc7_subr_0
:
4781 trampoline
= call_subr0_0
;
4783 case scm_tc7_subr_1o
:
4784 trampoline
= call_subr1o_0
;
4787 trampoline
= call_lsubr_0
;
4789 case scm_tcs_closures
:
4791 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4792 if (SCM_NULLP (formals
) || !SCM_CONSP (formals
))
4793 trampoline
= scm_i_call_closure_0
;
4798 case scm_tcs_struct
:
4799 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4800 trampoline
= scm_call_generic_0
;
4801 else if (SCM_I_OPERATORP (proc
))
4802 trampoline
= scm_call_0
;
4807 if (SCM_SMOB_APPLICABLE_P (proc
))
4808 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
4813 case scm_tc7_rpsubr
:
4816 trampoline
= scm_call_0
;
4819 return NULL
; /* not applicable on zero arguments */
4821 /* We only reach this point if a valid trampoline was determined. */
4823 /* If debugging is enabled, we want to see all calls to proc on the stack.
4824 * Thus, we replace the trampoline shortcut with scm_call_0. */
4832 call_subr1_1 (SCM proc
, SCM arg1
)
4834 return SCM_SUBRF (proc
) (arg1
);
4838 call_subr2o_1 (SCM proc
, SCM arg1
)
4840 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
4844 call_lsubr_1 (SCM proc
, SCM arg1
)
4846 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
4850 call_dsubr_1 (SCM proc
, SCM arg1
)
4852 if (SCM_INUMP (arg1
))
4854 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
4856 else if (SCM_REALP (arg1
))
4858 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4860 else if (SCM_BIGP (arg1
))
4862 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4864 else if (SCM_FRACTIONP (arg1
))
4866 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4868 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4869 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4873 call_cxr_1 (SCM proc
, SCM arg1
)
4875 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
4878 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
4879 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4880 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
4887 call_closure_1 (SCM proc
, SCM arg1
)
4889 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4892 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
4897 scm_trampoline_1 (SCM proc
)
4899 scm_t_trampoline_1 trampoline
;
4904 switch (SCM_TYP7 (proc
))
4906 case scm_tc7_subr_1
:
4907 case scm_tc7_subr_1o
:
4908 trampoline
= call_subr1_1
;
4910 case scm_tc7_subr_2o
:
4911 trampoline
= call_subr2o_1
;
4914 trampoline
= call_lsubr_1
;
4917 trampoline
= call_dsubr_1
;
4920 trampoline
= call_cxr_1
;
4922 case scm_tcs_closures
:
4924 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4925 if (!SCM_NULLP (formals
)
4926 && (!SCM_CONSP (formals
) || !SCM_CONSP (SCM_CDR (formals
))))
4927 trampoline
= call_closure_1
;
4932 case scm_tcs_struct
:
4933 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4934 trampoline
= scm_call_generic_1
;
4935 else if (SCM_I_OPERATORP (proc
))
4936 trampoline
= scm_call_1
;
4941 if (SCM_SMOB_APPLICABLE_P (proc
))
4942 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
4947 case scm_tc7_rpsubr
:
4950 trampoline
= scm_call_1
;
4953 return NULL
; /* not applicable on one arg */
4955 /* We only reach this point if a valid trampoline was determined. */
4957 /* If debugging is enabled, we want to see all calls to proc on the stack.
4958 * Thus, we replace the trampoline shortcut with scm_call_1. */
4966 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
4968 return SCM_SUBRF (proc
) (arg1
, arg2
);
4972 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
4974 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
4978 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
4980 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
4984 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
4986 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4987 scm_list_2 (arg1
, arg2
),
4989 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
4994 scm_trampoline_2 (SCM proc
)
4996 scm_t_trampoline_2 trampoline
;
5001 switch (SCM_TYP7 (proc
))
5003 case scm_tc7_subr_2
:
5004 case scm_tc7_subr_2o
:
5005 case scm_tc7_rpsubr
:
5007 trampoline
= call_subr2_2
;
5009 case scm_tc7_lsubr_2
:
5010 trampoline
= call_lsubr2_2
;
5013 trampoline
= call_lsubr_2
;
5015 case scm_tcs_closures
:
5017 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5018 if (!SCM_NULLP (formals
)
5019 && (!SCM_CONSP (formals
)
5020 || (!SCM_NULLP (SCM_CDR (formals
))
5021 && (!SCM_CONSP (SCM_CDR (formals
))
5022 || !SCM_CONSP (SCM_CDDR (formals
))))))
5023 trampoline
= call_closure_2
;
5028 case scm_tcs_struct
:
5029 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5030 trampoline
= scm_call_generic_2
;
5031 else if (SCM_I_OPERATORP (proc
))
5032 trampoline
= scm_call_2
;
5037 if (SCM_SMOB_APPLICABLE_P (proc
))
5038 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
5044 trampoline
= scm_call_2
;
5047 return NULL
; /* not applicable on two args */
5049 /* We only reach this point if a valid trampoline was determined. */
5051 /* If debugging is enabled, we want to see all calls to proc on the stack.
5052 * Thus, we replace the trampoline shortcut with scm_call_2. */
5059 /* Typechecking for multi-argument MAP and FOR-EACH.
5061 Verify that each element of the vector ARGV, except for the first,
5062 is a proper list whose length is LEN. Attribute errors to WHO,
5063 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
5065 check_map_args (SCM argv
,
5072 SCM
const *ve
= SCM_VELTS (argv
);
5075 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
5077 long elt_len
= scm_ilength (ve
[i
]);
5082 scm_apply_generic (gf
, scm_cons (proc
, args
));
5084 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
5088 scm_out_of_range_pos (who
, ve
[i
], SCM_MAKINUM (i
+ 2));
5091 scm_remember_upto_here_1 (argv
);
5095 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
5097 /* Note: Currently, scm_map applies PROC to the argument list(s)
5098 sequentially, starting with the first element(s). This is used in
5099 evalext.c where the Scheme procedure `map-in-order', which guarantees
5100 sequential behaviour, is implemented using scm_map. If the
5101 behaviour changes, we need to update `map-in-order'.
5105 scm_map (SCM proc
, SCM arg1
, SCM args
)
5106 #define FUNC_NAME s_map
5111 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
5113 len
= scm_ilength (arg1
);
5114 SCM_GASSERTn (len
>= 0,
5115 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
5116 SCM_VALIDATE_REST_ARGUMENT (args
);
5117 if (SCM_NULLP (args
))
5119 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5120 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
5121 while (SCM_NIMP (arg1
))
5123 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
5124 pres
= SCM_CDRLOC (*pres
);
5125 arg1
= SCM_CDR (arg1
);
5129 if (SCM_NULLP (SCM_CDR (args
)))
5131 SCM arg2
= SCM_CAR (args
);
5132 int len2
= scm_ilength (arg2
);
5133 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5135 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
5136 SCM_GASSERTn (len2
>= 0,
5137 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
5139 SCM_OUT_OF_RANGE (3, arg2
);
5140 while (SCM_NIMP (arg1
))
5142 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
5143 pres
= SCM_CDRLOC (*pres
);
5144 arg1
= SCM_CDR (arg1
);
5145 arg2
= SCM_CDR (arg2
);
5149 arg1
= scm_cons (arg1
, args
);
5150 args
= scm_vector (arg1
);
5151 ve
= SCM_VELTS (args
);
5152 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
5156 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5158 if (SCM_IMP (ve
[i
]))
5160 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
5161 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
5163 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
5164 pres
= SCM_CDRLOC (*pres
);
5170 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
5173 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
5174 #define FUNC_NAME s_for_each
5176 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
5178 len
= scm_ilength (arg1
);
5179 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
5180 SCM_ARG2
, s_for_each
);
5181 SCM_VALIDATE_REST_ARGUMENT (args
);
5182 if (SCM_NULLP (args
))
5184 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5185 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
5186 while (SCM_NIMP (arg1
))
5188 call (proc
, SCM_CAR (arg1
));
5189 arg1
= SCM_CDR (arg1
);
5191 return SCM_UNSPECIFIED
;
5193 if (SCM_NULLP (SCM_CDR (args
)))
5195 SCM arg2
= SCM_CAR (args
);
5196 int len2
= scm_ilength (arg2
);
5197 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5198 SCM_GASSERTn (call
, g_for_each
,
5199 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
5200 SCM_GASSERTn (len2
>= 0, g_for_each
,
5201 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
5203 SCM_OUT_OF_RANGE (3, arg2
);
5204 while (SCM_NIMP (arg1
))
5206 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
5207 arg1
= SCM_CDR (arg1
);
5208 arg2
= SCM_CDR (arg2
);
5210 return SCM_UNSPECIFIED
;
5212 arg1
= scm_cons (arg1
, args
);
5213 args
= scm_vector (arg1
);
5214 ve
= SCM_VELTS (args
);
5215 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
5219 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5221 if (SCM_IMP (ve
[i
]))
5222 return SCM_UNSPECIFIED
;
5223 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
5224 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
5226 scm_apply (proc
, arg1
, SCM_EOL
);
5233 scm_closure (SCM code
, SCM env
)
5236 SCM closcar
= scm_cons (code
, SCM_EOL
);
5237 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
5238 scm_remember_upto_here (closcar
);
5243 scm_t_bits scm_tc16_promise
;
5246 scm_makprom (SCM code
)
5248 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
5250 scm_make_rec_mutex ());
5254 promise_free (SCM promise
)
5256 scm_rec_mutex_free (SCM_PROMISE_MUTEX (promise
));
5261 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
5263 int writingp
= SCM_WRITINGP (pstate
);
5264 scm_puts ("#<promise ", port
);
5265 SCM_SET_WRITINGP (pstate
, 1);
5266 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
5267 SCM_SET_WRITINGP (pstate
, writingp
);
5268 scm_putc ('>', port
);
5272 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
5274 "If the promise @var{x} has not been computed yet, compute and\n"
5275 "return @var{x}, otherwise just return the previously computed\n"
5277 #define FUNC_NAME s_scm_force
5279 SCM_VALIDATE_SMOB (1, promise
, promise
);
5280 scm_rec_mutex_lock (SCM_PROMISE_MUTEX (promise
));
5281 if (!SCM_PROMISE_COMPUTED_P (promise
))
5283 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
5284 if (!SCM_PROMISE_COMPUTED_P (promise
))
5286 SCM_SET_PROMISE_DATA (promise
, ans
);
5287 SCM_SET_PROMISE_COMPUTED (promise
);
5290 scm_rec_mutex_unlock (SCM_PROMISE_MUTEX (promise
));
5291 return SCM_PROMISE_DATA (promise
);
5296 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
5298 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
5299 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
5300 #define FUNC_NAME s_scm_promise_p
5302 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
5307 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
5308 (SCM xorig
, SCM x
, SCM y
),
5309 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
5310 "Any source properties associated with @var{xorig} are also associated\n"
5311 "with the new pair.")
5312 #define FUNC_NAME s_scm_cons_source
5315 z
= scm_cons (x
, y
);
5316 /* Copy source properties possibly associated with xorig. */
5317 p
= scm_whash_lookup (scm_source_whash
, xorig
);
5319 scm_whash_insert (scm_source_whash
, z
, p
);
5325 /* The function scm_copy_tree is used to copy an expression tree to allow the
5326 * memoizer to modify the expression during memoization. scm_copy_tree
5327 * creates deep copies of pairs and vectors, but not of any other data types,
5328 * since only pairs and vectors will be parsed by the memoizer.
5330 * To avoid infinite recursion due to cyclic structures, the hare-and-tortoise
5331 * pattern is used to detect cycles. In fact, the pattern is used in two
5332 * dimensions, vertical (indicated in the code by the variable names 'hare'
5333 * and 'tortoise') and horizontal ('rabbit' and 'turtle'). In both
5334 * dimensions, the hare/rabbit will take two steps when the tortoise/turtle
5337 * The vertical dimension corresponds to recursive calls to function
5338 * copy_tree: This happens when descending into vector elements, into cars of
5339 * lists and into the cdr of an improper list. In this dimension, the
5340 * tortoise follows the hare by using the processor stack: Every stack frame
5341 * will hold an instance of struct t_trace. These instances are connected in
5342 * a way that represents the trace of the hare, which thus can be followed by
5343 * the tortoise. The tortoise will always point to struct t_trace instances
5344 * relating to SCM objects that have already been copied. Thus, a cycle is
5345 * detected if the tortoise and the hare point to the same object,
5347 * The horizontal dimension is within one execution of copy_tree, when the
5348 * function cdr's along the pairs of a list. This is the standard
5349 * hare-and-tortoise implementation, found several times in guile. */
5352 struct t_trace
*trace
; // These pointers form a trace along the stack.
5353 SCM obj
; // The object handled at the respective stack frame.
5358 struct t_trace
*const hare
,
5359 struct t_trace
*tortoise
,
5360 unsigned int tortoise_delay
)
5362 if (!SCM_CONSP (hare
->obj
) && !SCM_VECTORP (hare
->obj
))
5368 /* Prepare the trace along the stack. */
5369 struct t_trace new_hare
;
5370 hare
->trace
= &new_hare
;
5372 /* The tortoise will make its step after the delay has elapsed. Note
5373 * that in contrast to the typical hare-and-tortoise pattern, the step
5374 * of the tortoise happens before the hare takes its steps. This is, in
5375 * principle, no problem, except for the start of the algorithm: Then,
5376 * it has to be made sure that the hare actually gets its advantage by
5378 if (tortoise_delay
== 0)
5381 tortoise
= tortoise
->trace
;
5382 ASSERT_SYNTAX (!SCM_EQ_P (hare
->obj
, tortoise
->obj
),
5383 s_bad_expression
, hare
->obj
);
5390 if (SCM_VECTORP (hare
->obj
))
5392 const unsigned long int length
= SCM_VECTOR_LENGTH (hare
->obj
);
5393 const SCM new_vector
= scm_c_make_vector (length
, SCM_UNSPECIFIED
);
5395 /* Each vector element is copied by recursing into copy_tree, having
5396 * the tortoise follow the hare into the depths of the stack. */
5397 unsigned long int i
;
5398 for (i
= 0; i
< length
; ++i
)
5401 new_hare
.obj
= SCM_VECTOR_REF (hare
->obj
, i
);
5402 new_element
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5403 SCM_VECTOR_SET (new_vector
, i
, new_element
);
5408 else // SCM_CONSP (hare->obj)
5413 SCM rabbit
= hare
->obj
;
5414 SCM turtle
= hare
->obj
;
5418 /* The first pair of the list is treated specially, in order to
5419 * preserve a potential source code position. */
5420 result
= tail
= scm_cons_source (rabbit
, SCM_EOL
, SCM_EOL
);
5421 new_hare
.obj
= SCM_CAR (rabbit
);
5422 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5423 SCM_SETCAR (tail
, copy
);
5425 /* The remaining pairs of the list are copied by, horizontally,
5426 * having the turtle follow the rabbit, and, vertically, having the
5427 * tortoise follow the hare into the depths of the stack. */
5428 rabbit
= SCM_CDR (rabbit
);
5429 while (SCM_CONSP (rabbit
))
5431 new_hare
.obj
= SCM_CAR (rabbit
);
5432 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5433 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
5434 tail
= SCM_CDR (tail
);
5436 rabbit
= SCM_CDR (rabbit
);
5437 if (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
);
5443 rabbit
= SCM_CDR (rabbit
);
5445 turtle
= SCM_CDR (turtle
);
5446 ASSERT_SYNTAX (!SCM_EQ_P (rabbit
, turtle
),
5447 s_bad_expression
, rabbit
);
5451 /* We have to recurse into copy_tree again for the last cdr, in
5452 * order to handle the situation that it holds a vector. */
5453 new_hare
.obj
= rabbit
;
5454 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5455 SCM_SETCDR (tail
, copy
);
5462 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
5464 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
5465 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
5466 "contents of both pairs and vectors (since both cons cells and vector\n"
5467 "cells may point to arbitrary objects), and stops recursing when it hits\n"
5468 "any other object.")
5469 #define FUNC_NAME s_scm_copy_tree
5471 /* Prepare the trace along the stack. */
5472 struct t_trace trace
;
5475 /* In function copy_tree, if the tortoise makes its step, it will do this
5476 * before the hare has the chance to move. Thus, we have to make sure that
5477 * the very first step of the tortoise will not happen after the hare has
5478 * really made two steps. This is achieved by passing '2' as the initial
5479 * delay for the tortoise. NOTE: Since cycles are unlikely, giving the hare
5480 * a bigger advantage may improve performance slightly. */
5481 return copy_tree (&trace
, &trace
, 2);
5486 /* We have three levels of EVAL here:
5488 - scm_i_eval (exp, env)
5490 evaluates EXP in environment ENV. ENV is a lexical environment
5491 structure as used by the actual tree code evaluator. When ENV is
5492 a top-level environment, then changes to the current module are
5493 tracked by updating ENV so that it continues to be in sync with
5496 - scm_primitive_eval (exp)
5498 evaluates EXP in the top-level environment as determined by the
5499 current module. This is done by constructing a suitable
5500 environment and calling scm_i_eval. Thus, changes to the
5501 top-level module are tracked normally.
5503 - scm_eval (exp, mod)
5505 evaluates EXP while MOD is the current module. This is done by
5506 setting the current module to MOD, invoking scm_primitive_eval on
5507 EXP, and then restoring the current module to the value it had
5508 previously. That is, while EXP is evaluated, changes to the
5509 current module are tracked, but these changes do not persist when
5512 For each level of evals, there are two variants, distinguished by a
5513 _x suffix: the ordinary variant does not modify EXP while the _x
5514 variant can destructively modify EXP into something completely
5515 unintelligible. A Scheme data structure passed as EXP to one of the
5516 _x variants should not ever be used again for anything. So when in
5517 doubt, use the ordinary variant.
5522 scm_i_eval_x (SCM exp
, SCM env
)
5524 return SCM_XEVAL (exp
, env
);
5528 scm_i_eval (SCM exp
, SCM env
)
5530 exp
= scm_copy_tree (exp
);
5531 return SCM_XEVAL (exp
, env
);
5535 scm_primitive_eval_x (SCM exp
)
5538 SCM transformer
= scm_current_module_transformer ();
5539 if (SCM_NIMP (transformer
))
5540 exp
= scm_call_1 (transformer
, exp
);
5541 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5542 return scm_i_eval_x (exp
, env
);
5545 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
5547 "Evaluate @var{exp} in the top-level environment specified by\n"
5548 "the current module.")
5549 #define FUNC_NAME s_scm_primitive_eval
5552 SCM transformer
= scm_current_module_transformer ();
5553 if (SCM_NIMP (transformer
))
5554 exp
= scm_call_1 (transformer
, exp
);
5555 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5556 return scm_i_eval (exp
, env
);
5561 /* Eval does not take the second arg optionally. This is intentional
5562 * in order to be R5RS compatible, and to prepare for the new module
5563 * system, where we would like to make the choice of evaluation
5564 * environment explicit. */
5567 change_environment (void *data
)
5569 SCM pair
= SCM_PACK (data
);
5570 SCM new_module
= SCM_CAR (pair
);
5571 SCM old_module
= scm_current_module ();
5572 SCM_SETCDR (pair
, old_module
);
5573 scm_set_current_module (new_module
);
5577 restore_environment (void *data
)
5579 SCM pair
= SCM_PACK (data
);
5580 SCM old_module
= SCM_CDR (pair
);
5581 SCM new_module
= scm_current_module ();
5582 SCM_SETCAR (pair
, new_module
);
5583 scm_set_current_module (old_module
);
5587 inner_eval_x (void *data
)
5589 return scm_primitive_eval_x (SCM_PACK(data
));
5593 scm_eval_x (SCM exp
, SCM module
)
5594 #define FUNC_NAME "eval!"
5596 SCM_VALIDATE_MODULE (2, module
);
5598 return scm_internal_dynamic_wind
5599 (change_environment
, inner_eval_x
, restore_environment
,
5600 (void *) SCM_UNPACK (exp
),
5601 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
5606 inner_eval (void *data
)
5608 return scm_primitive_eval (SCM_PACK(data
));
5611 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
5612 (SCM exp
, SCM module
),
5613 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
5614 "in the top-level environment specified by @var{module}.\n"
5615 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
5616 "@var{module} is made the current module. The current module\n"
5617 "is reset to its previous value when @var{eval} returns.")
5618 #define FUNC_NAME s_scm_eval
5620 SCM_VALIDATE_MODULE (2, module
);
5622 return scm_internal_dynamic_wind
5623 (change_environment
, inner_eval
, restore_environment
,
5624 (void *) SCM_UNPACK (exp
),
5625 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
5630 /* At this point, scm_deval and scm_dapply are generated.
5640 scm_init_opts (scm_evaluator_traps
,
5641 scm_evaluator_trap_table
,
5642 SCM_N_EVALUATOR_TRAPS
);
5643 scm_init_opts (scm_eval_options_interface
,
5645 SCM_N_EVAL_OPTIONS
);
5647 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
5648 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
5649 scm_set_smob_free (scm_tc16_promise
, promise_free
);
5650 scm_set_smob_print (scm_tc16_promise
, promise_print
);
5652 undefineds
= scm_list_1 (SCM_UNDEFINED
);
5653 SCM_SETCDR (undefineds
, undefineds
);
5654 scm_permanent_object (undefineds
);
5656 scm_listofnull
= scm_list_1 (SCM_EOL
);
5658 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
5659 scm_permanent_object (f_apply
);
5661 #include "libguile/eval.x"
5663 scm_add_feature ("delay");