(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "18-Oct-93 10:05:08" "{Pele:mv:envos}Sources>CLTL2>CLSTREAMS.;2" 60585 |previous| |date:| "13-Apr-92 16:18:18" "{Pele:mv:envos}Sources>CLTL2>CLSTREAMS.;1" ) ; Copyright (c) 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT CLSTREAMSCOMS) (RPAQQ CLSTREAMSCOMS ( (* |;;;| "Implements a number of stream functions from CommonLisp. See CLtL chapter 21") (COMS (* |;;| "documented functions and macros") (FUNCTIONS OPEN LISP:CLOSE LISP:STREAM-EXTERNAL-FORMAT) (FUNCTIONS LISP:STREAM-ELEMENT-TYPE LISP:INPUT-STREAM-P LISP:OUTPUT-STREAM-P LISP:OPEN-STREAM-P) (COMS (FUNCTIONS FILE-STREAM-POSITION) (SETFS FILE-STREAM-POSITION)) (* |;;| "Random support for stream types (types defined in CMLTYPES)") (FUNCTIONS XCL:STRING-STREAM-P LISP::FILE-STREAM-P) (FUNCTIONS LISP:MAKE-SYNONYM-STREAM XCL:SYNONYM-STREAM-P LISP:SYNONYM-STREAM-SYMBOL XCL:FOLLOW-SYNONYM-STREAMS) (FUNCTIONS LISP:MAKE-BROADCAST-STREAM XCL:BROADCAST-STREAM-P LISP:BROADCAST-STREAM-STREAMS) (FUNCTIONS LISP:MAKE-CONCATENATED-STREAM XCL:CONCATENATED-STREAM-P LISP:CONCATENATED-STREAM-STREAMS) (FUNCTIONS LISP:MAKE-TWO-WAY-STREAM XCL:TWO-WAY-STREAM-P LISP:TWO-WAY-STREAM-OUTPUT-STREAM LISP:TWO-WAY-STREAM-INPUT-STREAM) (FUNCTIONS LISP:MAKE-ECHO-STREAM XCL:ECHO-STREAM-P LISP:ECHO-STREAM-INPUT-STREAM LISP:ECHO-STREAM-OUTPUT-STREAM) (FUNCTIONS LISP:MAKE-STRING-INPUT-STREAM MAKE-CONCATENATED-STRING-INPUT-STREAM) (FUNCTIONS %MAKE-INITIAL-STRING-STREAM-CONTENTS) (FUNCTIONS LISP:WITH-OPEN-STREAM LISP:WITH-INPUT-FROM-STRING LISP:WITH-OUTPUT-TO-STRING LISP:WITH-OPEN-FILE) (FUNCTIONS LISP:MAKE-STRING-OUTPUT-STREAM MAKE-FILL-POINTER-OUTPUT-STREAM LISP:GET-OUTPUT-STREAM-STRING \\STRING-STREAM-OUTCHARFN \\ADJUSTABLE-STRING-STREAM-OUTCHARFN)) (COMS (* |;;| "helpers") (FUNCTIONS %NEW-FILE PREDICT-NAME) (DECLARE\: EVAL@COMPILE DONTCOPY (FUNCTIONS INTERLISP-ACCESS))) (COMS (* |;;| "methods for the special devices") (FNS %BROADCAST-STREAM-DEVICE-BOUT %BROADCAST-STREAM-DEVICE-OUTCHARFN %BROADCAST-STREAM-DEVICE-CLOSEFILE %BROADCAST-STREAM-DEVICE-FORCEOUTPUT) (FUNCTIONS %BROADCAST-STREAM-DEVICE-CHARSETFN) (FNS %CONCATENATED-STREAM-DEVICE-BIN %CONCATENATED-STREAM-DEVICE-CLOSEFILE %CONCATENATED-STREAM-DEVICE-EOFP %CONCATENATED-STREAM-DEVICE-PEEKBIN %CONCATENATED-STREAM-DEVICE-BACKFILEPTR) (FUNCTIONS %CONCATENATED-STREAM-DEVICE-CHARSETFN) (FNS %ECHO-STREAM-DEVICE-BIN) (FUNCTIONS %SYNONYM-STREAM-DEVICE-GET-INDIRECT-STREAM) (FNS %SYNONYM-STREAM-DEVICE-BIN %SYNONYM-STREAM-DEVICE-BOUT %SYNONYM-STREAM-DEVICE-OUTCHARFN %SYNONYM-STREAM-DEVICE-CLOSEFILE %SYNONYM-STREAM-DEVICE-EOFP %SYNONYM-STREAM-DEVICE-FORCEOUTPUT %SYNONYM-STREAM-DEVICE-GETFILEINFO %SYNONYM-STREAM-DEVICE-PEEKBIN %SYNONYM-STREAM-DEVICE-READP %SYNONYM-STREAM-DEVICE-BACKFILEPTR %SYNONYM-STREAM-DEVICE-SETFILEINFO %SYNONYM-STREAM-DEVICE-CHARSETFN) (FNS %TWO-WAY-STREAM-DEVICE-BIN %TWO-WAY-STREAM-DEVICE-INPUTSTREAM %TWO-WAY-STREAM-DEVICE-BOUT %TWO-WAY-STREAM-DEVICE-OUTPUTSTREAM %TWO-WAY-STREAM-DEVICE-OUTCHARFN %TWO-WAY-STREAM-DEVICE-CLOSEFILE %TWO-WAY-STREAM-DEVICE-EOFP %TWO-WAY-STREAM-DEVICE-READP %TWO-WAY-STREAM-DEVICE-BACKFILEPTR %TWO-WAY-STREAM-DEVICE-FORCEOUTPUT %TWO-WAY-STREAM-DEVICE-PEEKBIN %TWO-WAY-STREAM-DEVICE-CHARSETFN) (FUNCTIONS %FILL-POINTER-STREAM-DEVICE-CLOSEFILE %FILL-POINTER-STREAM-DEVICE-GETFILEPTR ) (GLOBALVARS %SYNONYM-STREAM-DEVICE %BROADCAST-STREAM-DEVICE %CONCATENATED-STREAM-DEVICE %TWO-WAY-STREAM-DEVICE %ECHO-STREAM-DEVICE \\FILL-POINTER-STREAM-DEVICE)) (COMS (* |;;| "helper stuff") (FNS %SYNONYM-STREAM-DEVICE-GET-STREAM)) (COMS (* |;;| "module initialization") (VARIABLES *DEBUG-IO* *QUERY-IO* *TERMINAL-IO* *ERROR-OUTPUT* *STANDARD-OUTPUT* *STANDARD-INPUT*) (FUNCTIONS %INITIALIZE-STANDARD-STREAMS) (FNS %INITIALIZE-CLSTREAM-TYPES) (DECLARE\: DONTEVAL@LOAD DOCOPY (* \; "initialization") (P (%INITIALIZE-CLSTREAM-TYPES) (%INITIALIZE-STANDARD-STREAMS)))) (PROP FILETYPE CLSTREAMS))) (* |;;;| "Implements a number of stream functions from CommonLisp. See CLtL chapter 21") (* |;;| "documented functions and macros") (LISP:DEFUN OPEN (FILENAME &KEY (DIRECTION :INPUT) (ELEMENT-TYPE 'LISP:STRING-CHAR) (IF-EXISTS NIL EXISTS-P) (IF-DOES-NOT-EXIST NIL DOES-NOT-EXIST-P) (EXTERNAL-FORMAT :DEFAULT)) (* |;;;| "Return a stream which reads from or writes to Filename. Defined keywords: :direction (one of :input, :output or :probe :element-type), Type of object to read or write, default String-Char, :if-exists (one of :error, :new-version, :overwrite, :append or nil), :if-does-not-exist (one of :error, :create or nil). :external-format (one of :DEFAULT, :EUC, :JIS, :W-MS, :MS or :XCCS). The specification of :external-format is based on the JEIDA proposal. See the manual for details.") (LISP:UNLESS (MEMQ DIRECTION '(:INPUT :OUTPUT :IO :PROBE)) (LISP:ERROR "~S isn't a valid direction for open." DIRECTION)) (LISP:UNLESS (LISP:MEMBER ELEMENT-TYPE '(LISP:STRING-CHAR LISP:SIGNED-BYTE LISP:UNSIGNED-BYTE (LISP:UNSIGNED-BYTE 8) (LISP:SIGNED-BYTE 8) LISP:CHARACTER :DEFAULT) :TEST 'LISP:EQUAL) (LISP:ERROR "~S isn't an implemented element-type for open." ELEMENT-TYPE)) (LET ((PATHNAME (LISP:IF (LISP::LOGICAL-PATHNAME-P FILENAME) (LISP:TRANSLATE-LOGICAL-PATHNAME FILENAME) (PATHNAME FILENAME))) (FOR-INPUT (MEMQ DIRECTION '(:IO :INPUT))) (FOR-OUTPUT (MEMQ DIRECTION '(:IO :OUTPUT))) (ACCESS (INTERLISP-ACCESS DIRECTION)) (FILE-TYPE (IF (LISP:MEMBER ELEMENT-TYPE '(LISP:UNSIGNED-BYTE LISP:SIGNED-BYTE ( LISP:UNSIGNED-BYTE 8) (LISP:SIGNED-BYTE 8)) :TEST 'LISP:EQUAL) THEN 'BINARY ELSE 'TEXT)) (STREAM NIL)) (* |;;;| "Do hairy defaulting of :if-exists and :if-does-not-exist keywords.") (LISP:UNLESS EXISTS-P (SETQ IF-EXISTS (LISP:IF (EQ (LISP:PATHNAME-VERSION PATHNAME) :NEWEST) :NEW-VERSION :ERROR))) (* \;  "If the file does not exist, it is OK to have :if-exists :overwrite. ") (LISP:UNLESS DOES-NOT-EXIST-P (SETQ IF-DOES-NOT-EXIST (COND ((OR (EQ IF-EXISTS :APPEND) (EQ DIRECTION :INPUT)) :ERROR) ((EQ DIRECTION :PROBE) NIL) (T :CREATE)))) (LISP:LOOP (* \;  "See if the file exists and handle the existential keywords.") (LET* ((NAME (PREDICT-NAME PATHNAME)) (LISP:NAMESTRING (MKSTRING NAME))) (IF NAME THEN (* \; "file exists") (IF FOR-OUTPUT THEN (* |;;| "open for output/both") (CASE IF-EXISTS (:ERROR (LISP:CERROR "write it anyway." "File ~A already exists." LISP:NAMESTRING) (SETQ STREAM (OPENSTREAM LISP:NAMESTRING ACCESS NIL `((TYPE ,FILE-TYPE) (EXTERNALFORMAT ,EXTERNAL-FORMAT)))) (RETURN NIL)) ((:NEW-VERSION :SUPERSEDE :RENAME :RENAME-AND-DELETE) (SETQ STREAM (OPENSTREAM PATHNAME ACCESS 'NEW `((TYPE ,FILE-TYPE) (EXTERNALFORMAT ,EXTERNAL-FORMAT)))) (RETURN NIL)) (:OVERWRITE (SETQ STREAM (OPENSTREAM LISP:NAMESTRING ACCESS 'OLD `((TYPE ,FILE-TYPE) (EXTERNALFORMAT ,EXTERNAL-FORMAT)))) (RETURN NIL)) (:APPEND (IF (EQ DIRECTION :OUTPUT) THEN (* \;  "if the direction is output it is the same as interlisp append") (SETQ STREAM (OPENSTREAM LISP:NAMESTRING 'APPEND 'OLD `((TYPE ,FILE-TYPE) (EXTERNALFORMAT ,EXTERNAL-FORMAT)))) ELSE (* \;  "if direction is io it opens the file for both and goes to the end of the file") (SETQ STREAM (OPENSTREAM LISP:NAMESTRING 'BOTH 'OLD `((TYPE ,FILE-TYPE) (EXTERNALFORMAT ,EXTERNAL-FORMAT) ))) (SETFILEPTR STREAM -1)) (RETURN NIL)) ((NIL) (LISP:RETURN-FROM OPEN NIL)) (T (LISP:ERROR "~S is not a valid value for :if-exists." IF-EXISTS ))) |elseif| FOR-INPUT |then| (* |;;| "open for input/both") (SETQ STREAM (OPENSTREAM LISP:NAMESTRING ACCESS 'OLD `((TYPE ,FILE-TYPE) (EXTERNALFORMAT ,EXTERNAL-FORMAT)))) (RETURN NIL) |else| (* |;;| "open for probe") (SETQ STREAM (|create| STREAM FULLFILENAME _ (FULLNAME LISP:NAMESTRING))) (RETURN NIL)) |else| (* |;;| "file does not exist") (|if| FOR-OUTPUT |then| (CASE IF-DOES-NOT-EXIST (:ERROR (LISP:CERROR "prompt for a new name." 'XCL:FILE-NOT-FOUND :PATHNAME PATHNAME) (LISP:FORMAT *QUERY-IO* "~&New file name: ") (SETQ PATHNAME (PATHNAME (LISP:READ-LINE *QUERY-IO*)))) (:CREATE (SETQ STREAM (OPENSTREAM PATHNAME ACCESS 'NEW `((TYPE ,FILE-TYPE) (EXTERNALFORMAT ,EXTERNAL-FORMAT)))) (RETURN NIL)) ((NIL) (LISP:RETURN-FROM OPEN NIL)) (T (LISP:ERROR "~S is not a valid value for :if-does-not-exist." IF-DOES-NOT-EXIST))) |elseif| FOR-INPUT |then| (CASE IF-DOES-NOT-EXIST (:ERROR (LISP:CERROR "prompt for a new name." 'XCL:FILE-NOT-FOUND :PATHNAME PATHNAME) (LISP:FORMAT *QUERY-IO* "~&New file name: ") (SETQ PATHNAME (PATHNAME (LISP:READ-LINE *QUERY-IO*)))) (:CREATE (%NEW-FILE PATHNAME)) ((NIL) (LISP:RETURN-FROM OPEN NIL)) (T (LISP:ERROR "~S is not a valid value for :if-does-not-exist." IF-DOES-NOT-EXIST))) |else| (* \; "Open for probe.") (RETURN NIL))))) (STREAMPROP STREAM :FILE-STREAM-P T) STREAM)) (LISP:DEFUN LISP:CLOSE (STREAM &KEY ABORT) (* |;;;| "Close a stream. If ABORT, then don't keep the file") (|if| (STREAMP STREAM) |then| (|if| (OPENP STREAM) |then| (* |;;|  "determine 'deletability' of stream's file before closing, as that trashes the info") (LET ((ABORTABLE (AND (DIRTYABLE STREAM) (NOT (APPENDONLY STREAM))))) (CLOSEF STREAM) (|if| (AND ABORT ABORTABLE) |then| (* \;  "eventually we will change device CLOSEF methods to take an ABORT arg. For now, simulate it.") (DELFILE (LISP:NAMESTRING STREAM))))) |else| (ERROR "Closing a non-stream" STREAM)) T) (LISP:DEFUN LISP:STREAM-EXTERNAL-FORMAT (STREAM) (\\EXTERNALFORMAT STREAM)) (LISP:DEFUN LISP:STREAM-ELEMENT-TYPE (STREAM) 'LISP:UNSIGNED-BYTE) (LISP:DEFUN LISP:INPUT-STREAM-P (STREAM) (LISP:WHEN (NOT (STREAMP STREAM)) (\\ILLEGAL.ARG STREAM)) (* |;;| "we return T instead of the stream because Symbolics does") (AND (\\IOMODEP STREAM 'INPUT T) T)) (LISP:DEFUN LISP:OUTPUT-STREAM-P (STREAM) (LISP:WHEN (NOT (STREAMP STREAM)) (\\ILLEGAL.ARG STREAM)) (* |;;| "we return T instead of the stream because Symbolics does") (AND (\\IOMODEP STREAM 'OUTPUT T) T)) (LISP:DEFUN LISP:OPEN-STREAM-P (STREAM) (* |;;| "is stream an open stream?") (AND (STREAMP STREAM) (OPENED STREAM))) (LISP:DEFUN FILE-STREAM-POSITION (STREAM) (GETFILEPTR STREAM)) (LISP:DEFSETF FILE-STREAM-POSITION SETFILEPTR) (* |;;| "Random support for stream types (types defined in CMLTYPES)") (LISP:DEFUN XCL:STRING-STREAM-P (STREAM) (* \; "Edited 14-Feb-92 12:43 by jrb:") (STREAMPROP STREAM 'XCL:STRING-STREAM-P)) (LISP:DEFUN LISP::FILE-STREAM-P (STREAM) (* \; "Edited 14-Feb-92 12:42 by jrb:") (FETCH (STREAM FULLFILENAME) OF STREAM)) (LISP:DEFUN LISP:MAKE-SYNONYM-STREAM (LISP:SYMBOL) (* |;;| "A CommonLisp function for shadowing a stream. See CLtL p. 329") (LET ((STREAM (|create| STREAM DEVICE _ %SYNONYM-STREAM-DEVICE ACCESS _ 'BOTH F1 _ LISP:SYMBOL LINELENGTH _ (|fetch| (STREAM LINELENGTH) |of| (LISP:SYMBOL-VALUE LISP:SYMBOL)) OUTCHARFN _ (FUNCTION %SYNONYM-STREAM-DEVICE-OUTCHARFN)))) (STREAMPROP STREAM 'XCL:SYNONYM-STREAM-P T) (* |;;| "save the synonym stream in the OPENFILELST field of %SYNONYM-STREAM-DEVICE") (|replace| (FDEV OPENFILELST) |of| %SYNONYM-STREAM-DEVICE |with| (CONS STREAM (|fetch| (FDEV OPENFILELST) |of| %SYNONYM-STREAM-DEVICE))) STREAM)) (LISP:DEFUN XCL:SYNONYM-STREAM-P (STREAM) (STREAMPROP STREAM 'XCL:SYNONYM-STREAM-P)) (LISP:DEFUN LISP:SYNONYM-STREAM-SYMBOL (STREAM) (AND (XCL:SYNONYM-STREAM-P STREAM) (FETCH (STREAM F1) OF STREAM))) (LISP:DEFUN XCL:FOLLOW-SYNONYM-STREAMS (STREAM) (* |;;;| "Return the non-synonym stream at the heart of STREAM.") (LISP:IF (XCL:SYNONYM-STREAM-P STREAM) (XCL:FOLLOW-SYNONYM-STREAMS (LISP:SYMBOL-VALUE (LISP:SYNONYM-STREAM-SYMBOL STREAM))) STREAM)) (LISP:DEFUN LISP:MAKE-BROADCAST-STREAM (&REST STREAMS) (* |;;| "CommonLisp function that makes a broadcast stream. See CLtL p329") (IF (FOR STREAM? IN STREAMS ALWAYS (STREAMP STREAM?)) THEN (LET ((STREAM (|create| STREAM DEVICE _ %BROADCAST-STREAM-DEVICE ACCESS _ 'OUTPUT F1 _ STREAMS OUTCHARFN _ (FUNCTION %BROADCAST-STREAM-DEVICE-OUTCHARFN)))) (STREAMPROP STREAM 'XCL:BROADCAST-STREAM-P T) STREAM) ELSE (\\ILLEGAL.ARG (FOR STREAM? IN STREAMS WHEN (NOT (STREAMP STREAM?)) DO (RETURN STREAM?))))) (LISP:DEFUN XCL:BROADCAST-STREAM-P (STREAM) (* |;;| "is stream a broadcast stream?") (STREAMPROP STREAM 'XCL:BROADCAST-STREAM-P)) (LISP:DEFUN LISP:BROADCAST-STREAM-STREAMS (STREAM) (* |;;| "return all of the streams that STREAM broadcasts to") (AND (XCL:BROADCAST-STREAM-P STREAM) (FETCH (STREAM F1) OF STREAM))) (LISP:DEFUN LISP:MAKE-CONCATENATED-STREAM (&REST STREAMS) (* |;;| "CommonLisp function that creates a concatenated stream. See CLtL p. 329") (IF (FOR STREAM? IN STREAMS ALWAYS (STREAMP STREAM?)) THEN (LET ((STREAM (|create| STREAM DEVICE _ %CONCATENATED-STREAM-DEVICE ACCESS _ 'INPUT F1 _ STREAMS))) (STREAMPROP STREAM 'XCL:CONCATENATED-STREAM-P T) STREAM) ELSE (\\ILLEGAL.ARG (FOR STREAM? IN STREAMS WHEN (NOT (STREAMP STREAM?)) DO (RETURN STREAM?))))) (LISP:DEFUN XCL:CONCATENATED-STREAM-P (STREAM) (STREAMPROP STREAM 'XCL:CONCATENATED-STREAM-P)) (LISP:DEFUN LISP:CONCATENATED-STREAM-STREAMS (STREAM) (* |;;| "return all of STREAM's concatenated streams") (AND (XCL:CONCATENATED-STREAM-P STREAM) (FETCH (STREAM F1) OF STREAM))) (LISP:DEFUN LISP:MAKE-TWO-WAY-STREAM (LISP::INPUT-STREAM LISP::OUTPUT-STREAM) (* |;;| "A CommonLisp function for splicing together two streams. See CLtL p. 329") (LISP:UNLESS (STREAMP LISP::INPUT-STREAM) (\\ILLEGAL.ARG LISP::INPUT-STREAM)) (LISP:UNLESS (STREAMP LISP::OUTPUT-STREAM) (\\ILLEGAL.ARG LISP::OUTPUT-STREAM)) (LET ((STREAM (|create| STREAM DEVICE _ %TWO-WAY-STREAM-DEVICE ACCESS _ 'BOTH F1 _ LISP::INPUT-STREAM F2 _ LISP::OUTPUT-STREAM LINELENGTH _ (|fetch| (STREAM LINELENGTH) |of| LISP::OUTPUT-STREAM) OUTCHARFN _ (FUNCTION %TWO-WAY-STREAM-DEVICE-OUTCHARFN)))) (STREAMPROP STREAM 'XCL:TWO-WAY-STREAM-P T) (* |;;| "save STREAM in the OPENFILELST field of %TWO-WAY-STREAM-DEVICE") (|replace| (FDEV OPENFILELST) |of| %TWO-WAY-STREAM-DEVICE |with| (CONS STREAM (|fetch| (FDEV OPENFILELST) |of| %TWO-WAY-STREAM-DEVICE))) STREAM)) (LISP:DEFUN XCL:TWO-WAY-STREAM-P (STREAM) (* |;;| "is STREAM a two-way stream?") (STREAMPROP STREAM 'XCL:TWO-WAY-STREAM-P)) (LISP:DEFUN LISP:TWO-WAY-STREAM-OUTPUT-STREAM (STREAM) (AND (XCL:TWO-WAY-STREAM-P STREAM) (FETCH (STREAM F2) OF STREAM))) (LISP:DEFUN LISP:TWO-WAY-STREAM-INPUT-STREAM (STREAM) (AND (XCL:TWO-WAY-STREAM-P STREAM) (FETCH (STREAM F1) OF STREAM))) (LISP:DEFUN LISP:MAKE-ECHO-STREAM (LISP::INPUT-STREAM LISP::OUTPUT-STREAM) (* |;;| "A CommonLisp function for making an echo stream. See CLtL p. 329") (LISP:UNLESS (STREAMP LISP::INPUT-STREAM) (\\ILLEGAL.ARG LISP::INPUT-STREAM)) (LISP:UNLESS (STREAMP LISP::OUTPUT-STREAM) (\\ILLEGAL.ARG LISP::OUTPUT-STREAM)) (LET ((STREAM (|create| STREAM DEVICE _ %ECHO-STREAM-DEVICE ACCESS _ 'BOTH F1 _ LISP::INPUT-STREAM F2 _ LISP::OUTPUT-STREAM LINELENGTH _ (|fetch| (STREAM LINELENGTH) |of| LISP::OUTPUT-STREAM) OUTCHARFN _ (FUNCTION %TWO-WAY-STREAM-DEVICE-OUTCHARFN)))) (STREAMPROP STREAM 'XCL:ECHO-STREAM-P T) (* |;;| "save STREAM in the OPENFILELST field of %ECHO-STREAM-DEVICE") (|replace| (FDEV OPENFILELST) |of| %ECHO-STREAM-DEVICE |with| (CONS STREAM (|fetch| (FDEV OPENFILELST) |of| %ECHO-STREAM-DEVICE))) STREAM)) (LISP:DEFUN XCL:ECHO-STREAM-P (STREAM) (* |;;| "is stream an echo stream?") (STREAMPROP STREAM 'XCL:ECHO-STREAM-P)) (LISP:DEFUN LISP:ECHO-STREAM-INPUT-STREAM (STREAM) (AND (XCL:ECHO-STREAM-P STREAM) (FETCH (STREAM F1) OF STREAM))) (LISP:DEFUN LISP:ECHO-STREAM-OUTPUT-STREAM (STREAM) (AND (XCL:ECHO-STREAM-P STREAM) (FETCH (STREAM F2) OF STREAM))) (LISP:DEFUN LISP:MAKE-STRING-INPUT-STREAM (STRING &OPTIONAL (LISP::START 0) (LISP::END NIL)) (* \; "Edited 14-Feb-92 12:36 by jrb:") (* |;;;| "A CommonLisp function for producing a stream from a string. See CLtL p. 330") (LET ((STREAM (OPENSTRINGSTREAM (|if| (OR (NOT (LISP:ZEROP LISP::START)) (NOT (NULL LISP::END))) |then| (* |;;| "A displaced array is ok here because the stream's uses GETBASEBYTE directly and doesn't go through the array code at all. ") (SUBSTRING STRING (LISP:1+ LISP::START) LISP::END) |else| STRING) 'INPUT))) (STREAMPROP STREAM 'XCL:STRING-STREAM-P T) STREAM)) (LISP:DEFUN MAKE-CONCATENATED-STRING-INPUT-STREAM (STRINGS) (COND ((NULL STRINGS) NIL) ((NULL (LISP:REST STRINGS)) (LISP:MAKE-STRING-INPUT-STREAM (LISP:FIRST STRINGS))) (T (LISP:APPLY 'LISP:MAKE-CONCATENATED-STREAM (FOR STRING IN STRINGS COLLECT (LISP:MAKE-STRING-INPUT-STREAM STRING)))))) (LISP:DEFUN %MAKE-INITIAL-STRING-STREAM-CONTENTS (&OPTIONAL (ELEMENT-TYPE 'LISP:STRING-CHAR)) (* \; "Edited 24-Mar-92 12:55 by jrb:") (LISP:MAKE-ARRAY '(256) :ELEMENT-TYPE ELEMENT-TYPE :EXTENDABLE T :FILL-POINTER 0)) (DEFMACRO LISP:WITH-OPEN-STREAM ((VAR STREAM) &BODY (BODY DECLS)) (LET ((ABORTP (GENSYM))) `(LET ((,VAR ,STREAM) (,ABORTP T)) ,@DECLS (LISP:UNWIND-PROTECT (LISP:MULTIPLE-VALUE-PROG1 (PROGN ,@BODY) (SETQ ,ABORTP NIL)) (LISP:CLOSE ,VAR :ABORT ,ABORTP))))) (DEFMACRO LISP:WITH-INPUT-FROM-STRING ((LISP::VAR STRING &KEY (LISP::INDEX NIL LISP::INDEXP) (LISP::START 0 LISP::STARTP) (LISP::END NIL LISP:ENDP)) &BODY (LISP::BODY LISP::DECLS)) `(LET* ((LISP::$STRING$ ,STRING) (LISP::$START$ ,LISP::START)) (DECLARE (LOCALVARS LISP::$STRING$ LISP::$START$)) (LISP:WITH-OPEN-STREAM (,LISP::VAR (LISP:MAKE-STRING-INPUT-STREAM LISP::$STRING$ LISP::$START$ ,LISP::END)) ,@LISP::DECLS ,@(LISP:IF LISP::INDEXP (* |;;| "This exists as a fudge for the fat string problem. It WILL GO AWAY when STRINGSTREAMS HAVE THEIR OWN DEVICE.") `((LISP:MULTIPLE-VALUE-PROG1 (PROGN ,@LISP::BODY) (* |;;| "(IF (FASL::FAT-STRING-P $STRING$) (SETF ,INDEX (+ $START$ (IL:IQUOTIENT (IL:GETFILEPTR ,VAR) 2))) (SETF ,INDEX (+ $START$ (IL:GETFILEPTR ,VAR))))") (LISP:SETF ,LISP::INDEX (+ LISP::$START$ (GETFILEPTR ,LISP::VAR))))) LISP::BODY)))) (DEFMACRO LISP:WITH-OUTPUT-TO-STRING ((LISP::VAR &OPTIONAL (STRING NIL LISP::ST-P) &KEY LISP::ELEMENT-TYPE) &BODY (LISP::FORMS LISP::DECLS)) (COND (STRING `(LISP:WITH-OPEN-STREAM (,LISP::VAR (MAKE-FILL-POINTER-OUTPUT-STREAM ,STRING)) ,@LISP::DECLS ,@LISP::FORMS)) (LISP::ELEMENT-TYPE `(LISP:WITH-OPEN-STREAM (,LISP::VAR (LISP:MAKE-STRING-OUTPUT-STREAM :ELEMENT-TYPE ,LISP::ELEMENT-TYPE)) ,@LISP::DECLS (PROGN ,@LISP::FORMS (LISP:GET-OUTPUT-STREAM-STRING ,LISP::VAR)))) (T `(LISP:WITH-OPEN-STREAM (,LISP::VAR (LISP:MAKE-STRING-OUTPUT-STREAM)) ,@LISP::DECLS (PROGN ,@LISP::FORMS (LISP:GET-OUTPUT-STREAM-STRING ,LISP::VAR)))))) (DEFMACRO LISP:WITH-OPEN-FILE ((VAR &REST OPEN-ARGS) &BODY (FORMS DECLS)) (* |;;;| "The file whose name is File-Name is opened using the OPEN-ARGS and bound to the variable VAR. The Forms are executed, and when they terminate, normally or otherwise, the file is closed.") (LET ((ABORTP (GENSYM))) `(LET ((,VAR (OPEN ,@OPEN-ARGS)) (,ABORTP T)) ,@DECLS (LISP:UNWIND-PROTECT (LISP:MULTIPLE-VALUE-PROG1 (PROGN ,@FORMS) (SETQ ,ABORTP NIL)) (LISP:CLOSE ,VAR :ABORT ,ABORTP))))) (DEFINLINE LISP:MAKE-STRING-OUTPUT-STREAM (&KEY (LISP::ELEMENT-TYPE 'LISP:STRING-CHAR)) (* |;;;| "A function for producing a string stream. See also the function get-output-stream-string. Also, see CLtL p. 330") (LET ((STREAM (MAKE-FILL-POINTER-OUTPUT-STREAM LISP::ELEMENT-TYPE))) STREAM)) (LISP:DEFUN MAKE-FILL-POINTER-OUTPUT-STREAM (&OPTIONAL (STRING (  %MAKE-INITIAL-STRING-STREAM-CONTENTS ))) (* \; "Edited 24-Mar-92 12:54 by jrb:") (DECLARE (GLOBALVARS \\FILL-POINTER-STREAM-DEVICE)) (* |;;| "HACK: STRING may also be a type; catch that here and fix it") (LISP:UNLESS (STRINGP STRING) (SETQ STRING (%MAKE-INITIAL-STRING-STREAM-CONTENTS STRING))) (|if| (NOT (LISP:ARRAY-HAS-FILL-POINTER-P STRING)) |then| (\\ILLEGAL.ARG STRING) |else| (LET ((STREAM (|create| STREAM DEVICE _ \\FILL-POINTER-STREAM-DEVICE F1 _ STRING ACCESS _ 'OUTPUT OTHERPROPS _ '(STRING-OUTPUT-STREAM T XCL:STRING-STREAM-P T)))) (* \;  "give it a canned property list to save some consing.") (|replace| (STREAM OUTCHARFN) |of| STREAM |with| (|if| (EXTENDABLE-ARRAY-P STRING) |then| (FUNCTION \\ADJUSTABLE-STRING-STREAM-OUTCHARFN) |else| (FUNCTION \\STRING-STREAM-OUTCHARFN))) (|replace| (STREAM STRMBOUTFN) |of| STREAM |with| (FUNCTION \\OUTCHAR)) STREAM))) (LISP:DEFUN LISP:GET-OUTPUT-STREAM-STRING (STRING-OUTPUT-STREAM) (* |;;;| "A CommonLisp function for getting the contents of the buffer created by a call to make-string-output-stream. See CLtL p. 330") (|if| (NOT (STREAMPROP STRING-OUTPUT-STREAM 'STRING-OUTPUT-STREAM)) |then| (ERROR "Stream not a string-output-stream" STRING-OUTPUT-STREAM) |else| (PROG1 (|fetch| (STREAM F1) |of| STRING-OUTPUT-STREAM) (|replace| (STREAM F1) |of| STRING-OUTPUT-STREAM |with| (  %MAKE-INITIAL-STRING-STREAM-CONTENTS ))))) (LISP:DEFUN \\STRING-STREAM-OUTCHARFN (STREAM CHAR) (IF (OR (IEQP (FETCH (STREAM CHARPOSITION) OF STREAM) (FETCH (STREAM LINELENGTH) OF STREAM)) (EQ CHAR (CHARCODE EOL))) THEN (REPLACE (STREAM CHARPOSITION) OF STREAM WITH 0) ELSE (ADD (FETCH (STREAM CHARPOSITION) OF STREAM) 1)) (LISP:VECTOR-PUSH (LISP:CHARACTER CHAR) (FETCH (STREAM F1) OF STREAM))) (LISP:DEFUN \\ADJUSTABLE-STRING-STREAM-OUTCHARFN (STREAM CHAR) (LET ((STRING (FETCH (STREAM F1) OF STREAM)) (CH (LISP:CHARACTER CHAR))) (IF (OR (IEQP (FETCH (STREAM CHARPOSITION) OF STREAM) (FETCH (STREAM LINELENGTH) OF STREAM)) (EQ CHAR (CHARCODE EOL))) THEN (REPLACE (STREAM CHARPOSITION) OF STREAM WITH 0) ELSE (ADD (FETCH (STREAM CHARPOSITION) OF STREAM) 1)) (* |;;| "Do the equivalent of VECTOR-PUSH-EXTEND inline to save the significant! overhead of calculating the new length at each character.") (LISP:UNLESS (LISP:VECTOR-PUSH CH STRING) (LET ((CURRENT-LENGTH (LISP:ARRAY-TOTAL-SIZE STRING))) (IF (>= CURRENT-LENGTH (LISP:1- LISP:ARRAY-TOTAL-SIZE-LIMIT)) THEN (PROCEED-CASE (LISP:ERROR 'END-OF-FILE :STREAM STREAM) (SI::RETRY-OUTCHAR NIL :REPORT "VECTOR-PUSH the character anyway" :CONDITION END-OF-FILE (LISP:VECTOR-PUSH CH (FETCH (STREAM F1) OF STREAM )))) ELSE (LISP:ADJUST-ARRAY STRING (MIN (LISP:1- LISP:ARRAY-TOTAL-SIZE-LIMIT) (+ CURRENT-LENGTH (MAX (LRSH CURRENT-LENGTH 1) *DEFAULT-PUSH-EXTENSION-SIZE* )))) (LISP:VECTOR-PUSH CH STRING)))))) (* |;;| "helpers") (LISP:DEFUN %NEW-FILE (FILENAME) (CLOSEF (OPENSTREAM FILENAME 'OUTPUT 'NEW))) (LISP:DEFUN PREDICT-NAME (PATHNAME) (LET ((PATH (LISP:PROBE-FILE PATHNAME))) (IF PATH THEN (LISP:NAMESTRING PATH)))) (DECLARE\: EVAL@COMPILE DONTCOPY (DEFMACRO INTERLISP-ACCESS (DIRECTION) `(CASE ,DIRECTION (:INPUT 'INPUT) (:OUTPUT 'OUTPUT) (:IO 'BOTH) (T NIL))) ) (* |;;| "methods for the special devices") (DEFINEQ (%BROADCAST-STREAM-DEVICE-BOUT (LAMBDA (STREAM BYTE) (* \; "Edited 13-Jan-87 14:45 by hdj") (* |;;| "The BOUT method for the broadcast-stream device") (|for| S |in| (|fetch| F1 |of| STREAM) |do| (\\BOUT S BYTE)) BYTE)) (%BROADCAST-STREAM-DEVICE-OUTCHARFN (LAMBDA (STREAM CHARCODE) (* \; "Edited 18-Mar-87 11:00 by lal") (* |;;| "outcharfn for broadcast streams") (* |;;| "Using the charposition from the first stream in the broadcast stream list") (|for| S |in| (|fetch| (STREAM F1) |of| STREAM) |do| (\\OUTCHAR S CHARCODE)) (|replace| (STREAM CHARPOSITION) |of| STREAM |with| (|fetch| (STREAM CHARPOSITION ) |of| (CAR (|fetch| (STREAM F1) |of| STREAM)))) CHARCODE)) (%BROADCAST-STREAM-DEVICE-CLOSEFILE (LAMBDA (STREAM) (* |hdj| "26-Mar-86 16:28") (* |;;;| "The CLOSEFILE method for the broadcast-stream device") (|replace| ACCESS |of| STREAM |with| NIL) (|replace| F1 |of| STREAM |with| NIL) STREAM)) (%BROADCAST-STREAM-DEVICE-FORCEOUTPUT (LAMBDA (|stream| |waitForFinish?|) (* |smL| "14-Aug-85 15:55") (* |;;;| "The FORCEOUTPUT method for the broadcast-stream device") (|for| S |in| (|fetch| F1 |of| |stream|) |do| (FORCEOUTPUT S |waitForFinish?| )))) ) (LISP:DEFUN %BROADCAST-STREAM-DEVICE-CHARSETFN (STREAM NEWVALUE) (* |;;| "charset function for broadcast streams. Not clear what the value should be, so we arbitrarily return the value of the last stream.") (FOR S IN (FETCH (STREAM F1) OF STREAM) DO (SETQ $$VAL (ACCESS-CHARSET S NEWVALUE)))) (DEFINEQ (%CONCATENATED-STREAM-DEVICE-BIN (LAMBDA (STREAM) (* \; "Edited 13-Jan-87 14:52 by hdj") (* |;;| "The BIN method for the concatenated-stream device") (WHILE (FETCH (STREAM F1) OF STREAM) DO (IF (EOFP (CAR (FETCH (STREAM F1) OF STREAM))) THEN (CLOSEF (POP (FETCH (STREAM F1) OF STREAM))) ELSE (RETURN (\\BIN (CAR (FETCH (STREAM F1) OF STREAM))))) FINALLY (* \; "the EOF case") (\\EOF.ACTION STREAM)))) (%CONCATENATED-STREAM-DEVICE-CLOSEFILE (LAMBDA (|stream|) (* |smL| "14-Aug-85 16:53") (* |;;;| "The CLOSEFILE method for the concatenated-stream device") (|replace| ACCESS |of| |stream| |with| NIL) (|for| S |in| (|fetch| F1 |of| |stream|) |do| (CLOSEF S)) (|replace| F1 |of| |stream| |with| NIL) |stream|)) (%CONCATENATED-STREAM-DEVICE-EOFP (LAMBDA (|stream|) (* \; "Edited 17-Mar-87 09:20 by lal") (* |;;;| "The EOFP method for the concatenated-stream device") (|while| (|fetch| F1 |of| |stream|) |do| (|if| (EOFP (CAR (|fetch| F1 |of| |stream|))) |then| (CLOSEF (|pop| (|fetch| F1 |of| |stream|))) |else| (RETURN NIL)) |finally| (* \; "the EOF case") (RETURN T)))) (%CONCATENATED-STREAM-DEVICE-PEEKBIN (LAMBDA (|stream| |noErrorFlg?|) (* |smL| "14-Aug-85 16:53") (* |;;;| "The PEEKBIN method for the concatenated-stream device") (|while| (|fetch| F1 |of| |stream|) |do| (|if| (EOFP (CAR (|fetch| F1 |of| |stream|))) |then| (CLOSEF (|pop| (|fetch| F1 |of| |stream|))) |else| (RETURN (\\PEEKBIN (CAR (|fetch| F1 |of| |stream|))))) |finally| (* \; "the EOF case") (|if| |noErrorFlg?| |then| (RETURN NIL) |else| (\\EOF.ACTION |stream|))))) (%CONCATENATED-STREAM-DEVICE-BACKFILEPTR (LAMBDA (|stream|) (* \; "Edited 24-Mar-87 10:47 by lal") (* |;;| "concatenated streams are read sequentially and a list of them are kept in F1. as they are read, the used stream is removed from the list. \\backfileptr will work because 1) when a file is stream is used up the new one is read, at least one character's worth and 2) \\backfileptr only needs to back up one character") (\\BACKFILEPTR (CAR (|fetch| F1 |of| |stream|))))) ) (LISP:DEFUN %CONCATENATED-STREAM-DEVICE-CHARSETFN (STREAM NEWVALUE) (* |;;| "the charset method for concatenated stream devices") (LET ((STREAMS (FETCH (STREAM F1) OF STREAM))) (IF STREAMS THEN (ACCESS-CHARSET (CAR STREAMS) NEWVALUE) ELSE 0))) (DEFINEQ (%ECHO-STREAM-DEVICE-BIN (LAMBDA (STREAM) (* |hdj| "21-Apr-86 18:33") (* |;;;| "The BIN method for the echo-stream device") (LET ((BYTE (%TWO-WAY-STREAM-DEVICE-BIN STREAM))) (\\BOUT STREAM BYTE) BYTE))) ) (LISP:DEFUN %SYNONYM-STREAM-DEVICE-GET-INDIRECT-STREAM (SYNONYM-STREAM) (* |;;| "given a synonym-stream, find out what it is currently tracking") (LISP:SYMBOL-VALUE (LISP:SYNONYM-STREAM-SYMBOL SYNONYM-STREAM))) (DEFINEQ (%SYNONYM-STREAM-DEVICE-BIN (LAMBDA (STREAM) (* |hdj| "19-Mar-86 17:19") (* |;;;| "The BIN method for the synonym-stream device.") (\\BIN (%SYNONYM-STREAM-DEVICE-GET-STREAM STREAM)))) (%SYNONYM-STREAM-DEVICE-BOUT (LAMBDA (STREAM BYTE) (* |hdj| "19-Mar-86 17:20") (* |;;;| "The BOUT method for the synonym-stream device.") (\\BOUT (%SYNONYM-STREAM-DEVICE-GET-STREAM STREAM) BYTE))) (%SYNONYM-STREAM-DEVICE-OUTCHARFN (LAMBDA (STREAM CHARCODE) (* \; "Edited 3-Jan-90 15:25 by jds") (* |;;| " OUTCHARFN for synonym streams") (LET ((OTHER-STREAM (%SYNONYM-STREAM-DEVICE-GET-STREAM STREAM))) (\\OUTCHAR OTHER-STREAM CHARCODE) (|freplace| (STREAM CHARPOSITION) |of| STREAM |with| (|ffetch| (STREAM CHARPOSITION ) |of| OTHER-STREAM))) )) (%SYNONYM-STREAM-DEVICE-CLOSEFILE (LAMBDA (STREAM) (* \; "Edited 18-Dec-87 12:17 by sye") (* |;;;| "the CLOSEFILE method for the synonym-stream device") (|replace| F1 |of| STREAM |with| NIL) (* |;;| "remove the synonym stream STREAM from the OPENFILELST field of %SYNONYM-STREAM-DEVICE") (|replace| (FDEV OPENFILELST) |of| %SYNONYM-STREAM-DEVICE |with| (DREMOVE STREAM (|fetch| (FDEV OPENFILELST) |of| %SYNONYM-STREAM-DEVICE))) STREAM)) (%SYNONYM-STREAM-DEVICE-EOFP (LAMBDA (STREAM) (* |hdj| "19-Mar-86 17:20") (* |;;;| "The EOFP method for the synonym-stream device.") (\\EOFP (%SYNONYM-STREAM-DEVICE-GET-STREAM STREAM)))) (%SYNONYM-STREAM-DEVICE-FORCEOUTPUT (LAMBDA (STREAM WAITFORFINISH) (* |hdj| "19-Mar-86 17:09") (* |;;;| "The FORCEOUTPUT method for the synonym-stream device.") (FORCEOUTPUT (%SYNONYM-STREAM-DEVICE-GET-STREAM STREAM) WAITFORFINISH))) (%SYNONYM-STREAM-DEVICE-GETFILEINFO (LAMBDA (STREAM ATTRIBUTE DEVICE) (* |hdj| "19-Mar-86 17:10") (* |;;;| "The GETFILEINFO method for the synonym-stream device.") (GETFILEINFO (%SYNONYM-STREAM-DEVICE-GET-STREAM STREAM) ATTRIBUTE))) (%SYNONYM-STREAM-DEVICE-PEEKBIN (LAMBDA (STREAM NOERRORFLG?) (* |hdj| "19-Mar-86 17:12") (* |;;;| "The PEEKBIN method for the synonym-stream device") (\\PEEKBIN (%SYNONYM-STREAM-DEVICE-GET-STREAM STREAM) NOERRORFLG?))) (%SYNONYM-STREAM-DEVICE-READP (LAMBDA (STREAM FLG) (READP (%SYNONYM-STREAM-DEVICE-GET-STREAM STREAM) FLG))) (%SYNONYM-STREAM-DEVICE-BACKFILEPTR (LAMBDA (STREAM) (* |hdj| "26-Aug-86 17:35") (\\BACKFILEPTR (%SYNONYM-STREAM-DEVICE-GET-STREAM STREAM)))) (%SYNONYM-STREAM-DEVICE-SETFILEINFO (LAMBDA (STREAM ATTRIBUTE VALUE DEVICE) (* |hdj| "19-Mar-86 17:17") (* |;;;| "The SETFILEINFO method for the synonym-stream device.") (SETFILEINFO (%SYNONYM-STREAM-DEVICE-GET-STREAM STREAM) ATTRIBUTE VALUE))) (%SYNONYM-STREAM-DEVICE-CHARSETFN (LAMBDA (STREAM NEWVALUE) (* \; "Edited 11-Sep-87 16:01 by bvm:") (* |;;| "The charset method for the synonym-stream device.") (ACCESS-CHARSET (%SYNONYM-STREAM-DEVICE-GET-STREAM STREAM) NEWVALUE))) ) (DEFINEQ (%TWO-WAY-STREAM-DEVICE-BIN (LAMBDA (|stream|) (* |smL| "14-Aug-85 16:44") (* |;;;| "The BIN method for the two-way-stream device") (\\BIN (|fetch| F1 |of| |stream|)))) (%TWO-WAY-STREAM-DEVICE-INPUTSTREAM (LAMBDA (|stream|) (* \; "Edited 14-Apr-87 16:59 by bvm:") (* |;;;| "Fetch the real input for the two-way-stream device") (|fetch| F1 |of| |stream|))) (%TWO-WAY-STREAM-DEVICE-BOUT (LAMBDA (STREAM BYTE) (* |hdj| "17-Sep-86 15:28") (* |;;| " the BOUT method for two-way streams") (\\BOUT (|fetch| F2 |of| STREAM) BYTE))) (%TWO-WAY-STREAM-DEVICE-OUTPUTSTREAM (LAMBDA (STREAM BYTE) (* \; "Edited 14-Apr-87 16:59 by bvm:") (* |;;| "Fetch the real output stream for two-way streams") (|fetch| F2 |of| STREAM))) (%TWO-WAY-STREAM-DEVICE-OUTCHARFN (LAMBDA (STREAM CHARCODE) (* \; "Edited 3-Jan-90 15:26 by jds") (* |;;| "outcharfn for two-way streams") (\\OUTCHAR (|fetch| (STREAM F2) |of| STREAM) CHARCODE) (|freplace| (STREAM CHARPOSITION) |of| STREAM |with| (|ffetch| (STREAM CHARPOSITION ) |of| (|ffetch| (STREAM F2) |of| STREAM)) ))) (%TWO-WAY-STREAM-DEVICE-CLOSEFILE (LAMBDA (|stream|) (* \; "Edited 18-Dec-87 12:32 by sye") (* |;;;| "The CLOSEFILE method for the two-way-stream device and echo-stream device") (LET ((STREAMDEVICE (|if| (XCL:TWO-WAY-STREAM-P |stream|) |then| %TWO-WAY-STREAM-DEVICE |else| %ECHO-STREAM-DEVICE))) (|replace| ACCESS |of| |stream| |with| NIL) (CLOSEF? (|fetch| F1 |of| |stream|)) (|replace| F1 |of| |stream| |with| NIL) (CLOSEF? (|fetch| F2 |of| |stream|)) (|replace| F2 |of| |stream| |with| NIL) (* |;;|  "remove STREAM from the OPENFILELST field of %TWO-WAY-STREAM-DEVICE or %ECHO-STREAM-DEVICE") (|replace| (FDEV OPENFILELST) |of| STREAMDEVICE |with| (DREMOVE |stream| (|fetch| (FDEV OPENFILELST ) |of| STREAMDEVICE))) |stream|))) (%TWO-WAY-STREAM-DEVICE-EOFP (LAMBDA (|stream|) (* |smL| "14-Aug-85 16:47") (* |;;;| "The EOFP method for the two-way-stream device") (\\EOFP (|fetch| F1 |of| |stream|)))) (%TWO-WAY-STREAM-DEVICE-READP (LAMBDA (STREAM FLG) (* \; "Edited 14-Apr-87 17:01 by bvm:") (* |;;;| "The READP method for the two-way-stream device") (READP (|fetch| F1 |of| STREAM) FLG))) (%TWO-WAY-STREAM-DEVICE-BACKFILEPTR (LAMBDA (STREAM) (* |hdj| "15-Sep-86 15:02") (\\BACKFILEPTR (|fetch| (STREAM F1) |of| STREAM)))) (%TWO-WAY-STREAM-DEVICE-FORCEOUTPUT (LAMBDA (|stream| |waitForFinish?|) (* |smL| "14-Aug-85 16:49") (* |;;;| "the FORCEOUTPUT method for the two-way-stream device") (FORCEOUTPUT (|fetch| F2 |of| |stream|) |waitForFinish?|))) (%TWO-WAY-STREAM-DEVICE-PEEKBIN (LAMBDA (|stream| |noErrorFlg?|) (* |smL| "14-Aug-85 16:46") (* |;;;| "The PEEKBIN method for the two-way-stream device") (\\PEEKBIN (|fetch| F1 |of| |stream|) |noErrorFlg?|))) (%TWO-WAY-STREAM-DEVICE-CHARSETFN (LAMBDA (STREAM NEWVALUE) (* \; "Edited 11-Sep-87 16:00 by bvm:") (* |;;| "The charset method for two-way streams. Unclear what this is supposed to mean--let's apply it only to the input side (in which case newvalue is senseless)") (ACCESS-CHARSET (|fetch| (STREAM F1) |of| STREAM) NEWVALUE))) ) (LISP:DEFUN %FILL-POINTER-STREAM-DEVICE-CLOSEFILE (STREAM &OPTIONAL ABORTFLAG) (* |;;;| "the CLOSEFILE method for the fill-pointer-string-stream device") (|replace| F1 |of| STREAM |with| NIL) STREAM) (LISP:DEFUN %FILL-POINTER-STREAM-DEVICE-GETFILEPTR (STREAM) (LISP:LENGTH (|fetch| (STREAM F1) |of| STREAM))) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS %SYNONYM-STREAM-DEVICE %BROADCAST-STREAM-DEVICE %CONCATENATED-STREAM-DEVICE %TWO-WAY-STREAM-DEVICE %ECHO-STREAM-DEVICE \\FILL-POINTER-STREAM-DEVICE) ) (* |;;| "helper stuff") (DEFINEQ (%SYNONYM-STREAM-DEVICE-GET-STREAM (LAMBDA (|stream|) (* \; "Edited 12-Jan-87 14:46 by hdj") (* |;;| "given a synonym-stream, find out what it is currently tracking") (LISP:SYMBOL-VALUE (|fetch| (STREAM F1) |of| |stream|)))) ) (* |;;| "module initialization") (LISP:DEFVAR *DEBUG-IO*) (LISP:DEFVAR *QUERY-IO*) (LISP:DEFVAR *TERMINAL-IO*) (LISP:DEFVAR *ERROR-OUTPUT*) (LISP:DEFVAR *STANDARD-OUTPUT*) (LISP:DEFVAR *STANDARD-INPUT*) (LISP:DEFUN %INITIALIZE-STANDARD-STREAMS () (* |;;|  "Called when CLSTREAMS is loaded. Almost everything is same as *TERMINAL-IO* to start with.") (LISP:SETQ *QUERY-IO* (LISP:MAKE-TWO-WAY-STREAM (LISP:MAKE-SYNONYM-STREAM '\\LINEBUF.OFD) (LISP:MAKE-SYNONYM-STREAM '\\TERM.OFD))) (LISP:SETQ *DEBUG-IO* *QUERY-IO*) (LISP:SETQ *TERMINAL-IO* *QUERY-IO*) (LISP:SETQ *ERROR-OUTPUT* (LISP:MAKE-SYNONYM-STREAM '\\TERM.OFD))) (DEFINEQ (%INITIALIZE-CLSTREAM-TYPES (LAMBDA NIL (* \; "Edited 14-Apr-87 17:08 by bvm:") (* |;;| "Initialize the CLSTREAMS package. This sets up some file devices for the functions make-two-way-stream-device, etc. See CLtL chapter 21") (SETQ %BROADCAST-STREAM-DEVICE (|create| FDEV DEVICENAME _ 'BROADCAST-STREAM-DEVICE RESETABLE _ NIL RANDOMACCESSP _ NIL NODIRECTORIES _ T BUFFERED _ NIL PAGEMAPPED _ NIL FDBINABLE _ NIL FDBOUTABLE _ NIL FDEXTENDABLE _ NIL DEVICEINFO _ NIL HOSTNAMEP _ (FUNCTION NILL) EVENTFN _ (FUNCTION NILL) DIRECTORYNAMEP _ (FUNCTION NILL) REOPENFILE _ (FUNCTION NILL) CLOSEFILE _ (FUNCTION %BROADCAST-STREAM-DEVICE-CLOSEFILE) GETFILENAME _ (FUNCTION NILL) DELETEFILE _ (FUNCTION NILL) GENERATEFILES _ (FUNCTION \\GENERATENOFILES) RENAMEFILE _ (FUNCTION NILL) BIN _ (FUNCTION NILL) BOUT _ (FUNCTION %BROADCAST-STREAM-DEVICE-BOUT) PEEKBIN _ (FUNCTION NILL) READP _ (FUNCTION NILL) EOFP _ (FUNCTION TRUE) BLOCKIN _ (FUNCTION \\GENERIC.BINS) BLOCKOUT _ (FUNCTION NILL) FORCEOUTPUT _ (FUNCTION %BROADCAST-STREAM-DEVICE-FORCEOUTPUT) GETFILEINFO _ (FUNCTION NILL) SETFILEINFO _ (FUNCTION NILL) CHARSETFN _ (FUNCTION %BROADCAST-STREAM-DEVICE-CHARSETFN))) (SETQ %CONCATENATED-STREAM-DEVICE (|create| FDEV DEVICENAME _ 'CONCATENATED-STREAM-DEVICE RESETABLE _ NIL RANDOMACCESSP _ NIL NODIRECTORIES _ T BUFFERED _ NIL PAGEMAPPED _ NIL FDBINABLE _ NIL FDBOUTABLE _ NIL FDEXTENDABLE _ NIL DEVICEINFO _ NIL HOSTNAMEP _ (FUNCTION NILL) EVENTFN _ (FUNCTION NILL) DIRECTORYNAMEP _ (FUNCTION NILL) REOPENFILE _ (FUNCTION NILL) CLOSEFILE _ (FUNCTION %CONCATENATED-STREAM-DEVICE-CLOSEFILE) GETFILENAME _ (FUNCTION NILL) DELETEFILE _ (FUNCTION NILL) GENERATEFILES _ (FUNCTION \\GENERATENOFILES) RENAMEFILE _ (FUNCTION NILL) BIN _ (FUNCTION %CONCATENATED-STREAM-DEVICE-BIN) BOUT _ (FUNCTION NILL) PEEKBIN _ (FUNCTION %CONCATENATED-STREAM-DEVICE-PEEKBIN) READP _ (FUNCTION \\GENERIC.READP) BACKFILEPTR _ (FUNCTION %CONCATENATED-STREAM-DEVICE-BACKFILEPTR) EOFP _ (FUNCTION %CONCATENATED-STREAM-DEVICE-EOFP) BLOCKIN _ (FUNCTION \\GENERIC.BINS) BLOCKOUT _ (FUNCTION NILL) FORCEOUTPUT _ (FUNCTION NILL) GETFILEINFO _ (FUNCTION NILL) SETFILEINFO _ (FUNCTION NILL) CHARSETFN _ (FUNCTION %CONCATENATED-STREAM-DEVICE-CHARSETFN))) (SETQ %TWO-WAY-STREAM-DEVICE (|create| FDEV DEVICENAME _ 'TWO-WAY-STREAM-DEVICE RESETABLE _ NIL RANDOMACCESSP _ NIL NODIRECTORIES _ T BUFFERED _ NIL PAGEMAPPED _ NIL FDBINABLE _ NIL FDBOUTABLE _ NIL FDEXTENDABLE _ NIL INPUT-INDIRECTED _ T OUTPUT-INDIRECTED _ T DEVICEINFO _ NIL HOSTNAMEP _ (FUNCTION NILL) EVENTFN _ (FUNCTION NILL) DIRECTORYNAMEP _ (FUNCTION NILL) REOPENFILE _ (FUNCTION NILL) CLOSEFILE _ (FUNCTION %TWO-WAY-STREAM-DEVICE-CLOSEFILE) GETFILENAME _ (FUNCTION NILL) DELETEFILE _ (FUNCTION NILL) GENERATEFILES _ (FUNCTION \\GENERATENOFILES) RENAMEFILE _ (FUNCTION NILL) BIN _ (FUNCTION %TWO-WAY-STREAM-DEVICE-BIN) BOUT _ (FUNCTION %TWO-WAY-STREAM-DEVICE-BOUT) PEEKBIN _ (FUNCTION %TWO-WAY-STREAM-DEVICE-PEEKBIN) READP _ (FUNCTION %TWO-WAY-STREAM-DEVICE-READP) BACKFILEPTR _ (FUNCTION %TWO-WAY-STREAM-DEVICE-BACKFILEPTR) EOFP _ (FUNCTION %TWO-WAY-STREAM-DEVICE-EOFP) BLOCKIN _ (FUNCTION \\GENERIC.BINS) BLOCKOUT _ (FUNCTION \\GENERIC.BOUTS) FORCEOUTPUT _ (FUNCTION %TWO-WAY-STREAM-DEVICE-FORCEOUTPUT) GETFILEINFO _ (FUNCTION NILL) SETFILEINFO _ (FUNCTION NILL) CHARSETFN _ (FUNCTION %TWO-WAY-STREAM-DEVICE-CHARSETFN) INPUTSTREAM _ (FUNCTION %TWO-WAY-STREAM-DEVICE-INPUTSTREAM) OUTPUTSTREAM _ (FUNCTION %TWO-WAY-STREAM-DEVICE-OUTPUTSTREAM))) (SETQ %ECHO-STREAM-DEVICE (|create| FDEV |using| %TWO-WAY-STREAM-DEVICE DEVICENAME _ 'ECHO-STREAM-DEVICE BIN _ (FUNCTION %ECHO-STREAM-DEVICE-BIN))) (SETQ %SYNONYM-STREAM-DEVICE (|create| FDEV DEVICENAME _ 'SYNONYM-STREAM-DEVICE RESETABLE _ NIL RANDOMACCESSP _ NIL NODIRECTORIES _ T BUFFERED _ NIL PAGEMAPPED _ NIL FDBINABLE _ NIL FDBOUTABLE _ NIL FDEXTENDABLE _ NIL DEVICEINFO _ NIL INPUT-INDIRECTED _ T OUTPUT-INDIRECTED _ T HOSTNAMEP _ (FUNCTION NILL) EVENTFN _ (FUNCTION NILL) DIRECTORYNAMEP _ (FUNCTION NILL) REOPENFILE _ (FUNCTION NILL) CLOSEFILE _ (FUNCTION %SYNONYM-STREAM-DEVICE-CLOSEFILE) GETFILENAME _ (FUNCTION NILL) DELETEFILE _ (FUNCTION NILL) GENERATEFILES _ (FUNCTION \\GENERATENOFILES) RENAMEFILE _ (FUNCTION NILL) BIN _ (FUNCTION %SYNONYM-STREAM-DEVICE-BIN) BOUT _ (FUNCTION %SYNONYM-STREAM-DEVICE-BOUT) PEEKBIN _ (FUNCTION %SYNONYM-STREAM-DEVICE-PEEKBIN) READP _ (FUNCTION %SYNONYM-STREAM-DEVICE-READP) BACKFILEPTR _ (FUNCTION %SYNONYM-STREAM-DEVICE-BACKFILEPTR) EOFP _ (FUNCTION %SYNONYM-STREAM-DEVICE-EOFP) BLOCKIN _ (FUNCTION \\GENERIC.BINS) BLOCKOUT _ (FUNCTION \\GENERIC.BOUTS) FORCEOUTPUT _ (FUNCTION %SYNONYM-STREAM-DEVICE-FORCEOUTPUT) GETFILEINFO _ (FUNCTION %SYNONYM-STREAM-DEVICE-GETFILEINFO) SETFILEINFO _ (FUNCTION %SYNONYM-STREAM-DEVICE-SETFILEINFO) INPUTSTREAM _ (FUNCTION %SYNONYM-STREAM-DEVICE-GET-INDIRECT-STREAM) OUTPUTSTREAM _ (FUNCTION %SYNONYM-STREAM-DEVICE-GET-INDIRECT-STREAM) CHARSETFN _ (FUNCTION %SYNONYM-STREAM-DEVICE-CHARSETFN))) (SETQ \\FILL-POINTER-STREAM-DEVICE (|create| FDEV DEVICENAME _ 'FILL-POINTER-STREAM-DEVICE RESETABLE _ NIL RANDOMACCESSP _ NIL NODIRECTORIES _ T BUFFERED _ NIL PAGEMAPPED _ NIL FDBINABLE _ NIL FDBOUTABLE _ NIL FDEXTENDABLE _ NIL DEVICEINFO _ NIL HOSTNAMEP _ (FUNCTION NILL) EVENTFN _ (FUNCTION NILL) DIRECTORYNAMEP _ (FUNCTION NILL) OPENFILE _ (FUNCTION NILL) REOPENFILE _ (FUNCTION NILL) CLOSEFILE _ (FUNCTION %FILL-POINTER-STREAM-DEVICE-CLOSEFILE) GETFILENAME _ (FUNCTION NILL) DELETEFILE _ (FUNCTION NILL) GENERATEFILES _ (FUNCTION \\GENERATENOFILES) RENAMEFILE _ (FUNCTION NILL) BIN _ (FUNCTION \\ILLEGAL.DEVICEOP) BOUT _ (FUNCTION NILL) PEEKBIN _ (FUNCTION \\ILLEGAL.DEVICEOP) READP _ (FUNCTION \\ILLEGAL.DEVICEOP) EOFP _ (FUNCTION NILL) BLOCKIN _ (FUNCTION \\ILLEGAL.DEVICEOP) BLOCKOUT _ (FUNCTION \\GENERIC.BOUTS) FORCEOUTPUT _ (FUNCTION NILL) GETFILEPTR _ (FUNCTION %FILL-POINTER-STREAM-DEVICE-GETFILEPTR) SETFILEINFO _ (FUNCTION \\ILLEGAL.DEVICEOP))))) ) (DECLARE\: DONTEVAL@LOAD DOCOPY (%INITIALIZE-CLSTREAM-TYPES) (%INITIALIZE-STANDARD-STREAMS) ) (PUTPROPS CLSTREAMS FILETYPE LISP:COMPILE-FILE) (PUTPROPS CLSTREAMS COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1991 1992 1993)) (DECLARE\: DONTCOPY (FILEMAP (NIL (35395 37407 (%BROADCAST-STREAM-DEVICE-BOUT 35405 . 35708) ( %BROADCAST-STREAM-DEVICE-OUTCHARFN 35710 . 36678) (%BROADCAST-STREAM-DEVICE-CLOSEFILE 36680 . 37012) ( %BROADCAST-STREAM-DEVICE-FORCEOUTPUT 37014 . 37405)) (37825 40759 (%CONCATENATED-STREAM-DEVICE-BIN 37835 . 38468) (%CONCATENATED-STREAM-DEVICE-CLOSEFILE 38470 . 38896) (%CONCATENATED-STREAM-DEVICE-EOFP 38898 . 39473) (%CONCATENATED-STREAM-DEVICE-PEEKBIN 39475 . 40206) ( %CONCATENATED-STREAM-DEVICE-BACKFILEPTR 40208 . 40757)) (41099 41397 (%ECHO-STREAM-DEVICE-BIN 41109 . 41395)) (41630 45502 (%SYNONYM-STREAM-DEVICE-BIN 41640 . 41889) (%SYNONYM-STREAM-DEVICE-BOUT 41891 . 42159) (%SYNONYM-STREAM-DEVICE-OUTCHARFN 42161 . 42868) (%SYNONYM-STREAM-DEVICE-CLOSEFILE 42870 . 43427) (%SYNONYM-STREAM-DEVICE-EOFP 43429 . 43681) (%SYNONYM-STREAM-DEVICE-FORCEOUTPUT 43683 . 43979) (%SYNONYM-STREAM-DEVICE-GETFILEINFO 43981 . 44273) (%SYNONYM-STREAM-DEVICE-PEEKBIN 44275 . 44558) ( %SYNONYM-STREAM-DEVICE-READP 44560 . 44692) (%SYNONYM-STREAM-DEVICE-BACKFILEPTR 44694 . 44895) ( %SYNONYM-STREAM-DEVICE-SETFILEINFO 44897 . 45195) (%SYNONYM-STREAM-DEVICE-CHARSETFN 45197 . 45500)) ( 45503 50475 (%TWO-WAY-STREAM-DEVICE-BIN 45513 . 45749) (%TWO-WAY-STREAM-DEVICE-INPUTSTREAM 45751 . 46005) (%TWO-WAY-STREAM-DEVICE-BOUT 46007 . 46254) (%TWO-WAY-STREAM-DEVICE-OUTPUTSTREAM 46256 . 46510) (%TWO-WAY-STREAM-DEVICE-OUTCHARFN 46512 . 47374) (%TWO-WAY-STREAM-DEVICE-CLOSEFILE 47376 . 48798) ( %TWO-WAY-STREAM-DEVICE-EOFP 48800 . 49039) (%TWO-WAY-STREAM-DEVICE-READP 49041 . 49306) ( %TWO-WAY-STREAM-DEVICE-BACKFILEPTR 49308 . 49504) (%TWO-WAY-STREAM-DEVICE-FORCEOUTPUT 49506 . 49792) ( %TWO-WAY-STREAM-DEVICE-PEEKBIN 49794 . 50067) (%TWO-WAY-STREAM-DEVICE-CHARSETFN 50069 . 50473)) (51071 51379 (%SYNONYM-STREAM-DEVICE-GET-STREAM 51081 . 51377)) (52117 60299 (%INITIALIZE-CLSTREAM-TYPES 52127 . 60297))))) STOP