%INCLUDE "ERCC07.TRIMP_HOSTCODES" %CONSTINTEGER HOST=EMAS %CONSTINTEGER TARGET=IBM %CONSTINTEGER FOURKTDISP=0 %INCLUDE "ERCC10.OPOUTS" ! %CONSTINTEGER LGR=X'58',AND=X'54',ICP=X'59'; ! VARIANT MNEMONICS %IF TARGET=IBM %THEN %START %CONSTINTEGER BALCODE=BAL %FINISH %ELSE %START %CONSTINTEGER BALCODE=BAS %FINISH %CONSTINTEGER MARGIN=512; ! MARGIN FOR ADRESSABILITY %CONSTINTEGER MAXREG=19; ! FOR DECLARING REGISTER ETC %CONSTINTEGER CODER=12 %CONSTINTEGER WSPR =11 %CONSTINTEGER GLA =13 %CONSTINTEGER LINKREG=15; ! REGISTER FOR RETURN ADDRESS %CONSTINTEGER EPREG=14; ! REGISTER HOLDING RT ENTRYPOINT %CONSTINTEGER CTABLEREG=14; ! REGISTER HOLDING CONSTANT TABLE %CONSTINTEGER GR0=X'000F0000'; ! ANY GR FROM 0-15 %CONSTINTEGER GR1=X'0001000F'; ! ANY GR BAR GR0 %CONSTINTEGER FR0=X'00100013'; ! ANY FR %CONSTINTEGER GRSAFE=X'00040009'; ! ANY GR SAFE AGAINT RT CALL %CONSTINTEGER GRPAIR=X'01000008' %CONSTINTEGER FRPAIR=X'01100012' %CONSTINTEGER GRSEQ=X'81000008' %CONSTINTEGER GRQUAD=X'83000006' %CONSTINTEGER ANYGR=-1,ANYGRBAR0=-2,ANYFR=-3,ANYSAFEGR=-4, ANYGRPAIR=-5,ANYFRPAIR=-6,ANY2SEQ=-7,ANY4SEQ=-8 %CONSTINTEGERARRAY NEGREG(-8:-1)=GRQUAD,GRSEQ,FRPAIR,GRPAIR,GRSAFE,FR0,GR1,GR0; ! ! PARAMETERISE THE REGISTER USESES ! %CONSTINTEGER IRESULT=1,TEMPBASE=2,RTPARAM=3,NAMEBASE=4,LITCONST=5, TABCONST=6,ADDROF=7,BASEOF=8,LOCALVAR=9,LOCALTEMP=10, FOURKMULT=11,LABFOURK=12,BASEREG=13,PERMFOURK=14,DVBASE=15, STRWKAREA=16 %CONSTBYTEINTEGERARRAY REGWORDS(0:127)=X'11'(96){PRECS 0-5}, X'11',X'22',X'12',X'11'(13){PREC=6}, X'11',X'44',X'24',X'11'(13){PREC=7}; ! ABOVE IS NO OF REGS<<4!NO OF 32 BIT WORS %CONSTBYTEINTEGERARRAY REGCODE(0:MAXREG)= 0,1,2,3,4,5,6,7,8,9, 10,11,12,13,14,15,0,2,4,6; %CONSTBYTEINTEGERARRAY DISPREG(-1:8)=WSPR,GLA,10,9,8,7,6,5,4,3; %CONSTBYTEINTEGERARRAY GRMAP(0:14)=0,1,2,3,15,16,17,18,19, 4,5,6,7,8,9; %CONSTBYTEINTEGERARRAY LDCODE(0:15)=0(3),IC,LH,LGR,LM,LM,0(5),LE,LD,LD; %CONSTBYTEINTEGERARRAY STCODE(0:15)=0(3),STC,STH,ST,STM,STM,0(5),STE,STD,STD; %CONSTBYTEINTEGERARRAY WHICHREG(0:15)=0(3),-ANYGR(3),-ANYGRPAIR,-ANY4SEQ, 0(5),-ANYFR(2),-ANYFRPAIR ! %INCLUDE "ERCC07.TRIPCNSTS" %INCLUDE "ERCC07.TRIMP_TFORM1S" %RECORDFORMAT REGF(%INTEGER CL,CNT,AT,(%INTEGER USE %OR %HALF SECUSE,PRIMUSE), %INTEGER INF1,INF2,LINK) %OWNINTEGER CABUF,GLACABUF,CONSTHOLE,CREFHEAD,PROFDATA, OLDLINE,HALFHOLE %OWNINTEGERNAME CA,GLACA %OWNINTEGER PPCURR=0,GLACURR=0,LCA=0,FPPTR=0,FPHEAD=0,LASTPARREG=0 %OWNINTEGER MAX4KMULT=0,UNASSOFFSET=0,SWITEMSIZE=0 %OWNINTEGER USINGR=12,USINGAT=0; ! REMEMBERS ASSEMBLER USINGS %OWNRECORD(LISTF)%ARRAYNAME ASLIST %OWNBYTEINTEGERARRAY CODE(0:268) %OWNBYTEINTEGERARRAY GLABUF(0:268) %OWNINTEGERARRAYNAME CTABLE %OWNINTEGERARRAYNAME TAGS %EXTRINSICINTEGERARRAY CAS(0:10) %EXTRINSICRECORD(WORKAF)WORKA %EXTRINSICRECORD(PARMF) PARM %OWNRECORD(REGF)%ARRAY REGS(0:MAXREG) %CONSTINTEGER MAXKXREF=5 %OWNINTEGERARRAY KXREFS(0:MAXKXREF) %CONSTSTRING(11)%ARRAY KXREFNAME(0:MAXKXREF)="S#STOP","S#NDIAG", "S#ILOG","S#IEXP","S#IOCP", "ICL9CEAUXST"; %%EXTERNALSTRING(255)%FNSPEC PRINTNAME(%INTEGER N) %EXTERNALROUTINESPEC FLAGAND FOLD(%RECORD(TRIPF)%ARRAYNAME T) %SYSTEMINTEGERMAPSPEC COMREG(%INTEGER N) %EXTERNALROUTINESPEC IBMRECODE(%INTEGER A,B,C) %SYSTEMROUTINESPEC IPUT(%INTEGER A,B,C,D) %EXTERNALSTRING(255)%FNSPEC UCSTRING(%STRING(255) S) %EXTERNALROUTINESPEC FAULT(%INTEGER I,J,K) %ROUTINESPEC PRINT USE %EXTERNALROUTINESPEC PUSH(%INTEGERNAME CELL,%INTEGER S1,S2,S3) %ROUTINESPEC STORECONST(%INTEGERNAME D,%INTEGER L,AD) %INTEGERFNSPEC WORDCONST(%INTEGER VAL) %ROUTINESPEC CNOP(%INTEGER I,J) %EXTERNALROUTINESPEC POP(%INTEGERNAME A,B,C,D) !%EXTERNALROUTINESPEC PRINTLIST(%INTEGER HEAD) %EXTERNALROUTINESPEC PRHEX(%INTEGER VALUE,PLACES) %EXTERNALROUTINESPEC PRINTTHISTRIP(%RECORD(TRIPF)%ARRAYNAME T, %INTEGER I) %EXTERNALROUTINESPEC PRINT TRIPS(%RECORD(TRIPF)%ARRAYNAME T) %ROUTINESPEC RELOCATE(%INTEGER GLARAD,VALUE,AREA) %CONSTINTEGER USE IMP=NO %CONSTINTEGER UNASSPAT=X'80808080' %CONSTBYTEINTEGERARRAY BYTES(0:7)=0(3),1,2,4,8,16; %CONSTBYTEINTEGERARRAY WORDS(0:7)=0(3),1,1,1,2,4; %CONSTBYTEINTEGERARRAY BYTESTOPT(1:16)=X'31',X'41',X'57',X'51', X'57'(3),X'62',X'57'(7),X'72'; %CONSTINTEGER DAREA=4; ! AREA FOR DIAG TABLES %CONSTINTEGER CAREA=6; ! CONSTANTS AT BACK OF CODE ! ! FIXED GLA CURRENTLY USED AS FOLLOWS ! 0-3 FREE(WAS 2900 ENTRY DESCRIPTOR) ! 4-7 ADDRESS OF HEAD OF CODE ! 8-11 ADDRESS OF UNSHARED SYMBOL TABLES ! 12-15 ADDRESS OF SHARED SYMBOL TABLES ! 16-19 LANGUAGE & COMPILER DATA ! 20-23 ADDRESS OF DIAGS TABLES ! 24-27 ADDRESS OF CONSTANT TABL ! 28-31 ADDRESS OF A WORD CONTAINING STACKTOP 0FOR NO CHECKS ! 32-35 HOLDS M'IDIA' FOR DIAGNOSTIC IDENTIFICATION ! 36-39 FREE ! %CONSTINTEGER FIXEDGLALEN=56 %OWNINTEGERARRAY FIXED GLA(0:FIXEDGLALEN>>2-1)=M'IMPG',0, 0(6),M'IDIA',0(*); ! !*********************************************************************** !* IMP CODE PLANTING ROUTINES * !* CODE AND GLAP ARE PUT INTO THE BUFFERS 'CODE,GLABUF(0:268)' * !* BY A NUMBER OF TRIVIAL ROUTINES.IPUT IS CALLED TO ADD THE * !* BUFFER TO THE OUTPUT FILE. THE BUFFERS ARE BASICALLY 0:255 * !* WITH A 12-BYTE MARGIN TO MINIMISE THE NUMBER OF TESTS FOR * !* THE BUFFER FULL CONDITION * !* * !* PPCURR(GLACURR) IS THE BUFFER POINTER * !* CA(GLACA) IS THE RELATIVE ADDRESS OF THE NEXT BYTE * !* CABUF(GLACABUF) IS CA(GLACA) FOR START OF BUFFER * !*********************************************************************** %ROUTINE LIPUT(%INTEGER A,B,C,D) %INTEGER I %IF PARM_Z#0 %THEN %START PRINTSTRING(" CALL ON IPUT") WRITE(A,4) WRITE(B,4) WRITE(C,4) WRITE(D,4) %IF A=7 %OR A>30 %START SPACE PRHEX(BYTEINTEGER(D+I),2) %FOR I=0,1,19 %FINISH NEWLINE %FINISH IPUT(A,B,C,D) %END %ROUTINE CPINIT !*********************************************************************** !* PERFORMS ANY NECESSARY TARGET DEPENDANT INITIALISING * !************************************************************************ %INTEGER I TAGS==WORKA_TAGS KXREFS(I)=0 %FOR I=0,1,MAXKXREF PPCURR=0; GLACURR=0 LIPUT(0,0,0,0); ! OPEN OBJECT FILE %END %ROUTINE RECODE(%INTEGER S,F,AD) %IF S#F %START PRINTSTRING(" CODE FOR LINE"); WRITE(WORKA_LINE,3) NEWLINE IBMRECODE(S,F,AD) PRINT USE NEWLINE %FINISH %END %EXTERNALROUTINE CODEOUT %IF PPCURR>0 %THEN %START RECODE(ADDR(CODE(0)), ADDR(CODE(PPCURR)), CABUF) %C %IF PARM_DCOMP#0 LIPUT(30+1, PPCURR, CABUF, ADDR(CODE(0))) %IF PARM_INHCODE=0 PPCURR=0; CABUF=CA %FINISH %END %ROUTINE PLANT(%INTEGER HALFWORD) !*********************************************************************** !* ADD A HALF WORD OF BINARY TO THE BUFFER * !*********************************************************************** CODE(PPCURR)<-HALFWORD>>8 CODE(PPCURR+1)<-HALFWORD PPCURR=PPCURR+2 CA=CA+2 CODEOUT %IF PPCURR>=256 %END %ROUTINE PCONST(%INTEGER WORD) !*********************************************************************** !* ADD A WORD OF BINARY TO THE BUFFER * !*********************************************************************** %INTEGER I %CYCLE I=24,-8,0 CODE(PPCURR)=WORD>>I&255 PPCURR=PPCURR+1 %REPEAT CA=CA+4 CODE OUT %IF PPCURR>=256 %END %ROUTINE PRR(%INTEGER OPCODE,R1,R2) !*********************************************************************** !* PLANTS THE ORIGINAL FORM OF REGISTER TO REGISTER OPERATION * !*********************************************************************** CODE(PPCURR)=OPCODE CODE(PPCURR+1)=(R1&15)<<4!(R2&15) PPCURR=PPCURR+2 CA=CA+2 CODEOUT %IF PPCURR>=256 %END %ROUTINE PRRX(%INTEGER LOPCODE,R1,R2) !*********************************************************************** !* PLANTS THE EXTENDED FORM OF REGISTER TO REGISTER INSTRUCTION * !*********************************************************************** CODE(PPCURR)=LOPCODE>>8 CODE(PPCURR+1)<-LOPCODE CODE(PPCURR+2)=0 CODE(PPCURR+3)=R1<<4!R2 CA=CA+4 PPCURR=PPCURR+4 CODEOUT %IF PPCURR>256 %END %ROUTINE MOVE BACK PC(%INTEGER LCA) %IF LCA4095 R1=R1&15 %IF PARM_OPT=0 %THEN %START %IF OPCODE=LGR %OR OPCODE=ST %THEN %START %IF LCA+4=CA %AND LB=B %AND R2=0 %AND %C ((LOPCODE=OPCODE %AND (LR1+1)&15=R1 %AND LR2=0 %AND %C D=LD+4) %OR (LOPCODE=OPCODE+X'40' %AND %C (LR2+1)&15=R1 %AND D=LD+((R1-LR1)&15)*4)) %START %IF PARM_DCOMP#0 %THEN PRINTSTRING("** LOADS COMBINED **") MOVE BACK PC(LCA) PRX(STM+OPCODE&15,LR1,R1,LB,LD);! CHANGE L & ST TO LM&STM %RETURN %FINISH %FINISH LCA=CA; LR1=R1; LR2=R2 LB=B; LD=D; LOPCODE=OPCODE %FINISH CODE(PPCURR)=OPCODE CODE(PPCURR+1)=R1<<4!R2 CODE(PPCURR+2)=B<<4!D>>8 CODE(PPCURR+3)<-D PPCURR=PPCURR+4 CA=CA+4 CODEOUT %IF PPCURR>=256 %END %ROUTINE PSI(%INTEGER OPCODE,J,B,D) !*********************************************************************** !* PLANTS THE SI STORE IMMEDIATE INSTRUCTION * !*********************************************************************** %MONITOR %AND %STOP %IF D>4095 CODE(PPCURR)=OPCODE CODE(PPCURR+1)=J CODE(PPCURR+2)=B<<4!D>>8 CODE(PPCURR+3)<-D PPCURR=PPCURR+4 CA=CA+4 CODEOUT %IF PPCURR>=256 %END %ROUTINE PSS(%INTEGER OPCODE,N,B1,D1,B2,D2) !*********************************************************************** !* PLANTS THE SS INSTRUCTION LENGTH CAN BE A BYTE FIELD OR TWO * !* FOUR BIT FIELDS WHICH HAVE TO BE COMBINED BEFORE TH CALL * !*********************************************************************** %MONITOR %AND %STOP %IF D1>4095 %OR D2>4095 CODE(PPCURR)=OPCODE N=N-1 %UNLESS N=0 CODE(PPCURR+1)=N CODE(PPCURR+2)=B1<<4!D1>>8 CODE(PPCURR+3)<-D1 CODE(PPCURR+4)=B2<<4!D2>>8 CODE(PPCURR+5)<-D2 PPCURR=PPCURR+6 CA=CA+6 CODEOUT %IF PPCURR>=256 %END %ROUTINE PS(%INTEGER LOPCODE,B,D) !*********************************************************************** !* PLANTS THE S STORE WITH IMPLIED OPERAND INSTRUCTION * !*********************************************************************** %MONITOR %AND %STOP %IF D>4095 CODE(PPCURR)=LOPCODE>>8 CODE(PPCURR+1)<-LOPCODE CODE(PPCURR+2)=B<<4!D>>8 CODE(PPCURR+3)<-D PPCURR=PPCURR+4 CA=CA+4 CODEOUT %IF PPCURR>=256 %END %ROUTINE PSSE(%INTEGER LOPCODE,B1,D1,B2,D2) !*********************************************************************** !* PLANTS THE SSE INSTRUCTION STORE TO STORE WITH EXTENDED OPCODE * !*********************************************************************** %MONITOR %AND %STOP %IF D1>4095 %OR D2>4095 CODE(PPCURR)=LOPCODE>>8 CODE(PPCURR+1)<-LOPCODE CODE(PPCURR+2)=B1<<4!D1>>8 CODE(PPCURR+3)<-D1 CODE(PPCURR+4)=B2<<4!D2>>8 CODE(PPCURR+5)<-D2 PPCURR=PPCURR+6 CA=CA+6 CODEOUT %IF PPCURR>=256 %END %ROUTINE PMVC(%INTEGER L,B1,D1,B2,D2) !*********************************************************************** !* PLANTS AN MVC INSTRN. IN OPTIMISING MODE TRIES TO GLUE IT * !* ON TO THE LAST ONE PLANTED * !*********************************************************************** %OWNINTEGER LL,LB1,LD1,LB2,LD2 %IF PARM_OPT=0 %THEN %START %IF LCA+6=CA %AND B1=LB1 %AND B2=LB2 %C %AND D1=LD1+LL %AND D2=LD2+LL %AND LL+L<=256 %START MOVE BACK PC(LCA) CA=LCA; L=L+LL D1=LD1; D2=LD2 %FINISH LCA=CA; LL=L; LB1=B1; LD1=D1 LB2=B2; LD2=D2 %FINISH PSS(MVC,L,B1,D1,B2,D2) %END %ROUTINE CNOP(%INTEGER I, J) PRR(BCR,0,0) %WHILE CA&(J-1)#I %END %INTEGERFN LONG CONST(%LONGINTEGER VALUE) !*********************************************************************** !* SIMPLE INTERFACE TO STORE DESCRIPTOR CONSTANT * !*********************************************************************** %INTEGER K STORE CONST(K,8,ADDR(VALUE)) %RESULT=K %END %INTEGERFN WORD CONST(%INTEGER VALUE) !*********************************************************************** !* SIMPLE INTERFACE TO STORE CONST FOR 32 BIT CONSTS * !*********************************************************************** %INTEGER K STORE CONST(K,4,ADDR(VALUE)) %RESULT=K %END %INTEGERFN SHORT CONST(%INTEGER VALUE) !*********************************************************************** !* STORE A 16 BIT CONSTANT VIA STORE CONST * !*********************************************************************** %INTEGER K STORE CONST(K,2,ADDR(VALUE)+2) %RESULT=K %END %ROUTINE STORE CONST(%INTEGERNAME D, %INTEGER L, AD) !*********************************************************************** !* PUT THE CONSTANT VAL OF LENGTH 'L' INTO THE CONSTANT TABLE * !* A CHECK IS MADE TO SEE IF THE CONSTANT HAS ALREADY * !* BEEN INSERTED IN WHICH CASE THE OLD COPY IS REUSED * !*********************************************************************** %INTEGER I, J, K, C1, C2, C3, C4, LP %INTEGERNAME CONST PTR CONST PTR==WORKA_CONST PTR LP=L//4; C1=0; C2=0; C3=0; C4=0 %CYCLE I=0,1,L-1 BYTEINTEGER(ADDR(C1)+I)=BYTEINTEGER(AD+I) %REPEAT K=WORKA_CONST BTM; ! AFTER STRINGS IN CTABLE %IF L=2 %START J=HALF HOLE %IF J=0 %THEN J=CONST PTR %FOR K=K,1,J-1 %CYCLE %IF C1=CTABLE(K)&X'FFFF0000' %THEN D=4*K %AND %RETURN %IF C1=CTABLE(K)<<16 %THEN D=4*K+2 %AND %RETURN %REPEAT %FINISH %ELSE %IF L=4 %THEN %START J=CONST PTR ! %IF USE IMP=YES %THEN %START %FOR K=K,1,J-1 %CYCLE %IF CTABLE(K)=C1 %AND CONSTHOLE#K %C %THEN D=4*K %AND %RETURN %REPEAT ! %FINISH %ELSE %START ! %FINISH %FINISH %ELSE %IF L=6 %START %FOR K=K,1,CONST PTR-2 %CYCLE %IF CTABLE(K)=C1 %AND CTABLE(K+1)&X'FFFF0000'=C2 %C %THEN D=4*K %AND %RETURN %IF CTABLE(K)<<16=C1&X'FFFF0000' %AND C1&X'FFFF' %C =CTABLE(K)>>16 %AND CTABLE(K+1)>>16=C2 %THEN %C D=4*K+2 %AND %RETURN %REPEAT %FINISH %ELSE %START J=CONSTPTR-LP %WHILE K<=J %CYCLE %IF CTABLE(K)=C1 %AND CTABLE(K+1)=C2 %AND %C (CONSTHOLE=K+LP) %START %IF L=8 %OR (CTABLE(K+2)=C3 %C %AND CTABLE(K+3)=C4) %THEN D=4*K %C %AND %RETURN %FINISH K=K+2 %REPEAT %FINISH %IF L=2 %START %IF HALFHOLE#0 %THEN %START CTABLE(HALFHOLE)=CTABLE(HALFHOLE)!(C1>>16) D=4*HALFHOLE+2 HALFHOLE=0 %RETURN %FINISH %IF CONSTHOLE#0 %START CTABLE(CONSTHOLE)=C1 HALFHOLE=CONSTHOLE CONSTHOLE=0 D=4*HALFHOLE %RETURN %FINISH CTABLE(CONST PTR)=C1 HALFHOLE=CONST PTR D=4*HALFHOLE CONST PTR=CONST PTR+1 %RETURN %FINISH %IF L=4 %AND CONSTHOLE#0 %START CTABLE(CONSTHOLE)=C1 D=4*CONSTHOLE CONSTHOLE=0 %RETURN %FINISH %IF L=6 %START %IF 0>16 CTABLE(CONSTHOLE)=C1<<16!C2>>16 D=4*HALFHOLE+2 HALFHOLE=0; CONSTHOLE=0 %RETURN %FINISH %IF 0>16 CTABLE(CONSTPTR)=C1<<16!C2>>16 D=4*HALFHOLE+2 HALFHOLE=0 CONST PTR=CONST PTR+1 %RETURN %FINISH CTABLE(CONST PTR)=C1 CTABLE(CONST PTR+1)=C2 HALFHOLE=CONST PTR+1 D=4*CONST PTR CONST PTR =CONST PTR+2 %RETURN %FINISH %IF L>4 %AND CONST PTR&1#0 %C %THEN CONSTHOLE=CONST PTR %AND CONSTPTR=CONST PTR+1 D=4*CONST PTR CTABLE(CONSTPTR)=C1 CTABLE(CONSTPTR+1)=C2 %IF L=16 %THEN CTABLE(CONSTPTR+2)=C3 %C %AND CTABLE(CONSTPTR+3)=C4 CONST PTR=CONST PTR+LP %IF CONST PTR>WORKA_CONST LIMIT %THEN FAULT(102, WORKA_WKFILEK,0) %END %ROUTINE STORE STRING(%INTEGERNAME D, %STRINGNAME S) !*********************************************************************** !* PUT THE STRING CONSTANT "S" INTO THE CONSTANT TABLE * !* A CHECK IS MADE TO SEE IF THE CONSTANT HAS ALREADY * !* BEEN INSERTED IN WHICH CASE THE OLD COPY IS REUSED * !*********************************************************************** %INTEGER J,K,LP %INTEGERNAME CONST PTR CONST PTR==WORKA_CONST PTR K=WORKA_CONST BTM LP=1+LENGTH(S)//4 J=CONSTPTR-LP %FOR K=1,1,J %CYCLE %IF S=STRING(ADDR(CTABLE(K))) %THEN D=4*K %ANDRETURN %REPEAT D=4*CONST PTR STRING(ADDR(CTABLE(CONSTPTR)))=S CONST PTR=CONST PTR+LP %IF CONST PTR>WORKA_CONST LIMIT %THEN FAULT(102,WORKA_WKFILEK,0) %END %ROUTINE GET ENV(%INTEGERNAME HEAD) !*********************************************************************** !* SAVE A COPY OF THE REGISTER STATE FOR FUTURE REFERENCE * !*********************************************************************** %INTEGER I, USE %RECORD(REGF)%NAME REG %CYCLE I=0, 1, MAXREG %CONTINUE %IF 10<=I<=14; ! SKIP FIXED USE REGS REG==REGS(I) USE=REG_USE&X'FF'; ! MAIN USE ONLY PUSH(HEAD, REG_INF1, REG_AT, I<<8!USE) %IF USE#0 %REPEAT %END %ROUTINE RESTORE(%INTEGER HEAD) !*********************************************************************** !* RESET THE REGISTERS TO ENVIRONMENT IN LIST HEADED BY 'HEAD' * !*********************************************************************** %INTEGER I, R, USE, INF, AT %RECORD(REGF)%NAME REG %CYCLE I=0, 1, MAXREG REG==REGS(I) %IF REG_CL>=0 %THEN REG_USE=0 %REPEAT %WHILE HEAD#0 %CYCLE POP(HEAD, INF, AT, I) R=I>>8; USE=I&255 REG==REGS(R) %IF REG_CL>=0 %THEN REG_USE=USE %AND REG_INF1=INF REG_AT=AT %REPEAT %END %ROUTINE REDUCE ENV(%INTEGERNAME OLDHEAD) !*********************************************************************** !* REMOVES FROM ENVIRONMENT OLDHEAD ANYTHING INCOMPATABLE WITH * !* THE CURRENT ENVIRONMENT. FOR MULTIPLE JUMPS TO LABELS * !*********************************************************************** %INTEGERNAME HEAD %INTEGER R,U,S1,S2,S3 %RECORD(LISTF)%NAME LCELL %RECORD(REGF)%NAME REG HEAD==OLDHEAD %WHILE HEAD>0 %CYCLE LCELL==ASLIST(HEAD) R=LCELL_S3>>8 U=LCELL_S3&255 REG==REGS(R) %IF (REG_PRIMUSE=U %AND REG_INF1=LCELL_S1) %OR %C (REG_SECUSE=U %AND REG_INF2=LCELL_S1) %START HEAD==LCELL_LINK %IF REG_AT>LCELL_S2 %THEN LCELL_S2=REG_AT ! TAKE MOST RECENT VERSION OF AT %FINISH %ELSE POP(HEAD,S1,S2,S3) %REPEAT %END %ROUTINE PGLA(%INTEGER BDRY, L, INF ADR) %INTEGER I, J J=GLACA; GLACA=(J+BDRY-1)&(-BDRY) GLACURR=GLACURR+GLACA-J; ! COMPLETE THE ROUNDING %IF L+GLACURR>256 %THEN %START %IF PARM_INHCODE=0 %C %THEN LIPUT(30+2, GLACURR, GLACABUF, ADDR(GLABUF(0))) GLACURR=0; GLACABUF=GLACA %FINISH %CYCLE I=0,1,L-1 GLABUF(GLACURR+I)=BYTE INTEGER(I+INF ADR) %REPEAT GLACA=GLACA+L; GLACURR=GLACURR+L %END %EXTERNALROUTINE PDATA(%INTEGER AREA,BNDRY,L,AD) !*********************************************************************** !* ADDS L(BYTES) TO AREA FOR UST,SST AND DIAGS AREAS * !*********************************************************************** %INTEGERNAME PTR PTR==CAS(AREA) PTR=(PTR+BNDRY-1)&(-BNDRY) %RETURN %IF PARM_INHCODE#0 LIPUT(30+AREA,L,PTR,AD) PTR=PTR+L %END %EXTERNALROUTINE PRDATA(%INTEGER AREA,BNDRY,L,REP,AD) !*********************************************************************** !* ADDS L(BYTES) REP TIMES TO AREA FOR UST,SST AND DIAGS AREAS * !*********************************************************************** %INTEGERNAME PTR PTR==CAS(AREA) PTR=(PTR+BNDRY-1)&(-BNDRY) %RETURN %IF PARM_INHCODE#0 LIPUT(40+AREA,L<<24!REP,PTR,AD) PTR=PTR+REP*L %END %ROUTINE PLUG(%INTEGER AREA, AT, VALUE, BYTES) !*********************************************************************** !* WRITE UP TO ONE WORD INTO OBJECT FILE OUT OF SEQUENCE * !*********************************************************************** %INTEGERNAME WCABUF %INTEGER I, RELAD, BUFAD WCABUF==CABUF; BUFAD=ADDR(CODE(0)) %IF AREA=2 %THEN WCABUF==GLACABUF %AND BUFAD=ADDR(GLABUF(0)) RELAD=AT-WCABUF %IF 0<=RELAD<=256 %AND AREA<=3 %THEN %START %CYCLE I=0,1,BYTES-1 BYTEINTEGER(RELAD+BUFAD+I)<-VALUE>>((BYTES-1-I)<<3) %REPEAT %FINISH %ELSE %START %IF AREA=1 %AND RELAD=-2 %THEN CODEOUT %IF PARM_INHCODE=0 %THEN %C LIPUT(30+AREA,BYTES,AT,ADDR(VALUE)+4-BYTES) %IF PARM_DCOMP=1=AREA %START NEWLINE IBMRECODE(ADDR(VALUE)+4-BYTES,ADDR(VALUE)+4,AT) %FINISH %FINISH %END %EXTERNALROUTINE FILL DTABREFS(%INTEGERNAME CURRINFRAL) !*********************************************************************** !* PLUGS REFENCES TO THE DIAG TABLES FOR CURRINF WHICH ARE * !* ABOUT TO BE GENERATED AT CAS(DAREA). THE LIST POPPED HAS * !* S1=AREA 1=CODE, DAREA FOR DIAGNOSTIC AREA * !* S2= THE OFFSET OF INSTRUCTION OR FORWARD POINTER * !* S3=THE WORD BEFORE FILLING - NOT USED FOR AREA 1 * !*********************************************************************** %INTEGER Q,JJ,KK %WHILE CURRINFRAL#0 %CYCLE POP(CURRINFRAL,Q,JJ,KK) %IF Q=1 %THEN %START KK=CAS(DAREA) PLUG(1,JJ,MVI<<8!((KK>>8)&255),2) PLUG(1,JJ+4,MVI<<8!(KK&255),2) %FINISH %ELSE %START PLUG(Q,JJ,KK!CAS(DAREA),4) %FINISH %REPEAT %END %EXTERNALINTEGERFN PINITOWN(%INTEGER PTYPE,ACC,%RECORD(RD)%NAME INIT, %STRINGNAME YNAME) !*********************************************************************** !* PUTS AN INITIALISED OWN INTO THE GLA. SHOULD DEAL WITH ALL TYPES * !*********************************************************************** %RECORD(RD)OPND %INTEGER PREC,TYPE,RL,RES,X,LITL %STRING(255)XNAME XNAME=UCSTRING(YNAME) TYPE=PTYPE&7 PREC=PTYPE>>4&7 LITL=PTYPE>>14&3 OPND=INIT %IF PTYPE&X'400'#0 %START; ! OWN NAMES PGLA(4,4,ADDR(OPND_D)) RES=GLACA-4 %IF LITL=3 %START; ! EXTRINSICS ARE NAMES LIPUT(15,2<<24!ACC,RES,ADDR(XNAME));! RELOCATE BY EXTERNAL %FINISH ->END %FINISH RL=BYTES(PREC) %IF TYPE=5 %OR TYPE=3 %THEN RL=4 %IF RL>8 %THEN RL=8 PGLA(RL,0,ADDR(OPND)) RES=GLACA; %IF TYPE=3 %OR (TYPE=5 %AND OPND_D=0) %START PGLA(1,1,ADDR(OPND_D)+3) %FOR X=1,1,ACC ->END %FINISH %IF TYPE=5 %THEN %START PGLA(1,ACC,ADDR(WORKA_A(OPND_D))) %FINISH %ELSE %START %IF PREC=3 %THEN PGLA(1,1,ADDR(OPND_D)+3) %IF PREC=4 %THEN PGLA(1,2,ADDR(OPND_D)+2) %IF PREC>=5 %THEN PGLA(1,4,ADDR(OPND_D)) %IF PREC=6 %THEN PGLA(1,4,ADDR(OPND_XTRA)) %FINISH END: ! NOTE ENTRYT IF EXTERNAL %IF LITL=2 %THEN LIPUT(14,2<<24!ACC,RES,ADDR(XNAME)) %RESULT=RES %END %EXTERNALINTEGERFN POWNARRAYHEAD(%INTEGER PTYPE,J,LB,SIZE,AOFFSET,AAREA, DVOFFSET,%STRING(31)XNAME) !*********************************************************************** !* SOME PARAMETERS ARE ONLY REQUIRED FOR CREATING DESCRIPORS ON * !* 2900 ARCHITECTURE. THESE ARE REDUNDANT HERE * !*********************************************************************** %INTEGER LITL,RES,AHW0,AHW1,AHW2,AHW3,PREC,TYPE XNAME=UCSTRING(XNAME) TYPE=PTYPE&7 PREC=PTYPE>>4&15 AHW0=AOFFSET-LB*CTABLE(DVOFFSET>>2+2) AHW1=AOFFSET AHW2=DVOFFSET AHW3=CTABLE(DVOFFSET>>2+2+3*J);! THE RELEVANE STRIDE PGLA(4,16,ADDR(AHW0)) RES=GLACA-16 LITL=PTYPE>>14&3 %IF LITL=3 %START; ! EXTRINSIC ARRAYS LIPUT(15,2<<24!SIZE,RES,ADDR(XNAME)) LIPUT(15,2<<24!SIZE,RES+4,ADDR(XNAME));! RELOCATE BY EXTERNAL %FINISH %ELSE %START %IF AAREA#0 %THEN RELOCATE(RES,AHW0,AAREA) %AND %C RELOCATE(RES+4,AHW1,AAREA) %FINISH RELOCATE(RES+8,AHW2,CAREA); ! RELOCATE DV PTR %IF LITL=2 %THEN LIPUT(14,AAREA<<24!SIZE,AOFFSET,ADDR(XNAME)) %RESULT=RES %END %ROUTINE GXREF(%STRING(31) NAME,%INTEGER MODE,XTRA,AT) !*********************************************************************** !* ASK IPUT TO ARRANGE FOR A TRIPLE WORD AT 'AT' IN THE GLA * !* TO CONTAIN A DESCRIPTOR FOR NAME 'NAME'. * !* MODE=0 "DONT CARE" XREF * !* MODE=1 SYSTEM CODE XREF * !* MODE=2 EXTERNAL CODE XREF * !* MODE=3 DYNAMIC CODE XREF * !* FOR MODES 0-3 XTRA IS PARAMETER CHECKING WORD * !* MODE=4 DATA XREF XTRA=MINIMIUM LENGTH (SINGLE WORD ONLY) * !*********************************************************************** %CONSTBYTEINTEGERARRAY IPUTCODE(0:4)= 12,12,12,13,15 NAME=UCSTRING(NAME) LIPUT(IPUTCODE(MODE),2{IN GLA},AT,ADDR(NAME)) %END %EXTERNALROUTINE CXREF(%STRING(255) NAME, %INTEGER MODE,XTRA,%INTEGERNAME AT) !*********************************************************************** !* CREATE A ZEROED AREA IN THE GLA AND CALL GXREF TO GET * !* IT FILLED AT LOAD TIME WITH INFORMATION ON AN EXTERNAL OBJECT * !* PARAMETERS ARE AS FOR GXREF. * !*********************************************************************** %INTEGER Z1,Z2,Z3,Z4 Z1=0; Z2=0; Z3=0; Z4=XTRA PGLA(4,16,ADDR(Z1)); ! 2 ZERO WORDS AT=GLACA-16 GXREF(NAME,MODE,XTRA,AT) %END %INTEGERFN KNOWN XREF(%INTEGER N) %INTEGER D %RESULT= KXREFS(N) %UNLESS KXREFS(N)=0 CXREF(KXREFNAME(N),0,-1,D); ! ALL FUNNY NAMES OMIT PARAM CHK KXREFS(N)=D %RESULT=D %END %ROUTINE CALL STOP !*********************************************************************** !* CALLS STOP ROUTINE. NOT VIA EPILOGUE ON PERQ * !************************************************************************ PRX(STM,4,14,WSPR,16) PRX(LM,12,14,GLA,KNOWNXREF(0)) PRR(BALCODE-X'40',15,14) %END %ROUTINE NOTE CREF(%INTEGER CA) !*********************************************************************** !* NOTE THAT A RELOCATION HAS N RELATIVE TO CONST TABLE * !* NOT REATIVE TO CODE. REMEMBER THE ADDRESS OF THE INSTRUCTION * !* SO THAT AN IPUT(18) CORRECTION CAN BE MADE AT END OF COMPILATION * !*********************************************************************** %RECORD(LISTF)%NAME CELL CELL==ASLIST(CREFHEAD) %IF CREFHEAD=0 %OR CELL_S3#0 %THEN %C PUSH(CREFHEAD,CA,0,0) %AND %RETURN %IF CELL_S2=0 %THEN CELL_S2=CA %ELSE CELL_S3=CA %END %EXTERNALROUTINE RELOCATE(%INTEGER GLARAD,VALUE,AREA) !*********************************************************************** !* PLANTS A WORD IN THE GLA (IF GLARAD<0) AND ARRANGES TO * !* RELOCATE IT RELATIVE TO AN AREA(CODE=1,GLA=2,CST=4,GST=5,CNTS=6) * !*********************************************************************** %IF AREA=CAREA %THEN NOTE CREF(VALUE&X'FFFF'!(GLARAD>>2<<16)) %C %AND AREA=1 LIPUT(19,2,GLARAD,AREA) %END %ROUTINE DEFINE EP(%STRING(255)XNAME, %INTEGER AREA,AT,MAINORMIN) !*********************************************************************** !* TO DEFINE AN EP SIMPLY TELL IPUT THE EP ADDRESS RELATIVE TO THE * !* START IF CODE. THIS IS STORED IN THE LOAD DATA. AT LOAD TIME * !* THE THREE WORDS IN THE GLA OF THE CALLING ROUTINE ARE FILLED * !* WITH START IF CODE,START OF GLA AND EP ADDRESS RESPECTIVELY * !* (DOCUMENTATION OF OBJECT FORMAT & IPUT DIFFER HEREABOUTS!) * !*********************************************************************** %RECORDFORMAT XREFF(%INTEGER W0,W1,W2,PW) %RECORD(XREFF)XREF XNAME=UCSTRING(XNAME) XREF=0 XREF_W2=AT XREF_PW=-1 LIPUT(11,MAINORMIN<<31!1,ADDR(XREF),ADDR(XNAME)) %END %ROUTINE PRINTUSE !*********************************************************************** !* UP TO TWO USES ARE REMEMBERED INFO IN GRINF1 & GRINF2 * !* BOTTOM HALF OF GRUSE RELATES TO INF1 TOP HALF TO INF2 * !* THE MEANS CLEARING GRUSE TO FORGETS THE REG COMPLETELY * !* ARRAY REGISTER KEEPS THE CLAIM STATUS AND GRAT THE LAST USE * !*********************************************************************** %CONSTSTRING(3)%ARRAY REGNAMES(0:MAXREG)="GR0","GR1","GR2","GR3", "GR4","GR5","GR6","GR7", "GR8","GR9","GRA","GRB", "GRC","GRD","GRE","GRF", "FR0","FR2","FR4","FR6"; %CONSTSTRING(15)%ARRAY USES(0:16) =" NOT KNOWN "," I-RESULT ", " TEMPORARY "," RTPARAM ", " NAMEBASE "," LIT CONST ", " TAB CONST "," DESC FOR ", " BASE OF "," LOCAL VAR ", " LOCALTEMP "," 4K MULT ", " 4K FORLAB "," BASE REG ", " 4K FOR EPI"," DV BASE ", " STRWKAREA "; %CONSTSTRING(11)%ARRAY STATE(-1:3)=%C " LOCKED "," FREE ", " I-RESULT "," TEMPORARY ", " RT-PARAM "; %ROUTINESPEC OUT(%INTEGER USE,INF) %INTEGER I,USE %RECORD(REGF)%NAME REG %CYCLE I=0,1,MAXREG REG==REGS(I) %IF REG_CL<0 %AND 10<=I<=14 %THEN %CONTINUE %IF REG_CL!REG_USE#0 %START USE=REG_USE PRINTSTRING(REGNAMES(I).STATE(REG_CL)) WRITE(REG_CNT,1) WRITE(REG_AT,2) OUT(USE&255,REG_INF1) %IF USE>>16#0 %THEN PRINTSTRING(" ALSO ") %C %AND OUT(USE>>16,REG_INF2) NEWLINE %FINISH %REPEAT %RETURN %ROUTINE OUT(%INTEGER USE,INF) %CONSTINTEGER LNMASK=B'1000001110000000' %CONSTINTEGER UNMASK=B'0000001110000000' PRINTSTRING(" USE = ".USES(USE)) %IF LNMASK&1<>16#0 %THEN PRINTSTRING(" MODBY ") %C %AND PRINTSTRING(PRINTNAME(INF>>16)) %END %END %EXTERNALROUTINE IMPABORT PRINTSTRING(" **************** IMPABORT ***************** IMPABORT *******") RECODE(ADDR(CODE(0)), ADDR(CODE(PPCURR)), CABUF) %C %UNLESS CA=CABUF %MONITOR %STOP %END %EXTERNALROUTINE PROLOGUE(%RECORD(LISTF)%ARRAYNAME ALIST) !*********************************************************************** !* GENERATES THE SUBROUTINE THAT ALWAYS ARE REQUIRED ONTO THE * !* FRONT OF THE OBJECT PROGRAM WHERE THEY ARE DIRECTLY ADDRESABLE* !*********************************************************************** %ROUTINESPEC ERR EXIT(%INTEGER A, B, C) %INTEGER I, K CPINIT; ! INITIALISE CODE PLANTING ASLIST==ALIST CA==CAS(1) GLACA==CAS(2) CA=0 GLACA=FIXEDGLALEN GLACABUF=FIXEDGLALEN CABUF=CA HALF HOLE=0; OLD LINE=-1 CONST HOLE=0; CREFHEAD=0 CTABLE==WORKA_CTABLE I=X'C2C2C2C2' LIPUT(30+DAREA,4,0,ADDR(I)) CAS(DAREA)=4 %CYCLE I=0, 1, 31 WORKA_PLABS(I)=0; WORKA_PLINK(I)=0 %REPEAT %CYCLE I=0,1,MAXREG REGS(I)=0 KXREFS(I)=0 %IF I<=MAXKXREF %REPEAT REGS(WSPR)_CL=-1 REGS(CODER)_CL=-1 REGS(GLA)_CL=-1 REGS(CTABLEREG)_CL=-1 USINGR=12; USINGAT=0 ! ! GENERATE THE TABLE OF 4K MULTIPLES ! MAX4KMULT=WORKA_ARTOP//4096+3 %IF MAX4KMULT<10 %THEN SWITEMSIZE=2 %ELSE SWITEMSIZE=4 PCONST(4096*I) %FOR I=0,1,MAX4KMULT ! ! GENERATE THE FIXED-FLOAT CONSTANTS THAT MAY BE NEEDED ! UNASS OFFSET=CA PCONST(UNASSPAT) %FOR I=1,1,2 WORKA_PLABS(1)=CA; ! LAB(1) MARRKS ANY FIXED-FLOAT CONSTANTS PCONST(255); ! FOR ANDING DOWN BYTES PCONST(-1) PCONST(X'80000000') PCONST(1) {16} PCONST(0); PCONST(0); ! DOUBLE ZERO {24} PCONST(X'4E000000'); PCONST(0); ! FIX CONST THESE ARE HERE AS CONSTANT ! AREA CAN OVERFLOW 4K AND THIS MAKES ! THE IN LINE JUMPS HARDED {32} PCONST(X'4E000001'); PCONST(0) {40} PCONST(X'4E000000'); PCONST(-1) {48} PCONST(X'50800000'); PCONST(0) {56} PCONST(X'51880000'); PCONST(0) {64} PCONST(X'5C000000'); PCONST(X'80');! 2**63 UNNORMALISED ! ! GENERATE THE RUN TIME ERROR ROUTINE :- ! MDIAGS FOR NR IS %ROUTINE MDIAGS(%INT PC,LNB,ERROR,XTRA) ! PC IS A DUMMY (SEG FIELD ONLY USED) EXCEPT AFTER CONTINGENCY ! ON ENTRY TO THIS SUBROUTINE ERROR & XTRA ARE IN GRS 0&1 ! ENTRY HAS BEEN BY BAS LINKREG SO RETURN ADDRESS IS AVAILABLE ! ! ST 15,64(11) ! STM 0,1,72(11) ! LR 0,10 ! LR 1,9 ! BAS LINKREG,CHECK IF R9 A VALID LNB ! LR 1,8 ! BAS LINKREG,CHECK DITTO FOR R8 ! LR 1,7 ! BAS LINKREG,CHECK DITTO ! LR 1,6 ! BAS LINKREG,CHECK DITTO ! LR 1,5 ! BAS LINKREG,CHECK DITTO !CHFAIL ST 0,68(11) ! STM 4,14,16(11) ! LM CODER,EPREG,40(13) MDIAG ENTRY POINT ! L 15,64(11) ! BCR 15,EPREG !CHECK CR 1,11 ! BC 2,CHFAIL ! CR 1,0 ! BC 12,CHKAIL ! C 1,44(1) CHECK STORE STACK POINTER ! BC 7,CHFAIL ! LR 0,1 ! BCR 15,LINKREG ! WORKA_PLABS(2)=CA PRX(ST,15,0,11,64) PRX(STM,0,1,11,72) PRR(LR,0,10) %CYCLE I=9,-1,5 PRR(LR,1,I) PRX(BALCODE,LINKREG,0,CODER,CA+22+6*(I-5)) %REPEAT K=CA PRX(ST,0,0,11,68) PRX(STM,4,14,11,16) PRX(LM,CODER,EPREG,GLA,KNOWN XREF(1)) PRX(LGR,15,0,11,64) PRR(BCR,15,EPREG) PRR(CR,1,11) PRX(BC,2,0,CODER,K) PRR(CR,1,0) PRX(BC,12,0,CODER,K) PRX(ICP,1,0,1,44) PRX(BC,7,0,CODER,K) PRR(LR,0,1) PRR(BCR,15,LINKREG) ! ! SUBROUTINE TO CALL DEBUG ROUTINE(S#IMPMON) LINE NO IN GR0 ! ! STM 4,0,16(11) ! LM CODER,EPREG,EPDIST ! BCR 15,LINKREG RETURN ADDR ALREADY IN GR15 ! %IF PARM_DBUG#0 %THEN %START WORKA_PLABS(3)=CA PRX(STM,4,0,16,11) PRX(LM,CODER,EPREG,GLA,KNOWN XREF(5)) PRR(BCR,15,LINKREG) %FINISH ! ! SUBROUTINE TO ADVANCE STACK FRONT BY GR0 WORDS AND FILL WITH UNASSIGNED ! GR1 HAS BYTES OF PARAMETERS WHICH MUST NOT BE OVERWRITTEN ! ! ! AR 1,11 BYTE TO START CLEARING ! AR 11,0 CLAIM SPACE !AGN CR 1,11 ! BCR 10,LINKREG ! MVI 0(1),UNASSPAT ! MVC 1(255,1),0(1) ! LA 1,256(1) ! BC 15,AGN ! ! THIS NEXT VERSION IS FOR XA ARCHITECTURE ONLY ! ! LA 2,0(1,11) ! AR 11,0 ADVANCE STACK FRONT ! SR 0,1 LENGTH OF FILL ! LR 1,0 TO CORRECT PLACE ! LR 0,2 ! LA 3,UNASSPAT&255 ! SLL 3,24 ! MVCL 0,2 ! BCR 15,LINKREG %IF PARM_CHK=1 %THEN %START; ! ONLY REQUIRED WITH CHKING WORKA_PLABS(4)=CA PRX(LA,2,1,WSPR,0) PRR(AR,WSPR,0) PRR(SR,0,1) PRR(LR,1,0) PRR(LR,0,2) PRX(LA,3,0,0,UNASSPAT&255) PRX(SLL,3,0,0,24) PRR(MVCL,0,2) PRR(BCR,15,LINKREG) %FINISH ! ! SOME ERROR ROUTINES ! ERR EXIT(5, X'801', 0) %IF PARM_OPT#0; ! UNASSIGNED VARIABLE ERR EXIT(6, X'802', 0); ! SWITCH LABEL UNSET ERR EXIT(7, X'505', 1); ! ILLEGEAL EXPONENTIATION ERR EXIT(8,X'201', 0) %IF PARM_OPT#0; ! EXCESS BLOCKS ERR EXIT(9, X'601', 0); ! CAPACITY EXCEEDED ERR EXIT(10,21, 0) ; ! NO RESULT ERR EXIT(11,X'501', 0) %IF PARM_OPT#0; ! CYCLE NOT VALID ERR EXIT(12,X'701',0); ! RES FAILS ERR EXIT(13,36,0) %IF PARM_OPT#0; ! WRONG NO OF PARAMS CTABLE(1)=M'IDIA' WORKA_CONST PTR=2 WORKA_CONST BTM=0 %IF PARM_PROF#0 %THEN %START; ! ALLOCATE PROFILE COUNT AREA PROFDATA=GLACA K=WORKA_LINE PGLA(4,4,ADDR(K)) K=0 %CYCLE I=0,1,WORKA_LINE PGLA(4,4,ADDR(K)) %REPEAT WORKA_LINE=0 %FINISH %RETURN %ROUTINE ERR EXIT(%INTEGER LAB, ERRNO, MODE) !*********************************************************************** !* MODE=0 FOR DUMMY(ZERO) XTRA - MODE=1 XTRA IN GR1 * !*********************************************************************** WORKA_PLABS(LAB)=CA %IF MODE=0 %THEN PRR(SR,1,1) PRX(LA,0,0,0,ERRNO) PRX(BC,15,0,CODER,WORKA_PLABS(2)) %END %END %EXTERNALROUTINE EPILOGUE(%INTEGER STMTS) !*********************************************************************** !* PLANT ANY SUBROUINES THAT HAVE BEEN REQUIRED DURING * !* THE CODE GENERATION PHASE * !*********************************************************************** %ROUTINESPEC LONGOP(%INTEGER OP) %ROUTINESPEC FILL(%INTEGER LAB) ! ! STRING RESOLUTION SUBROUTINE ! ON ENTRY GR0 HAS ADDRESS OF WK AREA HOLDING ! W1(GR2) HAS ADDRESS OF ORIGINAL STRING ! W2(GR3) BYTE0 HAS ORIGINAL LENGTH OF LHS ! BYTE1 HAS BYTES USED UP IN PREV RESOLUTIONS. ! BYTES 2&3 HAVE MAX LENGTH OF FRAGMENT STRING ! W3(GR4) HAS ZERO OR STRINGNAME TO HOLD FRAGMENT ! W4(GR5) HAS ADDRESS OF RESOLUTION EXPRESSION(READ ONLY) ! ! ON EXIT RESULT IS SET BY CC AND W2 UPDATED. NO OTHER EFFECTS ! EXCEPT POSSIBLY STORING INTO FRAGMENT W3 ! ! STM 1,10,4(WSPR) LOTS OF REGISTERS NEEDED ! LR 1,0 NOW PICK UP W1-4 ! SR 0,0 FOR VARIOUS ICS LATER ! LM 2,5,0(1) ! BASR 9,0 BASE REGISTER COVER VIA 9 ! CLI 5(1),0 FIRST ENTRY ? ! BC 7,NOT FIRST 14(9) ! MVC 4(1,1),0(2) COPY ORIGINAL LENGTH !NOTFIRST ! WORK OUT NO OF VALID COMPARISONS ! SR 6,6 ! IC 6,4(1) ORIGINAL LENGTH ! IC 0,5(1) ! SR 6,0 MINUS BYTES USED ! SR 7,7 ! IC 7,0(5) LENGTH OF EXPRESSION ! SR 6,7 ! BL RESFAIL 74(9) NOT ENOUGH LENGTH ! LA 6,1(6) EQUAL LENGTHS = 1 VALID COMP ! LTR 7,7 ! BC 8,NULL RES 150(9) RESOLVING FOR NULL STRING ! BCTR 7,0 FOR EXECUTING ! IC 0,5(1) ! AR 2,0 POINT TO START SEARCH -1 ! LR 10,2 SAVE THIS FOR STORING FRAGMNT !NRLOOP ! EX 7,COMP 82(9) COMPARE ! BC 8,NROK 88(9) FOUND IT ! LA 2,1(2) STEP ALONG 1 ! BCT 6,NRLOOP 58(9) AND KEEP GOING !RESFAIL LM 1,10,4(WSPR) WONT RESOLVE ! NR WSPR,WSPR SET NON ZERO CC ! BCR 15,LINKREG AND RETURN !COMP CLC 1(1,5),1(2) !NROK ! SR 2,10 LENGTH OF FRAGMENT ! LTR 4,4 IS FRAGMNT TO BE STORED ! BC 8,NOSTORE 112(9) ! EX 2,MOVE 136(9) COPY IT +RUBBISH LENGTH BYTE ! STC 2,0(4) RESET LENGTH BYTE ! CH 2,6(1) PERFORM CAP EXCEEDED CHECK ! BC 10,CPE 142(9) !NOSTORE IC 0(5(1) ! AR 2,0 R2=FRAG LENGTH + ORIG USED ! AR 2,7 PLUS BYTES OF EXPR ! LA 2,1(2) ! STC 2,5(1) BACK INTO WORK AREA !REND LM 1,10,4(WSPR) ! CR WSPR,WSPR SET CC TO 0 ! BCR 15,LINKREG !MOVE MVC 0(1,4),0(10) !CPE LM 1,10,4(WSPR) ! BC 15,PLABS9 !NULL RES RESOLVING ON NULL STRING ! LTR 4,4 ANY FRAG STRING ! BC 8,REND 128(9) NO SO EXIT ! MVI 0(4),0 SET IT TO NULL ! BC 15,REND 128(9) ! BCR 15,LINREG %IF WORKA_PLINK(16)=0 %THEN ->P17 FILL(16) PRX(STM,1,10,WSPR,4) PRR(LR,1,0) PRR(SR,0,0) PRX(LM,2,5,1,0) PRR(BALCODE-X'40',9,0) PSI(CLI,0,1,5) PRX(BC,7,0,9,14) PSS(MVC,1,1,4,2,0) PRR(SR,6,6) PRX(IC,6,0,1,4) PRX(IC,0,0,1,5) PRR(SR,6,0) PRR(SR,7,7) PRX(IC,7,0,5,0) PRR(SR,6,7) PRX(BC,4,0,9,74) PRX(LA,6,0,6,1) PRR(LTR,7,7) PRX(BC,8,0,9,150) PRR(BCTR,7,0) PRX(IC,0,0,1,5) PRR(AR,2,0) PRR(LR,10,2) PRX(EX,7,0,9,82) PRX(BC,8,0,9,88) PRX(LA,2,0,2,1) PRX(BCT,6,0,9,58) PRX(LM,1,10,WSPR,4) PRR(NR,WSPR,WSPR) PRR(BCR,15,LINKREG) PSS(CLC,1,5,1,2,1) PRR(SR,2,10) PRR(LTR,4,4) PRX(BC,8,0,9,112) PRX(EX,2,0,9,136) PRX(STC,2,0,4,0) PRX(CH,2,0,1,6) PRX(BC,10,0,9,142) PRX(IC,0,0,1,5) PRR(AR,2,0) PRR(AR,2,7) PRX(LA,2,0,2,1) PRX(STC,2,0,1,5) PRX(LM,1,10,WSPR,4) PRR(CR,WSPR,WSPR) PRR(BCR,15,LINKREG) PSS(MVC,1,4,0,10,0) PRX(LM,1,10,WSPR,4) PRX(BC,15,0,CODER,WORKA_PLABS(9)) PRR(LTR,4,4) PRX(BC,8,0,9,128) PSI(MVI,0,4,0) PRX(BC,15,0,9,128) P17: ! ! MULTIPLY TWO LONG INTEGER %IF WORKA_PLINK(17)=0 %THEN ->P18 FILL(17) LONGOP(MXR) P18: ! ! DIVIDE TWO LONG INTEGERS %IF WORKA_PLINK(18)=0 %THEN ->P19 FILL(18) LONGOP(DXR) P19: ! CONCATENATION ONE ! NOW DONE IN LINE %IF WORKA_PLINK(19)!WORKA_PLINK(20)=0 %THEN ->P21 P21: %BEGIN !*********************************************************************** !* PASS INFORMATION TO IPUT TO ENABLE IT TO GENERATE THE * !* LOADER DATA AND COMPLETE THE PROGRAM FILE. * !*********************************************************************** %ROUTINESPEC DUMPCONSTS %INTEGER LANGFLAG,PARMS,I,J,K CODE OUT CNOP(0, 8) DUMP CONSTS %IF PARM_TRACE=0 %THEN LANGFLAG=6 %ELSE LANGFLAG=3 LANGFLAG=LANGFLAG<<24 PARMS=(PARM_DIAG<<1!PARM_LINE)<<1!PARM_TRACE FIXED GLA(4)=LANGFLAG!WORKA_RELEASE<<16!(PARM_CPRMODE&1)<<8!PARMS;! LANG RLSE & MAINPROG I=GLACA-GLACABUF %IF PARM_INHCODE=0 %THEN %START LIPUT(30+2, I, GLACABUF, ADDR(GLABUF(0))) %UNLESS I=0 ! BACK OF GLAP LIPUT(30+2, FIXEDGLALEN, 0, ADDR(FIXED GLA(0)));! FRONT OF GLAP LIPUT(19,2,4,1); ! RELOCATE HEAD OF CODE LIPUT(19,2,8,5); ! RELOCATE GLA ST ADDRESS LIPUT(19,2,12,4); ! RELOCATE CODE ST ADDRESS LIPUT(19,2,20,DAREA); ! RELOCATE DIAG AREA PTYR LIPUT(19,2,24,1); ! RELOCATE CONSTANT AREA ! TILL PROPER INTERFACE APPEARS I=X'E2E2E2E2' LIPUT(30+DAREA, 4, CAS(DAREA), ADDR(I)) CAS(DAREA)=CAS(DAREA)+4 %FINISH %CYCLE I=1,1,6 CAS(I)=(CAS(I)+7)&(-8) %REPEAT PRINTSTRING(" IBM CODE") WRITE(CA, 6) PRINTSTRING(" BYTES GLAP") WRITE(GLACA, 3); PRINTSTRING("+") WRITE(CAS(5), 1); PRINTSTRING(" BYTES DIAG TABLES") WRITE(CAS(DAREA), 3); PRINTSTRING(" BYTES TOTAL") K=CA+GLACA+CAS(4)+CAS(5)+CAS(6) WRITE(K, 5); PRINTSTRING(" BYTES ") %IF PARM_FAULTY=0 %THEN %START WRITE(STMTS, 7); PRINTSTRING(" STATEMENTS COMPILED") COMREG(47)=STMTS; ! NO OF STMTS FOR COMPER %FINISH %ELSE %START PRINTSTRING("PROGRAM CONTAINS"); WRITE(PARM_FAULTY, 2) PRINTSTRING(" FAULT"); PRINTSYMBOL('S') %IF PARM_FAULTY>1 COMREG(47)=PARM_FAULTY; ! NO OF FAULTS FOR COMPER %FINISH NEWLINES(2) I=0; I=8 %IF PARM_FAULTY#0 COMREG(24)=I CAS(7)=K %IF PARM_INHCODE=0 %THEN LIPUT(7, 28, 0, ADDR(CAS(1))) ! SUMMARY INFO. PPROFILE %STOP %ROUTINE DUMP CONSTS !*********************************************************************** !* OUTPUT THE CONSTANT TABLE AND MAKE ANY RELEVANT RELOCATIONS * !*********************************************************************** %ROUTINESPEC RELFIX(%INTEGER HEAD) %ROUTINESPEC DOIT(%INTEGER VAL) %INTEGER I,J,K,SIZE,BASE BASE=0 SIZE=WORKA_CONSTPTR-BASE %IF SIZE<=0 %THEN %RETURN CNOP(0,8) %UNLESS CA&7=0 CODE OUT FIXED GLA(6)=CA; ! TILL PROPER AREA 6 APPEARS LIPUT(30+1,SIZE*4,CA,ADDR(CTABLE(BASE))) !*DELSTART %IF PARM_DCOMP#0 %START PRINTSTRING(" CONSTANT TABLE") I=BASE %CYCLE NEWLINE PRHEX(4*(I-BASE),5) %CYCLE J=0,1,7 SPACES(2) PRHEX(CTABLE(I+J),8) %REPEAT SPACE %CYCLE J=0,1,31 K=BYTEINTEGER(ADDR(CTABLE(I))+J) %IF K<31 %OR K>125 %THEN K=32 PRINT SYMBOL(K) %REPEAT I=I+8 %EXIT %IF I>=WORKA_CONSTPTR %REPEAT %FINISH !*DELEND ! RELFIX(CREFHEAD) SIZE=(SIZE+1)&(-2) CA=CA+4*SIZE CABUF=CA %RETURN %ROUTINE RELFIX(%INTEGER CREFHEAD) %INTEGER I,J,K %WHILE CREFHEAD#0 %CYCLE POP(CREFHEAD,I,J,K) DOIT(I) %IF J#0 %THEN DOIT(J) %IF K#0 %THEN DOIT(K) %REPEAT %END %ROUTINE DOIT(%INTEGER VAL) !*********************************************************************** !* VAL IS GLAWRDADDRR<<16!CTABLE WRD ADDR * !* THE GLA WORD IS TO RELOCATED BY HEAD OF CODE(ALREADY DONE) * !* HOWEVER THE GLAWORD NEEDS UPDATING FROM REL CTABLE TO REL CODE * !*********************************************************************** %INTEGER I,J I=(VAL>>16)<<2; ! GLA BYTE ADDRESS J=(VAL&X'FFFF')+CA; ! CTABLE ENTRY REL HD OF CODE PLUG(2,I,J,4); ! UPDATE THE GLA WORD %END %END %END %RETURN %ROUTINE LONGOP(%INTEGER OP) !*********************************************************************** !* PLANTS A SUBROUTINE TO CARRY OUT AN OPERATION ON 2 LONG * !* INTEGER AT WSPR+8 &WSPR+16. THE METHOD IS TO FLOAT BOTH AND * !* USE 128 REAL OPERATIONS AND THE FIX. RESULT IS LEFT IN GR0&1 * !* GRS 0-3 AND FRS 0-3 SHOULD BE SAVED BY PPJ * !*********************************************************************** %INTEGER W ! ! THE CODE PLANTED IS ! ! LD 4,X'5C00000000000080' ! SDR 6,6 ! STD 4,0(WSPR) ! XC 7(1,WSPR),8(WSPR) ! LD 2,8(WSPR) ! STD 4,8(WSPR) READY FOR NEXT FIT ! LD 0,0(WSPR) ! SXR 0,4 COMPLETE FLOAT AND NORMALISE ! STD 0,24(WSPR) ! STD 2,32(WSPR) SAVE FLTED OPND1 ! XC 15(1,WSPR),8(WSPR) ! LD 0,8(WSPR) ! LD 2,16(WSPR) ! SXR 0,4 COMPLETE FLOAT OF OPND2 ! LD 4,24(WSPR) ! LD 6,32(WSPR) ! MXR(OR DXR) 4,0 ! SDR 2,2 ! LD 0,X'5188000000000000' ! AXR 0,4 ! STD 0,16(WSPR) ! STD 2,24(WSPR) ! XI 17(WSPR),X'08' ! MVC 24(2,WSPR),25(WSPR) CLOSE UP MANTISSA ! MVO 7(10,WSPR),17(9,WSPR) ! LM 0,1,8(WSPR) ! BCR 15,15 W=WORKA_PLABS(1); ! OFFSET OF FIX FLOAT CONSTS PRX(LD,4,0,CODER,W+64) PRR(SDR,6,6) PRX(STD,4,0,WSPR,0) PSS(XC,1,WSPR,7,WSPR,8) PRX(LD,2,0,WSPR,8) PRX(STD,4,0,WSPR,8) PRX(LD,0,0,WSPR,0) PRR(SXR,0,4) PRX(STD,0,0,WSPR,24) PRX(STD,2,0,WSPR,32) PSS(XC,1,WSPR,15,WSPR,16) PRX(LD,0,0,WSPR,8) PRX(LD,2,0,WSPR,16) PRR(SXR,0,4) PRX(LD,4,0,WSPR,24) PRX(LD,6,0,WSPR,32) %IF OP<255 %THEN PRR(OP,4,0) %ELSE PRRX(OP,4,0) PRR(SDR,2,2) PRX(LD,0,0,CODER,W+56) PRR(AXR,0,4) PRX(STD,0,0,WSPR,16) PRX(STD,2,0,WSPR,24) PSI(XI,X'08',WSPR,17) PSS(MVC,2,WSPR,24,WSPR,25) PSS(MVO,X'99',WSPR,7,WSPR,17) PRX(LM,0,1,WSPR,8) PRR(BCR,15,15) %END %ROUTINE FILL(%INTEGER LAB) !*********************************************************************** !* FILL JUMPS TO THIS LAB WITH JUMP TO CURRENT ADDRESS * !* TOP BIT SET IN INSTRN WHEN 4K MULT ALREADY LOADED * !*********************************************************************** %INTEGER AT,INSTRN,I,MULT,TOP %INTEGERARRAY A(0:2) MULT=CA>>12 MULT=4*MULT; ! DISP OF MULT TOP=WORKA_PLINK(LAB) %WHILE TOP#0 %CYCLE POP(TOP,A(0),A(1),A(2)) %CYCLE I=0,1,2 INSTRN=A(I) %IF INSTRN#0 %THEN %START AT=INSTRN&X'FFFFFF'+2 %IF INSTRN>0 %THEN PLUG(1,AT,MULT,2) %AND AT=AT+4 PLUG(1,AT,CODER<<12!CA&4095,2) %FINISH %REPEAT %REPEAT WORKA_PLABS(LAB)=CA WORKA_PLINK(LAB)=0 %END %END %EXTERNALROUTINE CHANGESEX(%INTEGER BASEAD,OFFSET,L) !*********************************************************************** !* ALTERERS INITIALISED DATA FOR A BYTE SEX CHANGE * !* HOWEVER IBMS AND EMAS HAVE THE SAME BYTE SEX * !*********************************************************************** %END %EXTERNALROUTINE REFORMATC(%RECORD(RD)%NAME OPND) !*********************************************************************** !* REFORMATS A CONSTANT TO TAKE INTO ACCOUNT DIFFERENT HOST-TARGET * !* REPRESENTATIONS. HOWEVER EMAS FORMAT IS IBMXA FORMAT * !*********************************************************************** %END %EXTERNALROUTINE GENERATE(%RECORD(TRIPF) %ARRAYNAME TRIPLES, %INTEGER CURRLEVEL, %ROUTINE GET WSP(%INTEGERNAME PLACE, %INTEGER SIZE)) !*********************************************************************** !* EVALUATE A LIST OF TRIPLES PLABTING CODE IN BUFFERS * !*********************************************************************** %ROUTINESPEC CIOCP(%INTEGER A,B) %ROUTINESPEC CONSTEXP(%INTEGER PTYPE,VALUE) %ROUTINESPEC SAVE IRS(%INTEGER UPPER) %ROUTINESPEC SET USE(%INTEGER REG,PTYPE,USE,INF) %ROUTINESPEC FREE AND FORGET(%INTEGER REG) %ROUTINESPEC FORGET(%INTEGER REG) %ROUTINESPEC COPY USE(%INTEGER TO,FROM) %ROUTINESPEC FORGETM(%INTEGER UPPER) %ROUTINESPEC CLAIM THIS REG(%INTEGER REG) %ROUTINESPEC CLAIM ALL4 FRS %INTEGERFNSPEC CLAIM OTHER FRPAIR(%INTEGER PAIR0) %ROUTINESPEC FIND USE(%INTEGERNAME REG,%INTEGER PTYPE,USE,INF) %INTEGERFNSPEC FINDREG(%INTEGER MASK,CLVAL) %INTEGERFNSPEC FINDSEQREG(%INTEGER MASK,CLVAL) %INTEGERFNSPEC ACCEPTABLE REG(%INTEGER MASK,REG) %ROUTINESPEC SET LOCAL BASE(%INTEGERNAME LB,LA) %ROUTINESPEC PPJ(%INTEGER MASK,N,SAVE) %INTEGERFNSPEC SET DVREG(%INTEGER WHICH,DVBD,ANAME) %ROUTINESPEC SSTRASS(%RECORD(RD)%NAME LHOPND,RHOPND,%INTEGER ACC) %INTEGERFNSPEC SSVARASS(%INTEGER S,B,D,%RECORD(RD)%NAME OPND) %ROUTINESPEC VMULTIPLY %ROUTINESPEC LNEGATE(%INTEGER REG) %ROUTINESPEC REXP %ROUTINESPEC STARSTAR %ROUTINESPEC NOTE ASSMENT(%INTEGER REG,ASSOP,VAR,PTYPE) %ROUTINESPEC CEND %INTEGERFNSPEC REACHABLE(%INTEGER LAB,LINK) %ROUTINESPEC LOAD(%RECORD(RD) %NAME OP,%INTEGER REG,MODE) %ROUTINESPEC LOAD PAIR(%INTEGER TYPE,ODDEVEN,%RECORD(RD)%NAME OPND) %ROUTINESPEC LOADAD(%RECORD(RD) %NAME OPND,%INTEGER REG) %ROUTINESPEC LOADPTR(%RECORD(RD) %NAME OPND,OPND2,%INTEGER REG) %ROUTINESPEC DSTORE(%INTEGER REG,SIZE,LEVEL,DISP) %ROUTINESPEC CALL COMING(%INTEGER UPPER) %ROUTINESPEC CALL MADE %ROUTINESPEC GET IN ACC(%INTEGERNAME REG,%INTEGER SIZE,%RECORD(RD)%NAME OPND) %ROUTINESPEC GET OUT OF ACC(%INTEGER REG,SIZE,%RECORD(RD)%NAME OPND) %ROUTINESPEC BOOT OUT(%INTEGER REG) %ROUTINESPEC DFETCH(%INTEGERNAME REG,%INTEGER SIZE,LEVEL,DISP) %ROUTINESPEC INC REG(%INTEGER REG,AMOUNT,LAOK) %ROUTINESPEC DFETCHAD(%INTEGERNAME REG,%INTEGER LEVEL,DISP) %ROUTINESPEC ADJUST INDEX(%INTEGER MODE,%INTEGERNAME INDEX,DISP) %ROUTINESPEC DUMPRXE(%INTEGER CODE,%INTEGERNAME REG,%INTEGER X,B,D) %ROUTINESPEC DUMPRX(%INTEGER CODE,REG,X,LEVEL,DIS) %ROUTINESPEC DUMPSI(%INTEGER CODE,L,B,D) %ROUTINESPEC DUMPM(%INTEGER CODE,R1,R2,B,D) %ROUTINESPEC DUMPSS(%INTEGER OP,L,B1,D1,B2,D2) %ROUTINESPEC EXECUTESS(%INTEGER XREG,OPCODE,B1,D1,B2,D2) %ROUTINESPEC PUT(%INTEGER REG,CODE,OFFSET,FINISHED,%RECORD(RD)%NAME OPND) %ROUTINESPEC REDUCE BASE(%RECORD(RD)%NAME OPND) %ROUTINESPEC OPERAND USED(%RECORD(RD)%NAME OPND) %ROUTINESPEC OPERAND LOADED(%RECORD(RD)%NAME OPND,%INTEGER REG) %INTEGERFNSPEC RESULTREG(%INTEGER PTYPE) %ROUTINESPEC BULKM(%INTEGER MODE,L,B1,D1,B2,D2) ! %RECORD(RD) %NAME OPND1,OPND2,OPNDC,OPNDNC,OPND %RECORD(TRIPF) %NAME CURRT,WORKT %RECORD(LEVELF) %NAME LINF,CURRINF %RECORD(TAGF) %NAME TCELL %RECORD(LISTF) %NAME LCELL %RECORD(RD) TOPND; ! TEMPORARY OPERANDS ! %INTEGER B,C,D,WTRIPNO,JJ,KK,COMM,XTRA,PT,BFFLAG,TRIPINF,TRIPVAL,PTYPE,TYPE,PREC, STPTR,L0,B1,B2,B3,EVALREG,CLNB %OWNINTEGER RESTEMPAD=0; ! REMEMBERS CURRENT RESLN WK AD %OWNRECORD(RD) UOPND; ! TO SAVE SS OPERAND IN ASSEMBLER %LONGINTEGER DESC ! ! TRIPDATA GIVES INFORMATION ON TRIPLE ! TOP 4 BITS HAVE TYPE ! NEXT 12 BITS HAVE FLAGS:- ! 2**16 SET IF COMMUTATIVE ! 2**17 SET DONT LOAD OPERAND2 ! 2**18 SET DONT LOAD OPERAND1 ! 2**19 DONT SWOP NON COMMUTABLE OPERANDS ! NEXT 8 BITS HAVE MAX CODE PLANTED IN BYTES NOT INCLUDING ANY CONSTANSTS ! OR STRINGS WHICH MAY HAVE TO GO INLINE ! BOTTOM 8 BITS HAVE A POINTER OR VALUE ! TYPE 0 TRIPLES ARE IGNORED ! TYPE 1 TRIPLES VALUE HAS INDEX INTO SWITCH "TRIPSW" ! TYPE 2 TRIPLES VALUE HAS POINTER TO ISEQS ! %CONSTINTEGERARRAY TRIPDATA(0:199)=0, X'1000070F'{RTHD ROUTINE/BKK HDR}, X'10000C43'{RDSPLY MAKE DISPLAY}, X'10000410'{RDAREA INITIALISE DIAGS AREA}, X'10000511'{RDPTR RESET DIAGS PTR}, X'10000312'{RTBAD ERROR XIT FOR FN-MAP}, X'10000113'{RTXIT "%RETURN"}, X'10000314'{XSTOP "%STOP"}, 0(2), X'2000040A'{10 LOGICAL NOT}, X'2000040B'{11 LOGICAL NEGATE}, X'2000040C'{12 IFLOAT}, X'2000040D'{13 MODULUS}, X'2000080E'{14 SHORTEN}, X'2000040F'{15 LENGTHEN}, X'20000610'{16 JAM SHORTEN}, X'10000000'{17 ERROR}, 0{18 NULL TRIPLE}, X'20000413'{19 PRELOAD}, X'10000001'{20 UNUSED}, X'10000303'{21 STORE STACKPOINTER}, X'10000002'{22 RESTORE STACK POINTER}, X'10000505'{23 ADVANCE STACK POINTER}, X'10000D04'{24 DECLARE ARRAY}, X'10000301'{25 UPDATE LINE NO}, X'10000906'{26 CHECK ZERO FOR STEP}, X'10000307'{27 FOR PREAMBLE}, X'10000208'{28 FOR POSTAMBLE}, X'1000010E'{29 FOR SECOND PREAMBLE}, X'10000218'{30 PRECALL}, X'10000519'{31 ROUTINE CALL}, X'1000021A'{32 RECOVER FN RESULT}, X'1000021B'{33 RECOVER MAP RESULT}, X'00000000'{34 NOT CURRENTLY USED}, X'1000081D'{35 GETAD GET 32BIT ADDREESS}, X'10000424'{36 RTOI1 INT FN}, X'10000C25'{37 RTOI2 INTPT FN}, X'10000B26'{38 STOI1 TOSTRING FN}, X'1000093D'{39 MNITR FOR %MONITOR}, X'00000000'{40 PPROF PRINT PROFILE IGNORED}, X'1000053F'{41 RTFP TURN RTNAME TO FORMAL}, X'10000849'{42 ON EVENT1 NO CODE AS YET}, X'1000084A'{43 ON EVENT2 NO CODE AS YET}, X'10000846'{44 DVSTART FILL IN ELSIZE&ND}, X'10001047'{45 DVEND WORK OUT TOTSIZE ETC}, X'1000044C'{46 FOREND }, 0(3), X'10000132'{50 UCNOP}, X'10000133'{51 UCB1}, X'10000234'{52 UCB2}, X'10000335'{53 UCB3}, X'10000336'{54 UCW}, X'10000437'{55 UCBW}, 0(3), X'1000063B'{59 UCNAM U-C ACCESS TO NAMES}, 0(68), X'20010414'{128 +}, X'20000415'{129 -}, X'20010416'{130 !!}, X'20010417'{131 !}, X'20010418'{132 *}, X'20000419'{133 //}, X'2000041A'{134 /}, X'2001041B'{135 &}, X'2000041C'{136 >>}, X'2000041D'{137 <<}, X'20000E1E'{138 **}, X'2001041F'{139 COMP}, X'20000420'{140 DCOMP}, X'20060A21'{141 VMY}, X'20010422'{142 COMB}, X'200E0623'{143 ASSIGN=}, X'200E0624'{144 ASSIGN<-}, X'20020E25'{145 ****}, X'20060926'{146 BASE ADJ}, X'200E0527'{147 ARR INDEX}, X'20060428'{148 INDEXED FETCH}, X'200E0629'{149 LOCAL ASSIGN}, X'10000C09'{150 VALIDATE FOR}, X'10001815'{151 PRE CONCAT}, X'10002016'{152 COCNCATENEATION}, X'10000C17'{153 IOCP CALL}, X'10000C1C'{154 PARAMETER ASSIGNMENT 1 NORMAL VALUES}, X'1000041F'{155 PARAM ASSNG 2 NORMAL PTRS}, X'10000220'{156 PARAM ASSGN 3 ARRAYS}, X'10000220'{157 ASSGN FORMAL RT-CODE AS 156}, X'10000220'{158 PASS5 TYPE GENERAL NAME}, X'10000445'{159 PASS STR WORK AREA}, X'1000030A'{160 BACK JUMP}, X'1000030B'{161 FORWARD JUMP}, X'1000000C'{162 REMOVE LAB}, X'1000000D'{163 ENTER LABEL}, X'1000FF21'{164 DECLARE SWITCH}, X'10000022'{165 SET SWITCH LABEL TO CA}, X'10000523'{166 GOTO SWITCH LABEL}, X'10000D27'{167 STRING ASS1 GENERAL}, X'10001128'{168 STRING ASS 2 L KNOWN}, X'10000D29'{169 STRING JAM TRANSFER}, X'10000C2A'{170 ARRAY HEAD ASSIGNMENT}, X'10000C2B'{171 PTR ASSIGNMENT}, X'1000052C'{172 MAP RESULT ASSIGNMENT}, X'1000052D'{173 FN RESULT ASSIGNMENT}, X'10000C2E'{174 STRING COMPARISON}, X'10000C2E'{175 STRING DSIDED COMPARISON}, X'10000C2F'{176 PRE RESOLUTION 1}, X'10001230'{177 PRE RESOLUTION 2}, X'10000B31'{178 RESOLUTION PROPER}, X'1000233C'{179 RESOLUTION FINISH ASSN FRAGMNT}, X'1000084B'{180 SIGEV SIGNAL EVENT NOT IMPLEMENTED}, X'10000A3E'{181 RECASS WHOLE RECORD ASSIGNMENT}, X'10000A40'{182 ARRAY ADDR INC}, X'10000A41'{183 AHADJ FOR ARRAY MAPPING}, X'10000A42'{184 CREATE TYPE GENERAL PARAMETER}, X'1000081E'{185 GET POINTER FOR PASSING BY NAME}, X'10000844'{186 INDEX STRING FOR CHARNO}, X'2002042A'{187 ZCOMP COMPARE W ZERO}, X'2002022B'{188 CONSTANT LOGICAL SHIFT}, X'2002022B'{189 COSNTANT ARITHMETIC SHIFT}, X'10001048'{190 DV BPAIR ENTER LB,UB &RANGE IN CORRECT FORM}, 0(*) %CONSTBYTEINTEGERARRAY FCOMP(0:79)=0(2),2(2),4(2),6(2),8(2),10(2),12(2),14(2), 0(2),4(2),2(2),6(2),8(2),12(2),10(2),14(2), 0(2),21(2),22(2),36(2),20(2),38(2),37(2),15(2), 0(2),22(2),21(2),36(2),20(2),37(2),38(2),15(2), 0(2),5(2),2(2),7(2),8(2),13(2),10(2),15(2); ! ! THE FOLLOWING ARRAY HAS INSTRUCTION SEQUENCES FOR THE VARIOUS IMP ! IMP OPERATION PRECCED BY A SWITH LABEL AT WHICH THEY ARE PLANTED ! TOUGH CASES LIKE ** HAS A UNIQUE ONE-OFF SWITCH. ! LOOK UP THE SWITCH LABEL FOR PARAMETER DECODING IN DIFFICULT CASES ! %CONSTINTEGER NISEQS=34 %CONSTBYTEINTEGERARRAY ISEQS(40:4*(4*NISEQS+10)-1)={FIRST INTEGER FORMS} %C 8,0,0,-ANYGR {10 INTEGER LOGICAL NOT}, 2,LCR,0,-ANYGR {11 INTEGER LOGICAL NEGATE}, 12,0,0,0 {12 INTEGER FLOAT TO REAL}, 2,LPR,0,-ANYGR {13 INTEGER MODULUS}, 9,0,0,0 {14 SHORTEN INTEGER TO 16 BIT}, 10,0,0,0 {15 LENGTHEN INTEGER}, 21,0,0,0 {16 SHORTEN INTEGER FOR JAM}, 1,0,0,109 {17 COMPILER ERROR}, 7,0,0,0 {18 NOOP}, 6,0,0,-ANYGR {19 PRELOAD}, 3,A,AH,0 {20 INTEGER ADDITION}, 3,S,SH,0 {21 INTEGER SUBTRACTION}, 4,X,0,-ANYGR {22 INTEGER NONEQUIVALENCE}, 4,O,0,-ANYGR {23 INTEGER LOGICAL OR}, 11,M,0,-ANYGR {24 INTEGER MULTIPLY}, 11,DR+X'40',0,0 {25 INTEGER INTEGER DIVIDE}, 1,0,0,109 {26 INTEGER REAL DIVIDE}, 4,AND,0,-ANYGR {27 INTEGER AND}, 17,SRL,0,-ANYGR {28 INTEGER RIGHT SHIFT}, 17,SLL,0,-ANYGR {29 INTEGER LEFT SHIFT}, 1,0,0,109 {30 REAL EXP OPERATOR}, 13,ICP,CH,-ANYGR {31 INTEGER COMPARISONS}, 14,ICP,CH,-ANYGR {32 FIRST PART OF DOUBLE COMPARISONS}, 15,0,0,0 {33 VMY}, 4,A,0,-ANYGR {34 COMBINE VMY RESULTS}, 16,0,0,-ANYGR {35 ASSIGN}, 16,0,0,-ANYGR {36 ASSIGN(<-)}, 22,1,0,0 {37 INTEGER EXPONENTIATION}, 18,2,0,0 {38 BASE ADJUST ARRAY INTEGER INDEX}, 19,2,0,0 {39 ARRAY INDEX INTEGER INDEX}, 20,0,0,0 {40 INDEXED FETCH INTEGER INDEX}, 23,0,0,-ANYGR {41 LASS}, 24,LTR,0,-ANY GR {42 ZCOMP COMPARISON WITH ZERO}, 25,0,0,-ANYGR {43 INTEGER SHIFT BY CONSTANT}, 8,0,0,-ANY2SEQ {10 LONG INTEGER LOGICAL NOT}, 29,0,0,-ANY2SEQ {11 LONG INTEGER LOGICAL NEGATE}, 27,0,0,0 {12 LONG INTEGER FLOAT TO REAL}, 30,0,0,-ANY2SEQ {13 LONG INTEGER MODULUS}, 9,0,0,0 {14 SHORTEN LONG INTEGER TO 16 BIT}, 10,0,0,0 {15 LENGTHEN LONG INTEGER}, 21,0,0,0 {16 SHORTEN LONG INTEGER FOR JAM}, 1,0,0,109 {17 COMPILER ERROR}, 7,0,0,0 {18 NOOP}, 6,0,0,-ANYGRPAIR {19 PRELOAD}, 26,AL,A,12 {20 LONG INTEGER ADDITION}, 26,SL,S,3 {21 LONG INTEGER SUBTRACTION}, 26,X,X,0 {22 LONG INTEGER NONEQUIVALENCE}, 26,O,O,0 {23 LONG INTEGER LOGICAL OR}, 28,0,0,17 {24 LONG INTEGER MULTIPLY}, 28,0,0,18 {25 LONG INTEGER LONG INTEGER DIVIDE}, 1,0,0,109 {26 LONG INTEGER REAL DIVIDE}, 26,AND,AND,0 {27 LONG INTEGER AND}, 17,SRDL,0,-ANYGRPAIR {28 LONG INTEGER RIGHT SHIFT}, 17,SLDL,0,-ANYGRPAIR {29 LONG INTEGER LEFT SHIFT}, 1,0,0,109 {30 REAL EXP OPERATOR}, 13,ICP,CL,-ANY2SEQ {31 LONG INTEGER COMPARISONS}, 14,ICP,CL,-ANY2SEQ {32 FIRST PART OF DOUBLE COMPARISONS}, 15,0,0,0 {33 VMY}, 4,A,0,1 {34 COMBINE VMY RESULTS}, 16,0,0,-ANY2SEQ {35 ASSIGN}, 16,0,0,-ANY2SEQ {36 ASSIGN(<-)}, 1,0,0,99 {37 LONG INTEGER EXPONENTIATION}, 1,0,0,109 {38 BASE ADJUST ARRAY LONG INTEGER INDEX}, 1,0,0,109 {39 ARRAY INDEX LONG INTEGER INDEX}, 1,0,0,109 {40 INDEXED FETCH LONG INTEGER INDEX}, 23,0,0,1 {41 LASS}, 24,SLDA,0,-ANYGRPAIR {42 ZCOMP COMPARISON WITH ZERO}, 25,0,0,-ANYGRPAIR {43 LONG INTEGER SHIFT BY CONSTANT}, 7,0,0,0 {10 REAL LOGICAL NOT}, 2,LCDR,LCER,3 {11 REAL LOGICAL NEGATE}, 1,0,0,109 {12 FLOAT REAL COMPILER ERROR}, 2,LPDR,LPER,3 {13 REAL MODULUS}, 9,0,0,0 {14 SHORTEN REAL}, 10,0,0,0 {15 LENGTHEN REAL}, 9,0,0,0 {16 SHORTEN REAL FOR JAM}, 1,0,0,109 {17 COMPILER ERROR}, 7,0,0,0 {18 NOOP}, 6,0,0,-ANYFR {19 PRELOAD}, 4,AD,AE,3 {20 REAL ADDITION}, 4,SD,SE,3 {21 REAL SUBTRACTION}, 7,0,0,0 {22 REAL NONEQUIVALENCE}, 7,0,0,0 {23 REAL LOGICAL OR}, 4,MD,ME,3 {24 REAL MULTIPLY}, 7,0,0,0 {25 REAL INTEGER DIVIDE}, 4,DD,DE,3 {26 REAL REAL DIVIDE}, 7,0,0,0 {27 REAL AND}, 7,0,0,0 {28 REAL LEFT SHIFT}, 7,0,0,0 {29 REAL RIGHT SHIFT}, 22,2,0,0 {30 REAL EXP OPERATOR}, 13,CD,CE,3 {31 REAL COMPARISONS}, 14,CD,CE,3 {32 FIRST PART OF DOUBLE COMPARISONS}, 7,0,0,0 {33 VMY}, 7,0,0,0 {34 COMBINE VMY RESULTS}, 16,0,0,-ANYFR {35 ASSIGN}, 16,0,0,-ANYFR {36 ASSIGN(<-)}, 7,0,0,0 {37 REAL INTEGER EXPONENTIATION}, 1,0,0,109 {38 BASE ADJUST ARRAY REAL INDEX}, 7,0,0,0 {39 ARRAY INDEX REAL INDEX}, 3,0,0,0 {40 INDEXED FETCH REAL}, 23,0,0,3 {41 LASS}, 24,LTDR,LTER,-ANYFR {42 ZCOMP COMPARISONS WITH ZERO}, 7,0,0,0 {43 SHIFT BY CONST -ERROR}, 7,0,0,0 {10 EXTENDED REAL LOGICAL NOT}, 2,LCDR,LCDR,-ANYFRPAIR {11 EXTENDED REAL LOGICAL NEGATE}, 1,0,0,109 {12 FLOAT EXTENDED REAL COMPILER ERROR}, 2,LPDR,LPDR,-ANYFRPAIR {13 EXTENDED REAL MODULUS}, 9,0,0,0 {14 SHORTEN EXTENDED REAL}, 10,0,0,0 {15 LENGTHEN EXTENDED REAL}, 9,0,0,0 {16 SHORTEN EXTENDED REAL FOR JAM}, 1,0,0,109 {17 COMPILER ERROR}, 7,0,0,0 {18 NOOP}, 6,0,0,-ANYFRPAIR {19 PRELOAD}, 31,0,AXR,-ANYFRPAIR {20 EXTENDED REAL ADDITION}, 31,0,SXR,-ANYFRPAIR {21 EXTENDED REAL SUBTRACTION}, 7,0,0,0 {22 EXTENDED REAL NONEQUIVALENCE}, 7,0,0,0 {23 EXTENDED REAL LOGICAL OR}, 31,0,MXR,-ANYFRPAIR {24 EXTENDED REAL MULTIPLY}, 7,0,0,0 {25 EXTENDED REAL INTEGER DIVIDE}, 31,DXR>>8,DXR&255,-ANYFRPAIR {26 EXTENDED REAL EXTENDED REAL DIVIDE}, 7,0,0,0 {27 EXTENDED REAL AND}, 7,0,0,0 {28 EXTENDED REAL LEFT SHIFT}, 7,0,0,0 {29 EXTENDED REAL RIGHT SHIFT}, 22,2,0,0 {30 EXTENDED REAL EXP OPERATOR}, 13,CD,CD,-ANYFRPAIR {31 EXTENDED REAL COMPARISONS}, 14,CD,CD,-ANYFRPAIR {32 FIRST PART OF DOUBLE COMPARISONS}, 7,0,0,0 {33 VMY}, 7,0,0,0 {34 COMBINE VMY RESULTS}, 16,0,0,-ANYFRPAIR {35 ASSIGN}, 16,0,0,-ANYFRPAIR {36 ASSIGN(<-)}, 7,0,0,0 {37 EXTENDED REAL INTEGER EXPONENTIATION}, 1,0,0,109 {38 BASE ADJUST ARRAY EXTENDED REAL INDEX}, 7,0,0,0 {39 ARRAY INDEX EXTENDED REAL INDEX}, 3,0,0,0 {40 INDEXED FETCH EXTENDED REAL}, 23,0,0,-ANYFRPAIR {41 LASS}, 24,LTDR,0,-ANYFRPAIR {42 ZCOMP COMPARISONS WITH ZERO}, 7,0,0,0 {43 SHIFT BY CONST -ERROR} %SWITCH SW(0:35),TRIPSW(0:76) ! CURRINF==WORKA_LEVELINF(CURRLEVEL) CLNB=DISPREG(CURRINF_RBASE) FLAG AND FOLD(TRIPLES) %IF PARM_OPT#0;! ALREADY DONE FOR OPT=0 %IF PARM_DCOMP#0 %THEN PRINT TRIPS(TRIPLES) STPTR=TRIPLES(0)_FLINK %WHILE STPTR>0 %CYCLE %IF PARM_Z#0 %AND PARM_DCOMP#0 %THEN %START %IF PPCURR>0 %THEN %START IBMRECODE(ADDR(CODE(0)),ADDR(CODE(PPCURR)),CABUF) LIPUT(30+1,PPCURR,CABUF,ADDR(CODE(0))) PPCURR=0; CABUF=CA PRINT USE %FINISH PRINT THIS TRIP(TRIPLES,STPTR) %FINISH CURRT==TRIPLES(STPTR) WTRIPNO=STPTR STPTR=CURRT_FLINK COMM=1 OPND1==CURRT_OPND1 OPND2==CURRT_OPND2 XTRA=CURRT_X1 JJ=CURRT_OPERN TRIPINF=TRIPDATA(JJ) C=TRIPINF>>28; ! TRIPLE TYPE TRIPVAL=TRIPINF&255 PTYPE=OPND1_PTYPE&255; TYPE=PTYPE&7 %IF C=0 %THENCONTINUE %IF C=1 %THEN ->TRIPSW(TRIPVAL) COMM=1 %IF TYPE=2 %THEN C=4*(TRIPVAL+2*NISEQS) %C %ELSE C=4*TRIPVAL %IF PTYPE=X'61' %OR PTYPE=X'72' %THEN C=C+4*NISEQS L0=ISEQS(C); B1=ISEQS(C+1) B2=ISEQS(C+2); B3=ISEQS(C+3) %IF TRIPINF&X'10000'#0 %AND OPND2_FLAG=REFTRIP %START WORKT==TRIPLES(OPND2_D) %IF WORKT_OPND1_FLAG=9 %THEN COMM=2 %FINISH %IF COMM=1 %THEN OPNDC==OPND1 %ELSE OPNDC==OPND2 %IF OPNDC_FLAG#9 %AND TRIPINF&X'40000'=0 %START; ! OP1 NOT LOADED LOAD(OPNDC,ANY GR,0) %FINISH %IF JJ>=128 %AND COMM=1 %THEN OPNDNC==OPND2 %ELSE OPNDNC==OPND1 %UNLESS JJ<128 %OR OPNDNC_FLAG=9 %OR TRIPINF&X'20000'#0 %THEN %C LOAD(OPNDNC,ANY GR,0) ->SW(L0) SW(1): ! ERROR CONDITION TRIPSW(0): FAULT(B3,0,0) %UNLESS TYPE=7 TRIPSW(*): PLANT(X'1A01'); ! USEFUL IN DEBUGGING TO HAVE ! ERROR POSITION PINPOINTED ->STRES SW(5): ! PLANT ONE BYTE & SET PTYPE OPND1_PTYPE=B3 SW(2): ! PLANT UNARY OP LOAD(OPND1,-B3,2) %IF PTYPE=X'52' %THEN B1=B2 EVALREG=OPND1_XB PRR(B1,REGCODE(EVALREG),REGCODE(EVALREG)) %IF PTYPE=X'72' %THEN PRR(B2,REGCODE(EVALREG+1),REGCODE(EVALREG+1)) %C %AND FORGET(EVALREG+1) FORGET(EVALREG) ->SUSE ->STRES SW(3): ! INTEGER FORM NO PROBLEMS D=OPNDNC_PTYPE&255 %IF D=X'31' %OR (D=X'41' %AND B2=0) %THEN ->SW(4) LOAD(OPNDC,ANY GR,2); ! FIRST OPERAND TO ANY EVALREG=OPNDC_XB %IF OPNDNC_FLAG<=1 %THEN LOAD(OPNDNC,ANY GR,1) %IF D=X'41' %THEN B1=B2; ! USE HALFWORD VSN OF OP PUT(EVALREG,B1,0,YES,OPNDNC) %IF COMM=2 %THEN OPND1=OPND2; ! TRIPLE RESULT ALWAYS OPND1 SUSE: OPERAND LOADED(OPND1,EVALREG) ->STRES SW(4): ! ANY FORM NO PROBLEMS LOAD(OPNDC,-B3,2); ! TO ANY FR REG EVALREG=OPNDC_XB D=OPNDNC_PTYPE&255 %IF D=X'31' %OR D=X'41' %THEN LOAD(OPNDNC,ANY GR,2) %IF OPNDNC_FLAG<=1 %THEN LOAD(OPNDNC,ANY GR,1) %IF D=X'52' %THEN B1=B2; ! USE SHORT FORM PUT(EVALREG,B1,0,YES,OPNDNC) %IF COMM=2 %THEN OPND1=OPND2 ->SUSE SW(6): ! PRELOAD ! CA OMIT UNLESS RTCALL ETCE INTERVENES %UNLESS CURRT_CNT=1 %AND (CURRT_PUSE=STPTR %OR %C CURRT_PUSE=TRIPLES(STPTR)_FLINK) %THEN LOAD(OPND1,-B3,2) SW(7): ! NULL OPERATION ->STRES SW(8): ! LOGICAL NOT LOAD(OPND1,-B3,2) EVALREG=OPND1_XB DUMPRX(X,EVALREG,0,CODER,WORKA_PLABS(1)+4) FORGET(EVALREG) %IF PTYPE=X'61' %START DUMPRX(X,EVALREG+1,0,CODER,WORKA_PLABS(1)+4) FORGET(EVALREG+1) %FINISH ->SUSE SW(9): ! SHORTEN INTEGER OR REAL PTYPE=CURRT_OPTYPE %IF PTYPE=X'62' %START LOAD(OPND1,ANY FRPAIR,2); ! TO ANY FR PAIR EVALREG=OPND1_XB PRR(LRDR,REGCODE(EVALREG),REGCODE(EVALREG)) FORGET(EVALREG) FREE AND FORGET(EVALREG+1) %FINISH %ELSE %IF PTYPE=X'52' %START LOAD(OPND1,ANY FR,2); ! TO ANY FR EVALREG=OPND1_XB PRR(LRER,REGCODE(EVALREG),REGCODE(EVALREG)) FORGET(EVALREG) %FINISH %ELSE %IF PTYPE=X'51' %START LOAD(OPND1,ANY GRPAIR,2); ! TO ANY GR PAIR EVALREG=OPND1_XB %IF PARM_OPT=0 %START REGS(EVALREG)_CL=0 REGS(EVALREG)_USE=0 EVALREG=EVALREG+1 OPND1_XB=EVALREG %FINISH %ELSE %START PRX(SLDA,EVALREG,0,0,32) FORGET(EVALREG) REGS(EVALREG+1)_CL=0 %FINISH %FINISH %ELSE %IF PTYPE=X'41' %START LOAD(OPND1,ANY GR,2) EVALREG=OPND1_XB %IF PARM_OPT#0 %AND TRIPLES(CURRT_PUSE)_OPERN#SHRTN %THEN %START PRX(SLA,EVALREG,0,0,16) PRX(SRA,EVALREG,0,0,16) FORGET(EVALREG) %FINISH %FINISH %ELSE %IF PTYPE=X'31' %START LOAD(OPND1,ANY GR,2) EVALREG=OPND1_XB %IF PARM_OPT#0 %THEN %START DUMPRX(CL,EVALREG,0,CTABLEREG,WORD CONST(255)) PPJ(2,9,NO) %FINISH %FINISH OPND1_PTYPE=CURRT_OPTYPE ->SUSE SW(10): ! LENGTHEN INTEGER OR REAL %IF TYPE=2 %THEN %START %IF CURRT_OPTYPE=X'62' %START; ! 32 TO 64 BIT LOAD(OPND1,ANY FR,2) EVALREG=OPND1_XB DUMPRX(ME,REGCODE(EVALREG),0,CTABLEREG,WORDCONST(X'41100000')) %FINISH %ELSE %START LOAD PAIR(2,0,OPND1) EVALREG=OPND1_XB DUMPRX(MXD,REGCODE(EVALREG),0,CTABLEREG,LONGCONST(X'4110000000000000')) %FINISH %FINISH %ELSE %START %IF CURRT_OPTYPE=X'61' %THEN %START LOAD PAIR(1,0,OPND1) EVALREG=OPND1_XB DUMPRX(SRDA,EVALREG,0,0,32) %FINISH %ELSE %START LOAD(OPND1,ANY GR,2) EVALREG=OPND1_XB %FINISH %FINISH OPND1_PTYPE=CURRT_OPTYPE REGS(EVALREG)_USE=0 %IF CURRT_OPTYPE=X'61' %OR CURRT_OPTYPE=X'72' %THEN REGS(EVALREG+1)_USE=0 ->SUSE SW(11): ! INTEGER MULT&DIV LOAD PAIR(1,B3,OPND1) LOAD(OPND2,ANY GR,1) EVALREG=OPND1_XB %IF CURRT_OPERN=INTDIV %THEN PRX(SRDA,EVALREG,0,0,32) PUT(EVALREG,B1,0,YES,OPND2) %IF CURRT_OPERN=INTDIV %OR PARM_OPT=0 %THEN %START REGS(EVALREG)_CL=0 EVALREG=EVALREG+1 %ELSE PRX(SLDA,EVALREG,0,0,32);! TEST FOR OVERFLOW REGS(EVALREG+1)_CL=0 %FINISH ->SUSE SW(12): ! FLOAT %BEGIN %INTEGER P1 LOAD(OPND1,ANY GR,2) P1=OPND1_XB DUMPRX(X,P1,0,CODER,WORKA_PLABS(1)+8);! X'80000000' PRX(ST,P1,0,WSPR,4) PSS(MVC,4,WSPR,0,CODER,WORKA_PLABS(1)+24);! X4E000000 EVALREG=FINDREG(FR0,1) DUMPRX(LD,REGCODE(EVALREG),0,CTABLEREG,LONGCONST(X'4E00000080000000')) DUMPRX(AD,REGCODE(EVALREG),0,WSPR,0) REGS(P1)_CL=0 REGS(P1)_USE=0 REGS(EVALREG)_USE=0 OPND1_XB=EVALREG %END OPND1_PTYPE=X'62' ->STRES SW(21): ! SHORTEN INTEGER FOR JAM TRANSFER %IF CURRT_OPTYPE=X'51' %START;! LOMG TO NORMAL LOAD(OPND1,ANY2SEQ,2) EVALREG=OPND1_XB REGS(EVALREG)_CL=0 EVALREG=EVALREG+1 %FINISH %ELSE %START LOAD(OPND1,ANY GR,2) ! NO CODE NEEDED FOR 32BITS & LESS EVALREG=OPND1_XB %FINISH OPND1_PTYPE=CURRT_OPTYPE ->SUSE SW(22): ! EXP IN ANY EXPRSN %IF OPND2_PTYPE&7=1 %THENSTART %IF OPND2_FLAG=SCONST %AND 2<=OPND2_D %THEN %C CONST EXP(OPND1_PTYPE&255,OPND2_D) %ELSE STARSTAR ->SUSE %FINISH ! REAL**REAL BY SUBROUTINE REXP; ->SUSE SW(17): ! INTEGER SHIFT LOAD(OPND1,-B3,2) LOAD(OPND2,ANYGR BAR0,2) EVALREG=OPND1_XB PRX(B1,EVALREG,0,OPND2_XB,0) OPERAND USED(OPND2) REGS(EVALREG)_USE=0 ->SUSE SW(14): ! DSIDED COMPARISONS COMM=2 OPNDC==OPND2; OPNDNC==OPND1 SW(13): ! COMPARISONS BFFLAG=COMM-1; ! NOTE BACKWARDS OR FORWARDS C=FCOMP(XTRA&15+16*BFFLAG) WORKT==TRIPLES(CURRT_FLINK); ! NEXT TRIPLE %IF WORKT_OPERN=FJUMP %OR WORKT_OPERN=BJUMP %THEN %C WORKT_X1=WORKT_X1!!(C!!(XTRA&15));! PASS MASK ON FOR JUMP ! SUITABLY AMENDED FOR BACK COMPARISON %IF TYPE=1 %AND PTYPE>>4<=5 %THEN ->SW(3) %IF TYPE=2%AND PTYPE>>4<=6 %THEN ->SW(4) ! COMPARISON OF MULTIREGISTER ITEMS LOAD(OPNDC,-B3,2) EVALREG=OPNDC_XB PUT(EVALREG,B1,0,NO,OPNDNC) SET LOCAL BASE(C,JJ) PRX(BC,7,C,0,0) D=CA-2 PUT(EVALREG,B2,TYPE,YES,OPNDNC) PLUG(1,D,CA-JJ,2) %IF COMM=2 %THEN OPND1=OPND2 ->SUSE SW(15): ! SPECIAL MH FOR ARRAY ACCESS ! OPND1 IS SUBSCRIPT ! OPND2_D=CURRD<<24!MAXD<<16!DVDISP ! DVDISP=0 UNLESS BOUNDS ARE CONST ! OPND2_XTRA=BS<<16!DP FOR ARRAYHEAD C=OPND2_D>>24; ! CURRENT DIMENSION D=OPND2_D>>16&31; ! TOTAL NO OF DIMENSIONS VMULTIPLY ->STRES SW(18): ! BASE ADJUST ARRAY INDEX ! NOT USED FOR IBM AS HEAD ADJUSTED ->STRES SW(19): ! ARRAY INDEX WORKT==TRIPLES(CURRT_FLINK) %IF CURRT_CNT=1 %AND CURRT_PUSE=CURRT_FLINK %C %AND WORKT_OPERN=IFETCH %START; ! ONLY ARITHMETIC TYPES USED ! IN NEXT TRIPLE TAKE THIS ALT LOAD(OPND2,ANYGR BAR0,2) LOAD(OPND1,ANYGR BAR0,2) REGS(OPND1_XB)_CL=2 REGS(OPND2_XB)_CL=2 %IF WORKT_OPND1_FLAG=REFTRIP %AND WORKT_OPND1_D=WTRIPNO %THEN %C OPND==WORKT_OPND1 %ELSE %IF WORKT_OPND2_FLAG=REFTRIP %AND %C WORKT_OPND2_D=WTRIPNO %THEN OPND==WORKT_OPND2 %ELSE IMPABORT OPND_FLAG=10 OPND_XB=OPND1_XB<<4!OPND2_XB OPND_D=0 %FINISH %ELSE %START LOAD(OPND2,ANYGRBAR0,2) LOAD(OPND1,ANY GR,1) EVALREG=OPND2_XB DUMPRX(A,EVALREG,0,OPND1_XB,OPND1_D) FORGET(EVALREG) OPERAND USED(OPND1) OPERAND LOADED(OPND1,EVALREG) %FINISH ->STRES SW(20): ! INDEXED FETCH LOAD(OPND2,EVALREG,0) LOAD(OPND2,EVALREG,1) OPND1_FLAG=9; OPND1_XB=EVALREG OPND1_D=0 REGS(EVALREG)_LINK=ADDR(OPND1) ->STRES SW(16): ! ASSIGN(=) ! ASSIGN(<-) PT=XTRA&255; ! ORIGINAL PT OF LHS HERE %IF PT=0 %THEN PT=CURRT_OPTYPE TYPE=PT&15 TOPND=OPND1 EVALREG=-1; ! IN CASE SS ASSGNMNT MADE %IF OPND1_FLAG=2 %START; ! OPERAND A NAME TCELL==ASLIST(TAGS(OPND1_D)) %IF SSVARASS(BYTES(PT>>4),DISPREG(TCELL_UIOJ>>4&15), TCELL_SLINK+OPND1_XTRA,OPND2)=NO %THEN %START LOAD(OPND2,-B3,2) EVALREG=OPND2_XB DSTORE(EVALREG,BYTES(PT>>4),TCELL_UIOJ>>4&15,TCELL_SLINK+OPND1_XTRA) %FINISH %FINISHELSESTART; ! OPERAND A POINTER LOAD(OPND2,-B3,2) LOAD(OPND1,ANYGR BAR0,0) EVALREG=OPND2_XB GET OUT OF ACC(EVALREG,BYTES(PT>>4&7),OPND1) OPERAND USED(OPND1) %FINISH %IF TOPND_XTRA<=0 %AND (TOPND_FLAG=DNAME %OR TOPND_FLAG=INDNAME) %C %THEN NOTE ASSMENT(EVALREG,TRIPVAL-33,TOPND_D,PT) OPERAND USED(OPND2) OPND1=OPND2; ! IN CASE RESULT USED AGAIN ->STRES SW(23): ! LOCAL ASSIGNMENT EVALREG=-1 %IF SSVARASS(BYTES(PTYPE>>4&15),CLNB,OPND1_D&X'FFFF', OPND2)=NO %THEN %START LOAD(OPND2,-B3,2) EVALREG=OPND2_XB DSTORE(EVALREG,BYTES(PTYPE>>4&15),OPND1_D>>16,OPND1_D&X'FFFF') %FINISH OPERAND USED(OPND2) OPND1_FLAG=7 ->STRES SW(24): ! COMPARIONS WITH ZERO (OPND2 ZERO) WORKT==TRIPLES(CURRT_FLINK) LOAD(OPND1,-B3,2) EVALREG=OPND1_XB %IF PTYPE=X'52' %THEN B1=B2 %IF PTYPE=X'61' %THEN PRX(B1,EVALREG,0,0,0) %ELSE %C PRR(B1,REGCODE(EVALREG),REGCODE(EVALREG)) OPERAND USED(OPND1) ->STRES SW(25): ! SHIFT BY CONSTANT D=OPND2_D; ! THE CONSTANT %IF CURRT_OPERN=CASHIFT %THEN C=SLA %ELSE %C %IF D>=0 %THEN C=SLL %ELSE C=SRL %IF PTYPE=X'61' %THEN C=C+4; ! TO DOUBLE OPCODES LOAD(OPND1,-B3,2) EVALREG=OPND1_XB %IF PTYPE=X'61' %THEN C=C+4 PRX(C,EVALREG,0,0,IMOD(D)) REGS(EVALREG)_USE=0 ->SUSE SW(26): ! LONG INTEGER OPERATUION ! B3 IS THE MASK FOR CARRY LOAD(OPNDC,ANY2SEQ,2) EVALREG=OPNDC_XB SET LOCAL BASE(C,JJ) %UNLESS B3=0 PUT(EVALREG,B1,1,NO,OPNDNC); ! OPERATE ON L-S HALF %IF B3>0 %START PRX(BC,B3,C,0,CA+8-JJ); ! JUMP ROUND CARR DUMPRX(B2,EVALREG,0,CODER,WORKA_PLABS(1)+12);! CARRY OF 1 %FINISH PUT(EVALREG,B2,0,YES,OPNDNC) %IF COMM=2 %THEN OPND1=OPND2 ->SUSE SW(27): ! FLOAT LONG INTEGER CLAIM ALL4FRS LOAD(OPND1,ANY2SEQ,2) DUMPM(STM,OPND1_XB,OPND1_XB+1,WSPR,8) DUMPRX(LD,4,0,CODER,WORKA_PLABS(1)+64) DUMPRX(STD,4,0,WSPR,0) OPERAND USED(OPND1) PSS(XC,1,WSPR,7,WSPR,8) PRR(SDR,6,6) DUMPRX(LD,0,0,WSPR,0) DUMPRX(LD,2,0,WSPR,8) PRR(SXR,0,4) FREE AND FORGET(18) FREE AND FORGET(19) FORGET(16) FORGET(18) EVALREG=16 OPND1_PTYPE=X'72' ->SUSE SW(28): ! MULT & DIV LONG INTEGERS LOAD(OPNDC,ANY2SEQ,2) DUMPM(STM,OPNDC_XB,OPNDC_XB+1,WSPR,8) OPERAND USED(OPNDC) LOAD(OPNDNC,ANY2SEQ,2) DUMPM(STM,OPNDNC_XB,OPNDNC_XB+1,WSPR,16) OPERAND USED(OPNDNC) PPJ(0,B3,YES) EVALREG=0 REGS(0)_CL=1 REGS(1)_CL=1 ->SUSE SW(29): ! NEGATE LONG INTEGER LOAD(OPND1,ANY2SEQ,2) EVALREG=OPND1_XB LNEGATE(EVALREG) ->SUSE SW(30): ! LONGINTEGR ABS %BEGIN %INTEGER LB,LA,D LOAD(OPND1,ANY2SEQ,2) SET LOCAL BASE(LB,LA) EVALREG=OPND1_XB PRR(LTR,EVALREG,EVALREG) PRX(BC,10,LB,0,0) D=CA-2 LNEGATE(EVALREG) PLUG(1,D,CA-LA,2) %END ->SUSE SW(31): ! BINARY EXTENDED OPERATION LOAD(OPND1,-B3,2) LOAD(OPND2,-B3,2) EVALREG=OPND1_XB IMPABORT %UNLESS OPND1_FLAG=9 %AND OPND2_FLAG=9 %IF B1>0 %THEN PRRX(B1<<8!B2,REGCODE(EVALREG),REGCODE(OPND2_XB)) %C %ELSE PRR(B2,REGCODE(EVALREG),REGCODE(OPND2_XB)) OPERAND USED(OPND2) FORGET(EVALREG) FORGET(EVALREG+1) ->SUSE TRIPSW(1): ! SET LINE NO %BEGIN %INTEGER I,LINE LINE=OPND1_D>>16 %IF PARM_DBUG#0 %START DUMPRX(LA,0,0,0,LINE) PPJ(0,3,YES) %FINISH %ELSE %IF PARM_LINE#0 %AND LINE#OLDLINE %START PSI(MVI,LINE&255,CLNB,3) %IF OLDLINE=0 %OR OLDLINE>>8#LINE>>8 %THEN %C PSI(MVI,LINE>>8,CLNB,2) OLDLINE=LINE %FINISH %IF PARM_PROF#0 %THEN %START DUMPRX(LA,0,0,0,1) I=PROFDATA+4+4*LINE DUMPRX(ADD,0,0,GLA,I) DUMPRX(ST,0,0,GLA,I) REGS(0)_USE=0 %FINISH %END %CONTINUE TRIPSW(2): ! RESTORE STACK POINTER ! USED AT BEGIN BLOCK EXIT ONLY ! OPND1_D HAS SAVE AREA OFFSET D=WSPR DFETCH(D,4,CURRINF_RBASE,OPND1_D) %CONTINUE TRIPSW(3): ! SAVE STACK POINTER ! OPND1 IS TEMPORARY(16 BITS) FOR SAVE DSTORE(WSPR,4,CURRINF_RBASE,OPND1_D) %CONTINUE TRIPSW(70): ! START OF DOPE VECTOR ! OPND1_D=ND<<16!ELSIZE ! OPND1_XTRA=PTYPE<<16!DVDISP D=OPND1_XTRA&X'FFFF' DESC=5<<27!3*(OPND1_D>>16) TOPND_FLAG=SCONST; TOPND_PTYPE=X'51' TOPND_D=OPND1_D>>16 LOAD(TOPND,ANY GR,2) DUMPRX(ST,TOPND_XB,0,CLNB,D) OPERAND USED(TOPND) TOPND_FLAG=SCONST TOPND_D=OPND1_D&X'FFFF' LOAD(TOPND,ANY GR,2) DUMPRX(ST,TOPND_XB,0,CLNB,D+8+C) %FOR C=0,12,12 ! ELSIZE INTO DV AS ITSELF AND ! ALSO AS FIRST STRIDE OPERAND USED(TOPND) %CONTINUE TRIPSW(71): ! END OF DOPE VECTOR ! OPND1_D=DVF<<16!ELSIZE ! OPND1_XTRA=PTYPE ! XTRA=ND<<16!DVDISP PTYPE=OPND1_XTRA; ! DELARED ARRAY PTYPE ! NOW WORK OUT THE BASE OFFSET USING ! MASK OF NONZERO LBS PASSED IN DVF D=XTRA&X'FFFF'; ! DVDISP C=OPND1_D>>16; ! THE MASK CLAIM THIS REG(0); ! SHOULD ALWAYS BE FREE HERE PRR(SLR,0,0); ! AND SET IT TO ZERO %FOR JJ=1,1,XTRA>>16 %CYCLE %IF C&(1<>16&255; ! NO OF DIMENSIONS D=XTRA&X'FFFF'+12*(XTRA>>24); ! TRIPLE POSN B1=X'80000000' %IF OPND1_FLAG=SCONST %THEN B1=OPND1_D;! CONST LB LOAD(OPND1,ANY GR,2); ! LB DUMPRX(ST,OPND1_XB,0,CLNB,D) LOAD(OPND2,ANY GR,2); ! UB DUMPRX(ST,OPND2_XB,0,CLNB,D+4) %IF B1=X'80000000' %THEN %START PRR(SR,OPND2_XB,OPND1_XB) DUMPRX(A,OPND2_XB,0,CODER,WORKA_PLABS(1)+12);! F'1' %FINISH %ELSE INC REG(OPND2_XB,1-B1,YES) DUMPRX(MH,OPND2_XB,0,CLNB,D+10);! MULT BY STRIDE REGS(OPND2_XB)_USE=0 %IF C#XTRA>>24 %THEN D=D+20 %ELSE D=XTRA&X'FFFF'+4;! NEXT MULTIPLIER ! BUT LAST MULTIPLIER = TOTSIZE DUMPRX(ST,OPND2_XB,0,CLNB,D) OPERAND USED(OPND1) OPERAND USED(OPND2) %CONTINUE TRIPSW(4): ! DECLARE ARRAY ! OPND1=CDV<<31!C<<24!D<<16!DVDISP ! OPND1_XTRA HAS NAME %BEGIN %INTEGER DVDISP,B0,D0,ND TCELL==ASLIST(TAGS(OPND1_XTRA)) ND=TCELL_UIOJ&15 %IF ND=2 %THEN D0=32 %ELSE D0=20;! STRIDE OFFSET FROM DV START C=OPND1_D>>24&127 D=OPND1_D>>16&255 %IF C=0 %START; ! DV ADDR AND STRIDE ! SET UP FOR ALL ARRAYS ! ON FIRST DECL DVDISP=OPND1_D&X'FFFF' %IF OPND1_D>0 %START; ! DYNAMIC DOPE VECTOR CLAIM THIS REG(JJ) %FOR JJ=1,1,3 DUMPRX(LA,2,0,CLNB,DVDISP) DUMPRX(LGR,3,0,CLNB,DVDISP+D0) %FINISH %ELSE %START CLAIM THIS REG(JJ) %FOR JJ=0,1,3 B0=0 B0=B0-CTABLE(DVDISP>>2+3*JJ)*CTABLE(DVDISP>>2+3*JJ+2) %C %FOR JJ=1,1,ND %IF B0=0 %THEN PRR(SLR,0,0) %ELSE %C DUMPRX(LGR,0,0,CTABLEREG,WORD CONST(B0)) DUMPRX(LA,2,0,CTABLEREG,DVDISP) DUMPRX(LA,3,0,0,CTABLE((DVDISP+D0)>>2)) %FINISH %FINISH %ELSE PRR(SR,0,1) PRR(AR,0,WSPR) PRR(LR,1,WSPR) DSTORE(0,16,CURRINF_RBASE,TCELL_SLINK);! STORE AWAY HEAD %IF C=D %START; ! LAST IN THIS STMNT FREE AND FORGET(JJ) %FOR JJ=0,1,3 %FINISH %END %CONTINUE TRIPSW(5): ! CLAIM ARRAY SPACE ! OPND1_D=CDV<<31!SNDISP!DVDISP ! OPND1_XTRA HAS THE ARRAY NAME TCELL==ASLIST(TAGS(OPND1_XTRA)) PREC=TCELL_PTYPE>>4&15 D=OPND1_D&X'FFFF' %IF OPND1_D>0 %START; ! DYNAMIC DOPE VECTOR DUMPRX(A,WSPR,0,CLNB,D+4) %IF PREC<6 %AND TCELL_ACC&7#0 %START INC REG(WSPR,7,YES) DUMPRX(N,WSPR,0,CTABLEREG,WORD CONST(-8)) %FINISH %FINISHELSESTART; ! STATIC DOPE VECTORS C=CTABLE(OPND1_D>>16&X'7FFF'+1); ! ARRAYSIZE IN BYTES INC REG(WSPR,(C+7)&(-8),YES) %FINISH %CONTINUE TRIPSW(6): ! CHECK FOR ZERO FOR STEP LOAD(OPND1,ANY GR,2); ! STEP TO EVALREG EVALREG=OPND1_XB PRR(LTR,EVALREG,EVALREG) PPJ(8,11,NO) OPERAND USED(OPND1) %CONTINUE TRIPSW(7): ! FOR PREAMBLE CLAIM THIS REG(1) LOAD(OPND1,1,2); ! FORCE INITIAL TO GR1 FORGET(1) REGS(1)_USE=1; ! FRIG TILL COUNTS WORK %CONTINUE TRIPSW(8): ! FOR POSTAMBLE REGS(1)_CL=0 %CONTINUE TRIPSW(9): ! VALIDATE FOR LOADPAIR(1,0,OPND1); ! OPND1 IS FINAL-INIT LOAD(OPND2,ANY GR,1); ! OPND2 IS STEP EVALREG=OPND1_XB PRX(SRDA,EVALREG,0,0,32) PUT(EVALREG,DR+X'40',0,YES,OPND2) PRR(LTR,EVALREG,EVALREG) PPJ(7,11,NO) REGS(EVALREG)_CL=0 REGS(EVALREG)_USE=0 REGS(EVALREG+1)_CL=0 REGS(EVALREG+1)_USE=0 %CONTINUE TRIPSW(76): ! FOREND GET OPND1 TO RIGHT REG CLAIM THIS REG(1) LOAD(OPND1,1,2) %CONTINUE TRIPSW(10): ! BACK JUMP _X1 HAS TF&MASK ! OPND1_XTRA HAS LABEL CELL LCELL==ASLIST(OPND1_XTRA) C=LCELL_S1&X'FFFFFF'; ! CA OF THE LABEL %IF OPND1_D&X'40000000'#0 %START;! ASSEMBLER JUMP VIA USING C=C-USINGAT FAULT(98,0,0) %UNLESS 0<=C<4096 PRX(XTRA>>8,XTRA>>4&15,XTRA&15,USINGR,C) %FINISH %ELSE %START D=CURRT_X1&X'F'; ! THE MASK DUMPRX(BC,D,0,CODER,C) %FINISH %CONTINUE TRIPSW(11): ! FORWARD JUMP _X1 HAS TF&MASK ! OPND1_XTRA HAS LABEL CELL<<16!JUMP CELL LCELL==ASLIST(OPND1_XTRA&X'FFFF') C=XTRA&15 D=OPND1_D>>24; ! ENTER JUMP FLAGS %IF D&1#0 %OR REACHABLE(OPND1_D&X'FFFF',STPTR)=YES %START SET LOCAL BASE(B,JJ) PRX(BC,C,0,B,0) LCELL_S2=B<<24!JJ LCELL_S1=(CA-4)!X'80000000';! MARK AS SHORT PLANTED %FINISH %ELSE %IF D&X'40'#0 %START;! ASSEMBLER JUMP PRX(XTRA>>8,XTRA>>4&15,XTRA&15,USINGR,0) LCELL_S2=USINGR<<24!USINGAT LCELL_S1=(CA-4)!X'80000000';! MARK AS SHORT PLANTED %FINISH %ELSE %START FIND USE(B,X'51',LABFOURK,OPND1_D&X'FFFF');! IS 4K MULT LOADED %IF B>0 %START PRX(BC,C,B,0,0) LCELL_S2=(B+16)<<24 LCELL_S1=CA-4; ! AFTER ROUNDING FOR ACCENT %FINISH %ELSE %START B=FIND REG(GR1,0); ! REG TO HOLD 4K MULTIPLE PRX(LGR,B,CODER,0,0); ! LOAD OF 4K MULTIPLE PRX(BC,C,B,0,0) LCELL_S2=B<<24 LCELL_S1=CA-8 %FINISH %FINISH %IF D&2#0 %START; ! ENVIRONMENT MANIPULATION LCELL==ASLIST(OPND1_XTRA>>16);! ONTO LABEL CELL %IF D&128#0 %START; ! FIRST JUMP TO THIS LAB C=0; GET ENV(C) %FINISH %ELSE %START C=LCELL_S2>>16 REDUCE ENV(C); ! LATER USE MUST MERGE %FINISH LCELL_S2=C<<16!(LCELL_S2&X'FFFF') %FINISH %CONTINUE TRIPSW(12): ! REMOVE LABEL %BEGIN %INTEGER S1,S2,S3 %INTEGERNAME CELL CELL==CURRINF_LABEL %WHILE CELL>0 %CYCLE %IF ASLIST(CELL)_S3=OPND1_D %THEN POP(CELL,S1,S2,S3) %C %AND %EXIT CELL==ASLIST(CELL)_LINK %REPEAT %END %CONTINUE TRIPSW(13): ! INSERT LABEL ! OPND1_XTRA HAS LABEL CELL OLDLINE=0 LCELL==ASLIST(OPND1_XTRA) JJ=LCELL_S2&X'FFFF'; ! UNFILLED JUMPS LIST %WHILE JJ#0 %CYCLE; ! FILL FORWARD REFS POP(JJ,B1,B2,B3); ! B1<0 IF SHORT JUMP PLANTED ! B2 HAS ENVIRONMENT WHEN IMPLEMENTEED D=CA-B2&X'FFFFFF' B=B2>>24 %IF B1<0 %START; ! SUBSIDARY BASE REG USED %IF D>4095 %THEN FAULT(98,0,0) PLUG(1,B1&X'FFFFFF'+2,B<<12!D,2) %FINISH %ELSE %START %IF B<16 %THEN PLUG(1,B1+2,4*(CA>>12),2) %AND B1=B1+4 PLUG(1,B1+2,CODER<<12!(D&4095),2) %FINISH %REPEAT LCELL_S1=LCELL_S1&X'FF000000'!CA D=OPND1_D>>24; ! ENVIRONMENT MANIPULATION FLAGS %IF D&2=0 %THEN FORGETM(14) %ELSE %START C=LCELL_S2>>16 %IF D&4=0 %THEN REDUCE ENV(C);! MERGE WITH CURRENT RESTORE(C) %FINISH LCELL_S2=0; ! NO JUMPLIST&NO ENVIRONMENT %CONTINUE TRIPSW(14): ! FOR 2ND PREAMBLE ! MAY BE UNNECESSARY %BEGIN %RECORD(TRIPF)%NAME CTRIP,JTRIP,ADDTRIP,ASSTRIP CTRIP==TRIPLES(STPTR); ! NEXT TRIP IC COMPARE JTRIP==TRIPLES(CTRIP_FLINK); ! FOLLOWED BY CONDITIONAL JUMP ADDTRIP==TRIPLES(JTRIP_FLINK); ! AND THEN ADDITION OF INC ASSTRIP==TRIPLES(ADDTRIP_FLINK);! AND ASSIGNMENT %IF XTRA&X'080002'=X'080002' %START;! INCREMENT IS 1 ! CTRIP_X1=CTRIP_X1!X'80000000';! MARK TO USE CPIB ! ASSTRIP_OPND2=ADDTRIP_OPND1 ! ADDTRIP_OPERN=NULLT %FINISH %END %CONTINUE TRIPSW(15): ! RT HEADING OPND1_D=RTNAME %BEGIN %INTEGER W1,W2,W3 ! OPND1_XTRA=AXNAME #0 IF AN ENTRY %IF OPND1_XTRA#0 %START; ! EXTERNAL NEEDS INITIALISE %IF OPND1_D<0 %THEN %START; ! FIRST BEGIN OR MAIN ENTRY C=1; ! FLAG MAIN ENTRY %FINISH %ELSE C=0; ! NOT MAIN ENTRY DEFINEEP(STRING(OPND1_XTRA),1,CA,C) DUMPRX(LGR,CTABLEREG,0,GLA,24) %IF OPND1_D<0 %START; ! MAIN PROG DUMPRX(LGR,1,0,CTABLEREG,WORD CONST(X'08000000')) PRR(SPM,1,0); ! SET PROGRAM MASK %FINISH %FINISH OLDLINE=0 CNOP(0,4) CURRINF_ENTRYAD=CA %IF OPND1_D>=0 %START; ! ROUTINE PLANT INTERNAL ENTRY TCELL==ASLIST(TAGS(OPND1_D)) D=TCELL_SNDISP; ! LIST OF OUTSTANDING JUMPS %WHILE D>0 %CYCLE POP(D,W1,W2,W3); ! W1=INSTRN,W2 =ADDRESS W3=CA>>12 FAULT(98,0,0) %IF W3>MAX4KMULT PLUG(1,W2+2,W3<<2,2) PLUG(1,W2+6,CODER<<12!CA&4095,2) %REPEAT TCELL_SNDISP=(CA>>2) PRX(ST,LINKREG,0,WSPR,60) %FINISH %END %CONTINUE TRIPSW(67): ! RDSPY CREATE DIPLAY OPND1_D=DISPLAY OFFSET FORGETM(14) PRR(LR,CLNB,WSPR) REGS(CLNB)_CL=-1 REGS(CLNB)_USE=NAMEBASE REGS(CLNB)_INF1=CURRINF_RBASE CURRINF_SET=CA; ! REMEMBER ASF %IF PARM_CHK=0 %THEN PRX(LA,WSPR,WSPR,0,0) %ELSE %START PRX(LA,0,0,0,0) DUMPRX(LA,1,0,0,CURRINF_PSIZE) PPJ(0,4,YES) %FINISH %CONTINUE TRIPSW(16): ! RDAREA - INITIALISE DAIGS AREA ! OPND1_D=N FOR DIAGS AREA %CONTINUE TRIPSW(17): ! RDPTR SET DAIGS POINTER ! OPND1_D=LEVEL NOT CURRINF ALWAYS LINF==WORKA_LEVELINF(OPND1_D) PUSH(LINF_RAL,1,CA,0); ! TO OVERWRITE LATER PSI(MVI,0,CLNB,0) PSI(MVI,0,CLNB,1) %CONTINUE TRIPSW(18): ! RTBAD FN-MAP ERROR EXIT WORKT==TRIPLES(CURRT_BLINK); ! PREVIOUS TRIPLE %CONTINUEIF WORKT_OPERN=RTXIT %OR WORKT_OPERN=XSTOP %OR %C (WORKT_OPERN=BJUMP %AND WORKT_X1&15=15) PPJ(15,10,NO) %CONTINUE TRIPSW(19): ! RTXIT - "%RETURN" DUMPM(LM,4,LINKREG,CLNB,16) PRR(BCR,15,LINKREG) %IF OPND1_D#0 %THEN CEND %AND FORGETM(14) %CONTINUE TRIPSW(20): ! XSTOP - "%STOP" CALL STOP %IF OPND1_D#0 %THEN CEND %CONTINUE TRIPSW(61): ! %MONITOR CLAIM THIS REG(0) CLAIM THIS REG(1) PRR(SLR,0,0); PRR(SLR,1,1) REGS(0)_CL=0; REGS(1)_CL=0 PPJ(0,2,YES) %CONTINUE !*********************************************************************** !* SECTION FOR STRING CONCATENATION AND ASSIGNMENT * !*********************************************************************** TRIPSW(21): ! PRECONCAT ! OPND1 IS WORK AREA ! OPND2 HAS FIRST STRING D=OPND1_D&X'FFFF'; ! OFFSET OF WK AREA %IF OPND2_FLAG=LCONST %START LOAD(OPND2,ANY GR,1) DUMPSS(MVC,OPND2_XTRA+1,CLNB,D,OPND2_XB,OPND2_D) %FINISH %ELSE %START LOAD(OPND2,ANY GR,1) EVALREG=ANYGRBAR0 DUMPRXE(IC,EVALREG,0,OPND2_XB,OPND2_D) REGS(EVALREG)_CL=-1 REGS(EVALREG)_USE=LITCONST REGS(EVALREG)_INF1=-1000 EXECUTESS(EVALREG,MVC,CLNB,D,OPND2_XB,OPND2_D) REGS(EVALREG)_CL=0 %FINISH OPERAND USED(OPND2) OPND1_FLAG=7; ! RESULT IS LOCAL %CONTINUE TRIPSW(22): ! CONCATENATE OPND1 WORK AREA ! OPND2 THE NEXT BIT %BEGIN %INTEGER OLENREG,ALENREG,ADDREG OPND1=TRIPLES(OPND1_D)_OPND1 %WHILE OPND1_FLAG=REFTRIP D=OPND1_D&X'FFFF'; ! WOTF AREA OFFSET FROM LNB OLENREG=ANYGRBAR0 DUMPRXE(IC,OLENREG,0,CLNB,D); ! LENGTH OF BIT IN WK AREA REGS(OLENREG)_CL=-1 REGS(OLENREG)_USE=LITCONST REGS(OLENREG)_INF1=-1000 ADDREG=ANYGRBAR0 DUMPRXE(LA,ADDREG,CLNB,OLENREG,0);! PTR T0 STR END REGS(ADDREG)_CL=-1 REGS(ADDREG)_USE=0 %IF OPND2_FLAG=LCONST %START; ! STRING LITERAL BEING ADDED %IF OPND2_XTRA=1 %START DUMPSI(MVI,WORKA_A(OPND2_D+1),ADDREG,D+1) %FINISH %ELSE %START LOAD(OPND2,ANY GR,1) DUMPSS(MVC,OPND2_XTRA,ADDREG,D+1,OPND2_XB,OPND2_D+1) %FINISH DUMPRX(LA,OLENREG,0,OLENREG,OPND2_XTRA) %FINISH %ELSE %START LOAD(OPND2,ANY GR,1) ALENREG=ANYGRBAR0 DUMPRXE(IC,ALENREG,0,OPND2_XB,OPND2_D);! LENGTH OF BIT TO BE ADDED REGS(ALENREG)_CL=-1 REGS(ALENREG)_USE=LITCONST REGS(ALENREG)_INF1=-1000 EXECUTESS(ALENREG,MVC,ADDREG,D+1,OPND2_XB,OPND2_D+1) PRR(AR,OLENREG,ALENREG) REGS(ALENREG)_CL=0 %FINISH DUMPRX(STC,OLENREG,0,CLNB,D); ! STORE NEW LENGTH REGS(OLENREG)_CL=0 REGS(ADDREG)_CL=0 OPERAND USED(OPND2) %END %CONTINUE TRIPSW(39): ! GENERAL STRING ASSIGN ! OPND1 IS A STRING POINTER %BEGIN %INTEGER XREG LOAD(OPND1,ANY 2SEQ,2); ! PTR 2WORDS TO ANY CONSECUTIVE %IF OPND2_FLAG=LCONST %START %IF OPND2_XTRA=0 %START; ! NULL STRING ASSN DUMPSI(MVI,0,OPND1_XB+1,0) %FINISH %ELSE %START LOAD(OPND2,ANY GR,1) DUMPSS(MVC,OPND2_XTRA+1,OPND1_XB+1,0,OPND2_XB,OPND2_D) %IF PARM_OPT#0 %START; ! CHECK LENGTH XREG=SHORT CONST(OPND2_XTRA) PRX(CH,OPND1_XB,0,CTABLEREG,XREG) PPJ(4,9,NO) %FINISH %FINISH %FINISH %ELSE %START LOAD(OPND2,ANYGR BAR0,1); ! LHS TO ANY BAR 0 XREG=ANYGRBAR0 DUMPRXE(IC,XREG,0,OPND2_XB,OPND2_D) REGS(XREG)_CL=-1 REGS(XREG)_USE=LITCONST REGS(XREG)_INF1=-1000 EXECUTESS(XREG,MVC,OPND1_XB+1,0,OPND2_XB,OPND2_D) REGS(XREG)_CL=0 %IF PARM_OPT#0 %START PRR(CR,XREG,OPND1_XB) PPJ(2,9,NO) %FINISH %FINISH OPERAND USED(OPND1) OPERAND USED(OPND2) %END %CONTINUE TRIPSW(40): ! SIMPLE STRING ASSIGN TCELL==ASLIST(TAGS(OPND1_D)) LOAD(OPND1,ANY GR,1); ! LHS SSTRASS(OPND1,OPND2,TCELL_ACC) %CONTINUE TRIPSW(41): ! STRING JT VIA SUBROUTINE %BEGIN %INTEGER LB,LA,XREG LOAD(OPND1,ANY 2SEQ,2); ! PTR 2WORDS TO ANY CONSECUTIVE LOAD(OPND2,ANYGR BAR0,1); ! LHS TO ANY BAR 0 XREG=ANYGRBAR0 DUMPRXE(IC,XREG,0,OPND2_XB,OPND2_D) REGS(XREG)_CL=-1 REGS(XREG)_USE=LITCONST REGS(XREG)_INF1=-1000 PRR(CR,XREG,OPND1_XB); ! COMPARE LEN WITH LMAX SET LOCAL BASE(LB,LA) PRX(BC,4,0,LB,CA-LA+6) PRR(LR,XREG,OPND1_XB) EXECUTESS(XREG,MVC,OPND1_XB+1,0,OPND2_XB,OPND2_D) ! MOVE CHARS PLUS GASH LENGTH BYTE DUMPRX(STC,XREG,0,OPND1_XB+1,0);! OVERWRITE LB WITH CORRECT LB REGS(XREG)_CL=0 OPERAND USED(OPND1) OPERAND USED(OPND2) %END %CONTINUE TRIPSW(46): ! STRING COMPARISONS INCL DSIDED BFFLAG=0 WORKT==TRIPLES(CURRT_FLINK) %IF OPND2_FLAG=LCONST %AND OPND2_XTRA=0 %THEN %C OPND==OPND1 %AND ->NULLSC %IF OPND1_FLAG=LCONST %AND OPND1_XTRA=0 %THEN %C OPND==OPND2 %AND BFFLAG=1 %AND ->NULLSC D=CURRT_X1&15; ! THE "NORMAL" IBM MASK %IF 7<=D<=8 %START; ! = & # ARE EASIER C=-1 %IF OPND1_FLAG=LCONST %THEN C=OPND1_XTRA %IF OPND2_FLAG=LCONST %THEN C=OPND2_XTRA LOAD(OPND1,ANY GR,1) LOAD(OPND2,ANY GR,1) %IF C>0 %THEN %START DUMPSS(CLC,C+1,OPND1_XB,OPND1_D,OPND2_XB,OPND2_D) %FINISH %ELSE %START JJ=ANYGRBAR0 DUMPRXE(IC,JJ,0,OPND1_XB,OPND1_D) REGS(JJ)_CL=1 SET USE(JJ,X'51',LITCONST,-1000) EXECUTESS(JJ,CLC,OPND1_XB,OPND1_D,OPND2_XB,OPND2_D) REGS(JJ)_CL=0 %FINISH OPERAND USED(OPND1) OPERAND USED(OPND2) %CONTINUE %FINISH C=FINDSEQREG(GRPAIR,1) LOAD(OPND1,ANY GR,1) DUMPRX(LA,C,0,OPND1_XB,OPND1_D+1) DUMPRX(IC,C+1,0,OPND1_XB,OPND1_D) OPERAND USED(OPND1) D=FINDSEQREG(GRPAIR,1) LOAD(OPND2,ANY GR,1) DUMPRX(LA,D,0,OPND2_XB,OPND2_D+1) DUMPRX(IC,D+1,0,OPND2_XB,OPND2_D) OPERANDUSED(OPND2) PRR(CLCL,C,D) %FOR JJ=0,1,1 %CYCLE FREE AND FORGET(C+JJ) FREE AND FORGET(D+JJ) %REPEAT %CONTINUE NULLSC: ! TEST FOR A NULL STRING LOAD(OPND,ANY GR,1) D=FCOMP(CURRT_X1&15+16*BFFLAG) DUMPSI(CLI,0,OPND_XB,OPND_D) OPERAND USED(OPND) %IF WORKT_OPERN=FJUMP %OR WORKT_OPERN=BJUMP %START %IF WORKT_X1&X'80'#0 %THEN WORKT_X1=X'80'!(D!!X'F') %C %ELSE WORKT_X1=D %FINISH %ELSE IMPABORT %CONTINUE TRIPSW(47): ! PRE RESOLUTION 1 ! OPND1 IS 4 WORD WK AREA ! OPND2 IS STRING BEING RESLVD D=OPND1_D&X'FFFF' C=FINDSEQREG(GRSEQ,1) LOADAD(OPND2,C) PRR(SLR,C+1,C+1) DUMPM(STM,C,C+1,CLNB,D) FREE AND FORGET(C) FREE AND FORGET(C+1) SET USE(C+1,X'51',LITCONST,0) OPERAND USED(OPND2) %CONTINUE TRIPSW(48): ! PRE RESOLUTION 2 ! OPND1 IS 4 WORD WK AREA ! OPND2 IS POINTER TO STRING TO HOLD ! FRAGMENT OR ZERO(=DISCARD FRGMNT) RESTEMPAD=OPND1_D&X'FFFF' %IF OPND2_FLAG=SCONST %START; ! NO STRING FOR FRAGMENT PMVC(4,CLNB,RESTEMPAD+8,CODER,0) %FINISHELSESTART LOAD(OPND2,ANY GR,1) DUMPRX(STH,OPND2_XB,0,CLNB,RESTEMPAD+6) DUMPRX(ST,OPND2_XB+1,0,CLNB,RESTEMPAD+8) OPERAND USED(OPND2) %FINISH %CONTINUE TRIPSW(49): ! RESOLUTION ! OPND1 IS STRING RES EXPR ! OPND2 IS LABEL NO LOADAD(OPND1,-1) DUMPRX(ST,OPND1_XB,0,CLNB,RESTEMPAD+12) OPERAND USED(OPND1) CLAIM THIS REG(0) DUMPRX(LA,0,0,CLNB,RESTEMPAD) FREE AND FORGET(0) PPJ(0,16,YES) %IF OPND2_D=0 %THEN PPJ(7,12,NO); ! UNCONDITIONAL FAILS %CONTINUE TRIPSW(60): ! RESFN FINAL POST RES ASSIGN ! OPND2 HAS POINTER ! SINCE RESOLVED STRING MAY BE CONST ! CAN NOT USE NORMAL ASSIGN %BEGIN %INTEGER XREG,BREG,LB,LA D=OPND1_D&X'FFFF'; ! TO 4 WORD WK AREA LOAD(OPND2,ANY 2SEQ,2); ! POINTER TO DR XREG=ANYGRBAR0 DUMPRXE(IC,XREG,0,CLNB,D+4); ! ORIGINAL LHS LENGTH REGS(XREG)_CL=1 SET USE(XREG,X'51',LITCONST,-1000) BREG=ANYGRBAR0 DUMPRXE(IC,BREG,0,CLNB,D+5); ! BYTES USED UP REGS(BREG)_CL=1 PRR(SR,XREG,BREG) FORGET(BREG) DUMPRX(A,BREG,0,CLNB,D); ! ADD IN ORIGINAL ADDRESS %IF PARM_OPT#0 %START; ! FORCE IN CAP CHK PRR(CR,OPND2_XB,XREG) PPJ(12,9,NO); ! BLE FAIL %FINISH DUMPRX(STC,XREG,0,OPND2_XB+1,0);! ST LENGTH BYTE SET LOCAL BASE(LB,LA) PRR(LTR,XREG,XREG) PRX(BC,8,0,LB,CA+6-LA) PRR(BCTR,XREG,0) EXECUTESS(XREG,MVC,OPND2_XB+1,1,BREG,1) REGS(XREG)_CL=0 REGS(BREG)_CL=0 OPERAND USED(OPND2) %END %CONTINUE TRIPSW(68): ! INDEX STRING FOR CHARNO ! OPND1 32 BIT ADDRESS OF STR ! OPND2 THE INDEX LOAD(OPND2,-2,2) %UNLESS OPND2_FLAG=SCONST %AND OPND2_D=0 LOAD(OPND1,-2,2) EVALREG=OPND1_XB %IF PARM_OPT#0 %AND OPND2_FLAG#SCONST %START KK=ANYGR DUMPRXE(IC,KK,0,EVALREG,0); ! FETCH CURRENT LENGTH PRR(CLR,OPND2_XB,KK) PPJ(2,9,NO) SET USE(KK,X'51',LITCONST,-1000) %FINISH PRR(AR,EVALREG,OPND2_XB) %AND FORGET(EVALREG) %C %UNLESS OPND2_FLAG=SCONST OPERAND USED(OPND2) OPND1_PTYPE=X'51' ->SUSE !*********************************************************************** !* THIS NEXT SECTION DEALS WITH ROUTINE CALLS AND PARAMETER * !* PASSING. ALSO STORING AND RECOVERY OF FN & MAP RESULTS * !*********************************************************************** TRIPSW(23): ! IOCP CALL D=OPND1_D EVALREG=1 %IF REGS(1)_CL#0 %THEN EVALREG=-1 LOAD(OPND2,EVALREG,2) OPERAND USED(OPND2) CIOCP(D,OPND2_XB); ! ALWAYS CONSTANTS OPND1_FLAG=9; ! FOR WHEN RES NEEDED OPND1_D=0 OPND1_XB=1 %CONTINUE TRIPSW(24): ! PRECALL OPND1 HAS RT NAME ! TCELL==ASLIST(TAGS(OPND1_D)) CALL COMING(8) LAST PAR REG=14; ! LAST PAREMETER REG %CONTINUE TRIPSW(25): ! ROUTINE CALL (AFTER PARAMS) ! OPND1 HAS RT NAME %BEGIN %RECORD(REGF)%NAME REG TCELL==ASLIST(TAGS(OPND1_D)) C=TCELL_UIOJ>>4&15; ! ROUTINE LEVEL NO DUMPM(STM,4,LAST PAR REG,WSPR,16) FORGETM(8) %IF TCELL_UIOJ&15=14 %START; ! EXTERNAL CALL DUMPM(LM,CODER,EPREG,GLA,TCELL_SNDISP) PRR(BALCODE-X'40',LINKREG,EPREG) %FINISHELSEIF TCELL_PTYPE&X'400'#0 %START DUMPRX(LGR,LINKREG,0,DISPREG(C),TCELL_SNDISP) PRX(LM,CODER,LINKREG,LINKREG,0) PRX(LM,5,10,LINKREG,20) PRR(LR,1,EPREG) PRX(LGR,EPREG,0,LINKREG,56) PRR(BALCODE-X'40',LINKREG,1) %FINISHELSE %START JJ=TCELL_SNDISP %IF TCELL_UIOJ&15=15 %START;! NO BODY AS YET PUSH(JJ,BALCODE,CA,0) TCELL_SNDISP=JJ PRX(LGR,LINKREG,CODER,0,0) PRX(BALCODE,LINKREG,LINKREG,0,0) %FINISH %ELSE DUMPRX(BALCODE,LINKREG,0,CODER,(JJ&X'FFFF')<<2) %FINISH %CYCLE C=4,1,CLNB-1 REG==REGS(C) %IF ((1<RES TRIPSW(26): ! RECOVER FN RESULT ! CALLED AFTER RETURN TO CALLER D=RESULT REG(PTYPE) OPERAND LOADED(OPND1,D) %CONTINUE TRIPSW(27): ! RECOVER MAP RESULT ! CALLED AFTER RETURN TO CALLER OPERAND LOADED(OPND1,1) %CONTINUE TRIPSW(28): ! PASS PARAMETER(1)= NORMAL VALUE LCELL==ASLIST(OPND1_XTRA&X'FFFF'); ! PARAM DESCTR CELL D=LCELL_ACC; ! PARAM_ACC %IF OPND1_PTYPE&7=5 %START; ! STRINGS BY VALUE - LABORIOUS TOPND_PTYPE=X'51'; TOPND_FLAG=10 TOPND_XB=WSPR; TOPND_D=LCELL_SNDISP+64 SSTRASS(TOPND,OPND2,D) FPPTR=FPPTR+D %CONTINUE %FINISH %IF OPND1_PTYPE&7=3 %START; ! RECORD BY VALUE C=(D+3)&(-4) %IF OPND2_FLAG=SCONST %THEN D=0 %ELSE D=1 %AND LOAD(OPND2,-2,1) BULKM(D,C,WSPR,LCELL_SNDISP+64,OPND2_XB,0) OPERAND USED(OPND2) %CONTINUE %FINISH D=BYTES(OPND1_PTYPE>>4&15) %IF SSVARASS(D,WSPR,LCELL_SNDISP+64,OPND2)=YES %THEN ->PARDONE %IF OPND1_PTYPE&7=2 %THEN C=-3 %ELSE C=-1 LOAD(OPND2,C,2) EVALREG=OPND2_XB ->PARCHK TRIPSW(29): ! GET 32 BIT ADDRESS LOADAD(OPND1,ANYGRBAR0) EVALREG=OPND1_XB ->SUSE TRIPSW(30): ! GET POINTER FOR %NAME %IF TYPE=5 %THEN EVALREG = ANY2SEQ %ELSE EVALREG=ANYGRBAR0 LOADPTR(OPND1,OPND2,EVALREG) EVALREG=OPND1_XB ->SUSE TRIPSW(31): ! PARAM PASSING (2) NORMAL PTRS LCELL==ASLIST(OPND1_XTRA&X'FFFF') PTYPE=OPND1_PTYPE&255; ! FOR PARAM %IF PTYPE=X'35' %THEN C=ANY2SEQ %AND D=8 %ELSE C=ANYGR %AND D=4 LOAD(OPND2,C,2) EVALREG=OPND2_XB ->PARCHK TRIPSW(32): ! PARAM PASSING(3) ARRAYS ! ALSO (4) PASS RT PARAM SAME CODE LCELL==ASLIST(OPND1_XTRA&X'FFFF') %IF CURRT_OPERN=PASS4 %THEN C=ANYGR %AND D=4 %ELSE %C %IF CURRT_OPERN=PASS5 %THEN C=ANY2SEQ %AND D=8 %ELSE %C D=16 %AND C=ANY4SEQ %IF SSVARASS(D,WSPR,LCELL_SNDISP+64,OPND2)=YES %THEN ->PARDONE LOAD(OPND2,C,2) EVALREG=OPND2_XB PARCHK: ! KEEP AUTO STACKING CORRECT C=LCELL_SNDISP+64 DSTORE(EVALREG,D,-1,C) PARDONE: FPPTR=FPPTR+D OPERAND USED(OPND2) %CONTINUE TRIPSW(69): ! PASS6 PASS WKAREA FOR STR&RECORDS ! NOT USED IN IBMIMP %CONTINUE TRIPSW(63): ! RTFP TURN RTNAME INTO FORMAL TCELL==ASLIST(TAGS(OPND1_D)) EVALREG=ANYGR %IF TCELL_PTYPE&X'400'#0 %START; ! NAM>0 PASS A FORMAL DFETCH(EVALREG,4,TCELL_UIOJ>>4&15,TCELL_SNDISP) %FINISHELSEIF TCELL_UIOJ&15=14 %START; ! EXTERNAL PASSED DUMPRXE(LA,EVALREG,0,GLA,TCELL_SNDISP) %FINISHELSE %START GET WSP (D,4); ! PARAM INTO LOCAL DUMPM(STM,CODER,GLA,CLNB,D) DUMPRX(ST,WSPR,0,CLNB,D+12) EVALREG=FINDREG(GR1,0) REGS(EVALREG)_USE=0 JJ=TCELL_SNDISP %IF TCELL_UIOJ&15=15 %START;! BODY NOT GIVEN PUSH(JJ,LA,CA,0) TCELL_SNDISP=JJ PRX(LGR,EVALREG,CODER,0,0);! FOR 4K MULTIPLE PRX(LA,EVALREG,EVALREG,0,0) %FINISH %ELSE DUMPRX(LA,EVALREG,0,CODER,(JJ&X'FFFF')<<2) DUMPRX(ST,EVALREG,0,CLNB,D+8) DUMPRX(LA,EVALREG,0,CLNB,D) %FINISH OPERAND LOADED(OPND1,EVALREG) %CONTINUE TRIPSW(66): ! TYPE GENERAL PARAMETER ! OPND1 THE ACTUAL ! OPND2 HAS PTYPE&ACC JJ=FINDSEQREG(GRSEQ,1) %IF OPND1_FLAG=DNAME %AND OPND1_PTYPE&15=0 %START TCELL==ASLIST(TAGS(OPND1_D)) DFETCH(JJ,8,TCELL_UIOJ>>4&15,TCELL_SNDISP) %FINISH %ELSE %START LOAD(OPND1,JJ+1,2); ! 32 BIT ADDRESS TYPE=OPND2_D&7; PREC=OPND2_D>>4&7 DUMPRX(LGR,JJ,0,CTABLEREG,WORD CONST(OPND2_D&X'FFFF00FF')) OPND1_PTYPE=X'61' %FINISH OPND1_FLAG=9 OPND1_XB=JJ REGS(JJ)_LINK=ADDR(OPND1) REGS(JJ+1)_LINK=ADDR(OPND1) %CONTINUE !*********************************************************************** !* SECTION TO DEAL WITH SWITCHES INCLUDING ->SW(EXP) * !*********************************************************************** TRIPSW(33): ! DECLARE SWITCH OPND2 HAS BNDS %BEGIN %INTEGER D1,RANGE,LB %INTEGERNAME SSTL TCELL==ASLIST(TAGS(OPND1_D)) SSTL==CAS(4); ! TABLE BOUND FOR SST SSTL=(SSTL+3)&(-4); ! WRD BNDRY LB=OPND2_D RANGE=OPND2_XTRA-LB+1 D1=SSTL-SWITEMSIZE*LB; ! POINTER TO ELEMENT ZERO PGLA(4,4,ADDR(D1)) TCELL_SNDISP=(GLACA-4)>>2; ! REMEMBER POINTER LOCATION RELOCATE(GLACA-4,D1,4); ! RELOCATE SST ADDRESS C=WORKA_PLABS(6); ! DEFAULT ASLIST(TCELL_SLINK)_S1=SSTL LIPUT(44,SWITEMSIZE<<24!RANGE,SSTL,ADDR(C)+4-SWITEMSIZE);! REPEATED INIT OF SST SSTL=SSTL+SWITEMSIZE*RANGE %END %CONTINUE TRIPSW(34): ! SET SWITCH LABEL(OPND2) OLDLINE=0 TCELL==ASLIST(TAGS(OPND1_D)) LCELL==ASLIST(TCELL_SLINK); ! SIDECHAIN HAS TDISP LB&UB C=LCELL_S1+(OPND2_D-LCELL_S2)*SWITEMSIZE; ! LAB POSITION D=CA PLUG(4,C,D,SWITEMSIZE) FORGETM(14) %CONTINUE TRIPSW(35): ! GOTO SW LABEL TCELL==ASLIST(TAGS(OPND1_D)) LCELL==ASLIST(TCELL_SLINK); ! ONTO DISP & BOUNDS LOAD(OPND2,ANYGR BAR0,2) D=OPND2_XB C=TCELL_SNDISP %IF PARM_ARR#0 %START DUMPRX(CH,D,0,CTABLEREG,SHORT CONST(LCELL_S2));! CHK LB PPJ(4,6,NO) DUMPRX(CH,D,0,CTABLEREG,SHORT CONST(LCELL_S3));! CHK UB PPJ(2,6,NO) %FINISH EVALREG=ANYGRBAR0 DUMPRXE(LGR,EVALREG,0,GLA,4*C); ! LOAD SST ENTRY %IF SWITEMSIZE=2 %THEN PRR(AR,D,D) %ELSE PRX(SLL,D,0,0,2) DUMPRX(LGR-32+8*SWITEMSIZE,EVALREG,EVALREG,D,0) DUMPRX(BC,15,CODER,EVALREG,0) REGS(EVALREG)_USE=0 REGS(D)_USE=0 OPERAND USED(OPND2) %CONTINUE TRIPSW(36): ! REAL TO INTEGER AS INT C=BYTES(PTYPE>>4) %IF C<=8 %START; ! REAL AND LONGREAL LOAD(OPND1,ANY FR,2); ! TO ANY FR DUMPRX(AD,REGCODE(OPND1_XB),0,CTABLEREG,LONGCONST(X'4080000000000000')) FORGET(OPND1_XB) %FINISH %ELSE %START; ! LONGLONGREALS LOAD(OPND1,ANYFRPAIR,2) D=OPND1_XB C=CLAIM OTHER FRPAIR(D) DUMPRX(LD,REGCODE(C),0,CTABLEREG,LONGCONST(X'4080000000000000'));! 0.5 PRR(SDR,REGCODE(C+1),REGCODE(C+1)) PRR(AXR,REGCODE(D),REGCODE(C)) FREEANDFORGET(C) FREEAND FORGET(C+1) FORGET(D) FORGET(D+1) %FINISH TRIPSW(37): ! REAL TO INTEGER INTPT(OPND1) %BEGIN %INTEGER WREG,RWREG,LREG,RLREG,LB,LA,TEMP PREC=PTYPE>>4 GETWSP(TEMP,2) %IF PREC<=6 %START; ! REAL AND LONGREAL D=WORKA_PLABS(1) LOAD(OPND1,ANY FR,2); ! TO ANY FR LREG=OPND1_XB; RLREG=REGCODE(LREG) WREG=FINDREG(FR0,1) RWREG=REGCODE(WREG) %IF PARM_OPT#0 %THEN %START PRR(LPDR,RWREG,RLREG) DUMPRX(CD,RWREG,0,CTABLEREG,LONGCONST(X'4880000000000000')) PPJ(10,9,NO); ! THIS FAULT FIXING TO EXACTLY ! X80000000 ! %FINISH PRR(LDR,RWREG,RLREG) DUMPRX(AW,RWREG,0,CODER,D+24);! X'4E00000000000000' SET LOCAL BASE(LB,LA) PRR(LTDR,RLREG,RLREG) PRX(BC,10,0,LB,CA+26-LA) DUMPRX(AD,RWREG,0,CODER,D+16);! AD =D'0' TO RENORMALISE -VE PRR(CDR,RLREG,RWREG); ! CHECK FOR TRUNCATION PRX(BC,4,0,LB,CA+12-LA) DUMPRX(AW,RWREG,0,CODER,D+32);! AW X'4E00000100000000 PRX(BC,15,0,LB,CA+8-LA) DUMPRX(AW,RWREG,0,CODER,D+40);! AW X'4E000000FFFFFFFF DUMPRX(STD,RWREG,0,CLNB,TEMP) FREEAND FORGET(WREG) REGS(LREG)_CL=0; ! UNCHANGED TEMP=TEMP+4; ! RESULT IN LOWER WORD %FINISH %ELSE %START; ! LONGLONG REALS LOAD(OPND1,ANYFRPAIR,2) LREG=OPND1_XB; RLREG=REGCODE(LREG) WREG=CLAIM OTHER FR PAIR(LREG) RWREG=REGCODE(WREG) DUMPRX(LD,RWREG,0,CODER,WORKA_PLABS(1)+48);! 2**63 NORMALISED %IF PARM_OPT#0 %START; ! CHECK RANGE PRR(LPDR,RWREG+2,RLREG) PRR(CDR,RWREG+2,RWREG); ! CHECK MOD(X)<2**63 NB EXCLUDES ! -2**64 WHICH IS VALID PPJ(10,9,NO) %FINISH DUMPRX(LD,RWREG,0,CODER,WORKA_PLABS(1)+56);! X'5188000000000000' PRR(SDR,RWREG+2,RWREG+2); ! CLEAR BOTTOM HALF PRR(AXR,RLREG,RWREG); ! LREG=(X-2**63)+2**64 DUMPRX(STD,RLREG,0,WSPR,16) DUMPRX(STD,RLREG+2,0,WSPR,24);! USE TOP OF STACK AS SPACE DUMPSI(XI,X'08',WSPR,17); ! FLIP SIGN BIT DUMPSS(MVC,2,WSPR,24,WSPR,25);! CLOSE UPPER MANTISSA DUMPSS(MVO,X'99',WSPR,7,WSPR,17) DUMPSS(MVC,8,CLNB,TEMP,WSPR,8);! BTM BYTE TOP OF LOWER WORD FREE AND FORGET(LREG); FREE AND FORGET(LREG+1) FREE AND FORGET(WREG); FREE AND FORGET(WREG+1) %FINISH OPND1_D=CURRINF_RBASE<<16!TEMP OPND1_FLAG=7; ! UNDER LNB OPND1_PTYPE=OPND1_PTYPE-X'11' %END %CONTINUE TRIPSW(38): ! INTEGER TO STRING AS TOSTRING GET WSP(D,1) LOAD(OPND1,ANYGR,2) DUMPRX(STC,OPND1_XB,0,CLNB,D+1) DUMPSI(MVI,1,CLNB,D) OPERAND USED(OPND1) OPND1_FLAG=LOCALIR OPND1_PTYPE=X'35' OPND1_D=CURRINF_RBASE<<16!D %CONTINUE TRIPSW(42): ! ARRAYHEAD ASSIGNMENT OPND2_PTYPE=X'71'; ! SO LOAD LOADS HEAD NOT ELEMNT ! AND DROP THRO TO PTR ASSGN TRIPSW(43): ! POINTER ASSIGNMENT D=BYTES(OPND2_PTYPE>>4&15) %IF D=16 %THEN C=ANY4SEQ %ELSE %IF D=8 %THEN C=ANY2SEQ %ELSE C=ANYGR %IF OPND1_FLAG=DNAME %START; ! LOCAL PTR TCELL==ASLIST(TAGS(OPND1_D)) EVALREG=-1 %IF SSVARASS(D,DISPREG(TCELL_UIOJ>>4&15),TCELL_SLINK+OPND1_XTRA, OPND2)=NO %THEN %START LOAD(OPND2,C,2) EVALREG=OPND2_XB DSTORE(EVALREG,D,TCELL_UIOJ>>4&15,TCELL_SLINK+OPND1_XTRA) %FINISH NOTE ASSMENT(EVALREG,1,OPND1_D,OPND2_PTYPE&X'F0'!1) %FINISH %ELSE %START LOAD(OPND2,C,2) EVALREG=OPND2_XB LOADAD(OPND1,ANYGRBAR0) %IF D=4 %THEN DUMPRX(ST,EVALREG,0,OPND1_XB,0) %ELSE %C DUMPRX(STM,EVALREG,EVALREG+(D-4)>>2,OPND1_XB,0) OPERAND USED(OPND1) %FINISH OPERAND USED(OPND2) %CONTINUE TRIPSW(62): ! RECORD ASSIGNMENT LOAD(OPND1,-2,2) %IF OPND2_FLAG=SCONST %THEN %START BULKM(0,CURRT_X1,OPND1_XB,0,0,OPND2_D) %FINISH %ELSE %START LOAD(OPND2,-2,2) BULKM(1,CURRT_X1,OPND1_XB,0,OPND2_XB,0) OPERAND USED(OPND2) %FINISH OPERAND USED(OPND1) %CONTINUE TRIPSW(64): ! AAINC INCREMENT RECORD RELATIVE ! ARRAY ACCESS BY RECORD BASE(OPND1) ! TO GIVE ABSOLUTE ACCESS. LOAD(OPND1,ANYGRBAR0,2); ! THE RECORD BASE LOAD(OPND2,ANYGR,0); ! THE RELATIVE ACCESS EVALREG=OPND1_XB PUT(EVALREG,A,0,YES,OPND2) OPERAND USED(OPND1) OPND1=OPND2 ->SUSE TRIPSW(65): ! AHADJ ARRAY MAPPING OPND1 1 ! HAS ADJUSTMENT OPND2 THE HEAD ! ARRAY PTYPE<<4!MODE IS IN CURRT_X1 OPND2_PTYPE=X'71' LOAD(OPND2,ANY4SEQ,2); ! HEAD TO 4 GENERAL REGS LOAD(OPND1,ANY GR,1); ! BASE ADDRESS OR ADJMNT EVALREG=OPND2_XB; ! THE LOWEST OF 4 GRS %IF CURRT_X1&1=0 %START; ! ARRAY MAPPING OPND1 IS BASE PRR(SR,EVALREG,EVALREG+1) LOAD(OPND1,EVALREG+1,2) PRR(AR,EVALREG,EVALREG+1) %FINISH %ELSE %START PUT(EVALREG,A,0,NO,OPND1) PUT(EVALREG+1,A,0,YES,OPND1) %FINISH OPERAND USED(OPND1) OPND1_PTYPE=X'71' ->SUSE TRIPSW(73): ! ON EVENT 1 BEFORE THE TRAP ! SAVE PSW ETC DUMPRX(ST,WSPR,0,CLNB,CURRINF_ONINF+12) ! AUXSTACK USED NOTE TOP D=FINDREG(GR0,1) PRRX(IPM,D,0) DUMPRX(ST,D,0,CLNB,CURRINF_ONINF+8) REGS(D)_CL=0 %CONTINUE TRIPSW(74): ! ON EVENT 2 TRAP ENTRYPOINT FORGETM(14) D=CA PGLA(4,4,ADDR(D)) RELOCATE(GLACA-4,D,1); ! GLAWORD TO ON ENTRY ADDRESS CURRINF_ONWORD=CURRINF_ONWORD!(GLACA-4) CLAIM THIS REG(0) CLAIM THIS REG(1) DUMPM(STM,0,1,CLNB,CURRINF_ONINF) DUMPRX(LGR,1,0,CLNB,CURRINF_ONINF+8) PRR(SPM,1,0) DUMPRX(LGR,WSPR,0,CLNB,CURRINF_ONINF+12) REGS(0)_CL=0 REGS(1)_CL=0 %CONTINUE TRIPSW(75): ! SIGEV SIGNAL EVENT&SUBEVENT ! OPND1_D HAS SIGNAL LEVEL ! OPND2(COMPUTED) HAS EVENT ETC CLAIM THIS REG(0) CLAIM THIS REG(1) LOAD(OPND2,1,2) LINF==WORKA_LEVELINF(OPND1_D) %IF LINF##CURRINF %START %IF CURRINF_FLAG<=2 %START PUSH(LINF_RAL,1,CA,0) PSI(MVI,0,CLNB,0) PSI(MVI,0,CLNB,1) %FINISH %ELSE %START DUMPM(LM,4,10,CLNB,16); ! OTHERWISE FRIG DISPLAY %FINISH %FINISH REGS(0)_CL=0 REGS(1)_CL=0 PPJ(0,2,YES); ! MONITOR %CONTINUE !*********************************************************************** !* SECTION FOR GENERATING CODE FOR INLINE ASSEMBLER * !*********************************************************************** TRIPSW(50): ! UC NOOP CNOP(OPND1_D>>8,OPND1_D&255) %CONTINUE TRIPSW(51): ! UCB1 ONE REGISTER ASSEMBLER C=OPND1_D>>16 %IF C=X'FF01' %THEN USINGR=OPND1_D&15 %AND USINGAT=CA %AND %CONTINUE %IF C=X'FF02' %THEN USINGR=12 %AND USINGAT=0 %AND %CONTINUE %IF C=SVC %THEN PRR(SVC,OPND1_D>>4&15,OPND1_D&15) %AND %CONTINUE TRIPSW(52): ! UCB2 TWO REG RR &RRE ASSEMBLER C=OPND1_D>>16; D=OPND1_D&15; ! D IS REG1 %IF TARGET=IBM %AND C=BASR %THEN C=BALR %IF C>255 %THEN PRRX(C,D,OPND1_D>>8&15) %ELSE %C PRR(C,D,OPND1_D>>8&15) FORGETM(14) %CONTINUE TRIPSW(53): ! UCB3 RX ASSEMBLER LOAD(OPND1,ANYGR,1) ! XTRA HAS OPCODE,R1 &INDEX ! OPND HAS DB NOW IN FLAG=10 FORM C=XTRA>>16 %IF TARGET=IBM %AND C=BAS %THEN C=BAL PRX(C,XTRA&15,XTRA>>8&15,OPND1_XB,OPND1_D) FORGETM(14) %CONTINUE TRIPSW(54): ! UCW ASSEMBLER WITH STORE OR SI FORMAT LOAD(OPND1,ANYGR,1) C=XTRA>>16 %IF C>255 %THEN PS(C,OPND1_XB,OPND1_D) %ELSE %C PSI(C,XTRA&255,OPND1_XB,OPND1_D) FORGETM(14) %CONTINUE TRIPSW(55): ! UCBW BYTE&WORD OPERAND ASSEMBLER ! IBM SS &SSE FORMATS C=XTRA>>16 LOAD(UOPND,ANYGR,1) LOAD(OPND1,ANYGR,1) %IF C>255 %THEN PSSE(C,UOPND_XB,UOPND_D,OPND1_XB,OPND1_D) %C %ELSE PSS(C,XTRA&X'1FF',UOPND_XB,UOPND_D,OPND1_XB,OPND1_D) FORGETM(14) %CONTINUE TRIPSW(59): ! UCNAM ACCESS TO NAMES FROM U-C ! IN IBM PASSES IST OPERAND OF 2OPND ! SS INSTRUCTIONS SINCE PORTABLE ASSEMBLER ! ONLY ALLOWS ONE OPERAND FORMATS UOPND=OPND1; ! SAVE IN OWN VARAIBLE %CONTINUE STRES: CURRT_OPTYPE<-OPND1_PTYPE %IF CURRT_CNT>1 %START ! USED MORE THAN ONCE, IN A REG %IF CURRT_OPERN#LASS %START ! AND NOT ALREADY STORED %IF OPND1_FLAG#9 %START D=(CURRT_OPTYPE&7-1)*8+CURRT_OPTYPE>>4&7 LOAD(OPND1,-WHICHREG(D),2) %FINISH EVALREG=OPND1_XB REGS(EVALREG)_CNT=CURRT_CNT %FINISH %ELSE %START ! LASS EVALREG=OPND2_XB! REGS(EVALREG)_CL=0 C=BYTES(CURRT_OPTYPE>>4)<<24!CURRINF_RBASE<<16!OPND1_D SET USE(EVALREG,CURRT_OPTYPE,LOCALTEMP,C) %FINISH %FINISH %IF CURRT_CNT=0 %THEN OPERAND USED(OPND1) %REPEAT %IF PARM_DCOMP#0 %THEN CODEOUT %RETURN %ROUTINE SET LOCAL BASE(%INTEGERNAME LOCAL BASE,LOCAL ADDR) !*********************************************************************** !* FIND OR SET UP A REGISTER FOR BRANCHING A SMALL DISTANCE FORWARD * !*********************************************************************** %INTEGER I,J %RECORD(REGF)%NAME REG LOCAL BASE=CODER; LOCAL ADDR=0 %IF 4095-MARGIN>CA %THEN %RETURN; ! CAN USE MAIN BASE REGISTER(GR12) %CYCLE J=9+16,-1,15 I=J&15 REG==REGS(I) %IF I>0 %AND %C REG_USE=BASEREG %AND 4095-MARGIN>CA-REG_INF1 %START LOCAL ADDR=REG_INF1 LOCAL BASE=I REG_AT=WTRIPNO %RETURN %FINISH %REPEAT LOCAL BASE=FIND REG(GR1,0) PRR(BALCODE-X'40',LOCAL BASE,0) LOCAL ADDR=CA SET USE(LOCAL BASE,X'51',BASEREG,CA) %END; ! OF ROUTINE SET LOCAL BASE %ROUTINE LOAD(%RECORD(RD) %NAME OPND,%INTEGER REG,MODE) !*********************************************************************** !* DEVELOP OPERAND OPND WITH OPTIONAL LOAD TO SPECIFIC REG * !* MODE=0 DEVELOP OPERAND ONLY * !* MODE=1 DEVELOP OPERAND AND DEAL WITH "LA" CONST * !* MODE=2 DEVELOP OPERAND AND LOAD INTO SPECIFIED REG * !*********************************************************************** %INTEGER K,KK,D,PTYPE,PREC,TYPE,USE,INF,X %RECORD(TRIPF) %NAME REFTRIP %RECORD(REGF)%NAME REQREG %RECORD(TAGF) %NAME TCELL %SWITCH SW(0:10) USE=0; INF=0 K=OPND_FLAG X=OPND_XTRA PTYPE=OPND_PTYPE TYPE=PTYPE&15 PREC=PTYPE>>4&15 %IF REG>=0 %THEN REQREG==REGS(REG) %IF K>10 %THEN IMPABORT ->SW(K) SW(0): ! CONSTANT < 16 BITS %IF TYPE=1 %AND PREC<=5 %AND 0<=OPND_D<=4095 %START %RETURN %IF MODE=0; ! LAVE "LA" CONSTS %IF MODE=2 %THEN %START USE=LITCONST; INF=OPND_D %IF REG<0 %THEN %START FIND USE(D,X'51',USE,INF) %IF D>=0 %AND REGS(D)_CL=0 %THEN %C OPERAND LOADED(OPND,D) %AND ->SW(9) REG=FIND REG(NEGREG(REG),0) REQREG==REGS(REG) %FINISH %ELSE %START %IF REQREG_USE=USE %AND REQREG_INF1=INF %THEN ->LDED %FINISH %IF INF=0 %THEN PRR(SLR,REG,REG) %ELSE DUMPRX(X'41',REG,0,0,INF) ->LDED %FINISH %FINISH SW(1): ! LONG CONSTANT %IF TYPE=5 %THEN ->SCONST %IF PREC=7 %THEN KK=ADDR(WORKA_A(OPND_D)) %ELSE KK=ADDR(OPND_D) %IF PREC=4 %THEN KK=KK+2 STORE CONST(D,BYTES(PREC),KK) OPND_FLAG=10; OPND_XB=CTABLEREG OPND_D=D USE=6; INF=D ->OPTLOAD SCONST: ! STRING CONSTANT OPND_DIS AR PTR STORE STRING(D,STRING(ADDR(WORKA_A(OPND_D)))) OPND_FLAG=10 OPND_D=D OPND_XB=CTABLEREG ->OPTLOAD SW(3): ! 128 BIT CONSTANT IMPABORT SW(2): ! NAME (+POSSIBLE OFFSET) TCELL==ASLIST(TAGS(OPND_D)) OPND_FLAG=10 %IF X<=0 %THEN USE=9 %AND INF=OPND_D OPND_XB=DISPREG(TCELL_UIOJ>>4&X'F') OPND_D=TCELL_SLINK+X OPND_XTRA=0 ->OPTLOAD LDED: SET USE(REG,PTYPE,USE,INF) NULLOAD: OPERAND LOADED(OPND,REG) %RETURN SW(4): ! VIA DESC AT OFFSET FROM ! A COMPUTED POINTER REFTRIP==TRIPLES(OPND_D) OPND=REFTRIP_OPND1 LOAD(OPND,ANYGRBAR0,2) D=OPND_XB REGS(D)_CL=2 %IF X<0 %THEN X=0 %IF TYPE=5 %THEN X=X+4 KK=ANYGRBAR0 DUMPRXE(LGR,KK,0,D,X) REGS(D)_CL=0 OPND_PTYPE=PTYPE&255 OPND_FLAG=10; OPND_XB=KK REGS(KK)_CL=2 REGS(KK)_USE=0 OPND_XTRA=0 ->OPTLOAD SW(5): ! INDIRECT VIA DICTIONARY ! ONLY RECORDNAME SCALAR(_XTRA>=0) ! OR POINTER(_XTRA<0) TCELL==ASLIST(TAGS(OPND_D)) D=TCELL_SLINK %IF TYPE=5 %AND X<0 %THEN D=D+4 KK=ANYGRBAR0 DUMPRXE(LGR,KK,0,DISPREG(TCELL_UIOJ>>4&15),D) OPND_XB=KK REGS(KK)_CL=2 REGS(KK)_USE=0 OPND_FLAG=10 %IF X>0 %THEN OPND_D=X %ELSE OPND_D=0 ->OPTLOAD SW(6): ! INDIRECT WITH OFFSET REFTRIP==TRIPLES(OPND_D) OPND=REFTRIP_OPND1 LOAD(OPND,ANYGRBAR0,2) D=OPND_XB REGS(D)_USE=0 OPERAND USED(OPND) REGS(D)_CL=2 %IF REGS(D)_CL=0 %IF X<0 %THEN X=0 OPND_PTYPE=PTYPE&255 OPND_FLAG=10 OPND_XB=D OPND_D=X ->OPTLOAD SW(7): ! I-R IN A STACK FRAME ! %IF MODE=2 %AND REQREG_USE=2 %AND REQREG_INF1=OPND_D %C %THEN ->LDED OPND_FLAG=10 OPND_XB=DISPREG(OPND_D>>16) OPND_D=OPND_D&X'FFFF' ->OPTLOAD SW(8): ! TRIPLE REFTRIP==TRIPLES(OPND_D) OPND=REFTRIP_OPND1 LOAD(OPND,REG,MODE) OPND_PTYPE=PTYPE&255 %RETURN SW(9): ! I-R IN A REGISTER %IF MODE=2 %START %IF REGS(OPND_XB)_CNT<=1 %THEN %START %IF OPND_XB=REG %THEN REQREG_LINK=ADDR(OPND) %AND %RETURN %IF REG<0 %AND ACCEPTABLE REG(NEGREG(REG),OPND_XB)=YES %THEN %C REG=OPND_XB %AND REQREG==REGS(REG) %AND ->NULLOAD %FINISH %IF REG<0 %THEN REG=FINDREG(NEGREG(REG),0) %AND REQREG==REGS(REG) %IF REG<=15 %THEN KK=LR %ELSE KK=LDR PRR(KK,REGCODE(REG),REGCODE(OPND_XB)) COPY USE(REG,OPND_XB) %IF PTYPE=X'61' %OR PTYPE=X'72' %THEN %C PRR(KK,REGCODE(REG+1),REGCODE(OPND_XB+1)) %AND COPY USE(REG+1,OPND_XB+1) OPERAND USED(OPND) ->NULLOAD %FINISH %RETURN OPTLOAD: %IF USE>0 %THEN %START FIND USE(D,OPND_PTYPE&255,USE,INF) %IF D>0 %AND REGS(D)_CL=0 %THEN OPERAND LOADED(OPND,D) %AND ->SW(9) %FINISH SW(10): ! DEVELOPPED BD FORM %IF MODE=2 %THEN %START %IF TYPE=5 %THEN LOADAD(OPND,REG) %AND %RETURN GETINACC(REG,BYTES(PREC),OPND) OPERAND USED(OPND) REQREG==REGS(REG) ->LDED %FINISH %IF TYPE=5 %AND OPND_XB>15 %THEN REDUCE BASE(OPND) %END %ROUTINE LOAD PAIR(%INTEGER TYPE,ODDEVEN,%RECORD(RD)%NAME OPND) !*********************************************************************** !* THIS ROUTINE LOADS OPERAND INTO AN EVEN-ODD PAIR * !* THE PAIR IS CLAIMED AS LATE AS POSSIBLE * !*********************************************************************** %INTEGER PAIR,TOTHER LOAD(OPND,ANY GR,0); ! IN STORE UNLESS RT ETC -> IN STORE %UNLESS OPND_FLAG=9 TOTHER=OPND_XB!!1 -> INSTORE %UNLESS REGS(TOTHER)_CL=0 PAIR=TOTHER&X'FE' %IF ODDEVEN+PAIR=TOTHER %THEN LOAD(OPND,TOTHER,2) REGS(PAIR)_CL=1 REGS(PAIR+1)_CL=1 REGS(PAIR)_USE=0 REGS(PAIR+1)_USE=0 ->FIN INSTORE: PAIR=FINDSEQREG(NEGREG(-4-TYPE),1) LOAD(OPND,PAIR+ODDEVEN,2) FIN: OPND_XB=PAIR; ! ALWAYS LH MEMBER %END %ROUTINE LOADAD(%RECORD(RD) %NAME OPND,%INTEGER REG) !*********************************************************************** !* MUCH AS LOAD BUT PRODUCES THE 32 BIT ADDRESS OF OPERAND * !* IMPABORT ON NON RELEVANT ALTERNATIVES OF OPND * !************************************************************************ %RECORD(TRIPF)%NAME REFTRIP %RECORD(TAGF) %NAME TCELL %INTEGER B,D,TYPE,X %SWITCH SW(0:10) TYPE=OPND_PTYPE&7 X=OPND_XTRA %IF REG<0 %THEN REG=FINDREG(NEGREG(REG),1) ->SW(OPND_FLAG) SW(*): ! INVALID IMPABORT SW(0):SW(1): ! ADDR OF CONSTANTS NEEDED ON IBM LOAD(OPND,ANY GR,1) ->SW10 SW(2): ! DNAME TCELL==ASLIST(TAGS(OPND_D)) DFETCHAD(REG,TCELL_UIOJ>>4&15,TCELL_SLINK+X) LDED: OPND_PTYPE=X'51'; ! 32 BIT ADDRESS IS INTEGER OPERAND LOADED(OPND,REG) REGS(REG)_USE=0 %RETURN SW(4): ! VIA PTR AT OFFSET FROM ! COMPUTED EXPRESSION REFTRIP==TRIPLES(OPND_D) OPND=REFTRIP_OPND1; ! MUST COPY FOR MULTIPLY USED OPNDS LOAD(OPND,ANYGR BAR0,2) D=OPND_XB REGS(D)_CL=2 %IF X<0 %THEN X=0 %IF TYPE=5 %THEN X=X+4; ! TO ADDRESS PART OF STR HEADER DUMPRX(LGR,REG,0,D,X) REGS(D)_CL=0 ->LDED SW(5): ! INDIRECT VIA PTR TCELL==ASLIST(TAGS(OPND_D)) B=TCELL_UIOJ>>4&15 D=TCELL_SLINK %IF TYPE=5 %AND X<0 %THEN D=D+4 DFETCH(REG,4,B,D) INC: %IF X>0 %THEN %START %IF REG>0 %AND X<4095 %THEN %START DUMPRX(LA,REG,0,REG,X) %FINISH %ELSE %START REGS(REG)_CL=1 DUMPRX(AH,REG,0,CTABLEREG,SHORT CONST(X)) %FINISH %FINISH ->LDED SW(6): ! INDIRECT OFFSET REFTRIP==TRIPLES(OPND_D) OPND=REFTRIP_OPND1 LOAD(OPND,REG,2) ->INC SW(7): ! LOCAL-IR IN BASE&OFFSET FORM B=OPND_D>>16 D=OPND_D&X'FFFF' OPND_XTRA=0 DFETCHAD(REG,B,D); ->LDED SW(8): ! A TRIPLE IMPABORT %UNLESS TYPE=5; ! ONLY STRING INTERMEDIATES HAVE ADDRESS REFTRIP==TRIPLES(OPND_D) OPND=REFTRIP_OPND1 LOADAD(OPND,REG) %RETURN SW(10):SW10: ! DEVELOPPED BD FORM DUMPRX(LA,REG,OPND_XB>>4,OPND_XB&15,OPND_D) OPERAND USED(OPND) ->LDED %END %ROUTINE LOADPTR(%RECORD(RD) %NAME OPND,OPND2,%INTEGER REG) !*********************************************************************** !* MUCH AS LOAD BUT PRODUCES THE POINTER TO THE OPERAND * !* IMPABORT ON NON RELEVANT ALTERNATIVES OF OPND * !*********************************************************************** %RECORD(TAGF) %NAME TCELL %RECORD(TRIPF)%NAME REFTRIP %INTEGER K,X,WREG,B %SWITCH SW(0:10) PTYPE=OPND_PTYPE K=OPND_FLAG %IF PTYPE&7#5 %THEN LOADAD(OPND,REG) %AND %RETURN X=OPND_XTRA %IF REG<0 %THEN REG=FINDREG(NEGREG(REG),1) WREG=REG+1 ->SW(K) SW(*): ! INVALID IMPABORT SW(2): ! DNAME TCELL==ASLIST(TAGS(OPND_D)) DFETCHAD(WREG,TCELL_UIOJ>>4&15,TCELL_SLINK+X) STR: ! SET TOP HALF OF STRING DESC ! MESSY FOR STRING ARRAY NAMES ! OPND2_XTRA=BML<<16!DML PTYPE=OPND2_D>>16; ! BACK TO REFFED VARS PTYPE %IF OPND2_XTRA<0 %THEN %START; ! STRING LENGTH KNOWN DUMPRX(LA,REG,0,0,OPND2_XTRA&X'FFFF'+1);! DML IS ACC-1 DOES NOT INCLUDE LENGTHBYTE ->LDED %FINISH %IF PTYPE&X'300'=0 %START; ! STRINGNAMES DML&BML FOR HEAD DFETCH(REG,4,OPND2_XTRA>>16,OPND2_XTRA&X'FFFF') ->LDED %FINISH B=-2 DFETCH(B,4,OPND2_XTRA>>16,OPND2_XTRA&X'FFFF'+8);! DV ADDR TO B REGS(B)_USE=0 DUMPRX(LGR,REG,0,B,8) LDED: OPND_PTYPE=X'61' OPERAND LOADED(OPND,REG) %RETURN SW(4): ! VIA PTR AT OFFSET FROM COMPUTER ADDDRESS REFTRIP==TRIPLES(OPND_D) OPND=REFTRIP_OPND1 LOAD(OPND,ANYGR BAR0,2) B=OPND_XB %IF X<0 %THEN X=0 DUMPM(LM,REG,WREG,B,X) OPERAND USED(OPND) ->LDED SW(5): ! INDIRECT VIA DICT SW(6): ! INDIRECT OFFSET SW(7): ! LOCAL IR (OCCURRS WHEN EXPR PASSED BT REF) SW(10): ! DEVELOPPED BD FORM ! NORMALLY ARRAY ELEMENTS ONLY LOADAD(OPND,WREG) ->STR %END %INTEGERFN SSVARASS(%INTEGER SIZE,BASE,DISP,%RECORD(RD)%NAME RHOPND) !*********************************************************************** !* ATTEMPTS TO ASSIGN BY MVC(ETC) WHERE THIS IS ADVANTAGEOUS * !* SET RESULT=YES IF ASSIGNMENT MADE * !*********************************************************************** %INTEGER I,TYPE,PREC %RESULT=NO %IF CURRT_CNT>0; ! IF REUSED GO VIA REGISTERS %RESULT=NO %IF RHOPND_FLAG=INAREG; ! ALREADY LOADED TYPE=RHOPND_PTYPE&7 PREC=RHOPND_PTYPE>>4&15 %IF TYPE=1 %AND RHOPND_FLAG<=1 %START;! RHS IS A CONSTANT %IF SIZE=1 %AND 0<=RHOPND_D<=255 %START DUMPSI(MVI,RHOPND_D,BASE,DISP) %RESULT=YES %FINISH %RESULT=NO %IF SIZE<=4 %AND 0<=RHOPND_D<=4095;! LA QUICKER IN THESE CASES %FINISH %RESULT=NO %UNLESS SIZE=BYTES(PREC) %IF TYPE=2 %START %IF PREC=7 %THEN I=ANYFRPAIR %ELSE I=ANY FR %FINISH %ELSE %START %IF PREC=6 %THEN I=ANYGRPAIR %ELSE I=ANYGR %FINISH LOAD (RHOPND,I,1) %RESULT=NO %UNLESS RHOPND_FLAG=10 %AND RHOPND_XB<=15 %AND %C RHOPND_D<=4095 PMVC(SIZE,BASE,DISP,RHOPND_XB,RHOPND_D) %RESULT=YES %END %ROUTINE SSTRASS(%RECORD(RD)%NAME LHOPND,RHOPND,%INTEGER ACC) !*********************************************************************** !* DOES SIMPLE STRING ASSIGNMENTS WHEN ACC OF LHS IS KNOWN * !*********************************************************************** %INTEGER C,D D=RHOPND_XTRA; ! RHS LENGTH IF A CONST %IF RHOPND_FLAG=LCONST %AND D0 %THEN FIND USE(I,X'51',DVBASE,ANAME) %IF I>0 %THEN WHICH=I %ELSE WHICH=FINDREG(NEGREG(WHICH),0) %FINISH REG==REGS(WHICH) %UNLESS REG_USE=DVBASE %AND REG_INF1=ANAME>0 %START DFETCH(WHICH,4,DVBD>>16,DVBD&X'FFFF'+8) REG_USE=DVBASE; REG_INF1=ANAME %FINISH REG_CL=2 %RESULT=WHICH %END %ROUTINE VMULTIPLY !*********************************************************************** !* DOES ALL VECTOR MULTIPLIES * !*********************************************************************** %ROUTINESPEC BCHECK(%INTEGER IREG,DVREG,OFFSET) %ROUTINESPEC SCALE(%INTEGER IREG,DACC) %INTEGER DVPOS,DVPTYPE,DVD,DACC,DVREG,IREG,DVNAME DVNAME=XTRA&X'FFFF'; ! ZERO FOR ARRAYS IN RECORDS DVPTYPE=XTRA>>16 DACC=-1; ! EL SIZE NOT KNOWN %IF DVPTYPE&X'C00'=0 %AND DVNAME>0 %THEN DACC=ASLIST(TAGS(DVNAME))_ACC %IF DVPTYPE&7<=2 %THEN DACC=BYTES(DVPTYPE>>4&15) DVPOS=OPND2_D&X'FFFF' DVD=3*C; DVREG=-1 LOAD(OPND1,ANYGR BAR0,2) IREG=OPND1_XB %IF DVPOS>0 %START; ! DV IN CONST AREA DVD=DVD+DVPOS %IF PARM_ARR#0 %THEN BCHECK(IREG,CTABLEREG,4*DVD) DACC=CTABLE(DVD+2) SCALE(IREG,DACC) %FINISH %ELSE %START %IF PARM_ARR#0 %OR DACC<0 %OR C>1 %THEN DVREG=SET DVREG(-2,OPND2_XTRA,DVNAME) %IF PARM_ARR#0 %THEN BCHECK(IREG,DVREG,4*DVD) %IF DACC>0 %AND C=1 %THEN SCALE(IREG,DACC) %ELSE %C DUMPRX(MH,IREG,0,DVREG,4*DVD+10) FORGET(IREG) %IF DVREG>0 %THEN REGS(DVREG)_CL=0 %FINISH %RETURN %ROUTINE SCALE(%INTEGER IREG,DACC) !*********************************************************************** !* SCALE AN INDEXING REG AS EFFICIENTLY AS POSSIBLE * !*********************************************************************** %INTEGER SH,RES %IF DACC<=1 %THEN %RETURN %IF DACC=2 %THEN PRR(AR,IREG,IREG) %AND %RETURN RES=DACC; SH=0 SH=SH+1 %AND RES=RES>>1 %WHILE RES&1=0 %IF RES=1 %THEN PRX(SLL,IREG,0,0,SH) %C %ELSE DUMPRX(MH,IREG,0,CTABLEREG,SHORT CONST(DACC)) %END %ROUTINE BCHECK(%INTEGER IREG,DVREG,OFFSET) !*********************************************************************** !* PLANTS AN IN LINE BOUND CHECK * !*********************************************************************** DUMPRX(ICP,IREG,0,DVREG,OFFSET) PPJ(4,13,NO) DUMPRX(ICP,IREG,0,DVREG,OFFSET+4) PPJ(2,13,NO) %END %END %ROUTINE LNEGATE(%INTEGER REG) !*********************************************************************** !* NEGATES THE LONG INTEGER IN REGS REG®+1 BY SUBTRACTING * !* IT FROM ZERO WITH SOFTWARE CARRY * !*********************************************************************** %INTEGER LB,LA,WORK WORK=FIND REG(GR0,1) PRR(SLR,WORK,WORK) FORGET(WORK) SET LOCAL BASE(LB,LA) PRR(SLR,WORK,REG+1) PRX(BC,3,0,LB,CA+8-LA) PRX(A,REG,0,CODER,WORKA_PLABS(1)+12);! =F'1' PRR(LCR,REG,REG) PRR(LR,REG+1,WORK) FORGET(REG); FORGET(REG+1) FREE AND FORGET(WORK) %END %ROUTINE STARSTAR !*********************************************************************** !* PLANT IN-LINE CODE FOR EXPONENTIATION * !* THERE IS NO EXPONENT RABGE CHECKING ON IBMIMP80 * !*********************************************************************** %INTEGER TYPEP,PRECP,WORK,C,INTREG,COUNT,RREG,LB,LLA,OP,P1,P2,WMASK,LVAL,OPCODE,TM PTYPE=OPND1_PTYPE&255 TYPEP=PTYPE&7; PRECP=PTYPE>>4&15 TM=WORDCONST(X'9100C00F'+WORKA_PLABS(1));! TEST UNDER MASK OF 1 %IF TYPEP=1 %START WORK=FINDSEQREG(GRPAIR,1) LOADPAIR(1,1,OPND1) LOAD(OPND2,ANY GR,2) RREG=OPND1_XB COUNT=OPND2_XB PRX(LA,WORK+1,0,0,1) SET LOCAL BASE(LB,LLA) PRR(LTR,COUNT,COUNT) PPJ(4,7,NO); ! NEGATIVE INTEGER EXPONOENTS NONSENSE C=CA DUMPRX(EX,COUNT,0,CTABLEREG,TM) PRX(BC,8,LB,0,0) P1=CA-2 PRR(MR,WORK,RREG+1) %IF PARM_OPT#0 %THEN %START PRX(SLDA,WORK,0,0,32) PRR(LR,WORK+1,WORK) %FINISH PLUG(1,P1,CA-LLA,2); ! LABEL AFTER PRODUCT PRX(SRA,COUNT,0,0,1) PRX(BC,8,LB,0,0) P2=CA-2 PRR(MR,RREG,RREG+1) %IF PARM_OPT#0 %THEN %START PRX(SLDA,RREG,0,0,32) PRR(LR,RREG+1,RREG) %FINISH PRX(BC,15,0,LB,C-LLA) FREE AND FORGET(RREG+1) EVALREG=WORK+1 FREE AND FORGET(WORK) %FINISH %ELSE %START %IF PRECP=5 %THEN OPCODE=MER %AND WMASK=FR0 %AND LVAL=-3 %IF PRECP=6 %THEN OPCODE=MDR %AND WMASK=FR0 %AND LVAL=-3 %IF PRECP=7 %THEN OPCODE=MXR %AND WMASK=FRPAIR %AND LVAL=-6 ! ! NOW REGISTERS CAN BE OBTAINED FOR THE IN-LINE SUBROUTINE ! WORK HOLDS INITIALLY 1 PRIOR TO MULTIPLICATION ! INTREG HOLDS THE EXPONENT AS CALCULATED ! COUNT HOLDS A +VE VERSION OF INTREG FOR COUNTING THE MULTIPLIES ! RREG HOLD THE OPERAND. ! WORK=FINDREG(WMASK,1) LOAD(OPND1,LVAL,2); ! OPERAND TO ANY SUITABLE LOAD(OPND2,ANY GR,2); ! EXPONENT TO ANY GENERAL REG RREG=OPND1_XB INTREG=OPND2_XB ! ! GET '1' INTO WORK IN APPROPIATE FORM ! DUMPRX(LDCODE(8+PRECP),REGCODE(WORK),0,CTABLEREG,LONGCONST(X'4110000000000000')) %IF PRECP=7 %THEN PRR(SDR,REGCODE(WORK+1),REGCODE(WORK+1)) ! ! ALLOW FOR ZERO :- XX**0=1 FOR ALL XX ! ALSO ALLOW FOR X**(-N) WHICH IS 1/(X**N) FOR ALL X & N ! COUNT=FINDREG(GR0,1) PRR(LPR,COUNT,INTREG) SET LOCAL BASE(LB,LLA) C=CA DUMPRX(EX,COUNT,0,CTABLEREG,TM) PRX(BC,8,LB,0,CA+6-LLA); ! J(BOTTOM BIT=0) ROUND NEXT INSTRN PRR(OPCODE,REGCODE(WORK),REGCODE(RREG)) PRX(SRA,COUNT,0,0,1); ! SHIFT OFF BOTTOM BIT PRX(BC,8,0,LB,CA+10-LLA); ! EXIT IF ALL ZERO PRR(OPCODE,REGCODE(RREG),REGCODE(RREG));! SQUARE OPERAND PRX(BC,15,0,LB,C-LLA) ! ! FOR REAL EXPONENTS CHECK IF NEGATIVE AND EVALUATE INVERSE ! PRR(LTR,INTREG,INTREG) PRX(BC,2,LB,0,0); ! BP END OF EXP ROUTINE P2=CA-2 DUMPRX(LDCODE(8+PRECP),REGCODE(RREG),0,CTABLEREG,LONGCONST(X'4110000000000000')) %IF PRECP#7 %THEN %START PRR(DDR-MDR+OPCODE,REGCODE(RREG),REGCODE(WORK)) %FINISH %ELSE %START PRR(SDR,REGCODE(RREG+1),REGCODE(RREG+1));! CLEAR BTM 64 BITS PRRX(DXR,REGCODE(RREG),REGCODE(WORK)) PRR(LDR,REGCODE(WORK+1),REGCODE(RREG+1)) %FINISH PRR(LDR-MDR+OPCODE,REGCODE(WORK),REGCODE(RREG)) FREE AND FORGET(INTREG) EVALREG=WORK %FINISH PLUG(1,P2,CA-LLA,2) ! ! ALL OVER. REAL RESULTS ARE IN FR WORK. INT RESULTS IN GR WORK+1 ! FREE AND FORGET ANY OTHER REGISTERS ! OPERAND USED(OPND1) FREE AND FORGET(COUNT) %END %ROUTINE REXP !*********************************************************************** !* CALLS A PERM ROUTINE TO PERFORM REAL**REAL * !*********************************************************************** IMPABORT %END %ROUTINE CONST EXP(%INTEGER PTYPE,VALUE) !*********************************************************************** !* EXPONENTIATION TO A KNOWN POWER * !* VALUE = 2 UPWARDS. VALUE=1 HAS BEEN OPTIMISED OUT * !*********************************************************************** %INTEGER I,MULTS,MULT,DEST,REG,J,PREC,SIZE DEST=(FPPTR+7)&(-8) MULTS=0; I=VALUE %IF PTYPE&7=1 %START LOADPAIR(1,1,OPND1) EVALREG=OPND1_XB+1 %WHILE I>1 %CYCLE %IF I&1#0 %START DUMPRX(ST,EVALREG,0,WSPR,DEST) DEST=DEST+4 MULTS=MULTS+1 %FINISH PRR(MR,EVALREG-1,EVALREG) %IF PARM_OPT#0 %THEN PRX(SLDA,EVALREG-1,0,0,32) %C %AND PRR(LR,EVALREG,EVALREG-1) I=I>>1 %REPEAT %WHILE MULTS>0 %CYCLE MULT=MULTS-1 DEST=DEST-4 DUMPRX(M,EVALREG-1,0,WSPR,DEST) %IF PARM_OPT#0 %THEN PRX(SLDA,EVALREG-1,0,0,32) %C %AND PRR(LR,EVALREG,EVALREG-1) %REPEAT REGS(EVALREG-1)_CL=0 REGS(EVALREG-1)_USE=0 %RETURN %FINISH PREC=PTYPE>>4&7 SIZE=BYTES(PREC) J=-3; ! ANF FR %IF PREC=7 %THEN J=-6 %AND MULT=MXR %ELSE %C %IF PREC=6 %THEN MULT=MDR %ELSE MULT=MER LOAD(OPND1,J,2) EVALREG=OPND1_XB %WHILE I>1 %CYCLE %IF I&1#0 %START DSTORE(EVALREG,SIZE,-1,DEST) DEST=DEST+SIZE MULTS=MULTS+1 %FINISH PRR(MULT,REGCODE(EVALREG),REGCODE(EVALREG)) I=I>>1 %REPEAT %IF MULTS=0 %THEN %RETURN; ! **2,**4 ETC %IF PREC=7 %START REG=CLAIM OTHERFRPAIR(EVALREG) FREE AND FORGET(REG) FREE AND FORGET(REG+1) %FINISH %WHILE MULTS>0 %CYCLE DEST=DEST-SIZE %IF PREC<=6 %THEN %START DUMPRX(MULT+X'40',REGCODE(EVALREG),0,WSPR,DEST) %FINISH %ELSE %START DFETCH(REG,16,-1,DEST) PRR(MXR,REGCODE(EVALREG),REGCODE(REG)) %FINISH MULTS=MULTS-1 %REPEAT %END %INTEGERFN FINDREG(%INTEGER MASK,CLVAL) !*********************************************************************** !* FINDS A FREE REGISTER FROM RANGE DEFINED BY MASK * !*********************************************************************** %INTEGER I,L,U,USED,LASTUSED,LASTREG,STEP %RECORD(REGF)%NAME REG %IF MASK&X'0F000000'#0 %THEN %RESULT=FINDSEQREG(MASK,CLVAL) L=MASK>>16&255 U=MASK&255 %IF L<=U %THEN STEP=1 %ELSE STEP=-1 %FOR I=L,STEP,U %CYCLE REG==REGS(I) ->FOUND %IF REG_CL=0 %AND REG_USE=0 %REPEAT ! ! IN NEXT CYCLE LOOK FOR TEMPORAY THAT WILL NOT BE USED FOR THE ! LARGEST FUTURE TIME MEASURED BY NO OF TRIPLES ! NB NOT 100% PERFECT AS SHUFFLES CAN OCCUR IN OPTIMISING) ! LASTUSED=-1 LASTREG=-1 %FOR I=L,STEP,U %CYCLE REG==REGS(I) ->FOUND %IF REG_CL=0 %IF REG_AT#WTRIPNO %START; ! NOT USED IN THIS OPERATION USED=TRIPLES(REG_AT)_PUSE %IF USED >LASTUSED %AND (REG_CL=1 %OR REG_CL=3) %THEN %C LASTUSED=USED %AND LASTREG=I %FINISH %REPEAT %IF LASTREG>0 %THEN %START BOOT OUT(LASTREG) I=LASTREG REG==REGS(I) ->FOUND %FINISH IMPABORT FOUND: ! REG HAS BEEN FOUND %IF CLVAL#0 %THEN REG_CL=CLVAL %AND REG_CNT=1 %AND REG_USE=0 %RESULT=I %END %INTEGERFN FINDSEQREG(%INTEGER MASK,CLVAL) !*********************************************************************** !* FINDS A FREE REGISTER PAIR FROM RANGE DEFINED BY MASK * !* PAIRS ARE EVEN-ODD UNLESS TOP BIT OF MASK SET * !*********************************************************************** %INTEGER I,J,L,U,USED,LASTUSED,LASTREG,STEP,MISS,NREGS %RECORD(REGF)%NAME REG L=MASK>>16&255 U=MASK&255 NREGS=MASK>>24&7 %IF L<=U %THEN STEP=1 %ELSE STEP=-1 %IF MASK>0 %THEN STEP=2*STEP %FOR I=L,STEP,U %CYCLE MISS=0 %FOR J=0,1,NREGS %CYCLE REG==REGS(I+J) MISS=1 %UNLESS REG_CL=0 %AND REG_USE=0 %REPEAT ->FOUND %IF MISS=0 %REPEAT ! ! IN NEXT CYCLE LOOK FOR TEMPORAY THAT WILL NOT BE USED FOR THE ! LARGEST FUTURE TIME MEASURED BY NO OF TRIPLES ! NB NOT 100% PERFECT AS SHUFFLES CAN OCCUR IN OPTIMISING) ! AGN: LASTUSED=-1 LASTREG=-1 %FOR I=L,STEP,U %CYCLE MISS=0 %FOR J=0,1,NREGS %CYCLE REG==REGS(I+J) MISS=1 %AND %EXIT %IF REG_CL#0 %REPEAT ->FOUND %IF MISS=0 %IF REG_AT#WTRIPNO %START; ! NOT USED IN THIS OPERATION USED=TRIPLES(REG_AT)_PUSE %IF USED >LASTUSED %AND (REG_CL=1 %OR REG_CL=3) %THEN %C LASTUSED=USED %AND LASTREG=I+J %FINISH %REPEAT %IF LASTREG>0 %THEN BOOT OUT(LASTREG) %AND ->AGN IMPABORT FOUND: ! REG HAS BEEN FOUND %IF CLVAL#0 %THEN %START %FOR J=0,1,NREGS %CYCLE REG==REGS(I+J) REG_CL=CLVAL REG_CNT=1 REG_USE=0 %REPEAT %FINISH REGS(I+J)_AT=WTRIPNO %FOR J=0,1,NREGS %RESULT=I %END %INTEGERFN ACCEPTABLE REG(%INTEGER MASK,REG) !*********************************************************************** !* CHECKS IF REG IN WHICH A RESULT HAPPENS TO BE SATISFIES * !* THE REGISTER CONSTRAINTS OF MASK * !*********************************************************************** %INTEGER L,U,STEP,I L=MASK>>16&255 U=MASK&255 %IF U>=L %THEN STEP=1 %ELSE STEP=-1 %FOR I=L,STEP,U %CYCLE %RESULT=YES %IF I=REG %REPEAT %RESULT=NO %END %ROUTINE FORGETM(%INTEGER UPPER) !*********************************************************************** !* FORGETS A BLOCK OF REGISTERS DEFINED BY UPPER AND THE * !* GLOBAL ARRAY GRMAP * !* UPPER= 3 FOR GRS 0-3 * !* UPPER= 4 FOR GRS 0-3 AND 15 * !* UPPER= 8 FOR GRS 0-3 AND 15 PLUS ALL FRS * !* UPPER=14 FOR GRS 0-9,15 AND ALL FRS * !*********************************************************************** %INTEGER I,REG %CYCLE I=0,1,UPPER REG=GRMAP(I) %IF REGS(REG)_CL=0 %THEN REGS(REG)_USE=0 %REPEAT %END %ROUTINE SAVE IRS(%INTEGER UPPER) !*********************************************************************** !* INSPECTS THE REGISTERS DEFINED BY UPPER AND THE GLOBAL * !* ARRAY 'GRMAP'. ANY INTERMEDIATE RESULTS IN THESE REGISTERS * !* ARE TRANSFERED TO CORE BY 'BOOT OUT' * !* UPPER=4 FOR GRS 1-3 & 15 (CORRUPTED BY PERM) * !* UPPER=8 FOR GRS 1-3 & 15 +FRS 0-6 (CORRUPTED BY FN CALL) * !*********************************************************************** %INTEGER I,REG %CYCLE I=0,1,UPPER REG=GRMAP(I) BOOT OUT(REG) %IF REGS(REG)_CL>=1 %REPEAT %END %ROUTINE CLAIM THIS REG(%INTEGER REG) !*********************************************************************** !* CLAIMS THE REGISTER AND PRESERVES CONTENTS IF * !* THE REGISTER IS ALREADY CLAIMED * !*********************************************************************** BOOT OUT(REG) %IF REGS(REG)_CL>0 %IF REGS(REG)_CL#0 %THEN IMPABORT REGS(REG)_CL=1 %END %ROUTINE CLAIM ALL4FRS %INTEGER I CLAIM THIS REG(I) %FOR I=16,1,19 %END %INTEGERFN CLAIM OTHER FRPAIR(%INTEGER PAIR0) !*********************************************************************** !* FOR EXTENDED OPS THAT NEED BOTH FR PAIRS. SPECIAL ROUTINES IN * !* CASE SPECIAL MEASURES ARE NEEDED * !*********************************************************************** %INTEGER PAIR1 IMPABORT %UNLESS PAIR0=16 %OR PAIR0=18 PAIR1=PAIR0!!2 CLAIM THIS REG(PAIR1) CLAIM THIS REG(PAIR1+1) %RESULT=PAIR1 %END %ROUTINE FORGET(%INTEGER REGNO) !*********************************************************************** !* CLEARS THE USE OF ANY REGISTER. ALL CHANNELED THRO ONE RT * !* IN CASE NEED ANY DROP CALL TO PUT ETC * !*********************************************************************** %RECORD(REGF)%NAME REG REG==REGS(REGNO) REG_USE=0 REG_CNT=0 REG_LINK=0 %END %ROUTINE FREE AND FORGET(%INTEGER REGNO) !*********************************************************************** !* AS FORGET BUT CLEARS CCLAIM FLAG ALSO * !*********************************************************************** REGS(REGNO)_CL=0 FORGET(REGNO) %END %ROUTINE SET USE(%INTEGER REG,PTYPE,U,I) !*********************************************************************** !* NOTE THAT THE USE OF REGISTER 'R' IS NOW 'U' & 'I' * !* WORKS FOR MULTI REGISTER ITEMS * !*********************************************************************** %INTEGER XREGS %RECORD(REGF)%NAME UREG XREGS=REGWORDS(PTYPE&127)>>4-1 %FOR REG=REG,1,REG+XREGS %CYCLE UREG==REGS(REG) %IF UREG_CL>=0 %THEN %START %IF UREG_USE>0 %THEN FORGET(REG) UREG_USE=U UREG_INF1=I UREG_AT=WTRIPNO %FINISH %REPEAT %END %ROUTINE COPY USE(%INTEGER TO,FROM) !*********************************************************************** !* TRANSFER USE INFO FROM 1 REG TO ANOTHER * !*********************************************************************** %RECORD(REGF)%NAME RTO,RFROM RTO==REGS(TO) RFROM==REGS(FROM) RTO_USE=RFROM_USE RTO_INF1=RFROM_INF1 RTO_INF2=RFROM_INF2 RTO_AT=WTRIPNO %END %ROUTINE FIND USE(%INTEGERNAME REG, %INTEGER PTYPE, USE, INF) !*********************************************************************** !* SEARCHES FOR A REGISTER WITH THE REQUIRED CONTENTS * !*********************************************************************** %INTEGER I, L, U, J, NREGS %RECORD(REGF)%NAME TREG %CONSTBYTEINTEGERARRAY FMAP(1:15)=1,2,3,4,5,6,7,8,9,15,0,16,17,18,19; %IF PTYPE&7=2 %THEN L=12 %AND U=15 %ELSE L=1 %AND U=11 NREGS=REGWORDS(PTYPE&127)>>4; ! NO OF GRS(FRS) %CYCLE J=L,1,U+1-NREGS I=FMAP(J) TREG==REGS(I) %IF TREG_PRIMUSE=USE %AND (TREG_INF1=INF %OR INF=-1) %C %AND (NREGS=1 %OR(REGS(I+1)_PRIMUSE=USE %AND %C (REGS(I+1)_INF1=INF %OR INF=-1))) %THEN ->HIT %IF TREG_SECUSE=USE %AND(TREG_INF2=INF %OR INF=-1) %C %AND (NREGS=1 %OR(REGS(I+1)_SECUSE=USE %AND %C (REGS(I+1)_INF2=INF %OR INF=-1))) %THEN ->HIT %REPEAT REG=-1 %RETURN HIT: TREG_AT=WTRIPNO REG=I %END %ROUTINE BOOT OUT(%INTEGER REG) !*********************************************************************** !* REMOVE TEMPORARIES FROM REG INTO LOCAL OR ONTO STACK * !* IT IS VITAL THAT ACC IS STACKED FIRST BEFORE B OR DR * !* OTHERWISE MIXUPS OCCUR WHEN PASSING MULTI-DIMENSION ARRAY * !* ELEMENTS WITH FNS AS SUBSCRIPTS AS VALUE SCALARS * !*********************************************************************** %INTEGER BSIZE,WSIZE,NREGS,D,J %RECORD(REGF)%NAME BOOTREG %RECORD(RD)%NAME R BOOTREG==REGS(REG) IMPABORT %UNLESS 1<=BOOTREG_CL<=3 R==RECORD(BOOTREG_LINK) BSIZE=BYTES(R_PTYPE>>4&15) WSIZE=REGWORDS(R_PTYPE&127) NREGS=WSIZE>>4; WSIZE=WSIZE&15 %IF BOOTREG_CL=1 %THEN %START %IF R_D=0 %THEN %START GET WSP(D,WSIZE) R_D=CURRINF_RBASE<<16!D %FINISH DSTORE(REG,BSIZE,R_D>>16,R_D&X'FFFF') R_FLAG=7 %FINISH %ELSE %IF BOOTREG_CL=3 %START DSTORE(REG,BSIZE,-1,64+4*REG) %FINISH %ELSE %IF BOOTREG_CL=2 %THEN IMPABORT REGS(REG+J)=0 %FOR J=0,1,NREGS-1 %END %ROUTINE CALL COMING (%INTEGER UPPER) !*********************************************************************** !* CALLED TO SAVE RESULTS AND PARAMETERS IN CASE CALL WITHIN CALL * !*********************************************************************** %INTEGER J SAVE IRS(UPPER); ! FRS NOT ALWAYS SAVED FOR PERM J=(FPPTR+7)&(-8) PUSH(FPHEAD,FPPTR,LAST PAR REG,J) %IF FPPTR>64 %THEN DUMPRX(LA,WSPR,0,WSPR,J) FPPTR=64 %END %ROUTINE CALL MADE !*********************************************************************** !* CALL HAS BEEN MADE. EXPOSE ANY PARAMETERS * !*********************************************************************** %INTEGER J POP(FPHEAD,FPPTR,LAST PAR REG,J) %IF CA>4096-MARGIN %THEN SET USE(LINKREG,X'51',BASEREG,CA) %IF FPPTR>64 %THEN DUMPRX(SH,WSPR,0,CTABLEREG,SHORT CONST(J)) %END %ROUTINE GET IN ACC(%INTEGERNAME SREG,%INTEGER SIZE,%RECORD(RD)%NAME OPND) %INTEGER REG,COUNT,TY,PR,OPCODE,I %IF SREG<0 %THEN SREG=FINDREG(NEGREG(SREG),0) REG=SREG TY=REG>>4 PR=BYTESTOPT(SIZE)>>4 OPCODE=LDCODE(8*TY+PR) COUNT=SIZE>>2-1 %IF OPCODE=LM %START %IF OPND_XB>>4=0 %THEN DUMPM(OPCODE,REG,REG+COUNT,OPND_XB, OPND_D) %ELSE %START DUMPRX(LGR,REG+I,OPND_XB>>4,OPND_XB&15,OPND_D+I) %C %FOR I=0,1,COUNT %FINISH %FINISH %ELSE %START DUMPRX(OPCODE,REGCODE(REG),OPND_XB>>4,OPND_XB&15,OPND_D) %IF SIZE=16 %THEN %C DUMPRX(OPCODE,REGCODE(REG+1),OPND_XB>>4,OPND_XB&15,OPND_D+8) %FINISH %END %ROUTINE GET OUT OF ACC(%INTEGER REG,%INTEGER SIZE,%RECORD(RD)%NAME OPND) %INTEGER COUNT,TY,PR,OPCODE,I TY=REG>>4 PR=BYTESTOPT(SIZE)>>4 OPCODE=STCODE(8*TY+PR) COUNT=SIZE>>2-1 %IF OPCODE=STM %START %IF OPND_XB>>4=0 %THEN DUMPM(OPCODE,REG,REG+COUNT,OPND_XB, OPND_D) %ELSE %START DUMPRX(ST,REG+I,OPND_XB>>4,OPND_XB&15,OPND_D+I) %C %FOR I=0,1,COUNT %FINISH %FINISH %ELSE %START DUMPRX(OPCODE,REGCODE(REG),OPND_XB>>4,OPND_XB&15,OPND_D) %IF SIZE=16 %THEN %C DUMPRX(OPCODE,REGCODE(REG+1),OPND_XB>>4,OPND_XB&15,OPND_D+8) %FINISH %END %ROUTINE DSTORE(%INTEGER REG,SIZE,LEVEL,DISP) !*********************************************************************** !* STORE SIZE(BYTES) FROM DISP(BYTES) IN DISPLAY 'LEVEL' * !*********************************************************************** %RECORD(RD) DOPND DOPND_FLAG=10 DOPND_XB=DISPREG(LEVEL) DOPND_D=DISP GET OUT OF ACC(REG,SIZE,DOPND) %END %ROUTINE DFETCHAD(%INTEGERNAME REG,%INTEGER LEVEL,DISP) !*********************************************************************** !* FETCH ADDRESS OF DISP(BYTES) IN DISPLAY 'LEVEL' * !*********************************************************************** %IF REG<0 %THEN REG=FINDREG(NEGREG(REG),0) DUMPRX(LA,REG,0,DISPREG(LEVEL),DISP) REGS(REG)_USE=0 %END %ROUTINE DFETCH(%INTEGERNAME REG,%INTEGER SIZE,LEVEL,DISP) !*********************************************************************** !* FETCH SIZE(BYTES) FROM DISP(BYTES) IN DISPLAY 'LEVEL' * !*********************************************************************** %RECORD(RD) DOPND DOPND_FLAG=10 DOPND_XB=DISPREG(LEVEL) DOPND_D=DISP GET IN ACC(REG,SIZE,DOPND) %END %ROUTINE INC REG(%INTEGER REG,AMOUNT,LAOK) !*********************************************************************** !* ADDS OR SUBTRACTS AMOUNT INTO REG. IF LAOK=YES THEN USES LA * !* FOR SMALL INCREMENTS. NORMALLY USES AH * !*********************************************************************** %INTEGER OP,DIS %IF AMOUNT=0 %THEN %RETURN %IF LAOK=YES %AND 0LIMIT CURRT==TRIPLES(LINK) LINK=CURRT_FLINK %RESULT=YES %IF CURRT_OPERN=TLAB %AND CURRT_OPND1_D&X'FFFF'=LAB DIST=DIST+TRIPDATA(CURRT_OPERN)>>8&255 %REPEAT %END %ROUTINE CEND !************************************************************************ !* NOW CLAIM THE STACK FRAME BY SPECIFYING RT DICT ENTRY * !************************************************************************ %INTEGER JJ,D JJ=CURRINF_SNMAX %IF JJ<4095 %THEN PLUG(1,CURRINF_SET+2,JJ,2) %ELSE %START D=SHORT CONST(JJ) %IF D<4095 %THEN %START %IF PARM_CHK=0 %THEN JJ=AH<<24!WSPR<<20 %ELSE JJ=LH<<24 PLUG(1,CURRINF_SET,JJ!CTABLEREG<<16!D,4) %FINISH %ELSE IMPABORT %FINISH REGS(CLNB)_CL=0 %END %ROUTINE CIOCP(%INTEGER N,REG) !*********************************************************************** !* COMPILES A CALL ON IOCP ENTRY POINT NO 'N' * !* 2ND (32 BIT) PARAMETER IS ALREAD IN REG * !*********************************************************************** %CONSTINTEGER NEED RES=X'40016' %INTEGER MREG MREG=ANYGR REGS(REG)_CL=-1 FORGETM(8) CALL COMING(8) DSTORE(REG,4,-1,68) REGS(REG)_CL=0 DUMPRXE(LA,MREG,0,0,N) DSTORE(MREG,4,-1,64) DUMPM(STM,4,14,WSPR,16) DUMPM(LM,CODER,EPREG,GLA,KNOWN XREF(4)) PRR(BALCODE-X'40',15,14) CALL MADE %IF 1<0 %THEN DUMPRX(CODE,MASK&15,0,CODER,VAL) %ELSESTART J=CA FIND USE(REG,X'51',PERMFOURK,N); ! FIND RELEVANT 4K MULTIPL %IF REG>0 %THEN J=J!X'80000000' %ELSE %START REG=FINDREG(GR1,0); ! FIND EMPTY REGISTER PRX(LGR,REG,CODER,0,0); ! HALF OF LOAD INSTRN SET USE(REG,X'51',PERMFOURK,N) %FINISH PRX(CODE,MASK&15,REG,0,0); ! AND HALF OF BRANCH ! REST DONE BY FILL IN EPILOGUE LCELL==ASLIST(WORKA_PLINK(N)) %IF LCELL_S3#0 %THEN PUSH(WORKA_PLINK(N),J,0,0) %ELSE %START %IF LCELL_S2=0 %THEN LCELL_S2=J %ELSE LCELL_S3=J %FINISH %FINISH %IF CODE=BALCODE %START; ! IF WE ARE COMING BACK FORGETM(8) %IF SAVE=YES %IF REGS(LINKREG)_CL#0 %THEN IMPABORT REGS(LINKREG)_USE=0 %IF 4096-CA>4,OPND_XB&15,OPND_D) OPERAND USED(OPND) OPND_XB=NEWBASE OPND_D=0 REGS(NEWBASE)_CL=TEMPBASE REGS(NEWBASE)_USE=0 %END %ROUTINE OPERAND USED(%RECORD(RD)%NAME OPND) !*********************************************************************** !* AFTER OPERAND IS USED FREES UP TEMP BASES ETC * !*********************************************************************** %INTEGER X,B,J %RECORD(REGF)%NAME REG %IF OPND_FLAG=9 %START X=WORDS(OPND_PTYPE>>4&7) X=X>>1 %IF OPND_PTYPE&7=2 %AND X>1;! X IS NO OF REGISTERS %FOR J=OPND_XB,1,OPND_XB+X-1 %CYCLE REG==REGS(J) %IF REG_CL=IRESULT %THEN %START REG_CNT=REG_CNT-1 %IF REG_CNT<=0 %THEN REG_CL=0 %FINISH %REPEAT %FINISH %IF 10<=OPND_FLAG<=11 %START X=OPND_XB>>4 B=OPND_XB&15 REG==REGS(X) %IF X>0 %START REG_CNT=REG_CNT-1 %IF REG_CNT<=0 %AND (REG_CL=IRESULT %OR REG_CL=TEMPBASE) %C %THEN REG_CL=0 %FINISH REG==REGS(B) %IF B>0 %START REG_CNT=REG_CNT-1 %IF REG_CNT<=0 %AND (REG_CL=IRESULT %OR REG_CL=TEMPBASE) %C %THEN REG_CL=0 %FINISH %FINISH %END %ROUTINE OPERAND LOADED(%RECORD(RD)%NAME OPND,%INTEGER REG) !*********************************************************************** !* UPDATES OPERAND AND REG DESCRIPTORS AFTER A LOAD * !* NORMALLY IN LINE CODE BUT 360 REGS SUCH A MESS * !*********************************************************************** %INTEGER TYPE,PREC,X,J %RECORD(REGF)%NAME LREG TYPE=OPND_PTYPE&7 PREC=OPND_PTYPE>>4&15 %IF TYPE=1 %AND PREC<5 %THEN %START %IF PREC=3 %AND REGS(REG)_USE=0 %THEN REGS(REG)_USE=SCONST %C %AND REGS(REG)_INF1=-1000 PREC=5 OPND_PTYPE=X'51' %FINISH OPND_FLAG=9 OPND_D=0 OPND_XB=REG X=WORDS(PREC) X=X>>1 %IF TYPE=2 %AND X>1 %FOR J=REG,1,REG+X-1 %CYCLE LREG==REGS(J) LREG_CL=1 LREG_CNT=1 LREG_AT=WTRIPNO LREG_LINK=ADDR(OPND) %REPEAT %END %INTEGERFN RESULT REG(%INTEGER PTYPE) !*********************************************************************** !* DECIDES ON THE REGISTER FOR FN RESULTS * !*********************************************************************** PTYPE=PTYPE&255 %IF PTYPE&7=2 %THEN %RESULT=16{FR0} %ELSE %C %IF PTYPE=X'61' %THEN %RESULT=0 %ELSE %RESULT=1 %END %ROUTINE PUT(%INTEGER EVALREG, CODE,OFFSET,FINISHED,%RECORD(RD)%NAME OPND) !*********************************************************************** !* THIS ROUTINE PLANTS CODE TO PERFORM THE BASIC * !* OPERATION DEFINED BY OPND & OPCODE * !* OFFSET AND FINISHED NEED FOR MULTILENGTH INTEGER OPERATIONS * !* SINCE EITHER PART MAY NEED TO COME FIRST * !*********************************************************************** %RECORD(REGF)%NAME REG %IF OPND_FLAG=9 %START; ! SECOND OPERAND IN REG %IF CODE&X'FF00'#0 %THEN %C PRRX(CODE,REGCODE(EVALREG)+OFFSET,REGCODE(OPND_XB)+OFFSET) %ELSE %START %IF CODE>=X'40' %THEN CODE=CODE-X'40' PRR(CODE,REGCODE(EVALREG)+OFFSET,REGCODE(OPND_XB)+OFFSET) %FINISH %FINISH %ELSE %START IMPABORT %UNLESS OPND_FLAG=10 %AND CODE>=X'40' DUMPRX(CODE,REGCODE(EVALREG)+OFFSET,OPND_XB>>4,OPND_XB&15,OPND_D+4*OFFSET) %FINISH REG==REGS(EVALREG) REG_USE=0 %UNLESS (CODE4095 AND MANIPULATES * !* INDEX ACCORDINGLY. FREQUENTLY INDEX=0 (NO INDEXING) WHEN THE * !* SOLUTION IS TRIVIAL. MODE=0 IF INDEX MUST BE COPIED BEFORE * !* BEING ADJUSTED. * !*********************************************************************** %INTEGER J, K, D, PN J=FIND REG(GR1,0); ! MAY NOT BE NEEDED %IF DISP>0 %THEN K=X'5A' %AND D=DISP %ELSE K=X'5B' %AND D=4095-DISP PN=D>>12; FAULT(98, 0, 0) %IF PN>MAX4KMULT %IF INDEX=0 %AND DISP>0 %THEN %START FIND USE(INDEX,X'51',FOURKMULT,PN);! LOOK FOR 4K MULTIPLE ->REND %IF INDEX>0 SET USE(J,X'51', FOURKMULT, PN) INDEX=J; K=LGR %FINISH %ELSE %START %IF MODE=0 %OR INDEX=0 %THEN %START %IF MODE=0 %THEN PRR(LR, J, INDEX) %ELSE PRR(SR, J, J) INDEX=J %FINISH FORGET(INDEX) %FINISH PRX(K, INDEX, CODER, 0, PN<<2) REND: DISP=DISP&4095 %END %ROUTINE DUMPRXE(%INTEGER CODE,%INTEGERNAME REG,%INTEGER X,LEVEL,DISP) !*********************************************************************** !* AS DUMPRX BUT SELCTS THE REG ALSO !*********************************************************************** %INTEGER K %RECORD(REGF)%NAME UREG %IF REG<0 %THEN %START; ! -1==ANY -2==ANY BAR 0 %IF CODE=IC %START; ! TRY TO AVOID CLEARING A REG K=1 %WHILE REG<0 %AND K<=15 %CYCLE UREG==REGS(K) %IF UREG_CL=0 %AND %C ((UREG_PRIMUSE=LITCONST %AND UREG_INF1<=255) %C %OR (UREG_SECUSE=LITCONST %AND UREG_INF2<=255)) %C %THEN REG=K K=K+1 %REPEAT %FINISH %IF REG<0 %THEN REG=FIND REG(NEGREG(REG),0) %FINISH DUMPRX(CODE,REG,X,LEVEL,DISP) %END %ROUTINE DUMPRX(%INTEGER CODE, REG, X, LEVEL, DIS) !*********************************************************************** !* PUTS OUT AN RX INSTRUCTION COMPENSATING FOR SHORTCOMINGS OF IC * !* NO LONGER ATTEMPTS TO OPTIMISE "LA" BUT DEALS WITH DIS>4095 * !*********************************************************************** %INTEGER K,ANDR %RECORD(REGF)%NAME UREG ANDR=0 %IF CODENORMAL %IF UREG_PRIMUSE=LITCONST %AND UREG_INF1<=255 ->NORMAL %IF UREG_SECUSE=LITCONST %AND UREG_INF1<=255 %IF REG=0 %OR X#REG#LEVEL %THEN PRR(SR, REG, REG) %ELSE ANDR=1 %FINISH NORMAL: PRX(CODE, REG, X, LEVEL, DIS) %IF ANDR#0 %THEN PRX(AND, REG, 0, CODER, WORKA_PLABS(1)) %END %ROUTINE DUMPSI(%INTEGER OPCODE, L, B, D) !*********************************************************************** !* OUTPUTS A SI INSTRUCTION DEALING WITH DISPLACEMENTS>4095 * !*********************************************************************** %IF D>4095 %THEN ADJUST INDEX(REGS(B)_CL+1, B, D) PSI(OPCODE, L, B, D) %END %ROUTINE DUMPM(%INTEGER OPCODE, R1, R2, B, D) !*********************************************************************** !* OUTPUTS A STM TYPE OF INSTRUCTION COMPENSATIONG FOR D>4095 * !*********************************************************************** %IF D>4095 %THEN ADJUST INDEX(REGS(B)_CL+1, B, D) PRX(OPCODE, R1, R2, B, D) %END %ROUTINE DUMPSS(%INTEGER OP,L,B1,D1,B2,D2) !*********************************************************************** !* OUTPUTS AN SS INSTRN DEALING WITH EITHER OR BOTH DISPLACEMENTS * !* OF MORE THAN 4096 (PROVIDED BASES ARE CORRECTLY CLAIMED * !*********************************************************************** %IF D1>4095 %THEN ADJUST INDEX(0,B1,D1) %IF D2>4095 %THEN ADJUST INDEX(0,B2,D2) %IF OP=MVC %THEN PMVC(L,B1,D1,B2,D2) %ELSE %C PSS(OP,L,B1,D1,B2,D2) %END %ROUTINE EXECUTESS(%INTEGER XREG,OPCODE,B1,D1,B2,D2) !*********************************************************************** !* PUTS A ZERO LENGTH STORE TO STORE INSTRUCTION INTO CONSTANTS * !* AND EXECUTES IT WITH 'EX' * !*********************************************************************** %INTEGER I,J,K,C1,C2 C1=B1; C2=B2 %IF D1>4095 %THEN ADJUST INDEX(0,B1,D1) %AND REGS(B1)_CL=2 %IF D2>4095 %THEN ADJUST INDEX(0,B2,D2) %AND REGS(B2)_CL=2 I=OPCODE<<24!B1<<12!D1 J=B2<<28!D2<<16 STORE CONST(K,6,ADDR(I)) DUMPRX(EX,XREG,0,CTABLEREG,K) %IF B1#C1 %THEN REGS(B1)_CL=0 %IF B2#C2 %THEN REGS(B2)_CL=0 %END %ROUTINE NOTE ASSMENT(%INTEGER REG, ASSOP, VAR,PTYPE) !*********************************************************************** !* NOTES THE ASSIGNMENT TO SCALAR 'VAR'. THIS INVOLVES REMOVING * !* OLD COPIES FROM REGISTERS TO AVOID CONFUSING OLD AND NEW VALUE* !* ASSOP =1 FOR'==',=2 FOR '=',=3 FOR '<-' * !*********************************************************************** %CONSTINTEGER EEMASK=B'1100011110000000';! MASK OF USES RELEVANT TO == %CONSTINTEGER EMASK=B'100011000000000';! MASK OF USES RELEVANT TO = %RECORD(REGF)%NAME WREG %INTEGER I,II,NREGS %RETURN %IF VAR<=0 NREGS=REGWORDS(PTYPE)>>4 %IF ASSOP=1 %THEN %START %CYCLE II=0,1,14; ! THROUGH ALL REGISTERS I=GRMAP(II) WREG==REGS(I) %IF EEMASK&1<>16=VAR) %THEN WREG_SECUSE=0 %IF EEMASK&1<>16=VAR) %THEN WREG_USE=WREG_SECUSE %AND %C WREG_INF1=WREG_INF2 %REPEAT %IF REG>=0 %START WREG==REGS(REG) WREG_USE=ADDROF WREG_INF1=VAR %FINISH %FINISH %ELSE %START %CYCLE II=0,1,14 I=GRMAP(II) WREG==REGS(I) %IF EMASK&1<>16=VAR %OR WREG_INF2=VAR) %THEN WREG_SECUSE=0 %IF EMASK&1<>16=VAR %OR WREG_INF1=VAR) %THEN %C WREG_USE=WREG_SECUSE %AND WREG_INF1=WREG_INF2 ! ! ALL THE FOREGOING CONDITIONS ARE NOT AS SILLY AS THEY SEEM. MUST ! BEAR IN MIND THAT BOTH GRINF&VAR MAY BE RECORD ELEMENTS DEFINED ! BY ALL 32 BITS OF INF AS WELL AS MODIFIED SCALARS WHEN THE NAME ! ONLY TAKES 16 BITS ! %REPEAT %IF ASSOP=2 %AND VAR>0 %AND REG>=0 %START %FOR REG=REG,1,REG+NREGS-1 %CYCLE WREG==REGS(REG) %IF LITCONST<=WREG_PRIMUSE&255<=TABCONST %START; ! ASSIGN CONST TO VAR WREG_SECUSE=LOCAL VAR WREG_INF2=VAR %FINISH %ELSE %START; ! ASSIGN VAR OR EXP TO VAR WREG_SECUSE=WREG_PRIMUSE WREG_PRIMUSE=LOCAL VAR WREG_INF2=WREG_INF1; ! PREVIOUS USE BECOMES 2NDRY WREG_INF1=VAR %FINISH %REPEAT %FINISH %FINISH %END %ROUTINE BULK M(%INTEGER MODE,L,B1,D1,B2,D2) !*********************************************************************** !* PLANT CODE TO MOVE L BYTES (L KNOWN AT COMPILE TIME) FROM * !* D1(B1) TO D2(B2) * !* IF MODE =0 SET L BYTES TO D2(0 OR X'80') * !* * !* L MAY BE GREATER THAN 4095 * !*********************************************************************** %ROUTINESPEC UPDATE(%INTEGERNAME WI,DI) %INTEGER I,J,W1,W2,OPCODE,CONST W1=B1; W2=B2 OPCODE=MVC %IF L+D1> 4092 %THEN UPDATE(W1,D1) %IF MODE#0 %AND L+D2>4092 %THEN UPDATE(W2,D2) %IF MODE=0 %THEN %START; ! PROPAGATE CONSTANT J=L; W2=W1 CONST=D2; D2=D1 %IF CONST=0 %AND L<=32 %THEN %START ! CCSTATE=-1 OPCODE=X'D7'; ! CAN USE XC %FINISH %ELSE %START; ! USE MVI & MVC TO PROPOGATE PSI(MVI,CONST,W1,D1) L=L-1; D1=D1+1 %FINISH %FINISH ! ! END OF PREPARATION - CYCLE ROUND PLANTING MVC ! %WHILE L>0 %CYCLE %IF L>256 %THEN J=256 %ELSE J=L %IF D1>4092 %THEN %START I=D1; UPDATE(W1,D1) %IF W2=W1 %THEN D2=D2-I+D1; ! OVERLAPPING PROPAGATION W1=W2 %FINISH %IF D2>4092 %THEN UPDATE(W2,D2) PSS(OPCODE,J,W1,D1,W2,D2) D1=D1+J D2=D2+J L=L-J %REPEAT ! %RETURN %ROUTINE UPDATE(%INTEGERNAME WI,DI) %INTEGER WK,J WK=WI %IF REGS(WK)_CL<0 %THEN WK=FIND REG(GR1,0) %IF DI<4092 %THEN J=DI %ELSE J=4092 DUMPRX(LA,WK,0,WI,J) FORGET(WK) DI=DI-J; WI=WK %END %END; ! OF ROUTINE BULK M %END; ! OF ROUTINE GENERATE %ENDOFFILE