mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-03-12 16:00:31 -07:00
Code Issues Projects Releases Packages Wiki Activity

Merge branch 'revert' into 'develop'

Browse source 
Reapply merge !65

See merge request !68
This commit is contained in:
Daniel Kochmański 2017-06-03 11:14:40 +00:00
commit 1d4e453075
20 changed files with 85 additions and 33 deletions
Download patch file Download diff file Expand all files Collapse all files

17
src/c/character.d
View file

@ -208,6 +208,7 @@ ecl_char_eq(cl_object x, cl_object y)
if (ecl_char_eq(ecl_va_arg(ds), c)) {
@(return ECL_NIL);
}
ecl_va_end(ds);
}
@(return ECL_T);
} @)
@ -239,22 +240,22 @@ ecl_char_cmp(cl_object x, cl_object y)
@(defun char< (&rest args)
@
return Lchar_cmp(the_env, narg, 1, 1, args);
@(return Lchar_cmp(the_env, narg, 1, 1, args));
@)
@(defun char> (&rest args)
@
return Lchar_cmp(the_env, narg,-1, 1, args);
@(return Lchar_cmp(the_env, narg,-1, 1, args));
@)
@(defun char<= (&rest args)
@
return Lchar_cmp(the_env, narg, 1, 0, args);
@(return Lchar_cmp(the_env, narg, 1, 0, args));
@)
@(defun char>= (&rest args)
@
return Lchar_cmp(the_env, narg,-1, 0, args);
@(return Lchar_cmp(the_env, narg,-1, 0, args));
@)
@(defun char_equal (c &rest cs)
@ -330,22 +331,22 @@ ecl_char_compare(cl_object x, cl_object y)
@(defun char-lessp (&rest args)
@
return Lchar_compare(the_env, narg, 1, 1, args);
@(return Lchar_compare(the_env, narg, 1, 1, args));
@)
@(defun char-greaterp (&rest args)
@
return Lchar_compare(the_env, narg,-1, 1, args);
@(return Lchar_compare(the_env, narg,-1, 1, args));
@)
@(defun char-not-greaterp (&rest args)
@
return Lchar_compare(the_env, narg, 1, 0, args);
@(return Lchar_compare(the_env, narg, 1, 0, args));
@)
@(defun char-not-lessp (&rest args)
@
return Lchar_compare(the_env, narg,-1, 0, args);
@(return Lchar_compare(the_env, narg,-1, 0, args));
@)

7
src/c/cinit.d
View file

@ -38,6 +38,7 @@ si_safe_eval(cl_narg narg, cl_object form, cl_object env, ...)
cl_object err_value;
va_list args; va_start(args, env);
err_value = va_arg(args, cl_object);
va_end(args);
return _ecl_funcall4(@'ext::safe-eval', form, env, err_value);
}
return _ecl_funcall3(@'ext::safe-eval', form, env);
@ -98,6 +99,7 @@ si_string_to_object(cl_narg narg, cl_object string, ...)
cl_object err_value;
va_list args; va_start(args, string);
err_value = va_arg(args, cl_object);
va_end(args);
return _ecl_funcall3(@'si::string-to-object', string, err_value);
}
return _ecl_funcall2(@'si::string-to-object', string);
@ -110,8 +112,9 @@ si_signal_simple_error(cl_narg narg, cl_object condition, cl_object continuable,
cl_object rest;
ecl_va_start(args, format_args, narg, 4);
rest = cl_grab_rest_args(args);
cl_apply(6, @'si::signal-simple-error', condition, continuable,
format, format_args, rest);
ecl_va_end(args);
return cl_apply(6, @'si::signal-simple-error', condition, continuable,
format, format_args, rest);
}
extern cl_object

1
src/c/clos/gfun.d
View file

@ -49,6 +49,7 @@ user_function_dispatch(cl_narg narg, ...)
fun = fun->instance.slots[fun->instance.length - 1];
output = ecl_apply_from_stack_frame(frame, fun);
ecl_stack_frame_close(frame);
ecl_va_end(args);
return output;
}

39
src/c/dpp.c
View file

