!                                                            farith1
! 09/10/86 - insert include files
!                                                            ftnarith9
!* modified 15/06/86                                         ftnarith7
!*
%include "ftn_ht"
{%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 "ftn_fmts2"}
!* 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
!*
!*
!***********************************************************************
!* exports                                                             *
!***********************************************************************
!*
%routinespec Init Num(%integer Acom)
%integerfnspec Coerce Const(%integer A,Oldmode,Newmode,Adict, 
                            %integername Dptr)
%integerfnspec Const Eval(%integer Resl,Op,Resr,%record(Resf)%name Res,
                          %integer Adict,%integername Dptr)
%integerfnspec Conval(%integer Il,Ir,Op,Mode)
%integerfnspec Gconval(%integer IL,OP,IR,%integername Val)
%integerfnspec Concheck(%record(Resf) Res)
!*
!***********************************************************************
!* imports                                                             *
!***********************************************************************
!*
%externalintegerfnspec Scalar Space(%integer Len,%integername IIN)
%externalroutinespec Fault(%integer er)
%externalroutinespec Lfault(%integer er)
!*
!***********************************************************************
!* OWN variables                                                       *
!***********************************************************************
!*
%ownrecord(COMFMT)%name Com
!*
!***********************************************************************
!* consts                                                              *
!***********************************************************************
!*
%CONSTBYTEINTEGERARRAY CONST TRAN(0:110)= 0,
    0,    0,    0,    0,    0,    0,    0,    0,    1,    0,
    0,X'12',X'23',X'34',X'34',X'23',X'34',X'34',    1,    1,
X'B1',    0,X'44',X'44',X'55',X'B1',X'44',X'55',    1,    1,
X'B1',X'64',    0,X'64',X'64',X'66',X'64',X'64',    1,    1,
X'C1',X'C2',X'D3',    0,X'75',X'D3',X'77',X'75',    1,    1,
X'D4',X'D4',X'D4',X'D4',    0,X'D4',X'D4',X'88',    1,    1,
X'F3',X'F3',X'F3',X'F3',X'F3',    0,X'97',X'97',    1,    1,
X'F4',X'F4',X'F4',X'F4',X'F4',X'E6',    0,X'A8',    1,    1,
X'F5',X'F5',X'F5',X'F5',X'F5',X'E7',X'E7',    0,    1,    1,
    1,    1,    1,    1,    1,    1,    1,    1,    0,    1,
    1,    1,    1,    1,    1,    1,    1,    1,    1,    0
!*
{%include "ftn_copy1"}
!* modified 23/09/86
!*
%routine Copy(%integer Length,Fbase,Fdisp,Tbase,Tdisp)
!***********************************************************************
!* copy Length bytes from fbase(fdisp) to tbase(tdisp)                 *
!***********************************************************************
%integer I,From,To
      %if Length<=0 %then %return
      From=Fbase+Fdisp
      To=Tbase+Tdisp
      %cycle I=0,1,Length-1
         byteinteger(To+I)=byteinteger(From+I)
      %repeat
%end;! Copy
!*
!*
%externalroutine Init Num(%integer Acom)
      Com==record(Acom)
%end;! Init Num
!*
%externalintegerfn Coerce Const(%integer A,Oldmode,Newmode,Adict, 
                                %integername Dptr)
!***********************************************************************
!* Coerce constant held at displacement A in DICT in mode OLDMODE      *
!* to NEWMODE, setting %result=new DICT displacement                   *
!***********************************************************************
%INTEGER TEMPMODE,ANEW,I
%real R
%longreal RR
%SWITCH C(0:15)
      %IF OLDMODE>9 %OR NEWMODE>9 %THEN %RESULT=0;! error should have been reported
      %if Oldmode=0 %then Oldmode=1
      %if Newmode=0 %then Newmode=1
      %if oldmode=newmode %thenstart
         %if A=0 %thenstart;! was integer at Dict + 0
            integer(Adict+Dptr)=integer(Adict)
            A=Dptr
            Dptr=Dptr+4
         %finish
         %result=A
      %finish
      ANEW=ADICT+DPTR
      %if Anew&4#0 %thenstart
         Anew=Anew+4   {ensures doubleword alignment}
         Dptr=Dptr+4
      %finish
      A=ADICT+A
