X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/3b3b36ddb7dfbd5094abee360c253c8f1216dcdd..d8c40b9f49836a0d8c28b49ff5346033c50e113d:/libguile/eval.c diff --git a/libguile/eval.c b/libguile/eval.c index 59481e4a6..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); @@ -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) @@ -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; @@ -826,12 +835,12 @@ 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: @@ -842,7 +851,7 @@ iqq (SCM form,SCM env,int 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) @@ -894,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; @@ -1060,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); @@ -1188,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); @@ -1197,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)); } @@ -1257,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); @@ -1290,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) { @@ -1304,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); @@ -1337,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 */ @@ -1349,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); @@ -1360,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 */ @@ -1373,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); @@ -1412,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); @@ -1437,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; @@ -1700,7 +1711,7 @@ scm_option scm_evaluator_trap_table[] = { SCM_DEFINE (scm_eval_options_interface, "eval-options-interface", 0, 1, 0, (SCM setting), -"") + "") #define FUNC_NAME s_scm_eval_options_interface { SCM ans; @@ -1717,7 +1728,7 @@ SCM_DEFINE (scm_eval_options_interface, "eval-options-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; @@ -1779,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 */ @@ -1911,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))) @@ -1924,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: @@ -1964,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); @@ -1991,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); @@ -2003,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; @@ -2019,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 */ @@ -2050,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); @@ -2062,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; @@ -2076,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); @@ -2091,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)) @@ -2108,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))) @@ -2124,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) @@ -2158,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) @@ -2292,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)); @@ -2311,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); @@ -2337,15 +2344,15 @@ dispatch: case (SCM_ISYMNUM (SCM_IM_SLOT_REF)): x = SCM_CDR (x); t.arg1 = EVALCAR (x, env); - RETURN (SCM_STRUCT_DATA (t.arg1)[SCM_INUM (SCM_CADR (x))]) + 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)): @@ -2353,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; @@ -2369,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); @@ -2383,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; @@ -2414,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); @@ -2434,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); } @@ -2450,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: @@ -2479,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 @@ -2541,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) @@ -2729,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)) @@ -2752,7 +2760,6 @@ 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; @@ -3181,11 +3188,11 @@ ret: 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); @@ -3325,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)) @@ -3345,7 +3351,6 @@ 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; @@ -3680,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)); } @@ -3700,14 +3705,14 @@ prinprom (SCM exp,SCM port,scm_print_state *pstate) 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))) + 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); @@ -3721,8 +3726,8 @@ SCM_DEFINE (scm_force, "force", 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)); @@ -3731,7 +3736,7 @@ SCM_DEFINE (scm_promise_p, "promise?", 1, 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; @@ -3748,11 +3753,11 @@ SCM_DEFINE (scm_cons_source, "cons-source", 3, 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; @@ -3796,9 +3801,9 @@ scm_eval_3 (SCM obj, int copyp, SCM env) 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)); @@ -3807,8 +3812,8 @@ equivalent to @code{(eval2 exp *top-level-lookup-closure*)}.") 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, @@ -3864,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 */ @@ -3891,3 +3896,9 @@ scm_init_eval () } #endif /* !DEVAL */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/