!***********************************************************************
!* *
!* FORTRAN77 - EMAS Interface routines *
!* The user view of these routines is described in the EMAS Users' *
!* Guide. Many of them involve CHARACTER variables as parameters. *
!* These are accessed in the IMP code by their descriptor, which is *
!* treated as a pair of integers DR0 and DR1. DR0 contains the length *
!* of the variable in its least significant 24 bits. DR1 contains the *
!* address of the variable. *
!* The normal FORTRAN77 assigment rules apply. If too short then *
!* space fill on right. If too long then truncate on right. *
!* *
!***********************************************************************
!* Version 2 RDE UKC 06/11/82: FPROMPT uses UINFI(17) to check length
!* FCALL uses CASTOUT to allow spaces/lower case
!* Version 3 ERCC 30/08/84: FEXIST returns 1 for logical true, not -1
!* Version 4 RDE UKC 20/09/84: FPARAM returns string length as result
!* Version 5 ERCC 21/11/84: FEXIST and FPROMPT use the TOISO routine
!* so they will work when called from programs
!* compiled with PARM EBCDIC.
constinteger lengthmask=x'ffffff'; !used to extract length from top half of descriptor
externalroutinespec prompt(string (15) s)
externalroutinespec call(string (31) command, string (255) parameters)
systemroutinespec castout(stringname pstr)
systemroutinespec fill(integer len,ad,char)
systemroutinespec etoi(integer ad,len)
systemroutinespec itoe(integer ad,len)
systemroutinespec uctranslate(integer ad,len)
externalstringfnspec interrupt
externalintegerfnspec uinfi(integer n)
externalstringfnspec uinfs(integer n)
systemroutinespec move(integer len,from,to)
externalintegerfnspec exist(string (31) s)
routine removespaces(stringname s)
!machine code version may be available in the BASEFILE
string (255) s1,s2
while s->s1.(" ").s2 cycle
s=s1.s2
repeat
end ; !of removespaces
routine toiso(stringname s, integername flag)
!checks whether any character has value > 127. If it has then
!translate from EBCDIC to ISO. This is not a perfect test
!but will deal correctly with most cases
integer len,i
len=length(s)
if len=0 thenreturn ; !null string
cycle i=1,1,len
if charno(s,i)&x'80'#0 start
etoi(addr(s)+1,len)
flag=1; !to indicate that a translation was done
return
finish
repeat
flag=0; !to indicate that no translation was done
end ; !of toiso
externalroutine fuinfi(integername n,res)
res=uinfi(n)
end ; !of fuinfi
externalroutine fuinfs(integername n, integer dr0,dr1, integername len)
string (31) hold
integer maxlen
maxlen=dr0&lengthmask
fill(maxlen,dr1,' '); !space fill
hold=uinfs(n)
len=length(hold)
if len>maxlen then len=maxlen
move(len,addr(hold)+1,dr1)
end ; !of fuinfs
externalroutine finterrupt(integer dr0,dr1, integername len)
integer maxlen
string (15) hold
maxlen=dr0&lengthmask
fill(maxlen,dr1,' '); !space fill the chaacter variable
hold=interrupt
len=length(hold)
if len>maxlen then len=maxlen; !truncation needed
move(len,addr(hold)+1,dr1)
end ; !of finterrupt
externalroutine fupper(integer dr0,dr1)
uctranslate(dr1,dr0&lengthmask)
end ; !of fupper
externalroutine fetoi(integer dr0,dr1)
etoi(dr1,dr0&lengthmask)
end ; !of fetoi
externalroutine fitoe(integer dr0,dr1)
itoe(dr1,dr0&lengthmask)
end ; !of fitoe
externalroutine fcall(integer cdr0,cdr1,pdr0,pdr1)
!this routine enables a FORTRAN77 program to call an EMAS
!command. It takes two parameters which must be of type CHARACTER.
!e.g. CALL FCALL('LIST','F8,.OUT')
string (255) command,param
integer clen,plen,flag
clen=cdr0&lengthmask;
if clen>31 then clen=31; !maximum length of a command name
plen=pdr0&lengthmask
if plen>255 then plen=255; !maximum length of a parameter string
move(clen,cdr1,addr(command)+1)
length(command)=clen
move(plen,pdr1,addr(param)+1)
length(param)=plen
toiso(command,flag)
!this subtle bit of code is designed to deal with the possibility
!that the parameter does not contain any alpha-numeric characters.
!if it was necessary to translate the command name then clearly it must
!be necessary to translate the parameters
if flag#0 then etoi(addr(param)+1,plen)
removespaces(command)
uctranslate(addr(command)+1,clen); !can be removed if CALL is changed to do the translation
castout(param); !translates except inside quotes
call(command,param)
end ; !of fcall
externalintegerfn fexist(integer dr0,dr1)
!equivalent of EXIST for FORTRAN77 users. Parameter in F77 is a character
!variable
string (255) hold
integer len,res,i
len=dr0&lengthmask
if len>255 then len=255
length(hold)=len
move(len,dr1,addr(hold)+1)
toiso (hold,i)
removespaces(hold)
res=exist(hold)
if res#0 then res=1; !logical function in f77 returns 1 for true
result =res
end ; !of fexist
externalroutine fprompt(integer dr0,dr1)
string (255) hold
integer len,maxlen,i
len=dr0&lengthmask
maxlen=uinfi(17)
if len>maxlen then len=maxlen
length(hold)=len
move(len,dr1,addr(hold)+1)
toiso (hold,i)
prompt(hold)
end ; !of fprompt
externalintegerfunction fparam(integer dr0,dr1, integername len)
!this routine should be called by a FORTRAN77 command to massage
!the parameter passed to it by the command interpreter. The problem
!is that the command interpreter stores the parameters as an IMP string
!in the users CHARACTER parameter. All the routine does is to
!move the text down 1 byte and space fill the area.
integer maxlen
maxlen=dr0&lengthmask; !the length provided by the user
len=byteinteger(dr1); !the string length as for an IMP string
if len>maxlen then len=maxlen; !user did not provide enough room
move(len,dr1+1,dr1); !move the text to start of the character variable
if len<maxlen then fill(maxlen-len,dr1+len,' ')
result = len
end ; !of fparam
endoffile