!*
LOOP: I=CONST TRAN(10*OLDMODE+NEWMODE)
      TEMPMODE=I&15
      ->C(I>>4)
!*
C(2): REAL(ANEW)=INTEGER(A)             ;! I*4 -> R*4
      ->CHECK
!*
C(3): LONGREAL(ANEW)=INTEGER(A)         ;! I*4 -> R*8
      ->CHECK
!*
C(6):                                   ;! R*4 -> R*8/C*8
      %if Tempmode=Real8 %thenstart
         longreal(Anew)=real(A)
      %finishelsestart
         real(Anew)=real(A)
         real(Anew+W1)=0
      %finish
      ->CHECK
!*
C(7):                                   ;! R*8 -> R*16/C*16
      longreal(Anew)=longreal(A)
      longreal(Anew+W2)=0
      ->CHECK
!*
C(9):                                   ;! C*8 -> C*16
      longreal(Anew)=real(A)
      longreal(Anew+W2)=real(A+W1)
      ->CHECK
!*
c(11):                                  ;! R*4 -> I*4
      R=real(A)
      %if R<0 %thenstart
         %if -R>2147483647.0 %then ->Intoverflow
      %finishelsestart
         %unless R<=2147483647.0 %then ->Intoverflow
      %finish
      %if R<0 %thenstart
         integer(Anew)=-intpt(-R)
      %finishelse integer(Anew)=intpt(R)
      ->CHECK

!*
c(12):                                  ;! R*8 -> I*4
      RR=longreal(A)
      %if RR<0 %thenstart
         %if -RR>2147483647.0 %then ->Intoverflow
      %finishelsestart
         %unless RR<=2147483647.0 %then ->Intoverflow
      %finish
      %if RR<0 %thenstart
         integer(Anew)=-intpt(-RR)
      %finishelse integer(Anew)=intpt(RR)
      ->CHECK

!*
CHECK:%IF TEMPMODE=NEWMODE %THENSTART
         DPTR=DPTR+CSIZE(NEWMODE)
         %RESULT=ANEW-ADICT
      %FINISHELSESTART
         A=ANEW
         OLDMODE=TEMPMODE
         ->LOOP
      %FINISH
!*
C(13):                                 ;! R*8 ->R4
      real(Anew)=longreal(A)
      ->CHECK
!*
C(14):                                  ;! C*16 -> C*8
      real(Anew)=longreal(A)
      real(Anew+W1)=longreal(A+W2)
      ->CHECK
!*
C(15):%IF A=ANEW %THEN ->CHECK          ;! C*8/C*16/C*32 -> R*4/R*8/R*16
      %IF TEMPMODE=NEWMODE %THENSTART
         %RESULT=A-ADICT;! no new space required
      %FINISHELSESTART
         OLDMODE=TEMPMODE
         ->LOOP
      %FINISH
!*
INTOVERFLOW:
      FAULT(112)
      %RESULT=8;! int value 1
!*
REALOVERFLOW:
      FAULT(112)
      %RESULT=16;! real value 1
!*
C(0): FAULT(130)
      %RESULT=A
!*
C(*): %monitor
      %stop
!*
%END;! Coerce Const
!*
!*
%externalintegerfn Const Eval(%integer Resl,Op,Resr,%record(Resf)%name Res,
                              %integer Adict,%integername Dptr)
