! Modified 05/10/85
!
! FORTRAN 77 CTL MODULE FOR IBM 370 ARCHITECTURE
! XCTL1 MODIFIED FROM ACTL3 07/01/85
!
%OWNSTRING (52) VERSION = "Fortran77 Compiler Version 8Mar86"
%constinteger Rel  = 1
%constinteger Vers = 21
!*
%include "ftn_ht"
%include "ftn_consts1"
%include "ftn_fmts1"
!*
!*
!***********************************************************************
!* Exports                                                             *
!***********************************************************************
!*
%integerfnspec IBMFORT77 (%integer Control,Options1,Options2,F77parm,
                           Optflags,Srflags,Console,Liststream,Diagstream,
                           Diaglevel,Dsize,Tsize,Bsize,Lsize,Asize,Sp2)
%routinespec Dicful
%routinespec Namesful
%routinespec Extful
%routinespec F77abort(%integer N)
%integerfnspec Outputful
%integerfnspec Analful
%integerfnspec Genful
!*
!***********************************************************************
!* Imports                                                             *
!***********************************************************************
!*
%externalroutinespec Codegen(%integer Cgenep,
                             %record(Triadf)%arrayname Triads,
                             %integer Comad)
%externalintegerfnspec Analstart(%record(Triadf)%arrayname Triads,
                                 %integer Comad,%integername Count)
%EXTERNALROUTINESPEC INIT ALLOC (%INTEGER MODE, COMAD, REL, AVERS)
%externalroutinespec Init Num(%integer Comad)
%externalroutinespec F77area(%integer index,size,%integername ad)
%externalroutinespec Free(%integer byteaddress)
!*
%externalroutinespec Op4 Init(%integer Comad)
%externalroutinespec op4 Init1(%integer Comad)
%externalintegerfnspec Op4 Subprog
%externalroutinespec Reset Oplist
%externalroutinespec Lfault(%integer N)
%externalroutinespec Op4 Resetanal
!*
%externalroutinespec Optsource(%integer a,b,c,d,e,f)
%externalroutinespec Optctl(%integer Acom,Nexttr,Bits,Assgotos)
!*
!***********************************************************************
!* OWN variables                                                       *
!***********************************************************************
!*
%owninteger ComCONTROL,OPT,OPTIONS1,OPTIONS2,PTRACE,
      ADICT,ANAMES,ADOUTPUT,ADBLKDTAID,DICLEN,DPTR,
      MAXTRIADS,NEXTPLAB,ALABH,ADLHEAD,
      SUBPROGTYPE,SFPTR,EXTERNALS,CBNPTR,SCPTR,CHECKLIST,
      RESCOM1,RESCOM2,F77PARMS,FNO,FAULTY,LINEST,CMNIIN,SFMK,
      LISTL,LISTSTREAM,DIAGSTREAM,LISTMODE,XREF,
      PACKCMN,ITSMODE,PATHANAL,CHARACTER CODE,SPACE CHAR,
      HEADINGS,ARRAYCHECKS,JBRMODE,MESSLEN,NAMESLEN,
      NEXTCH,FUNRESDISP,WARNCOUNT,INP,MAXINP,MESSCOUNT,
      UNASSPATTERN,LISTCODE,PI21INT,DOPTR,SUBPROGPTR,
      FNLST,LAB,NAMESFREE,ALGOLREF,FIRSTSTATNUM,CEXPDICT,
      COMMONBASE,FASTPROLOGUE,STATEMENT,IFPTR,
      CNSTCA,COMMENTCNT,ADIDENT,ADERRIDEN,
      ADEXT,MAXDICT,MAXNAMES,MAXOUTPUT,MAXEXT,
      ACOMP,ASUBNAMES,MAXPSTACK,
      ATRIADS,TRFILEID,TRBLOCK,CMNCNT,SCANONLY,NOISY,
      MAXANAL,MAXGEN,SAVEANAL,SAVEGEN,OPTFLAGS,NEXTBIT,
      ACMNBITS,NEXTTEMP,ASSGOTOS,TMPPTR,DESTEMPS,OBJADDR,
      AREAADDR,PASTART,ADOPTDATA,TMINDEX,VRETURN,ENTRIES,
      EQUCHK,LABWARN,LINENO,MAXIBUFF,
      COMMENTS,DIAGLEVEL,WARNNOT77,WARNLENGTH,ALLOWUNIX,ALLOWVAX,
      ONETRIP,ComHOST,ComTARGET,MONERRS,TRANSMTM,
      GLACA,PLTCA,SSTCA,GSTCA,CONSTCA,SCALARCA,IOAREACA,ZGSTCA,STACKCA,
      ComW1,ComW2,ComW4,STATORDERMODE,CURSTATCLASS,LISTPOINT,STACKBASE,
      NEXTTRIAD,ASAVE,MAXSAVE,SUBTAB,LASTSUBTAB,
      INHIBOP4,ARGCNT,IDCNT,LABCNT,TMLIST,MAINPROG,PROCINDEX,ComCONSOLE,
      NEXTSAVE
