%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