!                                                       fdata3
! 20/07/87 - intiliase com_sstca in initdata
!                                                              fdata2
! 23/03/87 - set Genproctype for cdabs to 10802
!                                                               fdata1
! 16/11/86 - incorporate changes to ftndata17
! 24/09/86 - insert include files
!                                                               ftndata15
! 12/09/86 - third param to Array Space to allow/inhib use of BSS
! 09/09/86 - set Eflags&X'20' if profiling
! 07/09/86 - Intrincall special action for Gould intrinsics
! 06/09/86 - use BSS for local arrays
!                                                               ftndata14
! 16/07/86 - Syscall mod for Lattice
! 09/07/86                                                      ftndata13
!*
%include "ftn_ht"
{%include "ftn_fmts1"}
!* 09/12/85 - add recordformat SUBFMT
!* modified 14/03/85
!*
!***********************************************************************
!* Formats for accessing dictionary records                            *
!***********************************************************************
!*
%recordformat PRECF(%byteinteger CLASS,TYPE,X0,X1,
                    %integer LINK1, LINK2,
                   (%shortinteger COORD,LINK3  %OR %integer LAST   %C
                        %OR %integer CONSTRES %OR %integer INF3),
                    %integer ADDR4,
                    %shortinteger DISP,LEN,IDEN,IIN,
                    %integer LINE,XREF,CMNLENGTH,CMNREFAD)
!*
%recordformat SRECF(%integer INF0, LINK1, INF2, INF3, INF4)
!*
%recordformat RESF((%integer W %OR %shortinteger H0,
                      (%shortinteger H1 %OR %byteinteger FORM,MODE)))
!*
%recordformat DORECF( %C
    %integer LABEL, LINK1,
    %record(RESF) LOOPAD, ENDREF, INDEXRD, INCRD, FINALRD, ICRD,
    %integer LABLIST,LINE)
!*
%recordformat BFMT(%integer L,U,M)
!*
%recordformat ARRAYDVF(%integer DIMS, ADDRDV,ADDRZERO,  %C
            %integer ZEROTOFIRST, ADFIRST, NUMELS, ELLENGTH,  %C
            %record(BFMT) %ARRAY B(1 : 7))
!*
!*
%recordformat LRECF(%integer NOTFLAG,LINK1,
                    %record(RESF) ORLAB,ANDLAB,
                    %integer RELOP)
!*
%recordformat IFRECF(%integer TYPE,LINK1,
                     %record(RESF) ENDIFLAB,FALSELAB,
                     %integer LABLIST,LINE)
!*
%recordformat LABRECF(%shortinteger BLKIND,%byteinteger X0,X1,  %C
            %integer LINK1,LINK2,LINK3,ADDR4,LINK5,LAB,LINE,  %C
            %shortinteger DOSTART,DOEND,IFSTART,IFEND)
!*
%recordformat PLABF(%shortinteger BLKIND,%byteinteger USE,X1,
                    %integer INDEX,CODEAD,REF,REFCHAIN)
!*
%recordformat IMPDORECF(%integer VAL,LINK,IDEN)
!*
%recordformat CONSTRECF(%shortinteger MODE,LENGTH,
                      (%integer VALUE %OR %integer LINK1),
                      %integer DADDR,CADDR)
!*
%recordformat TMPF((%byteinteger CLASS,TYPE,
                        %shortinteger LEN %OR %integer W0),
                    %integer LINK1,
                    %byteinteger REG,MODE,%shortinteger INDEX,
                    %shortinteger COORD,USECNT,
                    %integer ADDR)
!*
%recordformat CHARF(%integer ADESC,LINK,LEN)
!*
%recordformat FNRECF(%integer FPTR,LINK1,HEAD,PCT)
!*
%recordformat TERECF(%shortinteger MODE,LOOP,
                      %integer CHAIN,DISP1,INDEX,
                      %shortinteger COORD,FLAGS)
!*
%recordformat DTRECF(%shortinteger MODE,IDENT,
                      %integer CHAIN,DISP2,
                      %shortinteger FLAGS,INDEX,
                     (%integer LOOP %OR %record(RESF) CONST))
!*
!*
!***********************************************************************
!* TRIAD record format                                                 *
!***********************************************************************
!*
%recordformat TRIADF(  %C
               %byteinteger OP,
               (%byteinteger USE %OR %byteinteger VAL2),
               %shortinteger CHAIN,
               (%record(RESF) RES1      %OR     %C
               (%shortinteger OPD1,%byteinteger QOPD1,MODE  %OR  %C
               (%integer SLN %OR %integer VAL1))),
               (%record(RESF) RES2      %OR   %C
                %shortinteger OPD2,%byteinteger QOPD2,MODE2))
!*
!***********************************************************************
!* COM record format                                                   *
!***********************************************************************
!*
%recordformat COMFMT(%integer CONTROL,OPT,OPTIONS1,OPTIONS2,PTRACE,
      ADICT,ANAMES,ADOUTPUT,ADBLKDTAID,DICLEN,DPTR,
      MAXTRIADS,NEXTPLAB,ALABH,ADLHEAD,
      SUBPROGTYPE,SFPTR,EXTERNALS,CBNPTR,SCPTR,CHECKLIST,
      RESCOM1,RESCOM2,F77PARM,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,HOST,TARGET,MONERRS,CODECA,
      GLACA,DIAGCA,SSTCA,GSTCA,CONSTCA,SCALARCA,IOAREACA,ZGSTCA,STACKCA,
      W1,W2,W4,STATORDERMODE,CURSTATCLASS,LISTPOINT,STACKBASE,
      NEXTTRIAD,ASAVE,MAXSAVE,SUBTAB,LASTSUBTAB,
      INHIBOP4,ARGCNT,IDCNT,LABCNT,TMLIST,MAINPROG,PROCINDEX,CONSOLE)
!*
!***********************************************************************
!* record format for communicating with optimiser                      *
!***********************************************************************
!*
%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)
!*
!***********************************************************************
!*
!*
%RECORDFORMAT SUBRECF(%INTEGER LINK,FLAGS,TRIADS,DICT,NAMES,PTRS,PROG,
      LABCNT,ARGCNT,IDCNT,TRCNT,REFSCNT,SUBSCNT,
      DPTR,NEXTTRIAD,NAMESFREE,NEXTBIT,SUBPROGTYPE,SUBPROGPTR,
      CBNPTR,SCPTR,CMNIIN,FUNRESDISP,CMNCNT,ASSGOTOS,VRETURN,ENTRIES,
      TMLIST,ALABS,ALHEADS,NEXTPLAB,
      %STRING(32) NAME,%INTEGERARRAY COORDS(0:15))
