From a9e4edf4d0ea43835ee9fe02b0d7f0dd54679a68 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Mon, 21 Oct 2002 09:27:58 +0000 Subject: [PATCH] The calling conventions have been changed. SI::C-ARGUMENTS-LIMIT and LAMBDA-PARAMETERS-LIMIT are both 64. Up to C-ARGUMENTS-LIMIT may be passed to a function using C calling conventions. If the function is to retrieve more arguments, (for instance through a &rest variable), this can be done, but then the arguments have to be pushed on the lisp stack. This method allows us to raise the CALL-ARGUMENTS-LIMIT up to MOST-POSITIVE-FIXNUM. From a users point of view, there is no visible change, excep the fact that a function may receive more arguments. The function apply() has been replaced with cl_apply_from_stack(). The former took a pointer to the list of arguments. The latter assumes that the last "narg" elements on the lisp stack are the arguments of the function. --- src/CHANGELOG | 33 +++++++++- src/c/Makefile.in | 2 +- src/c/apply.d | 33 ++-------- src/c/array.d | 10 +-- src/c/character.d | 40 ++++++------ src/c/cmpaux.d | 96 ++++------------------------- src/c/compiler.d | 3 + src/c/dpp.c | 15 ++--- src/c/error.d | 47 +++++++------- src/c/eval.d | 102 ++++++++++++++++++++++--------- src/c/file.d | 4 +- src/c/format.d | 2 +- src/c/interpreter.d | 132 +++++++++++++++++++++------------------ src/c/list.d | 30 ++++----- src/c/lwp.d | 6 +- src/c/mapfun.d | 139 ++++++++++++++++++++++++------------------ src/c/multival.d | 2 +- src/c/num_arith.d | 16 ++--- src/c/num_comp.d | 28 ++++----- src/c/num_log.d | 10 +-- src/c/string.d | 38 ++++++------ src/c/structure.d | 2 +- src/c/symbol.d | 4 +- src/c/symbols_list.h | 1 + src/c/time.d | 11 +--- src/c/unixfsys.d | 7 +-- src/cmp/cmpbind.lsp | 2 +- src/cmp/cmpcall.lsp | 98 ++++++++++++++++++++--------- src/cmp/cmpcatch.lsp | 33 +++++++--- src/cmp/cmpexit.lsp | 66 ++++++++++---------- src/cmp/cmpflet.lsp | 8 ++- src/cmp/cmpfun.lsp | 27 ++++---- src/cmp/cmplam.lsp | 37 ++++++----- src/cmp/cmploc.lsp | 10 +-- src/cmp/cmpmulti.lsp | 32 +++++----- src/cmp/cmputil.lsp | 2 +- src/configure.in | 2 +- src/h/config.h.in | 7 ++- src/h/ecl-cmp.h | 2 +- src/h/ecl.h | 1 - src/h/external.h | 47 +++++++------- src/h/lisp_external.h | 12 ++-- src/h/object.h | 9 +++ src/h/stacks.h | 9 --- src/lsp/helpfile.lsp | 1 + 45 files changed, 634 insertions(+), 584 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index 04b512334..b16cd34b7 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -952,8 +952,8 @@ ECL 0.6 - *PRINT-CIRCLE* defaults to NIL. -ECL 0.6 (bugfix release) -======================== +ECL 0.7 +======= * Errors fixed: @@ -961,6 +961,9 @@ ECL 0.6 (bugfix release) - Symbol BUILD-PROGRAM should be exported from package C. + - In compiled code UNWIND-PROTECT would procted also the exit form, + resulting in an infinite loop when the exit form fails. + * System design: - Global variables READsuppress, READdefault_float_format, @@ -975,12 +978,38 @@ ECL 0.6 (bugfix release) LEFT-PARENTHESIS-READER. This avoids using global variables "in_list_flag" and "dot_flag". + - The calling conventions have been changed. SI::C-ARGUMENTS-LIMIT + and LAMBDA-PARAMETERS-LIMIT are both 64. Up to C-ARGUMENTS-LIMIT + may be passed to a function using C calling conventions. If the + function is to retrieve more arguments, (for instance through a + &rest variable), this can be done, but then the arguments have to + be pushed on the lisp stack. This method allows us to raise the + CALL-ARGUMENTS-LIMIT up to MOST-POSITIVE-FIXNUM. From a users + point of view, there is no visible change, excep the fact that a + function may receive more arguments. + + - The function apply() has been replaced with cl_apply_from_stack(). + The former took a pointer to the list of arguments. The latter + assumes that the last "narg" elements on the lisp stack are the + arguments of the function. + * Visible changes: - New functions SI:SAFE-EVAL and cl_safe_eval() allow the user to evaluate code with errors without jumping into the debugger. Useful when embedding ECL in other programs. + - New function SI:OPEN-UNIX-SOCKET-STREAM creates a two-way stream + attached to a unix socked (Unix sockets are pipes which programs + from the same computer may use to communicate with each other, and + they are either anonymous (not supported by ECL) or associated to + a file of the filesystem). + + - New function SI:LOOKUP-HOST-ENTRY encompasses the C calls + gethostbyname() and gethostbyaddress() and it is used to guess the + address, aliases and hostname of a machine in the Internet (Currently + we only support AF_INET protocol). + * ANSI compatibility: - READ and READ-PRESERVING-WHITESPACE behave the same when diff --git a/src/c/Makefile.in b/src/c/Makefile.in index 7d10f7ef2..08ac7faee 100644 --- a/src/c/Makefile.in +++ b/src/c/Makefile.in @@ -63,7 +63,7 @@ install: $(HFILES) ranlib $@ clean: - $(RM) *.c $(OBJS) ../libecl.a cinit.o core a.out + $(RM) dpp *.c $(OBJS) ../libecl.a cinit.o core a.out # Build rules diff --git a/src/c/apply.d b/src/c/apply.d index e5d2f50b0..334559b6e 100644 --- a/src/c/apply.d +++ b/src/c/apply.d @@ -328,7 +328,7 @@ APPLY(int n, cl_objectfn fn, cl_object *x) x[43],x[44],x[45],x[46],x[47],x[48],x[49], x[50],x[51],x[52],x[53],x[54],x[55],x[56], x[57],x[58],x[59],x[60],x[61],x[62]); - case 64: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + default: return (*fn)(n, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], x[8],x[9],x[10],x[11],x[12],x[13],x[14], x[15],x[16],x[17],x[18],x[19],x[20],x[21], x[22],x[23],x[24],x[25],x[26],x[27],x[28], @@ -337,7 +337,7 @@ APPLY(int n, cl_objectfn fn, cl_object *x) x[43],x[44],x[45],x[46],x[47],x[48],x[49], x[50],x[51],x[52],x[53],x[54],x[55],x[56], x[57],x[58],x[59],x[60],x[61],x[62],x[63]); - default: FEprogram_error("Exceeded call-arguments-limit.", 0); + /* Arguments above 64 have been pushed on the stack */ } } @@ -644,7 +644,7 @@ APPLY_closure(int n, cl_objectfn fn, cl_object cl, cl_object *x) x[43],x[44],x[45],x[46],x[47],x[48],x[49], x[50],x[51],x[52],x[53],x[54],x[55],x[56], x[57],x[58],x[59],x[60],x[61]); - case 64: return (*fn)(n, cl, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], + default: return (*fn)(n, cl, x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7], x[8],x[9],x[10],x[11],x[12],x[13],x[14], x[15],x[16],x[17],x[18],x[19],x[20],x[21], x[22],x[23],x[24],x[25],x[26],x[27],x[28], @@ -653,31 +653,6 @@ APPLY_closure(int n, cl_objectfn fn, cl_object cl, cl_object *x) x[43],x[44],x[45],x[46],x[47],x[48],x[49], x[50],x[51],x[52],x[53],x[54],x[55],x[56], x[57],x[58],x[59],x[60],x[61],x[62]); - default: FEprogram_error("Exceeded call-arguments-limit.", 0); + /* Arguments above 64 have been pushed on the stack */ } } - -/* - * Variants for systems where stack grows upwards. - */ - -#ifdef NO_ARGS_ARRAY -cl_object -va_APPLY(int n, cl_objectfn fn, va_list args) -{ - cl_object x[n]; - int i; - for (i=0; iarray.rank) FEerror("Wrong number of indices.", 0); for (i = j = 0; i < r; i++) { - index = cl_nextarg(indx); + index = cl_va_arg(indx); if ((s = fixnnint(index)) >= x->array.dims[i]) FEerror("The ~:R index, ~S, to the array~%\ ~S is too large.", 3, MAKE_FIXNUM(i+1), index, x); @@ -78,7 +78,7 @@ object_to_index(cl_object n) case t_bitvector: if (r != 1) FEerror("Wrong number of indices.", 0); - index = cl_nextarg(indx); + index = cl_va_arg(indx); j = fixnnint(index); if (j >= x->vector.dim) FEerror("The first index, ~S, to the array ~S is too large.", @@ -162,7 +162,7 @@ aref1(cl_object v, cl_index index) if (r != x->array.rank) FEerror("Wrong number of indices.", 0); for (i = j = 0; i < r; i++) { - index = cl_nextarg(dims); + index = cl_va_arg(dims); if ((s = fixnnint(index)) >= x->array.dims[i]) FEerror("The ~:R index, ~S, to the array ~S is too large.", 3, MAKE_FIXNUM(i+1), index, x); @@ -175,7 +175,7 @@ aref1(cl_object v, cl_index index) case t_bitvector: if (r != 1) FEerror("Wrong number of indices.", 0); - index = cl_nextarg(dims); + index = cl_va_arg(dims); j = fixnnint(index); if (j >= x->vector.dim) FEerror("The first index, ~S, to the array ~S is too large.", @@ -284,7 +284,7 @@ aset1(cl_object v, cl_index index, cl_object val) if (r >= ARANKLIM) FEerror("The array rank, ~R, is too large.", 1, MAKE_FIXNUM(r)); for (i = 0, s = 1; i < r; i++) { - cl_object index = cl_nextarg(dims); + cl_object index = cl_va_arg(dims); if ((j = fixnnint(index)) > ADIMLIM) FEerror("The ~:R array dimension, ~D, is too large.", 2, MAKE_FIXNUM(i+1), index); diff --git a/src/c/character.d b/src/c/character.d index af899c2d5..7db031b46 100644 --- a/src/c/character.d +++ b/src/c/character.d @@ -140,7 +140,7 @@ digitp(int i, int r) @ /* INV: char_eq() checks types of `c' and `cs' */ while (--narg) - if (!char_eq(c, cl_nextarg(cs))) + if (!char_eq(c, cl_va_arg(cs))) @(return Cnil) @(return Ct) @) @@ -158,28 +158,28 @@ char_eq(cl_object x, cl_object y) /* INV: char_eq() checks types of its arguments */ if (narg == 0) @(return Ct) - c = cl_nextarg(cs); + c = cl_va_arg(cs); for (i = 2; i<=narg; i++) { - va_list ds; - va_start(ds, narg); - c = cl_nextarg(cs); + cl_va_list ds; + cl_va_start(ds, narg, narg, 0); + c = cl_va_arg(cs); for (j = 1; j -#endif #include "ecl.h" #include "ecl-inl.h" @@ -185,87 +182,20 @@ cl_go(cl_object tag_id, cl_object label) } cl_object -grab_rest_args(int narg, cl_object *args) +cl_grab_rest_args(cl_va_list args) { cl_object rest = Cnil; cl_object *r = &rest; - while (narg--) { - *r = CONS(*(args++), Cnil); + while (args[0].narg) { + *r = CONS(cl_va_arg(args), Cnil); r = &CDR(*r); } return rest; } void -parse_key( - int narg, /* number of actual args */ - cl_object *args, /* actual args */ - int nkey, /* number of keywords */ - cl_object *keys, /* keywords for the function */ - cl_object *vars, /* where to put values (vars[0..nkey-1]) - and suppliedp (vars[nkey..2*nkey-1]) */ - cl_object *rest, /* if rest!=NULL, collect arguments in a list */ - bool allow_other_keys) /* whether other key are allowed */ -{ - int i; - cl_object supplied_allow_other_keys = OBJNULL; - cl_object unknown_keyword = OBJNULL; - - if (rest != NULL) *rest = Cnil; - - for (i = 0; i < 2*nkey; i++) - vars[i] = Cnil; /* default values: NIL, supplied: NIL */ - if (narg <= 0) return; - - for (; narg>=2; narg-= 2) { - cl_object keyword = *(args++); - cl_object value = *(args++); - if (rest != NULL) { - rest = &CDR(*rest = CONS(keyword, Cnil)); - rest = &CDR(*rest = CONS(value, Cnil)); - } - for (i = 0; i < nkey; i++) { - if (keys[i] == keyword) { - if (vars[nkey+i] == Cnil) { - vars[i] = value; - vars[nkey+i] = Ct; - } - goto go_on; - } - } - /* the key is a new one */ - if (keyword == @':allow-other-keys') { - if (supplied_allow_other_keys == OBJNULL) - supplied_allow_other_keys = value; - } else if (unknown_keyword != OBJNULL) - unknown_keyword = keyword; - go_on: - (void)0; - } - if (narg != 0) - FEprogram_error("Odd number of keys", 0); - if (unknown_keyword != OBJNULL && !allow_other_keys && - supplied_allow_other_keys != Cnil) - FEprogram_error("Unknown keyword ~S", 1, unknown_keyword); -} - -#ifdef NO_ARGS_ARRAY -cl_object -va_grab_rest_args(int narg, va_list args) -{ - cl_object rest = Cnil; - cl_object *r = &rest; - while (narg--) { - *r = CONS(cl_nextarg(args), Cnil); - r = &CDR(*r); - } - return rest; -} - -void -va_parse_key( - int narg, /* number of actual args */ - va_list args, /* actual args */ +cl_parse_key( + cl_va_list args, /* actual args */ int nkey, /* number of keywords */ cl_object *keys, /* keywords for the function */ cl_object *vars, /* where to put values (vars[0..nkey-1]) @@ -281,11 +211,11 @@ va_parse_key( for (i = 0; i < 2*nkey; i++) vars[i] = Cnil; /* default values: NIL, supplied: NIL */ - if (narg <= 0) return; + if (args[0].narg <= 0) return; - for (; narg>=2; narg-= 2) { - cl_object keyword = cl_nextarg(args); - cl_object value = cl_nextarg(args); + for (; args[0].narg > 1; ) { + cl_object keyword = cl_va_arg(args); + cl_object value = cl_va_arg(args); if (rest != NULL) { rest = &CDR(*rest = CONS(keyword, Cnil)); rest = &CDR(*rest = CONS(value, Cnil)); @@ -307,13 +237,12 @@ va_parse_key( unknown_keyword = keyword; go_on: } - if (narg != 0) + if (args[0].narg != 0) FEprogram_error("Odd number of keys", 0); if (unknown_keyword != OBJNULL && !allow_other_keys && supplied_allow_other_keys != Cnil) FEprogram_error("Unknown keyword ~S", 1, unknown_keyword); } -#endif /* NO_ARGS_ARRAY */ /* Used in compiled macros */ void @@ -336,7 +265,7 @@ check_other_key(cl_object l, int n, ...) va_list ktab; va_start(ktab, n); /* extracting arguments */ for (i = 0; i < n; i++) - if (cl_nextarg(ktab) == k) + if (va_arg(ktab,cl_object) == k) break; va_end(ktab); if (i >= n) other_key = k; @@ -354,5 +283,6 @@ init_cmpaux(void) list(8, @'&optional', @'&rest', @'&key', @'&allow-other-keys', @'&aux', @'&whole', @'&environment', @'&body'); - SYM_VAL(@'LAMBDA-PARAMETERS-LIMIT') = MAKE_FIXNUM(64); + SYM_VAL(@'LAMBDA-PARAMETERS-LIMIT') = MAKE_FIXNUM(LAMBDA_PARAMETERS_LIMIT); + SYM_VAL(@'SI::C-ARGUMENTS-LIMIT') = MAKE_FIXNUM(C_ARGUMENTS_LIMIT); } diff --git a/src/c/compiler.d b/src/c/compiler.d index 472a89e2a..856dffa06 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -2151,6 +2151,9 @@ AUX: } OUTPUT: + if ((nreq+nopt+(!Null(rest))+nkey) >= LAMBDA_PARAMETERS_LIMIT) + FEprogram_error("LAMBDA: Argument list ist too long, ~S.", 1, + CAR(lambda)); @(return CONS(MAKE_FIXNUM(nreq), nreverse(reqs)) CONS(MAKE_FIXNUM(nopt), nreverse(opts)) nreverse(rest) diff --git a/src/c/dpp.c b/src/c/dpp.c index f0f9a4fa8..b08cd9435 100644 --- a/src/c/dpp.c +++ b/src/c/dpp.c @@ -607,19 +607,20 @@ put_declaration(void) fprintf(out, "\tcl_object KEY_VARS[%d];\n", 2*nkey); } put_lineno(); - fprintf(out, "\tva_list %s;\n\tva_start(%s, %s);\n", rest_var, rest_var, - ((nreq > 0) ? required[nreq-1] : "narg")); + fprintf(out, "\tcl_va_list %s;\n\tcl_va_start(%s, %s, narg, %d);\n", + rest_var, rest_var, ((nreq > 0) ? required[nreq-1] : "narg"), + nreq); put_lineno(); - fprintf(out, "\tif (narg < %d) FEtoo_few_arguments(&narg);\n", nreq); + fprintf(out, "\tif (narg < %d) FEtoo_few_arguments(narg);\n", nreq); if (nopt > 0 && !rest_flag && !key_flag) { put_lineno(); - fprintf(out, "\tif (narg > %d) FEtoo_many_arguments(&narg);\n", nreq + nopt); + fprintf(out, "\tif (narg > %d) FEtoo_many_arguments(narg);\n", nreq + nopt); } for (i = 0; i < nopt; i++) { put_lineno(); fprintf(out, "\tif (narg > %d) {\n", nreq+i, optional[i].o_var); put_lineno(); - fprintf(out, "\t\t%s = va_arg(%s, cl_object);\n", + fprintf(out, "\t\t%s = cl_va_arg(%s);\n", optional[i].o_var, rest_var); if (optional[i].o_svar) { put_lineno(); @@ -640,8 +641,8 @@ put_declaration(void) } if (key_flag) { put_lineno(); - fprintf(out, "\tva_parse_key(narg-%d, ARGS, %d, KEYS, KEY_VARS, NULL, %d);\n", - nreq+nopt, nkey, allow_other_keys_flag); + fprintf(out, "\tcl_parse_key(ARGS, %d, KEYS, KEY_VARS, NULL, %d);\n", + nkey, allow_other_keys_flag); for (i = 0; i < nkey; i++) { put_lineno(); fprintf(out, "\tif (KEY_VARS[%d]==Cnil) {\n", nkey+i); diff --git a/src/c/error.d b/src/c/error.d index caa7144fd..537bbc6c6 100644 --- a/src/c/error.d +++ b/src/c/error.d @@ -68,25 +68,23 @@ terminal_interrupt(bool correctable) void FEerror(char *s, int narg, ...) { - va_list args; - va_start(args, narg); + cl_va_list args; + cl_va_start(args, narg, narg, 0); funcall(4, @'si::universal-error-handler', Cnil, /* not correctable */ make_constant_string(s), /* condition text */ - va_grab_rest_args(narg, args)); - va_end(args); + cl_grab_rest_args(args)); } cl_object CEerror(char *err, int narg, ...) { - va_list args; - va_start(args, narg); + cl_va_list args; + cl_va_start(args, narg, narg, 0); return funcall(4, @'si::universal-error-handler', Ct, /* correctable */ make_constant_string(err), /* continue-format-string */ - va_grab_rest_args(narg, args)); - va_end(args); + cl_grab_rest_args(args)); } /*********************** @@ -96,40 +94,37 @@ CEerror(char *err, int narg, ...) void FEcondition(int narg, cl_object name, ...) { - va_list args; - va_start(args, name); + cl_va_list args; + cl_va_start(args, name, narg, 1); funcall(4, @'si::universal-error-handler', Cnil, /* not correctable */ name, /* condition name */ - va_grab_rest_args(--narg, args)); - va_end(args); + cl_grab_rest_args(args)); } void FEprogram_error(const char *s, int narg, ...) { - va_list args; + cl_va_list args; gc(t_contiguous); - va_start(args, narg); + cl_va_start(args, narg, narg, 0); funcall(4, @'si::universal-error-handler', Cnil, /* not correctable */ @'si::simple-program-error', /* condition name */ list(4, @':format-control', make_constant_string(s), - @':format-arguments', va_grab_rest_args(narg, args))); - va_end(args); + @':format-arguments', cl_grab_rest_args(args))); } void FEcontrol_error(const char *s, int narg, ...) { - va_list args; - va_start(args, narg); + cl_va_list args; + cl_va_start(args, narg, narg, 0); funcall(4, @'si::universal-error-handler', Cnil, /* not correctable */ @'si::simple-control-error', /* condition name */ list(4, @':format-control', make_constant_string(s), - @':format-arguments', va_grab_rest_args(narg, args))); - va_end(args); + @':format-arguments', cl_grab_rest_args(args))); } void @@ -167,19 +162,19 @@ FEundefined_function(cl_object fname) *************/ void -FEtoo_few_arguments(int *nargp) +FEtoo_few_arguments(int narg) { cl_object fname = ihs_top_function_name(); FEprogram_error("Function ~S requires more than ~R argument~:p.", - 2, fname, MAKE_FIXNUM(*nargp)); + 2, fname, MAKE_FIXNUM(narg)); } void -FEtoo_many_arguments(int *nargp) +FEtoo_many_arguments(int narg) { cl_object fname = ihs_top_function_name(); FEprogram_error("Function ~S requires less than ~R argument~:p.", - 2, fname, MAKE_FIXNUM(*nargp)); + 2, fname, MAKE_FIXNUM(narg)); } void @@ -252,7 +247,7 @@ not_a_variable(cl_object obj) funcall(4, @'si::universal-error-handler', Cnil, eformat, - va_grab_rest_args(narg-1, args)); + cl_grab_rest_args(args)); @) @(defun cerror (cformat eformat &rest args) @@ -260,7 +255,7 @@ not_a_variable(cl_object obj) return(funcall(4, @'si::universal-error-handler', cformat, eformat, - va_grab_rest_args(narg-2, args))); + cl_grab_rest_args(args))); @) void diff --git a/src/c/eval.d b/src/c/eval.d index 7b0d9415d..b3fd905a0 100644 --- a/src/c/eval.d +++ b/src/c/eval.d @@ -27,6 +27,31 @@ otherwise, it emulates funcall. */ +void +cl__va_start(cl_va_list args, int narg_before) +{ + if (args[0].narg > C_ARGUMENTS_LIMIT) { + args[0].sp = cl_stack_index() - args[0].narg; + } else { + args[0].sp = 0; + } + if (args[0].narg < narg_before) + FEtoo_few_arguments(args[0].narg); + args[0].narg -= narg_before; +} + +cl_object +cl_va_arg(cl_va_list args) +{ + if (args[0].narg <= 0) + FEerror("Too few arguments", 0); + args[0].narg--; + if (args[0].sp) + return cl_stack[args[0].sp++]; + return va_arg(args[0].args, cl_object); +} + + /* *---------------------------------------------------------------------- * @@ -42,18 +67,18 @@ *---------------------------------------------------------------------- */ cl_object -apply(int narg, cl_object fun, cl_object *args) +cl_apply_from_stack(cl_index narg, cl_object fun) { AGAIN: switch (type_of(fun)) { case t_cfun: - return APPLY(narg, fun->cfun.entry, args); + return APPLY(narg, fun->cfun.entry, cl_stack_top - narg); case t_cclosure: - return APPLY_closure(narg, fun->cclosure.entry, fun->cclosure.env, - args); + return APPLY_closure(narg, fun->cclosure.entry, + fun->cclosure.env, cl_stack_top - narg); #ifdef CLOS case t_gfun: - fun = compute_method(narg, fun, args); + fun = compute_method(narg, fun, cl_stack_top - narg); goto AGAIN; #endif case t_symbol: { @@ -64,7 +89,7 @@ apply(int narg, cl_object fun, cl_object *args) goto AGAIN; } case t_bytecodes: - return lambda_apply(narg, fun, args); + return lambda_apply(narg, fun); } FEinvalid_function(fun); } @@ -74,11 +99,17 @@ apply(int narg, cl_object fun, cl_object *args) *----------------------------------------------------------------------*/ cl_object -link_call(cl_object sym, cl_objectfn *pLK, int narg, va_list args) +link_call(cl_object sym, cl_objectfn *pLK, int narg, cl_va_list args) { - cl_object fun = symbol_function(sym); + cl_index sp; + cl_object out, fun = symbol_function(sym); - if (fun == OBJNULL) FEerror("Undefined function.", 0); + if (fun == OBJNULL) + FEerror("Undefined function.", 0); + if (args[0].sp) + sp = args[0].sp; + else + sp = cl_stack_push_va_list(args); AGAIN: switch (type_of(fun)) { case t_cfun: @@ -89,26 +120,28 @@ link_call(cl_object sym, cl_objectfn *pLK, int narg, va_list args) @'si::link-from'); *pLK = fun->cfun.entry; } - return va_APPLY(narg, fun->cfun.entry, args); + out = APPLY(narg, fun->cfun.entry, cl_stack + sp); + break; #ifdef CLOS -#ifndef va_copy -#define va_copy(x) (x) -#endif case t_gfun: { - va_list aux = va_copy(args); - fun = va_compute_method(narg, fun, aux); + fun = compute_method(narg, fun, cl_stack + sp); pLK = NULL; goto AGAIN; } #endif /* CLOS */ case t_cclosure: - return va_APPLY_closure(narg, fun->cclosure.entry, - fun->cclosure.env, args); + out = APPLY_closure(narg, fun->cclosure.entry, + fun->cclosure.env, cl_stack + sp); + break; case t_bytecodes: - return va_lambda_apply(narg, fun, args); + out = lambda_apply(narg, fun); + break; default: FEinvalid_function(fun); } + if (!args[0].sp) + cl_stack_set_index(sp); + return out; } @(defun si::unlink_symbol (s) @@ -126,21 +159,27 @@ link_call(cl_object sym, cl_objectfn *pLK, int narg, va_list args) @) @(defun funcall (function &rest funargs) - cl_object fun = function, x; + cl_index sp; + cl_object fun = function, out; @ + narg--; + if (funargs[0].sp) + sp = funargs[0].sp; + else + sp = cl_stack_push_va_list(funargs); AGAIN: switch (type_of(fun)) { case t_cfun: - return va_APPLY(narg-1, fun->cfun.entry, funargs); + out = APPLY(narg, fun->cfun.entry, cl_stack + sp); + break; case t_cclosure: - return va_APPLY_closure(narg-1, fun->cclosure.entry, - fun->cclosure.env, funargs); + out = APPLY_closure(narg, fun->cclosure.entry, + fun->cclosure.env, cl_stack + sp); + break; #ifdef CLOS - case t_gfun: { - va_list aux = va_copy(funargs); - fun = va_compute_method(narg-1, fun, aux); + case t_gfun: + fun = compute_method(narg, fun, cl_stack + sp); goto AGAIN; - } #endif case t_symbol: fun = SYM_FUN(fun); @@ -148,9 +187,14 @@ link_call(cl_object sym, cl_objectfn *pLK, int narg, va_list args) FEundefined_function(function); goto AGAIN; case t_bytecodes: - return va_lambda_apply(narg-1, fun, funargs); + out = lambda_apply(narg, fun); + break; + default: + FEinvalid_function(fun); } - FEinvalid_function(fun); + if (!funargs[0].sp) + cl_stack_set_index(sp); + return out; @) @(defun eval (form) @@ -209,5 +253,5 @@ void init_eval(void) { SYM_VAL(@'si::*ignore-errors*') = Cnil; - SYM_VAL(@'call-arguments-limit') = MAKE_FIXNUM(64); + SYM_VAL(@'call-arguments-limit') = MAKE_FIXNUM(CALL_ARGUMENTS_LIMIT); } diff --git a/src/c/file.d b/src/c/file.d index 5eb832e0a..45ad56b97 100644 --- a/src/c/file.d +++ b/src/c/file.d @@ -1311,7 +1311,7 @@ BEGIN: @ streams = Cnil; for (i = 0; i < narg; i++) { - x = cl_nextarg(ap); + x = cl_va_arg(ap); if (type_of(x) != t_stream || !output_stream_p(x)) cannot_write(x); streams = CONS(x, streams); @@ -1331,7 +1331,7 @@ BEGIN: @ streams = Cnil; for (i = 0; i < narg; i++) { - x = cl_nextarg(ap); + x = cl_va_arg(ap); if (type_of(x) != t_stream || !input_stream_p(x)) cannot_read(x); streams = CONS(x, streams); diff --git a/src/c/format.d b/src/c/format.d index 194078e96..a82012f7a 100644 --- a/src/c/format.d +++ b/src/c/format.d @@ -1789,7 +1789,7 @@ fmt_semicolon(format_stack fmt, bool colon, bool atsign) fmt.stream = strm; fmt.base = cl_stack_index(); for (narg -= 2; narg; narg--) - cl_stack_push(cl_nextarg(args)); + cl_stack_push(cl_va_arg(args)); fmt.index = fmt.base; fmt.end = cl_stack_index(); fmt.jmp_buf = &fmt_jmp_buf0; diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 20b462407..0c9ea888f 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -95,7 +95,6 @@ cl_stack_insert(cl_index where, cl_index n) { (cl_stack_top - cl_stack) * sizeof(*cl_stack)); } - void cl_stack_pop_n(cl_index index) { cl_object *new_top = cl_stack_top - index; @@ -104,6 +103,58 @@ cl_stack_pop_n(cl_index index) { cl_stack_top = new_top; } +int +cl_stack_push_values(void) { + int i; + for (i=0; i 0) + VALUES(--n) = cl_stack_pop(); +} + +cl_index +cl_stack_push_va_list(cl_va_list args) { + cl_index sp; + + sp = cl_stack_top - cl_stack; + while (cl_stack_top + args[0].narg > cl_stack_limit) + cl_stack_grow(); + while (args[0].narg > 0) { + args[0].narg--; + *(cl_stack_top++) = va_arg(args[0].args,cl_object); + } + return sp; +} + +cl_index +cl_stack_push_list(cl_object list) +{ + cl_index n; + cl_object fast, slow; + + /* INV: A list's length always fits in a fixnum */ + fast = slow = list; + for (n = 0; CONSP(fast); n++, fast = CDR(fast)) { + *cl_stack_top = CAR(fast); + if (++cl_stack_top >= cl_stack_limit) + cl_stack_grow(); + if (n & 1) { + /* Circular list? */ + if (slow == fast) break; + slow = CDR(slow); + } + } + if (fast != Cnil) + FEtype_error_proper_list(list); + return n; +} + /* ------------------------------ LEXICAL ENV. ------------------------------ */ cl_object lex_env; @@ -185,7 +236,7 @@ lambda_bind_var(cl_object var, cl_object val, cl_object specials) } static cl_object * -lambda_bind(int narg, cl_object lambda_list, cl_object *args) +lambda_bind(int narg, cl_object lambda_list, cl_index sp) { cl_object *data = &lambda_list->bytecodes.data[2]; cl_object specials = lambda_list->bytecodes.data[1]; @@ -200,13 +251,13 @@ lambda_bind(int narg, cl_object lambda_list, cl_object *args) if (narg < n) check_arg_failed(narg, n); for (; n; n--, narg--) - lambda_bind_var(next_code(data), next_code(args), specials); + lambda_bind_var(next_code(data), cl_stack[sp++], specials); /* 2) OPTIONAL ARGUMENTS: N var1 value1 flag1 ... varN valueN flagN */ for (n = fix(next_code(data)); n; n--, data+=3) { if (narg) { - lambda_bind_var(data[0], args[0], specials); - args++; narg--; + lambda_bind_var(data[0], cl_stack[sp], specials); + sp++; narg--; if (!Null(data[2])) lambda_bind_var(data[2], Ct, specials); } else { @@ -226,7 +277,7 @@ lambda_bind(int narg, cl_object lambda_list, cl_object *args) cl_object rest = Cnil; check_remaining = FALSE; for (i=narg; i; ) - rest = CONS(args[--i], rest); + rest = CONS(cl_stack[sp+(--i)], rest); lambda_bind_var(data[0], rest, specials); } data++; @@ -242,22 +293,24 @@ lambda_bind(int narg, cl_object lambda_list, cl_object *args) bool other_found = FALSE; for (i=0; i= CALL_ARGUMENTS_LIMIT) { @@ -572,10 +585,9 @@ interpret_unwind_protect(cl_object *vector) { unwinding = FALSE; } frs_pop(); - nr = NValues; - MV_SAVE(nr); + nr = cl_stack_push_values(); exit = interpret(exit); - MV_RESTORE(nr); + cl_stack_pop_values(nr); if (unwinding) unwind(nlj_fr, nlj_tag); return exit; diff --git a/src/c/list.d b/src/c/list.d index daafe16d0..1f4398700 100644 --- a/src/c/list.d +++ b/src/c/list.d @@ -114,14 +114,14 @@ setupTEST(cl_object item, cl_object test, cl_object test_not, cl_object key) cl_return f ## _if(int narg, cl_object pred, cl_object arg, cl_object key, cl_object val) \ { \ if (narg < 2) \ - FEtoo_few_arguments(&narg); \ + FEtoo_few_arguments(narg); \ return f(narg+2, pred, arg, @':test', @'funcall', key, val); \ } \ \ cl_return f ## _if_not(int narg, cl_object pred, cl_object arg, cl_object key, cl_object val) \ { \ if (narg < 2) \ - FEtoo_few_arguments(&narg); \ + FEtoo_few_arguments(narg); \ return f(narg+2, pred, arg, @':test-not', @'funcall', key, val); \ } @@ -129,7 +129,7 @@ cl_return f ## _if_not(int narg, cl_object pred, cl_object arg, cl_object key, c cl_return f ## _if(int narg, cl_object arg1, cl_object pred, cl_object arg3, cl_object key, cl_object val) \ { \ if (narg < 3) \ - FEtoo_few_arguments(&narg); \ + FEtoo_few_arguments(narg); \ return f(narg+2, arg1, pred, arg3, @':test', @'funcall', key, val); \ } \ \ @@ -137,7 +137,7 @@ cl_return f ## _if_not(int narg, cl_object arg1, cl_object pred, cl_object arg3, cl_object val) \ { \ if (narg < 3) \ - FEtoo_few_arguments(&narg); \ + FEtoo_few_arguments(narg); \ return f(narg+2, arg1, pred, arg3, @':test-not', @'funcall', key, val); \ } @@ -183,9 +183,9 @@ cdr(cl_object x) cl_object list = Cnil, z; @ if (narg-- != 0) { - list = z = CONS(va_arg(args, cl_object), Cnil); + list = z = CONS(cl_va_arg(args), Cnil); while (narg-- > 0) - z = CDR(z) = CONS(va_arg(args, cl_object), Cnil); + z = CDR(z) = CONS(cl_va_arg(args), Cnil); } @(return list) @) @@ -206,10 +206,10 @@ list(int narg, ...) cl_object p = Cnil, *z=&p; @ if (narg == 0) - FEtoo_few_arguments(&narg); + FEtoo_few_arguments(narg); while (--narg > 0) - z = &CDR( *z = CONS(cl_nextarg(args), Cnil)); - *z = va_arg(args, cl_object); + z = &CDR( *z = CONS(cl_va_arg(args), Cnil)); + *z = cl_va_arg(args); @(return p) @) @@ -221,7 +221,7 @@ listX(int narg, ...) va_start(args, narg); while (--narg > 0) - z = &CDR( *z = CONS(cl_nextarg(args), Cnil)); + z = &CDR( *z = CONS(va_arg(args,cl_object), Cnil)); *z = va_arg(args, cl_object); return(p); } @@ -246,8 +246,8 @@ copy_list_to(cl_object x, cl_object **z) else { lastcdr = &x; while (narg-- > 1) - copy_list_to(cl_nextarg(rest), &lastcdr); - *lastcdr = cl_nextarg(rest); + copy_list_to(cl_va_arg(rest), &lastcdr); + *lastcdr = cl_va_arg(rest); } @(return x) @) @@ -562,12 +562,12 @@ copy_tree(cl_object x) @(return Cnil) lastcdr = &x; while (narg-- > 1) { - *lastcdr = l = va_arg(lists, cl_object); + *lastcdr = l = cl_va_arg(lists); loop_for_on(l) { lastcdr = &CDR(l); } end_loop_for_on; } - *lastcdr = va_arg(lists, cl_object); + *lastcdr = cl_va_arg(lists); @(return x) @) @@ -894,7 +894,7 @@ cl_return cl_object output; if (narg < 2) - FEtoo_few_arguments(&narg); + FEtoo_few_arguments(narg); output = @si::member1(narg, item, list, k1, v1, k2, v2, k3, v3); if (Null(output)) output = CONS(item, list); diff --git a/src/c/lwp.d b/src/c/lwp.d index f0faff301..7745a03d7 100644 --- a/src/c/lwp.d +++ b/src/c/lwp.d @@ -687,7 +687,7 @@ resume(pd *rpd) thread_Values = cont->cn.cn_thread->thread.data->pd_lpd->lwp_Values; for (i = 1; i < narg; i++) - *(thread_Values++) = cl_nextarg(args); + *(thread_Values++) = va_arg(args, cl_object); cont->cn.cn_thread->thread.data->pd_lpd->lwp_nValues = narg-1; cont->cn.cn_resumed = TRUE; @@ -774,7 +774,7 @@ enable_scheduler() end_critical_section(); for (;;) { - if (apply(narg-1, fun, &cl_nextarg(args)) != Cnil) + if (apply(narg-1, fun, &va_arg(args, cl_object)) != Cnil) break; else if (timer_active) { /* the time slice has not been used */ @@ -808,7 +808,7 @@ enable_scheduler() break; } - if (apply(narg-1, fun, cl_nextarg(&args)) != Cnil) + if (apply(narg-1, fun, va_arg(&args, cl_object)) != Cnil) break; else { /* the time slice has not been used */ diff --git a/src/c/mapfun.d b/src/c/mapfun.d index c2f288fec..99952b8c1 100644 --- a/src/c/mapfun.d +++ b/src/c/mapfun.d @@ -16,129 +16,148 @@ #include "ecl.h" -@(defun mapcar (fun onelist &rest lists) +static cl_index +prepare_map(cl_va_list lists, cl_index *cdrs_sp) +{ + cl_index i, nlist = lists[0].narg; + + *cdrs_sp = cl_stack_index(); + if (nlist == 0) + FEerror("MAP*: Too few arguments.", 0); + cl_stack_push_va_list(lists); + for (i = 0; i 1) { - cl_object numi = cl_nextarg(nums); + cl_object numi = cl_va_arg(nums); cl_object t = number_times(lcm, numi); cl_object g = get_gcd(numi, lcm); lcm = number_divide(t, g); diff --git a/src/c/num_comp.d b/src/c/num_comp.d index f8057abab..9221f5231 100644 --- a/src/c/num_comp.d +++ b/src/c/num_comp.d @@ -22,7 +22,7 @@ /* ANSI: Need not signal error for 1 argument */ /* INV: For >= 2 arguments, number_equalp() performs checks */ for (i = 1; i < narg; i++) - if (!number_equalp(num, cl_nextarg(nums))) + if (!number_equalp(num, cl_va_arg(nums))) @(return Cnil) @(return Ct) @) @@ -253,29 +253,29 @@ number_compare(cl_object x, cl_object y) int i, j; @ if (narg == 0) - FEtoo_few_arguments(&narg); - numi = cl_nextarg(nums); + FEtoo_few_arguments(narg); + numi = cl_va_arg(nums); for (i = 2; i<=narg; i++) { - va_list numb; - va_start(numb, narg); - numi = cl_nextarg(nums); + cl_va_list numb; + cl_va_start(numb, narg, narg, 0); + numi = cl_va_arg(nums); for (j = 1; j MONOTONIC(-1, 1) @ /* INV: type check occurs in number_compare() */ while (--narg) { - cl_object numi = cl_nextarg(nums); + cl_object numi = cl_va_arg(nums); if (number_compare(max, numi) < 0) max = numi; } @@ -306,7 +306,7 @@ cl_object @> MONOTONIC(-1, 1) @ /* INV: type check occurs in number_compare() */ while (--narg) { - cl_object numi = va_arg(nums, cl_object); + cl_object numi = cl_va_arg(nums); if (number_compare(min, numi) > 0) min = numi; } diff --git a/src/c/num_log.d b/src/c/num_log.d index bf22d57c6..5aa2c0146 100644 --- a/src/c/num_log.d +++ b/src/c/num_log.d @@ -45,14 +45,14 @@ typedef cl_fixnum (*bit_operator)(cl_fixnum, cl_fixnum); static cl_object big_log_op(cl_object x, cl_object y, bit_operator op); static cl_object -log_op(int narg, bit_operator op, va_list ARGS) +log_op(int narg, bit_operator op, cl_va_list ARGS) { cl_type t; cl_object x, numi; int i = 1, j; - if (narg < 2) FEtoo_few_arguments(&narg); - x = cl_nextarg(ARGS); + if (narg < 2) FEtoo_few_arguments(narg); + x = cl_va_arg(ARGS); t = type_of(x); if (t == t_bignum) { x = big_copy(x); /* since big_log_op clobbers it */ @@ -62,7 +62,7 @@ log_op(int narg, bit_operator op, va_list ARGS) } j = fix(x); for (; i < narg; i++) { - numi = cl_nextarg(ARGS); + numi = cl_va_arg(ARGS); t = type_of(numi); if (t == t_bignum) { x = big_log_op(bignum1(j), numi, op); @@ -77,7 +77,7 @@ log_op(int narg, bit_operator op, va_list ARGS) BIG_OP: for (; i < narg; i++) - x = big_log_op(x, cl_nextarg(ARGS), op); + x = big_log_op(x, cl_va_arg(ARGS), op); return(big_normalize(x)); } diff --git a/src/c/string.d b/src/c/string.d index c7812c0a2..8436b38f8 100644 --- a/src/c/string.d +++ b/src/c/string.d @@ -296,10 +296,10 @@ string_equal(cl_object x, cl_object y) } static cl_return -string_cmp(int narg, int sign, int boundary, va_list ARGS) +string_cmp(int narg, int sign, int boundary, cl_va_list ARGS) { - cl_object string1 = cl_nextarg(ARGS); - cl_object string2 = cl_nextarg(ARGS); + cl_object string1 = cl_va_arg(ARGS); + cl_object string2 = cl_va_arg(ARGS); cl_index s1, e1, s2, e2; int s, i1, i2; cl_object KEYS[4]; @@ -311,12 +311,12 @@ string_cmp(int narg, int sign, int boundary, va_list ARGS) #define start2p KEY_VARS[6] cl_object KEY_VARS[8]; - if (narg < 2) FEtoo_few_arguments(&narg); + if (narg < 2) FEtoo_few_arguments(narg); KEYS[0]=@':start1'; KEYS[1]=@':end1'; KEYS[2]=@':start2'; KEYS[3]=@':end2'; - va_parse_key(narg-2, ARGS, 4, KEYS, KEY_VARS, NULL, FALSE); + cl_parse_key(ARGS, 4, KEYS, KEY_VARS, NULL, FALSE); string1 = coerce_to_string_designator(string1); string2 = coerce_to_string_designator(string2); @@ -380,10 +380,10 @@ string_cmp(int narg, int sign, int boundary, va_list ARGS) @) static cl_return -string_compare(int narg, int sign, int boundary, va_list ARGS) +string_compare(int narg, int sign, int boundary, cl_va_list ARGS) { - cl_object string1 = cl_nextarg(ARGS); - cl_object string2 = cl_nextarg(ARGS); + cl_object string1 = cl_va_arg(ARGS); + cl_object string2 = cl_va_arg(ARGS); cl_index s1, e1, s2, e2; int i1, i2, s; @@ -396,12 +396,12 @@ string_compare(int narg, int sign, int boundary, va_list ARGS) #define start2p KEY_VARS[6] cl_object KEY_VARS[8]; - if (narg < 2) FEtoo_few_arguments(&narg); + if (narg < 2) FEtoo_few_arguments(narg); KEYS[0]=@':start1'; KEYS[1]=@':end1'; KEYS[2]=@':start2'; KEYS[3]=@':end2'; - va_parse_key(narg-2, ARGS, 4, KEYS, KEY_VARS, NULL, FALSE); + cl_parse_key(ARGS, 4, KEYS, KEY_VARS, NULL, FALSE); string1 = coerce_to_string_designator(string1); string2 = coerce_to_string_designator(string2); @@ -544,9 +544,9 @@ cl_return static cl_return -string_case(int narg, int (*casefun)(int c, bool *bp), va_list ARGS) +string_case(int narg, int (*casefun)(int c, bool *bp), cl_va_list ARGS) { - cl_object strng = cl_nextarg(ARGS); + cl_object strng = cl_va_arg(ARGS); cl_index s, e, i; bool b; cl_object KEYS[2]; @@ -556,10 +556,10 @@ string_case(int narg, int (*casefun)(int c, bool *bp), va_list ARGS) cl_object conv; cl_object KEY_VARS[4]; - if (narg < 1) FEtoo_few_arguments(&narg); + if (narg < 1) FEtoo_few_arguments(narg); KEYS[0]=@':start'; KEYS[1]=@':end'; - va_parse_key(narg-1, ARGS, 2, KEYS, KEY_VARS, NULL, FALSE); + cl_parse_key(ARGS, 2, KEYS, KEY_VARS, NULL, FALSE); strng = coerce_to_string_designator(strng); conv = copy_simple_string(strng); @@ -619,9 +619,9 @@ char_capitalize(int c, bool *bp) static cl_return -nstring_case(int narg, int (*casefun)(int, bool *), va_list ARGS) +nstring_case(int narg, int (*casefun)(int, bool *), cl_va_list ARGS) { - cl_object strng = cl_nextarg(ARGS); + cl_object strng = cl_va_arg(ARGS); cl_index s, e, i; bool b; cl_object KEYS[2]; @@ -630,10 +630,10 @@ nstring_case(int narg, int (*casefun)(int, bool *), va_list ARGS) #define startp KEY_VARS[2] cl_object KEY_VARS[4]; - if (narg < 1) FEtoo_few_arguments(&narg); + if (narg < 1) FEtoo_few_arguments(narg); KEYS[0]=@':start'; KEYS[1]=@':end'; - va_parse_key(narg-1, ARGS, 2, KEYS, KEY_VARS, NULL, FALSE); + cl_parse_key(ARGS, 2, KEYS, KEY_VARS, NULL, FALSE); assert_type_string(strng); if (startp == Cnil) start = MAKE_FIXNUM(0); @@ -675,7 +675,7 @@ nstring_case(int narg, int (*casefun)(int, bool *), va_list ARGS) char *vself; @ for (i = 0, l = 0; i < narg; i++) { - strings[i] = coerce_to_string_designator(cl_nextarg(args)); + strings[i] = coerce_to_string_designator(cl_va_arg(args)); l += strings[i]->string.fillp; } v = cl_alloc_simple_string(l); diff --git a/src/c/structure.d b/src/c/structure.d index 221432a47..9475b99cb 100644 --- a/src/c/structure.d +++ b/src/c/structure.d @@ -87,7 +87,7 @@ structure_to_list(cl_object x) SLENGTH(x) = --narg; SLOTS(x) = (cl_object *)cl_alloc_align(sizeof(cl_object)*narg, sizeof(cl_object)); for (i = 0; i < narg; i++) - SLOT(x, i) = va_arg(args, cl_object); + SLOT(x, i) = cl_va_arg(args); @(return x) @) diff --git a/src/c/symbol.d b/src/c/symbol.d index c1cd4ba89..36a6cc48f 100644 --- a/src/c/symbol.d +++ b/src/c/symbol.d @@ -461,8 +461,8 @@ ONCE_MORE: cl_object prop; @ while (--narg >= 2) { - prop = va_arg(ind_values, cl_object); - putprop(sym, va_arg(ind_values, cl_object), prop); + prop = cl_va_arg(ind_values); + putprop(sym, cl_va_arg(ind_values), prop); narg--; } @(return sym) diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 672ab8e8f..71955fe0c 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -937,6 +937,7 @@ cl_symbols[] = { {"SI::BDS-VAL", SI_ORDINARY, NULL, siLbds_val}, {"SI::BDS-VAR", SI_ORDINARY, NULL, siLbds_var}, {"SI::BIT-ARRAY-OP", SI_ORDINARY, NULL, siLbit_array_op}, +{"SI::C-ARGUMENTS-LIMIT", SI_ORDINARY, NULL, NULL}, {"SI::CHAR-SET", SI_ORDINARY, NULL, siLchar_set}, {"SI::CHDIR", SI_ORDINARY, NULL, siLchdir}, {"SI::CLEAR-COMPILER-PROPERTIES", SI_ORDINARY, &siSclear_compiler_properties, siLclear_compiler_properties}, diff --git a/src/c/time.d b/src/c/time.d index 09c6db874..cf203d2da 100644 --- a/src/c/time.d +++ b/src/c/time.d @@ -123,17 +123,14 @@ UTC_time_to_universal_time(int i) * defaults to current time. * */ -@(defun si::daylight-saving-time-p (&rest args) +@(defun si::daylight-saving-time-p (&optional UT) struct tm *ltm; time_t when; @ if (narg == 0) when = time(0); - else if (narg == 1) { - cl_object UT, UTC; - va_start(args, narg); - UT = va_arg(args, cl_object); - UTC = number_minus(UT, Jan1st1970UT); + else { /* narg == 1 */ + cl_object UTC = number_minus(UT, Jan1st1970UT); switch (type_of(UTC)) { case t_fixnum: when = fix(UTC); @@ -145,8 +142,6 @@ UTC_time_to_universal_time(int i) FEerror("Universal Time out of range: ~A.", 1, UT); } } - else - FEtoo_many_arguments(&narg); ltm = localtime(&when); @(return (ltm->tm_isdst ? Ct : Cnil)) @) diff --git a/src/c/unixfsys.d b/src/c/unixfsys.d index 4dd296d64..0da778ccd 100644 --- a/src/c/unixfsys.d +++ b/src/c/unixfsys.d @@ -43,13 +43,12 @@ void FEfilesystem_error(const char *msg, int narg, ...) { - va_list args; + cl_va_list args; cl_object rest; const char *extra_msg; - va_start(args, narg); - rest = va_grab_rest_args(narg, args); - va_end(args); + cl_va_start(args, narg, narg, 0); + rest = cl_grab_rest_args(args); switch (errno) { case EPERM: diff --git a/src/cmp/cmpbind.lsp b/src/cmp/cmpbind.lsp index 67e418dd3..bc124767b 100644 --- a/src/cmp/cmpbind.lsp +++ b/src/cmp/cmpbind.lsp @@ -18,7 +18,7 @@ ;;; bind takes care of setting var-loc. (defun bind (loc var) - ;; loc can be either (LCL n), (VA-ARGS kind), (KEYVARS n), (CAR n), + ;; loc can be either (LCL n), 'VA-ARGS, (KEYVARS n), (CAR n), ;; a constant, or (VAR var) from a let binding. ; ccb (declare (type var var)) (case (var-kind var) diff --git a/src/cmp/cmpcall.lsp b/src/cmp/cmpcall.lsp index 6a2168496..10d20442f 100644 --- a/src/cmp/cmpcall.lsp +++ b/src/cmp/cmpcall.lsp @@ -122,13 +122,13 @@ args-pushed ;;; Args already pushed? ) (let* ((requireds (first lambda-list)) - (nreq (length requireds))) - (unless args-pushed (setq narg (length args))) + (nreq (length requireds)) + (nopt (if args-pushed narg (- (length args) nreq))) + (*unwind-exit* *unwind-exit*)) (wt-nl "{ ") - ;; In reverse order, since stack grows downward: - (if args-pushed - (wt-nl "cl_object *args = &VALUES(" nreq ");") - (wt-nl "cl_object args[" (- narg nreq) "];")) + (unless args-pushed + (setq narg `(LCL ,(next-lcl))) + (wt-nl "cl_index " narg "=0;")) (when requireds (wt-nl "cl_object ") (let ((lcl (+ *lcl* nreq))) @@ -137,29 +137,56 @@ ((null args)) (wt-lcl lcl) (when (cdr args) (wt ", ")) (decf lcl))) (wt ";")) - (wt-nl "int narg = ") - (wt (if args-pushed ;;; Args already pushed? - narg - (length args)) ";") - (if args-pushed - (dotimes (i nreq) - (wt-nl) (wt-lcl (next-lcl)) (wt "=VALUES(" i ");")) - (progn - (dotimes (i nreq) - (let ((*destination* `(LCL ,(next-lcl)))) - (c2expr* (pop args)))) - (do* ((*inline-blocks* 0) - (vals (inline-args args) (cdr vals)) - (i 0 (1+ i))) + (wt-nl "int narg;") + (wt-nl "cl_va_list args;") + (cond (args-pushed + (wt-nl "args[0].sp=cl_stack_index()-" narg ";") + (wt-nl "args[0].narg=" narg ";") + (dotimes (i nreq) + (wt-nl) (wt-lcl (next-lcl)) (wt "=cl_va_arg(args);"))) + (t + (dotimes (i nreq) + (let ((*destination* `(LCL ,(next-lcl)))) + (c2expr* (pop args)))) + (push (list STACK narg) *unwind-exit*) + (wt-nl "args[0].sp=cl_stack_index();") + (wt-nl "args[0].narg=" nopt ";") + (do* ((*inline-blocks* 0) + (vals (inline-args args) (cdr vals)) + (i 0 (1+ i))) ((null vals) (close-inline-blocks)) - (declare (fixnum i)) - (wt-nl "args[" i "]=" (second (first vals)) ";")) - (wt-nl "narg = " (- narg nreq) ";"))) + (declare (fixnum i)) + (wt-nl "cl_stack_push(" (second (first vals)) ");") + (wt-nl narg "++;")) + (wt-nl "args[0].narg=" narg ";"))) + (wt "narg=" narg ";") (c2lambda-expr lambda-list (third (cddr lambda-expr)) cfun nil nil 'CALL-LAMBDA) + (unless args-pushed + (wt-nl "cl_stack_pop_n(" narg ");")) (wt-nl "}")) (c2let (first lambda-list) args (third (cddr lambda-expr)))))) +(defun maybe-push-args (args) + (when (or (eq args 'ARGS-PUSHED) + (< (length args) SI::C-ARGUMENTS-LIMIT)) + (return-from maybe-push-args (values nil nil nil))) + (let* ((temp *temp*) ; allow reuse of TEMP variables + (*temp* temp) + (arg (list 'TEMP 0)) + (narg `(LCL ,(next-lcl)))) + (wt-nl "{cl_index " narg ";") + (let ((*destination* arg)) + (dolist (expr args) + (setf (second arg) (next-temp)) + (c2expr* expr))) + (setf (second arg) temp) ; restart numbering + (dotimes (i (length args)) + (wt-nl "cl_stack_push(" arg ");") + (incf (second arg))) + (wt-nl narg "=" (length args) ";") + (values `((STACK ,narg) ,@*unwind-exit*) 'ARGS-PUSHED narg))) + ;;; ;;; c2call-global: ;;; ARGS is either the list of arguments or 'ARGS-PUSHED @@ -167,6 +194,12 @@ ;;; LOC is either NIL or the location of the function object ;;; (defun c2call-global (fname args loc return-type &optional narg) + (multiple-value-bind (*unwind-exit* args narg) + (maybe-push-args args) + (when narg + (c2call-global fname args loc return-type narg) + (wt-nl "}") + (return-from c2call-global))) (unless (eq 'ARGS-PUSHED args) (case fname (AREF @@ -312,12 +345,16 @@ ;;; args are typed locations as produced by inline-args ;;; (defun call-loc (fname fun args &optional narg-loc) - (if (eq 'ARGS-PUSHED args) - (list 'CALL (if (stringp fun) - "APPLY" ; call to a C function - "apply") ; call to a Lisp function - narg-loc (list fun "&VALUES(0)") fname) - (list 'CALL fun (length args) (coerce-locs args nil) fname))) + (cond ((not (eq 'ARGS-PUSHED args)) + (list 'CALL fun (length args) (coerce-locs args nil) fname)) + ((stringp fun) + (list 'CALL "APPLY" narg-loc (list fun `(STACK-POINTER ,narg-loc)) + fname)) + (t + (list 'CALL "cl_apply_from_stack" narg-loc (list fun) fname)))) + +(defun wt-stack-pointer (narg) + (wt "cl_stack_top-" narg)) (defun wt-call (fun narg args &optional fname) (wt fun "(" narg) @@ -342,7 +379,7 @@ (add-symbol fname))))) (unwind-exit (if (eq args 'ARGS-PUSHED) - (list 'CALL "apply" narg (list loc "&VALUES(0)") fname) + (list 'CALL "cl_apply_from_stack" narg (list loc) fname) (call-loc fname "funcall" (cons (list T loc) args))))) ;;; ---------------------------------------------------------------------- @@ -353,3 +390,4 @@ (setf (get 'call-global 'c2) #'c2call-global) (setf (get 'CALL 'WT-LOC) #'wt-call) +(setf (get 'STACK-POINTER 'WT-LOC) #'wt-stack-pointer) diff --git a/src/cmp/cmpcatch.lsp b/src/cmp/cmpcatch.lsp index e3fe5d885..e6ab3c26f 100644 --- a/src/cmp/cmpcatch.lsp +++ b/src/cmp/cmpcatch.lsp @@ -50,18 +50,31 @@ (defun c2unwind-protect (form body &aux (nr (list 'LCL (next-lcl)))) (wt-nl "{ volatile bool unwinding = FALSE;") + ;; Here we compile the form which is protected. When this form + ;; is aborted, it continues at the frs_pop() with unwinding=TRUE. (wt-nl "if (frs_push(FRS_PROTECT,Cnil)) {") (wt-nl "unwinding = TRUE;} else {") - (let ((*unwind-exit* (cons 'FRAME *unwind-exit*))) - (let ((*destination* 'VALUES)) (c2expr* form)) - (wt-nl "}") - (wt-nl "MV_SAVE(" nr ");") - (let ((*destination* 'TRASH)) (c2expr* body)) - (wt-nl "MV_RESTORE(" nr ");") - (wt-nl "if (unwinding) unwind(nlj_fr,nlj_tag);") - (wt-nl "else {") - (unwind-exit 'VALUES) - (wt "}}"))) + (let ((*unwind-exit* (cons 'FRAME *unwind-exit*)) + (*destination* 'VALUES)) + (c2expr* form)) + (wt-nl "}") + (wt-nl "frs_pop();") + ;; Here we save the values of the form which might have been + ;; aborted, and execute some cleanup code. This code may also + ;; be aborted by some control structure, but is not protected. + (let* ((nr `(LCL ,(next-lcl))) + (*unwind-exit* `((STACK ,nr) ,@*unwind-exit*)) + (*destination* 'TRASH)) + (wt-nl "{cl_index " nr "=cl_stack_push_values();") + (c2expr* body) + (wt-nl "cl_stack_pop_values(" nr ");}")) + ;; Finally, if the protected form was aborted, jump to the + ;; next catch point... + (wt-nl "if (unwinding) unwind(nlj_fr,nlj_tag);") + (wt-nl "else {") + ;; ... or simply return the values of the protected form. + (unwind-exit 'VALUES) + (wt "}}")) (defun c1throw (args &aux (info (make-info)) tag) (when (or (endp args) (endp (cdr args))) diff --git a/src/cmp/cmpexit.lsp b/src/cmp/cmpexit.lsp index b67c15f89..0ca8711be 100644 --- a/src/cmp/cmpexit.lsp +++ b/src/cmp/cmpexit.lsp @@ -12,13 +12,18 @@ (in-package "COMPILER") -(defun unwind-bds (bds-lcl bds-bind) +(defun unwind-bds (bds-lcl bds-bind stack-pop) (declare (fixnum bds-bind)) + (when stack-pop + (wt-nl "cl_stack_pop_n(" (car stack-pop)) + (dolist (f (cdr stack-pop)) + (wt "+" f)) + (wt ");")) (when bds-lcl (wt-nl "bds_unwind(") (wt-lcl bds-lcl) (wt ");")) (dotimes (n bds-bind) (declare (fixnum n)) (wt-nl "bds_unwind1;"))) (defun unwind-exit (loc &optional (jump-p nil) - &aux (bds-lcl nil) (bds-bind 0)) + &aux (bds-lcl nil) (bds-bind 0) (stack-pop nil)) (declare (fixnum bds-bind)) (when (consp *destination*) (case (car *destination*) @@ -36,14 +41,16 @@ (dolist (ue *unwind-exit* (baboon)) ;; perform all unwind-exit's which precede *exit* (cond - ((consp ue) ; ( label# . ref-flag ) - (cond ((eq ue *exit*) + ((consp ue) ; ( label# . ref-flag )| (STACK n) + (cond ((eq (car ue) 'STACK) + (push (second ue) stack-pop)) + ((eq ue *exit*) ;; all body forms except the last (returning) are dealt here (cond ((and (consp *destination*) (or (eq (car *destination*) 'JUMP-TRUE) (eq (car *destination*) 'JUMP-FALSE))) - (unwind-bds bds-lcl bds-bind)) - ((not (or bds-lcl (plusp bds-bind))) + (unwind-bds bds-lcl bds-bind stack-pop)) + ((not (or bds-lcl (plusp bds-bind) stack-pop)) (set-loc loc)) ;; Save the value if LOC may possibly refer ;; to special binding. @@ -61,11 +68,11 @@ (temp (list 'TEMP (next-temp)))) (let ((*destination* temp)) (set-loc loc)) ; temp <- loc - (unwind-bds bds-lcl bds-bind) + (unwind-bds bds-lcl bds-bind stack-pop) (set-loc temp))) ; *destination* <- temp (t (set-loc loc) - (unwind-bds bds-lcl bds-bind))) + (unwind-bds bds-lcl bds-bind stack-pop))) (when jump-p (wt-nl) (wt-go *exit*)) (return)) (t (setq jump-p t)))) @@ -78,25 +85,16 @@ ;; *destination* must be either RETURN or TRASH. (cond ((eq loc 'VALUES) ;; from multiple-value-prog1 or values - (when (or bds-lcl (plusp bds-bind)) - (unwind-bds bds-lcl bds-bind)) + (unwind-bds bds-lcl bds-bind stack-pop) (wt-nl "return VALUES(0);")) ((eq loc 'RETURN) ;; from multiple-value-prog1 or values - (when (or bds-lcl (plusp bds-bind)) - (unwind-bds bds-lcl bds-bind)) - (wt-nl "return value0;")) - ((or bds-lcl (plusp bds-bind)) + (unwind-bds bds-lcl bds-bind stack-pop) + (wt-nl "return value0;")) + (t (let* ((*destination* 'RETURN)) (set-loc loc)) - (unwind-bds bds-lcl bds-bind) - (wt-nl "return value0;")) - ((and (consp loc) - (member (car loc) '(CALL CALL-LOCAL) - :test #'eq)) - (wt-nl "return(" loc ");")) - (t - (set-loc loc) + (unwind-bds bds-lcl bds-bind stack-pop) (wt-nl "return value0;"))) (return)) (RETURN-FIXNUM @@ -106,7 +104,7 @@ (let ((lcl (next-lcl))) (wt-nl "{int ") (wt-lcl lcl) (wt "= ") (wt-fixnum-loc loc) (wt ";") - (unwind-bds bds-lcl bds-bind) + (unwind-bds bds-lcl bds-bind stack-pop) (wt-nl "return(") (wt-lcl lcl) (wt ");}")) (progn (wt-nl "return(") (wt-fixnum-loc loc) (wt ");"))) @@ -118,7 +116,7 @@ (let ((lcl (next-lcl))) (wt-nl "{unsigned char ") (wt-lcl lcl) (wt "= ") (wt-character-loc loc) (wt ";") - (unwind-bds bds-lcl bds-bind) + (unwind-bds bds-lcl bds-bind stack-pop) (wt-nl "return(") (wt-lcl lcl) (wt ");}")) (progn (wt-nl "return(") (wt-character-loc loc) (wt ");"))) @@ -130,7 +128,7 @@ (let ((lcl (next-lcl))) (wt-nl "{double ") (wt-lcl lcl) (wt "= ") (wt-long-float-loc loc) (wt ";") - (unwind-bds bds-lcl bds-bind) + (unwind-bds bds-lcl bds-bind stack-pop) (wt-nl "return(") (wt-lcl lcl) (wt ");}")) (progn (wt-nl "return(") (wt-long-float-loc loc) (wt ");"))) @@ -142,7 +140,7 @@ (let ((lcl (next-lcl))) (wt-nl "{float ") (wt-lcl lcl) (wt "= ") (wt-short-float-loc loc) (wt ";") - (unwind-bds bds-lcl bds-bind) + (unwind-bds bds-lcl bds-bind stack-pop) (wt-nl "return(") (wt-lcl lcl) (wt ");}")) (progn (wt-nl "return(") (wt-short-float-loc loc) (wt ");"))) @@ -153,7 +151,7 @@ (if (or bds-lcl (plusp bds-bind)) (progn (wt-nl "{cl_object x =" loc ";") - (unwind-bds bds-lcl bds-bind) + (unwind-bds bds-lcl bds-bind stack-pop) (wt-nl "return(x);}")) (wt-nl "return(" loc ");")) (return))) @@ -168,20 +166,22 @@ ;;; Never reached ) -(defun unwind-no-exit (exit &aux (bds-lcl nil) (bds-bind 0)) +(defun unwind-no-exit (exit &aux (bds-lcl nil) (bds-bind 0) (stack-pop nil)) (declare (fixnum bds-bind)) (dolist (ue *unwind-exit* (baboon)) (cond ((consp ue) - (when (eq ue exit) - (unwind-bds bds-lcl bds-bind) - (return))) + (cond ((eq ue exit) + (unwind-bds bds-lcl bds-bind stack-pop) + (return)) + ((eq (car ue) 'STACK) + (push (cdr ue) stack-pop)))) ((numberp ue) (setq bds-lcl ue bds-bind 0)) ((eq ue 'BDS-BIND) (incf bds-bind)) ((member ue '(RETURN RETURN-OBJECT RETURN-FIXNUM RETURN-CHARACTER RETURN-LONG-FLOAT RETURN-SHORT-FLOAT)) (if (eq exit ue) - (progn (unwind-bds bds-lcl bds-bind) + (progn (unwind-bds bds-lcl bds-bind stack-pop) (return)) (baboon)) ;;; Never reached @@ -189,7 +189,7 @@ ((eq ue 'FRAME) (wt-nl "frs_pop();")) ((eq ue 'TAIL-RECURSION-MARK) (if (eq exit 'TAIL-RECURSION-MARK) - (progn (unwind-bds bds-lcl bds-bind) + (progn (unwind-bds bds-lcl bds-bind stack-pop) (return)) (baboon)) ;;; Never reached diff --git a/src/cmp/cmpflet.lsp b/src/cmp/cmpflet.lsp index e0bad46ea..6f1377e88 100644 --- a/src/cmp/cmpflet.lsp +++ b/src/cmp/cmpflet.lsp @@ -297,6 +297,12 @@ (defun c2call-local (fun args &optional narg) (declare (type fun fun)) + (multiple-value-bind (*unwind-exit* args narg) + (maybe-push-args args) + (when narg + (c2call-local fun args narg) + (wt-nl "}") + (return-from c2call-local))) (cond ((and (listp args) *tail-recursion-info* @@ -324,7 +330,7 @@ (unwind-exit (if (eq 'ARGS-PUSHED args) (list 'CALL-LOCAL "APPLY" lex-level closure-p - (list fun "&VALUES(0)") narg fname) + (list fun `(STACK-POINTER ,narg)) narg fname) (list 'CALL-LOCAL fun lex-level closure-p (coerce-locs (inline-args args) nil) narg fname))) (close-inline-blocks))))) diff --git a/src/cmp/cmpfun.lsp b/src/cmp/cmpfun.lsp index a98b2ee22..ab1fd10b6 100644 --- a/src/cmp/cmpfun.lsp +++ b/src/cmp/cmpfun.lsp @@ -116,13 +116,12 @@ (arg (list 'TEMP 0)) (narg (list 'LCL (next-lcl))) (is-lambda (eq 'LAMBDA (first funob)))) - ;; We must prepare in VALUES the following: - ;; n, lex0, ..., lexk, env, arg1, ..., argn - (wt-nl "{ int " narg ", i=0;") + ;; We must prepare in the lisp stack the following: + ;; lex0, ..., lexk, env, arg1, ..., argn + (wt-nl "{ cl_index " narg ";") (dolist (expr args) (setf (second arg) (next-temp)) (let ((*destination* arg)) (c2expr* expr))) - (wt-nl narg "=length(" arg ")+" (1- (length args)) ";") (setf (second arg) temp) ; restart numbering (unless is-lambda (let* ((fun (third funob)) @@ -130,22 +129,22 @@ (closure-lvl (when (fun-closure fun) (- *env* (fun-env fun))))) (when (plusp lex-lvl) (dotimes (n lex-lvl) - (wt-nl "VALUES(i++)=(cl_object)lex" n ";"))) + (wt-nl "cl_stack_push((cl_object)lex" n ");"))) (setq temp lex-lvl) ; count environment arguments (when closure-lvl ;; env of local fun is ALWAYS contained in current env (?) - (wt-nl "VALUES(i++)=(cl_object)env" *env-lvl* ";") + (wt-nl "cl_stack_push((cl_object)env" *env-lvl* ");") (incf temp)))) (dotimes (i (1- (length args))) - (wt-nl "VALUES(i++)=" arg ";") + (wt-nl "cl_stack_push(" arg ");") (incf (second arg))) - (unless is-lambda - (wt narg "+=" temp ";")) - (wt-nl "for (; i<" narg ";i++," arg "=CDR(" arg "))") - (wt-nl " VALUES(i)=CAR(" arg ");") - (if is-lambda - (c2funcall funob 'ARGS-PUSHED loc narg) - (c2call-local (third funob) 'ARGS-PUSHED narg)) + (wt-nl narg "=" (1- (length args))) + (unless is-lambda (wt "+" temp)) + (wt "+cl_stack_push_list(" arg ");") + (let ((*unwind-exit* `((STACK ,narg) ,@*unwind-exit*))) + (if is-lambda + (c2funcall funob 'ARGS-PUSHED loc narg) + (c2call-local (third funob) 'ARGS-PUSHED narg))) (wt-nl "}"))) (defun c1apply-optimize (info requireds rest body args diff --git a/src/cmp/cmplam.lsp b/src/cmp/cmplam.lsp index 904e00acf..d8ab5b64f 100644 --- a/src/cmp/cmplam.lsp +++ b/src/cmp/cmplam.lsp @@ -382,21 +382,21 @@ (when (or optionals rest) ; (not (null requireds)) (unless block-p (wt-nl "{") (setq block-p t)) - (wt-nl "va_list args; va_start(args, ") - (if (plusp nreq) - (wt-lcl (+ req0 nreq)) - (if closure-p (wt "env0") (wt "narg"))) - (wt ");"))) + (wt-nl "cl_va_list args; cl_va_start(args," + (cond ((plusp nreq) (format nil "V~d" (+ req0 nreq))) + (closure-p "env0") + (t "narg")) + (format nil ",narg,~d);" nreq)))) ;; check arguments (when (or *safe-compile* *compiler-check-args*) (cond ((or (third lambda-list) ; rest=NIL if not used optionals) (when requireds - (wt-nl "if(narg<" nreq ") FEtoo_few_arguments(&narg);")) + (wt-nl "if(narg<" nreq ") FEtoo_few_arguments(narg);")) (unless (third lambda-list) (wt-nl "if(narg>" (+ nreq (length optionals)) - ") FEtoo_many_arguments(&narg);"))) + ") FEtoo_many_arguments(narg);"))) (t (wt-nl "check_arg(" nreq ");")))) ;; Bind required parameters. @@ -412,7 +412,7 @@ ) ;; Bind optional parameters as long as there remain arguments. (when optionals - (let ((va-arg-loc `(VA-ARG ,(eq kind 'CALL-LAMBDA)))) + (let ((va-arg-loc 'VA-ARG)) (dolist (opt optionals) (push (next-label) labels) (wt-nl "if (i==narg) ") (wt-go (car labels)) @@ -436,9 +436,7 @@ (wt-nl "narg -= i;") (wt-nl "narg -=" nreq ";")) (wt-nl rest-loc) - (if (eq 'CALL-LAMBDA kind) - (wt "=grab_rest_args(narg,args);") - (wt "=va_grab_rest_args(narg,args);")) + (wt "=cl_grab_rest_args(args);") (bind rest-loc rest)) (when *tail-recursion-info* @@ -509,15 +507,15 @@ (unless call-lambda (unless block-p (wt-nl "{") (setq block-p t)) - (wt-nl "va_list args; va_start(args, ") - (wt (setq last-arg (if (plusp nreq) - (format nil "V~d" (+ req0 nreq)) - (if closure-p "env0" "narg")))) - (wt ");")) + (wt-nl "cl_va_list args; cl_va_start(args, " + (cond ((plusp nreq) (format nil "V~d" (+ req0 nreq))) + (closure-p "env0") + (t "narg")) + (format nil ", narg, ~d);" nreq))) ;; check arguments (when (and (or *safe-compile* *compiler-check-args*) requireds) - (wt-nl "if(narg<" nreq ") FEtoo_few_arguments(&narg);")) + (wt-nl "if(narg<" nreq ") FEtoo_few_arguments(narg);")) ;; Bind required parameters. (do ((reqs requireds (cdr reqs)) @@ -532,7 +530,7 @@ ) ;; Bind optional parameters as long as there remain arguments. (when optionals - (let ((va-arg-loc `(VA-ARG ,call-lambda))) + (let ((va-arg-loc 'VA-ARG)) (dolist (opt optionals) (push (next-label) labels) (wt-nl "if (i==narg) ") (wt-go (car labels)) @@ -561,8 +559,7 @@ (add-keyword (first kwd))) (wt-nl "{ cl_object keyvars[" (* 2 nkey) "];") - (wt-nl (if call-lambda "parse_key(narg,args," "va_parse_key(narg,args,") - (length keywords) ",L" cfun "keys,keyvars") + (wt-nl "cl_parse_key(args," (length keywords) ",L" cfun "keys,keyvars") (if rest (wt ",&" rest-loc) (wt ",NULL")) (wt (if allow-other-keys ",TRUE);" ",FALSE);")) (when rest (bind rest-loc rest)) diff --git a/src/cmp/cmploc.lsp b/src/cmp/cmploc.lsp index 9d9557bb7..bdbb6d4cf 100644 --- a/src/cmp/cmploc.lsp +++ b/src/cmp/cmploc.lsp @@ -106,6 +106,8 @@ (wt "value0")) ; added for last inline-arg ((eq loc 'VALUES) (wt "VALUES(0)")) + ((eq loc 'VA-ARG) + (wt "cl_va_arg(args);")) ((or (not (consp loc)) (not (symbolp (car loc)))) (baboon)) @@ -206,12 +208,6 @@ (t (wt "sf(" loc ")"))) (wt "sf(" loc ")"))) -(defun wt-va_arg (call-lambda) - (if call-lambda - (wt "args[i]") - (wt "va_arg(args, cl_object)"))) -;(defun set-va_arg (loc) (wt-nl "va_arg(args, cl_object)=" loc ";")) - (defun wt-value (i) (wt "VALUES(" i ")")) (defun wt-keyvars (i) (wt "keyvars[" i "]")) @@ -232,7 +228,5 @@ ;(setf (get 'LONG-FLOAT-LOC 'WT-LOC) #'wt-long-float-loc) (setf (get 'SHORT-FLOAT-VALUE 'WT-LOC) #'wt-number) ;(setf (get 'SHORT-FLOAT-LOC 'WT-LOC) #'wt-short-float-loc) -(setf (get 'VA-ARG 'WT-LOC) #'wt-va_arg) -;(setf (get 'VA-ARG 'SET-LOC) #'set-va_arg) (setf (get 'VALUE 'WT-LOC) #'wt-value) (setf (get 'KEYVARS 'WT-LOC) #'wt-keyvars) diff --git a/src/cmp/cmpmulti.lsp b/src/cmp/cmpmulti.lsp index a971a4aba..185953b97 100644 --- a/src/cmp/cmpmulti.lsp +++ b/src/cmp/cmpmulti.lsp @@ -25,19 +25,13 @@ (let ((tot (list 'LCL (next-lcl))) (nr (list 'LCL (next-lcl))) (loc (save-funob funob))) - (wt-nl "{ int " tot ";") - (let ((*destination* 'VALUES)) - (c2expr* (first forms))) - (wt-nl tot "=NValues;") - (dolist (form (rest forms)) - (wt-nl "MV_SAVE(" nr ");") + (wt-nl "{ cl_index " tot "=0;") + (let ((*unwind-exit* `((STACK ,tot) ,@*unwind-exit*))) (let ((*destination* 'VALUES)) - (c2expr* form)) - (wt-nl "MV_SHIFT(NValues," nr ");") - (wt-nl tot "+=NValues;") - (wt-nl "MV_RESTORE(" nr ");") - (wt-nl "NValues=" tot ";")) - (c2funcall funob 'ARGS-PUSHED loc tot) + (dolist (form forms) + (c2expr* form) + (wt-nl tot "+=cl_stack_push_values();"))) + (c2funcall funob 'ARGS-PUSHED loc tot)) (wt "}")) ) @@ -52,13 +46,15 @@ (if (eq 'TRASH *destination*) ;; dont bother saving values (c2progn (cons form forms)) - (progn + (let ((nr `(LCL ,(next-lcl)))) (let ((*destination* 'VALUES)) (c2expr* form)) - (wt-nl "MV_SAVE(nr);") - (dolist (form forms) - (let ((*destination* 'TRASH)) (c2expr* form))) - (wt-nl "MV_RESTORE(nr);") - (unwind-exit 'VALUES)))) + (wt-nl "{ cl_index " nr "=cl_stack_push_values();") + (let ((*destination* 'TRASH) + (*unwind-exit* `((STACK ,nr) ,@*unwind-exit*))) + (dolist (form forms) + (c2expr* form))) + (wt-nl "cl_stack_pop_values(" nr ");}") + (unwind-exit 'VALUES))))) ;;; Beppe: ;;; this is the WRONG way to handle 1 value problem. diff --git a/src/cmp/cmputil.lsp b/src/cmp/cmputil.lsp index 9d8cd3445..be514adc5 100644 --- a/src/cmp/cmputil.lsp +++ b/src/cmp/cmputil.lsp @@ -78,7 +78,7 @@ (defun baboon (&aux (*print-case* :upcase)) (print-current-form) (format - t "~&;;; A bug was found in the compiler. Contact attardi@di.unipi.it.~%") + t "~&;;; A bug was found in the compiler. Contact worm@arrakis.es.~%") (incf *error-count*) (break) ; (throw *cmperr-tag* '*cmperr-tag*) DEBUG diff --git a/src/configure.in b/src/configure.in index a7f574d0f..853f64548 100644 --- a/src/configure.in +++ b/src/configure.in @@ -31,7 +31,7 @@ exit 2; fi dnl Set the version number. This seems the best place to keep it. -ECL_VERSION=0.6 +ECL_VERSION=0.7 AC_SUBST(ECL_VERSION) dnl Guess operating system of host. We do not allow cross-compiling. diff --git a/src/h/config.h.in b/src/h/config.h.in index 674a727d5..7fbab369b 100644 --- a/src/h/config.h.in +++ b/src/h/config.h.in @@ -67,7 +67,12 @@ #define CSGETA 4000 #endif #define VSSIZE 128 /* Size of return values stack */ -#define CALL_ARGUMENTS_LIMIT 64 /* Maximum number of function arguments */ + /* Maximum number of function arguments */ +#define CALL_ARGUMENTS_LIMIT MOST_POSITIVE_FIXNUM + /* Maximum number of required arguments */ +#define LAMBDA_PARAMETERS_LIMIT 64 + /* Numb. of args. which can be passed using the C stack */ +#define C_ARGUMENTS_LIMIT 64 #define BIGNUM_REGISTER_SIZE 16 /* Size in words of each register */ diff --git a/src/h/ecl-cmp.h b/src/h/ecl-cmp.h index 366d7c4c1..8401b94c0 100644 --- a/src/h/ecl-cmp.h +++ b/src/h/ecl-cmp.h @@ -43,7 +43,7 @@ #define LINK_ARGS &narg #define TRAMPOLINK(narg, vv, lk) \ - va_list args; va_start(args, narg); \ + cl_va_list args; cl_va_start(args, narg, narg, 0); \ return(link_call(vv, (cl_objectfn *)lk, narg, args)) #define cclosure_call funcall diff --git a/src/h/ecl.h b/src/h/ecl.h index d46c430f0..0139f0387 100644 --- a/src/h/ecl.h +++ b/src/h/ecl.h @@ -24,7 +24,6 @@ #include "gmp.h" #include "object.h" #include "stacks.h" -#include "cs.h" #include "critical.h" #ifdef THREADS # include "lwp.h" diff --git a/src/h/external.h b/src/h/external.h index a83f7d1ed..d622f3dd3 100644 --- a/src/h/external.h +++ b/src/h/external.h @@ -164,12 +164,11 @@ extern int aset_bv(cl_object x, cl_index index, int value); extern void cl_throw(cl_object tag) __attribute__((noreturn)); extern void cl_return_from(cl_object block_id, cl_object block_name) __attribute__((noreturn)); extern void cl_go(cl_object tag_id, cl_object label) __attribute__((noreturn)); -extern void parse_key(int narg, cl_object *args, int nkey, cl_object *keys, cl_object *vars, cl_object *rest, bool allow_other_keys); -extern cl_object grab_rest_args(int narg, cl_object *args); +extern void cl_parse_key(cl_va_list args, int nkey, cl_object *keys, cl_object *vars, cl_object *rest, bool allow_other_keys); +extern cl_object cl_grab_rest_args(cl_va_list args); extern void check_other_key(cl_object l, int n, ...); extern void init_cmpaux(void); - /* compiler.c */ extern cl_object make_lambda(cl_object name, cl_object lambda); @@ -178,8 +177,20 @@ extern void init_compiler(void); /* interpreter.c */ +extern void cl_stack_push(cl_object o); +extern cl_object cl_stack_pop(void); +extern cl_index cl_stack_index(void); +extern void cl_stack_set_index(cl_index sp); +extern void cl_stack_pop_n(cl_index n); +extern void cl_stack_insert(cl_index where, cl_index n); +extern cl_index cl_stack_push_list(cl_object list); +extern cl_index cl_stack_push_va_list(cl_va_list args); +extern void cl_stack_push_n(cl_index n, cl_object *args); +extern int cl_stack_push_values(void); +extern void cl_stack_pop_values(int n); + extern cl_object lex_env; -extern cl_object lambda_apply(int narg, cl_object fun, cl_object *args); +extern cl_object lambda_apply(int narg, cl_object fun); extern cl_object *interpret(cl_object *memory); extern void init_interpreter(void); @@ -201,8 +212,8 @@ extern void FEcontrol_error(const char *s, int narg, ...) __attribute__((noretur extern void FEerror(char *s, int narg, ...) __attribute__((noreturn)); extern void FEcannot_open(cl_object fn) __attribute__((noreturn)); extern void FEwrong_type_argument(cl_object type, cl_object value) __attribute__((noreturn)); -extern void FEtoo_few_arguments(int *nargp) __attribute__((noreturn)); -extern void FEtoo_many_arguments(int *nargp) __attribute__((noreturn)); +extern void FEtoo_few_arguments(int narg) __attribute__((noreturn)); +extern void FEtoo_many_arguments(int narg) __attribute__((noreturn)); extern void FEunbound_variable(cl_object sym) __attribute__((noreturn)); extern void FEinvalid_macro_call(cl_object obj) __attribute__((noreturn)); extern void FEinvalid_variable(char *s, cl_object obj) __attribute__((noreturn)); @@ -222,27 +233,15 @@ extern void FEend_of_file(cl_object strm); #define funcall clLfuncall -extern cl_object apply(int narg, cl_object fun, cl_object *args); -extern cl_object link_call(cl_object sym, cl_objectfn *pLK, int narg, va_list args); +#define cl_va_start(a,p,n,k) (va_start(a[0].args,p),a[0].narg=n,cl__va_start(a,k)) +extern void cl__va_start(cl_va_list args, int args_before); +extern cl_object cl_va_arg(cl_va_list args); + +extern cl_object cl_apply_from_stack(cl_index narg, cl_object fun); +extern cl_object link_call(cl_object sym, cl_objectfn *pLK, int narg, cl_va_list args); extern cl_object cl_safe_eval(cl_object form, cl_object *bytecodes, cl_object env, cl_object err_value); extern void init_eval(void); -#ifdef NO_ARGS_ARRAY -extern cl_object va_APPLY(int narg, cl_objectfn fn, va_list args); -extern cl_object va_APPLY_closure(int narg, cl_objectfn fn, cl_object data, va_list args); -extern cl_object va_compute_method(int narg, cl_object fn, cl_object data, va_list args); -extern cl_object va_lambda_apply(int narg, cl_object fun, va_list args); -extern void va_parse_key(int narg, va_list args, int nkey, cl_object *keys, cl_object *vars, cl_object *rest, bool allow_other_keys); -extern cl_object va_grab_rest_args(int narg, va_list args); -#else -#define va_APPLY(x,y,z) APPLY(x,y,&va_arg(z,cl_object)) -#define va_APPLY_closure(x,y,p,z) APPLY_closure(x,y,p,&va_arg(z,cl_object)) -#define va_compute_method(x,y,z) compute_method(x,y,&va_arg(z,cl_object)) -#define va_lambda_apply(x,y,z) lambda_apply(x,y,&va_arg(z,cl_object)) -#define va_parse_key(a,b,c,d,e,f,g) parse_key(a,&va_arg(b,cl_object),c,d,e,f,g) -#define va_grab_rest_args(a,b) grab_rest_args(a,&va_arg(b,cl_object)) -#endif - /* file.c */ extern bool input_stream_p(cl_object strm); diff --git a/src/h/lisp_external.h b/src/h/lisp_external.h index d34397713..236d80f72 100644 --- a/src/h/lisp_external.h +++ b/src/h/lisp_external.h @@ -512,12 +512,12 @@ extern cl_object clLidentity _ARGS((int narg, cl_object x)); /* mapfun.c */ -extern cl_object clLmapcar _ARGS((int narg, cl_object fun, cl_object onelist, ...)); -extern cl_object clLmaplist _ARGS((int narg, cl_object fun, cl_object onelist, ...)); -extern cl_object clLmapc _ARGS((int narg, cl_object fun, cl_object onelist, ...)); -extern cl_object clLmapl _ARGS((int narg, cl_object fun, cl_object onelist, ...)); -extern cl_object clLmapcan _ARGS((int narg, cl_object fun, cl_object onelist, ...)); -extern cl_object clLmapcon _ARGS((int narg, cl_object fun, cl_object onelist, ...)); +extern cl_object clLmapcar _ARGS((int narg, cl_object fun, ...)); +extern cl_object clLmaplist _ARGS((int narg, cl_object fun, ...)); +extern cl_object clLmapc _ARGS((int narg, cl_object fun, ...)); +extern cl_object clLmapl _ARGS((int narg, cl_object fun, ...)); +extern cl_object clLmapcan _ARGS((int narg, cl_object fun, ...)); +extern cl_object clLmapcon _ARGS((int narg, cl_object fun, ...)); /* multival.c */ diff --git a/src/h/object.h b/src/h/object.h index 942c3a8be..6cbd0b037 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -545,6 +545,15 @@ typedef enum { FALSE : x == Cnil ? TRUE : \ (FEtype_error_list(x), FALSE)) +/* + This is used to retrieve optional arguments +*/ +typedef struct { + va_list args; + cl_index sp; + int narg; +} cl_va_list[1]; + #ifdef __cplusplus } #endif diff --git a/src/h/stacks.h b/src/h/stacks.h index b58120b0f..a5622bf72 100644 --- a/src/h/stacks.h +++ b/src/h/stacks.h @@ -26,15 +26,6 @@ extern cl_object *cl_stack; extern cl_object *cl_stack_top; extern cl_object *cl_stack_limit; -extern void cl_stack_push(cl_object o); -extern cl_object cl_stack_pop(void); -extern cl_index cl_stack_index(void); -extern void cl_stack_set_index(cl_index sp); -extern void cl_stack_pop_n(cl_index n); -extern void cl_stack_insert(cl_index where, cl_index n); -extern void cl_stack_push_varargs(cl_index n, va_list args); -extern void cl_stack_push_n(cl_index n, cl_object *args); - /************** * BIND STACK **************/ diff --git a/src/lsp/helpfile.lsp b/src/lsp/helpfile.lsp index f1d6a0005..65bd2dc14 100644 --- a/src/lsp/helpfile.lsp +++ b/src/lsp/helpfile.lsp @@ -137,6 +137,7 @@ the help file." (return-from get-documentation output))))))) (defun set-documentation (symbol doc-type string) + (tan 1.0) (unless (member doc-type '(variable function setf type structure)) (error "~S is not a valid documentation type" doc-type)) (unless (or (stringp string) (null string))