diff --git a/compiler/float-tran.lisp b/compiler/float-tran.lisp
index 86b7e8a8cecd6e2d0cc5f7482b6231b53684e9a0..6104a7dcdd135b256d5c0aacf9b17341bb5ce5f1 100644
--- a/compiler/float-tran.lisp
+++ b/compiler/float-tran.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.54 1997/12/18 16:42:02 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.55 1997/12/18 19:01:00 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -280,9 +280,9 @@
 			   :high new-hi)))))
 ;;;
 (defoptimizer (scale-single-float derive-type) ((f ex))
-  (two-arg-derive-type f ex #'scale-float-derive-type-aux))
+  (two-arg-derive-type f ex #'scale-float-derive-type-aux #'scale-single-float))
 (defoptimizer (scale-double-float derive-type) ((f ex))
-  (two-arg-derive-type f ex #'scale-float-derive-type-aux))
+  (two-arg-derive-type f ex #'scale-float-derive-type-aux #'scale-double-float))
 	     
 ;;; toy@rtp.ericsson.se:
 ;;;
@@ -307,7 +307,7 @@
 	       (specifier-type `(,',type ,(or lo '*) ,(or hi '*)))))
 	   
 	   (defoptimizer (,fun derive-type) ((num))
-	     (one-arg-derive-type num #',aux-name))))))
+	     (one-arg-derive-type num #',aux-name #',fun))))))
   (frob %single-float single-float)
   (frob %double-float double-float))
 ) ; end progn  
@@ -628,7 +628,8 @@
 	    #'(lambda (arg)
 		(elfun-derive-type-simple arg #',name
 					  ,cond
-					  ,def-lo-bnd ,def-hi-bnd)))))))
+					  ,def-lo-bnd ,def-hi-bnd))
+	    #',name)))))
   ;; These functions are easy because they are defined for the whole
   ;; real line.
   (frob exp (constantly t)
@@ -688,12 +689,12 @@
 				((consp lo) (list (coerce 0 f-type)))
 				(t (coerce 0 f-type)))
 		     :high (bound-func #'sqrt hi)))
-		  (float-or-complex-type arg))))
+		  (float-or-complex-type arg 0))))
 	   (t
 	    (float-or-complex-type arg 0))))))
 ;;;
 (defoptimizer (sqrt derive-type) ((num))
-  (one-arg-derive-type num #'sqrt-derive-type-aux))
+  (one-arg-derive-type num #'sqrt-derive-type-aux #'sqrt))
 
 
 ;;; Acos is monotonic decreasing, so we need to swap the function
@@ -725,7 +726,7 @@
 	    (float-or-complex-type arg 0 pi))))))
 ;;;
 (defoptimizer (acos derive-type) ((num))
-  (one-arg-derive-type num #'acos-derive-type-aux))
+  (one-arg-derive-type num #'acos-derive-type-aux #'acos))
 
 
 ;;; Compute bounds for (expt x y).  This should be easy since (expt x
@@ -890,7 +891,7 @@
 		(float-or-complex-type (numeric-contagion x y)))))))
 
 (defoptimizer (expt derive-type) ((x y))
-  (two-arg-derive-type x y #'expt-derive-type-aux))
+  (two-arg-derive-type x y #'expt-derive-type-aux #'expt))
 
 
 ;;; Note must assume that a type including 0.0 may also include -0.0
@@ -940,8 +941,8 @@
 
 (defoptimizer (log derive-type) ((x &optional y))
   (if y
-      (two-arg-derive-type x y #'log-derive-type-aux-2)
-      (one-arg-derive-type x #'log-derive-type-aux-1)))
+      (two-arg-derive-type x y #'log-derive-type-aux-2 #'log)
+      (one-arg-derive-type x #'log-derive-type-aux-1 #'log)))
 
 
 (defun atan-derive-type-aux-1 (y)
@@ -967,9 +968,9 @@
 
 (defoptimizer (atan derive-type) ((y &optional x))
   (cond ((null x)
-	 (one-arg-derive-type y #'atan-derive-type-aux-1))
+	 (one-arg-derive-type y #'atan-derive-type-aux-1 #'atan))
 	(t
-	 (two-arg-derive-type y x #'atan-derive-type-aux-2))))
+	 (two-arg-derive-type y x #'atan-derive-type-aux-2 #'atan))))
 
 
 (defun cosh-derive-type-aux (x)
@@ -980,7 +981,7 @@
    #'cosh (constantly t) 0 nil))
 
 (defoptimizer (cosh derive-type) ((num))
-  (one-arg-derive-type num #'cosh-derive-type-aux))
+  (one-arg-derive-type num #'cosh-derive-type-aux #'cosh))
 
 
 (defun phase-derive-type-aux (type)
@@ -1031,7 +1032,7 @@
 			    :high pi))))
 
 (defoptimizer (phase derive-type) ((num))
-  (one-arg-derive-type num #'phase-derive-type-aux))
+  (one-arg-derive-type num #'phase-derive-type-aux #'phase))
 
 ) ;end progn for propagate-fun-type
 
@@ -1067,7 +1068,7 @@
 			      :high (numeric-type-high type)))))
 
 (defoptimizer (realpart derive-type) ((num))
-  (one-arg-derive-type num #'realpart-derive-type-aux))
+  (one-arg-derive-type num #'realpart-derive-type-aux #'realpart))
 
 (defun imagpart-derive-type-aux (type)
   (cond ((numeric-type-real-p type)
@@ -1089,7 +1090,7 @@
 			    :high (numeric-type-high type)))))
 
 (defoptimizer (imagpart derive-type) ((num))
-  (one-arg-derive-type num #'imagpart-derive-type-aux))
+  (one-arg-derive-type num #'imagpart-derive-type-aux #'imagpart))
 
 (defun complex-derive-type-aux-1 (re-type)
   (if (numeric-type-p re-type)
@@ -1133,8 +1134,8 @@
 
 (defoptimizer (complex derive-type) ((re &optional im))
   (if im
-      (two-arg-derive-type re im #'complex-derive-type-aux-2)
-      (one-arg-derive-type re #'complex-derive-type-aux-1)))
+      (two-arg-derive-type re im #'complex-derive-type-aux-2 #'complex)
+      (one-arg-derive-type re #'complex-derive-type-aux-1 #'complex)))
 
 
 ;;; Define some transforms for complex operations.  We do this in lieu
@@ -1224,10 +1225,10 @@
 	    (float-or-complex-type arg -1 1))))))
 
 (defoptimizer (sin derive-type) ((num))
-  (one-arg-derive-type num #'sincos-derive-type-aux))
+  (one-arg-derive-type num #'sincos-derive-type-aux #'sin))
        
 (defoptimizer (cos derive-type) ((num))
-  (one-arg-derive-type num #'sincos-derive-type-aux))
+  (one-arg-derive-type num #'sincos-derive-type-aux #'cos))
 
 
 (defun tan-derive-type-aux (arg)
@@ -1244,7 +1245,7 @@
 	    (float-or-complex-type arg))))))
 
 (defoptimizer (tan derive-type) ((num))
-  (one-arg-derive-type num #'tan-derive-type-aux))
+  (one-arg-derive-type num #'tan-derive-type-aux #'tan))
 
 ;;; conjugate always returns the same type as the input type  
 (defoptimizer (conjugate derive-type) ((num))
@@ -1254,6 +1255,7 @@
   (one-arg-derive-type num
      #'(lambda (arg)
 	 (c::specifier-type
-	  `(complex ,(or (numeric-type-format arg) 'single-float))))))
+	  `(complex ,(or (numeric-type-format arg) 'single-float))))
+     #'cis))
 
 ) ; end progn
diff --git a/compiler/srctran.lisp b/compiler/srctran.lisp
index cafc55bdedeb52500c9e849feeb2dd1f8264f9ad..5ae082e6a164e2a32d5e918eea72c298f2689492 100644
--- a/compiler/srctran.lisp
+++ b/compiler/srctran.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.66 1997/12/17 19:24:39 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.67 1997/12/18 19:00:55 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -812,21 +812,18 @@
 	     (t
 	      (list arg))))
 	 (convert-member-type (type)
-	   ;; Run down the list of members and convert to the
-	   ;; appropriate numeric-type.
+	   ;; Run down the list of members and convert to a list of
+	   ;; member types.
 	   (mapcar #'(lambda (element)
 		       (if (numberp element)
-			   (let ((type (type-of element)))
-			     (specifier-type `(,(if (subtypep type 'integer)
-						    'integer
-						    type) ,element ,element)))
+			   (specifier-type `(member ,element))
 			   *empty-type*))
 		   (member-type-members type))))
     (when (eq arg *empty-type*)
       (return-from prepare-arg-for-derive-type nil))
     ;; Make sure all args are some type of numeric-type.  For member
     ;; types, convert the list of members into a union of equivalent
-    ;; numeric-types.
+    ;; single-element member-type's.
     (let ((new-args (flatten-list (mapcar #'(lambda (x)
 					      (if (member-type-p x)
 						  (convert-member-type x)
@@ -844,19 +841,32 @@
 ;;;
 ;;; Given the continuation ARG, derive the resulting type using the
 ;;; DERIVE-FCN.  DERIVE-FCN takes exactly one argument which is some
-;;; "atomic" continuation type like numeric-type.  It should return
-;;; the resulting type, which can be a list of types.
+;;; "atomic" continuation type like numeric-type or member-type
+;;; (containing just one element).  It should return the resulting
+;;; type, which can be a list of types.
 ;;;
-(defun one-arg-derive-type (arg derive-fcn)
-  (let ((arg-list (prepare-arg-for-derive-type (continuation-type arg)))
-	(result '()))
+;;; For the case of member types, we call FCN on the element of the
+;;; member type to get the resulting member type result.
+;;;
+(defun one-arg-derive-type (arg derive-fcn fcn)
+  (let ((arg-list (prepare-arg-for-derive-type (continuation-type arg))))
     (when arg-list
-      ;; Run down the list of args and derive the type of each one and
-      ;; save all of the results in a list.
-      (setf result (flatten-list (mapcar derive-fcn arg-list)))
-      (if (rest result)
-	  (make-union-type result)
-	  (first result)))))
+      (flet
+	  ((deriver (x)
+	     (etypecase x
+	       (member-type
+		(with-float-traps-masked (:underflow :overflow :divide-by-zero)
+		    
+		  (specifier-type
+		   `(member ,(funcall fcn (first (member-type-members x)))))))
+	       (numeric-type
+		(funcall derive-fcn x)))))
+	;; Run down the list of args and derive the type of each one and
+	;; save all of the results in a list.
+	(let ((result (flatten-list (mapcar #'deriver arg-list))))
+	  (if (rest result)
+	      (make-union-type result)
+	      (first result)))))))
 
 ;;; TWO-ARG-DERIVE-TYPE
 ;;;
@@ -867,27 +877,53 @@
 ;;; deriving the type of things like (* x x), which should always be
 ;;; positive.  If we didn't do this, we wouldn't be able to tell.
 ;;;
-(defun two-arg-derive-type (arg1 arg2 derive-fcn)
-  (let ((same-arg (same-leaf-ref-p arg1 arg2))
-	(a1 (prepare-arg-for-derive-type (continuation-type arg1)))
-	(a2 (prepare-arg-for-derive-type (continuation-type arg2)))
-	(result '()))
-    (when (and a1 a2)
-      (if same-arg
-	  ;; Since the args are the same continuation, just run down on
-	  ;; of the lists.
-	  (dolist (x a1)
-	    (push (funcall derive-fcn x x same-arg) result))
-	  ;; Try all pairwise combinations and gather the result
-	  (dolist (x a1)
-	    (dolist (y a2)
-	      (push (or (funcall derive-fcn x y same-arg)
-			(numeric-contagion x y))
-		    result))))
-      (setf result (flatten-list result))
-      (if (rest result)
-	      (make-union-type result)
-	      (first result)))))
+(defun two-arg-derive-type (arg1 arg2 derive-fcn fcn)
+  (labels
+      ((maybe-convert-member-type (arg)
+	 (etypecase arg
+	   (numeric-type arg)
+	   (member-type
+	    (let* ((val (first (member-type-members arg)))
+		   (val-type (type-of val)))
+	      (specifier-type `(,(if (subtypep val-type 'integer)
+				     'integer
+				     val-type)
+				,val ,val))))))
+       (deriver (x y same-arg)
+	 (let* ((member-result-p (and (member-type-p x) (member-type-p y)))
+		(x (maybe-convert-member-type x))
+		(y (maybe-convert-member-type y))
+		(result
+		 (if member-result-p
+		     (with-float-traps-masked
+			 (:underflow :overflow :divide-by-zero)
+		       (funcall fcn
+				(numeric-type-low x)
+				(numeric-type-low y)))
+		     (funcall derive-fcn x y same-arg))))
+	   (if (and member-result-p result)
+	       (specifier-type `(member ,result))
+	       result))))
+    (let ((same-arg (same-leaf-ref-p arg1 arg2))
+	  (a1 (prepare-arg-for-derive-type (continuation-type arg1)))
+	  (a2 (prepare-arg-for-derive-type (continuation-type arg2)))
+	  (result '()))
+      (when (and a1 a2)
+	(if same-arg
+	    ;; Since the args are the same continuation, just run down on
+	    ;; of the lists.
+	    (dolist (x a1)
+	      (push (deriver x x same-arg) result))
+	    ;; Try all pairwise combinations and gather the result
+	    (dolist (x a1)
+	      (dolist (y a2)
+		(push (or (deriver x y same-arg)
+			  (numeric-contagion x y))
+		      result))))
+	(setf result (flatten-list result))
+	(if (rest result)
+	    (make-union-type result)
+	    (first result))))))
 
 ) ; end progn
 
@@ -978,7 +1014,7 @@
 
 
 (defoptimizer (+ derive-type) ((x y))
-  (two-arg-derive-type x y #'+-derive-type-aux))
+  (two-arg-derive-type x y #'+-derive-type-aux #'+))
 
 (defun --derive-type-aux (x y same-arg)
   (if (and (numeric-type-real-p x)
@@ -1011,7 +1047,7 @@
       (numeric-contagion x y)))
 
 (defoptimizer (- derive-type) ((x y))
-  (two-arg-derive-type x y #'--derive-type-aux))
+  (two-arg-derive-type x y #'--derive-type-aux #'-))
 
 (defun *-derive-type-aux (x y same-arg)
   (if (and (numeric-type-real-p x)
@@ -1044,7 +1080,7 @@
       (numeric-contagion x y)))
 
 (defoptimizer (* derive-type) ((x y))
-  (two-arg-derive-type x y #'*-derive-type-aux))
+  (two-arg-derive-type x y #'*-derive-type-aux #'*))
 
 (defun /-derive-type-aux (x y same-arg)
   (if (and (numeric-type-real-p x)
@@ -1076,7 +1112,7 @@
 
 
 (defoptimizer (/ derive-type) ((x y))
-  (two-arg-derive-type x y #'/-derive-type-aux))
+  (two-arg-derive-type x y #'/-derive-type-aux #'/))
 
 ) ;end progn
 
@@ -1152,7 +1188,8 @@
 				      (if hi (negate-bound hi) nil))
 			       (setf (numeric-type-high result)
 				     (if lo (negate-bound lo) nil))
-			       result)))))
+			       result))
+			 #'-)))
 
 #-propagate-float-type
 (defoptimizer (abs derive-type) ((num))
@@ -1196,7 +1233,7 @@
 			      :high (interval-high abs-bnd))))))
 #+propagate-float-type
 (defoptimizer (abs derive-type) ((num))
-  (one-arg-derive-type num #'abs-derive-type-aux))
+  (one-arg-derive-type num #'abs-derive-type-aux #'abs))
 
 #-propagate-float-type
 (defoptimizer (truncate derive-type) ((number divisor))
@@ -1340,8 +1377,8 @@
   (make-values-type
    :required
    (list
-    (two-arg-derive-type number divisor #'truncate-derive-type-quot-aux)
-    (two-arg-derive-type number divisor #'truncate-derive-type-rem-aux))))
+    (two-arg-derive-type number divisor #'truncate-derive-type-quot-aux #'truncate)
+    (two-arg-derive-type number divisor #'truncate-derive-type-rem-aux #'rem))))
 
 (defun ftruncate-derive-type-quot (number-type divisor-type)
   ;; The bounds are the same as for truncate.  However, the first
@@ -1365,15 +1402,17 @@
   (make-values-type
    :required
    (list
-    (two-arg-derive-type number divisor #'ftruncate-derive-type-quot-aux)
-    (two-arg-derive-type number divisor #'truncate-derive-type-rem-aux))))
+    (two-arg-derive-type number divisor #'ftruncate-derive-type-quot-aux #'ftruncate)
+    (two-arg-derive-type number divisor #'truncate-derive-type-rem-aux #'rem))))
 
 
 (defun %unary-truncate-derive-type-aux (number)
   (truncate-derive-type-quot number (specifier-type '(integer 1 1))))
 
 (defoptimizer (%unary-truncate derive-type) ((number))
-  (one-arg-derive-type number #'%unary-truncate-derive-type-aux))
+  (one-arg-derive-type number
+		       #'%unary-truncate-derive-type-aux
+		       #'%unary-truncate))
 
 ;;; Define optimizers for floor and ceiling
 (macrolet
@@ -1435,8 +1474,8 @@
 			  *empty-type*)))
 	       (make-values-type
 		:required
-		(list (two-arg-derive-type number divisor #'derive-q)
-		      (two-arg-derive-type number divisor #'derive-r)))))
+		(list (two-arg-derive-type number divisor #'derive-q #',name)
+		      (two-arg-derive-type number divisor #'derive-r #'mod)))))
 	   ))))
   
   (frob-opt floor floor-quotient-bound floor-rem-bound)
@@ -1478,8 +1517,8 @@
 			  *empty-type*)))
 	       (make-values-type
 		:required
-		(list (two-arg-derive-type number divisor #'derive-q)
-		      (two-arg-derive-type number divisor #'derive-r)))))))))
+		(list (two-arg-derive-type number divisor #'derive-q #',name)
+		      (two-arg-derive-type number divisor #'derive-r #'mod)))))))))
   
   (frob-opt ffloor floor-quotient-bound floor-rem-bound)
   (frob-opt fceiling ceiling-quotient-bound ceiling-rem-bound))