!* 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