!*
%CONSTINTEGER SUBSIZE=232
%CONSTINTEGER LABSIZE=128
%CONSTINTEGER LHEADSIZE=620
!*
{%include "ftn_consts3"}
!* modified 23/09/86
!*
!*
%constinteger WSCALE = 2;! scale word address to byte address
%constinteger BSCALE = 0;! scaling factor for words to architectural units
%constinteger CSCALE = 0;! byte offset to architectural unit offset
%constinteger DSCALE = 2;! dict pointer scaling in RES records
!*
%constinteger W1 =  4 ;!  1 word  in architectural units
%constinteger W2 =  8 ;!  2 words in architectural units
%constinteger W3 = 12 ;!  3 words in architectural units
%constinteger W4 = 16 ;!  4 words in architectural units
!*
%constinteger TRIADLENGTH    = 12 ;! size of an individual triad
%constinteger BLRECSIZE      = 44 ;! size of a block table entry in architectural units
%constinteger LOOPRECSIZE    = 16 ;! size of a loop table entry
%constinteger PROPRECSIZE    = 12 ;! size of a propagation table entry
%constinteger CLOOPSZ        = 12 ;! size of cloop table entry
%constinteger FRSIZE         =  8 ;! size of freelist created by PUSHFREE
%constinteger TESZ           = 20
%constinteger DTSZ           = 20
%constinteger ARTICSZ        =  4
%constinteger CTSIZE         =  2 ;! used in OP3
%constinteger EXTNSIZE       =  4 ;! used in OP3
!*
!* following used in strength reduction
!*
%constinteger RDSZ           =  8
%constinteger RUSESZ         = 12
%constinteger RTESTSZ        =  4
%constinteger RDEFSZ         = 16
%constinteger USESZ          = 32
%constinteger SRUSESZ        =  2
%constinteger SRSCALE        =  2;! SR==RECORD(ABLOCKS + SRPTR<<SRSCALE)
%constinteger SRFIXED        = 36
!*
!*
%conststring(5) REG1="reg7"
%constinteger GLAOFFSET=32
%if target=ibm %thenstart
   %constinteger dvarea=7
%finishelsestart
   %constinteger DVAREA=2
%finish
!*
!***********************************************************************
!* 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  =  8;! N.B. this is a reduced size for compiler using Put interfaces
   %constinteger XREFSIZE     =  8
   %constinteger CMNRECEXT    = 16;! extra space on iden record for common block name
   %constinteger TMPRECSIZE   = 20
   %constinteger DVRECSIZE    = 28
   %constinteger TRIADSIZE    = 12
   %constinteger LBLKSIZE     = 520
!*
!*
!********************* TRIAD qualifiers ********************************
!*
%CONSTINTEGER NULL    = 0
%CONSTINTEGER LABID   = 1
%CONSTINTEGER PLABID  = 2
%CONSTINTEGER PROCID  = 3
%CONSTINTEGER STKLIT  = 4
%CONSTINTEGER GLALIT  = 5
%CONSTINTEGER SRTEMP  = 6
%CONSTINTEGER BREG    = 7
%CONSTINTEGER VALTEMP = 8
%CONSTINTEGER DESTEMP = 9
%CONSTINTEGER LSCALID =16
%CONSTINTEGER OSCALID =17
%CONSTINTEGER CSCALID =18
%CONSTINTEGER ASCALID =19
%CONSTINTEGER PSCALID =20
%CONSTINTEGER ARRID   =21
%CONSTINTEGER TMPID   =22
%CONSTINTEGER PERMID  =23
%CONSTINTEGER STFNID  =24
%CONSTINTEGER ITMPID  =22
%CONSTINTEGER RTMPID  =22
%CONSTINTEGER ETMPID  =22
%CONSTINTEGER TRIAD   =32
%CONSTINTEGER ARREL   =33
%CONSTINTEGER CHAREL  =34
%CONSTINTEGER CHVAL   =35
%CONSTINTEGER LIT     =64
%CONSTINTEGER NEGLIT  =65
%CONSTINTEGER CNSTID  =66
!*
!********************* TRIAD masks *************************************
!*
%CONSTINTEGER CONSTMASK=X'40'
%CONSTINTEGER IDMASK   =X'10'
%CONSTINTEGER TEXTMASK =X'20'
!*
!********************* other useful masks ******************************
!*
%CONSTINTEGER ARRAYBIT  = X'04'
%CONSTINTEGER CMNBIT    = X'02'
%CONSTINTEGER EQUIVBIT  = X'80'
!*
!********************* modes *******************************************
!*
%CONSTINTEGER INT2    = 0, INT4    = 1, INT8    = 2
%CONSTINTEGER REAL4   = 3, REAL8   = 4, REAL16  = 5
%CONSTINTEGER CMPLX8  = 6, CMPLX16 = 7, CMPLX32 = 8
%CONSTINTEGER LOG1    = 9, LOG2    =10, LOG4    =11
%CONSTINTEGER LOG8    =12, CHARMODE=13, HOLMODE =14
%CONSTINTEGER BYTE    =15, HEXCONST=16
!*
!********************* types *******************************************
!*
%CONSTINTEGER INTTYPE   = 1
%CONSTINTEGER REALTYPE  = 2
%CONSTINTEGER CMPLXTYPE = 3
%CONSTINTEGER LOGTYPE   = 4
%CONSTINTEGER CHARTYPE  = 5
!*
!********************* scaling factors *********************************
!*
!*
!********************* length of maximum source statement **************
!*
%CONSTINTEGER INPUT LIMIT = 1328
!*
!********************* mode to size/type *******************************
!*
%CONSTBYTEINTEGERARRAY MODETOST(0:15)=  %C
   X'41',X'51',X'61',X'52',X'62',X'72',
   X'53',X'63',X'73',X'34',X'44',X'54',X'64',5,0,X'31'
!*
!********************* mode to bytes etc. ******************************
!*
%CONSTBYTEINTEGERARRAY CSIZE(0:15)=  %c
   2,4,8,4,8,16,8,16,32,1,2,4,8,1,0,1
