!***********************************************************************
!*
!* Program to read files from an IBM labelled tape
!*
!* Copyright (C) R.D. Eager University of Kent MCMLXXXV
!*
!***********************************************************************
!
constantinteger version = 1; ! Major version number
constantinteger edit = 0; ! Edit number within major version
!
!***********************************************************************
!*
!* Constants
!*
!***********************************************************************
!
constantinteger no = 0, yes = 1
constantinteger sscharfiletype = 3; ! Subsystem file type
constantinteger ssdatafiletype = 4; ! Subsystem file type
constantinteger maxblk = 2400; ! Max 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
constantbyteintegerarray etoitable(0:255) = c
x'00',x'01',x'02',x'03',x'9c',x'09',x'86',x'7f',x'97',x'8d',
x'8e',x'0b',x'0c',x'0d',x'0e',x'0f',x'10',x'11',x'12',x'13',
x'9d',x'85',x'08',x'87',x'18',x'19',x'92',x'8f',x'1c',x'1d',
x'1e',x'1f',x'80',x'81',x'82',x'83',x'84',x'0a',x'17',x'1b',
x'88',x'89',x'8a',x'8b',x'8c',x'05',x'06',x'07',x'90',x'91',
x'16',x'93',x'94',x'95',x'96',x'04',x'98',x'99',x'9a',x'9b',
x'14',x'15',x'9e',x'1a',x'20',x'a0', '[', ']', '{', '}',
x'a5',x'a6',x'a7',x'a8',x'5b',x'2e',x'3c',x'28',x'2b', '|',
x'26',x'a9',x'aa',x'ab',x'ac',x'ad',x'ae',x'af',x'b0',x'b1',
'!',x'24',x'2a',x'29',x'3b', '~',x'2d',x'2f', '¬',x'b3',
x'b4',x'b5',x'b6',x'b7',x'b8',x'b9',x'7c',x'2c',x'25',x'5f',
x'3e',x'3f',x'ba',x'bb',x'bc',x'bd',x'be',x'bf',x'c0',x'c1',
x'c2',x'60',x'3a',x'23',x'40',x'27',x'3d',x'22',x'c3',x'61',
x'62',x'63',x'64',x'65',x'66',x'67',x'68',x'69',x'c4',x'c5',
x'c6',x'c7',x'c8',x'c9',x'ca',x'6a',x'6b',x'6c',x'6d',x'6e',
x'6f',x'70',x'71',x'72',x'cb',x'cc',x'cd',x'ce',x'cf',x'd0',
x'd1',x'ff',x'73',x'74',x'75',x'76',x'77',x'78',x'79',x'7a',
x'd2',x'd3',x'd4',x'd5',x'd6',x'd7',x'd8',x'd9',x'da',x'db',
x'dc',x'dd',x'de',x'df',x'e0',x'e1',x'e2',x'e3',x'e4',x'e5',
x'e6',x'e7',x'7b',x'41',x'42',x'43',x'44',x'45',x'46',x'47',
x'48',x'49',x'e8',x'e9',x'ea',x'eb',x'ec',x'ed',x'7d',x'4a',
x'4b',x'4c',x'4d',x'4e',x'4f',x'50',x'51',x'52',x'ee',x'ef',
x'f0',x'f1',x'f2',x'f3',x'ff',x'9f',x'53',x'54',x'55',x'56',
x'57',x'58',x'59',x'5a',x'f4',x'f5',x'f6',x'f7',x'f8',x'f9',
x'30',x'31',x'32',x'33',x'34',x'35',x'36',x'37',x'38',x'39',
x'fa',x'fb',x'fc',x'fd',x'fe',x'ff'
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,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
!*
!***********************************************************************
!
externalroutinespec changefilesize alias "S#CHANGEFILESIZE"(string (31) file,
integer newsize,integername flag)
externalroutinespec connect alias "S#CONNECT"(string (31) file,
integer mode,hole,prot,
record (rf)name r,integername flag)
externalstringfunctionspec date
externalroutinespec destroy alias "S#DESTROY"(string (31) file,
integername flag)
externalroutinespec disconnect alias "S#DISCONNECT"(string (31) file,
integername flag)
externalstringfunctionspec failuremessage alias "S#FAILUREMESSAGE"(integer mess)
externalstringfunctionspec interrupt
externalstringfunctionspec itos alias "S#ITOS"(integer n)
externalroutinespec modpdfile alias "S#MODPDFILE"(integer ep,string (31) pdfile,
string (11) member,string (31) infile,
integername flag)
externalroutinespec move alias "S#MOVE"(integer length,from,to)
externalstringfunctionspec nexttemp alias "S#NEXTTEMP"
externalroutinespec outfile alias "S#OUTFILE"(string (31) file,integer size,
hole,prot,integername conad,flag)
externalintegerfunctionspec outpos
externalintegerfunctionspec parmap alias "S#PARMAP"
externalroutinespec prompt(string (255) s)
externalintegerfunctionspec pstoi alias "S#PSTOI"(string (63) s)
externalroutinespec setpar alias "S#SETPAR"(string (255) s)
externalroutinespec set return code(integer i)
externalstringfunctionspec spar alias "S#SPAR"(integer n)
externalstringfunctionspec time
externalroutinespec trim alias "S#TRIM"(string (31) file,integername flag)
externalroutinespec uctranslate alias "S#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
owninteger magblk = 0
!
!
!***********************************************************************
!*
!* Service routines
!*
!***********************************************************************
!
integerfunction stopping
! Yields 'yes' iff INT:STOP has been issued.
string (15) s
!
s = interrupt
uctranslate(addr(s)+1,length(s))
if s = "STOP" then result = yes else result = no
end ; ! of stopping
!
!-----------------------------------------------------------------------
!
stringfunction specmessage(integer n)
switch sw(1000:1000)
!
-> sw(n)
!
sw(1000): result = "Failed to claim tape"
end ; ! of specmessage
!
!-----------------------------------------------------------------------
!
routine strip(stringname s)
! Strips trailing spaces from 's'.
length(s) = length(s) - 1 while charno(s,length(s)) = ' '
end ; ! of strip
!
!-----------------------------------------------------------------------
!
routine fail(integer n)
string (255) s
!
selectoutput(0)
if n < 1000 then s = failuremessage(n) else s = specmessage(n)
printstring(snl."IBMMT 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
magblk = magblk + n
end ; ! of skiptm
!
!-----------------------------------------------------------------------
!
routine readline(stringname s)
integer c
!
s = ""
cycle
cycle
readsymbol(c)
exit if c = nl
s <- s.tostring(c)
repeat
strip(s)
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
!
!-----------------------------------------------------------------------
!
routine etoi(integer ad,len)
! Translates 'len' bytes from IBM EBCDIC to ASCII, starting at 'ad'.
integer j
!
j = addr(etoitable(0))
*lb _len
*jat _14,<l99>
*ldtb _x'18000000'
*ldb _b
*lda _ad
*lss _j
*luh _x'18000100'
*ttr _l =dr
!
l99:
end ; ! of etoi
!
!-----------------------------------------------------------------------
!
routine rdmag(integer channel,ad,integername len,flag)
! Reads a tape block and translates it from EBCDIC to ASCII.
readmag(channel,ad,len,flag)
magblk = magblk + 1
! %if flag = 0 %then etoi(ad,len)
end ; ! of rdmag
!
!-----------------------------------------------------------------------
!
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: IBMMT(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 IBMMT.
/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 IBMMT.
")
end ; ! of printhelp
!
!-----------------------------------------------------------------------
!
routine directory(stringname mask)
integer ad,len,flag,i,adw,blocks,files,wildcard,labelno
string (255) work
byteintegerarray buf(0:maxblk-1)
!
ad = addr(buf(0))
adw = addr(work) + 1
!
rewindmag(chan)
len = maxblk
rdmag(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
etoi(ad,len)
move(6,ad+4,adw)
length(work) = 6
strip(work)
printstring(snl."Directory of IBM standard multi-file labelled tape ".work.snl)
printstring(" on ".date." at ".time.snl)
move(14,ad+37,adw)
length(work) = 14
strip(work)
work = substring(work,2,length(work)) while length(work) > 0 and charno(work,1) = ' '
printstring("Owned by ".work.snl.snl)
!
wildcard = wild(mask)
files = 0
blocks = 0
labelno = 0
!
printstring("Label Name Details".snl.snl)
cycle
exit if stopping = yes
len = maxblk
rdmag(chan,ad,len,flag)
exit if flag = 1; ! Final tape mark
if flag > 1 then start
printstring("?Tape read error".snl)
reset
return
finish
etoi(ad,len)
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)
strip(work)
labelno = labelno + 1
if match(work,mask) = no then start
skiptm(3)
continue
finish
printstring(" ".itos(labelno))
spaces(13-outpos)
printstring(work)
files = files + 1
spaces(30-outpos)
skiptm(2)
len = maxblk
rdmag(chan,ad,len,flag)
etoi(ad,len)
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,recsize,recfm,nrecs
string (11) name
string (31) out,temp,rtemp
byteintegerarray buf(0:maxblk-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
exit if stopping = yes
len = maxblk
rdmag(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
etoi(ad,len)
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)
strip(temp)
if match(temp,srce) = no then start
skiptm(3)
continue
finish
!
len = maxblk
rdmag(chan,ad,len,flag)
if flag > 1 then start
printstring("?Tape read error".snl)
reset
return
finish
if flag = 1 then start ; ! Tape mark
printstring("?Unexpected tape mark after HDR1".snl)
reset
return
finish
etoi(ad,len)
move(4,ad,addr(i))
if i # m'HDR2' then start
printstring("?HDR2 not found when expected".snl)
reset
return
finish
recfm = byteinteger(ad+4)
if recfm = 'F' then recfm = 1 else recfm = 2
length(rtemp) = 5
move(5,ad+10,addr(rtemp)+1)
strip(rtemp)
recsize = pstoi(rtemp)
!
skiptmmag(chan,1); ! Skip to just before first data block
magblk = magblk + 1
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 = ssdatafiletype
r_format = (recsize<<16)!recfm
ptr = r_dataend
nrecs = 0
!
cycle
exit if stopping = yes
len = maxblk
rdmag(chan,ad,len,flag)
if flag > 1 then start
printstring("?Tape read error".snl)
destroy(out,flag)
reset
return
finish
if flag = 1 then exit ; ! End of file
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
if recfm = 1 then start ; ! Fixed length records
move(len,ad,conad+ptr)
etoi(conad+ptr,len)
ptr = ptr + len
nrecs = nrecs + len//recsize
else
ad = ad + 4; ! Lose block header
len = len - 4
cycle
i = halfinteger(ad)
halfinteger(conad+ptr) = i - 2
ad = ad + 4
len = len - 4
move(i-4,ad,conad+ptr+2)
etoi(conad+ptr+2,i-4)
ptr = ptr + i - 2
ad = ad + i - 4
len = len - i + 4
nrecs = nrecs + 1
repeat until len <= 0
finish
repeat
!
r_dataend = ptr
r_records = nrecs
trim(out,flag)
skiptmmag(chan,1)
magblk = magblk + 3
!
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
printstring("%Creating pdfile ".pdfile.snl)
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
!
!
!***********************************************************************
!*
!* I B M M T
!*
!***********************************************************************
!
externalroutine ibmmt(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 ibmmt
endoffile