!***********************************************************************
!*
!* Program to read files from a TRIPOS tape
!*
!* Copyright (C) R.D. Eager University of Kent MCMLXXXIII
!*
!***********************************************************************
!
constantinteger version = 2; ! Major version number
constantinteger edit = 1; ! Edit number within major version
!
!***********************************************************************
!*
!* Constants
!*
!***********************************************************************
!
constantinteger no = 0, yes = 1
constantinteger sscharfiletype = 3; ! Subsystem file type
constantinteger blksize = 800; ! Size of tape blocks
constantinteger chan = 1; ! Channel for tape operations
constantinteger maxaction = 5
constantbyteintegerarray actions(1:maxaction) = c
'E','P','H','L','V'
constantbyteintegerarray monc(0:11) = c
31,28,31,30,31,30,31,31,30,31,30,31
constantstring (1) snl = "
"
constantstring (3)array mons(0:11) = c
"Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep","Oct","Nov","Dec"
!
!
!***********************************************************************
!*
!* Record and array formats
!*
!***********************************************************************
!
recordformat hf(integer dataend,datastart,filesize,filetype,c
sum,datetime,format,records)
recordformat rf(integer conad,filetype,datastart,dataend)
!
!
!***********************************************************************
!*
!* Subsystem references
!*
!***********************************************************************
!
systemroutinespec changefilesize(string (31) file,
integer newsize,integername flag)
systemroutinespec connect(string (31) file,integer mode,hole,
prot,record (rf)name r,integername flag)
externalstringfunctionspec date
systemroutinespec destroy(string (31) file,integername flag)
systemroutinespec disconnect(string (31) file,integername flag)
systemstringfunctionspec failuremessage(integer mess)
systemstringfunctionspec itos(integer n)
systemroutinespec modpdfile(integer ep,string (31) pdfile,
string (11) member,string (31) infile,
integername flag)
systemroutinespec move(integer length,from,to)
systemstringfunctionspec nexttemp
systemroutinespec outfile(string (31) file,integer size,hole,
prot,integername conad,flag)
externalintegerfunctionspec outpos
systemintegerfunctionspec parmap
externalroutinespec prompt(string (255) s)
systemintegerfunctionspec pstoi(string (63) s)
systemroutinespec setpar(string (255) s)
externalroutinespec set return code(integer i)
systemstringfunctionspec spar(integer n)
externalstringfunctionspec time
systemroutinespec trim(string (31) file,integername flag)
systemroutinespec uctranslate(integer ad,len)
!
externalroutinespec define(string (255) s)
!
!
!***********************************************************************
!*
!* Magnetic tape interface routines
!*
!***********************************************************************
!
externalroutinespec askmag(integer channel,string (7) vol,
integername flag)
externalroutinespec readmag(integer channel,ad,integername len,flag)
externalroutinespec rewindmag(integer channel)
externalroutinespec skipmag(integer channel,n)
externalroutinespec skiptmmag(integer channel,n)
externalroutinespec unloadmag(integer channel)
!
!
!***********************************************************************
!*
!* Own variables
!*
!***********************************************************************
!
owninteger masktype; ! Used to record type of current mask
!
!
!***********************************************************************
!*
!* Service routines
!*
!***********************************************************************
!
stringfunction specmessage(integer n)
switch sw(1000:1000)
!
-> sw(n)
!
sw(1000): result = "Failed to claim tape"
end ; ! of specmessage
!
!
routine fail(integer n)
string (255) s
!
selectoutput(0)
if n < 1000 then s = failuremessage(n) else s = specmessage(n)
printstring(snl."TRIPOSMT fails -".s)
unloadmag(chan)
set return code(n)
stop
end ; ! of fail
!
!
routine reset
rewindmag(chan)
skipmag(chan,1)
end ; ! of reset
!
!
routine skiptm(integer n)
integer i
!
for i = 1,1,n cycle
skiptmmag(chan,1)
repeat
end ; ! of skiptm
!
!
routine readline(stringname s)
integer c
!
s = ""
cycle
cycle
readsymbol(c)
exit if c = nl
s <- s.tostring(c)
repeat
while length(s) > 0 and charno(s,length(s)) = ' ' cycle
length(s) = length(s) - 1
repeat
exit unless s = ""
repeat
uctranslate(addr(s)+1,length(s))
end ; ! of readline
!
!
integerfunction match(string (63) s,mask)
! masktype = 0 before initialisation,
! 1 for *A*,
! 2 for *A,
! 3 for A* or A*B,
! 4 for A
ownstring (15) masks,maskt
string (63) work1,work2
switch typ(1:4)
!
result = yes if mask = "*" or mask = ""
! Common case
if masktype = 0 then start ; ! First time in for this mask - analyse it
if mask -> work1.("*").masks and work1 = "" then start
if charno(masks,length(masks)) = '*' then start
maskt = substring(masks,1,length(masks)-1)
masktype = 1
finish else start
maskt = masks
masktype = 2
finish
finish else start
if mask -> masks.("*").maskt then start
masktype = 3
finish else masktype = 4
finish
finish
!
-> typ(masktype)
!
typ(4):
if mask = s then result = yes else result = no
!
typ(3):
unless s -> work1.(masks).s and work1 = "" then result = no
if maskt = "" then result = yes
!
typ(2):
typ(1):
unless s -> work1.(maskt).work2 then result = no
if masktype = 1 then result = yes
while s -> work1.(maskt).work2 cycle
if work2 = "" then result = yes
s = substring(s,length(work1)+2,length(s))
repeat
result = no
end ; ! of match
!
!
integerfunction checkswitch(integer c)
integer i
!
for i = 1,1,maxaction cycle
if c = actions(i) then result = i
repeat
result = -1
end ; ! of checkswitch
!
!
routine getcommand(integername type,stringname srce,dest)
integer l
string (63) line
string (255) work1,work2
!
type = 0
readline(line)
line = work1.work2 while line -> work1.(" ").work2
l = length(line)
if l >= 2 then start
if charno(line,l-1) = '/' then start
type = checkswitch(charno(line,l))
length(line) = l - 2
finish
finish
if line -> work1.("/").work2 then start
type = -1
return
finish
!
if line -> work1.("=").work2 then start
dest <- work1
srce <- work2
finish else start
dest = ""
srce <- line
finish
end ; ! of getcommand
!
!
integerfunction wild(string (31) s)
if s -> ("*") then result = yes
result = no
end ; ! of wild
!
!
stringfunction tdate(integer n)
integer year,month,m
string (2) y
string (9) s
!
year = n//1000
n = n - year*1000
month = 0
cycle
m = monc(month)
if month = 1 and year//4*4 = year then m = m + 1
exit if n <= m
month = month + 1
n = n - m
repeat
s = itos(n)
y = itos(year)
if length(y) = 1 then y = "0".y
if length(s) = 1 then s = "0".s
result = s."-".mons(month)."-".y
end ; ! of tdate
!
!
routine printhelp
printstring("
Program call is: TRIPOSMT(tape[,commands])
Command format is: destination=source/switch
where one or two items may be null.
")
printstring("
File specs are: up to 17 alphanumeric characters
where an asterisk is also allowed, denoting a 'wild'
component that matches any substring.
")
printstring("
Switches are: /E - exit from TRIPOSMT.
/P - set current pdfile.")
printstring("
/H - print this help text.
/L - give a directory of all or part of the tape.
/V - display version number of TRIPOSMT.
")
end ; ! of printhelp
!
!
routine directory(stringname mask)
integer ad,len,flag,i,adw,blocks,files,wildcard
string (255) work
byteintegerarray buf(0:blksize-1)
!
ad = addr(buf(0))
adw = addr(work) + 1
!
rewindmag(chan)
len = blksize
readmag(chan,ad,len,flag)
if flag # 0 then start
if flag = 1 then printstring("?Unexpected tape mark".snl) else c
printstring("?Tape read error".snl)
reset
return
finish
move(6,ad+4,adw)
length(work) = 6
while charno(work,length(work)) = ' ' cycle
length(work) = length(work) - 1
repeat
printstring(snl."Directory mt:".work." on ")
printstring(date." at ".time.snl.snl)
!
wildcard = wild(mask)
files = 0
blocks = 0
cycle
len = blksize
readmag(chan,ad,len,flag)
exit if flag = 1; ! Final tape mark
if flag > 1 then start
printstring("?Tape read error".snl)
reset
return
finish
move(4,ad,addr(i))
if i # m'HDR1' then start
printstring("?HDR1 not found when expected".snl)
reset
return
finish
length(work) = 17
move(17,ad+4,adw)
for i = 17,-1,1 cycle
if charno(work,i) # ' ' then exit
length(work) = length(work) - 1
repeat
if match(work,mask) = no then start
skiptm(3)
continue
finish
printstring(work)
files = files + 1
printstring("/".itos(files))
spaces(24-outpos)
skiptm(2)
len = blksize
readmag(chan,ad,len,flag)
move(4,ad,addr(i))
if i # m'EOF1' then start
printstring("?EOF1 not found where expected".snl)
reset
return
finish
move(6,ad+54,adw)
length(work) = 6
i = pstoi(work); ! Number of blocks
blocks = blocks + i
write(i,3)
printstring(" Block")
if i = 1 then space else printsymbol('s')
space
move(5,ad+42,adw)
length(work) = 5
printstring(tdate(pstoi(work)).snl)
exit if wildcard = no
skiptmmag(chan,1)
repeat
!
printstring(snl."Total of ".itos(blocks)." block")
printsymbol('s') unless blocks = 1
printstring(" in ".itos(files)." file")
printsymbol('s') unless files = 1
newlines(2)
end ; ! of directory
!
!
routine transfer(stringname srce,dest,pdfile)
integer i,pd,rewound,ad,len,flag,ptr,conad,adt,wildcard
string (11) name
string (31) out,temp
byteintegerarray buf(0:blksize-1)
record (rf) rr
record (hf)name r
!
dest = "*" if dest = ""
ad = addr(buf(0))
adt = addr(temp) + 1
if wild(srce) = yes then start
wildcard = yes
reset
rewound = yes
finish else start
wildcard = no
rewound = no
finish
!
cycle
len = blksize
readmag(chan,ad,len,flag)
if flag > 1 then start
printstring("?Tape read error".snl)
reset
return
finish
if flag = 1 then start ; ! Final tape mark
reset
if rewound = no then start
rewound = yes
continue
finish
if wildcard = no then printstring("?File not found".snl)
return
finish
move(4,ad,addr(i))
if i # m'HDR1' then start
printstring("?HDR1 not found when expected".snl)
reset
return
finish
length(temp) = 17
move(17,ad+4,adt)
for i = 17,-1,1 cycle
if charno(temp,i) # ' ' then exit
length(temp) = length(temp) - 1
repeat
if match(temp,srce) = no then start
skiptm(3)
continue
finish
!
skiptmmag(chan,1); ! Skip to just before first data block
name <- temp
if wildcard = yes then start
printstring("[".name."]".snl)
finish
if wild(dest) = yes then out = name else out = dest
if pdfile # "" then start
out = "T#".nexttemp
pd = yes
finish else pd = no
outfile(out,4096,0,0,conad,flag)
if flag # 0 then start
printstring("%".failuremessage(flag))
skiptm(2)
continue
finish
r == record(conad)
r_filetype = sscharfiletype
ptr = r_dataend
!
cycle
len = blksize
readmag(chan,ad,len,flag)
if flag > 1 or (flag = 0 and len # blksize) then start
printstring("?Tape read error".snl)
destroy(out,flag)
reset
return
finish
if flag = 1 then exit ; ! End of file
len = halfinteger(ad+blksize-2)
if ptr + len >= r_filesize then start
i = (r_filesize+131072) & (¬131071)
changefilesize(out,i,flag)
if flag = 261 then start ; ! VM hole too small
disconnect(out,flag)
changefilesize(out,i,flag)
if flag = 0 then connect(out,3,0,0,rr,flag)
if flag = 0 then start
conad = rr_conad
r == record(conad); ! Re-map - it may have moved
finish
finish
if flag # 0 then start
printstring("?".failuremessage(flag))
skiptm(2)
return
finish
r_filesize = i
finish
move(len,ad,conad+ptr)
ptr = ptr + len
repeat
!
r_dataend = ptr
trim(out,flag)
skiptmmag(chan,1)
!
if pd = yes then start
connect(pdfile,0,0,0,rr,flag)
if flag = 218 then start ; ! Create pdfile
modpdfile(4,pdfile,"","",flag)
if flag # 0 then start
printstring("?".failuremessage(flag))
return
finish
finish
name = dest if wild(dest) = no
modpdfile(2,pdfile,name,"",flag); ! Delete any existing member of same name
modpdfile(1,pdfile,name,out,flag);! Insert new member
if flag # 0 then start
printstring("?".failuremessage(flag))
return
finish
destroy(out,flag)
finish else start
disconnect(out,flag)
finish
unless wildcard = yes then exit
repeat
end ; ! of transfer
!
!
!***********************************************************************
!*
!* T R I P O S M T
!*
!***********************************************************************
!
externalroutine triposmt(string (255) parms)
integer flag,type
string (6) vol
string (11) pdfile
string (31) input,srce,dest
switch sw(0:maxaction)
!
set return code(9999)
setpar(parms)
if parmap > 3 then fail(263); ! Wrong number of parameters
vol <- spar(1)
input <- spar(2)
if vol = "" then fail(263); ! Wrong number of parameters
if input = "" then input = ".IN"
define("1,".input)
selectinput(1)
!
askmag(chan,vol,flag)
if flag # 0 then fail(1000); ! Failed to claim tape
reset
!
pdfile = ""
prompt("*")
cycle
masktype = 0
getcommand(type,srce,dest)
if type < 0 or (type = 0 and srce = "") then start
printstring("?Illegal command".snl)
continue
finish
-> sw(type)
!
sw(0):
transfer(srce,dest,pdfile)
continue
!
sw(1): ! /E
exit
!
sw(2): ! /P
pdfile <- srce
if dest # "" then start
printstring("%File ".dest." ignored".snl)
finish
continue
!
sw(3): ! /H
unless srce = "" = dest then start
printstring("%Files ignored".snl)
finish
printhelp
continue
!
sw(4): ! /L
if dest # "" then start
printstring("%File ".dest." ignored".snl)
finish
if srce = "" then srce = "*"
directory(srce)
reset
continue
!
sw(5): ! /V
unless srce = "" = dest then start
printstring("%Files ignored".snl)
finish
printstring("Version: E".itos(version).".".itos(edit).snl)
continue
repeat
!
unloadmag(chan)
set return code(0)
end ; ! of triposmt
endoffile