;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 124.57
;;; Reason:
;;;  si:print-character and format's ~C control option blew up when given
;;;  character objects with weird mouse buttons.
;;; Written 14-Jun-88 12:41:34 by pld (Peter L. DeWolf) at site Gigamos Cambridge
;;; while running on Azathoth from band 1
;;; with Experimental System 124.56, Experimental Local-File 74.2, Experimental File-Server 23.1, Experimental Unix-Interface 12.0, Experimental ZMail 72.0, Experimental Tape 23.6, Experimental Lambda-Diag 16.1, microcode 1758, SDU Boot Tape 3.14, SDU ROM 8.



; From modified file DJ: L.IO; PRINT.LISP#221 at 14-Jun-88 12:56:22
#8R SYSTEM-INTERNALS#: #!:ZL
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; PRINT  "

(DEFUN PRINT-CHARACTER (CHAR STREAM &AUX (*PRINT-BASE* 10.) (*PRINT-RADIX* NIL) (*NOPOINT T))
  (IF (NOT *PRINT-ESCAPE*)
      (SEND STREAM :TYO (CHAR-INT CHAR))
    (SEND STREAM :STRING-OUT (CAR (PTTBL-CHARACTER *READTABLE*)))
    (IF (NOT (ZEROP (CHAR-FONT CHAR)))
	(PRIN1 (CHAR-FONT CHAR) STREAM))
    (SEND STREAM :STRING-OUT (CDR (PTTBL-CHARACTER *READTABLE*)))
    (LET ((BITS (CHAR-BITS CHAR))
	  (CODE (CHAR-CODE CHAR)))
      (SEND STREAM :STRING-OUT
	    (NTH BITS
		 '("" "c-" "m-" "c-m-"
		   "s-" "c-s-" "m-s-" "c-m-s-"
		   "h-" "c-h-" "m-h-" "c-m-h-"
		   "s-h-" "c-s-h-" "m-s-h-" "c-m-s-h-")))
      (COND ((TV:CHAR-MOUSE-P CHAR)
	     (SEND STREAM :STRING-OUT "Mouse-")
	     (let* ((bits (LDB %%KBD-MOUSE-BUTTON char))
		    (chname (nth bits '("Left-" "Middle-" "Right-"))))
	       (if chname
		   (SEND stream :STRING-OUT chname)
		 (progn
		   (send stream :string-out "Button:")
		   (prin1 bits stream)
		   (send stream :string-out "-"))))
	     (PRIN1 (1+ (LDB %%KBD-MOUSE-N-CLICKS CHAR)) STREAM))
	    (T
	     (LET ((CHNAME (FORMAT:OCHAR-GET-CHARACTER-NAME CODE)))
	       (IF CHNAME
		   (SEND STREAM :STRING-OUT CHNAME)
		 (AND ( BITS 0)
		      (CHARACTER-NEEDS-QUOTING-P CODE)
		      (SEND STREAM :TYO (PTTBL-SLASH *READTABLE*)))
		 (SEND STREAM :TYO CODE))))))))

))

; From modified file DJ: L.IO; FORMAT.LISP#273 at 14-Jun-88 12:56:28
#10R FORMAT#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FORMAT")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; FORMAT  "

