!* MODIFIED 25/03/82
!*************  IMP80 version  ******************
!*
!**** SYNTAX ****
!*
!* Syntax tables generated from file SYNTAX48 on 28/01/82 at 23.55.35
!*
%CONSTBYTEINTEGERARRAY OS(0:1500)=  %C                     
   0,   0,  34,   1,   1,   2,  25,   1,   1,   3,
  10,   7,   2,   3,  29,  61,   0,   1,   1,   0,
  13,   1,   0,   1,   3,  20,   4,   1,   2,   1,
   4,  17,   1,   1,   0,   1,   2,  20,   4,   1,
   1,   1,   3,  17,   0,   1,   2,  87,   0,   1,
   1,   0,   1,   3,  20,   5,   1,   2,   1,   4,
  17,   1,   1,   0,   1,   2,  20,   5,   1,   1,
   1,   3,  17,   0,   1,   2,   1,   3,  17,   1,
   1,   0,   1,   1,   1,   2,  17,   0,  20,   2,
   1,   1,   0,  20,   3,   1,   1,   0,  22,   1,
   1,   0,  23,   1,   1,   0,  24,   1,   1,   0,
  88,   1,   1,  89,   0,   0,  88,   1,   1,  89,
   1,   0,  12,   4,   1,   3,  20,   4,   1,   2,
  16,   4,   1,   1,   0,  12,   3,   1,   2,  20,
   4,   1,   1,  16,   3,   0,  12,   4,   1,   3,
  20,   5,   1,   2,  16,   4,   1,   1,   0,  12,
   3,   1,   2,  20,   5,   1,   1,  16,   3,   0,
  12,   3,   1,   2,  16,   3,   1,   1,   0,  12,
   2,   1,   1,  16,   2,   0,  12,   3,   1,   2,
  16,   3,  20,   4,   1,   1,   0,  12,   3,   1,
   2,  87,   3,   1,   1,   0,  12,   3,   1,   2,
  16,   3,  20,   5,   1,   1,   0,  12,   2,   1,
   1,  16,   2,   0,   1,   2,   1,   1,  66,   0,
   1,   1,   0,  13,   1,   0,  26,   1,   1,  27,
   0,   1,   2,  13,   3,  75,   0,  62,   0,   1,
   1,  62,   0,   1,   3,   1,   2,  49,   4,  75,
   0,   1,   1,  49,   2,   0,  36,   0,  35,   3,
   1,   2,  36,   0,  13,   1,   0,   1,   2,  13,
   3,  75,   0,   1,   3,   1,   2,  49,   4,  75,
   0,   1,   1,  49,   2,   0,  60,   1,   0,  60,
   2,   0,  13,   1,   0,  20,   0,   0,  20,   6,
   0,  21,   0,   0,  21,   6,   0,  21,   0,   0,
  20,   0,   0,  74,   0,   1,   1,  74,   0,   1,
   2,  74,   0,   1,   2,   1,   1,  74,   0,   1,
   1,  13,   1,   0,   1,   1,   0,   1,   1,  13,
   1,   0,  13,   1,   0,   1,   4,   1,   3,   1,
   2,   1,   5,  79,   1,   1,   0,   1,   3,   1,
   2,   1,   1,   1,   4,  79,   0,   1,   2,   1,
   3,  79,   1,   1,   0,   1,   1,   1,   2,  79,
   0,   1,   2,   1,   1,   0,   1,   2,   1,   1,
   0,  80,   5,   1,   4,   1,   3,   1,   2,  77,
   5,   1,   1,   0,  80,   4,   1,   3,   1,   2,
   1,   1,  77,   4,   0,  80,   3,   1,   2,  77,
   3,   1,   1,   0,  80,   2,   1,   1,  77,   2,
   0,  80,   4,   1,   3,  77,   4,   1,   2,   1,
   1,   0,  80,   2,   1,   1,  77,   2,   0,   1,
   2,   1,   1,  20,   7,  78,   2,   0,   1,   1,
   0,  13,   1,   0,  26,   1,   1,  27,   0,  13,
   1,   0,  20,   1,   0,  20,   5,   0,  20,   4,
   0,  20,   2,   0,  20,   3,   0,  20,  16,   0,
  20,  18,   0,  20,  17,   0,  20,  19,   0,  20,
  20,   0,  73,   2,   1,   1,   0,  73,   1,   0,
   1,   1,  34,   3,   1,   4,  25,   3,  38,   2,
   0,  34,   2,   1,   3,  25,   2,  38,   1,   0,
   1,   1,   0,  13,   1,   0,  90,   1,   3,   1,
   1,  72,   3,   0,  90,   1,   2,  72,   2,   0,
  34,   3,   1,   4,  25,   3,  10,   7,   4,   2,
   1,   1,   0,  34,   2,   1,   3,  25,   2,  10,
   7,   3,   1,   0,  10,   7,   2,   1,  29,   0,
  50,   4,   1,   1,  53,   0,  50,   4,   1,   1,
  52,   1,   1,  53,   0,  35,   2,  41,  29,   0,
  35,   3,   1,   2,  41,  33,  29,   0,  35,   2,
  41,  29,   0,  29,   0,  50,   7,   1,   1,  53,
   0,  50,   5,   1,   1,  53,   0,  50,   5,   1,
   1,  52,   1,   1,  53,   0,  84,   3,   0,  46,
   0,  84,   1,  86,   1,   1,   2,  85,   1,   0,
  84,   2,   0,   1,   2,   1,   1,  30,   0,  31,
   0,  50,   8,   1,   1,  53,   0,  50,   6,   1,
   1,  53,   0,  50,   2,   1,   2,  52,   2,   2,
   1,   1,  53,   0,  50,   2,   1,   1,  52,   2,
   1,  53,   0,  70,   0,  69,   0,  50,   1,   1,
   2,   1,   1,  53,   0,  50,   1,   1,   2,  52,
   2,   2,   1,   1,  53,   0,  50,   1,   1,   1,
  52,   2,   1,  53,   0,  47,   0,   1,   1,  44,
   0,  50,   3,   1,   1,  53,   0,  50,   3,   1,
   1,  52,   1,   1,  53,   0,  45,   0,  68,   0,
  50,   2,   1,   2,   1,   1,  53,   0,  82,   3,
   1,   1,   0,   1,   2,  81,   1,   0,   1,   1,
   0,  13,   1,   0,   1,   2,   1,   1,   0,   1,
   1,   0,   1,   2,  52,   1,   2,   1,   1,   0,
   1,   3,  52,   1,   3,   1,   2,  52,   2,   2,
   1,   1,   0,   1,   2,  52,   1,   2,   1,   1,
  52,   2,   1,   0,   1,   1,  52,   1,   1,   0,
   1,   2,   1,   1,   0,   1,   1,   0,  11,   0,
   0,   1,   1,   0,  11,   0,   0,   1,   1,   0,
   1,   1,  52,   1,   1,   0,   1,   1,  52,   2,
   1,   0,   1,   1,  52,   3,   1,   0,  52,   4,
   1,   0,  52,   5,   1,   0,   1,   1,  52,   6,
   1,   0,   1,   2,   1,   1,   0,   1,   1,   0,
   1,   1,   0,   1,   2,  52,   1,   2,   1,   1,
   0,   1,   1,  52,   1,   1,   0,   1,   2,   1,
   1,   0,   1,   1,   0,   1,   3,   1,   2,  54,
   2,   1,   1,   0,   1,   2,   1,   1,  54,   1,
   0,  11,  24,   0,  11,   8,   0,  11,   9,   0,
  11,  21,   0,  11,  10,   0,  11,  11,   0,  11,
  12,   0,  11,  13,   0,  11,  14,   0,  11,  15,
   0,  11,  16,   0,  11,  17,   0,  11,  18,   0,
  11,  19,   0,  11,  20,   0,  11,  22,   0,  11,
  23,   0,  11,  24,   0,  11,   7,   0,   1,   4,
   1,   3,   1,   2,  55,   0,   1,   6,  55,   1,
   1,   1,   0,   1,   4,   1,   3,  55,   0,   1,
   6,  55,   1,   1,   1,   0,   1,   2,   1,   1,
   0,  51,   2,   1,   1,   0,   1,   2,  56,   2,
   1,   1,   0,   1,   1,   0,   1,   5,  20,  10,
  17,  15,   0,  34,   6,   1,   7,  18,   1,   5,
  20,  10,  17,  15,  19,   0,  84,   0,  34,   1,
   1,   2,  85,   0,   0,  34,   2,   1,   3,  18,
   1,   1,  19,  29,   0,  34,   2,   1,   3,  18,
   1,   1,  19,  29,   0,   1,   3,   1,   2,   1,
   1,  28,   0,   1,   3,   1,   2,  28,   0,   1,
   1,   0, 0(399);
!*
!*** ENDSYNTAX ***
!*
!***********************************************************************
!%INCLUDE "ERCS06.PERQ_TRIADOPS"                                        ;
!***********************************************************************
!*
!*
!*********************** TRIAD operator values *************************
!*
%CONSTINTEGER ADD    = X'02'
%CONSTINTEGER SUB    = X'03'
%CONSTINTEGER MULT   = X'04'
%CONSTINTEGER DIV    = X'05'
%CONSTINTEGER NEG    = X'06'
%CONSTINTEGER ASMT   = X'07'
%CONSTINTEGER CVT    = X'08'
%CONSTINTEGER ARR    = X'09'
%CONSTINTEGER ARR1   = X'0A'
%CONSTINTEGER BOP    = X'0B'
%CONSTINTEGER CONCAT = X'0C'
%CONSTINTEGER DMULT  = X'0D'
%CONSTINTEGER EXP    = X'0E'
%CONSTINTEGER AND    = X'10'
%CONSTINTEGER OR     = X'11'
%CONSTINTEGER NOT    = X'12'
%CONSTINTEGER EQUIV  = X'13'
%CONSTINTEGER NEQ    = X'14'
%CONSTINTEGER GT     = X'15'
%CONSTINTEGER LT     = X'16'
%CONSTINTEGER NE     = X'17'
%CONSTINTEGER EQ     = X'18'
%CONSTINTEGER GE     = X'19'
%CONSTINTEGER LE     = X'1A'
%CONSTINTEGER STOD1  = X'20'
%CONSTINTEGER STOD2  = X'21'
%CONSTINTEGER STODA  = X'22'
%CONSTINTEGER EOD1   = X'24'
%CONSTINTEGER EOD2   = X'25'
%CONSTINTEGER EODA   = X'26'
%CONSTINTEGER EODB   = X'27'
%CONSTINTEGER EXP3   = X'28'
%CONSTINTEGER REL    = X'29'
%CONSTINTEGER RSUB   = X'2A'
%CONSTINTEGER RDIV   = X'2C'
%CONSTINTEGER STRTIO = X'30'
%CONSTINTEGER IOITEM = X'31'
%CONSTINTEGER IODO   = X'32'
%CONSTINTEGER IOSPEC = X'33'
%CONSTINTEGER IO     = X'34'
%CONSTINTEGER ASGN   = X'36'
%CONSTINTEGER AIF    = X'39'
%CONSTINTEGER SBSCV  = X'3A'
%CONSTINTEGER SBSCE  = X'3B'
%CONSTINTEGER SBSCR  = X'3C'
%CONSTINTEGER NOOP   = X'40'
%CONSTINTEGER FUN    = X'41'
%CONSTINTEGER SUBR   = X'42'
%CONSTINTEGER ARG    = X'43'
%CONSTINTEGER DINIT  = X'4B'
%CONSTINTEGER STOREB = X'4C'
%CONSTINTEGER LOADB  = X'4D'
%CONSTINTEGER SAVETM = X'4E'
%CONSTINTEGER REF    = X'4F'
%CONSTINTEGER JIT    = X'50'
%CONSTINTEGER JIF    = X'51'
%CONSTINTEGER JINN   = X'52'
%CONSTINTEGER JINP   = X'53'
%CONSTINTEGER JINZ   = X'54'
%CONSTINTEGER JIN    = X'55'
%CONSTINTEGER JIP    = X'56'
%CONSTINTEGER JIZ    = X'57'
%CONSTINTEGER CGT    = X'58'
%CONSTINTEGER GOTO   = X'59'
%CONSTINTEGER RET    = X'5A'
%CONSTINTEGER STOP   = X'5B'
%CONSTINTEGER PAUSE  = X'5C'
%CONSTINTEGER EOT    = X'5D'
%CONSTINTEGER STMT   = X'60'
%CONSTINTEGER ITS    = X'61'
%CONSTINTEGER PA     = X'62'
!*
!*
!*
!***********************************************************************
!%INCLUDE "ERCS06.PERQ_CONSTS"                                          ;
!***********************************************************************
!*
!*
!********************* TRIAD QUALIFIERS ********************************
!*
%CONSTINTEGER NULL    = 0
%CONSTINTEGER LIT     = 1
%CONSTINTEGER CNSTID  = 2
%CONSTINTEGER TRIAD   = 3
%CONSTINTEGER LSCALID = 4
%CONSTINTEGER OSCALID = 5
%CONSTINTEGER CSCALID = 6
%CONSTINTEGER PSCALID = 7
%CONSTINTEGER TMPID   = 8
%CONSTINTEGER ARRID   = 9
%CONSTINTEGER LABID   =10
%CONSTINTEGER PLABID  =11
%CONSTINTEGER PROCID  =12
%CONSTINTEGER ARREL   =13
%CONSTINTEGER CHVAL   =15
%CONSTINTEGER STKLIT  =16
%CONSTINTEGER GLALIT  =17
%CONSTINTEGER NEGLIT  =18
%CONSTINTEGER ASCALID =19
%CONSTINTEGER PERMID = 20
!*
!********************* MODES ****************************************
!*
%CONSTINTEGER INT2    = 0, INT4    = 1, INT8    = 2
%CONSTINTEGER REAL4   = 3, REAL8   = 4, REAL16  = 5
%CONSTINTEGER CMPLX8  = 6, CMPLX16 = 7, CMPLX32 = 8
%CONSTINTEGER LOG1    =13, LOG4    = 9, LOG8    =14
%CONSTINTEGER CHARMODE=10, HOLMODE =11
!*
!********************* TYPES **************************************
!*
%CONSTINTEGER INTTYPE   = 1
%CONSTINTEGER REALTYPE  = 2
%CONSTINTEGER CMPLXTYPE = 3
%CONSTINTEGER LOGTYPE   = 4
%CONSTINTEGER CHARTYPE  = 5
!*
!********************* DICT INDEX SCALING FACTOR ******************
!*
%CONSTINTEGER DSCALE = 0
!*
!********************* REGISTER HOLDING INTERMEDIATE VALUE ********
!*
%CONSTINTEGER INACC  = 1
!*
!*********************** length of maximum source statement ***********
!*
%CONSTINTEGER INPUT LIMIT = 200
!*
!*********************** fixed locations in global ********************
!*
%CONSTINTEGER CONST REF = 6;! word displacement of 32 bit @ of const area
!*
!***********************************************************************
!***********************************************************************
!*
!*
!*
!***********************************************************************
!%INCLUDE "ERCS06.PERQ_DICTFMTS"                                        ;
!***********************************************************************
!*
!*
!***********************************************************************
!* Formats for accessing dictionary records                            *
!***********************************************************************
!*
%RECORDFORMAT PRECF( %C
               %BYTEINTEGER CLASS,TYPE,X0,X1, %C
               %INTEGER LINK1, LINK2, LINK3, ADDR4,  %C
               %HALFINTEGER DISP,LEN,IDEN,IIN,  %C
               %INTEGER LINE,XREF,CMNLENGTH, CMNREFAD)
!*
%RECORDFORMAT SRECF(%INTEGER INF0, LINK1, INF2, INF3, INF4)
!*
%RECORDFORMAT RESF((%INTEGER W %OR %HALFINTEGER H0,
                      (%HALFINTEGER H1 %OR %BYTEINTEGER FORM,MODE)))
!*
%RECORDFORMAT DORECF( %C
    %INTEGER LABEL, LINK1, LOOPAD, ENDREF,
    %RECORD(RESF) INDEXRD, INCRD, FINALRD, ICRD,
    %INTEGER LABLIST,LINE)
!*
%RECORDFORMAT BFMT(%INTEGER L,U,M)
!*
%RECORDFORMAT ARRAYDVF(%HALFINTEGER DIMS, ADDRDV,  %C
            %INTEGER ZEROTOFIRST, ADFIRST, NUMELS, ELLENGTH,  %C
            %RECORD(BFMT) %ARRAY B(1 : 7))
!*
!*
%RECORDFORMAT LRECF(%INTEGER NOTFLAG,LINK1,ORLIST,ANDLIST,RELOP)
!*
%RECORDFORMAT IFRECF(%INTEGER TYPE,LINK1,ENDIFJUMP,FALSELIST,  %C
                                        LABLIST,LINE)
!*
%RECORDFORMAT LABRECF(%BYTEINTEGER CLASS,TYPE,X0,X1,  %C
            %INTEGER LINK1,LINK2,LINK3,ADDR4,LINK5,LAB,LINE,  %C
            %HALFINTEGER DOSTART,DOEND,IFSTART,IFEND)
