;;; -*- mode:lisp; package:user; base:10.;; Fonts: CPTFONTB -*- ;;; $Header: /ct/debug/scroll.l,v 1.86 84/09/18 14:11:55 bill Exp $ (putprop 'scroll "$Revision: 1.86 $" 'rcs_revision) ;;; This file implements scrolling windows to run with the ;;; CURSES system on character oriented terminals. ;;; A scrolling window allows the display of a string or a file ;;; of potentially very large size. A certain portion of the file ;;; may be visible at any time. The rest of the file may be displayed ;;; by scrolling backwards or forwards, or going to the beginning ;;; or end of the file. ;;; This code should run compatibly on both lispmachine and vax (under ;;; franz). NIL would be a better choice, but it is not available. Foo. ;;; WE HAVE COMBINED DBWINDOW AND SCROLL INTO THIS ONE FILE. ;;; &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& ;;; &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& ;;; ;;; As of 28-Jan-84, this code is being revised to run specifically ;;; on the Symbolics Lisp Machine. All usage of Curses will be ;;; removed; instead, this software will deal directly with the ;;; standard LM window system. ;;; ;;; &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& ;;; &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& ;;; &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& ;;; &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& ;;; ;;; Major changes started on 23-Mar-84 to improve the restrict-range ;;; feature. Before changes, file was re-read to change the range ;;; restrictions. With changes, restrictions are internal, and files ;;; do not need to be re-read. ;;; ;;; &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& ;;; &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& #| Debug Windows are special objects that manipulate raw curses windows. They also manipulate a special object called a scroll window. The scroll window is responsible for maintaining and displaying on the curses window a complete document. Debug windows must look like streams to much of the rest of the interpreter/debugger/world, so here we implement methods ct_format, ct_print, etc. that translate into messages that scroll windows can understand. Mostly, scroll windows understand ':add-many-lines, ':add-line, and ':add-string messages. Input is another matter. |# ;;; **************************************************************** ;;; Any SETUP information ;;; **************************************************************** ;;; Make macros work better in Franz Lisp. #+franz (declare (macros t)) (eval-when (compile load eval) (ct_load 'compat)) (eval-when (compile load eval) (ct_load 'aip)) (eval-when (compile load eval) (ct_load 'ctflav)) ;;;#+franz(cfasl "!/ct!/ctlisp!/fgetswon.o" '_fgetswon 'fgetswon "function") #+franz(eval-when (compile load eval) (ct_load 'readline)) (ct_load 'ctio) (eval-when (compile load eval) (ct_load 'ctstrl)) (defconst *terminal-width* 80.) (defconst *truncating-char* #/&) ;used to indicate truncated line. (defconst *return* '(#\linefeed #\return)) (defconst *display-inhibited* nil "You can bind this to T to inhibit redisplay. Use the macro with-output-buffered to do this in a nice fashion.") ;;; The number of the first character in a file. Usually, either ;;; 0. or 1., depending on how you count. (defconst *first-char-number* 0.) ;;; This controls the number of blank lines to put at the bottom when we show the ;;; last page. (defconst *bottom-space* 1.) ;;; This determines the number of overlapping lines when we page through the buffer (defconst *overlap-lines* 1) ;;; Maximum number of lines you can have when adding new lines. ;;; 1 million lines on Lisp Machine seems plenty (defconst *max-lines* #+franz 100. #+lispm 1000000.) ;;; When removing excess lines, this is how many to take away. (defconst *remove-chunk* 10.) ;;; The global variable used for editing single character type-in. ;;; I think this is now obsolete. (defvar *winio-editing-string* "") ;;; The global variable used for typein buffering. Doing a CT_TYI will ;;; look here for input, and if there is none, will use a CT_READLINE to ;;; refill this buffer. (defvar *ct_tyi_buffer* "") #+franz (declare (special control_g)) ; wab ;;; WARNING!! cCan't make a combined method localf, since it is not expr-like. #+franz (declare (localf ;;;db%debug_window-combined-:translate-method db%debug_window-primary-:translate-method tab-trans-from-x tab-trans-to-x db%debug_window-primary-:get-next-line-method db%debug_window-primary-:last-line-displayed-p-method ;;;db%debug_window-combined-:center-around-line-method db%debug_window-primary-:center-around-line-method ;;;;;;;;;;;;;;;; db%debug_window-primary-:maybe-remove-lines-method db%debug_window-primary-:after_output-method db%debug_window-primary-:adjust_position-method )) ;;; **************************************************************** ;;; Flavor definitions ;;; **************************************************************** ;;; The main thing. A db%debug_window maintains all its lines so that ;;; any page can be redisplayed. The line-list is a list of conses, ;;; each of which is the cons of the number of the first character ;;; displayed in that line and the string of that line. ;;; If first- and last-char are specified, these are character counts ;;; in the file. Only those characters are displayed. (ct_defflavor db%debug_window ((window nil) ; The LM Window. (line-list nil) ;1-based (line-number 1) ;number of first line (line nil) ;ptr to tail at first line. (lines-displayed 10.) ;how many in this window. (string-p nil) ;T if string displayed, not file. (filename "Foo.") (name "") (init-flag t) (no-more nil) (last-refresh-line1 nil) ;first line of last refresh. (last-refresh-linen nil) ;last line of last refresh. (last-ptr nil) ; same as (last line-list) (restrict-first nil) ;first line allowed to display (restrict-last nil) ;last line allowed to display (current_xpos 0) ;;current x position (current_ypos 0) ;;current y position (min_xpos 0) ;;minimum x position (min_ypos 0) ;;minimum y position (max_xpos 0) ;;maximum x position (max_ypos 0) ;;maximum y position (write_only nil)) ;; User input dis-allowed () #+lispm :initable-instance-variables :gettable-instance-variables :settable-instance-variables) ;;; Make sure all of these are initialized correctly. (defmethod (db%debug_window :after :init) (&rest ignore) (send self ':display-string "")) ;;; **************************************************************** ;;; Externally callable functions and methods ;;; **************************************************************** ;;; Asked for on 9-Apr-84. We need to be able to print the contents ;;; of a scroll window to a file. This seems simple. (defmethod (db%debug_window :print-to-file) (fname) (with-open-file (stream fname ':direction ':output) (loop for l in line-list do (format stream "~A~%" (cdr l))))) ;;; To display a file, send this message. It loads in the file (in ;;; the specified character range) and displays the first page. If ;;; the character range specified is NIL NIL, then the entire file is ;;; loaded in. Otherwise, only a portion of the file is loaded in. ;;; ;;; If a third optional argument is added, instead of displaying from ;;; the beginning of the file, we center the display around that char. ;;; If the third argument is NEGATIVE, then that character is put at ;;; the top of the display. (defmethod (db%debug_window :display-file) (fname &optional begin end center-char (center-pos ':center) (display-p t)) (cond ((not (ct_probef fname)) (lose 'file-not-found '(db%debug_window method :display-file))) ;; Check the center arg to see if it is valid. ((and center-char begin end (not (<= begin center-char end))) (lose 'center-arg-not-in-range '(db%debug_window method :display-file) "~D is not between ~D and ~D" center-char begin end)) (t (setq filename fname) (setq string-p nil) ;Not a string, silly. (setq line-list nil) ;reset line list (with_open_infile (stream filename) (setq no-more nil) ;more chars may be read ;; Now loop, gathering lines. get-next-line will set no-more ;; when we shouldn't read any more, either if end of file, or ;; because end has been reached. g-n-l is also responsible ;; for keeping track of character counts. Notice that we build ;; the line-list in reverse order, for efficiency. It is ;; eventually nreversed. (loop for next-line = (ct_csend db%debug_window self :get-next-line stream) do (setq line-list (nconc next-line line-list)) until no-more)) (setq line-list (nreverse line-list) last-ptr (last line-list) line-number 1 line line-list last-refresh-linen nil last-refresh-line1 nil) (send self ':restrict-range begin end nil) ;don't redisplay now. (ct_if center-char (ct_csend db%debug_window self :center-around-char center-char center-pos display-p) (ct_csend db%debug_window self :beginning display-p)) (if display-p (send self ':reposition_cursor))))) ;;; Displays a string instead of a file. Begin and end cannot be specified. ;;; If you want to display part of a string, send me just that part. (defmethod (db%debug_window :display-string) (string &optional (display-p t)) (if (string-equal "" string) (setq string " ")) (loop for i from 1 to (ct_string_length string) with b = i if (memq (ct_character (ct_substring string (1- i) i)) *return*) collect (cons b (ct_substring string (1- b) i)) into lls and do (setq b i) finally (progn (setq string-p t) (setq filename "String, not file.") (setq last-refresh-linen nil last-refresh-line1 nil line-list (append lls (setq last-ptr (list (cons b (ct_substring string b)))))) (ct_csend db%debug_window self :beginning display-p) (if display-p (send self ':reposition_cursor))))) ;;; Adds the specified string to the display. THe string may contain ;;; characters; they delimit lines. The first line of the ;;; string is APPENDED to the last line of the display. If you want ;;; to start a new line, you must supply a carriage return as the first ;;; character. ;;; Rewrite add-many-lines. Use character searching for . (defmethod (db%debug_window :add-many-lines) (string &optional (redisplay t)) (loop with left = 0 with len = (ct_string_length string) with 1len = (1- len) for right = (ct_string_search_set *return* string left) do (ct_if (zerop left) (ct_csend db%debug_window self :add-string (ct_substring string left (or right len)) nil) (ct_csend db%debug_window self :add-line (ct_substring string left (or right len)) nil)) if right do (setq left (1+ right)) if (equal right 1len) do (ct_csend db%debug_window self :add-line "" nil) until (or (not right) (equal right 1len))) (ct_csend db%debug_window self :maybe-remove-lines) (or *display-inhibited* (and redisplay (ct_csend db%debug_window self :display-page)))) ;;; Adds the contents of a specified file to the window display. ;;; The window can be displaying a string or a file. After adding ;;; the file, we attempt to adjust the display so that the first ;;; part of the added file is displayed. (defmethod (db%debug_window :add-file) (fname &optional (display-p t) &aux pos) (setq pos (max (- (length line-list) 2) 1)) (setq line-list (nreverse line-list)) (with_open_infile (stream fname) (setq no-more nil) (loop until no-more do (setq line-list (nconc (ct_csend db%debug_window self :get-next-line stream) line-list)))) (setq line-list (nreverse line-list)) (setq line-number pos) (setq line (nthcdr (1- pos) line-list)) (setq last-ptr (last line)) ;;Keep LAST up to date. ;; If too many lines, remove some. THis may not be a really good ;; idea here, since I am not sure about the interaction with POS. (ct_csend db%debug_window self :maybe-remove-lines) (or *display-inhibited* (and display-p (ct_csend db%debug_window self :display-page)))) ;;; Completely rewritten. You can ALWAYS restrict the range if you like. ;;; This updates the instance variables RESTRICT-FIRST and RESTRICT-LAST. ;;; Also guarantees that the display is in range. Recall that line numbers ;;; start with 1, not 0. (defmethod (db%debug_window :restrict-range) (begin end &optional (redisplay t)) (setq restrict-first (and begin (loop for i from 1 for l in line-list if (> (car l) begin) return (- i 1) finally nil)) restrict-last (and end (loop for i from 1 for l in line-list if (> (car l) end) return (- i 1) finally nil))) ;;; (format t "~%Restricting to range [~A .. ~A]" restrict-first restrict-last) ;; Now that restrict-first and restrict-last are set up, make sure ;; that the line-pointer is correct. (cond ;; If too small, change to first viewable line. ((and restrict-first (< line-number restrict-first)) (setq line-number restrict-first line (nthcdr (- line-number 1) line-list))) ;; If too large, change to before last viewable line. Don't ;; move pointer further back than first restricted line. Try ;; to display most of a page. ((and restrict-last (> line-number restrict-last)) (setq line-number (max restrict-first (- restrict-last lines-displayed -3)) line (nthcdr (- line-number 1) line-list)))) ;; Make sure we completely redisplay next time (setq last-refresh-line1 nil) ;; Finally, update the screen (if redisplay (or *display-inhibited* (ct_csend db&debug_window self :display-page)))) ;;; Moves to the beginning of the file for display. Modified to understand ;;; restrict-first. (defmethod (db%debug_window :beginning) (&optional (display-p t)) (setq line-number (or restrict-first 1)) (setq line (nthcdr (1- line-number) line-list)) (or *display-inhibited* (and display-p (ct_csend db%debug_window self :display-page)))) ;;; Moves to the end of the file for display. We can be smart here ;;; by not cdr-ing down from the beginning of the ;;; list, but by using the old line values instead. It would be nice ;;; if there were a way to get the length of line-list quickly. ;;; Modified to understand restrict-first and restrict-last. (defmethod (db%debug_window :end) (&optional (display-p t)) (unless (send self ':last-line-displayed-p) (setq line-number (max (or restrict-first 1) (- (or restrict-last (+ (length line) line-number -1)) lines-displayed (- *bottom-space*)))) (setq line (nthcdr (1- line-number) line-list))) (or *display-inhibited* (and display-p (ct_csend db%debug_window self :display-page)))) ;;; Moves to the next display page. Modified to understand restrict-last. (defmethod (db%debug_window :forward-screen) (&optional (line-count lines-displayed)) (setq line-number (min (+ line-number (- line-count *overlap-lines*)) (max (or restrict-first 1) (- (or restrict-last (+ (length line) line-number -1)) lines-displayed (- *bottom-space*))))) (setq line (nthcdr (1- line-number) line-list)) (or *display-inhibited* (ct_csend db%debug_window self :display-page))) ;;; Moves to the previous display page. (defmethod (db%debug_window :backward-screen) (&optional (line-count lines-displayed)) (setq line-number (max (or restrict-first 1) (- line-number (- line-count *overlap-lines*)))) (setq line (nthcdr (1- line-number) line-list)) (or *display-inhibited* (ct_csend db%debug_window self :display-page))) ;;; To make a specified line be at the top of the screen. ;;; RIGHT NOW DOES NOT UNDERSTAND RESTRICTIONS. (defmethod (db%debug_window :line-to-top) (number) (setq line-number (max 1 (+ line-number (min number (1- lines-displayed))))) (setq line (nthcdr (1- line-number) line-list)) (or *display-inhibited* (ct_csend db%debug_window self :display-page))) ;;; Adds a line of text. The string should NOT include any return ;;; characters. If the last line is visible, the screen will be ;;; updated. Note that we redisplay the entire page. CURSES will ;;; actually display only the last line, since that is all that will ;;; change. (we hope.) If redisplay is supplied NIL, then any ;;; display will be suppressed. Otherwise, redisplay is done only ;;; if the last line is showing. (defmethod (db%debug_window :add-line) (string &optional (redisplay t)) (ct_if line-list (rplacd last-ptr (list (cons (+ (caar last-ptr) 1 (ct_string_length (cdar last-ptr))) string))) (setq line-list (list (cons *first-char-number* string)) line line-list last-ptr line-list)) (setq last-ptr (last last-ptr)) ;;Keep LAST up to date. ;; If too many lines, remove some (ct_csend db%debug_window self :maybe-remove-lines) (or *display-inhibited* (ct_if (ct_csend db%debug_window self :last-line-displayed-p) (and redisplay (ct_csend db%debug_window self :display-page))))) ;;; Adds the string to the last line of text. This doesn't create ;;; any new lines. String must not contain any return characters. ;;; If there are no lines yet, create a new one. (This makes it robust.) ;;; If the last line is visible, the screen will be updated. ;;; Supplying redisplay NIL will force no redisplay. (defmethod (db%debug_window :add-string) (string &optional (redisplay t)) (ct_if line-list (rplacd (car last-ptr) (ct_string_append (cdar last-ptr) string)) (setq line-list (list (cons 1 string)) line line-list last-ptr line-list)) (setq last-ptr (last last-ptr)) ;; If too many lines, remove some. (ct_csend db%debug_window self :maybe-remove-lines) (or *display-inhibited* (ct_if (ct_csend db%debug_window self :last-line-displayed-p) (and redisplay (ct_csend db%debug_window self :display-page))))) (defmethod (db%debug_window :set-lines) (new-number-of-lines) (setq lines-displayed new-number-of-lines) (or *display-inhibited* (ct_csend db%debug_window self :display-page))) (defmethod (db%debug_window :number-of-lines) () (length line-list)) ;; Returns the number of chars in the document. (defmethod (db%debug_window :number-of-chars) () (cond ((null line-list) 0) (t (+ (car (car last-ptr)) (ct_string_length (cdar last-ptr)))))) ;;; The translate message will translate a screen coordinate into a ;;; source file position, or a source file position into a screen ;;; coordinate. (The difference is in how many args are passed to ;;; this function.) If a source file position is not on the screen, ;;; NIL is returned. If a screen position doesn't correspond to any ;;; character displayed, the closest character position is returned. ;;; (Happens after end of lines, or after the last line in file.) ;;; The X, Y coordinates supplied or returned are relative to the ;;; origin of the window involved, not the entire screen. ;;; ;;; A lot of this is re-worked to understand TABS in the source ;;; document. (defmethod (db%debug_window :translate) (x &optional y) (cond ((and y (numberp y)) ;If y supplied, screen coord. (let ((l (car (nthcdr y line)))) ;Get pointer to correct line. (ct_if l ;If a real line, ;; Return the counter for the beginning of the line, plus ;; the x coordinate, but no more than the number of chars ;; on the line, of course. (min (+ (car l) (tab-trans-from-x x l)) (+ (car l) (ct_string_length (cdr l)))) ;; If no line, its because we are past all lines. (+ (caar last-ptr) (ct_string_length (cdar last-ptr)))))) (t ;; y not supplied, must be a document position. The document ;; position could be corresponding to a carriage return, which has ;; no real screen position. We will return the position to the right ;; of the last position on a line for a return char. ;; Note that some chars may not be on the screen because a line is ;; too long. In that case, we will return the last position on that ;; screen line (Closest possible.) (loop for lll on line for i from line-number if (>= i (+ line-number lines-displayed)) return nil if (<= (caar lll) x (1- (or (caadr lll) 99999999))) return (list (min (- (tab-trans-to-x x (car lll)) (caar lll)) max_xpos) (- i line-number)) finally (return nil))))) ;;; &&&&&&&&&&&&&&&& ;;; The following functions are being modified to understand LM ;;; font change character sequences. These pairs of characters ;;; always begin with , and end with a digit. These characters ;;; should be counted in the source positions, but are of zero ;;; width (they don't print), so tab-trans needs to understand them. ;;; &&&&&&&&&&&&&&&& ;;; ;;; The two tab-trans functions take into account that tabs may exist ;;; in a document. A tab will take the cursor to the next tab stop, a ;;; multiple of 8 characters. It is necessary to scan most of a line ;;; to determine what character positions are. Foo. ;;; ;;; tab-trans-from-x assumes x is a cursor position. We want to translate ;;; it into the number of characters from the left margin. If there ;;; are no tabs, this is the identity transformation. (defun tab-trans-from-x (x line) (loop for i from 0 to (1- (ct_string_length (cdr line))) with xpos = 0 do (cond ((= (aref (cdr line) i) #\tab) (setq xpos (* 8 (1+ (!/ xpos 8))))) ;; If we see the epsilon, DECREMENT the xpos, so that the ;; net effect of the two characters is ZERO. ((= (aref (cdr line) i) 6.) (setq xpos (1- xpos))) (t (setq xpos (1+ xpos)))) until (>= xpos x) finally (return (1+ i)))) ;;; tab-trans-to-x assumes x is a document position. We want to translate ;;; the portion of it that applies to the current line into x screen positions. (defun tab-trans-to-x (x line) (loop for i from 0 to (- x (car line) 1) with xpos = 0 do (cond ((= (aref (cdr line) i) #\tab) (setq xpos (* 8 (1+ (!/ xpos 8))))) ((= (aref (cdr line) i) #/ ) (setq xpos (1- xpos))) (t (setq xpos (1+ xpos)))) finally (return (+ xpos (car line))))) ;;; The following two messages are supplied as a convenience in naming. (defmethod (db%debug_window :translate-screen-to-document) (x y) (ct_csend db%debug_window self :translate x y)) (defmethod (db%debug_window :translate-document-to-screen) (x) (ct_csend db%debug_window self :translate x)) ;;; This method will allow you to adjust the display to show a ;;; specific location in the file. Specify a location, and the line ;;; on which it appears will be centered in the display. Returns ;;; the position on the screen corresponding to that file position. ;;; If the position is near the beginning or end of the file, the ;;; line may not wind up centered. ;;; The screen-pos may be either ':top, ':center, or ':bottom. ;;; New feature: screen-pos may also be a flonum which indicates the fraction of ;;; the screen which is to be above the cursor. (defmethod (db%debug_window :center-around-char) (file-posn &optional (screen-pos ':center) (display-p t)) (loop for l in line-list for i from 1 if (<= (car l) file-posn (+ (car l) (ct_string_length (cdr l)))) do (ct_csend db%debug_window self :center-around-line i screen-pos display-p) and return (ct_csend db%debug_window self :translate file-posn) finally (progn (ct_csend db%debug_window self :end) (return (ct_csend db%debug_window self :translate file-posn))))) ;;; Searches for a text string. The string should not contain ;;; characters. Searching begins at the position in the ;;; document corresponding to the cursor location specified. If ;;; the search is successful, the location found will be centered. ;;; If unsuccessful, NIL will be returned. (To return NIL, just ;;; put the tape in a box and mail it to GSB@ML.) ;;; Modified to understand restrict-last (defmethod (db%debug_window :search) (key x y) (loop for i from (+ line-number y -1) until (> i (or restrict-last (length line-list))) for l in (nthcdr i line-list) for extra first (tab-trans-from-x x l) then 0 for str first (if (>= x (ct_string_length (cdr l))) "" (ct_substring (cdr l) x)) then (cdr l) for p = (font-search-in-string key str) if p return (progn (ct_csend db%debug_window self :center-around-line i) (list (- (tab-trans-to-x (+ (car l) extra p) l) (car l)) (- i line-number -1))))) (defun font-search-in-string (key string) (loop with i = 0 with max-string = (- (ct_string_length string) (ct_string_length key)) if (> i max-string) return nil if (= (aref string i) #/) do (setq i (+ i 2)) if (font-look-for-key key string i) return it else do (setq i (1+ i)))) (defun font-look-for-key (key string start) (loop for key-idx from 0 to (1- (ct_string_length key)) with string-idx = start with max-string = (1- (ct_string_length string)) if (> string-idx max-string) return nil if (= (aref string string-idx) #/) do (setq string-idx (+ string-idx 2)) if (not (ct_char_equal (aref key key-idx) (aref string string-idx))) return nil else do (setq string-idx (1+ string-idx)) finally (return string-idx))) ;;; This function replaces font-change sequences with spaces. ;;; It is an interim kludge. This function DESTRUCTIVELY modifies ;;; the string, which in this case is the right thing to do. (defun maybe-remove-font-chars (string) (if (stringp string) (loop for i from 0 to (- (string-length string) 2) if (= #/ (aref string i)) do (aset #\space string i) AND do (aset #\space string (1+ i))))) ;;; **************************************************************** ;;; Internally used functions, methods ;;; **************************************************************** #| ;;;This is the old way. New method is below. This change was made to handle files ;;;which don't end in a return. wab 5-7-84 ;;; Returns the next line in a file. Uses Bill's c-coded ;;; readline function (called fgetswon) instead of successive ;;; tyi's. (defmethod (db%debug_window :get-next-line) (stream) (let ((pos (ct_if line-list (+ (caar line-list) (ct_string_length (cdar line-list)) 1) *first-char-number*)) (str (readline stream 'foo))) ;;;; (maybe-remove-font-chars str) (cons pos (cond ;; If read end of file, set NO-MORE, and give a ;; null string. ((eq str 'foo) (setq no-more t) "") ;; Otherwise, just give the string. (t (ct_string str)))))) |# (defmethod (db%debug_window :get-next-line) (stream) (multiple-value-bind (str eofp) (ct_send stream ':line-in t) (let ((pos (ct_if line-list (+ (caar line-list) (ct_string_length (cdar line-list)) 1) *first-char-number*))) (setq no-more eofp) (cond ((not eofp) (list (cons pos str))) ((ct_string_equal str "") (list (cons pos str))) (t (list (cons (+ pos (ct_string_length str)) "") (cons pos str))))))) ;;; This function replaces font-change sequences with spaces. ;;; It is an interim kludge. This function DESTRUCTIVELY modifies ;;; the string, which in this case is the right thing to do. (defun maybe-remove-font-chars (string) (if (stringp string) (loop for i from 0 to (- (string-length string) 2) if (= #/ (aref string i)) do (aset #\space string i) AND do (aset #\space string (1+ i))))) ;;; Does the actual work of displaying a screenful of information. ;;; ;;; New, improved version. If we can update by scrolling one or ;;; two lines, do it instead of updating the entire screen. ;;; ;;; &&&&&&&&&&&&&&&& ;;; 28-Jan-84 Improvements. ;;; This needs to be reworked to understand LM windows. ;;; &&&&&&&&&&&&&&&& ;;; ;;; &&&&&&&&&&&&&&&& ;;; Changes on 23-Mar-84: ;;; Adjusted so that we won't display past RESTRICT-LAST line, if defined. ;;; Does this at each STRING-OUT by checking to see if the line we're on ;;; is too far. ; ;;;New display page method. Knows how to scroll correctly. Can scroll by up ;;; to three lines now. Can scroll either up or down. wab 1-31-84 (defmethod (db%debug_window :display-page) () (let ((diff (and last-refresh-line1 (- line-number last-refresh-line1)))) (cond ;; If small scroll backward, open up n lines at top and then write the ;; new text. ((or (eq -1. diff) (eq -2. diff) (eq -3. diff)) (send window ':home-cursor) (send window ':insert-line (abs diff)) (loop for i from 0 to (1- (- diff)) for lin in line for string = (cdr lin) do (send window ':set-cursorpos 0 i ':character) if (and string (<= (+ i line-number) (or restrict-last 99999999))) do (send window ':string-out (no-fonts string)))) ;; If small scroll forward (or no scroll), then delete n lines at the ;; top and write the new text at the bottom. Must be careful that the ;; whole window may not be full. ((or (eq 0. diff) (eq 1. diff) (eq 2. diff) (eq 3. diff)) (unless (zerop diff) (send window ':home-cursor) (send window ':delete-line diff)) (loop for i from (- last-refresh-linen line-number) to (min (1- lines-displayed) (1- (length line))) for lin in (nthcdr (- last-refresh-linen line-number) line) for string = (cdr lin) do (send window ':set-cursorpos 0 i ':character) if (and string (<= (+ i line-number) (or restrict-last 99999999))) do (send window ':string-out (no-fonts string)))) ;; If all else fails, repaint everything. (t (send window ':clear-screen) (loop for i from 0 to (1- lines-displayed) for lin in line for string = (cdr lin) do (send window ':set-cursorpos 0 i ':character) if (and string (<= (+ i line-number) (or restrict-last 99999999))) do (send window ':string-out (no-fonts string))))) ;; (break 'display) (setq last-refresh-line1 (max 1 line-number) last-refresh-linen (max last-refresh-line1 (+ last-refresh-line1 (1- (min lines-displayed (length line)))))))) ;;refresh this window's display on the screen (defmethod (db%debug_window :refresh) () (send window ':clear-screen) (loop for i from 0 to (1- lines-displayed) for lin in line for string = (cdr lin) do (send window ':set-cursorpos 0 i ':character) if string do (send window ':string-out (no-fonts string)))) ;;; Removes font change sequences from strings. (defun no-fonts (string) (let ((search (string-search-char #/ string))) (if search (string-append (substring string 0 search) (no-fonts (substring string (+ 2. search)))) string))) ;;; Returns T if the last line should be on the screen. (defmethod (db%debug_window :last-line-displayed-p) () (< (1- (length line)) lines-displayed)) ;;; Centers the display around a particular line, within reason. ;;; Screen pos can be either ':top, ':center, or ':bottom. ;;; Modified to understand restrict-first and restrict-last. ;;; New feature: screen-pos may now be a flonum which indicates the ;;; fraction of the screen to have above the cursor. (defmethod (db%debug_window :center-around-line) (line-num &optional (screen-pos ':center) (display-p t)) (let ((old line-number)) (setq line-number (max (or restrict-first 1) (min (or restrict-last 99999999) (fixr (- line-num (cond ((flonump screen-pos) (max 0 (min (1- lines-displayed) (* screen-pos lines-displayed)))) ((eq screen-pos ':center) (!/ lines-displayed 2.)) ((eq screen-pos ':top) 0) ((eq screen-pos ':bottom) (1- lines-displayed)) (t 0))))))) ;; Be careful here-- if going backwards, can't cdr down line. (ct_if (> line-number old) (setq line (nthcdr (max 0 (- line-number old)) line)) (setq line (nthcdr (1- line-number) line-list))) (or *display-inhibited* (and display-p (ct_csend db%debug_window self :display-page))))) ;;; This will check the number of lines in the window, and if there ;;; are too many, it will remove a chunk from the front of the list, ;;; allowing the garbage collector to run wild for a moment. ;;; This method should only be called by things that add lines to ;;; the window. Warning: if you are displaying a file in the window, ;;; part of the file may go away. (defmethod (db%debug_window :maybe-remove-lines) () (cond (;; Check to see if too many lines. First check line-number, ;; since it is easier to calculate than length of line-list. (or (> line-number *max-lines*) (> (length line-list) *max-lines*)) ;; Prepare by possibly moving first displayed line. (ct_if (<= line-number *remove-chunk*) (setq line-number (1+ *remove-chunk*) line (nthcdr (1- line-number) line-list))) ;; Now, surgically remove the first few lines. (setq line-list (nthcdr *remove-chunk* line-list) last-refresh-line1 (and last-refresh-line1 (- last-refresh-line1 *remove-chunk*)) last-refresh-linen (and last-refresh-linen (- last-refresh-linen *remove-chunk*)) line-number (- line-number *remove-chunk*))))) ;;; **************************************************************** ;;; Externally accessible code. ;;; **************************************************************** ;;; &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& ;;; &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& ;;; ;;; From this point down, we need to be extremely careful. A lot ;;; of these things may change drastically. ;;; ;;; &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& ;;; &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& (defmethod (db%debug_window :clear) () (send window ':clear-screen)) (defmethod (db%debug_window :touchwin) () nil) (defmethod (db%debug_window :wrefresh) () (send self ':display-page)) ;;; &&&& I think someone has the arguments in reverse order here. ;;; &&&& It should be OK now. (defmethod (db%debug_window :wmove) (ypos xpos) (send window ':set-cursorpos xpos ypos ':character)) ;;; Just redisplay the current page. &&&& now ok. (defmethod (db%debug_window :screen_refresh) () (send self ':display-page)) ;;; &&&& ok. ;;move the cursor to the current position in this window (defmethod (db%debug_window :reposition_cursor) (&optional (additional-x 0)) (ct_csend db%debug_window self :wmove current_ypos (+ current_xpos additional-x)) ;; (ct_csend db%debug_window self :touchwin) ;; (ct_csend db%debug_window self :wrefresh) ) ;move the cursor up one line ;;; &&&& ok (defmethod (db%debug_window :up_arrow) () (ct_if (eq min_ypos current_ypos) (progn ;;if already at top of window, error #+franz (tyo control_g) #+lispm (beep) #+franz (drain)) (progn (setq current_ypos (1- current_ypos)) (ct_csend db%debug_window self :reposition_cursor)))) ;move the cursor down one line ;;; &&&& ok (defmethod (db%debug_window :down_arrow) () (ct_if (eq max_ypos current_ypos) (progn ;;if already at bottom of window, error #+franz (tyo control_g) #+lispm (beep) #+franz (drain)) (progn (setq current_ypos (1+ current_ypos)) (ct_csend db%debug_window self :reposition_cursor)))) ;;move the cursor to the right ;;; &&&& ok (defmethod (db%debug_window :right_arrow) () (ct_if (eq max_xpos current_xpos) (progn ;;if already at far right of window, error #+franz (tyo control_g) #+lispm (beep) #+franz (drain)) (progn (setq current_xpos (1+ current_xpos)) (ct_csend db%debug_window self :reposition_cursor)))) ;move the cursor to the left ;;; &&&& ok (defmethod (db%debug_window :left_arrow) () (ct_if (eq min_xpos current_xpos) (progn ;;if already at far left of window, error #+franz (tyo control_g) #+lispm (beep) #+franz (drain)) (progn (setq current_xpos (1- current_xpos)) (ct_csend db%debug_window self :reposition_cursor)))) ;;get the next page for the window ;;; &&&& ok (defmethod (db%debug_window :next_page) () (ct_csend db%debug_window self :forward-screen)) ;;get the previous page for the window ;;; &&&& ok (defmethod (db%debug_window :previous_page) () (ct_csend db%debug_window self :backward-screen)) ;;get the top of the file displayed in the window ;;; &&&& ok (defmethod (db%debug_window :top_file) () (ct_csend db%debug_window self :beginning)) ;;get the end of the file displayed in the window ;;; &&&& ok (defmethod (db%debug_window :bottom_file) () (ct_csend db%debug_window self :end)) ;;; Following are the simple methods for output. I use FORMAT each ;;; time to guarantee that we are indeed printing a string. After all ;;; output, we move to the end of the window, and update the cursor ;;; position. ;;; &&&& This method is ok. (defmethod (db%debug_window :ct_princ) (thing) (ct_csend db%debug_window self :add-many-lines (cond ((ct_stringp thing) thing) (t (format nil "~A" thing))) nil) (ct_csend db%debug_window self :after_output)) ;;; &&&& This method is ok. (defmethod (db%debug_window :ct_prin1) (thing) (ct_csend db%debug_window self :add-many-lines (format nil "~S" thing) nil) (ct_csend db%debug_window self :after_output)) ;;; &&&& This method is ok. (defmethod (db%debug_window :ct_print) (thing) (ct_csend db%debug_window self :add-many-lines (format nil "~%~A " thing) nil) (ct_csend db%debug_window self :after_output)) ;;; &&&& This method is ok. (defmethod (db%debug_window :ct_tyo) (char) (ct_csend db%debug_window self :add-many-lines (format nil "~A" (ascii char)) nil) (ct_csend db%debug_window self :after_output)) ;;; &&&& This method is ok. (defmethod (db%debug_window :ct_terpri) () (ct_csend db%debug_window self :add-line "" nil) (ct_csend db%debug_window self :after_output)) ;;; &&&& This method is ok. (defmethod (db%debug_window :ct_format) (format-control-string &rest args) (let ((fmt (apply #'format (cons nil (cons format-control-string args))))) (ct_csend db%debug_window self :add-many-lines fmt nil) (ct_csend db%debug_window self :after_output))) ;;; &&&& Rewritten to use LM readline function. ;;; ;;; A difficult problem: readline. This gets around all the kludge ;;; of using ct_tyi. Accepts only printing characters (and space.) ;;; We do all the echo-ing here. (defmethod (db%debug_window :ct_readline) () (ct_csend db%debug_window self :reposition_cursor) (let ((string (ct_readline2 window))) (ct_csend db%debug_window self :add-string string nil) (ct_csend db%debug_window self :add-line "" nil) (ct_csend db%debug_window self :after_output) (ct_csend db%debug_window self :reposition_cursor) (send window ':clear-eol) string)) ;;; &&&& No need to fix this. ;;; This new, improved CT_TYI allows user editing by calling ct_readline ;;; to fill an input buffer when empty. If the buffer is not empty, ;;; ct_tyi returns the first character in the buffer. We have only ;;; one global buffer, not a buffer-per-window; this is deliberate, but ;;; for no really good reason, except that I feel in a single processing ;;; environment, multiple type-in buffers are a mistake. (defmethod (db%debug_window :ct_tyi) () (ct_if (ct_string_equal *ct_tyi_buffer* "") (setq *ct_tyi_buffer* (ct_csend db%debug_window self :ct_readline))) ;;(ct_string_append (ct_csend db%debug_window self ;; :ct_readline) #\return) ;; alex -- no need to append the return now, the necessary change made in ct_readline2 (prog1 (ct_nthchar *ct_tyi_buffer* 0) (setq *ct_tyi_buffer* (ct_substring *ct_tyi_buffer* 1)))) ;;; &&&& This method is ok. ;;; The new ct_tyipeek uses the buffer. (defmethod (db%debug_window :ct_tyipeek) () (ct_if (ct_string_equal "" *ct_tyi_buffer*) (setq *ct_tyi_buffer* (ct_csend db%debug_window self :ct_readline))) ;;(setq *ct_tyi_buffer* ;; (ct_string_append (ct_csend db%debug_window self ;; :ct_readline #\return))) (ct_nthchar *ct_tyi_buffer* 0)) ;;;A new method to flush any pending input. Note that this is very simplistic. We ;;;do not try to remove any echo from the scroll window output buffers, just ;;;prevent them from being read. (defmethod (db%debug_window :clear-input) () (setq *ct_tyi_buffer* "") (send window ':clear-input)) ;;; &&&& This method is ok. (defmethod (db%debug_window :after_output) () (ct_csend db%debug_window self :end) ;move to end of document (ct_if (not write_only) (ct_csend db%debug_window self :adjust_position))) ;;; &&&& This method is ok. (defmethod (db%debug_window :adjust_position) () #| Set the correct cursor position after a print |# (let ((xy (ct_csend db%debug_window self :translate-document-to-screen (ct_csend db%debug_window self :number-of-chars)))) (ct_csend db%debug_window self set-current_xpos (first xy)) (ct_csend db%debug_window self set-current_ypos (second xy)))) ;;kludge to grab extraneous close messages (defmethod (db%debug_window :close) (ignore) nil) ;;; **************************************************************** ;;; Testing Functions ;;; **************************************************************** ;;; A battery of testing functions to allow testing with Franz. ;;; Necessary, since I can't have two separate windows like on the ;;; lisp machine. Foo. ;(declare (special a b)) ; wab ; ;(defun t1 () ; (initscr) ; (setq a (newwin 10 80 3 0)) ; (setq b (ct_make_instance 'db%debug_window ; 'window a)) ; (ct_send b ':display-file "!/mnt!/john!/.lisprc") ; (read) ; (ct_send b ':search "zwei" 0 0) ; (read) ; (ct_send b ':end) ; (read) ; (ct_send b ':beginning) ; (read) ; (ct_send b ':forward-screen) ; (read)) ; ;(defun t2 () ; (initscr) ; (setq a (newwin 15 80 0 0)) ; (setq b (ct_make_instance 'db%debug_window 'window a)) ; (ct_send b ':display-string "Now is the time for all good men ;to come to the aid of their party.") ; (read) ; (ct_send b ':display-file "!/mnt!/john!/.lisprc") ; (read) ; (ct_send b ':restrict-range 0 40) ; (read) ; (ct_send b ':restrict-range nil nil) ; (read) ; (ct_send b ':add-line "************************") ; (read) ; (ct_send b ':end) ; (read) ; (ct_send b ':add-string "++++++++++++++") ; (read) ; (ct_send b ':center-around-char 100)) ; ; ;(defun t3 () ; (initscr) ; (setq a (newwin 10 80 0 0)) ; (setq b (ct_make_instance 'db%debug_window 'window a)) ; (ct_send b ':display-file "!/mnt!/john!/.login") ; (read) ; (ct_send b ':add-file "!/mnt!/john!/.logout") ; (read) ; (ct_send b ':end) ;) ; ;(defun t4 () ; (initscr) ; (setq a (newwin 10 80 0 0)) ; (setq b (ct_make_instance 'db%debug_window 'window a)) ; (ct_send b ':display-file "!/mnt!/john!/.login" nil nil 1000) ; (read) ; (ct_send b ':add-line "New Line Now.....") ; (read) ; (ct_send b ':add-many-lines "***FOO*** ;now is the time ;for all good men.") ; (read) ; (ct_send b ':end)) ; ; ; ;(defun t5 (lines &aux a b) ; (initscr) ; (setq a (newwin lines 80 0 0)) ; (werase a) ; (setq b (ct_make_instance 'db%debug_window 'window a 'lines-displayed lines)) ; (ct_send b ':display-file "!/mnt!/john!/.lisprc") ; (read) ; (ct_send b ':line-to-top 1) ; (read) ; (ct_send b ':line-to-top 2) ; (read) ; (ct_send b ':line-to-top -2) ; (read) ; (ct_send b ':line-to-top -1)) ; ; ;;;; Tab test ;(defun t6 (&aux a b) ; (initscr) ; (setq a (newwin 10 80 0 0)) ; (setq b (ct_make_instance 'db%debug_window 'window a)) ; (ct_send b ':display-string "This line has no tabs.") ; (read) ; (ct_send b ':add-line " This line has one tab in it.") ; (ct_send b ':add-line " This line has two tabs.") ; (read) ; (ct_send b ':add-line " This line has one tab in it.") ; (ct_send b ':add-line " This line has two tabs.") ; (read) ; (ct_send b ':add-line " This line has one tab in it.") ; (ct_send b ':add-line " This line has two tabs.") ; (read) ; (ct_send b ':add-line " This line has one tab in it.") ; (ct_send b ':add-line " This line has two tabs.") ; (read) ; (ct_send b ':add-line " This line has one tab in it.") ; (ct_send b ':add-line " This line has two tabs.") ; (read) ; (ct_send b ':add-line " This line has one tab in it.") ; (ct_send b ':add-line " This line has two tabs.") ; (read) ; (ct_send b ':add-line " This line has one tab in it.") ; (ct_send b ':add-line " This line has two tabs.") ; (read) ; (ct_send b ':add-line " This line has one tab in it.") ; (ct_send b ':add-line " This line has two tabs.") ; (read) ; (ct_send b ':add-line " This line has one tab in it.") ; (ct_send b ':add-line " This line has two tabs.") ; (read) ; (ct_send b ':add-line " This line has one tab in it.") ; (ct_send b ':add-line " This line has two tabs.") ;) ;;;;;;;;; ;;; Test to see if restrict-range works. ;(defun t6 ();;; (&aux a b) ; (setq a (tv:make-window 'tv:window ':character-height 24. ':character-width 80.)) ; (setq b (ct_make_instance 'db%debug_window 'window a)) ; (send a ':expose) ; ;; The following file has 100 lines with 20 characters (or 19) per line. ; (send b ':display-file "bigbird://mnt//john//linetest") ; (tyi) ; (send b ':end) ; (tyi) ; (send b ':beginning) ; (tyi) ; (send b ':restrict-range 100. 300.) ;restrict to lines 5 - 15 ; (tyi) ; (send b ':end) ; (tyi) ; (send b ':beginning) ; (tyi) ; (send b ':restrict-range 50 nil) ;Restrict to lines 3 --> ; (tyi) ; (send b ':end) ; (tyi) ; (send b ':beginning) ; (tyi) ; (send b ':restrict-range nil nil) ; (tyi) ; (send b ':beginning) ; (tyi) ; (send b ':end)) ; ; ; ; ;