merging in test - gcl.git - GNU Common Lisp

diff --git a/gcl/cmpnew/gcl_cmpopt.lsp b/gcl/cmpnew/gcl_cmpopt.lsp
index deda86f12..b6d064953 100755
--- a/gcl/cmpnew/gcl_cmpopt.lsp
+++ b/gcl/cmpnew/gcl_cmpopt.lsp

@@ -1270,3 +1270,15 @@ type_of(#0)==t_bitvector")

(push '((fixnum) t #.(compiler::flags) "({object _y=(object)#0;is_imm_fixnum(_y) ? Cnil : (is_imm_fixnum(_y->c.c_cdr) ? _y : (_y->d.f||_y->d.e ? Cnil : _y));})") (get 'si::static-inverse-cons 'compiler::inline-always))

(push '((t) t #.(compiler::flags) "({object _y=(object)fix(#0);is_imm_fixnum(_y) ? Cnil : (is_imm_fixnum(_y->c.c_cdr) ? _y : (_y->d.f||_y->d.e ? Cnil : _y));})") (get 'si::static-inverse-cons 'compiler::inline-unsafe))

(push '((fixnum) t #.(compiler::flags) "({object _y=(object)#0;is_imm_fixnum(_y) ? Cnil : (is_imm_fixnum(_y->c.c_cdr) ? _y : (_y->d.f||_y->d.e ? Cnil : _y));})") (get 'si::static-inverse-cons 'compiler::inline-unsafe))

+

+;;symbol-value

+(push '((t) t #.(compiler::flags) "(#0)->s.s_dbind")

+ (get 'symbol-value 'compiler::inline-unsafe))

+(push '((t) t #.(compiler::flags) "@0;type_of(#0)!=t_symbol ? (not_a_symbol(#0),Cnil) : ((#0)->s.s_dbind==OBJNULL ? (FEerror(\"unbound variable\",0),Cnil) : (#0)->s.s_dbind)")

+ (get 'symbol-value 'compiler::inline-always))

+(push '((symbol) t #.(compiler::flags) "@0;(#0)->s.s_dbind==OBJNULL ? (FEerror(\"unbound variable\",0),Cnil) : (#0)->s.s_dbind")

+ (get 'symbol-value 'compiler::inline-always))

+

+;;acons

+(push '((t t t) t #.(compiler::flags) "MMcons(MMcons((#0),(#1)),(#2))")

+ (get 'acons 'compiler::inline-always))

diff --git a/gcl/lsp/gcl_listlib.lsp b/gcl/lsp/gcl_listlib.lsp
index 7a7170186..7ddc29f6e 100755
--- a/gcl/lsp/gcl_listlib.lsp
+++ b/gcl/lsp/gcl_listlib.lsp

@@ -37,161 +37,91 @@

(proclaim '(optimize (safety 0) (space 3)))

)

-(defun key-list (key test test-not &aux (tem nil))

- (when key (push :key tem) (push key tem))

- (when test (push :test tem) (push test tem))

- (when test-not (push :test-not tem) (push test-not tem))

- (nreverse tem))

-

-;(defun union (list1 list2 &rest rest &key test test-not key)

-; (declare (ignore test test-not key))

-; (cond ((null list1) list2)

-; ((apply #'member1 (car list1) list2 rest)

-; (apply #'union (cdr list1) list2 rest))

-; (t

-; (cons (car list1)

-; (apply #'union (cdr list1) list2 rest)))))

-(defun union (list1 list2 &key test test-not key &aux first last)

- (do ((x list1 (cdr x)))

- ((null x) (if last (rplacd last list2)) (return (or first list2)))

- (or (consp x) (error "UNION not passed a list"))

- (if (not (apply #'member1 (car x) list2 (key-list key test test-not)))

- (if last (progn (rplacd last (cons (car x) nil))

- (setq last (cdr last)))

- (progn (setq first (cons (car x) nil))

- (setq last first)))) ) )

-

-;(defun nunion (list1 list2 &rest rest &key test test-not key)

-; (declare (ignore test test-not key))

-; (cond ((null list1) list2)

-; ((apply #'member1 (car list1) list2 rest)

-; (apply #'nunion (cdr list1) list2 rest))

-; (t

-; (rplacd list1

-; (apply #'nunion (cdr list1) list2 rest)))))

-(defun nunion (list1 list2 &key test test-not key &aux first last)

- (do ((x list1 (cdr x)))

- ((null x) (if last (rplacd last list2)) (return (or first list2)))

- (or (consp x) (error "NUNION not passed a list"))

- (if (not (apply #'member1 (car x) list2 (key-list key test test-not)))

- (progn (if last (rplacd last x)

- (setq first x))

- (setq last x))) ) )

-

-;(defun intersection (list1 list2 &rest rest &key test test-not key)

-; (declare (ignore test test-not key))

-; (cond ((null list1) nil)

-; ((apply #'member1 (car list1) list2 rest)

-; (cons (car list1)

-; (apply #'intersection (cdr list1) list2 rest)))

-; (t (apply #'intersection (cdr list1) list2 rest))))

-

-;; all functions in this file should be written as follows:

-;; Besides being non recursive, it allows compilation on safety 0

-(defun intersection (list1 list2 &key test test-not key &aux ans)

- (do ((x list1 (cdr x)))

- ((null x) (return ans))

- (or (consp x) (error "INTERSECTION not passed a list"))

- (if (apply #'member1 (car x) list2 (key-list key test test-not))

- (setq ans (cons (car x) ans))))

- )

-

-;(defun nintersection (list1 list2 &rest rest &key test test-not key)

-; (declare (ignore test test-not key))

-; (cond ((null list1) nil)

-; ((apply #'member1 (car list1) list2 rest)

-; (rplacd list1

-; (apply #'nintersection (cdr list1) list2 rest)))

-; (t (apply #'nintersection (cdr list1) list2 rest))))

-(defun nintersection (list1 list2 &key test test-not key &aux first last)

- (do ((x list1 (cdr x)))

- ((null x) (if last (rplacd last nil)) (return first))

- (or (consp x) (error "NINTERSECTION not passed a list"))

- (if (apply #'member1 (car x) list2 (key-list key test test-not))

- (progn (if last (rplacd last x)

- (setq first x))

- (setq last x))) ) )

-

-;(defun set-difference (list1 list2 &rest rest &key test test-not key)

-; (declare (ignore test test-not key))

-; (cond ((null list1) nil)

-; ((not (apply #'member1 (car list1) list2 rest))

-; (cons (car list1)

-; (apply #'set-difference (cdr list1) list2 rest)))

-; (t (apply #'set-difference (cdr list1) list2 rest))))

-(defun set-difference (list1 list2 &key test test-not key &aux ans)

- (do ((x list1 (cdr x)))

- ((null x) (return ans))

- (or (consp x) (error "SET-DIFFERENCE not passed a list"))

- (if (not (apply #'member1 (car x) list2 (key-list key test test-not)))

- (setq ans (cons (car x) ans)))) )

-(defun set-difference-rev (list1 list2 &key test test-not key &aux ans)

- (do ((x list1 (cdr x)))

- ((null x) (return ans))

- (or (consp x) (error "SET-DIFFERENCE not passed a list"))

- (if (not (apply #'member1 (car x) list2 :rev t (key-list key test test-not)))

- (setq ans (cons (car x) ans)))) )

-

-;(defun nset-difference (list1 list2 &rest rest &key test test-not key)

-; (declare (ignore test test-not key))

-; (cond ((null list1) nil)

-; ((not (apply #'member1 (car list1) list2 rest))

-; (rplacd list1

-; (apply #'nset-difference (cdr list1) list2 rest)))

-; (t (apply #'nset-difference (cdr list1) list2 rest))))

-(defun nset-difference (list1 list2 &key test test-not key &aux first last)

- (do ((x list1 (cdr x)))

- ((null x) (if last (rplacd last nil)) (return first))

- (or (consp x) (error "NSET-DIFFERENCE not passed a list"))

- (if (not (apply #'member1 (car x) list2 (key-list key test test-not)))

- (progn (if last (rplacd last x)

- (setq first x))

- (setq last x))) ) )

-(defun nset-difference-rev (list1 list2 &key test test-not key &aux first last)

- (do ((x list1 (cdr x)))

- ((null x) (if last (rplacd last nil)) (return first))

- (or (consp x) (error "NSET-DIFFERENCE not passed a list"))

- (if (not (apply #'member1 (car x) list2 :rev t (key-list key test test-not)))

- (progn (if last (rplacd last x)

- (setq first x))

- (setq last x))) ) )

-

-;(defun set-exclusive-or (list1 list2 &rest rest &key test test-not key)

-; (declare (ignore test test-not key))

-; (append (apply #'set-difference list1 list2 rest)

-; (apply #'set-difference list2 list1 rest)))

-(defun set-exclusive-or (list1 list2 &key test test-not key)

- (nconc (apply #'set-difference list1 list2 (key-list key test test-not))

- (apply #'set-difference-rev list2 list1 (key-list key test test-not))))

-

-;(defun nset-exclusive-or (list1 list2 &rest rest &key test test-not key)

-; (declare (ignore test test-not key))

-; (nconc (apply #'set-difference list1 list2 rest)

-; (apply #'nset-difference list2 list1 rest)))

-(defun nset-exclusive-or (list1 list2 &key test test-not key &aux first last fint lint)

- (do ((x list1 (cdr x)))

- ((null x) (if lint (rplacd lint nil))

- (if last

- (progn (rplacd last

- (apply #'nset-difference-rev list2 fint (key-list key test test-not)))

- (return first))

- (return (apply #'nset-difference-rev list2 fint (key-list key test test-not)))))

- (or (consp x) (error "NSET-EXCLUSIVE-OR not passed a list"))

- (if (apply #'member1 (car x) list2 (key-list key test test-not))

- (progn (if lint (rplacd lint x)

- (setq fint x))

- (setq lint x))

- (progn (if last (rplacd last x)

- (setq first x))

- (setq last x))) ) )

-

-(defun subsetp (list1 list2 &key test test-not key)

- (do ((l list1 (cdr l)))

- ((null l) t)

- (or (consp l) (error "SUBSETP not passed a list"))

- (if (not (apply #'member1 (car l) list2 (key-list key test test-not))) (return nil))))

-

+(macrolet

+ ((defl2fn (n &rest body) `(defun ,n (list1 list2 &key key test test-not &aux r rp

+ (key (when key (coerce key 'function)))

+ (test (when test (coerce test 'function)))

+ (test-not (when test-not (coerce test-not 'function))))

+ (macrolet

+ ((check-list (list) `(do ((l ,list (cdr l)))

+ ((not (consp l))

+ (when l (error 'type-error :datum l :expected-type 'list)))))

+ (apply-to-stack (form list) `(let (r rp)

+ (dolist (l ,list r)

+ (let ((tmp (cons ,(if form `(,@form l) `l) nil)))

+ (declare (dynamic-extent tmp))

+ (setq rp (if rp (cdr (rplacd rp tmp)) (setq r tmp)))))))

+ (collect (x) `(let ((temp ,x))

+ (setq rp (if rp (cdr (rplacd rp temp)) (setq r temp)))))

+ (do-test (x z) `(cond (test (funcall test ,x ,z))

+ (test-not (not (funcall test-not ,x ,z)))

+ ((eql ,x ,z))))

+ (memb (item list &optional rev) `(do ((item ,item)(l ,list (cdr l))) ((not l))

+ (let ((cl (car l)))

+ (when (do-test ,@(if rev `(cl item) `(item cl)))

+ (return l))))))

+ (check-list list1)(check-list list2)

+ (let ((klist2 (if key (apply-to-stack (funcall key) list2) list2)))

+ ,@body)))))

+

+ (defl2fn intersection

+ (dolist (l1 list1 r)

+ (when (memb (if key (funcall key l1) l1) klist2)

+ (collect (cons l1 nil)))))

+

+ (defl2fn union

+ (dolist (l1 list1)

+ (unless (memb (if key (funcall key l1) l1) klist2)

+ (collect (cons l1 nil))))

+ (when rp (rplacd rp list2))

+ (or r list2))

+

+ (defl2fn set-difference

+ (dolist (l1 list1 r)

+ (unless (memb (if key (funcall key l1) l1) klist2)

+ (collect (cons l1 nil)))))

+

+ (defl2fn set-exclusive-or

+ (let ((klist1 (if key (apply-to-stack (funcall key) list1) list1)))

+ (do ((kl1 klist1 (cdr kl1))(l1 list1 (cdr l1))) ((not kl1))

+ (unless (memb (car kl1) klist2)

+ (collect (cons (car l1) nil))))

+ (do ((kl2 klist2 (cdr kl2))(l2 list2 (cdr l2))) ((not kl2) r)

+ (unless (memb (car kl2) klist1 t)

+ (collect (cons (car l2) nil))))))

+

+ (defl2fn nintersection

+ (do ((l1 list1 (cdr l1)))((not l1) (when rp (rplacd rp nil)) r)

+ (let ((cl1 (car l1)))

+ (when (memb (if key (funcall key cl1) cl1) klist2)

+ (collect l1)))))

+

+ (defl2fn nunion

+ (do ((l1 list1 (cdr l1)))((not l1) (when rp (rplacd rp list2)) (or r list2))

+ (let ((cl1 (car l1)))

+ (unless (memb (if key (funcall key cl1) cl1) klist2)

+ (collect l1)))))

+

+ (defl2fn nset-difference

+ (do ((l1 list1 (cdr l1)))((not l1) (when rp (rplacd rp nil)) r)

+ (let ((cl1 (car l1)))

+ (unless (memb (if key (funcall key cl1) cl1) klist2)

+ (collect l1)))))

+

+ (defl2fn nset-exclusive-or

+ (let ((klist1 (if key (apply-to-stack (funcall key) list1) (apply-to-stack nil list1))))

+ (do ((kl1 klist1 (cdr kl1))(l1 list1 (cdr l1))) ((not kl1))

+ (unless (memb (car kl1) klist2)

+ (collect l1)))

+ (do ((kl2 klist2 (cdr kl2))(l2 list2 (cdr l2))) ((not kl2) (when rp (rplacd rp nil)) r)

+ (unless (memb (car kl2) klist1 t)

+ (collect l2)))))

+

+ (defl2fn subsetp r rp

+ (dolist (l1 list1 t)

+ (unless (memb (if key (funcall key l1) l1) klist2)

+ (return nil)))))

(defmacro tp-error (x y)

diff --git a/gcl/o/list.d b/gcl/o/list.d
index 1b9339954..b7b9bd212 100755
--- a/gcl/o/list.d
+++ b/gcl/o/list.d

@@ -299,59 +299,67 @@ object list_vector_new(int n,object first,va_list ap)

va_end(ap);

return res;

}*/

+#ifdef WIDE_CONS

+#define maybe_set_type_of(a,b) set_type_of(a,b)

+#else

+#define maybe_set_type_of(a,b)

+#endif

+

+

+#define multi_cons(n_,next_,last_) \

+ ({static struct typemanager *_tm=tm_table+t_cons; \

+ object _lis=OBJNULL; \

+ \

+ if (n<=_tm->tm_nfree) { \

+ \

+ object _tail=_tm->tm_free; \

+ \

+ _lis=_tail; \

+ \

+ BEGIN_NO_INTERRUPT; \

+ \

+ _tm->tm_nfree -= n_; \

+ while (--n_) { \

+ pageinfo(_tail)->in_use++; \

+ maybe_set_type_of(_tail,t_cons); \

+ _tail->c.c_cdr=OBJ_LINK(_tail); \

+ _tail->c.c_car=next_; \

+ _tail=_tail->c.c_cdr; \

+ } \

+ _tm->tm_free=OBJ_LINK(_tail); \

+ pageinfo(_tail)->in_use++; \

+ maybe_set_type_of(_tail,t_cons); \

+ _tail->c.c_car=next_; \

+ _tail->c.c_cdr=SAFE_CDR(last_); \

+ \

+ END_NO_INTERRUPT; \

+ } \

+ _lis;})

+

object listqA(int a,int n,va_list ap) {

- struct typemanager *tm=(&tm_table[(int)t_cons]);

- object tail=tm->tm_free,lis=tail;

+ object x,*p;

if (n<=0) return Cnil;

- CHECK_INTERRUPT;

+ if ((x=multi_cons(n,va_arg(ap,object),a ? va_arg(ap,object) : Cnil))!=OBJNULL)

+ return x;

- if (/* stack_alloc_start || */ tm->tm_nfree < n ) {

-

- object *p = vs_top;

-

- vs_push(Cnil);

- while(--n>=0)

- { *p=make_cons(va_arg(ap,object),Cnil);

- p= &((*p)->c.c_cdr);

- }

- if (a)

- *p=SAFE_CDR(va_arg(ap,object));

- return(vs_pop);

+ CHECK_INTERRUPT;

+ p = vs_top;

+

+ vs_push(Cnil);

+ while(--n>=0) {

+ *p=make_cons(va_arg(ap,object),Cnil);

+ p= &((*p)->c.c_cdr);

}

+ if (a)

+ *p=SAFE_CDR(va_arg(ap,object));

-

- {

-

- BEGIN_NO_INTERRUPT;

-

- tm->tm_nfree -= n;

- while (--n) {

- pageinfo(tail)->in_use++;

-#ifdef WIDE_CONS

- set_type_of(tail,t_cons);

-#endif

- tail->c.c_cdr=OBJ_LINK(tail);

- tail->c.c_car=va_arg(ap,object);

- tail=tail->c.c_cdr;

- }

- tm->tm_free=OBJ_LINK(tail);

- pageinfo(tail)->in_use++;

-#ifdef WIDE_CONS

- set_type_of(tail,t_cons);

-#endif

- tail->c.c_car=va_arg(ap,object);

- tail->c.c_cdr=a ? SAFE_CDR(va_arg(ap,object)) : Cnil;

-

- END_NO_INTERRUPT;

- return lis;

-

- }

+ return(vs_pop);

}

@@ -407,27 +415,56 @@ BEGIN:

}

object

-append(x, y)

-object x, y;

-{

- object z;

-

- if (endp(x))

- return(y);

- z = make_cons(Cnil, Cnil);

- vs_push(z);

- for (;;) {

- z->c.c_car = x->c.c_car;

- x = x->c.c_cdr;

- if (endp(x))

- break;

- z->c.c_cdr = make_cons(Cnil, Cnil);

- z = z->c.c_cdr;

- }

- z->c.c_cdr = SAFE_CDR(y);

- return(vs_pop);

+append(object x, object y) {

+

+ object z;

+ fixnum n;

+

+ if (endp(x))

+ return(y);

+

+ for (z=x,n=0;!endp(z);z=z->c.c_cdr,n++);

+ if ((z=multi_cons(n,({object _t=x->c.c_car;x=x->c.c_cdr;_t;}),y))!=OBJNULL)

+ return z;

+

+ z = make_cons(Cnil, Cnil);

+ vs_push(z);

+ for (;;) {

+ z->c.c_car = x->c.c_car;

+ x = x->c.c_cdr;

+ if (endp(x))

+ break;

+ z->c.c_cdr = make_cons(Cnil, Cnil);

+ z = z->c.c_cdr;

+ }

+ z->c.c_cdr = SAFE_CDR(y);

+ return(vs_pop);

}

+

+

+/* object */

+/* append(x, y) */

+/* object x, y; */

+/* { */

+/* object z; */

+

+/* if (endp(x)) */

+/* return(y); */

+/* z = make_cons(Cnil, Cnil); */

+/* vs_push(z); */

+/* for (;;) { */

+/* z->c.c_car = x->c.c_car; */

+/* x = x->c.c_cdr; */

+/* if (endp(x)) */

+/* break; */

+/* z->c.c_cdr = make_cons(Cnil, Cnil); */

+/* z = z->c.c_cdr; */

+/* } */

+/* z->c.c_cdr = SAFE_CDR(y); */

+/* return(vs_pop); */

+/* } */

+

/*

Copy_list(x) copies list x.

*/

diff --git a/gcl/o/main.c b/gcl/o/main.c
index f57d776ba..e3560c261 100755
--- a/gcl/o/main.c
+++ b/gcl/o/main.c

@@ -883,33 +883,38 @@ FFN(siLuser_init)(void) {

vs_base[0] = Cnil;

}

-static void

-FFN(siLaddress)(void) {

- check_arg(1);

- vs_base[0] = make_fixnum((long)vs_base[0]);

+/* static void */

+/* FFN(siLaddress)(void) { */

+/* check_arg(1); */

+/* vs_base[0] = make_fixnum((long)vs_base[0]); */

+/* } */

+

+DEFUN_NEW("NANI",object,fSnani,SI,1,1,NONE,OI,OO,OO,OO,(fixnum address),"") {

+

+ RETURN1((object)address);

+

}

-static void

-FFN(siLnani)(void) {

- check_arg(1);

+DEFUN_NEW("ADDRESS",object,fSaddress,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") {

- /*This is temporary, 2.6.x does not have 64bit fixnums on 64bit machines*/

- switch (type_of(vs_base[0])) {

- case t_fixnum:

- vs_base[0]=(object)fix(vs_base[0]);

- break;

- case t_bignum:

- if (mpz_fits_slong_p(MP(vs_base[0]))) {

- MP_INT *u = MP(vs_base[0]);

- vs_base[0]=(object)mpz_get_si(u);

- break;

- }

- default:

- FEerror("Cannot coerce ~s to an address",1,vs_base[0]);

- }

+ RETURN1(x);

}

+/* static void */

+/* FFN(siLnani)(void) { */

+/* check_arg(1); */

+

+/* switch (type_of(vs_base[0])) { */

+/* case t_fixnum: */

+/* vs_base[0]=(object)fix(vs_base[0]); */

+/* break; */

+/* default: */

+/* FEerror("Cannot coerce ~s to an address",1,vs_base[0]); */

+/* } */

+

+/* } */

+

static void

FFN(siLinitialization_failure)(void) {

check_arg(0);

@@ -994,8 +999,8 @@ init_main(void) {

make_si_function("RESET-STACK-LIMITS", siLreset_stack_limits);

make_si_function("INIT-SYSTEM", siLinit_system);

make_si_function("USER-INIT", siLuser_init);

- make_si_function("ADDRESS", siLaddress);

- make_si_function("NANI", siLnani);

+ /* make_si_function("ADDRESS", siLaddress); */

+ /* make_si_function("NANI", siLnani); */

make_si_function("INITIALIZATION-FAILURE",

siLinitialization_failure);