;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 124.80
;;; Reason:
;;;  Both the Gray Manual and Steele claim that (evenp) and (oddp) gave errors
;;;  if their argument was a complex number.  As coded, they instead always
;;;  returned NIL, since the software canonicalizes complex numbers with zero
;;;  imaginary parts into real numbers.
;;; Written 20-Jun-88 17:50:55 by pld (Peter L. DeWolf) at site Gigamos Cambridge
;;; while running on Cthulhu from band 1
;;; with Experimental System 124.79, Experimental Local-File 74.2, Experimental File-Server 23.1, Experimental Unix-Interface 12.0, Experimental ZMail 72.1, Experimental Tape 23.6, Experimental Lambda-Diag 16.2, microcode 1760, SDU Boot Tape 3.14, SDU ROM 8, the old ones.



; From modified file DJ: L.SYS2; RAT.LISP#53 at 20-Jun-88 17:50:56
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; RAT  "

(defun numeric-one-argument (code number)
  (declare (dbg:error-reporter))
  (macrolet ((illegal-rational (function number)
	       `(ferror "~S illegally applied to the rational number ~S" ,function ,number))
	     (illegal-complex (function number)
	       `(ferror "~S illegally applied to the complex number ~S" ,function ,number)))
    (unless (eq (%data-type number) dtp-extended-number)
      (ferror "Trap to macrocode for arithmetic on ~S" number))
    (case (%p-ldb-offset %%header-type-field number 0)
      ((#,%header-type-rational)
       (let ((num (%rational-numerator number))
	     (den (%rational-denominator number)))
	 (case (logand #o77 code)
	   (0 (if ( num 0)							;ABS
		  number
		(%ratio-cons (abs num) den)))
	   (1 (%ratio-cons (- num) den))					;MINUS
	   (2 (= num 0))							;ZEROP
	   (3 (> num 0))							;PLUSP
	   (4 (< num 0))							;MINUSP
	   (5 (%ratio-cons (+ num den) den))					;ADD1
	   (6 (%ratio-cons (- num den) den))					;SUB1
	   (7 (case (ldb #o0603 code)
		(0 (if (plusp num) (truncate num den)				; FLOOR
		     (truncate (- num den -1) den)))
		(1 (if (minusp num) (truncate num den)				; CEILING
		     (truncate (+ num den -1) den)))
		(2 (truncate num den))						; TRUNCATE
		(3								; ROUND
		 (let* ((floor (if (plusp num) (truncate num den)
				 (truncate (- num den -1) den)))
			(fraction-num (- num (* floor den)))
			(half-indicator (- (+ fraction-num fraction-num) den)))
		   (if (or (plusp half-indicator)
			   (and (zerop half-indicator)
				(oddp floor)))
		       (1+ floor)
		     floor)))))
	   (8   (// (float num) (float den)))					;FLOAT
	   (9   (// (small-float num) (small-float den)))			;SMALL-FLOAT
	   (10. (illegal-rational 'haulong number))
	   (11. (illegal-rational 'ldb number))
	   (12. (illegal-rational 'dpb number))
	   (13. (illegal-rational 'ash number))
	   (14. (illegal-rational 'oddp number))
	   (15. (illegal-rational 'evenp number))
	   (t (ferror "Arith one-arg op code ~D on ~S" code number)))))
      ((#,%header-type-complex)
       (let ((real (%complex-real-part number))
	     (imag (%complex-imag-part number)))
	 (case (logand #o77 code)
	   (0									;ABS
	    (if (zerop number)
		0
	      (let ((min (min (abs real) (abs imag)))
		    (max (max (abs real) (abs imag)))
		    tem			    
		    (zunderflow t))
		(if (rationalp max) (setq max (float max)))
		(setq tem (// min max))
		(* (sqrt (+ (* tem tem) 1)) max))))				;ABS
	   (1 (%complex-cons (- real) (- imag)))				;MINUS
	   (2 (and (zerop real) (zerop imag)))					;ZEROP
	   (3 (illegal-complex 'plusp number))
	   (4 (illegal-complex 'minusp number))
	   (5 (%complex-cons (1+ real) imag))					;ADD1
	   (6 (%complex-cons (1- real) imag))					;SUB1
	   (7 (case (ldb #o0603 code)
		(0 (illegal-complex 'floor number))
		(1 (illegal-complex 'ceiling number))
		(2 (illegal-complex 'truncate number))
		(3 (illegal-complex 'round number))))
	   (8 (%complex-cons (float real) (float imag)))		      	;float
	   (9 (%complex-cons (small-float real) (small-float imag)))		;small float
	   (10. (illegal-complex 'haulong number))
	   (11. (illegal-complex 'ldb number))
	   (12. (illegal-complex 'dpb number))
	   (13. (illegal-complex 'ash number))
	   (14. (illegal-complex 'oddp number)					;ODDP
		;;(and (zerop imag) (oddp real))
		)
	   (15. (illegal-complex 'evenp number)					;EVENP
		;;(and (zerop imag) (evenp real))
		)
	   (t (ferror "Arith one-arg op code ~D on ~S" code number)))))
      (t (ferror "Trap to macrocode for arithmetic on number ~S" number)))))

))