!* 15/12/85
!*
{\VAX}%include "ftn_ht"
{\VAX}%include "ftn_fmts1"
{\VAX}%include "ftn_consts2"
{\VAX}%include "ebits_ecodes1"
{\VAX}%include "ebits_especs1"
!*
!{VAX}%include "ht.inc"
!{VAX}%include "fmts1.inc"
!{VAX}%include "consts1.inc"
!{VAX}%include "ecodes1.inc"
!{VAX}%include "especs1.inc"
!*
!***********************************************************************
!* Exports *
!***********************************************************************
!*
%routinespec Init Data(%integer Mode,Adcom,Rel,Avers)
%routinespec Tidy Data(%integer Ep,IIN,Len)
%integerfnspec Dv Space(%integer LEN,%integername IIN)
%integerfnspec Stack Space(%integer Len)
%integerfnspec Scalar Space(%integer Len,%integername IIN)
%integerfnspec Array Space(%integer Len,%integername IIN)
%integerfnspec Const Space(%integer Len,%integername IIN)
%integerfnspec Char Ref(%integer IIN,Disp,Len)
%routinespec Set Array Head(%integer Adv,IIN,Disp,Addrzero,Type)
%routinespec Add Data Item(%integer Ptr,Copies,Disp,Len,Ad)
%integerfnspec Newcmn(%integer Init,Iden,%integername Refad)
%integerfnspec Alloc Char(%integer Len,Ad,%integername IIN)
%routinespec Syscall(%integer Proc)
%routinespec Usercall(%integer Form,Iden)
%routinespec Intrincall(%integer Form,Index,Mode)
%routinespec Alloc Temp(%record(TMPF)%name Tmp)
%integerfnspec Vtaddr(%integer Ad)
%integerfnspec Dtaddr(%integer Ad)
!*
%routinespec Ldstkaddr(%integer Offset)
%routinespec Ldstk(%integer Offset,Bytes)
%routinespec Ststk(%integer Offset,Bytes)
!*
!*
!***********************************************************************
!* Imports *
!***********************************************************************
!*
%externalroutinespec Alloc(%integer Ptr)
%externalroutinespec Lfault(%integer Er)
%externalroutinespec Init End(%integer Ep,Info)
%externalintegerfnspec Dictspace(%integer Length)
%externalroutinespec Dicful
%externalroutinespec Extful
!*
!***********************************************************************
!* Local procs *
!***********************************************************************
!*
!*
%constinteger Max Area Size=X'400000'
!*
%ownrecord(Comfmt)%name Com
%owninteger Init9,Area9offset
%owninteger Techain
%owninteger Ruse1,Ruse2,Ruse3,Lastreg
%owninteger Labblocks
%owninteger Area10size
!*
!*
{%conststring(6)%array Intrprocs(0:27) = "", }
{ "IABS" ,"ABS" ,"MOD" ,"AMOD" , }
{ "ISIGN" ,"SIGN" ,"NINT" ,"AINT" , }
{ "ANINT" ,"IDIM" ,"DIM" ,"DINT" , }
{ "DNINT" ,"IDNINT","DABS" ,"DMOD" , }
{ "DSIGN" ,"DDIM" ,"DPROD" ,"AIMAG" , }
{ "CONJG" ,"LEN" ,"INDEX" ,"LGE" , }
{ "LGT" ,"LLE" ,"LGE" }
!*
%conststring(7)%array Gen Name(0:69) = "",
"sqrt" ,"exp" ,"log" ,"log10" ,
"sin" ,"cos" ,"tan" ,"cot" ,
"asin" ,"acos" ,"atan" ,"atan2" ,
"sinh" ,"cosh" ,"tanh" ,"" ,
"" ,"cabs" ,"cdabs" ,"abs" ,
"lge" ,"lgt" ,"lle" ,"llt" ,
"dsqrt" ,"dexp" ,"dlog" ,"dlog10",
"dsin" ,"dcos" ,"dtan" ,"dcot" ,
"dasin" ,"dacos" ,"datan" ,"datan2",
"dsinh" ,"dcosh" ,"dtanh" ,"" ,
"csqrt" ,"cexp" ,"clog" ,"" ,
"csin" ,"ccos" ,"cdsqrt","cdexp" ,
"cdlog" ,"" ,"cdsin" ,"cdcos" ,
"powii" ,"powri" ,"powdi" ,"powci" ,
"powzi" ,"powrr" ,"powdd" ,"powcc" ,
"powzz" ,"erf" ,"erfc" ,"gamma" ,
"lgamma","derf" ,"derfc" ,"dgamma",
"dlgamma"
!*
%constbyteintegerarray Genparams(0:69)= 0,
1(11),2,1(3),0(2),1(3),4(4),1(11),2,1(3),
0,2(3),0,2(5),0,2(5),3(2),2(2),3(2),1(8)
!*
%constintegerarray Genprocpdesc(0:69)= 0,
X'10004',X'10004',X'10004',X'10004',
X'10004',X'10004',X'10004',X'10004',
X'10004',X'10004',X'10004',X'20008',
X'10004',X'10004',X'10004',X'10004',
X'10004',X'10004',X'10004',X'10004',
X'10004',X'10004',X'10004',X'10004',
X'10004',X'10004',X'10004',X'10004',
X'10004',X'10004',X'10004',X'10004',
X'10004',X'10004',X'10004',X'20008',
X'10004',X'10004',X'10004',X'10004',
X'10004',X'10004',X'10004',X'10004',
X'10004',X'10004',X'10004',X'10004',
X'10004',X'10004',X'10004',X'10004',
X'10004',X'10004',X'10004',X'10004',
X'10004',X'10004',X'10004',X'10004',
X'10004',X'10004',X'10004',X'10004',
X'10004',X'10004',X'10004',X'10004',
X'10004'
!*
%constbyteintegerarray Variant(0:15) = %c
0, 0, 0, 0,24, 0,40,46, 0, 0, 0, 0, 0, 0, 0, 0
!*
%constintegerarray Genproctype(0:69)= 0 ,
X'10402',X'10402',X'10402',X'10402',
X'10402',X'10402',X'10402',X'10402',
X'10402',X'10402',X'10402',X'10402',
X'10402',X'10402',X'10402',X'10402',
X'10402',X'10402',X'10402',X'10402',
X'10401',X'10401',X'10401',X'10401',
X'10802',X'10802',X'10802',X'10802',
X'10802',X'10802',X'10802',X'10802',
X'10802',X'10802',X'10802',X'10802',
X'10802',X'10802',X'10802', 0 ,
X'10000',X'10000',X'10000', 0 ,
X'10000',X'10000',X'10000',X'10000',
X'10000', 0 ,X'10000',X'10000',
X'10401',X'10402',X'10802',X'10000',
X'10000',X'10402',X'10802',X'10000',
X'10000',X'10402',X'10402',X'10402',
X'10402',X'10802',X'10802',X'10802',
X'10802'
!*
%ownintegerarray Genprocref(0:69)
!*
%conststring(9)%array Sysprocs(0:20)= %c
"f_aux" ,"f_stop" ,"f_pause" ,"f_ioa" ,"f_iob" ,
"f_ioc" , "f_iod" ,"f_ioe" ,"f_iof" ,"f_file" ,
"s#stop" ,"f_rterr" ,"f_ioar" ,"f_iobr" ,"f_iog" ,
"f_cpstr","f_concat","f_index" ,"f_ibits","f_ishftc",
"f_pcheck"
!*
%constbyteintegerarray Sysparams(0:20) = %c
2, 2, 2, 2, 2,
2, 2, 2, 2, 2,
0, 3, 2, 2, 2,
6, 4, 4, 3, 2,
4
!*
%constintegerarray Sysprocpdesc(0:20)= %c
X'20008',X'20008',X'20008',X'20008',X'20008',
X'20008',X'20008',X'20008',X'20008',X'20008',
0,X'3000C',X'20008',X'20008',X'20008',
X'60018',X'40010',X'40010',X'3000C',X'20008',
X'400010'
!*
%constintegerarray Sysproctype(0:20)= %c
X'10000',X'10000',X'10000',X'10401',X'10401',
X'10401',X'10401',X'10401',X'10401',X'10401',
X'10000',X'10000',X'10401',X'10401',X'10401',
X'10000',X'10000',X'10401',X'10401',X'10401',
X'10000'
!*
%ownintegerarray Sysprocref(0:31)
!*
%ownintegerarray Buffbase(0:8)
!*
%ownintegerarray Area2(0:31)
%ownintegerarray Areabase(0:255)
!*
%recordformat Cmfmt(%integer IIN,Init,%integer Len,
%integer Ref,%string(31) Id)
%ownrecord(Cmfmt)%array Cm(0:255)
!*
%owninteger Curfnid
%owninteger Nextcmn
%owninteger Filler
!*
{\VAX}%include "ftn_copy1"
!{VAX}%include "copy1.inc"
!*
%externalroutine Init Data(%integer Mode,Adcom,Rel,Avers)
%integer I
Com==record(Adcom)
!*
%if Mode=0 %thenstart;! initialisation at start of compilation
Einitialise(2,Avers,addr(Com_Stackca),addr(Com_Glaca),
Com_Control)
Init End(0,Adcom)
Com_Cmncnt=0
Nextcmn=11
%cycle I=0,1,31
Sysprocref(I)=0
%repeat
%cycle I=0,1,69
Genprocref(I)=0
%repeat
!*
%cycle I=0,1,31
Area2(I)=0
%repeat
!*
%cycle I=0,1,255
Areabase(I)=0
%repeat
!*
Com_Diagca=8
Com_Ioareaca=0
Com_Gstca=0
Com_Codeca=0
Area2(0)=M'F77 '
Area2(4)=X'02000000'
Area2(8) =M'F77 '
Area2(9) =X'10001';! init marker
Area2(10)=Rel
Area2(11)=Com_Control
Area2(12)=Com_Options1
Area2(13)=Com_Options2
Area2(15)=M'####'
Area10size=0
!*
Ed4(DIAGS,0,M'F77 ')
Ed4(DIAGS,4,M'diag')
%if TARGET=IBM %thenstart
%cycle I=2,1,8
%unless I=3 %then Efix(GLA,Glaoffset+I<<2 +32,I,0)
%repeat
I=132
Com_Glaca=Glaoffset+108
Com_Scalarca=4;! to avoid possible confusion with 0 fn result @
%finishelsestart
I=32
Com_Glaca=Glaoffset
Com_Scalarca=0
%finish
Edbytes(GLA,0,I,addr(Area2(0)))
!*
%if Com_F77parm&4=0 %then Filler=X'8181' %else Filler=0
%finish
Labblocks=0
Techain=0
%end;! Init Data
!*
%externalroutine Tidy Data(%integer Ep,IIN,Len)
%ownstring(5) Locid="F_LOC"
%integer I,J,K
%if Ep=1 %thenstart;! enter a common length
%if Com_Cmncnt#0 %thenstart
%cycle I=1,1,Com_Cmncnt
%if Cm(I)_IIN=IIN %thenstart
%if Len>Cm(I)_Len %then Cm(I)_Len=Len
%return
%finish
%repeat
%finish
%return
%finish
!*
%if Ep=2 %thenstart;! tidy up at end of compilation
%if Area10size>0 %thenstart
!! Qput(19,2,Glaoffset+72,10)
J=(10<<16)!X'C'
%if Filler#0 %then J=J!X'10'
!! Qput(16,J,Area10size,addr(Locid))
%finish
%if Com_Cmncnt#0 %thenstart;! define commons
%cycle I=1,1,Com_Cmncnt
EendCommon(CM(I)_IIN,CM(I)_Len)
J=(Cm(I)_IIN<<16)!Cm(I)_Init!9;! init, common and preset bits
%if Filler#0 %then J=J!X'10'
!! Qput(16,J,Cm(I)_Len,addr(Cm(I)_Id))
%repeat
%finish
%finish
%end
!*
!*****************************************************************************
!* *
!* Pseudo-op load and store operations *
!* *
!*****************************************************************************
!*
%externalroutine Ldstkaddr(%integer Offset)
Estkaddr(STACK,Offset,0,0)
%end;! Ldstkaddr
!*
%externalroutine Ldstk(%integer Offset,Bytes)
Estkdir(STACK,Offset,0,Bytes)
%end;! Ldstk
!*
%externalroutine Ststk(%integer Offset,Bytes)
Estkdir(STACK,Offset,0,Bytes)
Eop(ESTORE)
%end;! Ststk
!*
!*****************************************************************************
!* *
!* Data initialisation, common *
!* *
!*****************************************************************************
!*
%externalroutine Add Data Item(%integer Ptr,Copies,Disp,Len,Ad)
%record(PRECF)%name PP
%record(ARRAYDVF)%name DVREC
%integer Base,IIN
! %if Len>255 %AND COUNT>1 %thenstart
! %while COUNT>1 %cycle
! ADD DATA ITEM(AREA,PTR,1,DISP,Len,AD)
! DISP=DISP+Len
! COUNT=COUNT-1
! %repeat
! %finish
!*
ALLOC(PTR)
PP==record(COM_ADICT+PTR)
%if PP_CLASS&4#0 %thenstart;! array
DVREC==record(COM_ADICT+PP_ADDR4)
BASE=DVREC_ADFIRST
%finishelsestart;! scalar
BASE=PP_ADDR4
%finish
IIN=PP_IIN
! %if IIN=9 %thenstart
! %if Init9=0 %thenstart;! map area 9 into area 5
! Init9=1
! Area9offset=Com_Gstca
! Premap(5,9,Area9offset,Com_Zgstca)
! Com_Gstca=Com_Gstca+Com_Zgstca
! Com_Zgstca=0
! %finish
! IIN=5
! Base=Base+Area9offset
! %finish
Base=Base+Disp
Ad=Ad+Com_Adict
%if Copies<=1 %thenstart
Edbytes(IIN,Base,Len,Ad)
%finishelsestart
Edpattern(IIN,Base,Copies,Len,Ad)
%finish
%end;! Add Data Item
!*
%externalintegerfn Newcmn(%integer Init,Iden,%integername Refad)
%string(31) T
%integer I,K,IIN
T<-string(Com_Anames+Iden)
%if Com_Cmncnt#0 %thenstart
%cycle I=1,1,Com_Cmncnt
%if Cm(I)_Id=T %thenstart
IIN=Cm(I)_IIN
->Setref
%finish
%repeat
%finish
Com_Cmncnt=Com_Cmncnt+1
%if Com_Cmncnt>64 %thenstart
Lfault(322);! too many
Com_Cmncnt=1
%finish
I=Com_Cmncnt
IIN=Nextcmn
Nextcmn=Nextcmn+1
Cm(I)_IIN=IIN
Cm(I)_Id=T
%if T="F#BLCM" %then K=2 %else K=0;! blank common
Cm(I)_Init=K
Cm(I)_Ref=0
Cm(I)_Len=0
Ecommon(IIN,T)
Setref:
%if Init#0 %thenstart
Cm(I)_Init=4 {possible check for multiple init}
Refad=IIN
%finishelsestart
%if Cm(I)_Ref=0 %thenstart;! allocate ref location
Areabase(IIN)=Com_Glaca
Cm(I)_Ref=Com_Glaca
Efix(GLA,Com_Glaca,IIN,0)
Com_Glaca=Com_Glaca+4
%finish
Refad=Cm(I)_Ref
%finish
%result=IIN
%end;! Newcmn
!*
!*****************************************************************************
!* *
!* Fixups *
!* *
!*****************************************************************************
!*
%externalintegerfn Char Ref(%integer IIN,Disp,Len)
%integer J
J=Scalar Space(8,IIn);! for descriptor (which is %integer Len,Byte Address)
Ed4(IIN,J,Len)
Ed4(IIN,J+4,0);! since the ref is in bytes it must be set dynamically
%result=J
%end;! Char Ref
!*
%externalroutine Set Array Head(%integer Adv,IIN,Disp,Addrzero,Type)
%integer I
I=SCALARS
%if Type=CHARTYPE %or Type>>4=3 %then I=I!X'80000000';! request byte fixup
Efix(I,Adv-4,IIN,Addrzero)
Efix(I,Adv,IIN,Disp)
%end;! Set Array Head
!*
!*****************************************************************************
!* *
!* Space allocation *
!* *
!*****************************************************************************
!*
%externalintegerfn Dv Space(%integer LEN,%integername IIN)
!* LEN in bytes
%integer I
%if TARGET=IBM %thenstart
IIN=SCALARS
I=Com_Scalarca
Com_Scalarca=Com_Scalarca+Len
%finishelsestart
IIN=GLA
I=Com_Glaca
Com_Glaca=Com_Glaca+Len
%finish
%result=I
%end;! Dv Space
!*
%externalintegerfn Stack Space(%integer Len)
!***********************************************************************
!* Len in bytes *
!***********************************************************************
%integer I
%if Stack Direction=POSITIVE %thenstart
I=Com_Stackca
Com_Stackca=Com_Stackca+Len
%finishelsestart
Com_Stackca=Com_Stackca-Len
I=Com_Stackca
%finish
%result=I
%end;! Stack Space
!*
!*
%externalintegerfn Scalar Space(%integer LEN {BYTES},%integername IIN)
%integer Ad,I,L
%if TARGET=IBM %thenstart
IIN=SCALARS
Ad=Com_Scalarca
%finishelsestart
IIN=GLA
Ad=Com_Glaca
%finish
Len=(Len+3)&X'FFFFFFFC'
! I=Ad
! L=Len
! %while L>0 %cycle
! PD4(IIN,I,0)
! I=I+4
! L=L-4
! %repeat
%if LEN >MAX AREA SIZE %thenstart
LFAULT(316);! require > permitted area size
%finishelsestart
%if TARGET=IBM %thenstart
Com_Scalarca=Com_Scalarca+Len
%finishelsestart
Com_Glaca=Com_Glaca+Len
%finish
%finish
%if Com_F77parm&4=0 %thenstart;! unass checks
%unless Len=12 %thenstart;! avoids init of i/o descriptors
!! Edpattern(IIN,Ad,Len>>2,4,addr(Com_Unasspattern))
Ed4(IIN,Ad,Com_Unasspattern)
%if Len>4 %then Ed4(IIN,Ad+4,Com_Unasspattern)
%finish
%finish
%result=Ad
%end;! Scalar Space
!*
%externalintegerfn Array Space(%integer Len,%integername IIN)
%integer Ad
Len=(Len+3)&X'FFFFFFFC'
%if LEN >MAX AREA SIZE %thenstart
LFAULT(316);! require > permitted area size
IIN=10
%result=0
%finish
IIN=GST
Ad=Com_Gstca
Com_Gstca=Com_Gstca+Len
! IIN=10
! Ad=Area10size
! Area10size=Area10size+Len
!! %if Com_Statordermode>3 %and Com_F77parm&4#0 %c
!! %and Init9=0 %thenstart;! has not been initialised and no unass checks
!! IIN=ZEROGST
!! Ad=Com_Zgstca
!! Com_Zgstca=Com_Zgstca+Len
!! %finishelsestart;! could be data initialisation
!! IIN=GST
!! Ad=Com_Gstca
!! Com_Gstca=Com_Gstca+Len
!! %finish
%if Com_F77parm&4=0 %thenstart;! unass checks
!! Edpattern(IIN,Ad,Len>>2,4,addr(Com_Unasspattern))
%finish
%result=Ad
%end;! Array Space
!*
%externalintegerfn Alloc Char(%integer Len,Ad, %C
%integername IIN)
!***********************************************************************
!* ALLOCATE SPACE FOR CHAR VAR OR CONST *
!* AD = 0 VAR - FILL WITH UNASS *
!* AD # 0 CONST - DICT DISPLACEMENT OF CONSTANT VALUE *
!* SET DESCRIPTOR ON STACK, ADDRESS AS RESULT *
!***********************************************************************
%integer Disp,Saveinit9
%if Ad=0 %thenstart
{ Saveinit9=Init9 }
{ Init9=1;! to force allocation in GST }
Disp=Array Space(Len+1,IIN);! +1 to ensure zero terminator
{ Init9=Saveinit9 }
%result=Disp
%finishelsestart
Disp=Array Space(Len+1,IIN)
EDbytes(IIN,Disp,Len,ad)
%result=Disp
%finish
%end;! Alloc Char
!*
%externalintegerfn Const Space(%integer Len,%integername IIN)
!* LEN in bytes
%integer I
Len=(Len+3)&X'FFFC'
%result=Scalar Space(Len,IIN)
%end;! Const Space
!*
%externalroutine Alloc Temp(%record(TMPF)%name Tmp)
!***********************************************************************
!* Reserve local stack space for a temporary *
!***********************************************************************
%if Tmp_Addr=0 %thenstart
{N.B. check whether quad word alignment is preferred for 4 word items}
Tmp_Addr=Stack Space(ModetoTempBytes(Tmp_Mode))
%finish
%end;! Alloc Temp
!*
%externalintegerfn Vtaddr(%integer Ad)
!***********************************************************************
!* return the address of a value temporary, allocating if nec. *
!***********************************************************************
%record(Terecf)%name Te
%integer I,K
Te==record(Com_Adict+Ad)
%if Te_Disp1=0 %thenstart
Te_Chain=Techain;! for diags
Techain=Ad
Te_Disp1=Stack Space(ModetoTempBytes(Te_Mode))
Te_Loop=0;! will hold @ of desc if required
%finish
%result=Te_Disp1
%end;! Vtaddr
!*
%externalintegerfn Dtaddr(%integer Ad)
!***********************************************************************
!* return the address of a descriptor temporary, allocating if nec. *
!***********************************************************************
%record(Dtrecf)%name Dt
%integer I,K
Dt==record(Com_Adict+Ad)
%if Dt_Disp2=0 %thenstart
Dt_Disp2=Scalar Space(4,I)
%finish
%result=Dt_Disp2
%end;! Dtaddr
!*
!*****************************************************************************
!* *
!* User and library procedure calls *
!* *
!*****************************************************************************
!*
%externalroutine Syscall(%integer Proc)
%integer I,J,T
%string(31) S
T=Sysproctype(Proc)
J=Sysprocref(Proc)
%if J=0 %thenstart
S=Sysprocs(Proc)
J=Exname(T,S)
Sysprocref(Proc)=J
%finish
Eprecall(J)
I=Sysparams(Proc)
%while I>0 %cycle
%if Stack Direction=POSITIVE %then Epromote(I)
Eop(PUSHVAL)
I=I-1
%repeat
I=Sysprocpdesc(Proc)
Ecall(J,I>>16,I&X'FF')
%if T&7#0 %thenstart;! function
Estkresult(0,T&7,(T>>8)&255)
%finish
%end;! Syscall
!*
%externalroutine Intrincall(%integer Form,Index,Mode)
!* Form = 0 call
!* 1 lvrd
%string(31) S
%integer File,I,J,Procindex,T
%if Index>100 %thenstart
!! File=10;! F77AUX
!! Procindex=Index-88;! Index - 100 + 12 (offset to intrin entries)
%finishelsestart
%if Index=20 %thenstart
%if Mode=CMPLX8 %then Index=18 %else Index=19
%finishelsestart
%if 16<=Index<=19 %thenstart;! erf,erfc,gamma,lgamma
Index=Index+46;! range 62-65
%if Mode=REAL8 %then Index=Index+4
%finishelse Index=Index+Variant(Mode)
%finish
Procindex=Index
T=Genproctype(Procindex)
J=Genprocref(Procindex)
%if J=0 %thenstart
S="f_".Genname(Procindex)
J=Exname(T,S)
Genprocref(Procindex)=J
%finish
I=Genparams(Procindex)
%finish
%if Form=0 %thenstart
! Eprecall(J)
! %while I>0 %cycle
! Epromote(I)
! Eop(PUSHVAL)
! I=I-1
! %repeat
Ecall(J,I,I<<2)
%if T&7#0 %thenstart;! function
Estkresult(0,T&7,(T>>8)&255)
%finish
%finishelsestart
!! Opw(LVRD,J)
!! Pword(Procindex)
%finish
%end;! Intrincall
!*
!*
%endoffile