diff --git a/src/cmp/cmpnum.lsp b/src/cmp/cmpnum.lsp
index 1264efcc0..ba5a50c97 100644
--- a/src/cmp/cmpnum.lsp
+++ b/src/cmp/cmpnum.lsp
@@ -14,28 +14,32 @@
 (in-package "COMPILER")
 
 (defun simplify-arithmetic (operator args whole)
-  (let ((l (length args)))
-    (cond ((every #'numberp args)
-	   (apply operator args))
-          ((> l 2)
-	   (simplify-arithmetic
-	    operator
-	    (list* (simplify-arithmetic operator (list (first args) (second args)) nil)
-		   (cddr args))
-	    nil))
-	  ((= l 2)
-	   (or whole (list* operator args)))
-	  ((= l 1)
-	   (if (or (eq operator '*) (eq operator '+))
-	       (first args)
-	       (or whole (list* operator args))))
-	  ((eq operator '*)
-	   1)
-	  ((eq operator '+)
-	   0)
-	  (t
-	   (error 'simple-program-error :format-error "Wrong number of arguments for operator ~a in ~a"
-		  :format-arguments (list operators (or whole (list* operator args))))))))
+  (if (every #'numberp args)
+      (apply operator args)
+      (let ((l (length args)))
+        (cond ((> l 2)
+               (simplify-arithmetic
+                operator
+                (list* (simplify-arithmetic operator
+                                            (list (first args) (second args))
+                                            nil)
+                       (cddr args))
+                nil))
+              ((= l 2)
+               (or whole (list* operator args)))
+              ((= l 1)
+               (if (or (eq operator '*) (eq operator '+))
+                   (first args)
+                   (or whole (list* operator args))))
+              ((eq operator '*)
+               1)
+              ((eq operator '+)
+               0)
+              (t
+               (error 'simple-program-error
+                      :format-error "Wrong number of arguments for operator ~a in ~a"
+                      :format-arguments (list operators (or whole
+                                                            (list* operator args)))))))))
 
 (define-compiler-macro * (&whole all &rest args)
   (simplify-arithmetic '* args all))
@@ -49,3 +53,61 @@
 (define-compiler-macro - (&whole all &rest args)
   (simplify-arithmetic '- args all))
 
+;;;
+;;; The following are type propagators for arithmetic operations. Note
+;;; that some of they have become binary operators.
+;;;
+
+(defun maximum-number-type (t1 t2)
+  (let ((t1-eq nil)
+        (t2-eq nil)
+        (output nil))
+    (dolist (i '(FIXNUM INTEGER RATIONAL
+                 #+short-float SHORT-FLOAT SINGLE-FLOAT
+                 DOUBLE-FLOAT #+long-float LONG-FLOAT FLOAT REAL
+                 COMPLEX NUMBER)
+             (values (if (and t1-eq t2-eq output)
+                         output
+                         t)
+                     t1 t2))
+      (when (and (null t1-eq) (type>= i t1))
+        (setf t1-eq i)
+        (if (equalp t1 t2)
+            (setf t2-eq i))
+        (setf output t1-eq))
+      (when (and (null t2-eq) (type>= i t2))
+        (setf t2-eq i)
+        (setf output t1-eq)))))
+
+(defun prod/plus-propagator (op1 op2)
+  (multiple-value-bind (result-type op1-type op2-type)
+        (maximum-number-type (c1form-primary-type op1)
+                             (c1form-primary-type op2))
+    (when (and (eq op1-type 'FIXNUM)
+               (eq op2-type 'FIXNUM))
+      (setf result-type 'INTEGER))
+    (values (list op1-type op2-type) result-type)))
+
+(def-type-propagator * (fname op1 op2)
+  (prod/plus-propagator op1 op2))
+
+(def-type-propagator + (fname op1 op2)
+  (prod/plus-propagator op1 op2))
+
+(def-type-propagator - (fname op1 &optional (op2 nil op2-p))
+  (let* ((t1 (c1form-primary-type op1))
+         (t2 (if op2-p (c1form-primary-type op2) t1)))
+    (values (if op2-p (list t1 t2) (list t1))
+            (maximum-number-type t1 t2))))
+
+(def-type-propagator / (fname op1 &optional (op2 nil op2-p))
+  (multiple-value-bind (output t1 t2)
+        (let ((t1 (c1form-primary-type op1)))
+          (if op2-p
+              (maximum-number-type t1 (c1form-primary-type op2))
+              (maximum-number-type 'FIXNUM t1)))
+    (when (and (member t1 '(FIXNUM INTEGER))
+               (member t2 '(FIXNUM INTEGER)))
+      (setf output 'RATIONAL))
+    (values (if op2-p (list t1 t2) (list t1))
+            output)))