mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-03-01 10:10:27 -08:00
Code Issues Projects Releases Packages Wiki Activity

The calling conventions have been changed. SI::C-ARGUMENTS-LIMIT and

Browse source 
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.
This commit is contained in:
jjgarcia 2002-10-21 09:27:58 +00:00
parent 10fbd27569
commit a9e4edf4d0
45 changed files with 634 additions and 584 deletions
Download patch file Download diff file Expand all files Collapse all files

33
src/CHANGELOG
View file

@ -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

2
src/c/Makefile.in
View file

@ -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

33
src/c/apply.d
View file

@ -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; i<n; i++) x[i] = cl_nextarg(args);
APPLY(n, fn, x);
}
cl_object
va_APPLY_closure(int n, cl_objectfn fn, cl_object cl, va_list args)
{
cl_object x[n+1];
int i;
x[0] = cl;
for(i=1; i<=n; i++) x[i] = cl_nextarg(args);
APPLY(n+1, fn, x);
}
#endif /* NO_ARGS_ARRAY */

10
src/c/array.d
View file

@ -65,7 +65,7 @@ object_to_index(cl_object n)
if (r != x->array.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);

40
src/c/character.d
View file

@ -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<i; j++)
if (char_eq(cl_nextarg(ds), c))
if (char_eq(cl_va_arg(ds), c))
@(return Cnil)
}
@(return Ct)
@)
static cl_return
Lchar_cmp(int narg, int s, int t, va_list args)
Lchar_cmp(int narg, int s, int t, cl_va_list args)
{
cl_object c, d;
if (narg == 0)
FEtoo_few_arguments(&narg);
c = cl_nextarg(args);
FEtoo_few_arguments(narg);
c = cl_va_arg(args);
for (; --narg; c = d) {
d = cl_nextarg(args);
d = cl_va_arg(args);
if (s*char_cmp(d, c) < t)
return1(Cnil);
}
@ -223,7 +223,7 @@ char_cmp(cl_object x, cl_object y)
@
/* INV: char_equal() checks the type of its arguments */
for (narg--, i = 0; i < narg; i++) {
if (!char_equal(c, cl_nextarg(cs)))
if (!char_equal(c, cl_va_arg(cs)))
@(return Cnil)
}
@(return Ct)
@ -249,29 +249,29 @@ char_equal(cl_object x, cl_object y)
if (narg == 0)
@(return Ct)
/* INV: char_equal() checks the type of its arguments */
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<i; j++)
if (char_equal(c, cl_nextarg(ds)))
if (char_equal(c, cl_va_arg(ds)))
@(return Cnil)
}
@(return Ct)
@)
static cl_return
Lchar_compare(int narg, int s, int t, va_list args)
Lchar_compare(int narg, int s, int t, cl_va_list args)
{
cl_object c, d;
/* INV: char_compare() checks the types of its arguments */
if (narg == 0)
FEtoo_few_arguments(&narg);
c = cl_nextarg(args);
FEtoo_few_arguments(narg);
c = cl_va_arg(args);
for (; --narg; c = d) {
d = cl_nextarg(args);
d = cl_va_arg(args);
if (s*char_compare(d, c) < t)
return1(Cnil);
}

96
src/c/cmpaux.d
View file

@ -14,9 +14,6 @@
See file '../Copyright' for full details.
*/
#ifndef darwin
#include <malloc.h>
#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);
}

3
src/c/compiler.d
View file

@ -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)

15
src/c/dpp.c
View file

@ -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);

47
src/c/error.d
View file

@ -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

102
src/c/eval.d
View file

@ -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);
}

4
src/c/file.d
View file

@ -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);

2
src/c/format.d
View file

@ -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;

132
src/c/interpreter.d
View file