!*
%RECORDFORMAT PLABF(%INTEGER INDEX,CODEAD,REF,REFCHAIN)
!*
%RECORDFORMAT IMPDORECF(%INTEGER VAL,LINK,IDEN)
!*
%RECORDFORMAT CONRECF(%INTEGER MODE,LINK1,DADDR,CADDR)
!*
%RECORDFORMAT TMPF(%BYTEINTEGER REG,MODE,%HALFINTEGER INDEX,  %C
                    %INTEGER LINK1,ADDR)
!*
%RECORDFORMAT CHARF(%INTEGER ADESC,LINK,LEN)
!*
%RECORDFORMAT FNRECF(%INTEGER FPTR,LINK1,HEAD,PCT)
!*
!*
!***********************************************************************
!* Constants defining the size of DICT records                         *
!***********************************************************************
!*
%CONSTINTEGER IDRECSIZE    = 14;! size of dict entry reserved for a new identifier
%CONSTINTEGER CONRECSIZE   = 8
%CONSTINTEGER CNSTRECMIN   =  2
%CONSTINTEGER IMPDORECSIZE = 6;! size of DATA-implied-DO list item
%CONSTINTEGER LABRECSIZE   = 20
%CONSTINTEGER PLABRECSIZE  = 8
%CONSTINTEGER XREFSIZE     =  4
%CONSTINTEGER CMNRECEXT    = 8;! extra space on iden record for common block name
%CONSTINTEGER TMPRECSIZE     = 6
%CONSTINTEGER DVRECSIZE    = 10
!*
!***********************************************************************
!* TRIAD record format                                                 *
!***********************************************************************
!*
%RECORDFORMAT TRIADF(  %C
               %BYTEINTEGER OP,
               (%BYTEINTEGER USE %OR %BYTEINTEGER VAL2),
               %HALFINTEGER CHAIN,
               (%RECORD(RESF) RES1      %OR     %C
               (%HALFINTEGER OPD1,%BYTEINTEGER QOPD1,MODE  %OR  %C
               (%INTEGER SLN %OR %INTEGER VAL1))),
               (%RECORD(RESF) RES2      %OR   %C
                %HALFINTEGER OPD2,%BYTEINTEGER QOPD2,MODE2))
!*
!*
!***********************************************************************
!***********************************************************************
!*
!*
!*
!%INCLUDE "ERCS06.PERQ_COMFMT"
!*
%RECORDFORMAT COMFMT(%INTEGER CONTROL,OPTIONS,OPTIONS1,OPTIONS2,PTRACE,
      ADICT,ANAMES,ADOUTPUT,ADBLKDTAID,DICLEN,DPTR,
      MAXTRIADS,NEXTPLAB,ALABH,ADLHEAD,
      SUBPROGTYPE,SFPTR,EXTERNALS,CBNPTR,SCPTR,CHECKLIST,
      RESCOM1,RESCOM2,GLACA,FNO,FAULTY,LINEST,CMNIIN,SFMK,
      LISTL,LISTSTREAM,DIAGSTREAM,LISTPOINT,XREF,
      PACKCMN,ITSMODE,PATHANAL,CHARACTER CODE,SPACE CHAR,
      HEADINGS,ARRAYCHECKS,JBRMODE,MESSLEN,NAMESLEN,
      NEXTCH,FUNRESDISP,WARNCOUNT,INP,MAXINP,MESSCOUNT,
      UNASSPATTERN,LISTCODE,PI21INT,DOPTR,SUBPROGPTR,
      FNLST,LAB,NAMESFREE,ALGOLREF,FIRSTSTATNUM,CEXPDICT,
      COMMONBASE,FASTPROLOGUE,STATEMENT,IFPTR,
      CNSTCA,COMMENTCNT,ADIDENT,ADERRIDEN,
      ADEXT,MAXDICT,MAXNAMES,MAXOUTPUT,MAXEXT)
!*
!********************************* exports ****************************
!*
%ROUTINESPEC GENERATE(%RECORD(TRIADF)%ARRAYNAME TRIADS,
                      %INTEGERNAME NEXTTRIAD,
                      %INTEGER KGEN,PATH,LABRECAD,ACOM)
%INTEGERFNSPEC COERCE CONST(%INTEGER A,OLDMODE,NEWMODE,ADICT,
                            %INTEGERNAME DPTR)
!*
!***********************************************************************
!*
!{2900C}%EXTERNALROUTINESPEC PRINT TRIAD(%INTEGER INDEX,ADICT,ANAMES,
!{2900C}           LEVEL,%RECORD(TRIADF)%NAME TRIAD)
!*
%EXTERNALROUTINESPEC CODEGEN(%INTEGER CGENEP,
                             %RECORD(TRIADF)%ARRAYNAME TRIADS,
                             %INTEGER COMAD)
!*
%EXTERNALROUTINESPEC FREELISTCELL(%INTEGERNAME LISTHEAD,%INTEGER N)
%EXTERNALROUTINESPEC LFAULT(%INTEGER ER)
%EXTERNALROUTINESPEC TFAULT(%INTEGER ER,TA,TB)
%EXTERNALROUTINESPEC FAULT(%INTEGER ER)
%EXTERNALROUTINESPEC IFAULT(%INTEGER E,I)
!{2900}%EXTERNALROUTINESPEC FAULTNUM(%INTEGER ER,COMAD)
{PERQ}%EXTERNALROUTINESPEC FAULTNUM(%INTEGER ER,COMAD,UPDATE)
%EXTERNALINTEGERFNSPEC NEWLISTCELL(%INTEGERNAME LISTHEAD,%INTEGER N)
%EXTERNALINTEGERFNSPEC FREESP(%INTEGER N)
%EXTERNALINTEGERFNSPEC SETLAB(%INTEGER LAB,%INTEGERNAME LABRECPTR)
%EXTERNALROUTINESPEC CHECK DO INDEX(%INTEGER RD,DOHEAD)
%EXTERNALROUTINESPEC PUTWORD(%INTEGER AREA,VALUE)
!*
%EXTRINSICINTEGER STACKCA
!*
!*
%EXTERNALINTEGER STACKBASE
                            ! #0  STACK DISP OF 4 WORD AREA
                            !       0 - 1  WORD DESC TO COUNTS ARRAY
                            !       2 - 3  BYTE DESC TO PA AREA
%OWNINTEGER COMAD
%OWNINTEGER PATHREPORT  ;!  0
                         !  1  FORCE UPDATE TO TABLE WHETHER OR NOT LABELLED
!*
%OWNINTEGER LOGLIST
%OWNRECORD(RESF) RES
%OWNRECORD(RESF) RNULL
%OWNINTEGER DOTEST
%OWNINTEGER LABWARN
%OWNINTEGER NOTFLAG
%OWNINTEGER RELOP
%OWNINTEGER CEXMODE;! 'const' expression mode - 
%OWNINTEGER UNASSCHECKS
!*
!*
!*
%CONSTINTEGER IDENDISP=24
%CONSTINTEGER DVAREA=7
%CONSTINTEGER FULL=2
%CONSTINTEGER YES=1
%CONSTINTEGER NO=0
!*
!*
%CONSTINTEGER PCFMT=0
%CONSTINTEGER FIOLNB=24
%CONSTINTEGER BLANKCREC=96
%CONSTINTEGER LNBLINENO=28;! STACK ADDRESS TO HOLD LINENO 
%CONSTINTEGER LNBSTACKBASE=4;! STACK ADDRESS TO HOLD CURRENT LNB VALUE
%CONSTINTEGER MAXCHARSIZE=X'7FFF'
!*
!*
%CONSTBYTEINTEGERARRAY MODETOST(0:11)=  %C
   X'41',X'51',X'61',X'52',X'62',X'72',X'53',X'63',X'73',X'54',X'05'(2)
!*
%CONSTSTRING(12)%ARRAY IOSPECS(1:25)=  %C
   "UNIT=", "FMT=", "REC=", "END=", "ERR=","IOSTAT=","FILE=","STATUS=",
   "ACCESS=","FORM=","RECL=","BLANK=","EXIST=","OPENED=","NUMBER=",
   "NAMED=","NAME=","NREC=","SEQUENTIAL=","DIRECT=","FORMATTED=",
   "UNFORMATTED=","NEXTREC=","DESC=",""
!*
%CONSTSTRING(9)%ARRAY IOTYPES(1:8)=  %C
   "READ", "WRITE", "BACKSPACE", "ENDFILE",
   "REWIND", "OPEN", "CLOSE", "INQUIRE"
!*
%CONSTINTEGERARRAY IOMASKS(1:8)=  %C
   X'7E',X'6E',X'62'(3),X'1041FE2',X'1E2',X'FFFEE2'
!*
%CONSTBYTEINTEGERARRAY OPENPP(0:25)=  %C
   0(7),X'42',X'43',X'44',X'45',0,X'46',0(5),1,0(5),X'47',0
!*
%CONSTBYTEINTEGERARRAY CLOSEPP(0:25)=0(8),X'40',0(17)
!*
%CONSTBYTEINTEGERARRAY INQUIREPP(0:25)=  %C
   0(7),X'40',0,X'66',X'69',X'2C',X'4E',X'A1',X'A2',X'23',X'A4',
   X'45',X'30',X'47',X'48',X'4A',X'4B',X'2D',X'4F',0
!*
!*
!*
%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'64',X'64',    0,X'64',X'64',X'66',X'64',X'64',    1,    1,
X'C2',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
!*
%CONSTBYTEINTEGERARRAY CSIZE(0:9)=0,4,8,4,8,16,8,16,32,4
!*
%CONSTBYTEINTEGERARRAY SETMODE(0:63)= %C
0(5),10,0(11),1,3,6,9,0(12),2,4,7,14,0(13),5,8,13,0(11)
!*
%CONSTBYTEINTEGERARRAY MODETOBYTES(0:14)=  %C
   4,4,8,4,8,16,8,16,32,4,0,0,0,4,8
!*
!*
!{2900C}%ROUTINE MOVE(%INTEGER LENGTH, FROM, TO)
!{2900C}%INTEGER I
!{2900C}      %RETURNIF LENGTH <= 0
!{2900C}      I = X'18000000'!LENGTH
!{2900C}      *LSS_FROM
!{2900C}      *LUH_I
!{2900C}      *LDTB_I
!{2900C}      *LDA_TO
!{2900C}      *MV_%L=%DR
!{2900C}%END;                                   !OF MOVE
!{2900C}!*
!{2900C}%ROUTINE FILL(%INTEGER LENGTH,FROM,FILLER)
!{2900C}%INTEGER I
!{2900C}      %RETURNIF LENGTH <= 0
!{2900C}      I = X'18000000'!LENGTH
!{2900C}      *LDTB_I
!{2900C}      *LDA_FROM
!{2900C}      *LB_FILLER
!{2900C}      *MVL_%L=%DR
!{2900C}%END
!*
!*
{PERQC}%ROUTINE COPY(%INTEGER LEN,SBASE,%HALFINTEGER SDISP,
{PERQC}                  %INTEGER TBASE,%HALFINTEGER TDISP)
{PERQC}      **@TBASE; *LDDW; **TDISP
{PERQC}      **@SBASE; *LDDW; **SDISP
{PERQC}      **LEN
{PERQC}      *STLATE_X'63'; *MVBW
{PERQC}%END
!*
!*
!***********************************************************************
!***********************************************************************
!*
%EXTERNALROUTINE GENERATE(%RECORD(TRIADF)%ARRAYNAME TRIADS,
                          %INTEGERNAME NEXTTRIAD,
                          %INTEGER KGEN,PATH,LABRECAD,ACOM)
!*
%ROUTINESPEC ARITHOP(%RECORD(RESF) RESL,%INTEGER OP,%RECORD(RESF) RESR)
%ROUTINESPEC CONST EVAL(%INTEGER RESL,OP,RESR,%INTEGERNAME DPTR)
%ROUTINESPEC CONDC(%INTEGER LLIST)
%ROUTINESPEC LOGTOACC(%INTEGER NOT)
%ROUTINESPEC ANDOR(%INTEGER P1)
%ROUTINESPEC SETCA(%INTEGER I)
%INTEGERFNSPEC SIMPLE INT(%INTEGER R)
%ROUTINESPEC CHECK BACK LAB
%ROUTINESPEC START OF DO LOOP(%INTEGER MODE)
%ROUTINESPEC END DO SUB(%INTEGER DOREC,P)
%ROUTINESPEC END OF DO LOOP
%ROUTINESPEC LINK PARAM(%INTEGER FPTR,R)
%INTEGERFNSPEC NEW PLAB
%INTEGERFNSPEC NEW TEMP(%INTEGER MODE)
!{PA}  %ROUTINESPEC PATHCOUNT(%INTEGER LINE,INDEX)
!{ITS} %ROUTINESPEC ITSACT(%INTEGER ENTRY)
!*
%INTEGER ADICT,IGEN,I,J,K,L,PTR,SPTR,PCT
!{2900}%INTEGER SAVELINK, II, KK, LL
{PERQ}%HALFINTEGER SAVELINK, II, KK, LL, SAVEINDEX
%INTEGER BC,OP,DOLAB,P,P1,P2
%INTEGER IOFORM,IOMODE,IOINDEX,IOFLAGS,IOCONTROLS,IOMASK,IOTYPE
%INTEGER LOGPTR
%INTEGERARRAYFORMAT FOUTPUT(0:4000)
%INTEGERARRAYNAME OUTPUT
%RECORD(ARRAYDVF)%NAME DVREC
%RECORD(PRECF)%NAME PP
%RECORD(SRECF)%NAME SS
%RECORD(LRECF)%NAME LLL
%RECORD(DORECF)%NAME DOREC
%RECORD(PRECF)%NAME ARRAYREC
%RECORD(PRECF)%NAME STATFN
%RECORD(IFRECF)%NAME IFREC
%RECORD(LABRECF)%NAME LABREC
%RECORD(FNRECF)%NAME FNREC
%RECORD(CONRECF)%NAME CON
%RECORD(PLABF)%NAME PLAB
%RECORD(RESF) RESL,RESR
%RECORD(COMFMT)%NAME COM
%INTEGER IODOINIT,IODEPTH,IOCURDIMS,IOSTARTED
%RECORD(RESF)%ARRAY SUBSCRIPT(0:7)
{PERQ}%HALFINTEGERARRAY SAVEII(0:100)
{PERQ}%HALFINTEGERARRAY SAVEKK(0:100)
{PERQ}%HALFINTEGERARRAY SAVELL(0:100)
{PERQ}%HALFINTEGERARRAY SAVESL(0:100)
%SWITCH PHI(0 : 100)
%SWITCH SW52(1:12)
!*
!***********************************************************************
!%INCLUDE "ERCS06.PERQ_GENTRIADS"                                       ;
!***********************************************************************
!*
!*
!***********************************************************************
!* Routines to generate triads                                         *
!***********************************************************************
!*
%ROUTINE TRIAD ERROR
      %MONITOR; %STOP
%END;! TRIAD ERROR
!*
%INTEGERFN NEW TRIAD(%INTEGER OP,%RECORD(RESF) RES1,%INTEGER QOPD2,OPD2)
%INTEGER CUR
%RECORD(TRIADF) %NAME TR
      CUR = NEXT TRIAD
      NEXT TRIAD = CUR + 1
      %IF CUR > COM_MAXTRIADS %THENSTART
         TRIAD ERROR
      %FINISH
      TR==RECORD(ADDR(TRIADS(CUR)_OP))
      TR_OP=OP
      TR_USE=0
      TR_RES1=RES1
      TR_QOPD2=QOPD2
      TR_OPD2=OPD2
!      PRINT TRIAD(CUR,COM_ADICT,COM_ANAMES,2,TRIADS(CUR))
      %RESULT = CUR
%END;! NEW TRIAD
!*
%INTEGERFN NEW TRIADR(%INTEGER OP,%RECORD(RESF) RES1,RES2)
%INTEGER CUR
%RECORD(TRIADF)%NAME TR
      CUR = NEXT TRIAD
      NEXT TRIAD = CUR + 1
      %IF CUR > COM_MAXTRIADS %THENSTART
         TRIAD ERROR
      %FINISH
      TR==RECORD(ADDR(TRIADS(CUR)_OP))
      TR_OP=OP
      TR_USE=0
      TR_RES1=RES1
      TR_RES2=RES2
!      PRINT TRIAD(CUR,COM_ADICT,COM_ANAMES,2,TRIADS(CUR))
      %RESULT = CUR
%END;! NEW TRIADR
!*
%INTEGERFN NEW TRIAD2(%INTEGER OP,SLN,QOPD2,OPD2,VAL2)
%INTEGER CUR
%RECORD(TRIADF) %NAME TR
      CUR = NEXT TRIAD
      NEXT TRIAD = CUR + 1
      %IF NEXT TRIAD > COM_MAXTRIADS %THENSTART
         TRIAD ERROR
      %FINISH
      TR==RECORD(ADDR(TRIADS(CUR)_OP))
      TR_OP=OP
      TR_VAL2=VAL2
      TR_SLN=SLN
      TR_QOPD2=QOPD2
      TR_OPD2=OPD2
