%externalroutine icl9cezassemble %EXTERNALINTEGERMAPSPEC COMREG %ALIAS "S#COMREGMAP"(%INTEGER N) %EXTERNALROUTINESPEC IPUT %ALIAS "S#IPUT"(%INTEGER TYPE,LENGTH,LA,IA) %ROUTINESPEC ASSEMBLE(%BYTEINTEGERARRAYNAME S, %INTEGERNAME L,F) %INTEGER DUMMY,FLAG,FILE ADDR,FILE PTR,FILE END,L,LL %BYTEINTEGERARRAY OPCODE(0:32*1024) %OWNINTEGERARRAY FDI(0:5)=0,24,32,0,0,0 L=32000 %ownstring(63) hdr=" EMAS ASSEMBLER RELEASE 2 VERSION 23Sep85" NEWLINES(2); SPACES(15) PRINTSTRING(hdr) NEWLINES(4) FILE ADDR=COMREG(46) %IF FILE ADDR#0 %THENSTART 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") %ELSESTART PRINTSTRING("ASSEMBLY FAILS") NEWLINE COMREG(24)=FLAG %MONITOR %STOP; %FINISH DUMMY=0 LL=ADDR(OPCODE(0)) ! ! FILE MUST HAVE EMAS HEADER OF 4 WORDS PROVIDED BY USERS ! LAYOUT OF HEADER:- ! WORD 0 FILE LENGTH ! WORD 1 START OF CODE(REL START OF FILE) ! WORD 2 START OF GLA(REL TO DITTO) ! WORD 3 START OF LOAD DATA(REL TO DITTO) ! ALL AREAS MUST BE DOUBLE WORD ALLINED ! FDI(5)=L-32 FDI(0)=L PRINT STRING(" CODE "); WRITE(FDI(0),5); PRINT STRING(" GLAP "); WRITE(FDI(1),5); PRINT STRING(" LDATA"); WRITE(FDI(2),5); NEWLINE ! ! NOW CHECK HEADER FOR CONSISTENCY ! FLAG=FDI(0)!FDI(1)!FDI(2) %IF FLAG>0 %AND FLAG&7=0 %THENSTART IPUT(0,-1,0,ADDR(hdr)); ! OPEN FILE IPUT(1,FDI(0),0,LL); ! CODE IPUT(7,24,0,ADDR(FDI(0))); ! FILE DIRECTRY INFO COMREG(24)=0 %FINISHELSE PRINT STRING(" ERROR IN FILE HEADER BLOCK") %ANDMONITOR NEWLINES(2) %STOP %ROUTINE ASSEMBLE(%BYTEINTEGERARRAYNAME S, %INTEGERNAME LENGTH,F) %INTEGER NAMES,REFS,PROGMAX,NN NAMES=1023 REFS=10000 PROGMAX=LENGTH-65; ! LEAVE 64 BYTE SAFTETY MARGIN %INTEGERARRAY AD(0:NAMES+256) %STRING (8) %ARRAY NA(0:NAMES) %BYTEINTEGERARRAY LPOOL(0:1023),TCONST(0:256) %INTEGERARRAY LPTR,LINF,LXTRA(0:127),ST,STTYPE(0:15) %INTEGERARRAY A(1:REFS) %INTEGERARRAY CC(1:161) %INTEGERARRAY REG(0:15) %CONSTBYTEINTEGERARRAY L5(25:33)='T','G','T','G','T','E','T','T','E' %CONSTINTEGERARRAY 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 %CONSTBYTEINTEGERARRAY 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 %CONSTBYTEINTEGERARRAY 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 %CONSTBYTEINTEGERARRAY ALLMNT(0:33)=2(10),8,1(23); %CONSTBYTEINTEGERARRAY 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' %CONSTBYTEINTEGERARRAY AL(1:4)=11,10,6,6; %INTEGERFNSPEC GETN(%INTEGER MAX) %INTEGERFNSPEC EVAL EXP(%INTEGER MODE) %INTEGERFNSPEC GET NAME %INTEGERFNSPEC LITERAL %ROUTINESPEC SET BYTE(%INTEGER AT) %ROUTINESPEC EXPRSN(%INTEGERNAME VALUE,DEFINED) %ROUTINESPEC FAULT(%INTEGER ERR) %INTEGERFNSPEC DXB %INTEGERFNSPEC DLB(%INTEGER MAX,HALF,AT) %INTEGERFNSPEC GETL(%INTEGER MAX,HALF,AT) %ROUTINESPEC ASSERROR(%INTEGER ERR) %ROUTINESPEC NEXT LINE %ROUTINESPEC RELOCERR(%INTEGER ERR,AT) %ROUTINESPEC LITERAL POOL %ROUTINESPEC GET DB %ROUTINESPEC END OF DSECT %ROUTINESPEC GET EXPR %ROUTINESPEC ADDRESS CONST %ROUTINESPEC PRINT BRS %INTEGERFNSPEC TESTOP(%INTEGER OP) %INTEGERFNSPEC GET REG(%INTEGER HALF,SP) %ROUTINESPEC ALL(%INTEGER I,J) %ROUTINESPEC SET 12 BITS(%INTEGER AT) %ROUTINESPEC DUMPA(%INTEGER N,VAL) %ROUTINESPEC DUMPS %ROUTINESPEC WRITE HEX(%INTEGER N) %ROUTINESPEC SORT(%INTEGER A,B) %ROUTINESPEC 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)='!' %THENSTART ->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) %EXITUNLESS '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 %THENSTART; ! 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 %THENSTART; ! INSTRUCTION OPCODE=CODE(N) S(SP)=OPCODE SP=SP+1 %IF 2<=I<=4 %OR I=0 %THENSTART; ! 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) %ELSESTART %IF OPCODE=X'04' %THEN S(SP)=GET REG(0,SP)<<4 %ELSESTART 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)=',' %THENSTART Q=Q+1 SET BYTE(OSP+1) %FINISHELSE 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 %EXITIF 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) %ELSESTART 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 %THENSTART; ! 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 IORGMAX %IF I<0 %THEN FAULT(4) %ELSE SP=I %FINISHELSESTART; ! 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 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 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) %ELSESTART 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) %ELSESTART 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 %THENSTART %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: %RETURNIF NN=0 M=NN %CYCLE N=0,1,NN-1 %IF NA(N)="" %THENSTART; ! 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 %THENSTART PRINT STRING(" NOT SET") F=1 %FINISHELSE 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 KSYMBOLIC %IF 'A'<=J<='Z' %AND CC(Q+1)=M'''' ->NOT VALID %UNLESS '0'<=J<='9' J=0 %CYCLE I=CC(Q) %EXITUNLESS '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) %EXITUNLESS '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 %INTEGERFN 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='=' %THENRESULT=LITERAL %UNTIL N=8 %CYCLE I=CC(Q) %EXITUNLESS '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 %ANDRESULT=L %IF NA(L)=NEWNAME %THENRESULT=L %REPEAT PRINT STRING(" TOO MANY NAMES") %STOP %END %INTEGERFN 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 %THENSTART; ! 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:- * !* OR '('')' 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 %INTEGERFN 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:- * !* * !* '('')' * !* '('','')' * !*********************************************************************** %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 %INTEGERFN 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 %THENSTART; ! EVALUATED TO A CONST FAULT(3) %UNLESS 0<=I<=MAX I=I-1 %UNLESS I=0 %FINISHELSESTART 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 %INTEGERFN 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:- * !* '('')' * !* '('','')' * !*********************************************************************** %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) %ELSESTART 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(%INTEGERNAME VALUE,DEFINED) !%SHORTROUTINE !*********************************************************************** !* DEFINED=0 IF MUST BE EVALUATED LATER * !* DEFINED=1 IF EVALUATED TO VALUE * !*********************************************************************** %ROUTINESPEC STORE OP(%INTEGER N) %ROUTINESPEC OPERAND(%INTEGERNAME VALUE,DEFINED) %ROUTINESPEC TORP %INTEGER V,D,EVALABLE,J,SSP,OPPREC EVALABLE=1 SSP=STPTR ! TORP; ! EXPRESSION TO REVERSE POLISH ! %IF EVALABLE#0 %AND DEFINED#0 %THENSTART STPTR=STPTR-1 VALUE=ST(STPTR) DEFINED=1 %MONITORANDSTOPUNLESS 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 %INTEGERARRAY OPS(0:3) OPPTR=0; OPS(OPPTR)=0 NEXT OPERAND: ! GET AN OPERAND %IF CC(Q)='(' %THENSTART; ! SUBEXPRESSION Q=Q+1 TORP FAULT(1) %UNLESS CC(Q)=')' Q=Q+1 %FINISHELSESTART 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) %THENSTART 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(%INTEGERNAME VALUE,DEFINED) !%SHORTROUTINE !*********************************************************************** !* DEFINED AS FOR EXPRSN * !*********************************************************************** %INTEGER I,J J=CC(Q) %IF J='*' %THENSTART 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 %THENSTART DEFINED=1 VALUE=AD(I) %FINISHELSESTART DEFINED=0 VALUE=I %FINISH %RETURN %FINISH VALUE=GETN(X'7FFFFFFF') DEFINED=1 %END %END %INTEGERFN 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 %THENSTART S(AT)<-I FAULT(1) %IF I&X'FFFFFF00'#0 %FINISHELSESTART 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 %FINISHELSE 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 %CONSTBYTEINTEGERARRAY 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 %ELSESTART 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 %RETURNIF 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)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 %ROUTINESPEC CONST SET %INTEGERFNSPEC GET SIGN %LONGREAL SIGN,WORK,SCALE ! CONSTL=0; I=CC(Q) %IF CC(Q+1)='L' %THENSTART Q=Q+2; SPECLENGTH=EVAL EXP(1) %IF SPECLENGTH>256 %THENRETURN %FINISHELSE 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 %THENSTART FAULT(7) %IF CONSTL>SPECLENGTH %IF I='C' %THEN J=ITOE(' ') %ELSE J=' ' %WHILE CONSTLHERR %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 %THENSTART 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' %THENSTART %IF I#'0' %THEN WORK=WORK+(I&15)/SCALE SCALE=SCALE*10; ->AGAIN; %FINISH EXP: %IF CC(Q)='E' %THENSTART 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 %THENSTART FAULT(7) %IF SPECLENGTH>8 CONSTALL=1 CONSTL=SPECLENGTH %FINISHELSE CONSTL=CONSTALL %END %INTEGERFN GET SIGN %IF CC(Q)='+' %THEN Q=Q+1 %IF CC(Q)#'-' %THENRESULT=1 Q=Q+1; %RESULT=-1 %END L99:%END %INTEGERFN 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 %INTEGERFN LITERAL !%SHORTROUTINE %INTEGER I,J,WORK,XTRA %IF CC(Q)='A' %THENSTART 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) %ANDRESULT=0 WORK=CONSTL<<8!CONSTALL I=0 %WHILE INEXT %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 %THENSTART 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' %THENSTART; ! Y CONSTANTS ALL=2; L=2 Q=Q+1 %FINISHELSESTART ALL=4; L=4; ! ALLIGNMENT & LENGTH Q=Q+1 %IF CC(Q)='L' %THENSTART; ! 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 %RETURNIF 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) %CONSTSTRING (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) %CONSTSTRING (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 %THENSTART I=1 %UNTIL I=74 %OR J=NL %CYCLE READ SYMBOL(J) CC(I)=J I=I+1 %REPEAT %FINISHELSESTART %MONITORIF 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 %ENDOFfile