!                                                                      ggen67i4
! Changes to support new Imp front end including maked,splitd
! and proper handline of procedures called formally
!                                                                  ggen67i3
! 31/12/87 - Estkparind to use local base if imp
!                                                                  ggen67i2
! 23/11/87 - Take out SUI, and SRC
!                                                                  ggen67
! 25/04/87 - update ERBIT, EWBIT to UTX definitions
!                                                                  ggen65
! 17/04/87 - use correct np names div_jj, mpy_jj
!                                                                  ggen64
! 16/04/87 - support unsigned int comparison
!                                                                  ggen61
! 01/04/87 - support ERBIT, EWBIT
!                                                                  ggen60
! 18/03/87 - correct pow_cc and pow_zz entries
!                                                                  ggen59
! 28/02/87 - incorporate integer*8 support (ex ggen36u)
!          - incorporate C support (ex ggen54c)
!                                                                  ggen58
! 13/02/87 - support Ecxres
! 12/02/87 - Convert RI incorporate 'duke' change
! 11/02/87 - EREALRES to ensure regpair unlocked
!                                                                  ggen55
! 27/12/86 - add inline code for **2 in Expcall
! 24/12/86 - C dev version ex Ft.L.
!          - correct Reg1 => Reg3 in CAR in ERMOD
!                                                                  ggen54
! 15/12/86 - correct Convert UI
!                                                                  ggen53
! 13/12/86 - add ISHLST, ISHRST for C
!                                                                  ggen51
! 11/12/86 - add ECDUP support
! 09/12/86 - add C support codes Epushstr, Eldbits, Estbits
!                                                                  ggen50
! 08/12/86 - increase Stk array to 63 entries
!                                                                  ggen46
! 03/12/86 - modify ERMOD code to handle NP1 reciprocal problem
!                                                                  ggen45
! 01/12/86 - add support for CVTUI, CVTUR, CVTSBI, Eprocptr
!                                                                  ggen44
! 01/12/86 - on NP1 PROCARG does not push the arg (for APS2)
! 29/11/86 - incorporate changes for F77 1.0 final (ggen33)
!                                                                  ggen43
! 21/11/86 - ad Eprocptr and use ecodes10
!                                                                  ggen42
! 18/11/86 - merge C and NP1 developements
!                                                                  ggen40
! 25/10/86 - attemp to improve NP1 end of loop code
!                                                                  ggen39
! 21/10/86 - change Egivename to a routine 
! 20/10/86 - NP1 correct reg for STKIORES, EINDEXCHAR, EFSETVR, EFNOTEVR
!                                                                  ggen38
! 14/11/86 - use Gould procs for cx div
! 07/11/86 - EINCRB, EDECRB check that literal<=32767
! 05/11/86 - lock reg in <complex> <op> <real>
! 04/11/86 - Clear Regs after EASGNCHAR in case equiv with ints
!          - correct params to Gop Cpb in Cx Operation
! 31/10/86 - correct ECHAR for lit arg
! 30/10/86 - add ECSTORE
! 16/10/86 - complete operations to store for C
!          - modify Eswitch for use by C case
!          - add LOGNEG  to Eccop
!                                                                  ggen37
! 14/10/86 - call Note Reguse in Eswitch
!                                                                  ggen36
! 10/10/86 - correct EXS instruction in Convert IR
! 08/10/86 - result in r2,r3 for NP1
!                                                                   ggen35
! 27/09/86 - add NP1 code
! 26/09/86 - EDUPSTORE of DirVals (C)
!          - add EloseRegs
!                                                                   ggen30
! 21/09/86 - interpret EVAL as a call on Gop Mvlong  (temp)
!                                                                   ggen29
! 17/09/86 - use i_shftc for cyclic shift
!          - ensure that int params to exp routines are 32 bit
! 12/09/86 - support C regvars
!                                                                   ggen28
! 12/09/86 - support IADDST, ISUBST
! 08/09/86 - add support for Eadjl,Eadjr,Everify
! 06/09/86 - revise auxstack handling to use support proc
!                                                                   ggen27
!*  Alan increase auxst static allocation of BSS to 128k
! 04/09/86 - ensure reg pair used in Cx Operation for C*16 for CXNEG and CONJG
!                                                                   ggen26
! 16/08/86 - EINCR to use ARM
! 17/08/86 - in-line code for complex*8 mult
!          - improve code for CMPLX1 and CMPLX2
!                                                                   ggen25
! 14/07/86 - correction to ECHAR
! 31/07/86 - changes for >64K procedures
!                                                                   ggen23
!*
%constinteger Concept = 0
%constinteger NP1     = 1
!*
%constinteger Cpu     = NP1
!*
%include "gbits_gcodes8"
%include "ebits_ecodes28"
%include "ebits_enames28"
!*
%constinteger IMP     =  1
%constinteger fortran =  2
%constinteger ccomp   = 11
%constinteger pascal  = 14
!*
%constinteger Positive = 1
%constinteger Negative =-1
!*
%constinteger Stack Direction = Positive
!*
%externalinteger Report=0
%owninteger PrimeReport=0
%owninteger Decode
%owninteger Language
%externalintegerspec Initdataad
!*
!***********************************************************************
!* Exports                                                             *
!***********************************************************************
!*
%routinespec Einitialise(%integer Lang, Avertext, Astackca,
                                                    Aglaca, Options)
%routinespec Eterminate(%integer adareasizes)
%routinespec Ecommon(%integer area, %stringname Name)
%routinespec Eendcommon(%integer area, Length)
%routinespec Elinestart(%integer lineno)
%routinespec Elinedecode
%routinespec Emonon
%routinespec Emonoff
%routinespec Efaulty
%integerfnspec Estkmarker
%routinespec Esetmarker(%integer Markerid, New Value)
%integerfnspec Eswapmode
!*
%routinespec Estklit(%integer Val)
%routinespec Estkconst(%integer Len, Ad)
%routinespec Estkrconst(%integer Len, Ad)
%routinespec Estkdir(%integer Area, Offset, Adid, Bytes)
%routinespec Estkind(%integer Area, Offset, Adid, Bytes)
%routinespec Estkglobal(%integer Level, Offset, Adid, Bytes)
%routinespec Estkgind(%integer Level, Offset, Adid, Bytes)
%routinespec Estkpar(%integer Level, Offset, Adid, Bytes)
%routinespec Estkparind(%integer Level, Offset, Adid, Bytes)
%routinespec Estkresult(%integer Class, Type, Bytes)
%routinespec Erefer(%integer Offset, Bytes)
%routinespec Epromote(%integer Level)
%routinespec Edemote(%integer Level)
%routinespec Estkaddr(%integer Area, Offset, Adid, Bytes)
!*
%routinespec Elabel(%integer id)
%routinespec Ediscardlabel(%integer id)
%routinespec Ejump(%integer Opcode, Labelid)
%routinespec Etwjump(%integer Opcode, Lab1, Lab2, Lab3)
%routinespec Eswitch(%integer Lower, Upper, Switchid, Errlabid,
                                                     %integername SSTad)
%routinespec EswitchJump(%integer Switchid)
%routinespec EfswitchJump(%integer Switchid)
%routinespec Eswitchentry(%integer Switchid, Entry)
%routinespec Eswitchdef(%integer Switchid)
%routinespec EswitchLabel(%integer Switchid, Entry, Labelid)
!*
%routinespec Ed1(%integer area, Disp, Val)
%routinespec Ed2(%integer area, Disp, Val)
%routinespec Ed4(%integer area, Disp, Val)
%routinespec Edbytes(%integer area, Disp, len, ad)
%routinespec Edpattern(%integer area, Disp, ncopies, len, ad)
%routinespec Efix(%integer area, disp, tgtarea, tgtdisp)
!*
%integerfnspec EXname(%integer type, %string(255)%name Xref)
%routinespec Eprecall(%integer Id)
%routinespec Ecall(%integer Id, Numpars, Paramsize)
%routinespec Eprocref(%integer Id, Level)
%routinespec Esave(%integer Asave, %integername Key)
%routinespec Erestore(%integer Asave, Key, Existing)
!*
%integerfnspec Enextproc
%routinespec Eproclevel(%integer Level)
%routinespec Eproc(%stringname Name, %integer Props, Numpars, Paramsize,
                                                 Astacklen, %integername Id)
%routinespec Eprocend(%integer Localsize, Diagdisp, Astacklen)
%routinespec Eentry(%integer Index,Numpars,Paramsize, Localsize, Diagdisp,
                                                       %stringname Name)
!*
%routinespec Edataentry(%integer Area, Offset, Length,
                                                       %stringname Name)
%routinespec Edataref(%integer Area, Offset, Length,
                                                       %stringname Name)
%routinespec Egivename(%integer Key,%stringname S)
!*
%routinespec Eop(%integer Opcode)
%routinespec Ef77op(%integer Opcode)
%routinespec Epasop(%integer Opcode)
%routinespec Eccop(%integer Opcode)
!*
%recordformat Stkfmt(%byteinteger Form,Type,Reg,Modreg,
                                  Base,Modbase,Scale,Modform,
                      (%integer Offset %or %integer Intval),
                      (%integer Modoffset %or %integer Modintval),
                      %integer Size,Adid)
!*
%externalrecord(Stkfmt)%array Stk(0:63)
%constinteger Stklimit = 63
%ownrecord(Stkfmt) Rstk
%ownrecord(Stkfmt) Frstk
%ownrecord(Stkfmt) LitZero
%ownrecord(Stkfmt) LitOne
!*
!*
!***********************************************************************
!* Imports                                                             *
!***********************************************************************
!*
%externalroutinespec Init Mcode(%integer codelist,lang,options)
%externalintegerfnspec Tidy Mcode(%integer Level,%integername pltsize)
%externalroutinespec Mcode Label(%integer Label)
%externalroutinespec Mcode Plabel(%integer Label)
%externalintegerfnspec mprivatelabel
!*
%externalroutinespec Gop RXB(%integer Op,Reg,Base,Index,Offset,Size)
%externalroutinespec Gop RI(%integer Op,Reg,Lit)
%externalroutinespec Gop RR(%integer Op,Dreg,Sreg)
%externalroutinespec Gop RX(%integer Op,Reg,%record(Stkfmt)%name Stk)
%externalroutinespec Gop X(%integer Op,%record(Stkfmt)%name Stk)
%externalroutinespec Gop R(%integer Op,Reg)
%externalroutinespec Gop(%integer Op)
%externalroutinespec Gop Shift Lit(%integer Op,Reg,Lit)
%externalroutinespec Gop Shift(%integer Op,Reg,%record(Stkfmt)%name Stk)
%externalroutinespec Gop Jump(%integer Op,Label)
%externalroutinespec Gop Rnd(%integer Reg,Size,Const)
%externalroutinespec Gop Floor(%integer reg,size,consts)
%externalroutinespec Gop Call(%integer Id,Paramsize,numpars,Xlevel)
%externalroutinespec Gop Return
%externalroutinespec Gop Mvb(%record(Stkfmt)%name len,From,To)
%externalroutinespec Gop Mvlong(%record(Stkfmt)%name len,from,to,%integer units)
%externalroutinespec Gop Cpb(%integer Op,%record(Stkfmt)%name len,At,With)
%externalroutinespec CodeW(%integer h0,h1)
%externalroutinespec CodeH(%integer h0)
%externalroutinespec Mprecall
%externalroutinespec Mstartproc(%integer Props,Level,Paramsize)
%externalroutinespec Mtidyproc(%integer Markerid,Localsize,Diagdisp,
                               %integername Ca)
%externalintegerfnspec Mmarker
%externalroutinespec Msetopd(%integer Markerid,New Value)
%externalroutinespec Mline(%integer Lineno)
%externalintegerfnspec Mgetca(%integer mode)
%externalintegerfnspec Note Entry(%stringname Name,%integer Key,Ca,Main)
%externalintegerfnspec Get Prockey(%stringname S)
%externalroutinespec Mswitch(%integer Form,Refad,Base,Entries,Switchid,Errlab)
%externalroutinespec Mswitchentry(%integer Switchid,Entry)
%externalroutinespec Mswitchlabel(%integer Switchid,Entry,Labelid)
%externalroutinespec Minnerproc(%integer M)
%externalroutinespec Msetconst(%integer Ad,Len,%integername Area,Offset)
%externalroutinespec Msideentry(%integer ca)
%externalroutinespec Mr7updated
%externalroutinespec Eafix(%integer Area,Offset)
%externalintegerfnspec Pltspace(%integer len)
!*
!*
!***********************************************************************
!*        Code generation procedure specs                              *
!***********************************************************************
!*
%externalintegerfnspec Load Reg(%integer Reg,%record(Stkfmt)%name Stk)
%externalintegerfnspec Load Int(%record(Stkfmt)%name Stk,%integer Reg)
%externalintegerfnspec Load Real(%record(Stkfmt)%name Stk,%integer Reg,Newsize)
%externalroutinespec Int Binary Op(%integer Op,%record(Stkfmt)%name LHS,RHS)
%externalroutinespec Int Unary Op(%integer Op,%record(Stkfmt)%name RHS)
%externalroutinespec Real Binary Op(%integer Op,%record(Stkfmt)%name LHS,RHS)
%externalroutinespec Real Unary Op(%integer Op,%record(Stkfmt)%name RHS)
%externalintegerfnspec Storeop(%record(Stkfmt)%name LHS,RHS,%integer Dup)
%externalroutinespec Push Param(%record(Stkfmt)%name Stk)
%externalroutinespec Push Struct(%record(Stkfmt)%name Stk,%integer size)
%routinespec Note Index(%integer Scale,%record(Stkfmt)%name Base,Index)
%externalintegerfnspec Claim Reg
%externalintegerfnspec Claim Reg Pair(%integer Mode)
%externalroutinespec release reg(%integer reg)
%externalroutinespec Release Reg Pair(%integer Mode)
%externalintegerfnspec Claim Freg
%externalroutinespec Unlock Reg(%integer Reg)
%externalroutinespec Unlock Reg Pair(%integer Reg)
%externalroutinespec Lock Reg Pair(%integer Reg)
%externalroutinespec Reset Reguse(%integer Old,New)
%externalroutinespec Moptreguse(%integer reg,use)
%externalroutinespec Freeregs
%externalroutinespec Clear Regs
%externalroutinespec Dump Regs(%integer dlevel)
%externalroutinespec Note Reguse(%integer Reg,Use,Size)
%externalintegerfnspec Get Procref(%integer Id)
%externalroutinespec Mset Procref(%integer Area,Offset,%string(255)%name S)
%externalroutinespec Gop Bit(%integer Op,Mode,Treg,%record(Stkfmt) Loc,Adj)
!*
%routinespec Refer(%record(Stkfmt)%name Stk,%integer Offset)
%routinespec Address(%record(Stkfmt)%name Stk)
%routinespec Stackr(%integer R,bytes)
%routinespec Stackfr(%integer FR,Bytes)
%routinespec Establish Logical
%routinespec Convert RR(%integer Mode,%record(Stkfmt)%name Stk,%integer Bytes)
%routinespec Convert IR(%record(Stkfmt)%name Stk,%integer Bytes)
%routinespec Convert II(%record(Stkfmt)%name Stk,%integer Bytes)
%routinespec Convert RI(%record(Stkfmt)%name Stk,%integer Bytes,Mode)
%routinespec Convert SBI(%record(Stkfmt)%name Stk,%integer Bytes)
%routinespec Convert IU(%record(Stkfmt)%name Stk,%integer Bytes)
%routinespec Convert UR(%record(Stkfmt)%name Stk,%integer Bytes)
%routinespec Expcall(%integer Proc)
%routinespec Spcall(%integer Proc)
!*
%routinespec Do Charop(%integer Op,%record(Stkfmt)%name C1,L1,C2,L2)
%routinespec Cx Operation(%integer Op,Flags,%record(Stkfmt)%name LHS,RHS1,RHS2)
!*
!*
!***********************************
!* Put Interface Passing of Data   *
!***********************************
%externalroutinespec   MDBYTES   (%integer area, Disp, len, ad)
%externalroutinespec   MD        (%integer area, Disp, Databyte)
%externalroutinespec   MD2       (%integer area, Disp, DataDoublebyte)
%externalroutinespec   MD4       (%integer area, Disp, DataQuadbyte)
%externalroutinespec   MDPATTERN (%integer area, Disp, ncopies, len, ad)
!**********************************************
!* Put Interface RELOCATION and REFERENCES    *
!**********************************************
%externalintegerfnspec MXname (%integer type,%string(255)%name  s)
%externalroutinespec   Mfix   (%integer area,disp, tgtarea,tgtdisp)
%externalroutinespec   MDxref (%integer area,disp,id)
!**********************************
!* Put Interface - Miscellaneous  *
!**********************************
%externalintegerfnspec Mcommon       (%string(255)%name Name)
%externalroutinespec   MendCommon    (%integer id,length)
%externalroutinespec   Mproc (%string(255)%name name, %integer props,codead,
                              %integername id,%integer lineno)
%externalintegerfnspec Mentry(%integer Index,Codedisp,%string(255) %name name)
%externalroutinespec   Mprocend(%integername ca)
%externalroutinespec   Mdataentry(%string(255)%name name, %integer area, maxlen, disp)
%externalroutinespec   Minitialise   (%integer version,release,language)
%externalroutinespec   Mterminate    (%integer adareasizes)
%externalroutinespec   Mfaulty
%externalroutinespec   Mmonon
!*
!*
!*
!***********************************************************************
!*        Common declarations                                          *
!***********************************************************************
!*
!*
%constinteger LitVal         =  0        {  lit        }
%constinteger ConstVal       =  1        {  const      }
%constinteger RegVal         =  2        {  (reg)      }
%constinteger FregVal        =  3        {  (freg)     }
%constinteger TempVal        =  4        {  (temp)     }
%constinteger DirVal         =  5        {  (dir)      }
%constinteger IndRegVal      =  6        { ((reg))     }
%constinteger IndTempVal     =  7        { ((temp))    }
%constinteger IndDirVal      =  8        { ((dir))     }
%constinteger AddrConst      =  9        {  @const     }
%constinteger AddrDir        = 10        {  @dir       }
%constinteger RegAddr        = 11        {  (reg) is @ }
%constinteger TempAddr       = 12        {  (temp) is @}
%constinteger DirAddr        = 13        {  (dir) is @ }
%constinteger AddrDirMod     = 14        {  @dir+M     }
%constinteger RegModAddr     = 15        {  (reg)+M    }
%constinteger TempModAddr    = 16        {  (temp)+M   }
%constinteger DirModAddr     = 17        {  (dir)+M    }
%constinteger IndRegModVal   = 18        { ((reg)+M)   }
%constinteger IndTempModVal  = 19        { ((temp)+M)  }
%constinteger IndDirModVal   = 20        { ((dir)+M)   }
%constinteger AddrDirModVal  = 21        { (@dir+M)    }
%constinteger RegBitAddr     = 22        {  (reg) is @ }
%constinteger RegBitModAddr  = 23        {  (reg)+M    }
%constinteger RegVar         = 29        {  var in reg }
%constinteger RegPtr         = 30        {  ptr in reg }
%constinteger TopOfStack     = 31        {  TOS        }
!*
%constinteger Regflag       = 32  {used to speedup search for reguse}
!*
%conststring(14)%array Eform(0:31) =  %c
  "LitVal        ","ConstVal      ","RegVal        ","FregVal       ",
  "TempVal       ","DirVal        ","IndRegVal     ","IndTempVal    ",
  "IndDirVal     ","ConstAddr     ","AddrDir       ","RegAddr       ",
  "TempAddr      ","DirAddr       ","AddrDirMod    ","RegModAddr    ",
  "TempModAddr   ","DirModAddr    ","IndRegModVal  ","IndTempModVal ",
  "IndDirModVal  ","AddrDirModVal ","RegBitAddr    ","RegBitModAddr ",
  ""              ,""              ,""              ,""              ,
  ""              ,"RegVar"        ,"RegPtr"        ,"TOS           "
!*
%constinteger Stack  = 0
%constinteger Code   = 1
%constinteger Gla    = 2
%constinteger Plt    = 3
%constinteger Sst    = 4
%constinteger Ust    = 5
%constinteger Diags  = 6
%constinteger Static = 7
%constinteger Iotab  = 8
%constinteger Zust   = 9
%constinteger Cnst   =10
!*
%externalinteger Elevel
%owninteger ProgFaulty
%owninteger ProcLevel
%owninteger Savelineno
%owninteger Pltsize
%externalinteger Bitarea
%externalinteger Bitdisp
!*
%conststring(9)%array Expprocs(0:16)=  %c                     
      "pow_ii"  ,"pow_ri"  ,"pow_di" ,"pow_qi"  ,"pow_ci"   ,   
      "pow_zi"  ,"pow_zzi" ,""        ,""         ,"pow_rr"   ,
      "pow_dd"  ,"pow_qq"  ,"pow_cc" ,"pow_zz"  ,"pow_zzz",
      "pow_jj"  ,"pow_ji"    
!*
%constintegerarray Expproctype(0:16)= %c
      X'10401',X'10402',X'10802',X'11002',X'10000',
      X'10000',X'10000',       0,       0,X'10402',
      X'10802',X'11002',X'10000',X'10000',X'10000',
      x'10801',x'10801'
