;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 126.130
;;; Reason:
;;;  Misc. BYTE spec fixups.  
;;;  
;;;  Also fixup symbol lossage - somewhen (at least before sys 126.99)
;;;  SI:%AREA-TYPE got "un-IMPORTed" from the GC package...???
;;; Written 23-Oct-88 20:01:26 by keith (Keith Corbett) at site Gigamos Cambridge
;;; while running on Johannes Brahms from band 1
;;; with Experimental System 126.123, Experimental ZWEI 126.21, Experimental ZMail 74.9, Experimental Local-File 76.0, Experimental File-Server 25.0, Experimental Lambda-Diag 18.0, Experimental Unix-Interface 15.0, Experimental Tape 26.4, Microcode 1762, SDU Boot Tape 3.14, SDU ROM 103, 10/17.



; From file DJ: L.SYS2; RAT.LISP#56 at 23-Oct-88 20:01:37
#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 (BYTE 3. 6.) 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 (BYTE 3. 6.) 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)))))

))

; From modified file DJ: L.IO; READ.LISP#470 at 23-Oct-88 20:01:44
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; READ  "

(DEFUN XR-PARSE-KEYBOARD-CHAR (SYM)
  (WHEN (OR (SYMBOLP SYM) (STRINGP SYM))
    (LET ((STRING (IF (STRINGP SYM) SYM (GET-PNAME SYM)))
	  TOP-FLAG GREEK-FLAG SHIFT-FLAG)
      (LOOP WITH CHAR = 0
	    WITH END = (ARRAY-ACTIVE-LENGTH STRING)
	    WITH TEM = NIL
	    FOR START FIRST 0 THEN (1+ HYPHEN-POS)
	    FOR 1+PREV-HYPHEN-POS = 0 THEN (1+ HYPHEN-POS)
	    FOR HYPHEN-POS = (OR (STRING-SEARCH-CHAR #/- STRING START END) END)
	    DO (LET ((LEN (- HYPHEN-POS 1+PREV-HYPHEN-POS)))
		 (COND ((OR (XR-STR-CMP "CTRL")
			    (XR-STR-CMP "CONTROL"))
			(SETQ CHAR (DPB 1 %%KBD-CONTROL CHAR)))
		       ((XR-STR-CMP "META")
			(SETQ CHAR (DPB 1 %%KBD-META CHAR)))
		       ((XR-STR-CMP "HYPER")
			(SETQ CHAR (%LOGDPB 1 %%KBD-HYPER CHAR)))
		       ((XR-STR-CMP "SUPER")
			(SETQ CHAR (DPB 1 %%KBD-SUPER CHAR)))
		       ((XR-STR-CMP "GREEK")
			(SETQ GREEK-FLAG T))
		       ((XR-STR-CMP "FRONT")
			(SETQ GREEK-FLAG T))
		       ((XR-STR-CMP "TOP")
			(SETQ TOP-FLAG T))
		       ((OR (XR-STR-CMP "SHIFT")
			    (XR-STR-CMP "SH"))
			(SETQ SHIFT-FLAG T))
		       ((= 1+PREV-HYPHEN-POS (1- END))
			(RETURN (GREEKIFY-CHARACTER (AREF STRING 1+PREV-HYPHEN-POS)
						    GREEK-FLAG TOP-FLAG SHIFT-FLAG
						    CHAR)))
		       ((= 1+PREV-HYPHEN-POS (1- HYPHEN-POS))
			(LET ((bucky (cdr (ASSQ (CHAR-UPCASE (CHAR-CODE (AREF STRING
								       1+PREV-HYPHEN-POS)))
					 `((#/C . ,%%KBD-CONTROL)
					   (#/M . ,%%KBD-META)
					   (#/H . ,%%KBD-HYPER)
					   (#/S . ,%%KBD-SUPER))))))
			  (IF (null bucky)
			      (RETURN NIL)
			    (SETQ CHAR (%LOGDPB 1 bucky CHAR)))))
		       ;; See if we have a name of a special character "Return", "SP" etc.
		       ((SETQ TEM
			      (DOLIST (ELEM XR-SPECIAL-CHARACTER-NAMES)
				(LET ((TARGET (GET-PNAME (CAR ELEM))))
				  (IF (STRING-EQUAL TARGET STRING :START2 1+PREV-HYPHEN-POS)
				      (RETURN (CDR ELEM))))))
			;; Note: combine with LOGIOR rather than DPB, since mouse
			;; characters have the high %%KBD-MOUSE bit on.
			(RETURN (GREEKIFY-CHARACTER TEM GREEK-FLAG
						    TOP-FLAG SHIFT-FLAG
						    CHAR)))
		       (T (RETURN NIL))))))))

))

; From modified file DJ: L.SYS2; GC.LISP#358 at 23-Oct-88 20:46:31
#10R GARBAGE-COLLECTOR#: #!:CL
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "GARBAGE-COLLECTOR")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; GC  "

(shadowing-import '(si::%region-list-thread
		    si::%area-region-list
		    si::%area-type
		    si::with-quick-region-area-accessors
		    si::for-every-region-in-area))

))