!      PRINT TRIAD(CUR,COM_ADICT,COM_ANAMES,2 ,TRIADS(CUR))
      %RESULT = CUR
%END;! NEW TRIAD2
!*
!***********************************************************************
!***********************************************************************
!*
!*
      COMAD=ACOM;! for any other routines to map
      COM==RECORD(ACOM)
      ADICT=COM_ADICT
      OUTPUT==ARRAY(COM_ADOUTPUT,FOUTPUT)
{PERQ} SAVEINDEX=0
!*
      %IF PATH=-2 %THENSTART;! subprog entry
         PP==RECORD(ADICT+LABRECAD);! actually the subprog record
         I=NEW PLAB
         PP_DISP=I>>DSCALE
         I = NEW TRIAD2(STMT,NULL,PLABID,I>>DSCALE,0)
         %RETURN
      %FINISH
!*
      %IF LABRECAD # NULL %THENSTART
         LABREC==RECORD(ADICT+LABRECAD)
         DOLAB=LABREC_X0&4
      %FINISHELSE DOLAB=0
      %IF PATH = 3 %THEN DOTEST=1 %AND -> CHECKDO;! avoid any spurious errors when checking DO labels
      %UNLESS PATH=-1 %THENSTART;! except for const eval
         %IF COM_NEXTCH # 10 %OR PATH = 0 %THENSTART
            %IF COM_MAXINP>COM_INP %THEN COM_INP=COM_MAXINP
            FAULT(100);                         ! SYNTAX ERROR
            DOTEST=1;! to avoid spurious error report
            -> CHECK DO
         %FINISH
      %FINISH
      NOTFLAG = 0
      DOTEST = 0
      PCT = 0
      COM_FNLST=0
      %IF KGEN<0 %THENSTART
         KGEN=-KGEN
         IGEN=OUTPUT(KGEN)
      %FINISHELSE IGEN=KGEN
!*
!******** statement triad
!*
      %IF LABRECAD # NULL %THENSTART
         I=LABID
         J=1
      %FINISHELSESTART
         -> CHECK DO %IF OS(IGEN)=0
         I=NULL
         J=2
      %FINISH
      %UNLESS PATH=-1 %THENSTART
         I = NEW TRIAD2(STMT,COM_LINEST,I,LABRECAD>>DSCALE,J)
      %FINISH
      -> CHECK DO %IF OS(IGEN) = 0;  ! NO CODE TO PLANT
!*
!******** PATH ANALYSIS
   !*
!{PA}  %IF COM_PATHANAL#0 %AND PATH>0 %THENSTART
!{PA}     %IF COM_LAB#0 %OR PATHREPORT#0 %THEN PATHCOUNT(COM_LINEST,0)
!{PA}     PATHREPORT=0
!{PA}  %FINISH
!*
!*
      BC=0
      LL=0
      SAVELINK=0
      II=0
      KK=0
      LL=0
      ->START
PHI(1):
      II = IGEN+1
      KK = KGEN
                                        !RHO-SYMBOL
      LL = KGEN+OS(IGEN)
      IGEN = OUTPUT(LL)
      %IF IGEN<=0 %THENSTART
         KGEN = -IGEN
         IGEN = OUTPUT(KGEN)
      %FINISH
      SAVELINK=1
START:
!{2900} *LSQ_SAVELINK
!{2900} *ST_%TOS
!!{PERQC} **@SAVELINK
!!{PERQC} *LDC8
!!{PERQC} *LDMW;! save on mstack
{PERQ} SAVEII(SAVEINDEX)=II
{PERQ} SAVEKK(SAVEINDEX)=KK
{PERQ} SAVELL(SAVEINDEX)=LL
{PERQ} SAVESL(SAVEINDEX)=SAVELINK
{PERQ} SAVEINDEX=SAVEINDEX+1
{PERQ} %IF SAVEINDEX>100 %THEN %MONITOR %AND %STOP
L1:   P = OS(IGEN)
      IGEN = IGEN+1
      %IF COM_PTRACE#0 %THENSTART
         PRINTSTRING(" PHI")
         WRITE(P,2)
         SPACE
      %FINISH
      -> PHI(P)
PHI(0):
!{2900} *LSQ_%TOS
!{2900} *ST_SAVELINK
!!{PERQC} **@SAVELINK
!!{PERQC} *LDC8
!!{PERQC} *STMW;! restore from mstack
{PERQ} SAVEINDEX=SAVEINDEX-1
{PERQ} II=SAVEII(SAVEINDEX)
{PERQ} KK=SAVEKK(SAVEINDEX)
{PERQ} LL=SAVELL(SAVEINDEX)
{PERQ} SAVELINK=SAVESL(SAVEINDEX)
      %IF SAVELINK=0 %THENSTART
CHECK DO:%IF DOLAB = 4 %THEN END OF DO LOOP
         %RETURN
      %FINISH
      OUTPUT(LL)=RES_W
      IGEN=II
      KGEN=KK
      ->L1
!*
PHI(2):->L1;! DUMMY
!*
PHI(3):IGEN=OS(IGEN)<<8!OS(IGEN+1)
      ->L1;! for patching
!*
PHI(10):

!***********************************************************************
!* ARITHOP WITH OP,RESL AND RESR FROM TREE                             *
!***********************************************************************
      !SETP3
      OP = OS(IGEN)
      RESL_W = OUTPUT(KGEN+OS(IGEN+1))
      RESR_W = OUTPUT(KGEN+OS(IGEN+2))
      IGEN=IGEN+3
L100:
      %IF RESL_MODE=CHARMODE %OR RESR_MODE=CHARMODE %THENSTART
         %UNLESS RESL_MODE=CHARMODE %AND RESR_MODE=CHARMODE  %C
                       %AND (OP=1 %OR OP=7) %THENSTART
            LFAULT(132)
            %RETURN
         %FINISH
         RES_H0=NEW TRIADR(OP,RESL,RESR)
         RES_H1=TRIAD<<8!CHARMODE
      %FINISHELSE ARITHOP(RESL,OP,RESR)
      -> L1
!*
PHI(11):
!***********************************************************************
!* RES = constant integer                                              *
!***********************************************************************
      RES_W=OS(IGEN)
      IGEN=IGEN+1
      ->L1
!*
PHI(12):

!***********************************************************************
!* SAVE CURRENT OPERAND DESCRIPTOR AND OPERATOR IN GENERATE TREE       *
!***********************************************************************
      !SETP1
      PTR=FREESP(2)
      SS==RECORD(PTR+ADICT)
      SS_INF0=OP
      SS_LINK1=RES_W
      OUTPUT(KGEN+OS(IGEN))=PTR
      IGEN=IGEN+1
      -> L1
!*
PHI(13):

!***********************************************************************
!* SET RESULT DESCRIPTOR FROM TREE ENTRY P1                            *
!***********************************************************************
      P1=OS(IGEN)
      IGEN=IGEN+1
      RES_W = OUTPUT(KGEN+P1)
      COM_RESCOM1=RES_W;! for ANALYSE to reference const expression
      -> L1
!*
PHI(15):
!***********************************************************************
!* PLANT CODE FOR ARITHMETIC IF                                        *
!***********************************************************************
%BEGIN
%CONSTBYTEINTEGERARRAY ARITHIFMASK(0:7)= %C
   0, JIP, JIZ, JINN, JIN, JINZ, JINP, 0 ;! USED BY PHI(15) TO OPTIMISE ARITH IF BRANCHES
         %CONSTINTEGERARRAY NEXT(0:2)=1,2,0
         %INTEGERARRAY LDESC(0:2)
            %CYCLE I = 0,1,2
               LDESC(I) = (OUTPUT(KGEN+I+1)&X'FFFF0000')!(1<<I)
            %REPEAT
            %CYCLE I = 0,1,2
               J=NEXT(I)
              %IF LDESC(I)&X'FFFF0000' = LDESC(J)&X'FFFF0000' %THENSTART
                  LDESC(J)=LDESC(J)!LDESC(I)
                  LDESC(I) = 0
               %FINISH
            %REPEAT
            %CYCLE I = 0,1,2
               RESL_W=LDESC(I)
               J=RESL_H0
               %UNLESS J = 0 %THENSTART
                  LABREC==RECORD(ADICT+J<<DSCALE)
                  K=ARITHIFMASK(RESL_MODE)
                  %IF K=0 %THENSTART;! ALL LABELS THE SAME
                     RES_W=NULL
                     K=NEW TRIAD(GOTO,RES,LABID,J)
                  %FINISHELSESTART
                     K=NEW TRIAD(K,RES,LABID,J)
!{2900}               RES_FORM=NULL;! to avoid reloading acc
                  %FINISH
                  %IF LABREC_LINE # 0 %THENSTART;! BACKWARD JUMP
                     CHECK BACK LAB
                  %FINISHELSESTART;! FORWARD REFERENCE
                     PTR=NEW LIST CELL(LABREC_LINK2,3)
                     SS==RECORD(ADICT+PTR)
                     SS_INF0=K;! triad index
                     SS_INF2=COM_LINEST
                  %FINISH
               %FINISH
            %REPEAT
%END
         -> LABW
!*
PHI(16):
!***********************************************************************
!* ARITHOP WITH RESL AND OP FROM TREE, RESR=CURRENT OPERAND            *
!***********************************************************************
      P1=OS(IGEN)
      I = OUTPUT(KGEN+P1)
      IGEN=IGEN+1
      SS==RECORD(ADICT+I)
      OP=SS_INF0
      RESL_W=SS_LINK1
      RESR_W = RES_W
      %IF OP=1 %THEN ->L872;! to process concatenation
      FREE LIST CELL(I,2)
      -> L100
!*
PHI(17):

!***********************************************************************
!* IF UNARY - AT START OF EXPRESSION CALL ARITHOP                      *
!***********************************************************************
      %IF OP=0 %OR OP=10 %THEN ->L1;! + or none
      RESL_W = RES_W
      RESR_W = RES_W
      -> L100
!*
PHI(18):

!***********************************************************************
!* BEFORE PROCESSING STATEMENT AFTER LOGICAL IF                        *
!* SETS 'TRUE' ADDRESS BEFORE STATEMENT                                *
!* SAVE RECORD WITH 'FALSE' ADDRESS IN LOGPTR                          *
!***********************************************************************
         NOTFLAG=NOTFLAG!!1
         CONDC(1);! PLANT JUMP IF FALSE
         SETCA(LLL_ORLIST);! FILL .TRUE. ADDRESSES
         LOGPTR=LLL_ANDLIST
         FREE LIST CELL(LOGLIST,5)
         LLL==RECORD(ADICT+LOGLIST)
         RELOP=0
!{PA}     %IF COM_PATHANAL#0 %THEN PATHCOUNT(COM_LINEST,1);! RECORD SYMBOL 1
!{ITS}    %IF COM_ITSMODE=2 %THEN COM_STATEMENT=0 %AND ITSACT(2)
         ->L1
!*
PHI(19):

!***********************************************************************
!* FOLLOWING STATEMENT AFTER LOGICAL IF                                *
!* SETS 'FALSE' ADDRESS USING RECORD SAVED IN LOGPTR                   *
!***********************************************************************
         SETCA(LOGPTR)
         LABWARN=0
!!Z         FREE REGS
!{PA}     PATHREPORT=1
         ->L1
!*
PHI(21):

!***********************************************************************
!* AFTER .NOT.                                                         *
!* SETS NOTFLAG                                                        *
!* TIDIES UP AND/OR LISTS TO CORRECT BRACKET COUNT LEVEL               *
!***********************************************************************
         NOTFLAG=NOTFLAG!!1
!*
PHI(20):

!***********************************************************************
!* NOTE CURRENT OPERATOR CODE                                          *
!***********************************************************************
         !SETP1
         OP = OS(IGEN)
         IGEN=IGEN+1
         -> L1
!*
PHI(22):

!***********************************************************************
!* AFTER COMPARATOR (.EQ.,.NE.,.GT.,.GE.,.LT.,.LE.)                    *
!* SAVE CURRENT OPERAND DESCRIPTOR AND COMPARATOR CODE                 *
!***********************************************************************
      PTR=FREESP(2)
      SS==RECORD(ADICT+PTR)
      SS_INF0=OUTPUT(KGEN+2);! COMPARATOR CODE
      SS_LINK1=RES_W
      RELOP=PTR
      -> L1
!*
PHI(23):

!***********************************************************************
!* AFTER .OR.                                                          *
!***********************************************************************
      ANDOR(0)
      -> L1
!*
PHI(24):

!***********************************************************************
!* AFTER .AND.                                                         *
!***********************************************************************
      ANDOR(1)
      -> L1
!*
PHI(25):
!***********************************************************************
!* COMPILES CODE AT END OF LOGICAL ASSIGNMENT OR LOGICAL               *
!* EXPRESSION AS PARAM                                                 *
!***********************************************************************
      P1=OS(IGEN)
      IGEN=IGEN+1
      I=OUTPUT(KGEN+P1)
      -> L1 %IF I = 0
      BC=I>>16
      %IF RELOP#0 %OR LLL_ANDLIST#0 %OR LLL_ORLIST#0 %THENSTART
         LOGTOACC(0)
         ->L252
      %FINISHELSESTART
         %IF NOTFLAG#0 %THENSTART
            RES_H0=NEW TRIADR(NOT,RES,RNULL)
            RES_FORM=TRIAD
L252:       OUTPUT(KGEN+P1+1)=RES_W
         %FINISH
      %FINISH
      NOTFLAG=LLL_NOTFLAG
      RELOP=LLL_RELOP
      FREE LIST CELL(LOGLIST,5)
      LLL==RECORD(ADICT+LOGLIST)
      ->L1
!*
PHI(26):
!***********************************************************************
!* ACTION AT '(' FOR LOGICAL EXPRESSIONS                               *
!* PUSHES DOWN AND/OR LISTS                                            *
!* STORES BRACKET COUNT AND UPDATE IT                                  *
!***********************************************************************
         -> L1 %IF BC = 0
L260:    BC = BC+1;! COMMON CODE FOR PI(34)
         PTR=NEW LIST CELL(LOGLIST,5)
         LLL==RECORD(ADICT+LOGLIST)
         LLL_ORLIST=0
         LLL_ANDLIST=0
         LLL_NOTFLAG=NOTFLAG
         NOTFLAG=0
         LLL_RELOP=RELOP
         RELOP=0
         ->L1
!*
PHI(27):
!***********************************************************************
!* ACTION AT ')' IN LOGICAL EXPRESSIONS                                *
!* RESET BRACKET COUNT                                                 *
!* POPUP AND/OR LISTS IF NEITHER USED AND BC>1                         *
!***********************************************************************
         -> L1 %IF BC = 0
         BC = BC-1
         %IF LLL_ORLIST=0 %AND LLL_ANDLIST=0 %THENSTART
            NOTFLAG=LLL_NOTFLAG!!NOTFLAG
         %FINISHELSESTART
            LOGTOACC(LLL_NOTFLAG)
            NOTFLAG=0
         %FINISH
         %IF RELOP=0 %THEN RELOP=LLL_RELOP
         FREE LIST CELL(LOGLIST,5)
         LLL==RECORD(ADICT+LOGLIST)
         ->L1
!*
PHI(28):
!***********************************************************************
!* PLANT CODE FOR DO STATEMENT                                         *
!* FORM DO-LIST ENTRY                                                  *
!***********************************************************************
         PTR=NEW LIST CELL(COM_DOPTR,10)
         DOREC==RECORD(ADICT+PTR)
         I = OUTPUT(KGEN+5)
         LABREC==RECORD(ADICT+(I&X'FFFF')<<DSCALE);! LABEL RECORD
         LABREC_X0=LABREC_X0!4;! MARK AS REFERENCED BY DO
         DOREC_LABEL=(I&X'FF000000')!LABREC_LAB;! DEPTH<<24!LABEL
         DOREC_INDEXRD_W =  OUTPUT(KGEN+4);! INDEX R.D.
         CHECK DO INDEX(DOREC_INDEXRD_W,DOREC_LINK1)
         DOREC_INCRD_W = OUTPUT(KGEN+1)
         DOREC_FINALRD_W = OUTPUT(KGEN+2)
         DOREC_LABLIST=0
         DOREC_LINE=COM_LINEST
         RESL_W = OUTPUT(KGEN+3);! INITIAL VALUE R.D.
         START OF DO LOOP(0)
!{PA}     PATHREPORT=1;! TO ENSURE FIRST STAT IN DO LOOP IS REPORTED
         -> L1
!*
PHI(29):

!***********************************************************************
!* SET MARKER FOR STATEMENTS PERMITTED TO TERMINATE DO LOOP            *
!***********************************************************************
      DOTEST = 1
      -> L1
!*
PHI(30):
!***********************************************************************
!* COMPUTED GOTO                                                       *
!***********************************************************************
      SPTR = OUTPUT(KGEN+2)