@ -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<NValues; i++)
cl_stack_push(VALUES(i));
return i;
}
void
cl_stack_pop_values(int n) {
NValues = n;
while (n > 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<n; i++)
spp[i] = OBJNULL;
for (; narg; args+=2, narg-=2) {
if (!SYMBOLP(args[0]))
FEprogram_error("LAMBDA: Keyword expected, got ~S.", 1, args[0]);
for (; narg; narg-=2) {
cl_object key = cl_stack[sp++];
cl_object value = cl_stack[sp++];
if (!SYMBOLP(key))
FEprogram_error("LAMBDA: Keyword expected, got ~S.", 1, key);
keys = data;
for (i = 0; i < n; i++, keys += 4) {
if (args[0] == keys[0]) {
if (key == keys[0]) {
if (spp[i] == OBJNULL)
spp[i] = args[1];
spp[i] = value;
goto FOUND;
}
}
if (args[0] != @':allow-other-keys')
if (key != @':allow-other-keys')
other_found = TRUE;
else if (!allow_other_keys_found) {
allow_other_keys_found = TRUE;
other_keys = !Null(args[1]);
other_keys = !Null(value);
}
FOUND:
(void)0;
@ -288,8 +341,9 @@ lambda_bind(int narg, cl_object lambda_list, cl_object *args)
}
cl_object
lambda_apply(int narg, cl_object fun, cl_object *args)
lambda_apply(int narg, cl_object fun)
{
cl_index args = cl_stack_index() - narg;
cl_object output, name, *body;
bds_ptr old_bds_top;
volatile bool block;
@ -317,7 +371,6 @@ lambda_apply(int narg, cl_object fun, cl_object *args)
fun = new_frame_id();
bind_block(name, fun);
if (frs_push(FRS_CATCH, fun)) {
output = VALUES(0);
goto END;
}
}
@ -334,46 +387,6 @@ END: if (block) frs_pop();
}
#ifdef NO_ARGS_ARRAY
cl_object
va_lambda_apply(int narg, cl_object fun, va_list args)
{
cl_object out;
int i;
for (i=narg; i; i--)
cl_stack_push(cl_nextarg(args));
out = lambda_apply(narg, fun, cl_stack_top-narg);
cl_stack_pop_n(narg);
return out;
}
#ifdef CLOS
cl_object
va_gcall(int narg, cl_object fun, va_list args)
{
cl_object out;
int i;
for (i=narg; i; i--)
cl_stack_push(cl_nextarg(args));
out = gcall(narg, fun, cl_stack_top-narg);
cl_stack_pop_n(narg);
return out;
}
cl_object
va_compute_method(int narg, cl_object fun, va_list args)
{
cl_object out;
int i;
for (i=narg; i; i--)
cl_stack_push(cl_nextarg(args));
out = compute_method(narg, fun, cl_stack_top-narg);
cl_stack_pop_n(narg);
return out;
}
#endif
#endif
/* -------------------- AIDS TO THE INTERPRETER -------------------- */
static inline cl_fixnum
@ -425,7 +438,7 @@ interpret_funcall(int narg, cl_object fun) {
goto AGAIN;
#endif
case t_bytecodes:
x = lambda_apply(narg, fun, args);
x = lambda_apply(narg, fun);
break;
case t_symbol: {
cl_object function = SYM_FUN(fun);
@ -447,7 +460,7 @@ interpret_funcall(int narg, cl_object fun) {
narg -= 2;
for (i = 0; narg; i++,narg--) {
cl_stack_push(lastarg);
lastarg = va_arg(args, cl_object);
lastarg = cl_va_arg(args);
}
loop_for_in (lastarg) {
if (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;

30
src/c/list.d
View file

@ -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);

6
src/c/lwp.d
View file

@ -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 */

139
src/c/mapfun.d
View file

@ -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<nlist; i++)
cl_stack_push(Cnil);
return nlist;
}
@(defun mapcar (fun &rest lists)
cl_object res, *val = &res;
cl_object cdrs[narg-1];
cl_object cars[narg-1]; /* __GNUC__ */
int i;
cl_index i, nlist, cdrs_sp;
@
cdrs[0] = onelist;
for (--narg, i = 1; i < narg; i++)
cdrs[i] = cl_nextarg(lists);
nlist = prepare_map(lists, &cdrs_sp);
res = Cnil;
while (TRUE) {
for (i = 0; i < narg; i++) {
if (endp(cdrs[i]))
/* INV: The stack does not grow here. */
cl_object *cdrs = cl_stack + cdrs_sp;
cl_object *cars = cdrs + nlist;
for (i = 0; i < nlist; i++) {
if (endp(cdrs[i])) {
cl_stack_set_index(cdrs_sp);
@(return res)
}
cars[i] = CAR(cdrs[i]);
cdrs[i] = CDR(cdrs[i]);
}
*val = CONS(apply(narg, fun, cars), Cnil);
*val = CONS(cl_apply_from_stack(nlist, fun), Cnil);
val = &CDR(*val);
}
@)
@(defun maplist (fun onelist &rest lists)
@(defun maplist (fun &rest lists)
cl_object res, *val = &res;
cl_object cdrs[narg-1];
cl_object cars[narg-1]; /* __GNUC__ */
int i;
cl_index i, nlist, cdrs_sp;
@
cdrs[0] = onelist;
for (--narg, i = 1; i < narg; i++)
cdrs[i] = cl_nextarg(lists);
nlist = prepare_map(lists, &cdrs_sp);
res = Cnil;
while (TRUE) {
for (i = 0; i < narg; i++) {
if (endp(cdrs[i]))
cl_object *cdrs = cl_stack + cdrs_sp;
cl_object *cars = cdrs + nlist;
for (i = 0; i < nlist; i++) {
if (endp(cdrs[i])) {
cl_stack_set_index(cdrs_sp);
@(return res)
}
cars[i] = cdrs[i];
cdrs[i] = CDR(cdrs[i]);
}
*val = CONS(apply(narg, fun, cars), Cnil);
*val = CONS(cl_apply_from_stack(nlist, fun), Cnil);
val = &CDR(*val);
}
@)
@(defun mapc (fun onelist &rest lists)
cl_object cdrs[narg-1];
cl_object cars[narg-1]; /* __GNUC__ */
int i;
@(defun mapc (fun &rest lists)
cl_object onelist;
cl_index i, nlist, cdrs_sp;
@
cdrs[0] = onelist;
for (--narg, i = 1; i < narg; i++)
cdrs[i] = va_arg(lists, cl_object);
nlist = prepare_map(lists, &cdrs_sp);
onelist = cl_stack[cdrs_sp];
while (TRUE) {
for (i = 0; i < narg; i++) {
if (endp(cdrs[i]))
cl_object *cdrs = cl_stack + cdrs_sp;
cl_object *cars = cdrs + nlist;
for (i = 0; i < nlist; i++) {
if (endp(cdrs[i])) {
cl_stack_set_index(cdrs_sp);
@(return onelist)
}
cars[i] = CAR(cdrs[i]);
cdrs[i] = CDR(cdrs[i]);
}
apply(narg, fun, cars);
cl_apply_from_stack(nlist, fun);
}
@)
@(defun mapl (fun onelist &rest lists)
cl_object cdrs[narg-1];
cl_object cars[narg-1]; /* __GNUC__ */
int i;
@(defun mapl (fun &rest lists)
cl_object onelist;
cl_index i, nlist, cdrs_sp;
@
cdrs[0] = onelist;
for (--narg, i = 1; i < narg; i++)
cdrs[i] = cl_nextarg(lists);
nlist = prepare_map(lists, &cdrs_sp);
onelist = cl_stack[cdrs_sp];
while (TRUE) {
for (i = 0; i < narg; i++) {
if (endp(cdrs[i]))
cl_object *cdrs = cl_stack + cdrs_sp;
cl_object *cars = cdrs + nlist;
for (i = 0; i < nlist; i++) {
if (endp(cdrs[i])) {
cl_stack_set_index(cdrs_sp);
@(return onelist)
}
cars[i] = cdrs[i];
cdrs[i] = CDR(cdrs[i]);
}
apply(narg, fun, cars);
cl_apply_from_stack(nlist, fun);
}
@)
@(defun mapcan (fun onelist &rest lists)
@(defun mapcan (fun &rest lists)
cl_object *x, res, *val = &res;
cl_object cdrs[narg-1];
cl_object cars[narg-1]; /* __GNUC__ */
int i;
cl_index i, nlist, cdrs_sp;
@
cdrs[0] = onelist;
for (--narg, i = 1; i < narg; i++)
cdrs[i] = cl_nextarg(lists);
nlist = prepare_map(lists, &cdrs_sp);
res = Cnil;
while (TRUE) {
for (i = 0; i < narg; i++) {
if (endp(cdrs[i]))
cl_object *cdrs = cl_stack + cdrs_sp;
cl_object *cars = cdrs + nlist;
for (i = 0; i < nlist; i++) {
if (endp(cdrs[i])) {
cl_stack_set_index(cdrs_sp);
@(return res)
}
cars[i] = CAR(cdrs[i]);
cdrs[i] = CDR(cdrs[i]);
}
*val = apply(narg, fun, cars);
*val = cl_apply_from_stack(nlist, fun);
while (CONSP(*val))
val = &CDR(*val);
}
@)
@(defun mapcon (fun onelist &rest lists)
@(defun mapcon (fun &rest lists)
cl_object res, *val = &res;
cl_object cdrs[narg-1];
cl_object cars[narg-1]; /* __GNUC__ */
int i;
cl_index i, nlist, cdrs_sp;
@
cdrs[0] = onelist;
for (--narg, i = 1; i < narg; i++)
cdrs[i] = cl_nextarg(lists);
nlist = prepare_map(lists, &cdrs_sp);
res = Cnil;
while (TRUE) {
for (i = 0; i < narg; i++) {
if (endp(cdrs[i]))
cl_object *cdrs = cl_stack + cdrs_sp;
cl_object *cars = cdrs + nlist;
for (i = 0; i < nlist; i++) {
if (endp(cdrs[i])) {
cl_stack_set_index(cdrs_sp);
@(return res)
}
cars[i] = cdrs[i];
cdrs[i] = CDR(cdrs[i]);
}
*val = apply(narg, fun, cars);
*val = cl_apply_from_stack(nlist, fun);
while (CONSP(*val))
val = &CDR(*val);
}

2
src/c/multival.d
View file

@ -24,7 +24,7 @@
if (narg == 0)
VALUES(0) = Cnil;
else for (i = 0; i < narg; i++)
VALUES(i) = va_arg(args, cl_object);
VALUES(i) = cl_va_arg(args);
returnn(VALUES(0));
@)

16
src/c/num_arith.d
View file

@ -23,7 +23,7 @@
@
/* INV: type check in number_times() */
while (narg--)
prod = number_times(prod, cl_nextarg(nums));
prod = number_times(prod, cl_va_arg(nums));
@(return prod)
@)
@ -195,7 +195,7 @@ number_times(cl_object x, cl_object y)
@
/* INV: type check is in number_plus() */
while (narg--)
sum = number_plus(sum, cl_nextarg(nums));
sum = number_plus(sum, cl_va_arg(nums));
@(return sum)
@)
@ -350,7 +350,7 @@ number_plus(cl_object x, cl_object y)
if (narg == 1)
@(return number_negate(num))
for (diff = num; --narg; )
diff = number_minus(diff, cl_nextarg(nums));
diff = number_minus(diff, cl_va_arg(nums));
@(return diff)
@)
@ -567,11 +567,11 @@ number_negate(cl_object x)
@
/* INV: type check is in number_divide() */
if (narg == 0)
FEtoo_few_arguments(&narg);
FEtoo_few_arguments(narg);
if (narg == 1)
@(return number_divide(MAKE_FIXNUM(1), num))
while (--narg)
num = number_divide(num, cl_nextarg(nums));
num = number_divide(num, cl_va_arg(nums));
@(return num)
@)
@ -721,11 +721,11 @@ integer_divide(cl_object x, cl_object y)
if (narg == 0)
@(return MAKE_FIXNUM(0))
/* INV: get_gcd() checks types */
gcd = cl_nextarg(nums);
gcd = cl_va_arg(nums);
if (narg == 1)
@(return (number_minusp(gcd) ? number_negate(gcd) : gcd))
while (--narg)
gcd = get_gcd(gcd, cl_nextarg(nums));
gcd = get_gcd(gcd, cl_va_arg(nums));
@(return gcd)
@)
@ -874,7 +874,7 @@ one_minus(cl_object x)
/* INV: get_gcd() checks types. By placing `numi' before `lcm' in
this call, we make sure that errors point to `numi' */
while (narg-- > 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);

28
src/c/num_comp.d
View file

@ -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<i; j++)
if (number_equalp(numi, cl_nextarg(numb)))
if (number_equalp(numi, cl_va_arg(numb)))
@(return Cnil)
}
@(return Ct)
@)
static cl_object
monotonic(int s, int t, int narg, va_list nums)
monotonic(int s, int t, int narg, cl_va_list nums)
{
cl_object c, d;
if (narg == 0)
FEtoo_few_arguments(&narg);
FEtoo_few_arguments(narg);
/* INV: type check occurs in number_compare() */
for (c = cl_nextarg(nums); --narg; c = d) {
d = cl_nextarg(nums);
for (c = cl_va_arg(nums); --narg; c = d) {
d = cl_va_arg(nums);
if (s*number_compare(d, c) < t)
return1(Cnil);
}
@ -283,7 +283,7 @@ monotonic(int s, int t, int narg, va_list nums)
}
#define MONOTONIC(i, j) (int narg, ...) \
{ va_list nums; va_start(nums, narg); \
{ cl_va_list nums; cl_va_start(nums, narg, narg, 0); \
return monotonic(i, j, narg, nums); }
cl_object @<= MONOTONIC( 1, 0)
@ -295,7 +295,7 @@ cl_object @> 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;
}

10
src/c/num_log.d
View file

@ -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));
}

38
src/c/string.d
View file

@ -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);

2
src/c/structure.d
View file

@ -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)
@)

4
src/c/symbol.d
View file

@ -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)

1
src/c/symbols_list.h
View file

@ -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},

