-/* 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
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
+
+/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
+ gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
+
\f
/* This file is read twice in order to produce debugging versions of
#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 "validate.h"
#include "eval.h"
-void (*scm_memoize_method) (SCM, SCM);
+SCM (*scm_memoize_method) (SCM, SCM);
\f
*/
#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
#ifdef MEMOIZE_LOCALS
SCM *
-scm_ilookup (iloc, env)
- SCM iloc;
- SCM env;
+scm_ilookup (SCM iloc, SCM env)
{
register int ir = SCM_IFRAME (iloc);
register SCM er = 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)
#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);
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 */
#endif
}
#ifdef MEMOIZE_LOCALS
- iloc = (~SCM_IDSTMSK) & (iloc + SCM_IFRINC);
+ iloc = SCM_PACK ((~SCM_IDSTMSK) & SCM_UNPACK(iloc + SCM_IFRINC));
#endif
}
{
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;
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);
}
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
#ifdef USE_THREADS
SCM *
-scm_lookupcar (vloc, genv, check)
- SCM vloc;
- SCM genv;
- int check;
+scm_lookupcar (SCM vloc, SCM genv, int check)
{
SCM *loc = scm_lookupcar1 (vloc, genv, check);
if (loc == NULL)
#define unmemocar scm_unmemocar
SCM
-scm_unmemocar (form, env)
- SCM form;
- SCM env;
+scm_unmemocar (SCM form, SCM env)
{
#ifdef DEBUG_EXTENSIONS
register int ir;
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))
SCM
-scm_eval_car (pair, env)
- SCM pair;
- SCM env;
+scm_eval_car (SCM pair, SCM env)
{
return SCM_XEVALCAR (pair, env);
}
const char scm_s_clauses[] = "bad or missing clauses";
const char scm_s_formals[] = "bad formals";
-SCM scm_sym_dot, scm_sym_arrow, scm_sym_else, scm_sym_unquote, scm_sym_uq_splicing, scm_sym_apply;
+SCM scm_sym_dot, scm_sym_arrow, scm_sym_else;
+SCM scm_sym_unquote, scm_sym_uq_splicing, scm_sym_apply;
+
+SCM scm_f_apply;
#ifdef DEBUG_EXTENSIONS
SCM scm_sym_enter_frame, scm_sym_apply_frame, scm_sym_exit_frame;
-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 (xorig, bodyloc, what)
- SCM xorig;
- SCM *bodyloc;
- const char *what;
+bodycheck (SCM xorig, SCM *bodyloc, const char *what)
{
ASRTSYNTAX (scm_ilength (*bodyloc) >= 1, scm_s_expression);
}
This is not done yet. */
static SCM
-scm_m_body (op, xorig, what)
- SCM op;
- SCM xorig;
- char *what;
+scm_m_body (SCM op, SCM xorig, const char *what)
{
ASRTSYNTAX (scm_ilength (xorig) >= 1, scm_s_expression);
SCM_GLOBAL_SYMBOL(scm_sym_quote, s_quote);
SCM
-scm_m_quote (xorig, env)
- SCM xorig;
- SCM env;
+scm_m_quote (SCM xorig, SCM env)
{
SCM x = scm_copy_tree (SCM_CDR (xorig));
SCM_GLOBAL_SYMBOL(scm_sym_begin, s_begin);
SCM
-scm_m_begin (xorig, env)
- SCM xorig;
- SCM env;
+scm_m_begin (SCM xorig, SCM env)
{
SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) >= 1,
xorig, scm_s_expression, s_begin);
SCM_GLOBAL_SYMBOL(scm_sym_if, s_if);
SCM
-scm_m_if (xorig, env)
- SCM xorig;
- SCM env;
+scm_m_if (SCM xorig, SCM env)
{
int len = scm_ilength (SCM_CDR (xorig));
SCM_ASSYNT (len >= 2 && len <= 3, xorig, scm_s_expression, "if");
SCM_GLOBAL_SYMBOL(scm_sym_set_x, scm_s_set_x);
SCM
-scm_m_set_x (xorig, env)
- SCM xorig;
- SCM env;
+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);
}
#if 0
SCM
-scm_m_vref (xorig, env)
- SCM xorig;
- SCM env;
+scm_m_vref (SCM xorig, SCM env)
{
SCM x = SCM_CDR (xorig);
SCM_ASSYNT (1 == scm_ilength (x), xorig, scm_s_expression, s_vref);
{
/* 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)),
SCM
-scm_m_vset (xorig, env)
- SCM xorig;
- SCM env;
+scm_m_vset (SCM xorig, SCM env)
{
SCM x = SCM_CDR (xorig);
SCM_ASSYNT (3 == scm_ilength (x), xorig, scm_s_expression, s_vset);
SCM_GLOBAL_SYMBOL(scm_sym_and, s_and);
SCM
-scm_m_and (xorig, env)
- SCM xorig;
- SCM env;
+scm_m_and (SCM xorig, SCM env)
{
int len = scm_ilength (SCM_CDR (xorig));
SCM_ASSYNT (len >= 0, xorig, scm_s_test, s_and);
SCM_GLOBAL_SYMBOL(scm_sym_or,s_or);
SCM
-scm_m_or (xorig, env)
- SCM xorig;
- SCM env;
+scm_m_or (SCM xorig, SCM env)
{
int len = scm_ilength (SCM_CDR (xorig));
SCM_ASSYNT (len >= 0, xorig, scm_s_test, s_or);
SCM_GLOBAL_SYMBOL(scm_sym_case, s_case);
SCM
-scm_m_case (xorig, env)
- SCM xorig;
- SCM env;
+scm_m_case (SCM xorig, SCM env)
{
SCM proc, cdrx = scm_list_copy (SCM_CDR (xorig)), x = cdrx;
SCM_ASSYNT (scm_ilength (x) >= 2, xorig, scm_s_clauses, s_case);
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);
SCM
-scm_m_cond (xorig, env)
- SCM xorig;
- SCM env;
+scm_m_cond (SCM xorig, SCM env)
{
SCM arg1, cdrx = scm_list_copy (SCM_CDR (xorig)), x = cdrx;
int len = scm_ilength (x);
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);
SCM_GLOBAL_SYMBOL(scm_sym_lambda, s_lambda);
SCM
-scm_m_lambda (xorig, env)
- SCM xorig;
- SCM env;
+scm_m_lambda (SCM xorig, SCM env)
{
SCM proc, x = SCM_CDR (xorig);
if (scm_ilength (x) < 2)
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;
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);
}
SCM
-scm_m_letstar (xorig, env)
- SCM xorig;
- SCM env;
+scm_m_letstar (SCM xorig, SCM env)
{
SCM x = SCM_CDR (xorig), arg1, proc, vars = SCM_EOL, *varloc = &vars;
int len = scm_ilength (x);
{
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);
SCM_GLOBAL_SYMBOL(scm_sym_do, s_do);
SCM
-scm_m_do (xorig, env)
- SCM xorig;
- SCM env;
+scm_m_do (SCM xorig, SCM env)
{
SCM x = SCM_CDR (xorig), arg1, proc;
SCM vars = SCM_EOL, inits = SCM_EOL, steps = SCM_EOL;
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);
#define evalcar scm_eval_car
-static SCM iqq SCM_P ((SCM form, SCM env, int depth));
+static SCM iqq (SCM form, SCM env, int depth);
SCM_SYNTAX(s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote);
SCM_GLOBAL_SYMBOL(scm_sym_quasiquote, s_quasiquote);
SCM
-scm_m_quasiquote (xorig, env)
- SCM xorig;
- SCM env;
+scm_m_quasiquote (SCM xorig, SCM env)
{
SCM x = SCM_CDR (xorig);
SCM_ASSYNT (scm_ilength (x) == 1, xorig, scm_s_expression, s_quasiquote);
static SCM
-iqq (form, env, depth)
- SCM form;
- SCM env;
- int depth;
+iqq (SCM form,SCM env,int depth)
{
SCM tmp;
int edepth = 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)
/* Here are acros which return values rather than code. */
-SCM_SYNTAX(s_delay, "delay", scm_makacro, scm_m_delay);
+SCM_SYNTAX (s_delay, "delay", scm_makmmacro, scm_m_delay);
+SCM_GLOBAL_SYMBOL (scm_sym_delay, s_delay);
SCM
-scm_m_delay (xorig, env)
- SCM xorig;
- SCM env;
+scm_m_delay (SCM xorig, SCM env)
{
SCM_ASSYNT (scm_ilength (xorig) == 2, xorig, scm_s_expression, s_delay);
- xorig = SCM_CDR (xorig);
- return scm_makprom (scm_closure (scm_cons2 (SCM_EOL, SCM_CAR (xorig),
- SCM_CDR (xorig)),
- env));
+ return scm_cons2 (SCM_IM_DELAY, SCM_EOL, SCM_CDR (xorig));
}
SCM_GLOBAL_SYMBOL(scm_sym_define, s_define);
SCM
-scm_m_define (x, env)
- SCM x;
- SCM env;
+scm_m_define (SCM x, SCM env)
{
SCM proc, arg1 = x;
x = SCM_CDR (x);
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))
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;
/* end of acros */
static SCM
-scm_m_letrec1 (op, imm, xorig, env)
- SCM op;
- SCM imm;
- SCM xorig;
- SCM env;
+scm_m_letrec1 (SCM op, SCM imm, SCM xorig, SCM env)
{
SCM cdrx = SCM_CDR (xorig); /* locally mutable version of form */
char *what = SCM_CHARS (SCM_CAR (xorig));
/* 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);
SCM_GLOBAL_SYMBOL(scm_sym_letrec, s_letrec);
SCM
-scm_m_letrec (xorig, env)
- SCM xorig;
- SCM env;
+scm_m_letrec (SCM xorig, SCM env)
{
SCM x = SCM_CDR (xorig);
SCM_ASSYNT (scm_ilength (x) >= 2, xorig, scm_s_body, s_letrec);
SCM_GLOBAL_SYMBOL(scm_sym_let, s_let);
SCM
-scm_m_let (xorig, env)
- SCM xorig;
- SCM env;
+scm_m_let (SCM xorig, SCM env)
{
SCM cdrx = SCM_CDR (xorig); /* locally mutable version of form */
SCM x = cdrx, proc, arg1, name; /* structure traversers */
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 */
{ /* 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);
}
-SCM_SYNTAX(s_atapply,"@apply", scm_makmmacro, scm_m_apply);
-SCM_GLOBAL_SYMBOL(scm_sym_atapply, s_atapply);
+SCM_SYNTAX (s_atapply,"@apply", scm_makmmacro, scm_m_apply);
+SCM_GLOBAL_SYMBOL (scm_sym_atapply, s_atapply);
+SCM_GLOBAL_SYMBOL (scm_sym_apply, s_atapply + 1);
SCM
-scm_m_apply (xorig, env)
- SCM xorig;
- SCM env;
+scm_m_apply (SCM xorig, SCM env)
{
SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2,
xorig, scm_s_expression, s_atapply);
SCM
-scm_m_cont (xorig, env)
- SCM xorig;
- SCM env;
+scm_m_cont (SCM xorig, SCM env)
{
SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1,
xorig, scm_s_expression, s_atcall_cc);
/* 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);
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;
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);
{
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));
}
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);
* readable style... :)
*/
-static SCM unmemocopy SCM_P ((SCM x, SCM env));
+#define SCM_BIT8(x) (127 & SCM_UNPACK (x))
static SCM
-unmemocopy (x, env)
- SCM x;
- SCM env;
+unmemocopy (SCM x, SCM env)
{
SCM ls, z;
#ifdef DEBUG_EXTENSIONS
#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);
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 */
{
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);
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 */
}
break;
}
- case (127 & SCM_IM_LETSTAR):
+ case SCM_BIT8(SCM_IM_LETSTAR):
{
SCM b, y;
x = SCM_CDR (x);
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);
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;
case (SCM_ISYMNUM (SCM_IM_CONT)):
ls = z = scm_cons (scm_sym_atcall_cc, SCM_UNSPECIFIED);
goto loop;
+ case (SCM_ISYMNUM (SCM_IM_DELAY)):
+ ls = z = scm_cons (scm_sym_delay, SCM_UNSPECIFIED);
+ x = SCM_CDR (x);
+ goto loop;
default:
/* appease the Sun compiler god: */ ;
}
SCM
-scm_unmemocopy (x, env)
- SCM x;
- SCM env;
+scm_unmemocopy (SCM x, SCM env)
{
if (SCM_NNULLP (env))
/* Make a copy of the lowest frame to protect it from
#ifndef SCM_RECKLESS
int
-scm_badargsp (formals, args)
- SCM formals;
- SCM args;
+scm_badargsp (SCM formals, SCM args)
{
while (SCM_NIMP (formals))
{
\f
SCM
-scm_eval_args (l, env, proc)
- SCM l;
- SCM env;
- SCM proc;
+scm_eval_args (SCM l, SCM env, SCM proc)
{
SCM results = SCM_EOL, *lloc = &results, res;
while (SCM_NIMP (l))
return results;
}
+SCM
+scm_eval_body (SCM code, SCM env)
+{
+ SCM next;
+ again:
+ next = code;
+ while (SCM_NNULLP (next = SCM_CDR (next)))
+ {
+ if (SCM_IMP (SCM_CAR (code)))
+ {
+ if (SCM_ISYMP (SCM_CAR (code)))
+ {
+ code = scm_m_expand_body (code, env);
+ goto again;
+ }
+ }
+ else
+ SCM_XEVAL (SCM_CAR (code), env);
+ code = next;
+ }
+ return SCM_XEVALCAR (code, env);
+}
+
#endif /* !DEVAL */
{ ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
#undef ENTER_APPLY
#define ENTER_APPLY \
-{\
+do { \
SCM_SET_ARGSREADY (debug);\
if (CHECK_APPLY && SCM_TRAPS_P)\
if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
{\
- SCM tmp, tail = SCM_TRACED_FRAME_P (debug) ? SCM_BOOL_T : SCM_BOOL_F;\
+ SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
SCM_SET_TRACED_FRAME (debug); \
if (SCM_CHEAPTRAPS_P)\
{\
scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
}\
}\
-}
+} while (0)
#undef RETURN
#define RETURN(e) {proc = (e); goto exit;}
#ifdef STACK_CHECKING
*/
-SCM (*scm_ceval_ptr) SCM_P ((SCM x, SCM env));
+SCM (*scm_ceval_ptr) (SCM x, SCM env);
/* scm_last_debug_frame contains a pointer to the last debugging
* information stack frame. It is accessed very often from the
"Record procedure names at definition." },
{ SCM_OPTION_BOOLEAN, "backwards", 0,
"Display backtrace in anti-chronological order." },
+ { SCM_OPTION_INTEGER, "width", 79, "Maximal width of backtrace." },
{ SCM_OPTION_INTEGER, "indent", 10, "Maximal indentation in backtrace." },
{ SCM_OPTION_INTEGER, "frames", 3,
"Maximum number of tail-recursive frames in backtrace." },
{ SCM_OPTION_BOOLEAN, "exit-frame", 0, "Trap when exiting eval or apply." }
};
-SCM_PROC (s_eval_options_interface, "eval-options-interface", 0, 1, 0, scm_eval_options_interface);
-
-SCM
-scm_eval_options_interface (SCM setting)
+SCM_DEFINE (scm_eval_options_interface, "eval-options-interface", 0, 1, 0,
+ (SCM setting),
+ "")
+#define FUNC_NAME s_scm_eval_options_interface
{
SCM ans;
SCM_DEFER_INTS;
ans = scm_options (setting,
scm_eval_opts,
SCM_N_EVAL_OPTIONS,
- s_eval_options_interface);
+ FUNC_NAME);
scm_eval_stack = SCM_EVAL_STACK * sizeof (void *);
SCM_ALLOW_INTS;
return ans;
}
+#undef FUNC_NAME
-SCM_PROC (s_evaluator_traps, "evaluator-traps-interface", 0, 1, 0, scm_evaluator_traps);
-
-SCM
-scm_evaluator_traps (setting)
- SCM setting;
+SCM_DEFINE (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0,
+ (SCM setting),
+ "")
+#define FUNC_NAME s_scm_evaluator_traps
{
SCM ans;
SCM_DEFER_INTS;
ans = scm_options (setting,
scm_evaluator_trap_table,
SCM_N_EVALUATOR_TRAPS,
- s_evaluator_traps);
+ FUNC_NAME);
SCM_RESET_DEBUG_MODE;
- SCM_ALLOW_INTS
+ SCM_ALLOW_INTS;
return ans;
}
+#undef FUNC_NAME
SCM
-scm_deval_args (l, env, proc, lloc)
- SCM l, env, proc, *lloc;
+scm_deval_args (SCM l, SCM env, SCM proc, SCM *lloc)
{
SCM *results = lloc, res;
while (SCM_NIMP (l))
*/
#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 */
#if 0
SCM
-scm_ceval (x, env)
- SCM x;
- SCM env;
+scm_ceval (SCM x, SCM env)
{}
#endif
#if 0
SCM
-scm_deval (x, env)
- SCM x;
- SCM env;
+scm_deval (SCM x, SCM env)
{}
#endif
SCM
-SCM_CEVAL (x, env)
- SCM x;
- SCM env;
+SCM_CEVAL (SCM x, SCM env)
{
union
{
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;
if (CHECK_ENTRY && SCM_TRAPS_P)
if (SCM_ENTER_FRAME_P || (SCM_BREAKPOINTS_P && SRCBRKP (x)))
{
- SCM tail = SCM_TAILRECP (debug) ? SCM_BOOL_T : SCM_BOOL_F;
+ SCM tail = SCM_BOOL(SCM_TAILRECP (debug));
SCM_SET_TAILREC (debug);
if (SCM_CHEAPTRAPS_P)
t.arg1 = scm_make_debugobj (&debug);
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)))
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:
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);
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);
{
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;
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 */
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);
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;
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);
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))
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)))
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)
#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)
x = SCM_CODE (proc);
goto cdrxbegin;
}
- proc = scm_sym_apply;
+ proc = scm_f_apply;
goto evapply;
case (SCM_ISYMNUM (SCM_IM_CONT)):
{
SCM val;
val = SCM_THROW_VALUE (t.arg1);
- RETURN (val);
+ RETURN (val)
}
proc = SCM_CDR (x);
proc = evalcar (proc, env);
ENTER_APPLY;
goto evap1;
+ case (SCM_ISYMNUM (SCM_IM_DELAY)):
+ RETURN (scm_makprom (scm_closure (SCM_CDR (x), env)))
+
case (SCM_ISYMNUM (SCM_IM_DISPATCH)):
- /* (SCM_IM_DISPATCH ARGS N-SPECIALIZED
- * #((TYPE1 ... ENV FORMALS FORM ...) ...)
- * GF)
- */
- case (SCM_ISYMNUM (SCM_IM_HASH_DISPATCH)):
- /* (SCM_IM_HASH_DISPATCH ARGS N-SPECIALIZED HASHSET MASK
- * #((TYPE1 ... ENV FORMALS FORM ...) ...)
- * GF)
- *
- * ARGS is either a list of expressions, in which case they
- * are interpreted as the arguments of an application, or
- * a non-pair, which is interpreted as a single expression
- * yielding all arguments.
- *
- * SCM_IM_DISPATCH expressions in generic functions always
- * have ARGS = the symbol `args' or the iloc #@0-0.
- *
- * Need FORMALS in order to support varying arity. This
- * also avoids the need for renaming of bindings.
- *
- * We should probably not complicate this mechanism by
- * introducing "optimizations" for getters and setters or
- * primitive methods. Getters and setter will normally be
- * compiled into @slot-[ref|set!] or a procedure call.
- * They rely on the dispatch performed before executing
- * the code which contains them.
- *
- * We might want to use a more efficient representation of
- * this form in the future, perhaps after we have introduced
- * low-level support for syntax-case macros.
+ proc = SCM_CADR (x); /* unevaluated operands */
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ if (SCM_IMP (proc))
+ arg2 = *scm_ilookup (proc, env);
+ else if (SCM_NCONSP (proc))
+ {
+ if (SCM_NCELLP (proc))
+ arg2 = SCM_GLOC_VAL (proc);
+ else
+ arg2 = *scm_lookupcar (SCM_CDR (x), env, 1);
+ }
+ else
+ {
+ arg2 = scm_cons (EVALCAR (proc, env), SCM_EOL);
+ t.lloc = SCM_CDRLOC (arg2);
+ while (SCM_NIMP (proc = SCM_CDR (proc)))
+ {
+ *t.lloc = scm_cons (EVALCAR (proc, env), SCM_EOL);
+ t.lloc = SCM_CDRLOC (*t.lloc);
+ }
+ }
+
+ type_dispatch:
+ /* The type dispatch code is duplicated here
+ * (c.f. objects.c:scm_mcache_compute_cmethod) since that
+ * cuts down execution time for type dispatch to 50%.
*/
{
int i, n, end, mask;
- SCM z = SCM_CADR (x); /* unevaluated operands */
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- if (SCM_IMP (z))
- arg2 = *scm_ilookup (z, env);
- else if (SCM_NCONSP (z))
- {
- if (SCM_NCELLP (z))
- arg2 = SCM_GLOC_VAL (z);
- else
- arg2 = *scm_lookupcar (SCM_CDR (x), env, 1);
- }
- else
- {
- arg2 = scm_cons (EVALCAR (z, env), SCM_EOL);
- t.lloc = SCM_CDRLOC (arg2);
- while (SCM_NIMP (z = SCM_CDR (z)))
- {
- *t.lloc = scm_cons (EVALCAR (z, env), SCM_EOL);
- t.lloc = SCM_CDRLOC (*t.lloc);
- }
- }
-
- type_dispatch:
- z = SCM_CDDR (x);
+ SCM z = SCM_CDDR (x);
n = SCM_INUM (SCM_CAR (z)); /* maximum number of specializers */
- proc = SCM_CADR (z); /* method cache */
+ proc = SCM_CADR (z);
if (SCM_NIMP (proc))
{
proc = SCM_CADR (z);
i = 0;
t.arg1 = arg2;
- do
- {
- 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));
+ if (SCM_NIMP (t.arg1))
+ do
+ {
+ 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));
i &= mask;
end = i;
}
do
{
int j = n;
- SCM entry = SCM_VELTS (proc)[i];
+ z = SCM_VELTS (proc)[i];
t.arg1 = arg2; /* list of arguments */
- do
- {
- /* More arguments than specifiers => CLASS != ENV */
- if (scm_class_of (SCM_CAR (t.arg1)) != SCM_CAR (entry))
- goto next_method;
- t.arg1 = SCM_CDR (t.arg1);
- entry = SCM_CDR (entry);
- }
- while (--j && SCM_NIMP (t.arg1));
+ if (SCM_NIMP (t.arg1))
+ do
+ {
+ /* More arguments than specifiers => CLASS != ENV */
+ 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);
+ }
+ while (--j && SCM_NIMP (t.arg1));
/* Fewer arguments than specifiers => CAR != ENV */
- if (!SCM_CONSP (SCM_CAR (entry)))
+ if (!(SCM_IMP (SCM_CAR (z)) || SCM_CONSP (SCM_CAR (z))))
goto next_method;
- /* Copy the environment frame so that the dispatch form can
- be used also in normal code. */
- env = EXTEND_ENV (SCM_CADR (entry), arg2, SCM_CAR (entry));
- x = SCM_CDR (entry);
+ apply_cmethod:
+ env = EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (z)),
+ arg2,
+ SCM_CMETHOD_ENV (z));
+ x = SCM_CMETHOD_CODE (z);
goto cdrxbegin;
next_method:
i = (i + 1) & mask;
} while (i != end);
-
- /* No match - call external function and try again */
- scm_memoize_method (x, arg2);
- goto type_dispatch;
+
+ z = scm_memoize_method (x, arg2);
+ goto apply_cmethod;
}
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);
- RETURN (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)):
proc = SCM_CDR (x);
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;
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);
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;
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);
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);
}
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:
+#ifdef HAVE_ARRAYS
case scm_tc7_bvect:
case scm_tc7_byvect:
case scm_tc7_svect:
case scm_tc7_fvect:
case scm_tc7_dvect:
case scm_tc7_cvect:
-#ifdef LONGLONGS
+#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
+#endif
#endif
case scm_tc7_string:
case scm_tc7_substring:
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
#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)
env = EXTEND_ENV (SCM_CAR (x), SCM_EOL, SCM_ENV (proc));
goto cdrxbegin;
case scm_tcs_cons_gloc:
- if (!SCM_I_OPERATORP (proc))
+ if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
+ {
+ x = SCM_ENTITY_PROCEDURE (proc);
+ arg2 = SCM_EOL;
+ goto type_dispatch;
+ }
+ else if (!SCM_I_OPERATORP (proc))
goto badfun;
else
{
- x = (SCM_I_ENTITYP (proc)
- ? SCM_ENTITY_PROC_0 (proc)
- : SCM_OPERATOR_PROC_0 (proc));
- if (SCM_NIMP (x))
- {
- if (SCM_TYP7 (x) == scm_tc7_subr_1)
- RETURN (SCM_SUBRF (x) (proc))
- else if (SCM_CLOSUREP (x))
- {
- t.arg1 = proc;
- proc = x;
+ t.arg1 = proc;
+ proc = (SCM_I_ENTITYP (proc)
+ ? SCM_ENTITY_PROCEDURE (proc)
+ : SCM_OPERATOR_PROCEDURE (proc));
#ifdef DEVAL
- debug.info->a.args = scm_cons (t.arg1, SCM_EOL);
- debug.info->a.proc = proc;
+ debug.info->a.proc = proc;
+ debug.info->a.args = scm_cons (t.arg1, SCM_EOL);
#endif
- goto clos1;
- }
- }
- /* Fall through. */
+ if (SCM_NIMP (proc))
+ goto evap1;
+ else
+ goto badfun;
}
case scm_tc7_contin:
case scm_tc7_subr_1:
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))
}
#endif
floerr:
- scm_wta (t.arg1, (char *) SCM_ARG1, SCM_CHARS (SCM_SNAME (proc)));
+ 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);
}
#endif
goto evap1;
case scm_tcs_closures:
- clos1:
+ /* clos1: */
x = SCM_CODE (proc);
#ifdef DEVAL
env = EXTEND_ENV (SCM_CAR (x), debug.info->a.args, SCM_ENV (proc));
case scm_tcs_cons_gloc:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
{
+ x = SCM_ENTITY_PROCEDURE (proc);
#ifdef DEVAL
arg2 = debug.info->a.args;
#else
arg2 = scm_cons (t.arg1, SCM_EOL);
#endif
- x = SCM_ENTITY_PROC_1 (proc);
goto type_dispatch;
}
else if (!SCM_I_OPERATORP (proc))
goto badfun;
else
{
- x = (SCM_I_ENTITYP (proc)
- ? SCM_ENTITY_PROC_1 (proc)
- : SCM_OPERATOR_PROC_1 (proc));
- if (SCM_NIMP (x))
- {
- if (SCM_TYP7 (x) == scm_tc7_subr_2)
- RETURN (SCM_SUBRF (x) (proc, t.arg1))
- else if (SCM_CLOSUREP (x))
- {
- arg2 = t.arg1;
- t.arg1 = proc;
- proc = x;
+ arg2 = t.arg1;
+ t.arg1 = proc;
+ proc = (SCM_I_ENTITYP (proc)
+ ? SCM_ENTITY_PROCEDURE (proc)
+ : SCM_OPERATOR_PROCEDURE (proc));
#ifdef DEVAL
- debug.info->a.args = scm_cons (t.arg1,
- debug.info->a.args);
- debug.info->a.proc = proc;
+ debug.info->a.args = scm_cons (t.arg1, debug.info->a.args);
+ debug.info->a.proc = proc;
#endif
- goto clos2;
- }
- }
- /* Fall through. */
+ if (SCM_NIMP (proc))
+ goto evap2;
+ else
+ goto badfun;
}
case scm_tc7_subr_2:
case scm_tc7_subr_0:
cclon:
case scm_tc7_cclo:
#ifdef DEVAL
- RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), proc,
- scm_cons (debug.info->a.args, SCM_EOL)));
+ RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc),
+ scm_cons (proc, debug.info->a.args),
+ SCM_EOL));
#else
- RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), proc,
- scm_cons2 (t.arg1, arg2,
- scm_cons (scm_eval_args (x, env, proc),
- SCM_EOL))));
+ RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc),
+ scm_cons2 (proc, t.arg1,
+ scm_cons (arg2,
+ scm_eval_args (x,
+ env,
+ proc))),
+ SCM_EOL));
#endif
/* case scm_tc7_cclo:
x = scm_cons(arg2, scm_eval_args(x, env));
case scm_tcs_cons_gloc:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
{
+ x = SCM_ENTITY_PROCEDURE (proc);
#ifdef DEVAL
arg2 = debug.info->a.args;
#else
arg2 = scm_cons2 (t.arg1, arg2, SCM_EOL);
#endif
- x = SCM_ENTITY_PROC_2 (proc);
goto type_dispatch;
}
else if (!SCM_I_OPERATORP (proc))
goto badfun;
else
{
- x = (SCM_I_ENTITYP (proc)
- ? SCM_ENTITY_PROC_2 (proc)
- : SCM_OPERATOR_PROC_2 (proc));
- if (SCM_NIMP (x))
- {
- if (SCM_TYP7 (x) == scm_tc7_subr_3)
- RETURN (SCM_SUBRF (x) (proc, t.arg1, arg2))
- else if (SCM_CLOSUREP (x))
- {
+ operatorn:
#ifdef DEVAL
- SCM_SET_ARGSREADY (debug);
- debug.info->a.args = scm_cons (proc,
- debug.info->a.args);
- debug.info->a.proc = x;
-#endif
- env = EXTEND_ENV (SCM_CAR (SCM_CODE (x)),
- scm_cons2 (proc, t.arg1,
- scm_cons (arg2, SCM_EOL)),
- SCM_ENV (x));
- x = SCM_CODE (x);
- goto cdrxbegin;
- }
- }
- /* Fall through. */
+ RETURN (SCM_APPLY (SCM_I_ENTITYP (proc)
+ ? SCM_ENTITY_PROCEDURE (proc)
+ : SCM_OPERATOR_PROCEDURE (proc),
+ scm_cons (proc, debug.info->a.args),
+ SCM_EOL));
+#else
+ RETURN (SCM_APPLY (SCM_I_ENTITYP (proc)
+ ? SCM_ENTITY_PROCEDURE (proc)
+ : SCM_OPERATOR_PROCEDURE (proc),
+ scm_cons2 (proc, t.arg1,
+ scm_cons (arg2,
+ scm_eval_args (x,
+ env,
+ proc))),
+ SCM_EOL));
+#endif
}
case scm_tc7_subr_0:
case scm_tc7_cxr:
default:
goto badfun;
case scm_tcs_closures:
- clos2:
+ /* clos2: */
#ifdef DEVAL
env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)),
debug.info->a.args,
#else
arg2 = scm_cons2 (t.arg1, arg2, scm_eval_args (x, env, proc));
#endif
- x = SCM_ENTITY_PROC_3 (proc);
+ x = SCM_ENTITY_PROCEDURE (proc);
goto type_dispatch;
}
else if (!SCM_I_OPERATORP (proc))
goto badfun;
else
- {
- SCM p = (SCM_I_ENTITYP (proc)
- ? SCM_ENTITY_PROC_3 (proc)
- : SCM_OPERATOR_PROC_3 (proc));
- if (SCM_NIMP (p))
- {
- if (SCM_TYP7 (p) == scm_tc7_lsubr_2)
-#ifdef DEVAL
- RETURN (SCM_SUBRF (p) (proc, t.arg1,
- scm_cons (arg2, SCM_CDDR (debug.info->a.args))))
-#else
- RETURN (SCM_SUBRF (p) (proc, t.arg1,
- scm_cons (arg2,
- scm_eval_args (x, env, proc))))
-#endif
- else if (SCM_CLOSUREP (p))
- {
-#ifdef DEVAL
- SCM_SET_ARGSREADY (debug);
- debug.info->a.args = scm_cons (proc, debug.info->a.args);
- debug.info->a.proc = p;
- env = EXTEND_ENV (SCM_CAR (SCM_CODE (p)),
- scm_cons2 (proc, t.arg1,
- scm_cons (arg2,
- SCM_CDDDR (debug.info->a.args))),
- SCM_ENV (p));
-#else
- env = EXTEND_ENV (SCM_CAR (SCM_CODE (p)),
- scm_cons2 (proc, t.arg1,
- scm_cons (arg2,
- scm_eval_args (x, env, proc))),
- SCM_ENV (p));
-#endif
- x = SCM_CODE (p);
- goto cdrxbegin;
- }
- }
- /* Fall through. */
- }
+ goto operatorn;
case scm_tc7_subr_2:
case scm_tc7_subr_1o:
case scm_tc7_subr_2o:
you if you do (scm_apply scm_apply '( ... ))" If you know what
they're referring to, send me a patch to this comment. */
-SCM_PROC(s_nconc2last, "apply:nconc2last", 1, 0, 0, scm_nconc2last);
-
-SCM
-scm_nconc2last (lst)
- SCM lst;
+SCM_DEFINE (scm_nconc2last, "apply:nconc2last", 1, 0, 0,
+ (SCM lst),
+ "")
+#define FUNC_NAME s_scm_nconc2last
{
SCM *lloc;
- SCM_ASSERT (scm_ilength (lst) > 0, lst, SCM_ARG1, s_nconc2last);
+ SCM_VALIDATE_NONEMPTYLIST (1,lst);
lloc = &lst;
while (SCM_NNULLP (SCM_CDR (*lloc)))
lloc = SCM_CDRLOC (*lloc);
- SCM_ASSERT (scm_ilength (SCM_CAR (*lloc)) >= 0, lst, SCM_ARG1, s_nconc2last);
+ SCM_ASSERT (scm_ilength (SCM_CAR (*lloc)) >= 0, lst, SCM_ARG1, FUNC_NAME);
*lloc = SCM_CAR (*lloc);
return lst;
}
-
-SCM_GLOBAL_SYMBOL (scm_sym_args, "args");
+#undef FUNC_NAME
#endif /* !DEVAL */
#if 0
SCM
-scm_apply (proc, arg1, args)
- SCM proc;
- SCM arg1;
- SCM args;
+scm_apply (SCM proc, SCM arg1, SCM args)
{}
#endif
#if 0
SCM
-scm_dapply (proc, arg1, args)
- SCM proc;
- SCM arg1;
- SCM args;
-{}
+scm_dapply (SCM proc, SCM arg1, SCM args)
+{ /* empty */ }
#endif
onto the front of your argument list, and pass that as ARGS. */
SCM
-SCM_APPLY (proc, arg1, args)
- SCM proc;
- SCM arg1;
- SCM args;
+SCM_APPLY (SCM proc, SCM arg1, SCM args)
{
#ifdef DEBUG_EXTENSIONS
#ifdef DEVAL
}
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);
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))
RETURN (scm_makdbl (SCM_DSUBRF (proc) (scm_big2dbl (arg1)), 0.0))
#endif
floerr:
- scm_wta (arg1, (char *) SCM_ARG1, SCM_CHARS (SCM_SNAME (proc)));
+ 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);
}
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))
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));
}
args = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), args, SCM_ENV (proc));
- proc = SCM_CODE (proc);
- while (SCM_NNULLP (proc = SCM_CDR (proc)))
- arg1 = EVALCAR (proc, args);
- RETURN (arg1);
+ proc = SCM_CDR (SCM_CODE (proc));
+ again:
+ arg1 = proc;
+ while (SCM_NNULLP (arg1 = SCM_CDR (arg1)))
+ {
+ if (SCM_IMP (SCM_CAR (proc)))
+ {
+ if (SCM_ISYMP (SCM_CAR (proc)))
+ {
+ proc = scm_m_expand_body (proc, args);
+ goto again;
+ }
+ }
+ else
+ SCM_CEVAL (SCM_CAR (proc), args);
+ proc = arg1;
+ }
+ RETURN (EVALCAR (proc, args));
case scm_tc7_contin:
SCM_ASRTGO (SCM_NULLP (args), wrongnumargs);
scm_call_continuation (proc, arg1);
#else
args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
#endif
- if (SCM_NULLP (args))
- {
- arg1 = proc;
- proc = SCM_ENTITY_PROC_0 (proc);
-#ifdef DEVAL
- debug.vect[0].a.proc = proc;
- debug.vect[0].a.args = scm_cons (arg1, args);
-#endif
- goto tail;
- }
- proc = (SCM_NULLP (SCM_CDR (args))
- ? SCM_ENTITY_PROC_1 (proc)
- : (SCM_NULLP (SCM_CDDR (args))
- ? SCM_ENTITY_PROC_2 (proc)
- : SCM_ENTITY_PROC_3 (proc)));
- RETURN (SCM_CEVAL (proc,
- scm_acons (scm_sym_args, args,
- scm_apply_generic_env)));
+ RETURN (scm_apply_generic (proc, args));
}
else if (!SCM_I_OPERATORP (proc))
goto badproc;
args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
#endif
arg1 = proc;
- proc = (SCM_NULLP (args)
- ? (SCM_I_ENTITYP (proc)
- ? SCM_ENTITY_PROC_0 (proc)
- : SCM_OPERATOR_PROC_0 (proc))
- : SCM_NULLP (SCM_CDR (args))
- ? (SCM_I_ENTITYP (proc)
- ? SCM_ENTITY_PROC_1 (proc)
- : SCM_OPERATOR_PROC_1 (proc))
- : SCM_NULLP (SCM_CDDR (args))
- ? (SCM_I_ENTITYP (proc)
- ? SCM_ENTITY_PROC_2 (proc)
- : SCM_OPERATOR_PROC_2 (proc))
- : (SCM_I_ENTITYP (proc)
- ? SCM_ENTITY_PROC_3 (proc)
- : SCM_OPERATOR_PROC_3 (proc)));
+ proc = (SCM_I_ENTITYP (proc)
+ ? SCM_ENTITY_PROCEDURE (proc)
+ : SCM_OPERATOR_PROCEDURE (proc));
#ifdef DEVAL
debug.vect[0].a.proc = proc;
debug.vect[0].a.args = scm_cons (arg1, args);
#endif
- goto tail;
+ if (SCM_NIMP (proc))
+ goto tail;
+ else
+ goto badproc;
}
wrongnumargs:
scm_wrong_num_args (proc);
/* Typechecking for multi-argument MAP and FOR-EACH.
- Verify that each element of the vector ARGS, except for the first,
+ Verify that each element of the vector ARGV, except for the first,
is a proper list whose length is LEN. Attribute errors to WHO,
- and claim that the i'th element of ARGS is WHO's i+2'th argument. */
+ and claim that the i'th element of ARGV is WHO's i+2'th argument. */
static inline void
-check_map_args (long len, SCM args, const char *who)
-{
- SCM *ve = SCM_VELTS (args);
+check_map_args (SCM argv,
+ long len,
+ SCM gf,
+ SCM proc,
+ SCM args,
+ const char *who)
+{
+ SCM *ve = SCM_VELTS (argv);
int i;
- for (i = SCM_LENGTH (args) - 1; i >= 1; i--)
+ for (i = SCM_LENGTH (argv) - 1; i >= 1; i--)
{
int elt_len = scm_ilength (ve[i]);
if (elt_len < 0)
- scm_wrong_type_arg (who, i + 2, ve[i]);
+ {
+ if (gf)
+ scm_apply_generic (gf, scm_cons (proc, args));
+ else
+ scm_wrong_type_arg (who, i + 2, ve[i]);
+ }
if (elt_len != len)
scm_out_of_range (who, ve[i]);
}
- scm_remember (&args);
+ scm_remember (&argv);
}
-SCM_PROC (s_map, "map", 2, 0, 1, scm_map);
+SCM_GPROC (s_map, "map", 2, 0, 1, scm_map, g_map);
/* Note: Currently, scm_map applies PROC to the argument list(s)
sequentially, starting with the first element(s). This is used in
*/
SCM
-scm_map (proc, arg1, args)
- SCM proc;
- SCM arg1;
- SCM args;
+scm_map (SCM proc, SCM arg1, SCM args)
{
long i, len;
SCM res = SCM_EOL;
if (SCM_NULLP (arg1))
return res;
len = scm_ilength (arg1);
- SCM_ASSERT (len >= 0, arg1, SCM_ARG2, s_map);
+ SCM_GASSERTn (len >= 0,
+ g_map, scm_cons2 (proc, arg1, args), SCM_ARG2, s_map);
if (SCM_NULLP (args))
{
while (SCM_NIMP (arg1))
{
- SCM_ASSERT (SCM_CONSP (arg1), arg1, SCM_ARG2, s_map);
- *pres = scm_cons (scm_apply (proc, SCM_CAR (arg1), scm_listofnull), SCM_EOL);
+ SCM_GASSERT2 (SCM_CONSP (arg1), g_map, proc, arg1, SCM_ARG2, s_map);
+ *pres = scm_cons (scm_apply (proc, SCM_CAR (arg1), scm_listofnull),
+ SCM_EOL);
pres = SCM_CDRLOC (*pres);
arg1 = SCM_CDR (arg1);
}
return res;
}
- args = scm_vector (scm_cons (arg1, args));
+ args = scm_vector (arg1 = scm_cons (arg1, args));
ve = SCM_VELTS (args);
#ifndef SCM_RECKLESS
- check_map_args (len, args, s_map);
+ check_map_args (args, len, g_map, proc, arg1, s_map);
#endif
while (1)
{
}
-SCM_PROC(s_for_each, "for-each", 2, 0, 1, scm_for_each);
+SCM_GPROC (s_for_each, "for-each", 2, 0, 1, scm_for_each, g_for_each);
SCM
-scm_for_each (proc, arg1, args)
- SCM proc;
- SCM arg1;
- SCM args;
+scm_for_each (SCM proc, SCM arg1, SCM args)
{
SCM *ve = &args; /* Keep args from being optimized away. */
long i, len;
if SCM_NULLP (arg1)
return SCM_UNSPECIFIED;
len = scm_ilength (arg1);
- SCM_ASSERT (len >= 0, arg1, SCM_ARG2, s_for_each);
+ SCM_GASSERTn (len >= 0, g_for_each, scm_cons2 (proc, arg1, args),
+ SCM_ARG2, s_for_each);
if SCM_NULLP (args)
{
while SCM_NIMP (arg1)
{
- SCM_ASSERT (SCM_CONSP (arg1), arg1, SCM_ARG2, s_for_each);
+ SCM_GASSERT2 (SCM_CONSP (arg1),
+ g_for_each, proc, arg1, SCM_ARG2, s_for_each);
scm_apply (proc, SCM_CAR (arg1), scm_listofnull);
arg1 = SCM_CDR (arg1);
}
return SCM_UNSPECIFIED;
}
- args = scm_vector (scm_cons (arg1, args));
+ args = scm_vector (arg1 = scm_cons (arg1, args));
ve = SCM_VELTS (args);
#ifndef SCM_RECKLESS
- check_map_args (len, args, s_for_each);
+ check_map_args (args, len, g_for_each, proc, arg1, s_for_each);
#endif
while (1)
{
SCM
-scm_closure (code, env)
- SCM code;
- SCM env;
+scm_closure (SCM code, SCM env)
{
register SCM z;
SCM_NEWCELL (z);
long scm_tc16_promise;
SCM
-scm_makprom (code)
- SCM code;
+scm_makprom (SCM code)
{
- SCM_RETURN_NEWSMOB (scm_tc16_promise, code);
+ SCM_RETURN_NEWSMOB (scm_tc16_promise, SCM_UNPACK (code));
}
-static int prinprom SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
-
static int
-prinprom (exp, port, pstate)
- SCM exp;
- SCM port;
- scm_print_state *pstate;
+prinprom (SCM exp,SCM port,scm_print_state *pstate)
{
int writingp = SCM_WRITINGP (pstate);
scm_puts ("#<promise ", port);
}
-SCM_PROC(s_force, "force", 1, 0, 0, scm_force);
-
-SCM
-scm_force (x)
- SCM x;
+SCM_DEFINE (scm_force, "force", 1, 0, 0,
+ (SCM x),
+ "")
+#define FUNC_NAME s_scm_force
{
- SCM_ASSERT (SCM_NIMP(x) && SCM_TYP16 (x) == scm_tc16_promise,
- x, SCM_ARG1, s_force);
- 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);
}
return SCM_CDR (x);
}
+#undef FUNC_NAME
-SCM_PROC (s_promise_p, "promise?", 1, 0, 0, scm_promise_p);
-
-SCM
-scm_promise_p (x)
- SCM x;
+SCM_DEFINE (scm_promise_p, "promise?", 1, 0, 0,
+ (SCM x),
+ "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_NIMP (x) && (SCM_TYP16 (x) == scm_tc16_promise))
- ? SCM_BOOL_T
- : SCM_BOOL_F);
+ return SCM_BOOL(SCM_NIMP (x) && (SCM_TYP16 (x) == scm_tc16_promise));
}
+#undef FUNC_NAME
-SCM_PROC (s_cons_source, "cons-source", 3, 0, 0, scm_cons_source);
-
-SCM
-scm_cons_source (SCM xorig, SCM x, SCM y)
+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;
SCM_NEWCELL (z);
scm_whash_insert (scm_source_whash, z, p);
return z;
}
+#undef FUNC_NAME
-SCM_PROC (s_copy_tree, "copy-tree", 1, 0, 0, scm_copy_tree);
-
-SCM
-scm_copy_tree (obj)
- SCM obj;
+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\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;
if (SCM_IMP (obj))
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));
SCM_SETCDR (tl, obj);
return ans;
}
+#undef FUNC_NAME
SCM
-scm_eval_3 (obj, copyp, env)
- SCM obj;
- int copyp;
- SCM env;
+scm_eval_3 (SCM obj, int copyp, SCM env)
{
if (SCM_NIMP (SCM_CDR (scm_system_transformer)))
obj = scm_apply (SCM_CDR (scm_system_transformer), obj, scm_listofnull);
return SCM_XEVAL (obj, env);
}
-SCM_PROC(s_eval2, "eval2", 2, 0, 0, scm_eval2);
-
-SCM
-scm_eval2 (obj, env_thunk)
- SCM obj;
- SCM env_thunk;
+SCM_DEFINE (scm_eval2, "eval2", 2, 0, 0,
+ (SCM obj, SCM env_thunk),
+ "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
-SCM_PROC(s_eval, "eval", 1, 0, 0, scm_eval);
-
-SCM
-scm_eval (obj)
- SCM obj;
+SCM_DEFINE (scm_eval, "eval", 1, 0, 0,
+ (SCM obj),
+ "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,
1,
scm_top_level_env
(SCM_CDR (scm_top_level_lookup_closure_var)));
}
+#undef FUNC_NAME
-/* SCM_PROC(s_eval_x, "eval!", 1, 0, 0, scm_eval_x); */
+/*
+SCM_REGISTER_PROC(s_eval_x, "eval!", 1, 0, 0, scm_eval_x);
+*/
SCM
-scm_eval_x (obj)
- SCM obj;
+scm_eval_x (SCM obj)
{
return scm_eval_3 (obj,
0,
(SCM_CDR (scm_top_level_lookup_closure_var)));
}
-static const scm_smobfuns promsmob = {scm_markcdr, scm_free0, prinprom};
-
/* At this point, scm_deval and scm_dapply are generated.
*/
scm_eval_opts,
SCM_N_EVAL_OPTIONS);
- scm_tc16_promise = scm_newsmob (&promsmob);
+ scm_tc16_promise = scm_make_smob_type ("promise", 0);
+ scm_set_smob_mark (scm_tc16_promise, scm_markcdr);
+ scm_set_smob_print (scm_tc16_promise, prinprom);
- scm_sym_apply = scm_make_subr ("apply", scm_tc7_lsubr_2, scm_apply);
+ scm_f_apply = scm_make_subr ("apply", scm_tc7_lsubr_2, scm_apply);
scm_system_transformer = scm_sysintern ("scm:eval-transformer", SCM_UNDEFINED);
scm_sym_dot = SCM_CAR (scm_sysintern (".", SCM_UNDEFINED));
scm_sym_arrow = SCM_CAR (scm_sysintern ("=>", SCM_UNDEFINED));
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 */
}
#endif /* !DEVAL */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
HCoop / bpt / guile.git / blobdiff