Commit 82eb3001 authored by Jean-Claude Beaudoin's avatar Jean-Claude Beaudoin
Browse files

Get rid of "@(defun ...) forms and replace them with explicit C code. Major...

Get rid of "@(defun ...) forms and replace them with explicit C code. Major step toward retirement of dpp.
parent 38d7fe2f
...@@ -4,7 +4,7 @@ ...@@ -4,7 +4,7 @@
*/ */
/* /*
Copyright (c) 2001, Juan Jose Garcia Ripoll. Copyright (c) 2001, Juan Jose Garcia Ripoll.
Copyright (c) 2011-2016, Jean-Claude Beaudoin. Copyright (c) 2011-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
...@@ -1530,13 +1530,18 @@ mkcl_object mk_si_scrub_values(MKCL) ...@@ -1530,13 +1530,18 @@ mkcl_object mk_si_scrub_values(MKCL)
mkcl_return_no_value; mkcl_return_no_value;
} }
@(defun si::gc (&optional area) mkcl_object mk_si_gc(MKCL, mkcl_narg narg, ...)
@ {
mk_si_trim_dynamic_cons_stack(env); mkcl_call_stack_check(env);
mk_si_scrub_values(env); {
MKCL_GC_NO_INTR(env, MK_GC_gcollect()); mkcl_object area = mk_cl_Cnil;
mkcl_return_no_value; MKCL_RECEIVE_1_OPTIONAL_ARGUMENT(env, @'si::gc', narg, 0, narg, &area);
@) mk_si_trim_dynamic_cons_stack(env);
mk_si_scrub_values(env);
MKCL_GC_NO_INTR(env, MK_GC_gcollect());
mkcl_return_no_value;
}
}
mkcl_object mkcl_object
mk_si_gc_dump(MKCL) mk_si_gc_dump(MKCL)
......
...@@ -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-2017, Jean-Claude Beaudoin. Copyright (c) 2010-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
...@@ -50,46 +50,53 @@ mk_cl_set(MKCL, mkcl_object var, mkcl_object val) ...@@ -50,46 +50,53 @@ mk_cl_set(MKCL, mkcl_object var, mkcl_object val)
mkcl_return1(val); mkcl_return1(val);
} }
@(defun si::fset (fname def &optional macro pprint) mkcl_object mk_si_fset(MKCL, mkcl_narg narg, mkcl_object fname, mkcl_object def, ...)
mkcl_object sym = mk_si_function_block_name(env, fname); {
mkcl_object pack; mkcl_call_stack_check(env);
bool mflag; {
int type; mkcl_object sym = mk_si_function_block_name(env, fname);
@ mkcl_object pack;
if (mkcl_Null(sym)) sym = mk_cl_Cnil_symbol; bool mflag;
if (mkcl_Null(mk_cl_functionp(env, def))) mkcl_FEinvalid_function(env, def); int type;
pack = mkcl_symbol_package(env, sym); mkcl_object macro = mk_cl_Cnil;
if (pack != mk_cl_Cnil && pack->pack.closed) { mkcl_object pprint = mk_cl_Cnil;
mkcl_CEpackage_error(env, pack, MKCL_RECEIVE_2_OPTIONAL_ARGUMENTS(env, @'si::fset', narg, 2, def, &macro, &pprint);
"Attempt to redefine function ~S in closed package ~S.",
"Ignore closing and proceed", 2, fname, pack); if (mkcl_Null(sym)) sym = mk_cl_Cnil_symbol;
} if (mkcl_Null(mk_cl_functionp(env, def))) mkcl_FEinvalid_function(env, def);
mflag = !mkcl_Null(macro); pack = mkcl_symbol_package(env, sym);
type = mkcl_symbol_type(env, sym); if (pack != mk_cl_Cnil && pack->pack.closed) {
if ((type & mkcl_stp_special_form) && !mflag) { mkcl_CEpackage_error(env, pack,
mkcl_FEerror(env, "Given that ~S is a special form, ~S cannot be defined as a function.", "Attempt to redefine function ~S in closed package ~S.",
2, sym, fname); "Ignore closing and proceed", 2, fname, pack);
} }
if (MKCL_SYMBOLP(fname)) { mflag = !mkcl_Null(macro);
if (mflag) { type = mkcl_symbol_type(env, sym);
type |= mkcl_stp_macro; if ((type & mkcl_stp_special_form) && !mflag) {
mkcl_FEerror(env, "Given that ~S is a special form, ~S cannot be defined as a function.",
2, sym, fname);
}
if (MKCL_SYMBOLP(fname)) {
if (mflag) {
type |= mkcl_stp_macro;
} else {
type &= ~mkcl_stp_macro;
}
mkcl_symbol_type_set(env, sym, type);
MKCL_SYM_FUN(sym) = def;
if (!MKCL_INSTANCEP(def) && mkcl_Null(mk_si_compiled_function_name(env, def)))
mk_si_set_compiled_function_name(env, def, sym);
} else { } else {
type &= ~mkcl_stp_macro; if (mflag)
mkcl_FEerror(env, "~S is not a valid name for a macro.", 1, fname);
mk_si_put_sysprop(env, sym, @'si::setf-symbol', def);
mk_si_rem_sysprop(env, sym, @'si::setf-lambda');
mk_si_rem_sysprop(env, sym, @'si::setf-method');
mk_si_rem_sysprop(env, sym, @'si::setf-update');
} }
mkcl_symbol_type_set(env, sym, type); mkcl_return_value(def);
MKCL_SYM_FUN(sym) = def;
if (!MKCL_INSTANCEP(def) && mkcl_Null(mk_si_compiled_function_name(env, def)))
mk_si_set_compiled_function_name(env, def, sym);
} else {
if (mflag)
mkcl_FEerror(env, "~S is not a valid name for a macro.", 1, fname);
mk_si_put_sysprop(env, sym, @'si::setf-symbol', def);
mk_si_rem_sysprop(env, sym, @'si::setf-lambda');
mk_si_rem_sysprop(env, sym, @'si::setf-method');
mk_si_rem_sysprop(env, sym, @'si::setf-update');
} }
mkcl_return_value(def); }
@)
mkcl_object mkcl_object
mk_cl_makunbound(MKCL, mkcl_object sym) mk_cl_makunbound(MKCL, mkcl_object sym)
......
...@@ -116,14 +116,19 @@ mkcl_string_case(const mkcl_object str) ...@@ -116,14 +116,19 @@ mkcl_string_case(const mkcl_object str)
else return str_case; else return str_case;
} }
@(defun digit_char_p (c &optional (radix MKCL_MAKE_FIXNUM(10))) mkcl_object mk_cl_digit_char_p(MKCL, mkcl_narg narg, mkcl_object c, ...)
@ {
mkcl_call_stack_check(env);
{ {
mkcl_word basis = mkcl_fixnum_in_range(env, @'digit-char-p',"radix", radix, 2, 36); mkcl_object radix = MKCL_MAKE_FIXNUM(10);
mkcl_word value = mkcl_digitp(mkcl_char_code(env, c), basis); MKCL_RECEIVE_1_OPTIONAL_ARGUMENT(env, @'digit-char-p', narg, 1, c, &radix);
mkcl_return_value(((value < 0)? mk_cl_Cnil: MKCL_MAKE_FIXNUM(value))); {
} mkcl_word basis = mkcl_fixnum_in_range(env, @'digit-char-p',"radix", radix, 2, 36);
@) mkcl_word value = mkcl_digitp(mkcl_char_code(env, c), basis);
mkcl_return_value(((value < 0)? mk_cl_Cnil: MKCL_MAKE_FIXNUM(value)));
}
}
}
/* /*
Mkcl_Digitp(i, r) returns the weight of code i Mkcl_Digitp(i, r) returns the weight of code i
...@@ -494,30 +499,38 @@ mk_cl_char_downcase(MKCL, mkcl_object c) ...@@ -494,30 +499,38 @@ mk_cl_char_downcase(MKCL, mkcl_object c)
mkcl_return_value(MKCL_CODE_CHAR(mkcl_char_downcase(code))); mkcl_return_value(MKCL_CODE_CHAR(mkcl_char_downcase(code)));
} }
@(defun digit_char (weight &optional (radix MKCL_MAKE_FIXNUM(10))) mkcl_object mk_cl_digit_char(MKCL, mkcl_narg narg, mkcl_object weight, ...)
@ { {
mkcl_word basis = mkcl_fixnum_in_range(env, @'digit-char',"radix",radix,2,36); mkcl_call_stack_check(env);
mkcl_object output = mk_cl_Cnil; {
AGAIN: mkcl_object radix = MKCL_MAKE_FIXNUM(10);
switch (mkcl_type_of(weight)) { MKCL_RECEIVE_1_OPTIONAL_ARGUMENT(env, @'digit-char', narg, 1, weight, &radix);
case mkcl_t_fixnum: {
mkcl_word value = mkcl_fixnum_to_word(weight); {
if (value >= 0) { mkcl_word basis = mkcl_fixnum_in_range(env, @'digit-char',"radix",radix,2,36);
int dw = mkcl_digit_char(value, basis); mkcl_object output = mk_cl_Cnil;
if (dw >= 0) { AGAIN:
output = MKCL_CODE_CHAR(dw); switch (mkcl_type_of(weight)) {
} case mkcl_t_fixnum: {
mkcl_word value = mkcl_fixnum_to_word(weight);
if (value >= 0) {
int dw = mkcl_digit_char(value, basis);
if (dw >= 0) {
output = MKCL_CODE_CHAR(dw);
}
}
break;
} }
break; case mkcl_t_bignum:
} break;
case mkcl_t_bignum: default:
break; weight = mkcl_type_error(env, @'digit-char',"weight",weight,@'integer');
default: goto AGAIN;
weight = mkcl_type_error(env, @'digit-char',"weight",weight,@'integer'); }
goto AGAIN; mkcl_return_value(output);
} }
mkcl_return_value(output); }
} @) }
short short
mkcl_digit_char(mkcl_word w, mkcl_word r) mkcl_digit_char(mkcl_word w, mkcl_word r)
......
...@@ -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
...@@ -166,7 +166,7 @@ mkcl_grab_rest_args(MKCL, mkcl_va_list args, bool dynamic) ...@@ -166,7 +166,7 @@ mkcl_grab_rest_args(MKCL, mkcl_va_list args, bool dynamic)
return rest; return rest;
} }
void void /* old, swiss knife version. JCB */
mkcl_parse_key(MKCL, mkcl_parse_key(MKCL,
mkcl_va_list args, /* actual args */ mkcl_va_list args, /* actual args */
const mkcl_word nkey, /* number of keywords */ const mkcl_word nkey, /* number of keywords */
...@@ -222,6 +222,248 @@ mkcl_parse_key(MKCL, ...@@ -222,6 +222,248 @@ mkcl_parse_key(MKCL,
mkcl_FEprogram_error(env, "Unknown keyword ~S", 1, unknown_keyword); mkcl_FEprogram_error(env, "Unknown keyword ~S", 1, unknown_keyword);
} }
/* new, targeted version. JCB */
void mkcl_receive_1_keyword_argument(MKCL, const mkcl_object fname, mkcl_va_list ARGS, const mkcl_object key_arg_symbol, mkcl_object * const key_var_ref)
{
bool key_arg_seen = false;
bool extra_would_be_keyword_seen = false;
mkcl_object extra_would_be_keyword = mk_cl_Cnil;
bool allow_other_keys_argument_seen = false;
mkcl_object allow_other_keys_argument_value = mk_cl_Cnil;
if (ARGS[0].narg % 2) mkcl_FEprogram_error(env, "Function ~S received an odd number of arguments for &key", 1, fname);
do {
const mkcl_object keyword = mkcl_va_arg(ARGS);
const mkcl_object value = mkcl_va_arg(ARGS);
if (keyword == key_arg_symbol)
{
if (!key_arg_seen)
{ *key_var_ref = value; key_arg_seen = true; }
}
else if (keyword == @':allow-other-keys')
{
if (!allow_other_keys_argument_seen)
{ allow_other_keys_argument_value = value; allow_other_keys_argument_seen = true; }
}
else if (!extra_would_be_keyword_seen)
{ extra_would_be_keyword = keyword; extra_would_be_keyword_seen = true; }
} while (ARGS[0].narg > 0);
if (extra_would_be_keyword_seen)
if (!allow_other_keys_argument_seen || (allow_other_keys_argument_value == mk_cl_Cnil))
mkcl_FEprogram_error(env, "In LAMBDA-LIST &KEY part of ~S: expected ~S, instead got ~S.", 3, fname, key_arg_symbol, extra_would_be_keyword);
}
void mkcl_receive_0_keyword_arguments(MKCL, const mkcl_object fname, mkcl_va_list ARGS)
{
bool extra_would_be_keyword_seen = false;
mkcl_object extra_would_be_keyword = mk_cl_Cnil;
bool allow_other_keys_argument_seen = false;
mkcl_object allow_other_keys_argument_value = mk_cl_Cnil;
if (ARGS[0].narg % 2) mkcl_FEprogram_error(env, "Function ~S received an odd number of arguments for &key", 1, fname);
do {
const mkcl_object keyword = mkcl_va_arg(ARGS);
const mkcl_object value = mkcl_va_arg(ARGS);
if (keyword == @':allow-other-keys')
{
if (!allow_other_keys_argument_seen)
{ allow_other_keys_argument_value = value; allow_other_keys_argument_seen = true; }
}
else if (!extra_would_be_keyword_seen)
{ extra_would_be_keyword = keyword; extra_would_be_keyword_seen = true; }
} while (ARGS[0].narg > 0);
if (extra_would_be_keyword_seen)
if (!allow_other_keys_argument_seen || (allow_other_keys_argument_value == mk_cl_Cnil))
mkcl_FEprogram_error(env, "In LAMBDA-LIST &KEY part of ~S: expected no keyword, instead got ~S.", 2, fname, extra_would_be_keyword);
}
void mkcl_receive_2_keyword_arguments(MKCL, const mkcl_object fname, mkcl_va_list ARGS, const mkcl_object key1_arg_symbol, mkcl_object * const key1_var_ref, const mkcl_object key2_arg_symbol, mkcl_object * const key2_var_ref)
{
bool key1_arg_seen = false;
bool key2_arg_seen = false;
bool extra_would_be_keyword_seen = false;
mkcl_object extra_would_be_keyword = mk_cl_Cnil;
bool allow_other_keys_argument_seen = false;
mkcl_object allow_other_keys_argument_value = mk_cl_Cnil;
if (ARGS[0].narg % 2) mkcl_FEprogram_error(env, "Function ~S received an odd number of arguments for &key", 1, fname);
do {
const mkcl_object keyword = mkcl_va_arg(ARGS);
const mkcl_object value = mkcl_va_arg(ARGS);
if (keyword == key1_arg_symbol)
{
if (!key1_arg_seen)
{ *key1_var_ref = value; key1_arg_seen = true; }
}
else if (keyword == key2_arg_symbol)
{
if (!key2_arg_seen)
{ *key2_var_ref = value; key2_arg_seen = true; }
}
else if (keyword == @':allow-other-keys')
{
if (!allow_other_keys_argument_seen)
{ allow_other_keys_argument_value = value; allow_other_keys_argument_seen = true; }
}
else if (!extra_would_be_keyword_seen)
{ extra_would_be_keyword = keyword; extra_would_be_keyword_seen = true; }
} while (ARGS[0].narg > 0);
if (extra_would_be_keyword_seen)
if (!allow_other_keys_argument_seen || (allow_other_keys_argument_value == mk_cl_Cnil))
mkcl_FEprogram_error(env, "In LAMBDA-LIST &KEY part of ~S: expected ~S or ~S, instead got ~S.", 4, fname, key1_arg_symbol, key2_arg_symbol, extra_would_be_keyword);
}
void mkcl_receive_3_keyword_arguments(MKCL, const mkcl_object fname, mkcl_va_list ARGS, const mkcl_object key1_arg_symbol, mkcl_object * const key1_var_ref, const mkcl_object key2_arg_symbol, mkcl_object * const key2_var_ref, const mkcl_object key3_arg_symbol, mkcl_object * const key3_var_ref)
{
bool key1_arg_seen = false;
bool key2_arg_seen = false;
bool key3_arg_seen = false;
bool extra_would_be_keyword_seen = false;
mkcl_object extra_would_be_keyword = mk_cl_Cnil;
bool allow_other_keys_argument_seen = false;
mkcl_object allow_other_keys_argument_value = mk_cl_Cnil;
if (ARGS[0].narg % 2) mkcl_FEprogram_error(env, "Function ~S received an odd number of arguments for &key", 1, fname);
do {
const mkcl_object keyword = mkcl_va_arg(ARGS);
const mkcl_object value = mkcl_va_arg(ARGS);
if (keyword == key1_arg_symbol)
{
if (!key1_arg_seen)
{ *key1_var_ref = value; key1_arg_seen = true; }
}
else if (keyword == key2_arg_symbol)
{
if (!key2_arg_seen)
{ *key2_var_ref = value; key2_arg_seen = true; }
}
else if (keyword == key3_arg_symbol)
{
if (!key3_arg_seen)
{ *key3_var_ref = value; key3_arg_seen = true; }
}
else if (keyword == @':allow-other-keys')
{
if (!allow_other_keys_argument_seen)
{ allow_other_keys_argument_value = value; allow_other_keys_argument_seen = true; }
}
else if (!extra_would_be_keyword_seen)
{ extra_would_be_keyword = keyword; extra_would_be_keyword_seen = true; }
} while (ARGS[0].narg > 0);
if (extra_would_be_keyword_seen)
if (!allow_other_keys_argument_seen || (allow_other_keys_argument_value == mk_cl_Cnil))
mkcl_FEprogram_error(env, "In LAMBDA-LIST &KEY part of ~S: expected ~S or ~S or ~S, instead got ~S.", 5, fname, key1_arg_symbol, key2_arg_symbol, key3_arg_symbol, extra_would_be_keyword);
}
void mkcl_receive_4_keyword_arguments(MKCL, const mkcl_object fname, mkcl_va_list ARGS, const mkcl_object key1_arg_symbol, mkcl_object * const key1_var_ref, const mkcl_object key2_arg_symbol, mkcl_object * const key2_var_ref, const mkcl_object key3_arg_symbol, mkcl_object * const key3_var_ref, const mkcl_object key4_arg_symbol, mkcl_object * const key4_var_ref)
{
bool key1_arg_seen = false;
bool key2_arg_seen = false;
bool key3_arg_seen = false;
bool key4_arg_seen = false;
bool extra_would_be_keyword_seen = false;
mkcl_object extra_would_be_keyword = mk_cl_Cnil;
bool allow_other_keys_argument_seen = false;
mkcl_object allow_other_keys_argument_value = mk_cl_Cnil;
if (ARGS[0].narg % 2) mkcl_FEprogram_error(env, "Function ~S received an odd number of arguments for &key", 1, fname);
do {
const mkcl_object keyword = mkcl_va_arg(ARGS);
const mkcl_object value = mkcl_va_arg(ARGS);
if (keyword == key1_arg_symbol)
{
if (!key1_arg_seen)
{ *key1_var_ref = value; key1_arg_seen = true; }
}
else if (keyword == key2_arg_symbol)
{
if (!key2_arg_seen)
{ *key2_var_ref = value; key2_arg_seen = true; }
}
else if (keyword == key3_arg_symbol)
{
if (!key3_arg_seen)
{ *key3_var_ref = value; key3_arg_seen = true; }
}
else if (keyword == key4_arg_symbol)
{
if (!key4_arg_seen)
{ *key4_var_ref = value; key4_arg_seen = true; }
}
else if (keyword == @':allow-other-keys')
{
if (!allow_other_keys_argument_seen)
{ allow_other_keys_argument_value = value; allow_other_keys_argument_seen = true; }
}
else if (!extra_would_be_keyword_seen)
{ extra_would_be_keyword = keyword; extra_would_be_keyword_seen = true; }
} while (ARGS[0].narg > 0);
if (extra_would_be_keyword_seen)
if (!allow_other_keys_argument_seen || (allow_other_keys_argument_value == mk_cl_Cnil))
mkcl_FEprogram_error(env, "In LAMBDA-LIST &KEY part of ~S: expected ~S or ~S or ~S or ~S, instead got ~S.", 6, fname, key1_arg_symbol, key2_arg_symbol, key3_arg_symbol, key4_arg_symbol, extra_would_be_keyword);
}
void mkcl_receive_N_keyword_arguments(MKCL, const mkcl_object fname, mkcl_va_list ARGS, const long key_param_count, struct mkcl_key_param_spec key_params[])
{
bool extra_would_be_keyword_seen = false;
mkcl_object extra_would_be_keyword = mk_cl_Cnil;
bool allow_other_keys_argument_seen = false;
mkcl_object allow_other_keys_argument_value = mk_cl_Cnil;
long i;
if (ARGS[0].narg % 2) mkcl_FEprogram_error(env, "Function ~S received an odd number of arguments for &key", 1, fname);
do {
const mkcl_object keyword = mkcl_va_arg(ARGS);
const mkcl_object value = mkcl_va_arg(ARGS);
for (i = 0; i < key_param_count; i++)
{
if (keyword == key_params[i].key_symbol)
if (!key_params[i].key_arg_seen)
{ *(key_params[i].key_var_ref) = value; key_params[i].key_arg_seen = true; goto NEXT_ARG; }
}
if (keyword == @':allow-other-keys')
{
if (!allow_other_keys_argument_seen)
{ allow_other_keys_argument_value = value; allow_other_keys_argument_seen = true; }
}
else if (!extra_would_be_keyword_seen)
{ extra_would_be_keyword = keyword; extra_would_be_keyword_seen = true; }
NEXT_ARG:;
} while (ARGS[0].narg > 0);
if (extra_would_be_keyword_seen)
if (!allow_other_keys_argument_seen || (allow_other_keys_argument_value == mk_cl_Cnil))
{
mkcl_object key_list = mk_cl_Cnil;
for (i = 0; i < key_param_count; i++) key_list = mkcl_cons(env, key_params[i].key_symbol, key_list);
mkcl_FEprogram_error(env, "In LAMBDA-LIST &KEY part of ~S: expected one of ~S, instead got ~S.", 3, fname, key_list, extra_would_be_keyword);
}
}
static mkcl_object convert_cmp_lexical_info(MKCL, mkcl_object cmp_env) static mkcl_object convert_cmp_lexical_info(MKCL, mkcl_object cmp_env)
{ {
mkcl_object lex_env = mk_cl_Cnil; mkcl_object lex_env = mk_cl_Cnil;
......
...@@ -4,7 +4,7 @@ ...@@ -4,7 +4,7 @@
*/ */
/* /*
Copyright (c) 2001, Juan Jose Garcia Ripoll. Copyright (c) 2001, Juan Jose Garcia Ripoll.
Copyright (c) 2012-2014, Jean-Claude Beaudoin. Copyright (c) 2012-2014,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
...@@ -2410,42 +2410,49 @@ c_listA(MKCL, mkcl_object args, int flags) ...@@ -2410,42 +2410,49 @@ c_listA(MKCL, mkcl_object args, int flags)
/* /*
Handles special declarations, removes declarations from body Handles special declarations, removes declarations from body
*/ */
@(defun si::process_declarations (body &optional doc) mkcl_object mk_si_process_declarations(MKCL, mkcl_narg narg, mkcl_object body, ...)
mkcl_object documentation = mk_cl_Cnil, declarations = mk_cl_Cnil, specials = mk_cl_Cnil; {
mkcl_object decls, vars, v; mkcl_call_stack_check(env);
@ {
/* BEGIN: SEARCH DECLARE */
for (; !mkcl_endp(env, body); body = MKCL_CONS_CDR(body)) {
mkcl_object form = MKCL_CONS_CAR(body);
if (!mkcl_Null(doc) && MKCL_STRINGP(form) && !mkcl_endp(env, MKCL_CDR(body))) {
if (documentation == mk_cl_Cnil)
documentation = form;
else
break;
continue;
}
if (MKCL_ATOM(form) || (MKCL_CONS_CAR(form) != @'declare')) mkcl_object documentation = mk_cl_Cnil, declarations = mk_cl_Cnil, specials = mk_cl_Cnil;
break; mkcl_object decls, vars, v;
mkcl_object doc = mk_cl_Cnil;
for (decls = MKCL_CONS_CDR(form); !mkcl_endp(env, decls); decls = MKCL_CONS_CDR(decls)) { MKCL_RECEIVE_1_OPTIONAL_ARGUMENT(env, @'si::process-declarations', narg, 1, body, &doc);
mkcl_object sentence = MKCL_CONS_CAR(decls);
if (MKCL_ATOM(sentence)) /* BEGIN: SEARCH DECLARE */
mkcl_FEill_formed_input(env); for (; !mkcl_endp(env, body); body = MKCL_CONS_CDR(body)) {
push(env, sentence, declarations); mkcl_object form = MKCL_CONS_CAR(body);
if (MKCL_CONS_CAR(sentence) == @'special')
for (vars = MKCL_CONS_CDR(sentence); !mkcl_endp(env, vars); vars = MKCL_CONS_CDR(vars)) { if (!mkcl_Null(doc) && MKCL_STRINGP(form) && !mkcl_endp(env, MKCL_CDR(body))) {
v = MKCL_CONS_CAR(vars); if (documentation == mk_cl_Cnil)
mkcl_assert_type_symbol(env, v); documentation = form;
push(env, v,specials); else
} break;
} continue;
} }
/* END: SEARCH DECLARE */
if (MKCL_ATOM(form) || (MKCL_CONS_CAR(form) != @'declare'))
break;
for (decls = MKCL_CONS_CDR(form); !mkcl_endp(env, decls); decls = MKCL_CONS_CDR(decls)) {
mkcl_object sentence = MKCL_CONS_CAR(decls);
if (MKCL_ATOM(sentence))
mkcl_FEill_formed_input(env);
push(env, sentence, declarations);
if (MKCL_CONS_CAR(sentence) == @'special')
for (vars = MKCL_CONS_CDR(sentence); !mkcl_endp(env, vars); vars = MKCL_CONS_CDR(vars)) {
v = MKCL_CONS_CAR(vars);
mkcl_assert_type_symbol(env, v);
push(env, v,specials);
}
}
}