@ -120,6 +120,11 @@ char *required[MAXREQ];
int nreq;
int the_env_defined = 0;
enum vararg_status_t {
VARARG_NOT_DEFINED,
VARARG_SIMPLE,
VARARG_ECL};
enum vararg_status_t vararg_status = VARARG_NOT_DEFINED;
struct optional {
char *o_var;
@ -470,6 +475,7 @@ reset(void)
aux[i].a_var
= aux[i].a_init
= NULL;
vararg_status = VARARG_NOT_DEFINED;
}
void
@ -726,13 +732,16 @@ put_declaration(void)
}
}
put_lineno();
if (simple_varargs)
if (simple_varargs) {
vararg_status = VARARG_SIMPLE;
fprintf(out,"\tva_list %s;\n\tva_start(%s, %s);\n",
rest_var, rest_var, ((nreq > 0) ? required[nreq-1] : "narg"));
else
} else {
vararg_status = VARARG_ECL;
fprintf(out,"\tecl_va_list %s;\n\tecl_va_start(%s, %s, narg, %d);\n",
rest_var, rest_var, ((nreq > 0) ? required[nreq-1] : "narg"),
nreq);
}
put_lineno();
fprintf(out, "\tif (ecl_unlikely(narg < %d", nreq);
if (nopt > 0 && !rest_flag && !key_flag) {
@ -799,6 +808,16 @@ put_declaration(void)
}
}
void unregister_varargs()
{
if (vararg_status == VARARG_SIMPLE) {
fprintf(out, "va_end(%s);\n", rest_var);
}
else if (vararg_status == VARARG_ECL) {
fprintf(out, "ecl_va_end(%s);\n", rest_var);
}
}
void
put_return(void)
{
@ -826,6 +845,8 @@ put_return(void)
fprintf(out, "the_env->values[%d] = __value%d;\n", i, i);
}
put_tabs(t);
unregister_varargs();
put_tabs(t);
fprintf(out, "return __value0;\n");
}
put_tabs(tab_save);
@ -868,24 +889,28 @@ main_loop(void)
goto LOOP;
} else if (c == '\'') {
char *p;
poolp = pool;
char* tmp = poolp;
p = read_symbol(0);
pushc('\0');
fprintf(out,"%s",p);
poolp = tmp;
goto LOOP;
} else if (c == '[') {
char *p;
poolp = pool;
char * tmp = poolp;
p = read_symbol(1);
pushc('\0');
fprintf(out,"%s",p);
poolp = tmp;
goto LOOP;
} else if (c != '(') {
char *p;
char * tmp = poolp;
unreadc(c);
poolp = pool;
poolp = p = read_function();
fprintf(out,"%s",translate_function(poolp));
//poolp = pool;
p = read_function();
fprintf(out,"%s",translate_function(p));
poolp = tmp;
goto LOOP;
}
p = read_token();

5
src/c/error.d
View file

@ -125,12 +125,15 @@ void
FEerror(const char *s, int narg, ...)
{
ecl_va_list args;
cl_object rest;
ecl_va_start(args, narg, narg, 0);
ecl_enable_interrupts();
rest = cl_grab_rest_args(args);
ecl_va_end(args);
funcall(4, @'si::universal-error-handler',
ECL_NIL, /* not correctable */
make_constant_base_string(s), /* condition text */
cl_grab_rest_args(args));
rest);
_ecl_unexpected_return();
}

3
src/c/file.d
View file

