! rs6p422.i Dec94 adapted for a C backend
! rs6p420.i Jun94 Support for longints added
! Changes 16Nov93 to use pushbytes for string values
!         ALSO TO CONSTRUCT param descriptor from reversed lists
! Changes 20sep93 to allow tempspace to be allocated in 
!     prologue and epilogue rts.(For saveing GOT/TOC ) vsn p420.3
! Changes 10June93 to byteswop string length in initown
! Changes 4Jan93 to use Enextproc2
! Changes 3Mar92 to use MVW for aligned record copies
!
! Changes to count use of labels and call EfrLabel for short
!forward jumps
!
! Revisions to 22Feb changes to flag bytes as unsigned ints and hence
! to correct conversion code.                               26Nov91
! Changes 22Feb90 to pass types to the ecode generator Vsn 5
!
! Changes to reduce confusion over dummy parameter pushed for
! alignment purposes (Mostly but not entirely in PARDESLIST
!    PDS nov 89
!
! changes applied for risc development retrofitted (GEM 5/10/89)
!
! Warning this module has the revised triples spec.
!
! In first attempt at Triple Imp considerable use was made of constant operands
! to pass information from Pass2 to GEN. Although for specialised operations like
! passing Labels this still applies, this adhocery has caused problems with arrays
! and pointers particularly in mapped records. The operands for four triples
! have thus been redefined in a more standard way.
!
! GETPTR    X1 is now (ptype of passed)<<16! DIMENSION
!           Opnd2 is either a 32 bit const with the size (ACC) as value or
!           the ptr or arrayhead as normal operand.
!
! VMY       X1 is now dim<<28!maxdim<<24!array name(where known)
!           Opnd2 is either a 32 bit const with DV offset into const area or
!           the arrayhead as a standard operand
!
! AINDX     X1 is ELSIZE<<20 !spare
!           Opnd2 is arrayhead as standard operand
!           NOTE:- The Operands have been swopped for consistency with norm.
!
! BADJ      X1 is arrayptype<<16!no of Dimensions (latter in case of backward dvs)
!           Opnd2 exactly as for VMY
!

%include "hostcodes.inc"

%CONST %INTEGER HOST=DRS
%CONST %INTEGER TARGET=PENTIUM
%conststring(1) assemblerprefix=";"
%constinteger CGinC=no
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd. All Rights Reserved.
!
!************************************************************************
!*                                                                      *
!*                                                    G.E.Millard       *
!*   ECODES28                                         09/2/88          *
!*                                                                      *
!************************************************************************
!
{00} %constinteger      HALT =   0
!
!--------------------------------------- generic int operations -------
!
{01} %constinteger      IADD =   1     { (Etos-1) + (Etos) => (Etos)   }
{02} %constinteger      ISUB =   2     { (Etos-1) - (Etos) => (Etos)   }
{03} %constinteger     IMULT =   3     { (Etos-1) * (Etos) => (Etos)   }
{04} %constinteger      IDIV =   4     { (Etos-1) / (Etos) => (Etos)   }
{05} %constinteger      INEG =   5     {          - (Etos) => (Etos)   }
{06} %constinteger      IABS =   6     {     abs( (Etos) ) => (Etos)   }
{07} %constinteger      IREM =   7     { remainder from                }
                                       {  (Etos-1) / (Etos)=> (Etos)   }
!
{08} %constinteger      IAND =   8     { (Etos-1) & (Etos) => (Etos)   }
{09} %constinteger       IOR =   9     { (Etos-1) ! (Etos) => (Etos)   }
{0A} %constinteger      INOT =  10     {          ~ (Etos) => (Etos)   }
{0B} %constinteger      IXOR =  11     { (Etos-1) !! (Etos) => (Etos)  }
{0C} %constinteger     ISHLL =  12     { (Etos-1) << (Etos) => (Etos)  }
{0D} %constinteger     ISHRL =  13     { (Etos-1) >> (Etos) => (Etos)  }
{0E} %constinteger     ISHLA =  14     { arithmetic left shift         }
{0F} %constinteger     ISHRA =  15     { arithmetic right shift        }
!
{10} %constinteger       IGT =  16     { if                            }
{11} %constinteger       ILT =  17     {    (Etos-1) <relop> (Etos)    }
{12} %constinteger       IEQ =  18     { then                          }
{13} %constinteger       INE =  19     {    true  (1) => (Etos)        }
{14} %constinteger       IGE =  20     { else                          }
{15} %constinteger       ILE =  21     {    false (0) => (Etos)        }
{16} %constinteger       BNOT=  22     {  (Etos) = BNOT (Etos) 0<->1   }
!
{18} %constinteger      JIGT =  24     { if                            }
{19} %constinteger      JILT =  25     {    (Etos-1) <relop> (Etos)    }
{1A} %constinteger      JIEQ =  26     { then                          }
{1B} %constinteger      JINE =  27     {    -> <label>                 }
{1C} %constinteger      JIGE =  28     { else                          }
{1D} %constinteger      JILE =  29     {    continue                   }
!
{1E} %constinteger    JINTGZ =  30     { if (Etos) > 0 %then -> <lab>  }
{1F} %constinteger    JINTLZ =  31     { if (Etos) < 0 %then -> <lab>  }
{20} %constinteger     JINTZ =  32     { if (Etos) = 0 %then -> <lab>  }
{21} %constinteger    JINTNZ =  33     { if (Etos) # 0 %then -> <lab>  }
{22} %constinteger   JINTGEZ =  34     { if (Etos) >=0 %then -> <lab>  }
{23} %constinteger   JINTLEZ =  35     { if (Etos) <=0 %then -> <lab>  }
! 
{24} %constinteger      ITWB =  36     { if (Etos) < 0 then -> <lab1>  } 
                                       {           = 0 then -> <lab2>  }
                                       {           > 0 then -> <lab3>  }
!
!--------------------------------------- miscellaneous operations------
!
{26} %constinteger      JUMP =  38     { -> <label>                    }
{29} %constinteger       SFA =  41     { SF => (Etos)                  }
{2A} %constinteger    RETURN =  42     { procedure exit                }
{2B} %constinteger      ASF  =  43     { SF = SF + (Etos)              }
!
{2C} %constinteger     IPUSH =  44     { (Etos) => (Mstack)            }
{2D} %constinteger      IPOP =  45     { (Mstack) => (Etos)            }
{2E} %constinteger      EXCH =  46     { (Etos-1) <=> (Etos)           }
{2F} %constinteger      DUPL =  47     { replicate (Etos)              }
{30} %constinteger   DISCARD =  48     { discard (Etos)                }
!
{33} %constinteger    INDEX1 =  51     { (@ Etos-1) + (Etos)           }
                                       {               => (@ Etos)     }
{34} %constinteger    INDEX2 =  52     { (@ Etos-1) + (Etos)*2         }
                                       {               => (@ Etos)     }
{35} %constinteger    INDEX4 =  53     { (@ Etos-1) + (Etos)*4         }
                                       {               => (@ Etos)     }
{36} %constinteger    INDEX8 =  54     { (@ Etos-1) + (Etos)*8         }
                                       {               => (@ Etos)     }
{37} %constinteger     INDEX =  55     { (@ Etos-2)                    }
                                       {     + (Etos-1)*(Etos)         }
                                       {               => (@ Etos)     }
!
{38} %constinteger       MVB =  56     { move (Etos) bytes             }
                                       {  ((@ Etos-2)) => ((@ Etos-1)) }
!
{39} %constinteger       CHK =  57     { check that                    }
                                       { (Etos-1)<=(Etos-2)<=(Etos)    }
                                       { (Etos-2) => (Etos)            }
!
{3A} %constinteger     TMASK =  58     { (Etos-1) & (Etos)             }
                                       { - to be followed by JI[N]Z    }
{3B} %constinteger       MVW =  59     { move (Etos) words - aligned   }
                                       {  ((@ Etos-2)) => ((@ Etos-1)) }
{3C} %constinteger     EZERO =  60     { (Etos) bytes at ((@ Etos-1))=0}
!
{3E} %constinteger     CPBGT =  62     { if (Etos) bytes               }
{3F} %constinteger     CPBLT =  63     {  ((Etos-2)) <relop> ((Etos-1))}
{40} %constinteger     CPBEQ =  64     { then                          }
{41} %constinteger     CPBNE =  65     {    true  (1) => (Etos)        }
{42} %constinteger     CPBGE =  66     { else                          }
{43} %constinteger     CPBLE =  67     {    false (0) => (Etos)        }
{44} %constinteger    EMAKED =  68     { (Etos) = (Etos)<<32 ! (Etos-1)}
                                       {  64bit    32bit        32bit  }
{45} %constinteger   ESPLITD =  69     { (Etos) => (Etos)   ,  (Etos-1)}
!
!-------------------------------------- generic unsigned operations ---
!
{4D} %constinteger     UMULT=  77      { unsigned mult                 }
{4E} %constinteger     UREM =  78      { remainder - unsigned op       }
{4F} %constinteger     UDIV =  79      { (Etos-1) / (Etos) => (Etos)   }
{50} %constinteger     UADD =  80      { (Etos-1) + (Etos) => (Etos)   }
{51} %constinteger     USUB =  81      { (Etos-1) - (Etos) => (Etos)   }

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

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

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

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

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

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

{C4} %constinteger   ARGPROC = 196    { call formal procedure in (Etos)}
{C5} %constinteger PUSHBYTES = 197    { push (Etos) bytes from         }
                                      { (@etos-1) as value parameter   }
{C6} %constinteger    EAUXSF = 198    { AUXSF => (ETOS)                }
{C7} %constinteger   EAUXADD = 199    { AUXSF = AUXSF + (ETOS)         }
{C8} %constinteger   EAUXRES = 200    { AUXSF = (ETOS)                 }
{C9} %constinteger   EOLDLNB = 201    { stack LNB needed for diags     }
{CA} %constinteger     EFILL = 202    {fill (ETOS-1) bytes at (ETOS-2) with (ETOS) }
{CB} %constinteger     ECDUP = 203    {temp! next ..ST to restack val  }
{CD} %constinteger    EMCHIP = 205    { apply chip fn (ETOS) to arg (ETOS-1) }
!
{F4} %constinteger WHEREMASK = 244  { (Etos) is where mask expression}
{F5} %constinteger  WHERELSE = 245    { ELSEWHERE                      } 
{F6} %constinteger     VELOG = 246    { eval comparison to logical     } 
{F7} %constinteger   WHEREST = 247    { WHERE start  (ETOS) = mask     } 
{F8} %constinteger   WHEREND = 248    { WHERE end                      } 
{F9} %constinteger     VSEQR = 249    { SEQ real etos=start,etos-1=inc; sv inc!}
{FA} %constinteger     VSEQI = 250    { SEQ int etos=start,etos-1=inc; sv inc!}
{FB} %constinteger     VMASK = 251    { (ETOS) is logical mask }
{FC} %constinteger   VIMAGPT = 252    { (ETOS,complex) => (ETOS,imag part)}
{FD} %constinteger   VREALPT = 253    { (ETOS,complex) => (ETOS,real part)}
{FE} %constinteger    VSTART = 254    { start of vector loop           }
                                      { (Etos) = no. of elements       }
{FF} %constinteger    VEND   = 255    { end of vector loop             }
!
!***********************************************************************
!*                                                                     *
!*         Fortran specific codes                                      *
!*                                                                     *
!***********************************************************************
!
%constinteger CXADD       = 257       { ((Etos-3)) = ((Etos-2))        }
%constinteger CXSUB       = 258       {                      op        }
%constinteger CXMULT      = 259       {                      ((Etos-1))}
%constinteger CXDIV       = 260       { (Etos) = variant<<8 ! sizecode }

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

%constinteger CALLTPLATE  = 299       { not used                       }
%constinteger NOTEIORES   = 300       { preserve io fn result(no stack change) }
%constinteger STKIORES    = 301       { restack io fn result           }

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

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

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

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

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

%constinteger EINCR       = 308       { equiv to IADDST                }
%constinteger EDECR       = 309       { equiv to ISUBST                }
%constinteger ELOADB      = 310       { breg = (Etos)                  }
%constinteger ESTOREB     = 311       { (Etos) = breg                  }
%constinteger EINCRB      = 312       { breg = breg + (Etos)           }
%constinteger EDECRB      = 313       { breg = breg - (Etos)           }
%constinteger EDINIT      = 314       { not used                       }
%constinteger ELSHIFT     = 315       { (Etos) = (Etos-1) << (Etos)    }
%constinteger ERSHIFT     = 316       { (Etos) = (Etos-1) >> (Etos)    }
%constinteger EADJL       = 317       { char((Etos-3),(Etos-2))        }
                                      {   = leftjustify                }
                                      {      (char((Etos-1),(Etos)))   }
%constinteger EADJR       = 318       { char((Etos-3),(Etos-2))        }
                                      {   = rightjustify               }
                                      {      (char((Etos-1),(Etos)))   }
%constinteger EVERIFY     = 319       { char1 = verify (char2,char3)   }
%constinteger ECXRES      = 320       { NP special for cx results      }
%constinteger ERBIT       = 321       { (Etos) = bit (Etos-1) in (Etos) }
%constinteger EWBIT       = 322       { bit(Etos-1) in (Etos) = (Etos-2)}
%constinteger EMSTORE     = 323       { array = scalar                 }
                                      { (Etos) copies of (Etos-2)      }
                                      {               at (Etos-1)      }
%constinteger ALLTEMP     = 324       { allocate array temp on stack   }
                                      { (Etos) is size in bytes        }
                                      { ((Etos-1)) is dope vector(dv)  }
                                      {  (dv+4) = addr(temp)           }
                                      {    (dv) = (dv) + addr(temp)    }
%constinteger ALLRES      = 325       { allocate array temp on stack   }
                                      { (Etos) is size in bytes        }
                                      { ((Etos-1)) is dope vector(dv)  }
                                      {    (dv) = addr(temp)           }
                                      { (dv+12) = (dv+12) + addr(temp) }
%constinteger MANTEMPS    = 326       { (Etos) = 1  save stackfront    }
                                      {                  in (Etos-1)   }
                                      {        = 2  restore stackfront }
                                      {                from (Etos-1)   }
%constinteger ALLARR      = 327       { allocate user array on stack   }
                                      { (Etos) is size in bytes        }
                                      { ((Etos-1)) is dope vector(dv)  }
                                      {  (dv+4) = addr(temp)           }
                                      {    (dv) = (dv) + addr(temp)    }
%constinteger DEALLARR    = 328       { deallocate user array on stack }
                                      { (Etos) is dope vector          }
                                      { (dv)=0                         }
%constinteger EMSTOREA    = 329       { array = scalar                 }
                                      { (Etos) copies of (Etos-2) bytes}
                                      {               at (Etos-3)      }
                                      {               to (Etos-1)      }
%constinteger CXCVT       = 330       {    reg = ((Etos-1))            }
                                      { (Etos) = variant<<8            }
                                      {            ! sizecode(RHS)<<2  }
                                      {              ! sizecode(LHS)   }
!
!{************************************************************************}
!{***** 		   Pascal specific codes                    ******}
!{************************************************************************}
!*
!* { string operations }
!*
%constinteger STRGT = 511             { if                             }
%constinteger STRLT = 512             {    (Etos-1) <relop> (Etos)     }
%constinteger STREQ = 513             { then                           }
%constinteger STRNE = 514             {    1 => (Etos)                 }
%constinteger STRGE = 515             { else                           }
%constinteger STRLE = 516             {    0 => (Etos)                 }
!*
!* { pointer operations }
!*
%constinteger PTREQ = 520             { if                             }
%constinteger PTRNE = 521             {    (Etos-1) <relop> (Etos)     }
                                      {    (Etos-1) <relop> (Etos)     }
                                      { then                           }
                                      {   1 => (Etos)                  }
                                      { else                           }
                                      {   0 => (Etos)                  }
!*
!* { integer operations }
!*
%constinteger PIMOD = 525             { (Etos-1) mod (Etos) => (Etos)  }
!*
!* { set operations }
!*
%constinteger SETI   = 530            {  (Etos-1) * (Etos) => (Etos)   }
%constinteger SETU   = 531            {  (Etos-1) + (Etos) => (Etos)   }
%constinteger SETD   = 532            {  (Etos-1) - (Etos) => (Etos)   }
!*
%constinteger SETLE  = 533            {  if                            }
%constinteger SETEQ  = 534            {     (Etos-1) <relop> (Etos)    }
%constinteger SETNE  = 535            {  then                          }
%constinteger SETIN  = 536            {     1 => (Etos)                }
                                      {  else                          }
                                      {     0 => (Etos)                }
!*
%constinteger SETSING   = 537         {  [(Etos)] => (Etos)            }
%constinteger SETRANGE  = 538         {  [(Etos-1)..(Etos)] => (Etos)  }
%constinteger SETEMPTY  = 539         {  []                 => (Etos)  }
!*
!* { array operations }
!*
%constinteger PASSBPB   = 546         {  push (Etos-3)..(Etos) as bpb  }
%constinteger CAPMOVE   = 547         {  move (Etos-1) bytes from      }
                                      {  ((@ Etos-2)) => ((@ Etos))    }
%constinteger INDEXP    = 548         {  construct packed field        }
                                      {  descriptor from               }
                                      {  (@ Etos-2)- array base        }
                                      {  (Etos-1)  - index value       }
                                      {  (Etos)    - elements per word }
!*
!* { file and i/o operations }
!* 
%constinteger EOFOPT    = 558
%constinteger EOFOP     = 559         { if                             }
%constinteger EOLOP     = 560         {    fn((@ Etos))                }
                                      { then                           }
                                      {    1 => (Etos)                 }
                                      { else                           }
                                      {    0 => (Etos)                 }
%constinteger LAZYOP    = 574         { fn((@ Etos)) => (Etos)         }
!*
!* { Standard integer procedures }
!*
%constinteger ISQR      = 601         {  fn(Etos)   => (Etos)          }
%constinteger IODD      = 602         {  fn(Etos)   => (Etos)          } 
%constinteger ISUCC     = 603         {  (Etos) + 1 => (Etos)          }
%constinteger IPRED     = 604         {  (Etos) - 1 => (Etos)          }
%constinteger UODD      = 605         {  fn(Etos)   => (Etos)          }
%constinteger USUCC     = 606         {  (Etos) + 1 => (Etos)          }
%constinteger UPRED     = 607         {  (Etos) - 1 => (Etos)          }
!*
!* { Standard real procedures }
!*
%constinteger RSQR      = 611         {  fn(Etos)   => (Etos)          }
%constinteger CHKLN     = 612         {  if (Etos) <= 0.0 trap(33)     }
%constinteger CHKSQRT   = 613         {  if (Etos) < 0.0  trap(34)     }
!*
!* { Error handling operation }
!*
%constinteger PERROR    = 615         {  call error routine (Etos)     }
!*
!* { Integer range-checking operations }
!*
%constinteger CHKLT     = 620         {  if                            }
%constinteger CHKGT     = 621         {    (Etos-2) <relop> (Etos-1)   }
%constinteger CHKNE     = 629         {  then                          }
                                      {    trap((Etos))                }
                                      {  else                          }
                                      {    (Etos-2) => (Etos)          }
%constinteger CHKRNG    = 622         {  if                            }
                                      {    (Etos-3) < (Etos-2) or      }
                                      {    (Etos-3) > (Etos-1)         }
                                      {  then                          }
                                      {    trap((Etos))                }
                                      {  else                          }
                                      {    [(Etos-3)] => [(Etos)]      }
!*
!* { Set range-checking operations }
!*
%constinteger CHKSETGT  = 623         {  if                            }
                                      {    max([(Etos-2)]) > (Etos-1)  }
                                      {  then                          }
                                      {    trap((Etos))                }
                                      {  else                          }
                                      {    (Etos-2) => (Etos)          }
%constinteger CHKSETRNG = 624         {  if                            }
                                      {    min([(Etos-3)]) < (Etos-2)  }
                                      {  or                            }
                                      {    max([Etos-3)]) > (Etos-1)   }
                                      {  then                          }
                                      {    trap((Etos))                }
                                      {  else                          }
                                      {    [(Etos-3)] => [(Etos)]      }
!*
!* { Unsigned range-checking operations }
!*
%constinteger UCHKLT    = 625         {  if                            }
%constinteger UCHKGT    = 626         {    (Etos-2) <relop> (Etos-1)   }
%constinteger UCHKNE    = 627         {  then                          }
                                      {    trap((Etos))                }
                                      {  else                          }
                                      {    (Etos-2) => (Etos)          }
%constinteger UCHKRNG   = 628         {  if                            }
                                      {    (Etos-3) < (Etos-2) or      }
                                      {    (Etos-3) > (Etos-1)         }
                                      {  then                          }
                                      {    trap((Etos))                }
                                      {  else                          }
                                      {    [(Etos-3)] => [(Etos)]      }

!*
!* { Other checking operations }
!*
%constinteger CHKNEW2  	= 630         {  if                            }
                                      {    ((@ Etos)-2) <> 0           }
                                      {  then                          }
                                      {    trap(325)                   }
%constinteger CHKUNDEF  = 631         {  if  (Etos) undefined          }
                                      {  then trap(343)                }
%constinteger SETUNDEF  = 632         {  ((@ Etos)) <- undefined       }
%constinteger TRAP      = 633         {  trap((Etos))                  }
%constinteger CHKPTR    = 634         {  if (Etos)=undefined Trap(343) }
                                      {  if (Etos)=nil Trap(344)       }
%constinteger CHKIOVF   = 635         {  if int overflow(Etos) Trap(347)}
%constinteger CHKROVF   = 636         {  if rl overflow(Etos) Trap     }
%constinteger CHKRI     = 637         {  if abs(Etos)>maxint Trap(Etos)}
%constinteger CHKFN     = 638         {  if (Etos) Undefined Trap(348) }
%constinteger TRAPOVF   = 639         {  enable arithmetic exceptions  }
!*
!*
!* { Auxiliary stack support }
!*
%constinteger PAUXSF    = 640;        {  PAUXSF => (Etos)              }
%constinteger PAUXADD   = 641;        {  PAUXSF + (Etos) => PAUXSF     }
%constinteger PAUXRES   = 642;        {  (Etos) => PAUXSF              }
!*
!* { ICL Standard operations }
!*
%constinteger ICLWPTR   = 644;        {  addr(Etos) => (Etos)          }
%constinteger ICLCPTR   = 645;        {  byteaddr(Etos) => (Etos)      }
!
!*************************************************************************
!*            C specific opcodes                                         *
!*************************************************************************
!
%constinteger     LOGNEG = 768        { 0 => 1;   #0 => 0               }
%constinteger     LOGVAL = 769        { 0 => 0;  #0 => 1     (in r1)    }
%constinteger     LOGSTK = 770        { r1 => etos                      }
%constinteger    ECSTORE = 771        { struct((Etos)) = struct((Etos-1))    }
%constinteger ECPROCCALL = 772        { call proc through pointer (Etos)     }
%constinteger   EPUSHSTR = 773        { struct((Etos-1)) size(Etos) to stack }
%constinteger    ELDBITS = 774        { (Etos) = bit field from (Etos-2)}
                                      { size   (Etos) bits              }
                                      { offset (Etos-1) bits            }
%constinteger    ESTBITS = 775        { bit field in (Etos) = (Etos-3)  }
                                      { size   (Etos-1) bits            }
                                      { offset (Etos-2) bits            }
%constinteger     UADDST = 776        { unsigned add to store           }
%constinteger     USUBST = 777        { unsigned sub from store         }
%constinteger    UMULTST = 778        { unsigned mult to store          }
%constinteger     RADDST = 780        { ((Etos-1)) = (Etos-1) + (Etos)  }
%constinteger     RSUBST = 781        { ((Etos-1)) = (Etos-1) - (Etos)  }
%constinteger    RMULTST = 782        { ((Etos-1)) = (Etos-1) * (Etos)  }
%constinteger     RDIVST = 783        { ((Etos-1)) = (Etos-1) / (Etos)  }
%constinteger     ISHLST = 784        { ((Etos-1)) = (Etos-1) << (Etos) }
%constinteger     ISHRST = 785        { ((Etos-1)) = (Etos-1) >> (Etos) }
%constinteger      CEVAL = 786        { force load of (Etos)            }
%constinteger     ECSAVE = 787        { replicate (Etos) and save copy  }
%constinteger  ECRESTORE = 788        { recover saved operand (FIFO)    }
%constinteger    ISHRAST = 789        { shift right arith to store      }
%constinteger    CJFALSE = 790        { JFALSE with freeregs            }
!
!
! FIRST THE OPERAND FLAG CONSTANTS
!
%CONSTINTEGER SCONST=0;                 ! CONST UPTO 64 BITS value is carried
                                        ! in opnd_d and opnd_xtra
%CONSTINTEGER LCONST=1;                 ! CONST LONGER THAN SCONST const can be
                                        ! found elsewhere(at top of ar) by
                                        ! meanse of base&offset inf in_d and _xtra
%CONSTINTEGER DNAME=2;                  ! NAME BY DICTIONARY NO the base and disp in
                                        ! the dictionary after adjusting by
                                        ! possible offset for item in
                                        ! in records lead to the variable
%CONSTINTEGER ARNAME=3;                 ! NAME BY AR POINTER opnd_d the ar pointer
                                        ! this form local to pass2
                                        ! and used to identify functions
                                        ! with params before the call
                                        ! is planted
%CONSTINTEGER VIAPTR=4;                 ! VIA TRIPLE WITHOFFSET TO POINTER
                                        ! At an offset(_xtra) from address in
                                        ! referenced triple can be found a
                                        ! pointer to the required operand
%CONSTINTEGER INDNAME=5;                ! INDIRECT VIA DICTIONARY base&disp
                                        ! in dictionary identify a pointer
                                        ! variable at possible offset from
                                        ! this pointer
%CONSTINTEGER INDIRECT=6;               ! INDIRECT VIA TRIPLE WITH OFFSET
                                        ! the refenced triple has computed
                                        ! the (32bit) address of an item
                                        ! an offset may have to be applied
                                        ! before the fetch or store
%CONSTINTEGER LOCALIR=7;                ! BASE DISP REF IN CURRENT STACK FRAME
                                        ! opnd_b=base<<16!offset used only for
                                        ! compiler generated temporaries
%CONSTINTEGER REFTRIP=8;                ! REFERENCE TO A TRIPLE the operand is the result of 
                                        ! triple opnd_d
%CONSTINTEGER INAREG=9;                 ! REGISTER OPERAND this form is local to the
                                        ! code generating pass(es)
%CONSTINTEGER developped=10;            ! also local to generator
%CONSTINTEGER DEVADDR=11;               ! ALSO LOCAL TO GENERATOR
%CONSTINTEGER BTREFMASK=1<<REFTRIP!1<<INDIRECT!1<<VIAPTR
%CONSTINTEGER REFER NEEDED=1<<INDIRECT!1<<VIAPTR
!
! NOW THE DEFINITIONS OF ONE OPERAND TRIPLES <128
!
%CONSTINTEGER RTHD=1;                   ! ROUTINE-BLOCK HEADING
%CONSTINTEGER RDSPY=2;                  ! ROUTINE ENTRY SET DISPLAY
%CONSTINTEGER RDAREA=3;                 ! ROUTINE LEAVE DIAGNOSTIC SPACE
%CONSTINTEGER RDPTR=4;                  ! SET DIAGNOSTIC POINTER
%CONSTINTEGER RTBAD=5;                  ! ROUTINE-FN BAD EXIT
%CONSTINTEGER RTXIT=6;                  ! "%RETURN"
%CONSTINTEGER XSTOP=7;                  ! EXECUTE "%STO"
%CONSTINTEGER NOTL=10;                  ! LOGICAL NOT
%CONSTINTEGER LNEG=11;                  ! LOGICAL NEGATE
%CONSTINTEGER IFLOAT=12;                ! CONVERT INTEGER TO REAL
%CONSTINTEGER MODULUS=13;               ! AS USED BY IMOD&RMOD
%CONSTINTEGER SHRTN=14;                 ! SHORTEN TO LOWER PRECISION
%CONSTINTEGER LNGTHN=15;                ! LENGTHEN TO HIGHER PRECISION
%CONSTINTEGER JAMSHRTN=16;              ! SHORTEN FOR JAM TRANSFER
%CONSTINTEGER NULLT=18;                 ! FOR REDUNDANT TRIPLES
%CONSTINTEGER PRELOAD=19;               ! PREFETCH FOR OPTIMISATION REASONS
%CONSTINTEGER SSPTR=21;                 ! STORE STACK POINTER
%CONSTINTEGER RSPTR=22;                 ! RESTORE STACK POINTER
%CONSTINTEGER ASPTR=23;                 ! ADVANCE STACK PTR
%CONSTINTEGER DARRAY=24;                ! DECLARE ARRAY(IE STORE HD)
%CONSTINTEGER SLINE=25;                 ! UPDATE LINE NO
%CONSTINTEGER STPCK=26;                 ! CHECK FOR ZERO STEPS
%CONSTINTEGER FORPRE=27;                ! PREAMBLE FOR "FOR"
%CONSTINTEGER FORPOST=28;               ! POSTAMBLE FOR "FOR"
%CONSTINTEGER FORPR2=29;                ! FOR SECOND PREAMBLE
%CONSTINTEGER PRECL=30;                 ! PREPARATION FOR CALL
%CONSTINTEGER RCALL=31;                 ! THE CALL
%CONSTINTEGER RCRFR=32;                 ! RECOVER FN RESULT
%CONSTINTEGER RCRMR=33;                 ! RECOVER MAP RESULT
%CONSTINTEGER GETAD=35;                 ! GET ADDRESS OF NAME
%CONSTINTEGER RTOI1=36;                 ! REAL TO INTEGER AS INT
%CONSTINTEGER RTOI2=37;                 ! REAL TO INTEGER INTPT
%CONSTINTEGER ITOS1=38;                 ! INTEGER TO STRING AS TOSTRING
%CONSTINTEGER MNITR=39;                 ! %MONITOR
%CONSTINTEGER PPROF=40;                 ! PRINT PROFILE
%CONSTINTEGER RTFP=41;                  ! TURN RT INTO FORMAL PARAMETER
%CONSTINTEGER ONEV1=42;                 ! ON EVENT 1 PRIOR TO TRAP
%CONSTINTEGER ONEV2=43;                 ! ON EVENT 2 AFTER TRAP
%CONSTINTEGER DVSTT=44;                 ! START OF DOPE VECTOR
%CONSTINTEGER DVEND=45;                 ! END OF DV EVALUATE TOTSIZE ETC
%CONSTINTEGER FOREND=46;                ! END OF FOR LOOP
%CONSTINTEGER DMASS=47;                 ! assign via bim warning to opt only
%CONSTINTEGER RTOI3=48;                 ! real to integer as TRUNC
!
! CODES FOR USER WRITTEN ASSEMBLER. NATURALLY THESE ARE NOT
! MACHINE INDEPENDENT
!
%CONSTINTEGER UCNOP=50;                 ! FOR CNOPS
%CONSTINTEGER UCB1=51;                  ! ONE BYTE OPERATIONS
%CONSTINTEGER UCB2=52;                  ! FOR 2 BYTE OPERATIONE
%CONSTINTEGER UCB3=53;                  ! FOR 3 BYTE OPERATIONS
%CONSTINTEGER UCW=54;                   ! FOR WORD OPERATIONS
%CONSTINTEGER UCBW=55;                  ! FOR OPC,BYTEWORD OPERATIONE
%CONSTINTEGER UCWW=56;                  ! FOR OPC,WORD,WORD OPERAIONS
%CONSTINTEGER UCLW=57;                  ! FOR LONGWORD OPERATIONS
%CONSTINTEGER UCB2W=58;                 ! FOR OPC,B1,B2,WORD OPERATIONS
%CONSTINTEGER UCNAM=59;                 ! FOR ACESS TO NAMES FROM ASSEMBLER
!
! NOW THE BINARY OPERATIONS
!
%CONSTINTEGER ADD=128;                  ! ADDITION
%CONSTINTEGER SUB=129;                  ! SUBTRACTION
%CONSTINTEGER NONEQ=130;                ! INTEGER NONEQUIVALENCE
%CONSTINTEGER ORL=131;                  ! LOGICAL OR
%CONSTINTEGER MULT=132;                 ! MULTIPLICATION
%CONSTINTEGER INTDIV=133;               ! INTEGER DIVISION
%CONSTINTEGER REALDIV=134;              ! REAL DIVISION
%CONSTINTEGER ANDL=135;                 ! LOGICAL AND
%CONSTINTEGER RSHIFT=136;               ! LOGICAL RIGHT SHIFT
%CONSTINTEGER LSHIFT=137;               ! LOGICAL LEFT SHIFT
%CONSTINTEGER REXP=138;                 ! REAL EXPONENTIATION
%CONSTINTEGER COMP=139;                 ! COMPARISONS
%CONSTINTEGER DCOMP=140;                ! FIRST PART OF DSIDED(NEEDED?)
%CONSTINTEGER VMY=141;                  ! VECTOR MULTIPLY
%CONSTINTEGER COMB=142;                 ! COMBINE (IE ADD OF LA) ON VMY RESULTS
%CONSTINTEGER VASS=143;                 ! VARAIABLE ASSIGN WITH CHECKING
%CONSTINTEGER VJASS=144;                ! VARIABLE JAMMED ASSIGN
%CONSTINTEGER IEXP=145;                 ! INTEGER EXPONENTIAITION
%CONSTINTEGER BADJ=146;                 ! BASE ADJUST ARRAY INDEX
%CONSTINTEGER AINDX=147;                ! INDEX ARRAY(COMBINE BS&IX)
%CONSTINTEGER IFETCH=148;               ! NO LONGER USED
%CONSTINTEGER LASS=149;                 ! ASSIGN LOCAL TEMPORARY
%CONSTINTEGER FORCK=150;                ! VALIDATE FOR
%CONSTINTEGER PRECC=151;                ! PRELIMINARY CONNCATENATION
%CONSTINTEGER CONCAT=152;               ! CONCATENATION
%CONSTINTEGER IOCPC=153;                ! CALL IOCP
%CONSTINTEGER PASS1=154;                ! PRIMARY PARAMETER ASSIGNMENT
%CONSTINTEGER PASS2=155;                ! PARAMETER PASSING POINTER PARAMS
%CONSTINTEGER PASS3=156;                ! PARAMETERPASSING ARRAY PARAMETERS
%CONSTINTEGER PASS4=157;                ! PASS A FORMAL PROCEDURE
%CONSTINTEGER PASS5=158;                ! PASS AN UNTYPE(%NAME) PARAMETER
%CONSTINTEGER PASS6=159;                ! PASS STRFN OR RECFN RESULT AREA
%CONSTINTEGER BJUMP=160;                ! BACKWARDS JUMPS
%CONSTINTEGER FJUMP=161;                ! FORWARD JUMPS
%CONSTINTEGER REMLB=162;                ! REMOVE LAB FROM LABELIST
                                        ! NEEDS TO BE TRIPLE IF COMBINED
                                        ! LABEL LIST IS USED
%CONSTINTEGER TLAB=163;                 ! TO ENTER A LABEL
%CONSTINTEGER DCLSW=164;                ! DECLARE A SWITCH ARRAY
%CONSTINTEGER SETSW=165;                ! SET A SWITCH TO "CA"
%CONSTINTEGER GOTOSW=166;               ! GO TO A SWITCH LABEL
%CONSTINTEGER STRASS1=167;              ! STRING GENERAL ASSIGNMET
%CONSTINTEGER STRASS2=168;              ! STRING FIXED LENGTH ASSNMENT
%CONSTINTEGER STRJT=169;                ! STRING JAM TRANSFER
%CONSTINTEGER AHASS=170;                ! ASSIGNMENT OF ARRAYHEADS
%CONSTINTEGER PTRAS=171;                ! ASSIGNMENT OF POINTERS
%CONSTINTEGER MAPRES=172;               ! ASSIGN MAPPING FN RESULT
%CONSTINTEGER FNRES=173;                ! ASSIGN FN RESULT
%CONSTINTEGER SCOMP=174;                ! STRING COMPARISON
%CONSTINTEGER SDCMP=175;                ! FIRST PART OF STRING D-SIDED
%CONSTINTEGER PRES1=176;                ! PRE RESOLUTION 1
%CONSTINTEGER PRES2=177;                ! PRE RESOLUTION 2
%CONSTINTEGER RESLN=178;                ! STRING RESOLUTION
%CONSTINTEGER RESFN=179;                ! RESOLUTION FINALE
%CONSTINTEGER SIGEV=180;                ! SIGNAL EVENT
%CONSTINTEGER RECASS=181;               ! WHOLE RECORD ASSIGNMENT
%CONSTINTEGER AAINC=182;                ! ARRAY ADDRESS ADJUST FOR
                                        ! RECORD RELATIVE TO ABSOLUTE
%CONSTINTEGER AHADJ=183;                ! MODIFY HEAD FOR MAPPING
%CONSTINTEGER CTGEN=184;                ! CREATE TYPE GENERAL PARAMETER
%CONSTINTEGER GETPTR=185;               ! POINTER FOR PASSING BY NAME
%CONSTINTEGER SINDX=186;                ! INDEX STRING IE CHARNO
                                        ! SAME AS AINDX FOR ALL TARGETS
                                        ! BUT PNX !
%CONSTINTEGER ZCOMP=187;                ! COMPARISONS WITH ZERO
                                        ! GENERATED BY OPTIMISER
%CONSTINTEGER CLSHIFT=188;              ! CONSTANT LOGICAL SHIFT
                                        ! GENERATED BY OPTIMISER
%CONSTINTEGER CASHIFT=189;              ! CONSTANT ARITHMETIC SHIFT
                                        ! GENERATED BYOPTIMISER
%CONSTINTEGER DVBPR=190;                ! GENERATE DV ENTRY FOR BOUND PAIR
%CONSTINTEGER RSTORE=191;               ! REGISTER TO STORE OPERATION
%CONSTINTEGER MULTX=192;                ! MULTIPLY AND EXTEND PRECISION
!
! RECORDFORMAT FOR ALL THE OPTION AND FLAG VARAIBLES
!
! amended to remove non-alined longreal prior to bootstrapping to gould
!
%RECORDFORMAT PARMF(%INTEGER BITS1,BITS2,TTOPUT,
      %BYTEINTEGER LET,DYNAMIC,LINE,TRACE,ARR,DBUG,CHK,DIAG,OPT,FREE,
      LIST,CPRMODE,COMPILER,Z,Y,PROF,INHCODE,DCOMP,FAULTY,X,STACK,MAP,QUOTES,S2,
      %INTEGER LPOPUT,SP0)
%RECORDFORMAT LEVELF(%INTEGER RBASE, DIAGINF, RAL, FLAG, L, M, NMDECS, ONWORD, ONINF,
         LABEL, JROUND, UNATT FORMATS, PSIZE, ENTRYAD, DISPLAY, AUXSBASE, 
         NAMES, SNMAX,SN,RESSIZE,CLEVEL,SET, MAXPP, EXITLAB, CONTLAB, S3,
       %INTEGERARRAY AVL WSP(0:4))

%IF 1<<host&unsignedshorts=0 %START
%RECORDFORMAT RD((%INTEGER S1 %OR %SHORT PTYPE,%BYTE XB,FLAG),
      ((%INTEGER D %OR %REAL R),
      %INTEGER XTRA %OR %SHORT H0,H1,H2,H3 %OR %BYTE B0,B1,B2,B3,B4,B5,B6,B7))
%RECORDFORMAT TAGF((%SHORTINTEGER PTYPE,UIOJ,SNDISP,ACC,SLINK,KFORM %OR %C
      %INTEGER S1,S2,S3),%INTEGER LINK)
%RECORDFORMAT TRIPF(%BYTE OPERN,OPTYPE,CNT,DPTH,
      %SHORTINTEGER FLAGS,PUSE,FLINK,BLINK,%INTEGER X1,
      %RECORD(RD) OPND1,OPND2)
%RECORDFORMAT LISTF((%SHORTINTEGER PTYPE,(%SHORT UIOJ %OR %BYTE XB,FLAG),
      %SHORT SNDISP,ACC,SLINK,KFORM %OR  %INTEGER S1,S2,S3),%INTEGER LINK)
%FINISH %ELSE %START
%RECORDFORMAT RD((%INTEGER S1 %OR %HALF PTYPE,%BYTE XB,FLAG),
      ((%INTEGER D %OR %REAL R),
      %INTEGER XTRA %OR %HALF H0,H1,H2,H3 %OR %BYTE B0,B1,B2,B3,B4,B5,B6,B7))
%RECORDFORMAT TAGF((%HALFINTEGER PTYPE,UIOJ,SNDISP,ACC,SLINK,KFORM %OR %C
      %INTEGER S1,S2,S3),%INTEGER LINK)
%RECORDFORMAT TRIPF(%BYTE OPERN,OPTYPE,CNT,DPTH,
      %HALFINTEGER FLAGS,PUSE,FLINK,BLINK,%INTEGER X1,
      %RECORD(RD) OPND1,OPND2)
%RECORDFORMAT LISTF((%HALFINTEGER PTYPE,(%HALF UIOJ %OR %BYTE XB,FLAG),
      %HALF SNDISP,ACC,SLINK,KFORM %OR  %INTEGER S1,S2,S3),%INTEGER LINK)
%FINISH
%RECORDFORMAT WORKAF(%INTEGER NNAMES,CCSIZE,DSIZE,ASL MAX,ASL CUR BTM,CONST PTR,
      CONST BTM,LASTTRIP,WKFILEAD,WKFILEK,FILE ADDR,RELEASE,AASL0,CONST LIMIT,
      RTCOUNT,ARTOP,AMAINEP,DICTBASE,OPTCNT,INCLHEAD,S2,S3,S4,
      %INTEGERNAME LINE,N,S5,%STRING(9)LADATE,
      %BYTEINTEGERARRAYNAME CC,A,LETT,
      %INTEGERARRAYNAME WORD,TAGS,CTABLE,
      %RECORD(LEVELF)%ARRAYNAME LEVELINF,
      %INTEGERARRAY PLABS,PLINK(0:31),
      %RECORD(LISTF)%ARRAYNAME ASLIST)
!
! TRIPF_FLAGS SIGNIFY AS FOLLOWS
%CONSTINTEGER LEAVE STACKED=2****0;     ! SET LEAVE RESULT IN ESTACK
%CONSTINTEGER LOADOP1=2****1;           ! OPERAND 1 NEEDS LOADING
%CONSTINTEGER LOADOP2=2****2;           ! OPERAND 2 NEEDS LOADING
%CONSTINTEGER NOTINREG=2****3;          ! PREVENT REG OPTIMISNG
                                        ! OF TEMPS OVER LOOPS&JUMPS
%CONSTINTEGER USE ESTACK=2****4;        ! KEEP DUPLICATE IN ESTACK
%CONSTINTEGER USE MSTACK=2****5;        ! PUT DUPLICAT ON MSTACK
%CONSTINTEGER CONSTANTOP=2****6;        ! ONE OPERAND IS CONSTANT(FOR FOLDING)
%CONSTINTEGER COMMUTABLE=2****7;        ! OPERATION IS COMMUTABLE
%CONSTINTEGER BSTRUCT=2****12;          ! Proc contains inner blks or RTs
%CONSTINTEGER USED LATE=2****13;        ! I-RESULT USED AFTER LAB OR A LONG WAY AHEAD
%CONSTINTEGER ASS LEVEL=2****14;        ! ASSEMBLER LEVEL OPERATION
%CONSTINTEGER DONT OPT=2****15;         ! DONT DUPLICATE THIS RESULT
                                        ! USED FOR BYTE PTR & OTHER SODS!
!
%RECORDFORMAT EMASFHDRF(%INTEGER ENDRA,STARTRA,FBYTESIZE,W3,W4,W5,W6,W7)
                                        ! FORMAT FOR ARRAY HEADS
! %END %OF  %FILE "ERCC07.TRIMP_TFORM1S"
%CONST %INTEGER ESTK=0
%OWN %INTEGER profgla,profzgst;          ! OFFSETS FOR PROFILING DATA
%OWN %INTEGER GLACABUF,GLABEL,FPPTR,FPHEAD,SWAPMODE
%OWN %INTEGER %NAME CA,GLACA
%OWN %INTEGER %ARRAY %NAME CTABLE,TAGS,WORD
%OWN %BYTE %INTEGER %ARRAY %NAME lett
%OWN %RECORD (LISTF) %ARRAY %NAME ASLIST
%OWN %RECORD (LEVELF) %NAME WORKINGINF
      %EXTRINSIC %INTEGER %ARRAY CAS(0:12)
%EXTRINSIC %RECORD (WORKAF) WORKA
%EXTRINSIC %RECORD (PARMF) PARM
%CONST %INTEGER MAXREG=4
%EXTERNAL %ROUTINE %SPEC FLAGAND FOLD(%RECORD (TRIPF) %ARRAY %NAME T)
%EXTERNAL %ROUTINE %SPEC FAULT(%INTEGER I,J,K)
%EXTERNAL %ROUTINE %SPEC Einitialise(%INTEGER Lang,Aver,Astackca,Aglaca,options)
%EXTERNAL %ROUTINE %SPEC Eterminate(%INTEGER adareasizes)
%EXTERNAL %ROUTINE %SPEC Elinestart(%INTEGER lineno)
%EXTERNAL %ROUTINE %SPEC Elinedecode
%EXTERNAL %INTEGER %FN %SPEC Estkmarker
%EXTERNAL %ROUTINE %SPEC Esetmarker(%INTEGER Markerid,New Value)
%EXTERNAL %INTEGER %FN %SPEC Eswapmode
%EXTERNAL %ROUTINE %SPEC Emonon
%EXTERNAL %ROUTINE %SPEC Emonoff
%EXTERNAL %ROUTINE %SPEC Efaulty
%EXTERNAL %ROUTINE %SPEC Estklit(%INTEGER Val)
%EXTERNAL %ROUTINE %SPEC Estkconst(%INTEGER Len,Ad)
%EXTERNAL %ROUTINE %SPEC Estkrconst(%INTEGER Len,Ad)
%EXTERNAL %ROUTINE %SPEC Estkdir(%INTEGER Area,Offset,Adid,Bytes)
%EXTERNAL %ROUTINE %SPEC Estkind(%INTEGER Area,Offset,Adid,Bytes)
%EXTERNAL %ROUTINE %SPEC Estkglobal(%INTEGER Level,Offset,Adid,Bytes)
!%EXTERNAL %ROUTINE %SPEC Estkgind(%INTEGER Level,Offset,Adid,Bytes)
%EXTERNAL %ROUTINE %SPEC Estkpar(%INTEGER Level,Offset,Adid,Bytes)
%EXTERNAL %ROUTINE %SPEC Estkparind(%INTEGER Level,Offset,Adid,Bytes)
%EXTERNAL %ROUTINE %SPEC Estkresult(%INTEGER Class,Type,Bytes)
%EXTERNAL %ROUTINE %SPEC Erefer(%INTEGER Offset,Bytes)
%EXTERNAL %ROUTINE %SPEC Epromote(%INTEGER Level)
%EXTERNAL %ROUTINE %SPEC Edemote(%INTEGER Level)
%EXTERNAL %ROUTINE %SPEC Estkaddr(%INTEGER Area,Offset,Adid,Bytes)
%EXTERNAL %ROUTINE %SPEC Estkgaddr(%INTEGER Level,Offset,Adid,Bytes)
%EXTERNAL %ROUTINE %SPEC Estkpaddr(%INTEGER Level,Offset,Adid,Bytes)
%EXTERNAL %ROUTINE %SPEC Elabel(%INTEGER Id)
%EXTERNAL %ROUTINESPEC Eglabel(%integer Labid,Level,Glaoffset)
!%EXTERNAL %ROUTINE %SPEC Ediscardlabel(%INTEGER Id)
%EXTERNAL %ROUTINE %SPEC Euchecklab(%INTEGER Labid)
%EXTERNAL %ROUTINE %SPEC Eboundlab(%INTEGER Labid)
%EXTERNAL %ROUTINE %SPEC Ejump(%INTEGER Opcode,Labelid)
%EXTERNAL %ROUTINE %SPEC Eswitch(%INTEGER Lower,Upper,Switchid,Errlabid,
   %INTEGER %NAME SSTAD)
%EXTERNAL %ROUTINE %SPEC EswitchJump(%INTEGER Switchid)
%EXTERNAL %ROUTINE %SPEC Eswitchentry(%INTEGER Switchid,Entry)
%EXTERNAL %ROUTINE %SPEC Eswitchdef(%INTEGER Switchid)
%EXTERNAL %ROUTINE %SPEC EswitchLabel(%INTEGER Switchid,Entry,Labelid)
%EXTERNAL %ROUTINE %SPEC Ed1(%INTEGER area,Disp,Val)
%EXTERNAL %ROUTINE %SPEC Ed2(%INTEGER area,Disp,Val)
%EXTERNAL %ROUTINE %SPEC Ed4(%INTEGER area,Disp,Val)
%EXTERNAL %ROUTINE %SPEC Edbits(%INTEGER area,Disp,Bitoffset,Numbits,Val)
%EXTERNAL %ROUTINE %SPEC Edbytes(%INTEGER area,Disp,len,ad)
%EXTERNAL %ROUTINE %SPEC Edpattern(%INTEGER area,Disp,ncopies,len,ad)
%EXTERNAL %ROUTINE %SPEC Efix(%INTEGER area,disp,tgtarea,tgtdisp)
%if CGinC=NO %start
   %EXTERNAL %INTEGER %FN %SPEC Enextproc2(%string(255)%name s,%integer flags)
   %EXTERNAL %ROUTINE %SPEC Eproc2(%STRING %NAME Name, %INTEGER Props,Aparprops,
      %INTEGER %NAME ID)
   %EXTERNAL %ROUTINE %SPEC Edataentry(%INTEGER Area,Offset,Length, %STRING %NAME Name)
   %EXTERNAL %INTEGER %FN %SPEC EXname(%INTEGER type, %STRING (255) %NAME Xref)
   %EXTERNAL %ROUTINE %SPEC Edataref(%INTEGER Area,Offset,Length, %STRING %NAME Name)
%else
   %EXTERNAL %INTEGER %FN %SPEC Enextproc2(%integer Adcstring,%integer flags)
   %EXTERNAL %ROUTINE %SPEC Eproc2(%integer Adcstring, %INTEGER Props,Aparprops,
      %INTEGER %NAME ID)
   %EXTERNAL %ROUTINE %SPEC Edataentry(%INTEGER Area,Offset,Length, %integer Adcstring)
   %EXTERNAL %INTEGER %FN %SPEC EXname(%INTEGER type,%integer Adcstring)
   %EXTERNAL %ROUTINE %SPEC Edataref(%INTEGER Area,Offset,Length, %integer Adcstring)
%finish
%EXTERNAL %ROUTINE %SPEC Eprecall2(%INTEGER Id,aparprops)
%EXTERNAL %ROUTINE %SPEC Ecall2(%INTEGER Id,Extlev,Numpars,Paramsize)
%EXTERNAL %ROUTINE %SPEC Eprocref(%INTEGER Id,Level)
%EXTERNAL %ROUTINE %SPEC Eprocend(%INTEGER Localsize,Diagdisp,Astacklen)
%EXTERNAL %ROUTINE %SPEC Eop(%INTEGER Opcode)
%if target=RS6 %Start
   %externalroutinespec EfrLabel(%integer Lab,Count)
%finish
%CONST %INTEGER MAXKXREF=6
      %OWN %INTEGER %ARRAY KXREFS(0:MAXKXREF)=-1(*)
      %CONST %STRING (7) %ARRAY PLNAME(0:31)="plabs00","plabs01",
                                        "p_cndgs","plabs03","plabs04",
                                        "p_unass","p_swerr","p_exper",
                                        "p_xblks","p_capex","p_nores",
                                        "p_forer","p_reser","p_aberr",
                                        "plabs14","plabs15","p_stres",
                                        "plabs17","p_strjt","plabs19",
                                        "p_iexpn","p_rexpn","p_lrexp",
                                        "plabs23","p_conct","plabs25",
                                        "p_chkbp","plabs27","p_stcmp",
                                        "p_mvbb","plabs30","plabs31"

      %CONST %INTEGER %ARRAY PPJINFO(0:30)=0,0,x'00020005',0(13),
                                        X'02050014'{16 RESLN},
                                        0,x'00030009'{18 STRINGJT},
                                        0(5),X'00020005'{24 CONCAT},
                                        0(3),X'02020005'{28 STRING COMP},
                                        0(*)
                                         ! resflags<<24!naprs<<16!pardes entry
      %CONST %STRING (11) %ARRAY KXREFNAME(0:MAXKXREF)="s#stop","s#ndiag",
                                        "s#ilog","s#iexp","s#iocp",
                                        "icl9ceauxst","s#pprofile"

%CONST %INTEGER paramptr=27
      %OWN %INTEGER %ARRAY pardes(0:127)=0,0             { no parameters},
                              1,4,1<<24!4             {2 one integer param},
                              2,8,1<<24!4(2)          {5 two integer params},
                              3,12,1<<24!4(3)         {9 three integer params},
                              4,16,1<<24!4(4)         {14 four integer params},
                              5,20,1<<24!4(5)         {20 five integer params},
                              0(*)


%EXTERNAL %ROUTINE %SPEC PRINT TRIPS(%RECORD (TRIPF) %ARRAY %NAME T)
%EXTERNAL %ROUTINE %SPEC PRINT THIS TRIP(%RECORD (tripf) %ARRAY %NAME trips, %INTEGER i)
%EXTERNAL %ROUTINE %SPEC POP(%INTEGER %NAME A,B,C,D)
!%EXTERNALROUTINESPEC PRINT LIST(%INTEGER HEAD)
%EXTERNAL %ROUTINE %SPEC PUSH(%INTEGER %NAME A, %INTEGER B,C,D)
%EXTERNAL %ROUTINE %SPEC MOVE BYTES(%INTEGER L,FB,FO,TB,TO)
%INTEGER %FN %SPEC BYTESWOP(%INTEGER VAL)
%ROUTINE %SPEC REFORMATC(%RECORD (RD) %NAME OPND)
%ROUTINE %SPEC CHANGESEX(%INTEGER BASE,OFFSET,L)
%ROUTINE %SPEC PPJ(%INTEGER A,B)
%ROUTINE %SPEC IMPABORT
%EXTERNAL %ROUTINE %SPEC PRHEX(%INTEGER VALUE,PLACES)
%CONST %INTEGER PARAMS BWARDS=yes
%CONST %INTEGER Stack Down=Yes
%externalintegerspec pic %alias "Pic"       { Connect with back end pic flag}
%CONST %INTEGER aux stack=YES
%constinteger strvalinwa=no;            ! string and record values stacked
      %IF Stack Down=Yes %THEN %START
      %CONST %INTEGER Stack Inc=-1
      %ELSE
      %CONST %INTEGER Stack Inc=1
      %FINISH
%CONST %INTEGER longs aligned=no
      %CONST %BYTE %INTEGER %ARRAY BYTES(0:7)=0(3),1,2,4,8,16;
%CONST %INTEGER DAREA=6;                 ! AREA FOR DIAG TABLES
%CONST %INTEGER CAREA=10;                ! AREA FOR CONSTANTS
%CONST %INTEGER zgst=9;                  ! profile area into here
%CONST %INTEGER gla=2
%OWN %INTEGER prevline=0
%OWNINTEGER preassigned TEMPSPACE=0         { For Etemspace when in pro/epilogue}
%constinteger frameredtape=24  {16 for diags + 8 min display }
%CONST %INTEGER P0=-4,L0=-4-frame red tape
%CONST %INTEGER P1=P0+4,P2=P0+2*4,P3=P0+3*4,P4=P0+4*4,P5=P0+5*4,P6=P0+4*6
! Paramtere pffsets
      %IF Stack Down=Yes %THEN %START
      %CONST %INTEGER L1=L0-4*1,L2=L0-4*2,L3=L0-4*3,L4=L0-4*4,L5=L0-4*5,L6=L0-4*6,L7=L0-4*7,L8=L0-4*8,L9=L0-4*9
      %FINISH %ELSE %START
      %CONST %INTEGER L1=L0+4*1,L2=L0+4*2,L3=L0+4*3,L4=L0+4*4,L5=L0+4*5,L6=L0+4*6,L7=L0+4*7,L8=L0+4*8,L9=L0+4*9
      %FINISH
!
! FIXED GLA CURRENTLY USED AS FOLLOWS
!     0-7   FREE(WAS 2900 ENTRY DESCRIPTOR)
!     8-11  ADDRESS OF UNSHARED SYMBOL TABLES
!     12-15 ADDRESS OF SHARED SYMBOL TABLES
!     16-19 LANGUAGE & COMPILER DATA
!     20-23 ADDRESS OF DAREA WHEN DAREA#SST
!     24-27 ADDRESS OF CONSTANT TABLE
!     28-31 ADDRESS OF A WORD CONTAINING STACKTOP  0FOR NO CHECKS
!     32-35 HOLDS M'IDIA' FOR DIAGNOSTIC IDENTIFICATION
!     36-39 FREE
!     40-55 DEFINES THE ENTRY POINT OF MDIAGS
!
%CONST %INTEGER FIXEDGLALEN=56
      %OWN %INTEGER %ARRAY FIXED GLA(0:FIXEDGLALEN>>2-1)=M'IMP ',M'GLAP',
                                        0(6),M'IDIA',0(*)

!
!***********************************************************************
!*       IMP CODE PLANTING ROUTINES                                    *
!*       CODE AND GLAP ARE PUT INTO THE BUFFERS 'CODE,GLABUF(0:268)'   *
!*       BY A NUMBER OF TRIVIAL ROUTINES.QPUT IS CALLED TO ADD THE     *
!*       BUFFER TO THE OUTPUT FILE. THE BUFFERS ARE BASICALLY 0:255    *
!*       WITH A 12-BYTE MARGIN TO MINIMISE THE NUMBER OF TESTS FOR     *
!*       THE BUFFER FULL CONDITION                                     *
!*                                                                     *
!*       PPCURR(GLACURR) IS THE BUFFER POINTER                         *
!*       CA(GLACA)  IS THE RELATIVE ADDRESS OF THE NEXT BYTE           *
!*       CABUF(GLACABUF) IS CA(GLACA) FOR START OF BUFFER              *
!***********************************************************************
!*DELSTART
! temp frig routines
%integerfn Cstring(%string(255) s)
!***********************************************************************
!* returns the address of a cstring equivalent to an imp string        *
!***********************************************************************
%ownstring(255)%array cs(0:7)
%owninteger ind
      ind=(ind+1)&7
      cs(ind)=s.tostring(0)
      %result=addr(cs(ind))+1
%end
%routine Eprocinterface(%STRING %NAME Name, %INTEGER Props,Aparprops,
      %integername id)
!***********************************************************************
!*      An integerface to eproc2                                       *
!***********************************************************************
      %if CGinC=NO %start
         Eproc2(Name,Props,Aparprops,ID)
      %else
         Eproc2(Cstring(Name),Props,Aparprops,ID)
      %finish
%end
%ROUTINE CPINIT
!***********************************************************************
!*    PERFORMS ANY NECESSARY TARGET DEPENDANT INITIALISING             *
!************************************************************************
%STRING (63) HD
%integer j
      HD=" ERCC Ecode IMP80 Compiler Release ".TOSTRING(WORKA_RELEASE)." Version ". %C
         WORKA_LADATE
      j=parm_chk<<8!parm_arr<<9!parm_line<<3! (PIC&3)
      %if Target=PENTIUM %then j=j!x'00010000'
      EINITIALISE(1,ADDR(HD),ADDR(WORKA_LINE)+4 {frig},ADDR(CAS(2)),j)
                                         ! OPEN OBJECT FILE
      TAGS==WORKA_TAGS
      WORD==WORKA_WORD
      LETT==WORKA_LETT
      EMONON %IF PARM_DCOMP#0
      SWAPMODE=ESWAPMODE
      WORKINGINF==WORKA_LEVELINF(1)
%END
%EXTERNAL %ROUTINE CODEOUT
!***********************************************************************
!*    NEEDED TO SATISFY REFERENCE IN PASS2                             *
!***********************************************************************
%END
%EXTERNAL %ROUTINE PDATA(%INTEGER AREA,BNDRY,L,AD)
!***********************************************************************
!*    ADDS L(BYTES) TO AREA FOR UST,SST AND DIAGS AREAS                *
!***********************************************************************
%INTEGER %NAME PTR
      PTR==CAS(AREA)
      PTR=(PTR+BNDRY-1)&(-BNDRY)
      EDBYTES(AREA,PTR,L,AD) %unless area=ZGST
      PTR=PTR+L
%END
%EXTERNAL %ROUTINE PRDATA(%INTEGER AREA,BNDRY,L,REP,AD)
!***********************************************************************
!*    ADDS L(BYTES) REP TIMES TO AREA FOR UST,SST AND DIAGS AREAS      *
!*    DATA ALREADY BYTE SWAPPED BY PASS2                               *
!***********************************************************************
%INTEGER %NAME PTR
      PTR==CAS(AREA)
      PTR=(PTR+BNDRY-1)&(-BNDRY)
      EDPATTERN(AREA,PTR,REP,L,AD) %unless area=ZGST
      PTR=PTR+L*REP
%END
%EXTERNAL %INTEGER %FN PINITOWN(%INTEGER PTYPE,ACC, %RECORD (RD) %NAME INIT,
   %STRING %NAME XNAME)
!***********************************************************************
!*    PUTS AN INITIALISED OWN INTO THE GLA. SHOULD DEAL WITH ALL TYPES *
!*    INIT IS ALREADY BYTE SWAPPED. ACC ETC NORMAL                     *
!*    However strings in the A.R. can not be swopped till the last     *
!*    moment since they can be reused. These are copied&swopped here   *
!***********************************************************************
%RECORD (RD) OPND
%INTEGER PREC,TYPE,RL,RES,LITL,I,J
%STRING (255) IS
      TYPE=PTYPE&7
      PREC=PTYPE>>4&7
      LITL=PTYPE>>14&3
      OPND=INIT
      %IF PTYPE&X'400'#0 %START;         ! OWN NAMES
         GLACA=(GLACA+3)&(-4)
         RES=GLACA
         %IF TYPE=5 %START;              ! OWNSTRINGNAMES
                                         ! HAVE LENGTH @LOW AD END
                                         ! AND ADDR AT HIGH  AD END
                                         ! IN ESTACK LENGTH IS ON TOP
            OPND_XTRA=ACC-1
            ED4(2,RES,BYTESWOP(OPND_XTRA))
            EDBYTES(2,RES+4,4,ADDR(OPND_D))
            GLACA=GLACA+8
         %FINISH %ELSE %START
            EDBYTES(2,RES,4,ADDR(OPND_D))
            GLACA=GLACA+4
         %FINISH
         %IF LITL=3 %START;              ! EXTRINSICS ARE NAMES
            J=RES
            %IF TYPE=5 %THEN J=RES+4
            %if CGinC=NO %start
               EDATAREF(2 {gla},J,ACC,XNAME)
            %else
               EDATAREF(2 {gla},J,ACC,Cstring(XNAME))
            %finish
         %FINISH
         ->END
      %FINISH
      RL=BYTES(PREC)
      %IF TYPE=5 %THEN RL=2
      %IF TYPE=3 %THEN RL=8
      %IF RL>8 %THEN RL=8
      %if longs aligned=No %and rl>4 %then rl=4
      GLACA=(GLACA+RL-1)&(-RL)
      RES=GLACA; GLACA=GLACA+ACC
      %IF TYPE=3 %OR (TYPE=5 %AND OPND_D=0) %START
         EDPATTERN(2,RES,ACC,1,ADDR(OPND_D))
         ->END
      %FINISH
      %IF TYPE=5 %THEN %START
         I=WORKA_A(OPND_D)
         LENGTH(IS)=I
         %FOR I=1,1,I %CYCLE
            CHARNO(IS,I)=WORKA_A(OPND_D+I)
         %REPEAT
         CHANGE SEX(ADDR(IS),0,ACC) %IF HOST#TARGET
         EDPATTERN(2,RES,1,ACC,ADDR(IS)); ! ALLOW FOR ALIGNMENT
      %FINISH %ELSE %START
         %IF PREC=3 %THEN ED1(2,RES,OPND_D&255)
         %IF PREC=4 %THEN ED2(2,RES,OPND_D&x'ffff')
         %IF PREC=5 %THEN EDBYTES(2,RES,4,ADDR(OPND_D))
         %IF PREC=6 %THEN EDBYTES(2,RES,8,ADDR(OPND_D))
         %if prec=7 %then  EDBYTES(2,RES,16,addr(WORKA_A(OPND_D)))
      %FINISH
END:                                     ! NOTE ENTRYT IF EXTERNAL
      %IF LITL=2 %THEN %start
         %if CGinC=NO %start
            EDATAENTRY(2 {GLA},RES,ACC,XNAME)
         %else
            EDATAENTRY(2 {GLA},RES,ACC,Cstring(XNAME))
         %finish
      %finish
      %RESULT=RES
%END
%EXTERNAL %INTEGER %FN POWNARRAYHEAD(%INTEGER PTYPE,J,LB,SIZE,AOFFSET,AAREA,DVOFFSET,
   %STRING (31) XNAME)
!***********************************************************************
!*    SOME PARAMETERS ARE ONLY REQUIRED FOR CREATING DESCRIPORS ON     *
!*    2900 ARCHITECTURE. THESE ARE REDUNDANT HERE                      *
!*    PNX ARRAY HEAD HAS DV PTR AT LOW ADDRESS END AND @A(FIRST) AT    *
!*    THE HIGH ADDRESS END. WHEN IN ESTACK DV PTR IS ON TOP            *
!***********************************************************************
%INTEGER LITL,RES,AHW0,AHW1,HAREA
      AHW0=AOFFSET
      AHW1=DVOFFSET
      %IF HOST#TARGET %START
         AHW0=BYTESWOP(AHW0)
         AHW1=BYTESWOP(AHW1)
      %FINISH
      HAREA=2;                           ! NORMAL GLA
      GLACA=(GLACA+3)&(-4)
      RES=GLACA
      GLACA=GLACA+8
      LITL=PTYPE>>14&3
      EFIX(2,RES,4,DVOFFSET);            ! RELOCATE DV PTR
      %IF LITL=3 %START;                 ! EXTRINSIC ARRAYS
         %if CGinC=NO %start
            EDATAREF(HAREA,RES+4,SIZE,XNAME)
         %else
            EDATAREF(HAREA,RES+4,SIZE,Cstring(XNAME))
         %finish
      %FINISH %ELSE %START
         %IF AAREA=0 %THEN ED4(2,RES+4,AHW0) %ELSE EFIX(HAREA,RES+4,AAREA,AOFFSET)
      %FINISH
      %IF LITL=2 %THEN %start
         %if CGinC=NO %start
            EDATAENTRY(AAREA,AOFFSET,SIZE,XNAME)
         %else
            EDATAENTRY(AAREA,AOFFSET,SIZE,Cstring(XNAME))
         %finish
      %finish
      %RESULT=RES
%END
%EXTERNAL %ROUTINE CXREF(%STRING (255) NAME, %INTEGER MODE,XTRA, %INTEGER %NAME AT)
!***********************************************************************
!*    OBTAIN A REFERENCE NO FOR EXTERNAL PROCEDURES                    *
!*       MODE=0 STATIC CODE XREF                                       *
!*       MODE=1 DYNAMIC CODE XREF                                      *
!***********************************************************************
      %if CGinC=NO %start
         AT=EXNAME(1,NAME)
      %else
         AT=EXNAME(1,Cstring(NAME))
      %finish
%END
%INTEGER %FN KNOWN XREF(%INTEGER N)
!***********************************************************************
!*    RETURNS THE RT NO OF A KNOWN EXTERNAL NAME DEFINING IT ON        *
!*    THE FIRST OCCURRENCE ONLY                                        *
!***********************************************************************
%INTEGER D
%STRING (255) S
      %RESULT=KXREFS(N) %UNLESS KXREFS(N)<0
      S=KXREFNAME(N)
      %if CGinC=NO %start
         D=EXNAME(1,S)
      %else
         D=EXNAME(1,Cstring(S))
      %finish
      KXREFS(N)=D
      %RESULT=D
%END
%ROUTINE CALL STOP
!***********************************************************************
!*    CALLS STOP ROUTINE. NOT VIA EPILOGUE ON PERQ                     *
!***********************************************************************
      EPRECALL2(KNOWN XREF(0),addr(pardes(0)))
      ECALL2(KNOWN XREF(0),1,0,0);       ! S#STOP
%END
%INTEGER %FN EXCHANGE(%RECORD (RD) %NAME OPND1,OPND2)
!***********************************************************************
!*    REVERSES NEST SO OPERAND 1 IS AT TOP FOR FLOATS ETC              *
!*    NO ACTION IF OPND2 IS A CONSTANT                                 *
!***********************************************************************
      %RESULT=0 %UNLESS OPND1_FLAG<=8 %AND OPND1\==OPND2
      %RESULT=0 %UNLESS opnd2_flag>=8 %OR 1<<opnd2_flag&refer needed#0
      EOP(EXCH)
      %RESULT=1
%END
%ROUTINE BULKM(%INTEGER MODE,L,D2)
!***********************************************************************
!*       PLANT CODE TO MOVE L BYTES (L KNOWN AT COMPILE TIME) FROM     *
!*        ETOS-2,ETOS-3 TO ETOS,ETOS-1                                 *
!*       IF MODE =0 SET L BYTES TO D2(0 OR X'80')                      *
!*                                                                     *
!*       L MAY BE GREATER THAN 4095                                    *
!***********************************************************************
%INTEGER W2
      ESTKLIT(L)
      %IF MODE=0 %START;                 ! CLEAR
         ESTKLIT(D2&255)
         EOP(EFILL)
      %ELSE
         EOP(MVB)
      %FINISH
%END;                                    ! OF ROUTINE BULK M
%EXTERNAL %ROUTINE IMPABORT
      PRINTSTRING("
****************      ABORT********************    ABORT    *******")
!*DELSTART
      ELINEDECODE
!*DELEND
      %MONITOR
      %STOP
%END
%EXTERNAL %ROUTINE PROLOGUE(%RECORD (LISTF) %ARRAY %NAME ALIST)
!***********************************************************************
!*       GENERATES THE SUBROUTINE THAT ALWAYS  ARE REQUIRED ONTO THE   *
!*       FRONT OF THE OBJECT PROGRAM WHERE THEY ARE DIRECTLY ADDRESABLE*
!***********************************************************************
%ROUTINE %SPEC ERR EXIT(%INTEGER A,B,C)
%INTEGER I,K,LSIZE
%STRING (31) S
      ASLIST==ALIST
      GLABEL=WORKA_NNAMES+1;             ! FOR GENERATING LABELS
      FPPTR=0
      FPHEAD=0
      CA==CAS(1)
      GLACA==CAS(2)
      GLACA=FIXEDGLALEN
      CPINIT;                            ! INITIALISE CODE PLANTING
      CTABLE==WORKA_CTABLE
      %IF PARM_TRACE#0 %THEN I=X'C2C2C2C2' %AND PDATA(DAREA,4,4,ADDR(I))
      %CYCLE I=0,1,31
         WORKA_PLABS(I)=-1; WORKA_PLINK(I)=0
      %REPEAT
      %CYCLE I=0,1,MAXKXREF
         KXREFS(I)=-1
      %REPEAT
!
! GENERATE THE RUN TIME ERROR ROUTINE :-
! MDIAGS IS %ROUTINE MDIAGS(%INT PC,AP,ERROR,XTRA)
! PC IS A DUMMY EXCEPT AFTER CONTINGENCY
! ON ENTRY TO THIS SUBROUTINE ERROR & XTRA ARE AS PARAMETERS(P1&P2)
!
!     ILP2, IPUSH                       XTRA STACKED
!     ILP1, IPUSH                       ERROR STACKED
!     EOLDLNB                           CURRENT LNB TO ETOS
!     IPUSH                             AND STACKED
!     CI0                               DUMMY CALLING PC
!     IPUSH
!     CALL N                            CALL TO NDIAGS
!     RETURN
!
      K=KNOWN XREF(1);                   ! NDIAG XREF (AS NO ZERO) OBTAINED
      S=PLNAME(2)
      LSIZE=8+frame red tape
      preassigned TEMPSPACE = -LSIZE
      EPROCinterface(S,44,addr(pardes(5)),WORKA_PLABS(2)); ! NO DISPLAY OR LOCALS or inners
      EPRECALL2(K,addr(pardes(14)))
      ESTKPAR(1,p2,0,x'01000004')
      EOP(PUSHVAL) %IF PARAMS BWARDS=YES
      ESTKPAR(1,p1,0,x'01000004')
      EOP(PUSHVAL) %IF PARAMS BWARDS=YES
      EOP(EOLDLNB)
      EOP(PUSHVAL) %IF PARAMS BWARDS=YES
      ESTKLIT(0)
      EOP(PUSHVAL)
      %IF PARAMS Bwards=No %THEN %START
         EOP(PUSHVAL)
         EOP(PUSHVAL)
         EOP(PUSHVAL)
      %FINISH
      ECALL2(K,1,4,16)
      EOP(RETURN);                       ! ONLY NEEDED FOR %MONITOR
      EPROCEND(LSIZE,0,0);               ! 0 BYTES OF LOCALS
!
! SUBROUTINE TO CALL DEBUG ROUTINE(S#IMPMON) LINE NO IN GR0
!
!        STM   4,0,16(11)
!        LM    CODER,EPREG,EPDIST
!        BCR   15,LINKREG               RETURN ADDR ALREADY IN GR15
!
      %IF PARM_DBUG#0 %THEN %START
!         WORKA_PLABS(3)=CA
!         CXREF("S#IMPMON",PARM_DYNAMIC,2,K)
      %FINISH
!
! SUBROUTINE TO ADVANCE STACK FRONT BY ETOS WORDS AND CHECK FOR OFLOW
!
      %IF PARM_OPT=1 %THEN %START;       ! ONLY REQUIRED WITH CHKING
!         WORKA_PLABS(4)=CA
      %FINISH
!
! SOME ERROR ROUTINES
!
!      ERR EXIT(5, X'801', 0) %IF PARM_OPT#0; ! UNASSIGNED VARIABLE
!      ERR EXIT(6,  X'802', 0);              ! SWITCH LABEL UNSET
      ERR EXIT(7,X'505',1);              ! ILLEGEAL EXPONENTIATION
      ERR EXIT(8,X'201',0) %IF PARM_OPT#0; ! EXCESS BLOCKS
      ERR EXIT(9,X'601',0);              ! CAPACITY EXCEEDED
!      ERR EXIT(10,21, 0) ;                  ! NO RESULT
      ERR EXIT(11,X'501',0) %IF PARM_OPT#0; ! CYCLE NOT VALID
      ERR EXIT(12,X'701',0);             ! RES FAILS
      ERR EXIT(13,X'602',0) %IF PARM_OPT#0; ! ARRAY BOUND FAULT
      CTABLE(0)=BYTESWOP(M'CTAB')
      CTABLE(1)=0;                       ! NULL STRING
      WORKA_CONST PTR=2
      WORKA_CONST BTM=WORKA_CONST PTR
      %IF PARM_PROF#0 %THEN %START;      ! ALLOCATE PROFILE COUNT AREA
         profgla=glaca; glaca=glaca+8
         Ed4(gla,profgla,worka_line)
         Ed4(gla,profgla+4,0)
         profzgst=CAS(zgst)
         Efix(Gla,profgla+4,Zgst,profzgst)
         CAS(zgst)=profzgst+4+worka_line*4
      %FINISH
!      %IF parm_opt#0 %START
         Eboundlab(Glabel)
         Elabel(Glabel)
         Glabel=Glabel+1
         PPJ(15,13)
!      %FINISH
      %IF PARM_Chk#0 %START
         Euchecklab(Glabel)
         Elabel(Glabel)
         Glabel=Glabel+1
         Eprecall2(Worka_plabs(2),addr(pardes(14)))
         Estklit(0)
         Estklit(X'801')
         %IF PARAMS Bwards=Yes %THEN EOP(EXCH)
         Eop(Pushval); Eop(Pushval)
         Ecall2(Worka_Plabs(2),1,2,8)
      %FINISH
      ELINESTART(1);                     ! FOR PNX DEBUGGER
      preassigned TEMPSPACE=0
      %RETURN
%ROUTINE ERR EXIT(%INTEGER LAB,ERRNO,MODE)
!***********************************************************************
!*       MODE=0 FOR DUMMY(ZERO) XTRA - MODE=1 XTRA IN GR1              *
!***********************************************************************
%INTEGER J
%STRING (31) S
      S=PLNAME(LAB)
      LSIZE=8+frame red tape
      preassigned TEMPSPACE = -LSIZE
      EPROCinterface(S,44,addr(pardes(0)),WORKA_PLABS(LAB)); ! NO DISPLAY OR LOCALS REQD
      Eprecall2(Worka_plabs(2),addr(pardes(14)))
      EOP(Eoldlnb)
      ESTKLIT(ERRNO)
      %IF PARAMS Bwards=Yes %THEN EOP(EXCH)
      EOP(PUSHVAL)
      EOP(PUSHVAL)
      ECALL2(WORKA_PLABS(2),1,0,8)
      EPROCEND(LSIZE,0,0)
%END
%END
%EXTERNAL %ROUTINE EPILOGUE(%INTEGER STMTS)
!***********************************************************************
!*       PLANT ANY SUBROUINES THAT HAVE BEEN REQUIRED DURING           *
!*       THE CODE GENERATION PHASE                                     *
!***********************************************************************
%ROUTINE %SPEC FILL(%INTEGER LAB)
%INTEGER LSIZE
      %IF PARAMS Bwards=No %THEN %START
      %INTEGER p1,p2,p3,p4,p5
      %FINISH
      ELINESTART(9999);                  ! PSEUDO LINE NO
!
! STRING RESOLUTION ROUTINE (ENTERED BY CALL)
!     P5    = ADDRESS OF STRING BEING RESOLVED
!     P4    = ADDR OF (ORIGINAL LENGTH! BYTES USED UP<<16)
!     P3    = LMAXOF FRAGMENT HOLING STRING(=0 NO SUCH STRING)
!     P2    = ADDRESS OF FRAGMENT STRING
!     P1    = ADDRESS OF RESOLUTION STRING(CONVERTED TO BYTE FORM ON ENTRY)
!     END OF PARAMETER
!     L1    = LOCAL COPY OF BYTES USED UP
!     L2    = LENGTH OF RESOLUTION STRING
!     L3    = NO OF POSSIBLE VAILD COMPARISONS
!     L4    = COMPARISON LOOP CONTROL OF FORM 1,1,L3
!     L5    = COPY OF ORIGNAL LHS LENGTH
!     L6&7  = NOT USED (WAS WORK VARIABLES IN CH COMPARE LOOP)
!     L8    = BYTE POINTER TO FIRST RELEVANT BYTE OF RESTRING
!
!
! STAGE 1 INITIALISE LOOP CONTROL AND WORK OUT THE NO OF VALID
! COMPARISONS AND STORE IN L3
!
!     CI1 ISL4                          INITIALISE CONTROL
!     LDW ((P4)), CI255, IAND           COPY BYTES IN ORIGINAL STRING
!     DUPL, ISLL5                       AND SAVED IN LOCAL
!     LDW ((P4)), CI16, ISHRL
!     DUPL, ISL1                        COPY OF BYTES USED UP
!     ISUB                              BYTES LEFT OF LHS
!     LDB ((P1)), DUPL, ISL2            CURRENT LENGTH OF RESLN STRING
!     JINTZ <RESOK (L5)>                  RESOLVING ON NULL STRING
!     ILL2, ISUB                        0 LENGTH DIFF =1 VALID COMP
!     CI1, IADD, DUPL, ISL3             MAX NO OF VALID COMPARISONS
!     JINTLEZ <RESFAIL (L4)>              NOT ENOUGH LEFT OF LHS
!     ILP5, ILL1, IADD, ISL8
!
! STAGE 2 CYCLE ROUND WITH BYTEARRAY COMPARISONS TO LOCATE STRING
!
!OUTERLOOP(L0):                         REPITIONS TO HERE
!     ILP1, CI1, IADD,                  SET BYTE PTR TO RESOLUTION
!     ILL8, ILL4, IADD,                 POINTER TO RIGHT BYTE IN LHS
!     ILL2, CPBEQ                       TEST FOR EQUALITY
!     JTRUE <RESOK (L5)>                 ALL FOUND WITH NO NONEQIVALENCE
!                                       THIS COMPARISON FAILS
!                                       ADVANCE DOWN BY ONE
!     ILL4, CI1, IADD, DUPL, ISL4       INCREMENT CONTROL
!     ILL3, JILE<OUTER LOOP (L0)>       AND CONTINUE
!
!RESFAIL(L4):                           RESOLUTION HAS FAILED
!     CI0, RETURN                       EXIT WITH FALSE SET
!RESOK(L5):                             RESOLUTION HAS WORKED
!!     ILP3, JINTZ <NOSTORE (L6)>          FRAGMENT TO BE DISCARDED
!
! CONTROL(L4) IS NO OF BYTES TO BE STORED (IE L+1) OF FRAGMENT
! FIRST COPY IN BYTES + RUBBISH LENGTH THEN OVERWRITE
! WITH CORRECT LENGTH
!
!     ILL8                              SOURCE PTR
!     ILP2                              DEST POINTER
!     ILL4                              BYTES TO MOVE
!                                       ASSIGN POSSIBLY OVERLAPPING
!     MVB                               ASSIGN OK IF OVERLAPPED
!     ILL4, CI1, ISUB                   FRAGMENT LENGTH
!     DUPL, STB ((P2))                  STORED WITH PTR
!     ILP3, JILE <NOSTORE (L6)>         CHECK FOR CAP EXCEED
!     CALL PLABS9                       AND FAIL IF SO
!!NOSTORE(L6):                           ENTERS HERE IF FRAGMENT IS DISCARDED
!     ILL1,ILL2,IADD,ILL4,IADD          RECALCULATE BYTES USED UP
!     CI1, ISUB, CI16, ISHLL
!     ILL5, IOR, STW((P4))              AND STORE VIA HALFWORD PTR
!     CI1, RETURN                       EXIT WITH RESULT=TRUE
!
!
! These routine were coded for Unix type backwards parameters
! For forward paramters alter the offsets rathe than recode
                                         !
      %IF PARAMS Bwards=No %THEN %START



         P5=p0+4; P4=P0+8; P3=P0+12; P2=P0+16; P1=P0+20
      %FINISH
      %IF WORKA_PLINK(16)=0 %THEN ->P17
      LSIZE=40+ frame red tape
      preassigned TEMPSPACE = -LSIZE
      FILL(16)
      ESTKLIT(1)
      ESTKDIR(0,L4,0,X'01000004')
      EOP(ESTORE)
      ESTKPARIND(1 {lev},P4,0,x'01000004' {word}); ! ldw ((p4)
      ESTKLIT(255); EOP(IAND)
      ESTKDIR(0,L5,0,X'01000004')
      EOP(EDUPSTORE)
      ESTKPARIND(1,P4,0,x'01000004');    ! ldw ((p4)
      ESTKLIT(16); EOP(ISHRL)
      ESTKDIR(0,L1,0,X'01000004')
      EOP(EDUPSTORE)
      EOP(ISUB)
      ESTKPARIND(1,P1,0,x'03000001' {byte})
      ESTKDIR(0,L2,0,X'01000004')
      EOP(EDUPSTORE)
      EJUMP(JINTZ,GLABEL+5)
      ESTKDIR(0,L2,0,X'01000004')
      EOP(ISUB)
      ESTKLIT(1)
      EOP(IADD)
      ESTKDIR(0,L3,0,X'01000004')
      EOP(EDUPSTORE)
      EJUMP(JINTLEZ,GLABEL+4)
      ESTKPAR(1,P5,0,x'01000004')
      ESTKDIR(0,L1,0,X'01000004')
      EOP(IADD)
      ESTKDIR(0,L8,0,X'01000004')
      EOP(ESTORE)
! THIS IS "OUTERLOOP"
      ELABEL(GLABEL)
      ESTKPAR(1,P1,0,x'01000004')
      ESTKLIT(1)
      EOP(IADD)
      ESTKDIR(0,L8,0,X'01000004')
      ESTKDIR(0,L4,0,X'01000004')
      EOP(IADD)
      ESTKDIR(0,L2,0,X'01000004')
      EOP(CPBEQ)
      EJUMP(JTRUE,GLABEL+5)
      ESTKDIR(0,L4,0,X'01000004')
      ESTKLIT(1)
      EOP(IADD)
      ESTKDIR(0,L4,0,X'01000004')
      EOP(EDUPSTORE)
      ESTKDIR(0,L3,0,X'01000004')
      EJUMP(JILE,GLABEL)
! THIS IS "RESFAIL"
      ELABEL(GLABEL+4)
      ESTKLIT(0)
      EOP(EINTRES)
      EOP(RETURN)
! THIS IS "RESOK"
      ELABEL(GLABEL+5)
      ESTKPAR(1,P3,0,x'01000004')
      EJUMP(JINTZ,GLABEL+6)
      ESTKDIR(0,L8,0,X'01000004')
      ESTKPAR(1,P2,0,x'01000004')
      ESTKDIR(0,L4,0,X'01000004')
      EOP(MVB)
      ESTKDIR(0,L4,0,X'01000004')
      ESTKLIT(1)
      EOP(ISUB);
      ESTKPAR(1,P2,0,x'01000004')
      EREFER(0,x'03000001')
      EOP(EDUPSTORE)
      ESTKPAR(1,P3,0,x'01000004')
      EJUMP(JILE,GLABEL+6)
      EPRECALL2(WORKA_PLABS(9),addr(pardes(0)))
      ECALL2(WORKA_PLABS(9),1,0,0)
! THIS IS "NOSTORE"
      ELABEL(GLABEL+6)
      ESTKDIR(0,L1,0,X'01000004')
      ESTKDIR(0,L2,0,X'01000004')
      EOP(IADD)
      ESTKDIR(0,L4,0,X'01000004')
      EOP(IADD)
      ESTKLIT(1)
      EOP(ISUB)
      ESTKLIT(16)
      EOP(ISHLL)
      ESTKDIR(0,L5,0,X'01000004')
      EOP(IOR)
      ESTKPARIND(1,P4,0,x'01000004' {pointer})
      EOP(ESTORE)
      ESTKLIT(1)
      EOP(EINTRES)
      EOP(RETURN)
      EPROCEND(LSIZE,0,0)
      GLABEL=GLABEL+7
P17:
!
! EVALUATE X**Y
! ******** ****
! Y IS IN FR0 AND X IS AT TOP OF STACK
! EVENT 5/5 IS SIGNALLED IF X<0 OR (X=0 AND Y<=0)
! OTHERWISE RESULT=EXP(Y*LOG(Y))
!
!        ST    15,12(WSPR)              SAVE LINK
!        BALR  1,0
!        LTDR  0,0
!        BC    4,PLAB7
!        BC    7,20(1)
!        LD    2,0(WSPR)
!        LTDR  2,2
!        BC    12,PLAB7
!        LA    WSPR,16(WSPR)            PROTECT X AND RETURN ADD
!        STD   0,64(WSPR)               PARAMETER X TO LOG
!        STM   4,14,16(WSPR)            SAVE ENVIRONMENT
!        LM    CODER,EPREG,LOGEPDISP
!        BALR  LINKREG,EPREG
!        LA 0,16
!        SR    WSPR,0
!        MD    0,0(WSPR)
!        STD   0,64(WSPR)               Y*LOG(X) TO EXP
!        STM   4,14,16(WSPR)
!        LGR   LINKREG,12(WSPR)
!        LM    CODER,EPREG,EXPEPDISP
!        BCR   15,LINKREG               RETURNS DIRECT TO PROGRAM
!
      %IF WORKA_PLINK(17)=0 %THEN ->P18
      FILL(17)
!         %IF LOGEPDISP=0 %THEN CXREF("S#ILOG",0,2,LOGEPDISP)
!         %IF EXPEPDISP=0 %THEN CXREF("S#IEXP",0,2,EXPEPDISP)
P18:
!
! STRING JAM TRANSFER ENTERED BY CALL WITH 5 PARAMS
!     P2 = VIRT (WORD) ADDR OF SOURCE
!     P2 =  MAX LENGTH OF DEST
!     P1 = VIRT (WORD) ADDR OF DEST
!     L1 =  LOCAL THE ACTUAL STRING BYTES TO BE MOVED
!
!     ILP2, LBI, DUPL, ISL1             LENGTH OF SOURCE
!     ILP2, JILE <L0>                   NO TRUNCATION
!     ILP2, ISL1                        TRUNCATED LENGTH
!L0:  ILP2
!     ILP1, ILL1
!     CI1, IADD,                        MOVE LBYTES + LENGTH BYTE
!     MVB
!     ILL1, ILP1, ASSB                  AND OVERWRITE LENGTH
!     RETURN
!
      %IF PARAMS Bwards=No %THEN %START
         P3=P0+4; P2=P0+8; P1=P0+12
      %FINISH
      %IF WORKA_PLINK(18)=0 %THEN ->P19
      LSIZE=16+ frame red tape
      preassigned TEMPSPACE = -LSIZE
      FILL(18)
      ESTKPAR(1,P3,0,x'01000004')
      EREFER(0,x'03000001')
      ESTKDIR(0,L1,0,X'01000004')
      EOP(EDUPSTORE)
      ESTKPAR(1,P2,0,x'01000004')
      EJUMP(JILE,GLABEL)
      ESTKPAR(1,P2,0,x'01000004')
      ESTKDIR(0,L1,0,X'01000004')
      EOP(ESTORE)
      ELABEL(GLABEL)
      ESTKPAR(1,P3,0,x'01000004')
      ESTKPAR(1,P1,0,x'01000004')
      ESTKDIR(0,L1,0,X'01000004')
      ESTKLIT(1)
      EOP(IADD)
      EOP(MVB)
      ESTKDIR(0,L1,0,X'01000004')
      ESTKPAR(1,P1,0,x'01000004')
      EREFER(0,x'03000001')
      EOP(ESTORE)
      EOP(RETURN)
      EPROCEND(LSIZE,0,0)
      GLABEL=GLABEL+1
P19:
!     called subroutine to evaluate i****4
!
!      %IF WORKA_PLINK(19)=0 %THEN ->P20;! ROUTINE NOT USED
!P20:
!     called subroutine to evaluate i****N ( I 32 BITS)
!      N OVER I IN ESTACK NO C PARAMETERS
!     IN LINE CODE USED AS NO JLK INSTRUCTION
      %IF WORKA_PLINK(20)=0 %THEN ->P21; ! ROUTINE NOT USED
      FILL(20)
      EPROCEND(8,0,0)
      GLABEL=GLABEL+5
P21:
!     called subroutine to evaluate X**N ( X 32 BITS)
!     In-line code now genererated for this
!P22:
!     called subroutine to evaluate X**N ( X 64 BITS)
!     IN LINE CODE NOW USED
!
!P23:
!
! STRING PRE-CONCATENATION SUBROUTINE
! NOT USED ON PNX ALL DONE AT P24
!
!P24:
!
! STRING CONCATENATION SUBROUTINE
!     MUST LEAVE NO RUBBISH IN ESTACK IN CASE LHS DEST IN NEST
!
!     P2 HAS WORD ADDRESS OF NEXT BIT
!     P1 HAS WORD ADDRESS OF WORKAREA CONTAINING PREVIOUS BITS
!     L1 HAS BYTE LENGTH OF P2
!     L2 HAS BYTE LENGTH OF P1
!
!     ILP2, DUPL, LBI, DUPL
!     ISL1, EXCH, CI1, IADD, EXCH       LENGTH OF MOVE OVER SOURCE
!     ILP1, DUPL, LBI, DUPL
!     ISL2, IADD, CI1, IADD
!     EXCH, MVB                         STRINGS JOINED
!     ILL1, ILL2, IADD, ILP1
!     ASSB,
!     RETURN
!
      %IF PARAMS Bwards=No %THEN %START
         P2=P0+4; P1=P0+8
      %FINISH
      %IF WORKA_PLINK(24)=0 %THEN ->P25
      LSIZE=16+ frame red tape
      preassigned TEMPSPACE = -LSIZE
      FILL(24)
      ESTKPAR(1,P2,0,x'01000004')
      EOP(DUPL)
      EREFER(0,x'03000001')
      estklit(4)
      eop(cvtui)
      ESTKDIR(0,L1,0,X'01000004')
      EOP(EDUPSTORE)
      EOP(EXCH)
      ESTKLIT(1)
      EOP(IADD); EOP(EXCH)
      ESTKPAR(1,P1,0,x'01000004')
      EOP(DUPL)
      EREFER(0,x'03000001')
      estklit(4)
      eop(cvtui)
      ESTKDIR(0,L2,0,X'01000004')
      EOP(EDUPSTORE)
      EOP(IADD)
      ESTKLIT(1)
      EOP(IADD)
      EOP(EXCH)
      EOP(MVB)
      ESTKDIR(0,L1,0,X'01000004')
      ESTKDIR(0,L2,0,X'01000004')
      EOP(IADD)
      ESTKPAR(1,P1,0,x'01000004')
      EREFER(0,x'03000001')
      EOP(ESTORE)
      EOP(RETURN)
      EPROCEND(LSIZE,0,0)
P25:
!
! CHECK ARRAY BOUND WITH 16 BIT INDEX
!     NO RELEVANCE TO PNX
!P26:
!
! CHECK ARRAY BOUND WITH 32 BIT INDEX
!     NOW DONE IN LINE WITH CHK INSTR
!P27:
! REDUCE LONG BYTE INDEX
! NOT NEEDED FOR PNX
!
!P28:
! DIFFERENCE IMP STRINGS
! PARAMETERS ARE TWO BYTE ADDRESS AND ROUTINE RETURNS FIRST DIFFERENCE
!
!     P1 HAS FIRST OPERAND (BYTE) ADDRESS
!     P2 HAS SECOND OPERAND ADDRESS
!     L1 HAS FIRST OPERAND CURRENT (BYTE) ADDRESS
!     L2 HAS SECOND OPERAND CURREMT BYTE ADDRESS
!     L3 HAS SHORTER STRING LENGTH
!
!     ILP1 DUPL, CI1 IADD
!     ISL1, LBI, ISL3
!     ILP2, DUPL, CI1, IADD
!     ISL2, LBI, ILL3,
!     JIGE <L0>
!     LDB ((P2)), ISL3                  SHORTER LENGTH SET
!L0:  ILL3, JINTZ <L2>                  ZERO LENGTH WITH NO DIFFERENCE
!     ILL3, CI1, ISUB, ISL3             LENGTH DECREMENTED
!     LDB ((L1)), LDB ((L2))            NEXT TWO CHARS
!     JINE <L1>                         DIFFERENC FOUND
!     ILL2, CI1, IADD, ISL2             UPDATE 2ND POINTER
!     ILL1, CI1, IADD, ISL1             UPDATE 1ST POINTER
!     JUMP <L0>
!L1:                                    RETURN DIFFERENCE OF CHS
!     LDB ((L1)), LDB ((L2)), ISUB, RETURN
!L2:                                    NO DIFFERENCES RETURN LENGTHS
!     LDB ((P1)),LDB ((P2)), ISUB
!     RETURN
!
      %IF WORKA_PLINK(28)=0 %THEN ->P29
      LSIZE=24+ frame red tape
      preassigned TEMPSPACE = -LSIZE
      FILL(28)
      ESTKPAR(1,P1 {P1},0,x'01000004'); EOP(DUPL)
      ESTKLIT(1)
      EOP(IADD)
      ESTKDIR(0,L1,0,X'01000004')
      EOP(ESTORE)
      EREFER(0,x'03000001')
      estklit(4)
      eop(cvtui)
      ESTKDIR(0,L3,0,X'01000004')
      EOP(ESTORE)
      ESTKPAR(1,P2 {P2},0,x'01000004')
      EOP(DUPL)
      ESTKLIT(1)
      EOP(IADD)
      ESTKDIR(0,L2,0,X'01000004')
      EOP(ESTORE)
      EREFER(0,x'03000001')
      estklit(4)
      eop(cvtui)
      ESTKDIR(0,L3,0,X'01000004')
      EJUMP(JIGE,GLABEL)
      ESTKPARIND(1,P2,0,x'03000001' {ldb ((p2))})
      ESTKDIR(0,L3,0,X'01000004')
      EOP(ESTORE)
      ELABEL(GLABEL)
      ESTKDIR(0,L3,0,X'01000004')
      EJUMP(JINTZ,GLABEL+2)
      ESTKDIR(0,L3,0,X'01000004')
      ESTKLIT(1)
      EOP(ISUB)
      ESTKDIR(0,L3,0,X'01000004')
      EOP(ESTORE)
      ESTKIND(0,L1,0,1 {ldb ((L1))})
      ESTKIND(0,L2,0,1 {ldb ((L2))})
      EJUMP(JINE,GLABEL+1)
      ESTKDIR(0,L1 {L1},0,X'01000004')
      ESTKLIT(1)
      EOP(IADD)
      ESTKDIR(0,L1 {L1},0,X'01000004')
      EOP(ESTORE)
      ESTKDIR(0,L2,0,X'01000004')
      ESTKLIT(1)
      EOP(IADD)
      ESTKDIR(0,L2,0,X'01000004')
      EOP(ESTORE)
      EJUMP(JUMP,GLABEL)
      ELABEL(GLABEL+1);                  ! LABEL L1 HERE
      ESTKIND(0,L1,0,1 { ldb((L1))})
      ESTKIND(0,L2,0,1 {ldb ((L2))})
      EOP(ISUB); EOP(EINTRES)
      EOP(RETURN)
      ELABEL(GLABEL+2);                  ! LABEL L2 IS HERE
      ESTKPARIND(1,P1,0,x'03000001' {ldb ((P1))})
      ESTKPARIND(1,P2,0,x'03000001' {ldb ((P2))})
      EOP(ISUB); EOP(EINTRES)
      EOP(RETURN)
      EPROCEND(LSIZE,0,0)
      GLABEL=GLABEL+3
P29:
!
! GENERATE A MOVE BYTES ROUTINE ENTERED BY CALL
! USED IN RESOLUTION FOR POSSIBLY OVERLAPPED MOVES
! NO RELEVANCE TO Emachines MOVE BYTES INTRUCTION ADEQUATE
      %IF WORKA_PLINK(29)=0 %THEN ->P30
      FILL(29)
      EPROCEND(0,0,0)
P30:
      preassigned TEMPSPACE=0
      %IF PARM_DCOMP#0 %THEN PRINTSTRING("
CODE FOR LINE 99999") %AND ELINEDECODE
%BEGIN
!***********************************************************************
!*       PASS INFORMATION TO QPUT TO ENABLE IT TO GENERATE THE         *
!*       LOADER DATA AND COMPLETE THE PROGRAM FILE.                    *
!***********************************************************************
%INTEGER %ARRAY SIZES(0:10)
%ROUTINE %SPEC DUMP CONSTS
%INTEGER LANGFLAG,PARMS,I,K
!         CODE OUT
!         CNOP(0,8)
!         FIXED GLA(6)=CA;               ! CONST TABLE ADDRESS
      %IF PARM_TRACE=0 %THEN LANGFLAG=6 %ELSE LANGFLAG=1
      LANGFLAG=LANGFLAG<<24
      DUMP CONSTS
      PARMS=(PARM_DIAG<<1!PARM_LINE)<<1!PARM_TRACE
      FIXED GLA(4)=LANGFLAG!WORKA_RELEASE<<16!(PARM_CPRMODE&1)<<8!PARMS
                                         ! LANG RLSE & MAINPROG
      FIXED GLA(8)=BYTESWOP(M'IDIA')
      I=GLACA-GLACABUF
      %IF PARM_INHCODE=0 %THEN %START
                                         ! BACK OF GLAP
         EDBYTES(2,28,FIXEDGLALEN-28,ADDR(FIXED GLA(7)))
                                         ! FRONT OF GLAP

                                         ! word 0-6 are standard and set up by ecode
                                         ! on call of initialise from cpinit
         %IF PARM_TRACE#0 %THEN I=X'E2E2E2E2' %AND PDATA(DAREA,4,4,ADDR(I))
      %FINISH
      %CYCLE I=1,1,10
         SIZES(I)=(CAS(I)+7)&(-8)
      %REPEAT
      ETERMINATE(ADDR(SIZES(1)));        ! SUMMARY INFO.
      newline; printstring(assemblerprefix); PRINTSTRING("CODE")
      WRITE(SIZES(1),6)
      %IF SIZES(4)>0 %THEN PRINTSTRING("+") %AND WRITE(SIZES(4),4)
      PRINTSTRING(" BYTES      GLAP")
      WRITE(SIZES(2),3); PRINTSTRING("+")
      WRITE(SIZES(5),1); PRINTSTRING(" BYTES      DIAG TABLES")
      WRITE(SIZES(DAREA),3); PRINTSTRING(" BYTES
 ".assemblerprefix."TOTAL")
      K=SIZES(1)+SIZES(2)+SIZES(4)+SIZES(5)+SIZES(6)
      WRITE(K,5); PRINTSTRING(" BYTES
 ".assemblerprefix)
      %IF PARM_FAULTY=0 %THEN %START
         WRITE(STMTS,7); PRINTSTRING(" STATEMENTS COMPILED")
      %FINISH %ELSE %START
         PRINTSTRING("PROGRAM CONTAINS"); WRITE(PARM_FAULTY,2)
         PRINTSTRING(" FAULT"); PRINTSYMBOL('S') %IF PARM_FAULTY>1
      %FINISH
      NEWLINES(2)
%ROUTINE DUMP CONSTS
%INTEGER I,J,K
      %IF PARM_DCOMP#0 %START
         PRINTSTRING("
Constant Table")
         I=0
         %CYCLE
            NEWLINE
            PRHEX(4*I,5)
            %CYCLE J=0,1,7
               SPACES(2)
               PRHEX(WORKA_CTABLE(I+J),8)
            %REPEAT
            SPACE
            %CYCLE J=0,1,31
               K=ADDR(WORKA_CTABLE(0))+4*I+J
               K=BYTEINTEGER(K)
               %IF K<=31 %OR K>125 %THEN K=32
               PRINT SYMBOL(K)
            %REPEAT
            I=I+8
            %EXIT %IF I>=WORKA_CONSTPTR
         %REPEAT
      %FINISH
%END
%END
      %RETURN
%ROUTINE FILL(%INTEGER LAB)
!***********************************************************************
!*    NOT NECESSARY ACTUALLY TO FILL JUMPS ON PNX                      *
!*    CONSTRUCT THE RIGHT PPROC STATEMENT AND LOADER DOES THE REST     *
!***********************************************************************
%STRING (15) S
%INTEGER INF
      S=PLNAME(LAB)
      INF=PPJINFO(LAB)
      EPROCinterface(S,36,addr(pardes(INF&X'FFF')),WORKA_PLINK(LAB))
                                         ! NO DISPALY REQD
%END
%END
%REAL %FN ICL REAL TO PERQ(%REAL ICL REAL)
!***********************************************************************
!*    This is a function which converts a real number in ICL           *
!*         floating-point format into one that is in ICL PERQ          *
!*         floating-point format.                                      *
!*                                                                     *
!*     At Exit:   RESULT= +infinity if ICL Real is too large           *
!*                RESULT= -infinity if ICL Real is too small           *
!*                RESULT=  PERQ Real otherwise                         *
!*                                                                     *
!*Assumptions: (i). PERQ floating-point format conforms with the       *
!*                       proposed IEEE draft standard,                 *
!*            (ii). conversion is to be applied to 32-bit Reals,       *
!*           (iii). conversion is to be applied on ICLs,               *
!*            (iv). the hexadecimal representation of 1.0,             *
!*                                   on ICL PERQ's is R'3F800000'      *
!***********************************************************************
%CONST %REAL MINUS INFINITY= R'FF800000'; ! ie sign=1,exp=255,fraction=0
%CONST %REAL PLUS INFINITY= R'7F800000'; ! ie sign=0, exp=255,fraction=0
%CONST %REAL PERQ ZERO= R'00000000';     ! ie sign=0,exp=0,fraction=0
%INTEGER BITS SHIFTED LEFT;              ! by a SHZ instruction on ICL Fraction
%INTEGER ICL EXP;                        !exponent of ICL Real - 70
%INTEGER SIGN;                           !sign bit of ICL Real (1 if minus: 0 if plus)
%INTEGER PERQ EXP;                       !exponent of PERQ Real (calculated)
%INTEGER PERQ FRACTION;                  !fraction of PERQ Real (derived from ICL Fraction)
%REAL PERQ REAL;                         !--the Result
      %IF 1<<HOST&IBMFPFORMAT#0 %AND 1<<TARGET&IBMFPFORMAT=0 %START
         %IF PARM_X#0 %THEN %RESULT=ICL REAL; ! FOR SIMULATOR
         %IF ICL REAL=0.0 %THEN %RESULT=PERQ ZERO
         %IF ICL REAL<0.0 %THEN SIGN=1 %AND ICL REAL=-ICL REAL %ELSE SIGN=0
                                         ! ICL Real is now positive
                                         ! Decompose the ICL Real:
         PERQ FRACTION=INTEGER(ADDR(ICL REAL))
         ICL EXP=PERQ FRACTION>>24&x'7f'-70
         PERQ FRACTION=PERQ FRACTION<<8
         BITS SHIFTED LEFT=8
         %WHILE PERQ FRACTION>0 %CYCLE
            PERQ FRACTION=PERQ FRACTION<<1
            BITS SHIFTED LEFT=BITS SHIFTED LEFT+1
         %REPEAT
         PERQ FRACTION=PERQ FRACTION<<1>>9
                                         ! Calculate PERQ Exponent:
         PERQ EXP=((ICL EXP+5)*4 {as exponent is a hexadecimal exp})+ %C
            (11-BITS SHIFTED LEFT) {equals either 0,1,2, or 3}+127
         {the bias of the exponent}
                                         ! -and examine its range:
         %IF PERQ EXP<=0 %THEN %RESULT=MINUS INFINITY {ie Real Underflow}
         %IF PERQ EXP>=255 %THEN %RESULT=PLUS INFINITY {   Real  Overflow}
                                         ! Construct the PERQ Real
         INTEGER(ADDR(PERQ REAL))=(SIGN<<8!PERQ EXP)<<23!PERQ FRACTION
         %RESULT=PERQ REAL
      %FINISH %ELSE %RESULT=ICL REAL
%END;                                    !of ICL Real to PERQ
%LONG %REAL %FN ICL LONGREAL TO PERQ(%LONG %REAL ICL2900 REAL)
!***********************************************************************
!*    This is a function which converts a double precision real        *
!*         in ICL 2900 floating-point format into one that is          *
!*         in ICL PERQ floating-point format.                          *
!*     At Exit:   RESULT= equivalent PERQ real                         *
!*                                                                     *
!*Assumptions: (i). PERQ floating-point format conforms with the       *
!*                       proposed IEEE draft standard,                 *
!*            (ii). conversion is to be applied to 64-bit Reals,       *
!*           (iii). conversion is to be applied on ICL2900s,           *
!*            (iv). the hexadecimal representation of 1.0,             *
!*                             on ICL PERQ's is R'3FF0000000000000'    *
!************************************************************************
%INTEGER BITS SHIFTED LEFT;              ! by a SHZ instruction on ICL2900 Fraction
%INTEGER ICL2900 EXP;                    !exponent of ICL2900 Real - 78
%INTEGER SIGN;                           !sign bit of ICL2900 Real (1 if minus: 0 if plus)
%INTEGER PERQ EXP;                       !exponent of PERQ Real (calculated)
%LONG %REAL PERQ REAL;                   !--the Result
      %IF 1<<HOST&IBMFPFORMAT#0 %AND 1<<TARGET&IBMFPFORMAT=0 %START
      %LONG %INTEGER PERQ FRACTION;      !fraction of PERQ Real (derived from ICL2900 Fraction)
         %IF PARM_X#0 %THEN %RESULT=ICL2900REAL; ! FOR SIMULATOR
         %IF ICL2900 REAL=0.0 %THEN %RESULT=0.0
         %IF ICL2900 REAL<0.0 %THEN SIGN=1 %AND ICL2900 REAL=-ICL2900 REAL %ELSE SIGN=0
                                         ! ICL2900 Real is now positive
                                         ! Decompose the ICL2900 Real:
         PERQ FRACTION=LONGINTEGER(ADDR(ICL 2900 REAL))
         ICL2900EXP=PERQ FRACTION>>56&x'7f'-78
         PERQ FRACTION=PERQ FRACTION<<8
         BITS SHIFTED LEFT=8
         %WHILE PERQ FRACTION>0 %CYCLE
            PERQ FRACTION=PERQ FRACTION<<1
            BITS SHIFTEDLEFT=BITS SHIFTED LEFT+1
         %REPEAT
         PERQ FRACTION=PERQ FRACTION<<1>>12
                                         ! Calculate PERQ Exponent:
         PERQ EXP=(ICL2900 EXP+78 {which was subtracted by FIX above}-64 %C
            {which is the ICL2900 bias}-1 %C
            {   as the most significant digit is <1 and >=1/16})*4 %C
            {   as the ICL2900 exponent is a hex exponent}+(11-BITS SHIFTED LEFT) %C
            {bits shifted left equals 11, or 10, or 9, or 8}+1023
         {bias of PERQ double precision reals}
                                         ! Construct the PERQ Real
         LONGINTEGER(ADDR(PERQ REAL))=(LENGTHENI(SIGN<<11!PERQ EXP)<<52)!PERQ FRACTION
         %RESULT=PERQ REAL
      %FINISH %ELSE %RESULT=ICL2900 REAL
%END;                                    ! of ICL2900 LongReal to PERQ
%INTEGER %FN pardeslist(%RECORD (listf) %NAME tcell)
!***********************************************************************
!*      Builds the para descriptor table needed for risk chips         *
!*      where parameters are or may be passed in registers             *
!***********************************************************************
%RECORD (tagf) %NAME pcell
%INTEGER npars,i,j,entries,ptr,ptype,tslink,rtptype,offset
      tslink=tcell_slink
      rtptype=tcell_ptype&x'1FFF';       ! lose all external (etc) bits
      Offset=0
      ptr=paramptr+1
      %IF tslink=0 %THEN %START
         %IF X'33'#rtptype&255#x'35' %THEN %RESULT=addr(pardes(0)); ! no params
         pardes(paramptr+1)=0
         ptr=ptr+1; ->fn res
      %FINISH
      pcell==aslist(tslink)
      pardes(paramptr+1)=pcell_s3>>16
      %CYCLE
         ptr=ptr+1
         %EXIT %IF tslink=0
         pcell==aslist(tslink)
         tslink=pcell_link
         ptype=pcell_ptype
         %IF ptype&x'300' {arr}#0 %THEN %START
            %IF longs aligned=yes %AND offset&7=4 %START; ! aligment needed
               pardes(ptr)=-1;           ! dummy
               ptr=ptr+1; offset=offset+4
            %FINISH
            pardes(ptr)=4; pardes(ptr+1)=4
            offset=offset+8
            ptr=ptr+1;                   ! array is two addresses
            %CONTINUE
         %FINISH
         %IF ptype=x'400' %OR ptype=X'435' %OR (strvalinwa=yes %and ptype=X'35') %THEN %START
                                         ! general name or string name integer & address
            %IF longs aligned=yes %AND offset&7=4 %AND ptype=X'400' %START
                                         ! aligment needed
               pardes(ptr)=-1;           ! dummy
               ptr=ptr+1; offset=offset+4
            %FINISH
            pardes(ptr)=x'01000004'; pardes(ptr+1)=4
            ptr=ptr+1;                   ! these have two entries
            offset=offset+8
            %CONTINUE
         %FINISH
         %if strvalinwa=no %and ptype=x'35' %start
            pardes(ptr)=x'05000000'!(pcell_acc+3)&(-4)
            offset=offset+(pcell_acc+3)&(-4)
            %continue
         %finish
         %IF ptype&x'c00'#0 { all names} %START
            pardes(ptr)=4
            offset=offset+4
            %CONTINUE
         %FINISH
         %IF ptype&7<=2 %START
            %IF longs aligned=yes %AND offset&7=4 %AND ptype&X'F0'=X'60' %START
                                         ! aligment needed
               pardes(ptr)=-1;           ! dummy
               ptr=ptr+1; offset=offset+4
            %FINISH
            pardes(ptr)=(ptype&7)<<24!pcell_acc
            %IF pcell_acc=8 %THEN offset=offset+8 %ELSE offset=offset+4
            %CONTINUE
         %FINISH
         %IF ptype&7=3 %START
            %if strvalinwa=no %start
               pardes(ptr)=x'04000000'!(pcell_acc+3)&X'fffc'
              offset=offset+(Pcell_acc+3)&(-4)
            %else
               pardes(ptr)=4;           ! previous line when passed on stack
               offset=offset+4
            %finish
            %CONTINUE
         %FINISH
         impabort
      %REPEAT
fn res:                                  ! extra parameters fpr str &record fns
      rtptype=rtptype&x'fbff';           ! remove bit that indicates formal proc
      %IF rtptype=x'1035' %OR rtptype=x'1033' %START
                                         ! string fns and string fn formals
         pardes(ptr)=x'01000004'
         pardes(ptr+1)=4
         pardes(paramptr+1)=pardes(paramptr+1)+8; ! 2 extra words
         ptr=ptr+2
      %FINISH
      entries=ptr-(paramptr+2)
      pardes(param ptr)=entries
!
! If params arrive backwards the front end list will be last first
! so these parameters are the wrong way round. Reverse them here
!
      %if PARAMS BWARDS=Yes %start
         %for i=2+paramptr,1,1+paramptr+(entries>>1) %cycle
            j=pardes(i)
            pardes(i)=pardes(2*paramptr+entries-i+3)
            pardes(2*paramptr+entries-i+3)=j
         %repeat
      %FINISH
      %if PARM_dcomp#0 %then %start
          printstring("parameter list")
         %for i=0,1,entries+2 %cycle
           newline; prhex(pardes(paramptr+i),8)
         %repeat
         Newline
      %finish
      %RESULT=addr(pardes(param ptr))
%END
%ROUTINE PPJ(%INTEGER JUMP,N)
!***********************************************************************
!*    PLANT A 'JUMP PERMENTRY(N)'                                      *
!*    IF JUMP=0 THEN PLANT A CALL                                      *
!***********************************************************************
%string(15) S
%INTEGER VAL,LAB,INF
      %CONST %BYTE %INTEGER %ARRAY INVJ(24:35)=     JILE{JIGT},JIGE{JILT},
                                        JINE{JIEQ},JIEQ{JINE},
                                        JILT{JIGE},JIGT{JILE},
                                        JINTLEZ{JINTGZ},JINTGEZ{JINTLZ},
                                        JINTNZ{JINTZ},JINTZ{JINTNZ},
                                        JINTLZ{JINTGEZ},JINTGZ{JINTLEZ}

      LAB=0
      VAL=WORKA_PLABS(N)
      INF=PPJINFO(N);                    ! RESULTFLAGS<<24! npars<<16 ! BYTES OF PARAMS
      %IF VAL<0 %START
         S=plname(N)
         %if CGinC=NO %then %start
            VAL=ENEXTPROC2(S,4{local})
        %else
            val=enextproc2(Cstring(s),4{local})
         %finish
         WORKA_PLABS(N)=VAL
         WORKA_PLINK(N)=VAL
      %FINISH
      %IF JUMP>=24 %THEN LAB=GLABEL %AND GLABEL=LAB+1
      %IF LAB>0 %THEN EJUMP(INVJ(JUMP),LAB)
      EPRECALL2(VAL,addr(pardes(0))) %UNLESS INF&255#0; ! PRECALL MUST BE DONE BEFOR PARAMS
      ECALL2(VAL,1,pardes(inf&255),pardes(INF&X'FF'+1))
      %IF INF>>24#0 %THEN ESTKRESULT(0,1,4)
      %IF LAB>0 %THEN ELABEL(LAB)
%END
%INTEGER %FN BYTESWOP(%INTEGER VAL)
!***********************************************************************
!*    PERFORMS A COMPLETE BYTE REVERSAL OF VAL                         *
!***********************************************************************
%SWITCH SW(0:3)
      %IF Host=Perq3 %THEN %START
         %RESULT=Val
      %FINISH
      %IF HOST#TARGET %THEN ->SW(SWAPMODE&3)
SW(0): %RESULT=VAL
SW(1): %RESULT=(VAL<<8&x'ff00ff00')!(VAL>>8&x'ff00ff')
SW(2): %RESULT=VAL<<16!VAL>>16
SW(3): %RESULT=(VAL<<24)!(VAL<<8&X'FF0000')!(VAL>>8&X'FF00')!(VAL>>24)
%END
%EXTERNAL %ROUTINE REFORMATC(%RECORD (RD) %NAME OPND)
!***********************************************************************
!*    REFORMATS A CONSTANT TO TAKE INTO ACCOUNT DIFFERENT HOST-TARGET  *
!*    REPRESENTATIONS. HOST MAY BE EMAS OR PNX.                        *
!***********************************************************************
      %IF HOST#TARGET %START
      %INTEGER TYPE,PREC,I
      %LONG %REAL LR
      %RECORD (RD) TEMP
         TEMP=OPND
         I=OPND_D;                       ! ALL INTEGER UP TO 32 BIT
         TYPE=OPND_PTYPE&7
         PREC=OPND_PTYPE>>4&7
         %IF type=1 %AND SWAPMODE=0 %THEN %RETURN
         %IF TYPE=1 %START;              ! INTEGERS
            %IF PREC=3 %THEN OPND_B0<-I %AND OPND_B1<-I %AND OPND_B2<-I %AND %C
               OPND_B3<-I %AND %RETURN
            %IF PREC=4 %THEN %START
               OPND_D=BYTESWOP(I<<16!(I&X'FFFF'))
               %RETURN
            %FINISH
            %IF PREC=5 %THEN OPND_D=BYTESWOP(OPND_D) %AND %RETURN
            IMPABORT
         %FINISH
         %IF TYPE=2 %THEN %START
            %IF PREC=5 %START
               TEMP_R=ICLREALTOPERQ(OPND_R) %IF opnd_ptype&8=0; ! not if R' const
               OPND_D=BYTESWOP(TEMP_D)
               %RETURN
            %FINISH
            %IF PREC=6 %START
               MOVE BYTES(8,ADDR(OPND_D),0,ADDR(LR),0); ! obtaing unaligned longreal
               LR=ICLLONGREALTOPERQ(LR) %IF opnd_ptype&8=0; ! not if R' const
               MOVE BYTES(8,ADDR(LR),0,ADDR(TEMP_D),0)
               OPND_D=TEMP_D; OPND_XTRA=TEMP_XTRA
               %IF SWAPMODE&4#0 %THEN OPND_D=TEMP_XTRA %AND OPND_XTRA=TEMP_D
               OPND_D=BYTESWOP(OPND_D)
               OPND_XTRA=BYTESWOP(OPND_XTRA)
               %RETURN
            %FINISH
         %FINISH
         %IF TYPE=5 %THEN %RETURN;       ! CANT CHANGE SEX HERE
                                         ! MIGHT BE USED IN COMPILE TIME OP
!
! the next line can catch afulty programs so comment out when
! compiler is debugged
!
!         IMPABORT
      %FINISH
%END
%EXTERNAL %ROUTINE CHANGESEX(%INTEGER BASEAD,OFFSET,L)
!***********************************************************************
!*    ALTERERS INITIALISED DATA FOR A BYTE SEX CHANGE                  *
!***********************************************************************
      %OWN %BYTE %INTEGER %ARRAY %FORMAT F(0:X'FFFF')
%BYTE %INTEGER %ARRAY %NAME A
%INTEGER I,J
      %IF HOST#TARGET %AND X'10001'#SWAPMODE&X'10001'#0 %START
         A==ARRAY(BASEAD,F)
         %MONITOR %UNLESS OFFSET&1=0
         I=OFFSET
         %WHILE L>0 %CYCLE
            J=A(I)
            A(I)=A(I!!1)
            A(I!!1)=J
            I=I+2; L=L-2
         %REPEAT
      %FINISH
%END
%EXTERNAL %ROUTINE FILL DTABREFS(%INTEGER %NAME CURRINFRAL)
!***********************************************************************
!*    PLUGS REFENCES TO THE DIAG TABLES FOR CURRINF WHICH ARE          *
!*    ABOUT TO BE GENERATED AT CAS(DAREA). THE LIST POPPED HAS         *
!*    S1=AREA 1=CODE, DAREA FOR DIAGNOSTIC AREA                        *
!*    S2= THE OFFSET OF INSTRUCTION OR FORWARD POINTER                 *
!*    S3=THE WORD BEFORE FILLING - NOT USED FOR AREA 1                 *
!***********************************************************************
%INTEGER Q,JJ,KK
      %WHILE CURRINFRAL#0 %CYCLE
         POP(CURRINFRAL,Q,JJ,KK)
         %IF Q=1 %THEN %START
            ESETMARKER(JJ,CAS(DAREA))
         %FINISH %ELSE %START
            KK=CAS(DAREA)
            %IF Host#Target %AND swapmode&1#0 %THEN kk=kk<<16!(KK>>8&255)
            ED2(Q,JJ+2,KK&X'FFFF')
                                         ! THE PLUG ONLY ALLOWS 16 BIT OFFSET
                                         ! BUT TABLE FORM ALLOWS 18 BIT OFFSET
                                         ! EXTRA PLUG NEEDED IF >65K DIAGS
         %FINISH
      %REPEAT
%END
      %IF Host=Perq3 %OR host=amdahl %THEN %START
      %ROUTINE GET WSP(%INTEGER %NAME PLACE, %INTEGER SIZE)
!***********************************************************************
!*       FIND OR CREATE A TEMPORARY VARIABLE OF 'SIZE' WORDS           *
!***********************************************************************
      %INTEGER J,K,L,F
         %IF SIZE>4 %THEN SIZE=0
         K=worka_n
         %IF SIZE=0 %THEN worka_n=worka_n+268 %ELSE worka_n=worka_n+SIZE<<2
         PLACE=K
      %END
      %FINISH
%EXTERNAL %INTEGER %FN ETEMPSPACE(%INTEGER SIZE{in bytes},align)
!***********************************************************************
!*    provides a temporary for the emachine in the current stack frame *
!*    which kept in workarea and updated on every entry to generate    *
!*    This version uses unix conventions and the result is negative    *
!***********************************************************************
%INTEGER K
      %IF SIZE<4 %THEN SIZE=4
      %IF SIZE>16 %THEN IMPABORT
      %if preassigned TEMPSPACE#0 %start
         %if SIZE=4 %then %result=preassigned TEMPSPACE
         IMPABORT
      %finish
      K=WORKA_N
      align=align-1
      k=(k+align)&(~align)
      WORKA_N=K+SIZE
      %RESULT=WORKINGINF_DISPLAY-(K+SIZE)
%END
%EXTERNAL %INTEGER %FN EPERMSPACE(%INTEGER SIZE,ALIGN)
!***********************************************************************
!*    as etempspace but allocates in gla                               *
!***********************************************************************
%INTEGER k
      align=align-1
      glaca=(glaca+align)&(~align)
      k=glaca; glaca=glaca+size
      %RESULT=k
%END
%EXTERNAL %ROUTINE GENERATE(%RECORD (TRIPF) %ARRAY %NAME TRIPLES, %INTEGER CURRLEVEL,
   %ROUTINE GET WSP(%INTEGER %NAME PLACE, %INTEGER SIZE))
! should be%EXTERNAL %ROUTINE GENERATE(%RECORD (TRIPF) %ARRAY %NAME TRIPLES, %INTEGER CURRLEVEL,
! should be   %ROUTINE GET WSP(%INTEGER %NAME PLACE, %INTEGER SIZE))
!***********************************************************************
!*    EVALUATE A LIST OF TRIPLES PLABTING CODE IN BUFFERS              *
!***********************************************************************
%INTEGER %FN %SPEC JCODE(%INTEGER TFMASK)
%ROUTINE %SPEC VMY
%ROUTINE %SPEC REXP
%ROUTINE %SPEC STARSTAR
%ROUTINE %SPEC ISTARSTAR
%ROUTINE %SPEC CIOCP(%INTEGER N,xtra)
%INTEGER %FN %SPEC RLEVTOLEVEL(%INTEGER RLEV)
%INTEGER %FN %SPEC LOAD(%RECORD (RD) %NAME OP, %INTEGER mode)
%INTEGER %FN %SPEC STRINGLBAD(%RECORD (TAGF) %NAME TCELL)
%INTEGER %FN %SPEC RECORDELAD(%RECORD (TAGF) %NAME TCELL, %INTEGER SPTYPE,XTRA)
%integerfnspec assemblerrefad(%record(tagf)%name tcell,%integer xdisp)
%ROUTINE %SPEC INDLOAD(%INTEGER TYPE,SIZE,OFFSET)
%ROUTINE %SPEC INDSTORE(%INTEGER TYPE,SIZE,OFFSET)
%ROUTINE %SPEC LOADAD(%RECORD (RD) %NAME OPND)
%ROUTINE %SPEC LOADPTR(%RECORD (RD) %NAME OPND,OPND2)
%ROUTINE %SPEC DSTORE(%INTEGER TYPE,OPCODE,SIZE,LEVEL,DISP,Adid)
%ROUTINE %SPEC CHOP OPERAND(%RECORD (RD) %NAME OPND, %INTEGER PT,X)
%ROUTINE %SPEC DFETCH(%INTEGER TYPE,SIZE,LEVEL,DISP,Adid)
%ROUTINE %SPEC DFETCHAD(%INTEGER SIZE,LEVEL,DISP,Adid)
%ROUTINE %SPEC FETCH LOW AD END(%INTEGER B,D,Adid)
%ROUTINE %SPEC FETCH HIGH AD END(%INTEGER B,D,Adid)
%ROUTINE %SPEC STORE LOW AD END(%INTEGER B,D,Adid)
%ROUTINE %SPEC STORE HIGH AD END(%INTEGER B,D,Adid)
!
%RECORD (RD) %NAME OPND1,OPND2,OPND
%RECORD (RD) TOPND
%RECORD (TRIPF) %NAME CURRT,WORKT,WORKT2
%RECORD (LEVELF) %NAME LINF,CURRINF
%RECORD (TAGF) %NAME TCELL
%RECORD (LISTF) %NAME LCELL
!
%INTEGER C,D,WTRIPNO,JJ,COMM,Both loaded,XTRA,PT,BFFLAG,TRIPINF,TRIPVAL,PTYPE,TYPE,
   PREC,STPTR,DPTYPE,DACC,L0,B1,B2,B3,LRES,STACKATCALL,SKEY,TEMPLOC,op1origptype
!
! TRIPDATA GIVES INFORMATION ON TRIPLE
!     TOP 4 BITS HAVE TYPE
!     NEXT 12 BITS HAVE FLAGS:-
!     2**16 SET IF COMMUTATIVE
!     2**17 SET DONT LOAD OPERAND2
!     2**18 SET DONT LOAD OPERAND1
!     2**19 DONT SWOP NON COMMUTABLE OPERANDS
! NEXT 8 BITS HAVE MAX CODE PLANTED IN BYTES NOT INCLUDING ANY CONSTANSTS
! OR STRINGS WHICH MAY HAVE TO GO INLINE
! BOTTOM 8 BITS HAVE A POINTER OR VALUE
!     TYPE 0 TRIPLES ARE IGNORED
!     TYPE 1 TRIPLES VALUE HAS INDEX INTO SWITCH "TRIPSW"
!     TYPE 2 TRIPLES VALUE HAS POINTER TO ISEQS
!
      %CONST %INTEGER %ARRAY TRIPDATA(0:199)=0,
               X'1000070F'{RTHD ROUTINE/BKK HDR},
               X'10001043'{RDSPLY MAKE DISPLAY},
               X'10000410'{RDAREA INITIALISE DIAGS AREA},
               X'10000511'{RDPTR RESET DIAGS PTR},
               X'10000312'{RTBAD ERROR XIT FOR FN-MAP},
               X'10000113'{RTXIT "%RETURN"},
               X'10000314'{XSTOP "%STOP"},
               0(2),
               X'2000040A'{10 LOGICAL NOT},
               X'2000040B'{11 LOGICAL NEGATE},
               X'2000040C'{12 FLOAT},
               X'2000040D'{13 MODULUS},
               X'2000080E'{14 SHORTEN},
               X'2000040F'{15 LENGTHEN},
               X'20000610'{16 JAM SHORTEN},
               X'10000000'{17 ERROR},
               0{18 NULL TRIPLE},
               X'20000413'{19 PRELOAD},
               X'10000001'{20 UNUSED},
               X'10000303'{21 STORE STACKPOINTER},
               X'10000602'{22 RESTORE STACK POINTER},
               X'10000505'{23 ADVANCE STACK POINTER},
               X'10000D04'{24 DECLARE ARRAY},
               X'10000301'{25 UPDATE LINE NO},
               X'10000906'{26 CHECK ZERO FOR STEP},
               X'10000307'{27 FOR PREAMBLE},
               X'10000208'{28 FOR POSTAMBLE},
               X'1000010E'{29 FOR SECOND PREAMBLE},
               X'10000218'{30 PRECALL},
               X'10000519'{31 ROUTINE CALL},
               X'1000021A'{32 RECOVER FN RESULT},
               X'1000021B'{33 RECOVER MAP RESULT},
               X'00000000'{34 NOT CURRENTLY USED},
               X'1000081D'{35 GETAD GET 32BIT ADDREESS},
               X'10000424'{36 RTOI1 INT FN},
               X'10000C25'{37 RTOI2 INTPT FN},
               X'10000B26'{38 STOI1 TOSTRING FN},
               X'1000093D'{39 MNITR FOR %MONITOR},
               X'1000084F'{40 PPROF PRINT PROFILE tripsw(79)},
               X'1000053F'{41 RTFP TURN RTNAME TO FORMAL},
               X'10000649'{42 ON EVENT1 NO CODE AS YET},
               X'10000C4A'{43 ON EVENT2 NO CODE AS YET},
               X'10000846'{44 DVSTART FILL IN ELSIZE&ND},
               X'10001047'{45 DVEND WORK OUT TOTSIZE ETC},
               X'00000000'{46 FOREND noop},
               X'00000000'{47 DMASS noop},
               X'1000044E'{48 RTOI3 TRUNC function},
               0,
               X'10000132'{50 UCNOP},
               X'10000133'{51 UCB1},
               X'10000234'{52 UCB2},
               X'10000335'{53 UCB3},
               X'10000336'{54 UCW},
               X'10000437'{55 UCBW},
               0(3),
               X'1000063B'{59 UCNAM U-C ACCESS TO NAMES},
               0(68),
               X'20010414'{128 +},
               X'20000415'{129 -},
               X'20010416'{130 !!},
               X'20010417'{131 !},
               X'20010418'{132 *},
               X'20000419'{133 //},
               X'2000041A'{134 /},
               X'2001041B'{135 &},
               X'2000041C'{136 >>},
               X'2000041D'{137 <<},
               X'200A0E1E'{138 **},
               X'2001041F'{139 COMP},
               X'20000420'{140 DCOMP},
               X'200A0A21'{141 VMY},
               X'20010422'{142 COMB},
               X'200E0623'{143 ASSIGN=},
               X'200E0624'{144 ASSIGN<-},
               X'200A0E25'{145 ****},
               X'20020926'{146 BASE ADJ},
               X'200A0527'{147 ARR INDEX},
               X'20050428'{148 INDEXED FETCH},
               X'200E0629'{149 LOCAL ASSIGN},
               X'10000C09'{150 VALIDATE FOR},
               X'10000B15'{151 PRE CONCAT},
               X'10000A16'{152 COCNCATENEATION},
               X'10000C17'{153 IOCP CALL},
               X'10000C1C'{154 PARAMETER ASSIGNMENT 1 NORMAL VALUES},
               X'1000041F'{155 PARAM ASSNG 2 NORMAL PTRS},
               X'10000220'{156 PARAM ASSGN 3 ARRAYS},
               X'1000041f'{157 ASSGN FORMAL RT-CODE AS 155},
               X'10000220'{158 PASS5 TYPE GENERAL NAME},
               X'10000445'{159 PASS6 RESULT AREA FOR STR&REC FNS},
               X'1000030A'{160 BACK JUMP},
               X'1000030B'{161 FORWARD JUMP},
               X'1000000C'{162 REMOVE LAB},
               X'1000000D'{163 ENTER LABEL},
               X'1000FF21'{164 DECLARE SWITCH},
               X'10000022'{165 SET SWITCH LABEL TO CA},
               X'10000523'{166 GOTO SWITCH LABEL},
               X'10000D27'{167 STRING ASS1 GENERAL},
               X'10001128'{168 STRING ASS 2 L KNOWN},
               X'10000D29'{169 STRING JAM TRANSFER},
               X'10000C2A'{170 ARRAY HEAD ASSIGNMENT},
               X'10000C2B'{171 PTR ASSIGNMENT},
               X'1000052C'{172 MAP RESULT ASSIGNMENT},
               X'1000052D'{173 FN RESULT ASSIGNMENT},
               X'10000C2E'{174 STRING COMPARISON},
               X'10000C2E'{175 STRING DSIDED COMPARISON},
               X'10000C2F'{176 PRE RESOLUTION 1},
               X'10001230'{177 PRE RESOLUTION 2},
               X'10000B31'{178 RESOLUTION PROPER},
               X'1000233C'{179 RESOLUTION FINISH ASSN FRAGMNT},
               X'10000C4B'{180 SIGEV SIGNAL EVENT NOT IMPLEMENTED},
               X'10000A3E'{181 RECASS WHOLE RECORD ASSIGNMENT},
               X'10000A40'{182 ARRAY ADDR INC},
               X'10000A41'{183 AHADJ FOR ARRAY MAPPING},
               X'10000A42'{184  CREATE TYPE GENERAL PARAMETER},
               X'1000081E'{185 GET POINTER FOR PASSING BY NAME},
               X'10000444'{186 INDEX STRING FOR CHARNO},
               X'2002042A'{187 ZCOMP COMPARE W ZERO},
               X'2002022B'{188 CONSTANT LOGICAL SHIFT},
               X'2002022B'{189 COSNTANT ARITHMETIC SHIFT},
               X'10001048'{190 DV BPAIR ENTER LB,UB &RANGE IN CORRECT FORM},
               X'1000044C'{191 REG TO STORE OPERATION},
               0(*)
      %CONST %BYTE %INTEGER %ARRAY FCOMP(0:127)=0(2),
                                        IGT(2),ILT(2),INE(2),IEQ(2),
                                        IGE(2),ILE(2),0(2),
                                        0(2),
                                        ILT(2),IGT(2),INE(2),IEQ(2),
                                        ILE(2),IGE(2),0(2),
                                        0(2),
                                        JIGT(2),JILT(2),JINE(2),JIEQ(2),
                                        JIGE(2),JILE(2),0(2),
                                        0(2),
                                        JILT(2),JIGT(2),JINE(2),JIEQ(2),
                                        JILE(2),JIGE(2),0(2),
                                        0(2),
                                        RGT(2),RLT(2),RNE(2),REQ(2),
                                        RGE(2),RLE(2),0(2),
                                        0(2),
                                        RLT(2),RGT(2),RNE(2),REQ(2),
                                        RLE(2),RGE(2),0(2),
                                        0(2),
                                        JRGT(2),JRLT(2),JRNE(2),JREQ(2),
                                        JRGE(2),JRLE(2),0(2),
                                        0(2),
                                        JRLT(2),JRGT(2),JRNE(2),JREQ(2),
                                        JRLE(2),JRGE(2),0(2)

!
! OPCODE FOR ESTACK TO STORE VARIANT OPERATIONS
!
!
! THE FOLLOWING ARRAY HAS INSTRUCTION SEQUENCES FOR THE VARIOUS IMP
! IMP OPERATION PRECCED BY A SWITH LABEL AT WHICH THEY ARE PLANTED
! TOUGH CASES LIKE ** HAS A UNIQUE ONE-OFF SWITCH.
! LOOK UP THE SWITCH LABEL FOR PARAMETER DECODING IN DIFFICULT CASES
!
%CONST %INTEGER NISEQS=34
      %CONST %BYTE %INTEGER %ARRAY ISEQS(40:4*(3*NISEQS+10)-1)={FIRST INTEGER FORMS} %C
         2,INOT,0,0                    {10 16 BIT LOGICAL NOT},
         2,INEG,0,0                    {11 16 BIT LOGICAL NEGATE},
         12,0,0,0                      {12 16 BIT FLOAT TO 64 BIT REAL},
         2,IABS,0,0                    {13 16 BIT MODULUS},
         10,0,0,0                      {14 SHORTEN 16 BIT TO 16 BIT},
         11,0,0,0                      {15 LENGTHEN 16 BIT TO 32 BIT},
         21,0,0,0                      {16 SHORTEN 16 BIT FOR JAM},
         1,0,0,109                     {17 COMPILER ERROR},
         7,0,0,0                       {18 NOOP},
         7,0,0,0                       {19 PRELOAD},
         2,IADD,0,0                    {20 16 BIT ADDITION},
         2,ISUB,0,0                    {21 16 BIT SUBTRACTION},
         2,IXOR,0,0                    {22 16 BIT NONEQUIVALENCE},
         2,IOR,0,0                     {23 16 BIT LOGICAL OR},
         2,IMULT,0,0                   {24 16 BIT MULTIPLY},
         2,IDIV,0,0                    {25 16 BIT INTEGER DIVIDE},
         1,0,0,109                     {26 16 BIT REAL DIVIDE},
         2,IAND,0,0                    {27 16 BIT AND},
         2,ISHRL,0,0                   {28 16 BIT RIGHT SHIFT},
         2,ISHLL,0,0                   {29 16 BIT LEFT SHIFT},
         1,0,0,109                     {30 REAL EXP OPERATOR},
         13,0,0,0                      {31 COMPARISONS},
         14,0,0,0                      {32 FIRST PART OF DOUBLE COMPARISONS},
         15,0,0,0                      {33 VMY},
         2,IADD,0,0                    {34 COMBINE VMY RESULTS},
         16,0,0,0                      {35 ASSIGN},
         16,0,0,0                      {36 ASSIGN(<-)},
         17,1,2,20                     {37 16 BIT INTEGER EXPONENTIATION},
         18,2,0,0                      {38 BASE ADJUST ARRAY 16 BIT INDEX},
         19,2,0,0                      {39 ARRAY INDEX 16 BIT INDEX},
         20,0,0,0                      {40 INDEXED FETCH 16 BIT INDEX},
         23,0,0,0                      {41 LASS},
         24,0,0,0                      {42 ZCOMP COMPARISONS W ZERO},
         25,0,0,0                      {43 SHIFT BY CONSTANT},
         2,INOT,0,0                    {10 32 BIT LOGICAL NOT},
         2,INEG,0,0                    {11 32 BIT LOGICAL NEGATE},
         12,0,0,0                      {12 32 BIT FLOAT TO 64 BIT REAL},
         2,IABS,0,0                    {13 32 BIT MODULUS},
         10,0,0,0                      {14 SHORTEN 32 BIT TO 16 BIT},
         11,0,0,0                      {15 LENGTHEN 32 BIT TO 64 BIT},
         21,0,0,0                      {16 SHORTEN 32 BIT FOR JAM},
         1,0,0,109                     {17 COMPILER ERROR},
         7,0,0,0                       {18 NOOP},
         7,0,0,0                       {19 PRELOAD},
         2,IADD,0,0                    {20 32 BIT ADDITION},
         2,ISUB,0,0                    {21 32 BIT SUBTRACTION},
         2,IXOR,0,0                    {22 32 BIT NONEQUIVALENCE},
         2,IOR,0,0                     {23 32 BIT LOGICAL OR},
         2,IMULT,0,0                   {24 32 BIT MULTIPLY},
         2,IDIV,0,0                    {25 32 BIT INTEGER DIVIDE},
         1,0,0,109                     {26 32 BIT REAL DIVIDE},
         2,IAND,0,0                    {27 32 BIT AND},
         2,ISHRL,0,0                   {28 32 BIT RIGHT SHIFT},
         2,ISHLL,0,0                   {29 32 BIT LEFT SHIFT},
         1,0,0,109                     {30 REAL EXP OPERATOR},
         13,0,0,0                      {31 COMPARISONS},
         14,0,0,0                      {32 FIRST PART OF DOUBLE COMPARISONS},
         15,0,0,0                      {33 VMY},
         2,IADD,0,0                    {34 COMBINE VMY RESULTS},
         16,0,0,0                      {35 ASSIGN},
         16,0,0,0                      {36 ASSIGN(<-)},
         17,1,2,20                     {37 32 BIT INTEGER EXPONENTIATION},
         18,2,0,0                      {38 BASE ADJUST ARRAY 32 BIT INDEX},
         19,2,0,0                      {39 ARRAY INDEX 32 BIT INDEX},
         20,0,0,0                      {40 INDEXED FETCH 32 BIT INDEX},
         23,0,0,0                      {41 LASS},
         24,0,0,0                      {42 ZCOMP COMPARISONS W ZERO},
         25,0,0,0                      {43 SHIFT BY CONSTANT},
         7,0,0,0                       {10 REAL LOGICAL NOT},
         5,RNEG>>8,RNEG&255,0          {11 REAL LOGICAL NEGATE},
         1,0,0,109                     {12 FLOAT REAL COMPILER ERROR},
         2,RABS,0,0                    {13 REAL MODULUS},
         11,0,0,0                      {14 SHORTEN REAL},
         11,0,0,0                      {15 LENGTHEN REAL TO 64 BIT},
         1,0,0,109                     {16 SHORTEN REAL FOR JAM},
         1,0,0,109                     {17 COMPILER ERROR},
         7,0,0,0                       {18 NOOP},
         7,0,0,0                       {19 PRELOAD},
         4,RADD>>8,RADD&255,0          {20 REAL ADDITION},
         4,RSUB>>8,RSUB&255,0          {21 REAL SUBTRACTION},
         7,0,0,0                       {22 REAL NONEQUIVALENCE},
         7,0,0,0                       {23 REAL LOGICAL OR},
         4,RMULT>>8,RMULT&255,0        {24 REAL MULTIPLY},
         7,0,0,0                       {25 REAL INTEGER DIVIDE},
         4,RDIV>>8,RDIV&255,0          {26 REAL REAL DIVIDE},
         7,0,0,0                       {27 REAL AND},
         7,0,0,0                       {28 REAL LEFT SHIFT},
         7,0,0,0                       {29 REAL RIGHT SHIFT},
         22,2,2,21                     {30 REAL EXP OPERATOR},
         13,0,0,0                      {31 COMPARISONS},
         14,0,0,0                      {32 FIRST PART OF DOUBLE COMPARISONS},
         7,0,0,0                       {33 VMY},
         7,0,0,0                       {34 COMBINE VMY RESULTS},
         16,0,0,0                      {35 ASSIGN},
         16,0,0,0                      {36 ASSIGN(<-)},
         7,0,0,0                       {37 REAL INTEGER EXPONENTIATION},
         7,0,0,0                       {38 BASE ADJUST ARRAY REAL INDEX},
         7,0,0,0                       {39 ARRAY INDEX REAL INDEX},
         20,0,0,0                      {40 INDEXED FETCH REAL INDEX},
         23,0,0,0                      {41 LASS},
         24,0,0,0                      {42 ZCOMP COMPARISON W ZERO},
         7,0,0,0                       {43 SHIFT BY CNST ERROR}

%SWITCH SW(0:25),TRIPSW(0:79)
!
      CURRINF==WORKA_LEVELINF(CURRLEVEL)
      WORKINGINF==CURRINF
      FLAG AND FOLD(TRIPLES) %IF PARM_OPT#0; ! ALREADY DONE FOR OPT=0
      %IF PARM_DCOMP#0 %THEN PRINT TRIPS(TRIPLES)
      STPTR=TRIPLES(0)_FLINK
      %WHILE STPTR>0 %CYCLE
         CURRT==TRIPLES(STPTR)
         WTRIPNO=STPTR
         STPTR=CURRT_FLINK
         COMM=1; Both loaded=0
         OPND1==CURRT_OPND1
         OPND2==CURRT_OPND2
           op1origptype=opnd1_ptype          { needed for converts via multiple refers}
         XTRA=CURRT_X1
         JJ=CURRT_OPERN
         TRIPINF=TRIPDATA(JJ)
         %IF parm_dcomp#0 %AND parm_z#0 %THEN newline %AND print this trip(triples,stptr)
         C=TRIPINF>>28;                  ! TRIPLE TYPE
         TRIPVAL=TRIPINF&255
         %IF C=0 %THEN %CONTINUE
         %IF C=1 %THEN ->TRIPSW(TRIPVAL)
         LRES=0
!
! CARE IS NEEDED IN DETECTING WHEN OPERANDS ARE REVERSED IN STACK
! The loadop bits are set for indirect via triple operands which
! have some sort of IR in the stack
!
         %IF JJ>=128 {%AND CURRT_FLAGS&(LOADOP1+LOADOP2)=0} %AND %C
            1<<OPND1_FLAG&BTREFMASK#0 %AND 1<<OPND2_FLAG&BTREFMASK#0 %START
            workt==triples(opnd1_d)
            workt2==triples(opnd2_d)
            %IF workt_puse=wtripno %AND workt_flags&notinreg=0 %AND %C
               workt2_puse=wtripno %AND workt2_flags&notinreg=0 %START
               Both loaded=1
               L0=CURRT_BLINK
               L0=TRIPLES(L0)_BLINK %WHILE L0#0 %AND L0#OPND1_D %AND L0#OPND2_D
               %IF L0=OPND1_D %THEN COMM=2
            %FINISH
         %FINISH
         %IF TRIPINF&X'40000'=0 %START;  ! EOP NOT LOADED
            %IF Both loaded#0 %AND 1<<opnd1_flag&refer needed#0 %AND comm=1 %THEN %C
               comm=comm+exchange(opnd1,opnd2)
                                         ! Above is in case of refer on wrong operand
            LRES=LOAD(OPND1,0)<<1
            %IF JJ>=128 %AND CURRT_FLAGS&6=2 %START
                                         ! OPERANDS REVERSED IN ESTACK
               COMM=2
            %FINISH
         %FINISH
         %IF TRIPINF&X'F0000'=0 %AND COMM=2 %THEN comm=comm-EXCHANGE(OPND2,OPND1)
                                         ! I-RS THE WRONG WAY ROUND
                                         ! FOR NON COMMUTABLE OPS
         %IF 1<<opnd2_flag&refer needed#0 %AND (comm=2 %OR lres=2) %THEN %C
            comm=exchange(Opnd2,opnd1) %AND comm=1
! again to ensure refer on correct opnd
         %UNLESS JJ<128 %OR TRIPINF&X'20000'#0 %THEN LRES=LOAD(OPND2,0)
         PTYPE=OPND1_PTYPE&255; TYPE=PTYPE&7
         %IF TYPE=2 %THEN C=4*(TRIPVAL+2*NISEQS) %ELSE %IF PTYPE=X'51' %THEN %C
            C=4*(TRIPVAL+NISEQS) %ELSE C=4*TRIPVAL
         L0=ISEQS(C); B1=ISEQS(C+1)
         B2=ISEQS(C+2); B3=ISEQS(C+3)
         ->SW(L0)
SW(1):                                   ! ERROR CONDITION
TRIPSW(0):
         FAULT(B3,0,0) %UNLESS TYPE=7
TRIPSW(*):
         EOP(HALT);                      ! USEFUL IN DEBUGGING TO HAVE
                                         ! ERROR POSITION PINPOINTED
         ->STRES
SW(6):                                   ! PLANT  BYTE & SET PTYPE
         OPND1_PTYPE=B3
         ESTKLIT(BYTES(B3>>4))
SW(2):                                   ! PLANT ONE BYTE
         EOP(B1)
         OPND1_FLAG=9;                   ! PREVENT RELOAD IF THIS IS LAST
         ->STRES
SW(3):                                   ! PLANT 2 BYTES
         EOP(B1); EOP(B2)
         OPND1_FLAG=9;                   ! PREVENT RELOAD IF THIS IS LAST
         ->STRES
SW(4):                                   ! PLANT REAL OPERATION
SW(5):                                   ! REAL UNARY OPERATION
         D=B1<<8!B2
         EOP(D)
         OPND1_FLAG=9
         ->STRES
SW(7):                                   ! NULL OPERATION
         ->STRES
SUSE:
         ->STRES
SW(9):                                   ! INTEGER MODULUS
         ->SW(1);                        ! now unused
SW(10):                                  ! SHORTEN INTEGER TO BYTE
       %if opnd1_ptype&255=x'61' %then -> sw(11)
         %IF PARM_OPT#0 %START
            %UNLESS CURRT_CNT=1 %AND TRIPLES(CURRT_PUSE)_OPERN=SHRTN %START
               %IF CURRT_OPTYPE>X'31' %THEN %START
                  ESTKLIT(-x'8000')
                  ESTKLIT(X'7FFF')
               %FINISH %ELSE %START
                  ESTKLIT(0)
                  ESTKLIT(255)
               %FINISH
               EOP(CHK)
            %FINISH
         %FINISH
         OPND1_PTYPE=OPND1_PTYPE-X'10'
         ->SUSE
SW(11):                                  ! Change precision (general)
         D=Bytes(Currt_optype>>4)
!         printstring("lengthen"); write(currt_optype,5); write(d,5); newline
         %IF currt_optype&7=2 %THEN c=CVTRR %ELSE %c
            %if d=1 %then c=cvtiu %else %c
            %if op1origptype&255=x'31' %then c=cvtui %else c=CVTII
         %if bytes(op1origptype>>4&15)=d %then ->suse
         ESTKLIT(D)
         EOP(c)
         Opnd1_ptype=currt_optype
         ->Suse
SW(12):                                  ! FLOAT
         ESTKLIT(bytes(currt_optype>>4&15)); EOP(CVTIR)
         OPND1_PTYPE=currt_optype
         OPND1_XB=0
         ->SUSE
SW(21):                                  ! SHORTEN FOR JAM TRANSFER
                                         ! NO CODE NEEDED ON PNX
         OPND1_PTYPE=OPND1_PTYPE-X'10'
         ->SUSE
SW(22):                                  ! EXP IN REAL EXPRSN
         %IF OPND2_PTYPE&7=1 %THEN ->PCALL
                                         ! REAL**REAL BY SUBROUTINE
         LRES=LOAD(OPND2,0)
         %IF CURRT_FLAGS&LOAD OP1#0 %AND LRES=0 %THEN EOP(EXCH)
         REXP; ->SUSE
SW(17):                                  ! EXP IN INTEGER CONTEXT
PCALL:                                   ! CALL SUBROUTINE AS DEFINED
                                         ! IN CODE TABLE
         LRES=LOAD(OPND2,0)
         %IF CURRT_FLAGS&LOADOP1#0 %AND LRES=0 %THEN EOP(EXCH)
         %IF CURRT_OPTYPE&7=1 %THEN %START; ! INTEGERS
            ISTARSTAR
         %FINISH %ELSE %START
            STARSTAR;                    ! PLANT COMPLEX IN LINE ROUTINE
         %FINISH
         ->SUSE
SW(14):                                  ! DSIDED COMPARISONS
                                         ! COPY MIDDLE OPERAND(SIZE IN TABLE)
         GET WSP(D,2)
         DSTORE(TYPE,EDUPSTORE,BYTES(CURRT_OPTYPE>>4&15),CURRINF_RBASE,D,0)
         OPND2_PTYPE=CURRT_OPTYPE
         OPND2_FLAG=7; OPND2_D=CURRINF_RBASE<<16!D
         CURRT_FLAGS=CURRT_FLAGS!NOTINREG; ! STORE COPY TO BE USED
         WORKT==TRIPLES(CURRT_PUSE)
         WORKT_FLAGS=WORKT_FLAGS!LOADOP1; ! ENSURE ESTACK IS RIGHT WAY ROUND
SW(13):                                  ! COMPARISONS
         BFFLAG=COMM-1;                  ! NOTE BACKWARDS OR FORWARDS
         C=XTRA&15+16*BFFLAG
         %IF TYPE=2 %THEN C=C+64;        ! FLOATING COMPARATORS
         C=FCOMP(C)
         COMM=2
         WORKT==TRIPLES(CURRT_FLINK);    ! ON TO FOLLOWING TRIPLE
         %IF CURRT_OPTYPE=X'51' %OR CURRT_OPTYPE=X'41' %START
            %IF WORKT_OPERN=FJUMP %OR WORKT_OPERN=BJUMP %THEN %C
               WORKT_X1=WORKT_X1!X'40' %AND CURRT_OPND1=OPND2 %AND ->STRES
         %FINISH
         %IF TYPE=2 %START
            %IF WORKT_OPERN=FJUMP %OR WORKT_OPERN=BJUMP %THEN %C
               WORKT_X1=WORKT_X1!x'140' %AND CURRT_OPND1=OPND2 %AND ->STRES
         %FINISH
         EOP(C)
         CURRT_OPND1=OPND2;              ! OPND2 IS RESULT
         ->STRES;                        ! 2ND OPERAND MAY BE NEEDED IN
SW(15):                                  ! SPECIAL MH FOR ARRAY ACCESS
         C=XTRA>>28;                     ! CURRENT DIMENSION
         D=XTRA>>24&15;                  ! TOTAL NO OF DIMENSIONS
         VMY
         ->STRES
SW(18):                                  ! BASE ADJUST ARRAY INDEX
         DPTYPE=XTRA>>16
         %UNLESS PARM_COMPILER#0 %OR DPTYPE&X'300'=X'200' %START
            D=OPND2_D&X'FFFF'
            %IF OPND2_FLAG=SCONST %START; ! DV KNOWN
               C=CTABLE(D)
               C=BYTESWOP(C)
               ESTKLIT(C)
            %FINISH %ELSE %START
               CHOP OPERAND(OPND2,x'51',0)
               LRES=LOAD(OPND2,0)
               EREFER(0,X'01000004')
            %FINISH
            EOP(IADD)
         %FINISH
         ->STRES
SW(19):                                  ! ARRAY INDEX
         DACC=XTRA>>20
         %IF DACC>0 %START;              ! NORMAL CASE EL SIZE KNOWN
            CHOP OPERAND(OPND2,x'51',4); ! array base
            LRES=LOAD(OPND2,0)
            EOP(EXCH)
            %IF DACC<=1 %THEN EOP(INDEX1) %ELSE %IF DACC=2 %THEN EOP(INDEX2) %ELSE %IF %C
               DACC=4 %THEN EOP(INDEX4) %ELSE %IF DACC=8 %THEN EOP(INDEX8) %ELSE %C
               ESTKLIT(DACC) %AND EOP(INDEX)
         %FINISH %ELSE %START;           ! RARE CASE GO TO DV FOR SIZE
                                         ! ONLY FOR ACCESS OF STRING&RECORD
                                         ! ARRAYNAMES
            LRES=LOAD(OPND2,0);          ! full head dvptr on top
            %if 1<<TARGET&LINTAVAIL#0 %then Eop(ESPLITD)
            EREFER(6!!((HALFSWOPPED>>TARGET&1)<<1),x'01000002'); ! el size halfword out of (un)swopped dv
            EPROMOTE(3); EOP(EXCH)
            EOP(INDEX)
         %FINISH
         ->STRES
SW(20):                                  ! INDEXED FETCH
         INDLOAD(opnd1_ptype&7,BYTES(PTYPE>>4&7),0)
         OPND1_PTYPE=OPND1_PTYPE&255
         OPND1_FLAG=9
         OPND1_XB=0
         ->STRES
SW(16):                                  ! ASSIGN(=)
                                         ! ASSIGN(<-)
      %BEGIN
      %INTEGER newsize,convop
         newsize=0; convop=cvtii
         PT=XTRA&255;                    ! ORIGINAL PT OF LHS HERE
         %IF PT=0 %THEN PT=CURRT_OPTYPE
         %IF pt&7=1 %AND pt>>4#opnd2_ptype>>4&15 %THEN newsize=bytes(pt>>4)
         %if newsize=1 %then convop=cvtiu %else %if opnd2_ptype>>4&15=3 %c
             %then convop=cvtui
         %IF OPND1_FLAG=2 %START;        ! OPERAND A NAME
            LRES=LOAD(OPND2,0)
            %IF newsize#0 %THEN estklit(newsize) %AND eop(convop)
            TCELL==ASLIST(TAGS(OPND1_D))
            %IF TCELL_PTYPE&X'3FFF'=X'33' %THEN D=RECORDELAD(TCELL,PT,OPND1_XTRA) %ELSE %C
               D=TCELL_SLINK
            DSTORE(PT&7,ESTORE,BYTES(PT>>4),TCELL_UIOJ>>4&15,D&x'ffff',addr(lett(word(opnd1_d))))
         %finish %else %if opnd1_flag=local ir %start
                                        ! special for integer(addr(x))=...
            lres=load(opnd2,0)
            %if newsize#0 %then estklit(newsize) %and eop(convop)
            dstore(pt&7,estore,bytes(pt>>4),opnd1_d>>16,opnd1_d&X'ffff',0)
         %FINISH %ELSE %START;           ! OPERAND A POINTER
            %IF OPND1_FLAG=INDNAME %START; ! POINTER NOT LOADED
               LRES=LOAD(OPND2,0)
               %IF newsize#0 %THEN estklit(newsize) %AND eop(convop)
               LOADPTR(OPND1,OPND1)
            %FINISH %ELSE %START
               LOADPTR(OPND1,OPND1)
               LRES=LOAD(OPND2,0)
               %IF LRES>0 %OR (CURRT_FLAGS&LOADOP1=0 %AND COMM=1) %THEN EOP(EXCH)
               %IF newsize#0 %THEN %C
                  eop(EXCH) %AND estklit(newsize) %AND eop(convop) %AND eop(EXCH)
            %FINISH
            INDSTORE(PT&7,BYTES(PT>>4),0)
         %FINISH
      %END
         ->STRES
SW(23):                                  ! LOCAL ASSIGNMENT
         D=BYTES(PTYPE>>4&15)
         LRES=LOAD(OPND2,0)
         %IF CURRT_PUSE=CURRT_FLINK %AND OPND2_XB=ESTK %THEN EOP(DUPL)
         DSTORE(PTYPE&7,ESTORE,D,OPND1_D>>16,OPND1_D&X'FFFF',0)
         OPND1_FLAG=7; OPND1_XB=OPND2_XB; ! IN CASE USED AGAIN
         %IF CURRT_PUSE#CURRT_FLINK %THEN CURRT_FLAGS=CURRT_FLAGS!NOTINREG
                                         ! FORCE RELOAD FROM STORE IN ALL BUT
                                         ! BUT ONE SIMPLE CASE
         ->STRES
SW(24):                                  ! COMPARE WITH ZERO (OPND2=0)
         WORKT==TRIPLES(CURRT_FLINK);    ! NEXT OR JUMP TRIPLE
         D=WORKT_X1;                     ! IBM TYPE JUMP MASK
         BFFLAG=0
         %IF TYPE=1 %START;              ! INTEGERS
            WORKT_X1=D!X'60';            ! with zero and compare omitted
         %FINISH %ELSE %START
            WORKT_X1=D!!X'160';          ! with zero(2),comp omitted & real(256)
         %FINISH
         ->STRES
SW(25):                                  ! SHIFT BY CONSTANT
         D=OPND2_D
         %IF CURRT_OPERN=CASHIFT %AND D=-1 %THEN EOP(HALT) %ELSE %IF %C
            D>0 %OR CURRT_OPERN=CLSHIFT %THEN ESTKLIT(D) %AND EOP(ISHLL) %ELSE %C
            ESTKLIT(D) %AND EOP(ISHLA)
         ->STRES
TRIPSW(76):                              ! OPERATE AND ASSIGN OPERATION
                                         ! PRODUCED BY PNX OPT PASS ONLY
      %BEGIN
         %CONST %BYTE %INTEGER %ARRAY OOPC(128:135)=IADDST,ISUBST,IXORST,IORST,IMULTST,
                                                 IDIVST,HALT,IANDST

         LRES=LOAD(OPND2,0)
         Lres=LOAD(OPND1,0)
         EOP(EXCH)
         EOP(OOPC(XTRA))
      %END
         ->STRES
TRIPSW(1):                               ! SET LINE NO
         D=opnd1_d>>16
         %IF D=prev line %THEN %CONTINUE
         prev line=D
         ELINESTART(D)
         %IF Target=DRS %and  PARM_LINE#0 %START
            ESTKLIT(D)
            DSTORE(1,ESTORE,2,CURRINF_RBASE,OPND1_D&X'FFFF',0)
         %FINISH
         %IF parm_prof#0 %START
            Estkdir(zgst,profzgst+4*(D),0,X'01000004')
            Estklit(1)
            Eop(IADDST)
         %FINISH
         %CONTINUE
TRIPSW(2):                               ! RESET STACK PTR TO SAVED VAL
         DFETCH(1,4,CURRINF_RBASE,OPND1_D,0)
!
! DRS uses the main stack but eauxres reloads pointer in one instr (special)
!
         %IF aux stack=yes %or Target=DRS %THEN EOP(EAUXRES) %ELSE %START
            EOP(SFA)
            EOP(ISUB)
            EOP(ASF)
         %FINISH
         %CONTINUE
TRIPSW(3):                               ! SAVE STACK POINTER
                                         ! OPND1 IS TEMPORARY(16 BITS) FOR SAVE
         %IF aux stack=yes %THEN EOP(Eauxsf) %ELSE EOP(SFA)
         DSTORE(1,ESTORE,4,CURRINF_RBASE,OPND1_D,0)
         %CONTINUE
TRIPSW(70):                              ! START OF DOPE VECTOR
                                         ! OPND1_D=ND<<16!ELSIZE
                                         ! OPND1_XTRA=PTYPE<<16!DVDISP
         D=OPND1_XTRA&X'FFFF'
         ESTKLIT(OPND1_D)
         DSTORE(1,ESTORE,4,CURRINF_RBASE,D+4*Stack Inc,0)
         %CONTINUE
TRIPSW(71):                              ! END OF DOPE VECTOR
                                         ! OPND1_D=DVF<<16!ELSIZE
                                         ! OPND1_XTRA=PTYPE
                                         ! XTRA=ND<<16!DVDISP
         D=OPND1_D&X'FFFF';              ! ELSIZE
         %IF D>1 %THEN ESTKLIT(D) %AND EOP(IMULT)
         DSTORE(1,ESTORE,4,CURRINF_RBASE,XTRA&X'FFFF'+8*Stack Inc,0)
                                         ! NOW WORK OUT THE BASE OFFSET USING
                                         ! MASK OF NONZERO LBS PASSED IN DVF
         D=XTRA&X'FFFF';                 ! DVDISP
         C=OPND1_D>>16;                  ! THE MASK
         %IF C=0 %THEN ESTKLIT(0) %ELSE %START
            B1=0
            %FOR JJ=1,1,XTRA>>16 %CYCLE
               %IF C&(1<<JJ)#0 %START;   ! THIS LB NONZERO
                  DFETCH(1,4,CURRINF_RBASE,D+Stack Inc*(12*JJ+4),0); ! LB
                  %IF JJ>1 %THEN %START
                     DFETCH(1,4,CURRINF_RBASE,D+Stack Inc*(12*JJ-4),0)
                     EOP(IMULT)
                  %FINISH
                  %IF B1>0 %THEN EOP(IADD)
                  B1=B1+1;               ! COUNT PRODUCTS
               %FINISH
            %REPEAT
            EOP(INEG)
         %FINISH
         DSTORE(1,ESTORE,4,CURRINF_RBASE,D,0)
         %CONTINUE
TRIPSW(72):                              ! DV BOUND PAIR
                                         ! OPND1&2 ARE LB & UB RESPECTIVLY
                                         ! XTRA=CURRD<<24!ND<<16!DVDISP
         D=XTRA&X'FFFF'+12*Stack Inc*(XTRA>>24); ! TRIPLE POSN
         %IF OPND1_FLAG=SCONST %START;   ! LB A CONST
            ESTKLIT(OPND1_D)
            DSTORE(1,ESTORE,4,CURRINF_RBASE,D+4*Stack Inc,0)
            LRES=LOAD(OPND2,0)
            DSTORE(1,EDUPSTORE,4,CURRINF_RBASE,D,0)
            %IF OPND1_D#1 %THEN ESTKLIT(OPND1_D-1) %AND EOP(ISUB)
         %FINISH %ELSE %START
            LRES=LOAD(OPND1,0)<<1!LOAD(OPND2,0)
            %IF LRES=B'10' %THEN EOP(EXCH)
            DSTORE(1,EDUPSTORE,4,CURRINF_RBASE,D,0)
            EOP(EXCH)
            DSTORE(1,EDUPSTORE,4,CURRINF_RBASE,D+4*Stack Inc,0)
            EOP(ISUB); ESTKLIT(1); EOP(IADD)
         %FINISH
         C=XTRA>>24&255;                 ! CURRENT DIMENSION
         %IF C>1 %THEN EOP(IMULT);       ! MULTPLY UP BY LOWER RNAGES
         DSTORE(1,EDUPSTORE,4,CURRINF_RBASE,D+8*stack Inc,0)
         %CONTINUE
TRIPSW(4):                               ! DECLARE ARRAY
                                         ! OPND1_D=CDV<<31!C<<24!D<<16!DVDISP
                                         ! OPND1_XTRA HAS DICT ENTRY NO
                                         ! dvdisp refers to sst
                                         ! sndisp has disp to ctables
         TCELL==ASLIST(TAGS(OPND1_XTRA))
         C=OPND1_D>>24&127
         D=OPND1_D>>16&255
                                         ! NO OPTIMISING OF MULTIPLE DECS YET
                                         ! HENCE C & D NOT USED
         %IF OPND1_D>0 %START;           ! DYNAMIC DOPE VECTOR
            DFETCHAD(4,CURRINF_RBASE,OPND1_D&X'FFFF',0)
         %FINISH %ELSE %START;           ! DV IN SHAREABLE SYMBOL TABLES
            ESTKADDR(4,OPND1_D&X'FFFF',0,4)
         %FINISH
         DSTORE(1,ESTORE,4,CURRINF_RBASE,TCELL_SLINK+4,0)
         %IF aux stack=yes %THEN eop(eauxsf) %ELSE %IF stack down=no %THEN eop(sfa)
         %IF TRIPLES(STPTR)_OPERN=ASPTR %START; ! IF ARRAY NOT FORMAT
            %IF OPND1_D<0 %START;        ! ARRAY SIZE KNOWN
               C=CTABLE(TCELL_SNDISP+2)
               C=BYTESWOP(C)
               %IF longs aligned=yes %THEN C=(C+7)&(-8) %ELSE C=(C+3)&(-4)
                                         ! TO 64 BIT BNDRY
               %IF Aux stack=yes %OR Stack down=no %THEN Estklit(c) %ELSE ESTKLIT(-C)
            %FINISH %ELSE %START;        ! DYNAMIC NEEDS LOOP !
               DFETCH(1,4,CURRINF_RBASE,OPND1_D&X'FFFF'+8*stack Inc,0)
               %IF longs aligned=yes %THEN c=7 %ELSE c=3
               %IF Tcell_acc&c#0 %START; ! elements aresmall enough to need alignment
                  ESTKLIT(C); EOP(IADD)
                  ESTKLIT(-(C+1))
                  EOP(IAND)
               %FINISH
               %IF auxstack=no %AND Stack down=yes %THEN EOP(INEG)
            %FINISH
            %IF aux stack=yes %THEN eop(eauxadd) %ELSE eop(ASF)
         %FINISH
         EOP(SFA) %IF aux stack=no %AND stack down=yes; ! STACK FRONT ADDRESS=BASE ADDRESS
         DSTORE(1,ESTORE,4,CURRINF_RBASE,TCELL_SLINK&x'ffff',0)
         %CONTINUE
TRIPSW(5):                               ! CLAIM ARRAY SPACE
                                         ! OPND1_D=CDV<<31!SNDISP!DVDISP
                                         ! NOT NEEDED ON PNX AS THIS MUST
                                         ! BE DONE DURING DECLN(SEE ABOVE)
         %CONTINUE
TRIPSW(6):                               ! CHECK FOR ZERO FOR STEP
         LRES=LOAD(OPND1,0);             ! STEP TO ESTACK
         PPJ(JINTZ,11);                  ! USING ZERO=FALSE EQUIVALENCE
         %CONTINUE
TRIPSW(7):                               ! FOR PREAMBLE
         LRES=LOAD(OPND1,0);             ! FORCE INITIAL TO ESTACK
         WORKT==TRIPLES(CURRT_FLINK)
         WORKT==TRIPLES(WORKT_FLINK) %WHILE WORKT_OPERN#VASS
         TOPND=WORKT_OPND1;              ! control var name
         TCELL==ASLIST(TAGS(TOPND_D))
         %IF TOPND_FLAG=INDNAME %START
            DFETCH(1,4,TCELL_UIOJ>>4&15,TCELL_SLINK&X'ffff',0)
            INDSTORE(1,4,0)
         %FINISH %ELSE DSTORE(1,ESTORE,4,TCELL_UIOJ>>4&15,TCELL_SLINK&X'ffff',0)
         %CONTINUE
TRIPSW(8):                               ! FOR POSTAMBLE
         %CONTINUE
TRIPSW(9):                               ! VALIDATE FOR
         LRES=LOAD(OPND1,0)
         LRES=LOAD(OPND2,0)
         EOP(IREM)
         PPJ(JINTNZ,11);                 ! USING ZERO=FALSE EQIVALENCE
         %CONTINUE
TRIPSW(10):                              ! BACK JUMP _X1 HAS TF&MASK
                                         ! OPND1_XTRA HAS LABEL CELL
         LCELL==ASLIST(OPND1_XTRA)
         D=XTRA;                         ! THE MASK
         EJUMP(JCODE(D),lcell_s1&X'FFFF')
         %CONTINUE
TRIPSW(11):                              ! FORWARD JUMP _X1 HAS TF&MASK
                                         ! OPND1_XTRA HAS LABEL CELL<<16!JUMP CELL
         LCELL==ASLIST(OPND1_XTRA>>16)
         %IF Lcell_s1&X'FFFF'=0 %THEN lcell_S1=lcell_s1!glabel %AND glabel=glabel+1
         C=JCODE(XTRA)
         EJUMP(C,lcell_s1&X'FFFF')
         D=OPND1_D>>24;                  ! ENTER JUMP FLAGS
         %IF D&2#0 %START;               ! ENVIRONMENT MANIPULATION
                                         ! no environments in this machine
            Lcell_S2=Lcell_S2+x'10000';  !But can count uses and pass to Em-c
         %FINISH
         %CONTINUE
TRIPSW(12):                              ! REMOVE LABEL
      %BEGIN
      %INTEGER S1,S2,S3
      %INTEGER %NAME CELL
         CELL==CURRINF_LABEL
         %WHILE CELL>0 %CYCLE
            %IF ASLIST(CELL)_S3=OPND1_D %THEN POP(CELL,S1,S2,S3) %AND %EXIT
            CELL==ASLIST(CELL)_LINK
         %REPEAT
!         EDISCARDLABEL(OPND1_D)
      %END
         %CONTINUE
TRIPSW(13):                              ! INSERT LABEL
                                         ! OPND1_XTRA HAS LABEL CELL
         LCELL==ASLIST(OPND1_XTRA)
         %IF Lcell_s1&X'FFFF'=0 %THEN lcell_S1=lcell_s1!glabel %AND glabel=glabel+1
         D=LCELL_S2&X'FFFF';             ! JUMP LIST REDUNDANT ON PNX
         %WHILE D#0 %CYCLE;              ! FILL FORWARD REFS
            POP(D,B1,B2,B3);             ! B2=1 IF SHORT JUMP PLANTED
         %REPEAT
         D=OPND1_D>>24;                  ! ENVIRONMENT MANIPULATION FLAGS
                                         ! no environments in this machine
         %if D&2 #0 %Start;              ! But we have counted calls(above)
            %if TARGET=RS6 %then Efrlabel(lcell_s1&x'FFFF',lcell_s2>>16{Count})%c
              %else Elabel(Lcell_s1&x'ffff')
         %else
            ELABEL(LCELL_S1&X'FFFF')
         %finish
         LCELL_S2=0;                     ! NO JUMPLIST&NO ENVIRONMENT
         %CONTINUE
TRIPSW(14):                              ! FOR 2ND PREAMBLE
                                         ! MAY BE UNNECESSARY
         WORKT==TRIPLES(CURRT_FLINK)
         WORKT==TRIPLES(WORKT_FLINK) %WHILE WORKT_OPERN#VASS
         TOPND=WORKT_OPND1;              ! control var name
         OPND1=TOPND
         WORKT==TRIPLES(CURRT_PUSE)
         WORKT_FLAGS=WORKT_FLAGS!LOADOP1
         CURRT_FLAGS=CURRT_FLAGS!NOTINREG
         %CONTINUE
TRIPSW(15):                              ! RT HEADING OPND1_D=RTNAME
                                         ! OPND1_XTRA=AXNAME #0 IF AN ENTRY
      %BEGIN
      %INTEGER H,PCHKWORD,PBITS,INNER
         H=0; PCHKWORD=0
         INNER=Currt_Flags&Bstruct
         CURRINF_ENTRYAD=GLABEL;         !  FOR RETURN=JUMP TO END
         GLABEL=GLABEL+1
         %IF OPND1_D>=0 %THEN %START
            C=0
            TCELL==ASLIST(TAGS(OPND1_D))
            PCHKWORD=pardeslist(TCELL)
            H=TCELL_SNDISP
         %FINISH %ELSE C=1
         PBITS=CURRINF_RBASE<<16!Parm_Chk<<6; ! Rlevel and fill with unass
         %IF INNER=0 %THEN pbits=pbits!2****5
         %IF H=0 %THEN H=-1
         %IF OPND1_XTRA#0 %THEN %C
            Eprocinterface(STRING(OPND1_XTRA),Pbits!C<<1!1,pchkword,H) %ELSE %IF %C
            OPND1_D>=0 %THEN Eprocinterface(STRING(ADDR(WORKA_LETT(WORKA_WORD(OPND1_D)))),
            Pbits,pchkword,H)
         %IF OPND1_D>=0 %THEN TCELL_SNDISP=H
      %END
         %CONTINUE
TRIPSW(67):                              ! RDISPLY CREATE DISPLAY
         D=CURRINF_RBASE
         %CONTINUE
TRIPSW(16):                              ! RDAREA - INITIALISE DAIGS AREA
                                         ! OPND1_D=N FOR DIAGS AREA
         %if Target=DRS %start        { if IDIA not done by EM }
            ESTKDIR(2,32,0,X'01000004');           ! PICK UP M'IDIA'
            DSTORE(1,ESTORE,4,CURRINF_RBASE,OPND1_D,0)
         %finish
         %CONTINUE
TRIPSW(17):                              ! RDPTR SET DAIGS POINTER
                                         ! OPND1_D=LEVEL NOT CURRINF ALWAYS
         LINF==WORKA_LEVELINF(OPND1_D)
         D=ESTKMARKER
                                         ! BUT <16BITS OPTIMISED !
         PUSH(LINF_RAL,1,D,0);           ! TO  OVERWRITE LATER
         %if Target=DRS %then c=2 %else c=4
         DSTORE(1,ESTORE,c,LINF_RBASE,LINF_DIAGINF,0)
         %CONTINUE
TRIPSW(18):                              ! RTBAD FN-MAP ERROR EXIT
         WORKT==TRIPLES(CURRT_BLINK);    ! PREVIOUS TRIPLE
         %CONTINUE %IF WORKT_OPERN=RTXIT %OR WORKT_OPERN=XSTOP %OR %C
            (WORKT_OPERN=BJUMP %AND WORKT_X1&15=15)
         %IF PARM_OPT#0 %THEN %START
            Eprecall2(Worka_plabs(2),addr(pardes(14)))
            ESTKLIT(0)
            ESTKLIT(21)
            %IF PARAMS BWARDS=yes %THEN EOP(EXCH)
            EOP(PUSHVAL)
            EOP(PUSHVAL)
            PPJ(0,2)
         %FINISH
         %CONTINUE
TRIPSW(19):                              ! RTXIT - "%RETURN"
         %IF OPND1_D=0 %START;           ! JUMP TO END FOR RETURNS PROTEM
                                         ! TILL REGISTER RESTORING SOLVED
            %if currinf_auxsbase=0 %then EOP(RETURN) %else EJUMP(JUMP,CURRINF_ENTRYAD)
         %FINISH %ELSE %START
            ELABEL(CURRINF_ENTRYAD);     ! ENTRAD HOLDS LAB FOR RETURN
            %IF (Aux Stack=yes %or (Target=DRS{ %and currinf_rbase=1})) %c
             %AND CURRINF_AUXSBASE>0 %THEN %START
!
! on DRS must cut back stack before return to enable the ABI to work
! other wise the registers ESI & EDI are poped with junk
!
               DFETCH(1,4,CURRINF_RBASE,CURRINF_AUXSBASE,0)
               EOP(EAUXRES)
            %FINISH
            EOP(RETURN)
            EPROCEND(CURRINF_SNMAX-CURRINF_DISPLAY,0,ADDR(WORKA_N))
         %FINISH
         %CONTINUE
TRIPSW(20):                              ! XSTOP - "%STOP"
         CALL STOP
         %IF OPND1_D#0 %THEN EPROCEND(CURRINF_SNMAX-CURRINF_DISPLAY,0,ADDR(WORKA_N))
         %CONTINUE
TRIPSW(61):                              ! %MONITOR
         Eprecall2(Worka_plabs(2),addr(pardes(14)))
         ESTKLIT(0)
         EOP(PUSHVAL)
         ESTKLIT(0)
         EOP(PUSHVAL)
         PPJ(0,2)
         %CONTINUE
!***********************************************************************
!*    SECTION FOR STRING CONCATENATION AND ASSIGNMENT                  *
!***********************************************************************
TRIPSW(21):                              ! PRECONCAT
                                         ! OPND1 IS WORK AREA
                                         ! OPND2 HAS FIRST STRING
         LRES=LOAD(OPND2,0);             ! 32 BIT AD OF STRING2
         EOP(DUPL); EREFER(0,x'03000001')
         LRES=LOAD(OPND1,64)
         EOP(EXCH); ESTKLIT(1); EOP(IADD)
         EOP(MVB)
         OPND1_FLAG=7;                   ! RESULT IS LOCAL
         %CONTINUE
TRIPSW(22):                              ! CONCATENATE OPND1 WORK AREA
                                         ! OPND2 THE NEXT BIT
         OPND1=TRIPLES(OPND1_D)_OPND1 %WHILE OPND1_FLAG=REFTRIP
         LRES=LOAD(OPND2,0)
         EPRECALL2(WORKA_PLABS(24),addr(pardes(5)))
         EOP(PUSHVAL)
         LRES=LOAD(OPND1,64)
         EOP(PUSHVAL)
         PPJ(0,24)
         OPND1_FLAG=7;                   ! RESULT IS LOCAL
         %CONTINUE
TRIPSW(39):                              ! GENERAL STRING ASSIGN
         LRES=LOAD(OPND1,0);             ! PTR (2 WORDS) TO LHS
                                         ! Ptr has address over lmax
         %IF opnd1_ptype&255<x'61' %THEN estklit(255) %AND EOP(EXCH) 

         %IF OPND2_FLAG=LCONST %THEN %START; ! CONST STRING ASSN
            %if 1<<TARGET&LINTAVAIL#0 %then Eop(ESPLITD)
            %IF OPND2_XTRA=0 %START;     ! CONST IS NULL
               EOP(DISCARD); ESTKLIT(0); EOP(EXCH); EREFER(0,x'01000002')
               EOP(ESTORE)
            %FINISH %ELSE %START
               %IF PARM_OPT#0 %THEN EOP(EXCH) %ELSE EOP(DISCARD)
               LRES=LOAD(OPND2,0)
               EOP(EXCH)
               ESTKLIT(OPND2_XTRA+1)
               EOP(MVB)
               %IF PARM_OPT#0 %START
                  ESTKLIT(OPND2_XTRA)
                  PPJ(JILT,9)
               %FINISH
            %FINISH
         %FINISH %ELSE %START
            GET WSP(D,1);                ! temporary
            %IF CURRT_FLAGS&LOADOP2=0 %START; ! RHS(OP 2) FN OR MAP
               DSTORE(1,ESTORE,4,CURRINF_RBASE,D,0)
            %FINISH
            %if 1<<TARGET&LINTAVAIL#0 %then Eop(ESPLITD)
            %IF PARM_OPT#0 %THEN EOP(EXCH) %ELSE EOP(DISCARD)
                                         ! MAX LEN TO BTM FOR CHK OR DISCARDED
            %IF CURRT_FLAGS&LOADOP2=0 %THEN %C
               DFETCH(1,4,CURRINF_RBASE,D,0) { retrieve temp} %ELSE %START
               LRES=LOAD(OPND2,0)
               DSTORE(1,EDUPSTORE,4,CURRINF_RBASE,D,0); ! SOURCE BYTE ADDRE TO REG
            %FINISH
            EOP(EXCH);                   ! DEST OVER SOURCE FOR MVB
            DFETCH(1,4,CURRINF_RBASE,D,0); ! FURTHER COPY OF SOURCE
            EREFER(0,x'03000001')
            %IF PARM_OPT#0 %THEN %START
               GET WSP(TEMPLOC,1);       ! extra temporary reuse confuses ecode rts
               DSTORE(1,EDUPSTORE,4,CURRINF_RBASE,TEMPLOC,0)
            %FINISH
            ESTKLIT(1); EOP(IADD);       ! ASSIGN
            EOP(MVB)
            %IF PARM_OPT#0 %START;       ! CHECK LENGTH
               DFETCH(1,4,CURRINF_RBASE,TEMPLOC,0); ! RETRIEVE CURRENT LENGTH
               PPJ(JILT,9)
            %FINISH
         %FINISH
         %CONTINUE
TRIPSW(40):                              ! SIMPLE STRING ASSIGN
                                         ! LHS A SIMPLE STRING
         TCELL==ASLIST(TAGS(OPND1_D))
         %IF OPND2_FLAG=LCONST %AND OPND2_XTRA<TCELL_ACC %START
            %IF OPND2_XTRA=0 %START;     ! NULL STRING ASSIGN
               ESTKLIT(0)
               D=STRINGLBAD(TCELL)
               DFETCHAD(1,TCELL_UIOJ>>4&15,D&X'FFFF',0)
               EREFER(0,x'01000002'); EOP(ESTORE)
            %FINISH %ELSE %START;        ! ASSIGN CONSTANT STRING
               LRES=LOAD(OPND2,0)
               LRES=LOAD(OPND1,64)
               ESTKLIT(OPND2_XTRA+1)
               EOP(MVB)
            %FINISH
            %CONTINUE
         %FINISH
         LRES=LOAD(OPND2,0)
         EOP(DUPL);
         LRES=LOAD(OPND1,64)
         EOP(EXCH); EREFER(0,x'03000001'); ! LENGTH OF RHS
         %IF PARM_OPT#0 %AND TCELL_ACC<256 %START
            ESTKLIT(0)
            ESTKLIT(TCELL_ACC-1);        ! LMAX
            EOP(CHK)
         %FINISH
         ESTKLIT(1)
         EOP(IADD)
         EOP(MVB)
         %CONTINUE
TRIPSW(41):                              ! STRING JT VIA SUBROUTINE
         EPRECALL2(WORKA_PLABS(18),addr(pardes(9)))
         LRES=LOAD(OPND1,0);             ! SET BY GETPTR (IE LOADED)
         LRES=LRES<<1!LOAD(OPND2,0);     ! MAY OR MAY NOT NEED LOADING
         %IF LRES=B'10' %THEN %start
            %if 1<<TARGET&LINTAVAIL#0 %then EPROMOTE(2) %else EPROMOTE(3)
         %finish
         EOP(PUSHVAL)
         %if 1<<TARGET&LINTAVAIL#0 %then Eop(ESPLITD)
         EOP(PUSHVAL); EOP(PUSHVAL)
         PPJ(0,18)
         %CONTINUE
TRIPSW(46):                              ! STRING COMPARISONS INCL DSIDED
         BFFLAG=0
         %IF OPND2_FLAG=LCONST %AND OPND2_XTRA=0 %THEN OPND==OPND1 %AND ->NULLSC
         %IF OPND1_FLAG=LCONST %AND OPND1_XTRA=0 %THEN %C
            OPND==OPND2 %AND BFFLAG=1 %AND ->NULLSC
         %IF CURRT_FLAGS&LOADOP2#0 %START; ! OPND2 NOT LOADED
            LRES=LOAD(OPND1,0) %UNLESS currt_flags&loadop1=0
            LRES=LOAD(OPND2,0)
         %FINISH %ELSE %IF CURRT_FLAGS&LOADOP1=0 %START; ! BOTH LOADED
         %FINISH %ELSE %START;           ! ONLY 2 LDED BACK COMP
            BFFLAG=1
            LRES=LOAD(OPND1,0)
         %FINISH
         D=FCOMP(XTRA+16*BFFLAG)
         %IF D=IEQ %OR D=INE %START;     !   COMMON CASES IN LINE
            EOP(DUPL)
            EREFER(0,x'03000001')
            ESTKLIT(1)
            EOP(IADD)
            D=D+CPBEQ-IEQ
         %FINISH %ELSE %START
            EPRECALL2(WORKA_PLABS(28),addr(pardes(5)))
            EOP(PUSHVAL); EOP(PUSHVAL)
            PPJ(0,28)
            ESTKLIT(0);                  ! RETURNED AS DIFFERENCE FROM ZERO
         %FINISH
         EOP(D)
         %CONTINUE
NULLSC:                                  ! TEST FOR A NULL STRING
         LRES=LOAD(OPND,0)
         EREFER(0,x'03000001'); ESTKLIT(0); EOP(FCOMP(XTRA+16*BFFLAG))
         %CONTINUE

TRIPSW(47):                              ! PRE RESOLUTION 1
                                         ! OPND1 IS 4 WORD WK AREA
                                         ! OPND2 IS STRING BEING RESLVD
                                         ! IN PNX WORK AREA IS USED AS FOLLOWS
                                         ! W1 WORD ADDRESS OF STRING BEING RESOLVED
                                         ! W2 ORIGINAL LENGTH! BYTES USED<<16
                                         ! W3&4 WORKSPACE
         D=OPND1_D&X'FFFF'
         LRES=LOAD(OPND2,0);             ! 32 BIT ADDRESS TO ESTACK
         DSTORE(1,EDUPSTORE,4,CURRINF_RBASE,D,0); ! 32 BIT ADDR TO WK AREA
         EREFER(0,x'03000001')
         Estklit(4); Eop(CVTui)
         DSTORE(1,ESTORE,4,CURRINF_RBASE,D+4,0); ! WHOLE LENGTH STILL AVAILABLE
                                         ! 0 BYTES USED UP SO FAR
         %CONTINUE
TRIPSW(48):                              ! PRE RESOLUTION 2
                                         ! OPND1 IS 4 WORD WK AREA
                                         ! OPND2 IS POINTER TO STRING TO HOLD
                                         ! FRAGMENT OR ZERO(=DISCARD FRGMNT)
         D=OPND1_D&X'FFFF'
         EPRECALL2(WORKA_PLABS(16),addr(pardes(20)))
         DFETCHAD(4,CURRINF_RBASE,D+4,0)
         DFETCH(1,4,CURRINF_RBASE,D,0)
         EOP(PUSHVAL);                   ! RESLN STRING ADDR STACKED
         EOP(PUSHVAL);                   ! POINTER TO BYTES USED IS STCKD
         %IF OPND2_FLAG=SCONST %START;   ! NO STRING FOR FRAGMENT
            ESTKLIT(0); ESTKLIT(0);      ! TWO ZERO WORD
         %ELSE
            LRES=LOAD(OPND2,0); ! OR 2 POINTER WORDS
            %if 1<<TARGET&LINTAVAIL#0 %then Eop(ESPLITD)
         %FINISH
         EOP(PUSHVAL); EOP(PUSHVAL);     ! ARE STACKED
         %CONTINUE
TRIPSW(49):                              ! RESOLUTION
                                         ! OPND1 IS STRING RES EXPR
                                         ! OPND2 IS LABEL NO
         LRES=LOAD(OPND1,0)
         EOP(PUSHVAL)
         PPJ(0,16)
         %IF OPND2_D=0 %THEN PPJ(JINTZ,12); ! UNCONDITIONAL FAILS
                                         ! NDAIG PARAMETER LEFT BY SUBROUITNE
         %CONTINUE
TRIPSW(60):                              ! RESFN FINAL POST RES ASSIGN
                                         ! OPND2 HAS POINTER
                                         ! SINCE RESOLVED STRING MAY BE CONST
                                         ! CAN NOT USE NORMAL ASSIGN
         LRES=LOAD(OPND2,64);            ! POINTER TO NEST
         %if 1<<TARGET&LINTAVAIL#0 %then Eop(ESPLITD)
         D=OPND1_D&X'FFFF';              ! TO 4 WORD WK AREA
         %IF PARM_OPT#0 %THEN EOP(EXCH) %ELSE EOP(DISCARD)
                                         ! MAX LEN TO BTM FOR CHK OR DISCARDED
         EOP(DUPL);                      ! DEST(TWICE) OVER LMAX
         DFETCH(1,4,CURRINF_RBASE,D,0)
         DFETCH(1,4,CURRINF_RBASE,D+4,0)
         GET WSP(C,1)
         ESTKLIT(16); EOP(ISHRL);        ! BYTES USED
         DSTORE(1,EDUPSTORE,4,CURRINF_RBASE,C,0)
         EOP(IADD)
         EOP(EXCH)
         DFETCH(1,4,CURRINF_RBASE,D+4,0)
         ESTKLIT(x'ffff')
         EOP(IAND)
         DFETCH(1,4,CURRINF_RBASE,C,0);  ! fetch back bytes used
         EOP(ISUB);                      ! and subtract from orig
         DSTORE(1,EDUPSTORE,4,CURRINF_RBASE,C,0)
         ESTKLIT(1); EOP(IADD)
         EOP(MVB);                       ! call move overlapping

         DFETCH(1,4,CURRINF_RBASE,C,0); estklit(4); eop(cvtii); EOP(EXCH)
         EREFER(0,x'03000001')
         EOP(ESTORE);                    ! store length using 2nd copy of dest
         %IF PARM_OPT#0 %START
            DFETCH(1,4,CURRINF_RBASE,C,0)
            PPJ(JILT,9);                 ! capacity exceeded
         %FINISH
         %CONTINUE
TRIPSW(68):                              ! sindx index string for charno
                                         ! on all m-cs with consistent byte addressing
                                         ! this is the same as aindx
         LRES=LOAD(OPND1,64);            ! the base address of string
         %IF CURRT_FLAGS&LOADOP2#0 %START; ! offset needs loading
            %UNLESS OPND2_FLAG=SCONST %AND OPND2_D=0 %START
                                         ! LENGTH = 0 OFFSET
               LRES=LOAD(OPND2,0)
               EOP(index1)
            %FINISH
         %ELSE
            EOP(EXCH) %IF lres#0
            EOP(index1)
         %FINISH
         CURRT_OPTYPE=X'51';             ! 32 BIT ADDRESS MAY NEED SAVING
         ->STRES
!***********************************************************************
!*    THIS NEXT SECTION DEALS WITH ROUTINE CALLS AND PARAMETER         *
!*    PASSING. ALSO STORING AND RECOVERY OF FN & MAP RESULTS           *
!***********************************************************************
TRIPSW(23):                              ! IOCP CALL
         d=opnd2_d;                      ! -1 for skip symbol
         LRES=LOAD(OPND2,0)
         CIOCP(OPND1_D,D);               ! ALWAYS CONSTANTS
         OPND1_FLAG=9;                   ! FOR WHEN RES NEEDED
         OPND1_XB=ESTK
         %CONTINUE
TRIPSW(24):                              ! PRECALL OPND1 HAS RT NAME
         TCELL==ASLIST(TAGS(OPND1_D))
         %IF TCELL_SNDISP=0 %AND TCELL_PTYPE&x'400'=0 {not formal} %THEN %start
            %if CGinC=No %start
               TCELL_SNDISP=ENEXTPROC2(string(addr(worka_lett(worka_word(opnd1_d)))),4{local})
            %else
               TCELL_SNDISP=ENEXTPROC2(Cstring(string(addr(worka_lett(worka_word(opnd1_d))))),4{local})
            %finish
         %finish
         D=TCELL_SLINK
         %IF D#0 %THEN D=ASLIST(D)_SNDISP; ! FIRST PARAM OFFSET
         PTYPE=TCELL_PTYPE
         C=(CURRT_DPTH+1)>>1;            ! DEPTH IN PAIRS
         D=0
         PUSH(FPHEAD,FPPTR,C,D)
         EPRECALL2(TCELL_SNDISP,pardeslist(tcell))
         FPPTR=0
         %CONTINUE
TRIPSW(25):                              ! ROUTINE CALL (AFTER PARAMS)
                                         ! OPND1 HAS RT NAME
         TCELL==ASLIST(TAGS(OPND1_D))
         JJ=0
         %IF TCELL_SLINK#0 %THEN JJ=ASLIST(TCELL_SLINK)_S3&255 {n params}
         %IF TCELL_UIOJ&15=14 %START;    ! EXTERNAL CALL
            ECALL2(TCELL_SNDISP,1,JJ,FPPTR)
         %FINISH %ELSE %IF TCELL_PTYPE&X'400'#0 %START
            %if Target=DRS %start;         ! two words expected
               FETCH HIGH AD END(TCELL_UIOJ>>4&15,TCELL_SNDISP,0) {env}
               FETCH LOW AD END(TCELL_UIOJ>>4&15,TCELL_SNDISP,0) {addr}
            %finish %else DFETCH(1,4,TCELL_UIOJ>>4&15,TCELL_SNDISP,0) { proc desc}
            ESTKLIT(FPPTR)
            EOP(ARGPROC);                ! CALL FORMAL PROCEDURE
         %FINISH %ELSE %START
            C=TCELL_UIOJ>>4&15
!            %IF C>0 %THEN PI1(ILL,-4*(C+1));! DISPLAY PTR FOR INTERNAL RTS
            D=TCELL_SNDISP
            ECALL2(D,C+1,JJ,FPPTR)
         %FINISH
         POP(FPHEAD,FPPTR,STACKATCALL,SKEY)
                                         !the estack restore is done after recovering
                                         ! the fn or map result. there is never anything
                                         ! in the estack for routine call
         %CONTINUE
TRIPSW(44):                              ! MAP RESULT ASSIGNMENT
                                         ! CALLED BEFORE RETURN TO CALLER
         LRES=LOAD(OPND2,0)
         EOP(EINTRES)
         %CONTINUE
TRIPSW(45):                              ! FN RESULT ASSIGNMENT
                                         ! CALLED BEFORE RETURN TO CALLER
         %IF params bwards=yes %THEN D=P2 %ELSE d=currinf_psize-4
         LRES=LOAD(OPND2,0)
         %IF OPND2_PTYPE&7=5 %START;     ! STRING FN RESULTS
            EOP(DUPL); EREFER(0,x'03000001')
            ESTKPAR(0,D,0,4); EOP(EXCH); ! The second parameter offset is model dependent
            ESTKLIT(1); EOP(IADD); EOP(MVB)
            ESTKPAR(0,D,0,4);            ! THE "RESULT"
            EOP(EINTRES)
            %CONTINUE
         %FINISH
         %IF Opnd1_ptype&7=3 %START;     ! record functions
            estkpar(0,D,0,4)
            tcell==aslist(tags(opnd1_d))
            estklit(Tcell_acc)
            Eop(MVB)
            estkpar(0,D,0,4)
            eop(eintres)
            %CONTINUE
         %FINISH
         %UNLESS OPND2_PTYPE&7=2 %THEN EOP(EINTRES) %ELSE EOP(EREALRES)
         %CONTINUE
TRIPSW(26):                              ! RECOVER FN RESULT
                                         ! CALLED AFTER RETURN TO CALLER
         OPND1_FLAG=9; OPND1_XB=ESTK
         c=opnd1_ptype&7
         %IF c>=3 %THEN estkresult(0,0,4) {addr of length 4} %ELSE %C
            ESTKRESULT(0,C,BYTES(OPND1_PTYPE>>4&15))
         ->stres
TRIPSW(27):                              ! RECOVER MAP RESULT
                                         ! CALLED AFTER RETURN TO CALLER
         OPND1_FLAG=9
         OPND1_XB=ESTK
         ESTKRESULT(0,1,4)
         ->stres
TRIPSW(28):                              ! PASS PARAMETER(1)= NORMAL VALUE
         LCELL==ASLIST(OPND1_XTRA&X'FFFF'); ! PARAM DESCTR CELL
         D=LCELL_ACC;                    ! PARAM_ACC
         %IF OPND1_PTYPE&7=5 %START;     ! STRINGS BY VALUE - LABORIOUS
            C=(D+3)&(-4);                ! WORDS FOR STRING VALUE
            FPPTR=FPPTR+C
            LRES=LOAD(OPND2,0);          ! PTR TO STRING
            %IF PARM_OPT#0 %AND D<256 %START
               EOP(DUPL); EREFER(0,x'03000001'); ! LENGTH FROM DEST
               ESTKLIT(0)
               ESTKLIT(D-1);             ! FOR ASSNMNT CHECK
               eop(CHK); EOP(DISCARD)
            %FINISH
            ESTKLIT(C)
            EOP(PUSHBYTES)
         %FINISH %ELSE %IF OPND1_PTYPE&7=3 %START; ! RECORD BY VALUE
            C=(D+3)&(-4)
            %IF fpptr&3=2 %START
!               estklit(0); estklit(2); eop(cvtii)
!               eop(pushval)
               fpptr=fpptr+2       { BACKEND SHOULDNOW SORT ALIGNMEMNT }
            %FINISH
            %IF OPND2_FLAG=SCONST %THEN %START
!               %FOR D=4,4,C %CYCLE
                  Estklit(0); Eop(Pushval)   { AGAIN BACKEND SHOULD SORT THIS }
!               %REPEAT
            %ELSE
               LRES=LOAD(OPND2,0)
               %IF c=4 %THEN Erefer(0,X'01000004') %AND Eop(PUSHVAL) %ELSE %START
                  ESTKLIT(C); EOP(Pushbytes)
               %FINISH
            %FINISH
            FPPTR=FPPTR+C
         %FINISH %ELSE %START
            LRES=LOAD(OPND2,0)
            C=OPND1_PTYPE
            %IF C=X'62' %THEN %START
               %IF longs aligned=yes %AND fpptr&7=4 %START
!                  Estklit(0); Eop(PUSHVAL)
                  Fpptr=Fpptr+4
               %FINISH
               EOP(PUSHVAL)
               FPPTR=FPPTR+8
            %FINISH %ELSE %IF C=X'52' %THEN %START
               EOP(PUSHVAL)
               FPPTR=FPPTR+4
            %FINISH %ELSE %START
               %IF C=X'31' %or c=x'41' %start
                  estklit(4);  EOP(CVTII)
                  %if 1<<Target&Byteswopped#0 %start
                     %if c=x'31' %then c=24 %else c=16
                     Estklit(c); Eop(ishll)
                  %finish
                  c=x'51'
               %finish
               EOP(PUSHVAL)
               FPPTR=FPPTR+bytes(c>>4)
            %FINISH
         %FINISH
         %CONTINUE
TRIPSW(29):                              ! GET 32 BIT ADDRESS
         LOADAD(OPND1)
         ->STRES
TRIPSW(30):                              ! GET POINTER FOR %NAME
         LOADPTR(OPND1,OPND2)
         ->STRES
TRIPSW(31):                              ! PARAM PASSING (2) NORMAL PTRS
         %if (Target=DRS) %and currt_opern=PASS4 %then ->tripsw(32) {DRS formal procs}
         LRES=LOAD(OPND2,0)
         PTYPE=OPND1_PTYPE&255;          ! FOR PARAM
         %IF PTYPE=X'35' %START;         ! STRING(2 WORD) PTRS
            %if 1<<TARGET&LINTAVAIL#0 %then Eop(ESPLITD)
            FPPTR=FPPTR+4
            EOP(EXCH) %IF params bwards=yes
            EOP(PUSHVAL)
         %FINISH
         EOP(PUSHVAL)
         FPPTR=FPPTR+4
         %CONTINUE
TRIPSW(32):                              ! PARAM PASSING(3) ARRAYS
         %IF longs aligned=yes %AND fpptr&7#0 %START
!            Estklit(0); EOP(PUSHVAL)
            fpptr=fpptr+4
         %FINISH
                                         ! ALSO (4) PASS RT PARAM SAME CODE
                                         !  when rt params are 64 bits in size
         LRES=LOAD(OPND2,0)
         %if 1<<TARGET&LINTAVAIL#0 %then Eop(ESPLITD)
         EOP(EXCH) %IF PARAMS BWARDS=YES
         EOP(PUSHVAL); EOP(PUSHVAL)
         FPPTR=FPPTR+8
         %CONTINUE
TRIPSW(69):                              ! PASS 6 STORE STR FN RES PTR
                                         ! OPND2_D HAS OFFSET
         LRES=LOAD(OPND2,64)
         ESTKLIT(255)
         ESTKLIT(4); EOP(CVTII);         ! as 4 byte integer
         %IF PARAMS BWARDS=YES %THEN EOP(EXCH)
         EOP(PUSHVAL); EOP(PUSHVAL)
         FPPTR=FPPTR+8
         %CONTINUE
TRIPSW(63):                              ! RTFP TURN RTNAME INTO FORMAL
         TCELL==ASLIST(TAGS(OPND1_D))
         %IF TCELL_PTYPE&X'400'#0 %START; ! NAM>0 PASS A FORMAL
            DFETCH(1,4,TCELL_UIOJ>>4&15,TCELL_SNDISP,0)
         %FINISH %ELSE %START
            %IF tcell_uioj&15=14 %THEN c=0 %ELSE C=TCELL_UIOJ>>4&15
            D=TCELL_SNDISP
            %IF D=0 %THEN %start
               %if CGinC=NO %start
                  D=ENEXTPROC2(string(addr(worka_lett(worka_word(opnd1_d)))),4{local})
               %else
                  D=ENEXTPROC2(Cstring(string(addr(worka_lett(worka_word(opnd1_d))))),4{local})
               %finish
               TCELL_SNDISP=D
            %finish
            EPROCREF(D,C);               ! This puts ptr to proc in estack
         %FINISH
         %CONTINUE
TRIPSW(66):                              ! TYPE GENERAL PARAMETER
                                         ! OPND1 THE ACTUAL
                                         ! OPND2 HAS PTYPE&ACC
         %IF OPND1_FLAG=DNAME %AND OPND1_PTYPE&15=0 %START
            TCELL==ASLIST(TAGS(OPND1_D))
            DFETCH(1,8,TCELL_UIOJ>>4&15,TCELL_Slink&X'ffff',0)
         %FINISH %ELSE %IF opnd2_d&7=5 %AND opnd2_d&X'c00'#0 %START
                                         ! string name to type general
            lres=load(opnd1,0)
            %if 1<<TARGET&LINTAVAIL#0 %then Eop(ESPLITD)
            Eop(EXCH)
            Estklit(16); Eop(ISHLL)
            Estklit(Opnd2_d&255); Eop(IOR)
            %if 1<<TARGET&LINTAVAIL#0 %then Eop(EMAKED) %else %IF Params bwards=no %THEN eop(EXCH)
         %FINISH %ELSE %START
            LRES=LOAD(OPND1,0);          ! 32 BIT ADDRESS
            ESTKLIT(OPND2_D)
            %if 1<<TARGET&LINTAVAIL#0 %then Eop(EMAKED) %else %IF Params bwards=no %THEN eop(EXCH)
         %FINISH
         %CONTINUE
!***********************************************************************
!*    SECTION TO DEAL WITH SWITCHES INCLUDING ->SW(EXP)                *
!***********************************************************************
TRIPSW(33):                              ! DECLARE SWITCH OPND2 HAS BNDS
         TCELL==ASLIST(TAGS(OPND1_D))
         TCELL_SNDISP=GLABEL;            ! LABEL FOR SWITCH REFS
         ESWITCH(OPND2_D,OPND2_XTRA,GLABEL,GLABEL+1,CAS(4))
         ELABEL(GLABEL+1)
         GLABEL=GLABEL+2
         %IF PARM_OPT#0 %THEN %START
            Eprecall2(Worka_plabs(2),addr(pardes(14)))
            ESTKLIT(0)
            ESTKLIT(X'802')
            %IF PARAMS BWARDS=yes %THEN EOP(EXCH)
            EOP(PUSHVAL)
            EOP(PUSHVAL)
            PPJ(0,2)
         %FINISH
                                         ! ERROR EXIT AFTER TABLE
         %CONTINUE
TRIPSW(34):                              ! SET SWITCH LABEL(OPND2)
         TCELL==ASLIST(TAGS(OPND1_D))
         LCELL==ASLIST(TCELL_SLINK);     ! SIDECHAIN HAS TDISP LB&UB
         ESWITCHENTRY(TCELL_SNDISP,OPND2_D); ! REFS  REL TO ACTUAL START
         %CONTINUE
TRIPSW(35):                              ! GOTO SW LABEL
         TCELL==ASLIST(TAGS(OPND1_D))
         LCELL==ASLIST(TCELL_SLINK)
         C=LCELL_S2;                     ! ADJUST TO START OF 0
         LRES=LOAD(OPND2,0)
         ESWITCHJUMP(TCELL_SNDISP);      ! JUMP TO INDEXED JUMP
         %CONTINUE
TRIPSW(37):                              ! REAL TO INTGER INTPT(OPND1)
         LRES=LOAD(OPND1,0)
         ESTKLIT(Bytes(currt_optype>>4))
         EOP(EFLOOR)
         OPND1_XB=0
         OPND1_PTYPE=Currt_Optype
         %CONTINUE
TRIPSW(36):                              ! REAL TO INTEGER AS INT
         LRES=LOAD(OPND1,0)
         ESTKLIT(bytes(Currt_optype>>4)); EOP(RNDRI)
         OPND1_XB=0
         OPND1_PTYPE=Currt_Optype
         %CONTINUE
TRIPSW(78):                              ! REAL to INT as TRunc
         LRES=LOAD(OPND1,0)
         ESTKLIT(bytes(Currt_optype>>4))
         EOP(TNCRI)
         OPND1_XB=0
         OPND1_PTYPE=Currt_Optype
         %CONTINUE
TRIPSW(38):                              ! INTEGER TO STRING AS TOSTRING
         GET WSP(D,1)
         LRES=LOAD(OPND1,0)
          %if Stack Down=Yes %then DSTORE(1,ESTORE,1,CURRINF_RBASE,D+2,0) %c
         %else DSTORE(1,ESTORE,1,CURRINF_RBASE,D+1,0)
         ESTKLIT(1)
         %if Stack Down=Yes %then DSTORE(1,ESTORE,1,CURRINF_RBASE,D+3,0) %c
           %else DSTORE(1,ESTORE,1,CURRINF_RBASE,D,0)
         OPND1_FLAG=LOCALIR
         OPND1_PTYPE=X'35'
         OPND1_D=CURRINF_RBASE<<16!D
         OPND1_XTRA=4;                   ! LENGTH OF TEMP SPACE
         %CONTINUE
TRIPSW(42):                              ! ARRAYHEAD ASSIGNMENT
         OPND2_PTYPE=X'61';              ! SO LOAD LOADS HEAD NOT ELEMNT
         %IF OPND1_FLAG=DNAME %START;    ! LHS IN LOCAL SPACE
            LRES=LOAD(OPND2,0)
            TCELL==ASLIST(TAGS(OPND1_D))
            C=TCELL_SLINK
            %IF TCELL_PTYPE&X'3FFF'=X'33' %THEN %C
               C=RECORDELAD(TCELL,OPND1_PTYPE,OPND1_XTRA)
            DSTORE(1,ESTORE,8,TCELL_UIOJ>>4&15,C&X'ffff',0)
         %FINISH %ELSE %START
            IMPABORT %UNLESS OPND1_FLAG=INDIRECT %OR OPND1_FLAG=REFTRIP %OR %C
               OPND1_FLAG=INDNAME %OR PARM_FAULTY#0
            LRES=LOAD(OPND2,0)
            %IF OPND1_FLAG=REFTRIP %OR OPND1_FLAG=INDIRECT %THEN EPROMOTE(3)
            %IF OPND1_FLAG=INDIRECT %AND OPND1_XTRA>0 %START
               ESTKLIT(OPND1_XTRA)
               EOP(IADD)
            %FINISH
            %IF OPND1_FLAG=INDNAME %THEN LOADAD(OPND1)
            INDSTORE(1,8,0)
         %FINISH
         %CONTINUE
TRIPSW(43):                              ! POINTER ASSIGNMENT
         D=BYTES(CURRT_OPTYPE>>4)
         LRES=LOAD(OPND2,0)
         %IF OPND1_FLAG=DNAME %START;    ! LOCAL PTR
            TCELL==ASLIST(TAGS(OPND1_D))
            C=TCELL_SLINK
            %IF TCELL_PTYPE&X'3FFF'=X'33' %THEN %C
               C=RECORDELAD(TCELL,OPND1_PTYPE,OPND1_XTRA)
            DSTORE(1,ESTORE,D,TCELL_UIOJ>>4&15,C&X'ffff',0)
            %CONTINUE
         %FINISH
         %IF OPND1_FLAG=INDNAME %THEN LOADAD(OPND1) %ELSE %START
            %UNLESS CURRT_FLAGS&LOADOP1=0 %START; ! DEST NOT LOADED
               LRES=LOAD(OPND1,0)
            %FINISH %ELSE EPROMOTE(1+d>>2)
            %IF OPND1_FLAG=INDIRECT %AND OPND1_XTRA>0 %THEN %C
               ESTKLIT(OPND1_XTRA) %AND EOP(index1)
         %FINISH
         INDSTORE(1,D,0)
         %CONTINUE
TRIPSW(62):                              ! RECORD ASSIGNMENT
         %IF OPND2_FLAG=SCONST %THEN %START
            LRES=LOAD(OPND1,0)
            BULKM(0,XTRA,OPND2_D)
            %CONTINUE
         %FINISH
         LRES=LOAD(OPND2,0)
         %IF CURRT_FLAGS&LOAD OP1=0 %THEN JJ=EXCHANGE(OPND1,OPND2)
         LRES=LOAD(OPND1,0)
         %if xtra&x'ff000000'=0 %or xtra&3#0 %start
            Estklit(XTRa); Eop(MVB)
         %else
            Estklit((XTRa&x'ffffff')>>2) %and Eop(MVW)
         %finish
         %CONTINUE
TRIPSW(64):                              ! AAINC INCREMENT RECORD RELATIVE
                                         ! ARRAY ACCESS BY RECORD BASE(OPND1)
                                         ! TO GIVE ABSOLUTE ACCESS.
         LRES=LOAD(OPND1,0)
         LRES=LOAD(OPND2,0);             ! THE RELATIVE ACCESS
         EOP(index1);                    ! ADDITION
         ->STRES
TRIPSW(65):                              ! AHADJ ARRAY MAPPING OPND1 1
                                         ! HAS ADJUSTMENT OPND2 THE HEAD
                                         ! ARRAY PTYPE<<4!MODE IS IN XTRA
         LRES=LOAD(OPND1,0);             ! LOAD NEW BASE
         JJ=-1
         %IF OPND2_FLAG=DNAME %START
            TCELL==ASLIST(TAGS(OPND2_D))
            JJ=TCELL_SLINK; D=TCELL_UIOJ>>4&15
            %IF TCELL_PTYPE&X'3FFF'=X'33' %THEN %C
               JJ=RECORDELAD(TCELL,OPND2_PTYPE,OPND2_XTRA)
         %FINISH
         %IF OPND2_FLAG=7 %THEN JJ=OPND2_D&X'FFFF' %AND D=OPND2_D>>16
         %IF JJ#-1 %START;               ! HEAD ACCESSIBLE AVOID COMPLEX
                                         ! ESTACH MANIPULATIONS
            jj=jj&x'ffff'
            %IF XTRA&1=0 %THEN %START
               FETCH LOW AD END(D,JJ,0)
            %FINISH %ELSE %START
               FETCH HIGH AD END(D,JJ,0)
               EOP(IADD)
               FETCH LOW AD END(D,JJ,0)
            %FINISH
            %if 1<<TARGET&LINTAVAIL#0 %then Eop(EMAKED)
            %CONTINUE
         %FINISH
         LRES=LOAD(OPND2,0);             ! ARRAY HEAD BEFORE ADJMNT

         %if 1<<TARGET&LINTAVAIL#0 %then Eop(ESPLITD)
         %IF XTRA&1=0 %START;            ! ARRAY MAPPING OPND1 IS BASE
            EOP(EXCH); EOP(DISCARD);     ! DISCARD OLD BASE
         %FINISH %ELSE %START
            EOP(EXCH)
            EPROMOTE(3)
            EOP(IADD);                   ! ADDRESSES ADDED
            EOP(EXCH)
         %FINISH

         %if 1<<TARGET&LINTAVAIL#0 %then Eop(EMAKED)
         %CONTINUE
TRIPSW(73):                              ! on event1 On entering the routine
         %IF aux stack=yes %THEN Eop(EAUXSF) %ELSE Eop(SFA)
         Dstore(1,Estore,4,currinf_rbase,currinf_oninf+12,0)
         %CONTINUE
TRIPSW(74):                              ! on event2 at the re-entry point
         Glaca=(Glaca+3)&(-4)
         Eglabel(Glabel,Currlevel,Glaca);  ! Fixes word at Glaca to point to Glabel at CA
         Glabel=Glabel+1
         Currinf_Onword=Currinf_Onword!Glaca; ! Offset of resumption address
         Glaca=Glaca+4
         Estkresult(0,2,8);              !  8 Bytes set by Oncond
         Dstore(2,Estore,8,currinf_rbase,currinf_oninf,0); ! and stored
         Dfetch(1,4,currinf_Rbase,Currinf_Oninf+12,0); ! Stack front
         Eop(Eauxres);                   ! Is restored to value saved at TRIPSW(73)
         %CONTINUE
TRIPSW(75):                              ! Signal event spring a soft trap
                                         ! opnd1_d has thge level (constant)
                                         ! opnd2 is the event & subevent combined
         linf==worka_levelinf(opnd1_d)
         %IF linf==currinf %OR currinf_flag<=2 %START
                                         ! Right level or only begin block exit
            %IF linf##currinf %START;    ! Force begin block exit
               D=Estkmarker;             ! By changing diags pointer(cf tripsw(17))
               push(Linf_ral,1,D,0)
               dstore(1,estore,2,Linf_rbase,Linf_diaginf,0)
            %FINISH
                                         ! Now to ndiags via monitor exit
            Eprecall2(Worka_plabs(2),addr(pardes(14)))
            lres=load(opnd2,0)
            Estklit(0)
            %IF PARAMS Bwards=No %THEN Eop(EXCH)
            eop(Pushval)
            eop(Pushval)
            PPJ(0,2)
            %CONTINUE
         %FINISH
                                         ! Must force a routine exit before signalling
                                         ! so call ndiags directly giving a faked LNB
         D=Known Xref(1);                ! Ndiags reference
         Eprecall2(D,addr(pardes(14)))
         lres=Load(opnd2,0)
         Eop(Pushval)
         Estklit(0)
         Eop(Pushval)
         Eop(EOLDLNB)
         Eop(Pushval)
         Estklit(0)
         Eop(Pushval)
         Ecall2(D,1,4,16);               ! does not return
         %CONTINUE
TRIPSW(79):                              ! Pprofile output profiling info
         Eprecall2(Known xref(6),addr(pardes(2)))
         Estkaddr(Gla,profgla,0,4)
         Eop(Pushval)
         Ecall2(Known xref(6),1,1,4)
         %CONTINUE
!***********************************************************************
!*    SECTION FOR GENERATING CODE FOR INLINE ASSEMBLER                 *
!***********************************************************************
TRIPSW(50):                              ! UC NOOP
!         CNOP(OPND1_D>>8,OPND1_D&255)
         %CONTINUE
TRIPSW(51):                              ! UCB1 ONE BYTE ASSEMBLER
         EOP(OPND1_D)
         %CONTINUE
TRIPSW(52):                              ! UCB2 TWO BYTE ASSEMBLER
         Estklit(OPND1_D);               ! FOR *PUTS ALSO
         %IF opnd1_d>>16=0 %THEN jj=2 %ELSE jj=4
         Estklit(jj)
         Eop(HALT)
         %CONTINUE
TRIPSW(53):                              ! UCB3 3 BYTE ASSEMBLER
!         PI2(OPND1_D>>16,OPND1_D>>8&255,OPND1_D&255)
         %CONTINUE
TRIPSW(54):                              ! UCW ASSEMBLER WITH WORD OPERAND
         ESTKLIT(OPND1_XTRA)
         %CONTINUE
TRIPSW(55):                              ! UCBW BYTE&WORD OPERAND ASSEMBLER
!         PI2(OPND1_D>>24,OPND1_D>>16&255,OPND1_D&X'FFFF')
         %CONTINUE
TRIPSW(59):                              ! UCNAM ACCESS TO NAMES FROM U-C
         D=OPND1_D>>16
         JJ=OPND1_D&X'FFFF'
         TCELL==ASLIST(TAGS(JJ))
         %IF TCELL_PTYPE&X'3F00'=0 %THEN C=BYTES(TCELL_PTYPE>>4&15) %ELSE C=4
         JJ=assemblerrefad(TCELL,OPND1_XTRA) {adds or subtracts any ref }
                                          { allowing for stack bwards etc }
         %IF D=1 %THEN DFETCHAD(C,TCELL_UIOJ>>4&15,JJ,0) %ELSE %IF D=2 %THEN %C
            DSTORE(1,ESTORE,C,TCELL_UIOJ>>4&15,JJ,0) %ELSE %C
            DFETCH(1,C,TCELL_UIOJ>>4&15,JJ,0)
         %CONTINUE
STRES:
         CURRT_OPTYPE<-OPND1_PTYPE
         %IF CURRT_CNT>1 %AND CURRT_OPERN#LASS %START; ! USED MORE THAN ONCE
                                         ! AND NOT ALREADY STORED
            %IF CURRT_FLAGS&USE ESTACK#0 %START; ! IMPLIES _CNT=2 %AND TYPE=1
               EOP(DUPL)
            %FINISH %ELSE %START
               %IF OPND1_PTYPE&7>2 %THEN C=4 %ELSE C=BYTES(OPND1_PTYPE>>4&15)
               D=C
               %IF C<4 %THEN C=4
!               %IF D<2 %THEN D=2
               GET WSP(TEMPLOC,C>>2)
!
! strings do not expect i-r left in estack since this leads to jumps
! with estack no empty. see code at load sw(8)
!
               %if opnd1_ptype&15=5 %then  %start
                  %if currt_puse#0 %Start
                     workt==triples(currt_puse)
                     %if workt_opnd1_flag=reftrip %and workt_opnd1_d=wtripno %c
                         %then workt_flags=workt_flags!LOAD OP1
                     %if workt_opnd2_flag=reftrip %and workt_opnd2_d=wtripno %c
                         %then workt_flags=workt_flags!LOAD OP2
                    %finish
                  jj=ESTORE 
               %finish %else jj=EDUPSTORE
               DSTORE(OPND1_PTYPE&7,jj,D,CURRINF_RBASE,TEMPLOC,0)
               OPND1_D=CURRINF_RBASE<<16!TEMPLOC
               OPND1_XTRA=M'DUPL'
               OPND1_FLAG=7
            %FINISH
         %FINISH
      %REPEAT
      %IF PARM_DCOMP#0 %START
         PRINTSTRING("
CODE FOR LINE")
         WRITE(WORKA_LINE,3)
         ELINEDECODE
         ELINESTART(WORKA_LINE);         ! PREVENT CODE COMING AGAIN
      %FINISH
      %RETURN
%INTEGER %FN LOAD(%RECORD (RD) %NAME OPND, %INTEGER mode)
!***********************************************************************
!*       LOAD OPERAND OPND INTO TOP OF NEST(ESTACK)                    *
!*    2**6 of Mode set to omit Unassigned check                        *
!***********************************************************************
%INTEGER K,KK,X,PREG,B,D,RES,PTYPE,TYPE,PREC,adid,Chkass
%STRING (255) SVAL
%LONG %REAL RVAL
%RECORD (RD) ROPND
%RECORD (TRIPF) %NAME REFTRIP
%RECORD (TAGF) %NAME TCELL
%SWITCH SW(0:9)
      Adid=0
      K=OPND_FLAG
      RES=1;                             ! SOMETHING LOADED
      PTYPE=OPND_PTYPE
      TYPE=PTYPE&15
      PREC=PTYPE>>4&15
      Chkass=PARM_CHK
      Chkass=0 %IF Mode&64#0 %OR 1<<k&B'11110100'=0; ! k=2 & 4-7 only
      Chkass=0 %IF prec=3 %AND type#5
      %IF (Target=M88k %OR target=Gould) %AND type=5 %THEN Chkass=0
!
! The above line is needed if halfs must be half aligned. Unassigned
! Check of string tries to pick up the first half word. A new Eop
! is needed here.
!
      %IF K>9 %THEN IMPABORT
      ->SW(K)
SW(0):                                   ! CONSTANT < 16 BITS
SW(1):
      %IF TYPE=5 %THEN ->SCONST
      %IF TYPE=1 %THEN %start
         %if prec<=5 %then ESTKLIT(OPND_D) %AND ->LDED
         Estkconst(Bytes(prec),addr(opnd_d))
         ->lded
      %finish
      %IF TYPE=2 %OR type=10 %THEN %START; ! Type 10 is preformated(hex) real in target form
                                         ! Only found when cross compilng
         %IF HOST#TARGET %AND type=2 %THEN REFORMATC(OPND)
         %if prec<=6 %then ESTKRCONST(BYTES(PREC),ADDR(OPND_D)) %else %c
           estkrconst(BYTES(PREC),ADDR(WORKA_A(OPND_D)))
      %FINISH
      ->LDED
SCONST:                                  ! STRING CONSTANT OPND_DIS AR PTR
      KK=WORKA_A(OPND_D)
      LENGTH(SVAL)=KK
      %FOR KK=1,1,KK %CYCLE
         CHARNO(SVAL,KK)=WORKA_A(OPND_D+KK)
      %REPEAT
      %IF HOST#TARGET %THEN CHANGE SEX(ADDR(SVAL),0,KK+1)
      ESTKCONST(KK+1,ADDR(SVAL))
      EOP(EADDRESS)
      ->LDED
SW(3):                                   ! 128 BIT CONSTANT
      IMPABORT
SW(2):                                   ! NAME
      Adid=addr(lett(word(opnd_d)))
      TCELL==ASLIST(TAGS(OPND_D))
      B=TCELL_UIOJ>>4&15
      Chkass=0 %IF B=0
      K=BYTES(OPND_PTYPE>>4&15)
      %IF TCELL_PTYPE&X'3FFF'=X'33' %START
         KK=RECORDELAD(TCELL,PTYPE,OPND_XTRA)
      %FINISH %ELSE %IF TYPE=5 %THEN KK=STRINGLBAD(TCELL) %ELSE KK=TCELL_SLINK
      %IF TYPE=5 %THEN DFETCHAD(1,B,KK&X'FFFF',Adid) %ELSE %C
         DFETCH(TYPE,K,B,KK&X'FFFF',Adid)
LDED:
      %IF TYPE=1 %AND PREC<4 %THEN OPND_PTYPE=X'41'
      %IF Chkass#0 %and (type#5 %or (Target#MIPS %and Target#M88K)) %START
         %IF type=5 %THEN Erefer(0,X'01000002')
         Eop(UCHECK)
         %IF type=5 %THEN Eop(Eaddress)
      %FINISH
      OPND_FLAG=9
      OPND_XB=ESTK
      %RESULT=RES
SW(5):                                   ! INDIRECT VIA DICTIONARY
                                         ! ONLY RECORD SCALAR(_XTRA>=0)
                                         ! OR POINTER(_XTRA<0)
      Adid=addr(lett(word(opnd_d)))
      TCELL==ASLIST(TAGS(OPND_D))
      B=TCELL_UIOJ>>4&15
      Chkass=0 %IF B=0
      %IF TYPE=5 %AND OPND_XTRA<0 %START; ! STRING POINTER
         FETCH HIGH AD END(B,TCELL_SLINK&x'ffff',Adid)
      %FINISH %ELSE DFETCH(1,4,B,TCELL_SLINK&x'ffff',Adid)
      Eop(UCHECK) %IF Chkass#0
      ->IFETCH

SW(4):                                   ! VIA POINTER AT OFFSET FROM
                                         ! A COMPUTED ADDRESS
      REFTRIP==TRIPLES(OPND_D)
      x=opnd_xtra
      %IF REFTRIP_PUSE#WTRIPNO %THEN OPND_FLAG=8 %AND LRES=LOAD(OPND,64)
      %IF TYPE=5 %THEN x=x+4
      EREFER(x,X'01000004');             ! POINTER OR ADDRESS PORTION IN ESTK
      %IF TYPE#5 %THEN INDLOAD(TYPE,BYTES(PREC),0)
      ->LDED
SW(6):                                   ! INDIRECT WITH OFFSET
      REFTRIP==TRIPLES(OPND_D)
      %IF REFTRIP_PUSE#WTRIPNO %START;   ! NEED TO LOAD TRIPLE
         ROPND=OPND
         ROPND_PTYPE=REFTRIP_OPTYPE
         ROPND_FLAG=8
         KK=LOAD(ROPND,64)
      %FINISH
IFETCH:
      KK=OPND_XTRA
      KK=0 %IF KK<0
      %IF TYPE=5 %START
         ESTKLIT(KK) %AND EOP(index1) %IF KK>0
      %FINISH %ELSE %START
         INDLOAD(TYPE,BYTES(PREC),KK)
      %FINISH
      ->LDED
SW(7):                                   ! I-R IN A STACK FRAME
      B=OPND_D>>16; D=OPND_D&X'FFFF'
      Chkass=0 %IF B=0
      %IF TYPE=5 %OR type=3 %THEN %START
         %IF OPND_XTRA=M'DUPL' %THEN DFETCH(1,4,B,D,0) %ELSE %START
            %IF Stack Down=yes %THEN d=d+opnd_xtra-1
            DFETCHAD(1,B,D,0)
         %FINISH
      %FINISH %ELSE %START
         %IF OPND_XTRA=M'ARRH' %THEN FETCH HIGH AD END(B,D,Adid) %ELSE %C
            DFETCH(TYPE,BYTES(PREC),B,D,0)
      %FINISH
      ->LDED
SW(8):                                   ! TRIPLE
      REFTRIP==TRIPLES(OPND_D)
      %IF TYPE#5 %AND REFTRIP_PUSE=WTRIPNO %AND REFTRIP_FLAGS&NOTINREG=0 %THEN %C
         PREG=REFTRIP_OPND1_XB %AND RES=0 %AND ->LDED
      OPND=REFTRIP_OPND1
      %RESULT=LOAD(OPND,64)
SW(9):                                   ! I-R IN A REGISTER
      PREG=OPND_XB
      %RESULT=0
%END
%INTEGER %FN STRINGLBAD(%RECORD (TAGF) %NAME TCELL)
!***********************************************************************
!*    RETURNS B<<16!D OF THE STRING LENGTH BYTE                        *
!*    FN NEEDED AS GLA FORWARD & STACK BACKWARD                        *
!***********************************************************************
%INTEGER B,D,X,RL
%RECORD (LEVELF) %NAME INF
      D=TCELL_SLINK&x'ffff'
      B=TCELL_UIOJ>>4&15
      %IF Stack Down=No %or B=0 %THEN %RESULT=D
      INF==WORKA_LEVELINF(RLEVTOLEVEL(B))
      X=INF_DISPLAY
      %IF D<x %and Params Bwards=no %THEN %RESULT=d
      RL=1
      %if (Target=DRS %or Target=PENTIUM) %and D<x %then rl=3; ! Drs str vals word aligned
      D=(D+TCELL_ACC+RL)&(\RL)-1
      %RESULT=D
%END
%INTEGER %FN RECORDELAD(%RECORD (TAGF) %NAME TCELL, %INTEGER SPTYPE,XDISP)
!***********************************************************************
!*    RETURNS THE DISP OF A RECORD ELEMENT                             *
!***********************************************************************
%INTEGER B,D
%RECORD (levelf) %NAME inf
      D=TCELL_SLINK&x'ffff'
      B=TCELL_UIOJ>>4&15
      XDISP=XDISP&X'FFFF'
      %IF  Stack Down=No %or B=0 %THEN %RESULT=D+XDISP
      inf==worka_levelinf(rlevtolevel(b))
      %IF Params Bwards=NO %and d<inf_display{param} %THEN %RESULT=d+xdisp
      D=D+TCELL_ACC-XDISP
      %IF SPTYPE&7=5 %THEN %RESULT=D-1
      D=D-BYTES(SPTYPE>>4&7)
!      %IF 1<<target&halfswopped#0 %AND (sptype=X'31' %OR sptype=x'41') %C
%THEN d=d!!2
!      %IF 1<<target&byteswopped#0 %AND SPTYPE=X'31' %THEN D=D!!1
      %RESULT=D
%END
%integerfn assemblerrefad(%record(tagf)%name tcell,%integer xdisp)
!***********************************************************************
!*    RETURNS THE DISP OF A '**name+N' assembler reference             *
!***********************************************************************
%INTEGER B,D
%RECORD (levelf) %NAME inf
      D=TCELL_SLINK&x'ffff'
      B=TCELL_UIOJ>>4&15
      XDISP=XDISP&X'FFFF'
      %if xdisp&x'00008000'#0 %then xdisp=xdisp!x'ffff0000'
      %IF  Stack Down=No %or B=0 %THEN %RESULT=D+XDISP
      inf==worka_levelinf(rlevtolevel(b))
      %IF Params Bwards=NO %and d<inf_display{param} %THEN %RESULT=d+xdisp
      %result=d-xdisp
%end
%ROUTINE INDLOAD(%INTEGER TYPE,SIZE,OFFSET)
!***********************************************************************
!*    LOADS REG VIA INDIRECTION POINTER ON ETOS                        *
!***********************************************************************
      %IF 1<<Target&LINTAVAIL=0 %and TYPE=1 %AND SIZE=8 %START
         EOP(DUPL)
         EREFER(OFFSET+4,x'01000004')
         EOP(EXCH)
         EREFER(OFFSET,x'01000004')
      %ELSE
         %if type=1=size %then type=3
         EREFER(OFFSET,TYPE<<24!SIZE)
      %FINISH
%END
%ROUTINE INDSTORE(%INTEGER TYPE,SIZE,OFFSET)
!***********************************************************************
!*    STORES REG VIA INDIRECTION POINTER ON ETOS                       *
!*    WHEN REG ALSO = ETOS %THEN ROUTINE ASSUMES CORRECT ORDERING      *
!***********************************************************************
      %IF 1<<Target&LINTAVAIL=0 %and TYPE=1 %AND SIZE=8 %START
         EOP(DUPL)
         EPROMOTE(4)
         EOP(EXCH)
         EREFER(OFFSET+4,X'01000004')
         EOP(ESTORE)
         EREFER(OFFSET,X'01000004')
         EOP(ESTORE)
      %ELSE
         EREFER(OFFSET,TYPE<<24!SIZE)
         EOP(ESTORE)
      %FINISH
%END
%ROUTINE LOADAD(%RECORD (RD) %NAME OPND)
!***********************************************************************
!*    MUCH AS LOAD BUT PRODUCES THE 32 BIT ADDRESS OF OPERAND          *
!*    ABORT ON NON RELEVANT ALTERNATIVES OF OPND                       *
!***********************************************************************
%RECORD (TRIPF) %NAME REFTRIP
%RECORD (TAGF) %NAME TCELL
%RECORD (RD) ROPND
%INTEGER B,D,X,K,PTYPE,Adid
%SWITCH SW(0:9)
      PTYPE=OPND_PTYPE
      Adid=0
      X=OPND_XTRA
      K=OPND_FLAG
      ->SW(K)
SW(*):                                   ! INVALID
      IMPABORT %IF parm_faulty=0;        ! can occurr with gross errors
      x=load(opnd,0)
      Eop(EADDRESS)
      ->lded
SW(2):                                   ! DNAME
      Adid=addr(lett(word(opnd_d)))
      TCELL==ASLIST(TAGS(OPND_D))
      B=TCELL_UIOJ>>4&15
      %IF TCELL_PTYPE&X'3FFF'=X'33' %THEN D=RECORDELAD(TCELL,PTYPE,X) %ELSE %IF %C
         PTYPE&255=X'35' %THEN D=STRINGLBAD(TCELL) %ELSE D=TCELL_SLINK
      DFETCHAD(BYTES(PTYPE>>4&15),B,D&X'FFFF',Adid)
LDED:
      OPND_PTYPE=X'51';                  ! 32 BIT ADDRESS IS INTEGER
      OPND_FLAG=9
      OPND_XB=ESTK
      %RETURN

SW(4):                                   ! VIA POINTER AT OFFSET FROM
                                         ! A COMPUTED ADDRESS
      REFTRIP==TRIPLES(OPND_D)
      %IF REFTRIP_PUSE#WTRIPNO %THEN OPND_FLAG=8 %AND LRES=LOAD(OPND,0)
      %IF PTYPE&255=X'35' %THEN X=X+4
      EREFER(X,x'01000004');            ! ADDRESS IN ESTACK
      ->LDED
SW(5):                                   ! INDIRECT VIA PTR
      Adid=addr(lett(word(opnd_d)))
      TCELL==ASLIST(TAGS(OPND_D))
      B=TCELL_UIOJ>>4&15
      D=TCELL_SLINK&x'ffff'
      %IF PTYPE&X'FF'=X'35' %AND OPND_XTRA<0 %START; ! STRING POINTER
         FETCH HIGH AD END(B,D,Adid)
         ->LDED
      %FINISH
      DFETCH(1,4,B,D,Adid)
      ->INC ADDR
SW(6):                                   ! INDIRECT OFFSET
      REFTRIP==TRIPLES(OPND_D)
      %IF REFTRIP_PUSE#WTRIPNO %THEN %START
         ROPND=OPND
         ROPND_PTYPE=REFTRIP_OPTYPE
         ROPND_FLAG=8
         LRES=LOAD(ROPND,0)
      %FINISH
INC ADDR:                                ! X>=0 RECORD: X<0 POINTER
      %IF X>0 %THEN ESTKLIT(X) %AND EOP(index1)
      ->LDED
SW(7):                                   ! LOCAL-IR IN BASE&OFFSET FORM
      B=OPND_D>>16
      D=OPND_D&X'FFFF'
      %IF stack down=yes %START
         %IF opnd_xtra<=0 %THEN opnd_xtra=268; ! omission in pass 2
         %IF ptype=x'35' %OR ptype=X'33' %THEN d=d+opnd_xtra-1
      %FINISH
      DFETCHAD(BYTES(PTYPE>>4&7),B,D,0)
      ->LDED
%END
%ROUTINE LOADPTR(%RECORD (RD) %NAME OPND,OPND2)
!***********************************************************************
!*    MUCH AS LOAD BUT PRODUCES THE POINTER TO THE OPERAND             *
!*    ABORT ON NON RELEVANT ALTERNATIVES OF OPND                       *
!***********************************************************************
%RECORD (TRIPF) %NAME REFTRIP
%RECORD (TAGF) %NAME TCELL
%RECORD (RD) ROPND
%INTEGER K,B,D,X,PTYPE,Adid
%SWITCH SW(0:9)
      Adid=0
      PTYPE=OPND_PTYPE
      X=OPND_XTRA
      K=OPND_FLAG
      ->SW(K)
SW(*):                                   ! INVALID
      IMPABORT %IF parm_faulty=0;        ! can occurr with gross errors
      x=load(opnd,0)
      Eop(EADDRESS)
      ->lded
SW(2):                                   ! DNAME
      Adid=addr(lett(word(opnd_d)))
      TCELL==ASLIST(TAGS(OPND_D))
      %IF TCELL_PTYPE&X'3FFF'=X'33' %THEN %START
         D=RECORDELAD(TCELL,PTYPE,X)
      %FINISH %ELSE %IF PTYPE&255=X'35' %THEN D=STRINGLBAD(TCELL) %ELSE D=TCELL_SLINK
      %IF PTYPE&255=X'35' %THEN %START
         PTYPE=CURRT_X1>>16
         DFETCHAD(1,TCELL_UIOJ>>4&15,D&X'FFFF',Adid)
         ->STR
      %FINISH
      DFETCHAD(BYTES(OPND_PTYPE>>4&7),TCELL_UIOJ>>4&15,D&X'FFFF',Adid)
LDED:
      OPND_PTYPE=X'51'
      OPND_FLAG=9
      OPND_XB=ESTK
      %RETURN

SW(4):                                   ! VIA POINTER AT OFFSET FROM
                                         ! A COMPUTED ADDRESS
      REFTRIP==TRIPLES(OPND_D)
      %IF REFTRIP_PUSE#WTRIPNO %THEN OPND_FLAG=8 %AND LRES=LOAD(OPND,0)
      %IF PTYPE&255=X'35' %THEN INDLOAD(1,8,X) %AND ->SLDED
      INDLOAD(1,4,X)
      ->LDED
SW(5):                                   ! INDIRECT VIA DICT
      Adid=addr(lett(word(opnd_d)))
      TCELL==ASLIST(TAGS(OPND_D))
      %IF X<0 %START;                    ! IS A POINTER
         D=4
         %IF PTYPE&255=X'35' %THEN D=8
         DFETCH(1,D,TCELL_UIOJ>>4&15,TCELL_SLINK&x'ffff',Adid)
         ->LDED
      %FINISH
      DFETCH(1,4,TCELL_UIOJ>>4&15,TCELL_SLINK&x'ffff',Adid)
      ->INC ADDR
SW(6):                                   ! INDIRECT OFFSET
      REFTRIP==TRIPLES(OPND_D)
      %IF REFTRIP_PUSE#WTRIPNO %THEN %START
         ROPND=OPND
         ROPND_PTYPE=REFTRIP_OPTYPE
         ROPND_FLAG=8
         LRES=LOAD(ROPND,0)
      %FINISH
INC ADDR:                                ! FOR RECORD ELEMENTS
      %IF X>0 %THEN ESTKLIT(X) %AND EOP(index1)
STR:                                     ! ORGANISE WORD2 OF STR PNTR
                                         ! OPND2_XTRA=BML<<16!DML
      ->LDED %UNLESS PTYPE&255=X'35';    ! ALL NON STRING
! string lengths are maxl not acc which includes the length byte
! hence for arrays which have acc one must be removed
!
      %IF OPND2_FLAG=SCONST %THEN ESTKLIT(OPND2_D&X'FFFF') %ELSE %START
         CHOP OPERAND(OPND2,x'51',0)
         LRES=LOAD(OPND2,0)
                                         ! FOR STRINGNAMES PTR NOW LOADED
                                         ! FR STRINGARRAYNAMES DVBASE NOW LDED
                                         ! HAVE TO EXTRACT ELSIZE AND DECREMENT BY 1
         %IF PTYPE&X'300'#0 %THEN %START
            d=6
            %IF 1<<target&halfswopped#0 %THEN d=4
            EREFER(d,X'01000002')
            ESTKLIT(1)
            EOP(ISUB)
         %FINISH
      %FINISH
      %if 1<<TARGET&LINTAVAIL#0 %then Eop(EMAKED)
SLDED:                                   ! STRING PTR LOADED
      OPND_PTYPE=X'61';                  ! STR PNTERS ARE 64 BIT
      OPND_FLAG=9
      OPND_XB=ESTK
      %RETURN
SW(7):                                   ! LOCAL BASE&DISP(RESULTS FROM MAP OPTIMISATIONS)
      loadad(opnd)
      ->STR
SW(8):                                   ! A TRIPLE MEANS PREVIOUSLY USED
                                         ! POINTER A SECOND TIME
      REFTRIP==TRIPLES(OPND_D)
      IMPABORT %UNLESS REFTRIP_OPERN=GETPTR
      LRES=LOAD(OPND,0)
%END
%ROUTINE VMY
!***********************************************************************
!*    DOES ALL VECTOR MULTIPLIES                                       *
!***********************************************************************
%RECORD (RD) DOPND
%INTEGER DVPOS,PR,CM
      DVPOS=-1
      PR=OPND1_PTYPE>>4&15
      CM=-1
      %IF OPND2_FLAG=SCONST %THEN DVPOS=OPND2_D %ELSE %START
         CHOP OPERAND(OPND2,x'51',0);    ! to dv ptr
         DOPND=OPND2;                    ! for second load if needed
      %FINISH
      %IF PARM_ARR#0 %START
         %IF DVPOS>0 %START;             ! BOUND KNOWN
            ESTKLIT(BYTESWOP(CTABLE(DVPOS+3*C+1)))
            ESTKLIT(BYTESWOP(CTABLE(DVPOS+3*C)))
         %FINISH %ELSE %START
            LRES=LOAD(OPND2,64);         ! fetch dv ptr
            EOP(DUPL)
            EREFER(12*C+4,X'01000004')
            EOP(EXCH)
            EREFER(12*C,X'01000004')
         %FINISH
         EOP(CHK)
      %FINISH
      %IF C#1 %START;                    ! ALL DIMENSION BAR 1ST
         %IF DVPOS>0 %THEN %START
            ESTKLIT(BYTESWOP(CTABLE(DVPOS+3*C-1)))
         %FINISH %ELSE %START
            LRES=LOAD(DOPND,64);         ! fetch dv ptr
            EREFER(12*C-4,X'01000004');  ! MULTIPLIER
         %FINISH
         EOP(IMULT)
      %FINISH
%END
%ROUTINE REXP
!***********************************************************************
!*       CALLS A PERM ROUTINE TO PERFORM REAL**REAL                    *
!***********************************************************************
      %IF currt_optype>>4=6 %THEN estklit(10) %ELSE ESTKLIT(9)
      EOP(EPOWER)
%END
%ROUTINE CHOP OPERAND(%RECORD (RD) %NAME OPND, %INTEGER NEWPT,XOFFSET)
!***********************************************************************
!*    CHANGES RECORD OPERAND TO REFER TO A SMALLER BIT AT XOFFSET FROM *
!*    THE ORIGINAL START. USED TO LOAD ONE WORD OF STRING&ARRAY HEADERS*
!*    MUST COPE WITH GLA GOING FORWARD BUT STACK FRAMES GOING BACKWARDS*
!***********************************************************************
%INTEGER OLDPT,S1,S2,B
%RECORD (levelf) %NAME inf
%RECORD (TAGF) %NAME TCELL
      OLDPT=OPND_PTYPE&255
      OPND_PTYPE=OPND_PTYPE&X'FF00'!NEWPT
      %IF OPND_FLAG=9 %THEN IMPABORT
      %IF XOFFSET<0 %THEN %RETURN
      %IF OPND_FLAG=DNAME %START
         TCELL==ASLIST(TAGS(OPND_D))
         %IF TCELL_PTYPE&x'3FFF'=x'33' %THEN S1=RECORDELAD(TCELL,OLDPT,OPND_XTRA) %ELSE %C
            S1=TCELL_SLINK&x'ffff'
         OPND_D=(TCELL_UIOJ>>4&15)<<16!S1
         OPND_FLAG=LOCAL IR
      %FINISH
      %IF OPND_FLAG=INDIRECT %OR OPND_FLAG=INDNAME %THEN %C
         OPND_XTRA=OPND_XTRA&X'FFFF'+XOFFSET
      %IF OPND_FLAG=LOCALIR %THEN %START
         B=opnd_d>>16
         inf==worka_levelinf(rlevtolevel(b)) %UNLESS b=0
         %IF stack down=no %OR B=0 %OR (Params Bwards=No %and opnd_d&x'ffff'<inf_display) %THEN %C
            OPND_D=OPND_D+XOFFSET %ELSE %START
            S1=BYTES(OLDPT>>4)
            S2=BYTES(NEWPT>>4)
            OPND_D=OPND_D+S1-S2-XOFFSET
         %FINISH
      %FINISH
%END
%INTEGER %FN RLEVTOLEVEL(%INTEGER RLEV)
!*********************************************************************
!*    FIND LEVEL FOR VAR WHOSE RLEVEL IS KNOWN                         *
!***********************************************************************
%INTEGER I
%RECORD (LEVELF) %NAME INF
      I=1
      %CYCLE
         INF==WORKA_LEVELINF(I)
         %IF INF_RBASE=RLEV %THEN %RESULT=I
         I=I+1
      %REPEAT
%END
%ROUTINE DSTORE(%INTEGER TYPE,OPCODE,SIZE,RLEVEL,DISP,Adid)
!***********************************************************************
!*    STORE SIZE(BYTES) FROM DISP(BYTES) IN DISPLAY 'LEVEL'            *
!***********************************************************************
      %IF 1<<Target&LINTAVAIL=0 %and TYPE=1 %AND SIZE=8 %START
         %IF OPCODE=EDUPSTORE %THEN EOP(DUPL)
         STORE LOW AD END(RLEVEL,DISP,Adid)
         %IF OPCODE=EDUPSTORE %THEN EOP(EXCH) %AND EOP(DUPL)
         STORE HIGH AD END(RLEVEL,DISP,Adid)
         %IF OPCODE=EDUPSTORE %THEN EOP(EXCH)
      %ELSE
         DFETCH(TYPE,SIZE,RLEVEL,DISP,Adid)
         EOP(OPCODE)
      %FINISH
%END
%ROUTINE DFETCHAD(%INTEGER SIZE,RLEVEL,DISP,Adid)
!***********************************************************************
!*    FETCH ADDRESS OF DISP(BYTES) IN DISPLAY 'LEVEL'                  *
!*    SIZE IS NEED BECAUSE OF WRONG END LOW ADDRESS FOR STACKS         *
!***********************************************************************
      DFETCH(0,SIZE,RLEVEL,DISP,Adid)
      EOP(EADDRESS)
%END
%ROUTINE DFETCH(%INTEGER TYPE,SIZE,RLEVEL,DISP,Adid)
!***********************************************************************
!*    FETCH SIZE(BYTES) FROM DISP(BYTES) IN DISPLAY 'LEVEL'            *
!***********************************************************************
%INTEGER LEVELCODE,offset
%RECORD (LEVELF) %NAME INF
%SWITCH SW(0:3)
      %IF 1<<Target&LINTAVAIL=0 %and TYPE=1 %AND SIZE=8 %START
         FETCH HIGH AD END(RLEVEL,DISP,Adid)
         FETCH LOW AD END(RLEVEL,DISP,Adid)
         %RETURN
      %FINISH
      %IF RLEVEL=0 %THEN LEVELCODE=0 %ELSE %IF RLEVEL=CURRINF_RBASE %THEN %C
         LEVELCODE=1 %ELSE LEVELCODE=2
      %if type=1=size %then type=3;     !Bytes are unsigned for EMC
      ->SW(LEVELCODE)
SW(*):                                   ! FUNNY SIZES
      IMPABORT
SW(0):                                   ! GLOBAL FETCH
      ESTKDIR(2 {gla},DISP,Adid,TYPE<<24!SIZE)
      %RETURN
SW(1):                                   ! LOCAL FETCH
      %IF disp<currinf_display %THEN inf==currinf %AND ->param
      %IF Stack down=no %THEN offset=disp-currinf_display %ELSE %C
         offset=CURRINF_DISPLAY-(DISP+SIZE)
      ESTKDIR(0 {stack},offset,Adid,TYPE<<24!SIZE)
      %RETURN
SW(2):                                   ! INTERMEDIATE WORD FETCH
      INF==WORKA_LEVELINF(RLEVTOLEVEL(RLEVEL))
      %IF disp>inf_display %THEN %START
         %IF Stack down=no %THEN offset=disp-inf_display %ELSE %C
            offset=INF_DISPLAY-(DISP+SIZE)
         ESTKGLOBAL(RLEVEL,offset,Adid,TYPE<<24!SIZE)
         %RETURN
      %FINISH
param:
      %if Params Bwards=Yes %then disp=inf_display-(disp+size)
      estkpar(Rlevel,disp,Adid,type<<24!size)
%END
%ROUTINE FETCH HIGH AD END(%INTEGER B,D,Adid)
!***********************************************************************
!*    FETCHES THE HIGH END OF ARRAYHEAD(IE @A(FIRST)) OR STRINGNAME    *
!***********************************************************************
%RECORD (levelf) %NAME inf
      inf==worka_levelinf(rlevtolevel(b)) %UNLESS b=0
      %if Stack Down=No %or B=0 %or (Params Bwards=No %and d<inf_display) %then d=d+4
      DFETCH(1,4,B,D,Adid)
%END
%ROUTINE FETCH LOW AD END(%INTEGER B,D,Adid)
!***********************************************************************
!*    FETCHES LOW END OF ARRAYHD(IE DV PTR) OR STRINGHEAD(IE ACC)      *
!***********************************************************************
%RECORD (levelf) %NAME inf
      inf==worka_levelinf(rlevtolevel(b)) %UNLESS b=0
      %unless Stack Down=No %or B=0 %or (Params Bwards=No %and d<inf_display) %then d=d+4
      DFETCH(1,4,B,D,Adid)
%END
%ROUTINE STORE HIGH AD END(%INTEGER B,D,Adid)
!***********************************************************************
!*    STORES THE HIGH END OF ARRAYHEAD(IE @A(FIRST)) OR STRINGNAME     *
!***********************************************************************
%RECORD (levelf) %NAME inf
      inf==worka_levelinf(rlevtolevel(b)) %UNLESS b=0
      %if Stack Down=No %or B=0 %or (Params Bwards=No %and d<inf_display) %then d=d+4
      DSTORE(1,ESTORE,4,B,D,Adid)
%END
%ROUTINE STORE LOW AD END(%INTEGER B,D,Adid)
!***********************************************************************
!*    STORES LOW END OF ARRAYHD(IE DV PTR) OR STRINGHEAD(IE ACC)       *
!***********************************************************************
%RECORD (levelf) %NAME inf
      inf==worka_levelinf(rlevtolevel(b)) %UNLESS b=0
      %unless Stack Down=No %or B=0 %or (Params Bwards=No %and d<inf_display) %then d=d+4
      DSTORE(1,ESTORE,4,B,D,Adid)
%END
%INTEGER %FN JCODE(%INTEGER TFMASK)
!***********************************************************************
!*    PRODUCES JUMP CODE FROM IBM TYPE BRANCH MASK AND EXTRA BITS      *
!*    x20 bit set for comparisons with zero                            *
!*    x40 bit if compare has been omitted                              *
!*    x100 bit set for real comparisons                                *
!*    x80 bit set for reversed comparisons                             *
!***********************************************************************
%INTEGER D
      %IF TFMASK&15=15 %THEN %RESULT=JUMP
      %IF TFMASK&X'40'#0 %START;         ! OPTIMISED BY CCOMP
                                         ! NEXT LINE ASSUMES BFFLAG IS
                                         ! STILL AS SET BY CCOMP!
         D=32+16*BFFLAG+TFMASK&15
         %IF TFMASK&x'100'#0 %THEN D=D+64
         D=FCOMP(D)
         %IF TFMASK&x'20'#0 %THEN D=D+(JINTGZ-JIGT)
         %RESULT=D
      %FINISH
      %IF TFMASK&128#0 %THEN %RESULT=JFALSE
      %RESULT=JTRUE
%END
%ROUTINE ISTARSTAR
!***********************************************************************
!*    PLANT IN LINE CODE FOR INTEGER****INTEGER                        *
!*    IN LINE CODE RATHER THAN SUBROUTINE BECAUSE OF NO JLK            *
!***********************************************************************
      ESTKLIT(0)
      EOP(EPOWER)
%END
%ROUTINE STARSTAR
!***********************************************************************
!*    PLANT IN LINE CODE FOR REAL**INTEGER                             *
!*    IN LINE CODE RATHER THAN SUBROUTINE BECAUSE OF THE NO OF CASES   *
!*    NEEDED ON A REGISTER MACHINE WITH 2 LENGTHS OF ARITHMETIC        *
!***********************************************************************
%INTEGER n
      n=currt_Optype>>4-4
      ESTKLIT(n)
      EOP(EPOWER)
%END
%ROUTINE CIOCP(%INTEGER N,xtra)
!***********************************************************************
!*       COMPILES A CALL ON IOCP ENTRY POINT NO 'N'                    *
!*       2ND PARAMETER IS ALREADY IN ETOS                              *
!***********************************************************************
%CONST %INTEGER NEEDS RES=X'40016';      ! FLAGS EPS 1,2,4&18
%INTEGER C,X,ID
      EPRECALL2(KNOWN XREF(4),addr(pardes(5)))
      EOP(PUSHVAL) %IF params bwards=yes
      ESTKLIT(N)
      EOP(PUSHVAL)
      Eop(Pushval) %IF params bwards=no
      %IF 1<<N&NEEDS RES=0 %OR xtra=-1 {skip symbol special} %THEN X=0 %ELSE X=4<<8!1
                                         ! 4 BYTE INTEGER RESULT
      ECALL2(KNOWN XREF(4),1,0,8)
      %IF X#0 %THEN Estkresult(0,1,4)
%END
%END;                                    ! OF ROUTINE GENERATE
%END %OF %FILE