;;; This is a -*-Lisp-*- file.

;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; Spice Lisp is currently incomplete and under active development.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC). 
;;; **********************************************************************

;;; Source-level transforms for the Common Lisp Cross Compiler.  These
;;; transforms work like macros, but are only used when compiling.

;;; Written by Scott Fahlman, Dave Dill, Skef Wholey, et al.
;;; Currently maintained by Scott Fahlman.

;;; See also the files MACROS.SLISP (true built-in macros in Common Lisp),
;;; SEQTRAN.SLISP (efficiency transforms for sequence and list functions),
;;; and TYPETRAN.SLISP (implementation-specific transforms for type
;;; predicates).

;;; **********************************************************************

;;;; SETQ AND FRIENDS.

;;; Turn any multiple SETQ forms into a progn of individual SETQs.
;;; Setq of 0 pairs is legal, and returns NIL.

(deftransform setq setq-transform (&rest pairs)
  (let ((n (length pairs)))
    (cond ((zerop n) nil)
	  ((= n 2)
	   (test-varname (car pairs))
	   '%pass%)
	  ((oddp n)
	   (clc-error "Odd number of args to SETQ.")
	   nil)
	  (t (do ((m pairs (cddr m))
		  (l nil))
		 ((null m)
		  `(progn ,@(nreverse l)))
	       (push `(setq ,(car m) ,(cadr m)) l))))))


;;; Handle cases of PSETQ with 0, 2 or odd number of args.

(deftransform psetq psetq-transform (&rest pairs)
  (let ((n (length pairs)))
    (cond ((zerop n) nil)
	  ((= n 2)
	   `(setq ,(car pairs) ,(cadr pairs)))
	  ((oddp n)
	   (clc-error "Odd number of args to PSETQ.")
	   nil)
	  (t '%pass%))))

  

;;;; PREDICATES

;;; Just turn NULL into NOT.

(defsynonym null not)


;;; Handle degenerate case of NOT with constant or null argument.

(deftransform not not-transform (x)
  (cond ((or (null x) (equal x '(quote nil))) t)
	((or (eq x t) (equal x '(quote t))) nil)
	(t '%pass%)))


;;; Transform for EQ.  If one arg is NIL, convert form to NOT test.

(deftransform eq eq-transform (x y)
  (cond ((or (null x) (equal x '(quote nil))) `(not ,y))
	((or (null y) (equal y '(quote nil))) `(not ,x))
	(t '%pass%)))


;;; Transform for EQL.  Convert to EQ where one arg is constant and not
;;; a number.  If one arg is a zero, convert to ZEROP.

(deftransform eql eql-transform (x y)
  (cond ((fixnump x) `(eq ,x ,y))
	((fixnump y) `(eq ,x ,y))
	((numberp x) '%pass%)
	((numberp y) '%pass%)
	((or (constantp x) (constantp y))
	 `(eq ,x ,y))
	(t '%pass%)))


;;; Transform for =.   This only handles the two-arg case.
;;; If one arg is zero, convert to ZEROP.

(deftransform = =-transform (x &rest y)
  (cond ((not (= (length y) 1)) '%pass%)
	((and (numberp x) (zerop x))
	 `(zerop ,(car y)))
	((and (numberp (car y)) (zerop (car y)))
	 `(zerop ,x))
	(t '%pass%)))


;;;; CONTROL STRUCTURES


(deftransform return return-transform (&optional (value nil))
  `(return-from nil ,value))


(deftransform prog prog-transform (varlist &rest forms)
  (let* ((pb (parse-body2 forms))
	 (decls (car pb))
	 (body (cadr pb)))
    `(let ,varlist
       (declare ,@decls)
       (block nil (tagbody ,@body)))))


(deftransform prog* prog*-transform (varlist &rest forms)
  (let* ((pb (parse-body2 forms))
	 (decls (car pb))
	 (body (cadr pb)))
    `(let* ,varlist
       (declare ,@decls)
       (block nil (tagbody ,@body)))))


(deftransform progv progv-transform (varlist arglist &body body)
  (let ((v (new-internal-variable))
	(a (new-internal-variable))
	(n (new-internal-variable)))
    `(let ((,n 0))
       (do ((,v ,varlist (cdr ,v))
	    (,a ,arglist (cdr ,a)))
	   ((atom ,v))
	 (%sp-bind (car ,a) (car ,v))
	 (setq ,n (1+ ,n)))
       (multiple-value-prog1 (progn ,@body)
			     (%sp-unbind ,n)))))


(deftransform values values-transform (&rest values)
  (cond ((or (eq for-value 'tail) (eq for-value 'multiple))
	 (if (eq for-value 'tail) (setq returns-single-value nil))
	  (do ((v values (cdr v))
	       (n 0 (1+ n))
	       (l nil))
	      ((atom v)
	       `(progn ,@(nreverse l)
		       (%sp-n-to-values ,n)))
	    (push `(%sp-push ,(car v)) l)))
	(t `(prog1 . ,values))))

(deftransform values-list values-list-transform (form)
  (cond ((or (eq for-value 'tail) (eq for-value 'multiple))
	 (if (eq for-value 'tail) (setq returns-single-value nil))
	  (once-only ((v form))
	    `(progn (%sp-spread ,v)
		    (%sp-n-to-values (list-length ,v)))))
	(t `(car ,form))))

;;; Throw swaps the order of its args, so transform any case where the
;;; tag is not a constant.

(deftransform throw throw-transform (tag value)
  (cond ((constantp tag) '%pass%)
	((eq tag 'internal-throw-tag) '%pass%)
	(t `(let ((internal-throw-tag ,tag))
	      (throw internal-throw-tag ,value)))))

;;; Catch wants to reference the tag twice, so transform any case where
;;; the tag is not a constant.

(deftransform catch catch-transform (tag &rest forms)
  (cond ((constantp tag) '%pass%)
	((eq tag 'internal-throw-tag) '%pass%)
	(t `(let ((internal-throw-tag ,tag))
	      (catch internal-throw-tag ,@forms)))))


;;; The following transform only gets called on DEFUN forms not at top level.

(deftransform defun defun-transform (name varlist &rest forms)
  (let* ((pb (parse-body1 forms))
	 (decls (car pb))
	 (doc (cadr pb))
	 (body (caddr pb)))
    `(progn
      ,@(if doc `((%put ',name '%fun-documentation ',doc)))
      (remprop ',name 'macro-in-compiler)
      (setf (symbol-function ',name)
	    (function (lambda ,varlist
			(declare ,@decls)
			(block ,name ,@body))))
      ',name)))

;;; The following transform catches EVAL-WHEN forms that are not at top level.

(deftransform eval-when eval-when-transform (situations &rest forms)
  (cond ((or (atom situations)
	     (eq 'quote (car situations)))
	 (clc-error "Ill-formed EVAL-WHEN situation list: ~S. ~
		     Ignoring its contents." situations)
	 nil)
	(t (let ((*eval-when-compile* (memq 'compile situations))
		 (*eval-when-load* (memq 'load situations)))
	    (dolist (x forms) (process-form x))
	    (if (memq 'EVAL situations)
		`(progn ,@forms))))))

;;; For Funcall, if the function is #'symbol or 'symbol (and the symbol isn't
;;; functionally bound in the current lexical environment), turn it into the
;;; equivalent form with the symbol in the car.

(deftransform funcall funcall-transform (fn &rest args)
  (if (and (consp fn)
	   (consp (cdr fn))
	   (symbolp (cadr fn))
	   (or (eq (car fn) 'function)
	       (and (eq (car fn) 'quote)
		    (not (assq (cadr fn) *fenv*)))))
      (cons (cadr fn) args)
      '%pass%))

;;; IDENTITY turns into its arg.

(deftransform identity identity-transform (x) x)
 

;;;; LIST and SEQUENCE OPERATORS.

(defprimitive cons cons)

;;; RPLACA and RPLACD, if called for value, need to return the first argument.
;;; %RPLACA and %RPLACD just turn into Replace-Car and Replace-Cdr.

(deftransform rplaca rplaca-transform (a b)
  (if for-value
      (once-only ((aa a))
	`(progn
	  (%primitive replace-car ,aa ,b)
	  ,aa))
      `(%primitive replace-car ,a ,b)))

(deftransform rplacd rplacd-transform (a b)
  (if for-value
      (once-only ((aa a))
	`(progn
	  (%primitive replace-cdr ,aa ,b)
	  ,aa))
      `(%primitive replace-cdr ,a ,b)))

(defprimitive %rplaca replace-car)
(defprimitive %rplacd replace-cdr)

(deftransform caar caar-transform (x) `(car (car ,x)))
(deftransform cadr cadr-transform (x) `(car (cdr ,x)))
(deftransform cdar cdar-transform (x) `(cdr (car ,x)))
(deftransform cddr cddr-transform (x) `(cdr (cdr ,x)))
(deftransform caaar caaar-transform (x) `(car (car (car ,x))))
(deftransform caadr caadr-transform (x) `(car (car (cdr ,x))))
(deftransform cadar cadar-transform (x) `(car (cdr (car ,x))))
(deftransform caddr caddr-transform (x) `(car (cdr (cdr ,x))))
(deftransform cdaar cdaar-transform (x) `(cdr (car (car ,x))))
(deftransform cdadr cdadr-transform (x) `(cdr (car (cdr ,x))))
(deftransform cddar cddar-transform (x) `(cdr (cdr (car ,x))))
(deftransform cdddr cdddr-transform (x) `(cdr (cdr (cdr ,x))))
(deftransform caaaar caaaar-transform (x) `(car (car (car (car ,x)))))
(deftransform caaadr caaadr-transform (x) `(car (car (car (cdr ,x)))))
(deftransform caadar caadar-transform (x) `(car (car (cdr (car ,x)))))
(deftransform caaddr caaddr-transform (x) `(car (car (cdr (cdr ,x)))))
(deftransform cadaar cadaar-transform (x) `(car (cdr (car (car ,x)))))
(deftransform cadadr cadadr-transform (x) `(car (cdr (car (cdr ,x)))))
(deftransform caddar caddar-transform (x) `(car (cdr (cdr (car ,x)))))
(deftransform cadddr cadddr-transform (x) `(car (cdr (cdr (cdr ,x)))))
(deftransform cdaaar cdaaar-transform (x) `(cdr (car (car (car ,x)))))
(deftransform cdaadr cdaadr-transform (x) `(cdr (car (car (cdr ,x)))))
(deftransform cdadar cdadar-transform (x) `(cdr (car (cdr (car ,x)))))
(deftransform cdaddr cdaddr-transform (x) `(cdr (car (cdr (cdr ,x)))))
(deftransform cddaar cddaar-transform (x) `(cdr (cdr (car (car ,x)))))
(deftransform cddadr cddadr-transform (x) `(cdr (cdr (car (cdr ,x)))))
(deftransform cdddar cdddar-transform (x) `(cdr (cdr (cdr (car ,x)))))
(deftransform cddddr cddddr-transform (x) `(cdr (cdr (cdr (cdr ,x)))))

(deftransform first first-transform (x) `(car ,x))
(deftransform second second-transform (x) `(cadr ,x))
(deftransform third third-transform (x) `(caddr ,x))
(deftransform fourth fourth-transform (x) `(cadddr ,x))
(deftransform fifth fifth-transform (x) `(car (cddddr ,x)))
(deftransform sixth sixth-transform (x) `(cadr (cddddr ,x)))
(deftransform seventh seventh-transform (x) `(caddr (cddddr ,x)))
(deftransform eighth eighth-transform (x) `(cadddr (cddddr ,x)))
(deftransform ninth ninth-transform (x) `(car (cddddr (cddddr ,x))))
(deftransform tenth tenth-transform (x) `(cadr (cddddr (cddddr ,x))))


;;; Transform to open code short NTH and NTHCDR.
(deftransform nth nth-transform (n l)
  `(car (nthcdr ,n ,l)))

(deftransform nthcdr nthcdr-transform (n l)
  (if (and (integerp n) (< -1 n *nthcdr-open-code-limit*))
      (do ((x n (1- x))
	   (f l (list 'cdr f)))
	  ((zerop x) f))
      '%pass%))


;;;; SYMBOL FUNCTIONS.

;;; MAKUNBOUND and FMAKUNBOUND set the value or definition cell to
;;; the Misc-Trap code.

(deftransform makunbound makunbound-transform (x)
  (once-only ((symbol x))
    `(progn
      (set ,symbol ,unbound-marker)
      ,symbol)))

(deftransform fmakunbound fmakunbound-transform (x)
  (once-only ((symbol x))
    `(progn
      (%primitive set-definition ,symbol ,unbound-marker)
      ,symbol)))

(defprimitive set set-value)
(defprimitive symbol-value get-value)
(defprimitive fset set-definition)
(defprimitive symbol-function get-definition)
(defprimitive boundp boundp)
(defprimitive fboundp fboundp)
(defprimitive symbol-plist get-plist)
(defprimitive %set-plist set-plist)
(defprimitive symbol-name get-pname)
(defprimitive symbol-package get-package)
(defprimitive make-symbol alloc-symbol)

(deftransform fset fset-transform (symbol value)
  (clc-warning "FSET is obsolete, use SETF of SYMBOL-FUNCTION.")
  `(%sp-set-definition ,symbol ,value))


;;; We've got microcoded instructions to do GET, %PUT, GETF, and PUTF.
;;; PUTF is generated by the PUTF macro, so we don't do anything about that here.

(deftransform get get-transform (symbol indicator &optional default)
  (if (null default)
      `(%primitive get ,symbol ,indicator)
      '%pass%))

(deftransform getf getf-transform (symbol indicator &optional default)
  (if (null default)
      `(%primitive getf ,symbol ,indicator)
      '%pass%))

(defprimitive %put put)

;;;; ARITHMETIC and NUMEROLOGY.

(deftransform plusp plusp-transform (x)
  `(> ,x 0))

(deftransform minusp minusp-transform (x)
  `(< ,x 0))

(deftransform oddp oddp-transform (x)
  `(not (zerop (logand ,x 1))))

(deftransform evenp evenp-transform (x)
  `(zerop (logand ,x 1)))


;;; Handler for multi-argument comparisons.  Basically, turn things
;;; like (> a b c ... ) to (AND (> a b) (> b c) ... ).  But if an
;;; interior arg is not a number or symbol, have to do a setq to
;;; avoid evaling the arg twice.  If any setqs are needed, have to
;;; make one extra local variable with a LET form.

(defun multi-compare (form)
  (cond ((= (length form) 2) 't)
	((= (length form) 3) '%pass%)
	;; Simple case, args have no side effects.
	((do ((args (cdr form) (cdr args))
	      (result nil))
	     ((atom (cdr args))
	      (cons 'and (nreverse result)))
	   (cond ((trivialp (car args))
		  (push `(,(car form) ,(car args) ,(cadr args)) result))
		 (t (return nil)))))
	;; Bad case, eval all args first, exactly once.
	(t (do ((args (cddr form) (cdr args))
		(oldvar (if (numberp (cadr form))
			    (cadr form)
			    (new-internal-variable))
			newvar)
		(oldarg (cadr form) (car args))
		(newvar nil)
		(varlist nil (if (numberp oldvar)
				 varlist
				 (cons (list oldvar oldarg) varlist)))
		(result nil))
	       ((null args)
		(or (numberp oldvar)
		    (push (list oldvar oldarg) varlist))
		`(let ,(nreverse varlist) (and ,@(nreverse result))))
	     (setq newvar (if (numberp (car args))
			      (car args)
			      (new-internal-variable)))
	     (push `(,(car form) ,oldvar ,newvar) result)))))

(push 'multi-compare (get '= 'clc-transforms))
(push 'multi-compare (get '> 'clc-transforms))
(push 'multi-compare (get '< 'clc-transforms))
(push 'multi-compare (get '>= 'clc-transforms))
(push 'multi-compare (get '<= 'clc-transforms))


;;; Convert 2-arg comparisons to equivalents.

(deftransform >= >=-two-arg (x &rest y)
  (if (= (length y) 1)
      `(not (< ,x ,(car y)))
      '%pass%))

(deftransform <= <=-two-arg (x &rest y)
  (if (= (length y) 1)
      `(not (> ,x ,(car y)))
      '%pass%))


;;; /= is different, since it requires every element of the arglist to
;;; be compared to every other -- a doubly-nested DO loop.  Only open-code
;;; the one arg and two arg cases, and let the rest go call the actual /=
;;; function.
(deftransform /= /=-transform (x &rest more)
  (cond ((null more) 't)
	((null (cdr more))
	 `(not (= ,x ,(car more))))
	(t '%pass%)))


;;; Transforms for max and min.  Zap one-arg case and open-code
;;; two-arg case.

(deftransform max max-transform (x &rest more)
  (cond ((null more) x)
	((null (cdr more))
	 (once-only ((a x) (b (car more)))
	   `(if (> ,a ,b) ,a ,b)))
	(t '%pass%)))

(deftransform min min-transform (x &rest more)
  (cond ((null more) x)
	((null (cdr more))
	 (once-only ((a x) (b (car more)))
	   `(if (< ,a ,b) ,a ,b)))
	(t '%pass%)))


;;; Transform for multi-arg arithmetic and logical functions.

(defun multi-arith (form)
  (if (< (length form) 4)
      '%pass%
      (do ((f form `(,op (,op ,(cadr f) ,(caddr f)) ,@(cdddr f)))
	   (op (car form)))
	  ((< (length f) 4) f))))

(push 'multi-arith (get '+ 'clc-transforms))
(push 'multi-arith (get '- 'clc-transforms))
(push 'multi-arith (get '* 'clc-transforms))
(push 'multi-arith (get '/ 'clc-transforms))
(push 'multi-arith (get 'logior 'clc-transforms))
(push 'multi-arith (get 'logxor 'clc-transforms))
(push 'multi-arith (get 'logand 'clc-transforms))
(push 'multi-arith (get 'logeqv 'clc-transforms))

;;; Some of the following use EQ on numbers deliberately.  If the number
;;; is merely = to 1 or 0, it might be a float and should cause contagion.

(deftransform + +-transform (&rest args)
  (cond ((null args) 0)
	((null (cdr args)) (car args))
	((cddr args) '%pass%)
	((eq (car args) 0) (cadr args))
	((eq (car args) 1) `(1+ ,(cadr args)))
	((eq (cadr args) 0) (car args))
	((eq (cadr args) 1) `(1+ ,(car args)))
	(t '%pass%)))

(deftransform - --transform (x &rest args)
  (cond ((null args) `(%sp-negate ,x))
	((cdr args) '%pass%)
	((eq x 0) `(%sp-negate ,(car args)))
	((eq (car args) 0) x)
	((eq (car args) 1) `(1- ,x))
	(t '%pass%)))

(deftransform * *-transform (&rest args)
  (cond ((null args) 1)
	((null (cdr args)) (car args))
	((cddr args) '%pass%)
	((eq (car args) 1) (cadr args))
	((eq (cadr args) 1) (car args))
	(t '%pass%)))

(deftransform / /-transform (x &rest args)
  (cond ((null args) `(/ 1 ,x))
	((cdr args) '%pass%)
	((eql (car args) 0)
	 (clc-warning "Dividing by constant 0.")
	 '%pass%)
	((eq (car args) 1) x)
	(t '%pass%)))


;;; Transform one-arg forms to two-arg with 1 as second arg.  Also
;;; if not for value, just eval args for side-effect.

(defun second-arg-is-1 (form)
  ;; All of these guys return multiple values.
  (if (eq for-value 'tail) (setq returns-single-value nil))
  (cond ((cddr form) '%pass%)
	(t `(,(car form) ,(cadr form) 1))))

(push 'second-arg-is-1 (get 'truncate 'clc-transforms))
(push 'second-arg-is-1 (get 'floor 'clc-transforms))
(push 'second-arg-is-1 (get 'ceiling 'clc-transforms))
(push 'second-arg-is-1 (get 'round 'clc-transforms))
(push 'second-arg-is-1 (get 'ftruncate 'clc-transforms))
(push 'second-arg-is-1 (get 'ffloor 'clc-transforms))
(push 'second-arg-is-1 (get 'fceiling 'clc-transforms))
(push 'second-arg-is-1 (get 'fround 'clc-transforms))


;;; In 1-return case, convert FTRUNCATE and friends to (FLOAT (TRUNCATE ...)).

(deftransform ftruncate ftruncate-transform (x &optional (y 1))
  (if (or (eq for-value 'tail) (eq for-value 'multiple))
      '%pass%
      `(float (truncate ,x ,y))))

(deftransform ffloor ffloor-transform (x &optional (y 1))
  (if (or (eq for-value 'tail) (eq for-value 'multiple))
      '%pass%
      `(float (floor ,x ,y))))

(deftransform fceiling fceiling-transform (x &optional (y 1))
  (if (or (eq for-value 'tail) (eq for-value 'multiple))
      '%pass%
      `(float (ceiling ,x ,y))))

(deftransform fround fround-transform (x &optional (y 1))
  (if (or (eq for-value 'tail) (eq for-value 'multiple))
      '%pass%
      `(float (round ,x ,y))))

;;; Handle degenerate 0 and 1 arg cases of logical functions.

(deftransform logior logior-transform (&rest args)
  (cond ((null args) 0)
	((null (cdr args)) (car args))
	(t '%pass%)))

(deftransform logxor logxor-transform (&rest args)
  (cond ((null args) 0)
	((null (cdr args)) (car args))
	(t '%pass%)))

(deftransform logand logand-transform (&rest args)
  (cond ((null args) -1)
	((null (cdr args)) (car args))
	(t '%pass%)))

;;; Other logical functions.

(deftransform logeqv logeqv-transform (&rest args)
  (cond ((null args) -1)
	((null (cdr args)) (car args))
	((null (cddr args))
	 `(lognot (logxor ,(car args) ,(cadr args))))
	(t '%pass%)))

(deftransform lognand lognand-transform (x y)
  `(lognot (logand ,x ,y)))

(deftransform lognor lognor-transform (x y)
  `(lognot (logior ,x ,y)))

(deftransform logandc1 logandc1-transform (x y)
  `(logand (lognot ,x) ,y))

(deftransform logandc2 logandc2-transform (x y)
  `(logand ,x (lognot ,y)))

(deftransform logorc1 logorc1-transform (x y)
  `(logior (lognot ,x) ,y))

(deftransform logorc2 logorc2-transform (x y)
  `(logior ,x (lognot ,y)))


;;; If control arg to BOOLE is a constant integer, convert to the
;;; appropriate logical function.

(deftransform boole boole-transform (op x y)
  (let ((control (transform op)))
    (cond ((not (integerp control)) '%pass%)
	  (t (case control
	       (0 0)
	       (1 -1)
	       (2 x)
	       (3 y)
	       (4 `(lognot ,x))
	       (5 `(lognot ,y))
	       (6 `(logand ,x ,y))
	       (7 `(logior ,x ,y))
	       (8 `(logxor ,x ,y))
	       (9 `(logeqv ,x ,y))
	       (10 `(lognand ,x ,y))
	       (11 `(lognor ,x ,y))
	       (12 `(logandc1 ,x ,y))
	       (13 `(logandc2 ,x ,y))
	       (14 `(logorc1 ,x ,y))
	       (15 `(logorc2 ,x ,y))
	       (t (clc-error "~S illegal control arg to BOOLE." control)
		  nil))))))

(deftransform logtest logtest-transform (x y)
  `(not (zerop (logand ,x ,y))))

(deftransform logbitp logbitp-transform (x y)
  `(not (zerop (%primitive ldb 1 ,x ,y))))

;;; Byte specifier is just the cons of Size and Position.
(defsynonym byte cons)
(defsynonym byte-size car)
(defsynonym byte-position cdr)

(deftransform ldb ldb-transform (byte-spec x)
  (let ((bs (convert-byte-spec byte-spec)))
    (cond (bs `(%primitive ldb ,(car bs) ,(cdr bs) ,x))
	  (t (once-only ((b byte-spec))
	       `(%primitive ldb (car ,b) (cdr ,b) ,x))))))

(deftransform mask-field mask-field-transform (byte-spec x)
  (let ((bs (convert-byte-spec byte-spec)))
    (cond (bs `(%primitive mask-field ,(car bs) ,(cdr bs) ,x))
	  (t (once-only ((b byte-spec))
	       `(%primitive mask-field (car ,b) (cdr ,b) ,x))))))

(deftransform dpb dpb-transform (new byte-spec x)
  (let ((bs (convert-byte-spec byte-spec)))
    (cond (bs `(%primitive dpb ,new ,(car bs) ,(cdr bs) ,x))
	  (t (once-only ((b byte-spec))
	       `(%primitive dpb ,new (car ,b) (cdr ,b) ,x))))))

(deftransform deposit-field deposit-field-transform (new byte-spec x)
  (let ((bs (convert-byte-spec byte-spec)))
    (cond (bs `(%primitive deposit-field ,new ,(car bs) ,(cdr bs) ,x))
	  (t (once-only ((b byte-spec))
	       `(%primitive deposit-field ,new (car ,b) (cdr ,b) ,x))))))

(deftransform ldb-test ldb-test-transform (bytespec x)
  `(not (zerop (ldb ,bytespec ,x))))

(deftransform float float-transform (n &optional (other nil otherp))
  (cond ((not otherp) `(%primitive float-short ,n))
	((not (floatp (setq other (transform other)))) '%pass%)
	((typep other 'short-float) `(%primitive float-short ,n))
	((typep other 'single-float) `(%primitive float-short ,n))
	((typep other 'double-float) `(%primitive float-long ,n))
	((typep other 'long-float) `(%primitive float-long ,n))
	(t (error "Unknown float type?"))))

(defprimitive abs abs)
(defprimitive short-float float-short)
(defprimitive single-float float-short)
(defprimitive double-float float-long)
(defprimitive long-float float-long)
(defprimitive ash ash)
(defprimitive integer-length integer-length)


;;;; VECTOR and ARRAY HACKERY.

;;; This stuff is filled with millions of bogus pseudo-subprimtives that
;;; should be flushed someday.

;;; Simple accessors:

(defprimitive svref svref)
(defprimitive schar schar)
;(defprimitive sbit sbit);  <-- SBIT works on multi-D things.
(defprimitive saref1 aref1)
(defprimitive %sp-svref svref)
(defprimitive %sp-schar schar)
(defprimitive %sp-sbit sbit)
(defprimitive %sp-saref1 aref1)

;;; Simple setters:

(defprimitive %svset svset)
(defprimitive %scharset scharset)
;(defprimitive %sbitset sbitset);  <-- %SBITSET works on multi-D things.
(defprimitive %saset1 aset1)
(defprimitive %sp-svset svset)
(defprimitive %sp-scharset scharset)
(defprimitive %sp-sbitset sbitset)
(defprimitive %sp-saset1 aset1)

;;; Complex sets and accesses:

(defprimitive aref1 aref1)
(defprimitive %aset1 aset1)

;;; General Lisp-level accessors:

(deftransform aref aref-transform (array &rest indices)
  (let ((index (car indices)))
    (if (and index (null (cdr indices)))
	(case (find-type array)
	  (simple-vector `(svref ,array ,index))
	  (simple-string `(schar ,array ,index))
	  (simple-bit-vector `(%primitive sbit ,array ,index))
	  (simple-array `(saref1 ,array ,index))
	  (t `(aref1 ,array ,index)))
	'%pass%)))

(deftransform char char-transform (array index)
  (if (eq (find-type array) 'simple-string)
      `(schar ,array ,index)
      `(aref1 ,array ,index)))

;;; Bit accessors are special...

(deftransform sbit sbit-transform (array &rest indices)
  (if (and (car indices) (null (cdr indices)))
      `(%primitive sbit ,array ,(car indices))
      `(aref ,array ,@indices)))

(deftransform bit bit-transform (array &rest indices)
  `(aref ,array ,@indices))

;;; General Lisp-level setters:

(deftransform %aset %aset-transform (array &rest stuff)
  (let ((index (car stuff))
	(new (cadr stuff)))
    (if (and new (null (cddr stuff)))
	(case (find-type array)
	  (simple-vector `(%svset ,array ,index ,new))
	  (simple-string `(%scharset ,array ,index ,new))
	  (simple-bit-vector `(%sbitset ,array ,index ,new))
	  (simple-array `(%saset1 ,array ,index ,new))
	  (t `(%aset1 ,array ,index ,new)))
	'%pass%)))

(deftransform %charset %charset-transform (array index new)
  (if (eq (find-type array) 'simple-string)
      `(%scharset ,array ,index ,new)
      `(%aset1 ,array ,index ,new)))

(deftransform %sbitset %sbitset-transform (array &rest stuff)
  (if (and (cadr stuff) (null (cddr stuff)))
      `(%primitive sbitset ,array ,(car stuff) ,(cadr stuff))
      `(%aset ,array ,@stuff)))

(deftransform %bitset %bitset-transform (array &rest stuff)
  `(%aset ,array ,@stuff))

;;; Transforms for MAKE-VECTOR and MAKE-ARRAY.
;;; Since we can handle a specification of :Initial-Element, we'll squeeze
;;; out that special case.

(deftransform make-vector make-vector-transform (n &rest stuff)
  (cond ((null stuff)
	 `(%sp-alloc-b-vector ,n nil))
	((and (eq (car stuff) ':initial-element) (null (cddr stuff)))
	 `(%sp-alloc-b-vector ,n ,(cadr stuff)))
	(t '%pass%)))

(deftransform make-array make-array-transform (n &rest stuff)
  (cond ((not (integerp n)) '%pass%)
	((null stuff)
	 `(%sp-alloc-b-vector ,n nil))
	((and (eq (car stuff) ':initial-element) (null (cddr stuff)))
	 `(%sp-alloc-b-vector ,n ,(cadr stuff)))
	(t '%pass%)))

(deftransform make-string make-string-transform (n &rest stuff)
  (if (null stuff)
      `(%sp-alloc-string ,n)
      '%pass%))


;;;; CHARACTER FUNCTIONS

;;; CHAR= is just EQ in this system.

(deftransform char= char=-transform (char &rest more)
  (cond ((null more) t)
	((null (cdr more)) `(eq ,char ,(car more)))
	(t '%pass%)))

;;; Handle >2 arg cases just like numerical comparisons.

(push 'multi-compare (get 'char= 'clc-transforms))
(push 'multi-compare (get 'char> 'clc-transforms))
(push 'multi-compare (get 'char< 'clc-transforms))
(push 'multi-compare (get 'char>= 'clc-transforms))
(push 'multi-compare (get 'char<= 'clc-transforms))

;;; Like /=, this requires that all chars be compared.

(deftransform char/= char/=-transform (char &rest more)
  (cond ((null more) t)
	((null (cdr more)) `(not (eq ,char ,(car more))))
	(t '%pass%)))

(deftransform char-int char-int-transform (x)
  `(%primitive make-immediate-type ,x 16))

(deftransform char-code char-code-transform (x)
  `(logand 255 (%primitive make-immediate-type ,x 16)))

;;;; Instruction-level transforms.

(defprimitive %sp-cons cons)
(defprimitive %sp-alloc-symbol alloc-symbol)
(defprimitive %sp-alloc-b-vector alloc-g-vector)
(defprimitive %sp-alloc-u-vector alloc-i-vector)
(defprimitive %sp-alloc-string alloc-string)
(defprimitive %sp-alloc-function alloc-function)
(defprimitive %sp-alloc-array alloc-array)
(defprimitive %sp-alloc-xnum alloc-bignum)
(defprimitive %sp-type get-type)
(defprimitive %sp-make-immediate-type make-immediate-type)
(defprimitive %sp-get-vector-subtype get-vector-subtype)
(defprimitive %sp-set-vector-subtype set-vector-subtype)
(defprimitive %sp-get-vector-length vector-length)
(defprimitive %sp-get-value get-value)
(defprimitive %sp-set-value set-value)
(defprimitive %sp-get-definition get-definition)
(defprimitive %sp-set-definition set-definition)
(defprimitive %sp-get-plist get-plist)
(defprimitive %sp-set-plist set-plist)
(defprimitive %sp-get-pname get-pname)
(defprimitive %sp-get-package get-package)
(defprimitive %sp-set-package set-package)
(defprimitive %sp-boundp boundp)
(defprimitive %sp-fboundp fboundp)
(defprimitive %sp-negate negate)
(defprimitive %sp-lsh lsh)
(defprimitive %sp-get-vector-access-type get-vector-access-code)
(defprimitive %sp-logldb logldb)
(defprimitive %sp-logdpb logdpb)
(defprimitive %sp-abs abs)
(defprimitive %sp-subspace get-space)
(defprimitive %sp-typed-v-access typed-vref)
(defprimitive %sp-typed-v-store typed-vset)
(defprimitive %sp-shrink-vector shrink-vector)
(defprimitive %sp-values-to-n values-to-n)
(defprimitive %sp-n-to-values n-to-values)
(defprimitive %sp-arg-in-frame arg-in-frame)
(defprimitive %sp-current-stack-frame active-call-frame)
(defprimitive %sp-set-stack-frame set-call-frame)
(defprimitive %sp-current-open-frame current-open-frame)
(defprimitive %sp-set-open-frame set-open-frame)
(defprimitive %sp-current-stack-pointer current-stack-pointer)
(defprimitive %sp-current-binding-pointer current-binding-pointer)
(defprimitive %sp-read-control-stack read-control-stack)
(defprimitive %sp-write-control-stack write-control-stack)
(defprimitive %sp-read-binding-stack read-binding-stack)
(defprimitive %sp-write-binding-stack write-binding-stack)
(defprimitive %sp-ldb ldb)
(defprimitive %sp-mask-field mask-field)
(defprimitive %sp-dpb dpb)
(defprimitive %sp-deposit-field deposit-field)
(defprimitive %sp-ash ash)
(defprimitive %sp-haulong integer-length)
(defprimitive %sp-v-access aref1)
(defprimitive %sp-svref aref1)
(defprimitive %sp-v-store aset1)
(defprimitive %sp-svset aset1)
(defprimitive %sp-force-values force-values)
(defprimitive %sp-flush-values flush-values)
(defprimitive %sp-get-newspace-bit newspace-bit)
(defprimitive %sp-halt halt)
(defprimitive %sp-escape-return escape-return)
(defprimitive %sp-break-return break-return)
(defprimitive %sp-kernel-trap kernel-trap)
(defprimitive %sp-byte-blt byte-blt)
(defprimitive %sp-find-character find-character)
(defprimitive %sp-find-character-with-attribute find-character-with-attribute)
(defprimitive %sp-sxhash-simple-string sxhash-simple-string)
(defprimitive %sp-short-float float-short)
(defprimitive %sp-long-float float-long)
(defprimitive %sp-single-float float-short)
(defprimitive %sp-double-float float-long)
(defprimitive %sp-scale-float scale-float)
(defprimitive %sp-decode-float decode-float)
(defprimitive %sp-assoc assoc)
(defprimitive %sp-assq assq)
(defprimitive %sp-member member)
(defprimitive %sp-memq memq)

;;; This is the macro that constructs the transforms for string<, string<=, 
;;; string>, and string>=.  Char-fn is the character comparison function that
;;; finished off the job of %sp-string-compare.  String-fn is the * function that
;;; is called when one of the args to the function call that is being transformed
;;; is not simple (i.e. when we are punting on the transform).  These are put
;;; in by ,', at macroexpand time.  The backquoted form that is returned then 
;;; evaluates in all of the six arguments to the string comparison function at
;;; transform time.

(defmacro string<>=-body (string*-fn lessp equalp)
  `(if (and (eq (find-type string1) 'simple-string)
	    (eq (find-type string2) 'simple-string))
       (once-only ((str1 string1)
		   (str2 string2)
		   (s1 start1)
		   (e1 end1)
		   (s2 start2)
		   (e2 end2))
	 (let ((index (new-internal-variable))
	       (end1 (new-internal-variable))
	       (end2 (new-internal-variable)))
	   `(let* ((,end1 (if (not ,e1) (length (the simple-string ,str1)) ,e1))
		   (,end2 (if (not ,e2) (length (the simple-string ,str2)) ,e2))
		   (,index (%sp-string-compare ,str1 ,s1 ,end1 ,str2 ,s2 ,end2)))
	      (if ,index
		  (cond ((= ,index ,(if ,lessp end1 end2)) ,index)
			((= ,index ,(if ,lessp end2 end1)) nil)
			((,(if ,lessp 'char< 'char>)
			  (schar ,str1 ,index)
			  (schar ,str2 (+ ,index (- ,s2 ,s1))))
			 ,index)
			(t nil))
		  ,(if ,equalp `(- ,end1 ,s1) 'nil)))))
       `(,',string*-fn ,string1 ,string2 ,start1 ,end1 ,start2 ,end2)))

(deftransform string< string<-transform 
  (string1 string2 &key (start1 0) end1 (start2 0) end2)
  (string<>=-body string<* t nil))

(deftransform string> string>-transform 
  (string1 string2 &key (start1 0) end1 (start2 0) end2)
  (string<>=-body string>* nil nil))
  
(deftransform string<= string<=-transform 
  (string1 string2 &key (start1 0) end1 (start2 0) end2)
  (string<>=-body string<=* t t))

(deftransform string>= string>=-transform 
  (string1 string2 &key (start1 0) end1 (start2 0) end2)
  (string<>=-body string>=* nil t))

;;; As above, but for string= and string/=.  Compare-fn is the function to call
;;; on the result of %sp-string-compare. *-fn is the * function to call if there
;;; are non-simple strings.

(defmacro string=-body (compare-fn *-fn)
 `(if (and (eq (find-type string1) 'simple-string)
	   (eq (find-type string2) 'simple-string))
      (once-only ((str1 string1)
		  (str2 string2)
		  (e1 end1)
		  (e2 end2))
	`(,',compare-fn (%sp-string-compare ,str1 ,start1
		          (if (not ,e1) (length (the simple-string ,str1)) ,e1)
		          ,str2 ,start2
		          (if (not ,e2) (length (the simple-string ,str2)) ,e2))))
      `(,',*-fn ,string1 ,string2 ,start1 ,end1 ,start2 ,end2)))

(deftransform string= string=-transform
  (string1 string2 &key (start1 0) end1 (start2 0) end2)
  (string=-body not string=*))

(deftransform string/= string/=-transform
  (string1 string2 &key (start1 0) end1 (start2 0) end2)
  (string=-body identity string/=*))

;;; A transform for FORMAT, courtesy of Skef.

(deftransform format format-transform (stream control &rest args)
  (if (or (not (simple-string-p control))
	  (not (trivialp stream))
	  (eq stream nil))
      '%pass%
      (do* ((index 0)
	    (forms ())
	    (end (length control))
	    (penultimus (1- end))
	    (stream-var (new-internal-variable))
	    (stream-form (if (eq stream t) () `(,stream-var))))
	  ((= index end)
	   `(let (,@(if (eq stream t)
			()
			`((,stream-var ,stream))))
	      ,@(nreverse forms)
	      nil))
	(let* ((command-index (position #\~ (the simple-string control)
					:start index)))
	  (cond (command-index
		 (when (= command-index penultimus)
		   (clc-error "FORMAT control string ends in a ~~: ~S" control)
		   (return '%pass%))
		 ;; Get the format directive.
		 (let ((command-char (schar control (1+ command-index))))
		   ;; Non-command stuff gets write-string'ed out.
		   (if (/= index command-index)
		       (push `(write-string
			       ,(subseq (the simple-string control)
					index command-index)
			       ,@stream-form)
			     forms))
		   ;; Generate code for the command.
		   (push
		    (case command-char
		      ((#\b #\B) `(let ((*print-base* 2))
				    (princ ,(pop args) ,@stream-form)))
		      ((#\o #\O) `(let ((*print-base* 8))
				    (princ ,(pop args) ,@stream-form)))
		      ((#\d #\D) `(let ((*print-base* 10))
				    (princ ,(pop args) ,@stream-form)))
		      ((#\x #\X) `(let ((*print-base* 16))
				    (princ ,(pop args) ,@stream-form)))
		      ((#\a #\A) `(princ ,(pop args) ,@stream-form))
		      ((#\s #\S) `(prin1 ,(pop args) ,@stream-form))
		      (#\% `(terpri ,@stream-form))
		      (#\& `(fresh-line ,@stream-form))
		      (#\| `(write-char #\form ,@stream-form)) ; |) for EMACS
		      (#\~ `(write-char #\~ ,@stream-form))
		      (#\newline
		       (let ((new-pos (position-if-not
				       #'whitespace-char-p
				       (the simple-string control)
				       :start (+ command-index 2))))
			 (if new-pos
			     (setq command-index (- new-pos 2)))))
		      (t (return '%pass%)))
		    forms))
		 (setq index (+ command-index 2)))
		(t
		 ;; Write out the final part of the string.
		 (push `(write-string ,(subseq (the simple-string control)
					       index end)
				      ,@stream-form)
		       forms)
		 (setq index end)))))))