%externalroutine icl9cezassemble
   %external %integer %map %spec COMREG %alias "S#COMREGMAP"(%integer N)
{* IBM XA Code Planting routinespecs *}

{******** Monitoring *********}

{ Parm CODE will cause a line by line decode of instructions }
{ Monitoring of all non-code planting is turned on by PMonOn or bit 1 of }
{ COMREG(26). Monitoring of code planting is turned on by bit 2 of COMREG(26) }
{ COMREG(26)=128 causes decoding of each instruction as planted }
{ COMREG(26)=256 causes decoding of the whole code area after fixups }

{* The following routinespecs have been provided initially, corresponding to the *}
{* formats given in the "Principles of Operation".                           *}

   %externalroutinespec PIX RR %alias "S#PIXRR" (%integer Op, R1, R2)
      { Plant RR format instruction }

   %externalroutinespec PIX RRE %alias "S#PIXRRE"(%integer Op, R1, R2)
      { Plant RRE format instruction }

   %externalroutinespec PIX RX %alias "S#PIXRX" (%integer Op, R1, X2, B2, D2)
      { Plant RX format instruction }

   %externalroutinespec PIX RS %alias "S#PIXRS" (%integer Op, R1, R3, B2, D2)
      { Plant RS format instruction }

   %externalroutinespec PIX SI %alias "S#PIXSI" (%integer Op, I2, B1, D1)
      { Plant SI format instruction }

   %externalroutinespec PIX S %alias "S#PIXS"  (%integer Op, B2, D2)
      { Plant S format instruction }

   %externalroutinespec PIX SS %alias "S#PIXSS" (%integer Op, L1, L2, B1, D1, B2, D2)
      { Plant SS fromat instruction }
      { If L1 is zero the effect is to plant the long L form }

   %externalroutinespec PIX SSE %alias "S#PIXSSE"(%integer Op, B1, D1, B2, D2)
      { Plant SSE format instruction }

{* Area initialisation *}

   { All areas are buffered as the ten new areas. }

   { The following consts represent these areas in this interface }

   %constinteger Code   =  1,
                 Gla    =  2,
               { Unused =  3 }
                 SST    =  4,
                 UST    =  5,
                 Diags  =  6,
                 Static =  7,
                 IoTab  =  8,
                 ZGST   =  9,
                 Cnst   = 10

   %externalintegerfnspec PMarker %alias "S#PMarker"(%integer HalfWords)
      { Mark CA for future PSetOpd and reserve HalfWords of code for plugging }
      { Also used to identify points in code to be used in PFix. }

   %externalroutinespec PBReloc %alias "S#PBReloc"(%integer AreaLoc,BaseLoc)
      { A satisfied relocation request in a bound file. }
      { Binding has set word in AreaLoc>>24, displacement = (AreaLoc<<8)>>8, }
      { the address of area BaseLoc>>24, displacement = (BaseLoc<<8)>>8.}

   %externalroutinespec PSetOpD %alias "S#PSetOpD"(%integer Mark, Offset, HalfWord)
      { Plug HalfWord at Marked code address plus Offset halfwords }

   %externalroutinespec PLabel %alias "S#PLabel"(%integer LabelId)
      { Note a label at CA, LabelId being assigned by the code generator }

   %externalroutinespec PUsing %alias "S#PUsing"(%integer Reg)
      { Note that Reg has just been loaded with PC following BASR or BALR. }
      { Where Reg is already Used, a implicit PDrop is performed. }

   %externalroutinespec PDrop %alias "S#PDrop"(%integer Reg)
      { Note that PUsing of Reg no longer applies. }
      { If Reg is not Used, a warning is printed, NOT an error. }

   %externalroutinespec PJump %alias "S#PJump"(%integer Op, LabelId, Mask, Reg)
      { Plant jump instruction, using LabelId to associate a label }
      { Reg is a spare register if needed. }

   %externalroutinespec PJIndex %alias "S#PJIndex"(%integer Op, Label, Reg1, Reg3)
      { Plant instruction as if it was a Branch on Index type }
      { No chacking of the Op is done, although a warning will be }
      { generated if the expected format is not RS. It is the }
      { responsibility of the code generator to do a PUsing within }
      { range of the label and to preserve the Using register until }
      { this jump. }

