;;; -*- Syntax:Common-Lisp; Mode: LISP; Package: (TMS Lisp 1000.); Base: 10. -*-

(in-package 'tms)

"(c) Copyright 1986, 1987, 1988 Xerox Corporation.  All rights reserved.  Subject to
the following conditions, permission is granted to use and copy this
software and to prepare derivative works:  Such use, copying or
preparation of derivative works must be for non-commercial research or
educational purposes; each copy or derivative work must include this
copyright notice in full; a copy of each completed derivative work must
be returned to:  DEKLEER@XEROX.COM (Arpanet) or Johan de Kleer,
Xerox PARC, 3333 Coyote Hill Road, Palo Alto, CA 94304.  This software
is made available AS IS, and Xerox Corporation makes no warranty about
the software or its performance."

;;;; Note convention is that you will never see (n) 0 or 0 (n) or (n) (m)

;;; New Convention: We should never ever touch the n in (n)?  Eventually, we can have
;;; an array of these!

;;; We are adopting the convention that one can clobber the n in (n) with impunity.

;;; This means when copying, these should be copied as well. 

(defvar *+ns* nil)
(defvar *-ns* nil)
(defvar *+2* nil)
(defvar *+3* nil)
(defvar *-2* nil)
(defvar *-3* nil)

(defun build-ns ()
  (setq *+ns* (make-array 200))
  (dotimes (i 200) (setf (aref *+ns* i) (list i)))
  (setq *+2* (aref *+ns* 2))
  (setq *+3* (aref *+ns* 3))
  (setf (aref *+ns* 0) 'ERROR)
  (setf (aref *+ns* 1) 0)
  (setq *-ns* (make-array 200))
  (dotimes (i 200) (setf (aref *-ns* i) (list (- i))))
  (setq *-2* (aref *-ns* 2))
  (setq *-3* (aref *-ns* 3))
  (setf (aref *-ns* 0) 'ERROR)
  (setf (aref *-ns* 1) -1))

;;; This is for debugging, inefficient.
(defun bit-to-blit (bits &aux vector)
  (dolist (b bits)
    (cond ((= b 0) (cond ((null vector) (push 0 vector))
			 ((listp (car vector))
			  (if (> (caar vector) 0)
			      (rplaca vector
				      (aref *+ns* (1+ (caar vector))))
			      (push 0 vector)))
			 ((= (car vector) 0)
			  (rplaca vector *+2*))
			 (t (push 0 vector))))
	  ((= b -1) (cond ((null vector) (push -1 vector))
			  ((listp (car vector))
			   (if (< (caar vector) 0)
			       (rplaca vector
				       (aref *-ns* (1+ (- (caar vector)))))
			       (push -1 vector)))
			  ((= (car vector) -1)
			   (rplaca vector *-2*))
			  (t (push -1 vector))))
	  (t (push b vector))))
  (nreverse vector))

;;; For debugging, inefficient.
(defun copy-blit (blit)
  (mapcar #'(lambda (item) (if (listp item) (list (car item)) item)) blit))

(defun blit-to-bit (blit &aux vector)
  (dolist (b blit)
    (cond ((not (listp b)) (push b vector))
	  ((< (car b) 0) (dotimes (i (- (car b))) (push -1 vector)))
	  ((> (car b) 0) (dotimes (i (car b)) (push 0 vector)))))
  (nreverse vector))

(defun blits-size (vector &aux (size 0))
  (dolist (word vector)
    (cond ((not (listp word))
	   (cond ((= word 0))
		 ((> word 0) (incf size (logcount word)))
		 ((< word 0) (incf size (- *word-size* (logcount word))))))
	  ((< (car word) 0) (incf size (* (car word) #.(- *word-size*))))))
  size)

(defun check-blits-size ()
  (dotimes (i (array-length *environments*))
    (dolist (e (aref *environments* i))
      (unless (= (env-count e) (blits-size (env-vector e)))
	(error "Wrong size")))))

(defun blits-to-assumptions (vector &optional (conses *blits-to-assumptions-conses*)
			     assumptions (offset 0) p (count 0))
  (dolist (word vector)
    (cond ((not (listp word))
	   (unless (= word 0)
	     (dotimes (bit #.*word-size*)
	       (unless (zerop (logand word 1))
		 (setq p (+ offset bit))
		 (rplacd (car conses) assumptions)
		 (rplaca (car conses) (aref *assumption-array* p))
		 (incf count)
		 (setq assumptions (car conses) conses (cdr conses)))
	       (setq word (ash word -1))))
	   (incf offset #.*word-size*))
	  ((> (car word) 0) (incf offset (* (car word) #.*word-size*)))
	  (t (dotimes (i (- (car word)))
	       (dotimes (bit #.*word-size*)
		 (rplacd (car conses) assumptions)
		 (rplaca (car conses) (aref *assumption-array* offset))
		 (setq assumptions (car conses) conses (cdr conses))
		 (incf count)
		 (incf offset))))))
  (values assumptions count conses))

(defun do-assumptions-blits (vector function &aux (count 0) p (offset 0))
  #+Symbolics
  (declare (sys:downward-funarg function))
  (dolist (word vector)
    (cond ((not (listp word))
	   (unless (= word 0)
	     (dotimes (bit #.*word-size*)
	       (unless (zerop (logand word 1))
		 (setq p (+ offset bit))
		 (funcall function (aref *assumption-array* p))
		 (incf count))
	       (setq word (ash word -1))))
	   (incf offset #.*word-size*))
	  ((> (car word) 0) (incf offset (* (car word) #.*word-size*)))
	  (t (dotimes (i (- (car word)))
	       (dotimes (bit #.*word-size*)
		 (funcall function (aref *assumption-array* offset))
		 (incf count)
		 (incf offset))))))
  count)

(defun check-do (&aux assumptions)
  (dotimes (i (array-length *environments*))
    (dolist (e (aref *environments* i))
      (setq assumptions nil)
      (do-assumptions-blits (env-vector e)
			    #'(lambda (a)
				#+Symbolics
				(declare (sys:downward-function))
				(push a assumptions)))
      (setq assumptions (nreverse assumptions))
      (unless (equal (blits-to-assumptions (env-vector e))
		     (nreverse assumptions))
	(error "Can't happen")))))

(defun blits-to-assumptions (vector &optional (conses *blits-to-assumptions-conses*)
			     assumptions (offset 0) p (count 0))
  (dolist (word vector)
    (cond ((not (listp word))
	   (unless (= word 0)
	     (dotimes (bit #.*word-size*)
	       (unless (zerop (logand word 1))
		 (setq p (+ offset bit))
		 (rplacd (car conses) assumptions)
		 (rplaca (car conses) (aref *assumption-array* p))
		 (incf count)
		 (setq assumptions (car conses) conses (cdr conses)))
	       (setq word (ash word -1))))
	   (incf offset #.*word-size*))
	  ((> (car word) 0) (incf offset (* (car word) #.*word-size*)))
	  (t (dotimes (i (- (car word)))
	       (dotimes (bit #.*word-size*)
		 (rplacd (car conses) assumptions)
		 (rplaca (car conses) (aref *assumption-array* offset))
		 (setq assumptions (car conses) conses (cdr conses))
		 (incf count)
		 (incf offset))))))
  (values assumptions count conses))

(defun check-blits-to-assumptions ()
  (dotimes (i (array-length *environments*))
    (dolist (e (aref *environments* i))
      (unless (equal (blits-to-assumptions (env-vector e))
		     (env-assumptions e))
	(error "Can't happen")))))

;;;***** break coded is overused.

(defun remove-assumption-blits-test (blit assumption &aux r1 r2)
  (setq r1 (remove-assumption-blits blit assumption)
	r2 (bit-to-blit (remove-assumption-bits (blit-to-bit blit) assumption)))
  (unless (vector-equal r1 r2) (error "Unequal"))
  r1)

;;; The deal is this can't clobber anything of vector.
(defun remove-assumption-blits (vector assumption &aux word offset end)
  (setq vector (fcopylist vector)
	offset (assumption-offset assumption))
  ;; Find the word.**** Doesn't exploite (2)(3) can't happen.
  (do ((tail vector (cdr tail))
       (preprevious nil previous)		; Need to kill trailing 0s.
       (previous nil tail))
      ((null tail))
    (cond ((= offset 0)
	   (cond ((listp (car tail))
		  (cond ((> (caar tail) 0))
			((= (caar tail) -2)
			 (rplaca tail (logandc2 -1 (assumption-bits assumption)))
			 (rplacd tail (cons -1 (cdr tail))))
			(t (rplacd tail (cons (aref *-ns* (- -1 (caar tail))) (cdr tail)))
			   (rplaca tail (logandc2 -1 (assumption-bits assumption)))))
		  (return nil))
		 (t (setq word (logandc2 (car tail) (assumption-bits assumption)))
		    (cond ((not (zerop word))
			   (rplaca tail word) (return nil))
			  ;; If we are end of the vector, we have to get rid of trailing 0s.
			  ((null (cdr tail))

			   (cond ((null previous) (return-from remove-assumption-blits nil))
				 ((if (listp (car previous))
				      (> (caar previous) 0)
				      (zerop (car previous)))
				  (cond ((null preprevious) (return nil))
					(t (rplacd preprevious nil) (return nil))))
				 (t (rplacd previous nil))))
			  ;; Is the previous 0?
			  (t (cond ((and previous (listp (car previous)) (> (caar previous) 0))
				    (when (cdr tail)
				      (cond ((listp (cadr tail))
					     (cond ((> (caadr tail) 0)
						    (rplaca previous
							    (aref *+ns* (+ 1 (caar previous)
									   (caadr tail))))
						    (rplacd previous (cddr tail))
						    (return nil))))
					    ((zerop (cadr tail))
					     (rplaca previous
						     (aref *+ns* (+ (caar previous) 2)))
					     (rplacd previous (cddr tail))
					     (return nil))))
				    (rplaca previous (aref *+ns* (+ 1 (caar previous))))
				    (rplacd previous (cdr tail))
				    (return nil))
				   ((and previous (zerop (car previous)))
				    (when (cdr tail)
				      (cond ((listp (cadr tail))
					     (when (> (caadr tail) 0)
					       (rplaca previous
						       (aref *+ns* (+ 2 (caadr tail))))
					       (rplacd previous (cddr tail))
					       (return nil)))
					    ((zerop (cadr tail))
					     (rplaca previous *+3*)
					     (rplacd previous (cddr tail))
					     (return nil))))
				    (rplaca previous *+2*)
				    (rplacd previous (cdr tail))
				    (return nil))
				   (t (cond ((and (cdr tail) (listp (cadr tail))
						  (> (caadr tail) 0))
					     (rplaca tail (aref *+ns* (+ 1 (caadr tail))))
					     (rplacd tail (cddr tail))
					     (return nil))
					    ((and (cdr tail) (zerop (cadr tail)))
					     (rplaca tail *+2*)
					     (rplacd tail (cddr tail))
					     (return nil))
					    (t (rplaca tail 0)
					       (return nil))))))))))
	  ((not (listp (car tail))) (decf offset))
	  ((> (caar tail) 0) (setq offset (- offset (caar tail)))
	   (if (< offset 0) (return nil)))
	  ((< (setq offset (+ (setq end offset) (caar tail))) 0)
	   (rplaca tail (aref *-ns* end))
	   (rplacd tail (cons (logandc2 -1 (assumption-bits assumption)) (cdr tail)))
	   (incf offset)
	   (setq tail (cdr tail))
	   (unless (= offset 0)
	     (rplacd tail (cons (aref *-ns* (- offset)) (cdr tail))))
	   (return nil))))
  vector)

;;; ******* optimize.  Create a macro**********
(defun remove-assumption-blits-unsafe (vector assumption &aux word offset end)
  (setq offset (assumption-offset assumption))
  ;; Find the word.**** Doesn't exploite (2)(3) can't happen.
  (do ((tail vector (cdr tail))
       (preprevious nil previous)		; Need to kill trailing 0s.
       (previous nil tail))
      ((null tail))
    (cond ((= offset 0)
	   (cond ((listp (car tail))
		  (cond ((> (caar tail) 0))
			((= (caar tail) -2)
			 (rplaca tail (logandc2 -1 (assumption-bits assumption)))
			 (rplacd tail (cons -1 (cdr tail))))
			(t (rplacd tail (cons (aref *-ns* (- -1 (caar tail))) (cdr tail)))
			   (rplaca tail (logandc2 -1 (assumption-bits assumption)))))
		  (return nil))
		 (t (setq word (logandc2 (car tail) (assumption-bits assumption)))
		    (cond ((not (zerop word))
			   (rplaca tail word) (return nil))
			  ;; If we are end of the vector, we have to get rid of trailing 0s.
			  ((null (cdr tail))

			   (cond ((null previous) (return-from remove-assumption-blits-unsafe nil))
				 ((if (listp (car previous))
				      (> (caar previous) 0)
				      (zerop (car previous)))
				  (cond ((null preprevious) (return nil))
					(t (rplacd preprevious nil) (return nil))))
				 (t (rplacd previous nil))))
			  ;; Is the previous 0?
			  (t (cond ((and previous (listp (car previous)) (> (caar previous) 0))
				    (when (cdr tail)
				      (cond ((listp (cadr tail))
					     (cond ((> (caadr tail) 0)
						    (rplaca previous
							    (aref *+ns* (+ 1 (caar previous)
									   (caadr tail))))
						    (rplacd previous (cddr tail))
						    (return nil))))
					    ((zerop (cadr tail))
					     (rplaca previous
						     (aref *+ns* (+ (caar previous) 2)))
					     (rplacd previous (cddr tail))
					     (return nil))))
				    (rplaca previous (aref *+ns* (+ 1 (caar previous))))
				    (rplacd previous (cdr tail))
				    (return nil))
				   ((and previous (zerop (car previous)))
				    (when (cdr tail)
				      (cond ((listp (cadr tail))
					     (when (> (caadr tail) 0)
					       (rplaca previous
						       (aref *+ns* (+ 2 (caadr tail))))
					       (rplacd previous (cddr tail))
					       (return nil)))
					    ((zerop (cadr tail))
					     (rplaca previous *+3*)
					     (rplacd previous (cddr tail))
					     (return nil))))
				    (rplaca previous *+2*)
				    (rplacd previous (cdr tail))
				    (return nil))
				   (t (cond ((and (cdr tail) (listp (cadr tail))
						  (> (caadr tail) 0))
					     (rplaca tail (aref *+ns* (+ 1 (caadr tail))))
					     (rplacd tail (cddr tail))
					     (return nil))
					    ((and (cdr tail) (zerop (cadr tail)))
					     (rplaca tail *+2*)
					     (rplacd tail (cddr tail))
					     (return nil))
					    (t (rplaca tail 0)
					       (return nil))))))))))
	  ((not (listp (car tail))) (decf offset))
	  ((> (caar tail) 0) (setq offset (- offset (caar tail)))
	   (if (< offset 0) (return nil)))
	  ((< (setq offset (+ (setq end offset) (caar tail))) 0)
	   (rplaca tail (aref *-ns* end))
	   (rplacd tail (cons (logandc2 -1 (assumption-bits assumption)) (cdr tail)))
	   (incf offset)
	   (setq tail (cdr tail))
	   (unless (= offset 0)
	     (rplacd tail (cons (aref *-ns* (- offset)) (cdr tail))))
	   (return nil))))
  vector)

;;;****** Most times this is sorted.
(defun make-env-vector-blits-test (assumptions &optional max &aux r1 r2)
  (setq r1 (make-env-vector-blits assumptions max)
	r2 (bit-to-blit (make-env-vector-bits* assumptions)))
  (unless (vector-equal r1 r2) (error "Unequal"))
  r1)


(defun make-env-vector-blits-debug (assumptions &optional max &aux r1 r2)
  (setq r1 (make-env-vector-blits-new assumptions max)
	r2 (make-env-vector-blits-old assumptions max))
  (unless (equal r1 r2) (error "Unequal"))
  r1)

;;; This does not assume that assumptions is sorted, it should *****
(defun make-env-vector-blits (assumptions &optional max &aux vector blotsize word)
  ;;; Max is irrelevant here.
  max
  (dolist (assumption assumptions)
    (do ((offset (assumption-offset assumption))
	 (v vector (cdr v))
	 (previous nil v))
	((null v)
	 (cond (previous
		(cond ((= offset 0) (rplacd previous
					    (cons (assumption-bits assumption) nil)))
		      (t (rplacd previous
				 (cons (aref *+ns* offset)
				       (cons (assumption-bits assumption) nil))))))
	       (t (cond ((= offset 0) (setq vector
					    (cons (assumption-bits assumption) nil)))
			(t (setq vector
				 (cons (aref *+ns* offset)
				       (cons (assumption-bits assumption) nil)))))))
	 )
      (cond ((= offset 0)
	     (cond ((not (listp (car v)))
		    (setq word (logior (car v) (assumption-bits assumption)))
		    (cond ((not (= word -1))
			   (rplaca v word))
			  (previous
			   (cond ((listp (car previous))
				  (cond ((< (caar previous) 0)
					 (cond ((listp (cadr v))
						(cond ((and (cdr v) (< (caadr v) 0))
						       ;; Put unique (-n) back!
						       (rplaca previous
							       (aref *-ns* (- (+
										(caar previous)
										-1
										(caadr v)))))
						       (rplacd previous (cddr v)))
						      (t (rplaca previous
								 (aref *-ns*
								       (- 1 (caar previous))))
							 (rplacd previous (cdr v)))))
					       ((= (cadr v) -1)
						(rplaca previous
							(aref *-ns* (- 2 (caar previous))))
						(rplacd previous (cddr v)))
					       (t (rplaca previous
							  (aref *-ns*
								(+ (- (caar previous)) -1)))
						  (rplacd previous (cdr v)))))
					;; previous is 0-run, end of vector.
					((null (cdr v)) (rplaca v -1))
					;; previous is 0-run, next is a run.
					((listp (cadr v))
					 (cond ((< (caadr v) 0)
						;; previous is non-1, next is a -1-run.
						;; Throw away a cons.
						(setq v (cdr v))
						(rplaca v (aref *-ns* (- 1 (caar v))))
						(rplacd previous v))
					       ;; previous is 0-run, next is a 0-run
					       (t (rplaca v -1))))
					;; previous is a 0-run, next is a non-run.
					((= (cadr v) -1)
					 (rplaca v *-2*)
					 (rplacd v (cddr v)))
					(t (rplaca v word))))
				 ;; Previous is not a run.
				 ((= (car previous) -1)
				  (cond ((cdr v)
					 (cond ((listp (cadr v))
						(cond ((< (caadr v) 0)
						       (rplaca previous
							       (aref *-ns* (- 2 (caadr v))))
						       (rplacd previous (cddr v)))
						      (t (rplaca previous *-2*)
							 (rplacd previous (cdr v)))))
					       ;;**** could recycle the cons we are
					       ;; discarding here.
					       ((= (cadr v) -1)
						;;** recycle cons?
						(rplaca previous *-3*)
						(rplacd previous (cddr v)))
					       (t (rplaca previous *-2*)
						  (rplacd previous (cdr v)))))
					;;** throwing away a cons-- use it.
					(t (rplaca previous *-2*)
					   (rplacd previous (cdr v)))))
				 ;;***** combined next tests?
				 ;; Previous is not -1, end of vector.
				 ((null (cdr v)) (rplaca v -1))
				 ;; Previous is not -1, next is not a run.
				 ((not (listp (cadr v)))
				  (cond ((= (cadr v) -1)
					 (rplaca v *-2*)
					 (rplacd v (cddr v)))
					(t (rplaca v -1))))
				 ((> (caadr v) 0) (rplaca v -1))
				 ;; non-1, -1, (-n).
				 (t (rplaca v (aref *-ns* (- 1 (caadr v))))
				    (rplacd v (cddr v)))))
			  ;; No previous, end-of-vector:
			  ((null (cdr v)) (rplaca v -1))
			  ;; No previous, not a follows.
			  ((not (listp (cadr v)))
			   (cond ((= (cadr v) -1) (rplaca v *-2*) (rplacd v (cddr v)))
				 (t (rplaca v -1))))
			  ((> (caadr v) 0) (rplaca v -1))
			  ;; No previous, following is negative.
			  (t (rplaca v (aref *-ns* (- 1 (caadr v))))
			     (rplacd v (cddr v)))))
		   ;; If unioning into a -1, ignore it.
		   ((< (caar v) 0))
		   ;; Unioning into a 0 exactly here.
		   (t (if previous
			  (rplacd previous (cons (assumption-bits assumption) v))
			  (setq vector (cons (assumption-bits assumption) v)))
		      (rplaca v (aref *+ns* (1- (caar v))))))
	     (return nil))
	    ;; If were not looking at a run, just decrement the offset.
	    ((not (listp (car v))) (decf offset))
	    ;; If this is a run of zeros.
	    ((> (caar v) 0)
	     (cond ((>= offset (caar v))
		    (setq offset (- offset (caar v))))
		   ;; Last of run, dual of offset=0.
		   ((= (1- offset) (caar v))
		    (rplacd v (cons (assumption-bits assumption) (cdr v)))
		    (rplaca v (aref *+ns* (1- (caar v))))
		    (return nil))
		   (t (setq blotsize (caar v))
		      (cond ((= offset 1) (rplaca v 0))
			    (t (rplaca v (aref *+ns* offset))))
		      (setq blotsize (- blotsize 1 offset))
		      (rplacd v
			      (cons (assumption-bits assumption)
				    (cond ((= blotsize 0) (cdr v))
					  ((= blotsize 1) (cons 0 (cdr v)))
					  (t (cons (aref *+ns* blotsize) (cdr v))))))
		      (return ))))
	     ;; Else this is a run of -1's, if it is outside this section of -1s, ignore this.
	    ((>= offset (- (caar v)))
	     (setq offset (+ offset (caar v))))
	    ;; Within this section of -1s, return.
	    (t (return nil)))))
  vector)

(defun vector-intersection-blits-test? (v1 v2 &aux r1 r2)
  (setq r1 (vector-intersection-blits? v1 v2)
	r2 (vector-intersection-bits? (blit-to-bit v1) (blit-to-bit v2)))
  (unless (vector-equal r1 r2) (error "Unequal"))
  r1)

(defun vector-intersection-blits? (v1 v2 &aux i1 i2 c1 c2)
  (prog nil
	
     START
	(unless v1 (return nil))
	(unless v2 (return nil))

	(setq i1 (car v1) i2 (car v2) v1 (cdr v1) v2 (cdr v2))

	(when (listp i1)
	  (setq c1 (car i1))
	  (go SKIP2))
	
	(when (listp i2)
	  (setq c2 (car i2))
	  (go skip1))
	   
     TEST

	   (unless (zerop (logand i1 i2))
	     (return T))
	   (go start)

	   ;; Skip c1 elements along in v2.

     SKIP2

	   (if (< c1 0) (go SKIPO?))

     SKIPZ?

	   (cond ((listp i2)
		  (setq c2 (car i2))
		  (cond ((< c2 0) (go SKIPZO))
			((= c2 c1) (go START))
			((> c1 c2)
			 (setq c1 (- c1 c2 1) v2 (cdr v2))
			 (if (= c1 0) (go START))	;**could optimize.
			 (or v2 (return nil))
			 (setq i2 (car v2) v2 (cdr v2))
			 (go SKIPZ?))
			(t (setq c2 (- c2 c1 1) v1 (cdr v1))
			   (if (= c2 0) (go START))
			   (or v1 (return nil))
			   (setq i1 (car v1) v1 (cdr v1) )
			   (go SKIP1))))
		 ((= c1 1) (go START))	;** canbe better.
		 ((null v2) (return nil))	
		 (t (decf c1) (setq i2 (car v2) v2 (cdr v2)) (go SKIPZ?)))

  SKIPZO  (cond ((= (- c2) c1) (go START))
		((> c1 (- c2))
		 ;;**** optimize adding and subtracting.
		 (setq c1 (- c1 (- c2)))
		 ;;**** I suspect the following line is redundant.
		 (or v2 (return nil))
		 (setq i2 (car v2) v2 (cdr v2))
		 (go SKIPZ?))
		(t (setq c2 (+ c2 c1 1) v1 (cdr v1))
		   (if (= c2 0) (go START))
		   (or v1 (return nil))
		   (setq i1 (car v1) v1 (cdr v1) )
		   (go SKIP1)))

  SKIPO?  (cond ((listp i2)
		 (setq c2 (car i2))
		 (cond ((< c2 0) (return T))
		       ;;**** can be optimized better.***** two many adds/subs.
		       ((= c2 (- c1)) (go START))
		       ((> (- c1) c2)
			(setq c1 (+ c1 c2 1) v2 (cdr v2))
			(if (= c1 0) (go START))	;**could optimize.
			(or v2 (return nil))
			(setq i2 (car v2) v2 (cdr v2))
			(go SKIPO?))
		       (t (setq c2 (- c2 (- c1)))
			  ;; c2 must be positive, we must skip.
			  ;; ***** this may be redundant:
			  (or v1 (return nil))
			  (setq i1 (car v1) v1 (cdr v1) )
			  (go SKIP1))))
		((= c1 -1) (go START))
		((null v2) (return nil))
		(t (incf c1) (setq i2 (car v2) v2 (cdr v2)) (go SKIPO?)))

     SKIP1
	   (psetq c1 c2 c2 c1 i1 i2 i2 i1 v1 v2 v2 v1)
	   (go SKIP2)))



(defun vector-cons4-blits-test (assumption vector &aux r1 r2)
  (setq r1 (vector-cons4-blits assumption vector)
	r2 (bit-to-blit (vector-cons4-bits* assumption (blit-to-bit vector))))
  (unless (vector-equal r1 r2) (error "Unequal"))
  r1)

;;; This returns fresh list structure always.
(defun vector-cons4-blits (assumption vector &aux blotsize word)
  ;;***** Don't need to copy whole thing.
  (setq vector (fcopylist vector))
  (do ((offset (assumption-offset assumption))
       (v vector (cdr v))
       (previous nil v))
      ((null v)
       (cond (previous
	      (if (= offset 0)
		  (rplacd previous (cons (assumption-bits assumption) nil))
		  (rplacd previous (cons (aref *+ns* offset)
					 (cons (assumption-bits assumption) nil)))))
	     (t (setq vector
		      (if (= offset 0)
			  (cons (assumption-bits assumption) nil)
			  (cons (aref *+ns* offset)
				(cons (assumption-bits assumption) nil))))))
       )
    (cond ((= offset 0)
	   (cond ((not (listp (car v)))
		  (setq word (logior (car v) (assumption-bits assumption)))
		  (cond ((not (= word -1))
			 (rplaca v word))
			(previous
			 (cond ((listp (car previous))
				(cond ((< (caar previous) 0)
				       (cond ((listp (cadr v))
					      (cond ((and (cdr v) (< (caadr v) 0))
						     (rplaca previous
							     (aref *-ns*
								   (- 1
								      (caar previous)
								      (caadr v))))
						     (rplacd previous (cddr v)))
						    (t (rplaca previous
							       (aref *-ns*
								     (- 1 (caar previous))))
						       (rplacd previous (cdr v)))))
					       ((= (cadr v) -1)
						(rplaca previous
							(aref *-ns* (- 2 (caar previous))))
						(rplacd previous (cddr v)))
					       (t (rplaca previous
							  (aref *-ns* (- 1 (caar previous))))
						  (rplacd previous (cdr v)))))
					;; previous is 0-run, end of vector.
					((null (cdr v)) (rplaca v -1))
					;; previous is 0-run, next is a run.
					((listp (cadr v))
					 (cond ((< (caadr v) 0)
						;; previous is non-1, next is a -1-run.
						(setq v (cdr v))
						(rplaca v (aref *-ns* (- 1 (caar v))))
						(rplacd previous v))
					       ;; previous is 0-run, next is a 0-run
					       (t (rplaca v -1))))
					;; previous is a 0-run, next is a non-run.
					((= (cadr v) -1)
					 ;;** recycle the cons?
					 (rplaca v *-2*)
					 (rplacd v (cddr v)))
					(t (rplaca v word))))
				 ;; Previous is not a run.
				 ((= (car previous) -1)
				  (cond ((cdr v)
					 (cond ((listp (cadr v))
						(cond ((< (caadr v) 0)
						       (rplaca previous
							       (aref *-ns*
								     (- 2 (caadr v))))
						       (rplacd previous (cddr v)))
						      (t (rplaca previous *-2*)
							 (rplacd previous (cdr v)))))
					       ;;**** could recycle the cons we are
					       ;; discarding here.
					       ((= (cadr v) -1)
						;;** recycle cons?
						(rplaca previous *-3*)
						(rplacd previous (cddr v)))
					       (t (rplaca previous *-2*)
						  (rplacd previous (cdr v)))))
					;;** throwing away a cons-- use it.
					(t (rplaca previous *-2*)
					   (rplacd previous (cdr v)))))
				 ;;***** combined next tests?
				 ;; Previous is not -1, end of vector.
				 ((null (cdr v)) (rplaca v -1))
				 ;; Previous is not -1, next is not a run.
				 ((not (listp (cadr v)))
				  (cond ((= (cadr v) -1)
					 (rplaca v *-2*)
					 (rplacd v (cddr v)))
					(t (rplaca v -1))))
				 ((> (caadr v) 0) (rplaca v -1))
				 ;; non-1, -1, (-n).
				 (t (rplaca v (aref *-ns* (- 1 (caadr v))))
				    (rplacd v (cddr v)))))
			  ;; No previous, end-of-vector:
			  ((null (cdr v)) (rplaca v -1))
			  ;; No previous, not a follows.
			  ((not (listp (cadr v)))
			   (cond ((= (cadr v) -1) (rplaca v *-2*) (rplacd v (cddr v)))
				 (t (rplaca v -1))))
			  ((> (caadr v) 0) (rplaca v -1))
			  (t (rplaca v (aref *-ns* (- 1 (caadr v))))
			     ;;** above cons could be recycled.
			     (rplacd v (cddr v))
			     )))
		   ;; If unioning into a -1, ignore it.
		   ((< (caar v) 0))
		   ;; Unioning into a 0 exactly here.
		   (t (if previous
			  (rplacd previous (cons (assumption-bits assumption) v))
			  (setq vector (cons (assumption-bits assumption) v)))
		      (rplaca v (aref *+ns* (1- (caar v))))))
	     (return nil))
	    ;; If were not looking at a run, just decrement the offset.
	    ((not (listp (car v))) (decf offset))
	    ;; If this is a run of zeros.
	    ((> (caar v) 0)
	     (cond ((>= offset (caar v))
		    (setq offset (- offset (caar v))))
		   ;; Last of run, dual of offset=0.
		   ((= (1- offset) (caar v))
		    (rplacd v (cons (assumption-bits assumption) (cdr v)))
		    (rplaca v (aref *+ns* (1- (caar v))))
		    (return nil))
		   (t (setq blotsize (caar v))
		      (cond ((= offset 1) (rplaca v 0))
			    (t (rplaca v (aref *+ns* offset))))
		      (setq blotsize (- blotsize 1 offset))
		      (rplacd v
			      (cons (assumption-bits assumption)
				    (cond ((= blotsize 0) (cdr v))
					  (t (cons (aref *+ns* blotsize) (cdr v))))))
		      (return ))))
	     ;; Else this is a run of -1's, if it is outside this section of -1s, ignore this.
	    ((>= offset (- (caar v)))
	     (setq offset (+ offset (caar v))))
	    ;; Within this section of -1s, return.
	    (t (return nil))))
  vector)


(defmacro vector-cons3-blits-macro ()
  `(progn
  (do ((offset (assumption-offset assumption))
       (v vector (cdr v))
       (previous nil v))
      ((null v)
       (cond (previous
	      (if (= offset 0)
		  (rplacd previous (cons (assumption-bits assumption) nil))
		  (rplacd previous (cons (aref *+ns* offset)
					 (cons (assumption-bits assumption) nil)))))
	     (t (setq vector
		      (if (= offset 0)
			  (cons (assumption-bits assumption) nil)
			  (cons (aref *+ns* offset)
				(cons (assumption-bits assumption) nil)))))))
    (cond ((= offset 0)
	   (cond ((not (listp (car v)))
		  (setq word (logior (car v) (assumption-bits assumption)))
		  (cond ((not (= word -1))
			 (rplaca v word))
			(previous
			 (cond ((listp (car previous))
				(cond ((< (caar previous) 0)
				       (cond ((listp (cadr v))
					      (cond ((and (cdr v) (< (caadr v) 0))
						     (rplaca previous
							     (aref *-ns*
								   (- 1
								      (caar previous)
								      (caadr v))))
						     (rplacd previous (cddr v)))
						    (t (rplaca previous
							       (aref *-ns*
								     (- 1 (caar previous))))
						       (rplacd previous (cdr v)))))
					       ((= (cadr v) -1)
						(rplaca previous
							(aref *-ns* (- 2 (caar previous))))
						(rplacd previous (cddr v)))
					       (t (rplaca previous
							  (aref *-ns* (- 1 (caar previous))))
						  (rplacd previous (cdr v)))))
					;; previous is 0-run, end of vector.
					((null (cdr v)) (rplaca v -1))
					;; previous is 0-run, next is a run.
					((listp (cadr v))
					 (cond ((< (caadr v) 0)
						;; previous is non-1, next is a -1-run.
						(setq v (cdr v))
						(rplaca v (aref *-ns* (- 1 (caar v))))
						(rplacd previous v))
					       ;; previous is 0-run, next is a 0-run
					       (t (rplaca v -1))))
					;; previous is a 0-run, next is a non-run.
					((= (cadr v) -1)
					 ;;** recycle the cons?
					 (rplaca v *-2*)
					 (rplacd v (cddr v)))
					(t (rplaca v word))))
				 ;; Previous is not a run.
				 ((= (car previous) -1)
				  (cond ((cdr v)
					 (cond ((listp (cadr v))
						(cond ((< (caadr v) 0)
						       (rplaca previous
							       (aref *-ns*
								     (- 2 (caadr v))))
						       (rplacd previous (cddr v)))
						      (t (rplaca previous *-2*)
							 (rplacd previous (cdr v)))))
					       ;;**** could recycle the cons we are
					       ;; discarding here.
					       ((= (cadr v) -1)
						;;** recycle cons?
						(rplaca previous *-3*)
						(rplacd previous (cddr v)))
					       (t (rplaca previous *-2*)
						  (rplacd previous (cdr v)))))
					;;** throwing away a cons-- use it.
					(t (rplaca previous *-2*)
					   (rplacd previous (cdr v)))))
				 ;;***** combined next tests?
				 ;; Previous is not -1, end of vector.
				 ((null (cdr v)) (rplaca v -1))
				 ;; Previous is not -1, next is not a run.
				 ((not (listp (cadr v)))
				  (cond ((= (cadr v) -1)
					 (rplaca v *-2*)
					 (rplacd v (cddr v)))
					(t (rplaca v -1))))
				 ((> (caadr v) 0) (rplaca v -1))
				 ;; non-1, -1, (-n).
				 (t (rplaca v (aref *-ns* (- 1 (caadr v))))
				    (rplacd v (cddr v)))))
			  ;; No previous, end-of-vector:
			  ((null (cdr v)) (rplaca v -1))
			  ;; No previous, not a follows.
			  ((not (listp (cadr v)))
			   (cond ((= (cadr v) -1) (rplaca v *-2*) (rplacd v (cddr v)))
				 (t (rplaca v -1))))
			  ((> (caadr v) 0) (rplaca v -1))
			  (t (rplaca v (aref *-ns* (- 1 (caadr v))))
			     ;;** above cons could be recycled.
			     (rplacd v (cddr v))
			     )))
		   ;; If unioning into a -1, ignore it.
		   ((< (caar v) 0))
		   ;; Unioning into a 0 exactly here.
		   (t (if previous
			  (rplacd previous (cons (assumption-bits assumption) v))
			  (setq vector (cons (assumption-bits assumption) v)))
		      (rplaca v (aref *+ns* (1- (caar v))))))
	     (return nil))
	    ;; If were not looking at a run, just decrement the offset.
	    ((not (listp (car v))) (decf offset))
	    ;; If this is a run of zeros.
	    ((> (caar v) 0)
	     (cond ((>= offset (caar v))
		    (setq offset (- offset (caar v))))
		   ;; Last of run, dual of offset=0.
		   ((= (1- offset) (caar v))
		    (rplacd v (cons (assumption-bits assumption) (cdr v)))
		    (rplaca v (aref *+ns* (1- (caar v))))
		    (return nil))
		   (t (setq blotsize (caar v))
		      (cond ((= offset 1) (rplaca v 0))
			    (t (rplaca v (aref *+ns* offset))))
		      (setq blotsize (- blotsize 1 offset))
		      (rplacd v
			      (cons (assumption-bits assumption)
				    (cond ((= blotsize 0) (cdr v))
					  (t (cons (aref *+ns* blotsize) (cdr v))))))
		      (return ))))
	     ;; Else this is a run of -1's, if it is outside this section of -1s, ignore this.
	    ((>= offset (- (caar v)))
	     (setq offset (+ offset (caar v))))
	    ;; Within this section of -1s, return.
	    (t (return nil))))
  vector))

(defun vector-cons3-blits-test (assumption vector &optional ignore &aux r1 r2)
  (setq r2 (bit-to-blit (vector-cons4-bits* assumption (blit-to-bit vector)))
	r1 (vector-cons3-blits assumption vector))
  (unless (vector-equal r1 r2)
    (let ((original (remove-assumption-blits r2 assumption)))
      (error "Unequal")))
  r1)

;;; This is allowed to clobber its first argument.
(defun vector-cons3-blits (assumption vector &aux blotsize word)
  (vector-cons3-blits-macro))

;;; This is a cons-free version.  This is a hack fix some day soon.***
(defun vector-cons3-unsafe (assumption vector conses &aux blotsize word)
  (macrolet ((cons (a b) `(cons-unsafe ,a ,b))
	     (push (a b) `(push-unsafe ,a ,b)))
    (values (vector-cons3-blits-macro) conses)))

(defun vector-member-blits-test (a v &aux r1 r2)
  (setq r1 (vector-member-blits a v)
	r2 (vector-member-bits a (blit-to-bit v)))
  (unless (vector-equal r1 r2) (error "Unequal"))
  r1)

;;; Must return fresh list structure.  Is it worth cdr-coding this??*******

;;; If the vectors get long, stepping with cddddr might be much more efficient.
(defun vector-member-blits (a v &aux word)
  (when v
    (prog ((i (assumption-offset a)))
       LOOP
	  (setq word (car v))
	  (cond ((listp word)
		 (cond ;; If within the run of 1's, return T.
		       ((< (car word) 0)
			(incf i (car word))
			(if (< i 0) (return T)))
		       ;; If within the run of 0's, return NIL.
		       (t (decf i (car word))
			  (if (< i 0) (return nil))))
		 (setq v (cdr v))
		 (if v (go LOOP) (return nil)))
		((= i 0) (return (not= 0 (logand (assumption-bits a) word))))
		((setq v (cdr v)) (decf i) (if v (go LOOP) (return nil)))
		(t (return nil))))))

(defun vector-union-new-blits-test (v1 v2 &aux r1 r2)
  (setq r1 (vector-union-new-blits v1 v2)
	r2 (bit-to-blit (vector-union-new-bits (blit-to-bit v1) (blit-to-bit v2))))
  (unless (vector-equal r1 r2) (error "Unequal"))
  r1)

;;;***** pick shortest first?  IS that worth it?
;;; Remember this version is permitted to recycle old structure, but not side afect.

;;; Is (n) ever clobbered.  This assumes yes.  But that is probably not right.***

;;; This returns fresh list structure always.

;;; This returns FRESH list structure always.
;;; Must return fresh list structure.  Is it worth cdr-coding this??*******

;;; ***** note that this does not return fresh '(n).****** it should.
;;; Then it should be clobbered.
(defun vector-union-new-blits (v1 v2 &aux vector c d word)
  (unless v1 (error "HI"))
  (unless v2 (error "BYE"))


  (prog nil
     START

	(if (null v1) (go END))
	(when (null v2) (psetq v1 v2 v2 v1) (go END))

     START1

	(cond ((listp (car v1))
	       (setq c (caar v1) v1 (cdr v1))
	       (if (> c 0) (go V1-IS-ZERO) (go V1-IS-ONE)))
	      ((listp (car v2))
	       (setq c (caar v2) v2 (cdr v2))
	       (if (> c 0) (go V2-IS-ZERO) (go V2-IS-ONE))))

     START2

	(setq word (logior (car v1) (car v2)))
	(cond ((or (null vector) (not (= word -1))) (push word vector))
	      ((equal (car vector) -1)
	       (rplaca vector *-2*))
	      ((and (listp (car vector)) (< (caar vector) 0))
	       (rplaca vector (aref *-ns* (1+ (- (caar vector))))))
	      (t (push word vector)))
	(setq v1 (cdr v1) v2 (cdr v2))
	(go START)

     V1-IS-ZERO
	(cond ((= c 0) (go START))
	      ;; Note that v1 could no tend on a zero so v1 is non-nil here.
	      ((null v2) (return (nreconc vector (cons (aref *+ns* c) v1))))
	      ((not (listp (car v2)))
	       (decf c)
	       (cond ((not (equal (car v2) -1)))
		     ((null vector))
		     ((equal (car vector) -1)
		      (rplaca vector *-2*)
		      (setq v2 (cdr v2))
		      (go V1-IS-ZERO))
		     ((and (listp (car vector)) (< (caar vector) 0))
		      (rplaca vector (aref *-ns* (1+ (- (caar vector)))))
		      (setq v2 (cdr v2))
		      (go V1-IS-ZERO)))
	       (push (car v2) vector) (setq v2 (cdr v2)) (go V1-IS-ZERO))
	      ((< (caar v2) 0)
	       (setq d (+ (caar v2) c))
	       ;; Put (-n) onto the vector.
	       ;; Special case the situation where vector is empty.
	       ;;***** can be made more efficient.
	       (cond ((null vector) (setq vector (cons (car v2) nil)))
		     ((or (equal (car vector) -1)
			  (and (listp (car vector)) (< (caar vector) 0)))
		      (rplaca vector (aref *-ns* (1+ (- (caar v2))))))
		     (t (push (car v2) vector)))
	       (setq v2 (cdr v2))
	       (cond ((= 0 d) (go START))
		     ((> d 0) (setq c d) (go V1-IS-ZERO))
		     (t (setq c (- d)) (go V2-IS-ONE-LOOP))))
	      ((= 0 (setq d (- (caar v2) c)))
	       (push (car v2) vector) (setq v2 (cdr v2)) (go START))
	      ((> d 0) (push (aref *+ns* c) vector) (setq c d v2 (cdr v2))
	       (go V2-IS-ZERO))
	      (t (push (car v2) vector)
		 (setq c (- d)) ;;;**** d not neesary.
		 (setq v2 (cdr v2))
		 (go V1-IS-ZERO)))
     V2-IS-ZERO
	(psetq v1 v2 v2 v1)
	(GO V1-IS-ZERO)
     V1-IS-ONE	
	;; **** this dispatch can be made more efficient.
	(cond ((null vector) (setq vector (cons (aref *-ns* (- c)) nil)))
	      ((equal (car vector) -1)
	       (rplaca vector (aref *-ns* (- 1 c))))
	      ((and (listp (car vector)) (< c 0))
	       (rplaca vector (aref *-ns* (1+ (- (caar vector))))))
	      (t (push (aref *-ns* (- c)) vector)))
	;; Skip ahead -c, -c is already on vector.
     V1-IS-ONE-LOOP
	(cond ((= c 0) (go START))
	      ((null v2) (return (nreconc vector v1)))
	      ((not (listp (car v2)))
	       (incf c) (setq v2 (cdr v2)) (go V1-IS-ONE-LOOP))
	      ((< (caar v2) 0)
	       (setq d (- (caar v2) c)
		     v2 (cdr v2))
	       (cond ((= d 0) (go START))
		     ((> d 0) (rplaca vector (aref *-ns* (- d (caar vector))))
			      (setq c (- d))
		              (psetq v1 v2 v2 v1)
			      (go V1-IS-ONE-LOOP))
		     (t (setq c (- d)) (go V1-IS-ONE-LOOP))))
	      ((= 0 (setq d (+ (caar v2) c))) (setq v2 (cdr v2)) (go START))
	      ((> d 0) (setq c d v2 (cdr v2)) (go V2-IS-ZERO))
	      (t (setq c d v2 (cdr v2)) (go V1-IS-ONE-LOOP)))
     V2-IS-ONE
	(psetq v1 v2 v2 v1)
	(go V1-IS-ONE)
     V2-IS-ONE-LOOP
	(psetq v1 v2 v2 v1)
	(go V1-IS-ONE-LOOP)
     END
	;; V1 is null, know nothing about V2.
        (cond ((null vector) (return (fcopylist v2)))
	      ((null v2) (return (nreverse vector)))
	      ((equal (car vector) -1)
	       (cond ((equal (car v2) -1)
		      (rplaca vector *-2*)
		      (return (nreconc vector (fcopylist (cdr v2)))))
		     ((and (listp (car v2)) (< (caar v2) 0))
		      (rplaca vector (aref *-ns* (- 1 (caar v2))))
		      (return (nreconc vector (fcopylist (cdr v2)))))
		     (t (return (nreconc vector (fcopylist v2))))))
	      ((and (listp (car vector)) (< (caar vector) 0))
	       (cond ((equal (car v2) -1)
		      (rplaca vector (aref *-ns* (- 1 (caar vector))))
		      (return (nreconc vector (fcopylist (cdr v2)))))
		     ((and (listp (car v2)) (< (caar v2) 0))
		      (rplaca vector (aref *-ns* (- (+ (caar v2) (caar vector)))))
		      (return (nreconc vector (fcopylist (cdr v2)))))
		     (t (return (nreconc vector (fcopylist v2))))))
	      (t (return (nreconc vector (fcopylist v2)))))
))

;;; This reuses as much as the old structure as it can.  But it can't side affect it.
;;; Notice that vector-union-new-blits and vector-union-blits are basically the same.
;;; so any change in one should propagate to the other.
;;; ****Careful thought could probably reduce the number of conses here.
;;;;****** IF this works clean it up.
(defmacro vector-union-macro ()
  `(prog nil
     START

	(if (null v1) (go END))
	(when (null v2) (psetq v1 v2 v2 v1) (go END))

     START1

	(cond ((listp (car v1))
	       (setq c (caar v1) v1 (cdr v1))
	       (if (> c 0) (go V1-IS-ZERO) (go V1-IS-ONE)))
	      ((listp (car v2))
	       (setq c (caar v2) v2 (cdr v2))
	       (if (> c 0) (go V2-IS-ZERO) (go V2-IS-ONE))))

     START2

	(setq word (logior (car v1) (car v2)))
	(cond ((or (null vector) (not (= word -1))) (push word vector))
	      ((equal (car vector) -1)
	       (rplaca vector *-2*))
	      ((and (listp (car vector)) (< (caar vector) 0))
	       (rplaca vector (aref *-ns* (- 1 (caar vector)))))
	      (t (push word vector)))
	(setq v1 (cdr v1) v2 (cdr v2))
	(go START)

     V1-IS-ZERO
	(cond ((= c 0) (go START))
	      ;; Note that v1 could no tend on a zero so v1 is non-nil here.
	      ((null v2) (return (nreconc vector (cons (aref *+ns* c) v1))))
	      ((not (listp (car v2)))
	       (decf c)
	       (cond ((not (equal (car v2) -1)))
		     ((null vector))
		     ((equal (car vector) -1)
		      (rplaca vector *-2*)
		      (setq v2 (cdr v2))
		      (go V1-IS-ZERO))
		     ((and (listp (car vector)) (< (caar vector) 0))
		      (rplaca vector (aref *-ns* (- 1 (caar vector))))
		      (setq v2 (cdr v2))
		      (go V1-IS-ZERO)))
	       (push (car v2) vector) (setq v2 (cdr v2)) (go V1-IS-ZERO))
	      ((< (caar v2) 0)
	       (setq d (+ (caar v2) c))
	       ;; Put (-n) onto the vector.
	       ;; Special case the situation where vector is empty.
	       ;;***** can be made more efficient.
	       (cond ((null vector) (setq vector (cons (car v2) nil)))
		     ((or (equal (car vector) -1)
			  (and (listp (car vector)) (< (caar vector) 0)))
		      (rplaca vector (aref *-ns* (1+ (- (caar v2))))))
		     (t (push (car v2) vector)))
	       (setq v2 (cdr v2))
	       (cond ((= 0 d) (go START))
		     ((> d 0) (setq c d) (go V1-IS-ZERO))
		     (t (setq c (- d)) (go V2-IS-ONE-LOOP))))
	      ((= 0 (setq d (- (caar v2) c)))
	       (push (car v2) vector) (setq v2 (cdr v2)) (go START))
	      ((> d 0) (push (aref *+ns* c) vector) (setq c d v2 (cdr v2))
	       (go V2-IS-ZERO))
	      (t (push (car v2) vector)
		 (setq c (- d)) ;;;**** d not neesary.
		 (setq v2 (cdr v2))
		 (go V1-IS-ZERO)))
     V2-IS-ZERO
	(psetq v1 v2 v2 v1)
	(GO V1-IS-ZERO)
     V1-IS-ONE	
	;; **** this dispatch can be made more efficient.
	(cond ((null vector) (setq vector (cons (aref *-ns* (- c)) nil)))
	      ((equal (car vector) -1)
	       (rplaca vector (aref *-ns* (- 1 c))))
	      ((and (listp (car vector)) (< c 0))
	       (rplaca vector (aref *-ns* (- c (caar vector)))))
	      (t (push (aref *-ns* (- c)) vector)))
	;; Skip ahead -c, -c is already on vector.
     V1-IS-ONE-LOOP
	(cond ((= c 0) (go START))
	      ((null v2) (return (nreconc vector v1)))
	      ((not (listp (car v2)))
	       (incf c) (setq v2 (cdr v2)) (go V1-IS-ONE-LOOP))
	      ((< (caar v2) 0)
	       (setq d (- (caar v2) c)
		     v2 (cdr v2))
	       (cond ((= d 0) (go START))
		     ((> d 0) (rplaca vector (aref *-ns* (- d (caar vector))))
			      (setq c (- d))
		              (psetq v1 v2 v2 v1)
			      (go V1-IS-ONE-LOOP))
		     (t (setq c (- d)) (go V1-IS-ONE-LOOP))))
	      ((= 0 (setq d (+ (caar v2) c))) (setq v2 (cdr v2)) (go START))
	      ((> d 0) (setq c d v2 (cdr v2)) (go V2-IS-ZERO))
	      (t (setq c d v2 (cdr v2)) (go V1-IS-ONE-LOOP)))
     V2-IS-ONE
	(psetq v1 v2 v2 v1)
	(go V1-IS-ONE)
     V2-IS-ONE-LOOP
	(psetq v1 v2 v2 v1)
	(go V1-IS-ONE-LOOP)
     END
	;; V1 is null.
        (cond ((null vector) (return v2))
	      ((null v2) (return (nreverse vector)))
	      ((equal (car vector) -1)
	       (cond ((equal (car v2) -1)
		      (rplaca vector *-2*)
		      (return (nreconc vector (cdr v2))))
		     ((and (listp (car v2)) (< (caar v2) 0))
		      (rplaca vector (aref *-ns* (- 1 (caar v2))))
		      (return (nreconc vector (cdr v2))))
		     (t (return (nreconc vector v2)))))
	      ((and (listp (car vector)) (< (caar vector) 0))
	       (cond ((equal (car v2) -1)
		      (rplaca vector (aref *-ns* (- 1 (caar vector))))
		      (return (nreconc vector (cdr v2))))
		     ((and (listp (car v2)) (< (caar v2) 0))
		      (rplaca vector (aref *-ns* (- (+ (caar v2) (caar vector)))))
		      (return (nreconc vector (cdr v2))))
		     (t (return (nreconc vector v2)))))
	      (t (return (nreconc vector v2))))
	))

(defun vector-union-blits (v1 v2 &aux vector c d word)
  (vector-union-macro))

;;; This is a cons-free version.  This is a hack fix some day soon.***
(defun vector-union-unsafe-blits (v1 v2 conses &aux vector c d word)
  (macrolet ((cons (a b) `(cons-unsafe ,a ,b))
	     (push (a b) `(push-unsafe ,a ,b)))
    (values (vector-union-macro) conses)))

;;; Can be tuned somewhat****
;;; Think about ((-3) ..) (-1 )
;;;****** Needs doing.

(defun vector-subset-blits-test (v1 v2 &aux r1 r2)
  (setq r1 (vector-subset-blits v1 v2)
	r2 (vector-subset-bits (blit-to-bit v1) (blit-to-bit v2)))
  (unless (vector-equal r1 r2) (error "Unequal"))
  r1)

(defun vector-subset-blits (v1 v2 &aux c1 c2)
  (prog nil

	START

;	   (print (list 'start v1 v2))

	   (if (null v1) (return T))
	   (if (null v2) (return nil))

	   (when (listp (car v1))
	     (setq c1 (caar v1) v1 (cdr v1))
	     (if (< c1 0) (go SKIPO?) (go SKIP2)))

	   (when (listp (car v2))
	     (setq c2 (caar v2))
	     (if (> c2 0) (return nil))
	     (setq v2 (cdr v2) c2 (- c2))
	     (go SKIP?O))
	   
	   (if (not-subset-bits (car v1) (car v2)) (return nil))

	   (setq v1 (cdr v1) v2 (cdr v2))

	   

	   (go START)

	SKIPO?
	   (cond ((or (null v2)
		      (not (listp (car v2)))
		      (> (caar v2) 0)
		      (< c1 (caar v2)))
		  (return nil))
		 ((= c1 (caar v2)) (setq v2 (cdr v2)) (go START))
		 (t (setq c2 (- c1 (caar v2)) v2 (cdr v2))
		    (go SKIP?O)))

	SKIP?O	;; v2 is -1's.	Could cdr earlier*****

;	   (print (list 'SKIP?O c2 v1 v2))

	   (cond ((null v1) (return T))
		 ((= c2 0) (go START))
		 ((not (listp (car v1)))
		  (decf c2)
		  (setq v1 (cdr v1))
		  (go SKIP?O))
		 (t (setq c1 (caar v1) v1 (cdr v1))
		    (cond ((> c1 0)
			   (setq c1 (- c1 c2))
			   (cond ((> c1 0)
				  (go SKIP2))
				 ((= c1 0)
				  (go START))
				 (t (setq c2 (- c1)) (go SKIP?O))))
			  (t (setq c1 (+ c2 c1))
			     (cond ((> c1 0) (setq c2 c1) (go SKIP?O))
				   ((= c1 0) (go START))
				   (t (return nil)))))))

	SKIP2

;	   (print (list 'skip2 c1 v1 v2))

	   (cond ((null v2) (return nil))	; Can't be trailing 0.
		 
		 ((= c1 0) (go START))

		 ((not (listp (car v2)))
		  (decf c1)
		  (setq v2 (cdr v2))
		  (go SKIP2))

		 ((> (setq c2 (caar v2)) 0)
		  (cond ((> c1 c2) (setq c1 (- c1 c2) v2 (cdr v2)) (go SKIP2))
			((= c1 c2) (setq v2 (cdr v2)) (go START))
			(t (return nil))))
		 ((= (setq c1 (+ c1 c2)) 0) (setq v2 (cdr v2)) (go START))
		 ((> c1 0) (setq v2 (cdr v2)) (go SKIP2))
		 (t (setq v2 (cdr v2) c2 (- c1)) (go SKIP?O)))))

;;; This is like above, but it returns the first assumption if not subset, nil if subset.
(defun vector-subset-info-blits (v1 v2 &aux c1 c2 (c 0) w)
  (prog nil

	START


;	   (print (list 'start v1 v2))



	   (when (null v1) (return nil))
	   (unless v2 (go FIND-FAIL))

	   (when (listp (car v1))
	     (setq c1 (caar v1) v1 (cdr v1))
	     (cond ((< c1 0) (go SKIPO?))
		   (t (incf c c1) (go SKIP2))))

	   (when (listp (car v2))
	     (setq c2 (caar v2))
	     (if (> c2 0) (go FIND-FAIL))
	     (setq v2 (cdr v2) c2 (- c2))
	     (go SKIP?O))
	   
	   (setq w (logand (car v1) (lognot (car v2))))

	   (unless (zerop w) (go FAIL))

	   (setq v1 (cdr v1) v2 (cdr v2))

	   (incf c)

	   (go START)

	SKIPO?
	   (cond ((or (null v2)
		      (not (listp (car v2)))
		      (> (caar v2) 0))
		  (setq w -1)
		  (go FAIL))
		 ((< c1 (caar v2))
		  (setq w -1)
		  (incf c)
		  (go FAIL))
		 ((= c1 (caar v2)) (setq v2 (cdr v2))
		  (decf c c1)
		  (go START))
		 (t (setq c2 (- c1 (caar v2)) v2 (cdr v2))
		    (decf c c1)
		    (go SKIP?O)))

	SKIP?O	;; v2 is -1's.	Could cdr earlier*****

;	   (print (list 'SKIP?O c2 v1 v2))


	   (cond ((null v1) (return nil))
		 ((= c2 0) (go START))
		 ((not (listp (car v1)))
		  (decf c2)
		  (incf c)
		  (setq v1 (cdr v1))
		  (go SKIP?O))
		 (t (setq c1 (caar v1) v1 (cdr v1))
		    (cond ((> c1 0)
			   (incf c c1)
			   (setq c1 (- c1 c2))
			   (cond ((> c1 0)
				  (go SKIP2))
				 ((= c1 0)
				  (go START))
				 (t (setq c2 (- c1)) (go SKIP?O))))
			  (t (decf c c1)
			     (setq c1 (+ c2 c1))
			     (cond ((> c1 0) (setq c2 c1) (go SKIP?O))
				   ((= c1 0) (go START))
				   ;; The word at the end can't possibly match.
				   (t (incf c c1)
				      (setq w -1)
				      (and v2 (not (listp (car v2)))
					   (setq w (lognot (car v2))))
				      (go FAIL)))))))

	SKIP2

;	   (print (list 'skip2 c1 v1 v2))

	   ;; Come here if we have a run of 0's in v1, skip ahead in v2.

	   (cond ((null v2)
		  (setq w -1)
		  (and v1 (not (listp (car v1))) (setq w (car v1)))
		  (go FAIL))	; Can't be trailing 0.
		 
		 ((= c1 0) (go START))

		 ((not (listp (car v2)))
		  (decf c1)
		  (setq v2 (cdr v2))
		  (go SKIP2))

		 ((> (setq c2 (caar v2)) 0)
		  (cond ((> c1 c2) (setq c1 (- c1 c2) v2 (cdr v2)) (go SKIP2))
			((= c1 c2) (setq v2 (cdr v2)) (go START))
			(t ;; If v2 has more zeros, we know we've lost.
			   (setq w (car v1))
			   (go FAIL))))
		 ((= (setq c1 (+ c1 c2)) 0) (setq v2 (cdr v2)) (go START))
		 ((> c1 0) (setq v2 (cdr v2)) (go SKIP2))
		 (t (setq v2 (cdr v2) c2 (- c1)) (go SKIP?O)))
	FIND-FAIL
;	   (print 'find-fail)
	   ;; Find first non-zero word in v1.
	   (setq w (car v1))
	   (cond ((not (listp w))
		  (when (zerop w)
		    (setq v1 (cdr v1))
		    (incf c)
		    (go FIND-FAIL)))
		 ((< (car w) 0) (setq w -1))
		 ((> (car w) 0)
		  (incf c (car w))
		  (setq v1 (cdr v1))
		  (go FIND-FAIL)))

	FAIL
;	   (print 'fail)

	   ;; W is the word, c is the word offset.

	   (if (= w 0) (error "Not possible"))
	   (dotimes (bit #.*word-size* (error "Drop through error"))
	     (unless (zerop (logand w 1))
	       (return-from vector-subset-info-blits
		 (aref *assumption-array* (+ bit (* c #.*word-size*)))))	
	     (setq w (ash w -1)))
	   ))

;;; The (-n) (n) are unique now.  So we 
(defun vector-equal-blits-debug (l1 l2 &aux r1 r2)
  (setq r1 (vector-equal-bits l1 l2)
	r2 (vector-equal-blots l1 l2))
  (unless (eq r1 r2) (error "Mismatch!"))
  r1)

(defun install-blits ()
  (setq *break-coded* nil)

  (unless *-ns* (build-ns))


  (setf (symbol-function 'vector-union-unsafe) #'vector-union-unsafe-blits)

  (setf (symbol-function 'vector-subset-info) #'vector-subset-info-blits)
  (setf (symbol-function 'vector-equal) #'vector-equal-bits)
  (setf (symbol-function 'nmap-assumptions) #'error)
  (setf (symbol-function 'nnvector-assumptions) #'error)
  ;****** temporary.
  (setf (symbol-function 'vector-cons4) #'vector-cons4-blits)
  (setf (symbol-function 'vector-intersection2?) #'error)
  (setf (symbol-function 'vector-intersection?) #'vector-intersection-blits?)
  (setf (symbol-function 'vector-subset) #'vector-subset-blits)
  (setf (symbol-function 'vector-subset2) #'error)
  (setf (symbol-function 'vector-union) #'vector-union-blits)
  (setf (symbol-function 'vector-union-new) #'vector-union-new-blits)
  ;**** old clobbers its first arg.  Maybe wide-union should use it?
  ;;*** old is not exploited.
  (setf (symbol-function 'vector-union-old) #'vector-union-blits)
  (setf (symbol-function 'make-env-vector) #'make-env-vector-blits)
  (setf (symbol-function 'vector-member) #'vector-member-blits)
  ;;*** my understanding is that make-env-vector* does not presumed sortedness.
  (setf (symbol-function 'make-env-vector*) #'make-env-vector-blits)
  (setf (symbol-function 'vector-cons1) #'error)
  (setf (symbol-function 'vector-cons3) #'vector-cons3-blits)
  (setf (symbol-function 'basic-make-assumption-internal)
	#'basic-make-assumption-internal-bits)
  (setf (symbol-function 'construct-vector-run) #'error)
  #-Symbolics
  (format T "~% Warning, you need to write a decent hash function (blhash) for your machine.")
  ;;;**** this hash is wierd check it out if it works for blots.
  ;;;* hash-blots is probably ok.
  (setf (symbol-function 'hash) #'hash-blots)
  (setf (symbol-function 'vector-andc2) #'error)
  (setf (symbol-function 'remove-assumption) #'remove-assumption-blits)
  )

(defun install-blits-test ()
  (setq *break-coded* nil)
  (setf (symbol-function 'vector-equal) #'vector-equal-blots)
  (setf (symbol-function 'nmap-assumptions) #'error)
  (setf (symbol-function 'nnvector-assumptions) #'error)
  ;****** temporary.
  (setf (symbol-function 'vector-cons4) #'vector-cons4-blits-test)
  (setf (symbol-function 'vector-intersection2?) #'error)
  (setf (symbol-function 'vector-intersection?) #'vector-intersection-blits-test?)
  (setf (symbol-function 'vector-subset) #'vector-subset-blits-test)
  (setf (symbol-function 'vector-subset2) #'error)
  (setf (symbol-function 'vector-union) #'vector-union-new-blits-test)
  ;;;********* the different union functions can be better.
  (setf (symbol-function 'vector-union-new) #'vector-union-new-blits-test)
  ;**** old clobbers its first arg.  Maybe wide-union should use it?
  (setf (symbol-function 'vector-union-old) #'vector-union-new-blits-test)
  (setf (symbol-function 'make-env-vector) #'make-env-vector-blits-test)
  (setf (symbol-function 'vector-member) #'vector-member-blits-test)
  (setf (symbol-function 'make-env-vector*) #'make-env-vector-blits-test)

  (setf (symbol-function 'vector-cons1) #'error)
  ;;***** can do better:
  (setf (symbol-function 'vector-cons3) #'vector-cons3-blits-test)
;  (setf (symbol-function 'vector-cons3) #'error)

  (setf (symbol-function 'basic-make-assumption-internal)
	#'basic-make-assumption-internal-bits)
  (setf (symbol-function 'construct-vector-run) #'error)
  #-Symbolics
  (format T "~% Warning, you need to write a decent hash function (blhash) for your machine.")
  ;;;**** this hash is wierd check it out if it works for blots.
  ;;;* hash-blots is probably ok.
  (setf (symbol-function 'hash) #'hash-blots)
  (setf (symbol-function 'vector-andc2) #'error)
  (setf (symbol-function 'remove-assumption) #'remove-assumption-blits-test)
  )