! %CONST %BYTE %INTEGER %ARRAY I TO E TAB(0 : 127) = %C X'40',X'40',X'40',X'40',X'40',X'40',X'40',X'40', X'40',X'40',X'15',X'40',X'0C',X'40',X'40',X'40', X'40',X'40',X'40',X'40',X'40',X'40',X'40',X'40', X'40',X'40',X'40',X'40',X'40',X'40',X'40',X'40', X'40',X'4F',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'4A',X'5F',X'5A',X'6A',X'6D', X'7C',X'81',X'82',X'83',X'84',X'85',X'86',X'87', X'88',X'89',X'91',X'92',X'93',X'94',X'95',X'96', X'97',X'98',X'99',X'A2',X'A3',X'A4',X'A5',X'A6', X'A7',X'A8',X'A9',X'C0',X'40',X'D0',X'40',X'40' %CONSTBYTEINTEGERARRAY ONE CASE(0 : 127) = %C 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15, 16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31, 32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47, 48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63, 64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79, 80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95, 96,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79, 80,81,82,83,84,85,86,87,88,89,90,123,124,125,126,127; %CONSTINTEGER MAXLEVELS=31,COMMALT=2,DECALT=8,ENDALT=9,SNPT=X'1006' %CONSTINTEGER MAXIBITS=32; ! BITS IN LARGEST INTEGER %IF HOST=IBMXA %START %EXTERNALINTEGERMAPSPEC COMREG %ALIAS "S#COMREGMAP" (%INTEGER N) %ELSE %EXTERNALINTEGERMAPSPEC COMREG %ALIAS "S#COMREG" (%INTEGER I) %FINISH %CONSTBYTEINTEGERARRAY TRTAB(0:255)=0(48),1(10), 0(7),2(26),0(6),2(26),0(*); %INCLUDE "ERCC07.TRIMP_TFORM1S" %EXTRINSICRECORD(PARMF)PARM %EXTRINSICRECORD(WORKAF)WORKA %EXTERNALROUTINESPEC POP(%INTEGERNAME A,B,C,D) %EXTERNALROUTINESPEC PUSH(%INTEGERNAME A,%INTEGER B,C,D) %EXTERNALROUTINESPEC FAULT(%INTEGER A,B,C) %EXTERNALINTEGERFN PASSONE %IF HOST=PERQ %THEN %START %EXTERNALROUTINESPEC MOVE BEE %FINISH %ROUTINESPEC NEW SOURCE(%INTEGER NEW FIL AD) %ROUTINESPEC OLD SOURCE %ROUTINESPEC READ LINE(%INTEGER MODE,CHAR) %INTEGERFNSPEC COMPARE(%INTEGER P) %ROUTINESPEC PNAME(%INTEGER MODE) %ROUTINESPEC CONST(%INTEGER MODE) %ROUTINESPEC TEXTTEXT(%INTEGER EBCDIC) %EXTERNALROUTINESPEC MOVE BYTES(%INTEGER LENGTH,FBASE,FOFF,TOBASE,TOOFF) %CONSTINTEGERARRAY PRECONSTS(0:3)=10,0,{NL}X'413243F6',X'A8885A31'{PI}; %INTEGER I,J,K,LLENGTH,LEVEL,QMAX,Q,R,S,SNUM,NNAMES,DSIZE,NEXT,JJ,CPTR, STARSTART,ARSIZE,HIT,CTYPE,LASTAT,LASTNAME,LASTEND,STRLINK,IHEAD, IDEPTH,FILEADDR,FILEPTR,FILEEND %OWNBYTEINTEGERARRAYFORMAT SRCEF(0:1024*1024) %RECORD(EMASFHDRF)%NAME HDR %LONGREAL IMAX %STRING(9)NEM %INTEGERNAME LINE %BYTEINTEGERARRAYNAME CC,SOURCE,A %INTEGERARRAYNAME WORD,TAGS LINE==WORKA_LINE CC==WORKA_CC A==WORKA_A TAGS==WORKA_TAGS WORD==WORKA_WORD NNAMES=WORKA_NNAMES DSIZE=8*NNAMES ARSIZE=1024*WORKA_WKFILEK-(WORKA_CCSIZE+256);!256 BYTE MARGIN LEFT AT MAP TIME IMAX=(-1)>>1 %INTEGERARRAY SFS(0:MAXLEVELS) %BYTEINTEGERARRAYFORMAT LETTF(0:DSIZE+20) %BYTEINTEGERARRAYNAME LETT %BYTEINTEGERARRAY TLINE(0:161) %CONSTBYTEINTEGERARRAY ILETT(0: 526)= 11, 'S','E','L','E','C','T','I','N','P','U','T', 12,'S','E','L','E', 'C','T','O','U','T','P','U','T', 7,'N','E','W','L','I','N','E', 5,'S','P','A','C','E', 10,'S','K','I','P','S','Y','M','B','O', 'L', 10,'R','E','A','D','S','T','R','I','N','G', 8,'N','E','W', 'L','I','N','E','S', 6,'S','P','A','C','E','S', 10,'N','E','X', 'T','S','Y','M','B','O','L', 11,'P','R','I','N','T','S','Y','M', 'B','O','L', 10,'R','E','A','D','S','Y','M','B','O','L', 4,'R', 'E','A','D', 5,'W','R','I','T','E', 7,'N','E','W','P','A','G', 'E', 4,'A','D','D','R', 6,'A','R','C','S','I','N', 3,'I','N', 'T', 5,'I','N','T','P','T', 6,'F','R','A','C','P','T', 5,'P', 'R','I','N','T', 7,'P','R','I','N','T','F','L', 4,'R','E','A', 'L', 7,'I','N','T','E','G','E','R', 3,'M','O','D', 6,'A','R', 'C','C','O','S', 4,'S','Q','R','T', 3,'L','O','G', 3,'S','I', 'N', 3,'C','O','S', 3,'T','A','N', 3,'E','X','P', 11,'C','L', 'O','S','E','S','T','R','E','A','M', 11,'B','Y','T','E','I','N', 'T','E','G','E','R', 8,'E','V','E','N','T','I','N','F', 6,'R','A','D','I','U','S', 6,'A','R','C','T','A','N', 6,'L','E','N','G','T','H', 11,'P','R','I','N','T','S','T','R', 'I','N','G', 2,'N','L', 8,'L','O','N','G','R','E','A','L', 7, 'P','R','I','N','T','C','H', 6,'R','E','A','D','C','H', 6,'S', 'T','R','I','N','G', 8,'R','E','A','D','I','T','E','M', 8,'N', 'E','X','T','I','T','E','M', 6,'C','H','A','R','N','O', 8,'T', 'O','S','T','R','I','N','G', 9,'S','U','B','S','T','R','I', 'N','G', 6,'R','E','C','O','R','D', 5,'A','R','R','A','Y', 6, 'S','I','Z','E','O','F',4,'I','M','O','D',2,'P', 'I',9,'E','V','E','N','T','L','I','N','E',11,'L','O','N','G', 'I','N','T','E','G','E','R',12,'L','O','N','G','L','O','N','G', 'R','E','A','L',9,'L','E','N','G','T','H','E','N','I', 9,'L','E','N','G','T','H','E','N','R', 8,'S','H','O','R','T','E','N','I', 8,'S','H','O','R','T','E','N','R', 6,'N','E','X','T','C','H', 11,'H','A','L','F','I','N','T','E','G','E','R', 8,'P','P','R','O','F','I','L','E', 5,'F','L','O','A','T', 4,'L','I','N','T', 6,'L','I','N','T','P','T', 12,'S','H','O','R','T','I','N','T','E','G','E','R',255; LETT==ARRAY(ADDR(A(ARSIZE-DSIZE-20)),LETTF) ARSIZE=ARSIZE-DSIZE-300 LETT(0)=0 LEVEL=0 WORKA_LETT==LETT %CYCLE I=0,1,MAXLEVELS SFS(I)=0 %REPEAT %CYCLE I=0,1,NNAMES WORD(I)=0; TAGS(I)=0; %REPEAT FILEADDR=WORKA_FILEADDR IDEPTH=0; IHEAD=0 %IF FILEADDR#0 %THEN %START HDR==RECORD(FILEADDR) SOURCE==ARRAY(FILEADDR,SRCEF) FILEPTR=HDR_STARTRA FILEEND=HDR_ENDRA %FINISH PARM_OPT=1; PARM_ARR=1 PARM_LINE=1; PARM_TRACE=1; PARM_DIAG=1 PARM_CHK=1 I=PARM_BITS1 %IF I&4=4 %THEN PARM_DIAG=0 %IF I&X'800000'#0 %THEN PARM_LINE=0 %IF I&16=16 %THEN PARM_CHK=0 PARM_MAP=I>>17&1; ! MAP CONTROLS FUNNY LISTING OF INCLUDES PARM_LIST=(I>>1&1)!!1 PARM_FREE=I>>19&1 %IF I&32=32 %THEN PARM_ARR=0 PARM_PROF=(I>>15&1)!(I>>7&1); ! USE MAP OR PROFILE BIT PRO TEM PARM_DYNAMIC=I>>20&1 PARM_LET=I>>13&1 PARM_DCOMP=I>>14&1; ! PARM CODE OR D PARM_DBUG=I>>18&1 %IF I&64=64 %THEN PARM_TRACE=0 %AND PARM_DIAG=0 PARM_X=I>>28&1; ! DONT REFORMAT REALS FOR SIMULATOR PARM_Y=I>>27&1 PARM_Z=I>>26&1; ! USE PARMZ BIT FOR DUMPING WKFILE PARM_STACK=I>>3&1 PARM_TTOPUT=COMREG(40) %IF I&(1<<16)#0 %THEN %START PARM_ARR=0; PARM_OPT=0 PARM_LINE=0; PARM_CHK=0; PARM_DIAG=0 %FINISH PARM_TRACE=PARM_TRACE!PARM_OPT; ! ALLOW NOTRACE ONLY WITH OPT NEWLINES(3); SPACES(14) PRINTSTRING("ERCC. Portable Imp80") PRINTSTRING(" Compiler Release") WRITE(WORKA_RELEASE,1) PRINTSTRING(" Version ".WORKA_LADATE) NEWLINES(3) WRITE(NNAMES,5); WRITE(WORKA_ASL MAX,5) NEWLINE ! ! NOW DECLARE THE SPECIAL NAMES WHICH ARE IN ARRAY ILETT. ! %BEGIN %RECORD(TAGF) SNTAG CPTR=0; SNUM=0; STRLINK=0 K=0 %IF HOST//10=1 %THEN NEXT=1 %ELSE NEXT=2; !START AT 2 FOR WORD ADDRESSES HOSTS I=ILETT(0) %WHILE I<255 %CYCLE %CYCLE J=I,-1,1 CC(J)=ILETT(K+J) %REPEAT CC(I+1)=';' R=2; Q=1; PNAME(1) SNTAG=0; SNTAG_UIOJ<-X'8000'; ! SET USED BIT JJ=TSNAME(SNUM) %IF JJ&X'C000'#X'4000' %START; ! NOT A CONST VARAIBLE SNTAG_PTYPE=SNPT SNTAG_ACC=JJ; ! TRUE PTYPE HERE SNTAG_SLINK=SNUM %FINISHELSESTART SNTAG_PTYPE=JJ SNTAG_S2=PRECONSTS(CPTR) SNTAG_S3=PRECONSTS(CPTR+1) CPTR=CPTR+2 %FINISH PUSH(TAGS(LASTNAME),SNTAG_S1,SNTAG_S2,SNTAG_S3) SNUM=SNUM+1 K=K+I+1; I=ILETT(K) %REPEAT %END ! COMREG(24)=16; ! RETURN CODE LINE=0; LLENGTH=0; Q=1 R=1; LEVEL=1 %CYCLE %IF Q>=LLENGTH %THEN QMAX=1 %AND READ LINE(0,0) STARSTART=R R=R+3 A(R)=LINE>>8 A(R+1)=LINE&255 R=R+2 %IF COMPARE(SS)=0 %THEN %START FAULT(100,Q,QMAX<<16!LLENGTH) R=STARSTART Q=Q+1 %WHILE CC(Q)#';' %AND QARSIZE %IF A(STARSTART+5)=COMMALT %THEN R=STARSTART %ELSE %START I=R-STARSTART A(STARSTART)=I>>16 A(STARSTART+1)=I>>8&255 A(STARSTART+2)=I&255 !*DELSTART %IF PARM_Z#0 %THEN %START NEWLINE; WRITE(LINE, 5) WRITE(STARSTART,5); NEWLINE; J=0 %CYCLE I=STARSTART, 1, R-1 WRITE(A(I), 5) J=J+1 %IF J>=20 %THEN NEWLINE %AND J=0 %REPEAT NEWLINE %FINISH !*DELEND %IF A(STARSTART+5)=ENDALT %AND %C 1<=A(STARSTART+6)<=2 %START;! ENDOF PROG OR FILE %IF IHEAD=0 %THEN %EXIT OLD SOURCE R=STARSTART; ! IGNORE ENDOFFILE LIKE IMP77 LLENGTH=1 %CONTINUE %FINISH %IF LEVEL=0 %THEN %START FAULT(14, 0, 0) R=STARSTART; ! IGNORE IT LEVEL=1 %FINISH %FINISH %FINISH %REPEAT %WHILE SFS(1)#0 %CYCLE POP(SFS(1),I,J,K) %IF I=1 %THEN FAULT(53,K,0); ! FINISH MISSING %IF I=2 %THEN FAULT(13,K,0); ! %REPEAT MISSING %REPEAT A(I)=0 %FOR I=R,1,R+7; R=R+8 R=(R+7)&(-8) WORKA_DICTBASE=R %CYCLE I=0,1,NEXT A(R+I)=LETT(I) %REPEAT WORKA_LETT==ARRAY(ADDR(A(R)),SRCEF) R=R+NEXT+1 %IF LEVEL>1 %THEN FAULT(15,LEVEL-1,0) R=(R+7)&(-8) NEWLINE %IF PARM_FAULTY=0 %THEN %START WRITE(LINE, 5) PRINT STRING(" LINES ANALYSED SIZE=") WRITE(R, 5) %IF (HOST=EMAS %OR HOST=IBM %OR HOST=IBMXA) %AND %C LINE>90 %AND PARM_LIST#0 %THEN NEWPAGE %ELSE NEWLINE %FINISH %ELSE %START PRINTSTRING("CODE GENERATION NOT ATTEMPTED ") COMREG(24)=8 COMREG(47)=PARM_FAULTY %STOP %FINISH %RESULT=R %ROUTINE NEWSOURCE(%INTEGER NEWFILEADDR) !*********************************************************************** !* SETS UP COMPILER TO USE AN INCLUDED SOURCE FILES * !*********************************************************************** PUSH(IHEAD,FILEADDR,FILEPTR,LINE) FILEADDR=NEWFILEADDR HDR==RECORD(FILEADDR) SOURCE==ARRAY(FILEADDR,SRCEF) FILEPTR=HDR_STARTRA FILEEND=HDR_ENDRA IDEPTH=IDEPTH+1 %IF PARM_MAP#0 %THEN LINE=10000 %END %ROUTINE OLDSOURCE !*********************************************************************** !* UNDOES THE ABOVE !*********************************************************************** %INTEGER ALT LINE %IF IHEAD#0 %THEN %START POP(IHEAD,FILEADDR,FILEPTR,ALTLINE) HDR==RECORD(FILEADDR) FILEEND=HDR_ENDRA %IF PARM_MAP#0 %THEN LINE=ALT LINE SOURCE==ARRAY(FILEADDR,SRCEF) IDEPTH=IDEPTH-1 %FINISH %ELSE FAULT(110,0,0) %END %ROUTINE READ LINE(%INTEGER MODE,CHAR) %ROUTINESPEC GET LINE %INTEGER DEL, LL, LP, PREV, LASTC LL=0; LP=0; Q=1 LLENGTH=0; DEL=0; LASTC=-1; ! NO CONTINUATIONS AS YET NEXT: LP=LP+1 %IF LP>LL %THEN GET LINE %AND LP=1 I=TLINE(LP) %IF MODE=0 %THEN %START %WHILE I='{' %CYCLE %CYCLE PREV=I LP=LP+1 I=TLINE(LP) %REPEAT %UNTIL PREV='}' %OR I=NL %REPEAT %IF I='%' %THEN DEL=128 %AND ->NEXT I=ONE CASE(I) %IF 'A'<=I<='Z' %THEN I=I!DEL %ELSE %START DEL=0 ->NEXT %IF I=' ' %FINISH LLENGTH=LLENGTH+1 CC(LLENGTH)=I %IF I='''' %OR I=34 %THEN MODE=1 %AND CHAR=I %FINISH %ELSE %START LLENGTH=LLENGTH+1 CC(LLENGTH)=I %IF I=CHAR %THEN MODE=0 %FINISH ->NEXT %UNLESS I=NL %IF LLENGTH-1=LASTC %THEN LLENGTH=LASTC %AND ->NEXT I=CC(LLENGTH-1) %IF I='C'+128 %THEN LLENGTH=LLENGTH-2 %AND LASTC=LLENGTH %AND ->NEXT %IF MODE=0 %AND I=',' %THEN LLENGTH=LLENGTH-1 %AND LASTC=LLENGTH %AND ->NEXT FAULT(101,0,0) %IF LLENGTH>WORKA_CCSIZE ! ON PERQ IMP SEEMS DEAD ! THEREFORE MOVE THE BEE %IF HOST=PERQ %AND LINE&15=0 %THEN MOVE BEE %RETURN %ROUTINE GET LINE %EXTERNALROUTINESPEC IOCP %ALIAS "S#IOCP" (%INTEGER A,B) %CONSTBYTEINTEGERARRAY ITOI(0:255)=%C 32(10),10,32(14),25,26,32(5), 32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47, 48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63, 64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79, 80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95, 96,97,98,99,100,101,102,103,104,105,106,107,108,109, 110,111,112,113,114,115,116,117,118,119, 120,121,122,123,124,125,126,32, 26(5),10,26(10), 26(16), 26(14),92,38, 26(11),35,26(4), 26(16), 26(9),35,26(5),94, 26(32); %INTEGER K LL=0 %IF FILE ADDR=0 %THEN %START; ! SOURCE NOT A 'CLEAN' FILE %UNTIL K=NL %CYCLE READ SYMBOL(K) TLINE(LL+1)=ITOI(K) LL=LL+1 %REPEAT %FINISH %ELSE %START %IF FILEPTR>=FILE END %START OLD SOURCE; ! RESET SOURCE FILES GETLINE %RETURN %FINISH %UNTIL K=NL %OR K=0 %CYCLE K=SOURCE(FILEPTR); ! NEXT CHAR FROM SORCE FILE FILE PTR=FILE PTR+1 TLINE(LL+1)=ITOI(K) LL=LL+1 %REPEAT %FINISH LINE=LINE+1; ! COUNT ALL LINES %IF PARM_LIST#0 %THEN %START %IF MODE=0 %AND LLENGTH>0 %THEN %C PRINTSTRING(" C") %ELSE WRITE(LINE, 5) %IF MODE#0 %THEN PRINTSTRING(""" ") %ELSE SPACES(8) TLINE(0)=LL %IF HOST=PERQ %OR HOST=ACCENT %THEN %START PRINT SYMBOL(TLINE(K)) %FOR K=1,1,LL %FINISH %ELSE IOCP(15,ADDR(TLINE(0))) %FINISH ! %IF PARM_FREE=0 %AND LL>73 %THEN TLINE(73)=10 %AND LL=73 %END %END %INTEGERFN COMPARE(%INTEGER P) %INTEGER I, J, ITEM, RA, RL, RP, RQ, RR, RS, MARKER, SSL, ALT, PP %OWNINTEGER SAVECOMP; ! FOR CHECKING DSIDED CONDS %SWITCH BIP(999:1043) RP=SYMBOL(P) RL=LEVEL P=P+1 PP=P; ! ROUTINE REALLY STARTS HERE COMM: RQ=Q; ! RESET VALUES OF LINE&AR PTRS RR=R SSL=STRLINK; ! SAVE STRING LINK ALT=1; ! FIRST ALTERNATIVE TO BE TRIED RA=SYMBOL(P); ! RA TO NEXT PHRASE ALTERNATIVE RS=P UPR: R=R+1 SUCC: ! SUCCESS ON TO NEXT ITEM RS=RS+1; ! RS=NEXT ALTERNATIVE MEANS THAT ! THIS ALT HAS BEEN COMPLETED SO ! EXIT WITH HIT=1 %IF RS=RA %THEN ->FINI ITEM=SYMBOL(RS); ! NEXT BRICK IN THE CURRENT ALT %IF ITEM<999 %THEN ->LIT %IF ITEM<1300 %THEN ->BIP(ITEM) ! BRICK IS A PHRASE TYPE %IF COMPARE(ITEM)=0 %THEN ->FAIL ->SUCC LIT: ! BRICK IS LITERAL I=CC(Q); ! OBTAIN CURRENT CHARACTER ->FAIL %UNLESS I=CLETT(ITEM+1) Q=Q+1 K=CLETT(ITEM)+ITEM ITEM=ITEM+2 %WHILE ITEM<=K %CYCLE ->FAIL %UNLESS CC(Q)=CLETT(ITEM) Q=Q+1 ITEM=ITEM+1 %REPEAT; ! CHECK IT WITH LITERAL DICT ENTRY ->SUCC; ! MATCHED SUCCESSFULLY FAIL: ! FAILURE - NOTE POSITION REACHD %IF RA=RP %THEN ->TFAIL; ! TOTAL FAILURE NO ALT TO TRY QMAX=Q %IF Q>QMAX Q=RQ; ! RESET LINE AND A.R. POINTERS R=RR+1; ! AVOID GOING VIA UPR: STRLINK=SSL ALT=ALT+1; ! MOVE TO NEXT ALT OF PHRASE RS=RA RA=SYMBOL(RA) ->SUCC TFAIL: LEVEL=RL %RESULT=0 BIP(999): ! REPEATED PHRASE A(RR)=ALT; P=PP ->COMM BIP(1000):FINI: ! NULL ALWAYS LAST & OK A(RR)=ALT %RESULT=1 BIP(1001): ! PHRASE NAME I=CC(Q); ! OBTAIN CURRENT CHARACTER ->FAIL %UNLESS TRTAB(I)=2 PNAME(ITEM-1004) ->SUCC %IF HIT=1; ->FAIL BIP(1002): ! PHRASE INTEGER CONSTANT BIP(1003): ! PHRASE CONST CONST(ITEM-1003) ->FAIL %IF HIT=0 ->SUCC BIP(1004): ! PHRASE DUMMYSTART A(R)=1; ! THERE IS AN '%ELSESTART' R=R+1 ->SUCC BIP(1005): ! PHRASE N I=CC(Q); ! OBTAIN CURRENT CHARACTER ->FAIL %UNLESS '0'<=I<='9' S=0 %WHILE '0'<=I<='9' %CYCLE S=10*S+I&15 Q=Q+1; I=CC(Q) %REPEAT A(R)<-S>>8; A(R+1)=S&255 R=R+2; ->SUCC BIP(1006): ! PHRASE S=SEPARATOR I=CC(Q); ! OBTAIN CURRENT CHARACTER ->SUCC %IF I=NL ->FAIL %UNLESS I=';' Q=Q+1; ->SUCC BIP(1007): ! PHRASE COMMENT TEXT I=CC(Q); ! OBTAIN CURRENT CHARACTER %IF I='!' %THEN Q=Q+1 %AND ->COMFOUND ->FAIL %UNLESS I='C'+128 %AND CC(Q+1)=%C 'O'+128 %AND CC(Q+2)=CC(Q+3)='M'+128 %AND CC(Q+4)='E'+128 ->FAIL %UNLESS CC(Q+5)='N'+128 %AND CC(Q+6)='T'+128 Q=Q+7 COMFOUND: J=CC(Q) %CYCLE %EXIT %IF J=NL Q=Q+1; J=CC(Q) %REPEAT ->SUCC BIP(1008): ! PHRASE BIGHOLE ! NOT CURRENTLY USED IN TRIMP ! A(I)=0 %FOR I=R,1,R+3 ! R=R+4 ->SUCC BIP(1009): ! PHRASE N255 I=CC(Q); ! OBTAIN CURRENT CHARACTER ->FAIL %UNLESS '0'<=I<='9' S=0 %WHILE '0'<=I<='9' %CYCLE S=10*S+I&15 Q=Q+1; I=CC(Q) %REPEAT ->FAIL %UNLESS 0<=S<=255 A(R)=S; ->UPR BIP(1010): ! PHRASE HOLE MARKER=R; R=R+2; ->SUCC BIP(1011): ! PHRASE MARK I=R-MARKER A(MARKER+1)<-I A(MARKER)<-I>>8 ->SUCC BIP(1012): ! PHRASE READLINE? I=CC(Q); ! OBTAIN CURRENT CHARACTER %WHILE I=NL %%CYCLE READLINE(0,0) RQ=1 I=CC(Q) %REPEAT FAULT(102, WORKA_WKFILEK,0) %IF R>ARSIZE ->SUCC BIP(1013): ! PHRASE CHECKIMPS TEXTTEXT(0) ->FAIL %IF HIT=0 ->SUCC BIP(1014): ! PHRASE DUMMY APP A(R)=2; A(R+1)=2 R=R+2; ->SUCC BIP(1015): ! PHRASE DOWN=NEW TEXT LEVEL LEVEL=LEVEL+1 SFS(LEVEL)=0 ->SUCC BIP(1016): ! PHRASE UP 1 TEXTUAL LEVEL %WHILE SFS(LEVEL)#0 %CYCLE POP(SFS(LEVEL),I,J,K) %IF I=1 %THEN FAULT(53,K,0); ! FINISH MISSING %IF I=2 %THEN FAULT(13,K,0); ! %REPEAT MISSING %REPEAT LEVEL=LEVEL-1 ->SUCC BIP(1017): ! PHRASE LISTON PARM_LIST=1; ->SUCC BIP(1018): ! PHRASE LISTOFF PARM_LIST=0; ->SUCC BIP(1019): ! PHRASE COLON FOR LABEL ->FAIL %UNLESS CC(Q-1)=':' ->SUCC BIP(1020): ! PHRASE NOTE CONST ->SUCC BIP(1021): ! TRACE FOR ON CONDITIONS PARM_TRACE=1; ->SUCC BIP(1022): ! SET MNEMONIC I=CC(Q); ! OBTAIN CURRENT CHARACTER J=0 NEM="123456789" %WHILE 'A'<=I<='Z' %OR '0'<=I<='9' %CYCLE J=J+1 CHARNO(NEM,J)=I Q=Q+1; I=CC(Q) %REPEAT ->FAIL %UNLESS J>0 LENGTH(NEM)=J %IF I='_' %THEN Q=Q+1 ->SUCC BIP(1023): ! UCNOP MNEMONIC SANS OPERANDS ->FAIL %IF (TARGET=PNX %OR TARGET=PERQ %OR TARGET=ACCENT) %AND CC(Q-1)='_' ! EFFICIENCY FROG FOR ASSBLERS ! WITH NO PARAMETER OPCODES %CYCLE I=0,1,FIRSTUCUB-1 ->PFND %IF NEM=QCODES(I) %REPEAT ->FAIL PFND: J=OPC(I) A(R)<-J>>8; A(R+1)<-J R=R+2; ->SUCC; ! ALLOW MORE THAN 255 OPCODES BIP(1024): ! UCUB MNEMONIC WITH UNSIGNED BYTE OPERAND %CYCLE I=FIRST UCUB,1,FIRST UCSB-1 ->PFND %IF NEM=QCODES(I) %REPEAT ->FAIL BIP(1025): ! UCUB SIGNED BYTE OPERANDS %CYCLE I=FIRST UCSB,1,FIRST UCW-1 ->PFND %IF NEM=QCODES(I) %REPEAT; ->FAIL BIP(1026): ! P(OP)=+,-,&,****,**,*,!!,!, ! //,/,>>,<<,.,\\,\ I=CC(Q); ! OBTAIN CURRENT CHARACTER ->FAIL %UNLESS 32>((I-32)&31)&X'4237000A'#0 Q=Q+1 %IF I='+' %THEN A(R)=1 %AND ->UPR %IF I='-' %THEN A(R)=2 %AND ->UPR %IF I='&' %THEN A(R)=3 %AND ->UPR J=CC(Q) %IF I='*' %THEN %START %IF J#I %THEN A(R)=6 %AND ->UPR %IF CC(Q+1)=I=CC(Q+2) %THEN A(R)=4 %AND Q=Q+3 %AND ->UPR A(R)=5; Q=Q+1; ->UPR %FINISH %IF I='/' %THEN %START %IF J#I %THEN A(R)=10 %AND ->UPR A(R)=9; Q=Q+1; ->UPR %FINISH %IF I='!' %THEN %START %IF J#I %THEN A(R)=8 %AND ->UPR A(R)=7; Q=Q+1; ->UPR %FINISH %IF I='.' %THEN A(R)=13 %AND ->UPR %IF I=J='<' %THEN A(R)=12 %AND Q=Q+1 %AND ->UPR %IF I=J='>' %THEN A(R)=11 %AND Q=Q+1 %AND ->UPR %IF I='\' %THEN %START %IF J#I %THEN A(R)=15 %AND ->UPR Q=Q+1; A(R)=14; ->UPR %FINISH ->FAIL BIP(1027): ! PHRASE CHECK UI I=CC(Q); ! OBTAIN CURRENT CHARACTER ->SUCC %IF TRTAB(I)=2 %OR I='-' ->SUCC %IF X'80000000'>>(I&31)&X'14043000'#0 ->FAIL BIP(1028): ! P(+')=+,-,\,0 I=CC(Q); ! OBTAIN CURRENT CHARACTER %IF I='\' %OR I=X'7E' %THEN A(R)=3 %AND Q=Q+1 %AND ->UPR %IF I='-' %THEN A(R)=2 %AND Q=Q+1 %AND ->UPR %IF I='+' %THEN A(R)=1 %AND Q=Q+1 %AND ->UPR A(R)=4; ->UPR BIP(1029): ! PHRASE NOTE CYCLE A(R)=0; A(R+1)=0 A(R+2)=0; A(R+3)=0 PUSH(SFS(LEVEL),2,R,LINE) R=R+4 ->SUCC BIP(1030): ! P(,')=',',0 ! ! THIS IS VERY AWKWARD AS IT MEANS IT IS VERY TO HARD TO FIND ! THE END OF A PARAMETER LIST WITHOUT CHURNING. BY MAKING THIS A BIP ! WE CAN PEEP AHEAD FOR ')' AND FAIL HERE. ! I=CC(Q); ! OBTAIN CURRENT CHARACTER %IF I=')' %THEN ->FAIL %IF I=',' %THEN Q=Q+1 ->SUCC BIP(1031): ! PHRASE CHECKTYPE IE ENSURE ! FIRST LETTER IS(B,H,I,L,R,S) & ! 3RD LETTER IS (A,L,N,O,R,T) I=CC(Q); ! OBTAIN CURRENT CHARACTER ->FAIL %UNLESS I>128 %AND X'80000000'>>(I&31)&X'20C83000'#0%C %AND X'80000000'>>(CC(Q+2)&31)&X'500B2800'#0 ->SUCC BIP(1032): ! PHRASE COMP1 BIP(1037): ! PHRASE COMP2(IS 2ND HALF OF DSIDED) I=CC(Q); ! OBTAIN CURRENT CHARACTER ->FAIL %UNLESS 32>(I&31)&X'1004000E'#0 ! '='=1,'>='=2,'>'=3 ! '#' OR '\=' OR '<>'=4 ! '<='=5,'<'=6 ! 7UNUSED,'->'=8,'=='=9 ! '##' OR '\==' =10 %IF I='=' %THEN %START %IF CC(Q+1)=I %THEN J=9 %AND ->JOIN1 J=1; ->JOIN %FINISH %IF I='#' %THEN %START %IF CC(Q+1)=I %THEN J=10 %AND ->JOIN1 J=4; ->JOIN %FINISH %IF I='\' %AND CC(Q+1)='=' %THEN %START Q=Q+1 %IF CC(Q+1)='=' %THEN J=10 %AND ->JOIN1 J=4; ->JOIN %FINISH %IF I='>' %THEN %START %IF CC(Q+1)='=' %THEN J=2 %AND ->JOIN1 J=3; ->JOIN %FINISH %IF I='<' %THEN %START %IF CC(Q+1)='>' %THEN J=4 %AND ->JOIN1 %IF CC(Q+1)='=' %THEN J=5 %AND ->JOIN1 J=6; ->JOIN %FINISH %IF I='-' %AND CC(Q+1)='>' %THEN J=8 %AND ->JOIN1 ->FAIL JOIN1:Q=Q+1 JOIN: Q=Q+1 A(R)=J %IF ITEM=1032 %THEN SAVECOMP=J %AND ->UPR ! SAVE J TO CHECK DSIDED %IF SAVECOMP>6 %OR J>6 %THEN Q=Q-1 %AND ->FAIL;! ILLEGAL DSIDED ->UPR; ! NB OWNS WONT WORK IF ! COND EXPRS ALLOWED AS THE ! CAN BE NESTED! BIP(1033): ! P(ASSOP)- ==,=,<-,-> I=CC(Q); ! OBTAIN CURRENT CHARACTER %IF I='=' %THEN %START %IF CC(Q+1)='=' %THEN A(R)=1 %AND Q=Q+2 %AND ->UPR A(R)=2; Q=Q+1; ->UPR %FINISH %IF I='<' %AND CC(Q+1)='-' %THEN A(R)=3 %AND Q=Q+2 %AND ->UPR %IF I='-' %AND CC(Q+1)='>' %THEN A(R)=4 %AND Q=Q+2 %AND ->UPR ->FAIL BIP(1034): ! NOTE START A(R)=0; A(R+1)=0 A(R+2)=0; A(R+3)=0; ! HOLE FOR FORWARD PTR PUSH(SFS(LEVEL),1,R,LINE) R=R+4 ->SUCC BIP(1035): ! NOTE FINISH %IF SFS(LEVEL)=0 %THEN FAULT(51,0,0) %AND ->SUCC POP(SFS(LEVEL),I,J,K) %IF I=2 %THEN FAULT(59,K,0) MOVEBYTES(4,ADDR(STARSTART),0,ADDR(A(0)),J) ->SUCC BIP(1036): ! NOTE REPEAT %IF SFS(LEVEL)=0 %THEN FAULT(1,0,0) %AND ->SUCC POP(SFS(LEVEL),I,J,K) %IF I=1 %THEN FAULT(52,K,0); ! START INSTEAD OF CYCLE MOVEBYTES(4,ADDR(STARSTART),0,ADDR(A(0)),J) ->SUCC BIP(1038): ! INCLUDE "FILE" ->FAIL %IF IDEPTH>10 I=CC(Q) ->FAIL %UNLESS I=NL %OR I=';' Q=Q+1 %IF I=';' ->FAIL %UNLESS CTYPE=5 %AND A(S)<=31 %IF HOST=EMAS %THEN %START %BEGIN %EXTERNALROUTINESPEC CONSOURCE %ALIAS "S#CONSOURCE"(%STRING(31)FILENAME,%INTEGERNAME FILEADDR) CONSOURCE(STRING(ADDR(A(S))),J) NEWSOURCE(J) %END ->SUCC %FINISH %IF HOST=IBM %OR HOST=IBMXA %OR HOST=AMDAHL %START %BEGIN %EXTERNALROUTINESPEC CONSOURCE %ALIAS "S#CONSOURCE"(%STRING(255)FILENAME, %INTEGERNAME FILEADDR) CONSOURCE(STRING(ADDR(A(S))),J) NEWSOURCE(J) %END ->SUCC %FINISH %IF HOST=PNX %OR HOST=PERQ %THEN %START %BEGIN %STRING(255) FNAME %SYSTEMROUTINESPEC CONSOURCE(%STRING(255)FILENAME,%INTEGERNAME FILEADDR) LENGTH(FNAME)=A(S) CHARNO(FNAME,I)=A(S+I) %FOR I=1,1,A(S) CONSOURCE(FNAME,J) NEWSOURCE(J) %END ->SUCC %FINISH ->FAIL BIP(1039): ! UCW = USERCODE WORD OFFSET INSTRS %CYCLE I=FIRST UCW,1,FIRST UCUBUB-1 ->PFND %IF NEM=QCODES(I) %REPEAT ->FAIL BIP(1040): ! UCUBUB TWO UNSIGNED BYTE OPERANDS %CYCLE I=FIRST UCUBUB,1,FIRST UCUBW-1 ->PFND %IF NEM=QCODES(I) %REPEAT; ->FAIL BIP(1041): ! UCUCUBW - BYTE&WORD OPERANDS %CYCLE I=FIRST UCUBW,1,FIRST UCJUMP-1 ->PFND %IF NEM=QCODES(I) %REPEAT; ->FAIL BIP(1042): ! UCJUMP = JUMP MNEMONICS %CYCLE I=FIRST UCJUMP,1,LASTUC ->PFND %IF NEM=QCODES(I) %REPEAT; ->FAIL BIP(1043): ! UCWRONG ERRORS AND OTHER M-CS I=CC(Q) %CYCLE Q=Q+1 %EXIT %IF I=NL %OR I=';' I=CC(Q) %REPEAT ->SUCC %END; !OF ROUTINE 'COMPARE' %ROUTINE PNAME(%INTEGER MODE) !*********************************************************************** !* MODE=0 FOR OLD NAME(ALREADY IN DICT), MODE=1 FOR NEW NAME * !*********************************************************************** %CONSTINTEGERARRAY HASH(0:7)=71,47,97,79,29,37,53,59; %INTEGER JJ, KK, LL, FQ, FS, T, S, I HIT=0; FQ=Q; FS=CC(Q) %RETURN %UNLESS TRTAB(FS)=2 %AND M'"'#CC(Q+1)#M'''' ! 1ST CHAR MUST BE LETTER T=1 LETT(NEXT+1)=FS!32; JJ=71*FS %CYCLE Q=Q+1 I=CC(Q) %EXIT %IF TRTAB(I)=0 JJ=JJ+HASH(T)*I %IF T<=7 T=T+1 LETT(NEXT+T)=I!32 %REPEAT LETT(NEXT)=T; ! INSERT LENGTH S=T+1 FAULT(103,0,0) %IF NEXT+S>DSIZE; !DICTIONARY OVERFLOW JJ=(JJ+113*T)&NNAMES %CYCLE KK=JJ, 1, NNAMES LL=WORD(KK) ->HOLE %IF LL=0; ! NAME NOT KNOWN ->FND %IF STRING(ADDR(LETT(NEXT)))=STRING(ADDR(LETT(LL))) %REPEAT %CYCLE KK=0,1,JJ LL=WORD(KK) ->HOLE %IF LL=0; ! NAME NOT KNOWN ->FND %IF STRING(ADDR(LETT(NEXT)))=STRING(ADDR(LETT(LL))) %REPEAT FAULT(104, 0, 0); ! TOO MANY NAMES HOLE: %IF MODE=0 %THEN Q=FQ %AND %RETURN WORD(KK)=NEXT %IF HOST//10=1 %THEN NEXT=NEXT+S %ELSE NEXT=(NEXT+S+1)&(-2) FND: LASTAT=FQ; HIT=1; LASTNAME=KK A(R+1)<-LASTNAME A(R)=LASTNAME>>8; R=R+2 LASTEND=Q %END %ROUTINE CONST(%INTEGER MODE) !*********************************************************************** !* SYNTAX CHECK AND EVALUATE ALL THE FORMS OF IMP CONSTANT * !* MODE=0 FOR INTEGER CONSTANTS #0 FOR ANY SORT OF CONSTANT * !*********************************************************************** %CONSTBYTEINTEGERARRAY RSHIFT(0:32)=0,0,1,0,2,0(3),3,0(7),4,0(15),5; %INTEGER Z, DOTSEEN, EBCDIC, FS, CPREC, RR, S, SS, T, RS %IF 1<N %IF M'0'<=FS<=M'9' ->DOT %IF FS='.' %AND MODE=0 %AND '0'<=CC(Q+1)<='9' ! 1 DIDT MIN CTYPE=1; EBCDIC=0 ->QUOTE %IF FS=M'''' ->STR2 %IF FS=34 ->NOTQUOTE %UNLESS CC(Q+1)=M''''; Q=Q+2 ->HEX %IF FS='X' ->MULT %IF FS='M' ->BIN %IF FS=M'B' ->RHEX %IF FS='R' %AND MODE=0 ->OCT %IF FS='K' %IF FS='C' %THEN EBCDIC=1 %AND ->MULT %IF 1<N %IF CC(Q)='.' %THEN ->DOT %FINISH Q=Q-2; %RETURN QUOTE: ! SINGLE CH BETWEEN QUOTES S=CC(Q+1); Q=Q+2 %IF S=NL %THEN READLINE(1,'''') %AND Q=1 %IF CC(Q)=M'''' %THEN %START Q=Q+1 %IF S#M'''' %THEN ->IEND %IF CC(Q)=M'''' %THEN Q=Q+1 %AND ->IEND %FINISH %RETURN; ! NOT VALID NOTQUOTE: ! CHECK FOR E"...." %RETURN %UNLESS FS='E' %AND CC(Q+1)=M'"' EBCDIC=1; Q=Q+1 STR2: ! DOUBLE QUOTED STRING A(RR)=X'35'; TEXTTEXT(EBCDIC) CTYPE=5; %RETURN HEX: T=0; ! HEX CONSTANTS %CYCLE I=CC(Q); Q=Q+1 %EXIT %IF I=M'''' T=T+1 %RETURN %UNLESS %C ('0'<=I<='9' %OR 'A'<=I<='F' %OR 'a'<=I<='f') %AND %C (T<9 %OR (1<>6 %REPEAT %IF T>8 %START Z=4*(T-8) S=S!(SS<>(32-Z) CPREC=6 %FINISH IEND: %IF CPREC=6 %THEN MOVEBYTES(4,ADDR(SS),0,ADDR(A(0)),R) %AND R=R+4 %IF CPREC=5 %AND 0<=S<=X'7FFF' %START CPREC=4; A(R)<-S>>8; A(R+1)=S&255; R=R+2 %FINISH %ELSE %START MOVEBYTES(4,ADDR(S),0,ADDR(A(0)),R) R=R+4 %FINISH HIT=1 %UNLESS MODE#0 %AND CPREC=6 A(RR)=CPREC<<4!CTYPE %RETURN RHEX: ! REAL HEX CONSTANTS T=0 %CYCLE I=CC(Q); Q=Q+1 %IF T&7=0 %AND T#0 %START MOVEBYTES(4,ADDR(S),0,ADDR(A(0)),R); R=R+4; S=0 %FINISH %EXIT %IF I=M''''; T=T+1 %RETURN %UNLESS '0'<=I<='9' %OR 'A'<=I<='F' %OR 'a'<=I<='f' S=S<<4+I&15+9*I>>6 %REPEAT %RETURN %UNLESS T=8 %OR T=16 %OR (1<IEND MULT: T=0; ! MULTIPLE CONSTANTS %CYCLE I=CC(Q); Q=Q+1; T=T+1 %IF I=M'''' %THEN %START %IF CC(Q)#M'''' %THEN %EXIT %ELSE Q=Q+1 %FINISH %RETURN %IF T>=5 %IF EBCDIC#0 %THEN I=ITOETAB(I) S=S<<8!I %REPEAT ->IEND BIN: T=0; ! BINARY CONST %CYCLE I=CC(Q); Q=Q+1; T=T+1 %EXIT %IF I=M'''' %RETURN %UNLESS '0'<=I<='1' %AND T<33 S=S<<1!I&1 %REPEAT ->IEND RADIX: ! BASE_VALUE CONSTANTS T=0; RADIXV=0 RS=RSHIFT(S) Q=Q+1 %CYCLE I=CC(Q) %EXIT %UNLESS '0'<=I<='9' %OR 'A'<=I<='Z' %IF I<='9' %THEN I=I-'0' %ELSE I=I-('A'-10) %EXIT %IF I>=S; ! MUST BE LESS THAN BASE Q=Q+1 %IF RS#0 %THEN RADIXV=RADIXV<0 %AND T>MAXIBITS);! NO VALID DIGITS %IF 1<>32 %ELSE SS=0 S<-RADIXV CTYPE=1 %IF SS#0 %THEN CPREC=6 ->IEND N: ! CONSTANT STARTS WITH DIGIT I=CC(Q) %UNTIL IM'9' %CYCLE CVALUE=TEN*CVALUE+(I&15) Q=Q+1; I=CC(Q); ! ONTO NEXT CHAR %REPEAT %IF I='_' %AND 2<=CVALUE<33 %THEN S=INT(CVALUE) %AND ->RADIX ->ALPHA %UNLESS MODE=0 %AND I='.' DOT: Q=Q+1; X=TEN; I=CC(Q) DOTSEEN=1; ! CONSTANT HAS DECIMAL POINT %WHILE M'0'<=I<=M'9' %CYCLE CVALUE=CVALUE+(I&15)/X X=TEN*X; Q=Q+1; I=CC(Q) %REPEAT ALPHA: ! TEST FOR EXPONENT %IF MODE=0 %AND CC(Q)='@' %THEN %START Q=Q+1; X=CVALUE Z=1; I=CC(Q) %IF I='-' %THEN Z=-1 %IF I='+' %OR I='-' %THEN Q=Q+1 CONST(2) %IF HIT=0 %THEN %RETURN HIT=0 DOTSEEN=1; ! @ IMPLIES REAL IN IMP80 R=RR+1 %IF A(R)>>4#4 %THEN %RETURN; ! EXPONENT MUST BE HALFINTEGER S=(A(R+1)<<8!A(R+2))*Z %IF S=-99 %THEN CVALUE=0 %ELSE %START %WHILE S>0 %CYCLE S=S-1 CVALUE=CVALUE*TEN %REPEAT %WHILE S<0 %AND CVALUE#0 %CYCLE S=S+1 CVALUE=CVALUE/TEN %REPEAT %FINISH %FINISH ! SEE IF IT IS INTEGER %IF FS='D' %THEN %START I=CC(Q) %IF I='''' %THEN Q=Q+1 %ELSE %RETURN DOTSEEN=1; ! ENSURE NOT TAKEN AS INTEGER %FINISH %IF DOTSEEN=1 %OR CVALUE>IMAX %THEN CTYPE=2 %C %ELSE CTYPE=1 %AND S=INT(CVALUE) %IF CTYPE=1 %THEN ->IEND %IF CPREC=5 %THEN CPREC=6; ! ONLY 64 BIT REAL CONSTS %IF CPREC=6 %THEN %START MOVEBYTES(8,ADDR(CVALUE),0,ADDR(A(0)),R); R=R+8 %FINISH %ELSE %START; ! PREC = 7 CONTSTANTS MOVEBYTES(16,ADDR(CVALUE),0,ADDR(A(0)),R) R=R+16 %FINISH A(RR)=CPREC<<4+CTYPE HIT=1 %END %ROUTINE TEXTTEXT(%INTEGER EBCDIC) !*********************************************************************** !* PROCESSES TEXT BETWEEN DOUBLE QUOTES AND STORES IN ISO OR EBCDIC * !*********************************************************************** %INTEGER J, II %CONSTINTEGER QU='"' I=CC(Q) S=R; R=R+1; HIT=0 %RETURN %UNLESS I=QU; ! FAIL UNLESS INITIAL QUOTE Q=Q+1 %CYCLE I=CC(Q) %IF EBCDIC#0 %THEN II=ITOETAB(I) %ELSE II=I A(R)=II; R=R+1 %IF I=QU %THEN %START Q=Q+1 %IF CC(Q)#QU %THEN %EXIT %FINISH %IF I=10 %THEN READLINE(1,QU) %ELSE Q=Q+1 FAULT(106,0,0) %IF R-S>256 %REPEAT R=R-1; J=R-S-1 A(S)=J; HIT=1 %END %END; ! OF ROUTINE PASS ONE %ENDOFFILE