From 9b2a483feb196a95a39c0070868353fa3e268c01 Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Fri, 24 Aug 1990 18:30:08 +0000
Subject: [PATCH] Moved MIPS branch onto trunk; no merge necessary.

---
 compiler/globaldb.lisp    |  53 +--
 compiler/globals.lisp     |  10 +-
 compiler/pseudo-vops.lisp |   3 +-
 compiler/seqtran.lisp     |  69 +---
 compiler/srctran.lisp     | 738 ++++++++++++++++++++++++++++++++------
 compiler/typetran.lisp    |  51 +--
 6 files changed, 670 insertions(+), 254 deletions(-)

diff --git a/compiler/globaldb.lisp b/compiler/globaldb.lisp
index a02732b79..f5362037d 100644
--- a/compiler/globaldb.lisp
+++ b/compiler/globaldb.lisp
@@ -7,6 +7,8 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/globaldb.lisp,v 1.12 1990/08/24 18:29:19 wlott Exp $
+;;;
 ;;;    This file provides a functional interface to global information about
 ;;; named things in the system.  Information is considered to be global if it
 ;;; must persist between invocations of the compiler.  The use of a functional
@@ -301,7 +303,7 @@
     #-new-compiler
     (the fixnum (%primitive sxhash-simple-string (symbol-name x)))
     #+new-compiler
