;;;-*-Lisp-*-

(declare (load '((alan) lspenv init)))

;;;Bitwise macros (BIT-xxx X Y)

;X and Y
(defun (bit-and macro) (form) `(boole 1 . ,(cdr form)))

;X or Y
(defun (bit-or macro) (form) `(boole 7 . ,(cdr form)))

;X and (not Y)
(defun (bit-clear macro) (form) `(boole 4 . ,(cdr form)))

;Right 18. bits of 36. bit word
(defun (rh-bits macro) (form) `(boole 1 #o777777 ,(cadr form)))

;Left 18. bits of 36. bit word
(defun (lh-bits macro) (form) `(boole 1 #o777777 (lsh ,(cadr form) -18.)))

;T if bits are there
(defun (bitp macro) (form) `(not (= 0 (boole 1 . ,(cdr form)))))
(defun (bit-test macro) (form) `(not (= 0 (boole 1 .,(cdr form)))))

;T if bit not there
(defun (nbitp macro) (form) `(= 0 (boole 1 .,(cdr form))))

;(bit-range x |4.8-3.1|)
;Really should be a load byte.  Returns bit range, using ITS bit naming 
(defun (bit-range macro) (form)
  (prog (spec d1 d2 d3 d4)
	(setq spec (caddr form)
	      d1 (- (getcharn spec 1) #/0)
	      d2 (- (getcharn spec 3) #/0)
	      d3 (- (getcharn spec 5) #/0)
	      d4 (- (getcharn spec 7) #/0))
	(cond ((not (and (= (flatc spec) 7)
			 (eq (getchar spec 2) '/.)
			 (eq (getchar spec 4) '/-)
			 (eq (getchar spec 6) '/.)
			 (>= d1 1) (<= d1 4)
			 (>= d2 1) (<= d2 9.)
			 (>= d3 1) (<= d3 4)
			 (>= d4 1) (<= d4 9.)))
	       (error "-- bad bit range." spec 'wrng-type-arg))
	      (t (setq d1 (+ (* 9. (1- d1)) d2 -1)	  ; bit # start
		       d2 (+ (* 9. (1- d3)) d4 -1))	  ; bit # end
		 (unless (> d1 d2)
		   (setq d1 (prog1 d2 (setq d2 d1))))
		 (setq d3 (- d1 d2 -1))	  ; length of mask
		 (let ((shifted (if (zerop d2)
				    (cadr form)
				    `(rot ,(cadr form) ,(- d2)))))
		   (if (= d3 36.)
		       (return shifted)
		       (return `(boole 1 ,(1- (rot 1 d3))
				       ,shifted))))))))

;(rplac-lh word new-lh)
(defmacro rplac-lh (word new)
  `(bit-or (bit-and ,word #o777777) (lsh ,new 18.)))

;(rplac-rh word new-rh)
(defmacro rplac-rh (word new)
  `(bit-or (bit-clear ,word #o777777) ,new))