@ -5328,7 +5328,8 @@ flisten(cl_object stream, FILE *fp)
{
/* regular file */
ecl_off_t old_pos = ecl_ftello(fp), end_pos;
unlikely_if (ecl_fseeko(fp, 0, SEEK_END) != 0)
unlikely_if (old_pos == -1 ||
ecl_fseeko(fp, 0, SEEK_END) != 0)
file_libc_error(@[file-error], stream,
"Unable to check file position", 0);
end_pos = ecl_ftello(fp);

1
src/c/numbers/ceiling.d
View file

@ -77,6 +77,7 @@ ecl_ceiling2(cl_object x, cl_object y)
const cl_env_ptr the_env = ecl_process_env();
cl_object v0, v1;
cl_type ty;
v0 = v1 = ECL_NIL;
ty = ecl_t_of(y);
if (ecl_unlikely(!ECL_REAL_TYPE_P(ty))) {
FEwrong_type_nth_arg(@[ceiling],2, y, @[real]);

4
src/c/numbers/number_compare.d
View file

@ -208,7 +208,9 @@ monotonic(int s, int t, int narg, ecl_va_list nums)
#define MONOTONIC(i, j) (cl_narg narg, ...) \
{ ecl_va_list nums; ecl_va_start(nums, narg, narg, 0); \
return monotonic(i, j, narg, nums); }
cl_object result = monotonic(i, j, narg, nums); \
ecl_va_end(nums); \
return result; }
cl_object @<= MONOTONIC( 1, 0)
cl_object @>= MONOTONIC(-1, 0)

1
src/c/numbers/number_equalp.d
View file

@ -188,6 +188,7 @@ ecl_number_equalp(cl_object x, cl_object y)
if (ecl_number_equalp(numi, ecl_va_arg(numb))) {
@(return ECL_NIL);
}
ecl_va_end(numb);
}
@(return ECL_T);
@)

5
src/c/package.d
View file

@ -51,12 +51,15 @@ void
CEpackage_error(const char *message, const char *continue_message, cl_object package, int narg, ...)
{
ecl_va_list args;
cl_object arg;
ecl_va_start(args, narg, narg, 0);
arg = narg? cl_grab_rest_args(args) : cl_list(1,package);
ecl_va_end(args);
si_signal_simple_error(6,
@'package-error',
make_constant_base_string(continue_message),
make_constant_base_string(message), /* format control */
narg? cl_grab_rest_args(args) : cl_list(1,package),
arg,
@':package', package);
}

1
src/c/pathname.d
View file

@ -564,6 +564,7 @@ ecl_parse_namestring(cl_object s, cl_index start, cl_index end, cl_index *ep,
if (start == end) {
host = device = path = name = type = aux = version = @'nil';
logical = 0;
*ep = end;
goto make_it;
}
/* We first try parsing as logical-pathname. In case of

1
src/c/tcp.d
View file

@ -251,6 +251,7 @@ create_server_port(int port)
FElibc_error("Accepting requests", 0);
#endif /* THREADS */
close(request);
return(conn);
}

9
src/c/threads/process.d
View file

@ -190,7 +190,7 @@ thread_cleanup(void *aux)
cl_env_ptr env = process->process.env;
/* The following flags will disable all interrupts. */
AO_store_full((AO_t*)&process->process.phase, ECL_PROCESS_EXITING);
ecl_disable_interrupts_env(env);
if (env) ecl_disable_interrupts_env(env);
#ifdef HAVE_SIGPROCMASK
/* ...but we might get stray signals. */
{
@ -440,6 +440,7 @@ mp_process_preset(cl_narg narg, cl_object process, cl_object function, ...)
assert_type_process(process);
process->process.function = function;
process->process.args = cl_grab_rest_args(args);
ecl_va_end(args);
@(return process);
}
@ -645,6 +646,7 @@ cl_object
mp_process_run_function(cl_narg narg, cl_object name, cl_object function, ...)
{
cl_object process;
cl_object rest;
ecl_va_list args;
ecl_va_start(args, function, narg, 2);
if (narg < 2)
@ -654,8 +656,10 @@ mp_process_run_function(cl_narg narg, cl_object name, cl_object function, ...)
} else {
process = mp_make_process(2, @':name', name);
}
rest = cl_grab_rest_args(args);
ecl_va_end(args);
cl_apply(4, @'mp::process-preset', process, function,
cl_grab_rest_args(args));
rest);
return mp_process_enable(process);
}
@ -673,6 +677,7 @@ mp_process_run_function_wait(cl_narg narg, ...)
cl_sleep(wait);
}
}
ecl_va_end(args);
@(return process);
}

1
src/c/threads/queue.d
View file

@ -386,5 +386,6 @@ print_lock(char *prefix, cl_object l, ...)
fflush(stdout);
ecl_giveup_spinlock(&lock);
}
va_end(args);
}
/*#define print_lock(a,b,c) (void)0*/

6
src/c/typespec.d
View file