(DEFUN FORMAT-CTL-CHARACTER (ARG IGNORE &AUX CHNAME BITS LOWER-CASE)
  (WHEN (EQ (CAR-SAFE ARG) ':MOUSE-BUTTON) (SETQ ARG (CADR ARG)))
  (SETQ ARG (CLI:CHARACTER ARG)
	BITS (CHAR-BITS ARG))
  (FLET ((PRINT-BITS (BITS)
		     (AND (BIT-TEST CHAR-HYPER-BIT BITS)
			  (SEND *STANDARD-OUTPUT* :STRING-OUT "Hyper-"))
		     (AND (BIT-TEST CHAR-SUPER-BIT BITS)
			  (SEND *STANDARD-OUTPUT* :STRING-OUT "Super-"))
		     (AND (BIT-TEST CHAR-CONTROL-BIT BITS)
			  (SEND *STANDARD-OUTPUT* :STRING-OUT "Control-"))
		     (AND (BIT-TEST CHAR-META-BIT BITS)
			  (SEND *STANDARD-OUTPUT* :STRING-OUT "Meta-"))))
    (COND ((TV:CHAR-MOUSE-P ARG)
	   (IF (AND (NOT *COLON-FLAG*) *ATSIGN-FLAG*)
	       (PRINC "#\\"))
	   (PRINT-BITS BITS)
	   (SETF (CHAR-BITS ARG) 0)
	   (IF (AND (NOT *COLON-FLAG*) *ATSIGN-FLAG*)
	       (IF (SETQ CHNAME (FORMAT-GET-CHARACTER-NAME ARG))
		   (PRINC CHNAME)
		 (FORMAT-ERROR "~O unknown mouse character given to ~~@C" ARG))
	     (progn
	       (SEND *STANDARD-OUTPUT* :STRING-OUT "Mouse-")
	       (if (setq chname (nth (setq bits (LDB %%KBD-MOUSE-BUTTON ARG))
				     '("Left" "Middle" "Right")))
		   (SEND *STANDARD-OUTPUT* :STRING-OUT chname)
		 (progn
		   (send *standard-output* :string-out "Button:")
		   (prin1 bits)))
	       (IF (SETQ CHNAME (nth (SETQ BITS (LDB %%KBD-MOUSE-N-CLICKS ARG))
				     '("" "-Twice" "-Thrice")))
		   (SEND *STANDARD-OUTPUT* :STRING-OUT CHNAME)
		 (progn
		   (SEND *STANDARD-OUTPUT* :TYO #\-)
		   (ENGLISH-PRINT (1+ BITS))
		   (SEND *STANDARD-OUTPUT* :STRING-OUT "-times"))))))
	  ((NOT *COLON-FLAG*)
	   ;; If @ flag or if control bits, we want to use characters' names.
	   (IF (OR *ATSIGN-FLAG* (NOT (ZEROP BITS)))
	       (SETQ CHNAME (FORMAT-GET-CHARACTER-NAME (CHAR-CODE ARG))))
	   ;; Print an appropriate reader macro if @C.
	   (IF *ATSIGN-FLAG* (PRINC "#\\"))
	   (UNLESS (ZEROP BITS)
	     (SEND *STANDARD-OUTPUT*
		   :STRING-OUT (AREF #(""     "c-"     "m-"     "c-m-"
				       "s-"   "c-s-"   "m-s-"   "c-m-s-"
				       "h-"   "c-h-"   "m-h-"   "c-m-h-"
				       "s-h-" "c-s-h-" "m-s-h-" "c-m-s-h-")
				     BITS))
	     (IF ( (CHAR-CODE #\a) (SETQ LOWER-CASE (CHAR-CODE ARG)) (CHAR-CODE #\z))
		 (SEND *STANDARD-OUTPUT* :STRING-OUT "sh-")
	       (SETQ LOWER-CASE NIL)))
	   (COND (CHNAME
		  (SETQ CHNAME (SYMBOL-NAME CHNAME))
		  ;; are we CONSING yet?
		  (SEND *STANDARD-OUTPUT* :TYO (CHAR-UPCASE (CHAR CHNAME 0)))
		  (DO ((LEN (LENGTH CHNAME))
		       (I 1 (1+ I)))
		      ((= I LEN))
		    (SEND *STANDARD-OUTPUT* :TYO (CHAR-DOWNCASE (CHAR CHNAME I)))))
		 (T (IF *ATSIGN-FLAG*
			(IF (SI::CHARACTER-NEEDS-QUOTING-P (CHAR-CODE ARG))
			    (SEND *STANDARD-OUTPUT* :TYO (SI::PTTBL-SLASH *READTABLE*)))
		      (IF LOWER-CASE (SETQ ARG (CHAR-UPCASE (INT-CHAR LOWER-CASE)))))
		    (SEND *STANDARD-OUTPUT* :TYO (CHAR-CODE ARG)))))
	  (T
	   (PRINT-BITS BITS)
	   (SETQ ARG (INT-CHAR (CHAR-CODE ARG)))
	   (COND ((SETQ CHNAME (FORMAT-GET-CHARACTER-NAME ARG))
		  (SETQ CHNAME (SYMBOL-NAME CHNAME))
		  (SEND *STANDARD-OUTPUT* :TYO (CHAR-UPCASE (CHAR CHNAME 0)))
		  (DO ((LEN (LENGTH CHNAME))
		       (I 1 (1+ I)))
		      ((= I LEN))
		    (SEND *STANDARD-OUTPUT* :TYO (CHAR-DOWNCASE (CHAR CHNAME I))))
		  (AND *ATSIGN-FLAG* (FORMAT-PRINT-TOP-CHARACTER ARG)))
                 ((AND *ATSIGN-FLAG* (CHAR< ARG #\SPACE) (CHAR ARG #\))
		  (SEND *STANDARD-OUTPUT* :TYO ARG)
		  (FORMAT-PRINT-TOP-CHARACTER ARG))
		 ((AND (LOWER-CASE-P ARG)
		       (NOT (ZEROP BITS)))
		  (SEND *STANDARD-OUTPUT* :STRING-OUT "Shift-")
		  (SEND *STANDARD-OUTPUT* :TYO (CHAR-UPCASE ARG)))
                 (T (SEND *STANDARD-OUTPUT* :TYO ARG)))))))

))