X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/d3a6bc94840464e1af8109de5dddd5859560c679..d8c40b9f49836a0d8c28b49ff5346033c50e113d:/libguile/eval.c diff --git a/libguile/eval.c b/libguile/eval.c index 563936718..c17e4787d 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998, 1999 Free Software Foundation, Inc. +/* Copyright (C) 1995, 96, 97, 98, 99, 2000 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -93,10 +93,14 @@ char *alloca (); #include "srcprop.h" #include "stackchk.h" #include "objects.h" +#include "async.h" #include "feature.h" #include "modules.h" +#include "ports.h" +#include "root.h" +#include "vectors.h" -#include "scm_validate.h" +#include "validate.h" #include "eval.h" SCM (*scm_memoize_method) (SCM, SCM); @@ -140,17 +144,17 @@ SCM (*scm_memoize_method) (SCM, SCM); */ #define SCM_CEVAL scm_ceval -#define SIDEVAL(x, env) if (SCM_NIMP(x)) SCM_CEVAL((x), (env)) +#define SIDEVAL(x, env) if (SCM_NIMP (x)) SCM_CEVAL((x), (env)) -#define EVALCELLCAR(x, env) (SCM_SYMBOLP (SCM_CAR(x)) \ - ? *scm_lookupcar(x, env, 1) \ - : SCM_CEVAL(SCM_CAR(x), env)) +#define EVALCELLCAR(x, env) (SCM_SYMBOLP (SCM_CAR (x)) \ + ? *scm_lookupcar (x, env, 1) \ + : SCM_CEVAL (SCM_CAR (x), env)) -#define EVALCAR(x, env) (SCM_NCELLP(SCM_CAR(x))\ - ? (SCM_IMP(SCM_CAR(x)) \ - ? SCM_EVALIM(SCM_CAR(x), env) \ - : SCM_GLOC_VAL(SCM_CAR(x))) \ - : EVALCELLCAR(x, env)) +#define EVALCAR(x, env) (SCM_NCELLP (SCM_CAR (x)) \ + ? (SCM_IMP (SCM_CAR (x)) \ + ? SCM_EVALIM (SCM_CAR (x), env) \ + : SCM_GLOC_VAL (SCM_CAR (x))) \ + : EVALCELLCAR (x, env)) #define EXTEND_ENV SCM_EXTEND_ENV @@ -254,6 +258,8 @@ scm_ilookup (SCM iloc, SCM env) */ static scm_cell undef_cell = { SCM_UNDEFINED, SCM_UNDEFINED }; +SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable"); + #ifdef USE_THREADS static SCM * scm_lookupcar1 (SCM vloc, SCM genv, int check) @@ -272,18 +278,18 @@ scm_lookupcar (SCM vloc, SCM genv, int check) #endif for (; SCM_NIMP (env); env = SCM_CDR (env)) { - if (SCM_BOOL_T == scm_procedure_p (SCM_CAR (env))) + if (SCM_TRUE_P (scm_procedure_p (SCM_CAR (env)))) break; al = SCM_CARLOC (env); for (fl = SCM_CAR (*al); SCM_NIMP (fl); fl = SCM_CDR (fl)) { if (SCM_NCONSP (fl)) { - if (fl == var) + if (SCM_EQ_P (fl, var)) { #ifdef MEMOIZE_LOCALS #ifdef USE_THREADS - if (SCM_CAR (vloc) != var) + if (! SCM_EQ_P (SCM_CAR (vloc), var)) goto race; #endif SCM_SETCAR (vloc, iloc + SCM_ICDR); @@ -294,7 +300,7 @@ scm_lookupcar (SCM vloc, SCM genv, int check) break; } al = SCM_CDRLOC (*al); - if (SCM_CAR (fl) == var) + if (SCM_EQ_P (SCM_CAR (fl), var)) { #ifdef MEMOIZE_LOCALS #ifndef SCM_RECKLESS /* letrec inits to SCM_UNDEFINED */ @@ -317,7 +323,7 @@ scm_lookupcar (SCM vloc, SCM genv, int check) #endif } #ifdef MEMOIZE_LOCALS - iloc = (~SCM_IDSTMSK) & (iloc + SCM_IFRINC); + iloc = SCM_PACK ((~SCM_IDSTMSK) & SCM_UNPACK(iloc + SCM_IFRINC)); #endif } { @@ -330,7 +336,7 @@ scm_lookupcar (SCM vloc, SCM genv, int check) else top_thunk = SCM_BOOL_F; vcell = scm_sym2vcell (var, top_thunk, SCM_BOOL_F); - if (vcell == SCM_BOOL_F) + if (SCM_FALSEP (vcell)) goto errout; else var = vcell; @@ -342,11 +348,14 @@ scm_lookupcar (SCM vloc, SCM genv, int check) errout: /* scm_everr (vloc, genv,...) */ if (check) - scm_misc_error (NULL, - SCM_NULLP (env) - ? "Unbound variable: %S" - : "Damaged environment: %S", - scm_listify (var, SCM_UNDEFINED)); + { + if (SCM_NULLP (env)) + scm_error (scm_unbound_variable_key, NULL, "Unbound variable: ~S", + scm_cons (var, SCM_EOL), SCM_BOOL_F); + else + scm_misc_error (NULL, "Damaged environment: ~S", + scm_cons (var, SCM_EOL)); + } else return SCM_CDRLOC (&undef_cell); } @@ -359,10 +368,10 @@ scm_lookupcar (SCM vloc, SCM genv, int check) completely. */ race: var = SCM_CAR (vloc); - if ((var & 7) == 1) + if (SCM_ITAG3 (var) == 1) return SCM_GLOC_VAL_LOC (var); #ifdef MEMOIZE_LOCALS - if ((var & 127) == (127 & SCM_ILOC00)) + if ((SCM_UNPACK (var) & 127) == (127 & SCM_UNPACK (SCM_ILOC00))) return scm_ilookup (var, genv); #endif /* We can't cope with anything else than glocs and ilocs. When @@ -404,8 +413,8 @@ scm_unmemocar (SCM form, SCM env) if (SCM_IMP (form)) return form; c = SCM_CAR (form); - if (1 == (c & 7)) - SCM_SETCAR (form, SCM_CAR (c - 1)); + if (1 == (SCM_UNPACK (c) & 7)) + SCM_SETCAR (form, SCM_GLOC_SYM (c)); #ifdef MEMOIZE_LOCALS #ifdef DEBUG_EXTENSIONS else if (SCM_ILOCP (c)) @@ -457,7 +466,7 @@ SCM scm_sym_trace; -static void bodycheck SCM_P ((SCM xorig, SCM *bodyloc, const char *what)); +static void bodycheck (SCM xorig, SCM *bodyloc, const char *what); static void bodycheck (SCM xorig, SCM *bodyloc, const char *what) @@ -547,7 +556,7 @@ scm_m_set_x (SCM xorig, SCM env) { SCM x = SCM_CDR (xorig); SCM_ASSYNT (2 == scm_ilength (x), xorig, scm_s_expression, scm_s_set_x); - SCM_ASSYNT (SCM_NIMP (SCM_CAR (x)) && SCM_SYMBOLP (SCM_CAR (x)), + SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x)), xorig, scm_s_variable, scm_s_set_x); return scm_cons (SCM_IM_SET_X, x); } @@ -564,7 +573,7 @@ scm_m_vref (SCM xorig, SCM env) { /* scm_everr (SCM_UNDEFINED, env,..., "global variable reference") */ scm_misc_error (NULL, - "Bad variable: %S", + "Bad variable: ~S", scm_listify (SCM_CAR (SCM_CDR (x)), SCM_UNDEFINED)); } SCM_ASSYNT (SCM_NIMP(x) && DEFSCM_VARIABLEP (SCM_CAR (x)), @@ -629,7 +638,7 @@ scm_m_case (SCM xorig, SCM env) proc = SCM_CAR (x); SCM_ASSYNT (scm_ilength (proc) >= 2, xorig, scm_s_clauses, s_case); SCM_ASSYNT (scm_ilength (SCM_CAR (proc)) >= 0 - || scm_sym_else == SCM_CAR (proc), + || SCM_EQ_P (scm_sym_else, SCM_CAR (proc)), xorig, scm_s_clauses, s_case); } return scm_cons (SCM_IM_CASE, cdrx); @@ -651,13 +660,13 @@ scm_m_cond (SCM xorig, SCM env) arg1 = SCM_CAR (x); len = scm_ilength (arg1); SCM_ASSYNT (len >= 1, xorig, scm_s_clauses, s_cond); - if (scm_sym_else == SCM_CAR (arg1)) + if (SCM_EQ_P (scm_sym_else, SCM_CAR (arg1))) { SCM_ASSYNT (SCM_NULLP (SCM_CDR (x)) && len >= 2, xorig, "bad ELSE clause", s_cond); SCM_SETCAR (arg1, SCM_BOOL_T); } - if (len >= 2 && scm_sym_arrow == SCM_CAR (SCM_CDR (arg1))) + if (len >= 2 && SCM_EQ_P (scm_sym_arrow, SCM_CAR (SCM_CDR (arg1)))) SCM_ASSYNT (3 == len && SCM_NIMP (SCM_CAR (SCM_CDR (SCM_CDR (arg1)))), xorig, "bad recipient", s_cond); x = SCM_CDR (x); @@ -677,7 +686,7 @@ scm_m_lambda (SCM xorig, SCM env) proc = SCM_CAR (x); if (SCM_NULLP (proc)) goto memlambda; - if (SCM_IM_LET == proc) /* named let */ + if (SCM_EQ_P (SCM_IM_LET, proc)) /* named let */ goto memlambda; if (SCM_IMP (proc)) goto badforms; @@ -694,7 +703,7 @@ scm_m_lambda (SCM xorig, SCM env) else goto memlambda; } - if (!(SCM_NIMP (SCM_CAR (proc)) && SCM_SYMBOLP (SCM_CAR (proc)))) + if (!SCM_SYMBOLP (SCM_CAR (proc))) goto badforms; proc = SCM_CDR (proc); } @@ -725,8 +734,7 @@ scm_m_letstar (SCM xorig, SCM env) { arg1 = SCM_CAR (proc); SCM_ASSYNT (2 == scm_ilength (arg1), xorig, scm_s_bindings, s_letstar); - SCM_ASSYNT (SCM_NIMP (SCM_CAR (arg1)) && SCM_SYMBOLP (SCM_CAR (arg1)), - xorig, scm_s_variable, s_letstar); + SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), xorig, scm_s_variable, s_letstar); *varloc = scm_cons2 (SCM_CAR (arg1), SCM_CAR (SCM_CDR (arg1)), SCM_EOL); varloc = SCM_CDRLOC (SCM_CDR (*varloc)); proc = SCM_CDR (proc); @@ -769,8 +777,7 @@ scm_m_do (SCM xorig, SCM env) arg1 = SCM_CAR (proc); len = scm_ilength (arg1); SCM_ASSYNT (2 == len || 3 == len, xorig, scm_s_bindings, "do"); - SCM_ASSYNT (SCM_NIMP (SCM_CAR (arg1)) && SCM_SYMBOLP (SCM_CAR (arg1)), - xorig, scm_s_variable, "do"); + SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), xorig, scm_s_variable, "do"); /* vars reversed here, inits and steps reversed at evaluation */ vars = scm_cons (SCM_CAR (arg1), vars); /* variable */ arg1 = SCM_CDR (arg1); @@ -828,23 +835,23 @@ iqq (SCM form,SCM env,int depth) if (SCM_NCONSP(form)) return form; tmp = SCM_CAR (form); - if (scm_sym_quasiquote == tmp) + if (SCM_EQ_P (scm_sym_quasiquote, tmp)) { depth++; goto label; } - if (scm_sym_unquote == tmp) + if (SCM_EQ_P (scm_sym_unquote, tmp)) { --depth; label: form = SCM_CDR (form); - SCM_ASSERT (SCM_NIMP (form) && SCM_ECONSP (form) && SCM_NULLP (SCM_CDR (form)), - form, SCM_ARG1, s_quasiquote); + SCM_ASSERT (SCM_ECONSP (form) && SCM_NULLP (SCM_CDR (form)), + form, SCM_ARG1, s_quasiquote); if (0 == depth) return evalcar (form, env); return scm_cons2 (tmp, iqq (SCM_CAR (form), env, depth), SCM_EOL); } - if (SCM_NIMP (tmp) && (scm_sym_uq_splicing == SCM_CAR (tmp))) + if (SCM_NIMP (tmp) && (SCM_EQ_P (scm_sym_uq_splicing, SCM_CAR (tmp)))) { tmp = SCM_CDR (tmp); if (0 == --edepth) @@ -878,12 +885,12 @@ scm_m_define (SCM x, SCM env) SCM_ASSYNT (scm_ilength (x) >= 2, arg1, scm_s_expression, s_define); proc = SCM_CAR (x); x = SCM_CDR (x); - while (SCM_NIMP (proc) && SCM_CONSP (proc)) + while (SCM_CONSP (proc)) { /* nested define syntax */ x = scm_cons (scm_cons2 (scm_sym_lambda, SCM_CDR (proc), x), SCM_EOL); proc = SCM_CAR (proc); } - SCM_ASSYNT (SCM_NIMP (proc) && SCM_SYMBOLP (proc), + SCM_ASSYNT (SCM_SYMBOLP (proc), arg1, scm_s_variable, s_define); SCM_ASSYNT (1 == scm_ilength (x), arg1, scm_s_expression, s_define); if (SCM_TOP_LEVEL (env)) @@ -896,10 +903,10 @@ scm_m_define (SCM x, SCM env) proc: if (SCM_CLOSUREP (arg1) /* Only the first definition determines the name. */ - && scm_procedure_property (arg1, scm_sym_name) == SCM_BOOL_F) + && SCM_FALSEP (scm_procedure_property (arg1, scm_sym_name))) scm_set_procedure_property_x (arg1, scm_sym_name, proc); else if (SCM_TYP16 (arg1) == scm_tc16_macro - && SCM_CDR (arg1) != arg1) + && !SCM_EQ_P (SCM_CDR (arg1), arg1)) { arg1 = SCM_CDR (arg1); goto proc; @@ -944,7 +951,7 @@ scm_m_letrec1 (SCM op, SCM imm, SCM xorig, SCM env) /* vars scm_list reversed here, inits reversed at evaluation */ arg1 = SCM_CAR (proc); ASRTSYNTAX (2 == scm_ilength (arg1), scm_s_bindings); - ASRTSYNTAX (SCM_NIMP (SCM_CAR (arg1)) && SCM_SYMBOLP (SCM_CAR (arg1)), + ASRTSYNTAX (SCM_SYMBOLP (SCM_CAR (arg1)), scm_s_variable); vars = scm_cons (SCM_CAR (arg1), vars); *initloc = scm_cons (SCM_CAR (SCM_CDR (arg1)), SCM_EOL); @@ -988,8 +995,7 @@ scm_m_let (SCM xorig, SCM env) SCM_ASSYNT (scm_ilength (x) >= 2, xorig, scm_s_body, s_let); proc = SCM_CAR (x); if (SCM_NULLP (proc) - || (SCM_NIMP (proc) && SCM_CONSP (proc) - && SCM_NIMP (SCM_CAR (proc)) + || (SCM_CONSP (proc) && SCM_CONSP (SCM_CAR (proc)) && SCM_NULLP (SCM_CDR (proc)))) { /* null or single binding, let* is faster */ @@ -1018,7 +1024,7 @@ scm_m_let (SCM xorig, SCM env) { /* vars and inits both in order */ arg1 = SCM_CAR (proc); SCM_ASSYNT (2 == scm_ilength (arg1), xorig, scm_s_bindings, s_let); - SCM_ASSYNT (SCM_NIMP (SCM_CAR (arg1)) && SCM_SYMBOLP (SCM_CAR (arg1)), + SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), xorig, scm_s_variable, s_let); *varloc = scm_cons (SCM_CAR (arg1), SCM_EOL); varloc = SCM_CDRLOC (*varloc); @@ -1063,8 +1069,8 @@ scm_m_cont (SCM xorig, SCM env) /* Multi-language support */ -SCM scm_nil; -SCM scm_t; +SCM scm_lisp_nil; +SCM scm_lisp_t; SCM_SYNTAX (s_nil_cond, "nil-cond", scm_makmmacro, scm_m_nil_cond); @@ -1136,7 +1142,7 @@ scm_m_atfop (SCM xorig, SCM env) SCM x = SCM_CDR (xorig), vcell; SCM_ASSYNT (scm_ilength (x) >= 1, xorig, scm_s_expression, "@fop"); vcell = scm_symbol_fref (SCM_CAR (x)); - SCM_ASSYNT (SCM_NIMP (vcell) && SCM_CONSP (vcell), x, + SCM_ASSYNT (SCM_CONSP (vcell), x, "Symbol's function definition is void", NULL); SCM_SETCAR (x, vcell + 1); return x; @@ -1191,7 +1197,7 @@ scm_m_expand_body (SCM xorig, SCM env) SCM_CDR (form)), env); - if (SCM_IM_DEFINE == SCM_CAR (form)) + if (SCM_EQ_P (SCM_IM_DEFINE, SCM_CAR (form))) { defs = scm_cons (SCM_CDR (form), defs); x = SCM_CDR(x); @@ -1200,7 +1206,7 @@ scm_m_expand_body (SCM xorig, SCM env) { break; } - else if (SCM_IM_BEGIN == SCM_CAR (form)) + else if (SCM_EQ_P (SCM_IM_BEGIN, SCM_CAR (form))) { x = scm_append (scm_cons2 (SCM_CDR (form), SCM_CDR (x), SCM_EOL)); } @@ -1260,7 +1266,7 @@ scm_macroexp (SCM x, SCM env) if (SCM_IMP (proc) || scm_tc16_macro != SCM_TYP16 (proc) - || (int) (SCM_CAR (proc) >> 16) != 2) + || (int) (SCM_UNPACK_CAR (proc) >> 16) != 2) return x; unmemocar (x, env); @@ -1293,6 +1299,8 @@ scm_macroexp (SCM x, SCM env) * readable style... :) */ +#define SCM_BIT8(x) (127 & SCM_UNPACK (x)) + static SCM unmemocopy (SCM x, SCM env) { @@ -1307,28 +1315,28 @@ unmemocopy (SCM x, SCM env) #endif switch (SCM_TYP7 (x)) { - case (127 & SCM_IM_AND): + case SCM_BIT8(SCM_IM_AND): ls = z = scm_cons (scm_sym_and, SCM_UNSPECIFIED); break; - case (127 & SCM_IM_BEGIN): + case SCM_BIT8(SCM_IM_BEGIN): ls = z = scm_cons (scm_sym_begin, SCM_UNSPECIFIED); break; - case (127 & SCM_IM_CASE): + case SCM_BIT8(SCM_IM_CASE): ls = z = scm_cons (scm_sym_case, SCM_UNSPECIFIED); break; - case (127 & SCM_IM_COND): + case SCM_BIT8(SCM_IM_COND): ls = z = scm_cons (scm_sym_cond, SCM_UNSPECIFIED); break; - case (127 & SCM_IM_DO): + case SCM_BIT8(SCM_IM_DO): ls = scm_cons (scm_sym_do, SCM_UNSPECIFIED); goto transform; - case (127 & SCM_IM_IF): + case SCM_BIT8(SCM_IM_IF): ls = z = scm_cons (scm_sym_if, SCM_UNSPECIFIED); break; - case (127 & SCM_IM_LET): + case SCM_BIT8(SCM_IM_LET): ls = scm_cons (scm_sym_let, SCM_UNSPECIFIED); goto transform; - case (127 & SCM_IM_LETREC): + case SCM_BIT8(SCM_IM_LETREC): { SCM f, v, e, s; ls = scm_cons (scm_sym_letrec, SCM_UNSPECIFIED); @@ -1340,10 +1348,10 @@ unmemocopy (SCM x, SCM env) z = EXTEND_ENV (f, SCM_EOL, env); /* inits */ e = scm_reverse (unmemocopy (SCM_CAR (x), - SCM_CAR (ls) == scm_sym_letrec ? z : env)); + SCM_EQ_P (SCM_CAR (ls), scm_sym_letrec) ? z : env)); env = z; /* increments */ - s = SCM_CAR (ls) == scm_sym_do + s = SCM_EQ_P (SCM_CAR (ls), scm_sym_do) ? scm_reverse (unmemocopy (SCM_CDR (SCM_CDR (SCM_CDR (x))), env)) : f; /* build transformed binding list */ @@ -1352,7 +1360,7 @@ unmemocopy (SCM x, SCM env) { z = scm_acons (SCM_CAR (v), scm_cons (SCM_CAR (e), - SCM_CAR (s) == SCM_CAR (v) + SCM_EQ_P (SCM_CAR (s), SCM_CAR (v)) ? SCM_EOL : scm_cons (SCM_CAR (s), SCM_EOL)), z); @@ -1363,7 +1371,7 @@ unmemocopy (SCM x, SCM env) while (SCM_NIMP (v)); z = scm_cons (z, SCM_UNSPECIFIED); SCM_SETCDR (ls, z); - if (SCM_CAR (ls) == scm_sym_do) + if (SCM_EQ_P (SCM_CAR (ls), scm_sym_do)) { x = SCM_CDR (x); /* test clause */ @@ -1376,7 +1384,7 @@ unmemocopy (SCM x, SCM env) } break; } - case (127 & SCM_IM_LETSTAR): + case SCM_BIT8(SCM_IM_LETSTAR): { SCM b, y; x = SCM_CDR (x); @@ -1415,22 +1423,22 @@ unmemocopy (SCM x, SCM env) ls = scm_cons (scm_sym_letstar, z = scm_cons (y, SCM_UNSPECIFIED)); break; } - case (127 & SCM_IM_OR): + case SCM_BIT8(SCM_IM_OR): ls = z = scm_cons (scm_sym_or, SCM_UNSPECIFIED); break; - case (127 & SCM_IM_LAMBDA): + case SCM_BIT8(SCM_IM_LAMBDA): x = SCM_CDR (x); ls = scm_cons (scm_sym_lambda, z = scm_cons (SCM_CAR (x), SCM_UNSPECIFIED)); env = EXTEND_ENV (SCM_CAR (x), SCM_EOL, env); break; - case (127 & SCM_IM_QUOTE): + case SCM_BIT8(SCM_IM_QUOTE): ls = z = scm_cons (scm_sym_quote, SCM_UNSPECIFIED); break; - case (127 & SCM_IM_SET_X): + case SCM_BIT8(SCM_IM_SET_X): ls = z = scm_cons (scm_sym_set_x, SCM_UNSPECIFIED); break; - case (127 & SCM_IM_DEFINE): + case SCM_BIT8(SCM_IM_DEFINE): { SCM n; x = SCM_CDR (x); @@ -1440,7 +1448,7 @@ unmemocopy (SCM x, SCM env) SCM_SETCAR (SCM_CAR (env), scm_cons (n, SCM_CAR (SCM_CAR (env)))); break; } - case (127 & SCM_MAKISYM (0)): + case SCM_BIT8(SCM_MAKISYM (0)): z = SCM_CAR (x); if (!SCM_ISYMP (z)) goto unmemo; @@ -1701,9 +1709,9 @@ scm_option scm_evaluator_trap_table[] = { { SCM_OPTION_BOOLEAN, "exit-frame", 0, "Trap when exiting eval or apply." } }; -GUILE_PROC (scm_eval_options_interface, "eval-options-interface", 0, 1, 0, +SCM_DEFINE (scm_eval_options_interface, "eval-options-interface", 0, 1, 0, (SCM setting), -"") + "") #define FUNC_NAME s_scm_eval_options_interface { SCM ans; @@ -1718,9 +1726,9 @@ GUILE_PROC (scm_eval_options_interface, "eval-options-interface", 0, 1, 0, } #undef FUNC_NAME -GUILE_PROC (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0, +SCM_DEFINE (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0, (SCM setting), -"") + "") #define FUNC_NAME s_scm_evaluator_traps { SCM ans; @@ -1782,11 +1790,7 @@ scm_deval_args (SCM l, SCM env, SCM proc, SCM *lloc) */ #ifndef DEVAL -#ifdef SCM_FLOATS #define CHECK_EQVISH(A,B) (((A) == (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B))))) -#else -#define CHECK_EQVISH(A,B) ((A) == (B)) -#endif #endif /* DEVAL */ #define BUILTIN_RPASUBR /* Handle rpsubrs and asubrs without calling apply */ @@ -1835,8 +1839,8 @@ SCM_CEVAL (SCM x, SCM env) scm_last_debug_frame = &debug; #endif #ifdef EVAL_STACK_CHECKING - if (SCM_STACK_OVERFLOW_P ((SCM_STACKITEM *) &proc) - && scm_stack_checking_enabled_p) + if (scm_stack_checking_enabled_p + && SCM_STACK_OVERFLOW_P ((SCM_STACKITEM *) &proc)) { #ifdef DEVAL debug.info->e.exp = x; @@ -1914,7 +1918,7 @@ dispatch: x = scm_cons (x, SCM_UNDEFINED); goto retval; - case (127 & SCM_IM_AND): + case SCM_BIT8(SCM_IM_AND): x = SCM_CDR (x); t.arg1 = x; while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1))) @@ -1927,7 +1931,7 @@ dispatch: PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto carloop; - case (127 & SCM_IM_BEGIN): + case SCM_BIT8(SCM_IM_BEGIN): cdrxnoap: PREP_APPLY (SCM_UNDEFINED, SCM_EOL); cdrxbegin: @@ -1967,13 +1971,13 @@ dispatch: goto loop; /* tail recurse */ - case (127 & SCM_IM_CASE): + case SCM_BIT8(SCM_IM_CASE): x = SCM_CDR (x); t.arg1 = EVALCAR (x, env); while (SCM_NIMP (x = SCM_CDR (x))) { proc = SCM_CAR (x); - if (scm_sym_else == SCM_CAR (proc)) + if (SCM_EQ_P (scm_sym_else, SCM_CAR (proc))) { x = SCM_CDR (proc); PREP_APPLY (SCM_UNDEFINED, SCM_EOL); @@ -1994,7 +1998,7 @@ dispatch: RETURN (SCM_UNSPECIFIED) - case (127 & SCM_IM_COND): + case SCM_BIT8(SCM_IM_COND): while (SCM_NIMP (x = SCM_CDR (x))) { proc = SCM_CAR (x); @@ -2006,7 +2010,7 @@ dispatch: { RETURN (t.arg1) } - if (scm_sym_arrow != SCM_CAR (x)) + if (! SCM_EQ_P (scm_sym_arrow, SCM_CAR (x))) { PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto begin; @@ -2022,7 +2026,7 @@ dispatch: RETURN (SCM_UNSPECIFIED) - case (127 & SCM_IM_DO): + case SCM_BIT8(SCM_IM_DO): x = SCM_CDR (x); proc = SCM_CAR (SCM_CDR (x)); /* inits */ t.arg1 = SCM_EOL; /* values */ @@ -2053,7 +2057,7 @@ dispatch: goto begin; - case (127 & SCM_IM_IF): + case SCM_BIT8(SCM_IM_IF): x = SCM_CDR (x); if (SCM_NFALSEP (EVALCAR (x, env))) x = SCM_CDR (x); @@ -2065,7 +2069,7 @@ dispatch: goto carloop; - case (127 & SCM_IM_LET): + case SCM_BIT8(SCM_IM_LET): x = SCM_CDR (x); proc = SCM_CAR (SCM_CDR (x)); t.arg1 = SCM_EOL; @@ -2079,7 +2083,7 @@ dispatch: goto cdrxnoap; - case (127 & SCM_IM_LETREC): + case SCM_BIT8(SCM_IM_LETREC): x = SCM_CDR (x); env = EXTEND_ENV (SCM_CAR (x), scm_undefineds, env); x = SCM_CDR (x); @@ -2094,7 +2098,7 @@ dispatch: goto cdrxnoap; - case (127 & SCM_IM_LETSTAR): + case SCM_BIT8(SCM_IM_LETSTAR): x = SCM_CDR (x); proc = SCM_CAR (x); if (SCM_IMP (proc)) @@ -2111,7 +2115,7 @@ dispatch: while (SCM_NIMP (proc = SCM_CDR (proc))); goto cdrxnoap; - case (127 & SCM_IM_OR): + case SCM_BIT8(SCM_IM_OR): x = SCM_CDR (x); t.arg1 = x; while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1))) @@ -2127,15 +2131,15 @@ dispatch: goto carloop; - case (127 & SCM_IM_LAMBDA): + case SCM_BIT8(SCM_IM_LAMBDA): RETURN (scm_closure (SCM_CDR (x), env)); - case (127 & SCM_IM_QUOTE): + case SCM_BIT8(SCM_IM_QUOTE): RETURN (SCM_CAR (SCM_CDR (x))); - case (127 & SCM_IM_SET_X): + case SCM_BIT8(SCM_IM_SET_X): x = SCM_CDR (x); proc = SCM_CAR (x); switch (7 & (int) proc) @@ -2161,11 +2165,11 @@ dispatch: #endif - case (127 & SCM_IM_DEFINE): /* only for internal defines */ + case SCM_BIT8(SCM_IM_DEFINE): /* only for internal defines */ scm_misc_error (NULL, "Bad define placement", SCM_EOL); /* new syntactic forms go here. */ - case (127 & SCM_MAKISYM (0)): + case SCM_BIT8(SCM_MAKISYM (0)): proc = SCM_CAR (x); SCM_ASRTGO (SCM_ISYMP (proc), badfun); switch SCM_ISYMNUM (proc) @@ -2295,8 +2299,8 @@ dispatch: if (SCM_NIMP (t.arg1)) do { - i += (SCM_STRUCT_DATA (scm_class_of (SCM_CAR (t.arg1))) - [scm_si_hashsets + hashset]); + i += SCM_STRUCT_DATA (scm_class_of (SCM_CAR (t.arg1))) + [scm_si_hashsets + hashset]; t.arg1 = SCM_CDR (t.arg1); } while (--j && SCM_NIMP (t.arg1)); @@ -2314,7 +2318,7 @@ dispatch: do { /* More arguments than specifiers => CLASS != ENV */ - if (scm_class_of (SCM_CAR (t.arg1)) != SCM_CAR (z)) + if (! SCM_EQ_P (scm_class_of (SCM_CAR (t.arg1)), SCM_CAR (z))) goto next_method; t.arg1 = SCM_CDR (t.arg1); z = SCM_CDR (z); @@ -2340,20 +2344,15 @@ dispatch: case (SCM_ISYMNUM (SCM_IM_SLOT_REF)): x = SCM_CDR (x); t.arg1 = EVALCAR (x, env); - proc = SCM_STRUCT_DATA (t.arg1)[SCM_INUM (SCM_CADR (x))]; - if (proc == SCM_UNBOUND) - scm_misc_error (NULL, - "Unbound slot in object %S", - SCM_LIST1 (t.arg1)); - RETURN (proc) + RETURN (SCM_PACK (SCM_STRUCT_DATA (t.arg1) [SCM_INUM (SCM_CADR (x))])) case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X)): x = SCM_CDR (x); t.arg1 = EVALCAR (x, env); x = SCM_CDR (x); proc = SCM_CDR (x); - SCM_STRUCT_DATA (t.arg1)[SCM_INUM (SCM_CAR (x))] - = EVALCAR (proc, env); + SCM_STRUCT_DATA (t.arg1) [SCM_INUM (SCM_CAR (x))] + = SCM_UNPACK (EVALCAR (proc, env)); RETURN (SCM_UNSPECIFIED) case (SCM_ISYMNUM (SCM_IM_NIL_COND)): @@ -2361,9 +2360,9 @@ dispatch: while (SCM_NIMP (x = SCM_CDR (proc))) { if (!(SCM_FALSEP (t.arg1 = EVALCAR (proc, env)) - || t.arg1 == scm_nil)) + || t.arg1 == scm_lisp_nil)) { - if (SCM_CAR (x) == SCM_UNSPECIFIED) + if (SCM_EQ_P (SCM_CAR (x), SCM_UNSPECIFIED)) RETURN (t.arg1); PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto carloop; @@ -2377,12 +2376,12 @@ dispatch: case (SCM_ISYMNUM (SCM_IM_NIL_IFY)): x = SCM_CDR (x); RETURN ((SCM_FALSEP (proc = EVALCAR (x, env)) || SCM_NULLP (proc)) - ? scm_nil + ? scm_lisp_nil : proc) case (SCM_ISYMNUM (SCM_IM_T_IFY)): x = SCM_CDR (x); - RETURN (SCM_NFALSEP (EVALCAR (x, env)) ? scm_t : scm_nil) + RETURN (SCM_NFALSEP (EVALCAR (x, env)) ? scm_lisp_t : scm_lisp_nil) case (SCM_ISYMNUM (SCM_IM_0_COND)): proc = SCM_CDR (x); @@ -2391,7 +2390,7 @@ dispatch: if (!(SCM_FALSEP (t.arg1 = EVALCAR (proc, env)) || t.arg1 == SCM_INUM0)) { - if (SCM_CAR (x) == SCM_UNSPECIFIED) + if (SCM_EQ_P (SCM_CAR (x), SCM_UNSPECIFIED)) RETURN (t.arg1); PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto carloop; @@ -2422,7 +2421,8 @@ dispatch: while (SCM_NIMP (arg2)) { proc = SCM_GLOC_VAL (SCM_CAR (t.arg1)); - SCM_SETCDR (SCM_CAR (t.arg1) - 1L, SCM_CAR (arg2)); + SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t.arg1)) - 1L), + SCM_CAR (arg2)); SCM_SETCAR (arg2, proc); t.arg1 = SCM_CDR (t.arg1); arg2 = SCM_CDR (arg2); @@ -2442,7 +2442,8 @@ dispatch: arg2 = SCM_CDAR (env); while (SCM_NIMP (arg2)) { - SCM_SETCDR (SCM_CAR (t.arg1) - 1L, SCM_CAR (arg2)); + SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t.arg1)) - 1L), + SCM_CAR (arg2)); t.arg1 = SCM_CDR (t.arg1); arg2 = SCM_CDR (arg2); } @@ -2458,7 +2459,7 @@ dispatch: badfun: /* scm_everr (x, env,...) */ scm_misc_error (NULL, - "Wrong type to apply: %S", + "Wrong type to apply: ~S", scm_listify (proc, SCM_UNDEFINED)); case scm_tc7_vector: case scm_tc7_wvect: @@ -2487,7 +2488,7 @@ dispatch: RETURN (x); #ifdef MEMOIZE_LOCALS - case (127 & SCM_ILOC00): + case SCM_BIT8(SCM_ILOC00): proc = *scm_ilookup (SCM_CAR (x), env); SCM_ASRTGO (SCM_NIMP (proc), badfun); #ifndef SCM_RECKLESS @@ -2549,7 +2550,7 @@ dispatch: #ifdef DEVAL SCM_CLEAR_MACROEXP (debug); #endif - switch ((int) (SCM_CAR (proc) >> 16)) + switch ((int) (SCM_UNPACK_CAR (proc) >> 16)) { case 2: if (scm_ilength (t.arg1) <= 0) @@ -2737,7 +2738,6 @@ evapply: case scm_tc7_subr_1o: RETURN (SCM_SUBRF (proc) (t.arg1)); case scm_tc7_cxr: -#ifdef SCM_FLOATS if (SCM_SUBRF (proc)) { if (SCM_INUMP (t.arg1)) @@ -2760,13 +2760,12 @@ evapply: SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), t.arg1, SCM_ARG1, SCM_CHARS (SCM_SNAME (proc))); } -#endif proc = (SCM) SCM_SNAME (proc); { char *chrs = SCM_CHARS (proc) + SCM_LENGTH (proc) - 1; while ('c' != *--chrs) { - SCM_ASSERT (SCM_NIMP (t.arg1) && SCM_CONSP (t.arg1), + SCM_ASSERT (SCM_CONSP (t.arg1), t.arg1, SCM_ARG1, SCM_CHARS (proc)); t.arg1 = ('a' == *chrs) ? SCM_CAR (t.arg1) : SCM_CDR (t.arg1); } @@ -3187,13 +3186,13 @@ ret: you if you do (scm_apply scm_apply '( ... ))" If you know what they're referring to, send me a patch to this comment. */ -GUILE_PROC(scm_nconc2last, "apply:nconc2last", 1, 0, 0, +SCM_DEFINE (scm_nconc2last, "apply:nconc2last", 1, 0, 0, (SCM lst), -"") + "") #define FUNC_NAME s_scm_nconc2last { SCM *lloc; - SCM_VALIDATE_LIST(1,lst); + SCM_VALIDATE_NONEMPTYLIST (1,lst); lloc = &lst; while (SCM_NNULLP (SCM_CDR (*lloc))) lloc = SCM_CDRLOC (*lloc); @@ -3288,7 +3287,7 @@ SCM_APPLY (SCM proc, SCM arg1, SCM args) } else { - /* SCM_ASRTGO(SCM_NIMP(args) && SCM_CONSP(args), wrongnumargs); */ + /* SCM_ASRTGO(SCM_CONSP(args), wrongnumargs); */ args = scm_nconc2last (args); #ifdef DEVAL debug.vect[0].a.args = scm_cons (arg1, args); @@ -3333,7 +3332,6 @@ tail: RETURN (SCM_SUBRF (proc) (arg1)) case scm_tc7_cxr: SCM_ASRTGO (SCM_NULLP (args), wrongnumargs); -#ifdef SCM_FLOATS if (SCM_SUBRF (proc)) { if (SCM_INUMP (arg1)) @@ -3353,13 +3351,12 @@ tail: SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1, SCM_ARG1, SCM_CHARS (SCM_SNAME (proc))); } -#endif proc = (SCM) SCM_SNAME (proc); { char *chrs = SCM_CHARS (proc) + SCM_LENGTH (proc) - 1; while ('c' != *--chrs) { - SCM_ASSERT (SCM_NIMP (arg1) && SCM_CONSP (arg1), + SCM_ASSERT (SCM_CONSP (arg1), arg1, SCM_ARG1, SCM_CHARS (proc)); arg1 = ('a' == *chrs) ? SCM_CAR (arg1) : SCM_CDR (arg1); } @@ -3374,7 +3371,7 @@ tail: RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args))) #endif case scm_tc7_lsubr_2: - SCM_ASRTGO (SCM_NIMP (args) && SCM_CONSP (args), wrongnumargs); + SCM_ASRTGO (SCM_CONSP (args), wrongnumargs); RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CDR (args))) case scm_tc7_asubr: if (SCM_NULLP (args)) @@ -3415,8 +3412,7 @@ tail: else { SCM tl = args = scm_cons (SCM_CAR (arg1), SCM_UNSPECIFIED); - while (SCM_NIMP (arg1 = SCM_CDR (arg1)) - && SCM_CONSP (arg1)) + while (arg1 = SCM_CDR (arg1), SCM_CONSP (arg1)) { SCM_SETCDR (tl, scm_cons (SCM_CAR (arg1), SCM_UNSPECIFIED)); @@ -3689,7 +3685,7 @@ long scm_tc16_promise; SCM scm_makprom (SCM code) { - SCM_RETURN_NEWSMOB (scm_tc16_promise, code); + SCM_RETURN_NEWSMOB (scm_tc16_promise, SCM_UNPACK (code)); } @@ -3707,16 +3703,16 @@ prinprom (SCM exp,SCM port,scm_print_state *pstate) } -GUILE_PROC(scm_force, "force", 1, 0, 0, +SCM_DEFINE (scm_force, "force", 1, 0, 0, (SCM x), -"") + "") #define FUNC_NAME s_scm_force { - SCM_VALIDATE_SMOB(1,x,promise); - if (!((1L << 16) & SCM_CAR (x))) + SCM_VALIDATE_SMOB (1,x,promise); + if (!((1L << 16) & SCM_UNPACK_CAR (x))) { SCM ans = scm_apply (SCM_CDR (x), SCM_EOL, SCM_EOL); - if (!((1L << 16) & SCM_CAR (x))) + if (!((1L << 16) & SCM_UNPACK_CAR (x))) { SCM_DEFER_INTS; SCM_SETCDR (x, ans); @@ -3728,19 +3724,19 @@ GUILE_PROC(scm_force, "force", 1, 0, 0, } #undef FUNC_NAME -GUILE_PROC (scm_promise_p, "promise?", 1, 0, 0, +SCM_DEFINE (scm_promise_p, "promise?", 1, 0, 0, (SCM x), -"Return true if @var{obj} is a promise, i.e. a delayed computation -(@pxref{Delayed evaluation,,,r4rs.info,The Revised^4 Report on Scheme}).") + "Return true if @var{obj} is a promise, i.e. a delayed computation\n" + "(@pxref{Delayed evaluation,,,r4rs.info,The Revised^4 Report on Scheme}).") #define FUNC_NAME s_scm_promise_p { return SCM_BOOL(SCM_NIMP (x) && (SCM_TYP16 (x) == scm_tc16_promise)); } #undef FUNC_NAME -GUILE_PROC (scm_cons_source, "cons-source", 3, 0, 0, +SCM_DEFINE (scm_cons_source, "cons-source", 3, 0, 0, (SCM xorig, SCM x, SCM y), -"") + "") #define FUNC_NAME s_scm_cons_source { SCM p, z; @@ -3755,13 +3751,13 @@ GUILE_PROC (scm_cons_source, "cons-source", 3, 0, 0, } #undef FUNC_NAME -GUILE_PROC (scm_copy_tree, "copy-tree", 1, 0, 0, +SCM_DEFINE (scm_copy_tree, "copy-tree", 1, 0, 0, (SCM obj), -"Recursively copy the data tree that is bound to @var{obj}, and return a -pointer to the new data structure. @code{copy-tree} recurses down the -contents of both pairs and vectors (since both cons cells and vector -cells may point to arbitrary objects), and stops recursing when it hits -any other object.") + "Recursively copy the data tree that is bound to @var{obj}, and return a\n" + "pointer to the new data structure. @code{copy-tree} recurses down the\n" + "contents of both pairs and vectors (since both cons cells and vector\n" + "cells may point to arbitrary objects), and stops recursing when it hits\n" + "any other object.") #define FUNC_NAME s_scm_copy_tree { SCM ans, tl; @@ -3781,7 +3777,7 @@ any other object.") ans = tl = scm_cons_source (obj, scm_copy_tree (SCM_CAR (obj)), SCM_UNSPECIFIED); - while (SCM_NIMP (obj = SCM_CDR (obj)) && SCM_CONSP (obj)) + while (obj = SCM_CDR (obj), SCM_CONSP (obj)) { SCM_SETCDR (tl, scm_cons (scm_copy_tree (SCM_CAR (obj)), SCM_UNSPECIFIED)); @@ -3803,21 +3799,21 @@ scm_eval_3 (SCM obj, int copyp, SCM env) return SCM_XEVAL (obj, env); } -GUILE_PROC(scm_eval2, "eval2", 2, 0, 0, +SCM_DEFINE (scm_eval2, "eval2", 2, 0, 0, (SCM obj, SCM env_thunk), -"Evaluate @var{exp}, a Scheme expression, in the environment designated -by @var{lookup}, a symbol-lookup function. @code{(eval exp)} is -equivalent to @code{(eval2 exp *top-level-lookup-closure*)}.") + "Evaluate @var{exp}, a Scheme expression, in the environment designated\n" + "by @var{lookup}, a symbol-lookup function. @code{(eval exp)} is\n" + "equivalent to @code{(eval2 exp *top-level-lookup-closure*)}.") #define FUNC_NAME s_scm_eval2 { return scm_eval_3 (obj, 1, scm_top_level_env (env_thunk)); } #undef FUNC_NAME -GUILE_PROC(scm_eval, "eval", 1, 0, 0, +SCM_DEFINE (scm_eval, "eval", 1, 0, 0, (SCM obj), -"Evaluate @var{exp}, a list representing a Scheme expression, in the -top-level environment.") + "Evaluate @var{exp}, a list representing a Scheme expression, in the\n" + "top-level environment.") #define FUNC_NAME s_scm_eval { return scm_eval_3 (obj, @@ -3873,12 +3869,12 @@ scm_init_eval () scm_sym_unquote = SCM_CAR (scm_sysintern ("unquote", SCM_UNDEFINED)); scm_sym_uq_splicing = SCM_CAR (scm_sysintern ("unquote-splicing", SCM_UNDEFINED)); - scm_nil = scm_sysintern ("nil", SCM_UNDEFINED); - SCM_SETCDR (scm_nil, SCM_CAR (scm_nil)); - scm_nil = SCM_CAR (scm_nil); - scm_t = scm_sysintern ("t", SCM_UNDEFINED); - SCM_SETCDR (scm_t, SCM_CAR (scm_t)); - scm_t = SCM_CAR (scm_t); + scm_lisp_nil = scm_sysintern ("nil", SCM_UNDEFINED); + SCM_SETCDR (scm_lisp_nil, SCM_CAR (scm_lisp_nil)); + scm_lisp_nil = SCM_CAR (scm_lisp_nil); + scm_lisp_t = scm_sysintern ("t", SCM_UNDEFINED); + SCM_SETCDR (scm_lisp_t, SCM_CAR (scm_lisp_t)); + scm_lisp_t = SCM_CAR (scm_lisp_t); /* acros */ /* end of acros */ @@ -3900,3 +3896,9 @@ scm_init_eval () } #endif /* !DEVAL */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/