!*
%CONSTBYTEINTEGERARRAY OPERATING MODE(0:15)=1,1,1,3,4,0,6,7,0,1,1,1,0,13,1,1
!*
%INTEGER AL,FL,ML,AR,FR,MR,ARES,MRES,MMAX,I,IIN
%INTEGER IL,IR
%REAL RL,RR,CL,CR,RW,CW
%LONGREAL RRL,RRR,CCL,CCR,RRW,CCW
%record(Resf) Resll,Resrr
!*
%SWITCH OPMODE(0:15)
%SWITCH IOP(2:8)
%SWITCH ROP(2:8)
%SWITCH RROP(2:8)
%SWITCH COP(2:8)
%SWITCH CCOP(2:8)
!*
!*
      RL=0
      RR=0
      CL=0
      CR=0
      RW=0
      CW=0
      RRL=0
      RRR=0
      CCL=0
      CCR=0
      RRW=0
      CCW=0
      Resll_W=Resl
      Resrr_W=Resr
      AL=Resll_H0<<DSCALE
      FL=Resll_Form
      ML=Resll_Mode
      AR=Resrr_H0<<DSCALE
      FR=Resrr_Form
      MR=Resrr_Mode
      MMAX=ML
      %IF MR>MMAX %THEN MMAX=MR
!*
      %IF FL>2 %OR FR>2 %THENSTART;! param exp
         %IF COM_CEXPDICT=0 %THENSTART;! start of exp
            COM_CEXPDICT=DPTR
            DPTR=DPTR+W1;! for length
         %FINISH
         INTEGER(ADICT+DPTR)=RESL
         INTEGER(ADICT+DPTR+W1)=OP
         INTEGER(ADICT+DPTR+W2)=RESR
         Res_H0=Scalar Space(4,IIN);! temp in Gla
         Res_Form=6
         Res_Mode=1
         INTEGER(ADICT+DPTR+W3)=RES_W
         DPTR=DPTR+W4
         %result=0
      %FINISH
!*
      %IF FL=0 %THENSTART;! store simple integers in DICT for simplicity
         AL=AL>>DSCALE
         INTEGER(ADICT)=AL
         AL=0
      %FINISH
      %IF FR=0 %THENSTART
         AR=AR>>DSCALE
         INTEGER(ADICT+W1)=AR
         AR=W1
      %FINISH
!*
      MRES=OPERATING MODE(ML)
      I=OPERATING MODE(MR)
      %IF OP=7 %THENSTART;! **
         %IF I#1 %THENSTART
            LFAULT(113);! POWER MUST BE INTEGER
         AR=4
         INTEGER(ADICT)=1;! TO ALLOW CONTINUATION
         %FINISH
      %FINISHELSESTART
         %IF I>MRES %THEN MRES=I;! evaluate expressions as I*4,R*4,R*8,C*8 or C*16
      %FINISH
!*
      %IF 1<OP<=7 %THENSTART
         %IF OP#6 %AND ML#MRES %THEN  %C
                            AL=COERCE CONST(AL,ML,MRES,ADICT,DPTR)
         %IF MR#MRES %AND OP#7 %THEN  %C
                            AR=COERCE CONST(AR,MR,MRES,ADICT,DPTR)
      %FINISH
!*
OPERATE:
      AL=ADICT+AL
      AR=ADICT+AR
      %if Dptr&4#0 %then Dptr=Dptr+4
      ARES=ADICT+DPTR
      ->OPMODE(MRES)
!*
OPMODE(1):                              ! INTEGER*4
      IL=INTEGER(AL) %unless Op=6
      IR=INTEGER(AR)
      ->IOP(OP)
!*
IOP(2):IR=IL+IR
IMEET:
IMEET2:%IF 0<=IR<=X'7FFF' %THENSTART
         RES_H0=IR
         Res_Form=0
         Res_Mode=1
         %result=0
      %FINISH
      INTEGER(ARES)=IR
      RES_H0=DPTR>>DSCALE
      Res_Form=1
      Res_Mode=1
      DPTR=DPTR+4
      %result=0
!*
OVERI:%result=1
      FAULT(112)
      IR=1
      ->IMEET2
!*
IOP(3):IR=IL-IR
      ->IMEET
!*
IOP(4):IR=IL*IR
      ->IMEET
!*
IOP(5):%IF IR=0 %THEN ->OVERI
      IR=IL//IR
      ->IMEET