11
src/c/time.d
View file

@ -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))
@)

7
src/c/unixfsys.d
View file

@ -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:

2
src/cmp/cmpbind.lsp
View file

@ -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)

98
src/cmp/cmpcall.lsp
View file

@ -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)

33
src/cmp/cmpcatch.lsp
View file

@ -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)))

66
src/cmp/cmpexit.lsp
View file

@ -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

8
src/cmp/cmpflet.lsp
View file

@ -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)))))

27
src/cmp/cmpfun.lsp
View file

@ -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

37
src/cmp/cmplam.lsp
View file

@ -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))

10
src/cmp/cmploc.lsp
View file

@ -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)

32
src/cmp/cmpmulti.lsp
View file

@ -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.

2
src/cmp/cmputil.lsp
View file

@ -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

2
src/configure.in
View file

@ -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.

7
src/h/config.h.in
View file

@ -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 */

2
src/h/ecl-cmp.h
View file

@ -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

1
src/h/ecl.h
View file

@ -24,7 +24,6 @@
#include "gmp.h"
#include "object.h"
#include "stacks.h"
#include "cs.h"
#include "critical.h"
#ifdef THREADS
# include "lwp.h"

47
src/h/external.h
View file

@ -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);

12
src/h/lisp_external.h
View file

@ -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 */

9
src/h/object.h
View file

@ -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

9
src/h/stacks.h
View file

@ -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
**************/

1
src/lsp/helpfile.lsp
View file

@ -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))