!* modified 14/04/82
!*
!*************************** EXPORTS **********************
!*
%ROUTINESPEC F77COMP(%HALFINTEGER A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,
   %INTEGER INFILE,ERRFILE,OUTFILE,
   %HALFINTEGER BLKS,BITS,ISN,
   %INTEGER MODE,
   %HALFINTEGER NUMIMPORTS,MEMSIZE)
%ROUTINESPEC SOURCE LINE(%INTEGER ABUFF)
%ROUTINESPEC OUTPUTFUL
%ROUTINESPEC NAMESFUL
%ROUTINESPEC DICFUL
%ROUTINESPEC EXTFUL
!*
!********************************************************************
!*
!***********************************************************************
!*
!*
!***********************************************************************
!* Formats for accessing dictionary records                            *
!***********************************************************************
!*
%RECORDFORMAT PRECF( %C
               %BYTEINTEGER CLASS,TYPE,X0,X1, %C
               %INTEGER LINK1, LINK2, LINK3, ADDR4,  %C
               %HALFINTEGER DISP,LEN,  %C
               %INTEGER IDEN,LINE,XREF,CMNLENGTH, CMNREFAD)
!*
%RECORDFORMAT SRECF(%INTEGER INF0, LINK1, INF2, INF3, INF4)
!*
%RECORDFORMAT RESF((%INTEGER W %OR %HALFINTEGER H0,
                      (%HALFINTEGER H1 %OR %BYTEINTEGER FORM,MODE)))
!*
%RECORDFORMAT DORECF( %C
    %INTEGER LABEL, LINK1, LOOPAD, ENDREF,
    %RECORD(RESF) INDEXRD, INCRD, FINALRD, ICRD,
    %INTEGER LABLIST,LINE)
!*
%RECORDFORMAT BFMT(%INTEGER L,U,M)
!*
%RECORDFORMAT ARRAYDVF(%INTEGER DIMS, ADDRDV,GLADV,  %C
            %INTEGER ZEROTOFIRST, ADFIRST, NUMELS, ELLENGTH,  %C
            %RECORD(BFMT) %ARRAY B(1 : 7))
!*
!*
%RECORDFORMAT LRECF(%INTEGER NOTFLAG,LINK1,ORLIST,ANDLIST,RELOP)
!*
%RECORDFORMAT IFRECF(%INTEGER TYPE,LINK1,ENDIFJUMP,FALSELIST,  %C
                                        LABLIST,LINE)
!*
%RECORDFORMAT LABRECF(%BYTEINTEGER CLASS,TYPE,X0,X1,  %C
            %INTEGER LINK1,LINK2,LINK3,ADDR4,LINK5,LAB,LINE,  %C
            %HALFINTEGER DOSTART,DOEND,IFSTART,IFEND)
!*
%RECORDFORMAT PLABF(%INTEGER INDEX,CODEAD,REF,REFCHAIN)
!*
%RECORDFORMAT IMPDORECF(%INTEGER VAL,LINK,IDEN)
!*
%RECORDFORMAT CONRECF(%INTEGER MODE,LINK1,DADDR,CADDR)
!*
%RECORDFORMAT TMPF(%BYTEINTEGER REG,MODE,%HALFINTEGER INDEX,  %C
                    %INTEGER LINK1,ADDR)
!*
%RECORDFORMAT CHARF(%INTEGER ADESC,LINK,LEN)
!*
%RECORDFORMAT FNRECF(%INTEGER FPTR,LINK1,HEAD,PCT)
!*
!*
!***********************************************************************
!* Constants defining the size of DICT records                         *
!***********************************************************************
!*
%CONSTINTEGER IDRECSIZE    = 28;! size of dict entry reserved for a new identifier
%CONSTINTEGER CONRECSIZE   = 16
%CONSTINTEGER CNSTRECMIN   =  4
%CONSTINTEGER IMPDORECSIZE = 12;! size of DATA-implied-DO list item
%CONSTINTEGER LABRECSIZE   = 40
%CONSTINTEGER PLABRECSIZE  = 16
%CONSTINTEGER XREFSIZE     =  8
%CONSTINTEGER CMNRECEXT    = 12;! extra space on iden record for common block name
%CONSTINTEGER TMPRECSIZE=12
!*
!***********************************************************************
!* TRIAD record format                                                 *
!***********************************************************************
!*
%RECORDFORMAT TRIADF(  %C
               %BYTEINTEGER OP,
               (%BYTEINTEGER USE %OR %BYTEINTEGER VAL2),
               %HALFINTEGER CHAIN,
               (%RECORD(RESF) RES1      %OR     %C
               (%HALFINTEGER OPD1,%BYTEINTEGER QOPD1,MODE  %OR  %C
               (%INTEGER SLN %OR %INTEGER VAL1))),
               (%RECORD(RESF) RES2      %OR   %C
                %HALFINTEGER OPD2,%BYTEINTEGER QOPD2,MODE2))
