;;;   LODBYT	-*-MODE:LISP;PACKAGE:SI-*-		  -*-LISP-*-
;;;   **************************************************************
;;;   ***** MACLISP ******* BYTE-manipulation Macros ***************
;;;   **************************************************************
;;;   ** (C) COPYRIGHT 1981 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;;   ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;;   **************************************************************


(eval-when (eval compile)
   (and (status feature PDP10) 
	(error '|Don't really need this file for PDP10 MacLISP or for NIL|))
)

(herald LODBYT /42)


#Q 
(globalize "LDB" "DPB" "LOAD-BYTE" "DEPOSIT-BYTE")


(eval-when (eval compile)
   (setq word-size #Q 24.  #-Lispm 36.)
   (macro lispdir (x)
	(setq x (cadr x))
	#+Lispm   (string-append "lisp;" (get-pname x) "qfasl")
	#+Multics (catenate ">exl>lisp_dir>object" (get_pname x))
	)
)

(eval-when (eval compile)
  (macro subload (x)
	(setq x (cadr x))
	`(OR (GET ',x 'VERSION) (LOAD #%(LISPDIR ,x))))
)

(defmacro SI:PICK-A-MASK (size)  `(LSH -1 (- ,size #.word-size)))



;;;; LOAD-BYTE, DEPOSIT-BYTE

(defmacro LOAD-BYTE  (word position size &AUX byte-len)
    ;Similar to PDP-10 LDB, but "position" and "size" are separate
   (and (not (atom size)) (setq size (macroexpand size)))
   (and (not (atom position)) (setq position (macroexpand position)))
   (cond ((|constant-p/|| size)
	  (setq byte-len (eval size))
	  (unless (and (fixnump byte-len) 
		       (not (< byte-len 0))
		       (not (> byte-len #.word-size)))
		  (error '|Bad byte-length - LOAD-BYTE| size))
	  (cond ((= byte-len 0) ''0)
		((= byte-len #.word-size) `,word)
		((|constant-p/|| position)
		 (setq position (eval position))
		 (unless (and (fixnump position)
			      (not (< position 0)) 
			      (not (> (+ position byte-len) #.word-size)))
			 (error '|Bad position - LOAD-BYTE| position))
		 `(LDB ,(+ (lsh position 6) byte-len) ,word))
		(`(BOOLE 1 (LSH ,word (- ,position)) 
			   ,(si:pick-a-mask byte-len)))))
	 ((or (|side-effectsp/|| position)
	      (|side-effectsp/|| size)
	      (|side-effectsp/|| (setq word (macroexpand word))))
	  `(*LOAD-BYTE ,word ,position ,size))
	 (`(BOOLE 1 (LSH ,word (- ,position)) (SI:PICK-A-MASK ,size)))))


(defmacro DEPOSIT-BYTE 
	  (word position size val &AUX byte-len byte-mask nval)
   (setq word (macroexpand word)  position (macroexpand position)
	 size (macroexpand size)  val (macroexpand val))
   (cond ((|constant-p/|| size)
	  (setq byte-len (eval size))
	  (unless (and (fixnump byte-len) 
		       (not (< byte-len 0)) 
		       (not (> byte-len #.word-size)))
		  (error '|Bad byte-length - DEPOSIT-BYTE| size))
	  (setq byte-mask (si:pick-a-mask byte-len))
	  (setq nval (cond ((|constant-p/|| val) 
			     (boole 1 val byte-mask))
			   (`(BOOLE 1 ,val ,byte-mask))))
	  (cond ((= byte-len 0) `(PROG2 () ,word ,val))
		((= byte-len #.word-size) `(PROG2 ,word ,val))
		((|constant-p/|| position)
		 (setq position (eval position))
		 (or (and (fixnump position)
			  (not (< position 0)) 
			  (not (> (+ position byte-len) #.word-size)))
		     (error '|Bad position - DEPOSIT-BYTE| position))
		 (cond ((or (fixnump nval)
			    (and (not (|side-effectsp/|| val)) 
				 (not (|side-effectsp/|| word))))
			`(DPB ,nval ,(+ (lsh position 6) byte-len) ,word))
		       (`(BOOLE 7 
				(BOOLE 4 ,word ,(lsh byte-mask position))
				,(cond ((fixnump nval) (lsh nval position))
				       (`(LSH ,nval ,position)))))))
		((let ((byte-displ position) 
		       (byte-pos position)
		       (fl (or (not (symbolp position)) 
			       (|side-effectsp/|| nval)))
		       z) 
		   (cond (fl (si:gen-local-var byte-displ)
			     (setq byte-pos `(SETQ ,BYTE-DISPL ,position))))
		   (setq z `(BOOLE 7 
				   (BOOLE 4 ,word (LSH ,BYTE-MASK ,byte-pos))
				   (LSH ,nval ,byte-displ)))
		   (and fl (setq z `(LET ((,BYTE-DISPL 0))
				      (DECLARE (FIXNUM ,BYTE-DISPL))
				      ,z)))
		   z))))
	 ((or (|side-effectsp/|| word) (|side-effectsp/|| position) 
	      (|side-effectsp/|| size) (|side-effectsp/|| val))
	  `(*DEPOSIT-BYTE ,word ,position ,size ,val))
	 ((let ((byte-mask (si:gen-local-var))
		(byte-displ position) 
		more-decls)
	    `(LET (,.(cond ((not (atom byte-displ))
			    (si:gen-local-var byte-displ)
			    (setq more-decls (list byte-displ))
			    `((,BYTE-DISPL ,position)) ))
		     (,BYTE-MASK (SI:PICK-A-MASK ,size))) 
		(DECLARE (FIXNUM ,BYTE-MASK ,.more-decls))
		(BOOLE 7 (BOOLE 4 ,word (LSH ,BYTE-MASK ,BYTE-DISPL))
		         (LSH (BOOLE 1 ,val ,BYTE-MASK) ,BYTE-DISPL)))))))



;;;; LDB, DPB, *LOAD-BYTE, *LDB, etc


#-Lispm (progn 'compile 

(defmacro LDB (bp word)
   (and (not (atom bp)) (setq bp (macroexpand bp)))
   (cond ((|constant-p/|| bp) 
	   (setq bp (eval bp))
	   (let ((byte-len (boole 1 bp #o77)) 
		 (position (boole 1 (ash bp -6) #o77)))
	     (and (not (< position #.word-size)) 
		  (error '|Bad "position" - LDB|))
	     (and (not (atom word)) (setq word (macroexpand word)))
	     (cond ((|constant-p/|| word) 
		     `(QUOTE ,(*ldb (lsh bp 24.) (eval word))))
		   ('T (and (not (= 0 position))
			    (setq word `(LSH ,word ,(- position))))
		       `(BOOLE 1 ,word ,(si:pick-a-mask byte-len))))))
	 (`(*LDB (LSH ,bp 24.) ,word))))

(defmacro DPB (val bp word)
   (and (not (atom val)) (setq val (macroexpand val)))
   (and (not (atom bp)) (setq bp (macroexpand bp)))
   (setq bp (cond ((|constant-p/|| bp) (lsh (eval bp) 24.))
		  (`(LSH ,bp 24.))))
   (cond ((and (fixnump bp) 
	       (|constant-p/|| val)
	       (or (= (setq val (eval val)) 0)			      ;all 0's
		   (= (*ldb bp -1) (boole 1 (*ldb bp -1) val))))      ;all 1's
	   `(BOOLE ,(if (= val 0) 4 7) 
		   ,word 
		   ,(*dpb -1 bp 0)))
	 (`(*DPB ,val ,bp ,word))))


#+Multics (progn 'COMPILE 

(defun *LOAD-BYTE (w p s) 
       (boole 1 (lsh w (- p)) (si:pick-a-mask s)))
(defun *DEPOSIT-BYTE (w p s b)
       (let ((msk (lsh (lsh -1 (- 36. s)) p)))
	 (boole 1 (boole 4 w msk) (lsh (boole 1 b msk) p))))
(defun *LDB (ppss w)
       (*load-byte w (boole 1 (lsh ppss -30.) #o77)
		     (boole 1 (lsh s -24.) #o77)))
(defun *DPB (b ppss w) 
       (*DEPOSIT-BYTE w (boole 1 (lsh ppss -30.) #o77) 
		        (boole 1 (lsh s -24.) #o77) 
			b))

  )	;end of #+MULTICS

)	;end of #+FM


#Q (progn 'COMPILE 
(defun *LOAD-BYTE (word pos size) 
       (ldb (+ (lsh pos 6) size) word))
(defun *DEPOSIT-BYTE (word pos size byte) 
       (dpb byte (+ (lsh pos 6) size) word))
   )