;;;-*-lisp-*-

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

(*expr *make-array *rem *del ass mem listp copyalist copytree apropos
       defstruct-examine defstruct-deposit y-or-n-p
       macroexpand macroexpand-1)

(*lexpr format ?format ferror cerror describe inspect
	gprint gprint1 gprinc pl gexplode gexplodec)

(unspecial args symbols car cdr)

(setq use-strt7 t)

(defmacro xcar (x) `(car ,x))
(defmacro xrplaca (x v) `(rplaca ,x ,v))
(defmacro xcdr (x) `(cdr ,x))
(defmacro xrplacd (x v) `(rplacd ,x ,v))
(defmacro xcxr (n x) `(cxr ,n ,x))
(defmacro xrplacx (n x v) `(rplacx ,n ,x ,v))
(defmacro vcell (sym) `(cdar ,sym))
(defmacro pname (sym) `(cxr 2 (car ,sym)))

(defmacro ldb (ppss x)
  (setq ppss (macroexpand ppss))
  (setq x (macroexpand x))
  (if (not (fixp ppss))
      `(*ldb (lsh ,ppss #o30) ,x)			;ugh!
      (let ((mask (1- (lsh 1 (boole 1 #o77 ppss))))
	    (shift (- (lsh ppss -6))))
	(cond ((fixp x)
	       (boole 1 mask (lsh x shift)))
	      ((zerop shift)
	       `(boole 1 ,mask ,x))
	      (t
	       `(boole 1 ,mask (lsh ,x ,shift)))))))

(defmacro dpb (v ppss x)
  (setq v (macroexpand v))
  (setq ppss (macroexpand ppss))
  (setq x (macroexpand x))
  (if (not (fixp ppss))
      `(*dpb ,v (lsh ,ppss #o30) ,x)			;ugh!
      (let* ((shift (lsh ppss -6))
	     (mask (lsh (1- (lsh 1 (boole 1 #o77 ppss))) shift)))
	(let ((vp (cond ((fixp v)
			 (boole 1 mask (lsh v shift)))
			((zerop shift)
			 `(boole 1 ,mask ,v))
			(t
			 `(boole 1 ,mask (lsh ,v ,shift)))))
	      (xp (if (fixp x)
		      (boole 4 x mask)
		      `(boole 4 ,x ,mask))))
	  (if (and (fixp vp) (fixp xp))
	      (boole 7 vp xp)
	      `(boole 7 ,vp ,xp))))))

(sstatus feature alan/;lspcom)