!*
IOP(6):IR=-IR
      ->IMEET
!*
IOP(7):%IF IR=0 %THEN IR=1 %ELSESTART
         %IF IR<0 %THEN IR=0 %ELSESTART
            I=IL
            %WHILE IR>1 %CYCLE
               I=I*IL
               IR=IR-1
            %REPEAT
            IR=I
         %FINISH
      %FINISH
      ->IMEET
!*
IOP(*):%monitor
      %stop
!*
Opmode(3):
      RL=REAL(AL) %unless Op=6
      RR=REAL(AR)
ROPOP:->ROP(OP)
!*
ROP(2):RR=RL+RR
RMEET:
RMEET2:REAL(ARES)=RR
      %IF MRES=6 %THEN REAL(ARES+W1)=CR
      RES_H0=DPTR>>DSCALE
      Res_Form=1
      Res_Mode=0!MMAX
      DPTR=DPTR+CSIZE(MMAX)
      %result=0
!*
OVERR:%result=1
      FAULT(112)
      RR=1
      ->RMEET2
!*
ROP(3):RR=RL-RR
      ->RMEET
!*
ROP(4):RR=RL*RR
      ->RMEET
!*
ROP(5):%IF RR=0 %THEN ->OVERR
      RR=RL/RR
      ->RMEET
!*
ROP(6):RR=-RR
      ->RMEET
!*
ROP(7):IR=INTEGER(AR)
       %IF IR=0 %THEN RR=1.0 %ELSESTART
         %IF IR<0 %THEN RR=0 %ELSESTART
            RR=RL
            %WHILE IR>1 %CYCLE
               RR=RR*RL
               IR=IR-1
            %REPEAT
         %FINISH
      %FINISH
      ->RMEET
!*
ROP(*):%monitor
      %stop
!*
Opmode(4):
      %unless Op=6 %thenstart
         copy(8,AL,0,addr(RRL),0)
      %finish
      copy(8,AR,0,addr(RRR),0)
RROPOP:->RROP(OP)
!*
RROP(2):RRR=RRL+RRR
RRMEET:
RRMEET2:LONGREAL(ARES)=RRR
      %IF MRES=7 %THEN LONGREAL(ARES+W2)=CCR  
      RES_H0=DPTR>>DSCALE
      RES_Form=1
      RES_Mode=MMAX
      DPTR=DPTR+CSIZE(MMAX)
      %result=0
!*
OVERRR:%result=1
      FAULT(112)
      RRR=1
      ->RRMEET2
!*
RROP(3):RRR=RRL-RRR
      ->RRMEET
!*
RROP(4):RRR=RRL*RRR
      ->RRMEET
!*
RROP(5):%IF RRR=0 %THEN ->OVERRR
      RRR=RRL/RRR
      ->RRMEET
!*
RROP(6):RRR=-RRR
      ->RRMEET
!*
RROP(7):IR=INTEGER(AR)
       %IF IR=0 %THEN RRR=1.0 %ELSESTART
         %IF IR<0 %THEN RRR=0 %ELSESTART
            RRR=RRL
            %WHILE IR>1 %CYCLE
               RRR=RRR*RRL
               IR=IR-1
            %REPEAT
         %FINISH
      %FINISH
      ->RRMEET
!*
RROP(*):%monitor
      %stop
!*
Opmode(6):
      RL=real(AL)
      CL=real(AL+W1)
      %unless Op=6 %thenstart
         RR=real(AR)
         RW=RR
         CR=real(AR+W1)
      %finish
      ->COP(Op)
!*
COP(2):CR=CL+CW
      ->ROPOP
!*
COP(3):CR=CL-CW
      ->ROPOP
!*
COP(4):RR=RL*RW-CL*CW
      CR=RL*CW+RW*CL
      ->RMEET
!*
COP5:
COP(5):RR=RL*RW+CL*CW
      CR=RW*CL-RL*CW
      RW=RW*RW+CW*CW
      RR=RR/RW
      CR=CR/RW
      ->RMEET
