(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10) (FILECREATED "26-Apr-2026 23:27:40" {WMEDLEY}FILEIO.;146 165936 :EDIT-BY rmk :CHANGES-TO (FNS \DO.PARAMS.AT.OPEN) :PREVIOUS-DATE "26-Apr-2026 21:00:55" {WMEDLEY}FILEIO.;145) (PRETTYCOMPRINT FILEIOCOMS) (RPAQQ FILEIOCOMS [(PROP (FILETYPE MAKEFILE-ENVIRONMENT) FILEIO) (* ;; "Device independent IO. This file is used by VAX") (COMS (* ;; "STREAM, FDEV declarations") (DECLARE%: FIRST DOCOPY (* ;; "The microcode relies on STREAM being of a particular type, viz. the first type declared in the initial loadup (after VMEMPAGEP)") (INITRECORDS STREAM)) (SYSRECORDS STREAM) (DECLARE%: DONTCOPY (EXPORT (RECORDS STREAM) (MACROS STREAMOP) (CONSTANTS AppendBit NoBits ReadBit WriteBit (OutputBits (LOGOR AppendBit WriteBit)) (BothBits (LOGOR ReadBit OutputBits))) (MACROS TestMasked APPENDABLE APPENDONLY DIRTYABLE OPENED OVERWRITEABLE READABLE READONLY WRITEABLE) (CONSTANTS * EOLCONVENTIONS))) (FNS STREAMPROP GETSTREAMPROP PUTSTREAMPROP STREAMP) [COMS (* ; "make streams print pretty") (FNS \DEFPRINT.BY.NAME \STREAM.DEFPRINT \FDEV.DEFPRINT) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (DEFPRINT 'STREAM (FUNCTION \STREAM.DEFPRINT)) (DEFPRINT 'FDEV (FUNCTION \FDEV.DEFPRINT] (COMS (* ; "Needed because of STREAM initialization") (INITVARS (FILELINELENGTH 102) (\STREAM.DEFAULT.MAXBUFFERS 3))) (FNS \GETACCESS \SETACCESS) (DECLARE%: DONTCOPY (EXPORT (MACROS FDEVOP \RECOGNIZE-HACK) (RECORDS FDEV FILEGENOBJ))) (INITRECORDS FDEV) (SYSRECORDS FDEV)) (COMS (* ; "Device operations") (FNS \DEFINEDEVICE \GETDEVICEFROMNAME \GETDEVICEFROMHOSTNAME \REMOVEDEVICE \REMOVEDEVICE.NAMES) (INITVARS (STREAM-AFTER-OPEN-FNS NIL)) (FNS \CLOSEFILE \DELETEFILE \DEVICEEVENT \GENERATEFILES \GENERATENEXTFILE \GENERATEFILEINFO \GETFILENAME \GENERIC.OUTFILEP \OPENFILE \DO.PARAMS.AT.OPEN \RENAMEFILE \REVALIDATEFILE \PAGED.REVALIDATEFILELST \PAGED.REVALIDATEFILES \PAGED.REVALIDATEFILE \BUFFERED.REVALIDATEFILE \BUFFERED.REVALIDATEFILELST \PRINT-REVALIDATION-RESULT \TRUNCATEFILE \FILE-CONFLICT) (COMS (* ; "Generic enumerator") (FNS \GENERATENOFILES \NULLFILEGENERATOR \NOFILESNEXTFILEFN \NOFILESINFOFN) (DECLARE%: DONTCOPY (RECORDS NOFILEGENSTATE))) (FNS \FILE.NOT.OPEN \FILE.WONT.OPEN \ILLEGAL.DEVICEOP \IS.NOT.RANDACCESSP \STREAM.NOT.OPEN) (ADDVARS (\FILEDEVICES) (\FILEDEVICENAMES) (\DEVICENAMETODEVICE)) (COMS (* ; "Device instances") (FNS \FDEVINSTANCE) (MACROS \INHERITFDEVOP.D \INHERITFDEVOP.S)) (INITVARS (LOGINHOST/DIR '{DSK}) (\CONNECTED.DIRECTORY '{DSK})) (GLOBALVARS LOGINHOST/DIR \CONNECTED.DIRECTORY \FILEDEVICES \FILEDEVICENAMES \DEVICENAMETODEVICE)) (COMS (* ; "Directory defaulting") (FNS CNDIR DIRECTORYNAME DIRECTORYNAMEP HOSTNAMEP \ADD.CONNECTED.DIR)) [COMS (* ; "Binary I/O Public functions") (FNS \BACKFILEPTR \BACKPEEKBIN \BACKBIN BIN \BIN \BINS BOUT \BOUT \BOUTS COPYBYTES COPYCHARS COPYFILE \COPYOPENFILE \INFER.FILE.TYPE EOFP FORCEOUTPUT \FLUSH.OPEN.STREAMS CHARSET ACCESS-CHARSET GETEOFPTR GETFILEINFO \TYPE.FROM.FILETYPE \FILETYPE.FROM.TYPE GETFILEPTR SETFILEINFO SETFILEPTR BOUT16 BIN16) (PROP (DOPCODE) BOUT) (* ; "Generic functions") (FNS \GENERIC.BINS \GENERIC.BOUTS \GENERIC.RENAMEFILE \GENERIC.OPENP \GENERIC.READP \GENERIC.CHARSET) (FNS \MAP-OPEN-STREAMS) [INITVARS (FILING.TYPES '((BINARY 0) (DIRECTORY 1) (TEXT 2) (SERIALIZED 3) (INTERPRESS 4361) (TEDIT 6056) (FASL 6057) (LAFITE 6058] (GLOBALVARS FILING.TYPES) (DECLARE%: EVAL@COMPILE DONTCOPY (EXPORT (MACROS \DEVICE-OPEN-STREAMS \CONVERT-PATHNAME ) (OPTIMIZERS ACCESS-CHARSET))) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MAPC '((FORCEOUTPUT FLUSHOUTPUT) (FORCEOUTPUT FLUSHMAP) (\GENERIC.BINS \NONPAGEDBINS) (\GENERIC.BOUTS \NONPAGEDBOUTS)) (FUNCTION (LAMBDA (PAIR) (PUTD (CADR PAIR) (GETD (CAR PAIR)) T] (COMS (* ; "Internal functions") (FNS \EOF.ACTION \EOSERROR \GETEOFPTR \INCFILEPTR \PEEKBIN \SETCLOSEDFILELENGTH \SETEOFPTR \SETFILEPTR) (FNS \FIXPOUT \FIXPIN) (FNS \BOUTEOL) (DECLARE%: DONTCOPY (EXPORT (MACROS \DECFILEPTR \GETFILEPTR \SIGNEDWIN \SIGNEDWOUT \WIN \WOUT \BINS \BOUTS \EOFP SIZE.FROM.LENGTH) (CONSTANTS BitsPerByte (ByteOffsetSize (SELECTQ (SYSTEMTYPE) (VAX 10) 9)) WordsPerPage) [CONSTANTS (\MAXFILEPTR (SUB1 (LLSH 1 30] (RECORDS BYTEPTR)) (CONSTANTS MaxChar))) (COMS (* ; "Buffered IO") (FNS \BUFFERED.BIN \BUFFERED.PEEKBIN \BUFFERED.BOUT \BUFFERED.BINS \BUFFERED.BOUTS \BUFFERED.COPYBYTES)) (LOCALVARS . T) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA \IS.NOT.RANDACCESSP \ILLEGAL.DEVICEOP STREAMPROP]) (PUTPROPS FILEIO FILETYPE :BCOMPL) (PUTPROPS FILEIO MAKEFILE-ENVIRONMENT (:PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)) (* ;; "Device independent IO. This file is used by VAX") (* ;; "STREAM, FDEV declarations") (DECLARE%: FIRST DOCOPY (/DECLAREDATATYPE 'STREAM '(WORD WORD FLAG (BITS 3) POINTER BYTE BYTE WORD WORD WORD FLAG FLAG FLAG FLAG POINTER FLAG FLAG FLAG FLAG POINTER FLAG (BITS 2) FLAG POINTER POINTER POINTER WORD WORD POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER POINTER POINTER POINTER POINTER) '((STREAM 0 (BITS . 15)) (STREAM 1 (BITS . 15)) (STREAM 2 (FLAGBITS . 0)) (STREAM 2 (BITS . 18)) (STREAM 2 POINTER) (STREAM 4 (BITS . 7)) (STREAM 4 (BITS . 135)) (STREAM 5 (BITS . 15)) (STREAM 6 (BITS . 15)) (STREAM 7 (BITS . 15)) (STREAM 8 (FLAGBITS . 0)) (STREAM 8 (FLAGBITS . 16)) (STREAM 8 (FLAGBITS . 32)) (STREAM 8 (FLAGBITS . 48)) (STREAM 8 POINTER) (STREAM 10 (FLAGBITS . 0)) (STREAM 10 (FLAGBITS . 16)) (STREAM 10 (FLAGBITS . 32)) (STREAM 10 (FLAGBITS . 48)) (STREAM 10 POINTER) (STREAM 12 (FLAGBITS . 0)) (STREAM 12 (BITS . 17)) (STREAM 12 (FLAGBITS . 48)) (STREAM 12 POINTER) (STREAM 14 POINTER) (STREAM 16 POINTER) (STREAM 18 (BITS . 15)) (STREAM 19 (BITS . 15)) (STREAM 20 POINTER) (STREAM 22 POINTER) (STREAM 24 POINTER) (STREAM 26 POINTER) (STREAM 28 POINTER) (STREAM 30 (BITS . 15)) (STREAM 31 (BITS . 15)) (STREAM 32 (BITS . 15)) (STREAM 33 (BITS . 15)) (STREAM 34 POINTER) (STREAM 36 POINTER) (STREAM 38 POINTER) (STREAM 40 POINTER) (STREAM 42 POINTER) (STREAM 44 POINTER) (STREAM 46 POINTER) (STREAM 48 POINTER) (STREAM 50 POINTER) (STREAM 52 (BITS . 15)) (STREAM 53 (BITS . 15)) (STREAM 54 POINTER) (STREAM 56 POINTER) (STREAM 58 POINTER) (STREAM 60 POINTER) (STREAM 62 POINTER)) '64) ) (ADDTOVAR SYSTEMRECLST (DATATYPE STREAM ((COFFSET WORD) (CBUFSIZE WORD) (PEEKEDCHARP FLAG) (ACCESSBITS BITS 3) (CBUFPTR POINTER) (BYTESIZE BYTE) (CHARSET BYTE) (PEEKEDCHAR WORD) (CHARPOSITION WORD) (CBUFMAXSIZE WORD) (NONDEFAULTDATEFLG FLAG) (REVALIDATEFLG FLAG) (MULTIBUFFERHINT FLAG) (USERCLOSEABLE FLAG) (FULLFILENAME POINTER) (BINABLE FLAG) (BOUTABLE FLAG) (EXTENDABLE FLAG) (CBUFDIRTY FLAG) (DEVICE POINTER) (USERVISIBLE FLAG) (EOLCONVENTION BITS 2) (READONLY-EXTERNALFORMAT FLAG) (VALIDATION POINTER) (CPAGE POINTER) (EPAGE POINTER) (EOFFSET WORD) (LINELENGTH WORD) (F1 POINTER) (F2 POINTER) (F3 POINTER) (F4 POINTER) (F5 POINTER) (FW6 WORD) (FW7 WORD) (FW8 WORD) (FW9 WORD) (F10 POINTER) (STRMBINFN POINTER) (STRMBOUTFN POINTER) (OUTCHARFN POINTER) (ENDOFSTREAMOP POINTER) (OTHERPROPS POINTER) (IMAGEOPS POINTER) (IMAGEDATA POINTER) (BUFFS POINTER) (MAXBUFFERS WORD) (LASTCCODE WORD) (EXTRASTREAMOP POINTER) (INCCODEFN POINTER) (PEEKCCODEFN POINTER) (BACKCCODEFN POINTER) (EXTERNALFORMAT POINTER))) ) (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (DATATYPE STREAM ( (* ;; "First 8 words are fixed for BIN, BOUT opcodes. Used to require length of whole datatype be multiple of 4, but Dolphin dead now.") (COFFSET WORD) (* ; "Offset in CPPTR of next bin or bout") (CBUFSIZE WORD) (* ; "Offset past last byte in that buffer") (PEEKEDCHARP FLAG) (* ; "if true, PEEKEDCHAR contains value of recent call to unread-char") (ACCESSBITS BITS 3) (* ; "What kind of access file is open for (read, write, append)") (CBUFPTR POINTER) (* ; "Pointer to current buffer") (BYTESIZE BYTE) (* ; "Byte size of stream, always 8 for now") (CHARSET BYTE) (* ; "the current character set for this stream. If 255, stream is not runcoded, so read-char consumes two bytes every time") (PEEKEDCHAR WORD) (* ; "value of unread-char call") (CHARPOSITION WORD) (* ; "Used by POSITION etc.") (CBUFMAXSIZE WORD) (* ; "on output, the size of the physical buffer--can't extend beyond this") (* ;; "-------- Above fields (8 words) potentially known to microcode. --------") (NONDEFAULTDATEFLG FLAG) (REVALIDATEFLG FLAG) (MULTIBUFFERHINT FLAG) (* ; "True if stream likes to read and write more than one buffer at a time") (USERCLOSEABLE FLAG) (* ; "Can be closed by CLOSEF; NIL for terminal, dribble...") (FULLFILENAME POINTER) (* ; "Name by which file is known to user") (BINABLE FLAG) (* ; "BIN punts unless this bit on") (BOUTABLE FLAG) (* ; "BOUT punts unless this bit on") (EXTENDABLE FLAG) (* ; "BOUT punts when COFFSET ge CBUFFSIZE unless this bit set and COFFSET lt 512") (CBUFDIRTY FLAG) (* ; "true if BOUT has sullied the current buffer") (DEVICE POINTER) (* ; "FDEV of this guy") (USERVISIBLE FLAG) (* ; "Listed by OPENP; NIL for terminal, dribble ...") (EOLCONVENTION BITS 2) (* ; "End-of-line convention") (READONLY-EXTERNALFORMAT FLAG) (* ; "T if external format can only be set at open.") (* ; "Was NOTXCCS.") (VALIDATION POINTER) (* ; "A number somehow identifying file, used to determine if file has changed in our absence") (CPAGE POINTER) (* ; "CPAGE,,COFFSET constitutes current file pointer for most randaccess streams") (EPAGE POINTER) (EOFFSET WORD) (* ; "Page, byte offset of eof") (LINELENGTH WORD) (* ; "LINELENGTH of stream, or -1 for no line length") (* ;; "----Following are device-specific fields----") (* ;; "Available for device-specific uses, NOT for application use.") (F1 POINTER) (F2 POINTER) (F3 POINTER) (F4 POINTER) (F5 POINTER) (FW6 WORD) (FW7 WORD) (FW8 WORD) (FW9 WORD) (F10 POINTER) (* ;; "----Following only filled in for open streams----") (STRMBINFN POINTER) (* ; "Either the BIN fn from the FDEV, or a trap") (STRMBOUTFN POINTER) (* ; "Either the BIN fn from the FDEV, or a trap") (OUTCHARFN POINTER) (* ; "Called by \OUTCHAR, the normal character printer.") (ENDOFSTREAMOP POINTER) (* ; "Called if EOF and we try to read.") (OTHERPROPS POINTER) (* ; "PROP LIST for holding other info.") (IMAGEOPS POINTER) (* ; "Image operations vector") (IMAGEDATA POINTER) (* ; "Image instance variables--format depends on IMAGEOPS value") (BUFFS POINTER) (* ; "Buffer chain for pmapped streams") (MAXBUFFERS WORD) (* ; "Max # of buffers the system will allocate.") (LASTCCODE WORD) (* ; "After READ, RATOM, etc, the charcode that will be returned (as a character) by LASTC. If there is none, this field is 65535.") (EXTRASTREAMOP POINTER) (* ; "For use of applications programs, not devices") (INCCODEFN POINTER) (* ; "Set by \EXTERNALFORMAT") (PEEKCCODEFN POINTER) (BACKCCODEFN POINTER) (EXTERNALFORMAT POINTER)) (BLOCKRECORD STREAM ((NIL 2 WORD) (UCODEFLAGS1 BITS 1) (* ;; "respecification of access bits:") (RANDOMWRITEABLE FLAG) (* ; "File open for output (access = OUTPUT or BOTH)") (APPENDABLE FLAG) (* ; "File open for append (OUTPUT or APPEND or BOTH)") (READABLE FLAG) (* ; "File open for read (READ or BOTH)") (NIL POINTER))) (BLOCKRECORD STREAM ((NIL 4 WORD) (NIL BITS 14) (* ;; "JIS character encoding format specific, overrides CHARSET field.") (IN.KANJIIN FLAG) (* ; "True if input stream is in Kanji-in mode.") (OUT.KANJIIN FLAG) (* ; "True if output stream is in Kanji-in mode.") )) [ACCESSFNS STREAM ((ACCESS \GETACCESS \SETACCESS) (FULLNAME (OR (fetch (STREAM FULLFILENAME) of DATUM) DATUM)) (NAMEDP (AND (fetch (STREAM FULLFILENAME) of DATUM) T] (SYNONYM CBUFPTR (CPPTR)) USERCLOSEABLE _ T USERVISIBLE _ T ACCESSBITS _ NoBits CPAGE _ 0 EPAGE _ 0 BUFFS _ NIL BYTESIZE _ 8 CBUFPTR _ NIL MAXBUFFERS _ (LET NIL (DECLARE (GLOBALVARS \STREAM.DEFAULT.MAXBUFFERS )) \STREAM.DEFAULT.MAXBUFFERS) CHARPOSITION _ 0 LINELENGTH _ (LET NIL (DECLARE (GLOBALVARS FILELINELENGTH)) FILELINELENGTH) ENDOFSTREAMOP _ (FUNCTION \EOSERROR) IMAGEOPS _ \NOIMAGEOPS EOLCONVENTION _ LF.EOLC STRMBINFN _ (FUNCTION \STREAM.NOT.OPEN) STRMBOUTFN _ (FUNCTION \STREAM.NOT.OPEN) LASTCCODE _ 65535 (CREATE (PROGN (\EXTERNALFORMAT DATUM (OR (FETCH (FDEV DEFAULTEXTERNALFORMAT ) OF (FFETCH (STREAM DEVICE) OF DATUM)) :DEFAULT)) DATUM))) ) (/DECLAREDATATYPE 'STREAM '(WORD WORD FLAG (BITS 3) POINTER BYTE BYTE WORD WORD WORD FLAG FLAG FLAG FLAG POINTER FLAG FLAG FLAG FLAG POINTER FLAG (BITS 2) FLAG POINTER POINTER POINTER WORD WORD POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER POINTER POINTER POINTER POINTER) '((STREAM 0 (BITS . 15)) (STREAM 1 (BITS . 15)) (STREAM 2 (FLAGBITS . 0)) (STREAM 2 (BITS . 18)) (STREAM 2 POINTER) (STREAM 4 (BITS . 7)) (STREAM 4 (BITS . 135)) (STREAM 5 (BITS . 15)) (STREAM 6 (BITS . 15)) (STREAM 7 (BITS . 15)) (STREAM 8 (FLAGBITS . 0)) (STREAM 8 (FLAGBITS . 16)) (STREAM 8 (FLAGBITS . 32)) (STREAM 8 (FLAGBITS . 48)) (STREAM 8 POINTER) (STREAM 10 (FLAGBITS . 0)) (STREAM 10 (FLAGBITS . 16)) (STREAM 10 (FLAGBITS . 32)) (STREAM 10 (FLAGBITS . 48)) (STREAM 10 POINTER) (STREAM 12 (FLAGBITS . 0)) (STREAM 12 (BITS . 17)) (STREAM 12 (FLAGBITS . 48)) (STREAM 12 POINTER) (STREAM 14 POINTER) (STREAM 16 POINTER) (STREAM 18 (BITS . 15)) (STREAM 19 (BITS . 15)) (STREAM 20 POINTER) (STREAM 22 POINTER) (STREAM 24 POINTER) (STREAM 26 POINTER) (STREAM 28 POINTER) (STREAM 30 (BITS . 15)) (STREAM 31 (BITS . 15)) (STREAM 32 (BITS . 15)) (STREAM 33 (BITS . 15)) (STREAM 34 POINTER) (STREAM 36 POINTER) (STREAM 38 POINTER) (STREAM 40 POINTER) (STREAM 42 POINTER) (STREAM 44 POINTER) (STREAM 46 POINTER) (STREAM 48 POINTER) (STREAM 50 POINTER) (STREAM 52 (BITS . 15)) (STREAM 53 (BITS . 15)) (STREAM 54 POINTER) (STREAM 56 POINTER) (STREAM 58 POINTER) (STREAM 60 POINTER) (STREAM 62 POINTER)) '64) (DECLARE%: EVAL@COMPILE (PUTPROPS STREAMOP MACRO [ARGS (CONS 'SPREADAPPLY* (CONS (COND ((EQ (CAR (LISTP (CAR ARGS))) 'QUOTE) (LIST 'fetch (CADAR ARGS) 'of (CADR ARGS))) (T (HELP "STREAMOP - OPNAME not quoted:" ARGS))) (CDDR ARGS]) ) (DECLARE%: EVAL@COMPILE (RPAQQ AppendBit 2) (RPAQQ NoBits 0) (RPAQQ ReadBit 1) (RPAQQ WriteBit 4) (RPAQ OutputBits (LOGOR AppendBit WriteBit)) (RPAQ BothBits (LOGOR ReadBit OutputBits)) (CONSTANTS AppendBit NoBits ReadBit WriteBit (OutputBits (LOGOR AppendBit WriteBit)) (BothBits (LOGOR ReadBit OutputBits))) ) (DECLARE%: EVAL@COMPILE (PUTPROPS TestMasked MACRO ((BITS MASK) (NEQ (LOGAND BITS MASK) 0))) (PUTPROPS APPENDABLE MACRO ((STREAM) (TestMasked (fetch ACCESSBITS of STREAM) AppendBit))) (PUTPROPS APPENDONLY MACRO ((STREAM) (EQ (fetch ACCESSBITS of STREAM) AppendBit))) (PUTPROPS DIRTYABLE MACRO [(STREAM) (TestMasked (fetch ACCESSBITS of STREAM) (CONSTANT (LOGOR AppendBit WriteBit]) (PUTPROPS OPENED MACRO ((STREAM) (NEQ (fetch ACCESSBITS of STREAM) NoBits))) (PUTPROPS OVERWRITEABLE MACRO ((STREAM) (TestMasked (fetch ACCESSBITS of STREAM) WriteBit))) (PUTPROPS READABLE MACRO ((STREAM) (TestMasked (fetch ACCESSBITS of STREAM) ReadBit))) (PUTPROPS READONLY MACRO ((STREAM) (EQ (fetch ACCESSBITS of STREAM) ReadBit))) (PUTPROPS WRITEABLE MACRO [(STREAM) (OR (OVERWRITEABLE STREAM) (AND (APPENDABLE STREAM) (\EOFP STREAM]) ) (RPAQQ EOLCONVENTIONS ((CR.EOLC 0) (LF.EOLC 1) (CRLF.EOLC 2) (ANY.EOLC 3))) (DECLARE%: EVAL@COMPILE (RPAQQ CR.EOLC 0) (RPAQQ LF.EOLC 1) (RPAQQ CRLF.EOLC 2) (RPAQQ ANY.EOLC 3) (CONSTANTS (CR.EOLC 0) (LF.EOLC 1) (CRLF.EOLC 2) (ANY.EOLC 3)) ) (* "END EXPORTED DEFINITIONS") ) (DEFINEQ (STREAMPROP [LAMBDA X (* rda%: "22-Aug-84 14:24") (* ;; "general top level entry for both fetching and setting stream properties.") (COND ((IGREATERP X 2) (PUTSTREAMPROP (ARG X 1) (ARG X 2) (ARG X 3))) ((EQ X 2) (GETSTREAMPROP (ARG X 1) (ARG X 2))) (T (\ILLEGAL.ARG NIL]) (GETSTREAMPROP [LAMBDA (STREAM PROP) (* ; "Edited 25-Aug-2023 08:45 by rmk") (* ; "Edited 5-Jul-2022 23:57 by rmk") (* ; "Edited 29-Jun-2021 17:06 by rmk:") (* rda%: "22-Aug-84 16:17") (SELECTQ PROP ((FORMAT EXTERNALFORMAT :EXTERNAL-FORMAT) (\EXTERNALFORMAT STREAM)) (ENDOFSTREAMOP (FETCH (STREAM ENDOFSTREAMOP) OF STREAM)) (LINELENGTH (LINELENGTH NIL STREAM)) (LISTGET (fetch (STREAM OTHERPROPS) of STREAM) PROP]) (PUTSTREAMPROP [LAMBDA (STREAM PROP VALUE) (* ; "Edited 25-Aug-2023 08:45 by rmk") (* ; "Edited 5-Jul-2022 23:56 by rmk") (* ; "Edited 29-Jun-2021 17:06 by rmk:") (* rda%: "22-Aug-84 16:11") (SELECTQ PROP ((FORMAT EXTERNALFORMAT :EXTERNAL-FORMAT) (* ;; "Return the old name (=VALUE), not the format datum. Better design: the format should have it's name, and not have name as a separate property.") [IF (FETCH (STREAM READONLY-EXTERNALFORMAT) OF STREAM) THEN (ERROR "EXTERNALFORMAT CANNOT BE CHANGED" STREAM) ELSE (PROG1 (\EXTERNALFORMAT STREAM NIL) (AND VALUE (\EXTERNALFORMAT STREAM VALUE)))]) (ENDOFSTREAMOP (PROG1 (fetch (STREAM ENDOFSTREAMOP) of STREAM) (replace (STREAM ENDOFSTREAMOP) of STREAM with VALUE))) (LINELENGTH (LINELENGTH VALUE STREAM)) (PROG ((OLDDATA (fetch OTHERPROPS of STREAM)) OLDVALUE) (RETURN (PROG1 (COND (OLDDATA (SETQ OLDVALUE (LISTGET OLDDATA PROP)) [COND (VALUE (LISTPUT OLDDATA PROP VALUE)) (OLDVALUE (* ; "Remove the property") (COND ((EQ (CAR OLDDATA) PROP) (replace OTHERPROPS of STREAM with (CDDR OLDDATA))) (T (for TAIL on (CDR OLDDATA) by (CDDR TAIL) when (EQ (CADR TAIL) PROP) do (FRPLACD TAIL (CDDDR TAIL)) (RETURN] OLDVALUE) (VALUE (replace OTHERPROPS of STREAM with (LIST PROP VALUE)) (* ; "know old value is NIL") NIL]) (STREAMP [LAMBDA (X) (* rmk%: "14-OCT-83 14:35") (AND (type? STREAM X) X]) ) (* ; "make streams print pretty") (DEFINEQ (\DEFPRINT.BY.NAME [LAMBDA (OBJECT STREAM NAME TYPENAME) (* ; "Edited 8-May-87 15:53 by bvm:") (* ;; "Print an object using its name, for example, #. NAME is the object's name (or NIL if this one happens to be nameless), TYPENAME is a string giving the generic name you want to appear in front, e.g., %"FDev%"") [.SPACECHECK. STREAM (+ (NCHARS TYPENAME) (PROGN (* ; "Longest address is `< /177,177777>'") 14) (COND (NAME (NCHARS NAME)) (T 0] (\OUTCHAR STREAM (fetch (READTABLEP HASHMACROCHAR) of *READTABLE*)) (\OUTCHAR STREAM (CHARCODE <)) (\SOUT (MKSTRING TYPENAME) STREAM) (COND (NAME (\OUTCHAR STREAM (CHARCODE SPACE)) (\SOUT (MKSTRING NAME) STREAM))) (\OUTCHAR STREAM (CHARCODE /)) (\PRINTADDR OBJECT STREAM) (\OUTCHAR STREAM (CHARCODE >)) T]) (\STREAM.DEFPRINT [LAMBDA (STRM OUTSTREAM) (* ; "Edited 10-Oct-2022 15:57 by lmm") (* ; "Edited 9-Oct-2022 08:58 by lmm") (* ; "Edited 19-Aug-88 14:01 by bvm") (LET ((TYPE (SELECTC (fetch ACCESSBITS of STRM) (ReadBit "Input") (OutputBits "Output") (BothBits "IO") (AppendBit "Append") "Closed"))) (\DEFPRINT.BY.NAME STRM OUTSTREAM NIL (COND ((fetch (STREAM NAMEDP) of STRM) (* ; "Use file name") (CONCAT TYPE " Stream on " (fetch (STREAM FULLFILENAME ) of STRM))) ((TYPE? FDEV (FETCH DEVICE OF STRM)) (* ; "Name the device") (CONCAT TYPE " " [CL:STRING-CAPITALIZE (STRING (fetch (FDEV DEVICENAME) of (fetch DEVICE of STRM] " Stream")) (T (CONCAT TYPE " Stream"]) (\FDEV.DEFPRINT [LAMBDA (DEV STREAM) (* ; "Edited 8-May-87 15:55 by bvm") (* ;; "Print device using its name, for example, #") (\DEFPRINT.BY.NAME DEV STREAM (fetch (FDEV DEVICENAME) of DEV) "FDev"]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (DEFPRINT 'STREAM (FUNCTION \STREAM.DEFPRINT)) (DEFPRINT 'FDEV (FUNCTION \FDEV.DEFPRINT)) ) (* ; "Needed because of STREAM initialization") (RPAQ? FILELINELENGTH 102) (RPAQ? \STREAM.DEFAULT.MAXBUFFERS 3) (DEFINEQ (\GETACCESS [LAMBDA (STREAM) (* bvm%: "26-DEC-81 15:43") (* ;; "Decodes the access bits. The inverse of the encoding in \SETACCESS. Ugly but no less so than the machinery to do it elegantly.") (SELECTC (fetch ACCESSBITS of STREAM) (NoBits NIL) (ReadBit 'INPUT) (AppendBit 'APPEND) (OutputBits 'OUTPUT) (BothBits 'BOTH) (SHOULDNT]) (\SETACCESS [LAMBDA (STREAM ACCESS) (* rmk%: " 7-NOV-83 15:02") (* ;; "The setfn for the ACCESS field. Does not assume that streams are initialized with all bits off and \STREAM.NOT.OPEN installed") (UNINTERRUPTABLY (PROG ((DEVICE (fetch DEVICE of STREAM))) (SELECTQ ACCESS (NIL (replace ACCESSBITS of STREAM with NoBits) (* ; "Was open, now closing") (replace BINABLE of STREAM with (replace BOUTABLE of STREAM with (replace EXTENDABLE of STREAM with NIL))) (replace STRMBINFN of STREAM with (replace STRMBOUTFN of STREAM with (FUNCTION \STREAM.NOT.OPEN)))) (INPUT (replace ACCESSBITS of STREAM with ReadBit) (* ; "Was closed, now opening") (replace BINABLE of STREAM with (fetch FDBINABLE of DEVICE)) (replace STRMBINFN of STREAM with (fetch BIN of DEVICE)) (replace STRMBOUTFN of STREAM with (FUNCTION \STREAM.NOT.OPEN)) (replace BOUTABLE of STREAM with (replace EXTENDABLE of STREAM with NIL))) (APPEND (replace ACCESSBITS of STREAM with AppendBit) (replace BOUTABLE of STREAM with (fetch FDBOUTABLE of DEVICE)) (replace EXTENDABLE of STREAM with (fetch FDEXTENDABLE of DEVICE)) (replace STRMBOUTFN of STREAM with (fetch BOUT of DEVICE)) (replace STRMBINFN of STREAM with (FUNCTION \STREAM.NOT.OPEN)) (replace BINABLE of STREAM with NIL)) (OUTPUT (replace ACCESSBITS of STREAM with OutputBits) (replace BOUTABLE of STREAM with (fetch FDBOUTABLE of DEVICE)) (replace EXTENDABLE of STREAM with (fetch FDEXTENDABLE of DEVICE)) (replace STRMBOUTFN of STREAM with (fetch BOUT of DEVICE)) (replace STRMBINFN of STREAM with (FUNCTION \STREAM.NOT.OPEN)) (replace BINABLE of STREAM with NIL)) (BOTH (replace ACCESSBITS of STREAM with BothBits) (replace BINABLE of STREAM with (fetch FDBINABLE of DEVICE)) (replace BOUTABLE of STREAM with (fetch FDBOUTABLE of DEVICE)) (replace EXTENDABLE of STREAM with (fetch FDEXTENDABLE of DEVICE)) (replace STRMBINFN of STREAM with (fetch BIN of DEVICE)) (replace STRMBOUTFN of STREAM with (fetch BOUT of DEVICE) )) (RAID "Illegal stream access mode")))) ACCESS]) ) (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (PUTPROPS FDEVOP DMACRO [ARGS (LET ((OPNAME (CAR ARGS)) (METHOD-DEVICE (CADR ARGS)) (TAIL (CDDR ARGS))) (COND [(AND (LISTP OPNAME) (EQ (CAR OPNAME) 'QUOTE)) `(SPREADAPPLY* (fetch (FDEV ,(CADR OPNAME)) of ,METHOD-DEVICE) ,@TAIL] (T (ERROR "OPNAME not quoted: " OPNAME]) (PUTPROPS \RECOGNIZE-HACK DMACRO [ARGS (LET ((NAME (CAR ARGS)) (RECOG (CADR ARGS)) (DEVICE (CADDR ARGS))) `(if (type? STREAM ,NAME) then ,NAME else (FDEVOP 'GETFILENAME ,DEVICE ,NAME ,RECOG ,DEVICE]) ) (DECLARE%: EVAL@COMPILE (DATATYPE FDEV ((RESETABLE FLAG) (* ; "Obsolete") (RANDOMACCESSP FLAG) (NODIRECTORIES FLAG) (PAGEMAPPED FLAG) (* ; "True if i/o handled by pmap routines") (FDBINABLE FLAG) (* ; "Copied as a microcode flag for INPUT streams formed on this device") (FDBOUTABLE FLAG) (FDEXTENDABLE FLAG) (BUFFERED FLAG) (* ; "True implies that the device supports the BIN & BOUT uCode conventions, and implements the GETNEXTBUFFER method") (DEVICENAME POINTER) (* ; "Identifying name somehow") (REMOTEP FLAG) (* ; "true if device not local to machine") (SUBDIRECTORIES FLAG) (* ; "true if device has real subdirectories") (INPUT-INDIRECTED FLAG) (* ; "True for devices that indirect their input stream. Method INPUTSTREAM fetches it") (OUTPUT-INDIRECTED FLAG) (* ; "True for devices that indirect their output stream. Method OUTPUTSTREAM fetches it") (DEVICEINFO POINTER) (* ; "arbitrary device-specific info stored here") (OPENFILELST POINTER) (* ; "Default place to keep list of streams open on this device") (* ;; "-----Rest of record consists of device %"methods%"-----") (* ;; "-----Following fields required of all devices-----") (HOSTNAMEP POINTER) (* ; "(hostname {device}) => T if hostname is valid. If device is given, return a FDEV for this {new} host, or T to use existing device") (EVENTFN POINTER) (* ; "(device event), called before/after logout, sysout, makesys") (* ;; "-----Following fields required of all named devices, e.g., ones that open files-----") (DIRECTORYNAMEP POINTER) (* ; "(host/dir) => true if directory exists on host") (OPENFILE POINTER) (* ; "(name access recog otherinfo device) => new stream open on this device, or NIL if name not found") (CLOSEFILE POINTER) (* ; "(stream) => closes stream, returns it") (REOPENFILE POINTER) (* ; "(name access recog otherinfo device stream) like openfile, but called after logout to revalidate file, so optionally uses info in old stream to keep this opening like the previous") (GETFILENAME POINTER) (* ; "(name recog device) => full file name") (DELETEFILE POINTER) (* ; "(name) => deletes file so named, returning name, or NIL on failure. RECOG=OLDEST") (GENERATEFILES POINTER) (* ; "(device pattern) => generator object for files matching pattern. Car of object is generator function, cdr is arbitrary state. Generator fn returns next file, or NIL when finished") (RENAMEFILE POINTER) (* ; "(olddevice oldfile newdevice newfile) to rename file on this (olddevice) to a potentially different device.") (OPENP POINTER) (* ; "(name access dev) => stream if name is open for access, or all open streams if name = NIL") (REGISTERFILE POINTER) (* ; "(stream dev) => registers stream on its device") (UNREGISTERFILE POINTER) (* ; "(stream dev) => unregisters a stream from its device") (FREEPAGECOUNT POINTER) (* ; "(host/dir dev) => # of free pages on host/dir") (MAKEDIRECTORY POINTER) (* ; "(host/dir dev)") (CHECKFILENAME POINTER) (* ; "(name dev) => name if it is well-formed file name for dev") (HOSTALIVEP POINTER) (* ; "(host dev) => true if host is alive, i.e., responsive; only defined if REMOTEP is true") (BREAKCONNECTION POINTER) (* ; "(host fastp dev) => closes connections to host") (* ;; "-----The following are required methods for operating on open streams-----") (BIN POINTER) (* ; "(stream) => next byte of input") (BOUT POINTER) (* ; "(stream byte) output byte to stream") (PEEKBIN POINTER) (* ; "(stream) => next byte without advancing position in stream") (FDEV1 POINTER) (* ; "Was READCHAR, replaced by READCHARCODE. Now available for device-specific use") (FDEV2 POINTER) (* ; "Was WRITECHAR (stream char) => writes char to stream") (FDEV3 POINTER) (* ; "Was PEEKCHAR") (FDEV4 POINTER) (* ; "Was UNREADCHAR") (READP POINTER) (* ; "(stream flag) => T if there is input available from stream right now") (EOFP POINTER) (* ; "(stream) => T if BIN would signal eof.") (BLOCKIN POINTER) (* ; "(stream buffer byteoffset nbytes)") (BLOCKOUT POINTER) (* ; "(stream buffer byteoffset nbytes)") (FORCEOUTPUT POINTER) (* ; "(stream waitForFinish) flushes out to device anything that is buffered awaiting transmission") (GETFILEINFO POINTER) (* ; "(stream/name attribute device) => value of attribute for open stream or name of closed file") (SETFILEINFO POINTER) (* ; "(stream/name attribute newvalue device) sets attribute of open stream or closed file of given name") (CHARSETFN POINTER) (* ; "(stream charset) => access function for the charset slot, for benefit of indirect streams. See IMCHARSET for changing it on a file.") (INPUTSTREAM POINTER) (* ; "(stream) => indirected input stream") (OUTPUTSTREAM POINTER) (* ; "(stream) => indirected output stream") (* ;; "-----Following are required of random-access streams-----") (GETFILEPTR POINTER) (GETEOFPTR POINTER) (SETFILEPTR POINTER) (BACKFILEPTR POINTER) (* ; "(stream) backs up `fileptr' by one. Stream is only required to be able to do this once, i.e. one-character buffer suffices") (SETEOFPTR POINTER) (* ; "(stream length) => truncates or lengthens stream to indicated length") (LASTC POINTER) (* ; "Should be possible only if RANDOMACCESSP") (* ;; "-----Following used for buffered streams-----") (GETNEXTBUFFER POINTER) (* ; "(stream whatfor noerrorflg) => Disposes of current buffer and optionally reads next. whatfor is READ or WRITE. Can cause EOF error unless noerrorflg") (RELEASEBUFFER POINTER) (* ; "(stream) => Does whatever appropriate when CBUFPTR is released") (* ;; "-----Following used for pagemapped streams-----") (READPAGES POINTER) (* ; "(stream firstpage# buflist) => # of bytes read, starting at firstpage#, reading into buflist, a list of buffers or a single buffer (the usual case)") (WRITEPAGES POINTER) (* ; "(stream firstpage# buflist) writes from buflist to stream starting at firstpage# of stream") (TRUNCATEFILE POINTER) (* ; "(stream page offset) make stream's eof be at page,offset, discarding anything after it") (* ;; "-----For window system, argh-----") (WINDOWOPS POINTER) (* ; "window system operations") (WINDOWDATA POINTER) (* ; "data for window systems") (* ;; "-----For any stream (here to not recompile everything)-----") (DEFAULTEXTERNALFORMAT POINTER) (* ; "Was READCHARCODE. Read a character code from the stream (cf BIN for bytes).") ) DIRECTORYNAMEP _ (FUNCTION NILL) HOSTNAMEP _ (FUNCTION NILL) READP _ (FUNCTION \GENERIC.READP) SETFILEPTR _ (FUNCTION \IS.NOT.RANDACCESSP) GETFILEPTR _ (FUNCTION \ILLEGAL.DEVICEOP) GETEOFPTR _ (FUNCTION \IS.NOT.RANDACCESSP) EOFP _ (FUNCTION \ILLEGAL.DEVICEOP) BLOCKIN _ (FUNCTION \GENERIC.BINS) BLOCKOUT _ (FUNCTION \GENERIC.BOUTS) RENAMEFILE _ (FUNCTION \GENERIC.RENAMEFILE) FORCEOUTPUT _ (FUNCTION NILL) REGISTERFILE _ (FUNCTION NILL) OPENP _ (FUNCTION NILL) UNREGISTERFILE _ (FUNCTION NILL) CHARSETFN _ (FUNCTION \GENERIC.CHARSET) BREAKCONNECTION _ (FUNCTION NILL) DEFAULTEXTERNALFORMAT _ *DEFAULT-EXTERNALFORMAT*) (RECORD FILEGENOBJ (NEXTFILEFN FILEINFOFN . GENFILESTATE)) ) (/DECLAREDATATYPE 'FDEV '(FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER FLAG FLAG FLAG FLAG POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((FDEV 0 (FLAGBITS . 0)) (FDEV 0 (FLAGBITS . 16)) (FDEV 0 (FLAGBITS . 32)) (FDEV 0 (FLAGBITS . 48)) (FDEV 0 (FLAGBITS . 64)) (FDEV 0 (FLAGBITS . 80)) (FDEV 0 (FLAGBITS . 96)) (FDEV 0 (FLAGBITS . 112)) (FDEV 2 POINTER) (FDEV 2 (FLAGBITS . 0)) (FDEV 2 (FLAGBITS . 16)) (FDEV 2 (FLAGBITS . 32)) (FDEV 2 (FLAGBITS . 48)) (FDEV 4 POINTER) (FDEV 6 POINTER) (FDEV 8 POINTER) (FDEV 10 POINTER) (FDEV 12 POINTER) (FDEV 14 POINTER) (FDEV 16 POINTER) (FDEV 18 POINTER) (FDEV 20 POINTER) (FDEV 22 POINTER) (FDEV 24 POINTER) (FDEV 26 POINTER) (FDEV 28 POINTER) (FDEV 30 POINTER) (FDEV 32 POINTER) (FDEV 34 POINTER) (FDEV 36 POINTER) (FDEV 38 POINTER) (FDEV 40 POINTER) (FDEV 42 POINTER) (FDEV 44 POINTER) (FDEV 46 POINTER) (FDEV 48 POINTER) (FDEV 50 POINTER) (FDEV 52 POINTER) (FDEV 54 POINTER) (FDEV 56 POINTER) (FDEV 58 POINTER) (FDEV 60 POINTER) (FDEV 62 POINTER) (FDEV 64 POINTER) (FDEV 66 POINTER) (FDEV 68 POINTER) (FDEV 70 POINTER) (FDEV 72 POINTER) (FDEV 74 POINTER) (FDEV 76 POINTER) (FDEV 78 POINTER) (FDEV 80 POINTER) (FDEV 82 POINTER) (FDEV 84 POINTER) (FDEV 86 POINTER) (FDEV 88 POINTER) (FDEV 90 POINTER) (FDEV 92 POINTER) (FDEV 94 POINTER) (FDEV 96 POINTER) (FDEV 98 POINTER) (FDEV 100 POINTER) (FDEV 102 POINTER) (FDEV 104 POINTER)) '106) (* "END EXPORTED DEFINITIONS") ) (/DECLAREDATATYPE 'FDEV '(FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER FLAG FLAG FLAG FLAG POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((FDEV 0 (FLAGBITS . 0)) (FDEV 0 (FLAGBITS . 16)) (FDEV 0 (FLAGBITS . 32)) (FDEV 0 (FLAGBITS . 48)) (FDEV 0 (FLAGBITS . 64)) (FDEV 0 (FLAGBITS . 80)) (FDEV 0 (FLAGBITS . 96)) (FDEV 0 (FLAGBITS . 112)) (FDEV 2 POINTER) (FDEV 2 (FLAGBITS . 0)) (FDEV 2 (FLAGBITS . 16)) (FDEV 2 (FLAGBITS . 32)) (FDEV 2 (FLAGBITS . 48)) (FDEV 4 POINTER) (FDEV 6 POINTER) (FDEV 8 POINTER) (FDEV 10 POINTER) (FDEV 12 POINTER) (FDEV 14 POINTER) (FDEV 16 POINTER) (FDEV 18 POINTER) (FDEV 20 POINTER) (FDEV 22 POINTER) (FDEV 24 POINTER) (FDEV 26 POINTER) (FDEV 28 POINTER) (FDEV 30 POINTER) (FDEV 32 POINTER) (FDEV 34 POINTER) (FDEV 36 POINTER) (FDEV 38 POINTER) (FDEV 40 POINTER) (FDEV 42 POINTER) (FDEV 44 POINTER) (FDEV 46 POINTER) (FDEV 48 POINTER) (FDEV 50 POINTER) (FDEV 52 POINTER) (FDEV 54 POINTER) (FDEV 56 POINTER) (FDEV 58 POINTER) (FDEV 60 POINTER) (FDEV 62 POINTER) (FDEV 64 POINTER) (FDEV 66 POINTER) (FDEV 68 POINTER) (FDEV 70 POINTER) (FDEV 72 POINTER) (FDEV 74 POINTER) (FDEV 76 POINTER) (FDEV 78 POINTER) (FDEV 80 POINTER) (FDEV 82 POINTER) (FDEV 84 POINTER) (FDEV 86 POINTER) (FDEV 88 POINTER) (FDEV 90 POINTER) (FDEV 92 POINTER) (FDEV 94 POINTER) (FDEV 96 POINTER) (FDEV 98 POINTER) (FDEV 100 POINTER) (FDEV 102 POINTER) (FDEV 104 POINTER)) '106) (ADDTOVAR SYSTEMRECLST (DATATYPE FDEV ((RESETABLE FLAG) (RANDOMACCESSP FLAG) (NODIRECTORIES FLAG) (PAGEMAPPED FLAG) (FDBINABLE FLAG) (FDBOUTABLE FLAG) (FDEXTENDABLE FLAG) (BUFFERED FLAG) (DEVICENAME POINTER) (REMOTEP FLAG) (SUBDIRECTORIES FLAG) (INPUT-INDIRECTED FLAG) (OUTPUT-INDIRECTED FLAG) (DEVICEINFO POINTER) (OPENFILELST POINTER) (HOSTNAMEP POINTER) (EVENTFN POINTER) (DIRECTORYNAMEP POINTER) (OPENFILE POINTER) (CLOSEFILE POINTER) (REOPENFILE POINTER) (GETFILENAME POINTER) (DELETEFILE POINTER) (GENERATEFILES POINTER) (RENAMEFILE POINTER) (OPENP POINTER) (REGISTERFILE POINTER) (UNREGISTERFILE POINTER) (FREEPAGECOUNT POINTER) (MAKEDIRECTORY POINTER) (CHECKFILENAME POINTER) (HOSTALIVEP POINTER) (BREAKCONNECTION POINTER) (BIN POINTER) (BOUT POINTER) (PEEKBIN POINTER) (FDEV1 POINTER) (FDEV2 POINTER) (FDEV3 POINTER) (FDEV4 POINTER) (READP POINTER) (EOFP POINTER) (BLOCKIN POINTER) (BLOCKOUT POINTER) (FORCEOUTPUT POINTER) (GETFILEINFO POINTER) (SETFILEINFO POINTER) (CHARSETFN POINTER) (INPUTSTREAM POINTER) (OUTPUTSTREAM POINTER) (GETFILEPTR POINTER) (GETEOFPTR POINTER) (SETFILEPTR POINTER) (BACKFILEPTR POINTER) (SETEOFPTR POINTER) (LASTC POINTER) (GETNEXTBUFFER POINTER) (RELEASEBUFFER POINTER) (READPAGES POINTER) (WRITEPAGES POINTER) (TRUNCATEFILE POINTER) (WINDOWOPS POINTER) (WINDOWDATA POINTER) (DEFAULTEXTERNALFORMAT POINTER))) ) (* ; "Device operations") (DEFINEQ (\DEFINEDEVICE [LAMBDA (NAME DEV) (* bvm%: " 5-APR-83 15:33") (* ;; "NIL DEV removes any device associated with NAME. NIL NAME simply adds the device without associating a name with it. This is useful for getting its EVENTFN invoked. A litatom DEV makes NAME be a synonym for the device currently named DEV --- \FILEDEVICES contains each device only once, \FILEDEVICENAMES contains each name device/host name only once (for spelling correction), and \DEVICENAMETODEVICE maps a name into its device.") (DECLARE (GLOBALVARS \FILEDEVICES \FILEDEVICENAMES \DEVICENAMETODEVICE)) (PROG (TEMP) (SETQ NAME (U-CASE NAME)) (* ; "Use upper-case canonical device names") RETRY (COND [(NULL DEV) (COND ((SETQ TEMP (FASSOC NAME \DEVICENAMETODEVICE)) (UNINTERRUPTABLY (SETQ \DEVICENAMETODEVICE (DREMOVE TEMP \DEVICENAMETODEVICE)) (SETQ \FILEDEVICENAMES (DREMOVE NAME \FILEDEVICENAMES)))] [(type? FDEV DEV) (SETQ TEMP (FASSOC NAME \DEVICENAMETODEVICE)) (UNINTERRUPTABLY (COND ((NOT (FMEMB DEV \FILEDEVICES)) [COND (TEMP (SETQ \FILEDEVICES (DREMOVE (CDR TEMP) \FILEDEVICES] (* ; "Devices are stored in inverse order of their definition, for proper EVENTFN ordering.") (push \FILEDEVICES DEV))) (COND (NAME (pushnew \FILEDEVICENAMES NAME) (RPLACD [OR TEMP (CAR (push \DEVICENAMETODEVICE (CONS NAME] DEV))))] ([AND (LITATOM DEV) (SETQ TEMP (CDR (FASSOC (U-CASE DEV) \DEVICENAMETODEVICE] (SETQ DEV TEMP) (GO RETRY)) (T (SETQ DEV (ERROR "INVALID FILE DEVICE" DEV)) (GO RETRY))) (RETURN NAME]) (\GETDEVICEFROMNAME [LAMBDA (NAME NOERROR DONTCREATE) (* lmm " 5-Oct-84 18:06") (* ;; "maps a filename (with host added) into a device") (OR (AND (OR (LITATOM NAME) (STRINGP NAME)) (LET [(HOST (FILENAMEFIELD NAME 'HOST] (\GETDEVICEFROMHOSTNAME (OR HOST NAME) DONTCREATE))) (AND (NOT NOERROR) (LISPERROR "FILE NOT FOUND" NAME]) (\GETDEVICEFROMHOSTNAME [LAMBDA (HOSTN DONTCREATE) (DECLARE (GLOBALVARS \DEVICENAMETODEVICE \FILEDEVICES)) (* lmm " 5-Oct-84 14:36") (OR (CDR (FASSOC HOSTN \DEVICENAMETODEVICE)) (CDR (FASSOC (SETQ HOSTN (U-CASE HOSTN)) \DEVICENAMETODEVICE)) (AND (NOT DONTCREATE) (for D TEMP in \FILEDEVICES when (SETQ TEMP (FDEVOP 'HOSTNAMEP D HOSTN D)) do (* ;; "HOSTNAMEP is a pure predicate if the second arg is NIL. Here we give a device, which indicates that we are not just a predicate, but in fact would like a new device back, possibly constructed from the old one. A device value is installed with the new hostname; a T value means install with D.") (COND ((type? FDEV TEMP) (SETQ D TEMP))) (\DEFINEDEVICE HOSTN D) (RETURN D]) (\REMOVEDEVICE [LAMBDA (DEV) (* bvm%: " 3-NOV-83 23:17") (* ;; "Removes device DEV and also any association between any of its name and DEV") (DECLARE (GLOBALVARS \FILEDEVICES \FILEDEVICENAMES \DEVICENAMETODEVICE)) (PROG (TEMP) (UNINTERRUPTABLY (while (SETQ TEMP (find PAIR in \DEVICENAMETODEVICE suchthat (EQ (CDR PAIR) DEV))) do (SETQ \FILEDEVICENAMES (DREMOVE (CAR TEMP) \FILEDEVICENAMES)) (SETQ \DEVICENAMETODEVICE (DREMOVE TEMP \DEVICENAMETODEVICE))) (SETQ \FILEDEVICES (DREMOVE DEV \FILEDEVICES))) (RETURN DEV]) (\REMOVEDEVICE.NAMES [LAMBDA (DEV NAMES) (* bvm%: "30-Jan-85 21:53") (DECLARE (GLOBALVARS \DEVICENAMETODEVICE \FILEDEVICENAMES)) (* ;;; "removes any names associated with device DEV without actually removing the device itself. If NAMES is non-NIL, removes only the names inside it") (for TAIL on \DEVICENAMETODEVICE bind CHANGED when (AND (EQ (CDAR TAIL) DEV) (OR (NULL NAMES) (EQMEMB (CAAR TAIL) NAMES))) do (SETQ \FILEDEVICENAMES (DREMOVE (CAAR TAIL) \FILEDEVICENAMES)) (RPLACA TAIL NIL) (SETQ CHANGED T) finally (COND (CHANGED (SETQ \DEVICENAMETODEVICE (DREMOVE NIL \DEVICENAMETODEVICE]) ) (RPAQ? STREAM-AFTER-OPEN-FNS NIL) (DEFINEQ (\CLOSEFILE [LAMBDA (STREAM ABORTFLG) (* ; "Edited 8-May-87 16:35 by bvm") (* ;; "Close the file specified by the given open file descriptor and return the file handle.") (COND ((NOT (READONLY STREAM)) (IMAGEOP 'IMCLOSEFN STREAM STREAM) (* ; "Do image-specific operations before physically closing the stream") )) (LET ((DEVICE (fetch (STREAM DEVICE) of STREAM))) (PROG1 (FDEVOP 'CLOSEFILE DEVICE STREAM ABORTFLG) (FDEVOP 'UNREGISTERFILE DEVICE DEVICE STREAM) (replace (STREAM ACCESS) of STREAM with NIL) (* ; "This marks the STREAM as closed") )]) (\DELETEFILE [LAMBDA (FILENAME DEV) (* hdj "13-Jun-86 14:36") (SETQ FILENAME (\ADD.CONNECTED.DIR (\CONVERT-PATHNAME FILENAME))) (AND (OR DEV (SETQ DEV (\GETDEVICEFROMNAME FILENAME T))) (FDEVOP 'DELETEFILE DEV FILENAME DEV]) (\DEVICEEVENT [LAMBDA (EVENT) (* ; "Edited 20-Aug-88 18:08 by bvm") (* ;; "Executes device-dependent event code so all devices can respond to various system transition events (LOGOUT, MAKESYS, etc.) Before an event, devices are considered in the inverse order of their definition, so that older devices get processed later. The order is reversed for after-events.") (DECLARE (GLOBALVARS \FILEDEVICES)) (LET ((BEFOREP (SELECTQ EVENT ((BEFORELOGOUT BEFOREMAKESYS BEFORESYSOUT BEFORESAVEVM) T) NIL))) (for D in (if BEFOREP then \FILEDEVICES else (REVERSE \FILEDEVICES)) do (FDEVOP 'EVENTFN D D EVENT) (if BEFOREP then (* ;; "Mark output files as needing revalidation if we write to them again. This is so that if you do a SAVEVM, then write to the file some more, then boot back to the SAVEVM, that the AFTERSAVEVM event will notice that the stream has changed.") (* ;; "Don't do this until AFTER we've run the eventfn because, e.g., the eventfn might have done a forceoutput on the stream, thereby prematurely observing this flag.") (for STREAM in (FDEVOP 'OPENP D NIL 'OUTPUT D) unless (fetch (STREAM NONDEFAULTDATEFLG) of STREAM) do (replace (STREAM REVALIDATEFLG) of STREAM with T]) (\GENERATEFILES [LAMBDA (PATTERN DESIREDPROPS OPTIONS DEPTH) (* ;; "Edited 29-Mar-2022 08:52 by rmk: Added local DEPTH parameter, defaults to the free FILING.ENUMERATION.DEPTH.") (* bvm%: "27-Apr-84 23:21") (* ;; "Returns a file-generator object that will generate all files whose names match PATTERN. A gen-object consists of a device dependent NEXTFILEFN and GENFILESTATE") (SETQ PATTERN (\ADD.CONNECTED.DIR PATTERN)) (LET ((FDEV (\GETDEVICEFROMNAME PATTERN)) (FILING.ENUMERATION.DEPTH (IF (FIXP DEPTH) ELSEIF DEPTH THEN MAX.SMALLP ELSE FILING.ENUMERATION.DEPTH))) (DECLARE (SPECVARS FILING.ENUMERATION.DEPTH)) (FDEVOP 'GENERATEFILES FDEV FDEV PATTERN DESIREDPROPS OPTIONS]) (\GENERATENEXTFILE [LAMBDA (GENOBJ NAMEONLY) (* bvm%: " 8-Jul-85 19:30") (* ;; "GENOBJ is a file-generator object as created by \GENERATEFILES. The NEXTFILEFN must return the name of the next file generated by the generator, as a string or symbol. Returns NIL if no files left. It updates GENOBJ so that it will get the following satisfactory file on the next call to this function. --- If NAMEONLY, then filenames returned need not contain host, directory or version") (CL:FUNCALL (fetch NEXTFILEFN of GENOBJ) (fetch GENFILESTATE of GENOBJ) NAMEONLY]) (\GENERATEFILEINFO [LAMBDA (GENOBJ ATTRIBUTE) (* bvm%: "26-Apr-84 15:40") (* ;; "GENOBJ is a file-generator object as created by \GENERATEFILES. The FILEINFOFN performs a GETFILEINFO on the file which is the currently enumerated file, i.e., the last thing that NEXTFILEFN returned") (CL:FUNCALL (fetch FILEINFOFN of GENOBJ) (fetch GENFILESTATE of GENOBJ) ATTRIBUTE]) (\GETFILENAME [LAMBDA (NAME RECOG FDEV) (* hdj " 4-Sep-86 15:22") (* ;; "Expands NAME according to recog, returning either the full NAME or NIL.") (SETQ NAME (\ADD.CONNECTED.DIR (\CONVERT-PATHNAME NAME))) (COND ((OR FDEV (SETQ FDEV (\GETDEVICEFROMNAME NAME T))) (FDEVOP 'GETFILENAME FDEV NAME RECOG FDEV]) (\GENERIC.OUTFILEP [LAMBDA (NAME DEV) (* lmm " 6-Jan-85 17:41") (PROG ((V (FDEVOP 'GETFILENAME DEV NAME 'OLD DEV))) (RETURN (if V then (PACKFILENAME 'VERSION (ADD1 (OR (FILENAMEFIELD V 'VERSION) 1)) 'BODY V) else (PACKFILENAME 'VERSION 1 'BODY NAME]) (\OPENFILE [LAMBDA (NAME ACCESS RECOG PARAMETERS) (* hdj "14-Oct-86 14:04") (* ;;; "Opens the file identified by NAME possibly expanded according to RECOG. Returns an open stream for the file. ACCESS is assumed to be one of INPUT, OUTPUT, BOTH, or APPEND.") (PROG (FDEV CDNAME STREAM) RETRY [COND [(type? STREAM NAME) (COND ((\IOMODEP NAME ACCESS T) (\DO.PARAMS.AT.OPEN NAME ACCESS PARAMETERS) (RETURN NAME)) (T (SETQ CDNAME NAME) (SETQ FDEV (fetch (STREAM DEVICE) of NAME] (T (SETQ CDNAME (\ADD.CONNECTED.DIR NAME)) (SETQ FDEV (\GETDEVICEFROMNAME CDNAME] (* ; "Keep NAME for possible error") (* ;; "The OPENFILE operation returns NIL if the file wasn't found, so the name is right for the not-found error. That error must not be generated from inside the device, or spellfile would be too constrained. The won't-open error may happen inside the device, if the device itself does some interlocking (e.g. a file-server). The generic code in OPENFILE may also generate that error, to enforce interlocks among files already opened in this Lisp.") (COND ((SETQ STREAM (FDEVOP 'OPENFILE FDEV CDNAME ACCESS RECOG PARAMETERS FDEV)) (replace ACCESS of STREAM with ACCESS) (replace CPAGE of STREAM with (COND ((EQ ACCESS 'APPEND) (fetch EPAGE of STREAM)) (T 0))) (replace COFFSET of STREAM with (COND ((EQ ACCESS 'APPEND) (fetch EOFFSET of STREAM)) (T 0))) (\DO.PARAMS.AT.OPEN STREAM ACCESS PARAMETERS) (* ;; "register the file using its internal device's registerfile method instead of FDEV's; this is primarily for the benefit of the file cacher") (LET ((STREAM-FDEV (fetch (STREAM DEVICE) of STREAM))) (FDEVOP 'REGISTERFILE STREAM-FDEV STREAM-FDEV STREAM)) (RETURN STREAM)) (T (SETQ NAME (LISPERROR "FILE NOT FOUND" NAME)) (GO RETRY]) (\DO.PARAMS.AT.OPEN [LAMBDA (STREAM ACCESS PARAMETERS) (* ; "Edited 26-Apr-2026 23:27 by rmk") (* ; "Edited 21-Apr-2026 20:57 by mth") (* ; "Edited 20-Apr-2026 17:36 by mth") (* ; "Edited 25-Dec-2024 10:54 by rmk") (* ; "Edited 15-Jul-2024 22:29 by rmk") (* ; "Edited 25-Aug-2023 08:43 by rmk") (* ; "Edited 6-Jul-2022 00:00 by rmk") (* ; "Edited 19-Dec-2021 09:30 by rmk") (* ; "Edited 14-Dec-2021 16:10 by rmk") (* ; "Edited 13-Dec-2021 15:20 by rmk") (* ; "Edited 29-Jun-2021 17:07 by rmk:") (* ; "Edited 5-Oct-92 13:45 by jds") (* ;; "RMK: July 2024: Default EOL to ANY on input streams, allow EXTERNAL FORMAT to be a (FORMAT EOL) list so CL:OPEN can get the EOL") (* ;; "Does generic parameters when a file/stream is open. Called by \OPENFILE and OPENSTREAM") (* ;; "RMK: August 2023: Added PUTSTREAMPROP as last resort.") (* ;; "RMK July 2020: Make sure that \EXTERNALFORMAT is always called, so that it can implement per-device defaults.") (* ;; "RMK August 2020: Added hook for user STREAM-AFTER-OPEN-FNS, not global so can be rebound.") (DECLARE (USEDFREE STREAM-AFTER-OPEN-FNS)) (\EXTERNALFORMAT STREAM :DEFAULT) (for X ATTR VAL EOL in PARAMETERS do (COND [(LISTP X) (SETQ ATTR (CAR X)) (SETQ VAL (CAR (LISTP (CDR X] (T (SETQ ATTR X) (SETQ VAL T))) (SELECTQ ATTR (BUFFERS (SETFILEINFO STREAM 'BUFFERS VAL)) (ENDOFSTREAMOP (SETFILEINFO STREAM 'ENDOFSTREAMOP VAL)) (CHARSET (CHARSET STREAM VAL)) ((FORMAT EXTERNALFORMAT :EXTERNAL-FORMAT) (* ;; "This allows an EOL and format to be intermixed, the last ones of each are installed") (for V inside VAL do (if (MEMB V '(LF CR CRLF ANY)) then (SETQ EOL V) else (\EXTERNALFORMAT STREAM V)))) (CONVHANKAKU (CONVHANKAKU STREAM VAL)) ((EOL EOLCONVENTION EOLC) (SETQ EOL VAL)) NIL) finally (* ;; "If EOL is not specified, default input streams to ANY. ") (CL:UNLESS (OR EOL (\GETSTREAM STREAM 'OUTPUT T)) (SETQ EOL 'ANY)) (CL:WHEN EOL (SETFILEINFO STREAM 'EOL EOL))) (for FN in STREAM-AFTER-OPEN-FNS do (APPLY* FN STREAM ACCESS PARAMETERS]) (\RENAMEFILE [LAMBDA (OLDFILE NEWFILE) (* ; "Edited 25-Apr-2026 16:03 by rmk") (* ; "Edited 25-Dec-2024 10:14 by rmk") (* ; "Edited 16-Dec-2024 21:07 by rmk") (* hdj " 7-May-86 12:22") (SETQ OLDFILE (\ADD.CONNECTED.DIR OLDFILE)) (SETQ NEWFILE (\ADD.CONNECTED.DIR NEWFILE)) (* ;; "\GETDEVICEFROMNAME errors if the devices don't exist") (LET ((OLD-DEVICE (TRUEDEVICE OLDFILE)) (NEW-DEVICE (TRUEDEVICE NEWFILE)) NEWFULLNAME) (CL:WHEN (SETQ NEWFULLNAME (FDEVOP 'RENAMEFILE OLD-DEVICE OLD-DEVICE (TRUEFILENAME OLDFILE) NEW-DEVICE (TRUEFILENAME NEWFILE))) (CL:IF (PSEUDOHOSTP NEWFILE) (PSEUDOFILENAME NEWFULLNAME (FILENAMEFIELD NEWFILE 'HOST)) NEWFULLNAME))]) (\REVALIDATEFILE [LAMBDA (STREAM) (* bvm%: "30-DEC-81 17:45") (* ;; "Check the file to determine if it corresponds to the status information for it found in the STREAM and file handle. Return DELETED if the file no longer exists, CHANGED if the file does not correspond to the status information, or NIL if everything is OK.") (PROG ((NEWSTREAM (FDEVOP 'REOPENFILE (fetch DEVICE of STREAM) (fetch FULLFILENAME of STREAM) (fetch ACCESS of STREAM) 'OLD NIL (fetch DEVICE of STREAM) STREAM))) (RETURN (COND ((NOT NEWSTREAM) 'DELETED) ((EQ NEWSTREAM STREAM) (* ; "Nothing changed") NIL) (T (replace F1 of STREAM with (fetch F1 of NEWSTREAM)) (* ; "Copy 'device' information from the new opening to the old") (replace F2 of STREAM with (fetch F2 of NEWSTREAM)) (replace F3 of STREAM with (fetch F3 of NEWSTREAM)) (replace F4 of STREAM with (fetch F4 of NEWSTREAM)) (replace F5 of STREAM with (fetch F5 of NEWSTREAM)) (replace FW6 of STREAM with (fetch FW6 of NEWSTREAM)) (replace FW7 of STREAM with (fetch FW7 of NEWSTREAM)) (COND ((EQUAL (fetch VALIDATION of NEWSTREAM) (fetch VALIDATION of STREAM)) NIL) (T (replace VALIDATION of STREAM with (fetch VALIDATION of NEWSTREAM)) (replace EPAGE of STREAM with (fetch EPAGE of NEWSTREAM)) (replace EOFFSET of STREAM with (fetch EOFFSET of NEWSTREAM)) 'CHANGED]) (\PAGED.REVALIDATEFILELST [LAMBDA (DEVICE) (* hdj "30-Sep-86 15:23") (* ;;; "Revalidate all of the open files on DEVICE (a PMAP device)") (bind REASON PAGES for STREAM in (FDEVOP 'OPENP DEVICE NIL NIL DEVICE) do (if (SETQ REASON (\PAGED.REVALIDATEFILE STREAM)) then (SELECTQ REASON (CHANGED (* ; "it changed update the map") (SETQ PAGES (RESTOREMAP STREAM))) (DELETED (* ; "the file disappeared, so zap the stream") (SETQ PAGES (FORGETPAGES STREAM)) [MAPC (STREAMPROP STREAM 'AFTERCLOSE) (FUNCTION (LAMBDA (FN) (APPLY* FN STREAM] (replace ACCESS of STREAM with NIL) (FDEVOP 'UNREGISTERFILE DEVICE DEVICE STREAM)) (SHOULDNT)) (\PRINT-REVALIDATION-RESULT REASON STREAM))) (* ; "might as well return something useful") (FDEVOP 'OPENP DEVICE NIL NIL DEVICE]) (\PAGED.REVALIDATEFILES [LAMBDA (LIST) (* hdj "30-Sep-86 15:18") (* ;;; "Revalidate all of the open files on LIST; they are all PMAPped streams") (LET ((NEWLIST (COPY LIST))) (bind REASON PAGES for STREAM in LIST do (if (SETQ REASON (\PAGED.REVALIDATEFILE STREAM)) then (SELECTQ REASON (CHANGED (* ; "it changed - update the map") (SETQ PAGES (RESTOREMAP STREAM))) (DELETED (* ; "the file disappeared, so zap the stream") (SETQ PAGES (FORGETPAGES STREAM)) [MAPC (STREAMPROP STREAM 'AFTERCLOSE) (FUNCTION (LAMBDA (FN) (APPLY* FN STREAM] (replace ACCESS of STREAM with NIL) (LET ((DEVICE (fetch (STREAM DEVICE) of STREAM)) ) (FDEVOP 'UNREGISTERFILE DEVICE DEVICE STREAM)) (SETQ NEWLIST (DREMOVE STREAM NEWLIST))) (SHOULDNT)) (\PRINT-REVALIDATION-RESULT REASON STREAM))) (* ;;; "return the remaining files") NEWLIST]) (\PAGED.REVALIDATEFILE [LAMBDA (STREAM) (* hdj "23-May-86 14:14") (* ;; "Check the file to determine if it corresponds to the status information for it found in the STREAM and file handle. Return DELETED if the file no longer exists, CHANGED if the file does not correspond to the status information, or NIL if everything is OK") (LET ((NEWSTREAM (FDEVOP 'REOPENFILE (fetch DEVICE of STREAM) (fetch FULLFILENAME of STREAM) (fetch ACCESS of STREAM) 'OLD NIL (fetch DEVICE of STREAM) STREAM))) (COND ((NOT NEWSTREAM) 'DELETED) ((EQ NEWSTREAM STREAM) (* ; "Nothing changed") NIL) (T (replace F1 of STREAM with (fetch F1 of NEWSTREAM)) (* ; "Copy 'device' information from the new opening to the old") (replace F2 of STREAM with (fetch F2 of NEWSTREAM)) (replace F3 of STREAM with (fetch F3 of NEWSTREAM)) (replace F4 of STREAM with (fetch F4 of NEWSTREAM)) (replace F5 of STREAM with (fetch F5 of NEWSTREAM)) (replace FW6 of STREAM with (fetch FW6 of NEWSTREAM)) (replace FW7 of STREAM with (fetch FW7 of NEWSTREAM)) (COND ((EQUAL (fetch VALIDATION of NEWSTREAM) (fetch VALIDATION of STREAM)) NIL) (T (replace VALIDATION of STREAM with (fetch VALIDATION of NEWSTREAM)) (replace EPAGE of STREAM with (fetch EPAGE of NEWSTREAM)) (replace EOFFSET of STREAM with (fetch EOFFSET of NEWSTREAM) ) 'CHANGED]) (\BUFFERED.REVALIDATEFILE [LAMBDA (STREAM) (* hdj "23-May-86 14:14") (* ;; "Check the file to determine if it corresponds to the status information for it found in the STREAM and file handle. Return DELETED if the file no longer exists, CHANGED if the file does not correspond to the status information, or NIL if everything is OK") (LET ((NEWSTREAM (FDEVOP 'REOPENFILE (fetch DEVICE of STREAM) (fetch FULLFILENAME of STREAM) (fetch ACCESS of STREAM) 'OLD NIL (fetch DEVICE of STREAM) STREAM))) (COND ((NOT NEWSTREAM) 'DELETED) ((EQ NEWSTREAM STREAM) (* ; "Nothing changed") NIL) (T (replace F1 of STREAM with (fetch F1 of NEWSTREAM)) (* ; "Copy 'device' information from the new opening to the old") (replace F2 of STREAM with (fetch F2 of NEWSTREAM)) (replace F3 of STREAM with (fetch F3 of NEWSTREAM)) (replace F4 of STREAM with (fetch F4 of NEWSTREAM)) (replace F5 of STREAM with (fetch F5 of NEWSTREAM)) (replace FW6 of STREAM with (fetch FW6 of NEWSTREAM)) (replace FW7 of STREAM with (fetch FW7 of NEWSTREAM)) (COND ((EQUAL (fetch VALIDATION of NEWSTREAM) (fetch VALIDATION of STREAM)) NIL) (T (replace VALIDATION of STREAM with (fetch VALIDATION of NEWSTREAM)) (replace EPAGE of STREAM with (fetch EPAGE of NEWSTREAM)) (replace EOFFSET of STREAM with (fetch EOFFSET of NEWSTREAM) ) 'CHANGED]) (\BUFFERED.REVALIDATEFILELST [LAMBDA (DEVICE) (* hdj "30-Sep-86 15:16") (* ;;; "Revalidate all of the open files on DEVICE (a buffered device)") [bind REASON for STREAM in (FDEVOP 'OPENP DEVICE NIL NIL DEVICE) do (if (SETQ REASON (\BUFFERED.REVALIDATEFILE STREAM)) then (SELECTQ REASON ((DELETED CHANGED) (* ; "the file changed or disappeared, so zap the stream") [MAPC (STREAMPROP STREAM 'AFTERCLOSE) (FUNCTION (LAMBDA (FN) (APPLY* FN STREAM] (replace ACCESS of STREAM with NIL) (FDEVOP 'UNREGISTERFILE DEVICE DEVICE STREAM) (\PRINT-REVALIDATION-RESULT REASON STREAM)) (SHOULDNT] (* ;; "might as well return something useful") (FDEVOP 'OPENP DEVICE NIL NIL DEVICE]) (\PRINT-REVALIDATION-RESULT [LAMBDA (RESULT STREAM) (* ; "Edited 29-Sep-2022 20:11 by lmm") (* hdj "26-May-86 15:46") (* ;; "stack overflow if DRIBBLEFILE; use PROMPTWINDOW") (FRESHLINE PROMPTWINDOW) (if [AND (DRIBBLEFILE) (NOT (OPENP (DRIBBLEFILE) 'APPEND] THEN (PRINTOUT PROMPTWINDOW "Dribble file " (DRIBBLE) " ended" T)) (printout PROMPTWINDOW "**** WARNING: The file " (fetch (STREAM FULLNAME) of STREAM) (SELECTQ RESULT (CHANGED " has been modified since you last accessed it!") (DELETED " was previously opened but has disappeared!") (SHOULDNT)) T]) (\TRUNCATEFILE [LAMBDA (STREAM LASTPAGE LASTOFFSET) (* bvm%: " 8-MAY-82 16:11") (* ;; "Shorten an open file to have the given last page and offset. Last page = NIL means to truncate to the current length, which some devices may interpret as a noop") (FDEVOP 'TRUNCATEFILE (fetch DEVICE of STREAM) STREAM LASTPAGE LASTOFFSET]) (\FILE-CONFLICT [LAMBDA (NAME ACCESS DEVICE) (* ; "Edited 14-Apr-87 18:07 by jop") (* ;; "returns NIL if there's no conflict between the access mode of the file we're about to open and the ones already open there's no conflict if there are none already open, or if the ones already open are open for input, and so's the candidate") (LET* ((FILENAME (if (type? STREAM NAME) then (fetch (STREAM FULLFILENAME) of NAME) else NAME)) (STREAMS-FOR-THIS-FILE (FDEVOP 'OPENP DEVICE FILENAME NIL DEVICE))) (if STREAMS-FOR-THIS-FILE then [LET [(EXISTING-ACCESS-MODE (fetch (STREAM ACCESS) of (CAR STREAMS-FOR-THIS-FILE ] (if (NEQ ACCESS EXISTING-ACCESS-MODE) then T elseif (EQ ACCESS 'INPUT) then NIL else (NEQ NAME (CAR STREAMS-FOR-THIS-FILE] else NIL]) ) (* ; "Generic enumerator") (DEFINEQ (\GENERATENOFILES [LAMBDA (FDEV PATTERN DESIREDPROPS OPTIONS) (* bvm%: " 5-Jun-84 16:31") (* ;; "A dummy function to be used by devices that don't support directory generation. This produces a generate that generates no files.") (PROG ((STAR (STRPOS '* PATTERN)) (ESC (STRPOS '(CONSTANT (CHARACTER (CHARCODE ESC))) PATTERN))) (RETURN (COND ([AND [OR (NULL STAR) (AND (EQ (NTHCHARCODE PATTERN (SUB1 STAR)) (CHARCODE ;)) (NULL (STRPOS '* PATTERN (ADD1 STAR] (OR (NULL ESC) (AND (EQ (NTHCHARCODE PATTERN (SUB1 ESC)) (CHARCODE ;)) (NULL (STRPOS (CONSTANT (CHARACTER (CHARCODE ESC))) PATTERN (ADD1 ESC] (create FILEGENOBJ NEXTFILEFN _ (FUNCTION \NOFILESNEXTFILEFN) FILEINFOFN _ (FUNCTION \NOFILESINFOFN) GENFILESTATE _ (create NOFILEGENSTATE NOFILETYPE _ (COND ((AND (NULL STAR) (NULL ESC)) 'NOSTAR) (T (SETQ PATTERN (PACKFILENAME 'VERSION NIL 'BODY PATTERN)) 'STAR)) NOFILEPATTERN _ PATTERN))) (T (\NULLFILEGENERATOR]) (\NULLFILEGENERATOR [LAMBDA NIL (* bvm%: " 5-Jun-84 15:46") (* ;; "A file generator that generates no files") (create FILEGENOBJ NEXTFILEFN _ (FUNCTION NILL]) (\NOFILESNEXTFILEFN [LAMBDA (GENFILESTATE NAMEONLY) (* bvm%: " 8-Jul-85 19:28") (PROG (FILE TYPE) [SELECTQ (SETQ TYPE (fetch NOFILETYPE of GENFILESTATE)) (NOSTAR (replace NOFILETYPE of GENFILESTATE with 'DONE) (SETQ FILE (INFILEP (fetch NOFILEPATTERN of GENFILESTATE)))) (DONE (RETURN NIL)) (STAR (* ;; "Star in version field. Start out by producing the oldest file, and note its version and the version of the newest file for subsequent enumeration") (SETQ FILE (FULLNAME (fetch NOFILEPATTERN of GENFILESTATE) 'OLDEST)) [replace NOFILETYPE of GENFILESTATE with (CONS (FILENAMEFIELD FILE 'VERSION) (FILENAMEFIELD (INFILEP (fetch NOFILEPATTERN of GENFILESTATE )) 'VERSION]) (PROG [(VER (ADD1 (CAR TYPE] (* ;; "TYPE is a dotted pair of versions (old . newest) -- test INFILEP for each version number after old until we get to newest") LP (COND ((IGREATERP VER (CDR TYPE)) (RETURN NIL)) [[SETQ FILE (INFILEP (PACKFILENAME.STRING 'VERSION VER 'BODY (fetch NOFILEPATTERN of GENFILESTATE] (RPLACA TYPE (FILENAMEFIELD FILE 'VERSION] (T (add VER 1) (GO LP] (RETURN (COND (FILE (replace NOFILENAME of GENFILESTATE with FILE) FILE]) (\NOFILESINFOFN [LAMBDA (GENSTATE ATTRIBUTE) (* bvm%: "27-Apr-84 22:17") (* ;;; "Fileinfo fn for getting attributes of the file currently enumerated -- go thru the generic GETFILEINFO") (GETFILEINFO (fetch NOFILENAME of GENSTATE) ATTRIBUTE]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD NOFILEGENSTATE (NOFILETYPE NOFILEPATTERN . NOFILENAME)) ) ) (DEFINEQ (\FILE.NOT.OPEN [LAMBDA (X NOERROR) (* hdj "17-Jun-86 18:28") (* ;; "Returns NIL of NOERROR, otherwise causes the FILE NOT OPEN error. Used by \GETSTREAM. \STREAM.NOT.OPEN doesn't take NOERROR arg.") (AND (NULL NOERROR) (LISPERROR "FILE NOT OPEN" (COND ((type? STREAM X) (fetch (STREAM FULLNAME) of X)) (T X]) (\FILE.WONT.OPEN [LAMBDA (X) (* hdj "17-Jun-86 18:32") (LISPERROR "FILE WON'T OPEN" (COND ((type? STREAM X) (fetch (STREAM FULLNAME) of X)) (T X]) (\ILLEGAL.DEVICEOP [LAMBDA N (* bvm%: "28-DEC-81 15:44") (ERROR "Attempt to use undefined device operation" (for I from 1 to N collect (ARG N I]) (\IS.NOT.RANDACCESSP [LAMBDA N (* hdj "17-Jun-86 18:32") (PROG ((THING (ARG N 1))) (RETURN (ERROR "File is not RANDACCESSP" (COND ((type? STREAM THING) (fetch (STREAM FULLNAME) of THING)) (T THING]) (\STREAM.NOT.OPEN [LAMBDA (STREAM) (* hdj "17-Jun-86 18:32") (* ;; "Can be used as BIN/BOUT function. \FILE.NOT.OPEN accepts more than just a stream, and also has NOERROR control") (LISPERROR "FILE NOT OPEN" (fetch (STREAM FULLNAME) of STREAM]) ) (ADDTOVAR \FILEDEVICES ) (ADDTOVAR \FILEDEVICENAMES ) (ADDTOVAR \DEVICENAMETODEVICE ) (* ; "Device instances") (DEFINEQ (\FDEVINSTANCE [LAMBDA (FDEV) (* gbn "16-Sep-85 18:09") (* ;; "Creates an 'instance' of FDEV, a distinct device that executes all the operations of FDEV, but which can be smashed to change those operations in order to specialize streams. --- \INHERITFDEVOP.S and .D are macros that expect the device to be found from a STREAM or FDEV argument, respectively. Only operations that relate to streams are included, since non-stream device operations will be obtained from the original device, whose name is registered.") (create FDEV using FDEV DEVICEINFO _ FDEV CLOSEFILE _ (\INHERITFDEVOP.S CLOSEFILE STREAM) GETFILEINFO _ (\INHERITFDEVOP.D GETFILEINFO STREAM ATTRIB FDEV) OPENFILE _ (\INHERITFDEVOP.D OPENFILE CDNAME ACCESS RECOG OTHERINFO FDEV) READPAGES _ (\INHERITFDEVOP.S READPAGES STREAM FIRSTPAGE BUFFERLIST) SETFILEINFO _ (\INHERITFDEVOP.D SETFILEINFO STREAM ATTRIBUTE VALUE FDEV) TRUNCATEFILE _ (\INHERITFDEVOP.S TRUNCATEFILE STREAM LASTPAGE LASTOFFSET) WRITEPAGES _ (\INHERITFDEVOP.S WRITEPAGES STREAM FIRSTPAGE BUFFERLIST) REOPENFILE _ (\INHERITFDEVOP.D REOPENFILE NAME ACCESS RECOG OTHERINFO FDEV OLDSTREAM) BIN _ (\INHERITFDEVOP.S BIN STREAM) BOUT _ (\INHERITFDEVOP.S BOUT STREAM BYTE) PEEKBIN _ (\INHERITFDEVOP.S PEEKBIN STREAM NOERRORFLG) BACKFILEPTR _ (\INHERITFDEVOP.S BACKFILEPTR STREAM) SETFILEPTR _ (\INHERITFDEVOP.S SETFILEPTR STREAM INDX) GETFILEPTR _ (\INHERITFDEVOP.S GETFILEPTR STREAM) GETEOFPTR _ (\INHERITFDEVOP.S GETEOFPTR STREAM) EOFP _ (\INHERITFDEVOP.S EOFP STREAM) BLOCKIN _ (\INHERITFDEVOP.S BLOCKIN STREAM BASE OFFSET NBYTES) BLOCKOUT _ (\INHERITFDEVOP.S BLOCKOUT STREAM BASE OFFSET NBYTES) FORCEOUTPUT _ (\INHERITFDEVOP.S FORCEOUTPUT STREAM]) ) (DECLARE%: EVAL@COMPILE (PUTPROPS \INHERITFDEVOP.D MACRO [X (SUBPAIR '(NEWARGS OPNAME . ARGS) (CONS (SUBST '(fetch DEVICEINFO of FDEV) 'FDEV (CDR X)) X) '(FUNCTION (LAMBDA ARGS (FDEVOP 'OPNAME (fetch DEVICEINFO of FDEV) . NEWARGS]) (PUTPROPS \INHERITFDEVOP.S MACRO [(OPNAME . ARGS) (FUNCTION (LAMBDA ARGS (FDEVOP 'OPNAME (fetch DEVICEINFO of (fetch DEVICE of STREAM)) . ARGS]) ) (RPAQ? LOGINHOST/DIR '{DSK}) (RPAQ? \CONNECTED.DIRECTORY '{DSK}) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS LOGINHOST/DIR \CONNECTED.DIRECTORY \FILEDEVICES \FILEDEVICENAMES \DEVICENAMETODEVICE) ) (* ; "Directory defaulting") (DEFINEQ (CNDIR [LAMBDA (HOST/DIR) (* ; "Edited 11-Mar-87 14:28 by Pavel") (* ;;; "Connects to HOST/DIR, verifying that HOST/DIR exists.") (DECLARE (GLOBALVARS \CONNECTED.DIRECTORY)) (LET ([TEMP-DEFAULTS (PATHNAME (SETQ \CONNECTED.DIRECTORY (OR (DIRECTORYNAME (AND HOST/DIR (\CONVERT-PATHNAME HOST/DIR)) T 'ASK) (ERROR "Non-existent directory" HOST/DIR] (NEW-DEFAULTS (COPY-PATHNAME *DEFAULT-PATHNAME-DEFAULTS*))) (CL:SETF (%%PATHNAME-HOST NEW-DEFAULTS) (CL:PATHNAME-HOST TEMP-DEFAULTS)) (CL:SETF (%%PATHNAME-DEVICE NEW-DEFAULTS) (CL:PATHNAME-DEVICE TEMP-DEFAULTS)) (CL:SETF (%%PATHNAME-DIRECTORY NEW-DEFAULTS) (CL:PATHNAME-DIRECTORY TEMP-DEFAULTS)) (SETQ *DEFAULT-PATHNAME-DEFAULTS* NEW-DEFAULTS)) \CONNECTED.DIRECTORY]) (DIRECTORYNAME [LAMBDA (DIRNAME STRPTR CREATE?) (* ; "Edited 6-Feb-2026 23:19 by rmk") (* ; "Edited 20-May-92 11:08 by jds") (* ;; "Returns connected directory name") (DECLARE (GLOBALVARS LOGINHOST/DIR)) (CL:WHEN (CL:PATHNAMEP DIRNAME) (SETQ DIRNAME (CL:NAMESTRING DIRNAME))) (PROG (DN FDEV) [SELECTQ DIRNAME (T (* ; "Connected host/dir") (SETQ DN \CONNECTED.DIRECTORY)) (NIL (SETQ DN (OR LOGINHOST/DIR '{DSK}))) (COND [(AND [SETQ FDEV (LET [(HOST (FILENAMEFIELD DIRNAME 'HOST] (SELCHARQ (NTHCHARCODE DIRNAME 1) (> (* ; "Remove leading > from a subdirectory spec.") (SETQ DIRNAME (SUBSTRING DIRNAME 2))) NIL) (\GETDEVICEFROMHOSTNAME (OR HOST (FILENAMEFIELD [SELCHARQ (NTHCHARCODE DIRNAME 1) ((< /) (* ; "Whole directory, use it all.") (SETQ DIRNAME (PACKFILENAME.STRING 'DIRECTORY DIRNAME 'BODY \CONNECTED.DIRECTORY))) (SELCHARQ (NTHCHARCODE DIRNAME (NCHARS DIRNAME)) ((> /) (* ; "Remove any trailing > or / from a subdirectory spec.") (SETQ DIRNAME (PACKFILENAME.STRING 'SUBDIRECTORY (SUBSTRING DIRNAME 1 -2) 'DIRECTORY \CONNECTED.DIRECTORY))) (SETQ DIRNAME (PACKFILENAME.STRING 'SUBDIRECTORY DIRNAME 'DIRECTORY \CONNECTED.DIRECTORY] 'HOST] (SETQ DN (FDEVOP 'DIRECTORYNAMEP FDEV DIRNAME FDEV CREATE?))) (COND ((EQ DN T) (SETQ DN (PACKFILENAME.STRING 'HOST (fetch (FDEV DEVICENAME) of FDEV) 'DIRECTORY DIRNAME] (T (RETURN] (RETURN (COND ((NOT STRPTR) (MKSTRING DN)) ((EQ STRPTR T) (MKATOM DN)) (T (MKSTRING DN]) (DIRECTORYNAMEP [LAMBDA (DIRNAME HOSTNAME) (* bvm%: "18-Oct-85 14:38") (* ;; "T if DIRNAME is recognized as a currently existing directory, on HOSTNAME, or if not included, on the hostname in DIRNAME, or the connected host.") (LET ([DN (COND (HOSTNAME (PACKFILENAME.STRING 'DIRECTORY DIRNAME 'HOST HOSTNAME)) (T (PACKFILENAME.STRING 'DIRECTORY DIRNAME 'DIRECTORY \CONNECTED.DIRECTORY] FDEV) (AND (SETQ FDEV (\GETDEVICEFROMNAME DN T)) (FDEVOP 'DIRECTORYNAMEP FDEV DN FDEV) T]) (HOSTNAMEP [LAMBDA (NAME) (* rmk%: "11-NOV-81 14:33") (* ;; "T if NAME is the name of a recognizable host") (DECLARE (GLOBALVARS \FILEDEVICENAMES \FILEDEVICES)) (PROG (N) (COND ((LITATOM NAME) (SETQ N (U-CASE NAME))) [(STRINGP NAME) (SETQ N (MKATOM (U-CASE NAME] (T (RETURN NIL))) [COND ((EQ (CHCON1 N) (CHARCODE {)) (SETQ N (SUBATOM N 2 (SUB1 (OR (STRPOS '} N 2) (RETURN NIL] (RETURN (AND (OR (MEMB N \FILEDEVICENAMES) (find D in \FILEDEVICES suchthat (FDEVOP 'HOSTNAMEP D N))) T]) (\ADD.CONNECTED.DIR [LAMBDA (FILENAME) (* ; "Edited 29-Dec-89 15:41 by jds") (* ;; "Modifies the filename to include connected host and/or dir") (COND ([AND (OR (LITATOM FILENAME) (STRINGP FILENAME)) (NOT (UNPACKFILENAME.STRING FILENAME 'HOST] (PACKFILENAME.STRING 'BODY FILENAME 'DIRECTORY \CONNECTED.DIRECTORY)) (T FILENAME]) ) (* ; "Binary I/O Public functions") (DEFINEQ (\BACKFILEPTR [LAMBDA (STREAM) (* bvm%: "30-JAN-82 16:59") (FDEVOP 'BACKFILEPTR (fetch DEVICE of STREAM) STREAM]) (\BACKPEEKBIN [LAMBDA (STREAM) (* bvm%: " 7-Jun-84 16:45") (* ;; "Returns previous byte on file without changing fileptr. Returns NIL if we are positioned at the beginning of the file. Called by LASTC") (UNINTERRUPTABLY (AND (\BACKFILEPTR STREAM) (\BIN STREAM)))]) (\BACKBIN [LAMBDA (STREAM) (* bvm%: " 7-Jun-84 16:46") (* ;; "Returns previous character on file and backs up fileptr so that next \BIN will also return it. Returns NIL if we are positioned at the beginning of the file.") (AND (\BACKFILEPTR STREAM) (\PEEKBIN STREAM]) (BIN [LAMBDA (STREAM) (* lmm "20-APR-82 22:00") (* ; "MERELY EXECUTE OPCODE") (\BIN STREAM]) (\BIN [LAMBDA (STREAM) (* rmk%: " 2-NOV-83 14:32") (* ; "UFN for BIN opcode") (STREAMOP 'STRMBINFN (SETQ STREAM (\DTEST STREAM 'STREAM)) STREAM]) (\BINS [LAMBDA (STREAM BASE OFF NBYTES) (* bvm%: "25-MAY-83 12:48") (* ;; "BINs NBYTES bytes from STREAM into BASE+OFF") (FDEVOP 'BLOCKIN [ffetch DEVICE of (SETQ STREAM (\DTEST STREAM 'STREAM] STREAM BASE OFF NBYTES]) (BOUT [LAMBDA (STREAM BYTE) (* ; "Edited 3-Mar-87 16:04 by lal") (* ; "Merely execute opcode") (if (NUMBERP BYTE) then (if (GREATERP BYTE 65535) then (\ILLEGAL.ARG BYTE))) (\BOUT STREAM BYTE]) (\BOUT [LAMBDA (STREAM BYTE) (* ; "Edited 8-Jan-88 17:00 by jds") [COND ((NUMBERP BYTE) (COND ((GREATERP BYTE 65535) (\ILLEGAL.ARG BYTE] (SETQ STREAM (\DTEST STREAM 'STREAM)) (STREAMOP 'STRMBOUTFN STREAM STREAM BYTE]) (\BOUTS [LAMBDA (STREAM BASE OFF NBYTES) (* bvm%: "25-MAY-83 12:47") (* ;; "BOUTs NBYTES bytes from BASE+OFF into OFD. Follows logic of BINS.") (FDEVOP 'BLOCKOUT [ffetch DEVICE of (SETQ STREAM (\DTEST STREAM 'STREAM] STREAM BASE OFF NBYTES]) (COPYBYTES [LAMBDA (SRCFIL DSTFIL START END) (* ; "Edited 24-Jun-88 15:08 by drc:") (* ;; "Copies bytes from START up to but not including END from SRCFIL into DSTFIL.") (PROG ((SRC (\GETSTREAM SRCFIL 'INPUT)) (DST (\GETSTREAM DSTFIL 'OUTPUT)) NBYTES) (SETQ NBYTES (COND (END (* ; "Specified a start and ending") (COND ((EQUAL START END) (* ; "special case: no bytes to copy") (RETURN))) [\SETFILEPTR SRC (COND ((type? BYTEPTR START) START) (T (\ILLEGAL.ARG START] (IDIFFERENCE (COND [(EQ END -1) (COND ((RANDACCESSP SRC) (* ; "It's random access, so GETEOFPTR will work") (\GETEOFPTR SRC)) (T (* ; "Otherwise, we have to hack around this (probably a bug in FTP streams)") (GETFILEINFO SRC 'LENGTH] ((type? BYTEPTR END) END) (T (\ILLEGAL.ARG END))) START)) (T START))) (* ; "How much to copy, or NIL if to EOF") (COND ((AND NBYTES (ILESSP NBYTES 0)) (ERROR "Negative number of bytes to copy" NBYTES))) [COND ((fetch BUFFERED of (fetch DEVICE of SRC)) (* ; "Can copy by the bufferfull") (\BUFFERED.COPYBYTES SRC DST NBYTES)) [[OR NBYTES (SETQ NBYTES (COND ((fetch RANDOMACCESSP of (fetch DEVICE of SRC)) (IDIFFERENCE (\GETEOFPTR SRC) (\GETFILEPTR SRC] (* ; "Know how many bytes to copy") (FRPTQ NBYTES (\BOUT DST (\BIN SRC] (T (* ; "Copying to EOF but can't tell when that will happen") (until (\EOFP SRC) do (\BOUT DST (\BIN SRC] (RETURN T) (* ; "As specified in VM") ]) (COPYCHARS [LAMBDA (SRCFIL DSTFIL START END) (* ; "Edited 11-Sep-2025 20:47 by rmk") (* ; "Edited 13-Aug-2021 18:39 by rmk:") (* ; "Edited 14-Jun-2021 22:08 by rmk:") (* ; "Edited 8-Dec-95 16:38 by rmk:") (* ; "Edited 26-Mar-99 12:13 by rmk:") (* ;; "This is similar to COPYBYTES except that conversion is done between the EOL convention and externalformat of the input and the EOL convention/external format of the output. This assumes that an ANY.EOLC source file is actually the same as the destination.") [PROG ((SRCSTRM (\GETSTREAM SRCFIL)) (DSTSTRM (\GETSTREAM DSTFIL)) (ACTUALSTART 0) RAP ACTUALEND EOF SRCEOLC DSTEOLC CH) (CL:WHEN (AND (OR (EQ (SETQ SRCEOLC (fetch EOLCONVENTION of SRCSTRM)) (SETQ DSTEOLC (fetch EOLCONVENTION of DSTSTRM))) (EQ ANY.EOLC (fetch EOLCONVENTION of SRCSTRM))) (EQ (FETCH EXTERNALFORMAT OF SRCSTRM) (FETCH EXTERNALFORMAT OF DSTSTRM))) (RETURN (COPYBYTES SRCSTRM DSTSTRM START END))) (* ;; "Format or EOL convention are different. So first decode the START END specification") [COND ((SETQ RAP (fetch RANDOMACCESSP of (fetch DEVICE of SRCSTRM))) (SETQ EOF (\GETEOFPTR SRCSTRM] (COND [END (OR RAP (ERROR "COPYCHARS: Source file is not random access" (fetch FULLFILENAME of SRCSTRM))) (OR (type? BYTEPTR (SETQ ACTUALSTART (FIX START))) (LISPERROR "ILLEGAL ARG" START)) (\SETFILEPTR SRCSTRM ACTUALSTART) (SETQ ACTUALEND (COND ((EQ END -1) EOF) ((type? BYTEPTR END) END) (T (\ILLEGAL.ARG END] [START (SETQ ACTUALEND (COND (RAP (SETQ ACTUALSTART (\GETFILEPTR SRCSTRM)) (IMIN EOF (IPLUS START ACTUALSTART))) (T START] (RAP (SETQ ACTUALSTART (\GETFILEPTR SRCSTRM)) (SETQ ACTUALEND EOF)) (T (* ;; "Not random access and START and END are both NIL, just copy to the end of file,no need to count.") (until (\EOFP SRCSTRM) do (\OUTCHAR DSTSTRM (\INCCODE.EOLC SRCSTRM SRCEOLC))) (RETURN))) (CL:UNLESS (IGEQ ACTUALEND ACTUALSTART) (ERROR "Negative number of bytes to copy" (IDIFFERENCE ACTUALEND ACTUALSTART))) (* ;; "We now know which bytes we need to copy, in the case that there is an EOL/format mismatch. If we assume that this is fairly unusual and that we don't want to assume here that we know how the CR and LF are byte-coded, we don't try to optimize for an EOL-only change. We just go generic.") (* ;; "The \INCCODE.EOLC and \OUTCHAR handle all format and EOL issues.") (BIND (CNT _ (IDIFFERENCE ACTUALEND ACTUALSTART)) DECLARE (SPECVARS CNT) WHILE (IGREATERP CNT 0) DO (\OUTCHAR DSTSTRM (\INCCODE.EOLC SRCSTRM NIL 'CNT CNT] T]) (COPYFILE [LAMBDA (FROMFILE TOFILE) (* ;; "Edited 12-Sep-2025 08:18 by rmk") (* ;; "Edited 18-Dec-2024 21:07 by rmk") (* ;; "Edited 8-Jul-2022 10:41 by rmk") (* ;; "Edited 2-Jan-93 13:35 by jds") (CL:WHEN (DIRECTORYNAMEP (PACKFILENAME 'HOST NIL 'BODY TOFILE) (UNPACKFILENAME TOFILE 'HOST)) (SETQ TOFILE (PACKFILENAME 'DIRECTORY TOFILE 'BODY (PACKFILENAME 'HOST NIL 'DIRECTORY NIL 'BODY FROMFILE)))) (RESETLST (LET (FROMSTREAM TOSTREAM) [RESETSAVE [SETQ FROMSTREAM (OPENSTREAM FROMFILE 'INPUT 'OLD `((SEQUENTIAL T) (DON'TCACHE T] '(PROGN (CLOSEF? OLDVALUE] [RESETSAVE [SETQ TOSTREAM (OPENSTREAM TOFILE 'OUTPUT 'NEW `((SEQUENTIAL T) (DON'TCACHE T) (CREATIONDATE ,(GETFILEINFO FROMSTREAM 'CREATIONDATE] '(AND RESETSTATE (SETQ OLDVALUE (CLOSEF? OLDVALUE)) (DELFILE OLDVALUE] (COPYBYTES FROMSTREAM TOSTREAM) (CLOSEF FROMSTREAM) (CLOSEF TOSTREAM)))]) (\COPYOPENFILE [LAMBDA (INSTREAM NEWNAME DESTPARAMETERS) (* ;; "Edited 8-Jul-2022 10:58 by rmk: Use COPYCHARS if external formats are different") (* ;; "Edited 3-May-2021 20:36 by rmk:") (* ;; "Edited 11-Dec-95 11:50 by ") (* ;; "Edited 17-Sep-90 11:41 by jds") (* bvm%: "18-Oct-85 15:54") (PROG ((PROPS DESTPARAMETERS) TYPE X OUTSTREAM) [COND ([AND (NOT (ASSOC 'CREATIONDATE DESTPARAMETERS)) (SETQ X (GETFILEINFO INSTREAM 'CREATIONDATE] (push PROPS (LIST 'CREATIONDATE X] [COND [(SETQ TYPE (CADR (ASSOC 'TYPE DESTPARAMETERS] ((OR (AND (SETQ TYPE (GETFILEINFO INSTREAM 'TYPE)) (NEQ TYPE '?)) (SETQ TYPE (\INFER.FILE.TYPE INSTREAM))) (push PROPS (LIST 'TYPE TYPE] (* ;; "TAL removed : (COND ((AND (EQ TYPE 'TEXT) (SETQ X (GETFILEINFO INSTREAM 'EOL)) (NOT (ASSOC 'EOL DESTPARAMETERS))) (push PROPS (LIST 'EOL X)))) --- if the caller didn't specify, we ought to convert to the destination system's EOL convention for text files.") (CL:UNLESS (EQ TYPE 'TEXT) (* ;; "RMK: Setting the LENGTH seems wrong for TEXT files, since the byte-length could change if EOL or external-format differs. Let normal Length mechanisms prevail. Indeed, why bother with setting the length anyway--unless this is merely a hint for the opener? If so, the text guard can be removed.") [COND ((SETQ X (GETFILEINFO INSTREAM 'LENGTH)) (push PROPS (LIST 'LENGTH X]) [RESETSAVE [SETQ OUTSTREAM (OPENSTREAM NEWNAME 'OUTPUT 'NEW `((SEQUENTIAL T) (DON'TCACHE T) ,@PROPS] '(AND RESETSTATE (SETQ OLDVALUE (CLOSEF OLDVALUE)) (DELFILE OLDVALUE] (* ;; "Obsoleted by Lyric's multiple streams: (OR (EQ (\GETFILEPTR INSTREAM) 0) (SETFILEPTR INSTREAM 0)) ;; In case it was open by someone else! Really need multiple streams, but until then at least don't lose big this way") (COND ((OR (EQ TYPE 'TEXT) (NEQ (ffetch (STREAM EXTERNALFORMAT) of INSTREAM) (ffetch (STREAM EXTERNALFORMAT) of OUTSTREAM))) (* ;; "RMK: COPYCHARS ensures that external format conversion happens if necessary ") (COPYCHARS INSTREAM OUTSTREAM)) (T (COPYBYTES INSTREAM OUTSTREAM))) (* ;; "On UNIX version, give FX the option of printing a warning when the file type is defaulted -- they want to discourage that behavior.") (AND (EQ \MACHINETYPE \MAIKO) FileTypeConfirmFlg (STKPOS 'COPYFILE) (NULL (ASSOC 'TYPE DESTPARAMETERS)) (\UFStoOtherCopyMess INSTREAM OUTSTREAM)) (* ;; "We return the closed stream.") (RETURN (CLOSEF OUTSTREAM]) (\INFER.FILE.TYPE [LAMBDA (STREAM) (* bvm%: " 8-Jun-84 11:48") (* ;; "STREAM is open on a file whose TYPE is unknown. If we can, decide between TEXT and BINARY by examining bytes") (COND ((RANDACCESSP STREAM) (SETFILEPTR STREAM 0) (PROG ((OLDEOF (fetch ENDOFSTREAMOP of STREAM)) TYPE) (replace ENDOFSTREAMOP of STREAM with (FUNCTION NILL)) [SETQ TYPE (do (COND ((IGREATERP (OR (\BIN STREAM) (RETURN 'TEXT)) 127) (RETURN 'BINARY] (replace ENDOFSTREAMOP of STREAM with OLDEOF) (SETFILEPTR STREAM 0) (* ; "Put file ptr back") (RETURN TYPE]) (EOFP [LAMBDA (FILE) (* bvm%: "10-Jun-84 22:46") (* ;; "User entry. T if FILE is at EOF. I-10 only considers input files, we merely give priority to them") (\EOFP (OR (\GETSTREAM FILE 'INPUT T) (\GETSTREAM FILE]) (FORCEOUTPUT [LAMBDA (STREAM WAITFORFINISH) (* bvm%: "27-Apr-84 22:45") (SETQ STREAM (\GETSTREAM STREAM 'OUTPUT)) (FDEVOP 'FORCEOUTPUT (fetch DEVICE of STREAM) STREAM WAITFORFINISH]) (\FLUSH.OPEN.STREAMS [LAMBDA (FDEV) (* hdj " 5-Jun-86 12:58") (* ;;; "flush all of device's open streams") (for STREAM in (\DEVICE-OPEN-STREAMS FDEV) when (DIRTYABLE STREAM) do (FDEVOP 'FORCEOUTPUT (fetch (STREAM DEVICE) of STREAM) STREAM]) (CHARSET [LAMBDA (STREAM NEWVALUE DONTMARKFILE) (* ; "Edited 8-Dec-2023 15:04 by rmk") (* ; "Edited 11-Sep-87 16:22 by bvm:") (* ;; "Public access to a stream's CHARSET. If NEWVALUE is given, changes the charset (which for output streams can write a charset shift, depending on the external format, unless DONTMARKFILE). ACCESS-CHARSET recurses through any commonlisp meta-streams, eventually reaches \GENERIC.CHARSET, which then applies the format's FORMATCHARSETFN. ") (SETQ STREAM (\GETSTREAM STREAM)) (COND ((EQ NEWVALUE NSCHARSETSHIFT) (* ; "Coerce 255 to T for uniformity") (SETQ NEWVALUE T)) ([NOT (OR (EQ NEWVALUE NIL) (EQ NEWVALUE T) (AND (>= NEWVALUE 0) (< NEWVALUE \MAXCHARSET] (\ILLEGAL.ARG NEWVALUE))) (LET ((OLDVAL (ACCESS-CHARSET STREAM (if (EQ NEWVALUE T) then NSCHARSETSHIFT else NEWVALUE) DONTMARKFILE))) (* ; "First modify the stream's slot") (if (EQ OLDVAL NSCHARSETSHIFT) then (SETQ OLDVAL T)) OLDVAL]) (ACCESS-CHARSET [LAMBDA (STREAM NEWVALUE DONTMARKFILE) (* ; "Edited 24-Apr-2025 22:15 by rmk") (* ; "Edited 8-Dec-2023 15:05 by rmk") (* ; "Edited 11-Sep-87 15:46 by bvm:") (* ;; "Unless DONTMARKSTREAM, if STREAM is open for output, the external format function may modify the backing file as well as the stream, e.g. put in MCCS shifting bytes.") (FDEVOP 'CHARSETFN (fetch (STREAM DEVICE) of STREAM) STREAM NEWVALUE DONTMARKFILE]) (GETEOFPTR [LAMBDA (FILE) (* rmk%: "21-OCT-83 11:19") (PROG ((STREAM (\GETSTREAM FILE))) (RETURN (FDEVOP 'GETEOFPTR (fetch DEVICE of STREAM) STREAM]) (GETFILEINFO [LAMBDA (FILE ATTRIB) (* ; "Edited 29-Jun-2021 17:05 by rmk:") (* ; "Edited 11-Dec-95 11:03 by ") (* ; "Edited 8-May-87 16:53 by bvm") (LET (FULLNAME DEV) (COND [(type? STREAM FILE) (* ; "FILE is open or nameless. Ask device for info; if it can't handle it, at least handle some generic cases") (COND ((EQ ATTRIB 'ACCESS) (fetch ACCESS of FILE)) ((FDEVOP 'GETFILEINFO (SETQ DEV (fetch DEVICE of FILE)) FILE ATTRIB DEV)) ((OPENED FILE) (* ; "Could be false for a closed nameless stream") (SELECTQ ATTRIB ((BYTESIZE OPENBYTESIZE) (fetch BYTESIZE of FILE)) (EOL (SELECTC (fetch EOLCONVENTION of FILE) (CR.EOLC 'CR) (LF.EOLC 'LF) (CRLF.EOLC 'CRLF) (ANY.EOLC 'ANY) (SHOULDNT))) (BUFFERS (fetch MAXBUFFERS of FILE)) (CHARSET (CHARSET FILE)) (ENDOFSTREAMOP (fetch ENDOFSTREAMOP of FILE)) (LENGTH (AND (RANDACCESSP FILE) (\GETEOFPTR FILE))) (SIZE [SIZE.FROM.LENGTH (OR (FDEVOP 'GETFILEINFO DEV FILE 'LENGTH DEV) (AND (RANDACCESSP FILE) (\GETEOFPTR FILE]) ((FORMAT EXTERNALFORMAT) (\EXTERNALFORMAT FILE)) NIL)) ((EQ ATTRIB 'SIZE) (SIZE.FROM.LENGTH (FDEVOP 'GETFILEINFO DEV FILE 'LENGTH DEV] [(AND [SETQ DEV (\GETDEVICEFROMNAME (SETQ FULLNAME (\ADD.CONNECTED.DIR (\CONVERT-PATHNAME FILE] (SETQ FULLNAME (FDEVOP 'GETFILENAME DEV FULLNAME 'OLD DEV))) (* ; "Name of existing file. It's possible we should have the device do recognition instead, but then we have the confusion of file not found recovery in the wrong place.") (SELECTQ ATTRIB ((ACCESS OPENBYTESIZE) (* ; "Strip off attributes that apply only to open files") NIL) (OR (FDEVOP 'GETFILEINFO DEV FULLNAME ATTRIB DEV) (SELECTQ ATTRIB (SIZE (SIZE.FROM.LENGTH (FDEVOP 'GETFILEINFO DEV FULLNAME 'LENGTH DEV))) NIL] (T (LISPERROR "FILE NOT FOUND" FILE]) (\TYPE.FROM.FILETYPE [LAMBDA (FILETYPE) (* bvm%: "15-Jan-85 16:22") (* ;;; "Coerces a numeric FILETYPE to a symbolic TYPE or returns FILETYPE itself if it is not registered on the list FILING.TYPES") (AND FILETYPE (OR (CAR (find PAIR in FILING.TYPES suchthat (EQ (CADR PAIR) FILETYPE))) FILETYPE]) (\FILETYPE.FROM.TYPE [LAMBDA (TYPE) (* bvm%: "15-Jan-85 17:08") (OR (CADR (ASSOC TYPE FILING.TYPES)) (FIXP TYPE]) (GETFILEPTR [LAMBDA (FILE) (* rmk%: "21-OCT-83 11:19") (PROG ((STREAM (\GETSTREAM FILE))) (RETURN (FDEVOP 'GETFILEPTR (fetch DEVICE of STREAM) STREAM]) (SETFILEINFO [LAMBDA (FILE ATTRIB VALUE) (* ; "Edited 25-Dec-2024 10:56 by rmk") (* ; "Edited 19-Dec-2021 09:30 by rmk") (* ; "Edited 29-Jun-2021 17:05 by rmk:") (* ; "Edited 11-Dec-95 11:08 by ") (* ; "Edited 27-Mar-89 15:33 by bvm") (LET (FULLNAME DEV) (COND [(type? STREAM FILE) (* ; "FILE is open, so strip off attributes that can be set from the stream.") (SELECTQ ATTRIB ((ACCESS BYTESIZE OPENBYTESIZE) (* ; "These can't be changed for an open file") NIL) (EOL (replace EOLCONVENTION of FILE with (SELECTQ VALUE (CR CR.EOLC) (CRLF CRLF.EOLC) (LF LF.EOLC) (ANY (CL:UNLESS (EQ 'INPUT (\GETACCESS FILE)) (ERROR "EOL convention ANY is not allowed for output streams" FILE)) ANY.EOLC) (\ILLEGAL.ARG VALUE))) VALUE) ((FORMAT EXTERNALFORMAT) (\EXTERNALFORMAT FILE VALUE) VALUE) (ENDOFSTREAMOP (replace ENDOFSTREAMOP of FILE with VALUE)) (BUFFERS (replace MAXBUFFERS of FILE with (IMAX 1 (FIX VALUE)))) (CHARSET (CHARSET FILE VALUE)) (OR (FDEVOP 'SETFILEINFO (SETQ DEV (fetch DEVICE of FILE)) FILE ATTRIB VALUE DEV) (SELECTQ ATTRIB (LENGTH (* ;; "Let device at this attribute first. Probably should not have this generic op, since we don't know how to do this for all devices") [\SETEOFPTR FILE (COND ((type? BYTEPTR VALUE) VALUE) (T (\ILLEGAL.ARG VALUE]) (SIZE (\SETEOFPTR FILE (UNFOLD VALUE BYTESPERPAGE))) NIL] [(AND [SETQ DEV (\GETDEVICEFROMNAME (SETQ FULLNAME (\ADD.CONNECTED.DIR (\CONVERT-PATHNAME FILE] (SETQ FULLNAME (FDEVOP 'GETFILENAME DEV FULLNAME 'OLD DEV))) (* ; "Name of existing file. It's possible we should have the device do recognition instead, but then we have the confusion of file not found recovery in the wrong place.") (SELECTQ ATTRIB ((ACCESS OPENBYTESIZE EOLCONVENTION) NIL) (OR (FDEVOP 'SETFILEINFO DEV FULLNAME ATTRIB VALUE DEV) (COND ((EQ ATTRIB 'LENGTH) (\SETCLOSEDFILELENGTH FULLNAME (COND ((type? BYTEPTR VALUE) VALUE) (T (\ILLEGAL.ARG VALUE] (T (LISPERROR "FILE NOT FOUND" FILE]) (SETFILEPTR [LAMBDA (FILE ADR) (* ; "Edited 21-Jun-2021 12:12 by rmk:") (LET ((STREAM (\GETSTREAM FILE))) [FDEVOP 'SETFILEPTR (ffetch DEVICE of STREAM) STREAM (COND ((EQ ADR -1) (\GETEOFPTR STREAM)) ((type? BYTEPTR ADR) ADR) (T (LISPERROR "ILLEGAL ARG" ADR] (* ;; " RMK: There is no reason to believe that going to CSET 0 is more often right than wrong. If it truly is a runcoded cset 0 file, where this would be appropriate, then it presumably is already in cset 0, no need to do anything. If it is runcoded in some other character set (e.g. Greek), then it is more likely that the whole file (or at least wherever we are setting the file ptr) is also in Greek. So leave it alone.") (* ;; "And this would only apply, presumably, to an NS/XCCS file or some other runcoded file format, of which there aren't any.") (* (if (\RUNCODED STREAM) then (* ;; "always shift the character set to 0. This might be wrong sometimes, but it is more often right than wrong. We don't do it when reading a non-runcoded file, since maybe the whole file is that way (unfortunately, we can't tell)") (ACCESS-CHARSET STREAM 0))) (freplace (STREAM CHARPOSITION) of STREAM with 0) (* ; "Value is not coerced!") ADR]) (BOUT16 [LAMBDA (STREAM N) (* edited%: " 2-Apr-85 17:11") (BOUT STREAM (LRSH N 8)) (BOUT STREAM (LOGAND N 255)) N]) (BIN16 [LAMBDA (STREAM) (* edited%: " 2-Apr-85 17:11") (LOGOR (LLSH (BIN STREAM) 8) (BIN STREAM]) ) (PUTPROPS BOUT DOPCODE (33 BOUT 0 T -1 \BOUT (4K DORADO))) (* ; "Generic functions") (DEFINEQ (\GENERIC.BINS [LAMBDA (STREAM BASE OFF NBYTES) (* bvm%: "25-MAY-83 11:41") (* ;; "BINs NBYTES bytes from STREAM to memory starting at BASE+OFF.") (FRPTQ NBYTES (\PUTBASEBYTE BASE OFF (\BIN STREAM)) (add OFF 1]) (\GENERIC.BOUTS [LAMBDA (STREAM BASE OFF NBYTES) (* bvm%: "25-MAY-83 11:40") (* ;; "BOUTs NBYTES bytes from BASE+OFF into STREAM") (FRPTQ NBYTES (\BOUT STREAM (\GETBASEBYTE BASE OFF)) (add OFF 1]) (\GENERIC.RENAMEFILE [LAMBDA (OLDDEVICE OLDFILE NEWDEVICE NEWFILE) (* ; "Edited 16-Dec-2024 21:52 by rmk") (* ;; "Names and devices are true, not pseudo") (* ; "Edited 2-Jul-90 16:03 by nm") (CL:UNLESS (FDEVOP 'OPENP OLDDEVICE (FULLNAME OLDFILE) NIL OLDDEVICE) (* ; "Can't rename an open file") (RESETLST [LET (INSTREAM OUTSTREAM) [RESETSAVE [SETQ INSTREAM (OPENSTREAM OLDFILE 'INPUT 'OLD '((SEQUENTIAL T) (DON'TCACHE T] '(PROGN (CLOSEF? OLDVALUE] [RESETSAVE [SETQ OUTSTREAM (OPENSTREAM NEWFILE 'OUTPUT 'NEW `((SEQUENTIAL T) (DON'TCACHE T) (CREATIONDATE ,(GETFILEINFO OLDFILE 'CREATIONDATE] '(AND RESETSTATE (SETQ OLDVALUE (CLOSEF OLDVALUE)) (DELFILE OLDVALUE] (COPYBYTES INSTREAM OUTSTREAM) (CLOSEF OUTSTREAM) (if (\DELETEFILE (CLOSEF INSTREAM)) then (FULLNAME OUTSTREAM) else (CONDITIONS:RESTART-CASE (CL:ERROR 'XCL::FS-RENAMEFILE-SOURCE-COULDNT-DELETE :PATHNAME OLDFILE) (DELETE-DESTINATION NIL :CONDITION XCL::FS-RENAMEFILE-SOURCE-COULDNT-DELETE :REPORT "Delete the destination file too." (DELFILE NEWFILE) NIL) (DONT-DELETE-DESTINATION NIL :CONDITION XCL::FS-RENAMEFILE-SOURCE-COULDNT-DELETE :REPORT "Don't delete the destination file. Just returns the destination filename." NEWFILE]))]) (\GENERIC.OPENP [LAMBDA (FILENAME ACCESS DEVICE) (* hdj " 6-Oct-86 17:07") (* ;;; "return all open stream on DEVICE with name FILENAME and access ACCESS. FILENAME is assumed to be fully 'recognized.' FILENAME and/or ACCESS may be NIL.") (if FILENAME then [LET ((OPENFILES (fetch (FDEV OPENFILELST) of DEVICE))) (if OPENFILES then (for STREAM in OPENFILES collect STREAM when (AND (STRING-EQUAL FILENAME (fetch (STREAM FULLNAME ) of STREAM)) (OR (NULL ACCESS) (\IOMODEP STREAM ACCESS T] else (for S in (fetch (FDEV OPENFILELST) of DEVICE) collect S when (AND (OR (NULL ACCESS) (\IOMODEP S ACCESS T)) (fetch USERVISIBLE of S]) (\GENERIC.READP [LAMBDA (STRM FLG) (* ; "Edited 19-Jul-2022 23:23 by rmk") (* ; "Edited 23-Jun-2021 13:09 by rmk:") (* ; "The 10 does not do the EOL check on the peeked character.") (* ; "If FLG is NIL, a single EOL doesn't count.") (CL:UNLESS (\EOFP STRM) [PROG NIL (RETURN (OR FLG [NEQ EOL.TC (\SYNCODE \PRIMTERMSA (OR (\PEEKCCODE.EOLC STRM T) (RETURN] (UNINTERRUPTABLY (\INCCODE.EOLC STRM) (* ; "Read what we peeked (EOLC), see if anything comes after") (PROG1 (NOT (\EOFP STRM)) (\BACKCCODE.EOLC STRM)))])]) (\GENERIC.CHARSET [LAMBDA (STREAM NEWVALUE DONTMARKSTREAM) (* ; "Edited 24-Apr-2025 22:16 by rmk") (* ; "Edited 8-Dec-2023 15:17 by rmk") (* ; "Edited 11-Sep-87 16:20 by bvm:") (* ;;; "sets or returns the current numeric character set for this stream. This applies the stream's FORMATCHARSETFN if it has one, and (if MARKSTREAM) that may change an output backing stream in some way (e.g. write MCCS charset shift bytes). Otherwise, this just sets the charset stream parameter to influence subsequent reading and writing behavior. Charset doesn't exist in some formats (e.g. UTF-8), the format function would be a noop in that case.") (\DTEST STREAM 'STREAM) (LET ((EFORMAT (ffetch (STREAM EXTERNALFORMAT) of STREAM)) OLDVALUE) (if (AND EFORMAT (fetch (EXTERNALFORMAT FORMATCHARSETFN) of EFORMAT)) then (APPLY* (fetch (EXTERNALFORMAT FORMATCHARSETFN) of EFORMAT) STREAM NEWVALUE DONTMARKSTREAM) else (SETQ OLDVALUE (ffetch (STREAM CHARSET) of STREAM)) (CL:WHEN NEWVALUE (freplace (STREAM CHARSET) of STREAM with NEWVALUE) (CL:UNLESS (OR DONTMARKSTREAM (EQ NEWVALUE OLDVALUE) (NOT (\IOMODEP STREAM 'OUTPUT T))) (\BOUT STREAM NSCHARSETSHIFT) (if (OR (EQ CHARSET T) (EQ CHARSET NSCHARSETSHIFT)) then (\BOUT STREAM NSCHARSETSHIFT) (\BOUT STREAM 0) else (\BOUT STREAM CHARSET)))) OLDVALUE]) ) (DEFINEQ (\MAP-OPEN-STREAMS [LAMBDA (FN DEVICES ACCESS) (* hdj "11-Sep-86 10:48") (for DEVICE in DEVICES when (fetch (FDEV OPENP) of DEVICE) join (for STREAM in (FDEVOP 'OPENP DEVICE NIL ACCESS DEVICE) collect (APPLY* FN STREAM]) ) (RPAQ? FILING.TYPES '((BINARY 0) (DIRECTORY 1) (TEXT 2) (SERIALIZED 3) (INTERPRESS 4361) (TEDIT 6056) (FASL 6057) (LAFITE 6058))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS FILING.TYPES) ) (DECLARE%: EVAL@COMPILE DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (PUTPROPS \DEVICE-OPEN-STREAMS MACRO [ARGS (LET ((DEVICE (CAR ARGS))) `(FDEVOP 'OPENP ,DEVICE NIL NIL ,DEVICE]) (PUTPROPS \CONVERT-PATHNAME DMACRO (OPENLAMBDA (PATHNAME?) (* ;; "Coerce pathnames to Interlisp strings, for the benefit of antediluvian Interlisp-D file fns") (CL:TYPECASE PATHNAME? (PATHNAME (INTERLISP-NAMESTRING PATHNAME?)) (T PATHNAME?)))) ) (DEFOPTIMIZER ACCESS-CHARSET (STREAM &OPTIONAL NEWVALUE MARKSTREAM) `((OPENLAMBDA (STRM) (FDEVOP 'CHARSETFN (fetch (STREAM DEVICE) of STRM) STRM ,NEWVALUE ,MARKSTREAM)) ,STREAM)) (* "END EXPORTED DEFINITIONS") ) (DECLARE%: DONTEVAL@LOAD DOCOPY [MAPC '((FORCEOUTPUT FLUSHOUTPUT) (FORCEOUTPUT FLUSHMAP) (\GENERIC.BINS \NONPAGEDBINS) (\GENERIC.BOUTS \NONPAGEDBOUTS)) (FUNCTION (LAMBDA (PAIR) (PUTD (CADR PAIR) (GETD (CAR PAIR)) T] ) (* ; "Internal functions") (DEFINEQ (\EOF.ACTION [LAMBDA (STREAM) (* bvm%: "24-Aug-84 18:06") (* ;; "Standard thing to do at end of stream") (CL:FUNCALL (fetch (STREAM ENDOFSTREAMOP) of STREAM) STREAM]) (\EOSERROR [LAMBDA (STREAM) (* hdj "17-Jun-86 18:35") (LISPERROR "END OF FILE" (fetch (STREAM FULLNAME) of STREAM) T]) (\GETEOFPTR [LAMBDA (STREAM) (* lmm "25-MAY-83 23:17") (FDEVOP 'GETEOFPTR (fetch DEVICE of STREAM) STREAM]) (\INCFILEPTR [LAMBDA (STREAM AMOUNT) (* bvm%: " 7-Jun-84 16:47") (COND ((NOT (fetch PAGEMAPPED of (fetch DEVICE of STREAM))) (\SETFILEPTR STREAM (IPLUS (\GETFILEPTR STREAM) AMOUNT))) (T (\PAGED.INCFILEPTR STREAM AMOUNT]) (\PEEKBIN [LAMBDA (STREAM NOERRORFLG) (* bvm%: "26-DEC-81 15:59") (FDEVOP 'PEEKBIN (fetch DEVICE of STREAM) STREAM NOERRORFLG]) (\SETCLOSEDFILELENGTH [LAMBDA (FILENAME NBYTES) (* bvm%: "13-JUL-83 15:15") (* ;; "Reset the length of a closed file to nBytes.") (PROG [(STREAM (\OPENFILE FILENAME 'BOTH 'OLD] (\SETEOFPTR STREAM NBYTES) (\CLOSEFILE STREAM) (RETURN T]) (\SETEOFPTR [LAMBDA (STREAM LEN) (* bvm%: " 9-Jul-84 17:37") (FDEVOP 'SETEOFPTR (fetch DEVICE of STREAM) STREAM LEN]) (\SETFILEPTR [LAMBDA (STREAM INDX) (* rmk%: "22-AUG-83 13:37") (* ;; "Fast case of SETFILEPTR, assumes STREAM is a stream and INDX is an already coerced fileptr (not -1) Does not reset CHARPOSITION and value is uninteresting") (FDEVOP 'SETFILEPTR (fetch DEVICE of STREAM) STREAM INDX]) ) (DEFINEQ (\FIXPOUT [LAMBDA (STRM N) (* rmk%: "25-Jun-84 14:47") (\BOUT STRM (LOADBYTE N 24 BITSPERBYTE)) (\BOUT STRM (LOADBYTE N 16 BITSPERBYTE)) (\BOUT STRM (LOADBYTE N 8 BITSPERBYTE)) (\BOUT STRM (LOADBYTE N 0 BITSPERBYTE]) (\FIXPIN [LAMBDA (STRM) (* rmk%: "14-Jun-84 19:36") (* ;; "Read in a full 32 bit integer") (LOGOR (LLSH (\WIN STRM) 16) (\WIN STRM]) ) (DEFINEQ (\BOUTEOL [LAMBDA (STREAM) (* ; "Edited 6-Aug-2021 14:51 by rmk:") (* ;; "Convenient closed function to put out EOL characters without depending on EXPORTS.ALL for constants. .") (SELECTC (FETCH (STREAM EOLCONVENTION) OF STREAM) (LF.EOLC (\BOUT STREAM (CHARCODE LF))) (CR.EOLC (\BOUT STREAM (CHARCODE CR))) (CRLF.EOLC (\BOUT STREAM (CHARCODE CR)) (\BOUT STREAM (CHARCODE LF))) (ANY.EOLC (SHOULDNT)) NIL]) ) (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (PUTPROPS \DECFILEPTR MACRO ((STREAM X) (\INCFILEPTR STREAM (IMINUS X)))) (PUTPROPS \GETFILEPTR MACRO (OPENLAMBDA (STRM) (FDEVOP 'GETFILEPTR (fetch DEVICE of STRM) STRM))) (PUTPROPS \SIGNEDWIN MACRO ((STREAM) (SIGNED (\WIN STREAM) BITSPERWORD))) (PUTPROPS \SIGNEDWOUT MACRO ((STREAM N) (\WOUT STREAM (UNSIGNED N BITSPERWORD)))) (PUTPROPS \WIN MACRO (OPENLAMBDA (STREAM) (create WORD HIBYTE _ (\BIN STREAM) LOBYTE _ (\BIN STREAM)))) (PUTPROPS \WOUT MACRO (OPENLAMBDA (STREAM W) (\BOUT STREAM (fetch HIBYTE of W)) (\BOUT STREAM (fetch LOBYTE of W)))) (PUTPROPS \BINS BYTEMACRO (OPENLAMBDA (STRM BASE OFF NBYTES) (FDEVOP 'BLOCKIN (fetch (STREAM DEVICE) of STRM) STRM BASE OFF NBYTES))) (PUTPROPS \BOUTS BYTEMACRO (OPENLAMBDA (STRM BASE OFF NBYTES) (FDEVOP 'BLOCKOUT (fetch (STREAM DEVICE) of STRM) STRM BASE OFF NBYTES))) (PUTPROPS \EOFP BYTEMACRO (OPENLAMBDA (STRM) (FDEVOP 'EOFP (fetch (STREAM DEVICE) of STRM) STRM))) (PUTPROPS SIZE.FROM.LENGTH MACRO [LAMBDA (LEN) (DECLARE (LOCALVARS LEN)) (AND LEN (FOLDHI LEN BYTESPERPAGE]) ) (DECLARE%: EVAL@COMPILE (RPAQQ BitsPerByte 8) (RPAQ ByteOffsetSize (SELECTQ (SYSTEMTYPE) (VAX 10) 9)) (RPAQQ WordsPerPage 256) (CONSTANTS BitsPerByte (ByteOffsetSize (SELECTQ (SYSTEMTYPE) (VAX 10) 9)) WordsPerPage) ) (DECLARE%: EVAL@COMPILE (RPAQ \MAXFILEPTR (SUB1 (LLSH 1 30))) [CONSTANTS (\MAXFILEPTR (SUB1 (LLSH 1 30] ) (DECLARE%: EVAL@COMPILE (ACCESSFNS BYTEPTR ((PAGE (FOLDLO DATUM BYTESPERPAGE)) (OFFSET (MOD DATUM BYTESPERPAGE))) (TYPE? (AND (FIXP DATUM) (IGEQ DATUM 0) (ILEQ DATUM \MAXFILEPTR))) (CREATE (IPLUS (UNFOLD PAGE BYTESPERPAGE) OFFSET))) ) (* "END EXPORTED DEFINITIONS") (DECLARE%: EVAL@COMPILE (RPAQQ MaxChar 255) (CONSTANTS MaxChar) ) ) (* ; "Buffered IO") (DEFINEQ (\BUFFERED.BIN [LAMBDA (STREAM) (* bvm%: "10-Jul-84 13:25") (PROG (OFF X) RETRY [RETURN (\GETBASEBYTE (OR (fetch CBUFPTR of STREAM) (GO REFILL)) (PROG1 (SETQ OFF (fetch COFFSET of STREAM)) (COND ((IGEQ OFF (fetch CBUFSIZE of STREAM)) (GO REFILL))) (replace COFFSET of STREAM with (ADD1 OFF)))] REFILL (COND ((EQ (SETQ X (FDEVOP 'GETNEXTBUFFER (fetch DEVICE of STREAM) STREAM 'READ)) T) (GO RETRY)) (T (RETURN X]) (\BUFFERED.PEEKBIN [LAMBDA (STREAM NOERRORFLG) (* bvm%: "24-Aug-84 17:43") (PROG (OFF X) RETRY [RETURN (\GETBASEBYTE (OR (fetch CBUFPTR of STREAM) (GO REFILL)) (PROG1 (SETQ OFF (fetch COFFSET of STREAM)) (COND ((IGEQ OFF (fetch CBUFSIZE of STREAM)) (GO REFILL))))] REFILL (COND ((EQ (SETQ X (FDEVOP 'GETNEXTBUFFER (fetch DEVICE of STREAM) STREAM 'READ NOERRORFLG)) T) (GO RETRY)) (T (RETURN X]) (\BUFFERED.BOUT [LAMBDA (STREAM BYTE) (* bvm%: "10-Jul-84 13:30") (CHECK (type? STREAM STREAM) (WRITEABLE STREAM)) (PROG (OFF) RETRY (\PUTBASEBYTE (OR (fetch CBUFPTR of STREAM) (GO REFILL)) (PROG1 (SETQ OFF (fetch COFFSET of STREAM)) (COND ((ILESSP OFF (fetch CBUFMAXSIZE of STREAM)) (replace COFFSET of STREAM with (ADD1 OFF))) (T (GO REFILL)))) BYTE) (replace CBUFDIRTY of STREAM with T) (RETURN 1) REFILL (FDEVOP 'GETNEXTBUFFER (fetch DEVICE of STREAM) STREAM 'WRITE) (GO RETRY]) (\BUFFERED.BINS [LAMBDA (STREAM DBASE OFFSET NBYTES NOERRORFLG) (* bvm%: "11-Jul-84 19:15") (* ;;; "For buffered streams, BINs NBYTES bytes from STREAM to memory starting at DBASE+OFFSET --- If NOERRORFLG then stops without error at eof. Returns number of bytes actually read") (bind (BYTESLEFT _ NBYTES) CNT END IBASE START X do [COND ((SETQ IBASE (fetch CBUFPTR of STREAM)) (* ; "Current buffer") (SETQ START (fetch COFFSET of STREAM)) (* ; "Offset of first byte to transfer") [COND ((IGREATERP (SETQ CNT (IDIFFERENCE (SETQ END (fetch CBUFSIZE of STREAM)) START)) BYTESLEFT) (* ; "Not a whole buffer full") (SETQ END (IPLUS START (SETQ CNT BYTESLEFT] (* ; "First byte BEYOND whats to be read from this page") (\MOVEBYTES IBASE START DBASE OFFSET CNT) (replace COFFSET of STREAM with END) (COND ((EQ CNT BYTESLEFT) (* ; "Finished") (RETURN NBYTES)) (T (add OFFSET CNT) (SETQ BYTESLEFT (IDIFFERENCE BYTESLEFT CNT] (COND ((NULL (SETQ X (FDEVOP 'GETNEXTBUFFER (fetch DEVICE of STREAM) STREAM 'READ NOERRORFLG))) (* ; "No error at eof") (RETURN (IDIFFERENCE NBYTES BYTESLEFT))) ((NEQ X T) (* ; "At eof, but EOF op returned a value to fake more data at eof") (RETURN (do (\PUTBASEBYTE DBASE OFFSET X) (add OFFSET 1) (COND ((EQ (add BYTESLEFT -1) 0) (RETURN NBYTES))) (SETQ X (\BIN STREAM]) (\BUFFERED.BOUTS [LAMBDA (STREAM SBASE OFFSET NBYTES) (* bvm%: "10-Jul-84 13:39") (* ;;; "For buffered streams, bouts NBYTES bytes to STREAM from SBASE+OFFSET") (bind (DEV _ (fetch DEVICE of STREAM)) CNT END DBASE START do [COND ((SETQ DBASE (fetch CBUFPTR of STREAM)) (SETQ START (fetch COFFSET of STREAM)) [COND ((IGREATERP (SETQ CNT (IDIFFERENCE (SETQ END (fetch CBUFMAXSIZE of STREAM)) START)) NBYTES) (SETQ END (IPLUS START (SETQ CNT NBYTES] (\MOVEBYTES SBASE OFFSET DBASE START CNT) (replace COFFSET of STREAM with END) (replace CBUFDIRTY of STREAM with T) (COND ((ILEQ (SETQ NBYTES (IDIFFERENCE NBYTES CNT)) 0) (RETURN)) (T (add OFFSET CNT] (FDEVOP 'GETNEXTBUFFER DEV STREAM 'WRITE]) (\BUFFERED.COPYBYTES [LAMBDA (SRC DST NBYTES) (* bvm%: "10-Jul-84 21:48") (* ;;; "Copies NBYTES bytes from buffered stream SRC to arbitrary stream DST, or copies to eof if NBYTES is NIL") (bind (NOERRORFLG _ (NULL NBYTES)) (DEV _ (fetch DEVICE of SRC)) BUF NB STARTOFFSET END do [COND ((SETQ BUF (fetch CBUFPTR of SRC)) (* ; "Copy a buffer full") [SETQ NB (IDIFFERENCE (SETQ END (fetch CBUFSIZE of SRC)) (SETQ STARTOFFSET (fetch COFFSET of SRC] [COND ((AND NBYTES (IGREATERP NB NBYTES)) (* ; "Don't copy too much") (SETQ END (IPLUS STARTOFFSET (SETQ NB NBYTES] (\BOUTS DST BUF STARTOFFSET NB) (replace COFFSET of SRC with END) (COND (NBYTES (COND ((EQ NB NBYTES) (RETURN)) (T (SETQ NBYTES (IDIFFERENCE NBYTES NB] repeatwhile (FDEVOP 'GETNEXTBUFFER DEV SRC 'READ NOERRORFLG]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA \IS.NOT.RANDACCESSP \ILLEGAL.DEVICEOP STREAMPROP) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (27711 31827 (STREAMPROP 27721 . 28155) (GETSTREAMPROP 28157 . 28906) (PUTSTREAMPROP 28908 . 31675) (STREAMP 31677 . 31825)) (31870 35249 (\DEFPRINT.BY.NAME 31880 . 33032) ( \STREAM.DEFPRINT 33034 . 34942) (\FDEV.DEFPRINT 34944 . 35247)) (35507 40548 (\GETACCESS 35517 . 35971 ) (\SETACCESS 35973 . 40546)) (60774 66743 (\DEFINEDEVICE 60784 . 63100) (\GETDEVICEFROMNAME 63102 . 63575) (\GETDEVICEFROMHOSTNAME 63577 . 64621) (\REMOVEDEVICE 64623 . 65746) (\REMOVEDEVICE.NAMES 65748 . 66741)) (66783 93926 (\CLOSEFILE 66793 . 67618) (\DELETEFILE 67620 . 67914) (\DEVICEEVENT 67916 . 69686) (\GENERATEFILES 69688 . 70635) (\GENERATENEXTFILE 70637 . 71288) (\GENERATEFILEINFO 71290 . 71751) (\GETFILENAME 71753 . 72142) (\GENERIC.OUTFILEP 72144 . 72614) (\OPENFILE 72616 . 75194) ( \DO.PARAMS.AT.OPEN 75196 . 78665) (\RENAMEFILE 78667 . 79762) (\REVALIDATEFILE 79764 . 82366) ( \PAGED.REVALIDATEFILELST 82368 . 83926) (\PAGED.REVALIDATEFILES 83928 . 85647) (\PAGED.REVALIDATEFILE 85649 . 87932) (\BUFFERED.REVALIDATEFILE 87934 . 90220) (\BUFFERED.REVALIDATEFILELST 90222 . 91406) ( \PRINT-REVALIDATION-RESULT 91408 . 92250) (\TRUNCATEFILE 92252 . 92643) (\FILE-CONFLICT 92645 . 93924) ) (93962 98625 (\GENERATENOFILES 93972 . 96068) (\NULLFILEGENERATOR 96070 . 96314) (\NOFILESNEXTFILEFN 96316 . 98307) (\NOFILESINFOFN 98309 . 98623)) (98744 100652 (\FILE.NOT.OPEN 98754 . 99267) ( \FILE.WONT.OPEN 99269 . 99597) (\ILLEGAL.DEVICEOP 99599 . 99881) (\IS.NOT.RANDACCESSP 99883 . 100329) (\STREAM.NOT.OPEN 100331 . 100650)) (100787 103085 (\FDEVINSTANCE 100797 . 103083)) (104287 111258 ( CNDIR 104297 . 105602) (DIRECTORYNAME 105604 . 109384) (DIRECTORYNAMEP 109386 . 110002) (HOSTNAMEP 110004 . 110811) (\ADD.CONNECTED.DIR 110813 . 111256)) (111303 140250 (\BACKFILEPTR 111313 . 111501) ( \BACKPEEKBIN 111503 . 111864) (\BACKBIN 111866 . 112217) (BIN 112219 . 112436) (\BIN 112438 . 112715) (\BINS 112717 . 113003) (BOUT 113005 . 113367) (\BOUT 113369 . 113684) (\BOUTS 113686 . 113997) ( COPYBYTES 113999 . 117331) (COPYCHARS 117333 . 121131) (COPYFILE 121133 . 122493) (\COPYOPENFILE 122495 . 125694) (\INFER.FILE.TYPE 125696 . 126650) (EOFP 126652 . 126949) (FORCEOUTPUT 126951 . 127198) (\FLUSH.OPEN.STREAMS 127200 . 127556) (CHARSET 127558 . 128917) (ACCESS-CHARSET 128919 . 129556) (GETEOFPTR 129558 . 129808) (GETFILEINFO 129810 . 133003) (\TYPE.FROM.FILETYPE 133005 . 133475 ) (\FILETYPE.FROM.TYPE 133477 . 133656) (GETFILEPTR 133658 . 133910) (SETFILEINFO 133912 . 138149) ( SETFILEPTR 138151 . 139870) (BOUT16 139872 . 140057) (BIN16 140059 . 140248)) (140353 147533 ( \GENERIC.BINS 140363 . 140643) (\GENERIC.BOUTS 140645 . 140910) (\GENERIC.RENAMEFILE 140912 . 143160) (\GENERIC.OPENP 143162 . 144477) (\GENERIC.READP 144479 . 145631) (\GENERIC.CHARSET 145633 . 147531)) (147534 147873 (\MAP-OPEN-STREAMS 147544 . 147871)) (149728 151808 (\EOF.ACTION 149738 . 149989) ( \EOSERROR 149991 . 150184) (\GETEOFPTR 150186 . 150368) (\INCFILEPTR 150370 . 150720) (\PEEKBIN 150722 . 150913) (\SETCLOSEDFILELENGTH 150915 . 151249) (\SETEOFPTR 151251 . 151439) (\SETFILEPTR 151441 . 151806)) (151809 152351 (\FIXPOUT 151819 . 152119) (\FIXPIN 152121 . 152349)) (152352 152918 (\BOUTEOL 152362 . 152916)) (155814 165678 (\BUFFERED.BIN 155824 . 156676) (\BUFFERED.PEEKBIN 156678 . 157460) (\BUFFERED.BOUT 157462 . 158322) (\BUFFERED.BINS 158324 . 162009) (\BUFFERED.BOUTS 162011 . 163812) ( \BUFFERED.COPYBYTES 163814 . 165676))))) STOP