%CONSTBYTEINTEGERARRAY ModetoBytes(0:15)=  %c
   2,4,8,4,8,16,8,16,32,1,2,4,8,1,0,1
%CONSTBYTEINTEGERARRAY ModetoTempBytes(0:15)=  %c
   4,4,8,4,8,16,8,16,32,4,4,4,8,4,4,4
%CONSTBYTEINTEGERARRAY SETMODE(0:63)= %C
0(4),10,13,0(11),1,3,6,11,0(12),2,4,7,8,0(12),15,5,8,9,0(11)
!*
!********************** location of pseudo common record in dict *******
!*
%CONSTINTEGER PSEUDOCMN=20
!*
!********************** location of blank common record in dict ********
!*
%CONSTINTEGER BLCMPTR=96
!*
!********************** other useful consts ****************************
!*
%CONSTINTEGER NO  = 0
%CONSTINTEGER YES = 1
%CONSTINTEGER FULL= 2
!*
!********************** area identifiers *******************************
!*
%constinteger STACK   = 0
%CONSTINTEGER GLA     = 2
%CONSTINTEGER SST     = 4
%CONSTINTEGER GST     = 5
%CONSTINTEGER DIAGS   = 6
%if target=ibm %thenstart
   %constinteger scalars=7
%finishelsestart
   %CONSTINTEGER SCALARS = 2
