!***********************************************************************
!*
!* Program to write an unlabelled tape
!*
!* R.D. Eager University of Kent MCMLXXXIII
!*
!***********************************************************************
!
constantinteger version = 3; ! Major version number
constantinteger edit = 1; ! Edit number within major version
!
!***********************************************************************
!*
!* Constants
!*
!***********************************************************************
!
constantinteger no = 0, yes = 1
constantinteger ascii = 0, ebcdic = 1
constantinteger defaultrecsize = 80
constantinteger maxrecsize = 262143
constantinteger defaultblocksize = 800
constantinteger maxblocksize = 262143
constantinteger defaultthreshold = 10
constantinteger maxthreshold = 1000
constantinteger sscharfiletype = 3
constantinteger maxfile = 999; ! Maximum number of files per tape
constantinteger listchan = 80; ! Channel for listing of files written
constantinteger tapechan = 1
constantbyteinteger nl = 10
constantstring (1) snl = "
"
constantinteger keymax = 8; ! Number of parameter keywords
constantstring (9)array keys(1:keymax) = c
"TAPE",
"STARTFILE",
"LISTING",
"CODE",
"RECSIZE",
"BLOCKSIZE",
"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,format,records)
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)
externalintegerfunctionspec instream
systemintegerfunctionspec iocp(integer ep,parm)
systemroutinespec itoe(integer ad,l)
systemstringfunctionspec itos(integer n)
systemintegermapspec mapssfd(integer dsnum)
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 rewindmag(integer channel)
externalroutinespec skiptmmag(integer channel,n)
externalroutinespec writemag(integer channel,ad,len,integername flag)
externalroutinespec writetmmag(integer chan,integername flag)
externalroutinespec unloadmag(integer channel)
!
!
!***********************************************************************
!*
!* 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
!
!-----------------------------------------------------------------------
!
integerfunction matchstrings(stringname a,string (255) b)
integer l
!
l = length(a)
if length(b) < l then result = 0
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
!
!-----------------------------------------------------------------------
!
integerfunction findkey
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
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
!
!-----------------------------------------------------------------------
!
for i = 1,1,pmax cycle
pars(i) = ""; ! Initialise
repeat
parptr = 0
pnum = 1
parleng = length(param)
!
cycle
c = getpar
res = 0
if c # '=' then start
pn = pnum
else
pn = findkey
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
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
!
!-----------------------------------------------------------------------
!
string (63)function specmessage(integer n)
switch mes(1000:1002)
!
-> mes(n)
!
mes(1000): result = "Failed to claim tape"
mes(1001): result = "Tape write error"
mes(1002): result = "Incompatible block and record sizes"
end ; ! of specmessage
!
!-----------------------------------------------------------------------
!
routine fail(integer n)
selectoutput(0)
printstring(snl."WRULTAPE fails -")
if n < 1000 then start
printstring(failuremessage(n))
else
printstring(specmessage(n).snl)
finish
closestream(listchan)
clearstream(listchan)
set return code(n)
stop
end ; ! of fail
!
!-----------------------------------------------------------------------
!
routine readline(stringname s)
integer c
!
on event 9 start
s = ".END"
return
finish
!
s = ""
cycle
cycle
readsymbol(c)
exit if c = nl
s <- s.tostring(c)
repeat
!
while length(s) > 0 cycle
c = charno(s,length(s))
exit unless c = ' '
length(s) = length(s) - 1
repeat
!
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,code)
integer flag
!
if code = ebcdic then itoe(ad,len)
writemag(tapechan,ad,len,flag)
if flag # 0 then fail(1001)
end ; ! of write block
!
!-----------------------------------------------------------------------
!
integerfunction write file(integer conad,code,recsize,blocksize,
threshold,string (31) file)
integer start,i,ad,len,records,truncations,count
record (descf) fdesc,tdesc,tempdesc
string (63) mes
byteintegerarray buf(1:blocksize)
record (hf)name r
!
r == record(conad)
start = conad + r_datastart
len = r_dataend - r_datastart
!
! Set bound check inhibit, so that MODD works sensibly
!
*cpsr _i
i = i!x'400'
*mpsr _i
!
! Set up addresses for copying into the buffer
!
fdesc_dr0 = x'18000000'!len
fdesc_dr1 = start
ad = addr(buf(1))
!
! Main copy loop
!
records = 0
count = 0
truncations = 0
cycle
*lb _nl; ! Character for scan
*ld _fdesc
*jat _11,<endoffile>; ! *jzdl_endoffile
*swne _l =dr ; ! Scan to end of line
*jat _11,<eof>; ! *JZDL_EOF
*modd _1; ! Move past newline
eof:
*std _tempdesc
i = tempdesc_dr1-fdesc_dr1-1; ! Length of line, excluding newline
records = records + 1
if i > recsize then start
if truncations < threshold then start
mes = "File ".file." - record ".itos(records)." truncated".snl
warn(mes)
finish
truncations = truncations + 1
i = recsize
finish
fdesc_dr0 = x'18000000'!i; ! Descriptor to line
if count = 0 then start ; ! New buffer load - reset descriptor
tdesc_dr1 = ad
finish
tdesc_dr0 = x'18000000'!recsize
*lsd _fdesc
*ld _tdesc
*mv _l =dr ,0,32; ! Move and space fill
*std _tdesc; ! Update address
count = count + recsize
if count >= blocksize then start
write block(ad,count,code)
count = 0
finish
*lsd _tempdesc; ! Update descriptor to input file
*st _fdesc
repeat
!
endoffile:
if count # 0 then write block(ad,count,code)
if truncations > threshold then start
mes = "Total of ".itos(truncations)." records truncated".snl
warn(mes)
finish
result = records
end ; ! of write file
!
!
!***********************************************************************
!*
!* W R U L T A P E
!*
!***********************************************************************
!
externalroutine wrultape(string (255) parms)
stringname vol,fs,out,cs,rs,bs,ts,vs
integer flag,startfile,fileno,failures,code,recsize,blocksize,threshold
integer records,afd
string (63) input,name,work
record (rf) rr
string (255)array options(1:keymax)
!
flag = paramdecode(parms,keymax,keys,options)
-> err if flag # 0
vol == options(1)
fs == options(2)
out == options(3)
cs == options(4)
rs == options(5)
bs == options(6)
ts == options(7)
vs == options(8)
!
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
!
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 = ""
!
cs = "ASCII" if cs = ""
if matchstrings(cs,"ISO") = yes then cs = "ASCII"
if matchstrings(cs,"ASCII") = yes then start
code = ascii
else
if matchstrings(cs,"EBCDIC") = yes then start
code = ebcdic
else
setfname(keys(4))
flag = 326; ! Invalid value for CODE parameter
-> err
finish
finish
!
if rs # "" then start ; ! Record size specified
recsize = pstoi(rs)
unless 1 <= recsize <= maxrecsize then start
setfname(keys(5))
flag = 326; ! Invalid value for RECSIZE parameter
-> err
finish
finish else recsize = defaultrecsize
!
if bs # "" then start ; ! Block size specified
blocksize = pstoi(bs)
unless 1 <= blocksize <= maxblocksize then start
setfname(keys(6))
flag = 326; ! Invalid value for BLOCKSIZE parameter
-> err
finish
finish else blocksize = defaultblocksize
!
if ts # "" then start ; ! Error threshold specified
threshold = pstoi(ts)
unless 1 <= threshold <= maxthreshold then start
setfname(keys(7))
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(8))
flag = 326; ! Invalid value for VERSION parameter
-> err
finish
finish
finish
!
if blocksize//recsize*recsize # blocksize then fail(1002)
! Incompatible values
!
askmag(tapechan,vol."*",flag)
if flag # 0 then start
setfname(vol)
flag = 1000; ! Failed to claim tape
-> err
finish
rewindmag(tapechan)
!
define(listchan,out,afd,flag)
-> err if flag # 0
selectoutput(listchan)
newlines(2)
printstring("Unlabelled multi-file tape ".vol.c
" written at ".time." on ".date)
newlines(2)
printstring(" File File name ".c
"Records".snl)
newlines(2)
!
fileno = startfile - 1
skiptmmag(tapechan,fileno)
failures = 0
cycle
prompt("File: ")
readline(input)
exit if input = ".END"
connect(input,1,0,0,rr,flag)
if flag = 0 then start
if rr_filetype # sscharfiletype then start
setfname(input)
flag = 267; ! Invalid filetype
finish
finish
if flag # 0 then start
warn(failuremessage(flag))
failures = failures + 1
continue
finish
fileno = fileno + 1
records = write file(rr_conad,code,recsize,blocksize,threshold,input)
writetmmag(tapechan,flag)
!
-> tapeerr if flag # 0
write(fileno,6)
spaces(10)
name = input
if name -> work.(".").name then start ; finish
printstring(name)
spaces(40-outpos)
write(records,11)
newline
disconnect(input,flag)
repeat
!
if fileno = 0 then start
writetmmag(tapechan,flag)
-> tapeerr if flag # 0
finish
!
writetmmag(tapechan,flag); ! Double tape mark to terminate
-> tapeerr if flag # 0
!
newline
selectoutput(0)
closestream(listchan)
clearstream(listchan)
if failures # 0 then start
printstring(itos(failures)." file")
if failures # 1 then printsymbol('s')
printstring(" failed to copy".snl)
finish
printstring("Tape written".snl)
unloadmag(tapechan)
set return code(-failures)
stop
!
tapeerr:
!
unloadmag(tapechan)
flag = 1001; ! Tape write error
!
err:
fail(flag)
end ; ! of wrultape
endoffile