;;; -*- Mode: Common-Lisp; Package: User; Base: 10.; Patch-File: T -*- ;;; Reason: Change to sheet-line-out to check for reaching the right margin on a non-graphic char. ;;; This fixes the problem in ZMACS with extra tabs at end of the line causing a same-line ;;; line-wrap instead of a line-wrap to the next line. ;;; 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 TV version 6.21 ;;; Written 12/11/89 09:35:22 by MARKY, ;;; while running on LIBRA from band LODB ;;; With SYSTEM 6.26, VIRTUAL-MEMORY 6.3, EH 6.5, MAKE-SYSTEM 6.2, MICRONET 6.0, LOCAL-FILE 6.1, ;;; BASIC-PATHNAME 6.2, NETWORK-SUPPORT-COLD 6.2, BASIC-NAMESPACE 6.7, NETWORK-NAMESPACE 6.0, ;;; DISK-IO 6.2, DISK-LABEL 6.0, BASIC-FILE 6.6, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.0, ;;; COMPILER 6.14, TV 6.20, DATALINK 6.0, CHAOSNET 6.5, GC 6.3, MEMORY-AUX 6.0, NVRAM 6.2, ;;; SYSLOG 6.2, STREAMER-TAPE 6.5, UCL 6.0, INPUT-EDITOR 6.0, METER 6.1, ZWEI 6.8, ;;; DEBUG-TOOLS 6.3, NETWORK-SUPPORT 6.1, NETWORK-SERVICE 6.2, DATALINK-DISPLAYS 6.0, ;;; FONT-EDITOR 6.1, SERIAL 6.0, PRINTER 6.3, MAC-PRINTER-TYPES 6.1, PRINTER-TYPES 6.2, ;;; IMAGEN 6.1, SUGGESTIONS 6.1, MAIL-DAEMON 6.4, MAIL-READER 6.6, TELNET 6.0, VT100 6.0, ;;; NAMESPACE-EDITOR 6.4, PROFILE 6.2, VISIDOC 6.6, TI-CLOS 6.26, CLEH 6.5, IP 3.56, ;;; Experimental CLX 6.7, Inconsistent CLUE 6.36, X11M 6.18, Experimental BUG 11.17, ;;; MMON 6.2, Experimental SC 2.0, Experimental CONFORMANCE-CHECKER 2.0, Experimental CLIO 10.0, ;;; Experimental CLIO-DEMO 2.0, microcode 429, Band Name: REL6-mmon-11/15/89 ;;; SPR 10496 (by may for pf) ;;; Fix for bug that occurs while in "Uppercase Global Functions Mode" and a long line between the point and ;;; the line in the first pline of the window contains one or more #\tabs at the END of the line causing a ;;; "tab-induced line-over-wrap" - a line that wraps onto itself instead of the next line. The real problem is ;;; that extra tabs at the end of line did not cause a line-wrap to the next line - the tab chars wrapped to ;;; the SAME line. ;;; ;;; Reasoning: draw-string-internal returns an ambiguous second value, which ;;; indicates either that the right margin has been reached or that the next ;;; character is a non-graphic character. If the latter, there is no additional ;;; indication whether or not the right margin has been reached. The original code ;;; would proceed to sheet-tyo the non-graphic character, and in our problem case ;;; sheet-tyo would notice the line-wrap and print the character on the next line; ;;; unfortunately, sheet-line-out wouldn't know the line had wrapped and would ;;; therefore not do its usual line-wrap processing. ;;; ;;; This patch does sheet-compute-motion to find out whether the non-graphic ;;; character will cause a line-wrap, and does sheet-tyo only if it won't, doing ;;; the normal line-wrap exit if it will. There may be a better way to check the ;;; condition, but I didn't know one. The only flaw with this scheme is that Tabs ;;; that wrap will be moved whole onto the next line -- unlike gnuemacs, the eight ;;; spaces that the Tab occupies will not be split across the two lines. On the ;;; other hand, the mouse character-blinker would lose its mind if it were otherwise. ;;; #!C ; From file SHWARM.LISP#> WINDOW; Hotel: #10R TV#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "TV")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: WINDOW; SHWARM.#" (DEFUN sheet-line-out (sheet string &optional (start 0) (end nil) set-xpos set-ypos dwidth color) "New version of sheet line out which uses draw-string-internal. Returns the index of the next character to be printed and where the cursor got to. The first value may be incremented indicating that the line was completed." (declare (inline graphic-char-p)) (LET ((x (IF set-xpos (MIN (+ set-xpos (sheet-inside-left sheet)) (sheet-inside-right sheet)) (sheet-cursor-x sheet))) (y (IF set-ypos (MIN (+ set-ypos (sheet-inside-top sheet)) (sheet-inside-bottom sheet)) (sheet-cursor-y sheet))) (margin-flag (NOT (ZEROP (sheet-right-margin-character-flag sheet))))) (prepare-color (sheet color) (prepare-sheet (sheet) ;; Setting cursor position (SETF (sheet-cursor-x sheet) x) (IF (sheet-more-vpos sheet) (SETF (sheet-more-vpos sheet) (sheet-deduce-more-vpos sheet))) (SETF (sheet-cursor-y sheet) y) (WHEN set-ypos (SETF (sheet-exceptions sheet) 0) (WHEN (> (+ y (sheet-line-height sheet)) (sheet-inside-bottom sheet)) (SETF (sheet-end-page-flag sheet) 1))) (OR (ZEROP (sheet-exceptions sheet)) (sheet-handle-exceptions sheet)) ;; If we set the cursor then do a clear to end of line. (AND (OR set-xpos set-ypos) (%draw-rectangle (- (sheet-inside-right sheet) x) (sheet-line-height sheet) (sheet-cursor-x sheet) (sheet-cursor-y sheet) (sheet-erase-aluf sheet) sheet)) ;; If special case of italic line, move back and decrement ;; starting index. (WHEN (AND DWIDTH (NOT (ZEROP start))) (SETF (sheet-cursor-x sheet) (DECF x dwidth)) (DECF start)) ;; Drawing the string (LOOP with index = start with end = (OR end (LENGTH string)) with right-edge = (- (sheet-inside-right sheet) (IF margin-flag (sheet-char-width sheet) 0)) with font-map = (sheet-font-map sheet) with alu = (sheet-char-aluf sheet) until (>= index end) for current-font-number = (CHAR-FONT (AREF string index)) for current-font = (AREF font-map (IF (>= current-font-number (ARRAY-ACTIVE-LENGTH font-map)) 0 current-font-number)) for baseline-adjust = (- (sheet-baseline sheet) (font-baseline current-font)) for font-change-index = (LOOP for i from index below end when (neq (char-font (aref string i)) current-font-number) return i finally (return end)) do (MULTIPLE-VALUE-BIND (new-x new-end) (draw-string-internal sheet string index font-change-index x (+ y baseline-adjust) right-edge current-font alu) (IF new-end ;;Then all characters didn't get printed (IF (GRAPHIC-CHAR-P (AREF string new-end)) ;; Then last character must have overlapped XLIM, so print margin character and get out. (PROGN (WHEN margin-flag (SETF (sheet-cursor-x sheet) new-x) (SEND sheet :tyo-right-margin-character new-x y #\!)) (RETURN (IF (ZEROP (sheet-truncate-line-out-flag sheet)) new-end (1+ end)) (- (sheet-cursor-x sheet) (sheet-inside-left sheet)))) ;; Last character was non-graphic, let TYO handle it and go try to do the remainder of the string ;; may 12/11/89 START PATCH ... (multiple-value-bind (fx fy fsi mx) (sheet-compute-motion sheet new-x (sheet-cursor-y sheet) string new-end (1+ new-end)) (declare (ignore fy fsi)) (cond ((> mx fx) ; If max-x is greater than final-x, the next char will line-wrap. (WHEN margin-flag (SETF (sheet-cursor-x sheet) new-x) (SEND sheet :tyo-right-margin-character new-x y #\!)) (RETURN (IF (ZEROP (sheet-truncate-line-out-flag sheet)) new-end (1+ end)) (- (sheet-cursor-x sheet) (sheet-inside-left sheet)))) (:else ; No line-wrap, just a non-graphic character. ;; may 12/11/89 ... END PATCH (SETF (sheet-cursor-x sheet) new-x) (sheet-tyo sheet (AREF string new-end) current-font) (SETF index (1+ new-end)) (SETF x (sheet-cursor-x sheet) y (sheet-cursor-y sheet)))))) ;; Else they were all printed, go do rest of string (SETF index font-change-index) (SETF x new-x))) finally (SETF (sheet-cursor-x sheet) (- x (sheet-inside-left sheet))) (RETURN (1+ index) (- x (sheet-inside-left sheet)))))))) ))