* deprecated.h, boolean.h (SCM_FALSEP, SCM_NFALSEP, SCM_BOOL,
[bpt/guile.git] / libguile / eval.c
CommitLineData
434f2f7a
DH
1/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004
2 * Free Software Foundation, Inc.
0f2d19dd 3 *
73be1d9e
MV
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public
6 * License as published by the Free Software Foundation; either
7 * version 2.1 of the License, or (at your option) any later version.
0f2d19dd 8 *
73be1d9e
MV
9 * This library is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
0f2d19dd 13 *
73be1d9e
MV
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
17 */
1bbd0b84 18
0f2d19dd
JB
19\f
20
434f2f7a
DH
21/* This file is read twice in order to produce debugging versions of ceval and
22 * scm_apply. These functions, deval and scm_dapply, are produced when we
23 * define the preprocessor macro DEVAL. The file is divided into sections
24 * which are treated differently with respect to DEVAL. The heads of these
25 * sections are marked with the string "SECTION:". */
6dbd0af5 26
6dbd0af5 27/* SECTION: This code is compiled once.
0f2d19dd
JB
28 */
29
3d05f2e0
RB
30#if HAVE_CONFIG_H
31# include <config.h>
32#endif
0f2d19dd 33
3d05f2e0
RB
34#include "libguile/__scm.h"
35
36#ifndef DEVAL
d16332b3 37
48b96f4b
JB
38/* AIX requires this to be the first thing in the file. The #pragma
39 directive is indented so pre-ANSI compilers will ignore it, rather
40 than choke on it. */
5862b540 41#ifndef __GNUC__
48b96f4b
JB
42# if HAVE_ALLOCA_H
43# include <alloca.h>
44# else
45# ifdef _AIX
ac13d9d2 46# pragma alloca
48b96f4b
JB
47# else
48# ifndef alloca /* predefined by HP cc +Olibcalls */
49char *alloca ();
50# endif
51# endif
52# endif
53#endif
54
e7313a9d 55#include <assert.h>
a0599745 56#include "libguile/_scm.h"
21628685
DH
57#include "libguile/alist.h"
58#include "libguile/async.h"
59#include "libguile/continuations.h"
a0599745 60#include "libguile/debug.h"
328dc9a3 61#include "libguile/deprecation.h"
09074dbf 62#include "libguile/dynwind.h"
a0599745 63#include "libguile/eq.h"
21628685
DH
64#include "libguile/feature.h"
65#include "libguile/fluids.h"
756414cf 66#include "libguile/futures.h"
21628685
DH
67#include "libguile/goops.h"
68#include "libguile/hash.h"
69#include "libguile/hashtab.h"
70#include "libguile/lang.h"
4610b011 71#include "libguile/list.h"
a0599745 72#include "libguile/macros.h"
a0599745 73#include "libguile/modules.h"
21628685 74#include "libguile/objects.h"
a0599745 75#include "libguile/ports.h"
7e6e6b37 76#include "libguile/print.h"
21628685 77#include "libguile/procprop.h"
a0599745 78#include "libguile/root.h"
21628685
DH
79#include "libguile/smob.h"
80#include "libguile/srcprop.h"
81#include "libguile/stackchk.h"
82#include "libguile/strings.h"
83#include "libguile/throw.h"
84#include "libguile/validate.h"
a513ead3 85#include "libguile/values.h"
21628685 86#include "libguile/vectors.h"
a0599745 87
a0599745 88#include "libguile/eval.h"
89efbff4 89
0f2d19dd
JB
90\f
91
212e58ed 92static SCM unmemoize_exprs (SCM expr, SCM env);
0f572ba7 93static SCM canonicalize_define (SCM expr);
e5156567 94static SCM *scm_lookupcar1 (SCM vloc, SCM genv, int check);
212e58ed 95static SCM unmemoize_builtin_macro (SCM expr, SCM env);
0f572ba7
DH
96
97\f
98
e6729603
DH
99/* {Syntax Errors}
100 *
101 * This section defines the message strings for the syntax errors that can be
102 * detected during memoization and the functions and macros that shall be
103 * called by the memoizer code to signal syntax errors. */
104
105
106/* Syntax errors that can be detected during memoization: */
107
108/* Circular or improper lists do not form valid scheme expressions. If a
109 * circular list or an improper list is detected in a place where a scheme
110 * expression is expected, a 'Bad expression' error is signalled. */
111static const char s_bad_expression[] = "Bad expression";
112
89bff2fc
DH
113/* If a form is detected that holds a different number of expressions than are
114 * required in that context, a 'Missing or extra expression' error is
115 * signalled. */
116static const char s_expression[] = "Missing or extra expression in";
117
cc56ba80 118/* If a form is detected that holds less expressions than are required in that
8ae95199 119 * context, a 'Missing expression' error is signalled. */
cc56ba80
DH
120static const char s_missing_expression[] = "Missing expression in";
121
609a8b86 122/* If a form is detected that holds more expressions than are allowed in that
8ae95199 123 * context, an 'Extra expression' error is signalled. */
609a8b86
DH
124static const char s_extra_expression[] = "Extra expression in";
125
89bff2fc
DH
126/* The empty combination '()' is not allowed as an expression in scheme. If
127 * it is detected in a place where an expression is expected, an 'Illegal
128 * empty combination' error is signalled. Note: If you encounter this error
129 * message, it is very likely that you intended to denote the empty list. To
130 * do so, you need to quote the empty list like (quote ()) or '(). */
131static const char s_empty_combination[] = "Illegal empty combination";
132
c86c440b
DH
133/* A body may hold an arbitrary number of internal defines, followed by a
134 * non-empty sequence of expressions. If a body with an empty sequence of
135 * expressions is detected, a 'Missing body expression' error is signalled.
136 */
137static const char s_missing_body_expression[] = "Missing body expression in";
138
139/* A body may hold an arbitrary number of internal defines, followed by a
140 * non-empty sequence of expressions. Each the definitions and the
141 * expressions may be grouped arbitraryly with begin, but it is not allowed to
142 * mix definitions and expressions. If a define form in a body mixes
143 * definitions and expressions, a 'Mixed definitions and expressions' error is
6bff1368 144 * signalled. */
c86c440b 145static const char s_mixed_body_forms[] = "Mixed definitions and expressions in";
6bff1368
DH
146/* Definitions are only allowed on the top level and at the start of a body.
147 * If a definition is detected anywhere else, a 'Bad define placement' error
148 * is signalled. */
149static const char s_bad_define[] = "Bad define placement";
c86c440b 150
2a6f7afe
DH
151/* Case or cond expressions must have at least one clause. If a case or cond
152 * expression without any clauses is detected, a 'Missing clauses' error is
153 * signalled. */
154static const char s_missing_clauses[] = "Missing clauses";
155
609a8b86
DH
156/* If there is an 'else' clause in a case or a cond statement, it must be the
157 * last clause. If after the 'else' case clause further clauses are detected,
158 * a 'Misplaced else clause' error is signalled. */
159static const char s_misplaced_else_clause[] = "Misplaced else clause";
160
2a6f7afe
DH
161/* If a case clause is detected that is not in the format
162 * (<label(s)> <expression1> <expression2> ...)
163 * a 'Bad case clause' error is signalled. */
164static const char s_bad_case_clause[] = "Bad case clause";
165
2a6f7afe
DH
166/* If a case clause is detected where the <label(s)> element is neither a
167 * proper list nor (in case of the last clause) the syntactic keyword 'else',
168 * a 'Bad case labels' error is signalled. Note: If you encounter this error
169 * for an else-clause which seems to be syntactically correct, check if 'else'
170 * is really a syntactic keyword in that context. If 'else' is bound in the
171 * local or global environment, it is not considered a syntactic keyword, but
172 * will be treated as any other variable. */
173static const char s_bad_case_labels[] = "Bad case labels";
174
175/* In a case statement all labels have to be distinct. If in a case statement
176 * a label occurs more than once, a 'Duplicate case label' error is
177 * signalled. */
178static const char s_duplicate_case_label[] = "Duplicate case label";
179
609a8b86
DH
180/* If a cond clause is detected that is not in one of the formats
181 * (<test> <expression1> ...) or (else <expression1> <expression2> ...)
182 * a 'Bad cond clause' error is signalled. */
183static const char s_bad_cond_clause[] = "Bad cond clause";
184
185/* If a cond clause is detected that uses the alternate '=>' form, but does
186 * not hold a recipient element for the test result, a 'Missing recipient'
187 * error is signalled. */
188static const char s_missing_recipient[] = "Missing recipient in";
189
cc56ba80
DH
190/* If in a position where a variable name is required some other object is
191 * detected, a 'Bad variable' error is signalled. */
192static const char s_bad_variable[] = "Bad variable";
193
a954ce1d
DH
194/* Bindings for forms like 'let' and 'do' have to be given in a proper,
195 * possibly empty list. If any other object is detected in a place where a
196 * list of bindings was required, a 'Bad bindings' error is signalled. */
197static const char s_bad_bindings[] = "Bad bindings";
198
199/* Depending on the syntactic context, a binding has to be in the format
200 * (<variable> <expression>) or (<variable> <expression1> <expression2>).
201 * If anything else is detected in a place where a binding was expected, a
202 * 'Bad binding' error is signalled. */
203static const char s_bad_binding[] = "Bad binding";
204
4610b011
DH
205/* Some syntactic forms don't allow variable names to appear more than once in
206 * a list of bindings. If such a situation is nevertheless detected, a
207 * 'Duplicate binding' error is signalled. */
208static const char s_duplicate_binding[] = "Duplicate binding";
209
a954ce1d
DH
210/* If the exit form of a 'do' expression is not in the format
211 * (<test> <expression> ...)
212 * a 'Bad exit clause' error is signalled. */
213static const char s_bad_exit_clause[] = "Bad exit clause";
214
03a3e941
DH
215/* The formal function arguments of a lambda expression have to be either a
216 * single symbol or a non-cyclic list. For anything else a 'Bad formals'
217 * error is signalled. */
218static const char s_bad_formals[] = "Bad formals";
219
220/* If in a lambda expression something else than a symbol is detected at a
221 * place where a formal function argument is required, a 'Bad formal' error is
222 * signalled. */
223static const char s_bad_formal[] = "Bad formal";
224
225/* If in the arguments list of a lambda expression an argument name occurs
226 * more than once, a 'Duplicate formal' error is signalled. */
227static const char s_duplicate_formal[] = "Duplicate formal";
228
6f81708a
DH
229/* If the evaluation of an unquote-splicing expression gives something else
230 * than a proper list, a 'Non-list result for unquote-splicing' error is
231 * signalled. */
232static const char s_splicing[] = "Non-list result for unquote-splicing";
233
9a848baf
DH
234/* If something else than an exact integer is detected as the argument for
235 * @slot-ref and @slot-set!, a 'Bad slot number' error is signalled. */
236static const char s_bad_slot_number[] = "Bad slot number";
237
e6729603
DH
238
239/* Signal a syntax error. We distinguish between the form that caused the
240 * error and the enclosing expression. The error message will print out as
241 * shown in the following pattern. The file name and line number are only
242 * given when they can be determined from the erroneous form or from the
243 * enclosing expression.
244 *
245 * <filename>: In procedure memoization:
246 * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
247
248SCM_SYMBOL (syntax_error_key, "syntax-error");
249
250/* The prototype is needed to indicate that the function does not return. */
251static void
252syntax_error (const char* const, const SCM, const SCM) SCM_NORETURN;
253
254static void
255syntax_error (const char* const msg, const SCM form, const SCM expr)
256{
257 const SCM msg_string = scm_makfrom0str (msg);
258 SCM filename = SCM_BOOL_F;
259 SCM linenr = SCM_BOOL_F;
260 const char *format;
261 SCM args;
262
263 if (SCM_CONSP (form))
264 {
265 filename = scm_source_property (form, scm_sym_filename);
266 linenr = scm_source_property (form, scm_sym_line);
267 }
268
7888309b 269 if (scm_is_false (filename) && scm_is_false (linenr) && SCM_CONSP (expr))
e6729603
DH
270 {
271 filename = scm_source_property (expr, scm_sym_filename);
272 linenr = scm_source_property (expr, scm_sym_line);
273 }
274
275 if (!SCM_UNBNDP (expr))
276 {
7888309b 277 if (scm_is_true (filename))
e6729603
DH
278 {
279 format = "In file ~S, line ~S: ~A ~S in expression ~S.";
280 args = scm_list_5 (filename, linenr, msg_string, form, expr);
281 }
7888309b 282 else if (scm_is_true (linenr))
e6729603
DH
283 {
284 format = "In line ~S: ~A ~S in expression ~S.";
285 args = scm_list_4 (linenr, msg_string, form, expr);
286 }
287 else
288 {
289 format = "~A ~S in expression ~S.";
290 args = scm_list_3 (msg_string, form, expr);
291 }
292 }
293 else
294 {
7888309b 295 if (scm_is_true (filename))
e6729603
DH
296 {
297 format = "In file ~S, line ~S: ~A ~S.";
298 args = scm_list_4 (filename, linenr, msg_string, form);
299 }
7888309b 300 else if (scm_is_true (linenr))
e6729603
DH
301 {
302 format = "In line ~S: ~A ~S.";
303 args = scm_list_3 (linenr, msg_string, form);
304 }
305 else
306 {
307 format = "~A ~S.";
308 args = scm_list_2 (msg_string, form);
309 }
310 }
311
312 scm_error (syntax_error_key, "memoization", format, args, SCM_BOOL_F);
313}
314
315
316/* Shortcut macros to simplify syntax error handling. */
317#define ASSERT_SYNTAX(cond, message, form) \
318 { if (!(cond)) syntax_error (message, form, SCM_UNDEFINED); }
319#define ASSERT_SYNTAX_2(cond, message, form, expr) \
320 { if (!(cond)) syntax_error (message, form, expr); }
321
322\f
323
d0624e39
DH
324/* {Ilocs}
325 *
326 * Ilocs are memoized references to variables in local environment frames.
327 * They are represented as three values: The relative offset of the
328 * environment frame, the number of the binding within that frame, and a
329 * boolean value indicating whether the binding is the last binding in the
330 * frame.
331 */
7e6e6b37 332
d0624e39 333#define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc)
7e6e6b37
DH
334#define SCM_IFRINC (0x00000100L)
335#define SCM_ICDR (0x00080000L)
d0624e39 336#define SCM_IDINC (0x00100000L)
7e6e6b37
DH
337#define SCM_IFRAME(n) ((long)((SCM_ICDR-SCM_IFRINC)>>8) \
338 & (SCM_UNPACK (n) >> 8))
339#define SCM_IDIST(n) (SCM_UNPACK (n) >> 20)
340#define SCM_ICDRP(n) (SCM_ICDR & SCM_UNPACK (n))
d0624e39
DH
341#define SCM_IDSTMSK (-SCM_IDINC)
342#define SCM_MAKE_ILOC(frame_nr, binding_nr, last_p) \
343 SCM_PACK ( \
344 ((frame_nr) << 8) \
345 + ((binding_nr) << 20) \
346 + ((last_p) ? SCM_ICDR : 0) \
347 + scm_tc8_iloc )
348
7e6e6b37
DH
349void
350scm_i_print_iloc (SCM iloc, SCM port)
351{
352 scm_puts ("#@", port);
353 scm_intprint ((long) SCM_IFRAME (iloc), 10, port);
354 scm_putc (SCM_ICDRP (iloc) ? '-' : '+', port);
355 scm_intprint ((long) SCM_IDIST (iloc), 10, port);
356}
357
d0624e39
DH
358#if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
359
360SCM scm_dbg_make_iloc (SCM frame, SCM binding, SCM cdrp);
90df793f 361
d0624e39
DH
362SCM_DEFINE (scm_dbg_make_iloc, "dbg-make-iloc", 3, 0, 0,
363 (SCM frame, SCM binding, SCM cdrp),
364 "Return a new iloc with frame offset @var{frame}, binding\n"
365 "offset @var{binding} and the cdr flag @var{cdrp}.")
366#define FUNC_NAME s_scm_dbg_make_iloc
367{
368 SCM_VALIDATE_INUM (1, frame);
369 SCM_VALIDATE_INUM (2, binding);
370 return SCM_MAKE_ILOC (SCM_INUM (frame),
371 SCM_INUM (binding),
7888309b 372 scm_is_true (cdrp));
d0624e39
DH
373}
374#undef FUNC_NAME
375
376SCM scm_dbg_iloc_p (SCM obj);
90df793f 377
d0624e39
DH
378SCM_DEFINE (scm_dbg_iloc_p, "dbg-iloc?", 1, 0, 0,
379 (SCM obj),
380 "Return @code{#t} if @var{obj} is an iloc.")
381#define FUNC_NAME s_scm_dbg_iloc_p
382{
7888309b 383 return scm_from_bool (SCM_ILOCP (obj));
d0624e39
DH
384}
385#undef FUNC_NAME
386
387#endif
388
389\f
390
7e6e6b37
DH
391/* {Evaluator byte codes (isyms)}
392 */
393
394#define ISYMNUM(n) (SCM_ITAG8_DATA (n))
395
396/* This table must agree with the list of SCM_IM_ constants in tags.h */
397static const char *const isymnames[] =
398{
399 "#@and",
400 "#@begin",
401 "#@case",
402 "#@cond",
403 "#@do",
404 "#@if",
405 "#@lambda",
406 "#@let",
407 "#@let*",
408 "#@letrec",
409 "#@or",
410 "#@quote",
411 "#@set!",
412 "#@define",
413 "#@apply",
414 "#@call-with-current-continuation",
415 "#@dispatch",
416 "#@slot-ref",
417 "#@slot-set!",
418 "#@delay",
419 "#@future",
420 "#@call-with-values",
421 "#@else",
422 "#@arrow",
423 "#@nil-cond",
424 "#@bind"
425};
426
427void
428scm_i_print_isym (SCM isym, SCM port)
429{
430 const size_t isymnum = ISYMNUM (isym);
431 if (isymnum < (sizeof isymnames / sizeof (char *)))
432 scm_puts (isymnames[isymnum], port);
433 else
434 scm_ipruk ("isym", isym, port);
435}
436
437\f
438
e5156567
DH
439/* The function lookup_symbol is used during memoization: Lookup the symbol in
440 * the environment. If there is no binding for the symbol, SCM_UNDEFINED is
57d23e25
DH
441 * returned. If the symbol is a global variable, the variable object to which
442 * the symbol is bound is returned. Finally, if the symbol is a local
443 * variable the corresponding iloc object is returned. */
6f81708a
DH
444
445/* A helper function for lookup_symbol: Try to find the symbol in the top
446 * level environment frame. The function returns SCM_UNDEFINED if the symbol
57d23e25
DH
447 * is unbound and it returns a variable object if the symbol is a global
448 * variable. */
6f81708a
DH
449static SCM
450lookup_global_symbol (const SCM symbol, const SCM top_level)
451{
452 const SCM variable = scm_sym2var (symbol, top_level, SCM_BOOL_F);
7888309b 453 if (scm_is_false (variable))
57d23e25 454 return SCM_UNDEFINED;
6f81708a 455 else
57d23e25 456 return variable;
6f81708a
DH
457}
458
459static SCM
460lookup_symbol (const SCM symbol, const SCM env)
461{
462 SCM frame_idx;
463 unsigned int frame_nr;
464
465 for (frame_idx = env, frame_nr = 0;
466 !SCM_NULLP (frame_idx);
467 frame_idx = SCM_CDR (frame_idx), ++frame_nr)
468 {
469 const SCM frame = SCM_CAR (frame_idx);
470 if (SCM_CONSP (frame))
471 {
472 /* frame holds a local environment frame */
473 SCM symbol_idx;
474 unsigned int symbol_nr;
475
476 for (symbol_idx = SCM_CAR (frame), symbol_nr = 0;
477 SCM_CONSP (symbol_idx);
478 symbol_idx = SCM_CDR (symbol_idx), ++symbol_nr)
479 {
480 if (SCM_EQ_P (SCM_CAR (symbol_idx), symbol))
481 /* found the symbol, therefore return the iloc */
482 return SCM_MAKE_ILOC (frame_nr, symbol_nr, 0);
483 }
484 if (SCM_EQ_P (symbol_idx, symbol))
485 /* found the symbol as the last element of the current frame */
486 return SCM_MAKE_ILOC (frame_nr, symbol_nr, 1);
487 }
488 else
489 {
490 /* no more local environment frames */
491 return lookup_global_symbol (symbol, frame);
492 }
493 }
494
495 return lookup_global_symbol (symbol, SCM_BOOL_F);
496}
497
498
499/* Return true if the symbol is - from the point of view of a macro
500 * transformer - a literal in the sense specified in chapter "pattern
501 * language" of R5RS. In the code below, however, we don't match the
502 * definition of R5RS exactly: It returns true if the identifier has no
503 * binding or if it is a syntactic keyword. */
504static int
505literal_p (const SCM symbol, const SCM env)
506{
57d23e25
DH
507 const SCM variable = lookup_symbol (symbol, env);
508 if (SCM_UNBNDP (variable))
509 return 1;
510 if (SCM_VARIABLEP (variable) && SCM_MACROP (SCM_VARIABLE_REF (variable)))
6f81708a
DH
511 return 1;
512 else
513 return 0;
514}
17fa3fcf 515
5fb64383
DH
516
517/* Return true if the expression is self-quoting in the memoized code. Thus,
518 * some other objects (like e. g. vectors) are reported as self-quoting, which
519 * according to R5RS would need to be quoted. */
520static int
521is_self_quoting_p (const SCM expr)
522{
523 if (SCM_CONSP (expr))
524 return 0;
525 else if (SCM_SYMBOLP (expr))
526 return 0;
527 else if (SCM_NULLP (expr))
528 return 0;
529 else return 1;
530}
531
0f2d19dd 532
212e58ed
DH
533SCM_SYMBOL (sym_three_question_marks, "???");
534
535static SCM
536unmemoize_expression (const SCM expr, const SCM env)
537{
538 if (SCM_ILOCP (expr))
539 {
540 SCM frame_idx;
541 unsigned long int frame_nr;
542 SCM symbol_idx;
543 unsigned long int symbol_nr;
544
545 for (frame_idx = env, frame_nr = SCM_IFRAME (expr);
546 frame_nr != 0;
547 frame_idx = SCM_CDR (frame_idx), --frame_nr)
548 ;
549 for (symbol_idx = SCM_CAAR (frame_idx), symbol_nr = SCM_IDIST (expr);
550 symbol_nr != 0;
551 symbol_idx = SCM_CDR (symbol_idx), --symbol_nr)
552 ;
553 return SCM_ICDRP (expr) ? symbol_idx : SCM_CAR (symbol_idx);
554 }
555 else if (SCM_VARIABLEP (expr))
556 {
557 const SCM sym = scm_module_reverse_lookup (scm_env_module (env), expr);
7888309b 558 return scm_is_true (sym) ? sym : sym_three_question_marks;
212e58ed
DH
559 }
560 else if (SCM_VECTORP (expr))
561 {
562 return scm_list_2 (scm_sym_quote, expr);
563 }
564 else if (!SCM_CONSP (expr))
565 {
566 return expr;
567 }
568 else if (SCM_ISYMP (SCM_CAR (expr)))
569 {
570 return unmemoize_builtin_macro (expr, env);
571 }
572 else
573 {
574 return unmemoize_exprs (expr, env);
575 }
576}
577
578
579static SCM
580unmemoize_exprs (const SCM exprs, const SCM env)
581{
90df793f 582 SCM r_result = SCM_EOL;
9fcf3cbb 583 SCM expr_idx = exprs;
90df793f
DH
584 SCM um_expr;
585
586 /* Note that due to the current lazy memoizer we may find partially memoized
9fcf3cbb
DH
587 * code during execution. In such code, lists of expressions that stem from
588 * a body form may start with an ISYM if the body itself has not yet been
589 * memoized. This isym is just an internal marker to indicate that the body
590 * still needs to be memoized. It is dropped during unmemoization. */
591 if (SCM_CONSP (expr_idx) && SCM_ISYMP (SCM_CAR (expr_idx)))
592 expr_idx = SCM_CDR (expr_idx);
593
594 /* Moreover, in partially memoized code we have to expect improper lists of
90df793f
DH
595 * expressions: On the one hand, for such code syntax checks have not yet
596 * fully been performed, on the other hand, there may be even legal code
597 * like '(a . b) appear as an improper list of expressions as long as the
598 * quote expression is still in its unmemoized form. For this reason, the
599 * following code handles improper lists of expressions until memoization
600 * and execution have been completely separated. */
9fcf3cbb 601 for (; SCM_CONSP (expr_idx); expr_idx = SCM_CDR (expr_idx))
212e58ed
DH
602 {
603 const SCM expr = SCM_CAR (expr_idx);
90df793f
DH
604 um_expr = unmemoize_expression (expr, env);
605 r_result = scm_cons (um_expr, r_result);
606 }
607 um_expr = unmemoize_expression (expr_idx, env);
608 if (!SCM_NULLP (r_result))
609 {
610 const SCM result = scm_reverse_x (r_result, SCM_UNDEFINED);
611 SCM_SETCDR (r_result, um_expr);
612 return result;
613 }
614 else
615 {
616 return um_expr;
212e58ed 617 }
212e58ed
DH
618}
619
620
34adf7ea
DH
621/* Rewrite the body (which is given as the list of expressions forming the
622 * body) into its internal form. The internal form of a body (<expr> ...) is
623 * just the body itself, but prefixed with an ISYM that denotes to what kind
624 * of outer construct this body belongs: (<ISYM> <expr> ...). A lambda body
625 * starts with SCM_IM_LAMBDA, for example, a body of a let starts with
6bff1368 626 * SCM_IM_LET, etc.
34adf7ea
DH
627 *
628 * It is assumed that the calling expression has already made sure that the
629 * body is a proper list. */
26d5b9b4 630static SCM
430b8401 631m_body (SCM op, SCM exprs)
26d5b9b4 632{
26d5b9b4 633 /* Don't add another ISYM if one is present already. */
34adf7ea
DH
634 if (SCM_ISYMP (SCM_CAR (exprs)))
635 return exprs;
636 else
637 return scm_cons (op, exprs);
26d5b9b4
MD
638}
639
1cc91f1b 640
57d23e25
DH
641/* The function m_expand_body memoizes a proper list of expressions forming a
642 * body. This function takes care of dealing with internal defines and
643 * transforming them into an equivalent letrec expression. The list of
644 * expressions is rewritten in place. */
910b5125 645
57d23e25
DH
646/* This is a helper function for m_expand_body. If the argument expression is
647 * a symbol that denotes a syntactic keyword, the corresponding macro object
648 * is returned, in all other cases the function returns SCM_UNDEFINED. */
910b5125
DH
649static SCM
650try_macro_lookup (const SCM expr, const SCM env)
651{
652 if (SCM_SYMBOLP (expr))
653 {
57d23e25
DH
654 const SCM variable = lookup_symbol (expr, env);
655 if (SCM_VARIABLEP (variable))
656 {
657 const SCM value = SCM_VARIABLE_REF (variable);
658 if (SCM_MACROP (value))
659 return value;
660 }
910b5125 661 }
57d23e25
DH
662
663 return SCM_UNDEFINED;
910b5125
DH
664}
665
666/* This is a helper function for m_expand_body. It expands user macros,
667 * because for the correct translation of a body we need to know whether they
668 * expand to a definition. */
669static SCM
670expand_user_macros (SCM expr, const SCM env)
671{
672 while (SCM_CONSP (expr))
673 {
674 const SCM car_expr = SCM_CAR (expr);
675 const SCM new_car = expand_user_macros (car_expr, env);
676 const SCM value = try_macro_lookup (new_car, env);
677
678 if (SCM_MACROP (value) && SCM_MACRO_TYPE (value) == 2)
679 {
680 /* User macros transform code into code. */
681 expr = scm_call_2 (SCM_MACRO_CODE (value), expr, env);
682 /* We need to reiterate on the transformed code. */
683 }
684 else
685 {
686 /* No user macro: return. */
687 SCM_SETCAR (expr, new_car);
688 return expr;
689 }
690 }
691
692 return expr;
693}
694
695/* This is a helper function for m_expand_body. It determines if a given form
696 * represents an application of a given built-in macro. The built-in macro to
697 * check for is identified by its syntactic keyword. The form is an
698 * application of the given macro if looking up the car of the form in the
699 * given environment actually returns the built-in macro. */
700static int
701is_system_macro_p (const SCM syntactic_keyword, const SCM form, const SCM env)
702{
703 if (SCM_CONSP (form))
704 {
705 const SCM car_form = SCM_CAR (form);
706 const SCM value = try_macro_lookup (car_form, env);
707 if (SCM_BUILTIN_MACRO_P (value))
708 {
709 const SCM macro_name = scm_macro_name (value);
710 return SCM_EQ_P (macro_name, syntactic_keyword);
711 }
712 }
713
714 return 0;
715}
716
9d4bf6d3 717static void
910b5125
DH
718m_expand_body (const SCM forms, const SCM env)
719{
720 /* The first body form can be skipped since it is known to be the ISYM that
721 * was prepended to the body by m_body. */
722 SCM cdr_forms = SCM_CDR (forms);
723 SCM form_idx = cdr_forms;
724 SCM definitions = SCM_EOL;
725 SCM sequence = SCM_EOL;
726
727 /* According to R5RS, the list of body forms consists of two parts: a number
728 * (maybe zero) of definitions, followed by a non-empty sequence of
729 * expressions. Each the definitions and the expressions may be grouped
730 * arbitrarily with begin, but it is not allowed to mix definitions and
731 * expressions. The task of the following loop therefore is to split the
732 * list of body forms into the list of definitions and the sequence of
733 * expressions. */
734 while (!SCM_NULLP (form_idx))
735 {
736 const SCM form = SCM_CAR (form_idx);
737 const SCM new_form = expand_user_macros (form, env);
738 if (is_system_macro_p (scm_sym_define, new_form, env))
739 {
740 definitions = scm_cons (new_form, definitions);
741 form_idx = SCM_CDR (form_idx);
742 }
743 else if (is_system_macro_p (scm_sym_begin, new_form, env))
744 {
745 /* We have encountered a group of forms. This has to be either a
746 * (possibly empty) group of (possibly further grouped) definitions,
747 * or a non-empty group of (possibly further grouped)
748 * expressions. */
749 const SCM grouped_forms = SCM_CDR (new_form);
750 unsigned int found_definition = 0;
751 unsigned int found_expression = 0;
752 SCM grouped_form_idx = grouped_forms;
753 while (!found_expression && !SCM_NULLP (grouped_form_idx))
754 {
755 const SCM inner_form = SCM_CAR (grouped_form_idx);
756 const SCM new_inner_form = expand_user_macros (inner_form, env);
757 if (is_system_macro_p (scm_sym_define, new_inner_form, env))
758 {
759 found_definition = 1;
760 definitions = scm_cons (new_inner_form, definitions);
761 grouped_form_idx = SCM_CDR (grouped_form_idx);
762 }
763 else if (is_system_macro_p (scm_sym_begin, new_inner_form, env))
764 {
765 const SCM inner_group = SCM_CDR (new_inner_form);
766 grouped_form_idx
767 = scm_append (scm_list_2 (inner_group,
768 SCM_CDR (grouped_form_idx)));
769 }
770 else
771 {
772 /* The group marks the start of the expressions of the body.
773 * We have to make sure that within the same group we have
774 * not encountered a definition before. */
775 ASSERT_SYNTAX (!found_definition, s_mixed_body_forms, form);
776 found_expression = 1;
777 grouped_form_idx = SCM_EOL;
778 }
779 }
780
781 /* We have finished processing the group. If we have not yet
782 * encountered an expression we continue processing the forms of the
783 * body to collect further definition forms. Otherwise, the group
784 * marks the start of the sequence of expressions of the body. */
785 if (!found_expression)
786 {
787 form_idx = SCM_CDR (form_idx);
788 }
789 else
790 {
791 sequence = form_idx;
792 form_idx = SCM_EOL;
793 }
794 }
795 else
796 {
797 /* We have detected a form which is no definition. This marks the
798 * start of the sequence of expressions of the body. */
799 sequence = form_idx;
800 form_idx = SCM_EOL;
801 }
802 }
803
804 /* FIXME: forms does not hold information about the file location. */
805 ASSERT_SYNTAX (SCM_CONSP (sequence), s_missing_body_expression, cdr_forms);
806
807 if (!SCM_NULLP (definitions))
808 {
809 SCM definition_idx;
810 SCM letrec_tail;
811 SCM letrec_expression;
812 SCM new_letrec_expression;
910b5125
DH
813
814 SCM bindings = SCM_EOL;
815 for (definition_idx = definitions;
816 !SCM_NULLP (definition_idx);
817 definition_idx = SCM_CDR (definition_idx))
818 {
819 const SCM definition = SCM_CAR (definition_idx);
820 const SCM canonical_definition = canonicalize_define (definition);
821 const SCM binding = SCM_CDR (canonical_definition);
822 bindings = scm_cons (binding, bindings);
823 };
824
825 letrec_tail = scm_cons (bindings, sequence);
826 /* FIXME: forms does not hold information about the file location. */
827 letrec_expression = scm_cons_source (forms, scm_sym_letrec, letrec_tail);
828 new_letrec_expression = scm_m_letrec (letrec_expression, env);
9d4bf6d3
MV
829 SCM_SETCAR (forms, new_letrec_expression);
830 SCM_SETCDR (forms, SCM_EOL);
910b5125
DH
831 }
832 else
833 {
834 SCM_SETCAR (forms, SCM_CAR (sequence));
835 SCM_SETCDR (forms, SCM_CDR (sequence));
910b5125
DH
836 }
837}
838
2b189e65
MV
839static SCM
840macroexp (SCM x, SCM env)
841{
842 SCM res, proc, orig_sym;
843
844 /* Don't bother to produce error messages here. We get them when we
845 eventually execute the code for real. */
846
847 macro_tail:
848 orig_sym = SCM_CAR (x);
849 if (!SCM_SYMBOLP (orig_sym))
850 return x;
851
852 {
853 SCM *proc_ptr = scm_lookupcar1 (x, env, 0);
854 if (proc_ptr == NULL)
855 {
856 /* We have lost the race. */
857 goto macro_tail;
858 }
859 proc = *proc_ptr;
860 }
861
862 /* Only handle memoizing macros. `Acros' and `macros' are really
863 special forms and should not be evaluated here. */
864
865 if (!SCM_MACROP (proc)
866 || (SCM_MACRO_TYPE (proc) != 2 && !SCM_BUILTIN_MACRO_P (proc)))
867 return x;
868
869 SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of lookupcar */
870 res = scm_call_2 (SCM_MACRO_CODE (proc), x, env);
871
872 if (scm_ilength (res) <= 0)
873 res = scm_list_2 (SCM_IM_BEGIN, res);
874
875 SCM_DEFER_INTS;
876 SCM_SETCAR (x, SCM_CAR (res));
877 SCM_SETCDR (x, SCM_CDR (res));
878 SCM_ALLOW_INTS;
879
880 goto macro_tail;
881}
910b5125 882
9fbee57e 883/* Start of the memoizers for the standard R5RS builtin macros. */
0f2d19dd
JB
884
885
3b88ed2a 886SCM_SYNTAX (s_and, "and", scm_i_makbimacro, scm_m_and);
8ea46249 887SCM_GLOBAL_SYMBOL (scm_sym_and, s_and);
1cc91f1b 888
8ea46249 889SCM
e6729603 890scm_m_and (SCM expr, SCM env SCM_UNUSED)
0f2d19dd 891{
e6729603
DH
892 const SCM cdr_expr = SCM_CDR (expr);
893 const long length = scm_ilength (cdr_expr);
894
895 ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
896
897 if (length == 0)
898 {
899 /* Special case: (and) is replaced by #t. */
900 return SCM_BOOL_T;
901 }
0f2d19dd 902 else
e6729603
DH
903 {
904 SCM_SETCAR (expr, SCM_IM_AND);
905 return expr;
906 }
0f2d19dd
JB
907}
908
212e58ed
DH
909static SCM
910unmemoize_and (const SCM expr, const SCM env)
911{
912 return scm_cons (scm_sym_and, unmemoize_exprs (SCM_CDR (expr), env));
913}
914
1cc91f1b 915
3b88ed2a 916SCM_SYNTAX (s_begin, "begin", scm_i_makbimacro, scm_m_begin);
9fbee57e 917SCM_GLOBAL_SYMBOL (scm_sym_begin, s_begin);
8ea46249
DH
918
919SCM
2a6f7afe 920scm_m_begin (SCM expr, SCM env SCM_UNUSED)
0f2d19dd 921{
2a6f7afe 922 const SCM cdr_expr = SCM_CDR (expr);
21628685
DH
923 /* Dirk:FIXME:: An empty begin clause is not generally allowed by R5RS.
924 * That means, there should be a distinction between uses of begin where an
925 * empty clause is OK and where it is not. */
2a6f7afe
DH
926 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
927
928 SCM_SETCAR (expr, SCM_IM_BEGIN);
929 return expr;
0f2d19dd
JB
930}
931
212e58ed
DH
932static SCM
933unmemoize_begin (const SCM expr, const SCM env)
934{
935 return scm_cons (scm_sym_begin, unmemoize_exprs (SCM_CDR (expr), env));
936}
937
0f2d19dd 938
3b88ed2a 939SCM_SYNTAX (s_case, "case", scm_i_makbimacro, scm_m_case);
8ea46249 940SCM_GLOBAL_SYMBOL (scm_sym_case, s_case);
6f81708a 941SCM_GLOBAL_SYMBOL (scm_sym_else, "else");
1cc91f1b 942
8ea46249 943SCM
2a6f7afe 944scm_m_case (SCM expr, SCM env)
0f2d19dd 945{
8ea46249 946 SCM clauses;
2a6f7afe
DH
947 SCM all_labels = SCM_EOL;
948
949 /* Check, whether 'else is a literal, i. e. not bound to a value. */
950 const int else_literal_p = literal_p (scm_sym_else, env);
951
952 const SCM cdr_expr = SCM_CDR (expr);
953 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
954 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_clauses, expr);
955
956 clauses = SCM_CDR (cdr_expr);
8ea46249 957 while (!SCM_NULLP (clauses))
0f2d19dd 958 {
2a6f7afe
DH
959 SCM labels;
960
961 const SCM clause = SCM_CAR (clauses);
962 ASSERT_SYNTAX_2 (scm_ilength (clause) >= 2,
963 s_bad_case_clause, clause, expr);
964
965 labels = SCM_CAR (clause);
966 if (SCM_CONSP (labels))
967 {
968 ASSERT_SYNTAX_2 (scm_ilength (labels) >= 0,
969 s_bad_case_labels, labels, expr);
26ecfa39 970 all_labels = scm_append (scm_list_2 (labels, all_labels));
2a6f7afe 971 }
58a2510b
DH
972 else if (SCM_NULLP (labels))
973 {
974 /* The list of labels is empty. According to R5RS this is allowed.
975 * It means that the sequence of expressions will never be executed.
976 * Therefore, as an optimization, we could remove the whole
977 * clause. */
978 }
2a6f7afe
DH
979 else
980 {
981 ASSERT_SYNTAX_2 (SCM_EQ_P (labels, scm_sym_else) && else_literal_p,
982 s_bad_case_labels, labels, expr);
983 ASSERT_SYNTAX_2 (SCM_NULLP (SCM_CDR (clauses)),
609a8b86 984 s_misplaced_else_clause, clause, expr);
2a6f7afe
DH
985 }
986
987 /* build the new clause */
988 if (SCM_EQ_P (labels, scm_sym_else))
989 SCM_SETCAR (clause, SCM_IM_ELSE);
990
8ea46249 991 clauses = SCM_CDR (clauses);
0f2d19dd 992 }
2a6f7afe
DH
993
994 /* Check whether all case labels are distinct. */
995 for (; !SCM_NULLP (all_labels); all_labels = SCM_CDR (all_labels))
996 {
997 const SCM label = SCM_CAR (all_labels);
7888309b 998 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (label, SCM_CDR (all_labels))),
4610b011 999 s_duplicate_case_label, label, expr);
2a6f7afe
DH
1000 }
1001
1002 SCM_SETCAR (expr, SCM_IM_CASE);
1003 return expr;
0f2d19dd
JB
1004}
1005
212e58ed
DH
1006static SCM
1007unmemoize_case (const SCM expr, const SCM env)
1008{
1009 const SCM um_key_expr = unmemoize_expression (SCM_CADR (expr), env);
1010 SCM um_clauses = SCM_EOL;
1011 SCM clause_idx;
1012
1013 for (clause_idx = SCM_CDDR (expr);
1014 !SCM_NULLP (clause_idx);
1015 clause_idx = SCM_CDR (clause_idx))
1016 {
1017 const SCM clause = SCM_CAR (clause_idx);
1018 const SCM labels = SCM_CAR (clause);
1019 const SCM exprs = SCM_CDR (clause);
1020
1021 const SCM um_exprs = unmemoize_exprs (exprs, env);
1022 const SCM um_labels = (SCM_EQ_P (labels, SCM_IM_ELSE))
1023 ? scm_sym_else
1024 : scm_i_finite_list_copy (labels);
1025 const SCM um_clause = scm_cons (um_labels, um_exprs);
1026
1027 um_clauses = scm_cons (um_clause, um_clauses);
1028 }
1029 um_clauses = scm_reverse_x (um_clauses, SCM_UNDEFINED);
1030
1031 return scm_cons2 (scm_sym_case, um_key_expr, um_clauses);
1032}
1033
0f2d19dd 1034
3b88ed2a 1035SCM_SYNTAX (s_cond, "cond", scm_i_makbimacro, scm_m_cond);
8ea46249 1036SCM_GLOBAL_SYMBOL (scm_sym_cond, s_cond);
609a8b86 1037SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>");
1cc91f1b 1038
8ea46249 1039SCM
609a8b86 1040scm_m_cond (SCM expr, SCM env)
0f2d19dd 1041{
609a8b86
DH
1042 /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
1043 const int else_literal_p = literal_p (scm_sym_else, env);
1044 const int arrow_literal_p = literal_p (scm_sym_arrow, env);
1045
1046 const SCM clauses = SCM_CDR (expr);
1047 SCM clause_idx;
1048
1049 ASSERT_SYNTAX (scm_ilength (clauses) >= 0, s_bad_expression, expr);
1050 ASSERT_SYNTAX (scm_ilength (clauses) >= 1, s_missing_clauses, expr);
1051
1052 for (clause_idx = clauses;
1053 !SCM_NULLP (clause_idx);
1054 clause_idx = SCM_CDR (clause_idx))
0f2d19dd 1055 {
609a8b86
DH
1056 SCM test;
1057
1058 const SCM clause = SCM_CAR (clause_idx);
1059 const long length = scm_ilength (clause);
1060 ASSERT_SYNTAX_2 (length >= 1, s_bad_cond_clause, clause, expr);
1061
1062 test = SCM_CAR (clause);
1063 if (SCM_EQ_P (test, scm_sym_else) && else_literal_p)
0f2d19dd 1064 {
609a8b86
DH
1065 const int last_clause_p = SCM_NULLP (SCM_CDR (clause_idx));
1066 ASSERT_SYNTAX_2 (length >= 2,
1067 s_bad_cond_clause, clause, expr);
1068 ASSERT_SYNTAX_2 (last_clause_p,
1069 s_misplaced_else_clause, clause, expr);
1070 SCM_SETCAR (clause, SCM_IM_ELSE);
0f2d19dd 1071 }
609a8b86
DH
1072 else if (length >= 2
1073 && SCM_EQ_P (SCM_CADR (clause), scm_sym_arrow)
1074 && arrow_literal_p)
1075 {
1076 ASSERT_SYNTAX_2 (length > 2, s_missing_recipient, clause, expr);
1077 ASSERT_SYNTAX_2 (length == 3, s_extra_expression, clause, expr);
1078 SCM_SETCAR (SCM_CDR (clause), SCM_IM_ARROW);
8ea46249 1079 }
0f2d19dd 1080 }
609a8b86
DH
1081
1082 SCM_SETCAR (expr, SCM_IM_COND);
1083 return expr;
0f2d19dd
JB
1084}
1085
212e58ed
DH
1086static SCM
1087unmemoize_cond (const SCM expr, const SCM env)
1088{
1089 SCM um_clauses = SCM_EOL;
1090 SCM clause_idx;
1091
1092 for (clause_idx = SCM_CDR (expr);
1093 !SCM_NULLP (clause_idx);
1094 clause_idx = SCM_CDR (clause_idx))
1095 {
1096 const SCM clause = SCM_CAR (clause_idx);
1097 const SCM sequence = SCM_CDR (clause);
1098 const SCM test = SCM_CAR (clause);
1099 SCM um_test;
1100 SCM um_sequence;
1101 SCM um_clause;
1102
1103 if (SCM_EQ_P (test, SCM_IM_ELSE))
1104 um_test = scm_sym_else;
1105 else
1106 um_test = unmemoize_expression (test, env);
1107
1108 if (!SCM_NULLP (sequence) && SCM_EQ_P (SCM_CAR (sequence), SCM_IM_ARROW))
1109 {
1110 const SCM target = SCM_CADR (sequence);
1111 const SCM um_target = unmemoize_expression (target, env);
1112 um_sequence = scm_list_2 (scm_sym_arrow, um_target);
1113 }
1114 else
1115 {
1116 um_sequence = unmemoize_exprs (sequence, env);
1117 }
1118
1119 um_clause = scm_cons (um_test, um_sequence);
1120 um_clauses = scm_cons (um_clause, um_clauses);
1121 }
1122 um_clauses = scm_reverse_x (um_clauses, SCM_UNDEFINED);
1123
1124 return scm_cons (scm_sym_cond, um_clauses);
1125}
1126
1cc91f1b 1127
0f572ba7
DH
1128SCM_SYNTAX (s_define, "define", scm_i_makbimacro, scm_m_define);
1129SCM_GLOBAL_SYMBOL (scm_sym_define, s_define);
5280aaca 1130
9fbee57e
DH
1131/* Guile provides an extension to R5RS' define syntax to represent function
1132 * currying in a compact way. With this extension, it is allowed to write
1133 * (define <nested-variable> <body>), where <nested-variable> has of one of
1134 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
1135 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
1136 * should be either a sequence of zero or more variables, or a sequence of one
1137 * or more variables followed by a space-delimited period and another
1138 * variable. Each level of argument nesting wraps the <body> within another
1139 * lambda expression. For example, the following forms are allowed, each one
1140 * followed by an equivalent, more explicit implementation.
1141 * Example 1:
1142 * (define ((a b . c) . d) <body>) is equivalent to
1143 * (define a (lambda (b . c) (lambda d <body>)))
1144 * Example 2:
1145 * (define (((a) b) c . d) <body>) is equivalent to
1146 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
1147 */
1148/* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
1149 * module that does not implement this extension. */
0f572ba7
DH
1150static SCM
1151canonicalize_define (const SCM expr)
5280aaca 1152{
cc56ba80
DH
1153 SCM body;
1154 SCM variable;
1155
1156 const SCM cdr_expr = SCM_CDR (expr);
c86c440b 1157 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
cc56ba80
DH
1158 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
1159
1160 body = SCM_CDR (cdr_expr);
1161 variable = SCM_CAR (cdr_expr);
1162 while (SCM_CONSP (variable))
5280aaca 1163 {
cc56ba80
DH
1164 /* This while loop realizes function currying by variable nesting.
1165 * Variable is known to be a nested-variable. In every iteration of the
1166 * loop another level of lambda expression is created, starting with the
4610b011
DH
1167 * innermost one. Note that we don't check for duplicate formals here:
1168 * This will be done by the memoizer of the lambda expression. */
cc56ba80
DH
1169 const SCM formals = SCM_CDR (variable);
1170 const SCM tail = scm_cons (formals, body);
1171
1172 /* Add source properties to each new lambda expression: */
1173 const SCM lambda = scm_cons_source (variable, scm_sym_lambda, tail);
1174
1175 body = scm_list_1 (lambda);
1176 variable = SCM_CAR (variable);
5280aaca 1177 }
cc56ba80
DH
1178 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable), s_bad_variable, variable, expr);
1179 ASSERT_SYNTAX (scm_ilength (body) == 1, s_expression, expr);
1180
0f572ba7
DH
1181 SCM_SETCAR (cdr_expr, variable);
1182 SCM_SETCDR (cdr_expr, body);
1183 return expr;
1184}
1185
36245b66
DH
1186/* According to section 5.2.1 of R5RS we first have to make sure that the
1187 * variable is bound, and then perform the (set! variable expression)
1188 * operation. This means, that within the expression we may already assign
1189 * values to variable: (define foo (begin (set! foo 1) (+ foo 1))) */
0f572ba7
DH
1190SCM
1191scm_m_define (SCM expr, SCM env)
1192{
6bff1368 1193 ASSERT_SYNTAX (SCM_TOP_LEVEL (env), s_bad_define, expr);
0f572ba7 1194
6bff1368
DH
1195 {
1196 const SCM canonical_definition = canonicalize_define (expr);
1197 const SCM cdr_canonical_definition = SCM_CDR (canonical_definition);
1198 const SCM variable = SCM_CAR (cdr_canonical_definition);
36245b66
DH
1199 const SCM location
1200 = scm_sym2var (variable, scm_env_top_level (env), SCM_BOOL_T);
1201 const SCM value = scm_eval_car (SCM_CDR (cdr_canonical_definition), env);
6bff1368 1202
6bff1368
DH
1203 if (SCM_REC_PROCNAMES_P)
1204 {
1205 SCM tmp = value;
1206 while (SCM_MACROP (tmp))
1207 tmp = SCM_MACRO_CODE (tmp);
1208 if (SCM_CLOSUREP (tmp)
1209 /* Only the first definition determines the name. */
7888309b 1210 && scm_is_false (scm_procedure_property (tmp, scm_sym_name)))
6bff1368
DH
1211 scm_set_procedure_property_x (tmp, scm_sym_name, variable);
1212 }
0f572ba7 1213
36245b66 1214 SCM_VARIABLE_SET (location, value);
6bff1368
DH
1215
1216 return SCM_UNSPECIFIED;
1217 }
0f2d19dd
JB
1218}
1219
1220
8ae95199
DH
1221/* This is a helper function for forms (<keyword> <expression>) that are
1222 * transformed into (#@<keyword> '() <memoized_expression>) in order to allow
1223 * for easy creation of a thunk (i. e. a closure without arguments) using the
1224 * ('() <memoized_expression>) tail of the memoized form. */
1225static SCM
1226memoize_as_thunk_prototype (const SCM expr, const SCM env SCM_UNUSED)
1227{
1228 const SCM cdr_expr = SCM_CDR (expr);
1229 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
1230 ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
1231
1232 SCM_SETCDR (expr, scm_cons (SCM_EOL, cdr_expr));
1233
1234 return expr;
1235}
1236
1237
3b88ed2a 1238SCM_SYNTAX (s_delay, "delay", scm_i_makbimacro, scm_m_delay);
9fbee57e 1239SCM_GLOBAL_SYMBOL (scm_sym_delay, s_delay);
1cc91f1b 1240
9fbee57e
DH
1241/* Promises are implemented as closures with an empty parameter list. Thus,
1242 * (delay <expression>) is transformed into (#@delay '() <expression>), where
1243 * the empty list represents the empty parameter list. This representation
1244 * allows for easy creation of the closure during evaluation. */
8ea46249 1245SCM
8ae95199 1246scm_m_delay (SCM expr, SCM env)
0f2d19dd 1247{
8ae95199
DH
1248 const SCM new_expr = memoize_as_thunk_prototype (expr, env);
1249 SCM_SETCAR (new_expr, SCM_IM_DELAY);
1250 return new_expr;
0f2d19dd
JB
1251}
1252
212e58ed
DH
1253static SCM
1254unmemoize_delay (const SCM expr, const SCM env)
1255{
1256 const SCM thunk_expr = SCM_CADDR (expr);
1257 return scm_list_2 (scm_sym_delay, unmemoize_expression (thunk_expr, env));
1258}
1259
8ea46249 1260
a954ce1d
DH
1261SCM_SYNTAX(s_do, "do", scm_i_makbimacro, scm_m_do);
1262SCM_GLOBAL_SYMBOL(scm_sym_do, s_do);
1263
302c12b4 1264/* DO gets the most radically altered syntax. The order of the vars is
4610b011
DH
1265 * reversed here. During the evaluation this allows for simple consing of the
1266 * results of the inits and steps:
302c12b4 1267
0f2d19dd 1268 (do ((<var1> <init1> <step1>)
a954ce1d
DH
1269 (<var2> <init2>)
1270 ... )
1271 (<test> <return>)
1272 <body>)
302c12b4 1273
0f2d19dd 1274 ;; becomes
302c12b4 1275
e681d187 1276 (#@do (<init1> <init2> ... <initn>)
a954ce1d
DH
1277 (varn ... var2 var1)
1278 (<test> <return>)
1279 (<body>)
1280 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
302c12b4 1281 */
0f2d19dd 1282SCM
a954ce1d 1283scm_m_do (SCM expr, SCM env SCM_UNUSED)
0f2d19dd 1284{
a954ce1d
DH
1285 SCM variables = SCM_EOL;
1286 SCM init_forms = SCM_EOL;
1287 SCM step_forms = SCM_EOL;
1288 SCM binding_idx;
1289 SCM cddr_expr;
1290 SCM exit_clause;
1291 SCM commands;
1292 SCM tail;
1293
1294 const SCM cdr_expr = SCM_CDR (expr);
1295 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
1296 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
1297
1298 /* Collect variables, init and step forms. */
1299 binding_idx = SCM_CAR (cdr_expr);
1300 ASSERT_SYNTAX_2 (scm_ilength (binding_idx) >= 0,
1301 s_bad_bindings, binding_idx, expr);
1302 for (; !SCM_NULLP (binding_idx); binding_idx = SCM_CDR (binding_idx))
0f2d19dd 1303 {
a954ce1d
DH
1304 const SCM binding = SCM_CAR (binding_idx);
1305 const long length = scm_ilength (binding);
1306 ASSERT_SYNTAX_2 (length == 2 || length == 3,
1307 s_bad_binding, binding, expr);
1308
302c12b4 1309 {
a954ce1d
DH
1310 const SCM name = SCM_CAR (binding);
1311 const SCM init = SCM_CADR (binding);
1312 const SCM step = (length == 2) ? name : SCM_CADDR (binding);
1313 ASSERT_SYNTAX_2 (SCM_SYMBOLP (name), s_bad_variable, name, expr);
7888309b 1314 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name, variables)),
4610b011
DH
1315 s_duplicate_binding, name, expr);
1316
a954ce1d
DH
1317 variables = scm_cons (name, variables);
1318 init_forms = scm_cons (init, init_forms);
1319 step_forms = scm_cons (step, step_forms);
302c12b4 1320 }
0f2d19dd 1321 }
a954ce1d
DH
1322 init_forms = scm_reverse_x (init_forms, SCM_UNDEFINED);
1323 step_forms = scm_reverse_x (step_forms, SCM_UNDEFINED);
1324
1325 /* Memoize the test form and the exit sequence. */
1326 cddr_expr = SCM_CDR (cdr_expr);
1327 exit_clause = SCM_CAR (cddr_expr);
1328 ASSERT_SYNTAX_2 (scm_ilength (exit_clause) >= 1,
1329 s_bad_exit_clause, exit_clause, expr);
1330
1331 commands = SCM_CDR (cddr_expr);
1332 tail = scm_cons2 (exit_clause, commands, step_forms);
1333 tail = scm_cons2 (init_forms, variables, tail);
1334 SCM_SETCAR (expr, SCM_IM_DO);
1335 SCM_SETCDR (expr, tail);
1336 return expr;
0f2d19dd
JB
1337}
1338
212e58ed
DH
1339static SCM
1340unmemoize_do (const SCM expr, const SCM env)
1341{
1342 const SCM cdr_expr = SCM_CDR (expr);
1343 const SCM cddr_expr = SCM_CDR (cdr_expr);
1344 const SCM rnames = SCM_CAR (cddr_expr);
1345 const SCM extended_env = SCM_EXTEND_ENV (rnames, SCM_EOL, env);
1346 const SCM cdddr_expr = SCM_CDR (cddr_expr);
1347 const SCM exit_sequence = SCM_CAR (cdddr_expr);
1348 const SCM um_exit_sequence = unmemoize_exprs (exit_sequence, extended_env);
1349 const SCM cddddr_expr = SCM_CDR (cdddr_expr);
1350 const SCM um_body = unmemoize_exprs (SCM_CAR (cddddr_expr), extended_env);
1351
1352 /* build transformed binding list */
1353 SCM um_names = scm_reverse (rnames);
1354 SCM um_inits = unmemoize_exprs (SCM_CAR (cdr_expr), env);
1355 SCM um_steps = unmemoize_exprs (SCM_CDR (cddddr_expr), extended_env);
1356 SCM um_bindings = SCM_EOL;
1357 while (!SCM_NULLP (um_names))
1358 {
1359 const SCM name = SCM_CAR (um_names);
1360 const SCM init = SCM_CAR (um_inits);
1361 SCM step = SCM_CAR (um_steps);
1362 step = SCM_EQ_P (step, name) ? SCM_EOL : scm_list_1 (step);
1363
1364 um_bindings = scm_cons (scm_cons2 (name, init, step), um_bindings);
1365
1366 um_names = SCM_CDR (um_names);
1367 um_inits = SCM_CDR (um_inits);
1368 um_steps = SCM_CDR (um_steps);
1369 }
1370 um_bindings = scm_reverse_x (um_bindings, SCM_UNDEFINED);
1371
1372 return scm_cons (scm_sym_do,
1373 scm_cons2 (um_bindings, um_exit_sequence, um_body));
1374}
1375
b8229a3b 1376
3b88ed2a 1377SCM_SYNTAX (s_if, "if", scm_i_makbimacro, scm_m_if);
9fbee57e 1378SCM_GLOBAL_SYMBOL (scm_sym_if, s_if);
b8229a3b 1379
9fbee57e 1380SCM
4610b011 1381scm_m_if (SCM expr, SCM env SCM_UNUSED)
0f2d19dd 1382{
4610b011
DH
1383 const SCM cdr_expr = SCM_CDR (expr);
1384 const long length = scm_ilength (cdr_expr);
1385 ASSERT_SYNTAX (length == 2 || length == 3, s_expression, expr);
1386 SCM_SETCAR (expr, SCM_IM_IF);
1387 return expr;
0f2d19dd
JB
1388}
1389
212e58ed
DH
1390static SCM
1391unmemoize_if (const SCM expr, const SCM env)
1392{
1393 const SCM cdr_expr = SCM_CDR (expr);
1394 const SCM um_condition = unmemoize_expression (SCM_CAR (cdr_expr), env);
1395 const SCM cddr_expr = SCM_CDR (cdr_expr);
1396 const SCM um_then = unmemoize_expression (SCM_CAR (cddr_expr), env);
1397 const SCM cdddr_expr = SCM_CDR (cddr_expr);
1398
1399 if (SCM_NULLP (cdddr_expr))
1400 {
1401 return scm_list_3 (scm_sym_if, um_condition, um_then);
1402 }
1403 else
1404 {
1405 const SCM um_else = unmemoize_expression (SCM_CAR (cdddr_expr), env);
1406 return scm_list_4 (scm_sym_if, um_condition, um_then, um_else);
1407 }
1408}
1409
302c12b4 1410
3b88ed2a 1411SCM_SYNTAX (s_lambda, "lambda", scm_i_makbimacro, scm_m_lambda);
9fbee57e 1412SCM_GLOBAL_SYMBOL (scm_sym_lambda, s_lambda);
0f2d19dd 1413
4610b011
DH
1414/* A helper function for memoize_lambda to support checking for duplicate
1415 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
1416 * LIST or to the cdr of the last cons. Therefore, LIST may have any of the
1417 * forms that a formal argument can have:
1418 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
9fbee57e 1419static int
4610b011 1420c_improper_memq (SCM obj, SCM list)
5cb22e96 1421{
9fbee57e
DH
1422 for (; SCM_CONSP (list); list = SCM_CDR (list))
1423 {
1424 if (SCM_EQ_P (SCM_CAR (list), obj))
4610b011 1425 return 1;
9fbee57e
DH
1426 }
1427 return SCM_EQ_P (list, obj);
5cb22e96
DH
1428}
1429
28d52ebb 1430SCM
03a3e941 1431scm_m_lambda (SCM expr, SCM env SCM_UNUSED)
28d52ebb 1432{
9fbee57e 1433 SCM formals;
03a3e941 1434 SCM formals_idx;
34adf7ea
DH
1435 SCM cddr_expr;
1436 int documentation;
1437 SCM body;
1438 SCM new_body;
03a3e941
DH
1439
1440 const SCM cdr_expr = SCM_CDR (expr);
1441 const long length = scm_ilength (cdr_expr);
1442 ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
1443 ASSERT_SYNTAX (length >= 2, s_missing_expression, expr);
28d52ebb 1444
03a3e941
DH
1445 /* Before iterating the list of formal arguments, make sure the formals
1446 * actually are given as either a symbol or a non-cyclic list. */
1447 formals = SCM_CAR (cdr_expr);
1448 if (SCM_CONSP (formals))
1449 {
1450 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
1451 * detected, report a 'Bad formals' error. */
1452 }
1453 else
1454 {
1455 ASSERT_SYNTAX_2 (SCM_SYMBOLP (formals) || SCM_NULLP (formals),
1456 s_bad_formals, formals, expr);
1457 }
1cc91f1b 1458
03a3e941
DH
1459 /* Now iterate the list of formal arguments to check if all formals are
1460 * symbols, and that there are no duplicates. */
1461 formals_idx = formals;
1462 while (SCM_CONSP (formals_idx))
0f2d19dd 1463 {
03a3e941
DH
1464 const SCM formal = SCM_CAR (formals_idx);
1465 const SCM next_idx = SCM_CDR (formals_idx);
1466 ASSERT_SYNTAX_2 (SCM_SYMBOLP (formal), s_bad_formal, formal, expr);
1467 ASSERT_SYNTAX_2 (!c_improper_memq (formal, next_idx),
1468 s_duplicate_formal, formal, expr);
1469 formals_idx = next_idx;
0f2d19dd 1470 }
03a3e941
DH
1471 ASSERT_SYNTAX_2 (SCM_NULLP (formals_idx) || SCM_SYMBOLP (formals_idx),
1472 s_bad_formal, formals_idx, expr);
9fbee57e 1473
34adf7ea
DH
1474 /* Memoize the body. Keep a potential documentation string. */
1475 /* Dirk:FIXME:: We should probably extract the documentation string to
1476 * some external database. Otherwise it will slow down execution, since
1477 * the documentation string will have to be skipped with every execution
1478 * of the closure. */
1479 cddr_expr = SCM_CDR (cdr_expr);
1480 documentation = (length >= 3 && SCM_STRINGP (SCM_CAR (cddr_expr)));
1481 body = documentation ? SCM_CDR (cddr_expr) : cddr_expr;
430b8401 1482 new_body = m_body (SCM_IM_LAMBDA, body);
34adf7ea
DH
1483
1484 SCM_SETCAR (expr, SCM_IM_LAMBDA);
1485 if (documentation)
1486 SCM_SETCDR (cddr_expr, new_body);
1487 else
1488 SCM_SETCDR (cdr_expr, new_body);
1489 return expr;
0f2d19dd 1490}
6dbd0af5 1491
212e58ed
DH
1492static SCM
1493unmemoize_lambda (const SCM expr, const SCM env)
1494{
1495 const SCM formals = SCM_CADR (expr);
1496 const SCM body = SCM_CDDR (expr);
1497
1498 const SCM new_env = SCM_EXTEND_ENV (formals, SCM_EOL, env);
1499 const SCM um_formals = scm_i_finite_list_copy (formals);
1500 const SCM um_body = unmemoize_exprs (body, new_env);
1501
1502 return scm_cons2 (scm_sym_lambda, um_formals, um_body);
1503}
1504
0f2d19dd 1505
d6754c23 1506/* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
302c12b4 1507static void
d6754c23 1508check_bindings (const SCM bindings, const SCM expr)
0f2d19dd 1509{
d6754c23 1510 SCM binding_idx;
302c12b4 1511
d6754c23
DH
1512 ASSERT_SYNTAX_2 (scm_ilength (bindings) >= 0,
1513 s_bad_bindings, bindings, expr);
0f2d19dd 1514
d6754c23
DH
1515 binding_idx = bindings;
1516 for (; !SCM_NULLP (binding_idx); binding_idx = SCM_CDR (binding_idx))
0f2d19dd 1517 {
d6754c23
DH
1518 SCM name; /* const */
1519
1520 const SCM binding = SCM_CAR (binding_idx);
1521 ASSERT_SYNTAX_2 (scm_ilength (binding) == 2,
1522 s_bad_binding, binding, expr);
1523
1524 name = SCM_CAR (binding);
1525 ASSERT_SYNTAX_2 (SCM_SYMBOLP (name), s_bad_variable, name, expr);
0f2d19dd 1526 }
d6754c23 1527}
26d5b9b4 1528
d6754c23
DH
1529
1530/* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
1531 * transformed to the lists (vn ... v2 v1) and (i1 i2 ... in). That is, the
1532 * variables are returned in a list with their order reversed, and the init
1533 * forms are returned in a list in the same order as they are given in the
1534 * bindings. If a duplicate variable name is detected, an error is
1535 * signalled. */
1536static void
1537transform_bindings (
1538 const SCM bindings, const SCM expr,
1539 SCM *const rvarptr, SCM *const initptr )
1540{
1541 SCM rvariables = SCM_EOL;
1542 SCM rinits = SCM_EOL;
1543 SCM binding_idx = bindings;
1544 for (; !SCM_NULLP (binding_idx); binding_idx = SCM_CDR (binding_idx))
1545 {
1546 const SCM binding = SCM_CAR (binding_idx);
1547 const SCM cdr_binding = SCM_CDR (binding);
1548 const SCM name = SCM_CAR (binding);
7888309b 1549 ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name, rvariables)),
d6754c23
DH
1550 s_duplicate_binding, name, expr);
1551 rvariables = scm_cons (name, rvariables);
1552 rinits = scm_cons (SCM_CAR (cdr_binding), rinits);
1553 }
1554 *rvarptr = rvariables;
1555 *initptr = scm_reverse_x (rinits, SCM_UNDEFINED);
0f2d19dd
JB
1556}
1557
302c12b4 1558
3b88ed2a 1559SCM_SYNTAX(s_let, "let", scm_i_makbimacro, scm_m_let);
2f0d1375 1560SCM_GLOBAL_SYMBOL(scm_sym_let, s_let);
b8229a3b 1561
d6754c23
DH
1562/* This function is a helper function for memoize_let. It transforms
1563 * (let name ((var init) ...) body ...) into
1564 * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
1565 * and memoizes the expression. It is assumed that the caller has checked
1566 * that name is a symbol and that there are bindings and a body. */
1567static SCM
1568memoize_named_let (const SCM expr, const SCM env SCM_UNUSED)
1569{
1570 SCM rvariables;
1571 SCM variables;
1572 SCM inits;
1573
1574 const SCM cdr_expr = SCM_CDR (expr);
1575 const SCM name = SCM_CAR (cdr_expr);
1576 const SCM cddr_expr = SCM_CDR (cdr_expr);
1577 const SCM bindings = SCM_CAR (cddr_expr);
1578 check_bindings (bindings, expr);
1579
1580 transform_bindings (bindings, expr, &rvariables, &inits);
1581 variables = scm_reverse_x (rvariables, SCM_UNDEFINED);
1582
1583 {
1584 const SCM let_body = SCM_CDR (cddr_expr);
430b8401 1585 const SCM lambda_body = m_body (SCM_IM_LET, let_body);
d6754c23
DH
1586 const SCM lambda_tail = scm_cons (variables, lambda_body);
1587 const SCM lambda_form = scm_cons_source (expr, scm_sym_lambda, lambda_tail);
1588
1589 const SCM rvar = scm_list_1 (name);
1590 const SCM init = scm_list_1 (lambda_form);
430b8401 1591 const SCM body = m_body (SCM_IM_LET, scm_list_1 (name));
d6754c23
DH
1592 const SCM letrec_tail = scm_cons (rvar, scm_cons (init, body));
1593 const SCM letrec_form = scm_cons_source (expr, SCM_IM_LETREC, letrec_tail);
1594 return scm_cons_source (expr, letrec_form, inits);
1595 }
1596}
1597
1598/* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1599 * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
302c12b4 1600SCM
d6754c23 1601scm_m_let (SCM expr, SCM env)
0f2d19dd 1602{
d6754c23
DH
1603 SCM bindings;
1604
1605 const SCM cdr_expr = SCM_CDR (expr);
1606 const long length = scm_ilength (cdr_expr);
1607 ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
1608 ASSERT_SYNTAX (length >= 2, s_missing_expression, expr);
302c12b4 1609
d6754c23
DH
1610 bindings = SCM_CAR (cdr_expr);
1611 if (SCM_SYMBOLP (bindings))
26d5b9b4 1612 {
d6754c23
DH
1613 ASSERT_SYNTAX (length >= 3, s_missing_expression, expr);
1614 return memoize_named_let (expr, env);
26d5b9b4 1615 }
d6754c23
DH
1616
1617 check_bindings (bindings, expr);
1618 if (SCM_NULLP (bindings) || SCM_NULLP (SCM_CDR (bindings)))
26d5b9b4 1619 {
d6754c23 1620 /* Special case: no bindings or single binding => let* is faster. */
430b8401 1621 const SCM body = m_body (SCM_IM_LET, SCM_CDR (cdr_expr));
d6754c23 1622 return scm_m_letstar (scm_cons2 (SCM_CAR (expr), bindings, body), env);
26d5b9b4 1623 }
302c12b4
DH
1624 else
1625 {
d6754c23
DH
1626 /* plain let */
1627 SCM rvariables;
1628 SCM inits;
1629 transform_bindings (bindings, expr, &rvariables, &inits);
26d5b9b4 1630
302c12b4 1631 {
430b8401 1632 const SCM new_body = m_body (SCM_IM_LET, SCM_CDR (cdr_expr));
d6754c23
DH
1633 const SCM new_tail = scm_cons2 (rvariables, inits, new_body);
1634 SCM_SETCAR (expr, SCM_IM_LET);
1635 SCM_SETCDR (expr, new_tail);
1636 return expr;
302c12b4
DH
1637 }
1638 }
0f2d19dd
JB
1639}
1640
212e58ed
DH
1641static SCM
1642build_binding_list (SCM rnames, SCM rinits)
1643{
1644 SCM bindings = SCM_EOL;
1645 while (!SCM_NULLP (rnames))
1646 {
1647 const SCM binding = scm_list_2 (SCM_CAR (rnames), SCM_CAR (rinits));
1648 bindings = scm_cons (binding, bindings);
1649 rnames = SCM_CDR (rnames);
1650 rinits = SCM_CDR (rinits);
1651 }
1652 return bindings;
1653}
1654
1655static SCM
1656unmemoize_let (const SCM expr, const SCM env)
1657{
1658 const SCM cdr_expr = SCM_CDR (expr);
1659 const SCM um_rnames = SCM_CAR (cdr_expr);
1660 const SCM extended_env = SCM_EXTEND_ENV (um_rnames, SCM_EOL, env);
1661 const SCM cddr_expr = SCM_CDR (cdr_expr);
1662 const SCM um_inits = unmemoize_exprs (SCM_CAR (cddr_expr), env);
1663 const SCM um_rinits = scm_reverse_x (um_inits, SCM_UNDEFINED);
1664 const SCM um_bindings = build_binding_list (um_rnames, um_rinits);
1665 const SCM um_body = unmemoize_exprs (SCM_CDR (cddr_expr), extended_env);
1666
1667 return scm_cons2 (scm_sym_let, um_bindings, um_body);
1668}
1669
1670
1671SCM_SYNTAX(s_letrec, "letrec", scm_i_makbimacro, scm_m_letrec);
1672SCM_GLOBAL_SYMBOL(scm_sym_letrec, s_letrec);
1673
1674SCM
1675scm_m_letrec (SCM expr, SCM env)
1676{
1677 SCM bindings;
1678
1679 const SCM cdr_expr = SCM_CDR (expr);
1680 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
1681 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
1682
1683 bindings = SCM_CAR (cdr_expr);
1684 if (SCM_NULLP (bindings))
1685 {
1686 /* no bindings, let* is executed faster */
1687 SCM body = m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr));
1688 return scm_m_letstar (scm_cons2 (SCM_CAR (expr), SCM_EOL, body), env);
1689 }
1690 else
1691 {
1692 SCM rvariables;
1693 SCM inits;
1694 SCM new_body;
1695
1696 check_bindings (bindings, expr);
1697 transform_bindings (bindings, expr, &rvariables, &inits);
1698 new_body = m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr));
1699 return scm_cons2 (SCM_IM_LETREC, rvariables, scm_cons (inits, new_body));
1700 }
1701}
1702
1703static SCM
1704unmemoize_letrec (const SCM expr, const SCM env)
1705{
1706 const SCM cdr_expr = SCM_CDR (expr);
1707 const SCM um_rnames = SCM_CAR (cdr_expr);
1708 const SCM extended_env = SCM_EXTEND_ENV (um_rnames, SCM_EOL, env);
1709 const SCM cddr_expr = SCM_CDR (cdr_expr);
1710 const SCM um_inits = unmemoize_exprs (SCM_CAR (cddr_expr), extended_env);
1711 const SCM um_rinits = scm_reverse_x (um_inits, SCM_UNDEFINED);
1712 const SCM um_bindings = build_binding_list (um_rnames, um_rinits);
1713 const SCM um_body = unmemoize_exprs (SCM_CDR (cddr_expr), extended_env);
1714
1715 return scm_cons2 (scm_sym_letrec, um_bindings, um_body);
1716}
1717
1718
0f2d19dd 1719
3b88ed2a 1720SCM_SYNTAX (s_letstar, "let*", scm_i_makbimacro, scm_m_letstar);
9fbee57e 1721SCM_GLOBAL_SYMBOL (scm_sym_letstar, s_letstar);
1cc91f1b 1722
d6754c23
DH
1723/* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1724 * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
9fbee57e 1725SCM
d6754c23 1726scm_m_letstar (SCM expr, SCM env SCM_UNUSED)
0f2d19dd 1727{
d6754c23 1728 SCM binding_idx;
d6754c23 1729 SCM new_body;
0f2d19dd 1730
d6754c23
DH
1731 const SCM cdr_expr = SCM_CDR (expr);
1732 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
1733 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
9fbee57e 1734
d6754c23
DH
1735 binding_idx = SCM_CAR (cdr_expr);
1736 check_bindings (binding_idx, expr);
1737
461bffb1
DH
1738 /* Transform ((v1 i1) (v2 i2) ...) into (v1 i1 v2 i2 ...). The
1739 * transformation is done in place. At the beginning of one iteration of
1740 * the loop the variable binding_idx holds the form
1741 * P1:( (vn . P2:(in . ())) . P3:( (vn+1 in+1) ... ) ),
1742 * where P1, P2 and P3 indicate the pairs, that are relevant for the
1743 * transformation. P1 and P2 are modified in the loop, P3 remains
1744 * untouched. After the execution of the loop, P1 will hold
1745 * P1:( vn . P2:(in . P3:( (vn+1 in+1) ... )) )
1746 * and binding_idx will hold P3. */
1747 while (!SCM_NULLP (binding_idx))
9fbee57e 1748 {
461bffb1 1749 const SCM cdr_binding_idx = SCM_CDR (binding_idx); /* remember P3 */
d6754c23
DH
1750 const SCM binding = SCM_CAR (binding_idx);
1751 const SCM name = SCM_CAR (binding);
461bffb1
DH
1752 const SCM cdr_binding = SCM_CDR (binding);
1753
1754 SCM_SETCDR (cdr_binding, cdr_binding_idx); /* update P2 */
1755 SCM_SETCAR (binding_idx, name); /* update P1 */
1756 SCM_SETCDR (binding_idx, cdr_binding); /* update P1 */
1757
1758 binding_idx = cdr_binding_idx; /* continue with P3 */
9fbee57e
DH
1759 }
1760
430b8401 1761 new_body = m_body (SCM_IM_LETSTAR, SCM_CDR (cdr_expr));
461bffb1
DH
1762 SCM_SETCAR (expr, SCM_IM_LETSTAR);
1763 /* the bindings have been changed in place */
1764 SCM_SETCDR (cdr_expr, new_body);
1765 return expr;
9fbee57e 1766}
b8229a3b 1767
212e58ed
DH
1768static SCM
1769unmemoize_letstar (const SCM expr, const SCM env)
0f2d19dd 1770{
d6754c23 1771 const SCM cdr_expr = SCM_CDR (expr);
212e58ed
DH
1772 const SCM body = SCM_CDR (cdr_expr);
1773 SCM bindings = SCM_CAR (cdr_expr);
1774 SCM um_bindings = SCM_EOL;
1775 SCM extended_env = env;
1776 SCM um_body;
d6754c23 1777
212e58ed 1778 while (!SCM_NULLP (bindings))
9fbee57e 1779 {
212e58ed
DH
1780 const SCM variable = SCM_CAR (bindings);
1781 const SCM init = SCM_CADR (bindings);
1782 const SCM um_init = unmemoize_expression (init, extended_env);
1783 um_bindings = scm_cons (scm_list_2 (variable, um_init), um_bindings);
1784 extended_env = SCM_EXTEND_ENV (variable, SCM_BOOL_F, extended_env);
1785 bindings = SCM_CDDR (bindings);
9fbee57e 1786 }
212e58ed 1787 um_bindings = scm_reverse_x (um_bindings, SCM_UNDEFINED);
d6754c23 1788
212e58ed
DH
1789 um_body = unmemoize_exprs (body, extended_env);
1790
1791 return scm_cons2 (scm_sym_letstar, um_bindings, um_body);
0f2d19dd
JB
1792}
1793
73b64342 1794
3b88ed2a 1795SCM_SYNTAX (s_or, "or", scm_i_makbimacro, scm_m_or);
9fbee57e 1796SCM_GLOBAL_SYMBOL (scm_sym_or, s_or);
73b64342
MD
1797
1798SCM
21628685 1799scm_m_or (SCM expr, SCM env SCM_UNUSED)
73b64342 1800{
21628685
DH
1801 const SCM cdr_expr = SCM_CDR (expr);
1802 const long length = scm_ilength (cdr_expr);
1803
1804 ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
1805
1806 if (length == 0)
1807 {
1808 /* Special case: (or) is replaced by #f. */
1809 return SCM_BOOL_F;
1810 }
9fbee57e 1811 else
21628685
DH
1812 {
1813 SCM_SETCAR (expr, SCM_IM_OR);
1814 return expr;
1815 }
73b64342
MD
1816}
1817
212e58ed
DH
1818static SCM
1819unmemoize_or (const SCM expr, const SCM env)
1820{
1821 return scm_cons (scm_sym_or, unmemoize_exprs (SCM_CDR (expr), env));
1822}
1823
73b64342 1824
9fbee57e
DH
1825SCM_SYNTAX (s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote);
1826SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, s_quasiquote);
6f81708a
DH
1827SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote");
1828SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing, "unquote-splicing");
9fbee57e
DH
1829
1830/* Internal function to handle a quasiquotation: 'form' is the parameter in
1831 * the call (quasiquotation form), 'env' is the environment where unquoted
1832 * expressions will be evaluated, and 'depth' is the current quasiquotation
1833 * nesting level and is known to be greater than zero. */
1834static SCM
1835iqq (SCM form, SCM env, unsigned long int depth)
73b64342 1836{
9fbee57e 1837 if (SCM_CONSP (form))
c96d76b8 1838 {
21628685 1839 const SCM tmp = SCM_CAR (form);
9fbee57e
DH
1840 if (SCM_EQ_P (tmp, scm_sym_quasiquote))
1841 {
21628685
DH
1842 const SCM args = SCM_CDR (form);
1843 ASSERT_SYNTAX (scm_ilength (args) == 1, s_expression, form);
9fbee57e
DH
1844 return scm_list_2 (tmp, iqq (SCM_CAR (args), env, depth + 1));
1845 }
1846 else if (SCM_EQ_P (tmp, scm_sym_unquote))
1847 {
21628685
DH
1848 const SCM args = SCM_CDR (form);
1849 ASSERT_SYNTAX (scm_ilength (args) == 1, s_expression, form);
9fbee57e
DH
1850 if (depth - 1 == 0)
1851 return scm_eval_car (args, env);
1852 else
1853 return scm_list_2 (tmp, iqq (SCM_CAR (args), env, depth - 1));
1854 }
1855 else if (SCM_CONSP (tmp)
1856 && SCM_EQ_P (SCM_CAR (tmp), scm_sym_uq_splicing))
1857 {
21628685
DH
1858 const SCM args = SCM_CDR (tmp);
1859 ASSERT_SYNTAX (scm_ilength (args) == 1, s_expression, form);
9fbee57e
DH
1860 if (depth - 1 == 0)
1861 {
21628685
DH
1862 const SCM list = scm_eval_car (args, env);
1863 const SCM rest = SCM_CDR (form);
1864 ASSERT_SYNTAX_2 (scm_ilength (list) >= 0,
1865 s_splicing, list, form);
9fbee57e
DH
1866 return scm_append (scm_list_2 (list, iqq (rest, env, depth)));
1867 }
1868 else
1869 return scm_cons (iqq (SCM_CAR (form), env, depth - 1),
1870 iqq (SCM_CDR (form), env, depth));
1871 }
1872 else
1873 return scm_cons (iqq (SCM_CAR (form), env, depth),
1874 iqq (SCM_CDR (form), env, depth));
1875 }
1876 else if (SCM_VECTORP (form))
c96d76b8 1877 {
9fbee57e
DH
1878 size_t i = SCM_VECTOR_LENGTH (form);
1879 SCM const *const data = SCM_VELTS (form);
1880 SCM tmp = SCM_EOL;
1881 while (i != 0)
1882 tmp = scm_cons (data[--i], tmp);
1883 scm_remember_upto_here_1 (form);
1884 return scm_vector (iqq (tmp, env, depth));
c96d76b8 1885 }
9fbee57e
DH
1886 else
1887 return form;
1888}
1889
1890SCM
21628685 1891scm_m_quasiquote (SCM expr, SCM env)
9fbee57e 1892{
21628685
DH
1893 const SCM cdr_expr = SCM_CDR (expr);
1894 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
1895 ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
1896 return iqq (SCM_CAR (cdr_expr), env, 1);
9fbee57e
DH
1897}
1898
1899
3b88ed2a 1900SCM_SYNTAX (s_quote, "quote", scm_i_makbimacro, scm_m_quote);
9fbee57e
DH
1901SCM_GLOBAL_SYMBOL (scm_sym_quote, s_quote);
1902
1903SCM
21628685 1904scm_m_quote (SCM expr, SCM env SCM_UNUSED)
9fbee57e 1905{
21628685
DH
1906 SCM quotee;
1907
1908 const SCM cdr_expr = SCM_CDR (expr);
1909 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
1910 ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
1911 quotee = SCM_CAR (cdr_expr);
5fb64383 1912 if (is_self_quoting_p (quotee))
21628685 1913 return quotee;
e7313a9d 1914
21628685 1915 SCM_SETCAR (expr, SCM_IM_QUOTE);
e7313a9d 1916 SCM_SETCDR (expr, quotee);
21628685 1917 return expr;
9fbee57e
DH
1918}
1919
e7313a9d
DH
1920static SCM
1921unmemoize_quote (const SCM expr, const SCM env SCM_UNUSED)
1922{
1923 return scm_list_2 (scm_sym_quote, SCM_CDR (expr));
1924}
1925
9fbee57e
DH
1926
1927/* Will go into the RnRS module when Guile is factorized.
3b88ed2a 1928SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
9fbee57e
DH
1929static const char s_set_x[] = "set!";
1930SCM_GLOBAL_SYMBOL (scm_sym_set_x, s_set_x);
1931
1932SCM
82b3e2c6 1933scm_m_set_x (SCM expr, SCM env SCM_UNUSED)
9fbee57e 1934{
82b3e2c6 1935 SCM variable;
36245b66 1936 SCM new_variable;
82b3e2c6
DH
1937
1938 const SCM cdr_expr = SCM_CDR (expr);
1939 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
1940 ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
1941 variable = SCM_CAR (cdr_expr);
36245b66
DH
1942
1943 /* Memoize the variable form. */
1944 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable), s_bad_variable, variable, expr);
1945 new_variable = lookup_symbol (variable, env);
36245b66
DH
1946 /* Leave the memoization of unbound symbols to lazy memoization: */
1947 if (SCM_UNBNDP (new_variable))
1948 new_variable = variable;
82b3e2c6
DH
1949
1950 SCM_SETCAR (expr, SCM_IM_SET_X);
36245b66 1951 SCM_SETCAR (cdr_expr, new_variable);
82b3e2c6 1952 return expr;
9fbee57e
DH
1953}
1954
212e58ed
DH
1955static SCM
1956unmemoize_set_x (const SCM expr, const SCM env)
1957{
1958 return scm_cons (scm_sym_set_x, unmemoize_exprs (SCM_CDR (expr), env));
1959}
1960
9fbee57e
DH
1961
1962/* Start of the memoizers for non-R5RS builtin macros. */
1963
1964
3b88ed2a 1965SCM_SYNTAX (s_atapply, "@apply", scm_i_makbimacro, scm_m_apply);
9fbee57e
DH
1966SCM_GLOBAL_SYMBOL (scm_sym_atapply, s_atapply);
1967SCM_GLOBAL_SYMBOL (scm_sym_apply, s_atapply + 1);
1968
1969SCM
82b3e2c6 1970scm_m_apply (SCM expr, SCM env SCM_UNUSED)
9fbee57e 1971{
82b3e2c6
DH
1972 const SCM cdr_expr = SCM_CDR (expr);
1973 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
1974 ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_missing_expression, expr);
2e171178 1975
82b3e2c6
DH
1976 SCM_SETCAR (expr, SCM_IM_APPLY);
1977 return expr;
1978}
2e171178 1979
212e58ed
DH
1980static SCM
1981unmemoize_apply (const SCM expr, const SCM env)
1982{
1983 return scm_list_2 (scm_sym_atapply, unmemoize_exprs (SCM_CDR (expr), env));
1984}
1985
2e171178 1986
3b88ed2a 1987SCM_SYNTAX (s_atbind, "@bind", scm_i_makbimacro, scm_m_atbind);
73b64342 1988
82b3e2c6
DH
1989/* FIXME: The following explanation should go into the documentation: */
1990/* (@bind ((var init) ...) body ...) will assign the values of the `init's to
1991 * the global variables named by `var's (symbols, not evaluated), creating
1992 * them if they don't exist, executes body, and then restores the previous
1993 * values of the `var's. Additionally, whenever control leaves body, the
1994 * values of the `var's are saved and restored when control returns. It is an
1995 * error when a symbol appears more than once among the `var's. All `init's
1996 * are evaluated before any `var' is set.
1997 *
1998 * Think of this as `let' for dynamic scope.
1999 */
2000
2001/* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into
2002 * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...).
2003 *
2004 * FIXME - also implement `@bind*'.
2005 */
73b64342 2006SCM
82b3e2c6 2007scm_m_atbind (SCM expr, SCM env)
73b64342 2008{
82b3e2c6
DH
2009 SCM bindings;
2010 SCM rvariables;
2011 SCM inits;
2012 SCM variable_idx;
2e171178 2013
82b3e2c6 2014 const SCM top_level = scm_env_top_level (env);
73b64342 2015
82b3e2c6
DH
2016 const SCM cdr_expr = SCM_CDR (expr);
2017 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
2018 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
2019 bindings = SCM_CAR (cdr_expr);
2020 check_bindings (bindings, expr);
2021 transform_bindings (bindings, expr, &rvariables, &inits);
2022
2023 for (variable_idx = rvariables;
2024 !SCM_NULLP (variable_idx);
2025 variable_idx = SCM_CDR (variable_idx))
73b64342 2026 {
82b3e2c6
DH
2027 /* The first call to scm_sym2var will look beyond the current module,
2028 * while the second call wont. */
2029 const SCM variable = SCM_CAR (variable_idx);
2030 SCM new_variable = scm_sym2var (variable, top_level, SCM_BOOL_F);
7888309b 2031 if (scm_is_false (new_variable))
82b3e2c6
DH
2032 new_variable = scm_sym2var (variable, top_level, SCM_BOOL_T);
2033 SCM_SETCAR (variable_idx, new_variable);
73b64342 2034 }
82b3e2c6
DH
2035
2036 SCM_SETCAR (expr, SCM_IM_BIND);
2037 SCM_SETCAR (cdr_expr, scm_cons (rvariables, inits));
2038 return expr;
73b64342 2039}
73b64342 2040
b0c5d67b 2041
3b88ed2a 2042SCM_SYNTAX(s_atcall_cc, "@call-with-current-continuation", scm_i_makbimacro, scm_m_cont);
9fbee57e
DH
2043SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc, s_atcall_cc);
2044
9fbee57e 2045SCM
da48db62 2046scm_m_cont (SCM expr, SCM env SCM_UNUSED)
b0c5d67b 2047{
da48db62
DH
2048 const SCM cdr_expr = SCM_CDR (expr);
2049 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
2050 ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
2051
2052 SCM_SETCAR (expr, SCM_IM_CONT);
2053 return expr;
b0c5d67b 2054}
b0c5d67b 2055
212e58ed
DH
2056static SCM
2057unmemoize_atcall_cc (const SCM expr, const SCM env)
2058{
2059 return scm_list_2 (scm_sym_atcall_cc, unmemoize_exprs (SCM_CDR (expr), env));
2060}
2061
b0c5d67b 2062
3b88ed2a 2063SCM_SYNTAX (s_at_call_with_values, "@call-with-values", scm_i_makbimacro, scm_m_at_call_with_values);
9fbee57e 2064SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values, s_at_call_with_values);
b0c5d67b
DH
2065
2066SCM
da48db62 2067scm_m_at_call_with_values (SCM expr, SCM env SCM_UNUSED)
b0c5d67b 2068{
da48db62
DH
2069 const SCM cdr_expr = SCM_CDR (expr);
2070 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
2071 ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
2072
2073 SCM_SETCAR (expr, SCM_IM_CALL_WITH_VALUES);
2074 return expr;
b0c5d67b 2075}
b0c5d67b 2076
212e58ed
DH
2077static SCM
2078unmemoize_at_call_with_values (const SCM expr, const SCM env)
2079{
2080 return scm_list_2 (scm_sym_at_call_with_values,
2081 unmemoize_exprs (SCM_CDR (expr), env));
2082}
2083
b0c5d67b 2084
3b88ed2a 2085SCM_SYNTAX (s_future, "future", scm_i_makbimacro, scm_m_future);
9fbee57e 2086SCM_GLOBAL_SYMBOL (scm_sym_future, s_future);
a513ead3 2087
9fbee57e
DH
2088/* Like promises, futures are implemented as closures with an empty
2089 * parameter list. Thus, (future <expression>) is transformed into
2090 * (#@future '() <expression>), where the empty list represents the
2091 * empty parameter list. This representation allows for easy creation
2092 * of the closure during evaluation. */
a513ead3 2093SCM
8ae95199 2094scm_m_future (SCM expr, SCM env)
a513ead3 2095{
8ae95199
DH
2096 const SCM new_expr = memoize_as_thunk_prototype (expr, env);
2097 SCM_SETCAR (new_expr, SCM_IM_FUTURE);
2098 return new_expr;
a513ead3
MV
2099}
2100
212e58ed
DH
2101static SCM
2102unmemoize_future (const SCM expr, const SCM env)
2103{
2104 const SCM thunk_expr = SCM_CADDR (expr);
2105 return scm_list_2 (scm_sym_future, unmemoize_expression (thunk_expr, env));
2106}
2107
9fbee57e 2108
3b88ed2a 2109SCM_SYNTAX (s_gset_x, "set!", scm_i_makbimacro, scm_m_generalized_set_x);
9fbee57e
DH
2110SCM_SYMBOL (scm_sym_setter, "setter");
2111
2112SCM
7893dbbf 2113scm_m_generalized_set_x (SCM expr, SCM env)
9fbee57e 2114{
7893dbbf 2115 SCM target, exp_target;
da48db62
DH
2116
2117 const SCM cdr_expr = SCM_CDR (expr);
2118 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
2119 ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
2120
2121 target = SCM_CAR (cdr_expr);
2122 if (!SCM_CONSP (target))
2123 {
2124 /* R5RS usage */
2125 return scm_m_set_x (expr, env);
2126 }
9fbee57e 2127 else
da48db62
DH
2128 {
2129 /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */
7893dbbf
MV
2130 /* Macroexpanding the target might return things of the form
2131 (begin <atom>). In that case, <atom> must be a symbol or a
2132 variable and we memoize to (set! <atom> ...).
2133 */
2b189e65 2134 exp_target = macroexp (target, env);
7893dbbf
MV
2135 if (SCM_EQ_P (SCM_CAR (exp_target), SCM_IM_BEGIN)
2136 && !SCM_NULLP (SCM_CDR (exp_target))
2137 && SCM_NULLP (SCM_CDDR (exp_target)))
2138 {
2139 exp_target= SCM_CADR (exp_target);
6d1a2e9f
MV
2140 ASSERT_SYNTAX_2 (SCM_SYMBOLP (exp_target)
2141 || SCM_VARIABLEP (exp_target),
2142 s_bad_variable, exp_target, expr);
7893dbbf
MV
2143 return scm_cons (SCM_IM_SET_X, scm_cons (exp_target,
2144 SCM_CDR (cdr_expr)));
2145 }
2146 else
2147 {
2148 const SCM setter_proc_tail = scm_list_1 (SCM_CAR (target));
2149 const SCM setter_proc = scm_cons_source (expr, scm_sym_setter,
2150 setter_proc_tail);
da48db62 2151
7893dbbf
MV
2152 const SCM cddr_expr = SCM_CDR (cdr_expr);
2153 const SCM setter_args = scm_append_x (scm_list_2 (SCM_CDR (target),
2154 cddr_expr));
da48db62 2155
7893dbbf
MV
2156 SCM_SETCAR (expr, setter_proc);
2157 SCM_SETCDR (expr, setter_args);
2158 return expr;
2159 }
da48db62 2160 }
9fbee57e
DH
2161}
2162
2163
a4aa2134
DH
2164/* @slot-ref is bound privately in the (oop goops) module from goops.c. As
2165 * soon as the module system allows us to more freely create bindings in
2166 * arbitrary modules during the startup phase, the code from goops.c should be
2167 * moved here. */
212e58ed
DH
2168
2169SCM_SYMBOL (sym_atslot_ref, "@slot-ref");
2170
9fbee57e 2171SCM
9a848baf 2172scm_m_atslot_ref (SCM expr, SCM env SCM_UNUSED)
9fbee57e 2173{
9a848baf
DH
2174 SCM slot_nr;
2175
2176 const SCM cdr_expr = SCM_CDR (expr);
2177 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
2178 ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
2179 slot_nr = SCM_CADR (cdr_expr);
2180 ASSERT_SYNTAX_2 (SCM_INUMP (slot_nr), s_bad_slot_number, slot_nr, expr);
9fbee57e 2181
9a848baf 2182 SCM_SETCAR (expr, SCM_IM_SLOT_REF);
e7313a9d 2183 SCM_SETCDR (cdr_expr, slot_nr);
9a848baf
DH
2184 return expr;
2185}
9fbee57e 2186
212e58ed
DH
2187static SCM
2188unmemoize_atslot_ref (const SCM expr, const SCM env)
2189{
2190 const SCM instance = SCM_CADR (expr);
2191 const SCM um_instance = unmemoize_expression (instance, env);
2192 const SCM slot_nr = SCM_CDDR (expr);
2193 return scm_list_3 (sym_atslot_ref, um_instance, slot_nr);
2194}
2195
9fbee57e 2196
a4aa2134
DH
2197/* @slot-set! is bound privately in the (oop goops) module from goops.c. As
2198 * soon as the module system allows us to more freely create bindings in
2199 * arbitrary modules during the startup phase, the code from goops.c should be
2200 * moved here. */
212e58ed
DH
2201
2202SCM_SYMBOL (sym_atslot_set_x, "@slot-set!");
2203
9fbee57e 2204SCM
9a848baf 2205scm_m_atslot_set_x (SCM expr, SCM env SCM_UNUSED)
9fbee57e 2206{
9a848baf
DH
2207 SCM slot_nr;
2208
2209 const SCM cdr_expr = SCM_CDR (expr);
2210 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
2211 ASSERT_SYNTAX (scm_ilength (cdr_expr) == 3, s_expression, expr);
2212 slot_nr = SCM_CADR (cdr_expr);
2213 ASSERT_SYNTAX_2 (SCM_INUMP (slot_nr), s_bad_slot_number, slot_nr, expr);
2214
2215 SCM_SETCAR (expr, SCM_IM_SLOT_SET_X);
2216 return expr;
9fbee57e 2217}
9fbee57e 2218
212e58ed
DH
2219static SCM
2220unmemoize_atslot_set_x (const SCM expr, const SCM env)
2221{
2222 const SCM cdr_expr = SCM_CDR (expr);
2223 const SCM instance = SCM_CAR (cdr_expr);
2224 const SCM um_instance = unmemoize_expression (instance, env);
2225 const SCM cddr_expr = SCM_CDR (cdr_expr);
2226 const SCM slot_nr = SCM_CAR (cddr_expr);
2227 const SCM cdddr_expr = SCM_CDR (cddr_expr);
2228 const SCM value = SCM_CAR (cdddr_expr);
2229 const SCM um_value = unmemoize_expression (value, env);
2230 return scm_list_4 (sym_atslot_set_x, um_instance, slot_nr, um_value);
2231}
2232
9fbee57e
DH
2233
2234#if SCM_ENABLE_ELISP
2235
70c1c108
DH
2236static const char s_defun[] = "Symbol's function definition is void";
2237
3b88ed2a 2238SCM_SYNTAX (s_nil_cond, "nil-cond", scm_i_makbimacro, scm_m_nil_cond);
9fbee57e 2239
70c1c108
DH
2240/* nil-cond expressions have the form
2241 * (nil-cond COND VAL COND VAL ... ELSEVAL) */
9fbee57e 2242SCM
70c1c108 2243scm_m_nil_cond (SCM expr, SCM env SCM_UNUSED)
9fbee57e 2244{
70c1c108
DH
2245 const long length = scm_ilength (SCM_CDR (expr));
2246 ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
2247 ASSERT_SYNTAX (length >= 1 && (length % 2) == 1, s_expression, expr);
2248
2249 SCM_SETCAR (expr, SCM_IM_NIL_COND);
2250 return expr;
9fbee57e
DH
2251}
2252
2253
3b88ed2a 2254SCM_SYNTAX (s_atfop, "@fop", scm_i_makbimacro, scm_m_atfop);
9fbee57e 2255
70c1c108
DH
2256/* The @fop-macro handles procedure and macro applications for elisp. The
2257 * input expression must have the form
2258 * (@fop <var> (transformer-macro <expr> ...))
2259 * where <var> must be a symbol. The expression is transformed into the
2260 * memoized form of either
2261 * (apply <un-aliased var> (transformer-macro <expr> ...))
2262 * if the value of var (across all aliasing) is not a macro, or
2263 * (<un-aliased var> <expr> ...)
2264 * if var is a macro. */
9fbee57e 2265SCM
70c1c108 2266scm_m_atfop (SCM expr, SCM env SCM_UNUSED)
9fbee57e 2267{
70c1c108
DH
2268 SCM location;
2269 SCM symbol;
2270
2271 const SCM cdr_expr = SCM_CDR (expr);
2272 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
2273 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 1, s_missing_expression, expr);
2274
2275 symbol = SCM_CAR (cdr_expr);
2276 ASSERT_SYNTAX_2 (SCM_SYMBOLP (symbol), s_bad_variable, symbol, expr);
2277
2278 location = scm_symbol_fref (symbol);
2279 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location), s_defun, symbol, expr);
2280
2281 /* The elisp function `defalias' allows to define aliases for symbols. To
2282 * look up such definitions, the chain of symbol definitions has to be
2283 * followed up to the terminal symbol. */
2284 while (SCM_SYMBOLP (SCM_VARIABLE_REF (location)))
9fbee57e 2285 {
70c1c108
DH
2286 const SCM alias = SCM_VARIABLE_REF (location);
2287 location = scm_symbol_fref (alias);
2288 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location), s_defun, symbol, expr);
9fbee57e 2289 }
70c1c108
DH
2290
2291 /* Memoize the value location belonging to the terminal symbol. */
2292 SCM_SETCAR (cdr_expr, location);
2293
2294 if (!SCM_MACROP (SCM_VARIABLE_REF (location)))
9fbee57e 2295 {
70c1c108
DH
2296 /* Since the location does not contain a macro, the form is a procedure
2297 * application. Replace `@fop' by `@apply' and transform the expression
2298 * including the `transformer-macro'. */
2299 SCM_SETCAR (expr, SCM_IM_APPLY);
2300 return expr;
2301 }
2302 else
2303 {
2304 /* Since the location contains a macro, the arguments should not be
2305 * transformed, so the `transformer-macro' is cut out. The resulting
2306 * expression starts with the memoized variable, that is at the cdr of
2307 * the input expression. */
2308 SCM_SETCDR (cdr_expr, SCM_CDADR (cdr_expr));
2309 return cdr_expr;
9fbee57e 2310 }
9fbee57e
DH
2311}
2312
2313#endif /* SCM_ENABLE_ELISP */
2314
2315
212e58ed
DH
2316static SCM
2317unmemoize_builtin_macro (const SCM expr, const SCM env)
2318{
2319 switch (ISYMNUM (SCM_CAR (expr)))
2320 {
2321 case (ISYMNUM (SCM_IM_AND)):
2322 return unmemoize_and (expr, env);
2323
2324 case (ISYMNUM (SCM_IM_BEGIN)):
2325 return unmemoize_begin (expr, env);
2326
2327 case (ISYMNUM (SCM_IM_CASE)):
2328 return unmemoize_case (expr, env);
2329
2330 case (ISYMNUM (SCM_IM_COND)):
2331 return unmemoize_cond (expr, env);
2332
2333 case (ISYMNUM (SCM_IM_DELAY)):
2334 return unmemoize_delay (expr, env);
2335
2336 case (ISYMNUM (SCM_IM_DO)):
2337 return unmemoize_do (expr, env);
2338
2339 case (ISYMNUM (SCM_IM_IF)):
2340 return unmemoize_if (expr, env);
2341
2342 case (ISYMNUM (SCM_IM_LAMBDA)):
2343 return unmemoize_lambda (expr, env);
2344
2345 case (ISYMNUM (SCM_IM_LET)):
2346 return unmemoize_let (expr, env);
2347
2348 case (ISYMNUM (SCM_IM_LETREC)):
2349 return unmemoize_letrec (expr, env);
2350
2351 case (ISYMNUM (SCM_IM_LETSTAR)):
2352 return unmemoize_letstar (expr, env);
2353
2354 case (ISYMNUM (SCM_IM_OR)):
2355 return unmemoize_or (expr, env);
2356
2357 case (ISYMNUM (SCM_IM_QUOTE)):
2358 return unmemoize_quote (expr, env);
2359
2360 case (ISYMNUM (SCM_IM_SET_X)):
2361 return unmemoize_set_x (expr, env);
2362
2363 case (ISYMNUM (SCM_IM_APPLY)):
2364 return unmemoize_apply (expr, env);
2365
2366 case (ISYMNUM (SCM_IM_BIND)):
2367 return unmemoize_exprs (expr, env); /* FIXME */
2368
2369 case (ISYMNUM (SCM_IM_CONT)):
2370 return unmemoize_atcall_cc (expr, env);
2371
2372 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
2373 return unmemoize_at_call_with_values (expr, env);
2374
2375 case (ISYMNUM (SCM_IM_FUTURE)):
2376 return unmemoize_future (expr, env);
2377
2378 case (ISYMNUM (SCM_IM_SLOT_REF)):
2379 return unmemoize_atslot_ref (expr, env);
2380
2381 case (ISYMNUM (SCM_IM_SLOT_SET_X)):
2382 return unmemoize_atslot_set_x (expr, env);
2383
2384 case (ISYMNUM (SCM_IM_NIL_COND)):
2385 return unmemoize_exprs (expr, env); /* FIXME */
2386
2387 default:
2388 return unmemoize_exprs (expr, env); /* FIXME */
2389 }
2390}
2391
2392
9fcf3cbb
DH
2393/* scm_i_unmemocopy_expr and scm_i_unmemocopy_body take a memoized expression
2394 * respectively a memoized body together with its environment and rewrite it
2395 * to its original form. Thus, these functions are the inversion of the
2396 * rewrite rules above. The procedure is not optimized for speed. It's used
2397 * in scm_i_unmemoize_expr, scm_procedure_source, macro_print and scm_iprin1.
212e58ed
DH
2398 *
2399 * Unmemoizing is not a reliable process. You cannot in general expect to get
2400 * the original source back.
2401 *
2402 * However, GOOPS currently relies on this for method compilation. This ought
2403 * to change. */
2404
2405SCM
9fcf3cbb
DH
2406scm_i_unmemocopy_expr (SCM expr, SCM env)
2407{
2408 const SCM source_properties = scm_whash_lookup (scm_source_whash, expr);
2409 const SCM um_expr = unmemoize_expression (expr, env);
2410
7888309b 2411 if (scm_is_true (source_properties))
9fcf3cbb
DH
2412 scm_whash_insert (scm_source_whash, um_expr, source_properties);
2413
2414 return um_expr;
2415}
2416
2417SCM
2418scm_i_unmemocopy_body (SCM forms, SCM env)
212e58ed
DH
2419{
2420 const SCM source_properties = scm_whash_lookup (scm_source_whash, forms);
2421 const SCM um_forms = unmemoize_exprs (forms, env);
2422
7888309b 2423 if (scm_is_true (source_properties))
212e58ed
DH
2424 scm_whash_insert (scm_source_whash, um_forms, source_properties);
2425
2426 return um_forms;
2427}
2428
2429
434f2f7a 2430#if (SCM_ENABLE_DEPRECATED == 1)
f58c472a 2431
434f2f7a
DH
2432/* Deprecated in guile 1.7.0 on 2003-11-09. */
2433SCM
2434scm_m_expand_body (SCM exprs, SCM env)
2435{
2436 scm_c_issue_deprecation_warning
2437 ("`scm_m_expand_body' is deprecated.");
2438 m_expand_body (exprs, env);
2439 return exprs;
2440}
f58c472a 2441
f58c472a
DH
2442
2443SCM_SYNTAX (s_undefine, "undefine", scm_makacro, scm_m_undefine);
2444
2445SCM
70c1c108 2446scm_m_undefine (SCM expr, SCM env)
f58c472a 2447{
70c1c108
DH
2448 SCM variable;
2449 SCM location;
2450
2451 const SCM cdr_expr = SCM_CDR (expr);
2452 ASSERT_SYNTAX (SCM_TOP_LEVEL (env), "Bad undefine placement in", expr);
2453 ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
2454 ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
2455
2b189e65
MV
2456 scm_c_issue_deprecation_warning
2457 ("`undefine' is deprecated.\n");
2458
70c1c108
DH
2459 variable = SCM_CAR (cdr_expr);
2460 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable), s_bad_variable, variable, expr);
2461 location = scm_sym2var (variable, scm_env_top_level (env), SCM_BOOL_F);
7888309b 2462 ASSERT_SYNTAX_2 (scm_is_true (location)
70c1c108
DH
2463 && !SCM_UNBNDP (SCM_VARIABLE_REF (location)),
2464 "variable already unbound ", variable, expr);
2465 SCM_VARIABLE_SET (location, SCM_UNDEFINED);
f58c472a 2466 return SCM_UNSPECIFIED;
f58c472a
DH
2467}
2468
26d5b9b4
MD
2469SCM
2470scm_macroexp (SCM x, SCM env)
2471{
2b189e65
MV
2472 scm_c_issue_deprecation_warning
2473 ("`scm_macroexp' is deprecated.");
2474 return macroexp (x, env);
26d5b9b4 2475}
73b64342 2476
6f81708a
DH
2477#endif
2478
60a49842 2479
212e58ed 2480#if (SCM_ENABLE_DEPRECATED == 1)
26d5b9b4 2481
212e58ed
DH
2482SCM
2483scm_unmemocar (SCM form, SCM env)
8ea46249 2484{
212e58ed
DH
2485 scm_c_issue_deprecation_warning
2486 ("`scm_unmemocar' is deprecated.");
60a49842 2487
60a49842
DH
2488 if (!SCM_CONSP (form))
2489 return form;
2490 else
2491 {
2492 SCM c = SCM_CAR (form);
2493 if (SCM_VARIABLEP (c))
2494 {
2495 SCM sym = scm_module_reverse_lookup (scm_env_module (env), c);
7888309b 2496 if (scm_is_false (sym))
60a49842
DH
2497 sym = sym_three_question_marks;
2498 SCM_SETCAR (form, sym);
2499 }
2500 else if (SCM_ILOCP (c))
2501 {
2502 unsigned long int ir;
2503
2504 for (ir = SCM_IFRAME (c); ir != 0; --ir)
2505 env = SCM_CDR (env);
2506 env = SCM_CAAR (env);
2507 for (ir = SCM_IDIST (c); ir != 0; --ir)
2508 env = SCM_CDR (env);
f62b9dff 2509
60a49842
DH
2510 SCM_SETCAR (form, SCM_ICDRP (c) ? env : SCM_CAR (env));
2511 }
2512 return form;
2513 }
2514}
2515
434f2f7a
DH
2516#endif
2517
6f81708a
DH
2518/*****************************************************************************/
2519/*****************************************************************************/
2520/* The definitions for execution start here. */
2521/*****************************************************************************/
2522/*****************************************************************************/
2523
2524SCM_GLOBAL_SYMBOL (scm_sym_enter_frame, "enter-frame");
2525SCM_GLOBAL_SYMBOL (scm_sym_apply_frame, "apply-frame");
2526SCM_GLOBAL_SYMBOL (scm_sym_exit_frame, "exit-frame");
2527SCM_GLOBAL_SYMBOL (scm_sym_trace, "trace");
2528
2529/* A function object to implement "apply" for non-closure functions. */
2530static SCM f_apply;
2531/* An endless list consisting of #<undefined> objects: */
2532static SCM undefineds;
2533
2534
2535int
6e8d25a6 2536scm_badargsp (SCM formals, SCM args)
0f2d19dd 2537{
6a0f6ff3 2538 while (!SCM_NULLP (formals))
0f2d19dd 2539 {
01f11e02 2540 if (!SCM_CONSP (formals))
ff467021 2541 return 0;
6a0f6ff3 2542 if (SCM_NULLP (args))
ff467021 2543 return 1;
0f2d19dd
JB
2544 formals = SCM_CDR (formals);
2545 args = SCM_CDR (args);
2546 }
01f11e02 2547 return !SCM_NULLP (args) ? 1 : 0;
0f2d19dd 2548}
a392ee15 2549
0f2d19dd 2550\f
62360b89 2551
434f2f7a
DH
2552/* The evaluator contains a plethora of EVAL symbols. This is an attempt at
2553 * explanation.
62360b89 2554 *
434f2f7a
DH
2555 * The following macros should be used in code which is read twice (where the
2556 * choice of evaluator is hard soldered):
62360b89 2557 *
434f2f7a
DH
2558 * CEVAL is the symbol used within one evaluator to call itself.
2559 * Originally, it is defined to ceval, but is redefined to deval during the
2560 * second pass.
62360b89
DH
2561 *
2562 * SCM_EVALIM is used when it is known that the expression is an
2563 * immediate. (This macro never calls an evaluator.)
434f2f7a
DH
2564 *
2565 * EVAL evaluates an expression that is expected to have its symbols already
2566 * memoized. Expressions that are not of the form '(<form> <form> ...)' are
2567 * evaluated inline without calling an evaluator.
2568 *
2569 * EVALCAR evaluates the car of an expression 'X:(Y:<form> <form> ...)',
2570 * potentially replacing a symbol at the position Y:<form> by its memoized
2571 * variable. If Y:<form> is not of the form '(<form> <form> ...)', the
2572 * evaluation is performed inline without calling an evaluator.
62360b89
DH
2573 *
2574 * The following macros should be used in code which is read once
2575 * (where the choice of evaluator is dynamic):
2576 *
434f2f7a
DH
2577 * SCM_XEVAL corresponds to EVAL, but uses ceval *or* deval depending on the
2578 * debugging mode.
62360b89 2579 *
434f2f7a
DH
2580 * SCM_XEVALCAR corresponds to EVALCAR, but uses ceval *or* deval depending
2581 * on the debugging mode.
62360b89
DH
2582 *
2583 * The main motivation for keeping this plethora is efficiency
2584 * together with maintainability (=> locality of code).
2585 */
2586
434f2f7a
DH
2587static SCM ceval (SCM x, SCM env);
2588static SCM deval (SCM x, SCM env);
2589#define CEVAL ceval
2590
62360b89
DH
2591
2592#define SCM_EVALIM2(x) \
2593 ((SCM_EQ_P ((x), SCM_EOL) \
2594 ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \
2595 : 0), \
2596 (x))
2597
2598#define SCM_EVALIM(x, env) (SCM_ILOCP (x) \
434f2f7a 2599 ? *scm_ilookup ((x), (env)) \
62360b89
DH
2600 : SCM_EVALIM2(x))
2601
434f2f7a
DH
2602#define SCM_XEVAL(x, env) \
2603 (SCM_IMP (x) \
2604 ? SCM_EVALIM2 (x) \
2605 : (SCM_VARIABLEP (x) \
2606 ? SCM_VARIABLE_REF (x) \
2607 : (SCM_CONSP (x) \
2608 ? (scm_debug_mode_p \
2609 ? deval ((x), (env)) \
2610 : ceval ((x), (env))) \
2611 : (x))))
2612
2613#define SCM_XEVALCAR(x, env) \
2614 (SCM_IMP (SCM_CAR (x)) \
2615 ? SCM_EVALIM (SCM_CAR (x), (env)) \
2616 : (SCM_VARIABLEP (SCM_CAR (x)) \
2617 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2618 : (SCM_CONSP (SCM_CAR (x)) \
2619 ? (scm_debug_mode_p \
2620 ? deval (SCM_CAR (x), (env)) \
2621 : ceval (SCM_CAR (x), (env))) \
2622 : (!SCM_SYMBOLP (SCM_CAR (x)) \
2623 ? SCM_CAR (x) \
2624 : *scm_lookupcar ((x), (env), 1)))))
2625
2626#define EVAL(x, env) \
2627 (SCM_IMP (x) \
2628 ? SCM_EVALIM ((x), (env)) \
2629 : (SCM_VARIABLEP (x) \
2630 ? SCM_VARIABLE_REF (x) \
2631 : (SCM_CONSP (x) \
2632 ? CEVAL ((x), (env)) \
2633 : (x))))
2634
2635#define EVALCAR(x, env) \
2636 (SCM_IMP (SCM_CAR (x)) \
2637 ? SCM_EVALIM (SCM_CAR (x), (env)) \
2638 : (SCM_VARIABLEP (SCM_CAR (x)) \
2639 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2640 : (SCM_CONSP (SCM_CAR (x)) \
2641 ? CEVAL (SCM_CAR (x), (env)) \
2642 : (!SCM_SYMBOLP (SCM_CAR (x)) \
2643 ? SCM_CAR (x) \
2644 : *scm_lookupcar ((x), (env), 1)))))
62360b89
DH
2645
2646SCM_REC_MUTEX (source_mutex);
2647
2648
e5156567
DH
2649/* Lookup a given local variable in an environment. The local variable is
2650 * given as an iloc, that is a triple <frame, binding, last?>, where frame
2651 * indicates the relative number of the environment frame (counting upwards
2652 * from the innermost environment frame), binding indicates the number of the
2653 * binding within the frame, and last? (which is extracted from the iloc using
2654 * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
2655 * very end of the improper list of bindings. */
2656SCM *
2657scm_ilookup (SCM iloc, SCM env)
2658{
2659 unsigned int frame_nr = SCM_IFRAME (iloc);
2660 unsigned int binding_nr = SCM_IDIST (iloc);
2661 SCM frames = env;
2662 SCM bindings;
2663
2664 for (; 0 != frame_nr; --frame_nr)
2665 frames = SCM_CDR (frames);
2666
2667 bindings = SCM_CAR (frames);
2668 for (; 0 != binding_nr; --binding_nr)
2669 bindings = SCM_CDR (bindings);
2670
2671 if (SCM_ICDRP (iloc))
2672 return SCM_CDRLOC (bindings);
2673 return SCM_CARLOC (SCM_CDR (bindings));
2674}
2675
2676
2677SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable");
2678
2679static void error_unbound_variable (SCM symbol) SCM_NORETURN;
2680static void
2681error_unbound_variable (SCM symbol)
2682{
2683 scm_error (scm_unbound_variable_key, NULL,
2684 "Unbound variable: ~S",
2685 scm_list_1 (symbol), SCM_BOOL_F);
2686}
2687
2688
2689/* The Lookup Car Race
2690 - by Eva Luator
2691
2692 Memoization of variables and special forms is done while executing
2693 the code for the first time. As long as there is only one thread
2694 everything is fine, but as soon as two threads execute the same
2695 code concurrently `for the first time' they can come into conflict.
2696
2697 This memoization includes rewriting variable references into more
2698 efficient forms and expanding macros. Furthermore, macro expansion
2699 includes `compiling' special forms like `let', `cond', etc. into
2700 tree-code instructions.
2701
2702 There shouldn't normally be a problem with memoizing local and
2703 global variable references (into ilocs and variables), because all
2704 threads will mutate the code in *exactly* the same way and (if I
2705 read the C code correctly) it is not possible to observe a half-way
2706 mutated cons cell. The lookup procedure can handle this
2707 transparently without any critical sections.
2708
2709 It is different with macro expansion, because macro expansion
2710 happens outside of the lookup procedure and can't be
2711 undone. Therefore the lookup procedure can't cope with it. It has
2712 to indicate failure when it detects a lost race and hope that the
2713 caller can handle it. Luckily, it turns out that this is the case.
2714
2715 An example to illustrate this: Suppose that the following form will
2716 be memoized concurrently by two threads
2717
2718 (let ((x 12)) x)
2719
2720 Let's first examine the lookup of X in the body. The first thread
2721 decides that it has to find the symbol "x" in the environment and
2722 starts to scan it. Then the other thread takes over and actually
2723 overtakes the first. It looks up "x" and substitutes an
2724 appropriate iloc for it. Now the first thread continues and
2725 completes its lookup. It comes to exactly the same conclusions as
2726 the second one and could - without much ado - just overwrite the
2727 iloc with the same iloc.
2728
2729 But let's see what will happen when the race occurs while looking
2730 up the symbol "let" at the start of the form. It could happen that
2731 the second thread interrupts the lookup of the first thread and not
2732 only substitutes a variable for it but goes right ahead and
2733 replaces it with the compiled form (#@let* (x 12) x). Now, when
2734 the first thread completes its lookup, it would replace the #@let*
2735 with a variable containing the "let" binding, effectively reverting
2736 the form to (let (x 12) x). This is wrong. It has to detect that
2737 it has lost the race and the evaluator has to reconsider the
2738 changed form completely.
2739
2740 This race condition could be resolved with some kind of traffic
2741 light (like mutexes) around scm_lookupcar, but I think that it is
2742 best to avoid them in this case. They would serialize memoization
2743 completely and because lookup involves calling arbitrary Scheme
2744 code (via the lookup-thunk), threads could be blocked for an
2745 arbitrary amount of time or even deadlock. But with the current
2746 solution a lot of unnecessary work is potentially done. */
2747
2748/* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
2749 return NULL to indicate a failed lookup due to some race conditions
2750 between threads. This only happens when VLOC is the first cell of
2751 a special form that will eventually be memoized (like `let', etc.)
2752 In that case the whole lookup is bogus and the caller has to
2753 reconsider the complete special form.
2754
2755 SCM_LOOKUPCAR is still there, of course. It just calls
2756 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
2757 should only be called when it is known that VLOC is not the first
2758 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
2759 for NULL. I think I've found the only places where this
2760 applies. */
2761
2762static SCM *
2763scm_lookupcar1 (SCM vloc, SCM genv, int check)
2764{
2765 SCM env = genv;
2766 register SCM *al, fl, var = SCM_CAR (vloc);
2767 register SCM iloc = SCM_ILOC00;
2768 for (; SCM_NIMP (env); env = SCM_CDR (env))
2769 {
2770 if (!SCM_CONSP (SCM_CAR (env)))
2771 break;
2772 al = SCM_CARLOC (env);
2773 for (fl = SCM_CAR (*al); SCM_NIMP (fl); fl = SCM_CDR (fl))
2774 {
2775 if (!SCM_CONSP (fl))
2776 {
2777 if (SCM_EQ_P (fl, var))
2778 {
2779 if (! SCM_EQ_P (SCM_CAR (vloc), var))
2780 goto race;
2781 SCM_SET_CELL_WORD_0 (vloc, SCM_UNPACK (iloc) + SCM_ICDR);
2782 return SCM_CDRLOC (*al);
2783 }
2784 else
2785 break;
2786 }
2787 al = SCM_CDRLOC (*al);
2788 if (SCM_EQ_P (SCM_CAR (fl), var))
2789 {
2790 if (SCM_UNBNDP (SCM_CAR (*al)))
2791 {
2792 env = SCM_EOL;
2793 goto errout;
2794 }
2795 if (!SCM_EQ_P (SCM_CAR (vloc), var))
2796 goto race;
2797 SCM_SETCAR (vloc, iloc);
2798 return SCM_CARLOC (*al);
2799 }
2800 iloc = SCM_PACK (SCM_UNPACK (iloc) + SCM_IDINC);
2801 }
2802 iloc = SCM_PACK ((~SCM_IDSTMSK) & (SCM_UNPACK(iloc) + SCM_IFRINC));
2803 }
2804 {
2805 SCM top_thunk, real_var;
2806 if (SCM_NIMP (env))
2807 {
2808 top_thunk = SCM_CAR (env); /* env now refers to a
2809 top level env thunk */
2810 env = SCM_CDR (env);
2811 }
2812 else
2813 top_thunk = SCM_BOOL_F;
2814 real_var = scm_sym2var (var, top_thunk, SCM_BOOL_F);
7888309b 2815 if (scm_is_false (real_var))
e5156567
DH
2816 goto errout;
2817
2818 if (!SCM_NULLP (env) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var)))
2819 {
2820 errout:
2821 if (check)
2822 {
2823 if (SCM_NULLP (env))
2824 error_unbound_variable (var);
2825 else
2826 scm_misc_error (NULL, "Damaged environment: ~S",
2827 scm_list_1 (var));
2828 }
2829 else
2830 {
2831 /* A variable could not be found, but we shall
2832 not throw an error. */
2833 static SCM undef_object = SCM_UNDEFINED;
2834 return &undef_object;
2835 }
2836 }
2837
2838 if (!SCM_EQ_P (SCM_CAR (vloc), var))
2839 {
2840 /* Some other thread has changed the very cell we are working
2841 on. In effect, it must have done our job or messed it up
2842 completely. */
2843 race:
2844 var = SCM_CAR (vloc);
2845 if (SCM_VARIABLEP (var))
2846 return SCM_VARIABLE_LOC (var);
2847 if (SCM_ILOCP (var))
2848 return scm_ilookup (var, genv);
2849 /* We can't cope with anything else than variables and ilocs. When
2850 a special form has been memoized (i.e. `let' into `#@let') we
2851 return NULL and expect the calling function to do the right
2852 thing. For the evaluator, this means going back and redoing
2853 the dispatch on the car of the form. */
2854 return NULL;
2855 }
2856
2857 SCM_SETCAR (vloc, real_var);
2858 return SCM_VARIABLE_LOC (real_var);
2859 }
2860}
2861
2862SCM *
2863scm_lookupcar (SCM vloc, SCM genv, int check)
2864{
2865 SCM *loc = scm_lookupcar1 (vloc, genv, check);
2866 if (loc == NULL)
2867 abort ();
2868 return loc;
2869}
2870
2871
36245b66
DH
2872/* During execution, look up a symbol in the top level of the given local
2873 * environment and return the corresponding variable object. If no binding
2874 * for the symbol can be found, an 'Unbound variable' error is signalled. */
2875static SCM
2876lazy_memoize_variable (const SCM symbol, const SCM environment)
2877{
2878 const SCM top_level = scm_env_top_level (environment);
2879 const SCM variable = scm_sym2var (symbol, top_level, SCM_BOOL_F);
2880
7888309b 2881 if (scm_is_false (variable))
36245b66
DH
2882 error_unbound_variable (symbol);
2883 else
2884 return variable;
2885}
2886
2887
62360b89
DH
2888SCM
2889scm_eval_car (SCM pair, SCM env)
2890{
2891 return SCM_XEVALCAR (pair, env);
2892}
2893
2894
6dbd0af5 2895SCM
6e8d25a6 2896scm_eval_args (SCM l, SCM env, SCM proc)
6dbd0af5 2897{
680ed4a8 2898 SCM results = SCM_EOL, *lloc = &results, res;
904a077d 2899 while (SCM_CONSP (l))
6dbd0af5 2900 {
680ed4a8 2901 res = EVALCAR (l, env);
904a077d 2902
8ea46249 2903 *lloc = scm_list_1 (res);
a23afe53 2904 lloc = SCM_CDRLOC (*lloc);
6dbd0af5
MD
2905 l = SCM_CDR (l);
2906 }
22a52da1 2907 if (!SCM_NULLP (l))
904a077d 2908 scm_wrong_num_args (proc);
680ed4a8 2909 return results;
6dbd0af5 2910}
c4ac4d88 2911
d0b07b5d 2912
9de33deb
MD
2913SCM
2914scm_eval_body (SCM code, SCM env)
2915{
2916 SCM next;
434f2f7a 2917
9de33deb 2918 again:
01f11e02
DH
2919 next = SCM_CDR (code);
2920 while (!SCM_NULLP (next))
9de33deb
MD
2921 {
2922 if (SCM_IMP (SCM_CAR (code)))
2923 {
2924 if (SCM_ISYMP (SCM_CAR (code)))
2925 {
28d52ebb 2926 scm_rec_mutex_lock (&source_mutex);
9bc4701c
MD
2927 /* check for race condition */
2928 if (SCM_ISYMP (SCM_CAR (code)))
9d4bf6d3 2929 m_expand_body (code, env);
28d52ebb 2930 scm_rec_mutex_unlock (&source_mutex);
9de33deb
MD
2931 goto again;
2932 }
2933 }
2934 else
2935 SCM_XEVAL (SCM_CAR (code), env);
2936 code = next;
01f11e02 2937 next = SCM_CDR (code);
9de33deb
MD
2938 }
2939 return SCM_XEVALCAR (code, env);
2940}
2941
0f2d19dd
JB
2942#endif /* !DEVAL */
2943
6dbd0af5
MD
2944
2945/* SECTION: This code is specific for the debugging support. One
2946 * branch is read when DEVAL isn't defined, the other when DEVAL is
2947 * defined.
2948 */
2949
2950#ifndef DEVAL
2951
2952#define SCM_APPLY scm_apply
2953#define PREP_APPLY(proc, args)
2954#define ENTER_APPLY
ddea3325 2955#define RETURN(x) do { return x; } while (0)
b7ff98dd
MD
2956#ifdef STACK_CHECKING
2957#ifndef NO_CEVAL_STACK_CHECKING
2958#define EVAL_STACK_CHECKING
2959#endif
6dbd0af5
MD
2960#endif
2961
2962#else /* !DEVAL */
2963
434f2f7a
DH
2964#undef CEVAL
2965#define CEVAL deval /* Substitute all uses of ceval */
2966
0f2d19dd
JB
2967#undef SCM_APPLY
2968#define SCM_APPLY scm_dapply
434f2f7a 2969
6dbd0af5
MD
2970#undef PREP_APPLY
2971#define PREP_APPLY(p, l) \
2972{ ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
434f2f7a 2973
6dbd0af5
MD
2974#undef ENTER_APPLY
2975#define ENTER_APPLY \
d3a6bc94 2976do { \
b7ff98dd 2977 SCM_SET_ARGSREADY (debug);\
5132eef0 2978 if (scm_check_apply_p && SCM_TRAPS_P)\
b7ff98dd 2979 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
6dbd0af5 2980 {\
7888309b 2981 SCM tmp, tail = scm_from_bool(SCM_TRACED_FRAME_P (debug)); \
c6a4fbce 2982 SCM_SET_TRACED_FRAME (debug); \
d95c0b76 2983 SCM_TRAPS_P = 0;\
b7ff98dd 2984 if (SCM_CHEAPTRAPS_P)\
6dbd0af5 2985 {\
c0ab1b8d 2986 tmp = scm_make_debugobj (&debug);\
d95c0b76 2987 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
b6d75948 2988 }\
6dbd0af5
MD
2989 else\
2990 {\
5f144b10
GH
2991 int first;\
2992 tmp = scm_make_continuation (&first);\
2993 if (first)\
d95c0b76 2994 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
6dbd0af5 2995 }\
d95c0b76 2996 SCM_TRAPS_P = 1;\
6dbd0af5 2997 }\
d3a6bc94 2998} while (0)
434f2f7a 2999
0f2d19dd 3000#undef RETURN
ddea3325 3001#define RETURN(e) do { proc = (e); goto exit; } while (0)
434f2f7a 3002
b7ff98dd
MD
3003#ifdef STACK_CHECKING
3004#ifndef EVAL_STACK_CHECKING
3005#define EVAL_STACK_CHECKING
3006#endif
6dbd0af5
MD
3007#endif
3008
0f2d19dd 3009
434f2f7a
DH
3010/* scm_last_debug_frame contains a pointer to the last debugging information
3011 * stack frame. It is accessed very often from the debugging evaluator, so it
3012 * should probably not be indirectly addressed. Better to save and restore it
3013 * from the current root at any stack swaps.
6dbd0af5
MD
3014 */
3015
6dbd0af5
MD
3016/* scm_debug_eframe_size is the number of slots available for pseudo
3017 * stack frames at each real stack frame.
3018 */
3019
c014a02e 3020long scm_debug_eframe_size;
6dbd0af5 3021
434f2f7a
DH
3022int scm_debug_mode_p;
3023int scm_check_entry_p;
3024int scm_check_apply_p;
3025int scm_check_exit_p;
6dbd0af5 3026
c014a02e 3027long scm_eval_stack;
a74145b8 3028
92c2555f 3029scm_t_option scm_eval_opts[] = {
a74145b8 3030 { SCM_OPTION_INTEGER, "stack", 22000, "Size of thread stacks (in machine words)." }
33b97402
MD
3031};
3032
92c2555f 3033scm_t_option scm_debug_opts[] = {
b7ff98dd
MD
3034 { SCM_OPTION_BOOLEAN, "cheap", 1,
3035 "*Flyweight representation of the stack at traps." },
3036 { SCM_OPTION_BOOLEAN, "breakpoints", 0, "*Check for breakpoints." },
3037 { SCM_OPTION_BOOLEAN, "trace", 0, "*Trace mode." },
3038 { SCM_OPTION_BOOLEAN, "procnames", 1,
3039 "Record procedure names at definition." },
3040 { SCM_OPTION_BOOLEAN, "backwards", 0,
3041 "Display backtrace in anti-chronological order." },
274dc5fd 3042 { SCM_OPTION_INTEGER, "width", 79, "Maximal width of backtrace." },
4e646a03
MD
3043 { SCM_OPTION_INTEGER, "indent", 10, "Maximal indentation in backtrace." },
3044 { SCM_OPTION_INTEGER, "frames", 3,
b7ff98dd 3045 "Maximum number of tail-recursive frames in backtrace." },
4e646a03
MD
3046 { SCM_OPTION_INTEGER, "maxdepth", 1000,
3047 "Maximal number of stored backtrace frames." },
3048 { SCM_OPTION_INTEGER, "depth", 20, "Maximal length of printed backtrace." },
11f77bfc
MD
3049 { SCM_OPTION_BOOLEAN, "backtrace", 0, "Show backtrace on error." },
3050 { SCM_OPTION_BOOLEAN, "debug", 0, "Use the debugging evaluator." },
863e833b 3051 { SCM_OPTION_INTEGER, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
d95c0b76 3052 { 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."}
6dbd0af5
MD
3053};
3054
92c2555f 3055scm_t_option scm_evaluator_trap_table[] = {
b6d75948 3056 { SCM_OPTION_BOOLEAN, "traps", 0, "Enable evaluator traps." },
b7ff98dd
MD
3057 { SCM_OPTION_BOOLEAN, "enter-frame", 0, "Trap when eval enters new frame." },
3058 { SCM_OPTION_BOOLEAN, "apply-frame", 0, "Trap when entering apply." },
d95c0b76
NJ
3059 { SCM_OPTION_BOOLEAN, "exit-frame", 0, "Trap when exiting eval or apply." },
3060 { SCM_OPTION_SCM, "enter-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for enter-frame traps." },
3061 { SCM_OPTION_SCM, "apply-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for apply-frame traps." },
3062 { SCM_OPTION_SCM, "exit-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for exit-frame traps." }
6dbd0af5
MD
3063};
3064
a1ec6916 3065SCM_DEFINE (scm_eval_options_interface, "eval-options-interface", 0, 1, 0,
1bbd0b84 3066 (SCM setting),
b3f26b14
MG
3067 "Option interface for the evaluation options. Instead of using\n"
3068 "this procedure directly, use the procedures @code{eval-enable},\n"
3939e9df 3069 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
1bbd0b84 3070#define FUNC_NAME s_scm_eval_options_interface
33b97402
MD
3071{
3072 SCM ans;
3073 SCM_DEFER_INTS;
3074 ans = scm_options (setting,
3075 scm_eval_opts,
3076 SCM_N_EVAL_OPTIONS,
1bbd0b84 3077 FUNC_NAME);
a74145b8 3078 scm_eval_stack = SCM_EVAL_STACK * sizeof (void *);
33b97402
MD
3079 SCM_ALLOW_INTS;
3080 return ans;
3081}
1bbd0b84 3082#undef FUNC_NAME
33b97402 3083
d0b07b5d 3084
a1ec6916 3085SCM_DEFINE (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0,
1bbd0b84 3086 (SCM setting),
b3f26b14 3087 "Option interface for the evaluator trap options.")
1bbd0b84 3088#define FUNC_NAME s_scm_evaluator_traps
33b97402
MD
3089{
3090 SCM ans;
3091 SCM_DEFER_INTS;
3092 ans = scm_options (setting,
3093 scm_evaluator_trap_table,
3094 SCM_N_EVALUATOR_TRAPS,
1bbd0b84 3095 FUNC_NAME);
33b97402 3096 SCM_RESET_DEBUG_MODE;
bfc69694 3097 SCM_ALLOW_INTS;
33b97402
MD
3098 return ans;
3099}
1bbd0b84 3100#undef FUNC_NAME
33b97402 3101
d0b07b5d 3102
24933780 3103static SCM
a392ee15 3104deval_args (SCM l, SCM env, SCM proc, SCM *lloc)
0f2d19dd 3105{
b1cb24ff 3106 SCM *results = lloc;
904a077d 3107 while (SCM_CONSP (l))
0f2d19dd 3108 {
b1cb24ff 3109 const SCM res = EVALCAR (l, env);
904a077d 3110
8ea46249 3111 *lloc = scm_list_1 (res);
a23afe53 3112 lloc = SCM_CDRLOC (*lloc);
0f2d19dd
JB
3113 l = SCM_CDR (l);
3114 }
22a52da1 3115 if (!SCM_NULLP (l))
904a077d 3116 scm_wrong_num_args (proc);
680ed4a8 3117 return *results;
0f2d19dd
JB
3118}
3119
6dbd0af5
MD
3120#endif /* !DEVAL */
3121
3122
a392ee15 3123/* SECTION: This code is compiled twice.
6dbd0af5
MD
3124 */
3125
a392ee15 3126
d9d39d76 3127/* Update the toplevel environment frame ENV so that it refers to the
a392ee15 3128 * current module. */
d9d39d76
MV
3129#define UPDATE_TOPLEVEL_ENV(env) \
3130 do { \
3131 SCM p = scm_current_module_lookup_closure (); \
d0b07b5d 3132 if (p != SCM_CAR (env)) \
d9d39d76
MV
3133 env = scm_top_level_env (p); \
3134 } while (0)
3135
6dbd0af5 3136
6f81708a
DH
3137#define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
3138 ASSERT_SYNTAX (!SCM_EQ_P ((x), SCM_EOL), s_empty_combination, x)
3139
3140
a392ee15
DH
3141/* This is the evaluator. Like any real monster, it has three heads:
3142 *
434f2f7a
DH
3143 * ceval is the non-debugging evaluator, deval is the debugging version. Both
3144 * are implemented using a common code base, using the following mechanism:
3145 * CEVAL is a macro, which is either defined to ceval or deval. Thus, there
3146 * is no function CEVAL, but the code for CEVAL actually compiles to either
3147 * ceval or deval. When CEVAL is defined to ceval, it is known that the macro
3148 * DEVAL is not defined. When CEVAL is defined to deval, then the macro DEVAL
3149 * is known to be defined. Thus, in CEVAL parts for the debugging evaluator
a392ee15
DH
3150 * are enclosed within #ifdef DEVAL ... #endif.
3151 *
434f2f7a
DH
3152 * All three (ceval, deval and their common implementation CEVAL) take two
3153 * input parameters, x and env: x is a single expression to be evalutated.
3154 * env is the environment in which bindings are searched.
a392ee15 3155 *
434f2f7a
DH
3156 * x is known to be a pair. Since x is a single expression, it is necessarily
3157 * in a tail position. If x is just a call to another function like in the
3158 * expression (foo exp1 exp2 ...), the realization of that call therefore
3159 * _must_not_ increase stack usage (the evaluation of exp1, exp2 etc.,
3160 * however, may do so). This is realized by making extensive use of 'goto'
3161 * statements within the evaluator: The gotos replace recursive calls to
3162 * CEVAL, thus re-using the same stack frame that CEVAL was already using.
3163 * If, however, x represents some form that requires to evaluate a sequence of
3164 * expressions like (begin exp1 exp2 ...), then recursive calls to CEVAL are
3165 * performed for all but the last expression of that sequence. */
6dbd0af5 3166
434f2f7a
DH
3167static SCM
3168CEVAL (SCM x, SCM env)
0f2d19dd 3169{
42030fb2 3170 SCM proc, arg1;
6dbd0af5 3171#ifdef DEVAL
92c2555f
MV
3172 scm_t_debug_frame debug;
3173 scm_t_debug_info *debug_info_end;
1646d37b 3174 debug.prev = scm_last_debug_frame;
020c890c 3175 debug.status = 0;
04b6c081 3176 /*
92c2555f 3177 * The debug.vect contains twice as much scm_t_debug_info frames as the
04b6c081
MD
3178 * user has specified with (debug-set! frames <n>).
3179 *
3180 * Even frames are eval frames, odd frames are apply frames.
3181 */
92c2555f 3182 debug.vect = (scm_t_debug_info *) alloca (scm_debug_eframe_size
a392ee15 3183 * sizeof (scm_t_debug_info));
c0ab1b8d
JB
3184 debug.info = debug.vect;
3185 debug_info_end = debug.vect + scm_debug_eframe_size;
3186 scm_last_debug_frame = &debug;
6dbd0af5 3187#endif
b7ff98dd 3188#ifdef EVAL_STACK_CHECKING
79f55b7c 3189 if (scm_stack_checking_enabled_p && SCM_STACK_OVERFLOW_P (&proc))
6dbd0af5 3190 {
b7ff98dd 3191#ifdef DEVAL
6dbd0af5
MD
3192 debug.info->e.exp = x;
3193 debug.info->e.env = env;
b7ff98dd 3194#endif
6dbd0af5
MD
3195 scm_report_stack_overflow ();
3196 }
3197#endif
6a0f6ff3 3198
6dbd0af5
MD
3199#ifdef DEVAL
3200 goto start;
3201#endif
6a0f6ff3 3202
6dbd0af5
MD
3203loop:
3204#ifdef DEVAL
b7ff98dd
MD
3205 SCM_CLEAR_ARGSREADY (debug);
3206 if (SCM_OVERFLOWP (debug))
6dbd0af5 3207 --debug.info;
04b6c081
MD
3208 /*
3209 * In theory, this should be the only place where it is necessary to
3210 * check for space in debug.vect since both eval frames and
3211 * available space are even.
3212 *
3213 * For this to be the case, however, it is necessary that primitive
3214 * special forms which jump back to `loop', `begin' or some similar
680516ba 3215 * label call PREP_APPLY.
04b6c081 3216 */
c0ab1b8d 3217 else if (++debug.info >= debug_info_end)
6dbd0af5 3218 {
b7ff98dd 3219 SCM_SET_OVERFLOW (debug);
6dbd0af5
MD
3220 debug.info -= 2;
3221 }
6a0f6ff3 3222
6dbd0af5
MD
3223start:
3224 debug.info->e.exp = x;
3225 debug.info->e.env = env;
5132eef0
DH
3226 if (scm_check_entry_p && SCM_TRAPS_P)
3227 {
bc76d628
DH
3228 if (SCM_ENTER_FRAME_P
3229 || (SCM_BREAKPOINTS_P && scm_c_source_property_breakpoint_p (x)))
5132eef0 3230 {
bc76d628 3231 SCM stackrep;
7888309b 3232 SCM tail = scm_from_bool (SCM_TAILRECP (debug));
5132eef0
DH
3233 SCM_SET_TAILREC (debug);
3234 if (SCM_CHEAPTRAPS_P)
bc76d628 3235 stackrep = scm_make_debugobj (&debug);
5132eef0
DH
3236 else
3237 {
3238 int first;
3239 SCM val = scm_make_continuation (&first);
3240
3241 if (first)
bc76d628 3242 stackrep = val;
5132eef0
DH
3243 else
3244 {
3245 x = val;
3246 if (SCM_IMP (x))
3247 RETURN (x);
3248 else
3249 /* This gives the possibility for the debugger to
3250 modify the source expression before evaluation. */
3251 goto dispatch;
3252 }
3253 }
3254 SCM_TRAPS_P = 0;
3255 scm_call_4 (SCM_ENTER_FRAME_HDLR,
3256 scm_sym_enter_frame,
bc76d628 3257 stackrep,
5132eef0 3258 tail,
212e58ed 3259 unmemoize_expression (x, env));
5132eef0
DH
3260 SCM_TRAPS_P = 1;
3261 }
3262 }
6dbd0af5 3263#endif
f8769b1d 3264dispatch:
9cb5124f 3265 SCM_TICK;
dec40cd2 3266 if (SCM_ISYMP (SCM_CAR (x)))
0f2d19dd 3267 {
7e6e6b37 3268 switch (ISYMNUM (SCM_CAR (x)))
dec40cd2 3269 {
7e6e6b37 3270 case (ISYMNUM (SCM_IM_AND)):
dec40cd2
DH
3271 x = SCM_CDR (x);
3272 while (!SCM_NULLP (SCM_CDR (x)))
3273 {
3274 SCM test_result = EVALCAR (x, env);
7888309b 3275 if (scm_is_false (test_result) || SCM_NILP (test_result))
dec40cd2
DH
3276 RETURN (SCM_BOOL_F);
3277 else
3278 x = SCM_CDR (x);
3279 }
3280 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
3281 goto carloop;
0f2d19dd 3282
7e6e6b37 3283 case (ISYMNUM (SCM_IM_BEGIN)):
dec40cd2
DH
3284 x = SCM_CDR (x);
3285 if (SCM_NULLP (x))
3286 RETURN (SCM_UNSPECIFIED);
b8113bc8 3287
dec40cd2 3288 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
0f2d19dd 3289
dec40cd2
DH
3290 begin:
3291 /* If we are on toplevel with a lookup closure, we need to sync
3292 with the current module. */
3293 if (SCM_CONSP (env) && !SCM_CONSP (SCM_CAR (env)))
3294 {
3295 UPDATE_TOPLEVEL_ENV (env);
3296 while (!SCM_NULLP (SCM_CDR (x)))
3297 {
3298 EVALCAR (x, env);
3299 UPDATE_TOPLEVEL_ENV (env);
3300 x = SCM_CDR (x);
3301 }
3302 goto carloop;
3303 }
3304 else
3305 goto nontoplevel_begin;
5280aaca 3306
dec40cd2
DH
3307 nontoplevel_begin:
3308 while (!SCM_NULLP (SCM_CDR (x)))
3309 {
b1cb24ff 3310 const SCM form = SCM_CAR (x);
dec40cd2
DH
3311 if (SCM_IMP (form))
3312 {
3313 if (SCM_ISYMP (form))
3314 {
3315 scm_rec_mutex_lock (&source_mutex);
3316 /* check for race condition */
3317 if (SCM_ISYMP (SCM_CAR (x)))
3318 m_expand_body (x, env);
3319 scm_rec_mutex_unlock (&source_mutex);
3320 goto nontoplevel_begin;
3321 }
3322 else
3323 SCM_VALIDATE_NON_EMPTY_COMBINATION (form);
3324 }
3325 else
b1cb24ff 3326 (void) EVAL (form, env);
dec40cd2
DH
3327 x = SCM_CDR (x);
3328 }
b1cb24ff 3329
dec40cd2
DH
3330 carloop:
3331 {
3332 /* scm_eval last form in list */
b1cb24ff 3333 const SCM last_form = SCM_CAR (x);
0f2d19dd 3334
dec40cd2
DH
3335 if (SCM_CONSP (last_form))
3336 {
3337 /* This is by far the most frequent case. */
3338 x = last_form;
3339 goto loop; /* tail recurse */
3340 }
3341 else if (SCM_IMP (last_form))
3342 RETURN (SCM_EVALIM (last_form, env));
3343 else if (SCM_VARIABLEP (last_form))
3344 RETURN (SCM_VARIABLE_REF (last_form));
3345 else if (SCM_SYMBOLP (last_form))
3346 RETURN (*scm_lookupcar (x, env, 1));
3347 else
3348 RETURN (last_form);
3349 }
0f2d19dd
JB
3350
3351
7e6e6b37 3352 case (ISYMNUM (SCM_IM_CASE)):
dec40cd2
DH
3353 x = SCM_CDR (x);
3354 {
b1cb24ff 3355 const SCM key = EVALCAR (x, env);
dec40cd2
DH
3356 x = SCM_CDR (x);
3357 while (!SCM_NULLP (x))
3358 {
b1cb24ff 3359 const SCM clause = SCM_CAR (x);
dec40cd2
DH
3360 SCM labels = SCM_CAR (clause);
3361 if (SCM_EQ_P (labels, SCM_IM_ELSE))
3362 {
3363 x = SCM_CDR (clause);
3364 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
3365 goto begin;
3366 }
3367 while (!SCM_NULLP (labels))
3368 {
b1cb24ff 3369 const SCM label = SCM_CAR (labels);
dec40cd2 3370 if (SCM_EQ_P (label, key)
7888309b 3371 || scm_is_true (scm_eqv_p (label, key)))
dec40cd2
DH
3372 {
3373 x = SCM_CDR (clause);
3374 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
3375 goto begin;
3376 }
3377 labels = SCM_CDR (labels);
3378 }
3379 x = SCM_CDR (x);
3380 }
3381 }
3382 RETURN (SCM_UNSPECIFIED);
0f2d19dd
JB
3383
3384
7e6e6b37 3385 case (ISYMNUM (SCM_IM_COND)):
dec40cd2
DH
3386 x = SCM_CDR (x);
3387 while (!SCM_NULLP (x))
3388 {
b1cb24ff 3389 const SCM clause = SCM_CAR (x);
dec40cd2
DH
3390 if (SCM_EQ_P (SCM_CAR (clause), SCM_IM_ELSE))
3391 {
3392 x = SCM_CDR (clause);
3393 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
3394 goto begin;
3395 }
3396 else
3397 {
3398 arg1 = EVALCAR (clause, env);
7888309b 3399 if (scm_is_true (arg1) && !SCM_NILP (arg1))
dec40cd2
DH
3400 {
3401 x = SCM_CDR (clause);
3402 if (SCM_NULLP (x))
3403 RETURN (arg1);
3404 else if (!SCM_EQ_P (SCM_CAR (x), SCM_IM_ARROW))
3405 {
3406 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
3407 goto begin;
3408 }
3409 else
3410 {
3411 proc = SCM_CDR (x);
3412 proc = EVALCAR (proc, env);
3413 PREP_APPLY (proc, scm_list_1 (arg1));
3414 ENTER_APPLY;
3415 goto evap1;
3416 }
3417 }
3418 x = SCM_CDR (x);
3419 }
3420 }
3421 RETURN (SCM_UNSPECIFIED);
e5cb71a0 3422
e5cb71a0 3423
7e6e6b37 3424 case (ISYMNUM (SCM_IM_DO)):
dec40cd2
DH
3425 x = SCM_CDR (x);
3426 {
3427 /* Compute the initialization values and the initial environment. */
3428 SCM init_forms = SCM_CAR (x);
3429 SCM init_values = SCM_EOL;
3430 while (!SCM_NULLP (init_forms))
3431 {
3432 init_values = scm_cons (EVALCAR (init_forms, env), init_values);
3433 init_forms = SCM_CDR (init_forms);
3434 }
3435 x = SCM_CDR (x);
3436 env = SCM_EXTEND_ENV (SCM_CAR (x), init_values, env);
3437 }
3438 x = SCM_CDR (x);
3439 {
3440 SCM test_form = SCM_CAR (x);
3441 SCM body_forms = SCM_CADR (x);
3442 SCM step_forms = SCM_CDDR (x);
e5cb71a0 3443
dec40cd2 3444 SCM test_result = EVALCAR (test_form, env);
e5cb71a0 3445
7888309b 3446 while (scm_is_false (test_result) || SCM_NILP (test_result))
dec40cd2
DH
3447 {
3448 {
3449 /* Evaluate body forms. */
3450 SCM temp_forms;
3451 for (temp_forms = body_forms;
3452 !SCM_NULLP (temp_forms);
3453 temp_forms = SCM_CDR (temp_forms))
3454 {
3455 SCM form = SCM_CAR (temp_forms);
b1cb24ff
DH
3456 /* Dirk:FIXME: We only need to eval forms that may have
3457 * a side effect here. This is only true for forms that
3458 * start with a pair. All others are just constants.
3459 * Since with the current memoizer 'form' may hold a
3460 * constant, we call EVAL here to handle the constant
3461 * cases. In the long run it would make sense to have
3462 * the macro transformer of 'do' eliminate all forms
3463 * that have no sideeffect. Then instead of EVAL we
3464 * could call CEVAL directly here. */
3465 (void) EVAL (form, env);
dec40cd2
DH
3466 }
3467 }
0f2d19dd 3468
dec40cd2
DH
3469 {
3470 /* Evaluate the step expressions. */
3471 SCM temp_forms;
3472 SCM step_values = SCM_EOL;
3473 for (temp_forms = step_forms;
3474 !SCM_NULLP (temp_forms);
3475 temp_forms = SCM_CDR (temp_forms))
3476 {
b1cb24ff 3477 const SCM value = EVALCAR (temp_forms, env);
dec40cd2
DH
3478 step_values = scm_cons (value, step_values);
3479 }
3480 env = SCM_EXTEND_ENV (SCM_CAAR (env),
3481 step_values,
3482 SCM_CDR (env));
3483 }
0f2d19dd 3484
dec40cd2
DH
3485 test_result = EVALCAR (test_form, env);
3486 }
3487 }
3488 x = SCM_CDAR (x);
3489 if (SCM_NULLP (x))
3490 RETURN (SCM_UNSPECIFIED);
3491 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
3492 goto nontoplevel_begin;
0f2d19dd
JB
3493
3494
7e6e6b37 3495 case (ISYMNUM (SCM_IM_IF)):
dec40cd2
DH
3496 x = SCM_CDR (x);
3497 {
3498 SCM test_result = EVALCAR (x, env);
3499 x = SCM_CDR (x); /* then expression */
7888309b 3500 if (scm_is_false (test_result) || SCM_NILP (test_result))
dec40cd2
DH
3501 {
3502 x = SCM_CDR (x); /* else expression */
3503 if (SCM_NULLP (x))
3504 RETURN (SCM_UNSPECIFIED);
3505 }
3506 }
3507 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
3508 goto carloop;
0f2d19dd
JB
3509
3510
7e6e6b37 3511 case (ISYMNUM (SCM_IM_LET)):
dec40cd2
DH
3512 x = SCM_CDR (x);
3513 {
3514 SCM init_forms = SCM_CADR (x);
3515 SCM init_values = SCM_EOL;
3516 do
3517 {
3518 init_values = scm_cons (EVALCAR (init_forms, env), init_values);
3519 init_forms = SCM_CDR (init_forms);
3520 }
3521 while (!SCM_NULLP (init_forms));
3522 env = SCM_EXTEND_ENV (SCM_CAR (x), init_values, env);
3523 }
3524 x = SCM_CDDR (x);
3525 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
3526 goto nontoplevel_begin;
0f2d19dd
JB
3527
3528
7e6e6b37 3529 case (ISYMNUM (SCM_IM_LETREC)):
dec40cd2
DH
3530 x = SCM_CDR (x);
3531 env = SCM_EXTEND_ENV (SCM_CAR (x), undefineds, env);
3532 x = SCM_CDR (x);
3533 {
3534 SCM init_forms = SCM_CAR (x);
3535 SCM init_values = SCM_EOL;
3536 do
3537 {
3538 init_values = scm_cons (EVALCAR (init_forms, env), init_values);
3539 init_forms = SCM_CDR (init_forms);
3540 }
3541 while (!SCM_NULLP (init_forms));
3542 SCM_SETCDR (SCM_CAR (env), init_values);
3543 }
3544 x = SCM_CDR (x);
3545 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
3546 goto nontoplevel_begin;
0f2d19dd 3547
302c12b4 3548
7e6e6b37 3549 case (ISYMNUM (SCM_IM_LETSTAR)):
dec40cd2
DH
3550 x = SCM_CDR (x);
3551 {
3552 SCM bindings = SCM_CAR (x);
212e58ed 3553 if (!SCM_NULLP (bindings))
dec40cd2
DH
3554 {
3555 do
3556 {
3557 SCM name = SCM_CAR (bindings);
3558 SCM init = SCM_CDR (bindings);
3559 env = SCM_EXTEND_ENV (name, EVALCAR (init, env), env);
3560 bindings = SCM_CDR (init);
3561 }
3562 while (!SCM_NULLP (bindings));
3563 }
3564 }
3565 x = SCM_CDR (x);
3566 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
3567 goto nontoplevel_begin;
0f2d19dd
JB
3568
3569
7e6e6b37 3570 case (ISYMNUM (SCM_IM_OR)):
dec40cd2
DH
3571 x = SCM_CDR (x);
3572 while (!SCM_NULLP (SCM_CDR (x)))
3573 {
3574 SCM val = EVALCAR (x, env);
7888309b 3575 if (scm_is_true (val) && !SCM_NILP (val))
dec40cd2
DH
3576 RETURN (val);
3577 else
3578 x = SCM_CDR (x);
3579 }
3580 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
3581 goto carloop;
0f2d19dd
JB
3582
3583
7e6e6b37 3584 case (ISYMNUM (SCM_IM_LAMBDA)):
dec40cd2 3585 RETURN (scm_closure (SCM_CDR (x), env));
0f2d19dd
JB
3586
3587
7e6e6b37 3588 case (ISYMNUM (SCM_IM_QUOTE)):
e7313a9d 3589 RETURN (SCM_CDR (x));
0f2d19dd
JB
3590
3591
7e6e6b37 3592 case (ISYMNUM (SCM_IM_SET_X)):
dec40cd2
DH
3593 x = SCM_CDR (x);
3594 {
3595 SCM *location;
3596 SCM variable = SCM_CAR (x);
3597 if (SCM_ILOCP (variable))
3598 location = scm_ilookup (variable, env);
3599 else if (SCM_VARIABLEP (variable))
3600 location = SCM_VARIABLE_LOC (variable);
36245b66
DH
3601 else
3602 {
3603 /* (SCM_SYMBOLP (variable)) is known to be true */
3604 variable = lazy_memoize_variable (variable, env);
3605 SCM_SETCAR (x, variable);
3606 location = SCM_VARIABLE_LOC (variable);
3607 }
dec40cd2
DH
3608 x = SCM_CDR (x);
3609 *location = EVALCAR (x, env);
3610 }
3611 RETURN (SCM_UNSPECIFIED);
3f04400d
DH
3612
3613
7e6e6b37 3614 case (ISYMNUM (SCM_IM_APPLY)):
6bff1368 3615 /* Evaluate the procedure to be applied. */
e910e9d2
DH
3616 x = SCM_CDR (x);
3617 proc = EVALCAR (x, env);
3618 PREP_APPLY (proc, SCM_EOL);
6bff1368
DH
3619
3620 /* Evaluate the argument holding the list of arguments */
e910e9d2
DH
3621 x = SCM_CDR (x);
3622 arg1 = EVALCAR (x, env);
9a069bdd
DH
3623
3624 apply_proc:
3625 /* Go here to tail-apply a procedure. PROC is the procedure and
3626 * ARG1 is the list of arguments. PREP_APPLY must have been called
3627 * before jumping to apply_proc. */
0f2d19dd
JB
3628 if (SCM_CLOSUREP (proc))
3629 {
9a069bdd 3630 SCM formals = SCM_CLOSURE_FORMALS (proc);
6dbd0af5 3631#ifdef DEVAL
9a069bdd 3632 debug.info->a.args = arg1;
6dbd0af5 3633#endif
9a069bdd
DH
3634 if (scm_badargsp (formals, arg1))
3635 scm_wrong_num_args (proc);
3636 ENTER_APPLY;
3637 /* Copy argument list */
3638 if (SCM_NULL_OR_NIL_P (arg1))
3639 env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc));
3640 else
3641 {
3642 SCM args = scm_list_1 (SCM_CAR (arg1));
3643 SCM tail = args;
3644 arg1 = SCM_CDR (arg1);
3645 while (!SCM_NULL_OR_NIL_P (arg1))
3646 {
3647 SCM new_tail = scm_list_1 (SCM_CAR (arg1));
3648 SCM_SETCDR (tail, new_tail);
3649 tail = new_tail;
3650 arg1 = SCM_CDR (arg1);
3651 }
3652 env = SCM_EXTEND_ENV (formals, args, SCM_ENV (proc));
3653 }
3654
3655 x = SCM_CLOSURE_BODY (proc);
3656 goto nontoplevel_begin;
0f2d19dd 3657 }
3f04400d
DH
3658 else
3659 {
e910e9d2
DH
3660 ENTER_APPLY;
3661 RETURN (SCM_APPLY (proc, arg1, SCM_EOL));
3f04400d
DH
3662 }
3663
0f2d19dd 3664
7e6e6b37 3665 case (ISYMNUM (SCM_IM_CONT)):
5f144b10
GH
3666 {
3667 int first;
3668 SCM val = scm_make_continuation (&first);
3669
e050d4f8 3670 if (!first)
5f144b10 3671 RETURN (val);
e050d4f8
DH
3672 else
3673 {
3674 arg1 = val;
3675 proc = SCM_CDR (x);
6bff1368 3676 proc = EVALCAR (proc, env);
e050d4f8
DH
3677 PREP_APPLY (proc, scm_list_1 (arg1));
3678 ENTER_APPLY;
e050d4f8
DH
3679 goto evap1;
3680 }
5f144b10 3681 }
e050d4f8 3682
0f2d19dd 3683
7e6e6b37 3684 case (ISYMNUM (SCM_IM_DELAY)):
ddea3325 3685 RETURN (scm_makprom (scm_closure (SCM_CDR (x), env)));
a570e93a 3686
e050d4f8 3687
7e6e6b37 3688 case (ISYMNUM (SCM_IM_FUTURE)):
28d52ebb
MD
3689 RETURN (scm_i_make_future (scm_closure (SCM_CDR (x), env)));
3690
3691
7e6e6b37
DH
3692 /* PLACEHOLDER for case (ISYMNUM (SCM_IM_DISPATCH)): The following
3693 code (type_dispatch) is intended to be the tail of the case
3694 clause for the internal macro SCM_IM_DISPATCH. Please don't
3695 remove it from this location without discussing it with Mikael
c8e1d354
MD
3696 <djurfeldt@nada.kth.se> */
3697
f12745b6
DH
3698 /* The type dispatch code is duplicated below
3699 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
3700 * cuts down execution time for type dispatch to 50%. */
dff98306 3701 type_dispatch: /* inputs: x, arg1 */
f12745b6
DH
3702 /* Type dispatch means to determine from the types of the function
3703 * arguments (i. e. the 'signature' of the call), which method from
3704 * a generic function is to be called. This process of selecting
3705 * the right method takes some time. To speed it up, guile uses
3706 * caching: Together with the macro call to dispatch the signatures
3707 * of some previous calls to that generic function from the same
3708 * place are stored (in the code!) in a cache that we call the
3709 * 'method cache'. This is done since it is likely, that
3710 * consecutive calls to dispatch from that position in the code will
3711 * have the same signature. Thus, the type dispatch works as
3712 * follows: First, determine a hash value from the signature of the
3713 * actual arguments. Second, use this hash value as an index to
3714 * find that same signature in the method cache stored at this
3715 * position in the code. If found, you have also found the
3716 * corresponding method that belongs to that signature. If the
3717 * signature is not found in the method cache, you have to perform a
3718 * full search over all signatures stored with the generic
3719 * function. */
3720 {
3721 unsigned long int specializers;
3722 unsigned long int hash_value;
3723 unsigned long int cache_end_pos;
3724 unsigned long int mask;
3725 SCM method_cache;
3726
3727 {
3728 SCM z = SCM_CDDR (x);
3729 SCM tmp = SCM_CADR (z);
3730 specializers = SCM_INUM (SCM_CAR (z));
3731
3732 /* Compute a hash value for searching the method cache. There
3733 * are two variants for computing the hash value, a (rather)
3734 * complicated one, and a simple one. For the complicated one
3735 * explained below, tmp holds a number that is used in the
3736 * computation. */
3737 if (SCM_INUMP (tmp))
3738 {
3739 /* Use the signature of the actual arguments to determine
3740 * the hash value. This is done as follows: Each class has
3741 * an array of random numbers, that are determined when the
3742 * class is created. The integer 'hashset' is an index into
3743 * that array of random numbers. Now, from all classes that
3744 * are part of the signature of the actual arguments, the
3745 * random numbers at index 'hashset' are taken and summed
3746 * up, giving the hash value. The value of 'hashset' is
3747 * stored at the call to dispatch. This allows to have
3748 * different 'formulas' for calculating the hash value at
3749 * different places where dispatch is called. This allows
3750 * to optimize the hash formula at every individual place
3751 * where dispatch is called, such that hopefully the hash
3752 * value that is computed will directly point to the right
3753 * method in the method cache. */
3754 unsigned long int hashset = SCM_INUM (tmp);
3755 unsigned long int counter = specializers + 1;
dff98306 3756 SCM tmp_arg = arg1;
f12745b6
DH
3757 hash_value = 0;
3758 while (!SCM_NULLP (tmp_arg) && counter != 0)
61364ba6 3759 {
f12745b6
DH
3760 SCM class = scm_class_of (SCM_CAR (tmp_arg));
3761 hash_value += SCM_INSTANCE_HASH (class, hashset);
3762 tmp_arg = SCM_CDR (tmp_arg);
3763 counter--;
61364ba6 3764 }
f12745b6
DH
3765 z = SCM_CDDR (z);
3766 method_cache = SCM_CADR (z);
3767 mask = SCM_INUM (SCM_CAR (z));
3768 hash_value &= mask;
3769 cache_end_pos = hash_value;
3770 }
3771 else
3772 {
3773 /* This method of determining the hash value is much
3774 * simpler: Set the hash value to zero and just perform a
3775 * linear search through the method cache. */
3776 method_cache = tmp;
3777 mask = (unsigned long int) ((long) -1);
3778 hash_value = 0;
3779 cache_end_pos = SCM_VECTOR_LENGTH (method_cache);
3780 }
3781 }
61364ba6 3782
f12745b6
DH
3783 {
3784 /* Search the method cache for a method with a matching
3785 * signature. Start the search at position 'hash_value'. The
3786 * hashing implementation uses linear probing for conflict
3787 * resolution, that is, if the signature in question is not
3788 * found at the starting index in the hash table, the next table
3789 * entry is tried, and so on, until in the worst case the whole
3790 * cache has been searched, but still the signature has not been
3791 * found. */
3792 SCM z;
3793 do
3794 {
dff98306 3795 SCM args = arg1; /* list of arguments */
f12745b6
DH
3796 z = SCM_VELTS (method_cache)[hash_value];
3797 while (!SCM_NULLP (args))
61364ba6
MD
3798 {
3799 /* More arguments than specifiers => CLASS != ENV */
f12745b6
DH
3800 SCM class_of_arg = scm_class_of (SCM_CAR (args));
3801 if (!SCM_EQ_P (class_of_arg, SCM_CAR (z)))
61364ba6 3802 goto next_method;
f12745b6 3803 args = SCM_CDR (args);
61364ba6
MD
3804 z = SCM_CDR (z);
3805 }
f12745b6
DH
3806 /* Fewer arguments than specifiers => CAR != ENV */
3807 if (SCM_NULLP (SCM_CAR (z)) || SCM_CONSP (SCM_CAR (z)))
3808 goto apply_cmethod;
3809 next_method:
3810 hash_value = (hash_value + 1) & mask;
3811 } while (hash_value != cache_end_pos);
3812
3813 /* No appropriate method was found in the cache. */
dff98306 3814 z = scm_memoize_method (x, arg1);
f12745b6 3815
dff98306 3816 apply_cmethod: /* inputs: z, arg1 */
f12745b6
DH
3817 {
3818 SCM formals = SCM_CMETHOD_FORMALS (z);
821f18a4 3819 env = SCM_EXTEND_ENV (formals, arg1, SCM_CMETHOD_ENV (z));
f12745b6
DH
3820 x = SCM_CMETHOD_BODY (z);
3821 goto nontoplevel_begin;
3822 }
3823 }
61364ba6 3824 }
73b64342 3825
1d15ecd3 3826
7e6e6b37 3827 case (ISYMNUM (SCM_IM_SLOT_REF)):
ca4be6ea 3828 x = SCM_CDR (x);
1d15ecd3
DH
3829 {
3830 SCM instance = EVALCAR (x, env);
e7313a9d 3831 unsigned long int slot = SCM_INUM (SCM_CDR (x));
1d15ecd3
DH
3832 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot]));
3833 }
3834
3835
7e6e6b37 3836 case (ISYMNUM (SCM_IM_SLOT_SET_X)):
ca4be6ea 3837 x = SCM_CDR (x);
1d15ecd3
DH
3838 {
3839 SCM instance = EVALCAR (x, env);
3840 unsigned long int slot = SCM_INUM (SCM_CADR (x));
3841 SCM value = EVALCAR (SCM_CDDR (x), env);
3842 SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (value);
3843 RETURN (SCM_UNSPECIFIED);
3844 }
3845
c96d76b8 3846
22721140 3847#if SCM_ENABLE_ELISP
ca4be6ea 3848
7e6e6b37 3849 case (ISYMNUM (SCM_IM_NIL_COND)):
1d15ecd3
DH
3850 {
3851 SCM test_form = SCM_CDR (x);
3852 x = SCM_CDR (test_form);
3853 while (!SCM_NULL_OR_NIL_P (x))
3854 {
3855 SCM test_result = EVALCAR (test_form, env);
7888309b 3856 if (!(scm_is_false (test_result)
1d15ecd3
DH
3857 || SCM_NULL_OR_NIL_P (test_result)))
3858 {
3859 if (SCM_EQ_P (SCM_CAR (x), SCM_UNSPECIFIED))
3860 RETURN (test_result);
3861 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
3862 goto carloop;
3863 }
3864 else
3865 {
3866 test_form = SCM_CDR (x);
3867 x = SCM_CDR (test_form);
3868 }
3869 }
3870 x = test_form;
3871 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
3872 goto carloop;
3873 }
73b64342 3874
c96d76b8 3875#endif /* SCM_ENABLE_ELISP */
73b64342 3876
7e6e6b37 3877 case (ISYMNUM (SCM_IM_BIND)):
2e171178
MV
3878 {
3879 SCM vars, exps, vals;
73b64342 3880
2e171178
MV
3881 x = SCM_CDR (x);
3882 vars = SCM_CAAR (x);
3883 exps = SCM_CDAR (x);
2e171178 3884 vals = SCM_EOL;
82b3e2c6 3885 while (!SCM_NULLP (exps))
2e171178
MV
3886 {
3887 vals = scm_cons (EVALCAR (exps, env), vals);
3888 exps = SCM_CDR (exps);
3889 }
3890
3891 scm_swap_bindings (vars, vals);
3892 scm_dynwinds = scm_acons (vars, vals, scm_dynwinds);
1d15ecd3
DH
3893
3894 /* Ignore all but the last evaluation result. */
3895 for (x = SCM_CDR (x); !SCM_NULLP (SCM_CDR (x)); x = SCM_CDR (x))
2e171178 3896 {
1d15ecd3 3897 if (SCM_CONSP (SCM_CAR (x)))
434f2f7a 3898 CEVAL (SCM_CAR (x), env);
2e171178
MV
3899 }
3900 proc = EVALCAR (x, env);
73b64342 3901
2e171178
MV
3902 scm_dynwinds = SCM_CDR (scm_dynwinds);
3903 scm_swap_bindings (vars, vals);
73b64342 3904
ddea3325 3905 RETURN (proc);
2e171178 3906 }
c96d76b8 3907
1d15ecd3 3908
7e6e6b37 3909 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
a513ead3 3910 {
9a069bdd
DH
3911 SCM producer;
3912
3913 x = SCM_CDR (x);
3914 producer = EVALCAR (x, env);
3915 x = SCM_CDR (x);
3916 proc = EVALCAR (x, env); /* proc is the consumer. */
3917 arg1 = SCM_APPLY (producer, SCM_EOL, SCM_EOL);
dff98306 3918 if (SCM_VALUESP (arg1))
82b3e2c6
DH
3919 {
3920 /* The list of arguments is not copied. Rather, it is assumed
3921 * that this has been done by the 'values' procedure. */
3922 arg1 = scm_struct_ref (arg1, SCM_INUM0);
3923 }
a513ead3 3924 else
82b3e2c6
DH
3925 {
3926 arg1 = scm_list_1 (arg1);
3927 }
9a069bdd
DH
3928 PREP_APPLY (proc, arg1);
3929 goto apply_proc;
a513ead3
MV
3930 }
3931
b7798e10 3932
0f2d19dd 3933 default:
dec40cd2 3934 break;
0f2d19dd 3935 }
dec40cd2
DH
3936 }
3937 else
3938 {
434f2f7a
DH
3939 if (SCM_VARIABLEP (SCM_CAR (x)))
3940 proc = SCM_VARIABLE_REF (SCM_CAR (x));
f9986767
DH
3941 else if (SCM_ILOCP (SCM_CAR (x)))
3942 proc = *scm_ilookup (SCM_CAR (x), env);
434f2f7a
DH
3943 else if (SCM_CONSP (SCM_CAR (x)))
3944 proc = CEVAL (SCM_CAR (x), env);
3945 else if (SCM_SYMBOLP (SCM_CAR (x)))
0f2d19dd 3946 {
e050d4f8 3947 SCM orig_sym = SCM_CAR (x);
b7798e10
DH
3948 {
3949 SCM *location = scm_lookupcar1 (x, env, 1);
3950 if (location == NULL)
3951 {
3952 /* we have lost the race, start again. */
3953 goto dispatch;
3954 }
3955 proc = *location;
3956 }
f8769b1d 3957
22a52da1 3958 if (SCM_MACROP (proc))
0f2d19dd 3959 {
86d31dfe
MV
3960 SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of
3961 lookupcar */
e050d4f8 3962 handle_a_macro: /* inputs: x, env, proc */
368bf056 3963#ifdef DEVAL
7c354052
MD
3964 /* Set a flag during macro expansion so that macro
3965 application frames can be deleted from the backtrace. */
3966 SCM_SET_MACROEXP (debug);
368bf056 3967#endif
dff98306 3968 arg1 = SCM_APPLY (SCM_MACRO_CODE (proc), x,
6bff1368 3969 scm_cons (env, scm_listofnull));
7c354052
MD
3970#ifdef DEVAL
3971 SCM_CLEAR_MACROEXP (debug);
3972#endif
22a52da1 3973 switch (SCM_MACRO_TYPE (proc))
0f2d19dd 3974 {
3b88ed2a 3975 case 3:
0f2d19dd 3976 case 2:
e7313a9d 3977 if (!SCM_CONSP (arg1))
dff98306 3978 arg1 = scm_list_2 (SCM_IM_BEGIN, arg1);
e7313a9d
DH
3979
3980 assert (!SCM_EQ_P (x, SCM_CAR (arg1))
3981 && !SCM_EQ_P (x, SCM_CDR (arg1)));
3982
6dbd0af5 3983#ifdef DEVAL
22a52da1 3984 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc)))
6dbd0af5 3985 {
6dbd0af5 3986 SCM_DEFER_INTS;
dff98306
DH
3987 SCM_SETCAR (x, SCM_CAR (arg1));
3988 SCM_SETCDR (x, SCM_CDR (arg1));
6dbd0af5
MD
3989 SCM_ALLOW_INTS;
3990 goto dispatch;
3991 }
3992 /* Prevent memoizing of debug info expression. */
6203706f
MD
3993 debug.info->e.exp = scm_cons_source (debug.info->e.exp,
3994 SCM_CAR (x),
3995 SCM_CDR (x));
6dbd0af5 3996#endif
0f2d19dd 3997 SCM_DEFER_INTS;
dff98306
DH
3998 SCM_SETCAR (x, SCM_CAR (arg1));
3999 SCM_SETCDR (x, SCM_CDR (arg1));
0f2d19dd 4000 SCM_ALLOW_INTS;
680516ba
DH
4001 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
4002 goto loop;
3063e30a 4003#if SCM_ENABLE_DEPRECATED == 1
0f2d19dd 4004 case 1:
680516ba
DH
4005 x = arg1;
4006 if (SCM_NIMP (x))
4007 {
4008 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
4009 goto loop;
4010 }
4011 else
4012 RETURN (arg1);
3063e30a 4013#endif
0f2d19dd 4014 case 0:
dff98306 4015 RETURN (arg1);
0f2d19dd
JB
4016 }
4017 }
4018 }
4019 else
434f2f7a 4020 proc = SCM_CAR (x);
bd987b8e 4021
ddd8f927 4022 if (SCM_MACROP (proc))
0f2d19dd 4023 goto handle_a_macro;
0f2d19dd
JB
4024 }
4025
4026
dec40cd2
DH
4027 /* When reaching this part of the code, the following is granted: Variable x
4028 * holds the first pair of an expression of the form (<function> arg ...).
4029 * Variable proc holds the object that resulted from the evaluation of
4030 * <function>. In the following, the arguments (if any) will be evaluated,
4031 * and proc will be applied to them. If proc does not really hold a
4032 * function object, this will be signalled as an error on the scheme
4033 * level. If the number of arguments does not match the number of arguments
4034 * that are allowed to be passed to proc, also an error on the scheme level
4035 * will be signalled. */
6dbd0af5
MD
4036 PREP_APPLY (proc, SCM_EOL);
4037 if (SCM_NULLP (SCM_CDR (x))) {
4038 ENTER_APPLY;
89efbff4 4039 evap0:
ddd8f927 4040 SCM_ASRTGO (!SCM_IMP (proc), badfun);
0f2d19dd
JB
4041 switch (SCM_TYP7 (proc))
4042 { /* no arguments given */
4043 case scm_tc7_subr_0:
4044 RETURN (SCM_SUBRF (proc) ());
4045 case scm_tc7_subr_1o:
4046 RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED));
4047 case scm_tc7_lsubr:
4048 RETURN (SCM_SUBRF (proc) (SCM_EOL));
4049 case scm_tc7_rpsubr:
4050 RETURN (SCM_BOOL_T);
4051 case scm_tc7_asubr:
4052 RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED));
0717dfd8 4053 case scm_tc7_smob:
68b06924 4054 if (!SCM_SMOB_APPLICABLE_P (proc))
0717dfd8 4055 goto badfun;
68b06924 4056 RETURN (SCM_SMOB_APPLY_0 (proc));
0f2d19dd 4057 case scm_tc7_cclo:
dff98306 4058 arg1 = proc;
0f2d19dd 4059 proc = SCM_CCLO_SUBR (proc);
6dbd0af5
MD
4060#ifdef DEVAL
4061 debug.info->a.proc = proc;
dff98306 4062 debug.info->a.args = scm_list_1 (arg1);
6dbd0af5 4063#endif
0f2d19dd 4064 goto evap1;
89efbff4
MD
4065 case scm_tc7_pws:
4066 proc = SCM_PROCEDURE (proc);
4067#ifdef DEVAL
4068 debug.info->a.proc = proc;
4069#endif
002f1a5d
MD
4070 if (!SCM_CLOSUREP (proc))
4071 goto evap0;
ddd8f927 4072 /* fallthrough */
0f2d19dd 4073 case scm_tcs_closures:
ddd8f927
DH
4074 {
4075 const SCM formals = SCM_CLOSURE_FORMALS (proc);
4076 if (SCM_CONSP (formals))
212e58ed 4077 goto wrongnumargs;
ddd8f927
DH
4078 x = SCM_CLOSURE_BODY (proc);
4079 env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc));
4080 goto nontoplevel_begin;
4081 }
904a077d 4082 case scm_tcs_struct:
195847fa
MD
4083 if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
4084 {
4085 x = SCM_ENTITY_PROCEDURE (proc);
dff98306 4086 arg1 = SCM_EOL;
195847fa
MD
4087 goto type_dispatch;
4088 }
2ca0d207 4089 else if (SCM_I_OPERATORP (proc))
da7f71d7 4090 {
dff98306 4091 arg1 = proc;
195847fa
MD
4092 proc = (SCM_I_ENTITYP (proc)
4093 ? SCM_ENTITY_PROCEDURE (proc)
4094 : SCM_OPERATOR_PROCEDURE (proc));
da7f71d7 4095#ifdef DEVAL
195847fa 4096 debug.info->a.proc = proc;
dff98306 4097 debug.info->a.args = scm_list_1 (arg1);
da7f71d7 4098#endif
ddd8f927 4099 goto evap1;
da7f71d7 4100 }
2ca0d207
DH
4101 else
4102 goto badfun;
0f2d19dd
JB
4103 case scm_tc7_subr_1:
4104 case scm_tc7_subr_2:
4105 case scm_tc7_subr_2o:
14b18ed6 4106 case scm_tc7_dsubr:
0f2d19dd
JB
4107 case scm_tc7_cxr:
4108 case scm_tc7_subr_3:
4109 case scm_tc7_lsubr_2:
212e58ed 4110 wrongnumargs:
f5bf2977 4111 scm_wrong_num_args (proc);
0f2d19dd 4112 default:
ddd8f927
DH
4113 badfun:
4114 scm_misc_error (NULL, "Wrong type to apply: ~S", scm_list_1 (proc));
0f2d19dd 4115 }
6dbd0af5 4116 }
0f2d19dd
JB
4117
4118 /* must handle macros by here */
4119 x = SCM_CDR (x);
dff98306
DH
4120 if (SCM_CONSP (x))
4121 arg1 = EVALCAR (x, env);
680ed4a8 4122 else
ab1f1094 4123 scm_wrong_num_args (proc);
6dbd0af5 4124#ifdef DEVAL
dff98306 4125 debug.info->a.args = scm_list_1 (arg1);
6dbd0af5 4126#endif
0f2d19dd 4127 x = SCM_CDR (x);
42030fb2
DH
4128 {
4129 SCM arg2;
4130 if (SCM_NULLP (x))
4131 {
4132 ENTER_APPLY;
4133 evap1: /* inputs: proc, arg1 */
ddd8f927 4134 SCM_ASRTGO (!SCM_IMP (proc), badfun);
42030fb2
DH
4135 switch (SCM_TYP7 (proc))
4136 { /* have one argument in arg1 */
4137 case scm_tc7_subr_2o:
4138 RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
4139 case scm_tc7_subr_1:
4140 case scm_tc7_subr_1o:
4141 RETURN (SCM_SUBRF (proc) (arg1));
14b18ed6
DH
4142 case scm_tc7_dsubr:
4143 if (SCM_INUMP (arg1))
4144 {
4145 RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1))));
4146 }
4147 else if (SCM_REALP (arg1))
4148 {
4149 RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
4150 }
4151 else if (SCM_BIGP (arg1))
4152 {
4153 RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
4154 }
f92e85f7
MV
4155 else if (SCM_FRACTIONP (arg1))
4156 {
4157 RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1))));
4158 }
4159 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
14b18ed6 4160 SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc)));
42030fb2 4161 case scm_tc7_cxr:
42030fb2 4162 {
14b18ed6
DH
4163 unsigned char pattern = (scm_t_bits) SCM_SUBRF (proc);
4164 do
4165 {
4166 SCM_ASSERT (SCM_CONSP (arg1), arg1, SCM_ARG1,
4167 SCM_SYMBOL_CHARS (SCM_SNAME (proc)));
4168 arg1 = (pattern & 1) ? SCM_CAR (arg1) : SCM_CDR (arg1);
4169 pattern >>= 2;
4170 } while (pattern);
42030fb2 4171 RETURN (arg1);
0f2d19dd 4172 }
42030fb2
DH
4173 case scm_tc7_rpsubr:
4174 RETURN (SCM_BOOL_T);
4175 case scm_tc7_asubr:
4176 RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
4177 case scm_tc7_lsubr:
0f2d19dd 4178#ifdef DEVAL
42030fb2 4179 RETURN (SCM_SUBRF (proc) (debug.info->a.args));
0f2d19dd 4180#else
42030fb2 4181 RETURN (SCM_SUBRF (proc) (scm_list_1 (arg1)));
0f2d19dd 4182#endif
42030fb2
DH
4183 case scm_tc7_smob:
4184 if (!SCM_SMOB_APPLICABLE_P (proc))
4185 goto badfun;
4186 RETURN (SCM_SMOB_APPLY_1 (proc, arg1));
4187 case scm_tc7_cclo:
4188 arg2 = arg1;
4189 arg1 = proc;
4190 proc = SCM_CCLO_SUBR (proc);
6dbd0af5 4191#ifdef DEVAL
42030fb2
DH
4192 debug.info->a.args = scm_cons (arg1, debug.info->a.args);
4193 debug.info->a.proc = proc;
6dbd0af5 4194#endif
42030fb2
DH
4195 goto evap2;
4196 case scm_tc7_pws:
4197 proc = SCM_PROCEDURE (proc);
89efbff4 4198#ifdef DEVAL
42030fb2 4199 debug.info->a.proc = proc;
89efbff4 4200#endif
42030fb2
DH
4201 if (!SCM_CLOSUREP (proc))
4202 goto evap1;
ddd8f927 4203 /* fallthrough */
42030fb2 4204 case scm_tcs_closures:
ddd8f927
DH
4205 {
4206 /* clos1: */
4207 const SCM formals = SCM_CLOSURE_FORMALS (proc);
4208 if (SCM_NULLP (formals)
4209 || (SCM_CONSP (formals) && SCM_CONSP (SCM_CDR (formals))))
212e58ed 4210 goto wrongnumargs;
ddd8f927 4211 x = SCM_CLOSURE_BODY (proc);
0f2d19dd 4212#ifdef DEVAL
ddd8f927
DH
4213 env = SCM_EXTEND_ENV (formals,
4214 debug.info->a.args,
4215 SCM_ENV (proc));
0f2d19dd 4216#else
ddd8f927
DH
4217 env = SCM_EXTEND_ENV (formals,
4218 scm_list_1 (arg1),
4219 SCM_ENV (proc));
0f2d19dd 4220#endif
ddd8f927
DH
4221 goto nontoplevel_begin;
4222 }
42030fb2
DH
4223 case scm_tcs_struct:
4224 if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
4225 {
4226 x = SCM_ENTITY_PROCEDURE (proc);
f3d2630a 4227#ifdef DEVAL
42030fb2 4228 arg1 = debug.info->a.args;
f3d2630a 4229#else
42030fb2 4230 arg1 = scm_list_1 (arg1);
f3d2630a 4231#endif
42030fb2
DH
4232 goto type_dispatch;
4233 }
2ca0d207 4234 else if (SCM_I_OPERATORP (proc))
42030fb2
DH
4235 {
4236 arg2 = arg1;
4237 arg1 = proc;
4238 proc = (SCM_I_ENTITYP (proc)
4239 ? SCM_ENTITY_PROCEDURE (proc)
4240 : SCM_OPERATOR_PROCEDURE (proc));
0c32d76c 4241#ifdef DEVAL
42030fb2
DH
4242 debug.info->a.args = scm_cons (arg1, debug.info->a.args);
4243 debug.info->a.proc = proc;
0c32d76c 4244#endif
ddd8f927 4245 goto evap2;
42030fb2 4246 }
2ca0d207
DH
4247 else
4248 goto badfun;
42030fb2
DH
4249 case scm_tc7_subr_2:
4250 case scm_tc7_subr_0:
4251 case scm_tc7_subr_3:
4252 case scm_tc7_lsubr_2:
ab1f1094 4253 scm_wrong_num_args (proc);
42030fb2
DH
4254 default:
4255 goto badfun;
4256 }
4257 }
42030fb2
DH
4258 if (SCM_CONSP (x))
4259 arg2 = EVALCAR (x, env);
4260 else
ab1f1094 4261 scm_wrong_num_args (proc);
bd987b8e 4262
42030fb2 4263 { /* have two or more arguments */
6dbd0af5 4264#ifdef DEVAL
42030fb2 4265 debug.info->a.args = scm_list_2 (arg1, arg2);
6dbd0af5 4266#endif
42030fb2
DH
4267 x = SCM_CDR (x);
4268 if (SCM_NULLP (x)) {
4269 ENTER_APPLY;
4270 evap2:
ddd8f927 4271 SCM_ASRTGO (!SCM_IMP (proc), badfun);
42030fb2
DH
4272 switch (SCM_TYP7 (proc))
4273 { /* have two arguments */
4274 case scm_tc7_subr_2:
4275 case scm_tc7_subr_2o:
4276 RETURN (SCM_SUBRF (proc) (arg1, arg2));
4277 case scm_tc7_lsubr:
0f2d19dd 4278#ifdef DEVAL
42030fb2 4279 RETURN (SCM_SUBRF (proc) (debug.info->a.args));
6dbd0af5 4280#else
42030fb2
DH
4281 RETURN (SCM_SUBRF (proc) (scm_list_2 (arg1, arg2)));
4282#endif
4283 case scm_tc7_lsubr_2:
4284 RETURN (SCM_SUBRF (proc) (arg1, arg2, SCM_EOL));
4285 case scm_tc7_rpsubr:
4286 case scm_tc7_asubr:
4287 RETURN (SCM_SUBRF (proc) (arg1, arg2));
4288 case scm_tc7_smob:
4289 if (!SCM_SMOB_APPLICABLE_P (proc))
4290 goto badfun;
4291 RETURN (SCM_SMOB_APPLY_2 (proc, arg1, arg2));
4292 cclon:
4293 case scm_tc7_cclo:
0f2d19dd 4294#ifdef DEVAL
42030fb2
DH
4295 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc),
4296 scm_cons (proc, debug.info->a.args),
4297 SCM_EOL));
0f2d19dd 4298#else
42030fb2
DH
4299 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc),
4300 scm_cons2 (proc, arg1,
4301 scm_cons (arg2,
4302 scm_eval_args (x,
4303 env,
4304 proc))),
4305 SCM_EOL));
4306#endif
4307 case scm_tcs_struct:
4308 if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
4309 {
4310 x = SCM_ENTITY_PROCEDURE (proc);
4311#ifdef DEVAL
4312 arg1 = debug.info->a.args;
4313#else
4314 arg1 = scm_list_2 (arg1, arg2);
6dbd0af5 4315#endif
42030fb2
DH
4316 goto type_dispatch;
4317 }
2ca0d207 4318 else if (SCM_I_OPERATORP (proc))
42030fb2
DH
4319 {
4320 operatorn:
f3d2630a 4321#ifdef DEVAL
42030fb2
DH
4322 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc)
4323 ? SCM_ENTITY_PROCEDURE (proc)
4324 : SCM_OPERATOR_PROCEDURE (proc),
4325 scm_cons (proc, debug.info->a.args),
4326 SCM_EOL));
f3d2630a 4327#else
42030fb2
DH
4328 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc)
4329 ? SCM_ENTITY_PROCEDURE (proc)
4330 : SCM_OPERATOR_PROCEDURE (proc),
4331 scm_cons2 (proc, arg1,
4332 scm_cons (arg2,
4333 scm_eval_args (x,
4334 env,
4335 proc))),
4336 SCM_EOL));
f3d2630a 4337#endif
42030fb2 4338 }
2ca0d207
DH
4339 else
4340 goto badfun;
42030fb2 4341 case scm_tc7_subr_0:
14b18ed6 4342 case scm_tc7_dsubr:
42030fb2
DH
4343 case scm_tc7_cxr:
4344 case scm_tc7_subr_1o:
4345 case scm_tc7_subr_1:
4346 case scm_tc7_subr_3:
ab1f1094 4347 scm_wrong_num_args (proc);
42030fb2 4348 default:
9b07e212 4349 goto badfun;
42030fb2
DH
4350 case scm_tc7_pws:
4351 proc = SCM_PROCEDURE (proc);
4352#ifdef DEVAL
4353 debug.info->a.proc = proc;
4354#endif
4355 if (!SCM_CLOSUREP (proc))
4356 goto evap2;
ddd8f927 4357 /* fallthrough */
42030fb2 4358 case scm_tcs_closures:
ddd8f927
DH
4359 {
4360 /* clos2: */
4361 const SCM formals = SCM_CLOSURE_FORMALS (proc);
4362 if (SCM_NULLP (formals)
4363 || (SCM_CONSP (formals)
4364 && (SCM_NULLP (SCM_CDR (formals))
4365 || (SCM_CONSP (SCM_CDR (formals))
4366 && SCM_CONSP (SCM_CDDR (formals))))))
212e58ed 4367 goto wrongnumargs;
0c32d76c 4368#ifdef DEVAL
ddd8f927
DH
4369 env = SCM_EXTEND_ENV (formals,
4370 debug.info->a.args,
4371 SCM_ENV (proc));
195847fa 4372#else
ddd8f927
DH
4373 env = SCM_EXTEND_ENV (formals,
4374 scm_list_2 (arg1, arg2),
4375 SCM_ENV (proc));
195847fa 4376#endif
ddd8f927
DH
4377 x = SCM_CLOSURE_BODY (proc);
4378 goto nontoplevel_begin;
4379 }
42030fb2
DH
4380 }
4381 }
42030fb2 4382 if (!SCM_CONSP (x))
ab1f1094 4383 scm_wrong_num_args (proc);
42030fb2
DH
4384#ifdef DEVAL
4385 debug.info->a.args = scm_cons2 (arg1, arg2,
4386 deval_args (x, env, proc,
4387 SCM_CDRLOC (SCM_CDR (debug.info->a.args))));
4388#endif
4389 ENTER_APPLY;
4390 evap3:
ddd8f927 4391 SCM_ASRTGO (!SCM_IMP (proc), badfun);
42030fb2
DH
4392 switch (SCM_TYP7 (proc))
4393 { /* have 3 or more arguments */
4394#ifdef DEVAL
6dbd0af5 4395 case scm_tc7_subr_3:
ab1f1094
DH
4396 if (!SCM_NULLP (SCM_CDR (x)))
4397 scm_wrong_num_args (proc);
4398 else
4399 RETURN (SCM_SUBRF (proc) (arg1, arg2,
4400 SCM_CADDR (debug.info->a.args)));
42030fb2
DH
4401 case scm_tc7_asubr:
4402 arg1 = SCM_SUBRF(proc)(arg1, arg2);
4403 arg2 = SCM_CDDR (debug.info->a.args);
4404 do
4405 {
4406 arg1 = SCM_SUBRF(proc)(arg1, SCM_CAR (arg2));
4407 arg2 = SCM_CDR (arg2);
4408 }
4409 while (SCM_NIMP (arg2));
4410 RETURN (arg1);
4411 case scm_tc7_rpsubr:
7888309b 4412 if (scm_is_false (SCM_SUBRF (proc) (arg1, arg2)))
42030fb2
DH
4413 RETURN (SCM_BOOL_F);
4414 arg1 = SCM_CDDR (debug.info->a.args);
4415 do
4416 {
7888309b 4417 if (scm_is_false (SCM_SUBRF (proc) (arg2, SCM_CAR (arg1))))
42030fb2
DH
4418 RETURN (SCM_BOOL_F);
4419 arg2 = SCM_CAR (arg1);
4420 arg1 = SCM_CDR (arg1);
4421 }
4422 while (SCM_NIMP (arg1));
4423 RETURN (SCM_BOOL_T);
4424 case scm_tc7_lsubr_2:
4425 RETURN (SCM_SUBRF (proc) (arg1, arg2,
4426 SCM_CDDR (debug.info->a.args)));
4427 case scm_tc7_lsubr:
4428 RETURN (SCM_SUBRF (proc) (debug.info->a.args));
4429 case scm_tc7_smob:
4430 if (!SCM_SMOB_APPLICABLE_P (proc))
4431 goto badfun;
4432 RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2,
4433 SCM_CDDR (debug.info->a.args)));
4434 case scm_tc7_cclo:
4435 goto cclon;
002f1a5d
MD
4436 case scm_tc7_pws:
4437 proc = SCM_PROCEDURE (proc);
002f1a5d 4438 debug.info->a.proc = proc;
002f1a5d 4439 if (!SCM_CLOSUREP (proc))
42030fb2 4440 goto evap3;
ddd8f927 4441 /* fallthrough */
6dbd0af5 4442 case scm_tcs_closures:
ddd8f927
DH
4443 {
4444 const SCM formals = SCM_CLOSURE_FORMALS (proc);
4445 if (SCM_NULLP (formals)
4446 || (SCM_CONSP (formals)
4447 && (SCM_NULLP (SCM_CDR (formals))
4448 || (SCM_CONSP (SCM_CDR (formals))
4449 && scm_badargsp (SCM_CDDR (formals), x)))))
212e58ed 4450 goto wrongnumargs;
ddd8f927
DH
4451 SCM_SET_ARGSREADY (debug);
4452 env = SCM_EXTEND_ENV (formals,
4453 debug.info->a.args,
4454 SCM_ENV (proc));
4455 x = SCM_CLOSURE_BODY (proc);
4456 goto nontoplevel_begin;
4457 }
6dbd0af5 4458#else /* DEVAL */
42030fb2 4459 case scm_tc7_subr_3:
ab1f1094
DH
4460 if (!SCM_NULLP (SCM_CDR (x)))
4461 scm_wrong_num_args (proc);
4462 else
4463 RETURN (SCM_SUBRF (proc) (arg1, arg2, EVALCAR (x, env)));
42030fb2
DH
4464 case scm_tc7_asubr:
4465 arg1 = SCM_SUBRF (proc) (arg1, arg2);
4466 do
4467 {
4468 arg1 = SCM_SUBRF(proc)(arg1, EVALCAR(x, env));
4469 x = SCM_CDR(x);
4470 }
6bff1368 4471 while (!SCM_NULLP (x));
42030fb2
DH
4472 RETURN (arg1);
4473 case scm_tc7_rpsubr:
7888309b 4474 if (scm_is_false (SCM_SUBRF (proc) (arg1, arg2)))
42030fb2
DH
4475 RETURN (SCM_BOOL_F);
4476 do
4477 {
4478 arg1 = EVALCAR (x, env);
7888309b 4479 if (scm_is_false (SCM_SUBRF (proc) (arg2, arg1)))
42030fb2
DH
4480 RETURN (SCM_BOOL_F);
4481 arg2 = arg1;
4482 x = SCM_CDR (x);
4483 }
6bff1368 4484 while (!SCM_NULLP (x));
42030fb2
DH
4485 RETURN (SCM_BOOL_T);
4486 case scm_tc7_lsubr_2:
4487 RETURN (SCM_SUBRF (proc) (arg1, arg2, scm_eval_args (x, env, proc)));
4488 case scm_tc7_lsubr:
4489 RETURN (SCM_SUBRF (proc) (scm_cons2 (arg1,
4490 arg2,
4491 scm_eval_args (x, env, proc))));
4492 case scm_tc7_smob:
4493 if (!SCM_SMOB_APPLICABLE_P (proc))
4494 goto badfun;
4495 RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2,
4496 scm_eval_args (x, env, proc)));
4497 case scm_tc7_cclo:
4498 goto cclon;
4499 case scm_tc7_pws:
4500 proc = SCM_PROCEDURE (proc);
4501 if (!SCM_CLOSUREP (proc))
4502 goto evap3;
ddd8f927
DH
4503 /* fallthrough */
4504 case scm_tcs_closures:
da7f71d7 4505 {
ddd8f927 4506 const SCM formals = SCM_CLOSURE_FORMALS (proc);
42030fb2
DH
4507 if (SCM_NULLP (formals)
4508 || (SCM_CONSP (formals)
4509 && (SCM_NULLP (SCM_CDR (formals))
4510 || (SCM_CONSP (SCM_CDR (formals))
4511 && scm_badargsp (SCM_CDDR (formals), x)))))
212e58ed 4512 goto wrongnumargs;
ddd8f927
DH
4513 env = SCM_EXTEND_ENV (formals,
4514 scm_cons2 (arg1,
4515 arg2,
4516 scm_eval_args (x, env, proc)),
4517 SCM_ENV (proc));
4518 x = SCM_CLOSURE_BODY (proc);
4519 goto nontoplevel_begin;
da7f71d7 4520 }
0f2d19dd 4521#endif /* DEVAL */
42030fb2
DH
4522 case scm_tcs_struct:
4523 if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
4524 {
f3d2630a 4525#ifdef DEVAL
42030fb2 4526 arg1 = debug.info->a.args;
f3d2630a 4527#else
42030fb2 4528 arg1 = scm_cons2 (arg1, arg2, scm_eval_args (x, env, proc));
f3d2630a 4529#endif
42030fb2
DH
4530 x = SCM_ENTITY_PROCEDURE (proc);
4531 goto type_dispatch;
4532 }
2ca0d207 4533 else if (SCM_I_OPERATORP (proc))
42030fb2 4534 goto operatorn;
2ca0d207
DH
4535 else
4536 goto badfun;
42030fb2
DH
4537 case scm_tc7_subr_2:
4538 case scm_tc7_subr_1o:
4539 case scm_tc7_subr_2o:
4540 case scm_tc7_subr_0:
14b18ed6 4541 case scm_tc7_dsubr:
42030fb2
DH
4542 case scm_tc7_cxr:
4543 case scm_tc7_subr_1:
ab1f1094 4544 scm_wrong_num_args (proc);
42030fb2 4545 default:
9b07e212 4546 goto badfun;
42030fb2
DH
4547 }
4548 }
0f2d19dd
JB
4549 }
4550#ifdef DEVAL
6dbd0af5 4551exit:
5132eef0 4552 if (scm_check_exit_p && SCM_TRAPS_P)
b7ff98dd 4553 if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug)))
6dbd0af5 4554 {
b7ff98dd
MD
4555 SCM_CLEAR_TRACED_FRAME (debug);
4556 if (SCM_CHEAPTRAPS_P)
dff98306 4557 arg1 = scm_make_debugobj (&debug);
6dbd0af5
MD
4558 else
4559 {
5f144b10
GH
4560 int first;
4561 SCM val = scm_make_continuation (&first);
e050d4f8 4562
5f144b10 4563 if (first)
dff98306 4564 arg1 = val;
5f144b10 4565 else
6dbd0af5 4566 {
5f144b10 4567 proc = val;
6dbd0af5
MD
4568 goto ret;
4569 }
4570 }
d95c0b76 4571 SCM_TRAPS_P = 0;
dff98306 4572 scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, arg1, proc);
d95c0b76 4573 SCM_TRAPS_P = 1;
6dbd0af5
MD
4574 }
4575ret:
1646d37b 4576 scm_last_debug_frame = debug.prev;
0f2d19dd
JB
4577 return proc;
4578#endif
4579}
4580
6dbd0af5
MD
4581
4582/* SECTION: This code is compiled once.
4583 */
4584
0f2d19dd
JB
4585#ifndef DEVAL
4586
fdc28395 4587\f
d0b07b5d 4588
fdc28395
KN
4589/* Simple procedure calls
4590 */
4591
4592SCM
4593scm_call_0 (SCM proc)
4594{
4595 return scm_apply (proc, SCM_EOL, SCM_EOL);
4596}
4597
4598SCM
4599scm_call_1 (SCM proc, SCM arg1)
4600{
4601 return scm_apply (proc, arg1, scm_listofnull);
4602}
4603
4604SCM
4605scm_call_2 (SCM proc, SCM arg1, SCM arg2)
4606{
4607 return scm_apply (proc, arg1, scm_cons (arg2, scm_listofnull));
4608}
4609
4610SCM
4611scm_call_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3)
4612{
4613 return scm_apply (proc, arg1, scm_cons2 (arg2, arg3, scm_listofnull));
4614}
4615
d95c0b76
NJ
4616SCM
4617scm_call_4 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4)
4618{
4619 return scm_apply (proc, arg1, scm_cons2 (arg2, arg3,
4620 scm_cons (arg4, scm_listofnull)));
4621}
4622
fdc28395
KN
4623/* Simple procedure applies
4624 */
4625
4626SCM
4627scm_apply_0 (SCM proc, SCM args)
4628{
4629 return scm_apply (proc, args, SCM_EOL);
4630}
4631
4632SCM
4633scm_apply_1 (SCM proc, SCM arg1, SCM args)
4634{
4635 return scm_apply (proc, scm_cons (arg1, args), SCM_EOL);
4636}
4637
4638SCM
4639scm_apply_2 (SCM proc, SCM arg1, SCM arg2, SCM args)
4640{
4641 return scm_apply (proc, scm_cons2 (arg1, arg2, args), SCM_EOL);
4642}
4643
4644SCM
4645scm_apply_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM args)
4646{
4647 return scm_apply (proc, scm_cons (arg1, scm_cons2 (arg2, arg3, args)),
4648 SCM_EOL);
4649}
4650
82a2622a 4651/* This code processes the arguments to apply:
b145c172
JB
4652
4653 (apply PROC ARG1 ... ARGS)
4654
82a2622a
JB
4655 Given a list (ARG1 ... ARGS), this function conses the ARG1
4656 ... arguments onto the front of ARGS, and returns the resulting
4657 list. Note that ARGS is a list; thus, the argument to this
4658 function is a list whose last element is a list.
4659
4660 Apply calls this function, and applies PROC to the elements of the
b145c172
JB
4661 result. apply:nconc2last takes care of building the list of
4662 arguments, given (ARG1 ... ARGS).
4663
82a2622a
JB
4664 Rather than do new consing, apply:nconc2last destroys its argument.
4665 On that topic, this code came into my care with the following
4666 beautifully cryptic comment on that topic: "This will only screw
4667 you if you do (scm_apply scm_apply '( ... ))" If you know what
4668 they're referring to, send me a patch to this comment. */
b145c172 4669
3b3b36dd 4670SCM_DEFINE (scm_nconc2last, "apply:nconc2last", 1, 0, 0,
b3f26b14
MG
4671 (SCM lst),
4672 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
4673 "conses the @var{arg1} @dots{} arguments onto the front of\n"
4674 "@var{args}, and returns the resulting list. Note that\n"
4675 "@var{args} is a list; thus, the argument to this function is\n"
4676 "a list whose last element is a list.\n"
4677 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
4678 "destroys its argument, so use with care.")
1bbd0b84 4679#define FUNC_NAME s_scm_nconc2last
0f2d19dd
JB
4680{
4681 SCM *lloc;
34d19ef6 4682 SCM_VALIDATE_NONEMPTYLIST (1, lst);
0f2d19dd 4683 lloc = &lst;
c96d76b8
NJ
4684 while (!SCM_NULLP (SCM_CDR (*lloc))) /* Perhaps should be
4685 SCM_NULL_OR_NIL_P, but not
4686 needed in 99.99% of cases,
4687 and it could seriously hurt
4688 performance. - Neil */
a23afe53 4689 lloc = SCM_CDRLOC (*lloc);
1bbd0b84 4690 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc)) >= 0, lst, SCM_ARG1, FUNC_NAME);
0f2d19dd
JB
4691 *lloc = SCM_CAR (*lloc);
4692 return lst;
4693}
1bbd0b84 4694#undef FUNC_NAME
0f2d19dd
JB
4695
4696#endif /* !DEVAL */
4697
6dbd0af5
MD
4698
4699/* SECTION: When DEVAL is defined this code yields scm_dapply.
4700 * It is compiled twice.
4701 */
4702
0f2d19dd 4703#if 0
0f2d19dd 4704SCM
6e8d25a6 4705scm_apply (SCM proc, SCM arg1, SCM args)
0f2d19dd
JB
4706{}
4707#endif
4708
4709#if 0
0f2d19dd 4710SCM
6e8d25a6 4711scm_dapply (SCM proc, SCM arg1, SCM args)
d0b07b5d 4712{}
0f2d19dd
JB
4713#endif
4714
1cc91f1b 4715
82a2622a
JB
4716/* Apply a function to a list of arguments.
4717
4718 This function is exported to the Scheme level as taking two
4719 required arguments and a tail argument, as if it were:
4720 (lambda (proc arg1 . args) ...)
4721 Thus, if you just have a list of arguments to pass to a procedure,
4722 pass the list as ARG1, and '() for ARGS. If you have some fixed
4723 args, pass the first as ARG1, then cons any remaining fixed args
4724 onto the front of your argument list, and pass that as ARGS. */
4725
0f2d19dd 4726SCM
1bbd0b84 4727SCM_APPLY (SCM proc, SCM arg1, SCM args)
0f2d19dd 4728{
0f2d19dd 4729#ifdef DEVAL
92c2555f
MV
4730 scm_t_debug_frame debug;
4731 scm_t_debug_info debug_vect_body;
1646d37b 4732 debug.prev = scm_last_debug_frame;
b7ff98dd 4733 debug.status = SCM_APPLYFRAME;
c0ab1b8d 4734 debug.vect = &debug_vect_body;
6dbd0af5
MD
4735 debug.vect[0].a.proc = proc;
4736 debug.vect[0].a.args = SCM_EOL;
1646d37b 4737 scm_last_debug_frame = &debug;
0f2d19dd 4738#else
434f2f7a 4739 if (scm_debug_mode_p)
0f2d19dd 4740 return scm_dapply (proc, arg1, args);
0f2d19dd
JB
4741#endif
4742
4743 SCM_ASRTGO (SCM_NIMP (proc), badproc);
82a2622a
JB
4744
4745 /* If ARGS is the empty list, then we're calling apply with only two
4746 arguments --- ARG1 is the list of arguments for PROC. Whatever
4747 the case, futz with things so that ARG1 is the first argument to
4748 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
30000774
JB
4749 rest.
4750
4751 Setting the debug apply frame args this way is pretty messy.
4752 Perhaps we should store arg1 and args directly in the frame as
4753 received, and let scm_frame_arguments unpack them, because that's
4754 a relatively rare operation. This works for now; if the Guile
4755 developer archives are still around, see Mikael's post of
4756 11-Apr-97. */
0f2d19dd
JB
4757 if (SCM_NULLP (args))
4758 {
4759 if (SCM_NULLP (arg1))
30000774
JB
4760 {
4761 arg1 = SCM_UNDEFINED;
4762#ifdef DEVAL
4763 debug.vect[0].a.args = SCM_EOL;
4764#endif
4765 }
0f2d19dd
JB
4766 else
4767 {
30000774
JB
4768#ifdef DEVAL
4769 debug.vect[0].a.args = arg1;
4770#endif
0f2d19dd
JB
4771 args = SCM_CDR (arg1);
4772 arg1 = SCM_CAR (arg1);
4773 }
4774 }
4775 else
4776 {
0f2d19dd 4777 args = scm_nconc2last (args);
30000774
JB
4778#ifdef DEVAL
4779 debug.vect[0].a.args = scm_cons (arg1, args);
4780#endif
0f2d19dd 4781 }
0f2d19dd 4782#ifdef DEVAL
b6d75948 4783 if (SCM_ENTER_FRAME_P && SCM_TRAPS_P)
6dbd0af5
MD
4784 {
4785 SCM tmp;
b7ff98dd 4786 if (SCM_CHEAPTRAPS_P)
c0ab1b8d 4787 tmp = scm_make_debugobj (&debug);
6dbd0af5
MD
4788 else
4789 {
5f144b10
GH
4790 int first;
4791
4792 tmp = scm_make_continuation (&first);
4793 if (!first)
6dbd0af5
MD
4794 goto entap;
4795 }
d95c0b76
NJ
4796 SCM_TRAPS_P = 0;
4797 scm_call_2 (SCM_ENTER_FRAME_HDLR, scm_sym_enter_frame, tmp);
4798 SCM_TRAPS_P = 1;
6dbd0af5
MD
4799 }
4800entap:
4801 ENTER_APPLY;
4802#endif
6dbd0af5 4803tail:
0f2d19dd
JB
4804 switch (SCM_TYP7 (proc))
4805 {
4806 case scm_tc7_subr_2o:
4807 args = SCM_NULLP (args) ? SCM_UNDEFINED : SCM_CAR (args);
ddea3325 4808 RETURN (SCM_SUBRF (proc) (arg1, args));
0f2d19dd 4809 case scm_tc7_subr_2:
ab1f1094
DH
4810 if (SCM_NULLP (args) || !SCM_NULLP (SCM_CDR (args)))
4811 scm_wrong_num_args (proc);
0f2d19dd 4812 args = SCM_CAR (args);
ddea3325 4813 RETURN (SCM_SUBRF (proc) (arg1, args));
0f2d19dd 4814 case scm_tc7_subr_0:
ab1f1094
DH
4815 if (!SCM_UNBNDP (arg1))
4816 scm_wrong_num_args (proc);
4817 else
4818 RETURN (SCM_SUBRF (proc) ());
0f2d19dd 4819 case scm_tc7_subr_1:
ab1f1094
DH
4820 if (SCM_UNBNDP (arg1))
4821 scm_wrong_num_args (proc);
0f2d19dd 4822 case scm_tc7_subr_1o:
ab1f1094
DH
4823 if (!SCM_NULLP (args))
4824 scm_wrong_num_args (proc);
4825 else
4826 RETURN (SCM_SUBRF (proc) (arg1));
14b18ed6
DH
4827 case scm_tc7_dsubr:
4828 if (SCM_UNBNDP (arg1) || !SCM_NULLP (args))
4829 scm_wrong_num_args (proc);
4830 if (SCM_INUMP (arg1))
4831 {
4832 RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1))));
4833 }
4834 else if (SCM_REALP (arg1))
4835 {
4836 RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
4837 }
4838 else if (SCM_BIGP (arg1))
f92e85f7
MV
4839 {
4840 RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
4841 }
4842 else if (SCM_FRACTIONP (arg1))
4843 {
4844 RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1))));
4845 }
14b18ed6
DH
4846 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
4847 SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc)));
0f2d19dd 4848 case scm_tc7_cxr:
ab1f1094
DH
4849 if (SCM_UNBNDP (arg1) || !SCM_NULLP (args))
4850 scm_wrong_num_args (proc);
0f2d19dd 4851 {
14b18ed6
DH
4852 unsigned char pattern = (scm_t_bits) SCM_SUBRF (proc);
4853 do
4854 {
4855 SCM_ASSERT (SCM_CONSP (arg1), arg1, SCM_ARG1,
4856 SCM_SYMBOL_CHARS (SCM_SNAME (proc)));
4857 arg1 = (pattern & 1) ? SCM_CAR (arg1) : SCM_CDR (arg1);
4858 pattern >>= 2;
4859 } while (pattern);
4860 RETURN (arg1);
0f2d19dd
JB
4861 }
4862 case scm_tc7_subr_3:
ab1f1094
DH
4863 if (SCM_NULLP (args)
4864 || SCM_NULLP (SCM_CDR (args))
4865 || !SCM_NULLP (SCM_CDDR (args)))
4866 scm_wrong_num_args (proc);
4867 else
4868 RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CADR (args)));
0f2d19dd
JB
4869 case scm_tc7_lsubr:
4870#ifdef DEVAL
ddea3325 4871 RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args));
0f2d19dd 4872#else
ddea3325 4873 RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args)));
0f2d19dd
JB
4874#endif
4875 case scm_tc7_lsubr_2:
ab1f1094
DH
4876 if (!SCM_CONSP (args))
4877 scm_wrong_num_args (proc);
4878 else
4879 RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CDR (args)));
0f2d19dd
JB
4880 case scm_tc7_asubr:
4881 if (SCM_NULLP (args))
ddea3325 4882 RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
0f2d19dd
JB
4883 while (SCM_NIMP (args))
4884 {
4885 SCM_ASSERT (SCM_CONSP (args), args, SCM_ARG2, "apply");
4886 arg1 = SCM_SUBRF (proc) (arg1, SCM_CAR (args));
4887 args = SCM_CDR (args);
4888 }
4889 RETURN (arg1);
4890 case scm_tc7_rpsubr:
4891 if (SCM_NULLP (args))
4892 RETURN (SCM_BOOL_T);
4893 while (SCM_NIMP (args))
4894 {
4895 SCM_ASSERT (SCM_CONSP (args), args, SCM_ARG2, "apply");
7888309b 4896 if (scm_is_false (SCM_SUBRF (proc) (arg1, SCM_CAR (args))))
0f2d19dd
JB
4897 RETURN (SCM_BOOL_F);
4898 arg1 = SCM_CAR (args);
4899 args = SCM_CDR (args);
4900 }
4901 RETURN (SCM_BOOL_T);
4902 case scm_tcs_closures:
4903#ifdef DEVAL
6dbd0af5 4904 arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args);
0f2d19dd
JB
4905#else
4906 arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args));
4907#endif
726d810a 4908 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc), arg1))
ab1f1094 4909 scm_wrong_num_args (proc);
1609038c
MD
4910
4911 /* Copy argument list */
4912 if (SCM_IMP (arg1))
4913 args = arg1;
4914 else
4915 {
4916 SCM tl = args = scm_cons (SCM_CAR (arg1), SCM_UNSPECIFIED);
05b15362 4917 for (arg1 = SCM_CDR (arg1); SCM_CONSP (arg1); arg1 = SCM_CDR (arg1))
1609038c 4918 {
05b15362 4919 SCM_SETCDR (tl, scm_cons (SCM_CAR (arg1), SCM_UNSPECIFIED));
1609038c
MD
4920 tl = SCM_CDR (tl);
4921 }
4922 SCM_SETCDR (tl, arg1);
4923 }
4924
821f18a4
DH
4925 args = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
4926 args,
4927 SCM_ENV (proc));
f9450cdb 4928 proc = SCM_CLOSURE_BODY (proc);
e791c18f 4929 again:
05b15362
DH
4930 arg1 = SCM_CDR (proc);
4931 while (!SCM_NULLP (arg1))
2ddb0920
MD
4932 {
4933 if (SCM_IMP (SCM_CAR (proc)))
4934 {
4935 if (SCM_ISYMP (SCM_CAR (proc)))
4936 {
28d52ebb 4937 scm_rec_mutex_lock (&source_mutex);
9bc4701c
MD
4938 /* check for race condition */
4939 if (SCM_ISYMP (SCM_CAR (proc)))
9d4bf6d3 4940 m_expand_body (proc, args);
28d52ebb 4941 scm_rec_mutex_unlock (&source_mutex);
e791c18f 4942 goto again;
2ddb0920 4943 }
5280aaca 4944 else
17fa3fcf 4945 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc));
2ddb0920
MD
4946 }
4947 else
b1cb24ff 4948 (void) EVAL (SCM_CAR (proc), args);
e791c18f 4949 proc = arg1;
05b15362 4950 arg1 = SCM_CDR (proc);
2ddb0920 4951 }
e791c18f 4952 RETURN (EVALCAR (proc, args));
0717dfd8 4953 case scm_tc7_smob:
68b06924 4954 if (!SCM_SMOB_APPLICABLE_P (proc))
0717dfd8 4955 goto badproc;
afa38f6e 4956 if (SCM_UNBNDP (arg1))
ddea3325 4957 RETURN (SCM_SMOB_APPLY_0 (proc));
afa38f6e 4958 else if (SCM_NULLP (args))
ddea3325 4959 RETURN (SCM_SMOB_APPLY_1 (proc, arg1));
0717dfd8 4960 else if (SCM_NULLP (SCM_CDR (args)))
ddea3325 4961 RETURN (SCM_SMOB_APPLY_2 (proc, arg1, SCM_CAR (args)));
0717dfd8 4962 else
68b06924 4963 RETURN (SCM_SMOB_APPLY_3 (proc, arg1, SCM_CAR (args), SCM_CDR (args)));
0f2d19dd
JB
4964 case scm_tc7_cclo:
4965#ifdef DEVAL
6dbd0af5
MD
4966 args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
4967 arg1 = proc;
4968 proc = SCM_CCLO_SUBR (proc);
4969 debug.vect[0].a.proc = proc;
4970 debug.vect[0].a.args = scm_cons (arg1, args);
0f2d19dd
JB
4971#else
4972 args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
0f2d19dd
JB
4973 arg1 = proc;
4974 proc = SCM_CCLO_SUBR (proc);
6dbd0af5 4975#endif
0f2d19dd 4976 goto tail;
89efbff4
MD
4977 case scm_tc7_pws:
4978 proc = SCM_PROCEDURE (proc);
4979#ifdef DEVAL
4980 debug.vect[0].a.proc = proc;
4981#endif
4982 goto tail;
904a077d 4983 case scm_tcs_struct:
f3d2630a
MD
4984 if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
4985 {
4986#ifdef DEVAL
4987 args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
4988#else
4989 args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
4990#endif
195847fa 4991 RETURN (scm_apply_generic (proc, args));
f3d2630a 4992 }
2ca0d207 4993 else if (SCM_I_OPERATORP (proc))
da7f71d7 4994 {
504d99c5 4995 /* operator */
da7f71d7
MD
4996#ifdef DEVAL
4997 args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
4998#else
4999 args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
5000#endif
5001 arg1 = proc;
195847fa
MD
5002 proc = (SCM_I_ENTITYP (proc)
5003 ? SCM_ENTITY_PROCEDURE (proc)
5004 : SCM_OPERATOR_PROCEDURE (proc));
da7f71d7
MD
5005#ifdef DEVAL
5006 debug.vect[0].a.proc = proc;
5007 debug.vect[0].a.args = scm_cons (arg1, args);
5008#endif
195847fa
MD
5009 if (SCM_NIMP (proc))
5010 goto tail;
5011 else
5012 goto badproc;
da7f71d7 5013 }
2ca0d207
DH
5014 else
5015 goto badproc;
0f2d19dd
JB
5016 default:
5017 badproc:
db4b4ca6 5018 scm_wrong_type_arg ("apply", SCM_ARG1, proc);
0f2d19dd
JB
5019 }
5020#ifdef DEVAL
6dbd0af5 5021exit:
5132eef0 5022 if (scm_check_exit_p && SCM_TRAPS_P)
b7ff98dd 5023 if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug)))
6dbd0af5 5024 {
b7ff98dd
MD
5025 SCM_CLEAR_TRACED_FRAME (debug);
5026 if (SCM_CHEAPTRAPS_P)
c0ab1b8d 5027 arg1 = scm_make_debugobj (&debug);
6dbd0af5
MD
5028 else
5029 {
5f144b10
GH
5030 int first;
5031 SCM val = scm_make_continuation (&first);
5032
5033 if (first)
5034 arg1 = val;
5035 else
6dbd0af5 5036 {
5f144b10 5037 proc = val;
6dbd0af5
MD
5038 goto ret;
5039 }
5040 }
d95c0b76
NJ
5041 SCM_TRAPS_P = 0;
5042 scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, arg1, proc);
5043 SCM_TRAPS_P = 1;
6dbd0af5
MD
5044 }
5045ret:
1646d37b 5046 scm_last_debug_frame = debug.prev;
0f2d19dd
JB
5047 return proc;
5048#endif
5049}
5050
6dbd0af5
MD
5051
5052/* SECTION: The rest of this file is only read once.
5053 */
5054
0f2d19dd
JB
5055#ifndef DEVAL
5056
504d99c5
MD
5057/* Trampolines
5058 *
5059 * Trampolines make it possible to move procedure application dispatch
5060 * outside inner loops. The motivation was clean implementation of
5061 * efficient replacements of R5RS primitives in SRFI-1.
5062 *
5063 * The semantics is clear: scm_trampoline_N returns an optimized
5064 * version of scm_call_N (or NULL if the procedure isn't applicable
5065 * on N args).
5066 *
5067 * Applying the optimization to map and for-each increased efficiency
5068 * noticeably. For example, (map abs ls) is now 8 times faster than
5069 * before.
5070 */
5071
756414cf
MD
5072static SCM
5073call_subr0_0 (SCM proc)
5074{
5075 return SCM_SUBRF (proc) ();
5076}
5077
5078static SCM
5079call_subr1o_0 (SCM proc)
5080{
5081 return SCM_SUBRF (proc) (SCM_UNDEFINED);
5082}
5083
5084static SCM
5085call_lsubr_0 (SCM proc)
5086{
5087 return SCM_SUBRF (proc) (SCM_EOL);
5088}
5089
5090SCM
5091scm_i_call_closure_0 (SCM proc)
5092{
6a3f13f0
DH
5093 const SCM env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
5094 SCM_EOL,
5095 SCM_ENV (proc));
5096 const SCM result = scm_eval_body (SCM_CLOSURE_BODY (proc), env);
d0b07b5d 5097 return result;
756414cf
MD
5098}
5099
5100scm_t_trampoline_0
5101scm_trampoline_0 (SCM proc)
5102{
2510c810
DH
5103 scm_t_trampoline_0 trampoline;
5104
756414cf 5105 if (SCM_IMP (proc))
d0b07b5d 5106 return NULL;
2510c810 5107
756414cf
MD
5108 switch (SCM_TYP7 (proc))
5109 {
5110 case scm_tc7_subr_0:
2510c810
DH
5111 trampoline = call_subr0_0;
5112 break;
756414cf 5113 case scm_tc7_subr_1o:
2510c810
DH
5114 trampoline = call_subr1o_0;
5115 break;
756414cf 5116 case scm_tc7_lsubr:
2510c810
DH
5117 trampoline = call_lsubr_0;
5118 break;
756414cf
MD
5119 case scm_tcs_closures:
5120 {
5121 SCM formals = SCM_CLOSURE_FORMALS (proc);
4b612c5b 5122 if (SCM_NULLP (formals) || !SCM_CONSP (formals))
2510c810 5123 trampoline = scm_i_call_closure_0;
756414cf 5124 else
d0b07b5d 5125 return NULL;
2510c810 5126 break;
756414cf
MD
5127 }
5128 case scm_tcs_struct:
5129 if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
2510c810 5130 trampoline = scm_call_generic_0;
2ca0d207 5131 else if (SCM_I_OPERATORP (proc))
2510c810
DH
5132 trampoline = scm_call_0;
5133 else
5134 return NULL;
5135 break;
756414cf
MD
5136 case scm_tc7_smob:
5137 if (SCM_SMOB_APPLICABLE_P (proc))
2510c810 5138 trampoline = SCM_SMOB_DESCRIPTOR (proc).apply_0;
756414cf 5139 else
d0b07b5d 5140 return NULL;
2510c810 5141 break;
756414cf
MD
5142 case scm_tc7_asubr:
5143 case scm_tc7_rpsubr:
5144 case scm_tc7_cclo:
5145 case scm_tc7_pws:
2510c810
DH
5146 trampoline = scm_call_0;
5147 break;
756414cf 5148 default:
2510c810 5149 return NULL; /* not applicable on zero arguments */
756414cf 5150 }
2510c810
DH
5151 /* We only reach this point if a valid trampoline was determined. */
5152
5153 /* If debugging is enabled, we want to see all calls to proc on the stack.
5154 * Thus, we replace the trampoline shortcut with scm_call_0. */
434f2f7a 5155 if (scm_debug_mode_p)
2510c810
DH
5156 return scm_call_0;
5157 else
5158 return trampoline;
756414cf
MD
5159}
5160
504d99c5
MD
5161static SCM
5162call_subr1_1 (SCM proc, SCM arg1)
5163{
5164 return SCM_SUBRF (proc) (arg1);
5165}
5166
9ed24633
MD
5167static SCM
5168call_subr2o_1 (SCM proc, SCM arg1)
5169{
5170 return SCM_SUBRF (proc) (arg1, SCM_UNDEFINED);
5171}
5172
504d99c5
MD
5173static SCM
5174call_lsubr_1 (SCM proc, SCM arg1)
5175{
5176 return SCM_SUBRF (proc) (scm_list_1 (arg1));
5177}
5178
5179static SCM
5180call_dsubr_1 (SCM proc, SCM arg1)
5181{
5182 if (SCM_INUMP (arg1))
5183 {
5184 RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1))));
5185 }
5186 else if (SCM_REALP (arg1))
5187 {
5188 RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
5189 }
504d99c5 5190 else if (SCM_BIGP (arg1))
f92e85f7
MV
5191 {
5192 RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
5193 }
5194 else if (SCM_FRACTIONP (arg1))
5195 {
5196 RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1))));
5197 }
504d99c5
MD
5198 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
5199 SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc)));
5200}
5201
5202static SCM
5203call_cxr_1 (SCM proc, SCM arg1)
5204{
14b18ed6
DH
5205 unsigned char pattern = (scm_t_bits) SCM_SUBRF (proc);
5206 do
5207 {
5208 SCM_ASSERT (SCM_CONSP (arg1), arg1, SCM_ARG1,
5209 SCM_SYMBOL_CHARS (SCM_SNAME (proc)));
5210 arg1 = (pattern & 1) ? SCM_CAR (arg1) : SCM_CDR (arg1);
5211 pattern >>= 2;
5212 } while (pattern);
5213 return arg1;
504d99c5
MD
5214}
5215
5216static SCM
5217call_closure_1 (SCM proc, SCM arg1)
5218{
6a3f13f0
DH
5219 const SCM env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
5220 scm_list_1 (arg1),
5221 SCM_ENV (proc));
5222 const SCM result = scm_eval_body (SCM_CLOSURE_BODY (proc), env);
d0b07b5d 5223 return result;
504d99c5
MD
5224}
5225
5226scm_t_trampoline_1
5227scm_trampoline_1 (SCM proc)
5228{
2510c810
DH
5229 scm_t_trampoline_1 trampoline;
5230
504d99c5 5231 if (SCM_IMP (proc))
d0b07b5d 5232 return NULL;
2510c810 5233
504d99c5
MD
5234 switch (SCM_TYP7 (proc))
5235 {
5236 case scm_tc7_subr_1:
5237 case scm_tc7_subr_1o:
2510c810
DH
5238 trampoline = call_subr1_1;
5239 break;
9ed24633 5240 case scm_tc7_subr_2o:
2510c810
DH
5241 trampoline = call_subr2o_1;
5242 break;
504d99c5 5243 case scm_tc7_lsubr:
2510c810
DH
5244 trampoline = call_lsubr_1;
5245 break;
14b18ed6 5246 case scm_tc7_dsubr:
2510c810
DH
5247 trampoline = call_dsubr_1;
5248 break;
504d99c5 5249 case scm_tc7_cxr:
2510c810
DH
5250 trampoline = call_cxr_1;
5251 break;
504d99c5
MD
5252 case scm_tcs_closures:
5253 {
5254 SCM formals = SCM_CLOSURE_FORMALS (proc);
4b612c5b
MD
5255 if (!SCM_NULLP (formals)
5256 && (!SCM_CONSP (formals) || !SCM_CONSP (SCM_CDR (formals))))
2510c810 5257 trampoline = call_closure_1;
504d99c5 5258 else
d0b07b5d 5259 return NULL;
2510c810 5260 break;
504d99c5
MD
5261 }
5262 case scm_tcs_struct:
5263 if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
2510c810 5264 trampoline = scm_call_generic_1;
2ca0d207 5265 else if (SCM_I_OPERATORP (proc))
2510c810
DH
5266 trampoline = scm_call_1;
5267 else
5268 return NULL;
5269 break;
504d99c5
MD
5270 case scm_tc7_smob:
5271 if (SCM_SMOB_APPLICABLE_P (proc))
2510c810 5272 trampoline = SCM_SMOB_DESCRIPTOR (proc).apply_1;
504d99c5 5273 else
d0b07b5d 5274 return NULL;
2510c810 5275 break;
504d99c5
MD
5276 case scm_tc7_asubr:
5277 case scm_tc7_rpsubr:
5278 case scm_tc7_cclo:
5279 case scm_tc7_pws:
2510c810
DH
5280 trampoline = scm_call_1;
5281 break;
504d99c5 5282 default:
d0b07b5d 5283 return NULL; /* not applicable on one arg */
504d99c5 5284 }
2510c810
DH
5285 /* We only reach this point if a valid trampoline was determined. */
5286
5287 /* If debugging is enabled, we want to see all calls to proc on the stack.
5288 * Thus, we replace the trampoline shortcut with scm_call_1. */
434f2f7a 5289 if (scm_debug_mode_p)
2510c810
DH
5290 return scm_call_1;
5291 else
5292 return trampoline;
504d99c5
MD
5293}
5294
5295static SCM
5296call_subr2_2 (SCM proc, SCM arg1, SCM arg2)
5297{
5298 return SCM_SUBRF (proc) (arg1, arg2);
5299}
5300
9ed24633
MD
5301static SCM
5302call_lsubr2_2 (SCM proc, SCM arg1, SCM arg2)
5303{
5304 return SCM_SUBRF (proc) (arg1, arg2, SCM_EOL);
5305}
5306
504d99c5
MD
5307static SCM
5308call_lsubr_2 (SCM proc, SCM arg1, SCM arg2)
5309{
5310 return SCM_SUBRF (proc) (scm_list_2 (arg1, arg2));
5311}
5312
5313static SCM
5314call_closure_2 (SCM proc, SCM arg1, SCM arg2)
5315{
6a3f13f0
DH
5316 const SCM env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
5317 scm_list_2 (arg1, arg2),
5318 SCM_ENV (proc));
5319 const SCM result = scm_eval_body (SCM_CLOSURE_BODY (proc), env);
d0b07b5d 5320 return result;
504d99c5
MD
5321}
5322
5323scm_t_trampoline_2
5324scm_trampoline_2 (SCM proc)
5325{
2510c810
DH
5326 scm_t_trampoline_2 trampoline;
5327
504d99c5 5328 if (SCM_IMP (proc))
d0b07b5d 5329 return NULL;
2510c810 5330
504d99c5
MD
5331 switch (SCM_TYP7 (proc))
5332 {
5333 case scm_tc7_subr_2:
5334 case scm_tc7_subr_2o:
5335 case scm_tc7_rpsubr:
5336 case scm_tc7_asubr:
2510c810
DH
5337 trampoline = call_subr2_2;
5338 break;
9ed24633 5339 case scm_tc7_lsubr_2:
2510c810
DH
5340 trampoline = call_lsubr2_2;
5341 break;
504d99c5 5342 case scm_tc7_lsubr:
2510c810
DH
5343 trampoline = call_lsubr_2;
5344 break;
504d99c5
MD
5345 case scm_tcs_closures:
5346 {
5347 SCM formals = SCM_CLOSURE_FORMALS (proc);
4b612c5b
MD
5348 if (!SCM_NULLP (formals)
5349 && (!SCM_CONSP (formals)
5350 || (!SCM_NULLP (SCM_CDR (formals))
5351 && (!SCM_CONSP (SCM_CDR (formals))
5352 || !SCM_CONSP (SCM_CDDR (formals))))))
2510c810 5353 trampoline = call_closure_2;
504d99c5 5354 else
d0b07b5d 5355 return NULL;
2510c810 5356 break;
504d99c5
MD
5357 }
5358 case scm_tcs_struct:
5359 if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
2510c810 5360 trampoline = scm_call_generic_2;
2ca0d207 5361 else if (SCM_I_OPERATORP (proc))
2510c810
DH
5362 trampoline = scm_call_2;
5363 else
5364 return NULL;
5365 break;
504d99c5
MD
5366 case scm_tc7_smob:
5367 if (SCM_SMOB_APPLICABLE_P (proc))
2510c810 5368 trampoline = SCM_SMOB_DESCRIPTOR (proc).apply_2;
504d99c5 5369 else
d0b07b5d 5370 return NULL;
2510c810 5371 break;
504d99c5
MD
5372 case scm_tc7_cclo:
5373 case scm_tc7_pws:
2510c810
DH
5374 trampoline = scm_call_2;
5375 break;
504d99c5 5376 default:
d0b07b5d 5377 return NULL; /* not applicable on two args */
504d99c5 5378 }
2510c810
DH
5379 /* We only reach this point if a valid trampoline was determined. */
5380
5381 /* If debugging is enabled, we want to see all calls to proc on the stack.
5382 * Thus, we replace the trampoline shortcut with scm_call_2. */
434f2f7a 5383 if (scm_debug_mode_p)
2510c810
DH
5384 return scm_call_2;
5385 else
5386 return trampoline;
504d99c5
MD
5387}
5388
d9c393f5
JB
5389/* Typechecking for multi-argument MAP and FOR-EACH.
5390
47c3f06d 5391 Verify that each element of the vector ARGV, except for the first,
d9c393f5 5392 is a proper list whose length is LEN. Attribute errors to WHO,
47c3f06d 5393 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
d9c393f5 5394static inline void
47c3f06d 5395check_map_args (SCM argv,
c014a02e 5396 long len,
47c3f06d
MD
5397 SCM gf,
5398 SCM proc,
5399 SCM args,
5400 const char *who)
d9c393f5 5401{
34d19ef6 5402 SCM const *ve = SCM_VELTS (argv);
c014a02e 5403 long i;
d9c393f5 5404
b5c2579a 5405 for (i = SCM_VECTOR_LENGTH (argv) - 1; i >= 1; i--)
d9c393f5 5406 {
c014a02e 5407 long elt_len = scm_ilength (ve[i]);
d9c393f5
JB
5408
5409 if (elt_len < 0)
47c3f06d
MD
5410 {
5411 if (gf)
5412 scm_apply_generic (gf, scm_cons (proc, args));
5413 else
5414 scm_wrong_type_arg (who, i + 2, ve[i]);
5415 }
d9c393f5
JB
5416
5417 if (elt_len != len)
504d99c5 5418 scm_out_of_range_pos (who, ve[i], SCM_MAKINUM (i + 2));
d9c393f5
JB
5419 }
5420
5d2b97cd 5421 scm_remember_upto_here_1 (argv);
d9c393f5
JB
5422}
5423
5424
47c3f06d 5425SCM_GPROC (s_map, "map", 2, 0, 1, scm_map, g_map);
1cc91f1b 5426
368bf056
MD
5427/* Note: Currently, scm_map applies PROC to the argument list(s)
5428 sequentially, starting with the first element(s). This is used in
8878f040 5429 evalext.c where the Scheme procedure `map-in-order', which guarantees
368bf056 5430 sequential behaviour, is implemented using scm_map. If the
8878f040 5431 behaviour changes, we need to update `map-in-order'.
368bf056
MD
5432*/
5433
0f2d19dd 5434SCM
1bbd0b84 5435scm_map (SCM proc, SCM arg1, SCM args)
af45e3b0 5436#define FUNC_NAME s_map
0f2d19dd 5437{
c014a02e 5438 long i, len;
0f2d19dd
JB
5439 SCM res = SCM_EOL;
5440 SCM *pres = &res;
34d19ef6 5441 SCM const *ve = &args; /* Keep args from being optimized away. */
0f2d19dd 5442
d9c393f5 5443 len = scm_ilength (arg1);
47c3f06d
MD
5444 SCM_GASSERTn (len >= 0,
5445 g_map, scm_cons2 (proc, arg1, args), SCM_ARG2, s_map);
af45e3b0 5446 SCM_VALIDATE_REST_ARGUMENT (args);
0f2d19dd
JB
5447 if (SCM_NULLP (args))
5448 {
504d99c5
MD
5449 scm_t_trampoline_1 call = scm_trampoline_1 (proc);
5450 SCM_GASSERT2 (call, g_map, proc, arg1, SCM_ARG1, s_map);
5451 while (SCM_NIMP (arg1))
5452 {
5453 *pres = scm_list_1 (call (proc, SCM_CAR (arg1)));
5454 pres = SCM_CDRLOC (*pres);
5455 arg1 = SCM_CDR (arg1);
5456 }
5457 return res;
5458 }
5459 if (SCM_NULLP (SCM_CDR (args)))
5460 {
5461 SCM arg2 = SCM_CAR (args);
5462 int len2 = scm_ilength (arg2);
5463 scm_t_trampoline_2 call = scm_trampoline_2 (proc);
5464 SCM_GASSERTn (call,
5465 g_map, scm_cons2 (proc, arg1, args), SCM_ARG1, s_map);
5466 SCM_GASSERTn (len2 >= 0,
5467 g_map, scm_cons2 (proc, arg1, args), SCM_ARG3, s_map);
5468 if (len2 != len)
5469 SCM_OUT_OF_RANGE (3, arg2);
0f2d19dd
JB
5470 while (SCM_NIMP (arg1))
5471 {
504d99c5 5472 *pres = scm_list_1 (call (proc, SCM_CAR (arg1), SCM_CAR (arg2)));
a23afe53 5473 pres = SCM_CDRLOC (*pres);
0f2d19dd 5474 arg1 = SCM_CDR (arg1);
504d99c5 5475 arg2 = SCM_CDR (arg2);
0f2d19dd
JB
5476 }
5477 return res;
5478 }
05b15362
DH
5479 arg1 = scm_cons (arg1, args);
5480 args = scm_vector (arg1);
0f2d19dd 5481 ve = SCM_VELTS (args);
47c3f06d 5482 check_map_args (args, len, g_map, proc, arg1, s_map);
0f2d19dd
JB
5483 while (1)
5484 {
5485 arg1 = SCM_EOL;
b5c2579a 5486 for (i = SCM_VECTOR_LENGTH (args) - 1; i >= 0; i--)
0f2d19dd 5487 {
d9c393f5
JB
5488 if (SCM_IMP (ve[i]))
5489 return res;
0f2d19dd 5490 arg1 = scm_cons (SCM_CAR (ve[i]), arg1);
34d19ef6 5491 SCM_VECTOR_SET (args, i, SCM_CDR (ve[i]));
0f2d19dd 5492 }
8ea46249 5493 *pres = scm_list_1 (scm_apply (proc, arg1, SCM_EOL));
a23afe53 5494 pres = SCM_CDRLOC (*pres);
0f2d19dd
JB
5495 }
5496}
af45e3b0 5497#undef FUNC_NAME
0f2d19dd
JB
5498
5499
47c3f06d 5500SCM_GPROC (s_for_each, "for-each", 2, 0, 1, scm_for_each, g_for_each);
1cc91f1b 5501
0f2d19dd 5502SCM
1bbd0b84 5503scm_for_each (SCM proc, SCM arg1, SCM args)
af45e3b0 5504#define FUNC_NAME s_for_each
0f2d19dd 5505{
34d19ef6 5506 SCM const *ve = &args; /* Keep args from being optimized away. */
c014a02e 5507 long i, len;
d9c393f5 5508 len = scm_ilength (arg1);
47c3f06d
MD
5509 SCM_GASSERTn (len >= 0, g_for_each, scm_cons2 (proc, arg1, args),
5510 SCM_ARG2, s_for_each);
af45e3b0 5511 SCM_VALIDATE_REST_ARGUMENT (args);
c96d76b8 5512 if (SCM_NULLP (args))
0f2d19dd 5513 {
504d99c5
MD
5514 scm_t_trampoline_1 call = scm_trampoline_1 (proc);
5515 SCM_GASSERT2 (call, g_for_each, proc, arg1, SCM_ARG1, s_for_each);
5516 while (SCM_NIMP (arg1))
5517 {
5518 call (proc, SCM_CAR (arg1));
5519 arg1 = SCM_CDR (arg1);
5520 }
5521 return SCM_UNSPECIFIED;
5522 }
5523 if (SCM_NULLP (SCM_CDR (args)))
5524 {
5525 SCM arg2 = SCM_CAR (args);
5526 int len2 = scm_ilength (arg2);
5527 scm_t_trampoline_2 call = scm_trampoline_2 (proc);
5528 SCM_GASSERTn (call, g_for_each,
5529 scm_cons2 (proc, arg1, args), SCM_ARG1, s_for_each);
5530 SCM_GASSERTn (len2 >= 0, g_for_each,
5531 scm_cons2 (proc, arg1, args), SCM_ARG3, s_for_each);
5532 if (len2 != len)
5533 SCM_OUT_OF_RANGE (3, arg2);
c96d76b8 5534 while (SCM_NIMP (arg1))
0f2d19dd 5535 {
504d99c5 5536 call (proc, SCM_CAR (arg1), SCM_CAR (arg2));
0f2d19dd 5537 arg1 = SCM_CDR (arg1);
504d99c5 5538 arg2 = SCM_CDR (arg2);
0f2d19dd
JB
5539 }
5540 return SCM_UNSPECIFIED;
5541 }
05b15362
DH
5542 arg1 = scm_cons (arg1, args);
5543 args = scm_vector (arg1);
0f2d19dd 5544 ve = SCM_VELTS (args);
47c3f06d 5545 check_map_args (args, len, g_for_each, proc, arg1, s_for_each);
0f2d19dd
JB
5546 while (1)
5547 {
5548 arg1 = SCM_EOL;
b5c2579a 5549 for (i = SCM_VECTOR_LENGTH (args) - 1; i >= 0; i--)
0f2d19dd 5550 {
c96d76b8
NJ
5551 if (SCM_IMP (ve[i]))
5552 return SCM_UNSPECIFIED;
0f2d19dd 5553 arg1 = scm_cons (SCM_CAR (ve[i]), arg1);
34d19ef6 5554 SCM_VECTOR_SET (args, i, SCM_CDR (ve[i]));
0f2d19dd
JB
5555 }
5556 scm_apply (proc, arg1, SCM_EOL);
5557 }
5558}
af45e3b0 5559#undef FUNC_NAME
0f2d19dd 5560
1cc91f1b 5561
0f2d19dd 5562SCM
6e8d25a6 5563scm_closure (SCM code, SCM env)
0f2d19dd 5564{
16d4699b
MV
5565 SCM z;
5566 SCM closcar = scm_cons (code, SCM_EOL);
228a24ef 5567 z = scm_cell (SCM_UNPACK (closcar) + scm_tc3_closure, (scm_t_bits) env);
16d4699b 5568 scm_remember_upto_here (closcar);
0f2d19dd
JB
5569 return z;
5570}
5571
5572
92c2555f 5573scm_t_bits scm_tc16_promise;
1cc91f1b 5574
0f2d19dd 5575SCM
6e8d25a6 5576scm_makprom (SCM code)
0f2d19dd 5577{
28d52ebb
MD
5578 SCM_RETURN_NEWSMOB2 (scm_tc16_promise,
5579 SCM_UNPACK (code),
5580 scm_make_rec_mutex ());
0f2d19dd
JB
5581}
5582
28d52ebb
MD
5583static size_t
5584promise_free (SCM promise)
5585{
5586 scm_rec_mutex_free (SCM_PROMISE_MUTEX (promise));
5587 return 0;
5588}
1cc91f1b 5589
0f2d19dd 5590static int
e841c3e0 5591promise_print (SCM exp, SCM port, scm_print_state *pstate)
0f2d19dd 5592{
19402679 5593 int writingp = SCM_WRITINGP (pstate);
b7f3516f 5594 scm_puts ("#<promise ", port);
19402679 5595 SCM_SET_WRITINGP (pstate, 1);
28d52ebb 5596 scm_iprin1 (SCM_PROMISE_DATA (exp), port, pstate);
19402679 5597 SCM_SET_WRITINGP (pstate, writingp);
b7f3516f 5598 scm_putc ('>', port);
0f2d19dd
JB
5599 return !0;
5600}
5601
3b3b36dd 5602SCM_DEFINE (scm_force, "force", 1, 0, 0,
28d52ebb 5603 (SCM promise),
67e8151b
MG
5604 "If the promise @var{x} has not been computed yet, compute and\n"
5605 "return @var{x}, otherwise just return the previously computed\n"
5606 "value.")
1bbd0b84 5607#define FUNC_NAME s_scm_force
0f2d19dd 5608{
28d52ebb
MD
5609 SCM_VALIDATE_SMOB (1, promise, promise);
5610 scm_rec_mutex_lock (SCM_PROMISE_MUTEX (promise));
5611 if (!SCM_PROMISE_COMPUTED_P (promise))
0f2d19dd 5612 {
28d52ebb
MD
5613 SCM ans = scm_call_0 (SCM_PROMISE_DATA (promise));
5614 if (!SCM_PROMISE_COMPUTED_P (promise))
0f2d19dd 5615 {
28d52ebb
MD
5616 SCM_SET_PROMISE_DATA (promise, ans);
5617 SCM_SET_PROMISE_COMPUTED (promise);
0f2d19dd
JB
5618 }
5619 }
28d52ebb
MD
5620 scm_rec_mutex_unlock (SCM_PROMISE_MUTEX (promise));
5621 return SCM_PROMISE_DATA (promise);
0f2d19dd 5622}
1bbd0b84 5623#undef FUNC_NAME
0f2d19dd 5624
445f675c 5625
a1ec6916 5626SCM_DEFINE (scm_promise_p, "promise?", 1, 0, 0,
67e8151b 5627 (SCM obj),
b380b885 5628 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
7a095584 5629 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
1bbd0b84 5630#define FUNC_NAME s_scm_promise_p
0f2d19dd 5631{
7888309b 5632 return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_promise, obj));
0f2d19dd 5633}
1bbd0b84 5634#undef FUNC_NAME
0f2d19dd 5635
445f675c 5636
a1ec6916 5637SCM_DEFINE (scm_cons_source, "cons-source", 3, 0, 0,
1bbd0b84 5638 (SCM xorig, SCM x, SCM y),
11768c04
NJ
5639 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
5640 "Any source properties associated with @var{xorig} are also associated\n"
5641 "with the new pair.")
1bbd0b84 5642#define FUNC_NAME s_scm_cons_source
26d5b9b4
MD
5643{
5644 SCM p, z;
16d4699b 5645 z = scm_cons (x, y);
26d5b9b4
MD
5646 /* Copy source properties possibly associated with xorig. */
5647 p = scm_whash_lookup (scm_source_whash, xorig);
7888309b 5648 if (scm_is_true (p))
26d5b9b4
MD
5649 scm_whash_insert (scm_source_whash, z, p);
5650 return z;
5651}
1bbd0b84 5652#undef FUNC_NAME
26d5b9b4 5653
445f675c 5654
62360b89
DH
5655/* The function scm_copy_tree is used to copy an expression tree to allow the
5656 * memoizer to modify the expression during memoization. scm_copy_tree
5657 * creates deep copies of pairs and vectors, but not of any other data types,
5658 * since only pairs and vectors will be parsed by the memoizer.
5659 *
5660 * To avoid infinite recursion due to cyclic structures, the hare-and-tortoise
5661 * pattern is used to detect cycles. In fact, the pattern is used in two
5662 * dimensions, vertical (indicated in the code by the variable names 'hare'
5663 * and 'tortoise') and horizontal ('rabbit' and 'turtle'). In both
5664 * dimensions, the hare/rabbit will take two steps when the tortoise/turtle
5665 * takes one.
5666 *
5667 * The vertical dimension corresponds to recursive calls to function
5668 * copy_tree: This happens when descending into vector elements, into cars of
5669 * lists and into the cdr of an improper list. In this dimension, the
5670 * tortoise follows the hare by using the processor stack: Every stack frame
5671 * will hold an instance of struct t_trace. These instances are connected in
5672 * a way that represents the trace of the hare, which thus can be followed by
5673 * the tortoise. The tortoise will always point to struct t_trace instances
5674 * relating to SCM objects that have already been copied. Thus, a cycle is
5675 * detected if the tortoise and the hare point to the same object,
5676 *
5677 * The horizontal dimension is within one execution of copy_tree, when the
5678 * function cdr's along the pairs of a list. This is the standard
5679 * hare-and-tortoise implementation, found several times in guile. */
5680
5681struct t_trace {
5682 struct t_trace *trace; // These pointers form a trace along the stack.
5683 SCM obj; // The object handled at the respective stack frame.
5684};
5685
5686static SCM
5687copy_tree (
5688 struct t_trace *const hare,
5689 struct t_trace *tortoise,
5690 unsigned int tortoise_delay )
5691{
5692 if (!SCM_CONSP (hare->obj) && !SCM_VECTORP (hare->obj))
5693 {
5694 return hare->obj;
5695 }
5696 else
5697 {
5698 /* Prepare the trace along the stack. */
5699 struct t_trace new_hare;
5700 hare->trace = &new_hare;
5701
5702 /* The tortoise will make its step after the delay has elapsed. Note
5703 * that in contrast to the typical hare-and-tortoise pattern, the step
5704 * of the tortoise happens before the hare takes its steps. This is, in
5705 * principle, no problem, except for the start of the algorithm: Then,
5fb64383 5706 * it has to be made sure that the hare actually gets its advantage of
62360b89
DH
5707 * two steps. */
5708 if (tortoise_delay == 0)
5709 {
5710 tortoise_delay = 1;
5711 tortoise = tortoise->trace;
5712 ASSERT_SYNTAX (!SCM_EQ_P (hare->obj, tortoise->obj),
5713 s_bad_expression, hare->obj);
5714 }
5715 else
5716 {
5717 --tortoise_delay;
5718 }
5719
5720 if (SCM_VECTORP (hare->obj))
5721 {
5722 const unsigned long int length = SCM_VECTOR_LENGTH (hare->obj);
5723 const SCM new_vector = scm_c_make_vector (length, SCM_UNSPECIFIED);
5724
5725 /* Each vector element is copied by recursing into copy_tree, having
5726 * the tortoise follow the hare into the depths of the stack. */
5727 unsigned long int i;
5728 for (i = 0; i < length; ++i)
5729 {
5730 SCM new_element;
5731 new_hare.obj = SCM_VECTOR_REF (hare->obj, i);
5732 new_element = copy_tree (&new_hare, tortoise, tortoise_delay);
5733 SCM_VECTOR_SET (new_vector, i, new_element);
5734 }
5735
5736 return new_vector;
5737 }
5738 else // SCM_CONSP (hare->obj)
5739 {
5740 SCM result;
5741 SCM tail;
5742
5743 SCM rabbit = hare->obj;
5744 SCM turtle = hare->obj;
5745
5746 SCM copy;
5747
5748 /* The first pair of the list is treated specially, in order to
5749 * preserve a potential source code position. */
5750 result = tail = scm_cons_source (rabbit, SCM_EOL, SCM_EOL);
5751 new_hare.obj = SCM_CAR (rabbit);
5752 copy = copy_tree (&new_hare, tortoise, tortoise_delay);
5753 SCM_SETCAR (tail, copy);
5754
5755 /* The remaining pairs of the list are copied by, horizontally,
5756 * having the turtle follow the rabbit, and, vertically, having the
5757 * tortoise follow the hare into the depths of the stack. */
5758 rabbit = SCM_CDR (rabbit);
5759 while (SCM_CONSP (rabbit))
5760 {
5761 new_hare.obj = SCM_CAR (rabbit);
5762 copy = copy_tree (&new_hare, tortoise, tortoise_delay);
5763 SCM_SETCDR (tail, scm_cons (copy, SCM_UNDEFINED));
5764 tail = SCM_CDR (tail);
5765
5766 rabbit = SCM_CDR (rabbit);
5767 if (SCM_CONSP (rabbit))
5768 {
5769 new_hare.obj = SCM_CAR (rabbit);
5770 copy = copy_tree (&new_hare, tortoise, tortoise_delay);
5771 SCM_SETCDR (tail, scm_cons (copy, SCM_UNDEFINED));
5772 tail = SCM_CDR (tail);
5773 rabbit = SCM_CDR (rabbit);
5774
5775 turtle = SCM_CDR (turtle);
5776 ASSERT_SYNTAX (!SCM_EQ_P (rabbit, turtle),
5777 s_bad_expression, rabbit);
5778 }
5779 }
5780
5781 /* We have to recurse into copy_tree again for the last cdr, in
5782 * order to handle the situation that it holds a vector. */
5783 new_hare.obj = rabbit;
5784 copy = copy_tree (&new_hare, tortoise, tortoise_delay);
5785 SCM_SETCDR (tail, copy);
5786
5787 return result;
5788 }
5789 }
5790}
5791
a1ec6916 5792SCM_DEFINE (scm_copy_tree, "copy-tree", 1, 0, 0,
1bbd0b84 5793 (SCM obj),
b380b885 5794 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
bfefbf18 5795 "the new data structure. @code{copy-tree} recurses down the\n"
b380b885
MD
5796 "contents of both pairs and vectors (since both cons cells and vector\n"
5797 "cells may point to arbitrary objects), and stops recursing when it hits\n"
5798 "any other object.")
1bbd0b84 5799#define FUNC_NAME s_scm_copy_tree
0f2d19dd 5800{
62360b89
DH
5801 /* Prepare the trace along the stack. */
5802 struct t_trace trace;
5803 trace.obj = obj;
5804
5805 /* In function copy_tree, if the tortoise makes its step, it will do this
5806 * before the hare has the chance to move. Thus, we have to make sure that
5807 * the very first step of the tortoise will not happen after the hare has
5808 * really made two steps. This is achieved by passing '2' as the initial
5809 * delay for the tortoise. NOTE: Since cycles are unlikely, giving the hare
5810 * a bigger advantage may improve performance slightly. */
5811 return copy_tree (&trace, &trace, 2);
0f2d19dd 5812}
1bbd0b84 5813#undef FUNC_NAME
0f2d19dd 5814
1cc91f1b 5815
4163eb72
MV
5816/* We have three levels of EVAL here:
5817
5818 - scm_i_eval (exp, env)
5819
5820 evaluates EXP in environment ENV. ENV is a lexical environment
5821 structure as used by the actual tree code evaluator. When ENV is
5822 a top-level environment, then changes to the current module are
a513ead3 5823 tracked by updating ENV so that it continues to be in sync with
4163eb72
MV
5824 the current module.
5825
5826 - scm_primitive_eval (exp)
5827
5828 evaluates EXP in the top-level environment as determined by the
5829 current module. This is done by constructing a suitable
5830 environment and calling scm_i_eval. Thus, changes to the
5831 top-level module are tracked normally.
5832
5833 - scm_eval (exp, mod)
5834
a513ead3 5835 evaluates EXP while MOD is the current module. This is done by
4163eb72
MV
5836 setting the current module to MOD, invoking scm_primitive_eval on
5837 EXP, and then restoring the current module to the value it had
5838 previously. That is, while EXP is evaluated, changes to the
5839 current module are tracked, but these changes do not persist when
5840 scm_eval returns.
5841
5842 For each level of evals, there are two variants, distinguished by a
5843 _x suffix: the ordinary variant does not modify EXP while the _x
5844 variant can destructively modify EXP into something completely
5845 unintelligible. A Scheme data structure passed as EXP to one of the
5846 _x variants should not ever be used again for anything. So when in
5847 doubt, use the ordinary variant.
5848
5849*/
5850
0f2d19dd 5851SCM
68d8be66 5852scm_i_eval_x (SCM exp, SCM env)
0f2d19dd 5853{
434f2f7a
DH
5854 if (SCM_SYMBOLP (exp))
5855 return *scm_lookupcar (scm_cons (exp, SCM_UNDEFINED), env, 1);
5856 else
5857 return SCM_XEVAL (exp, env);
0f2d19dd
JB
5858}
5859
68d8be66
MD
5860SCM
5861scm_i_eval (SCM exp, SCM env)
5862{
26fb6390 5863 exp = scm_copy_tree (exp);
434f2f7a
DH
5864 if (SCM_SYMBOLP (exp))
5865 return *scm_lookupcar (scm_cons (exp, SCM_UNDEFINED), env, 1);
5866 else
5867 return SCM_XEVAL (exp, env);
68d8be66
MD
5868}
5869
5870SCM
4163eb72 5871scm_primitive_eval_x (SCM exp)
0f2d19dd 5872{
a513ead3 5873 SCM env;
bcdab802 5874 SCM transformer = scm_current_module_transformer ();
a513ead3 5875 if (SCM_NIMP (transformer))
fdc28395 5876 exp = scm_call_1 (transformer, exp);
a513ead3 5877 env = scm_top_level_env (scm_current_module_lookup_closure ());
4163eb72 5878 return scm_i_eval_x (exp, env);
0f2d19dd
JB
5879}
5880
4163eb72
MV
5881SCM_DEFINE (scm_primitive_eval, "primitive-eval", 1, 0, 0,
5882 (SCM exp),
2069af38 5883 "Evaluate @var{exp} in the top-level environment specified by\n"
4163eb72
MV
5884 "the current module.")
5885#define FUNC_NAME s_scm_primitive_eval
5886{
a513ead3 5887 SCM env;
bcdab802 5888 SCM transformer = scm_current_module_transformer ();
7888309b 5889 if (scm_is_true (transformer))
fdc28395 5890 exp = scm_call_1 (transformer, exp);
a513ead3 5891 env = scm_top_level_env (scm_current_module_lookup_closure ());
4163eb72
MV
5892 return scm_i_eval (exp, env);
5893}
5894#undef FUNC_NAME
5895
6bff1368 5896
68d8be66
MD
5897/* Eval does not take the second arg optionally. This is intentional
5898 * in order to be R5RS compatible, and to prepare for the new module
5899 * system, where we would like to make the choice of evaluation
4163eb72 5900 * environment explicit. */
549e6ec6 5901
09074dbf
DH
5902static void
5903change_environment (void *data)
5904{
5905 SCM pair = SCM_PACK (data);
5906 SCM new_module = SCM_CAR (pair);
aa767bc5 5907 SCM old_module = scm_current_module ();
09074dbf 5908 SCM_SETCDR (pair, old_module);
aa767bc5 5909 scm_set_current_module (new_module);
09074dbf
DH
5910}
5911
09074dbf
DH
5912static void
5913restore_environment (void *data)
5914{
5915 SCM pair = SCM_PACK (data);
5916 SCM old_module = SCM_CDR (pair);
aa767bc5 5917 SCM new_module = scm_current_module ();
2e9c835d 5918 SCM_SETCAR (pair, new_module);
aa767bc5 5919 scm_set_current_module (old_module);
09074dbf
DH
5920}
5921
4163eb72
MV
5922static SCM
5923inner_eval_x (void *data)
5924{
5925 return scm_primitive_eval_x (SCM_PACK(data));
5926}
5927
5928SCM
5929scm_eval_x (SCM exp, SCM module)
5930#define FUNC_NAME "eval!"
5931{
5932 SCM_VALIDATE_MODULE (2, module);
5933
5934 return scm_internal_dynamic_wind
5935 (change_environment, inner_eval_x, restore_environment,
5936 (void *) SCM_UNPACK (exp),
5937 (void *) SCM_UNPACK (scm_cons (module, SCM_BOOL_F)));
5938}
5939#undef FUNC_NAME
5940
5941static SCM
5942inner_eval (void *data)
5943{
5944 return scm_primitive_eval (SCM_PACK(data));
5945}
09074dbf 5946
68d8be66 5947SCM_DEFINE (scm_eval, "eval", 2, 0, 0,
4163eb72
MV
5948 (SCM exp, SCM module),
5949 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
5950 "in the top-level environment specified by @var{module}.\n"
8f85c0c6 5951 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
4163eb72
MV
5952 "@var{module} is made the current module. The current module\n"
5953 "is reset to its previous value when @var{eval} returns.")
1bbd0b84 5954#define FUNC_NAME s_scm_eval
0f2d19dd 5955{
4163eb72 5956 SCM_VALIDATE_MODULE (2, module);
09074dbf
DH
5957
5958 return scm_internal_dynamic_wind
5959 (change_environment, inner_eval, restore_environment,
4163eb72
MV
5960 (void *) SCM_UNPACK (exp),
5961 (void *) SCM_UNPACK (scm_cons (module, SCM_BOOL_F)));
0f2d19dd 5962}
1bbd0b84 5963#undef FUNC_NAME
0f2d19dd 5964
6dbd0af5 5965
434f2f7a 5966/* At this point, deval and scm_dapply are generated.
6dbd0af5
MD
5967 */
5968
a44a9715
DH
5969#define DEVAL
5970#include "eval.c"
0f2d19dd 5971
1cc91f1b 5972
434f2f7a
DH
5973#if (SCM_ENABLE_DEPRECATED == 1)
5974
5975/* Deprecated in guile 1.7.0 on 2004-03-29. */
5976SCM scm_ceval (SCM x, SCM env)
5977{
5978 if (SCM_CONSP (x))
5979 return ceval (x, env);
5980 else if (SCM_SYMBOLP (x))
5981 return *scm_lookupcar (scm_cons (x, SCM_UNDEFINED), env, 1);
5982 else
5983 return SCM_XEVAL (x, env);
5984}
5985
5986/* Deprecated in guile 1.7.0 on 2004-03-29. */
5987SCM scm_deval (SCM x, SCM env)
5988{
5989 if (SCM_CONSP (x))
5990 return deval (x, env);
5991 else if (SCM_SYMBOLP (x))
5992 return *scm_lookupcar (scm_cons (x, SCM_UNDEFINED), env, 1);
5993 else
5994 return SCM_XEVAL (x, env);
5995}
5996
5997static SCM
5998dispatching_eval (SCM x, SCM env)
5999{
6000 if (scm_debug_mode_p)
6001 return scm_deval (x, env);
6002 else
6003 return scm_ceval (x, env);
6004}
6005
6006/* Deprecated in guile 1.7.0 on 2004-03-29. */
6007SCM (*scm_ceval_ptr) (SCM x, SCM env) = dispatching_eval;
6008
6009#endif
6010
6011
0f2d19dd
JB
6012void
6013scm_init_eval ()
0f2d19dd 6014{
33b97402
MD
6015 scm_init_opts (scm_evaluator_traps,
6016 scm_evaluator_trap_table,
6017 SCM_N_EVALUATOR_TRAPS);
6018 scm_init_opts (scm_eval_options_interface,
6019 scm_eval_opts,
6020 SCM_N_EVAL_OPTIONS);
6021
f99c9c28
MD
6022 scm_tc16_promise = scm_make_smob_type ("promise", 0);
6023 scm_set_smob_mark (scm_tc16_promise, scm_markcdr);
28d52ebb 6024 scm_set_smob_free (scm_tc16_promise, promise_free);
e841c3e0 6025 scm_set_smob_print (scm_tc16_promise, promise_print);
b8229a3b 6026
a44a9715
DH
6027 undefineds = scm_list_1 (SCM_UNDEFINED);
6028 SCM_SETCDR (undefineds, undefineds);
6029 scm_permanent_object (undefineds);
7c33806a 6030
a44a9715 6031 scm_listofnull = scm_list_1 (SCM_EOL);
0f2d19dd 6032
a44a9715
DH
6033 f_apply = scm_c_define_subr ("apply", scm_tc7_lsubr_2, scm_apply);
6034 scm_permanent_object (f_apply);
86d31dfe 6035
a0599745 6036#include "libguile/eval.x"
60a49842 6037
25eaf21a 6038 scm_add_feature ("delay");
0f2d19dd 6039}
0f2d19dd 6040
6dbd0af5 6041#endif /* !DEVAL */
89e00824
ML
6042
6043/*
6044 Local Variables:
6045 c-file-style: "gnu"
6046 End:
6047*/