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 @@
Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
Copyright (c) 1990, Giuseppe Attardi.
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
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)
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_index r = narg - 1;
AGAIN:
switch (mkcl_type_of(x)) {
case mkcl_t_array:
if (r != x->array.rank)
mkcl_FEerror(env, "Wrong number of indices.", 0);
for (i = j = 0; i < r; i++) {
mkcl_object index = mkcl_va_arg(indx);
mkcl_index dim = x->array.dims[i];
mkcl_index 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);
j = j*dim + s;
}
break;
case mkcl_t_vector:
case mkcl_t_string:
case mkcl_t_base_string:
case mkcl_t_bitvector:
if (r != 1)
mkcl_FEerror(env, "Wrong number of indices.", 0);
{
mkcl_object index = mkcl_va_arg(indx);
mkcl_setup_for_rest(env, @'array-row-major-index', 1, narg, x, indx);
{
mkcl_index i, j;
mkcl_index r = narg - 1;
AGAIN:
switch (mkcl_type_of(x)) {
case mkcl_t_array:
if (r != x->array.rank)
mkcl_FEerror(env, "Wrong number of indices.", 0);
for (i = j = 0; i < r; i++) {
mkcl_object index = mkcl_va_arg(indx);
mkcl_index dim = x->array.dims[i];
mkcl_index 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);
j = j*dim + s;
}
break;
case mkcl_t_vector:
case mkcl_t_string:
case mkcl_t_base_string:
case mkcl_t_bitvector:
if (r != 1)
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)))
j = mkcl_fixnum_in_range(env, @'array-row-major-index', "index", index, 0, (mkcl_word)x->vector.dim-1);
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);
}
break;
default:
x = mkcl_type_error(env, @'aref',"argument",x,@'array');
goto AGAIN;
}
break;
default:
x = mkcl_type_error(env, @'aref',"argument",x,@'array');
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_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)
{
......@@ -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_index r = narg - 1;
AGAIN:
switch (mkcl_type_of(x)) {
case mkcl_t_array:
if (r != x->array.rank)
mkcl_FEerror(env, "Wrong number of indices.", 0);
for (i = j = 0; i < r; i++) {
mkcl_object index = mkcl_va_arg(indx);
mkcl_index dim = x->array.dims[i];
mkcl_index 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);
j = j*dim + s;
}
break;
case mkcl_t_vector:
case mkcl_t_string:
case mkcl_t_base_string:
case mkcl_t_bitvector:
if (r != 1)
mkcl_FEerror(env, "Wrong number of indices.", 0);
{
mkcl_object index = mkcl_va_arg(indx);
mkcl_setup_for_rest(env, @'aref', 1, narg, x, indx);
{
mkcl_index i, j;
mkcl_index r = narg - 1;
AGAIN:
switch (mkcl_type_of(x)) {
case mkcl_t_array:
if (r != x->array.rank)
mkcl_FEerror(env, "Wrong number of indices.", 0);
for (i = j = 0; i < r; i++) {
mkcl_object index = mkcl_va_arg(indx);
mkcl_index dim = x->array.dims[i];
mkcl_index 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);
j = j*dim + s;
}
break;
case mkcl_t_vector:
case mkcl_t_string:
case mkcl_t_base_string:
case mkcl_t_bitvector:
if (r != 1)
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)))
j = mkcl_fixnum_in_range(env, @'aref', "index", index, 0, (mkcl_word)x->vector.dim-1);
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);
}
break;
default:
x = mkcl_type_error(env, @'aref',"argument",x,@'array');
goto AGAIN;
}
break;
default:
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_va_end(indx);
mkcl_return_value(mkcl_aref_index(env, x, j));
}
@)
}
}
mkcl_object
mkcl_aref(MKCL, mkcl_object x, mkcl_object index)
......@@ -373,47 +382,51 @@ mkcl_vref(MKCL, mkcl_object v, mkcl_object index)
(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_index r = narg - 2;
AGAIN:
switch (mkcl_type_of(x)) {
case mkcl_t_array:
if (r != x->array.rank)
mkcl_FEerror(env, "Wrong number of indices.", 0);
for (i = j = 0; i < r; i++) {
mkcl_object index = mkcl_va_arg(dims);
mkcl_index dim = x->array.dims[i];
mkcl_index 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);
j = j*dim + s;
}
break;
case mkcl_t_vector:
case mkcl_t_string:
case mkcl_t_base_string:
case mkcl_t_bitvector:
if (r != 1)
mkcl_FEerror(env, "Wrong number of indices.", 0);
{
mkcl_object index = mkcl_va_arg(dims);
mkcl_setup_for_rest(env, @'si::aset', 2, narg, x, dims);
{
mkcl_index i, j;
mkcl_index r = narg - 2;
AGAIN:
switch (mkcl_type_of(x)) {
case mkcl_t_array:
if (r != x->array.rank)
mkcl_FEerror(env, "Wrong number of indices.", 0);
for (i = j = 0; i < r; i++) {
mkcl_object index = mkcl_va_arg(dims);
mkcl_index dim = x->array.dims[i];
mkcl_index 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);
j = j*dim + s;
}
break;
case mkcl_t_vector:
case mkcl_t_string:
case mkcl_t_base_string:
case mkcl_t_bitvector:
if (r != 1)
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)))
j = mkcl_fixnum_in_range(env, @'si::aset',"index", index, 0, (mkcl_word)x->vector.dim - 1);
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);
}
break;
default:
x = mkcl_type_error(env, @'si::aset',"destination",v,@'array');
goto AGAIN;
}
break;
default:
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_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)
{
......
......@@ -6,7 +6,7 @@
Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
Copyright (c) 1990, Giuseppe Attardi.
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
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)
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.
*/
@(defun si::clone-closure (&rest args)
mkcl_object head = mk_cl_Cnil;
@
mkcl_object mk_si_clone_closure(MKCL, mkcl_narg narg, ...)
{
mkcl_call_stack_check(env);
{
mkcl_object tail;
mkcl_object c0;
mkcl_object c0_env = mk_cl_Cnil;
mkcl_object clone;
mkcl_object clone_env;
mkcl_object (* cloner)(MKCL, mkcl_object c0, mkcl_object new_env);
while (narg && mkcl_Null(c0_env))
{
c0 = mkcl_va_arg(args);
switch(mkcl_type_of(c0))
{
case mkcl_t_bclosure:
c0_env = c0->bclosure.lex;
cloner = mkcl_clone_bclosure;
clone = cloner(env, c0, mk_cl_Cnil);
clone_env = clone->bclosure.lex;
break;
case mkcl_t_cclosure:
c0_env = c0->cclosure.cenv;
cloner = mkcl_clone_cclosure;
clone = cloner(env, c0, mk_cl_Cnil);
clone_env = clone->cclosure.cenv;
break;
default:
clone = c0;
break;
}
if (mkcl_Null(head))
{
tail = head = mkcl_list1(env, clone);
}
else
{
mkcl_object cons = mkcl_list1(env, clone);
MKCL_RPLACD(tail, cons);
tail = cons;
}
narg--;
}
mkcl_object head = mk_cl_Cnil;
mkcl_setup_for_rest(env, @'si::clone-closure', 0, narg, narg, args);
{
mkcl_object tail;
mkcl_object c0;
mkcl_object c0_env = mk_cl_Cnil;
mkcl_object clone;
mkcl_object clone_env;
mkcl_object (* cloner)(MKCL, mkcl_object c0, mkcl_object new_env);
while (narg && mkcl_Null(c0_env))
{
c0 = mkcl_va_arg(args);
switch(mkcl_type_of(c0))
{
case mkcl_t_bclosure:
c0_env = c0->bclosure.lex;
cloner = mkcl_clone_bclosure;
clone = cloner(env, c0, mk_cl_Cnil);
clone_env = clone->bclosure.lex;
break;
case mkcl_t_cclosure:
c0_env = c0->cclosure.cenv;
cloner = mkcl_clone_cclosure;
clone = cloner(env, c0, mk_cl_Cnil);
clone_env = clone->cclosure.cenv;
break;
default:
clone = c0;
break;
}
if (mkcl_Null(head))
{
tail = head = mkcl_list1(env, clone);
}
else
{
mkcl_object cons = mkcl_list1(env, clone);
MKCL_RPLACD(tail, cons);
tail = cons;
}
narg--;
}
while (narg--) {
mkcl_object c1 = mkcl_va_arg(args);
mkcl_object c1_env;
switch(mkcl_type_of(c1))
{
case mkcl_t_bclosure: c1_env = c1->bclosure.lex; break;
case mkcl_t_cclosure: c1_env = c1->cclosure.cenv; break;
default: c1_env = mk_cl_Cnil; break;
}
while (narg--) {
mkcl_object c1 = mkcl_va_arg(args);
mkcl_object c1_env;
switch(mkcl_type_of(c1))
{
case mkcl_t_bclosure: c1_env = c1->bclosure.lex; break;
case mkcl_t_cclosure: c1_env = c1->cclosure.cenv; break;
default: c1_env = mk_cl_Cnil; break;
}
if ( c0_env == c1_env ) /* Twin closures? */
clone = cloner(env, c1, clone_env);
else
clone = c1;
mkcl_object cons = mkcl_list1(env, clone);
MKCL_RPLACD(tail, cons);
tail = cons;
if ( c0_env == c1_env ) /* Twin closures? */
clone = cloner(env, c1, clone_env);
else
clone = c1;
mkcl_object cons = mkcl_list1(env, clone);
MKCL_RPLACD(tail, cons);
tail = cons;
}
}
}
mkcl_va_end(args);
mkcl_return_value(head);
@)
mkcl_return_value(head);
}
}
mkcl_object
mk_si_closure_siblings_p(MKCL, mkcl_object c1, mkcl_object c2)
......
......@@ -5,7 +5,7 @@
/*
Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
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
modify it under the terms of the GNU Lesser General Public
......@@ -156,15 +156,20 @@ mk_cl_alphanumericp(MKCL, mkcl_object c)
mkcl_return_value((mkcl_alphanumericp(i) ? mk_cl_Ct : mk_cl_Cnil));
}
@(defun char= (c &rest cs)
@
/* INV: mkcl_char_eq() checks types of `c' and `cs' */
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);
@)
mkcl_object mk_cl_charE(MKCL, mkcl_narg narg, mkcl_object c, ...)
{
mkcl_call_stack_check(env);
{
mkcl_setup_for_rest(env, @'char=', 1, narg, c, cs);
/* INV: mkcl_char_eq() checks types of `c' and `cs' */
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
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);
}
@(defun char/= (&rest cs)
int i, j;
mkcl_object c;
@
/* INV: mkcl_char_eq() checks types of its arguments */
if (narg == 0)
mkcl_FEwrong_num_arguments(env, @'char/=', 1, -1, 0);
c = mkcl_va_arg(cs);
for (i = 2; i<=narg; i++) {
mkcl_va_list ds;
mkcl_va_start(env, ds, narg, narg, 0);
mkcl_object mk_cl_charNE(MKCL, const mkcl_narg narg, ...)
{
int i, j;
mkcl_object c;
mkcl_call_stack_check(env);
{
mkcl_setup_for_rest(env, @'char=', 0, narg, narg, cs);
/* INV: mkcl_char_eq() checks types of its arguments */
if (narg == 0)
mkcl_FEwrong_num_arguments(env, @'char/=', 1, -1, 0);
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);
for (i = 2; i<=narg; i++) {
mkcl_va_list ds;
mkcl_va_start(env, ds, narg, narg, 0);
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
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)
return mkcl_char_code(env, x) - mkcl_char_code(env, y);
}
@(defun char< (&rest args)
@
mkcl_object val = Lchar_cmp(env, narg, 1, 1, args);
mkcl_va_end(args);
return val;
@)
mkcl_object mk_cl_charL(MKCL, const mkcl_narg narg, ...)
{
mkcl_call_stack_check(env);
{
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);
return val;
@)
mkcl_object val = Lchar_cmp(env, narg, 1, 1, args);
mkcl_va_end(args);
return val;
}
}
@(defun char<= (&rest args)
@
mkcl_object val = Lchar_cmp(env, narg, 1, 0, args);
mkcl_va_end(args);
return val;
@)
mkcl_object mk_cl_charG(MKCL, const mkcl_narg narg, ...)
{
mkcl_call_stack_check(env);
{
mkcl_setup_for_rest(env, @'char>', 0, narg, narg, args);
@(defun char>= (&rest args)
@
mkcl_object val = Lchar_cmp(env, narg,-1, 0, args);
mkcl_va_end(args);
return val;
@)
mkcl_object val = Lchar_cmp(env, narg, -1, 1, args);
mkcl_va_end(args);
return val;
}
}
@(defun char_equal (c &rest cs)
int i;
@
/* INV: mkcl_char_equal() checks the type of its arguments */
for (narg--, i = 0; i < narg; i++) {
if (!mkcl_char_equal(env, c, mkcl_va_arg(cs)))
{ mkcl_va_end(cs); mkcl_return_value(mk_cl_Cnil); }
mkcl_object mk_cl_charLE(MKCL, const mkcl_narg narg, ...)
{
mkcl_call_stack_check(env);
{
mkcl_setup_for_rest(env, @'char<=', 0, narg, narg, args);
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);
@)
}
mkcl_object mk_cl_charGE(MKCL, const mkcl_narg narg, ...)
{
mkcl_call_stack_check(env);
{
mkcl_setup_for_rest(env, @'char>=', 0, narg, narg, args);
mkcl_object val = Lchar_cmp(env, narg, -1, 0, args);
mkcl_va_end(args);
return val;
}
}
mkcl_object mk_cl_char_equal(MKCL, mkcl_narg narg, mkcl_object c, ...)
{
mkcl_narg i;
mkcl_call_stack_check(env);
{
mkcl_setup_for_rest(env, @'char-equal', 1, narg, c, cs);
/* INV: mkcl_char_equal() checks the type of its arguments */