!*
%ownrecord(Objfmt) Obj
%ownrecord(Comfmt)%name Com
%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 FORT77 (%INTEGER CONTROL, OPTIONS1, OPTIONS2, F77PARMS, OPTFLAGS, %C  
   SRFLAGS, CONSOLE, LISTSTREAM, DIAGSTREAM, DIAGLEVEL, DSIZE, TSIZE, BSIZE, LSIZE, ASIZE, SP2)
%record(Triadf)%arrayformat Trform(0:10000)
%record(Triadf)%arrayname Triads
%integer Diclen,Maxtriads,Maxblocks,Maxloops
%integer I,J,K,F,Count
%string(63) S
!*
      Com==record(addr(ComControl))
      Comad=addr(Com_Control)
!*
!******  Host dependent data
!*
      Com_Host=HOST
      Com_W1=W1
      Com_W2=W2
      Com_W4=W3
!*
!******
!*
      Com_Messlen=1
!*
!******* ESTABLISH Com_Options
!*
      Com_Control = Control
      Com_Options1=Options1
      Com_Options2=Options2
!      %if F77PARMS&X'18'=0 %then F77PARMS=F77PARMS!X'10'
      F77parms=F77parms!2;! inhibit argument checks
      Com_F77parm=F77PARMS
      Com_Opt=(Com_Options1>>20)&15
      %if Com_Opt>2 %then Com_Opt=4
      %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=Liststream
      Com_Diagstream=Diagstream
      Com_Console=Diagstream
    {  Com_Liststream=1 }
    {  Com_Diagstream=2 }
    {  Com_Console=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
!*
      %if Tsize=0 %then Tsize=128
      %if Tsize<32 %then Tsize=32
      %if Tsize>256 %then Tsize=256
!*
      %if Bsize=0 %then Bsize=48
      %if Bsize<16 %then Bsize=16
      %if Bsize>128 %then Bsize=128
!*
      %if Lsize=0 %then Lsize=4
      %if Lsize<1 %then Lsize=1
      %if Lsize>16 %then Lsize=16
!*
      Diclen=Dsize<<10
      Dsize=Dsize<<10
!*
      Tsize=Tsize<<10
      Maxtriads=Tsize//12
!*
      Maxblocks=Bsize<<9
      Bsize=Bsize<<10
!*
      Maxloops=Lsize<<9
      Lsize=Lsize<<10
!*
      Com_Objaddr=addr(Obj)
      F77area(0,Dsize,Com_Adict);! T#DICT
      %IF COM_ADICT < 1 %THEN %RESULT = -COM_ADICT
      Com_Diclen=Diclen
      F77area(1,X'b000',Com_Anames);! T#NAMES
      %IF COM_ANAMES < 1 %THEN %RESULT = -COM_ANAMES
      Com_Nameslen=x'1000'
      Com_Adoutput=Com_Anames+X'1000'
      Com_Maxoutput=4000
      Com_Saveanal=Com_Anames+X'4000'
      Com_Maxanal=X'4000'
      Com_Savegen=Com_Anames+X'8000'
      Com_Maxgen=X'3000'
      f77area(2,Tsize,Com_Atriads);! T#TRIADS
      %IF COM_ATRIADS < 1 %THEN %RESULT = -COM_ATRIADS
      Com_Maxtriads=Maxtriads
      %if Com_Opt#0 %thenstart
         F77area(3,Bsize,Obj_Ablocks);! T#BLOCKS
         %IF OBJ_ABLOCKS < 1 %THEN %RESULT = -OBJ_ABLOCKS
         Obj_Maxblocks=Maxblocks
         F77area(4,X'10000',Obj_Atabs);! T#TABS
         %IF OBJ_ATABS < 1 %THEN %RESULT = -OBJ_ATABS
         Obj_Maxtabs=X'8000'
         F77area(5,Lsize,Obj_Aloop);! T#LOOPS
         %IF OBJ_ALOOP < 1 %THEN %RESULT = -OBJ_ALOOP
         Obj_Maxloop=Maxloops
         %if Com_Opt=4 %thenstart
            F77area(6,X'40000',Com_Asave);! T#SAVE
            Com_Maxsave=X'40000'
         %finish
      %finish
      Triads==array(Com_Atriads,Trform)
!*
      Com_Allowvax=0
      Com_Allowunix=0
!*
      %if Com_Control&2=0 %or Host=IBM %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_Listl=((Com_Control&2)>>1)!!1
      Com_Listmode=2
      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'81818181'
      %if Com_Control&X'10'#0 %then Com_F77parm=(Com_F77parm)!X'7'
                                 ! nochar,noarg,nochar (NOCHECK)
      %if Com_Control&X'20'#0 %then Com_F77parm=Com_F77parm!X'10'
                                ! nobound (NOARRAY)
!*
      %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_F77parm&X'10'#0 %then Com_Arraychecks=NO  %C
                              %else Com_Arraychecks=YES
!*
      %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,Rel<<16!Vers,addr(Version))
      Init Num(Comad)
      %if Com_Listl#0 %thenstart
