!SQDASM19S: Modified 29/June/83
!
! * Changed CHANGESM - corrects EMAS 2900 fault number 157, also
! has been substantially rewritten.
!
! AGRK
!SQDASM18S: Modified 16/March/83
!
! * Converted to IMP80 and SOAPed
! * Use of %alias to obviate need to change entry names and reference
! status after compilation (magio,openda,closeda,opensq,closesq)
!
! RDE (UKC)
!SQDASM17S: Modified 6/December/82
!
! * Changed OPTHEADER - efficiency only
! * Changed FORTRANDF - now accepts calls from NEW FILE OP to open a
! direct-access file for FORTRAN77
!
! AGRK
recordformat rf(integer conad,filetype,datastart,dataend)
recordformat frf(integer conad,filetype,datastart,dataend,size,rup,eep,apf, c
users,arch, string (6) tran, string (8) date,time, integer count, c
spare1,spare2)
recordformat fdf(integer link,dsnum, byteinteger status,access route, c
valid action,cur state, byteinteger mode of use,mode,file org,dev class, c
byteinteger rec type,flags,lm,rm, integer asvar,arec,recsize,minrec, c
maxrec,maxsize,routeccy,conad,currec,cur,end,transfers,darecnum,cursize, c
datastart, string (31) iden, string (8) device)
systemintegermapspec comreg(integer n)
systemroutinespec setpar(string (255) s)
systemintegerfunctionspec parmap
systemstringfunctionspec spar(integer n)
systemintegerfunctionspec pstoi(string (255) s)
systemroutinespec setfname(string (40) name)
dynamicroutinespec magio alias "S#MAGIO" (integer afd,ep, integername flag)
externalintegerfunctionspec uinfi(integer n)
systemroutinespec finfo(string (31) file, integer mode, c
record (frf) name r, integername flag)
systemroutinespec extend(record (fdf) name f, integername flag)
systemintegerfunctionspec open(integer afd,mode)
systemintegerfunctionspec fdmap(integer chan)
systemroutinespec signal(integer ep,pc,lnb, integername flag)
systemroutinespec move(integer len,from,to)
systemroutinespec psysmes(integer root,flag)
systemroutinespec disconnect(string (31) s, integername f)
systemroutinespec changefilesize(string (31) s, integer newsize, c
integername flag)
systemroutinespec fill(integer l,f,p)
systemintegerfunctionspec close(integer i)
systemroutinespec connect(string (31) file, integer mode,hole,protect, c
record (rf) name r, integername flag)
recordformat dahf(integer dataend,datastart,size,filetype,date,time,format, c
records)
constantinteger ssfformat= 1
constantinteger ssvformat= 2
constantinteger ssuformat= 3
constantinteger ssdatafiletype= 4
systemroutinespec outfile(string (31) s, integer len,maxlen,use, c
integername conad,flag)
!*
!*
integerfunction namel(integer dr0)
!***********************************************************************
!* *
!* This function decodes the top half of a descriptor passed by the *
!* IMP %name parameter and returns the length of the entity passed in *
!* bytes. Either the descriptor is scaled in which case the length is *
!* decoded from the size code in the descriptor, or it is unscaled in *
!* which case the length is held in the bound. *
!* *
!***********************************************************************
constantbyteintegerarray slen(3:7)= c
1,2,4,8,16; !LENGTHS FOR SCALED DESCRIPTORS
if dr0 & x'02000000' = 0 thenresult = slen((dr0 >> 27) & 7)
!SCALED - CODE IN SIZE
result = dr0 & x'FFFFFF'; !UNSCALED - LENGTH IN BOUND
end ; !OF NAMEL
integerfunction optheader(integer blocksize)
!CALCULATES THE OPTIMUM FILE HEADER SIZE FOR A DATA
!FILE WITH A GIVEN BLOCK SIZE
!
if blocksize <= 4096 thenstart
!
! Test if Record length is a multiple of 4096 (page size)
!
if blocksize & (blocksize - 1) = 0 and blocksize >= 32 then c
result = blocksize
!
!Label Header Size used is the record length so
! long as it is a factor of 4096 and is also at
! least as large as the minimum header size
finishelsestart
if blocksize & 4095 = 0 thenresult = 4096
!
!Header size=4096 if 4096 is a
!multiple of the record length
finish
result = 32; !in all other cases
end ; !of OPT HEADER
!***********************************************************************
!* *
!* IMP SEQUENTIAL ACCESS ROUTINES *
!* *
!***********************************************************************
externalroutine opensq(integer chan)
integer flag,afd
record (fdf) name f
! SSOPENUSED = 1
flag = 0
unless 0 < chan <= 99 then flag = 164 and ->err
!INVALID CHANNEL
afd = fdmap(chan)
if afd = 0 then flag = 151 and ->err; !NOT DEFINED
f == record(afd)
if f_status # 0 then flag = 176 and ->err
!ALREADY OPEN
f_link = uinfi(12); !FDLEVEL - TO CAUSE AUTO-CLOSE
f_status = 2; !PARTLY OPEN - COMPLETED BY READSQ OR WRITESQ
err:
if flag # 0 then psysmes( - 49,flag)
end ; !OF OPENSQ
externalroutine closesq(integer chan)
integer flag,afd
flag = 0
unless 0 < chan <= 99 then flag = 164 and ->err
!INVALID CHAN
afd = fdmap(chan)
if afd = 0 then flag = 151 and ->err; !NOT DEFINED
flag = close(afd)
err:
if flag # 0 then psysmes( - 50,flag)
end ; !OF CLOSESQ
owninteger holdlengthsq
externalroutine writesq(integer chan,sdr0,sdr1,edr0,edr1)
record (dahf) name head
record (fdf) name f
integer afd,start,len,flag,irgap
flag = 0
unless 1 <= chan <= 80 or chan = 96 then flag = 164 and ->err
!INVALID CHAN
afd = fdmap(chan)
if afd = 0 then flag = 151 and ->err; !NOT DEFINED
f == record(afd)
if f_status = 0 then flag = 301 and ->err; !NOT OPEN
if f_status = 2 start ; !OPENED BY OPENSQ - NOW COMPLETE THE OPEN
f_modeofuse = 2; !SET MODE OF USE TO SQ
flag = open(afd,2); !OPEN FOR WRITING
->err if flag # 0
if f_modeofuse # 2 then flag = 267 and setfname(f_iden) and ->err
if f_accessroute # 5 start ; !NOT FOR MAG TAPE
head == record(f_conad)
head_filetype = ssdatafiletype
head_format = (f_maxrec << 16 ! f_rectype)
head_records = 0
finish
finishelsestart ; !ALREADY FULLY OPEN
if f_modeofuse # 2 or f_validaction & 2 = 0 then flag = 266 and ->err
!INCONSISTENT FILE USE
finish
!NOW OPEN CORRECTLY - CHECK ADDRESSES
start = sdr1
len = edr1 - sdr1 + namel(edr0); !TOTAL LENGTH OF REQUEST
if len < 0 then flag = 177 and ->err; !ADDRESSES INSIDE OUT
if f_rectype = ssfformat start ; !FIXED FORMAT
if len # f_minrec then flag = 161 and ->err
!WRONG RECORD LENGTH
irgap = 0; !NO INTER RECORD GAP
finishelsestart
if len > f_maxrec then flag = 161 and ->err
!WRONG RECORD LENGTH
irgap = 2
finish
if f_accessroute = 5 start ; !MAGNETIC TAPE
move(len,start,f_arec); !MOVE DATA TO IO BUFFER
f_recsize = len
magio(afd,3,flag)
->err
finish
while f_cur + len + irgap > f_end cycle
extend(f,flag)
if flag # 0 start
if flag = 1 then flag = 169; !OUTPUT EXCEEDED
->err
finish
repeat
move(len,start,f_cur + irgap)
if irgap # 0 start ; !PUT IN REC SEPARATOR
len = len + 2
byteinteger(f_cur) <- len >> 8
byteinteger(f_cur + 1) <- len
finish
f_cur = f_cur + len
f_transfers = f_transfers + 1
err:
if flag # 0 then psysmes( - 83,flag); !PRINT MESSAGE AND STOP
end ; !OF WRITESQ
externalroutine readlsq(integer chan,sdr0,sdr1,edr0,edr1, c
integername reqlen)
record (fdf) name f
integer afd,start,len,irgap,flag
flag = 0
unless 1 <= chan <= 80 then flag = 164 and ->err
!INVALID CHAN
afd = fdmap(chan)
if afd = 0 then flag = 151 and ->err; !NOT DEFINED
f == record(afd)
if f_status = 0 then flag = 301 and ->err; !NOT OPEN
if f_status = 2 start ; !OPENED BY OPENSQ - NOW COMPLETE
flag = open(afd,1); !OPEN FOR READING
->err if flag # 0
unless f_rectype = ssfformat or f_rectype = ssvformat or c
(f_rectype = ssuformat and f_accessroute = 5) then c
flag = 267 and setfname(f_iden) and ->err
!INVALID FILETYPE UNLESS F,V, OR (U IF MAG TAPE)
f_modeofuse = 2; !SEQUENTIAL USE
finishelsestart ; !ALREADY FULLY OPEN
if f_modeofuse # 2 or f_validaction & 2 # 0 then flag = 266 and ->err
!INCONSISTENT FILE USE
finish
!NOW OPEN CORRECTLY
start = sdr1
reqlen = edr1 - sdr1 + namel(sdr0)
if reqlen < 0 then flag = 177 and ->err; !ADDRESSES INSIDE-OUT
if f_accessroute = 5 start ; !MAGNETIC TAPE
magio(afd,2,flag)
if flag # 0 start
if flag = 153 then flag = 0 and reqlen = 0
!INPUT ENDED
->err
finish
if f_recsize < reqlen then reqlen = f_recsize
!RECORD SHORTER THAN REQUESTED
move(reqlen,f_arec,start)
->err
finish
if f_cur >= f_end then reqlen = 0 and ->err
!INPUT ENDED
if f_rectype = ssfformat start ; !FIXED FORMAT
if reqlen > f_minrec then reqlen = f_minrec
!RECORD SHORTER THAN REQUEST
len = f_minrec; !THE ACTUAL RECORD LENGTH
irgap = 0
finishelsestart ; !VARIABLE RECORD FORMAT
len = (byteinteger(f_cur) << 8) ! byteinteger(f_cur + 1) - 2
!LENGTH OF DATA IN RECORD
if reqlen > len then reqlen = len
!RECORD SHORTER THAN REQUESTED LENGTH
irgap = 2
finish
move(reqlen,f_cur + irgap,start); !MOVE DATA TO PROGRAM AREA
f_cur = f_cur + irgap + len
err:
if flag # 0 then psysmes( - 84,flag)
end ; !OF READLSQ
externalroutine readsq(integer chan,sdr0,sdr1,edr0,edr1)
integer len,flag
readlsq(chan,sdr0,sdr1,edr0,edr1,len)
holdlengthsq = len
if len = 0 then signal(2,140,0,flag); !SIGNAL INPUT ENDED
end ; !OF READSQ
externalintegerfunction lengthsq
result = holdlengthsq
end ; !OF LENGTHSQ
!***********************************************************************
!* *
!* ALGOL SEQUENTIAL ACCESS ROUTINES *
!* *
!***********************************************************************
systemroutine opensq1 alias "S#OPENSQ" (integer chan)
!SQ ROUTINE FOR ALGOL
integer flag,afd
record (fdf) name f
! SSOPENUSED = 1
flag = 0
unless 0 < chan <= 99 then flag = 164 and ->err
!INVALID CHANNEL
afd = fdmap(chan)
if afd = 0 then flag = 151 and ->err; !NOT DEFINED
f == record(afd)
if f_status # 0 then flag = 176 and ->err
!ALREADY OPEN
f_link = uinfi(12); !FDLEVEL - TO CAUSE AUTO-CLOSE
f_status = 2; !PARTLY OPEN - COMPLETED BY READSQ OR WRITESQ
err:
if flag # 0 then psysmes( - 49,flag)
end ; !OF OPENSQ
systemroutine closesq1 alias "S#CLOSESQ" (integer chan)
!SQ ROUTINE FOR ALGOL
integer flag,afd
flag = 0
unless 0 < chan <= 99 then flag = 164 and ->err
!INVALID CHAN
afd = fdmap(chan)
if afd = 0 then flag = 151 and ->err; !NOT DEFINED
flag = close(afd)
err:
if flag # 0 then psysmes( - 50,flag)
end ; !OF CLOSESQ
systemroutine rwndsq(integer chan)
!SQ ROUTINE FOR ALGOL - DOES CLOSE+OPEN
integer flag,afd
record (fdf) name f
flag = 0
unless 0 < chan <= 99 then flag = 164 and ->err
!INVALID CHAN
afd = fdmap(chan)
if afd = 0 then flag = 151 and ->err; !NOT DEFINED
flag = close(afd)
if flag # 0 then ->err
f == record(afd)
f_link = uinfi(12); !FDLEVEL - TO CAUSE AUTOCLOSE
f_status = 2; !PARTLY OPEN - COMPLETED BY READSQ OR WRITESQ
err:
if flag # 0 then psysmes( - 91,flag)
end ; !OF RWNDSQ
systemroutine putsq(integer chan,dr0,dr1, longinteger dopevdesc)
!SQ ROUTINE FOR ALGOL, EQUIVALENT TO WRITESQ
!DOPE VECTOR DESCRIPTOR IS NOT USED
record (dahf) name head
record (fdf) name f
integer afd,start,len,flag,irgap
flag = 0
unless 1 <= chan <= 80 or chan = 96 then flag = 164 and ->err
!INVALID CHAN
afd = fdmap(chan)
if afd = 0 then flag = 151 and ->err; !NOT DEFINED
f == record(afd)
if f_status = 0 then flag = 301 and ->err; !NOT OPEN
if f_status = 2 start ; !OPENED BY OPENSQ - NOW COMPLETE THE OPEN
f_modeofuse = 2; !SET MODE OF USE TO SQ
flag = open(afd,2); !OPEN FOR WRITING
->err if flag # 0
if f_modeofuse # 2 then flag = 267 and ->err
head == record(f_conad)
head_filetype = ssdatafiletype
head_format = (f_maxrec << 16 ! f_rectype)
head_records = 0
finishelsestart ; !ALREADY FULLY OPEN
if f_modeofuse # 2 or f_validaction & 2 = 0 then flag = 266 and ->err
!INCONSISTENT FILE USE
finish
start = dr1; !NOW OPEN, DECODE DESCRIPTOR
len = namel(dr0) * (dr0 & x'FFFFFF')
if f_rectype = ssfformat start ; !FIXED FORMAT
if len # f_minrec then flag = 161 and ->err
!WRONG RECORD LENGTH
irgap = 0; !NO INTER RECORD GAP
finishelsestart
if len > f_maxrec then flag = 161 and ->err
!WRONG RECORD LENGTH
irgap = 2
finish
if f_cur + len + irgap > f_end thenstart
extend(f,flag)
if flag # 0 then flag = 169 and ->err; !OUTPUT EXCEEDED
finish
move(len,start,f_cur + irgap)
if irgap # 0 start ; !PUT IN REC SEPARATOR
len = len + 2
byteinteger(f_cur) <- len >> 8
byteinteger(f_cur + 1) <- len
finish
f_cur = f_cur + len
f_transfers = f_transfers + 1
err:
if flag # 0 then psysmes( - 89,flag); !PRINT MESSAGE AND STOP
end ; !OF PUTSQ
systemroutine getsq(integer chan,dr0,dr1, longinteger dopevdesc)
!SQ ROUTINE FOR ALGOL EQUIVALENT TO READSQ
!DOPE VECTOR DESCRIPTOR IS NOT REQUIRED
record (fdf) name f
integer afd,start,len,irgap,flag,reqlen
flag = 0
unless 1 <= chan <= 80 then flag = 164 and ->err
!INVALID CHAN
afd = fdmap(chan)
if afd = 0 then flag = 151 and ->err; !NOT DEFINED
f == record(afd)
if f_status = 0 then flag = 301 and ->err; !NOT OPEN
if f_status = 2 start ; !OPENED BY OPENSQ - NOW COMPLETE
flag = open(afd,1); !OPEN FOR READING
->err if flag # 0
if ssfformat # f_rectype # ssvformat then flag = 267 and ->err
!INVALID FILETYPE
f_modeofuse = 2; !SEQUENTIAL USE
finishelsestart ; !ALREADY FULLY OPEN
if f_modeofuse # 2 or f_validaction & 2 # 0 then flag = 266 and ->err
!INCONSISTENT FILE USE
finish
!NOW OPEN CORRECTLY
start = dr1
reqlen = namel(dr0) * (dr0 & x'FFFFFF')
if f_cur >= f_end then signal(2,140,0,flag)
!INPUT ENDED
if f_rectype = ssfformat start ; !FIXED FORMAT
if reqlen > f_minrec then reqlen = f_minrec; !RECORD SHORTER THAN REQUEST
len = f_minrec; !THE ACTUAL RECORD LENGTH
irgap = 0
finishelsestart ; !VARIABLE RECORD FORMAT
len = (byteinteger(f_cur) << 8) ! byteinteger(f_cur + 1) - 2
!LENGTH OF DATA IN RECORD
if reqlen > len then reqlen = len
!RECORD SHORTER THAN REQUESTED LENGTH
irgap = 2
finish
move(reqlen,f_cur + irgap,start); !MOVE DATA TO PROGRAM AREA
f_cur = f_cur + irgap + len
holdlengthsq = reqlen
err:
if flag # 0 then psysmes( - 90,flag)
end ; !OF GETSQ
!***********************************************************************
!* *
!* STORE MAPPING ROUTINES *
!* *
!***********************************************************************
externalroutine newsmfile(string (255) s)
string (31) file,size
integer isize,flag,conad,i
record (dahf) name dah
record (frf) fr
setpar(s)
if parmap # 3 then flag = 263 and ->err; !WRONG NO OF PARAMS
file = spar(1)
size = spar(2)
finfo(file,0,fr,flag)
if flag = 0 then flag = 219; !ALREADY EXISTS
if flag # 218 then ->err; !218 MEANS DOES NOT EXIST - OK
isize = pstoi(size)
if isize <= 0 then setfname(size) and flag = 202 and ->err
outfile(file,isize + 32,0,0,conad,flag)
->err if flag # 0
dah == record(conad)
dah_dataend = isize + 32; !TOTAL SIZE
dah_datastart = 32; !LENGTH OF HEADER
dah_filetype = ssdatafiletype; !DATA FILE
dah_format = ssuformat; !UNSTRUCTURED
disconnect(file,i)
err:
comreg(24) = flag; !RETURN CODE
if flag # 0 then psysmes(44,flag)
end ; !OF NEWSMFILE
externalintegerfunction smaddr(integer chan, integername len)
integer flag,afd
record (rf) rr
record (fdf) name f
! SSOPENUSED = 1
!TO INDICATE OPEN USED
unless 0 < chan <= 80 then flag = 223 and ->err
!INVALID CHAN
afd = fdmap(chan)
if afd = 0 then flag = 151 and ->err; !CHAN NOT DEFINED
f == record(afd)
if f_status # 0 then flag = 265 and ->err
!ALREADY OPEN
if f_accessroute = 10 then flag = 294 and ->err
!ILLEGAL USE OF .NULL
connect(f_iden,3,0,0,rr,flag); !TRY AND CONNECT WRITE
if flag = 0 start ; !CONNECTED IN WRITE MODE
f_validaction = 3; !READ AND WRITE
finishelsestart
connect(f_iden,0,0,0,rr,flag); !TRY READ MODE
->err if flag # 0; ! STILL NO GOOD
f_validaction = 1; !ONLY READING ALLOWED
finish
f_status = 3; !OPEN
f_accessroute = 3; !MAPPED FILE
f_link = uinfi(12); !FDLEVEL - TO CAUSE AUTO-CLOSE
len = rr_dataend - rr_datastart
result = rr_conad + rr_datastart
err:
psysmes( - 17,flag)
end ; !OF SMADDR
externalroutine opensm(integer chan,mode, integername ad,len)
!MODE=0 DON'T CARE
!MODE=1 READ ONLY
!MODE=2 READ+WRITE
!ADDRESS RETURNED THROUGH AD, DATALENGTH THROUGH LEN
string (31) file,rest
integer flag,afd
record (frf) fr
record (rf) rr
record (fdf) name f
unless 0 < chan <= 80 then flag = 223 and ->err
!INVALID CHAN
afd = fdmap(chan); !NOTE THAT THIS SETS SSOPENUSED IN BASEFILE TO ENSURE FILE
!IS CLOSED ON THE WAY BACK TO COMMAND
if afd = 0 then flag = 151 and ->err; !CHAN NOT DEFINED
f == record(afd)
if f_status # 0 then flag = 265 and ->err
!ALREADY OPEN
if f_accessroute = 10 then flag = 294 and ->err
!ILLEGAL USE OF .NULL
if mode & 2 = 2 then mode = 3; !ENSURE READ INCLUDED
connect(f_iden,mode,0,0,rr,flag); !TRY AND CONNECT IN REQUESTED MODE
if flag = 0 start ; !CONNECTED IN REQUESTED MODE
unless f_iden - > file.("_").rest then file = f_iden
finfo(file,0,fr,flag)
if fr_apf & x'F0' # 0 then f_validaction = 3 else f_validaction = 1
f_status = 3; !OPEN
f_accessroute = 3; !MAPPED FILE
f_link = uinfi(12); !FDLEVEL - TO CAUSE AUTO-CLOSE
len = rr_dataend - rr_datastart
ad = rr_conad + rr_datastart
finishelsestart
ad = 0; !TO INDICATE FAILURE
len = 0
return
finish
err:
if flag # 0 then psysmes( - 17,flag)
end ; !OF OPENSM
externalroutine closesm(integer chan)
integer flag,afd
record (fdf) name f
unless 0 < chan <= 80 then flag = 223 and ->err
!INVALID CHAN
afd = fdmap(chan)
if afd = 0 then flag = 151 and ->err; !NOT DEFINED
f == record(afd)
if f_status = 0 then flag = 301 and ->err
!CHANNEL NOT OPEN
if f_accessroute # 3 then flag = 266 and ->err
!INCONSISTENT USE
flag = close(afd)
err:
if flag # 0 then psysmes( - 26,flag)
end ; !OF CLOSESM
Externalroutine CHANGESM (integer chan, newsize)
!
!
!---------------------------------------------------------------------%C
C
Modified 29/June/83 C
C
This procedure did not update the Total File Size field C
in the file header presumably because it assumed that C
CHANGEFILESIZE would do it, and it doesnt. C
C
An explicit check now only allows character and data files. C
C
Also error 295, although detected, was never reported. C
C
AGRK C
C
!-----------------------------------------------------------------------
record (fdf) name f {file definition table format}
record (rf ) rr {CONNECT record format}
string (31) file {copy of F_IDEN}
integer flag
integer maxsize {new maximum size of file}
integer oldsize {old size of file taken from DATAEND}
integer afd { address of file definition table for CHAN}
unless 0 < chan <= 80 then flag = 164 and ->err
!INVALID CHAN
afd = fdmap(chan)
if afd = 0 then flag = 151 and ->err; !NOT DEFINED
f == record(afd)
if f_status # 0 then flag = 302 and -> err
!FILE OPEN
file = f_iden
if newsize <= 0 then flag = 295 and -> err; !INVALID FILESIZE
!
! Connect the File (in write mode and in a 'suitable' hole)
!
Connect (file, 3, newsize + 4096, 0, rr, flag); -> err if flag¬= 0
! newsize + 4096 gets the file
! connected in a hole
! which should be large
! enough
if rr_filetype¬= 3 {a character file} and c
rr_filetype¬= 4 {a data file } thenstart
!
{What use someone can make of the } Disconnect (file,flag)
{ability to access a character } Setfname (file)
{file as a store-map file escapes } flag= 267; !INVALID FILE TYPE
{me right now, but we will let it } -> err
{through. However all the other }
{file types are definitely invalid} finish
!Calculate new file sizes:
!
newsize= integer(rr_conad+4) + newsize ; !increment newsize by header length
maxsize= x'fffff000' & (newsize+4095); !calculate the maximum file length
oldsize= integer(rr_conad ) ; ! remember current actual length
!and update the file header:
!
integer(rr_conad )= newsize; !update actual length of file
integer(rr_conad+8)= maxsize; !update maximum length of file
!
! Tidy Up and Disconnect
!
Fill (maxsize-newsize,rr_conad+newsize,0) if newsize<oldsize
{zero out the hole in the last page}
{ if the file size has been made }
{ smaller }
Disconnect (file,flag)
if flag¬= 0 then -> err
!
! Finally Update the Physical File Size
!
Changefilesize (file,newsize,flag)
!
!It might be considered sailing alittle bit close to the wind
!to update the file header before changing the physical file
!size but it does save a Connect and a Disconnect.
err: if flag¬= 0 then Psysmes (-33, flag)
end ; !of CHANGESM
!***********************************************************************
!* *
!* FORTRAN DEFINE FILE *
!* *
!***********************************************************************
systemintegerfunction fortrandf(integer dsnum,numblocks,blksize,asvardescad)
!***********************************************************************
!* *
!* Called by FORTRAN statement DEFINE FILE. If channel is open ignore *
!* call. Otherwise try and connect the file, first write, then read. *
!* If it does not exist create a new one taking size from *
!* NUMBLOCKS*BLKSIZE. If it does exist check that BLKSIZE agrees with *
!* file and that NUMBLOCKS is not greater than in file. Extract info *
!* about associated variable and store in file descriptor. *
!* *
!***********************************************************************
!
!Modified 6/December/82
!
!If ASVARDESCAD is zero then FORTRANDF will have been
! called from NEW FILE OP to open a file for direct
! -access for FORTRAN77. The file/channel will have
! been connected via a DEFINE command with the third
! parameter set to 'D'.
!
record (fdf) name f
record (dahf) name h
record (rf) rr
!
owninteger dummy f77 asvar= 0
! DUMMY F77 ASVAR is a variable pointed at by a FORTRAN77
! File Definition Table and which pretends to be an
! Associated Variable to fool OUTREC and INREC when
! they are handling Direct-Access requests.
!
integer flag,afd,size,headr
! SSOPENUSED = 1
unless 1 <= dsnum <= 80 thenresult = 164
!INVALID CHAN
afd = fdmap(dsnum)
if afd = 0 thenresult = 151; !NOT DEFINED
f == record(afd)
if f_status # 0 thenresult = 0; !ALREADY OPEN - IGNORE CALL
if f_accessroute = 10 thenresult = 294; !ILLEGAL USE OF .NULL
f_validaction = 67; !READ,WRITE,SEEK BY DEFAULT
f_modeofuse = 13; !FORTRAN DA
!FIRST TRY AND CONNECT IN WRITE MODE
connect(f_iden,3,0,0,rr,flag)
if flag = 218 start ; !FILE DOES NOT EXIST
!
if asvardescad = 0 thenstart
!
! Extract Record and File Sizes for a FORTRAN77 Open
!
blksize = f_maxrec
numblocks = (f_maxsize - 32) // blksize
finish
headr = optheader(blksize); !GET OPT FILE HEADER SIZE
size = headr + (blksize * numblocks)
outfile(f_iden,size,0,0,rr_conad,flag)
!TRY AND CREATE
if flag # 0 thenresult = flag
h == record(rr_conad)
h_dataend = size
h_datastart = headr
h_filetype = ssdatafiletype
h_format = (blksize << 16) ! ssfformat; !FIXED FORMAT
h_records = numblocks
->opened
finishelsestart ; !FAILED TO CONNECT WRITE
if flag # 0 start
connect(f_iden,0,0,0,rr,flag)
if flag # 0 thenresult = flag
f_validaction = 65; !READ AND SEEK ONLY
finish
finish
h == record(rr_conad)
if asvardescad = 0 thenstart ; ! (FORTRAN77 specific)
!
blksize = h_format >> 16
numblocks = (h_data end - h_data start) // blksize
finish
if (h_dataend - h_datastart) < (numblocks * blksize) or c
h_filetype # ssdatafiletype or h_format & x'FF' # ssfformat then c
result = 179
!INVALID FILE FOR DA
if h_format >> 16 # blksize thenresult = 180
!WRONG RECORD LENGTH FOR DA
opened:
unless asvardescad = 0 thenstart
!
! Set the FORTE Associated Variable address
!
if integer(asvardescad) >> 24 = x'58' then f_flags = f_flags ! 4 else c
f_flags = f_flags & x'BF'
!Test if the Associated Variable is an Integer*2 or Integer*4
!
f_asvar = integer(asvardescad + 4)
finishelse f_asvar = addr(dummy f77 asvar)
f_conad = rr_conad
f_datastart = h_datastart; !HEADER MIGHT NOT BE 32 BYTES
f_rectype = 1; !FIXED
f_maxsize = h_records
f_maxrec = blksize
f_minrec = blksize
f_recsize = blksize
f_status = 3
f_link = uinfi(12); !FDLEVEL - TO CAUSE AUTO CLOSE
f_curstate = 1
f_darecnum = 1; !ASSUME STARTS AT BLOCK 1
result = 0
end ; !OF FORTRANDF
!***********************************************************************
!* *
!* IMP DIRECT ACCESS ROUTINES *
!* *
!***********************************************************************
constantinteger recsize= 1024; !FIXED RECORD SIZE PROTEM
externalroutine openda(integer chan)
integer afd,flag
record (rf) rr
record (dahf) name h
record (fdf) name f
! SSOPENUSED = 1
unless 1 <= chan <= 80 then flag = 164 and ->err
!INVALID CHAN
afd = fdmap(chan)
if afd = 0 then flag = 151 and ->err; !NOT DEFINED
f == record(afd)
if f_status # 0 then flag = 176 and ->err
!ALREADY OPEN
if f_accessroute = 10 then flag = 294 and ->err
!ILLEGAL USE OF .NULL
f_validaction = 3; !READ AND WRITE - DEFAULT
f_modeofuse = 3; !DIRECT ACCESS
!FIRST TRY AND CONNECT IN WRITE MODE
connect(f_iden,3,0,0,rr,flag); !CONNECT IN WRITE MODE
if flag = 218 start ; !FILE DOES NOT EXIST
outfile(f_iden,f_maxsize,0,0,rr_conad,flag)
!CREATE IT
->err if flag # 0
h == record(rr_conad)
h_dataend = f_maxsize
h_datastart = recsize; !TO GIVE ALIGNMENT
h_filetype = ssdatafiletype
h_format = (recsize << 16) ! 1; !F1024
h_records = (h_dataend - h_datastart) // recsize
finishelsestart
if flag # 0 start ; !FAILED TO CONNECT IN WRITE MODE
connect(f_iden,0,0,0,rr,flag); !TRY IN READ MODE
->err if flag # 0
f_validaction = 1; !ONLY READ ALLOWED
finish
finish
h == record(rr_conad)
if h_filetype # ssdatafiletype or h_format # (recsize << 16) ! 1 then c
flag = 267 and ->err
!INVALID FILETYPE
f_conad = rr_conad
f_transfers = h_records
f_status = 3
f_link = uinfi(12); !FDLEVEL - TO CAUSE AUTO CLOSE
err:
if flag # 0 then psysmes( - 79,flag)
end ; !OF OPENDA
externalroutine closeda(integer chan)
integer afd,flag
record (fdf) name f
unless 1 <= chan <= 80 then flag = 164 and ->err
!INVALID CHANNEL
afd = fdmap(chan)
if afd = 0 then flag = 151 and ->err; !NOT DEFINED
f == record(afd)
if f_modeofuse # 3 then flag = 171 and ->err
!INVALID OPERATION ON FILE
if f_status = 0 then flag = 301 and ->err
!NOT OPEN
flag = close(afd)
err:
if flag # 0 then psysmes( - 80,flag)
end ; !OF CLOSEDA
externalroutine writeda(integer chan, integername sect, integer sdr0, c
sdr1,edr0,edr1)
integer afd,start,len,flag,sectneeded
record (fdf) name f
flag = 0
unless 1 <= chan <= 80 then flag = 164 and ->err
!INVALID CHAN
afd = fdmap(chan)
if afd = 0 then flag = 151 and ->err; !NOT DEFINED
f == record(afd)
if f_status = 0 then flag = 301 and ->err
!NOT OPEN
if f_modeofuse # 3 then flag = 171 and ->err
!INVALID USE
!NOW CALCULATE START ADDRESS AND LENGTH
start = sdr1; !ADDRESS PART OF FIRST DESCRIPTOR
len = edr1 - sdr1 + namel(edr0)
!LENGTH TO BE MOVED
if len < 1 then flag = 177 and ->err; !ADDRESSES INSIDE-OUT
sectneeded = (len + recsize - 1) // recsize; !NO OF SECTIONS INVOLVED
unless 1 <= sect <= f_transfers - (sectneeded - 1) then flag = 158 and ->err
!RECORD OUT OF RANGE
move(len,start,f_conad + integer(f_conad + 4) + recsize * (sect - 1))
!MOVE IN THE DATA
sect = sect + sectneeded - 1
err:
if flag # 0 then psysmes( - 81,flag)
end ; !OF WRITEDA
externalroutine readda(integer chan, integername sect, integer sdr0,sdr1, c
edr0,edr1)
integer afd,start,len,flag,sectneeded
record (fdf) name f
flag = 0
unless 1 <= chan <= 80 then flag = 164 and ->err
!INVALID CHAN
afd = fdmap(chan)
if afd = 0 then flag = 151 and ->err; !NOT DEFINED
f == record(afd)
if f_status = 0 then flag = 301 and ->err
!NOT OPEN
if f_modeofuse # 3 then flag = 171 and ->err
!INVALID USE
!NOW CALCULATE START ADDRESS AND LENGTH
start = sdr1; !ADDRESS PART OF FIRST DESCRIPTOR
len = edr1 - sdr1 + namel(edr0)
!LENGTH TO BE MOVED
if len < 1 then flag = 177 and ->err; !ADDRESSES INSIDE-OUT
sectneeded = (len + recsize - 1) // recsize; !NO OF SECTIONS INVOLVED
unless 1 <= sect <= f_transfers - (sectneeded - 1) then flag = 158 and ->err
!RECORD OUT OF RANGE
move(len,f_conad + integer(f_conad + 4) + recsize * (sect - 1),start)
!MOVE IN THE DATA
sect = sect + sectneeded - 1
err:
if flag # 0 then psysmes( - 82,flag)
end ; !OF READDA
!***********************************************************************
!* *
!* ALGOL DIRECT ACCESS ROUTINES *
!* *
!***********************************************************************
systemroutine openda1 alias "S#OPENDA" (integer chan)
!DA ROUTINE FOR ALGOL
integer afd,flag
record (rf) rr
record (dahf) name h
record (fdf) name f
! SSOPENUSED = 1
unless 1 <= chan <= 80 then flag = 164 and ->err
!INVALID CHAN
afd = fdmap(chan)
if afd = 0 then flag = 151 and ->err; !NOT DEFINED
f == record(afd)
if f_rectype # 1 then flag = 179 and ->err; !MUST BE FIXED
if f_status # 0 then flag = 176 and ->err
!ALREADY OPEN
if f_accessroute = 10 then flag = 294 and ->err
!ILLEGAL USE OF .NULL
f_validaction = 3; !READ AND WRITE - DEFAULT
f_modeofuse = 3; !DIRECT ACCESS
!FIRST TRY AND CONNECT IN WRITE MODE
connect(f_iden,3,0,0,rr,flag); !CONNECT IN WRITE MODE
if flag = 218 start ; !FILE DOES NOT EXIST
outfile(f_iden,f_maxsize,0,0,rr_conad,flag)
!CREATE IT
->err if flag # 0
h == record(rr_conad)
h_datastart = optheader(f_minrec); !GET OPT FILE HEADER SIZE
h_filetype = ssdatafiletype
h_format = (f_minrec << 16) ! 1; !FIXED
h_records = (f_maxsize - h_datastart) // f_minrec
h_dataend = h_datastart + h_records * f_minrec
finishelsestart
if flag # 0 start ; !FAILED TO CONNECT IN WRITE MODE
connect(f_iden,0,0,0,rr,flag); !TRY IN READ MODE
->err if flag # 0
f_validaction = 1; !ONLY READ ALLOWED
finish
finish
h == record(rr_conad)
if h_filetype # ssdatafiletype or h_format # (f_minrec << 16) ! 1 then c
flag = 267 and ->err
!INVALID FILETYPE
f_conad = rr_conad
f_transfers = h_records
f_status = 3
f_link = uinfi(12); !FDLEVEL - TO CAUSE AUTO CLOSE
err:
if flag # 0 then psysmes( - 79,flag)
end ; !OF OPENDA
systemroutine closeda1 alias "S#CLOSEDA" (integer chan)
!DA ROUTINE FOR ALGOL
integer afd,flag
record (fdf) name f
unless 1 <= chan <= 80 then flag = 164 and ->err
!INVALID CHANNEL
afd = fdmap(chan)
if afd = 0 then flag = 151 and ->err; !NOT DEFINED
f == record(afd)
if f_modeofuse # 3 then flag = 171 and ->err
!INVALID OPERATION ON FILE
if f_status = 0 then flag = 301 and ->err
!NOT OPEN
flag = close(afd)
err:
if flag # 0 then psysmes( - 80,flag)
end ; !OF CLOSEDA
systemroutine putda(integer chan, integername sect, integer dr0,dr1, c
longinteger dopevdesc)
!DA ROUTINE FOR ALGOL EQUIVALENT TO WRITEDA
!DOPE VECTOR DESCRIPTOR IS NOT USED
integer afd,start,len,flag,sectneeded
record (fdf) name f
flag = 0
unless 1 <= chan <= 80 then flag = 164 and ->err
!INVALID CHAN
afd = fdmap(chan)
if afd = 0 then flag = 151 and ->err; !NOT DEFINED
f == record(afd)
if f_status = 0 then flag = 301 and ->err
!NOT OPEN
if f_modeofuse # 3 then flag = 171 and ->err
!INVALID USE
!NOW CALCULATE START ADDRESS AND LENGTH
start = dr1; !ADDRESS PART OF FIRST DESCRIPTOR
len = namel(dr0) * (dr0 & x'FFFFFF')
!LENGTH TO BE MOVED
sectneeded = (len + f_minrec - 1) // f_minrec; !NO OF SECTIONS INVOLVED
unless 1 <= sect <= f_transfers - (sectneeded - 1) then flag = 158 and ->err
!RECORD OUT OF RANGE
move(len,start,f_conad + integer(f_conad + 4) + f_minrec * (sect - 1))
!MOVE IN THE DATA
sect = sect + sectneeded
err:
if flag # 0 then psysmes( - 92,flag)
end ; !OF PUTDA
systemroutine getda(integer chan, integername sect, integer dr0,dr1, c
longinteger dopevdesc)
!DA ROUTINE FOR ALGOL, EQUIVALENT TO READDA
!DOPE VECTOR DESCRIPTOR NOT USED
integer afd,start,len,flag,sectneeded
record (fdf) name f
flag = 0
unless 1 <= chan <= 80 then flag = 164 and ->err
!INVALID CHAN
afd = fdmap(chan)
if afd = 0 then flag = 151 and ->err; !NOT DEFINED
f == record(afd)
if f_status = 0 then flag = 301 and ->err
!NOT OPEN
if f_modeofuse # 3 then flag = 171 and ->err
!INVALID USE
!NOW CALCULATE START ADDRESS AND LENGTH
start = dr1; !ADDRESS PART OF FIRST DESCRIPTOR
len = namel(dr0) * (dr0 & x'FFFFFF')
!LENGTH TO BE MOVED
sectneeded = (len + f_minrec - 1) // f_minrec; !NO OF SECTIONS INVOLVED
unless 1 <= sect <= f_transfers - (sectneeded - 1) then flag = 158 and ->err
!RECORD OUT OF RANGE
move(len,f_conad + integer(f_conad + 4) + f_minrec * (sect - 1),start)
!MOVE IN THE DATA
sect = sect + sectneeded
err:
if flag # 0 then psysmes( - 93,flag)
end ; !OF GETDA
endoffile