%INCLUDE "ERCS04.PNX_CCODES" %INCLUDE "ERCC07.TRIPCNSTS" %INCLUDE "ERCC07.TRIMP_TFORM1S" %CONSTINTEGER ESTK=0,BR0=1,BR1=2,BR2=3,BR3=4,FR0=5,FR1=6,FR2=7,FR3=8, BRN=BR0<<16!BR3,FRN=FR0<<16!FR3 %RECORDFORMAT REGF(%INTEGER CL,(%INTEGER USE %OR %HALF SECUSE,PRIMUSE), %INTEGER INF1,INF2,AT,LINK) %OWNINTEGER CABUF,GLACABUF,GLABEL,FPPTR,FPHEAD %OWNINTEGERNAME CA,GLACA,PPCURR %OWNINTEGERARRAYNAME CTABLE,TAGS !%OWNBYTEINTEGERARRAYNAME CODE %OWNRECORD(LISTF)%ARRAYNAME ASLIST %EXTRINSICINTEGERARRAY CAS(0:12) %EXTRINSICRECORD(WORKAF)WORKA %EXTRINSICRECORD(PARMF) PARM %CONSTINTEGER MAXREG=8 %OWNRECORD(REGF)%ARRAY REGS(0:MAXREG) %EXTERNALROUTINESPEC FLAGAND FOLD(%RECORD(TRIPF)%ARRAYNAME T) %SYSTEMINTEGERMAPSPEC COMREG(%INTEGER N) %EXTERNALROUTINESPEC FAULT(%INTEGER I,J,K) %INCLUDE "ERCS04.PNX_PUTSPECS" %CONSTINTEGER MAXKXREF=5 %OWNINTEGERARRAY KXREFS(0:MAXKXREF)=-1(*) %CONSTSTRING(7)%ARRAY PLNAME(0:31)="plabs00","p_mvbb", "p_cndgs","plabs03","plabs04", "p_unass","p_swerr","p_exper", "p_xblks","p_capex","p_nores", "p_forer","p_reser","p_aberr", "plabs14","plabs15","p_stres", "plabs17","p_strjt","plabs19", "p_iexpn","p_rexpn","p_lrexp", "plabs23","p_conct","plabs25", "p_chkbp","plabs27","p_stcmp", "plabs29","plabs30","plabs31"; %CONSTSTRING(11)%ARRAY KXREFNAME(0:MAXKXREF)="s#stop","s#ndiag", "s#ilog","s#iexp","s#iocp", "icl9ceauxst"; %EXTERNALSTRING(255)%FNSPEC PRINTNAME(%INTEGER NAME) %EXTERNALROUTINESPEC PRINT TRIPS(%RECORD(TRIPF)%ARRAYNAME T) %ROUTINESPEC CNOP(%INTEGER I,J) %EXTERNALROUTINESPEC POP(%INTEGERNAME A,B,C,D) %EXTERNALROUTINESPEC PUSH(%INTEGERNAME A,%INTEGER B,C,D) %ROUTINESPEC REFORMATC(%RECORD(RD)%NAME OPND) %ROUTINESPEC PPJ(%INTEGER A,B) %ROUTINESPEC IMPABORT %EXTERNALROUTINESPEC PRHEX(%INTEGER VALUE,PLACES) %CONSTINTEGER YES=1,NO=0 %CONSTINTEGER EMAS=10 %CONSTINTEGER PERQ=11 %CONSTINTEGER PNX=12 %CONSTINTEGER HOST=EMAS %CONSTINTEGER TARGET=PERQ %CONSTINTEGER PARAMS BWARDS=YES %CONSTBYTEINTEGERARRAY BYTES(0:7)=0(3),1,2,4,8,16; %CONSTBYTEINTEGERARRAY WORDS(0:7)=0(3),1,1,1,2,4; %CONSTINTEGER DAREA=6; ! AREA FOR DIAG TABLES %CONSTINTEGER CAREA=10; ! AREA FOR CONSTANTS ! ! FIXED GLA CURRENTLY USED AS FOLLOWS ! 0-7 FREE(WAS 2900 ENTRY DESCRIPTOR) ! 8-11 ADDRESS OF UNSHARED SYMBOL TABLES ! 12-15 ADDRESS OF SHARED SYMBOL TABLES ! 16-19 LANGUAGE & COMPILER DATA ! 20-23 ADDRESS OF DAREA WHEN DAREA#SST ! 24-27 ADDRESS OF CONSTANT TABLE ! 28-31 ADDRESS OF A WORD CONTAINING STACKTOP 0FOR NO CHECKS ! 32-35 HOLDS M'IDIA' FOR DIAGNOSTIC IDENTIFICATION ! 36-39 FREE ! 40-55 DEFINES THE ENTRY POINT OF MDIAGS ! %CONSTINTEGER FIXEDGLALEN=56 %OWNINTEGERARRAY FIXED GLA(0:FIXEDGLALEN>>2-1)=M'IMP ',M'GLAP', 0(6),M'IDIA',0(*); ! !*********************************************************************** !* IMP CODE PLANTING ROUTINES * !* CODE AND GLAP ARE PUT INTO THE BUFFERS 'CODE,GLABUF(0:268)' * !* BY A NUMBER OF TRIVIAL ROUTINES.QPUT IS CALLED TO ADD THE * !* BUFFER TO THE OUTPUT FILE. THE BUFFERS ARE BASICALLY 0:255 * !* WITH A 12-BYTE MARGIN TO MINIMISE THE NUMBER OF TESTS FOR * !* THE BUFFER FULL CONDITION * !* * !* PPCURR(GLACURR) IS THE BUFFER POINTER * !* CA(GLACA) IS THE RELATIVE ADDRESS OF THE NEXT BYTE * !* CABUF(GLACABUF) IS CA(GLACA) FOR START OF BUFFER * !*********************************************************************** !*DELSTART %ROUTINE CPINIT !*********************************************************************** !* PERFORMS ANY NECESSARY TARGET DEPENDANT INITIALISING * !************************************************************************ PINITIALISE(1,WORKA_RELEASE,1); ! OPEN OBJECT FILE TAGS==WORKA_TAGS PMONON %IF PARM_DCOMP#0 %AND PARM_Z#0 %END %EXTERNALROUTINE CODEOUT !*********************************************************************** !* NEEDED TO SATISFY REFERENCE IN PASS2 * !*********************************************************************** %END %ROUTINE CNOP(%INTEGER I, J) PI(NULL) %WHILE CA&(J-1)#I %END %ROUTINE STORE CONST(%INTEGERNAME D, %RECORD(RD)%NAME OPND) !*********************************************************************** !* PUT THE CONSTANT OPND INTO THE CONSTANT TABLE * !* ONLY USED FOR LONG REALS ON PNX * !* 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,PR %INTEGERNAME CONST PTR CONST PTR==WORKA_CONST PTR K=WORKA_CONST BTM; ! AFTER STRINGS IN CTABLE PR=OPND_PTYPE>>4&15 LP=WORDS(PR); ! MAINTAIN GENERALITY J=CONSTPTR-LP %WHILE K<=J %CYCLE %IF CTABLE(K)=OPND_D %AND (LP=1 %OR CTABLE(K+1)=OPND_XTRA) %C %THEN D=4*K %ANDRETURN K=K+1 %REPEAT ! %IF CONST PTR&1#0 %THEN CONSTHOLE=CONST PTR %AND CONSTPTR=CONST PTR+1 D=4*CONST PTR CTABLE(CONSTPTR)=OPND_D %IF LP>1 %THEN CTABLE(CONSTPTR+1)=OPND_XTRA CONST PTR=CONST PTR+LP %IF CONST PTR>WORKA_CONST LIMIT %THEN FAULT(102,WORKA_WKFILEK,0) %END %ROUTINE STORE STRING(%INTEGERNAME D, %STRINGNAME S) !*********************************************************************** !* PUT THE STRING CONSTANT "S" INTO THE CONSTANT TABLE * !* A CHECK IS MADE TO SEE IF THE CONSTANT HAS ALREADY * !* BEEN INSERTED IN WHICH CASE THE OLD COPY IS REUSED * !*********************************************************************** %INTEGER J,K,LP %INTEGERNAME CONST PTR CONST PTR==WORKA_CONST PTR K=WORKA_CONST BTM; ! AFTER STRINGS IN CTABLE LP=1+LENGTH(S)//4 J=CONSTPTR-LP %WHILE K<=J %CYCLE %IF S=STRING(ADDR(CTABLE(K))) %THEN D=4*K %ANDRETURN K=K+1 %REPEAT ! %IF CONST PTR&1#0 %THEN CONSTHOLE=CONST PTR %AND CONSTPTR=CONST PTR+1 D=4*CONST PTR STRING(ADDR(CTABLE(CONSTPTR)))=S %IF HOST#TARGET %THEN PREVERSEBYTES(CAREA,D,4*LP) CONST PTR=CONST PTR+LP %IF CONST PTR>WORKA_CONST LIMIT %THEN FAULT(102,WORKA_WKFILEK,0) %END %ROUTINE GET ENV(%INTEGERNAME HEAD) !*********************************************************************** !* SAVE A COPY OF THE REGISTER STATE FOR FUTURE REFERENCE * !*********************************************************************** %INTEGER I, USE %RECORD(REGF)%NAME REG %CYCLE I=0, 1, MAXREG REG==REGS(I) USE=REG_USE&X'FF'; ! MAIN USE ONLY PUSH(HEAD, REG_INF1, REG_AT, I<<8!USE) %IF USE#0 %REPEAT %END %ROUTINE RESTORE(%INTEGER HEAD) !*********************************************************************** !* RESET THE REGISTERS TO ENVIRONMENT IN LIST HEADED BY 'HEAD' * !*********************************************************************** %INTEGER I, R, USE, INF, AT %RECORD(REGF)%NAME REG %CYCLE I=0, 1, MAXREG REG==REGS(I) %IF REG_CL>=0 %THEN REG_USE=0 %REPEAT %WHILE HEAD#0 %CYCLE POP(HEAD, INF, AT, I) R=I>>8; USE=I&255 REG==REGS(R) %IF REG_CL>=0 %THEN REG_USE=USE %AND REG_INF1=INF REG_AT=AT %REPEAT %END %ROUTINE REDUCE ENV(%INTEGERNAME OLDHEAD) !*********************************************************************** !* REMOVES FROM ENVIRONMENT OLDHEAD ANYTHING INCOMPATABLE WITH * !* THE CURRENT ENVIRONMENT. FOR MULTIPLE JUMPS TO LABELS * !*********************************************************************** %INTEGERNAME HEAD %INTEGER R,U,S1,S2,S3 %RECORD(LISTF)%NAME LCELL %RECORD(REGF)%NAME REG HEAD==OLDHEAD %WHILE HEAD>0 %CYCLE LCELL==ASLIST(HEAD) R=LCELL_S3>>8 U=LCELL_S3&255 REG==REGS(R) %IF REG_USE&255=U %AND REG_INF1=LCELL_S1 %AND LCELL_S2=REG_AT %C %THEN HEAD==LCELL_LINK %ELSE POP(HEAD,S1,S2,S3) %REPEAT %END %ROUTINE FORGET(%INTEGER REG) !*********************************************************************** !* CLEARS OUT USES OF NON LOCKED REGISTERS * !*********************************************************************** %INTEGER L,U %RECORD(REGF)%NAME FREG L=REG; U=L %IF L<0 %THEN L=0 %AND U=MAXREG %CYCLE REG=L,1,U FREG==REGS(REG); ! FORGETABLE REG %IF FREG_CL>= 0 %THEN FREG_USE=0 %REPEAT %END %EXTERNALROUTINE PDATA(%INTEGER AREA,BNDRY,L,AD) !*********************************************************************** !* ADDS L(BYTES) TO AREA FOR UST,SST AND DIAGS AREAS * !* L MAY BE REPETITION<<16! BASIC LENGTH * !*********************************************************************** %INTEGERNAME PTR PTR==CAS(AREA) PTR=(PTR+BNDRY-1)&(-BNDRY) %IF L>>16#0 %THEN %START PDPATTERN(AREA,PTR,L>>16,L&X'FFFF',AD) PTR=PTR+(L>>16)*(L&X'FFFF') %ELSE PDBYTES(AREA,PTR,AD,L) PTR=PTR+L %FINISH %END %EXTERNALINTEGERFN PINITOWN(%INTEGER PTYPE,ACC,%RECORD(RD)%NAME INIT, %STRINGNAME XNAME) !*********************************************************************** !* PUTS AN INITIALISED OWN INTO THE GLA. SHOULD DEAL WITH ALL TYPES * !*********************************************************************** %RECORD(RD)OPND %INTEGER PREC,TYPE,RL,RES,X,LITL 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 %START; ! OWNSTRINGNAMES ! HAVE LENGTH @LOW AD END ! AND ADDR AT HIGH AD END ! IN ESTACK LENGTH IS ON TOP OPND_XTRA=ACC-1 PD4(2,RES,OPND_XTRA) PD4(2,RES+4,OPND_D) GLACA=GLACA+8 %FINISH %ELSE %START PD4(2,RES,OPND_D) GLACA=GLACA+4 %FINISH %IF LITL=3 %START; ! EXTRINSICS ARE NAMES X=PXNAME(0,XNAME) PDXREF(2{IN GLA},RES,X) %FINISH ->END %FINISH %IF TYPE=2 %THEN REFORMATC(OPND) RL=BYTES(PREC) %IF TYPE=5 %THEN RL=2 %IF TYPE=3 %THEN RL=4 %IF RL>4 %THEN RL=4 GLACA=(GLACA+RL-1)&(-RL) RES=GLACA; GLACA=GLACA+ACC %IF TYPE=3 %OR (TYPE=5 %AND OPND_D=0) %START PDPATTERN(2,RES,ACC,1,ADDR(OPND_D)) ->END %FINISH %IF TYPE=5 %THEN %START PDPATTERN(2,RES,1,ACC,ADDR(WORKA_A(OPND_D))) %IF HOST#TARGET %THEN PREVERSEBYTES(2,RES,ACC) %FINISH %ELSE %START %IF PREC=3 %THEN PD(2,RES,OPND_D) %IF PREC=4 %THEN PD2(2,RES,OPND_D) %IF PREC>=5 %THEN PD4(2,RES,OPND_D) %IF PREC=6 %THEN PD4(2,RES+4,OPND_XTRA) %FINISH END: ! NOTE ENTRYT IF EXTERNAL %IF LITL=2 %THEN PDATAENTRY(XNAME,2{GLA},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 * !* PNX ARRAY HEAD HAS DV PTR AT LOW ADDRESS END AND @A(FIRST) AT * !* THE HIGH ADDRESS END. WHEN IN ESTACK DV PTR IS ON TOP * !*********************************************************************** %INTEGER LITL,RES,X,AHW0,AHW1 AHW0=AOFFSET>>1 AHW1=DVOFFSET>>1 GLACA=(GLACA+3)&(-4) RES=GLACA GLACA=GLACA+8 LITL=PTYPE>>14&3 PFIX(2,RES,CAREA,DVOFFSET); ! RELOCATE DV PTR %IF LITL=3 %START; ! EXTRINSIC ARRAYS X=PXNAME(0,XNAME) PDXREF(2,RES+4,X) %FINISH %ELSE %START %IF AAREA=0 %THEN PD4(2,RES+4,AHW0) %ELSE %C PFIX(2,RES+4,AAREA,AOFFSET) %FINISH %IF LITL=2 %THEN PDATAENTRY(XNAME,AAREA,SIZE,AOFFSET) %RESULT=RES %END %EXTERNALROUTINE CXREF(%STRING(255) NAME, %INTEGER MODE,XTRA,%INTEGERNAME AT) !*********************************************************************** !* OBTAIN A REFERENCE NO FOR EXTERNAL PROCEDURES * !* MODE=0 STATIC CODE XREF * !* MODE=1 DYNAMIC CODE XREF * !*********************************************************************** AT=PXNAME(1,NAME) %END %INTEGERFN KNOWN XREF(%INTEGER N) !*********************************************************************** !* RETURNS THE RT NO OF A KNOWN EXTERNAL NAME DEFINING IT ON * !* THE FIRST OCCURRENCE ONLY * !*********************************************************************** %INTEGER D %STRING(255) S %RESULT= KXREFS(N) %UNLESS KXREFS(N)<0 S=KXREFNAME(N) D=PXNAME(1,S) KXREFS(N)=D %RESULT=D %END %ROUTINE CALL STOP !*********************************************************************** !* CALLS STOP ROUTINE. NOT VIA EPILOGUE ON PERQ * !*********************************************************************** PI1(CALL,KNOWN XREF(0)); ! S#STOP %END %ROUTINE ERASE(%INTEGER WORDS) !*********************************************************************** !* REMOVES 1 OR 2 WORDS FROM THE ESTACK * !*********************************************************************** %INTEGER I PI(DISCARD) %FOR I=1,1,WORDS %END %ROUTINE EXCHANGE(%RECORD(RD)%NAME OPND1,OPND2) !*********************************************************************** !* REVERSES NEST SO OPERAND 1 IS AT TOP FOR FLOATS ETC * !* NO ACTION IF OPND2 IS A CONSTANT * !*********************************************************************** %RETURN %UNLESS OPND1_FLAG<=8 %AND OPND2_FLAG>=8 %C %AND OPND1\==OPND2 PI(EXCH) %END %ROUTINE BULKM(%INTEGER MODE,L,D2) !*********************************************************************** !* PLANT CODE TO MOVE L BYTES (L KNOWN AT COMPILE TIME) FROM * !* ETOS-2,ETOS-3 TO ETOS,ETOS-1 * !* IF MODE =0 SET L BYTES TO D2(0 OR X'80') * !* * !* L MAY BE GREATER THAN 4095 * !*********************************************************************** %INTEGER W2 %IF MODE=0 %START; ! CLEAR W2=D2<<8!D2 %UNLESS L=2 %START; ! SET END 16? BIT WORD PI(DUPL) %FINISH PLOADCONST(W2) P2I(EXCH,ASSH) L=L-2 %RETURN %IF L=0 P2I(EXCH,DUPL); ! INIT NOT REMOVED FROM STACK P2I(CI1,IADD) %FINISH PLOADCONST(L>>1) PI(MVWD) %END; ! OF ROUTINE BULK M %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)="ESK","BR0","BR1","BR2", "BR3","FR0","FR1","FR2","FR3"; %CONSTSTRING(15)%ARRAY USES(0:15) =" NOT KNOWN "," I-RESULT ", " TEMPORARY "," PLTBASE ", " NAMEBASE "," LIT CONST ", " TAB CONST "," DESC FOR ", " RECD BASE "," LOCAL VAR ", " NAME+CNST "," AUXSTPTR- ", " BYTE DES "," HALF DES ", " VMY RES "," DV BASE "; %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 NEWLINE %CYCLE I=0,1,MAXREG REG==REGS(I) %IF REG_CL!REG_USE#0 %START USE=REG_USE PRINTSTRING(REGNAMES(I).STATE(REG_CL)) WRITE(REG_AT,3); SPACE 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'0100011110000000' %CONSTINTEGER UNMASK=B'0100001110000000' PRINTSTRING(" USE = ".USES(USE)) %IF LNMASK&1<>16,1) %IF UNMASK&1<>16#0 %THEN PRINTSTRING(" MODBY ") %C %AND PRINTSTRING(PRINTNAME(INF>>16)) %END %END %EXTERNALROUTINE IMPABORT PRINTSTRING(" **************** ABORT******************** ABORT *******") !*DELSTART PCODELINE PRINT USE !*DELEND %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 %STRING(31) S CPINIT; ! INITIALISE CODE PLANTING ASLIST==ALIST GLABEL=WORKA_NNAMES+1; ! FOR GENERATING LABELS FPPTR=0 FPHEAD=0 CA==CAS(1) GLACA==CAS(2) GLACA=FIXEDGLALEN CTABLE==WORKA_CTABLE I=X'C2C2C2C2' PDATA(DAREA,4,4,ADDR(I)) %CYCLE I=0, 1, 31 WORKA_PLABS(I)=-1; WORKA_PLINK(I)=0 %REPEAT %CYCLE I=0,1,FR3; ! HIGHEST PNX REG REGS(I)=0 KXREFS(I)=-1 %IF I<=MAXKXREF %REPEAT ! ! GENERATE A MOVE BYTES ROUTINE ENTERED BY CALL ! USED IN RESOLUTION FOR POSSIBLY OVERLAPPED MOVES ! (ETOS)=LENGTH ! (ETOS-2=>R0)=DEST ADDRESS IN BYTES ! (ETOS-4=>R1)=SOURCE ADDRESS IN BYTES ! ! SAVE2,EXCH,SR0,DISCARD DEST TO R0 ! EXCH,SR1,DISCARD SOURCE TO R1 ! DUPL,CI0,IJLE !L1: ATR1 1,ATR0 1 GET CURRENT DEST&SRCE AND INC ! CI1,MVB MOVE A SINGLE BYTE ! ILL4, ILL2,IADD,ASSB ! CI1,ISUB,DUPL,JTRUE !L0: DISCRD,RETURN2 ! S=PLNAME(1) PPROC(S,0,WORKA_PLABS(1)) P4I(SAVE2,EXCH,SR0,DISCARD) P3I(EXCH,SR1,DISCARD) P2I(DUPL,CI0) PJUMP(IJLE,GLABEL) PLABEL(GLABEL+1) PI1(ATR1,1) ! THE NEXT LINES CHANGED WHEN MVB APPEARED TO HAVE A FALUT PI(LBI) PI1(ATR0,1) ! P2I(CI1,MVB) P2I(ASSB,DISCARD) P3I(CI1,ISUB,DUPL) PJUMP(JTRUE,GLABEL+1) PLABEL(GLABEL) P2I(DISCARD,RETURN2) PPROCEND(0) GLABEL=GLABEL+2 ! ! GENERATE THE RUN TIME ERROR ROUTINE :- ! MDIAGS FOR PERQ IS %ROUTINE MDIAGS(%INT PC,AP,ERROR,XTRA) ! PC IS A DUMMY EXCEPT AFTER CONTINGENCY ! ON ENTRY TO THIS SUBROUTINE ERROR & XTRA ARE IN ETOS ! ENTRY HAS BEEN BY JMPW LINKREG SO RETURN ADDRESS IS NOT AVAILABLE ! ! LAS 0 CURRENT LNB TO ETOS ! CI0 DUMMY CALLING PC ! IPUSH, IPUSH ABOVE TWO REVERSED TO MEMMORY ! IPUSH, IPUSH ZERO AND EXTRA TO MEMORY ! CALL N CALL TO NDIAGS ! RETURN ! K=KNOWN XREF(1); ! NDIAG XREF (AS NO ZERO) OBTAINED S=PLNAME(2) PPROC(S,0,WORKA_PLABS(2)) %IF PARAMS BWARDS=YES %THEN %START P3I(EXCH,IPUSH,IPUSH) PI1(LAS,0) PI(LI) P3I(IPUSH,CI0,IPUSH) %FINISH %ELSE %START PI1(LAS,0) PI(LI) PI(CI0) P4I(IPUSH,IPUSH,IPUSH,IPUSH) %FINISH PI1(CALL,K) PI1(ASFW,16) PI(RETURN); ! ONLY NEEDED FOR %MONITOR PPROCEND(0); ! 0 BYTES OF LOCALS ! ! SUBROUTINE TO CALL DEBUG ROUTINE(S#IMPMON) LINE NO IN GR0 ! ! STM 4,0,16(11) ! LM CODER,EPREG,EPDIST ! BCR 15,LINKREG RETURN ADDR ALREADY IN GR15 ! %IF PARM_DBUG#0 %THEN %START ! WORKA_PLABS(3)=CA ! CXREF("S#IMPMON",PARM_DYNAMIC,2,K) %FINISH ! ! SUBROUTINE TO ADVANCE STACK FRONT BY ETOS WORDS AND CHECK FOR OFLOW ! ! REPL,LDC0,EXCH ! KEEP COPY AND MAKE LONG ! LDC0,LDTP,ADDL ! LENGTH AFTER PROOSED ADJUST ! LDC0,LDCW X'F000',LEQI L ! JTB ! LDC0,LDCW X'201', JMP ! EXCESS BLOCKS ERROR !OK: MES, EXCH ! ATPW, MMS, RETURN ! CLAIM SPACE AND RETURN ! %IF PARM_OPT=1 %THEN %START; ! ONLY REQUIRED WITH CHKING ! WORKA_PLABS(4)=CA %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 FAULT WORKA_CONST PTR=1 WORKA_CONST BTM=WORKA_CONST PTR %IF PARM_PROF#0 %THEN %START; ! ALLOCATE PROFILE COUNT AREA %FINISH %RETURN %ROUTINE ERR EXIT(%INTEGER LAB, ERRNO, MODE) !*********************************************************************** !* MODE=0 FOR DUMMY(ZERO) XTRA - MODE=1 XTRA IN GR1 * !*********************************************************************** %INTEGER J %STRING(31)S S=PLNAME(LAB) PPROC(S,2,WORKA_PLABS(LAB)) %IF MODE=0 %THEN PLOAD CONST(0) PLOADCONST(ERRNO) PI1(CALL,WORKA_PLABS(2)) PPROCEND(0) %END %END %EXTERNALROUTINE EPILOGUE(%INTEGER STMTS) !*********************************************************************** !* PLANT ANY SUBROUINES THAT HAVE BEEN REQUIRED DURING * !* THE CODE GENERATION PHASE * !*********************************************************************** %ROUTINESPEC FILL(%INTEGER LAB) PLINESTART(9999); ! PSEUDO LINE NO ! ! STRING RESOLUTION ROUTINE (ENTERED BY CALL) ! P6 = WORD ADDRESS OF STRING BEING RESOLVED ! P5 = WORD ADDR OF (ORIGINAL LENGTH! BYTES USED UP<<16) ! P4 = LMAXOF FRAGMENT HOLING STRING(=0 NO SUCH STRING) ! P3 = WORD ADDRESS OF FRAGMENT STRING ! P2 = WORD ADRESS OF RESOLUTION STRING(CONVERTED TO BYTE FORM ON ENTRY) ! P1 = DUMMY SET IN ROUTINE TO ORIGINAL LENGTH ! END OF PARAMETER ! L1 = LOCAL COPY OF BYTES USED UP ! L2 = LENGTH OF RESOLUTION STRING ! L3 = NO OF POSSIBLE VAILD COMPARISONS ! L4 = COMPARISON LOOP CONTROL OF FORM 1,1,L3 ! L5 = CH COMPARE CONTRO FOR LOOP 1,1,L2 ! L6&7 = WORK VARIABLES IN CH COMPARE LOOP ! L8 = BYTE POINTER TO FIRST RELEVANT BYTE OF RESTRING ! ! ! STAGE 1 INITIALISE LOOP CONTROL AND WORK OUT THE NO OF VALID ! COMPARISONS AND STORE IN L3 ! ! CI1 ISL4 INITIALISE CONTROL ! LLOS(P5), MASKH, ISP1 COPY BYTES IN ORIGINAL STRING ! LHLOS(P5), ISL1 COPY OF BYTES USED UP ! ISUB BYTES LEFT OF LHS ! ILP2, CVBA, ISP2 EXAMINE RESOLUTION STRING ! LBI, ISL2 AND GET ITS CURRENT LENGTH ! JFALSE RESOLVING ON NULL STRING ! ILL2, ISUB 0 LENGTH DIFF =1 VALID COMP ! CI1, IADD, ISL3 MAX NO OF VALID COMPARISONS ! CI0, IJLE NOT ENOUGH LEFT OF LHS ! ILP6, CVBA, ILL1, IADD, ISL8 ! ! STAGE 2 CYCLE ROUND WITH BYTEARRAY COMPARISONS TO LOCATE STRING ! !OUTERLOOP(L0): REPITIONS TO HERE ! ILP2, CI1, ISL5, IADD, ISL6 INIT CONTRO & SET BYTE PTR TO RESOLUTION ! ILL8, ILL4, IADD, ISL7 POINTER TO RIGHT BYTE IN LHS !INNERLOOP(L1): REPEAT ON BYTE BY BYTE ! LBI, EXCH, LBI GET NEXT BYTE PAIR ! IJNE NOT THE SAME ! ILL5, CI1, IADD, ISL5 UPDATE CONTROL ! ILL2, IJGT ALL FOUND WITH NO NONEQIVALENCE ! CI1, LAS (L6), OAADD UPDATE FIRST POINTER ! CI1, LAS (L7), OAADD UPDATE SECOND PTR ! JUMP AND REPEAT !DIFF FOUND(L3): THIS COMPARISON FAILS ! ADVANCE DOWN BY ONE ! ILL4, CI1, IADD,ISL4 INCREMENT CONTROL ! ILL3, IJLE AND CONTINUE ! !RESFAIL(L4): RESOLUTION HAS FAILED ! CI0, RETURN EXIT WITH FALSE SET !RESOK(L5): RESOLUTION HAS WORKED ! ILP4, JFALSE FRAGMENT TO BE DISCARDED ! ! CONTROL IS NO OF BYTES TO BE STORED (IE L+1) OF FRAGMENT ! FIRST COPY IN BYTES + RUBBISH LENGTH THEN OVERWRITE ! WITH CORRECT LENGTH ! ! ILL8 SOURCE PTR ! ILP3, CVBA DEST POINTER ! ILL4 BYTES TO MOVE ! CALL PLABS1 ASSIGN POSSIBLY OVERLAPPING ! ILL4, CI1, ISUB FRAGMENT LENGTH ! ILP3,CVBA, ASSB STORED WITH PTR ! ILP4, IJLE CHECK FOR CAP EXCEED ! CALL PLABS9 AND FAIL IF SO !NOSTORE(L6): ENTERS HERE IF FRAGMENT IS DISCARDED ! ILL1,ILL2,IADD,ILL4,IADD RECALCULATE BYTES USED UP ! CI1, ISUB, SHLOS(P5) AND STORE VIA HALFWORD PTR ! CI1, RETURN EXIT WITH RESULT=TRUE ! %IF WORKA_PLINK(16)=0 %THEN ->P17 FILL(16) P2I(CI1,ISL4) PI1(LLO,24) P2I(MASKS,ISP1) PI1(LHLO,24) P2I(ISL1,ISUB) P3I(ILP2,CVBA,ISP2) P2I(LBI,ISL2) PJUMP(JFALSE,GLABEL+5) P2I(ILL2,ISUB) P4I(CI1,IADD,ISL3,CI0) PJUMP(IJLE,GLABEL+4) PI1(ILL,28) P4I(CVBA,ILL1,IADD,ISL8) ! THIS IS "OUTERLOOP" PLABEL(GLABEL) P4I(ILP2,CI1,ISL5,IADD) PI(ISL6) P4I(ILL8,ILL4,IADD,ISL7) ! THIS IS "INNERLOOP" PLABEL(GLABEL+1) P3I(LBI,EXCH,LBI) PJUMP(IJNE,GLABEL+3) P4I(ILL5,CI1,IADD,ISL5) PI(ILL2) PJUMP(IJGT,GLABEL+5) PI(CI1) PI1(LAS,-24) P2I(OAADD,CI1) PI1(LAS,-28) PI(OAADD) PJUMP(JUMP,GLABEL+1) ! THIS IS "DIFF FOUND" PLABEL(GLABEL+3) P4I(ILL4,CI1,IADD,ISL4) PI(ILL3) PJUMP(IJLE,GLABEL) ! THIS IS "RESFAIL" PLABEL(GLABEL+4) PI(CI0) PI(RETURN) ! THIS IS "RESOK" PLABEL(GLABEL+5) PI(ILP4) PJUMP(JFALSE,GLABEL+6) PI(ILL8) P3I(ILP3,CVBA,ILL4) PI1(CALL,WORKA_PLABS(1)) P3I(ILL4,CI1,ISUB) P3I(ILP3,CVBA,ASSB) PI(ILP4) PJUMP(IJLE,GLABEL+6) PI1(JLK,WORKA_PLABS(9)) ! THIS IS "NOSTORE" PLABEL(GLABEL+6) P4I(ILL1,ILL2,IADD,ILL4) P3I(IADD,CI1,ISUB) PI1(SHLO,24) P2I(CI1,RETURN) PPROCEND(32) GLABEL=GLABEL+7 P17: ! ! EVALUATE X**Y ! ******** **** ! Y IS IN FR0 AND X IS AT TOP OF STACK ! EVENT 5/5 IS SIGNALLED IF X<0 OR (X=0 AND Y<=0) ! OTHERWISE RESULT=EXP(Y*LOG(Y)) ! ! ST 15,12(WSPR) SAVE LINK ! BALR 1,0 ! LTDR 0,0 ! BC 4,PLAB7 ! BC 7,20(1) ! LD 2,0(WSPR) ! LTDR 2,2 ! BC 12,PLAB7 ! LA WSPR,16(WSPR) PROTECT X AND RETURN ADD ! STD 0,64(WSPR) PARAMETER X TO LOG ! STM 4,14,16(WSPR) SAVE ENVIRONMENT ! LM CODER,EPREG,LOGEPDISP ! BALR LINKREG,EPREG ! LA 0,16 ! SR WSPR,0 ! MD 0,0(WSPR) ! STD 0,64(WSPR) Y*LOG(X) TO EXP ! STM 4,14,16(WSPR) ! LGR LINKREG,12(WSPR) ! LM CODER,EPREG,EXPEPDISP ! BCR 15,LINKREG RETURNS DIRECT TO PROGRAM ! %IF WORKA_PLINK(17)=0 %THEN ->P18 FILL(17) ! %IF LOGEPDISP=0 %THEN CXREF("S#ILOG",0,2,LOGEPDISP) ! %IF EXPEPDISP=0 %THEN CXREF("S#IEXP",0,2,EXPEPDISP) P18: ! ! STRING JAM TRANSFER ENTERED BY CALL WITH 5 PARAMS ! P4 = VIRT (WORD) ADDR OF SOURCE ! P3 = MAX LENGTH OF DEST ! P2 = VIRT (WORD) ADDR OF DEST ! P1 = DUMMY FOR ALIGNMENT ! L1 = LOCAL THE ACTUAL STRING BYTES TO BE MOVED ! ! ILP4, CVBA, LBI, ISL1 LENGTH OF SOURCE ! ILP3, IJLE NO TRUNCATION ! ILP3, ISL1 TRUNCATED LENGTH !L0: ILP4, CVBA ! ILP2, CVBA,ILL1 ! CI1, IADD, MOVE LBYTES + LENGTH BYTE ! MVB ! ILL1, ILP2, CVBA, ASSB AND OVERWRITE LENGTH ! RETURN ! %IF WORKA_PLINK(18)=0 %THEN ->P19 FILL(18) P4I(ILP4,CVBA,LBI,ISL1) PI(ILP3) PJUMP(IJLE,GLABEL) P2I(ILP3,ISL1) PLABEL(GLABEL) P4I(ILP4,CVBA,ILP2,CVBA) P3I(ILL1,CI1,IADD) PI(MVB) P4I(ILL1,ILP2,CVBA,ASSB) PI(RETURN) PPROCEND(8) GLABEL=GLABEL+1 P19: ! called subroutine to evaluate i****4 ! ! %IF WORKA_PLINK(19)=0 %THEN ->P20;! ROUTINE NOT USED P20: ! called subroutine to evaluate i****N ( I 32 BITS) ! N OVER I IN ESTACK NO C PARAMETERS ! fault recorded unless 0<=n<=63 ! ! ISL,DUPL STORE N IN LOCAL 1 ! LCONST 0, IJLT L0 ! LCONST 63, IJLT L1 !L0 CALL PLABS7 !L1 ISL 2 STORE I IN LOCAL 2 ! DISCARD ERASE I FROM ESTACK ! LCONST 1 PRODUCT !L4 LL1 1,LCOSNT 1, ISUB, STL1 DECREMENT N ! LCONST 0, IJLT L3 JUMPOUT WHEN COMPLETE ! LL 2,IMULT, JUMP L4 !L3 RETURN ! %IF WORKA_PLINK(20)=0 %THEN ->P21;! ROUTINE NOT USED FILL(20) PI(ISL1) PI(DUPL) PLOADCONST(0) PJUMP(IJLT,GLABEL) PLOADCONST(63) PJUMP(IJLT,GLABEL+1) PLABEL(GLABEL) PI1(JLK,WORKA_PLABS(7)) PLABEL(GLABEL+1) P2I(ISL2,DISCARD) PLOADCONST(1) PLABEL(GLABEL+4) PI(ILL1) PLOADCONST(1) PI(ISUB) PI(ISL1) PLOADCONST(0) PJUMP(IJLT,GLABEL+3) PI(ILL2) PI(IMULT) PJUMP(JUMP,GLABEL+4) PLABEL(GLABEL+3) PI(RETURN) PPROCEND(8) GLABEL=GLABEL+5 P21: ! called subroutine to evaluate X**N ( X 32 BITS) ! In-line code now genererated for this P22: ! called subroutine to evaluate X**N ( X 64 BITS) ! IN LINE CODE NOW USED ! P23: ! ! STRING PRE-CONCATENATION SUBROUTINE ! NOT USED ON PNX ALL DONE AT P24 ! P24: ! ! STRING CONCATENATION SUBROUTINE ! MUST LEAVE NO RUBBISH IN ESTACK IN CASE LHS DEST IN NEST ! ! P2 HAS WORD ADDRESS OF NEXT BIT ! P1 HAS WORD ADDRESS OF WORKAREA CONTAINING PREVIOUS BITS ! L1 HAS BYTE LENGTH OF P2 ! L2 HAS BYTE LENGTH OF P1 ! ! ILP2, CVBA, DUPL, LBI ! ISL1, EXCH, CI1, IADD, EXCH LENGTH OF MOVE OVER SOURCE ! ILP1, CVBA, DUPL, LBI ! ISL2, IADD, CI1, IADD ! EXCH, MVB STRINGS JOINED ! ILL1, ILL2, IADD, ILP1 ! CVBA, ASSB, ! DISCARD REMOVE LENGTH ! RETURN ! %IF WORKA_PLINK(24)=0 %THEN ->P25 FILL(24) P4I(ILP2, CVBA, DUPL, LBI) P3I(ISL1,EXCH,CI1) P2I(IADD,EXCH) P4I(ILP1,CVBA,DUPL,LBI) P4I(ISL2,IADD,CI1,IADD) PI(EXCH) PI(MVB) P4I(ILL1,ILL2,IADD,ILP1) P3I(CVBA,ASSB,DISCARD) PI(RETURN) PPROCEND(8) P25: ! ! CHECK ARRAY BOUND WITH 16 BIT INDEX ! NO RELEVANCE TO PNX P26: ! ! CHECK ARRAY BOUND WITH 32 BIT INDEX ! NOW DONE IN LINE WITH CHK INSTR P27: ! REDUCE LONG BYTE INDEX ! NOT NEEDED FOR PNX ! P28: ! DIFFERENCE IMP STRINGS ! ESTACK HAS TWO WORD ADDRESS AND ROUTINE RETURNS FIRST DIFFERENCE ! ! L1 HAS UPPER (BYTE) ADDRESS ! L2 HAS UPPER STRING LENGTH ! L3 HAS LOWER (BYTE) ADDRESS ! L4 HAS LOWER STRING LENGTH ! L5 HAS SHORTER STRING LENGTH ! ! CVBA ISL1, LBI, ISL2 ! EXCH, CVBA, ISL3, LBI, ISL4, ISL5 ! IJGE ! ILL2, ISL5 SHORTER LENGTH SET !L0: ILL5 L5 ON TOP OF ESTACK ! JFALSE END REACHED !L3: ILL3, CI1, IADD, ISL3, LBI ! ILL1, CI1, IADD, ISL1, LBI ! IJNE A DIFFERENCE FOUND ! ILL5, CI1, ISUB, ISL5 ! JTRUE !L1: NO DIFFERENCE RETURN LENGTHS ! ILL4, ILL2, RETURN !L2: A DIFFERENCE RELOAD CHARS ! ILL3, LBI, ILL1, LBI ! RETURN ! %IF WORKA_PLINK(28)=0 %THEN ->P29 FILL(28) P4I(CVBA,ISL1,LBI,ISL2) P3I(EXCH,CVBA,ISL3) P3I(LBI,ISL4,ISL5) PJUMP(IJGE,GLABEL) P2I(ILL2,ISL5) PLABEL(GLABEL) PI(ILL5) PJUMP(JFALSE,GLABEL+1) PLABEL(GLABEL+3) P3I(ILL3,CI1,IADD) P2I(ISL3,LBI) P3I(ILL1,CI1,IADD) P2I(ISL1,LBI) PJUMP(IJNE,GLABEL+2) P4I(ILL5,CI1,ISUB,ISL5) PJUMP(JTRUE,GLABEL+3) PLABEL(GLABEL+1) P3I(ILL4,ILL2,RETURN) PLABEL(GLABEL+2) P4I(ILL3,LBI,ILL1,LBI) PI(RETURN) PPROCEND(24) GLABEL=GLABEL+4 P29: ! SCALE VIA DV FOR 32 BIT INDEX ! CURRENT DONE IN LINE TILL JLINK PROVIDED ! P30: %IF PARM_DCOMP#0 %THEN PRINTSTRING(" CODE FOR LINE 99999") %AND PCODELINE %BEGIN !*********************************************************************** !* PASS INFORMATION TO QPUT TO ENABLE IT TO GENERATE THE * !* LOADER DATA AND COMPLETE THE PROGRAM FILE. * !*********************************************************************** %ROUTINESPEC DUMPCONSTS %INTEGERARRAY SIZES(0:10) %INTEGER LANGFLAG,PARMS,I,K ! CODE OUT ! CNOP(0,8) ! FIXED GLA(6)=CA; ! CONST TABLE ADDRESS DUMP CONSTS %IF PARM_TRACE=0 %THEN LANGFLAG=6 %ELSE LANGFLAG=1 LANGFLAG=LANGFLAG<<24 PARMS=(PARM_DIAG<<1!PARM_LINE)<<1!PARM_TRACE FIXED GLA(4)=LANGFLAG!WORKA_RELEASE<<16!(PARM_CPRMODE&1)<<8!PARMS;! LANG RLSE & MAINPROG I=GLACA-GLACABUF %IF PARM_INHCODE=0 %THEN %START ! QPUT(42, I, GLACABUF, ADDR(GLABUF(0))) %UNLESS I=0 ! BACK OF GLAP PDBYTES(2,0,ADDR(FIXED GLA(0)), FIXEDGLALEN);! FRONT OF GLAP PFIX(2,8,5,0); ! RELOCATE GLA ST ADDRESS PFIX(2,12,4,0); ! RELOCATE CODE ST ADDRESS PFIX(2,20,DAREA,0); ! RELOCATE DAREA POINTER PFIX(2,24,CAREA,0); ! RELOCATE CONSTANT TABLE I=X'E2E2E2E2' PDATA(DAREA, 4, 4, ADDR(I)) %FINISH %CYCLE I=1,1,10 SIZES(I)=0 SIZES(I)=(CAS(I)+7)&(-8) %IF 2<=I<=6 %REPEAT SIZES(CAREA)=((WORKA_CONSTPTR+1)>>1)*8 PTERMINATE(ADDR(SIZES(1)));! SUMMARY INFO. PRINTSTRING(" PNX CODE") WRITE(SIZES(1)+SIZES(CAREA), 6) %IF SIZES(4)>0 %THEN PRINTSTRING("+") %AND %C WRITE(SIZES(4),4) PRINTSTRING(" BYTES GLAP") WRITE(SIZES(2), 3); PRINTSTRING("+") WRITE(SIZES(5), 1); PRINTSTRING(" BYTES DIAG TABLES") WRITE(SIZES(DAREA), 3); PRINTSTRING(" BYTES TOTAL") K=SIZES(1)+SIZES(CAREA)+SIZES(2)+SIZES(4)+SIZES(5)+SIZES(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 %ROUTINE DUMP CONSTS !*********************************************************************** !* OUTPUT THE CONSTANT TABLE AND MAKE ANY RELEVANT RELOCATIONS * !*********************************************************************** %INTEGER I,J,K,BASE BASE=ADDR(WORKA_CTABLE(0)) %IF PARM_DCOMP#0 %START PRINTSTRING(" CONSTANT TABLE") I=0 %CYCLE NEWLINE PRHEX(4*I,5) %CYCLE J=0,1,7 SPACES(2) PRHEX(INTEGER(BASE+4*(I+J)),8) %REPEAT SPACE %CYCLE J=0,1,31 K=BYTEINTEGER(BASE+4*I+J) %IF K<31 %OR K>125 %THEN K=32 PRINT SYMBOL(K) %REPEAT I=I+8 %EXIT %IF I>=WORKA_CONSTPTR %REPEAT %FINISH PDBYTES(CAREA,0,BASE,4*WORKA_CONSTPTR) %END %END %RETURN %ROUTINE FILL(%INTEGER LAB) !*********************************************************************** !* NOT NECESSARY ACTUALLY TO FILL JUMPS ON PNX * !* CONSTRUCT THE RIGHT PPROC STATEMENT AND LOADER DOES THE REST * !*********************************************************************** %STRING(15)S S=PLNAME(LAB) PPROC(S,0,WORKA_PLINK(LAB)) %END %END %EXTERNALREALFN ICL Real to PERQ(%REAL ICL Real) !*********************************************************************** !* This is a function which converts a real number in ICL * !* floating-point format into one that is in ICL PERQ * !* floating-point format. * !* * !* At Exit: RESULT= +infinity if ICL Real is too large * !* RESULT= -infinity if ICL Real is too small * !* RESULT= PERQ Real otherwise * !* * !*Assumptions: (i). PERQ floating-point format conforms with the * !* proposed IEEE draft standard, * !* (ii). conversion is to be applied to 32-bit Reals, * !* (iii). conversion is to be applied on ICLs, * !* (iv). the hexadecimal representation of 1.0, * !* on ICL PERQ's is R'3F800000' * !*********************************************************************** %CONSTREAL MINUS INFINITY= R'FF800000'; ! ie sign=1,exp=255,fraction=0 %CONSTREAL PLUS INFINITY= R'7F800000'; ! ie sign=0, exp=255,fraction=0 %CONSTREAL PERQ ZERO= R'00000000'; ! ie sign=0,exp=0,fraction=0 %INTEGER Bits Shifted Left; ! by a SHZ instruction on ICL Fraction %INTEGER ICL Exp; !exponent of ICL Real - 70 %INTEGER Sign; !sign bit of ICL Real (1 if minus: 0 if plus) %INTEGER PERQ Exp; !exponent of PERQ Real (calculated) %INTEGER PERQ Fraction; !fraction of PERQ Real (derived from ICL Fraction) %INTEGER PERQ Real; !--the Result %IF HOST#TARGET %START %IF PARM_X#0 %THENRESULT=ICL REAL; ! FOR SIMULATOR %IF ICL Real=0.0 %THENRESULT=PERQ ZERO %IF ICL Real<0.0 %THEN SIGN=1 %AND ICL Real=-ICL Real %ELSE SIGN=0 ! ICL Real is now positive ! Decompose the ICL Real: *LSS_ICL Real *FIX_ICL Exp *SHZ_Bits shifted left *USH_1; *USH_-9 *ST_PERQ Fraction ! Calculate PERQ Exponent: PERQ Exp=((ICL Exp+5)*4 {as exponent is a hexadecimal exp})+ %C (11-bits shifted left) {equals either 0,1,2, or 3}+127 {the bias of the exponent} ! -and examine its range: %IF PERQ Exp<=0 %THENRESULT=MINUS INFINITY {ie Real Underflow} %IF PERQ Exp>=255 %THENRESULT=PLUS INFINITY { Real Overflow} ! Construct the PERQ Real *LSS_SIGN *USH_8 *OR_PERQ Exp *USH_23 *OR_PERQ Fraction *ST_PERQ Real *EXIT_-64 ! %RESULT=PERQ Real %FINISHELSERESULT=ICL REAL %END; !of ICL Real to PERQ %EXTERNALLONGREALFN ICL LongReal to PERQ(%LONGREAL ICL2900 Real) !*********************************************************************** !* This is a function which converts a double precision real * !* in ICL 2900 floating-point format into one that is * !* in ICL PERQ floating-point format. * !* At Exit: RESULT= equivalent PERQ real * !* * !*Assumptions: (i). PERQ floating-point format conforms with the * !* proposed IEEE draft standard, * !* (ii). conversion is to be applied to 64-bit Reals, * !* (iii). conversion is to be applied on ICL2900s, * !* (iv). the hexadecimal representation of 1.0, * !* on ICL PERQ's is R'3FF0000000000000' * !************************************************************************ %INTEGER Bits Shifted Left; ! by a SHZ instruction on ICL2900 Fraction %INTEGER ICL2900 Exp; !exponent of ICL2900 Real - 78 %INTEGER Sign; !sign bit of ICL2900 Real (1 if minus: 0 if plus) %INTEGER PERQ Exp; !exponent of PERQ Real (calculated) %LONGREAL PERQ Fraction; !fraction of PERQ Real (derived from ICL2900 Fraction) %LONGREAL PERQ Real; !--the Result %IF HOST#TARGET %START %IF PARM_X#0 %THENRESULT=ICL2900REAL; ! FOR SIMULATOR %IF ICL2900 Real=0.0 %THENRESULT=0.0 %IF ICL2900 Real<0.0 %THEN %C SIGN=1 %AND ICL2900 Real=-ICL2900 Real %ELSE SIGN=0 ! ICL2900 Real is now positive ! Decompose the ICL2900 Real: *LSD_ICL2900 Real *FIX_ICL2900 Exp *SHZ_Bits shifted left *USH_1; *USH_-12 *ST_PERQ Fraction ! Calculate PERQ Exponent: PERQ EXP=(ICL2900 Exp+78 {which was subtracted by FIX above}-64 %C {which is the ICL2900 bias}-1 %C { as the most significant digit is <1 and >=1/16})*4 %C { as the ICL2900 exponent is a hex exponent}+ %C (11-bits shifted left) %C {bits shifted left equals 11, or 10, or 9, or 8}+1023 {bias of PERQ double precision reals} ! Construct the PERQ Real *LSS_SIGN; ! Load sign of PERQ Real *USH_11; ! and shift to make room for PERQ Exp *OR_PERQ Exp; ! Add on the PERQ exponent *MPSR_X'12'; ! Then double ACC size *USH_52; ! and shift sign and exponent to the top *OR_PERQ Fraction; ! Add on the PERQ fraction *ST_PERQ Real; ! and save the result %RESULT=PERQ Real %FINISH %END; ! of ICL2900 LongReal to PERQ %ROUTINE PPJ(%INTEGER JUMP,N) !*********************************************************************** !* PLANT A 'JUMP PERMENTRY(N)' * !* IF JUMP=0 THEN PLANT A CALL * !*********************************************************************** %INTEGER VAL, J, LAB, OP %CONSTINTEGER JLKMASK=X'FFF8' LAB=0 %IF 1<0 %THEN PJUMP(JTRUE+JFALSE-JUMP,LAB) %IF FPPTR&7#0 %THEN PI(ALIGN) PI1(OP,VAL) %IF FPPTR&7#0 %THEN PI1(ASFW,4) %IF LAB>0 %THEN PLABEL(LAB) %END %EXTERNALROUTINE REFORMATC(%RECORD(RD)%NAME OPND) !*********************************************************************** !* REFORMATS A CONSTANT TO TAKE INTO ACCOUNT DIFFERENT HOST-TARGET * !* REPRESENTATIONS * !*********************************************************************** %IF HOST#TARGET %START %INTEGER TYPE,PREC,I I=OPND_D; ! ALL INTEGER UP TO 32 BIT TYPE=OPND_PTYPE&7 %IF TYPE=1 %THEN %RETURN PREC=OPND_PTYPE>>4&7 %IF TYPE=2 %THEN %START %IF PREC=5 %THEN OPND_R=ICLREALTOPERQ(OPND_R) %AND %RETURN %IF PREC=6 %THEN OPND_LR=ICLLONGREALTOPERQ(OPND_LR) %AND %RETURN %FINISH %FINISH %END %EXTERNALROUTINE CHANGESEX(%INTEGER BASEAD,OFFSET,L) !*********************************************************************** !* ALTERERS INITIALISED DATA FOR A BYTE SEX CHANGE * !*********************************************************************** %OWNBYTEINTEGERARRAYFORMAT F(0:X'FFFF') %BYTEINTEGERARRAYNAME A %INTEGER I,J %IF HOST#TARGET %START A==ARRAY(BASEAD,F) %MONITOR %UNLESS OFFSET&1=0 I=OFFSET %WHILE L>0 %CYCLE J=A(I) A(I)=A(I!!1) A(I!!1)=J I=I+2; L=L-2 %REPEAT %FINISH %END %EXTERNALROUTINE FILL DTABREFS(%INTEGERNAME CURRINFRAL) !*********************************************************************** !* PLUGS REFENCES TO THE DIAG TABLES FOR CURRINF WHICH ARE * !* ABOUT TO BE GENERATED AT CAS(DAREA). THE LIST POPPED HAS * !* S1=AREA 1=CODE, DAREA FOR DIAGNOSTIC AREA * !* S2= THE OFFSET OF INSTRUCTION OR FORWARD POINTER * !* S3=THE WORD BEFORE FILLING - NOT USED FOR AREA 1 * !*********************************************************************** %INTEGER Q,JJ,KK %WHILE CURRINFRAL#0 %CYCLE POP(CURRINFRAL,Q,JJ,KK) %IF Q=1 %THEN %START PSETOPD(JJ,CAS(DAREA)) %FINISH %ELSE %START PD2(Q,JJ+2,CAS(DAREA)) ! THE PLUG ONLY ALLOWS 16 BIT OFFSET ! BUT TABLE FORM ALLOWS 18 BIT OFFSET ! EXTRA PLUG NEEDED IF >65K DIAGS %FINISH %REPEAT %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 * !*********************************************************************** %INTEGERFNSPEC JCODE(%INTEGER TFMASK) %ROUTINESPEC VMY %ROUTINESPEC REXP %ROUTINESPEC STARSTAR %ROUTINESPEC CIOCP(%INTEGER N) %INTEGERFNSPEC FINDREG(%INTEGER MASK) %INTEGERFNSPEC RLEVTOLEVEL(%INTEGER RLEV) %ROUTINESPEC CONSTEXP(%INTEGER PTYPE,REG,VALUE) %INTEGERFNSPEC LOAD(%RECORD(RD) %NAME OP) %INTEGERFNSPEC STRINGLBAD(%RECORD(TAGF)%NAME TCELL) %INTEGERFNSPEC RECORDELAD(%RECORD(TAGF)%NAME TCELL,%INTEGER SPTYPE,XTRA) %ROUTINESPEC INDLOAD(%INTEGER REG,SIZE) %ROUTINESPEC INDSTORE(%INTEGER REG,SIZE) %ROUTINESPEC LOADAD(%RECORD(RD) %NAME OPND) %ROUTINESPEC LOADPTR(%RECORD(RD) %NAME OPND,OPND2) %ROUTINESPEC DSTORE(%INTEGER REG,SIZE,LEVEL,DISP) %ROUTINESPEC SAVE IRS %ROUTINESPEC BOOT OUT(%INTEGER REG) %ROUTINESPEC DFETCH(%INTEGER REG,SIZE,LEVEL,DISP) %ROUTINESPEC DPTRFETCH(%INTEGER REG,SIZE,LEVEL,DISP) %ROUTINESPEC DFETCHAD(%INTEGER BA,SIZE,LEVEL,DISP) %ROUTINESPEC FETCH LOW AD END(%INTEGER REG,B,D) %ROUTINESPEC FETCH HIGH AD END(%INTEGER REG,B,D) %ROUTINESPEC STORE LOW AD END(%INTEGER REG,B,D) %ROUTINESPEC STORE HIGH AD END(%INTEGER REG,B,D) %INTEGERFNSPEC SET LEVELREG(%INTEGER WHICH,RLEV) %INTEGERFNSPEC FIND USE(%INTEGER MASK,USE,INF) %INTEGERFNSPEC SET DVREG(%INTEGER WHICH,DVBD) ! %RECORD(RD) %NAME OPND1,OPND2,OPND %RECORD(TRIPF) %NAME CURRT,WORKT %RECORD(LEVELF) %NAME LINF,CURRINF %RECORD(TAGF) %NAME TCELL %RECORD(LISTF) %NAME LCELL ! %INTEGER C,D,WTRIPNO,JJ,COMM,XTRA,PT,BFFLAG,TRIPINF,TRIPVAL,PTYPE,TYPE,PREC, STPTR,DPTYPE,DACC,L0,B1,B2,B3,LRES %REAL CV1 %LONGREAL CV2 ! ! TRIPDATA GIVES INFORMATION ON TRIPLE ! TOP 4 BITS HAVE TYPE ! NEXT 12 BITS HAVE FLAGS:- ! 2**16 SET IF COMMUTATIVE ! 2**17 SET DONT LOAD OPERAND2 ! 2**18 SET DONT LOAD OPERAND1 ! 2**19 DONT SWOP NON COMMUTABLE OPERANDS ! NEXT 8 BITS HAVE MAX CODE PLANTED IN BYTES NOT INCLUDING ANY CONSTANSTS ! OR STRINGS WHICH MAY HAVE TO GO INLINE ! BOTTOM 8 BITS HAVE A POINTER OR VALUE ! TYPE 0 TRIPLES ARE IGNORED ! TYPE 1 TRIPLES VALUE HAS INDEX INTO SWITCH "TRIPSW" ! TYPE 2 TRIPLES VALUE HAS POINTER TO ISEQS ! %CONSTINTEGERARRAY TRIPDATA(0:199)=0, X'1000070F'{RTHD ROUTINE/BKK HDR}, X'10001043'{RDSPLY MAKE DISPLAY}, X'10000410'{RDAREA INITIALISE DIAGS AREA}, X'10000511'{RDPTR RESET DIAGS PTR}, X'10000312'{RTBAD ERROR XIT FOR FN-MAP}, X'10000113'{RTXIT "%RETURN"}, X'10000314'{XSTOP "%STOP"}, 0(2), X'2000040A'{10 LOGICAL NOT}, X'2000040B'{11 LOGICAL NEGATE}, X'2000040C'{12 FLOAT}, X'2000040D'{13 MODULUS}, X'2000080E'{14 SHORTEN}, X'2000040F'{15 LENGTHEN}, X'20000610'{16 JAM SHORTEN}, X'10000000'{17 ERROR}, 0{18 NULL TRIPLE}, X'20000413'{19 PRELOAD}, X'10000001'{20 UNUSED}, X'10000303'{21 STORE STACKPOINTER}, X'10000002'{22 RESTORE STACK POINTER}, X'10000505'{23 ADVANCE STACK POINTER}, X'10000D04'{24 DECLARE ARRAY}, X'10000301'{25 UPDATE LINE NO}, X'10000906'{26 CHECK ZERO FOR STEP}, X'10000307'{27 FOR PREAMBLE}, X'10000208'{28 FOR POSTAMBLE}, X'1000010E'{29 FOR SECOND PREAMBLE}, X'10000218'{30 PRECALL}, X'10000519'{31 ROUTINE CALL}, X'1000021A'{32 RECOVER FN RESULT}, X'1000021B'{33 RECOVER MAP RESULT}, X'00000000'{34 NOT CURRENTLY USED}, X'1000081D'{35 GETAD GET 32BIT ADDREESS}, X'10000424'{36 RTOI1 INT FN}, X'10000C25'{37 RTOI2 INTPT FN}, X'10000B26'{38 STOI1 TOSTRING FN}, X'1000093D'{39 MNITR FOR %MONITOR}, X'00000000'{40 PPROF PRINT PROFILE IGNORED}, X'1000053F'{41 RTFP TURN RTNAME TO FORMAL}, X'00000000'{42 ON EVENT1 NO CODE AS YET}, X'00000000'{43 ON EVENT2 NO CODE AS YET}, X'10000846'{44 DVSTART FILL IN ELSIZE&ND}, X'10001047'{45 DVEND WORK OUT TOTSIZE ETC}, 0(4), X'10000132'{50 UCNOP}, X'10000133'{51 UCB1}, X'10000234'{52 UCB2}, X'10000335'{53 UCB3}, X'10000336'{54 UCW}, X'10000437'{55 UCBW}, 0(3), X'1000063B'{59 UCNAM U-C ACCESS TO NAMES}, 0(68), X'20010414'{128 +}, X'20000415'{129 -}, X'20010416'{130 !!}, X'20010417'{131 !}, X'20010418'{132 *}, X'20000419'{133 //}, X'2000041A'{134 /}, X'2001041B'{135 &}, X'2000041C'{136 >>}, X'2000041D'{137 <<}, X'200A0E1E'{138 **}, X'2001041F'{139 COMP}, X'20000420'{140 DCOMP}, X'200A0A21'{141 VMY}, X'20010422'{142 COMB}, X'200E0623'{143 ASSIGN=}, X'200E0624'{144 ASSIGN<-}, X'200A0E25'{145 ****}, X'20020926'{146 BASE ADJ}, X'20080527'{147 ARR INDEX}, X'20050428'{148 INDEXED FETCH}, X'200E0629'{149 LOCAL ASSIGN}, X'10000C09'{150 VALIDATE FOR}, X'10000B15'{151 PRE CONCAT}, X'10000A16'{152 COCNCATENEATION}, X'10000C17'{153 IOCP CALL}, X'10000C1C'{154 PARAMETER ASSIGNMENT 1 NORMAL VALUES}, X'1000041F'{155 PARAM ASSNG 2 NORMAL PTRS}, X'10000220'{156 PARAM ASSGN 3 ARRAYS}, X'10000220'{157 ASSGN FORMAL RT-CODE AS 156}, X'10000220'{158 PASS5 TYPE GENERAL NAME}, X'10000445'{159 PASS6 RESULT AREA FOR STR&REC FNS}, X'1000030A'{160 BACK JUMP}, X'1000030B'{161 FORWARD JUMP}, X'1000000C'{162 REMOVE LAB}, X'1000000D'{163 ENTER LABEL}, X'1000FF21'{164 DECLARE SWITCH}, X'10000022'{165 SET SWITCH LABEL TO CA}, X'10000523'{166 GOTO SWITCH LABEL}, X'10000D27'{167 STRING ASS1 GENERAL}, X'10001128'{168 STRING ASS 2 L KNOWN}, X'10000D29'{169 STRING JAM TRANSFER}, X'10000C2A'{170 ARRAY HEAD ASSIGNMENT}, X'10000C2B'{171 PTR ASSIGNMENT}, X'1000052C'{172 MAP RESULT ASSIGNMENT}, X'1000052D'{173 FN RESULT ASSIGNMENT}, X'10000C2E'{174 STRING COMPARISON}, X'10000C2E'{175 STRING DSIDED COMPARISON}, X'10000C2F'{176 PRE RESOLUTION 1}, X'10001230'{177 PRE RESOLUTION 2}, X'10000B31'{178 RESOLUTION PROPER}, X'1000233C'{179 RESOLUTION FINISH ASSN FRAGMNT}, X'00000000'{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'10000444'{186 INDEX STRING FOR CHARNO}, X'2002042A'{187 ZCOMP COMPARE W ZERO}, X'2002022B'{188 CONSTANT LOGICAL SHIFT}, X'2002022B'{189 COSNTANT ARITHMETIC SHIFT}, X'10001048'{190 DV BPAIR ENTER LB,UB &RANGE IN CORRECT FORM}, 0(*) %CONSTHALFINTEGERARRAY FCOMP(0:95)=0(2), ILT(2),IGT(2),INE(2),IEQ(2), ILE(2),IGE(2),0(2), 0(2), IGT(2),ILT(2),INE(2),IEQ(2), IGE(2),ILE(2),0(2), 0(2), IJGT(2),IJLT(2),IJNE(2),IJEQ(2), IJGE(2),IJLE(2),0(2), 0(2), IJLT(2),IJGT(2),IJNE(2),IJEQ(2), IJLE(2),IJGE(2),0(2), 0(2), RDLT(2),RDGT(2),RDNE(2),RDEQ(2), RDLE(2),RDGE(2),0(2), 0(2), RDGT(2),RDLT(2),RDNE(2),RDEQ(2), RDGE(2),RDLE(2),0(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*(2*NISEQS+10)-1)={FIRST 32 BIT INTEGER FORMS} %C 2,ILNOT,0,0 {10 32 BIT LOGICAL NOT}, 2,INEG,0,0 {11 32 BIT LOGICAL NEGATE}, 12,0,0,0 {12 32 BIT FLOAT TO 64 BIT REAL}, 9,0,8,0 {13 32 BIT MODULUS}, 10,0,0,0 {14 SHORTEN 32 BIT TO 16 BIT}, 1,0,0,109 {15 LENGTHEN 32 BIT TO 64 BIT}, 21,0,0,0 {16 SHORTEN 32 BIT FOR JAM}, 1,0,0,109 {17 COMPILER ERROR}, 7,0,0,0 {18 NOOP}, 7,0,0,0 {19 PRELOAD}, 2,IADD,0,0 {20 32 BIT ADDITION}, 2,ISUB,0,0 {21 32 BIT SUBTRACTION}, 2,IXOR,0,0 {22 32 BIT NONEQUIVALENCE}, 2,ILOR,0,0 {23 32 BIT LOGICAL OR}, 2,IMULT,0,0 {24 32 BIT MULTIPLY}, 2,IDIV,0,0 {25 32 BIT INTEGER DIVIDE}, 1,0,0,109 {26 32 BIT REAL DIVIDE}, 2,ILAND,0,0 {27 32 BIT AND}, 2,ISRLT,0,0 {28 32 BIT RIGTH SHIFT}, 2,ISLLT,0,0 {29 32 BIT LEFT SHIFT}, 1,0,0,109 {30 REAL EXP OPERATOR}, 13,0,0,0 {31 COMPARISONS}, 14,0,0,0 {32 FIRST PART OF DOUBLE COMPARISONS}, 15,0,0,0 {33 VMY}, 2,IADD,0,0 {34 COMBINE VMY RESULTS}, 16,0,0,0 {35 ASSIGN}, 16,0,0,0 {36 ASSIGN(<-)}, 17,1,2,20 {37 32 BIT INTEGER EXPONENTIATION}, 18,2,0,0 {38 BASE ADJUST ARRAY 32 BIT INDEX}, 19,2,0,0 {39 ARRAY INDEX 32 BIT INDEX}, 20,0,0,0 {40 INDEXED FETCH 32 BIT INDEX}, 23,0,0,0 {41 LASS}, 24,0,0,0 {42 ZCOMP COMPARISONS W ZERO}, 25,0,0,0 {43 SHIFT BY CONSTANT}, 7,0,0,0 {10 REAL LOGICAL NOT}, 5,RDNEG>>8,RDNEG&255,0 {11 REAL LOGICAL NEGATE}, 1,0,0,109 {12 FLOAT REAL COMPILER ERROR}, 11,0,8,0 {13 REAL MODULUS}, 5,RDCNVS>>8,RDCNVS&255,0 {14 SHORTEN REAL}, 5,RDCNVS>>8,RDCNVS&255,0 {15 LENGTHEN REAL TO 64 BIT}, 1,0,0,109 {16 SHORTEN REAL FOR JAM}, 1,0,0,109 {17 COMPILER ERROR}, 7,0,0,0 {18 NOOP}, 7,0,0,0 {19 PRELOAD}, 4,RDADD>>8,RDADD&255,0 {20 REAL ADDITION}, 4,RDSUB>>8,RDSUB&255,0 {21 REAL SUBTRACTION}, 7,0,0,0 {22 REAL NONEQUIVALENCE}, 7,0,0,0 {23 REAL LOGICAL OR}, 4,RDMULT>>8,RDMULT&255,0 {24 REAL MULTIPLY}, 7,0,0,0 {25 REAL INTEGER DIVIDE}, 4,RDDIV>>8,RDDIV&255,0 {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,2,21 {30 REAL EXP OPERATOR}, 13,0,0,0 {31 COMPARISONS}, 14,0,0,0 {32 FIRST PART OF DOUBLE COMPARISONS}, 7,0,0,0 {33 VMY}, 7,0,0,0 {34 COMBINE VMY RESULTS}, 16,0,0,0 {35 ASSIGN}, 16,0,0,0 {36 ASSIGN(<-)}, 7,0,0,0 {37 REAL INTEGER EXPONENTIATION}, 7,0,0,0 {38 BASE ADJUST ARRAY REAL INDEX}, 7,0,0,0 {39 ARRAY INDEX REAL INDEX}, 20,0,0,0 {40 INDEXED FETCH REAL INDEX}, 23,0,0,0 {41 LASS}, 24,0,0,0 {42 ZCOMP COMPARISON W ZERO}, 7,0,0,0 {43 SHIFT BY CNST ERROR}; %SWITCH SW(0:25),TRIPSW(0:72) ! CV1=0; CV2=0 CURRINF==WORKA_LEVELINF(CURRLEVEL) 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 CURRT==TRIPLES(STPTR) WTRIPNO=STPTR STPTR=CURRT_FLINK COMM=1 OPND1==CURRT_OPND1 OPND2==CURRT_OPND2 XTRA=CURRT_X1 JJ=CURRT_OPERN TRIPINF=TRIPDATA(JJ) C=TRIPINF>>28; ! TRIPLE TYPE TRIPVAL=TRIPINF&255 %IF C=0 %THENCONTINUE %IF C=1 %THEN ->TRIPSW(TRIPVAL) %IF TRIPINF&X'40000'=0 %START; ! OP1 NOT LOADED LRES=LOAD(OPND1) %IF JJ>=128 %AND CURRT_FLAGS&6=2 %AND OPND1_PTYPE&7#2 %AND %C OPND2_PTYPE&7#2 %START; ! OPERANDS REVERSED IN ESTACK %UNLESS TRIPINF&X'B0000'#0 %THEN EXCHANGE(OPND2,OPND1) %ELSE %C COMM=2 %FINISH %FINISH %IF OPND2_FLAG=REFTRIP %AND OPND2_D# CURRT_BLINK %C %AND CURRT_FLAGS&LOADOP2=0 %START %IF TRIPINF&X'F0000'=0 %THEN EXCHANGE(OPND2,OPND1) %ELSE COMM=2 ! I-RS THE WRONG WAY ROUND ! FOR NON COMMUTABLE OPS %FINISH %UNLESS JJ<128 %OR TRIPINF&X'20000'#0 %THEN %C LRES=LOAD(OPND2) PTYPE=OPND1_PTYPE&255; TYPE=PTYPE&7 %IF TYPE=2 %THEN C=4*(TRIPVAL+NISEQS) %ELSE C=4*TRIPVAL L0=ISEQS(C); B1=ISEQS(C+1) B2=ISEQS(C+2); B3=ISEQS(C+3) ->SW(L0) SW(1): ! ERROR CONDITION TRIPSW(0): FAULT(B3,0,0) %UNLESS TYPE=7 TRIPSW(*): PI(NULL); ! USEFUL IN DEBUGGING TO HAVE ! ERROR POSITION PINPOINTED ->STRES SW(2): ! PLANT ONE BYTE PI(B1) OPND1_FLAG=9; ! PREVENT RELOAD IF THIS IS LAST ->STRES SW(6): ! PLANT 2 BYTES & SET PTYPE OPND1_PTYPE=B3 SW(3): ! PLANT 2 BYTES PI1(B1,B2) OPND1_FLAG=9; ! PREVENT RELOAD IF THIS IS LAST ->STRES SW(4): ! PLANT REAL OPERATION D=B1<<8!B2 %IF CURRT_OPTYPE=X'52' %THEN D=D+8;! USE SHORT OPCODE FORM PI2(D,(OPND1_XB-FR0)&3,(OPND2_XB-FR0)&3) %UNLESS OPND1_XB=OPND2_XB %THEN REGS(OPND2_XB)_CL=0 OPND1_FLAG=9; ! PREVENT RELOAD IF THIS IS LAST ->STRES SW(5): ! REAL UNARY OPERATION D=B1<<8!B2 %IF CURRT_OPTYPE=X'52' %THEN D=D+8 C=OPND1_XB-FR0 PI2(D,C,C) OPND1_FLAG=9 ->STRES SW(7): ! NULL OPERATION ->STRES SUSE: ->STRES SW(9): ! INTEGER MODULUS P2I(DUPL,CI0) PJUMP(IJGE,GLABEL) PI(INEG) PLABEL(GLABEL) GLABEL=GLABEL+1 ->SUSE SW(10): ! SHORTEN INTEGER TO BYTE %IF PARM_OPT#0 %START %UNLESS CURRT_CNT=1 %AND TRIPLES(CURRT_PUSE)_OPERN=SHRTN %START PI(DUPL) %IF CURRT_OPTYPE>X'31' %THEN D=X'FFFF' %ELSE D=255 PLOADCONST(D) PI(ULE) PPJ(JFALSE,9) %FINISH %FINISH OPND1_PTYPE=OPND1_PTYPE-X'10' ->SUSE SW(11): ! REAL MODULUS (DIFFICULT) D=FINDREG(FRN) REGS(D)_USE=0; ! FORGET PREVIOUS USE PLOADCONST(0) %IF PTYPE>>4&7=6 %THEN %START B1=RDFLOAT; B2=RDGE; B3=RDNEG %FINISH %ELSE %START B1=RSFLOAT; B2=RSGE; B3=RSNEG %FINISH PI1(B1,D-FR0) PI2(B2,OPND1_XB-FR0,D-FR0) PJUMP(JTRUE,GLABEL) PI2(B3,OPND1_XB-FR0,OPND1_XB-FR0) PLABEL(GLABEL) GLABEL=GLABEL+1 ->SUSE SW(12): ! FLOAT D=FINDREG(FRN) PI1(RDFLOAT,D-FR0) OPND1_PTYPE=X'62' OPND1_XB=D REGS(D)_CL=1 REGS(D)_AT=WTRIPNO REGS(D)_LINK=WTRIPNO ->SUSE SW(21): ! SHORTEN FOR JAM TRANSFER ! NO CODE NEEDED ON PNX OPND1_PTYPE=OPND1_PTYPE-X'10' ->SUSE SW(22): ! EXP IN REAL EXPRSN %IF OPND2_PTYPE&7=1 %THENSTART %IF OPND2_FLAG<=1 %AND 2<=OPND2_D<=255 %THEN %C CONSTEXP(OPND1_PTYPE&255,OPND1_XB,OPND2_D) %ELSE ->PCALL ->SUSE %FINISH ! REAL**REAL BY SUBROUTINE REXP; ->SUSE SW(17): ! EXP IN INTEGER CONTEXT %IF OPND2_FLAG<=1 %AND 2<=OPND2_D<=63 %THEN %C CONSTEXP(OPND1_PTYPE&255,OPND1_XB,OPND2_D) %AND ->STRES PCALL: ! CALL SUBROUTINE AS DEFINED ! IN CODE TABLE LRES=LOAD(OPND2) %IF CURRT_OPTYPE&7=1 %THEN %START;! INTEGERS %IF CURRT_FLAGS&LOADOP1#0 %AND LRES=0 %THEN PI(EXCH) PPJ(0,B3); ! CALL ROUTINE %FINISH %ELSE %START STARSTAR; ! PLANT COMPLEX IN LINE ROUTINE %FINISH ->SUSE SW(14): ! DSIDED COMPARISONS ! COPY MIDDLE OPERAND(SIZE IN TABLE) %IF TYPE=1 %THEN %START GET WSP(D,2) DSTORE(ESTK,4,CURRINF_RBASE,D) OPND2_FLAG=7; OPND2_D=CURRINF_RBASE<<16!D CURRT_FLAGS=CURRT_FLAGS!NOTINREG;! STORE COPY TO BE USED %FINISH; ! PDS THINKS REALS CAN BE LEFT IN REG SW(13): ! COMPARISONS BFFLAG=COMM-1; ! NOTE BACKWARDS OR FORWARDS C=XTRA&15+16*BFFLAG %IF TYPE=2 %THEN C=C+64; ! FLOATING COMPARATORS C=FCOMP(C) COMM=2 %IF CURRT_OPTYPE=X'51' %START WORKT==TRIPLES(CURRT_FLINK); ! ON TO FOLLOWING TRIPLE %IF WORKT_OPERN=FJUMP %OR WORKT_OPERN=BJUMP %THEN %C WORKT_X1=WORKT_X1!X'40' %AND CURRT_OPND1=OPND2 %AND ->STRES %FINISH %IF TYPE=1 %THEN PI(C) %ELSE %START %IF CURRT_OPTYPE=X'52' %THEN C=C+8;! USE 16BIT FORMS PI2(C,OPND2_XB-FR0,OPND1_XB-FR0) REGS(OPND1_XB)_CL=0 REGS(OPND2_XB)_LINK=WTRIPNO;! WILL BE "RESULT" %FINISH CURRT_OPND1=OPND2; ! OPND2 IS RESULT ->STRES; ! 2ND OPERAND MAY BE NEEDED IN SW(15): ! SPECIAL MH FOR ARRAY ACCESS C=OPND2_D>>24; ! CURRENT DIMENSION D=OPND2_D>>16&31; ! TOTAL NO OF DIMENSIONS VMY ->STRES SW(18): ! BASE ADJUST ARRAY INDEX DPTYPE=XTRA>>16 %UNLESS PARM_COMPILER#0 %OR DPTYPE&X'300'=X'200' %START D=OPND2_D&X'FFFF' %IF D>0 %START; ! DV KNOWN C=CTABLE(D) PLOADCONST(C) %FINISHELSESTART C=FIND USE(BRN,15,OPND2_XTRA) %IF C>0 %START PI1(LRO0-BR0+C,0); ! BASE OFFSET FROM DV %FINISH %ELSE %START %IF OPND2_XTRA>>16=0 %THEN %C PFIXI(LGPO,2,OPND2_XTRA&X'FFFF') %ELSE %C DPTRFETCH(ESTK,4,OPND2_XTRA>>16,OPND2_XTRA&X'FFFF'+4) %FINISH %FINISH PI(IADD) %FINISH ->STRES SW(19): ! ARRAY INDEX DACC=XTRA>>20 %IF DACC>0 %START; ! NORMAL CASE EL SIZE KNOWN %IF (COMM=2 %AND DACC>2) %OR (COMM=1 %AND DACC=1) %THEN PI(EXCH) %IF DACC=1 %THEN PI(INDINT) %C %ELSE %IF DACC=2 %THEN PI(IADD) %C %ELSE %IF DACC=4 %THEN PI(INDINT) %C %ELSE %IF DACC<=510 %THEN PI1(INDEX,(DACC+1)>>1) %C %ELSE PLOADCONST((DACC+1)>>1) %AND P2I(IMULT,IADD) %FINISH %ELSE %START; ! RARE CASE GO TO DV FOR SIZE ! ONLY FOR ACCESS OF STRING&RECORD ! ARRAYNAMES %IF COMM=2 %THEN PI(EXCH) D=SET DVREG(-1,XTRA); ! BR TO START OF DV PI1(LROA0-BR0+D,6) P4I(LHI,IMULT,CVIA,IADD) %FINISH ->STRES SW(20): ! INDEXED FETCH %IF TYPE#2 %THEN D=ESTK %ELSE D=FINDREG(FRN) INDLOAD(D,BYTES(PTYPE>>4&7)) OPND1_PTYPE=OPND1_PTYPE&255 OPND1_FLAG=9 OPND1_XB=D %IF D#ESTK %THEN REGS(D)_CL=1 %AND REGS(D)_AT=WTRIPNO %C %AND REGS(D)_LINK=WTRIPNO ->STRES SW(16): ! ASSIGN(=) ! ASSIGN(<-) PT=XTRA&255; ! ORIGINAL PT OF LHS HERE %IF PT=0 %THEN PT=CURRT_OPTYPE %IF OPND1_FLAG=2 %START; ! OPERAND A NAME LRES=LOAD(OPND2) TCELL==ASLIST(TAGS(OPND1_D)) %IF TCELL_PTYPE&X'3FFF'=X'33' %THEN %C D=RECORDELAD(TCELL,PT,OPND1_XTRA) %ELSE D=TCELL_SLINK DSTORE(OPND2_XB,BYTES(PT>>4),TCELL_UIOJ>>4&15,D) %FINISHELSESTART; ! OPERAND A POINTER %IF OPND1_FLAG=INDNAME %START; ! POINTER NOT LOADED LRES=LOAD(OPND2) LOADPTR(OPND1,OPND1) %FINISH %ELSE %START LOADPTR(OPND1,OPND1) LRES=LOAD(OPND2) %IF TYPE#2 %AND LRES>0 %THEN PI(EXCH) %FINISH INDSTORE(OPND2_XB,BYTES(PT>>4)) %FINISH %IF OPND2_XB<=FR3 %THEN REGS(OPND2_XB)_CL=0 ->STRES SW(23): ! LOCAL ASSIGNMENT D=BYTES(PTYPE>>4&15) LRES=LOAD(OPND2) DSTORE(OPND2_XB,D,OPND1_D>>16,OPND1_D&X'FFFF') OPND1_FLAG=7; OPND1_XB=OPND2_XB;! IN CASE USED AGAIN %IF CURRT_DPTH>0 %AND CURRT_CNT=0 %THEN ERASE((D+3)>>2) %FOR D=BR0,1,FR3 %CYCLE %IF REGS(D)_INF1=OPND1_D %THEN FORGET(D) %REPEAT ->STRES SW(24): ! COMPARE WITH ZERO (OPND2=0) WORKT==TRIPLES(CURRT_FLINK); ! NEXT OR JUMP TRIPLE D=WORKT_X1; ! IBM TYPE JUMP MASK %IF TYPE=1 %START; ! INTEGERS %IF D=8 %OR D=X'87' %THEN WORKT_X1=D!! X'8F' %FINISH %ELSE %START C=OPND1_XB %IF CURRT_OPTYPE=X'52' %THEN B1=RSTEST %ELSE B1=RDTEST PI1(B1,C-FR0) REGS(C)_CL=0 %IF XTRA&X'F'#7 %THEN WORKT_X1=D!!X'8F' %FINISH ->STRES SW(25): ! SHIFT BY CONSTANT D=OPND2_D %IF CURRT_OPERN=CASHIFT %AND D=-1 %THEN PI(CVIA) %ELSE %C %IF D>0 %OR CURRT_OPERN=CLSHIFT %THEN PI1(ISHL,D) %C %ELSE PI1(ISRA,-D) %CONTINUE TRIPSW(1): ! SET LINE NO PLINESTART(OPND1_D>>16) %IF PARM_LINE#0 %START PLOADCONST(OPND1_D>>16) DSTORE(ESTK,2,CURRINF_RBASE,OPND1_D&X'FFFF') %FINISH %CONTINUE TRIPSW(3): ! SAVE STACK POINTER ! OPND1 IS TEMPORARY(16 BITS) FOR SAVE PI(SFA) DSTORE(ESTK,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' PLOADCONST(OPND1_D) DSTORE(ESTK,4,CURRINF_RBASE,D-4) %CONTINUE TRIPSW(71): ! END OF DOPE VECTOR ! OPND1_D=DVF<<16!ELSIZE ! OPND1_XTRA=PTYPE ! XTRA=ND<<16!DVDISP D=OPND1_D&X'FFFF'; ! ELSIZE %IF D=1 %START; ! BYTES P2I(CI1,IADD) PI1(ISHL,-1) %FINISH %ELSE %IF D>2 %START PLOADCONST(D>>1) PI(IMULT) %FINISH DSTORE(ESTK,4,CURRINF_RBASE,XTRA&X'FFFF'-8) ! 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 %IF C=0 %THEN PLOADCONST(0) %ELSE %START B1=0 %FOR JJ=1,1,XTRA>>16 %CYCLE %IF C&(1<1 %THEN %START DFETCH(ESTK,4,CURRINF_RBASE,D-12*JJ+4) PI(IMULT) %FINISH %IF B1>0 %THEN PI(IADD) B1=B1+1; ! COUNT PRODUCTS %FINISH %REPEAT PI(INEG) %FINISH DSTORE(ESTK,4,CURRINF_RBASE,D) %CONTINUE TRIPSW(72): ! DV BOUND PAIR ! OPND1&2 ARE LB & UB RESPECTIVLY ! XTRA=CURRD<<24!ND<<16!DVDISP D=XTRA&X'FFFF'-12*(XTRA>>24); ! TRIPLE POSN %IF OPND1_FLAG=SCONST %START; ! LB A CONST PLOADCONST(OPND1_D) DSTORE(ESTK,4,CURRINF_RBASE,D-4) LRES=LOAD(OPND2) %IF LRES=0 %THEN PI(DISCARD) DSTORE(ESTK,4,CURRINF_RBASE,D) %IF OPND1_D#1 %THEN PLOADCONST(OPND1_D-1) %AND PI(ISUB) %FINISH %ELSE %START LRES=LOAD(OPND1)<<1!LOAD(OPND2) %IF LRES=B'10' %THEN PI(EXCH) DSTORE(ESTK,4,CURRINF_RBASE,D) PI(EXCH) DSTORE(ESTK,4,CURRINF_RBASE,D-4) P3I(ISUB,CI1,IADD) %FINISH C=XTRA>>24&255; ! CURRENT DIMENSION %IF C>1 %START; ! MULTPLY UP BY LOWER RNAGES DFETCH(ESTK,4,CURRINF_RBASE,D+4) PI(IMULT) %FINISH DSTORE(ESTK,4,CURRINF_RBASE,D-8) %CONTINUE TRIPSW(4): ! DECLARE ARRAY ! OPND1_D=CDV<<31!C<<24!D<<16!DVDISP ! OPND1_XTRA HAS DICT ENTRY NO TCELL==ASLIST(TAGS(OPND1_XTRA)) C=OPND1_D>>24&127 D=OPND1_D>>16&255 ! NO OPTIMISING OF MULTIPLE DECS YET ! HENCE C & D NOT USED %IF OPND1_D>0 %START; ! DYNAMIC DOPE VECTOR DFETCHAD(NO,4,CURRINF_RBASE,OPND1_D&X'FFFF') %FINISHELSESTART; ! DV IN SHAREABLE SYMBOL TABLES PFIXI(LGA,10,OPND1_D&X'FFFF') %FINISH DSTORE(ESTK,4,CURRINF_RBASE,TCELL_SLINK+4) %IF TRIPLES(STPTR)_OPERN=ASPTR %START;! IF ARRAY NOT FORMAT %IF OPND1_D<0 %START; ! ARRAY SIZE KNOWN C=CTABLE((OPND1_D&X'FFFF')>>2+2) C=(C+3)&(-4); ! TO 64 BIT BNDRY PI1(ASFW,-64000) %AND C=C-32000 %WHILE C>32000 PI1(ASFW,-2*C); ! C IN 16BIT WORDS %FINISH %ELSE %START; ! DYNAMIC NEEDS LOOP ! DFETCH(ESTK,4,CURRINF_RBASE,OPND1_D&X'FFFF'-8) P2I(CI3,IADD) PLOADCONST(-4) P3I(ILAND,INEG,ASFT) %FINISH %FINISH PI(SFA); ! STACK FRONT ADDRESS=BASE ADDRESS DSTORE(ESTK,4,CURRINF_RBASE,TCELL_SLINK) %CONTINUE TRIPSW(5): ! CLAIM ARRAY SPACE ! OPND1_D=CDV<<31!SNDISP!DVDISP ! NOT NEEDED ON PNX AS THIS MUST ! BE DONE DURING DECLN(SEE ABOVE) %CONTINUE TRIPSW(6): ! CHECK FOR ZERO FOR STEP LRES=LOAD(OPND1); ! STEP TO ESTACK PPJ(JFALSE,11); ! USING ZERO=FALSE EQUIVALENCE %CONTINUE TRIPSW(7): ! FOR PREAMBLE LRES=LOAD(OPND1); ! FORCE INITIAL TO ESTACK %CONTINUE TRIPSW(8): ! FOR POSTAMBLE %CONTINUE TRIPSW(9): ! VALIDATE FOR LRES=LOAD(OPND1) LRES=LOAD(OPND2) PI(IREM) PPJ(JTRUE,11); ! USING ZERO=FALSE EQIVALENCE %CONTINUE TRIPSW(10): ! BACK JUMP _X1 HAS TF&MASK ! OPND1_XTRA HAS LABEL CELL LCELL==ASLIST(OPND1_XTRA) D=CURRT_X1; ! THE MASK PJUMP(JCODE(D),OPND1_D&X'FFFF') %CONTINUE TRIPSW(11): ! FORWARD JUMP _X1 HAS TF&MASK ! OPND1_XTRA HAS LABEL CELL<<16!JUMP CELL LCELL==ASLIST(OPND1_XTRA>>16) C=JCODE(CURRT_X1) PJUMP(C,OPND1_D&X'FFFF') D=OPND1_D>>24; ! ENTER JUMP FLAGS %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 PDISCARDLABEL(OPND1_D) %END %CONTINUE TRIPSW(13): ! INSERT LABEL ! OPND1_XTRA HAS LABEL CELL LCELL==ASLIST(OPND1_XTRA) D=LCELL_S2&X'FFFF'; ! JUMP LIST REDUNDANT ON PNX %WHILE D#0 %CYCLE; ! FILL FORWARD REFS POP(D,B1,B2,B3); ! B2=1 IF SHORT JUMP PLANTED %REPEAT PLABEL(OPND1_D&X'FFFF') D=OPND1_D>>24; ! ENVIRONMENT MANIPULATION FLAGS %IF D&2=0 %THEN FORGET(-1) %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 PI(DUPL) OPND1_XB=ESTK; OPND1_FLAG=9 %CONTINUE TRIPSW(15): ! RT HEADING OPND1_D=RTNAME ! OPND1_XTRA=AXNAME #0 IF AN ENTRY %BEGIN %INTEGER H H=0 CURRINF_ENTRYAD=GLABEL; ! FOR RETURN=JUMP TO END GLABEL=GLABEL+1 %IF OPND1_D>=0 %THEN %START C=0 TCELL==ASLIST(TAGS(OPND1_D)) H=TCELL_SNDISP %FINISH %ELSE C=1 %IF H=0 %THEN H=-1 %IF OPND1_XTRA#0 %THEN PPROC(STRING(OPND1_XTRA),C<<31!1,H) %ELSE %C %IF OPND1_D>=0 %THEN%C PPROC(STRING(ADDR(WORKA_LETT(WORKA_WORD(OPND1_D)))),0,H) %IF OPND1_D>=0 %THEN TCELL_SNDISP=H %END %CONTINUE TRIPSW(67): ! RDISPLY CREATE DISPLAY FORGET(-1) D=CURRINF_RBASE %IF D>1 %START; ! SOME DISPLAY TO COPY PLOADCONST(2*D) PI(ISUB) PI1(LAS,-4*D) PLOADCONST(2*D) PI(MVWD) %FINISH %ELSE %START; ! SET GLAPTR IN EXTERNALS PFIXI(LGA,2,0) PI1(ISL,-4*D) %FINISH PI1(LAS,0); ! CURRENT LNB PI1(ISL,-4*D-4) %CONTINUE TRIPSW(16): ! RDAREA - INITIALISE DAIGS AREA ! OPND1_D=N FOR DIAGS AREA PFIXI(LGI,2,32); ! PICK UP M'IDIA' DSTORE(ESTK,4,CURRINF_RBASE,OPND1_D) %CONTINUE TRIPSW(17): ! RDPTR SET DAIGS POINTER ! OPND1_D=LEVEL NOT CURRINF ALWAYS LINF==WORKA_LEVELINF(OPND1_D) D=PMARKER PLOADCONST(X'7F7F'); ! 7F7F ARBITARY & WILL BE OVERWRITTEN ! BUT <16BITS OPTIMISED ! PUSH(LINF_RAL,1,D,0); ! TO OVERWRITE LATER DSTORE(ESTK,2,LINF_RBASE,LINF_DIAGINF) %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(JUMP,10) %CONTINUE TRIPSW(19): ! RTXIT - "%RETURN" %IF OPND1_D=0 %START; ! JUMP TO END FOR RETURNS PROTEM ! TILL REGISTER RESTORING SOLVED PJUMP(JUMP,CURRINF_ENTRYAD) %FINISH %ELSE %START PLABEL(CURRINF_ENTRYAD); ! ENTRAD HOLDS LAB FOR RETURN PI(RETURN) PPROCEND(CURRINF_SNMAX-CURRINF_DISPLAY) FORGET(-1) %FINISH %CONTINUE TRIPSW(20): ! XSTOP - "%STOP" CALL STOP %IF OPND1_D#0 %THEN PPROCEND(CURRINF_SNMAX-CURRINF_DISPLAY) %CONTINUE TRIPSW(61): ! %MONITOR P2I(CI0,CI0) PPJ(0,2) %CONTINUE !*********************************************************************** !* SECTION FOR STRING CONCATENATION AND ASSIGNMENT * !*********************************************************************** TRIPSW(21): ! PRECONCAT ! OPND1 IS WORK AREA ! OPND2 HAS FIRST STRING LRES=LOAD(OPND2); ! 32 BIT AD OF STRING2 P3I(DUPL,LHI,MASKC) LRES=LOAD(OPND1) P3I(EXCH,CI2,IADD) P2I(CVIA,MVWD) OPND1_FLAG=7; ! RESULT IS LOCAL %CONTINUE TRIPSW(22): ! CONCATENATE OPND1 WORK AREA ! OPND2 THE NEXT BIT OPND1=TRIPLES(OPND1_D)_OPND1 %WHILE OPND1_FLAG=REFTRIP LRES=LOAD(OPND2) D=FPPTR %IF D&7#0 %THEN PI(ALIGN) %AND FPPTR=FPPTR+4 PI(IPUSH) LRES=LOAD(OPND1) PI(IPUSH) PPJ(0,24) %IF D=FPPTR %THEN PI1(ASFW,8) %ELSE PI1(ASFW,12) %AND FPPTR=D OPND1_FLAG=7; ! RESULT IS LOCAL %CONTINUE TRIPSW(39): ! GENERAL STRING ASSIGN LRES=LOAD(OPND1); ! PTR (2 WORDS) TO LHS %IF OPND2_FLAG=LCONST %THEN %START; ! CONST STRING ASSN %IF OPND2_XTRA=0 %START; ! CONST IS NULL P4I(DISCARD,CI0,EXCH,ASSH) %FINISH %ELSE %START %IF PARM_OPT#0 %THEN PI(EXCH) %ELSE PI(DISCARD) LRES=LOAD(OPND2) PI(EXCH) PLOADCONST((OPND2_XTRA+2)>>1) PI(MVWD) %IF PARM_OPT#0 %START PLOADCONST((OPND2_XTRA+2)>>1) PI(ILE) PPJ(JFALSE,9) %FINISH %FINISH %FINISHELSESTART D=FINDREG(BRN) REGS(D)_USE=0 %IF PARM_OPT#0 %THEN PI(EXCH) %ELSE PI(DISCARD) ! MAX LEN TO BTM FOR CHK OR DISCARDED PI(CVBA) LRES=LOAD(OPND2) PI(CVBA) PI(SR0-BR0+D); ! SOURCE BYTE ADDRE TO REG PI(EXCH); ! DEST OVER SOURCE FOR MVB PI(LR0-BR0+D); ! FURTHER COPY OF SOURCE P3I(LBI,CI1,IADD); ! ASSIGN PI(MVB) %IF PARM_OPT#0 %START; ! CHECK LENGTH PI(LR0-BR0+D) PI(LBI); ! CURRENT LENGTN = BYTE1 OF DEST PI(ILE) PPJ(JFALSE,9) %FINISH %FINISH %CONTINUE TRIPSW(40): ! SIMPLE STRING ASSIGN ! LHS A SIMPLE STRING TCELL==ASLIST(TAGS(OPND1_D)) %IF OPND2_FLAG=LCONST %AND OPND2_XTRA>4&15,D&X'FFFF') PI(ASSH) %FINISHELSESTART; ! ASSIGN CONSTANT STRING LRES=LOAD(OPND2) LRES=LOAD(OPND1) PLOADCONST((OPND2_XTRA+2)>>1) PI(MVWD) %FINISH %CONTINUE %FINISH D=FINDREG(BRN) REGS(D)_USE=0 LRES=LOAD(OPND2) PI(SR0-BR0+D) LRES=LOAD(OPND1) P3I(LR0-BR0+D,LHI,MASKC); ! LENGTH OF RHS %IF PARM_OPT#0 %START PI(DUPL) PLOADCONST(TCELL_ACC-1); ! LMAX PI(IGE) PPJ(JFALSE,9) %FINISH P3I(CI2,IADD,CVIA) PI(MVWD) %CONTINUE TRIPSW(41): ! STRING JT VIA SUBROUTINE LRES=LOAD(OPND1); ! SET BY GETPTR (IE LOADED) LRES=LRES<<1!LOAD(OPND2); ! MAY OR MAY NOT NEED LOADING %IF LRES=B'10' %THEN P4I(IPUSH,EXCH,IPOP,EXCH) P2I(IPUSH,IPUSH) P2I(IPUSH,ALIGN) PPJ(0,18) PI1(ASFW,16) %CONTINUE TRIPSW(46): ! STRING COMPARISONS INCL DSIDED BFFLAG=0 %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 %IF CURRT_FLAGS&LOADOP2#0 %START; ! OPND2 NOT LOADED LRES=LOAD(OPND1) LRES=LOAD(OPND2) %FINISHELSEIF CURRT_FLAGS&LOADOP1=0 %START; ! BOTH LOADED %FINISHELSESTART; ! ONLY 2 LDED BACK COMP BFFLAG=1 LRES=LOAD(OPND1) %FINISH PPJ(0,28) D=FCOMP(CURRT_X1+16*BFFLAG) PI(D) %CONTINUE NULLSC: ! TEST FOR A NULL STRING LRES=LOAD(OPND) P4I(CVBA,LBI,CI0,FCOMP(CURRT_X1+16*BFFLAG)) %CONTINUE TRIPSW(47): ! PRE RESOLUTION 1 ! OPND1 IS 4 WORD WK AREA ! OPND2 IS STRING BEING RESLVD ! IN PNX WORK AREA IS USED AS FOLLOWS ! W1 WORD ADDRESS OF STRING BEING RESOLVED ! W2 ORIGINAL LENGTH! BYTES USED<<16 ! W3&4 WORKSPACE D=OPND1_D&X'FFFF' LRES=LOAD(OPND2); ! 32 BIT ADDRESS TO ESTACK DSTORE(ESTK,4,CURRINF_RBASE,D); ! 32 BIT ADDR TO WK AREA P2I(CVBA,LBI) DSTORE(ESTK,4,CURRINF_RBASE,D+4); ! WHOLE LENGTH STILL AVAILABLE ! 0 BYTES USED UP SO FAR %CONTINUE TRIPSW(48): ! PRE RESOLUTION 2 ! OPND1 IS 4 WORD WK AREA ! OPND2 IS POINTER TO STRING TO HOLD ! FRAGMENT OR ZERO(=DISCARD FRGMNT) D=OPND1_D&X'FFFF' DFETCHAD(NO,4,CURRINF_RBASE,D+4) DFETCH(ESTK,4,CURRINF_RBASE,D) PI(IPUSH); ! RESLN STRING ADDR STACKED PI(IPUSH); ! POINTER TO BYTES USED IS STCKD %IF OPND2_FLAG=SCONST %START; ! NO STRING FOR FRAGMENT P2I(CI0,CI0); ! TWO ZERO WORD %FINISHELSE LRES=LOAD(OPND2); ! OR 2 POINTER WORDS P2I(IPUSH,IPUSH); ! ARE STACKED %CONTINUE TRIPSW(49): ! RESOLUTION ! OPND1 IS STRING RES EXPR ! OPND2 IS LABEL NO LRES=LOAD(OPND1) P2I(IPUSH,ALIGN) PPJ(0,16) PI1(ASFW,24); ! RECLAIM PARM SPACE %IF OPND2_D=0 %THEN PPJ(JFALSE,12); ! UNCONDITIONAL FAILS %CONTINUE TRIPSW(60): ! RESFN FINAL POST RES ASSIGN ! OPND2 HAS POINTER ! SINCE RESOLVED STRING MAY BE CONST ! CAN NOT USE NORMAL ASSIGN LRES=LOAD(OPND2); ! POINTER TO NEST D=OPND1_D&X'FFFF'; ! TO 4 WORD WK AREA C=FINDREG(BRN); ! TEMP REG FOR WORKSPACE REGS(C)_USE=0; ! FORGET PREVIOUS USE %IF PARM_OPT#0 %THEN PI(EXCH) %ELSE PI(DISCARD) ! MAX LEN TO BTM FOR CHK OR DISCARDED P2I(CVBA,DUPL); ! DEST(TWICE) OVER LMAX DFETCH(ESTK,4,CURRINF_RBASE,D) PI(CVBA) DFETCH(ESTK,4,CURRINF_RBASE,D+4) PI1(ISHL,-16); ! BYTES USED P3I(SR0-BR0+C,IADD,EXCH); ! SOURCE UNDER DEST BUT OVER LMAX DFETCH(ESTK,4,CURRINF_RBASE,D+4);! BYTESUSED<<16! ORIGINAL BYTES P2I(MASKS,LR0-BR0+C); ! FETCH BACK BYTES USED PI(ISUB); ! LENGTH OF FINAL STRING PI(SR0-BR0+C); ! TO TEMP P2I(CI1,IADD) PPJ(0,1); ! CALL MOVE OVERLAPPING P3I(LR0-BR0+C,EXCH,ASSB); ! STORE LENGTH WITH SECOND COPY OF DEST %IF PARM_OPT#0 %START; ! CHECK CAPACITY PI(ILE); ! COMPARED WITH ORIGINAL LMAX PPJ(JFALSE,9); ! CAPACITY EXCEEDED %FINISH %CONTINUE TRIPSW(68): ! SINDX INDEX STRING FOR CHARNO ! ON ALL M-CS WITH CONSISTENT BYTE ADDRESSING ! THIS CAN ROUTED WITH AINDX. SPECIAL ! CODE NEEDED ON PNX HOWEVER LRES=LOAD(OPND1); ! THE "GOT ADDR" OF STRING %IF CURRT_FLAGS&LOADOP2#0 %START;! OFFSET NEDS LOADING PI(CVBA) %UNLESS OPND2_FLAG=SCONST %AND OPND2_D=0 %START;! LENGTH = 0 OFFSET LRES=LOAD(OPND2) PI(IADD) %FINISH %FINISH %ELSE P3I(EXCH,CVBA,IADD) %CONTINUE !*********************************************************************** !* THIS NEXT SECTION DEALS WITH ROUTINE CALLS AND PARAMETER * !* PASSING. ALSO STORING AND RECOVERY OF FN & MAP RESULTS * !*********************************************************************** TRIPSW(23): ! IOCP CALL LRES=LOAD(OPND2) CIOCP(OPND1_D); ! ALWAYS CONSTANTS OPND1_FLAG=9; ! FOR WHEN RES NEEDED OPND1_XB=ESTK FORGET(-1) %CONTINUE TRIPSW(24): ! PRECALL OPND1 HAS RT NAME TCELL==ASLIST(TAGS(OPND1_D)) D=TCELL_SLINK %IF D#0 %THEN D=ASLIST(D)_SNDISP;! FIRST PARAM OFFSET PTYPE=TCELL_PTYPE SAVE IRS C=(CURRT_DPTH+1)>>1; ! DEPTH IN PAIRS PUSH(FPHEAD,FPPTR,C,0) PI(ALIGN) %IF FPPTR&7#0 PI1(ESAVE,C) %UNLESS C=0 FPPTR=0 %IF D#0 %THEN PI(ALIGN) %AND FPPTR=FPPTR+4 %CONTINUE TRIPSW(25): ! ROUTINE CALL (AFTER PARAMS) ! OPND1 HAS RT NAME TCELL==ASLIST(TAGS(OPND1_D)) %IF FPPTR&7#0 %AND PARM_FAULTY=0 %THEN IMPABORT %IF TCELL_UIOJ&15=14 %START; ! EXTERNAL CALL PI1(CALL,TCELL_SNDISP) %FINISHELSEIF TCELL_PTYPE&X'400'#0 %START DFETCH(ESTK,8,TCELL_UIOJ>>4&15,TCELL_SNDISP) PI(CALLT); ! CALL FORMAL PROCEDURE %FINISHELSE %START C=TCELL_UIOJ>>4&15 %IF C>0 %THEN PI1(ILL,-4*(C+1));! DISPLAY PTR FOR INTERNAL RTS D=TCELL_SNDISP %IF D=0 %THEN D=P NEXT SYMBOL %AND TCELL_SNDISP=D PI1(CALL,D) %FINISH PI1(ASFW,FPPTR) %UNLESS FPPTR=0 POP(FPHEAD,FPPTR,C,D) D=TCELL_PTYPE&X'80F'; ! MAP & TYPE BITS %IF C#0 %START; ! ESTACK WAS SAVED %IF C=5 %THEN PI1(RESE,C) %ELSE PI1(ERES,C) %FINISH %IF FPPTR&7#0 %THEN PI1(ASFW,4);! ALIGN WAS DONE AT PRECALL FORGET(-1) %CONTINUE TRIPSW(44): ! MAP RESULT ASSIGNMENT ! CALLED BEFORE RETURN TO CALLER RES: LRES=LOAD(OPND2) %CONTINUE TRIPSW(45): ! FN RESULT ASSIGNMENT ! CALLED BEFORE RETURN TO CALLER %IF OPND2_PTYPE&7=5 %START; ! STRING FN RESULTS LRES=LOAD(OPND2) P3I(DUPL,LHI,MASKC) P2I(ILP2,EXCH) P4I(CI2,IADD,CVIA,MVWD) PI(ILP2); ! THE "RESULT" %CONTINUE %FINISH ->RES %UNLESS OPND2_PTYPE&7=2 %IF REGS(FR0)_CL=0 %THEN REGS(FR0)_USE=0 LRES=LOAD(OPND2) %IF OPND2_XB#FR0 %START %IF CURRT_OPTYPE=X'52' %THEN D=RSCPY %ELSE D=RDCPY PI2(D,0,OPND2_XB-FR0) REGS(OPND2_XB)_CL=0 %FINISH %ELSE REGS(FR0)_CL=0 %CONTINUE TRIPSW(26): ! RECOVER FN RESULT ! CALLED AFTER RETURN TO CALLER OPND1_FLAG=9; OPND1_XB=ESTK %IF OPND1_PTYPE&7=2 %THEN %START OPND1_XB=FR0 REGS(FR0)_CL=1 REGS(FR0)_AT=WTRIPNO REGS(FR0)_LINK=WTRIPNO %FINISH %CONTINUE TRIPSW(27): ! RECOVER MAP RESULT ! CALLED AFTER RETURN TO CALLER OPND1_FLAG=9 OPND1_XB=ESTK %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 C=(D+3)&(-4); ! PNX WORDS FOR STRING VALUE PI1(ASFW,-C) FPPTR=FPPTR+C LRES=LOAD(OPND2); ! PTR TO STRING %IF C<=32 %START; ! SHORT STRINGS PI(SFA) PLOADCONST(C>>1) %FINISH %ELSE %START; ! LONG STRINGS COMPUTE MOVE SIZE P4I(DUPL,LHI,MASKC,CI2) P4I(IADD,CVIA,SFA,EXCH) %FINISH PI(MVWD) %IF PARM_OPT#0 %START P3I(SFA,LHI,MASKC); ! LENGTH FROM DEST PLOADCONST(D); ! FOR ASSNMNT CHECK PI(IGE) PPJ(JFALSE,9) %FINISH %FINISHELSEIF OPND1_PTYPE&7=3 %START; ! RECORD BY VALUE C=(D+3)&(-4) %IF OPND2_FLAG=SCONST %THEN D=0 %ELSE D=1 %AND LRES=LOAD(OPND2) PI1(ASFW,-C) PI(SFA) BULKM(D,C,0) FPPTR=FPPTR+C %FINISHELSESTART LRES=LOAD(OPND2) C=OPND1_PTYPE %IF C=X'62' %THEN %START PI1(RDPUSHD,OPND2_XB-FR0) FPPTR=FPPTR+8 %FINISH %ELSE %IF C=X'52' %THEN %START PI1(RSPUSHS,OPND2_XB-FR0) FPPTR=FPPTR+4 %FINISH %ELSE %START %IF C=X'31' %THEN PI1(ISHL,8) PI(IPUSH) FPPTR=FPPTR+4 %FINISH %IF C&7=2 %THEN REGS(OPND2_XB)_CL=0 %FINISH %CONTINUE TRIPSW(29): ! GET 32 BIT ADDRESS LOADAD(OPND1) ->STRES %CONTINUE TRIPSW(30): ! GET POINTER FOR %NAME LOADPTR(OPND1,OPND2) ->STRES %CONTINUE TRIPSW(31): ! PARAM PASSING (2) NORMAL PTRS LRES=LOAD(OPND2) PTYPE=OPND1_PTYPE&255; ! FOR PARAM %IF PTYPE=X'35' %START; ! STRING(2 WORD) PTRS FPPTR=FPPTR+4 P2I(EXCH,IPUSH) %FINISH PI(IPUSH) FPPTR=FPPTR+4 %CONTINUE TRIPSW(32): ! PARAM PASSING(3) ARRAYS ! ALSO (4) PASS RT PARAM SAME CODE LRES=LOAD(OPND2) P3I(EXCH,IPUSH,IPUSH) FPPTR=FPPTR+8 %CONTINUE TRIPSW(69): ! PASS 6 STORE STR FN RES PTR ! OPND2_D HAS OFFSET PLOADCONST(255) LRES=LOAD(OPND2) P2I(IPUSH,IPUSH) FPPTR=FPPTR+8 %CONTINUE TRIPSW(63): ! RTFP TURN RTNAME INTO FORMAL TCELL==ASLIST(TAGS(OPND1_D)) %IF TCELL_PTYPE&X'400'#0 %START; ! NAM>0 PASS A FORMAL DFETCH(ESTK,8,TCELL_UIOJ>>4&15,TCELL_SNDISP) %FINISHELSEIF TCELL_UIOJ&15=14 %START; ! EXTERNAL PASSED PLOADCONST(0); ! DUMMY DISPLAY DESC PFIXI(LGA,TCELL_SNDISP,0); ! RT FIXUP AREA== RT ID NO %FINISHELSE %START C=TCELL_UIOJ>>4&15 %IF C>0 %THEN PI1(ILL,-4*(C+1)) %ELSE PLOADCONST(0) D=TCELL_SNDISP %IF D=0 %THEN D=PNEXT SYMBOL %AND TCELL_SNDISP=D PFIXI(LGA,1,TCELL_SNDISP) %FINISH %CONTINUE TRIPSW(66): ! TYPE GENERAL PARAMETER ! OPND1 THE ACTUAL ! OPND2 HAS PTYPE&ACC %IF OPND1_FLAG=DNAME %AND OPND1_PTYPE&15=0 %START TCELL==ASLIST(TAGS(OPND1_D)) DFETCH(ESTK,8,TCELL_UIOJ>>4&15,TCELL_SNDISP) %FINISH %ELSE %START LRES=LOAD(OPND1); ! 32 BIT ADDRESS PLOADCONST(OPND2_D) PI(EXCH) %FINISH %CONTINUE !*********************************************************************** !* SECTION TO DEAL WITH SWITCHES INCLUDING ->SW(EXP) * !*********************************************************************** TRIPSW(33): ! DECLARE SWITCH OPND2 HAS BNDS TCELL==ASLIST(TAGS(OPND1_D)) TCELL_SNDISP=GLABEL; ! LABEL FOR SWITCH REFS PSWITCH(OPND2_XTRA-OPND2_D+1,GLABEL) GLABEL=GLABEL+1 PPJ(JUMP,6); ! ERROR EXIT AFTER TABLE %CONTINUE TRIPSW(34): ! SET SWITCH LABEL(OPND2) TCELL==ASLIST(TAGS(OPND1_D)) LCELL==ASLIST(TCELL_SLINK); ! SIDECHAIN HAS TDISP LB&UB PSWITCHLABEL(TCELL_SNDISP,OPND2_D-LCELL_S2);! REFS REL START OF 0 FORGET(-1) %CONTINUE TRIPSW(35): ! GOTO SW LABEL TCELL==ASLIST(TAGS(OPND1_D)) LCELL==ASLIST(TCELL_SLINK) C=LCELL_S2; ! ADJUST TO START OF 0 LRES=LOAD(OPND2) %IF C#0 %THEN PLOADCONST(C) %AND PI(ISUB) PJUMP(JUMP,TCELL_SNDISP); ! JUMP TO INDEXED JUMP %CONTINUE TRIPSW(37): ! REAL TO INTGER INTPT(OPND1) ! WORK OUT AS(INT(X-0.5) %BEGIN %RECORD(RD) COPND LRES=LOAD(OPND1) COPND_PTYPE=OPND1_PTYPE&255 COPND_FLAG=1 %IF OPND1_PTYPE>>4&15=6 %START; ! LONGREAL COPND_LR=0.5; D=RDSUB %FINISHELSESTART COPND_R=0.5; D=RSSUB %FINISH LRES=LOAD(COPND) REGS(COPND_XB)_CL=0 PI2(D,OPND1_XB-FR0,COPND_XB-FR0) %END TRIPSW(36): ! REAL TO INTEGER AS INT LRES=LOAD(OPND1) C=FINDREG(FRN)-FR0 %IF OPND1_PTYPE>>4&7=6 %START PI1(RDROUND,OPND1_XB-FR0) %FINISHELSESTART PI1(RSROUND,OPND1_XB-FR0) %FINISH REGS(OPND1_XB)_CL=0 OPND1_XB=0 OPND1_PTYPE=X'51' %CONTINUE TRIPSW(38): ! INTEGER TO STRING AS TOSTRING GET WSP(D,1) LRES=LOAD(OPND1) PI1(ISHL,8) PLOADCONST(1) PI(IADD) PI1(ISHL,16) DSTORE(ESTK,4,CURRINF_RBASE,D) PI(DISCARD) %IF CURRT_DPTH>0 OPND1_FLAG=LOCALIR OPND1_PTYPE=X'35' OPND1_D=CURRINF_RBASE<<16!D OPND1_XTRA=4; ! LENGTH OF TEMP SPACE %CONTINUE TRIPSW(42): ! ARRAYHEAD ASSIGNMENT OPND2_PTYPE=X'61'; ! SO LOAD LOADS HEAD NOT ELEMNT %IF OPND1_FLAG=DNAME %START; ! LHS IN LOCAL SPACE LRES=LOAD(OPND2) TCELL==ASLIST(TAGS(OPND1_D)) C=TCELL_SLINK %IF TCELL_PTYPE&X'3FFF'=X'33' %THEN %C C=RECORDELAD(TCELL,OPND1_PTYPE,OPND1_XTRA) DSTORE(ESTK,8,TCELL_UIOJ>>4&15,C) %FINISHELSESTART IMPABORT %UNLESS OPND1_FLAG=INDIRECT %OR OPND1_FLAG=REFTRIP %C %OR OPND1_FLAG=INDNAME %OR PARM_FAULTY#0 LRES=LOAD(OPND2) D=FINDREG(FRN) REGS(D)_USE=0 P3I(EXCH,IPUSH,IPUSH) PI1(RDPOPD,D-FR0) %IF OPND1_FLAG=INDIRECT %AND OPND1_XTRA>0 %START PLOADCONST(OPND1_XTRA>>1) PI(IADD) %FINISH %IF OPND1_FLAG=INDNAME %THEN LOADAD(OPND1) INDSTORE(D,8) %FINISH %CONTINUE TRIPSW(43): ! POINTER ASSIGNMENT D=BYTES(CURRT_OPTYPE>>4) LRES=LOAD(OPND2) %IF OPND1_FLAG=DNAME %START; ! LOCAL PTR TCELL==ASLIST(TAGS(OPND1_D)) C=TCELL_SLINK %IF TCELL_PTYPE&X'3FFF'=X'33' %THEN %C C=RECORDELAD(TCELL,OPND1_PTYPE,OPND1_XTRA) DSTORE(ESTK,D,TCELL_UIOJ>>4&15,C) %CONTINUE %FINISH %UNLESS CURRT_FLAGS&LOADOP1=0 %START;! DEST NOT LOADED LRES=LOAD(OPND1) %FINISH %ELSE %IF D=4 %THEN PI(EXCH) %ELSE P4I(IPUSH,EXCH,IPOP,EXCH) %IF OPND1_FLAG=INDIRECT %AND OPND1_XTRA>0 %THEN %C PLOADCONST(OPND1_XTRA>>1) %AND PI(IADD) %IF OPND1_FLAG=INDNAME %THEN LOADAD(OPND1) INDSTORE(ESTK,D) %CONTINUE TRIPSW(62): ! RECORD ASSIGNMENT %IF OPND2_FLAG=SCONST %THEN %START LRES=LOAD(OPND1) BULKM(0,CURRT_X1,OPND2_D) %CONTINUE %FINISH LRES=LOAD(OPND2) %IF CURRT_FLAGS&LOAD OP1=0 %THEN EXCHANGE(OPND1,OPND2) LRES=LOAD(OPND1) BULKM(1,CURRT_X1,0) %CONTINUE TRIPSW(64): ! AAINC INCREMENT RECORD RELATIVE ! ARRAY ACCESS BY RECORD BASE(OPND1) ! TO GIVE ABSOLUTE ACCESS. LRES=LOAD(OPND1) LRES=LOAD(OPND2); ! THE RELATIVE ACCESS %IF XTRA=X'31' %START; ! BYTE ARRAY ACCESS REL OFFSET BYTE P2I(EXCH,INDINT) %FINISH %ELSE PI(IADD); ! ADDITION %CONTINUE TRIPSW(65): ! AHADJ ARRAY MAPPING OPND1 1 ! HAS ADJUSTMENT OPND2 THE HEAD ! ARRAY PTYPE<<4!MODE IS IN CURRT_X1 LRES=LOAD(OPND1); ! LOAD NEW BASE JJ=-1 %IF OPND2_FLAG=DNAME %START TCELL==ASLIST(TAGS(OPND2_D)) JJ=TCELL_SLINK; D=TCELL_UIOJ>>4&15 %IF TCELL_PTYPE&X'3FFF'=X'33' %THEN %C JJ=RECORDELAD(TCELL,OPND2_PTYPE,OPND2_XTRA) %FINISH %IF OPND2_FLAG=7 %THEN JJ=OPND2_D&X'FFFF' %AND %C D=OPND2_D>>16 %IF JJ#-1 %START; ! HEAD ACCESSIBLE AVOID COMPLEX ! ESTACH MANIPULATIONS %IF CURRT_X1&1=0 %THEN %START FETCH LOW AD END(ESTK,D,JJ) %FINISH %ELSE %START FETCH HIGH AD END(ESTK,D,JJ) PI(IADD) FETCH LOW AD END(ESTK,D,JJ) %FINISH %CONTINUE %FINISH LRES=LOAD(OPND2); ! ARRAY HEAD BEFORE ADJMNT %IF CURRT_X1&1=0 %START; ! ARRAY MAPPING OPND1 IS BASE P2I(EXCH,DISCARD); ! DISCARD OLD BASE %FINISH %ELSE %START PI(IPUSH) PI(IADD); ! ADDRESSES ADDED PI(IPOP) %FINISH %CONTINUE !*********************************************************************** !* SECTION FOR GENERATING CODE FOR INLINE ASSEMBLER * !*********************************************************************** TRIPSW(50): ! UC NOOP ! CNOP(OPND1_D>>8,OPND1_D&255) FORGET(-1) %CONTINUE TRIPSW(51): ! UCB1 ONE BYTE ASSEMBLER PI(OPND1_D) FORGET(-1) %CONTINUE TRIPSW(52): ! UCB2 TWO BYTE ASSEMBLER PPUT2(OPND1_D&X'FFFF'); ! FOR *PUTS ALSO FORGET(-1) %CONTINUE TRIPSW(53): ! UCB3 3 BYTE ASSEMBLER PI2(OPND1_D>>16,OPND1_D>>8&255,OPND1_D&255) FORGET(-1) %CONTINUE TRIPSW(54): ! UCW ASSEMBLER WITH WORD OPERAND PI1(OPND1_D,OPND1_XTRA) FORGET(-1) %CONTINUE TRIPSW(55): ! UCBW BYTE&WORD OPERAND ASSEMBLER PI2(OPND1_D>>24,OPND1_D>>16&255,OPND1_D&X'FFFF') FORGET(-1) %CONTINUE TRIPSW(59): ! UCNAM ACCESS TO NAMES FROM U-C D=OPND1_D>>16 JJ=OPND1_D&X'FFFF' TCELL==ASLIST(TAGS(JJ)) %IF TCELL_PTYPE&X'3F00'=0 %THEN C=BYTES(TCELL_PTYPE>>4&15) %C %ELSE C=4 JJ=TCELL_SLINK+OPND1_XTRA %IF D=1 %THEN DFETCHAD(NO,C,TCELL_UIOJ>>4&15,JJ) %C %ELSEIF D=2 %THEN DSTORE(ESTK,C,TCELL_UIOJ>>4&15,JJ) %C %ELSE DFETCH(ESTK,C,TCELL_UIOJ>>4&15,JJ) %CONTINUE STRES: CURRT_OPTYPE<-OPND1_PTYPE %IF CURRT_CNT>1 %AND CURRT_OPERN#LASS %START; ! USED MORE THAN ONCE ! AND NOT ALREADY STORED %IF CURRT_FLAGS&USE ESTACK #0 %START;! IMPLIES _CNT=2 %AND TYPE=1 PI(DUPL) %FINISH %ELSE %START C=BYTES(OPND1_PTYPE>>4&15) GET WSP(D,C>>1) DSTORE(OPND1_XB,C,CURRINF_RBASE,D) OPND1_D=CURRINF_RBASE<<16!D OPND1_FLAG=7 %FINISH %FINISH ! %IF CURRT_CNT=1 %AND CURRT_OPTYPE&7=2 %AND %C ! CURRT_PUSE-WTRIPNO>2 %START ! BOOT OUT(OPND1_XB) ! %FINISH %IF CURRT_CNT=0 %AND 00 %THEN REGS(OPND1_XB)_CL=0 %REPEAT %IF PARM_DCOMP#0 %START PRINTSTRING(" CODE FOR LINE") WRITE(WORKA_LINE,3) PCODELINE; PRINT USE PLINESTART(WORKA_LINE); ! PREVENT CODE COMING AGAIN %FINISH %RETURN %INTEGERFN LOAD(%RECORD(RD) %NAME OPND) !*********************************************************************** !* LOAD OPERAND OPND INTO TOP OF NEST(ESTACK) * !*********************************************************************** %INTEGER K,KK,PREG,B,D,RES %STRING(255)SVAL %LONGREAL RVAL %RECORD(TRIPF) %NAME REFTRIP %RECORD(TAGF) %NAME TCELL %SWITCH SW(0:9) K=OPND_FLAG RES=1; ! SOMETHING LOADED PTYPE=OPND_PTYPE TYPE=PTYPE&15 PREC=PTYPE>>4&15 %IF K<=7 %START %IF TYPE#2 %THEN PREG=ESTK %ELSE PREG=FINDREG(FRN) %FINISH %IF K>9 %THEN IMPABORT ->SW(K) SW(0): ! CONSTANT < 16 BITS SW(1): %IF TYPE=5 %THEN ->SCONST %IF TYPE=1 %THEN PLOAD CONST(OPND_D) %AND ->LDED %IF TYPE=2 %THENSTART RVAL=OPND_LR; ! REFORMATTING CAN GIVE NONSTANDRD ! VALUES WHICH GIVE SPURIOUS 0 %IF HOST=EMAS %THEN REFORMATC(OPND) STORE CONST(KK,OPND) PFIXI(LGA,CAREA,KK) %IF PREC=5 %THEN KK=RSLDIS %ELSE KK=RDLDID PI1(KK,PREG-FR0) %FINISH ->LDED SCONST: ! STRING CONSTANT OPND_DIS AR PTR %IF HOST=EMAS %THEN SVAL=STRING(ADDR(WORKA_A(OPND_D))) %ELSE %START KK=WORKA_A(OPND_D) LENGTH(SVAL)=KK %FOR KK=1,1,KK %CYCLE CHARNO(SVAL,KK)=WORKA_A(OPND_D+KK) %REPEAT %FINISH STORE STRING(KK,SVAL) PFIXI(LGA,CAREA,KK) ->LDED SW(3): ! 128 BIT CONSTANT IMPABORT SW(2): ! NAME TCELL==ASLIST(TAGS(OPND_D)) K=BYTES(OPND_PTYPE>>4&15) %IF TCELL_PTYPE&X'3FFF'=X'33' %START KK=RECORDELAD(TCELL,PTYPE,OPND_XTRA) %FINISH %ELSE %IF TYPE=5 %THEN KK=STRINGLBAD(TCELL) %ELSE KK=TCELL_SLINK %IF TYPE=5 %THEN DFETCHAD(NO,1,TCELL_UIOJ>>4&15,KK&X'FFFF') %C %ELSE DFETCH(PREG,K,TCELL_UIOJ>>4&15,KK) LDED: %IF TYPE=1 %AND PREC<4 %THEN OPND_PTYPE=X'41' OPND_FLAG=9 OPND_XB=PREG %IF PREG>0 %THEN REGS(PREG)_CL=1 %AND REGS(PREG)_AT=WTRIPNO %C %AND REGS(PREG)_LINK=WTRIPNO %RESULT=RES SW(5): ! INDIRECT VIA DICTIONARY ! ONLY RECORD SCALAR(_XTRA>=0) ! OR POINTER(_XTRA<0) TCELL==ASLIST(TAGS(OPND_D)) %IF TYPE=5 %AND OPND_XTRA<0 %START;! STRING POINTER FETCH HIGH AD END(ESTK,TCELL_UIOJ>>4&15,TCELL_SLINK) %FINISH %ELSE DFETCH(ESTK,4,TCELL_UIOJ>>4&15,TCELL_SLINK) ->IFETCH SW(4): ! VIA POINTER AT OFFSET FROM ! A COMPUTED ADDRESS REFTRIP==TRIPLES(OPND_D) %IF REFTRIP_PUSE#WTRIPNO %THEN OPND_FLAG=8 %AND LRES=LOAD(OPND) %IF TYPE=5 %THEN OPND_XTRA=OPND_XTRA+4 %IF OPND_XTRA>0 %THEN PLOADCONST(OPND_XTRA>>1) %AND PI(IADD) ! ADDRESS OF POINTER NOW IN ESTK PI(LI); ! POINTER OR ADDRESS PORTION IN ESTK %IF TYPE#5 %THEN INDLOAD(PREG,BYTES(PREC)) ->LDED SW(6): ! INDIRECT WITH OFFSET REFTRIP==TRIPLES(OPND_D) %IF REFTRIP_PUSE#WTRIPNO %START; ! NEED TO LOAD TRIPLE OPND_FLAG=8 KK=LOAD(OPND) %FINISH IFETCH: %IF TYPE=5 %START PLOADCONST(OPND_XTRA>>1) %AND PI(IADD) %IF OPND_XTRA>0 %FINISH %ELSE %IF TYPE=1 %AND PREC=3 %START %IF OPND_XTRA>=0 %THEN PI(CVBA);! RECORDS ARE WORD PTRS? KK=OPND_XTRA!!1 PLOADCONST(KK) %AND PI(IADD) %UNLESS KK<=0 INDLOAD(ESTK,1) %FINISHELSESTART PLOADCONST(OPND_XTRA>>1) %AND PI(IADD) %UNLESS OPND_XTRA<=0 INDLOAD(PREG,BYTES(PREC)) %FINISH ->LDED SW(7): ! I-R IN A STACK FRAME B=OPND_D>>16; D=OPND_D&X'FFFF' %IF TYPE=5 %THEN %C DFETCHAD(NO,1,B,D+OPND_XTRA-1) %ELSE %C %IF OPND_XTRA=M'ARRH' %THEN FETCH HIGH AD END(PREG,B,D) %ELSE %C DFETCH(PREG,BYTES(PREC),B,D) ->LDED SW(8): ! TRIPLE REFTRIP==TRIPLES(OPND_D) %IF TYPE=5 %THEN %RESULT=LOAD(REFTRIP_OPND1) %IF REFTRIP_PUSE=WTRIPNO %AND REFTRIP_FLAGS&NOTINREG=0 %THEN %C PREG=REFTRIP_OPND1_XB %AND RES=0 %AND ->LDED OPND=REFTRIP_OPND1 %RESULT=LOAD(OPND) SW(9): ! I-R IN A REGISTER PREG=OPND_XB %IF PREG>0 %THEN REGS(PREG)_LINK=WTRIPNO %AND %C REGS(PREG)_AT=WTRIPNO %RESULT=0 %END %INTEGERFN STRINGLBAD(%RECORD(TAGF)%NAME TCELL) !*********************************************************************** !* RETURNS B<<16!D OF THE STRING LENGTH BYTE * !* FN NEEDED AS GLA FORWARD & STACK BACKWARD * !*********************************************************************** %INTEGER B,D,X,RL %RECORD(LEVELF)%NAME INF D=TCELL_SLINK B=TCELL_UIOJ>>4&15 %IF B=0 %THEN %RESULT=D INF==WORKA_LEVELINF(RLEVTOLEVEL(B)) X=INF_DISPLAY %IF D>4&15 %IF B=0 %THEN %RESULT=D+XDISP D=D+TCELL_ACC-XDISP %IF SPTYPE&7=5 %THEN %RESULT=D-1 D=D-BYTES(SPTYPE>>4&7) %IF SPTYPE=X'31' %THEN D=D!!1 %RESULT=D %END %ROUTINE INDLOAD(%INTEGER REG,SIZE) !*********************************************************************** !* LOADS REG VIA INDIRECTION POINTER ON ETOS * !*********************************************************************** %INTEGER BR %SWITCH SW(0:8) ->SW(SIZE) SW(*): ! UNKNOWN SIZES IMPABORT SW(1): ! BYTE PI(LBI); %RETURN SW(2): ! HALF PI(LHUI); %RETURN SW(4): ! WORD %IF FR0<=REG<=FR3 %THEN PI1(RSLDIS,REG-FR0) %AND %RETURN PI(LI) %IF BR0<=REG<=BR3 %THEN PI(SR0-BR0+REG) %RETURN SW(8): ! LONGREAL %IF REG=ESTK %START; ! DOUBLE WORD IN ESTACK BR=FINDREG(BRN) REGS(BR)_USE=0 PI(SR0-BR0+BR) PI(LI); ! LOW AD END PI1(LRO0-BR0+BR,4); ! HIGH AD END PI(EXCH); ! SO LOW AD END ON TOP %FINISH %ELSE PI1(RDLDID,REG-FR0) %END %ROUTINE INDSTORE(%INTEGER REG,SIZE) !*********************************************************************** !* STORES REG VIA INDIRECTION POINTER ON ETOS * !* WHEN REG ALSO = ETOS %THEN ROUTINE ASSUMES CORRECT ORDERING * !*********************************************************************** %INTEGER BR %SWITCH SW(0:8) ->SW(SIZE) SW(*): ! UNKNOWN SIZES IMPABORT SW(1): ! BYTE PI(ASSB); %RETURN SW(2): ! HALF PI(ASSH); %RETURN SW(4): ! WORD %IF FR0<=REG<=FR3 %THEN PI1(RSASSS,REG-FR0) %AND %RETURN %IF BR0<=REG<=BR3 %THEN P2I(LR0-BR0+REG,EXCH) PI(ASS) %RETURN SW(8): ! LONGREAL %IF REG=ESTK %START; ! DOUBLE WORD IN ESTACK BR=FINDREG(BRN) REGS(BR)_USE=0; P2I(SR0-BR0+BR,ASS); ! LOW AD END FROM TOP PI(EXCH) PI1(SRO0-BR0+BR,4); ! HIGH AD END FROM LOWER POSN %FINISH %ELSE PI1(RDASSD,REG-FR0) %END %ROUTINE LOADAD(%RECORD(RD) %NAME OPND) !*********************************************************************** !* MUCH AS LOAD BUT PRODUCES THE 32 BIT ADDRESS OF OPERAND * !* ABORT ON NON RELEVANT ALTERNATIVES OF OPND * !*********************************************************************** %RECORD(TRIPF)%NAME REFTRIP %RECORD(TAGF) %NAME TCELL %INTEGER B,D,X,K %SWITCH SW(0:9) PTYPE=OPND_PTYPE X=OPND_XTRA K=OPND_FLAG ->SW(K) SW(*): ! INVALID IMPABORT SW(2): ! DNAME TCELL==ASLIST(TAGS(OPND_D)) B=TCELL_UIOJ>>4&15 %IF TCELL_PTYPE&X'3FFF'=X'33' %THEN D=RECORDELAD(TCELL,PTYPE,X) %C %ELSE %IF PTYPE&255=X'35' %THEN D=STRINGLBAD(TCELL) %C %ELSE D=TCELL_SLINK DFETCHAD(NO,BYTES(PTYPE>>4&15),B,D) LDED: OPND_PTYPE=X'51'; ! 32 BIT ADDRESS IS INTEGER OPND_FLAG=9 OPND_XB=ESTK %RETURN SW(4): ! VIA POINTER AT OFFSET FROM ! A COMPUTED ADDRESS REFTRIP==TRIPLES(OPND_D) %IF REFTRIP_PUSE#WTRIPNO %THEN OPND_FLAG=8 %AND LRES=LOAD(OPND) %IF PTYPE&255=X'35' %THEN OPND_XTRA=OPND_XTRA+4 %IF OPND_XTRA>0 %THEN PLOADCONST(OPND_XTRA>>1) %AND PI(IADD) ! ADDRESS OF POINTER NOW IN ESTK PI(LI); ! ADDRESS IN ESTACK %IF PTYPE&X'FF'=X'31' %THEN PI(CVIA);! BYTE POINTERS ARE BYTE ADDRESSES ->LDED SW(5): ! INDIRECT VIA PTR TCELL==ASLIST(TAGS(OPND_D)) B=TCELL_UIOJ>>4&15 D=TCELL_SLINK %IF PTYPE&X'FF'=X'35' %AND OPND_XTRA<0 %START;! STRING POINTER FETCH HIGH AD END(ESTK,B,D) ->LDED %FINISH DFETCH(ESTK,4,B,D) ->INC ADDR SW(6): ! INDIRECT OFFSET REFTRIP==TRIPLES(OPND_D) %IF REFTRIP_PUSE#WTRIPNO %THEN OPND_FLAG=8 %AND LRES=LOAD(OPND) INC ADDR: ! X>=0 RECORD: X<0 POINTER %IF OPND_PTYPE&X'FF'=X'31' %AND X<0 %START;! BYTE INTEGER ARRAYS PI(CVIA) %FINISH %ELSE %START; ! ALL OTHER ITEMS WORD ADDRESSES %IF X>0 %THEN PLOADCONST(X>>1) %AND PI(IADD) %FINISH ->LDED SW(7): ! LOCAL-IR IN BASE&OFFSET FORM B=OPND_D>>16 D=OPND_D&X'FFFF' DFETCHAD(NO,BYTES(PTYPE>>4&7),B,D) ->LDED %END %ROUTINE LOADPTR(%RECORD(RD) %NAME OPND,OPND2) !*********************************************************************** !* MUCH AS LOAD BUT PRODUCES THE POINTER TO THE OPERAND * !* ABORT ON NON RELEVANT ALTERNATIVES OF OPND * !*********************************************************************** %RECORD(TRIPF)%NAME REFTRIP %RECORD(TAGF) %NAME TCELL %INTEGER K,B,D,X,PTYPE %SWITCH SW(0:9) PTYPE=OPND_PTYPE X=OPND_XTRA K=OPND_FLAG ->SW(K) SW(*): ! INVALID IMPABORT SW(2): ! DNAME TCELL==ASLIST(TAGS(OPND_D)) %IF TCELL_PTYPE&X'3FFF'=X'33' %THEN %START D=RECORDELAD(TCELL,PTYPE,X) %FINISH %ELSE %IF PTYPE&255=X'35' %THEN D=STRINGLBAD(TCELL) %C %ELSE D=TCELL_SLINK %IF PTYPE&255=X'35' %THEN %START PTYPE=OPND2_D>>16 DFETCHAD(NO,1,TCELL_UIOJ>>4&15,D&X'FFFF') ->STR %FINISH %IF PTYPE&255=X'31' %THEN %C DFETCHAD(YES,1,TCELL_UIOJ>>4&15,D) %ELSE %C DFETCHAD(NO,BYTES(OPND_PTYPE>>4&7),TCELL_UIOJ>>4&15,D) LDED: OPND_PTYPE=X'51' OPND_FLAG=9 OPND_XB=ESTK %RETURN SW(4): ! VIA POINTER AT OFFSET FROM ! A COMPUTED ADDRESS REFTRIP==TRIPLES(OPND_D) %IF REFTRIP_PUSE#WTRIPNO %THEN OPND_FLAG=8 %AND LRES=LOAD(OPND) %IF OPND_XTRA>0 %THEN PLOADCONST(OPND_XTRA>>1) %AND PI(IADD) ! ADDRESS OF POINTER NOW IN ESTK %IF PTYPE&255=X'35' %THEN INDLOAD(ESTK,8) %AND ->SLDED INDLOAD(ESTK,4) ->LDED SW(5): ! INDIRECT VIA DICT TCELL==ASLIST(TAGS(OPND_D)) %IF X<0 %START; ! IS A POINTER D=4 %IF PTYPE&255=X'35' %THEN D=8 DFETCH(ESTK,D,TCELL_UIOJ>>4&15,TCELL_SLINK) ->LDED %FINISH DFETCH(ESTK,4,TCELL_UIOJ>>4&15,TCELL_SLINK) ->INC ADDR SW(6): ! INDIRECT OFFSET REFTRIP==TRIPLES(OPND_D) %IF REFTRIP_PUSE#WTRIPNO %THEN OPND_FLAG=8 %AND LRES=LOAD(OPND) INC ADDR: ! FOR RECORD ELEMENTS %IF PTYPE&255=X'31' %START; ! BYTE POINTER WANTED PI(CVBA) %IF X>=0; ! RECORD POINTER IN WORDS X=X!!1 %IF X>0 %THEN PLOADCONST(X) %AND PI(IADD) %FINISH %ELSE %START; ! WORD POINTER WANTED %IF X>0 %THEN PLOADCONST(X>>1) %AND PI(IADD) %FINISH STR: ! ORGANISE WORD2 OF STR PNTR ! OPND2_XTRA=BML<<16!DML ->LDED %UNLESS PTYPE&255=X'35'; ! ALL NON STRING %IF OPND2_XTRA<0 %THEN PLOADCONST(OPND2_XTRA&X'FFFF') %ELSE %START FETCHLOW AD END(ESTK,OPND2_XTRA>>16,OPND2_XTRA&X'FFFF') ! FOR STRINGNAMES PTR NOW LOADED ! FR STRINGARRAYNAMES DVBASE NOW LDED ! HAVE TO EXTRACT ELSIZE AND DECREMENT BY 1 %IF PTYPE&X'300'#0 %THEN %START P3I(CI3,IADD,LHI) PLOADCONST(1) PI(ISUB) %FINISH %FINISH SLDED: ! STRING PTR LOADED OPND_PTYPE=X'61'; ! STR PNTERS ARE 64 BIT OPND_FLAG=9 OPND_XB=ESTK %RETURN SW(7): ! LOCAL BASE&DISP(RESULTS FROM MAP OPTIMISATIONS) B=OPND_D>>16 D=OPND_D&X'FFFF' DFETCHAD(NO,BYTES(PTYPE>>4&7),B,D) ->LDED SW(8): ! A TRIPLE MEANS PREVIOUSLY USED ! POINTER A SECOND TIME REFTRIP==TRIPLES(OPND_D) IMPABORT %UNLESS REFTRIP_OPERN=GETPTR LRES=LOAD(OPND) %END %ROUTINE VMY !*********************************************************************** !* DOES ALL VECTOR MULTIPLIES * !*********************************************************************** %INTEGER DVPOS,PR,CM DVPOS=OPND2_D&X'FFFF' PR=OPND1_PTYPE>>4&15 CM=-1 %IF PARM_ARR#0 %START %IF DVPOS>0 %START; ! BOUND KNOWN PLOADCONST(CTABLE(DVPOS+3*C+1)) PLOADCONST(CTABLE(DVPOS+3*C)) %FINISH %ELSE %START CM=SETDVREG(-1,OPND2_XTRA) PI1(LRO0-BR0+CM,12*C+4) PI1(LRO0-BR0+CM,12*C) %FINISH PI(CHK) %FINISH %IF C#1 %START; ! ALL DIMENSION BAR 1ST %IF DVPOS>0 %THENSTART PLOADCONST(CTABLE(DVPOS+3*C-1)) %FINISHELSESTART CM=SET DVREG(-1,OPND2_XTRA) %IF CM<0 PI1(LRO0-BR0+CM,12*C-4); ! MULTIPLIER %FINISH PI(IMULT) %FINISH %END %ROUTINE STARSTAR !*********************************************************************** !* PLANT IN LINE CODE FOR REAL**INTEGER * !* IN LINE CODE RATHER THAN SUBROUTINE BECAUSE OF THE NO OF CASES * !* NEEDED ON A REGISTER MACHINE WITH 2 LENGTHS OF ARITHMETIC * !*********************************************************************** %INTEGER OREG,WREG,MOP,DOP,FLOP,COPOP,LBASE OREG=OPND1_XB-FR0; ! OPERAND REGISTER WREG=FINDREG(FRN); ! WORKING FLOATING REGISTER FORGET(WREG) WREG=WREG-FR0 LBASE=GLABEL; GLABEL=GLABEL+5 %IF CURRT_OPTYPE>>4&15=6 %START; ! LONG MODE MOP=RDMULT; DOP=RDDIV FLOP=RDFLOAT; COPOP=RDCPY %FINISH %ELSE %START MOP=RSMULT; DOP=RSDIV FLOP=RSFLOAT; COPOP=RSCPY %FINISH ! CODE PLANTED IS AS FOLLOWS ! ! DUPL, DUPL, LCONST 0, IJLE L0 COPY ORIGINAL SIGNED EXPONENT ! INEG, !L0 DUPL COPY OF ABS(N) ! LCONST 255, IJLE L1 ! CALL PLABS7 ERROR EXIT EXPONENT TOO LARGE !L1 LCONST 1, FLOAT 1 1 TO WORK REG !L2 LCONST 1 ! ISUB, DUPL, LCONST 0 ! IJLT L3, RMULT WREG,OREG JUMP L2 !L3 ERASE EXPOSE ORIGINAL SIGNED EXPONENT ! RCOPY OREG,WREG COPY RESULT TO ORIGINAL ! LCONST 0, IJGE L4 ! LCONST 1, FLOAT OREG ! RDIV OREG,WREG INVERT !L5 ! P3I(DUPL,DUPL,CI0) PJUMP(IJGE,LBASE) PI(INEG) PLABEL(LBASE) PI(DUPL) PLOADCONST(255) PJUMP(IJLE,LBASE+1) PPJ(0,7) PLABEL(LBASE+1) PLOADCONST(1) PI1(FLOP,WREG) PLABEL(LBASE+2) P4I(CI1,ISUB,DUPL,CI0) PJUMP(IJLT,LBASE+3) PI2(MOP,WREG,OREG) PJUMP(JUMP,LBASE+2) PLABEL(LBASE+3) PI(DISCARD) PI2(COPOP,OREG,WREG) PLOADCONST(0) PJUMP(IJGE,LBASE+4) PLOADCONST(1) PI1(FLOP,OREG) PI2(DOP,OREG,WREG) PLABEL(LBASE+4) %END %ROUTINE REXP !*********************************************************************** !* CALLS A PERM ROUTINE TO PERFORM REAL**REAL * !*********************************************************************** IMPABORT %END %INTEGERFN SET DVREG(%INTEGER WHICH,DVBD) !*********************************************************************** !* SELECT(USUALLY) AND SET UP A C REGISTER AS A BASE REGISTER * !* FOR A DOPEVECTOR IN ARRAY WHOSE HEAD B&D GIVEN * !*********************************************************************** %INTEGER I %RECORD(REGF)%NAME REG %IF WHICH<0 %START; ! ANY REG WHICH=FIND USE(BRN,15,DVBD) %RESULT=WHICH %IF WHICH>0 WHICH=FINDREG(BRN) %FINISH REG==REGS(WHICH) %UNLESS REG_USE=15 %AND REG_INF1=DVBD %START FETCHLOW AD END(WHICH,DVBD>>16,DVBD&X'FFFF') PI(DISCARD) REG_USE=15; REG_INF1=DVBD %FINISH %RESULT=WHICH %END %INTEGERFN FIND USE(%INTEGER MASK,USE,INF) !*********************************************************************** !* SEARCHES FOR A REGISTER LOADED WITH USEFULL INFO * !*********************************************************************** %INTEGER I,L,U %RECORD(REGF)%NAME REG L=MASK>>16 U=MASK&255 %CYCLE I=L,1,U REG==REGS(I) %IF REG_USE=USE %AND REG_INF1=INF %THEN %RESULT=I %REPEAT %RESULT=-1 %END %INTEGERFN SET LEVELREG(%INTEGER WHICH,RLEV) !*********************************************************************** !* SELECT(USUALLY) AND SET UP A C REGISTER AS A BASE REGISTER * !* FOR ROUTINELEVEL RLEV * !*********************************************************************** %INTEGER I %RECORD(REGF)%NAME REG %IF WHICH<0 %START; ! ANY REG WHICH=FINDUSE(BRN,4,RLEV) %RESULT=WHICH %IF WHICH>0 WHICH=FINDREG(BRN) %FINISH REG==REGS(WHICH) %UNLESS REG_USE=4 %AND REG_INF1=RLEV %START PI1(ILL,-4*(RLEV+1)) P2I(SR0+WHICH-BR0,DISCARD) REG_USE=4; REG_INF1=RLEV %FINISH %RESULT=WHICH %END %ROUTINE SAVE IRS !*********************************************************************** !* DUMP REGISTERS INTO LOCAL SPACE. USED BEFORE CALLING FNS * !* IN EXPRESSIONS. * !*********************************************************************** %INTEGER I %CYCLE I=FR0,1,FR1 %IF REGS(I)_CL>=1 %THEN BOOT OUT(I) %REPEAT %END %ROUTINE BOOT OUT(%INTEGER REG) !*********************************************************************** !* REMOVE TEMPORARIES FROM REG INTO LOCAL STORE * !*********************************************************************** %INTEGER SIZE %RECORD(REGF)%NAME BOOTREG %RECORD(RD)%NAME R %RECORD(TRIPF)%NAME RTRIP BOOTREG==REGS(REG) IMPABORT %UNLESS 1<=BOOTREG_CL<=3 RTRIP==TRIPLES(BOOTREG_LINK) R==RTRIP_OPND1 IMPABORT %UNLESS R_XB=REG SIZE=BYTES(R_PTYPE>>4&15) GET WSP(R_D,SIZE>>2) DSTORE(REG,SIZE,CURRINF_RBASE,R_D) R_FLAG=7; R_XB=0 R_D=R_D!CURRINF_RBASE<<16 BOOTREG_CL=0 RTRIP_FLAGS=RTRIP_FLAGS!NOTINREG %END %INTEGERFN RLEVTOLEVEL(%INTEGER RLEV) !********************************************************************* !* FIND LEVEL FOR VAR WHOSE RLEVEL IS KNOWN * !*********************************************************************** %INTEGER I %RECORD(LEVELF)%NAME INF I=1 %CYCLE INF==WORKA_LEVELINF(I) %IF INF_RBASE=RLEV %THEN %RESULT=I I=I+1 %REPEAT %END %ROUTINE DSTORE(%INTEGER REG,SIZE,RLEVEL,DISP) !*********************************************************************** !* STORE SIZE(BYTES) FROM DISP(BYTES) IN DISPLAY 'LEVEL' * !*********************************************************************** %INTEGER LEVELCODE,BREG %RECORD(LEVELF)%NAME INF %SWITCH SW(0:24) IMPABORT %UNLESS REG=ESTK %OR SIZE=4 %OR (SIZE=8 %AND FR0<=REG<=FR3) %IF RLEVEL=0 %THEN LEVELCODE=0 %ELSEIF %C RLEVEL=CURRINF_RBASE %THEN LEVELCODE=1 %ELSE LEVELCODE=2 %IF SIZE=4 %START %IF FR0<=REG<=FR3 %THEN DFETCHAD(NO,4,RLEVEL,DISP) %AND %C PI1(RSASSS,REG-FR0) %AND %RETURN %IF BR0<=REG<=BR1 %THEN PI(LR0-BR0+REG) %FINISH ->SW(8*LEVELCODE+SIZE) SW(*): ! FUNNY SIZES IMPABORT SW(1): ! GLOBAL BYTE STORE SW(9): ! LOCAL BYTE STORE SW(17): ! INTERMEDIATE BYTE STORE DFETCHAD(YES,SIZE,RLEVEL,DISP); ! SIMPLE WAY FOR NOW PI(ASSB) %RETURN SW(2): ! GLOBAL HALF STORE SW(10): ! LOCAL HALF STORE SW(18): ! INTERMEDIATE HALF STORE DFETCHAD(NO,SIZE,RLEVEL,DISP) PI(ASSH) %RETURN SW(4): ! GLOBAL WORD STORE PFIXI(SGI,2,DISP); ! FIXED INSTRN NEEDED %RETURN SW(12): ! LOCAL WORD STORE PI1(ISL,CURRINF_DISPLAY-(DISP+4)) %RETURN SW(20): ! INTERMEDIATE WORD STORE INF==WORKA_LEVELINF(RLEVTOLEVEL(RLEVEL)) BREG=SET LEVELREG(-1,RLEVEL) PI1(SRO0-BR0+BREG,INF_DISPLAY-(DISP+4)) %RETURN SW(8): ! DOUBLE REAL GLOBAL STORE SW(16): ! DOUBLE REAL LOCAL STORE SW(24): ! DOUBLE REAL INTERMEDIATE STORE %IF REG=ESTK %START; ! DOUBLE INTEGER IN ESTK STORE LOW AD END(ESTK,RLEVEL,DISP) PI(EXCH); ! STORE NON DESTRUCTIVE) STORE HIGH AD END(ESTK,RLEVEL,DISP) %FINISH %ELSE %START DFETCHAD(NO,SIZE,RLEVEL,DISP) PI1(RDASSD,REG-FR0) %FINISH %END %ROUTINE DPTRFETCH(%INTEGER REG,SIZE,RLEVEL,DISP) !*********************************************************************** !* FETCHES SIZE(BYTES) VIA PTR AT DISP IN DISPLAY * !*********************************************************************** %INTEGER LEVELCODE ->GENERAL %UNLESS SIZE=4 %AND REG=ESTK ! SIZE =2 SIGN EXTENDS! %IF RLEVEL=0 %THEN LEVELCODE=0 %ELSE %IF RLEVEL=CURRINF_RBASE %C %THEN LEVELCODE=1 %ELSE LEVELCODE=2 ->GENERAL %IF LEVELCODE=2 %IF LEVELCODE#0 %THEN PI1(LLO,CURRINF_DISPLAY-(DISP+4)) %C %ELSE PFIXI(LGPO,2,DISP) %RETURN GENERAL: ! LONG WAY FOR DIFFICULT CASES DFETCH(ESTK,4,RLEVEL,DISP) INDLOAD(REG,SIZE) %END %ROUTINE DFETCHAD(%INTEGER BA,SIZE,RLEVEL,DISP) !*********************************************************************** !* FETCH ADDRESS OF DISP(BYTES) IN DISPLAY 'LEVEL' * !* WORD ADDRESS FETCHED UNLESS BA=YES WHEN BYTE ADDR FETCHED * !* SIZE IS NEED BECAUSE OF WRONG END LOW ADDRESS FOR STACKS * !*********************************************************************** %INTEGER I,WDISP,REG %RECORD(LEVELF)%NAME INF %IF RLEVEL=0 %START; ! GLOBAL ADDRESS NORMAL %IF BA=YES %THEN PFIXI(LGAB,2,DISP!!1) %AND %RETURN PFIXI(LGA,2,DISP) %FINISH %ELSE %IF RLEVEL=CURRINF_RBASE %START;! CURRENT LOCAL LEVEL WDISP=(DISP+SIZE+1)&(-2)-CURRINF_DISPLAY PI1(LAS,-WDISP) %FINISH %ELSE %START; ! INTERMEDIATE LEVEL INF==WORKA_LEVELINF(RLEVTOLEVEL(RLEVEL)) WDISP=(DISP+SIZE+1)&(-2)-INF_DISPLAY REG=SET LEVELREG(-1,RLEVEL) PI1(LROA0+REG-BR0,-WDISP) %FINISH %IF BA=YES %START; ! CONVERT TO BYTE FORM PI(CVBA) %IF DISP&1=0 %THEN PLOADCONST(1) %AND PI(IADD) %FINISH %END %ROUTINE DFETCH(%INTEGER REG,SIZE,RLEVEL,DISP) !*********************************************************************** !* FETCH SIZE(BYTES) FROM DISP(BYTES) IN DISPLAY 'LEVEL' * !*********************************************************************** %INTEGER LEVELCODE,BREG %RECORD(LEVELF)%NAME INF %SWITCH SW(0:24) IMPABORT %UNLESS REG=ESTK %OR SIZE=4 %OR (SIZE=8 %AND FR0<=REG<=FR3) %IF SIZE=4 %AND FR0<=REG<=FR3 %START DFETCHAD(NO,4,RLEVEL,DISP) PI1(RSLDIS,REG-FR0) %RETURN %FINISH %IF RLEVEL=0 %THEN LEVELCODE=0 %ELSEIF %C RLEVEL=CURRINF_RBASE %THEN LEVELCODE=1 %ELSE LEVELCODE=2 ->SW(8*LEVELCODE+SIZE) SW(*): ! FUNNY SIZES IMPABORT SW(1): ! GLOBAL BYTE FETCH SW(9): ! LOCAL BYTE FETCH SW(17): ! INTERMEDIATE BYTE FETCH DFETCHAD(YES,SIZE,RLEVEL,DISP); ! SIMPLE WAY FOR NOW PI(LBI) %RETURN SW(2): ! GLOBAL HALF FETCH SW(10): ! LOCAL HALF FETCH SW(18): ! INTERMEDIATE HALF FETCH DFETCHAD(NO,SIZE,RLEVEL,DISP) PI(LHUI) %RETURN SW(4): ! GLOBAL WORD FETCH PFIXI(LGI,2,DISP); ! FIXED INSTRN NEEDED ->WAYOUT SW(12): ! LOCAL WORD FETCH PI1(ILL,CURRINF_DISPLAY-(DISP+4)) ->WAYOUT SW(20): ! INTERMEDIATE WORD FETCH INF==WORKA_LEVELINF(RLEVTOLEVEL(RLEVEL)) BREG=SET LEVELREG(-1,RLEVEL) PI1(LRO0-BR0+BREG,INF_DISPLAY-(DISP+4)) ->WAYOUT SW(8): ! DOUBLE REAL GLOBAL FETCH SW(16): ! DOUBLE REAL LOCAL FETCH SW(24): ! DOUBLE REAL INTERMEDIATE FETCH %IF REG=ESTK %START; ! DOUBLE INTEGER IN ESTK FETCH HIGH AD END(ESTK,RLEVEL,DISP) FETCH LOW AD END(ESTK,RLEVEL,DISP) %FINISH %ELSE %START DFETCHAD(NO,SIZE,RLEVEL,DISP) PI1(RDLDID,REG-FR0) %FINISH %RETURN WAYOUT: %IF SIZE=4 %AND BR0<=REG<=BR3 %THEN PI(SR0-BR0+REG) %END %ROUTINE FETCH HIGH AD END(%INTEGER REG,B,D) !*********************************************************************** !* FETCHES THE HIGH END OF ARRAYHEAD(IE @A(FIRST)) OR STRINGNAME * !*********************************************************************** %IF B=0 %THEN D=D+4 DFETCH(REG,4,B,D) %END %ROUTINE FETCH LOW AD END(%INTEGER REG,B,D) !*********************************************************************** !* FETCHES LOW END OF ARRAYHD(IE DV PTR) OR STRINGHEAD(IE ACC) * !*********************************************************************** %IF B#0 %THEN D=D+4 DFETCH(REG,4,B,D) %END %ROUTINE STORE HIGH AD END(%INTEGER REG,B,D) !*********************************************************************** !* STORES THE HIGH END OF ARRAYHEAD(IE @A(FIRST)) OR STRINGNAME * !*********************************************************************** %IF B=0 %THEN D=D+4 DSTORE(REG,4,B,D) %END %ROUTINE STORE LOW AD END(%INTEGER REG,B,D) !*********************************************************************** !* STORES LOW END OF ARRAYHD(IE DV PTR) OR STRINGHEAD(IE ACC) * !*********************************************************************** %IF B#0 %THEN D=D+4 DSTORE(REG,4,B,D) %END %INTEGERFN JCODE(%INTEGER TFMASK) !*********************************************************************** !* PRODUCES JUMP CODE FROM IBM TYPE BRANCH MASK AND EXTRA BITS * !*********************************************************************** %IF TFMASK&15=15 %THENRESULT=JUMP %IF TFMASK&X'40'#0 %START; ! OPTIMISED BY CCOMP ! NEXT LINE ASSUMES BFFLAG IS ! STILL AS SET BY CCOMP! %RESULT=FCOMP(32+16*BFFLAG+TFMASK&15) %FINISH %IF TFMASK&128#0 %THENRESULT=JFALSE %RESULT=JTRUE %END %INTEGERFN FINDREG(%INTEGER MASK) !*********************************************************************** !* FINDS A FREE REGISTER FROM RANGE DEFINED BY MASK * !*********************************************************************** %INTEGER I,L,U,USED,LASTUSED,LASTREG %RECORD(REGF)%NAME REG L=MASK>>16 U=MASK&255 %FOR I=L,1,U %CYCLE REG==REGS(I) %RESULT=I %IF REG_CL=0 %AND REG_USE=0 %REPEAT ! ! IN NEXT CYCLE LOOK FOR TEMPORAY THAT WILL NOT BE USED FOR THE ! LARGEST FUTURE TIME MEASURED BY NO OF TRIPLES ! NB NOT 100% PERFECT AS SHUFFLES CAN OCCUR IN OPTIMISING) ! LASTUSED=WTRIPNO LASTREG=-1 %FOR I=L,1,U %CYCLE REG==REGS(I) %RESULT=I %IF REG_CL=0 %IF REG_AT#WTRIPNO %START; ! NOT USED IN THIS OPERATION USED=TRIPLES(REG_AT)_PUSE %IF USED >LASTUSED %THEN LASTUSED=USED %AND LASTREG=I %FINISH %REPEAT %IF LASTREG>0 %THEN BOOT OUT(LASTREG) %AND %RESULT=LASTREG IMPABORT %END %ROUTINE CONSTEXP(%INTEGER PTYPE,REG,VALUE) !*********************************************************************** !* EXPONENTIATION TO A KNOWN POWER * !* VALUE = 2 UPWARDS. VALUE=1 HAS BEEN OPTIMISED OUT * !*********************************************************************** %INTEGER WREG,I,MULTS,MULT,PUSH,POP MULTS=0; I=VALUE %IF PTYPE&7=1 %THEN ->INTEXP REG=REG-FR0 %IF PTYPE>>4&7=6 %START MULT=RDMULT; PUSH=RDPUSHD; POP=RDPOPD %FINISH %ELSE %START MULT=RSMULT; PUSH=RSPUSHS; POP=RSPOPS %FINISH %WHILE I>1 %CYCLE %IF I&1#0 %START PI1(PUSH,REG) MULTS=MULTS+1 %FINISH PI2(MULT,REG,REG) I=I>>1 %REPEAT %IF MULTS=0 %THEN %RETURN; ! **2,**4 ETC WREG=FINDREG(FRN) FORGET(WREG) WREG=WREG-FR0 %WHILE MULTS>0 %CYCLE MULTS=MULTS-1 PI1(POP,WREG) PI2(MULT,REG,WREG) %REPEAT %RETURN INTEXP: %WHILE I>1 %CYCLE %IF I&1#0 %START; ! PRESERVE THIS POWER FOR LATER PI(DUPL) PI(IPUSH) %UNLESS MULTS=0; ! USE ONLY 3 ESTACK CELLS MULTS=MULTS+1 %FINISH P2I(DUPL,IMULT) I=I>>1 %REPEAT %WHILE MULTS>0 %CYCLE MULTS=MULTS-1 PI(IPOP) %UNLESS MULTS=0 PI(IMULT) %REPEAT %END %ROUTINE CIOCP(%INTEGER N) !*********************************************************************** !* COMPILES A CALL ON IOCP ENTRY POINT NO 'N' * !* 2ND PARAMETER IS ALREADY IN ETOS * !*********************************************************************** %CONSTINTEGER NEEDS RES=X'20016'; ! FLAGS EPS 1,2,4&18 %INTEGER C C=(CURRT_DPTH+1)>>1 SAVE IRS PI(ALIGN) %IF FPPTR&7#0 PI1(ESAVE,C) %UNLESS C=0 %IF PARAMS BWARDS=YES %THEN %START PI(IPUSH) PLOADCONST(N) %FINISH %ELSE %START PLOADCONST(N) PI(IPUSH) %FINISH PI(IPUSH) PI1(CALL,KNOWN XREF(4)) PI1(ASFW,8); ! REMOVE PARAMETERS PI1(ERES,C) %UNLESS C=0 %IF FPPTR&7#0 %THEN PI1(ASFW,4) %END %END; ! OF ROUTINE GENERATE %ENDOFFILE