%if Target=Gould %thenstart
   printstring("
   EPC/Gould ")
   printstring(Version)
   newlines(2)
%finishelsestart
         newlines(2)
         printstring("    Edinburgh Amdahl ")
         printstring(Version)
         newlines(2)
%finish
      %finish
!*
      Com_Lineno=-1
      Com_Linest=0
      Com_Warncount=0;! individual counts for each subprog
      Com_Messcount=0
      Com_Commonbase=0
      Com_Headings=0
      Com_Mainprog=0;! set after a main program - used to check multiples
      Com_Procindex=0;! used to default main prog out of position for Opt3
      Com_Adoptdata=0;! will be set non-zero on entry to optimiser
!*
      Count=0
!*
      %if Com_Opt=4 %thenstart
         Op4 Init(Comad)
         Op4 Init1(Comad)
      %finish
!*
      I=Analstart(Triads,Comad,Count)
!*
      %if Com_Opt=4 %and Com_Fno=0 %thenstart
!printstring("
!Subtab  Lastsubtab  Nextsave ")
!write(Com_Subtab,4)
!write(Com_Lastsubtab,4)
!write(Com_Nextsave,4)
!newlines(2)
!dump(Com_Asave,Com_Nextsave)
         %if Obj_Optflags&32#0 %then Reset Oplist
         %cycle
            %if Com_Fno#0 %or Com_Faulty#0 %then %exit
            J=Op4 Subprog
            %if J=-3 %then Lfault(347);! recursion
            %if J<=0 %then %exit
            Op4 Resetanal
            Optctl(Comad,Com_Nexttriad,32,Com_Assgotos)
            %IF OBJ_OPTFLAGS&X'10000'#0 %THENSTART;! DIS=OPLIST
               SELECTOUTPUT(COM_DIAGSTREAM)
               OPTSOURCE(COM_ADICT,COM_ANAMES,COM_ATRIADS,   %C
                         COM_DESTEMPS,COM_ADOPTDATA,COM_TMLIST)
               SELECTOUTPUT(COM_LISTSTREAM)
            %FINISH
            %IF OBJ_OPTFLAGS&32#0 %THENSTART
               NEWPAGE
               COM_HEADINGS=1
               %IF COM_TMINDEX=0 %THEN COM_TMLIST=0
               OPTSOURCE(COM_ADICT,COM_ANAMES,COM_ATRIADS,    %C
                         COM_DESTEMPS,COM_ADOPTDATA,COM_TMLIST)
            %FINISH
            Codegen(3,Triads,Comad)
         %repeat
      %finish
!*
      %if I#0 %then Codegen(I,Triads,Comad)
!*
      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)
      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
")
      newline
      %stop
%end;! Abort
!*
%externalroutine Dicful
      Abort("Dictionary")
%end
!*
!*
%externalroutine Namesful
      Abort("Name")
%end
!*
%externalroutine Extful
      Abort("Externals")
%end
!*
%externalroutine F77abort(%integer N)
      %if N=1 %thenstart;! the only defined value pro tem
         Abort("Triad")
      %finishelse Abort("???")
%end;! F77abort
!*
%externalintegerfn Outputful
%result=1
%end
!*
%externalintegerfn Analful
%result=1
%end
!*
%externalintegerfn Genful
%result=1
%end
!*
!*
%ENDOFFILE