219 |
* more than once, a 'Duplicate formal' error is signalled. */ |
* more than once, a 'Duplicate formal' error is signalled. */ |
220 |
static const char s_duplicate_formal[] = "Duplicate formal"; |
static const char s_duplicate_formal[] = "Duplicate formal"; |
221 |
|
|
222 |
|
/* If the evaluation of an unquote-splicing expression gives something else |
223 |
|
* than a proper list, a 'Non-list result for unquote-splicing' error is |
224 |
|
* signalled. */ |
225 |
|
static const char s_splicing[] = "Non-list result for unquote-splicing"; |
226 |
|
|
227 |
/* If something else than an exact integer is detected as the argument for |
/* If something else than an exact integer is detected as the argument for |
228 |
* @slot-ref and @slot-set!, a 'Bad slot number' error is signalled. */ |
* @slot-ref and @slot-set!, a 'Bad slot number' error is signalled. */ |
229 |
static const char s_bad_slot_number[] = "Bad slot number"; |
static const char s_bad_slot_number[] = "Bad slot number"; |
363 |
|
|
364 |
|
|
365 |
|
|
366 |
#define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \ |
/* The function lookup_symbol is used during memoization: Lookup the symbol |
367 |
ASSERT_SYNTAX (!SCM_EQ_P ((x), SCM_EOL), s_empty_combination, x) |
* in the environment. If there is no binding for the symbol, SCM_UNDEFINED |
368 |
|
* is returned. If the symbol is a syntactic keyword, the macro object to |
369 |
|
* which the symbol is bound is returned. If the symbol is a global variable, |
370 |
|
* the variable object to which the symbol is bound is returned. Finally, if |
371 |
|
* the symbol is a local variable the corresponding iloc object is returned. |
372 |
|
*/ |
373 |
|
|
374 |
|
/* A helper function for lookup_symbol: Try to find the symbol in the top |
375 |
|
* level environment frame. The function returns SCM_UNDEFINED if the symbol |
376 |
|
* is unbound, it returns a macro object if the symbol is a syntactic keyword |
377 |
|
* and it returns a variable object if the symbol is a global variable. */ |
378 |
|
static SCM |
379 |
|
lookup_global_symbol (const SCM symbol, const SCM top_level) |
380 |
|
{ |
381 |
|
const SCM variable = scm_sym2var (symbol, top_level, SCM_BOOL_F); |
382 |
|
if (SCM_FALSEP (variable)) |
383 |
|
{ |
384 |
|
return SCM_UNDEFINED; |
385 |
|
} |
386 |
|
else |
387 |
|
{ |
388 |
|
const SCM value = SCM_VARIABLE_REF (variable); |
389 |
|
if (SCM_MACROP (value)) |
390 |
|
return value; |
391 |
|
else |
392 |
|
return variable; |
393 |
|
} |
394 |
|
} |
395 |
|
|
396 |
|
static SCM |
397 |
|
lookup_symbol (const SCM symbol, const SCM env) |
398 |
|
{ |
399 |
|
SCM frame_idx; |
400 |
|
unsigned int frame_nr; |
401 |
|
|
402 |
|
for (frame_idx = env, frame_nr = 0; |
403 |
|
!SCM_NULLP (frame_idx); |
404 |
|
frame_idx = SCM_CDR (frame_idx), ++frame_nr) |
405 |
|
{ |
406 |
|
const SCM frame = SCM_CAR (frame_idx); |
407 |
|
if (SCM_CONSP (frame)) |
408 |
|
{ |
409 |
|
/* frame holds a local environment frame */ |
410 |
|
SCM symbol_idx; |
411 |
|
unsigned int symbol_nr; |
412 |
|
|
413 |
|
for (symbol_idx = SCM_CAR (frame), symbol_nr = 0; |
414 |
|
SCM_CONSP (symbol_idx); |
415 |
|
symbol_idx = SCM_CDR (symbol_idx), ++symbol_nr) |
416 |
|
{ |
417 |
|
if (SCM_EQ_P (SCM_CAR (symbol_idx), symbol)) |
418 |
|
/* found the symbol, therefore return the iloc */ |
419 |
|
return SCM_MAKE_ILOC (frame_nr, symbol_nr, 0); |
420 |
|
} |
421 |
|
if (SCM_EQ_P (symbol_idx, symbol)) |
422 |
|
/* found the symbol as the last element of the current frame */ |
423 |
|
return SCM_MAKE_ILOC (frame_nr, symbol_nr, 1); |
424 |
|
} |
425 |
|
else |
426 |
|
{ |
427 |
|
/* no more local environment frames */ |
428 |
|
return lookup_global_symbol (symbol, frame); |
429 |
|
} |
430 |
|
} |
431 |
|
|
432 |
|
return lookup_global_symbol (symbol, SCM_BOOL_F); |
433 |
|
} |
434 |
|
|
435 |
|
|
436 |
|
/* Return true if the symbol is - from the point of view of a macro |
437 |
|
* transformer - a literal in the sense specified in chapter "pattern |
438 |
|
* language" of R5RS. In the code below, however, we don't match the |
439 |
|
* definition of R5RS exactly: It returns true if the identifier has no |
440 |
|
* binding or if it is a syntactic keyword. */ |
441 |
|
static int |
442 |
|
literal_p (const SCM symbol, const SCM env) |
443 |
|
{ |
444 |
|
const SCM value = lookup_symbol (symbol, env); |
445 |
|
if (SCM_UNBNDP (value) || SCM_MACROP (value)) |
446 |
|
return 1; |
447 |
|
else |
448 |
|
return 0; |
449 |
|
} |
450 |
|
|
451 |
|
|
452 |
|
|
510 |
SCM_REC_MUTEX (source_mutex); |
SCM_REC_MUTEX (source_mutex); |
511 |
|
|
512 |
|
|
|
static const char s_test[] = "bad test"; |
|
|
static const char s_bindings[] = "bad bindings"; |
|
|
static const char s_duplicate_bindings[] = "duplicate bindings"; |
|
|
static const char s_variable[] = "bad variable"; |
|
|
static const char s_splicing[] = "bad (non-list) result for unquote-splicing"; |
|
|
|
|
|
|
|
513 |
/* Lookup a given local variable in an environment. The local variable is |
/* Lookup a given local variable in an environment. The local variable is |
514 |
* given as an iloc, that is a triple <frame, binding, last?>, where frame |
* given as an iloc, that is a triple <frame, binding, last?>, where frame |
515 |
* indicates the relative number of the environment frame (counting upwards |
* indicates the relative number of the environment frame (counting upwards |
732 |
return loc; |
return loc; |
733 |
} |
} |
734 |
|
|
|
/* Return true if the symbol is - from the point of view of a macro |
|
|
* transformer - a literal in the sense specified in chapter "pattern |
|
|
* language" of R5RS. In the code below, however, we don't match the |
|
|
* definition of R5RS exactly: It returns true if the identifier has no |
|
|
* binding or if it is a syntactic keyword. */ |
|
|
static int |
|
|
literal_p (const SCM symbol, const SCM env) |
|
|
{ |
|
|
const SCM x = scm_cons (symbol, SCM_UNDEFINED); |
|
|
const SCM value = *scm_lookupcar (x, env, 0); |
|
|
if (SCM_UNBNDP (value) || SCM_MACROP (value)) |
|
|
return 1; |
|
|
else |
|
|
return 0; |
|
|
} |
|
|
|
|
735 |
|
|
736 |
SCM |
SCM |
737 |
scm_eval_car (SCM pair, SCM env) |
scm_eval_car (SCM pair, SCM env) |
740 |
} |
} |
741 |
|
|
742 |
|
|
|
/* |
|
|
* The following rewrite expressions and |
|
|
* some memoized forms have different syntax |
|
|
*/ |
|
|
|
|
|
SCM_GLOBAL_SYMBOL (scm_sym_else, "else"); |
|
|
SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote"); |
|
|
SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing, "unquote-splicing"); |
|
|
|
|
|
SCM_GLOBAL_SYMBOL (scm_sym_enter_frame, "enter-frame"); |
|
|
SCM_GLOBAL_SYMBOL (scm_sym_apply_frame, "apply-frame"); |
|
|
SCM_GLOBAL_SYMBOL (scm_sym_exit_frame, "exit-frame"); |
|
|
SCM_GLOBAL_SYMBOL (scm_sym_trace, "trace"); |
|
|
|
|
743 |
|
|
744 |
/* Rewrite the body (which is given as the list of expressions forming the |
/* Rewrite the body (which is given as the list of expressions forming the |
745 |
* body) into its internal form. The internal form of a body (<expr> ...) is |
* body) into its internal form. The internal form of a body (<expr> ...) is |
774 |
{ |
{ |
775 |
if (SCM_SYMBOLP (expr)) |
if (SCM_SYMBOLP (expr)) |
776 |
{ |
{ |
777 |
const SCM tmp_pair = scm_list_1 (expr); |
const SCM value = lookup_symbol (expr, env); |
|
const SCM value = *scm_lookupcar1 (tmp_pair, env, 0); |
|
778 |
return value; |
return value; |
779 |
} |
} |
780 |
else |
else |
1018 |
|
|
1019 |
SCM_SYNTAX (s_case, "case", scm_i_makbimacro, scm_m_case); |
SCM_SYNTAX (s_case, "case", scm_i_makbimacro, scm_m_case); |
1020 |
SCM_GLOBAL_SYMBOL (scm_sym_case, s_case); |
SCM_GLOBAL_SYMBOL (scm_sym_case, s_case); |
1021 |
|
SCM_GLOBAL_SYMBOL (scm_sym_else, "else"); |
1022 |
|
|
1023 |
SCM |
SCM |
1024 |
scm_m_case (SCM expr, SCM env) |
scm_m_case (SCM expr, SCM env) |
1668 |
|
|
1669 |
SCM_SYNTAX (s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote); |
SCM_SYNTAX (s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote); |
1670 |
SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, s_quasiquote); |
SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, s_quasiquote); |
1671 |
|
SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote"); |
1672 |
|
SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing, "unquote-splicing"); |
1673 |
|
|
1674 |
/* Internal function to handle a quasiquotation: 'form' is the parameter in |
/* Internal function to handle a quasiquotation: 'form' is the parameter in |
1675 |
* the call (quasiquotation form), 'env' is the environment where unquoted |
* the call (quasiquotation form), 'env' is the environment where unquoted |
2098 |
#endif |
#endif |
2099 |
|
|
2100 |
|
|
2101 |
|
#if (SCM_ENABLE_DEPRECATED == 1) |
2102 |
|
|
2103 |
SCM |
SCM |
2104 |
scm_macroexp (SCM x, SCM env) |
scm_macroexp (SCM x, SCM env) |
2105 |
{ |
{ |
2144 |
goto macro_tail; |
goto macro_tail; |
2145 |
} |
} |
2146 |
|
|
2147 |
|
#endif |
2148 |
|
|
2149 |
|
/*****************************************************************************/ |
2150 |
|
/*****************************************************************************/ |
2151 |
|
/* The definitions for unmemoization start here. */ |
2152 |
|
/*****************************************************************************/ |
2153 |
|
/*****************************************************************************/ |
2154 |
|
|
2155 |
#define SCM_BIT7(x) (127 & SCM_UNPACK (x)) |
#define SCM_BIT7(x) (127 & SCM_UNPACK (x)) |
2156 |
|
|
2157 |
/* A function object to implement "apply" for non-closure functions. */ |
SCM_SYMBOL (sym_three_question_marks, "???"); |
|
static SCM f_apply; |
|
|
/* An endless list consisting of #<undefined> objects: */ |
|
|
static SCM undefineds; |
|
2158 |
|
|
2159 |
|
|
2160 |
/* scm_unmemocopy takes a memoized expression together with its |
/* scm_unmemocopy takes a memoized expression together with its |
2187 |
} |
} |
2188 |
|
|
2189 |
|
|
2190 |
SCM_SYMBOL (sym_three_question_marks, "???"); |
static SCM |
2191 |
|
unmemocar (SCM form, SCM env) |
|
#define unmemocar scm_unmemocar |
|
|
|
|
|
SCM |
|
|
scm_unmemocar (SCM form, SCM env) |
|
2192 |
{ |
{ |
2193 |
if (!SCM_CONSP (form)) |
if (!SCM_CONSP (form)) |
2194 |
return form; |
return form; |
2217 |
} |
} |
2218 |
} |
} |
2219 |
|
|
2220 |
|
|
2221 |
|
#if (SCM_ENABLE_DEPRECATED == 1) |
2222 |
|
|
2223 |
|
SCM |
2224 |
|
scm_unmemocar (SCM form, SCM env) |
2225 |
|
{ |
2226 |
|
return unmemocar (form, env); |
2227 |
|
} |
2228 |
|
|
2229 |
|
#endif |
2230 |
|
|
2231 |
|
|
2232 |
static SCM |
static SCM |
2233 |
unmemocopy (SCM x, SCM env) |
unmemocopy (SCM x, SCM env) |
2234 |
{ |
{ |
2463 |
return ls; |
return ls; |
2464 |
} |
} |
2465 |
|
|
|
|
|
2466 |
SCM |
SCM |
2467 |
scm_unmemocopy (SCM x, SCM env) |
scm_unmemocopy (SCM x, SCM env) |
2468 |
{ |
{ |
2475 |
} |
} |
2476 |
|
|
2477 |
|
|
2478 |
int |
/*****************************************************************************/ |
2479 |
|
/*****************************************************************************/ |
2480 |
|
/* The definitions for execution start here. */ |
2481 |
|
/*****************************************************************************/ |
2482 |
|
/*****************************************************************************/ |
2483 |
|
|
2484 |
|
SCM_GLOBAL_SYMBOL (scm_sym_enter_frame, "enter-frame"); |
2485 |
|
SCM_GLOBAL_SYMBOL (scm_sym_apply_frame, "apply-frame"); |
2486 |
|
SCM_GLOBAL_SYMBOL (scm_sym_exit_frame, "exit-frame"); |
2487 |
|
SCM_GLOBAL_SYMBOL (scm_sym_trace, "trace"); |
2488 |
|
|
2489 |
|
/* A function object to implement "apply" for non-closure functions. */ |
2490 |
|
static SCM f_apply; |
2491 |
|
/* An endless list consisting of #<undefined> objects: */ |
2492 |
|
static SCM undefineds; |
2493 |
|
|
2494 |
|
|
2495 |
|
int |
2496 |
scm_badargsp (SCM formals, SCM args) |
scm_badargsp (SCM formals, SCM args) |
2497 |
{ |
{ |
2498 |
while (!SCM_NULLP (formals)) |
while (!SCM_NULLP (formals)) |
2750 |
} while (0) |
} while (0) |
2751 |
|
|
2752 |
|
|
2753 |
|
#define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \ |
2754 |
|
ASSERT_SYNTAX (!SCM_EQ_P ((x), SCM_EOL), s_empty_combination, x) |
2755 |
|
|
2756 |
|
|
2757 |
/* This is the evaluator. Like any real monster, it has three heads: |
/* This is the evaluator. Like any real monster, it has three heads: |
2758 |
* |
* |
2759 |
* scm_ceval is the non-debugging evaluator, scm_deval is the debugging |
* scm_ceval is the non-debugging evaluator, scm_deval is the debugging |