! %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 %SYSTEMINTEGERMAPSPEC COMREG(%INTEGER I) %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) %ROUTINESPEC FAULT(%INTEGER A,B,C) %EXTERNALINTEGERFN PASSONE %ROUTINESPEC READ LINE(%INTEGER MODE,CHAR) %INTEGERFNSPEC COMPARE(%INTEGER P) %ROUTINESPEC PNAME(%INTEGER MODE) %ROUTINESPEC CONST(%INTEGER MODE) %ROUTINESPEC TEXTTEXT(%INTEGER EBCDIC) %ROUTINESPEC MOVE BYTES(%INTEGER LENGTH,FBASE,FOFF,TOBASE,TOOFF) %CONSTINTEGER NO OF SNS=65 %CONSTINTEGER LRLPT=X'62' %CONSTHALFINTEGERARRAY TSNAME (0:NO OF SNS)=X'1000'(8), X'1041',X'1000'(5),X'1051',X'1000'+LRLPT, X'1051'(2),X'1000'+LRLPT, X'1000'(2),X'52',X'51',LRLPT,X'1000'+LRLPT(7), X'1000',X'31',X'51',X'1000'+LRLPT(2),X'31',X'1000', X'4051',LRLPT,X'1000'(2),X'35',X'1000',X'1035', X'31',X'35',X'1035',X'33',0,X'1051',X'51',X'4052',X'51', X'61',X'72',X'61',X'72',X'51',LRLPT,X'1051',X'41', X'1000',LRLPT,X'1061'(2); %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 %BYTEINTEGERARRAYFORMAT 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=7*NNAMES ARSIZE=768*WORKA_WKFILEK-300 IMAX=(-1)>>1 %INTEGERARRAY SFS(0:MAXLEVELS) %BYTEINTEGERARRAY TLINE(-60:161),LETT(0:DSIZE+20) %CONSTBYTEINTEGERARRAY ILETT(0: 513)= 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',255; LETT(0)=0 LEVEL=0 WORKA_LETT==ARRAY(ADDR(LETT(0)),A) %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_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_SMAP=I>>26&1; ! USE PARMZ BIT FOR DUMPING WKFILE PARM_X=I>>28&1; ! DONT REFORMAT REALS FOR SIMULATOR 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#PERQ %THEN NEXT=1 %ELSE NEXT=2 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_SMAP#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 IDEPTH=IDEPTH-1 POP(IHEAD,FILEADDR,FILEPTR,FILEEND) HDR==RECORD(FILEADDR) SOURCE==ARRAY(FILEADDR,SRCEF) 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 A(I)=0 %FOR I=R,1,R+7; R=R+8 R=(R+7)&(-8) %IF R+NEXT>ARSIZE %THEN FAULT(102, WORKA_WKFILEK,0) WORKA_DICTBASE=R %CYCLE I=0,1,NEXT A(R+I)=LETT(I) %REPEAT WORKA_LETT==ARRAY(ADDR(A(R)),A) 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 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 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 %RETURN %ROUTINE GET LINE %SYSTEMROUTINESPEC 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 %IF IHEAD#0 %THEN %START POP(IHEAD,FILEADDR,FILEPTR,FILEEND) HDR==RECORD(FILEADDR) SOURCE==ARRAY(FILEADDR,SRCEF) IDEPTH=IDEPTH-1 GETLINE %RETURN %FINISH FAULT(110,0,0) %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) ! SPACES(8) %CYCLE K=-7,1,0 TLINE(K)=' ' %REPEAT %IF MODE#0 %THEN TLINE(-7)=M'"' TLINE(-8)=LL+8 %IF HOST=PERQ %THEN %START PRINT SYMBOL(TLINE(K)) %FOR K=-8,1,LL %FINISH %ELSE IOCP(15,ADDR(TLINE(-8))) %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; A(R+1)=1; ! THERE IS ELSE AND START R=R+2 ->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 CC(Q-1)='_' %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 %SYSTEMROUTINESPEC CONSOURCE(%STRING(31)FILENAME,%INTEGERNAME FILEADDR) PUSH(IHEAD,FILEADDR,FILEPTR,FILEEND) CONSOURCE(STRING(ADDR(A(S))),FILEADDR) HDR==RECORD(FILEADDR) SOURCE==ARRAY(FILEADDR,SRCEF) FILEPTR=HDR_STARTRA FILEEND=HDR_ENDRA IDEPTH=IDEPTH+1 %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=EMAS %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 %ROUTINE MOVE BYTES(%INTEGER LENGTH,FBASE,FOFF,TOBASE,TOOFF) !************************************************************************ !* A MOVE BYTES ROUTINE THAT WILL WORK ON WORD&BYTE ADDRESS M-CS * !*********************************************************************** %INTEGER I %RETURN %IF LENGTH<=0 %IF HOST=EMAS %START; ! EMAS BYTE ADDRESSES I=X'18000000'+LENGTH *LDA_TOBASE; *INCA_TOOFF; *LDTB_I *LSS_FBASE; *IAD_FOFF; *LUH_I *MV_%L=%DR %FINISH %IF HOST=PERQ %START; ! WORD ADDRESS+BYTE OFFSET FBASE=FBASE+FOFF>>1 FOFF=FOFF&1 TOBASE=TOBASE+TOOFF>>1 TOOFF=TOOFF&1 *LDLDB_2; ! FBASE *LDL4; ! FOFF *LDLDB_6; ! TO BASE *LDL8; ! TOOFF (BTM BITS) *LDL0; ! LENGTH *MVBW %FINISH %END %END; ! OF ROUTINE PASS ONE %EXTERNALSTRINGFN PRINTNAME(%INTEGER N) %INTEGER V, K %STRING(255)S S="???" %IF 0<=N<=WORKA_NNAMES %START V=WORKA_WORD(N) K=WORKA_LETT(V) %IF K#0 %THEN S=STRING(ADDR(WORKA_LETT(V))) %FINISH %RESULT=S %END %STRINGFN MESSAGE(%INTEGER N) !*********************************************************************** !* OUTPUTS AN ERROR MESSAGE STORED IN A COMPRESSED FORMAT * !* 1 %REPEAT is not required * !* 2 Label & has already been set in this block * !* 4 & is not a Switch name at current textual level * !* 5 Switch name & in expression or assignment * !* 6 Switch label &(#) set a second time * !* 7 Name & has already been declared * !* 8 Routine or fn & has more parameters than specified * !* 9 Parameter # of & differs in type from specification * !* 10 Routine or fn & has fewer parameters than specified * !* 11 Label & referenced at line # has not been set * !* 12 %CYCLE at line # has two control clauses * !* 13 %REPEAT for %CYCLE at line # is missing * !* 14 %END is not required * !* 15 # %ENDs are missing * !* 16 Name & has not been declared * !* 17 Name & does not require parameters or subscripts * !* 18 # too few parameters provided for & * !* 19 # too many parameters provided for & * !* 20 # too few subscripts provided for array & * !* 21 # too many subscripts provided for array & * !* 22 Actual parameter # of & conflicts with specification * !* 23 Routine name & in an expression * !* 24 Integer operator has Real operands * !* 25 Real expression in integer context * !* 26 # is not a valid %EVENT number * !* 27 & is not a routine name * !* 28 Routine or fn & has specification but no body * !* 29 %FUNCTION name & not in expression * !* 30 %RETURN outwith routine body * !* 31 %RESULT outwith fn or map body * !* 34 Too many textual levels * !* 37 Array & has too many dimensions * !* 38 Array & has upper bound # less than lower bound * !* 39 Size of Array & is more than X'FFFFFF' bytes * !* 40 Declaration is not at head of block * !* 41 Constant cannot be evaluated at compile time * !* 42 # is an invalid repetition factor * !* 43 %CONSTANT name & not in expression * !* 44 Invalid constant initialising & after # items * !* 45 Array initialising items expected ## items given # * !* 46 Invalid %EXTERNAL %EXTRINSIC or variable %SPEC * !* 47 %ELSE already given at line # * !* 48 %ELSE invalid after %ON %EVENT * !* 49 Attempt to initialise %EXTRINSIC or %FORMAT & * !* 50 Subscript of # is outwith the bounds of & * !* 51 %FINISH is not required * !* 52 %REPEAT instead of %FINISH for %START at line # * !* 53 %FINISH for %START at line # is missing * !* 54 %EXIT outwith %CYCLE %REPEAT body * !* 55 %CONTINUE outwith %CYCLE %REPEAT body * !* 56 %EXTERNALROUTINE & at wrong textual level * !* 57 Executable statement found at textual level zero * !* 58 Program among external routines * !* 59 %FINISH instead of %REPEAT for %CYCLE at line # * !* 61 Name & has already been used in this %FORMAT * !* 62 & is not a %RECORD or %RECORD %FORMAT name * !* 63 %RECORD length is greater than # bytes * !* 64 Name & requires a subname in this context * !* 65 Subname & is not in the %RECORD %FORMAT * !* 66 Expression assigned to record & * !* 67 Records && and & have different formats * !* 69 Subname && is attached to & which is not of type %RECORD * !* 70 String declaration has invalid max length of # * !* 71 & is not a String variable * !* 72 Arithmetic operator in a String expression * !* 73 Arithmetic constant in a String expression * !* 74 Resolution is not the correct format * !* 75 String expression contains a sub expression * !* 76 String variable & in arithmetic expression * !* 77 String constant in arithmetic expression * !* 78 String operator '.' in arithmetic expression * !* 80 Pointer variable & compared with expression * !* 81 Pointer variable & equivalenced to expression * !* 82 & is not a pointer name * !* 83 && and & are not equivalent in type * !* 86 Global pointer && equivalenced to local & * !* 87 %FORMAT name & use in expression * !* 90 Untyped name & used in expression * !* 91 %FOR control variable & not integer * !* 92 %FOR clause has zero step * !* 93 %FOR clause has noninteger number of traverses * !* 95 Name & not valid in assembler * !* 96 Operand # not valid in assembler * !* 97 Assembler construction not valid * !* 98 Addressability * !* 99 Facility not supported by target hardware * !* 101 Source line has too many continuations * !* 102 Workfile of # Kbytes is too small * !* 103 Dictionary completely full * !* 104 Dictionary completely full * !* 105 Too many textual levels * !* 106 String constant too long * !* 107 Compiler tables are completely full * !* 108 Condition too complicated * !* 109 Compiler inconsistent * !* 110 Input ended * !* 201 Long integers are inefficient as subscripts * !* 202 Name & not used * !* 203 Label & not used * !* 204 Global %FOR control variable & * !* 205 Name & not addressable * !* 206 Semicolon in comment text * !* 207 %CONSTANT variable & not initialised * !* 208 Unsupported precision used - nearest available substituted * !* 209 Target machine is word addressed? * !* 210 Redundant %ALIAS provided * !* 255 SEE IMP MANUAL * !*********************************************************************** %CONSTBYTEINTEGERARRAY OUTTT(0:63)='?','A','B','C','D','E','F','G', 'H','I','J','K','L','M','N', 'O','P','Q','R','S','T','U', 'V','W','X','Y','Z','&','-', '/','''','(',')', 'a','b','c','d','e','f','g', 'h','i','j','k','l','m','n', 'o','p','q','r','s','t','u', 'v','w','x','y','z','.','%', '#','?'(2) %CONSTINTEGER WORDMAX= 780,DEFAULT= 776 %CONSTHALFINTEGERARRAY WORD(0:WORDMAX)=0,%C 1, 32769, 32771, 32772, 32773, 2, 32775, 32776, 32777, 32778, 32780, 32781, 32782, 32783, 32784, 4, 32776, 32771, 32772, 32785, 32786, 32788, 32789, 32790, 32792, 32794, 5, 32786, 32788, 32776, 32782, 32795, 32797, 32798, 6, 32786, 32800, 32801, 32781, 32785, 32802, 32804, 7, 32805, 32776, 32777, 32778, 32780, 32806, 8, 32808, 32797, 32810, 32776, 32777, 32811, 32812, 32814, 32815, 9, 32817, 32819, 32820, 32776, 32821, 32782, 32823, 32824, 32825, 10, 32808, 32797, 32810, 32776, 32777, 32828, 32812, 32814, 32815, 11, 32775, 32776, 32829, 32789, 32831, 32819, 32777, 32772, 32780, 32781, 12, 32832, 32789, 32831, 32819, 32777, 32834, 32835, 32837, 13, 32769, 32839, 32832, 32789, 32831, 32819, 32771, 32840, 14, 32842, 32771, 32772, 32773, 15, 32819, 32843, 32844, 32840, 16, 32805, 32776, 32777, 32772, 32780, 32806, 17, 32805, 32776, 32845, 32772, 32846, 32812, 32797, 32848, 18, 32819, 32850, 32851, 32812, 32852, 32839, 32776, 19, 32819, 32850, 32854, 32812, 32852, 32839, 32776, 20, 32819, 32850, 32851, 32848, 32852, 32839, 32855, 32776, 21, 32819, 32850, 32854, 32848, 32852, 32839, 32855, 32776, 22, 32856, 32858, 32819, 32820, 32776, 32860, 32862, 32825, 23, 32808, 32788, 32776, 32782, 32863, 32795, 24, 32864, 32866, 32777, 32868, 32869, 25, 32868, 32795, 32782, 32871, 32873, 26, 32819, 32771, 32772, 32785, 32875, 32876, 32878, 27, 32776, 32771, 32772, 32785, 32880, 32788, 28, 32808, 32797, 32810, 32776, 32777, 32825, 32882, 32883, 32884, 29, 32885, 32788, 32776, 32772, 32782, 32795, 30, 32887, 32889, 32880, 32884, 31, 32891, 32889, 32810, 32797, 32893, 32884, 34, 32894, 32854, 32792, 32895, 37, 32897, 32776, 32777, 32850, 32854, 32898, 38, 32897, 32776, 32777, 32900, 32901, 32819, 32902, 32814, 32903, 32901, 39, 32904, 32820, 32897, 32776, 32771, 32811, 32814, 32905, 32907, 40, 32908, 32771, 32772, 32789, 32911, 32820, 32784, 41, 32912, 32914, 32916, 32917, 32789, 32919, 32804, 42, 32819, 32771, 32863, 32921, 32923, 32925, 43, 32927, 32788, 32776, 32772, 32782, 32795, 44, 32929, 32931, 32933, 32776, 32936, 32819, 32937, 45, 32897, 32933, 32937, 32938, 32940, 32937, 32941, 32819, 46, 32929, 32942, 32944, 32797, 32946, 32948, 47, 32949, 32778, 32941, 32789, 32831, 32819, 48, 32949, 32921, 32936, 32950, 32876, 49, 32951, 32953, 32954, 32944, 32797, 32956, 32776, 50, 32958, 32820, 32819, 32771, 32889, 32960, 32961, 32820, 32776, 51, 32963, 32771, 32772, 32773, 52, 32769, 32965, 32820, 32963, 32839, 32967, 32789, 32831, 32819, 53, 32963, 32839, 32967, 32789, 32831, 32819, 32771, 32840, 54, 32969, 32889, 32832, 32769, 32884, 55, 32970, 32889, 32832, 32769, 32884, 56, 32972, 32776, 32789, 32976, 32792, 32794, 57, 32977, 32979, 32981, 32789, 32792, 32794, 32982, 58, 32983, 32985, 32986, 32988, 59, 32963, 32965, 32820, 32769, 32839, 32832, 32789, 32831, 32819, 61, 32805, 32776, 32777, 32778, 32780, 32990, 32782, 32783, 32956, 62, 32776, 32771, 32772, 32785, 32991, 32797, 32991, 32956, 32788, 63, 32991, 32993, 32771, 32995, 32814, 32819, 32907, 64, 32805, 32776, 32997, 32785, 32999, 32782, 32783, 32873, 65, 33001, 32776, 32771, 32772, 32782, 32960, 32991, 32956, 66, 33003, 33005, 32953, 33007, 32776, 67, 33009, 33011, 33012, 32776, 33013, 33014, 33016, 69, 33001, 33011, 32771, 33018, 32953, 32776, 33020, 32771, 32772, 32820, 32823, 32991, 70, 33021, 33023, 32777, 32921, 33026, 32993, 32820, 32819, 71, 32776, 32771, 32772, 32785, 33021, 32946, 72, 33027, 32866, 32782, 32785, 33021, 32795, 73, 33027, 32931, 32782, 32785, 33021, 32795, 74, 33029, 32771, 32772, 32960, 33031, 33033, 75, 33021, 32795, 33035, 32785, 33037, 32795, 76, 33021, 32946, 32776, 32782, 33038, 32795, 77, 33021, 32931, 32782, 33038, 32795, 78, 33021, 32866, 33040, 32782, 33038, 32795, 80, 33041, 32946, 32776, 33043, 32862, 32795, 81, 33041, 32946, 32776, 33045, 32953, 32795, 82, 32776, 32771, 32772, 32785, 33048, 32788, 83, 33011, 33012, 32776, 32844, 32772, 33050, 32782, 32823, 86, 33052, 33048, 33011, 33045, 32953, 33054, 32776, 87, 32956, 32788, 32776, 33055, 32782, 32795, 90, 33056, 32788, 32776, 32990, 32782, 32795, 91, 33058, 32835, 32946, 32776, 32772, 32871, 92, 33058, 33059, 32777, 32982, 33061, 93, 33058, 33059, 32777, 33062, 32878, 32820, 33064, 90, 33056, 32788, 32776, 32990, 33066, 32946, 95, 32805, 32776, 32772, 32875, 32782, 33067, 96, 33069, 32819, 32772, 32875, 32782, 33067, 97, 33071, 33073, 32772, 32875, 98, 33076, 99, 33079, 32772, 33081, 33083, 33084, 33086, 101, 33088, 32831, 32777, 32850, 32854, 33090, 102, 33093, 32820, 32819, 33095, 32771, 32850, 33097, 103, 33098, 33100, 33102, 104, 33098, 33100, 33102, 105, 32894, 32854, 32792, 32895, 106, 33021, 32931, 32850, 33103, 107, 33104, 33106, 32844, 33100, 33102, 108, 33108, 32850, 33110, 109, 33104, 33113, 110, 33116, 33117, 201, 33118, 33119, 32844, 33121, 33066, 32848, 202, 32805, 32776, 32772, 32990, 203, 32775, 32776, 32772, 32990, 204, 33052, 33058, 32835, 32946, 32776, 205, 32805, 32776, 32772, 33124, 206, 33127, 32782, 33129, 33131, 207, 32927, 32946, 32776, 32772, 33132, 208, 33135, 33138, 32990, 33140, 33141, 33143, 33145, 209, 33148, 33150, 32771, 33152, 33153, 210, 33155, 33157, 32852, 255, 33159, 33160, 33161, 0 %CONSTINTEGERARRAY LETT(0: 394)=0,%C X'7890A80B',X'02A00000',X'53980000',X'5D7E8000', X'652E3AD3',X'652C8000',X'190C52D8',X'36000000', X'510E6000',X'436652C3',X'49C80000',X'452CB700', X'672E8000',X'53700000',X'69453980',X'4565F1D6', X'42000000',X'27BD3A47',X'50000000',X'5D0DB280', X'43A00000',X'47AE594B',X'5DA00000',X'692F1A6B', X'43600000',X'592ED2D8',X'4BC6194B',X'679D37DC', X'5F900000',X'439E74CF',X'5D6CB768',X'590C52D8', X'36FFB000',X'672C77DD',X'48000000',X'694DB280', X'1D0DB280',X'492C7643',X'652C8000',X'257EBA53', X'5D280000',X'4D700000',X'5B7E5280',X'610E50DB', X'4BA4B966',X'69443700',X'6784B1D3',X'4D4CB200', X'210E50DB',X'4BA4B900',X'7A000000',X'5F300000', X'494CD34B',X'65980000',X'69CE1280',X'4D95F680', X'6784B1D3',X'4D4C70E9',X'537DC000',X'4D2EF2E4', X'652CD2E5',X'4B7472C8',X'594DD280',X'781B2199', X'0A000000',X'69BDE000',X'477DDA65',X'5F600000', X'47643AE7',X'4B980000',X'4D7E4000',X'5B4E79D3', X'5D380000',X'7829C200',X'7829C266',X'4394A000', X'497CB980',X'652E3AD3',X'65280000',X'67AC59C7', X'654E1A66',X'697DE000',X'4D2EE000',X'6195FB53', X'492C8000',X'5B0DDC80',X'439650F2',X'031E9AC3', X'58000000',X'610E50DB',X'4BA4B900',X'477DD359', X'531E9980',X'6F4E9400',X'43700000',X'137692CF', X'4B900000',X'5F84B943',X'697E4000',X'252C3600', X'5F84B943',X'5D266000',X'537692CF',X'4B900000', X'477DDA4B',X'71A00000',X'6D0D94C8',X'782AC29D', X'28000000',X'5DADB14B',X'64000000',X'657EBA53', X'5D280000',X'45AE8000',X'5D780000',X'457C9C80', X'7832A707',X'2849E700',X'7890AA2B',X'24700000', X'5FAE9BD3',X'69400000',X'7890A9AB',X'18A00000', X'5B0E0000',X'297DE000',X'592ED2D9',X'66000000', X'039650F2',X'494DB2DD',X'674DF766',X'6B8612E4', X'457EB748',X'592E7980',X'597EF2E4',X'274F5280', X'30F0C30D',X'0C30CF00',X'45CE92E6',X'092C7643', X'650E94DF',X'5C000000',X'512C3200',X'077DD9E9', X'43768000',X'470DD75F',X'68000000',X'45280000', X'4BB4366B',X'43A4B200',X'477DB853',X'59280000', X'5376D0D9',X'53200000',X'652E12E9',X'53A537DC', X'4D0C7A5F',X'64000000',X'7819E727',X'2809CA00', X'1376D0D9',X'53200000',X'477DD9E9',X'43768000', X'53753A53',X'436539D3',X'5D380000',X'433692E4', X'53A4B6E6',X'4BC612C7',X'692C8000',X'7BE80000', X'4F4ED2DC',X'782B0A0B',X'24702600',X'782B0A25', X'12726486',X'6D0E54C3',X'4564A000',X'789A0286', X'7829898A',X'7879C000',X'03A692DB',X'61A00000', X'69780000',X'53753A53',X'436539CA',X'7831E91B', X'02A00000',X'27AC59C7',X'654E1A00',X'6944A000', X'457EB749',X'66000000',X'78312713',X'26400000', X'53767A4B',X'43200000',X'789A80A5',X'28000000', X'782B04A8',X'7819E729',X'1272A280',X'782B0A0B', X'24702625',X'1EAA849D',X'0A000000',X'6F95F74E', X'0BC4B1EB',X'690C564A',X'67A43A4B',X'5B2DDA00', X'4D7EB748',X'752E5780',X'2195F3E5',X'43680000', X'436DF74E',X'4BC692E5',X'5D0D8000',X'657EBA53', X'5D2E6000',X'6B9CB200',X'7890A19F',X'24200000', X'592DD3E9',X'50000000',X'4F94B0E9',X'4B900000', X'652E3AD3',X'652E6000',X'67AC5743',X'5B280000', X'27AC5743',X'5B280000',X'0BC6194B',X'679D37DC', X'439E74CF',X'5D2C8000',X'652C77E5',X'48000000', X'252C77E5',X'49980000',X'36D80000',X'43748000', X'510ED280',X'494CD34B',X'652DDA00',X'4D7E56C3', X'69980000',X'43A690C7',X'512C8000',X'6F4531D0', X'27A654DD',X'4E000000',X'492C7643',X'650E94DF', X'5C000000',X'5B0F0000',X'03953A51',X'5B2E94C6', X'252E77D9',X'6BA537DC',X'477E594B',X'47A00000', X'4D7E56C3',X'68000000',X'477DDA43',X'53766000', X'67AC4000',X'43953A51',X'5B2E94C6',X'3DDBC000', X'217D3769',X'4B900000',X'477DB843',X'652C8000', X'4B8EB4ED',X'4364B747',X'4B200000',X'617D3769', X'4B900000',X'4B8EB4ED',X'4364B768',X'0F65F143', X'58000000',X'597C70D8',X'6B9CA000',X'2B769CE1', X'4B200000',X'7831E900',X'47643AE7',X'4A000000', X'67A4B800',X'5D7DD4DD',X'692CF2E4',X'69943B4B', X'659CB980',X'43980000',X'439E72DB',X'4564B900', X'1F84B943',X'5D200000',X'039E72DB',X'4564B900', X'477DD9E9',X'65AC7A53',X'5F700000',X'0324994B', X'679C3153',X'594E9C80',X'0D0C74D9',X'53A72000', X'67AE185F',X'65A4B200',X'45C80000',X'690E53CB', X'68000000',X'510E526F',X'4394A000',X'277EB947', X'4A000000',X'477DDA53',X'5DAC3A53',X'5F766000', X'2F7E55CD',X'5364A000',X'17173A4B',X'66000000', X'676C3658',X'094C7A53',X'5F743972',X'477DB859', X'4BA4B672',X'4DAD9600',X'597DD380',X'077DB853', X'592E4000',X'690C564B',X'66000000',X'077DD253', X'694DF700',X'477DB859',X'531C3A4B',X'48000000', X'537477DD',X'674E7A4B',X'5DA00000',X'13761AE8', X'4B7492C8',X'197DD380',X'537692CF',X'4B966000', X'5374B34D',X'531D32DD',X'68000000',X'4324994B', X'679C3159',X'4A000000',X'272DB4C7',X'5F65F700', X'477DB6CB',X'5DA00000',X'692F1A00',X'53753A53', X'436539CB',X'48000000',X'2B767AE1',X'617E5A4B', X'48000000',X'6194B1D3',X'674DF700',X'38000000', X'5D2C394B',X'67A00000',X'43B434D9',X'43159280', X'67AC59E9',X'53A6BA4B',X'48000000',X'290E53CB', X'68000000',X'5B0C7453',X'5D280000',X'6F7E5200', X'4324994B',X'679CB27E',X'252C9ADD',X'490DDA00', X'78098483',X'26000000',X'2628A000',X'126A0000', X'1A09CA83',X'18000000' %INTEGER I,J,K,M,Q,S %STRING(70)OMESS OMESS=" " %CYCLE I=1,1,WORDMAX-1 ->FOUND %IF N=WORD(I) %REPEAT I=DEFAULT FOUND: J=1 %CYCLE K=WORD(I+J) %IF K&X'8000'=0 %THEN %EXIT K=K&X'7FFF' OMESS=OMESS." " %UNLESS J=1 %UNTIL M&1=0 %CYCLE M=LETT(K); S=25 %UNTIL S<0 %CYCLE Q=M>>S&63; %IF Q\=0 %THEN OMESS=OMESS.TOSTRING(OUTTT(Q)) S=S-6 %REPEAT K=K+1 %REPEAT J=J+1 %REPEAT %RESULT=OMESS %END %STRING(16)%FN SWRITE(%INTEGER VALUE, PLACES) %STRING (16) S %STRING(1)SIGN %INTEGER D0, D1, D2 PLACES=PLACES&15 SIGN=" " S="" %IF VALUE<0 %THEN SIGN="-" %AND VALUE=-VALUE D0=VALUE %CYCLE D1=D0//10 D2=D0-10*D1 S=TOSTRING(D2+'0').S D0=D1 %REPEAT %UNTIL D0=0 S=SIGN.S S=" ".S %WHILE BYTEINTEGER(ADDR(S))<=PLACES %RESULT=S %END %EXTERNALROUTINE FAULT(%INTEGER N, DATA, IDENT) !*********************************************************************** !* SETS UP AN ERROR MESSAGE AND SHOVES IT OUT ONTO THE LISTING * !* AN ALSO OPTIONALLY TO THE TERMINAL * !*********************************************************************** %INTEGER I, J, S, T, Q, QMAX, LENGTH %STRING(255)MESS1,MESS2,WK1,WK2 !*DELSTART %MONITOR %IF PARM_FAULTY=0 %AND (PARM_SMAP#0 %OR PARM_DCOMP#0) !*DELEND MESS1=""; MESS2="" PARM_FAULTY=PARM_FAULTY+1 %IF N=100 %THEN %START; ! SYNTAX FAULTS ARE SPECIAL MESS1=" * Failed to analyse line ".SWRITE(WORKA_LINE,2)." " J=0; S=0; T=0; Q=DATA; QMAX=IDENT>>16 LENGTH=IDENT&X'FFFF' %UNTIL (J=';' %AND Q>QMAX) %OR Q=LENGTH %CYCLE I=J; J=WORKA_CC(Q); ! DATA HAS START OF LINE POSN %IF J>128 %AND I<128 %THEN MESS2=MESS2." %" %AND T=T+2 %IF I>128 %AND J<128 %THEN MESS2=MESS2." " %AND T=T+1 MESS2=MESS2.TOSTRING(J) T=T+1 %IF Q=QMAX %THEN S=T Q=Q+1 %EXIT %IF T>=250 %REPEAT %IF Q=QMAX %THEN S=T %FINISH %ELSE %START MESS1=" *".SWRITE(WORKA_LINE, 4)." " PARM_OPT=1 PARM_INHCODE=1 %IF PARM_LET=0; ! STOP GENERATING CODE MESS1=MESS1."FAULT".SWRITE(N,2) MESS2=MESSAGE(N) %IF MESS2->WK1.("##").WK2 %THEN %C MESS2=WK1.SWRITE(IDENT,1).WK2 %IF MESS2->WK1.("#").WK2 %THEN %C MESS2=WK1.SWRITE(DATA,1).WK2 %IF MESS2->WK1.("&&").WK2 %THEN %C MESS2=WK1.PRINTNAME(DATA).WK2 %IF MESS2->WK1.("&").WK2 %THEN %C MESS2=WK1.PRINTNAME(IDENT).WK2 %IF N>100 %THEN MESS2=MESS2." Disaster" %FINISH %CYCLE I=2,-1,1 SELECT OUTPUT(PARM_TTOPUT) %IF I=1 PRINTSTRING(MESS1) PRINTSTRING(MESS2) %IF MESS2#"" %IF N=100 %AND S<115 %THEN %START NEWLINE; SPACES(S+4); PRINTSYMBOL('!') %FINISH NEWLINE SELECT OUTPUT(82) %IF I=1 %EXIT %IF PARM_TTOPUT<=0 %REPEAT %IF N=109 %THEN %MONITOR ! %IF N=109 %THEN PARM_DCOMP=1 %AND CODEOUT %IF N>100 %THEN %STOP %END %EXTERNALROUTINE WARN(%INTEGER N,V) %STRING(30) T; %STRING(120) S S=MESSAGE(N+200) %IF S->S.("&").T %THEN S=S.PRINTNAME(V).T PRINTSTRING(" ? Warning :- ".S." at line No".SWRITE(WORKA_LINE,1)) NEWLINE %END %ENDOFFILE