;;; -*- Mode: Common-Lisp; Package: Sys; Base: 10.; Patch-File: T -*- ;;; Reason: Added :read-cursorpos and :incrment-cursorpos to basic-buffered-output-stream. ;;; 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. ;;; Written 12/08/89 12:55:48 by BERGER, ;;; while running on ARIES from band LODA ;;; With SYSTEM 6.27, 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.19, 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.11, ;;; 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.7, TI-CLOS 6.26, CLEH 6.5, IP 3.56, ;;; Experimental CLX 6.7, CLUE 6.35, X11M 6.19, Experimental BUG 11.17, RPC 6.2, ;;; NFS 3.9, DECNET 1.70, microcode 429, Band Name: REL 6.0 + SLE 11/28 #!C ; From file STREAM.LISP#> BASIC-FILE; SYS: #10R SYSTEM#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* *COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: BASIC-FILE; STREAM.#" (DEFFLAVOR BASIC-BUFFERED-OUTPUT-STREAM ((STREAM-OUTPUT-BUFFER NIL) (STREAM-OUTPUT-INDEX NIL) STREAM-OUTPUT-LIMIT (Stream-output-byte-limit nil) (last-position-newline 0) ; DAB 12-08-89 The position of the last newline char. Used by read-cursorpos. ) (OUTPUT-STREAM) :GETTABLE-INSTANCE-VARIABLES (:REQUIRED-METHODS :NEW-OUTPUT-BUFFER :SEND-OUTPUT-BUFFER :DISCARD-OUTPUT-BUFFER) (:DOCUMENTATION :COMBINATION "Output stream with a buffer. Only gives a :TYO method. Required methods are :NEW-OUTPUT-BUFFER, which returns three values, an array, starting index, and ending index into which characters can be stuffed and ,optionally, a fourth argument of the minimal number of characters to write back. And :SEND-OUTPUT-BUFFER takes the array and the ending output index reached or the minimal number of characters,whichever is greater, and transmit to the particular device. :DISCARD-OUTPUT-BUFFER takes the array and should forget about sending the buffered data.")) (DEFMETHOD (BASIC-BUFFERED-OUTPUT-STREAM :SEND-CURRENT-OUTPUT-BUFFER) () (COND (STREAM-OUTPUT-BUFFER (when (and (variable-boundp last-position-newline ) ;For compatibility DAB 12-11-89 (stringp STREAM-OUTPUT-BUFFER)) ; DAB 12-08-89 ;;Record the last newline in the buffer so read-cursorpos will work across buffer boundaries. ;;If STREAM-OUTPUT-BUFFER is not a string, then it must be a binary stream, so don;t do this. (setf last-position-newline (POSITION #\NEWLINE (THE STRING STREAM-OUTPUT-BUFFER) ; DAB 12-08-89 :END STREAM-OUTPUT-INDEX :FROM-END T)) (setf last-position-newline (if last-position-newline (- STREAM-OUTPUT-INDEX last-position-newline 1) 0))) (SEND SELF ;; If aborted out of write, prefer losing data to ;; getting links circular. :SEND-OUTPUT-BUFFER (PROG1 STREAM-OUTPUT-BUFFER (SETQ STREAM-OUTPUT-BUFFER ())) STREAM-OUTPUT-INDEX)))) (DEFMETHOD (SYS:BASIC-BUFFERED-OUTPUT-STREAM :READ-CURSORPOS) (&OPTIONAL UNITS) ; DAB 12-08-89 "Reads the current cursor position relative to the last NEWLINE. UNITS much be :CHARACTER. NOTE: The :SET-POINTER operation will reset the position of the last NEWLINE to zero. This may cause a value return from :READ-CURSORPOS to be smaller than what it really is." (UNLESS (EQ UNITS ':CHARACTER) (ERROR "UNITS is ~S; only ~S is meaningful here." UNITS ':CHARACTER)) (IF (NULL STREAM-OUTPUT-BUFFER) ; haven't started writing yet (VALUES 0 0) (unless (stringp STREAM-OUTPUT-BUFFER) (ERROR "~a must be a character stream." self)) (LET ((NX (POSITION #\NEWLINE (THE STRING STREAM-OUTPUT-BUFFER) ; DAB 12-08-89Get the last position :END STREAM-OUTPUT-INDEX :FROM-END T))) (VALUES (IF (NULL NX) ;Last NEWLINE is in previous buffer. ;;last-position-newline is updated in :send-current-output-buffer. (+ STREAM-OUTPUT-INDEX last-position-newline ) (- STREAM-OUTPUT-INDEX NX 1)) 0)))) (DEFMETHOD (SYS:BASIC-BUFFERED-OUTPUT-STREAM :increment-CURSORPOS) (&OPTIONAL (X 0) (y 0) UNITS) ; DAB 12-08-89 "Outputs X spaces from current cursor position." (UNLESS (EQ UNITS ':CHARACTER) (ERROR "UNITS is ~S; only ~S is meaningful here." UNITS ':CHARACTER)) (unless (stringp STREAM-OUTPUT-BUFFER) (ERROR "~a must be a character stream." self)) (UNLESS (EQ Y 0) ; DAB 12-08-89 Y must be ZERO since we only operate in the X-plane. (ERROR "The Y argument must be 0")) (dotimes (xx x) (send self :tyo #\space)) ;Output the SPACES. ) (DEFMETHOD (OUTPUT-POINTER-REMEMBERING-MIXIN :SET-POINTER) (NEW-POINTER) (DO ((BUFFER-RELOADED NIL T)) (()) (LET ((allocated-new-space nil) (NEW-RELATIVE-POINTER (+ (- NEW-POINTER OUTPUT-POINTER-BASE) STREAM-OUTPUT-LOWER-LIMIT))) ;; Does the buffer we have now include the desired pointer? (IF (IF STREAM-OUTPUT-BUFFER (AND (>= NEW-RELATIVE-POINTER STREAM-OUTPUT-LOWER-LIMIT) (< NEW-RELATIVE-POINTER STREAM-OUTPUT-LIMIT)) (= NEW-RELATIVE-POINTER STREAM-OUTPUT-LOWER-LIMIT)) (PROGN (if saved-STREAM-OUTPUT-INDEX ;last pointer in this buffered allocation. (and (> STREAM-OUTPUT-INDEX saved-STREAM-OUTPUT-INDEX) (not (eql saved-relative-pointer stream-output-index)) ;07.15.87 DAB (SETQ saved-STREAM-OUTPUT-INDEX STREAM-OUTPUT-INDEX)) (unless (or (null saved-relative-pointer) (eql saved-relative-pointer stream-output-index)) (SETQ saved-STREAM-OUTPUT-INDEX STREAM-OUTPUT-INDEX))) (SETQ STREAM-OUTPUT-INDEX NEW-RELATIVE-POINTER) (setq saved-relative-pointer new-relative-pointer) (AND BUFFER-RELOADED (send SELF :GET-OLD-DATA STREAM-OUTPUT-BUFFER STREAM-OUTPUT-LOWER-LIMIT)) (when (variable-boundp last-position-newline) ; DAB 12-08-89 Must check , could be an old instance. (setf last-position-newline 0)) ;Set this to 0 for :read-cursorpos (RETURN (+ OUTPUT-POINTER-BASE (IF STREAM-OUTPUT-INDEX (- STREAM-OUTPUT-INDEX STREAM-OUTPUT-LOWER-LIMIT) 0))))) ;; No, get another buffer after specifying where in the file we want. (send SELF :SEND-CURRENT-OUTPUT-BUFFER) (multiple-value-SETQ (OUTPUT-POINTER-BASE allocated-new-space) (send SELF :SET-BUFFER-POINTER NEW-POINTER)) (send SELF :SETUP-NEW-OUTPUT-BUFFER) (when allocated-new-space (setf saved-STREAM-OUTPUT-INDEX nil) (setf Stream-output-byte-limit nil) )))) ))