L300: I = NEW TRIAD(CGT,RES,NULL,SPTR>>DSCALE)
      %WHILE SPTR#0 %CYCLE
         SS==RECORD(ADICT+SPTR)
         SPTR=SS_LINK1
         LABREC==RECORD(ADICT+SS_INF0)
         %IF LABREC_LINE # 0 %THENSTART;! backward jump
            CHECK BACK LAB
         %FINISHELSESTART;! forward
            PTR=NEWLISTCELL(LABREC_LINK2,3)
            SS==RECORD(ADICT+PTR)
            SS_INF0=I;! triad index
            SS_INF2=COM_LINEST
         %FINISH
      %REPEAT
      -> L1
!*
PHI(31):
!***********************************************************************
!* UNCONDITIONAL AND ASSIGNED GOTO                                     *
!***********************************************************************
      RES_W=OUTPUT(KGEN+1)
      %IF RES_FORM=LABID %THENSTART;! LABEL RECORD
         LABREC==RECORD(ADICT+RES_H0<<DSCALE)
         %IF LABREC_LINE#0 %THENSTART;! ALREADY DEFINED
            CHECK BACK LAB
         %FINISHELSESTART;! FORWARD REFERENCE
            PTR=NEW LIST CELL(LABREC_LINK2,3);! CHAIN OF FORWARD REFS
            SS==RECORD(ADICT+PTR)
            SS_INF0=NEXT TRIAD
            SS_INF2=COM_LINEST
         %FINISH
      %FINISHELSESTART;! ASSIGNED GOTO
         %IF RES_MODE # 1 %THEN LFAULT(190);! check that this is correct error *************
      %FINISH
      I = NEW TRIAD(GOTO,RES,NULL,NULL)
LABW: LABWARN = 1
         -> L1
!*
PHI(33):
!***********************************************************************
!* CALLED AFTER PHI32 TO PERFORM COMPUTED GOTO IF LABEL PARAMS         *
!***********************************************************************
      SPTR = OUTPUT(KGEN+1)
      -> L1 %IF SPTR = 0;! no label params
      RES_W=0
      -> L300
!*
PHI(34):
!***********************************************************************
!* ABOUT TO COMPILE AN EXPRESSION WHICH MAY BE LOGICAL                 *
!* NO ACTION UNLESS THIS IS SO                                         *
!***********************************************************************
         !SETP1
         P1=OS(IGEN)
         IGEN=IGEN+1
         I = OUTPUT(KGEN+P1)
         %IF I = 0 %AND BC = 0 %THEN -> L1;  ! NOTFLAG=0(NO LOGICAL COMPONENT)
         OUTPUT(KGEN+P1) = BC<<16!I;    ! NOW CONTAINS BC<<16!NOTFLAG
         BC = 0
         -> L260
!*
!*
!*
PHI(35):
!***********************************************************************
!* START OF PROCESSING FN                                              *
!***********************************************************************
      FNREC==RECORD(ADICT+NEW LIST CELL(COM_FNLST,4));! MAKE FN RECORD AVAIL TO SETPARAM FOR INTRINS CHECK
      FNREC_FPTR=OUTPUT(KGEN+OS(IGEN));! dict record for function
      IGEN=IGEN+1
      FNREC_HEAD=0
      FNREC_PCT=0
      -> L1
