;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 123.19
;;; Reason:
;;;  Fix storage convention violations that could result in incorrect results from LOG, etc.  This
;;;  was responsible for the "bignum print bombout bug".
;;; Written 28-Sep-87 11:45:13 by rg at site LMI Cambridge
;;; while running on Love from band 2
;;; with Experimental System 123.16, Experimental Local-File 73.0, Experimental FILE-Server 22.0, Experimental Unix-Interface 11.0, Experimental Tape 18.0, Experimental KERMIT 34.0, Experimental ZMail 71.0, Experimental Lambda-Diag 15.0, microcode 1754, SDU Boot Tape 3.13, SDU ROM 102.


;; *** Note: ***
;;   You may lose because the buffer has no readtable attribute.
;; *************

; From modified file DJ: L.SYS2; NUMDEF.LISP#13 at 28-Sep-87 11:45:14
#10R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; NUMDEF  "

(defsubst %single-float-exponent (single-float)
  "Extracts the 11-bit exponent of single-floats as a fixnum, including the sign bit."
  (%p-ldb-offset (byte 11. 8.) single-float 0))

))

; From modified file DJ: L.SYS2; NUMER.LISP#82 at 28-Sep-87 11:46:02
#10R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; NUMER  "

(defun log-aux (n)
  (cond ((= n 0) (ferror 'sys:zero-log "Attempt to take logarithm of zero: ~S." n))
	((complexp n)
	 (%complex-cons (log-aux (abs n)) (phase n)))
        ((= n 1) 0.0)
        ((< n 0) (%complex-cons (log-aux (- n)) pi))
        (t
	 (let* ((f (let ((number-cons-area working-storage-area))
		     (float n 0f0)))
		(i (1- (float-exponent f))))   	;i gets the base 2 exponent
	   ;; f gets the mantissa (1.0 to 2.0) ie 2x(float-fraction f)
	   (setf (%single-float-exponent f) (1+ single-float-exponent-offset))
	   (setq f (// (- f 1.414213562374)
		       (+ f 1.414213562374)))
	   (setq f (+ .5
		      (* f (+ 2.885390073
			      (* (setq f (* f f))
				 (+ 0.9618007623
				    (* f (+ 0.5765843421
					    (* 0.4342597513 f)))))))))
	   (* 0.69314718056 (+ i f))))))

))

; From modified file DJ: L.SYS; QFASL.LISP#495 at 28-Sep-87 11:46:12
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; QFASL  "

(defun fasl-op-new-float ()
  (let ((sign (if fasl-group-flag -1 1))
	(exponent-length (fasl-next-nibble))
	(exponent 0)
	mantissa-length
	(mantissa 0)
	result)
    (cond ((< exponent-length 9.)		;small float
	   (setq exponent (fasl-next-nibble))
	   (setq mantissa-length (fasl-next-nibble))
	   (cond ((< mantissa-length 18.)
		  (do ((i 0 (1+ i))
		       (scale 1 (* scale (^ 2 16.))))
		      ((= i (ceiling mantissa-length 16.)))
		    (setq mantissa (+ mantissa (* scale (fasl-next-nibble)))))
		  (setq mantissa (logand mantissa (if (plusp sign)
						      ;; nuke leading 1
						      (1- (^ 2 17.))
						      ;; nuke sign bit and leading 1
						      (1- (^ 2 16.)))))
		  (setq result (%make-pointer dtp-small-flonum
					      (%logdpb exponent
						       (byte 8. 17.)
						       mantissa)))
		  ;;>> broken setf in 107
		  ;(setq result (%make-pointer dtp-small-flonum mantissa))
		  ;(setf (%short-float-exponent result) exponent))
		  )
		 (t (ferror "Fasl-op-new-float: Exponent length ~D, Mantissa length ~D"
			    exponent-length mantissa-length))))
	  ((< exponent-length 12.)		;single float
	   (setq exponent (fasl-next-nibble))
	   (if ( exponent (^ 2 11.))
	       (setq exponent (- (logand (1- (^ 2 12.)) (^ 2 12.)))))
	   (setq mantissa-length (fasl-next-nibble))
	   (cond ((< mantissa-length 32.)
		  (do ((i 0 (1+ i))
		       (scale 1 (* scale (^ 2 16.))))
		      ((= i (ceiling mantissa-length 16.)))
		    (setq mantissa (+ mantissa (* scale (fasl-next-nibble)))))
		  (let ((number-cons-area working-storage-area))
		    (setq result (%float-double 0 1)))
		  (setf (%single-float-mantissa result) (* sign mantissa)
			(%single-float-exponent result) exponent))
		 (t (ferror "Fasl-op-new-float: Exponent length ~D, Mantissa length ~D"
			    exponent-length mantissa-length))))
	  (t
	   (ferror "Fasl-op-new-float: Exponent length ~D" exponent-length)))
    (enter-fasl-table result)))

))