#| -*- Mode:LISP; Package:SI; Base:10; FONTS: (CPTFONTB) -*-

CODE TO IMPLEMENT THE CREATION OF PATCH TAPES FOR CUSTOMER SUPPORT.

THIS WAS NEEDED TO GET SYSTEM PATCHES FOR THE FIRST LISP TCP-IP RELEASE.
5/20/85 10:22:20 -GEORGE CARRETTE.
MODIFIED TO KEEP TRACK OF MICROCODE VERSIONS 6/11/85 09:47:14 -GJC.
TO DO: MAKE SHORT-FORM COMMANDS FOR COMMULATIVE INCREMENTAL UPDATES.

The Database for release 2p0 is on the release control machine BORIS:
so that a call to use this utility would be

 (PATCHUP-UTILITY "BORIS:RELEASE-LOG;UTILITY")

SHORT FORM USAGE:
 (PATCHUP-UTILITY) ... PROMPTS FOR INFORMATION.

LONG USAGE:
 When you do a major release also do
  (DUMP-LOADED-PATCH-STATUS "RELEASE-LOG;RELEASE-2P0-PATCH-STATUS")

 Then, when you want to have some patches send out, load-patches
 into your machine, and say
 
  (DUMP-PATCH-UPDATE-INFO "RELEASE-LOG;RELEASE-2P0-PATCH-STATUS"
                          "RELEASE-LOG;RELEASE-2P0-PATCH-UPDATE-1")

  Which will create:
     RELEASE-2P0-PATCH-UPDATE-1.LISP, a list of files,
     RELEASE-2P0-PATCH-UPDATE-1.TEXT, a report of what was changed.

 (MAKE-PATCH-UPDATE-TAPE "RELEASE-LOG;RELEASE-2P0-PATCH-UPDATE-1") will make
 a tape.

Then do
 (DUMP-LOADED-PATCH-STATUS "RELEASE-LOG;RELEASE-2P0-PATCH-STATUS-1")

 (MAKE-PATCH-UPDATE-REPORT "RELEASE-LOG;RELEASE-2P0-PATCH-STATUS"
                           "RELEASE-LOG;RELEASE-2P0-PATCH-STATUS-1"
                           "RELEASE-LOG;RELEASE-2P0-PATCH-UPDATE-1")

Which will make a line-printer style REPORT in
          "RELEASE-LOG;RELEASE-2P0-PATCH-UPDATE-1.REPORT"

|#

(DEFVAR *PATCHUP-UTILITY-DIR* NIL)
(DEFVAR *LOG-FILE-PREPEND* NIL)
(DEFVAR *SYSTEMS-TO-CONSIDER* T)
(DEFVAR *SPECIAL-SYSTEMS-LIST* NIL)
(DEFVAR *FILE-TYPES-REPORT-SPECIAL* NIL)