!*
%ownintegerarray Expprocref(0:16)
!*
%if Cpu=NP1 %thenstart
!*
%constintegerarray Expprocpdesc(0:16)= %c
      X'20008',X'20008',X'2000C',X'20008',X'20008',
      X'20008',X'3000C',0       ,0       ,X'20008',
      X'20010',X'20008',X'20008',X'20008',X'3000C',
      X'20008',x'20008'
!*
%conststring(9)%array Spprocs(0:30)= %c
      "f_crmult" ,"f_cdmult" ,"f_cqmult" ,"div_cc"  ,
      "div_zz"   ,"f_cqdiv"  ,"f_index"  ,"f_concat" ,
      "p_stop"   ,"f_cpystr" ,"f_cpstr"  ,"p_eoft",
      "p_eof"    ,"p_eol"    ,"p_lazy"   ,"f_ishft",
      "f_ibits"  ,"f_ibset"  ,"f_btest"  ,"f_ibclr",
      "i_shftc","i_auxst"  ,"s_adjl"   ,"s_adjr",
      "i_vrfy"   ,"lshift"   ,"rshift", "mpy_jj",
      "div_jj","#udiv"    ,"#urem"
!*
%constintegerarray Spprocpdesc(0:30)= %c
      X'3000C',X'3000C',X'3000C',X'20008',
      X'20008',X'3000C',X'40010',X'40010',
      0       ,X'40010',X'50014',X'10004',
      X'10004',X'10004',X'10004',X'20008',
      X'3000C',X'20008',X'20008',X'20008',
      X'3000C',X'20008',X'40010',X'40010',
      X'40010',X'20008',X'20008',X'20008',
      X'20008',X'20008',X'20008'
!*
%finishelsestart  {Concept}
!*
%constintegerarray Expprocpdesc(0:16)= %c
      X'20008',X'20008',X'2000C',X'20008',X'3000C',
      X'3000C',X'3000C',0       ,0       ,X'20008',
      X'20010',X'20008',X'3000C',X'3000C',X'3000C',
      X'20008',x'20008'
!*
%conststring(9)%array Spprocs(0:30)= %c
      "f_crmult" ,"f_cdmult" ,"f_cqmult" ,"c_div"  ,
      "z_div"    ,"f_cqdiv"  ,"f_index"  ,"f_concat" ,
      "p_stop"   ,"f_cpystr" ,"f_cpstr"  ,"p_eoft",
      "p_eof"    ,"p_eol"    ,"p_lazy"   ,"f_ishft",
      "f_ibits"  ,"f_ibset"  ,"f_btest"  ,"f_ibclr",
      "i_shftc"  ,"i_auxst"  ,"s_adjl"   ,"s_adjr",
      "i_vrfy"   ,"lshift"   ,"rshift", "ftnmpyjj_",
      "ftndivjj_","#udiv"    ,"#urem"
!*
%constintegerarray Spprocpdesc(0:30)= %c
      X'3000C',X'3000C',X'3000C',X'3000C',
      X'3000C',X'3000C',X'40010',X'40010',
      0       ,X'40010',X'50014',X'10004',
      X'10004',X'10004',X'10004',X'20008',
      X'3000C',X'20008',X'20008',X'20008',
      X'3000C',X'20008',X'40010',X'40010',
      X'40010',X'20008',X'20008',X'20008',
      X'20008',X'20008',X'20008'
!*
%finish
!*
%constintegerarray Spproctype(0:30)= %c
      X'10000',X'10000',X'10000',X'10000',
      X'10000',X'10000',X'10000',X'10000',
      0       ,X'10000',X'10401',X'10401',
      X'10401',X'10401',X'10401',X'10401',
      X'10401',X'10401',X'10401',X'10401',
      X'10401',X'10401',X'10000',X'10000',
      X'10401',X'10401',X'10401',X'10801',
      X'10801',X'10401',X'10401'
!*
%ownintegerarray Spprocref(0:30)
!*
%owninteger Unasslab,Bounderr
!*
%ownintegerarray Procprops(0:15);   ! hold the props as passed to Eproc
%ownintegerarray Procstkmark(0:15)
%ownintegerarray Noteparamsize(0:15)
!*
%constintegerarray Bmaskval(0:31) =  %c
   x'1',x'3',x'7',x'f',x'1f',x'3f',x'7f',x'ff',
   x'1ff',x'3ff',x'7ff',x'fff',x'1fff',x'3fff',x'7fff',x'ffff',
   x'1ffff',x'3ffff',x'7ffff',x'fffff',
   x'1fffff',x'3fffff',x'7fffff',x'ffffff',
   x'1ffffff',x'3ffffff',x'7ffffff',x'fffffff',
   x'1fffffff',x'3fffffff',x'7fffffff',x'ffffffff'
!*
!***********************************************************************
!*        Gould-specific declarations                                 *
!***********************************************************************
!*
!*
%constinteger r0=0
%constinteger r1=1
%constinteger r2=2
%constinteger r3=3
%constinteger r4=4
%constinteger r5=5
%constinteger r6=6
%constinteger r7=7
%constinteger br0=8
%constinteger br1=9
%constinteger br2=10
%constinteger br3=11
%constinteger br4=12
%constinteger br5=13
%constinteger br6=14
%constinteger br7=15
!*
%constbyteintegerarray Falsecc(0:5)= 5,4,3,2,1,0       {LE GE NE EQ LT GT}
!*
%owninteger Stack Offset=0
%owninteger Param Offset=0
%owninteger Gla Offset  =0
%owninteger Display Offset=0
!*
%recordformat cswfmt(%integer id,type,plt,index,count,lower)
%ownrecord(cswfmt)%array csw(0:63)
%owninteger numcsw
!*
!***********************************************************************
!*
%ownintegerarray Areabase(0:255)
%ownintegerarray Areaid(0:255)
%ownintegerarray Areaprops(0:255)
!*
%owninteger Addrstackca, Addrglaca
%owninteger CC, CCset
%owninteger Curdiagca
%owninteger CurCnst
%owninteger Curswitchad
%owninteger Visibleproc
%owninteger Auxaddr
%owninteger saveoptions;               ! for holding the options given to Einitialise
%ownstring(7)auxsname="p_aux";         ! The name of aux stack data ref
%owninteger BSSlen
%owninteger consthalf,Nearhalf;         ! Constant address for Convert RI
%owninteger Notediagdisp
%owninteger Keycommon
%owninteger Numregvars
%owninteger Ecdupflag
%owninteger  numcsave
%ownintegerarray Regvaroffset(0:4)
%ownintegerarray Regvarsize(0:4)
%ownintegerarray Regvarclass(0:4)
%ownintegerarray Regvarval(0:4)
%ownintegerarray Regvarload(0:4)
!*
!***********************************************************************
!*
%ownstring(8)%array Areas(0:255)=  %c
   "Locals","Code","Static","Plt","Ust","Fardata","Diags","Params",
   "Ioarea","Bss","Consts",""(245)
!*
%routine Phex(%integer Val)
%conststring(1)%array C(0:15)=  %c
   "0","1","2","3","4","5","6","7",
   "8","9","A","B","C","D","E","F"
%integer I
      %cycle I=28,-4,0
         printstring(C((Val>>I)&15))
      %repeat
%end
!*
!*
%routine Dump Estack
%record(Stkfmt)%name E
%integer I,J,K
%routine Pform(%integer Form,Reg,Base,Offset)
      printstring(Eform(Form&31))
      %if Form>=RegVar %then write(Reg,1) %and %return
      %if Form=Litval %thenstart
         write(Offset,4)
         %return
      %finish
      printstring(Areas(Base))
      %if Offset<0 %thenstart
         printstring(" - ")
         Offset=-Offset
      %finishelse printstring(" + ")
      write(Offset,0)
%end;! Pform
      Dump Regs(0)
      %if Elevel<=0 %then %return
      I=Elevel
      %while I>0 %cycle
         J=addr(Stk(I))
         E==record(J)
         write(I,1);printstring(":")
         Pform(E_Form,E_Reg,E_Base,E_offset)
         %if RegVar>(E_Form&31)>=AddrDirMod %thenstart
            printstring("  mod by:")
            Pform(E_Modform,E_Modreg,E_Modbase,E_Modoffset)
            %if E_Scale>1 %thenstart
               printstring("  scaled by:")
               write(E_Scale,1)
            %finish
         %finish
         printstring("  size:")
         write(E_Size,1)
         newline
         I=I-1
      %repeat
%end;! Dump Estack
!*
%externalroutine EGiveName(%integer Key,%stringname S)
      S={"@".}Areas(Key)
%end;! EGiveName
!*
%externalintegerfn EGiveAreaId(%integer Area)
      %if Area<=10 %then %result=Area
      %result=AreaId(Area)
%end;! EGiveAreaId
!*
!*
%externalroutine Enote CC(%integer Cond)
      CCset=1
      CC=Cond
%end;! Enote CC
!*
%externalintegerfn Eglaspace(%integer size)
!***********************************************************************
!***********************************************************************
!*      Obtain from the gla allocated by compiler. Can not trust       *
!*      the pointer to be word aligned                                 *
%integer ad
      ad=integer(Addrglaca)
      %if size>1 %and ad&1#0 %then ad=ad+1
      %if size>2 %and ad&2#0 %then ad=ad+2
      %if size>4 %and ad&4#0 %then ad=ad+4
      integer(Addrglaca)=ad+size
      %result=ad
%end;! Eglaspace
!*
%externalintegerfn Estackspace(%integer size)
%integer ad
      ad=integer(Addrstackca)
      %if size>4 %and ad&4#0 %then ad=ad+4
      integer(Addrstackca)=ad+size
      %result=ad
%end;! Estackspace
!*
%externalintegerfn Estkrecad(%integer level)
      %result=addr(Stk(level))
%end;! Estkrecad
!*
!**********************************************************************
!**********************************************************************
!**                      Error reporting                             **
!**********************************************************************
!**********************************************************************
!*
!*
%externalroutine Low Estack(%integer Opcode,Reqlevel)
      printstring("******* Estack error ******
!!  Op = ".Eopname(Opcode)."  actual/required levels:")
      write(Elevel,4)
      write(Reqlevel,4)
      newline
%monitor
%stop
      Elevel=0
%end;! Low Estack
!*
%routine Abort
      Dump Estack
      %monitor
      %stop
%end;! Abort
!*
%routine Abortm(%string(31) S)
      printstring("
*** Mgen abort - ".S." ***
")
      Dump Estack
      %monitor
      %stop
%end;! Abort
!*
%routine Unsupported Opcode(%integer Opcode)
%string(15) S
      %if Opcode<=255 %then S=Eopname(Opcode) %else S=Ef77opname(Opcode)
      printstring("******* Unsupported Opcode ****** ".S)
      newline
%end;! Unsupported Opcode
!*
!*
!***********************************************************************
!***********************************************************************
!**             Externally visible procedures                         **
!***********************************************************************
!***********************************************************************
!*
!*
!*                    *********************
!*                    *  Administration   *
!*                    *********************
!*
!*
%externalroutine Einitialise(%integer Lang,Aver,Astackca,Aglaca,options)
!***********************************************************************
!* called once at the start of compilation to initialise Eput          *
!* options: bit  1   emon                                              *
!*               2   codeon                                            *
!*               4   mmon                                              *
!*               8)  00  no diags                                      *
!*              16)  01  min diags                                     *
!*                   10  diags + line nos                              *
!*                   11  sdb/dbx                                       *
!*             256)  (Imp) Unass checking on                           *
!*             512)  (Imp) array checking on                           *
!***********************************************************************
%integer I
      %if options&1 # 0 %then Emonon
      %if options&4 # 0 %then Mmonon
      Saveoptions=options
      ProgFaulty=0
      Decode=Options&2
      Language=Lang
      Stack Offset=0
      Param Offset=0
      Display Offset=0
      Gla Offset=0
      %if Language=IMP %thenstart
         Report=0
      %finishelsestart
         Report=PrimeReport
      %finish
      %if Report#0 %thenstart
         printstring("Einitialise ")
         newline
      %finish
      Init Mcode(Decode,Lang,options)
      Addrstackca=Astackca
      Addrglaca=Aglaca
      Clear Regs
      CCset=0
      Elevel=0
      ProcLevel=0
      %cycle I=0,1,255
         Areabase(I)=0
         Areaid(I)=0
         Areaprops(I)=0
      %repeat
      %cycle I=4,1,10
         Areabase(I)=I<<2+64
      %repeat
      %cycle I=0,1,14
         Expprocref(I)=0
      %repeat
      %cycle I=0,1,10
         Areaid(I)=1
      %repeat
      %cycle I=0,1,26
         Spprocref(I)=0
      %repeat
!*
      Minitialise(0,1,Language)
!*
      Mfix(Gla,8,Ust,0)
      Mfix(Gla,12,SST,0)
      Md4(Gla,16,Language<<24)
      Mfix(Gla,20,Diags,0)
!*
      
      Curcnst=0
!*
      Auxaddr=0
!      BSSlen=0
!*
      Rstk=0;  Rstk_Form=RegVal;   Rstk_Size=4
      Frstk=0; Frstk_Form=FregVal
      LitZero=0; LitZero_Form=LitVal
      LitOne=0; LitOne_Form=LitVal; LitOne_IntVal=1
!8
      consthalf=0; Nearhalf=0
      Keycommon=-1
      Numregvars=0
      Ecdupflag=0
      Numcsave=0
      Bitarea=-1
      Bitdisp=-1
!*
%end;! Einitialise
!*
%externalroutine Eterminate(%integer adareasizes)
!***********************************************************************
!* called once at the end of compilation by the code generator         *
!***********************************************************************
%ownintegerarray S(1:10)
%integer I,J,ca
      %if ProgFaulty#0 %then %return
      J=0
      %cycle I=1,1,9
         S(I)=integer(Adareasizes+J)
         J=J+4
      %repeat
      %if Language=Ccomp %thenstart
         S(8)=S(5)
         S(5)=0
      %finish
      ca=Tidy Mcode(1,Pltsize)
      S(1) =ca
      s(3)=Pltsize
!      %if Language=IMP %then S(9)=BSSlen
      S(10)=CurCnst
      %if Report#0 %thenstart
         printstring("Eterminate ")
         write(S(I),1) %for I=1,1,10
         newline
      %finish
      Mterminate(addr(S(1)))
      integer(adareasizes)=S(1)
%end;! Eterminate
!*
%externalroutine Ecommon(%integer area,%stringname Name)
!***********************************************************************
!* define a common area (in range 11-255)                              *
!***********************************************************************
%string(31) S
%integer Prop
      %if Report#0 %thenstart
         printstring("Ecommon   ");Write(Area,1);spaces(4);printstring(Name) 
         Newline
      %finish
      %if ProgFaulty#0 %then %return
      S=Name
      %if S="F#BLCM" %then Prop=1 %and S="_BLNK__" %else Prop=2
      Areaprops(Area)=Prop
      Areas(Area)<-S
      Areaid(Area)=Mcommon(S)
      %if Keycommon<0 %then Keycommon=area
%end;! Ecommon
!*
%externalroutine Eendcommon(%integer area,Length)
!***********************************************************************
!* define length of previously defined common                          *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Eendcommon   ");write(Area,1);write(Length,6) 
         Newline
      %finish
      %if ProgFaulty#0 %then %return
      Mendcommon(Areaid(Area),Length)
%end;! Eendcommon
!*
%externalroutine Elinestart(%integer lineno)
!***********************************************************************
!* register start of a line                                            *
!***********************************************************************
      Report=PrimeReport
      %if Report#0 %thenstart
         printstring(" Elinestart ++++++++++++++++++++++");write(Lineno,4)
         newline
         Dump Regs(1)
      %finish
      %if ProgFaulty#0 %then %return
      Savelineno=Lineno
      Mline(Lineno)
%end;! Elinestart
!*
%externalroutine Elinedecode
!***********************************************************************
!* decompile code generated from last Elinedecode or Elinestart        *
!***********************************************************************
    { Plinedecode }
%end;! Elinedecode
!*
%externalintegerfn Estkmarker
!***********************************************************************
!* note marker for a literal value                                     *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Estkmarker  ")
         newline
      %finish
      Estklit(X'0101');! to guarantee 16-bit hole for later plugging
      %result=Mmarker
%end;! Estkmarker
!*
%externalroutine Esetmarker(%integer Markerid,New Value)
!***********************************************************************
!* substitute value at a marker                                        *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Esetmarker  ");write(Markerid,4)
         write(New Value,4)
         newline
      %finish
      Msetopd(Markerid,New Value)
%end;! Esetmarker
!*
%externalintegerfn Eswapmode
!***********************************************************************
!* turn on internal tracing                                            *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Eswapmode  ")
         newline
      %finish
      %result=0
%end;! Eswapmode
!*
%externalroutine Emonon
!***********************************************************************
!* turn on internal tracing                                            *
!***********************************************************************
      PrimeReport=1
      Report=1
%end;! Emonon
!*
%externalroutine Emonoff
!***********************************************************************
!* turn off internal tracing                                           *
!***********************************************************************
      PrimeReport=0
      Report=0
%end;! Emonoff
!*
%externalroutine Efaulty
!***********************************************************************
!* compilation has a fault - no object file to be generated            *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Efaulty ");
         newline
      %finish
      ProgFaulty=1
      Mfaulty
%end;! Efaulty
!*
!*
!*
!*                 *********************
!*                 * Stack operations  *
!*                 *********************
!*
!*
%externalroutine Estklit(%integer Val)
!***********************************************************************
!* stacks Val as a 32-bit integer literal                              *
!***********************************************************************
%record(Stkfmt)%name Lstk
      %if Report#0 %thenstart
         printstring("Estklit  ");write(Val,6)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if CCset#0 %then Establish Logical
      %if Elevel=Stklimit %then %monitor %and %stop
      Elevel=Elevel+1
      Lstk==Stk(Elevel)
      Lstk=0
      Lstk_Form=LitVal
      Lstk_Intval=Val
      Lstk_Size=4
%end;! Estklit
!*
%externalroutine Estkconst(%integer Len,Ad)
!***********************************************************************
!* stacks the constant, allocating space for it if necessary           *
!***********************************************************************
%integer Area,Offset
      %if Report#0 %thenstart
         printstring("Estkconst     ")
         write(Len,4)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      Msetconst(Ad,Len,Area,Offset)
      Estkdir(Area,Offset,0,Len)
%end;! Estkconst
!*
%externalroutine Estkrconst(%integer Len,Ad)
!***********************************************************************
!* stacks the constant, allocating space for it if necessary           *
!***********************************************************************
%integer Area,Offset
      %if Report#0 %thenstart
         printstring("Estkconst     ")
         write(Len,4)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      Msetconst(Ad,Len,Area,Offset)
      Estkdir(Area,Offset,0,Len)
%end;! Estkrconst
!*
%externalroutine Estkdir(%integer Area,Offset,Adid,Bytes)
!***********************************************************************
!* stacks a direct operand                                             *
!***********************************************************************
%integer I
%record(Stkfmt)%name Lstk
      %if Report#0 %thenstart
         printstring("Estkdir   ".Areas(area)." +");write(Offset,1)
         write(Bytes,6)
         %if Adid#0 %then spaces(4) %and printstring(string(Adid))
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if CCset#0 %then Establish Logical
      %if Language=Ccomp %thenstart
         %if Area=5 %then Area=8
      %finish
      %if Area=Gla %then Offset=Offset+Gla Offset
      %if Elevel=Stklimit %then Abort
      Elevel=Elevel+1
      Lstk==Stk(Elevel)
      Lstk=0
      Lstk_Form=DirVal
      Lstk_Size=Bytes
      Lstk_Base=Area
      %if Area=Stack %thenstart
         Offset=Offset+Stack Offset
         %if Numregvars>0 %thenstart
            %cycle I=1,1,Numregvars
               %if Regvaroffset(I)=Offset %thenstart
                  Lstk_Form=Regvarclass(I)
                  Offset=0
                  Lstk_Reg=Regvarval(I)
                  %exit
               %finish
            %repeat
         %finish
      %finish
      Lstk_Offset=Offset
      Lstk_Adid=Adid
%end;! Estkdir
!*
%externalroutine Estkind(%integer Area,Offset,Adid,Bytes)
!***********************************************************************
!* stacks an indirect operand                                          *
!***********************************************************************
%record(Stkfmt)%name Lstk
      %if Report#0 %thenstart
         printstring("Estkind   ".Areas(area)." +");write(Offset,1)
         write(Bytes,6)
         %if Adid#0 %then spaces(4) %and printstring(string(Adid))
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if CCset#0 %then Establish Logical
      %if Language=Ccomp %thenstart
         %if Area=5 %then Area=8
      %finish
      %if Area=Stack %then Offset=Offset+Stack Offset
      %if Area=Gla %then Offset=Offset+Gla Offset
      %if Elevel=Stklimit %then Abort
      Elevel=Elevel+1
      Lstk==Stk(Elevel)
      Lstk=0
      Lstk_Form=IndDirVal
      Lstk_Size=Bytes
      Lstk_Base=Area
      Lstk_Offset=Offset
      Lstk_Adid=Adid