!*
COP(6):CR=-CR
      ->ROPOP
!*
COP(7):IR=INTEGER(AR)
      IL=IR
      %IF IR<0 %THEN IR=-IR
      RR=RL
      CR=CL
      %WHILE IR>1 %CYCLE
         RW=RR
         CW=CR
         RR=RL*RW-CL*CW
         CR=RL*CW+RR*CL
         IR=IR-1
      %REPEAT
      %IF IL<=0 %THENSTART
         RW=RR
         CW=CR
         RL=1.0
         RR=0
         %IF IL#0 %THEN ->COP5
      %FINISH
      ->RMEET
!*
COP(*):%monitor
      %stop
!*
Opmode(7):
      copy(8,AL,0,addr(RRL),0)
      copy(8,AL+W2,0,addr(CCL),0)
      %unless Op=6 %thenstart
         copy(8,AR,0,addr(RRR),0)
         RRW=RRR
         copy(8,AR+W2,0,addr(CCW),0)
      %finish
      ->CCOP(Op)
!*
CCOP(2):CCR=CCL+CCW
      ->RROPOP
!*
CCOP(3):CCR=CCL-CCW
      ->RROPOP
!*
CCOP(4):RRR=RRL*RRW-CCL*CCW
      CCR=RRL*CCW+RRW*CCL
      ->RRMEET
!*
CCOP5:
CCOP(5):RRR=RRL*RRW+CCL*CCW
      CCR=RRW*CCL-RRL*CCW
      RRW=RRW*RRW+CCW*CCW
      RRR=RRR/RRW
      CCR=CCR/RRW
      ->RRMEET
!*
CCOP(6):CCR=-CCR
      ->RROPOP
!*
CCOP(7):IR=INTEGER(AR)
      IL=IR
      %IF IR<0 %THEN IR=-IR
      RRR=RRL
      CCR=CCL
      %WHILE IR>1 %CYCLE
         RRW=RRR
         CCW=CCR
         RRR=RRL*RRW-CCL*CCW
         CCR=RRL*CCW+RRR*CCL
         IR=IR-1
      %REPEAT
      %IF IL<=0 %THENSTART
         RRW=RRR
         CCW=CCR
         RRL=1.0
         RRR=0
         %IF IL#0 %THEN ->CCOP5
      %FINISH
      ->RRMEET
!*
CCOP(*):%monitor
      %stop
!*
OP9:  %result=1
      FAULT(130)
      RES_W=RESL
      %result=0
!*
OPMODE(13):%UNLESS ML=MR %AND OP=1 %THEN ->OP9
      FL=INTEGER(AL)
      FR=INTEGER(AR)
      INTEGER(ARES)=FL+FR
!!      MOVE(FL,AL+4,ARES+4)
!!      MOVE(FR,AR+4,ARES+4+FL)
      RES_H0=DPTR>>DSCALE; RES_H1=X'10D'
      DPTR=(DPTR+FL+FR+7)&(-4)
      %result=0
!*
OPMODE(*):
      %monitor
      %stop
!*
%end;! Const Eval
!*
%integerfn Conout(%RECORD(RESF) R)
%RECORD(CONSTRECF)%NAME CON
      %IF R_FORM=LIT %THEN %RESULT=R_H0
      %IF R_FORM=NEGLIT %THEN %RESULT=-R_H0
      CON==RECORD(COM_ADICT+R_H0<<DSCALE)
      %RESULT=INTEGER(COM_ADICT+CON_DADDR)
%end;! Conout
!*
%externalintegerfn Conval(%integer Il,Ir,Op,Mode)
%INTEGER I,VAL
%SWITCH IOP(2:8)
      %unless Mode=INT4 %then %monitor
      ->IOP(OP)
!*
IOP(2):VAL=IL+IR
IMEET:
IMEET2:%RESULT=VAL
!*
OVERI:VAL=1
      %RESULT=1
