|| (C) Copyright 1979 Tripos Research Group
|| University of Cambridge
|| Computer Laboratory
|| Disc Editor for TRIPOS
|| For version 2 of the filing system (Jan 1979)
|| Intel 8086 version for MDS 721 floppy discs
SECTION "Disced1"
GET "DISCED"
LET start(zero.or.packet) BE
$(
LET match = ?
LET temp = ?
LET currword = 0
TEST zero.or.packet \= 0 THEN
$( qpkt(zero.or.packet)
initio()
selectinput(findinput("**"))
selectoutput(findoutput("**"))
$)
ELSE
UNTIL (ch = '*N') | (ch = '*E') | (ch = ';')
DO ch := rdch()
// Initialization of 'file-handler' globals
size.block := 256
sector.origin := 0
n.surfaces := 1
n.sectorsperblock := 1
n.blockspertrack := 13
n.reservedblocks := 1
preallocationfactor := 8
interleavefactor := 1
lowercylinder := 15
uppercylinder := 76
n.blockspercylinder := n.blockspertrack*n.surfaces
keylowerbound := n.reservedblocks
keyupperbound := [uppercylinder-lowercylinder+1]*
n.blockspercylinder-1
n.blocks := keyupperbound-keylowerbound+1
rootkey := [keyupperbound+keylowerbound]/2
b.file.secondarytype := size.block-1
b.file.infobits := size.block-2
b.file.parentdir := size.block-3
b.file.hashchain := size.block-4
b.file.filename := size.block-20
b.file.creationdate := size.block-23
b.file.infobase := size.block-50
b.dir.hashtablelimit := b.file.infobase-1
size.hashtable := b.dir.hashtablelimit+1-b.dir.hashtablebase
size.fcb := fcb.xvec+preallocationfactor+2
size.bitmap := [n.blocks-1]/bitsperword+1
writes("TRIPOS (floppy) Disc Editor version 2.0*N")
// Code to get cylinder count right on floppies
FOR z=0 TO ndrives-1
DO $(
sendpkt(notinuse, dddevid, act.seek, ?, ?, ?, ?, z, 2)
sendpkt(notinuse, dddevid, act.seek, ?, ?, ?, ?, z, -80)
$)
block.read := FALSE
style := " %N "
drive := 0
cyl, sur, sec := -1, -1, -1
cylbase := LowerCylinder
write.protected := TRUE
writef("Write protect mode set*N*
*Cylinder base set to %N*N",
cylbase)
lbnbase := 0
lbn := -1
stringstyle := FALSE
charstyle := FALSE
mask, pattern := -1, 0
nullnumber := FALSE
blockbuff := getvec(size.block - 1)
IF blockbuff = 0
THEN $( WRITES("No space for buffer*N"); STOP(20) $)
blockwrittenback := TRUE
writes("# *E")
$( || Main loop
ch := rdch()
SWITCHON capitalch(ch) INTO
$(
CASE '*E': newline()
CASE '*N': writes("# *E")
ENDCASE
CASE '*S': ENDCASE
CASE 'B': || Reset logical block
|| number base
temp := readvalue()
UNLESS 0 <= temp < nblocks
THEN
$(
writes(" Silly value %N*N",
temp)
ENDCASE
$)
lbnbase := temp
writef(" Logical block number *
*base set to %N*N", lbnbase)
ENDCASE
CASE 'C': || Print n characters
check.block.read()
writes(" '")
FOR j = 0 TO readvalue() - 1
DO wrch(getbyte(blockbuff+currword,j))
writes("'*N")
ENDCASE
CASE 'D': || Set the disc drive number
temp := readvalue()
UNLESS 0 <= temp < ndrives
THEN
$(
writef(" Silly drive number %N*N",
temp)
ENDCASE
$)
drive := temp
writef(" Drive %N selected*N",drive)
ENDCASE
CASE 'G': || Get block from disc
$(
LET oldlbn = lbn
LET addrok = readdiscaddr()
LET newlbn = lbn
UNLESS blockwrittenback | NOT block.read
THEN
$(
writes(" Last block not *
*yet written back!!*N*
* Type N if you do not *
*want it updated *E")
UNTIL rdch()='*N' LOOP
temp := rdch()
UNLESS (temp='N') | (temp='n')
THEN
$(
unrdch()
lbn := oldlbn
convertdiscaddr(oldlbn+lbnbase)
UNLESS discaction(act.write)
THEN ENDCASE
lbn := newlbn
convertdiscaddr(newlbn+lbnbase)
$)
$)
IF addrok
THEN discaction(act.read)
$)
ENDCASE
CASE 'H': || Calculate hash value given
|| string
$(
LET s = VEC filenameupb+1
LET p = 0
LET h = 0
skiplayout()
ch := rdch()
IF ch = '"' THEN ch := readchar()
UNTIL (ch = '*N') | (ch = '"') |
(ch = ' ') | (p=filenameupb)
DO
$(
p := p + 1
s!p := capitalch(ch)
ch := rdch()
$)
IF ch = '*N' THEN unrdch()
h := p
FOR z = 1 TO p
DO h := (h*13 + s!z) & #X7FF
writef(" Hash value = %N*N",
B.Dir.HashTableBase +
(h REM Size.HashTable))
ENDCASE
$)
CASE 'I': || Print file info
|| Print the information in the
|| first few words of the block
$(
LET type = blockbuff ! B.File.Type
LET data.block = ?
check.block.read()
IF (type & T.Deleted) \= 0
THEN writes(" Deleted")
type := type & (NOT T.deleted)
writef(" %S*N", VALOF
SWITCHON type
INTO
$(
CASE T.Long:
RESULTIS "Long file"
CASE T.Short:
RESULTIS "Short file"
CASE T.Data:
RESULTIS "Data block"
CASE T.List:
RESULTIS "List"
DEFAULT:
RESULTIS "Corrupt type"
$)
)
data.block := type = T.Data
writef(" Header key: %N*N",
blockbuff ! B.File.Headerkey)
TEST data.block
THEN writes(" Sequence number: ")
ELSE writes(" Highest seq num: ")
writef("%N*N",
blockbuff ! B.File.HighestSeq)
writef(" Data size: %N*N",
blockbuff ! B.File.Datasize)
TEST data.block
THEN writes(" Next data block: ")
ELSE writes(" First data block: ")
writef("%N*N",
blockbuff ! B.File.FirstDataKey)
writef(" Checksum: %N*N",
blockbuff ! B.File.Checksum)
UNLESS data.block
THEN
$(
LET datvec = VEC 14
writef(" Secondary type: %S*N",
VALOF SWITCHON blockbuff!B.File.Secondarytype
INTO
$(
CASE ST.File: RESULTIS "File"
CASE ST.Root: RESULTIS "Root block"
CASE ST.UserDirectory:
RESULTIS "User directory"
DEFAULT: RESULTIS "(Unset)"
$) )
writef(" Info bits: #X%X4*N",
blockbuff ! B.File.Infobits)
writef(" Parent Directory: %N*N",
blockbuff ! B.File.ParentDir)
writef(" Hash Chain: %N*N",
blockbuff ! B.File.HashChain)
writef(" Filename: *"%S*"*N",
blockbuff + B.File.Filename)
IF zero.or.packet = 0
THEN
$( // Running as command
callseg(":L.dat-to-strings",
blockbuff+B.File.CreationDate,
datvec)
writef(" Created: %S %S %S*N",
datvec+10, datvec, datvec+5)
$)
$)
$)
ENDCASE
CASE 'K': || Calculate and check checksum
check.block.read()
$(
LET cs = block.checksum()
TEST cs = 0
THEN writes(" Checksum correct*N")
ELSE
$(
LET bad.cs = blockbuff ! B.File.Checksum
LET correct.cs = 0-(cs-bad.cs)
blockbuff ! B.File.Checksum := correct.cs
writef(" Checksum incorrect*N*
* Value in block was %N*N*
* Corrected to %N*N",
bad.cs, correct.cs)
blockwrittenback := FALSE
$)
ENDCASE
$)
CASE 'L': || Locate words which match
|| pattern under mask
match := TRUE
search: $(
LET lwb = readvalue()
LET upb = size.block - 1
LET maskedpat = mask & pattern
check.block.read()
skiplayout()
UNLESS nullnumber
THEN
$(
UNLESS 0 <= lwb < size.block
THEN
$(
writes(" Invalid lower *
*bound*N")
lwb := 0
$)
upb := readvalue()
UNLESS 0 <= upb < size.block
THEN
$(
writes(" Invalid upper *
*bound*N")
upb := size.block - 1
$)
$)
FOR j = lwb TO upb
DO
$(
LET v = blockbuff ! j
IF TESTFLAGS(1) BREAK
IF ((v & mask) = maskedpat) = match
THEN
$(
writef(" %I3:", j)
printloc(j)
$)
$)
$)
ENDCASE
CASE 'M': || Set locate mask
mask := readvalue()
ENDCASE
CASE 'N': // Locate words which don't
// match pattern under mask
match := false
GOTO SEARCH
CASE 'P': || Put block back on disc
IF readdiscaddr()
THEN discaction(act.write)
ENDCASE
CASE 'Q': || Quit
freevec(blockbuff)
RETURN
CASE 'R': || Identify Root Block
writef(" Root Block is block %N*N",
RootKey)
ENDCASE
CASE 'S': || Set printing style
stringstyle := FALSE
charstyle := FALSE
style := VALOF
SWITCHON capitalch(rdch())
INTO
$(
CASE 'C': charstyle := TRUE
RESULTIS style
CASE 'S': stringstyle := TRUE
RESULTIS style
CASE 'O': RESULTIS " %O6 "
CASE 'X': RESULTIS " %X4 "
CASE 'D': RESULTIS " %N "
DEFAULT: writes(" Try c,s,o*
*,x or d*N")
RESULTIS style
$)
printloc(currword)
ENDCASE
CASE 'T': || Type range of locations
$(
LET lwb = readvalue()
LET upb = readvalue()
check.block.read()
IF nullnumber
THEN upb := lwb
FOR j = lwb TO upb
DO
$(
IF TESTFLAGS(1) BREAK
writef(" %I3: ", j)
printloc(j)
$)
$)
ENDCASE
CASE 'V': || Set value for locate
pattern := readvalue()
ENDCASE
CASE 'W': || Windup
UNLESS blockwrittenback
THEN UNLESS discaction(act.write)
THEN ENDCASE
freevec(blockbuff)
RETURN
CASE 'X': || Invert write protect mode
write.protected := NOT write.protected
writef(" Write protect mode %Sset*N",
write.protected -> "","un")
ENDCASE
CASE 'Y': || Set cylinder base
temp := readvalue()
UNLESS 0 <= temp <= maxcyl
THEN
$(
writef("Value should be in range*
* 0 to %N*N", maxcyl)
ENDCASE
$)
cylbase := temp
writef(" Cylinder base set to %N*N", cylbase)
ENDCASE
CASE 'Z': || Zero buffer
FOR i = 0 TO size.block - 1 DO
blockbuff ! i := 0
ENDCASE
CASE '-': CASE '+': CASE '#':
CASE '0': CASE '1': CASE '2':
CASE '3': CASE '4': CASE '5':
CASE '6': CASE '7': CASE '8':
CASE '9': || Read the offset in the buffer
|| of the new current word
$(
LET n = ?
unrdch()
n := readvalue()
IF (n < 0) | (n >= size.block)
THEN
$(
writef(" Offset %N invalid*N", n)
ENDCASE
$)
currword := n
$)
ENDCASE
CASE '=': || Print default values set
writef(" Disc drive %N*N",drive)
writef(" Block number %N: cyl %N,*
* sur %N, sec %N*N", lbn, cyl,
sur, sec)
writef(" Cylinder base = %N*N*
* Write protect mode is %Sset*N*
* Current block is %Sup to date*
* on disc*N",
cylbase,
write.protected -> "", "not ",
(blockwrittenback -> "", "not ") )
writef(" Current word offset = *
*%N*N", currword)
writef(" Logical block number *
*base = %N*N", lbnbase)
ENDCASE
CASE '/': || Open location
$(
LET v = readvalue()
check.block.read()
TEST nullnumber
THEN printloc(currword)
ELSE
$(
blockbuff ! currword := v
blockwrittenback := FALSE
$)
$)
ENDCASE
CASE '*'': || Row of characters
$(
LET stringbase = currword*bytesperword
LET boffset = stringbase
LET bofflim = size.block * bytesperword
check.block.read()
ch := readchar()
UNTIL (ch = '*'')
DO
$(
IF boffset >= bofflim
THEN
$(
writes(" Attempt to *
*overflow block*N")
BREAK
$)
putbyte(blockbuff, boffset, ch)
boffset := boffset + 1
ch := readchar()
$)
$)
blockwrittenback := FALSE
ENDCASE
CASE '"': || String
$(
LET stringbase = currword*bytesperword
LET boffset = stringbase + 1
LET bofflim = size.block * bytesperword
check.block.read()
ch := readchar()
UNTIL (ch = '"')
DO
$(
IF boffset >= bofflim
THEN
$(
writes(" Attempt to overflow*
* block*N")
BREAK
$)
putbyte(blockbuff, boffset, ch)
boffset := boffset + 1
ch := readchar()
$)
|| Fill in the length
putbyte(blockbuff,stringbase,
boffset-1-stringbase)
$)
blockwrittenback := FALSE
ENDCASE
CASE '?': writes(" See file :Doc.DiscedSpec*
* for a list of commands *
*available*N")
ENDCASE
unknown:
DEFAULT: writef(" Unknown command %C*N", ch)
ch := rdch() REPEATUNTIL ch = '*N'
unrdch()
$)
$) REPEAT
$)
.
SECTION "Disced2"
GET "DISCED"
LET skiplayout() BE
$(
LET c = rdch()
WHILE (c = ' ') | (c = '*T')
DO c := rdch()
unrdch()
$)
AND printloc(offset) BE
$(
IF (offset < 0) | (offset >= size.block)
THEN
$(
writef(" Offset %N invalid*N", offset)
RETURN
$)
TEST stringstyle
THEN writef(" *"%S*" *N", blockbuff + offset)
ELSE
TEST charstyle
THEN
$(
writes(" '")
FOR j = 0 TO bytesperword-1
DO wrch(getbyte(blockbuff+offset, j))
writes("' *N")
$)
ELSE
$(
writef(style, blockbuff ! offset,
(blockbuff!offset) >> 8)
newline()
$)
$)
AND discaction(action) = VALOF
$(
|| Does a disc read or write as specified by action,
|| using blockbuff. The disc address is given by the
|| globals cyl, sur and sec.
LET s = ?
IF action = act.write
THEN
$(
IF block.checksum() \= 0
THEN writes(" ******Warning - *
*block has incorrect *
*checksum*N")
IF write.protected
THEN
$( writes(" Write protect mode is set: block*
* not written back*N")
RESULTIS FALSE
$)
$)
UNLESS 0 <= cyl <= maxcyl
THEN
$(
writef(" Cylinder %N is out of range*N", cyl)
RESULTIS FALSE
$)
FOR r = 1 TO 10
DO
$(
s := sendpkt(notinuse,dddevid,action,?,?,
blockbuff,size.block,drive,cyl,sur,sec)
IF s = 0
THEN
$(
IF r > 2
THEN writef(" %N tries needed to transfer*
* cyl %N, sur %N, sec %N*N",
r, cyl, sur, sec)
IF action = act.read
THEN block.read := TRUE
blockwrittenback := TRUE
writef(" Block %N %S (cyl %N, sur %N, sec %N)*N",
lbn, (action=act.write-> "updated","read"),
cyl, sur, sec)
RESULTIS TRUE
$)
$)
writef(" Transfer failed: cyl %N, sur %N, sec %N*
*, status %X4, error %X4*N",cyl,sur,sec,result2,s)
RESULTIS FALSE
$)
AND readdiscaddr() = VALOF
$(
|| Reads a new disc address.
|| There are 2 possible cases:
|| (a) No numbers after the command - keep
|| the current address
||
|| (b) A new block number is specified.
|| Set globals cyl, sur and sec from it.
||
|| Exits with lbn, cyl, sur and sec set. Returns
|| TRUE if the address is valid, FALSE if an
|| error is detected.
LET val = readvalue()
UNLESS nullnumber
THEN $( lbn := val; skiplayout() $)
UNLESS convertdiscaddr(lbn+lbnbase)
THEN RESULTIS FALSE
RESULTIS TRUE
$)
AND readchar() = VALOF
$(
|| Returns the next character, after interpreting
|| escape combinations
|| If the character is the result of an escape
|| combination, then bit #X100 is set in the
|| result. This is so that unescaped quotes
|| can be detected by the caller.
ch := rdch()
TEST ch = '**'
THEN
$(
ch := capitalch( rdch() )
SWITCHON ch INTO
$(
CASE '**':RESULTIS '**' | escbit
CASE '*'':RESULTIS '*'' | escbit
CASE '*"':RESULTIS '*"' | escbit
CASE 'N': RESULTIS '*N' | escbit
CASE 'E': RESULTIS '*E' | escbit
CASE 'S': RESULTIS '*S' | escbit
CASE 'T': RESULTIS '*T' | escbit
CASE 'B': RESULTIS '*B' | escbit
CASE 'X': || Read 2 digit hex value
RESULTIS ((hexval(rdch()) << 4) +
hexval(rdch())) | escbit
CASE '0': CASE '1': CASE '2':
CASE '3': CASE '4': CASE '5':
CASE '6': CASE '7':
|| Read a 3 digit octal value
$(
LET val = ch - '0'
FOR i = 1 TO 2
DO
$(
ch := rdch()
UNLESS '0' <= ch <= '7'
THEN
$(
writef(" Invalid octal *
*digit %C*N", ch)
BREAK
$)
val := val*8 + ch - '0'
$)
IF val > 255
THEN writef(" Value %O3 too big*N",
val)
RESULTIS val | escbit
$)
DEFAULT: writef(" Unknown escape %C*N",ch)
RESULTIS ch | escbit
$)
$)
ELSE
$(
IF (ch = '*N') | (ch = '*E')
THEN unrdch()
RESULTIS ch
$)
$)
AND hexval(c) = VALOF
$(
|| Gives the value of the hex digit c
IF '0' <= c <= '9' THEN RESULTIS c - '0'
IF 'a' <= c <= 'f' THEN RESULTIS c - 'a' + 10
IF 'A' <= c <= 'F' THEN RESULTIS c - 'A' + 10
writef(" Invalid hex digit %C*N", c)
RESULTIS 0
$)
AND convertdiscaddr(blockno) = VALOF
$(
|| Sets globals cyl sur and sec.
|| Returns TRUE if blockno is valid, FALSE otherwise.
IF (blockno >= nblocks) | (blockno < 0)
THEN
$(
writef(" Block number %N is invalid*N", blockno)
RESULTIS FALSE
$)
cyl := blockno/(N.Surfaces * N.blockspertrack) + cylbase
sur := blockno REM N.Surfaces
sec := (blockno/N.Surfaces) REM N.blockspertrack *
N.SectorsPerBlock + Sector.Origin
RESULTIS TRUE
$)
AND readvalue() = VALOF
$(
|| Reads: optionally signed decimal number
|| # octal number
|| #X hex number
|| '<single char>
nullnumber := FALSE
skiplayout()
ch := rdch()
SWITCHON ch INTO
$(
CASE '-': RESULTIS -readvalue()
CASE '+': RESULTIS readvalue()
CASE '#': ch := rdch()
TEST (ch = 'X') | (ch = 'x')
THEN RESULTIS readhexnum()
ELSE
$(
unrdch()
RESULTIS readoctnum()
$)
CASE '*'':RESULTIS rdch()
CASE '0': CASE '1': CASE '2':
CASE '3': CASE '4': CASE '5':
CASE '6': CASE '7': CASE '8':
CASE '9': unrdch()
RESULTIS readn()
DEFAULT: nullnumber := TRUE
unrdch()
RESULTIS 0
$)
$)
AND readhexnum() = VALOF
$(
LET val = 0
ch := rdch()
UNLESS ('0' <= ch <= '9') |
('A' <= capitalch(ch) <= 'F')
THEN nullnumber := TRUE
WHILE ('0' <= ch <= '9') |
('A' <= capitalch(ch) <= 'F')
DO
$(
val := (val << 4) + hexval(ch)
ch := rdch()
$)
unrdch()
RESULTIS val
$)
AND readoctnum() = VALOF
$(
LET val = 0
ch := rdch()
UNLESS '0' <= ch <= '7'
THEN nullnumber := TRUE
WHILE ('0' <= ch <= '7')
DO
$(
val := (val << 3) + ch - '0'
ch := rdch()
$)
unrdch()
RESULTIS val
$)
AND check.block.read() BE
UNLESS block.read
THEN writes("****** WARNING - No block has been*
* read into buffer!*N")
AND block.checksum() = VALOF
$(
LET cs = 0
FOR z=0 TO size.block-1
DO cs := cs + blockbuff!z
RESULTIS cs
$)