%end;! Estkind
!*
%externalroutine Estkglobal(%integer Level,Offset,Adid,Bytes)
!***********************************************************************
!* stacks a direct operand local to an enclosing level                 *
!***********************************************************************
%record(Stkfmt)%name Lstk
      %if Report#0 %thenstart
         printstring("Estkglobal ");write(Level,1);write(Offset,1)
         write(Bytes,6)
         %if Adid#0 %then spaces(4) %and printstring(string(Adid))
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if CCset#0 %then Establish Logical
      %if Elevel=Stklimit %then Abort
      Elevel=Elevel+1
      Lstk==Stk(Elevel)
      Lstk=0
      Lstk_Form=IndDirModVal
      Lstk_Size=Bytes
      Lstk_Base=Stack
      Lstk_Offset=Display Offset + (Level*4)
      Lstk_Modform=Litval
      Lstk_Modoffset=Offset
      Lstk_Adid=Adid
%end;! Estkglobal
!*
%externalroutine Estkgind(%integer Level,Offset,Adid,Bytes)
!***********************************************************************
!* stacks an indirect operand local to an enclosing level              *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Estkgind ");write(Level,1);write(Offset,1)
         write(Bytes,6)
         %if Adid#0 %then spaces(4) %and printstring(string(Adid))
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if CCset#0 %then Establish Logical
      %if Elevel=Stklimit %then Abort
      Estkglobal(Level,Offset,Adid,4)
      Erefer(0,Bytes)
%end;! Estkgind
!*
%externalroutine Estkpar(%integer Level,Offset,Adid,Bytes)
!***********************************************************************
!* stacks a direct parameter operand                                   *
!***********************************************************************
%record(Stkfmt)%name Lstk
      %if Report#0 %thenstart
         printstring("Estkpar   ");write(Level,1);write(Offset,1)
         write(Bytes,6)
         %if Adid#0 %then spaces(4) %and printstring(string(Adid))
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if CCset#0 %then Establish Logical
      %if Elevel=Stklimit %then Abort
      Elevel=Elevel+1
      Lstk==Stk(Elevel)
      Lstk=0
      Lstk_Form=DirVal
      Lstk_Size=Bytes
      %if Language=IMP %and Procprops(Proclevel)&2****5=0 %thenstart
         Lstk_Base=0
         Lstk_Offset=Offset+Stack Offset
      %finishelsestart
         Lstk_Base=7
         Lstk_Offset=Offset+Param Offset
      %finish
      Lstk_Adid=Adid
%end;! Estkpar
!*
%externalroutine Estkparind(%integer Level,Offset,Adid,Bytes)
!***********************************************************************
!* stacks an indirect parameter operand                                *
!***********************************************************************
%record(Stkfmt)%name Lstk
      %if Report#0 %thenstart
         printstring("Estkparind ");write(Level,1);write(Offset,1)
         write(Bytes,6)
         %if Adid#0 %then spaces(4) %and printstring(string(Adid))
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if CCset#0 %then Establish Logical
      %if Elevel=Stklimit %then Abort
      Elevel=Elevel+1
      Lstk==Stk(Elevel)
      Lstk=0
      Lstk_Form=IndDirVal
      Lstk_Size=Bytes
      %if Language=IMP %and Procprops(Proclevel)&2****5=0 %thenstart
         Lstk_Base=0
         Lstk_Offset=Offset+Stack Offset
      %finishelsestart
         Lstk_Base=7
         Lstk_Offset=Offset+Param Offset
      %finish
      Lstk_Adid=Adid
%end;! Estkparind
!*
%externalroutine Estkresult(%integer Class,Type,Bytes)
!***********************************************************************
!* defines the result stacked by a function call                       *
!* Type = 1  int                                                       *
!*      = 2  real                                                      *
!***********************************************************************
%integer reg
      %if Report#0 %thenstart
         printstring("Estkresult ")
         write(Class,4);write(Type,4);write(Bytes,4)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if Cpu=Concept %thenstart
         reg=r0
      %finishelsestart
         reg=r2
      %finish
      %if Type=2 %thenstart;! real
         Stackfr(reg,Bytes)
      %finishelse Stackr(reg,bytes)
%end;! Estkresult
!*
%externalroutine Erefer(%integer Offset,Bytes)
!***********************************************************************
!* stacks the address of a direct operand                              *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("EREFER   ");write(Offset,1);write(Bytes,6)
         newline
         Dump Estack
      %finish
      %if ProgFaulty#0 %then %return
      %if Elevel<1 %then Abort
      Refer(Stk(Elevel),Offset)
      Stk(Elevel)_Size=Bytes
%end;! Erefer
!*
%externalroutine Epromote(%integer Level)
!***********************************************************************
!* move the entry at Level in Estack to the top of the Estack          *
!*  - the top entry is at level 1                                      *
!***********************************************************************
%record(Stkfmt) E 
%integer I
      %if Report#0 %thenstart
         printstring("Epromote ");write(Level,4)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if CCset#0 %then Establish Logical
      %unless 0<Level<=Elevel %then abort
      %if Level=1 %then %return
      Level=Elevel-Level+1
      E=Stk(Level)
      Reset Reguse(Level,Elevel+1);! to avoid problems
      %cycle I=Level,1,Elevel-1
         Stk(I)=Stk(I+1)
         Reset Reguse(I+1,I)
      %repeat
      Stk(Elevel)=E
      Reset Reguse(Elevel+1,ELevel)
%end;! Epromote
!*
%externalroutine Edemote(%integer Level)
!***********************************************************************
!* move the entry at the top of the Estack to Level in Estack          *
!*  - the top entry is at level 1                                      *
!***********************************************************************
%record(Stkfmt) E 
%integer I
      %if Report#0 %thenstart
         printstring("Edemote ");write(Level,4)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if CCset#0 %then Establish Logical
      %unless 0<Level<=Elevel %then abort
      %if Level=1 %then %return
      Level=Elevel-Level+1
      E=Stk(Elevel)
      Reset Reguse(Elevel,Elevel+1);! to avoid problems
      %cycle I=Elevel,-1,Level+1
         Stk(I)=Stk(I-1)
         Reset Reguse(I-1,I)
      %repeat
      Stk(Level)=E
      Reset Reguse(Elevel+1,Level)
%end;! Edemote
!*
%externalroutine Estkaddr(%integer Area,Offset,Adid,Bytes)
!***********************************************************************
!* stacks the address of a direct operand                              *
!***********************************************************************
 %record(Stkfmt)%name Lstk
     %if Report#0 %thenstart
         printstring("Estkaddr   ".Areas(area)." +");write(Offset,1)
         write(Bytes,6)
         %if Adid#0 %then spaces(4) %and printstring(string(Adid))
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if CCset#0 %then Establish Logical
      %if Language=Ccomp %thenstart
         %if Area=5 %then Area=8
      %finish
      %if Area=Stack %then Offset=Offset+Stack Offset
      %if Elevel=Stklimit %then %monitor %and %stop
      Elevel=Elevel+1
      Lstk==Stk(Elevel)
      Lstk=0
      Lstk_Form=AddrDir
      Lstk_Size=4;! always 4 bytes for an address
      Lstk_Base=Area
      Lstk_Offset=Offset
      Lstk_Adid=Adid
%end;! Estkaddr
!*
%externalroutine Estkgaddr(%integer Level,Offset,Adid,Bytes)
!***********************************************************************
!* stacks the address of a global operand                              *
!***********************************************************************
 %record(Stkfmt)%name Lstk
     %if Report#0 %thenstart
         printstring("Estkgaddr   ")
         write(Level,1);write(Offset,1)
         write(Bytes,6)
         %if Adid#0 %then spaces(4) %and printstring(string(Adid))
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if CCset#0 %then Establish Logical
      Offset=Offset+Param Offset
      %if Elevel=Stklimit %then %monitor %and %stop
      Elevel=Elevel+1
      Lstk==Stk(Elevel)
      Lstk=0
      Lstk_Form=IndDirVal
      Lstk_Size=4;! always 4 bytes for an address
      Lstk_Base=0
      Lstk_Offset=Display Offset + (Level*4)
      Lstk_Modform=Litval
      Lstk_Modoffset=Offset
      Lstk_Adid=Adid
      Eop(Eaddress)
%end;! Estkgaddr
!*
%externalroutine Estkreg(%integer reg,Offset)
!***********************************************************************
!* used by optimiser                                                   *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Estkreg ");write(Reg,4)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      Stackr(reg,4)
      Stk(Elevel)_Offset=Offset
      Moptreguse(r6,0)
%end;! Estkreg
!*
%externalroutine Eregvar(%integer Offset,Size,Loadit)
!***********************************************************************
!* used by C                                                           *
!***********************************************************************
%integer I,Reg
      %if Report#0 %thenstart
         printstring("Eregvar");write(Offset,4);write(Size,4)
         newline
      %finish
      %if ProgFaulty#0 %then %return
%return
      %if Numregvars>0 %thenstart
         %cycle I=1,1,Numregvars
            %if Regvaroffset(I)=Offset %then %return
         %repeat
      %finish
      %if Numregvars<4 %thenstart
         I=Numregvars+1
         Numregvars=I
         Regvaroffset(I)=Offset
         Regvarsize(I)=Size
         Regvarclass(I)=RegVar
         Regvarval(I)=8-I
         Regvarload(I)=Loadit
         %if Loadit#0 %thenstart
            Numregvars=0  {to avoid mapping to reg}
            Estkdir(Stack,Offset,0,Size)
            Elevel=Elevel-1
            Reg=Load Reg(Regvarval(I),Stk(Elevel+1))
         %finish
      %finish
%end
!*
%externalroutine Eloseregs(%integer Level)
%integer I,Count
      %if Report#0 %thenstart
         printstring("Eloseregs");write(Level,4);newline
      %finish
      Count=Numregvars
      Numregvars=0
      %if Count>0 %thenstart
         %cycle I=1,1,Count
            %if Regvarload(I)#0 %thenstart
               Estkdir(Stack,Regvaroffset(I),0,Regvarsize(I))
               Elevel=Elevel-1
               Gop RX(ST,Regvarval(I),Stk(Elevel+1))
             %finishelse Numregvars=I
         %repeat
      %finish
%end;! Eloseregs
!*
!*
!*
!*                 *********************
!*                 *  Labels, Jumps    *
!*                 *********************
!*
!*
%externalroutine Elabel(%integer Id)
!***********************************************************************
!* register a label                                                    *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Elabel >>>>>>>>>>>>>>>>>>>>>>>>>>>>>  L");write(Id,0)
         newline
      %finish
      %if ProgFaulty#0 %then %return
{      %if Elevel>0 %then Abort}
      Mcode label(id)
%end;! Elabel
!*
%externalroutine Ediscardlabel(%integer Id)
!***********************************************************************
!* advise that  a label can now be discarded - i.e. no future ref       *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Ediscardlabel ");write(Id,4)
         newline
      %finish
%end;! Ediscardlabel
!*
%externalroutine Euchecklab(%integer Labid)
      Unasslab=Labid
%end
!*
%externalroutine Eboundlab(%integer Labid)
      Bounderr=Labid
%end
!*
%externalroutine Ecjump(%integer Opcode,Labelid)
!* special for C - condition code set
%integer Op
      %if Opcode=JFALSE %then Op=BEQ %else Op=BNE
      Gop Jump(Op,Labelid)
%end;! Ecjump
!*
%routine Size8check
      %if stk(Elevel-1)_size=8 %and Stk(Elevel)_size#8 %start
         Estklit(8)
         Eop(CVTII)
      %finish
      %if stk(Elevel-1)_size#8 %and stk(Elevel)_size=8 %start
         Eop(Exch)
         Estklit(8)
         Eop(CVTII)
         Eop(EXCH)
      %finish
%end
!*
%externalroutine Ejump(%integer Opcode, Labelid)
!***********************************************************************
!* generate specified conditional or unconditional jump                *
!***********************************************************************
%switch OpI(JIGT:JUMP),OpR(JRGT:JFALSE),OpU(JUGT:JULEZ)
%integer Reg1,Freg1,Bytes,Bcc,Bcond,I
      %if Report#0 %thenstart
         printstring("Ejump ".Eopname(Opcode));write(Labelid,4)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if CCset#0 %thenstart
         %if Opcode=JINTZ %then Opcode=JFALSE
         %if Opcode=JINTNZ %then Opcode=JTRUE
         %if Opcode<JTRUE %then Establish Logical
      %finish
      %if Opcode<JRGT %thenstart
         %if Opcode<JUGT %then ->OpI(Opcode) %else ->OpU(Opcode)
      %finishelse ->OpR(Opcode)
!*
OpI(*):
OpI(*):
      Abort
!*
OpI(JIGT):
OpI(JILT):
OpI(JIEQ):
OpI(JINE): 
OpI(JIGE): 
OpI(JILE):
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      Size8check
      Elevel=Elevel-2
      Int Binary Op(IGT+Opcode-JIGT,Stk(Elevel+1),Stk(Elevel+2))
      Gop Jump(BGT+CC,Labelid)
      CCset=0
      %return
!*
OpU(JUGT):
OpU(JULT):
OpU(JUEQ):
OpU(JUNE): 
OpU(JUGE): 
OpU(JULE):
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      Elevel=Elevel-2
   {   Int Binary Op(IGT+Opcode-JUGT,Stk(Elevel+1),Stk(Elevel+2))  }
   {   Gop Jump(BGT+Opcode-JUGT,Labelid)  }
      CCset=0
      %return
!*
OpI(JINTGZ):
OpI(JINTLZ):
OpI(JINTZ):
OpI(JINTNZ):
OpI(JINTGEZ):
OpI(JINTLEZ):
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
      Elevel=Elevel-1
      Gop X(TST,Stk(Elevel+1))
      Gop Jump(BGT+Opcode-JINTGZ,Labelid)
      %return
!*
OpU(JUGTZ):
OpU(JULTZ):
OpU(JUEQZ):
OpU(JUNEZ):
OpU(JUGEZ):
OpU(JULEZ):
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
      Elevel=Elevel-1
    {  Gop X(TST,Stk(Elevel+1))  }
    {  Gop Jump(BGT+Opcode-JUNTGZ,Labelid)  }
      %return
!*
OpI(JUMP):
      Gop Jump(BU,Labelid)
      %return
!*
OpR(JRGT):
OpR(JRLT):
OpR(JREQ): 
OpR(JRNE): 
OpR(JRGE):
OpR(JRLE): 
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      Elevel=Elevel-2
      Real Binary Op(RGT+Opcode-JRGT,Stk(Elevel+1),Stk(Elevel+2))
      Gop Jump(BGT+CC,Labelid)
      CCset=0
      %return
!*
OpR(JRGZ):  
OpR(JRLZ):
OpR(JRZ): 
OpR(JRNZ):
OpR(JRGEZ):
OpR(JRLEZ):
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
      Elevel=Elevel-1
      Gop X(TST,Stk(Elevel+1))
      Gop Jump(BGT+Opcode-JRGZ,Labelid)
      %return
!*
OpR(JTRUE):
      Bcc=BGT+CC
      Bcond=BNE
