head 1.6; access; symbols; locks gtoal:1.6; strict; comment @# @; 1.6 date 2022.08.18.07.15.56; author gtoal; state Exp; branches; next 1.5; 1.5 date 2022.08.18.00.07.22; author gtoal; state Exp; branches; next 1.4; 1.4 date 2022.08.17.23.48.51; author gtoal; state Exp; branches; next 1.3; 1.3 date 2022.08.17.22.06.47; author gtoal; state Exp; branches; next 1.2; 1.2 date 2022.08.17.05.51.35; author gtoal; state Exp; branches; next 1.1; 1.1 date 2022.08.17.05.50.48; author gtoal; state Exp; branches; next ; desc @Pass 1 of Peter Stephens' Imp to C converter @ 1.6 log @*** empty log message *** @ text @!* rs6p104 !* 21/12/92 - Changes to correctly number include file lines(pds) !* rs6p102.i !* 30/08/89 - changes incorporated (ex Sun3 version) to get source !* directly from buffer using Consource since read symbol !* is not supported (gm) !* m88p102 !* 29/08/89 - original from pds (m88p102s on emas) !* !!{GT:}%include "hostcodes.inc" %CONSTINTEGER YES=1,NO=0 ! ! THESE CODE ARE ARBITARY BUT THE TOP DECIMAL DIGIT GIVES THE NO OF BYTES ! IN THE UNIT OF ADDRESSABILITY. BYTE ADDRESSED HOSTS BEING 1N ( also 0N) AND ! 16 BIT WORD ADDRESSED HOSTS BEING 2N ETC %CONSTINTEGER PENTIUM=4; ! PENTIUM chip Unix stack and completely swopped %constinteger MIPS=05; ! Imp on MIPS (all variants) %CONSTINTEGER RS6=06; ! imp on IBM rs6000 %CONSTINTEGER M88K=07; ! Imp on all forms of 88k ! also serves for Sparc sinc there is a common b-e %CONSTINTEGER VAX=08; ! Imp on Vax using F & G formats %CONSTINTEGER UNISYS=09; ! Imp on UnisSys. Unix stack unswopped Vax reals %CONSTINTEGER EMAS=10; ! emas on 2900 (unsigned shorts) %CONSTINTEGER IBM=11; ! emas on 24 bit ibm hardware %CONSTINTEGER IBMXA=12; ! emas of XA 31 bit hardware %CONSTINTEGER WWC=13; ! WWc (Natsemi chip) completely swopped %CONSTINTEGER AMDAHL=14; ! Emas on Amdahls guess at Xa Minor differences fron IBM) %CONSTINTEGER PERQ3=15; ! ICL packaged 68k chip Unix stack but not swopped %CONSTINTEGER GOULD=16; ! Gould unswopped forward stack. Needs 4&8 byte alined %CONSTINTEGER VNS=17; ! Unix on 2900 unsigned shorts params as ! 2900. Long int available but not in Ecode %CONSTINTEGER EAMD=18; ! Amdahl via the Emachine %CONSTINTEGER DRS=19; ! Intel chip Unix stack and mostly swopped %CONSTINTEGER PERQ=20; ! Pos perq now obselete. Fully swopped forward stack %CONSTINTEGER PNX=21; ! ICL's perq2 Unix stack byte swopped (unsigned shorts) %CONSTINTEGER ACCENT=22; ! Perq 1 under accent. obsolete now ! ACCENT DIFFERS FROM PERQ ONLY IN ! ASSEMBLES SEQUENCES&SYNTAX ! AND GENERATOR %constinteger ORN=23 %CONSTINTEGER UNSIGNEDSHORTS = 1<>1 %INTEGERARRAY Downptr,SFS(0:MAXLEVELS) %BYTEINTEGERARRAYFORMAT LETTF(0:DSIZE+20) %BYTEINTEGERARRAYNAME LETT %BYTEINTEGERARRAY TLINE(0:2047) %CONSTBYTEINTEGERARRAY ILETT(0: 532)= 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', 5,'T','R','U','N','C',255; !* %byteintegerarrayformat inbuffm(0:4095) %ownbyteintegerarrayname inbuf %owninteger inptr=4095 %owninteger dataad !* LETT==ARRAY(ADDR(A(ARSIZE-DSIZE-20)),LETTF) ARSIZE=ARSIZE-DSIZE-300 !* dataad = malloc(4096) inbuf == array(dataad, inbuffm) !* 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>>7&1; ! PROFILE BIT parm_prof=0 %if parm_map#0; ! Cant profile funny listint PARM_DYNAMIC=I>>20&1 PARM_LET=I>>13&1 PARM_DCOMP=I>>14&1; ! PARM CODE OR D PARM_DBUG=I>>18&1 PARM_QUOTES=I&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 %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) ! %if target=MIPS %or Target=M88K %then printstring(assprefix) SPACES(4) PRINTSTRING("/* EPC Imp to C Translation ") PRINTSTRING("Release") WRITE(WORKA_RELEASE,1) PRINTSTRING(" Version ".WORKA_LADATE." */") NEWLINES(3) printstring("#include ""imptoc.h"" ") ! %if target=MIPS %or Target=M88k %then printstring(assprefix) ! 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)!32 %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) %exit %if snum>no of sns %REPEAT ! ! The idea of the above exit is to allow further special names to be added ! without preventing the rebuilds of compilers that do not support the extra facilities ! Until no of sns is increased in the steering consts the new names are ignored ! %END ! LINE=0; LLENGTH=0; Q=1 R=1; LEVEL=1 %CYCLE curlinead=file addr+fileptr %IF Q>=LLENGTH %THEN QMAX=1 %AND READ LINE(0,0) %if llength=-1 { no more input} %then %exit STARSTART=R R=R+3 A(R)=LINE>>8 A(R+1)=LINE&255 R=R+2 movebytes(4,addr(curlinead),0,addr(a(0)),r) r=r+4 %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+9)=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+9)=ENDALT %AND 1<=A(STARSTART+10)<=2 %START;! ENDOF PROG OR FILE %IF IHEAD=0 %THEN %EXIT llength=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 move bytes(next+1,addr(lett(0)),0,addr(a(0)),r) 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 free(dataad) %FINISH %ELSE %START PRINTSTRING("C GENERATION NOT ATTEMPTED ") %FINISH %RESULT=R %ROUTINE NEWSOURCE(%INTEGER NEWFILEADDR) !*********************************************************************** !* SETS UP COMPILER TO USE AN INCLUDED SOURCE FILES * !*********************************************************************** %externalinteger filesseen=0 PUSH(IHEAD,FILEADDR,FILEPTR,LINE) FILEADDR=NEWFILEADDR HDR==RECORD(FILEADDR) SOURCE==ARRAY(FILEADDR,SRCEF) FILEPTR=HDR_STARTRA FILEEND=HDR_ENDRA IDEPTH=IDEPTH+1 filesseen=filesseen+1 %IF PARM_MAP#0 %THEN LINE=18000+2000*filesseen %END %integerfn OLDSOURCE !*********************************************************************** !* UNDOES THE ABOVE !*********************************************************************** %INTEGER ALT LINE %IF IHEAD#0 %THEN %START POP(IHEAD,FILEADDR,FILEPTR,ALTLINE) %if Fileaddr#0 %start; ! if it was mapped remap HDR==RECORD(FILEADDR) FILEEND=HDR_ENDRA SOURCE==ARRAY(FILEADDR,SRCEF) %finish %IF PARM_MAP#0 %THEN LINE=ALT LINE IDEPTH=IDEPTH-1 %result=1 %FINISH %ELSE %result=0 %END %ROUTINE READ LINE(%INTEGER MODE,CHAR) %integerfnSPEC GET LINE %INTEGER DEL, LL, LP, PREV, LASTC, PPREV, LASTNS, i,j LL=0; LP=0; PREV=0; Q=1 LLENGTH=0; DEL=0; LASTC=-1; ! NO CONTINUATIONS AS YET NEXT: LP=LP+1 %IF LP>LL %THEN lp=GET LINE %if lp=0 %then llength=-1 %and %return 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 %while I='/' %and tline(lp+1)='*' %cycle %cycle pprev=prev; prev=i; lp=lp+1 i=tline(lp); %repeat %until i=nl %or (prev='/' %and pprev='*') %repeat %IF I='%' %THEN DEL=128 %AND ->NEXT ! %if parm_quotes#0 %then i=onecase(i+128) %else I=ONE CASE(I) %IF 'A'<=I<='Z' %THEN %start I=I!DEL %finish %else %if 'a'<=i<='z' %then %start %if del#0 %then i=(i-32)!DEL %else 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 j=LLENGTH LASTNS=CC(LLENGTH-1) %while LASTNS=' ' %cycle { Dont allow trailing spaces to trip us up} j=j-1 LASTNS=CC(j-1) %repeat %IF LLENGTH-1=LASTC %THEN LLENGTH=LASTC %AND ->NEXT %IF LASTNS='C'+128 %THEN %start CC(j-1)=' ' { obliterate %c with space } LLENGTH=LLENGTH-1 LASTC=LLENGTH ->NEXT %finish %IF MODE=0 %AND LASTNS='\' %THEN cc(LLENGTH)=13 %and LASTC=LLENGTH %AND ->NEXT %IF MODE=0 %AND LASTNS=',' %THEN LLENGTH=LLENGTH-1 %AND LASTC=LLENGTH %AND ->NEXT FAULT(101,0,0) %IF LLENGTH>WORKA_CCSIZE %RETURN %integerfn GET LINE %externalintegerspec SrcId %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 { Since there is no support for read symbol, use } { Unix block read which is faster anyway. } { READ SYMBOL(K) } inptr = inptr + 1 %if inptr = 4096 %thenstart k = fileread(SrcId, addr(inbuf(0)), 4096) inptr = 0 %finish k = inbuf(inptr) TLINE(LL+1)=ITOI(K) LL=LL+1 %REPEAT curlinead=0 %FINISH %ELSE %START %IF FILEPTR>=FILE END %START %if OLD SOURCE=0 %then %result=0; ! RESET SOURCE FILES %result=GETLINE %FINISH ! curlinead=file addr+fileptr %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 %while ll>1 %and TLINE(ll-1)=' ' %cycle { deal with trailing spaces } TLINE(LL-1)=TLINE(LL) LL=LL-1 %repeat 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) %IF HOST=ACCENT %or ll>255 %THEN %START PRINT SYMBOL(TLINE(K)) %FOR K=1,1,LL %ELSE tline(0)=ll printstring(string(ADDR(TLINE(0)))) %finish %FINISH ! %IF PARM_FREE=0 %AND LL>73 %THEN TLINE(73)=10 %AND LL=73 %result=1 { line got OK} %END { GET LINE | %END { READ LINE } %integerfn next nonspace %integer i i=cc(q) q=q+1 %and i=cc(q) %while i=' ' %result=i %end %INTEGERFN COMPARE(%INTEGER P) %INTEGER I, J, ITEM, RA, RL, RP, RQ, RR, RS, MARKER, SSL, ALT, PP, nbochar %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 !printstring("testing item&sym"); write(item,4); space; printsymbol(nextnonspace&127); ! write(q,5); ! write(nextnonspace,4); newline %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=next nonspace; ! 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 next nonspace=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=next nonspace; ! 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 EVALCONST(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=next nonspace; ! OBTAIN CURRENT CHARACTER ->FAIL %UNLESS '0'<=I<='9' S=0 %WHILE '0'<=I<='9' %CYCLE S=10*S+I&15 Q=Q+1; I=next nonspace %REPEAT A(R)<-S>>8; A(R+1)=S&255 R=R+2 ->SUCC BIP(1006): ! PHRASE S=SEPARATOR I=next nonspace; ! OBTAIN CURRENT CHARACTER a(r)=I; r=r+1 ->SUCC %IF I=NL ->FAIL %UNLESS I=';' Q=Q+1 ->SUCC BIP(1007): ! PHRASE COMMENT TEXT I=next nonspace; ! OBTAIN CURRENT CHARACTER %IF I='#' %THEN %start a(r)=1; r=r+1 Q=Q+1 ->COMFOUND %finish %IF I='!' %THEN %start a(r)=2; r=r+1 Q=Q+1 ->COMFOUND %finish ->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 a(r)=3; r=r+1 COMFOUND: J=CC(Q) %CYCLE a(r)=j; r=r+1 %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=next nonspace; ! OBTAIN CURRENT CHARACTER ->FAIL %UNLESS '0'<=I<='9' S=0 %WHILE '0'<=I<='9' %CYCLE S=10*S+I&15 Q=Q+1; I=next nonspace %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 read line? I=next nonspace; ! OBTAIN CURRENT CHARACTER %WHILE I=NL %%CYCLE %if llength=-1 %then fault(110,0,0) read line(0,0) RQ=1 I=next nonspace %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 %if level>1 %then a(downptr(level))=1; ! flag down in enclosing blk LEVEL=LEVEL+1 SFS(LEVEL)=0 Downptr(level)=r ->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=next nonspace; ! OBTAIN CURRENT CHARACTER J=0 NEM="123456789abcdef" %WHILE 'A'<=I<='Z' %OR '0'<=I<='9' %CYCLE J=J+1 %if j>=15 %then ->fail CHARNO(NEM,J)=I Q=Q+1; I=next nonspace %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=ACCENT %or %c target=drs %or target=wwc %or target=perq3) %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=next nonspace; ! 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=next nonspace %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=next nonspace; ! 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=next nonspace; ! 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=next nonspace; ! 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=next nonspace; ! 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=next nonspace; ! OBTAIN CURRENT CHARACTER ->FAIL %UNLESS 32>(I&31)&X'1004000E'#0 ! '='=1,'>='=2,'>'=3 ! '#' OR '\=' OR '<>'=4 ! '<='=5,'<'=6 ! 7UNUSED,'->'=8,'=='=9 ! '##' OR '\==' =10 q=q+1; nbochar=next nonspace %IF I='=' %THEN %START %IF nbochar=I %THEN J=9 %AND ->JOIN1 J=1 ->JOIN %FINISH %IF I='#' %THEN %START %IF nbochar=I %THEN J=10 %AND ->JOIN1 J=4 ->JOIN %FINISH %IF I='\' %AND nbochar='=' %THEN %START Q=Q+1 %IF next nonspace='=' %THEN J=10 %AND ->JOIN1 J=4 ->JOIN %FINISH %IF I='>' %THEN %START %IF nbochar='=' %THEN J=2 %AND ->JOIN1 J=3 ->JOIN %FINISH %IF I='<' %THEN %START %IF nbochar='>' %THEN J=4 %AND ->JOIN1 %IF nbochar='=' %THEN J=5 %AND ->JOIN1 J=6 ->JOIN %FINISH %IF I='-' %AND nbochar='>' %THEN J=8 %AND ->JOIN1 ->FAIL JOIN1:Q=Q+1 JOIN: 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 THEY ! CAN BE NESTED! BIP(1033): ! P(ASSOP)- ==,=,<-,-> I=next nonspace q=q+1; nbochar=next nonspace %if i='=' %then %start %if nbochar='=' %then A(R)=1 %AND Q=Q+1 %AND ->UPR A(R)=2 ->UPR %FINISH %IF I='<' %AND nbochar='-' %THEN A(R)=3 %AND Q=Q+1 %AND ->UPR %IF I='-' %AND nbochar='>' %THEN A(R)=4 %AND Q=Q+1 %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=next nonspace ->FAIL %UNLESS I=NL %OR I=';' Q=Q+1 %IF I=';' ->FAIL %UNLESS CTYPE=5 %AND (Host#emas %or A(S)<=31) %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) {#}%if host=Vax %Start %unless fname->(".") %then fname=fname.".INC" {#}%finish CONSOURCE(FNAME,J) NEWSOURCE(J) %END ->succ 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=next nonspace %CYCLE Q=Q+1 %EXIT %IF I=NL %OR I=';' I=next nonspace %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=next nonspace q=q+1 %RETURN %UNLESS TRTAB(FS)=2 %AND M'"'#next nonspace#M'''' ! 1ST CHAR MUST BE LETTER %if PARM_QUOTES=0 %then FS=FS!32 T=1 LETT(NEXT+1)=FS; JJ=71*FS q=q-1 %CYCLE Q=Q+1 I=next nonspace %EXIT %IF TRTAB(I)=0 %if PARM_QUOTES=0 %then I=I!32 JJ=JJ+HASH(T)*I %IF T<=7 T=T+1 LETT(NEXT+T)=I %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 { PNAME } %ROUTINE EVALCONST(%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, J, nbochar, QQ %integer hexformat %integerarray rhexpat(0:3) %constinteger powerl=75 {#}%IF 1<N %IF M'0'<=FS<=M'9' ->DOT %IF FS='.' %AND MODE=0 %AND '0'<=nbo char<='9' ! 1 DIDT MIN CTYPE=1; EBCDIC=0 ->QUOTE %IF FS=M'''' ->STR2 %IF FS=34 ->NOTQUOTE %UNLESS nbo char=M''''; Q=Q+2 ->HEX %IF FS='X' %or FS='x' ->MULT %IF FS='M' %or FS='m' ->BIN %IF FS=M'B' %or FS='b' ->RHEX %IF (FS='R' %or FS='H' %or FS='r' %or FS='h') %AND MODE=0 ->OCT %IF FS='K' %or FS='k' %IF FS='C' %or FS='c' %THEN EBCDIC=1 %AND ->MULT %IF (FS='D' %or FS='d') %AND MODE=0 %THEN %START CPREC=7 %IF M'0'<=next nonspace<=M'9' %THEN ->N %IF next nonspace='.' %THEN ->DOT %FINISH Q=Q-2 %RETURN QUOTE: ! SINGLE CH BETWEEN QUOTES hexformat=8; cprec=3 q=q+1; s=cc(q); q=q+1 %if s=nl %start READ LINE(1,'''') fault(110,0,0) %if llength=-1 Q=1 %finish %IF next nonspace=M'''' %THEN %START Q=Q+1 %IF S#M'''' %THEN ->IEND %IF next nonspace=M'''' %THEN Q=Q+1 %AND ->IEND %FINISH %RETURN; ! NOT VALID NOTQUOTE: ! CHECK FOR E"...." %RETURN %UNLESS FS='E' %AND nbochar=M'"' EBCDIC=1; Q=Q+1 STR2: ! DOUBLE QUOTED STRING A(RR)=X'35'; TEXTTEXT(EBCDIC) CTYPE=5; %RETURN HEX: T=0; ! HEX CONSTANTS hexformat=8 %CYCLE I=next nonspace; 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 t<17 %IF T=9 %THEN SS=S %AND S=0 S=S<<4+I&15+9*I>>6 %REPEAT %IF T>8 %START Z=4*(T-8) %unless Z=32 %then S=S!(SS<>(32-Z);! shifts modulo 31 on gould! CPREC=6 %FINISH IEND: %IF CPREC=6 %THEN %Start {#}%if 1<>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! hexformat %RETURN RHEX: ! REAL HEX CONSTANTS T=0 %CYCLE I=next nonspace; Q=Q+1 %IF T&7=0 %AND T#0 %START rhexpat(t//8-1)=s; 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 T=32 %IF T=32 %THEN CPREC=7 %ELSE CPREC=4+T//8 A(RR)=CPREC<<4!2 %if host#target %and ibmfpformat>>host&1#ibmfpformat>>target&1 %c %and FS='R'%then A(RR)=A(RR)!8; ! Flag const not to converted t=t//8-1 %for i=0,1,t %cycle {#}%if 1<IEND MULT: T=0; ! MULTIPLE CONSTANTS %CYCLE I=cc(q); Q=Q+1; T=T+1 %IF I=M'''' %THEN %START %IF next nonspace#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 hexformat=8 %CYCLE I=next nonspace; 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 hexformat=8 T=0; RADIXV=0 RS=RSHIFT(S) Q=Q+1 %CYCLE I=next nonspace %EXIT %UNLESS '0'<=I<='9' %OR 'A'<=I<='Z' %OR 'a'<=I<='z' %IF I<='9' %THEN I=I-'0' %ELSE I=I&15+9 %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 {#}%FINISH S<-RADIXV CTYPE=1 %IF SS#0 %THEN CPREC=6 ->IEND N: ! CONSTANT STARTS WITH DIGIT I=next nonspace %UNTIL IM'9' %CYCLE CVALUE=TEN*CVALUE+(I&15) Q=Q+1; I=next nonspace; ! 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; I=next nonspace DOTSEEN=1; ! CONSTANT HAS DECIMAL POINT dvalue=0; s=0 %WHILE M'0'<=I<=M'9' %CYCLE dvalue=ten*dvalue+(i&15) s=s+1 Q=Q+1; I=next nonspace %REPEAT cvalue=cvalue+(dvalue/powers(s)) ALPHA: ! TEST FOR EXPONENT %IF MODE=0 %AND next nonspace='@@' %THEN %START Q=Q+1; X=CVALUE Z=1; I=next nonspace %IF I='-' %THEN Z=-1 %IF I='+' %OR I='-' %THEN Q=Q+1 EVALCONST(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 %if powerll<=s<=powerl %start cvalue=cvalue*powers(s) %finish %else %if imod(s)<=powerl %start cvalue=cvalue/powers(-s) %finish %else %start {#}%if 1<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 %FINISH ! SEE IF IT IS INTEGER %IF FS='D' %THEN %START I=next nonspace %IF I='''' %THEN Q=Q+1 %ELSE %RETURN DOTSEEN=1; ! ENSURE NOT TAKEN AS INTEGER %FINISH %if 1<imax %start radixv=lint(cvalue) ss<-radixv>>32; s<-radixv cprec=6 ->iend %finish %IF DOTSEEN=1 %OR CVALUE>IMAX %THEN CTYPE=2 %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 cvaluep=cvalue; ! may perform a round MOVEBYTES(8,ADDR(CVALUEp),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 {evalconst} %ROUTINE TEXTTEXT(%INTEGER EBCDIC) !*********************************************************************** !* PROCESSES TEXT BETWEEN DOUBLE QUOTES AND STORES IN ISO OR EBCDIC * !*********************************************************************** %INTEGER J, II %CONSTINTEGER QU='"' I=next nonspace 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 next nonspace#QU %THEN %EXIT %FINISH %IF I=10 %THEN %start READ LINE(1,QU) fault(110,0,0) %if llength=-1 %finish %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 { texttext } %END; ! OF ROUTINE PASS ONE %ENDOFFILE @ 1.5 log @flagging conditional compilation @ text @d1163 1 a1163 1 ! //,/,>>,<<,.,\\,\ @ 1.4 log @more formatting @ text @d1741 5 a1745 1 %if 1<>32 %ELSE SS=0 d1841 8 a1848 3 %if powerll<=s<=powerl %then cvalue=cvalue*powers(s) %else %c %if imod(s)<=powerl %then cvalue=cvalue/powers(-s) %else %Start %if 1<imax %start d1871 1 d1873 1 a1873 3 %finish %IF DOTSEEN=1 %OR CVALUE>IMAX %THEN CTYPE=2 %C %ELSE CTYPE=1 %AND S=INT(CVALUE) @ 1.3 log @formatting and comments @ text @d766 1 a766 1 NEXT: d902 1 a902 1 %OWNINTEGER SAVECOMP; ! FOR CHECKING DSIDED CONDS d907 2 a908 2 PP=P; ! ROUTINE REALLY STARTS HERE COMM: d915 2 a916 2 UPR: R=R+1 SUCC: ! SUCCESS ON TO NEXT ITEM d931 1 a931 1 LIT: ! BRICK IS LITERAL d955 1 a955 1 TFAIL: d958 2 a959 1 BIP(999): ! REPEATED PHRASE d963 2 a964 1 BIP(1000):FINI: ! NULL ALWAYS LAST & OK d967 2 a968 1 BIP(1001): ! PHRASE NAME d975 2 a976 2 BIP(1002): ! PHRASE INTEGER CONSTANT BIP(1003): ! PHRASE CONST d981 1 a981 1 BIP(1004): ! PHRASE DUMMYSTART d986 1 a986 1 BIP(1005): ! PHRASE N d998 1 a998 1 BIP(1006): ! PHRASE S=SEPARATOR d1006 1 a1006 1 BIP(1007): d1013 1 a1014 1 %finish d1019 1 a1020 1 %finish d1026 1 a1026 1 COMFOUND: d1035 1 a1035 1 BIP(1008): ! PHRASE BIGHOLE d1041 1 a1041 1 BIP(1009): ! PHRASE N255 d1053 1 a1053 1 BIP(1010): ! PHRASE HOLE d1057 1 a1057 1 BIP(1011): ! PHRASE MARK d1063 1 a1063 1 BIP(1012): ! PHRASE read line? d1074 1 a1074 1 BIP(1013): ! PHRASE CHECKIMPS d1079 1 a1079 1 BIP(1014): ! PHRASE DUMMY APP d1084 1 a1084 1 BIP(1015): ! PHRASE DOWN=NEW TEXT LEVEL d1091 1 a1091 1 BIP(1016): ! PHRASE UP 1 TEXTUAL LEVEL d1100 1 a1100 1 BIP(1017): ! PHRASE LISTON d1104 1 a1104 1 BIP(1018): ! PHRASE LISTOFF d1108 1 a1108 1 BIP(1019): ! PHRASE COLON FOR LABEL d1112 1 a1112 1 BIP(1020): ! PHRASE NOTE CONST d1115 1 a1115 1 BIP(1021): ! TRACE FOR ON CONDITIONS d1119 1 a1119 1 BIP(1022): ! SET MNEMONIC d1134 1 a1134 1 BIP(1023): ! UCNOP MNEMONIC SANS OPERANDS d1144 1 a1144 1 PFND: d1148 1 a1148 1 ->SUCC; ! ALLOW MORE THAN 255 OPCODES d1150 1 a1150 1 BIP(1024): ! UCUB MNEMONIC WITH UNSIGNED BYTE OPERAND d1156 1 a1156 1 BIP(1025): ! UCUB SIGNED BYTE OPERANDS d1162 1 a1162 1 BIP(1026): ! P(OP)=+,-,&,****,**,*,!!,!, d1177 1 a1178 1 %FINISH d1183 1 a1184 1 %FINISH d1189 1 a1190 1 %FINISH d1198 1 a1199 1 %FINISH d1287 1 a1287 1 JOIN: d1308 1 a1308 1 BIP(1034): ! NOTE START d1315 1 a1315 1 BIP(1035): ! NOTE FINISH d1322 1 a1322 1 BIP(1036): ! NOTE REPEAT d1329 1 a1329 1 BIP(1038): ! INCLUDE "FILE" d1421 1 a1421 1 HOLE: %IF MODE=0 %THEN Q=FQ %AND %RETURN d1424 1 a1424 1 FND: LASTAT=FQ; HIT=1; LASTNAME=KK d1440 2 a1441 2 %IF 1<>19&1 d581 2 a582 2 PARM_PROF=I>>7&1; ! PROFILE BIT parm_prof=0 %if parm_map#0; ! Cant profile funny listint d585 1 a585 1 PARM_DCOMP=I>>14&1; ! PARM CODE OR D d589 1 a589 1 PARM_X=I>>28&1; ! DONT REFORMAT REALS FOR SIMULATOR d591 1 a591 1 PARM_Z=I>>26&1; ! USE PARMZ BIT FOR DUMPING WKFILE d597 1 a597 1 PARM_TRACE=PARM_TRACE!PARM_OPT; ! ALLOW NOTRACE ONLY WITH OPT d599 1 a599 1 ! %if target=MIPS %or Target=M88K %then printstring(assprefix) d608 3 a610 3 ! %if target=MIPS %or Target=M88k %then printstring(assprefix) ! WRITE(NNAMES,5); WRITE(WORKA_ASL MAX,5) ! NEWLINE d628 1 a628 1 %IF JJ&X'C000'#X'4000' %START; ! NOT A CONST VARAIBLE d630 1 a630 1 SNTAG_ACC=JJ; ! TRUE PTYPE HERE d655 1 a655 1 %if llength=-1 %then %exit { no more input} d670 1 a670 1 ! %IF A(STARSTART+9)=COMMALT %THEN R=STARSTART %ELSE %START d672 3 a674 3 A(STARSTART)=I>>16 A(STARSTART+1)=I>>8&255 A(STARSTART+2)=I&255 d687 1 a687 2 %IF A(STARSTART+9)=ENDALT %AND %C 1<=A(STARSTART+10)<=2 %START;! ENDOF PROG OR FILE d726 1 d742 1 d760 1 d785 2 a786 2 %IF I='%' %THEN DEL=128 %AND ->NEXT ! %if parm_quotes#0 %then i=onecase(i+128) %else I=ONE CASE(I) d793 1 a793 1 ! ->NEXT %IF I=' ' d806 1 a806 1 %while LASTNS=' ' %cycle { Dont allow trailing spaces to trip us up} d812 1 a812 1 CC(j-1)=' ' { obnliterate %c with space } d816 1 d822 2 a823 1 %%integerfn GET LINE d889 4 a892 2 %END %END d899 1 d930 1 d943 2 a944 1 FAIL: ! FAILURE - NOTE POSITION REACHD d954 1 d961 1 d969 3 a971 1 ->SUCC %IF HIT=1; ->FAIL d977 1 d982 1 d992 3 a994 1 R=R+2; ->SUCC d1000 3 a1002 1 Q=Q+1; ->SUCC d1008 3 a1010 1 Q=Q+1; ->COMFOUND d1014 3 a1016 1 Q=Q+1; ->COMFOUND d1031 1 d1037 1 d1047 3 a1049 1 A(R)=S; ->UPR d1051 3 a1053 1 MARKER=R; R=R+2; ->SUCC d1059 1 d1070 1 d1075 1 d1078 3 a1080 1 R=R+2; ->SUCC d1087 1 d1096 1 d1098 3 a1100 1 PARM_LIST=1; ->SUCC d1102 3 a1104 1 PARM_LIST=0; ->SUCC d1108 1 d1111 1 d1113 3 a1115 1 PARM_TRACE=1; ->SUCC d1130 1 d1140 1 d1144 3 a1146 1 R=R+2; ->SUCC; ! ALLOW MORE THAN 255 OPCODES d1152 1 d1156 3 a1158 1 %REPEAT; ->FAIL d1172 3 a1174 1 A(R)=5; Q=Q+1; ->UPR d1178 3 a1180 1 A(R)=9; Q=Q+1; ->UPR d1184 3 a1186 1 A(R)=7; Q=Q+1; ->UPR d1193 3 a1195 1 Q=Q+1; A(R)=14; ->UPR d1198 2 a1199 1 BIP(1027): ! PHRASE CHECK UI d1204 2 a1205 1 BIP(1028): ! P(+')=+,-,\,0 d1210 4 a1213 2 A(R)=4; ->UPR BIP(1029): ! PHRASE NOTE CYCLE d1219 2 a1220 1 BIP(1030): ! P(,')=',',0 d1230 2 a1231 1 BIP(1031): ! PHRASE CHECKTYPE IE ENSURE d1235 2 a1236 2 ->FAIL %UNLESS I>128 %AND X'80000000'>>(I&31)&X'20C83000'#0%C %AND X'80000000'>>(CC(Q+2)&31)&X'500B2800'#0 d1238 3 a1240 2 BIP(1032): ! PHRASE COMP1 BIP(1037): ! PHRASE COMP2(IS 2ND HALF OF DSIDED) d1242 1 a1242 2 ->FAIL %UNLESS 32>(I&31)&X'1004000E'#0 d1251 3 a1253 1 J=1; ->JOIN d1257 3 a1259 1 J=4; ->JOIN d1264 3 a1266 1 J=4; ->JOIN d1270 3 a1272 1 J=3; ->JOIN d1277 2 a1278 1 J=6; ->JOIN d1282 3 a1284 2 JOIN1:Q=Q+1 JOIN: d1290 3 a1292 3 ! COND EXPRS ALLOWED AS THE ! CAN BE NESTED! BIP(1033): ! P(ASSOP)- ==,=,<-,-> d1297 3 a1299 1 A(R)=2; ->UPR d1304 1 d1311 1 d1318 1 d1325 1 d1337 1 a1337 1 %if host=Vax %Start d1339 1 a1339 1 %finish d1344 2 a1345 1 BIP(1039): ! UCW = USERCODE WORD OFFSET INSTRS d1350 2 a1351 1 BIP(1040): ! UCUBUB TWO UNSIGNED BYTE OPERANDS d1354 4 a1357 2 %REPEAT; ->FAIL BIP(1041): ! UCUCUBW - BYTE&WORD OPERANDS d1360 4 a1363 2 %REPEAT; ->FAIL BIP(1042): ! UCJUMP = JUMP MNEMONICS d1366 4 a1369 2 %REPEAT; ->FAIL BIP(1043): ! UCWRONG ERRORS AND OTHER M-CS d1377 1 d1379 1 d1425 1 a1425 1 %END d1748 1 d1760 1 d1770 1 d1791 1 d1848 3 a1850 1 cprec=6; ->iend d1865 2 a1866 1 %END d1874 1 a1874 1 S=R; R=R+1; HIT=0 d1893 2 a1894 1 %END d1896 1 @ 1.1 log @Initial revision @ text @d13 1 a13 1 d22 1 a22 1 ! also serves for Sparc sinc there is a common b-e d33 1 a33 1 ! 2900. Long int available but not in Ecode d39 3 a41 3 ! ACCENT DIFFERS FROM PERQ ONLY IN ! ASSEMBLES SEQUENCES&SYNTAX ! AND GENERATOR d63 20 a82 20 197, 211, 211, 5, 215, 200, 201, 204, 197, 5, 213, 206, 212, 201, 204, 3, 198, 207, 210, 1, 61, 5, 193, 204, 201, 193, 211, 7, 201, 206, 212, 197, 199, 197, 210, 4, 210, 197, 193, 204, 4, 204, 207, 206, 199, 4, 194, 217, 212, 197, 6, 211, 212, 210, 201, 206, 199, 4, 200, 193, 204, 198, 5, 211, 200, 207, 210, 212, 6, 210, 197, 195, 207, 210, 196, 7, 210, 207, 213, 212, 201, 206, 197, 2, 198, 206, 3, 205, 193, 208, 8, 198, 213, 206, 195, 212, 201, 207, 206, 4, 206, 193, 205, 197, 9, 193, 210, 210, 193, 217, 206, 193, 205, 197, 9, 207, 198, 208, 210, 207, 199, 210, 193, 205, 6, 207, 198, 198, 201, 204, 197, 6, 207, 198, 204, 201, 211, 212, 6, 198, 207, 210, 205, 193, 212, 3, 206, 207, 212, 3, 193, 206, 196, 2, 207, 210, 1, 58, 4, 211, 208, 197, 195, 5, 193, 210, 210, 193, 217, 3, 207, 215, 206, 8, 197, 216, 212, 197, 210, 206, 193, 204, 9, 197, 216, 212, 210, 201, 206, 211, 201, 195, 8, 195, 207, 206, 211, 212, 193, 206, 212, 5, 195, 207, 206, 211, 212, 5, 197, 214, 197, 206, 212, 5, 211, 212, 193, 210, 212, 9, 212, 200, 197, 206, 211, 212, 193, 210, 212, 4, 212, 200, 197, 206, 9, 197, 204, 211, 197, 211, 212, 193, 210, 212, 4, 197, 204, 211, 197, 1, 95, 6, 211, 217, 211, 212, 197, 205, 7, 196, 217, 206, 193, 205, 201, 195, 4, 80, 85, 84, 95, 5, 67, 78, 79, 80, 95, 1, 43, 1, d84 9 a92 9 210, 197, 211, 213, 204, 212, 7, 205, 207, 206, 201, 212, 207, 210, 4, 211, 212, 207, 208, 6, 211, 201, 199, 206, 193, 204, 4, 197, 216, 201, 212, 8, 195, 207, 206, 212, 201, 206, 213, 197, 6, 198, 201, 206, 201, 211, 200, 5, 195, 217, 195, 204, 197, 6, 210, 197, 208, 197, 193, 212, 3, 197, 206, 196, 7, 201, 206, 195, 204, 213, 196, 197, 5, 194, 197, 199, 201, 206, 2, 207, 206, 6, 211, 215, 201, 212, 195, 200, 4, 204, 201, 211, 212, 14, 212, 210, 213, 211, 212, 197, 196, 208, 210, 207, 199, 210, 193, 205, 6, 205, 193, 201, 206, 197, 208, 7, 195, 207, 206, 212, 210, 207, 204, 4, 40, 42, d117 2 a118 2 999, 1514, 1000, 1525, 1518, 129, 1016, 1520, 139, 1523, 146, 1018, 1525, 1016, 1530, 1528, 153, 1530, 1000, 1546, d127 1 a127 1 178, 1525, 1614, 1620, 1620, 1001, 1408, 1791, 1620, 1626, d135 1 a135 1 0, 1328, 2, 1696, 1000, 1703, 1701, 6, 1321, 999, d138 1 a138 1 171, 1337, 2, 999, 1727, 1000, 1734, 1732, 24, 1530, d143 1 a143 1 259, 1373, 1010, 1530, 1552, 1011, 1747, 1781, 259, 1939, d146 4 a149 4 34, 1028, 1300, 1344, 1807, 1000, 1816, 1810, 266, 1812, 188, 1814, 273, 1816, 1000, 1827, 1825, 1001, 34, 1337, 6, 1337, 6, 1337, 1827, 1000, 1834, 1832, 6, 1852, 999, 1834, 1000, 1845, 1838, 173, 1001, 1845, 1001, 0, d152 1 a152 1 2, 1870, 1867, 1488, 1001, 1408, 1870, 178, 1614, 1878, d163 1 a163 1 340, 2097, 1979, 1027, 1010, 1939, 1011, 1734, 1981, 1007, d168 1 a168 1 83, 153, 1834, 1006, 2035, 1010, 1807, 1453, 1011, 1585, d172 1 a172 1 0, 1337, 171, 1337, 2, 1714, 1006, 2072, 397, 1006, d238 59 a296 59 1,2,3,4, 5,6,7,8, 9,10,11,12, 13,14,15,16, 17,18,19,20, 21,22,36,41, 42,43,44,45, 46,47,48,51, 52,53,54,55, 56,57,58,59, 60,62,63,64, 65,66,67,68, 69,77,78,79, 80,81,82,83, 84,85,86,87, 100,101,102,103, 104,105,106,107, 108,109,110,111, 112,113,114,115, 116,117,118,130, 131,132,133,134, 135,136,137,138, 139,140,141,142, 143,144,145,146, 147,148,149,162, 177,184,185,186, 187,188,189,190, 191,192,193,194, 195,196,197,198, 199,200,201,202, 203,205,257,258, 259,260,261,262, 263,264,286,287, 279,266,267,268, 269,270,271,272, 273,274,275,276, 277,278,280,281, 282,283,284,285, 288,289,290,291, 292,293,294,295, 296,297,298,299, 300,301,302,303, 304,305,306,307, 308,309,310,311, 312,313,314,315, 316,317,318,319, 511,512,513,514, 515,516,520,521, 530,531,532,533, 534,535,536,537, 538,539,547,548, 559,560,574,601, 602,603,604,605, 606,607,611,620, 621,629,622,623, 624,625,626,627, 628,630,631,632, 633,642,643,0, 255; d307 3 a309 3 ! THE SPECIAL NAMES ARE HERE TO ALLOW ! DIFFERENCES OF PRECISION BETWEEN COMPILERS ! ESPECIAL THE MAPS HALF&SHORT d311 8 a318 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'4062',X'51', X'61',X'72',X'61',X'72',X'51',LRLPT,X'1051',X'51', X'1000',LRLPT,X'1061'(2),X'41',X'1051'; d326 16 a341 16 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' d343 16 a358 16 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, 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+128,66+128,67+128,68+128,69+128,70+128,71+128,72+128,73+128,74+128,75+128,76+128,77+128,78+128,79+128, 80+128,81+128,82+128,83+128,84+128,85+128,86+128,87+128,88+128,89+128,90+128,123,124,125,126,127; d362 1 a362 1 0(7),2(26),0(6),2(26),0(*); d369 3 a371 3 %BYTEINTEGER LET,DYNAMIC,LINE,TRACE,ARR,DBUG,CHK,DIAG,OPT,FREE, LIST,CPRMODE,COMPILER,Z,Y,PROF,INHCODE,DCOMP,FAULTY,X,STACK,MAP,QUOTES,S2, %INTEGER LPOPUT,SP0) d373 3 a375 3 LABEL, JROUND, UNATT FORMATS, PSIZE, ENTRYAD, DISPLAY, AUXSBASE, NAMES, SNMAX,SN,RESSIZE,CLEVEL,SET, MAXPP, EXITLAB, CONTLAB, S3, %INTEGERARRAY AVL WSP(0:4)) d378 10 a387 10 %RECORDFORMAT RD((%INTEGER S1 %OR %SHORT PTYPE,%BYTE XB,FLAG), ((%INTEGER D %OR %REAL R), %INTEGER XTRA %OR %SHORT H0,H1,H2,H3 %OR %BYTE B0,B1,B2,B3,B4,B5,B6,B7)) %RECORDFORMAT TAGF((%SHORTINTEGER PTYPE,UIOJ,SNDISP,ACC,SLINK,KFORM %OR %C %INTEGER S1,S2,S3),%INTEGER LINK) %RECORDFORMAT TRIPF(%BYTE OPERN,OPTYPE,CNT,DPTH, %SHORTINTEGER FLAGS,PUSE,FLINK,BLINK,%INTEGER X1, %RECORD(RD) OPND1,OPND2) %RECORDFORMAT LISTF((%SHORTINTEGER PTYPE,(%SHORT UIOJ %OR %BYTE XB,FLAG), %SHORT SNDISP,ACC,SLINK,KFORM %OR %INTEGER S1,S2,S3),%INTEGER LINK) d389 10 a398 10 %RECORDFORMAT RD((%INTEGER S1 %OR %HALF PTYPE,%BYTE XB,FLAG), ((%INTEGER D %OR %REAL R), %INTEGER XTRA %OR %HALF H0,H1,H2,H3 %OR %BYTE B0,B1,B2,B3,B4,B5,B6,B7)) %RECORDFORMAT TAGF((%HALFINTEGER PTYPE,UIOJ,SNDISP,ACC,SLINK,KFORM %OR %C %INTEGER S1,S2,S3),%INTEGER LINK) %RECORDFORMAT TRIPF(%BYTE OPERN,OPTYPE,CNT,DPTH, %HALFINTEGER FLAGS,PUSE,FLINK,BLINK,%INTEGER X1, %RECORD(RD) OPND1,OPND2) %RECORDFORMAT LISTF((%HALFINTEGER PTYPE,(%HALF UIOJ %OR %BYTE XB,FLAG), %HALF SNDISP,ACC,SLINK,KFORM %OR %INTEGER S1,S2,S3),%INTEGER LINK) d401 8 a408 8 CONST BTM,LASTTRIP,WKFILEAD,WKFILEK,FILE ADDR,RELEASE,AASL0,CONST LIMIT, RTCOUNT,ARTOP,AMAINEP,DICTBASE,OPTCNT,INCLHEAD,S2,S3,S4, %INTEGERNAME LINE,N,S5,%STRING(9)LADATE, %BYTEINTEGERARRAYNAME CC,A,LETT, %INTEGERARRAYNAME WORD,TAGS,CTABLE, %RECORD(LEVELF)%ARRAYNAME LEVELINF, %INTEGERARRAY PLABS,PLINK(0:31), %RECORD(LISTF)%ARRAYNAME ASLIST) d415 1 a415 1 ! OF TEMPS OVER LOOPS&JUMPS d424 1 a424 1 ! USED FOR BYTE PTR & OTHER SODS! d427 1 a427 1 ! FORMAT FOR ARRAY HEADS d448 9 a456 9 %ROUTINESPEC NEW SOURCE(%INTEGER NEW FIL AD) %integerfnspec OLD SOURCE %ROUTINESPEC READ LINE(%INTEGER MODE,CHAR) %INTEGERFNSPEC COMPARE(%INTEGER P) %ROUTINESPEC PNAME(%INTEGER MODE) %ROUTINESPEC EVALCONST(%INTEGER MODE) %ROUTINESPEC TEXTTEXT(%INTEGER EBCDIC) %EXTERNALROUTINESPEC MOVE BYTES(%INTEGER LENGTH,FBASE,FOFF,TOBASE,TOOFF) %if 1<>1 %INTEGERARRAY Downptr,SFS(0:MAXLEVELS) d488 4 a491 4 %BYTEINTEGERARRAYFORMAT LETTF(0:DSIZE+20) %BYTEINTEGERARRAYNAME LETT %BYTEINTEGERARRAY TLINE(0:2047) %CONSTBYTEINTEGERARRAY ILETT(0: 532)= 11, d494 1 a494 1 5,'S','P','A','C','E', 10,'S','K','I','P','S','Y','M','B','O', d508 2 a509 2 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', d523 22 a544 22 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', 5,'T','R','U','N','C',255; !* %byteintegerarrayformat inbuffm(0:4095) %ownbyteintegerarrayname inbuf %owninteger inptr=4095 %owninteger dataad !* LETT==ARRAY(ADDR(A(ARSIZE-DSIZE-20)),LETTF) ARSIZE=ARSIZE-DSIZE-300 !* dataad = malloc(4096) inbuf == array(dataad, inbuffm) !* LETT(0)=0 LEVEL=0 d546 52 a597 52 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>>7&1; ! PROFILE BIT parm_prof=0 %if parm_map#0; ! Cant profile funny listint PARM_DYNAMIC=I>>20&1 PARM_LET=I>>13&1 PARM_DCOMP=I>>14&1; ! PARM CODE OR D PARM_DBUG=I>>18&1 PARM_QUOTES=I&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 %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) ! %if target=MIPS %or Target=M88K %then printstring(assprefix) SPACES(4) PRINTSTRING("/* EPC Imp to C Translation ") PRINTSTRING("Release") WRITE(WORKA_RELEASE,1) PRINTSTRING(" Version ".WORKA_LADATE." */") NEWLINES(3) printstring("#include ""imptoc.h"" d599 8 a606 8 ! %if target=MIPS %or Target=M88k %then printstring(assprefix) ! WRITE(NNAMES,5); WRITE(WORKA_ASL MAX,5) ! NEWLINE ! ! NOW DECLARE THE SPECIAL NAMES WHICH ARE IN ARRAY ILETT. ! %BEGIN %RECORD(TAGF) SNTAG d634 81 a714 81 ! ! The idea of the above exit is to allow further special names to be added ! without preventing the rebuilds of compilers that do not support the extra facilities ! Until no of sns is increased in the steering consts the new names are ignored ! %END ! LINE=0; LLENGTH=0; Q=1 R=1; LEVEL=1 %CYCLE curlinead=file addr+fileptr %IF Q>=LLENGTH %THEN QMAX=1 %AND READ LINE(0,0) %if llength=-1 %then %exit { no more input} STARSTART=R R=R+3 A(R)=LINE>>8 A(R+1)=LINE&255 R=R+2 movebytes(4,addr(curlinead),0,addr(a(0)),r) r=r+4 %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+9)=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+9)=ENDALT %AND %C 1<=A(STARSTART+10)<=2 %START;! ENDOF PROG OR FILE %IF IHEAD=0 %THEN %EXIT llength=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 move bytes(next+1,addr(lett(0)),0,addr(a(0)),r) 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 free(dataad) %FINISH %ELSE %START PRINTSTRING("C GENERATION NOT ATTEMPTED d716 7 a722 7 %FINISH %RESULT=R %ROUTINE NEWSOURCE(%INTEGER NEWFILEADDR) !*********************************************************************** !* SETS UP COMPILER TO USE AN INCLUDED SOURCE FILES * !*********************************************************************** %externalinteger filesseen=0 d732 6 a737 6 %END %integerfn OLDSOURCE !*********************************************************************** !* UNDOES THE ABOVE !*********************************************************************** %INTEGER ALT LINE d740 1 a740 1 %if Fileaddr#0 %start; ! if it was mapped remap d749 4 a752 4 %END %ROUTINE READ LINE(%INTEGER MODE,CHAR) %integerfnSPEC GET LINE %INTEGER DEL, LL, LP, PREV, LASTC, PPREV, LASTNS, i,j d755 1 a755 1 NEXT: d758 1 a758 1 %if lp=0 %then llength=-1 %and %return d770 2 a771 2 pprev=prev; prev=i; lp=lp+1 i=tline(lp); d775 1 a775 1 ! %if parm_quotes#0 %then i=onecase(i+128) %else I=ONE CASE(I) d779 1 a779 1 %if del#0 %then i=(i-32)!DEL d782 1 a782 1 ! ->NEXT %IF I=' ' d810 62 a871 29 %%integerfn GET LINE %externalintegerspec SrcId %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 { Since there is no support for read symbol, use } { Unix block read which is faster anyway. } { READ SYMBOL(K) } inptr = inptr + 1 %if inptr = 4096 %thenstart k = fileread(SrcId, addr(inbuf(0)), 4096) inptr = 0 a872 9 k = inbuf(inptr) TLINE(LL+1)=ITOI(K) LL=LL+1 %REPEAT curlinead=0 %FINISH %ELSE %START %IF FILEPTR>=FILE END %START %if OLD SOURCE=0 %then %result=0; ! RESET SOURCE FILES %result=GETLINE d874 6 a879 30 ! curlinead=file addr+fileptr %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 %while ll>1 %and TLINE(ll-1)=' ' %cycle { deal with trailing spaces } TLINE(LL-1)=TLINE(LL) LL=LL-1 %repeat 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) %IF HOST=ACCENT %or ll>255 %THEN %START PRINT SYMBOL(TLINE(K)) %FOR K=1,1,LL %ELSE tline(0)=ll printstring(string(ADDR(TLINE(0)))) %finish %FINISH ! %IF PARM_FREE=0 %AND LL>73 %THEN TLINE(73)=10 %AND LL=73 %result=1 { line got OK} %END %END %integerfn next nonspace %integer i d883 5 a887 5 %end %INTEGERFN COMPARE(%INTEGER P) %INTEGER I, J, ITEM, RA, RL, RP, RQ, RR, RS, MARKER, SSL, ALT, PP, nbochar %OWNINTEGER SAVECOMP; ! FOR CHECKING DSIDED CONDS %SWITCH BIP(999:1043) d892 1 a892 1 COMM: d899 2 a900 2 UPR: R=R+1 SUCC: ! SUCCESS ON TO NEXT ITEM d902 2 a903 2 ! THIS ALT HAS BEEN COMPLETED SO ! EXIT WITH HIT=1 d906 3 a908 3 !printstring("testing item&sym"); write(item,4); space; printsymbol(nextnonspace&127); ! write(q,5); ! write(nextnonspace,4); newline d911 1 a911 1 ! BRICK IS A PHRASE TYPE d914 1 a914 1 LIT: ! BRICK IS LITERAL d926 1 a926 1 FAIL: ! FAILURE - NOTE POSITION REACHD d936 1 a936 1 TFAIL: d939 1 a939 1 BIP(999): ! REPEATED PHRASE d942 1 a942 1 BIP(1000):FINI: ! NULL ALWAYS LAST & OK d945 1 a945 1 BIP(1001): ! PHRASE NAME d950 2 a951 2 BIP(1002): ! PHRASE INTEGER CONSTANT BIP(1003): ! PHRASE CONST d955 1 a955 1 BIP(1004): ! PHRASE DUMMYSTART d959 1 a959 1 BIP(1005): ! PHRASE N d969 1 a969 1 BIP(1006): ! PHRASE S=SEPARATOR d975 2 a976 2 BIP(1007): ! PHRASE COMMENT TEXT d988 1 a988 1 ->FAIL %UNLESS CC(Q+5)='N'+128 %AND CC(Q+6)='T'+128 d991 1 a991 1 COMFOUND: d999 4 a1002 4 BIP(1008): ! PHRASE BIGHOLE ! NOT CURRENTLY USED IN TRIMP ! A(I)=0 %FOR I=R,1,R+3 ! R=R+4 d1004 1 a1004 1 BIP(1009): ! PHRASE N255 d1014 1 a1014 1 BIP(1010): ! PHRASE HOLE d1016 1 a1016 1 BIP(1011): ! PHRASE MARK d1021 1 a1021 1 BIP(1012): ! PHRASE read line? d1031 1 a1031 1 BIP(1013): ! PHRASE CHECKIMPS d1035 1 a1035 1 BIP(1014): ! PHRASE DUMMY APP d1038 1 a1038 1 BIP(1015): ! PHRASE DOWN=NEW TEXT LEVEL d1044 1 a1044 1 BIP(1016): ! PHRASE UP 1 TEXTUAL LEVEL d1052 1 a1052 1 BIP(1017): ! PHRASE LISTON d1054 1 a1054 1 BIP(1018): ! PHRASE LISTOFF d1056 1 a1056 1 BIP(1019): ! PHRASE COLON FOR LABEL d1059 1 a1059 1 BIP(1020): ! PHRASE NOTE CONST d1061 1 a1061 1 BIP(1021): ! TRACE FOR ON CONDITIONS d1063 1 a1063 1 BIP(1022): ! SET MNEMONIC d1077 1 a1077 1 BIP(1023): ! UCNOP MNEMONIC SANS OPERANDS d1079 3 a1081 3 target=drs %or target=wwc %or target=perq3) %AND CC(Q-1)='_' ! EFFICIENCY FROG FOR ASSBLERS ! WITH NO PARAMETER OPCODES d1086 1 a1086 1 PFND: d1090 1 a1090 1 BIP(1024): ! UCUB MNEMONIC WITH UNSIGNED BYTE OPERAND d1095 1 a1095 1 BIP(1025): ! UCUB SIGNED BYTE OPERANDS d1099 2 a1100 2 BIP(1026): ! P(OP)=+,-,&,****,**,*,!!,!, ! //,/,>>,<<,.,\\,\ d1103 1 a1103 1 X'80000000'>>((I-32)&31)&X'4237000A'#0 d1130 1 a1130 1 BIP(1027): ! PHRASE CHECK UI d1135 1 a1135 1 BIP(1028): ! P(+')=+,-,\,0 d1141 1 a1141 1 BIP(1029): ! PHRASE NOTE CYCLE d1147 1 a1147 1 BIP(1030): ! P(,')=',',0 d1157 3 a1159 3 BIP(1031): ! PHRASE CHECKTYPE IE ENSURE ! FIRST LETTER IS(B,H,I,L,R,S) & ! 3RD LETTER IS (A,L,N,O,R,T) d1162 1 a1162 1 %AND X'80000000'>>(CC(Q+2)&31)&X'500B2800'#0 d1164 2 a1165 2 BIP(1032): ! PHRASE COMP1 BIP(1037): ! PHRASE COMP2(IS 2ND HALF OF DSIDED) d1168 6 a1173 6 X'80000000'>>(I&31)&X'1004000E'#0 ! '='=1,'>='=2,'>'=3 ! '#' OR '\=' OR '<>'=4 ! '<='=5,'<'=6 ! 7UNUSED,'->'=8,'=='=9 ! '##' OR '\==' =10 d1199 2 a1200 2 JOIN1:Q=Q+1 JOIN: d1203 1 a1203 1 ! SAVE J TO CHECK DSIDED d1206 3 a1208 3 ! COND EXPRS ALLOWED AS THE ! CAN BE NESTED! BIP(1033): ! P(ASSOP)- ==,=,<-,-> d1218 1 a1218 1 BIP(1034): ! NOTE START d1224 1 a1224 1 BIP(1035): ! NOTE FINISH d1230 1 a1230 1 BIP(1036): ! NOTE REPEAT d1236 1 a1236 1 BIP(1038): ! INCLUDE "FILE" d1242 11 a1252 11 %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) %if host=Vax %Start %unless fname->(".") %then fname=fname.".INC" %finish CONSOURCE(FNAME,J) NEWSOURCE(J) %END d1254 1 a1254 1 BIP(1039): ! UCW = USERCODE WORD OFFSET INSTRS d1259 1 a1259 1 BIP(1040): ! UCUBUB TWO UNSIGNED BYTE OPERANDS d1263 1 a1263 1 BIP(1041): ! UCUCUBW - BYTE&WORD OPERANDS d1267 1 a1267 1 BIP(1042): ! UCJUMP = JUMP MNEMONICS d1271 1 a1271 1 BIP(1043): ! UCWRONG ERRORS AND OTHER M-CS d1279 7 a1285 7 %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 d1289 1 a1289 1 ! 1ST CHAR MUST BE LETTER d1318 1 a1318 1 HOLE: %IF MODE=0 %THEN Q=FQ %AND %RETURN d1321 1 a1321 1 FND: LASTAT=FQ; HIT=1; LASTNAME=KK d1325 1 a1325 1 %END d1327 205 a1531 205 %ROUTINE EVALCONST(%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, J, nbochar, QQ %integer hexformat %integerarray rhexpat(0:3) %constinteger powerl=75 %IF 1<imax %start d1747 1 a1747 1 %ELSE CTYPE=1 %AND S=INT(CVALUE) d1759 28 a1786 28 %END %ROUTINE TEXTTEXT(%INTEGER EBCDIC) !*********************************************************************** !* PROCESSES TEXT BETWEEN DOUBLE QUOTES AND STORES IN ISO OR EBCDIC * !*********************************************************************** %INTEGER J, II %CONSTINTEGER QU='"' I=next nonspace 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 next nonspace#QU %THEN %EXIT %FINISH %IF I=10 %THEN %start READ LINE(1,QU) fault(110,0,0) %if llength=-1 %finish %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 @