%finish
%CONSTINTEGER IOAREA  = 8
%CONSTINTEGER ZEROGST = 9
%CONSTINTEGER CONSTS  =10
!*
!********************** system procedures ******************************
!*
%constinteger F77AUX   = 0
%constinteger F77STOP  = 1
%constinteger F77PAUSE = 2
%constinteger F77IOA   = 3
%constinteger F77IOB   = 4
%constinteger F77IOC   = 5
%constinteger F77IOD   = 6
%constinteger F77IOE   = 7
%constinteger F77IOF   = 8
%constinteger F77FILE  = 9
%constinteger IMPSTOP  =10
%constinteger F77RTERR =11
%constinteger F77IOAR  =12
%constinteger F77IOBR  =13
%constinteger F77IOG   =14
%constinteger F77CPSTR =15
%constinteger F77CONCAT=16
%constinteger F77INDEX =17
%constinteger FIBITS   =18
%constinteger FISHFTC  =19
%constinteger F77PCHECK=20
%constinteger F77IOH   =21
%constinteger F77IOI   =22
!***********************************************************************
!*
{%include "ebits_ecodes7"
!
!************************************************************************
!*                                                                      *
!*                                                    G.E.Millard       *
!*   ECODES8F                                         23/09/86          *
!*                                                                      *
!************************************************************************
!
{00} %constinteger      HALT =   0
!
!--------------------------------------- generic int operations -------
!
{01} %constinteger      IADD =   1     { (Etos-1) + (Etos) => (Etos)   }
{02} %constinteger      ISUB =   2     { (Etos-1) - (Etos) => (Etos)   }
{03} %constinteger     IMULT =   3     { (Etos-1) * (Etos) => (Etos)   }
{04} %constinteger      IDIV =   4     { (Etos-1) / (Etos) => (Etos)   }
{05} %constinteger      INEG =   5     {          - (Etos) => (Etos)   }
{06} %constinteger      IABS =   6     {     abs( (Etos) ) => (Etos)   }
{07} %constinteger      IREM =   7     { remainder from                }
                                       {  (Etos-1) / (Etos)=> (Etos)   }
!
{08} %constinteger      IAND =   8     { (Etos-1) & (Etos) => (Etos)   }
{09} %constinteger       IOR =   9     { (Etos-1) ! (Etos) => (Etos)   }
{0A} %constinteger      INOT =  10     {          ~ (Etos) => (Etos)   }
{0B} %constinteger      IXOR =  11     { (Etos-1) !! (Etos) => (Etos)  }
{0C} %constinteger     ISHLL =  12     { (Etos-1) << (Etos) => (Etos)  }
{0D} %constinteger     ISHRL =  13     { (Etos-1) >> (Etos) => (Etos)  }
{0E} %constinteger     ISHLA =  14     { arithmetic left shift         }
{0F} %constinteger     ISHRA =  15     { arithmetic right shift        }
!
{10} %constinteger       IGT =  16     { if                            }
{11} %constinteger       ILT =  17     {    (Etos-1) <relop> (Etos)    }
{12} %constinteger       IEQ =  18     { then                          }
{13} %constinteger       INE =  19     {    true  (1) => (Etos)        }
{14} %constinteger       IGE =  20     { else                          }
{15} %constinteger       ILE =  21     {    false (0) => (Etos)        }
{16} %constinteger       BNOT=  22     {  (Etos) = BNOT (Etos) 0<->1   }
!
{18} %constinteger      JIGT =  24     { if                            }
{19} %constinteger      JILT =  25     {    (Etos-1) <relop> (Etos)    }
{1A} %constinteger      JIEQ =  26     { then                          }
{1B} %constinteger      JINE =  27     {    -> <label>                 }
{1C} %constinteger      JIGE =  28     { else                          }
{1D} %constinteger      JILE =  29     {    continue                   }
!
{1E} %constinteger    JINTGZ =  30     { if (Etos) > 0 %then -> <lab>  }
{1F} %constinteger    JINTLZ =  31     { if (Etos) < 0 %then -> <lab>  }
{20} %constinteger     JINTZ =  32     { if (Etos) = 0 %then -> <lab>  }
{21} %constinteger    JINTNZ =  33     { if (Etos) # 0 %then -> <lab>  }
{22} %constinteger   JINTGEZ =  34     { if (Etos) >=0 %then -> <lab>  }
{23} %constinteger   JINTLEZ =  35     { if (Etos) <=0 %then -> <lab>  }
! 
{24} %constinteger      ITWB =  36     { if (Etos) < 0 then -> <lab1>  } 
                                       {           = 0 then -> <lab2>  }
                                       {           > 0 then -> <lab3>  }
!
!--------------------------------------- miscellaneous operations------
!
{26} %constinteger      JUMP =  38     { -> <label>                    }
{29} %constinteger       SFA =  41     { SF => (Etos)                  }
{2A} %constinteger    RETURN =  42     { procedure exit                }
{2B} %constinteger      ASF  =  43     { SF = SF + (Etos)              }
!
{2C} %constinteger     IPUSH =  44     { (Etos) => (Mstack)            }
{2D} %constinteger      IPOP =  45     { (Mstack) => (Etos)            }
{2E} %constinteger      EXCH =  46     { (Etos-1) <=> (Etos)           }
{2F} %constinteger      DUPL =  47     { replicate (Etos)              }
{30} %constinteger   DISCARD =  48     { discard (Etos)                }
!
{33} %constinteger    INDEX1 =  51     { (@ Etos-1) + (Etos)           }
                                       {               => (@ Etos)     }
{34} %constinteger    INDEX2 =  52     { (@ Etos-1) + (Etos)*2         }
                                       {               => (@ Etos)     }
{35} %constinteger    INDEX4 =  53     { (@ Etos-1) + (Etos)*4         }
                                       {               => (@ Etos)     }
{36} %constinteger    INDEX8 =  54     { (@ Etos-1) + (Etos)*8         }
                                       {               => (@ Etos)     }
{37} %constinteger     INDEX =  55     { (@ Etos-2)                    }
                                       {     + (Etos-1)*(Etos)         }
                                       {               => (@ Etos)     }
!
{38} %constinteger       MVB =  56     { move (Etos) bytes             }
                                       {  ((@ Etos-2)) => ((@ Etos-1)) }
!
{39} %constinteger       CHK =  57     { check that                    }
                                       { (Etos-1)<=(Etos-2)<=(Etos)    }
                                       { (Etos-2) => (Etos)            }
!
{3A} %constinteger     TMASK =  58     { (Etos-1) & (Etos)             }
                                       { - to be followed by JI[N]Z    }
!
{3E} %constinteger     CPBGT =  62     { if (Etos) bytes               }
{3F} %constinteger     CPBLT =  63     {  ((Etos-2)) <relop> ((Etos-1))}
{40} %constinteger     CPBEQ =  64     { then                          }
{41} %constinteger     CPBNE =  65     {    true  (1) => (Etos)        }
{42} %constinteger     CPBGE =  66     { else                          }
{43} %constinteger     CPBLE =  67     {    false (0) => (Etos)        }
!
!-------------------------------------- generic unsigned operations ---
!
{50} %constinteger     UADD =  80      { (Etos-1) + (Etos) => (Etos)   }
{51} %constinteger     USUB =  81      { (Etos-1) - (Etos) => (Etos)   }

{52} %constinteger      UGT =  82      { if                            }
{53} %constinteger      ULT =  83      {    (Etos-1) <relop> (Etos)    }
{54} %constinteger      UEQ =  84      { then                          }
{55} %constinteger      UNE =  85      {    1 => (Etos)                }
{56} %constinteger      UGE =  86      { else                          }
{57} %constinteger      ULE =  87      {    0 => (Etos)                }
 
{58} %constinteger     JUGT =  88      { if                            }
{59} %constinteger     JULT =  89      {    (Etos-1) <relop> (Etos)    }
{5A} %constinteger     JUEQ =  90      { then                          }
{5B} %constinteger     JUNE =  91      {    -> <label>                 }
{5C} %constinteger     JUGE =  92      { else                          }
{5D} %constinteger     JULE =  93      {    continue                   }

{5E} %constinteger    JUGTZ =  94      { if (Etos) > 0 %then -> <lab>  }
{5F} %constinteger    JULTZ =  95      { if (Etos) < 0 %then -> <lab>  }
{60} %constinteger    JUEQZ =  96      { if (Etos) = 0 %then -> <lab>  }
{61} %constinteger    JUNEZ =  97      { if (Etos) # 0 %then -> <lab>  }
{62} %constinteger    JUGEZ =  98      { if (Etos) >=0 %then -> <lab>  }
{63} %constinteger    JULEZ =  99      { if (Etos) <=0 %then -> <lab>  }

{64} %constinteger   UCVTII = 100      { (int Etos-1) => int size(Etos)}{*}
!
!---------------------------------- generic int operations to store----
!
{65} %constinteger    IADDST = 101    { (Etos-1) = (Etos-1)+(Etos)   }{*}
{66} %constinteger    ISUBST = 102    { (Etos-1) = (Etos-1)-(Etos)   }{*}
{67} %constinteger   IMULTST = 103    { (Etos-1) = (Etos-1)*(Etos)   }{*}
{68} %constinteger    IDIVST = 104    { (Etos-1) = (Etos-1)/(Etos)   }{*}
{69} %constinteger    INEGST = 105    { (Etos)   = - (Etos)          }{*}
!
{72} %constinteger    IANDST = 108    { (Etos-1) = (Etos-1)&(Etos)   }{*}
{73} %constinteger     IORST = 109    { (Etos-1) = (Etos-1)!(Etos)   }{*}
{74} %constinteger    INOTST = 110    { (Etos)   = ~ (Etos)          }{*}
{75} %constinteger    IXORST = 111    { (Etos-1) = (Etos-1)!!(Etos)  }{*}
!
!-------------------------------------- generic real operations -------
!
{71} %constinteger     RADD = 113     { (Etos-1) + (Etos) => (Etos)    }
{72} %constinteger     RSUB = 114     { (Etos-1) - (Etos) => (Etos)    }
{73} %constinteger    RMULT = 115     { (Etos-1) * (Etos) => (Etos)    }
{74} %constinteger     RDIV = 116     { (Etos-1) / (Etos) => (Etos)    }
{75} %constinteger     RNEG = 117     {        - (Etos) => (Etos)      }
{76} %constinteger     RABS = 118     {   abs( (Etos) ) => (Etos)      }
!
{88} %constinteger    CVTII = 136     { (int Etos-1) => int size(Etos) }
{89} %constinteger    CVTIR = 137     { (int Etos-1) => real size(Etos)}
{8A} %constinteger    CVTRR = 138     { (real Etos-1)=> real size(Etos)}
{8B} %constinteger    TNCRI = 139     { (real Etos-1)=> int size(Etos) trunc toward 0}
{8C} %constinteger    RNDRI = 140     { (real Etos-1)=> int size(Etos) to nearest int}
{8D} %constinteger   EFLOOR = 141     { (real Etos-1)=> int size(Etos)  towards -inf }
{8E} %constinteger    TNCRR = 142
{8F} %constinteger    RNDRR = 143
!
{90} %constinteger       RGT = 144     { if                            }
{91} %constinteger       RLT = 145     {    (Etos-1) <relop> (Etos)    }
{92} %constinteger       REQ = 146     { then                          }
{93} %constinteger       RNE = 147     {    1 => (Etos)                }
{94} %constinteger       RGE = 148     { else                          }
{95} %constinteger       RLE = 149     {    0 => (Etos)                }
!
{96} %constinteger      JRGT = 150     { if                            }
{97} %constinteger      JRLT = 151     {    (Etos-1) <relop> (Etos)    }
{98} %constinteger      JREQ = 152     { then                          }
{99} %constinteger      JRNE = 153     {    -> <label>                 }
{9A} %constinteger      JRGE = 154     { else                          }
{9B} %constinteger      JRLE = 155     {    continue                   }
!
{9C} %constinteger      JRGZ = 156     { if (Etos) > 0 %then -> <lab>  }
{9D} %constinteger      JRLZ = 157     { if (Etos) < 0 %then -> <lab>  }
{9E} %constinteger       JRZ = 158     { if (Etos) = 0 %then -> <lab>  }
{9F} %constinteger      JRNZ = 159     { if (Etos) # 0 %then -> <lab>  }
{A0} %constinteger     JRGEZ = 160     { if (Etos) >=0 %then -> <lab>  }
{A1} %constinteger     JRLEZ = 161     { if (Etos) <=0 %then -> <lab>  }
!
{A2} %constinteger      RTWB = 162     { if (Etos) < 0 then -> <lab1>  }
                                       {           = 0 then -> <lab2>  }
                                       {           > 0 then -> <lab3>  }
{A3} %constinteger     JTRUE = 163     { if (Etos) true  then -> <lab  }
{A4} %constinteger    JFALSE = 164     { if (Etos) false then -> <lab> }
!
!----------------------------------------------------------------------
!
{B1} %constinteger    UCHECK = 177    { if (Etos) unassigned diagnose  }
{B8} %constinteger    ESTORE = 184    { ((Etos)) = (Etos-1)            }
{B9} %constinteger EDUPSTORE = 185    { ((Etos)) = (Etos-1)            }
                                      { retain (Etos-1) as new (Etos)  }
{BA} %constinteger   PUSHVAL = 186    { push (Etos) as value param     }
{BB} %constinteger  PUSHADDR = 187    { push (Etos) as ref param       }
{BC} %constinteger      EVAL = 188    { force load of (Etos)           }
{BD} %constinteger  EVALADDR = 189    { force load of @ at (Etos)      }
{BE} %constinteger  EADDRESS = 190    { address(Etos) is required      }
{BF} %constinteger   EINTRES = 191    { (Etos) is integer fn result    }
{C0} %constinteger  EREALRES = 192    { (Etos) is real fn result       }
{C1} %constinteger     ESIZE = 193    { size of (Etos-1) is (Etos)     }

{C2}%constinteger     EPOWER = 194    { (Etos-3) @ result if cx        }
                                      { (Etos-2) base (@ base if cx)   }
                                      { (Etos-1) power(@ power if cx)  }
                                      { (Etos)   procindex             }

{C3}%constinteger    EPOWERI = 195    { (Etos-2) base                  }
                                      { (Etos-1) power (int)           }
                                      { (Etos)   procindex (0-3)       }

                                      { procindex =  0  powii          }
                                      {              1  powri          }
                                      {              2  powdi          }
                                      {              3  powqi          }
                                      {              4  powci          }
                                      {              5  powzi          }
                                      {              6  powzzi         }
                                      {              9  powrr          }
                                      {             10  powdd          }
                                      {             11  powqq          }
                                      {             12  powcc          }
                                      {             13  powzz          }
                                      {             14  powzzz         }

{C4} %constinteger   ARGPROC = 196    { call formal procedure in (Etos }
{C5} %constinteger PUSHBYTES = 197    { push (Etos) bytes from         }
                                      { (@etos-1) as value parameter   }
{C6} %constinteger    EAUXSF = 198    { AUXSF => (ETOS)                }
{C7} %constinteger   EAUXADD = 199    { AUXSF = AUXSF + (ETOS)         }
{C8} %constinteger   EAUXRES = 200    { AUXSF = (ETOS)                 }
{C9} %constinteger   EOLDLNB = 201    { stack LNB needed for diags     }
!
!***********************************************************************
!*                                                                     *
!*         Fortran specific codes                                      *
!*                                                                     *
!***********************************************************************
!
%constinteger CXADD       = 257       { ((Etos-3)) = ((Etos-2))        }
%constinteger CXSUB       = 258       {                      op        }
%constinteger CXMULT      = 259       {                      ((Etos-1))}
%constinteger CXDIV       = 260       { (Etos) = variant<<8 ! sizecode }

%constinteger CXNEG       = 261       { ((Etos-2)) = - ((Etos-1))      }
                                      { (Etos) = sizecode              }

%constinteger CXASGN      = 262       { ((Etos-2)) = ((Etos-1))        }
                                      { (Etos) = variant<<8            }
                                      {            ! sizecode(RHS)<<2  }
                                      {              ! sizecode(LHS)   }

%constinteger CXEQ        = 263       { (Etos) =  ((Etos-2))           }
%constinteger CXNE        = 264       {                  op ((Etos-1)) }
                                      { (Etos) = variant<<8 ! sizecode }

%constinteger ECMPLX1     = 286       { ((Etos-2))=((Etos-1),0)        }
%constinteger ECMPLX2     = 287       { ((Etos-3))=((Etos-2),(Etos-1)) }
                                      { (Etos) = sizecode              }

%constinteger ECONJG      = 279       { ((Etos-2) =  conjg((Etos-1))   }
                                      { (Etos) = sizecode              }

                                      { variant  = 0    cx op cx       }
                                      {            1    cx op real     }
                                      {            2  real op cx       }
                                      { sizecode = 0    c*8   (r*4)    }
                                      {            1    c*16  (r*8)    }
                                      {            2    c*32  (r*16)   }

%constinteger EANINT      = 266       { (Etos) = anint (Etos)          }
%constinteger EM1EXP      = 267       { (Etos) = (-1) ** (Etos) - int  }

%constinteger EISIGN      = 268       { (Etos) = sign(Etos)            }
%constinteger ESIGN       = 269       {                  * abs(Etos-1) }

%constinteger EIMOD       = 270       { (Etos) = int(Etos-1)/(Etos)    }
%constinteger ERMOD       = 271       {                       * (Etos) }

%constinteger EIDIM       = 272       { (Etos) = if (Etos-1) > (Etos)  }
%constinteger ERDIM       = 273       {          then (Etos-1)-(Etos)  }
                                      {          else 0

%constinteger EIMIN       = 274       { (Etos) = min( (Etos-1),        }
%constinteger ERMIN       = 275       {                (Etos) )        }

%constinteger EIMAX       = 276       { (Etos) = max( (Etos-1),        }
%constinteger ERMAX       = 277       {                (Etos) )        }

%constinteger EDMULT      = 278       { (Etos) = dble((Etos-1)*(Etos)) }

%constinteger ECHAR       = 280       {  ((Etos-1)) = char(Etos)       }
%constinteger EICHAR      = 281       {      (Etos) = ichar((Etos-1))  }

%constinteger EINDEXCHAR  = 282       {      (Etos) = index( C1,C2 )   }
                                      {  ((Etos-3)) = Charad(C1)       }
                                      {   (Etos-2)  = Charlen(C1)      }
                                      {  ((Etos-1)) = Charad(C2)       }
                                      {    (Etos)   = Charlen(C2)      }

%constinteger ECONCAT     = 283       {          C1 = concat list      }
                                      {  ((Etos-3)) = @ concat table   }
                                      {   (Etos-2)  = no. items        }
                                      {  ((Etos-1)) = Charad(C1)       }
                                      {    (Etos)   = Charlen(C1)      }

%constinteger EASGNCHAR   = 284       {          C1 = C2               }
                                      {  ((Etos-3)) = Charad(C1)       }
                                      {   (Etos-2)  = Charlen(C1)      }
                                      {  ((Etos-1)) = Charad(C2)       }
                                      {    (Etos)   = Charlen(C2)      }

%constinteger ECOMPCHAR   = 285       {     (Etos) = compare( C1,C2 )  }
                                      {  ((Etos-4)) = Charad(C1)       }
                                      {   (Etos-3)  = Charlen(C1)      }
                                      {  ((Etos-2)) = Charad(C2)       }
                                      {   (Etos-1)  = Charlen(C2)      }
                                      {    (Etos)   = relop            }
                                      {  relop  =  0 >   1 <   2 =     }
                                      {            3 #   4 >=  5 <=    }

%constinteger EISHFT      = 288       { (Etos) = (Etos-1) << (Etos)    }
%constinteger EIBITS      = 289       { (Etos) = (Etos) bits from      }
                                      {       bit (Etos-1) in (Etos-2) }
%constinteger EIBSET      = 290       { (Etos) = (Etos-1)&(1<<(Etos))  }
%constinteger EIBTEST     = 291       { (Etos) = (Etos-1)!(1<<(Etos))  }
%constinteger EIBCLR      = 292       { (Etos) = (Etos-1)&\(1<<(Etos)) }
%constinteger EISHFTC     = 293       { (Etos) = (Etos-1) <<c (Etos)   }

%constinteger PROCARG     = 294
%constinteger IPROCARG    = 295
%constinteger CHARARG     = 296
%constinteger IPROCCALL   = 297
%constinteger ARGPROCCALL = 298       {   (Etos)   = paramsize(bytes)  }
                                      {   (Etos-1) = arg               }

%constinteger CALLTPLATE  = 299
%constinteger NOTEIORES   = 300
%constinteger STKIORES    = 301

%constinteger EFCVT       = 302       { convert(Etos-1)                }
                                      { (Etos)      convert code       }
%constinteger EFCVTASGN   = 303       { (Etos-1) =  convert(Etos-2)    }
                                      { (Etos)      convert code       }
                                      { convert code=oldmode<<3!newmode}
                                      { mode =[0  bit - futures]       }
                                      {        1  I1 (byte)            }
                                      {        2  I2                   }
                                      {        3  I4                   }
                                      {        4  I8                   }
                                      {        5  R4                   }
                                      {        6  R8                   }
                                      {        7  R16                  }

%constinteger EARGLEN     = 304       { (Etos) is char arg len         }
                                      {   - on Amdahl load bottom half }

%constinteger EFDVACC     = 305       { dope vector special evaluation }
                                      { (Etos-1) => (Etos)             }
                                      { (Etos-2) + (Etos-1)*(Etos)     }
                                      {                => (Etos-1)     }

%constinteger EFNOTEVR    = 306       { (Etos) is the variable return  }
                                      { index                          }

%constinteger EFSETVR     = 307       { stack a descriptor for the     }
                                      { variable return index          }

%constinteger EINCR       = 308
%constinteger EDECR       = 309
%constinteger ELOADB      = 310
%constinteger ESTOREB     = 311
%constinteger EINCRB      = 312
%constinteger EDECRB      = 313
%constinteger EDINIT      = 314
%constinteger ELSHIFT     = 315
%constinteger ERSHIFT     = 316
%constinteger EADJL       = 317
%constinteger EADJR       = 318
%constinteger EVERIFY     = 319
!
!************************************************************************
!* modified 19/08/85
!*
%externalroutinespec Einitialise(%integer Lang, Avertext, Astackca,
                                                    Aglaca, Options)
%externalroutinespec Ecommon(%integer area, %stringname Name)
%externalroutinespec Eendcommon(%integer area, Length)
%externalroutinespec Estkdir(%integer Area, Offset, Adid, Bytes)
%externalroutinespec Estkresult(%integer Class, Type, Bytes)
%externalroutinespec Epromote(%integer Level)
%externalroutinespec Estkaddr(%integer Area, Offset, Adid, Bytes)
!*
%externalroutinespec Ed1(%integer area, Disp, Val)
%externalroutinespec Ed2(%integer area, Disp, Val)
%externalroutinespec Ed4(%integer area, Disp, Val)
%externalroutinespec Edbytes(%integer area, Disp, len, ad)
%externalroutinespec Edpattern(%integer area, Disp, ncopies, len, ad)
%externalroutinespec Efix(%integer area, disp, tgtarea, tgtdisp)
!*
%externalintegerfnspec EXname(%integer type, %string(255)%name Xref)
%externalroutinespec Eprecall(%integer Id)
%externalroutinespec Ecall(%integer Id, Numpars, Paramsize)
!*
%externalroutinespec Eop(%integer Opcode)
!*
!*
!*
!***********************************************************************
!* 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,%integer AllowBSS)
%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 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 BSSreloc(%integer Ptr)
%externalstringfnspec Lowstring(%string(63) S)
%externalroutinespec Lfault(%integer Er)
%externalroutinespec Init End(%integer Ep,Info)
%externalintegerfnspec Dictspace(%integer Length)
%externalroutinespec Dicful
%externalroutinespec Extful
!*
%if Target=Gould %thenstart
   %externalroutinespec Mprivatecall
%finish
!*
%if Target=Lattice %thenstart
   %externalintegerfnspec ICltag(%integer area,offset,mode)
%finish
!*
!***********************************************************************
!* Local procs                                                         *
!***********************************************************************
!*
!*
%constinteger Max Area Size=X'F00000'
!*
%ownrecord(Comfmt)%name Com
%owninteger Init9,Area9offset
%owninteger Techain
%owninteger Ruse1,Ruse2,Ruse3,Lastreg
%owninteger Labblocks
!*
!*
{%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"                    }
!*
%if Target=Gould %thenstart
!*
%conststring(7)%array Gen Name(0:69) = "",
   "sqrt"  ,"exp"   ,"log"   ,"lg10" ,   
   "sin"   ,"cos"   ,"tan"   ,"cot"   ,   
   "asin"  ,"acos"  ,"atan"  ,"xtn2" ,   
   "sinh"  ,"cosh"  ,"tanh"  ,""      ,   
   ""      ,"cabs"  ,"cdabs" ,"abs"   ,   
   "l_ge"   ,"l_gt"   ,"l_le"   ,"l_lt"   ,   
   "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"
!*
%finishelsestart
!*
%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"
!*
%finish
!*
%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'10802',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'
!*
%conststring(3)%array Gldprefix(0:15) = %c
   "","","","rv_","d_","","c_","z_",""(8)
!*
%ownintegerarray Genprocref(0:69)
!*
%constintegerarray Gldproctype(0:7) = %c
      X'10402',X'10401',X'10402',X'10402',
      X'10802',X'10401',X'10802',X'10802'
!*
%conststring(7)%array Gldprocnames(0:7) = %c
      "r_ceil", "ir_expn","r_frac", "r_flr",
      "d_ceil", "id_expn","d_frac", "d_flr"
!*
%ownintegerarray Gldprocref(0:7)
!*
%conststring(9)%array Sysprocs(0:22)=  %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_ishftc3",   
      "f_pcheck","f_ioh"  ,"f_ioi"
!*
%constbyteintegerarray Sysparams(0:22) = %c   
       2, 2, 2, 2, 2,                        
       2, 2, 2, 2, 2,                        
       0, 3, 2, 2, 2,                        
       6, 4, 4, 3, 2,                        
       4, 2, 2                                     
!*
%constintegerarray Sysprocpdesc(0:22)= %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'3000C',
      X'40010',X'20008',X'20008'
!*
%constintegerarray Sysproctype(0:22)= %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',X'10401',X'10401'
!*
%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
!*
%externalroutine Init Data(%integer Mode,Adcom,Rel,Avers)
%integer I,Eflags
      Com==record(Adcom)
!*
      %if Mode=0 %thenstart;! initialisation at start of compilation
         Com_Glaca=Glaoffset
         %if Target=IBM %then Com_Glaca=Com_Glaca+108
         Eflags=Com_Control&1     { emon (quotes) flag }
         %if Com_Control&X'4000'#0 %then Eflags=Eflags!2 { code listing }
         %if Com_F77parm&X'10000000'#0 %thenstart
            Eflags=Eflags!X'18'        { sdb/dbx }
         %finishelsestart
            %if Com_Diaglevel=0 %thenstart
               Eflags=Eflags!8         { minimum diags }
            %finishelsestart
               %if Com_Diaglevel>0 %thenstart
                  Eflags=Eflags!X'10'   { line no update }
               %finish
            %finish
         %finish
         %if Com_Options2&X'20'#0 %then Eflags=Eflags!X'20'
         Einitialise(2,Avers,addr(Com_Stackca),addr(Com_Glaca),Eflags)
         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,7
            Gldprocref(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_Sstca=0
         Com_Gstca=0
         Com_Codeca=0
         Com_Zgstca=0
         %if Target=Gould %thenstart
            Init9=0    {use BSS for local unitialised arrays}
         %finishelsestart
            Init9=1
         %finish
         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'####'
!*
         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_Scalarca=4;! to avoid possible confusion with 0 fn result @
         %finishelsestart
            I=32
            Com_Scalarca=0
         %finish
         %unless target=lattice %thenstart
            Edbytes(GLA,0,I,addr(Area2(0)))
         %finish
!*
         %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 Com_Cmncnt#0 %thenstart;! define commons
            %cycle I=1,1,Com_Cmncnt
               EendCommon(CM(I)_IIN,CM(I)_Len)  
            %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
!*
      ALLOC(PTR)
      PP==record(COM_ADICT+PTR)
      %if PP_CLASS&4#0 %thenstart;! array
         %if PP_IIN=ZEROGST %then BSSreloc(Ptr)
         DVREC==record(COM_ADICT+PP_ADDR4)
         BASE=DVREC_ADFIRST
      %finishelsestart;! scalar
         BASE=PP_ADDR4
      %finish
      IIN=PP_IIN
      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>255 %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" %thenstart;! blank common
         K=2
      %finishelsestart
         K=0
         T=Lowstring(T)
      %finish
      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
         %if Target=Gould %thenstart
            %if Len>=8 %thenstart
               %if Com_Stackca&4#0 %then Com_Stackca=Com_Stackca+4
            %finish
         %finish
         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
         %if Target=Gould %thenstart
             %if Len>=8 %and Ad&4#0 %thenstart
                Ad=Ad+4
                Com_Glaca=Com_Glaca+4
             %finish
          %finish
      %finish
      Len=(Len+3)&X'FFFFFFFC'
      %if LEN >MAX AREA SIZE %thenstart
         LFAULT(343);! 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
            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 AllowBSS)
!* AllowBSS = 0  do not allocate in BSS
!*            1  can use BSS
%integer Ad
      Len=(Len+7)&X'FFFFFFF8'
      %if LEN >MAX AREA SIZE %thenstart
         LFAULT(343);! require > permitted area size
         IIN=10
         %result=0
      %finish
      IIN=GST
      %if Com_Statordermode>3 %and Com_F77parm&4#0 %and AllowBSS#0  %c
                              %and Init9=0 %thenstart;! has not been initialised and no unass checks
         IIN=ZEROGST
         Ad=0  {to avoid unassigned check - actual will be set later}
      %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 Target=Gould %thenstart
         %if Len<=3 %thenstart
            Disp=Scalar Space(4,IIN)
            ->Init
         %finish
      %finish
      Saveinit9=Init9
      Init9=1;! to force allocation in GST  
      Disp=Array Space(Len+1,IIN,0);! +1 to ensure zero terminator
      Init9=Saveinit9                       
Init: %if Ad#0 %then EDbytes(IIN,Disp,Len,ad)
      %result=Disp
%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                           *
!***********************************************************************
%integer I
      %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
      %if Target=Lattice %thenstart
         I=ICltag(0,Tmp_Addr,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
!*
%integerfn Boundval(%integer Bound)
%record(Resf) R
      R_W=Bound
      %if R_Form=0 %thenstart
         %result=R_H0
      %finishelsestart
         %result=integer(Com_Adict+R_H0<<DSCALE)
      %finish
%end;! Boundval
!*
%externalroutine Alloc Nmlist(%integer R)
%recordformat Wfmt(%integer W %or %byteinteger b0,b1,%shortinteger h1)
%record(Wfmt) W
%record(Resf) Res
%record(Srecf)%name SS
%record(Precf)%name NML,PP
%record(Arraydvf)%name Dvrec
%integer Ad,Bits,Ptr,Sptr,Len,Class,Dims,Glaca,I
%string(32) S
      Res_W=R
      NML==record(Com_Adict+Res_H0<<Dscale)
      Ad=Com_Ioareaca
      %if Ad=0 %then Ad=4
      NML_Addr4=Ad
      S=string(Com_Anames+NML_Iden)
      Len=length(S)+1
      Edbytes(Ioarea,Ad,Len,addr(S))
      Ad=Ad+((Len+3)>>2)<<2
      Sptr=NML_Inf3
      %while Sptr#0 %cycle
         SS==record(Com_Adict+Sptr)
         Sptr=SS_Link1
         Ptr=SS_Inf0
         Alloc(Ptr)
         PP==record(Com_Adict+Ptr)
         Class=PP_Class
         W_b1=PP_Type&15
         %if PP_Type=Chartype %thenstart
            W_h1=PP_Len
         %finishelsestart
            W_h1=1<<(PP_Type>>4-3)
            %if W_b1=3 %then W_h1=W_h1<<1   { complex}
         %finish
         Bits=0
         %if Class&1#0 %then Bits=X'80' %else Bits=0
         %if Class&4#0 %then Bits=X'20'
         W_b0=Bits
         Ed4(Ioarea,Ad,W_w)
         Ed4(Ioarea,Ad+4,0)
         ED4(Ioarea,Ad+8,0)
         %if Class&6=0 %thenstart;! simple scalar or param
            Efix(Ioarea,Ad+4,PP_IIN,PP_Addr4)
         %finishelsestart;! array
            Dvrec==record(Com_Adict+PP_Addr4)
            Efix(Ioarea,Ad+4,Gla,Dvrec_Addrdv)
            Glaca=Com_Glaca
            Efix(Ioarea,Ad+8,Gla,Glaca)
            Dims=Dvrec_Dims
            Ed4(Gla,Glaca,Dims)
            Glaca=Glaca+4
            %cycle I=1,1,Dims
               Ed4(Gla,Glaca,Boundval(Dvrec_B(I)_L))
               Ed4(Gla,Glaca+4,Boundval(Dvrec_B(I)_U))
               Glaca=Glaca+8
            %repeat
            Com_Glaca=Glaca
         %finish
         Ad=Ad+12
         S=string(Com_Anames+PP_Iden)
         Len=length(S)+1
         Edbytes(Ioarea,Ad,Len,addr(S))
         Ad=Ad+((Len+3)>>2)<<2
      %repeat
      Ed4(Ioarea,Ad,-1)
      Com_Ioareaca=Ad+4
%end;! Alloc Nmlist
!*
!*****************************************************************************
!*                                                                           *
!* User and library procedure calls                                          *
!*                                                                           *
!*****************************************************************************
!*
%externalroutine Syscall(%integer Proc)
%integer I,J,T
%string(31) S
      %if Target=Gould %thenstart
         Mprivatecall
      %finish
      T=Sysproctype(Proc)
      J=Sysprocref(Proc)
      %if Target=Lattice %thenstart
         T=(T&X'FFFF')!(Sysprocpdesc(Proc)&X'FFFF0000')
      %finish
      %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 %thenstart
            %if Target=LATTICE %thenstart
               Epromote(I+1)
            %finishelsestart
               Epromote(I)
            %finish
         %finish
         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 X'D9'<=Index<=X'DC' %thenstart  {Gould Ceiling,Exponent,Fraction,Floor}
         Index=Index-X'D9'
         %if Mode=REAL8 %then Index=Index+4
         T=Gldproctype(Index)
         J=Gldprocref(Index)
         %if J=0 %thenstart
            S=Gldprocnames(Index)
            J=Exname(T,S)
            Gldprocref(Index)=J
         %finish
         I=1  {no of params}
         ->Call
      %finish
      %if Index=20 %thenstart
         %if Target#Gould %thenstart
            %if Mode=CMPLX8 %then Index=18 %else Index=19
         %finish
         Procindex=Index
      %finishelsestart
         %if 16<=Index<=19 %thenstart;! erf,erfc,gamma,lgamma
            Index=Index+46;! range 62-65
            Procindex=Index
            %if Mode=REAL8 %then Procindex=Procindex+4
         %finishelse Procindex=Index+Variant(Mode)
      %finish
      T=Genproctype(Procindex)
      J=Genprocref(Procindex)
      %if Target=Lattice %thenstart
         T=(T&X'FFFF')!(Genprocpdesc(Procindex)&X'FFFF0000')
      %finish
      %if J=0 %thenstart
         %if Target=Gould %thenstart
            %if Mode=REAL8 %and Index&3#0 %thenstart
               S=Genname(Index)
            %finishelsestart
               S=Gldprefix(Mode).Genname(Index)
            %finish
         %finishelsestart
            S="f_".Genname(Procindex)
         %finish
         J=Exname(T,S)
         Genprocref(Procindex)=J
      %finish
      I=Genparams(Procindex)
Call: Ecall(J,I,I<<2)
      %if T&7#0 %thenstart;! function
         Estkresult(0,T&7,(T>>8)&255)
      %finish
%end;! Intrincall
!*
!*
%endoffile