! 08/01/85 include N=5 in F77abort
!* modified 14/12/84
!*
%CONSTINTEGER DICTVERSION=0;! 0 EMAS  1 VME
!*
%CONSTSTRING(5) LOCAL VERSION="1.4"
!*
%include "host_host"
!*
%include "bits_fmts"
!*
%include "bits_com"
!*
%RECORDFORMAT OBJFMT(%STRING(35) MODULE,%INTEGER MAINEP,I,J,K,
                     ADATE,ATIME,OPTIONS2,EXTPROCS,ATRIADS,MAXTRIADS,
                     ABLOCKS,MAXBLOCKS,ALOOP,MAXLOOP,ATABS,MAXTABS,
                     SRFLAGS,INHIBMASK,OPT,OPTFLAGS,OPTDESC0,OPTDESC1,
                     D1,D2,D3,D4)
!*
%OWNRECORD(OBJFMT) OBJ
%OWNRECORD(COMFMT)%NAME COM
!*
!*
!*
%EXTERNALROUTINESPEC CODEGEN(%INTEGER CGENEP,
                             %RECORD(TRIADF)%ARRAYNAME TRIADS,
                             %INTEGER COMAD)
!*
%EXTERNALINTEGERFNSPEC GET COMAD
!*
%EXTERNALINTEGERFNSPEC ANALSTART(%RECORD(TRIADF)%ARRAYNAME TRIADS,
                           %INTEGER MAXTRIADS,COMAD,
                           %INTEGER ADICT0,ANAMES0,AMT,AM)
%EXTERNALROUTINESPEC Init Alloc(%integer Mode,Comad)
%externalroutinespec Init Num(%integer Comad)
!*
%externalroutinespec F77area(%integer index,size,%integername ad)
%externalroutinespec Free(%integer byteaddress)
!*
%CONSTINTEGER NO=0
%CONSTINTEGER YES=1
%CONSTINTEGER FULL=2

%owninteger CurDsize,CurTsize,CurBsize,CurLsize,CurAsize
!*
%OWNINTEGER COMAD
%CONSTBYTEINTEGERARRAY HEX(0 : 15) =   %C
 '0','1','2','3','4','5','6',
'7','8','9','A','B','C','D','E','F'
!*
%ROUTINE PRHEX(%INTEGER J)
%INTEGER K
      %CYCLE K = 28,-4,0
         PRINT SYMBOL(HEX((J>>K)&15))
      %REPEAT
%END
!*
!*
%externalintegerfn Pnxfort77(%integer Control,Options1,Options2,F77parm,
                               Optflags,Srflags,Liststream,Diagstream,
                               Diaglevel,Dsize,Tsize,Bsize,Lsize,Asize,Sp2)
%string(63) S
!*
%OWNINTEGER MAXTRIADS = 10800
!*
%INTEGER VERSION,I,J,K,F
!*
%ROUTINE OPTMESS
      PRINTSTRING("OPT level")
      WRITE(Com_OPT,1)
      %if Com_OPTFLAGS#0 %thenstart
         PRINTSTRING("          flags")
         WRITE(Com_OPTFLAGS,2)
      %finish
%END
!*
      COMAD= GET COMAD
      COM==RECORD(COMAD)
!******  Host dependent data
      Com_Host=HOST
      Com_W1=W1
      Com_W2=W2
      Com_W4=W3
!******
      VERSION=DICTVERSION
      Com_Messlen=1

%begin
%BYTEINTEGERARRAY MESSTYPE(0:Com_MESSLEN)
%STRING(120)%ARRAY MESS(0:Com_MESSLEN)
%RECORD(TRIADF)%ARRAYFORMAT TRFORM(0:10000)
%RECORD(TRIADF)%ARRAYNAME TRIADS
%integer Diclen,Maxtr,Maxblocks,Maxloops,Maxtabs
!*
!******* ESTABLISH Com_Options
!*
      Com_Control = Control
      Com_Options1=Options1
      Com_Options2=Options2
      %if F77parm&X'18'=0 %then F77parm=F77parm!X'10'
      Com_F77parm=F77parm
      Com_Opt=(Com_Options1>>20)&15
      %if Com_Opt#0 %then Com_F77parm=Com_F77parm!X'17';! all checks off
      Com_Optflags=Optflags
      Obj_Srflags=Srflags
      Obj_Inhibmask=0
      Com_Liststream=1
      Com_Diagstream=2
      Com_Noisy=1;! report routine name to diagstream
      %if Srflags#0 %thenstart
         printstring("       SRFLAGS = X")
         Prhex(Srflags)
      %finish
!*
      %if Dsize=0 %then Dsize=48
      %if Dsize<16 %then Dsize=16
      %if Dsize>64 %then Dsize=64
      CurDsize = Dsize
!*
      %if Tsize=0 %then Tsize=64
      %if Tsize<32 %then Tsize=32
      %if Tsize>256 %then Tsize=256
      CurTsize = Tsize
!*
      %if Bsize=0 %then Bsize=48
      %if Bsize<16 %then Bsize=16
      %if Bsize>128 %then Bsize=128
      CurBsize = Bsize
!*
      %if Lsize=0 %then Lsize=4
      %if Lsize<1 %then Lsize=1
      %if Lsize>16 %then Lsize=16
      CurLsize = Lsize
!*
      %if Asize=0 %then Asize=48
      %if Asize<16 %then Asize=16
      %if Asize>128 %then Asize=128
      CurAsize = Asize
!*
      Diclen=Dsize<<9
      Dsize=Dsize<<10
!*
      Tsize=Tsize<<10
      Maxtriads=Tsize//12