!*
IOP(3):VAL=IL-IR
      ->IMEET
!*
IOP(4):VAL=IL*IR
      ->IMEET
!*
IOP(5):%IF IR=0 %THEN ->OVERI
      VAL=IL//IR
      ->IMEET
!*
IOP(6):VAL=-IR
      ->IMEET
!*
IOP(7):%IF IR=0 %THEN IR=1 %ELSESTART
         %IF IR<0 %THEN IR=0 %ELSESTART
            I=IL
            %WHILE IR>1 %CYCLE
               I=I*IL
               IR=IR-1
            %REPEAT
            VAL=I
         %FINISH
      %FINISH
      ->IMEET
!*
IOP(*):%monitor
      %stop
%end;! Conval
!*
%externalintegerfn Gconval(%integer IL,OP,IR,%integername Val)
%INTEGER I
%SWITCH IOP(2:8)
      ->IOP(OP)
!*
IOP(2):VAL=IL+IR
IMEET:
IMEET2:%RESULT=0
!*
OVERI:VAL=1
      %RESULT=1
!*
IOP(3):VAL=IL-IR
      ->IMEET
!*
IOP(4):VAL=IL*IR
      ->IMEET
!*
IOP(5):%IF IR=0 %THEN ->OVERI
      VAL=IL//IR
      ->IMEET
!*
IOP(6):VAL=-IR
      ->IMEET
!*
IOP(7):%IF IR=0 %THEN IR=1 %ELSESTART
         %IF IR<0 %THEN IR=0 %ELSESTART
            I=IL
            %WHILE IR>1 %CYCLE
               I=I*IL
               IR=IR-1
            %REPEAT
            VAL=I
         %FINISH
      %FINISH
      ->IMEET
!*
IOP(*):%monitor
      %stop
%end;! Gconval
!*
%externalintegerfn Concheck(%record(Resf) Res)
!***********************************************************************
!* if constant is any of -1, 0, 1, 2 then return integer val           *
!* else if -ve integer then return -2                                  *
!* else if 0.5 then return 3                                           *
!* else return 10                                                      *
!***********************************************************************
%CONSTINTEGERARRAY IVALS(0:3)=-1,0,1,2
!$%CONSTINTEGERARRAY IIVALS(0:3) = -1,0,1,2
!$%CONSTLONGLONGREALARRAY RVALS(0:4) = %C
!$ R'C110000000000000',0,
!$ R'4110000000000000',R'4120000000000000',
!$ R'4080000000000000'
!$%LONGREAL RR
!$%REAL R
%INTEGER I,J
!$%RECORD(CONSTRECF)%NAME CON
!$%SWITCH M(0:5)
!$      %UNLESS INT2<RES_MODE<CMPLX8 %THEN %RESULT=10
!$      %IF RES_FORM=CNSTID %THEN CON==RECORD(COM_ADICT+RES_H0<<DSCALE)
!$      ->M(RES_MODE)
!$!*
!$M(1):
   %if Res_Mode=INT4 %thenstart
      I=CONOUT(RES)
      %CYCLE J=0,1,3
         %IF I=IVALS(J) %THEN %RESULT=J-1
      %REPEAT
      %IF I<0 %THEN %RESULT=-2
      %RESULT=10
   %finish
!$!*
!$M2:   %CYCLE J=0,1,3
!$         %IF I=IIVALS(J)%THEN %RESULT=J-1
!$      %REPEAT
!$      %IF I<0 %THEN %RESULT=-2
!$      %RESULT=10
!$!*
!$M(3): R=REAL(COM_ADICT+CON_DADDR)
!$      RR=R
!$      ->M5
!$!*
!$M(4): RR=LONGREAL(COM_ADICT+CON_DADDR)
!$!*
!$M5:   %CYCLE J=0,1,4
!$         %IF RR=RVALS(J) %THEN %RESULT=J-1
!$      %REPEAT
        %RESULT=10
!$!*
!$M(*): %monitor
!$      %stop
%end;! Concheck
%endoffile