-    (truly-the index (%primitive sxhash-simple-string (symbol-name x))))
+    (%sxhash-simple-string (symbol-name x)))
    ((and (listp x)
 	 (eq (car x) 'setf))
     (let ((next (cdr x)))
@@ -314,9 +316,7 @@
 				      (%primitive sxhash-simple-string
 						  (symbol-name name)))
 				 #+new-compiler
-				 (truly-the index
-					    (%primitive sxhash-simple-string
-							(symbol-name name)))
+				 (%sxhash-simple-string (symbol-name name))
 				 110680597))))))
     (sxhash x))
    (t
@@ -628,7 +628,7 @@
 ;;; Exact density (modulo rounding) of the hashtable in a compact info
 ;;; environment in names/bucket.
 ;;;
-(defconstant compact-info-environment-density 0.65)
+(defconstant compact-info-environment-density 65)
 
 
 ;;; COMPACT-INFO-ENVIRONMENT  --  Public
@@ -652,10 +652,8 @@
     
     (let* ((table-size
 	    (primify
-	     (+
-	      (truncate
-	       (/ name-count compact-info-environment-density))
-	      3)))
+	     (+ (truncate (* name-count 100) compact-info-environment-density)
+		3)))
 	   (table (make-array table-size :initial-element 0))
 	   (index (make-array table-size
 			      :element-type 'compact-info-entries-index))
@@ -849,7 +847,7 @@
 
 ;;; The maximum density of the hashtable in a volatile env (in names/bucket).
 ;;;
-(defconstant volatile-info-environment-density 0.5)
+(defconstant volatile-info-environment-density 50)
 
 
 ;;; MAKE-INFO-ENVIRONMENT  --  Public
@@ -859,9 +857,7 @@
 (defun make-info-environment (&key (size 42) (name "Unknown"))
   (declare (type (integer 1) size))
   (let ((table-size
-	 (primify
-	  (truncate
-	   (/ size volatile-info-environment-density)))))
+	 (primify (truncate (* size 100) volatile-info-environment-density))))
     (make-volatile-info-env
      :name name
      :table (make-array table-size :initial-element nil)
@@ -993,13 +989,9 @@
 (define-info-type function type ctype
   #+new-compiler
   (if (fboundp name)
-      (let ((def (fdefinition name)))
-	(let ((entry (if (eql (%primitive get-vector-subtype def)
-			      %function-closure-subtype)
-			 (%primitive header-ref def %function-name-slot)
-			 def)))
-	  (specifier-type
-	   (%primitive header-ref entry %function-entry-type-slot))))
+      (specifier-type (%primitive function-type
+				  (%primitive closure-function
+					      (fdefinition name))))
       (specifier-type 'function))
   #-new-compiler
   (specifier-type 'function))
@@ -1028,22 +1020,18 @@
 ;;; A macro-like function which transforms a call to this function into some
 ;;; other Lisp form.  This expansion is inhibited if inline expansion is
 ;;; inhibited.
-(define-info-type function source-transform (or function null
-						#-new-compiler list))
+(define-info-type function source-transform (or function null list))
 
 ;;; The macroexpansion function for this macro.
-(define-info-type function macro-function (or function null
-					      #-new-compiler list)
+(define-info-type function macro-function (or function null list)
   nil)
 
 ;;; A function which converts this special form into IR1.
-(define-info-type function ir1-convert (or function null
-					   #-new-compiler list))
+(define-info-type function ir1-convert (or function null list))
 
 ;;; A function which gets a chance to do stuff to the IR1 for any call to this
 ;;; function.
-(define-info-type function ir1-transform (or function null
-					     #-new-compiler list))
+(define-info-type function ir1-transform (or function null list))
 
 ;;; If a function is an alien-operator, then this is the Alien-Info.
 (define-info-type function alien-operator (or lisp::alien-info null) nil)
@@ -1117,12 +1105,10 @@
       nil))
 
 ;;; Expander function for a defined type.
-(define-info-type type expander (or function null
-				    #-new-compiler list) nil)
+(define-info-type type expander (or function null list) nil)
 
 ;;; Print function for a type.
-(define-info-type type printer (or function symbol null
-				   #-new-compiler list) nil)
+(define-info-type type printer (or function symbol null list) nil)
 
 ;;; Defstruct description information for a structure type.  DEFINED is the
 ;;; current global definition, and is not shadowed by compilation of
@@ -1158,8 +1144,7 @@
 
 (define-info-type setf documentation (or string null) nil)
 
-(define-info-type setf expander (or function null 
-				    #-new-compiler list) nil)
+(define-info-type setf expander (or function null list) nil)
 
 ;;; Used for storing random documentation types.  The stuff is an alist
 ;;; translating documentation kinds to values.
diff --git a/compiler/globals.lisp b/compiler/globals.lisp
index 62e5ce6a2..71e8862be 100644
--- a/compiler/globals.lisp
+++ b/compiler/globals.lisp
@@ -12,4 +12,12 @@
 	    *meta-sc-numbers* *primitive-type-names* *move-costs* *save-scs*
 	    *save-costs* *restore-costs* *parsed-vops*
 	    *compiler-error-context* *word-length* target-byte-order
-	    *undefined-warnings* *meta-sb-names* *meta-sc-names*))
+	    *undefined-warnings* *meta-sb-names* *meta-sc-names*
+	    *code-segment* *elsewhere*))
+
+(defconstant native-byte-order target-byte-order
+  "The byte order we are running under.")
+
+(eval-when (compile)
+  (format t "foo!")
+  (setf (info variable constant-value 'native-byte-order) target-byte-order))
diff --git a/compiler/pseudo-vops.lisp b/compiler/pseudo-vops.lisp
index 48b4fbaa7..023a064b9 100644
--- a/compiler/pseudo-vops.lisp
+++ b/compiler/pseudo-vops.lisp
@@ -32,6 +32,5 @@
   (:info name)
   (:vop-var vop)
   (:generator 0
-    (unassemble
-      (funcall (symbol-function name) vop x y))))
+    (funcall (symbol-function name) vop x y)))
 
diff --git a/compiler/seqtran.lisp b/compiler/seqtran.lisp
index 9bc1f687b..93e502996 100644
--- a/compiler/seqtran.lisp
+++ b/compiler/seqtran.lisp
@@ -7,6 +7,8 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/seqtran.lisp,v 1.9 1990/08/24 18:29:34 wlott Exp $
+;;;
 ;;;    This file contains optimizers for list and sequence functions.
 ;;;
 ;;; Written by Rob MacLachlan.  Some code adapted from the old seqtran file,
@@ -119,65 +121,6 @@
 member map concatenate position find
 |#
 
-
-;;;; Simple string transforms:
-
-
-(deftransform subseq ((string start &optional (end nil))
-		      (simple-string t &optional t))
-  '(let* ((length (- (or end (length string))
-		     start))
-	  (result (make-string length)))
-     (%primitive byte-blt string start result 0 length)
-     result))
-
-
-(deftransform copy-seq ((seq) (simple-string))
-  '(let* ((length (length seq))
-	  (res (make-string length)))
-     (%primitive byte-blt seq 0 res 0 length)
-     res))
-
-
-(deftransform replace ((string1 string2 &key (start1 0) (start2 0)
-				end1 end2)
-		       (simple-string simple-string &rest t))
-  '(progn
-     (%primitive byte-blt string2 start2 string1 start1
-		 (+ start1
-		    (min (- (or end1 (length string1))
-			    start1)
-			 (- (or end2 (length string2))
-			    start2))))
-     string1))
-
-
-(deftransform concatenate ((rtype &rest sequences)
-			   (t &rest simple-string)
-			   simple-string)
-  (collect ((lets)
-	    (forms)
-	    (all-lengths)
-	    (args))
-    (dolist (seq sequences)
-      (declare (ignore seq))
-      (let ((n-seq (gensym))
-	    (n-length (gensym)))
-	(args n-seq)
-	(lets `(,n-length (length ,n-seq)))
-	(all-lengths n-length)
-	(forms `(setq start end  end (+ start ,n-length)))
-	(forms `(%primitive byte-blt ,n-seq 0 res start end))))
-    `(lambda (rtype ,@(args))
-       (declare (ignore rtype))
-       (let* (,@(lets)
-	      (res (make-string (+ ,@(all-lengths))))
-	      (start 0)
-	      (end 0))
-	 (declare (type index start end))
-	 ,@(forms)
-	 res))))
-
 
 ;;; Names of predicates that compute the same value as CHAR= when applied to
 ;;; characters.
@@ -190,10 +133,10 @@ member map concatenate position find
   (unless (or (not test)
 	      (continuation-function-is test char=-functions))
     (give-up))
-  `(and (typep item 'string-char)
-	(,@(if (constant-value-or-lose from-end)
-	       '(lisp::%sp-reverse-find-character)
-	       '(%primitive find-character))
+  `(and (typep item 'character)
+	(,(if (constant-value-or-lose from-end)
+	      'lisp::%sp-reverse-find-character
+	      'lisp::%sp-find-character)
 	 sequence start (or end (length sequence))
 	 item)))
 
diff --git a/compiler/srctran.lisp b/compiler/srctran.lisp
index 711632cbd..66c45bbee 100644
--- a/compiler/srctran.lisp
+++ b/compiler/srctran.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.11 1990/06/01 15:41:29 ram Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.12 1990/08/24 18:29:38 wlott Exp $
 ;;;
 ;;;    This file contains macro-like source transformations which convert
 ;;; uses of certain functions into the canonical form desired within the
@@ -16,7 +16,7 @@
 ;;;
 ;;; Written by Rob MacLachlan
 ;;;
-(in-package 'c)
+(in-package "C")
 
 ;;; Source transform for Not, Null  --  Internal
 ;;;
@@ -261,6 +261,10 @@
 			    (* x-high y-high)
 			    nil))))))))
 
+(defoptimizer (/ derive-type) ((x y))
+  (numeric-contagion (continuation-type x) (continuation-type y)))
+
+
 (defoptimizer (ash derive-type) ((n shift))
   (or (let ((n-type (continuation-type n)))
 	(when (numeric-type-p n-type)
@@ -269,7 +273,12 @@
 	    (if (constant-continuation-p shift)
 		(let ((shift (continuation-value shift)))
 		  (make-numeric-type :class 'integer  :complexp :real
-				     :low (when n-low (ash n-low shift))
+				     :low (when n-low
+					    #+new-compiler
+					    (ash n-low shift)
+					    ;; ### fuckin' bignum bug.
+					    #-new-compiler
+					    (* n-low (ash 1 shift)))
 				     :high (when n-high (ash n-high shift))))
 		(let ((s-type (continuation-type shift)))
 		  (when (numeric-type-p s-type)
@@ -370,15 +379,185 @@
   (defoptimizer (lognot derive-type) ((int))
     (derive-integer-type int int (frob lognot))))
 
+
+(defoptimizer (abs derive-type) ((num))
+  (let ((type (continuation-type num)))
+    (if (and (numeric-type-p type)
+	     (eq (numeric-type-class type) 'integer)
+	     (eq (numeric-type-complexp type) :real))
+	(let ((lo (numeric-type-low type))
+	      (hi (numeric-type-high type)))
+	  (make-numeric-type :class 'integer :complexp :real
+			     :low (cond ((and hi (minusp hi))
+					 (abs hi))
+					(lo
+					 (max 0 lo))
+					(t
+					 0))
+			     :high (if (and hi lo)
+				       (max (abs hi) (abs lo))
+				       nil)))
+	(numeric-contagion type type))))
+
+
+(defoptimizer (truncate derive-type) ((number divisor))
+  (let ((number-type (continuation-type number))
+	(divisor-type (continuation-type divisor))
+	(integer-type (specifier-type 'integer)))
+    (if (and (numeric-type-p number-type)
+	     (csubtypep number-type integer-type)
+	     (numeric-type-p divisor-type)
+	     (csubtypep divisor-type integer-type))
+	(let ((number-low (numeric-type-low number-type))
+	      (number-high (numeric-type-high number-type))
+	      (divisor-low (numeric-type-low divisor-type))
+	      (divisor-high (numeric-type-high divisor-type)))
+	  (values-specifier-type
+	   `(values ,(integer-truncate-derive-type number-low number-high
+						   divisor-low divisor-high)
+		    ,(integer-rem-derive-type number-low number-high
+					      divisor-low divisor-high))))
+	*universal-type*)))
+
+;;; NUMERIC-RANGE-INFO  --  internal.
+;;;
+;;; Derive useful information about the range.  Returns three values:
+;;; - '+ if its positive, '- negative, or nil if it overlaps 0.
+;;; - The abs of the minimal value (i.e. closest to 0) in the range.
+;;; - The abs of the maximal value if there is one, or nil if it is unbounded.
+;;; 
+(defun numeric-range-info (low high)
+  (cond ((and low (not (minusp low)))
+	 (values '+ low high))
+	((and high (not (plusp high)))
+	 (values '- (- high) (if low (- low) nil)))
+	(t
+	 (values nil 0 (and low high (max (- low) high))))))
+
+;;; INTEGER-TRUNCATE-DERIVE-TYPE -- internal
+;;; 
+(defun integer-truncate-derive-type
+       (number-low number-high divisor-low divisor-high)
+  ;; The result cannot be larger in magnitude than the number, but the sign
+  ;; might change.  If we can determine the sign of either the number or
+  ;; the divisor, we can eliminate some of the cases.
+  (multiple-value-bind
+      (number-sign number-min number-max)
+      (numeric-range-info number-low number-high)
+    (multiple-value-bind
+	(divisor-sign divisor-min divisor-max)
+	(numeric-range-info divisor-low divisor-high)
+      (when (and divisor-max (zerop divisor-max))
+	;; We've got a problem: guarenteed division by zero.
+	(return-from integer-truncate-derive-type t))
+      (when (zerop divisor-min)
+	;; We'll assume that they arn't going to divide by zero.
+	(incf divisor-min))
+      (cond ((and number-sign divisor-sign)
+	     ;; We know the sign of both.
+	     (if (eq number-sign divisor-sign)
+		 ;; Same sign, so the result will be positive.
+		 `(integer ,(if divisor-max
+				(truncate number-min divisor-max)
+				0)
+			   ,(if number-max
+				(truncate number-max divisor-min)
+				'*))
+		 ;; Different signs, the result will be negative.
+		 `(integer ,(if number-max
+				(- (truncate number-max divisor-min))
+				'*)
+			   ,(if divisor-max
+				(- (truncate number-min divisor-max))
+				0))))
+	    ((eq divisor-sign '+)
+	     ;; The divisor is positive.  Therefore, the number will just
+	     ;; become closer to zero.
+	     `(integer ,(if number-low
+			    (truncate number-low divisor-min)
+			    '*)
+		       ,(if number-high
+			    (truncate number-high divisor-min)
+			    '*)))
+	    ((eq divisor-sign '-)
+	     ;; The divisor is negative.  Therefore, the absolute value of
+	     ;; the number will become closer to zero, but the sign will also
+	     ;; change.
+	     `(integer ,(if number-high
+			    (- (truncate number-high divisor-min))
+			    '*)
+		       ,(if number-low
+			    (- (truncate number-low divisor-min))
+			    '*)))
+	    ;; The divisor could be either positive or negative.
+	    (number-max
+	     ;; The number we are dividing has a bound.  Divide that by the
+	     ;; smallest posible divisor.
+	     (let ((bound (truncate number-max divisor-min)))
+	       `(integer ,(- bound) ,bound)))
+	    (t
+	     ;; The number we are dividing is unbounded, so we can't tell
+	     ;; anything about the result.
+	     'integer)))))
+	  
+(defun integer-rem-derive-type
+       (number-low number-high divisor-low divisor-high)
+  (if (and divisor-low divisor-high)
+      ;; We know the range of the divisor, and the remainder must be smaller
+      ;; than the divisor.  We can tell the sign of the remainer if we know
+      ;; the sign of the number.
+      (let ((divisor-max (1- (max (abs divisor-low) (abs divisor-high)))))
+	`(integer ,(if (or (null number-low)
+			   (minusp number-low))
+		       (- divisor-max)
+		       0)
+		  ,(if (or (null number-high)
+			   (plusp number-high))
+		       divisor-max
+		       0)))
+      ;; The divisor is potentially either very positive or very negative.
+      ;; Therefore, the remainer is unbounded, but we might be able to tell
+      ;; something about the sign from the number.
+      `(integer ,(if (and number-low (not (minusp number-low)))
+		     ;; The number we are dividing is positive.  Therefore,
+		     ;; the remainder must be positive.
+		     0
+		     '*)
+		,(if (and number-high (not (plusp number-high)))
+		     ;; The number we are dividing is negative.  Therefore,
+		     ;; the remainder must be negative.
+		     0
+		     '*))))
+
 
 ;;;; Array derive-type optimizers:
 
+(defoptimizer (array-in-bounds-p derive-type) ((array &rest indices))
+  (assert-continuation-type
+   array
+   (specifier-type `(array * ,(make-list (length indices)
+					 :initial-element '*))))
+  *universal-type*)
+
 (defoptimizer (aref derive-type) ((array &rest indices))
+  (assert-continuation-type
+   array
+   (specifier-type `(array * ,(make-list (length indices)
+					 :initial-element '*))))
+  (let ((type (continuation-type array)))
+    (when (array-type-p type)
+      (array-type-element-type type))))
+
+(defoptimizer (data-vector-ref derive-type) ((array index))
   (let ((type (continuation-type array)))
     (when (array-type-p type)
       (array-type-element-type type))))
 
 (defoptimizer (%aset derive-type) ((array &rest stuff))
+  (assert-continuation-type
+   array
+   (specifier-type `(array * ,(make-list (1- (length stuff))
+					 :initial-element '*))))
   (let ((type (continuation-type array)))
     (when (array-type-p type)
       (let ((val (car (last stuff)))
@@ -386,6 +565,31 @@
 	(assert-continuation-type val eltype)
 	(continuation-type val)))))
 
+(defoptimizer (data-vector-set derive-type) ((array index new-value))
+  (let ((type (continuation-type array)))
+    (when (array-type-p type)
+      (let ((eltype (array-type-element-type type)))
+	(assert-continuation-type new-value eltype)
+	(continuation-type new-value)))))
+
+(defoptimizer (array-row-major-index derive-type) ((array &rest indices))
+  (assert-continuation-type
+   array
+   (specifier-type `(array * ,(make-list (length indices)
+					 :initial-element '*))))
+  *universal-type*)
+
+(defoptimizer (row-major-aref derive-type) ((array index))
+  (let ((type (continuation-type array)))
+    (when (array-type-p type)
+      (array-type-element-type type))))
+  
+(defoptimizer (%set-row-major-aref derive-type) ((array index new-value))
+  (let ((type (continuation-type array)))
+    (when (array-type-p type)
+      (assert-continuation-type new-value (array-type-element-type type))
+      (continuation-type new-value))))
+
 
 ;;; Unsupplied-Or-NIL  --  Internal
 ;;;
@@ -428,7 +632,7 @@
 
 
 (defoptimizer (code-char derive-type) ((code))
-  (specifier-type 'string-char))
+  (specifier-type 'base-character))
 
 
 (defoptimizer (values derive-type) ((&rest values))
@@ -437,6 +641,7 @@
 			  (type-specifier (continuation-type x)))
 		      values))))
 
+
 
 ;;;; Byte operations:
 ;;;
@@ -489,59 +694,128 @@
     `(%deposit-field ,newbyte ,size ,pos ,int)))
 
 
-;;; Check-Fixnum-Byte  --  Internal
-;;;
-;;;    If the continuations Size and Pos are constant, and represent a field
-;;; that fits into a fixnum, then return the size and position as values,
-;;; otherwise Give-Up.
-;;;
-(defun check-fixnum-byte (size pos)
-  (unless (and (constant-continuation-p size)
-	       (constant-continuation-p pos))
-    (give-up))
-  (let ((size (continuation-value size))
-	(pos (continuation-value pos)))
-    (when (> (+ size pos) (integer-length most-positive-fixnum))
-      (give-up))
-    (values size pos)))
-
-(defun max-value (cont)
-  (if (constant-continuation-p cont)
-      (continuation-value cont)
-      (let ((type (continuation-type cont)))
-	(or (and (numeric-type-p type)
-		 (numeric-type-high type))
-	    (give-up
-	     "Size is not constant and its upper bound is not known.")))))
-
-(deftransform %ldb ((size pos int) (fixnum fixnum integer))
-  (let ((size-len (max-value size)))
-    (unless (<= size-len (integer-length most-positive-fixnum))
-      (give-up "result might be up to ~D bits, can't open code %ldb." size-len))
-    (if (zerop size-len)
-	0
-	`(logand (ash int (- pos))
-		 (ash ,(1- (ash 1 (integer-length most-positive-fixnum)))
-		      (- size ,(integer-length most-positive-fixnum)))))))
-
-(deftransform %dpb ((new size pos int) (t t t fixnum))
-  (multiple-value-bind (size pos)
-		       (check-fixnum-byte size pos)
-    `(logior (ash (logand new ,(ldb (byte size 0) -1))
-		  pos)
-	     (logand int ,(lognot (ash (ldb (byte size 0) -1) pos))))))
-
-(deftransform %mask-field ((size pos int) (t t fixnum))
-  (multiple-value-bind (size pos)
-		       (check-fixnum-byte size pos)
-    `(logand int ,(ash (ldb (byte size 0) -1) pos))))
-
-(deftransform %deposit-field ((new size pos int) (t t t fixnum))
-  (multiple-value-bind (size pos)
-		       (check-fixnum-byte size pos)
-    (let ((mask (ash (ldb (byte size 0) -1) pos)))
-      `(logior (logand new ,mask)
-	       (logand int ,(lognot mask))))))
+(defoptimizer (%ldb derive-type) ((size posn num))
+  (let ((size (continuation-type size)))
+    (if (and (numeric-type-p size)
+	     (csubtypep size (specifier-type 'integer)))
+	(let ((size-high (numeric-type-high size)))
+	  (if (and size-high (<= size-high vm:word-bits))
+	      (specifier-type `(unsigned-byte ,size-high))
+	      (specifier-type 'unsigned-byte)))
+	*universal-type*)))
+
+(defoptimizer (%mask-field derive-type) ((size posn num))
+  (let ((size (continuation-type size))
+	(posn (continuation-type posn)))
+    (if (and (numeric-type-p size)
+	     (csubtypep size (specifier-type 'integer))
+	     (numeric-type-p posn)
+	     (csubtypep posn (specifier-type 'integer)))
+	(let ((size-high (numeric-type-high size))
+	      (posn-high (numeric-type-high posn)))
+	  (if (and size-high posn-high
+		   (<= (+ size-high posn-high) vm:word-bits))
+	      (specifier-type `(unsigned-byte ,(+ size-high posn-high)))
+	      (specifier-type 'unsigned-byte)))
+	*universal-type*)))
+
+(defoptimizer (%dpb derive-type) ((newbyte size posn int))
+  (let ((size (continuation-type size))
+	(posn (continuation-type posn))
+	(int (continuation-type int)))
+    (if (and (numeric-type-p size)
+	     (csubtypep size (specifier-type 'integer))
+	     (numeric-type-p posn)
+	     (csubtypep posn (specifier-type 'integer))
+	     (numeric-type-p int)
+	     (csubtypep int (specifier-type 'integer)))
+	(let ((size-high (numeric-type-high size))
+	      (posn-high (numeric-type-high posn))
+	      (high (numeric-type-high int))
+	      (low (numeric-type-low int)))
+	  (if (and size-high posn-high high low
+		   (<= (+ size-high posn-high) vm:word-bits))
+	      (specifier-type
+	       (list (if (minusp low) 'signed-byte 'unsigned-byte)
+		     (max (integer-length high)
+			  (integer-length low)
+			  (+ size-high posn-high))))
+	      *universal-type*))
+	*universal-type*)))
+
+(defoptimizer (%deposit-field derive-type) ((newbyte size posn int))
+  (let ((size (continuation-type size))
+	(posn (continuation-type posn))
+	(int (continuation-type int)))
+    (if (and (numeric-type-p size)
+	     (csubtypep size (specifier-type 'integer))
+	     (numeric-type-p posn)
+	     (csubtypep posn (specifier-type 'integer))
+	     (numeric-type-p int)
+	     (csubtypep int (specifier-type 'integer)))
+	(let ((size-high (numeric-type-high size))
+	      (posn-high (numeric-type-high posn))
+	      (high (numeric-type-high int))
+	      (low (numeric-type-low int)))
+	  (if (and size-high posn-high high low
+		   (<= (+ size-high posn-high) vm:word-bits))
+	      (specifier-type
+	       (list (if (minusp low) 'signed-byte 'unsigned-byte)
+		     (max (integer-length high)
+			  (integer-length low)
+			  (+ size-high posn-high))))
+	      *universal-type*))
+	*universal-type*)))
+
+
+
+(deftransform %ldb ((size posn int)
+		    (fixnum fixnum integer)
+		    (unsigned-byte #.vm:word-bits))
+  `(logand (ash int (- posn))
+	   (ash ,(1- (ash 1 vm:word-bits))
+		(- size ,vm:word-bits))))
+
+(deftransform %mask-field ((size posn int)
+			   (fixnum fixnum integer)
+			   (unsigned-byte #.vm:word-bits))
+  `(logand int
+	   (ash (ash ,(1- (ash 1 vm:word-bits))
+		     (- size ,vm:word-bits))
+		posn)))
+
+;;; Note: for %dpb and %deposit-field, we can't use (or (signed-byte n)
+;;; (unsigned-byte n)) as the result type, as that would allow result types
+;;; that cover the range -2^(n-1) .. 1-2^n, instead of allowing result types
+;;; of (unsigned-byte n) and result types of (signed-byte n).
+
+(deftransform %dpb ((new size posn int)
+		    *
+		    (unsigned-byte #.vm:word-bits))
+  `(let ((mask (ldb (byte size 0) -1)))
+     (logior (ash (logand new mask) posn)
+	     (logand int (lognot (ash mask posn))))))
+
+(deftransform %dpb ((new size posn int)
+		    *
+		    (signed-byte #.vm:word-bits))
+  `(let ((mask (ldb (byte size 0) -1)))
+     (logior (ash (logand new mask) posn)
+	     (logand int (lognot (ash mask posn))))))
+
+(deftransform %deposit-field ((new size posn int)
+			      *
+			      (unsigned-byte #.vm:word-bits))
+  `(let ((mask (ash (ldb (byte size 0) -1) posn)))
+     (logior (logand new mask)
+	     (logand int (lognot mask)))))
+
+(deftransform %deposit-field ((new size posn int)
+			      *
+			      (signed-byte #.vm:word-bits))
+  `(let ((mask (ash (ldb (byte size 0) -1) posn)))
+     (logior (logand new mask)
+	     (logand int (lognot mask)))))
 
 
 ;;;; Funny function stubs:
@@ -551,15 +825,35 @@
 ;;; definition to allow constant folding.
 ;;;
 
+#-new-compiler
+(progn
+
 (defun %negate (x) (%primitive negate x))
 (defun %ldb (s p i) (%primitive ldb s p i))
 (defun %dpb (n s p i) (%primitive dpb n s p i))
 (defun %mask-field (s p i) (%primitive mask-field s p i))
 (defun %deposit-field (n s p i) (%primitive deposit-field n s p i))
 
+); #-new-compiler progn
+
 
 ;;; Miscellanous numeric transforms:
 
+
+;;; COMMUTATIVE-ARG-SWAP  --  Internal
+;;;
+;;;    If a constant appears as the first arg, swap the args.
+;;;
+(deftransform commutative-arg-swap ((x y) * * :defun-only t :node node)
+  (if (and (constant-continuation-p x)
+	   (not (constant-continuation-p y)))
+      `(,(continuation-function-name (basic-combination-fun node)) y x)
+      (give-up)))
+
+(dolist (x '(= char= + * logior logand logxor))
+  (%deftransform x '(function * *) #'commutative-arg-swap))
+
+
 ;;; Handle the case of a constant boole-code.
 ;;;
 (deftransform boole ((op x y))
@@ -600,20 +894,27 @@
 	`(ash x ,len))))
 
 ;;; If arg is a constant power of two, turn floor into a shift and mask.
-;;; 
-(deftransform floor ((x y) (integer integer))
-  (unless (constant-continuation-p y) (give-up))
-  (let* ((y (continuation-value y))
-	 (y-abs (abs y))
-	 (len (1- (integer-length y-abs))))
-    (unless (= y-abs (ash 1 len)) (give-up))
-    (let ((shift (- len))
-	  (mask (1- y-abs)))
-      (if (minusp y)
-	  `(values (ash (- x) ,shift)
-		   (- (logand (- x) ,mask)))
-	  `(values (ash x ,shift)
-		   (logand x ,mask))))))
+;;; If ceiling, add in (1- (abs y)) and then do floor.
+;;;
+(flet ((frob (y ceil-p)
+	 (unless (constant-continuation-p y) (give-up))
+	 (let* ((y (continuation-value y))
+		(y-abs (abs y))
+		(len (1- (integer-length y-abs))))
+	   (unless (= y-abs (ash 1 len)) (give-up))
+	   (let ((shift (- len))
+		 (mask (1- y-abs)))
+	     `(let ,(when ceil-p `((x (+ x ,(1- y-abs)))))
+		,(if (minusp y)
+		     `(values (ash (- x) ,shift)
+			      (- (logand (- x) ,mask)))
+		     `(values (ash x ,shift)
+			      (logand x ,mask))))))))
+  (deftransform floor ((x y) (integer integer))
+    (frob y nil))
+  (deftransform ceiling ((x y) (integer integer))
+    (frob y t)))
+
 
 ;;; Do the same for mod.
 ;;;
@@ -662,10 +963,17 @@
 	   (- (logand (- x) ,mask))
 	   (logand x ,mask)))))
 
+
+;;; Flush calls to random arith functions that convert to the identity
+;;; function.
+;;; 
+(deftransform ash ((x y) (* (constant-argument (member 0))))
+  'x)
+
 
 ;;;; Character operations:
 
-(deftransform char-equal ((a b) (string-char string-char))
+(deftransform char-equal ((a b) (base-character base-character))
   '(let* ((ac (char-code a))
 	  (bc (char-code b))
 	  (sum (logxor ac bc)))
@@ -674,14 +982,14 @@
 	   (let ((sum (+ ac bc)))
 	     (and (> sum 161) (< sum 213)))))))
 
-(deftransform char-upcase ((x) (string-char))
+(deftransform char-upcase ((x) (base-character))
   '(let ((n-code (char-code x)))
      (if (and (> n-code #o140)	; Octal 141 is #\a.
 	      (< n-code #o173))	; Octal 172 is #\z.
 	 (code-char (logxor #x20 n-code))
 	 x)))
 
-(deftransform char-downcase ((x) (string-char))
+(deftransform char-downcase ((x) (base-character))
   '(let ((n-code (char-code x)))
      (if (and (> n-code 64)	; 65 is #\A.
 	      (< n-code 91))	; 90 is #\Z.
@@ -715,10 +1023,10 @@
 (deftransform simple-equality-transform ((x y) * * :defun-only t)
   (cond ((same-leaf-ref-p x y)
 	 't)
-	((types-intersect (continuation-type x) (continuation-type y))
-	 (give-up))
+	((not (types-intersect (continuation-type x) (continuation-type y)))
+	 'nil)
 	(t
-	 'nil)))
+	 (give-up))))
 
 (dolist (x '(eq char= equal))
   (%deftransform x '(function * *) #'simple-equality-transform))
@@ -728,22 +1036,19 @@
 ;;;
 ;;;    Similar to SIMPLE-EQUALITY-PREDICATE, except that we also try to convert
 ;;; to a type-specific predicate or EQ:
-;;;
 ;;; -- If both args are characters, convert to CHAR=.  This is better than just
 ;;;    converting to EQ, since CHAR= may have special compilation strategies
 ;;;    for non-standard representations, etc.
-;;; -- If both args are the "same" numeric type, then convert to =.  This
-;;;    allows all of ='s expertise to come into play.  "Same" means either both
-;;;    rational or both floats of the same format.  Complexp must also be
-;;;    specified and identical.
 ;;; -- If either arg is definitely not a number, then we can compare with EQ.
-;;; -- If either arg is definitely a fixnum, then we can compare with EQ.
+;;; -- Otherwise, we try to put the arg we know more about second.  If X is
+;;;    constant then we put it second.  If X is a subtype of Y, we put it
+;;;    second.  These rules make it easier for the back end to match these
+;;;    interesting cases.
 ;;;
 (deftransform eql ((x y))
   (let ((x-type (continuation-type x))
 	(y-type (continuation-type y))
 	(char-type (specifier-type 'character))
-	(fixnum-type (specifier-type 'fixnum))
 	(number-type (specifier-type 'number)))
     (cond ((same-leaf-ref-p x y)
 	   't)
@@ -752,29 +1057,44 @@
 	  ((and (csubtypep x-type char-type)
 		(csubtypep y-type char-type))
 	   '(char= x y))
-	  ((and (numeric-type-p x-type) (numeric-type-p y-type)
-		(let ((x-class (numeric-type-class x-type))
-		      (y-class (numeric-type-class y-type))
-		      (x-format (numeric-type-format x-type)))
-		  (or (and (eq x-class 'float) (eq y-class 'float)
-			   x-format
-			   (eq x-format (numeric-type-format y-type)))
-		      (and (member x-class '(rational integer))
-			   (member y-class '(rational integer)))))
-		(let ((x-complexp (numeric-type-complexp x-type)))
-		  (and x-complexp
-		       (eq x-complexp (numeric-type-complexp y-type)))))
-	   '(= x y))
 	  ((or (not (types-intersect x-type number-type))
 	       (not (types-intersect y-type number-type)))
 	   '(eq x y))
-	  ((or (csubtypep x-type fixnum-type)
-	       (csubtypep y-type fixnum-type))
-	   '(eq x y))
+	  ((and (not (constant-continuation-p y))
+		(or (constant-continuation-p x)
+		    (and (csubtypep x-type y-type)
+			 (not (csubtypep y-type x-type)))))
+	   '(eql y x))
 	  (t
 	   (give-up "Not enough type information to open-code.")))))
 
 
+;;; = IR1 Transform  --  Internal
+;;;
+;;;    Convert to EQL if both args are the "same" numeric type.  This allows
+;;; all of EQL's type-specific expertise to come into play.  "Same" means
+;;; either both rational or both floats of the same format.  Complexp must also
+;;; be specified and identical.
+;;; 
+(deftransform = ((x y))
+  (let ((x-type (continuation-type x))
+	(y-type (continuation-type y)))
+    (if (and (numeric-type-p x-type) (numeric-type-p y-type)
+	     (let ((x-class (numeric-type-class x-type))
+		   (y-class (numeric-type-class y-type))
+		   (x-format (numeric-type-format x-type)))
+	       (or (and (eq x-class 'float) (eq y-class 'float)
+			x-format
+			(eq x-format (numeric-type-format y-type)))
+		   (and (member x-class '(rational integer))
+			(member y-class '(rational integer)))))
+	     (let ((x-complexp (numeric-type-complexp x-type)))
+	       (and x-complexp
+		    (eq x-complexp (numeric-type-complexp y-type)))))
+	'(eql x y)
+	(give-up "Operands might not be the same type, so can't open code."))))
+
+
 ;;; Numeric-Type-Or-Lose  --  Interface
 ;;;
 ;;;    If Cont's type is a numeric type, then return the type, otherwise
@@ -791,30 +1111,34 @@
 ;;;
 ;;;    See if we can statically determine (< X Y) using type information.  If
 ;;; X's high bound is < Y's low, then X < Y.  Similarly, if X's low is >= to
-;;; Y's high, the X >= Y (so return NIL).
+;;; Y's high, the X >= Y (so return NIL).  If not, at least make sure any
+;;; constant arg is second.
 ;;;
-(defun ir1-transform-< (x y)
+(defun ir1-transform-< (x y first second inverse)
   (if (same-leaf-ref-p x y)
       'nil
-      (let* ((x (numeric-type-or-lose x))
-	     (x-lo (numeric-type-low x))
-	     (x-hi (numeric-type-high x))
-	     (y (numeric-type-or-lose y))
-	     (y-lo (numeric-type-low y))
-	     (y-hi (numeric-type-high y)))
+      (let* ((x-type (numeric-type-or-lose x))
+	     (x-lo (numeric-type-low x-type))
+	     (x-hi (numeric-type-high x-type))
+	     (y-type (numeric-type-or-lose y))
+	     (y-lo (numeric-type-low y-type))
+	     (y-hi (numeric-type-high y-type)))
 	(cond ((and x-hi y-lo (< x-hi y-lo))
 	       't)
 	      ((and y-hi x-lo (>= x-lo y-hi))
 	       'nil)
+	      ((and (constant-continuation-p first)
+		    (not (constant-continuation-p second)))
+	       `(,inverse y x))
 	      (t
 	       (give-up))))))
 	      
 
 (deftransform < ((x y) (integer integer))
-  (ir1-transform-< x y))
+  (ir1-transform-< x y x y '>))
 
 (deftransform > ((x y) (integer integer))
-  (ir1-transform-< y x))
+  (ir1-transform-< y x x y '<))
 
 
 ;;;; Converting N-arg comparisons:
@@ -970,6 +1294,23 @@
 (def-source-transform logeqv (&rest args)
   (source-transform-transitive 'logeqv args -1 'logeqv-two-arg))
 
+;;; Note: we can't use source-transform-transitive for GCD and LCM because when
+;;; they are given one argument, they return it's absolute value.
+
+(def-source-transform gcd (&rest args)
+  (case (length args)
+    (0 0)
+    (1 `(abs (the integer ,(first args))))
+    (2 (values nil t))
+    (t (associate-arguments 'gcd (first args) (rest args)))))
+
+(def-source-transform lcm (&rest args)
+  (case (length args)
+    (0 1)
+    (1 `(abs (the integer ,(first args))))
+    (2 (values nil t))
+    (t (associate-arguments 'lcm (first args) (rest args)))))
+
 
 ;;; Source-Transform-Intransitive  --  Internal
 ;;;
@@ -1041,16 +1382,23 @@
     (cond ((csubtypep type (specifier-type 'simple-string))
 	   (when initial-element
 	     (give-up "Can't hack initial elements in strings."))
-	   `(truly-the ,spec (%primitive alloc-string length)))
+	   `(truly-the ,spec (%primitive alloc-string (the index length))))
 	  ((csubtypep type (specifier-type 'simple-bit-vector))
 	   (unless (or (not initial-element)
 		       (and (constant-continuation-p initial-element)
 			    (eql (continuation-value initial-element) 0)))
 	     (give-up "Can't hack non-zero initial-elements in bit-vectors."))
-	   `(truly-the ,spec (%primitive alloc-bit-vector length)))
+	   `(truly-the ,spec
+		       (%primitive allocate-vector
+				   vm:simple-bit-vector-type
+				   (the index length)
+				   (the index
+					(ceiling length vm:word-bits)))))
 	  ((csubtypep type (specifier-type 'simple-vector))
 	   `(truly-the ,spec
-		       (%primitive alloc-g-vector length initial-element)))
+		       (%primitive alloc-g-vector
+				   (the index length)
+				   initial-element)))
 	  (t
 	   (give-up "Can't open-code creation of ~S."
 		    (type-specifier type))))))
@@ -1062,13 +1410,167 @@
 ;;; MAKE-ARRAY.
 ;;;
 (def-source-transform make-string (length)
-  `(make-array ,length :element-type 'string-char))
+  `(make-array ,length :element-type 'base-character))
+
+
+;;; Transforms for various random array properties.  If the property is know
+;;; at compile time because of a type spec, use that constant value.
+
+(deftransform array-rank ((array))
+  (let ((array-type (continuation-type array)))
+    (unless (array-type-p array-type)
+      (give-up))
+    (let ((dims (array-type-dimensions array-type)))
+      (if (not (listp dims))
+	  (give-up)
+	  (length dims)))))
+
+(deftransform array-dimension ((array axis)
+			       (array index))
+  (unless (constant-continuation-p axis)
+    (give-up "Axis not constant."))
+  (let ((array-type (continuation-type array))
+	(axis (continuation-value axis)))
+    (unless (array-type-p array-type)
+      (give-up))
+    (let ((dims (array-type-dimensions array-type)))
+      (unless (listp dims)
+	(give-up
+	 "Array dimensions unknown, must call array-dimension at runtime."))
+      (unless (> (length dims) axis)
+	(abort-transform "Array has dimensions ~S, ~D is too large."
+			 dims axis))
+      (let ((dim (nth axis dims)))
+	(cond ((integerp dim)
+	       dim)
+	      ((= (length dims) 1)
+	       (ecase (array-type-complexp array-type)
+		 ((t)
+		  '(%array-dimension array 0))
+		 ((nil)
+		  '(length array))
+		 (*
+		  (give-up "Can't tell if ~S is simple" array))))
+	      (t
+	       '(%array-dimension array axis)))))))
+
+(deftransform length ((vector)
+		      ((simple-array * (*))))
+  (let ((type (continuation-type vector)))
+    (unless (array-type-p type)
+      (give-up))
+    (let ((dims (array-type-dimensions type)))
+      (unless (and (listp dims) (integerp (car dims)))
+	(give-up "Vector length unknown, must call length at runtime."))
+      (car dims))))
+
+(deftransform length ((vector) (vector))
+  '(vector-length vector))
+
+(deftransform array-total-size ((array)
+				(array))
+  (let ((array-type (continuation-type array)))
+    (unless (array-type-p array-type)
+      (give-up))
+    (let ((dims (array-type-dimensions array-type)))
+      (unless (listp dims)
+	(give-up)
+	(if (member '* dims)
+	    (do ((form 1 `(truly-the index
+				     (* (truly-the index
+						   (array-dimension array ,i))
+					,form)))
+		 (i 0 (1+ i)))
+		((= i (length dims)) form))
+	    (reduce #'* dims))))))
+
+(deftransform array-has-fill-pointer-p ((array))
+  (let ((array-type (continuation-type array)))
+    (unless (array-type-p array-type)
+      (give-up))
+    (let ((dims (array-type-dimensions array-type)))
+      (if (and (listp dims) (not (= (length dims) 1)))
+	  nil
+	  (ecase (array-type-complexp array-type)
+	    ((t)
+	     t)
+	    ((nil)
+	     nil)
+	    (*
+	     (give-up "Array type ambiguous; must call ~
+	              array-has-fill-pointer-p at runtime.")))))))
+
+;;; Primitive used to verify indicies into arrays.  If we can tell at
+;;; compile-time or we are generating unsafe code, don't bother with the VOP.
+
+(deftransform %check-bound ((array dimension index))
+  (unless (constant-continuation-p dimension)
+    (give-up))
+  (let ((dim (continuation-value dimension)))
+    `(the (integer 0 ,dim) index)))
+
+(deftransform %check-bound ((array dimension index) * *
+			    :policy (and (> speed safety) (= safety 0)))
+  'index)
+
+;;; Array accessor/setter transforms.
+
+(defmacro with-row-major-index ((array indices index &optional new-value)
+				&rest body)
+  `(let (n-indices dims)
+     (dotimes (i (length ,indices))
+       (push (make-symbol (format nil "INDEX-~D" i)) n-indices)
+       (push (make-symbol (format nil "DIM-~D" i)) dims))
+     (setf n-indices (nreverse n-indices))
+     (setf dims (nreverse dims))
+     `(lambda (,',array ,@n-indices ,@',(when new-value (list new-value)))
+	(let* (,@(let ((,index -1))
+		   (mapcar #'(lambda (name)
+			       `(,name (array-dimension ,',array
+							,(incf ,index))))
+			   dims))
+	       (,',index
+		,(if (null dims)
+		     0
+		     (do* ((dims dims (cdr dims))
+			   (indices n-indices (cdr indices))
+			   (last-dim nil (car dims))
+			   (form `(%check-bound ,',array
+						,(car dims)
+						,(car indices))
+				 `(truly-the index
+					     (+ (truly-the index
+							   (* ,form
+							      ,last-dim))
+						(%check-bound
+						 ,',array
+						 ,(car dims)
+						 ,(car indices))))))
+			  ((null (cdr dims)) form)))))
+	  ,',@body))))
+
+(deftransform array-row-major-index ((array &rest indices))
+  (with-row-major-index (array indices index)
+    index))
+
+(deftransform aref ((array &rest indices))
+  (with-row-major-index (array indices index)
+    (data-vector-ref array index)))
+
+(deftransform %aset ((array &rest stuff))
+  (let ((indices (butlast stuff)))
+    (with-row-major-index (array indices index new-value)
+      (data-vector-set array index new-value))))
+
+(deftransform row-major-aref ((array index))
+  `(data-vector-ref array (%check-bound array (array-total-size array) index)))
+
+(deftransform %set-row-major-aref ((array index new-value))
+  `(data-vector-set array
+		    (%check-bound array (array-total-size array) index)
+		    new-value))
 
 
-(deftransform array-dimension ((array dim)
-			       ((simple-array * (*)) (integer 0 0)))
-  '(length array))
-			       
 
 ;;;; Apply:
 ;;;
diff --git a/compiler/typetran.lisp b/compiler/typetran.lisp
index 5a08db8ca..97a29aea0 100644
--- a/compiler/typetran.lisp
+++ b/compiler/typetran.lisp
@@ -7,13 +7,15 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/typetran.lisp,v 1.5 1990/08/24 18:30:08 wlott Exp $
+;;;
 ;;;    This file contains stuff that implements the portable IR1 semantics of
 ;;; type tests.  The main thing we do is convert complex type tests into
 ;;; simpler code that can be compiled inline.
 ;;;
 ;;; Written by Rob MacLachlan
 ;;;
-(in-package 'c)
+(in-package "C")
 
 
 ;;;; Type predicate translation:
@@ -94,6 +96,7 @@
 ;;;    Flush %Typep tests whose result is known at compile time.
 ;;;
 (deftransform %typep ((object type))
+  (unless (constant-continuation-p type) (give-up))
   (ir1-transform-type-predicate
    object
    (specifier-type (continuation-value type))))
@@ -149,28 +152,6 @@
 (def-source-transform atom (x)
   `(not (consp ,x)))
 
-
-;;;; Internal predicates:
-;;;
-;;;    These type predicates are used to implement simple cases of typep.  They
-;;; shouldn't be used explicitly.
-
-;;; Numeric type predicates:
-;;;
-(define-type-predicate bignump bignum)
-(define-type-predicate double-float-p double-float)
-(define-type-predicate fixnump fixnum)
-(define-type-predicate long-float-p long-float)
-(define-type-predicate ratiop ratio)
-(define-type-predicate short-float-p short-float)
-(define-type-predicate single-float-p single-float)
-
-;;; Character type predicates.  Unlike the un-%'ed versions, these are true
-;;; type predicates, accepting any type object.
-;;;
-(define-type-predicate %string-char-p string-char)
-(define-type-predicate %standard-char-p standard-char)
-
 
 ;;;; Typep source transform:
 
@@ -217,16 +198,11 @@
 ;;;
 (defun source-transform-numeric-typep (object type)
   (let* ((class (numeric-type-class type))
-	 (low (numeric-type-low type))
-	 (high (numeric-type-high type))
 	 (base (ecase class
-		 (integer
-		  (if (and low (>= low most-negative-fixnum)
-			   high (<= high most-positive-fixnum))
-		      'fixnum
-		      'integer))
+		 (integer (containing-integer-type type))
 		 (rational 'rational)
-		 (float (or (numeric-type-format type) 'float)))))
+		 (float (or (numeric-type-format type) 'float))
+		 ((nil) 'number))))
     (once-only ((n-object object))
       (ecase (numeric-type-complexp type)
 	(:real
@@ -236,11 +212,14 @@
 	 `(and (complexp ,n-object)
 	       ,(once-only ((n-real `(realpart (the complex ,n-object)))
 			    (n-imag `(imagpart (the complex ,n-object))))
-		  `(and (typep ,n-real ',base)
-			,@(unless (eq class 'float) `((typep ,n-imag ',base)))
-			,(transform-numeric-bound-test n-real type base)
-			,(transform-numeric-bound-test n-imag type
-						       base)))))))))
+		  `(progn
+		     ,n-imag ; ignorable
+		     (and (typep ,n-real ',base)
+			  ,@(when (eq class 'integer)
+			      `((typep ,n-imag ',base)))
+			  ,(transform-numeric-bound-test n-real type base)
+			  ,(transform-numeric-bound-test n-imag type
+							 base))))))))))
 
 
 ;;; Source-Transform-Hairy-Typep  --  Internal
-- 
GitLab