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

Merge more functions (copy_tree, copy_list, etc), so that only the lisp version is used and this one takes a fixed number of arguments.

Browse source
This commit is contained in:
jjgarcia 2002-11-18 11:23:52 +00:00
parent 7ecf198780
commit bfcc390d7f
8 changed files with 83 additions and 107 deletions
Download patch file Download diff file Expand all files Collapse all files

2
src/c/compiler.d
View file

@ -386,7 +386,7 @@ c_new_env(cl_object env)
return;
}
c_env.lexical_level = 1;
for (env = @revappend(2, env, Cnil); !Null(env); env = CDDR(env))
for (env = @revappend(env, Cnil); !Null(env); env = CDDR(env))
{
cl_object tag = CADR(env);
cl_object what = CAR(env);

127
src/c/list.d
View file

@ -310,14 +310,15 @@ BEGIN:
@(return Cnil)
@)
@(defun endp (x)
@
cl_object
cl_endp(cl_object x)
{
if (Null(x))
@(return Ct)
if (CONSP(x))
@(return Cnil)
FEtype_error_list(x);
@)
}
bool
endp(cl_object x)
@ -330,7 +331,7 @@ endp(cl_object x)
}
cl_object
list_length(cl_object x)
cl_list_length(cl_object x)
{
cl_fixnum n;
cl_object fast, slow;
@ -346,18 +347,14 @@ list_length(cl_object x)
}
if (fast != Cnil)
FEtype_error_proper_list(x);
return MAKE_FIXNUM(n);
@(return MAKE_FIXNUM(n));
}
@(defun list_length (x)
@
@(return list_length(x))
@)
@(defun nth (n x)
@
cl_object
cl_nth(cl_object n, cl_object x)
{
@(return nth(fixint(n), x))
@)
}
cl_object
nth(cl_fixnum n, cl_object x)
@ -375,10 +372,11 @@ nth(cl_fixnum n, cl_object x)
FEtype_error_list(x);
}
@(defun nthcdr (n x)
@
cl_object
cl_nthcdr(cl_object n, cl_object x)
{
@(return nthcdr(fixint(n), x))
@)
}
cl_object
nthcdr(cl_fixnum n, cl_object x)
@ -413,16 +411,8 @@ nthcdr(cl_fixnum n, cl_object x)
@(return x)
@)
@(defun copy_list (x)
@
@(return copy_list(x))
@)
/*
Copy_list(x) copies list x.
*/
cl_object
copy_list(cl_object x)
cl_copy_list(cl_object x)
{
cl_object copy;
cl_object *y = ©
@ -431,19 +421,11 @@ copy_list(cl_object x)
y = &CDR(*y = CONS(CAR(x), Cnil));
} end_loop_for_on;
*y = x;
return copy;
@(return copy);
}
@(defun copy_alist (x)
@
@(return copy_alist(x))
@)
/*
Copy_alist(x) copies alist x.
*/
cl_object
copy_alist(cl_object x)
cl_copy_alist(cl_object x)
{
cl_object copy;
cl_object *y = ©
@ -456,33 +438,32 @@ copy_alist(cl_object x)
y = &CDR(*y);
} end_loop_for_on;
*y = x;
return copy;
@(return copy);
}
@(defun copy_tree (x)
@
@(return copy_tree(x))
@)
/*
Copy_tree(x) returns a copy of tree x.
*/
cl_object
copy_tree(cl_object x)
static cl_object
do_copy_tree(cl_object x)
{
cs_check(x);
if (ATOM(x))
return x;
return CONS(copy_tree(CAR(x)), copy_tree(CDR(x)));
return CONS(do_copy_tree(CAR(x)), do_copy_tree(CDR(x)));
}
@(defun revappend (x y)
@
cl_object
cl_copy_tree(cl_object x)
{
@(return do_copy_tree(x))
}
cl_object
cl_revappend(cl_object x, cl_object y)
{
loop_for_in(x) {
y = CONS(CAR(x),y);
} end_loop_for_in;
@(return y)
@)
}
@(defun nconc (&rest lists)
cl_object x, l,*lastcdr;
@ -577,9 +558,11 @@ cl_nreconc(cl_object l, cl_object y)
@(return lis)
@)
@(defun ldiff (x y)
cl_object
cl_ldiff(cl_object x, cl_object y)
{
cl_object res = Cnil, *fill = &res;
@
loop_for_on(x) {
if (x == y)
break;
@ -587,21 +570,23 @@ cl_nreconc(cl_object l, cl_object y)
fill = &CDR(*fill = CONS(CAR(x), Cnil));
} end_loop_for_on;
@(return res)
@)
}
@(defun rplaca (x v)
@
cl_object
cl_rplaca(cl_object x, cl_object v)
{
assert_type_cons(x);
CAR(x) = v;
@(return x)
@)
}
@(defun rplacd (x v)
@
cl_object
cl_rplacd(cl_object x, cl_object v)
{
assert_type_cons(x);
CDR(x) = v;
@(return x)
@)
}
@(defun subst (new_obj old_obj tree &key test test_not key)
saveTEST;
@ -760,26 +745,17 @@ member_eq(cl_object x, cl_object l)
return(FALSE);
}
@(defun si::memq (x l)
@
cl_object
si_memq(cl_object x, cl_object l)
{
loop_for_in(l) {
if (x == CAR(l))
@(return l)
} end_loop_for_in;
@(return Cnil)
@)
/* Added for use by the compiler, instead of open coding them. Beppe */
cl_object
memq(cl_object x, cl_object l)
{
loop_for_in(l) {
if (x == CAR(l))
return(l);
} end_loop_for_in;
return(Cnil);
}
/* Added for use by the compiler, instead of open coding them. Beppe */
cl_object
memql(cl_object x, cl_object l)
{
@ -820,14 +796,15 @@ PREDICATE2(@member)
@(return list)
@)
@(defun tailp (y x)
@
cl_object
cl_tailp(cl_object y, cl_object x)
{
loop_for_on(x) {
if (x == y)
@(return Ct)
} end_loop_for_on;
@(return ((x == y)? Ct : Cnil))
@)
}
cl_return
@adjoin(int narg, cl_object item, cl_object list, cl_object k1, cl_object v1,

2
src/c/package.d
View file

@ -627,7 +627,7 @@ si_package_lock(cl_object p, cl_object t)
cl_object
cl_list_all_packages()
{
@(return copy_list(package_list))
return cl_copy_list(package_list);
}
@(defun intern (strng &optional (p current_package()) &aux sym)

2
src/c/sequence.d
View file

@ -180,7 +180,7 @@ E:
sequence = CDR(sequence);
}
if (e < 0)
@(return copy_list(sequence))
return cl_copy_list(sequence);
{ cl_object *z = &x;
for (i = 0; i < e; i++) {
if (ATOM(sequence))

2
src/c/symbol.d
View file

@ -289,7 +289,7 @@ cl_symbol_name(cl_object sym)
SYM_VAL(x) = SYM_VAL(sym);
x->symbol.mflag = sym->symbol.mflag;
SYM_FUN(x) = SYM_FUN(sym);
x->symbol.plist = copy_list(sym->symbol.plist);
x->symbol.plist = cl_copy_list(sym->symbol.plist);
@(return x)
@)

26
src/c/symbols_list.h
View file

@ -241,12 +241,12 @@ cl_symbols[] = {
{"CONSP", CL_ORDINARY, cl_consp, 1},
{"CONSTANTLY", CL_ORDINARY, NULL, -1},
{"CONSTANTP", CL_ORDINARY, cl_constantp, 1},
{"COPY-ALIST", CL_ORDINARY, cl_copy_alist, -1},
{"COPY-LIST", CL_ORDINARY, cl_copy_list, -1},
{"COPY-ALIST", CL_ORDINARY, cl_copy_alist, 1},
{"COPY-LIST", CL_ORDINARY, cl_copy_list, 1},
{"COPY-READTABLE", CL_ORDINARY, cl_copy_readtable, -1},
{"COPY-SEQ", CL_ORDINARY, cl_copy_seq, 1},
{"COPY-SYMBOL", CL_ORDINARY, cl_copy_symbol, -1},
{"COPY-TREE", CL_ORDINARY, cl_copy_tree, -1},
{"COPY-TREE", CL_ORDINARY, cl_copy_tree, 1},
{"COS", CL_ORDINARY, cl_cos, 1},
{"COSH", CL_ORDINARY, cl_cosh, 1},
{"COUNT", CL_ORDINARY, NULL, -1},
@ -310,7 +310,7 @@ cl_symbols[] = {
{"ELT", CL_ORDINARY, cl_elt, 2},
{"ENCODE-UNIVERSAL-TIME", CL_ORDINARY, NULL, -1},
{"END-OF-FILE", CL_ORDINARY, NULL, -1},
{"ENDP", CL_ORDINARY, cl_endp, -1},
{"ENDP", CL_ORDINARY, cl_endp, 1},
{"ENOUGH-NAMESTRING", CL_ORDINARY, cl_enough_namestring, -1},
{"ENSURE-DIRECTORIES-EXIST", CL_ORDINARY, NULL, -1},
{"EQ", CL_ORDINARY, cl_eq, 2},
@ -426,7 +426,7 @@ cl_symbols[] = {
{"LCM", CL_ORDINARY, cl_lcm, -1},
{"LDB", CL_ORDINARY, NULL, -1},
{"LDB-TEST", CL_ORDINARY, NULL, -1},
{"LDIFF", CL_ORDINARY, cl_ldiff, -1},
{"LDIFF", CL_ORDINARY, cl_ldiff, 2},
{"LEAST-NEGATIVE-DOUBLE-FLOAT", CL_CONSTANT, NULL, -1},
{"LEAST-NEGATIVE-LONG-FLOAT", CL_CONSTANT, NULL, -1},
{"LEAST-NEGATIVE-SHORT-FLOAT", CL_CONSTANT, NULL, -1},
@ -443,7 +443,7 @@ cl_symbols[] = {
{"LIST", CL_ORDINARY, cl_list, -1},
{"LIST*", CL_ORDINARY, cl_listX, -1},
{"LIST-ALL-PACKAGES", CL_ORDINARY, cl_list_all_packages, 0},
{"LIST-LENGTH", CL_ORDINARY, cl_list_length, -1},
{"LIST-LENGTH", CL_ORDINARY, cl_list_length, 1},
{"LISTEN", CL_ORDINARY, cl_listen, -1},
{"LISTP", CL_ORDINARY, cl_listp, 1},
{"LOAD", CL_ORDINARY, cl_load, -1},
@ -560,9 +560,9 @@ cl_symbols[] = {
{"NSUBSTITUTE", CL_ORDINARY, NULL, -1},
{"NSUBSTITUTE-IF", CL_ORDINARY, NULL, -1},
{"NSUBSTITUTE-IF-NOT", CL_ORDINARY, NULL, -1},
{"NTH", CL_ORDINARY, cl_nth, -1},
{"NTH", CL_ORDINARY, cl_nth, 2},
{"NTH-VALUE", FORM_ORDINARY, NULL, -1},
{"NTHCDR", CL_ORDINARY, cl_nthcdr, -1},
{"NTHCDR", CL_ORDINARY, cl_nthcdr, 2},
{"NULL", CL_ORDINARY, cl_null, 1},
{"NUMBER", CL_ORDINARY, NULL, -1},
{"NUMBERP", CL_ORDINARY, cl_numberp, 1},
@ -667,14 +667,14 @@ cl_symbols[] = {
{"REST", CL_ORDINARY, cl_cdr, 1},
{"RETURN", FORM_ORDINARY, NULL, -1},
{"RETURN-FROM", FORM_ORDINARY, NULL, -1},
{"REVAPPEND", CL_ORDINARY, cl_revappend, -1},
{"REVAPPEND", CL_ORDINARY, cl_revappend, 2},
{"REVERSE", CL_ORDINARY, cl_reverse, 1},
{"ROOM", CL_ORDINARY, NULL, -1},
{"ROTATEF", CL_ORDINARY, NULL, -1},
{"ROUND", CL_ORDINARY, cl_round, -1},
{"ROW-MAJOR-AREF", CL_ORDINARY, cl_row_major_aref, 2},
{"RPLACA", CL_ORDINARY, cl_rplaca, -1},
{"RPLACD", CL_ORDINARY, cl_rplacd, -1},
{"RPLACA", CL_ORDINARY, cl_rplaca, 2},
{"RPLACD", CL_ORDINARY, cl_rplacd, 2},
{"SAFETY", CL_ORDINARY, NULL, -1},
{"SATISFIES", CL_ORDINARY, NULL, -1},
{"SBIT", CL_ORDINARY, NULL, -1},
@ -788,7 +788,7 @@ cl_symbols[] = {
{"SYNONYM-STREAM", CL_ORDINARY, NULL, -1},
{"TAG", CL_ORDINARY, NULL, -1},
{"TAGBODY", FORM_ORDINARY, NULL, -1},
{"TAILP", CL_ORDINARY, cl_tailp, -1},
{"TAILP", CL_ORDINARY, cl_tailp, 2},
{"TAN", CL_ORDINARY, cl_tan, 1},
{"TANH", CL_ORDINARY, cl_tanh, 1},
{"TENTH", CL_ORDINARY, cl_tenth, 1},
@ -994,7 +994,7 @@ cl_symbols[] = {
{"SI::MAKE-VECTOR", SI_ORDINARY, si_make_vector, 6},
{"SI::MANGLE-NAME", SI_ORDINARY, si_mangle_name, -1},
{"SI::MEMBER1", SI_ORDINARY, si_member1, -1},
{"SI::MEMQ", SI_ORDINARY, si_memq, -1},
{"SI::MEMQ", SI_ORDINARY, si_memq, 2},
{"SI::MKDIR", SI_ORDINARY, si_mkdir, 2},
{"SI::OPEN-PIPE", SI_ORDINARY, si_open_pipe, 1},
{"SI::OUTPUT-STREAM-STRING", SI_ORDINARY, si_output_stream_string, 1},

2
src/c/typespec.d
View file

@ -193,7 +193,7 @@ assert_type_proper_list(cl_object p)
{
if (ATOM(p) && p != Cnil)
FEtype_error_list(p);
if (list_length(p) == Cnil)
if (cl_list_length(p) == Cnil)
FEcircular_list(p);
}

27
src/h/external.h
View file

@ -564,6 +564,19 @@ extern cl_object cl_seventh(cl_object x);
extern cl_object cl_eighth(cl_object x);
extern cl_object cl_ninth(cl_object x);
extern cl_object cl_tenth(cl_object x);
extern cl_object cl_endp(cl_object x);
extern cl_object cl_list_length(cl_object x);
extern cl_object cl_nth(cl_object n, cl_object x);
extern cl_object cl_nthcdr(cl_object n, cl_object x);
extern cl_object cl_copy_list(cl_object x);
extern cl_object cl_copy_alist(cl_object x);
extern cl_object cl_copy_tree(cl_object x);
extern cl_object cl_revappend(cl_object x, cl_object y);
extern cl_object cl_ldiff(cl_object x, cl_object y);
extern cl_object cl_rplaca(cl_object x, cl_object v);
extern cl_object cl_rplacd(cl_object x, cl_object v);
extern cl_object cl_tailp(cl_object y, cl_object x);
extern cl_object si_memq(cl_object x, cl_object l);
extern cl_object cl_nreconc(cl_object x, cl_object y);
extern cl_object cl_cons(cl_object x, cl_object y);
extern cl_object cl_acons(cl_object x, cl_object y, cl_object z);
@ -571,22 +584,11 @@ extern cl_object cl_list _ARGS((int narg, ...));
extern cl_object cl_listX _ARGS((int narg, ...));
extern cl_object cl_append _ARGS((int narg, ...));
extern cl_object cl_tree_equal _ARGS((int narg, cl_object x, cl_object y, ...));
extern cl_object cl_endp _ARGS((int narg, cl_object x));
extern cl_object cl_list_length _ARGS((int narg, cl_object x));
extern cl_object cl_nth _ARGS((int narg, cl_object n, cl_object x));
extern cl_object cl_nthcdr _ARGS((int narg, cl_object n, cl_object x));
extern cl_object cl_last _ARGS((int narg, cl_object x, ...));
extern cl_object cl_make_list _ARGS((int narg, cl_object size, ...));
extern cl_object cl_copy_list _ARGS((int narg, cl_object x));
extern cl_object cl_copy_alist _ARGS((int narg, cl_object x));
extern cl_object cl_copy_tree _ARGS((int narg, cl_object x));
extern cl_object cl_revappend _ARGS((int narg, cl_object x, cl_object y));
extern cl_object cl_nconc _ARGS((int narg, ...));
extern cl_object cl_butlast _ARGS((int narg, cl_object lis, ...));
extern cl_object cl_nbutlast _ARGS((int narg, cl_object lis, ...));
extern cl_object cl_ldiff _ARGS((int narg, cl_object x, cl_object y));
extern cl_object cl_rplaca _ARGS((int narg, cl_object x, cl_object v));
extern cl_object cl_rplacd _ARGS((int narg, cl_object x, cl_object v));
extern cl_object cl_subst _ARGS((int narg, cl_object new_obj, cl_object old_obj, cl_object tree, ...));
extern cl_object cl_subst_if _ARGS((int narg, cl_object arg1, cl_object pred, cl_object arg3, cl_object key, cl_object val));
extern cl_object cl_subst_if_not _ARGS((int narg, cl_object arg1, cl_object pred, cl_object arg3, cl_object key, cl_object val));
@ -596,11 +598,9 @@ extern cl_object cl_nsubst_if_not _ARGS((int narg, cl_object arg1, cl_object pre
extern cl_object cl_sublis _ARGS((int narg, cl_object alist, cl_object tree, ...));
extern cl_object cl_nsublis _ARGS((int narg, cl_object alist, cl_object tree, ...));
extern cl_object cl_member _ARGS((int narg, cl_object item, cl_object list, ...));
extern cl_object si_memq _ARGS((int narg, cl_object x, cl_object l));
extern cl_object cl_member_if _ARGS((int narg, cl_object pred, cl_object arg, cl_object key, cl_object val));
extern cl_object cl_member_if_not _ARGS((int narg, cl_object pred, cl_object arg, cl_object key, cl_object val));
extern cl_object si_member1 _ARGS((int narg, cl_object item, cl_object list, ...));
extern cl_object cl_tailp _ARGS((int narg, cl_object y, cl_object x));
extern cl_object cl_adjoin _ARGS((int narg, cl_object item, cl_object list, cl_object k1, cl_object v1, cl_object k2, cl_object v2, cl_object k3, cl_object v3));
extern cl_object cl_pairlis _ARGS((int narg, cl_object keys, cl_object data, ...));
extern cl_object cl_rassoc _ARGS((int narg, cl_object item, cl_object alist, ...));
@ -627,7 +627,6 @@ extern void nsubst(cl_object new_object, cl_object *treep);
extern cl_object sublis(cl_object alist, cl_object tree);
extern void nsublis(cl_object alist, cl_object *treep);
extern bool member_eq(cl_object x, cl_object l);
extern cl_object memq(cl_object x, cl_object l);
extern cl_object memql(cl_object x, cl_object l);
extern cl_object member(cl_object x, cl_object l);
extern cl_object assq(cl_object x, cl_object l);