{* Switch support *}

   %externalroutinespec PSwitch %alias "S#PSwitch"(%integer SSTAd,Lower,Upper,Size)
      { Note a switch table from Lower to Upper is at SSTAd }
      { Element size in bytes is Size }

   %externalroutinespec PSwitchVal %alias "S#PSwitchVal"(%integer SSTAd, Index, Label)
      { Link Entry(Index) in switch table at SSTAd with Label }

   %externalroutinespec PSLabel %alias "S#PSLabel"(%integer SSTAd, Index)
      { Overwrite element no Index of switch at SSTAd with Ca }

   %externalroutinespec PSDefault %alias "S#PSDefault"(%integer SSTAd, Label)
      { Fill remaining elements of switch at SSTAd with Label's code offset }

{* Put Interface Passing of Data   * *}

   %externalroutinespec PCodeHalf %alias "S#PCodeHalf"(%integer Val)
      { Write 2 bytes to Code area at Ca, checking for overflow }

   %externalroutinespec PCodeWord %alias "S#PCodeWord"(%integer Val)
      { Write 4 bytes to Code area at Ca, with no validation }

   %externalroutinespec PCodeBytes %alias "S#PCodeBytes"(%integer Len, Ad)
      { Copy Len bytes from Ad into the Code area at Ca }


   %externalroutinespec PDBytes %alias "S#PDBytes"(%integer Area, Disp, Len, Ad)
      { Pass Len bytes of data from Ad to be placed at Disp in Area }
      { Areas used are the ten defined above }

   %externalroutinespec PD4 %alias "S#PD4"(%integer Area, Disp, Value)
      { Plant a 4 byte Value at Disp in Area, using buffered areas }

   %externalroutinespec PDPattern %alias "S#PDPattern"(%integer Area, Disp, NCopies, Len, Ad)
      { Make NCopies of Len bytes from Ad at Disp in Area }

{* Put Interface RELOCATION and REFERENCES    *}

   %externalintegerfnspec PXname %alias "S#PXname"(%integer Typ,%string(255)%name S,%integer GlAd)
      { Create an external code reference }
      { Xrefs are used many times so establish mapping to integer ID early}
      { and save on holding/passing of strings }
      { GlAd holds location at which code generator has placed a descriptor }
      { Type = 0 means normal spec, = 1 means dynamic spec }

   %externalroutinespec Pfix %alias "S#Pfix"(%integer Hostarea, HostDisp, TgtArea,TgtDisp)
      { A relocation request: set word in HostArea at offset HostDisp bytes, }
      { to the address of area TargetArea, displacement = TargetDisp.}
      { If area is Code, TargetDisp is assumed to be a PMarker value, unless }
      { TargetDisp is zero, when head of code is assumed. }

   %externalroutinespec PDXRef %alias "S#PDXRef"(%integer Type,Area,Disp,%string(31)%name ExtName)
      { Define an external data reference }
      { Relocate word at Disp in Area by external data ref ExtName }
      { Type holds min size in lowest byte }

   %externalroutinespec PDataEntry %alias "S#PDataEntry"(%string(255)%name Name,
                                   %integer Area, Maxlen, Disp)
      { Define a data entry in Area at Disp with Maxlen and called Name }

{* The next five routinespecs deal with PROCEDURES *}

   %externalroutinespec PEntry %alias "S#PEntry"(%integer Index, %string(255)%name Iden)
      { Note a sideways entry point. If Index is zero make this the main EP }

   %externalroutinespec PProcEntry %alias "S#PProcEntry"(%integer COffset,GOffset,EPOffset,ParamW, %c
                                   %string(255)%name Name)
      { Add a complete procedure entry. Used by LINK, MODIFY etc. }
      { The 4 integers specify the four words of the external entry. }
      { Name gives its identifier. }

   %externalroutinespec PProc %alias "S#PProc"(%string(31)%name Name, %integer Props, ParamW,
                                  %integername Id)
      { Start a new procedure. If Id is <0 no spec has been given by PXName. }
      { PROPS&1   = external }
      { PROPS>>31 = Main entry }

   %externalroutinespec PMinMultiples %alias "S#PMinMultiples"(%integer NMults)
      { Specify a minimum number of 4k multiples to be planted at the }
      { head of the current body of code. This routine should be }
      { called immediately before PProcEnd if multiples are to be }
      { added in front of each procedure body or before PTerminate }
      { if multiples are only added once at the start of the whole }
      { code area. Whether or not it is called, sufficient multiples }
      { are planted to address the whole of the code area, if the }
      { appropriate bit of Properties is set for PInitialise. }

   %externalroutinespec PProcEnd %alias "S#PProcEnd"
      { End of routine }

{* Put Interface - Miscellaneous  *}

   %externalroutinespec PNewArea %alias "S#PNewArea"(%string(255)%name Name, %integer Iin, Props)
      { Note a new area identified by Iin with properties given by Props }

   %externalroutinespec PEndArea %alias "S#PEndArea"(%integer Id,Length,Props)
      { End a Fortran Common area }
      { Not implemented on XA yet }

   %externalroutinespec PHistory %alias "S#PHistory"(%integer Type, Ad)
      { Add a history record to the linked list. }
      { Type sets the type. Ad is the address of the information, }
      { viewed as a string by PHistory. }

   %externalroutinespec Pfaulty %alias "S#Pfaulty"
     { Code generator has encountered a user error. Code requests should no }
     { longer be checked and minimum work done in PUT }

   %externalroutinespec PLineStart %alias "S#PLineStart"(%integer Line)
      { Updates latest line number }

   %externalroutinespec PLineDecode %alias "S#PLINEDECODE"
      { Decodes from the last PLineStart or PLineDecode }

   %externalroutinespec PInitialise %alias "S#PINITIALISE"(%integer Language, Properties, SourceAd)
      { Start code generation }
      { If Language=-1 then SourceAd is compiler or other source string7s }
      { string's address. Otherwise no source identifier for history records }
      { Properties&1#0 means Put to add multiples at head of each code area. }
      { Properties&2#0 means output a new code area at each PProcEnd. }

   %externalintegerfnspec PTerminate %alias "S#PTerminate"(%integer AdAreaSizes, MSize)
      { Code generator closes with this call }
      { Set Code size etc. }

{* PGENERATE - FINAL PHASE OF COMPILATION IS CREATE OBJECT FILE *}

   %externalroutinespec PGenerateObject %alias "S#PGenerateObject"(%string(255) %name  objfilename )
      { Output object file for target system }
      { No effect on Amdahl. Need not be called. }

   %externalroutinespec PMonOn %alias "S#PMonOn"
      { Switches on internal Put tracing }

   %externalroutinespec PMonOff %alias "S#PMonOff"
      { Switches off internal Put tracing }

   %externalroutinespec PTraceOn %alias "S#PTraceOn"

   %externalroutinespec PTraceOff %alias "S#PTraceOff"

{*   Pseudo - Operations    *}

   %externalroutinespec PCNOP %alias "S#PCNOP"(%integer I, J)
      { Matches CNOP in assembler manual }

   %routine %spec ASSEMBLE(%byte %integer %array %name S, %integer %name L,F)
   %integer DUMMY,FLAG,FILE ADDR,FILE PTR,FILE END,L,LL
   %byte %integer %array OPCODE(0:32*1024)
   %own %integer %array FDI(0:10)=0(*)
%ownstring(64) header =" EMAS ASSEMBLER  RELEASE  2  VERSION 1"
   L = 32000
   NEWLINES(2); SPACES(15)
   PRINTSTRING(header)
   NEWLINES(4)
   FILE ADDR = COMREG(46)
   %if FILE ADDR#0 %then %start
      FILE PTR = FILE ADDR+INTEGER(FILE ADDR+4)
      FILE END = FILE ADDR+INTEGER(FILE ADDR)
   %finish
   ASSEMBLE(OPCODE,L,FLAG)
   NEWLINES(2)
   PRINTSYMBOL('*')
   %if FLAG=0 %then PRINTSTRING("ASSEMBLY SUCCESSFUL") %else %start
      PRINTSTRING("ASSEMBLY FAILS")
      NEWLINE
      COMREG(24) = FLAG
      %monitor
      %stop; %finish
   DUMMY = 0
   LL = ADDR(OPCODE(0))
   PRINT STRING("
CODE "); WRITE(l,5); NEWLINE
      pinitialise(-1,0,addr(header))
      pcodebytes(l,ll)
      flag=pterminate(addr(fdi(1)),0)
      COMREG(24) = 0
   NEWLINES(2)
      %return
   %routine ASSEMBLE(%byte %integer %array %name S, %integer %name LENGTH,F)
      %integer NAMES,REFS,PROGMAX,NN
      NAMES = 1023
      REFS = 10000
      PROGMAX = LENGTH-65;               ! LEAVE 64 BYTE SAFTETY MARGIN
      %integer %array AD(0:NAMES+256)
      %string (8) %array NA(0:NAMES)
      %byte %integer %array LPOOL(0:1023),TCONST(0:256)
      %integer %array LPTR,LINF,LXTRA(0:127),ST,STTYPE(0:15)
      %integer %array A(1:REFS)
      %integer %array CC(1:161)
      %integer %array REG(0:15)
      %const %byte %integer %array L5(25:33)='T','G','T','G','T','E','T','T','E'
      %const %integer %array OPS(0:255)= %c
         M'TR',M'TDV',M'HDR',0,M'CLC',M'MVN',0,0,
         M'END',M'PC',M'SP',M'CP',M'STC',M'DROP',M'EDMK',M'SLDA',
         M'STAR',M'SLDL',M'TRT',M'HER',M'BNE',M'NR',M'LCDR',M'TITL',
         M'BALR',M'LPER',M'ALR',M'CDR',0,0,M'AWR',0,
         M'PACK',M'XC',M'LDR',0,M'DS',M'SD',M'BNM',M'CE',
         M'SDV',M'MP',M'DD',M'LNDR',M'BCR',0,M'SER',M'AW',
         M'NOP',M'ISK',M'XI',M'IC',0,0,M'MVI',0,
         M'BXLE',0,0,0,M'BR',0,M'SRA',0,
         M'LPR',M'A',M'B',M'C',M'D',0,0,0,
         M'SLR',M'XR',M'LD',M'BZR',M'L',M'M',M'BZ',M'O',
         M'N',M'BXH',M'SW',M'S',M'ST',M'STM',M'NI',M'SRDA',
         M'BCTR',M'DP',M'USIN',M'ORG',M'TM',M'SSK',M'BC',M'X',
         M'SSP',M'AH',M'AD',M'AER',M'LA',M'AL',M'OR',M'STD',
         M'CNOP',M'AP',M'NOPR',M'SRDL',M'ED',M'WRD',M'DE',M'LTDR',
         M'LR',M'SH',M'MVC',M'DSEC',M'DIG',M'SPAC',M'BO',M'SE',
         M'LH',M'PRIN',M'SPM',M'CKC',M'AUR',M'LER',M'SVC',M'CSEC',
         M'BNL',M'BNZ',M'NC',0,0,0,0,0,
         M'ADR',0,0,0,M'MVZ',M'MD',M'CR',M'CER',
         M'LNR',M'RDD',M'MER',M'SUR',M'LE',0,0,0,
         M'SDR',M'LTOR',0,0,0,M'AE',0,M'OI',
         M'LTR',0,0,0,0,0,0,M'SU',
         M'BH',M'DER',M'LNER',0,0,M'AU',M'SR',0,
         M'STH',M'BL',M'BNH',M'ZAP',M'STE',0,0,0,
         M'BP',M'SRL',M'SWR',0,M'SL',0,0,0,
         M'MH',M'EQU',M'MR',M'LCER',M'CVB',M'OC',0,M'CCW',
         M'BAL',M'CLR',M'LCR',0,M'SLA',0,M'EJEC',0,
         M'LSP',M'EX',0,0,0,0,0,0,
         M'UNPK',M'ME',0,0,0,0,0,0,
         M'SLL',M'HDV',M'BE',M'IDL',M'DC',M'DR',M'CD',M'DDR',
         M'BCT',M'LPDR',M'AR',M'MDR',M'CLI',M'BOR',0,0,
         M'CH',0,M'BM',0,M'LM',0,0,0,
         M'CVD',M'LTER',M'MVO',M'BNP',M'CL',0,0,0
      %const %byte %integer %array CODE(0:255)= %c
         X'DC',X'9D',X'24',0,X'D5',X'D1',0,0,
         0,X'82',X'FB',X'F9',X'42',0,X'DF',X'8F',
         0,X'8D',X'DD',X'34',7,X'14',X'23',0,
         X'05',X'30',X'1E',X'29',0,0,X'2E',0,
         X'F2',X'D7',X'28',0,0,X'6B',11,X'79',
         X'9C',X'FC',X'6D',X'21',X'07',0,X'3B',
         X'6E',0,X'09',X'97',X'43',0,0,X'92',
         0,X'87',0,0,0,X'F0',0,X'8A',
         0,X'10',X'5A',15,X'59',X'5D',0,0,0,
         X'1F',X'17',X'68',X'80',X'58',X'5C',8,X'56',
         X'54',X'86',X'6F',X'5B',X'50',X'90',X'94',X'8E',
         X'06',X'FD',0,0,X'91',X'08',X'47',X'57',
         X'D0',X'4A',X'6A',X'3A',X'41',X'5E',X'16',X'60',
         0,X'FA',X'00',X'8C',X'DE',X'84',X'7D',X'22',
         X'18',X'4B',X'D2',0,X'83',0,1,X'7B',
         X'48',0,X'04',X'9F',X'3E',X'38',X'0A',0,
         11,7,X'D4',0,0,0,0,0,
         X'2A',0,0,0,X'D3',X'6C',X'19',X'39',
         X'11',X'85',X'3C',X'3F',X'78',0,0,0,
         X'2B',0,0,0,0,X'7A',0,X'96',
         X'12',0,0,0,0,0,0,X'7F',
         2,X'3D',X'31',0,0,X'7E',X'1B',0,
         X'40',4,13,X'F8',X'70',0,0,0,
         2,X'88',X'2F',0,X'5F',0,0,0,
         X'4C',0,X'1C',X'33',X'4F',X'D6',0,0,
         X'45',X'15',X'13',0,X'8B',0,0,0,
         X'D8',X'44',0,0,0,0,0,0,
         X'F3',X'7C',0,0,0,0,0,0,
         X'89',X'9E',8,X'80',0,X'1D',X'69',X'2D',
         X'46',X'20',X'1A',X'2C',X'95',X'10',0,0,
         X'49',0,4,0,X'98',0,0,0,
         X'4E',X'32',X'F1',13,X'55',0,0,0
      %const %byte %integer %array TYPE(0:255)= %c
         8,6,0,0,8,8,0,0,15,6,7,7,4,11,8,2,
         27,2,8,0,5,0,0,30,0,0,0,0,0,0,0,0,
         7,8,0,0,13,4,5,4,6,7,4,0,0,0,0,4,
         5,0,6,4,0,0,6,0,3,0,0,0,1,0,2,0,
         0,4,5,4,4,0,0,0,0,0,4,1,4,4,5,4,
         4,3,4,4,4,3,6,2,0,7,26,16,6,0,4,4,
         8,4,4,0,4,4,0,4,14,7,1,2,8,6,4,0,
         0,4,8,31,6,33,5,4,4,25,1,6,0,0,1,32,
         5,5,8,0,0,0,0,0,0,0,0,0,8,4,0,0,
         0,6,0,0,4,0,0,0,0,28,0,0,0,4,0,6,
         0,0,0,0,0,0,0,4,5,0,0,0,0,4,0,0,
         4,5,5,7,4,0,0,0,5,2,0,0,4,0,0,0,
         4,17,0,0,4,8,0,10,4,0,0,0,2,0,29,0,
         8,4,0,0,0,0,0,0,7,4,0,0,0,0,0,0,
         2,6,5,6,12,0,4,0,4,0,0,0,6,1,0,0,
         4,0,5,0,3,0,0,0,4,0,7,5,4,0,0,0
      %const %byte %integer %array ALLMNT(0:33)=2(10),8,1(23)

      %const %byte %integer %array ITOE(0:127)= %c
         0,0,0,0,0,0,0,0,
         0,0,X'15',0,0,0,0,0,
         0,0,0,0,0,0,0,0,
         0,0,0,0,0,0,0,0,
         X'40',X'5A',X'7F',X'7B',X'5B',X'6C',X'50',X'7D',
         X'4D',X'5D',X'5C',X'4E',X'6B',X'60',X'4B',X'61',
         X'F0',X'F1',X'F2',X'F3',X'F4',X'F5',X'F6',X'F7',
         X'F8',X'F9',X'7A',X'5E',X'4C',X'7E',X'6E',X'6F',
         X'7C',X'C1',X'C2',X'C3',X'C4',X'C5',X'C6',X'C7',
         X'C8',X'C9',X'D1',X'D2',X'D3',X'D4',X'D5',X'D6',
         X'D7',X'D8',X'D9',X'E2',X'E3',X'E4',X'E5',X'E6',
         X'E7',X'E8',X'E9',X'4D',X'5F',X'5D',X'6A',X'6D',
         X'7C',X'C1',X'C2',X'C3',X'C4',X'C5',X'C6',X'C7',
         X'C8',X'C9',X'D1',X'D2',X'D3',X'D4',X'D5',X'D6',
         X'D7',X'D8',X'D9',X'E2',X'E3',X'E4',X'E5',X'E6',
         X'E7',X'E8',X'E9',X'40',X'40',X'40',X'40',X'FF'
      %const %byte %integer %array AL(1:4)=11,10,6,6;
      %integer %fn %spec GETN(%integer MAX)
      %integer %fn %spec EVAL EXP(%integer MODE)
      %integer %fn %spec GET NAME
      %integer %fn %spec LITERAL
      %routine %spec SET BYTE(%integer AT)
      %routine %spec EXPRSN(%integer %name VALUE,DEFINED)
      %routine %spec FAULT(%integer ERR)
      %integer %fn %spec DXB
      %integer %fn %spec DLB(%integer MAX,HALF,AT)
      %integer %fn %spec GETL(%integer MAX,HALF,AT)
      %routine %spec ASSERROR(%integer ERR)
      %routine %spec NEXT LINE
      %routine %spec RELOCERR(%integer ERR,AT)
      %routine %spec LITERAL POOL
      %routine %spec GET DB
      %routine %spec END OF DSECT
      %routine %spec GET EXPR
      %routine %spec ADDRESS CONST
      %routine %spec PRINT BRS
      %integer %fn %spec TESTOP(%integer OP)
      %integer %fn %spec GET REG(%integer HALF,SP)
      %routine %spec ALL(%integer I,J)
      %routine %spec SET 12 BITS(%integer AT)
      %routine %spec DUMPA(%integer N,VAL)
      %routine %spec DUMPS
      %routine %spec WRITE HEX(%integer N)
      %routine %spec SORT(%integer A,B)
      %routine %spec CONST
      %integer LINDEX,LNUM,LSPACE,CONSTL,CONSTALL
      %integer G,H,I,J,K,L,M,N,STMNT TYPE,OPCODE
      %integer Q,BA,AP,SP,PR,EN,DORGMAX
      %integer OSP,DSECT,DSECTN,DBASE,DSP,CSECT,ORGMAX,STPTR
      %switch SW(0:33),ASW(0:21)
      LINDEX = 0; LNUM = NAMES+1; LSPACE = 0
      DSECT = 0; DSECTN = 0; CSECT = 0
      ORGMAX = -1; STPTR = 0; NN = 0
      %cycle I = 1,1,72
         CC(I) = 0
      %repeat
      K = ADDR(S(PROGMAX))
      I = ADDR(S(0))
      %while I<=K %cycle
         INTEGER(I) = 0
         I = I+4
      %repeat
      %cycle I = 0,1,NAMES
         NA(I) = ""; AD(I) = -1
      %repeat
      BA = 0; AP = 1; SP = 0
      F = 0; PR = 1; EN = -1
      OSP = 0
!
! OBTAIN A LINE FOR EXAMINATION EITHER VIA READ SYMBOL OR DIRECTLY
!
L11:  NEXT LINE
!
! DEAL WITH COMMENTS WHICH HAVE '*' IN COLUMN ONE AND ALSO OUTPUT
! FROM A PREPOCESSOR WHICH HAS '!' TO MARK OF LINES WHICH HAVE
! BEEN EXPANDED
!
      %if CC(1)='*' %or CC(1)='!' %then %start
         ->L11 %if PR=0;                 ! PRINT OFF SPECIFIED
         %if CC(1)='!' %then CC(1) = ' ' %and K = 22 %else K = 23
         SPACES(K)
         ->L203
      %finish
!
! OBTAIN THE NAME FROM COLUMNS 1-8 AND STORE IT IN H
!
      G = 0; H = -1; Q = 1
      ->L12 %if CC(1)=' ';               ! NO NAME ON THIS STMNT
      ->L90 %unless 'A'<=CC(1)<='Z'
      H = GET NAME
      G = 2 %unless AD(H)<0;             ! NAME ALREADY KNOWN !
      ->L90 %unless CC(Q)=' '
L12:  %until M#' ' %cycle;               ! SKIP TO OPERN FIELD
         Q = Q+1
         M = CC(Q)
      %repeat
!
! OBTAIN THE MNEMONIC AND STORE IN 'L' WORKING OUT A HASH VALUE IN 'M'
!
      L = M; N = 24; Q = Q+1
      %until N=0 %cycle
         I = CC(Q)
         %exit %unless 'A'<=I<='Z'
         M = M*I+N; N = N-8
         L = L<<8!I; Q = Q+1
      %repeat
!
! SEARCH FOR THE MNEMONIC IN THE LIST
!
      %cycle I = M,1,M+255
         N = I&255
         %if OPS(N)=L %then ->L30
      %repeat
      ->L90;                             ! INVALID MNEMONIC
L30:  STMNT TYPE = TYPE(N)
      I = STMNT TYPE
      %if I>=25 %then %start;            ! FIVE LETTER CODES
         ->L90 %unless CC(Q)=L5(I)
         Q = Q+1
      %finish
      %if CC(Q)#' ' %and (I<=14 %or 17<=I<=26) %then ->L90
      Q = Q+1 %while CC(Q)=' '
      ALL(0,ALLMNT(STMNT TYPE))
      %if I<10 %then %start;             ! INSTRUCTION
         OPCODE = CODE(N)
         S(SP) = OPCODE
         SP = SP+1
         %if 2<=I<=4 %or I=0 %then %start; ! RR,RX,RS FORM
            J = GET REG(0,SP)
            ->L90 %unless CC(Q)=','
            Q = Q+1
         %finish
      %finish
      ->SW(STMNT TYPE)
!
SW(0):                                   ! RR
      S(SP) = J<<4!GET REG(1,SP)
      ->L92
SW(1):                                   ! RRS ONE OPERAND RR INSTRNS
      %if OPCODE=X'0A' %then S(SP) = GETN(255) %else %start
         %if OPCODE=X'04' %then S(SP) = GET REG(0,SP)<<4 %else %start
            S(SP) = OPCODE!GET REG(1,SP)
            S(OSP) = 7
         %finish
      %finish
      ->L92
SW(2):                                   ! RS
      S(SP) = J<<4
      SP = SP+1
      ->L40
SW(3):                                   ! RSS
      S(SP) = J<<4!GET REG(1,SP)
      SP = SP+1
      ->L41
SW(5):                                   ! RXS
      J = OPCODE
      S(OSP) = X'47'
SW(4):                                   ! RX
      SP = SP+1
      S(OSP+1) = J<<4!DXB
      ->L91
SW(6):                                   ! SI
      SP = SP+1
      GET DB
      %if CC(Q)=',' %then %start
         Q = Q+1
         SET BYTE(OSP+1)
      %finish %else S(OSP+1) = 0
      ->L91
SW(7):                                   ! SS
      SP = SP+1
      L = DLB(16,0,OSP+1)
      ->L90 %unless CC(Q)=','
      Q = Q+1
      M = DLB(16,1,OSP+1)
      S(OSP+1) = L<<4!M
      ->L91
SW(8):                                   ! SSS
      SP = SP+1
      L = DLB(256,0,OSP+1)
      S(OSP+1) = L
L41:  ->L90 %unless CC(Q)=','
      Q = Q+1
L40:  GET DB
      ->L91
SW(10):                                  ! CCW
      SET BYTE(SP)
      SP = SP+1
      ->L90 %unless CC(Q)=','
      Q = Q+1
      GET EXPR
      DUMPA(6,SP+BA)
      SP = SP+3
      ->L90 %unless CC(Q)=','
      Q = Q+1
      SET BYTE(SP)
      S(SP+1) = 0
      SP = SP+2
      ->L90 %unless CC(Q)=','
      Q = Q+1
      GET EXPR
      DUMPA(10,SP+BA)
      SP = SP+2
      ->L91
SW(11):                                  ! DROP
      %cycle
         DUMPA(16,X'FFFFFF');            ! XFFFFFF TO TOP OF STACK
         GET EXPR;                       ! REGISTER NO
         DUMPA(5,0);                     ! AND TO APPROPIATE REGISTER
         %exit %if CC(Q)#','
         Q = Q+1
      %repeat
      ->L91
SW(12):                                  ! DC
      I = CC(Q)
      %if '0'<=I<='9' %then N = GETN(X'FFFF') %else N = 1
      I = CC(Q)
      %if I='A' %or I='Y' %or I='S' %then ->ACONST
      CONST;                             ! EVALUATE CONST TO TCONST
      ->L90 %if CONSTL=0;                ! NO CONST FOUND
      ALL(0,CONSTALL);                   ! ALLIGN AS REQUIRED
      %if N=0 %then ->L91;               ! ZERO REPITIONS
      %cycle I = 1,1,N;                  ! OUTPUT N COPIES
         %cycle J = 0,1,CONSTL-1;        ! OF THE CONSTANT
            S(SP) = TCONST(J); SP = SP+1
         %repeat;
         DUMPS;                          ! CHECK STILL SPACE
      %repeat; ->L91
ACONST:                                  ! ADDRESS CONSTANTS
      ADDRESS CONST
      ->L90 %if CONSTL=0
      ALL(0,CONSTALL)
      %if I='S' %then K = 4 %else K = AL(CONSTL)
      %while N>0 %cycle
         %if N#1 %then DUMPA(14,0);      ! DUPLICATE
         I = SP+BA
         %if CONSTL=4 %then S(SP) = 0 %and I = I+1; ! TREAT 4 BYTE AS 3 BYTE
         DUMPA(K,I)
         SP = SP+CONSTL
         N = N-1
      %repeat
      ->L91
SW(13):                                  ! DS
      K = 0
      %if '0'<=CC(Q)<='9' %then N = GETN(X'FFFF') %else N = 1
      %if CC(Q)='D' %then K = 8
      %if CC(Q)='H' %then K = 2
      %if CC(Q)='B' %or CC(Q)='C' %then K = 1
      %if CC(Q)='F' %then K = 4
      %if K=0 %then FAULT(1) %else %start
         ALL(0,K);                       ! ALLIGN
         Q = Q+1
         SP = SP+K*N
         DUMPS
      %finish
      ->L91
SW(14):                                  ! CNOP
      I = GETN(6)
      FAULT(3) %unless I&1=0
      ->L90 %unless CC(Q)=','
      Q = Q+1
      J = GETN(8)
      FAULT(3) %unless J&1=0 %and J\=0
      %if G=0 %then %start;              ! NO ERRORS
         K = SP
         ALL(I,J)
         %if K&1=1 %then K = K+1
         S(K) = 7 %and K = K+2 %while K#SP
      %finish
      ->L91
SW(15):                                  ! END
      END OF DSECT
      LITERAL POOL
      EN = NAMES+1
      EN = GET NAME %if 'A'<=CC(Q)<='Z'
      ->L91
SW(16):                                  ! ORG
      %if CC(Q)=NL %then I = ORGMAX %else I = EVAL EXP(4)-BA-X'1000000'
      %if I<SP %then %start;             ! BACKWARDS ORG
         ORGMAX = SP %if SP>ORGMAX
         %if I<0 %then FAULT(4) %else SP = I
      %finish %else %start;              ! FORWARD ORG
         %if I>=PROGMAX %then FAULT(4) %else SP = I
      %finish
      ->L91
SW(17):                                  ! EQU
      ->L90 %if H<0
      AD(H) = EVAL EXP(5); ->L91
SW(25):                                  ! PRINT
      ->L90 %unless CC(Q)='O'
      Q = Q+1
      %if CC(Q)='F'=CC(Q+1) %then PR = 0 %and Q = Q+2 %and ->L91
      ->L90 %unless CC(Q)='N'
      Q = Q+1
      PR = 1
      ->L11 %unless ' '#CC(Q)#NL
      ->L93
SW(26):                                  ! USING
      GET EXPR
      ->L90 %unless CC(Q)=','
L81:  Q = Q+1
      DUMPA(14,0);                       !DUPLICATE
      GET EXPR
      DUMPA(5,0)
      %unless CC(Q)=',' %then DUMPA(21,0) %and ->L 91
      DUMPA(16,4096);                    ! AND 4096 TO STACK TOP
      DUMPA(17,0);                       ! ADD THE TWO TOGETHER
      ->L81
SW(27):                                  ! START
      END OF DSECT
      ->L90 %unless CSECT=0
      %if CC(Q)#NL %then BA = 8*((GETN(X'FFFFFF')+7)//8)
      AD(H) = BA+X'1000000' %unless H<0
      ->L91
SW(28):                                  ! LTORG
      LITERAL POOL
      ->L91
SW(30):                                  ! TITLE
      NEWPAGE %if PR#0; ->L93
SW(29):                                  ! EJECT
      NEWPAGE %if PR#0; ->L91
SW(31):                                  ! DSECT
      ENDOFDSECT
      DSECT = 1
      DSECTN = DSECTN+1
      DBASE = BA
      DORGMAX = ORGMAX
      DSP = SP
      BA = DSECTN<<16-(SP+7)&(-8)
      ALL(0,8)
      ->L91
SW(32):                                  ! CSECT
      END OF DSECT
      CSECT = CSECT+1
      ALL(0,1)
      ->L91
SW(33):                                  ! SPACE
      %if CC(Q)=NL %then N = 1 %else N = GETN(255)
      NEWLINES(N); ->L91
L92:  SP = SP+1
L91:  ->L93 %unless ' '\=CC(Q)\=NL
L90:  FAULT(1)
L93:  DUMPS
      ->L11 %if PR=0 %and EN<0
      %if G=0 %then SPACES(9) %else ASS ERROR(G)
      WRITE HEX(OSP+BA)
      SPACES(6)
L203: I = 1
      %until I=74 %or J=NL %cycle
         J = CC(I)
         PRINT SYMBOL(J)
         I = I+1
      %repeat
      ->L11 %if EN<0;                    ! LAST STMNT NOT 'END'
!
! NOW EVALUATE THE STACK OF OPERATIONS THAT COULD NOT BE COMPLETED
! ON THE FIRST PASS BECAUSE OF SYMBOLS NOT YET DEFINED
! AND ALSO WORK OUT ALL THE BASE REGISTER COVERAGE
!
      I = BA
      %if EN<=NAMES %then I = AD(EN)
      EN = I
      REG(0) = 0
      %cycle I = 1,1,15
         REG(I) = X'FFFFFF'
      %repeat
      I = 0
L221: I = I+1
      %if I=AP %then ->L220
      K = A(I)
      L = K&X'3FFFFFF'
      ->ASW(K>>26)
ASW(7):                                  ! SET ADDRESS IN BASE REGISTER
      %if L>=16 %then L = AD(L-16)
      %if L<0 %or L>15 %then RELOC ERR(2,0) %else ST(STPTR) = REG(L)
      STPTR = STPTR+1
      ->L221
ASW(8):                                  ! SET REG IN TOP 4 BITS
      %if 0<=ST(STPTR)<=15 %then L = L-BA %and S(L) = ST(STPTR)<<4!S(L) %else %c
         RELOCERR(1,L)
      STPTR = STPTR-1
      ->L221
ASW(9):                                  ! SET REG IN BOTTOM 4 BITS
      %if 0<=ST(STPTR)<=15 %then L = L-BA %and S(L) = S(L)!ST(STPTR) %else %c
         RELOCERR(1,L)
      STPTR = STPTR-1
      ->L221
ASW(4):                                  ! FIND BASE REGISTER
      M = 0
      %if ST(STPTR)>>24#0 %start;        ! RELOCATABLE EXPRSN
         ST(STPTR) = ST(STPTR)&X'FFFFFF'
         %cycle N = 1,1,15
            %if ST(STPTR)>=REG(N) %and REG(N)>=REG(M) %then M = N
         %repeat
      %finish
      N = ST(STPTR)-REG(M)
      %if N>4095 %then RELOC ERR(3,L) %else %start
         L = L-BA
         S(L) = M<<4!N>>8&15
         S(L+1) <- N
      %finish
      STPTR = STPTR-1
      ->L221
ASW(5):                                  ! USING - SET VALUE IN REG
                                         ! STACK TOP HAS REGISTER
                                         ! STACK NEXT HAS VALUE
      L = ST(STPTR)
      STPTR = STPTR-1
      %unless 0<=L<=15 %then RELOC ERR(2,0) %else %start
         REG(L) = ST(STPTR)&X'FFFFFF' %unless L=0
      %finish
      STPTR = STPTR-1
      ->L221
ASW(6):                                  ! STORE RESULT OF CALCULATION
                                         ! INTO THREE BYTES
      M = ST(STPTR)>>24
      %if M#0 %then %start
         %if M=1 %then RELOC ERR(5,L) %else RELOC ERR(4,L)
      %finish
      L = L-BA
      S(L) <- ST(STPTR)>>16
      S(L+1) <- ST(STPTR)>>8
      S(L+2) <- ST(STPTR)
      STPTR = STPTR-1
      ->L221
ASW(10):                                 ! STORE RESULT INTO HALFWORD
      %if ST(STPTR)#HALFINTEGER(ADDR(ST(STPTR))+2) %then RELOCERR(4,L)
      L = L-BA
      S(L) <- ST(STPTR)>>8
      S(L+1) <- ST(STPTR)
      STPTR = STPTR-1
      ->L221
ASW(11):                                 ! STORE RESULT INTO BYTE
      %if ST(STPTR)&X'FFFFFF00'#0 %then RELOCERR(4,L)
      L = L-BA
      S(L) <- ST(STPTR)
      STPTR = STPTR-1
      ->L221
ASW(12):                                 ! STORE RESULT INTO 12 BITS
      %if ST(STPTR)&X'FFFFF000'#0 %then RELOC ERR(4,L)
      L = L-BA
      S(L) = S(L)&X'F0'!ST(STPTR)>>8
      S(L+1) <- ST(STPTR)
      STPTR = STPTR-1
      ->L221
ASW(13):                                 ! DECREMENT IF NOT ZERO
      %if ST(STPTR)#0 %then ST(STPTR) = ST(STPTR)-1
      ->L221
ASW(14):                                 ! DUPLICATE STACK TOP
      ST(STPTR+1) = ST(STPTR)
      STPTR = STPTR+1
      ->L221
ASW(15):                                 ! STACK NAME
      STPTR = STPTR+1
      ST(STPTR) = AD(L)
      ->L221
ASW(16):                                 ! STACK VALUE
      STPTR = STPTR+1
      ST(STPTR) = L
      ->L221
ASW(17):                                 ! '+'
      STPTR = STPTR-1
      ST(STPTR) = ST(STPTR)+ST(STPTR+1)
      ->L221
ASW(18):                                 ! '-'
      STPTR = STPTR-1
      ST(STPTR) = ST(STPTR)-ST(STPTR+1)
      ->L221
ASW(19):                                 ! '*'
      STPTR = STPTR-1
      ST(STPTR) = ST(STPTR)*ST(STPTR+1)
      ->L221
ASW(20):                                 ! '/'
      STPTR = STPTR-1
      ST(STPTR) = ST(STPTR)//ST(STPTR+1)
      ->L221
ASW(21):
      STPTR = STPTR-1
      ->L 221
!
! COLLAPSE THE HASHED DICTIONARY PRIOR TO SORTING INTO ALAPHABETIC ORDER
!
L220:
      %return %if NN=0
      M = NN
      %cycle N = 0,1,NN-1
         %if NA(N)="" %then %start;      ! HOLE TO BE FILLED
            M = M+1 %while NA(M)=""
            NA(N) = NA(M)
            AD(N) = AD(M)
            M = M+1
         %finish
      %repeat
      M = NN-1
      SORT(0,M)
!
!
! PRINT OUT A TABLE OF NAMES DEFINED AND VALUES
!
      I = 0
      %while I<=M %cycle
         %if I&3=0 %then NEWLINE
         PRINT STRING(NA(I))
         %if AD(I)<0 %then %start
            PRINT STRING(" NOT SET")
            F = 1
         %finish %else WRITE HEX(AD(I)&X'FFFFFF')
         %if AD(I)>>24=0 %then PRINTSTRING("*") %else SPACE
         SPACES(7)
         I = I+1
      %repeat
      LENGTH = (SP+7)&(-8)
      %return
!
      %routine ALL(%integer I,J)
                                         !%shortroutine
         %integer K
         K = J*(SP//J)+I
         %if K<SP %then K = K+J
         SP = K
         AD(H) = SP+BA+X'1000000' %unless H<0
         OSP = SP
      %end
      %integer %fn GETN(%integer MAX)
                                         !%shortroutine
!***********************************************************************
!*       OBTAIN AN INTEGER CONSTANT                                    *
!*       ALSO ACCEPTS HEX AND CHARACTER CONSTANTS                      *
!*       MAX IS THE MAXIMUM ALLOWABLE SIZE                             *
!***********************************************************************
         %integer I,J,K
         J = CC(Q)
         ->SYMBOLIC %if 'A'<=J<='Z' %and CC(Q+1)=M''''
         ->NOT VALID %unless '0'<=J<='9'
         J = 0
         %cycle
            I = CC(Q)
            %exit %unless '0'<=I<='9'
            J = 10*J+I-'0'
            Q = Q+1
         %repeat
L2:      %unless 0<=J<=MAX %then FAULT(3) %and J = 0
         %result = J
SYMBOLIC: ->HEX %if J='X'
         ->NOT VALID %unless J='C' %or J='M'
         CONST;                          ! EVALUATE CONST
         ->NOT VALID %unless 0#CONSTL<=4
         J = 0
         %cycle I = 0,1,CONSTL-1;        ! COLLECT THE CONSTANT
            BYTEINTEGER(ADDR(J)+4-CONSTL+I) = TCONST(I)
         %repeat
         ->L2
HEX:     J = 0; Q = Q+2
         %cycle K = 1,1,8
            I = CC(Q)
            %exit %unless '0'<=I<='9' %or 'A'<=I<='F'
            %if I>='A' %then I = I+9
            J = J<<4!I&15
            Q = Q+1
         %repeat
         %if CC(Q)='''' %then Q = Q+1 %and ->L2
NOT VALID: FAULT(1)
         %result = 0
      %end
      %integer %fn GET NAME
!%shortroutine
         %integer I,L,M,N
         %string (8) NEWNAME
         NEWNAME = "        "
         M = CC(Q)
         N = 1
         Q = Q+1
         BYTE INTEGER(ADDR(NEWNAME)+1) = M
         %if M='=' %then %result = LITERAL
         %until N=8 %cycle
            I = CC(Q)
            %exit %unless 'A'<=I<='Z' %or '0'<=I<='9' %or I='#'
            M = M*I&X'FFFF'
            N = N+1
            BYTE INTEGER(ADDR(NEWNAME)+N) = I
            Q = Q+1
         %repeat
         %cycle I = M,1,M+NAMES
            L = I&NAMES
            %if NA(L)="" %then NA(L) = NEWNAME %and NN = NN+1 %and %result = L
            %if NA(L)=NEWNAME %then %result = L
         %repeat
         PRINT STRING("
TOO MANY NAMES")
         %stop
      %end
      %integer %fn GET REG(%integer HALF,SP)
                                         !%shortroutine
!***********************************************************************
!*         HALF=0 FOR TOP HALF,=1 FOR BOTTOM HALF                      *
!***********************************************************************
         %integer I,J
         I = 1; J = 1
         EXPRSN(I,J)
         %if J=1 %then %start;           ! EVALUATED TO I
            FAULT(3) %unless 0<=I<=15
            %result = I&15
         %finish
                                         ! EXPRN CANT BE EVALUATED YET
         DUMPA(HALF+8,SP);               ! STORE RESULT OF EVALUATION
         %result = 0
      %end
      %routine GET DB
!***********************************************************************
!*       DEAL WITH OPERAND OF DB FORMAT                                *
!*       ALLOWED FORMATS ARE:-                                         *
!*       <NAME>   OR <D>'('<B>')'  ONLY                                *
!***********************************************************************
                                         !%shortroutine
         %integer I,J
         I = Q
         %until J=' ' %or J=',' %or J=NL %cycle
            J = CC(I)
            %if J='(' %and I>Q %and TESTOP(CC(I-1))=0 %then ->EXPLCT
            I = I+1
         %repeat
         GET EXPR
         DUMPA(4,SP+BA)
         ->L4
EXPLCT:  SET 12 BITS(SP)
         FAULT(1) %unless CC(Q)='('
         J = GET REG(0,SP)
         S(SP) = S(SP)&X'F'!J<<4
L4:      SP = SP+2
      %end
      %integer %fn DXB
                                         !%shortroutine
!***********************************************************************
!*       DEAL WITH DXB FORMAT OPERANDS                                 *
!*       THE DB PART IS PLANTED INTO THE CURRENT HALFWORD AND X IS     *
!*       RETURNED AS THE RESULT. IF X DOES NOT EVALUATED IT IS ADDED   *
!*       LATER INTO THE PREVIOUS BYTE.                                 *
!*       THE FORMATS ALLOWED ARE:-                                     *
!*       <NAME>                                                        *
!*       <NAME>'('<X>')'                                               *
!*       <D>'('<X>','<B>')'                                            *
!***********************************************************************
         %integer I,J,K,BR
!
! DETERMINE THE FORMAT BY A PRESCAN
!
         I = Q; BR = 0
         %until J=' ' %or J=NL %cycle
            J = CC(I)
            %if J='(' %then BR = BR+1
            %if J=')' %then BR = BR-1
            %if J=',' %and BR=1 %then ->EXPLICIT
            I = I+1
         %repeat
!
! SOME SYMBOLIC FORMAT
!
         GET EXPR
         DUMPA(4,SP+BA);                 ! SET BR AND STORE DB
         %if CC(Q)='(' %then I = GET REG(1,SP-1) %else I = 0
         ->L9
EXPLICIT: SET 12 BITS(SP)
         FAULT(1) %unless CC(Q)='('
         Q = Q+1
         I = GETREG(1,SP-1);             ! INDEX
         FAULT(1) %unless CC(Q)=','
         Q = Q+1
         K = GET REG(0,SP);              ! BASE
         FAULT(1) %unless CC(Q)=')'
         Q = Q+1
         S(SP) = S(SP)&15!K<<4
L9:      SP = SP+2
         %result = I
      %end
      %integer %fn GETL(%integer MAX,HALF,AT)
                                         !%shortroutine
!***********************************************************************
!*       DEAL WITH THE LENGTH TERM IN DLB FORMAT INSTRUCTIONS          *
!***********************************************************************
         %integer I,J
         I = 1; J = 1
         EXPRSN(I,J)
         %if J=1 %then %start;           ! EVALUATED TO A CONST
            FAULT(3) %unless 0<=I<=MAX
            I = I-1 %unless I=0
         %finish %else %start
            DUMPA(13,0);                 ! TAKE ONE OFF UNLESS ZERO
            %if MAX=256 %then J = 11 %else J = HALF+8
            DUMPA(J,AT)
            I = 0
         %finish
         %result = I
      %end
      %integer %fn DLB(%integer MAX,HALF,AT)
                                         !%shortroutine
!***********************************************************************
!*       DEAL WITH DLB FORMAT OPERANDS                                 *
!*       THE DB PART IS PLANTED INTO THE CURRENT HALFWORD AND L IS     *
!*       RETURNED AS THE RESULT. IF L DOES NOT EVALUATED IT IS ADDED   *
!*       LATER INTO THE HALF BYTE OR BYTE SPECIFIED.                   *
!*       THE FORMATS ALLOWED ARE:-                                     *
!*       <NAME>'('<L>')'                                               *
!*       <D>'('<L>','<B>')'                                            *
!***********************************************************************
         %integer I,J,K,BR
!
! DETERMINE THE FORMAT BY A PRESCAN
!
         I = Q; BR = 0
         %until J=' ' %or J=',' %or J=NL %cycle
            J = CC(I)
            %if J='(' %then BR = BR+1
            %if J=')' %then BR = BR-1
            %if J=',' %and BR=1 %then ->EXPLICIT
            I = I+1
         %repeat
!
! SOME SYMBOLIC FORMAT
!
         GET EXPR
         DUMPA(4,SP+BA);                 ! SET BR AND STORE DB
         %if CC(Q)#'(' %then FAULT(1) %else %start
            Q = Q+1
            I = GETL(MAX,HALF,AT)
            FAULT(1) %unless CC(Q)=')'
            Q = Q+1
         %finish
         ->L9
EXPLICIT: SET 12 BITS(SP)
         FAULT(1) %unless CC(Q)='('
         Q = Q+1
         I = GETL(MAX,HALF,AT);          ! LENGTH
         FAULT(1) %unless CC(Q)=','
         Q = Q+1
         K = GET REG(0,SP);              ! BASE
         FAULT(1) %unless CC(Q)=')'
         Q = Q+1
         S(SP) = S(SP)&15!K<<4
L9:      SP = SP+2
         %result = I
      %end
      %routine EXPRSN(%integer %name VALUE,DEFINED)
                                         !%shortroutine
!***********************************************************************
!*       DEFINED=0 IF MUST BE EVALUATED LATER                          *
!*       DEFINED=1 IF EVALUATED TO VALUE                               *
!***********************************************************************
         %routine %spec STORE OP(%integer N)
         %routine %spec OPERAND(%integer %name VALUE,DEFINED)
         %routine %spec TORP
         %integer V,D,EVALABLE,J,SSP,OPPREC
         EVALABLE = 1
         SSP = STPTR
!
         TORP;                           ! EXPRESSION TO REVERSE POLISH
!
         %if EVALABLE#0 %and DEFINED#0 %then %start
            STPTR = STPTR-1
            VALUE = ST(STPTR)
            DEFINED = 1
            %monitor %and %stop %unless SSP=STPTR
            %return
         %finish
!
! ARRANGE TO EVALUATE LATER
!
         %cycle J = SSP,1,STPTR-1
            DUMPA(STTYPE(J),ST(J))
         %repeat
         STPTR = SSP
         DEFINED = 0
         %return
         %routine TORP
            %integer OPCODE,OPPTR
            %integer %array OPS(0:3)
            OPPTR = 0; OPS(OPPTR) = 0
NEXT OPERAND:                            ! GET AN OPERAND
            %if CC(Q)='(' %then %start;  ! SUBEXPRESSION
               Q = Q+1
               TORP
               FAULT(1) %unless CC(Q)=')'
               Q = Q+1
            %finish %else %start
               OPERAND(V,D)
               ST(STPTR) = V
               STTYPE(STPTR) = D+15
               STPTR = STPTR+1
            %finish
            EVALABLE = EVALABLE*D;       ! FIRST ZERO MAKES NONEVALABLE
!
! TEST FOR OPERATOR AND DEAL WITH IT
!
            J = CC(Q)
            ->END OF EXP %unless TESTOP(J)#0
            Q = Q+1
            OPCODE = 3
            %if J='+' %then OPCODE = 0
            %if J='-' %then OPCODE = 1
            %if J='*' %then OPCODE = 2
            OPPREC = OPCODE>>1+1
!
! EMPTY OPERATOR STACK UNTIL OPERATOR CAN BE STORED
!
            %while OPPREC<=OPS(OPPTR)>>16 %cycle
               STORE OP(OPS(OPPTR)&15)
               OPPTR = OPPTR-1
            %repeat
!
! NOW STORE THE OPERATOR
!
            OPPTR = OPPTR+1
            OPS(OPPTR) = OPPREC<<16!OPCODE
            ->NEXT OPERAND
!
END OF EXP:
            %while OPPTR>0 %cycle
               STORE OP(OPS(OPPTR)&15);  ! EMPTY REMAINING OPERATORS
               OPPTR = OPPTR-1
            %repeat
         %end
         %routine STORE OP(%integer OP)
            %switch EVAL(0:3)
            %unless 16=STTYPE(STPTR-1)=STTYPE(STPTR-2) %then %start
               ST(STPTR) = OP
               STTYPE(STPTR) = OP+17
               ->END
            %finish
            STPTR = STPTR-2
            ->EVAL(OP)
EVAL(0):                                 ! '+'
            ST(STPTR) = ST(STPTR)+ST(STPTR+1)
            ->END
EVAL(1):                                 ! '-'
            ST(STPTR) = ST(STPTR)-ST(STPTR+1)
            ->END
EVAL(2):                                 ! '*'
            ST(STPTR) = ST(STPTR)*ST(STPTR+1)
            ->END
EVAL(3):                                 ! '/'
            ST(STPTR) = ST(STPTR)//ST(STPTR+1)
            ->END
END:        STPTR = STPTR+1
         %end
         %routine OPERAND(%integer %name VALUE,DEFINED)
                                         !%shortroutine
!***********************************************************************
!*         DEFINED AS FOR EXPRSN                                       *
!***********************************************************************
            %integer I,J
            J = CC(Q)
            %if J='*' %then %start
               Q = Q+1
               VALUE = OSP+BA+X'1000000'
               DEFINED = 1
               %return
            %finish
!
            %if ('A'<=J<='Z' %and CC(Q+1)#'''') %or J='=' %start
               I = GETNAME
               %if AD(I)>=0 %then %start
                  DEFINED = 1
                  VALUE = AD(I)
               %finish %else %start
                  DEFINED = 0
                  VALUE = I
               %finish
               %return
            %finish
            VALUE = GETN(X'7FFFFFFF')
            DEFINED = 1
         %end
      %end
      %integer %fn TEST OP(%integer OP)
         %result = 1 %if OP='+' %or OP='-' %or OP='*' %or OP='/'
         %result = 0
      %end
      %routine SET BYTE(%integer AT)
                                         !%shortroutine
!***********************************************************************
!*       SET THE BYTE TO AN EXPRESSION                                 *
!*       EVALUATE NOW IF POSSIBLE TO SAVE STORING REFS                 *
!***********************************************************************
         %integer I,J
         I = 0; J = 1
         EXPRSN(I,J)
         %if J=1 %then %start
            S(AT) <- I
            FAULT(1) %if I&X'FFFFFF00'#0
         %finish %else %start
            S(AT) = 0
            DUMPA(11,AT+BA)
         %finish
      %end
      %routine SET 12 BITS(%integer AT)
                                         !%shortroutine
!***********************************************************************
!*       RAISON D'ETRE AS FOR SET BYTE                                 *
!***********************************************************************
         %integer I,J
         I = 0; J = 1
         EXPRSN(I,J)
         %if J=1 %start
            FAULT(1) %if I&X'FFFFF000'#0
            S(AT) = S(AT)&X'F0'!I>>8
            S(AT+1) <- I
         %finish %else DUMPA(12,AT+BA)
      %end
      %routine GET EXPR
                                         !%shortroutine
         %integer I,J
         I = 0; J = 0
         EXPRSN(I,J)
      %end
      %routine DUMPA(%integer N,VALUE)
                                         !%shortroutine
         %if DSECT=0 %or STMNT TYPE=11 %or STMNT TYPE=26 %start
            A(AP) = N<<26!X'3FFFFFF'&VALUE
            AP = AP+1
            %if AP>REFS %then F = 1 %and AP = 1 %and PRINT STRING("
TOO MANY REFS")
         %finish
      %end
      %routine DUMPS
                                         !%shortroutine
         %if SP>PROGMAX %then F = 1 %and SP = 0 %and PRINT STRING("
PROG TOO LONG")
      %end
      %routine WRITE HEX(%integer N)
                                         !%shortroutine
         %const %byte %integer %array H(0:15)='0','1','2','3','4','5','6',
            '7','8','9','A','B','C','D','E','F'
         %integer I,J,K
         I = 0
         %cycle J = 28,-4,0
            K = N>>J&15
            %if I=0=K %and J\=0 %then SPACE %else %start
               I = 1
               PRINT SYMBOL(H(K))
            %finish
         %repeat
      %end
      %routine SORT(%integer A,B)
                                         !%shortroutine
!***********************************************************************
!*       'QUICKSORT' TAKEN FROM THE IMP MANUAL                         *
!***********************************************************************
         %integer L,U
         %string (8) I
         %return %if A>=B
         L = A
         U = B
         I = NA(U)
         K = AD(U)
         ->L1
L2:      L = L+1
         ->L3 %if L=U
L1:      ->L2 %unless NA(L)>I
         NA(U) = NA(L)
         AD(U) = AD(L)
L4:      U = U-1
         ->L3 %if L=U
         ->L4 %unless NA(U)<I
         NA(L) = NA(U)
         AD(L) = AD(U)
         ->L2
L3:      NA(U) = I
         AD(U) = K
         SORT(A,L-1)
         SORT(U+1,B)
      %end
      %routine CONST
                                         !%shortroutine
!***********************************************************************
!*       OBTAIN A F:H:C:M:X CONSTANT AND PUT IN ARRAY TCONST           *
!*       SET UP CONSTALL(ALLIGNMENT) & CONSTL(LENGTH IN BYTES)         *
!***********************************************************************
         %integer I,J,K,SPECLENGTH,AD
         %routine %spec CONST SET
         %integer %fn %spec GET SIGN
         %long %real SIGN,WORK,SCALE
!
         CONSTL = 0; I = CC(Q)
         %if CC(Q+1)='L' %then %start
            Q = Q+2; SPECLENGTH = EVAL EXP(1)
            %if SPECLENGTH>256 %then %return
         %finish %else SPECLENGTH = 0 %and Q = Q+1
         ->L99 %unless CC(Q)=M''''
         Q = Q+1; CONSTALL = 8
         ->REALC %if I='D'
         CONSTALL = 4
         ->REALC %if I='E'
         ->FWORD %if I='F'
         CONSTALL = 2
         ->HWORD %if I='H'
         CONSTALL = 1
         ->HEX %if I='X'
         ->L99 %unless I='C' %or I='M'
CHAR:    J = CC(Q); Q = Q+1
         ->NOT QUOTE %unless J=M''''
         J = CC(Q); ->CEND %unless J=M''''
         Q = Q+1; ->TRANS
NOTQUOTE: %if J='\' %then J = 10
         %if J='_' %and I='M' %then J = 13
TRANS:   %if I='C' %then J = ITOE(J)
         TCONST(CONSTL) = J
         CONSTL = CONSTL+1; ->CHAR
CEND:    FAULT(3) %if CONSTL=0 %or CONSTL>256
         %if SPECLENGTH#0 %then %start
            FAULT(7) %if CONSTL>SPECLENGTH
            %if I='C' %then J = ITOE(' ') %else J = ' '
            %while CONSTL<SPECLENGTH %cycle
               TCONST(CONSTL) = J
               CONSTL = CONSTL+1
            %repeat
         %finish
         %return
HEX:     K = 0
         %cycle I = 1,1,2
            J = CC(Q); Q = Q+1
            ->HERR %unless '0'<=J<='9' %or 'A'<=J<='F'
            J = J-7 %if J>='A'
            K = K<<4!(J-'0')
         %repeat
         TCONST(CONSTL) = K
         CONSTL = CONSTL+1
         ->HEX %unless CC(Q)=M''''
         Q = Q+1
         %if SPECLENGTH#0 %then %start
            FAULT(7) %if CONSTL>SPECLENGTH
            K = SPECLENGTH-1
            %while K>=0 %cycle;          ! PAD TO SPECLENGTH AT LH END
               CONSTL = CONSTL-1
               %if CONSTL<0 %then J = 0 %else J = TCONST(CONSTL)
               TCONST(K) = J
               K = K-1
            %repeat
            CONSTL = SPECLENGTH
         %finish
         %return
HERR:    CONSTL = 0; %return
FWORD:   I = GETSIGN
         K = GETN(X'7FFFFFFF')*I
         ->HERR %unless CC(Q)=M''''
         Q = Q+1
PUTIN:   CONST SET
         AD = ADDR(K)+3
         J = 0
         %cycle I = CONSTL-1,-1,0
            TCONST(I) = BYTE INTEGER(AD)
            AD = AD-1
         %repeat
         %return
HWORD:   I = GETSIGN
         K = GETN(X'7FFF')*I
         ->HERR %unless CC(Q)=M''''
         Q = Q+1
         K = K&X'FFFF'
         ->PUTIN
REALC:   SIGN = GET SIGN
         WORK = 0
         %if CC(Q)#'.' %then WORK = GETN(X'7FFFFFFF')
         SCALE = 10
         %if CC(Q)#'.' %then ->EXP
AGAIN:   Q = Q+1; I = CC(Q)
         %if '0'<=I<='9' %then %start
            %if I#'0' %then WORK = WORK+(I&15)/SCALE
            SCALE = SCALE*10; ->AGAIN; %finish
EXP:     %if CC(Q)='E' %then %start
            Q = Q+1; I = GET SIGN
            I = I*GETN(76)
            WORK = WORK*10**I; %finish
         ->HERR %unless CC(Q)=''''
         Q = Q+1
         WORK = SIGN*WORK
         %if CONSTALL=4 %then INTEGER(ADDR(WORK)+4) = 0
         CONST SET
         %cycle I = 0,1,CONSTL-1
            TCONST(I) = BYTEINTEGER(ADDR(WORK)+I)
         %repeat
         %return
         %routine CONST SET
            %if SPECLENGTH#0 %then %start
               FAULT(7) %if SPECLENGTH>8
               CONSTALL = 1
               CONSTL = SPECLENGTH
            %finish %else CONSTL = CONSTALL
         %end
         %integer %fn GET SIGN
            %if CC(Q)='+' %then Q = Q+1
            %if CC(Q)#'-' %then %result = 1
            Q = Q+1; %result = -1
         %end
L99:  %end
      %integer %fn EVAL EXP(%integer MODE)
! EVALUATES AN EXPRESSION OF PREVIOUSLY DEFINED NAMES AND CONSTS
! MODE=4 FOR'ORG' AND MODE=5 FOR 'EQU'
                                         !%shortroutine
         %integer I,J
         I = 0; J = 1
         EXPRSN(I,J)
         %if J#1 %then FAULT(MODE)
         %result = I
      %end
      %integer %fn LITERAL
                                         !%shortroutine
         %integer I,J,WORK,XTRA
         %if CC(Q)='A' %then %start
            ADDRESS CONST
            XTRA = AP
            %if CONSTL=4 %then J = 1 %else J = 0
            DUMPA(AL(CONSTL),J);         ! DISPLACEMENT LATER
            %cycle I = 0,1,16
               TCONST(I) = 0
            %repeat
            WORK = 0
!           %monitor %if G#0
            ->PUTIN;                     ! CANNOT SHARE ADDRESS LITS
         %finish
         XTRA = -1
         CONST;                          ! GET THE CONST
         %if CONSTL=0 %then FAULT(6) %and %result = 0
         WORK = CONSTL<<8!CONSTALL
         I = 0
         %while I<LINDEX %cycle;         ! SEARCH TO SEE IF LITERAL IN POO
            J = LPTR(I)
            %if LINF(I)&X'FFFF'#WORK %then ->NEXT
            %cycle K = 0,1,CONSTL-1
               ->NEXT %unless TCONST(K)=LPOOL(J+K)
            %repeat
            %result = LINF(I)>>16
NEXT:       I = I+1
         %repeat
PUTIN:   LSPACE = (LSPACE+CONSTALL-1)&(-CONSTALL)
         LPTR(LINDEX) = LSPACE
         %cycle I = 0,1,CONSTL-1
            LPOOL(LSPACE) = TCONST(I)
            LSPACE = LSPACE+1
            %if LSPACE>1024 %then ->FULL
         %repeat
         LINF(LINDEX) = LNUM<<16!WORK
         LXTRA(LINDEX) = XTRA
         LINDEX = LINDEX+1
         %if LINDEX>127 %then ->FULL
         AD(LNUM) = -1; LNUM = LNUM+1
         %result = LNUM-1

FULL:    PRINT STRING("LITERAL POOL O/FLOW")
         %stop
      %end
      %routine END OF DSECT
                                         !%shortroutine
         %if DSECT=1 %then %start
            LITERAL POOL
            DSECT = 0
            BA = DBASE
            ORGMAX = DORGMAX
            SP = DSP
         %finish
      %end
      %routine ADDRESS CONST
                                         !%shortroutine
         %integer I,J,K,L,ALL
         I = CC(Q)
         %if I='Y' %or I='S' %then %start; ! Y CONSTANTS
            ALL = 2; L = 2
            Q = Q+1
         %finish %else %start
            ALL = 4; L = 4;              ! ALLIGNMENT & LENGTH
            Q = Q+1
            %if CC(Q)='L' %then %start;  ! LENGTH SPECIFIED
               ALL = 1; Q = Q+1
               L = GETN(4)
               FAULT(1) %if L=0
            %finish
         %finish
         FAULT(1) %unless CC(Q)='('
         K = 0;                          ! FORCE EVALUATION LATER
         EXPRSN(J,K);                    ! EVALUATE EXPR IN PARENS
         CONSTL = L; CONSTALL = ALL
      %end
      %routine LITERAL POOL
                                         !%shortroutine
         %integer I,J,K
         %return %if LINDEX=0 %or LSPACE=0
         ALL(0,8); K = SP+BA
         %cycle I = 0,1,LSPACE-1
            S(SP) = LPOOL(I)
            SP = SP+1
            DUMPS
         %repeat
         %cycle I = 0,1,LINDEX-1
            J = LXTRA(I)
            %if J>=0 %and DSECT=0 %then A(J) = A(J)+(K+LPTR(I))
            AD(LINF(I)>>16) = K+LPTR(I)+X'1000000'
         %repeat
         LSPACE = 0; LINDEX = 0
      %end
      %routine FAULT(%integer ERR)
         G = ERR
!         %monitor
      %end
      %routine ASS ERROR(%integer ERR)
         %const %string (9) %array MESS(1:7)="SYNTAX   ",
             "SAME NAME","INVALID N","ORG VALUE",
             "EQU VALUE","LITERAL ?","CNST SIZE"
         PRINTSTRING(MESS(ERR))
         F = 1
         %if ERR=1 %then OSP = SP
      %end
      %routine RELOC ERR(%integer ERR,AT)
         %const %string (20) %array MESS(1:5)="INVALID REGISTER",
            "INVALID 'USING'","NO BASE REGISTER",
            "TRUNCATION ERROR","RELOCATION REQUIRED"
         NEWLINE
         PRINTSTRING(MESS(ERR))
         %if ERR#2 %then PRINTSTRING(" AT ") %and WRITE HEX(AT)
         PRINT BRS %if ERR=3
         F = 1 %unless ERR>=4
      %end
      %routine PRINT BRS
         %integer I
         PRINTSTRING("   CURRENT BRS=")
         %cycle I = 0,1,15
            %if REG(I)#X'FFFFFF' %then WRITE(I,5) %and WRITEHEX(REG(I))
         %repeat
         NEWLINE
      %end
      %routine NEXT LINE
                                         !%shortroutine
!***********************************************************************
!*       OBTAIN THE NEXT LINE AND DISCARD BLANKS                       *
!***********************************************************************
         %integer I,J
         %if FILE ADDR=0 %then %start
            I = 1
            %until I=74 %or J=NL %cycle
               READ SYMBOL(J)
               CC(I) = J
               I = I+1
            %repeat
         %finish %else %start
            %monitor %if FILEPTR>FILE END
            I = 1
            %until J=NL %or J=0 %cycle
               J = BYTE INTEGER(FILE PTR)
               FILE PTR = FILE PTR+1
               CC(I) = J
               I = I+1
            %repeat
         %finish
         CC(73) = NL
         %if CC(1)=NL %then NEXT LINE
      %end;                              ! OF ROUTINE NEXT LINE
   %end
%end
%end %of %file