!*
      Maxblocks=Bsize<<9
      Bsize=Bsize<<10
!*
      Maxloops=Lsize<<9
      Lsize=Lsize<<10
!*
      Maxtabs=Asize<<9
      Asize=Asize<<10
!*
      Com_Objaddr=addr(Obj)
      F77area(0,Dsize,Com_Adict);! T#DICT
      Com_Diclen=Diclen
      F77area(1,X'b000',Com_Anames);! T#NAMES
      Com_Nameslen=x'1000'
      Com_Adoutput=Com_Anames+X'1000'
      Com_Maxoutput=4000
      Com_Saveanal=Com_Anames+X'2000'
      Com_Maxanal=X'2000'
      Com_Savegen=Com_Anames+X'4000'
      Com_Maxgen=X'1800'
      f77area(2,Tsize,Com_Atriads);! T#TRIADS
      Com_Maxtriads=Maxtriads
      %if Com_Opt#0 %thenstart
         F77area(3,Bsize,Obj_Ablocks);! T#BLOCKS
         Obj_Maxblocks=Maxblocks
         F77area(4,Asize,Obj_Atabs);! T#TABS
         Obj_Maxtabs=Maxtabs
         F77area(5,Lsize,Obj_Aloop);! T#LOOPS
         Obj_Maxloop=Maxloops
      %finish
      Triads==array(Com_Atriads,Trform)
!*
      Com_Allowvax=1
      Com_Allowunix=1
!*
      Com_Listl=((Com_Control&2)>>1)!!1
      %if Com_Control&2=0 %thenstart;! listing required
         %if Liststream>0 %and Diagstream>0 %then Com_Listmode=1  %c
                                            %else Com_Listmode=2
         Com_Listl=1
      %finishelsestart
         Com_Listmode=0
         Com_Listl=0
      %finish
      Com_Xref=(Com_Control&X'800')>>11
      Com_Scanonly=(Com_Options1&X'20')>>5
      %if Com_Control&X'400000'#0 %thenstart;! EBCDIC
         Com_Character Code=1
         Com_Space Char=X'40'
      %finishelsestart;! ISO
         Com_Character Code=0
         Com_Space Char=X'20'
      %finish
      Com_Itsmode=0
      Com_Unasspattern=X'80808080'
      %if Com_Control&X'10'#0 %then Com_F77parm=((Com_F77parm)>>4)<<4!X'17'
                                 ! nobound,nochar,noarg,nochar (OPT)
!*
      %if Com_F77parm&X'F'#7 %and Diaglevel<0 %then Diaglevel=0;! to ensure some diags available
      %if Diaglevel<0 %then Com_Control=Com_Control!X'10000';! to minimise overhead
      Com_Diaglevel=Diaglevel
!*
      %if Com_Options1&X'10'#0 %then Com_Optflags=Com_Optflags!32;! oplist
      Obj_Optflags=Com_Optflags
!*
      Com_Pathanal=Com_Control&X'80';! PROFILE BIT
!*
      Init Alloc(0,Comad)
      Init Num(Comad)
      %if Com_Listl#0 %thenstart
         newlines(2)
         printstring("     PNX Fortran77 Compiler Release ")
         printstring(LOCAL VERSION)
         newlines(2)
      %finish
!*
      I=Analstart(Triads,Maxtriads,Comad,Com_Adict,Com_Anames,
                addr(Messtype(0)),addr(Mess(0)))
!*
      %if I#0 %then Codegen(I,Triads,Comad)
!*
%end
      Free(Com_Adict<<1)
      Free(Com_Anames<<1)
      %if Com_Opt#0 %thenstart
         Free(Obj_Ablocks<<1)
         Free(Obj_Atabs<<1)
         Free(Obj_Aloop<<1)
      %finish


      %if Com_Faulty=0 %then %result=Com_Linest  %c
                       %else %result=-Com_Faulty


%end;! PNXFort77
!*
%routine Abort(%string(63) S, %integer CurSize,MaxSize,IDLetter)
      printstring("
***Compilation aborted due to ")
      printstring(S)
      printstring(" table overflow
***This may be avoided by reducing the size or complexity of the subprogram
***currently being compiled.
")
      %if CurSize # MaxSize %Start
         printstring("***Alternatively the table size may be increased within the range
    ")
         write(CurSize+1,1)
         printstring(" to ")
         write(MaxSize,1)
         printstring(" Kb by use of the compiler option  -N")
         printsymbol(IDLetter)
         printstring("(NumKb)    eg. -N")
         printsymbol(IDLetter)
         printstring("100")
      %finish
      newline
      %stop
%end;! Abort
!*
%externalroutine Dicful
      Abort("Dictionary",CurDsize,64,'d')
%end
!*
!*
%externalroutine Namesful
      Abort("Name",0,0,0)
%end
!*
%externalroutine Extful
      Abort("Externals",0,0,0)
%end
!*
%externalroutine F77abort(%integer N)
      %if N=1 %then Abort("Triad",CurTsize,256,'t')
      %if N=2 %then Abort("Block",CurBsize,128,'b')
      %if N=3 %then Abort("Loop",CurLsize,16,'l')
      %if N=4 %then Abort("Tab",CurAsize,128,'a')
      %if N=5 %then Abort("Com_saveanal",0,0,0)
      Abort("???",0,0,0)
%end;! F77abort
!*
%externalintegerfn Outputful
%result=1
%end
!*
%externalintegerfn Analful
%result=1
%end
!*
%externalintegerfn Genful
%result=1
%end
!*
!*
%ENDOFFILE