(FILECREATED "21-Jul-85 14:29:56" {ERIS}<LISPNEW>CPMPATCH.;3 69382
changes to: (VARS CPMPATCHCOMS)
(FNS \CFLOPPY.INIT \CFLOPPY.DIRECTORYNAMEP \CFLOPPY.DIR.PUT)
previous date: "21-Jul-85 14:13:33" {ERIS}<LISPNEW>CPMPATCH.;2)
(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CPMPATCHCOMS)
(RPAQQ CPMPATCHCOMS ((* "CPM" *)
(CONSTANTS (CPMDELETEMARK 229)
(CPMFILEMARK 0))
(INITVARS (\CFLOPPYINFO NIL)
(\CFLOPPYCALLOCS NIL)
(\CFLOPPYDIR NIL)
(\CFLOPPYFDEV NIL)
(\CFLOPPYDIRECTORY NIL)
(\CFLOPPYBLANKSECTOR NIL)
(\CFLOPPYSECTORMAP NIL)
(\CFLOPPYDISKMAP NIL)
(CPM.DIRECTORY.WINDOW NIL))
(INITRECORDS CFLOPPYFDEV CINFO CALLOC FCB @FCB)
(DECLARE: EVAL@COMPILE DONTCOPY (RECORDS CFLOPPYFDEV CINFO CALLOC FCB @FCB))
(FNS \CFLOPPY.GET.FCB.FILENAME \CFLOPPY.SET.FCB.FILENAME \CFLOPPY.INIT \CFLOPPY.OPEN
\CFLOPPY.OPEN.DIRECTORY \CFLOPPY.OPENFILE \CFLOPPY.OPENFILE1 \CFLOPPY.OPENOLDFILE
\CFLOPPY.OPENNEWFILE \CFLOPPY.ASSURESTREAM \CFLOPPY.GETFILEINFO \CFLOPPY.GETFILEINFO1
\CFLOPPY.SETFILEINFO \CFLOPPY.CLOSEFILE \CFLOPPY.CLOSEFILE1 \CFLOPPY.DELETEFILE
\CFLOPPY.GETFILENAME \CFLOPPY.DIRECTORYNAMEP \CFLOPPY.GENERATEFILES \CFLOPPY.NEXTFILEFN
\CFLOPPY.FILEINFOFN \CFLOPPY.RENAMEFILE \CFLOPPY.STREAMS.AGAINST \CFLOPPY.STREAMS.USING
\CFLOPPY.READPAGES \CFLOPPY.READPAGE \CFLOPPY.PHYSICAL.RECORDNO \CFLOPPY.READRECORDNO
\CFLOPPY.WRITERECORDNO \CFLOPPY.RECORDNOTODISKADDRESS \CFLOPPY.DIR.GET \CFLOPPY.DIR.PUT
\CFLOPPY.DIR.REMOVE \CFLOPPY.WRITEPAGES \CFLOPPY.WRITEPAGE \CFLOPPY.TRUNCATEFILE
\CFLOPPY.ALLOCATE.FCB \CFLOPPY.ALLOCATE.GROUP \CFLOPPY.ALLOCATE \CFLOPPY.TRUNCATE
\CFLOPPY.DEALLOCATE \CFLOPPY.EXTEND \CFLOPPY.SAVE.CHANGES \CFLOPPY.ICHECK
\CFLOPPY.ICHECK.CALLOC \CFLOPPY.FREE.PAGES \CFLOPPY.FORMAT CPM.DIRECTORY)))
(* "CPM" *)
(DECLARE: EVAL@COMPILE
(RPAQQ CPMDELETEMARK 229)
(RPAQQ CPMFILEMARK 0)
(CONSTANTS (CPMDELETEMARK 229)
(CPMFILEMARK 0))
)
(RPAQ? \CFLOPPYINFO NIL)
(RPAQ? \CFLOPPYCALLOCS NIL)
(RPAQ? \CFLOPPYDIR NIL)
(RPAQ? \CFLOPPYFDEV NIL)
(RPAQ? \CFLOPPYDIRECTORY NIL)
(RPAQ? \CFLOPPYBLANKSECTOR NIL)
(RPAQ? \CFLOPPYSECTORMAP NIL)
(RPAQ? \CFLOPPYDISKMAP NIL)
(RPAQ? CPM.DIRECTORY.WINDOW NIL)
(/DECLAREDATATYPE (QUOTE CINFO)
(QUOTE (POINTER POINTER POINTER POINTER POINTER))
(QUOTE ((CINFO 0 POINTER)
(CINFO 2 POINTER)
(CINFO 4 POINTER)
(CINFO 6 POINTER)
(CINFO 8 POINTER)))
(QUOTE 10))
(/DECLAREDATATYPE (QUOTE CALLOC)
(QUOTE (POINTER POINTER POINTER POINTER FLAG FLAG))
(QUOTE ((CALLOC 0 POINTER)
(CALLOC 2 POINTER)
(CALLOC 4 POINTER)
(CALLOC 6 POINTER)
(CALLOC 6 (FLAGBITS . 0))
(CALLOC 6 (FLAGBITS . 16))))
(QUOTE 8))
(/DECLAREDATATYPE (QUOTE FCB)
(QUOTE (BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE
BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE
BYTE BYTE BYTE FIXP))
(QUOTE ((FCB 0 (BITS . 7))
(FCB 0 (BITS . 135))
(FCB 1 (BITS . 7))
(FCB 1 (BITS . 135))
(FCB 2 (BITS . 7))
(FCB 2 (BITS . 135))
(FCB 3 (BITS . 7))
(FCB 3 (BITS . 135))
(FCB 4 (BITS . 7))
(FCB 4 (BITS . 135))
(FCB 5 (BITS . 7))
(FCB 5 (BITS . 135))
(FCB 6 (BITS . 7))
(FCB 6 (BITS . 135))
(FCB 7 (BITS . 7))
(FCB 7 (BITS . 135))
(FCB 8 (BITS . 7))
(FCB 8 (BITS . 135))
(FCB 9 (BITS . 7))
(FCB 9 (BITS . 135))
(FCB 10 (BITS . 7))
(FCB 10 (BITS . 135))
(FCB 11 (BITS . 7))
(FCB 11 (BITS . 135))
(FCB 12 (BITS . 7))
(FCB 12 (BITS . 135))
(FCB 13 (BITS . 7))
(FCB 13 (BITS . 135))
(FCB 14 (BITS . 7))
(FCB 14 (BITS . 135))
(FCB 15 (BITS . 7))
(FCB 15 (BITS . 135))
(FCB 16 FIXP)))
(QUOTE 18))
(DECLARE: EVAL@COMPILE DONTCOPY
[DECLARE: EVAL@COMPILE
(ACCESSFNS CFLOPPYFDEV ((OPEN (fetch (CINFO OPEN) of (fetch (FDEV DEVICEINFO) of DATUM))
(replace (CINFO OPEN) of (fetch (FDEV DEVICEINFO) of DATUM)
with NEWVALUE))
(CALLOCS (fetch (CINFO CALLOCS) of (fetch (FDEV DEVICEINFO) of DATUM))
(PROGN (replace (CINFO CALLOCS) of (fetch (FDEV DEVICEINFO)
of DATUM)
with NEWVALUE)
(SETQ \CFLOPPYCALLOCS NEWVALUE)))
(DIR (fetch (CINFO DIR) of (fetch (FDEV DEVICEINFO) of DATUM))
(PROGN (replace (CINFO DIR) of (fetch (FDEV DEVICEINFO) of DATUM)
with NEWVALUE)
(SETQ \CFLOPPYDIR NEWVALUE)))
(FREEFCBS (fetch (CINFO FREEFCBS) of (fetch (FDEV DEVICEINFO) of DATUM))
(PROGN (replace (CINFO FREEFCBS) of (fetch (FDEV DEVICEINFO)
of DATUM)
with NEWVALUE)
(SETQ \CFLOPPYFREEFCBS NEWVALUE)))
(FREEGROUPS (fetch (CINFO FREEGROUPS) of (fetch (FDEV DEVICEINFO)
of DATUM))
(PROGN (replace (CINFO FREEGROUPS) of (fetch (FDEV DEVICEINFO)
of DATUM)
with NEWVALUE)
(SETQ \CFLOPPYFREEGROUPS NEWVALUE)))))
(DATATYPE CINFO (OPEN CALLOCS DIR FREEFCBS FREEGROUPS))
(DATATYPE CALLOC (FCBS FILENAME CHANGEDFCBS CHANGEDGROUPS (WRITEFLG FLAG)
(DELETEFLG FLAG))
(ACCESSFNS ((RECORDCOUNT (COND
((fetch (CALLOC FCBS) of DATUM)
(* This isn't a file in the midst of deletion *)
(IPLUS (ITIMES 128 (SUB1 (LENGTH (fetch (CALLOC FCBS)
of DATUM))))
(fetch (FCB RECORDCOUNT)
of (CAR (LAST (fetch (CALLOC FCBS)
of DATUM))))))
(T 0)))
(GROUPCOUNT (IQUOTIENT (IPLUS (fetch (CALLOC RECORDCOUNT) of DATUM)
7)
8))
(GROUPS (PROG (ANSWER)
(for FCB in (fetch (CALLOC FCBS) of DATUM)
do (SETQ ANSWER (NCONC ANSWER (fetch (FCB GROUPS)
of FCB))))
(RETURN ANSWER)))
(LENGTH (ITIMES 128 (fetch (CALLOC RECORDCOUNT) of DATUM)))
(PAGELENGTH (IQUOTIENT (IPLUS (fetch (CALLOC RECORDCOUNT) of DATUM)
3)
4)))))
(DATATYPE FCB ((ET BYTE)
(\NAME 8 BYTE)
(\EXTENSION 3 BYTE)
(EXTENT BYTE)
(\UNUSEDHI BYTE)
(\UNUSEDLO BYTE)
(RECORDCOUNT BYTE)
(\DISKMAP0 BYTE)
(\DISKMAP1 BYTE)
(\DISKMAP2 BYTE)
(\DISKMAP3 BYTE)
(\DISKMAP4 BYTE)
(\DISKMAP5 BYTE)
(\DISKMAP6 BYTE)
(\DISKMAP7 BYTE)
(\DISKMAP8 BYTE)
(\DISKMAP9 BYTE)
(\DISKMAP10 BYTE)
(\DISKMAP11 BYTE)
(\DISKMAP12 BYTE)
(\DISKMAP13 BYTE)
(\DISKMAP14 BYTE)
(\DISKMAP15 BYTE)
(NUMBER FIXP))
(ACCESSFNS ((FILENAME (\CFLOPPY.GET.FCB.FILENAME DATUM)
(\CFLOPPY.SET.FCB.FILENAME DATUM NEWVALUE))
(NAME (CREATE STRINGP
BASE ← DATUM
LENGTH ← 8
OFFST ← 1)
(PROGN (RPLSTRING (fetch (FCB NAME) of DATUM)
1 " ")
(RPLSTRING (fetch (FCB NAME) of DATUM)
1
(OR (SUBSTRING NEWVALUE 1 (IMIN (NCHARS NEWVALUE)
8))
""))))
(EXTENSION (CREATE STRINGP
BASE ← DATUM
LENGTH ← 3
OFFST ← 9)
(PROGN (RPLSTRING (fetch (FCB EXTENSION) of DATUM)
1 " ")
(RPLSTRING (fetch (FCB EXTENSION) of DATUM)
1
(OR (SUBSTRING NEWVALUE 1 (IMIN (NCHARS
NEWVALUE)
3))
""))))
(UNUSED (IPLUS (ITIMES 256 (fetch (FCB \UNUSEDHI) of DATUM))
(fetch (FCB \UNUSEDLO) of DATUM)))
(GROUPCOUNT (PROG (ANSWER)
(COND
((IEQP (fetch (FCB ET) of DATUM)
CPMDELETEMARK)
(RETURN 0)))
(SETQ ANSWER (IQUOTIENT (IPLUS (fetch (FCB RECORDCOUNT)
of DATUM)
7)
8))
(COND
((IGREATERP ANSWER 16)
(SHOULDNT)))
(RETURN ANSWER)))
(GROUPS (for I from 0 to (SUB1 (fetch (FCB GROUPCOUNT) of DATUM))
collect (\GETBASEBYTE (fetch (FCB DISKMAP) of DATUM)
I)))
(DISKMAP (\ADDBASE (\DTEST DATUM (QUOTE FCB))
8))
(\VALUE DATUM (\BLT DATUM NEWVALUE 16)))))
(BLOCKRECORD @FCB ((ET BYTE)
(\NAME 8 BYTE)
(\EXTENSION 3 BYTE)
(EXTENT BYTE)
(\UNUSEDHI BYTE)
(\UNUSEDLO BYTE)
(RECORDCOUNT BYTE)
(\DISKMAP0 BYTE)
(\DISKMAP1 BYTE)
(\DISKMAP2 BYTE)
(\DISKMAP3 BYTE)
(\DISKMAP4 BYTE)
(\DISKMAP5 BYTE)
(\DISKMAP6 BYTE)
(\DISKMAP7 BYTE)
(\DISKMAP8 BYTE)
(\DISKMAP9 BYTE)
(\DISKMAP10 BYTE)
(\DISKMAP11 BYTE)
(\DISKMAP12 BYTE)
(\DISKMAP13 BYTE)
(\DISKMAP14 BYTE)
(\DISKMAP15 BYTE)
(NUMBER FIXP))
(ACCESSFNS ((FILENAME (\CFLOPPY.GET.FCB.FILENAME DATUM)
(\CFLOPPY.SET.FCB.FILENAME DATUM NEWVALUE))
(NAME (CREATE STRINGP
BASE ← DATUM
LENGTH ← 8
OFFST ← 1)
(PROGN (RPLSTRING (fetch (FCB NAME) of DATUM)
1 " ")
(RPLSTRING (fetch (FCB NAME) of DATUM)
1
(OR (SUBSTRING NEWVALUE 1 (IMIN (NCHARS
NEWVALUE)
8))
""))))
(EXTENSION (CREATE STRINGP
BASE ← DATUM
LENGTH ← 3
OFFST ← 9)
(PROGN (RPLSTRING (fetch (FCB EXTENSION) of DATUM)
1 " ")
(RPLSTRING (fetch (FCB EXTENSION) of DATUM)
1
(OR (SUBSTRING NEWVALUE 1
(IMIN (NCHARS NEWVALUE)
3))
""))))
(UNUSED (IPLUS (ITIMES 256 (fetch (FCB \UNUSEDHI) of DATUM))
(fetch (FCB \UNUSEDLO) of DATUM)))
(DISKMAP (\ADDBASE DATUM 8))
(\VALUE DATUM (\BLT DATUM NEWVALUE 16)))))
]
(/DECLAREDATATYPE (QUOTE CINFO)
(QUOTE (POINTER POINTER POINTER POINTER POINTER))
(QUOTE ((CINFO 0 POINTER)
(CINFO 2 POINTER)
(CINFO 4 POINTER)
(CINFO 6 POINTER)
(CINFO 8 POINTER)))
(QUOTE 10))
(/DECLAREDATATYPE (QUOTE CALLOC)
(QUOTE (POINTER POINTER POINTER POINTER FLAG FLAG))
(QUOTE ((CALLOC 0 POINTER)
(CALLOC 2 POINTER)
(CALLOC 4 POINTER)
(CALLOC 6 POINTER)
(CALLOC 6 (FLAGBITS . 0))
(CALLOC 6 (FLAGBITS . 16))))
(QUOTE 8))
(/DECLAREDATATYPE (QUOTE FCB)
(QUOTE (BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE
BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE
BYTE BYTE BYTE FIXP))
(QUOTE ((FCB 0 (BITS . 7))
(FCB 0 (BITS . 135))
(FCB 1 (BITS . 7))
(FCB 1 (BITS . 135))
(FCB 2 (BITS . 7))
(FCB 2 (BITS . 135))
(FCB 3 (BITS . 7))
(FCB 3 (BITS . 135))
(FCB 4 (BITS . 7))
(FCB 4 (BITS . 135))
(FCB 5 (BITS . 7))
(FCB 5 (BITS . 135))
(FCB 6 (BITS . 7))
(FCB 6 (BITS . 135))
(FCB 7 (BITS . 7))
(FCB 7 (BITS . 135))
(FCB 8 (BITS . 7))
(FCB 8 (BITS . 135))
(FCB 9 (BITS . 7))
(FCB 9 (BITS . 135))
(FCB 10 (BITS . 7))
(FCB 10 (BITS . 135))
(FCB 11 (BITS . 7))
(FCB 11 (BITS . 135))
(FCB 12 (BITS . 7))
(FCB 12 (BITS . 135))
(FCB 13 (BITS . 7))
(FCB 13 (BITS . 135))
(FCB 14 (BITS . 7))
(FCB 14 (BITS . 135))
(FCB 15 (BITS . 7))
(FCB 15 (BITS . 135))
(FCB 16 FIXP)))
(QUOTE 18))
)
(DEFINEQ
(\CFLOPPY.GET.FCB.FILENAME
(LAMBDA (FCB) (* edited: "23-Jul-84 15:31")
(PROG (NAME EXTENSION POS FILENAME)
(SETQ NAME (fetch (FCB NAME) of FCB))
(SETQ EXTENSION (fetch (FCB EXTENSION) of FCB))
(SETQ POS (SUB1 (OR (STRPOS " " NAME)
9)))
(SETQ NAME (OR (SUBSTRING NAME 1 POS)
""))
(SETQ POS (SUB1 (OR (STRPOS " " EXTENSION)
4)))
(SETQ EXTENSION (OR (SUBSTRING EXTENSION 1 POS)
""))
(SETQ FILENAME (PACK* NAME "." EXTENSION))
(RETURN FILENAME))))
(\CFLOPPY.SET.FCB.FILENAME
(LAMBDA (FCB FILENAME) (* edited: "23-Jul-84 15:31")
(PROG (UNAME)
(SETQ UNAME (UNPACKFILENAME FILENAME))
(replace (FCB NAME) of FCB with (OR (LISTGET UNAME (QUOTE NAME))
""))
(replace (FCB EXTENSION) of FCB with (OR (LISTGET UNAME (QUOTE EXTENSION))
"")))))
(\CFLOPPY.INIT
(LAMBDA NIL (* kbr: "21-Jul-85 14:29")
(PROG NIL
(SETQ \CFLOPPYDIRECTORY (\FLOPPY.BUFFER 4))
(SETQ \CFLOPPYSECTORMAP (ARRAY 26 (QUOTE BYTE)
0 0))
(SETQ \CFLOPPYDISKMAP (ARRAY 250 (QUOTE POINTER)
NIL 0))
(for I from 0 as J
in (QUOTE (1 7 13 19 25 5 11 17 23 3 9 15 21 2 8 14 20 26 6 12 18 24 4 10 16 22))
do (SETA \CFLOPPYSECTORMAP I J))
(SETQ \CFLOPPYBLANKSECTOR (\FLOPPY.BUFFER 1))
(for I from 0 to (SUB1 BYTESPERPAGE)
do (* change all bytes on page to be the cpm delete mark,
229)
(\PUTBASEBYTE \CFLOPPYBLANKSECTOR I 229))
(SETQ \CFLOPPYINFO (create CINFO))
(SETQ \CFLOPPYFDEV (create FDEV
DEVICENAME ← (QUOTE FLOPPY)
NODIRECTORIES ← T
CLOSEFILE ← (QUOTE \CFLOPPY.CLOSEFILE)
DELETEFILE ← (QUOTE \CFLOPPY.DELETEFILE)
DIRECTORYNAMEP ← (QUOTE \CFLOPPY.DIRECTORYNAMEP)
EVENTFN ← (QUOTE \FLOPPY.EVENTFN)
GENERATEFILES ← (QUOTE \CFLOPPY.GENERATEFILES)
GETFILEINFO ← (QUOTE \CFLOPPY.GETFILEINFO)
GETFILENAME ← (QUOTE \CFLOPPY.GETFILENAME)
HOSTNAMEP ← (QUOTE \FLOPPY.HOSTNAMEP)
OPENFILE ← (QUOTE \CFLOPPY.OPENFILE)
READPAGES ← (QUOTE \CFLOPPY.READPAGES)
REOPENFILE ← (QUOTE \CFLOPPY.OPENFILE)
SETFILEINFO ← (QUOTE NILL)
TRUNCATEFILE ← (QUOTE \CFLOPPY.TRUNCATEFILE)
WRITEPAGES ← (QUOTE \CFLOPPY.WRITEPAGES)
DEVICEINFO ← \CFLOPPYINFO
RENAMEFILE ← (QUOTE \CFLOPPY.RENAMEFILE)))
(\MAKE.PMAP.DEVICE \CFLOPPYFDEV))))
(\CFLOPPY.OPEN
(LAMBDA NIL (* edited: "23-Jul-84 15:31")
(* Assume floppy mounted. Cache directory info for floppy
if not already cached. Return T or NIL.
*)
(PROG NIL
(COND
((fetch (CFLOPPYFDEV OPEN) of \FLOPPYFDEV) (* Already open *)
(RETURN T)))
(replace (CFLOPPYFDEV CALLOCS) of \FLOPPYFDEV with NIL)
(replace (CFLOPPYFDEV DIR) of \FLOPPYFDEV with NIL)
(\CFLOPPY.OPEN.DIRECTORY)
(replace (CFLOPPYFDEV OPEN) of \FLOPPYFDEV with T)
(RETURN T))))
(\CFLOPPY.OPEN.DIRECTORY
(LAMBDA NIL (* edited: "23-Jul-84 15:31")
(PROG (FCB FREEFCBS FREEGROUPS FILENAME ALIST CALLOC CALLOCS)
(* Use \CFLOPPYDISKMAP to temporarily keep track of occupied groups while reading in FCBs. FREEFCBS will then be
calculated from \CFLOPPYDISKMAP. Groups 0 & 1 contain directory. *)
(SETA \CFLOPPYDISKMAP 0 T)
(SETA \CFLOPPYDISKMAP 1 T)
(for I from 2 to 249 do (SETA \CFLOPPYDISKMAP I NIL))
(* Read in FCBs. Calc FREEFCBS.
ALIST keeps track of which extents go with which
filenames. *)
(for I from 0 to 15 do (\CFLOPPY.READRECORDNO I (\ADDBASE \CFLOPPYDIRECTORY
(ITIMES I 64))))
(for I from 0 to 63
do (SETQ FCB (create FCB
\VALUE ← (\ADDBASE \CFLOPPYDIRECTORY (ITIMES I 16))
NUMBER ← I))
(COND
((IEQP (fetch (FCB ET) of FCB)
CPMDELETEMARK)
(push FREEFCBS FCB))
(T (SETQ FILENAME (fetch (FCB FILENAME) of FCB))
(RPLACD (OR (ASSOC FILENAME ALIST)
(PROGN (push ALIST (LIST FILENAME))
(CAR ALIST)))
(CONS FCB (CDR (ASSOC FILENAME ALIST))))
(for J from 0 to 15 do (SETA \CFLOPPYDISKMAP (\GETBASEBYTE (fetch (FCB DISKMAP)
of FCB)
J)
T)))))
(SETQ FREEFCBS (DREVERSE FREEFCBS)) (* Calc FREEGROUPS. *)
(SETQ FREEGROUPS (for I from 2 to 249 when (NOT (ELT \CFLOPPYDISKMAP I)) collect I))
(* Calc CALLOCS. *)
(for BUCKET in ALIST
do (SETQ FILENAME (CAR BUCKET))
(SETQ FCBS (CDR BUCKET))
(SORT FCBS (FUNCTION (LAMBDA (FCB1 FCB2)
(ILEQ (fetch (FCB EXTENT) of FCB1)
(fetch (FCB EXTENT) of FCB2)))))
(SETQ CALLOC (create CALLOC
FILENAME ← FILENAME
FCBS ← FCBS))
(push CALLOCS CALLOC))
(SETQ CALLOCS (SORT CALLOCS (FUNCTION (LAMBDA (CALLOC1 CALLOC2)
(ALPHORDER (fetch (CALLOC FILENAME) of CALLOC1)
(fetch (CALLOC FILENAME) of CALLOC2))))))
(* Store CALLOCS, FREEFCBS, & FREEGROUPS.
*)
(replace (CINFO CALLOCS) of \CFLOPPYINFO with CALLOCS)
(replace (CINFO FREEFCBS) of \CFLOPPYINFO with FREEFCBS)
(replace (CINFO FREEGROUPS) of \CFLOPPYINFO with FREEGROUPS)
(* We create the directory last because PACKFILENAME is brittle and it is nice to have the other info already filled
in if you have to debug. *)
(for CALLOC in CALLOCS when (LITATOM (fetch (CALLOC FILENAME) of CALLOC))
do (\CFLOPPY.DIR.PUT (fetch (CALLOC FILENAME) of CALLOC)
(QUOTE OLD)
CALLOC)))))
(\CFLOPPY.OPENFILE
(LAMBDA (FILE ACCESS RECOG OTHERINFO FDEV OLDSTREAM) (* edited: "23-Jul-84 15:31")
(OR (\SFLOPPY.HACK FILE ACCESS RECOG OTHERINFO FDEV OLDSTREAM)
(PROG (STREAM WAIT CALLOC FULLFILENAME)
(SETQ OTHERINFO (\FLOPPY.OTHERINFO OTHERINFO))
RETRY (* Get STREAM *)
(COND
((NULL (NLSETQ (SELECTQ ACCESS
(INPUT (\FLOPPY.CACHED.READ))
(\FLOPPY.CACHED.WRITE))))
(LISPERROR "FILE WON'T OPEN" FILE)
(GO RETRY)))
(COND
((NOT (type? STREAM FILE))
(SETQ STREAM (\CFLOPPY.OPENFILE1 FILE RECOG OTHERINFO)))
(T (SETQ STREAM FILE)))
(COND
((NULL STREAM) (* FILE NOT FOUND error generated in \OPENFILE when we
return NIL. *)
(RETURN NIL))) (* Establish ACCESS rights. *)
(SETQ CALLOC (fetch (FLOPPYSTREAM CALLOC) of STREAM))
(COND
((NOT (EQ ACCESS (QUOTE INPUT)))
(* WRITEFLG indicates whether FILE is currently being written. Impossible for more than one stream to point to a
file that is being written. *)
(SETQ WAIT (CDR (ASSOC (QUOTE WAIT)
OTHERINFO)))
(COND
(WAIT (WHILE (\CFLOPPY.STREAMS.AGAINST STREAM) DO (BLOCK))
(replace (CALLOC WRITEFLG) of CALLOC with T))
((fetch (CALLOC WRITEFLG) of CALLOC)
(SETQ FULLFILENAME (fetch (STREAM FULLFILENAME) of STREAM))
(SETQ FILE (LISPERROR "FILE WON'T OPEN" FULLFILENAME T))
(GO RETRY))) (* Use OTHERINFO to establish correct CREATIONDATE etc.
*)
(for BUCKET in OTHERINFO do (\CFLOPPY.SETFILEINFO STREAM (CAR BUCKET)
(CDR BUCKET)))))
(COND
((EQ ACCESS (QUOTE OUTPUT)) (* ACCESS = OUTPUT always starts empty.
*)
(replace (STREAM EPAGE) of STREAM with 0)
(replace (STREAM EOFFSET) of STREAM with 0)))
(RETURN STREAM)))))
(\CFLOPPY.OPENFILE1
(LAMBDA (FILE RECOG OTHERINFO) (* kbr: "17-Jul-85 19:04")
(WITH.MONITOR \FLOPPYLOCK (PROG (FILENAME EXTENSION CALLOC FCB IDATE STREAM)
RETRY (* Case where old FILE is being opened for output or
appending to be written *)
(SETQ FILENAME (\FLOPPY.ASSUREFILENAME FILE))
(SETQ CALLOC (\CFLOPPY.DIR.GET FILENAME RECOG))
(SETQ STREAM (SELECTQ RECOG
((EXACT OLD/NEW)
(COND
((NULL CALLOC)
(\CFLOPPY.OPENNEWFILE FILENAME
OTHERINFO))
(T (\CFLOPPY.OPENOLDFILE CALLOC
OTHERINFO))))
(NEW
(* CPM doesn't support version numbers.
*)
(COND
((NULL CALLOC)
(\CFLOPPY.OPENNEWFILE FILENAME
OTHERINFO))))
((OLD OLDEST)
(\CFLOPPY.OPENOLDFILE CALLOC OTHERINFO))
(SHOULDNT)))
(COND
((NULL STREAM)
(SELECTQ RECOG
((NEW OLD/NEW)
(SETQ FILENAME (LISPERROR "FILE WON'T OPEN"
FILENAME T)))
(PROGN
(* "FILE NOT FOUND" error is generated in \OPENFILE by our
returning NIL *)
(RETURN NIL)))
(GO RETRY)))
(RETURN STREAM)))))
(\CFLOPPY.OPENOLDFILE
(LAMBDA (CALLOC OTHERINFO) (* kbr: "19-Jul-85 14:06")
(PROG (LENGTH RECORDCOUNT LASTRECORDNO EPAGE EOFFSET FCBS STREAM)
(COND
((NULL CALLOC) (* Error in calling function. *)
(RETURN NIL)))
(COND
((EQ (CDR (ASSOC (QUOTE TYPE)
OTHERINFO))
(QUOTE BINARY)) (* File is binary, can't be sure ↑Zs are part of file or
are padding, so treat as if no padding.
*)
(SETQ LENGTH (fetch (CALLOC LENGTH) of CALLOC)))
(T
(* File is text. The convention is to pad files out with ↑Zs. Therefore, look in the last sector for a ↑Z to
indicate end of file. *)
(SETQ RECORDCOUNT (fetch (CALLOC RECORDCOUNT) of CALLOC))
(COND
((EQ RECORDCOUNT 0) (* There are no records. This is an empty file.
*)
(SETQ LENGTH 0))
(T (SETQ LASTRECORDNO (\CFLOPPY.PHYSICAL.RECORDNO CALLOC (SUB1 RECORDCOUNT)))
(\CFLOPPY.READRECORDNO LASTRECORDNO \FLOPPY.SCRATCH.BUFFER)
(SETQ LENGTH (IPLUS (ITIMES 128 (SUB1 RECORDCOUNT))
(for I from 0 to 127 when (EQ (\GETBASEBYTE
\FLOPPY.SCRATCH.BUFFER I)
(CHARCODE ↑Z))
do (RETURN I) finally (RETURN 128))))))))
(SETQ EPAGE (IQUOTIENT LENGTH 512))
(SETQ EOFFSET (IREMAINDER LENGTH 512))
(SETQ FCBS (fetch (CALLOC FCBS) of CALLOC))
(SETQ STREAM (create STREAM
DEVICE ← \FLOPPYFDEV
FULLFILENAME ← (\FLOPPY.ADDDEVICENAME (fetch (CALLOC FILENAME)
of CALLOC))
EOLCONVENTION ← CRLF.EOLC
EPAGE ← EPAGE
EOFFSET ← EOFFSET))
(replace (FLOPPYSTREAM CALLOC) of STREAM with CALLOC)
(replace (FLOPPYSTREAM FCBS) of STREAM with FCBS)
(RETURN STREAM))))
(\CFLOPPY.OPENNEWFILE
(LAMBDA (FILENAME OTHERINFO) (* kbr: "29-Apr-85 15:49")
(PROG (LENGTH CALLOC FCBS STREAM)
(SETQ LENGTH (CDR (ASSOC (QUOTE LENGTH)
OTHERINFO)))
(COND
(LENGTH (SETQ LENGTH (ADD1 (IQUOTIENT (IPLUS LENGTH 127)
128)))))
(SETQ CALLOC (\CFLOPPY.ALLOCATE LENGTH))
(SETQ FCBS (fetch (CALLOC FCBS) of CALLOC))
(\CFLOPPY.DIR.PUT FILENAME (QUOTE NEW)
CALLOC)
(for FCB in FCBS do (replace (FCB FILENAME) of FCB with FILENAME))
(* File is empty *)
(SETQ STREAM (create STREAM
DEVICE ← \FLOPPYFDEV
FULLFILENAME ← (\FLOPPY.ADDDEVICENAME (fetch (CALLOC FILENAME)
of CALLOC))
EOLCONVENTION ← CRLF.EOLC
EPAGE ← 0
EOFFSET ← 0))
(replace (FLOPPYSTREAM CALLOC) of STREAM with CALLOC)
(replace (FLOPPYSTREAM FCBS) of STREAM with FCBS)
(RETURN STREAM))))
(\CFLOPPY.ASSURESTREAM
(LAMBDA (FILE) (* edited: "23-Jul-84 15:31")
(PROG (STREAM)
RETRY
(COND
((type? STREAM FILE)
(RETURN FILE)))
(SETQ STREAM (\CFLOPPY.OPENFILE1 FILE (QUOTE OLD)))
(COND
((NULL STREAM)
(SETQ FILE (LISPERROR "FILE NOT FOUND" FILE))
(GO RETRY)))
(RETURN STREAM))))
(\CFLOPPY.GETFILEINFO
(LAMBDA (FILE ATTRIBUTE FDEV) (* kbr: "18-Jul-85 15:28")
(WITH.MONITOR \FLOPPYLOCK (PROG (STREAM LP ANSWER)
(COND
((AND (EQ ATTRIBUTE (QUOTE LENGTH))
(type? STREAM FILE))
(RETURN (\GETEOFPTR FILE))))
(\FLOPPY.CACHED.READ)
(SETQ STREAM (\CFLOPPY.ASSURESTREAM FILE))
(COND
(STREAM (SETQ CALLOC (fetch (FLOPPYSTREAM CALLOC) of STREAM))
(SETQ ANSWER (\CFLOPPY.GETFILEINFO1 CALLOC ATTRIBUTE))))
(RETURN ANSWER)))))
(\CFLOPPY.GETFILEINFO1
(LAMBDA (CALLOC ATTRIBUTE) (* kbr: "18-Jul-85 15:30")
(* Used by \CFLOPPY.GETFILEINFO & \CFLOPPY.FILEINFOFN *)
(PROG (ANSWER)
(SETQ ANSWER (SELECTQ ATTRIBUTE
(LENGTH
(* Don't know if file is supposed to be TEXT or BINARY if we are asked to determine LENGTH in this function instead
of \CFLOPPY.GETFILEINFO. We make a rough estimate, returning the value BINARY would return. *)
(fetch (CALLOC LENGTH) of CALLOC))
(SIZE (fetch (CALLOC PAGELENGTH) of CALLOC))
NIL))
(RETURN ANSWER))))
(\CFLOPPY.SETFILEINFO
(LAMBDA (FILE ATTRIBUTE VALUE) (* kbr: "29-Apr-85 16:13")
(WITH.MONITOR \FLOPPYLOCK (PROG (STREAM SUCCESSFUL)
(\FLOPPY.CACHED.WRITE)
(SETQ STREAM (\CFLOPPY.ASSURESTREAM FILE))
(COND
(STREAM (SETQ SUCCESSFUL T)
(SELECTQ ATTRIBUTE
(EOL (replace (STREAM EOLCONVENTION)
of STREAM with (SELECTQ VALUE
(CR CR.EOLC)
(CRLF
CRLF.EOLC)
(LF LF.EOLC)
NIL)))
(SETQ SUCCESSFUL NIL))))
(RETURN SUCCESSFUL)))))
(\CFLOPPY.CLOSEFILE
(LAMBDA (FILE) (* edited: "23-Jul-84 15:31")
(WITH.MONITOR \FLOPPYLOCK (PROG (STREAM FULLFILENAME)
(SETQ STREAM (\CFLOPPY.ASSURESTREAM FILE))
(\CLEARMAP STREAM)
(SETQ FULLFILENAME (\CFLOPPY.CLOSEFILE1 STREAM))
(RETURN FULLFILENAME)))))
(\CFLOPPY.CLOSEFILE1
(LAMBDA (STREAM) (* edited: "23-Jul-84 15:31")
(* The real CLOSEFILE. *)
(* Part of \CFLOPPY.CLOSEFILE needed to close subportions
of huge files. *)
(PROG (CALLOC MP NEXT NMP FULLFILENAME)
(SETQ CALLOC (fetch (FLOPPYSTREAM CALLOC) of STREAM))
(SETQ FULLFILENAME (fetch (STREAM FULLFILENAME) of STREAM))
(COND
((EQ (fetch (STREAM ACCESS) of STREAM)
(QUOTE INPUT))
(RETURN FULLFILENAME)))
(\CFLOPPY.SAVE.CHANGES CALLOC) (* Release STREAM. *)
(replace (CALLOC WRITEFLG) of CALLOC with NIL)
(COND
((fetch (CALLOC DELETEFLG) of CALLOC)
(\CFLOPPY.DELETEFILE STREAM)))
(RETURN FULLFILENAME))))
(\CFLOPPY.DELETEFILE
(LAMBDA (FILE FDEV RECOG) (* kbr: "17-Jul-85 18:52")
(COND
((NULL RECOG)
(SETQ RECOG (QUOTE OLDEST))))
(WITH.MONITOR \FLOPPYLOCK (PROG (FILENAME CALLOC MP NEXT NMP FULLFILENAME)
(\CFLOPPY.OPEN)
(SETQ FILENAME (\FLOPPY.ASSUREFILENAME FILE))
(SETQ CALLOC (\CFLOPPY.DIR.GET FILENAME RECOG))
(COND
((NULL CALLOC) (* File not found. *)
(* Returning NIL means unsuccessful.
*)
(RETURN NIL)))
(SETQ FULLFILENAME (\FLOPPY.ADDDEVICENAME (fetch (CALLOC FILENAME)
of CALLOC)))
(COND
((\CFLOPPY.STREAMS.USING CALLOC)
(* Make deletion pending. *)
(replace (CALLOC DELETEFLG) of CALLOC with T))
(T (* Carry out deletion. *)
(replace (CALLOC DELETEFLG) of CALLOC with NIL)
(\CFLOPPY.DIR.REMOVE CALLOC)
(\CFLOPPY.DEALLOCATE CALLOC)
(\CFLOPPY.SAVE.CHANGES CALLOC)))
(RETURN FULLFILENAME)))))
(\CFLOPPY.GETFILENAME
(LAMBDA (FILE RECOG FDEV) (* edited: "23-Jul-84 15:31")
(WITH.MONITOR \FLOPPYLOCK (PROG (FILENAME CALLOC)
(COND
((type? STREAM FILE)
(RETURN (fetch (STREAM FULLFILENAME) of FILE))))
(COND
((AND (\FLOPPY.EXISTSP)
(\FLOPPY.CACHED.READ))
(SETQ FILENAME (\FLOPPY.ASSUREFILENAME FILE))
(SETQ CALLOC (\CFLOPPY.DIR.GET FILENAME RECOG))
(COND
((NULL CALLOC)
(RETURN NIL)))
(RETURN (\FLOPPY.ADDDEVICENAME (fetch (CALLOC FILENAME)
of CALLOC)))))
(* NIL is returned if there is no floppy.
*)
))))
(\CFLOPPY.DIRECTORYNAMEP
(LAMBDA (DIRNAME) (* kbr: "21-Jul-85 14:24")
(EQ DIRNAME (QUOTE {FLOPPY}))))
(\CFLOPPY.GENERATEFILES
(LAMBDA (FDEV PATTERN DESIREDPROPS OPTIONS) (* edited: "23-Jul-84 15:31")
(WITH.MONITOR \FLOPPYLOCK (PROG (ALLOCS FILTER GENFILESTATE FILEGENOBJ)
(* No floppy gives empty directory so that {FLOPPY} can
safely be on DIRECTORIES search path.
*)
(COND
((AND (\FLOPPY.EXISTSP)
(\FLOPPY.CACHED.READ))
(SETQ FILTER (DIRECTORY.MATCH.SETUP PATTERN))
(SETQ ALLOCS (for CALLOC in (fetch (CFLOPPYFDEV CALLOCS)
of \FLOPPYFDEV)
when (AND (LITATOM (fetch (CALLOC FILENAME)
of CALLOC))
(DIRECTORY.MATCH
FILTER
(fetch (CALLOC FILENAME)
of CALLOC)))
collect CALLOC))))
(COND
((MEMB (QUOTE SORT)
OPTIONS)
(SORT ALLOCS (FUNCTION (LAMBDA (X Y)
(UALPHORDER (fetch (CALLOC FILENAME) of X)
(fetch (CALLOC FILENAME) of Y)))))))
(SETQ GENFILESTATE (create GENFILESTATE
ALLOCS ← ALLOCS
DEVICENAME ← (fetch (FDEV DEVICENAME)
of FDEV)))
(SETQ FILEGENOBJ (create FILEGENOBJ
NEXTFILEFN ← (FUNCTION
\CFLOPPY.NEXTFILEFN)
FILEINFOFN ← (FUNCTION
\CFLOPPY.FILEINFOFN)
GENFILESTATE ← GENFILESTATE))
(RETURN FILEGENOBJ)))))
(\CFLOPPY.NEXTFILEFN
(LAMBDA (GENFILESTATE NAMEONLY SCRATCHLIST) (* edited: "23-Jul-84 15:31")
(* Generates next file from GENFILESTATE or NIL if
finished. Used by \CFLOPPY.GENERATEFILES.
*)
(PROG (ALLOCS FILENAME DEVICENAME ANSWER)
(SETQ ALLOCS (fetch (GENFILESTATE ALLOCS) of GENFILESTATE))
(COND
((NULL ALLOCS)
(RETURN)))
(replace (GENFILESTATE CURRENTALLOC) of GENFILESTATE with (CAR ALLOCS))
(replace (GENFILESTATE ALLOCS) of GENFILESTATE with (CDR ALLOCS))
(SETQ FILENAME (fetch (CALLOC FILENAME) of (CAR ALLOCS)))
(SETQ DEVICENAME (fetch (GENFILESTATE DEVICENAME) of GENFILESTATE))
(COND
(NAMEONLY (SETQ ANSWER FILENAME))
(T (SETQ ANSWER (CONCAT "{" (fetch (GENFILESTATE DEVICENAME) of GENFILESTATE)
"}" FILENAME))))
(RETURN ANSWER))))
(\CFLOPPY.FILEINFOFN
(LAMBDA (GENFILESTATE ATTRIBUTE) (* edited: "23-Jul-84 15:31")
(* Get file info for current file in GENFILESTATE.
*)
(\CFLOPPY.GETFILEINFO1 (fetch (GENFILESTATE CURRENTALLOC) of GENFILESTATE)
ATTRIBUTE)))
(\CFLOPPY.RENAMEFILE
(LAMBDA (OLDFILE NEWFILE FDEV OLDRECOG NEWRECOG) (* edited: "23-Jul-84 15:31")
(COND
((NULL OLDRECOG)
(SETQ OLDRECOG (QUOTE OLD))))
(COND
((NULL NEWRECOG)
(SETQ NEWRECOG (QUOTE NEW))))
(WITH.MONITOR \FLOPPYLOCK (PROG (OLDFILENAME NEWFILENAME CALLOC FCBS FULLFILENAME)
(\FLOPPY.CACHED.READ)
(SETQ OLDFILENAME (\FLOPPY.ASSUREFILENAME OLDFILE))
(SETQ NEWFILENAME (\FLOPPY.ASSUREFILENAME NEWFILE))
(SETQ CALLOC (\CFLOPPY.DIR.GET OLDFILENAME OLDRECOG))
(COND
((NULL CALLOC) (* File not found. *)
(* Returning NIL means unsuccessful.
*)
(RETURN NIL)))
(\CFLOPPY.DIR.REMOVE CALLOC)
(* Store NEWFILENAME on FCBS. *)
(\CFLOPPY.DIR.PUT NEWFILENAME NEWRECOG CALLOC)
(FOR FCB IN (fetch (CALLOC FCBS) of CALLOC)
DO (replace (FCB FILENAME) of FCB with NEWFILENAME))
(replace (CALLOC CHANGEDFCBS) of CALLOC
with (UNION (fetch (CALLOC CHANGEDFCBS) of CALLOC)
(fetch (CALLOC FCBS) of CALLOC)))
(* Write changes out to floppy.
*)
(\CFLOPPY.SAVE.CHANGES CALLOC)
(* Return FULLFILENAME. *)
(SETQ FULLFILENAME (\FLOPPY.ADDDEVICENAME (fetch (CALLOC FILENAME)
of CALLOC)))
(RETURN FULLFILENAME)))))
(\CFLOPPY.STREAMS.AGAINST
(LAMBDA (STREAM) (* edited: "23-Jul-84 15:31")
(* Return other open floppy streams with same CALLOC.
*)
(FOR F IN \OPENFILES WHEN (AND (EQ (fetch (STREAM DEVICE) of F)
\FLOPPYFDEV)
(EQ (fetch (FLOPPYSTREAM CALLOC) of F)
(fetch (FLOPPYSTREAM CALLOC) of STREAM))
(NOT (EQ F STREAM)))
COLLECT F)))
(\CFLOPPY.STREAMS.USING
(LAMBDA (CALLOC) (* edited: "23-Jul-84 15:31")
(* Return open floppy streams with this CALLOC.
*)
(for F in \OPENFILES when (AND (EQ (fetch (STREAM DEVICE) of F)
\FLOPPYFDEV)
(EQ (fetch (FLOPPYSTREAM CALLOC) of F)
CALLOC))
collect F)))
(\CFLOPPY.READPAGES
(LAMBDA (STREAM FIRSTPAGE# BUFFERS) (* edited: "23-Jul-84 15:31")
(PROG NIL
(for BUFFER in (MKLIST BUFFERS) as I from 0 do (\CFLOPPY.READPAGE STREAM (IPLUS FIRSTPAGE#
I)
BUFFER)))))
(\CFLOPPY.READPAGE
(LAMBDA (FILE FIRSTPAGE# BUFFER) (* kbr: "19-Jul-85 17:56")
(WITH.MONITOR \FLOPPYLOCK (PROG (STREAM CALLOC RECORDNO)
(SETQ STREAM (\CFLOPPY.ASSURESTREAM FILE))
(SETQ CALLOC (fetch (FLOPPYSTREAM CALLOC) of STREAM))
(COND
((IGREATERP FIRSTPAGE# (FOLDLO (SUB1 (\GETEOFPTR STREAM))
BYTESPERPAGE))
(* Don't bother to do actual read.
*)
(COND
((IGEQ FIRSTPAGE# (fetch (CALLOC PAGELENGTH) of CALLOC))
(* Typically (because of lisp page buffering) we will try to write to RECORDNO in the very near future.
It's easier for the user to confront FILE SYSTEM RESOURCES EXCEEDED if we reallocate now instead of later.
*)
(\CFLOPPY.EXTEND CALLOC)))
(RETURN)))
(SETQ RECORDNO (\CFLOPPY.PHYSICAL.RECORDNO CALLOC
(ITIMES 4 FIRSTPAGE#)))
(for I from 0 to 3 do (\CFLOPPY.READRECORDNO (IPLUS RECORDNO I)
(\ADDBASE
BUFFER
(ITIMES 64 I))))))
(BLOCK)))
(\CFLOPPY.PHYSICAL.RECORDNO
(LAMBDA (CALLOC N) (* kbr: "19-Jul-85 17:31")
(* Return the Nth physical RECORDNO of CALLOC.
0th is first. *)
(PROG (FCBS FCB GROUP RECORDNO)
(SETQ FCBS (fetch (CALLOC FCBS) of CALLOC))
(SETQ FCB (CAR (NTH FCBS (ADD1 (IQUOTIENT N 128)))))
(SETQ N (IREMAINDER N 128))
(SETQ GROUP (\GETBASEBYTE (fetch (FCB DISKMAP) of FCB)
(IQUOTIENT N 8)))
(COND
((EQ GROUP 0) (* Didn't find a legal group. *)
(SHOULDNT)))
(SETQ RECORDNO (IPLUS (ITIMES 8 GROUP)
(IREMAINDER N 8)))
(RETURN RECORDNO))))
(\CFLOPPY.READRECORDNO
(LAMBDA (RECORDNO RECORD NOERROR) (* edited: "23-Jul-84 15:31")
(PROG (ANSWER) (* Read RECORD. *)
(GLOBALRESOURCE \FLOPPY.IBMS128.FLOPPYIOCB (SETQ ANSWER (COND
((OR (ILESSP RECORDNO 0)
(IGREATERP RECORDNO 4003))
(\FLOPPY.SEVERE.ERROR "Illegal Read RECORD Number")
NIL)
(T (\FLOPPY.READSECTOR \FLOPPY.IBMS128.FLOPPYIOCB (
\CFLOPPY.RECORDNOTODISKADDRESS RECORDNO)
RECORD NOERROR)))))
(* Return ANSWER (RECORD or NIL) *)
(RETURN ANSWER))))
(\CFLOPPY.WRITERECORDNO
(LAMBDA (RECORDNO RECORD NOERROR) (* edited: "23-Jul-84 15:31")
(PROG (ANSWER) (* Write RECORD. *)
(GLOBALRESOURCE \FLOPPY.IBMS128.FLOPPYIOCB (SETQ ANSWER (COND
((OR (ILESSP RECORDNO 0)
(IGREATERP RECORDNO 4003))
(\FLOPPY.SEVERE.ERROR "Illegal Write RECORD Number")
NIL)
(T (\FLOPPY.WRITESECTOR \FLOPPY.IBMS128.FLOPPYIOCB (
\CFLOPPY.RECORDNOTODISKADDRESS RECORDNO)
RECORD NOERROR)))))
(* Return ANSWER (RECORD or NIL) *)
(RETURN ANSWER))))
(\CFLOPPY.RECORDNOTODISKADDRESS
(LAMBDA (RECORDNO) (* edited: "23-Jul-84 15:31")
(PROG (CPMSECTORSPERTRACK CPMTRACKSPERCYLINDER QUOTIENT CYLINDER HEAD SECTOR DISKADDRESS)
(SETQ CPMSECTORSPERTRACK 26)
(SETQ CPMTRACKSPERCYLINDER 1)
(SETQ SECTOR (ELT \CFLOPPYSECTORMAP (IREMAINDER RECORDNO CPMSECTORSPERTRACK)))
(SETQ QUOTIENT (IQUOTIENT RECORDNO CPMSECTORSPERTRACK))
(SETQ CYLINDER (IPLUS (IQUOTIENT QUOTIENT CPMTRACKSPERCYLINDER)
2))
(SETQ HEAD (IREMAINDER QUOTIENT CPMTRACKSPERCYLINDER))
(SETQ DISKADDRESS (create DISKADDRESS
SECTOR ← SECTOR
HEAD ← HEAD
CYLINDER ← CYLINDER))
(RETURN DISKADDRESS))))
(\CFLOPPY.DIR.GET
(LAMBDA (FILENAME RECOG) (* edited: "23-Jul-84 15:31")
(PROG (UNAME NALIST EALIST NAME EXTENSION CALLOC)
(COND
((NOT (EQ RECOG (QUOTE EXACT)))
(SETQ UNAME (UNPACKFILENAME FILENAME))
(SETQ NAME (LISTGET UNAME (QUOTE NAME)))
(SETQ EXTENSION (LISTGET UNAME (QUOTE EXTENSION)))
(SETQ NAME (SUBATOM NAME 1 (IMIN 8 (NCHARS NAME))))
(SETQ EXTENSION (SUBATOM EXTENSION 1 (IMIN 3 (NCHARS EXTENSION))))
(SETQ NAME (U-CASE NAME))
(SETQ EXTENSION (U-CASE EXTENSION))
(SETQ NALIST (fetch (CFLOPPYFDEV DIR) of \FLOPPYFDEV))
(SETQ EALIST (CDR (ASSOC NAME NALIST)))
(SETQ CALLOC (CDR (ASSOC EXTENSION EALIST))))
(T (SETQ CALLOC (FOR CALLOC IN (fetch (CFLOPPYFDEV CALLOCS) of \FLOPPYFDEV)
THEREIS (EQ (fetch (CALLOC FILENAME) of CALLOC)
FILENAME)))))
(RETURN CALLOC))))
(\CFLOPPY.DIR.PUT
(LAMBDA (FILENAME RECOG CALLOC) (* kbr: "21-Jul-85 14:10")
(PROG (UNAME NALIST EALIST NAME EXTENSION)
(SETQ UNAME (UNPACKFILENAME FILENAME))
(SETQ NAME (LISTGET UNAME (QUOTE NAME)))
(SETQ EXTENSION (LISTGET UNAME (QUOTE EXTENSION)))
(SETQ NAME (SUBATOM NAME 1 (IMIN 8 (NCHARS NAME))))
(SETQ EXTENSION (SUBATOM EXTENSION 1 (IMIN 3 (NCHARS EXTENSION))))
(LISTPUT UNAME (QUOTE NAME)
NAME)
(LISTPUT UNAME (QUOTE EXTENSION)
EXTENSION)
(LISTPUT UNAME (QUOTE VERSION)
NIL)
(LISTPUT UNAME (QUOTE DIRECTORY)
NIL)
(LISTPUT UNAME (QUOTE HOST)
NIL)
(SETQ FILENAME (PACKFILENAME UNAME))
(SETQ NAME (U-CASE NAME))
(SETQ EXTENSION (U-CASE EXTENSION))
(replace (CALLOC FILENAME) of CALLOC with FILENAME)
(SETQ NALIST (fetch (CFLOPPYFDEV DIR) of \FLOPPYFDEV))
(SETQ EALIST (CDR (ASSOC NAME NALIST)))
(SETQ EALIST (\FLOPPY.LEXPUTASSOC EXTENSION CALLOC EALIST))
(SETQ NALIST (\FLOPPY.LEXPUTASSOC NAME EALIST NALIST))
(replace (CFLOPPYFDEV DIR) of \FLOPPYFDEV with NALIST)
(RETURN CALLOC))))
(\CFLOPPY.DIR.REMOVE
(LAMBDA (CALLOC) (* edited: "23-Jul-84 15:31")
(PROG (FILENAME UNAME NALIST EALIST NAME EXTENSION)
(SETQ FILENAME (fetch (CALLOC FILENAME) of CALLOC))
(SETQ UNAME (UNPACKFILENAME FILENAME))
(SETQ NAME (LISTGET UNAME (QUOTE NAME)))
(SETQ EXTENSION (LISTGET UNAME (QUOTE EXTENSION)))
(SETQ NAME (SUBATOM NAME 1 (IMIN 8 (NCHARS NAME))))
(SETQ EXTENSION (SUBATOM EXTENSION 1 (IMIN 3 (NCHARS EXTENSION))))
(SETQ NAME (U-CASE NAME))
(SETQ EXTENSION (U-CASE EXTENSION))
(SETQ NALIST (fetch (CFLOPPYFDEV DIR) of \FLOPPYFDEV))
(SETQ EALIST (CDR (ASSOC NAME NALIST)))
(SETQ EALIST (\FLOPPY.LEXREMOVEASSOC EXTENSION EALIST))
(COND
(EALIST (SETQ NALIST (\FLOPPY.LEXPUTASSOC NAME EALIST NALIST)))
(T (SETQ NALIST (\FLOPPY.LEXREMOVEASSOC NAME NALIST))))
(replace (CFLOPPYFDEV DIR) of \FLOPPYFDEV with NALIST)
(RETURN CALLOC))))
(\CFLOPPY.WRITEPAGES
(LAMBDA (STREAM FIRSTPAGE# BUFFERS) (* edited: "23-Jul-84 15:31")
(PROG NIL
(for BUFFER in (MKLIST BUFFERS) as I from 0 do (\CFLOPPY.WRITEPAGE STREAM (IPLUS FIRSTPAGE#
I)
BUFFER)))))
(\CFLOPPY.WRITEPAGE
(LAMBDA (FILE FIRSTPAGE# BUFFER) (* edited: "23-Jul-84 15:32")
(WITH.MONITOR \FLOPPYLOCK (PROG (STREAM CALLOC RECORDNO)
(SETQ STREAM (\CFLOPPY.ASSURESTREAM FILE))
(* Put in a check to see that we have not exceeded our
allocation. *)
(SETQ CALLOC (fetch (FLOPPYSTREAM CALLOC) of STREAM))
RETRY
(COND
((IGREATERP FIRSTPAGE# (fetch (CALLOC PAGELENGTH) of CALLOC))
(\CFLOPPY.EXTEND CALLOC)
(GO RETRY)))
(SETQ RECORDNO (\CFLOPPY.PHYSICAL.RECORDNO CALLOC
(ITIMES 4 FIRSTPAGE#)))
(for I from 0 to 3 do (\CFLOPPY.WRITERECORDNO
(IPLUS RECORDNO I)
(\ADDBASE BUFFER (ITIMES 64 I))))))
(BLOCK)))
(\CFLOPPY.TRUNCATEFILE
(LAMBDA (FILE LASTPAGE LASTPOFFSET) (* kbr: "19-Jul-85 17:57")
(WITH.MONITOR \FLOPPYLOCK (PROG (STREAM CALLOC NRECORDS LASTRECORD LASTROFFSET)
(SETQ STREAM (\CFLOPPY.ASSURESTREAM FILE))
(* Split CALLOC into file block and free block.
*)
(COND
((NULL LASTPAGE) (* LASTPAGE = NIL means to truncate to the current length.
*)
(SETQ LASTPAGE (fetch (STREAM EPAGE) of STREAM))
(SETQ LASTPOFFSET (fetch (STREAM EOFFSET) of STREAM))))
(SETQ CALLOC (fetch (FLOPPYSTREAM CALLOC) of STREAM))
(* Convert remaining pages into free block.
*)
(SETQ LASTROFFSET (IREMAINDER LASTPOFFSET 128))
(COND
((ZEROP LASTROFFSET)
(* Special case LASTROFFSET = 0 *)
(SETQ NRECORDS (IPLUS (ITIMES 4 LASTPAGE)
(IQUOTIENT LASTPOFFSET 128))))
(T (* Pad out with ↑Zs. *)
(SETQ NRECORDS (ADD1 (IPLUS (ITIMES 4 LASTPAGE)
(IQUOTIENT LASTPOFFSET 128))))
(SETQ LASTRECORD (\CFLOPPY.PHYSICAL.RECORDNO CALLOC
(SUB1 NRECORDS))
)
(GLOBALRESOURCE \FLOPPY.SCRATCH.BUFFER (
\CFLOPPY.READRECORDNO LASTRECORD
\FLOPPY.SCRATCH.BUFFER)
(for I from LASTROFFSET to 127
do (\PUTBASEBYTE \FLOPPY.SCRATCH.BUFFER I
(CHARCODE ↑Z)))
(\CFLOPPY.WRITERECORDNO LASTRECORD
\FLOPPY.SCRATCH.BUFFER))))
(\CFLOPPY.TRUNCATE CALLOC NRECORDS)))))
(\CFLOPPY.ALLOCATE.FCB
(LAMBDA NIL (* edited: "23-Jul-84 15:32")
(PROG (FREEFCBS FCB)
RETRY
(SETQ FREEFCBS (fetch (CINFO FREEFCBS) of \CFLOPPYINFO))
(COND
((NULL FREEFCBS)
(LISPERROR "FILE SYSTEM RESOURCES EXCEEDED")
(GO RETRY)))
(SETQ FCB (CAR FREEFCBS))
(replace (CINFO FREEFCBS) of \CFLOPPYINFO with (CDR FREEFCBS))
(* NAME & EXTENSION become blanks.
Rest of FCB--not including NUMBER--is zeroed.
*)
(replace (FCB ET) of FCB with CPMFILEMARK)
(for I from 1 to 12 do (\PUTBASEBYTE FCB I (CHARCODE SP)))
(for I from 13 to 32 do (\PUTBASEBYTE FCB I 0))
(RETURN FCB))))
(\CFLOPPY.ALLOCATE.GROUP
(LAMBDA NIL (* edited: "23-Jul-84 15:32")
(PROG (FREEGROUPS GROUP)
RETRY
(SETQ FREEGROUPS (fetch (CINFO FREEGROUPS) of \CFLOPPYINFO))
(COND
((NULL FREEGROUPS)
(LISPERROR "FILE SYSTEM RESOURCES EXCEEDED")
(GO RETRY)))
(SETQ GROUP (CAR FREEGROUPS))
(replace (CINFO FREEGROUPS) of \CFLOPPYINFO with (CDR FREEGROUPS))
(RETURN GROUP))))
(\CFLOPPY.ALLOCATE
(LAMBDA (NRECORDS) (* kbr: "19-Jul-85 16:06")
(COND
((NULL NRECORDS)
(SETQ NRECORDS 8)))
(PROG (NFCBS NGROUPS FCBS GROUPS CALLOC) (* Get sufficient numbers of FCBS & GROUPS for the
allocation. Always at least one FCB even if no groups.
*)
(* FCB = directory entry. Group = group of pages on
floppy. *)
(SETQ NGROUPS (IQUOTIENT (IPLUS NRECORDS 7)
8))
(SETQ NFCBS (IMAX 1 (IQUOTIENT (IPLUS NGROUPS 15)
16)))
RETRY
(COND
((OR (ILESSP (LENGTH (fetch (CINFO FREEFCBS) of \CFLOPPYINFO))
NFCBS)
(ILESSP (LENGTH (fetch (CINFO FREEGROUPS) of \CFLOPPYINFO))
NGROUPS))
(LISPERROR "FILE SYSTEM RESOURCES EXCEEDED")
(GO RETRY)))
(UNINTERRUPTABLY
(SETQ FCBS (for I from 1 to NFCBS collect (\CFLOPPY.ALLOCATE.FCB)))
(SETQ GROUPS (for I from 1 to NGROUPS collect (\CFLOPPY.ALLOCATE.GROUP)))
(* Fill in fields of FCBS. *)
(for FCB in FCBS as EXTENT from 0
do (replace (FCB EXTENT) of FCB with EXTENT)
(COND
((NOT (IEQP EXTENT (SUB1 NFCBS)))
(replace (FCB RECORDCOUNT) of FCB with 128))
(T (replace (FCB RECORDCOUNT) of FCB with (IDIFFERENCE NRECORDS
(ITIMES 128
(SUB1 NFCBS))))))
(for (DMINDEX ← 0) to 15 while GROUPS do (\PUTBASEBYTE (fetch (FCB DISKMAP)
of FCB)
DMINDEX
(pop GROUPS))))
(* Create CALLOC. *)
(SETQ CALLOC (create CALLOC
FCBS ← FCBS
CHANGEDFCBS ← FCBS))
(replace (CINFO CALLOCS) of \CFLOPPYINFO with (CONS CALLOC (fetch (CINFO CALLOCS)
of \CFLOPPYINFO))))
(* OKEY DOKEY. *)
(\CFLOPPY.ICHECK)
(RETURN CALLOC))))
(\CFLOPPY.TRUNCATE
(LAMBDA (CALLOC NRECORDS) (* kbr: "19-Jul-85 17:22")
(PROG (OLDNGROUPS NGROUPS NFCBS FREEFCBS FREEGROUPS CHANGEDFCBS CHANGEDGROUPS)
(COND
((ILEQ (fetch (CALLOC RECORDCOUNT) of CALLOC)
NRECORDS) (* Nothing to do. *)
(RETURN)))
(UNINTERRUPTABLY
(SETQ OLDNGROUPS (FOLDHI (fetch (CALLOC RECORDCOUNT) of CALLOC)
8))
(SETQ NGROUPS (FOLDHI NRECORDS 8))
(SETQ NFCBS (FOLDHI NGROUPS 16))
(SETQ FREEFCBS (fetch (CINFO FREEFCBS) of \CFLOPPYINFO))
(SETQ FREEGROUPS (fetch (CINFO FREEGROUPS) of \CFLOPPYINFO))
(* Mark existing FCBs. *)
(for FCB in (fetch (CALLOC FCBS) of CALLOC) as I from 1
do (COND
((ILESSP I NFCBS) (* No changes to this FCB. *)
)
((IEQP I NFCBS)
(replace (FCB RECORDCOUNT) of FCB with (IDIFFERENCE NRECORDS
(ITIMES 128 (SUB1 NFCBS)))
)
(push CHANGEDFCBS FCB))
(T (COND
((IGREATERP I 1)
(* I = 1 implies empty file, but we never delete first FCB, even if it is empty. Otherwise an empty file would mean
no file. *)
(replace (FCB ET) of FCB with CPMDELETEMARK)
(push FREEFCBS FCB)))
(push CHANGEDFCBS FCB)))
(for DMINDEX from 0 to 15 when (AND (IGEQ (IPLUS (ITIMES 16 (SUB1 I))
DMINDEX)
NGROUPS)
(ILEQ (IPLUS (ITIMES 16 (SUB1 I))
DMINDEX)
(SUB1 OLDNGROUPS)))
do (push CHANGEDGROUPS (\GETBASEBYTE (fetch (FCB DISKMAP) of FCB)
I))))
(* Update CALLOC. *)
(RPLACD (NTH (fetch (CALLOC FCBS) of CALLOC)
(IMAX 1 NFCBS))
NIL)
(replace (CALLOC CHANGEDFCBS) of CALLOC with (UNION CHANGEDFCBS (fetch (CALLOC
CHANGEDFCBS)
of CALLOC)))
(replace (CALLOC CHANGEDGROUPS) of CALLOC with (UNION CHANGEDGROUPS
(fetch (CALLOC CHANGEDGROUPS)
of CALLOC))))
(* Update floppy. *)
(\CFLOPPY.SAVE.CHANGES CALLOC))))
(\CFLOPPY.DEALLOCATE
(LAMBDA (CALLOC) (* kbr: "19-Jul-85 16:29")
(PROG (FCBS) (* FCB = directory entry. Group = group of pages on
floppy. *)
(SETQ FCBS (fetch (CALLOC FCBS) of CALLOC))
(UNINTERRUPTABLY
(replace (CALLOC CHANGEDFCBS) of CALLOC with FCBS)
(replace (CALLOC CHANGEDGROUPS) of CALLOC with (fetch (CALLOC GROUPS) of CALLOC))
(* Changing FCBS of CALLOC to NIL changes ACCESSFN GROUPS
to NIL. *)
(replace (CALLOC FCBS) of CALLOC with NIL)
(for FCB in FCBS do (replace (FCB ET) of FCB with CPMDELETEMARK))
(replace (CINFO CALLOCS) of \CFLOPPYINFO with (DREMOVE CALLOC (fetch (CINFO CALLOCS)
of \CFLOPPYINFO))))
(\CFLOPPY.ICHECK))))
(\CFLOPPY.EXTEND
(LAMBDA (CALLOC) (* edited: "23-Jul-84 15:32")
(PROG (FCB GROUP RECORDCOUNT DMINDEX)
(SETQ FCB (CAR (LAST (fetch (CALLOC FCBS) of CALLOC))))
(SETQ RECORDCOUNT (fetch (FCB RECORDCOUNT) of FCB))
(* Adding fcbs. *)
(COND
((IEQP RECORDCOUNT 128) (* FCB full. Get a new one. *)
(SETQ FCB (\CFLOPPY.ALLOCATE.FCB))
(replace (FCB FILENAME) of FCB with (fetch (CALLOC FILENAME) of CALLOC))
(replace (FCB EXTENT) of FCB with (LENGTH (fetch (CALLOC FCBS) of CALLOC)))
(replace (FCB RECORDCOUNT) of FCB with 0)
(SETQ RECORDCOUNT 0)
(replace (CALLOC FCBS) of CALLOC with (NCONC (fetch (CALLOC FCBS) of CALLOC)
(LIST FCB)))))
(* Adding records or groups. DMINDEX = current Disk Map
INDEX. *)
(SETQ DMINDEX (SUB1 (IQUOTIENT (IPLUS RECORDCOUNT 7)
8)))
(COND
((NOT (IEQP (IREMAINDER RECORDCOUNT 8)
0)) (* Add records by using remainder of last group.
*)
(replace (FCB RECORDCOUNT) of FCB with (ITIMES 8 (ADD1 DMINDEX))))
(T (* Add a group. *)
(SETQ GROUP (\CFLOPPY.ALLOCATE.GROUP))
(\PUTBASEBYTE (fetch (FCB DISKMAP) of FCB)
(ADD1 DMINDEX)
GROUP)
(replace (FCB RECORDCOUNT) of FCB with (ITIMES 8 (IPLUS 2 DMINDEX)))))
(* Remember changed FCB. *)
(COND
((NOT (MEMB FCB (fetch (CALLOC CHANGEDFCBS) of CALLOC)))
(replace (CALLOC CHANGEDFCBS) of CALLOC with (CONS FCB (fetch (CALLOC CHANGEDFCBS)
of CALLOC))))))))
(\CFLOPPY.SAVE.CHANGES
(LAMBDA (CALLOC) (* kbr: "19-Jul-85 16:31")
(PROG (FREEFCBS FREEGROUPS RECORDNO RECORDNOS) (* Determine new FREEFCBS & FREEGROUPS for \CFLOPPYINFO.
Calc which directory records need to be rewritten.
*)
(\FLOPPY.CACHED.WRITE)
(UNINTERRUPTABLY
(SETQ FREEFCBS (fetch (CINFO FREEFCBS) of \CFLOPPYINFO))
(SETQ FREEGROUPS (fetch (CINFO FREEGROUPS) of \CFLOPPYINFO))
(for FCB in (fetch (CALLOC CHANGEDFCBS) of CALLOC)
do (COND
((AND (EQ (fetch (FCB ET) of FCB)
CPMDELETEMARK)
(NOT (FMEMB FCB FREEFCBS)))
(replace (CINFO FREEFCBS) of \CFLOPPYINFO with (SETQ FREEFCBS
(CONS FCB FREEFCBS)))
(replace (CINFO FREEGROUPS) of \CFLOPPYINFO
with (SETQ FREEGROUPS (NCONC (fetch (FCB GROUPS) of FCB)
FREEGROUPS)))
(for I from 0 to 31 do (\PUTBASEBYTE FCB I CPMDELETEMARK))))
(\BLT (\ADDBASE \CFLOPPYDIRECTORY (ITIMES 16 (fetch (FCB NUMBER) of FCB)))
FCB 16)
(SETQ RECORDNO (IQUOTIENT (fetch (FCB NUMBER) of FCB)
4))
(COND
((NOT (FMEMB RECORDNO RECORDNOS))
(push RECORDNOS RECORDNO)))) (* Write out changed directory records *)
(for RECORDNO in RECORDNOS do (\CFLOPPY.WRITERECORDNO RECORDNO (\ADDBASE
\CFLOPPYDIRECTORY
(ITIMES 64
RECORDNO))
T))
(* Update CALLOC & \CFLOPPYINFO *)
(replace (CALLOC CHANGEDFCBS) of CALLOC with NIL)
(replace (CALLOC CHANGEDGROUPS) of CALLOC with NIL)
(replace (CINFO FREEFCBS) of \CFLOPPYINFO with FREEFCBS)
(replace (CINFO FREEGROUPS) of \CFLOPPYINFO with FREEGROUPS))
(\CFLOPPY.ICHECK))))
(\CFLOPPY.ICHECK
(LAMBDA NIL (* kbr: "19-Jul-85 16:37")
(* Integrity check. *)
(PROG (USEDFCBS USEDGROUPS FREEFCBS FREEGROUPS FCBS GROUPS)
(* Check each CALLOC for plausibleness.
Groups 0 & 1 contain directory.
*)
(SETQ USEDGROUPS (QUOTE (0 1)))
(for CALLOC in (fetch (CFLOPPYFDEV CALLOCS) of \FLOPPYFDEV)
do (\CFLOPPY.ICHECK.CALLOC CALLOC)
(SETQ USEDFCBS (APPEND (fetch (CALLOC FCBS) of CALLOC)
USEDFCBS))
(SETQ USEDGROUPS (APPEND (fetch (CALLOC GROUPS) of CALLOC)
USEDGROUPS))) (* Check that we have accounted for all GROUPS and FCBS *)
(SETQ FREEFCBS (fetch (CFLOPPYFDEV FREEFCBS) of \FLOPPYFDEV))
(SETQ FREEGROUPS (fetch (CFLOPPYFDEV FREEGROUPS) of \FLOPPYFDEV))
(COND
((INTERSECTION USEDFCBS FREEFCBS)
(\FLOPPY.SEVERE.ERROR "USEDFCBS & FREEFCBS intersect")))
(COND
((INTERSECTION USEDGROUPS FREEGROUPS)
(\FLOPPY.SEVERE.ERROR "USEDGROUPS & FREEGROUPS intersect")))
(SETQ FCBS (APPEND FREEFCBS USEDFCBS))
(SETQ GROUPS (APPEND FREEGROUPS USEDGROUPS))
(COND
((NOT (ILEQ (LENGTH FCBS)
64))
(\FLOPPY.SEVERE.ERROR "Wrong number of FCBS")))
(COND
((NOT (ILEQ (LENGTH GROUPS)
250))
(\FLOPPY.SEVERE.ERROR "Wrong number of GROUPS")))
(* Check FLOPPY streams ok *)
(for F in \OPENFILES when (AND (EQ (fetch (STREAM DEVICE) of F)
\FLOPPYFDEV)
(NOT (MEMB (fetch (FLOPPYSTREAM CALLOC) of F)
(fetch (CFLOPPYFDEV CALLOCS) of \FLOPPYFDEV))))
do (\FLOPPY.SEVERE.ERROR "Streams Allocation Error")))))
(\CFLOPPY.ICHECK.CALLOC
(LAMBDA (CALLOC) (* kbr: "19-Jul-85 15:56")
(* CALLOC Integrity Check *)
(PROG NIL
(for I from 1 as FCB in (fetch (CALLOC FCBS) of CALLOC)
when (NOT (IEQP I (ADD1 (fetch (FCB EXTENT) of FCB)))) do (\FLOPPY.SEVERE.ERROR
"Unexpected FCB extent number"))
(COND
((OR (INTERSECTION (QUOTE (0 1))
(fetch (CALLOC GROUPS) of CALLOC))
(INTERSECTION (QUOTE (0 1))
(fetch (CALLOC CHANGEDGROUPS) of CALLOC)))
(\FLOPPY.SEVERE.ERROR "Unexpected group number"))))))
(\CFLOPPY.FREE.PAGES
(LAMBDA NIL (* edited: "23-Jul-84 15:32")
(WITH.MONITOR \FLOPPYLOCK (PROG (ANSWER)
(\FLOPPY.CACHED.READ)
(SETQ ANSWER (ITIMES 2 (LENGTH (fetch (CINFO FREEGROUPS)
of \CFLOPPYINFO))))
(RETURN ANSWER)))))
(\CFLOPPY.FORMAT
(LAMBDA (NAME AUTOCONFIRMFLG SLOWFLG) (* kbr: "18-Jul-85 13:46")
(WITH.MONITOR \FLOPPYLOCK
(PROG NIL
(\FLOPPY.CLOSE)
RETRY
(COND
((NOT (\FLOPPY.UNCACHED.WRITE))
(GO RETRY))) (* Configure floppy. *)
(COND
(SLOWFLG (GLOBALRESOURCE
\FLOPPY.IBMS128.FLOPPYIOCB
(* Format tracks. *)
(COND
((NOT (AND (\FLOPPY.INITIALIZE T)
(\FLOPPY.RECALIBRATE T)
(\FLOPPY.FORMATTRACKS \FLOPPY.IBMS128.FLOPPYIOCB
(create DISKADDRESS
CYLINDER ← 0
HEAD ← 0
SECTOR ← 1)
77 T)
(OR (NOT (fetch (FLOPPYRESULT TWOSIDED)
of \FLOPPYRESULT))
(AND (\FLOPPY.RECALIBRATE T)
(\FLOPPY.FORMATTRACKS
\FLOPPY.IBMS128.FLOPPYIOCB
(create DISKADDRESS
CYLINDER ← 0
HEAD ← 1
SECTOR ← 1)
77 T)))))
(\FLOPPY.MESSAGE "RETRYING FORMAT")
(GO RETRY)))
(* Check that we can read from each cylinder. We need to do this because FORMATTRACKS is unreliable.
If we find a bad cylinder, it usually works to try again a few times. *)
(COND
((for I from 0 to 76
thereis (NULL (\FLOPPY.READSECTOR
\FLOPPY.IBMS128.FLOPPYIOCB
(create DISKADDRESS
CYLINDER ← I
HEAD ← 0
SECTOR ← 1)
\FLOPPY.SCRATCH.BUFFER T)
))
(\FLOPPY.MESSAGE "RETRYING FORMAT")
(GO RETRY))))))
(for I from 0 to 15 do (COND
((NULL (\CFLOPPY.WRITERECORDNO I \CFLOPPYBLANKSECTOR
T))
(* Unsuccessful write. *)
(\FLOPPY.MESSAGE "RETRYING FORMAT")
(SETQ SLOWFLG T)
(GO RETRY))))))))
(CPM.DIRECTORY
(LAMBDA NIL (* edited: "23-Jul-84 15:32")
(PROG (H W FONT @FCB)
(COND
((NULL CPM.DIRECTORY.WINDOW)
(SETQ FONT (FONTCREATE (QUOTE GACHA)
8))
(SETQ H (HEIGHTIFWINDOW (ITIMES (FONTPROP FONT (QUOTE HEIGHT))
64)
T))
(SETQ W (WIDTHIFWINDOW (ITIMES (STRINGWIDTH "A" FONT)
(IPLUS 2 1 12 1 1 1 2 1 3 64))))
(SETQ CPM.DIRECTORY.WINDOW (CREATEW (GETBOXREGION W H)
"CPM DIRECTORY WINDOW"))
(DSPFONT FONT CPM.DIRECTORY.WINDOW)
(WINDOWPROP CPM.DIRECTORY.WINDOW (QUOTE REPAINTFN)
(QUOTE (CPM.DIRECTORY))))
(T (OPENW CPM.DIRECTORY.WINDOW)))
(CLEARW CPM.DIRECTORY.WINDOW)
(for I from 0 to 63
do (SETQ @FCB (\ADDBASE \CFLOPPYDIRECTORY (ITIMES 16 I)))
(printout CPM.DIRECTORY.WINDOW .I2 I .TAB0 3 (COND
((IEQP (CHCON1 (fetch (@FCB FILENAME) of @FCB))
CPMDELETEMARK)
"********.***")
(T (fetch (@FCB FILENAME) of @FCB)))
.TAB0 16 (SELECT (fetch (@FCB ET) of @FCB)
(CPMDELETEMARK " ")
(CPMFILEMARK "F")
"?")
.I3
(fetch (@FCB EXTENT) of @FCB)
.I4
(fetch (@FCB RECORDCOUNT) of @FCB)
.I4
(fetch (@FCB \DISKMAP0) of @FCB)
.I4
(fetch (@FCB \DISKMAP1) of @FCB)
.I4
(fetch (@FCB \DISKMAP2) of @FCB)
.I4
(fetch (@FCB \DISKMAP3) of @FCB)
.I4
(fetch (@FCB \DISKMAP4) of @FCB)
.I4
(fetch (@FCB \DISKMAP5) of @FCB)
.I4
(fetch (@FCB \DISKMAP6) of @FCB)
.I4
(fetch (@FCB \DISKMAP7) of @FCB)
.I4
(fetch (@FCB \DISKMAP8) of @FCB)
.I4
(fetch (@FCB \DISKMAP9) of @FCB)
.I4
(fetch (@FCB \DISKMAP10) of @FCB)
.I4
(fetch (@FCB \DISKMAP11) of @FCB)
.I4
(fetch (@FCB \DISKMAP12) of @FCB)
.I4
(fetch (@FCB \DISKMAP13) of @FCB)
.I4
(fetch (@FCB \DISKMAP14) of @FCB)
.I4
(fetch (@FCB \DISKMAP15) of @FCB))))))
)
(PUTPROPS CPMPATCH COPYRIGHT ("Xerox Corporation" 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (12131 69303 (\CFLOPPY.GET.FCB.FILENAME 12141 . 12847) (\CFLOPPY.SET.FCB.FILENAME 12849
. 13291) (\CFLOPPY.INIT 13293 . 15199) (\CFLOPPY.OPEN 15201 . 15938) (\CFLOPPY.OPEN.DIRECTORY 15940
. 19192) (\CFLOPPY.OPENFILE 19194 . 21429) (\CFLOPPY.OPENFILE1 21431 . 22957) (\CFLOPPY.OPENOLDFILE
22959 . 25112) (\CFLOPPY.OPENNEWFILE 25114 . 26303) (\CFLOPPY.ASSURESTREAM 26305 . 26771) (
\CFLOPPY.GETFILEINFO 26773 . 27401) (\CFLOPPY.GETFILEINFO1 27403 . 28111) (\CFLOPPY.SETFILEINFO 28113
. 28793) (\CFLOPPY.CLOSEFILE 28795 . 29165) (\CFLOPPY.CLOSEFILE1 29167 . 30171) (\CFLOPPY.DELETEFILE
30173 . 31437) (\CFLOPPY.GETFILENAME 31439 . 32250) (\CFLOPPY.DIRECTORYNAMEP 32252 . 32413) (
\CFLOPPY.GENERATEFILES 32415 . 34018) (\CFLOPPY.NEXTFILEFN 34020 . 35103) (\CFLOPPY.FILEINFOFN 35105
. 35460) (\CFLOPPY.RENAMEFILE 35462 . 37209) (\CFLOPPY.STREAMS.AGAINST 37211 . 37762) (
\CFLOPPY.STREAMS.USING 37764 . 38231) (\CFLOPPY.READPAGES 38233 . 38541) (\CFLOPPY.READPAGE 38543 .
39792) (\CFLOPPY.PHYSICAL.RECORDNO 39794 . 40658) (\CFLOPPY.READRECORDNO 40660 . 41381) (
\CFLOPPY.WRITERECORDNO 41383 . 42103) (\CFLOPPY.RECORDNOTODISKADDRESS 42105 . 42927) (\CFLOPPY.DIR.GET
42929 . 44038) (\CFLOPPY.DIR.PUT 44040 . 45492) (\CFLOPPY.DIR.REMOVE 45494 . 46695) (
\CFLOPPY.WRITEPAGES 46697 . 47009) (\CFLOPPY.WRITEPAGE 47011 . 47929) (\CFLOPPY.TRUNCATEFILE 47931 .
49815) (\CFLOPPY.ALLOCATE.FCB 49817 . 50752) (\CFLOPPY.ALLOCATE.GROUP 50754 . 51303) (
\CFLOPPY.ALLOCATE 51305 . 53677) (\CFLOPPY.TRUNCATE 53679 . 56277) (\CFLOPPY.DEALLOCATE 56279 . 57305)
(\CFLOPPY.EXTEND 57307 . 59473) (\CFLOPPY.SAVE.CHANGES 59475 . 61582) (\CFLOPPY.ICHECK 61584 . 63701)
(\CFLOPPY.ICHECK.CALLOC 63703 . 64469) (\CFLOPPY.FREE.PAGES 64471 . 64821) (\CFLOPPY.FORMAT 64823 .
66967) (CPM.DIRECTORY 66969 . 69301)))))
STOP