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 @@
*/
/*
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
modify it under the terms of the GNU Lesser General Public
......@@ -1530,13 +1530,18 @@ mkcl_object mk_si_scrub_values(MKCL)
mkcl_return_no_value;
}
@(defun si::gc (&optional area)
@
mkcl_object mk_si_gc(MKCL, mkcl_narg narg, ...)
{
mkcl_call_stack_check(env);
{
mkcl_object area = mk_cl_Cnil;
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
mk_si_gc_dump(MKCL)
......
......@@ -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-2017, Jean-Claude Beaudoin.
Copyright (c) 2010-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
......@@ -50,12 +50,18 @@ mk_cl_set(MKCL, mkcl_object var, mkcl_object 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_call_stack_check(env);
{
mkcl_object sym = mk_si_function_block_name(env, fname);
mkcl_object pack;
bool mflag;
int type;
@
mkcl_object macro = mk_cl_Cnil;
mkcl_object pprint = mk_cl_Cnil;
MKCL_RECEIVE_2_OPTIONAL_ARGUMENTS(env, @'si::fset', narg, 2, def, &macro, &pprint);
if (mkcl_Null(sym)) sym = mk_cl_Cnil_symbol;
if (mkcl_Null(mk_cl_functionp(env, def))) mkcl_FEinvalid_function(env, def);
pack = mkcl_symbol_package(env, sym);
......@@ -89,7 +95,8 @@ mk_cl_set(MKCL, mkcl_object var, mkcl_object val)
mk_si_rem_sysprop(env, sym, @'si::setf-update');
}
mkcl_return_value(def);
@)
}
}
mkcl_object
mk_cl_makunbound(MKCL, mkcl_object sym)
......
......@@ -116,14 +116,19 @@ mkcl_string_case(const mkcl_object str)
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_object radix = MKCL_MAKE_FIXNUM(10);
MKCL_RECEIVE_1_OPTIONAL_ARGUMENT(env, @'digit-char-p', narg, 1, c, &radix);
{
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
......@@ -494,8 +499,14 @@ mk_cl_char_downcase(MKCL, mkcl_object c)
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_call_stack_check(env);
{
mkcl_object radix = MKCL_MAKE_FIXNUM(10);
MKCL_RECEIVE_1_OPTIONAL_ARGUMENT(env, @'digit-char', narg, 1, weight, &radix);
{
mkcl_word basis = mkcl_fixnum_in_range(env, @'digit-char',"radix",radix,2,36);
mkcl_object output = mk_cl_Cnil;
AGAIN:
......@@ -517,7 +528,9 @@ mk_cl_char_downcase(MKCL, mkcl_object c)
goto AGAIN;
}
mkcl_return_value(output);
} @)
}
}
}
short
mkcl_digit_char(mkcl_word w, mkcl_word r)
......
......@@ -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
......@@ -166,7 +166,7 @@ mkcl_grab_rest_args(MKCL, mkcl_va_list args, bool dynamic)
return rest;
}
void
void /* old, swiss knife version. JCB */
mkcl_parse_key(MKCL,
mkcl_va_list args, /* actual args */
const mkcl_word nkey, /* number of keywords */
......@@ -222,6 +222,248 @@ mkcl_parse_key(MKCL,
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)
{
mkcl_object lex_env = mk_cl_Cnil;
......
......@@ -4,7 +4,7 @@
*/
/*
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
modify it under the terms of the GNU Lesser General Public
......@@ -2410,10 +2410,16 @@ c_listA(MKCL, mkcl_object args, int flags)
/*
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_call_stack_check(env);
{
mkcl_object documentation = mk_cl_Cnil, declarations = mk_cl_Cnil, specials = mk_cl_Cnil;
mkcl_object decls, vars, v;
@
mkcl_object doc = mk_cl_Cnil;
MKCL_RECEIVE_1_OPTIONAL_ARGUMENT(env, @'si::process-declarations', narg, 1, body, &doc);
/* BEGIN: SEARCH DECLARE */
for (; !mkcl_endp(env, body); body = MKCL_CONS_CDR(body)) {
mkcl_object form = MKCL_CONS_CAR(body);
......@@ -2444,8 +2450,9 @@ c_listA(MKCL, mkcl_object args, int flags)
}
/* END: SEARCH DECLARE */
mkcl_return_4_values(declarations, body, documentation, specials)
@)
mkcl_return_4_values(declarations, body, documentation, specials);
}
}
#if 0
static size_t mk_si_process_lambda_ctr = 0;
......@@ -2902,18 +2909,21 @@ mk_si_make_lambda(MKCL, mkcl_object name, mkcl_object rest)
mkcl_return_value(lambda);
}
@(defun si::eval-in-env (form
&optional
(lex_env mk_cl_Cnil)
(stepping mk_cl_Cnil)
(compiler_env_p mk_cl_Cnil)
(execute mk_cl_Ct))
mkcl_object mk_si_eval_in_env(MKCL, mkcl_narg narg, mkcl_object form, ...)
{
mkcl_call_stack_check(env);
{
volatile mkcl_compiler_env_ptr old_c_env;
struct mkcl_compiler_env new_c_env;
volatile mkcl_index handle;
mkcl_object bytecode = mk_cl_Cnil, interpreter_env, compiler_env;
mkcl_env the_env;
@
mkcl_object lex_env = mk_cl_Cnil;
mkcl_object stepping = mk_cl_Cnil;
mkcl_object compiler_env_p = mk_cl_Cnil;
mkcl_object execute = mk_cl_Ct;
MKCL_RECEIVE_4_OPTIONAL_ARGUMENTS(env, @'si::eval-in-env', narg, 1, form, &lex_env, &stepping, &compiler_env_p, &execute);
the_env = env;
/*
* Compile to bytecode.
......@@ -2963,4 +2973,5 @@ mk_si_make_lambda(MKCL, mkcl_object name, mkcl_object rest)
mkcl_dealloc(env, bytecode);
return output;
}
@)
}
}
......@@ -268,9 +268,14 @@ mk_cl_eval(MKCL, mkcl_object form)
return mk_si_eval_in_env(env, 1, form);
}
@(defun constantp (arg &optional lex_env)
mkcl_object mk_cl_constantp(MKCL, mkcl_narg narg, mkcl_object arg, ...)
{
mkcl_call_stack_check(env);
{
mkcl_object flag;
@
mkcl_object lex_env = mk_cl_Cnil;
MKCL_RECEIVE_1_OPTIONAL_ARGUMENT(env, @'constantp', narg, 1, arg, &lex_env);
switch (mkcl_type_of(arg)) {
case mkcl_t_cons:
if (MKCL_CAR(arg) == @'quote') {
......@@ -289,7 +294,8 @@ mk_cl_eval(MKCL, mkcl_object form)
flag = mk_cl_Ct;
}
mkcl_return_value(flag);
@)
}
}
extern inline MKCL_API mkcl_object mkcl_validate_function(MKCL, mkcl_object fun);
......
......@@ -4,7 +4,7 @@
*/
/*
Copyright (c) 2001, Juan Jose Garcia Ripoll.
Copyright (c) 2011-2013, Jean-Claude Beaudoin.
Copyright (c) 2011-2013,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
......@@ -724,10 +724,15 @@ void mkcl_fficall_align16(MKCL)
fficall->buffer_sp = (char *) (((intptr_t) (fficall->buffer_sp + 0xF)) & ~((uintptr_t)0xF));
}
@(defun si::call-cfun (fun return_type arg_types args &optional (cc_type @':cdecl'))
mkcl_object mk_si_call_cfun(MKCL, mkcl_narg narg, mkcl_object fun, mkcl_object return_type, mkcl_object arg_types, mkcl_object args, ...)
{
mkcl_call_stack_check(env);
{
void *cfun = mkcl_foreign_raw_pointer(env, fun);
enum mkcl_ffi_tag return_type_tag = mkcl_foreign_type_code(env, return_type);
@
mkcl_object cc_type = mk_cl_Cnil;
MKCL_RECEIVE_1_OPTIONAL_ARGUMENT(env, @'si::call-cfun', narg, 4, args, &cc_type);
struct mkcl_fficall *fficall = mkcl_fficall_prepare(env, return_type, arg_types, cc_type);
while (MKCL_CONSP(arg_types)) {
......@@ -758,16 +763,24 @@ void mkcl_fficall_align16(MKCL)
fficall->buffer_sp = fficall->buffer;
mkcl_return_value(return_value);
}
@)
}
}
mkcl_object mk_si_make_dynamic_callback(MKCL, mkcl_narg narg, mkcl_object fun, mkcl_object sym, mkcl_object rtype, mkcl_object argtypes, ...)
{
mkcl_call_stack_check(env);
{
@(defun si::make-dynamic-callback (fun sym rtype argtypes &optional (cctype @':cdecl'))
mkcl_object data;
mkcl_object cbk;
@
mkcl_object cctype = mk_cl_Cnil;
MKCL_RECEIVE_1_OPTIONAL_ARGUMENT(env, @'si::make-dynamic-callback', narg, 4, argtypes, &cctype);
data = mk_cl_list(env, 3, fun, rtype, argtypes);
cbk = mkcl_make_foreign(env, @':void', 0, mkcl_dynamic_callback_make(env, data, mkcl_foreign_cc_code(env, cctype)));
mk_si_put_sysprop(env, sym, @':callback', MKCL_CONS(env, cbk, data));
mkcl_return_value(cbk);
@)
}
}
......@@ -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-2017,2021 Jean-Claude Beaudoin.
Copyright (c) 2010-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
......@@ -1684,10 +1684,17 @@ mkcl_make_string_output_stream(MKCL, mkcl_index line_length, bool extended, mkcl
#define DEFAULT_OUTPUT_STRING_LENGTH 128
@(defun make-string-output-stream (&key (element_type @'character') (encoding @':default'))
bool extended = FALSE;
@
mkcl_object mk_cl_make_string_output_stream(MKCL, mkcl_narg narg, ...)
{
mkcl_call_stack_check(env);
{
mkcl_object element_type = @'character';
mkcl_object encoding = @':default';
MKCL_RECEIVE_2_KEYWORD_ARGUMENTS(env, @'make-string-output-stream', narg, 0, narg, @':element-type', &element_type, @':encoding', &encoding);
{
bool extended = FALSE;
if (element_type == @'base-char') {
extended = FALSE;
} else if (element_type == @'character') {
......@@ -1706,7 +1713,8 @@ mkcl_make_string_output_stream(MKCL, mkcl_index line_length, bool extended, mkcl
}
mkcl_return_value(mkcl_make_string_output_stream(env, DEFAULT_OUTPUT_STRING_LENGTH, extended, encoding));
}
@)
}
}
mkcl_object
mk_cl_get_output_stream_string(MKCL, mkcl_object strm)
......@@ -1920,9 +1928,26 @@ mkcl_make_string_input_stream(MKCL, mkcl_object strng, mkcl_index istart, mkcl_i
return strm;
}
@(defun make_string_input_stream (strng &o (istart MKCL_MAKE_FIXNUM(0)) (iend mk_cl_Cnil) &key (encoding @':default'))
mkcl_object mk_cl_make_string_input_stream(MKCL, mkcl_narg narg, mkcl_object strng, ...)
{
mkcl_call_stack_check(env);
{
mkcl_index s, e;
@
mkcl_object istart = MKCL_MAKE_FIXNUM(0);
mkcl_object iend = mk_cl_Cnil;
mkcl_object encoding = @':default';
mkcl_check_minimal_arg_count(env, @'make-string-input-stream', narg, 1);
if (narg > 1) {
mkcl_va_list ARGS;
mkcl_va_start(env, ARGS, strng, narg, 1);
istart = mkcl_va_arg(ARGS);
if (narg > 2) iend = mkcl_va_arg(ARGS);
if (narg > 3)
mkcl_receive_1_keyword_argument(env, @'make-string-input-stream', ARGS, @':encoding', &encoding);
mkcl_va_end(ARGS);
}
strng = mk_cl_string(env, strng);
if (!MKCL_FIXNUMP(istart) || MKCL_FIXNUM_MINUSP(istart))
goto E;
......@@ -1943,7 +1968,8 @@ mkcl_make_string_input_stream(MKCL, mkcl_object strng, mkcl_index istart, mkcl_i
"~S and ~S are illegal as :START and :END~%"
"for the string ~S.",
3, istart, iend, strng);
@)
}