%INCLUDE "ERCC07.TRIMP_HOSTCODES" %CONSTINTEGER HOST=EMAS %CONSTINTEGER TARGET=EMAS %CONSTINTEGER FOURKTDISP=0 %INCLUDE "ERCC10.OPOUTS" ! %CONSTINTEGER LGR=X'58',AND=X'54',ICP=X'59'; ! VARIANT MNEMONICS %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'0000000F'; ! 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,LOCALTIMES=10, FOURKMULT=11,LABFOURK=12,BASEREG=13,PERMFOURK=14,DVBASE=15, STRWKAREA=16 %CONSTINTEGER LB=X'7A',SLB=X'52',STB=X'5A',ADB=X'20',CPB=X'26', %C MYB=X'2A',SBB=X'22',CPIB=X'2E',CPSR=X'34' %CONSTINTEGER LDA=X'72',INCA=X'14',LDB=X'76', %C LDTB=X'74',LDRL=X'70',CYD=X'12',MODD=X'16' %CONSTINTEGER ASF=X'6E',RALN=X'6C',LXN=X'7E',%C LLN=X'7C',LSS=X'62',SLSS=X'42',MPSR=X'32',STSF=X'5E',%C LUH=X'6A',STUH=X'4A',LSD=X'64',SLSD=X'44',PRCL=X'18', %C LSQ=X'66' %CONSTINTEGER JUNC=X'1A',JLK=X'1C',CALL=X'1E',JCC=2, %C JAT=4,JAF=6,DEBJ=X'24' %CONSTINTEGER IAD=X'E0',USH=X'C8',ISB=X'E2',IRSB=X'E4',%C IMY=X'EA',IMDV=X'AE', %C ISH=X'E8',NEQ=X'8E' %CONSTINTEGER RAD=X'F0',FLT=X'A8',RRDV=X'BC', %C RSC=X'F8',FIX=X'B8',RDV=X'BA', %C RMY=X'FA',RCP=X'F6' ! %CONSTINTEGER MVL=X'B0',MV=X'B2',CPS=X'A4' ! ! DEFINE SOME MNEMONICS FOR THE VISIBLE REGISTERS (XCEPT LNB) ! %CONSTINTEGER ACCR=0,DESR=1,LNB=2,XNB=3,CTB=5,TOS=6,BREG=7 %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; ! %INCLUDE "ERCC07.TRIPCNSTS" %INCLUDE "ERCC07.TRIMP_TFORM1S" %RECORDFORMAT REGF(%INTEGER CL,CNT,(%INTEGER USE %OR %HALF SECUSE,PRIMUSE), %INTEGER INF1,INF2,AT,LINK) %OWNINTEGER CABUF,GLACABUF,CONSTHOLE,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 !%OWNINTEGERNAME ASL %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 LPUT(%INTEGER A,B,C,D) %EXTERNALSTRING(255)%FNSPEC UCSTRING(%STRING(255) S) %EXTERNALROUTINESPEC FAULT(%INTEGER I,J,K) %ROUTINESPEC PF1(%INTEGER OPCODE,A,B,N) %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=6; ! AREA FOR DIAG TABLES %CONSTINTEGER CAREA=1; ! 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.LPUT 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 LLPUT(%INTEGER A,B,C,D) !%INTEGER I ! PRINTSTRING(" !CALL ON LPUT") ! 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 ! LPUT(A,B,C,D) ! NEWLINE !%END %ROUTINESPEC PF1(%INTEGER OPCODE,A,B,N) %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=6; ! AREA FOR DIAG TABLES %CONSTINTEGER CAREA=1; ! 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.LPUT 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 LLPUT(%INTEGER A,B,C,D) !%INTEGER I ! PRINTSTRING(" !CALL ON LPUT") ! 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 ! LPUT(A,B,C,D) ! NEWLINE !%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 LPUT(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 LPUT(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 %ROUTINE PSF1(%INTEGER OPCODE,K,N) !*********************************************************************** !* PLANT THE HALFWORD FORMS OF PRIMARY FORMAT NR INSTRNS * !* IF N IS TOO LARGE FOR THE SHORT FORM PF1 IS CALLED TO PLANT * !* THE CORRESPONDING LONG FORM * !*********************************************************************** PLANT(X'0701') %END %ROUTINE PF1(%INTEGER OPCODE,KP,KPP,N) !*********************************************************************** !* PLANT THE NORMAL FORMS OF PRIMARY FORMAT INSTRNS(IE THOSE * !* WHICH DO NOT DEPEND ON THE SIZE OF N) * !*********************************************************************** %INTEGER INC PCONST(X'470000F1') %END %ROUTINE PSORLF1(%INTEGER OPCODE,KP,KPP,N) !*********************************************************************** !* AS PF1 BUT CUT VALID FORMS TO SHORT FORM * !*********************************************************************** PCONST(X'470000F1') %END %ROUTINE PF3(%INTEGER OPCODE,MASK,KPPP,N) !*********************************************************************** !* PLANT THE TERTIARY(JUMP) FORMAT INSTRUCTIONS * !*********************************************************************** ! IMPABORT %UNLESS 0<=MASK<=15 %AND 0<=KPPP<=7 %AND OPCODE&1=0 PCONST(X'470000F3') %END %INTEGERFN MAPDES(%INTEGER PREC) %RESULT=0 %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)) %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 %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 SKIP: %IF L=2 %START %IF HALFHOLE#0 %THEN %START CTABLE(HALFHOLE)=CTABLE(HALFHOLE)!(C1>>16) HALFHOLE=0 D=4*HALFHOLE+2 %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 I,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_USE&255=U %AND REG_INF1=LCELL_S1 %AND LCELL_S2=REG_AT %C %THEN HEAD==LCELL_LINK %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 LPUT(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 LPUT(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 LPUT(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 LPUT(30+AREA,BYTES,AT,ADDR(VALUE)+4-BYTES) IBMRECODE(ADDR(VALUE)+4-BYTES,ADDR(VALUE)+4,AT) %C %IF PARM_DCOMP=1=AREA %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 LPUT(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>4 %THEN RL=4 GLACA=(GLACA+RL-1)&(-RL) 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 LPUT(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,X,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 LPUT(15,2<<24!SIZE,RES,ADDR(XNAME)) LPUT(15,2<<24!SIZE,RES+4,ADDR(XNAME));! RELOCATE BY EXTERNAL %FINISH %ELSE %START %IF AAREA#0 %THEN RELOCATE(RES,AHW1,AAREA) %AND %C RELOCATE(RES+4,AHW1,AAREA) %FINISH RELOCATE(RES+8,AHW3,1); ! RELOCATE DV PTR %IF LITL=2 %THEN LPUT(14,AAREA<<24!SIZE,AOFFSET,ADDR(XNAME)) %RESULT=RES %END %ROUTINE GXREF(%STRING(31) NAME,%INTEGER MODE,XTRA,AT) !*********************************************************************** !* ASK LPUT 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 * !* MODE=4 DATA XREF XTRA=MINIMIUM LENGTH (SINGLE WORD ONLY) * !*********************************************************************** %CONSTBYTEINTEGERARRAY LPUTCODE(0:4)= 12,12,12,13,15 NAME=UCSTRING(NAME) LPUT(LPUTCODE(MODE),XTRA,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=0 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,0,D) 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(BASR,15,14) %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 * !*********************************************************************** %INTEGER QP LPUT(19,2,GLARAD,AREA) %END %ROUTINE DEFINE EP(%STRING(255)XNAME, %INTEGER AREA,AT,MAINORMIN) !*********************************************************************** !* TO DEFINE AN EP SIMPLY TELL LPUT 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 & LPUT DIFFER HEREABOUTS!) * !*********************************************************************** XNAME=UCSTRING(XNAME) %IF AREA=1 %START; ! CODE ENTRIES LPUT(11,MAINORMIN<<31!1,AT,ADDR(XNAME)) %FINISH %ELSE %START LPUT(14,AREA<<24!MAINORMIN,AT,ADDR(XNAME)) %FINISH %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 ", " NAME*CNST "," 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,3) 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'1000011110000000' %CONSTINTEGER UNMASK=B'0000001110000000' PRINTSTRING(" USE = ".USES(USE)) %IF LNMASK&1<>16,1) %IF UNMASK&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, L, STCA 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 CTABLE==WORKA_CTABLE I=X'C2C2C2C2' LPUT(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 ! ! 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(BAS,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 * !*********************************************************************** %INTEGER D,J %ROUTINESPEC LONGOP(%INTEGER OP) %ROUTINESPEC FILL(%INTEGER LAB) P16: ! ! 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(BASR,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 LPUT 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 LPUT(30+2, I, GLACABUF, ADDR(GLABUF(0))) %UNLESS I=0 ! BACK OF GLAP LPUT(30+2, FIXEDGLALEN, 0, ADDR(FIXED GLA(0)));! FRONT OF GLAP LPUT(19,2,4,1); ! RELOCATE HEAD OF CODE LPUT(19,2,8,5); ! RELOCATE GLA ST ADDRESS LPUT(19,2,12,4); ! RELOCATE CODE ST ADDRESS LPUT(19,2,20,DAREA); ! RELOCATE DIAG AREA PTYR LPUT(19,2,24,CAREA); ! RELOCATE DIAGS AREA I=X'E2E2E2E2' LPUT(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 LPUT(7, 28, 0, ADDR(CAS(1))) ! SUMMARY INFO. PPROFILE %STOP %ROUTINE DUMP CONSTS !*********************************************************************** !* OUTPUT THE CONSTANT TABLE AND MAKE ANY RELEVANT RELOCATIONS * !*********************************************************************** %INTEGER I,J,K,DISP,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 LPUT(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 ! SIZE=(SIZE+1)&(-2) CA=CA+4*SIZE CABUF=CA %RETURN %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,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 TYPE,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 VMULTIPLY %ROUTINESPEC LNEGATE(%INTEGER REG) %ROUTINESPEC REXP %ROUTINESPEC STARSTAR %ROUTINESPEC NOTE ASSMENT(%INTEGER REG,ASSOP,VAR) %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 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) %INTEGERFNSPEC EXECUTESS(%INTEGER 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,COMM,XTRA,PT,BFFLAG,TRIPINF,TRIPVAL,PTYPE,TYPE,PREC, STPTR,L0,B1,B2,B3,EVALREG,NEST,CLNB %OWNINTEGER RESTEMPAD=0; ! REMEMBERS CURRENT RESLN WK AD %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'20040420'{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}, 7,0,0,0 {19 PRELOAD}, 3,A,AH,0 {20 INTEGER ADDITION}, 3,S,SH,0 {21 INTEGER SUBTRACTION}, 1,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}, 3,AND,0,0 {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 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,0,0,0 {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}, 7,0,0,0 {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,CH,1 {31 COMPARISONS}, 14,ICP,CH,3 {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,0,0,0 {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}, 7,0,0,0 {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 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,0,0,0 {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}, 7,0,0,0 {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,CE,-ANYFRPAIR {31 COMPARISONS}, 14,CD,CE,-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,0,0,0 {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) LPUT(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 SW(6): ! PLANT 2 BYTES & SET PTYPE OPND1_PTYPE=B3 ->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(7): ! NULL OPERATION ->STRES SW(8): ! LOGICAL NOT LOAD(OPND1,-B3,2) DUMPRX(X,OPND1_XB,0,CODER,WORKA_PLABS(1)+4) FORGET(OPND1_XB) %IF PTYPE=X'61' %START DUMPRX(X,OPND1_XB+1,0,CODER,WORKA_PLABS(1)+4) FORGET(OPND1_XB+1) %FINISH ->SUSE SW(9): ! SHORTEN INTEGER OR REAL %IF PTYPE=X'72' %START LOAD(OPND1,ANY FRPAIR,2); ! TO ANY FR PAIR EVALREG=OPND1_XB PRR(LRDR,REGCODE(EVALREG),REGCODE(EVALREG)) REGS(EVALREG)_CL=0 %FINISH %ELSE %IF PTYPE=X'62' %START LOAD(OPND1,ANY FR,2); ! TO ANY FR EVALREG=OPND1_XB PRR(LRER,REGCODE(EVALREG),REGCODE(EVALREG)) %FINISH %ELSE %IF PTYPE=X'61' %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 OPND_XB=EVALREG %FINISH %ELSE %START PRX(SLDA,EVALREG,0,0,32) REGS(EVALREG+1)_CL=0 %FINISH %FINISH %ELSE %IF PTYPE=X'51' %START LOAD(OPND1,ANY GR,2) EVALREG=OPND1_XB %IF PARM_OPT#0 %THEN %START PRX(SLA,EVALREG,0,0,16) PRX(SRA,EVALREG,0,0,16) %FINISH %FINISH %ELSE %IF PTYPE=X'41' %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=OPND1_PTYPE-X'10' ->STRES SW(10): ! LENGTHEN INTEGER OR REAL %IF TYPE=2 %THEN %START %IF PTYPE=X'52' %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 PTYPE=X'51' %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=OPND1_PTYPE+X'10' REGS(EVALREG)_USE=0 %IF PTYPE=X'51' %OR PTYPE=X'62' %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,P2 P1=OPND1_XB P2=(P1+1)&15 %UNLESS OPND1_FLAG=9 %AND REGS(P2)_CL=0 %START P1=FINDSEQREG(GRSEQ,1) P2=(P1+1)&15 LOAD(OPND1,P1,2) %FINISH PRR(LPR,P2,P1) DUMPRX(AND,P1,0,CTABLEREG,WORD CONST(X'80000000')) PRX(STM,P1,P2,WSPR,0) PSI(OI,X'4E',WSPR,0) EVALREG=FINDREG(FR0,1) PRR(SDR,REGCODE(EVALREG),REGCODE(EVALREG)) PRX(AD,REGCODE(EVALREG),0,WSPR,0) REGS(P1)_CL=0 REGS(P2)_CL=0 REGS(P1)_USE=0 REGS(P2)_USE=0 REGS(EVALREG)_USE=0 OPND1_XB=EVALREG %END OPND1_PTYPE=OPND1_PTYPE+X'11' ->STRES SW(21): ! SHORTEN INTEGER FOR JAM TRANSFER LOAD(OPND1,ANY GR,2) ! NO CODE NEEDED FOR 32BITS & LESS EVALREG=OPND1_XB OPND1_PTYPE=OPND1_PTYPE-X'10' ->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 %THEN ->SW(4) ! COMPARISON OF MULTIREGISTER ITEMS LOAD(OPNDC,ANY2SEQ,2) EVALREG=OPNDC_XB PUT(EVALREG,ICP,0,NO,OPNDNC) SET LOCAL BASE(C,JJ) PRX(BC,7,C,0,0) D=CA-2 PUT(EVALREG,CL,1,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,ANYGR BAR0,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 %IF OPND1_FLAG=2 %START; ! OPERAND A NAME LOAD(OPND2,-B3,2) EVALREG=OPND2_XB TCELL==ASLIST(TAGS(OPND1_D)) DSTORE(EVALREG,BYTES(PT>>4),TCELL_UIOJ>>4&15,TCELL_SLINK+OPND1_XTRA) %IF OPND1_XTRA<=0 %THEN NOTE ASSMENT(EVALREG,TRIPVAL-33,OPND1_D) %FINISHELSESTART; ! OPERAND A POINTER LOAD(OPND2,-B3,2) LOAD(OPND1,ANYGR BAR0,0) EVALREG=OPND2_XB PUT(EVALREG,STCODE(8*(PT&7-1)+(PT>>4&7)),0,YES,OPND1) %FINISH OPERAND USED(OPND2) OPND1=OPND2; ! IN CASE RESULT USED AGAIN ->STRES SW(23): ! LOCAL ASSIGNMENT LOAD(OPND2,-B3,2) EVALREG=OPND2_XB DSTORE(EVALREG,BYTES(PTYPE>>4&15),OPND1_D>>16,OPND1_D&X'FFFF') REGS(EVALREG)_CL=0 OPND1_FLAG=7 ->STRES SW(24): ! COMPARIONS WITH ZERO (OPND2 ZERO) D=FCOMP(CURRT_X1+32) %IF TYPE=2 %THEN D=D-4 WORKT==TRIPLES(CURRT_FLINK) %IF WORKT_OPERN=FJUMP %OR WORKT_OPERN=BJUMP %START %IF WORKT_X1&X'80'#0 %THEN WORKT_X1=X'80'!(D!!X'30') %C %ELSE WORKT_X1=D %FINISH %ELSE IMPABORT ->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)) ->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,0) DUMPM(STM,OPNDNC_XB,OPNDNC_XB+1,WSPR,16) OPERAND USED(OPNDNC) PPJ(0,B3,YES) EVALREG=0 REGS(0)_CL=0 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,XTRA&X'FFFF'+10);! MULT BY ELSSIZE 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,W0,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 %CONTINUE TRIPSW(9): ! VALIDATE FOR LOADPAIR(1,0,OPND1); ! OPND1 IS FINAL-INIT LOAD(OPND2,ANY GR,0); ! 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) REGS(1)_CL=0 %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 D=CURRT_X1&X'F'; ! THE MASK DUMPRX(BC,D,0,CODER,C) %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,B,0,0) LCELL_S2=B<<24!JJ LCELL_S1=(CA-4)!X'80000000';! MARK AS SHORT PLANTED %FINISH %ELSE %START FIND USE(B,1,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' %IF B1<0 %START; ! SUBSIDARY BASE REG USED %IF D>4095 %THEN FAULT(98,0,0) PLUG(1,B1&X'FFFFFF'+2,D,2) %FINISH %ELSE %START B=B2>>24 %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) PMVC(OPND2_XTRA+1,CLNB,D,OPND2_XB,OPND2_D) %FINISH %ELSE %START LOAD(OPND2,ANY GR,1) DUMPRX(IC,-2,0,OPND2_XB,OPND2_D) REGS(NEST)_CL=-1 REGS(NEST)_USE=LITCONST REGS(NEST)_INF1=-1000 C=EXECUTESS(MVC,CLNB,D,OPND2_XB,OPND2_D) DUMPRX(EX,NEST,0,CTABLEREG,C) REGS(NEST)_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 DUMPRX(IC,-2,0,CLNB,D); ! LENGTH OF BIT IN WK AREA OLENREG=NEST REGS(OLENREG)_CL=-1 REGS(OLENREG)_USE=LITCONST REGS(OLENREG)_INF1=-1000 DUMPRX(LA,-2,CLNB,OLENREG,0); ! PTR T0 STR END ADDREG=NEST 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) DUMPRX(IC,-2,0,OPND2_XB,OPND2_D);! LENGTH OF BIT TO BE ADDED ALENREG=NEST REGS(ALENREG)_CL=-1 REGS(ALENREG)_USE=LITCONST REGS(ALENREG)_INF1=-1000 DUMPRX(EX,ALENREG,0,CTABLEREG, EXECUTESS(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 PRX(CH,OPND1_XB,0,CTABLEREG,SHORT CONST(OPND2_XTRA)) PPJ(4,9,NO) %FINISH %FINISH %FINISH %ELSE %START LOAD(OPND2,ANYGR BAR0,1); ! LHS TO ANY BAR 0 DUMPRX(IC,-2,0,OPND2_XB,OPND2_D) XREG=NEST REGS(XREG)_CL=-1 REGS(XREG)_USE=LITCONST REGS(XREG)_INF1=-1000 D=EXECUTESS(MVC,OPND1_XB+1,0,OPND2_XB,OPND2_D) DUMPRX(EX,XREG,0,CTABLEREG,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)) D=OPND2_XTRA; ! RHS LENGTH IF A CONST %IF OPND2_FLAG=LCONST %AND DNULLSC %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 DUMPRX(IC,-2,0,OPND1_XB,OPND1_D) JJ=NEST; REGS(JJ)_CL=1 SET USE(JJ,LITCONST,-1000) D=EXECUTE SS(CLC,OPND1_XB,OPND1_D,OPND2_XB,OPND2_D) DUMPRX(EX,JJ,0,CTABLEREG,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,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) PPJ(0,16,YES) FREE AND FORGET(0) %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 DUMPRX(IC,-2,0,CLNB,D+4); ! ORIGINAL LHS LENGTH XREG=NEST; REGS(XREG)_CL=1 SETUSE(XREG,LITCONST,-1000) DUMPRX(IC,-2,0,CLNB,D+5); ! BYTES USED UP BREG=NEST; 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) C=EXECUTESS(MVC,OPND2_XB+1,1,BREG,1) DUMPRX(EX,XREG,0,CTABLEREG,C) 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) LOAD(OPND1,-2,2) EVALREG=OPND1_XB %IF PARM_OPT#0 %START DUMPRX(IC,-1,0,EVALREG,0); ! FETCH CURRENT LENGTH PRR(CLR,OPND2_XB,NEST) PPJ(2,9,NO) SETUSE(NEST,LITCONST,-1000) %FINISH PRR(AR,EVALREG,OPND2_XB) FORGET(EVALREG) 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(BASR,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(BASR,LINKREG,1) %FINISHELSE %START JJ=TCELL_SNDISP %IF TCELL_UIOJ&15=15 %START;! NO BODY AS YET PUSH(JJ,BAS,CA,0) TCELL_SNDISP=JJ PRX(LGR,LINKREG,CODER,0,0) PRX(BAS,LINKREG,LINKREG,0,0) %FINISH %ELSE DUMPRX(BAS,LINKREG,0,CODER,(JJ&X'FFFF')<<2) %FINISH %CYCLE C=4,1,CLNB-1 REG==REGS(C) %IF ((1<4096-MARGIN %THEN SET USE(LINKREG,BASEREG,CA) %END %CONTINUE TRIPSW(44): ! MAP RESULT ASSIGNMENT ! CALLED BEFORE RETURN TO CALLER D=1 RES: LOAD(OPND2,D,2) OPERAND USED(OPND2) %CONTINUE TRIPSW(45): ! FN RESULT ASSIGNMENT ! CALLED BEFORE RETURN TO CALLER TCELL==ASLIST(TAGS(OPND1_D)) %IF CURRT_OPTYPE=X'35' %START;! STRING FNS %CONTINUE %FINISH D=RESULT REG(PTYPE) ->RES TRIPSW(26): ! RECOVER FN RESULT ! CALLED AFTER RETURN TO CALLER %IF CURRT_OPTYPE=X'35' %START; ! STRING FNS ! RESULTS ALREADY IN WORK AREA OPND1_FLAG=7 OPND1_D=CURRINF_RBASE<<16!OPND1_XTRA %CONTINUE %FINISH 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 MISPLACED %IF OPND1_PTYPE&7=5 %START; ! STRINGS BY VALUE - LABORIOUS LOAD(OPND2,ANY GR,1) DUMPSS(MVC,D,WSPR,LCELL_SNDISP+64,OPND2_XB,OPND2_D) OPERAND USED(OPND2) FPPTR=FPPTR+D %CONTINUE %FINISHELSEIF 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 %FINISHELSESTART %IF OPND1_PTYPE&7=2 %THEN C=-3 %ELSE C=-1 LOAD(OPND2,C,2) EVALREG=OPND2_XB %FINISH D=BYTES(OPND1_PTYPE>>4&15) ->PARCHK TRIPSW(29): ! GET 32 BIT ADDRESS LOADAD(OPND1,EVALREG) ->STRES TRIPSW(30): ! GET POINTER FOR %NAME LOADPTR(OPND1,OPND2,EVALREG) ->STRES 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=-5 %ELSE C=-1 LOAD(OPND2,C,2) EVALREG=OPND2_XB D=BYTES(PTYPE>>4) ->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=-1 %AND D=4 %ELSE D=16 %AND C=-8 LOAD(OPND2,C,2) EVALREG=OPND2_XB PARCHK: ! KEEP AUTO STACKING CORRECT C=LCELL_SNDISP+64 DSTORE(EVALREG,D,-1,C) 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=-1 %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 DUMPRX(LA,EVALREG,0,GLA,TCELL_SNDISP) EVALREG=NEST %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(OPND1_D&X'FFFF000F')) 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-4*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 LPUT(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 DUMPRX(LGR,-2,0,GLA,4*C); ! LOAD SST ENTRY %IF SWITEMSIZE=2 %THEN PRR(AR,D,D) %ELSE PRX(SLL,D,0,0,4) DUMPRX(LGR-32+8*SWITEMSIZE,NEST,NEST,D,0) DUMPRX(BC,15,CODER,NEST,0) REGS(NEST)_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 %IF OPND1_FLAG=DNAME %START; ! LHS IN LOCAL SPACE LOAD(OPND2,ACCR,1) TCELL==ASLIST(TAGS(OPND1_D)) DSTORE(EVALREG,16,TCELL_UIOJ>>4&15,TCELL_SLINK+OPND1_XTRA) %FINISHELSESTART LOADAD(OPND1,BREG) LOAD(OPND2,ACCR,1) PF1(ST,3,PC,MAPDES(7)) %FINISH %CONTINUE TRIPSW(43): ! POINTER ASSIGNMENT %IF OPND1_FLAG=DNAME %START; ! LOCAL PTR LOAD(OPND2,ACCR,1) TCELL==ASLIST(TAGS(OPND1_D)) DSTORE(EVALREG,8,TCELL_UIOJ>>4&15,TCELL_SLINK+OPND1_XTRA) %CONTINUE %FINISH LOADAD(OPND1,BREG) LOAD(OPND2,ACCR,1) PF1(ST,3,PC,MAPDES(6)) %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,EVALREG,0); ! THE RECORD BASE LOAD(OPND2,EVALREG,0); ! THE RELATIVE ACCESS %IF OPND2_XB&7>=2 %AND OPND2_XB>>4<7 %START;! DESC NOT YET IN DR TOPND=OPND2 TOPND_XB=TOPND_XB&X'F0' ! GET IN ACC(DESR,8,TOPND) %FINISH PUT(DESR,INCA,0,YES,OPND1) OPND1=OPND2 OPND1_XB=OPND1_XB!X'70'; ! EITHER (DESR) OR (DESR+B) %CONTINUE 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 D=OPND2_XB; ! THE LOWEST OF 4 GRS %IF CURRT_X1&1=0 %START; ! ARRAY MAPPING OPND1 IS BASE PRR(SR,D,D+1) LOAD(OPND1,D+1,2) PRR(AR,D,D+1) %FINISH %ELSE %START PUT(D,A,0,YES,OPND1) PUT(D+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 PRIMARY FORMAT ASSEMBLER C=XTRA&15 LOAD(OPND1,ACCR,0); ! PREPARE OPERAND ! PSORLF1(XTRA>>16,OPND1_XB&3!C,OPND1_XB>>4,OPND1_D) FORGETM(14) %CONTINUE TRIPSW(52): ! UCB2 TWO BYTE ASSEMBLER ! ALSO SECONDARY FORMAT INSTRNS %IF XTRA=0 %START ! PLANT(OPND1_D&X'FFFF'); ! ALLOWS *PUT AT LEAST %FINISH %ELSE %START D=OPND1_D ! PF2(XTRA>>16,D>>31,D>>30&1,D>>16&255,D>>8&255,D&255) %FINISH FORGETM(14) %CONTINUE TRIPSW(53): ! UCB3 TERTIARY ASSEMBLER LOAD(OPND1,ACCR,0) ! PF3(XTRA>>16,XTRA&15,OPND1_XB,OPND1_D) FORGETM(14) %CONTINUE TRIPSW(54): ! UCW ASSEMBLER WITH WORD OPERAND ! PBW(OPND1_D>>16,OPND1_D&X'FFFF') %CONTINUE TRIPSW(55): ! UCBW BYTE&WORD OPERAND ASSEMBLER ! PB2W(OPND1_D>>24,OPND1_D>>16&255,OPND1_D&X'FFFF') %CONTINUE TRIPSW(59): ! UCNAM ACCESS TO NAMES FROM U-C D=OPND1_D>>28 C=OPND1_D>>16&63; ! LEVEL JJ=OPND1_D&X'FFFF' %IF D=1 %THEN DFETCHAD(EVALREG,C,JJ) %ELSEIF D=2 %THEN %C DSTORE(EVALREG,2,C,JJ) %ELSE DFETCH(EVALREG,2,C,JJ) FORGETM(14) %CONTINUE STRES: CURRT_OPTYPE<-OPND1_PTYPE %IF CURRT_CNT>1 %AND CURRT_OPERN#LASS %AND CURRT_OPERN#AINDX %C %AND OPND1_FLAG=9 %START ! USED MORE THAN ONCE, IN A REG ! AND NOT ALREADY STORED C=BYTES(OPND1_PTYPE>>4&15) %IF CURRT_FLAGS&USE ESTACK=0 %START; ! DUPLICATE NOT LEFT IN ESTACK GET WSP(D,(C+3)>>2) DSTORE(EVALREG,C,CURRINF_RBASE,D) OPND1_FLAG=7 OPND1_D=CURRINF_RBASE<<16!D REGS(EVALREG)_CL=0 REGS(EVALREG)_USE=2 REGS(EVALREG)_INF1=OPND1_D %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(BASR,LOCAL BASE,0) LOCAL ADDR=CA SET USE(LOCAL BASE,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,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 %IF REG<0 %THEN REG=FIND REG(NEGREG(REG),0) %AND %C REQREG==REGS(REG) USE=LITCONST; INF=OPND_D %IF INF=0 %THEN PRR(SLR,REG,REG) %ELSE DUMPRX(X'41',REG,0,0,INF) ->LDED %FINISH %FINISH SW(1): SW1: ! LONG CONSTANT %IF TYPE=5 %THEN ->SCONST %IF PREC=7 %THEN KK=ADDR(WORKA_A(OPND_D)) %ELSE KK=ADDR(OPND_D) 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: REQREG_USE=USE REQREG_INF1=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 DUMPRX(LGR,-2,0,D,X) REGS(D)_CL=0 OPND_PTYPE=PREC<<4!TYPE OPND_FLAG=10; OPND_XB=NEST REGS(NEST)_CL=2 REGS(NEST)_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 DUMPRX(LGR,-2,0,DISPREG(TCELL_UIOJ>>4&15),D) OPND_XB=NEST REGS(NEST)_CL=2 REGS(NEST)_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=PREC<<4!TYPE 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) %RETURN SW(9): ! I-R IN A REGISTER %IF MODE=2 %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 %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: 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,I 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,KK,TYPE,X %SWITCH SW(0:10) PTYPE=OPND_PTYPE TYPE=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+4 %IF TYPE=5 %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 OPND=REFTRIP_OPND1 LOAD(OPND1,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(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,D,B,OP %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') ->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_D REGS(B)_CL=2 %IF X<0 %THEN X=0 DUMPM(LM,REG,WREG,B,X) REGS(B)_CL=0 ->LDED SW(5): ! INDIRECT VIA DICT SW(6): ! INDIRECT OFFSET SW(10): ! DEVELOPPED BD FORM ! NORMALLY ARRAY ELEMENTS ONLY LOADAD(OPND,WREG) ->STR %END %INTEGERFN SET DVREG(%INTEGER WHICH,DVBD,ANAME) !*********************************************************************** !* SELECT(USUALLY) AND SET UP A GENERAL REGISTER AS A BASE REGISTER * !* FOR A DOPEVECTOR IN ARRAY WHOSE HEAD B&D GIVEN * !*********************************************************************** %INTEGER I %RECORD(REGF)%NAME REG %IF WHICH<0 %START; ! ANY REG FIND USE(I,1,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 %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' DVPTYPE=XTRA>>16 DACC=-1; ! EL SIZE NOT KNOWN %IF DVPTYPE&X'C00'=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 * !* IMP ALLOWS EXPONENTS IN INTEGER EXPRESSIONS FROM 0-63 AND * !* IN REAL EXPRESSIONS FROM-255 TO +255 * !*********************************************************************** %INTEGER TYPEP,PRECP,WORK,C,INTREG,COUNT,RREG,LB,LLA,OP,P1,P2,WMASK,LVAL,OPCODE PTYPE=OPND1_PTYPE&255 TYPEP=PTYPE&7; PRECP=PTYPE>>4&15 %IF TYPEP=1 %START OPCODE=MR; WMASK=GRPAIR; LVAL=-1 %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 %FINISH ! ! IF EITHER OPERAND IS A FN IT HAS BEEN FETCHED TO A REGISTER ! SO 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. ! COUNT & INTREG CAN BE THE SAME REGISTER IF EXPONENT IS +VE ! 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 COUNT=INTREG ! ! GET '1' INTO WORK IN APPROPIATE FORM ! %IF TYPEP=1 %THEN PRX(LA,WORK+1,0,0,1) %ELSE %C DUMPRX(LDCODE(8+PRECP),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 ! OP=LTR COUNT=INTREG %IF TYPEP=2 %THEN OP=LPR %AND COUNT=FINDREG(GR0,1) PRR(OP,COUNT,INTREG) SET LOCAL BASE(LB,LLA) PRX(BC,8,LB,0,0); ! J(EXPONENT=0) END OF EXP ROUTINE P1=CA-2 ! ! IN CHECKING MODE PLANT CODE TO CHECK RANGE OF EXPONENT ! %IF PARM_OPT#0 %THEN %START %IF TYPEP=2 %THEN DUMPRX(X'59',COUNT,0,CODER,WORKA_PLABS(1)) %C %ELSE DUMPRX(X'55',COUNT,0,CTABLEREG,WORD CONST(63)) PPJ(2,7,NO) %FINISH C=CA PRR(OPCODE,REGCODE(WORK),REGCODE(RREG)) %IF TYPEP=1 %THEN %START PRX(SLDA,WORK,0,0,32) PRR(LR,WORK+1,WORK) %FINISH PRX(BCT,COUNT,0,LB,C-LLA) ! ! FOR REAL EXPONENTS CHECK IF NEGATIVE AND EVALUATE INVERSE ! %IF TYPEP=2 %THEN %START PRR(LTR,INTREG,INTREG) PRX(BC,2,LB,0,0); ! BP END OF EXP ROUTINE P2=CA-2 DUMPRX(LDCODE(8+PRECP),RREG,0,CTABLEREG,LONGCONST(X'4110000000000000')) %IF PRECP#7 %THEN %START PRR(DDR-MDR+OPCODE,RREG,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)) %FINISH ! ! ALL OVER. REAL RESULTS ARE IN FR WORK. INT RESULTS IN GR WORK+1 ! FREE AND FORGET ANY OTHER REGISTERS ! OPERAND USED(OPND1) %IF TYPEP=1 %THEN FREE AND FORGET(WORK) FREE AND FORGET(COUNT) %IF TYPEP=2 %THEN FREE AND FORGET(INTREG) EVALREG=WORK+2-TYPEP PLUG(1,P1,CA-LLA,2); ! LABEL AT END OF EXP ROUTINE PLUG(1,P2,CA-LLA,2) %IF TYPEP=2 %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=WTRIPNO 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=WTRIPNO 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 %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,U,I) !*********************************************************************** !* NOTE THAT THE USE OF REGISTER 'R' IS NOW 'U' & 'I' * !*********************************************************************** %RECORD(REGF)%NAME UREG UREG==REGS(REG) %IF UREG_CL>=0 %THEN UREG_USE=U %AND UREG_INF1=I %C %AND UREG_AT=WTRIPNO %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 TYPE, USE, INF) !*********************************************************************** !* SEARCHES FOR A REGISTER WITH THE REQUIRED CONTENTS * !*********************************************************************** %INTEGER I, L, U, J %RECORD(REGF)%NAME TREG %CONSTBYTEINTEGERARRAY FMAP(1:15)=1,2,3,4,5,6,7,8,9,15,0,16,17,18,19; %IF TYPE=2 %THEN L=12 %AND U=15 %ELSE L=1 %AND U=11 %CYCLE J=L,1,U I=FMAP(J) TREG==REGS(I) %IF TREG_PRIMUSE=USE %AND %C (TREG_INF1=INF %OR INF=-1) %THEN ->HIT %IF TREG_SECUSE=USE %AND(TREG_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 CODE,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=(BSIZE+3)//4 NREGS=WSIZE %IF REG>16 %THEN NREGS=(NREGS+1)>>1 %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 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' REGS(REG)_CL=-1 CALL COMING(8) DSTORE(REG,4,-1,68) REGS(REG)_CL=0 DUMPRX(LA,-1,0,0,N) DSTORE(NEST,4,-1,64) DUMPM(STM,4,14,WSPR,16) DUMPM(LM,CODER,EPREG,GLA,KNOWN XREF(4)) PRR(BASR,15,14) CALL MADE %IF 1<0 %THEN DUMPRX(CODE,MASK&15,0,CODER,VAL) %ELSESTART J=CA FIND USE(REG,1,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,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=BAS %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=NEST OPND_D=0 REGS(NEST)_CL=TEMPBASE REGS(NEST)_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 OPND_FLAG=10 %START X=OPND_XB>>4 B=OPND_XB&15 REG==REGS(X) %IF X>0 %AND REG_CL=TEMPBASE %THEN REG_CL=0 REG==REGS(B) %IF B>0 %AND REG_CL=TEMPBASE %THEN REG_CL=0 %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 PREC=5 %AND OPND_PTYPE=X'51' 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_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' PRX(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,1,FOURKMULT,PN);! LOOK FOR 4K MULTIPLE ->REND %IF INDEX>0 SET USE(J, 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 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 %INTEGERFN EXECUTESS(%INTEGER OPCODE,B1,D1,B2,D2) !*********************************************************************** !* PUTS A ZERO LENGTH STORE TO STORE INSTRUCTION INTO CONSTANTS * !* AND RETURNS ITS DIPLACEMENT FOR EXECUTING WITH 'EX' * !*********************************************************************** %INTEGER I,J,K %IF D1>4095 %THEN ADJUST INDEX(0,B1,D1) %IF D2>4095 %THEN ADJUST INDEX(0,B2,D2) I=OPCODE<<24!B1<<12!D1 J=B2<<28!D2<<16 STORE CONST(K,6,ADDR(I)) %RESULT=K %END %ROUTINE NOTE ASSMENT(%INTEGER REG, ASSOP, VAR) !*********************************************************************** !* 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 %RETURN %IF VAR<=0 %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 WREG==REGS(REG) WREG_USE=ADDROF WREG_INF1=VAR %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 %START 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 %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