!*
PHI(36):
!***********************************************************************
!* AFTER  <IDEN> ( <PARAMLIST> )                                       *
!***********************************************************************
      PP==RECORD(ADICT+FNREC_FPTR)
      I=PP_X0&7;! fn group ( 1 intrin call, 2 intrin inline, 3 max/min)
      PCT=FNREC_PCT
      %IF I>0 %THENSTART
         J=PP_LINK2;! fn details
         %IF PCT=0 %OR (I<=2 %AND PCT#J&3) %OR   %C
              (PCT=1 %AND I=3 %AND 145<=J>>24<=150)  %C
                         %THEN LFAULT(139);! wrong no. of params
      %FINISH
      I=SETMODE(PP_TYPE&X'3F')
      %IF I=LOG1 %THEN I=LOG4
      %IF I=INT2 %THEN I=INT4
      RES_MODE=I
      I=FUN
L36A: RES_H0=FNREC_FPTR>>DSCALE
      RES_FORM=PROCID
      RESR_H0=FNREC_HEAD
      RESR_FORM=TRIAD
      RESR_MODE=FNREC_PCT
      RES_H0=NEW TRIADR(I,RES,RESR)
      RES_FORM=TRIAD
      FREE LIST CELL(COM_FNLST,4)
      FNREC==RECORD(ADICT+COM_FNLST)
      -> L1
!*
PHI(38):
!***********************************************************************
!* FOLLOWING EVALUATION OF PARAM TO EXTERNAL SUBPROG                   *
!* SET PARAM DESCRIPTOR ON STACK                                       *
!***********************************************************************
      I=KGEN+OS(IGEN)
      IGEN=IGEN+1
      LINK PARAM(FNREC_FPTR,OUTPUT(I+2))
      ->L1
!*
PHI(41):
!***********************************************************************
!* AFTER  CALL <IDEN>                                                  *
!***********************************************************************
      PP==RECORD(ADICT+FNREC_FPTR)
      RES_MODE=NULL
      I=SUBR
      ->L36A
!*
PHI(44):
!***********************************************************************
!* RETURN I                                                            *
!***********************************************************************
      %IF COM_SUBPROGTYPE=1 %THEN ->L451
L440:
!{ITS} %IF COM_ITSMODE#0 %THEN ITSACT(3);! REPORT RETURN
      OP = RET
      ->L452
!*
PHI(45):
!***********************************************************************
!* STOP                                                                *
!***********************************************************************
L451: RES_H0 = 0; RES_H1 = 0
L450:
!{ITS} %IF COM_ITSMODE#0 %THEN ITSACT(4);! REPORT STOP 
      OP = STOP
L452: I = NEW TRIAD(OP,RES,NULL,NULL)
      -> LABW
!*
PHI(46):

!***********************************************************************
!* END                                                                 *
!***********************************************************************
      RES_W=NULL
      I=NEW TRIAD(EOT,RES,NULL,NULL);! SUBPROGEND
      CODEGEN(3,TRIADS,ACOM);! GENERATE CODE
      -> L1
!*
PHI(47):

!***********************************************************************
!* RETURN                                                              *
!***********************************************************************
      %IF COM_SUBPROGTYPE=1 %THEN ->L451
      RES_W=NULL
      ->L440
!*
PHI(49):
!***********************************************************************
!* AFTER REF TO MULTI-DIMENSIONAL ARRAY ELEMENT                        *
!***********************************************************************
      RESL_W=OUTPUT(KGEN+OS(IGEN))
      IGEN=IGEN+1
      ARRAYREC==RECORD(ADICT+RESL_H0<<DSCALE)
      DVREC==RECORD(ADICT+ARRAYREC_ADDR4)
      PCT=DVREC_DIMS
      L=0
      %CYCLE J=1,1,PCT
         RES=SUBSCRIPT(J)
         %IF ARRAYREC_CLASS&X'C0'=0 %THENSTART;! not adjustable
            %IF RES_FORM=LIT %THENSTART
L491:          %UNLESS DVREC_B(J)_L<=RES_H0<=DVREC_B(J)_U %THENSTART
                  TFAULT(232,COM_ANAMES+ARRAYREC_IDEN,0)
               %FINISH
            %FINISHELSESTART
               %IF RES_FORM=NEGLIT %THEN K=-RES_H0 %AND ->L491
               L=1
            %FINISH
         %FINISH
         %IF DVREC_B(J)_M=-1 %THEN L=1
      %REPEAT
!*
      %IF COM_CONTROL&X'20'=0 %OR PCT=1 %OR L=0 %THENSTART;! ARRAYCHECKS#FULL or 1 subscript or all int
         %IF PCT>1 %THENSTART
            %CYCLE I=PCT,-1,2
               J=DVREC_B(I-1)_M
               RES_MODE=INT4
               %IF 0<J<X'7FFF' %THENSTART
                  RES_H0=J; RES_FORM=LIT;! handle as simple integer const
               %FINISHELSESTART;! set R.D. to multiplier in DV
                  RES_H0=DVREC_ADDRDV+I<<2+4; RES_FORM=STKLIT
               %FINISH
               ARITHOP(SUBSCRIPT(I),4,RES)
               %UNLESS I=PCT %THEN ARITHOP(RES,2,SUBSCRIPT(I+1))
               SUBSCRIPT(I)=RES
            %REPEAT
            ARITHOP(RES,2,SUBSCRIPT(1))
         %FINISHELSE RES=SUBSCRIPT(1)
         I=ARR
      %FINISHELSESTART
!************************************************************************
!!         MOVE(PCT<<2,ADDR(SUBSCRIPT(1)_W),ADICT+COM_DPTR)
!!         RES_H0=COM_DPTR>>DSCALE
!!         RES_FORM=LIT
!!         RES_MODE=RESL_MODE
!!         COM_DPTR=COM_DPTR+PCT<<2
!!         I=ARR1
      %FINISH
      RES_H0=NEW TRIADR(I,RESL,RES)
      RES_MODE=RESL_MODE
!{2900} RES_FORM=TRIAD
{PERQ} RES_FORM=ARREL
      ->L1
!*
PHI(50):
!***********************************************************************
!* Start processing I/O statement                                      *
!* P1  (IOTYPE)  = 1  READ                                             *
!*                 2  WRITE,PRINT                                      *
!*                 3  REWIND                                           *
!*                 4  BACKSPACE                                        *
!*                 5  ENDFILE                                          *
!*                 6  OPEN                                             *
!*                 7  CLOSE                                            *
!*                 8  INQUIRE                                          *
!***********************************************************************
      IOTYPE=OS(IGEN)
      IGEN=IGEN+1
      IOFORM=0
      IOMODE=0
      IOFLAGS=0
      %IF IOTYPE<=2 %THEN IOMODE=X'60' %ELSESTART
         %IF 3<=IOTYPE<=5 %THEN IOFORM=7  %C
                          %ELSE IOFORM=8
      %FINISH
!*
      %IF IOTYPE>5 %AND COM_JBRMODE#0 %THEN LFAULT(311);! not yet available
!*
      IOMODE=IOMODE!(1<<(IOTYPE-1));! Set sequential file as default, I/O type as spec
      IOFLAGS=IOFLAGS!(COM_CHARACTER CODE<<1)!(UNASSCHECKS<<2);! set if EBCDIC, CHECK
      IOFLAGS=IOFLAGS!((COM_CONTROL>>16)&8);! defaulting to strict ANSI (unless PARM(FREE))
      IOCONTROLS=0;! bit significance to check multiple or conflicting control specs
      IOMASK=IOMASKS(IOTYPE)
      IODOINIT=0
      IODEPTH=0
      IOCURDIMS=0
      RES_W=NULL
      IOSTARTED=NEW TRIAD(STRTIO,RES,LIT,IOTYPE)
      IOINDEX=0
      ->L1
!*
PHI(51):
!***********************************************************************
!* PROCESS I/O LIST ITEM                                               *
!***********************************************************************
      P1=OS(IGEN)
      IGEN=IGEN+1
      RES_W=OUTPUT(KGEN+P1)
      %IF RES_W=0 %THEN ->L1;! controlled var
!* reject also if expression and input list *********************************
      %IF IOTYPE=1 %AND (RES_FORM=LIT %OR RES_FORM=CNSTID) %THENSTART
         LFAULT(298);! not valid in input list
         ->L1
      %FINISH
PHI51A:IOINDEX=IOINDEX+1
      I=NEW TRIAD(IOITEM,RES,LIT,IOINDEX)
      ->L1
!*
%INTEGERFN CHECK DESC TO VAR(%RECORD(RESF) RES,%INTEGER MODE)
      %RESULT=0
%END;! CHECK DESC TO VAR
!*
PHI(52):
!***********************************************************************
!* Process I/O specification clause                                    *
!***********************************************************************

      P1=OS(IGEN)
      P2=OS(IGEN+1)
      IGEN=IGEN+2
      RES_W=OUTPUT(KGEN+P2)
L520: I=1<<P1
      %IF IOCONTROLS&I#0 %THEN TFAULT(211,ADDR(IOSPECS(P1)),0);!repeated defn
      %IF IOMASK&I=0 %THEN TFAULT(212,ADDR(IOSPECS(P1)),0);!incompatible specification
      IOCONTROLS=IOCONTROLS!I
      %IF P1>6 %THENSTART;! OPEN,CLOSE,INQUIRE
         %IF IOTYPE=6 %THEN J=OPENPP(P1) %ELSESTART
            %IF IOTYPE=7 %THEN J=CLOSEPP(P1) %ELSE J=INQUIREPP(P1)
         %FINISH
         %UNLESS IOTYPE=8 %THEN J=J!X'100'
         %IF MODETOST(RES_MODE)&15#I %THENSTART
L52A:       TFAULT(217,ADDR(IOSPECS(P1)),0);! invalid specifier
            ->L1
         %FINISH
L52B:    I=NEW TRIAD(IOSPEC,RES,P1,J)
         ->L1
      %FINISH
      ->SW52(P1)
!*
SW52(1):! UNIT=
!*
      %IF RES_W=0 %THENSTART ;!default unit specified (table initialised for default)
         %IF IOTYPE>2 %THEN TFAULT(223,ADDR(IOTYPES(IOTYPE)),0)
         ->L1
      %FINISH
!*
      %IF RES_MODE=CHARMODE %THENSTART
         IOMODE=(IOMODE&X'0F')!5;! internal file
!* check that it is not a concatenation or other expression ***********************
      %FINISHELSESTART
         %UNLESS RES_MODE<=INT8 %THENSTART
L523:       LFAULT(213);!invalid unit or internal file specifier
            ->L1
         %FINISH
      %FINISH
      ->L52B
!*
SW52(2): ! FMT=
!*
      IOFLAGS=IOFLAGS!1;! formatted I/O flag
!*
      %IF RES_W=0 %THENSTART ;! list directed
         IOFORM = 3;! form = 3
         ->L1
      %FINISH
!*
      J=RES_FORM
!*
      %IF J=LIT %THENSTART;! format label
L524:    K=RES_H0
         IOFORM=1;! form = 1
         %UNLESS 0<K<=99999 %THEN IFAULT(110,K) %AND ->L1;! invalid statement label
         I=SETLAB(K,PTR)
         LABREC==RECORD(ADICT+PTR)
         %IF I=0 %THENSTART ;! already set or referenced
            %UNLESS LABREC_X0=8 %THEN IFAULT(302,K) %AND ->L1;! already used as a statement label
         %FINISH
         LABREC_X0=8
         RES_FORM=LABID
         RES_H0=PTR>>DSCALE
         ->L52B
      %FINISH
!*
      %IF LSCALID<=J<=CSCALID %THENSTART ;! Scalar, must be assigned
         %IF RES_MODE=CHARMODE %THENSTART
            IOFORM=2
            ->L52B
         %FINISH
         IOFORM=1;! form=1
         %UNLESS RES_MODE<=INT8 %THENSTART
L521:       LFAULT(214);! wrong type
            ->L1
         %FINISH
         ->L52B
      %FINISH
!*
      IOFORM=2;! form=2
!*
      %IF J=ARRID %THENSTART ;! special iden (must be character array)
         PP==RECORD(ADICT+RES_H0<<DSCALE)
         %UNLESS PP_TYPE=5 %THEN LFAULT(191);! non-char array is non-standard
         ->L52B
      %FINISH
!*
      %IF RES_MODE=CHARMODE %THEN ->L52B
!*
      %IF J=CNSTID %THENSTART
         CON==RECORD(ADICT+RES_H0<<DSCALE)
         %IF CON_MODE=INT4 %THENSTART
            K=INTEGER(ADICT+CON_DADDR)
            ->L524
         %FINISH
         %IF CON_MODE=INT8 %THENSTART;! possible if I8 default chosen
            K=INTEGER(ADICT+CON_DADDR+4)
            ->L524
         %FINISH
      %FINISH
!*
      ->L521;! else error
!*
SW52(3):   ! REC=
!*
      IOMODE=IOMODE!X'70';! iotype=7 (over-riding default 6)
      %UNLESS RES_MODE<=INT8 %THEN LFAULT(216) %AND ->L1
      ->L52B
!*
SW52(4):   ! END =
!*
SW52(5): ! ERR=
!*
      J=RES_H0
      %UNLESS RES_FORM=0 %AND 0<J %THENSTART
         %IF RES_FORM=1 %THENSTART;! INT IN DICT
            %IF RES_MODE<=2 %THENSTART;! INT4 or INT8
               J=INTEGER(ADICT+J<<DSCALE+4*(RES_MODE-1))
            %FINISH
            %IF 0<J<=99999 %THEN ->SW525A
         %FINISH
         TFAULT(224,ADDR(IOSPECS(P1)),0)
         ->L1
      %FINISH
SW525A:I=SETLAB(J,PTR)
      LABREC==RECORD(ADICT+PTR)
      %IF LABREC_X0&8#0 %THENSTART
         IFAULT(228,LABREC_LINE);! already used as format label
      %FINISHELSESTART
         %IF LABREC_X0&1#0 %THENSTART
            IFAULT(225,J) ;! refers to a non-exec statement
         %FINISHELSESTART
            %IF  LABREC_LINE#0 %THENSTART ;! already defined
               CHECK BACK LAB
            %FINISH
            RES_FORM=LABID
            RES_H0=PTR>>DSCALE
            ->L52B
         %FINISH
      %FINISH
      ->L1
!*
SW52(6): ! IOSTAT=
!*
      I=CHECK DESC TO VAR(RES,1)
      %IF I#0 %THEN LFAULT(226) %AND ->L1
      ->L52B
!*
!*
PHI(53):
!***********************************************************************
!* End of I/O statement processing                                     *
!***********************************************************************
      %IF IOTYPE=8 %THENSTART;! INQUIRE
         %IF IOCONTROLS&X'82'=0 %THEN LFAULT(313);! UNIT or FILE required
         %IF IOCONTROLS&X'82'=X'82' %THEN LFAULT(314);! not both
      %FINISH
       %IF 6<=IOTYPE<=7 %THENSTART;! OPEN,CLOSE
         %UNLESS IOCONTROLS&2#0 %THEN LFAULT(315);! UNIT required
      %FINISH
      RES_FORM=IOFORM
      RES_MODE=IOTYPE
      RES_H0=IOMODE<<8!IOFLAGS
      I=NEW TRIAD(IO,RES,LIT,IOSTARTED)
      DOTEST=1;! allow I/O statements to terminate DO
      ->L1
!*
PHI(54):
!***********************************************************************
!* Process auxiliary I/O statment information clause                   *
!***********************************************************************
      I=OS(IGEN)
      P1=OUTPUT(KGEN+I+1);! control item
      RES_W=OUTPUT(KGEN+I);! expression descriptor
      IGEN=IGEN+1
      ->L520
!*
PHI(55):
!***********************************************************************
!* P1 = 0  start of implied-DO loop processing (in I/O list)           *
!*      1  end of loop processing                                      *
!***********************************************************************
      P1=OS(IGEN)
      IGEN=IGEN+1
!*
      IOINDEX=IOINDEX+1
      RES_FORM=P1
      RES_H0=IOINDEX
      I=NEW TRIAD(IODO,RES,NULL,NULL);! to ensure this is kept within the coroutine
!*
      %IF P1=0 %THENSTART;! start
         PTR=NEW LIST CELL(COM_DOPTR,10)
         DOREC==RECORD(ADICT+PTR)
         I=OUTPUT(KGEN+5);! index
         %IF I&X'FF'=X'41' %THENSTART;! I*2 NOT ALLOWED
            LFAULT(190)
            %RETURN
         %FINISH
         DOREC_INDEXRD_W=I
         CHECK DO INDEX(I,DOREC_LINK1)
         DOREC_INCRD_W=OUTPUT(KGEN+2)
         DOREC_FINALRD_W=OUTPUT(KGEN+3)
         RESL_W=OUTPUT(KGEN+4);! initial
         DOREC_LABEL=0
         START OF DO LOOP(1)
      %FINISHELSESTART;! end
         END DO SUB(COM_DOPTR,1)
         FREE LIST CELL(COM_DOPTR,10)
      %FINISH
      ->L1
!*
PHI(56):
!***********************************************************************
!* Expression or array element in I/O list                             *
!* P1 locates RES in tree                                              *
!***********************************************************************
      P1=OS(IGEN)
      IGEN=IGEN+1
      RES_W=OUTPUT(KGEN+P1)
      %IF RES_FORM=TRIAD %AND IOTYPE=1 %THENSTART;! look for expression in input list
         I=TRIADS(RES_H0)_QOPD1
         %IF I#ARR %AND I#ARR1 %THENSTART
            LFAULT(298)
            ->L1
         %FINISH
      %FINISH
      ->PHI51A
!*
PHI(60):
!***********************************************************************
!* COMPILES INITIAL CODE ON ENTRY TO A STATEMENT FUNCTION              *
!* SETS RESULT DESCRIPTOR                                              *
!***********************************************************************
      COM_FAST PROLOGUE=NO
      P1=OS(IGEN)
      IGEN=IGEN+1
      STATFN == RECORD(ADICT+OUTPUT(KGEN+P1))
      %IF STATFN_TYPE=5 %THENSTART
         PTR=FREESP(3)
         SS==RECORD(ADICT+PTR)
         SS_INF0=STATFN_LINK2
         SS_INF2=STATFN_LEN
         RES_W=PTR<<12!X'F05'
      %FINISHELSE RES_W = STATFN_LINK2<<12!X'200'!STATFN_TYPE
      -> L1
!*
PHI(61):

!***********************************************************************
!* AFTER COMPILATION OF AN ASSIGNMENT TAKE FURTHER ACTION IF           *
!* IT WAS A STATEMENT FUNCTION                                         *
!* COMPILES RETURN                                                     *
!* CLEARS LIST OF PARAMETERS(SFPTR)                                    *
!* LINKS SHORTENED FORM OF PARAMETER LIST TO STATEMENT FN RECORD       *
!* UPDATES START OF CODE ADDRESS FOR MAIN ENTRY                        *
!***********************************************************************
        -> L1 %IF COM_SFMK = 0
         COM_SFMK = 0
!!S         OPTOS(JUMP)
         SPTR=0
         %IF COM_SFPTR#0 %THENSTART
            %WHILE COM_SFPTR#0 %CYCLE
               PP==RECORD(ADICT+COM_SFPTR)
               PTR=NEW LIST CELL(SPTR,2)
               SS==RECORD(ADICT+PTR)
               %IF PP_TYPE=5 %THENSTART
                  PTR=FREESP(3)
                  SS_INF0=PTR<<12!X'F05'
                  SS==RECORD(ADICT+PTR)
                  SS_INF0=PP_ADDR4
                  SS_INF2=PP_LEN
               %FINISHELSESTART
                  SS_INF0=PP_ADDR4<<12!X'200'!PP_TYPE
               %FINISH
               FREE LIST CELL(COM_SFPTR,8)
            %REPEAT
            STATFN==RECORD(ADICT+PP_LINK3)
            STATFN_LINK3=SPTR
         %FINISH
!!S         %CYCLE I=1,1,8
!!S            TEMPST(I)=0;! ABANDON ANY TEMP STORES USED
!!S         %REPEAT
!!S         PTR=COM_SUBPROGPTR
!!S         %WHILE PTR#0 %CYCLE
!!S            PP==RECORD(ADICT+PTR)
!!S            %IF CODECA&2#0 %THEN OPLITT(JUMP,1);! to ensure word alignment
!!S            PP_DISP=CODECA>>2;! UPDATE START OF EXECUTABLE CODE
!!S            PTR=PP_LINK3
!!S         %REPEAT
!!S         FREE REGS
!{PA}     PATHREPORT=1;! ENSURE REPORTING OF FIRST ACTUAL PROG STATEMENT
         -> L1
!*
PHI(62):

!***********************************************************************
!* COMPILE CALL ON STATEMENT FUNCTION                                  *
!***********************************************************************
!!T      FREE REGS
!!T      STATFN==RECORD(ADICT+OUTPUT(KGEN+2))
!!T      %IF STATFN_TYPE=5 %THENSTART;! character
!!T         K=STATFN_LEN
!!T         I=ALLOC CHAR(K,0,J)
!!T         OPLNB(LD,I)
!!T         OPLNB(STD,STATFN_LINK2)
!!T         PTR=FREESP(3)
!!T         SS==RECORD(ADICT+PTR)
!!T         SS_INF0=I
!!T         SS_INF2=K
!!T         RES=PTR<<12!X'F05'
!!T      %FINISHELSE RES=STATFN_LINK2<<12!X'200'!STATFN_TYPE
!!T      OPLITT(JLK,(STATFN_ADDR4-CODECA)>>1)
!!T      %UNLESS RES&15=3 %OR RES&15=5 %THEN ARITHOP(0,9,RES)
!!T      %IF STATFN_TYPE=X'54' %THEN  %C
!!T            INTEGER(ADICT+RES>>12)=(INTEGER(ADICT+RES>>12)>>8)<<8!X'54'
      -> L1
!*
PHI(66):
!***********************************************************************
!* AFTER <U>**<F>                                                      *
!***********************************************************************
      RESL_W=OUTPUT(KGEN+2)
      RESR_W=OUTPUT(KGEN+1)
      ARITHOP(RESL,8,RESR)
      -> L1
!*
PHI(68):
!***********************************************************************
!* STOP <INT>                                                          *
!***********************************************************************
      RESL_W = OUTPUT(KGEN+1)
      ->L450
!*
PHI(69):
!***********************************************************************
!* PAUSE <INT>  OR  PAUSE ' <TEXT> '                                   *
!***********************************************************************
      RES_W = OUTPUT(KGEN+1)
L691: OP = PAUSE
      ->L452
!*
PHI(70):
!***********************************************************************
!* PAUSE                                                               *
!***********************************************************************
      RES_H0 = 0; RES_H1 = 0
      ->L691
!*
PHI(72):
!***********************************************************************
!* Coerce subscripts to I*4 if necessary                               *
!* Note R.D. for subscript in SUBSCRIPT array                          *
!***********************************************************************
      P1=OS(IGEN)
      IGEN=IGEN+1
      RES_W=OUTPUT(KGEN+P1);! evaluated subscript
      SUBSCRIPT(OUTPUT(KGEN+P1-1))_W=SIMPLE INT(RES_W)
      ->L1
!*
PHI(73):
!***********************************************************************
!* SET FORMAT PARAM (SYSTEM4 ONLY)                                     *
!***********************************************************************
         IGEN=IGEN+1
         ->L1
!*
PHI(74):
!***********************************************************************
!* Extract R.D.s for lower and upper substring expressions             *
!***********************************************************************
      RESL_W=SIMPLE INT(OUTPUT(KGEN+2))
      RESR_W=SIMPLE INT(OUTPUT(KGEN+1))
      COM_RESCOM1=RESL_W
      COM_RESCOM2=RESR_W
      ->L1
!*
PHI(75):
!***********************************************************************
!* Obtain descriptor to substring                                      *
!***********************************************************************
      COM_INP=OUTPUT(KGEN+1)
!!K      CHAR SUBSTRING(RES,RESL,RESR)
      ->L1
!*
PHI(77):
!***********************************************************************
!* Constant operation with RESL and OP from tree, RESR = RES           *
!***********************************************************************
      I=KGEN+OS(IGEN)
      IGEN=IGEN+1
      OP=OUTPUT(I+1)
PHI77A:RESL_W=OUTPUT(I)
PHI77B:CONST EVAL(RESL_W,OP,RES_W,COM_DPTR)
      ->L1
!*
PHI(78):
!***********************************************************************
!* Constant operation with RESL only from tree                         *
!***********************************************************************
      I=KGEN+OS(IGEN)
      IGEN=IGEN+1
      ->PHI77A
!*
PHI(79):
!***********************************************************************
!* Unary operation on constant                                         *
!***********************************************************************
      %IF OP=0 %THEN ->L1;! + or nothing
      RESL_W=0
      RESR_W=RES_W
      ->PHI77B
!*
PHI(80):
!***********************************************************************
!* Save current RES and OP                                             *
!***********************************************************************
      I=KGEN+OS(IGEN)
      IGEN=IGEN+1
      OUTPUT(I)=RES_W
      OUTPUT(I+1)=OP
      ->L1
!*
!*
PHI(81):
!***********************************************************************
!* Assign constant expression value to constant name, checking         *
!* compatability                                                       *
!* OUTPUT(P1)   = INP value (in case of error to be reported)          *
!* OUTPUT(P1+1) = RES for constant expression                          *
!* OUTPUT(P1+2) = DICT @ of constant name record                       *
!***********************************************************************
      I=KGEN+OS(IGEN)
      IGEN=IGEN+1
      PP==RECORD(ADICT+OUTPUT(I+2));! constant name record
      J=PP_TYPE
      K=SETMODE(J&X'3F')
      %IF J=X'54' %THEN K=9;! not given correctly by SETMODE
      RES_W=OUTPUT(I+1);! constant form of RES
      L=RES_H1&15
      %IF K=L %THENSTART
         %IF K=10 %THENSTART
            I=PP_LEN;! name length
            J=RES_H0<<DSCALE;! dict @ of const
            K=INTEGER(ADICT+J);! length of const
            %IF I#K %THENSTART
               %IF I=0 %THENSTART;! (*) specification
                  PP_LEN=K
               %FINISHELSESTART
!************************************************************************
!!                  INTEGER(ADICT+COM_DPTR)=I
!!                  %IF I<K %THENSTART
!!                     MOVE(I,ADICT+J+4,ADICT+COM_DPTR+4)
!!                  %FINISHELSESTART
!!                     FILL(I,ADICT+COM_DPTR+4,COM_SPACECHAR)
!!                     MOVE(K,ADICT+J+4,ADICT+COM_DPTR+4)
!!                  %FINISH
!!                  RES_H0=COM_DPTR>>DSCALE; RES_H1=X'10A'
!!                  COM_DPTR=COM_DPTR+((I+7)>>2)<<2
               %FINISH
            %FINISH
         %FINISH
         PP_LINK3=RES_W
L811:    
!{2900}         %IF COM_ITSMODE#0 %THENSTART;! ALLOCATE CONST TO CONSTAREA (FOR POSSIBLE ITS USE)
!{2900}            %IF RES_W&X'F00'=0 %THENSTART;! simple int
!{2900}               %IF RES_W<0 %THEN RES_W=(RES_W>>16)!X'FFFF0000'  %C
!{2900}                         %ELSE RES_W=RES_W>>16
!{2900}               L=4
!{2900}               I=ADDR(RES_W)
!{2900}            %FINISHELSESTART
!{2900}               I=RES_H0<<DSCALE;! DICT DISPACEMENT OF CONST
!{2900}               %IF K=10 %THENSTART;! CHAR
!{2900}                  L=INTEGER(ADICT+I)
!{2900}                  I=ADICT+I+4
!{2900}               %FINISHELSESTART
!{2900}                  L=MODETOBYTES(K)
!{2900}                  I=ADICT+I
!{2900}               %FINISH
!{2900}            %FINISH
!{2900}!!V            J=NEWCONST(L,I,K);! LENGTH, @ ,MODE
!{2900}!!V            PP_ADDR4=CONSTADDR(J)
!{2900}         %FINISH
         ->L1
      %FINISH
      %IF 1<=K<=8 %AND 1<=L<=8 %THENSTART;! compatible arithmetic modes
         %IF RES_W&X'F00'=0 %THENSTART
            %IF RES_W<0 %THEN RES_W=(RES_W>>16)!X'FFFF0000'  %C
                        %ELSE RES_W=RES_W>>16
            INTEGER(ADICT)=RES_W;! integer value for coertion
            RES_W=0
         %FINISHELSE RES_W=RES_H0<<DSCALE
         RES_W=COERCE CONST(RES_W,L,K,ADICT,COM_DPTR)>>DSCALE
         PP_LINK3=RES_W<<12!X'100'!K
         ->L811
      %FINISHELSESTART;! error
         COM_INP=OUTPUT(I)
         FAULT(278);! const expression of the wrong type
      %FINISH
      ->L1
!*
PHI(82):
!***********************************************************************
!* Set CEXMODE to indicate type of expression being evaluated          *
!* = 0  any const expression                                           *
!*   1  int const expression                                           *
!*   2  DATA-implied D0 subscript                                      *
!*   3  dimension bound expression                                     *
!***********************************************************************
      CEXMODE=OS(IGEN)
      IGEN=IGEN+1
      ->L1
!*
PHI(84):
!***********************************************************************
!* Block IF, ELSEIF, ELSE of ENDIF statement                           *
!* P1 = 0  IF(...)THEN                                                 *
!*      1  ELSEIF(...)THEN                                             *
!*      2  ELSE                                                        *
!*      3  ENDIF                                                       *
!***********************************************************************
      P1=OS(IGEN)
      IGEN=IGEN+1
!*
!!L      FREEREGS
      IFREC==RECORD(ADICT+COM_IFPTR)
!*
      %IF P1>0  %THENSTART;! ELSEIF, ELSE, ENDIF - note label enclosures
         I=COM_LINEST
         %IF P1=3 %THEN I=I-1;! ENDIF stat is not part of enclosure
         PTR=IFREC_LABLIST
         %WHILE PTR#0 %CYCLE
            SS==RECORD(ADICT+PTR)
            LABREC==RECORD(ADICT+SS_INF0);! label record
            LABREC_IFEND=I;! complete IF-block enclosure
            FREE LIST CELL(PTR,2)
         %REPEAT
         %IF COM_DOPTR#0 %THENSTART
            DOREC==RECORD(ADICT+COM_DOPTR)
            %IF DOREC_LINE>IFREC_LINE %THEN LFAULT(234)
         %FINISH
      %FINISH
!*
      %IF 1<=P1<=2 %THENSTART;! ELSEIF, ELSE - fill in jumps
!!L         IFREC_ENDIFJUMP=CODECA
!!L         PLF1(JUMP,0,0,0);! to ENDIF
         SETCA(IFREC_FALSELIST)
         IFREC_FALSELIST=0
      %FINISH
!*
      %IF P1<3 %THENSTART;! IF, ELSEIF, ELSE
         PTR=NEWLISTCELL(COM_IFPTR,6)
         IFREC==RECORD(ADICT+PTR)
         IFREC_TYPE=P1
         IFREC_ENDIFJUMP=0;! in case IF
         IFREC_FALSELIST=0;! in case ELSE
         IFREC_LABLIST=0
         I=COM_LINEST
         %IF P1=0 %THEN I=I+1;! IF stat is not part of enclosure
         IFREC_LINE=I;! for start of label enclosures
      %FINISHELSESTART
         %WHILE COM_IFPTR#0 %CYCLE
            IFREC==RECORD(ADICT+COM_IFPTR)
            J=IFREC_ENDIFJUMP
!!L            %IF J#0 %THEN PLUGADDRESS(J,CODECA)
            J=IFREC_FALSELIST
            %IF J#0 %THEN SETCA(J)
            FREE LIST CELL(COM_IFPTR,6)
            %IF IFREC_TYPE=0 %THEN %EXIT
         %REPEAT
      %FINISH
      ->L1
!*
PHI(85):
!***********************************************************************
!* After IF(...)THEN, ELSEIF                                           *
!* Fill in the jumps etc.                                              *
!***********************************************************************
      P1=OS(IGEN)
      IGEN=IGEN+1;! note P1 not used, but available if required
      NOTFLAG=NOTFLAG!!1
      CONDC(1)
      SETCA(LLL_ORLIST);! fill true addresses
      LOGPTR=LLL_ANDLIST
      FREE LIST CELL(LOGLIST,5)
      LLL==RECORD(ADICT+LOGLIST)
      IFREC==RECORD(ADICT+COM_IFPTR)
      IFREC_FALSELIST=LOGPTR
      ->L1
!*
PHI(86):
!***********************************************************************
!* ELSEIF statment                                                     *
!* Check that the expression is logical and go to common code          *
!***********************************************************************
      P1=OS(IGEN)
      IGEN=IGEN+1
      I=OUTPUT(KGEN+P1)
      %IF I=0 %AND BC=0 %THENSTART;! not logical
         LFAULT(192);! expression must be logical
      %FINISH
      OUTPUT(KGEN+P1)=BC<<16!I
      BC=0
      ->L260
!*
PHI(87):
!***********************************************************************
!* process a character item which is being concatenated                *
!* check that RES is of type character                                 *
!* force RES to form 15                                                *
!* P1=0 first on chain                                                 *
!*  >0 link RES record to chain at node P1                             *
!* RES describes head of chain                                         *
!***********************************************************************
      P1=OS(IGEN)
      IGEN=IGEN+1
      OP=1
L872: %IF RES_H1&X'FF'#CHARMODE %THENSTART
L871:    LFAULT(132);! invalid combination
         PTR=FREESP(3);! set dummy result to allow continuation
         SS==RECORD(ADICT+PTR)
         SS_INF0=X'205'
         SS_INF2=1
         RES_H0=PTR>>DSCALE; RES_H1=X'F0A'
         ->L1
      %FINISH
!!M      %IF RES&X'FFF'#X'F05' %THENSTART;! force temp form
!!M         SET CHAR DESC(RES,LD,0)
!!M         SET CHAR RECORD
!!M      %FINISH
      %IF P1=0 %THEN ->L1;! first in chain
      J=RES_H0<<DSCALE;! only link required
      I=OUTPUT(KGEN+P1)
      SS==RECORD(ADICT+I)
      OP=SS_INF0
      RES_W=SS_LINK1
      %UNLESS RES_H1=X'F0A' %THEN ->L871
      I=RES_H0<<DSCALE
      %WHILE I#0 %CYCLE
         SS==RECORD(ADICT+I)
         I=SS_LINK1
      %REPEAT
      SS_LINK1=J
      ->L1
!*
PHI(88):
!***********************************************************************
!* after EQV or NEQV                                                   *
!***********************************************************************
      LOGTOACC(0)
      OUTPUT(KGEN+2)=RES_W
      ->L1
!*
PHI(89):
!***********************************************************************
!* after RHS of EQV or NEQV                                            *
!***********************************************************************
      P1=OS(IGEN)
      IGEN=IGEN+1
      LOGTOACC(0)
      %IF P1=0 %THEN I=EQUIV %ELSE I=NEQ
      RESR_W=OUTPUT(KGEN+2)
      RES_H0=NEW TRIADR(I,RES,RESR)
      RES_FORM=TRIAD
      RES_MODE=LOG4
      ->L1
!*
PHI(90):
!***********************************************************************
!*  Start of processing array subscript                                *
!***********************************************************************
      RES_W=0
      I=NEW TRIADR(BOP,RES,RES)
      ->L1
!*
!*
%ROUTINE CHECK PMODE(%INTEGER PTR,MODE)
%INTEGER I,J,K,L,ST
%CONSTINTEGERARRAY GENMASK(0:8)=1,1,1,2,2,2,4,4,4
%RECORD(PRECF)%NAME PP
      ST=MODETOST(MODE)
      PP==RECORD(ADICT+PTR)
      I=PP_LINK2;! FN DETAILS
      J=I>>8&X'FF';! PARAMETER SIZE/TYPE
!{2900}K=I>>16&X'FF'
!{2900}%IF K&X'88'=0 %THENSTART;! no CHARACTER involved
!{2900}   %IF COM_OPTIONS1&10#0 %THENSTART    ;!MAKE GENERIC
!{2900}      J=K>>4;! PARAMETER MODE
!{2900}      %IF J>0 %THEN L=X'10'
!{2900}      %IF J>2 %THEN L=X'20'
!{2900}      %IF J>5 %THEN L=X'40'
!{2900}      %IF J#0 %THEN I=I!L
!{2900}      J=0
!{2900}      K=K&X'F'
!{2900}      L=K
!{2900}      %IF (K=1 %AND COM_OPTIONS1&2#0) %OR   %C
!{2900}         ((K=3 %OR K=6) %AND COM_OPTIONS1&8#0) %THENSTART
!{2900}         L=K+1
!{2900}         PP_TYPE=PP_TYPE+X'10';! MODIFY RESULT TYPE
!{2900}      %FINISH
!{2900}      I=(I&X'FF00FFFF')!L<<16
!{2900}   %FINISH
!{2900}%FINISH
      %IF J=0 %THENSTART;! PARAMETER MODE NOT SET (GENERIC)
         K=I>>4&15;! GENERIC RANGE
         %IF MODE<=CMPLX32 %THENSTART
            %IF K&GENMASK(MODE)#0 %THENSTART;! VALID GENERIC TYPE
               I=I!MODE<<20!ST<<8
               %IF I>>16&X'F'=0 %THENSTART;! FN MODE NOT SET
                  I=I!MODE<<16
                  PP_TYPE=ST
               %FINISH
               PP_LINK2=I
               %RETURN
            %FINISH
         %FINISH
ERR:     LFAULT(143)
      %FINISHELSESTART
         %IF J#ST %THENSTART
          %UNLESS (I>>16)&255=INT4 %AND MODE<=INT4 %THEN ->ERR
         %FINISH
      %FINISH
      %RETURN
%END;! CHECK PMODE
!*
%ROUTINE LINK PARAM(%INTEGER FPTR,R)
%RECORD(RESF) RES
%RECORD(PRECF)%NAME PP
%INTEGER FORM,VAL
      RES_W=R
      VAL=FNREC_HEAD
      %IF VAL#0 %THENSTART
         FORM=TRIAD
      %FINISHELSE FORM=NULL
      FNREC_HEAD=NEW TRIAD(ARG,RES,FORM,VAL)
      FNREC_PCT=FNREC_PCT+1
      PP==RECORD(ADICT+FPTR)
      %IF PP_X0&7#0 %THEN CHECK PMODE(FPTR,RES_MODE)
%END;! LINK PARAM
!*
%ROUTINE ARITHOP(%RECORD(RESF) RESL,%INTEGER OP,%RECORD(RESF) RESR)
!***********************************************************************
!* RESL,RESR  RESULT DESCRIPTORS FOR LEFT AND RIGHT OPERANDS WHERE REL.*
!* OP  1  COMPARE                                                      *
!*     2  +                                                            *
!*     3  -                                                            *
!*     4  *                                                            *
!*     5  /                                                            *
!*     6  UNARY -                                                      *
!*     7  ASSIGN (LEFT OPERAND TO RIGHT OPERAND LOCATION               *
!*     8  **                                                           *
!* OPERATION MODE IS MAX(OPERAND MODES)                                *
!***********************************************************************
!*
%INTEGER LF, LA, LMODE, RF, RA, RMODE, OPMODE
%INTEGER I, J, K
!*
!{2900}%CONSTBYTEINTEGERARRAY SETOPMODE(0:80)= %C
!{2900}X'01',X'01',X'02',X'03',X'04',X'05',X'53',X'54',X'55',
!{2900}X'01',X'01',X'02',X'03',X'04',X'05',X'53',X'54',X'55',
!{2900}X'02',X'02',X'02',X'04',X'04',X'05',X'54',X'54',X'55',
!{2900}X'03',X'03',X'04',X'03',X'04',X'05',X'63',X'64',X'65',
!{2900}X'04',X'04',X'04',X'04',X'04',X'05',X'64',X'64',X'65',
!{2900}X'05',X'05',X'05',X'05',X'05',X'05',X'65',X'65',X'65',
!{2900}X'13',X'13',X'14',X'23',X'24',X'25',X'33',X'34',X'35',
!{2900}X'14',X'14',X'14',X'24',X'24',X'25',X'34',X'34',X'35',
!{2900}X'15',X'15',X'15',X'25',X'25',X'25',X'35',X'35',X'35'
!{2900}!*
!{2900}%CONSTBYTEINTEGERARRAY CHANGEMODE(0:15) =  %C
!{2900}   1,1,2,3,4,5,6,7,8,1,0,0,0,1,2,0
!*
{PERQ}%CONSTBYTEINTEGERARRAY SETOPMODE(0:80)= %C
{PERQ}X'00',X'01',X'02',X'03',X'04',X'05',X'53',X'54',X'55',
{PERQ}X'01',X'01',X'02',X'03',X'04',X'05',X'53',X'54',X'55',
{PERQ}X'02',X'02',X'02',X'04',X'04',X'05',X'54',X'54',X'55',
{PERQ}X'03',X'03',X'04',X'03',X'04',X'05',X'63',X'64',X'65',
{PERQ}X'04',X'04',X'04',X'04',X'04',X'05',X'64',X'64',X'65',
{PERQ}X'05',X'05',X'05',X'05',X'05',X'05',X'65',X'65',X'65',
{PERQ}X'13',X'13',X'14',X'23',X'24',X'25',X'33',X'34',X'35',
{PERQ}X'14',X'14',X'14',X'24',X'24',X'25',X'34',X'34',X'35',
{PERQ}X'15',X'15',X'15',X'25',X'25',X'25',X'35',X'35',X'35'
{PERQ}!*
{PERQ}%CONSTBYTEINTEGERARRAY CHANGEMODE(0:15) =  %C
{PERQ}   0,1,2,3,4,5,6,7,8,1,0,0,0,1,2,0
!*
%CONSTBYTEINTEGERARRAY SHORTFLAG(0:15) = X'80',0(12),X'60',0(2)
%CONSTBYTEINTEGERARRAY TRIADOP(0:5)= 0, REL, ADD, SUB, MULT, DIV
!*
%SWITCH SW(6 : 11)
!*
!******  EXPAND RESULT DESRIPTOR FOR RHS OPERAND
         RA = RESR_H0
         RMODE = RESR_MODE
         RF = RESR_FORM!SHORTFLAG(RMODE)
!******  FOR DIADIC OPERATORS EXPAND RESULT DESC FOR LEFT OPERAND
         LA = RESL_H0
         LMODE = RESL_MODE
         LF = RESL_FORM!SHORTFLAG(LMODE)
!*
         LMODE=CHANGEMODE(LMODE)
         RMODE=CHANGEMODE(RMODE)
         OPMODE = SETOPMODE(LMODE*9+RMODE)
         %IF OPMODE>15 %THENSTART;! SOME COMPLEX ITEM
!!!            COMPLEXOP(LF,LA,LMODE,RF,RA,RMODE,OP,OPMODE)
            %RETURN
         %FINISH
!*
         %IF OP > 5 %THEN -> SW(OP)
!*
!* following section should be handled by CONST EVAL
!* and should include all consts (const coercion should also be covered)
         %IF LF=NEGLIT %THEN LF=LIT %AND LA=-LA
         %IF RF=NEGLIT %THEN RF=LIT %AND RA=-RA
         %IF LF=LIT %AND RF=LIT %THENSTART
            %IF OP=2 %THENSTART
               I=LA+RA
               ->RESINT
            %FINISH
            %IF OP=3 %AND LA>=RA %THENSTART
               I=LA-RA
               ->RESINT
            %FINISH
            %IF OP=4 %THENSTART
               I=LA*RA
RESINT:        %IF X'FFFF8000'<I<X'7FFF' %THENSTART
                  %IF I<0 %THENSTART
                     I=-I
                     K=NEGLIT
                  %FINISHELSE K=LIT
                  %IF LMODE!RMODE#1 %THEN J=INT8 %ELSE J=INT4
                  RES_H0=I; RES_H1=(K<<8)!J
                  %RETURN
               %FINISH
            %FINISH
         %FINISH
!*
         RES_FORM=NULL
         RES_MODE=OPMODE
         %IF LMODE#OPMODE %THENSTART
            LA=NEW TRIADR(CVT,RES,RESL)
            LF=TRIAD
         %FINISH
         %IF RMODE#OPMODE %THENSTART
            RA=NEW TRIADR(CVT,RES,RESR)
            RF=TRIAD
         %FINISH
         RESL_MODE=OPMODE
         RES_H0=NEW TRIADR(TRIADOP(OP),RESL,RESR)
         RES_H1=TRIAD<<8!OPMODE
         %RETURN
!*
SW(6):   ! UNARY -
         %IF RF=LIT %THENSTART
            I=-RA
            ->RESINT
         %FINISH
         %IF RMODE=INT2 %THENSTART
            RESL_FORM=NULL
            RESL_MODE=INT4
            RESR_H0=NEW TRIADR(CVT,RESL,RESR)
            RESR_FORM=TRIAD
            RMODE=INT4
            RESR_MODE=INT4
         %FINISH
         RES_H0=NEW TRIAD(NEG,RESR,NULL,NULL)
         RES_H1=TRIAD<<8!RMODE
         %RETURN
!*
SW(7):   ! ASSIGN LHS TO RHS
!* could perform const conversions here
{PERQ}  %IF RMODE=INT2 %AND (LF=LIT %OR LF=NEGLIT)  %C
{PERQ}                               %THEN RESL_MODE=INT2
         %IF RMODE=LMODE %THEN I=ASMT %ELSE I=CVT
         I=NEW TRIADR(I,RESR,RESL)
         %RETURN
!*
SW(8):!**
         %IF RMODE>5 %OR LMODE>5 %THENSTART
            LFAULT(134)
            RES_W=NULL
            %RETURN
         %FINISH
        RESL_MODE=OPMODE
         RES_H0=NEW TRIADR(EXP,RESL,RESR)
         RES_H1=TRIAD<<8!OPMODE
         %RETURN
!*
!*
%END;                                   ! ARITHOP
!*
!*
!*
!*
!*
!*
%ROUTINE SETCA(%INTEGER PLABEL)
!***********************************************************************
!* define private label for conditional branches                       *
!***********************************************************************
%INTEGER I
      %IF PLABEL#0 %THENSTART
         I=NEW TRIAD2(STMT,NULL,PLABID,PLABEL>>DSCALE,0)
      %FINISH
%END;! SETCA
!*
%INTEGERFN SIMPLE INT(%INTEGER R)
!***********************************************************************
!* Ensure that any integer expressions requiring DR are loaded and     *
!* that the result is a simple integer value                           *
!***********************************************************************
!!Z      %IF R=0 %THEN %RESULT=0
!!Z      %IF R&X'FF'#X'51' %OR 11<=(R>>8)&X'F'<=12 %THENSTART
!!Z         ARITHOP(X'51',9,R);! load to acc as simple int
!!Z         %RESULT=RES
!!Z      %FINISHELSE %RESULT=R
      %RESULT=R
%END;! SIMPLE INT
!*
%ROUTINE CHECK BACK LAB
%INTEGER I
      I=LABREC_DOSTART
      %IF I#0 %THENSTART
         %UNLESS I<=COM_LINEST<=LABREC_DOEND %THEN  %C
                                IFAULT(205,LABREC_LINE)
      %FINISH
      I=LABREC_IFSTART
      %IF I#0 %THENSTART
         %UNLESS I<=COM_LINEST<=LABREC_IFEND %THEN  %C
                             IFAULT(203,LABREC_LINE)
      %FINISH
%END;! CHECK BACK LAB
!*
%ROUTINE CONDC(%INTEGER LLIST)
!***********************************************************************
!* COMPILE TESTS IN LOGICAL EXPRESSIONS
!* COMPILE LOAD AND TEST AND BC FOR LOGICAL VARS
!* IF RELOP # 0 COMPARE AND BRANCH
!***********************************************************************
%CONSTBYTEINTEGERARRAY COMPOPS(0:12) =  %C
   0,0,GT,0,LT,0,NE,0,EQ,0,GE,0,LE
%INTEGER I,PLABREC,JUMPOP,CONDMASK
%RECORD(SRECF)%NAME SSS
      %IF LLIST=0 %THENSTART
         PLABREC=LLL_ORLIST
      %FINISHELSE PLABREC=LLL_ANDLIST
      %IF PLABREC=0 %THENSTART
         PLABREC=NEW PLAB
         %IF LLIST=0 %THENSTART
            LLL_ORLIST=PLABREC
         %FINISHELSE LLL_ANDLIST=PLABREC
      %FINISH
      RESR_H0=PLABREC>>DSCALE
      RESR_FORM=PLABID
      RESR_MODE=0
      %IF RELOP#0 %THENSTART;! COMPARISON TO BE PERFORMED
         SSS==RECORD(ADICT+RELOP)
         CONDMASK=SSS_INF0
         RESL_W=SSS_LINK1
         RES_H0=NEW TRIADR(COMPOPS(CONDMASK),RESL,RES)
         RES_FORM=TRIAD;! keeping RES_MODE=char/non-char as indicator
      %FINISH
      %IF NOTFLAG=0 %THEN JUMPOP=JIT %ELSE JUMPOP=JIF
      I=NEW TRIADR(JUMPOP,RES,RESR)
      NOTFLAG=0
      RELOP=0
%END;! CONDC
!*
%ROUTINE LOGTOACC(%INTEGER NOTFL)
%INTEGER I,J
      %IF RELOP=0 %AND LLL_ANDLIST=0 %AND LLL_ORLIST=0 %THEN %RETURN
      CONDC(0);! PLANTS JUMP IF TRUE
      SETCA(LLL_ANDLIST);! FILLS .AND. ADDRESSES
      LLL_ANDLIST=0
      %IF NOTFL =0 %THEN I=0 %ELSE I=1
      RES_H0=NEW TEMP(LOG4)>>DSCALE
      RES_FORM=TMPID
      RES_MODE=LOG4
      J=NEW TRIAD(ASMT,RES,LIT,I)
      RESR_H0=NEW PLAB>>DSCALE
      RESR_FORM=PLABID
      RESR_MODE=0
      J=NEW TRIADR(GOTO,RESR,RNULL)
      SETCA(LLL_ORLIST);! FILL .TRUE. ADDRESSES
      LLL_ORLIST=0
      J=NEW TRIAD(ASMT,RES,LIT,I!!1)
      J=NEW TRIAD2(ASMT,NULL,PLABID,RESR_H0,0)
%END;! LOGTOACC
!*
%ROUTINE ANDOR(%INTEGER P1)
!***********************************************************************
!* COMPILE CODE FOR .AND. OR .OR. CONDITION AND SET UP AND/OR LISTS    *
!* P1 = 0  .OR.                                                        *
!*      1  .AND.                                                       *
!***********************************************************************
         NOTFLAG=NOTFLAG!!P1
         CONDC(P1)
         %IF P1=0 %THENSTART
            SETCA(LLL_ANDLIST)
            LLL_ANDLIST=0
         %FINISH
%END;! ANDOR
!*
%ROUTINE START OF DO LOOP(%INTEGER PAR)
%INTEGER M,IMODE
%RECORD(RESF) R
      %IF DOREC_INDEXRD_MODE=INT4 %THEN M=0 %ELSE M=X'800000';! can use BREG
      %UNLESS DOREC_INCRD_MODE=INT4 %AND DOREC_FINALRD_MODE=INT4  %C
         %AND RESL_MODE=INT4 %AND DOREC_INCRD_FORM=LIT  %C
         %AND DOREC_FINALRD_FORM#NEGLIT %AND RESL_FORM#NEGLIT  %C
                                        %THEN M=M!X'400000';! if 0 then all simpl int consts
      DOREC_LABEL=DOREC_LABEL!M;! for end of loop processing
      %IF DOREC_INCRD_FORM=LIT %AND DOREC_INCRD_H0=0 %THENSTART;! zero increment
         LFAULT(295)
         DOREC_INCRD_H0=1
      %FINISH
      %IF M=0 %THENSTART;! simple case
         %IF DOREC_FINALRD_FORM # LIT %THENSTART;! final is not simple int const
            RESR_FORM=PERMID
            RESR_MODE=INT4
            RESR_H0=NEW TEMP(INT4)>>DSCALE
            I = NEW TRIADR(ASMT,RESR,DOREC_FINALRD)
            DOREC_FINALRD=RESR
         %FINISH
         I = NEW TRIADR(STOD1,DOREC_INDEXRD,RESL);! index, initial
         %UNLESS RESL_FORM=LIT   %C
                       %AND DOREC_FINALRD_FORM=LIT %THENSTART;! unless both initial and final are const
            DOREC_ENDREF=NEW PLAB
            I=NEW TRIAD(STOD2,DOREC_FINALRD,PLABID,DOREC_ENDREF>>DSCALE)
         %FINISHELSESTART
            %IF DOREC_FINALRD_H0<RESL_H0 %THENSTART;! zero trip
               DOREC_ENDREF=NEW PLAB
            I = NEW TRIAD(GOTO,RNULL,PLABID,DOREC_ENDREF>>DSCALE)
            %FINISHELSE DOREC_ENDREF=0
         %FINISH
         DOREC_LOOPAD=NEW PLAB
         I = NEW TRIAD2(STMT,NULL,PLABID,DOREC_LOOPAD>>DSCALE,0)
         %RETURN
      %FINISH
!*
      IMODE=DOREC_INDEXRD_MODE
      I = NEW TRIADR(CVT,DOREC_INDEXRD,RESL);! index=initial
      %IF DOREC_INDEXRD_FORM#LIT %OR DOREC_INCRD_H0#1  %C
                %OR IMODE#INT4 %THENSTART;! unless default int 1 and int required
         K=1
         RESR_FORM=PERMID
         RESR_MODE=IMODE
         RESR_H0=NEW TEMP(IMODE)>>DSCALE
         I = NEW TRIADR(CVT,RESR,DOREC_INCRD)
      %FINISHELSE K=0
!*
      %IF DOREC_FINALRD_MODE#IMODE %THENSTART
         R_W=NULL
         R_MODE=IMODE
         DOREC_FINALRD_H0 = NEW TRIADR(CVT,R,DOREC_FINALRD)
         DOREC_FINALRD_MODE=IMODE
         DOREC_FINALRD_FORM=TRIAD
      %FINISH
      R_H0 = NEW TRIADR(SUB,DOREC_FINALRD,DOREC_INDEXRD)
      R_FORM=TRIAD
      RESR_H0 = NEW TEMP(INT4)>>DSCALE
      RESR_FORM=TMPID
      RESR_MODE=INT4
      R_H0 = NEW TRIAD(ADD,R,LIT,1)
      DOREC_ICRD=RESR
      I = NEW TRIADR(ASMT,RESR,R)
      DOREC_ENDREF=NEW PLAB
      I = NEW TRIAD(GOTO,RNULL,PLABID,DOREC_ENDREF>>DSCALE)
      DOREC_LOOPAD=NEW PLAB
      I = NEW TRIAD2(STMT,NULL,PLABID,DOREC_LOOPAD>>DSCALE,0)
%END;! START OF DO LOOP

!*
%ROUTINE END DO SUB(%INTEGER DOPTR,PAR)
%INTEGER I
%RECORD(DORECF)%NAME DOREC
%RECORD(RESF) R
      DOREC==RECORD(ADICT+DOPTR)
      %IF DOREC_LABEL&X'C00000'#0 %THENSTART;! not all int consts
         R_H0 = NEW TRIADR(ADD,DOREC_INDEXRD,DOREC_INCRD)
         R_MODE = DOREC_INDEXRD_MODE
         R_FORM = TRIAD
         I = NEW TRIADR(ASMT,DOREC_INDEXRD,R)
         I = NEW TRIAD(EODA,DOREC_ICRD,PLABID,DOREC_ENDREF>>DSCALE)
         I = NEW TRIAD(EODB,RNULL,PLABID,DOREC_LOOPAD>>DSCALE)
      %FINISHELSESTART;! all int consts
         I = NEW TRIADR(EOD1,DOREC_INDEXRD,DOREC_INCRD)
         I = NEW TRIAD(EOD2,DOREC_FINALRD,PLABID,DOREC_LOOPAD>>DSCALE)
         %IF DOREC_ENDREF # 0 %THENSTART
             I = NEW TRIAD2(STMT,NULL,PLABID,DOREC_ENDREF>>DSCALE,0)
         %FINISH
      %FINISH
%END;! END DO SUB
!*
%ROUTINE END OF DO LOOP
!***********************************************************************
!* THE LABEL ON THE CURRENT STATEMENT HAS BEEN SPECIFIED IN A DO STAT  *
!***********************************************************************
%INTEGER J,PTR
%RECORD(DORECF)%NAME DOREC
%RECORD(SRECF)%NAME SS
%RECORD(IFRECF)%NAME IFREC
%RECORD(LABRECF)%NAME LABREC
      %IF DOTEST = 0 %THENSTART
         LFAULT(294);! ILLEGAL STATEMENT TERMINATING DO
      %FINISH
      DOTEST = 0
!{PA}  J=0;! FOR PATH ANALYSIS
      %CYCLE
         DOREC == RECORD(ADICT+COM_DOPTR)
         %IF DOREC_INDEXRD_W&X'FF000000'#X'FF000000' %THENSTART;! VALID RECORD
            %IF DOREC_LABEL&X'FFFFF' = COM_LAB %THENSTART;! N.B. DO DEPTH IS IN TOP BYTE
!{PA}           %IF J#0 %AND COM_PATHANAL#0 %THEN PATHCOUNT(COM_LINEST,J)
!{PA}            J=J+1
               %IF COM_IFPTR#0 %THENSTART
                  IFREC==RECORD(ADICT+COM_IFPTR)
                  %IF IFREC_LINE>DOREC_LINE %THEN LFAULT(234)
               %FINISH
               END DO SUB(COM_DOPTR,0)
!{PA}           PATHREPORT=1
            %FINISHELSEEXIT;! FROM CYCLE
         %FINISH
         PTR=DOREC_LABLIST
         %WHILE PTR#0 %CYCLE
            SS==RECORD(ADICT+PTR)
            LABREC==RECORD(ADICT+SS_INF0);! label record
            LABREC_DOEND=COM_LINEST;! complete DO enclosure
            FREE LIST CELL(PTR,2)
         %REPEAT
         FREE LIST CELL(COM_DOPTR,10)
         %IF COM_DOPTR = 0 %THENRETURN
      %REPEAT
!*
      I = COM_DOPTR
      %WHILE I # 0 %CYCLE
         DOREC == RECORD(ADICT+I)
         %IF DOREC_LABEL&X'FFFFF' = COM_LAB %THENSTART
            LFAULT(148);                  ! ILLEGAL STATEMENT TERMINATING DO, OR WRONGLY N ESTED DO
            DOREC_INDEXRD_W = X'FF000000'
         %FINISH
         I = DOREC_LINK1
      %REPEAT
      PATHREPORT=1;! ENSURE NEXT STAT IS REPORTED WHEN PA IN USE
%END;                                   ! END OF DO LOOP
!*
!*
%ROUTINE CKLAB
!***********************************************************************
!* CHECK FOR LABELS NOT SET AT END OF SUBPROGRAM                       *
!***********************************************************************
%INTEGER I, J,PTR
%RECORD(LABRECF)%NAME LABREC
%INTEGERARRAYFORMAT FLABH(0:31)
%INTEGERARRAYNAME LABH
      LABH==ARRAY(COM_ALABH,FLABH)
      I = 0
      %CYCLE J = 0,1,31
         PTR = LABH(J)
         %WHILE PTR # 0 %CYCLE
            LABREC == RECORD(ADICT+PTR)
            %IF LABREC_ADDR4 = 0 %AND LABREC_LAB#0 %THENSTART;  ! LABEL NOT SET
               COM_PI21INT=LABREC_LAB
!{2900}         FAULTNUM(111,COMAD);! LABEL NOT SET
{PERQ}         %IF COM_DIAGSTREAM>=0 %THENSTART
{PERQ}            SELECTOUTPUT(COM_DIAGSTREAM)
{PERQ}            FAULTNUM(111,COMAD,1)
{PERQ}         %FINISH
{PERQ}         %IF COM_LISTSTREAM>=0 %THENSTART
{PERQ}            SELECTOUTPUT(COM_LISTSTREAM)
{PERQ}            FAULTNUM(111,COMAD,0)
{PERQ}         %FINISH
            %FINISH
            PTR = LABREC_LINK1
         %REPEAT
      %REPEAT
%END;                                   ! CKLAB
!*
%INTEGERFN NEW TEMP(%INTEGER MODE)
!***********************************************************************
!* Get temp scalar DICT record                                         *
!***********************************************************************
%INTEGER I,J
%RECORD(TMPF)%NAME TMP
      J=COM_DPTR
      COM_DPTR=COM_DPTR+TMPRECSIZE
      TMP==RECORD(ADICT+J)
      TMP_MODE=MODE
      TMP_REG=0
      TMP_LINK1=0
      TMP_ADDR=0
      %RESULT=J
%END;! GET TEMP
!*
%INTEGERFN NEW PLAB
!***********************************************************************
!* Provide a new dict record for a private label                       *
!***********************************************************************
%INTEGER I
      I=COM_DPTR
      COM_DPTR=COM_DPTR+PLABRECSIZE
      PLAB==RECORD(ADICT+I)
      PLAB_INDEX=COM_NEXT PLAB
      PLAB_CODEAD=0
      PLAB_REF=0
      PLAB_REFCHAIN=0
      COM_NEXT PLAB=COM_NEXT PLAB+1
      %RESULT=I
%END;! NEW PLAB
!*
%ROUTINE CONST EVAL(%INTEGER RESL,OP,RESR,%INTEGERNAME DPTR)
!{2900C}!*
!{2900C}%CONSTBYTEINTEGERARRAY OPERATING MODE(0:10)=0,1,1,5,5,5,8,8,8,9,10
!{2900C}!*
!{2900C}%INTEGER AL,FL,ML,AR,FR,MR,ARES,MRES,I
!{2900C}%INTEGER IL,IR
!{2900C}%LONGLONGREAL RL,RR,CL,CR,RW,CW
!{2900C}!*
!{2900C}%SWITCH OPMODE(1:10)
!{2900C}%SWITCH IOP(2:8)
!{2900C}%SWITCH ROP(2:8)
!{2900C}%SWITCH COP(2:8)
!{2900C}!*
!{2900C}      *MPSR_X'E180';! mask overflow
!{2900C}      AL=RESL>>12
!{2900C}      FL=(RESL>>8)&15
!{2900C}      ML=RESL&255
!{2900C}      AR=RESR>>12
!{2900C}      FR=(RESR>>8)&15
!{2900C}      MR=RESR&255
!{2900C}!*
!{2900C}      %IF FL>2 %OR FR>2 %THENSTART;! param exp
!{2900C}         %IF COM_CEXPDICT=0 %THENSTART;! start of exp
!{2900C}            COM_CEXPDICT=DPTR
!{2900C}            DPTR=DPTR+4;! for length
!{2900C}         %FINISH
!{2900C}         RESL=RESL!X'80000000'
!{2900C}         RESR=RESR!X'80000000'
!{2900C}         MOVE(12,ADDR(RESL),ADICT+DPTR)
!{2900C}         RES_W=(STACKCA-STACKBASE)<<12!X'80000601';! temp on stack
!{2900C}         PUTWORD(7,0)
!{2900C}         INTEGER(ADICT+DPTR+12)=RES_W
!{2900C}         DPTR=DPTR+16
!{2900C}         %RETURN
!{2900C}      %FINISH
!{2900C}!*
!{2900C}      %IF FL=0 %THENSTART;! store simple integers in DICT for simplicity
!{2900C}         %IF RESL<0 %THEN AL=AL!X'FFF00000'
!{2900C}         INTEGER(ADICT)=AL
!{2900C}         AL=0
!{2900C}      %FINISH
!{2900C}      %IF FR=0 %THENSTART
!{2900C}         %IF RESR<0 %THEN AR=AR!X'FFF00000'
!{2900C}         INTEGER(ADICT+4)=AR
!{2900C}         AR=4
!{2900C}      %FINISH
!{2900C}!*
!{2900C}      MRES=OPERATING MODE(ML)
!{2900C}      I=OPERATING MODE(MR)
!{2900C}      %IF OP=7 %THENSTART;! **
!{2900C}         %IF I#1 %THENSTART
!{2900C}            LFAULT(113);! POWER MUST BE INTEGER
!{2900C}         AR=4
!{2900C}         INTEGER(ADICT)=1;! TO ALLOW CONTINUATION
!{2900C}         %FINISH
!{2900C}      %FINISHELSESTART
!{2900C}         %IF I>MRES %THEN MRES=I;! evaluate expressions as I*4,R*16 or C*32
!{2900C}      %FINISH
!{2900C}!*
!{2900C}      %IF 1<OP<=7 %THENSTART
!{2900C}         %IF OP#6 %AND ML#MRES %THEN  %C
!{2900C}                            AL=COERCE CONST(AL,ML,MRES,ADICT,DPTR)
!{2900C}         %IF MR#MRES %AND OP#7 %THEN  %C
!{2900C}                            AR=COERCE CONST(AR,MR,MRES,ADICT,DPTR)
!{2900C}      %FINISH
!{2900C}!*
!{2900C}OPERATE:
!{2900C}      AL=ADICT+AL
!{2900C}      AR=ADICT+AR
!{2900C}      ARES=ADICT+DPTR
!{2900C}      ->OPMODE(MRES)
!{2900C}!*
!{2900C}OPMODE(1):                              ! INTEGER*4
!{2900C}      IL=INTEGER(AL)
!{2900C}      IR=INTEGER(AR)
!{2900C}      ->IOP(OP)
!{2900C}!*
!{2900C}IOP(2):IR=IL+IR
!{2900C}IMEET:*JAT_15,<OVERI>
!{2900C}IMEET2:%IF 0<=IR<=X'7FFF' %THENSTART
!{2900C}         RES_H0=IR; RES_H1=1
!{2900C}         %RETURN
!{2900C}      %FINISH
!{2900C}      INTEGER(ARES)=IR
!{2900C}      RES_H0=DPTR>>DSCALE; RES_H1=X'101'
!{2900C}      DPTR=DPTR+4
!{2900C}      %RETURN
!{2900C}!*
!{2900C}OVERI:FAULT(112)
!{2900C}      IR=1
!{2900C}      ->IMEET2
!{2900C}!*
!{2900C}IOP(3):IR=IL-IR
!{2900C}      ->IMEET
!{2900C}!*
!{2900C}IOP(4):IR=IL*IR
!{2900C}      *JAT_15,<OVERI>
!{2900C}      ->IMEET
!{2900C}!*
!{2900C}IOP(5):%IF IR=0 %THEN ->OVERI
!{2900C}      IR=IL//IR
!{2900C}      *JAT_15,<OVERI>
!{2900C}      ->IMEET
!{2900C}!*
!{2900C}IOP(6):IR=-IR
!{2900C}      ->IMEET
!{2900C}!*
!{2900C}IOP(7):%IF IR=0 %THEN IR=1 %ELSESTART
!{2900C}         %IF IR<0 %THEN IR=0 %ELSESTART
!{2900C}            I=IL
!{2900C}            %WHILE IR>1 %CYCLE
!{2900C}               I=I*IL
!{2900C}               *JAT_15,<OVERI>
!{2900C}               IR=IR-1
!{2900C}            %REPEAT
!{2900C}            IR=I
!{2900C}         %FINISH
!{2900C}      %FINISH
!{2900C}      ->IMEET
!{2900C}!*
!{2900C}OPMODE(5):                              ! REAL*16
!{2900C}      RL=LONGLONGREAL(AL)
!{2900C}      RR=LONGLONGREAL(AR)
!{2900C}ROPOP:->ROP(OP)
!{2900C}!*
!{2900C}ROP(2):RR=RL+RR
!{2900C}RMEET:*JAT_15,<OVERR>
!{2900C}RMEET2:LONGLONGREAL(ARES)=RR
!{2900C}      %IF MRES=8 %THEN LONGLONGREAL(ARES+16)=CR
!{2900C}      RES_H0=DPTR>>DSCALE; RES_H1=X'100'!MRES
!{2900C}      DPTR=DPTR+CSIZE(MRES)
!{2900C}      %RETURN
!{2900C}!*
!{2900C}OVERR:FAULT(112)
!{2900C}      RR=1
!{2900C}      ->RMEET2
!{2900C}!*
!{2900C}ROP(3):RR=RL-RR
!{2900C}      ->RMEET
!{2900C}!*
!{2900C}ROP(4):RR=RL*RR
!{2900C}      *JAT_15,<OVERR>
!{2900C}      ->RMEET
!{2900C}!*
!{2900C}ROP(5):RR=RL/RR
!{2900C}      *JAT_15,<OVERR>
!{2900C}      ->RMEET
!{2900C}!*
!{2900C}ROP(6):RR=-RR
!{2900C}      ->RMEET
!{2900C}!*
!{2900C}ROP(7):RR=RL**INTEGER(AR)
!{2900C}      *JAT_15,<OVERR>
!{2900C}      ->RMEET
!{2900C}!*
!{2900C}OPMODE(8):                              ! COMPLEX*32
!{2900C}      RL=LONGLONGREAL(AL)
!{2900C}      CL=LONGLONGREAL(AL+16)
!{2900C}      RR=LONGLONGREAL(AR)
!{2900C}      RW=RR
!{2900C}      CW=LONGLONGREAL(AR+16)
!{2900C}      ->COP(OP)
!{2900C}!*
!{2900C}COP(2):CR=CL+CR
!{2900C}      ->ROPOP
!{2900C}!*
!{2900C}COP(3):CR=CL-CR
!{2900C}      ->ROPOP
!{2900C}!*
!{2900C}COP(4):RR=RL*RW-CL*CW
!{2900C}      CR=RL*CW+RW*CL
!{2900C}      ->RMEET
!{2900C}!*
!{2900C}COP5:
!{2900C}COP(5):RR=RL*RW+CL*CW
!{2900C}      CR=RW*CL-RL*CW
!{2900C}      RW=RW*RW+CW*CW
!{2900C}      RR=RR/RW
!{2900C}      CR=CR/RW
!{2900C}      ->RMEET
!{2900C}!*
!{2900C}COP(6):CR=-CW
!{2900C}      ->ROPOP
!{2900C}!*
!{2900C}COP(7):IR=INTEGER(AR)
!{2900C}      IL=IR
!{2900C}      %IF IR<0 %THEN IR=-IR
!{2900C}      RR=RL
!{2900C}      CR=CL
!{2900C}      %WHILE IR>1 %CYCLE
!{2900C}         RW=RR
!{2900C}         CW=CR
!{2900C}         RR=RL*RW-CL*CW
!{2900C}         CR=RL*CW+RR*CL
!{2900C}         IR=IR-1
!{2900C}      %REPEAT
!{2900C}      %IF IL<=0 %THENSTART
!{2900C}         RW=RR
!{2900C}         CW=CR
!{2900C}         RL=1.0
!{2900C}         RR=0
!{2900C}         %IF IL#0 %THEN ->COP5
!{2900C}      %FINISH
!{2900C}      ->RMEET
!{2900C}!*
!{2900C}OP9:
!{2900C}OPMODE(9):FAULT(130)
!{2900C}      RES_W=RESL
!{2900C}      %RETURN
!{2900C}!*
!{2900C}OPMODE(10):%UNLESS ML=MR %AND OP=1 %THEN ->OP9
!{2900C}      FL=INTEGER(AL)
!{2900C}      FR=INTEGER(AR)
!{2900C}      INTEGER(ARES)=FL+FR
!{2900C}      MOVE(FL,AL+4,ARES+4)
!{2900C}      MOVE(FR,AR+4,ARES+4+FL)
!{2900C}      RES_H0=DPTR>>DSCALE; RES_H1=X'10A'
!{2900C}      DPTR=(DPTR+FL+FR+7)&(-4)
!{2900C}      %RETURN
!{2900C}!*
%END;! CONST EVAL
!*
!{PA} %ROUTINE PATHCOUNT(%INTEGER LINE,INDEX)
!{PA} %INTEGER I
!{PA}     I = NEW TRIAD2(PA,LINE,NULL,NULL,INDEX)
!{PA} %END;! PATHCOUNT
!*
!{ITS} %ROUTINE ITSACT(%INTEGER ENTRY)
!{ITS} %INTEGER I
!{ITS}    I = NEW TRIAD2(ITS,ENTRY,NULL,NULL,NULL)
!{ITS} %END;! ITSACT
!*
%END;! GENERATE
!*
%EXTERNALINTEGERFN COERCE CONST(%INTEGER A,OLDMODE,NEWMODE,ADICT, 
                                %INTEGERNAME DPTR)
!{2900C}!***********************************************************************
!{2900C}!* Coerce constant held at displacement A in DICT in mode OLDMODE      *
!{2900C}!* to NEWMODE, setting %result=new DICT displacement                   *
!{2900C}!***********************************************************************
!{2900C}%CONSTLONGREAL ZERO8=R'4F00000000000000'
!{2900C}%CONSTLONGREAL CROUND8=R'0000000080000000'
!{2900C}%CONSTLONGLONGREAL CROUND16=R'00000000000000000080000000000000'
!{2900C}%LONGREAL ROUND8
!{2900C}%LONGLONGREAL ROUND16
!{2900C}%INTEGER TEMPMODE,ANEW,I
!{2900C}%SWITCH C(0:15)
!{2900C}      *MPSR_X'C080';! MASK OVERFLOW AND UNDERFLOW
!{2900C}      *LSD_CROUND8
!{2900C}      *ST_ROUND8
!{2900C}      *LSQ_CROUND16
!{2900C}      *ST_ROUND16
!{2900C}      ANEW=ADICT+DPTR
!{2900C}      A=ADICT+A
!{2900C}!*
!{2900C}LOOP: I=CONST TRAN(10*OLDMODE+NEWMODE)
!{2900C}      TEMPMODE=I&15
!{2900C}      ->C(I>>4)
!{2900C}!*
!{2900C}C(1): *LXN_A                            ;! I*4 -> I*8
!{2900C}      *LSS_(%XNB)
!{2900C}      *IMYD_1
!{2900C}      *LXN_ANEW
!{2900C}      *ST_(%XNB)
!{2900C}      ->CHECK
!{2900C}!*
!{2900C}C(2): REAL(ANEW)=INTEGER(A)             ;! I*4 -> R*4
!{2900C}      ->CHECK
!{2900C}!*
!{2900C}C(3): LONGREAL(ANEW)=INTEGER(A)         ;! I*4 -> R*8
!{2900C}      ->CHECK
!{2900C}!*
!{2900C}C(4): LONGREAL(ANEW)=LONGINTEGER(A)     ;! I*8 ->R*8
!{2900C}      ->CHECK
!{2900C}!*
!{2900C}C(5): LONGLONGREAL(ANEW)=LONGINTEGER(A) ;! I*8 -> R*16
!{2900C}      ->CHECK
!{2900C}!*
!{2900C}C(6): *LXN_A                            ;! R*4 -> R*8/C*8
!{2900C}      *LSS_0
!{2900C}      *LUH_(%XNB)
!{2900C}      *LXN_ANEW
!{2900C}      *ST_(%XNB)
!{2900C}      ->CHECK
!{2900C}!*
!{2900C}C(7): *LXN_A                            ;! R*8 -> R*16/C*16
!{2900C}      *LSD_0
!{2900C}      *LUH_(%XNB)
!{2900C}      *LXN_ANEW
!{2900C}      *ST_(%XNB)
!{2900C}      ->CHECK
!{2900C}!*
!{2900C}C(8): *LXN_A                            ;! R*16 -> C*32
!{2900C}      *LSQ_(%XNB)
!{2900C}      *LXN_ANEW
!{2900C}      *ST_(%XNB)
!{2900C}      *LSQ_0
!{2900C}      *ST_(%XNB+4)
!{2900C}      ->CHECK
!{2900C}!*
!{2900C}C(9): *LXN_A                            ;! C*8 -> C*16
!{2900C}      *LCT_ANEW
!{2900C}      *LSS_0
!{2900C}      *LUH_(%XNB)
!{2900C}      *ST_(%CTB)
!{2900C}      *LSS_0
!{2900C}      *LUH_(%XNB+1)
!{2900C}      *ST_(%CTB+2)
!{2900C}      ->CHECK
!{2900C}!*
!{2900C}C(10):*LXN_A                            ;! C*16 -> C*32
!{2900C}      *LCT_ANEW
!{2900C}      *LSD_0
!{2900C}      *LUH_(%XNB)
!{2900C}      *ST_(%CTB)
!{2900C}      *LSD_0
!{2900C}      *LUH_(%XNB+2)
!{2900C}      *ST_(%CTB+4)
!{2900C}!*
!{2900C}CHECK:%IF TEMPMODE=NEWMODE %THENSTART
!{2900C}         DPTR=DPTR+CSIZE(NEWMODE)
!{2900C}         %RESULT=ANEW-ADICT
!{2900C}      %FINISHELSESTART
!{2900C}         A=ANEW
!{2900C}         %IF NEWMODE=8 %THEN ANEW=ANEW+16;! ELSE OVERLAP
!{2900C}         OLDMODE=TEMPMODE
!{2900C}         ->LOOP
!{2900C}      %FINISH
!{2900C}!*
!{2900C}C(11):*LXN_A                            ;! I*8 -> I*4
!{2900C}      *LSD_(%XNB)
!{2900C}      *ISH_32
!{2900C}      *LXN_ANEW
!{2900C}      *STUH_(%XNB)
!{2900C}      *JAT_15,<INTOVERFLOW>
!{2900C}      ->CHECK
!{2900C}!*
!{2900C}C(12):*LXN_A                            ;! R*8 -> I*8
!{2900C}      *LSD_(%XNB)
!{2900C}      *RAD_ZERO8
!{2900C}      *RSC_47
!{2900C}      *RSC_-47
!{2900C}      *FIX_%B
!{2900C}      *MYB_4
!{2900C}      *ISH_%B
!{2900C}      *LXN_ANEW
!{2900C}      *ST_(%XNB)
!{2900C}      *JAT_15,<INTOVERFLOW>
!{2900C}      ->CHECK
!{2900C}!*
!{2900C}C(13):%IF OLDMODE=4 %THENSTART         ;! R*8 ->R4
!{2900C}         *LXN_A
!{2900C}         *LSS_(%XNB)
!{2900C}         *USH_-24
!{2900C}         *USH_24
!{2900C}         *ST_ROUND8
!{2900C}         *LSD_(%XNB)
!{2900C}         *RAD_ROUND8
!{2900C}         *LXN_ANEW
!{2900C}         *STUH_(%XNB)
!{2900C}      %FINISHELSESTART                  ;! R16 -> R8
!{2900C}         *LXN_A
!{2900C}         *LSS_(%XNB)
!{2900C}         *USH_-24
!{2900C}         *USH_24
!{2900C}         *ST_ROUND16
!{2900C}         *LSQ_(%XNB)
!{2900C}         *RAD_ROUND16
!{2900C}         *LXN_ANEW
!{2900C}         *STUH_(%XNB)
!{2900C}      %FINISH
!{2900C}      *JAT_15,<REALOVERFLOW>
!{2900C}      ->CHECK
!{2900C}!*
!{2900C}C(14):%IF OLDMODE=7 %THENSTART          ;! C*16 -> C*8
!{2900C}         *LXN_A
!{2900C}         *LCT_ANEW
!{2900C}         *LSS_(%XNB)
!{2900C}         *USH_-24
!{2900C}         *USH_24
!{2900C}         *ST_ROUND8
!{2900C}         *LSD_(%XNB)
!{2900C}         *RAD_ROUND8
!{2900C}         *STUH_(%CTB)
!{2900C}         *LSS_(%XNB+2)
!{2900C}         *USH_-24
!{2900C}         *USH_24
!{2900C}         *ST_ROUND8
!{2900C}         *LSD_(%XNB+2)
!{2900C}         *RAD_ROUND8
!{2900C}         *STUH_(%CTB+1)
!{2900C}      %FINISHELSESTART                  ;! C*32 -> C*16
!{2900C}         *LXN_A
!{2900C}         *LCT_ANEW
!{2900C}         *LSS_(%XNB)
!{2900C}         *USH_-24
!{2900C}         *USH_24
!{2900C}         *ST_ROUND16
!{2900C}         *LSQ_(%XNB)
!{2900C}         *RAD_ROUND16
!{2900C}         *STUH_(%CTB)
!{2900C}         *LSS_(%XNB+4)
!{2900C}         *USH_-24
!{2900C}         *USH_24
!{2900C}         *ST_ROUND16
!{2900C}         *LSQ_(%XNB+4)
!{2900C}         *RAD_ROUND16
!{2900C}         *STUH_(%CTB+2)
!{2900C}      %FINISH
!{2900C}      *JAT_15,<REALOVERFLOW>
!{2900C}      ->CHECK
!{2900C}!*
!{2900C}C(15):%IF A=ANEW %THEN ->CHECK          ;! C*8/C*16/C*32 -> R*4/R*8/R*16
!{2900C}      %IF TEMPMODE=NEWMODE %THENSTART
!{2900C}         %RESULT=A-ADICT;! no new space required
!{2900C}      %FINISHELSESTART
!{2900C}         OLDMODE=TEMPMODE
!{2900C}         ->LOOP
!{2900C}      %FINISH
!{2900C}!*
!{2900C}INTOVERFLOW:
!{2900C}      FAULT(112)
!{2900C}      %RESULT=8;! int value 1
!{2900C}!*
!{2900C}REALOVERFLOW:
!{2900C}      FAULT(112)
!{2900C}      %RESULT=16;! real value 1
!{2900C}!*
!{2900C}C(0): FAULT(130)
!{2900C}      %RESULT=A
!{2900C}!*
%END;! COERCE CONST
!*
!*
%ENDOFFILE