(FILECREATED "24-Sep-86 09:44:26" {ERIS}<LISPCORE>MSPF>FILEIO.;15 152056
changes to: (FNS \GETFILENAME.OR.STREAM \CLOSEFILE)
(VARS FILEIOCOMS)
previous date: "23-Sep-86 10:29:33" {ERIS}<LISPCORE>MSPF>FILEIO.;13)
(* Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT FILEIOCOMS)
(RPAQQ FILEIOCOMS
((* ;; "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))
\NORUNCODE)
(MACROS APPENDABLE APPENDONLY DIRTYABLE OPENED OVERWRITEABLE
READABLE READONLY WRITEABLE)
(MACROS TestMasked)
(MACROS \RUNCODED)
(CONSTANTS * EOLCONVENTIONS)))
(FNS STREAMPROP GETSTREAMPROP PUTSTREAMPROP STREAMP)
(COMS (* ; "make streams print pretty")
(FNS \STREAM.DEFPRINT)
(DECLARE: DONTEVAL@LOAD DOCOPY (P (DEFPRINT (QUOTE STREAM)
(FUNCTION \STREAM.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)
(FNS \CLOSEFILE \DELETEFILE \DEVICEEVENT \GENERATEFILES \GENERATENEXTFILE
\GENERATEFILEINFO \GETFILENAME \GETFILENAME.OR.STREAM \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 (QUOTE {DSK}))
(\CONNECTED.DIRECTORY (QUOTE {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 GETEOFPTR GETFILEINFO \TYPE.FROM.FILETYPE
\FILETYPE.FROM.TYPE GETFILEPTR SETFILEINFO SETFILEPTR BOUT16 BIN16)
(* ; "Generic functions")
(FNS \GENERIC.BINS \GENERIC.BOUTS \GENERIC.RENAMEFILE \GENERIC.OPENP \GENERIC.READP)
(FNS \MAP-OPEN-STREAMS)
(VARS FILING.TYPES)
(GLOBALVARS FILING.TYPES)
(DECLARE: DONTCOPY (EXPORT (MACROS \OUTCHAR \DEVICE-OPEN-STREAMS \CONVERT-PATHNAME)))
(DECLARE: DONTEVAL@LOAD DOCOPY (P (MAPC (QUOTE ((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)
(DECLARE: DONTCOPY (EXPORT (MACROS \DECFILEPTR \GETFILEPTR \SIGNEDWIN \SIGNEDWOUT \WIN
\WOUT \BINS \BOUTS \EOFP)
(CONSTANTS BitsPerByte (ByteOffsetSize (SELECTQ (SYSTEMTYPE)
(VAX 10)
9))
WordsPerPage)
(CONSTANTS (\MAXFILEPTR (SUB1 (LLSH 1 24))))
(RECORDS BYTEPTR))
(CONSTANTS MaxChar)))
(COMS (* ; "Buffered IO")
(FNS \BUFFERED.BIN \BUFFERED.PEEKBIN \BUFFERED.BOUT \BUFFERED.BINS \BUFFERED.BOUTS
\BUFFERED.COPYBYTES))
(COMS (* ; "NULL device")
(FNS \NULLDEVICE \NULL.OPENFILE)
(DECLARE: DONTEVAL@LOAD DOCOPY (P (\NULLDEVICE))))
(LOCALVARS . T)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA \IS.NOT.RANDACCESSP
\ILLEGAL.DEVICEOP
STREAMPROP)))))
(* ;; "Device independent IO. This file is used by VAX")
(* ;; "STREAM, FDEV declarations")
(DECLARE: FIRST DOCOPY
(/DECLAREDATATYPE (QUOTE STREAM)
(QUOTE (WORD WORD FLAG FLAG FLAG (BITS 5)
POINTER FLAG FLAG FLAG FLAG FLAG (BITS 3)
POINTER POINTER POINTER WORD WORD POINTER POINTER POINTER POINTER POINTER WORD
WORD BYTE POINTER WORD WORD WORD WORD WORD WORD (BITS 2)
FLAG
(BITS 5)
POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER
BYTE))
(QUOTE ((STREAM 0 (BITS . 15))
(STREAM 1 (BITS . 15))
(STREAM 2 (FLAGBITS . 0))
(STREAM 2 (FLAGBITS . 16))
(STREAM 2 (FLAGBITS . 32))
(STREAM 2 (BITS . 52))
(STREAM 2 POINTER)
(STREAM 4 (FLAGBITS . 0))
(STREAM 4 (FLAGBITS . 16))
(STREAM 4 (FLAGBITS . 32))
(STREAM 4 (FLAGBITS . 48))
(STREAM 4 (FLAGBITS . 64))
(STREAM 4 (BITS . 82))
(STREAM 4 POINTER)
(STREAM 6 POINTER)
(STREAM 8 POINTER)
(STREAM 10 (BITS . 15))
(STREAM 11 (BITS . 15))
(STREAM 12 POINTER)
(STREAM 14 POINTER)
(STREAM 16 POINTER)
(STREAM 18 POINTER)
(STREAM 20 POINTER)
(STREAM 22 (BITS . 15))
(STREAM 23 (BITS . 15))
(STREAM 20 (BITS . 7))
(STREAM 24 POINTER)
(STREAM 26 (BITS . 15))
(STREAM 27 (BITS . 15))
(STREAM 28 (BITS . 15))
(STREAM 29 (BITS . 15))
(STREAM 30 (BITS . 15))
(STREAM 31 (BITS . 15))
(STREAM 24 (BITS . 1))
(STREAM 24 (FLAGBITS . 32))
(STREAM 24 (BITS . 52))
(STREAM 32 POINTER)
(STREAM 34 POINTER)
(STREAM 36 POINTER)
(STREAM 38 POINTER)
(STREAM 40 POINTER)
(STREAM 42 POINTER)
(STREAM 44 POINTER)
(STREAM 46 POINTER)
(STREAM 48 (BITS . 15))
(STREAM 49 (BITS . 15))
(STREAM 50 POINTER)
(STREAM 50 (BITS . 7))))
(QUOTE 52))
)
[ADDTOVAR SYSTEMRECLST
(DATATYPE STREAM ((COFFSET WORD)
(CBUFSIZE WORD)
(BINABLE FLAG)
(BOUTABLE FLAG)
(EXTENDABLE FLAG)
(NIL BITS 5)
(CBUFPTR POINTER)
(NONDEFAULTDATEFLG FLAG)
(REVALIDATEFLG FLAG)
(MULTIBUFFERHINT FLAG)
(USERCLOSEABLE FLAG)
(USERVISIBLE FLAG)
(ACCESSBITS BITS 3)
(FULLFILENAME POINTER)
(DEVICE POINTER)
(VALIDATION POINTER)
(EPAGE WORD)
(EOFFSET WORD)
(F1 POINTER)
(F2 POINTER)
(F3 POINTER)
(F4 POINTER)
(F5 POINTER)
(FW6 WORD)
(FW7 WORD)
(BYTESIZE BYTE)
(BUFFS POINTER)
(CPAGE WORD)
(FW8 WORD)
(MAXBUFFERS WORD)
(CHARPOSITION WORD)
(DIRTYBITS WORD)
(LINELENGTH WORD)
(EOLCONVENTION BITS 2)
(CBUFDIRTY FLAG)
(NIL BITS 5)
(OUTCHARFN POINTER)
(ENDOFSTREAMOP POINTER)
(OTHERPROPS POINTER)
(IMAGEOPS POINTER)
(IMAGEDATA POINTER)
(EXTRASTREAMOP POINTER)
(STRMBINFN POINTER)
(STRMBOUTFN POINTER)
(CBUFMAXSIZE WORD)
(FW9 WORD)
(F10 POINTER)
(CHARSET BYTE)))
]
(DECLARE: DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
[DECLARE: EVAL@COMPILE
(DATATYPE STREAM
( (* First 4 words are fixed for BIN,
BOUT opcodes. Length of whole datatype
is multiple of 4, so quad-aligned)
(COFFSET WORD) (* Offset in CPPTR of next bin or bout)
(CBUFSIZE WORD) (* Offset past last byte in that
buffer)
(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)
(NIL BITS 5)
(CBUFPTR POINTER) (* Pointer to current buffer)
(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...)
(USERVISIBLE FLAG) (* Listed by OPENP; NIL for terminal,
dribble ...)
(ACCESSBITS BITS 3) (* What kind of access file is open
for (read, write, append))
(FULLFILENAME POINTER) (* Name by which file is known to user)
(DEVICE POINTER) (* FDEV of this guy)
(VALIDATION POINTER) (* A number somehow identifying file,
used to determine if file has changed
in our absence)
(EPAGE WORD)
(EOFFSET WORD) (* Page, byte offset of eof)
(* Following are device-specific
fields)
(F1 POINTER)
(F2 POINTER)
(F3 POINTER)
(F4 POINTER)
(F5 POINTER)
(FW6 WORD)
(FW7 WORD) (* Following only filled in for open
streams)
(BYTESIZE BYTE)
(BUFFS POINTER)
(CPAGE WORD)
(FW8 WORD)
(MAXBUFFERS WORD)
(CHARPOSITION WORD) (* Used by POSITION etc.)
(DIRTYBITS WORD)
(LINELENGTH WORD)
(EOLCONVENTION BITS 2) (* End-of-line convention)
(CBUFDIRTY FLAG)
(NIL BITS 5)
(OUTCHARFN POINTER)
(ENDOFSTREAMOP POINTER) (* For use of applications programs,
not devices)
(OTHERPROPS POINTER)
(IMAGEOPS POINTER) (* Image operations vector)
(IMAGEDATA POINTER) (* Image instance variables--format
depends on IMAGEOPS value)
(EXTRASTREAMOP POINTER)
(STRMBINFN POINTER) (* Either the BIN fn from the FDEV, or
a trap)
(STRMBOUTFN POINTER) (* Either the BIN fn from the FDEV, or
a trap)
(CBUFMAXSIZE WORD)
(FW9 WORD)
(F10 POINTER) (* the current character set for this
stream. gbn 4-2-85)
(CHARSET BYTE))
(BLOCKRECORD STREAM ((NIL 2 WORD)
(UCODEFLAGS BYTE)
(NIL POINTER)))
(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 BUFFS ← NIL BYTESIZE ← 8 CBUFPTR ←
NIL MAXBUFFERS ← (PROGN (DECLARE (GLOBALVARS \STREAM.DEFAULT.MAXBUFFERS))
\STREAM.DEFAULT.MAXBUFFERS)
CHARPOSITION ← 0 LINELENGTH ← (PROGN (DECLARE (GLOBALVARS FILELINELENGTH))
FILELINELENGTH)
OUTCHARFN ← (FUNCTION \FILEOUTCHARFN)
ENDOFSTREAMOP ← (FUNCTION \EOSERROR)
IMAGEOPS ← \NOIMAGEOPS EOLCONVENTION ← (SELECTQ (SYSTEMTYPE)
(D CR.EOLC)
(VAX LF.EOLC)
(JERICHO CRLF.EOLC)
CR.EOLC)
STRMBINFN ← (FUNCTION \STREAM.NOT.OPEN)
STRMBOUTFN ← (FUNCTION \STREAM.NOT.OPEN))
]
(/DECLAREDATATYPE (QUOTE STREAM)
(QUOTE (WORD WORD FLAG FLAG FLAG (BITS 5)
POINTER FLAG FLAG FLAG FLAG FLAG (BITS 3)
POINTER POINTER POINTER WORD WORD POINTER POINTER POINTER POINTER POINTER WORD
WORD BYTE POINTER WORD WORD WORD WORD WORD WORD (BITS 2)
FLAG
(BITS 5)
POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER
BYTE))
(QUOTE ((STREAM 0 (BITS . 15))
(STREAM 1 (BITS . 15))
(STREAM 2 (FLAGBITS . 0))
(STREAM 2 (FLAGBITS . 16))
(STREAM 2 (FLAGBITS . 32))
(STREAM 2 (BITS . 52))
(STREAM 2 POINTER)
(STREAM 4 (FLAGBITS . 0))
(STREAM 4 (FLAGBITS . 16))
(STREAM 4 (FLAGBITS . 32))
(STREAM 4 (FLAGBITS . 48))
(STREAM 4 (FLAGBITS . 64))
(STREAM 4 (BITS . 82))
(STREAM 4 POINTER)
(STREAM 6 POINTER)
(STREAM 8 POINTER)
(STREAM 10 (BITS . 15))
(STREAM 11 (BITS . 15))
(STREAM 12 POINTER)
(STREAM 14 POINTER)
(STREAM 16 POINTER)
(STREAM 18 POINTER)
(STREAM 20 POINTER)
(STREAM 22 (BITS . 15))
(STREAM 23 (BITS . 15))
(STREAM 20 (BITS . 7))
(STREAM 24 POINTER)
(STREAM 26 (BITS . 15))
(STREAM 27 (BITS . 15))
(STREAM 28 (BITS . 15))
(STREAM 29 (BITS . 15))
(STREAM 30 (BITS . 15))
(STREAM 31 (BITS . 15))
(STREAM 24 (BITS . 1))
(STREAM 24 (FLAGBITS . 32))
(STREAM 24 (BITS . 52))
(STREAM 32 POINTER)
(STREAM 34 POINTER)
(STREAM 36 POINTER)
(STREAM 38 POINTER)
(STREAM 40 POINTER)
(STREAM 42 POINTER)
(STREAM 44 POINTER)
(STREAM 46 POINTER)
(STREAM 48 (BITS . 15))
(STREAM 49 (BITS . 15))
(STREAM 50 POINTER)
(STREAM 50 (BITS . 7))))
(QUOTE 52))
(DECLARE: EVAL@COMPILE
(PUTPROPS STREAMOP MACRO (ARGS (CONS (QUOTE SPREADAPPLY*)
(CONS (COND ((EQ (CAR (LISTP (CAR ARGS)))
(QUOTE QUOTE))
(LIST (QUOTE fetch)
(CADAR ARGS)
(QUOTE 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))
(RPAQQ \NORUNCODE 255)
(CONSTANTS AppendBit NoBits ReadBit WriteBit (OutputBits (LOGOR AppendBit WriteBit))
(BothBits (LOGOR ReadBit OutputBits))
\NORUNCODE)
)
(DECLARE: EVAL@COMPILE
(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)))))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS TestMasked MACRO ((BITS MASK)
(NEQ (LOGAND BITS MASK)
0)))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS \RUNCODED MACRO (OPENLAMBDA (STREAM)
(* returns NIL is the stream is not runcoded, that is, if the stream
has 16 bit bytes explicitly represented)
(* note that neq is ok since charsets are known to be SMALLP's)
(NEQ (fetch CHARSET of STREAM)
\NORUNCODE)))
)
(RPAQQ EOLCONVENTIONS ((CR.EOLC 0)
(LF.EOLC 1)
(CRLF.EOLC 2)))
(DECLARE: EVAL@COMPILE
(RPAQQ CR.EOLC 0)
(RPAQQ LF.EOLC 1)
(RPAQQ CRLF.EOLC 2)
(CONSTANTS (CR.EOLC 0)
(LF.EOLC 1)
(CRLF.EOLC 2))
)
(* 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) (* rda: "22-Aug-84 16:17")
(OR (type? STREAM STREAM)
(\ILLEGAL.ARG))
(LISTGET (fetch (STREAM OTHERPROPS) of STREAM)
PROP)))
(PUTSTREAMPROP
(LAMBDA (STREAM PROP VALUE) (* rda: "22-Aug-84 16:11")
(OR (type? STREAM STREAM)
(\ILLEGAL.ARG 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
(\STREAM.DEFPRINT
(LAMBDA (ITEM OUTSTREAM) (* hdj "15-Sep-86 12:58")
(DECLARE (SPECVARS *READTABLE*))
(LET ((HILOC-STRING (OCTALSTRING (\HILOC ITEM)))
(LOLOC-STRING (OCTALSTRING (\LOLOC ITEM)))
(HASHMACROCHAR (CHARACTER (fetch (READTABLEP HASHMACROCHAR) of *READTABLE*))))
(LIST (CONCAT HASHMACROCHAR "<" (SELECTQ (fetch (STREAM ACCESS) of ITEM)
(INPUT "Input ")
(OUTPUT "Output ")
(BOTH "IO ")
"Closed ")
"Stream " HILOC-STRING "," LOLOC-STRING (if (fetch (STREAM NAMEDP) of ITEM)
then (CONCAT " on "
(fetch (STREAM
FULLFILENAME
)
of ITEM)
">")
else ">"))))))
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(DEFPRINT (QUOTE STREAM)
(FUNCTION \STREAM.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 (QUOTE INPUT))
(AppendBit (QUOTE APPEND))
(OutputBits (QUOTE OUTPUT))
(BothBits (QUOTE 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 QUOTE)))
(BQUOTE (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)))
(BQUOTE (if (type? STREAM (\, NAME))
then
(\, NAME)
else
(FDEVOP (QUOTE GETFILENAME)
(\, DEVICE)
(\, NAME)
(\, RECOG)
(\, DEVICE)))))))
)
[DECLARE: EVAL@COMPILE
(DATATYPE FDEV ((DEVICENAME POINTER)
(RESETABLE FLAG)
(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")
(* ; "Device operations:")
(REMOTEP FLAG) (* ; "true if device not local to machine")
(SUBDIRECTORIES FLAG) (* ; "true if device has real subdirectories")
(NIL 6 FLAG)
(CLOSEFILE POINTER) (* ; "(stream) => closes stream, returns it")
(DELETEFILE POINTER) (* ;
"(name) => deletes file so named, returning name, or NIL on failure. RECOG=OLDEST")
(DIRECTORYNAMEP POINTER) (* ;
"(host/dir) => true if directory exists on host")
(EVENTFN POINTER) (* ;
"(device event), called before/after logout, sysout, makesys")
(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")
(GETFILEINFO POINTER) (* ;
"(stream/name attribute device) => value of attribute for open stream or name of closed file")
(GETFILENAME POINTER) (* ; "(name recog device) => full file name")
(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")
(OPENFILE POINTER) (* ;
"(name access recog otherinfo device) => new stream open on this device, or NIL if name not found")
(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)")
(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")
(SETFILEINFO POINTER) (* ;
"(stream/name attribute newvalue device) sets attribute of open stream or closed file of given name")
(TRUNCATEFILE POINTER) (* ;
"(stream page offset) make stream's eof be at page,offset, discarding anything after it")
(WRITEPAGES POINTER) (* ;
"(stream firstpage# buflist) writes from buflist to stream starting at firstpage# of stream")
(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")
(READP POINTER) (* ;
"(stream flag) => T if there is input available from stream")
(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")
(DEVICEINFO POINTER) (* ; "arbitrary device-specific info stored here")
(FORCEOUTPUT POINTER) (* ;
"(stream waitForFinish) flushes out to device anything that is buffered awaiting transmission")
(LASTC POINTER) (* ; "Should be possible only if RANDOMACCESSP")
(SETFILEPTR POINTER)
(GETFILEPTR POINTER)
(GETEOFPTR POINTER)
(EOFP POINTER)
(BLOCKIN POINTER) (* ; "(stream buffer byteoffset nbytes)")
(BLOCKOUT POINTER) (* ; "(stream buffer byteoffset nbytes)")
(RENAMEFILE POINTER) (* ; "oldfile newfile device")
(RELEASEBUFFER POINTER) (* ;
"(stream) => Does whatever appropriate when CBUFPTR is released")
(GETNEXTBUFFER POINTER) (* ;; "(stream whatfor noerrorflg) => Disposes of current buffer and optionally reads next. whatfor is READ or WRITE. Can cause EOF error unless noerrorflg")
(SETEOFPTR POINTER) (* ;
"(stream length) => truncates or lengthens stream to indicated length")
(FREEPAGECOUNT POINTER) (* ;
"(host/dir dev) => # of free pages on host/dir")
(MAKEDIRECTORY POINTER) (* ; "(host/dir dev)")
(WINDOWOPS POINTER) (* ; "window system operations")
(WINDOWDATA POINTER) (* ; "data for window systems")
(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")
(OPENP POINTER) (* ;
"(name access dev) => stream if name is open for access, or all open streams if name = NIL")
(OPENFILELST POINTER) (* ;
"Default place to keep list of streams open on this device")
(REGISTERFILE POINTER) (* ;
"(stream dev) => registers stream on its device")
(UNREGISTERFILE POINTER) (* ;
"(stream dev) => unregisters a stream from its device")
)
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))
(RECORD FILEGENOBJ (NEXTFILEFN FILEINFOFN . GENFILESTATE))
]
(/DECLAREDATATYPE (QUOTE FDEV)
(QUOTE (POINTER FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG 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))
(QUOTE ((FDEV 0 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 (FLAGBITS . 0))
(FDEV 2 (FLAGBITS . 16))
(FDEV 2 (FLAGBITS . 32))
(FDEV 2 (FLAGBITS . 48))
(FDEV 2 (FLAGBITS . 64))
(FDEV 2 (FLAGBITS . 80))
(FDEV 2 (FLAGBITS . 96))
(FDEV 2 (FLAGBITS . 112))
(FDEV 2 POINTER)
(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)))
(QUOTE 86))
(* END EXPORTED DEFINITIONS)
)
(/DECLAREDATATYPE (QUOTE FDEV)
(QUOTE (POINTER FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG 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))
(QUOTE ((FDEV 0 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 (FLAGBITS . 0))
(FDEV 2 (FLAGBITS . 16))
(FDEV 2 (FLAGBITS . 32))
(FDEV 2 (FLAGBITS . 48))
(FDEV 2 (FLAGBITS . 64))
(FDEV 2 (FLAGBITS . 80))
(FDEV 2 (FLAGBITS . 96))
(FDEV 2 (FLAGBITS . 112))
(FDEV 2 POINTER)
(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)))
(QUOTE 86))
[ADDTOVAR SYSTEMRECLST
(DATATYPE FDEV ((DEVICENAME POINTER)
(RESETABLE FLAG)
(RANDOMACCESSP FLAG)
(NODIRECTORIES FLAG)
(PAGEMAPPED FLAG)
(FDBINABLE FLAG)
(FDBOUTABLE FLAG)
(FDEXTENDABLE FLAG)
(BUFFERED FLAG)
(REMOTEP FLAG)
(SUBDIRECTORIES FLAG)
(NIL 6 FLAG)
(CLOSEFILE POINTER)
(DELETEFILE POINTER)
(DIRECTORYNAMEP POINTER)
(EVENTFN POINTER)
(GENERATEFILES POINTER)
(GETFILEINFO POINTER)
(GETFILENAME POINTER)
(HOSTNAMEP POINTER)
(OPENFILE POINTER)
(READPAGES POINTER)
(REOPENFILE POINTER)
(SETFILEINFO POINTER)
(TRUNCATEFILE POINTER)
(WRITEPAGES POINTER)
(BIN POINTER)
(BOUT POINTER)
(PEEKBIN POINTER)
(READP POINTER)
(BACKFILEPTR POINTER)
(DEVICEINFO POINTER)
(FORCEOUTPUT POINTER)
(LASTC POINTER)
(SETFILEPTR POINTER)
(GETFILEPTR POINTER)
(GETEOFPTR POINTER)
(EOFP POINTER)
(BLOCKIN POINTER)
(BLOCKOUT POINTER)
(RENAMEFILE POINTER)
(RELEASEBUFFER POINTER)
(GETNEXTBUFFER POINTER)
(SETEOFPTR POINTER)
(FREEPAGECOUNT POINTER)
(MAKEDIRECTORY POINTER)
(WINDOWOPS POINTER)
(WINDOWDATA POINTER)
(CHECKFILENAME POINTER)
(HOSTALIVEP POINTER)
(OPENP POINTER)
(OPENFILELST POINTER)
(REGISTERFILE POINTER)
(UNREGISTERFILE 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 (QUOTE 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 (QUOTE 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))
)))))
)
(DEFINEQ
(\CLOSEFILE
(LAMBDA (STREAM) (* hdj "23-Sep-86 13:33")
(* ;
"Close the file specified by the given open file descriptor and return the file handle.")
(COND
((NOT (READONLY STREAM))
(IMAGEOP (QUOTE IMCLOSEFN)
STREAM STREAM) (* ;
"Do image-specific operations before physically closing the stream")
))
(FDEVOP (QUOTE CLOSEFILE)
(fetch (STREAM DEVICE) of STREAM)
STREAM)
(FDEVOP (QUOTE UNREGISTERFILE)
(fetch (STREAM DEVICE) of STREAM)
STREAM)
(replace (STREAM ACCESS) of STREAM with NIL) (* ; "This marks the STREAM as closed")
STREAM))
(\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 (QUOTE DELETEFILE)
DEV FILENAME DEV))))
(\DEVICEEVENT
(LAMBDA (EVENT) (* hdj " 5-Jun-86 12:38")
(* 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))
(for D in (SELECTQ EVENT
((BEFORELOGOUT BEFOREMAKESYS BEFORESYSOUT BEFORESAVEVM)
(* Mark output files as needing
revalidation if we write to them again)
(\MAP-OPEN-STREAMS (FUNCTION (LAMBDA (STREAM)
(if (AND (DIRTYABLE STREAM)
(NOT (fetch (STREAM NONDEFAULTDATEFLG)
of STREAM)))
then (replace (STREAM REVALIDATEFLG)
of STREAM with T))))
\FILEDEVICES NIL)
\FILEDEVICES)
(REVERSE \FILEDEVICES)) do (FDEVOP (QUOTE EVENTFN)
D D EVENT))))
(\GENERATEFILES
(LAMBDA (PATTERN DESIREDPROPS OPTIONS) (* 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))
(PROG ((FDEV (\GETDEVICEFROMNAME PATTERN)))
(RETURN (FDEVOP (QUOTE 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)
(APPLY* (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)
(APPLY* (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 (QUOTE GETFILENAME)
FDEV NAME RECOG FDEV)))))
(\GETFILENAME.OR.STREAM
(LAMBDA (NAME RECOG FDEV) (* hdj "23-Sep-86 17:41")
(* ;;
"If NAME is an open stream, returns the stream, else returns full name according to RECOG")
(SETQ NAME (\CONVERT-PATHNAME NAME))
(COND
((type? STREAM NAME)
NAME)
(T (SETQ NAME (\ADD.CONNECTED.DIR NAME))
(COND
((SETQ NAME (AND (OR FDEV (SETQ FDEV (\GETDEVICEFROMNAME NAME T)))
(FDEVOP (QUOTE GETFILENAME)
FDEV NAME RECOG FDEV)))
NAME))))))
(\GENERIC.OUTFILEP
(LAMBDA (NAME DEV) (* lmm " 6-Jan-85 17:41")
(PROG ((V (FDEVOP (QUOTE GETFILENAME)
DEV NAME (QUOTE OLD)
DEV)))
(RETURN (if V
then (PACKFILENAME (QUOTE VERSION)
(ADD1 (OR (FILENAMEFIELD V (QUOTE VERSION))
1))
(QUOTE BODY)
V)
else (PACKFILENAME (QUOTE VERSION)
1
(QUOTE BODY)
NAME))))))
(\OPENFILE
(LAMBDA (NAME ACCESS RECOG PARAMETERS) (* hdj "12-Sep-86 10:48")
(* * "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 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 (QUOTE OPENFILE)
FDEV CDNAME ACCESS RECOG PARAMETERS FDEV))
(replace ACCESS of STREAM with ACCESS)
(replace CPAGE of STREAM with (COND
((EQ ACCESS (QUOTE APPEND))
(fetch EPAGE of STREAM))
(T 0)))
(replace COFFSET of STREAM with (COND
((EQ ACCESS (QUOTE APPEND))
(fetch EOFFSET of STREAM))
(T 0)))
(\DO.PARAMS.AT.OPEN STREAM ACCESS PARAMETERS)
(FDEVOP (QUOTE REGISTERFILE)
FDEV FDEV STREAM)
(RETURN STREAM))
(T (SETQ NAME (LISPERROR "FILE NOT FOUND" NAME))
(GO RETRY))))))
(\DO.PARAMS.AT.OPEN
(LAMBDA (STREAM ACCESS PARAMETERS) (* rmk: "27-Mar-85 18:02")
(* Does generic parameters when a
file/stream is open.
Called by \OPENFILE and OPENSTREAM)
(for X ATTR VAL 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 (QUOTE BUFFERS)
VAL))
(ENDOFSTREAMOP (SETFILEINFO STREAM (QUOTE ENDOFSTREAMOP)
VAL))
(CHARSET (CHARSET STREAM VAL))
NIL))))
(\RENAMEFILE
(LAMBDA (OLDFILE NEWFILE) (* hdj " 7-May-86 12:22")
(SETQ OLDFILE (\ADD.CONNECTED.DIR OLDFILE))
(SETQ NEWFILE (\ADD.CONNECTED.DIR NEWFILE))
(LET ((OLD-DEVICE (\GETDEVICEFROMNAME OLDFILE T))
(NEW-DEVICE (\GETDEVICEFROMNAME NEWFILE T)))
(AND OLD-DEVICE (FDEVOP (QUOTE RENAMEFILE)
OLD-DEVICE OLD-DEVICE OLDFILE NEW-DEVICE NEWFILE)))))
(\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 (QUOTE REOPENFILE)
(fetch DEVICE of STREAM)
(fetch FULLFILENAME of STREAM)
(fetch ACCESS of STREAM)
(QUOTE OLD)
NIL
(fetch DEVICE of STREAM)
STREAM)))
(RETURN (COND
((NOT NEWSTREAM)
(QUOTE 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))
(QUOTE CHANGED)))))))))
(\PAGED.REVALIDATEFILELST
(LAMBDA (DEVICE) (* hdj "16-Sep-86 18:51")
(* * Revalidate all of the open files on DEVICE
(a PMAP device))
(bind REASON PAGES for STREAM in (FDEVOP (QUOTE 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 (QUOTE AFTERCLOSE))
(FUNCTION (LAMBDA (FN)
(APPLY* FN STREAM))))
(replace ACCESS of STREAM with NIL)
(\DELETE-OPEN-STREAM STREAM DEVICE))
(SHOULDNT))
(\PRINT-REVALIDATION-RESULT REASON STREAM)))
(* might as well return something
useful)
(FDEVOP (QUOTE OPENP)
DEVICE NIL NIL DEVICE)))
(\PAGED.REVALIDATEFILES
(LAMBDA (LIST) (* hdj "16-Sep-86 18:52")
(* * "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 (QUOTE AFTERCLOSE))
(FUNCTION (LAMBDA (FN)
(APPLY* FN STREAM))))
(replace ACCESS of STREAM with NIL)
(\DELETE-OPEN-STREAM STREAM (fetch (STREAM DEVICE) of 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 (QUOTE REOPENFILE)
(fetch DEVICE of STREAM)
(fetch FULLFILENAME of STREAM)
(fetch ACCESS of STREAM)
(QUOTE OLD)
NIL
(fetch DEVICE of STREAM)
STREAM)))
(COND
((NOT NEWSTREAM)
(QUOTE 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))
(QUOTE 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 (QUOTE REOPENFILE)
(fetch DEVICE of STREAM)
(fetch FULLFILENAME of STREAM)
(fetch ACCESS of STREAM)
(QUOTE OLD)
NIL
(fetch DEVICE of STREAM)
STREAM)))
(COND
((NOT NEWSTREAM)
(QUOTE 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))
(QUOTE CHANGED))))))))
(\BUFFERED.REVALIDATEFILELST
(LAMBDA (DEVICE) (* hdj "16-Sep-86 18:52")
(* * Revalidate all of the open files on DEVICE
(a buffered device))
(bind REASON for STREAM in (FDEVOP (QUOTE 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 (QUOTE AFTERCLOSE))
(FUNCTION (LAMBDA (FN)
(APPLY* FN STREAM))))
(replace ACCESS of STREAM with NIL)
(\DELETE-OPEN-STREAM STREAM DEVICE)
(\PRINT-REVALIDATION-RESULT REASON STREAM))
(SHOULDNT))))
(* * might as well return something useful)
(FDEVOP (QUOTE OPENP)
DEVICE NIL NIL DEVICE)))
(\PRINT-REVALIDATION-RESULT
(LAMBDA (RESULT STREAM) (* hdj "26-May-86 15:46")
(printout T T T "**** WARNING: The file " (fetch (STREAM FULLNAME) of STREAM))
(SELECTQ RESULT
(CHANGED (printout T " has been modified since you last accessed it!" T))
(DELETED (printout T " was previously opened but has disappeared!" T))
(SHOULDNT))))
(\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 (QUOTE TRUNCATEFILE)
(fetch DEVICE of STREAM)
STREAM LASTPAGE LASTOFFSET)))
(\FILE-CONFLICT
(LAMBDA (NAME ACCESS DEVICE) (* hdj "11-Sep-86 15:24")
(* ;; "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 (QUOTE 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 (AND (EQ ACCESS (QUOTE INPUT))
(EQ EXISTING-ACCESS-MODE (QUOTE INPUT)))
then (* "no conflict")
NIL
else T))
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 (QUOTE *)
PATTERN))
(ESC (STRPOS (QUOTE (CONSTANT (CHARACTER (CHARCODE ESC))))
PATTERN)))
(RETURN (COND
((AND (OR (NULL STAR)
(AND (EQ (NTHCHARCODE PATTERN (SUB1 STAR))
(CHARCODE ;))
(NULL (STRPOS (QUOTE *)
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))
(QUOTE NOSTAR))
(T (SETQ PATTERN
(PACKFILENAME (QUOTE VERSION)
NIL
(QUOTE BODY)
PATTERN))
(QUOTE 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 (QUOTE 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)
(QUOTE OLDEST)))
(replace NOFILETYPE of GENFILESTATE
with (CONS (FILENAMEFIELD FILE (QUOTE VERSION))
(FILENAMEFIELD (INFILEP (fetch NOFILEPATTERN of GENFILESTATE))
(QUOTE 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 (QUOTE VERSION)
VER
(QUOTE BODY)
(fetch NOFILEPATTERN of GENFILESTATE))))
(RPLACA TYPE (FILENAMEFIELD FILE (QUOTE 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 (QUOTE (NEWARGS OPNAME . ARGS))
(CONS (SUBST (QUOTE (fetch DEVICEINFO of FDEV))
(QUOTE FDEV)
(CDR X))
X)
(QUOTE (FUNCTION (LAMBDA ARGS (FDEVOP (QUOTE OPNAME)
(fetch DEVICEINFO of
FDEV) . NEWARGS
)))))))
(PUTPROPS \INHERITFDEVOP.S MACRO ((OPNAME . ARGS)
(FUNCTION (LAMBDA ARGS (FDEVOP (QUOTE OPNAME)
(fetch DEVICEINFO of
(fetch DEVICE of STREAM)) . ARGS
)))))
)
(RPAQ? LOGINHOST/DIR (QUOTE {DSK}))
(RPAQ? \CONNECTED.DIRECTORY (QUOTE {DSK}))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS LOGINHOST/DIR \CONNECTED.DIRECTORY \FILEDEVICES \FILEDEVICENAMES \DEVICENAMETODEVICE)
)
(* ; "Directory defaulting")
(DEFINEQ
(CNDIR
(LAMBDA (HOST/DIR) (* hdj "16-Jul-86 15:20")
(* * "Connects to HOST/DIR, verifying that HOST/DIR exists.")
(DECLARE (GLOBALVARS *DEFAULT-PATHNAME-DEFAULTS* \CONNECTED.DIRECTORY))
(LET ((TEMP-DEFAULTS (PATHNAME (SETQ \CONNECTED.DIRECTORY (OR (DIRECTORYNAME (AND HOST/DIR
(
\CONVERT-PATHNAME
HOST/DIR))
T
(QUOTE ASK))
(ERROR "Non-existent directory"
HOST/DIR))))))
(SETF (%%PATHNAME-HOST *DEFAULT-PATHNAME-DEFAULTS*)
(PATHNAME-HOST TEMP-DEFAULTS))
(SETF (%%PATHNAME-DIRECTORY *DEFAULT-PATHNAME-DEFAULTS*)
(PATHNAME-DIRECTORY TEMP-DEFAULTS)))
\CONNECTED.DIRECTORY))
(DIRECTORYNAME
(LAMBDA (DIRNAME STRPTR CREATE?) (* hdj "17-Jun-86 18:33")
(* Returns connected directory name)
(SELECTQ (SYSTEMTYPE)
(VAX (GETDIRNAME))
(D (DECLARE (GLOBALVARS LOGINHOST/DIR))
(PROG (DN FDEV)
(SELECTQ DIRNAME
(T (* Connected host/dir)
(SETQ DN \CONNECTED.DIRECTORY))
(NIL (SETQ DN (OR LOGINHOST/DIR (QUOTE {DSK}))))
(COND
((AND (SETQ FDEV (LET ((HOST (FILENAMEFIELD DIRNAME (QUOTE HOST))))
(\GETDEVICEFROMHOSTNAME
(OR HOST (FILENAMEFIELD (SETQ DIRNAME
(PACKFILENAME.STRING
(QUOTE DIRECTORY)
DIRNAME
(QUOTE DIRECTORY)
\CONNECTED.DIRECTORY))
(QUOTE HOST))))))
(SETQ DN (FDEVOP (QUOTE DIRECTORYNAMEP)
FDEV DIRNAME FDEV CREATE?)))
(COND
((EQ DN T)
(SETQ DN (PACKFILENAME.STRING (QUOTE HOST)
(fetch (FDEV DEVICENAME) of FDEV)
(QUOTE DIRECTORY)
DIRNAME)))))
(T (RETURN))))
(RETURN (if (NOT STRPTR)
then (MKSTRING DN)
elseif (EQ STRPTR T)
then (MKATOM DN)
else (MKSTRING DN)))))
(HELP))))
(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 (QUOTE DIRECTORY)
DIRNAME
(QUOTE HOST)
HOSTNAME))
(T (PACKFILENAME.STRING (QUOTE DIRECTORY)
DIRNAME
(QUOTE DIRECTORY)
\CONNECTED.DIRECTORY))))
FDEV)
(AND (SETQ FDEV (\GETDEVICEFROMNAME DN T))
(FDEVOP (QUOTE 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 (QUOTE })
N 2)
(RETURN NIL)))))))
(RETURN (AND (OR (MEMB N \FILEDEVICENAMES)
(find D in \FILEDEVICES suchthat (FDEVOP (QUOTE HOSTNAMEP)
D N)))
T)))))
(\ADD.CONNECTED.DIR
(LAMBDA (FILENAME) (* lmm " 9-Oct-84 13:36")
(* * Modifies the filename to include connected host and/or dir)
(if (AND (OR (LITATOM FILENAME)
(STRINGP FILENAME))
(NOT (FILENAMEFIELD FILENAME (QUOTE HOST))))
then (PACKFILENAME (QUOTE BODY)
FILENAME
(QUOTE DIRECTORY)
\CONNECTED.DIRECTORY)
else FILENAME)))
)
(* ; "Binary I/O
Public functions")
(DEFINEQ
(\BACKFILEPTR
(LAMBDA (STREAM) (* bvm: "30-JAN-82 16:59")
(FDEVOP (QUOTE 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 (QUOTE STRMBINFN)
(SETQ STREAM (\DTEST STREAM (QUOTE STREAM)))
STREAM)))
(\BINS
(LAMBDA (STREAM BASE OFF NBYTES) (* bvm: "25-MAY-83 12:48")
(* BINs NBYTES bytes from STREAM into
BASE+OFF)
(FDEVOP (QUOTE BLOCKIN)
(ffetch DEVICE of (SETQ STREAM (\DTEST STREAM (QUOTE STREAM))))
STREAM BASE OFF NBYTES)))
(BOUT
(LAMBDA (STREAM BYTE) (* rmk: "21-OCT-83 14:40")
(* MERELY EXECUTE OPCODE)
(\BOUT STREAM BYTE)))
(\BOUT
(LAMBDA (STREAM BYTE) (* rmk: " 2-NOV-83 14:32")
(STREAMOP (QUOTE STRMBOUTFN)
(SETQ STREAM (\DTEST STREAM (QUOTE 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 (QUOTE BLOCKOUT)
(ffetch DEVICE of (SETQ STREAM (\DTEST STREAM (QUOTE STREAM))))
STREAM BASE OFF NBYTES)))
(COPYBYTES
(LAMBDA (SRCFIL DSTFIL START END) (* rmk: "11-Mar-85 12:13")
(* Copies bytes from START up to but
not including END from SRCFIL into
DSTFIL.)
(PROG ((SRC (\GETSTREAM SRCFIL (QUOTE INPUT)))
(DST (\GETSTREAM DSTFIL (QUOTE OUTPUT)))
NBYTES)
(SETQ NBYTES (COND
(END (* Specified a start and ending)
(if (EQUAL START END)
then (* special case: no bytes to copy)
(RETURN))
(\SETFILEPTR SRC (COND
((type? BYTEPTR START)
START)
(T (\ILLEGAL.ARG START))))
(IDIFFERENCE (COND
((EQ END -1)
(\GETEOFPTR SRC))
((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 (AND (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) (* rmk: "11-Mar-85 12:12")
(* This is similar to COPYBYTES except
that conversion is done between the
EOL convention of the input and the
EOL convention of the output)
(PROG ((SRCSTRM (\GETSTREAM SRCFIL))
(DSTSTRM (\GETSTREAM DSTFIL))
(ACTUALSTART 0)
RAP ACTUALEND EOF SRCEOLC DSTEOLC CH)
(COND
((EQ (SETQ SRCEOLC (fetch EOLCONVENTION of SRCSTRM))
(SETQ DSTEOLC (fetch EOLCONVENTION of DSTSTRM)))
(RETURN (COPYBYTES SRCSTRM DSTSTRM START END))))
(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 (until (\EOFP SRCSTRM) do (\OUTCHAR DSTSTRM (\INCHAR SRCSTRM)))
(* Not RAP and START and END are both
NIL. Slow copy to the end of the file.)
(RETURN)))
(OR (IGEQ ACTUALEND ACTUALSTART)
(ERROR "Negative number of bytes to copy" (IDIFFERENCE ACTUALEND ACTUALSTART)))
(* We only have to worry about
mismatched EOLCs)
(SELECTC SRCEOLC
(CR.EOLC (* DST is either CRLF or LF)
(FRPTQ (IDIFFERENCE ACTUALEND ACTUALSTART)
(SELCHARQ (SETQ CH (\BIN SRCSTRM))
(CR (AND (EQ DSTEOLC CRLF.EOLC)
(\BOUT DSTSTRM (CHARCODE CR)))
(\BOUT DSTSTRM (CHARCODE LF)))
(\BOUT DSTSTRM CH))))
(LF.EOLC (* DST is either CRLF or CR)
(FRPTQ (IDIFFERENCE ACTUALEND ACTUALSTART)
(SELCHARQ (SETQ CH (\BIN SRCSTRM))
(LF (\BOUT DSTSTRM (CHARCODE CR))
(AND (EQ DSTEOLC CRLF.EOLC)
(\BOUT DSTSTRM (CHARCODE LF))))
(\BOUT DSTSTRM CH))))
(CRLF.EOLC (* DST is either CR or LF)
(for I from (IDIFFERENCE ACTUALEND ACTUALSTART) to 1 by -1
do (\BOUT DSTSTRM (COND
((OR (NEQ (SETQ CH (\BIN SRCSTRM))
(CHARCODE CR))
(EQ I 1))
CH)
((PROGN (add I -1)
(* Adjust for second character)
(EQ (SETQ CH (\BIN SRCSTRM))
(CHARCODE LF)))
(COND
((EQ DSTEOLC CR.EOLC)
(CHARCODE CR))
(T (CHARCODE LF))))
(T (\BOUT DSTSTRM (CHARCODE CR))
CH)))))
(SHOULDNT)))
T))
(COPYFILE
(LAMBDA (FROMFILE TOFILE DESTPARAMETERS) (* bvm: "18-Oct-85 15:50")
(* * DESTPARAMETERS is like PARAMETERS arg to OPENSTREAM --
overrides default parameters)
(RESETLST (RESETSAVE (SETQ FROMFILE (OPENSTREAM FROMFILE (QUOTE INPUT)
(QUOTE OLD)
(QUOTE ((SEQUENTIAL T)
(DON'TCACHE T)))))
(QUOTE (PROGN (CLOSEF OLDVALUE))))
(\COPYOPENFILE FROMFILE TOFILE DESTPARAMETERS))))
(\COPYOPENFILE
(LAMBDA (INSTREAM NEWNAME DESTPARAMETERS) (* bvm: "18-Oct-85 15:54")
(PROG ((PROPS DESTPARAMETERS)
TYPE X OUTSTREAM)
(COND
((AND (NOT (ASSOC (QUOTE CREATIONDATE)
DESTPARAMETERS))
(SETQ X (GETFILEINFO INSTREAM (QUOTE CREATIONDATE))))
(push PROPS (LIST (QUOTE CREATIONDATE)
X))))
(COND
((SETQ X (GETFILEINFO INSTREAM (QUOTE LENGTH)))
(push PROPS (LIST (QUOTE LENGTH)
X))))
(COND
((SETQ TYPE (CADR (ASSOC (QUOTE TYPE)
DESTPARAMETERS))))
((OR (AND (SETQ TYPE (GETFILEINFO INSTREAM (QUOTE TYPE)))
(NEQ TYPE (QUOTE ?)))
(SETQ TYPE (\INFER.FILE.TYPE INSTREAM)))
(push PROPS (LIST (QUOTE TYPE)
TYPE))))
(COND
((AND (EQ TYPE (QUOTE TEXT))
(SETQ X (GETFILEINFO INSTREAM (QUOTE EOL)))
(NOT (ASSOC (QUOTE EOL)
DESTPARAMETERS)))
(push PROPS (LIST (QUOTE EOL)
X))))
(RESETSAVE (SETQ OUTSTREAM (OPENSTREAM NEWNAME (QUOTE OUTPUT)
(QUOTE NEW)
(BQUOTE ((SEQUENTIAL T)
(DON'TCACHE T)
(\,@ PROPS)))))
(QUOTE (AND RESETSTATE (SETQ OLDVALUE (CLOSEF OLDVALUE))
(DELFILE OLDVALUE))))
(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
((AND (EQ TYPE (QUOTE TEXT))
(NEQ (GETFILEINFO OUTSTREAM (QUOTE EOL))
X)) (* Incompatible EOL conventions, do
slow way)
(replace ENDOFSTREAMOP of INSTREAM with (FUNCTION NILL))
(bind CH (SRCEOL ← (fetch EOLCONVENTION of INSTREAM))
until (NULL (SETQ CH (\BIN INSTREAM))) do (\OUTCHAR OUTSTREAM (\CHECKEOLC CH SRCEOL
INSTREAM))))
(T (COPYBYTES INSTREAM OUTSTREAM)))
(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 (QUOTE TEXT)))
127)
(RETURN (QUOTE 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 (QUOTE INPUT)
T)
(\GETSTREAM FILE)))))
(FORCEOUTPUT
(LAMBDA (STREAM WAITFORFINISH) (* bvm: "27-Apr-84 22:45")
(SETQ STREAM (\GETSTREAM STREAM (QUOTE OUTPUT)))
(FDEVOP (QUOTE 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 (QUOTE FORCEOUTPUT)
(fetch (STREAM DEVICE) of STREAM)
STREAM))))
(CHARSET
(LAMBDA (STREAM CHARACTERSET) (* rmk: "24-Apr-85 11:06")
(* * sets or returns the current character set for this stream)
(SETQ STREAM (\GETSTREAM STREAM))
(OR (EQ CHARACTERSET NIL)
(EQ CHARACTERSET T)
(AND (IGEQ CHARACTERSET 0)
(ILEQ CHARACTERSET \MAXCHARSET)
(NEQ CHARACTERSET NSCHARSETSHIFT))
(\ILLEGAL.ARG CHARACTERSET))
(PROG1 (if (\RUNCODED STREAM)
then (* it makes sense, so return the
current character set.)
(ffetch CHARSET of STREAM)
else (* just return T since there is no
notion of current charset for streams
which are currently not runcoded)
T)
(AND CHARACTERSET (COND
((EQ T CHARACTERSET) (* this means to make the stream not
be runcoded)
(if (\RUNCODED STREAM)
then (IMAGEOP (QUOTE IMCHARSET)
STREAM STREAM CHARACTERSET)
(freplace CHARSET of STREAM with \NORUNCODE)))
((NEQ CHARACTERSET (ffetch CHARSET of STREAM))
(IMAGEOP (QUOTE IMCHARSET)
STREAM STREAM CHARACTERSET)
(freplace CHARSET of STREAM with CHARACTERSET)))))))
(GETEOFPTR
(LAMBDA (FILE) (* rmk: "21-OCT-83 11:19")
(PROG ((STREAM (\GETSTREAM FILE)))
(RETURN (FDEVOP (QUOTE GETEOFPTR)
(fetch DEVICE of STREAM)
STREAM)))))
(GETFILEINFO
(LAMBDA (FILE ATTRIB) (* rmk: "27-Mar-85 18:05")
(PROG ((STREAM (\GETFILENAME.OR.STREAM FILE (QUOTE OLD)))
DEV VAL)
(RETURN (COND
((type? STREAM STREAM) (* FILE is open. Ask device for info;
if it can't handle it, at least handle
some generic cases)
(COND
((EQ ATTRIB (QUOTE ACCESS))
(fetch ACCESS of STREAM))
((FDEVOP (QUOTE GETFILEINFO)
(SETQ DEV (fetch DEVICE of STREAM))
STREAM ATTRIB DEV))
((OPENED STREAM) (* Could be false for a closed
nameless stream)
(SELECTQ ATTRIB
((BYTESIZE OPENBYTESIZE)
(fetch BYTESIZE of STREAM))
(EOL (SELECTC (fetch EOLCONVENTION of STREAM)
(CR.EOLC (QUOTE CR))
(LF.EOLC (QUOTE LF))
(CRLF.EOLC (QUOTE CRLF))
(SHOULDNT)))
(BUFFERS (fetch MAXBUFFERS of STREAM))
(CHARSET (CHARSET STREAM))
(ENDOFSTREAMOP (fetch ENDOFSTREAMOP of STREAM))
(LENGTH (AND (RANDACCESSP STREAM)
(\GETEOFPTR STREAM)))
(SIZE (AND (SETQ VAL (OR (FDEVOP (QUOTE GETFILEINFO)
DEV STREAM (QUOTE LENGTH)
DEV)
(AND (RANDACCESSP STREAM)
(\GETEOFPTR STREAM))))
(FOLDHI VAL BYTESPERPAGE)))
NIL))
((EQ ATTRIB (QUOTE SIZE))
(AND (SETQ VAL (FDEVOP (QUOTE GETFILEINFO)
DEV STREAM (QUOTE LENGTH)
DEV))
(FOLDHI VAL BYTESPERPAGE)))))
(STREAM (* STREAM is a full filename)
(SELECTQ ATTRIB
((ACCESS OPENBYTESIZE) (* Strip off attributes that apply
only to open files)
NIL)
(OR (FDEVOP (QUOTE GETFILEINFO)
(SETQ DEV (\GETDEVICEFROMNAME STREAM))
STREAM ATTRIB DEV)
(SELECTQ ATTRIB
(SIZE (AND (SETQ VAL (FDEVOP (QUOTE GETFILEINFO)
DEV STREAM (QUOTE LENGTH)
DEV))
(FOLDHI VAL BYTESPERPAGE)))
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 (QUOTE GETFILEPTR)
(fetch DEVICE of STREAM)
STREAM)))))
(SETFILEINFO
(LAMBDA (FILE ATTRIB VALUE) (* rmk: "27-Mar-85 18:04")
(PROG ((STREAM (\GETFILENAME.OR.STREAM FILE (QUOTE OLD)))
DEV)
(RETURN (COND
((type? STREAM STREAM) (* FILE is open, so strip off
attributes that can be set from the
stream..)
(SELECTQ ATTRIB
((ACCESS BYTESIZE OPENBYTESIZE) (* These cant be changed for an open
file)
NIL)
(EOL (replace EOLCONVENTION of STREAM with (SELECTQ VALUE
(CR CR.EOLC)
(CRLF CRLF.EOLC)
(LF LF.EOLC)
(\ILLEGAL.ARG VALUE)))
VALUE)
(ENDOFSTREAMOP (replace ENDOFSTREAMOP of STREAM with VALUE))
(BUFFERS (replace MAXBUFFERS of STREAM with (IMAX 1 (FIX VALUE))))
(CHARSET (CHARSET STREAM VALUE))
(OR (FDEVOP (QUOTE SETFILEINFO)
(SETQ DEV (fetch DEVICE of STREAM))
STREAM 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 STREAM (COND
((type? BYTEPTR VALUE)
VALUE)
(T (\ILLEGAL.ARG VALUE)))))
(SIZE (\SETEOFPTR STREAM (UNFOLD VALUE BYTESPERPAGE)))
NIL))))
(STREAM (* STREAM is a full filename)
(SELECTQ ATTRIB
((ACCESS OPENBYTESIZE EOLCONVENTION)
NIL)
(OR (FDEVOP (QUOTE SETFILEINFO)
(SETQ DEV (\GETDEVICEFROMNAME STREAM))
STREAM ATTRIB VALUE DEV)
(COND
((EQ ATTRIB (QUOTE LENGTH))
(\SETCLOSEDFILELENGTH STREAM (COND
((type? BYTEPTR VALUE)
VALUE)
(T (\ILLEGAL.ARG VALUE)))))))
))
(T (LISPERROR "FILE NOT FOUND" FILE)))))))
(SETFILEPTR
(LAMBDA (FILE ADR) (* lmm "29-Apr-86 16:39")
(LET ((STREAM (\GETSTREAM FILE)))
(FDEVOP (QUOTE SETFILEPTR)
(ffetch DEVICE of STREAM)
STREAM
(COND
((EQ ADR -1)
(\GETEOFPTR STREAM))
((type? BYTEPTR ADR)
ADR)
(T (LISPERROR "ILLEGAL ARG" ADR))))
(if (\RUNCODED STREAM)
then (* always shift the character set to
0.0 This might be wrong sometimes, but
it is more often right than wrong.)
(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))))
)
(* ; "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) (* hdj "16-May-86 13:34")
(if (NOT (FDEVOP (QUOTE OPENP)
OLDDEVICE OLDFILE (QUOTE OLD)
OLDDEVICE))
then (RESETLST (RESETSAVE (SETQ OLDFILE (OPENSTREAM OLDFILE (QUOTE INPUT)
(QUOTE OLD)
(QUOTE ((SEQUENTIAL T)
DON'TCACHE))))
(QUOTE (AND RESETSTATE (CLOSEF? OLDVALUE))))
(COND
((SETQ NEWFILE (\COPYOPENFILE OLDFILE NEWFILE))
(\DELETEFILE (CLOSEF OLDFILE))
NEWFILE))))))
(\GENERIC.OPENP
(LAMBDA (FILENAME ACCESS DEVICE) (* hdj "17-Jun-86 11:40")
(* * "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))
FULL)
(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 (STREAM FLG) (* rmk: "27-Mar-85 18:07")
(* The 10 does not do the EOL check on
the peeked character.)
(* If FLG is NIL, a single EOL doesn't
count.)
(PROG ((SHIFTEDCHARSET (UNFOLD (ffetch CHARSET of STREAM)
256)))
(RETURN (AND (NOT (\EOFP STREAM))
(OR (NOT (NULL FLG))
(NEQ EOL.TC (\SYNCODE \PRIMTERMSA (OR (\NSPEEK STREAM SHIFTEDCHARSET
SHIFTEDCHARSET T)
(RETURN))))
(UNINTERRUPTABLY
(\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET)
(* To find out if the EOL is the last
character, we BIN the stream, check
for EOF, then back it up again.)
(PROG1 (NOT (\EOFP STREAM))
(\BACKNSCHAR STREAM SHIFTEDCHARSET)))))))))
)
(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 (QUOTE OPENP)
DEVICE NIL ACCESS DEVICE) collect (APPLY* FN STREAM)))))
)
(RPAQQ 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: DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(PUTPROPS \OUTCHAR DMACRO (OPENLAMBDA (STREAM CHARCODE)
(STREAMOP (QUOTE OUTCHARFN)
STREAM STREAM CHARCODE)))
(PUTPROPS \DEVICE-OPEN-STREAMS MACRO (ARGS (LET ((DEVICE (CAR ARGS)))
(BQUOTE (FDEVOP (QUOTE 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"
)
(TYPECASE PATHNAME? (PATHNAME (INTERLISP-NAMESTRING
PATHNAME?))
(T PATHNAME?))))
)
(* END EXPORTED DEFINITIONS)
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(MAPC (QUOTE ((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)
(APPLY* (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 (QUOTE 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 (QUOTE 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 (QUOTE BOTH)
(QUOTE OLD))))
(\SETEOFPTR STREAM NBYTES)
(\CLOSEFILE STREAM)
(RETURN T))))
(\SETEOFPTR
(LAMBDA (STREAM LEN) (* bvm: " 9-Jul-84 17:37")
(FDEVOP (QUOTE 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 (QUOTE 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))))
)
(DECLARE: DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(PUTPROPS \DECFILEPTR MACRO ((STREAM X)
(\INCFILEPTR STREAM (IMINUS X))))
(PUTPROPS \GETFILEPTR MACRO (OPENLAMBDA (STRM)
(FDEVOP (QUOTE 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 (QUOTE BLOCKIN)
(fetch (STREAM DEVICE)
of STRM)
STRM BASE OFF NBYTES)))
(PUTPROPS \BOUTS BYTEMACRO (OPENLAMBDA (STRM BASE OFF NBYTES)
(FDEVOP (QUOTE BLOCKOUT)
(fetch (STREAM DEVICE)
of STRM)
STRM BASE OFF NBYTES)))
(PUTPROPS \EOFP BYTEMACRO (OPENLAMBDA (STRM)
(FDEVOP (QUOTE EOFP)
(fetch (STREAM DEVICE)
of STRM)
STRM)))
)
(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 24)))
(CONSTANTS (\MAXFILEPTR (SUB1 (LLSH 1 24))))
)
[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 (QUOTE GETNEXTBUFFER)
(fetch DEVICE of STREAM)
STREAM
(QUOTE 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 (QUOTE GETNEXTBUFFER)
(fetch DEVICE of STREAM)
STREAM
(QUOTE 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 (QUOTE GETNEXTBUFFER)
(fetch DEVICE of STREAM)
STREAM
(QUOTE 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 (QUOTE GETNEXTBUFFER)
(fetch DEVICE of STREAM)
STREAM
(QUOTE 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 (QUOTE GETNEXTBUFFER)
DEV STREAM (QUOTE 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 (QUOTE GETNEXTBUFFER)
DEV SRC (QUOTE READ)
NOERRORFLG))))
)
(* ; "NULL device")
(DEFINEQ
(\NULLDEVICE
(LAMBDA NIL (* bvm: "30-Jan-85 22:06")
(* Defines the NULL device, an
infinite source or sink)
(\DEFINEDEVICE (QUOTE NULL)
(create FDEV
DEVICENAME ← (QUOTE NULL)
RANDOMACCESSP ← T
NODIRECTORIES ← T
CLOSEFILE ← (FUNCTION NILL)
DELETEFILE ← (FUNCTION NILL)
OPENFILE ← (FUNCTION \NULL.OPENFILE)
REOPENFILE ← (FUNCTION \NULL.OPENFILE)
BIN ← (FUNCTION \EOF.ACTION)
BOUT ← (FUNCTION NILL)
PEEKBIN ← (FUNCTION (LAMBDA (STREAM NOERRORFLG)
(AND (NULL NOERRORFLG)
(BIN STREAM))))
READP ← (FUNCTION NILL)
BACKFILEPTR ← (FUNCTION NILL)
EOFP ← (FUNCTION TRUE)
RENAMEFILE ← (FUNCTION NILL)
GETFILENAME ← (FUNCTION NILL)
EVENTFN ← (FUNCTION NILL)
BLOCKIN ← (FUNCTION \EOF.ACTION)
BLOCKOUT ← (FUNCTION NILL)
GENERATEFILES ← (FUNCTION \NULLFILEGENERATOR)
GETFILEPTR ← (FUNCTION ZERO)
GETEOFPTR ← (FUNCTION ZERO)
SETFILEPTR ← (FUNCTION NILL)
GETFILEINFO ← (FUNCTION NILL)
SETFILEINFO ← (FUNCTION NILL)
SETEOFPTR ← (FUNCTION NILL)))))
(\NULL.OPENFILE
(LAMBDA (NAME ACCESS RECOG PARAMETERS DEVICE OLDSTREAM) (* bvm: "30-Jan-85 22:05")
(OR OLDSTREAM (create STREAM
USERCLOSEABLE ← T
ACCESS ← ACCESS
FULLFILENAME ← NIL
DEVICE ← DEVICE))))
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(\NULLDEVICE)
)
(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)
)
(PUTPROPS FILEIO COPYRIGHT ("Xerox Corporation" 1981 1982 1983 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (23316 25929 (STREAMPROP 23326 . 23948) (GETSTREAMPROP 23950 . 24200) (PUTSTREAMPROP
24202 . 25773) (STREAMP 25775 . 25927)) (25972 27428 (\STREAM.DEFPRINT 25982 . 27426)) (27654 32141 (
\GETACCESS 27664 . 28396) (\SETACCESS 28398 . 32139)) (49197 55672 (\DEFINEDEVICE 49207 . 51740) (
\GETDEVICEFROMNAME 51742 . 52347) (\GETDEVICEFROMHOSTNAME 52349 . 53440) (\REMOVEDEVICE 53442 . 54457)
(\REMOVEDEVICE.NAMES 54459 . 55670)) (55673 80557 (\CLOSEFILE 55683 . 56566) (\DELETEFILE 56568 .
56891) (\DEVICEEVENT 56893 . 58503) (\GENERATEFILES 58505 . 59401) (\GENERATENEXTFILE 59403 . 60146) (
\GENERATEFILEINFO 60148 . 60648) (\GETFILENAME 60650 . 61184) (\GETFILENAME.OR.STREAM 61186 . 61873) (
\GENERIC.OUTFILEP 61875 . 62584) (\OPENFILE 62586 . 64948) (\DO.PARAMS.AT.OPEN 64950 . 66213) (
\RENAMEFILE 66215 . 66685) (\REVALIDATEFILE 66687 . 69235) (\PAGED.REVALIDATEFILELST 69237 . 70884) (
\PAGED.REVALIDATEFILES 70886 . 72437) (\PAGED.REVALIDATEFILE 72439 . 74811) (\BUFFERED.REVALIDATEFILE
74813 . 77188) (\BUFFERED.REVALIDATEFILELST 77190 . 78438) (\PRINT-REVALIDATION-RESULT 78440 . 78861)
(\TRUNCATEFILE 78863 . 79315) (\FILE-CONFLICT 79317 . 80555)) (80593 86214 (\GENERATENOFILES 80603 .
83298) (\NULLFILEGENERATOR 83300 . 83665) (\NOFILESNEXTFILEFN 83667 . 85862) (\NOFILESINFOFN 85864 .
86212)) (86332 88701 (\FILE.NOT.OPEN 86342 . 87108) (\FILE.WONT.OPEN 87110 . 87445) (\ILLEGAL.DEVICEOP
87447 . 87735) (\IS.NOT.RANDACCESSP 87737 . 88192) (\STREAM.NOT.OPEN 88194 . 88699)) (88836 91161 (
\FDEVINSTANCE 88846 . 91159)) (92582 98558 (CNDIR 92592 . 93852) (DIRECTORYNAME 93854 . 96066) (
DIRECTORYNAMEP 96068 . 96957) (HOSTNAMEP 96959 . 98030) (\ADD.CONNECTED.DIR 98032 . 98556)) (98605
127605 (\BACKFILEPTR 98615 . 98825) (\BACKPEEKBIN 98827 . 99501) (\BACKBIN 99503 . 99899) (BIN 99901
. 100119) (\BIN 100121 . 100423) (\BINS 100425 . 100858) (BOUT 100860 . 101086) (\BOUT 101088 .
101309) (\BOUTS 101311 . 101768) (COPYBYTES 101770 . 104506) (COPYCHARS 104508 . 109646) (COPYFILE
109648 . 110286) (\COPYOPENFILE 110288 . 113298) (\INFER.FILE.TYPE 113300 . 114444) (EOFP 114446 .
114957) (FORCEOUTPUT 114959 . 115235) (\FLUSH.OPEN.STREAMS 115237 . 115635) (CHARSET 115637 . 117550)
(GETEOFPTR 117552 . 117840) (GETFILEINFO 117842 . 121610) (\TYPE.FROM.FILETYPE 121612 . 122106) (
\FILETYPE.FROM.TYPE 122108 . 122292) (GETFILEPTR 122294 . 122584) (SETFILEINFO 122586 . 126225) (
SETFILEPTR 126227 . 127217) (BOUT16 127219 . 127407) (BIN16 127409 . 127603)) (127640 131827 (
\GENERIC.BINS 127650 . 128051) (\GENERIC.BOUTS 128053 . 128439) (\GENERIC.RENAMEFILE 128441 . 129263)
(\GENERIC.OPENP 129265 . 130309) (\GENERIC.READP 130311 . 131825)) (131828 132196 (\MAP-OPEN-STREAMS
131838 . 132194)) (134054 136535 (\EOF.ACTION 134064 . 134431) (\EOSERROR 134433 . 134631) (\GETEOFPTR
134633 . 134838) (\INCFILEPTR 134840 . 135192) (\PEEKBIN 135194 . 135407) (\SETCLOSEDFILELENGTH
135409 . 135906) (\SETEOFPTR 135908 . 136118) (\SETFILEPTR 136120 . 136533)) (136536 137138 (\FIXPOUT
136546 . 136851) (\FIXPIN 136853 . 137136)) (140054 149623 (\BUFFERED.BIN 140064 . 140983) (
\BUFFERED.PEEKBIN 140985 . 141864) (\BUFFERED.BOUT 141866 . 142774) (\BUFFERED.BINS 142776 . 146171) (
\BUFFERED.BOUTS 146173 . 147878) (\BUFFERED.COPYBYTES 147880 . 149621)) (149652 151673 (\NULLDEVICE
149662 . 151344) (\NULL.OPENFILE 151346 . 151671)))))
STOP