@ -90,9 +90,9 @@ cl_object
ecl_type_error(cl_object function, const char *place, cl_object o,
cl_object type)
{
si_wrong_type_argument(4, o, type,
(*place? make_constant_base_string(place) : ECL_NIL),
function);
return si_wrong_type_argument(4, o, type,
(*place? make_constant_base_string(place) : ECL_NIL),
function);
}
/**********************************************************************/

2
src/c/unicode/ucd_names_char.c
View file

@ -514,7 +514,7 @@ static void
fill_pair_name(char *buffer, int pair)
{
if (pair < ECL_UCD_FIRST_PAIR) {
strncat(buffer, ecl_ucd_names_word[pair], ECL_UCD_LARGEST_CHAR_NAME+1);
strncat(buffer, ecl_ucd_names_word[pair], ECL_UCD_LARGEST_CHAR_NAME);
/*
printf("text=%s\n", ecl_ucd_names_word[pair]);
*/

6
src/c/unixsys.d
View file

@ -104,7 +104,7 @@ from_list_to_execve_argument(cl_object l, char ***environp)
cl_object buffer;
char **environ;
for (p = l; !Null(p); p = ECL_CONS_CDR(p)) {
cl_object s;
cl_object s = ECL_CONS_CAR(p);
total_size += s->base_string.fillp + 1;
nstrings++;
}
@ -515,7 +515,7 @@ si_spawn_subprocess(cl_object command, cl_object argv, cl_object environ,
}
close(child_stdin);
close(child_stdout);
close(child_stderr);
if (!(error == @':output')) close(child_stderr);
if (child_pid < 0) {
pid = ECL_NIL;
@ -533,7 +533,7 @@ si_spawn_subprocess(cl_object command, cl_object argv, cl_object environ,
if (Null(pid)) {
if (parent_write) close(parent_write);
if (parent_read) close(parent_read);
if (parent_error) close(parent_error);
if (parent_error > 0) close(parent_error);
parent_write = 0;
parent_read = 0;
parent_error = 0;

3
src/cmp/cmpmain.lsp
View file

@ -262,7 +262,7 @@ void ~A(cl_object cblock)
* circular chain. This disables the garbage collection of
* the library until _ALL_ functions in all modules are unlinked.
*/
cl_object current, next = Cblock;
cl_object current = OBJNULL, next = Cblock;
~:{
current = ecl_make_codeblock();
current->cblock.next = next;
@ -313,6 +313,7 @@ extern int
ecl_init_module(OBJNULL, ~A);
~A
} ECL_CATCH_ALL_END;
return 0;
}
")

2
src/cmp/cmptop.lsp
View file

@ -443,7 +443,7 @@
(wt-nl "volatile cl_object lex" *level* "[" *max-lex* "];"))
(unless (eq closure-type 'CLOSURE)
(wt-nl "cl_object " *volatile* "env0;"))
(wt-nl "cl_object " *volatile* "env0 = ECL_NIL;"))
(when (plusp *max-env*)
;; Closure structure has to be marked volatile or else GCC may

4
src/h/internal.h
View file

@ -194,6 +194,7 @@ extern cl_object si_constant_form_value _ECL_ARGS((cl_narg narg, cl_object form,
va_list args; \
va_start(args, lastarg); \
frame->frame.base = (cl_object*)args; \
va_end(args); \
} else { \
frame->frame.base = env->stack_top - narg; \
}
@ -207,7 +208,7 @@ extern cl_object si_constant_form_value _ECL_ARGS((cl_narg narg, cl_object form,
frame->frame.t = t_frame; \
frame->frame.env = env; \
frame->frame.size = narg; \
if (narg < ECL_C_ARGUMENTS_LIMIT) { \
if (narg < ECL_C_ARGUMENTS_LIMIT) { \
cl_object *p = frame->frame.base = env->values; \
va_list args; \
va_start(args, lastarg); \
@ -215,6 +216,7 @@ extern cl_object si_constant_form_value _ECL_ARGS((cl_narg narg, cl_object form,
*p = va_arg(args, cl_object); \
++p; \
} \
va_end(args); \
frame->frame.stack = (cl_object*)0x1; \
} else { \
frame->frame.base = env->stack_top - narg; \