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