!***********************************************************************
!*
!* Program to write an ICL VME 2900 tape
!*
!* R.D. Eager University of Kent MCMLXXXIV
!*
!***********************************************************************
!
constantinteger version = 1; ! Major version number
constantinteger edit = 0; ! Edit number within major version
!
!***********************************************************************
!*
!* Constants
!*
!***********************************************************************
!
constantinteger no = 0, yes = 1
constantinteger defaultthreshold = 10
constantinteger maxthreshold = 1000
constantinteger sscharfiletype = 3; ! Subsystem file type
constantinteger ssdatafiletype = 4; ! Subsystem file type
constantinteger maxfile = 999; ! Maximum number of files per tape
constantinteger listchan = 80; ! Channel for listing of files written
constantinteger tapechan = 1
constantbyteinteger nl = 10
constantbyteintegerarray monthdays(1:11) = c
31,28,31,30,31,30,31,31,30,31,30
constantstring (1) space char = " "
constantstring (1) snl = "
"
constantstring (6) data00 = "DATA00"
constantinteger keymax = 6; ! Number of parameter keywords
constantstring (9)array keys(1:keymax) = c
"TAPE",
"STARTFILE",
"LISTING",
"UPPER",
"THRESHOLD",
"VERSION"
!
!***********************************************************************
!*
!* Record formats
!*
!***********************************************************************
!
recordformat descf(integer dr0,dr1 or c
longinteger dr)
recordformat fdf(integer link,dsnum,byteinteger status,accessroute,
valid action,cur state,mode of use,mode,file org,
dev code,rec type,flags,lm,rm,integer asvar,arec,
recsize,minrec,maxrec,maxsize,lastrec,conad,currec,
cur,end,transfers,darecnum,cursize,datastart,
string (31) iden,integer keydesc0,keydesc1,
recsizedesc0,recsizedesc1,byteinteger f77flag,
f77form,f77access,f77status,integer f77recl,f77nrec,
idaddr,byteinteger f77blank,f77ufd,spare1,spare2)
recordformat hf(integer dataend,datastart,filesize,filetype,sum,
datetime,
(integer spare1,spare2 or c { Character file }
integer format,records or c { Data file }
integer adir,count or c { Pdfile }
integer pstart,spare3 or c { Old directory file }
integer spare4,controlmode or c { Background control file }
integer lda,ofm)) { Object file }
recordformat rf(integer conad,filetype,datastart,dataend)
!
!
!***********************************************************************
!*
!* Subsystem references
!*
!***********************************************************************
!
systemroutinespec connect(string (31) file,integer mode,hole,
prot,record (rf)name r,integername flag)
externalstringfunctionspec date
systemroutinespec define(integer chan,string (31) iden,
integername afd,flag)
systemroutinespec disconnect(string (31) file,integername flag)
systemstringfunctionspec failuremessage(integer mess)
systemroutinespec fill(integer length,from,filler)
externalintegerfunctionspec instream
systemintegerfunctionspec iocp(integer ep,parm)
systemroutinespec itoe(integer ad,l)
systemstringfunctionspec itos(integer n)
systemintegermapspec mapssfd(integer dsnum)
systemroutinespec move(integer length,from,to)
externalintegerfunctionspec outpos
externalintegerfunctionspec outstream
externalroutinespec prompt(string (255) s)
systemintegerfunctionspec pstoi(string (63) s)
systemroutinespec setfname(string (63) s)
externalroutinespec set return code(integer i)
externalstringfunctionspec time
systemroutinespec uctranslate(integer ad,len)
!
!
!***********************************************************************
!*
!* Magnetic tape interface routines
!*
!***********************************************************************
!
externalroutinespec askmag(integer channel,string (7) vol,
integername flag)
externalroutinespec fskiptmmag(integer chan,n,integername flag)
externalroutinespec readmag(integer channel,ad,integername len,flag)
externalroutinespec rewindmag(integer channel)
externalroutinespec skipmag(integer channel,n)
externalroutinespec writemag(integer channel,ad,len,integername flag)
externalroutinespec writetmmag(integer chan,integername flag)
externalroutinespec unloadmag(integer channel)
!
!
!***********************************************************************
!*
!* Own variables
!*
!***********************************************************************
!
owninteger blockno; ! Number of next block to be written
!
!
!***********************************************************************
!*
!* Forward references
!*
!***********************************************************************
!
integerfunctionspec matchstrings(stringname a,string (255) b)
routinespec write label1(string (4) type,string (16) name,
integer fileno,generation,blocks)
routinespec write label2(string (4) type,integer blocksize,maxrec)
routinespec write tape mark
string (6)functionspec year and day
!
!
!***********************************************************************
!*
!* Service routines
!*
!***********************************************************************
!
routine clearstream(integer chan)
! Clears out a channel definition, but does not give an error if the
! channel was not defined.
record (fdf)name f
!
if mapssfd(chan) # 0 then start
f == record(mapssfd(chan))
if f_status = 0 then start
mapssfd(chan) = 0
f_dsnum = 0; ! Mark descriptor as free
finish
finish
end ; ! of clearstream
!
!-----------------------------------------------------------------------
!
routine closestream(integer chan)
! Private version of 'closestream'. Does not give an error if the
! operation fails.
integer flag
!
return unless instream # chan # outstream
flag = iocp(16,chan)
end ; ! of closestream
!
!-----------------------------------------------------------------------
!
routine fail(integer n)
selectoutput(0)
printstring(snl."WRITEBTAPE fails -")
printstring(failuremessage(n))
closestream(listchan)
clearstream(listchan)
set return code(n)
stop
end ; ! of fail
!
!-----------------------------------------------------------------------
!
integerfunction findkey(stringname wksp,stringarrayname keys,
integer pmax)
integer f,i
!
if length(wksp) = 0 then result = -2;! Missing keyword
f = 0
for i = 1,1,pmax cycle
if matchstrings(wksp,keys(i)) = yes then start
unless f = 0 then result = -1
f = i
finish
repeat
result = f
end ; ! of findkey
!
!-----------------------------------------------------------------------
!
integerfunction getpar(stringname wksp,param,integername parptr,parleng)
integer c,inpr
!
inpr = 0
wksp = ""
!
cycle
parptr = parptr + 1
if parptr > parleng then result = -1
c = charno(param,parptr)
if c = ',' or c = '=' then result = c
wksp = wksp.tostring(c)
repeat
end ; ! of getpar
!
!-----------------------------------------------------------------------
!
integerfunction matchstrings(stringname a,string (255) b)
integer l
!
l = length(a)
if length(b) < l then result = no
length(b) = l
if a = b then result = yes else result = no
end ; ! of matchstrings
!
!-----------------------------------------------------------------------
!
integerfunction paramdecode(string (255) param,integer pmax,
stringarrayname keys,pars)
integer i,pnum,pn,res,c,parptr,parleng
string (255) wksp
!
for i = 1,1,pmax cycle
pars(i) = ""; ! Initialise
repeat
parptr = 0
pnum = 1
parleng = length(param)
!
cycle
c = getpar(wksp,param,parptr,parleng)
res = 0
if c # '=' then start
pn = pnum
else
pn = findkey(wksp,keys,pmax)
if pn = 0 then res = 322; ! Unknown keyword
if pn = -1 then res = 321; ! Ambiguous keyword
if pn = -2 then res = 325; ! Missing keyword
c = getpar(wksp,param,parptr,parleng)
if c = '=' then res = 320; ! Format error
finish
if pn > pmax then res = 323; ! Too many parameters
if res = 0 then start
if wksp # "" # pars(pn) then res = 324
! Duplicated parameter
pars(pn) = wksp
finish
if res # 0 then result = res
if c = -1 then result = 0; ! Finished, all OK
pnum = pnum + 1
repeat
end ; ! of paramdecode
!
!-----------------------------------------------------------------------
!
routine readline(stringname s)
integer c
string (255) work1,work2
!
on event 9 start
s = ".END"
return
finish
!
s = ""
cycle
cycle
readsymbol(c)
exit if c = nl
s <- s.tostring(c)
repeat
!
s = work1.work2 while s -> work1.(" ").work2
!
exit unless length(s) = 0
repeat
uctranslate(addr(s)+1,length(s))
end ; ! of readline
!
!-----------------------------------------------------------------------
!
routine warn(string (255) s)
s <- "Warning - ".s
selectoutput(0)
printstring(s)
selectoutput(listchan)
printstring(s)
end ; ! of warn
!
!-----------------------------------------------------------------------
!
routine write block(integer ad,len)
! Writes a block to the tape of length 'len', starting at 'ad'. Fills in
! the block sequence number and the block length (which together make up
! the 'block organisation data'), for which space should have been left
! at 'ad'.
integer flag
!
move(4,addr(blockno),ad); ! Block sequence number
halfinteger(ad+4) = len; ! Block length
blockno = blockno + 1
!
writemag(tapechan,ad,len,flag)
if flag # 0 then start
unloadmag(tapechan)
setfname("Tape write error")
fail(233); ! General error
finish
end ; ! of write block
!
!-----------------------------------------------------------------------
!
routine write body(integer conad,threshold,maxrec,blocksize,upper,
string (31) input,integername blocks,records)
integer lastrec,start,len,i,rad,rlen,count,truncations,translate
record (descf) fdesc,tempdesc
record (hf)name h
byteintegerarray b(-7:blocksize-8)
!
! Set bound check inhibit, so that MODD will work sensibly
!
*cpsr _i
i = i!x'400'
*mpsr _i
!
h == record(conad)
start = conad + h_datastart
len = h_dataend - h_datastart
!
fdesc_dr0 = x'18000000'!len
fdesc_dr1 = start
!
records = 0
count = 0
truncations = 0
blocks = 0
truncations = 0
!
! Main copy loop
!
while len > 0 cycle
translate = no
if h_filetype = sscharfiletype then start
*lb _nl; ! Character for scan
*ld _fdesc
*jat _11,<endoffile>; ! Jump on zero descriptor length
*swne _l =dr ; ! Scan for newline
*jat _11,<eof>; ! Jump on zero descriptor length
*modd _1; ! Move past newline
eof:
*std _tempdesc
rlen = tempdesc_dr1 - fdesc_dr1 - 1
len = len - rlen - 1
! Length of line, excluding newline
rad = fdesc_dr1
translate = yes
*lsd _tempdesc; ! Update descriptor to input file
*st _fdesc
finish else c
if h_format & x'ffff' = 1 then start
! Data file, fixed length records
rad = fdesc_dr1
rlen = h_format >> 16
len = len - rlen
fdesc_dr1 = fdesc_dr1 + rlen
else ; ! Data file, variable length records
rad = fdesc_dr1 + 2; ! Omit record header
rlen = halfinteger(fdesc_dr1) - 2;! Record length
len = len - rlen - 2
fdesc_dr1 = fdesc_dr1 + rlen + 2
finish
!
records = records + 1
if rlen > maxrec - 4 then start
rlen = maxrec - 4
truncations = truncations + 1
if truncations <= threshold then start
warn("Record ".itos(records)." of file ".input." truncated".snl)
finish
finish
!
if translate = yes and rlen = 0 then start
rad = addr(space char) + 1
rlen = 1
finish
!
if count + rlen + 4 > blocksize - 8 then start
halfinteger(addr(b(-1))) = lastrec
fill(blocksize-8-count,addr(b(1))+count,0)
! Pad rest of block with zeros
write block(addr(b(-7)),blocksize)
count = 0
blocks = blocks + 1
finish
!
halfinteger(addr(b(1))+count) = rlen + 4
halfinteger(addr(b(3))+count) = 0
move(rlen,rad,addr(b(5))+count)
if translate = yes then start
if upper = yes then uctranslate(addr(b(5))+count,rlen)
itoe(addr(b(5))+count,rlen)
finish
lastrec = count + 2
count = count + rlen + 4
repeat
!
endoffile:
!
if count # 0 then start ; ! Write last incomplete block
halfinteger(addr(b(-1))) = lastrec
fill(blocksize-8-count,addr(b(1))+count,0)
! Pad rest of block with zeros
write block(addr(b(-7)),blocksize)
blocks = blocks + 1
finish
!
if truncations > threshold then start
warn("Total of ".itos(truncations)." records truncated in file ".input.snl)
finish
end ; ! of write body
!
!-----------------------------------------------------------------------
!
routine write file(integer conad,fileno,threshold,generation,upper,
string (31) input,output,integername records)
! Writes the file 'input' (connected at 'conad') to the tape, giving it
! the name 'output'.
integer maxrec,nblocks,blocksize
record (hf)name h
!
write label1("HDR1",output,fileno,generation,0)
h == record(conad)
if h_filetype = sscharfiletype then start
maxrec = 256 + 4; ! Allow for record header
else
maxrec = h_format >> 16 + 4
finish
blocksize = maxrec
blocksize = 4096 if blocksize < 4096; ! Minimum blocksize
blocksize = blocksize + 8; ! Allow for block organisation data
!
write label2("HDR2",blocksize,maxrec)
write tape mark
write body(conad,threshold,maxrec,blocksize,upper,input,nblocks,records)
if nblocks = 0 then warn("File ".input." is empty".snl)
write tape mark
write label1("EOF1",output,fileno,generation,nblocks)
write label2("EOF2",blocksize,maxrec)
write tape mark
end ; ! of write file
!
!-----------------------------------------------------------------------
!
routine write label1(string (4) type,string (16) name,integer fileno,
generation,blocks)
! Writes a first file header or end of file label (HDR1 or EOF1) to the
! tape.
string (31) s
byteintegerarray b(-5:80)
!
move(4,addr(type)+1,addr(b(1)))
fill(17,addr(b(5)),' ')
move(length(name),addr(name)+1,addr(b(5)))
! File identifier (VME 2900 filename)
move(6,addr(data00)+1,addr(b(22))); ! File set identifier
s = "0001"; ! File section number
move(4,addr(s)+1,addr(b(28)))
s = itos(fileno); ! File sequence number
s = "0".s while length(s) < 4
move(4,addr(s)+1,addr(b(32)))
s = itos(generation)
s = "0".s while length(s) < 4
move(4,addr(s)+1,addr(b(36)))
s = "01"; ! Version number
move(2,addr(s)+1,addr(b(40)))
s = year and day; ! Creation date
move(6,addr(s)+1,addr(b(42)))
move(6,addr(s)+1,addr(b(48))); ! Expiration date
b(54) = ' '; ! Accessibility - all
s = itos(blocks)
s = "0".s while length(s) < 6
move(6,addr(s)+1,addr(b(55)))
fill(20,addr(b(61)),' '); ! System code/reserved
!
itoe(addr(b(1)),80)
write block(addr(b(-5)),86)
end ; ! of write label1
!
!-----------------------------------------------------------------------
!
routine write label2(string (4) type,integer blocksize,maxrec)
! Writes a second file header or end of file label (HDR2 or EOF2) to the
! tape.
string (31) s
byteintegerarray b(-5:80)
!
move(4,addr(type)+1,addr(b(1)))
b(5) = 'V'; ! Variable length records
s = itos(blocksize)
s = "0".s while length(s) < 5
move(5,addr(s)+1,addr(b(6)))
s = itos(maxrec)
s = "0".s while length(s) < 5
move(5,addr(s)+1,addr(b(11)))
fill(35,addr(b(16)),' ')
b(51) = '0'
b(52) = '8'
fill(28,addr(b(53)),' ')
!
itoe(addr(b(1)),80)
!
write block(addr(b(-5)),86)
end ; ! of write label2
!
!-----------------------------------------------------------------------
!
routine write tape mark
! Writes one tape mark to the tape.
integer flag
!
blockno = blockno + 1
!
writetmmag(tapechan,flag)
if flag # 0 then start
unloadmag(tapechan)
setfname("Tape write error")
fail(233); ! General error
finish
end ; ! of write tape mark
!
!-----------------------------------------------------------------------
!
routine write vol1 label(string (6) vol)
! Writes the main volume header label (VOL1) to the tape.
integer i
byteintegerarray b(-5:80)
!
i = m'VOL1'
move(4,addr(i),addr(b(1)))
move(6,addr(vol)+1,addr(b(5)))
b(i) = ' ' for i = 11,1,79
b(80) = '2'; ! Indicates 2900 standard version
!
itoe(addr(b(1)),80)
write block(addr(b(-5)),86)
end ; ! of write vol1 label
!
!-----------------------------------------------------------------------
!
string (6)function year and day
! Yields the year and day within the year as a 6-character string, in
! the form ' yyddd'.
integer month,day,year
string (3) res
string (3) ds
string (8) dt
!
dt = date
res = substring(dt,7,8); ! Year
year = pstoi(res)
month = pstoi(substring(dt,4,5)); ! Month
day = pstoi(substring(dt,1,2)); ! Day
if year//4*4 = year and month > 2 then day = day + 1
!
while month > 1 cycle
month = month - 1
day = day + monthdays(month)
repeat
!
ds = itos(day)
ds = "0".ds while length(ds) < 3
!
result = " ".res.ds
end ; ! of year and day
!
!
!***********************************************************************
!*
!* W R I T E B T A P E
!*
!***********************************************************************
!
externalroutine writebtape(string (255) parms)
integer flag,startfile,fileno,failures,threshold,records,afd,i,c,upper
integer generation,len
string (63) input,output,name
string (255) s,work
stringname vol,fs,out,us,ts,vs
record (rf) rr
record (hf)name h
byteintegerarray b(-5:80)
string (255)array options(1:keymax)
!
if parms = "?" then start
printstring("Parameters are: ")
for i = 1,1,keymax cycle
printstring(keys(i))
printsymbol(',') unless i = keymax
repeat
newline
set return code(0)
return
finish
!
flag = paramdecode(parms,keymax,keys,options)
-> err if flag # 0
vol == options(1)
fs == options(2)
out == options(3)
us == options(4)
ts == options(5)
vs == options(6)
!
if vol = "" then start
flag = 263; ! Wrong number of parameters
-> err
finish
unless 1 <= length(vol) <= 6 then start
setfname(keys(1))
flag = 326; ! Invalid value for TAPE parameter
-> err
finish
for i = 1,1,length(vol) cycle
c = charno(vol,i)
unless 'A' <= c <= 'Z' or c
(i # 1 and ('0' <= c <= '9')) then start
setfname(keys(1))
flag = 326; ! Invalid value for TAPE parameter
-> err
finish
repeat
vol = vol." " while length(vol) < 6
!
if fs # "" then start ; ! Starting file specified
startfile = pstoi(fs)
unless 1 <= startfile <= maxfile then start
setfname(keys(2))
flag = 326; ! Invalid value for STARTFILE parameter
-> err
finish
finish else startfile = 1
!
out = "T#LIST" if out = ""
!
if us # "" then start ; ! Upper case option specified
if matchstrings(us,"NO") = no then start
if matchstrings(us,"YES") = yes then start
upper = yes
else
setfname(keys(4))
flag = 326; ! Invalid value for UPPER parameter
-> err
finish
else
upper = no
finish
finish else upper = no
!
if ts # "" then start ; ! Error threshold specified
threshold = pstoi(ts)
unless 1 <= threshold <= maxthreshold then start
setfname(keys(5))
flag = 326; ! Invalid value for THRESHOLD parameter
-> err
finish
finish else threshold = defaultthreshold
!
if vs # "" then start
if matchstrings(vs,"NO") = no then start
if matchstrings(vs,"YES") = yes then start
printstring("Version: E".itos(version).".".itos(edit).snl)
else
setfname(keys(6))
flag = 326; ! Invalid value for VERSION parameter
-> err
finish
finish
finish
!
askmag(tapechan,vol."*",flag)
if flag # 0 then start
setfname("Failed to claim tape ".vol)
flag = 233; ! General error
-> err
finish
!
rewindmag(tapechan)
fileno = startfile - 1
if startfile = 1 then start
blockno = 0
write vol1 label(vol)
else
fskiptmmag(tapechan,fileno*3,flag); ! Position after last required file
if flag = 1 then start
setfname("Too few files already on tape")
flag = 233; ! General error
-> uerr
finish
if flag # 0 then start
setfname("Tape read error")
flag = 233; ! General error
-> uerr
finish
!
skipmag(tapechan,-2); ! Position before last EOF2
len = 86; ! Length of EOF2
readmag(tapechan,addr(b(-5)),len,flag)
if flag # 0 or len # 86 then start
setfname("Error reading last EOF2 label")
flag = 233; ! General error
-> uerr
finish
move(4,addr(b(-5)),addr(blockno))
blockno = blockno + 2; ! Number of next block to write
skipmag(tapechan,1); ! Skip over tape mark
finish
!
define(listchan,out,afd,flag)
-> err if flag # 0
selectoutput(listchan)
newlines(2)
printstring(" ICL VME 2900 tape ".vol." written at ".time." on ".date)
newlines(2)
printstring(" File EMAS filename VME 2900 filename ".c
"Records".snl)
newlines(2)
!
failures = 0
cycle
prompt("File: ")
readline(s)
exit if s = ".END"
unless s -> input.(",").output then start
input = s
output = s
finish
if output -> output.("(").work.(")") then start
generation = pstoi(work)
else
generation = 1
finish
unless 1 <= generation <= 4095 then start
warn("Invalid generation number for output file '".output."' - 1 assumed".snl)
generation = 1
finish
if length(output) > 16 then start
warn("VME2900 filename '".output."' truncated to 16 characters".snl)
length(output) = 16
finish
!
connect(input,1,0,0,rr,flag)
if flag = 0 then start
h == record(rr_conad)
unless h_filetype = sscharfiletype or c
(h_filetype = ssdatafiletype and h_format & x'ffff' # 3) then start
flag = 267; ! Invalid filetype
setfname(input)
finish
finish
if flag # 0 then start
warn(failuremessage(flag))
failures = failures + 1
continue
finish
fileno = fileno + 1
!
write file(rr_conad,fileno,threshold,generation,upper,input,output,records)
!
write(fileno,8)
spaces(8)
name = input
if name -> work.(".").name then start ; finish
printstring(name)
spaces(49-outpos)
printstring(output."(".itos(generation).")")
spaces(74-outpos)
write(records,6)
newline
disconnect(input,flag)
repeat
!
write tape mark if fileno = 0
write tape mark
!
newline
selectoutput(0)
closestream(listchan)
clearstream(listchan)
if failures # 0 then start
printstring(itos(failures)." file")
printsymbol('s') if failures # 1
printstring(" failed to copy".snl)
finish
printstring("Tape written".snl)
unloadmag(tapechan)
set return code(-failures)
return
!
uerr:
unloadmag(tapechan)
!
err:
fail(flag)
end ; ! of writebtape
endoffile