! ! Warning this module has the revised triples spec. ! ! In first attempt at Triple Imp considerable use was made of constant operands ! to pass information from Pass2 to GEN. Although for specialised operations like ! passing Labels this still applies, this adhocery has caused problems with arrays ! and pointers particularly in mapped records. The operands for four triples ! have thus been redefined in a more standard way. ! ! GETPTR X1 is now (ptype of passed)<<16! DIMENSION ! Opnd2 is either a 32 bit const with the size (ACC) as value or ! the ptr or arrayhead as normal operand. ! ! VMY X1 is now dim<<28!maxdim<<24!array name(where known) ! Opnd2 is either a 32 bit const with DV offset into const area or ! the arrayhead as a standard operand ! ! AINDX X1 is ELSIZE<<20 !spare ! Opnd2 is arrayhead as standard operand ! NOTE:- The Operands have been swopped for consistency with norm. ! ! BADJ X1 is arrayptype<<16!no of Dimensions (latter in case of backward dvs) ! Opnd2 exactly as for VMY ! %INCLUDE "ERCC07:ITRIMP_HOSTCODES" %CONSTINTEGER HOST=AMDAHL %CONSTINTEGER TARGET=AMDAHL %CONSTINTEGER FOURKTDISP=0 %INCLUDE "ERCC10:OPOUTS" ! %CONSTINTEGER LGR=X'58',AND=X'54',ICP=X'59'; ! VARIANT MNEMONICS %IF TARGET=IBM %THENSTART %OWNINTEGER BALCODE=BAL %FINISHELSESTART %OWNINTEGER BALCODE=BAS %FINISH %CONSTINTEGER MARGIN=512; ! MARGIN FOR ADRESSABILITY %CONSTINTEGER MAXREG=19; ! FOR DECLARING REGISTER ETC %CONSTINTEGER CODER=12 %CONSTINTEGER WSPR=11 %CONSTINTEGER GLAREG=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'000F0019'; ! ANY GR FROM 0-15 %CONSTINTEGER GR1=X'001A0023'; ! ANY GR BAR GR0 %CONSTINTEGER FR0=X'00240027'; ! ANY FR %CONSTINTEGER GRSAFE=X'0028002D'; ! ANY GR SAFE AGAINT RT CALL %CONSTINTEGER GRPAIR=X'012E0032' %CONSTINTEGER FRPAIR=X'01330034' %CONSTINTEGER GRSEQ=X'8135003D' %CONSTINTEGER GRQUAD=X'833E0044' %CONSTINTEGER ANYGR=-1,ANYGRBAR0=-2,ANYFR=-3,ANYSAFEGR=-4, ANYGRPAIR=-5,ANYFRPAIR=-6,ANY2SEQ=-7,ANY4SEQ=-8 %CONSTINTEGERARRAY NEGREG(-8:-1)=GRQUAD,GRSEQ,FRPAIR,GRPAIR,GRSAFE,FR0,GR1,GR0 ! ! PARAMETERISE THE REGISTER USESES ! %CONSTINTEGER IRESULT=1,TEMPBASE=2,RTPARAM=3,NAMEBASE=4,LITCONST=5, TABCONST=6,ADDROF=7,BASEOF=8,LOCALVAR=9,LOCALTEMP=10, FOURKMULT=11,LABFOURK=12,BASEREG=13,PERMFOURK=14,DVBASE=15, STRWKAREA=16 %CONSTBYTEINTEGERARRAY REGWORDS(0:127)=X'11'(96){PRECS 0-5}, X'11',X'22',X'12',X'11'(13){PREC=6}, X'11',X'44',X'24',X'11'(13){PREC=7} ! ABOVE IS NO OF REGS<<4!NO OF 32 BIT WORS %CONSTBYTEINTEGERARRAY REGCODE(0:MAXREG)= 0,1,2,3,4,5,6,7,8,9, 10,11,12,13,14,15,0,2,4,6 %CONSTBYTEINTEGERARRAY DISPREG(-1:15)=WSPR,GLAREG,10,9,8,7,6,5,4,3,0(5),14,0;{unset names ->15} %CONSTBYTEINTEGERARRAY GRMAP(0:68)=0,1,2,3,15,16,17,18,19,4,5,6,7,8,9, {gr0 15:25} 15,1,0,9,8,7,6,5,4,3,2, {gr1 26:35} 1,15,4,5,6,7,8,9,2,3, {fr0 36:39} 16,17,18,19, {grsafe 40:45} 4,5,6,7,8,9, {grpair 46:50} 0,2,4,6,8, {frpair 51:52} 18,16, {grseq 53:61} 0,1,2,3,4,5,6,7,8, {grquad 62:68} 0,1,2,3,4,5,6 %CONSTBYTEINTEGERARRAY LDCODE(0:15)=IC(4),LH,LGR,LM,LM,LE(5),LE,LD,LD %CONSTBYTEINTEGERARRAY STCODE(0:15)=STC(4),STH,ST,STM,STM,STE(5),STE,STD,STD %CONSTBYTEINTEGERARRAY WHICHREG(0:15)=0(3),-ANYGR(3),-ANYGRPAIR,-ANY4SEQ, 0(5),-ANYFR(2),-ANYFRPAIR ! %INCLUDE "ERCC07:TRIPCNSTS" %INCLUDE "ERCC07:ITRIMP_TFORM2S" !%INCLUDE "ERCS20:ib8.SPECS" %include "ercc07:putspecs" %IF HOST=EMAS %START %RECORDFORMAT REGF(%INTEGER CL,CNT,AT,(%INTEGER USE %ORHALF SECUSE,PRIMUSE), %INTEGER INF1,INF2,LINK) %ELSE %RECORDFORMAT REGF(%INTEGER CL,CNT,AT,(%INTEGER USE %ORSHORT SECUSE,PRIMUSE), %INTEGER INF1,INF2,LINK) %FINISH %OWNINTEGER CONSTHOLE,PROFDATA,OLDLINE,HALFHOLE %OWNINTEGERNAME CA,GLACA %OWNINTEGER FPPTR=0,FPHEAD=0,LASTPARREG=1,BOOTDEPTH=04 %OWNINTEGER MAX4KMULT=0,GLABEL=X'7FFF',UNASSOFFSET=0,SWITEMSIZE=0 %OWNINTEGER USINGR=12,USINGAT=0; ! REMEMBERS ASSEMBLER USINGS %OWNRECORD (LISTF) %ARRAYNAME ASLIST %OWNINTEGERARRAY COFFSET(0:31) %OWNINTEGERARRAYNAME CTABLE %OWNINTEGERARRAYNAME TAGS %EXTRINSICINTEGERARRAY CAS(0:12) %EXTRINSICRECORD (WORKAF) WORKA %EXTRINSICRECORD (PARMF) PARM %OWNRECORD (REGF) %ARRAY REGS(0:MAXREG) %CONSTINTEGER MAXKXREF=6 %OWNINTEGERARRAY KXREFS(0:MAXKXREF) %CONSTSTRING (11) %ARRAY KXREFNAME(0:MAXKXREF)="S#STOP","S#NDIAG", "S#ILOG","S#IEXP","S#IOCP", "ICL9CEAUXST","S#PPROFILE"; %CONSTINTEGERARRAY KXREFPWORD(0:MAXKXREF)=0,X'00040010', X'00010008'(2),X'00020008', -1(*) %EXTERNALSTRING (255) %FNSPEC PRINTNAME(%INTEGER N) %EXTERNALROUTINESPEC FLAGAND FOLD(%RECORD (TRIPF) %ARRAYNAME T) %STRING (255) %FNSPEC UCSTRING(%STRING (255) S) %EXTERNALROUTINESPEC FAULT(%INTEGER I,J,K) %ROUTINESPEC PRINT USE %EXTERNALROUTINESPEC PUSH(%INTEGERNAME CELL, %INTEGER S1,S2,S3) %ROUTINESPEC STORECONST(%INTEGERNAME D, %INTEGER L,AD) %INTEGERFNSPEC WORD CONST(%INTEGER VAL) %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) %EXTERNALINTEGERFNSPEC CHANGE CONTEXT %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(0:16)=0,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=10; ! 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 ! %CONSTSTRING (15) STKTOP="EMAS3TOPSTK" %CONSTINTEGER FIXEDGLALEN=56 %OWNINTEGERARRAY FIXED GLA(0:FIXEDGLALEN>>2-1)=M'IMPG',0, 0(*) ! 0-5 as per standards ! 6 addr(const area) ! 7 addr(current stack limit) ! 8&9 unused ! 10 -13 ndiags ref ! %ROUTINE CPINIT !*********************************************************************** !* PERFORMS ANY NECESSARY TARGET DEPENDANT INITIALISING * !*********************************************************************** %INTEGER I,J,K %STRING (63) HD TAGS==WORKA_TAGS FPPTR=0; FPHEAD=0 GLABEL=X'7FFF'; ! RESET FOR WHEN COMPILER NOT RELOADED HD=" ERCC IBMImp80 Compiler Release ".TOSTRING(WORKA_RELEASE+'0')." Version ". %C WORKA_LADATE PINITIALISE(-1 {STRING},WORKA_RELEASE,ADDR(HD)); ! OPEN OBJECT FILE %IF HOST=EMAS %AND PARM_BITS1&1 {QUOTES}#0 %THEN BALCODE=BAL %WHILE WORKA_INCLHEAD>0 %CYCLE POP(WORKA_INCLHEAD,I,J,K) HD<-"Included : """.STRING(I)."""" PHISTORY(8,ADDR(HD)) %REPEAT %END %STRING (255) %FN UCSTRING(%STRING (255) S) %INTEGER CH,L,I L=LENGTH(S) %FOR I=1,1,L %CYCLE CH=CHARNO(S,I) %IF 96K+1) %AND (HALFHOLEK+1) %THEN D=4*K %ANDRETURN %IF CTABLE(K)<<16=C1&X'FFFF0000' %AND C1&X'FFFF'=CTABLE(K)>>16 %AND %C CTABLE(K+1)>>16=C2 %AND (CONSTHOLEK+1) %AND (HALFHOLEK+1) %THEN D=4*K+2 %ANDRETURN %REPEAT %FINISHELSESTART J=CONSTPTR-LP %WHILE K<=J %CYCLE %IF CTABLE(K)=C1 %AND CTABLE(K+1)=C2 %AND (CONSTHOLE=K+LP) %AND %C (HALFHOLE=K+LP) %START %IF L=8 %OR (CTABLE(K+2)=C3 %AND CTABLE(K+3)=C4) %THEN D=4*K %ANDRETURN %FINISH K=K+2 %REPEAT %FINISH %IF L=2 %START %IF HALFHOLE#0 %THENSTART CTABLE(HALFHOLE)=CTABLE(HALFHOLE)!(C1>>16) D=4*HALFHOLE+2 HALFHOLE=0 %RETURN %FINISH %IF CONSTHOLE#0 %START CTABLE(CONSTHOLE)=C1 HALFHOLE=CONSTHOLE CONSTHOLE=0 D=4*HALFHOLE %RETURN %FINISH CTABLE(CONST PTR)=C1 HALFHOLE=CONST PTR D=4*HALFHOLE CONST PTR=CONST PTR+1 %RETURN %FINISH %IF L=4 %AND CONSTHOLE#0 %START CTABLE(CONSTHOLE)=C1 D=4*CONSTHOLE CONSTHOLE=0 %RETURN %FINISH %IF L=6 %START %IF 0>16 CTABLE(CONSTHOLE)=C1<<16!C2>>16 D=4*HALFHOLE+2 HALFHOLE=0; CONSTHOLE=0 %RETURN %FINISH %IF 0>16 CTABLE(CONSTPTR)=C1<<16!C2>>16 D=4*HALFHOLE+2 HALFHOLE=0 CONST PTR=CONST PTR+1 %RETURN %FINISH CTABLE(CONST PTR)=C1 CTABLE(CONST PTR+1)=C2 HALFHOLE=CONST PTR+1 D=4*CONST PTR CONST PTR=CONST PTR+2 %RETURN %FINISH %IF L>4 %AND CONST PTR&1#0 %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 %AND CTABLE(CONSTPTR+3)=C4 CONST PTR=CONST PTR+LP %IF CONST PTR>WORKA_CONST LIMIT %THEN FAULT(102,WORKA_WKFILEK,0) %END %ROUTINE STORE STRING(%INTEGERNAME D, %STRINGNAME S) !*********************************************************************** !* PUT THE STRING CONSTANT "S" INTO THE CONSTANT TABLE * !* A CHECK IS MADE TO SEE IF THE CONSTANT HAS ALREADY * !* BEEN INSERTED IN WHICH CASE THE OLD COPY IS REUSED * !*********************************************************************** %INTEGER J,K,LP,L %INTEGERNAME CONST PTR CONST PTR==WORKA_CONST PTR K=WORKA_CONST BTM L=LENGTH(S) LP=1+L//4 %IF L=1 %START K=256!CHARNO(S,1) D=SHORT CONST(K) %RETURN %FINISH J=CONSTPTR-LP %FOR K=1,1,J %CYCLE %IF S=STRING(ADDR(CTABLE(K))) %and (K>consthole %or k+lp-1halfhole %or k+lp-10 %START STRING(ADDR(CTABLE(CONSTHOLE)))=S D=4*CONSTHOLE CONSTHOLE=0 %RETURN %FINISH 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 %INTEGERFN KWCONSTS(%INTEGER WHICH) !*********************************************************************** !* PUTS CERTAIN KNOWN WORD CONSTANTS INTO THE CONSTANT TABLE ON * !* DEMAND AND REMEMBERS THEIR POSN TO AVOID SEARCHING * !*********************************************************************** %CONSTINTEGERARRAY SCS(0:4)= X'80000000',255, X'FFFFFFFF',1, X'41100000' %INTEGER K K=COFFSET(WHICH) %RESULT=K %UNLESS K=0 STORE CONST(K,4,ADDR(SCS(WHICH))) COFFSET(WHICH)=K %RESULT=K %END %INTEGERFN KLCONSTS(%INTEGER WHICH) !*********************************************************************** !* PUTS CERTAIN KNOWN LONG CONSTANTS INTO THE CONSTANT TABLE ON * !* DEMAND AND REMEMBERS THEIR POSN TO AVOID SEARCHING * !*********************************************************************** %CONSTINTEGERARRAY SCS(0:21)= %C 0, 0, X'4E000000', 0, X'48800000', 0, X'40800000', 0, X'50800000', 0, X'51880000', 0, X'5C000000', X'80', X'41100000', 0, X'4E000000', X'80000000', X'43000000',8, 0,x'7FFFFFFF' %INTEGER K K=COFFSET(WHICH+16) %RESULT=K %UNLESS K=0 STORE CONST(K,8,ADDR(SCS(2*WHICH))) COFFSET(WHICH+16)=K %RESULT=K %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 %CONTINUEIF 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' * !* RATHER NOTTED ON IBM AS ONE CANNOT RESTORE A DROPPED REG * !*********************************************************************** %INTEGER I,R,USE,INF,AT,DROPMASK %RECORD (REGF) %NAME REG DROPMASK=0 %CYCLE I=0,1,MAXREG %UNLESS 10<=I<=14 %THENSTART REG==REGS(I) %IF REG_USE=BASEREG %THEN DROPMASK=DROPMASK!(1<>8; USE=I&255 REG==REGS(R) %IF USE#BASEREG %THEN REG_USE=USE %AND REG_INF1=INF %ELSESTART %IF REG_USE=BASEREG %AND INF=REG_INF1 %THEN DROPMASK=DROPMASK&(\(1<0 %CYCLE LCELL==ASLIST(HEAD) R=LCELL_S3>>8 U=LCELL_S3&255 REG==REGS(R) %IF (REG_PRIMUSE=U %AND REG_INF1=LCELL_S1) %OR (REG_SECUSE=U %AND %C REG_INF2=LCELL_S1) %START HEAD==LCELL_LINK %IF REG_AT>LCELL_S2 %THEN LCELL_S2=REG_AT ! TAKE MOST RECENT VERSION OF AT %FINISHELSE POP(HEAD,S1,S2,S3) %REPEAT %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) %RETURNIF PARM_INHCODE#0 PDBYTES(AREA,PTR,L,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) %RETURNIF PARM_INHCODE#0 PDPATTERN(AREA,PTR,REP,L,AD) %unless area=9; ! zgst alredy zeroed PTR=PTR+REP*L %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 %THENSTART KK=CAS(DAREA) PSETOPD(JJ,0,MVI<<8!((KK>>8)&255)) PSETOPD(JJ,2,MVI<<8!(KK&255)) %FINISHELSESTART PD4(Q,JJ,KK!CAS(DAREA)) %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 (31) 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 GLACA=(GLACA+3)&(-4) RES=GLACA %IF TYPE=5 %THEN PD4(2,GLACA,ACC) %AND GLACA=GLACA+4 PD4(2,GLACA,OPND_D) GLACA=GLACA+4 %IF LITL=3 %START; ! EXTRINSICS ARE NAMES PDXREF(ACC,2,GLACA-4,XNAME); ! RELOCATE BY EXTERNAL %FINISH ->END %FINISH RL=BYTES(PREC) %IF TYPE=5 %THEN RL=4 %IF TYPE=3 %THEN RL=8 %IF RL>8 %THEN RL=8 GLACA=(GLACA+RL-1)&(-RL); ! ROUND TO RL RES=GLACA; %IF TYPE=3 %OR (TYPE=5 %AND OPND_D=0) %START PDPATTERN(2,RES,ACC,1,ADDR(OPND_D)+3) GLACA=GLACA+ACC ->END %FINISH %IF TYPE=5 %THENSTART PDBYTES(2,GLACA,ACC,ADDR(WORKA_A(OPND_D))) GLACA=GLACA+ACC %FINISHELSESTART %IF PREC=3 %THEN PDBYTES(2,GLACA,1,ADDR(OPND_D)+3) %IF PREC=4 %THEN PDBYTES(2,GLACA,2,ADDR(OPND_D)+2) %IF 5<=PREC<=6 %THEN PD4(2,GLACA,OPND_D) %IF PREC=6 %THEN PD4(2,GLACA+4,OPND_XTRA) %IF PREC=7 %THEN PDBYTES(2,GLACA,16,ADDR(WORKA_A(OPND_D))) GLACA=GLACA+BYTES(PREC) %FINISH END: ! NOTE ENTRYT IF EXTERNAL %IF LITL=2 %THEN PDATAENTRY(XNAME,2,ACC,RES) %RESULT=RES %END %EXTERNALINTEGERFN POWNARRAYHEAD(%INTEGER PTYPE,J,LB,SIZE,AOFFSET,AAREA,DVOFFSET, %STRING (31) XNAME) !*********************************************************************** !* SOME PARAMETERS ARE ONLY REQUIRED FOR CREATING DESCRIPORS ON * !* 2900 ARCHITECTURE. THESE ARE REDUNDANT HERE * !*********************************************************************** %INTEGER LITL,RES,AHW0,AHW1,AHW2,AHW3,PREC,TYPE XNAME=UCSTRING(XNAME) TYPE=PTYPE&7 PREC=PTYPE>>4&15 AHW0=AOFFSET-LB*CTABLE(DVOFFSET>>2+2) AHW1=AOFFSET AHW2=DVOFFSET AHW3=CTABLE(DVOFFSET>>2+2+3*J); ! THE RELEVANE STRIDE GLACA=(GLACA+3)&(-4) RES=GLACA GLACA=GLACA+16 LITL=PTYPE>>14&3 %IF LITL=3 %START; ! EXTRINSIC ARRAYS PD4(2,RES,AHW0) PD4(2,RES+4,AHW1) PDXREF(SIZE,2,RES,XNAME) PDXREF(SIZE,2,RES+4,XNAME); ! RELOCATE BY EXTERNAL %FINISHELSESTART %IF AAREA=0 %START PD4(2,RES,AHW0) PD4(2,RES+4,AHW1) %ELSE PD4(2,RES,0) PD4(2,RES+4,0) RELOCATE(RES,AHW0,AAREA) RELOCATE(RES+4,AHW1,AAREA) %FINISH %FINISH PD4(2,RES+8,0) RELOCATE(RES+8,AHW2,CAREA); ! RELOCATE DV PTR PD4(2,RES+12,AHW3) %IF LITL=2 %THEN PDATAENTRY(XNAME,AAREA,SIZE,AOFFSET) %RESULT=RES %END %ROUTINE GXREF(%STRING (31) NAME, %INTEGER MODE,XTRA,AT) !*********************************************************************** !* ASK IPUT TO ARRANGE FOR A TRIPLE WORD AT 'AT' IN THE GLA * !* TO CONTAIN A DESCRIPTOR FOR NAME 'NAME'. * !* MODE=0 "DONT CARE" XREF * !* MODE=1 SYSTEM CODE XREF * !* MODE=2 EXTERNAL CODE XREF * !* MODE=3 DYNAMIC CODE XREF * !* FOR MODES 0-3 XTRA IS PARAMETER CHECKING WORD * !*********************************************************************** NAME=UCSTRING(NAME) %IF NAME="S#ILOG" %AND KXREFS(2)=0 %THEN KXREFS(2)=AT %IF NAME="S#IEXP" %AND KXREFS(3)=0 %THEN KXREFS(3)=AT AT=PXNAME(MODE//3 {1 FOR DYNAMIC ELSE 0},NAME,AT) %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 %STRING (31) TNAME TNAME<-NAME Z1=0; Z2=0; Z3=0; Z4=XTRA GLACA=(GLACA+3)&(-4) PDBYTES(2,GLACA,16,ADDR(Z1)); ! 3 ZERO WORDS+PARAMETER WORD AT=GLACA GLACA=GLACA+16 GXREF(TNAME,MODE,XTRA,AT) %END %INTEGERFN KNOWN XREF(%INTEGER N) %INTEGER D %RESULT=KXREFS(N) %UNLESS KXREFS(N)=0 CXREF(KXREFNAME(N),0,KXREFPWORD(N),D) KXREFS(N)=D %RESULT=D %END %EXTERNALROUTINE RELOCATE(%INTEGER GLARAD,VALUE,AREA) !*********************************************************************** !* PLANTS A WORD IN THE GLA (IF GLARAD<0) AND ARRANGES TO * !* RELOCATE IT RELATIVE TO AN AREA(CODE=1,GLA=2,CST=4,GST=5,CNTS=6) * !*********************************************************************** PFIX(2,GLARAD,AREA,VALUE) %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 "," ADDR OF ", " BASE OF "," LOCAL VAR ", " LOCALTEMP "," 4K MULT ", " 4K FORLAB "," BASE REG ", " 4K FOR EPI"," DV BASE ", " STRWKAREA " %CONSTSTRING (11) %ARRAY STATE(-1:3)= %C " LOCKED "," FREE ", " I-RESULT "," TEMPORARY ", " RT-PARAM " %ROUTINESPEC OUT(%INTEGER USE,INF) %INTEGER I,USE,JJ %RECORD (REGF) %NAME REG %CYCLE I=0,1,MAXREG REG==REGS(I) %IF REG_CL<0 %AND 10<=I<=14 %THENCONTINUE %IF REG_CL!REG_USE#0 %OR REG_CNT>0 %START USE=REG_USE PRINTSTRING(REGNAMES(I).STATE(REG_CL)) WRITE(REG_CNT,1) WRITE(REG_AT,2) OUT(USE&255,REG_INF1) %IF USE>>16#0 %THEN PRINTSTRING(" ALSO ") %AND OUT(USE>>16,REG_INF2) %IF 1<=REG_CL<=2 %START %UNLESS REG_LINK>0 %THEN PRINTSTRING(" ???") %ELSESTART SPACE %AND PRHEX(INTEGER(JJ),8) %FOR JJ=REG_LINK-16,4,REG_LINK+8 %FINISH %FINISH NEWLINE %FINISH %REPEAT %RETURN %ROUTINE OUT(%INTEGER USE,INF) %CONSTINTEGER LNMASK=B'1000001110000000' %CONSTINTEGER UNMASK=B'0000001110000000' %IF USE&128#0 %THEN PRINTSYMBOL('*') %AND USE=USE&127 %ELSE SPACE PRINTSTRING("USE = ".USES(USE)) %IF LNMASK&1<4096 %THEN %C PRHEX(INF,8) %ELSE WRITE(INF,1) %IF UNMASK&1<>16#0 %THEN %C PRINTSTRING(" MODBY ") %AND PRINTSTRING(PRINTNAME(INF>>16)) %END %END %EXTERNALROUTINE IMPABORT NEWLINE PLINEDECODE PRINTSTRING(" **************** IMPABORT ***************** IMPABORT *******") WRITE(WORKA_LINE,5) NEWLINE PRINT USE %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 MAX4KMULT=WORKA_ARTOP//4096 %IF PARM_CHK#0 %THEN MAX4KMULT=2*MAX4KMULT MAX4KMULT=MAX4KMULT+7 %IF MAX4KMULT<10 %THEN SWITEMSIZE=2 %ELSE SWITEMSIZE=4 CPINIT; ! INITIALISE CODE PLANTING ASLIST==ALIST CA==CAS(1) GLACA==CAS(2) CA=128+4*max4kmult; ! allow for preamble etc GLACA=FIXEDGLALEN HALF HOLE=0; OLD LINE=-1 CONST HOLE=0 CTABLE==WORKA_CTABLE PD4(DAREA,0,X'C2C2C2C2') CAS(DAREA)=4 %CYCLE I=0,1,31 COFFSET(I)=0 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(GLAREG)_CL=-1 REGS(CTABLEREG)_CL=-1 USINGR=12; USINGAT=0 BOOTDEPTH=0 ! ! GENERATE THE TABLE OF 4K MULTIPLES ! PCODEWORD(4096*I) %FOR I=0,1,MAX4KMULT ! ! GENERATE THE FIXED-FLOAT CONSTANTS THAT MAY BE NEEDED ! WORKA_CONST PTR=1 WORKA_CONST BTM=0 I=KWCONSTS(3); ! ENSURE F'1' IS IN CINST TABLE FOR EXP %IF PARM_CHK#0 %START UNASS OFFSET=8 CTABLE(2)=UNASSPAT CTABLE(3)=UNASSPAT WORKA_CONST PTR=4 %FINISH I=KWCONSTS(1); ! ensure F'255' is in ctable for dumprx ! ! 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 ! ! STM 4,14,16(11) !sideentry for call within event block ! 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) ! LM CODER,EPREG,40(13) MDIAG ENTRY POINT ! L 15,64(11) ! BCR 15,EPREG !CHECK La 2,64(1) ! CR 2,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 ! PLABEL(GLABEL) WORKA_PLABS(2)=GLABEL; GLABEL=GLABEL-1 PIX RS(STM,4,14,11,16) PLABEL(GLABEL) WORKA_PLABS(1)=GLABEL; GLABEL=GLABEL-1 PIX RX(ST,15,0,11,64) PIX RS(STM,0,1,11,72) PIX RR(LR,0,10) %CYCLE I=9,-1,5 PIX RR(LR,1,I) PJUMP(BALCODE,GLABEL-1,LINKREG,0) %REPEAT K=GLABEL; GLABEL=GLABEL-1 PLABEL(K) PIX RX(ST,0,0,11,68) PIX RS(LM,CODER,EPREG,GLAREG,KNOWN XREF(1)) PIX RX(LGR,15,0,11,64) PIX RR(BCR,15,EPREG) PLABEL(GLABEL) GLABEL=GLABEL-1 PIX RX(la,2,0,1,64) PIX RR(CR,2,11) PJUMP(BC,K,2,0) PIX RR(CR,1,0) PJUMP(BC,K,12,0) PIX RX(ICP,1,0,1,44) PJUMP(BC,K,7,0) PIX RR(LR,0,1) PIX RR(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 %THENSTART PLABEL(GLABEL) WORKA_PLABS(3)=GLABEL; GLABEL=GLABEL-1 PIX RS(STM,4,0,16,11) PIX RS(LM,CODER,EPREG,GLAREG,KNOWN XREF(5)) PIX RR(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 ! GR2 & 3 may contain array head and must be saved ! ! ! 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 ! ! sr 0,1 lengtn for the fill ! ar 1,11 place for fill to start ! stm 2,3,0(1) save 2 & 3 in first filled words ! l 2,28(gla) get stack limit ! c 11,0(2) ! bc 12,ok enough stack space gr is workreg ! la 0,X'201' ! bc 15,plabs(2) stop on excess stack !ok la 11,7(11) ! la 3,8 ! lcr 3,3 ! nr 11,3 ! stack top to d-w boundary ! mvc 0(8,11),0(1) move saved word ti stack after check ! lr 2,1 valid soyrce address for move ! LR 1,0 TO CORRECT PLACE ! LR 0,2 ! LA 3,UNASSPAT&255 ! SLL 3,24 ! MVCL 0,2 ! lm 2,3,0(11) restore 2&3 ! BCR 15,LINKREG %IF PARM_CHK=1 %THENSTART; ! ONLY REQUIRED WITH CHKING PLABEL(GLABEL) WORKA_PLABS(4)=GLABEL; GLABEL=GLABEL-1 PIX RR(SR,0,1) PIX RR(AR,1,WSPR) PIX RR(LR,WSPR,1) PIX RR(AR,WSPR,0) PIX RS(STM,2,3,1,0) PIX RX(LGR,2,0,GLAREG,28) PIX RX(ICP,WSPR,0,2,0) PJUMP(BC,GLABEL,12,3) PIX RX(LA,0,0,0,x'201') PIX RR(LR,WSPR,1) PJUMP(BC,WORKA_PLABS(2),15,3) PLABEL(GLABEL) GLABEL=GLABEL-1 PIX RX(LA,WSPR,0,WSPR,7) PIX RX(LA,3,0,0,8) PIX RR(LCR,3,3) PIX RR(NR,WSPR,3) PIX SS(MVC,0,8,WSPR,0,1,0) PIX RR(LR,2,1) PIX RR(LR,1,0) PIX RR(LR,0,2) PIX RX(LA,3,0,0,UNASSPAT&255) PIX RS(SLL,3,0,0,24) PIX RR(MVCL,0,2) PIX RS(LM,2,3,WSPR,0) PIX RR(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,X'602',0) %IF PARM_OPT#0; ! ARRAY BOUND CHECK ERR EXIT(14,x'101',0) %IF PARM_OPT#0; ! integer oflow from int-intpt %IF PARM_PROF#0 %THENSTART; ! ALLOCATE PROFILE COUNT AREA PROFDATA=GLACA write(worka_line,4) PD4(2,GLACA,WORKA_LINE) GLACA=GLACA+4 %CYCLE I=0,1,WORKA_LINE PD4(2,GLACA,0) GLACA=GLACA+4 %REPEAT WORKA_LINE=0 %FINISH %RETURN %ROUTINE ERR EXIT(%INTEGER LAB,ERRNO,MODE) !*********************************************************************** !* MODE=0 FOR DUMMY(ZERO) XTRA - MODE=1 XTRA IN GR1 * !*********************************************************************** PLABEL(GLABEL) WORKA_PLABS(LAB)=GLABEL; GLABEL=GLABEL-1 %IF MODE=0 %THEN PIX RR(SR,1,1) PIX RX(LA,0,0,0,ERRNO) PJUMP(BC,WORKA_PLABS(2),15,0) %END %END %EXTERNALROUTINE EPILOGUE(%INTEGER STMTS) !*********************************************************************** !* PLANT ANY SUBROUINES THAT HAVE BEEN REQUIRED DURING * !* THE CODE GENERATION PHASE * !*********************************************************************** %INTEGER DISP %ROUTINESPEC LONGOP(%INTEGER OP) %ROUTINESPEC FILL(%INTEGER LAB) ! ! STRING RESOLUTION SUBROUTINE ! ON ENTRY GR0 HAS ADDRESS OF WK AREA HOLDING ! W1(GR2) HAS ADDRESS OF ORIGINAL STRING ! W2(GR3) BYTE0 HAS ORIGINAL LENGTH OF LHS ! BYTE1 HAS BYTES USED UP IN PREV RESOLUTIONS. ! BYTES 2&3 HAVE MAX LENGTH OF FRAGMENT STRING ! W3(GR4) HAS ZERO OR STRINGNAME TO HOLD FRAGMENT ! W4(GR5) HAS ADDRESS OF RESOLUTION EXPRESSION(READ ONLY) ! ! ON EXIT RESULT IS SET BY CC AND W2 UPDATED. NO OTHER EFFECTS ! EXCEPT POSSIBLY STORING INTO FRAGMENT W3 ! ! STM 1,10,4(WSPR) LOTS OF REGISTERS NEEDED ! LR 1,0 NOW PICK UP W1-4 ! SR 0,0 FOR VARIOUS ICS LATER ! LM 2,5,0(1) ! BASR 9,0 BASE REGISTER COVER VIA 9 ! CLI 5(1),0 FIRST ENTRY ? ! BC 7,NOT FIRST 14(9) ! MVC 4(1,1),0(2) COPY ORIGINAL LENGTH !NOTFIRST ! WORK OUT NO OF VALID COMPARISONS ! SR 6,6 ! IC 6,4(1) ORIGINAL LENGTH ! IC 0,5(1) ! SR 6,0 MINUS BYTES USED ! SR 7,7 ! IC 7,0(5) LENGTH OF EXPRESSION ! SR 6,7 ! BL RESFAIL 74(9) NOT ENOUGH LENGTH ! LA 6,1(6) EQUAL LENGTHS = 1 VALID COMP ! LTR 7,7 ! BC 8,NULL RES 150(9) RESOLVING FOR NULL STRING ! BCTR 7,0 FOR EXECUTING ! IC 0,5(1) ! AR 2,0 POINT TO START SEARCH -1 ! LR 10,2 SAVE THIS FOR STORING FRAGMNT !NRLOOP ! EX 7,COMP 82(9) COMPARE ! BC 8,NROK 88(9) FOUND IT ! LA 2,1(2) STEP ALONG 1 ! BCT 6,NRLOOP 58(9) AND KEEP GOING !RESFAIL LM 1,10,4(WSPR) WONT RESOLVE ! NR WSPR,WSPR SET NON ZERO CC ! BCR 15,LINKREG AND RETURN !COMP CLC 1(1,5),1(2) !NROK ! SR 2,10 LENGTH OF FRAGMENT ! LTR 4,4 IS FRAGMNT TO BE STORED ! BC 8,NOSTORE 112(9) ! EX 2,MOVE 136(9) COPY IT +RUBBISH LENGTH BYTE ! STC 2,0(4) RESET LENGTH BYTE ! CH 2,6(1) PERFORM CAP EXCEEDED CHECK ! BC 10,CPE 142(9) !NOSTORE IC 0(5(1) ! AR 2,0 R2=FRAG LENGTH + ORIG USED ! AR 2,7 PLUS BYTES OF EXPR ! LA 2,1(2) ! STC 2,5(1) BACK INTO WORK AREA !REND LM 1,10,4(WSPR) ! CR WSPR,WSPR SET CC TO 0 ! BCR 15,LINKREG !MOVE MVC 0(1,4),0(10) !CPE LM 1,10,4(WSPR) ! BC 15,PLABS9 !NULL RES RESOLVING ON NULL STRING ! LTR 4,4 ANY FRAG STRING ! BC 8,REND 128(9) NO SO EXIT ! MVI 0(4),0 SET IT TO NULL ! BC 15,REND 128(9) ! BCR 15,LINREG %IF WORKA_PLINK(16)=0 %THEN ->P17 FILL(16) PIX RS(STM,1,10,WSPR,4) PIX RR(LR,1,0) PIX RR(SR,0,0) PIX RS(LM,2,5,1,0) PIX RR(BALCODE-X'40',9,0) PIX SI(CLI,0,1,5) PIX RX(BC,7,0,9,14) PIX SS(MVC,0,1,1,4,2,0) PIX RR(SR,6,6) PIX RX(IC,6,0,1,4) PIX RX(IC,0,0,1,5) PIX RR(SR,6,0) PIX RR(SR,7,7) PIX RX(IC,7,0,5,0) PIX RR(SR,6,7) PIX RX(BC,4,0,9,74) PIX RX(LA,6,0,6,1) PIX RR(LTR,7,7) PIX RX(BC,8,0,9,150) PIX RR(BCTR,7,0) PIX RX(IC,0,0,1,5) PIX RR(AR,2,0) PIX RR(LR,10,2) PIX RX(EX,7,0,9,82) PIX RX(BC,8,0,9,88) PIX RX(LA,2,0,2,1) PIX RX(BCT,6,0,9,58) PIX RS(LM,1,10,WSPR,4) PIX RR(NR,WSPR,WSPR) PIX RR(BCR,15,LINKREG) PIX SS(CLC,0,1,5,1,2,1) PIX RR(SR,2,10) PIX RR(LTR,4,4) PIX RX(BC,8,0,9,112) PIX RX(EX,2,0,9,136) PIX RX(STC,2,0,4,0) PIX RX(CH,2,0,1,6) PIX RX(BC,10,0,9,142) PIX RX(IC,0,0,1,5) PIX RR(AR,2,0) PIX RR(AR,2,7) PIX RX(LA,2,0,2,1) PIX RX(STC,2,0,1,5) PIX RS(LM,1,10,WSPR,4) PIX RR(CR,WSPR,WSPR) PIX RR(BCR,15,LINKREG) PIX SS(MVC,0,1,4,0,10,0) PIX RS(LM,1,10,WSPR,4) PJUMP(BC,WORKA_PLABS(9),15,0) PIX RR(LTR,4,4) PIX RX(BC,8,0,9,128) PIX SI(MVI,0,4,0) PIX RX(BC,15,0,9,128) P17: ! ! MULTIPLY TWO LONG INTEGERS AT WSPR+8 AND WSPR+16 %IF WORKA_PLINK(17)=0 %THEN ->P18 FILL(17) ! ! BASR 1,0 !(0) CLC OPND2,X'000000007FFFFFFF' CHECK FOR SMALL +VE MULTIPLIER !(6) BC 2,LONGWAY !(10) CLC OPND1,X'000000007FFFFFFF' ! CHECK MULTIPLICAND !(16) BC 2,LONGWAY !(20) LM 0,1,OPND1 !(24) M 0,OPND2+4 !(28) BCR 15,15 !(30)LONGWAY DISP=KLCONSTS(10) %IF DISP<4095 %START PIX RR(BALCODE-X'40',1,0) PIX SS(CLC,0,8,WSPR,16,CTABLEREG,DISP) PIX RX(BC,2,0,1,30) PIX SS(CLC,0,8,WSPR,8,CTABLEREG,DISP) PIX RX(BC,2,0,1,30) PIX RS(LM,0,1,WSPR,8) PIX RX(M,0,0,WSPR,20) PIX RR(BCR,15,15) %FINISH LONGOP(MXR) P18: ! ! DIVIDE TWO LONG INTEGES AT WSPR+8 AND WSPR+16S ! %IF WORKA_PLINK(18)=0 %THEN ->P19 ! ! BASR 1,0 !(0) CLC OPND2,X'000000007FFFFFFF' CHECK FOR SMALL +VE DIVISOR !(6) BC 2,LONGWAY !(10) CLC OPND1,X'000000007FFFFFFF' ! CHECK DIVIDEND !(16) BC 2,LONGWAY !(20) LM 0,1,OPND1 !(24) D 0,OPND2+4 !(28) LR 0,1 !(30) SRDA 0,32 !(34) BCR 15,15 !(36)LONGWAY FILL(18) DISP=KLCONSTS(10) %IF DISP<4095 %START PIX RR(BALCODE-X'40',1,0) PIX SS(CLC,0,8,WSPR,16,CTABLEREG,DISP) PIX RX(BC,2,0,1,36) PIX SS(CLC,0,8,WSPR,8,CTABLEREG,DISP) PIX RX(BC,2,0,1,36) PIX RS(LM,0,1,WSPR,8) PIX RX(D,0,0,WSPR,20) PIX RR(LR,0,1) PIX RS(SRDA,0,0,0,32) PIX RR(BCR,15,15) %FINISH LONGOP(DXR) P19: ! CONCATENATION ONE ! NOW DONE IN LINE %IF WORKA_PLINK(19)!WORKA_PLINK(20)=0 %THEN ->P21 P21: %BEGIN !*********************************************************************** !* PASS INFORMATION TO IPUT TO ENABLE IT TO GENERATE THE * !* LOADER DATA AND COMPLETE THE PROGRAM FILE. * !*********************************************************************** %ROUTINESPEC DUMPCONSTS %INTEGER LANGFLAG,PARMS,I,J,K %STRING (15) S CODE OUT PCNOP(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 %IF PARM_INHCODE=0 %THENSTART ! BACK OF GLAP PDBYTES(2,0,FIXEDGLALEN,ADDR(FIXED GLA(0))); ! FRONT OF GLAP PFIX(2,4,1,0); ! RELOCATE HEAD OF CODE PFIX(2,8,5,0); ! RELOCATE GLA ST ADDRESS PFIX(2,12,4,0); ! RELOCATE CODE ST ADDRESS PFIX(2,20,DAREA,0); ! RELOCATE DIAG AREA PTYR PFIX(2,24,CAREA,0); ! RELOCATE CONSTANT AREA %IF PARM_CHK#0 %THEN S=STKTOP %AND PDXREF(4,2,28,S) PD4(DAREA,CAS(DAREA),X'E2E2E2E2') CAS(DAREA)=CAS(DAREA)+4 %FINISH %CYCLE I=1,1,10 CAS(I)=(CAS(I)+7)&(-8) %REPEAT %IF PARM_INHCODE=0 %THENSTART I=CHANGE CONTEXT I=PTERMINATE(ADDR(CAS(1)),MAX4KMULT) %IF CA>4096*MAX4KMULT+4095 %THEN FAULT(98,0,0) %IF I#0 %THEN PARM_FAULTY=PARM_FAULTY+1 %FINISH %IF WORKA_OPTCNT>0 %THENSTART NEWLINE WRITE(WORKA_OPTCNT,2) PRINTSTRING(" OPTIMISATIONS HAVE BEEN MADE") %FINISH PRINTSTRING(" IBM CODE") WRITE(CA,6) PRINTSTRING("+"); WRITE(CAS(CAREA),4) PRINTSTRING(" BYTES GLAP") WRITE(GLACA,3); PRINTSTRING("+") WRITE(CAS(5),1); PRINTSTRING(" BYTES DIAG TABLES") WRITE(CAS(DAREA),3); PRINTSTRING(" BYTES TOTAL") K=CA+CAS(CAREA)+GLACA+CAS(4)+CAS(5)+CAS(6) WRITE(K,5); PRINTSTRING(" BYTES ") %IF PARM_FAULTY=0 %THENSTART WRITE(STMTS,7); PRINTSTRING(" STATEMENTS COMPILED") %FINISHELSESTART PRINTSTRING("PROGRAM CONTAINS"); WRITE(PARM_FAULTY,2) PRINTSTRING(" FAULT"); PRINTSYMBOL('S') %IF PARM_FAULTY>1 %FINISH NEWLINES(2) PPROFILE ->BLKEND %ROUTINE DUMP CONSTS !*********************************************************************** !* OUTPUT THE CONSTANT TABLE AND MAKE ANY RELEVANT RELOCATIONS * !*********************************************************************** %INTEGER I,J,K,SIZE,BASE BASE=0 SIZE=WORKA_CONSTPTR-BASE CAS(CAREA)=4*SIZE %IF SIZE<=0 %THENRETURN PDBYTES(CAREA,0,SIZE*4,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 %EXITIF I>=WORKA_CONSTPTR %REPEAT NEWLINE %FINISH !*DELEND ! %RETURN %END BLKEND: %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 B1,D1,R1,B2,D2,R2,B3,D3,R3 ! ! 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 ! LD 0,X'5188000000000000' ! LD 2,X'4300000000000008' ROUNDING BIT AT BTM SINCE EMULATED DIVIDE ! MAY HAVE LAST FEW BITS WRONG ! 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 ! D1=KLCONSTS(6); ! X'5C00000000000080' B1=D1>>12; R1=0 D2=KLCONSTS(5); ! X'5188000000000000' B2=D2>>12; R2=0 D3=KLCONSTS(9) B3=D3>>12; R3=0 %IF B1#0 %THEN R1=1 %AND PIX RX(L,1,0,CODER,4*B1); ! 4K MULT LDED PIX RX(LD,4,R1,CTABLEREG,D1&X'FFF') PIX RR(SDR,6,6) PIX RX(STD,4,0,WSPR,0) PIX SS(XC,0,1,WSPR,7,WSPR,8) PIX RX(LD,2,0,WSPR,8) PIX RX(STD,4,0,WSPR,8) PIX RX(LD,0,0,WSPR,0) PIX RR(SXR,0,4) PIX RX(STD,0,0,WSPR,24) PIX RX(STD,2,0,WSPR,32) PIX SS(XC,0,1,WSPR,15,WSPR,16) PIX RX(LD,0,0,WSPR,8) PIX RX(LD,2,0,WSPR,16) PIX RR(SXR,0,4) PIX RX(LD,4,0,WSPR,24) PIX RX(LD,6,0,WSPR,32) %IF OP<255 %THEN PIX RR(OP,4,0) %ELSE PIX RRE(OP,4,0) %IF B1=B2 %THEN R2=R1 %ELSEIF B2>0 %THEN PIX RX(L,1,0,CODER,4*B2) %AND R2=1 PIX RX(LD,0,R2,CTABLEREG,D2&X'FFF') %IF B2=B3 %THEN R3=R2 %ELSEIF B3>0 %THEN PIX RX(L,1,0,CODER,4*B3) %AND R3=1 PIX RX(LD,2,R3,CTABLEREG,D3&X'FFF') PIX RR(AXR,0,4) PIX RX(STD,0,0,WSPR,16) PIX RX(STD,2,0,WSPR,24) PIX SI(XI,X'08',WSPR,17) PIX SS(MVC,0,2,WSPR,24,WSPR,25) PIX SS(MVO,0,X'99',WSPR,7,WSPR,17) PIX RS(LM,0,1,WSPR,8) PIX RR(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 * !*********************************************************************** PLABEL(WORKA_PLABS(LAB)) %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 CALL STOP %ROUTINESPEC CONSTEXP(%INTEGER PTYPE,VALUE) %ROUTINESPEC SAVE IRS(%INTEGER UPPER,MASK) %ROUTINESPEC SET USE(%INTEGER REG,PTYPE,USE,INF) %ROUTINESPEC FREE AND FORGET(%INTEGER REG) %ROUTINESPEC FORGET(%INTEGER REG) %ROUTINESPEC COPY USE(%INTEGER TO,FROM) %ROUTINESPEC FORGETM(%INTEGER UPPER) %ROUTINESPEC CLAIM THIS REG(%INTEGER REG) %INTEGERFNSPEC FREE REGS(%INTEGER L,U) %ROUTINESPEC CLAIM ALL4 FRS %INTEGERFNSPEC CLAIM OTHER FRPAIR(%INTEGER PAIR0) %ROUTINESPEC FIND USE(%INTEGERNAME REG, %INTEGER PTYPE,USE,INF) %INTEGERFNSPEC FINDREG(%INTEGER MASK,CLVAL) %INTEGERFNSPEC FINDSEQREG(%INTEGER MASK,CLVAL) %INTEGERFNSPEC CHECKSEQREG(%INTEGER MASK,QUICK) %INTEGERFNSPEC ACCEPTABLE REG(%INTEGER MASK,REG) %ROUTINESPEC SET LOCAL BASE %ROUTINESPEC PPJ(%INTEGER MASK,N,SAVE) %ROUTINESPEC CHOP OPERAND(%RECORD (RD) %NAME OPND, %INTEGER NEWPT,XOFFSET) %INTEGERFNSPEC SET DVREG(%INTEGER WHICH,ANAME, %RECORD (RD) %NAME DOPND) %INTEGERFNSPEC LOADSTRLEN(%INTEGER REGORMASK, %RECORD (RD) %NAME OPND) %ROUTINESPEC SSTRASS(%RECORD (RD) %NAME LHOPND,RHOPND, %INTEGER ACC) %INTEGERFNSPEC SSVAROP(%INTEGER OP,S,B,D, %RECORD (RD) %NAME OPND) %ROUTINESPEC VMULTIPLY %ROUTINESPEC LNEGATE(%INTEGER REG) %ROUTINESPEC REALEXP %ROUTINESPEC STARSTAR %ROUTINESPEC NOTE ASSMENT(%INTEGER REG,ASSOP,VAR,PTYPE) %ROUTINESPEC NOTE LASS(%INTEGER SIZE,BASE,DISP) %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 %INTEGERFNSPEC APSSIMPLE %ROUTINESPEC FILL SAVE AREA(%INTEGER LPR) %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 TESTRASS(%INTEGER R,PTYPE) %ROUTINESPEC TESTVASS(%RECORD (RD) %NAME OPND) %ROUTINESPEC INC REG(%INTEGER REG,AMOUNT,LAOK) %ROUTINESPEC DFETCHAD(%INTEGERNAME REG, %INTEGER LEVEL,DISP) %ROUTINESPEC ADJUST INDEX(%INTEGER MODE, %INTEGERNAME INDEX,DISP) %ROUTINESPEC DUMPRXE(%INTEGER CODE, %INTEGERNAME REG, %INTEGER X,B,D) %ROUTINESPEC DUMPRX(%INTEGER CODE,REG,X,LEVEL,DIS) %ROUTINESPEC DUMPLA(%INTEGER REG,X,LEVEL,DIS) %ROUTINESPEC DUMPSI(%INTEGER CODE,L,B,D) %ROUTINESPEC DUMPM(%INTEGER CODE,R1,R2,B,D) %ROUTINESPEC DUMPSS(%INTEGER OP,L,B1,D1,B2,D2) %ROUTINESPEC EXECUTESS(%INTEGER XREG,OPCODE,B1,D1,B2,D2) %ROUTINESPEC PUT(%INTEGER REG,CODE,OFFSET,FINISHED, %RECORD (RD) %NAME OPND) %ROUTINESPEC REDUCE BASE(%RECORD (RD) %NAME OPND) %ROUTINESPEC OPERAND USED(%RECORD (RD) %NAME OPND) %routinespec operand revised(%record(rd)%name opnd) %ROUTINESPEC OPERAND LOADED(%RECORD (RD) %NAME OPND, %INTEGER REG,RESET) %INTEGERFNSPEC RESULTREG(%INTEGER PTYPE) %ROUTINESPEC BULKM(%INTEGER MODE,L,B1,D1,B2,D2) %ROUTINESPEC POLISH LOOP(%RECORD (TRIPF) %NAME R) ! %RECORD (RD) %NAME OPND1,OPND2,OPNDC,OPNDNC,OPND %RECORD (TRIPF) %NAME CURRT,WORKT %RECORD (LEVELF) %NAME LINF,CURRINF %RECORD (TAGF) %NAME TCELL %RECORD (LISTF) %NAME LCELL %RECORD (RD) TOPND; ! TEMPORARY OPERANDS ! %INTEGER B,C,D,WTRIPNO,JJ,KK,COMM,XTRA,PT,BFFLAG,TRIPINF,TRIPVAL,PTYPE,TYPE,PREC,STPTR,L0,B1, B2,B3,EVALREG,CLNB,SIZE,local base %OWNINTEGER RESTEMPAD=0; ! REMEMBERS CURRENT RESLN WK AD %OWNRECORD (RD) UOPND; ! TO SAVE SS OPERAND IN ASSEMBLER %LONGINTEGER DESC ! ! TRIPDATA GIVES INFORMATION ON TRIPLE ! TOP 4 BITS HAVE TYPE ! NEXT 12 BITS HAVE FLAGS:- ! 2**16 SET IF COMMUTATIVE ! 2**17 SET DONT LOAD OPERAND2 ! 2**18 SET DONT LOAD OPERAND1 ! 2**19 DONT SWOP NON COMMUTABLE OPERANDS ! NEXT 8 BITS HAVE MAX CODE PLANTED IN BYTES NOT INCLUDING ANY CONSTANSTS ! OR STRINGS WHICH MAY HAVE TO GO INLINE ! BOTTOM 8 BITS HAVE A POINTER OR VALUE ! TYPE 0 TRIPLES ARE IGNORED ! TYPE 1 TRIPLES VALUE HAS INDEX INTO SWITCH "TRIPSW" ! TYPE 2 TRIPLES VALUE HAS POINTER TO ISEQS ! %CONSTINTEGERARRAY TRIPDATA(0:199)=0, X'10000E0F'{RTHD ROUTINE/BKK HDR}, X'10000E43'{RDSPLY MAKE DISPLAY}, X'10000010'{RDAREA INITIALISE DIAGS AREA}, X'10000811'{RDPTR RESET DIAGS PTR}, X'10000412'{RTBAD ERROR XIT FOR FN-MAP}, X'10000613'{RTXIT "%RETURN"}, X'10000A14'{XSTOP "%STOP"}, 0(2), X'2000040A'{10 LOGICAL NOT}, X'2000040B'{11 LOGICAL NEGATE}, X'2000020C'{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'10000403'{21 STORE STACKPOINTER}, X'10000402'{22 RESTORE STACK POINTER}, X'10000805'{23 ADVANCE STACK POINTER}, X'10001004'{24 DECLARE ARRAY}, X'10000801'{25 UPDATE LINE NO}, X'10000A06'{26 CHECK ZERO FOR STEP}, X'10000407'{27 FOR PREAMBLE}, X'10000008'{28 FOR POSTAMBLE}, X'1000000E'{29 FOR SECOND PREAMBLE}, X'10000418'{30 PRECALL}, X'10000C19'{31 ROUTINE CALL}, X'1000081A'{32 RECOVER FN RESULT}, X'1000041B'{33 RECOVER MAP RESULT}, X'00000000'{34 NOT CURRENTLY USED}, X'1000081D'{35 GETAD GET 32BIT ADDREESS}, X'10002C24'{36 RTOI1 INT FN}, X'10002C25'{37 RTOI2 INTPT FN}, X'10000C26'{38 STOI1 TOSTRING FN}, X'10000C3D'{39 MNITR FOR %MONITOR}, X'10000C4F'{40 PPROF PRINT PROFILE }, X'1000143F'{41 RTFP TURN RTNAME TO FORMAL}, X'10000649'{42 ON EVENT1}, X'10000E4A'{43 ON EVENT2}, X'10001446'{44 DVSTART FILL IN ELSIZE&ND}, X'10002047'{45 DVEND WORK OUT TOTSIZE ETC}, X'1000044C'{46 FOREND }, X'1000004D'{47 DMASS Dummy assignment to Variable}, X'10002C4E'{48 RTOI3 Real to integer as TRUNC}, 0, X'10000232'{50 UCNOP}, X'10000233'{51 UCB1}, X'10000234'{52 UCB2}, X'10000435'{53 UCB3}, X'10000436'{54 UCW}, X'10000637'{55 UCBW}, 0(3), X'1000003B'{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'2000401E'{138 **}, X'2001041F'{139 COMP}, X'20000420'{140 DCOMP}, X'20061421'{141 VMY}, X'20010422'{142 COMB}, X'200E0c23'{143 ASSIGN=}, X'200E0c24'{144 ASSIGN<-}, X'20022025'{145 ****}, X'20060026'{146 BASE ADJ}, X'200E0C27'{147 ARR INDEX}, X'20060428'{148 INDEXED FETCH}, X'200E0c29'{149 LOCAL ASSIGN}, X'10001609'{150 VALIDATE FOR}, X'10001015'{151 PRE CONCAT}, X'10001C16'{152 COCNCATENEATION}, X'10001817'{153 IOCP CALL}, X'10000C1C'{154 PARAMETER ASSIGNMENT 1 NORMAL VALUES}, X'1000081F'{155 PARAM ASSNG 2 NORMAL PTRS}, X'10000820'{156 PARAM ASSGN 3 ARRAYS}, X'10000C20'{157 ASSGN FORMAL RT-CODE AS 156}, X'10000220'{158 PASS5 TYPE GENERAL NAME}, X'10000845'{159 PASS STR WORK AREA}, X'1000080A'{160 BACK JUMP}, X'1000080B'{161 FORWARD JUMP}, X'1000000C'{162 REMOVE LAB}, X'1000000D'{163 ENTER LABEL}, X'10000021'{164 DECLARE SWITCH}, X'10000022'{165 SET SWITCH LABEL TO CA}, X'10001023'{166 GOTO SWITCH LABEL}, X'10001027'{167 STRING ASS1 GENERAL}, X'10000A28'{168 STRING ASS 2 L KNOWN}, X'10002029'{169 STRING JAM TRANSFER}, X'10000C2A'{170 ARRAY HEAD ASSIGNMENT}, X'10000C2B'{171 PTR ASSIGNMENT}, X'1000042C'{172 MAP RESULT ASSIGNMENT}, X'1000082D'{173 FN RESULT ASSIGNMENT}, X'1000122E'{174 STRING COMPARISON}, X'1000122E'{175 STRING DSIDED COMPARISON}, X'10000C2F'{176 PRE RESOLUTION 1}, X'10000C30'{177 PRE RESOLUTION 2}, X'10001C31'{178 RESOLUTION PROPER}, X'1000283C'{179 RESOLUTION FINISH ASSN FRAGMNT}, X'10000C4B'{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'2002082B'{188 CONSTANT LOGICAL SHIFT}, X'2002082B'{189 COSNTANT ARITHMETIC SHIFT}, X'10001048'{190 DV BPAIR ENTER LB,UB &RANGE IN CORRECT FORM}, x'2000062d'{191 rstore store to store opns}, X'2000042C'{192 MULTX MULTIPLY AND INCREASE PRECISION}, 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=36 %CONSTBYTEINTEGERARRAY ISEQS(40:4*(4*NISEQS+10)-1)={FIRST INTEGER FORMS} %C 8,0,0,-ANYGR {10 INTEGER LOGICAL NOT}, 2,LCR,0,-ANYGR {11 INTEGER LOGICAL NEGATE}, 12,0,0,0 {12 INTEGER FLOAT TO REAL}, 2,LPR,0,-ANYGR {13 INTEGER MODULUS}, 9,0,0,0 {14 SHORTEN INTEGER TO 16 BIT}, 10,0,0,0 {15 LENGTHEN INTEGER}, 21,0,0,0 {16 SHORTEN INTEGER FOR JAM}, 1,0,0,109 {17 COMPILER ERROR}, 7,0,0,0 {18 NOOP}, 6,0,0,-ANYGR {19 PRELOAD}, 3,A,AH,-ANYGR {20 INTEGER ADDITION}, 3,S,SH,-ANYGR {21 INTEGER SUBTRACTION}, 4,X,0,-ANYGR {22 INTEGER NONEQUIVALENCE}, 4,O,0,-ANYGR {23 INTEGER LOGICAL OR}, 11,M,0,-ANYGR {24 INTEGER MULTIPLY}, 11,DR+X'40',0,0 {25 INTEGER INTEGER DIVIDE}, 1,0,0,109 {26 INTEGER REAL DIVIDE}, 4,AND,0,-ANYGR {27 INTEGER AND}, 17,SRL,0,-ANYGR {28 INTEGER RIGHT SHIFT}, 17,SLL,0,-ANYGR {29 INTEGER LEFT SHIFT}, 1,0,0,109 {30 REAL EXP OPERATOR}, 13,ICP,CH,-ANYGR {31 INTEGER COMPARISONS}, 14,ICP,CH,-ANYGR {32 FIRST PART OF DOUBLE COMPARISONS}, 15,0,0,0 {33 VMY}, 4,A,0,-ANYGR {34 COMBINE VMY RESULTS}, 16,0,0,-ANYGR {35 ASSIGN}, 16,0,0,-ANYGR {36 ASSIGN(<-)}, 22,1,0,0 {37 INTEGER EXPONENTIATION}, 18,2,0,0 {38 BASE ADJUST ARRAY INTEGER INDEX}, 19,2,0,0 {39 ARRAY INDEX INTEGER INDEX}, 20,0,0,0 {40 INDEXED FETCH INTEGER INDEX}, 23,0,0,-ANYGR {41 LASS}, 24,LTR,0,-ANY GR {42 ZCOMP COMPARISON WITH ZERO}, 25,0,0,-ANYGR {43 INTEGER SHIFT BY CONSTANT}, 32,M,0,-ANYGRPAIR {44 MULTX MULTIPLY AND EXTEND}, 36,0,0,-ANYGR {45 store to store}, 8,0,0,-ANY2SEQ {10 LONG INTEGER LOGICAL NOT}, 29,0,0,-ANY2SEQ {11 LONG INTEGER LOGICAL NEGATE}, 27,0,0,0 {12 LONG INTEGER FLOAT TO REAL}, 30,0,0,-ANY2SEQ {13 LONG INTEGER MODULUS}, 9,0,0,0 {14 SHORTEN LONG INTEGER TO 16 BIT}, 10,0,0,0 {15 LENGTHEN LONG INTEGER}, 21,0,0,0 {16 SHORTEN LONG INTEGER FOR JAM}, 1,0,0,109 {17 COMPILER ERROR}, 7,0,0,0 {18 NOOP}, 6,0,0,-ANYGRPAIR {19 PRELOAD}, 26,AL,A,12 {20 LONG INTEGER ADDITION}, 26,SL,S,3 {21 LONG INTEGER SUBTRACTION}, 26,X,X,0 {22 LONG INTEGER NONEQUIVALENCE}, 26,O,O,0 {23 LONG INTEGER LOGICAL OR}, 28,0,0,17 {24 LONG INTEGER MULTIPLY}, 28,0,0,18 {25 LONG INTEGER LONG INTEGER DIVIDE}, 1,0,0,109 {26 LONG INTEGER REAL DIVIDE}, 26,AND,AND,0 {27 LONG INTEGER AND}, 17,SRDL,0,-ANYGRPAIR {28 LONG INTEGER RIGHT SHIFT}, 17,SLDL,0,-ANYGRPAIR {29 LONG INTEGER LEFT SHIFT}, 1,0,0,109 {30 REAL EXP OPERATOR}, 13,ICP,CL,-ANY2SEQ {31 LONG INTEGER COMPARISONS}, 14,ICP,CL,-ANY2SEQ {32 FIRST PART OF DOUBLE COMPARISONS}, 15,0,0,0 {33 VMY}, 4,A,0,1 {34 COMBINE VMY RESULTS}, 16,0,0,-ANY2SEQ {35 ASSIGN}, 16,0,0,-ANY2SEQ {36 ASSIGN(<-)}, 22,2,0,-ANYFRPAIR {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,-ANY2SEQ {41 LASS}, 24,SLDA,0,-ANYGRPAIR {42 ZCOMP COMPARISON WITH ZERO}, 25,0,0,-ANYGRPAIR {43 LONG INTEGER SHIFT BY CONSTANT}, 7,0,0,0 {44 MULTX INVALID WITH LONG INTS}, 36,0,0,-ANYGR {45 store to store}, 7,0,0,0 {10 REAL LOGICAL NOT}, 2,LCDR,LCER,3 {11 REAL LOGICAL NEGATE}, 1,0,0,109 {12 FLOAT REAL COMPILER ERROR}, 2,LPDR,LPER,3 {13 REAL MODULUS}, 9,0,0,0 {14 SHORTEN REAL}, 10,0,0,0 {15 LENGTHEN REAL}, 9,0,0,0 {16 SHORTEN REAL FOR JAM}, 1,0,0,109 {17 COMPILER ERROR}, 7,0,0,0 {18 NOOP}, 6,0,0,-ANYFR {19 PRELOAD}, 4,AD,AE,3 {20 REAL ADDITION}, 4,SD,SE,3 {21 REAL SUBTRACTION}, 7,0,0,0 {22 REAL NONEQUIVALENCE}, 7,0,0,0 {23 REAL LOGICAL OR}, 4,MD,ME,3 {24 REAL MULTIPLY}, 7,0,0,0 {25 REAL INTEGER DIVIDE}, 4,DD,DE,3 {26 REAL REAL DIVIDE}, 7,0,0,0 {27 REAL AND}, 7,0,0,0 {28 REAL LEFT SHIFT}, 7,0,0,0 {29 REAL RIGHT SHIFT}, 22,2,0,-ANYFR {30 REAL EXP OPERATOR}, 13,CD,CE,3 {31 REAL COMPARISONS}, 14,CD,CE,3 {32 FIRST PART OF DOUBLE COMPARISONS}, 7,0,0,0 {33 VMY}, 7,0,0,0 {34 COMBINE VMY RESULTS}, 16,0,0,-ANYFR {35 ASSIGN}, 16,0,0,-ANYFR {36 ASSIGN(<-)}, 7,0,0,0 {37 REAL INTEGER EXPONENTIATION}, 1,0,0,109 {38 BASE ADJUST ARRAY REAL INDEX}, 7,0,0,0 {39 ARRAY INDEX REAL INDEX}, 3,0,0,0 {40 INDEXED FETCH REAL}, 23,0,0,3 {41 LASS}, 24,LTDR,LTER,-ANYFR {42 ZCOMP COMPARISONS WITH ZERO}, 7,0,0,0 {43 SHIFT BY CONST -ERROR}, 33,MXD,ME,-ANYFRPAIR {44 MULTX MULTIPLY AND EXTEND PREC}, 7,0,0,0 {45 store to store}, 7,0,0,0 {10 LLREAL LOGICAL NOT}, 2,LCDR,LCDR,-ANYFRPAIR {11 LLREAL LOGICAL NEGATE}, 1,0,0,109 {12 FLOAT LLREAL COMPILER ERROR}, 2,LPDR,LPDR,-ANYFRPAIR {13 LLREAL MODULUS}, 9,0,0,0 {14 SHORTEN LLREAL}, 10,0,0,0 {15 LENGTHEN LLREAL}, 9,0,0,0 {16 SHORTEN LLREAL FOR JAM}, 1,0,0,109 {17 COMPILER ERROR}, 7,0,0,0 {18 NOOP}, 6,0,0,-ANYFRPAIR {19 PRELOAD}, 31,0,AXR,-ANYFRPAIR {20 LLREAL ADDITION}, 31,0,SXR,-ANYFRPAIR {21 LLREAL SUBTRACTION}, 7,0,0,0 {22 LLREAL NONEQUIVALENCE}, 7,0,0,0 {23 LLREAL LOGICAL OR}, 31,0,MXR,-ANYFRPAIR {24 LLREAL MULTIPLY}, 7,0,0,0 {25 LLREAL INTEGER DIVIDE}, 31,DXR>>8,DXR&255,-ANYFRPAIR {26 LLREAL REAL DIVIDE}, 7,0,0,0 {27 LLREAL AND}, 7,0,0,0 {28 LLREAL LEFT SHIFT}, 7,0,0,0 {29 LLREAL RIGHT SHIFT}, 22,0,0,-ANYFRPAIR {30 LLREAL EXP OPERATOR}, 13,CD,CD,-ANYFRPAIR {31 LLREAL COMPARISONS}, 14,CD,CD,-ANYFRPAIR {32 FIRST PART OF DOUBLE COMPARISONS}, 7,0,0,0 {33 VMY}, 7,0,0,0 {34 COMBINE VMY RESULTS}, 16,0,0,-ANYFRPAIR {35 ASSIGN}, 16,0,0,-ANYFRPAIR {36 ASSIGN(<-)}, 7,0,0,0 {37 LLREAL INTEGER EXPONENTIATION}, 1,0,0,109 {38 BASE ADJUST ARRAY LLREAL INDEX}, 7,0,0,0 {39 ARRAY INDEX LLREAL INDEX}, 3,0,0,0 {40 INDEXED FETCH LLREAL}, 23,0,0,-ANYFRPAIR {41 LASS}, 24,LTDR,0,-ANYFRPAIR {42 ZCOMP COMPARISONS WITH ZERO}, 7,0,0,0 {43 SHIFT BY CONST -ERROR}, 7,0,0,0 {44 MULTX INVALID WITH LLREALS}, 7,0,0,0 {45 store to store} %SWITCH SW(0:36),TRIPSW(0:79) ! CURRINF==WORKA_LEVELINF(CURRLEVEL) CLNB=DISPREG(CURRINF_RBASE) %if clnb<=3 %then fault(105,0,0) %FOR JJ=11,1,14 %CYCLE IMPABORT %UNLESS REGS(JJ)_CL=-1 %REPEAT 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 EVALREG=0 %WHILE STPTR>0 %CYCLE CURRT==TRIPLES(STPTR) JJ=CURRT_OPERN TRIPINF=TRIPDATA(JJ) KK=TRIPINF>>8&255 %IF PARM_Z#0 %AND PARM_DCOMP#0 %THENSTART NEWLINE %if kk#0 %then PLINEDECODE %and PRINT USE PRINT THIS TRIP(TRIPLES,STPTR) %FINISH WTRIPNO=STPTR STPTR=CURRT_FLINK COMM=1 OPND1==CURRT_OPND1 OPND2==CURRT_OPND2 XTRA=CURRT_X1 CA=CA+kk; ! APPROX WORDRST CA FOR BASE REGISTER COVER CA=CA+4 %IF PARM_CHK#0 %and KK#0 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) %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 JJ>=128 %AND COMM=1 %THEN OPNDNC==OPND2 %ELSE OPNDNC==OPND1 ! %UNLESS JJ<128 %OR OPNDNC_FLAG=9 %OR TRIPINF&X'20000'#0 %THEN LOAD(OPNDNC,ANY GR,0) ->SW(L0) SW(1): ! ERROR CONDITION TRIPSW(0): FAULT(B3,0,0) %UNLESS TYPE=7 TRIPSW(*): PIX RR(X'1A',0,1); ! 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 PIX RR(B1,REGCODE(EVALREG),REGCODE(EVALREG)) %IF PTYPE=X'72' %THEN %C PIX RR(B2,REGCODE(EVALREG+1),REGCODE(EVALREG+1)) %AND FORGET(EVALREG+1) FORGET(EVALREG) ->SUSE ->STRES SW(3): ! INTEGER FORM NO PROBLEMS D=OPNDNC_PTYPE&255 %IF D=X'51' %AND B2#0 %AND OPNDNC_FLAG=0 %AND X'FFFF8000'<=OPNDNC_D<=X'7FFF' %THEN %C D=X'41' %AND OPNDNC_PTYPE=D %IF D=X'31' %OR (D=X'41' %AND B2=0) %THEN ->SW(4) C=2; ! TO REGISTER %IF JJ=COMP %OR JJ=DCOMP %THEN C=18; ! TO REGISTER BUT READONLY LOAD(OPNDC,ANY GR,C); ! FIRST OPERAND TO ANY EVALREG=OPNDC_XB %IF JJ=SUB %AND D=X'41' %AND OPNDNC_FLAG=SCONST %AND OPNDNC_D=1 %START PIX RR(BCTR,EVALREG,0) FORGET(EVALREG) ->SUSE; ! COMM ALWAYS 1 FOR SUBTRACT %FINISH %IF OPNDNC_FLAG<=8 %THEN LOAD(OPNDNC,ANY GR,1) %IF OPNDNC_PTYPE&255=X'41' %THEN B1=B2; ! USE HALFWORD VSN OF OP ! LOAD MAY HAVE EXPANDED IT(!) PUT(EVALREG,B1,0,YES,OPNDNC) %IF COMM=2 %THEN OPND1=OPND2; ! TRIPLE RESULT ALWAYS OPND1 SUSE: %IF (JJ=COMP %OR JJ=DCOMP) %AND REGS(EVALREG)_CNT>1 %THEN %C OPERAND USED(OPND1) %AND D=NO %ELSE D=YES OPERAND LOADED(OPND1,EVALREG,D); ! compare can be done on multiple use operands ->STRES SW(4): ! ANY FORM NO PROBLEMS C=2; ! TO REGISTER ! %IF JJ=COMP %OR JJ=DCOMP %THEN C=18;! TO REGISTER BUT READONLY LOAD(OPNDC,-B3,C); ! 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<=8 %THEN LOAD(OPNDNC,ANY GR,1) %IF D=X'52' %THEN B1=B2; ! USE SHORT FORM PUT(EVALREG,B1,0,YES,OPNDNC) %IF COMM=2 %THEN OPND1=OPND2 ->SUSE SW(6): ! PRELOAD ! CA OMIT UNLESS RTCALL ETCE INTERVENES %UNLESS CURRT_CNT=1 %AND (CURRT_PUSE=STPTR %OR %C CURRT_PUSE=TRIPLES(STPTR)_FLINK) %THEN LOAD(OPND1,-B3,2) SW(7): ! NULL OPERATION ->STRES SW(8): ! LOGICAL NOT LOAD(OPND1,-B3,2) EVALREG=OPND1_XB DUMPRX(X,EVALREG,0,CTABLEREG,KWCONSTS(2)) FORGET(EVALREG) %IF PTYPE=X'61' %START DUMPRX(X,EVALREG+1,0,CTABLEREG,KWCONSTS(2)) FORGET(EVALREG+1) %FINISH ->SUSE SW(9): ! SHORTEN INTEGER OR REAL PTYPE=CURRT_OPTYPE %IF PTYPE=X'62' %START LOAD(OPND1,ANY FRPAIR,2); ! TO ANY FR PAIR EVALREG=OPND1_XB PIX RR(LRDR,REGCODE(EVALREG),REGCODE(EVALREG)) FORGET(EVALREG) FREE AND FORGET(EVALREG+1) %FINISHELSEIF PTYPE=X'52' %START LOAD(OPND1,ANY FR,2); ! TO ANY FR EVALREG=OPND1_XB PIX RR(LRER,REGCODE(EVALREG),REGCODE(EVALREG)) FORGET(EVALREG) %FINISHELSEIF PTYPE=X'51' %START LOAD(OPND1,ANY GRPAIR,2); ! TO ANY GR PAIR EVALREG=OPND1_XB %IF PARM_OPT=0 %START REGS(EVALREG)_CL=0 FORGET(EVALREG) EVALREG=EVALREG+1 OPND1_XB=EVALREG %FINISHELSESTART PIX RS(SLDA,EVALREG,0,0,32) FORGET(EVALREG) REGS(EVALREG+1)_CL=0 %FINISH %FINISHELSEIF PTYPE=X'41' %START LOAD(OPND1,ANY GR,2) EVALREG=OPND1_XB %IF PARM_OPT#0 %AND TRIPLES(CURRT_PUSE)_OPERN#SHRTN %THENSTART PIX RX(SLA,EVALREG,0,0,16) PIX RX(SRA,EVALREG,0,0,16) FORGET(EVALREG) %FINISH %FINISHELSEIF PTYPE=X'31' %START LOAD(OPND1,ANY GR,2) EVALREG=OPND1_XB %IF PARM_OPT#0 %THENSTART DUMPRX(CL,EVALREG,0,CTABLEREG,KWCONSTS(1)) PPJ(2,9,NO) %FINISH %FINISH OPND1_PTYPE=CURRT_OPTYPE ->SUSE SW(10): ! LENGTHEN INTEGER OR REAL %IF TYPE=2 %THENSTART %IF CURRT_OPTYPE=X'62' %START; ! 32 TO 64 BIT LOAD(OPND1,ANY FR,2) EVALREG=OPND1_XB DUMPRX(ME,REGCODE(EVALREG),0,CTABLEREG,KWCONSTS(4)) %FINISHELSESTART LOAD PAIR(2,0,OPND1) EVALREG=OPND1_XB DUMPRX(MXD,REGCODE(EVALREG),0,CTABLEREG,KLCONSTS(7)) ! =D'1' %FINISH %FINISHELSESTART %IF CURRT_OPTYPE=X'61' %THENSTART LOAD PAIR(1,0,OPND1) EVALREG=OPND1_XB DUMPRX(SRDA,EVALREG,0,0,32) %FINISHELSESTART LOAD(OPND1,ANY GR,2) EVALREG=OPND1_XB %FINISH %FINISH OPND1_PTYPE=CURRT_OPTYPE FORGET(EVALREG) %IF CURRT_OPTYPE=X'61' %OR CURRT_OPTYPE=X'72' %THEN FORGET(EVALREG+1) ->SUSE SW(11): ! INTEGER MULT&DIV %IF PARM_OPT=0 %AND JJ=MULT %START %IF OPNDC_FLAG=SCONST %AND X'FFFF8000'<=OPNDC_D<=X'7FFF' %THEN ->MH1 %IF OPNDNC_FLAG=SCONST %AND X'FFFF8000'<=OPNDNC_D<=X'7FFF' %THEN ->MH2 %FINISH LOAD PAIR(1,B3,OPNDC) C=OPNDNC_PTYPE>>4&7; ! OPNDNC PREC %IF C<5 %THEN LOAD(OPNDNC,ANYGR,18) %ELSE LOAD(OPNDNC,ANY GR,17) EVALREG=OPNDC_XB %IF CURRT_OPERN=INTDIV %THEN PIX RX(SRDA,EVALREG,0,0,32) PUT(EVALREG,B1,0,YES,OPNDNC) FORGET(EVALREG) FORGET(EVALREG+1) %IF CURRT_OPERN=INTDIV %OR PARM_OPT=0 %THENSTART REGS(EVALREG)_CL=0 EVALREG=EVALREG+1 %ELSE PIX RS(SLDA,EVALREG,0,0,32); ! TEST FOR OVERFLOW REGS(EVALREG+1)_CL=0 %IF COMM=2 %THEN OPND1=OPND2 %FINISH ->SUSE MH1: LOAD(OPNDNC,ANYGR,2) D=SHORT CONST(OPNDC_D) EVALREG=OPNDNC_XB ->MH3 MH2: LOAD(OPNDC,ANYGR,2) D=SHORT CONST(OPNDNC_D) EVALREG=OPNDC_XB MH3: DUMPRX(MH,EVALREG,0,CTABLEREG,D) FORGET(EVALREG) %IF COMM=2 %THEN OPND1=OPND2 ->SUSE SW(12): ! FLOAT %BEGIN %INTEGER P0,P1,D LOAD(OPND1,ANY GR,2) P1=OPND1_XB P0=(P1-1)&15 D=KLCONSTS(8); ! X'4E00000080000000' DUMPRX(X,P1,0,CTABLEREG,D+4); ! X'80000000' %IF REGS(P0)_CL=0 %AND (REGS(P0)_USE=0 %OR D>4095) %START DUMPRX(LGR,P0,0,CTABLEREG,D) DUMPM(STM,P0,P1,WSPR,0) FORGET(P0) %ELSE PIX RX(ST,P1,0,WSPR,4) DUMP SS(MVC,4,WSPR,0,CTABLEREG,D); ! X4E000000 %FINISH EVALREG=FINDREG(FR0,1) DUMPRX(LD,REGCODE(EVALREG),0,WSPR,0) DUMPRX(SD,REGCODE(EVALREG),0,CTABLEREG,D); ! X'4E00000080000000' REGS(P1)_CL=0 FORGET(P1) FORGET(EVALREG) OPND1_XB=EVALREG %END OPND1_PTYPE=X'62' ->SUSE SW(21): ! SHORTEN INTEGER FOR JAM TRANSFER %IF CURRT_OPTYPE=X'51' %START; ! LOMG TO NORMAL LOAD(OPND1,ANY2SEQ,2) EVALREG=OPND1_XB REGS(EVALREG)_CL=0 EVALREG=EVALREG+1 %FINISHELSESTART LOAD(OPND1,ANY GR,2) ! NO CODE NEEDED FOR 32BITS & LESS EVALREG=OPND1_XB %FINISH OPND1_PTYPE=CURRT_OPTYPE ->SUSE SW(22): ! EXP IN ANY EXPRSN %IF OPND2_PTYPE&7=1 %THENSTART %IF OPND2_FLAG=SCONST %AND 2<=OPND2_D %THEN %C CONST EXP(OPND1_PTYPE&255,OPND2_D) %ELSE STARSTAR ->SUSE %FINISH ! REAL**REAL BY SUBROUTINE %IF PTYPE=x'72' %THEN B3=99 %AND ->SW(1) REALEXP; ->SUSE SW(17): ! INTEGER SHIFT LOAD(OPND1,-B3,2) LOAD(OPND2,ANYGR BAR0,18); ! read only EVALREG=OPND1_XB PIX RX(B1,EVALREG,0,OPND2_XB,0) OPERAND USED(OPND2) FORGET(EVALREG) ->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 WORKT_X1=WORKT_X1!!(C!!(XTRA&15)) ! PASS MASK ON FOR JUMP ! SUITABLY AMENDED FOR BACK COMPARISON LOAD(OPNDC,-B3,0) %IF L0=13 %AND OPNDC_FLAG=10 %AND OPNDC_XB<=15 %AND (7<=C<=8 %OR PTYPE=X'31') %AND %C SSVAROP(CLC,BYTES(PTYPE>>4),OPNDC_XB,OPNDC_D,OPNDNC)=YES %START OPERAND USED(OPNDNC) %IF COMM=2 %THEN OPND1=OPND2 ->STRES; ! RESULTS OF COMP NEVER REUSED %FINISH %IF TYPE=1 %AND PTYPE>>4<=5 %THEN ->SW(3) %IF TYPE=2 %AND PTYPE>>4<=6 %THEN ->SW(4) ! COMPARISON OF MULTIREGISTER ITEMS LOAD(OPNDC,-B3,2) LOAD(OPNDNC,-B3,1) EVALREG=OPNDC_XB PUT(EVALREG,B1,0,NO,OPNDNC) SET LOCAL BASE D=GLABEL; GLABEL=GLABEL-1 PJUMP(BC,D,7,0) PUT(EVALREG,B2,TYPE,YES,OPNDNC) PLABEL(D) %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=XTRA>>28; ! CURRENT DIMENSION D=XTRA>>24&15; ! TOTAL NO OF DIMENSIONS VMULTIPLY ->STRES SW(18): ! BASE ADJUST ARRAY INDEX ! NOT USED FOR IBM AS HEAD ADJUSTED ->STRES SW(19): ! ARRAY INDEX ! OPND1 THE EVALUATED SUBSRCIPT(S) ! OPND2 THE ARRAYHEAD AS B&D ! TOP 12 BITS OF XTRA HAVE ARRAY EL SIZE ! OR 0 FOR STRINGARRAYNAMES WORKT==TRIPLES(CURRT_FLINK) OPND2_PTYPE=OPND1_PTYPE&X'FF0F'!X'51'; ! CHOP DOWN ARRAYHEAD TYPE ! SO THAT THE LOAD OPERATES ONLY ! ON THE ADDR(A(0)) WORD NOT ON THE ! WHOLE 4 WORD ARRAYHEAD %IF CURRT_CNT=1 {%and Clnb>5{Not short of grs} %START; LOAD(OPND2,ANYGR BAR0,18) D=OPND2_XB %IF REGS(D)_CL>=0 %AND REGS(D)_CNT<=1 %THEN %C REGS(D)_CL=2 %AND REGS(D)_LINK=ADDR(OPND1) %IF OPND1_FLAG=SCONST %AND 0<=OPND1_D<=4095 %THENSTART OPND1_XB=D %FINISHELSESTART LOAD(OPND1,ANYGR BAR0,18) C=OPND1_XB %IF REGS(C)_CL>=0 %AND REGS(C)_CNT<=1 %THEN %C REGS(C)_CL=2 %AND REGS(C)_LINK=ADDR(OPND1) OPND1_XB=D<<4!C OPND1_D=0 %FINISH OPND1_FLAG=11 %FINISHELSESTART LOAD(OPND1,ANYGRBAR0,2) LOAD(OPND2,ANY GR,17) EVALREG=OPND1_XB PUT(EVALREG,A,0,YES,OPND2) OPERAND USED(OPND1) operand used(opnd2) opnd1=opnd2 OPERAND LOADED(OPND1,EVALREG,NO) %FINISH ->STRES SW(20): ! INDEXED FETCH ! NO LONGER GENERATED BY PASS2 ->STRES SW(16): ! ASSIGN(=) ! ASSIGN(<-) PT=XTRA&255; ! ORIGINAL PT OF LHS HERE %IF PT=0 %THEN PT=CURRT_OPTYPE TYPE=PT&15 SIZE=BYTES(PT>>4) TOPND=OPND1 EVALREG=-1; ! IN CASE SS ASSGNMNT MADE %IF OPND1_FLAG=2 %START; ! OPERAND A NAME TCELL==ASLIST(TAGS(OPND1_D)) %IF SSVAROP(MVC,SIZE,DISPREG(TCELL_UIOJ>>4&15),TCELL_SLINK&X'FFFF'+OPND1_XTRA&X'FFFF', OPND2)=NO %THENSTART LOAD(OPND2,-B3,18) EVALREG=OPND2_XB DSTORE(EVALREG,SIZE,TCELL_UIOJ>>4&15,TCELL_SLINK&X'FFFF'+OPND1_XTRA&X'FFFF') %FINISH NOTE LASS(SIZE,TCELL_UIOJ>>4&15,TCELL_SLINK&X'FFFF'+OPND1_XTRA&X'FFFF') OPERAND USED(OPND2) %FINISHELSESTART; ! OPERAND A POINTER LOAD(OPND1,ANYGR BAR0,X'60'); ! LEAVE IN STORE AND NO UNASS CHK %IF OPND1_FLAG#10 %OR OPND1_XB>15 %OR %C SSVAROP(MVC,SIZE,OPND1_XB,OPND1_D,OPND2)=NO %START LOAD(OPND2,-B3,18) EVALREG=OPND2_XB GET OUT OF ACC(EVALREG,SIZE,OPND1) %FINISH OPERAND USED(OPND1) OPND1=OPND2; ! IN CASE RESULT USED AGAIN %FINISH %IF TOPND_XTRA<0 %AND (TOPND_FLAG=DNAME %OR TOPND_FLAG=INDNAME) %THEN %C NOTE ASSMENT(EVALREG,TRIPVAL-33,TOPND_D,PT) ->STRES SW(23): ! LOCAL ASSIGNMENT EVALREG=-1 D=REGWORDS(PTYPE)>>4-1 SIZE=BYTES(PTYPE>>4) KK=(SIZE//(D+1))<<24!DISPREG(OPND1_D>>16)<<16!OPND1_D&X'FFFF' NOTE LASS(SIZE,OPND1_D>>16,KK&X'FFFF') %IF SSVAROP(MVC,SIZE,CLNB,OPND1_D&X'FFFF',OPND2)=NO %THENSTART %IF PTYPE=X'71' %THEN B3=-ANY4SEQ LOAD(OPND2,-B3,2) EVALREG=OPND2_XB DSTORE(EVALREG,SIZE,OPND1_D>>16,OPND1_D&X'FFFF') SET USE(EVALREG+C,PTYPE,LOCALTEMP,KK+C*(SIZE//(D+1))) %FOR C=0,1,D %FINISH OPERAND USED(OPND2) OPND1_FLAG=7 ->STRES SW(24): ! COMPARIONS WITH ZERO (OPND2 ZERO) D=YES; ! LTR (ETC) NEEDED %IF OPND1_FLAG=REFTRIP %AND OPND1_D=CURRT_BLINK %AND PTYPE#X'61' %START C=TRIPLES(OPND1_D)_OPERN %IF C=ADD %OR C=SUB %OR C=CASHIFT %THEN D=NO %IF 7<=XTRA&15<=8 %AND (C=ORL %OR C=ANDL %OR C=NONEQ) %THEN D=NO %FINISH LOAD(OPND1,-B3,18) EVALREG=OPND1_XB %IF PTYPE=X'52' %THEN B1=B2 %IF PTYPE=X'61' %THEN PIX RX(B1,EVALREG,0,0,0) %ELSEIF D=YES %THEN %C PIX RR(B1,REGCODE(EVALREG),REGCODE(EVALREG)) ! OPERAND USED(OPND1) ->STRES SW(25): ! SHIFT BY CONSTANT D=OPND2_D; ! THE CONSTANT %IF CURRT_OPERN=CASHIFT %THEN C=SLA %ELSEIF 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 PIX RS(C,EVALREG,0,0,IMOD(D)) FORGET(EVALREG) %IF PTYPE=x'61' %THEN FORGET(EVALREG+1) ->SUSE SW(26): ! LONG INTEGER OPERATION ! B3 IS THE MASK FOR CARRY LOAD(OPNDNC,ANY2SEQ,X'11'); ! Read only LOAD(OPNDC,ANY2SEQ,2) EVALREG=OPNDC_XB SET LOCAL BASE %UNLESS B3=0 PUT(EVALREG,B1,1,NO,OPNDNC); ! OPERATE ON L-S HALF %IF B3>0 %START PJUMP(BC,GLABEL,B3,0); ! JUMP ROUND CARRY DUMPRX(B2,EVALREG,0,CTABLEREG,KWCONSTS(3)); ! CARRY OF 1 PLABEL(GLABEL) GLABEL=GLABEL-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,CTABLEREG,KLCONSTS(6)); ! X'5C00000000000080' DUMPRX(STD,4,0,WSPR,0) OPERAND USED(OPND1) PIX SS(XC,0,1,WSPR,7,WSPR,8) PIX RR(SDR,6,6) DUMPRX(LD,0,0,WSPR,0) DUMPRX(LD,2,0,WSPR,8) PIX RR(SXR,0,4) FREE AND FORGET(18) FREE AND FORGET(19) FORGET(16) FORGET(18) EVALREG=16 OPND1_PTYPE=X'72' ->SUSE SW(28): ! MULT & DIV LONG INTEGERS LOAD(OPNDC,ANY2SEQ,2) DUMPM(STM,OPNDC_XB,OPNDC_XB+1,WSPR,8) OPERAND USED(OPNDC) LOAD(OPNDNC,ANY2SEQ,2) DUMPM(STM,OPNDNC_XB,OPNDNC_XB+1,WSPR,16) OPERAND USED(OPNDNC) PPJ(0,B3,YES) EVALREG=0 REGS(0)_CL=1 REGS(1)_CL=1 ->SUSE SW(29): ! NEGATE LONG INTEGER LOAD(OPND1,ANY2SEQ,2) EVALREG=OPND1_XB LNEGATE(EVALREG) ->SUSE SW(30): ! LONGINTEGR ABS %BEGIN %INTEGER D LOAD(OPND1,ANY2SEQ,2) SET LOCAL BASE EVALREG=OPND1_XB PIX RR(LTR,EVALREG,EVALREG) D=GLABEL; GLABEL=GLABEL-1 PJUMP(BC,D,10,0) LNEGATE(EVALREG) PLABEL(D) %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 PIX RRE(B1<<8!B2,REGCODE(EVALREG),REGCODE(OPND2_XB)) %ELSE %C PIX RR(B2,REGCODE(EVALREG),REGCODE(OPND2_XB)) OPERAND USED(OPND2) FORGET(EVALREG) FORGET(EVALREG+1) ->SUSE SW(32): ! MULTS EXPAND& MULTIPLY INTEGER LOADPAIR(1,1,OPNDC) C=OPNDNC_PTYPE>>4&7 %IF C<5 %THEN D=18 %ELSE D=17 LOAD(OPNDNC,ANYGR,D) EVALREG=OPNDC_XB PUT(EVALREG,B1,0,YES,OPNDNC) FORGET(EVALREG+1) %IF COMM=2 %THEN OPND1=OPND2 OPND1_PTYPE=X'61' ->SUSE SW(33): ! MULTX EXPAND AND MULTIPLY REAL C=OPNDC_PTYPE>>4&7 %IF C=5 %START LOAD(OPNDC,ANYFR,2) %IF OPNDNC_FLAG<=8 %THEN LOAD(OPNDNC,ANYFR,1) EVALREG=OPNDC_XB PUT(EVALREG,ME,0,YES,OPNDNC) %ELSE LOADPAIR(2,0,OPNDC) EVALREG=OPNDC_XB %IF OPNDNC_FLAG<=8 %THEN LOAD(OPNDNC,ANYFR,17) PUT(EVALREG,MXD,0,YES,OPNDNC) FORGET(EVALREG+1) %FINISH %IF COMM=2 %THEN OPND1=OPND2 OPND1_PTYPE=OPND1_PTYPE+X'10' ->SUSE SW(36): ! store to store operations TOPND=OPND1 PREC=PTYPE>>4&15 LOAD(OPND1,0,33) %IF OPND1_XB>15 %THEN REDUCEBASE(OPND1) %IF XTRA=NONEQ %THEN C=XC %ELSEIF XTRA=ORL %THEN C=OC %ELSE C=NC %IF OPND2_FLAG=SCONST %and opnd2_ptype<=x'51'{longs too hard} %START D=OPND2_D %IF prec=3 %or (0<=D<=255 %AND C#NC) %OR %c (c=nc %and d>>8=X'FFFFFF') %START DUMPSI(C-x'40',D&255,OPND1_XB,OPND1_D+BYTES(PREC)-1) ->NA %FINISH %IF D&255=0 %AND 0<=D>>8<=255 %AND C#NC %START DUMPSI(C-x'40',D>>8,OPND1_XB,OPND1_D+BYTES(PREC)-2) ->NA %FINISH %FINISH %IF OPND2_FLAG=SCONST %THEN OPND2_PTYPE=OPND1_PTYPE&255 ! force const to be stored at right precision LOAD(OPND2,0,33) %IF OPND2_XB>15 %THEN REDUCEBASE(OPND2) DUMPSS(C,BYTES(PREC),OPND1_XB,OPND1_D,OPND2_XB,OPND2_D) OPERAND USED(OPND2) NA: %IF TOPND_FLAG=INDNAME %OR TOPND_FLAG=DNAME %THEN %START Tcell==aslist(tags(topnd_d)) NOTE ASSMENT(-1,2,TOPND_D,CURRT_OPTYPE) %if Topnd_flag=dname %then note lass(bytes(prec), tcell_uioj>>4&15,Tcell_slink&X'FFFF'+topnd_xtra&x'FFFF') %finish OPERAND USED(OPND1) ->STRES TRIPSW(1): ! SET LINE NO %BEGIN %INTEGER I,LINE LINE=OPND1_D>>16 ! %IF parm_dcomp#0 %START; ! only used for controlling decompilation PLINESTART(LINE) %UNLESS PARM_OPT=0 %AND PARM_DCOMP#0 ! %FINISH %IF PARM_DBUG#0 %START DUMPRX(LA,0,0,0,LINE) PPJ(0,3,YES) %FINISHELSEIF PARM_LINE#0 %AND LINE#OLDLINE %START PIX SI(MVI,LINE&255,CLNB,3) %IF OLDLINE=0 %OR OLDLINE>>8#LINE>>8 %THEN PIX SI(MVI,LINE>>8,CLNB,2) OLDLINE=LINE %FINISH %IF PARM_PROF#0 %THENSTART DUMPRX(LA,0,0,0,1) I=PROFDATA+4*LINE DUMPRX(A,0,0,GLAREG,I) DUMPRX(ST,0,0,GLAREG,I) FORGET(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 PIX RR(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 PAIR(1,1,OPND2) LOAD(OPND1,ANY GR,2); ! LB DUMPRX(ST,OPND1_XB,0,CLNB,D) DUMPRX(ST,OPND2_XB+1,0,CLNB,D+4) %IF B1=X'80000000' %THENSTART PIX RR(SR,OPND2_XB+1,OPND1_XB) DUMPRX(A,OPND2_XB+1,0,CTABLEREG,KWCONSTS(3)); ! F'1' %FINISHELSE INC REG(OPND2_XB+1,1-B1,YES) DUMPRX(M,OPND2_XB,0,CLNB,D+8); ! MULT BY STRIDE FREE AND FORGET(OPND2_XB) OPND2_XB=OPND2_XB+1; ! bottom end FORGET(OPND2_XB) %IF C#XTRA>>24 %THEN D=D+20 %ELSE D=XTRA&X'FFFF'+4 ! NEXT MULTIPLIER ! BUT LAST MULTIPLIER = TOTSIZE DUMPRX(ST,OPND2_XB,0,CLNB,D) OPERAND USED(OPND1) OPERAND USED(OPND2) %CONTINUE TRIPSW(4): ! DECLARE ARRAY ! OPND1=CDV<<31!C<<24!D<<16!DVDISP ! OPND1_XTRA HAS NAME %BEGIN %INTEGER DVDISP,B0,D0,ND TCELL==ASLIST(TAGS(OPND1_XTRA)) ND=TCELL_UIOJ&15 %IF ND=2 %THEN D0=32 %ELSE D0=20; ! STRIDE OFFSET FROM DV START C=OPND1_D>>24&127 D=OPND1_D>>16&255 %IF C=0 %START; ! DV ADDR AND STRIDE ! SET UP FOR ALL ARRAYS ! ON FIRST DECL DVDISP=OPND1_D&X'FFFF' %IF OPND1_D>0 %START; ! DYNAMIC DOPE VECTOR CLAIM THIS REG(JJ) %FOR JJ=1,1,3 DUMPRX(LA,2,0,CLNB,DVDISP) DUMPRX(LGR,3,0,CLNB,DVDISP+D0) %FINISHELSESTART CLAIM THIS REG(JJ) %FOR JJ=0,1,3 B0=0 B0=B0-CTABLE(DVDISP>>2+3*JJ)*CTABLE(DVDISP>>2+3*JJ+2) %FOR JJ=1,1,ND %IF B0=0 %THEN PIX RR(SLR,0,0) %ELSE DUMPRX(LGR,0,0,CTABLEREG,WORD CONST(B0)) DUMPRX(LA,2,0,CTABLEREG,DVDISP) DUMPRX(LGR,3,0,CTABLEREG,DVDISP+D0) %FINISH %FINISHELSE PIX RR(SR,0,1) PIX RR(AR,0,WSPR) PIX RR(LR,1,WSPR) DSTORE(0,16,CURRINF_RBASE,TCELL_SLINK&X'FFFF'); ! STORE AWAY HEAD %IF C=D %START; ! LAST IN THIS STMNT FREE AND FORGET(JJ) %FOR JJ=0,1,3 %else forget(jj) %for jj=0,1,3; ! 4 K multiples can be remebered %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 PARM_CHK#0 %START %IF OPND1_D>0 %THEN DUMPRX(LGR,0,0,CLNB,D+4) %ELSE %C DUMPRX(LGR,0,0,CTABLEREG,4*(OPND1_D>>16&x'7fff'+1)) PIX RR(SR,1,1) PPJ(0,4,no) %IF REGS(0)_CL#0 %THEN C=0 %AND DFETCH(C,16,CURRINF_RBASE,TCELL_SLINK&X'FFFF') %elsestart forget(jj) %for jj=0,1,3 %finish %ELSE %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 %FINISH %CONTINUE TRIPSW(6): ! CHECK FOR ZERO FOR STEP LOAD(OPND1,ANY GR,2); ! STEP TO EVALREG EVALREG=OPND1_XB PIX RR(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) OPERAND LOADED(OPND1,1,YES) %IF PARM_OPT=0 %AND TRIPLES(CURRT_PUSE)_OPERN=FORPOST %THEN POLISH LOOP(CURRT) %CONTINUE TRIPSW(8): ! FOR POSTAMBLE REGS(1)_CL=0; REGS(1)_CNT=0 %FOR D=4,1,9 %CYCLE %IF 1<>8=LA %OR XTRA>>8=BAL %OR XTRA>>8=BAS %THEN B=XTRA>>4&15 PJUMP(XTRA>>8,C,XTRA>>4&15,B) %FINISHELSE PJINDEX(XTRA>>8,C,XTRA>>4&15,D) %FINISHELSESTART B=BC %IF XTRA&63=48 %THEN B=BCT %AND XTRA=1; ! SPECIAL FOR FORS D=FINDREG(GR1,0) FORGET(D) PJUMP(B,C,XTRA&15,D) %FINISH %CONTINUE TRIPSW(11): ! FORWARD JUMP _X1 HAS TF&MASK ! OPND1_XTRA HAS LABEL CELL<<16!JUMP CELL LCELL==ASLIST(OPND1_XTRA>>16) %IF LCELL_S1&X'FFFF'=0 %THEN LCELL_S1=LCELL_S1!GLABEL %AND GLABEL=GLABEL-1 B=BC C=XTRA&63 D=OPND1_D>>24; ! ENTER JUMP FLAGS %IF C=48 %AND D&X'40'=0 %THEN B=BCT %AND C=1 %IF D&X'40'#0 %START; ! ASSEMBLER JUMP C=XTRA&15; ! INDEX REG IN ASSEMBLER JUMP %IF C=0 %START; ! JUMP HAS NO INDEX B=0; ! NO OWRK REGISTER %IF XTRA>>8=LA %OR XTRA>>8=BAS %OR XTRA>>8=BAL %THEN B=XTRA>>4&15 PJUMP(XTRA>>8,LCELL_S1&X'FFFF',XTRA>>4&15,B) %FINISHELSESTART PJINDEX(XTRA>>8,LCELL_S1&X'FFFF',XTRA>>4&15,C) %FINISH %FINISHELSEIF D&1#0 %OR REACHABLE(OPND1_D&X'FFFF',STPTR)=YES %START SET LOCAL BASE PJUMP(B,LCELL_S1&X'FFFF',C,0) %FINISHELSESTART KK=FINDREG(GR1,0) FORGET(KK) PJUMP(B,LCELL_S1&X'FFFF',C,KK) %FINISH %IF D&2#0 %START; ! ENVIRONMENT MANIPULATION %IF D&128#0 %START; ! FIRST JUMP TO THIS LAB C=0; GET ENV(C) %FINISHELSESTART 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) %ANDEXIT 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 %REPEAT %IF LCELL_S1&X'FFFF'=0 %THEN LCELL_S1=LCELL_S1!GLABEL %AND GLABEL=GLABEL-1 PLABEL(LCELL_S1&X'FFFF') D=OPND1_D>>24; ! ENVIRONMENT MANIPULATION FLAGS %IF D&2=0 %THEN FORGETM(14) %ELSESTART 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 REGS(1)_CNT=CURRT_CNT %CONTINUE TRIPSW(15): ! RT HEADING OPND1_D=RTNAME ! OPND1_XTRA=AXNAME OR 0 %BEGIN %INTEGER W1,PCKWORD %IF OPND1_D>=0 %START TCELL==ASLIST(TAGS(OPND1_D)) %IF TCELL_PTYPE&x'1000'=0 %THEN TCELL==ASLIST(TCELL_LINK&x'ffff') ! silly case rt name also redeclared in params %FINISH W1=-1; PCKWORD=0; ! OPND1_XTRA=AXNAME #0 IF AN ENTRY %IF OPND1_XTRA#0 %START; ! EXTERNAL NEEDS INITIALISE %IF OPND1_D<0 %THENSTART; ! FIRST BEGIN OR MAIN ENTRY C=1; ! FLAG MAIN ENTRY %FINISHELSESTART; ! NOT MAIN ENTRY C=0 D=TCELL_SLINK; ! TO PARAM CHAIN %IF D>0 %THENSTART PCKWORD=ASLIST(D)_S3 PCKWORD=(PCKWORD&X'FFF')<<16!PCKWORD>>16 %FINISH %FINISH PPROC(STRING(OPND1_XTRA),C<<31!1,PCKWORD,W1) DUMPRX(LGR,CTABLEREG,0,GLAREG,24) %IF OPND1_D<0 %START; ! MAIN PROG DUMPRX(LGR,1,0,CTABLEREG,WORD CONST(X'08000000')) PIX RR(SPM,1,0); ! SET PROGRAM MASK %FINISH %FINISHELSEIF OPND1_D>=0 %THEN %C PPROC(STRING(ADDR(WORKA_LETT(WORKA_WORD(OPND1_D)))),0,0,W1) OLDLINE=0 %IF OPND1_D>=0 %START; ! ROUTINE PLANT INTERNAL ENTRY D=TCELL_SNDISP; ! LIST OF OUTSTANDING JUMPS %IF D=0 %THEN D=GLABEL %AND TCELL_SNDISP=D %AND GLABEL=GLABEL-1 PLABEL(TCELL_SNDISP) %FINISH PIX RX(ST,LINKREG,0,WSPR,60) %IF OPND1_D>=0 %OR OPND1_XTRA#0 %END %CONTINUE TRIPSW(67): ! RDSPY CREATE DIPLAY OPND1_D=DISPLAY OFFSET FORGETM(14) %IF PARM_CHK=0 %THEN PIX RR(LR,CLNB,WSPR) %ELSE PIXRR(LR,3,WSPR) ! leave old lnb till after ppj4 for diags REGS(CLNB)_CL=-1 REGS(CLNB)_USE=NAMEBASE REGS(CLNB)_INF1=CURRINF_RBASE CURRINF_SET=PMARKER(2); ! 2 HALF WORDS FOR ASF %FOR JJ=0,1,CLNB-1 %CYCLE IMPABORT %IF REGS(JJ)_CL#0 %REPEAT %IF PARM_CHK#0 %THENSTART DUMPRX(LA,1,0,0,CURRINF_PSIZE) PPJ(0,4,YES) PIX RR(LR,CLNB,3) %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) C=PMARKER(4) PUSH(LINF_RAL,1,C,0); ! TO OVERWRITE LATER PSETOPD(C,1,CLNB<<12) PSETOPD(C,3,CLNB<<12!1) %CONTINUE TRIPSW(18): ! RTBAD FN-MAP ERROR EXIT WORKT==TRIPLES(CURRT_BLINK); ! PREVIOUS TRIPLE %CONTINUEIF WORKT_OPERN=RTXIT %OR WORKT_OPERN=XSTOP %OR (WORKT_OPERN=BJUMP %AND %C WORKT_X1&15=15) PPJ(15,10,NO) %CONTINUE TRIPSW(19): ! RTXIT - "%RETURN" DUMPM(LM,4,LINKREG,CLNB,16) PIX RR(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) PIX RR(SLR,0,0); PIX RR(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 NOTE LASS(256,CURRINF_RBASE,D); ! discard any old lengths in regs LOAD(OPND2,ANY GR,1) %IF OPND2_FLAG=LCONST %START DUMPSS(MVC,OPND2_XTRA+1,CLNB,D,OPND2_XB,OPND2_D) %FINISHELSESTART EVALREG=ANYGRBAR0 DUMPRXE(IC,EVALREG,0,OPND2_XB,OPND2_D) SET USE(EVALREG,X'31',LOCALTEMP,1<<24!CLNB<<16!D) REGS(EVALREG)_CL=-1 EXECUTESS(EVALREG,MVC,CLNB,D,OPND2_XB,OPND2_D) REGS(EVALREG)_SECUSE=LITCONST REGS(EVALREG)_INF2=-1000 REGS(EVALREG)_CL=0 %FINISH OPERAND USED(OPND2) OPND1_FLAG=7; ! RESULT IS LOCAL %CONTINUE TRIPSW(22): ! CONCATENATE OPND1 WORK AREA ! OPND2 THE NEXT BIT ! A nasty problem is the no of regs ! That the execute can use in the worst case ! when workarea ctable & operand are >4096 ! hence curious order of operatios %BEGIN %INTEGER OLENREG,ALENREG,ADDREG,ADRADJ %RECORD (RD) OLOPND OPND1=TRIPLES(OPND1_D)_OPND1 %WHILE OPND1_FLAG=REFTRIP D=OPND1_D&X'FFFF'; ! work AREA OFFSET FROM LNB OLENREG=ANYGRBAR0; ADRADJ=0 OLOPND=0; OLOPND_FLAG=7; OLOPND_PTYPE=x'31' OLOPND_D=CURRINF_RBASE<<16!D; ! length byte of wk-area as operand LOAD(OLOPND,OLENREG,2); ! and loaded OLENREG=OLOPND_XB REGS(OLENREG)_AT=WTRIPNO-1; ! may be booted in this sequence ADDREG=ANYGRBAR0 ! If the work area is more than 4k ! but less than 8k from CLNB then we ! can save an instrn and more important a reg ! by makink an adjustment here %IF 4096<=D<8188 %THEN ADRADJ=4092 DUMPRXE(LA,ADDREG,CLNB,OLENREG,ADRADJ); ! PTR T0 STR END %IF OLENREG=0 %THEN PIX RR(AR,ADDREG,0) REGS(ADDREG)_CL=-1 FORGET(ADDREG) %IF OPND2_FLAG=LCONST %START; ! STRING LITERAL BEING ADDED INC REG(OLENREG,OPND2_XTRA,YES) DUMPRX(STC,OLENREG,0,CLNB,D) %if parm_opt#0 %Start dumprx(cl,olenreg,0,ctablereg,kwconsts(1)) ppj(2,9,no) %finish OPERAND USED(OLOPND) SET USE(OLENREG,x'31',LOCALTEMP,1<<24!CLNB<<16!D) %IF OPND2_XTRA=1 %START DUMPSI(MVI,WORKA_A(OPND2_D+1),ADDREG,D-ADRADJ+1) %FINISHELSESTART LOAD(OPND2,ANY GR,1) DUMPSS(MVC,OPND2_XTRA,ADDREG,D-ADRADJ+1,OPND2_XB,OPND2_D+1) %FINISH %FINISHELSESTART ALENREG=LOADSTRLEN(ANYGRBAR0,OPND2) REGS(ALENREG)_CL=-1 PIX RR(AR,OLENREG,ALENREG) DUMPRX(STC,OLENREG,0,CLNB,D); ! STORE NEW LENGTH %if parm_opt#0 %Start dumprx(cl,olenreg,0,ctablereg,kwconsts(1)) ppj(2,9,no) %finish OPERAND USED(OLOPND) SET USE(OLENREG,x'31',LOCALTEMP,1<<24!CLNB<<16!D) EXECUTESS(ALENREG,MVC,ADDREG,D-ADRADJ+1,OPND2_XB,OPND2_D+1) REGS(ALENREG)_CL=0 %FINISH 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) %FINISHELSESTART LOAD(OPND2,ANY GR,1) DUMPSS(MVC,OPND2_XTRA+1,OPND1_XB+1,0,OPND2_XB,OPND2_D) %IF PARM_OPT#0 %START; ! CHECK LENGTH XREG=SHORT CONST(OPND2_XTRA) DUMP RX(CH,OPND1_XB,0,CTABLEREG,XREG) PPJ(12,9,NO) %FINISH %FINISH %FINISHELSESTART XREG=LOADSTRLEN(ANYGRBAR0,OPND2) REGS(XREG)_CL=-1 EXECUTESS(XREG,MVC,OPND1_XB+1,0,OPND2_XB,OPND2_D) REGS(XREG)_CL=0 %IF PARM_OPT#0 %START PIX RR(CR,XREG,OPND1_XB) PPJ(10,9,NO) %FINISH %FINISH OPERAND USED(OPND1) OPERAND USED(OPND2) %END %CONTINUE TRIPSW(40): ! SIMPLE STRING ASSIGN LOAD(OPND1,ANY GR,X'41'); ! LHS without unass check SSTRASS(OPND1,OPND2,xtra{holds ACC}) %CONTINUE TRIPSW(41): ! STRING JT VIA SUBROUTINE %BEGIN %INTEGER XREG LOAD(OPND1,ANY 2SEQ,2); ! PTR 2WORDS TO ANY CONSECUTIVE XREG=LOADSTRLEN(ANYGRBAR0,OPND2) REGS(XREG)_CL=-1 PIX RR(BCTR,OPND1_XB,0) PIX RR(CR,XREG,OPND1_XB); ! COMPARE LEN WITH LMAX SET LOCAL BASE PJUMP(BC,GLABEL,4,0) PIX RR(LR,XREG,OPND1_XB) PLABEL(GLABEL) GLABEL=GLABEL-1 EXECUTESS(XREG,MVC,OPND1_XB+1,0,OPND2_XB,OPND2_D) ! MOVE CHARS PLUS GASH LENGTH BYTE DUMPRX(STC,XREG,0,OPND1_XB+1,0); ! OVERWRITE LB WITH CORRECT LB REGS(XREG)_CL=0 OPERAND USED(OPND1) OPERAND USED(OPND2) %END %CONTINUE TRIPSW(46): ! STRING COMPARISONS INCL DSIDED BFFLAG=0 WORKT==TRIPLES(CURRT_FLINK) %IF OPND2_FLAG=LCONST %AND OPND2_XTRA=0 %THEN OPND==OPND1 %AND ->NULLSC %IF OPND1_FLAG=LCONST %AND OPND1_XTRA=0 %THEN 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(OPND2,ANY GR,1) %IF C>0 %THENSTART LOAD(OPND1,ANY GR,1) DUMPSS(CLC,C+1,OPND1_XB,OPND1_D,OPND2_XB,OPND2_D) %FINISHELSESTART JJ=LOADSTRLEN(ANYGRBAR0,OPND1) REGS(JJ)_CL=1 EXECUTESS(JJ,CLC,OPND1_XB,OPND1_D,OPND2_XB,OPND2_D) REGS(JJ)_CL=0 %FINISH OPERAND USED(OPND1) OPERAND USED(OPND2) %CONTINUE %FINISH C=FINDSEQREG(GRPAIR,1) LOAD(OPND1,ANY GR,1) DUMPRX(LA,C,0,OPND1_XB,OPND1_D+1) DUMPRX(IC,C+1,0,OPND1_XB,OPND1_D) OPERAND USED(OPND1) D=FINDSEQREG(GRPAIR,1) LOAD(OPND2,ANY GR,1) DUMPRX(LA,D,0,OPND2_XB,OPND2_D+1) DUMPRX(IC,D+1,0,OPND2_XB,OPND2_D) OPERANDUSED(OPND2) SET LOCAL BASE PIX RR(CR,C+1,D+1); ! compare lengths PJUMP(BC,GLABEL,2,0) PIX RR(LR,D+1,C+1) PJUMP(BC,GLABEL-1,15,0) PLABEL(GLABEL) PIX RR(LR,C+1,D+1) PLABEL(GLABEL-1) GLABEL=GLABEL-2 KK=FINDREG(GR0,1) ! PIX RRE(IPM,KK,0) PIX RR(BALR,KK,0) FORGET(KK) PIX RR(CLCL,C,D); ! compare shorter lengths only %FOR JJ=0,1,1 %CYCLE FREE AND FORGET(C+JJ) FREE AND FORGET(D+JJ) %REPEAT SET LOCAL BASE PJUMP(BC,GLABEL,7,0); ! anything bar equal PIX RR(SPM,KK,0) PLABEL(GLABEL) GLABEL=GLABEL-1 REGS(KK)_CL=0 %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') %ELSE WORKT_X1=D %FINISHELSE 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) PIX RR(SLR,C+1,C+1) testrass(c,5) %if parm_chk#0 DUMPM(STM,C,C+1,CLNB,D) FREE AND FORGET(C) FREE AND FORGET(C+1) SET USE(C+1,X'51',LITCONST,0) OPERAND USED(OPND2) %CONTINUE TRIPSW(48): ! PRE RESOLUTION 2 ! OPND1 IS 4 WORD WK AREA ! OPND2 IS POINTER TO STRING TO HOLD ! FRAGMENT OR ZERO(=DISCARD FRGMNT) RESTEMPAD=OPND1_D&X'FFFF' %IF OPND2_FLAG=SCONST %START; ! NO STRING FOR FRAGMENT DUMPSS(MVC,4,CLNB,RESTEMPAD+8,CODER,0) %FINISHELSESTART LOAD(OPND2,ANY2SEQ,X'41') %IF OPND2_FLAG=DEVELOPPED %AND OPND2_XB<=15 %AND RESTEMPAD<=4089 %START DUMPSS(MVC,6,CLNB,RESTEMPAD+6,OPND2_XB,OPND2_D+2) %ELSE LOAD(OPND2,ANY2SEQ,X'42') %UNLESS OPND2_FLAG=INAREG DUMPRX(STH,OPND2_XB,0,CLNB,RESTEMPAD+6) DUMPRX(ST,OPND2_XB+1,0,CLNB,RESTEMPAD+8) %FINISH OPERAND USED(OPND2) %FINISH %CONTINUE TRIPSW(49): ! RESOLUTION ! OPND1 IS STRING RES EXPR ! OPND2 IS LABEL NO LOADAD(OPND1,-1) DUMPRX(ST,OPND1_XB,0,CLNB,RESTEMPAD+12) OPERAND USED(OPND1) CLAIM THIS REG(0) DUMPRX(LA,0,0,CLNB,RESTEMPAD) FREE AND FORGET(0) PPJ(0,16,YES) %IF OPND2_D=0 %THEN PPJ(7,12,NO); ! UNCONDITIONAL FAILS %CONTINUE TRIPSW(60): ! RESFN FINAL POST RES ASSIGN ! OPND2 HAS POINTER ! SINCE RESOLVED STRING MAY BE CONST ! CAN NOT USE NORMAL ASSIGN %BEGIN %INTEGER XREG,BREG,LB D=OPND1_D&X'FFFF'; ! TO 4 WORD WK AREA LOAD(OPND2,ANY 2SEQ,2); ! POINTER TO DR XREG=ANYGRBAR0 DUMPRXE(IC,XREG,0,CLNB,D+4); ! ORIGINAL LHS LENGTH setuse(xreg,X'51',Litconst,-1000) REGS(XREG)_CL=-1 SET USE(XREG,X'51',LITCONST,-1000) BREG=ANYGRBAR0 DUMPRXE(IC,BREG,0,CLNB,D+5); ! BYTES USED UP setuse(breg,X'51',Litconst,-1000) REGS(BREG)_CL=-1 PIX RR(SR,XREG,BREG) FORGET(BREG) DUMPRX(A,BREG,0,CLNB,D); ! ADD IN ORIGINAL ADDRESS %IF PARM_OPT#0 %START; ! FORCE IN CAP CHK PIX RR(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 PIX RR(LTR,XREG,XREG) PJUMP(BC,GLABEL,8,0) PIX RR(BCTR,XREG,0) PLABEL(GLABEL) GLABEL=GLABEL-1 c=regs(opnd2_xb+1)_CL regs(opnd2_xb+1)_CL=-1 EXECUTESS(XREG,MVC,OPND2_XB+1,1,BREG,1) regs(opnd2_xb+1)_CL=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,ANYGR,2) %UNLESS OPND2_FLAG=SCONST %AND OPND2_D=0 LOAD(OPND1,ANYGRBAR0,2) EVALREG=OPND1_XB testrass(evalreg,5) %if Parm_chk#0 %IF PARM_OPT#0 %AND OPND2_FLAG#SCONST %START KK=ANYGR DUMPRXE(IC,KK,0,EVALREG,0); ! FETCH CURRENT LENGTH PIX RR(CLR,OPND2_XB,KK) PPJ(2,9,NO) SET USE(KK,X'51',LITCONST,-1000) %FINISH PIX RR(AR,EVALREG,OPND2_XB) %AND FORGET(EVALREG) %UNLESS OPND2_FLAG=SCONST OPERAND USED(OPND2) OPND1_PTYPE=X'51' ->SUSE !*********************************************************************** !* THIS NEXT SECTION DEALS WITH ROUTINE CALLS AND PARAMETER * !* PASSING. ALSO STORING AND RECOVERY OF FN & MAP RESULTS * !*********************************************************************** TRIPSW(23): ! IOCP CALL D=OPND1_D EVALREG=1 %IF REGS(1)_CL#0 %THEN EVALREG=-1 LOAD(OPND2,EVALREG,2) %if d=7{printstring} %and parm_chk#0 %then %c testrass(opnd2_xb,x'35') OPERAND USED(OPND2) CIOCP(D,OPND2_XB); ! ALWAYS CONSTANTS EVALREG=1 OPERAND LOADED(OPND1,EVALREG,YES) ->STRES TRIPSW(24): ! PRECALL OPND1 HAS RT NAME TCELL==ASLIST(TAGS(OPND1_D)) CALL COMING(8) %IF TCELL_SLINK=0 %THEN D=0 %ELSE D=ASLIST(TCELL_SLINK)_S3 %IF D&255>5 %THEN D=D&X'7FFF'; ! CAN ONLY REGISTERISE 5 PARAMS %IF D&X'8000'#0 %START; ! PARAS SIMPLE %FOR C=0,1,D&15 %CYCLE D=D&X'7FFF' %UNLESS REGS(C)_CL=0 %REPEAT %FINISH %IF D&X'8000'#0 %START; ! STILL SIMPLE D=D&X'7FFF' %UNLESS APSSIMPLE=YES %FINISH %IF D&X'8000'#0 %THEN LAST PAR REG=0 %ELSE LAST PAR REG=14; ! LAST PAREMETER REG %CONTINUE TRIPSW(25): ! ROUTINE CALL (AFTER PARAMS) ! OPND1 HAS RT NAME %BEGIN %RECORD (REGF) %NAME REG SAVE IRS(8,B'110'); ! ANY INTERMEDIATES BOOTED TCELL==ASLIST(TAGS(OPND1_D)) C=TCELL_UIOJ>>4&15; ! ROUTINE LEVEL NO FILL SAVE AREA(LAST PAR REG-1) FORGETM(8) %IF TCELL_UIOJ&15=14 %START; ! EXTERNAL CALL DUMPM(LM,CODER,EPREG,GLAREG,TCELL_SNDISP) PIX RR(BALCODE-X'40',LINKREG,EPREG) %FINISHELSEIF TCELL_PTYPE&X'400'#0 %START DUMPRX(LGR,LINKREG,0,DISPREG(C),TCELL_SNDISP) PIX RS(LM,CODER,LINKREG,LINKREG,0) PIX RS(LM,5,10,LINKREG,20) PIX RR(LR,1,EPREG) PIX RX(LGR,EPREG,0,LINKREG,56) PIX RR(BALCODE-X'40',LINKREG,1) %FINISHELSESTART JJ=TCELL_SNDISP %IF JJ=0 %THEN JJ=GLABEL %AND TCELL_SNDISP=JJ %AND GLABEL=GLABEL-1 PJUMP(BALCODE,JJ,15,15) %FINISH %FOR C=4,1,CLNB-1 %CYCLE REG==REGS(C) %continue %if reg_cl<0; ! devastates loop optimising otherwise! %IF ((1<RES TRIPSW(26): ! RECOVER FN RESULT ! CALLED AFTER RETURN TO CALLER D=RESULT REG(PTYPE) %IF PTYPE=X'35' %START; ! STRING FN REGS(D)_CL=2 REGS(D)_CNT=1 regs(d)_link=addr(opnd1) OPND1_FLAG=10 OPND1_XB=D OPND1_D=0 %ELSE OPERAND LOADED(OPND1,D,YES) %IF PTYPE=X'33' %THEN OPND1_PTYPE=X'51' %FINISH %CONTINUE TRIPSW(27): ! RECOVER MAP RESULT ! CALLED AFTER RETURN TO CALLER opnd1_ptype=x'51'; ! map results 32 bits if booted OPERAND LOADED(OPND1,1,YES) %CONTINUE TRIPSW(28): ! PASS PARAMETER(1)= NORMAL VALUE LCELL==ASLIST(OPND1_XTRA&X'FFFF'); ! PARAM DESCTR CELL D=LCELL_ACC; ! PARAM_ACC %IF OPND1_PTYPE&7=5 %START; ! STRINGS BY VALUE - LABORIOUS TOPND_PTYPE=X'51'; TOPND_FLAG=10 TOPND_XB=WSPR; TOPND_D=LCELL_SNDISP+64 SSTRASS(TOPND,OPND2,D) FPPTR=FPPTR+D %CONTINUE %FINISH %IF OPND1_PTYPE&7=3 %START; ! RECORD BY VALUE C=(D+3)&(-4) %IF OPND2_FLAG=SCONST %THEN D=0 %ELSE D=1 %AND LOAD(OPND2,ANYGRBAR0,2) BULKM(D,C,WSPR,LCELL_SNDISP+64,OPND2_XB,0) OPERAND USED(OPND2) %CONTINUE %FINISH D=BYTES(OPND1_PTYPE>>4&15) %IF LAST PAR REG=14 %START; ! PARAMS TO STORE %IF SSVAROP(MVC,D,WSPR,LCELL_SNDISP+64,OPND2)=YES %THEN ->PARDONE %IF OPND1_PTYPE&7=2 %THEN C=-3 %ELSE C=-1 %FINISHELSE C=LAST PAR REG LOAD(OPND2,C,18); ! PARAMETERS ARE READ ONLY EVALREG=OPND2_XB ->PARCHK TRIPSW(29): ! GET 32 BIT ADDRESS %if opnd1_flag=dname %or opnd1_flag=indname %then %c note assment(-1,2,opnd1_d,opnd1_ptype&255) LOADAD(OPND1,ANYGRBAR0) EVALREG=OPND1_XB ->STRES TRIPSW(30): ! GET POINTER FOR %NAME %IF TYPE=5 %THEN EVALREG=ANY2SEQ %ELSE EVALREG=ANYGRBAR0 LOADPTR(OPND1,OPND2,EVALREG) EVALREG=OPND1_XB ->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=ANY2SEQ %AND D=8 %ELSE C=ANYGR %AND D=4 %IF LAST PAR REG<14 %THEN C=LAST PAR REG LOAD(OPND2,C,18); ! PARAMETERS ARE READ ONLY EVALREG=OPND2_XB ->PARCHK TRIPSW(32): ! PARAM PASSING(3) ARRAYS ! ALSO (4) PASS RT PARAM SAME CODE LCELL==ASLIST(OPND1_XTRA&X'FFFF') %IF CURRT_OPERN=PASS4 %THEN C=ANYGR %AND D=4 %ELSEIF CURRT_OPERN=PASS5 %THEN %C C=ANY2SEQ %AND D=8 %ELSE D=16 %AND C=ANY4SEQ %IF SSVAROP(MVC,D,WSPR,LCELL_SNDISP+64,OPND2)=YES %THEN ->PARDONE LOAD(OPND2,C,2) EVALREG=OPND2_XB PARCHK: ! KEEP AUTO STACKING CORRECT C=LCELL_SNDISP+64 %IF LAST PAR REG=14 %START DSTORE(EVALREG,D,-1,C) %ELSE REGS(EVALREG)_CL=3; ! REGISTERISED PARAM LAST PAR REG=LAST PAR REG+1 %FINISH PARDONE: FPPTR=LCELL_SNDISP+64+D OPERAND USED(OPND2) %IF LAST PAR REG=14; ! STILL USED IF IN REG %CONTINUE TRIPSW(69): ! PASS6 PASS WKAREA FOR STR&RECORDS ! NOT USED IN IBMIMP %CONTINUE TRIPSW(63): ! RTFP TURN RTNAME INTO FORMAL TCELL==ASLIST(TAGS(OPND1_D)) EVALREG=ANYGR %IF TCELL_PTYPE&X'400'#0 %START; ! NAM>0 PASS A FORMAL DFETCH(EVALREG,4,TCELL_UIOJ>>4&15,TCELL_SNDISP) %FINISHELSEIF TCELL_UIOJ&15=14 %START; ! EXTERNAL PASSED DUMPRXE(LA,EVALREG,0,GLAREG,TCELL_SNDISP) %FINISHELSESTART GET WSP(D,4); ! PARAM INTO LOCAL DUMPM(STM,CODER,GLAREG,CLNB,D) DUMPRX(ST,WSPR,0,CLNB,D+12) EVALREG=FINDREG(GR1,0) FORGET(EVALREG) JJ=TCELL_SNDISP %IF JJ=0 %THEN JJ=GLABEL %AND TCELL_SNDISP=JJ %AND GLABEL=JJ-1 PJUMP(LA,JJ,EVALREG,EVALREG) regs(evalreg)_cl=-1 DUMPRX(ST,EVALREG,0,CLNB,D+8) regs(evalreg)_cl=0 DUMPRX(LA,EVALREG,0,CLNB,D) %FINISH OPERAND LOADED(OPND1,EVALREG,NO) %CONTINUE TRIPSW(66): ! TYPE GENERAL PARAMETER ! OPND1 THE ACTUAL ! OPND2 HAS PTYPE&ACC %IF OPND1_FLAG=DNAME %AND OPND1_PTYPE&15=0 %START JJ=FINDSEQREG(GRSEQ,1) TCELL==ASLIST(TAGS(OPND1_D)) DFETCH(JJ,8,TCELL_UIOJ>>4&15,TCELL_SLINK) %FINISHELSEIF OPND2_D&7=5 %AND OPND2_D&X'C00'#0 %START ! STRING(ARRAY) NAMES LOAD(OPND1,ANY2SEQ,2); ! OPND1 IS 64 BIT POINTER JJ=OPND1_XB PIX RS(SLL,JJ,0,0,16) DUMPRX(O,JJ,0,CTABLEREG,WORD CONST(OPND2_D&255)) %FINISHELSESTART JJ=FINDSEQREG(GRSEQ,0) LOAD(OPND1,JJ+1,2); ! 32 BIT ADDRESS TYPE=OPND2_D&7; PREC=OPND2_D>>4&7 DUMPRX(LGR,JJ,0,CTABLEREG,WORD CONST(OPND2_D&X'FFFF00FF')) FORGET(JJ) REGS(JJ)_CL=1 OPND1_PTYPE=X'61' %FINISH OPND1_FLAG=9 OPND1_XB=JJ REGS(JJ)_LINK=ADDR(OPND1) REGS(JJ+1)_LINK=ADDR(OPND1) %CONTINUE !*********************************************************************** !* SECTION TO DEAL WITH SWITCHES INCLUDING ->SW(EXP) * !*********************************************************************** TRIPSW(33): ! DECLARE SWITCH OPND2 HAS BNDS %BEGIN %INTEGER D1,RANGE,LB %INTEGERNAME SSTL TCELL==ASLIST(TAGS(OPND1_D)) SSTL==CAS(4); ! TABLE BOUND FOR SST SSTL=(SSTL+3)&(-4); ! WRD BNDRY LB=OPND2_D RANGE=OPND2_XTRA-LB+1 D1=SSTL-SWITEMSIZE*LB; ! POINTER TO ELEMENT ZERO GLACA=(GLACA+3)&(-4) PD4(2,GLACA,0) TCELL_SNDISP=(GLACA)>>2; ! REMEMBER POINTER LOCATION RELOCATE(GLACA,D1,4); ! RELOCATE SST ADDRESS GLACA=GLACA+4 C=WORKA_PLABS(6); ! DEFAULT ASLIST(TCELL_SLINK)_S1=SSTL PSWITCH(SSTL,LB,OPND2_XTRA,SWITEMSIZE); ! DEFINE SWITCH IN SST PSDEFAULT(SSTL,C); ! PLABS(6) IS DEFAULT 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 PSLABEL(LCELL_S1,OPND2_D) FORGETM(14) %CONTINUE TRIPSW(35): ! GOTO SW LABEL TCELL==ASLIST(TAGS(OPND1_D)) LCELL==ASLIST(TCELL_SLINK); ! ONTO DISP & BOUNDS LOAD(OPND2,ANYGR BAR0,2) D=OPND2_XB C=TCELL_SNDISP %IF PARM_ARR#0 %START DUMPRX(CH,D,0,CTABLEREG,SHORT CONST(LCELL_S2)); ! CHK LB PPJ(4,6,NO) DUMPRX(CH,D,0,CTABLEREG,SHORT CONST(LCELL_S3)); ! CHK UB PPJ(2,6,NO) %FINISH EVALREG=ANYGRBAR0 DUMPRXE(LGR,EVALREG,0,GLAREG,4*C); ! LOAD SST ENTRY %IF SWITEMSIZE=2 %THEN PIX RR(AR,D,D) %ELSE PIX RS(SLL,D,0,0,2) DUMPRX(LGR-32+8*SWITEMSIZE,EVALREG,EVALREG,D,0) DUMPRX(BC,15,CODER,EVALREG,0) FORGET(EVALREG) FORGET(D) 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,KLCONSTS(3)) FORGET(OPND1_XB) %FINISHELSESTART; ! LONGLONGREALS LOAD(OPND1,ANYFRPAIR,2) D=OPND1_XB C=CLAIM OTHER FRPAIR(D) DUMPRX(LD,REGCODE(C),0,CTABLEREG,KLCONSTS(3)); ! 0.5 PIX RR(SDR,REGCODE(C+1),REGCODE(C+1)) PIX RR(AXR,REGCODE(D),REGCODE(C)) FREEANDFORGET(C) FREEAND FORGET(C+1) FORGET(D) FORGET(D+1) %FINISH TRIPSW(37): ! REAL TO INTEGER INTPT(OPND1) TRIPSW(78): ! Real to integer TRUNC(opnd1) %BEGIN %INTEGER WREG,RWREG,LREG,RLREG,TEMP PREC=PTYPE>>4 GETWSP(TEMP,2) %IF PREC<=6 %START; ! REAL AND LONGREAL ! ! THEORY ! CAN TRUNCATE BY USING AW AND A SUITABLE NONSTANDARD ZERO BUT THIS TRUNCATES ! TOWARDS ZERO WHEREAS IMP TRUNCATES TO - INFINITY. CONSEQUENTLY WE ADD 2**31 ! FIRST THEN TRUNCATE. NUMBER MUST BE POSITIVE IF IN RANGE AND TRUNCATION TO ZERO ! IS THE SAME AS TO - INFINITY. THE 2**31 IS TAKEN OFF AGAIN WITH THE XI. ! LOAD(OPND1,ANY FR,2); ! TO ANY FR LREG=OPND1_XB; RLREG=REGCODE(LREG) %IF PARM_OPT#0 %THENSTART DUMPRX(CD,RLREG,0,CTABLEREG,KLCONSTS(2)); ! =X'4880000000000000' PPJ(10,14,NO) %FINISH %IF CURRT_OPERN=RTOI3{TRUNC} %START DUMPRX(AW,RLREG,0,CTABLEREG,KLCONSTS(1)); ! x'4e00000000000000' DUMPRX(AW,RLREG,0,CTABLEREG,KLCONSTS(8)); ! x'4e00000080000000' %ELSE DUMPRX(AD,RLREG,0,CTABLEREG,KLCONSTS(2)); ! MAKE UNSIGNED & +VE %FINISH %IF PARM_OPT#0 %THEN PPJ(4,14,NO) %IF CURRT_OPERN#RTOI3 %THEN DUMPRX(AW,RLREG,0,CTABLEREG,KLCONSTS(1)) ! X'4E00000000000000' DUMPRX(STD,RLREG,0,CLNB,TEMP) DUMPSI(XI,X'80',CLNB,TEMP+4); ! CONVERT UNSIGNED TO SIGNED FREE AND FORGET(LREG) TEMP=TEMP+4; ! RESULT IN LOWER WORD %FINISHELSESTART; ! 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,CTABLEREG,KLCONSTS(4)); ! 2**63 NORMALISED %IF PARM_OPT#0 %START; ! CHECK RANGE PIX RR(LPDR,RWREG+2,RLREG) PIX RR(CDR,RWREG+2,RWREG); ! CHECK MOD(X)<2**63 NB EXCLUDES ! -2**64 WHICH IS VALID PPJ(10,14,NO) %FINISH DUMPRX(LD,RWREG,0,CTABLEREG,KLCONSTS(5)); ! X'5188000000000000' PIX RR(SDR,RWREG+2,RWREG+2); ! CLEAR BOTTOM HALF PIX RR(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' Note Lass(Bytes(opnd1_ptype>>4&15),currinf_Rbase,temp) %END %CONTINUE TRIPSW(38): ! INTEGER TO STRING AS TOSTRING GET WSP(D,1) LOAD(OPND1,ANYGR,2) DUMPRX(STC,OPND1_XB,0,CLNB,D+1) DUMPSI(MVI,1,CLNB,D) OPERAND USED(OPND1) OPND1_FLAG=LOCALIR OPND1_PTYPE=X'35' OPND1_D=CURRINF_RBASE<<16!D %CONTINUE TRIPSW(42): ! ARRAYHEAD ASSIGNMENT OPND2_PTYPE=X'71'; ! SO LOAD LOADS HEAD NOT ELEMNT ! AND DROP THRO TO PTR ASSGN TRIPSW(43): ! POINTER ASSIGNMENT D=BYTES(OPND2_PTYPE>>4&15) %IF D=16 %THEN C=ANY4SEQ %ELSEIF D=8 %THEN C=ANY2SEQ %ELSE C=ANYGR %IF OPND1_FLAG=DNAME %START; ! LOCAL PTR B=OPND1_XTRA TCELL==ASLIST(TAGS(OPND1_D)) EVALREG=-1 %IF SSVAROP(MVC,D,DISPREG(TCELL_UIOJ>>4&15),TCELL_SLINK&X'FFFF'+OPND1_XTRA&x'ffff', OPND2)=NO %THENSTART LOAD(OPND2,C,2) EVALREG=OPND2_XB DSTORE(EVALREG,D,TCELL_UIOJ>>4&15,TCELL_SLINK&X'FFFF'+OPND1_XTRA&x'ffff') %FINISH %IF B<0 %THEN NOTE ASSMENT(EVALREG,1,OPND1_D,OPND2_PTYPE&X'F0'!1) %FINISHELSESTART LOAD(OPND2,C,2) EVALREG=OPND2_XB LOAD(OPND1,ANYGRBAR0,X'61'); ! MODE1 LEAVE IN STORE & DONT CHECK GET OUT OF ACC(EVALREG,D,OPND1) OPERAND USED(OPND1) %FINISH OPERAND USED(OPND2) %CONTINUE TRIPSW(62): ! RECORD ASSIGNMENT LOAD(OPND1,ANYGRBAR0,X'52'); ! Read only no unass check %IF OPND2_FLAG=SCONST %THENSTART BULKM(0,CURRT_X1,OPND1_XB,0,0,OPND2_D) %FINISHELSESTART LOAD(OPND2,ANYGRBAR0,18) 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. %IF OPND1_FLAG=SCONST %and opnd1_d<4096*(max4kmult-3) %THENSTART LOAD(OPND2,ANYGRBAR0,0) %IF OPND2_FLAG=11 %THEN %Start OPND2_D=OPND2_D+OPND1_D OPND1=OPND2 operand revised(opnd1) ->STRES %finish %IF OPND2_FLAG#9 %THEN LOAD(OPND2,ANYGRBAR0,18) %IF OPND2_FLAG=9 %AND OPND2_XB>0 %START OPND2_FLAG=11; OPND2_D=OPND1_D OPND1=OPND2 ! ! An operand cant be both an IR and a base at the same time or boot out ! cant cope. Hence the need to force a load here in some rare case ! %if regs(opnd2_xb)_cnt>1 %then load(opnd1,anygrbar0,2) %else %c operand revised(opnd1) ->STRES %FINISH %FINISH LOAD(OPND1,ANYGRBAR0,2); ! THE RECORD BASE LOAD(OPND2,ANYGR,17); ! THE RELATIVE ACCESS EVALREG=OPND1_XB PUT(EVALREG,A,0,YES,OPND2) FORGET(EVALREG) OPERAND USED(OPND1) OPND1=OPND2 ->SUSE TRIPSW(65): ! AHADJ ARRAY MAPPING OPND1 1 ! HAS ADJUSTMENT OPND2 THE HEAD ! ARRAY PTYPE<<4!MODE IS IN CURRT_X1 OPND2_PTYPE=X'71' D=CHECKSEQREG(NEGREG(ANY4SEQ),NO); ! CHECK FOUR REGS AVAILABLE ! OPND1 MIGHT BE ARRAY ELEAMENT %IF D<0 %START; ! 4 REGS NOT AVAILABLE LOAD(OPND1,ANYGR,2); ! FETCH OPND1 BOOT OUT(OPND1_XB); ! AND PUT INTO LOCAL SPACE %FINISH LOAD(OPND2,ANY4SEQ,2); ! HEAD TO 4 GENERAL REGS LOAD(OPND1,ANY GR,1); ! BASE ADDRESS OR ADJMNT EVALREG=OPND2_XB; ! THE LOWEST OF 4 GRS %IF CURRT_X1&1=0 %START; ! ARRAY MAPPING OPND1 IS BASE PIX RR(SR,EVALREG,EVALREG+1) LOAD(OPND1,EVALREG+1,2) PIX RR(AR,EVALREG,EVALREG+1) %FINISHELSESTART PUT(EVALREG,A,0,NO,OPND1) PUT(EVALREG+1,A,0,YES,OPND1) FORGET(EVALREG+1) %FINISH FORGET(EVALREG) 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) %IF TARGET#IBMXA %THEN PIXRR(BALR,D,0) %ELSE PIX RRE(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) GLACA=(GLACA+3)&(-4) PD4(2,GLACA,0) C=PMARKER(0) PFIX(2,GLACA,1,C); ! GLAWORD TO ON ENTRY ADDRESS CURRINF_ONWORD=CURRINF_ONWORD!(GLACA) GLACA=GLACA+4 CLAIM THIS REG(0) CLAIM THIS REG(1) PIXRR(BCR,0,1) PIX RR(BCR,0,2) PIX RR(BCR,0,3); ! avoid put bug DUMPM(STM,0,1,CLNB,CURRINF_ONINF) DUMPRX(LGR,1,0,CLNB,CURRINF_ONINF+8) PIX RR(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) REGS(0)_CL=0 LOAD(OPND2,0,2) PIX RR(SLR,1,1) LINF==WORKA_LEVELINF(OPND1_D) D=2; ! the perm routine %IF LINF##CURRINF %START %IF CURRINF_FLAG<=2 %START C=PMARKER(4) PUSH(LINF_RAL,1,C,0) PSETOPD(C,1,CLNB<<12) PSETOPD(C,3,CLNB<<12!1) %FINISHELSESTART DUMPSS(MVC,44,WSPR,16,CLNB,16); ! OTHERWISE FRIG DISPLAY DUMPM(LM,4,10,CLNB,16); ! to get rigth lnb D=1; ! and use alternative subroutine %FINISH %FINISH operand used(opnd2) REGS(1)_CL=0 PPJ(0,D,YES); ! MONITOR %CONTINUE TRIPSW(77): ! dummy assignment to var ! used after "integer(addr(var))=" etc ! so optimiser knows var has changed NOTE ASSMENT(-1,3,OPND1_D,OPND1_PTYPE&255) %if opnd1_d<=worka_nnames %start; ! a valide name tcell==aslist(tags(opnd1_d)) size=bytes(opnd1_ptype>>4&15) notelass(size,tcell_uioj>>4&15,tcell_slink&X'FFFF'+opnd1_xtra&x'ffff') %finish %CONTINUE TRIPSW(79): ! PProfile call coming(8) dumpla(0,0,Glareg,profdata) regs(0)_cl=3 save irs(8,B'110') fill save area(0) dumpm(lm,12,14,glareg,known xref(6)) pix rr(BASR,15,14) call made %continue !*********************************************************************** !* SECTION FOR GENERATING CODE FOR INLINE ASSEMBLER * !*********************************************************************** TRIPSW(50): ! UC NOOP PCNOP(OPND1_D>>8,OPND1_D&255) %CONTINUE TRIPSW(51): ! UCB1 ONE REGISTER ASSEMBLER C=OPND1_D>>16 %IF C=X'FF01' %THEN USINGR=OPND1_D&15 %AND PUSING(USINGR) %ANDCONTINUE %IF C=X'FF02' %THEN PDROP(USINGR) %AND USINGR=12 %ANDCONTINUE %IF C=SVC %THEN PIX RR(SVC,OPND1_D>>4&15,OPND1_D&15) %ANDCONTINUE TRIPSW(52): ! UCB2 TWO REG RR &RRE ASSEMBLER C=OPND1_D>>16; D=OPND1_D&15; ! D IS REG1 %IF (TARGET=IBM %OR (HOST=EMAS %AND PARM_BITS1&1#0)) %AND C=BASR %THEN C=BALR %IF C>255 %THEN PCODEWORD(C<<16!D<<4!OPND1_D>>8&15) %ELSE %C PCODEHALF(C<<8!D<<4!OPND1_D>>8&15) FORGETM(14) %CONTINUE TRIPSW(53): ! UCB3 RX ASSEMBLER LOAD(OPND1,ANYGR,x'61'); ! with no unass check & ignore reg copy ! XTRA HAS OPCODE,R1 &INDEX ! OPND HAS DB NOW IN FLAG=10 FORM C=XTRA>>16 %IF (TARGET=IBM %OR (HOST=EMAS %AND PARM_BITS1&1#0)) %AND C=BAS %THEN C=BAL PIX RX(C,XTRA&15,XTRA>>8&15,OPND1_XB,OPND1_D) FORGETM(14) %CONTINUE TRIPSW(54): ! UCW ASSEMBLER WITH STORE OR SI FORMAT LOAD(OPND1,ANYGR,x'61'); ! with no unass check & ignore reg copy C=XTRA>>16 %IF C>255 %OR C=LPSW %OR C=SSM %OR C=TS %THEN PIX S(C,OPND1_XB,OPND1_D) %ELSE %C PIX SI(C,XTRA&255,OPND1_XB,OPND1_D) FORGETM(14) %CONTINUE TRIPSW(55): ! UCBW BYTE&WORD OPERAND ASSEMBLER ! IBM SS &SSE FORMATS C=XTRA>>16 LOAD(UOPND,ANYGR,x'61'); ! with no unass check & ignore reg copy LOAD(OPND1,ANYGR,x'61'); ! with no unass check & ignore reg copy %IF C>255 %THEN PIX SSE(C,UOPND_XB,UOPND_D,OPND1_XB,OPND1_D) %ELSE %C PIX SS(C,0,XTRA&X'1FF',UOPND_XB,UOPND_D,OPND1_XB,OPND1_D) FORGETM(14) %CONTINUE TRIPSW(59): ! UCNAM ACCESS TO NAMES FROM U-C ! IN IBM PASSES IST OPERAND OF 2OPND ! SS INSTRUCTIONS SINCE PORTABLE ASSEMBLER ! ONLY ALLOWS ONE OPERAND FORMATS UOPND=OPND1; ! SAVE IN OWN VARAIBLE %CONTINUE STRES: CURRT_OPTYPE<-OPND1_PTYPE %IF CURRT_CNT>1 %START ! USED MORE THAN ONCE, IN A REG %IF CURRT_OPERN#LASS %START ! AND NOT ALREADY STORED %IF OPND1_FLAG#9 %START D=(CURRT_OPTYPE&7-1)*8+CURRT_OPTYPE>>4&7 LOAD(OPND1,-WHICHREG(D),2) %FINISH EVALREG=OPND1_XB C=REGWORDS(CURRT_OPTYPE)>>4 REGS(EVALREG+D)_CNT=CURRT_CNT %FOR D=0,1,C-1 %IF CURRT_FLAGS&USED LATE#0 %THEN BOOT OUT(EVALREG) %FINISHELSESTART ! LASS EVALREG=OPND2_XB! REGS(EVALREG)_CL=0 C=BYTES(CURRT_OPTYPE>>4)<<24!CLNB<<16!OPND1_D SET USE(EVALREG,CURRT_OPTYPE,LOCALTEMP,C) %FINISH %FINISH %IF CURRT_CNT=0 %THEN OPERAND USED(OPND1) %REPEAT %IF PARM_DCOMP#0 %THEN CODEOUT %RETURN %ROUTINE SET LOCAL BASE !*********************************************************************** !* FIND OR SET UP A REGISTER FOR BRANCHING A SMALL DISTANCE FORWARD * !*********************************************************************** %INTEGER I,J %CONSTBYTEINTEGERARRAY CHOICE(0:9)=15,9,8,7,6,5,4,3,2,1; %RECORD (REGF) %NAME REG LOCAL BASE=CODER %IF 4095-MARGIN>CA %THENRETURN; ! CAN USE MAIN BASE REGISTER(GR12) %CYCLE J=0,1,9 I=CHOICE(J) REG==REGS(I) %IF REG_USE=BASEREG %AND 4095-MARGIN>CA-REG_INF1 %START LOCAL BASE=I REG_AT=WTRIPNO %RETURN %FINISH %REPEAT LOCAL BASE=FIND REG(GR1,0) PIX RR(BALCODE-X'40',LOCAL BASE,0) SET USE(LOCAL BASE,X'51',BASEREG,CA) PUSING(LOCAL BASE) %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 AND OPERAND FORM* !* MODE=2 DEVELOP OPERAND AND LOAD INTO SPECIFIED REG * !* 2**4 BIT SET IN MODE FOR READ ONLY OPERANDS * !* 2**5 BIT SET IF REGISTER COPY NOT WANTED * !* 2**6 SET IF UNASSIGNED CHECK NOT WANTED IN SPITE OF OPTION * !*********************************************************************** %INTEGER K,KK,D,PTYPE,PREC,TYPE,USE,INF,LEAVEINSTR,READONLY,X,CHKASS %RECORD (TRIPF) %NAME REFTRIP %RECORD (REGF) %NAME REQREG %RECORD (TAGF) %NAME TCELL %SWITCH SW(0:11) USE=0; INF=0 K=OPND_FLAG X=OPND_XTRA PTYPE=OPND_PTYPE TYPE=PTYPE&15 PREC=PTYPE>>4&15 CHKASS=PARM_CHK CHKASS=0 %IF 1<=0 %THEN REQREG==REGS(REG) %IF K>11 %THEN IMPABORT ->SW(K) SW(0): ! CONSTANT < 16 BITS %IF TYPE=1 %AND PREC<=5 %AND 0<=OPND_D<=4095 %AND LEAVEINSTR=0 %START %RETURNIF MODE=0; ! LAVE "LA" CONSTS USE=LITCONST; INF=OPND_D FIND USE(D,X'51',USE,INF) %IF D>=0 %THEN OPERAND LOADED(OPND,D,NO) %AND ->SW9 %IF MODE=2 %THENSTART %IF REG<0 %THENSTART REG=FIND REG(NEGREG(REG),0) REQREG==REGS(REG) %FINISHELSESTART %IF REQREG_primUSE=USE %AND REQREG_INF1=INF %THEN ->LDED %FINISH %IF INF=0 %THEN PIX RR(SLR,REG,REG) %ELSE DUMPRX(X'41',REG,0,0,INF) ->LDED %FINISH %FINISH SW(1): ! LONG CONSTANT %IF TYPE=5 %THEN ->SCONST %IF PREC=7 %THEN KK=ADDR(WORKA_A(OPND_D)) %ELSE KK=ADDR(OPND_D) %IF TYPE=1 %AND PREC=5 %AND MODE=2 %AND K=0 %AND X'FFFF8000'<=OPND_D<=X'7FFF' %THEN %C PREC=4 %AND PTYPE=X'41' %AND OPND_PTYPE=PTYPE %IF PREC=4 %THEN KK=KK+2 %if prec=3 %then kk=kk+3; ! const bytes and others 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 %AND (TCELL_PTYPE&15<3 %OR TCELL_PTYPE&x'300'#0 {array base}) %THEN %C USE=9 %AND INF=OPND_D OPND_XB=DISPREG(TCELL_UIOJ>>4&X'F') CHKASS=0 %IF OPND_XB=GLAREG; ! DONT CHECK GLA OPND_D=TCELL_SLINK&X'FFFF'+X&X'FFFF' OPND_XTRA=0 ->OPTLOAD LDED: SET USE(REG,PTYPE,USE,INF) NULLOAD: OPERAND LOADED(OPND,REG,NO) %RETURN SW(4): ! VIA DESC AT OFFSET FROM ! A COMPUTED POINTER REFTRIP==TRIPLES(OPND_D) OPND=REFTRIP_OPND1 LOAD(OPND,ANYGRBAR0,18) D=OPND_XB %IF X<0 %THEN X=0 %IF TYPE=5 %THEN X=X+4 KK=ANYGRBAR0 DUMPRXE(LGR,KK,0,D,X) %IF PARM_CHK#0 %THEN TESTRASS(KK,X'51') OPERAND USED(OPND) OPND_PTYPE=PTYPE&255 OPND_FLAG=10; OPND_XB=KK REGS(KK)_CL=2 REGS(KK)_CNT=1 REGS(KK)_LINK=ADDR(OPND) FORGET(KK) 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&X'FFFF' %IF TYPE=5 %AND X<0 %THEN D=D+4 %if tcell_uioj&x'F0'=X'E0' %Start inf=worka_ctable(d>>2) %if x>0 %then inf=inf+x %if inf<4095 %Start; ! Supervisor references to page 0 Opnd_flag=10; opnd_xb=0; opnd_d=inf ->optload %finish %finish INF=OPND_D FIND USE(KK,X'51',ADDROF,INF) %IF KK>0 %THENSTART %IF REGS(KK)_CL#0 %THEN REGS(KK)_CNT=REGS(KK)_CNT+1 %FINISHELSESTART KK=ANYGRBAR0 DUMPRXE(LGR,KK,0,DISPREG(TCELL_UIOJ>>4&15),D) %IF PARM_CHK#0 %and x'E0'#tcell_uioj&X'F0'#0 %THEN TESTRASS(KK,X'51') %FINISH SET USE(KK,X'51',ADDROF,INF) OPND_XB=KK REGS(KK)_CL=2 %AND REGS(KK)_CNT=1 %IF REGS(KK)_CL=0 OPND_FLAG=10 %IF X>=0 %THEN OPND_D=X %ELSE OPND_D=0 %AND USE=LOCALVAR ->OPTLOAD SW(6): ! INDIRECT WITH OFFSET REFTRIP==TRIPLES(OPND_D) OPND=REFTRIP_OPND1 %IF X<0 %THEN X=0 %IF OPND_FLAG=11 %START OPND_FLAG=10 OPND_D=OPND_D+X %FINISHELSESTART LOAD(OPND,ANYGRBAR0,18!64); ! no assigned check for dumped I-R D=OPND_XB OPND_FLAG=10 OPND_XB=D OPND_D=X %FINISH OPND_PTYPE=PTYPE&255 ->OPTLOAD SW(7): ! I-R IN A STACK FRAME USE=LOCALTEMP %UNLESS TYPE=5 OPND_FLAG=10 OPND_XB=DISPREG(OPND_D>>16) CHKASS=0 %IF OPND_XB=GLAREG; ! DONT CHECK GLA CHKASS=0 %IF TYPE=5; ! Dont check string wk areas ! Check made as wa initialised OPND_D=OPND_D&X'FFFF' INF=BYTES(PREC)<<24!OPND_XB<<16!OPND_D ->OPTLOAD SW(8): ! TRIPLE REFTRIP==TRIPLES(OPND_D) OPND=REFTRIP_OPND1 LOAD(OPND,REG,READONLY!MODE!64); ! no assigned check for dumped I-R OPND_PTYPE=PTYPE&255 %RETURN SW(9): SW9: ! I-R IN A REGISTER ! MAY NEED SHUFFLED %IF MODE=2 %START %IF REGS(OPND_XB)_CL>=0 %AND REGS(OPND_XB)_CNT<=1 %THENSTART %IF OPND_XB=REG %THEN REQREG_LINK=ADDR(OPND) %ANDRETURN %IF REG<0 %AND ACCEPTABLE REG(NEGREG(REG),OPND_XB)=YES %THEN %C REG=OPND_XB %AND REQREG==REGS(REG) %AND OPERAND USED(OPND) %AND ->NULLOAD %FINISH %IF READONLY#0 %AND (REG=OPND_XB %OR (REG<0 %AND %C ACCEPTABLE REG(NEGREG(REG),OPND_XB)=YES)) %THENRETURN %IF REG<0 %THEN REG=FINDREG(NEGREG(REG),0) %AND REQREG==REGS(REG) %IF REG<=15 %THEN KK=LR %ELSE KK=LDR %IF REG#OPND_XB %START PIX RR(KK,REGCODE(REG),REGCODE(OPND_XB)) COPY USE(REG,OPND_XB) %IF PTYPE=X'61' %OR PTYPE=X'72' %THEN %C PIX RR(KK,REGCODE(REG+1),REGCODE(OPND_XB+1)) %AND COPY USE(REG+1,OPND_XB+1) %FINISH OPERAND USED(OPND) ->NULLOAD %FINISH %RETURN SW(10): ! DEVELOPPED BD FORM %IF CLNB<=OPND_XB<=13 %THEN USE=LOCALTEMP %AND INF=BYTES(PREC)<<24!OPND_XB<<16!OPND_D OPTLOAD: %IF USE>0 %AND LEAVEINSTR=0 %THENSTART FIND USE(D,OPND_PTYPE&255,USE,INF) %IF D>=0 %AND (READONLY#0 %OR REGS(D)_CL=0) %THEN %C OPERAND USED(OPND) %AND OPERAND LOADED(OPND,D,NO) %AND ->SW9 %FINISH %IF MODE=2 %THENSTART %IF TYPE=5 %THEN LOADAD(OPND,REG) %ANDRETURN GETINACC(REG,BYTES(PREC),OPND) %IF CHKASS#0 %THEN TESTRASS(REG,OPND_PTYPE) OPERAND USED(OPND) REQREG==REGS(REG) ->LDED %FINISH %IF TYPE=5 %AND OPND_XB>15 %THEN REDUCE BASE(OPND) %IF CHKASS#0 %THEN TESTVASS(OPND) %RETURN SW(11): ! OPERAND IS CONSTRUCTED BY ! DOING A LA ON OPERAND %IF MODE>0 %START DUMPRXE(LA,REG,OPND_XB>>4,OPND_XB&15,OPND_D) OPERAND USED(OPND) REQREG==REGS(REG) ->LDED %FINISH %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 %RECORD (RD) TOPND TOPND=OPND %IF TOPND_FLAG=8 %THEN TOPND=TRIPLES(TOPND_D)_OPND1; ! back 1 reference ->IN STORE %UNLESS TOPND_FLAG=9 %AND REGS(TOPND_XB)_CNT<=1 TOTHER=TOPND_XB!!1 %IF REGS(TOTHER)_CL=0 %THEN ->SPAIR PAIR=CHECKSEQREG(NEGREG(-4-TYPE),YES); ! pair available without booting? %IF PAIR>=0 %THEN ->INSTORE; ! yes so shuffle %UNLESS (REGS(TOTHER)_CL=1 %OR REGS(TOTHER)_CL=3) %AND REGS(TOTHER)_AT#WTRIPNO %THEN %C ->INSTORE BOOT OUT(TOTHER) SPAIR: ! simple case use the same pair as opnd in PAIR=TOTHER&X'FE' LOAD(OPND,PAIR+ODDEVEN,2) REGS(PAIR)_CL=1 REGS(PAIR+1)_CL=1 FORGET(PAIR) FORGET(PAIR+1) ->FIN INSTORE: PAIR=FINDSEQREG(NEGREG(-4-TYPE),1) REGS(PAIR+ODDEVEN)_CL=0 LOAD(OPND,PAIR+ODDEVEN,2) FIN: OPND_XB=PAIR; ! ALWAYS LH MEMBER %END %ROUTINE LOADAD(%RECORD (RD) %NAME OPND, %INTEGER REG) !*********************************************************************** !* MUCH AS LOAD BUT PRODUCES THE 32 BIT ADDRESS OF OPERAND * !* IMPABORT ON NON RELEVANT ALTERNATIVES OF OPND * !************************************************************************ %RECORD (TRIPF) %NAME REFTRIP %RECORD (TAGF) %NAME TCELL %INTEGER B,D,TYPE,X,USE,INF %SWITCH SW(0:11) TYPE=OPND_PTYPE&7 X=OPND_XTRA USE=0; INF=0 ->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 %IF X<=0 %THEN USE=ADDROF %AND INF=OPND_D TCELL==ASLIST(TAGS(OPND_D)) D=-1 %IF X<=0 %THEN FIND USE(D,X'51',USE,INF) %IF D>0 %AND regs(d)_cl=0 %and %c (D=REG %OR (REG<0 %AND ACCEPTABLE REG(NEGREG(REG),D)=YES)) %THEN %C REG=D %AND ->LDED DFETCHAD(REG,TCELL_UIOJ>>4&15,TCELL_SLINK&X'FFFF'+X&X'FFFF') LDED: OPND_PTYPE=X'51'; ! 32 BIT ADDRESS IS INTEGER OPERAND LOADED(OPND,REG,NO) SET USE(REG,X'51',USE,INF) %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,18) D=OPND_XB %IF X<0 %THEN X=0 %IF TYPE=5 %THEN X=X+4; ! TO ADDRESS PART OF STR HEADER DUMPRXE(LGR,REG,0,D,X) OPERAND USED(OPND) ->LDED SW(5): ! INDIRECT VIA PTR %IF X<=0 %THEN USE=ADDROF %AND INF=OPND_D TCELL==ASLIST(TAGS(OPND_D)) FIND USE(D,X'51',ADDROF,OPND_D); ! LOOK FOR BAS PTR %IF D>0 %THEN ->FND B=TCELL_UIOJ>>4&15 D=TCELL_SLINK&X'FFFF' %IF (TYPE=0 %OR TYPE=5) %AND TCELL_PTYPE&7#3 %AND X<0 %THEN D=D+4 ! 2words for %NAME %STRINGNAME ex record DFETCH(REG,4,B,D) INC: %IF X>0 %THEN INC REG(REG,X,YES) ->LDED FND: ! BASE ADDRESS FOUND %IF X<0 %THEN X=0 %IF REG>=0 %THEN DUMPLA(REG,0,D,X) %AND ->LDED %IF ACCEPTABLEREG(NEGREG(REG),D)=YES %AND REGS(D)_CL=0 %THEN REG=D %AND ->INC ! where already claimed further optimisation ! are possible too but attempt 1 caused bugs DUMPRXE(LA,REG,0,D,X) ->LDED SW(6): ! INDIRECT OFFSET REFTRIP==TRIPLES(OPND_D) OPND=REFTRIP_OPND1 %IF OPND_FLAG=11 %AND X>0 %THEN OPND_D=OPND_D+X %AND X=0 LOAD(OPND,REG,2) REG=OPND_XB %IF X>0 %THEN INC REG(REG,X,YES) OPERAND USED(OPND) ->LDED SW(7): ! LOCAL-IR IN BASE&OFFSET FORM B=OPND_D>>16 D=OPND_D&X'FFFF' OPND_XTRA=0 DFETCHAD(REG,B,D); ->LDED SW(8): ! A TRIPLE IMPABORT %UNLESS TYPE=5; ! ONLY STRING INTERMEDIATES HAVE ADDRESS REFTRIP==TRIPLES(OPND_D) OPND=REFTRIP_OPND1 LOADAD(OPND,REG) %RETURN SW(10): SW10: ! DEVELOPPED BD FORM DUMPRXE(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 (TRIPF) %NAME REFTRIP %RECORD (TAGF) %NAME TCELL %INTEGER K,X,WREG,B,DVNAME %SWITCH SW(0:11) PTYPE=OPND_PTYPE K=OPND_FLAG %IF PTYPE&7#5 %THEN LOADAD(OPND,REG) %ANDRETURN X=OPND_XTRA %IF REG<0 %THEN REG=FINDREG(NEGREG(REG),1) WREG=REG+1 REGS(REG)_LINK=ADDR(OPND) REGS(WREG)_LINK=ADDR(OPND) DVNAME=-1 ->SW(K) SW(*): ! INVALID IMPABORT SW(2): ! DNAME DVNAME=OPND_D TCELL==ASLIST(TAGS(DVNAME)) DFETCHAD(WREG,TCELL_UIOJ>>4&15,TCELL_SLINK&X'FFFF'+X&X'FFFF') STR: ! SET TOP HALF OF STRING DESC ! MESSY FOR STRING ARRAY NAMES ! OPND2_XTRA=BML<<16!DML PTYPE=CURRT_X1>>16; ! BACK TO REFFED VARS PTYPE %IF OPND2_FLAG=SCONST %THENSTART; ! STRING LENGTH KNOWN DUMPRX(LA,REG,0,0,OPND2_D&X'FFFF'+1); ! DML IS ACC-1 DOES NOT INCLUDE LENGTHBYTE ->LDED %FINISH %IF PTYPE&X'300'=0 %START; ! STRINGNAMES DML&BML FOR HEAD CHOP OPERAND(OPND2,X'51',0) LOAD(OPND2,REG,2) OPERAND USED(OPND2) ->LDED %FINISH B=SET DVREG(ANYGRBAR0,DVNAME,OPND2) DUMPRX(LGR,REG,0,B,8) OPERAND USED(OPND2) LDED: OPND_PTYPE=X'61' OPERAND LOADED(OPND,REG,YES) %RETURN SW(4): ! VIA PTR AT OFFSET FROM COMPUTER ADDDRESS REFTRIP==TRIPLES(OPND_D) OPND=REFTRIP_OPND1 LOAD(OPND,ANYGR BAR0,18) B=OPND_XB %IF X<0 %THEN X=0 DUMPM(LM,REG,WREG,B,X) OPERAND USED(OPND) ->LDED SW(5): ! INDIRECT VIA DICT SW(6): ! INDIRECT OFFSET SW(7): ! LOCAL IR (OCCURRS WHEN EXPR PASSED BT REF) SW(10): ! DEVELOPPED BD FORM ! NORMALLY ARRAY ELEMENTS ONLY LOADAD(OPND,WREG) ->STR %END %INTEGERFN SSVAROP(%INTEGER OP,SIZE,BASE,DISP, %RECORD (RD) %NAME RHOPND) !*********************************************************************** !* ATTEMPTS TO ASSIGN BY MVC(ETC) WHERE THIS IS ADVANTAGEOUS * !* SET RESULT=YES IF ASSIGNMENT MADE * !*********************************************************************** %INTEGER I,TYPE,PREC %RESULT=NO %IF CURRT_CNT>0; ! IF REUSED GO VIA REGISTERS %RESULT=NO %IF RHOPND_FLAG=INAREG; ! ALREADY LOADED %RESULT=NO %IF DISP>4095 TYPE=RHOPND_PTYPE&7 PREC=RHOPND_PTYPE>>4&15 %IF TYPE=1 %AND RHOPND_FLAG<=1 %START; ! RHS IS A CONSTANT %IF SIZE=1 %AND 0<=RHOPND_D<=255 %START DUMPSI(OP-X'40' {mvc to mvi},RHOPND_D,BASE,DISP) %RESULT=YES %FINISH %RESULT=NO %IF SIZE<=4 %AND 0<=RHOPND_D<=4095; ! LA QUICKER IN THESE CASES %FINISH %RESULT=NO %UNLESS SIZE=BYTES(PREC) %IF TYPE=2 %START %IF PREC=7 %THEN I=ANYFRPAIR %ELSE I=ANY FR %FINISHELSESTART %IF PREC=6 %THEN I=ANYGRPAIR %ELSE I=ANYGR %FINISH %RESULT=NO %IF RHOPND_FLAG=REFTRIP %AND TRIPLES(RHOPND_D)_OPND1_PTYPE>>4&15#PREC ! size changed by dump&reload LOAD(RHOPND,I,1) %RESULT=NO %UNLESS RHOPND_FLAG=10 %AND RHOPND_XB<=15 %AND RHOPND_D<=4095 DUMPSS(OP,SIZE,BASE,DISP,RHOPND_XB,RHOPND_D) %RESULT=YES %END %INTEGERFN LOADSTRLEN(%INTEGER REGORMASK, %RECORD (RD) %NAME OPND) !*********************************************************************** !* Gets a string length byte into a register for executing an * !* assignment or compare. When opnd is a work the area the byte * !* is almost always hanging around * !*********************************************************************** %INTEGER XREG %RECORD (RD) TOPND TOPND=OPND; ! keep a copy topnd=triples(topnd_d)_opnd1 %while topnd_flag=reftrip LOAD(OPND,REGORMASK,1); ! to base & disp form %IF TOPND_FLAG=LOCALIR %START TOPND_PTYPE=x'31' LOAD(TOPND,REGORMASK,2) %RESULT=TOPND_XB %ELSE XREG=REGORMASK DUMPRXE(IC,XREG,0,OPND_XB,OPND_D) SET USE(XREG,x'51',LITCONST,-1000) %RESULT=XREG %FINISH %END %ROUTINE SSTRASS(%RECORD (RD) %NAME LHOPND,RHOPND, %INTEGER ACC) !*********************************************************************** !* DOES SIMPLE STRING ASSIGNMENTS WHEN ACC OF LHS IS KNOWN * !*********************************************************************** %INTEGER C,D D=RHOPND_XTRA; ! RHS LENGTH IF A CONST %IF RHOPND_FLAG=LCONST %AND D0 %THEN FIND USE(I,X'51',DVBASE,ANAME) %IF I>0 %THEN OPERAND LOADED(DOPND,I,NO) %ANDRESULT=I %FINISH DOPND_PTYPE=DOPND_PTYPE&X'FF00'!X'51'; ! CHOP DOWN PTYPE SO ONLY ! DVPOINTER NOT WHOLE HEAD WILL BE LOADED CHOP OPERAND(DOPND,X'51',8) LOAD(DOPND,WHICH,18) WHICH=DOPND_XB %IF ANAME>0 %THEN SET USE(WHICH,X'51',DVBASE,ANAME) %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,MAXD DVNAME=XTRA&X'FFFF'; ! ZERO FOR ARRAYS IN RECORDS DVPOS=-1 DACC=-1; ! EL SIZE NOT KNOWN %IF OPND2_FLAG=SCONST %THEN DVPOS=OPND2_D MAXD=D; ! NO OC DIMENSIONS OF ARRAY DVD=3*C; DVREG=-1 %IF DVPOS>0 %OR C=1 %START LOAD(OPND1,ANYGR BAR0,2) IREG=OPND1_XB %ELSE; ! full multiply needed LOADPAIR(1,1,OPND1) IREG=OPND1_XB+1 OPND1_XB=IREG %FINISH %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) %FINISHELSESTART ! FOR FIRST DIMENSION USE DACC IF KNOWN ! ELSE THE STRIDE IN ARRAYHEAD ! FOR SECOND OF 2 DIM USE STRIDE IN AH ! ALL OTHER CASES AND BOUND CHECKS ! NEED TO GO VIA THE DOPEVECTOR %IF DVNAME>0 %START; ! INFO AVAILABLE FROM TAGS DVPTYPE=ASLIST(TAGS(DVNAME))_PTYPE %IF DVPTYPE&X'C00'=0 %THEN DACC=ASLIST(TAGS(DVNAME))_ACC %IF DVPTYPE&7<=2 %THEN DACC=BYTES(DVPTYPE>>4&15) %FINISH %IF PARM_ARR#0 %THENSTART DVREG=SET DVREG(-2,DVNAME,OPND2) BCHECK(IREG,DVREG,4*DVD) %FINISH %IF DACC>0 %AND C=1 %THENSTART SCALE(IREG,DACC) %FINISHELSEIF DVREG<0 %AND DACC<0 %AND C=1=MAXD %START CHOP OPERAND(OPND2,X'41',14) LOAD(OPND2,ANYGR,X'61'); ! MODE1 LEAVE IN STORE & DONT CHECK PUT(IREG,MH,0,YES,OPND2) %FINISHELSEIF DVREG<0 %AND C=2=MAXD %START CHOP OPERAND(OPND2,x'51',12) LOAD(OPND2,ANYGR,x'41') PUT(IREG-1,M,0,YES,OPND2) FREE AND FORGET(IREG-1) %FINISHELSESTART %IF DVREG<0 %THEN DVREG=SET DVREG(-2,DVNAME,OPND2) %IF C=1 %THEN DUMPRX(MH,IREG,0,DVREG,4*DVD+10) %ELSE %C DUMPRX(M,IREG-1,0,DVREG,4*DVD+8) %AND FREE AND FORGET(IREG-1) %FINISH %IF DVREG>0 %THEN OPERAND USED(OPND2) %FINISH FORGET(IREG) %UNLESS DACC=1 %RETURN %ROUTINE SCALE(%INTEGER IREG,DACC) !*********************************************************************** !* SCALE AN INDEXING REG AS EFFICIENTLY AS POSSIBLE * !*********************************************************************** %INTEGER SH,RES %IF DACC<=1 %THENRETURN %IF DACC=2 %THEN PIX RR(AR,IREG,IREG) %ANDRETURN RES=DACC; SH=0 SH=SH+1 %AND RES=RES>>1 %WHILE RES&1=0 %IF RES=1 %THEN PIX RS(SLL,IREG,0,0,SH) %ANDRETURN %IF DACC<=X'7FFF' %START DUMPRX(MH,IREG,0,CTABLEREG,SHORT CONST(DACC)) %RETURN %FINISH %IF IREG&1#0 %AND REGS(IREG-1)_CL=0 %START DUMPRX(M,IREG-1,0,CTABLEREG,WORD CONST(DACC)) FORGET(IREG-1) %RETURN %FINISH %IF RES<=X'7FFF' %START DUMPRX(MH,IREG,0,CTABLEREG,SHORT CONST(RES)) PIX RS(SLL,IREG,0,0,SH) %RETURN %FINISH IMPABORT %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 WORK WORK=FIND REG(GR0,1) PIX RR(SLR,WORK,WORK) FORGET(WORK) SET LOCAL BASE PIX RR(SLR,WORK,REG+1) PJUMP(BC,GLABEL,3,0) PIX RX(A,REG,0,CTABLEREG,KWCONSTS(3)); ! =F'1' PLABEL(GLABEL) GLABEL=GLABEL-1 PIX RR(LCR,REG,REG) PIX RR(LR,REG+1,WORK) FORGET(REG); FORGET(REG+1) FREE AND FORGET(WORK) %END %ROUTINE STARSTAR !*********************************************************************** !* PLANT IN-LINE CODE FOR EXPONENTIATION * !* THERE IS NO EXPONENT RABGE CHECKING ON IBMIMP80 * !*********************************************************************** %INTEGER TYPEP,PRECP,WORK,INTREG,COUNT,RREG,WMASK,LVAL,OPCODE,TM PTYPE=OPND1_PTYPE&255 TYPEP=PTYPE&7; PRECP=PTYPE>>4&15 TM=WORD CONST(X'9100E003'+KWCONSTS(3)); ! TEST UNDER MASK OF 1 %IF TYPEP=1 %START WORK=FINDSEQREG(GRPAIR,1) LOADPAIR(1,1,OPND1) LOAD(OPND2,ANY GR,2) RREG=OPND1_XB COUNT=OPND2_XB PIX RX(LA,WORK+1,0,0,1) SET LOCAL BASE %if local base#coder %then regs(local base)_cl=-1 PIX RR(LTR,COUNT,COUNT) PPJ(4,7,NO); ! NEGATIVE INTEGER EXPONOENTS NONSENSE PLABEL(GLABEL) DUMPRX(EX,COUNT,0,CTABLEREG,TM) PJUMP(BC,GLABEL-1,8,0) PIX RR(MR,WORK,RREG+1) %IF PARM_OPT#0 %THENSTART PIX RS(SLDA,WORK,0,0,32) PIX RR(LR,WORK+1,WORK) %FINISH PLABEL(GLABEL-1); ! LABEL AFTER PRODUCT PIX RX(SRA,COUNT,0,0,1) PJUMP(BC,GLABEL-2,8,0) PIX RR(MR,RREG,RREG+1) %IF PARM_OPT#0 %THENSTART PIX RS(SLDA,RREG,0,0,32) PIX RR(LR,RREG+1,RREG) %FINISH PJUMP(BC,GLABEL,15,0) PLABEL(GLABEL-2) GLABEL=GLABEL-3 FORGET(RREG) FREE AND FORGET(RREG+1) EVALREG=WORK+1 FREE AND FORGET(WORK) %FINISHELSESTART %IF PRECP=5 %THEN OPCODE=MER %AND WMASK=FR0 %AND LVAL=-3 %IF PRECP=6 %THEN OPCODE=MDR %AND WMASK=FR0 %AND LVAL=-3 %IF PRECP=7 %THEN OPCODE=MXR %AND WMASK=FRPAIR %AND LVAL=-6 ! ! NOW REGISTERS CAN BE OBTAINED FOR THE IN-LINE SUBROUTINE ! WORK HOLDS INITIALLY 1 PRIOR TO MULTIPLICATION ! INTREG HOLDS THE EXPONENT AS CALCULATED ! COUNT HOLDS A +VE VERSION OF INTREG FOR COUNTING THE MULTIPLIES ! RREG HOLD THE OPERAND. ! WORK=FINDREG(WMASK,1) LOAD(OPND1,LVAL,2); ! OPERAND TO ANY SUITABLE LOAD(OPND2,ANY GR,2); ! EXPONENT TO ANY GENERAL REG RREG=OPND1_XB INTREG=OPND2_XB ! ! GET '1' INTO WORK IN APPROPIATE FORM ! DUMPRX(LDCODE(8+PRECP),REGCODE(WORK),0,CTABLEREG,KLCONSTS(7)) ! =D'1' %IF PRECP=7 %THEN PIX RR(SDR,REGCODE(WORK+1),REGCODE(WORK+1)) ! ! ALLOW FOR ZERO :- XX**0=1 FOR ALL XX ! ALSO ALLOW FOR X**(-N) WHICH IS 1/(X**N) FOR ALL X & N ! COUNT=FINDREG(GR1,1) PIX RR(LPR,COUNT,INTREG) SET LOCAL BASE %if local base#coder %then regs(local base)_cl=-1 PLABEL(GLABEL) DUMPRX(EX,COUNT,0,CTABLEREG,TM) PJUMP(BC,GLABEL-1,8,0); ! J(BOTTOM BIT=0) ROUND NEXT INSTRN PIX RR(OPCODE,REGCODE(WORK),REGCODE(RREG)) PLABEL(GLABEL-1) PIX RX(SRA,COUNT,0,0,1); ! SHIFT OFF BOTTOM BIT PJUMP(BC,GLABEL-2,8,0); ! EXIT IF ALL ZERO PIX RR(OPCODE,REGCODE(RREG),REGCODE(RREG)); ! SQUARE OPERAND PJUMP(BC,GLABEL,15,0) PLABEL(GLABEL-2) ! ! FOR REAL EXPONENTS CHECK IF NEGATIVE AND EVALUATE INVERSE ! PIX RR(LTR,INTREG,INTREG) PJUMP(BC,GLABEL-3,2,0); ! BP END OF EXP ROUTINE DUMPRX(LDCODE(8+PRECP),REGCODE(RREG),0,CTABLEREG,KLCONSTS(7)) ! =D'1' %IF PRECP#7 %THENSTART PIX RR(DDR-MDR+OPCODE,REGCODE(RREG),REGCODE(WORK)) PIX RR(LDR-MDR+OPCODE,REGCODE(WORK),REGCODE(RREG)) %FINISHELSESTART PIX RR(SDR,REGCODE(RREG+1),REGCODE(RREG+1)); ! CLEAR BTM 64 BITS PIX RRE(DXR,REGCODE(RREG),REGCODE(WORK)) PIX RR(LDR,REGCODE(WORK),REGCODE(RREG)) PIX RR(LDR,REGCODE(WORK+1),REGCODE(RREG+1)) %FINISH FORGET(RREG) FREE AND FORGET(INTREG) EVALREG=WORK PLABEL(GLABEL-3) GLABEL=GLABEL-4 %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 local base#coder %then regs(local base)_cl=0 FREE AND FORGET(COUNT) %END %ROUTINE REALEXP !*********************************************************************** !* CALLS A PERM ROUTINE TO PERFORM REAL**REAL * !*********************************************************************** CALL COMING(8) LOAD(OPND1,-B3,2) PIX RS(STD,REGCODE(OPND1_XB),0,WSPR,64) OPERAND USED(OPND1) SAVE IRS(8,b'110') FILL SAVE AREA(14) forgetm(8) DUMPRX(LM,12,14,GLAREG,KNOWN XREF(2)) PIXRR(BALCODE-x'40',LINKREG,EPREG) OPERAND LOADED(OPND1,16,YES) LOAD(OPND2,-B3,x'11') PUT(16,MD,0,YES,OPND2) PIX RS(STD,0,0,WSPR,64) OPERAND USED(OPND1) SAVE IRS(8,b'1110') FILL SAVE AREA(14) forgetm(8) DUMPRX(LM,12,14,GLAREG,KNOWN XREF(3)) PIXRR(BALCODE-x'40',LINKREG,EPREG) CALL MADE EVALREG=16 %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 PIX RR(MR,EVALREG-1,EVALREG) %IF PARM_OPT#0 %THEN PIX RS(SLDA,EVALREG-1,0,0,32) %AND %C PIX RR(LR,EVALREG,EVALREG-1) I=I>>1 %REPEAT %WHILE MULTS>0 %CYCLE MULTS=MULTS-1 DEST=DEST-4 DUMPRX(M,EVALREG-1,0,WSPR,DEST) %IF PARM_OPT#0 %THEN PIX RS(SLDA,EVALREG-1,0,0,32) %AND %C PIX RR(LR,EVALREG,EVALREG-1) %REPEAT REGS(EVALREG-1)_CL=0 FORGET(EVALREG-1) %RETURN %FINISH PREC=PTYPE>>4&7 SIZE=BYTES(PREC) J=-3; ! ANF FR %IF PREC=7 %THEN J=-6 %AND MULT=MXR %ELSEIF PREC=6 %THEN MULT=MDR %ELSE MULT=MER LOAD(OPND1,J,2) EVALREG=OPND1_XB FORGET(EVALREG) %WHILE I>1 %CYCLE %IF I&1#0 %START DSTORE(EVALREG,SIZE,-1,DEST) DEST=DEST+SIZE MULTS=MULTS+1 %FINISH PIX RR(MULT,REGCODE(EVALREG),REGCODE(EVALREG)) I=I>>1 %REPEAT %IF MULTS=0 %THENRETURN; ! **2,**4 ETC %IF PREC=7 %START REG=CLAIM OTHERFRPAIR(EVALREG) FORGET(EVALREG+1) FREE AND FORGET(REG) FREE AND FORGET(REG+1) %FINISH %WHILE MULTS>0 %CYCLE DEST=DEST-SIZE %IF PREC<=6 %THENSTART DUMPRX(MULT+X'40',REGCODE(EVALREG),0,WSPR,DEST) %FINISHELSESTART DFETCH(REG,16,-1,DEST) PIX RR(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,CNTRL,BOOTMASK %RECORD (REGF) %NAME REG %IF MASK&X'0F000000'#0 %THENRESULT=FINDSEQREG(MASK,CLVAL) L=MASK>>16&255 U=MASK&255 %FOR CNTRL=L,1,U %CYCLE I=GRMAP(CNTRL) 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) ! BOOTMASK=1<<3; ! BOOT PARAMETERS FIRST AGN: LASTUSED=-1 LASTREG=-1 %FOR CNTRL=L,1,U %CYCLE I=GRMAP(CNTRL) REG==REGS(I) ->FOUND %IF REG_CL=0 %IF REG_AT#WTRIPNO %AND 1<LASTUSED %THEN LASTUSED=USED %AND LASTREG=I %FINISH %REPEAT %IF LASTREG>=0 %THENSTART BOOT OUT(LASTREG) I=LASTREG REG==REGS(I) ->FOUND %FINISH %IF BOOTMASK&(1<<1)=0 %THEN BOOTMASK=BOOTMASK!(1<<1) %AND ->AGN %IF BOOTMASK&(1<<2)=0 %THEN BOOTMASK=BOOTMASK!(1<<2) %AND ->AGN IMPABORT FOUND: ! REG HAS BEEN FOUND %IF CLVAL#0 %THEN %Start REG_CL=CLVAL REG_LINK=-1 reg_at=wtripno REG_CNT=1 FORGET(I) %finish %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,CNTRL,MISS,NREGS,OUTER %RECORD (REGF) %NAME REG L=MASK>>16&255 U=MASK&255 NREGS=MASK>>24&7 %FOR OUTER=0,1,1 %CYCLE %FOR CNTRL=L,1,U %CYCLE I=GRMAP(CNTRL) MISS=0 %FOR J=0,1,NREGS %CYCLE REG==REGS(I+J) MISS=1 %UNLESS REG_CL=0 %AND (OUTER#0 %OR REG_USE=0) %REPEAT ->FOUND %IF MISS=0 %REPEAT %REPEAT %IF PARM_DCOMP#0 %START PRINTSTRING(" find seqreg") PRHEX(MASK,8) NEWLINE PRINTUSE %FINISH I=CHECKSEQREG(MASK,NO); ! USE MORE ELABORATE CODE IN CHECK %IF PARM_DCOMP#0 %START PRINTSTRING("seq reg found"); WRITE(I,3) NEWLINE; PRINT USE %FINISH %IF I>=0 %THEN ->FOUND IMPABORT FOUND: ! REG HAS BEEN FOUND %IF CLVAL#0 %THENSTART %FOR J=0,1,NREGS %CYCLE REG==REGS(I+J) REG_CL=CLVAL REG_LINK=-1 REG_CNT=1 FORGET(I+J) %REPEAT %FINISH REGS(I+J)_AT=WTRIPNO %FOR J=0,1,NREGS %RESULT=I %END %INTEGERFN CHECKSEQREG(%INTEGER MASK,QUICK) !*********************************************************************** !* CHECKS FOR AVAILABILITY OF A 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,CNTRL,MISS,NREGS,BOOTMASK,REGMASK,cwtripno %RECORD (REGF) %NAME REG L=MASK>>16&255 U=MASK&255 cwtripno=wtripno NREGS=MASK>>24&7 %FOR CNTRL=L,1,U %CYCLE I=GRMAP(CNTRL) 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 REGMASK=0 %FOR CNTRL=L,1,U %CYCLE I=GRMAP(CNTRL) MISS=0; LASTREG=-1 %FOR J=0,1,NREGS %CYCLE REG==REGS(I+J) %IF REG_CL#0 %THENSTART; ! reg not free %IF MISS=0 %AND REG_CL=1 %AND REG_AT#WTRIPNO %THEN LASTREG=I+J MISS=MISS+1 %FINISH %REPEAT ->FOUND %IF MISS=0 %IF MISS=1 %AND LASTREG>=0 %THEN REGMASK=REGMASK!1<FOUND %IF MISS=0 %IF REG_AT#cWTRIPNO %AND 1<LASTUSED %THEN LASTUSED=USED %AND LASTREG=I+J %FINISH %REPEAT %IF LASTREG>=0 %THEN BOOT OUT(LASTREG) %AND ->AGN %IF BOOTMASK&(1<<1)=0 %THEN BOOTMASK=BOOTMASK!(1<<1) %AND ->AGN %IF BOOTMASK&(1<<2)=0 %THEN BOOTMASK=BOOTMASK!(1<<2) %AND ->AGN %if cwtripno>0 %then cwtripno=-1 %and ->agn %RESULT=-1; ! NOT FOUND FOUND: %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,CNTRL,I L=MASK>>16&255 U=MASK&255 %FOR CNTRL=L,1,U %CYCLE I=GRMAP(CNTRL) %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 FORGET(REG) %REPEAT %END %ROUTINE SAVE IRS(%INTEGER UPPER,MASK) !*********************************************************************** !* 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,J,FLAG FLAG=0 %CYCLE J=0,1,1; ! may take two passes to save addresses %CYCLE I=0,1,UPPER REG=GRMAP(I) %IF REGS(REG)_CL=2 %THEN FLAG=1 BOOT OUT(REG) %IF MASK&(1<0 %IF REGS(REG)_CL#0 %THEN IMPABORT REGS(REG)_CL=1 %END %INTEGERFN FREE REGS(%INTEGER L,U) !*********************************************************************** !* Counts the number of free regs in a certian range * !*********************************************************************** %INTEGER I,J J=0 %FOR I=L,1,U %CYCLE J=J+1 %IF REGS(I)_CL=0 %REPEAT %RESULT=J %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) %IF REG_USE=BASEREG %THENSTART PDROP(REGNO) ! %MONITOR %IF parm_dcomp#0 %FINISH REG_USE=0 REG_INF1=0 %END %ROUTINE FREE AND FORGET(%INTEGER REGNO) !*********************************************************************** !* AS FORGET BUT CLEARS CCLAIM FLAG ALSO * !*********************************************************************** REGS(REGNO)_CL=0 REGS(REGNO)_CNT=0 FORGET(REGNO) %END %ROUTINE SET USE(%INTEGER REG,PTYPE,U,I) !*********************************************************************** !* NOTE THAT THE USE OF REGISTER 'R' IS NOW 'U' & 'I' * !* WORKS FOR MULTI REGISTER ITEMS * !*********************************************************************** %INTEGER XREGS %RECORD (REGF) %NAME UREG XREGS=REGWORDS(PTYPE&127)>>4-1 %FOR REG=REG,1,REG+XREGS %CYCLE UREG==REGS(REG) %IF UREG_CL>=0 %THENSTART %IF UREG_USE>0 %THEN FORGET(REG) UREG_USE=U UREG_INF1=I UREG_AT=WTRIPNO %FINISH U=U!128; ! CONTINUATION BIT FOR MULT REG ITEMS %REPEAT %END %ROUTINE COPY USE(%INTEGER TO,FROM) !*********************************************************************** !* TRANSFER USE INFO FROM 1 REG TO ANOTHER * !*********************************************************************** %RECORD (REGF) %NAME RTO,RFROM RTO==REGS(TO) RFROM==REGS(FROM) %IF RTO_USE#0 %THEN FORGET(TO) RTO_USE=RFROM_USE RTO_INF1=RFROM_INF1 RTO_INF2=RFROM_INF2 RTO_AT=WTRIPNO %END %ROUTINE FIND USE(%INTEGERNAME REG, %INTEGER PTYPE,USE,INF) !*********************************************************************** !* SEARCHES FOR A REGISTER WITH THE REQUIRED CONTENTS * !*********************************************************************** %INTEGER I,L,U,J,NREGS %RECORD (REGF) %NAME TREG %CONSTBYTEINTEGERARRAY FMAP(1:15)=1,2,3,4,5,6,7,8,9,15,0,16,17,18,19 NREGS=REGWORDS(PTYPE&127)>>4; ! NO OF GRS(FRS) %IF PTYPE&7=2 %THEN L=12 %AND U=15 %ELSE L=1 %AND U=10+NREGS REG=-1 %ANDRETURNIF NREGS>2; ! 4 REG ITEMS TOO COMPILCATED TO SHUFFLE %CYCLE J=L,1,U+1-NREGS I=FMAP(J) TREG==REGS(I) %IF TREG_PRIMUSE=USE %AND (TREG_INF1=INF %OR INF=-1) %AND (NREGS=1 %OR %C (REGS(I+1)_PRIMUSE=USE!128 %AND (REGS(I+1)_INF1=INF %OR INF=-1))) %THEN ->HIT %IF TREG_SECUSE=USE %AND (TREG_INF2=INF %OR INF=-1) %AND (NREGS=1 %OR %C (REGS(I+1)_SECUSE=USE!128 %AND (REGS(I+1)_INF2=INF %OR INF=-1))) %THEN ->HIT %REPEAT REG=-1 %RETURN HIT: TREG_AT=WTRIPNO REG=I %END %ROUTINE BOOT OUT(%INTEGER REG) !*********************************************************************** !* REMOVE TEMPORARIES FROM REG INTO LOCAL OR ONTO STACK * !* IT IS VITAL THAT ACC IS STACKED FIRST BEFORE B OR DR * !* OTHERWISE MIXUPS OCCUR WHEN PASSING MULTI-DIMENSION ARRAY * !* ELEMENTS WITH FNS AS SUBSCRIPTS AS VALUE SCALARS * !*********************************************************************** %SWITCH BOOT(1:3) %INTEGER BSIZE,WSIZE,NREGS,D,J %RECORD (REGF) %NAME BOOTREG %RECORD (RD) %NAME R BOOTREG==REGS(REG) IMPABORT %UNLESS 1<=BOOTREG_CL<=3 R==RECORD(BOOTREG_LINK) BSIZE=BYTES(R_PTYPE>>4&15) WSIZE=REGWORDS(R_PTYPE&127) NREGS=WSIZE>>4; WSIZE=WSIZE&15 %IF NREGS=2 %AND R_XB=REG-1 %THEN BOOT OUT(REG-1) %AND ->END %IF PARM_DCOMP#0 %START PRINTSTRING("boot out") WRITE(REG,3) WRITE(R_PTYPE,4) WRITE(NREGS,1) NEWLINE %FINISH BOOTDEPTH=BOOTDEPTH+1 IMPABORT %IF BOOTDEPTH>10 ->BOOT(BOOTREG_CL) BOOT(3): ! PARAMETER AWAITONG STACKING DSTORE(REG,BSIZE,-1,64+4*REG) ->FREE %IF BOOTREG_CNT<=1 R_D=0; ! PARAM ALSO I-R FOR LATER PARAM BOOT(1): ! INTERMEDIATE RESULT %if R_FLag>=10 %then ->boot(2) %IF R_D=0 %THENSTART GET WSP(D,WSIZE) R_D=CURRINF_RBASE<<16!D %FINISHELSE D=R_D&X'FFFF' ! ! A desparate situation arises if the dumphole is beyond 4096 bytes from ! the base register. There is almost certainly not a register to ! load a multiple of 4096 so an emergency method is used ! %IF D>4095 %THEN PIX RX(x'5A',DISPREG(R_D>>16),0,CODER,D>>12<<2) DSTORE(REG,BSIZE,R_D>>16,D&4095) ! ! A desparate situation arises if the dumphole is beyond 4096 bytes from ! the base register. There is almost certainly not a register to ! load a multiple of 4096 so an emergency method is used ! %IF D>4095 %THEN PIX RX(x'5B',DISPREG(R_D>>16),0,CODER,D>>12<<2) D=BSIZE<<24!DISPREG(R_D>>16)<<16!R_D&X'FFFF' %CYCLE FINDUSE(J,R_PTYPE,LOCALTEMP,D) %EXITIF J<0 FORGET(J) %IF PARM_DCOMP#0 %THEN PRINTSTRING("temp reuse noted") %REPEAT SET USE(REG,R_PTYPE,LOCALTEMP,D) R_FLAG=7 ->FREE BOOT(2): ! TEMPORARY BASE %IF 10<=R_FLAG<=11 %AND (R_XB&15=REG %OR 0#REG=R_XB>>4) %AND BOOTREG_CNT<=1 %START %if R_flag=11 %start dumpla(reg,R_XB>>4,R_XB&15,R_D&X'FFF') %if R_d>4095 %then PIX RX(A,REG,0,Coder,R_D>>12<<2) operand used(r) forget(reg) operand loaded(r,reg,Yes) ->BOOT(1) %finish %IF R_FLAG=10 %and R_PTYPE&7=1 %Start load(r,REg,2) ->boot(1) %finish J=FINDREG(GRSAFE,2) DUMPLA(J,R_XB>>4,R_XB&15,R_D) OPERAND USED(R) R_XB=J %IF R_FLAG=11 %THEN R_FLAG=9 %ELSE R_D=0 REGS(J)_LINK=BOOTREG_LINK %IF PARM_DCOMP#0 %START PRINTSTRING("post boot") NEWLINE PRINT USE %FINISH %IF BOOTREG_CL=0 %THEN ->END %FINISH IMPABORT FREE: %FOR J=0,1,NREGS-1 %CYCLE BOOTREG==REGS(REG+J) BOOTREG_CL=0 BOOTREG_CNT=0 BOOTREG_LINK=0 %REPEAT END: BOOTDEPTH=BOOTDEPTH-1 %END %ROUTINE CALL COMING(%INTEGER UPPER) !*********************************************************************** !* CALLED TO SAVE RESULTS AND PARAMETERS IN CASE CALL WITHIN CALL * !*********************************************************************** %INTEGER J SAVE IRS(UPPER,1<<3); ! ONLY ACTIVE PARAMETERS SAVED AT THIS STAGE J=(FPPTR+7)&(-8) PUSH(FPHEAD,FPPTR,LAST PAR REG,J) %IF FPPTR>64 %THEN DUMPRX(LA,WSPR,0,WSPR,J) FPPTR=64 %END %ROUTINE CALL MADE !*********************************************************************** !* CALL HAS BEEN MADE. EXPOSE ANY PARAMETERS * !*********************************************************************** %INTEGER J POP(FPHEAD,FPPTR,LAST PAR REG,J) %IF CA>4096-MARGIN %THENSTART SET USE(LINKREG,X'51',BASEREG,CA) PUSING(LINKREG) %FINISHELSE FORGET(LINKREG) %IF FPPTR>64 %THENSTART REGS(1)_CL=1 DUMPRX(SH,WSPR,0,CTABLEREG,SHORT CONST(J)) REGS(1)_CL=0; ! IN CASE OF RESULT AND CONST TABLE>4096 ONLY %FINISH %END %INTEGERFN APSSIMPLE !*********************************************************************** !* CHECKS AN ACTUAL PARAMETER LIST FOR ANY NASTIES * !*********************************************************************** %INTEGER LINK,OPERN %RECORD (TRIPF) %NAME CHECKT LINK=CURRT_FLINK %CYCLE %RESULT=NO %IF LINK=0 CHECKT==TRIPLES(LINK) OPERN=CHECKT_OPERN LINK=CHECKT_FLINK %RESULT=YES %IF OPERN=RCALL; ! CALL REACHED BEFORE A NASTY %RESULT=NO %IF OPERN=PRECL %OR OPERN=MNITR %OR OPERN=IOCPC %OR OPERN=IEXP %OR %C CHECKT_CNT>1 ! unattractive problems with multiply used parameters %REPEAT %END %ROUTINE FILL SAVE AREA(%INTEGER LAST PAR REG) !*********************************************************************** !* STORE REGS INTO A SAVE AREA. LAST PAR REG=14 IF NO CLEVER STUFF * !* OTHER WISE IS HIGHEST GR HOLDING A PARAMETER. USES BEST METHOD * !*********************************************************************** %INTEGER UPPER,LOWER,I %RECORD (REGF) %NAME REG LOWER=4; UPPER=14 ->RAISE %IF LAST PAR REG=14 %FOR I=0,1,LASTPARREG %CYCLE %IF REGS(I)_CL#3 %START; ! ONE OR MORE REGS DUMPED SAVE IRS(9,1<<3); ! DUMP ANY OTHERS UP TO GR5 ->RAISE %FINISH %REPEAT %FOR I=0,1,LAST PAR REG %CYCLE REG==REGS(I) REG_CNT=REG_CNT-1 IMPABORT %IF REG_CNT>0 REG_CL=0 %REPEAT UPPER=LAST PAR REG %IF UPPER>=4 %THENSTART LOWER=UPPER+1 FORGET(I) %FOR I=4,1,UPPER %FINISH RAISE: ! RAISE THE LOWER LIMIT ! IF NOTHING IN THE REG %FOR I=LOWER,1,CLNB-1 %CYCLE REG==REGS(I) %EXITUNLESS REG_CL=0 %AND (1<=16 %OR SREG=ANYFR %OR SREG=ANYFRPAIR %THEN TY=1 PR=BYTESTOPT(SIZE)>>4 OPCODE=LDCODE(8*TY+PR) COUNT=SIZE>>2-1 %IF OPCODE=LM %START %IF SREG<0 %THEN SREG=FINDREG(NEGREG(SREG),0) %IF OPND_XB>>4=0 %THEN DUMPM(OPCODE,SREG,SREG+COUNT,OPND_XB,OPND_D) %ELSESTART DUMPRX(LGR,SREG+I,OPND_XB>>4,OPND_XB&15,OPND_D+4*I) %FOR I=0,1,COUNT %FINISH %FINISHELSESTART DUMPRXE(OPCODE,SREG,OPND_XB>>4,OPND_XB&15,OPND_D) %IF SIZE=16 %THEN DUMPRX(OPCODE,REGCODE(SREG+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) !*********************************************************************** !* SIMILAR TO DSTORE BUT WITH OPND TYPE PARAMETER * !*********************************************************************** %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) %ELSESTART DUMPRX(ST,REG+I,OPND_XB>>4,OPND_XB&15,OPND_D+4*I) %FOR I=0,1,COUNT %FINISH %FINISHELSESTART DUMPRX(OPCODE,REGCODE(REG),OPND_XB>>4,OPND_XB&15,OPND_D) %IF SIZE=16 %THEN 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' * !*********************************************************************** DUMPRXE(LA,REG,0,DISPREG(LEVEL),DISP) FORGET(REG) %END %ROUTINE DFETCH(%INTEGERNAME REG, %INTEGER SIZE,LEVEL,DISP) !*********************************************************************** !* FETCH SIZE(BYTES) FROM DISP(BYTES) IN DISPLAY 'LEVEL' * !*********************************************************************** %RECORD (RD) DOPND %INTEGER TREG,USE,TY,PT DOPND_FLAG=10 DOPND_XB=DISPREG(LEVEL) DOPND_D=DISP TY=1 %IF REG=ANYFR %THEN TY=2 %IF REG<0 %AND SIZE<=4*TY %START USE=SIZE<<24!DOPND_XB<<16!DISP PT=BYTESTOPT(SIZE)>>4<<4!TY FIND USE(TREG,PT,LOCALTEMP,USE) %IF TREG>=0 %AND REGS(TREG)_CL=0 %AND ACCEPTABLE REG(NEGREG(REG),TREG)=YES %THEN %C REG=TREG %ANDRETURN %FINISH GET IN ACC(REG,SIZE,DOPND) %END %ROUTINE TESTRASS(%INTEGER REG,PTYPE) !*********************************************************************** !* TEST THAT A REG HAS NOT BEEN LOADED WITH THE UNASSIGNED MARKER * !*********************************************************************** %INTEGER OP,TY,Regp PTYPE=PTYPE&255 TY=PTYPE&7 %if ty=5 %Start Regp=Reg %if Regp=0 %then regp=Findreg(gr1,1) %and pix rr(lr,regp,reg) dumpss(CLC,2,regp,0,ctablereg,unassoffset) %if regp#reg %then freeandforget(regp) %else %RETURNIF TY=0 %OR TY>2 %OR PTYPE=X'31' OP=LDCODE(8*(TY-1)+PTYPE>>4) %IF OP=LM %THEN OP=LGR PIX RX(OP+1,REGCODE(REG),0,CTABLEREG,UNASSOFFSET) %finish PPJ(8,5,NO) %END %ROUTINE TESTVASS(%RECORD (RD) %NAME OPND) !*********************************************************************** !* TEST A VARIABLE FOR NOT ASSIGNED * !*********************************************************************** %INTEGER OP,PTYPE,TY,PR,REG,L PTYPE=OPND_PTYPE&255 %IF OPND_FLAG=INAREG %THEN TESTRASS(OPND_XB,PTYPE) %ANDRETURN TY=PTYPE&7; PR=PTYPE>>4 %RETURNUNLESS OPND_FLAG=10; ! THE LA FORM CAN NOT PRODUCE UNASSPAT %RETURNIF PR=3 %and type=1; ! cant check bytes %IF OPND_XB<=15 %AND (OPND_D<=4095 %or ty=5) %START; ! USE STORE TO STORE FORMAT %IF TY=5 %THEN L=2 %ELSE L=BYTES(PR) L=8 %IF L>8; ! ONLY 8 BYTES OF UNASS PATTERN DUMPSS(CLC,L,OPND_XB,OPND_D,CTABLEREG,UNASSOFFSET) %else %IF TY=2 %THEN REG=ANYFR %ELSE REG=ANYGR OP=LDCODE(8*(TY-1)+PR) %IF OP=LM %THEN OP=LGR DUMPRXE(OP,REG,0,CTABLEREG,UNASSOFFSET) DUMPRX(OP+1,REGCODE(REG),OPND_XB>>4,OPND_XB&15,OPND_D) FORGET(REG) %finish PPJ(8,5,NO) %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,REGSTATE %IF AMOUNT=0 %THENRETURN %IF LAOK=YES %AND REG#0 %START %IF 0X'380' %START PIX RX(A,REG,0,CODER,AMOUNT>>12<<2) INC REG(REG,AMOUNT&X'FFF',YES) %RETURN %FINISH %FINISH %IF X'FFFF8000'LIMIT 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,TOP PPROCEND JJ=CURRINF_SNMAX %if jj>x'7fff' %then fault(98,0,0); ! up to 64 in shorts unsigned %IF JJ<4095 %THENSTART %IF PARM_CHK=0 %THEN D=LA<<8!WSPR<<4!WSPR %ELSE D=LA<<8 PSETOPD(CURRINF_SET,0,D) PSETOPD(CURRINF_SET,1,JJ) %FINISHELSESTART D=word CONST(JJ) %IF PARM_CHK=0 %THEN TOP=a<<8!WSPR<<4 %ELSE TOP=lgr<<8 PSETOPD(CURRINF_SET,0,TOP) %IF D<4095 %THENSTART PSETOPD(CURRINF_SET,1,CTABLEREG<<12!D) %FINISHELSESTART D=JJ>>12<<2+4; ! OFFSET OF NEXT HIGHER 4K MULTIPLE PSETOPD(CURRINF_SET,1,CODER<<12!D) %FINISH %FINISH REGS(CLNB)_CL=0 CLNB=CLNB+1 %END %ROUTINE CALL STOP !*********************************************************************** !* CALLS STOP ROUTINE. NOT VIA EPILOGUE ON PERQ * !************************************************************************ PIX RS(STM,4,14,WSPR,16) DUMPM(LM,12,14,GLAREG,KNOWNXREF(0)) PIX RR(BALCODE-X'40',15,14) %END %ROUTINE CIOCP(%INTEGER N,REG) !*********************************************************************** !* COMPILES A CALL ON IOCP ENTRY POINT NO 'N' * !* 2ND (32 BIT) PARAMETER IS ALREAD IN REG * !*********************************************************************** %CONSTINTEGER NEED RES=X'40016' %INTEGER MREG,LASTPR MREG=ANYGR; LASTPR=14 REGS(REG)_CL=-1 CALL COMING(8) %IF REGS(0)_CL=0 %THEN MREG=0 DUMPRXE(LA,MREG,0,0,N) %IF MREG=0 %THEN LASTPR=0 %AND REGS(0)_CL=3 %and regs(0)_cnt=1 %ELSE DSTORE(MREG,4,-1,64) %IF LASTPR=0 %AND REG=1 %THEN REGS(1)_CL=3 %AND LASTPR=1 %ELSESTART DSTORE(REG,4,-1,68) REGS(REG)_CL=0 %FINISH SAVE IRS(8,B'110') FILL SAVE AREA(LASTPR) FORGETM(8) DUMPM(LM,CODER,EPREG,GLAREG,KNOWN XREF(4)) PIX RR(BALCODE-X'40',15,14) CALL MADE %END %ROUTINE PPJ(%INTEGER MASK,N,SAVE) !*********************************************************************** !* PLANT A 'BC MASK,PERMENTRY(N)' * !* IF MASK=0 THEN PLANT A BAS * !* QUITE DIFFICULT IF PERM LABEL NOT YET SET. HAVE TO ARRANGE TO * !* LOAD RELEVANT 4K MULTIPLE AND NOTE CA FOR LATER FILLING * !*********************************************************************** %INTEGER VAL,CODE,J,WREG CODE=BC %IF MASK=0 %THENSTART CODE=BALCODE MASK=LINKREG SAVE IRS(8,B'110') %IF SAVE=YES %FINISH VAL=WORKA_PLABS(N) %IF VAL<=0 %THEN VAL=GLABEL %AND WORKA_PLABS(N)=VAL %AND WORKA_PLINK(N)=VAL %AND %C GLABEL=VAL-1 %IF N<=15 %THEN WREG=0 %ELSEIF CODE=BALCODE %THEN WREG=LINKREG %ELSE IMPABORT PJUMP(CODE,VAL,MASK&15,WREG) %IF CODE=BALCODE %START; ! IF WE ARE COMING BACK FORGETM(8) %IF SAVE=YES %IF REGS(LINKREG)_CL#0 %THEN IMPABORT FORGET(LINKREG) %IF 4096-CA>4,OPND_XB&15,D) %IF D>4095 %THEN OPERAND USED(OPND) OPND_XB=NEWBASE OPND_D=0 REGS(NEWBASE)_CL=TEMPBASE FORGET(NEWBASE) %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) REG_CNT=REG_CNT-1 %IF REG_CL>=0 %IF REG_CNT<=0 %AND (REG_CL=IRESULT %OR REG_CL=TEMPBASE) %THEN REG_CL=0 %REPEAT %FINISH %IF 10<=OPND_FLAG<=11 %START X=OPND_XB>>4 B=OPND_XB&15 REG==REGS(X) %IF X>0 %START REG_CNT=REG_CNT-1 %IF REG_CL>=0 %IF REG_CNT<=0 %AND (REG_CL=IRESULT %OR REG_CL=TEMPBASE) %THEN REG_CL=0 %FINISH REG==REGS(B) %IF B>0 %START REG_CNT=REG_CNT-1 %IF REG_CL>=0 %IF REG_CNT<=0 %AND (REG_CL=IRESULT %OR REG_CL=TEMPBASE) %THEN REG_CL=0 %FINISH %FINISH %END %ROUTINE OPERAND revised(%RECORD (RD) %NAME OPND) !*********************************************************************** !* AFTER OPERAND IS USED amends 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) REG_AT=WTRIPNO reg_link=addr(opnd) %REPEAT %FINISH %IF 10<=OPND_FLAG<=11 %START X=OPND_XB>>4 B=OPND_XB&15 REG==REGS(X) %IF X>0 %START reg_at=wtripno reg_link=addr(opnd) %FINISH REG==REGS(B) %IF B>0 %START reg_at=wtripno reg_link=addr(opnd) %FINISH %FINISH %END %ROUTINE OPERAND LOADED(%RECORD (RD) %NAME OPND, %INTEGER REG,RESET) !*********************************************************************** !* 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 %THENSTART %IF PREC=3 %AND REGS(REG)_USE=0 %AND VJASS#CURRT_OPERN#JAMSHRTN %THEN %C REGS(REG)_USE=LITCONST %AND REGS(REG)_INF1=-1000 PREC=5 OPND_PTYPE=X'51' %FINISH OPND_FLAG=9 OPND_D=0 OPND_XB=REG X=WORDS(PREC) X=X>>1 %IF TYPE=2 %AND X>1 %FOR J=REG,1,REG+X-1 %CYCLE LREG==REGS(J) %IF (RESET=YES %OR LREG_CL=0) %THEN %C LREG_CNT=0 %AND LREG_LINK=ADDR(OPND) %AND LREG_CL=1 LREG_CNT=LREG_CNT+1 LREG_AT=WTRIPNO %REPEAT %END %INTEGERFN RESULT REG(%INTEGER PTYPE) !*********************************************************************** !* DECIDES ON THE REGISTER FOR FN RESULTS * !*********************************************************************** PTYPE=PTYPE&255 %IF PTYPE&7=2 %THENRESULT=16 {FR0} %ELSEIF PTYPE=X'61' %THENRESULT=0 %ELSERESULT=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 PIX RRE(CODE,REGCODE(EVALREG)+OFFSET,REGCODE(OPND_XB)+OFFSET) %ELSESTART %IF CODE>=X'40' %THEN CODE=CODE-X'40' %IF CODE=12 %THEN IMPABORT PIX RR(CODE,REGCODE(EVALREG)+OFFSET,REGCODE(OPND_XB)+OFFSET) %FINISH %FINISHELSESTART IMPABORT %UNLESS OPND_FLAG=10 %AND CODE>=X'40' DUMPRX(CODE,REGCODE(EVALREG)+OFFSET,OPND_XB>>4,OPND_XB&15,OPND_D+4*OFFSET) %FINISH REG==REGS(EVALREG) FORGET(EVALREG) %UNLESS %C (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. MODE#0 MAKE USUAL USE CHECKS ON INDEX * !*********************************************************************** %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 %THENSTART FIND USE(INDEX,X'51',FOURKMULT,PN); ! LOOK FOR 4K MULTIPLE ->REND %IF INDEX>0 SET USE(J,X'51',FOURKMULT,PN) INDEX=J; K=LGR %FINISHELSESTART %IF REGS(INDEX)_CL<0 %OR REGS(INDEX)_CNT>1 %THEN MODE=0 %IF MODE=0 %AND 4096<=DISP<8188 %START DUMPLA(J,0,INDEX,4092) DISP=DISP-4092 INDEX=J; FORGET(J) %RETURN %FINISH %IF MODE=0 %OR INDEX=0 %THENSTART %IF MODE=0 %THEN PIX RR(LR,J,INDEX) %ELSE PIX RR(SR,J,J) INDEX=J %FINISH FORGET(INDEX) %FINISH PIX RX(K,INDEX,CODER,0,PN<<2) REND: DISP=DISP&4095 %END %ROUTINE DUMPRXE(%INTEGER CODE, %INTEGERNAME REG, %INTEGER X,LEVEL,DISP) !*********************************************************************** !* AS DUMPRX BUT SELCTS THE REG ALSO !*********************************************************************** %INTEGER K %RECORD (REGF) %NAME UREG %IF REG=ANYGR %OR REG=ANYGRBAR0 %START %IF CODE=IC %START; ! TRY TO AVOID CLEARING A REG FIND USE(K,X'51',LITCONST,-1000) %IF (K>0 %OR (K=0 %AND REG=ANYGR)) %AND REGS(K)_CL=0 %THEN REG=K %ELSESTART K=1 %WHILE REG<0 %AND K<=15 %CYCLE UREG==REGS(K) %IF UREG_CL=0 %AND ((UREG_PRIMUSE=LITCONST %AND UREG_INF1<=255) %OR %C (UREG_SECUSE=LITCONST %AND UREG_INF2<=255)) %THEN REG=K K=K+1 %REPEAT %FINISH %FINISH %FINISH %IF REG<0 %THEN REG=FIND REG(NEGREG(REG),0) DUMPRX(CODE,REGCODE(REG),X,LEVEL,DISP) %END %ROUTINE DUMPRX(%INTEGER CODE,REG,X,LEVEL,DIS) !*********************************************************************** !* PUTS OUT AN RX INSTRUCTION COMPENSATING FOR SHORTCOMINGS OF IC * !* NO LONGER ATTEMPTS TO OPTIMISE "LA" BUT DEALS WITH DIS>4095 * !*********************************************************************** %INTEGER K,ANDR %RECORD (REGF) %NAME UREG ANDR=0 %IF CODENORMAL %IF UREG_PRIMUSE=LITCONST %AND UREG_INF1<=255 ->NORMAL %IF UREG_SECUSE=LITCONST %AND UREG_INF2<=255 %IF REG=0 %OR X#REG#LEVEL %THEN PIX RR(SR,REG,REG) %ELSE ANDR=1 %FINISH NORMAL:PIX RX(CODE,REG,X,LEVEL,DIS) %IF ANDR#0 %THEN PIX RX(AND,REG,0,CTABLEREG,KWCONSTS(1)); ! n reg,=f'255' ! F255 put into ctable in pinitialise %END %ROUTINE DUMPLA(%INTEGER REG,X,LEVEL,DIS) !*********************************************************************** !* A VERSION OF DUMPRX SOLEY FOR LOAD ADDRESS. MAKES ALL THE * !* SHORT CUTS THAT PDS CAN THINK OF * !*********************************************************************** %IF DIS=0 %START; ! VARIOUS NOOPS AND LRS POSSIBLE %IF X=LEVEL=0 %THEN PIXRR(SLR,REG,REG) %ANDRETURN %IF REG=X>0 %START %IF LEVEL#0 %THEN PIX RR(AR,REG,LEVEL) %RETURN %FINISH %IF REG=LEVEL>0 %START %IF X#0 %THEN PIX RR(AR,REG,X) %RETURN %FINISH %IF LEVEL=0 %OR X=0 %THEN PIX RR(LR,REG,LEVEL+X) %ANDRETURN %FINISH %IF REG#0 %AND ((REG=LEVEL %AND X=0) %OR (REG=X %AND LEVEL=0)) %THEN %C INC REG(REG,DIS,YES) %ANDRETURN ! IMPROVES CODE IF DIS>4095 %IF DIS>4095 %THEN ADJUST INDEX(1,X,DIS) PIX RX(LA,REG,X,LEVEL,DIS) %END %ROUTINE DUMPSI(%INTEGER OPCODE,L,B,D) !*********************************************************************** !* OUTPUTS A SI INSTRUCTION DEALING WITH DISPLACEMENTS>4095 * !*********************************************************************** %IF D>4095 %THEN ADJUST INDEX(1,B,D) PIX SI(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(1,B,D) PIX RS(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 * !*********************************************************************** %INTEGER C1,C2 C1=B1; C2=B2 %IF D1>4095 %THEN ADJUST INDEX(1,B1,D1) %AND REGS(B1)_CL=2 %IF D2>4095 %THEN ADJUST INDEX(1,B2,D2) %AND REGS(B2)_CL=2 %IF OP=MVC %THEN PMVC(L,B1,D1,B2,D2) %ELSE PIX SS(OP,0,L,B1,D1,B2,D2) %IF B1#C1 %THEN REGS(B1)_CL=0 %IF B2#C2 %THEN REGS(B2)_CL=0 %END %ROUTINE EXECUTESS(%INTEGER XREG,OPCODE,B1,D1,B2,D2) !*********************************************************************** !* PUTS A ZERO LENGTH STORE TO STORE INSTRUCTION INTO CONSTANTS * !* AND EXECUTES IT WITH 'EX' * !*********************************************************************** %INTEGER I,J,K,C1,C2 C1=B1; C2=B2 %IF D1>4095 %THEN ADJUST INDEX(1,B1,D1) %AND REGS(B1)_CL=2 %IF D2>4095 %THEN ADJUST INDEX(1,B2,D2) %AND REGS(B2)_CL=2 I=OPCODE<<24!B1<<12!D1 J=B2<<28!D2<<16 STORE CONST(K,6,ADDR(I)) DUMPRX(EX,XREG,0,CTABLEREG,K) %IF B1#C1 %THEN REGS(B1)_CL=0 %IF B2#C2 %THEN REGS(B2)_CL=0 %END %ROUTINE NOTE ASSMENT(%INTEGER REG,ASSOP,VAR,PTYPE) !*********************************************************************** !* NOTES THE ASSIGNMENT TO SCALAR 'VAR'. THIS INVOLVES REMOVING * !* OLD COPIES FROM REGISTERS TO AVOID CONFUSING OLD AND NEW VALUE* !* ASSOP =1 FOR'==',=2 FOR '=',=3 FOR '<-' * !*********************************************************************** %CONSTINTEGER EEMASK=B'1100011110000000'; ! MASK OF USES RELEVANT TO == %CONSTINTEGER EMASK=B'100011000000000'; ! MASK OF USES RELEVANT TO = %RECORD (REGF) %NAME WREG %INTEGER I,II,NREGS,UU %RETURNIF VAR<=0 NREGS=REGWORDS(PTYPE)>>4 %IF ASSOP=1 %THENSTART %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 WREG_INF1=WREG_INF2 %REPEAT %IF REG>=0 %AND NREGS<=2 %THEN SET USE(REG+NREGS-1,X'51',ADDROF,VAR) %FINISHELSESTART %CYCLE II=0,1,14 I=GRMAP(II) WREG==REGS(I) %IF EMASK&1<>16=VAR %OR %C WREG_INF2=VAR) %THEN WREG_SECUSE=0 %IF EMASK&1<>16=VAR %OR %C WREG_INF1=VAR) %THEN WREG_USE=WREG_SECUSE %AND WREG_INF1=WREG_INF2 ! ! ALL THE FOREGOING CONDITIONS ARE NOT AS SILLY AS THEY SEEM. MUST ! BEAR IN MIND THAT BOTH GRINF&VAR MAY BE RECORD ELEMENTS DEFINED ! BY ALL 32 BITS OF INF AS WELL AS MODIFIED SCALARS WHEN THE NAME ! ONLY TAKES 16 BITS ! %REPEAT %IF ASSOP=2 %AND VAR>0 %AND REG>=0 %START UU=LOCAL VAR %FOR REG=REG,1,REG+NREGS-1 %CYCLE WREG==REGS(REG) %IF LITCONST<=WREG_PRIMUSE&255<=TABCONST %START ! ASSIGN CONST TO VAR WREG_SECUSE=UU WREG_INF2=VAR %FINISHELSESTART; ! ASSIGN VAR OR EXP TO VAR WREG_SECUSE=WREG_PRIMUSE WREG_PRIMUSE=UU WREG_INF2=WREG_INF1; ! PREVIOUS USE BECOMES 2NDRY WREG_INF1=VAR %FINISH UU=UU!128; ! CONTINUATION BIT FOR SUBSEQUENT REGS %REPEAT %FINISH %FINISH %END %ROUTINE NOTE LASS(%INTEGER SIZE,BASE,DISP) !*********************************************************************** !* WHEN AN ASSIGNMENT IS MADE TO BASE&DISP PERFORMS A REGISTER CHECK* !*********************************************************************** %RECORD (REGF) %NAME CREG %INTEGER C,JJ,KK KK=DISPREG(BASE)<<16!DISP JJ=KK+SIZE %FOR C=0,1,MAXREG %CYCLE CREG==REGS(C) %IF CREG_primUSE=LOCALTEMP %AND KK<=CREG_INF1&X'FFFFF'1024 %AND USE LONG=0 %THENRETURN OPCODE=MVC %IF L+D1>4092 %THEN UPDATE(W1,D1) %IF MODE#0 %AND L+D2>4092 %THEN UPDATE(W2,D2) %IF MODE=0 %THENSTART; ! PROPAGATE CONSTANT J=L; W2=W1 CONST=D2; D2=D1 %IF CONST=0 %AND L<=32 %THENSTART ! CCSTATE=-1 OPCODE=X'D7'; ! CAN USE XC %FINISHELSESTART; ! USE MVI & MVC TO PROPOGATE PIX SI(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 %THENSTART 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) PIX SS(OPCODE,0,J,W1,D1,W2,D2) D1=D1+J D2=D2+J L=L-J %REPEAT ! %RETURN %INTEGERFN USE LONG !*********************************************************************** !* ATTEMPTS TO USE MVCL FOR THIS BULK MOVE. MAY FAIL (RESULT#0) * !* SINCE TWO EVENODD PAIRS ARE NOT ALWAYS AVAILABLE * !*********************************************************************** %INTEGER PAIR0,PAIR1,RS,TOTHER TOTHER=B1!!1 %IF REGS(B1)_CL>0 %AND REGS(B1)_CNT=1 %AND REGS(TOTHER)_CL=0 %THEN PAIR0=B1&X'FE' %ELSE %C PAIR0=CHECKSEQREG(GRPAIR,NO) %IF PAIR0<0 %THENRESULT=1 RS=REGS(PAIR0)_CL REGS(PAIR0)_CL=-1 TOTHER=B2!!1 %IF MODE#0 %AND REGS(B2)_CL>0 %AND REGS(B2)_CNT=1 %AND REGS(TOTHER)_CL=0 %THEN %C PAIR1=B2&X'FE' %ELSE PAIR1=CHECKSEQREG(GRPAIR,NO) %IF PAIR1<0 %THEN REGS(PAIR0)_CL=RS %ANDRESULT=1 DUMPLA(PAIR0,0,B1,D1) FORGET(PAIR0) DUMPLA(PAIR0+1,0,0,L) FORGET(PAIR0+1) %IF MODE=0 %START; ! CLEAR TO ZERO OR BYTE PIXRR(LR,PAIR1,PAIR0); ! ANY VALIDE ADDRESS DUMPLA(PAIR1+1,0,0,D2&255) %IF D2#0 %THEN PIX RS(SLL,PAIR1+1,0,0,24); ! FILLER TO TOP %ELSE DUMPLA(PAIR1,0,B2,D2) PIX RR(LR,PAIR1+1,PAIR0+1) %FINISH FORGET(PAIR1) FORGET(PAIR1+1) PIX RR(MVCL,PAIR0,PAIR1) REGS(PAIR0)_CL=RS %RESULT=0 %END %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 DUMPLA(WK,0,WI,J) FORGET(WK) DI=DI-J; WI=WK %END %END; ! OF ROUTINE BULK M %ROUTINE POLISH LOOP(%RECORD (TRIPF) %NAME FPTRIP) !*********************************************************************** !* POLISHES THE CODE AROUND A LOOP THAT IS KNOWN TO BE SHORT * !* AND FREE FROM CONTAINED LOOPS. A BXH IS ARRANGED WHERE POSSIBLE * !* AND SPARE REGISTERS ARE USED FOR BASES AND CONSTANTS * !*********************************************************************** %INTEGER I,J,K,REGMASK,USEDMASK,OP,FORBITS,FREE REGS,ADEX,CPTR %INTEGER INCFLAG,INCVAL,FINALFLAG,FINALVAL,USINGREG,MULTRES %RECORDFORMAT IOPNDF(%INTEGER WTCNT,CNT,MODE, %RECORD (RD) OPND) %CONSTBYTEINTEGERARRAY WTS(0:3)=0,2,1,2; %CONSTINTEGER MAX=15 %RECORD (IOPNDF) %ARRAY IOPNDA(0:MAX) %RECORD (IOPNDF) %NAME IOPND %ROUTINESPEC QUICKSORT(%RECORD (IOPNDF) %ARRAYNAME X, %INTEGER L,U) %ROUTINESPEC ADDIN(%INTEGER MODE, %RECORD (RD) %NAME OPND) %RECORD (RD) TOPND %CONSTLONGINTEGER LO=1 %CONSTLONGINTEGER UOPMASK=LO<1 %and currt_optype&7#2 %and k#forpr2 %c %then multres=multres+1; ! multiply used integer results %IF K<128 %THEN UOP=UOP!(L1<>7 %CYCLE %IF I=0 %THEN TOPND=CURRT_OPND1 %ELSE TOPND=CURRT_OPND2 %IF X'41'<=TOPND_PTYPE<=X'51' %AND TOPND_FLAG=0 %AND 0<=TOPND_D<=4095 %AND %C ((K<128 %AND LO<=128 %AND LO<<(K-128)&BOPMASK=0)) %START TOPND_XTRA=0 ADDIN(2,TOPND); ! RECORD ANY CNST %FINISH %IF TOPND_FLAG=INDNAME %THEN TOPND_XTRA=0 %AND ADDIN(3,TOPND) %REPEAT J=CURRT_FLINK %REPEAT %IF UOP&LO<4000 %OR WORKA_CONSTPTR>1000 %THEN FREE REGS=FREE REGS-1 %if multres>1 %then free regs=free regs-1 ->SKIP BXH %UNLESS FREE REGS>=3 %AND (OP=BXLE %OR OP=BXH) %FOR I=8,-2,4 %CYCLE; ! CHOOSE A PAIR FOR BXH %IF REGMASK>>I&3=3 %THEN K=I %AND ->CHOSEN %REPEAT ->SKIP BXH; ! NO PAIR AVAILABLE CHOSEN: ! K HAS A VALID PAIR FOR BXH INCFLAG=0; INCVAL=ADDTRIP_OPND2_D; ! RECORD INCREMENT VAL LOAD(ADDTRIP_OPND2,K,2); ! INC(CONST) TO EVEN REG REGS(K)_CL=-1 regs(k)_secuse=0 TOPND=COMPTRIP_OPND2 FINALFLAG=TOPND_FLAG %IF FINALFLAG=0 %AND OP=BXLE %THEN TOPND_D=TOPND_D+INCVAL %IF FINALFLAG=0 %AND COMPTRIP_OPERN=ZCOMP %AND COMPTRIP_X1&8=0 %THEN %C TOPND_D=TOPND_D+INCVAL ! undo optimisations of >=1 to>0 etc FINALVAL=TOPND_D LOAD(TOPND,K+1,2); ! FINAL TO ODD REG REGS(K+1)_CL=-1 regs(k+1)_secuse=0 %IF OP=BXLE %AND FINALFLAG#0 %THEN PIX RR(AR,K+1,K) %AND REGS(K+1)_USE=0 REGMASK=REGMASK!!(3<0 %AND 4095-MARGIN<=CA %START %FOR I=9,-1,4 %CYCLE %IF 1<FINALE %IF INCFLAG=0 %START %FOR I=0,1,CPTR-1 %CYCLE; ! DELETE CNSTS SAME AS INC OR FINAL IOPND==IOPNDA(I) %IF IOPND_MODE=2 %AND (IOPND_OPND_D=INCVAL %OR (FINAL FLAG=0 %AND %C IOPND_OPND_D=FINALVAL)) %THEN IOPND_CNT=0 %REPEAT %FINISH %FOR I=0,1,CPTR-1 %CYCLE IOPND==IOPNDA(I) IOPND_WTCNT=IOPND_CNT*WTS(IOPND_MODE) %REPEAT %IF CPTR>0 %THEN QUICKSORT(IOPNDA,0,CPTR-1) %IF PARM_DCOMP#0 %START PRINTSTRING(" PRELOAD LIST wtcnt cmt mode operand") %FOR I=0,1,CPTR-1 %CYCLE IOPND==IOPNDA(I) NEWLINE WRITE(IOPND_WTCNT,4) WRITE(IOPND_CNT,4) WRITE(IOPND_MODE,4) SPACES(4) PRHEX(IOPND_OPND_S1,8) SPACE PRHEX(IOPND_OPND_D,8) SPACE PRHEX(IOPND_OPND_XTRA,8) %REPEAT NEWLINE %FINISH %FOR ADEX=0,1,CPTR-1 %CYCLE IOPND==IOPNDA(ADEX) %IF FREE REGS<=0 %OR IOPND_CNT=0 %THENEXIT %IF IOPND_MODE=1 %AND BOP&(LO<<(AHASS-128))#0 %THENCONTINUE %IF IOPND_MODE=3 %AND BOP&(LO<<(PTRAS-128))#0 %THENCONTINUE %FOR I=9,-1,4 %CYCLE %IF REGMASK&1<0 %START PIX RR(BALCODE-X'40',USINGREG,0) SET USE(USINGREG,X'51',BASEREG,CA) PUSING(USINGREG) REGS(USINGREG)_CL=-1 %FINISH ! ! FINALLY PASSED USEDMASK TO POSTAMBLE SO REGISTERS CAN BE RELEASED ! POSTTRIP_OPND1_D=USEDMASK %RETURN %ROUTINE ADDIN(%INTEGER MODE, %RECORD (RD) %NAME OPND) %INTEGER I %RECORD (IOPNDF) %NAME IOPND %FOR I=0,1,CPTR-1 %CYCLE IOPND==IOPNDA(I) %IF OPND_S1=IOPND_OPND_S1 %AND OPND_D=IOPND_OPND_D %AND %C OPND_XTRA=IOPND_OPND_XTRA %THENSTART IOPND_CNT=IOPND_CNT+1 %RETURN %FINISH %REPEAT %RETURNIF CPTR>MAX IOPND==IOPNDA(CPTR) IOPND_CNT=1 IOPND_MODE=MODE IOPND_OPND=OPND CPTR=CPTR+1 %END %ROUTINE QUICKSORT(%RECORD (IOPNDF) %ARRAYNAME X, %INTEGER FROM,TO) %INTEGER L,U %RECORD (IOPNDF) D %RETURNIF FROM>=TO; ! NOTHING (LEFT) TO SORT L=FROM; U=TO D=X(U); ! THE PARTITION BOUND %CYCLE L=L+1 %WHILE L=U X(U)=X(L); U=U-1 %WHILE L=U X(U)=D L=L-1; U=U+1 QUICKSORT(X,FROM,L) %IF FROMU %END %END %END; ! OF ROUTINE GENERATE %ENDOFFILE