From bfcc390d7fd0fc6dc45ff2a13cffb61260260dba Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Mon, 18 Nov 2002 11:23:52 +0000 Subject: [PATCH] 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. --- src/c/compiler.d | 2 +- src/c/list.d | 127 ++++++++++++++++++------------------------- src/c/package.d | 2 +- src/c/sequence.d | 2 +- src/c/symbol.d | 2 +- src/c/symbols_list.h | 26 ++++----- src/c/typespec.d | 2 +- src/h/external.h | 27 +++++---- 8 files changed, 83 insertions(+), 107 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index d5a76f5e6..c9ff9e7fd 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -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); diff --git a/src/c/list.d b/src/c/list.d index 6f139f980..b7abfa521 100644 --- a/src/c/list.d +++ b/src/c/list.d @@ -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, diff --git a/src/c/package.d b/src/c/package.d index 325653df2..c38692fd9 100644 --- a/src/c/package.d +++ b/src/c/package.d @@ -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) diff --git a/src/c/sequence.d b/src/c/sequence.d index b34c490d5..7ecd2ba0d 100644 --- a/src/c/sequence.d +++ b/src/c/sequence.d @@ -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)) diff --git a/src/c/symbol.d b/src/c/symbol.d index bb815d3df..34c198604 100644 --- a/src/c/symbol.d +++ b/src/c/symbol.d @@ -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) @) diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 9e3c3ccc1..b005c6df4 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -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}, diff --git a/src/c/typespec.d b/src/c/typespec.d index 702716792..309146bb6 100644 --- a/src/c/typespec.d +++ b/src/c/typespec.d @@ -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); } diff --git a/src/h/external.h b/src/h/external.h index bcc7563eb..9c19f1810 100644 --- a/src/h/external.h +++ b/src/h/external.h @@ -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);