;;; -*- Mode: Common-Lisp; Package: User; Base: 8.; Patch-File: T -*-

;;; Reason: Fixed Numeric-one-argument for handling float of single floats.
;;; Code wasn't handling rounding correctly. - RJF

;;;                           RESTRICTED RIGHTS LEGEND
;;;
;;; Use, duplication, or disclosure by the Government is subject to
;;; restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;; Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;   TEXAS INSTRUMENTS INCORPORATED      
;;;   P.O. BOX 2909, M/S 2151             
;;;   AUSTIN, TEXAS 78769                 
;;;
;;; Copyright (C) 1989 Texas Instruments Incorporated.
;;; All rights reserved.

;;; Patch file for SYSTEM version 6.34
;;; Written 05/23/90 11:58:08 by FISH,
;;; while running on DaVinci from band LOD2
;;; With SYSTEM 6.31, VIRTUAL-MEMORY 6.3, EH 6.7, MAKE-SYSTEM 6.3, MICRONET 6.0, LOCAL-FILE 6.2,
;;;  BASIC-PATHNAME 6.4, NETWORK-SUPPORT-COLD 6.2, BASIC-NAMESPACE 6.7, NETWORK-NAMESPACE 6.1,
;;;  DISK-IO 6.3, DISK-LABEL 6.0, BASIC-FILE 6.10, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.2,
;;;  COMPILER 6.14, TV 6.24, DATALINK 6.0, CHAOSNET 6.6, GC 6.4, MEMORY-AUX 6.0, NVRAM 6.3,
;;;  SYSLOG 6.2, STREAMER-TAPE 6.5, UCL 6.0, INPUT-EDITOR 6.0, METER 6.1, ZWEI 6.15,
;;;  DEBUG-TOOLS 6.4, NETWORK-SUPPORT 6.1, NETWORK-SERVICE 6.2, DATALINK-DISPLAYS 6.0,
;;;  FONT-EDITOR 6.1, SERIAL 6.0, PRINTER 6.5, MAC-PRINTER-TYPES 6.2, PRINTER-TYPES 6.2,
;;;  IMAGEN 6.1, SUGGESTIONS 6.1, MAIL-DAEMON 6.6, MAIL-READER 6.8, TELNET 6.1, VT100 6.0,
;;;  NAMESPACE-EDITOR 6.4, PROFILE 6.3, VISIDOC 6.7, TI-CLOS 6.46, CLEH 6.5, IP 3.62,
;;;  Experimental CLX 6.11, CLUE 6.104, X11M 6.24, Experimental BUG 11.19,  microcode 483,
;;;  Band Name: Rel 6.0 + SLE 5/21

#!C
; From file NUMBERS.LISP#> KERNEL; Hotel:
#8R SYSTEM#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* *COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; NUMBERS.#"


