Commit 38d7fe2f authored by Jean-Claude Beaudoin's avatar Jean-Claude Beaudoin
Browse files

Replace instances of &rest with their C expansion. Step toward retirement of dpp.

parent ac3b64c1
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
Copyright (c) 1990, Giuseppe Attardi. Copyright (c) 1990, Giuseppe Attardi.
Copyright (c) 2001, Juan Jose Garcia Ripoll. Copyright (c) 2001, Juan Jose Garcia Ripoll.
Copyright (c) 2011-2017, Jean-Claude Beaudoin. Copyright (c) 2011-2017,2021 Jean-Claude Beaudoin.
MKCL is free software; you can redistribute it and/or MKCL is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public modify it under the terms of the GNU Lesser General Public
...@@ -192,48 +192,52 @@ mk_si_row_major_aset(MKCL, mkcl_object x, mkcl_object indx, mkcl_object val) ...@@ -192,48 +192,52 @@ mk_si_row_major_aset(MKCL, mkcl_object x, mkcl_object indx, mkcl_object val)
mkcl_return_value(mkcl_aset_index(env, x, j, val)); mkcl_return_value(mkcl_aset_index(env, x, j, val));
} }
@(defun array-row-major-index (x &rest indx) mkcl_object mk_cl_array_row_major_index(MKCL, const mkcl_narg narg, mkcl_object x, ...)
@ {
mkcl_call_stack_check(env);
{ {
mkcl_index i, j; mkcl_setup_for_rest(env, @'array-row-major-index', 1, narg, x, indx);
mkcl_index r = narg - 1; {
AGAIN: mkcl_index i, j;
switch (mkcl_type_of(x)) { mkcl_index r = narg - 1;
case mkcl_t_array: AGAIN:
if (r != x->array.rank) switch (mkcl_type_of(x)) {
mkcl_FEerror(env, "Wrong number of indices.", 0); case mkcl_t_array:
for (i = j = 0; i < r; i++) { if (r != x->array.rank)
mkcl_object index = mkcl_va_arg(indx); mkcl_FEerror(env, "Wrong number of indices.", 0);
mkcl_index dim = x->array.dims[i]; for (i = j = 0; i < r; i++) {
mkcl_index s; mkcl_object index = mkcl_va_arg(indx);
mkcl_index dim = x->array.dims[i];
if (!(MKCL_FIXNUMP(index) && ((s = mkcl_fixnum_to_word(index)) < dim))) mkcl_index s;
s = mkcl_fixnum_in_range(env, @'array-row-major-index', "index", index, 0, (mkcl_word)dim-1);
j = j*dim + s; if (!(MKCL_FIXNUMP(index) && ((s = mkcl_fixnum_to_word(index)) < dim)))
} s = mkcl_fixnum_in_range(env, @'array-row-major-index', "index", index, 0, (mkcl_word)dim-1);
break; j = j*dim + s;
case mkcl_t_vector: }
case mkcl_t_string: break;
case mkcl_t_base_string: case mkcl_t_vector:
case mkcl_t_bitvector: case mkcl_t_string:
if (r != 1) case mkcl_t_base_string:
mkcl_FEerror(env, "Wrong number of indices.", 0); case mkcl_t_bitvector:
{ if (r != 1)
mkcl_object index = mkcl_va_arg(indx); mkcl_FEerror(env, "Wrong number of indices.", 0);
{
mkcl_object index = mkcl_va_arg(indx);
if (!(MKCL_FIXNUMP(index) && ((j = mkcl_fixnum_to_word(index)) < x->vector.dim))) if (!(MKCL_FIXNUMP(index) && ((j = mkcl_fixnum_to_word(index)) < x->vector.dim)))
j = mkcl_fixnum_in_range(env, @'array-row-major-index', "index", index, 0, (mkcl_word)x->vector.dim-1); j = mkcl_fixnum_in_range(env, @'array-row-major-index', "index", index, 0, (mkcl_word)x->vector.dim-1);
}
break;
default:
x = mkcl_type_error(env, @'aref',"argument",x,@'array');
goto AGAIN;
} }
break; mkcl_va_end(indx);
default: /* By construction, "j" is a valid array index and should thus be within the range of fixnum. */
x = mkcl_type_error(env, @'aref',"argument",x,@'array'); mkcl_return_value(MKCL_MAKE_FIXNUM(j));
goto AGAIN;
} }
mkcl_va_end(indx); }
/* By construction, "j" is a valid array index and should thus be within the range of fixnum. */ }
mkcl_return_value(MKCL_MAKE_FIXNUM(j));
}
@)
mkcl_index mkcl_array_row_major_index_2_t(MKCL, mkcl_object a, mkcl_object i, mkcl_object j) mkcl_index mkcl_array_row_major_index_2_t(MKCL, mkcl_object a, mkcl_object i, mkcl_object j)
{ {
...@@ -297,47 +301,52 @@ mkcl_index mkcl_array_row_major_index_3_t(MKCL, mkcl_object a, mkcl_object i, mk ...@@ -297,47 +301,52 @@ mkcl_index mkcl_array_row_major_index_3_t(MKCL, mkcl_object a, mkcl_object i, mk
} }
} }
@(defun aref (x &rest indx) mkcl_object mk_cl_aref(MKCL, const mkcl_narg narg, mkcl_object x, ...)
@ {
mkcl_call_stack_check(env);
{ {
mkcl_index i, j; mkcl_setup_for_rest(env, @'aref', 1, narg, x, indx);
mkcl_index r = narg - 1; {
AGAIN: mkcl_index i, j;
switch (mkcl_type_of(x)) { mkcl_index r = narg - 1;
case mkcl_t_array: AGAIN:
if (r != x->array.rank) switch (mkcl_type_of(x)) {
mkcl_FEerror(env, "Wrong number of indices.", 0); case mkcl_t_array:
for (i = j = 0; i < r; i++) { if (r != x->array.rank)
mkcl_object index = mkcl_va_arg(indx); mkcl_FEerror(env, "Wrong number of indices.", 0);
mkcl_index dim = x->array.dims[i]; for (i = j = 0; i < r; i++) {
mkcl_index s; mkcl_object index = mkcl_va_arg(indx);
mkcl_index dim = x->array.dims[i];
if (!(MKCL_FIXNUMP(index) && ((s = mkcl_fixnum_to_word(index)) < dim))) mkcl_index s;
s = mkcl_fixnum_in_range(env, @'aref', "index", index, 0, (mkcl_word)dim-1);
j = j*dim + s; if (!(MKCL_FIXNUMP(index) && ((s = mkcl_fixnum_to_word(index)) < dim)))
} s = mkcl_fixnum_in_range(env, @'aref', "index", index, 0, (mkcl_word)dim-1);
break; j = j*dim + s;
case mkcl_t_vector: }
case mkcl_t_string: break;
case mkcl_t_base_string: case mkcl_t_vector:
case mkcl_t_bitvector: case mkcl_t_string:
if (r != 1) case mkcl_t_base_string:
mkcl_FEerror(env, "Wrong number of indices.", 0); case mkcl_t_bitvector:
{ if (r != 1)
mkcl_object index = mkcl_va_arg(indx); mkcl_FEerror(env, "Wrong number of indices.", 0);
{
mkcl_object index = mkcl_va_arg(indx);
if (!(MKCL_FIXNUMP(index) && ((j = mkcl_fixnum_to_word(index)) < x->vector.dim))) if (!(MKCL_FIXNUMP(index) && ((j = mkcl_fixnum_to_word(index)) < x->vector.dim)))
j = mkcl_fixnum_in_range(env, @'aref', "index", index, 0, (mkcl_word)x->vector.dim-1); j = mkcl_fixnum_in_range(env, @'aref', "index", index, 0, (mkcl_word)x->vector.dim-1);
}
break;
default:
x = mkcl_type_error(env, @'aref',"argument",x,@'array');
goto AGAIN;
} }
break; mkcl_va_end(indx);
default: mkcl_return_value(mkcl_aref_index(env, x, j));
x = mkcl_type_error(env, @'aref',"argument",x,@'array');
goto AGAIN;
} }
mkcl_va_end(indx); }
mkcl_return_value(mkcl_aref_index(env, x, j)); }
}
@)
mkcl_object mkcl_object
mkcl_aref(MKCL, mkcl_object x, mkcl_object index) mkcl_aref(MKCL, mkcl_object x, mkcl_object index)
...@@ -373,47 +382,51 @@ mkcl_vref(MKCL, mkcl_object v, mkcl_object index) ...@@ -373,47 +382,51 @@ mkcl_vref(MKCL, mkcl_object v, mkcl_object index)
(si:aset value array dim0 ... dimN) (si:aset value array dim0 ... dimN)
*/ */
@(defun si::aset (v x &rest dims) mkcl_object mk_si_aset(MKCL, const mkcl_narg narg, mkcl_object v, mkcl_object x, ...)
@ {
mkcl_call_stack_check(env);
{ {
mkcl_index i, j; mkcl_setup_for_rest(env, @'si::aset', 2, narg, x, dims);
mkcl_index r = narg - 2; {
AGAIN: mkcl_index i, j;
switch (mkcl_type_of(x)) { mkcl_index r = narg - 2;
case mkcl_t_array: AGAIN:
if (r != x->array.rank) switch (mkcl_type_of(x)) {
mkcl_FEerror(env, "Wrong number of indices.", 0); case mkcl_t_array:
for (i = j = 0; i < r; i++) { if (r != x->array.rank)
mkcl_object index = mkcl_va_arg(dims); mkcl_FEerror(env, "Wrong number of indices.", 0);
mkcl_index dim = x->array.dims[i]; for (i = j = 0; i < r; i++) {
mkcl_index s; mkcl_object index = mkcl_va_arg(dims);
mkcl_index dim = x->array.dims[i];
if (!(MKCL_FIXNUMP(index) && ((s = mkcl_fixnum_to_word(index)) < dim))) mkcl_index s;
s =mkcl_fixnum_in_range(env, @'si::aset', "index", index, 0, (mkcl_word)dim-1);
j = j*dim + s; if (!(MKCL_FIXNUMP(index) && ((s = mkcl_fixnum_to_word(index)) < dim)))
} s =mkcl_fixnum_in_range(env, @'si::aset', "index", index, 0, (mkcl_word)dim-1);
break; j = j*dim + s;
case mkcl_t_vector: }
case mkcl_t_string: break;
case mkcl_t_base_string: case mkcl_t_vector:
case mkcl_t_bitvector: case mkcl_t_string:
if (r != 1) case mkcl_t_base_string:
mkcl_FEerror(env, "Wrong number of indices.", 0); case mkcl_t_bitvector:
{ if (r != 1)
mkcl_object index = mkcl_va_arg(dims); mkcl_FEerror(env, "Wrong number of indices.", 0);
{
mkcl_object index = mkcl_va_arg(dims);
if (!(MKCL_FIXNUMP(index) && ((j = mkcl_fixnum_to_word(index)) < x->vector.dim))) if (!(MKCL_FIXNUMP(index) && ((j = mkcl_fixnum_to_word(index)) < x->vector.dim)))
j = mkcl_fixnum_in_range(env, @'si::aset',"index", index, 0, (mkcl_word)x->vector.dim - 1); j = mkcl_fixnum_in_range(env, @'si::aset',"index", index, 0, (mkcl_word)x->vector.dim - 1);
}
break;
default:
x = mkcl_type_error(env, @'si::aset',"destination",v,@'array');
goto AGAIN;
} }
break; mkcl_va_end(dims);
default: mkcl_return_value(mkcl_aset_index(env, x, j, v));
x = mkcl_type_error(env, @'si::aset',"destination",v,@'array');
goto AGAIN;
} }
mkcl_va_end(dims); }
mkcl_return_value(mkcl_aset_index(env, x, j, v)); }
}
@)
mkcl_index mkcl_ensure_index_for_array_row_major_index(MKCL, mkcl_index i, mkcl_index dim) mkcl_index mkcl_ensure_index_for_array_row_major_index(MKCL, mkcl_index i, mkcl_index dim)
{ {
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
Copyright (c) 1990, Giuseppe Attardi. Copyright (c) 1990, Giuseppe Attardi.
Copyright (c) 2001, Juan Jose Garcia Ripoll. Copyright (c) 2001, Juan Jose Garcia Ripoll.
Copyright (c) 2010-2016, Jean-Claude Beaudoin. Copyright (c) 2010-2016,2021 Jean-Claude Beaudoin.
MKCL is free software; you can redistribute it and/or MKCL is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public modify it under the terms of the GNU Lesser General Public
...@@ -486,75 +486,79 @@ mkcl_clone_cclosure(MKCL, mkcl_object c0, mkcl_object new_cenv) ...@@ -486,75 +486,79 @@ mkcl_clone_cclosure(MKCL, mkcl_object c0, mkcl_object new_cenv)
must be twin closures (ie: they were closed over the same environment). must be twin closures (ie: they were closed over the same environment).
Any other object will be passed through as is to the value list without any cloning. Any other object will be passed through as is to the value list without any cloning.
*/ */
@(defun si::clone-closure (&rest args) mkcl_object mk_si_clone_closure(MKCL, mkcl_narg narg, ...)
mkcl_object head = mk_cl_Cnil; {
@ mkcl_call_stack_check(env);
{ {
mkcl_object tail; mkcl_object head = mk_cl_Cnil;
mkcl_object c0; mkcl_setup_for_rest(env, @'si::clone-closure', 0, narg, narg, args);
mkcl_object c0_env = mk_cl_Cnil; {
mkcl_object clone; mkcl_object tail;
mkcl_object clone_env; mkcl_object c0;
mkcl_object (* cloner)(MKCL, mkcl_object c0, mkcl_object new_env); mkcl_object c0_env = mk_cl_Cnil;
mkcl_object clone;
while (narg && mkcl_Null(c0_env)) mkcl_object clone_env;
{ mkcl_object (* cloner)(MKCL, mkcl_object c0, mkcl_object new_env);
c0 = mkcl_va_arg(args);
switch(mkcl_type_of(c0)) while (narg && mkcl_Null(c0_env))
{ {
case mkcl_t_bclosure: c0 = mkcl_va_arg(args);
c0_env = c0->bclosure.lex; switch(mkcl_type_of(c0))
cloner = mkcl_clone_bclosure; {
clone = cloner(env, c0, mk_cl_Cnil); case mkcl_t_bclosure:
clone_env = clone->bclosure.lex; c0_env = c0->bclosure.lex;
break; cloner = mkcl_clone_bclosure;
case mkcl_t_cclosure: clone = cloner(env, c0, mk_cl_Cnil);
c0_env = c0->cclosure.cenv; clone_env = clone->bclosure.lex;
cloner = mkcl_clone_cclosure; break;
clone = cloner(env, c0, mk_cl_Cnil); case mkcl_t_cclosure:
clone_env = clone->cclosure.cenv; c0_env = c0->cclosure.cenv;
break; cloner = mkcl_clone_cclosure;
default: clone = cloner(env, c0, mk_cl_Cnil);
clone = c0; clone_env = clone->cclosure.cenv;
break; break;
} default:
if (mkcl_Null(head)) clone = c0;
{ break;
tail = head = mkcl_list1(env, clone); }
} if (mkcl_Null(head))
else {
{ tail = head = mkcl_list1(env, clone);
mkcl_object cons = mkcl_list1(env, clone); }
MKCL_RPLACD(tail, cons); else
tail = cons; {
} mkcl_object cons = mkcl_list1(env, clone);
narg--; MKCL_RPLACD(tail, cons);
} tail = cons;
}
narg--;
}
while (narg--) { while (narg--) {
mkcl_object c1 = mkcl_va_arg(args); mkcl_object c1 = mkcl_va_arg(args);
mkcl_object c1_env; mkcl_object c1_env;
switch(mkcl_type_of(c1)) switch(mkcl_type_of(c1))
{ {
case mkcl_t_bclosure: c1_env = c1->bclosure.lex; break; case mkcl_t_bclosure: c1_env = c1->bclosure.lex; break;
case mkcl_t_cclosure: c1_env = c1->cclosure.cenv; break; case mkcl_t_cclosure: c1_env = c1->cclosure.cenv; break;
default: c1_env = mk_cl_Cnil; break; default: c1_env = mk_cl_Cnil; break;
} }
if ( c0_env == c1_env ) /* Twin closures? */ if ( c0_env == c1_env ) /* Twin closures? */
clone = cloner(env, c1, clone_env); clone = cloner(env, c1, clone_env);
else else
clone = c1; clone = c1;
mkcl_object cons = mkcl_list1(env, clone); mkcl_object cons = mkcl_list1(env, clone);
MKCL_RPLACD(tail, cons); MKCL_RPLACD(tail, cons);
tail = cons; tail = cons;
}
} }
}
mkcl_va_end(args); mkcl_va_end(args);
mkcl_return_value(head); mkcl_return_value(head);
@) }
}
mkcl_object mkcl_object
mk_si_closure_siblings_p(MKCL, mkcl_object c1, mkcl_object c2) mk_si_closure_siblings_p(MKCL, mkcl_object c1, mkcl_object c2)
......
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
/* /*
Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
Copyright (c) 1990, Giuseppe Attardi. Copyright (c) 1990, Giuseppe Attardi.
Copyright (c) 2012-2019, Jean-Claude Beaudoin. Copyright (c) 2012-2019,2021 Jean-Claude Beaudoin.
MKCL is free software; you can redistribute it and/or MKCL is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public modify it under the terms of the GNU Lesser General Public
...@@ -156,15 +156,20 @@ mk_cl_alphanumericp(MKCL, mkcl_object c) ...@@ -156,15 +156,20 @@ mk_cl_alphanumericp(MKCL, mkcl_object c)
mkcl_return_value((mkcl_alphanumericp(i) ? mk_cl_Ct : mk_cl_Cnil)); mkcl_return_value((mkcl_alphanumericp(i) ? mk_cl_Ct : mk_cl_Cnil));
} }
@(defun char= (c &rest cs) mkcl_object mk_cl_charE(MKCL, mkcl_narg narg, mkcl_object c, ...)
@ {
/* INV: mkcl_char_eq() checks types of `c' and `cs' */ mkcl_call_stack_check(env);
while (--narg) {
if (!mkcl_char_eq(env, c, mkcl_va_arg(cs))) mkcl_setup_for_rest(env, @'char=', 1, narg, c, cs);
{ mkcl_va_end(cs); mkcl_return_value(mk_cl_Cnil); }
mkcl_va_end(cs); /* INV: mkcl_char_eq() checks types of `c' and `cs' */
mkcl_return_value(mk_cl_Ct); while (--narg)
@) if (!mkcl_char_eq(env, c, mkcl_va_arg(cs)))
{ mkcl_va_end(cs); mkcl_return_value(mk_cl_Cnil); }
mkcl_va_end(cs);
mkcl_return_value(mk_cl_Ct);
}
}
bool bool
mkcl_char_eq(MKCL, mkcl_object x, mkcl_object y) mkcl_char_eq(MKCL, mkcl_object x, mkcl_object y)
...@@ -172,26 +177,32 @@ mkcl_char_eq(MKCL, mkcl_object x, mkcl_object y) ...@@ -172,26 +177,32 @@ mkcl_char_eq(MKCL, mkcl_object x, mkcl_object y)
return mkcl_char_code(env, x) == mkcl_char_code(env, y); return mkcl_char_code(env, x) == mkcl_char_code(env, y);
} }
@(defun char/= (&rest cs) mkcl_object mk_cl_charNE(MKCL, const mkcl_narg narg, ...)
int i, j; {
mkcl_object c; int i, j;
@ mkcl_object c;
/* INV: mkcl_char_eq() checks types of its arguments */
if (narg == 0) mkcl_call_stack_check(env);
mkcl_FEwrong_num_arguments(env, @'char/=', 1, -1, 0); {
c = mkcl_va_arg(cs); mkcl_setup_for_rest(env, @'char=', 0, narg, narg, cs);
for (i = 2; i<=narg; i++) {
mkcl_va_list ds; /* INV: mkcl_char_eq() checks types of its arguments */
mkcl_va_start(env, ds, narg, narg, 0); if (narg == 0)
mkcl_FEwrong_num_arguments(env, @'char/=', 1, -1, 0);
c = mkcl_va_arg(cs); c = mkcl_va_arg(cs);
for (j = 1; j<i; j++) for (i = 2; i<=narg; i++) {
if (mkcl_char_eq(env, mkcl_va_arg(ds), c)) mkcl_va_list ds;
{ mkcl_va_end(cs); mkcl_va_end(ds); mkcl_return_value(mk_cl_Cnil); } mkcl_va_start(env, ds, narg, narg, 0);
mkcl_va_end(ds); c = mkcl_va_arg(cs);
for (j = 1; j<i; j++)
if (mkcl_char_eq(env, mkcl_va_arg(ds), c))
{ mkcl_va_end(cs); mkcl_va_end(ds); mkcl_return_value(mk_cl_Cnil); }
mkcl_va_end(ds);
}
mkcl_va_end(cs);
mkcl_return_value(mk_cl_Ct);
} }
mkcl_va_end(cs); }
mkcl_return_value(mk_cl_Ct);
@)
static mkcl_object static mkcl_object
Lchar_cmp(MKCL, mkcl_narg narg, int s, int t, mkcl_va_list args) Lchar_cmp(MKCL, mkcl_narg narg, int s, int t, mkcl_va_list args)
...@@ -218,45 +229,70 @@ mkcl_char_cmp(MKCL, mkcl_object x, mkcl_object y) ...@@ -218,45 +229,70 @@ mkcl_char_cmp(MKCL, mkcl_object x, mkcl_object y)
return mkcl_char_code(env, x) - mkcl_char_code(env, y); return mkcl_char_code(env, x) - mkcl_char_code(env, y);
} }
@(defun char< (&rest args) mkcl_object mk_cl_charL(MKCL, const mkcl_narg narg, ...)
@ {
mkcl_object val = Lchar_cmp(env, narg, 1, 1, args); mkcl_call_stack_check(env);
mkcl_va_end(args); {
return val; mkcl_setup_for_rest(env, @'char<', 0, narg, narg, args);
@)
@(defun char> (&rest args) mkcl_object val = Lchar_cmp(env, narg, 1, 1, args);
@ mkcl_va_end(args);
mkcl_object val = Lchar_cmp(env, narg,-1, 1, args); return val;
mkcl_va_end(args); }
return val; }
@)
@(defun char<= (&rest args) mkcl_object mk_cl_charG(MKCL, const mkcl_narg narg, ...)
@ {
mkcl_object val = Lchar_cmp(env, narg, 1, 0, args); mkcl_call_stack_check(env);
mkcl_va_end(args); {
return val; mkcl_setup_for_rest(env, @'char>', 0, narg, narg, args);
@)
@(defun char>= (&rest args) mkcl_object val = Lchar_cmp(env, narg, -1, 1, args);
@ mkcl_va_end(args);
mkcl_object val = Lchar_cmp(env, narg,-1, 0, args); return val;
mkcl_va_end(args); }
return val; }
@)
@(defun char_equal (c &rest cs) mkcl_object mk_cl_charLE(MKCL, const mkcl_narg narg, ...)
int i; {
@ mkcl_call_stack_check(env);
/* INV: mkcl_char_equal() checks the type of its arguments */ {
for (narg--, i = 0; i < narg; i++) { mkcl_setup_for_rest(env, @'char<=', 0, narg, narg, args);
if (!mkcl_char_equal(env, c, mkcl_va_arg(cs)))
{ mkcl_va_end(cs); mkcl_return_value(mk_cl_Cnil); } mkcl_object val = Lchar_cmp(env, narg, 1, 0, args);
mkcl_va_end(args);
return val;
} }
mkcl_va_end(cs); }
mkcl_return_value(mk_cl_Ct);