! ! 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.TRIMP_HOSTCODES" %CONSTINTEGER HOST=EMAS %CONSTINTEGER TARGET=AMDAHL %CONSTINTEGER FOURKTDISP=0 %INCLUDE "ERCC10.OPOUTS" ! %CONSTINTEGER LGR=X'58',AND=X'54',ICP=X'59'; ! VARIANT MNEMONICS %IF TARGET=IBM %THEN %START %OWNINTEGER BALCODE=BAL %FINISH %ELSE %START %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'000F0000'; ! ANY GR FROM 0-15 %CONSTINTEGER GR1=X'0001000F'; ! ANY GR BAR GR0 %CONSTINTEGER FR0=X'00100013'; ! ANY FR %CONSTINTEGER GRSAFE=X'00040009'; ! ANY GR SAFE AGAINT RT CALL %CONSTINTEGER GRPAIR=X'01000008' %CONSTINTEGER FRPAIR=X'01100012' %CONSTINTEGER GRSEQ=X'81000008' %CONSTINTEGER GRQUAD=X'83000006' %CONSTINTEGER ANYGR=-1,ANYGRBAR0=-2,ANYFR=-3,ANYSAFEGR=-4, ANYGRPAIR=-5,ANYFRPAIR=-6,ANY2SEQ=-7,ANY4SEQ=-8 %CONSTINTEGERARRAY NEGREG(-8:-1)=GRQUAD,GRSEQ,FRPAIR,GRPAIR,GRSAFE,FR0,GR1,GR0; ! ! PARAMETERISE THE REGISTER USESES ! %CONSTINTEGER IRESULT=1,TEMPBASE=2,RTPARAM=3,NAMEBASE=4,LITCONST=5, TABCONST=6,ADDROF=7,BASEOF=8,LOCALVAR=9,LOCALTEMP=10, FOURKMULT=11,LABFOURK=12,BASEREG=13,PERMFOURK=14,DVBASE=15, STRWKAREA=16 %CONSTBYTEINTEGERARRAY REGWORDS(0:127)=X'11'(96){PRECS 0-5}, X'11',X'22',X'12',X'11'(13){PREC=6}, X'11',X'44',X'24',X'11'(13){PREC=7}; ! ABOVE IS NO OF REGS<<4!NO OF 32 BIT WORS %CONSTBYTEINTEGERARRAY REGCODE(0:MAXREG)= 0,1,2,3,4,5,6,7,8,9, 10,11,12,13,14,15,0,2,4,6; %CONSTBYTEINTEGERARRAY DISPREG(-1:8)=WSPR,GLAREG,10,9,8,7,6,5,4,3; %CONSTBYTEINTEGERARRAY GRMAP(0:14)=0,1,2,3,15,16,17,18,19, 4,5,6,7,8,9; %CONSTBYTEINTEGERARRAY LDCODE(0:15)=IC(4),LH,LGR,LM,LM,0(5),LE,LD,LD; %CONSTBYTEINTEGERARRAY STCODE(0:15)=STC(4),STH,ST,STM,STM,0(5),STE,STD,STD; %CONSTBYTEINTEGERARRAY WHICHREG(0:15)=0(3),-ANYGR(3),-ANYGRPAIR,-ANY4SEQ, 0(5),-ANYFR(2),-ANYFRPAIR ! %INCLUDE "ERCC07.TRIPCNSTS" %INCLUDE "ERCC07.TRIMP_TFORM1S" %INCLUDE "ERCS12.XAOPT_SPECS" %IF HOST=EMAS %START %RECORDFORMAT REGF(%INTEGER CL,CNT,AT,(%INTEGER USE %OR %HALF SECUSE,PRIMUSE), %INTEGER INF1,INF2,LINK) %ELSE %RECORDFORMAT REGF(%INTEGER CL,CNT,AT,(%INTEGER USE %OR %SHORT SECUSE,PRIMUSE), %INTEGER INF1,INF2,LINK) %FINISH %OWNINTEGER CONSTHOLE,PROFDATA, OLDLINE,HALFHOLE %OWNINTEGERNAME CA,GLACA %OWNINTEGER FPPTR=0,FPHEAD=0,LASTPARREG=0 %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:10) %EXTRINSICRECORD(WORKAF)WORKA %EXTRINSICRECORD(PARMF) PARM %OWNRECORD(REGF)%ARRAY REGS(0:MAXREG) %CONSTINTEGER MAXKXREF=5 %OWNINTEGERARRAY KXREFS(0:MAXKXREF) %CONSTSTRING(11)%ARRAY KXREFNAME(0:MAXKXREF)="S#STOP","S#NDIAG", "S#ILOG","S#IEXP","S#IOCP", "ICL9CEAUXST"; %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) %IF HOST=IBM %OR HOST=IBMXA %OR HOST=AMDAHL %START %EXTERNALINTEGERMAPSPEC COMREG %ALIAS "S#COMREGMAP"(%INTEGER N) %ELSE %EXTERNALINTEGERMAPSPEC COMREG %ALIAS "S#COMREG" (%INTEGER N) %FINISH %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) %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=4; ! 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 ! %CONSTINTEGER FIXEDGLALEN=56 %OWNINTEGERARRAY FIXED GLA(0:FIXEDGLALEN>>2-1)=M'IMPG',0, 0(6),M'IDIA',0(*); ! %ROUTINE CPINIT !*********************************************************************** !* PERFORMS ANY NECESSARY TARGET DEPENDANT INITIALISING * !*********************************************************************** %INTEGER I %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'). %C " Version ".WORKA_LADATE PINITIALISE(-1{STRING},WORKA_RELEASE,ADDR(HD));! OPEN OBJECT FILE %IF HOST=EMAS %AND PARM_BITS1&1{QUOTES}#0 %THEN BALCODE=BAL %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 96>16 %AND CTABLE(K+1)>>16=C2 %THEN %C D=4*K+2 %AND %RETURN %REPEAT %FINISH %ELSE %START J=CONSTPTR-LP %WHILE K<=J %CYCLE %IF CTABLE(K)=C1 %AND CTABLE(K+1)=C2 %AND %C (CONSTHOLE=K+LP) %START %IF L=8 %OR (CTABLE(K+2)=C3 %C %AND CTABLE(K+3)=C4) %THEN D=4*K %C %AND %RETURN %FINISH K=K+2 %REPEAT %FINISH %IF L=2 %START %IF HALFHOLE#0 %THEN %START CTABLE(HALFHOLE)=CTABLE(HALFHOLE)!(C1>>16) D=4*HALFHOLE+2 HALFHOLE=0 %RETURN %FINISH %IF CONSTHOLE#0 %START CTABLE(CONSTHOLE)=C1 HALFHOLE=CONSTHOLE CONSTHOLE=0 D=4*HALFHOLE %RETURN %FINISH CTABLE(CONST PTR)=C1 HALFHOLE=CONST PTR D=4*HALFHOLE CONST PTR=CONST PTR+1 %RETURN %FINISH %IF L=4 %AND CONSTHOLE#0 %START CTABLE(CONSTHOLE)=C1 D=4*CONSTHOLE CONSTHOLE=0 %RETURN %FINISH %IF L=6 %START %IF 0>16 CTABLE(CONSTHOLE)=C1<<16!C2>>16 D=4*HALFHOLE+2 HALFHOLE=0; CONSTHOLE=0 %RETURN %FINISH %IF 0>16 CTABLE(CONSTPTR)=C1<<16!C2>>16 D=4*HALFHOLE+2 HALFHOLE=0 CONST PTR=CONST PTR+1 %RETURN %FINISH CTABLE(CONST PTR)=C1 CTABLE(CONST PTR+1)=C2 HALFHOLE=CONST PTR+1 D=4*CONST PTR CONST PTR =CONST PTR+2 %RETURN %FINISH %IF L>4 %AND CONST PTR&1#0 %C %THEN CONSTHOLE=CONST PTR %AND CONSTPTR=CONST PTR+1 D=4*CONST PTR CTABLE(CONSTPTR)=C1 CTABLE(CONSTPTR+1)=C2 %IF L=16 %THEN CTABLE(CONSTPTR+2)=C3 %C %AND CTABLE(CONSTPTR+3)=C4 CONST PTR=CONST PTR+LP %IF CONST PTR>WORKA_CONST LIMIT %THEN FAULT(102, WORKA_WKFILEK,0) %END %ROUTINE STORE STRING(%INTEGERNAME D, %STRINGNAME S) !*********************************************************************** !* PUT THE STRING CONSTANT "S" INTO THE CONSTANT TABLE * !* A CHECK IS MADE TO SEE IF THE CONSTANT HAS ALREADY * !* BEEN INSERTED IN WHICH CASE THE OLD COPY IS REUSED * !*********************************************************************** %INTEGER J,K,LP,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))) %THEN D=4*K %ANDRETURN %REPEAT %IF L<=3 %AND CONSTHOLE>0 %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:19) =%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; %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 %CONTINUE %IF 10<=I<=14; ! SKIP FIXED USE REGS REG==REGS(I) USE=REG_USE&X'FF'; ! MAIN USE ONLY PUSH(HEAD, REG_INF1, REG_AT, I<<8!USE) %IF USE#0 %REPEAT %END %ROUTINE RESTORE(%INTEGER HEAD) !*********************************************************************** !* RESET THE REGISTERS TO ENVIRONMENT IN LIST HEADED BY 'HEAD' * !* 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 REG==REGS(I) %IF REG_CL>=0 %THEN %START %IF REG_USE=BASEREG %THEN DROPMASK=DROPMASK!(1<>8; USE=I&255 REG==REGS(R) %IF REG_CL>=0 %START %IF USE#BASEREG %THEN REG_USE=USE %AND REG_INF1=INF %ELSE %START %IF REG_USE=BASEREG %AND INF=REG_INF1 %THEN %C 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 %C (REG_SECUSE=U %AND REG_INF2=LCELL_S1) %START HEAD==LCELL_LINK %IF REG_AT>LCELL_S2 %THEN LCELL_S2=REG_AT ! TAKE MOST RECENT VERSION OF AT %FINISH %ELSE POP(HEAD,S1,S2,S3) %REPEAT %END %EXTERNALROUTINE PDATA(%INTEGER AREA,BNDRY,L,AD) !*********************************************************************** !* ADDS L(BYTES) TO AREA FOR UST,SST AND DIAGS AREAS * !*********************************************************************** %INTEGERNAME PTR PTR==CAS(AREA) PTR=(PTR+BNDRY-1)&(-BNDRY) %RETURN %IF PARM_INHCODE#0 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) %RETURN %IF PARM_INHCODE#0 PDPATTERN(AREA,PTR,REP,L,AD) 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 %THEN %START KK=CAS(DAREA) PSETOPD(JJ,0,MVI<<8!((KK>>8)&255)) PSETOPD(JJ,2,MVI<<8!(KK&255)) %FINISH %ELSE %START 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(255)XNAME XNAME=UCSTRING(YNAME) TYPE=PTYPE&7 PREC=PTYPE>>4&7 LITL=PTYPE>>14&3 OPND=INIT %IF PTYPE&X'400'#0 %START; ! OWN NAMES 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 %THEN %START PDBYTES(2,GLACA,ACC,ADDR(WORKA_A(OPND_D))) GLACA=GLACA+ACC %FINISH %ELSE %START %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) PDBYTES(2,GLACA,16,ADDR(AHW0)) RES=GLACA GLACA=GLACA+16 LITL=PTYPE>>14&3 %IF LITL=3 %START; ! EXTRINSIC ARRAYS PDXREF(SIZE,2,RES,XNAME) PDXREF(SIZE,2,RES+4,XNAME); ! RELOCATE BY EXTERNAL %FINISH %ELSE %START %IF AAREA#0 %THEN RELOCATE(RES,AHW0,AAREA) %AND %C RELOCATE(RES+4,AHW1,AAREA) %FINISH RELOCATE(RES+8,AHW2,CAREA); ! RELOCATE DV PTR %IF LITL=2 %THEN 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) 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 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(NAME,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 %ROUTINE CALL STOP !*********************************************************************** !* CALLS STOP ROUTINE. NOT VIA EPILOGUE ON PERQ * !************************************************************************ PIX RS(STM,4,14,WSPR,16) PIX RS(LM,12,14,GLAREG,KNOWNXREF(0)) PIX RR(BALCODE-X'40',15,14) %END %EXTERNALROUTINE RELOCATE(%INTEGER GLARAD,VALUE,AREA) !*********************************************************************** !* PLANTS A WORD IN THE GLA (IF GLARAD<0) AND ARRANGES TO * !* RELOCATE IT RELATIVE TO AN AREA(CODE=1,GLA=2,CST=4,GST=5,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 %RECORD(REGF)%NAME REG %CYCLE I=0,1,MAXREG REG==REGS(I) %IF REG_CL<0 %AND 10<=I<=14 %THEN %CONTINUE %IF REG_CL!REG_USE#0 %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 ") %C %AND OUT(USE>>16,REG_INF2) 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 PRHEX(INF,8) %ELSE WRITE(INF,1) %IF UNMASK&1<>16#0 %THEN PRINTSTRING(" MODBY ") %C %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+3 %IF MAX4KMULT<10 %THEN SWITEMSIZE=2 %ELSE SWITEMSIZE=4 CPINIT; ! INITIALISE CODE PLANTING ASLIST==ALIST CA==CAS(1) GLACA==CAS(2) CA=0 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 ! ! 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 ! ! GENERATE THE RUN TIME ERROR ROUTINE :- ! MDIAGS FOR NR IS %ROUTINE MDIAGS(%INT PC,LNB,ERROR,XTRA) ! PC IS A DUMMY (SEG FIELD ONLY USED) EXCEPT AFTER CONTINGENCY ! ON ENTRY TO THIS SUBROUTINE ERROR & XTRA ARE IN GRS 0&1 ! ENTRY HAS BEEN BY BAS LINKREG SO RETURN ADDRESS IS AVAILABLE ! ! ST 15,64(11) ! STM 0,1,72(11) ! LR 0,10 ! LR 1,9 ! BAS LINKREG,CHECK IF R9 A VALID LNB ! LR 1,8 ! BAS LINKREG,CHECK DITTO FOR R8 ! LR 1,7 ! BAS LINKREG,CHECK DITTO ! LR 1,6 ! BAS LINKREG,CHECK DITTO ! LR 1,5 ! BAS LINKREG,CHECK DITTO !CHFAIL ST 0,68(11) ! STM 4,14,16(11) ! LM CODER,EPREG,40(13) MDIAG ENTRY POINT ! L 15,64(11) ! BCR 15,EPREG !CHECK CR 1,11 ! BC 2,CHFAIL ! CR 1,0 ! BC 12,CHKAIL ! C 1,44(1) CHECK STORE STACK POINTER ! BC 7,CHFAIL ! LR 0,1 ! BCR 15,LINKREG ! PLABEL(GLABEL) WORKA_PLABS(2)=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(STM,4,14,11,16) 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 RR(CR,1,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 %THEN %START 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 ! ! ! AR 1,11 BYTE TO START CLEARING ! AR 11,0 CLAIM SPACE !AGN CR 1,11 ! BCR 10,LINKREG ! MVI 0(1),UNASSPAT ! MVC 1(255,1),0(1) ! LA 1,256(1) ! BC 15,AGN ! ! THIS NEXT VERSION IS FOR XA ARCHITECTURE ONLY ! ! LA 2,0(1,11) ! AR 11,0 ADVANCE STACK FRONT ! SR 0,1 LENGTH OF FILL ! LR 1,0 TO CORRECT PLACE ! LR 0,2 ! LA 3,UNASSPAT&255 ! SLL 3,24 ! MVCL 0,2 ! BCR 15,LINKREG %IF PARM_CHK=1 %THEN %START; ! ONLY REQUIRED WITH CHKING PLABEL(GLABEL) WORKA_PLABS(4)=GLABEL; GLABEL=GLABEL-1 PIX RX(LA,2,1,WSPR,0) PIX RR(AR,WSPR,0) PIX RR(SR,0,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 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 %IF PARM_PROF#0 %THEN %START; ! ALLOCATE PROFILE COUNT AREA PROFDATA=GLACA 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 * !*********************************************************************** %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) LONGOP(MXR) P18: ! ! DIVIDE TWO LONG INTEGES AT WSPR+8 AND WSPR+16S ! %IF WORKA_PLINK(18)=0 %THEN ->P19 ! ! BASR 1,0 ! NC OPND2(5),OPND2 CHECK FOR SMALL +VE DIVISOR ! BC 7,LONGWAY ! LM 0,1,OPND1 ! D 0,OPND2+4 ! LR 0,1 ! SRDA 0,32 ! BCR 15,15 !LONGWAY FILL(18) ! PIX RR(BALCODE-X'40',1,0) ! PIX SS(NC,0,5,WSPR,16,WSPR,16) ! PIX RX(BC,7,0,1,26) ! 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) LONGOP(DXR) P19: ! CONCATENATION ONE ! NOW DONE IN LINE %IF WORKA_PLINK(19)!WORKA_PLINK(20)=0 %THEN ->P21 P21: %BEGIN !*********************************************************************** !* PASS INFORMATION TO IPUT TO ENABLE IT TO GENERATE THE * !* LOADER DATA AND COMPLETE THE PROGRAM FILE. * !*********************************************************************** %ROUTINESPEC DUMPCONSTS %INTEGER LANGFLAG,PARMS,I,J,K CODE OUT 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 %THEN %START ! 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 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 %THEN PTERMINATE(ADDR(CAS(1)),MAX4KMULT) %IF WORKA_OPTCNT>0 %THEN %START 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 %THEN %START WRITE(STMTS, 7); PRINTSTRING(" STATEMENTS COMPILED") COMREG(47)=STMTS; ! NO OF STMTS FOR COMPER %FINISH %ELSE %START PRINTSTRING("PROGRAM CONTAINS"); WRITE(PARM_FAULTY, 2) PRINTSTRING(" FAULT"); PRINTSYMBOL('S') %IF PARM_FAULTY>1 COMREG(47)=PARM_FAULTY; ! NO OF FAULTS FOR COMPER %FINISH NEWLINES(2) I=0; I=8 %IF PARM_FAULTY#0 COMREG(24)=I ! SUMMARY INFO. 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 %THEN %RETURN 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 %EXIT %IF 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 %ELSE %IF B2>0 %THEN %C 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 %ELSE %IF B3>0 %THEN %C 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 CONSTEXP(%INTEGER PTYPE,VALUE) %ROUTINESPEC SAVE IRS(%INTEGER UPPER) %ROUTINESPEC SET USE(%INTEGER REG,PTYPE,USE,INF) %ROUTINESPEC FREE AND FORGET(%INTEGER REG) %ROUTINESPEC FORGET(%INTEGER REG) %ROUTINESPEC COPY USE(%INTEGER TO,FROM) %ROUTINESPEC FORGETM(%INTEGER UPPER) %ROUTINESPEC CLAIM THIS REG(%INTEGER REG) %ROUTINESPEC CLAIM ALL4 FRS %INTEGERFNSPEC CLAIM OTHER FRPAIR(%INTEGER PAIR0) %ROUTINESPEC FIND USE(%INTEGERNAME REG,%INTEGER PTYPE,USE,INF) %INTEGERFNSPEC FINDREG(%INTEGER MASK,CLVAL) %INTEGERFNSPEC FINDSEQREG(%INTEGER MASK,CLVAL) %INTEGERFNSPEC CHECKSEQREG(%INTEGER MASK) %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) %ROUTINESPEC SSTRASS(%RECORD(RD)%NAME LHOPND,RHOPND,%INTEGER ACC) %INTEGERFNSPEC SSVARASS(%INTEGER S,B,D,%RECORD(RD)%NAME OPND) %ROUTINESPEC VMULTIPLY %ROUTINESPEC LNEGATE(%INTEGER REG) %ROUTINESPEC REALEXP %ROUTINESPEC STARSTAR %ROUTINESPEC NOTE ASSMENT(%INTEGER REG,ASSOP,VAR,PTYPE) %ROUTINESPEC CEND %INTEGERFNSPEC REACHABLE(%INTEGER LAB,LINK) %ROUTINESPEC LOAD(%RECORD(RD) %NAME OP,%INTEGER REG,MODE) %ROUTINESPEC LOAD PAIR(%INTEGER TYPE,ODDEVEN,%RECORD(RD)%NAME OPND) %ROUTINESPEC LOADAD(%RECORD(RD) %NAME OPND,%INTEGER REG) %ROUTINESPEC LOADPTR(%RECORD(RD) %NAME OPND,OPND2,%INTEGER REG) %ROUTINESPEC DSTORE(%INTEGER REG,SIZE,LEVEL,DISP) %ROUTINESPEC CALL COMING(%INTEGER UPPER) %ROUTINESPEC CALL MADE %ROUTINESPEC GET IN ACC(%INTEGERNAME REG,%INTEGER SIZE,%RECORD(RD)%NAME OPND) %ROUTINESPEC GET OUT OF ACC(%INTEGER REG,SIZE,%RECORD(RD)%NAME OPND) %ROUTINESPEC BOOT OUT(%INTEGER REG) %ROUTINESPEC DFETCH(%INTEGERNAME REG,%INTEGER SIZE,LEVEL,DISP) %ROUTINESPEC 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 LOADED(%RECORD(RD)%NAME OPND,%INTEGER REG) %ROUTINESPEC OPERAND RELOADED(%RECORD(RD)%NAME OPND,%INTEGER REG) %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 %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'00000000'{40 PPROF PRINT PROFILE IGNORED}, 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 }, 0(3), 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'20061021'{141 VMY}, X'20010422'{142 COMB}, X'200E0623'{143 ASSIGN=}, X'200E0624'{144 ASSIGN<-}, X'20022025'{145 ****}, X'20060026'{146 BASE ADJ}, X'200E0C27'{147 ARR INDEX}, X'20060428'{148 INDEXED FETCH}, X'200E0629'{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}, 0(*) %CONSTBYTEINTEGERARRAY FCOMP(0:79)=0(2),2(2),4(2),6(2),8(2),10(2),12(2),14(2), 0(2),4(2),2(2),6(2),8(2),12(2),10(2),14(2), 0(2),21(2),22(2),36(2),20(2),38(2),37(2),15(2), 0(2),22(2),21(2),36(2),20(2),37(2),38(2),15(2), 0(2),5(2),2(2),7(2),8(2),13(2),10(2),15(2); ! ! THE FOLLOWING ARRAY HAS INSTRUCTION SEQUENCES FOR THE VARIOUS IMP ! IMP OPERATION PRECCED BY A SWITH LABEL AT WHICH THEY ARE PLANTED ! TOUGH CASES LIKE ** HAS A UNIQUE ONE-OFF SWITCH. ! LOOK UP THE SWITCH LABEL FOR PARAMETER DECODING IN DIFFICULT CASES ! %CONSTINTEGER NISEQS=34 %CONSTBYTEINTEGERARRAY ISEQS(40:4*(4*NISEQS+10)-1)={FIRST INTEGER FORMS} %C 8,0,0,-ANYGR {10 INTEGER LOGICAL NOT}, 2,LCR,0,-ANYGR {11 INTEGER LOGICAL NEGATE}, 12,0,0,0 {12 INTEGER FLOAT TO REAL}, 2,LPR,0,-ANYGR {13 INTEGER MODULUS}, 9,0,0,0 {14 SHORTEN INTEGER TO 16 BIT}, 10,0,0,0 {15 LENGTHEN INTEGER}, 21,0,0,0 {16 SHORTEN INTEGER FOR JAM}, 1,0,0,109 {17 COMPILER ERROR}, 7,0,0,0 {18 NOOP}, 6,0,0,-ANYGR {19 PRELOAD}, 3,A,AH,0 {20 INTEGER ADDITION}, 3,S,SH,0 {21 INTEGER SUBTRACTION}, 4,X,0,-ANYGR {22 INTEGER NONEQUIVALENCE}, 4,O,0,-ANYGR {23 INTEGER LOGICAL OR}, 11,M,0,-ANYGR {24 INTEGER MULTIPLY}, 11,DR+X'40',0,0 {25 INTEGER INTEGER DIVIDE}, 1,0,0,109 {26 INTEGER REAL DIVIDE}, 4,AND,0,-ANYGR {27 INTEGER AND}, 17,SRL,0,-ANYGR {28 INTEGER RIGHT SHIFT}, 17,SLL,0,-ANYGR {29 INTEGER LEFT SHIFT}, 1,0,0,109 {30 REAL EXP OPERATOR}, 13,ICP,CH,-ANYGR {31 INTEGER COMPARISONS}, 14,ICP,CH,-ANYGR {32 FIRST PART OF DOUBLE COMPARISONS}, 15,0,0,0 {33 VMY}, 4,A,0,-ANYGR {34 COMBINE VMY RESULTS}, 16,0,0,-ANYGR {35 ASSIGN}, 16,0,0,-ANYGR {36 ASSIGN(<-)}, 22,1,0,0 {37 INTEGER EXPONENTIATION}, 18,2,0,0 {38 BASE ADJUST ARRAY INTEGER INDEX}, 19,2,0,0 {39 ARRAY INDEX INTEGER INDEX}, 20,0,0,0 {40 INDEXED FETCH INTEGER INDEX}, 23,0,0,-ANYGR {41 LASS}, 24,LTR,0,-ANY GR {42 ZCOMP COMPARISON WITH ZERO}, 25,0,0,-ANYGR {43 INTEGER SHIFT BY CONSTANT}, 8,0,0,-ANY2SEQ {10 LONG INTEGER LOGICAL NOT}, 29,0,0,-ANY2SEQ {11 LONG INTEGER LOGICAL NEGATE}, 27,0,0,0 {12 LONG INTEGER FLOAT TO REAL}, 30,0,0,-ANY2SEQ {13 LONG INTEGER MODULUS}, 9,0,0,0 {14 SHORTEN LONG INTEGER TO 16 BIT}, 10,0,0,0 {15 LENGTHEN LONG INTEGER}, 21,0,0,0 {16 SHORTEN LONG INTEGER FOR JAM}, 1,0,0,109 {17 COMPILER ERROR}, 7,0,0,0 {18 NOOP}, 6,0,0,-ANYGRPAIR {19 PRELOAD}, 26,AL,A,12 {20 LONG INTEGER ADDITION}, 26,SL,S,3 {21 LONG INTEGER SUBTRACTION}, 26,X,X,0 {22 LONG INTEGER NONEQUIVALENCE}, 26,O,O,0 {23 LONG INTEGER LOGICAL OR}, 28,0,0,17 {24 LONG INTEGER MULTIPLY}, 28,0,0,18 {25 LONG INTEGER LONG INTEGER DIVIDE}, 1,0,0,109 {26 LONG INTEGER REAL DIVIDE}, 26,AND,AND,0 {27 LONG INTEGER AND}, 17,SRDL,0,-ANYGRPAIR {28 LONG INTEGER RIGHT SHIFT}, 17,SLDL,0,-ANYGRPAIR {29 LONG INTEGER LEFT SHIFT}, 1,0,0,109 {30 REAL EXP OPERATOR}, 13,ICP,CL,-ANY2SEQ {31 LONG INTEGER COMPARISONS}, 14,ICP,CL,-ANY2SEQ {32 FIRST PART OF DOUBLE COMPARISONS}, 15,0,0,0 {33 VMY}, 4,A,0,1 {34 COMBINE VMY RESULTS}, 16,0,0,-ANY2SEQ {35 ASSIGN}, 16,0,0,-ANY2SEQ {36 ASSIGN(<-)}, 1,0,0,99 {37 LONG INTEGER EXPONENTIATION}, 1,0,0,109 {38 BASE ADJUST ARRAY LONG INTEGER INDEX}, 1,0,0,109 {39 ARRAY INDEX LONG INTEGER INDEX}, 1,0,0,109 {40 INDEXED FETCH LONG INTEGER INDEX}, 23,0,0,-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 {10 REAL LOGICAL NOT}, 2,LCDR,LCER,3 {11 REAL LOGICAL NEGATE}, 1,0,0,109 {12 FLOAT REAL COMPILER ERROR}, 2,LPDR,LPER,3 {13 REAL MODULUS}, 9,0,0,0 {14 SHORTEN REAL}, 10,0,0,0 {15 LENGTHEN REAL}, 9,0,0,0 {16 SHORTEN REAL FOR JAM}, 1,0,0,109 {17 COMPILER ERROR}, 7,0,0,0 {18 NOOP}, 6,0,0,-ANYFR {19 PRELOAD}, 4,AD,AE,3 {20 REAL ADDITION}, 4,SD,SE,3 {21 REAL SUBTRACTION}, 7,0,0,0 {22 REAL NONEQUIVALENCE}, 7,0,0,0 {23 REAL LOGICAL OR}, 4,MD,ME,3 {24 REAL MULTIPLY}, 7,0,0,0 {25 REAL INTEGER DIVIDE}, 4,DD,DE,3 {26 REAL REAL DIVIDE}, 7,0,0,0 {27 REAL AND}, 7,0,0,0 {28 REAL LEFT SHIFT}, 7,0,0,0 {29 REAL RIGHT SHIFT}, 22,2,0,0 {30 REAL EXP OPERATOR}, 13,CD,CE,3 {31 REAL COMPARISONS}, 14,CD,CE,3 {32 FIRST PART OF DOUBLE COMPARISONS}, 7,0,0,0 {33 VMY}, 7,0,0,0 {34 COMBINE VMY RESULTS}, 16,0,0,-ANYFR {35 ASSIGN}, 16,0,0,-ANYFR {36 ASSIGN(<-)}, 7,0,0,0 {37 REAL INTEGER EXPONENTIATION}, 1,0,0,109 {38 BASE ADJUST ARRAY REAL INDEX}, 7,0,0,0 {39 ARRAY INDEX REAL INDEX}, 3,0,0,0 {40 INDEXED FETCH REAL}, 23,0,0,3 {41 LASS}, 24,LTDR,LTER,-ANYFR {42 ZCOMP COMPARISONS WITH ZERO}, 7,0,0,0 {43 SHIFT BY CONST -ERROR}, 7,0,0,0 {10 EXTENDED REAL LOGICAL NOT}, 2,LCDR,LCDR,-ANYFRPAIR {11 EXTENDED REAL LOGICAL NEGATE}, 1,0,0,109 {12 FLOAT EXTENDED REAL COMPILER ERROR}, 2,LPDR,LPDR,-ANYFRPAIR {13 EXTENDED REAL MODULUS}, 9,0,0,0 {14 SHORTEN EXTENDED REAL}, 10,0,0,0 {15 LENGTHEN EXTENDED REAL}, 9,0,0,0 {16 SHORTEN EXTENDED REAL FOR JAM}, 1,0,0,109 {17 COMPILER ERROR}, 7,0,0,0 {18 NOOP}, 6,0,0,-ANYFRPAIR {19 PRELOAD}, 31,0,AXR,-ANYFRPAIR {20 EXTENDED REAL ADDITION}, 31,0,SXR,-ANYFRPAIR {21 EXTENDED REAL SUBTRACTION}, 7,0,0,0 {22 EXTENDED REAL NONEQUIVALENCE}, 7,0,0,0 {23 EXTENDED REAL LOGICAL OR}, 31,0,MXR,-ANYFRPAIR {24 EXTENDED REAL MULTIPLY}, 7,0,0,0 {25 EXTENDED REAL INTEGER DIVIDE}, 31,DXR>>8,DXR&255,-ANYFRPAIR {26 EXTENDED REAL EXTENDED REAL DIVIDE}, 7,0,0,0 {27 EXTENDED REAL AND}, 7,0,0,0 {28 EXTENDED REAL LEFT SHIFT}, 7,0,0,0 {29 EXTENDED REAL RIGHT SHIFT}, 22,2,0,0 {30 EXTENDED REAL EXP OPERATOR}, 13,CD,CD,-ANYFRPAIR {31 EXTENDED REAL COMPARISONS}, 14,CD,CD,-ANYFRPAIR {32 FIRST PART OF DOUBLE COMPARISONS}, 7,0,0,0 {33 VMY}, 7,0,0,0 {34 COMBINE VMY RESULTS}, 16,0,0,-ANYFRPAIR {35 ASSIGN}, 16,0,0,-ANYFRPAIR {36 ASSIGN(<-)}, 7,0,0,0 {37 EXTENDED REAL INTEGER EXPONENTIATION}, 1,0,0,109 {38 BASE ADJUST ARRAY EXTENDED REAL INDEX}, 7,0,0,0 {39 ARRAY INDEX EXTENDED REAL INDEX}, 3,0,0,0 {40 INDEXED FETCH EXTENDED REAL}, 23,0,0,-ANYFRPAIR {41 LASS}, 24,LTDR,0,-ANYFRPAIR {42 ZCOMP COMPARISONS WITH ZERO}, 7,0,0,0 {43 SHIFT BY CONST -ERROR} %SWITCH SW(0:35),TRIPSW(0:76) ! CURRINF==WORKA_LEVELINF(CURRLEVEL) CLNB=DISPREG(CURRINF_RBASE) %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 %WHILE STPTR>0 %CYCLE %IF PARM_Z#0 %AND PARM_DCOMP#0 %THEN %START NEWLINE PLINEDECODE PRINT USE PRINT THIS TRIP(TRIPLES,STPTR) %FINISH CURRT==TRIPLES(STPTR) WTRIPNO=STPTR STPTR=CURRT_FLINK COMM=1 OPND1==CURRT_OPND1 OPND2==CURRT_OPND2 XTRA=CURRT_X1 JJ=CURRT_OPERN TRIPINF=TRIPDATA(JJ) CA=CA+TRIPINF>>8&255;! APPROX WORDRST CA FOR BASE REGISTER COVER C=TRIPINF>>28; ! TRIPLE TYPE TRIPVAL=TRIPINF&255 PTYPE=OPND1_PTYPE&255; TYPE=PTYPE&7 %IF C=0 %THENCONTINUE %IF C=1 %THEN ->TRIPSW(TRIPVAL) COMM=1 %IF TYPE=2 %THEN C=4*(TRIPVAL+2*NISEQS) %C %ELSE C=4*TRIPVAL %IF PTYPE=X'61' %OR PTYPE=X'72' %THEN C=C+4*NISEQS L0=ISEQS(C); B1=ISEQS(C+1) B2=ISEQS(C+2); B3=ISEQS(C+3) %IF TRIPINF&X'10000'#0 %AND OPND2_FLAG=REFTRIP %START WORKT==TRIPLES(OPND2_D) %IF WORKT_OPND1_FLAG=9 %THEN COMM=2 %FINISH %IF COMM=1 %THEN OPNDC==OPND1 %ELSE OPNDC==OPND2 %IF JJ>=128 %AND COMM=1 %THEN OPNDNC==OPND2 %ELSE OPNDNC==OPND1 %UNLESS JJ<128 %OR OPNDNC_FLAG=9 %OR TRIPINF&X'20000'#0 %THEN %C LOAD(OPNDNC,ANY GR,0) ->SW(L0) SW(1): ! ERROR CONDITION TRIPSW(0): FAULT(B3,0,0) %UNLESS TYPE=7 TRIPSW(*): 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 PIX RR(B2,REGCODE(EVALREG+1),REGCODE(EVALREG+1)) %C %AND FORGET(EVALREG+1) FORGET(EVALREG) ->SUSE ->STRES SW(3): ! INTEGER FORM NO PROBLEMS D=OPNDNC_PTYPE&255 %IF D=X'51' %AND B2#0 %AND OPNDNC_FLAG=0 %AND %C X'FFFF8000'<=OPNDNC_D<=X'7FFF' %THEN 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 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: OPERAND LOADED(OPND1,EVALREG) ->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) %FINISH %ELSE %IF PTYPE=X'52' %START LOAD(OPND1,ANY FR,2); ! TO ANY FR EVALREG=OPND1_XB PIX RR(LRER,REGCODE(EVALREG),REGCODE(EVALREG)) FORGET(EVALREG) %FINISH %ELSE %IF PTYPE=X'51' %START LOAD(OPND1,ANY GRPAIR,2); ! TO ANY GR PAIR EVALREG=OPND1_XB %IF PARM_OPT=0 %START REGS(EVALREG)_CL=0 FORGET(EVALREG) EVALREG=EVALREG+1 OPND1_XB=EVALREG %FINISH %ELSE %START PIX RS(SLDA,EVALREG,0,0,32) FORGET(EVALREG) REGS(EVALREG+1)_CL=0 %FINISH %FINISH %ELSE %IF PTYPE=X'41' %START LOAD(OPND1,ANY GR,2) EVALREG=OPND1_XB %IF PARM_OPT#0 %AND TRIPLES(CURRT_PUSE)_OPERN#SHRTN %THEN %START PIX RX(SLA,EVALREG,0,0,16) PIX RX(SRA,EVALREG,0,0,16) FORGET(EVALREG) %FINISH %FINISH %ELSE %IF PTYPE=X'31' %START LOAD(OPND1,ANY GR,2) EVALREG=OPND1_XB %IF PARM_OPT#0 %THEN %START DUMPRX(CL,EVALREG,0,CTABLEREG,KWCONSTS(1)) PPJ(2,9,NO) %FINISH %FINISH OPND1_PTYPE=CURRT_OPTYPE ->SUSE SW(10): ! LENGTHEN INTEGER OR REAL %IF TYPE=2 %THEN %START %IF CURRT_OPTYPE=X'62' %START; ! 32 TO 64 BIT LOAD(OPND1,ANY FR,2) EVALREG=OPND1_XB DUMPRX(ME,REGCODE(EVALREG),0,CTABLEREG,KWCONSTS(4)) %FINISH %ELSE %START LOAD PAIR(2,0,OPND1) EVALREG=OPND1_XB DUMPRX(MXD,REGCODE(EVALREG),0,CTABLEREG,KLCONSTS(7));! =D'1' %FINISH %FINISH %ELSE %START %IF CURRT_OPTYPE=X'61' %THEN %START LOAD PAIR(1,0,OPND1) EVALREG=OPND1_XB DUMPRX(SRDA,EVALREG,0,0,32) %FINISH %ELSE %START LOAD(OPND1,ANY GR,2) EVALREG=OPND1_XB %FINISH %FINISH OPND1_PTYPE=CURRT_OPTYPE 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'%C %THEN ->MH1 %IF OPNDNC_FLAG=SCONST %AND X'FFFF8000'<=OPNDNC_D<=X'7FFF'%C %THEN ->MH2 %FINISH LOAD PAIR(1,B3,OPND1) C=OPND2_PTYPE>>4&7; ! OPND2 PREC %IF C<5 %THEN LOAD(OPND2,ANYGR,18) %ELSE LOAD(OPND2,ANY GR,17) EVALREG=OPND1_XB %IF CURRT_OPERN=INTDIV %THEN PIX RX(SRDA,EVALREG,0,0,32) PUT(EVALREG,B1,0,YES,OPND2) FORGET(EVALREG) FORGET(EVALREG+1) %IF CURRT_OPERN=INTDIV %OR PARM_OPT=0 %THEN %START REGS(EVALREG)_CL=0 EVALREG=EVALREG+1 %ELSE PIX RS(SLDA,EVALREG,0,0,32);! TEST FOR OVERFLOW REGS(EVALREG+1)_CL=0 %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 %START DUMPRX(LGR,P0,0,CTABLEREG,D) DUMPM(STM,P0,P1,WSPR,0) %ELSE PIX RX(ST,P1,0,WSPR,4) PIX SS(MVC,0,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 %FINISH %ELSE %START LOAD(OPND1,ANY GR,2) ! NO CODE NEEDED FOR 32BITS & LESS EVALREG=OPND1_XB %FINISH OPND1_PTYPE=CURRT_OPTYPE ->SUSE SW(22): ! EXP IN ANY EXPRSN %IF OPND2_PTYPE&7=1 %THENSTART %IF OPND2_FLAG=SCONST %AND 2<=OPND2_D %THEN %C CONST EXP(OPND1_PTYPE&255,OPND2_D) %ELSE STARSTAR ->SUSE %FINISH ! REAL**REAL BY SUBROUTINE REALEXP; ->SUSE SW(17): ! INTEGER SHIFT LOAD(OPND1,-B3,2) LOAD(OPND2,ANYGR BAR0,2) 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 %C WORKT_X1=WORKT_X1!!(C!!(XTRA&15));! PASS MASK ON FOR JUMP ! SUITABLY AMENDED FOR BACK COMPARISON %IF TYPE=1 %AND PTYPE>>4<=5 %THEN ->SW(3) %IF TYPE=2%AND PTYPE>>4<=6 %THEN ->SW(4) ! COMPARISON OF MULTIREGISTER ITEMS LOAD(OPNDC,-B3,2) 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 %START; LOAD(OPND2,ANYGR BAR0,18) D=OPND2_XB %IF REGS(D)_CL>=0 %AND REGS(D)_CNT<=1 %THEN REGS(D)_CL=2 %AND REGS(D)_LINK=ADDR(OPND1) %IF OPND1_FLAG=SCONST %AND 0<=OPND1_D<=4095 %THEN %START OPND1_XB=D %FINISH %ELSE %START LOAD(OPND1,ANYGR BAR0,18) C=OPND1_XB %IF REGS(C)_CL>=0 %AND REGS(C)_CNT<=1 %THEN REGS(C)_CL=2 %AND %C REGS(C)_LINK=ADDR(OPND1) OPND1_XB=D<<4!C OPND1_D=0 %FINISH OPND1_FLAG=11 %FINISH %ELSE %START LOAD(OPND2,ANYGRBAR0,2) LOAD(OPND1,ANY GR,17) EVALREG=OPND2_XB PUT(EVALREG,A,0,YES,OPND1) OPERAND LOADED(OPND1,EVALREG) %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 TOPND=OPND1 EVALREG=-1; ! IN CASE SS ASSGNMNT MADE %IF OPND1_FLAG=2 %START; ! OPERAND A NAME TCELL==ASLIST(TAGS(OPND1_D)) %IF SSVARASS(BYTES(PT>>4),DISPREG(TCELL_UIOJ>>4&15), TCELL_SLINK+OPND1_XTRA,OPND2)=NO %THEN %START LOAD(OPND2,-B3,18) EVALREG=OPND2_XB DSTORE(EVALREG,BYTES(PT>>4),TCELL_UIOJ>>4&15,TCELL_SLINK+OPND1_XTRA) %FINISH 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 SSVARASS(BYTES(PT>>4),OPND1_XB,OPND1_D,OPND2)=NO %START LOAD(OPND2,-B3,18) EVALREG=OPND2_XB GET OUT OF ACC(EVALREG,BYTES(PT>>4&7),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) %C %THEN 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' %FOR C=0,1,MAXREG %CYCLE %IF REGS(C)_USE=LOCALTEMP %AND KK&X'FFFFFF'<=REGS(C)_INF1&X'FFFFFF' %C <= KK&X'FFFFFF'+SIZE %THEN FORGET(C) %REPEAT %IF SSVARASS(SIZE,CLNB,OPND1_D&X'FFFF', OPND2)=NO %THEN %START %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))) %C %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=ORL %OR C=ANDL %OR C=NONEQ %C %OR C=CASHIFT %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) %ELSE %C %IF D=YES %THEN 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 %ELSE %C %IF D>=0 %THEN C=SLL %ELSE C=SRL %IF PTYPE=X'61' %THEN C=C+4; ! TO DOUBLE OPCODES LOAD(OPND1,-B3,2) EVALREG=OPND1_XB PIX RS(C,EVALREG,0,0,IMOD(D)) FORGET(EVALREG) ->SUSE SW(26): ! LONG INTEGER OPERATUION ! B3 IS THE MASK FOR CARRY 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)) %C %ELSE PIX RR(B2,REGCODE(EVALREG),REGCODE(OPND2_XB)) OPERAND USED(OPND2) FORGET(EVALREG) FORGET(EVALREG+1) ->SUSE TRIPSW(1): ! SET LINE NO %BEGIN %INTEGER I,LINE LINE=OPND1_D>>16 PLINESTART(LINE) %UNLESS PARM_OPT=0 %AND PARM_DCOMP#0 %IF PARM_DBUG#0 %START DUMPRX(LA,0,0,0,LINE) PPJ(0,3,YES) %FINISH %ELSE %IF PARM_LINE#0 %AND LINE#OLDLINE %START PIX SI(MVI,LINE&255,CLNB,3) %IF OLDLINE=0 %OR OLDLINE>>8#LINE>>8 %THEN %C PIX SI(MVI,LINE>>8,CLNB,2) OLDLINE=LINE %FINISH %IF PARM_PROF#0 %THEN %START DUMPRX(LA,0,0,0,1) I=PROFDATA+4+4*LINE DUMPRX(ADD,0,0,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(OPND1,ANY GR,2); ! LB DUMPRX(ST,OPND1_XB,0,CLNB,D) LOAD(OPND2,ANY GR,2); ! UB DUMPRX(ST,OPND2_XB,0,CLNB,D+4) %IF B1=X'80000000' %THEN %START PIX RR(SR,OPND2_XB,OPND1_XB) DUMPRX(A,OPND2_XB,0,CTABLEREG,KWCONSTS(3));! F'1' %FINISH %ELSE INC REG(OPND2_XB,1-B1,YES) DUMPRX(MH,OPND2_XB,0,CLNB,D+10);! MULT BY STRIDE 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) %FINISH %ELSE %START CLAIM THIS REG(JJ) %FOR JJ=0,1,3 B0=0 B0=B0-CTABLE(DVDISP>>2+3*JJ)*CTABLE(DVDISP>>2+3*JJ+2) %C %FOR JJ=1,1,ND %IF B0=0 %THEN PIX RR(SLR,0,0) %ELSE %C DUMPRX(LGR,0,0,CTABLEREG,WORD CONST(B0)) DUMPRX(LA,2,0,CTABLEREG,DVDISP) DUMPRX(LA,3,0,0,CTABLE((DVDISP+D0)>>2)) %FINISH %FINISH %ELSE PIX RR(SR,0,1) PIX RR(AR,0,WSPR) PIX RR(LR,1,WSPR) DSTORE(0,16,CURRINF_RBASE,TCELL_SLINK);! STORE AWAY HEAD %IF C=D %START; ! LAST IN THIS STMNT FREE AND FORGET(JJ) %FOR JJ=0,1,3 %FINISH %END %CONTINUE TRIPSW(5): ! CLAIM ARRAY SPACE ! OPND1_D=CDV<<31!SNDISP!DVDISP ! OPND1_XTRA HAS THE ARRAY NAME TCELL==ASLIST(TAGS(OPND1_XTRA)) PREC=TCELL_PTYPE>>4&15 D=OPND1_D&X'FFFF' %IF OPND1_D>0 %START; ! DYNAMIC DOPE VECTOR DUMPRX(A,WSPR,0,CLNB,D+4) %IF PREC<6 %AND TCELL_ACC&7#0 %START INC REG(WSPR,7,YES) DUMPRX(N,WSPR,0,CTABLEREG,WORD CONST(-8)) %FINISH %FINISHELSESTART; ! STATIC DOPE VECTORS C=CTABLE(OPND1_D>>16&X'7FFF'+1); ! ARRAYSIZE IN BYTES INC REG(WSPR,(C+7)&(-8),YES) %FINISH %CONTINUE TRIPSW(6): ! CHECK FOR ZERO FOR STEP LOAD(OPND1,ANY GR,2); ! STEP TO EVALREG EVALREG=OPND1_XB 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) REGS(1)_USE=1; ! FRIG TILL COUNTS WORK %IF PARM_OPT=0 %AND TRIPLES(CURRT_PUSE)_OPERN=FORPOST %THEN %C POLISH LOOP(CURRT) %CONTINUE TRIPSW(8): ! FOR POSTAMBLE REGS(1)_CL=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) %FINISH %ELSE PJINDEX(XTRA>>8,C,XTRA>>4&15,D) %FINISH %ELSE %START 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 %C %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 %C B=XTRA>>4&15 PJUMP(XTRA>>8,LCELL_S1&X'FFFF',XTRA>>4&15,B) %FINISH %ELSE %START PJINDEX(XTRA>>8,LCELL_S1&X'FFFF',XTRA>>4&15,C) %FINISH %FINISH %ELSE %IF D&1#0 %OR REACHABLE(OPND1_D&X'FFFF',STPTR)=YES %START SET LOCAL BASE PJUMP(B,LCELL_S1&X'FFFF',C,0) %FINISH %ELSE %START D=FINDREG(GR1,0) FORGET(D) PJUMP(B,LCELL_S1&X'FFFF',C,D) %FINISH %IF D&2#0 %START; ! ENVIRONMENT MANIPULATION %IF D&128#0 %START; ! FIRST JUMP TO THIS LAB C=0; GET ENV(C) %FINISH %ELSE %START C=LCELL_S2>>16 REDUCE ENV(C); ! LATER USE MUST MERGE %FINISH LCELL_S2=C<<16!(LCELL_S2&X'FFFF') %FINISH %CONTINUE TRIPSW(12): ! REMOVE LABEL %BEGIN %INTEGER S1,S2,S3 %INTEGERNAME CELL CELL==CURRINF_LABEL %WHILE CELL>0 %CYCLE %IF ASLIST(CELL)_S3=OPND1_D %THEN POP(CELL,S1,S2,S3) %C %AND %EXIT CELL==ASLIST(CELL)_LINK %REPEAT %END %CONTINUE TRIPSW(13): ! INSERT LABEL ! OPND1_XTRA HAS LABEL CELL OLDLINE=0 LCELL==ASLIST(OPND1_XTRA) JJ=LCELL_S2&X'FFFF'; ! UNFILLED JUMPS LIST %WHILE JJ#0 %CYCLE; ! FILL FORWARD REFS POP(JJ,B1,B2,B3); ! B1<0 IF SHORT JUMP PLANTED %REPEAT %IF LCELL_S1&X'FFFF'=0 %THEN LCELL_S1=LCELL_S1!GLABEL %C %AND GLABEL=GLABEL-1 PLABEL(LCELL_S1&X'FFFF') D=OPND1_D>>24; ! ENVIRONMENT MANIPULATION FLAGS %IF D&2=0 %THEN FORGETM(14) %ELSE %START C=LCELL_S2>>16 %IF D&4=0 %THEN REDUCE ENV(C);! MERGE WITH CURRENT RESTORE(C) %FINISH LCELL_S2=0; ! NO JUMPLIST&NO ENVIRONMENT %CONTINUE TRIPSW(14): ! FOR 2ND PREAMBLE ! MAY BE UNNECESSARY %BEGIN %RECORD(TRIPF)%NAME CTRIP,JTRIP,ADDTRIP,ASSTRIP CTRIP==TRIPLES(STPTR); ! NEXT TRIP IC COMPARE JTRIP==TRIPLES(CTRIP_FLINK); ! FOLLOWED BY CONDITIONAL JUMP ADDTRIP==TRIPLES(JTRIP_FLINK); ! AND THEN ADDITION OF INC ASSTRIP==TRIPLES(ADDTRIP_FLINK);! AND ASSIGNMENT %IF XTRA&X'080002'=X'080002' %START;! INCREMENT IS 1 ! CTRIP_X1=CTRIP_X1!X'80000000';! MARK TO USE CPIB ! ASSTRIP_OPND2=ADDTRIP_OPND1 ! ADDTRIP_OPERN=NULLT %FINISH %END %CONTINUE TRIPSW(15): ! RT HEADING OPND1_D=RTNAME ! OPND1_XTRA=AXNAME OR 0 %BEGIN %INTEGER W1,PCKWORD W1=-1; PCKWORD=0; ! OPND1_XTRA=AXNAME #0 IF AN ENTRY %IF OPND1_XTRA#0 %START; ! EXTERNAL NEEDS INITIALISE %IF OPND1_D<0 %THEN %START; ! FIRST BEGIN OR MAIN ENTRY C=1; ! FLAG MAIN ENTRY %FINISH %ELSE %START; ! NOT MAIN ENTRY C=0 TCELL==ASLIST(TAGS(OPND1_D)) D=TCELL_SLINK; ! TO PARAM CHAIN %IF D>0 %THEN %START 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 %FINISH %ELSE %IF 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 TCELL==ASLIST(TAGS(OPND1_D)) 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) PIX RR(LR,CLNB,WSPR) 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 %THEN %START DUMPRX(LA,1,0,0,CURRINF_PSIZE) PPJ(0,4,YES) %FINISH %CONTINUE TRIPSW(16): ! RDAREA - INITIALISE DAIGS AREA ! OPND1_D=N FOR DIAGS AREA %CONTINUE TRIPSW(17): ! RDPTR SET DAIGS POINTER ! OPND1_D=LEVEL NOT CURRINF ALWAYS LINF==WORKA_LEVELINF(OPND1_D) 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 %C (WORKT_OPERN=BJUMP %AND 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 %IF OPND2_FLAG=LCONST %START LOAD(OPND2,ANY GR,1) DUMPSS(MVC,OPND2_XTRA+1,CLNB,D,OPND2_XB,OPND2_D) %FINISH %ELSE %START LOAD(OPND2,ANY GR,1) EVALREG=ANYGRBAR0 DUMPRXE(IC,EVALREG,0,OPND2_XB,OPND2_D) SET USE(EVALREG,X'51',LITCONST,-1000) REGS(EVALREG)_CL=-1 EXECUTESS(EVALREG,MVC,CLNB,D,OPND2_XB,OPND2_D) REGS(EVALREG)_CL=0 %FINISH OPERAND USED(OPND2) OPND1_FLAG=7; ! RESULT IS LOCAL %CONTINUE TRIPSW(22): ! CONCATENATE OPND1 WORK AREA ! OPND2 THE NEXT BIT %BEGIN %INTEGER OLENREG,ALENREG,ADDREG OPND1=TRIPLES(OPND1_D)_OPND1 %WHILE OPND1_FLAG=REFTRIP D=OPND1_D&X'FFFF'; ! WOTF AREA OFFSET FROM LNB OLENREG=ANYGRBAR0 DUMPRXE(IC,OLENREG,0,CLNB,D); ! LENGTH OF BIT IN WK AREA SET USE(OLENREG,X'51',LITCONST,-1000) REGS(OLENREG)_CL=-1 ADDREG=ANYGRBAR0 DUMPRXE(LA,ADDREG,CLNB,OLENREG,0);! PTR T0 STR END REGS(ADDREG)_CL=-1 FORGET(ADDREG) %IF OPND2_FLAG=LCONST %START; ! STRING LITERAL BEING ADDED %IF OPND2_XTRA=1 %START DUMPSI(MVI,WORKA_A(OPND2_D+1),ADDREG,D+1) %FINISH %ELSE %START LOAD(OPND2,ANY GR,1) DUMPSS(MVC,OPND2_XTRA,ADDREG,D+1,OPND2_XB,OPND2_D+1) %FINISH DUMPRX(LA,OLENREG,0,OLENREG,OPND2_XTRA) %FINISH %ELSE %START LOAD(OPND2,ANY GR,1) ALENREG=ANYGRBAR0 DUMPRXE(IC,ALENREG,0,OPND2_XB,OPND2_D);! LENGTH OF BIT TO BE ADDED SET USE(ALENREG,X'51',LITCONST,-1000) REGS(ALENREG)_CL=-1 EXECUTESS(ALENREG,MVC,ADDREG,D+1,OPND2_XB,OPND2_D+1) PIX RR(AR,OLENREG,ALENREG) REGS(ALENREG)_CL=0 %FINISH DUMPRX(STC,OLENREG,0,CLNB,D); ! STORE NEW LENGTH REGS(OLENREG)_CL=0 REGS(ADDREG)_CL=0 OPERAND USED(OPND2) %END %CONTINUE TRIPSW(39): ! GENERAL STRING ASSIGN ! OPND1 IS A STRING POINTER %BEGIN %INTEGER XREG LOAD(OPND1,ANY 2SEQ,2); ! PTR 2WORDS TO ANY CONSECUTIVE %IF OPND2_FLAG=LCONST %START %IF OPND2_XTRA=0 %START; ! NULL STRING ASSN DUMPSI(MVI,0,OPND1_XB+1,0) %FINISH %ELSE %START LOAD(OPND2,ANY GR,1) DUMPSS(MVC,OPND2_XTRA+1,OPND1_XB+1,0,OPND2_XB,OPND2_D) %IF PARM_OPT#0 %START; ! CHECK LENGTH XREG=SHORT CONST(OPND2_XTRA) PIX RX(CH,OPND1_XB,0,CTABLEREG,XREG) PPJ(12,9,NO) %FINISH %FINISH %FINISH %ELSE %START LOAD(OPND2,ANYGR BAR0,1); ! LHS TO ANY BAR 0 XREG=ANYGRBAR0 DUMPRXE(IC,XREG,0,OPND2_XB,OPND2_D) SET USE(XREG,X'51',LITCONST,-1000) 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 TCELL==ASLIST(TAGS(OPND1_D)) LOAD(OPND1,ANY GR,1); ! LHS SSTRASS(OPND1,OPND2,TCELL_ACC) %CONTINUE TRIPSW(41): ! STRING JT VIA SUBROUTINE %BEGIN %INTEGER XREG LOAD(OPND1,ANY 2SEQ,2); ! PTR 2WORDS TO ANY CONSECUTIVE LOAD(OPND2,ANYGR BAR0,1); ! LHS TO ANY BAR 0 XREG=ANYGRBAR0 DUMPRXE(IC,XREG,0,OPND2_XB,OPND2_D) SET USE(XREG,X'51',LITCONST,-1000) 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 %C OPND==OPND1 %AND ->NULLSC %IF OPND1_FLAG=LCONST %AND OPND1_XTRA=0 %THEN %C OPND==OPND2 %AND BFFLAG=1 %AND ->NULLSC D=CURRT_X1&15; ! THE "NORMAL" IBM MASK %IF 7<=D<=8 %START; ! = & # ARE EASIER C=-1 %IF OPND1_FLAG=LCONST %THEN C=OPND1_XTRA %IF OPND2_FLAG=LCONST %THEN C=OPND2_XTRA LOAD(OPND1,ANY GR,1) LOAD(OPND2,ANY GR,1) %IF C>0 %THEN %START DUMPSS(CLC,C+1,OPND1_XB,OPND1_D,OPND2_XB,OPND2_D) %FINISH %ELSE %START JJ=ANYGRBAR0 DUMPRXE(IC,JJ,0,OPND1_XB,OPND1_D) REGS(JJ)_CL=1 SET USE(JJ,X'51',LITCONST,-1000) EXECUTESS(JJ,CLC,OPND1_XB,OPND1_D,OPND2_XB,OPND2_D) REGS(JJ)_CL=0 %FINISH OPERAND USED(OPND1) OPERAND USED(OPND2) %CONTINUE %FINISH C=FINDSEQREG(GRPAIR,1) LOAD(OPND1,ANY GR,1) DUMPRX(LA,C,0,OPND1_XB,OPND1_D+1) DUMPRX(IC,C+1,0,OPND1_XB,OPND1_D) OPERAND USED(OPND1) D=FINDSEQREG(GRPAIR,1) LOAD(OPND2,ANY GR,1) DUMPRX(LA,D,0,OPND2_XB,OPND2_D+1) DUMPRX(IC,D+1,0,OPND2_XB,OPND2_D) OPERANDUSED(OPND2) PIX RR(CLCL,C,D) %FOR JJ=0,1,1 %CYCLE FREE AND FORGET(C+JJ) FREE AND FORGET(D+JJ) %REPEAT %CONTINUE NULLSC: ! TEST FOR A NULL STRING LOAD(OPND,ANY GR,1) D=FCOMP(CURRT_X1&15+16*BFFLAG) DUMPSI(CLI,0,OPND_XB,OPND_D) OPERAND USED(OPND) %IF WORKT_OPERN=FJUMP %OR WORKT_OPERN=BJUMP %START %IF WORKT_X1&X'80'#0 %THEN WORKT_X1=X'80'!(D!!X'F') %C %ELSE WORKT_X1=D %FINISH %ELSE IMPABORT %CONTINUE TRIPSW(47): ! PRE RESOLUTION 1 ! OPND1 IS 4 WORD WK AREA ! OPND2 IS STRING BEING RESLVD D=OPND1_D&X'FFFF' C=FINDSEQREG(GRSEQ,1) LOADAD(OPND2,C) PIX RR(SLR,C+1,C+1) DUMPM(STM,C,C+1,CLNB,D) FREE AND FORGET(C) FREE AND FORGET(C+1) SET USE(C+1,X'51',LITCONST,0) OPERAND USED(OPND2) %CONTINUE TRIPSW(48): ! PRE RESOLUTION 2 ! OPND1 IS 4 WORD WK AREA ! OPND2 IS POINTER TO STRING TO HOLD ! FRAGMENT OR ZERO(=DISCARD FRGMNT) RESTEMPAD=OPND1_D&X'FFFF' %IF OPND2_FLAG=SCONST %START; ! NO STRING FOR FRAGMENT PMVC(4,CLNB,RESTEMPAD+8,CODER,0) %FINISHELSESTART LOAD(OPND2,ANY GR,1) DUMPRX(STH,OPND2_XB,0,CLNB,RESTEMPAD+6) DUMPRX(ST,OPND2_XB+1,0,CLNB,RESTEMPAD+8) OPERAND USED(OPND2) %FINISH %CONTINUE TRIPSW(49): ! RESOLUTION ! OPND1 IS STRING RES EXPR ! OPND2 IS LABEL NO LOADAD(OPND1,-1) DUMPRX(ST,OPND1_XB,0,CLNB,RESTEMPAD+12) OPERAND USED(OPND1) CLAIM THIS REG(0) DUMPRX(LA,0,0,CLNB,RESTEMPAD) FREE AND FORGET(0) PPJ(0,16,YES) %IF OPND2_D=0 %THEN PPJ(7,12,NO); ! UNCONDITIONAL FAILS %CONTINUE TRIPSW(60): ! RESFN FINAL POST RES ASSIGN ! OPND2 HAS POINTER ! SINCE RESOLVED STRING MAY BE CONST ! CAN NOT USE NORMAL ASSIGN %BEGIN %INTEGER XREG,BREG,LB D=OPND1_D&X'FFFF'; ! TO 4 WORD WK AREA LOAD(OPND2,ANY 2SEQ,2); ! POINTER TO DR XREG=ANYGRBAR0 DUMPRXE(IC,XREG,0,CLNB,D+4); ! ORIGINAL LHS LENGTH REGS(XREG)_CL=1 SET USE(XREG,X'51',LITCONST,-1000) BREG=ANYGRBAR0 DUMPRXE(IC,BREG,0,CLNB,D+5); ! BYTES USED UP REGS(BREG)_CL=1 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 EXECUTESS(XREG,MVC,OPND2_XB+1,1,BREG,1) REGS(XREG)_CL=0 REGS(BREG)_CL=0 OPERAND USED(OPND2) %END %CONTINUE TRIPSW(68): ! INDEX STRING FOR CHARNO ! OPND1 32 BIT ADDRESS OF STR ! OPND2 THE INDEX LOAD(OPND2,-2,2) %UNLESS OPND2_FLAG=SCONST %AND OPND2_D=0 LOAD(OPND1,-2,2) EVALREG=OPND1_XB %IF PARM_OPT#0 %AND OPND2_FLAG#SCONST %START KK=ANYGR DUMPRXE(IC,KK,0,EVALREG,0); ! FETCH CURRENT LENGTH 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) %C %UNLESS OPND2_FLAG=SCONST OPERAND USED(OPND2) OPND1_PTYPE=X'51' ->SUSE !*********************************************************************** !* THIS NEXT SECTION DEALS WITH ROUTINE CALLS AND PARAMETER * !* PASSING. ALSO STORING AND RECOVERY OF FN & MAP RESULTS * !*********************************************************************** TRIPSW(23): ! IOCP CALL D=OPND1_D EVALREG=1 %IF REGS(1)_CL#0 %THEN EVALREG=-1 LOAD(OPND2,EVALREG,2) OPERAND USED(OPND2) CIOCP(D,OPND2_XB); ! ALWAYS CONSTANTS EVALREG=1 OPERAND LOADED(OPND1,EVALREG) ->STRES TRIPSW(24): ! PRECALL OPND1 HAS RT NAME ! TCELL==ASLIST(TAGS(OPND1_D)) CALL COMING(8) LAST PAR REG=14; ! LAST PAREMETER REG %CONTINUE TRIPSW(25): ! ROUTINE CALL (AFTER PARAMS) ! OPND1 HAS RT NAME %BEGIN %RECORD(REGF)%NAME REG TCELL==ASLIST(TAGS(OPND1_D)) C=TCELL_UIOJ>>4&15; ! ROUTINE LEVEL NO DUMPM(STM,4,LAST PAR REG,WSPR,16) FORGETM(8) %IF TCELL_UIOJ&15=14 %START; ! EXTERNAL CALL DUMPM(LM,CODER,EPREG,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) %FINISHELSE %START JJ=TCELL_SNDISP %IF JJ=0 %THEN JJ=GLABEL %AND TCELL_SNDISP=JJ %AND GLABEL=GLABEL-1 PJUMP(BALCODE,JJ,15,15) %FINISH %CYCLE C=4,1,CLNB-1 REG==REGS(C) %IF ((1<RES TRIPSW(26): ! RECOVER FN RESULT ! CALLED AFTER RETURN TO CALLER D=RESULT REG(PTYPE) %IF PTYPE=X'35' %START; ! STRING FN REGS(D)_CL=2 OPND1_FLAG=10 OPND1_XB=D OPND1_D=0 %ELSE OPERAND LOADED(OPND1,D) %IF PTYPE=X'33' %THEN OPND1_PTYPE=X'51' %FINISH %CONTINUE TRIPSW(27): ! RECOVER MAP RESULT ! CALLED AFTER RETURN TO CALLER OPERAND LOADED(OPND1,1) %CONTINUE TRIPSW(28): ! PASS PARAMETER(1)= NORMAL VALUE LCELL==ASLIST(OPND1_XTRA&X'FFFF'); ! PARAM DESCTR CELL D=LCELL_ACC; ! PARAM_ACC %IF OPND1_PTYPE&7=5 %START; ! STRINGS BY VALUE - LABORIOUS TOPND_PTYPE=X'51'; TOPND_FLAG=10 TOPND_XB=WSPR; TOPND_D=LCELL_SNDISP+64 SSTRASS(TOPND,OPND2,D) FPPTR=FPPTR+D %CONTINUE %FINISH %IF OPND1_PTYPE&7=3 %START; ! RECORD BY VALUE C=(D+3)&(-4) %IF OPND2_FLAG=SCONST %THEN D=0 %ELSE %C 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 SSVARASS(D,WSPR,LCELL_SNDISP+64,OPND2)=YES %THEN ->PARDONE %IF OPND1_PTYPE&7=2 %THEN C=-3 %ELSE C=-1 LOAD(OPND2,C,2) EVALREG=OPND2_XB ->PARCHK TRIPSW(29): ! GET 32 BIT ADDRESS LOADAD(OPND1,ANYGRBAR0) EVALREG=OPND1_XB ->SUSE TRIPSW(30): ! GET POINTER FOR %NAME %IF TYPE=5 %THEN EVALREG = ANY2SEQ %ELSE EVALREG=ANYGRBAR0 LOADPTR(OPND1,OPND2,EVALREG) EVALREG=OPND1_XB ->SUSE TRIPSW(31): ! PARAM PASSING (2) NORMAL PTRS LCELL==ASLIST(OPND1_XTRA&X'FFFF') PTYPE=OPND1_PTYPE&255; ! FOR PARAM %IF PTYPE=X'35' %THEN C=ANY2SEQ %AND D=8 %ELSE C=ANYGR %AND D=4 LOAD(OPND2,C,2) EVALREG=OPND2_XB ->PARCHK TRIPSW(32): ! PARAM PASSING(3) ARRAYS ! ALSO (4) PASS RT PARAM SAME CODE LCELL==ASLIST(OPND1_XTRA&X'FFFF') %IF CURRT_OPERN=PASS4 %THEN C=ANYGR %AND D=4 %ELSE %C %IF CURRT_OPERN=PASS5 %THEN C=ANY2SEQ %AND D=8 %ELSE %C D=16 %AND C=ANY4SEQ %IF SSVARASS(D,WSPR,LCELL_SNDISP+64,OPND2)=YES %THEN ->PARDONE LOAD(OPND2,C,2) EVALREG=OPND2_XB PARCHK: ! KEEP AUTO STACKING CORRECT C=LCELL_SNDISP+64 DSTORE(EVALREG,D,-1,C) PARDONE: FPPTR=FPPTR+D OPERAND USED(OPND2) %CONTINUE TRIPSW(69): ! PASS6 PASS WKAREA FOR STR&RECORDS ! NOT USED IN IBMIMP %CONTINUE TRIPSW(63): ! RTFP TURN RTNAME INTO FORMAL TCELL==ASLIST(TAGS(OPND1_D)) EVALREG=ANYGR %IF TCELL_PTYPE&X'400'#0 %START; ! NAM>0 PASS A FORMAL DFETCH(EVALREG,4,TCELL_UIOJ>>4&15,TCELL_SNDISP) %FINISHELSEIF TCELL_UIOJ&15=14 %START; ! EXTERNAL PASSED DUMPRXE(LA,EVALREG,0,GLAREG,TCELL_SNDISP) %FINISHELSE %START 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) DUMPRX(ST,EVALREG,0,CLNB,D+8) DUMPRX(LA,EVALREG,0,CLNB,D) %FINISH OPERAND LOADED(OPND1,EVALREG) %CONTINUE TRIPSW(66): ! TYPE GENERAL PARAMETER ! OPND1 THE ACTUAL ! OPND2 HAS PTYPE&ACC %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) %FINISH %ELSE %IF 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)) %FINISH %ELSE %START JJ=FINDSEQREG(GRSEQ,1) LOAD(OPND1,JJ+1,2); ! 32 BIT ADDRESS TYPE=OPND2_D&7; PREC=OPND2_D>>4&7 DUMPRX(LGR,JJ,0,CTABLEREG,WORD CONST(OPND2_D&X'FFFF00FF')) OPND1_PTYPE=X'61' %FINISH OPND1_FLAG=9 OPND1_XB=JJ REGS(JJ)_LINK=ADDR(OPND1) REGS(JJ+1)_LINK=ADDR(OPND1) %CONTINUE !*********************************************************************** !* SECTION TO DEAL WITH SWITCHES INCLUDING ->SW(EXP) * !*********************************************************************** TRIPSW(33): ! DECLARE SWITCH OPND2 HAS BNDS %BEGIN %INTEGER D1,RANGE,LB %INTEGERNAME SSTL TCELL==ASLIST(TAGS(OPND1_D)) SSTL==CAS(4); ! TABLE BOUND FOR SST SSTL=(SSTL+3)&(-4); ! WRD BNDRY LB=OPND2_D RANGE=OPND2_XTRA-LB+1 D1=SSTL-SWITEMSIZE*LB; ! POINTER TO ELEMENT ZERO GLACA=(GLACA+3)&(-4) PD4(2,GLACA,D1) 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) %FINISH %ELSE %START; ! 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) %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 %THEN %START DUMPRX(CD,RLREG,0,CTABLEREG,KLCONSTS(2));! =X'4880000000000000' PPJ(10,9,NO) %FINISH DUMPRX(AD,RLREG,0,CTABLEREG,KLCONSTS(2));! MAKE UNSIGNED & +VE %IF PARM_OPT#0 %THEN PPJ(4,9,NO) 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 REGS(LREG)_CL=0; ! UNCHANGED TEMP=TEMP+4; ! RESULT IN LOWER WORD %FINISH %ELSE %START; ! LONGLONG REALS LOAD(OPND1,ANYFRPAIR,2) LREG=OPND1_XB; RLREG=REGCODE(LREG) WREG=CLAIM OTHER FR PAIR(LREG) RWREG=REGCODE(WREG) DUMPRX(LD,RWREG,0,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,9,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' %END %CONTINUE TRIPSW(38): ! INTEGER TO STRING AS TOSTRING GET WSP(D,1) LOAD(OPND1,ANYGR,2) DUMPRX(STC,OPND1_XB,0,CLNB,D+1) DUMPSI(MVI,1,CLNB,D) OPERAND USED(OPND1) OPND1_FLAG=LOCALIR OPND1_PTYPE=X'35' OPND1_D=CURRINF_RBASE<<16!D %CONTINUE TRIPSW(42): ! ARRAYHEAD ASSIGNMENT OPND2_PTYPE=X'71'; ! SO LOAD LOADS HEAD NOT ELEMNT ! AND DROP THRO TO PTR ASSGN TRIPSW(43): ! POINTER ASSIGNMENT D=BYTES(OPND2_PTYPE>>4&15) %IF D=16 %THEN C=ANY4SEQ %ELSE %IF D=8 %THEN C=ANY2SEQ %ELSE C=ANYGR %IF OPND1_FLAG=DNAME %START; ! LOCAL PTR TCELL==ASLIST(TAGS(OPND1_D)) EVALREG=-1 %IF SSVARASS(D,DISPREG(TCELL_UIOJ>>4&15),TCELL_SLINK+OPND1_XTRA, OPND2)=NO %THEN %START LOAD(OPND2,C,2) EVALREG=OPND2_XB DSTORE(EVALREG,D,TCELL_UIOJ>>4&15,TCELL_SLINK+OPND1_XTRA) %FINISH %IF OPND1_XTRA=0 %THEN NOTE ASSMENT(EVALREG,1,OPND1_D,OPND2_PTYPE&X'F0'!1) %FINISH %ELSE %START 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,18) %IF OPND2_FLAG=SCONST %THEN %START BULKM(0,CURRT_X1,OPND1_XB,0,0,OPND2_D) %FINISH %ELSE %START 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 %THEN %START LOAD(OPND2,ANYGRBAR0,0) %IF OPND2_FLAG=11 %THEN %C OPND2_D=OPND2_D+OPND1_D %AND OPND1=OPND2 %AND ->STRES %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 ->STRES %FINISH %FINISH LOAD(OPND1,ANYGRBAR0,2); ! THE RECORD BASE LOAD(OPND2,ANYGR,1); ! 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));! 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) %FINISH %ELSE %START 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) 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) LOAD(OPND2,1,2) LINF==WORKA_LEVELINF(OPND1_D) %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) %FINISH %ELSE %START DUMPM(LM,4,10,CLNB,16); ! OTHERWISE FRIG DISPLAY %FINISH %FINISH REGS(0)_CL=0 REGS(1)_CL=0 PPJ(0,2,YES); ! MONITOR %CONTINUE !*********************************************************************** !* SECTION FOR GENERATING CODE FOR INLINE ASSEMBLER * !*********************************************************************** TRIPSW(50): ! UC NOOP 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) %AND %CONTINUE %IF C=X'FF02' %THEN PDROP(USINGR) %AND USINGR=12 %AND %CONTINUE %IF C=SVC %THEN PIX RR(SVC,OPND1_D>>4&15,OPND1_D&15) %AND %CONTINUE TRIPSW(52): ! UCB2 TWO REG RR &RRE ASSEMBLER C=OPND1_D>>16; D=OPND1_D&15; ! D IS REG1 %IF (TARGET=IBM %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,1) ! 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,1) C=XTRA>>16 %IF C>255 %OR C=LPSW %OR C=SSM %OR C=TS %THEN %C PIX S(C,OPND1_XB,OPND1_D) %ELSE 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,1) LOAD(OPND1,ANYGR,1) %IF C>255 %THEN PIX SSE(C,UOPND_XB,UOPND_D,OPND1_XB,OPND1_D) %C %ELSE 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 REGS(EVALREG)_CNT=CURRT_CNT %IF CURRT_FLAGS&USED LATE #0 %THEN BOOT OUT(EVALREG) %FINISH %ELSE %START ! 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,LOCAL BASE %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 %THEN %RETURN; ! 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 %START %RETURN %IF MODE=0; ! LAVE "LA" CONSTS USE=LITCONST; INF=OPND_D FIND USE(D,X'51',USE,INF) %IF D>=0 %THEN OPERAND RELOADED(OPND,D) %AND ->SW9 %IF MODE=2 %THEN %START %IF REG<0 %THEN %START REG=FIND REG(NEGREG(REG),0) REQREG==REGS(REG) %FINISH %ELSE %START %IF REQREG_USE=USE %AND REQREG_INF1=INF %THEN ->LDED %FINISH %IF INF=0 %THEN 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' %C %THEN PREC=4 %AND PTYPE=X'41' %AND OPND_PTYPE=PTYPE %IF PREC=4 %THEN KK=KK+2 STORE CONST(D,BYTES(PREC),KK) OPND_FLAG=10; OPND_XB=CTABLEREG OPND_D=D USE=6; INF=D ->OPTLOAD SCONST: ! STRING CONSTANT OPND_DIS AR PTR STORE STRING(D,STRING(ADDR(WORKA_A(OPND_D)))) OPND_FLAG=10 OPND_D=D OPND_XB=CTABLEREG ->OPTLOAD SW(3): ! 128 BIT CONSTANT IMPABORT SW(2): ! NAME (+POSSIBLE OFFSET) TCELL==ASLIST(TAGS(OPND_D)) OPND_FLAG=10 %IF X<=0 %AND TCELL_PTYPE&15<3 %THEN 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 OPND_XTRA=0 ->OPTLOAD LDED: SET USE(REG,PTYPE,USE,INF) NULLOAD: OPERAND LOADED(OPND,REG) %RETURN SW(4): ! VIA DESC AT OFFSET FROM ! A COMPUTED POINTER REFTRIP==TRIPLES(OPND_D) OPND=REFTRIP_OPND1 LOAD(OPND,ANYGRBAR0,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 %IF TYPE=5 %AND X<0 %THEN D=D+4 INF=OPND_D FIND USE(KK,X'51',ADDROF,INF) %IF KK>0 %THEN %START %IF REGS(KK)_CL#0 %THEN REGS(KK)_CNT=REGS(KK)_CNT+1 %FINISH %ELSE %START KK=ANYGRBAR0 DUMPRXE(LGR,KK,0,DISPREG(TCELL_UIOJ>>4&15),D) %IF PARM_CHK#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 %FINISH %ELSE %START LOAD(OPND,ANYGRBAR0,18) D=OPND_XB REGS(D)_CL=2 %IF REGS(D)_CL=0 REGS(D)_LINK=ADDR(OPND) 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 OPND_FLAG=10 OPND_XB=DISPREG(OPND_D>>16) CHKASS=0 %IF OPND_XB=GLAREG; ! DONT CHECK GLA 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) 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 %THEN %START %IF OPND_XB=REG %THEN REQREG_LINK=ADDR(OPND) %AND %RETURN %IF REG<0 %AND ACCEPTABLE REG(NEGREG(REG),OPND_XB)=YES %THEN %C REG=OPND_XB %AND REQREG==REGS(REG) %AND ->NULLOAD %FINISH %IF READONLY#0 %AND REG<0 %AND %C ACCEPTABLE REG(NEGREG(REG),OPND_XB)=YES %THEN %RETURN %IF REG<0 %THEN REG=FINDREG(NEGREG(REG),0) %AND REQREG==REGS(REG) %IF REG<=15 %THEN KK=LR %ELSE KK=LDR 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) OPERAND USED(OPND) ->NULLOAD %FINISH %RETURN SW(10): ! DEVELOPPED BD FORM %IF CLNB<=OPND_XB<=13 %THEN %C USE=LOCALTEMP %AND INF=BYTES(PREC)<<24!OPND_XB<<16!OPND_D OPTLOAD: %IF USE>0 %AND LEAVEINSTR=0 %THEN %START 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 RELOADED(OPND,D) %AND ->SW9 %FINISH %IF MODE=2 %THEN %START %IF TYPE=5 %THEN LOADAD(OPND,REG) %AND %RETURN 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 LOAD(OPND,ANY GR,0); ! IN STORE UNLESS RT ETC -> IN STORE %UNLESS OPND_FLAG=9 TOTHER=OPND_XB!!1 -> INSTORE %UNLESS REGS(TOTHER)_CL=0 PAIR=TOTHER&X'FE' %IF ODDEVEN+PAIR=TOTHER %THEN LOAD(OPND,TOTHER,2) REGS(PAIR)_CL=1 REGS(PAIR+1)_CL=1 FORGET(PAIR) FORGET(PAIR+1) ->FIN INSTORE: PAIR=FINDSEQREG(NEGREG(-4-TYPE),1) LOAD(OPND,PAIR+ODDEVEN,2) FIN: OPND_XB=PAIR; ! ALWAYS LH MEMBER %END %ROUTINE LOADAD(%RECORD(RD) %NAME OPND,%INTEGER REG) !*********************************************************************** !* MUCH AS LOAD BUT PRODUCES THE 32 BIT ADDRESS OF OPERAND * !* IMPABORT ON NON RELEVANT ALTERNATIVES OF OPND * !************************************************************************ %RECORD(TRIPF)%NAME REFTRIP %RECORD(TAGF) %NAME TCELL %INTEGER B,D,TYPE,X,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 (D=REG %OR (REG<0 %AND ACCEPTABLE REG(NEGREG(REG),D)=YES)) %C %THEN REG=D %AND ->LDED DFETCHAD(REG,TCELL_UIOJ>>4&15,TCELL_SLINK+X) LDED: OPND_PTYPE=X'51'; ! 32 BIT ADDRESS IS INTEGER OPERAND LOADED(OPND,REG) 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 %IF (TYPE=0 %OR TYPE=5) %AND X<0 %THEN D=D+4 DFETCH(REG,4,B,D) %IF REGS(REG)_CL=0 %THEN REGS(REG)_CL=2 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 %C 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 ->INC SW(7): ! LOCAL-IR IN BASE&OFFSET FORM B=OPND_D>>16 D=OPND_D&X'FFFF' OPND_XTRA=0 DFETCHAD(REG,B,D); ->LDED SW(8): ! A TRIPLE IMPABORT %UNLESS TYPE=5; ! ONLY STRING INTERMEDIATES HAVE ADDRESS REFTRIP==TRIPLES(OPND_D) OPND=REFTRIP_OPND1 LOADAD(OPND,REG) %RETURN SW(10):SW10: ! DEVELOPPED BD FORM 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) %AND %RETURN X=OPND_XTRA %IF REG<0 %THEN REG=FINDREG(NEGREG(REG),1) WREG=REG+1 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) 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 %THEN %START;! 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) %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 SSVARASS(%INTEGER SIZE,BASE,DISP,%RECORD(RD)%NAME RHOPND) !*********************************************************************** !* ATTEMPTS TO ASSIGN BY MVC(ETC) WHERE THIS IS ADVANTAGEOUS * !* SET RESULT=YES IF ASSIGNMENT MADE * !*********************************************************************** %INTEGER I,TYPE,PREC %RESULT=NO %IF CURRT_CNT>0; ! IF REUSED GO VIA REGISTERS %RESULT=NO %IF RHOPND_FLAG=INAREG; ! ALREADY LOADED %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(MVI,RHOPND_D,BASE,DISP) %RESULT=YES %FINISH %RESULT=NO %IF SIZE<=4 %AND 0<=RHOPND_D<=4095;! LA QUICKER IN THESE CASES %FINISH %RESULT=NO %UNLESS SIZE=BYTES(PREC) %IF TYPE=2 %START %IF PREC=7 %THEN I=ANYFRPAIR %ELSE I=ANY FR %FINISH %ELSE %START %IF PREC=6 %THEN I=ANYGRPAIR %ELSE I=ANYGR %FINISH LOAD (RHOPND,I,1) %RESULT=NO %UNLESS RHOPND_FLAG=10 %AND RHOPND_XB<=15 %AND %C RHOPND_D<=4095 PMVC(SIZE,BASE,DISP,RHOPND_XB,RHOPND_D) %RESULT=YES %END %ROUTINE SSTRASS(%RECORD(RD)%NAME LHOPND,RHOPND,%INTEGER ACC) !*********************************************************************** !* DOES SIMPLE STRING ASSIGNMENTS WHEN ACC OF LHS IS KNOWN * !*********************************************************************** %INTEGER C,D D=RHOPND_XTRA; ! RHS LENGTH IF A CONST %IF RHOPND_FLAG=LCONST %AND D15 %IF ACC<=16 %THEN %START;! AVOID EXECUTE MOVE THE LOT DUMPSS(MVC,ACC,LHOPND_XB,LHOPND_D,RHOPND_XB,RHOPND_D) %FINISH %ELSE %START C=ANYGRBAR0 DUMPRXE(IC,C,0,RHOPND_XB,RHOPND_D);! PICK UP LENGTH SET USE(C,X'51',LITCONST,-1000) REGS(C)_CL=-1 EXECUTESS(C,MVC,LHOPND_XB,LHOPND_D,RHOPND_XB,RHOPND_D) REGS(C)_CL=0 %FINISH %IF PARM_OPT#0 %AND ACC<256 %START;! FORCE CAPACITY CHK DUMPSI(CLI,ACC-1,LHOPND_XB,LHOPND_D) PPJ(2,9,NO) %FINISH %FINISH OPERAND USED(LHOPND) OPERAND USED(RHOPND) %END %ROUTINE CHOP OPERAND(%RECORD(RD)%NAME OPND,%INTEGER NEWPT,XOFFSET) !*********************************************************************** !* CHANGES RECORD OPERAND TO REFER TO A SMALLER BIT AT XOFFSET FROM * !* THE ORIGINAL START. USED TO LOAD ONE WORD OF STRING&ARRAY HEADERS* !*********************************************************************** OPND_PTYPE=OPND_PTYPE&X'FF00'!NEWPT %IF OPND_FLAG=9 %THEN IMPABORT %IF XOFFSET<=0 %THEN %RETURN %IF OPND_FLAG=DNAME %OR OPND_FLAG=INDIRECT %OR OPND_FLAG=INDNAME %THEN %C OPND_XTRA=OPND_XTRA&X'FFFF'+XOFFSET %IF OPND_FLAG=LOCALIR %OR OPND_FLAG=DEVELOPPED %THEN %C OPND_D=OPND_D+XOFFSET %END %INTEGERFN SET DVREG(%INTEGER WHICH,ANAME,%RECORD(RD)%NAME DOPND) !*********************************************************************** !* SELECT(USUALLY) AND SET UP A GENERAL REGISTER AS A BASE REGISTER * !* FOR A DOPEVECTOR IN ARRAY WHOSE HEAD B&D GIVEN * !*********************************************************************** %INTEGER I %IF WHICH<0 %START; ! ANY REG I=-1 %IF ANAME>0 %THEN FIND USE(I,X'51',DVBASE,ANAME) %IF I>0 %THEN OPERAND RELOADED(DOPND,I) %AND %RESULT=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 LOAD(OPND1,ANYGR BAR0,2) IREG=OPND1_XB %IF DVPOS>0 %START; ! DV IN CONST AREA DVD=DVD+DVPOS %IF PARM_ARR#0 %THEN BCHECK(IREG,CTABLEREG,4*DVD) DACC=CTABLE(DVD+2) SCALE(IREG,DACC) %FINISH %ELSE %START ! 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 %THEN %START DVREG=SET DVREG(-2,DVNAME,OPND2) BCHECK(IREG,DVREG,4*DVD) %FINISH %IF DACC>0 %AND C=1 %THEN %START SCALE(IREG,DACC) %FINISH %ELSE %IF DVREG<0 %AND ((DACC<0 %AND C=1=MAXD) %OR C=2=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) %FINISH %ELSE %START %IF DVREG<0 %THEN DVREG=SET DVREG(-2,DVNAME,OPND2) DUMPRX(MH,IREG,0,DVREG,4*DVD+10) %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 %THEN %RETURN %IF DACC=2 %THEN PIX RR(AR,IREG,IREG) %AND %RETURN 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) %C %ELSE DUMPRX(MH,IREG,0,CTABLEREG,SHORT CONST(DACC)) %END %ROUTINE BCHECK(%INTEGER IREG,DVREG,OFFSET) !*********************************************************************** !* PLANTS AN IN LINE BOUND CHECK * !*********************************************************************** DUMPRX(ICP,IREG,0,DVREG,OFFSET) PPJ(4,13,NO) DUMPRX(ICP,IREG,0,DVREG,OFFSET+4) PPJ(2,13,NO) %END %END %ROUTINE LNEGATE(%INTEGER REG) !*********************************************************************** !* NEGATES THE LONG INTEGER IN REGS REG®+1 BY SUBTRACTING * !* IT FROM ZERO WITH SOFTWARE CARRY * !*********************************************************************** %INTEGER 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 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 %THEN %START 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 %THEN %START 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) %FINISH %ELSE %START %IF PRECP=5 %THEN OPCODE=MER %AND WMASK=FR0 %AND LVAL=-3 %IF PRECP=6 %THEN OPCODE=MDR %AND WMASK=FR0 %AND LVAL=-3 %IF PRECP=7 %THEN OPCODE=MXR %AND WMASK=FRPAIR %AND LVAL=-6 ! ! NOW REGISTERS CAN BE OBTAINED FOR THE IN-LINE SUBROUTINE ! WORK HOLDS INITIALLY 1 PRIOR TO MULTIPLICATION ! INTREG HOLDS THE EXPONENT AS CALCULATED ! COUNT HOLDS A +VE VERSION OF INTREG FOR COUNTING THE MULTIPLIES ! RREG HOLD THE OPERAND. ! WORK=FINDREG(WMASK,1) LOAD(OPND1,LVAL,2); ! OPERAND TO ANY SUITABLE LOAD(OPND2,ANY GR,2); ! EXPONENT TO ANY GENERAL REG RREG=OPND1_XB INTREG=OPND2_XB ! ! GET '1' INTO WORK IN APPROPIATE FORM ! DUMPRX(LDCODE(8+PRECP),REGCODE(WORK),0,CTABLEREG,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(GR0,1) PIX RR(LPR,COUNT,INTREG) SET LOCAL BASE 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 %THEN %START PIX RR(DDR-MDR+OPCODE,REGCODE(RREG),REGCODE(WORK)) PIX RR(LDR-MDR+OPCODE,REGCODE(WORK),REGCODE(RREG)) %FINISH %ELSE %START 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) FREE AND FORGET(COUNT) %END %ROUTINE REALEXP !*********************************************************************** !* CALLS A PERM ROUTINE TO PERFORM REAL**REAL * !*********************************************************************** IMPABORT %END %ROUTINE CONST EXP(%INTEGER PTYPE,VALUE) !*********************************************************************** !* EXPONENTIATION TO A KNOWN POWER * !* VALUE = 2 UPWARDS. VALUE=1 HAS BEEN OPTIMISED OUT * !*********************************************************************** %INTEGER I,MULTS,MULT,DEST,REG,J,PREC,SIZE DEST=(FPPTR+7)&(-8) MULTS=0; I=VALUE %IF PTYPE&7=1 %START LOADPAIR(1,1,OPND1) EVALREG=OPND1_XB+1 %WHILE I>1 %CYCLE %IF I&1#0 %START DUMPRX(ST,EVALREG,0,WSPR,DEST) DEST=DEST+4 MULTS=MULTS+1 %FINISH PIX RR(MR,EVALREG-1,EVALREG) %IF PARM_OPT#0 %THEN PIX RS(SLDA,EVALREG-1,0,0,32) %C %AND PIX RR(LR,EVALREG,EVALREG-1) I=I>>1 %REPEAT %WHILE MULTS>0 %CYCLE MULT=MULTS-1 DEST=DEST-4 DUMPRX(M,EVALREG-1,0,WSPR,DEST) %IF PARM_OPT#0 %THEN PIX RS(SLDA,EVALREG-1,0,0,32) %C %AND 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 %ELSE %C %IF PREC=6 %THEN MULT=MDR %ELSE MULT=MER LOAD(OPND1,J,2) EVALREG=OPND1_XB %WHILE I>1 %CYCLE %IF I&1#0 %START DSTORE(EVALREG,SIZE,-1,DEST) DEST=DEST+SIZE MULTS=MULTS+1 %FINISH PIX RR(MULT,REGCODE(EVALREG),REGCODE(EVALREG)) I=I>>1 %REPEAT %IF MULTS=0 %THEN %RETURN; ! **2,**4 ETC %IF PREC=7 %START REG=CLAIM OTHERFRPAIR(EVALREG) FREE AND FORGET(REG) FREE AND FORGET(REG+1) %FINISH %WHILE MULTS>0 %CYCLE DEST=DEST-SIZE %IF PREC<=6 %THEN %START DUMPRX(MULT+X'40',REGCODE(EVALREG),0,WSPR,DEST) %FINISH %ELSE %START DFETCH(REG,16,-1,DEST) 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,STEP,BOOTMASK %RECORD(REGF)%NAME REG %IF MASK&X'0F000000'#0 %THEN %RESULT=FINDSEQREG(MASK,CLVAL) L=MASK>>16&255 U=MASK&255 %IF L<=U %THEN STEP=1 %ELSE STEP=-1 %FOR I=L,STEP,U %CYCLE REG==REGS(I) ->FOUND %IF REG_CL=0 %AND REG_USE=0 %REPEAT ! ! IN NEXT CYCLE LOOK FOR TEMPORAY THAT WILL NOT BE USED FOR THE ! LARGEST FUTURE TIME MEASURED BY NO OF TRIPLES ! NB NOT 100% PERFECT AS SHUFFLES CAN OCCUR IN OPTIMISING) ! BOOTMASK=1<<3; ! BOOT PARAMETERS FIRST AGN: LASTUSED=-1 LASTREG=-1 %FOR I=L,STEP,U %CYCLE REG==REGS(I) ->FOUND %IF REG_CL=0 %IF REG_AT#WTRIPNO %START; ! NOT USED IN THIS OPERATION USED=TRIPLES(REG_AT)_PUSE %IF USED >LASTUSED %AND 1<=0 %THEN %START 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 REG_CL=CLVAL %AND REG_CNT=1 %AND FORGET(I) %RESULT=I %END %INTEGERFN FINDSEQREG(%INTEGER MASK,CLVAL) !*********************************************************************** !* FINDS A FREE REGISTER PAIR FROM RANGE DEFINED BY MASK * !* PAIRS ARE EVEN-ODD UNLESS TOP BIT OF MASK SET * !*********************************************************************** %INTEGER I,J,L,U,USED,LASTUSED,LASTREG,STEP,MISS,NREGS %RECORD(REGF)%NAME REG L=MASK>>16&255 U=MASK&255 NREGS=MASK>>24&7 %IF L<=U %THEN STEP=1 %ELSE STEP=-1 %IF MASK>0 %THEN STEP=2*STEP %FOR I=L,STEP,U %CYCLE MISS=0 %FOR J=0,1,NREGS %CYCLE REG==REGS(I+J) MISS=1 %UNLESS REG_CL=0 %AND REG_USE=0 %REPEAT ->FOUND %IF MISS=0 %REPEAT I=CHECKSEQREG(MASK); ! USE MORE ELABORATE CODE IN CHECK %IF I>=0 %THEN ->FOUND IMPABORT FOUND: ! REG HAS BEEN FOUND %IF CLVAL#0 %THEN %START %FOR J=0,1,NREGS %CYCLE REG==REGS(I+J) REG_CL=CLVAL REG_CNT=1 FORGET(I+J) %REPEAT %FINISH REGS(I+J)_AT=WTRIPNO %FOR J=0,1,NREGS %RESULT=I %END %INTEGERFN CHECKSEQREG(%INTEGER MASK) !*********************************************************************** !* 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,STEP,MISS,NREGS,BOOTMASK %RECORD(REGF)%NAME REG L=MASK>>16&255 U=MASK&255 NREGS=MASK>>24&7 %IF L<=U %THEN STEP=1 %ELSE STEP=-1 %IF MASK>0 %THEN STEP=2*STEP %FOR I=L,STEP,U %CYCLE MISS=0 %FOR J=0,1,NREGS %CYCLE REG==REGS(I+J) MISS=1 %UNLESS REG_CL=0 %AND REG_USE=0 %REPEAT ->FOUND %IF MISS=0 %REPEAT ! ! IN NEXT CYCLE LOOK FOR TEMPORAY THAT WILL NOT BE USED FOR THE ! LARGEST FUTURE TIME MEASURED BY NO OF TRIPLES ! NB NOT 100% PERFECT AS SHUFFLES CAN OCCUR IN OPTIMISING) ! BOOTMASK=1<<3; ! FIRST BOOT PARAMETERS AGN: LASTUSED=-1 LASTREG=-1 %FOR I=L,STEP,U %CYCLE MISS=0 %FOR J=0,1,NREGS %CYCLE REG==REGS(I+J) MISS=1 %AND %EXIT %IF REG_CL#0 %REPEAT ->FOUND %IF MISS=0 %IF REG_AT#WTRIPNO %START; ! NOT USED IN THIS OPERATION USED=TRIPLES(REG_AT)_PUSE %IF USED >LASTUSED %AND 1<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 %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,STEP,I L=MASK>>16&255 U=MASK&255 %IF U>=L %THEN STEP=1 %ELSE STEP=-1 %IF MASK>0 %AND MASK&X'0F000000'#0 %THEN STEP=2*STEP %FOR I=L,STEP,U %CYCLE %RESULT=YES %IF I=REG %REPEAT %RESULT=NO %END %ROUTINE FORGETM(%INTEGER UPPER) !*********************************************************************** !* FORGETS A BLOCK OF REGISTERS DEFINED BY UPPER AND THE * !* GLOBAL ARRAY GRMAP * !* UPPER= 3 FOR GRS 0-3 * !* UPPER= 4 FOR GRS 0-3 AND 15 * !* UPPER= 8 FOR GRS 0-3 AND 15 PLUS ALL FRS * !* UPPER=14 FOR GRS 0-9,15 AND ALL FRS * !*********************************************************************** %INTEGER I,REG %CYCLE I=0,1,UPPER REG=GRMAP(I) %IF REGS(REG)_CL=0 %THEN FORGET(REG) %REPEAT %END %ROUTINE SAVE IRS(%INTEGER UPPER) !*********************************************************************** !* INSPECTS THE REGISTERS DEFINED BY UPPER AND THE GLOBAL * !* ARRAY 'GRMAP'. ANY INTERMEDIATE RESULTS IN THESE REGISTERS * !* ARE TRANSFERED TO CORE BY 'BOOT OUT' * !* UPPER=4 FOR GRS 1-3 & 15 (CORRUPTED BY PERM) * !* UPPER=8 FOR GRS 1-3 & 15 +FRS 0-6 (CORRUPTED BY FN CALL) * !*********************************************************************** %INTEGER I,REG %CYCLE I=0,1,UPPER REG=GRMAP(I) BOOT OUT(REG) %IF REGS(REG)_CL>=1 %REPEAT %END %ROUTINE CLAIM THIS REG(%INTEGER REG) !*********************************************************************** !* CLAIMS THE REGISTER AND PRESERVES CONTENTS IF * !* THE REGISTER IS ALREADY CLAIMED * !*********************************************************************** BOOT OUT(REG) %IF REGS(REG)_CL>0 %IF REGS(REG)_CL#0 %THEN IMPABORT REGS(REG)_CL=1 %END %ROUTINE CLAIM ALL4FRS %INTEGER I CLAIM THIS REG(I) %FOR I=16,1,19 %END %INTEGERFN CLAIM OTHER FRPAIR(%INTEGER PAIR0) !*********************************************************************** !* FOR EXTENDED OPS THAT NEED BOTH FR PAIRS. SPECIAL ROUTINES IN * !* CASE SPECIAL MEASURES ARE NEEDED * !*********************************************************************** %INTEGER PAIR1 IMPABORT %UNLESS PAIR0=16 %OR PAIR0=18 PAIR1=PAIR0!!2 CLAIM THIS REG(PAIR1) CLAIM THIS REG(PAIR1+1) %RESULT=PAIR1 %END %ROUTINE FORGET(%INTEGER REGNO) !*********************************************************************** !* CLEARS THE USE OF ANY REGISTER. ALL CHANNELED THRO ONE RT * !* IN CASE NEED ANY DROP CALL TO PUT ETC * !*********************************************************************** %RECORD(REGF)%NAME REG REG==REGS(REGNO) %IF REG_USE=BASEREG %THEN PDROP(REGNO) REG_USE=0 REG_INF1=0 %END %ROUTINE FREE AND FORGET(%INTEGER REGNO) !*********************************************************************** !* AS FORGET BUT CLEARS CCLAIM FLAG ALSO * !*********************************************************************** REGS(REGNO)_CL=0 FORGET(REGNO) %END %ROUTINE SET USE(%INTEGER REG,PTYPE,U,I) !*********************************************************************** !* NOTE THAT THE USE OF REGISTER 'R' IS NOW 'U' & 'I' * !* WORKS FOR MULTI REGISTER ITEMS * !*********************************************************************** %INTEGER XREGS %RECORD(REGF)%NAME UREG XREGS=REGWORDS(PTYPE&127)>>4-1 %FOR REG=REG,1,REG+XREGS %CYCLE UREG==REGS(REG) %IF UREG_CL>=0 %THEN %START %IF UREG_USE>0 %THEN FORGET(REG) UREG_USE=U UREG_INF1=I UREG_AT=WTRIPNO %FINISH 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; %IF PTYPE&7=2 %THEN L=12 %AND U=15 %ELSE L=1 %AND U=11 NREGS=REGWORDS(PTYPE&127)>>4; ! NO OF GRS(FRS) REG=-1 %AND %RETURN %IF 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) %C %AND (NREGS=1 %OR(REGS(I+1)_PRIMUSE=USE!128 %AND %C (REGS(I+1)_INF1=INF %OR INF=-1))) %THEN ->HIT %IF TREG_SECUSE=USE %AND(TREG_INF2=INF %OR INF=-1) %C %AND (NREGS=1 %OR(REGS(I+1)_SECUSE=USE!128 %AND %C (REGS(I+1)_INF2=INF %OR INF=-1))) %THEN ->HIT %REPEAT REG=-1 %RETURN HIT: TREG_AT=WTRIPNO REG=I %END %ROUTINE BOOT OUT(%INTEGER REG) !*********************************************************************** !* REMOVE TEMPORARIES FROM REG INTO LOCAL OR ONTO STACK * !* IT IS VITAL THAT ACC IS STACKED FIRST BEFORE B OR DR * !* OTHERWISE MIXUPS OCCUR WHEN PASSING MULTI-DIMENSION ARRAY * !* ELEMENTS WITH FNS AS SUBSCRIPTS AS VALUE SCALARS * !*********************************************************************** %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 ->BOOT(BOOTREG_CL) BOOT(1): ! INTERMEDIATE RESULT %IF R_D=0 %THEN %START GET WSP(D,WSIZE) R_D=CURRINF_RBASE<<16!D %FINISH %ELSE D=R_D&X'FFFF' DSTORE(REG,BSIZE,R_D>>16,D) D=BSIZE<<24!DISPREG(R_D>>16)<<16!R_D&X'FFFF' 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 %C BOOTREG_CNT<=1 %START 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 BOOTREG_CL=0 %THEN %RETURN %FINISH IMPABORT BOOT(3): ! PARAMETER AWAITONG STACKING DSTORE(REG,BSIZE,-1,64+4*REG) FREE: %FOR J=0,1,NREGS-1 %CYCLE BOOTREG==REGS(REG+J) BOOTREG_CL=0 BOOTREG_CNT=0 BOOTREG_LINK=0 %REPEAT %END %ROUTINE CALL COMING (%INTEGER UPPER) !*********************************************************************** !* CALLED TO SAVE RESULTS AND PARAMETERS IN CASE CALL WITHIN CALL * !*********************************************************************** %INTEGER J SAVE IRS(UPPER); ! FRS NOT ALWAYS SAVED FOR PERM J=(FPPTR+7)&(-8) PUSH(FPHEAD,FPPTR,LAST PAR REG,J) %IF FPPTR>64 %THEN DUMPRX(LA,WSPR,0,WSPR,J) FPPTR=64 %END %ROUTINE CALL MADE !*********************************************************************** !* CALL HAS BEEN MADE. EXPOSE ANY PARAMETERS * !*********************************************************************** %INTEGER J POP(FPHEAD,FPPTR,LAST PAR REG,J) %IF CA>4096-MARGIN %THEN %C PUSING(LINKREG) %AND SET USE(LINKREG,X'51',BASEREG,CA) %IF FPPTR>64 %THEN %START 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 %ROUTINE GET IN ACC(%INTEGERNAME SREG,%INTEGER SIZE,%RECORD(RD)%NAME OPND) !*********************************************************************** !* SIMILAR TO DFETCH BUT HAS MORE GENERAL OPND PARAMETER * !*********************************************************************** %INTEGER COUNT,TY,PR,OPCODE,I TY=0 %IF SREG>=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) %ELSE %START DUMPRX(LGR,SREG+I,OPND_XB>>4,OPND_XB&15,OPND_D+I) %C %FOR I=0,1,COUNT %FINISH %FINISH %ELSE %START DUMPRXE(OPCODE,SREG,OPND_XB>>4,OPND_XB&15,OPND_D) %IF SIZE=16 %THEN %C 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) %ELSE %START DUMPRX(ST,REG+I,OPND_XB>>4,OPND_XB&15,OPND_D+4*I) %C %FOR I=0,1,COUNT %FINISH %FINISH %ELSE %START DUMPRX(OPCODE,REGCODE(REG),OPND_XB>>4,OPND_XB&15,OPND_D) %IF SIZE=16 %THEN %C DUMPRX(OPCODE,REGCODE(REG+1),OPND_XB>>4,OPND_XB&15,OPND_D+8) %FINISH %END %ROUTINE DSTORE(%INTEGER REG,SIZE,LEVEL,DISP) !*********************************************************************** !* STORE SIZE(BYTES) FROM DISP(BYTES) IN DISPLAY 'LEVEL' * !*********************************************************************** %RECORD(RD) DOPND DOPND_FLAG=10 DOPND_XB=DISPREG(LEVEL) DOPND_D=DISP GET OUT OF ACC(REG,SIZE,DOPND) %END %ROUTINE DFETCHAD(%INTEGERNAME REG,%INTEGER LEVEL,DISP) !*********************************************************************** !* FETCH ADDRESS OF DISP(BYTES) IN DISPLAY 'LEVEL' * !*********************************************************************** 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 %C ACCEPTABLE REG(NEGREG(REG),TREG)=YES %THEN REG=TREG %AND %RETURN %FINISH GET IN ACC(REG,SIZE,DOPND) %END %ROUTINE TESTRASS(%INTEGER REG,PTYPE) !******************************* !* TEST THAT A REGISTER HAS NOT BEEN LOADED WITH THE UNASSIGNED MARKER !*********************************************************************** %INTEGER OP,TY PTYPE=PTYPE&255 TY=PTYPE&7 %RETURN %IF TY>2 %OR PTYPE=X'31' OP=LDCODE(8*(TY-1)+PTYPE>>4)+1 PIX RX(OP,REGCODE(REG),0,CTABLEREG,UNASSOFFSET) 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) %AND %RETURN TY=PTYPE&7; PR=PTYPE>>4 %RETURN %UNLESS OPND_FLAG=10; ! THE LA FORM CAN NOT PRODUCE UNASSPAT %IF OPND_XB<=15 %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) PPJ(8,5,NO) %RETURN %FINISH %IF TY=2 %THEN REG=ANYFR %ELSE REG=ANYGR OP=LDCODE(8*(TY-1)+PR) DUMPRXE(OP,REG,0,CTABLEREG,UNASSOFFSET) DUMPRX(OP+1,REG,OPND_XB>>4,OPND_XB&15,OPND_D) FORGET(REG) 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 %IF AMOUNT=0 %THEN %RETURN %IF LAOK=YES %AND 0LIMIT CURRT==TRIPLES(LINK) LINK=CURRT_FLINK %RESULT=YES %IF CURRT_OPERN=TLAB %AND CURRT_OPND1_D&X'FFFF'=LAB DIST=DIST+TRIPDATA(CURRT_OPERN)>>8&255 %REPEAT %END %ROUTINE CEND !************************************************************************ !* NOW CLAIM THE STACK FRAME BY SPECIFYING RT DICT ENTRY * !************************************************************************ %INTEGER JJ,D,TOP PPROCEND JJ=CURRINF_SNMAX %IF JJ<4095 %THEN %START %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) %FINISH %ELSE %START D=SHORT CONST(JJ) %IF PARM_CHK=0 %THEN TOP=AH<<8!WSPR<<4 %ELSE TOP=LH<<8 PSETOPD(CURRINF_SET,0,TOP) %IF D<4095 %THEN %START PSETOPD(CURRINF_SET,1,CTABLEREG<<12!D) %FINISH %ELSE %START D=JJ>>12<<2+4; ! OFFSET OF NEXT HIGHER 4K MULTIPLE PSETOPD(CURRINF_SET,1,CODER<<12!(D+2));! USE BTM HALF %FINISH %FINISH REGS(CLNB)_CL=0 %END %ROUTINE CIOCP(%INTEGER N,REG) !*********************************************************************** !* COMPILES A CALL ON IOCP ENTRY POINT NO 'N' * !* 2ND (32 BIT) PARAMETER IS ALREAD IN REG * !*********************************************************************** %CONSTINTEGER NEED RES=X'40016' %INTEGER MREG MREG=ANYGR REGS(REG)_CL=-1 CALL COMING(8) DSTORE(REG,4,-1,68) REGS(REG)_CL=0 DUMPRXE(LA,MREG,0,0,N) DSTORE(MREG,4,-1,64) FORGETM(8) DUMPM(STM,4,14,WSPR,16) 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 %THEN %START CODE=BALCODE MASK=LINKREG SAVEIRS(8) %IF SAVE=YES %FINISH VAL=WORKA_PLABS(N) %IF VAL<=0 %THEN VAL=GLABEL %AND WORKA_PLABS(N)=VAL %C %AND WORKA_PLINK(N)=VAL %AND GLABEL=VAL-1 %IF N<=15 %THEN WREG=0 %ELSE %IF CODE=BALCODE %THEN WREG=LINKREG %C %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,OPND_D) 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) %IF REG_CL=IRESULT %OR REG_CL=TEMPBASE %THEN %START REG_CNT=REG_CNT-1 %IF REG_CNT<=0 %THEN REG_CL=0 %FINISH %REPEAT %FINISH %IF 10<=OPND_FLAG<=11 %START X=OPND_XB>>4 B=OPND_XB&15 REG==REGS(X) %IF X>0 %START REG_CNT=REG_CNT-1 %IF REG_CL>=0 %IF REG_CNT<=0 %AND (REG_CL=IRESULT %OR REG_CL=TEMPBASE) %C %THEN REG_CL=0 %FINISH REG==REGS(B) %IF B>0 %START REG_CNT=REG_CNT-1 %IF REG_CL>=0 %IF REG_CNT<=0 %AND (REG_CL=IRESULT %OR REG_CL=TEMPBASE) %C %THEN REG_CL=0 %FINISH %FINISH %END %ROUTINE OPERAND LOADED(%RECORD(RD)%NAME OPND,%INTEGER REG) !*********************************************************************** !* UPDATES OPERAND AND REG DESCRIPTORS AFTER A LOAD * !* NORMALLY IN LINE CODE BUT 360 REGS SUCH A MESS * !*********************************************************************** %INTEGER TYPE,PREC,X,J %RECORD(REGF)%NAME LREG TYPE=OPND_PTYPE&7 PREC=OPND_PTYPE>>4&15 %IF TYPE=1 %AND PREC<5 %THEN %START %IF PREC=3 %AND REGS(REG)_USE=0 %AND 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) IMPABORT %IF LREG_CL=1 %AND LREG_CNT>1 LREG_LINK=ADDR(OPND) LREG_CL=1 LREG_CNT=1 LREG_AT=WTRIPNO %REPEAT %END %ROUTINE OPERAND RELOADED(%RECORD(RD)%NAME OPND,%INTEGER REG) !*********************************************************************** !* OPERAND HAS BEEN FOUND IN A REG. IT MAY JUST BE AROUND(OFTEN) * !* OR MAY BE BEING HELD THERE FOR A DIFFERENT OPERATION(RARE) * !* UPDATES OPERAND AND REG DESCRIPTORS AFTER THE DISCOVERY * !* NORMALLY IN LINE CODE BUT 360 REGS SUCH A MESS * !*********************************************************************** %INTEGER TYPE,PREC,X,J %RECORD(REGF)%NAME LREG TYPE=OPND_PTYPE&7 PREC=OPND_PTYPE>>4&15 %IF TYPE=1 %AND PREC<5 %THEN %START 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 LREG_CL=0 %THEN LREG_LINK=ADDR(OPND) %AND %C LREG_CNT=0 %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 %THEN %RESULT=16{FR0} %ELSE %C %IF PTYPE=X'61' %THEN %RESULT=0 %ELSE %RESULT=1 %END %ROUTINE PUT(%INTEGER EVALREG, CODE,OFFSET,FINISHED,%RECORD(RD)%NAME OPND) !*********************************************************************** !* THIS ROUTINE PLANTS CODE TO PERFORM THE BASIC * !* OPERATION DEFINED BY OPND & OPCODE * !* OFFSET AND FINISHED NEED FOR MULTILENGTH INTEGER OPERATIONS * !* SINCE EITHER PART MAY NEED TO COME FIRST * !*********************************************************************** %RECORD(REGF)%NAME REG %IF OPND_FLAG=9 %START; ! SECOND OPERAND IN REG %IF CODE&X'FF00'#0 %THEN %C PIX RRE(CODE,REGCODE(EVALREG)+OFFSET,REGCODE(OPND_XB)+OFFSET) %ELSE %START %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 %FINISH %ELSE %START IMPABORT %UNLESS OPND_FLAG=10 %AND CODE>=X'40' DUMPRX(CODE,REGCODE(EVALREG)+OFFSET,OPND_XB>>4,OPND_XB&15,OPND_D+4*OFFSET) %FINISH REG==REGS(EVALREG) FORGET(EVALREG) %UNLESS (CODE4095 AND MANIPULATES * !* INDEX ACCORDINGLY. FREQUENTLY INDEX=0 (NO INDEXING) WHEN THE * !* SOLUTION IS TRIVIAL. MODE=0 IF INDEX MUST BE COPIED BEFORE * !* BEING ADJUSTED. 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 %THEN %START FIND USE(INDEX,X'51',FOURKMULT,PN);! LOOK FOR 4K MULTIPLE ->REND %IF INDEX>0 SET USE(J,X'51', FOURKMULT, PN) INDEX=J; K=LGR %FINISH %ELSE %START %IF REGS(INDEX)_CL<0 %OR REGS(INDEX)_CNT>1 %THEN MODE=0 %IF MODE=0 %OR INDEX=0 %THEN %START %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 %C %THEN REG=K %ELSE %START K=1 %WHILE REG<0 %AND K<=15 %CYCLE UREG==REGS(K) %IF UREG_CL=0 %AND %C ((UREG_PRIMUSE=LITCONST %AND UREG_INF1<=255) %C %OR (UREG_SECUSE=LITCONST %AND UREG_INF2<=255)) %C %THEN REG=K K=K+1 %REPEAT %FINISH %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_INF1<=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)); !=F'255' %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) %AND %RETURN %IF REG=X %AND LEVEL=0 %THEN %RETURN %IF REG=LEVEL %AND X=0 %THEN %RETURN %IF LEVEL=0 %OR X=0 %THEN PIX RR(LR,REG,LEVEL+X) %AND %RETURN %FINISH %IF REG#0 %AND ((REG=LEVEL %AND X=0) %OR (REG=X %AND LEVEL=0)) %THEN %C INC REG(REG,DIS,YES) %AND %RETURN; ! 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(0,B1,D1) %AND REGS(B1)_CL=2 %IF D2>4095 %THEN ADJUST INDEX(0,B2,D2) %AND REGS(B2)_CL=2 %IF OP=MVC %THEN PMVC(L,B1,D1,B2,D2) %ELSE %C 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(0,B1,D1) %AND REGS(B1)_CL=2 %IF D2>4095 %THEN ADJUST INDEX(0,B2,D2) %AND REGS(B2)_CL=2 I=OPCODE<<24!B1<<12!D1 J=B2<<28!D2<<16 STORE CONST(K,6,ADDR(I)) DUMPRX(EX,XREG,0,CTABLEREG,K) %IF B1#C1 %THEN REGS(B1)_CL=0 %IF B2#C2 %THEN REGS(B2)_CL=0 %END %ROUTINE NOTE ASSMENT(%INTEGER REG, ASSOP, VAR,PTYPE) !*********************************************************************** !* NOTES THE ASSIGNMENT TO SCALAR 'VAR'. THIS INVOLVES REMOVING * !* OLD COPIES FROM REGISTERS TO AVOID CONFUSING OLD AND NEW VALUE* !* ASSOP =1 FOR'==',=2 FOR '=',=3 FOR '<-' * !*********************************************************************** %CONSTINTEGER EEMASK=B'1100011110000000';! MASK OF USES RELEVANT TO == %CONSTINTEGER EMASK=B'100011000000000';! MASK OF USES RELEVANT TO = %RECORD(REGF)%NAME WREG %INTEGER I,II,NREGS,UU %RETURN %IF VAR<=0 NREGS=REGWORDS(PTYPE)>>4 %IF ASSOP=1 %THEN %START %CYCLE II=0,1,14; ! THROUGH ALL REGISTERS I=GRMAP(II) WREG==REGS(I) %IF EEMASK&1<>16=VAR) %THEN WREG_SECUSE=0 %IF EEMASK&1<>16=VAR) %THEN WREG_USE=WREG_SECUSE %AND %C WREG_INF1=WREG_INF2 %REPEAT %IF REG>=0 %AND NREGS<=2 %THEN SET USE(REG+NREGS-1,X'51',ADDROF,VAR) %FINISH %ELSE %START %CYCLE II=0,1,14 I=GRMAP(II) WREG==REGS(I) %IF EMASK&1<>16=VAR %OR WREG_INF2=VAR) %THEN WREG_SECUSE=0 %IF EMASK&1<>16=VAR %OR WREG_INF1=VAR) %THEN %C WREG_USE=WREG_SECUSE %AND WREG_INF1=WREG_INF2 ! ! ALL THE FOREGOING CONDITIONS ARE NOT AS SILLY AS THEY SEEM. MUST ! BEAR IN MIND THAT BOTH GRINF&VAR MAY BE RECORD ELEMENTS DEFINED ! BY ALL 32 BITS OF INF AS WELL AS MODIFIED SCALARS WHEN THE NAME ! ONLY TAKES 16 BITS ! %REPEAT %IF ASSOP=2 %AND VAR>0 %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 %FINISH %ELSE %START; ! 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 BULK M(%INTEGER MODE,L,B1,D1,B2,D2) !*********************************************************************** !* PLANT CODE TO MOVE L BYTES (L KNOWN AT COMPILE TIME) FROM * !* D1(B1) TO D2(B2) * !* IF MODE =0 SET L BYTES TO D2(0 OR X'80') * !* * !* L MAY BE GREATER THAN 4095 * !*********************************************************************** %ROUTINESPEC UPDATE(%INTEGERNAME WI,DI) %INTEGERFNSPEC USE LONG %INTEGER I,J,W1,W2,OPCODE,CONST W1=B1; W2=B2 %IF L>1024 %AND USE LONG=0 %THEN %RETURN OPCODE=MVC %IF L+D1> 4092 %THEN UPDATE(W1,D1) %IF MODE#0 %AND L+D2>4092 %THEN UPDATE(W2,D2) %IF MODE=0 %THEN %START; ! PROPAGATE CONSTANT J=L; W2=W1 CONST=D2; D2=D1 %IF CONST=0 %AND L<=32 %THEN %START ! CCSTATE=-1 OPCODE=X'D7'; ! CAN USE XC %FINISH %ELSE %START; ! USE MVI & MVC TO PROPOGATE 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 %THEN %START I=D1; UPDATE(W1,D1) %IF W2=W1 %THEN D2=D2-I+D1; ! OVERLAPPING PROPAGATION W1=W2 %FINISH %IF D2>4092 %THEN UPDATE(W2,D2) 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 PAIR0=CHECKSEQREG(GRPAIR) %IF PAIR0<0 %THEN %RESULT=1 REGS(PAIR0)_CL=-1 PAIR1=CHECKSEQREG(GRPAIR) %IF PAIR1<0 %THEN REGS(PAIR0)_CL=0 %AND %RESULT=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=0 %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 %RECORDFORMAT IOPNDF(%INTEGER CNT,MODE,%RECORD(RD)OPND) %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 BOPMASK=LO<<(ZCOMP-128)!LO<<(CLSHIFT-128)! %C LO<<(CASHIFT-128)!LO<<(IEXP-128)!LO<<(REXP-128)!LO<<(AAINC-128)! %C LO<<(IOCPC-128)!LO<<(MULT-128){MH OPTIMISATION!} %LONGINTEGER UOP,BOP %CONSTLONGINTEGER L1=1 %RECORD (TRIPF) %NAME COMPTRIP,ADDTRIP,JTRIP,ASSTRIP,POSTTRIP,LTRIP, CURRT,FP2TRIP FORBITS=FPTRIP_X1; ! BITS DEFINED IN CLOOP OF PASS2 OP=0 INCFLAG=-1; FINALFLAG=-1; USINGREG=-1 %IF FORBITS&2#0 %START; ! CONST INCREMENT %IF FORBITS&X'FFFF03'=X'820803' %THEN OP=BCT %ELSE %C %IF FORBITS&X'800000'#0 %THEN OP=BXLE %ELSE OP=BXH %FINISH %IF OP=BCT %START FP2TRIP==TRIPLES(FPTRIP_FLINK) COMPTRIP==TRIPLES(FP2TRIP_FLINK) JTRIP==TRIPLES(COMPTRIP_FLINK) LTRIP==TRIPLES(JTRIP_FLINK) ASSTRIP==TRIPLES(LTRIP_FLINK) %ELSE LTRIP==TRIPLES(FPTRIP_FLINK); ! THE LABEL FOR REPEATING FP2TRIP==TRIPLES(LTRIP_FLINK); ! THE SECOND PREAMBLE COMPTRIP==TRIPLES(FP2TRIP_FLINK); ! THE COMPARISION JTRIP==TRIPLES(COMPTRIP_FLINK) ADDTRIP==TRIPLES(JTRIP_FLINK) ASSTRIP==TRIPLES(ADDTRIP_FLINK); ! THE ASSIGNMENT TO THE CONTROL %FINISH POSTTRIP==TRIPLES(FPTRIP_PUSE); ! THE POSTAMBLE IMPABORT %UNLESS (COMPTRIP_OPERN=COMP %OR COMPTRIP_OPERN=ZCOMP) %AND %C JTRIP_OPERN=FJUMP %AND ASSTRIP_OPERN=VASS ! REGMASK=0; ! NO USABLE REGISTERS AS YET USEDMASK=0; ! NO REGISTERS USED AS YET FREE REGS=0; ! COUNT OF FREE REGISTERS %FOR I=4,1,9 %CYCLE %IF REGS(I)_CL=0 %THEN %C REGMASK=REGMASK!(1<>7 %CYCLE %IF I=0 %THEN TOPND=CURRT_OPND1 %ELSE TOPND=CURRT_OPND2 %IF X'41'<=TOPND_PTYPE<=X'51' %AND TOPND_FLAG=0 %C %AND 0<=TOPND_D<=4095 %AND (K<128 %OR 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 BOP&(LO<<(SCOMP-128))#0 %START FREE REGS=FREE REGS-1 %FINISH %ELSE %IF UOP&LO<SKIP BXH %UNLESS %C 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 TOPND=COMPTRIP_OPND2 FINALFLAG=TOPND_FLAG %IF FINALFLAG=0 %AND OP=BXLE %THEN TOPND_D=TOPND_D+INCVAL FINALVAL=TOPND_D LOAD(TOPND,K+1,2); ! FINAL TO ODD REG REGS(K+1)_CL=-1 %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 %C (FINAL FLAG=0 %AND IOPND_OPND_D=FINALVAL)) %THEN IOPND_CNT=0 %REPEAT %FINISH %IF CPTR>0 %THEN QUICKSORT(IOPNDA,0,CPTR-1) %IF PARM_DCOMP#0 %START PRINTSTRING(" PRELOAD LIST") %FOR I=0,1,CPTR-1 %CYCLE IOPND==IOPNDA(I) NEWLINE WRITE(IOPND_CNT,1) WRITE(IOPND_MODE,4) SPACE 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 %THEN %EXIT %IF IOPND_MODE=1 %AND BOP&(LO<<(AHASS-128))#0 %THEN %CONTINUE %IF IOPND_MODE=3 %AND BOP&(LO<<(PTRAS-128))#0 %THEN %CONTINUE %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 %THEN %START IOPND_CNT=IOPND_CNT+1 %RETURN %FINISH %REPEAT %RETURN %IF 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 %RETURN %IF 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