!*
!*
!***********************************************************************
!***********************************************************************
!*
!*
!*
%RECORDFORMAT COMFMT(%INTEGER CONTROL,OPTIONS,OPTIONS1,OPTIONS2,PTRACE,
      ADICT,ANAMES,ADOUTPUT,ADBLKDTAID,DICLEN,DPTR,
      MAXTRIADS,NEXTPLAB,ALABH,ADLHEAD,
      SUBPROGTYPE,SFPTR,EXTERNALS,CBNPTR,SCPTR,CHECKLIST,
      RESCOM1,RESCOM2,GLACA,FNO,FAULTY,LINEST,CMNIIN,SFMK,
      LISTL,LISTSTREAM,DIAGSTREAM,LISTPOINT,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)
!*
!*
%EXTERNALROUTINESPEC CODEGEN(%INTEGER CGENEP,
                             %RECORD(TRIADF)%ARRAYNAME TRIADS,
                             %INTEGER COMAD)
%EXTERNALROUTINESPEC QPUT(%INTEGER I,J,K,L)
!*
%EXTERNALINTEGERFNSPEC GET COMAD
!*
%EXTERNALROUTINESPEC INIT COMP(%HALFINTEGER LIST,DIAG)
%EXTERNALINTEGERFNSPEC ANALSTART(%RECORD(TRIADF)%ARRAYNAME TRIADS,
                           %INTEGER MAXTRIADS,COMAD,
                           %INTEGER ADICT0,ANAMES0,AMT,AM)
%EXTERNALROUTINESPEC INIT ALLOC(%INTEGER COMAD)
%EXTERNALROUTINESPEC INITMAIN
%EXTERNALROUTINESPEC NEWSEG(%HALFINTEGERNAME SEGNUM,%HALFINTEGER FSIZE,
                            FINCR,FMAX)
%EXTERNALROUTINESPEC EXTENDSEG(%HALFINTEGERNAME SEGNUM,
                               %HALFINTEGER FSIZE)
%EXTERNALROUTINESPEC READBLOCK(%HALFINTEGER ID,BLLKNO,%INTEGER BUFFADDR)
%EXTERNALHALFINTEGERFNSPEC CREATEFILE(%INTEGER NAMEAD)
%EXTERNALROUTINESPEC DATEANDTIME(%INTEGER ASTRING)
!*
!*
%CONSTINTEGER NO=0
%CONSTINTEGER YES=1
%CONSTINTEGER FULL=2
!*
%OWNINTEGER COMAD,ADICT,ANAMES,ATRIADS,WORKAD,CINFILE
%CONSTINTEGER MAXTRIADS=1000
%OWNINTEGER INIT
%OWNHALFINTEGER LISTFLAG,ERRFLAG,DEBUGFLAG
%OWNINTEGER BLKBUFFADDR
%OWNHALFINTEGER INBLKS,INBYTES,FILEID
%OWNRECORD(TRIADF)%ARRAY TRIADS(0:1)
%OWNHALFINTEGER OUTSEG,NAMSEG,DICTSEG,EXTSEG,TRIADSEG,WORKSEG
!*
!*
%EXTERNALROUTINE F77COMP(   %C
   %HALFINTEGER OUTID,INID,WKID,EXTERN,RANGE,CHECK,LIST,CODE,XREF,
                SCAN,NOISY,QUERY,DEBUG,DOSTAT,BLOCKS,
   %INTEGER INFILE,ERRFILE,OUTFILE,
   %HALFINTEGER BLKS,BITS,ISN,
   %INTEGER MODS,
   %HALFINTEGER NUMIMPORTS,MEMSIZE)

