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