Jtf:  %if CCset=0 %thenstart
         %if Elevel=0 %and Language=Ccomp %then ->L1
         %if Elevel<1 %then Low Estack(Opcode,1) %and %return
         Elevel=Elevel-1
         %if Stk(Elevel+1)_Form=LitVal %thenstart
            I=Stk(Elevel+1)_IntVal
            %if (I=0 %and Bcond=BEQ) %or (I#0 %and Bcond=BNE) %thenstart
               Gop Jump(BU,Labelid)
               %return
            %finish
         %finish
         Gop X(TST,Stk(Elevel+1))
L1:      Gop Jump(Bcond,Labelid)
         %return
      %finish
      Gop Jump(Bcc,Labelid)
      CCset=0
      %return
!*
OpR(JFALSE):
      Bcc=BGT+Falsecc(CC)
      Bcond=BEQ
      ->Jtf
%end;! Ejump
!*
%externalroutine Etwjump(%integer Opcode,Lab1,Lab2,Lab3)
!***********************************************************************
!* generate the code for a Fortran three-way jump                      *
!* opcode = ITWB or RTWB for integer or real expression on Estack      *
!* Lab1,Lab2,Lab3 are the labels to jump to if Etos <0,=0,>0           *
!*  - if Labi <= 0 that jump is not required                           *
!***********************************************************************
%integer Op,Reg1,Freg1,Bytes
      %if Report#0 %thenstart
         printstring("Etwjump  ".Eopname(Opcode))
         write(Lab1,4);write(Lab2,4);write(Lab3,4)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
      Elevel=Elevel-1
      Gop X(TST,Stk(Elevel+1))
      %if Lab1>0 %then Gop Jump(BLT,Lab1);! if < 0
      %if Lab2>0 %then Gop Jump(BEQ,Lab2);!    = 0
      %if Lab3>0 %then Gop Jump(BGT,Lab3);!    > 0
%end;! Etwjump
!*
%externalroutine Eswitch(%integer Lower, Upper, Switchid, Errlabid,
                                                %integername SSTad)
!***********************************************************************
!* define a switch Switchid to be indexed in the range (Lower:Upper)   *
!* space may be claimed from SST for the switch table                  *
!***********************************************************************
%integer Refad,Base,Mode,Reg,Op,p,c,plab,plab1,i,numcases
      %if Report#0 %thenstart
         printstring("Eswitch ")
         write(Lower,4);write(Upper,4);write(Switchid,4);write(Errlabid,4)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if Ccset#0 %then Establish Logical
      %if Language=CCOMP %thenstart
         numcases=Errlabid
         %if lower<0 %and upper>0 %thenstart  {protect aggainst overflow}
            i=(-lower)>>1 + upper>>1
            %if i>>30=1 %then ->unsafe
         %finish
         %if upper-lower>256 %and upper-lower>10*numcases %thenstart
unsafe:
            numcsw=numcsw+1
            csw(numcsw)_id=switchid
            csw(numcsw)_count=numcases
            csw(numcsw)_lower=lower
            csw(numcsw)_index=0
            upper=numcases
            lower=0
            csw(numcsw)_plt=pltspace((numcases+1)<<2)
            base=SSTad
            Refad=SSTad
            SSTad=SSTad+(Upper+1)<<2
            note reguse(r0,0,4)
            note reguse(r1,0,4)
            elevel=elevel-1
            reg=load int(Stk(Elevel+1),r0)
            p=csw(numcsw)_plt
            c=csw(numcsw)_count
            plab1=mprivatelabel
            %cycle I=1,1,c
               Plab=mprivatelabel
               eafix(PLT,0)
               Gop RXB(CAM,r0,0,0,p,4)
               Gop Jump(BNE,Plab)
               Gop RI(LI,r1,I)
               Gop Jump(BU,plab1)
               Mcode Label(Plab)
               p=p+4
            %repeat
            Gop Jump(BU,switchid)
            Mcode Label(Plab1)
            Mswitch(0,Refad,Base,Upper+1,switchid,switchid)
            %return
         %finishelsestart
            numcsw=numcsw+1
            csw(numcsw)_id=switchid
            csw(numcsw)_plt=0
            csw(numcsw)_lower=lower
            %unless lower=0 %thenstart
               Estklit(lower)
               Eop(ISUB)
            %finish
            Upper=Upper-Lower
            Lower=0
         %finish
      %finish
      Base=SSTad
      Refad=SSTad - (Lower*4)
      SSTad=SSTad+(Upper-Lower+1)<<2
      %if Language=FORTRAN %or Language=CCOMP %thenstart;! computed GOTO or C case
         Elevel=Elevel-1
         Note Reguse(r1,0,4)  {ensure that reg is loaded for test}
         Reg=Load Int(Stk(Elevel+1),r1)  { load GOTO index }
         %if Language=FORTRAN %then Op=BLE %else Op=BLT
         Gop Jump(Op,Switchid)
         Estklit(Upper)
         Gop RX(CAM,Reg,Stk(Elevel))
         Elevel=Elevel-1
         Gop Jump(BGT,Switchid)
         %if Language=FORTRAN %thenstart
            Mswitch(1,Refad,Base,Upper,Switchid,0)
            Mcode Label(Switchid)
         %finishelsestart {C case}
            Mswitch(0,Refad,Base,Upper+1,Switchid,Switchid)
         %finish
      %finishelsestart;! IMP switch
         Mcode Label(Switchid)
         Mswitch(0,Refad,Base,Upper-Lower+1,Switchid,Errlabid)
      %finish
%end;! Eswitch
!*
%externalroutine EswitchJump(%integer Switchid)
!***********************************************************************
!* jump to Switchid( (Etos) )                                          *
!* if (Etos) is outside the bounds defined for Switchid then error     *
!***********************************************************************
%integer Reg
      %if Report#0 %thenstart
         printstring("EswitchJump ");write(switchid,4)
         newline
      %finish
      %if Elevel<1 %then Low Estack(JUMP,1) %and %return
      Elevel=Elevel-1
      Reg=Load Int(Stk(Elevel+1),r1)  { load switch index }
      Ejump(JUMP,Switchid)
      Note Reguse(r1,0,0)
%end;! EswitchJump
!*
%externalroutine EfswitchJump(%integer Switchid)
!***********************************************************************
!* jump to Switchid( (Etos) )                                          *
!* if (Etos) is outside the bounds the jump has no effect. Note that   *
!* in this case Switchid(Lower) addresses the next instruction         *
!* N.B. this procedure is only used on Amdahl                          *
!***********************************************************************
{       abortm("EfswitchJump") }
%end;! EfswitchJump
!*
%externalroutine Eswitchentry(%integer Switchid, Entry)
!***********************************************************************
!* define the current code address as Switchid(Entry)                  *
!***********************************************************************
%integer I
      %if Report#0 %thenstart
         printstring("Eswitchentry ");write(Switchid,4);write(Entry,4)
         newline
      %finish
      Clear Regs
      %if Language=Ccomp %thenstart
         %if numcsw>0 %thenstart
            %cycle i=1,1,numcsw
               %if csw(i)_id=switchid %thenstart
                  %if csw(i)_plt=0 %thenstart  {simple switch}
                     Entry=Entry-csw(i)_lower
                  %finishelsestart  {multiple test}
                     Ed4(Plt,csw(i)_plt,entry)
                     csw(i)_plt=csw(i)_plt+4
                     entry=csw(i)_index+1
                     csw(i)_index=entry
                  %finish
                  %exit
               %finish
            %repeat
         %finish
      %finish
      Mswitchentry(Switchid, Entry)
%end;!Eswitchentry
!*
%externalroutine Eswitchdef(%integer Switchid)
!***********************************************************************
!* define the current code address as Switchid(*) - the default        *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Eswitchdef ");write(Switchid,4)
         newline
      %finish
      Abort
%end;!Eswitchdef
!*
%externalroutine EswitchLabel(%integer Switchid, Entry, Labelid)
!***********************************************************************
!* define Labelid as Switchid(Entry)                                   *
!***********************************************************************
%integer I
      %if Report#0 %thenstart
         printstring("EswitchLabel ");write(switchid,4);write(entry,4)
         write(labelid,4)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      Clear Regs
      Mswitchlabel(Switchid,Entry,Labelid)
%end;! EswitchLabel
!*
!*
!*
!*                *******************************
!*                * Data initialisation, fixups *
!*                *******************************
!*
!*
%externalroutine Ed1(%integer area, Disp, Val)
!***********************************************************************
!* intialise an 8-bit location                                         *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Ed1   ".Areas(Area)." +");write(Disp,1)
         spaces(4);Phex(Val)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if Language=Ccomp %thenstart
         %if Area=5 %then Area=8
      %finish
      %if area>10 %then areaprops(area)=areaprops(area)!X'400'  %c
                   %and area=areaid(area)
      Md(area, Disp, Val)
%end;! Ed1
!*
%externalroutine Ed2(%integer area, Disp, Val)
!***********************************************************************
!* intialise a 16-bit location                                         *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Ed2   ".Areas(Area)." +");write(Disp,1)
         spaces(4);Phex(Val)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if Language=Ccomp %thenstart
         %if Area=5 %then Area=8
      %finish
      %if area>10 %then areaprops(area)=areaprops(area)!X'400'  %c
                   %and area=areaid(area)
      Md2(area, Disp, Val)
%end;! Ed2
!*
%externalroutine Ed4(%integer area, Disp, Val)
!***********************************************************************
!* intialise a 32-bit location                                         *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Ed4   ".Areas(Area)." +");write(Disp,1)
         spaces(4);Phex(Val)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if Language=Ccomp %thenstart
         %if Area=5 %then Area=8
      %finish
      %if area>10 %then areaprops(area)=areaprops(area)!X'400'  %c
                   %and area=areaid(area)
      Md4(area, Disp, Val)
%end;! Ed4
!*
%externalroutine Edbytes(%integer area, Disp, len, ad)
!***********************************************************************
!* intialise a block of data                                           *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Edbytes ")
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if Language=Ccomp %thenstart
         %if Area=5 %then Area=8
      %finish
      %if Area=10 %then %monitor;! should not be allocated any more
      %if area>10 %then areaprops(area)=areaprops(area)!X'400'  %c
                   %and area=areaid(area)
      Mdbytes(area, disp, len, ad)
%end;! Edbytes
!*
%externalroutine Edpattern(%integer area, Disp, ncopies, len, ad)
!***********************************************************************
!* initialise using a 1,2,4 or 8 byte pattern                          *
!***********************************************************************
%integer I
      %if Report#0 %thenstart
         printstring("Edpattern ")
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if Language=Ccomp %thenstart
         %if Area=5 %then Area=8
      %finish
      %if area>10 %then areaprops(area)=areaprops(area)!X'400'  %c
                   %and area=areaid(area)
      Mdpattern(area, Disp, ncopies, len, ad)
%end;!Edpattern
!*
%externalroutine Edbits(%integer area, Disp, Bitoffset, Numbits, Val)
!***********************************************************************
!* intialise a bit field                                               *
!***********************************************************************
%integer Mask1,Mask2,I,J
      %if Report#0 %thenstart
         printstring("Edbits  ".Areas(Area)." +");write(Disp,1)
         write(Bitoffset,4);write(Numbits,4);write(Val,4)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if Language=Ccomp %thenstart
         %if Area=5 %then Area=8
      %finish
      I=(32-Bitoffset-Numbits)
      Mask1=Bmaskval(Numbits-1)
      Val=(Val&Mask1)<<I
      Mask2=(Mask1<<I)!!(-1)
      %if area=Bitarea %and Disp=Bitdisp %thenstart {add to existing init}
         integer(Initdataad)=(integer(Initdataad)&Mask2)!Val
      %finishelsestart  {new bit initialisation}
         %return %if Val=0
         Bitarea=area
         Bitdisp=disp
         Md4(area,disp,Val)
       %finish
%end;! Edbits
!*
%externalroutine Efix(%integer area,disp, tgtarea,tgtdisp)
!***********************************************************************
!* relocate area+disp to tgtarea+tgtdisp  (all are byte addresses)     *
!***********************************************************************
      Area=Area&X'FFF';! in case 'byte' marker had been set (historic)
      %if Report#0 %thenstart
         printstring("Efix  ".Areas(Area)." +");write(Disp,1)
         printstring(" => ".Areas(Tgtarea)." +");write(Tgtdisp,1)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if Language=Ccomp %thenstart
         %if Area=5 %then Area=8
         %if tgtarea=5 %then tgtarea=8
      %finish
      %if tgtarea>10 %then tgtarea=areaid(tgtarea)
      %if tgtdisp#0 %then Md4(area,disp,tgtdisp)
      Mfix(area,disp,tgtarea,0)
%end;! Efix
!*
!*
!*
!*                 *********************
!*                 * Procedure call    *
!*                 *********************
!*
!*
%externalintegerfn EXname(%integer type,%string(255)%name Xref)
!***********************************************************************
!* generate an external reference, returning an Id for future reference*
!***********************************************************************
%integer I
      %if Report#0 %thenstart
         printstring("EXname  ".Xref);write(Type&15,4);write(Type>>4,4)
         newline
      %finish
      %if ProgFaulty#0 %then %result=1
    { I=MXname(0,Xref) }
      %result=Get Prockey(Xref)
%end;! EXname
!*
%externalroutine Eprecall(%integer Id)
!***********************************************************************
!* called prior to planting parameters to a procedure call             *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Eprecall ")
         newline
      %finish
      Mprecall
%end;! Eprecall
!*
%externalroutine Ecall2(%integer Id,Xlevel,Numpars,Paramsize)
!***********************************************************************
!* call the procedure defined by Id                                    *
!*    Xlevel is the level of the called routine 1=Global etc           *
!*    Numpars and paramsize(bytes) are obvious                         *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Ecall2    "); write(Id,4); write(xlevel,4)
         write(Numpars,6); write(Paramsize,4)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      Freeregs
      Gop Call(Id,Paramsize,numpars,Xlevel)
%end;! Ecall2
%externalroutine Ecall(%integer Id,Numpars,Paramsize)
!***********************************************************************
!* call the procedure defined by Id                                    *
!***********************************************************************
      Ecall2(Id,99,Numpars,Paramsize)
%end;! Ecall
!*
%externalroutine Eprocref(%integer Id, Level)
!***********************************************************************
!* obtain a pointer to a procedure for use as a parameter              *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Eprocref ");write(Id,4)
         newline
      %finish
      %unless Language=Ccomp %or Language=Pascal %thenstart
         %if Language=IMp %thenstart
            %if Level>1 %thenstart
               Estkdir(Stack,Display Offset + (Level*4),0,4)
            %finishelse Estklit(0)
         %finishelse Estklit(0)
      %finish
      Stackr(Get Procref(Id),4)
%end;! Eprocref
!*
%externalroutine Eprocenv(%integer Level)
!**********************************************************************
!* stack the environment of a procedure being passed as a parameter   *
!**********************************************************************
      %if Report#0 %thenstart
         printstring("Eprocenv "); write(Level,4)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      %if Language=IMP %or Language=Pascal %thenstart
         %if Level>1 %thenstart
            %if Language=Pascal %thenstart
               Estkdir(Stack,(Level-2)*8,0,4)
            %finishelsestart
               Estkdir(Stack,Display Offset+(Level*4),0,4)
            %finish
         %finishelse Estklit(0)
      %finishelse Estklit(0)
%end;! Eprocenv
!*
!*
%externalroutine Eprocptr(%integer Area,Offset,%string(255)%name S)
!***********************************************************************
!* establish a pointer to a procedure at Offset in Area                *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Eprocptr ");write(Area,4);write(Offset,4)
         printstring("   ".S)
         newline
      %finish
      %if Language=Ccomp %thenstart
         %if Area=5 %then Area=8
      %finish
      Mset Procref(Area,Offset,S)
%end;! Eprocptr
!*
%externalroutine Esave(%integer Asave, %integername Key)
!***********************************************************************
!* a (hopefully) redundant IMP requirement                             *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Esave ");write(Asave,4)
         newline
      %finish
%end;! Esave
!*
%externalroutine Erestore(%integer Asave, Key, Existing)
!***********************************************************************
!* a (hopefully) redundant IMP requirement                             *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Erestore ");write(Asave,4)
         newline
      %finish
%end;! Erestore
!*
!*
!*
!*               **********************************
!*               * Procedure definition and entry *
!*               **********************************
!*
!*
%externalintegerfn Enextproc
!***********************************************************************
!* result is an Id to be used for a procedure first encountered as an  *
!* internal spec                                                       *
!***********************************************************************
%string(3) S
      %if Report#0 %thenstart
         printstring("Enextproc ")
         newline
      %finish
      S=""
      %result=Get Prockey(S)
%end;! Enextproc
!*
%externalroutine Eproclevel(%integer Level)
!***********************************************************************
!* record static nesting level of the current procedure                *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Eproclevel ");write(Level,3)
         newline
      %finish
      ProcLevel = Level
%end;! Eproclevel
!*
%externalroutine Eproc(%stringname Name,%integer Props, Numpars, Paramsize,
                                      Astacklen, %integername Id)
!***********************************************************************
!* define the start of a procedure body                                *
!* if Id > 0 this is the Id returned by a previous call of Enextproc   *
!* Astacklen is the address of the word noting the current local       *
!* stack-frame size                                                    *
!*                                                                     *
!*    PDS thinks props is as follows:?                                 *
!*    2**0     Set if external                                         *
!*    2**1     Set if main entry       (2**31 is used by Fortran!)     *
!*   2**2     Set if display not required (Implied for Fortran & C)    *
!*    2**3      Set if there are no local variables                    *
!*    2**4     Set if ??    PDS has vague memories this was used on PNX*
!*    2**5     Set if there are no internal blocks or procedures       *
!*    2**14    Set if first param is a word                            *
!*    2**15    Set if first param a Dword   Used if Numpars = 1?       *
!*    2**16-2**23   Byte giving nesting level of procedure             *
!***********************************************************************
%integer Pprops,Ca,Disp,Putid,I,Reg
%record(Stkfmt) S1,S2
      %if Report#0 %thenstart
         printstring("Eproc ");printstring(Name);write(props&X'ffff',4)
         write(Numpars,4); write(Paramsize,4)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      Clear Regs
      %unless Astacklen=-1 %then Addrstackca=Astacklen
      %unless Language=PASCAL %then ProcLevel=ProcLevel+1
      %if Language=PASCAL %and Proclevel=1 %then Props=2
      %if Props&2#0 %then Pprops=X'80000001' %else Pprops=Props&1
      Ca=Mgetca(0)
      Minnerproc(0)
      %if Props&3#0 %thenstart;! to be externally visible
         Putid=-1
         Mproc(Name,Pprops,Ca,Putid,Savelineno+1)
         Visibleproc=Proclevel
      %finish
      Id=Note Entry(Name,Id,Ca,1)
      Curdiagca=-1
      Display Offset=Paramsize
      Procprops(Proclevel)=Props
      Procstkmark(ProcLevel)=Mmarker
      Noteparamsize(Proclevel)=Paramsize
      Mstartproc(Props,Proclevel,Paramsize)
%end;! Eproc
!*
%externalroutine Eprocend(%integer Localsize,Diagdisp,Astacklen)
!***********************************************************************
!* called at procedure end                                             *
!* Localsize is the total stack-frame requirement (excluding red tape) *
!* Astacklen is the address of the word noting the current local       *
!* stack-frame size of th enclosing procedure                          *
!***********************************************************************
%integer Ca
      %if Report#0 %thenstart
         printstring("Eprocend ");write(Localsize,6)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      Keycommon=-1
      Numregvars=0
      %if Language=PASCAL %then Eop(RETURN)
      %if Language=IMP %then Localsize=Localsize+Noteparamsize(Proclevel)
      Mtidyproc(Procstkmark(Proclevel),Localsize,Notediagdisp,Ca)
      %if Visibleproc=Proclevel %thenstart
         Mprocend(Ca)
         Visibleproc=0
      %finish
      Minnerproc(1)
      ProcLevel=ProcLevel-1
      Display Offset=Noteparamsize(Proclevel)
%end;! Eprocend
!*
%externalroutine Eentry(%integer Index,Numpars,Paramsize,
                           Localsize,Diagdisp,%stringname Name)
!***********************************************************************
!* defines a side entry within the current procedure (used by Fortran) *
!* Localsize is the total stack-frame requirement (excluding red tape) * 
!***********************************************************************
%integer Id,ca,Procid,Reg
%record(Stkfmt) S1,S2
      %if Report#0 %thenstart
         printstring("Eentry  ".Name);write(Index,4)
         write(Numpars,4);write(Paramsize,4)
         newline
      %finish
      %if ProgFaulty#0 %then %return
      Notediagdisp=Diagdisp
      %if Index=0 %then %return;! prologue start in Eproc
      Ca=Mgetca(1)
      Id=Mentry(Index,ca,Name)
      Procid=-1
      Id=Note Entry(Name,Procid,Ca,0)
      Msideentry(Ca)
%end;! Eentry
!*
!*
!*
!*               *********************************
!*               * Data definition and reference *
!*               *********************************
!*
!*
%externalroutine Edataentry(%integer Area,Offset,Length,%stringname Name)
!***********************************************************************
!* defines a data entry Name starting at Offset in Area                *
!***********************************************************************
      %if Report#0 %thenstart
         printstring("Edataentry  ".Name);write(Area,4)
         write(Offset,4);write(Length,4)
         newline
      %finish
      %if Language=Ccomp %thenstart
         %if Area=5 %then Area=8
      %finish
      Mdataentry(Name,Area,Length,Offset)
%end;! Edataentry
!*
%externalroutine Edataref(%integer Area,Offset,Length,%stringname Name)
!***********************************************************************
!* requests a data ref to Name (with at least Length)at Offset in Area *
!***********************************************************************
%integer Id
      %if Report#0 %thenstart
         printstring("Edataref  ".Name);write(Area,4)
         write(Offset,4);write(Length,4)
         newline
      %finish
      %if Language=Ccomp %thenstart
         %if Area=5 %then Area=8
      %finish
      Id=Mxname(0,Name)
      Mdxref(Area,Offset,Id)
%end;! Edataref
!*
!*
!*
!*                  ********************
!*                  * Ecode operations *
!*                  ********************
!*
%ownrecord(Stkfmt) Csavestk
!*
%externalroutine Eop(%integer Opcode)
!***********************************************************************
!* opcodes with general applicability                                  *
!***********************************************************************
%integer Reg1,Reg2,Freg1,Bytes,Form,I
%constbyteintegerarray Logop(0:3)=SLL,SRL,SLA,SRA
%constbyteintegerarray DLogop(0:3)=SLLD,SRLD,SLAD,SRAD
%constbyteintegerarray Opst(0:11) =  %c
   IADD,ISUB,IMULT,IDIV,0,UREM,UDIV,IAND,IOR,0,IXOR,IREM
%constbyteintegerarray Gopst(0:10) = ADM,SUM,MPM,DVM,0,0,0,ANM,ORM,0,EOM
%if Cpu = NP1 %thenstart
   %constbyteintegerarray IncOp(0:8) = 0, INCMB, INCMH, 0, INCMW, 0, 0, 0, INCMD
%finish
%switch Op(0:255)
      %if Opcode>=768 %thenstart
         Eccop(Opcode)
         %return
      %finish
      %if Report#0 %thenstart
         printstring("Eop    ".Eopname(Opcode))
         newline
         Dump Estack
      %finish
      %if ProgFaulty#0 %then %return
!*
      %if CCset # 0 %then Establish Logical;! establish logical value 0 or 1
!*
      ->Op(Opcode)
Op(HALT):
      %if Elevel>=2 %and Stk(Elevel)_Form=Litval=Stk(Elevel-1)_Form %Start
         Elevel=Elevel-2
         I=Stk(Elevel+1)_Intval
         %if Stk(Elevel+2)_Intval=4 %then CodeW(i>>16,i&X'FFFF') %else CodeH(i)
         Clearregs
         %return
      %finish
Op(*):%monitor
      Unsupported Opcode(Opcode)
      %return    
!*
Op(IADD):
Op(ISUB):
Op(IMULT):
Op(IDIV): 
!*
Op(IREM): 
!*
Op(IAND):
Op(IOR): 
Op(IXOR): 
!*
Op(IGT): 
Op(ILT): 
Op(IEQ): 
Op(INE):  
Op(IGE):  
Op(ILE):  
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      Size8check
      %if (opcode=IMULT %or opcode=IDIV) %and stk(Elevel)_size=8 %start
         %if opcode=IMULT %then spcall(27) %else spcall(28)
         %return
      %finish
      Elevel=Elevel-2
      Int Binary Op(Opcode,Stk(Elevel+1),Stk(Elevel+2))
      %return
!*
Op(INEG): 
Op(IABS): 
Op(INOT):
Op(BNOT):
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
      Elevel=Elevel-1
      Int Unary Op(Opcode,Stk(Elevel+1))
      %return
!*
Op(UDIV):
      Spcall(29)
      %return
!*
Op(UREM):
      Spcall(30)
      %return
!*
Op(UADD):
Op(USUB):
      Opcode=Opcode-UADD+IADD
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      Elevel=Elevel-2
      Int Binary Op(Opcode,Stk(Elevel+1),Stk(Elevel+2))
      %return
!*
Op(UGT): 
Op(ULT): 
Op(UEQ): 
Op(UNE):  
Op(UGE):  
Op(ULE):
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      Elevel=Elevel-1
      Convert IU(Stk(Elevel+1),8)
      Epromote(2)  
      Elevel=Elevel-1
      Convert IU(Stk(Elevel+1),8)
      Epromote(2)  
      Elevel=Elevel-2
      Int Binary Op(Opcode-UGT+IGT,Stk(Elevel+1),Stk(Elevel+2))
      %return
!*
Op(IADDST):
      %if Ecdupflag#0 %or Stk(Elevel-1)_Form&31=Regval %then ->Op(ISUBST)
      Elevel=Elevel-2
      %if Stk(Elevel+1)_Form&31>=RegVar %thenstart
         I=ADM
Regop:   Gop RX(I,Stk(Elevel+1)_Reg,Stk(Elevel+2))
         %return
      %finish
      %if Cpu = NP1 %thenstart
         %if Stk(Elevel+2)_Form=LitVal %and 0<=Stk(Elevel+2)_IntVal<=8  %c
                                       %and Stk(Elevel+1)_Size=4 %thenstart
            I = IncOp(Stk(Elevel+2)_IntVal)
            %if I # 0 %thenstart
               Gop X(I,Stk(Elevel+1))
               %return
            %finish
         %finish
      %finish
      Reg1=Load Int(Stk(Elevel+2),-1)
      Gop RX(ARM,Reg1,Stk(Elevel+1))
      Unlock Reg(Reg1)
      %return
!*
Op(UDIVST): 
Op(UREMST):
Op(ISUBST):
Op(IMULTST):
Op(IDIVST): 
Op(IANDST):
Op(IORST): 
Op(IXORST): 
Op(IREMST):
      %if Stk(Elevel-1)_Form&31>=RegVar %thenstart
         Elevel=Elevel-2
         I=Gopst(Opcode-IADDST)
         ->Regop
      %finish
      %if Stk(Elevel-1)_Form&31=Regval %thenstart;! C has coerced
         Eop(Opst(Opcode-IADDST))
         Elevel=Elevel+1
         Stk(Elevel-1)_Size=Csavestk_Size
         Stk(Elevel)=Csavestk
      %finishelsestart
         Eop(EXCH)
         Eop(DUPL)
         Epromote(3)
         Eop(Opst(Opcode-IADDST))
         Stk(Elevel)_Size=Stk(Elevel-1)_Size  {to ensure STH when appropriate}
         Eop(EXCH)
      %finish
      %if Ecdupflag#0 %thenstart
         Ecdupflag=0
         Eop(EDUPSTORE)
      %finishelsestart
         Eop(ESTORE)
      %finish
      %return
!*
Op(INEGST): 
Op(INOTST):
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
      Elevel=Elevel-1
      Int Unary Op(Opcode,Stk(Elevel+1))
      %return
!*
Op(ISHLL):
!*
Op(ISHRL):
!*
Op(ISHLA):
!*
Op(ISHRA):
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      Elevel=Elevel-2
      %if stk(Elevel+1)_size=8 %and stk(elevel+2)_form=litval %and stk(elevel+2)_intval=32 %start
         %if opcode=ISHLL %start
            %if stk(Elevel+1)_form&31=regval %start
               reg1=stk(elevel+1)_reg
               Gop RR(TRR,reg1,reg1+1)
               lock reg pair(reg1)
            %finishelsestart
               %if stk(Elevel+1)_form=Dirval %start
                  Stk(Elevel+1)_size=4
                  Stk(Elevel+1)_offset=Stk(Elevel+1)_Offset+4
                  reg1=Claim reg pair(1)
                  reg1=Load Int(stk(Elevel+1),reg1)
               %finishelsestart
                  reg1=Claim reg pair(1)
                  reg1=Load Int(stk(Elevel+1),reg1)
                  Gop RR(TRR,reg1,reg1+1)
                  lock reg pair(reg1)
               %finish
            %finish
            Gop R(Zr,reg1+1)
            stackr(reg1,8)
            %return
         %finish
      %finish
      Reg1=Load Int(Stk(Elevel+1),-1)
      %if stk(Elevel+1)_size=8 %then i=Dlogop(opcode-ISHLL) %c
                               %else i=logop(opcode-ISHLL)
      Gop Shift(i,Reg1,Stk(Elevel+2))
      Stackr(Reg1,Stk(Elevel+1)_size)
      %return    
!*
Op(RETURN): 
      Gop Return
      %return
!*
Op(SFA):
      Unsupported Opcode(Opcode)  { auxiliary stack used on Gould }
      %return
!*
Op(ASF):
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
      Elevel=Elevel-1
      Unsupported Opcode(Opcode)  { auxiliary stack used on Gould }
      %return
!*
Op(IPUSH):
!*
Op(IPOP):  
      Unsupported Opcode(Opcode)
      %return    
!*
Op(EXCH):
      Epromote(2)
      %return
!*
Op(DUPL):
      I=Stk(Elevel)_Form&31
      %if 14<=I<=17 %thenstart
         Reg1=Load Int(Stk(Elevel),-1)
         Elevel=Elevel-1
         Stackr(Reg1,stk(elevel)_size)
         %if I=18 %then I=RegVal %else I=RegAddr
         Stk(Elevel)_Form=I!32
      %finish
      Stk(Elevel+1)=Stk(Elevel)
      Elevel=Elevel+1
      Form=Stk(Elevel)_Form&31
      %if Form=RegVal %or Form=RegAddr  %c
                      %or Form=IndRegModVal %thenstart
         %if stk(Elevel)_size<=4 %start
            Reg1=Claim Reg       { (Stk(Elevel)_Reg) }
         %finishelsestart
            reg1=Claim reg pair(1)
            Gop RR(TRR,reg1+1,stk(Elevel-1)_reg+1)
         %finish
         Stk(Elevel)_Reg=Reg1
         Gop RR(TRR,Reg1,Stk(Elevel-1)_Reg)
         Note Reguse(Reg1,-Elevel,stk(Elevel)_size)
      %finishelsestart
         %if Form=FregVal %thenstart
            Freg1=Claim Freg
!??            %if Stk(Elevel)_Size=4 %then XAop=LER %else XAop=LDR
!??            PIX RR(XAop,Freg1,Stk(Elevel)_Reg)
            Stk(Elevel)_Reg=Freg1
!??            Fruse(Freg1)=-Elevel
         %finishelsestart
            %if Form=TempVal %then Stk(Elevel)_Form=DirVal
         %finish
      %finish
      %return    
!*
Op(DISCARD):
      %if Elevel<1 %then { Low Estack(Opcode,1) %and } %return
      I=Stk(Elevel)_Form&31
      %if I=RegVal %or I=FregVal %or I=IndRegVal %or I=IndRegModVal %thenstart
         Note Reguse(Stk(Elevel)_Reg,0,Stk(Elevel)_Size)
      %finish
      %if I>=AddrDirMod %thenstart
         %if Stk(Elevel)_Modform=RegVal %then Note Reguse(Stk(Elevel)_Modreg,0,4)
      %finish
      Elevel=Elevel-1
      %return
!*
Op(INDEX1): 
!*
Op(INDEX2):
!*
Op(INDEX4):
!*
Op(INDEX8):
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      Elevel=Elevel-1
      I=Opcode-INDEX1
NoteI:Note Index(I,Stk(Elevel),Stk(Elevel+1))
      %return
!*
Op(INDEX):
      %if Elevel<3 %then Low Estack(Opcode,3) %and %return
      Elevel=Elevel-2
      %if Language=IMP %thenstart;! mixes 16 and 32 bit operands
         Elevel=Elevel+2
         %if Stk(Elevel)_Size=2 %thenstart
            Estklit(4)
            Eop(CVTII)
         %finish
         %if Stk(Elevel-1)_Size=2 %thenstart
            Epromote(2)
            Estklit(4)
            Eop(CVTII)
            Epromote(2)
         %finish
         Elevel=Elevel-2
      %finish
      Int Binary Op(IMULT,Stk(Elevel+1),Stk(Elevel+2))
      Elevel=Elevel-1
      I=0
      ->NoteI
!*
Op(MVB):    
      %if Elevel<3 %then Low Estack(Opcode,3) %and %return
      Elevel=Elevel-3
      Gop Mvb(Stk(Elevel+3),Stk(Elevel+1),Stk(Elevel+2))
      %return    
!*
Op(EZERO):
      Elevel=Elevel-2
      %return
!*
Op(CHK):  
      %if Elevel<3 %then Low Estack(Opcode,3) %and %return
      bytes=stk(Elevel-2)_size
      %if bytes>4 %Start;        ! longinteger chk difficult
         Eop(DISCARD); Eop(DISCARD)
         %return
      %finish
      Elevel=Elevel-3
      Reg1=Load Int(Stk(Elevel+1),-1)
      Gop RX(CAM,Reg1,Stk(Elevel+2))
      Gop Jump(BLT,Bounderr)
      Gop RX(CAM,Reg1,Stk(Elevel+3))
      Gop Jump(BGT,Bounderr)
      Stackr(Reg1,4)
      %return    
!*
Op(TMASK): 
      Unsupported Opcode(Opcode)
      %return    
!*
Op(CPBGT):
!*
Op(CPBLT):
!*
Op(CPBEQ):
!*
Op(CPBNE):
!*
Op(CPBGE):
!*
Op(CPBLE):
      %if Elevel<3 %then Low Estack(Opcode,3) %and %return
      Elevel=Elevel-3
      Gop Cpb(Opcode-CPBGT,Stk(Elevel+3),Stk(Elevel+1),Stk(Elevel+2))
      CCset=1
      CC=Opcode-CPBGT
      %return    
!*
Op(RADD): 
Op(RSUB): 
Op(RMULT):
Op(RDIV): 
!*
Op(RGT):  
Op(RLT):  
Op(REQ): 
Op(RNE):  
Op(RGE):   
Op(RLE): 
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      Elevel=Elevel-2
      Real Binary Op(Opcode,Stk(Elevel+1),Stk(Elevel+2))
      %return
!*
Op(RNEG): 
Op(RABS):
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
      Elevel=Elevel-1
      Real Unary Op(Opcode,Stk(Elevel+1))
      %return
!*
Op(CVTSBI):
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      Elevel=Elevel-2
      Convert SBI(Stk(Elevel+1),Stk(Elevel+2)_Intval)
      %return
!*
Op(CVTIU):
Op(CVTUI):
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      %if Language=Ccomp %then Csavestk=Stk(Elevel-1)
      Elevel=Elevel-2
      Convert IU(Stk(Elevel+1),Stk(Elevel+2)_Intval)
      %return
!*
Op(CVTUR):
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      Elevel=Elevel-2
      Convert UR(Stk(Elevel+1),Stk(Elevel+2)_Intval)
      %return
!*
Op(CVTRU):
      Elevel=Elevel-1
      %return
!*
Op(UCVTII):
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      %if Language = Ccomp %then Csavestk=Stk(Elevel-1)
      Elevel=Elevel-2
      Convert II(Stk(Elevel+1),Stk(Elevel+2)_Intval)
      %return
!*
Op(CVTII):
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      %if Language = Ccomp %then Csavestk=Stk(Elevel-1)
      Elevel=Elevel-2
      Convert II(Stk(Elevel+1),Stk(Elevel+2)_Intval)
      %return
!*
Op(CVTRR):
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      Elevel=Elevel-2
      Convert RR(0,Stk(Elevel+1),Stk(Elevel+2)_Intval)
      %return
!*
Op(TNCRI): 
Op(RNDRI):
Op(EFLOOR):
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      Elevel=Elevel-2
      Convert RI(Stk(Elevel+1),Stk(Elevel+2)_Intval,Opcode-TNCRI)
      %return
!*
Op(TNCRR):
      %if Elevel<1 %then Low Estack(Opcode,2) %and %return
      Elevel=Elevel-1
      Convert RR(1,Stk(Elevel+1),Stk(Elevel+1)_Size)
      %return
!*
Op(RNDRR):
      %if Elevel<1 %then Low Estack(Opcode,2) %and %return
      Elevel=Elevel-1
      Convert RR(2,Stk(Elevel+1),Stk(Elevel+1)_Size)
      %return
!*
Op(CVTIR):  
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      Elevel=Elevel-2
      Convert IR(Stk(Elevel+1),Stk(Elevel+2)_Intval)
      %return
!*
Op(UCHECK):
      %if Stk(Elevel)_Form=DirVal %thenstart
!??         Set BD(Stk(Elevel),B1,D1)
      %finishelsestart
         Reg1=Claim Reg
!??         Op RX(LA,Reg1,Stk(Elevel))
         Stk(Elevel)_Form=IndRegVal!Regflag
         Stk(Elevel)_Reg=Reg1
!!         dreguse(Reg1)=-Elevel
      %finish
!??      PIX SS(CLC,0,Stk(Elevel)_Size,B1,D1,R9,32)
!??      Pjump(BC,Unasslab,8,R14)
      %return    
!*
!
! PDS found the coding for EDUPSTORE worked only for very simple cases
! and woulf not support IMP parm opt which uses this feature extensively
! The code has been rewritten and combined with that for ESTORE (Jan89)
!
Op(EDUPSTORE): 
Op(ESTORE):
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      Elevel=Elevel-2
      %if AddrConst<=Stk(Elevel+2)_Form&31<=DirModAddr %thenstart
         Refer(Stk(Elevel+2),0)
         Stk(Elevel+2)_Size=Stk(Elevel+1)_Size
      %finish
      Bytes=Stk(Elevel+2)_Size
      Reg1=Storeop(Stk(Elevel+2),Stk(Elevel+1),Opcode-Estore)
      %if Opcode=EDUPSTORE %then %start
         %if Stk(Elevel+1)_Form=RegVar %then Elevel=Elevel+1 %else Stackr(Reg1,bytes)
      %finish
      %return
Op(PUSHADDR):
      Address(Stk(Elevel))
!*
Op(PUSHVAL):
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
      Elevel=Elevel-1
      Push Param(Stk(Elevel+1))
      %return
!*
Op(EVAL):
      %if Elevel<1 %then low estack(opcode,1) %and %return
      Release reg(r0)
      reg1=load reg(r0,stk(Elevel))
      Elevel=Elevel-1
      Stackr(reg1,Stk(Elevel+1)_Size)
      %return
Op(MVW):
      %if Elevel<3 %then Low estack(Opcode,3) %and %return
      Elevel=Elevel-3
      Gop Mvlong(Stk(Elevel+3),Stk(Elevel+1),Stk(Elevel+2),4)
      %return
!*
Op(EVALADDR):
Op(EADDRESS):
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
      Address(Stk(Elevel))
      Stk(Elevel)_Size=4
      %if Opcode=EADDRESS %then %return
      Release reg(r1)
      Reg1=load reg(R1,stk(Elevel))
      Elevel=Elevel-1
      Stackr(Reg1,4)
      %return
!*
Op(EPOWER):       
!*
Op(EPOWERI):     
      %if Elevel<3 %then Low Estack(Opcode,3) %and %return
      %if Stk(Elevel)_Form#Litval %then Abort
      Elevel=Elevel-1
      Expcall(Stk(Elevel+1)_Intval)
      %return
!*
Op(EINTRES):    
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
      %if stk(elevel)_form&31#regval %then free regs %And Note reguse(R2,-255,4)

       Elevel=Elevel-1
      %if Cpu=Concept %thenstart
         Reg1=r0
      %finishelsestart
         Reg1=r2
      %finish

      Bytes=Stk(Elevel+1)_Size
      Reg1=Load Int(Stk(Elevel+1),Reg1)
      Note Reguse(Reg1,0,bytes)
      %if cpu=concept %then notereguse(R2,0,0)
      %return
!*
Op(EREALRES):    
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
      Bytes=Stk(Elevel)_Size
      %if stk(elevel)_form&31#fregval %then free regs %and note reguse(R2,-255,Bytes)
      Elevel=Elevel-1
      %if Cpu=Concept %thenstart
         Reg1=r0
      %finishelsestart
         Reg1=r2
      %finish
      Reg1=Load Real(Stk(Elevel+1),Reg1,Stk(Elevel+1)_Size)
      Note reguse(Reg1,0,Bytes)
      %if cpu=concept %then note reguse(R2,0,Bytes)
      %return
!*
Op(ESIZE):    
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      Elevel=Elevel-1
      Stk(Elevel)_Size=Stk(Elevel+1)_Intval
      %return
!*
Op(ARGPROC):    
      %if Elevel<3 %then Low Estack(Opcode,3) %and %return
      Elevel=Elevel-3
      Freeregs
      Reg1=Load Int(Stk(Elevel+1),r0)
      %if (Language=Pascal %or Language=IMp) %and Stk(Elevel+2)_Form %c
         #Litval %start
         %if Cpu=Concept %then Reg1=r1 %else Reg1=r7
         Gop RX(L,Reg1,Stk(Elevel+2));   ! Load display pointer
      %finish
      Gop Call(0,Stk(Elevel+3)_Intval,0,0)
      %return
!*
Op(EAUXSF):    
      %if auxaddr=0 %then auxaddr=Eglaspace(4) %and %c
         Edataref(Gla,auxaddr,4,auxsname)
      Estkind(Gla,auxaddr,0,4)
      %return
!*
Op(EAUXADD):    
      %if auxaddr=0 %then auxaddr=Eglaspace(4) %and %c
         Edataref(Gla,auxaddr,4,auxsname)
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
      %if Saveoptions&256#0 %start;     ! Imp Unass checking on
         Estklit(1)
         Eop(EXCH)
         Spcall(21);                    ! support procedure will fill with X80s
         Eop(Discard);                  ! Stack pointer not wanted
      %else
         Estkind(Gla,auxaddr,0,4)
         Eop(IADD)
         Estkind(Gla,auxaddr,0,4)
         %if Saveoptions&512#0 %and Language=Imp %start
            Eop(EDUPSTORE)
            Estkdir(Gla,auxaddr,0,4)
            Erefer(4,4)
            Ejump(JIGT,Bounderr)
         %finish %else Eop(ESTORE)
         %finish
      %return
!*
Op(EAUXRES):    
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
   Gop RXB(ST,R2,BR2,0,16,8);      ! result may be loeded
      Estkind(Gla,auxaddr,0,4)
      EOP(ESTORE)
   Gop RXB(L,R2,BR2,0,16,8);      ! result may be loeded
      %return
!*
Op(EOLDLNB):
      Gop RXB(L,r1,br1,0,0,4)
      Gop RXB(LA,r1,br2,r1,0,0)
      Stackr(r1,4)
      %return
!*
Op(Ecdup):
      Ecdupflag=1
      %return
!*
Op(EMAKED):                             ! make a double integer out of two singles
                                        ! etos is the MSh
      Reg1=claim reg pair(1)
      Elevel=Elevel-2
      Reg2=load int(Stk(Elevel+2),reg1)
      Reg2=load int(Stk(Elevel+1),Reg1+1)
      UNlock reg pair(REg1)
      Stackr(Reg1,8)
      %return
Op(ESPLITD):                            ! Split a long int converse of EMAKED
      Elevel=Elevel-1
      Reg1=load int(Stk(Elevel+1),-1)
      UNlock reg pair(Reg1)
      Stackr(Reg1+1,4)
      Stackr(Reg1,4)
      %return
%end;! Eop
!*
%externalroutine Ef77op(%integer Opcode)
!***********************************************************************
!* opcodes specifically defined for use by Fortran                     *
!***********************************************************************
%integer Reg1,Reg2,Reg3,Freg1,Freg2,Bytes,Relop,Lab1,Lab2,Op,Shift,Val
%integer B1,D1,Flags,SceReg,DestReg
%record(Stkfmt) Tstk,Regstk,Fregstk
%switch F77op(256:322)
      %if Report#0 %thenstart
         printstring("Ef77op  ".Ef77opname(Opcode))
         newline
         Dump Estack
      %finish
      %if ProgFaulty#0 %then %return
!*
      %if CCset # 0 %then Establish Logical;! establish logical value 0 or 1
!*
         Bytes=Stk(Elevel)_Size
      ->F77op(Opcode)
!*
F77op(*):Abort
!*
F77op(CXADD):       
!*
F77op(CXSUB):      
!*
F77op(CXMULT):     
!*
F77op(CXDIV):      
      %if Elevel<4 %then Low Estack(Opcode,4) %and %return
      Elevel=Elevel-4
      Opcode=Opcode&X'FF'
      Flags=Stk(Elevel+4)_Intval
Cxop: Cx Operation(Opcode,Flags,Stk(Elevel+1),Stk(Elevel+2),Stk(Elevel+3))
      %return
!*
F77op(CXNEG):       
!*
F77op(CXASGN):     
!*
F77op(CXEQ):       
!*
F77op(CXNE):       
      %if Elevel<3 %then Low Estack(Opcode,3) %and %return
      Elevel=Elevel-3
      Opcode=Opcode&X'FF'
      Flags=Stk(Elevel+3)_Intval
      ->Cxop
!*
F77op(EM1EXP):      
      Elevel=Elevel-1
      Reg1=claim reg
      Gop RI(LI,Reg1,1)
      Reg2=Load Int(Stk(Elevel+1),-1)
      %if Reg2=r7 %thenstart
         Reg2=claim reg
         Gop RR(TRR,Reg2,r7)
         Note Reguse(r7,0,0)
      %finish
      %if bytes<=4 %then Gop RR(ANR,Reg2,Reg1) %else Gop RR(ANR,reg2+1,reg1)
      Lab1=Mprivatelabel
      Gop Jump(BEQ,Lab1)
      Gop RR(TRN,Reg1,Reg1)
      Mcode Plabel(Lab1)
      Note Reguse(Reg2,0,0)
      Stackr(Reg1,bytes)
      %return
!*
F77op(EISIGN):
      Elevel=Elevel-1
      Eop(IABS)
      Reg1=Stk(Elevel)_Reg
      Elevel=Elevel-1
      %if Stk(Elevel+2)_Form&31=Regval %thenstart
         Reg2=Stk(Elevel+2)_Reg
         Gop RR(TRR,Reg2,Reg2);! to set condition
      %finishelse Reg2=Load Int(Stk(Elevel+2),-2)
      Lab1=Mprivatelabel
      Gop Jump(BGE,Lab1)
      %if bytes<=4 %start
         Gop RR(TRN,Reg1,Reg1)
      %finishelsestart
         Release reg pair(reg1)
         reg1=Claim reg pair(1)
         Gop R(zr,reg1); gop r (Zr,reg1+1)
         Gop RX(SUM,reg1,stk(Elevel+2))
      %finish
      Mcode Plabel(Lab1)
      unlock reg(Reg2)
      Stackr(Reg1,bytes)
      %return
!*
F77op(ESIGN):      
      Elevel=Elevel-1
      Eop(RABS)
      Reg1=Stk(Elevel)_Reg
      Note Reguse(Reg1,-255,bytes)
      Elevel=Elevel-1
      %if Stk(Elevel+2)_Form&31=Fregval %thenstart
         Reg2=Stk(Elevel+2)_Reg
         Gop RR(TRR,Reg2,Reg2);! to set condition
      %finishelse Reg2=Load Real(Stk(Elevel+2),-2,Bytes)
      Lab1=Mprivatelabel
      %if Bytes=4 %thenstart
         Gop Jump(BGE,Lab1)
         Gop RR(TRN,Reg1,Reg1)
         unlock reg(Reg2)
      %finishelsestart
         Gop Jump(BGE,Lab1)
         %if Cpu = NP1 %thenstart
            Gop RR(TRND,Reg1,Reg1)
         %finishelsestart
            Gop RR(TRC,Reg1,Reg1)
            Gop RR(TRC,Reg1+1,Reg1+1)
         %finish
         unlock reg pair(Reg2)
      %finish
      Mcode Plabel(Lab1)
      Stackfr(Reg1,Stk(Elevel+1)_Size)
      %return
!*
F77op(EIMOD):        
      Elevel=Elevel-2
      Int Binary Op(IREM,Stk(Elevel+1),Stk(Elevel+2))
      %return
!*
F77op(ERMOD):       
      Elevel=Elevel-2
      Reg1=Load Real(Stk(Elevel+1),-1,Bytes)
      Reg2=Load Real(Stk(Elevel+2),-1,Bytes)
      %if Bytes=4 %thenstart
         Reg3=claim reg
         %if Cpu = NP1 %thenstart
            Gop RR(Trr,reg3,reg2)
            Gop R(RRFW,Reg3)     { Reg3 = 1/a2    }
            Gop RR(MPRFW,Reg3,Reg1)    { Reg3 = a1/a2   }
         %finishelsestart
            Gop RR(TRR,Reg3,Reg1)  { Reg3 = a1      }
            Gop RR(DVRFW,Reg3,Reg2)    { Reg3 = a1/a2   }
         %finish
         Gop RR(FIXW,Reg3,Reg3)
         Gop RR(FLTW,Reg3,Reg3)
         Gop RR(MPRFW,Reg3,Reg2)
         Gop RR(SURFW,Reg1,Reg3)
         %if Cpu=NP1 %thenstart  {additional check for reciprocal error}
            Gop RR(TRABS,Reg3,Reg1)
            Gop RR(TRABS,Reg2,Reg2)
            Lab1=Mprivatelabel
            Gop RR(CAR,Reg2,Reg3)
            Gop Jump(BNE,Lab1)
            Gop R(ZR,Reg1)
            Mcode Plabel(Lab1)
         %finish
         unlock reg(Reg2)
         unlock reg(Reg3)
      %finishelsestart {8 bytes}
         Reg3=claim reg pair(1)
         %if Cpu = NP1 %thenstart
            Gop RR(Trr,reg3,reg2)
            Gop RR(Trr,reg3+1,reg2+1)
            Gop R(RRFD,Reg3)     { Reg3 = 1/a2    }
            Gop RR(MPRFD,Reg3,Reg1)    { Reg3 = a1/a2   }
         %finishelsestart
            Gop RR(TRR,Reg3,Reg1)
            Gop RR(TRR,Reg3+1,Reg1+1)  { Reg3 = a1      }
            Gop RR(DVRFD,Reg3,Reg2)    { Reg3 = a1/a2   }
         %finish
         Gop RR(FIXD,Reg3,Reg3)
         Gop RR(FLTD,Reg3,Reg3)
         Gop RR(MPRFD,Reg3,Reg2)
         Gop RR(SURFD,Reg1,Reg3)
         %if Cpu=NP1 %thenstart  {additional check for reciprocal error}
            Gop RR(TRABSD,Reg3,Reg1)
            Gop RR(TRABSD,Reg2,Reg2)
            Lab1=Mprivatelabel
            Gop RR(CARD,Reg2,Reg3)
            Gop Jump(BNE,Lab1)
            Gop R(ZR,Reg1)
            Gop R(ZR,Reg1+1)
            Mcode Plabel(Lab1)
         %finish
         unlock reg pair(Reg2)
         unlock reg pair(Reg3)
      %finish
      Stackfr(Reg1,Bytes)
      %return
!*
F77op(EIDIM):
      Eop(ISUB)
      %if Stk(Elevel)_Form=Litval %thenstart  {both operands literal - compile-time evaluation}
         %if Stk(Elevel)_Intval<0 %then Stk(Elevel)_Intval=0
         %return
      %finish
      Reg1=Stk(Elevel)_Reg
      Elevel=Elevel-1
      Lab1=Mprivatelabel
      Gop Jump(BGE,Lab1)
      Gop R(ZR,Reg1)
      %if bytes=8 %then Gop R(ZR,Reg1+1)
      Mcode Plabel(Lab1)
      Stackr(Reg1,bytes)
      %return
!*
F77op(ERDIM):       
      Eop(RSUB)
      Reg1=Stk(Elevel)_Reg
      Elevel=Elevel-1
      Lab1=Mprivatelabel
      %if Bytes=4 %thenstart
         Gop Jump(BGE,Lab1)
         Gop R(ZR,Reg1)
      %finishelsestart
         Gop Jump(BGE,Lab1)
         Gop R(ZR,Reg1)
         Gop R(ZR,Reg1+1)
      %finish
      Mcode Plabel(Lab1)
      Stackfr(Reg1,Bytes)
      %return
!*
F77op(EIMIN):        
      Relop=BLE
Iminmax:
      Elevel=Elevel-2
      Reg1=Load Int(Stk(Elevel+1),-1)
      %if bytes<=4 %start
         Reg2=Load Int(Stk(Elevel+2),-1)
         Gop RR(CAR,Reg1,Reg2)
      %finishelsestart
         Gop RX(CAM,reg1,stk(Elevel+2))
      %finish
      Lab1=Mprivatelabel
      Gop Jump(Relop,Lab1)
      %if bytes<=4 %start
         Gop RR(TRR,Reg1,Reg2)
      %finishelsestart
         reg1=Load Int(stk(Elevel+2),reg1)
      %finish
      Mcode Plabel(Lab1)
      %if bytes<=4 %then unlock reg(Reg2) 
      Stackr(Reg1,bytes)
!!      Reg2=Load Int(Stk(Elevel+2),-1)
!!      !%if Cpu = NP1 %thenstart
!!         !%if Opcode = EIMIN %thenstart
!!            !SceReg = Reg1
!!            !DestReg= Reg2
!!         !%finishelsestart
!!            !SceReg = Reg2
!!            !DestReg= Reg1
!!         !%finish
!!         !Gop RR(CXCR,DestReg,SceReg)
!!      !%finishelsestart
!!         Gop RR(CAR,Reg1,Reg2)
!!         Lab1=Mprivatelabel
!!         Gop Jump(Relop,Lab1)
!!         Gop RR(TRR,Reg1,Reg2)
!!         Mcode Plabel(Lab1)
!!      !%finish
!!      unlock reg(Reg2)
!!      Stackr(Reg1)
      %return
!*
F77op(ERMIN):       
      Relop=BLE
Rminmax:
      Elevel=Elevel-2
      Reg1=Load Real(Stk(Elevel+1),-1,Bytes)
      Reg2=Load Real(Stk(Elevel+2),-1,Bytes)
      !%if Cpu = NP1 %thenstart
         !%if Opcode = ERMIN %thenstart
            !SceReg = Reg1
            !DestReg= Reg2
         !%finishelsestart
            !SceReg = Reg2
            !DestReg= Reg1
         !%finish
         !%if Bytes = 4 %then Op = CXCR %else Op = CXCRD
         !Gop RR(Op,DestReg,SceReg)
         !%if Bytes = 4 %thenstart
            !Unlock Reg(Reg2)
         !%finishelsestart
            !Unlock Reg Pair(Reg2)
         !%finish
      !%finishelsestart
         Gop RR(CAR,Reg1,Reg2)
         Lab1=Mprivatelabel
         Gop Jump(Relop,Lab1)
         Gop RR(TRR,Reg1,Reg2)
         %if Bytes=4 %thenstart
            Gop(NOP)
            unlock reg(Reg2)
         %finishelsestart
            Gop RR(TRR,Reg1+1,Reg2+1)
            unlock reg pair(Reg2)
         %finish
         Mcode Plabel(Lab1)
      !%finish
      Stackfr(Reg1,Bytes)
      %return
!*
F77op(EIMAX):       
      Relop=BGE
      ->Iminmax
!*
F77op(ERMAX):       
      Relop=BGE
      ->Rminmax
!*
F77op(EDMULT):      
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      Elevel=Elevel-2
      Reg1=Load Real(Stk(Elevel+1),-1,8)
      Reg2=Load Real(Stk(Elevel+2),-1,8)
      Gop RR(MPRFD,Reg1,Reg2)
      unlock reg pair(Reg2)
      Stackfr(Reg1,8)
      %return
!*
F77op(ECONJG):     
      %if Elevel<3 %then Low Estack(Opcode,3) %and %return
      Elevel=Elevel-3
      Opcode=9
      Flags=Stk(Elevel+3)_Intval
      ->Cxop
!*
F77op(ECHAR):      
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      %if Stk(Elevel)_Form=LitVal %thenstart
         Reg1=claim reg
         Gop RI(LI,Reg1,Stk(Elevel)_Intval&255)
      %finishelsestart
         Reg1=Load Int(Stk(Elevel),-1)
      %finish
      Elevel=Elevel-1
      Refer(Stk(Elevel),0)
      Stk(Elevel)_Size=1
      Gop RX(ST,Reg1,Stk(Elevel))
      Elevel=Elevel-1
      Note Reguse(Reg1,0,0)
      %return
!*
F77op(EICHAR):     
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
      %if Stk(Elevel)_Form =LitVal %thenstart
         Stk(Elevel)_Size=4
         %return
      %finish
      Refer(Stk(Elevel),0)
      Stk(Elevel)_Size=1
      Reg1=claim reg
      Gop RX(L,Reg1,Stk(Elevel))
      Elevel=Elevel-1
      Stackr(Reg1,4)
      %return
!*
F77op(EINDEXCHAR):  
      %if Stk(Elevel-3)_Form=LitVal %then Address(Stk(Elevel-3))
      %if Stk(Elevel-1)_Form=LitVal %then Address(Stk(Elevel-1))
      {for Unix compatibility call requires A1,A2,L1,L2}
      Epromote(3)
      Epromote(2)
      Spcall(6)
      %if CPU=Concept %thenstart
         Stackr(r0,4)
      %finishelsestart
         Stackr(r2,4)
      %finish
      %return
!*
F77op(ECONCAT):    
      Spcall(7)
      %return
!*
F77op(EASGNCHAR):  
      %if Elevel<4 %then Low Estack(Opcode,4) %and %return
      Elevel=Elevel-4
      Do Charop(Opcode,Stk(Elevel+1),Stk(Elevel+2),Stk(Elevel+3),Stk(Elevel+4))
      Clear Regs   {in case characters equiv with ints - lose reg memory}
      %return
!*
F77op(ECOMPCHAR):  
      %if Elevel<5 %then Low Estack(Opcode,5) %and %return
      CC=Stk(Elevel)_Intval
      Elevel=Elevel-5
      Do Charop(Opcode,Stk(Elevel+1),Stk(Elevel+2),Stk(Elevel+3),Stk(Elevel+4))
      %return
!*
F77op(ECMPLX1):
      %if Elevel<3 %then Low Estack(Opcode,3) %and %return
      Elevel=Elevel-3
      Flags=Stk(Elevel+3)_Intval
      ->CXcmn
!*
F77op(ECMPLX2):     
      %if Elevel<4 %then Low Estack(Opcode,4) %and %return
      Elevel=Elevel-4
      Flags=Stk(Elevel+4)_Intval
CXcmn:%if Flags=0 %then Bytes=4 %else Bytes=8
      Reg1=Load Reg(-3,Stk(Elevel+1));! address(target)
      Freg1=Load Real(Stk(Elevel+2),-1,Bytes)
      Gop RXB(ST,Freg1,0,Reg1,0,Bytes)
      Note Reguse(Freg1,0,Bytes)
      %if Opcode=ECMPLX1 %thenstart
         Gop RXB(ZM,0,0,Reg1,Bytes,Bytes)
      %finishelsestart
         Freg1=Load Real(Stk(Elevel+3),-1,Bytes)
         Gop RXB(ST,Freg1,0,Reg1,Bytes,Bytes)
         Note Reguse(Freg1,0,Bytes)
      %finish
      Unlock Reg(Reg1)
      %return
!*
F77op(EISHFT):      
      %if Stk(Elevel)_Form=Litval %thenstart
         Shift=Stk(Elevel)_Intval
Litshift:%if Shift=0 %then Elevel=Elevel-1 %and %return
         %if Shift<0 %thenstart
            %if Opcode=EISHFT %then Op=SRL %else Op=SRA
            Shift=-Shift
         %finishelse Op=SLL
         Shift=Shift&31
         Elevel=Elevel-2
         %if bytes<=4 %and Stk(Elevel+1)_Form=Litval %and Op#SRA %thenstart
            Val=Stk(Elevel+1)_Intval
            %if Op=SLL %then Val=Val<<Shift %else Val=Val>>Shift
            Estklit(Val)
            %return
         %finish
         Reg1=Load Int(Stk(Elevel+1),-1)
         %if Stk(Elevel+1)_Size=2 %and Opcode=EISHFT %thenstart
            Estklit(X'FFFF')
            Elevel=Elevel-1
            %if Op=SRL %thenstart
               Gop RX(ANM,Reg1,Stk(Elevel+1))
               Gop Shift Lit(SRL,Reg1,Shift)
            %finishelsestart
               Gop Shift Lit(SLL,Reg1,Shift)
               Gop RX(ANM,Reg1,Stk(Elevel+1))
            %finish
         %finishelsestart
            Gop Shift Lit(Op,Reg1,Shift)
         %finish
         Stackr(Reg1,bytes)
         %return
      %finishelse ->Spc
!*
F77op(EIBTEST):     
      Eop(ISHRL)
      Estklit(1)
      Eop(IAND)
      %return
!*
F77op(EIBSET):      
      %if Stk(Elevel)_Form=Litval %thenstart
         Stk(Elevel)_Intval=1<<Stk(Elevel)_Intval
      %finishelsestart
         Estklit(1)
         Epromote(2)
         Eop(ISHLL)
      %finish
      Eop(IOR)
      %return
!*
F77op(EIBCLR):      
      %if Stk(Elevel)_Form=Litval %thenstart
         Stk(Elevel)_Intval=(1<<Stk(Elevel)_Intval)!!(-1)
      %finishelsestart
         Estklit(1)
         Epromote(2)
         Eop(ISHLL)
         Eop(INOT)
      %finish
      Eop(IAND)
      %return
!*
F77op(EIBITS):       
!*
F77op(EISHFTC):      
Spc:  Spcall(15+Opcode-EISHFT)
      %return
!*
F77op(PROCARG):    
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
      Elevel=Elevel-1
      Reg1=Get Procref(Stk(Elevel+1)_Intval)
      Stackr(Reg1,4)
      %if Cpu=Concept %thenstart
         Eop(Pushval)
      %finish
      %return
!*
F77op(IPROCARG):   
!*
F77op(CHARARG):    
!*
F77op(IPROCCALL):   
      Unsupported Opcode(Opcode)
      %return
!*
F77op(ARGPROCCALL):
      %if Elevel<2 %then Low Estack(Opcode,2) %and %return
      Elevel=Elevel-2
      Reg1=Load Int(Stk(Elevel+1),r0)
      Gop Call(0,Stk(Elevel+2)_Intval,0,0)
      %return
!*
F77op(NOTEIORES):  
      {no special action required here on Gould - result will stay in r0}
      %return
!*
F77op(STKIORES):    
      %if Cpu=Concept %thenstart
         Stackr(r0,4)
      %finishelsestart
         Stackr(r2,4)
      %finish
      %return
!*
F77op(CALLTPLATE): 
      %return    
!*
F77op(EFDVACC):
      %if Elevel<3 %then Low Estack(Opcode,3) %and %return
      Reg1=claim reg pair(1)
      Reg2=Load Int(Stk(Elevel),Reg1+1)
      Reg2=Load Int(Stk(Elevel-1),-1)
      %if cpu=concept %start
         Gop RR(MPR,Reg1,Reg2)
      %finishelsestart
         Gop RR(MPR,Reg1+1,Reg2)
      %finish
      Elevel=Elevel-2
      unlock reg pair(Reg1)
      Stackr(Reg1+1,4)
      Eop(IADD)
      Stackr(Reg2,4)
      %return
!*
F77op(EARGLEN):
      %return
!*
F77op(EFNOTEVR):
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
      Elevel=Elevel-1
      %if Cpu=Concept %thenstart
         Reg1=Load Int(Stk(Elevel+1),r0)
      %finishelsestart
         Reg1=Load Int(Stk(Elevel+1),r2)
      %finish
      %return
!*
F77op(EFSETVR):
      %if Cpu=Concept %thenstart
         Stackr(r0,4)
      %finishelsestart
         Stackr(r2,4)
      %finish
      %return
!*
F77op(ELOADB):
      Elevel=Elevel-1
      Moptreguse(r7,1)
      %if Stk(Elevel+1)_Form&31=Regval %thenstart
         Reg1=Stk(Elevel+1)_Reg
         Gop RR(TRR,r7,Reg1)
         Note Reguse(Reg1,0,0)
      %finishelsestart
         Gop RX(L,r7,Stk(Elevel+1))
      %finish
      %if Keycommon>0 %then moptreguse(r6,Keycommon)
      %return
!*
F77op(ESTOREB):
      Elevel=Elevel-1
      Gop RX(ST,r7,Stk(Elevel+1))
      Mr7updated
      Moptreguse(r6,0)
      %return
!*
F77op(EINCRB):
      Elevel=Elevel-1
      %if Stk(Elevel+1)_Form=Litval %and 0<=Stk(Elevel+1)_Intval<=32767 %thenstart
         Gop RI(ADI,r7,Stk(Elevel+1)_Intval)
      %finishelsestart
         Gop RX(ADM,r7,Stk(Elevel+1))
      %finish
      Mr7updated
      %return
!*
F77op(EDECRB):
      Elevel=Elevel-1
      %if Stk(Elevel+1)_Form=Litval %and 0<=Stk(Elevel+1)_Intval<=32767 %thenstart
         Gop RI(ADI,r7,-Stk(Elevel+1)_Intval)
      %finishelsestart
         Gop RX(SUM,r7,Stk(Elevel+1))
      %finish
      Mr7updated
      %return
!*
F77op(EINCR):
      Eop(IADDST)
      %return
!*
F77op(EDECR):
      Eop(ISUBST)
      %return
!*
F77op(ELSHIFT):
      %if Stk(Elevel)_Form=Litval %thenstart
         Shift=Stk(Elevel)_Intval
         ->Litshift
      %finish
      Spcall(25)
      %return
!*
F77op(ERSHIFT):
      %if Stk(Elevel)_Form=Litval %thenstart
         Shift=-Stk(Elevel)_Intval
         ->Litshift
      %finish
      Spcall(26)
      %return
!*
F77op(EADJL):
      Spcall(22)
      %return
!*
F77op(EADJR):
      Spcall(23)
      %return
!*
F77op(EVERIFY):
      Spcall(24)
      %return
!*
F77op(ECXRES):
      Elevel=Elevel-2
      Reg1=claim reg
      Gop RX(L,Reg1,Stk(Elevel+2))
      Gop RXB(ST,r2,0,Reg1,0,4)
      Gop RXB(ST,r3,0,Reg1,4,4)
      Notereguse(Reg1,0,0)
      unlock reg pair(r2)
      %return
!*
F77op(ERBIT):
      Elevel=Elevel-2
      Reg1=claim reg
      Gop R(ZR,Reg1)
      Gop Bit(TBM,0,0,Stk(Elevel+1),Stk(Elevel+2))
      Lab1=Mprivatelabel
      Gop Jump(BCF,Lab1)
      Gop RI(LI,Reg1,1)
      Mcode Plabel(Lab1)
      Stackr(Reg1,4)
      %return
!*
F77op(EWBIT):
      Elevel=Elevel-3
      %if Stk(Elevel+1)_form=LitVal %thenstart
         Reg1=Stk(Elevel+1)_IntVal&1
         Gop Bit(SBM,0,Reg1,Stk(Elevel+2),Stk(Elevel+3))
      %finishelsestart
         Reg1=Load Reg(-2,Stk(Elevel+1))
         Gop Bit(SBM,1,Reg1,Stk(Elevel+2),Stk(Elevel+3))
         unlock reg(Reg1)
      %finish
      %return
!*
%end;! Ef77op
!*
%externalroutine Epasop(%integer Opcode)
!***********************************************************************
!* opcodes specifically defined for use by Pascal                      *
!***********************************************************************
      Abortm("Epasop")
!*
%end;! Epasop
!*
%externalroutine Eccop(%integer Opcode)
!***********************************************************************
!* opcodes specifically defined for use by C                           *
!***********************************************************************
%constintegerarray Uopst(0:3) = IADDST,ISUBST,IMULTST,IDIVST
%constintegerarray Ropst(0:9) = RADD,RSUB,RMULT,RDIV,ISHLL,ISHRL,0,0,0,ISHRA
%integer I,Reg1,Reg2,Bstart,Nbits,Bmask,Bshift,Bitval
%switch Cop(768:790)
      %if Report#0 %thenstart
         printstring("Cop     ".Ecopname(Opcode))
         newline
         Dump Estack
      %finish
      %if progfaulty#0 %then %return
      ->Cop(Opcode)
!*
Cop(LOGNEG):
      %if Elevel<1 %then Low Estack(Opcode,1) %and %return
      Estklit(0)
      Eop(IEQ)
      Establish Logical
      %return
!*
Cop(LOGVAL):
      %if CCset=0 %thenstart
         %if Elevel<1 %then Low Estack(Opcode,1)%and %return
         Estklit(0)
         Eop(INE)
      %finish
      Note Reguse(r1,0,4)   {to ensure r1 is used}
      Establish Logical
      Elevel=Elevel-1   {use of r1 will be presumed by LOGSTK}
      Note Reguse(r1,0,4)
      %return
!*
Cop(LOGSTK):
      Stackr(r1,4)
      %return
!*
Cop(ECSTORE):
      I=Stk(Elevel)_Size
      %unless Stk(Elevel-1)_Size=I %then %monitor %and %stop
      Epromote(2)
      %if Stk(Elevel)_Form&31=Regval %thenstart
         Stk(Elevel)_Form=Regaddr
      %finishelsestart
         Eop(EADDRESS)
      %finish
      Epromote(2)
      Eop(EADDRESS)
      Estklit(I)
      %if I&3=0 %thenstart  {use word copy}
         Eop(EVAL)
      %finishelsestart
         Eop(MVB)
      %finish
      %return
!*
Cop(ECPROCCALL):
      %if Stk(Elevel)_Size=0 %thenstart
         Stk(Elevel)_Size=4
      %finish
      Eop(EADDRESS)
      Elevel=Elevel-1
      Reg1=Load Int(Stk(Elevel+1),r0)
      Gop Call(0,0,0,0)
      %return
!*
Cop(EPUSHSTR):
      Elevel=Elevel-2
      Push Struct(Stk(Elevel+1),Stk(Elevel+2)_Intval)
      %return
!*
Cop(ELDBITS):
      Elevel=Elevel-3
      Nbits=Stk(Elevel+3)_Intval
      Bstart=Stk(Elevel+2)_Intval
      Bmask=Bmaskval((Nbits-1)&31)  
      Bshift=32-Bstart-Nbits
      Reg1=Load Int(Stk(Elevel+1),-1)
      %if Bshift>0 %then Gop Shift Lit(SRL,Reg1,Bshift)
      Stackr(Reg1,4)
      Estklit(Bmask)
      Eop(IAND)
      %return
!*
Cop(ESTBITS):
      Elevel=Elevel-2
      Nbits=Stk(Elevel+2)_Intval
      Bstart=Stk(Elevel+1)_Intval
      Bmask=Bmaskval((Nbits-1)&31)
      Bshift=32-Bstart-Nbits
      Eop(DUPL)
      Elevel=Elevel-1
      Reg1=Load Int(Stk(Elevel+1),-1)
      Stackr(Reg1,4)
      Estklit((Bmask<<Bshift)!!(-1))
      Eop(IAND)
      Epromote(3)     {value to be set}
      Elevel=Elevel-1
      %if Stk(Elevel+1)_Form=Litval %thenstart
         Bitval=(Stk(Elevel+1)_Intval&Bmask)<<Bshift
         %if Ecdupflag#0 %thenstart
            Ecdupflag=0
            Estklit(Stk(Elevel+1)_Intval&Bmask)
            Epromote(3)
            Epromote(3)
         %finish
         Estklit(Bitval)
      %finishelsestart
         Reg2=Load Int(Stk(Elevel+1),-1)
         Stackr(Reg2,4)
         Estklit(Bmask)
         Eop(IAND)
         %if Ecdupflag#0 %thenstart
            Ecdupflag=0
            Eop(DUPL)
            Epromote(3)
            Epromote(3)
         %finish
         Estklit(Bshift)
         Eop(ISHLL)
      %finish
      Eop(IOR)
      Eop(EXCH)
      %if Ecdupflag#0 %thenstart
         Ecdupflag=0
         Eop(EDUPSTORE)
      %finishelsestart
         Eop(ESTORE)
      %finish
      %return
!*
Cop(UADDST):
Cop(USUBST):
Cop(UMULTST):
      Eop(Uopst(Opcode-UADDST))
      %return
!*
Cop(RADDST):
Cop(RSUBST):
Cop(RMULTST):
Cop(RDIVST): 
Cop(ISHLST):
Cop(ISHRST):
Cop(ISHRAST):
      %if Stk(Elevel-1)_Form&31=Regval %thenstart
         Eop(Ropst(Opcode-RADDST))
         Stk(Elevel)_Size=Csavestk_Size
         Elevel=Elevel+1
         Stk(Elevel)=Csavestk 
      %finishelsestart
         Eop(EXCH)
         Eop(DUPL)
         Epromote(3)
         Eop(Ropst(Opcode-RADDST))
         Eop(EXCH)
      %finish
      %if Ecdupflag#0 %thenstart
         Ecdupflag=0
         Eop(EDUPSTORE)
      %finishelsestart
         Eop(ESTORE)
      %finish
      %return
!*
Cop(CEVAL):
      Elevel=Elevel-1
      Reg1=Load Int(Stk(Elevel+1),-1)
      Stackr(Reg1,4)
      %return
!*
Cop(ECSAVE):
      Eop(DUPL)
      I=Elevel-1
      %while I>0 %cycle
         Epromote(Elevel)
         I=I-1
      %repeat
      Numcsave=Numcsave+1
      %return
!*
Cop(ECRESTORE):
      Epromote(Elevel-Numcsave+1)
      Numcsave=Numcsave-1
      %return
!*
Cop(*):
      %monitor
%end;! Eccop
!*
%routine Expcall(%integer Proc)
!***********************************************************************
!* call an exponentiation routine                                      *
!***********************************************************************
%integer I,J,T,Reg1
%string(31) S
      %if Proc<=2 %thenstart
         %if stk(elevel+1)_size#8 %and Stk(Elevel)_form=Litval %c
                                  %and Stk(Elevel)_Intval=2 %thenstart
            Elevel=Elevel-2
            %if Proc=0 %thenstart  {I**2}
               I=Load Int(Stk(Elevel+1),-1)
               %if Cpu=Concept %thenstart
                  Reg1=claim reg pair(1)
                  Gop RR(TRR,Reg1+1,I)
                  Gop RR(MPR,Reg1,I)
                  Note reguse(Reg1,0,4)
                  Note reguse(I,0,4)
                  Stackr(Reg1+1,4)
               %finishelsestart   {NP1}
                  Gop RR(MPR,I,I)
                  Stackr(I,4)
               %finish
               %return
            %finishelsestart
               %if Proc=1 %thenstart  {R**2}
                  J=MPRFW
                  T=4
               %finishelsestart  {D**2}
                  J=MPRFD
                  T=8
               %finish
               I=Load Real(Stk(Elevel+1),-1,T)
               Gop RR(J,I,I)
               Stackfr(I,T)
               %return
            %finish
         %finish
      %finish
      T=Expproctype(Proc)
      J=Expprocref(Proc)
      %if J=0 %thenstart
         S=Expprocs(Proc)
         J=Exname(T,S)
         Expprocref(Proc)=J
      %finish
      Eprecall(J)
      I=Expprocpdesc(Proc)>>16
      %while I>0 %cycle
         %if STACK DIRECTION=POSITIVE %thenstart
            Epromote(I)
         %finish
         %if Stk(Elevel)_Size<4 %thenstart
            Estklit(4)
            Eop(CVTII)
         %finish
         Address(Stk(Elevel))
         Stk(Elevel)_Size=4
         Eop(PUSHVAL)
         I=I-1
      %repeat
      I=Expprocpdesc(Proc)
      Freeregs
      Ecall(J,I>>16,I&X'FF')
      %if T&7#0 %thenstart;! function
         Estkresult(0,T&7,(T>>8)&255)
      %finish
      %if Cpu=NP1 %thenstart
         %if Proc=4 %or Proc=12 %thenstart  ;! c**i, c**c
            Stackfr(r2,8)
            Epromote(2)
            Ef77op(Ecxres)
         %finish
      %finish
%end;! Expcall
!*
%externalroutine Spcall(%integer Proc)
!***********************************************************************
!* call a support procedure                                            *
!***********************************************************************
%integer I,J,T
%string(31) S
      T=Spproctype(Proc)
      J=Spprocref(Proc)
      %if J=0 %thenstart
         S=Spprocs(Proc)
         J=Exname(T,S)
         Spprocref(Proc)=J
      %finish
      Eprecall(J)
      I=Spprocpdesc(Proc)>>16
      %while I>0 %cycle
         %if STACK DIRECTION=POSITIVE %thenstart
            Epromote(I)
         %finish
         %if Proc=27 %or Proc=28 %thenstart  {integer*8 proc}
            Eop(Pushaddr)
         %finishelse Eop(PUSHVAL)
         I=I-1
      %repeat
      I=Spprocpdesc(Proc)
      Freeregs
      Ecall(J,I>>16,I&X'FF')
      %if T&7#0 %thenstart;! function
         Estkresult(0,T&7,(T>>8)&255)
      %finish
%end;! Spcall
!*
!*
!*
!*
!***********************************************************************
!***********************************************************************
!**             Code generation support procedures                    **
!***********************************************************************
!***********************************************************************
!*
!*
%externalroutine Epush Operand(%record(Stkfmt)%name Operand)
      %if Elevel=Stklimit %then Abort
      Elevel=Elevel+1
      Stk(Elevel)=Operand
%end;! Push Operand
!*
%externalroutine Refer(%record(Stkfmt)%name Stk,%integer Offset)
%integer Reg
%record(Stkfmt) S1
%switch F(0:31)
      ->F(Stk_Form&31);! removing the reg marker bit
!*
F(RegVar):
      Stk_Form=Regptr
      %return
!*
F(RegVal):                {  (reg)      }
      %if stk_Reg=0 %thenstart
         Reg=claim reg
         Gop RR(TRR,Reg,0)
         Note Reguse(0,0,0)
         Stk_Reg=Reg
      %finish
      %if Offset#0 %thenstart
         Stk_Form=IndRegModVal!Regflag
         Note Reguse(Stk_Reg,-Elevel,4)
Setoff:  Stk_Modform=Litval
         Stk_Modintval=Offset
         Stk_Scale=0
         %return
      %finish
      Stk_Form=IndRegVal!Regflag
      Note Reguse(Stk_Reg,-Elevel,4)
      %return
!*
F(TempVal):               {  (temp)     }
      %if Offset#0 %thenstart
         Stk_Form=IndTempModVal
         ->Setoff
      %finish
      Stk_Form=IndTempVal
      %return
!*
F(DirVal):                {  (dir)      }
      %if Offset#0 %thenstart
         Stk_Form=IndDirModVal
         ->Setoff
      %finish
      Stk_Form=IndDirVal
      %return
!*
F(IndRegVal):             { ((reg))     }
      Gop RXB(L,Stk_Reg,0,Stk_Reg,0,4)
      ->F(RegVal)
!*
F(AddrDirMod):            {  @dir+M     }
      %if Offset=0 %thenstart
         Stk_Form=AddrDirModVal
         %return
      %finish
      ->Loadr
!*
F(IndTempVal):            { ((temp))    }
F(IndDirVal):             { ((dir))     }
F(AddrDirModVal):         { (dir+M)     }
F(IndRegModVal):          { ((reg)+M)   }
F(IndTempModVal):         { ((temp)+M)  }
F(IndDirModVal):          { ((dir)+M)   }
Loadr:Reg=Load Int(stk,-1)
      Stk_Reg=Reg
      ->F(RegVal)
!*
F(AddrConst):             {  @const     }
      Stk_Form=ConstVal
      Stk_Offset=Stk_Offset+Offset
      %return
!*
F(AddrDir):               {  @dir       }
      Stk_Form=DirVal
      Stk_Offset=Stk_Offset+Offset
      %return
!*
F(RegAddr):               {  (reg) is @ }
      ->F(RegVal)
!*
F(TempAddr):              {  (temp) is @}
      %if Offset#0 %thenstart
         Stk_Form=IndTempModVal
         ->Setoff
      %finish
      Stk_Form=IndTempVal
      %return
!*
F(DirAddr):               {  (dir) is @ }
      %if Offset#0 %thenstart
         Stk_Form=IndDirModVal
         ->Setoff
      %finish
      Stk_Form=IndDirVal
      %return
!*
F(RegModAddr):            {  (reg)+M    }
      %if Offset=0 %thenstart
         Stk_Form=IndRegModVal!Regflag
         %return
      %finish
      ->Loadr
!*
F(TempModAddr):           {  (temp)+M   }
      %if Offset=0 %thenstart
         Stk_Form=IndTempModVal
         %return
      %finish
      ->Loadr
!*
F(DirModAddr):            {  (dir)+M    }
      %if Offset=0 %thenstart
         Stk_Form=InddirModVal
         %return
      %finish
      ->Loadr
!*
F(LitVal):                {  lit        }
F(ConstVal):              {  const      }
F(FregVal):               {  (freg)     }
      printstring("
Invalid attempt to Refer 
")
      Abort
!*
%end;! Refer
!*
%externalroutine Address(%record(Stkfmt)%name Stk)
%integer I,J,Reg,Op,Area,Offset
%record(Stkfmt) S1
%switch F(0:21)
      ->F(Stk_Form&31);! removing the reg marker bit
!*
F(LitVal):                {  lit        }
      I=Stk_Intval
      J=addr(I)
      %if Stk_Size#4 %thenstart
         %if Stk_Size=2 %then J=J+2 %else J=J+3
      %finish
      Msetconst(J,Stk_Size,Area,Offset)
      Stk_Base=Area
      Stk_Offset=Offset
F(ConstVal):              {  const      }
      Stk_Form=AddrConst
Size: Stk_Size=4
      %return
!*
F(RegVal):                {  (reg)      }
      Stk_Base=Stack
      Stk_Offset=Estackspace(Stk_size)
Streg:Stk_Form=DirVal
      Gop RX(ST,Stk_Reg,Stk)
      Stk_Form=AddrDir
      Note Reguse(Stk_Reg,0,Stk_Size)
      ->Size
!*
F(FregVal):               {  (freg)     }
      Stk_Base=Stack
      Stk_Offset=Estackspace(Stk_Size)
      ->Streg
!*
F(TempVal):               {  (temp)     }
      Stk_Form=AddrDir
      ->Size
!*
F(DirVal):                {  (dir)      }
      Stk_Form=AddrDir
      ->Size
!*
F(IndRegVal):             { ((reg))     }
      Stk_Form=RegAddr!Regflag
      ->Size
!*
F(IndTempVal):            { ((temp))    }
      Stk_Form=TempAddr
      ->Size
!*
F(IndDirVal):             { ((dir))     }
      Stk_Form=DirAddr
      ->Size
!*
F(AddrDirModVal):             { (dir+M)     }
      Stk_Form=AddrDirMod!(Stk_Form&Regflag)
      ->Size
!*
F(IndRegModVal):          { ((reg)+M)   }
      Stk_Form=RegModAddr!Regflag
      ->Size
!*
F(IndTempModVal):         { ((temp)+M)  }
      Stk_Form=TempModAddr!(Stk_Form&Regflag)
      ->Size
!*
F(IndDirModVal):          { ((dir)+M)   }
      Stk_Form=DirModAddr!(Stk_Form&Regflag)
      ->Size
!*
F(AddrConst):             {  @const     }
F(RegAddr):               {  (reg) is @ }
F(TempAddr):              {  (temp) is @}
F(DirAddr):               {  (dir) is @ }
F(AddrDir):               {  @dir       }
F(AddrDirMod):            {  @dir+M     }
F(RegModAddr):            {  (reg)+M    }
F(TempModAddr):           {  (temp)+M   }
F(DirModAddr):            {  (dir)+M    }
!*
%end;! Address
!*
%externalroutine Stackr(%integer R,size)
!***********************************************************************
!* create an Estack entry for a value held in a general register       *
!***********************************************************************
%record(Stkfmt)%name Lstk
      Elevel=Elevel+1
      Lstk==Stk(Elevel)
      Lstk=0
      Lstk_Form=RegVal!Regflag
      Lstk_Reg=R
      Lstk_Size=size
      Note Reguse(R,-Elevel,size)
%end;! Stackr
!*
%externalroutine Stackfr(%integer FR,Bytes)
!***********************************************************************
!* create an Estack entry for a value held in a floating register      *
!***********************************************************************
%record(Stkfmt)%name Lstk
      Elevel=Elevel+1
      Lstk==Stk(Elevel)
      Lstk=0
      Lstk_Form=FregVal!Regflag
      Lstk_Reg=FR
      Lstk_Size=Bytes
      Note Reguse(FR,-Elevel,Bytes)
%end;! Stackfr
!*
%externalroutine Establish Logical
!***********************************************************************
!* called when a condition code has been set and required result is a  *
!* logical value (0 or 1)                                              *
!***********************************************************************
%integer Reg1,Lab1,Lab2
      Lab1=Mprivatelabel
      Lab2=Mprivatelabel
      Reg1=Claim Reg
      Gop Jump(BGT+CC,Lab1)
      Gop R(ZR,Reg1)
      Gop(NOP)
      Gop Jump(BU,Lab2)
      Mcode Plabel(Lab1)
      Gop RI(LI,Reg1,1)
      Mcode Plabel(Lab2)
      Stackr(Reg1,4);! stack integer result in Reg1
      CCset=0
%end;! Establish Logical
!*
%routine Convert II(%record(Stkfmt)%name Lstk,%integer Newsize)
!***********************************************************************
!* converts between integer sizes                                      *
!* descriptor to result on Estack                                      *
!***********************************************************************
%integer data1,data2
%integer Reg,Bytes,Op,i
      Bytes=Lstk_Size
      %if Bytes=Newsize %then Elevel=Elevel+1 %and %return
      %if Lstk_Form=LitVal %thenstart
         %if bytes=2 %and newsize=4 %start
           %if Lstk_Intval&x'8000'#0 %then Lstk_intval=Lstk_Intval!x'ffff0000'
         %finish
         %if newsize=8 %start
            data2=Lstk_intval
            %if data2>>31#0 %then data1=-1 %else data1=0
            Estkconst(8,addr(data1))
         %finishelsestart
            Lstk_Size=Newsize
            Elevel=Elevel+1
         %finish
         %return
      %finish
      %if bytes<=4 %and newsize=8 %start 
          reg=Claim reg pair(1)
          i=Load Int(Lstk,reg+1) 
          %if Cpu=NP1 %thenstart
             Gop RR(EXS,Reg,Reg+1)
          %finishelsestart
             Gop R(ES,Reg)
          %finish
      %finishelsec
          Reg=Load Int(Lstk,-1)
      %if bytes=8 %and newsize<=4 %start   { DO we worry about overflow???}
         Unlock reg pair(reg)
         reg=reg+1
         Note reguse(reg,-255,4)
      %finish
      %if Lstk_Form&31=regval %and bytes=2 %start
         Gop Shift Lit(SLL,reg,16)
         Gop Shift Lit(SRA,reg,16)
      %finish
      Stackr(Reg,newsize)
%end;! Convert II
!*
%routine Convert RR(%integer Mode,%record(Stkfmt)%name Stk,%integer Newsize)
!***********************************************************************
!* 0  converts between real sizes                                      *
!* 1  TNCRR                                                            *
!* 2  RNDRR                                                            *
!* descriptor to result on Estack                                      *
!***********************************************************************
%integer Freg1
      Freg1=Load Real(Stk,-1,Newsize)
      Stackfr(Freg1,Newsize)
      %if Mode=0 %then %return
      %if Mode=1 %thenstart
         Estklit(4)
         Eop(TNCRI)
         Estklit(Newsize)
         Eop(CVTIR)
      %finishelsestart
         Estklit(4)
         Eop(RNDRI)
         Estklit(Newsize)
         Eop(CVTIR)
      %finish
%end;! Convert RR
!*
%routine Convert RI(%record(Stkfmt)%name Stk,%integer Newsize,Mode)
!***********************************************************************
!* converts between real and integer                                   *
!* Mode = 0   TNC       Round towards zero (Fortran)                   *
!*        1   RND       Round towards the nearest integer              *
!*      2   EFLOOR      round towards - infinity                       *
!* descriptor to result on Estack                                      *
!*     Theory of fixing on NP                                          *
!*     The only instruction acts by fixing towards zero so :-          *
!*          For round we add or subtarct 0.5 and use TNC               *
!*          For efloor if positive treat as TNC                        *
!*               If negative add maxint TNC and subtract maxint        *
!***********************************************************************
%ownintegerarray Half(0:5)=X'40800000',0,X'4E000000',X'80000000',
                          X'50800000',0;
%integer Reg,Area,size,reg2
      size=stk_size
      %if Mode>=1 %and consthalf=0 %then %c
         Msetconst(addr(Half(0)),8,Area,consthalf)
      %if Mode=2 %and Nearhalf=0 %then %start
         Msetconst(addr(Half(2)),8,Area,Nearhalf)
        Msetconst(addr(Half(4)),8,Area,reg2); ! Will be consecuitve
      %finish
      %if newsize=8 %then Size=8;! Avoid oflow prob if real*4->i*8
      Reg=Load Real(Stk,-1,Size)
      %if Mode=2 %then %start
         Gop Floor(Reg,Newsize,Nearhalf)
      %else
         %if Mode>=1 %then Gop Rnd(Reg,Size,consthalf)
         %if Size<=4 %thenstart
            Gop RR(FIXW,Reg,Reg)
         %finishelsestart
            Gop RR(FIXD,Reg,Reg)
         %finish
      %finish
      %if newsize<=4 %start
         unlock reg pair(Reg)
         Reg=Reg+1
      %finish
      Stackr(Reg,newsize)
%end;! Convert RI
!*
%routine Convert IR(%record(Stkfmt)%name PStk,%integer Newsize)
!***********************************************************************
!* converts real to integer                                            *
!* descriptor to result on Estack                                      *
!***********************************************************************
%integer Reg,Reg1,Op,bytes
      bytes=Pstk_size
      %if Newsize=8 %thenstart
         %if bytes=8 %and Pstk_form&31=regval %then reg=Pstk_reg %c
                                              %else Reg=claim reg pair(1)
         %if bytes<=4 %start
            Reg1=Load Int(Pstk,Reg+1)
            %if Cpu=NP1 %thenstart
               Gop RR(EXS,Reg,Reg+1)
            %finishelsestart
               Gop R(ES,Reg)
            %finish
         %finishelse reg1=Load Int(pstk,reg)
         Op=FLTD
      %finishelsestart
         Reg=Load Int(PStk,-1)
         %if bytes<=4 %then Op=FLTW %else Op=FLTD
      %finish
      Gop RR(Op,Reg,Reg)
      %if bytes=8 %and newsize<=4 %start
         Unlock reg pair(reg)
         reg=reg+1
         Note reguse(reg,-255,4)

      %finish
      Stackfr(Reg,Newsize)
      %return    
%end;! Convert IR
!*
%routine Convert SBI(%record(Stkfmt)%name Lstk,%integer Newsize)
!***********************************************************************
!* converts signed byte to integer                                     *
!* descriptor to result on Estack                                      *
!***********************************************************************
%integer Reg,Bytes,Op
      Bytes=Lstk_Size
      %if Bytes=Newsize %then Elevel=Elevel+1 %and %return
      %if Lstk_Form=LitVal %thenstart
         Lstk_Size=Newsize
         %if Lstk_Intval&128#0 %then Lstk_Intval=Lstk_Intval!X'FFFFFF00'
         Elevel=Elevel+1
         %return
      %finish
      Reg=Load Int(Lstk,-1)
      Gop Shift Lit(SLL,Reg,24)
      Gop Shift Lit(SRA,Reg,24)
      Stackr(Reg,4)
      Stk(Elevel)_Size=Newsize
%end;! Convert SBI
!*
%routine Convert IU(%record(Stkfmt)%name Lstk,%integer Newsize)
!***********************************************************************
!* converts integer to unsigned integer                                *
!* descriptor to result on Estack                                      *
!***********************************************************************
%integer data1,data2
%integer Reg,Bytes,Op,I
      Bytes=Lstk_Size
      %if Bytes=Newsize %then Elevel=Elevel+1 %and %return
      %if Lstk_Form=LitVal %thenstart
         %if Newsize=2 %thenstart
            Lstk_Intval=Lstk_Intval&X'FFFF'
         %finishelsestart
            %if Newsize=1 %thenstart
               Lstk_Intval=Lstk_Intval&X'FF'
            %finish
         %finish
         %if newsize=8 %start
            data2=Lstk_intval
            data1=0
            Estkconst(8,addr(data1))
         %finishelsestart
            Lstk_Size=Newsize
            Elevel=Elevel+1
         %finish
         %return
      %finish
      %if bytes<=4 %and newsize=8 %start 
          reg=Claim reg pair(1)
          I=Load Int(Lstk,reg+1) 
          Gop RR(EOR,Reg,Reg)
      %finishelse Reg=Load Int(Lstk,-1)
      %if bytes=8 %and newsize<=4 %start
         Unlock reg pair(reg)
         reg=reg+1
         Note reguse(reg,-255,4)
      %finish
      Stackr(Reg,Newsize)
      %if Newsize=1 %thenstart 
         Estklit(X'FF')
         Eop(IAND)
      %finishelsestart
         %if Bytes=2 %or Newsize=2 %thenstart
            Estklit(X'FFFF')
            Eop(IAND)
         %finish
      %finish
      Stk(Elevel)_Size=Newsize
%end;! ConvertIU 
!*
%routine Convert UR(%record(Stkfmt)%name Lstk,%integer Newsize)
!***********************************************************************
!* converts unsigned integer to real                                   *
!* descriptor to result on Estack                                      *
!***********************************************************************
%integer Reg,Bytes,Op
      Bytes=Lstk_Size
      Reg=Load Int(Lstk,-1)
      Stackr(Reg,4)
      %if Bytes=2 %thenstart
         Estklit(X'FFFF')
         Eop(IAND)
      %finish
      Stk(Elevel)_Size=4
      Estklit(Newsize)
      Eop(CVTIR)
%end;! Convert UR
!*
!*
!***********************************************************************
!***********************************************************************
!**            Pascal-specific support procedures                     **
!***********************************************************************
!***********************************************************************
!*
!*
!***********************************************************************
!***********************************************************************
!*
!*
%routine Do Charop(%integer Op,%record(Stkfmt)%name C1,LenC1,C2,LenC2)
%integer I,Len1,Len2,B1,D1,B2,D2,XAop,Apars,Reg
      %if C1_Form=LitVal %then C1_Size=1
      %if C2_Form=LitVal %then C2_Size=1
      Len1=LenC1_Intval
      Len2=LenC2_Intval
      %if LenC1_Form=Litval %and LenC2_Form=LitVal %and Len1=Len2 %thenstart
         %if Op=EASGNCHAR %thenstart
            %if Len1=1 %thenstart
               Refer(C1,0)
               C1_Size=1
               Refer(C2,0)
               C2_Size=1
               Reg=claim reg
               Gop RX(L,Reg,C2)
               Gop RX(ST,Reg,C1)
               Note Reguse(Reg,0,0)
            %finishelsestart
               Gop Mvb(LenC1,C2,C1)
            %finish
         %finishelsestart
            %if Len1=1 %thenstart
               Refer(C1,0)
               C1_Size=1
               Refer(C2,0)
               C2_Size=1
               Reg=claim reg
               Gop RX(L,Reg,C1)
               Gop RX(CAM,Reg,C2)
               Note Reguse(Reg,0,0)
            %finishelsestart
               Gop Cpb(CC,LenC1,C1,C2)
            %finish
            CCset=1
         %finish
      %finishelsestart
         %if Op=EASGNCHAR %thenstart
            Elevel=Elevel+4
            Spcall(9)
         %finishelsestart
            Elevel=Elevel+5
            Spcall(10)
         %finish
      %finish
%end;! Do Charop
!*
%routine Cx Operation(%integer Op,Flags,%record(Stkfmt)%name LHS,RHS1,RHS2)
!***********************************************************************
!* Op = 1   CXADD           5   CXNEG          9   CONJG               *
!*      2   CXSUB           6   CXASGN        10   CMPLX1              *
!*      3   CXMULT          7   CXEQ          11   CMPLX2              *
!*      4   CXDIV           8   CXNE                                   *
!* Flags = Variant<<8 ! Sizecode                                       *
!*         Variant:  0   complex  op  complex                          *
!*                   1   complex  op  real                             *
!*                   2      real  op  complex                          *
!*        Sizecode:  0    8                                            *
!*                   1   16                                            *
!*                   2   32                                            *
!***********************************************************************
%integer Variant,Size,D,NewD,Freg1,Freg2,I,Op1,Ax,Ay,Az,saver6r7
%record(Stkfmt) Xr,Xi,Yr,Yi,Zr,Zi
%switch S(0:11)
      Variant=Flags>>8
      Size=Flags&3
      %if Size=0 %then D=4 %else D=8
      %if ((Op=3 %and Size#0) %or Op=4) %and Variant=0 %thenstart;! use support procedure
         Elevel=Elevel+3;! to allow operands to be pushed
         %if Op=3 %thenstart
            saver6r7=Estackspace(8)
            Eafix(Stack,0)
            Gop RXB(ST,r6,br2,0,saver6r7,8)
         %finish
         Spcall(3*(Op-3)+Size)
         %if Cpu=NP1 %thenstart
            %if Size=0 %thenstart  ;! c*4/c*4
               Stackfr(r2,8)
               Epromote(2)
               Ef77op(Ecxres)
            %finish
         %finish
         %if Op=3 %thenstart
            Eafix(Stack,0)
            Gop RXB(L,r6,br2,0,saver6r7,8)
         %finish
         %return
      %finish
!*
      Ax=-1
      Ay=-1
      Az=-1
      Freg1=-1
      Freg2=-1
!*
   %unless 7<=Op<=8 %thenstart
      %if RHS1_Form=Addrdir {%and RHS1_Base#Stack} %thenstart
         RHS1_Form=Dirval
         Xr=RHS1
         Xr_Size=D
         Xi=RHS1
         Xi_Size=D
         Xi_Offset=Xi_Offset+D
      %finishelsestart
         Xr=0
         Xr_Form=Indregval
         Xr_Size=D
         Xi=0
         Xi_Form=Indregmodval
         Xi_Size=D
         Xi_Modform=Litval
         Xi_Modintval=D
         Ax=Load Reg(-3,RHS1)
         Xr_Reg=Ax
         Xi_Reg=Ax
      %finish
!*
      %if Op<=4 %or Op=11 %thenstart
         %if RHS2_Form=Addrdir {%and RHS2_Base#Stack} %thenstart
            RHS2_Form=Dirval
            Yr=RHS2
            Yr_Size=D
            Yi=RHS2
            Yi_Size=D
            Yi_Offset=Yi_Offset+D
         %finishelsestart
            Yr=0
            Yr_Form=Indregval
            Yr_Size=D
            Yi=0
            Yi_Form=Indregmodval
            Yi_Size=D
            Yi_Modform=Litval
            Yi_Modintval=D
            Ay=Load Reg(-3,RHS2)
            Yr_Reg=Ay
            Yi_Reg=Ay
         %finish
      %finish
!*
      %if LHS_Form=Addrdir {%and LHS_Base#Stack} %thenstart
         LHS_Form=Dirval
         Zr=LHS
         Zr_Size=D
         Zi=LHS
         Zi_Size=D
         Zi_Offset=Zi_Offset+D
      %finishelsestart
         Zr=0
         Zr_Form=Indregval
         Zr_Size=D
         Zi=0
         Zi_Form=Indregmodval
         Zi_Size=D
         Zi_Modform=Litval
         Zi_Modintval=D
         Az=Load Reg(-3,LHS)
         Zr_Reg=Az
         Zi_Reg=Az
      %finish
   %finish
!*
      ->S(Op)
!*
S(1): ! CXADD
      Freg1=Load Real(Xr,-1,D)
      %if Ax>0 %then Note Reguse(Ax,-255,0);! since it may have been released
      Gop RX(ADF,Freg1,Yr)
      %if Ay>0 %then Note Reguse(Ay,-255,0)
      Gop RX(ST,Freg1,Zr)
      Note Reguse(Freg1,0,D)
      %if Az>0 %then Note Reguse(Az,-255,0)
      Freg2=Load Real(Xi,-1,D)
      %if Variant=0 %thenstart
         Gop RX(ADF,Freg2,Yi)
      %finish
Store:%if Freg2>=0 %thenstart
         Gop RX(ST,Freg2,Zi)
         Note Reguse(Freg2,0,D)
      %finish
Free: %if Ax>=0 %then Unlock Reg(Ax)
      %if Ay>=0 %then Unlock Reg(Ay)
      %if Az>=0 %then Unlock Reg(Az)
      %return
!*
S(2): ! CXSUB
      Freg1=Load Real(Xr,-1,D)
      %if Ax>0 %then Note Reguse(Ax,-255,0);! since it may have been released
      Gop RX(SUF,Freg1,Yr)
      %if Ay>0 %then Note Reguse(Ay,-255,0)
      Gop RX(ST,Freg1,Zr)
      Note Reguse(Freg1,0,D)
      %if Az>0 %then Note Reguse(Az,-255,0)
      %if Variant=2 %thenstart
         %if D=4 %then Freg2=claim reg %else Freg2=claim reg pair(1)
         Gop RX(LN,Freg2,Yi)
      %finishelsestart
         Freg2=Load Real(Xi,-1,D)
         %if Variant=0 %thenstart
            Gop RX(SUF,Freg2,Yi)
         %finish
      %finish
      ->Store
!*
S(3): ! CXMULT
      %if Variant=0 %thenstart;! complex*8
         Freg1=Load Real(Xr,-1,D)
         %if Ax>0 %then Note Reguse(Ax,-255,0)
         Gop RX(MPF,Freg1,Yr)
         %if Ay>0 %then Note Reguse(Ay,-255,0)
         Freg2=Load Real(Xi,-1,D)
         %if Ax>0 %then Note Reguse(Ax,-255,0)
         Gop RX(MPF,Freg2,Yi)
         %if Ay>0 %then Note Reguse(Ay,-255,0)
         Gop RR(SURFW,Freg1,Freg2)
         Gop RX(ST,Freg1,Zr)
         %if Az>0 %then Note Reguse(Az,-255,0)
         Note Reguse(Freg1,0,D)
         Note Reguse(Freg2,0,D)
         Freg1=Load Real(Xr,-1,D)
         %if Ax>0 %then Note Reguse(Ax,-255,0)
         Gop RX(MPF,Freg1,Yi)
         %if Ay>0 %then Note Reguse(Ay,-255,0)
         Freg2=Load Real(Xi,-1,D)
         %if Ax>0 %then Note Reguse(Ax,-255,0)
         Gop RX(MPF,Freg2,Yr)
         %if Ay>0 %then Note Reguse(Ay,-255,0)
         Gop RR(ADRFW,Freg1,Freg2)
         Gop RX(ST,Freg1,Zi)
         Note Reguse(Freg1,0,D)
         Note Reguse(Freg2,0,D)
         ->Free
      %finish
      Op1=MPF
Mdiv: Freg1=Load Real(Xr,-1,D)
Mdiv2:%if Ax>0 %then Note Reguse(Ax,-255,0);! since it may have been released
      Gop RX(Op1,Freg1,Yr)
      %if Ay>0 %then Note Reguse(Ay,-255,0)
      Gop RX(ST,Freg1,Zr)
      Note Reguse(Freg1,0,D)
      %if Az>0 %then Note Reguse(Az,-255,0)
      Freg2=Load Real(Xi,-1,D)
      Yi=Yr
      Gop RX(Op1,Freg2,Yi)
      ->Store
!*
S(4): ! CXDIV
      %if Cpu = NP1 %thenstart
         Freg1 = Load Real(Yr,-1,D)
         %if D = 4  %thenstart
            Op = RRFW 
            Op1 =MPRFW  
         %finishelsestart
            Op = RRFD
            Op1 =MPRFD  
         %finish
         Gop RR(Op,Freg1,Freg1)      { reciprocal }
         Freg2 = Load Real(Xr,-1,D)
         %if Ax>0 %then Note Reguse(Ax,-255,0)
         Gop RR(Op1,Freg2,Freg1)
         Gop RX(ST,Freg2,Zr)
         Note Reguse(Freg2,0,D)
         %if Az>0 %then Note Reguse(Az,-255,0)
         Gop RX(MPF,Freg1,Xi)
         Gop RX(ST,Freg1,Zi)
	 Note Reguse(Freg1,0,D)
         ->Free
      %finishelsestart
         Op1=DVF
         ->Mdiv
      %finish
!*
S(5): ! CXNEG
      %if D=4 %then Freg1=claim reg %else Freg1=claim reg pair(1)
      Gop RX(LN,Freg1,Xr)
      %if Ax>0 %then Note Reguse(Ax,-255,0);! since it may have been released
      Gop RX(ST,Freg1,Zr)
      Note Reguse(Freg1,0,D)
      %if Az>0 %then Note Reguse(Az,-255,0)
      %if D=4 %then Freg2=claim reg %else Freg2=claim reg pair(1)
      Gop RX(LN,Freg2,Xi)
      ->Store
!*
S(10):! CMPLX1
      Variant=1;! for complex = real
S(11):! CMPLX2
      NewD=D
      ->Ass
!*
S(6): ! CXASGN
      %if Flags&4=0 %thenstart;! assigning to single
         NewD=4
      %finishelsestart
         NewD=8
      %finish
Ass:  Zr_Size=NewD
      Zi_Size=NewD
      Zi_Modintval=NewD
      Freg1=Load Real(Xr,-1,NewD)
      %if Ax>0 %then Note Reguse(Ax,-255,0);! since it may have been released
      Gop RX(ST,Freg1,Zr)
      Note Reguse(Freg1,0,NewD)
      %if Az>0 %then Note Reguse(Az,-255,0)
      %if Variant#0 %thenstart;! not Cx = Cx
         %if Variant=2 %thenstart;! Real = Cx
            {no action required}
         %finishelsestart;! Cx = Real
            Zi_Offset=Zi_Offset+NewD-D
            Gop RX(ZM,0,Zi)
         %finish
      %finishelsestart;! Cx = Cx
         %if D#NewD %thenstart;! unequal lengths being assigned
            Freg2=Load Real(Xi,-1,NewD)
            Zi_Offset=Zi_Offset+NewD-D
         %finishelsestart
            %if Op=11 %thenstart
               Freg2=Load Real(Yr,-1,D)
            %finishelsestart
               Freg2=Load Real(Xi,-1,D)
            %finish
         %finish
      %finish
      D=NewD {to release appropriate register(s)}
      ->Store
!*
S(7): ! CXEQ
S(8): ! CXNE
      Zr=0
      Zr_Form=Litval
      Zr_Intval=D*2
      Zr_Size=4
      CC=Op-5;! 2  EQ   3  NE
      Gop Cpb(CC,Zr,LHS,RHS1)
      CCset=1
      %return
!*
S(9): ! CONJG
      Freg1=Load Real(Xr,-1,D)
      %if Ax>0 %then Note Reguse(Ax,-255,0);! since it may have been released
      Gop RX(ST,Freg1,Zr)
      Note Reguse(Freg1,0,D)
      %if Az>0 %then Note Reguse(Az,-255,0)
      %if D=4 %then Freg2=claim reg %else Freg2=claim reg pair(1)
      Gop RX(LN,Freg2,Xi)
      ->Store
%end;! Cx Operation
!*
!*
!***********************************************************************
!*
!*
%routine Note Index(%integer Scale,%record(Stkfmt)%name Base,Index)
!***********************************************************************
!* incorporate Index info into Base record                             *
!***********************************************************************
%integer Reg,Form
%switch F(0:21)
      %if Index_Size#4 %thenstart
          Convert II(Index,4)
          Elevel=Elevel-1
       %finish
      %if Index_Form&31>=AddrDirMod %thenstart
         Reg=Load Int(Index,-1)
         Note Reguse(Reg,-Elevel,4)
         Index_Reg=Reg
         Index_Form=RegVal!Regflag
      %finish
      %if Index_Form=LitVal %thenstart
         Index_Intval=Index_Intval<<Scale
         Scale=0
         %if Base_Form=AddrDir %thenstart
            Base_Offset=Base_Offset+Index_Intval
            %return
         %finish
      %finish
      ->F(Base_Form&31)
!*
F(IndRegVal):             { ((reg))     }
F(IndTempVal):            { ((temp))    }
F(IndDirVal):             { ((dir))     }
      Base_Form=Base_Form+12
Set:  Base_Modreg=Index_Reg
      Base_Modbase=Index_Base
      Base_Modform=Index_Form
      Base_Modoffset=Index_Offset
      Base_Scale=Scale
      %if Base_Modform&31=Regval %thenstart
         Note Reguse(Base_Modreg,-Elevel,4)
         Base_Modoffset=Base_Modoffset<<Scale
      %finish
      %return
!*
F(AddrDir):               {  @dir       }
F(RegAddr):               {  (reg) is @ }
F(TempAddr):              {  (temp) is @}
F(DirAddr):               {  (dir) is @ }
      Base_Form=Base_Form+4
      ->Set
!*
F(AddrDirMod):            {  @dir+M     }
F(RegModAddr):            {  (reg)+M    }
F(TempModAddr):           {  (temp)+M   }
F(DirModAddr):            {  (dir)+M    }
F(LitVal):                {  lit        }
F(ConstVal):              {  const      }
F(RegVal):                {  (reg)      }
F(TempVal):               {  (temp)     }
F(AddrConst):             {  @const     }
F(IndRegModVal):          { ((reg)+M)   }
F(IndTempModVal):         { ((temp)+M)  }
F(IndDirModVal):          { ((dir)+M)   }
F(AddrDirModVal):         { (@dir+M)    }
      Reg=Load Int(Base,-1)
      Note Reguse(Reg,-Elevel,4)
      Base_Reg=Reg
      Base_Form=RegModAddr!regflag
      ->Set
!*
F(DirVal):                {  (dir)      }
      ->F(IndDirVal)       { IMP failing to Refer }
!*
F(FregVal):               {  (freg)     }
      Abort
!*
%end;! Note Index
!*
%endoffile