;;; -*- Mode:LISP; Package:SYSTEM-INTERNALS; Base:8; Readtable:ZL -*- ;;; ** (C) Copyright 1981, Symbolics, Inc. ;;; Enhancements (C) Copyright 1981, Massachusetts Institute of Technology ;;; The Massachusetts Institute of Technology has acquired the rights from Symbolics ;;; to include the Software covered by the foregoing notice of copyright with its ;;; licenses of the Lisp Machine System ** ;;; Flavor basis for streams ;;; To make a buffered stream: ;;; For input, define :NEXT-INPUT-BUFFER &OPTIONAL NO-HANG-P => ARRAY START END ;;; :DISCARD-INPUT-BUFFER ARRAY ;;; For output, define :NEW-OUTPUT-BUFFER => ARRAY START END ;;; :SEND-OUTPUT-BUFFER ARRAY END ;;; :DISCARD-OUTPUT-BUFFER ARRAY ;;; To make :SET-POINTER work, define :SET-BUFFER-POINTER NEW-POINTER => REAL-NEW-POINTER ;;; where REAL-NEW-POINTER should be such that the next :NEXT-INPUT-BUFFER will access the ;;; desired position somewhere in the buffer. ;;; To make binary streams, mix with ;;; for input SI:BUFFERED-INPUT-STREAM ;;; for output SI:BUFFERED-OUTPUT-STREAM ;;; for both SI:BUFFERED-STREAM ;;; To make character streams, mix with ;;; for input SI:BUFFERED-INPUT-CHARACTER-STREAM ;;; for output SI:BUFFERED-OUTPUT-CHARACTER-STREAM ;;; for both SI:BUFFERED-CHARACTER-STREAM ;;; To make a character stream that does character set translation or compression or something ;;; like that, define a wrapper on :TYI (:TYO) that does the translation. Then mix with ;;; for input SI:BUFFERED-TYI-INPUT-STREAM ;;; for output SI:BUFFERED-TYO-OUTPUT-STREAM ;;; for both SI:BUFFERED-TYI-TYO-STREAM ;;; There are mixins in this file (SI:ASCII-TRANSLATING-INPUT-STREAM-MIXIN and ;;; SI:ASCII-TRANSLATING-OUTPUT-STREAM-MIXIN) for translating between ASCII and Lisp ;;; machine character set. ;;; For file streams, the mixin SI:STREAM-WITH-PATHNAME-MIXIN handles the pathname and ;;; printing nicely. Use this for :PROBE openings (since they cannot do I/O). ;;; For input file streams, use SI:INPUT-FILE-STREAM-MIXIN. ;;; For output file streams, use SI:OUTPUT-FILE-STREAM-MIXIN. ;;; These make you interact with the who-line correctly. ;;; Base flavors (DEFFLAVOR STREAM () () (:REQUIRED-METHODS :DIRECTION) (:DOCUMENTATION :BASE-FLAVOR "All streams are built on this. This flavor is mostly for TYPEP, but also provides default methods for messages which all streams, input or output, are required to handle.")) (DEFMETHOD (STREAM :CLOSE) (&OPTIONAL MODE) MODE ;ignored NIL) ;;; Streams are binary until proven otherwise (DEFMETHOD (STREAM :CHARACTERS) () NIL) (DEFMETHOD (STREAM :ELEMENT-TYPE) () (LET ((VALUE (SEND SELF ':SEND-IF-HANDLES ':BYTE-SIZE))) (IF VALUE `(UNSIGNED-BYTE ,VALUE) 'FIXNUM))) (DEFFLAVOR CHARACTER-STREAM () () (:INCLUDED-FLAVORS STREAM)) (DEFMETHOD (CHARACTER-STREAM :CHARACTERS) () T) (DEFMETHOD (CHARACTER-STREAM :ELEMENT-TYPE) () 'CHARACTER) (DEFFLAVOR INPUT-STREAM () (STREAM) (:REQUIRED-METHODS :TYI :UNTYI) (:SELECT-METHOD-ORDER :TYI :UNTYI) (:DOCUMENTATION :BASE-FLAVOR "All input streams are built on this.")) (DEFMETHOD (INPUT-STREAM :DIRECTION) () ':INPUT) (DEFMETHOD (INPUT-STREAM :LISTEN) () (LET ((TEM (FUNCALL-SELF ':TYI-NO-HANG NIL))) (COND (TEM (FUNCALL-SELF ':UNTYI TEM) T)))) (DEFMETHOD (INPUT-STREAM :TYIPEEK) (&OPTIONAL EOF) (LET ((TEM (FUNCALL-SELF ':TYI EOF))) (COND (TEM (FUNCALL-SELF ':UNTYI TEM) TEM)))) (DEFMETHOD (INPUT-STREAM :TYI-NO-HANG) (&OPTIONAL EOF) (SEND SELF ':TYI EOF)) (DEFMETHOD (INPUT-STREAM :ANY-TYI) (&OPTIONAL EOF) (SEND SELF ':TYI EOF)) (DEFMETHOD (INPUT-STREAM :ANY-TYI-NO-HANG) (&OPTIONAL EOF) (SEND SELF ':TYI EOF)) (DEFMETHOD (INPUT-STREAM :CLEAR-INPUT) () NIL) (DEFMETHOD (INPUT-STREAM :READ-UNTIL-EOF) () (LOOP WHILE (FUNCALL-SELF ':TYI))) (DEFMETHOD (INPUT-STREAM :STRING-IN) (EOF STRING &OPTIONAL (START 0) END) (OR END (SETQ END (ARRAY-LENGTH STRING))) (LOOP WHILE (< START END) AS CH = (FUNCALL-SELF ':TYI) WHILE CH DO (ASET CH STRING (PROG1 START (INCF START))) FINALLY (AND (ARRAY-HAS-LEADER-P STRING) (STORE-ARRAY-LEADER START STRING 0)) (AND (NULL CH) EOF (FERROR 'END-OF-FILE-1 "End of file on ~S." SELF)) (RETURN (VALUES START (NULL CH))))) (DEFFLAVOR OUTPUT-STREAM () (STREAM) (:REQUIRED-METHODS :TYO) :ABSTRACT-FLAVOR (:SELECT-METHOD-ORDER :TYO) (:DOCUMENTATION :BASE-FLAVOR "All output streams are built on this.")) (DEFMETHOD (OUTPUT-STREAM :DIRECTION) () ':OUTPUT) (DEFMETHOD (OUTPUT-STREAM :FRESH-LINE) () (FUNCALL-SELF ':TYO #\CR) T) (DEFMETHOD (OUTPUT-STREAM :STRING-OUT) (STRING &OPTIONAL (START 0) END) (OR END (SETQ END (ARRAY-ACTIVE-LENGTH STRING))) (DO ((I START (1+ I))) (( I END)) (FUNCALL-SELF ':TYO (AREF STRING I)))) (DEFMETHOD (OUTPUT-STREAM :CLEAR-OUTPUT) () NIL) (DEFMETHOD (OUTPUT-STREAM :FORCE-OUTPUT) () NIL) (DEFMETHOD (OUTPUT-STREAM :FINISH) () NIL) (DEFMETHOD (OUTPUT-STREAM :BEFORE :FINISH) () (FUNCALL-SELF ':FORCE-OUTPUT)) (DEFMETHOD (OUTPUT-STREAM :EOF) () (FUNCALL-SELF ':FINISH)) (DEFFLAVOR BIDIRECTIONAL-STREAM () () (:INCLUDED-FLAVORS INPUT-STREAM OUTPUT-STREAM)) (DEFMETHOD (BIDIRECTIONAL-STREAM :DIRECTION) () ':BIDIRECTIONAL) ;;; Buffered streams (DEFFLAVOR BASIC-BUFFERED-INPUT-STREAM ((STREAM-INPUT-BUFFER NIL) (STREAM-INPUT-INDEX NIL) STREAM-INPUT-LIMIT) (INPUT-STREAM) :GETTABLE-INSTANCE-VARIABLES (:REQUIRED-METHODS :NEXT-INPUT-BUFFER :DISCARD-INPUT-BUFFER) (:DOCUMENTATION :COMBINATION "Input stream with a buffer. Defines only a :TYI method. Requires methods :NEXT-INPUT-BUFFER, which takes a no hang argument and returns three values, an array, a starting index, and an ending index, or NIL at EOF or no input available right away. And :DISCARD-INPUT-BUFFER takes the array back and throws it away someplace.")) ;;; Returns non-NIL if any input was to be found. (DEFMETHOD (BASIC-BUFFERED-INPUT-STREAM :SETUP-NEXT-INPUT-BUFFER) (&OPTIONAL NO-HANG-P) (FUNCALL-SELF ':DISCARD-CURRENT-INPUT-BUFFER) (MULTIPLE-VALUE (STREAM-INPUT-BUFFER STREAM-INPUT-INDEX STREAM-INPUT-LIMIT) (FUNCALL-SELF ':NEXT-INPUT-BUFFER NO-HANG-P))) (DEFMETHOD (BASIC-BUFFERED-INPUT-STREAM :DISCARD-CURRENT-INPUT-BUFFER) () (COND (STREAM-INPUT-BUFFER ;; Pretend that the index has reached the end, so that input remembering will work. (SETQ STREAM-INPUT-INDEX STREAM-INPUT-LIMIT) (FUNCALL-SELF ':DISCARD-INPUT-BUFFER (PROG1 STREAM-INPUT-BUFFER (SETQ STREAM-INPUT-BUFFER NIL)))))) (DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-BUFFERED-INPUT-STREAM) (DEFUN BASIC-BUFFERED-INPUT-STREAM-TYI (MESSAGE &OPTIONAL EOF) (LOOP UNTIL (AND STREAM-INPUT-BUFFER (< STREAM-INPUT-INDEX STREAM-INPUT-LIMIT)) ;Out of input, get some more UNTIL (FUNCALL-SELF ':SETUP-NEXT-INPUT-BUFFER (EQ MESSAGE ':TYI-NO-HANG)) ;Reached end of file RETURN (AND EOF (FERROR 'SYS:END-OF-FILE-1 "End of file on ~S." SELF)) ;Here we have a character available FINALLY (RETURN (PROG1 (AREF STREAM-INPUT-BUFFER STREAM-INPUT-INDEX) (OR (EQ MESSAGE ':TYIPEEK) (INCF STREAM-INPUT-INDEX)))))) ) (DEFMETHOD (BASIC-BUFFERED-INPUT-STREAM :TYI) BASIC-BUFFERED-INPUT-STREAM-TYI) (DEFMETHOD (BASIC-BUFFERED-INPUT-STREAM :TYI-NO-HANG) BASIC-BUFFERED-INPUT-STREAM-TYI) (DEFMETHOD (BASIC-BUFFERED-INPUT-STREAM :TYIPEEK) BASIC-BUFFERED-INPUT-STREAM-TYI) (DEFMETHOD (BASIC-BUFFERED-INPUT-STREAM :UNTYI) (CH) (LET ((NEW-INDEX (AND STREAM-INPUT-BUFFER (1- STREAM-INPUT-INDEX)))) (COND ((AND NEW-INDEX ( NEW-INDEX 0) (EQ (AREF STREAM-INPUT-BUFFER NEW-INDEX) CH)) (SETQ STREAM-INPUT-INDEX NEW-INDEX)) (T (FERROR NIL "Attempt to :UNTYI something different than last :TYI'ed."))))) (DEFMETHOD (BASIC-BUFFERED-INPUT-STREAM :LISTEN) () (OR (AND STREAM-INPUT-BUFFER (< STREAM-INPUT-INDEX STREAM-INPUT-LIMIT)) (FUNCALL-SELF ':SETUP-NEXT-INPUT-BUFFER T))) (DEFMETHOD (BASIC-BUFFERED-INPUT-STREAM :READ-UNTIL-EOF) () (LOOP WHILE (FUNCALL-SELF ':SETUP-NEXT-INPUT-BUFFER))) (DEFMETHOD (BASIC-BUFFERED-INPUT-STREAM :CLEAR-INPUT) () (FUNCALL-SELF ':DISCARD-CURRENT-INPUT-BUFFER)) (DEFMETHOD (BASIC-BUFFERED-INPUT-STREAM :BEFORE :CLOSE) (&OPTIONAL IGNORE) (FUNCALL-SELF ':DISCARD-CURRENT-INPUT-BUFFER)) (DEFFLAVOR BUFFERED-INPUT-STREAM () (BASIC-BUFFERED-INPUT-STREAM) (:DOCUMENTATION :COMBINATION "Buffered input stream with :READ-INPUT-BUFFER. Usef for all buffered input streams for which :TYI doesn't have wrappers to do translation or such.")) (DEFMETHOD (BUFFERED-INPUT-STREAM :GET-INPUT-BUFFER) (&OPTIONAL EOF) (LOOP UNTIL (AND STREAM-INPUT-BUFFER (< STREAM-INPUT-INDEX STREAM-INPUT-LIMIT)) ;Out of input, get some more UNTIL (FUNCALL-SELF ':SETUP-NEXT-INPUT-BUFFER) ;Reached end of file RETURN (AND EOF (FERROR 'SYS:END-OF-FILE-1 "End of file on ~S." SELF)) ;Here we have a non-empty available FINALLY (RETURN (VALUES STREAM-INPUT-BUFFER STREAM-INPUT-INDEX (- STREAM-INPUT-LIMIT STREAM-INPUT-INDEX))))) (DEFMETHOD (BUFFERED-INPUT-STREAM :READ-INPUT-BUFFER) (&OPTIONAL EOF) (LOOP UNTIL (AND STREAM-INPUT-BUFFER (< STREAM-INPUT-INDEX STREAM-INPUT-LIMIT)) ;Out of input, get some more UNTIL (FUNCALL-SELF ':SETUP-NEXT-INPUT-BUFFER) ;Reached end of file RETURN (AND EOF (FERROR 'SYS:END-OF-FILE-1 "End of file on ~S." SELF)) ;Here we have a non-empty available FINALLY (RETURN (VALUES STREAM-INPUT-BUFFER STREAM-INPUT-INDEX STREAM-INPUT-LIMIT)))) (DEFMETHOD (BUFFERED-INPUT-STREAM :STRING-IN) (EOF STRING &OPTIONAL (START 0) END) (OR END (SETQ END (ARRAY-LENGTH STRING))) (LOOP WHILE (< START END) WHILE (LOOP UNTIL (AND STREAM-INPUT-BUFFER (< STREAM-INPUT-INDEX STREAM-INPUT-LIMIT)) ;Out of input, get some more UNTIL (FUNCALL-SELF ':SETUP-NEXT-INPUT-BUFFER) DO (AND EOF (FERROR 'SYS:END-OF-FILE-1 "End of file on ~S." SELF)) RETURN NIL FINALLY (RETURN T)) AS AMT = (MIN (- END START) (- STREAM-INPUT-LIMIT STREAM-INPUT-INDEX)) DO (COPY-ARRAY-PORTION STREAM-INPUT-BUFFER STREAM-INPUT-INDEX (SETQ STREAM-INPUT-INDEX (+ STREAM-INPUT-INDEX AMT)) STRING START (SETQ START (+ START AMT))) FINALLY (AND (ARRAY-HAS-LEADER-P STRING) (STORE-ARRAY-LEADER START STRING 0)) (RETURN (VALUES START (NULL STREAM-INPUT-BUFFER))))) (DEFMETHOD (BUFFERED-INPUT-STREAM :ADVANCE-INPUT-BUFFER) (&OPTIONAL NEW-INDEX) (COND (NEW-INDEX (OR (AND ( NEW-INDEX 0) ( NEW-INDEX STREAM-INPUT-LIMIT)) (FERROR NIL "New index out of range")) (SETQ STREAM-INPUT-INDEX NEW-INDEX)) (T (FUNCALL-SELF ':DISCARD-CURRENT-INPUT-BUFFER)))) (DEFFLAVOR BASIC-BUFFERED-OUTPUT-STREAM ((STREAM-OUTPUT-BUFFER NIL) (STREAM-OUTPUT-INDEX NIL) STREAM-OUTPUT-LIMIT) (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 :SEND-OUTPUT-BUFFER takes the array and the ending output index reached, 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 :SETUP-NEW-OUTPUT-BUFFER) () (FUNCALL-SELF ':SEND-CURRENT-OUTPUT-BUFFER) (MULTIPLE-VALUE (STREAM-OUTPUT-BUFFER STREAM-OUTPUT-INDEX STREAM-OUTPUT-LIMIT) (FUNCALL-SELF ':NEW-OUTPUT-BUFFER))) (DEFMETHOD (BASIC-BUFFERED-OUTPUT-STREAM :SEND-CURRENT-OUTPUT-BUFFER) () (COND (STREAM-OUTPUT-BUFFER (FUNCALL-SELF ':SEND-OUTPUT-BUFFER ;; If aborted out of write, prefer losing data to ;; getting links circular. (PROG1 STREAM-OUTPUT-BUFFER (SETQ STREAM-OUTPUT-BUFFER NIL)) STREAM-OUTPUT-INDEX)))) (DEFMETHOD (BASIC-BUFFERED-OUTPUT-STREAM :DISCARD-CURRENT-OUTPUT-BUFFER) () (AND STREAM-OUTPUT-BUFFER (FUNCALL-SELF ':DISCARD-OUTPUT-BUFFER (PROG1 STREAM-OUTPUT-BUFFER (SETQ STREAM-OUTPUT-BUFFER NIL))))) (DEFMETHOD (BASIC-BUFFERED-OUTPUT-STREAM :TYO) (CH) (LOOP UNTIL (AND STREAM-OUTPUT-BUFFER (< STREAM-OUTPUT-INDEX STREAM-OUTPUT-LIMIT)) DO (FUNCALL-SELF ':SETUP-NEW-OUTPUT-BUFFER) FINALLY (ASET CH STREAM-OUTPUT-BUFFER STREAM-OUTPUT-INDEX) (INCF STREAM-OUTPUT-INDEX))) (DEFMETHOD (BASIC-BUFFERED-OUTPUT-STREAM :PAD-AND-SEND-BUFFER) (&OPTIONAL (PAD 0) (modulo stream-output-limit)) (WHEN STREAM-OUTPUT-BUFFER (let ((pad-limit (* modulo (1+ (floor stream-output-index modulo))))) (ARRAY-INITIALIZE STREAM-OUTPUT-BUFFER PAD STREAM-OUTPUT-INDEX pad-limit) (SETQ STREAM-OUTPUT-INDEX pad-limit) (SEND SELF :SEND-CURRENT-OUTPUT-BUFFER)))) (DEFMETHOD (BASIC-BUFFERED-OUTPUT-STREAM :FORCE-OUTPUT) () (FUNCALL-SELF ':SEND-CURRENT-OUTPUT-BUFFER)) (DEFMETHOD (BASIC-BUFFERED-OUTPUT-STREAM :BEFORE :CLOSE) (&OPTIONAL ABORTP) (FUNCALL-SELF (IF ABORTP ':DISCARD-CURRENT-OUTPUT-BUFFER ':SEND-CURRENT-OUTPUT-BUFFER))) (DEFMETHOD (BASIC-BUFFERED-OUTPUT-STREAM :LAST-CHAR-OUTPUT) () (AND STREAM-OUTPUT-BUFFER (PLUSP STREAM-OUTPUT-INDEX) (AREF STREAM-OUTPUT-BUFFER (1- STREAM-OUTPUT-INDEX)))) (DEFFLAVOR BUFFERED-OUTPUT-STREAM () (BUFFERED-OUTPUT-STREAM-MIXIN BASIC-BUFFERED-OUTPUT-STREAM) (:DOCUMENTATION :COMBINATION "Buffered output stream with :STRING-OUT. Should be used for all output streams which do not have wrappers on :TYO to do translation or such like.")) (DEFFLAVOR BUFFERED-OUTPUT-STREAM-MIXIN () () (:REQUIRED-FLAVORS BASIC-BUFFERED-OUTPUT-STREAM)) (DEFMETHOD (BUFFERED-OUTPUT-STREAM-MIXIN :STRING-OUT) (STRING &OPTIONAL (START 0) END) (OR END (SETQ END (ARRAY-ACTIVE-LENGTH STRING))) (LOOP WHILE (< START END) UNLESS STREAM-OUTPUT-BUFFER DO (FUNCALL-SELF ':SETUP-NEW-OUTPUT-BUFFER) AS AMT = (MIN (- END START) (- STREAM-OUTPUT-LIMIT STREAM-OUTPUT-INDEX)) DO (COPY-ARRAY-PORTION STRING START (SETQ START (+ START AMT)) STREAM-OUTPUT-BUFFER STREAM-OUTPUT-INDEX (SETQ STREAM-OUTPUT-INDEX (+ STREAM-OUTPUT-INDEX AMT))) WHEN (< START END) DO (FUNCALL-SELF ':SEND-CURRENT-OUTPUT-BUFFER))) ;; Since this stream has enough knowledge to execute this message intelligently, let it. ;; Note that this message can't go in BASIC-BUFFERED-OUTPUT-STREAM, because wrappers may ;; be defined on :TYO messages which would cause it to lose. (DEFMETHOD (BUFFERED-OUTPUT-STREAM-MIXIN :FRESH-LINE) () (IF (CHAR-EQUAL #\CR (OR (FUNCALL-SELF ':LAST-CHAR-OUTPUT) 0)) NIL (FUNCALL-SELF ':TYO #\CR) T)) ; LINE input and output ; This comes in two different flavors, depending on whether the stream is buffered ; or unbuffered (DEFFLAVOR UNBUFFERED-LINE-INPUT-STREAM () (CHARACTER-STREAM INPUT-STREAM) (:DOCUMENTATION :COMBINATION "Input stream with :LINE-IN but no buffering. Used with input streams which only support :TYI.")) (DEFMETHOD (UNBUFFERED-LINE-INPUT-STREAM :STRING-LINE-IN) (EOF STRING &OPTIONAL (START 0) END) (OR END (SETQ END (ARRAY-LENGTH STRING))) (LOOP WHILE (< START END) AS CH = (FUNCALL-SELF ':TYI) WHILE (AND CH (NEQ CH #\RETURN)) DO (ASET CH STRING (PROG1 START (INCF START))) FINALLY (AND (ARRAY-HAS-LEADER-P STRING) (STORE-ARRAY-LEADER START STRING 0)) (AND (NULL CH) EOF (FERROR 'END-OF-FILE-1 "End of file on ~S." SELF)) (RETURN (VALUES START (NULL CH) (NEQ CH #\RETURN))))) (DEFMETHOD (UNBUFFERED-LINE-INPUT-STREAM :LINE-IN) (&OPTIONAL LEADER) (LOOP WITH LENGTH-SO-FAR = 0 AND LINE = (MAKE-ARRAY 80 ':TYPE 'ART-STRING ':LEADER-LENGTH (AND (NUMBERP LEADER) LEADER)) AS CH = (FUNCALL-SELF ':TYI) UNTIL (NULL CH) ;i.e. EOF UNTIL (= CH #\CR) ;We have an ordinary character, stick it on the end of the line WHEN ( LENGTH-SO-FAR (ARRAY-LENGTH LINE)) DO (SETQ LINE (ADJUST-ARRAY-SIZE LINE (FLOOR (* LENGTH-SO-FAR 3) 2))) DO (ASET CH LINE LENGTH-SO-FAR) (INCF LENGTH-SO-FAR) FINALLY ;Adjust size and active-length of line (ADJUST-ARRAY-SIZE LINE LENGTH-SO-FAR) (IF (ARRAY-HAS-LEADER-P LINE) (STORE-ARRAY-LEADER LENGTH-SO-FAR LINE 0)) (RETURN (VALUES LINE (NULL CH))))) (DEFFLAVOR LINE-OUTPUT-STREAM-MIXIN () () (:REQUIRED-METHODS :STRING-OUT) (:INCLUDED-FLAVORS CHARACTER-STREAM OUTPUT-STREAM) (:DOCUMENTATION :MIXIN "Output stream with :LINE-OUT. Used for buffered and unbuffered streams.")) (DEFMETHOD (LINE-OUTPUT-STREAM-MIXIN :LINE-OUT) (LINE &OPTIONAL (START 0) END) (FUNCALL-SELF ':STRING-OUT LINE START END) (FUNCALL-SELF ':TYO #\CR)) (DEFFLAVOR BUFFERED-LINE-INPUT-STREAM () (CHARACTER-STREAM BUFFERED-INPUT-STREAM) (:DOCUMENTATION :COMBINATION "Input stream with buffering and :LINE-IN.")) (COMMENT (DEFMETHOD (BUFFERED-LINE-INPUT-STREAM :LINE-IN) (&OPTIONAL LEADER) (LOOP WITH LENGTH-SO-FAR = 0 AND LINE = (MAKE-ARRAY 80 ':TYPE 'ART-STRING ':LEADER-LENGTH (AND (NUMBERP LEADER) LEADER)) UNLESS (AND STREAM-INPUT-BUFFER (< STREAM-INPUT-INDEX STREAM-INPUT-LIMIT)) ;Out of buffer, get another one DO (FUNCALL-SELF ':SETUP-NEXT-INPUT-BUFFER) UNTIL (NULL STREAM-INPUT-BUFFER) ;i.e. EOF ;We have a non-empty buffer, search for CR in it AS CR-IDX = (%STRING-SEARCH-CHAR #\CR STREAM-INPUT-BUFFER STREAM-INPUT-INDEX STREAM-INPUT-LIMIT) AS AMT = (- (OR CR-IDX STREAM-INPUT-LIMIT) STREAM-INPUT-INDEX) ;Nconc this many characters onto the end of the line WHEN (> (+ AMT LENGTH-SO-FAR) (ARRAY-LENGTH LINE)) DO (SETQ LINE (ADJUST-ARRAY-SIZE LINE (+ AMT LENGTH-SO-FAR))) DO (COPY-ARRAY-PORTION STREAM-INPUT-BUFFER STREAM-INPUT-INDEX (SETQ STREAM-INPUT-INDEX (+ STREAM-INPUT-INDEX AMT)) LINE LENGTH-SO-FAR (SETQ LENGTH-SO-FAR (+ LENGTH-SO-FAR AMT))) UNTIL CR-IDX ;i.e. until we saw a CR FINALLY ;If we terminated with a CR, advance over it (IF STREAM-INPUT-BUFFER (INCF STREAM-INPUT-INDEX)) ;Adjust size and active-length of line (ADJUST-ARRAY-SIZE LINE LENGTH-SO-FAR) (IF (ARRAY-HAS-LEADER-P LINE) (STORE-ARRAY-LEADER LENGTH-SO-FAR LINE 0)) (RETURN (VALUES LINE (NULL STREAM-INPUT-BUFFER))))) );COMMENT (DEFMETHOD (BUFFERED-LINE-INPUT-STREAM :STRING-LINE-IN) (EOF STRING &OPTIONAL (START 0) END) (OR END (SETQ END (ARRAY-LENGTH STRING))) (LOOP WHILE (< START END) WHILE (LOOP UNTIL (AND STREAM-INPUT-BUFFER (< STREAM-INPUT-INDEX STREAM-INPUT-LIMIT)) ;Out of input, get some more UNTIL (FUNCALL-SELF ':SETUP-NEXT-INPUT-BUFFER) DO (AND EOF (FERROR 'SYS:END-OF-FILE-1 "End of file on ~S." SELF)) RETURN NIL FINALLY (RETURN T)) AS LINE-END-INDEX = (%STRING-SEARCH-CHAR #\RETURN STREAM-INPUT-BUFFER STREAM-INPUT-INDEX STREAM-INPUT-LIMIT) AS AMT = (MIN (- END START) (- (OR LINE-END-INDEX STREAM-INPUT-LIMIT) STREAM-INPUT-INDEX)) DO (COPY-ARRAY-PORTION STREAM-INPUT-BUFFER STREAM-INPUT-INDEX (SETQ STREAM-INPUT-INDEX (+ STREAM-INPUT-INDEX AMT)) STRING START (SETQ START (+ START AMT))) (WHEN (EQ STREAM-INPUT-INDEX LINE-END-INDEX) (INCF STREAM-INPUT-INDEX) (RETURN (VALUES START NIL NIL))) FINALLY (AND (ARRAY-HAS-LEADER-P STRING) (STORE-ARRAY-LEADER START STRING 0)) (RETURN (VALUES START (NULL STREAM-INPUT-BUFFER) T)))) (DEFMETHOD (BUFFERED-LINE-INPUT-STREAM :LINE-IN) (&OPTIONAL LEADER) (LOOP NAMED LINE-IN ;; STRING is not made until needed to avoid calling ADJUST-ARRAY-SIZE except when ;; strings cross buffer boundaries. WITH STRING = NIL AND STRING-INDEX = 0 DO (LOOP UNTIL (AND STREAM-INPUT-BUFFER (< STREAM-INPUT-INDEX STREAM-INPUT-LIMIT)) ;Out of input, get some more UNTIL (FUNCALL-SELF ':SETUP-NEXT-INPUT-BUFFER) ;EOF if none that way WHEN (NULL STRING) DO (SETQ STRING (MAKE-ARRAY STRING-INDEX ':TYPE 'ART-STRING ':LEADER-LENGTH (AND (NUMBERP LEADER) LEADER))) WHEN (NUMBERP LEADER) DO (STORE-ARRAY-LEADER STRING-INDEX STRING 0) DO (RETURN-FROM LINE-IN (VALUES STRING T))) ;; Now see if this buffer has a CR, and copy out the appropriate amount AS CR-INDEX = (%STRING-SEARCH-CHAR #\CR STREAM-INPUT-BUFFER STREAM-INPUT-INDEX STREAM-INPUT-LIMIT) WITH NEW-STRING-INDEX AND NEW-BUFFER-INDEX WHEN (NOT (NULL CR-INDEX)) ; WHEN (AND (NULL STRING) (NULL LEADER)) ; DO (SETQ STRING (LET ((ARRAY STREAM-INPUT-BUFFER) ; (OFFSET STREAM-INPUT-INDEX)) ; (AND (ARRAY-INDEXED-P ARRAY) ; (SETQ OFFSET (+ OFFSET (%P-CONTENTS-OFFSET ARRAY 3)) ; ARRAY (%P-CONTENTS-OFFSET ARRAY 1))) ; (MAKE-ARRAY (- CR-INDEX STREAM-INPUT-INDEX) ; ':TYPE 'ART-STRING ; ':DISPLACED-TO ARRAY ; ':DISPLACED-INDEX-OFFSET OFFSET)) ; STREAM-INPUT-INDEX (1+ CR-INDEX)) ; (RETURN (VALUES STRING NIL)) ; ELSE DO (SETQ NEW-BUFFER-INDEX (1+ CR-INDEX) NEW-STRING-INDEX (+ STRING-INDEX (- CR-INDEX STREAM-INPUT-INDEX))) ELSE DO (SETQ NEW-BUFFER-INDEX STREAM-INPUT-LIMIT NEW-STRING-INDEX (+ STRING-INDEX (- STREAM-INPUT-LIMIT STREAM-INPUT-INDEX))) WHEN (NULL STRING) ;;Make a string to return or save the end of this packet in. DO (SETQ STRING (MAKE-ARRAY NEW-STRING-INDEX ':TYPE 'ART-STRING ':LEADER-LENGTH (AND (NUMBERP LEADER) LEADER))) ;;Was some stuff from previous packet, make room. ELSE DO (ADJUST-ARRAY-SIZE STRING NEW-STRING-INDEX) DO (COPY-ARRAY-PORTION STREAM-INPUT-BUFFER STREAM-INPUT-INDEX NEW-BUFFER-INDEX STRING STRING-INDEX NEW-STRING-INDEX) (SETQ STREAM-INPUT-INDEX NEW-BUFFER-INDEX STRING-INDEX NEW-STRING-INDEX) WHEN (NOT (NULL CR-INDEX)) ;This buffer is enough to satisfy DO (AND (NUMBERP LEADER) (STORE-ARRAY-LEADER STRING-INDEX STRING 0)) (RETURN (VALUES STRING NIL)))) ;;; Less basic stream flavors (DEFFLAVOR ASCII-TRANSLATING-INPUT-STREAM-MIXIN () () (:REQUIRED-METHODS :TYI) (:INCLUDED-FLAVORS INPUT-STREAM) (:DOCUMENTATION :MIXIN "An input stream that translates characters from ASCII into lisp machine character set for :TYI method.")) (DEFWRAPPER (ASCII-TRANSLATING-INPUT-STREAM-MIXIN :TYI) (IGNORE . BODY) `(PROGN .DAEMON-CALLER-ARGS. ;Prevent compiler warnings (TYI-FROM-ASCII-STREAM #'(LAMBDA (&REST .DAEMON-CALLER-ARGS. &AUX (.DAEMON-MAPPING-TABLE. SELF-MAPPING-TABLE)) .DAEMON-MAPPING-TABLE. . ,BODY)))) (DEFUN TYI-FROM-ASCII-STREAM (ASCII-STREAM &AUX CH) (SELECTQ (SETQ CH (FUNCALL ASCII-STREAM ':TYI)) (10 #\BS) (11 #\TAB) (12 #\LINE) (14 #\FF) (15 (LET ((CH1 (FUNCALL ASCII-STREAM ':TYI))) (OR (= CH1 12) (FUNCALL ASCII-STREAM ':UNTYI CH1))) #\CR) (177 #\RUBOUT) (T CH))) (DEFFLAVOR ASCII-TRANSLATING-OUTPUT-STREAM-MIXIN () () (:REQUIRED-METHODS :TYO) (:INCLUDED-FLAVORS OUTPUT-STREAM) (:DOCUMENTATION :MIXIN "An output stream that translates characters from lisp machine character set into ASCII for :TYO method.")) (DEFWRAPPER (ASCII-TRANSLATING-OUTPUT-STREAM-MIXIN :TYO) ((CH) . BODY) `(TYO-TO-ASCII-STREAM #'(LAMBDA (&REST .DAEMON-CALLER-ARGS. &AUX (.DAEMON-MAPPING-TABLE. SELF-MAPPING-TABLE)) .DAEMON-MAPPING-TABLE. . ,BODY) CH)) (DEFUN TYO-TO-ASCII-STREAM (ASCII-STREAM CH) (FUNCALL ASCII-STREAM ':TYO (SELECTQ CH (#\BS 10) (#\TAB 11) (#\LINE 12) (#\FF 14) (#\CR (FUNCALL ASCII-STREAM ':TYO 15) 12) (#\RUBOUT 177) (T CH)))) (DEFFLAVOR INPUT-POINTER-REMEMBERING-MIXIN ((INPUT-POINTER-BASE 0) (STREAM-INPUT-LOWER-LIMIT 0)) () (:INCLUDED-FLAVORS BASIC-BUFFERED-INPUT-STREAM) ;; :SET-BUFFER-POINTER is sent when a :SET-POINTER request goes beyond the current buffer. ;; It should return the real position set and arrange for the next :NEXT-INPUT-BUFFER ;; to contain the desired position in it someplace. (:REQUIRED-METHODS :SET-BUFFER-POINTER) (:DOCUMENTATION :MIXIN "Buffered input stream with :SET-POINTER and :READ-POINTER methods." )) (DEFMETHOD (INPUT-POINTER-REMEMBERING-MIXIN :SET-BUFFER-POINTER) (NEW-POINTER) (FERROR NIL "Cannot set pointer on ~S to ~D" SELF NEW-POINTER)) ;;; Obsolete shorthand message, but in the manual, so keep for a while. (DEFMETHOD (INPUT-POINTER-REMEMBERING-MIXIN :REWIND) () (FUNCALL-SELF ':SET-POINTER 0)) (DEFMETHOD (INPUT-POINTER-REMEMBERING-MIXIN :SET-POINTER) (NEW-POINTER) (LET ((LEN (FUNCALL-SELF :LENGTH))) (COND ((KEYWORDP NEW-POINTER) (CASE NEW-POINTER (:START (SETQ NEW-POINTER 0)) (:END (SETQ NEW-POINTER LEN)) (T (FERROR NIL "~s is not a recognized keyword." NEW-POINTER)))) ((CHECK-TYPE NEW-POINTER INTEGER)) ((MINUSP NEW-POINTER) (FERROR NIL "Negative file pointers are not allowed.")) ((> NEW-POINTER LEN) (FERROR NIL "New file pointer, ~d, is beyond end of file, ~d." NEW-POINTER LEN)))) (LOOP AS NEW-RELATIVE-POINTER = (+ (- NEW-POINTER INPUT-POINTER-BASE) STREAM-INPUT-LOWER-LIMIT) WHEN (AND STREAM-INPUT-INDEX (= NEW-RELATIVE-POINTER STREAM-INPUT-INDEX)) RETURN T ;Fast check UNTIL (IF STREAM-INPUT-BUFFER (AND ( NEW-RELATIVE-POINTER STREAM-INPUT-LOWER-LIMIT) (< NEW-RELATIVE-POINTER STREAM-INPUT-LIMIT)) (= NEW-RELATIVE-POINTER STREAM-INPUT-LOWER-LIMIT)) DO (FUNCALL-SELF :DISCARD-CURRENT-INPUT-BUFFER) (SETQ INPUT-POINTER-BASE (FUNCALL-SELF :SET-BUFFER-POINTER NEW-POINTER)) (FUNCALL-SELF :SETUP-NEXT-INPUT-BUFFER) FINALLY (PROGN (SETQ STREAM-INPUT-INDEX NEW-RELATIVE-POINTER) (RETURN T)))) (DEFMETHOD (INPUT-POINTER-REMEMBERING-MIXIN :BEFORE :DISCARD-INPUT-BUFFER) (IGNORE) (INCF INPUT-POINTER-BASE (- STREAM-INPUT-INDEX STREAM-INPUT-LOWER-LIMIT)) (SETQ STREAM-INPUT-LOWER-LIMIT STREAM-INPUT-INDEX)) (DEFMETHOD (INPUT-POINTER-REMEMBERING-MIXIN :AFTER :SETUP-NEXT-INPUT-BUFFER) (&OPTIONAL IGNORE) (AND STREAM-INPUT-BUFFER (SETQ STREAM-INPUT-LOWER-LIMIT STREAM-INPUT-INDEX))) (DEFMETHOD (INPUT-POINTER-REMEMBERING-MIXIN :READ-POINTER) () (+ INPUT-POINTER-BASE (IF STREAM-INPUT-INDEX (- STREAM-INPUT-INDEX STREAM-INPUT-LOWER-LIMIT) 0))) (DEFFLAVOR OUTPUT-POINTER-REMEMBERING-MIXIN ((OUTPUT-POINTER-BASE 0) (STREAM-OUTPUT-LOWER-LIMIT 0) (STREAM-OUTPUT-LIMIT-LAST-BLOCK-SIZE 0)) () (:SETTABLE-INSTANCE-VARIABLES OUTPUT-POINTER-BASE) (:INCLUDED-FLAVORS BASIC-BUFFERED-OUTPUT-STREAM) (:DOCUMENTATION :MIXIN "Buffered output stream with :READ-POINTER method.")) (DEFMETHOD (OUTPUT-POINTER-REMEMBERING-MIXIN :SETUP-NEXT-OUTPUT-BUFFER) () (FUNCALL-SELF :SETUP-NEW-OUTPUT-BUFFER) (SETQ OUTPUT-POINTER-BASE (FUNCALL-SELF :BYTES-BEFORE-CURRENT-BLOCK))) (DEFMETHOD (OUTPUT-POINTER-REMEMBERING-MIXIN :SETUP-NEW-OUTPUT-BUFFER) () (LET ((OLD-MAP-SIZE (SEND-IF-HANDLES SELF :MAP-NBLOCKS))) (FUNCALL-SELF :SEND-CURRENT-OUTPUT-BUFFER) (MULTIPLE-VALUE (STREAM-OUTPUT-BUFFER STREAM-OUTPUT-INDEX STREAM-OUTPUT-LIMIT) (FUNCALL-SELF :NEW-OUTPUT-BUFFER)) (WHEN (TYPEP SELF 'FS:MAP-OUTPUT-STREAM-MIXIN) (LET ((NEW-MAP-SIZE (FUNCALL-SELF :MAP-NBLOCKS)) (NEW-LAST-BLOCK-P (FUNCALL-SELF :LAST-BLOCK-P))) (WHEN NEW-LAST-BLOCK-P (IF (OR (> NEW-MAP-SIZE OLD-MAP-SIZE) (ZEROP STREAM-OUTPUT-LIMIT-LAST-BLOCK-SIZE)) (SETQ STREAM-OUTPUT-LIMIT-LAST-BLOCK-SIZE STREAM-OUTPUT-LIMIT) ;NEW LAST BLOCK (SETQ STREAM-OUTPUT-LIMIT STREAM-OUTPUT-LIMIT-LAST-BLOCK-SIZE) ;RE-ENTERED LAST BLOCK (FUNCALL-SELF :UPDATE-RQB-VALID-PAGES STREAM-OUTPUT-LIMIT)))))) STREAM-OUTPUT-BUFFER) ; ASSUMES PRESENCE OF MAP-OUTPUT-STREAM-MIXIN, LM-DATA-STREAM-MIXIN ; CALLED BY (LM-OUTPUT-STREAM-MIXIN :AFTER :INIT), ; (OUTPUT-POINTER-REMEMBERING-MIXIN :SET-POINTER) (DEFMETHOD (OUTPUT-POINTER-REMEMBERING-MIXIN :SETUP-BUFFER-FOR-APPEND) () (COND ((NULL (FUNCALL-SELF :SET-MAP-FOR-APPEND)) ; FILE IS EMPTY (FUNCALL-SELF :SETUP-NEW-OUTPUT-BUFFER) (SETQ STREAM-OUTPUT-LIMIT STREAM-OUTPUT-LIMIT-LAST-BLOCK-SIZE) (SETQ OUTPUT-POINTER-BASE 0)) (T (LET ((OLD-MAX-BYTES-LAST-BLOCK (FUNCALL-SELF :MAX-BYTES-IN-BLOCK)) (OLD-BYTES-IN-LAST-BLOCK (FUNCALL-SELF :BYTES-IN-BLOCK))) (FUNCALL-SELF :SET-MAP-FOR-APPEND (= OLD-MAX-BYTES-LAST-BLOCK OLD-BYTES-IN-LAST-BLOCK)) (FUNCALL-SELF :SETUP-NEW-OUTPUT-BUFFER) (LET ((NEW-MAX-BYTES-LAST-BLOCK (FUNCALL-SELF :MAX-BYTES-IN-BLOCK)) (NEW-BYTES-IN-LAST-BLOCK (FUNCALL-SELF :BYTES-IN-BLOCK))) (SETQ OUTPUT-POINTER-BASE (FUNCALL-SELF :SET-BUFFER-POINTER-TO-END)) (SETQ STREAM-OUTPUT-LIMIT-LAST-BLOCK-SIZE NEW-MAX-BYTES-LAST-BLOCK) (SETQ STREAM-OUTPUT-LIMIT STREAM-OUTPUT-LIMIT-LAST-BLOCK-SIZE) (SETQ STREAM-OUTPUT-INDEX NEW-BYTES-IN-LAST-BLOCK)))))) (DEFMETHOD (OUTPUT-POINTER-REMEMBERING-MIXIN :BEFORE :SEND-OUTPUT-BUFFER) (IGNORE IGNORE) (INCF OUTPUT-POINTER-BASE (- STREAM-OUTPUT-INDEX STREAM-OUTPUT-LOWER-LIMIT)) (SETQ STREAM-OUTPUT-LOWER-LIMIT STREAM-OUTPUT-INDEX)) (DEFMETHOD (OUTPUT-POINTER-REMEMBERING-MIXIN :AFTER :SETUP-NEW-OUTPUT-BUFFER) () (SETQ STREAM-OUTPUT-LOWER-LIMIT STREAM-OUTPUT-INDEX)) (DEFMETHOD (OUTPUT-POINTER-REMEMBERING-MIXIN :READ-POINTER) () (+ OUTPUT-POINTER-BASE (IF STREAM-OUTPUT-INDEX (- STREAM-OUTPUT-INDEX STREAM-OUTPUT-LOWER-LIMIT) 0))) ;; NOT FOR QFILE OUTPUT STREAMS (DEFMETHOD (OUTPUT-POINTER-REMEMBERING-MIXIN :SET-POINTER) (NEW-POINTER &AUX TO-END) (LET ((ACTIVE-LENGTH (FUNCALL-SELF :LENGTH))) (COND ((KEYWORDP NEW-POINTER) (CASE NEW-POINTER (:START (SETQ NEW-POINTER 0)) (:END (SETQ TO-END T) (SETQ NEW-POINTER ACTIVE-LENGTH)) (T (FERROR NIL "~s is not a recognized keyword." NEW-POINTER)))) ((CHECK-TYPE NEW-POINTER INTEGER)) ((MINUSP NEW-POINTER) (FERROR NIL "Negative file pointers are not allowed.")) ((> NEW-POINTER ACTIVE-LENGTH) (FERROR NIL "New file pointer, ~d, is beyond end of file, ~d." new-pointer active-length)) ((= NEW-POINTER ACTIVE-LENGTH) (SETQ TO-END T)))) (LOOP (LET ((NEW-RELATIVE-POINTER (+ (- NEW-POINTER OUTPUT-POINTER-BASE) STREAM-OUTPUT-LOWER-LIMIT))) ;; Does the buffer we have now include the desired pointer? (WHEN (IF STREAM-OUTPUT-BUFFER (AND (NOT (MINUSP NEW-RELATIVE-POINTER)) ;NECESSARY? ( NEW-RELATIVE-POINTER STREAM-OUTPUT-LOWER-LIMIT) (< NEW-RELATIVE-POINTER STREAM-OUTPUT-LIMIT)) (= NEW-RELATIVE-POINTER STREAM-OUTPUT-LOWER-LIMIT)) (SETQ STREAM-OUTPUT-INDEX NEW-RELATIVE-POINTER) (RETURN T))) ;; No, get another buffer after specifying where in the file we want. (FUNCALL-SELF :SEND-CURRENT-OUTPUT-BUFFER) (COND (TO-END (FUNCALL-SELF :SETUP-BUFFER-FOR-APPEND)) (T (SETQ OUTPUT-POINTER-BASE (FUNCALL-SELF :SET-BUFFER-POINTER NEW-POINTER)) (FUNCALL-SELF :SETUP-NEW-OUTPUT-BUFFER))))) ;; [QFILE-OUTPUT-CHARACTER-STREAM USES ;; OUTPUT-POINTER-REMEMBERING-MIXIN, NOT MAP-OUTPUT-STREAM-MIXIN.] (DEFMETHOD (OUTPUT-POINTER-REMEMBERING-MIXIN :BEFORE :CLOSE) (&optional abortp) ABORTP (AND (TYPEP SELF 'FS:MAP-OUTPUT-STREAM-MIXIN) STREAM-OUTPUT-BUFFER (FUNCALL-SELF :MAYBE-UPDATE-MAP-BLOCK-SIZE stream-output-index))) (DEFMETHOD (OUTPUT-POINTER-REMEMBERING-MIXIN :DEFAULT :GET-OLD-DATA) (BUFFER-ARRAY OUTPUT-LOWER-LIMIT) BUFFER-ARRAY OUTPUT-LOWER-LIMIT NIL) ;;; Some useful combinations (DEFFLAVOR BUFFERED-INPUT-CHARACTER-STREAM () (INPUT-POINTER-REMEMBERING-MIXIN BUFFERED-LINE-INPUT-STREAM) (:DOCUMENTATION :COMBINATION "A buffered input character stream, gives :LINE-IN.")) (DEFFLAVOR BUFFERED-OUTPUT-CHARACTER-STREAM () (LINE-OUTPUT-STREAM-MIXIN CHARACTER-STREAM BUFFERED-OUTPUT-STREAM) (:DOCUMENTATION :COMBINATION "A buffered output character stream, gives :LINE-OUT.")) (DEFFLAVOR BUFFERED-CHARACTER-STREAM () (BIDIRECTIONAL-STREAM INPUT-POINTER-REMEMBERING-MIXIN BUFFERED-LINE-INPUT-STREAM LINE-OUTPUT-STREAM-MIXIN BUFFERED-OUTPUT-STREAM) (:DOCUMENTATION :COMBINATION "A bidrection character stream, :LINE-IN and :LINE-OUT.")) (DEFFLAVOR BUFFERED-STREAM () (BIDIRECTIONAL-STREAM BUFFERED-INPUT-STREAM BUFFERED-OUTPUT-STREAM) (:DOCUMENTATION :COMBINATION "A bidirection buffered stream.")) (DEFFLAVOR BUFFERED-TYI-INPUT-STREAM () (INPUT-POINTER-REMEMBERING-MIXIN UNBUFFERED-LINE-INPUT-STREAM BASIC-BUFFERED-INPUT-STREAM) (:DOCUMENTATION :COMBINATION "A buffered character input stream for use with :TYI wrappers.")) (DEFFLAVOR BUFFERED-TYO-OUTPUT-STREAM () (LINE-OUTPUT-STREAM-MIXIN CHARACTER-STREAM BASIC-BUFFERED-OUTPUT-STREAM) (:DOCUMENTATION :COMBINATION "A buffered character output stream for use with :TYO wrappers.")) (DEFFLAVOR BUFFERED-TYI-TYO-STREAM () (BIDIRECTIONAL-STREAM INPUT-POINTER-REMEMBERING-MIXIN UNBUFFERED-LINE-INPUT-STREAM BASIC-BUFFERED-INPUT-STREAM LINE-OUTPUT-STREAM-MIXIN BASIC-BUFFERED-OUTPUT-STREAM) (:DOCUMENTATION :COMBINATION "A bidirectional buffered character stream, for use with :TYI and :TYO wrappers.")) ;;; Flavors for use with file computers ;;; For use with :PROBE OPEN calls (DEFFLAVOR FILE-STREAM-MIXIN (PATHNAME) () (:INCLUDED-FLAVORS STREAM) (:REQUIRED-METHODS :TRUENAME :PLIST) (:INITABLE-INSTANCE-VARIABLES PATHNAME) (:GETTABLE-INSTANCE-VARIABLES PATHNAME) (:DOCUMENTATION :MIXIN "Streams for use with file computers, as returned by OPEN.")) (DEFMETHOD (FILE-STREAM-MIXIN :PRINT-SELF) (STREAM IGNORE IGNORE) (SI:PRINTING-RANDOM-OBJECT (SELF STREAM :TYPEP) (PRIN1 (STRING PATHNAME) STREAM))) (DEFMETHOD (FILE-STREAM-MIXIN :GET) (INDICATOR &OPTIONAL DEFAULT) (LET ((PLIST (SEND SELF :PLIST))) (GET (LOCF PLIST) INDICATOR DEFAULT))) (DEFMETHOD (FILE-STREAM-MIXIN :CREATION-DATE) () (FUNCALL-SELF ':GET ':CREATION-DATE)) (DEFMETHOD (FILE-STREAM-MIXIN :INFO) () (CONS (FUNCALL-SELF ':TRUENAME) (FUNCALL-SELF ':CREATION-DATE))) (DEFMETHOD (FILE-STREAM-MIXIN :GENERIC-PATHNAME) () (FUNCALL PATHNAME ':GENERIC-PATHNAME)) ;;; For use with :READ and :WRITE OPEN calls (DEFFLAVOR FILE-DATA-STREAM-MIXIN () (FILE-STREAM-MIXIN) (:INCLUDED-FLAVORS STREAM) (:REQUIRED-METHODS :READ-POINTER :LENGTH :QFASLP) (:DOCUMENTATION :MIXIN "Streams which can actually do file I/O.")) (DEFMETHOD (FILE-DATA-STREAM-MIXIN :AFTER :INIT) (IGNORE) (FUNCALL TV:WHO-LINE-FILE-STATE-SHEET ':ADD-STREAM SELF)) (defwrapper (file-data-stream-mixin :close) (ignore . body) `(unwind-protect (progn ,@body) (funcall tv:who-line-file-state-sheet :delete-stream self))) (DEFMETHOD (FILE-DATA-STREAM-MIXIN :WHO-LINE-INFORMATION) (&AUX COUNT LENGTH PERCENT DIRECTION) (SETQ COUNT (FUNCALL-SELF ':READ-POINTER)) (SETQ DIRECTION (FUNCALL-SELF ':DIRECTION)) (AND (SETQ LENGTH (FUNCALL-SELF ':LENGTH)) (NOT (ZEROP LENGTH)) (SETQ PERCENT (ROUND (* 100. COUNT) LENGTH))) (LET ((MAYBE-NAME (FUNCALL-SELF ':TRUENAME))) ;; directory streams (and maybe others) don't have truenames; show ;; their pathnames instead. (IF (NULL MAYBE-NAME) (SETQ MAYBE-NAME (FUNCALL-SELF ':PATHNAME))) (VALUES MAYBE-NAME DIRECTION COUNT PERCENT))) (DEFFLAVOR INPUT-FILE-STREAM-MIXIN () (FILE-DATA-STREAM-MIXIN) (:INCLUDED-FLAVORS INPUT-POINTER-REMEMBERING-MIXIN) (:DOCUMENTATION :MIXIN "Streams for use with input files.")) (DEFFLAVOR OUTPUT-FILE-STREAM-MIXIN () (FILE-DATA-STREAM-MIXIN) (:INCLUDED-FLAVORS OUTPUT-POINTER-REMEMBERING-MIXIN) (:DOCUMENTATION :MIXIN "Streams for use with output files.")) (DEFMETHOD (OUTPUT-FILE-STREAM-MIXIN :LENGTH) () NIL) (DEFSTRUCT (INDENTING-STREAM) INDENTING-STREAM-BASE-STREAM INDENTING-STREAM-INDENTATION INDENTING-STREAM-BEGINNING-OF-LINE?) (DEFUN MAKE-STREAM-INDENTABLE (STREAM) "Return an indenting stream which passes output to STREAM. If STREAM is already an indenting stream, it is returned unchanged. The indenting stream inserts a specified indentation before each line. It supports the :SET-INDENTATION and :INDENT-RELATIVE operations to specify the amount of indentation." (IF (FUNCALL STREAM ':OPERATION-HANDLED-P ':INDENT-RELATIVE) STREAM (LET-CLOSED ((*SELF (MAKE-INDENTING-STREAM INDENTING-STREAM-BASE-STREAM STREAM INDENTING-STREAM-INDENTATION 0 INDENTING-STREAM-BEGINNING-OF-LINE? NIL))) #'(LAMBDA (&REST STUFF) (LEXPR-FUNCALL #'INDENTING-STREAM-INTERFACE *SELF STUFF))))) (DEFUN INDENTING-STREAM-INTERFACE (SELF MESSAGE &REST ARGS) (LET ((HANDLER (AND (SYMBOLP MESSAGE) (GET MESSAGE 'INDENTING-STREAM-OPERATIONS)))) (IF (NULL HANDLER) (LEXPR-FUNCALL (INDENTING-STREAM-BASE-STREAM SELF) MESSAGE ARGS) (FUNCALL HANDLER SELF ARGS)))) (DEFUN INDENTING-STREAM-WHICH-OPERATIONS (SELF) (LET ((MY-OPS NIL) (BASE-OPS (FUNCALL (INDENTING-STREAM-BASE-STREAM SELF) ':WHICH-OPERATIONS))) (SETQ MY-OPS (LIST* NIL ':WHICH-OPERATIONS ':OPERATION-HANDLED-P ':SEND-IF-HANDLES ':SET-INDENTATION ':INDENT-RELATIVE ':TYO ':STRING-OUT ':FRESH-LINE BASE-OPS)) (DO ((TAIL MY-OPS (CDR TAIL))) ((EQ (CDR TAIL) BASE-OPS) (CDR MY-OPS)) (COND ((MEMQ (CADR TAIL) BASE-OPS) (RPLACD TAIL (CDDR TAIL)) (IF (EQ (CDR TAIL) BASE-OPS) (RETURN (CDR MY-OPS)))))))) (DEFUN INDENTING-STREAM-INDENT (SELF) (IF (FUNCALL (INDENTING-STREAM-BASE-STREAM SELF) ':OPERATION-HANDLED-P ':INCREMENT-CURSORPOS) (FUNCALL (INDENTING-STREAM-BASE-STREAM SELF) ':INCREMENT-CURSORPOS (INDENTING-STREAM-INDENTATION SELF) 0 ':CHARACTER) (DOTIMES (I (INDENTING-STREAM-INDENTATION SELF)) (FUNCALL (INDENTING-STREAM-BASE-STREAM SELF) ':TYO #\SPACE)))) (DEFUN (:WHICH-OPERATIONS INDENTING-STREAM-OPERATIONS) (SELF IGNORE) (INDENTING-STREAM-WHICH-OPERATIONS SELF)) (DEFUN (:OPERATION-HANDLED-P INDENTING-STREAM-OPERATIONS) (SELF ARGS) (MEMQ (CAR ARGS) (INDENTING-STREAM-WHICH-OPERATIONS SELF))) (DEFUN (:SEND-IF-HANDLES INDENTING-STREAM-OPERATIONS) (SELF ARGS) (IF (MEMQ (CAR ARGS) (INDENTING-STREAM-WHICH-OPERATIONS SELF)) (LEXPR-FUNCALL SELF (CAR ARGS) (CDR ARGS)) NIL)) (DEFUN (:SET-INDENTATION INDENTING-STREAM-OPERATIONS) (SELF ARGS) (SETF (INDENTING-STREAM-BEGINNING-OF-LINE? SELF) NIL) (SETF (INDENTING-STREAM-INDENTATION SELF) (CAR ARGS))) (DEFUN (:INDENT-RELATIVE INDENTING-STREAM-OPERATIONS) (SELF ARGS) (SETF (INDENTING-STREAM-BEGINNING-OF-LINE? SELF) NIL) (INCF (INDENTING-STREAM-INDENTATION SELF) (CAR ARGS))) (DEFUN (:TYO INDENTING-STREAM-OPERATIONS) (SELF ARGS) (LEXPR-FUNCALL (INDENTING-STREAM-BASE-STREAM SELF) ':TYO (CAR ARGS) (CDR ARGS)) (SETF (INDENTING-STREAM-BEGINNING-OF-LINE? SELF) (CHAR-EQUAL (CAR ARGS) #\CR)) (IF (NOT (NULL (INDENTING-STREAM-BEGINNING-OF-LINE? SELF))) (INDENTING-STREAM-INDENT SELF))) (DEFUN (:STRING-OUT INDENTING-STREAM-OPERATIONS) (SELF ARGS) (LET ((STRING (CAR ARGS)) (START (CADR ARGS)) (END (CADDR ARGS))) (IF (NULL START) (SETQ START 0)) (IF (NULL END) (SETQ END (ARRAY-ACTIVE-LENGTH STRING))) (COND ((> END START) (SETF (INDENTING-STREAM-BEGINNING-OF-LINE? SELF) NIL) (LET ((MARK START)) (DO () ((NOT (SETQ MARK (%STRING-SEARCH-CHAR #\CR STRING MARK END))) (FUNCALL (INDENTING-STREAM-BASE-STREAM SELF) ':STRING-OUT STRING START END) (RETURN STRING)) (FUNCALL (INDENTING-STREAM-BASE-STREAM SELF) ':STRING-OUT STRING START MARK) (INDENTING-STREAM-INTERFACE SELF ':TYO #\CR) (COND ((= (SETQ MARK (1+ MARK)) END) (SETF (INDENTING-STREAM-BEGINNING-OF-LINE? SELF) T) (RETURN STRING))) (SETQ START MARK))))))) (DEFUN (:FRESH-LINE INDENTING-STREAM-OPERATIONS) (SELF IGNORE) (IF (NULL (INDENTING-STREAM-BEGINNING-OF-LINE? SELF)) (INDENTING-STREAM-INTERFACE SELF ':TYO #\CR))) (DEFFLAVOR IO-STREAM-INPUT-MIXIN () () (:REQUIRED-FLAVORS OUTPUT-POINTER-REMEMBERING-MIXIN)) (DEFMETHOD (IO-STREAM-INPUT-MIXIN :TYI) (&OPTIONAL EOF) (LOOP UNTIL (AND STREAM-OUTPUT-BUFFER (< STREAM-OUTPUT-INDEX (FUNCALL-SELF :BYTES-IN-BLOCK))) ;Out of input, get some more UNTIL (UNLESS (FUNCALL-SELF :LAST-BLOCK-P) (FUNCALL-SELF :SETUP-NEXT-OUTPUT-BUFFER)) ;Reached end of file RETURN (AND EOF (FERROR 'SYS:END-OF-FILE-1 "End of file on ~S." SELF)) ;Here we have a character available FINALLY (RETURN (PROG1 (AREF STREAM-OUTPUT-BUFFER STREAM-OUTPUT-INDEX) (INCF STREAM-OUTPUT-INDEX))))) (DEFMETHOD (IO-STREAM-INPUT-MIXIN :ANY-TYI) (&OPTIONAL EOF) (FUNCALL-SELF :TYI EOF)) (DEFMETHOD (IO-STREAM-INPUT-MIXIN :TYIPEEK) (&OPTIONAL EOF) (LET ((CH (FUNCALL-SELF :TYI EOF))) (WHEN CH (FUNCALL-SELF :UNTYI CH)) CH)) (DEFMETHOD (IO-STREAM-INPUT-MIXIN :READ-UNTIL-EOF) () (FUNCALL-SELF :SET-POINTER :END)) (DEFMETHOD (IO-STREAM-INPUT-MIXIN :UNTYI) (CH) (LET ((NEW-INDEX (AND STREAM-OUTPUT-BUFFER (1- STREAM-OUTPUT-INDEX)))) (COND ((AND NEW-INDEX ( NEW-INDEX 0) (EQ (AREF STREAM-OUTPUT-BUFFER NEW-INDEX) CH)) ; (FUNCALL-SELF :MAYBE-UPDATE-MAP-BLOCK-SIZE STREAM-OUTPUT-INDEX) (SETQ STREAM-OUTPUT-INDEX NEW-INDEX)) (T (FERROR NIL "Attempt to :UNTYI something different than last :TYI'ed."))))) (DEFMETHOD (IO-STREAM-INPUT-MIXIN :STRING-IN) (EOF STRING &OPTIONAL (START 0) END) (OR END (SETQ END (ARRAY-LENGTH STRING))) (LOOP WHILE (< START END) WHILE (LOOP UNTIL (AND STREAM-OUTPUT-BUFFER (< STREAM-OUTPUT-INDEX (FUNCALL-SELF :BYTES-IN-BLOCK))) ;Out of input, get some more UNTIL (UNLESS (FUNCALL-SELF :LAST-BLOCK-P) (FUNCALL-SELF :SETUP-NEXT-OUTPUT-BUFFER)) DO (AND EOF (FERROR 'SYS:END-OF-FILE-1 "End of file on ~S." SELF)) RETURN NIL FINALLY (RETURN T)) AS AMT = (MIN (- END START) (- (FUNCALL-SELF :BYTES-IN-BLOCK) STREAM-OUTPUT-INDEX)) DO (COPY-ARRAY-PORTION STREAM-OUTPUT-BUFFER STREAM-OUTPUT-INDEX (SETQ STREAM-OUTPUT-INDEX (+ STREAM-OUTPUT-INDEX AMT)) STRING START (SETQ START (+ START AMT))) FINALLY (AND (ARRAY-HAS-LEADER-P STRING) (STORE-ARRAY-LEADER START STRING 0)) (RETURN (VALUES START (NULL STREAM-OUTPUT-BUFFER))))) (DEFMETHOD (IO-STREAM-INPUT-MIXIN :STRING-LINE-IN) (EOF STRING &OPTIONAL (START 0) END) (OR END (SETQ END (ARRAY-LENGTH STRING))) (LOOP WHILE (< START END) WHILE (LOOP UNTIL (AND STREAM-OUTPUT-BUFFER (< STREAM-OUTPUT-INDEX (FUNCALL-SELF :BYTES-IN-BLOCK))) ;Out of input, get some more UNTIL (UNLESS (FUNCALL-SELF :LAST-BLOCK-P) (FUNCALL-SELF :SETUP-NEXT-OUTPUT-BUFFER)) DO (AND EOF (FERROR 'SYS:END-OF-FILE-1 "End of file on ~S." SELF)) RETURN NIL FINALLY (RETURN T)) AS BYTES-IN-BLOCK = (FUNCALL-SELF :BYTES-IN-BLOCK) AS LINE-END-INDEX = (%STRING-SEARCH-CHAR #\RETURN STREAM-OUTPUT-BUFFER STREAM-OUTPUT-INDEX BYTES-IN-BLOCK) AS AMT = (MIN (- END START) (- (OR LINE-END-INDEX BYTES-IN-BLOCK) STREAM-OUTPUT-INDEX)) DO (COPY-ARRAY-PORTION STREAM-OUTPUT-BUFFER STREAM-OUTPUT-INDEX (SETQ STREAM-OUTPUT-INDEX (+ STREAM-OUTPUT-INDEX AMT)) STRING START (SETQ START (+ START AMT))) (WHEN (EQ STREAM-OUTPUT-INDEX LINE-END-INDEX) (INCF STREAM-OUTPUT-INDEX) (RETURN (VALUES START NIL NIL))) FINALLY (AND (ARRAY-HAS-LEADER-P STRING) (STORE-ARRAY-LEADER START STRING 0)) (RETURN (VALUES START (NULL STREAM-OUTPUT-BUFFER) T)))) ; WITH APOLOGIES TO ;(DEFMETHOD (BUFFERED-LINE-INPUT-STREAM :LINE-IN) (&OPTIONAL LEADER) (DEFMETHOD (IO-STREAM-INPUT-MIXIN :LINE-IN) (&OPTIONAL LEADER) (LOOP NAMED LINE-IN ;; STRING is not made until needed to avoid calling ADJUST-ARRAY-SIZE except when ;; strings cross buffer boundaries. WITH STRING = NIL AND STRING-INDEX = 0 DO (LOOP UNTIL (AND STREAM-OUTPUT-BUFFER (< STREAM-OUTPUT-INDEX (FUNCALL-SELF :BYTES-IN-BLOCK))) ;Out of input, get some more UNTIL (UNLESS (FUNCALL-SELF :LAST-BLOCK-P) (FUNCALL-SELF :SETUP-NEXT-OUTPUT-BUFFER)) ;EOF if none that way WHEN (NULL STRING) DO (SETQ STRING (MAKE-ARRAY STRING-INDEX :TYPE 'ART-STRING :LEADER-LENGTH (AND (NUMBERP LEADER) LEADER))) WHEN (NUMBERP LEADER) DO (STORE-ARRAY-LEADER STRING-INDEX STRING 0) DO (RETURN-FROM LINE-IN (VALUES STRING T))) ;; Now see if this buffer has a CR, and copy out the appropriate amount AS BYTES-IN-BLOCK = (FUNCALL-SELF :BYTES-IN-BLOCK) AS CR-INDEX = (%STRING-SEARCH-CHAR #\CR STREAM-OUTPUT-BUFFER STREAM-OUTPUT-INDEX BYTES-IN-BLOCK) WITH NEW-STRING-INDEX AND NEW-BUFFER-INDEX WHEN (NOT (NULL CR-INDEX)) ; WHEN (AND (NULL STRING) (NULL LEADER)) ; DO (SETQ STRING (LET ((ARRAY STREAM-OUTPUT-BUFFER) ; (OFFSET STREAM-OUTPUT-INDEX)) ; (AND (ARRAY-INDEXED-P ARRAY) ; (SETQ OFFSET (+ OFFSET (%P-CONTENTS-OFFSET ARRAY 3)) ; ARRAY (%P-CONTENTS-OFFSET ARRAY 1))) ; (MAKE-ARRAY (- CR-INDEX STREAM-OUTPUT-INDEX) ; :TYPE 'ART-STRING ; :DISPLACED-TO ARRAY ; :DISPLACED-INDEX-OFFSET OFFSET)) ; STREAM-OUTPUT-INDEX (1+ CR-INDEX)) ; (RETURN (VALUES STRING NIL)) ; ELSE DO (SETQ NEW-BUFFER-INDEX (1+ CR-INDEX) NEW-STRING-INDEX (+ STRING-INDEX (- CR-INDEX STREAM-OUTPUT-INDEX))) ELSE DO (SETQ NEW-BUFFER-INDEX BYTES-IN-BLOCK NEW-STRING-INDEX (+ STRING-INDEX (- BYTES-IN-BLOCK STREAM-OUTPUT-INDEX))) WHEN (NULL STRING) ;;Make a string to return or save the end of this packet in. DO (SETQ STRING (MAKE-ARRAY NEW-STRING-INDEX :TYPE 'ART-STRING :LEADER-LENGTH (AND (NUMBERP LEADER) LEADER))) ;;Was some stuff from previous packet, make room. ELSE DO (ADJUST-ARRAY-SIZE STRING NEW-STRING-INDEX) DO (COPY-ARRAY-PORTION STREAM-OUTPUT-BUFFER STREAM-OUTPUT-INDEX NEW-BUFFER-INDEX STRING STRING-INDEX NEW-STRING-INDEX) (SETQ STREAM-OUTPUT-INDEX NEW-BUFFER-INDEX STRING-INDEX NEW-STRING-INDEX) WHEN (NOT (NULL CR-INDEX)) ;This buffer is enough to satisfy DO (AND (NUMBERP LEADER) (STORE-ARRAY-LEADER STRING-INDEX STRING 0)) (RETURN (VALUES STRING NIL)))) (DEFMETHOD (IO-STREAM-INPUT-MIXIN :GET-INPUT-BUFFER) (&OPTIONAL EOF) (LET ((BYTES-IN-BLOCK (FUNCALL-SELF :BYTES-IN-BLOCK))) (LOOP UNTIL (AND STREAM-OUTPUT-BUFFER (< STREAM-OUTPUT-INDEX BYTES-IN-BLOCK)) ;Out of input, get some more UNTIL (UNLESS (FUNCALL-SELF :LAST-BLOCK-P) (FUNCALL-SELF :SETUP-NEXT-OUTPUT-BUFFER)) ;Reached end of file RETURN (AND EOF (FERROR 'SYS:END-OF-FILE-1 "End of file on ~S." SELF)) ;Here we have a non-empty available FINALLY (RETURN (VALUES STREAM-OUTPUT-BUFFER STREAM-OUTPUT-INDEX (- BYTES-IN-BLOCK STREAM-OUTPUT-INDEX)))))) (DEFMETHOD (IO-STREAM-INPUT-MIXIN :READ-INPUT-BUFFER) (&OPTIONAL EOF) (LET ((BYTES-IN-BLOCK (FUNCALL-SELF :BYTES-IN-BLOCK))) (LOOP UNTIL (AND STREAM-OUTPUT-BUFFER (< STREAM-OUTPUT-INDEX BYTES-IN-BLOCK)) ;Out of input, get some more UNTIL (UNLESS (FUNCALL-SELF :LAST-BLOCK-P) (FUNCALL-SELF :SETUP-NEXT-OUTPUT-BUFFER)) ;Reached end of file RETURN (AND EOF (FERROR 'SYS:END-OF-FILE-1 "End of file on ~S." SELF)) ;Here we have a non-empty available FINALLY (RETURN (VALUES STREAM-OUTPUT-BUFFER STREAM-OUTPUT-INDEX BYTES-IN-BLOCK))))) (DEFMETHOD (IO-STREAM-INPUT-MIXIN :ADVANCE-INPUT-BUFFER) (&OPTIONAL NEW-INDEX) (WHEN STREAM-OUTPUT-BUFFER (LET ((BYTES-IN-BLOCK (FUNCALL-SELF :BYTES-IN-BLOCK))) (COND (NEW-INDEX (OR (AND ( NEW-INDEX 0) ( NEW-INDEX BYTES-IN-BLOCK)) (FERROR NIL "New index out of range")) ;; IN CASE WE'RE MOVING BACKWARDS AND THE MAP HASN'T BEEN UPDATED YET. (FUNCALL-SELF :MAYBE-UPDATE-MAP-BLOCK-SIZE STREAM-OUTPUT-INDEX) (SETQ STREAM-OUTPUT-INDEX NEW-INDEX)) (T (IF (FUNCALL-SELF :LAST-BLOCK-P) (FUNCALL-SELF :SET-POINTER :END) (FUNCALL-SELF :SETUP-NEXT-OUTPUT-BUFFER)))))))