(DEFUN PATCHUP-UTILITY (&OPTIONAL DBASE)
  (IF DBASE (LOAD DBASE :SET-DEFAULT-PATHNAME NIL))
  (COND ((NOT (y-or-n-p "~&Load Patches?")))
	((LISTP *SYSTEMS-TO-CONSIDER*)
	 (LOAD-PATCHES :SYSTEMS
		       (subset #'(lambda (x)
				   (not (AND (KEYWORDP x)
					     (GET x 'GET-SPECIAL-SYSTEM-VERSION))))
			       *SYSTEMS-TO-CONSIDER*)
		       :NOSELECTIVE))
	('ELSE
	 (load-patches :noselective)))
  (cond ((OR (NULL *PATCHUP-UTILITY-DIR*)
	     (NULL *LOG-FILE-PREPEND*)
	     (Y-OR-N-P "~&Do you want to change the release log directory?"))
	 (SETUP-UTILITY-VARS))
	('else
	 (list-utility-directory)))
  (LET ((UVN (OR (PROMPT-AND-READ
		   :STRING-OR-NIL
		   "~&what update number (default TEST): ")
		 "TEST")))
    (let ((previous-status-file (make-utility-filename "STATUS"))
	  (update-file (make-utility-filename (string-append "UPDATE-" UVN)))
	  (status-file (make-utility-filename (string-append "STATUS-" UVN))))
      (format t "~&Update info from ~S to ~S" previous-status-file
	      update-file)
      (dump-patch-update-info previous-status-file update-file)
      (format t "~&Status file ~S" status-file)
      (dump-loaded-patch-status status-file)
      (format t "~&Making report")
      (make-patch-update-report previous-status-file
				status-file
				update-file)
      (if (y-or-n-p "~&make the tape?")
	  (make-patch-update-tape update-file)))))

(DEFUN SETUP-UTILITY-VARS ()
  (DO ((F))
      (NIL)
    (SETQ *PATCHUP-UTILITY-DIR* (PROMPT-AND-READ :PATHNAME
						 "~&Directory with patch logs> "))
    (SETQ *LOG-FILE-PREPEND* (PROMPT-AND-READ :STRING
					      "~&filenames start with: "))
    (SETQ F (LIST-UTILITY-DIRECTORY))
    (IF (Y-OR-N-P "Is ~A correct?" (SEND F :STRING-FOR-PRINTING)) (RETURN))))

(defun make-utility-filename (name &optional type)
  (send *PATCHUP-UTILITY-DIR* :new-pathname
	:name (string-append *LOG-FILE-PREPEND*
			     "-" name)
	:type type
	:version :newest))

(DEFUN LIST-UTILITY-DIRECTORY (&AUX F)
  (SETQ F (SEND *PATCHUP-UTILITY-DIR*
		:NEW-PATHNAME :NAME (STRING-APPEND *LOG-FILE-PREPEND*
						   "*")
		:TYPE :WILD
		:VERSION :NEWEST))
  (LISTF F)
  F)


(DEFUN GET-LOADED-PATCH-STATUS ()
  (DELQ NIL
	(MAPCAR #'(LAMBDA (SYSTEM)
		    (MULTIPLE-VALUE-BIND (MAJOR MINOR STATUS)
			(COND ((AND (KEYWORDP SYSTEM)
				    (GET SYSTEM 'GET-SPECIAL-SYSTEM-VERSION))
			       (FUNCALL (GET SYSTEM 'GET-SPECIAL-SYSTEM-VERSION)))
			      ('ELSE
			       (SI:GET-SYSTEM-VERSION SYSTEM)))
		      (AND MAJOR MINOR STATUS
			   (LIST (IF (KEYWORDP SYSTEM) SYSTEM (SI:SYSTEM-NAME SYSTEM))
				 MAJOR MINOR STATUS))))
		(APPEND (LOADED-SPECIAL-SYSTEMS)
			(LOADED-PATCHABLE-SYSTEMS)))))


(DEFUN DUMP-LOADED-PATCH-STATUS (&OPTIONAL (FILENAME (MAKE-UTILITY-FILENAME "STATUS" :LISP)))
  (WITH-OPEN-FILE (STREAM FILENAME :OUT)
    (LET ((BASE 10)
	  (PACKAGE (FIND-PACKAGE "USER")))
      (FORMAT STREAM ";;-*-MODE:LISP;PACKAGE:USER;BASE:10;READTABLE:ZL-*-~%")
      (FORMAT STREAM ";; Loaded patch status for ~A dumped by ~A~%"
	      (send si:local-host :name)
	      si:user-id)
      (format stream ";; on ~A~%" (time:print-current-date nil))
      (format stream "(SET 'SI:*SAVED-LOADED-PATCH-STATUS* '(~%")
      (dolist (x (get-loaded-patch-status))
	(format stream " ~S~%" x))
      (format stream " ))~%"))))


(DEFUN LOADED-PATCHABLE-SYSTEMS ()
  (SUBSET #'(LAMBDA (SYSTEM)
	      (AND (TYPEP SYSTEM 'SYSTEM) 
		   (SYSTEM-PATCHABLE-P SYSTEM)
		   (OR (EQ *SYSTEMS-TO-CONSIDER* T)
		       (MEM #'(LAMBDA (ITEM ELEMENT)
				(and (not (AND (KEYWORDP element)
					       (GET element
						    'GET-SPECIAL-SYSTEM-VERSION)))
				     (EQ ITEM (SI:FIND-SYSTEM-NAMED ELEMENT NIL T))))
			    SYSTEM *SYSTEMS-TO-CONSIDER*))))
	  *SYSTEMS-LIST*))

(DEFUN LOADED-SPECIAL-SYSTEMS ()
  (SUBSET #'(LAMBDA (SYSTEM)
	      (AND (KEYWORDP SYSTEM)
		   (OR (EQ *SYSTEMS-TO-CONSIDER* T)
		       (MEMQ SYSTEM *SYSTEMS-TO-CONSIDER*))))
	  *SPECIAL-SYSTEMS-LIST*))

(DEFVAR *SAVED-LOADED-PATCH-STATUS* NIL)

(DEFUN LOAD-SAVED-STATUS (FILENAME)
  (LET (*SAVED-LOADED-PATCH-STATUS*)
    (LOAD FILENAME)
    *SAVED-LOADED-PATCH-STATUS*))

(DEFUN PATCH-FILES-NEEDED (saved-status)
  (let ((sys-minor-alist (incremental-need-check-consistency
			   saved-status
			   (get-loaded-patch-status))))
    (MAPCAN #'PATCH-FILES-NEEDED-FOR SYS-MINOR-ALIST)))


(DEFUN PATCH-FILES-NEEDED-FOR (SYSTEM-DESC)
  (LET ((SYSTEM (CAR SYSTEM-DESC))
	(MAJOR (CADR SYSTEM-DESC))
	(AFTER (CADDR SYSTEM-DESC)))
    (COND ((AND (KEYWORDP SYSTEM) (GET SYSTEM 'HANDLE-SPECIAL-PATCH-FILES-NEEDED))
	   (FUNCALL (GET SYSTEM 'HANDLE-SPECIAL-PATCH-FILES-NEEDED)
		    MAJOR
		    AFTER))
	  ('ELSE
	   (LET* ((PATCH-SYSTEM (GET-PATCH-SYSTEM-NAMED SYSTEM T T))
		  (VERSION (PATCH-VERSION PATCH-SYSTEM))
		  (LATEST (VERSION-NUMBER (CAR (PATCH-VERSION-LIST PATCH-SYSTEM)))))
	     (COND ((NULL PATCH-SYSTEM)
		    (FORMAT T "~&No ~A system loaded~%" SYSTEM))
		   ((NOT (EQUAL MAJOR VERSION))
		    (FORMAT
		      T
		      "~&Inconsistent usage, ~A system version is ~D should be ~D~%"
		      SYSTEM VERSION MAJOR))
		   ((> AFTER LATEST)
		    (FORMAT
		      T
		      "~&Inconsistent usage, ~A system patches not all loaded.~%"
		      SYSTEM))
		   ('ELSE
		    (LET (LIST)
		      (PUSH (PATCH-SYSTEM-PATHNAME SYSTEM :VERSION-DIRECTORY MAJOR)
			    LIST)
		      (DOLIST (V (REVERSE (PATCH-VERSION-LIST PATCH-SYSTEM)))
			(WHEN ( AFTER (VERSION-NUMBER V))
			  (LET ((P (PATCH-SYSTEM-PATHNAME SYSTEM :PATCH-FILE
							  MAJOR (VERSION-NUMBER V))))
			    (PUSH (SEND P :NEW-TYPE :LISP) LIST)
			    (PUSH (SEND P :NEW-TYPE :QFASL) LIST))))
		      (NREVERSE LIST)))))))))


(PUSHNEW :%MICROCODE-VERSION-NUMBER *SPECIAL-SYSTEMS-LIST*)
(PUSHNEW :LMC *FILE-TYPES-REPORT-SPECIAL*)
(PUSHNEW :LMC-SYM *FILE-TYPES-REPORT-SPECIAL*)
(PUSHNEW :LMC-TBL *FILE-TYPES-REPORT-SPECIAL*)
(PUSHNEW :LMC-LOCS *FILE-TYPES-REPORT-SPECIAL*)

(DEFUN (:%MICROCODE-VERSION-NUMBER GET-SPECIAL-SYSTEM-VERSION) ()
  (VALUES 1
	  %MICROCODE-VERSION-NUMBER
	  :RELEASED))


(defun probe-file! (x)
  (cond ((probe-file x))
	('else
	 (cerror "try again"
		 "File expected but not found: ~S" x)
	 (probe-file! x))))

(DEFUN (:%MICROCODE-VERSION-NUMBER HANDLE-SPECIAL-PATCH-FILES-NEEDED) (MAJOR AFTER)
  MAJOR
  (COND ((GREATERP %MICROCODE-VERSION-NUMBER AFTER)
	 (DO ((J AFTER (1+ J))
	      (L NIL (CONS (PROBE-FILE! (FS:MAKE-PATHNAME
					 :HOST "SYS"
					 :DIRECTORY "UBIN"
					 :device :unspecific
					 :NAME "ULAMBDA"
					 :TYPE "LMC-LOCS"
					 :VERSION J))
			   L)))
	     ((> J %MICROCODE-VERSION-NUMBER)
	      (NRECONC L
		       (MAPCAR #'(LAMBDA (TYPE)
				   (PROBE-FILE! (FS:MAKE-PATHNAME
						 :HOST "SYS"
						 :DIRECTORY "UBIN"
						 :device :unspecific
						 :NAME "ULAMBDA"
						 :TYPE TYPE
						 :VERSION %MICROCODE-VERSION-NUMBER)))
			       '("LMC" "LMC-SYM" "LMC-TBL"))))))))

(DEFUN (:LMC-LOCS FILE-TYPE-REPORT-SPECIAL) (FILENAME STREAM)
  (FORMAT STREAM "~&The file ~A describes a change to the hardware microcode:~%"
	  filename)
  (with-open-file (si filename)
    (DO ((LINE))
	((NULL (SETQ LINE (READLINE SI NIL))))
      (AND (STRING-EQUAL LINE "Locations used:") (RETURN NIL))
      (SEND STREAM :LINE-OUT LINE))))

(defun incremental-need-check-consistency (from to)
  "Return an alist of (SYSTEM MAJOR MINOR-NEEDED-FROM) for those systems which
have new patches to go from FROM to TO. Prints warning messages about
new systems and missing systems"
  (LET ((ALIST))
    (DOLIST (OLD FROM)
      (LET ((NEW (ASS #'STRING-EQUAL (CAR OLD) TO)))
	(COND ((NOT NEW)
	       (FORMAT T "~&Warning, system ~A no longer exists~%" (CAR OLD)))
	      ((NOT (EQUAL (CADR OLD) (CADR NEW)))
	       (FORMAT T "~&Warning, system ~A changed MAJOR version from ~D to ~D~%"
		       (CADR OLD) (CADR NEW)))
	      ((GREATERP (CADDR NEW) (CADDR OLD))
	       (PUSH (LIST (CAR NEW) (CADR NEW) (1+ (CADDR OLD))) ALIST)))))
    (DOLIST (NEW TO)
      (WHEN (NOT (ASS #'STRING-EQUAL (CAR NEW) FROM))
	(FORMAT T "~&Warning, system ~A is newly loaded~%" (CAR NEW))))
    ALIST))


(defvar *files-modified* nil)
(defvar *definitions-modified* nil)

(DEFUN DUMP-PATCH-UPDATE-INFO (PREVIOUS-STATUS-FILE TO-INFO-FILE)
  "Reads the previous-status-file, then creates TO-INFO-FILE.LISP,
and TO-INFO-FILE.TEXT."
  (LET* ((REPORT-FILE (SEND (FS:PARSE-PATHNAME TO-INFO-FILE) :NEW-TYPE :TEXT))
	 (INFO-FILE (SEND REPORT-FILE :NEW-TYPE :LISP)))
    (LET ((FILES (PATCH-FILES-NEEDED (LOAD-SAVED-STATUS PREVIOUS-STATUS-FILE))))
      (WITH-OPEN-FILE (REPORT-STREAM REPORT-FILE :OUT)
	(WITH-OPEN-FILE (INFO-STREAM INFO-FILE :OUT)
	  (LET ((BASE 10)
		(PACKAGE (FIND-PACKAGE "USER")))
	    (FORMAT INFO-STREAM ";;-*-MODE:LISP;PACKAGE:USER;BASE:10;READTABLE:ZL-*-~%")
	    (FORMAT INFO-STREAM ";; patch update file list dumped by ~A from ~A~%"
		    si:user-id
		    (send si:local-host :name))
	    (format info-stream ";; on ~A~%" (time:print-current-date nil))
	    (format info-stream "(SET 'SI:*SAVED-PATCH-UPDATE-FILES* '(~%")
	    (format report-stream "Report of patches to update from ~A~%"
		    previous-status-file)
	    (format report-stream "Created by ~A from ~A~%on ~A~2%"
		    si:user-id
		    (send si:local-host :name)
		    (time:print-current-date nil))
	    (let  ((*files-modified* nil)
		   (*definitions-modified* nil))
	      (DOLIST (FILE FILES)
		(FORMAT INFO-STREAM " ~S~%" (REPORT-ON-PATCH-FILE FILE REPORT-STREAM)))
	      (format report-stream
		      "~3%A list of all files modified:~%~{ ~A~%~}~%"
		      *files-modified*)
	      (format report-stream
		      "~3%A list of all definitions modified:~%~{ ~A~%~}~%"
		      *definitions-modified*))
	    (FORMAT INFO-STREAM " ))~%")))))))

(eval-when (eval compile)
  (when (and (< (si:get-system-version :system) 110)
	     (not (fboundp 'string-matchp)))
    (defun string-matchp (string1 string2)
      "Like STRING-EQUAL but STRING1 can have wildchar indicators:
       `%' = match one character, `*' = match any number of characters from STRING2"
      ;; 17-Mar-86 17:16:08 -gjc
      (IF (or (string-search #\* string1)
	      (string-search #\% string1))
	  (string-matchp-1 string1 0 (string-length string1)
			   string2 0 (string-length string2))
	(string-equal string1 string2)))

    (defun string-matchp-1 (string1 i1 n1 string2 i2 n2)
      (prog (temp)
	 loop
	    (if (and (= i1 n1) (= i2 n2)) (return t))
	    (if (= i1 n1) (return nil))
	    (if (= i2 n2) (go check-star))
	    (when (or (char-equal (setq temp (aref string1 i1)) #\%)
		      (char-equal temp (aref string2 i2)))
	      (setq i1 (1+ i1) i2 (1+ i2))
	      (go loop))
	 check-star
	    (if (char-equal (aref string1 i1) #\*)
		(cond ((= (1+ i1) n1) (return t))
		      ((= i2 n2) (return nil))
		      ((string-matchp-1 string1 (1+ i1) n1 string2 (1+ i2) n2)
		       (return t))
		      ((string-matchp-1 string1 i1 n1 string2 (1+ i2) n2)
		       (return t))
		      ('else
		       (setq i1 (1+ i1))
		       (go loop)))
	      (return nil))))))

(DEFUN REPORT-ON-PATCH-FILE (FILENAME &OPTIONAL (STREAM STANDARD-OUTPUT) &AUX TEMP)
  (cond ((EQ :QFASL (SEND (FS:PARSE-PATHNAME FILENAME) :CANONICAL-TYPE))
	 (LET ((TN (PROBE-FILE! FILENAME)))
	   (FORMAT STREAM "~&Object file for patches is ~S~%" TN)
	   TN))
	((SETQ TEMP (MEM #'STRING-EQUAL
			 (send (fs:parse-pathname filename) :canonical-type)
			 *FILE-TYPES-REPORT-SPECIAL*))
	 (IF (SETQ TEMP (GET (CAR TEMP) 'FILE-TYPE-REPORT-SPECIAL))
	     (FUNCALL TEMP FILENAME STREAM))
	 (PROBE-FILE! FILENAME))
	('ELSE
	 (with-open-file (R filename)
	   (LET ((TN (SEND R :TRUENAME)))
	     (COND ((EQ :LISP (SEND TN :CANONICAL-TYPE))
		    (FORMAT STREAM "~&~%Report on source containing patches: ~S~%"
			    TN))
		   ('ELSE
		    (FORMAT STREAM "~&~%Report on directory of patches: ~S~%"
			    TN)))
	     (condition-case ()
		 (do ((string (make-string 1000 :fill-pointer 0))
		      (n)
		      (beginingp t))
		     ((null (setq n (send r :string-line-in t string))))
		   (setf (fill-pointer string) n)
		   (cond ((or (string-matchp "; From *file*" string)
			      (string-matchp "(def*" string))
			  (send stream :line-out string 0 n)
			  (cond ((string-matchp "; From *file*" string)
				 (let ((s (substring string
						     (+ (length "FILE")
							(string-search "FILE" string))
						     n)))
				   (or (mem #'string-equal s *files-modified*)
				       (push s *files-modified*))))
				('else
				 (push (substring string 1 n)
				       *definitions-modified*)))
			  (setq beginingp nil))
			 ((and (string-matchp ";*" string) beginingp)
			  (send stream :line-out string 0 n))
			 ('else
			  (setq beginingp nil))))
	       (sys:end-of-file
		tn)))))))

(defvar *SAVED-PATCH-UPDATE-FILES* nil)

(DEFUN MAKE-PATCH-UPDATE-TAPE (INFO-FILENAME)
  (let ((*SAVED-PATCH-UPDATE-FILES*))
    (load INFO-FILENAME)
    (format t "~&Rewinding Tape~%")
    (fs:mt-rewind)
    (format t "~&Writing ~D files." (length *SAVED-PATCH-UPDATE-FILES*))
    (dolist (file *SAVED-PATCH-UPDATE-FILES*)
      (copy-file-to-tape file))
    (format t "~&Writing EOF marker~%")
    (fs:mt-write-eof)
    (format t "~&Rewinding Tape~%")
    (fs:mt-rewind)
    (format t "~&Done~%")))

(defun copy-file-to-tape (x)
  (dolist (f (cdr (fs:directory-list x)))
    (fs:fs-copy-file (car f) "mt:" :directory-list (cdr f))))

(defvar *patch-report-from* "GEORGE CARRETTE")
(defvar *patch-report-to* "GEORGE COLPITTS")
(defvar *patch-report-about* "Release 2.0 Lisp Software Update Tape")

(DEFUN MAKE-PATCH-UPDATE-REPORT (BEFORE-STATUS AFTER-STATUS UPDATE-FILE)
  "Makes a printable written report of the patch activities"
  (setq update-file (FS:PARSE-PATHNAME UPDATE-FILE))
  (WITH-OPEN-FILE (STREAM (SEND update-file :NEW-TYPE "REPORT")
			  :OUT)
    (LET ((LPR (MAKE-LPR-STREAM STREAM)))
      (FORMAT LPR "~2%TO:   ~A~
                 ~%FROM: ~A~
                 ~%RE:   ~A~
                 ~%DATE: ~A~%"
	      *patch-report-to*
	      *patch-report-from*
	      *patch-report-about*
	      (time:print-current-date nil))
      (format lpr "This tape updates lisp software from the following versions:~%")
      (insert-file-into-report lpr before-status)
      (format lpr "~%to the following versions:~%")
      (insert-file-into-report lpr after-status)
      (format lpr "~%The tape contains the following files:~%")
      (insert-file-into-report lpr (send update-file :new-type :LISP))
      (format lpr "~%The following is a detailed report each patch file,~
                   ~%with a note of every FILE, FUNCTION, or VARIABLE modified:~%")
      (insert-file-into-report lpr (send update-file :new-type :text)))
    (send stream :truename)))

(defun insert-file-into-report (stream filename)
  (with-open-file (x filename)
    (stream-copy-until-eof x stream)))

(DEFUN MAKE-LPR-STREAM (OUTPUT &OPTIONAL &KEY (MARGIN 10) (WIDTH 69) (LENGTH 50)
			&AUX STREAM (LINE-COUNT 0) (CHAR-COUNT 0) (PAGE-COUNT 1))
  "Make a stream for creating files suitable for simple line-printers"
  (SETQ STREAM #'(LAMBDA (OP &OPTIONAL ARG1 &REST ARGS)
		   (SI:SELECTQ-WITH-WHICH-OPERATIONS OP
		     (:TYO
		       (COND ((< ARG1 #o40))
			     ((= ARG1 #\RETURN)
			      (COND ((= LINE-COUNT LENGTH)
				     (SEND OUTPUT :TYO #\FORM)
				     (INCF PAGE-COUNT)
				     (SETQ LINE-COUNT 0)
				     (SETQ CHAR-COUNT 0)
				     (DOTIMES (J (FLOOR WIDTH 2))
				       (SEND OUTPUT :TYO #\SPACE))
				     (FORMAT STREAM "Page ~D~%~%" page-count))
				    ('ELSE
				     (INCF LINE-COUNT)
				     (SETQ CHAR-COUNT 0)
				     (SEND OUTPUT :TYO #\RETURN)
				     (DOTIMES (J MARGIN)
				       (SEND OUTPUT :TYO #\SPACE)))))
			     ((GRAPHIC-CHAR-P ARG1)
			      (COND ((= CHAR-COUNT WIDTH)
				     (SEND STREAM :TYO #\RETURN)
				     (SEND STREAM :TYO ARG1))
				    ('ELSE
				     (INCF CHAR-COUNT)
				     (SEND OUTPUT :TYO ARG1))))))
		     (T
		       (STREAM-DEFAULT-HANDLER STREAM OP ARG1 ARGS))))))