%RECORD(COMFMT)%NAME COM
!*
%BYTEINTEGERARRAY BLKBUFF(0:511)
%INTEGER VERSION,I
%HALFINTEGER OUTF,WRKF
%STRING(6) ID
!*
%ROUTINE ENTER
%RECORD(COMFMT)%NAME COM
%HALFINTEGER I
%OWNSTRING(18) DT="                  "
%INTEGER II
      %IF INIT=0 %THENSTART
         INIT=1
         INITMAIN
         %RETURN
      %FINISH
      COM==RECORD(COMAD);! avoid using the enclosing stackframe
!     PRINTSTRING("Edinburgh PERQ Fortran77 Compiler Test Version 0.2")
      NEWLINES(2)
!*
      INIT COMP(LISTFLAG,ERRFLAG)
      %IF COM_LISTSTREAM=1 %THENSTART
         SELECTOUTPUT(1)
         PRINTSTRING("Fortran version 0.0                   ")
         II=ADDR(DT)
         DATEANDTIME(II)
         PRINTSTRING(DT)
         NEWLINES(2)
         PRINTSTRING("Source: ")
         PRINTSTRING(STRING(CINFILE))
         NEWLINES(3)
      %FINISH
      %IF LISTFLAG#0 %THENSTART
         SELECTOUTPUT(1)
      %FINISH
      I=ANALSTART(TRIADS,MAXTRIADS,COMAD,ADICT,ANAMES,0,0)
      %IF I#0 %THENSTART
         CODEGEN(I,TRIADS,COMAD)
         %IF COM_FAULTY=0 %THEN QPUT(8,0,0,0)
      %FINISH
!      PRINTSTRING("Returned to F77COMP")
!      NEWLINES(2)
!      %STOP
  %END; ! ENTER
!*
      COMAD= GET COMAD
      COM==RECORD(COMAD)
      COM_MAXOUTPUT=2*128
      COM_MAXNAMES=2*256
      COM_MAXDICT=16*256
      NEWSEG(WORKSEG,8,1,8)
      NEWSEG(DICTSEG,16,16,64)
      WORKAD=WORKSEG
      WORKAD=WORKAD<<16
      COM_ATRIADS=WORKAD
      COM_ADOUTPUT=WORKAD+X'100'
      COM_ANAMES=WORKAD+X'400'
      COM_ADEXT=WORKAD+X'600'
      COM_ADICT=DICTSEG
      COM_ADICT=COM_ADICT<<16
      COM_DPTR=32
      COM_DICLEN=X'E00'
      COM_NAMESLEN=512
      COM_CHARACTER CODE=0
      COM_SPACE CHAR=X'20'
      COM_CMNIIN=10
      COM_DIAGSTREAM=0
      OUTF=OUTID
      WRKF=WKID
      QPUT(1,INTEGER(ADDR(OUTF)),DEBUG,INFILE)
      ID="F_TEMP"
      COM_TRFILEID=CREATEFILE(ADDR(ID))
      CINFILE=INFILE
      I=0;! for control options
      %IF CHECK=0 %THEN I=I!X'10';! no unassigned checks
      %IF RANGE=0 %THEN I=I!X'20';! no range checks
      %IF LIST#0 %THENSTART
         COM_LISTL=1
         COM_LISTSTREAM=1
         %IF CODE#0 %THEN I=I!X'4000';! object code listing
         %IF XREF#0 %THEN I=I!X'800';! cross-reference listing
      %FINISHELSE COM_LISTSTREAM=-1
      COM_CONTROL=I
!*
      INIT ALLOC(COMAD)
!*
BLKBUFFADDR=ADDR(BLKBUFF(0))
INBLKS=BLKS
INBYTES=BITS//8
FILEID=INID
!*
LISTFLAG=LIST
%IF QUERY#0 %THENSTART
   ERRFLAG=0
%FINISHELSESTART
   ERRFLAG=1
   COM_DIAGSTREAM=3