(DEFUN numeric-one-argument (code number)
  (COND ((RATIONALP number)
	 (LET ((num (rational-numerator number))
	       (den (rational-denominator number)))
	   (CASE (LOGAND #x3F code)
		 (0 (IF (OR (= num 0)			;ABS
			    (AND (> num 0) (> den 0))
			    (AND (< den 0) (< num 0)))
			number
			(make-rational (ABS num) (ABS den))))
		 (1 (make-rational (- num) den))	;MINUS
		 (2 (= num 0))			;ZEROP
		 (3 (OR (AND (> num 0) (> den 0))	;PLUSP
			(AND (< num 0) (< den 0))))
		 (4 (OR (AND (> num 0) (< den 0))	;MINUSP
			(AND (< num 0) (> den 0))))
		 (5 (make-rational (+ num den) den))	;ADD1
		 (6 (make-rational (- num den) den))	;SUB1
		 (7					;FIX
		  (CASE (LDB #o0603 code)
			(0 (IF (PLUSP num) (TRUNCATE num den)
			       (TRUNCATE (- num den -1) den)))
			(1 (IF (MINUSP num) (TRUNCATE num den)
			       (TRUNCATE (+ num den -1) den)))
			(2 (TRUNCATE num den))
			(3
			 (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)))
			       (INCF floor))
			   floor))))
		 (#o10 				        ;Single-float
		  (LET* ((other 1.0f0)
			 (iln (INTEGER-LENGTH num))
			 (ild (INTEGER-LENGTH den))
			 (fdo (FLOAT-DIGITS other))
			 (fld (MIN (+ fdo 2) ild))	;Provide 2 additional guard bits
			 (fln (+ fld fdo)))
		    (WHEN (> (ASH num (- ild iln)) den)
		      (INCF iln))
		    ; The result of the round in is the 24 bit fraction and 1 bit 
                    ; for rounding.  If the round didn't round up (as noted by a 
                    ; negative remainder), then we must determine if we need to round
                    ; up.  The microcode for bignum to float will round down when 
                    ; the bits is is dropping is exactly 1/2, so we must compensate
                    ; if the dropped bits is really > 1/2 - RJF
		    (MULTIPLE-VALUE-BIND (quotient remainder)
			(ROUND (ASH num (- fln iln)) (ASH den (- fld ild)))
		      (if (and (> remainder 0)(oddp quotient)(= (haulong quotient) 25.))
			  (setf quotient (1+ quotient)))
  		      (SCALE-FLOAT (FLOAT quotient other) (- iln ild fdo)) )))
		 (#o11				        ;Short-float
		  (LET* ((other 1.0s0)
			 (iln (INTEGER-LENGTH num))
			 (ild (INTEGER-LENGTH den))
			 (fdo (FLOAT-DIGITS other))
			 (fld (MIN (+ fdo 2) ild))	;Provide 2 additional guard bits
			 (fln (+ fld fdo)))
		    (WHEN (> (ASH num (- ild iln)) den)
		      (INCF iln))
		    (SCALE-FLOAT
		      (FLOAT (ROUND (ASH num (- fln iln)) (ASH den (- fld ild))) other)
		      (- iln ild fdo))))
		 (#o12 (FERROR nil "Illegal operation \"HAULONG\" on ~s" number))
		 (#o13 (FERROR nil "Illegal operation \"LDB\" on ~s" number))
		 (#o14 (FERROR nil "Illegal operation \"DPB\" on ~s" number))
		 (#o15 (FERROR nil "Illegal operation \"ASH\" on ~s" number))
		 (#o16					;Double-float
		  (LET* ((iln (INTEGER-LENGTH num))
			 (ild (INTEGER-LENGTH den))
;;;			 (fdo (FLOAT-DIGITS 1.0d0))	;Only do this natively!!!
			 (fdo 53.)
			 (fld (MIN (+ fdo 2) ild))	;Provide 2 additional guard bits
			 (fln (+ fld fdo)))
		    (WHEN (> (ASH num (- ild iln)) den)
		      (INCF iln))
		    (SCALE-FLOAT
		      (double-float (ROUND (ASH num (- fln iln)) (ASH den (- fld ild))))
		      (- iln ild fdo))))
		 (t (FERROR nil "Arith one-arg op code ~S on ~s" code number)))))
	((COMPLEXP number)
	 (LET ((real (complex-real-part number))
	       (imag (complex-imag-part number)))
	   (CASE code
		 (0 (LET ((y (ABS real))
			  (x (ABS imag)))
		      (WHEN (< y x) (PSETQ y x x y))
		      (IF (ZEROP x)			;X is always the smaller of X and Y
			  y				;Already properly coerced
			  (* y (SQRT (1+ (sqr (/ x y))))))))	;ABS
		 (1 (COMPLEX (- real) (- imag)))	;MINUS
		 (2 (AND (ZEROP real) (ZEROP imag)))	;ZEROP
		 (3 (FERROR nil "PLUSP applied to the complex number ~s" number))	;PLUSP
		 (4 (FERROR nil "MINUSP applied to the complex number ~s" number))	;MINUSP
		 (5 (COMPLEX (+ real 1) imag))		;ADD1
		 (6 (COMPLEX (- real 1) imag))		;SUB1
		 (7 (COMPLEX (FLOOR real) (FLOOR imag)))	;FIX
		 (#o10 (COMPLEX				;Single-float
			 (internal-float real)
			 (internal-float imag)))
		 (#o11 (COMPLEX				;Short-float
			 (SMALL-FLOAT real)
			 (SMALL-FLOAT imag)))
		 (#o12 (FERROR nil "Illegal operation \"HAULONG\" on ~s" number))
		 (#o13 (FERROR nil "Illegal operation \"LDB\" on ~s" number))
		 (#o14 (FERROR nil "Illegal operation \"DPB\" on ~s" number))
		 (#o15 (FERROR nil "Illegal operation \"ASH\" on ~s" number))
		 (#o16 (COMPLEX				;Double-float
			 (double-float real)
			 (double-float imag)))
		 (t (FERROR nil "Arith one-arg op code ~S on ~s" code number)))))
	(t (FERROR nil "Trap to macrocode for arithmetic on number ~s" number))))
))