%FINISH
DEBUGFLAG=DEBUG
ADICT=COM_ADICT
ANAMES=COM_ANAMES
!*
ENTER
!*
%END;! F77COMP1
!*
%INTEGERFN NEXTBLOCK
%OWNINTEGER BLKSREAD
%IF BLKSREAD<INBLKS %THENSTART
  READBLOCK(FILEID,BLKSREAD,BLKBUFFADDR)
  BLKSREAD=BLKSREAD+1
  %IF BLKSREAD=INBLKS %THEN %RESULT=INBYTES-1
  %RESULT=511
%FINISH
%RESULT=-1
%END; ! NEXTBLOCK
!*
%EXTERNALROUTINE SOURCE LINE(%INTEGER LBADDR)
%OWNINTEGER BITSREAD,BLKEND
%BYTEINTEGERARRAYNAME LBUFF
%BYTEINTEGERARRAYFORMAT LBF(0:80)
%BYTEINTEGERARRAYNAME BLOCK
%BYTEINTEGERARRAYFORMAT BF(0:511)
%INTEGER I
BLOCK==ARRAY(BLKBUFFADDR,BF)
LBUFF==ARRAY(LBADDR,LBF)
I=0
%CYCLE
  %IF BITSREAD=0 %THEN BLKEND=NEXTBLOCK
  %IF BLKEND<0 %THEN ->EOF
  %IF BLOCK(BITSREAD)=10 %THEN ->ENDLINE
  %IF BLOCK(BITSREAD)#13 %AND I<80 %THENSTART
    I=I+1
    LBUFF(I)=BLOCK(BITSREAD)
  %FINISH
  %IF BITSREAD=BLKEND %THEN BITSREAD=0 %ELSE BITSREAD=BITSREAD+1
%REPEAT
ENDLINE:
%IF BITSREAD=BLKEND %THEN BITSREAD=0 %ELSE BITSREAD=BITSREAD+1
LBUFF(0)=I
%IF I<73 %THENSTART
  %CYCLE I=LBUFF(0)+1,1,72
    LBUFF(I)=' '
  %REPEAT
%FINISH
%RETURN
EOF:
LBUFF(0)=1
LBUFF(1)=25
%END;! SOURCE LINE
!*
%EXTERNALROUTINE OUTPUTFUL
%RECORD(COMFMT)%NAME COM
COMAD=GET COMAD
COM==RECORD(COMAD)
COM_MAXOUTPUT=COM_MAXOUTPUT+2*128
%IF DEBUGFLAG=0 %THENSTART
  PRINTSTRING("EXTENDING OUTPUT SEG TO")
  WRITE(COM_MAXOUTPUT,4)
  NEWLINE
  %FINISH
EXTENDSEG(OUTSEG,COM_MAXOUTPUT//128)
%END; ! OUTPUTFUL

%EXTERNALROUTINE NAMESFUL
%RECORD(COMFMT)%NAME COM
COMAD=GET COMAD
COM==RECORD(COMAD)
COM_MAXNAMES=COM_MAXNAMES+512
%IF DEBUGFLAG=0 %THENSTART
  PRINTSTRING("EXTENDING NAMES SEG TO")
  WRITE(COM_MAXNAMES,4)
  NEWLINE
  %FINISH
EXTENDSEG(NAMSEG,COM_MAXNAMES//256)
%END; ! NAMESFUL

%EXTERNALROUTINE DICFUL
%RECORD(COMFMT)%NAME COM
COMAD=GET COMAD
COM==RECORD(COMAD)
COM_MAXDICT=COM_MAXDICT+16*256
%IF DEBUGFLAG=0 %THENSTART
  PRINTSTRING("EXTENDING DICT SEG TO")
  WRITE(COM_MAXDICT,5)
  NEWLINE
  %FINISH
EXTENDSEG(DICTSEG,COM_MAXDICT//256)
COM_DICLEN=COM_MAXDICT-X'200'
%END; ! DICFUL
!*
%EXTERNALROUTINE EXTFUL
%RECORD(COMFMT)%NAME COM
COMAD=GET COMAD
COM==RECORD(COMAD)
COM_MAXEXT=COM_MAXEXT+256
%IF DEBUGFLAG=0 %THENSTART
  PRINTSTRING("EXTENDING EXT SEG TO")
  WRITE(COM_MAXEXT,4)
  NEWLINE
  %FINISH
EXTENDSEG(EXTSEG,COM_MAXEXT//256)
%END; ! EXTFUL
!*
%ENDOFFILE