! ! Warning this module has the revised triples spec. ! ! In first attempt at Triple Imp considerable use was made of constant operands ! to pass information from Pass2 to GEN. Although for specialised operations like ! passing Labels this still applies, this adhocery has caused problems with arrays ! and pointers particularly in mapped records. The operands for four triples ! have thus been redefined in a more standard way. ! ! GETPTR X1 is now (ptype of passed)<<16! DIMENSION ! Opnd2 is either a 32 bit const with the size (ACC) as value or ! the ptr or arrayhead as normal operand. ! ! VMY X1 is now dim<<28!maxdim<<24!array name(where known) ! Opnd2 is either a 32 bit const with DV offset into const area or ! the arrayhead as a standard operand ! ! AINDX X1 is ELSIZE<<20 !spare ! Opnd2 is arrayhead as standard operand ! NOTE:- The Operands have been swopped for consistency with norm. ! ! BADJ X1 is arrayptype<<16!no of Dimensions (latter in case of backward dvs) ! Opnd2 exactly as for VMY ! %INCLUDE "ERCC07.TRIMP_HOSTCODES" %CONSTINTEGER HOST=EMAS %CONSTINTEGER TARGET=PNX %INCLUDE "ERCS02.DRS_ECODES" %INCLUDE "ERCC07.TRIPCNSTS" %INCLUDE "ERCC07.TRIMP_TFORM1S" %CONSTINTEGER ESTK=0,FR0=1,FR1=2,FR2=3,FR3=4,FRN=FR0<<16!FR3 %RECORDFORMAT REGF(%INTEGER CL,(%INTEGER USE %ORHALF 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=4 %OWNRECORD (REGF) %ARRAY REGS(0:MAXREG) %EXTERNALROUTINESPEC FLAGAND FOLD(%RECORD (TRIPF) %ARRAYNAME T) %EXTERNALINTEGERMAPSPEC COMREG %ALIAS "S#COMREG"(%INTEGER N) %EXTERNALROUTINESPEC FAULT(%INTEGER I,J,K) %INCLUDE "ERCS02.DRS_EPUTSPECS" %CONSTINTEGER MAXKXREF=5 %OWNINTEGERARRAY KXREFS(0:MAXKXREF)=-1(*) %CONSTSTRING (7) %ARRAY PLNAME(0:31)="plabs00","plabs01", "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", "p_mvbb","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 PRINT LIST(%INTEGER HEAD) %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 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) OP1(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) %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 %IF S="" %THEN D=4 %ANDRETURN; ! NULL STRING SET UP IN PROLOGUE 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 CTABLE(CONSTPTR+LP-1)=0; ! MAKE TRAILING BYTES ZERO STRING(ADDR(CTABLE(CONSTPTR)))=S CONST PTR=CONST PTR+LP %IF CONST PTR>WORKA_CONST LIMIT %THEN FAULT(102,WORKA_WKFILEK,0) %END %ROUTINE GET ENV(%INTEGERNAME HEAD) !*********************************************************************** !* SAVE A COPY OF THE REGISTER STATE FOR FUTURE REFERENCE * !*********************************************************************** %INTEGER I,USE %RECORD (REGF) %NAME REG %CYCLE I=0,1,MAXREG REG==REGS(I) USE=REG_USE&X'FF'; ! MAIN USE ONLY PUSH(HEAD,REG_INF1,REG_AT,I<<8!USE) %IF USE#0 %REPEAT %END %ROUTINE RESTORE(%INTEGER HEAD) !*********************************************************************** !* RESET THE REGISTERS TO ENVIRONMENT IN LIST HEADED BY 'HEAD' * !*********************************************************************** %INTEGER I,R,USE,INF,AT %RECORD (REGF) %NAME REG %CYCLE I=0,1,MAXREG REG==REGS(I) %IF REG_CL>=0 %THEN REG_USE=0 %REPEAT %WHILE HEAD#0 %CYCLE POP(HEAD,INF,AT,I) R=I>>8; USE=I&255 REG==REGS(R) %IF REG_CL>=0 %THEN REG_USE=USE %AND REG_INF1=INF REG_AT=AT %REPEAT %END %ROUTINE REDUCE ENV(%INTEGERNAME OLDHEAD) !*********************************************************************** !* REMOVES FROM ENVIRONMENT OLDHEAD ANYTHING INCOMPATABLE WITH * !* THE CURRENT ENVIRONMENT. FOR MULTIPLE JUMPS TO LABELS * !*********************************************************************** %INTEGERNAME HEAD %INTEGER R,U,S1,S2,S3 %RECORD (LISTF) %NAME LCELL %RECORD (REGF) %NAME REG HEAD==OLDHEAD %WHILE HEAD>0 %CYCLE LCELL==ASLIST(HEAD) R=LCELL_S3>>8 U=LCELL_S3&255 REG==REGS(R) %IF (REG_PRIMUSE=U %AND REG_INF1=LCELL_S1) %OR (REG_SECUSE=U %AND REG_INF2=LCELL_S1) %START HEAD==LCELL_LINK %IF REG_AT>LCELL_S2 %THEN LCELL_S2=REG_AT ! TAKE MOST RECENT VERSION OF AT %FINISHELSE 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 * !*********************************************************************** %INTEGERNAME PTR PTR==CAS(AREA) PTR=(PTR+BNDRY-1)&(-BNDRY) PDBYTES(AREA,PTR,AD,L) PTR=PTR+L %END %EXTERNALROUTINE PRDATA(%INTEGER AREA,BNDRY,L,REP,AD) !*********************************************************************** !* ADDS L(BYTES) REP TIMES TO AREA FOR UST,SST AND DIAGS AREAS * !* DATA ALREADY BYTE SWAPPED BY PASS2 * !*********************************************************************** %INTEGERNAME PTR %INTEGER I PTR==CAS(AREA) PTR=(PTR+BNDRY-1)&(-BNDRY) %FOR I=1,1,REP %CYCLE PDBYTES(AREA,PTR,AD,L) AD=AD+L PTR=PTR+L %REPEAT %END %EXTERNALINTEGERFN PINITOWN(%INTEGER PTYPE,ACC, %RECORD (RD) %NAME INIT, %STRINGNAME XNAME) !*********************************************************************** !* PUTS AN INITIALISED OWN INTO THE GLA. SHOULD DEAL WITH ALL TYPES * !* INIT IS ALREADY BYTE SWAPPED. ACC ETC NORMAL * !*********************************************************************** %RECORD (RD) OPND %INTEGER PREC,TYPE,RL,RES,X,LITL,I,J %STRING (255) IS 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) PDBYTES(2,RES+4,ADDR(OPND_D),4) GLACA=GLACA+8 %FINISHELSESTART PDBYTES(2,RES,ADDR(OPND_D),4) GLACA=GLACA+4 %FINISH %IF LITL=3 %START; ! EXTRINSICS ARE NAMES X=PXNAME(0,XNAME,GLACA) J=2 %IF TYPE=1 %AND PREC=3 %THEN J=X'80000002'; ! BYTE ADDRESS %IF TYPE=5 %THEN RES=RES+4 PDXREF(J,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 %THENSTART I=WORKA_A(OPND_D) LENGTH(IS)=I %FOR I=1,1,I %CYCLE CHARNO(IS,I)=WORKA_A(OPND_D+I) %REPEAT PDPATTERN(2,RES,1,ACC,ADDR(IS)); ! ALLOW FOR ALIGNMENT ON PNX %FINISHELSESTART %IF PREC=3 %THEN PD(2,RES,OPND_D) %IF PREC=4 %THEN PDBYTES(2,RES,ADDR(OPND_D),2) %IF PREC=5 %THEN PDBYTES(2,RES,ADDR(OPND_D),4) %IF PREC=6 %THEN PDBYTES(2,RES+4,ADDR(OPND_D),8) %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,HAREA AHW0=AOFFSET AHW1=DVOFFSET HAREA=2; ! NORMAL GLA 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,GLACA) PDXREF(HAREA,RES+4,X) %FINISHELSESTART %IF AAREA=0 %THEN PD4(2,RES+4,AHW0) %ELSE PFIX(HAREA,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,GLACA) %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,GLACA) KXREFS(N)=D %RESULT=D %END %ROUTINE CALL STOP !*********************************************************************** !* CALLS STOP ROUTINE. NOT VIA EPILOGUE ON PERQ * !*********************************************************************** PCALL(KNOWN XREF(0),0,0); ! S#STOP %END %ROUTINE ERASE(%INTEGER WORDS) !*********************************************************************** !* REMOVES 1 OR 2 WORDS FROM THE ESTACK * !*********************************************************************** %INTEGER I OP1(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 * !*********************************************************************** %RETURNUNLESS OPND1_FLAG<=8 %AND OPND2_FLAG>=8 %AND OPND1\==OPND2 OP1(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 OP1(DUPL) %FINISH PLOADCONST(W2) OP1(EXCH); OPIND(STH,0) L=L-2 %RETURNIF L=0 OP1(DUPL) PLOADCONST(1); OP1(IADD) %FINISH PLOADCONST(L) OP1(MVB) %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","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 ") %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 ") %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 %IF PARM_TRACE#0 %THEN I=X'C2C2C2C2' %AND 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 THE RUN TIME ERROR ROUTINE :- ! MDIAGS FOR DRS IS %ROUTINE MDIAGS(%INT PC,AP,ERROR,XTRA) ! PC IS A DUMMY EXCEPT AFTER CONTINGENCY ! ON ENTRY TO THIS SUBROUTINE ERROR & XTRA ARE AS PARAMETERS(P1&P2) ! ! ILP2, IPUSH XTRA STACKED ! ILP1, IPUSH ERROR STACKED ! LAS 0 CURRENT LNB TO ETOS ! IPUSH AND STACKED ! CI0 DUMMY CALLING PC ! IPUSH ! CALL N CALL TO NDIAGS ! RETURN ! K=KNOWN XREF(1); ! NDIAG XREF (AS NO ZERO) OBTAINED S=PLNAME(2) PPROC(S,12,WORKA_PLABS(2)); ! NO DISPLAY OR LOCALS OPDIR(LDW,0,10); ! P2 OP1(IPUSH) OPDIR(LDW,0,6); ! P1 (ERROR) OP1(IPUSH) OPDIR(LDA,0,0) OP1(IPUSH) PLOADCONST(0) OP1(IPUSH) PCALL(K,0,16) OP1(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 %THENSTART ! WORKA_PLABS(3)=CA ! CXREF("S#IMPMON",PARM_DYNAMIC,2,K) %FINISH ! ! SUBROUTINE TO ADVANCE STACK FRONT BY ETOS WORDS AND CHECK FOR OFLOW ! %IF PARM_OPT=1 %THENSTART; ! 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 CTABLE(1)=0; ! NULL STRING WORKA_CONST PTR=2 WORKA_CONST BTM=WORKA_CONST PTR %IF PARM_PROF#0 %THENSTART; ! ALLOCATE PROFILE COUNT AREA %FINISH PLINESTART(1); ! FOR PNX DEBUGGER %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,12,WORKA_PLABS(LAB)); ! NO DISPLAY OR LOCALS REQD PLOAD CONST(0) OP1(IPUSH) PLOADCONST(ERRNO) OP1(IPUSH) PCALL(WORKA_PLABS(2),0,8) 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) ! P5 = ADDRESS OF STRING BEING RESOLVED ! P4 = ADDR OF (ORIGINAL LENGTH! BYTES USED UP<<16) ! P3 = LMAXOF FRAGMENT HOLING STRING(=0 NO SUCH STRING) ! P2 = ADDRESS OF FRAGMENT STRING ! P1 = ADDRESS OF RESOLUTION STRING(CONVERTED TO BYTE FORM ON ENTRY) ! 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 = COPY OF ORIGNAL LHS LENGTH ! L6&7 = NOT USED (WAS 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 ! LDW ((P4)), CI255, IAND COPY BYTES IN ORIGINAL STRING ! DUPL, ISLL5 AND SAVED IN LOCAL ! LDW ((P4)), CI16, ISHRL ! DUPL, ISL1 COPY OF BYTES USED UP ! ISUB BYTES LEFT OF LHS ! LDB ((P1)), DUPL, ISL2 CURRENT LENGTH OF RESLN STRING ! JIZ RESOLVING ON NULL STRING ! ILL2, ISUB 0 LENGTH DIFF =1 VALID COMP ! CI1, IADD, DUPL, ISL3 MAX NO OF VALID COMPARISONS ! JILEZ NOT ENOUGH LEFT OF LHS ! ILP5, ILL1, IADD, ISL8 ! ! STAGE 2 CYCLE ROUND WITH BYTEARRAY COMPARISONS TO LOCATE STRING ! !OUTERLOOP(L0): REPITIONS TO HERE ! ILP1, CI1, IADD, SET BYTE PTR TO RESOLUTION ! ILL8, ILL4, IADD, POINTER TO RIGHT BYTE IN LHS !INNERLOOP(L1): REPEAT ON BYTE BY BYTE ! ILL2, CPBEQ TEST FOR EQUALITY ! JINZ ALL FOUND WITH NO NONEQIVALENCE !DIFF FOUND(L3): THIS COMPARISON FAILS ! ADVANCE DOWN BY ONE ! ILL4, CI1, IADD, DUPL, ISL4 INCREMENT CONTROL ! ILL3, JILE AND CONTINUE ! !RESFAIL(L4): RESOLUTION HAS FAILED ! CI0, RETURN EXIT WITH FALSE SET !RESOK(L5): RESOLUTION HAS WORKED ! ILP3, JIZ FRAGMENT TO BE DISCARDED ! ! CONTROL(L4) 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 ! ILP2 DEST POINTER ! ILL4 BYTES TO MOVE !MOVEMORE(L7): ASSIGN POSSIBLY OVERLAPPING ! MVB ASSIGN OK IF OVERLAPPED ! ILL4, CI1, ISUB FRAGMENT LENGTH ! DUPL, STB ((P2)) STORED WITH PTR ! ILP3, JILE 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, CI16, ISHLL ! ILL5, IOR, STW((P4)) AND STORE VIA HALFWORD PTR ! CI1, RETURN EXIT WITH RESULT=TRUE ! %IF WORKA_PLINK(16)=0 %THEN ->P17 FILL(16) PLOADCONST(1) OPDIR(STW,0,-4*4) OPDIS(LDW,0,2+4*4,0) PLOADCONST(255); OP2(IAND,DUPL) OPDIR(STW,0,-4*5) OPDIS(LDW,0,2+4*4,0) PLOADCONST(16); OP1(ISHRL) OP1(DUPL) OPDIR(STW,0,-4*1) OP1(ISUB) OPDIS(LDB,0,2+4*1,0) OP1(DUPL) OPDIR(STW,0,-4*2) PJUMP(JIZ,GLABEL+5) OPDIR(LDW,0,-4*2) OP1(ISUB) PLOADCONST(1) OP2(IADD,DUPL) OPDIR(STW,0,-4*3) PJUMP(JILEZ,GLABEL+4) OPDIR(LDW,0,2+4*5) OPDIR(LDW,0,-4*1) OP1(IADD) OPDIR(STW,0,-4*8) ! THIS IS "OUTERLOOP" PLABEL(GLABEL) OPDIR(LDW,0,2+4*1) PLOADCONST(1) OP1(IADD) OPDIR(LDW,0,-4*8) OPDIR(LDW,0,-4*4) OP1(IADD) ! THIS IS "INNERLOOP" PLABEL(GLABEL+1) OPDIR(LDW,0,-4*2) OP1(CPBEQ) PJUMP(JINZ,GLABEL+5) ! THIS IS "DIFF FOUND" PLABEL(GLABEL+3) OPDIR(LDW,0,-4*4) PLOADCONST(1) OP2(IADD,DUPL) OPDIR(STW,0,-4*4) OPDIR(LDW,0,-4*3) PJUMP(JILE,GLABEL) ! THIS IS "RESFAIL" PLABEL(GLABEL+4) PLOADCONST(0) OP1(RETURN) ! THIS IS "RESOK" PLABEL(GLABEL+5) OPDIR(LDW,0,2+4*3) PJUMP(JIZ,GLABEL+6) OPDIR(LDW,0,-4*8) OPDIR(LDW,0,2+4*2) OPDIR(LDW,0,-4*4) PLABEL(GLABEL+7) OP1(MVB) OPDIR(LDW,0,-4*4) PLOADCONST(1) OP2(ISUB,DUPL) OPDIS(STB,0,2+4*2,0) OPDIR(LDW,0,2+4*3) PJUMP(JILE,GLABEL+6) PRECALL PCALL(WORKA_PLABS(9),0,0) ! THIS IS "NOSTORE" PLABEL(GLABEL+6) OPDIR(LDW,0,-4*1) OPDIR(LDW,0,-4*2) OP1(IADD) OPDIR(LDW,0,-4*4) OP1(IADD) PLOADCONST(1) OP1(ISUB) PLOADCONST(16) OP1(ISHLL) OPDIR(LDW,0,-4*5) OP1(IOR) OPDIS(STW,0,2+4*4,0) PLOADCONST(1) OP1(RETURN) PPROCEND(32) GLABEL=GLABEL+8 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 ! P2 = VIRT (WORD) ADDR OF SOURCE ! P2 = MAX LENGTH OF DEST ! P1 = VIRT (WORD) ADDR OF DEST ! L1 = LOCAL THE ACTUAL STRING BYTES TO BE MOVED ! ! ILP2, LBI, DUPL, ISL1 LENGTH OF SOURCE ! ILP2, JILE NO TRUNCATION ! ILP2, ISL1 TRUNCATED LENGTH !L0: ILP2 ! ILP1, ILL1 ! CI1, IADD, MOVE LBYTES + LENGTH BYTE ! MVB ! ILL1, ILP1, ASSB AND OVERWRITE LENGTH ! RETURN ! %IF WORKA_PLINK(18)=0 %THEN ->P19 FILL(18) OPDIR(LDW,0,2+4*3); OPIND(LDB,0); OP1(DUPL); OPDIR(STW,0,-4*1) OPDIR(LDW,0,2+4*2) PJUMP(JILE,GLABEL) OPDIR(LDW,0,2+4*2); OPDIR(STW,0,-4*1) PLABEL(GLABEL) OPDIR(LDW,0,2+4*3); OPDIR(LDW,0,2+4*1) OPDIR(LDW,0,-4*1) PLOADCONST(1) OP1(IADD) OP1(MVB) OPDIR(LDW,0,-4*1); OPDIR(LDW,0,2+4*1); OPIND(STB,0) OP1(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 ! IN LINE CODE USED AS NO JLK INSTRUCTION %IF WORKA_PLINK(20)=0 %THEN ->P21; ! ROUTINE NOT USED FILL(20) 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, DUPL, LBI, DUPL ! ISL1, EXCH, CI1, IADD, EXCH LENGTH OF MOVE OVER SOURCE ! ILP1, DUPL, LBI, DUPL ! ISL2, IADD, CI1, IADD ! EXCH, MVB STRINGS JOINED ! ILL1, ILL2, IADD, ILP1 ! ASSB, ! RETURN ! %IF WORKA_PLINK(24)=0 %THEN ->P25 FILL(24) OPDIR(LDW,0,2+4*2); OP1(DUPL); OPIND(LDB,0); OP1(DUPL) OPDIR(STW,0,-4*1); OP1(EXCH); PLOADCONST(1) OP1(IADD); OP1(EXCH) OPDIR(LDW,0,2+4*1); OP1(DUPL); OPIND(LDB,0); OP1(DUPL) OPDIR(STW,0,-4*2); OP1(IADD); PLOADCONST(1); OP1(IADD) OP1(EXCH) OP1(MVB) OPDIR(LDW,0,-4*1); OPDIR(LDW,0,-4*2); OP1(IADD); OPDIR(LDW,0,2+4*1) OPIND(STB,0) OP1(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 ! PARAMETERS ARE TWO BYTE ADDRESS AND ROUTINE RETURNS FIRST DIFFERENCE ! ! P1 HAS FIRST OPERAND (BYTE) ADDRESS ! P2 HAS SECOND OPERAND ADDRESS ! L1 HAS FIRST OPERAND CURRENT (BYTE) ADDRESS ! L2 HAS SECOND OPERAND CURREMT BYTE ADDRESS ! L3 HAS SHORTER STRING LENGTH ! ! ILP1 DUPL, CI1 IADD ! ISL1, LBI, ISL3 ! ILP2, DUPL, CI1, IADD ! ISL2, LBI, ILL3, ! JIGE ! LDB ((P2)), ISL3 SHORTER LENGTH SET !L0: ILL3, DUPL, JIZ ZERO LENGTH WITH NO DIFFERENCE ! CI1, ISUB, ISL3 LENGTH DECREMENTED ! LDB ((L1)), LDB ((L2)) NEXT TWO CHARS ! JINE DIFFERENC FOUND ! ILL2, CI1, IADD, ISL2 UPDATE 2ND POINTER ! ILL1, CI1, IADD, ISL1 UPDATE 1ST POINTER ! JUMP !L1: RETURN DIFFERENCE OF CHS ! LDB ((L1)), LDB ((L2)), ISUB, RETURN !L2: NO DIFFERENCES RETURN LENGTHS ! DISCARD ! LDB ((P1)),LDB ((P2)), ISUB ! RETURN ! %IF WORKA_PLINK(28)=0 %THEN ->P29 FILL(28) OPDIR(LDW,0,6 {P1}); OP1(DUPL) PLOADCONST(1); OP1(IADD) OPDIR(STW,0,-4 {L1}) OPIND(LDB,0); OPDIR(STW,0,-12 {L3}) OPDIR(LDW,0,10 {P2}); OP1(DUPL) PLOADCONST(1); OP1(IADD) OPDIR(STW,0,-8 {L2}) OPIND(LDB,0); OPDIR(LDW,0,-12 {L3}) PJUMP(JIGE,GLABEL) OPDIS(LDB,0,10,0 {((P2))}); OPDIR(STW,0,-12 {L3}) PLABEL(GLABEL) OPDIR(LDW,0,-12 {L3}); OP1(DUPL) PJUMP(JIZ,GLABEL+2) PLOADCONST(1); OP1(ISUB) OPDIR(STW,0,-12 {L3}) OPDIS(LDB,0,-4,0 {((L1))}) OPDIS(LDB,0,-8,0 {((L2))}) PJUMP(JINE,GLABEL+1) OPDIR(LDW,0,-4 {L1}); PLOADCONST(1); OP1(IADD) OPDIR(STW,0,-4 {L1}) OPDIR(LDW,0,-8 {L2}); PLOADCONST(1); OP1(IADD) OPDIR(STW,0,-8 {L2}) PJUMP(JUMP,GLABEL) PLABEL(GLABEL+1); ! LABEL L1 HERE OPDIS(LDB,0,-4,0 {((L1))}) OPDIS(LDB,0,-8,0 {((L2))}) OP2(ISUB,RETURN) PLABEL(GLABEL+2); ! LABEL L2 IS HERE OP1(DISCARD) OPDIS(LDB,0,6,0 {((P1))}) OPDIS(LDB,0,10,0 {((P2))}) OP2(ISUB,RETURN) PPROCEND(16) GLABEL=GLABEL+3 P29: ! ! GENERATE A MOVE BYTES ROUTINE ENTERED BY CALL ! USED IN RESOLUTION FOR POSSIBLY OVERLAPPED MOVES ! NO RELEVANCE TO DRS MOVE BYTES INTRUCTION ADEQUATE %IF WORKA_PLINK(29)=0 %THEN ->P30 FILL(29) PPROCEND(0) 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 %THENSTART ! 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 %IF PARM_TRACE#0 %THEN PFIX(2,20,DAREA,0); ! RELOCATE DAREA POINTER PFIX(2,24,CAREA,0); ! RELOCATE CONSTANT TABLE %IF PARM_TRACE#0 %THEN I=X'E2E2E2E2' %AND 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(" DRS CODE") WRITE(SIZES(1)+SIZES(CAREA),6) %IF SIZES(4)>0 %THEN PRINTSTRING("+") %AND 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 %THENSTART WRITE(STMTS,7); PRINTSTRING(" STATEMENTS COMPILED") COMREG(47)=STMTS; ! NO OF STMTS FOR COMPER %FINISHELSESTART 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(WORKA_CTABLE(I+J),8) %REPEAT SPACE %CYCLE J=0,1,31 %IF HOST=EMAS %THEN K=BYTEINTEGER(BASE+4*I+J) %ELSE K=BYTEINTEGER(2*BASE+4*I+J) %IF K<31 %OR K>125 %THEN K=32 PRINT SYMBOL(K) %REPEAT I=I+8 %EXITIF 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,4,WORKA_PLINK(LAB)); ! NO DISPALY REQD %END %END %REALFN 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 %AND HOST#PNX %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})+(11-BITS SHIFTED LEFT) %C {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 %LONGREALFN 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 %AND HOST#PNX %START %IF PARM_X#0 %THENRESULT=ICL2900REAL; ! FOR SIMULATOR %IF ICL2900 REAL=0.0 %THENRESULT=0.0 %IF ICL2900 REAL<0.0 %THEN 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 {which is the ICL2900 bias}-1 %C { as the most significant digit is <1 and >=1/16})*4 { as the ICL2900 exponent is a hex exponent}+ %C (11-BITS SHIFTED LEFT) {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,INF %CONSTBYTEINTEGERARRAY INVJ(24:35)= JILE{JIGT},JIGE{JILT}, JINE{JIEQ},JIEQ{JINE}, JILT{JIGE},JIGT{JILE}, JILEZ{JIGZ},JIGEZ{JILZ}, JINZ{JIZ},JIZ{JINZ}, JILZ{JIGEZ},JIGZ{JILEZ} %CONSTINTEGERARRAY INFO(0:30)=0,0,8,0(13), X'02010014'{16 RESLN}, 0,12{18 STRINGJT}, 0(9),X'02010008'{28 STRING COMP}, 0(*) LAB=0 VAL=WORKA_PLABS(N) INF=INFO(N); ! RESULTFLAGS<<16 ! BYTES OF PARAMS %IF VAL<0 %START VAL=PNEXTSYMBOL WORKA_PLABS(N)=VAL WORKA_PLINK(N)=VAL %FINISH %IF JUMP>=24 %THEN LAB=GLABEL %AND GLABEL=LAB+1 %IF LAB>0 %THEN PJUMP(INVJ(JUMP),LAB) PRECALL %UNLESS INF&255#0; ! PRECALL MUST BE DONE BEFOR PARAMS PCALL(VAL,INF>>16,INF&X'FF') %IF LAB>0 %THEN PLABEL(LAB) %END %INTEGERFN DRSSWOP(%INTEGER VAL) !*********************************************************************** !* PERFORMS A COMPLETE BYTE REVERSAL OF VAL * !*********************************************************************** %IF PSWAPMODE=0 %THENRESULT=VAL %RESULT=(VAL<<24)!(VAL<<8&X'FF0000')!(VAL>>8&X'FF00')!(VAL>>24) %END %EXTERNALROUTINE REFORMATC(%RECORD (RD) %NAME OPND) !*********************************************************************** !* REFORMATS A CONSTANT TO TAKE INTO ACCOUNT DIFFERENT HOST-TARGET * !* REPRESENTATIONS. HOST MAY BE EMAS OR PNX. * !*********************************************************************** %IF HOST#TARGET %START %INTEGER TYPE,PREC,I %REAL R %RECORD (RD) TEMP %IF PSWAPMODE=0 %THENRETURN TEMP=OPND I=OPND_D; ! ALL INTEGER UP TO 32 BIT TYPE=OPND_PTYPE&7 PREC=OPND_PTYPE>>4&7 %IF TYPE=1 %START; ! INTEGERS %IF PREC=3 %THEN OPND_B0<-I %AND OPND_B1<-I %ANDRETURN %IF PREC=4 %THEN OPND_B0<-I %AND OPND_B1<-I>>8 %ANDRETURN %IF PREC=5 %THEN OPND_D=DRSSWOP(OPND_D) %ANDRETURN IMPABORT %FINISH %IF TYPE=2 %THENSTART %IF PREC=5 %START TEMP_R=ICLREALTOPERQ(OPND_R) OPND_D=DRSSWOP(TEMP_D) %RETURN %FINISH %IF PREC=6 %START TEMP_LR=ICLLONGREALTOPERQ(OPND_LR) OPND_D=DRSSWOP(TEMP_XTRA) OPND_XTRA=DRSSWOP(TEMP_D) %RETURN %FINISH %FINISH %IF TYPE=5 %THENRETURN; ! CANT CHANGE SEX HERE ! MIGHT BE USED IN COMPILE TIME OP IMPABORT %FINISH %END %EXTERNALROUTINE CHANGESEX(%INTEGER BASEAD,OFFSET,L) !*********************************************************************** !* ALTERERS INITIALISED DATA FOR A BYTE SEX CHANGE * !* HOWEVER DRS IS BYTESWOPPED BUT HAS EMAS BYTE SEX * !*********************************************************************** %OWNBYTEINTEGERARRAYFORMAT F(0:X'FFFF') %BYTEINTEGERARRAYNAME A %INTEGER I,J %IF HOST=PNX %START A==ARRAY(BASEAD,F) %MONITORUNLESS 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 %THENSTART PSETOPD(JJ,CAS(DAREA)) %FINISHELSESTART 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 ISTARSTAR %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 PCALLPARAM(%INTEGER RTPTYPE) %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 CHOP OPERAND(%RECORD (RD) %NAME OPND, %INTEGER PT,X) %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 FIND USE(%INTEGER MASK,USE,INF) %ROUTINESPEC SET DVREG(%INTEGER 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'10000602'{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}, X'20000413'{46 FOREND EXACTLY AS PRELD FOR PNX}, 0(3), X'10000132'{50 UCNOP}, X'10000133'{51 UCB1}, X'10000234'{52 UCB2}, X'10000335'{53 UCB3}, X'10000336'{54 UCW}, X'10000437'{55 UCBW}, 0(3), X'1000063B'{59 UCNAM U-C ACCESS TO NAMES}, 0(68), X'20010414'{128 +}, X'20000415'{129 -}, X'20010416'{130 !!}, X'20010417'{131 !}, X'20010418'{132 *}, X'20000419'{133 //}, X'2000041A'{134 /}, X'2001041B'{135 &}, X'2000041C'{136 >>}, X'2000041D'{137 <<}, X'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'200A0527'{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}, X'10000449'{191 REG TO STORE OPERATION}, 0(*) %CONSTHALFINTEGERARRAY FCOMP(0:95)=0(2), IGT(2),ILT(2),INE(2),IEQ(2), IGE(2),ILE(2),0(2), 0(2), ILT(2),IGT(2),INE(2),IEQ(2), ILE(2),IGE(2),0(2), 0(2), JIGT(2),JILT(2),JINE(2),JIEQ(2), JIGE(2),JILE(2),0(2), 0(2), JILT(2),JIGT(2),JINE(2),JIEQ(2), JILE(2),JIGE(2),0(2), 0(2), RLT(2),RGT(2),RNE(2),REQ(2), RLE(2),RGE(2),0(2), 0(2), RGT(2),RLT(2),RNE(2),REQ(2), RGE(2),RLE(2),0(2) ! ! OPCODE FOR ESTACK TO STORE VARIANT OPERATIONS ! ! ! 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*(3*NISEQS+10)-1)={FIRST INTEGER FORMS} %C 2,INOTH,0,0 {10 16 BIT LOGICAL NOT}, 2,INEGH,0,0 {11 16 BIT LOGICAL NEGATE}, 12,0,0,0 {12 16 BIT FLOAT TO 64 BIT REAL}, 9,0,8,0 {13 16 BIT MODULUS}, 10,0,0,0 {14 SHORTEN 16 BIT TO 16 BIT}, 6,EXTEND,0,X'51' {15 LENGTHEN 16 BIT TO 32 BIT}, 21,0,0,0 {16 SHORTEN 16 BIT FOR JAM}, 1,0,0,109 {17 COMPILER ERROR}, 7,0,0,0 {18 NOOP}, 7,0,0,0 {19 PRELOAD}, 2,IADDH,0,0 {20 16 BIT ADDITION}, 2,ISUBH,0,0 {21 16 BIT SUBTRACTION}, 2,IXORH,0,0 {22 16 BIT NONEQUIVALENCE}, 2,IORH,0,0 {23 16 BIT LOGICAL OR}, 2,IMULTH,0,0 {24 16 BIT MULTIPLY}, 2,IDIVH,0,0 {25 16 BIT INTEGER DIVIDE}, 1,0,0,109 {26 16 BIT REAL DIVIDE}, 2,IANDH,0,0 {27 16 BIT AND}, 2,ISHRLH,0,0 {28 16 BIT RIGTH SHIFT}, 2,ISHLLH,0,0 {29 16 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,IADDH,0,0 {34 COMBINE VMY RESULTS}, 16,0,0,0 {35 ASSIGN}, 16,0,0,0 {36 ASSIGN(<-)}, 17,1,2,20 {37 16 BIT INTEGER EXPONENTIATION}, 18,2,0,0 {38 BASE ADJUST ARRAY 16 BIT INDEX}, 19,2,0,0 {39 ARRAY INDEX 16 BIT INDEX}, 20,0,0,0 {40 INDEXED FETCH 16 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}, 2,INOT,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,IOR,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,IAND,0,0 {27 32 BIT AND}, 2,ISHRL,0,0 {28 32 BIT RIGTH SHIFT}, 2,ISHLL,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:73) ! 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) LRES=0 ! ! CARE IS NEEDED IN DETECTING WHEN OPERANDS ARE REVERSED IN STACK ! %IF JJ>=128 %AND CURRT_FLAGS&(LOADOP1+LOADOP2)=0 %AND 1<=128 %AND CURRT_FLAGS&6=2 %AND OPND1_PTYPE&7#2 %AND OPND2_PTYPE&7#2 %START; ! OPERANDS REVERSED IN ESTACK COMM=2 %FINISH %FINISH %IF TRIPINF&X'F0000'=0 %AND COMM=2 %THEN EXCHANGE(OPND2,OPND1) %AND COMM=1 ! I-RS THE WRONG WAY ROUND ! FOR NON COMMUTABLE OPS %UNLESS JJ<128 %OR TRIPINF&X'20000'#0 %THEN LRES=LOAD(OPND2) PTYPE=OPND1_PTYPE&255; TYPE=PTYPE&7 %IF TYPE=2 %THEN C=4*(TRIPVAL+2*NISEQS) %ELSEIF PTYPE=X'51' %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(*): OP1(NULL); ! USEFUL IN DEBUGGING TO HAVE ! ERROR POSITION PINPOINTED ->STRES SW(6): ! PLANT BYTE & SET PTYPE OPND1_PTYPE=B3 SW(2): ! PLANT ONE BYTE OP1(B1) OPND1_FLAG=9; ! PREVENT RELOAD IF THIS IS LAST ->STRES SW(3): ! PLANT 2 BYTES OP2(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-64; ! USE SHORT OPCODE FORM FOP2(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-64 C=OPND1_XB-FR0 FOP2(D,C,C) OPND1_FLAG=9 ->STRES SW(7): ! NULL OPERATION ->STRES SUSE: ->STRES SW(9): ! INTEGER MODULUS OP1(DUPL) PLOADCONST(0) PJUMP(JIGE,GLABEL) OP1(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 OP1(DUPL) %IF CURRT_OPTYPE>X'31' %THENSTART OP1(IABS) PLOADCONST(X'7FFF') PPJ(JIGT,9) %FINISHELSESTART PLOADCONST(255) OP2(INOT,IAND) PPJ(JINZ,9) %FINISH %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 %THENSTART B1=RDFLOAT; B2=RGE; B3=RDNEG %FINISHELSESTART B1=RSFLOAT; B2=RGE; B3=RSNEG %FINISH FOP1(B1,D-FR0) FOP2(B2,OPND1_XB-FR0,D-FR0) PJUMP(JINZ,GLABEL) FOP2(B3,OPND1_XB-FR0,OPND1_XB-FR0) PLABEL(GLABEL) GLABEL=GLABEL+1 ->SUSE SW(12): ! FLOAT D=FINDREG(FRN) FOP1(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 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 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 %THENSTART; ! INTEGERS %IF CURRT_FLAGS&LOADOP1#0 %AND LRES=0 %THEN OP1(EXCH) ISTARSTAR %FINISHELSESTART STARSTAR; ! PLANT COMPLEX IN LINE ROUTINE %FINISH ->SUSE SW(14): ! DSIDED COMPARISONS ! COPY MIDDLE OPERAND(SIZE IN TABLE) %IF TYPE=1 %THENSTART GET WSP(D,2) OP1(DUPL) 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 WORKT==TRIPLES(CURRT_PUSE) WORKT_FLAGS=WORKT_FLAGS!LOADOP1; ! ENSURE ESTACK IS RIGHT WAY ROUND %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 OP1(C) %ELSESTART FOP2(C,OPND1_XB-FR0,OPND2_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=XTRA>>28; ! CURRENT DIMENSION D=XTRA>>24&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 OPND2_D=SCONST %START; ! DV KNOWN C=CTABLE(D) C=DRSSWOP(C) PLOADCONST(C) %FINISHELSESTART CHOP OPERAND(OPND2,x'51',0) LRES=LOAD(OPND2) OPIND(LDW,0) %FINISH OP1(IADD) %FINISH ->STRES SW(19): ! ARRAY INDEX DACC=XTRA>>20 %IF DACC>0 %START; ! NORMAL CASE EL SIZE KNOWN CHOP OPERAND(OPND2,x'51',4); ! array base LRES=LOAD(OPND2) %IF DACC>=2 %THEN OP1(EXCH) %IF DACC<=1 %THEN OP1(INDEX1) %ELSEIF DACC=2 %THEN OP1(INDEX2) %ELSEIF DACC=4 %THEN OP1(INDEX4) %ELSEIF %C DACC=8 %THEN OP1(INDEX8) %ELSE PLOADCONST(DACC) %AND OP1(INDEX) %FINISHELSESTART; ! RARE CASE GO TO DV FOR SIZE ! ONLY FOR ACCESS OF STRING&RECORD ! ARRAYNAMES LRES=LOAD(OPND2); ! full head dvptr on top OPIND(LDH,6); ! el size halfword out of dv OP3(IPUSH,EXCH,IPOP) OP1(INDEX) %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 %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 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) %FINISHELSESTART LOADPTR(OPND1,OPND1) LRES=LOAD(OPND2) %IF TYPE#2 %AND (LRES>0 %OR (CURRT_FLAGS&LOADOP1=0 %AND COMM=1)) %THEN OP1(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) %IF CURRT_PUSE=CURRT_FLINK %AND OPND2_XB=ESTK %THEN OP1(DUPL) DSTORE(OPND2_XB,D,OPND1_D>>16,OPND1_D&X'FFFF') OPND1_FLAG=7; OPND1_XB=OPND2_XB; ! IN CASE USED AGAIN %IF CURRT_PUSE#CURRT_FLINK %THEN CURRT_FLAGS=CURRT_FLAGS!NOTINREG ! FORCE RELOAD FROM STORE IN ALL BUT ! BUT ONE SIMPLE CASE %FOR D=FR0,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' %FINISHELSESTART C=OPND1_XB ! %IF CURRT_OPTYPE=X'52' %THEN B1=RSTEST %ELSE B1=RDTEST FOP1(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 OP1(NULL) %ELSEIF D>0 %OR CURRT_OPERN=CLSHIFT %THEN %C PLOADCONST(D) %AND OP1(ISHLL) %ELSE PLOADCONST(D) %AND OP1(ISHLA) %CONTINUE TRIPSW(73): ! OPERATE AND ASSIGN OPERATION ! PRODUCED BY PNX OPT PASS ONLY IMPABORT 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(2): ! RESET STACK PTR TO SAVED VAL DFETCH(ESTK,4,CURRINF_RBASE,OPND1_D) OP1(SFA) OP1(ISUB) OP1(ASF) %CONTINUE TRIPSW(3): ! SAVE STACK POINTER ! OPND1 IS TEMPORARY(16 BITS) FOR SAVE OP1(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 %THEN PLOADCONST(D) %AND OP1(IMULT) 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) %ELSESTART B1=0 %FOR JJ=1,1,XTRA>>16 %CYCLE %IF C&(1<1 %THENSTART DFETCH(ESTK,4,CURRINF_RBASE,D-12*JJ+4) OP1(IMULT) %FINISH %IF B1>0 %THEN OP1(IADD) B1=B1+1; ! COUNT PRODUCTS %FINISH %REPEAT OP1(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) OP1(DUPL) DSTORE(ESTK,4,CURRINF_RBASE,D) %IF OPND1_D#1 %THEN PLOADCONST(OPND1_D-1) %AND OP1(ISUB) %FINISHELSESTART LRES=LOAD(OPND1)<<1!LOAD(OPND2) %IF LRES=B'10' %THEN OP1(EXCH) OP1(DUPL) DSTORE(ESTK,4,CURRINF_RBASE,D) OP2(EXCH,DUPL) DSTORE(ESTK,4,CURRINF_RBASE,D-4) OP1(ISUB); PLOADCONST(1); OP1(IADD) %FINISH C=XTRA>>24&255; ! CURRENT DIMENSION %IF C>1 %START; ! MULTPLY UP BY LOWER RNAGES DFETCH(ESTK,4,CURRINF_RBASE,D+4) OP1(IMULT) %FINISH OP1(DUPL) 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 OPDIR(LDA,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=DRSSWOP(C) C=(C+3)&(-4); ! TO 64 BIT BNDRY PLOADCONST(-C) OP1(ASF) %FINISHELSESTART; ! DYNAMIC NEEDS LOOP ! DFETCH(ESTK,4,CURRINF_RBASE,OPND1_D&X'FFFF'-8) PLOADCONST(3); OP1(IADD) PLOADCONST(-4) OP1(IAND); OP1(INEG); OP1(ASF) %FINISH %FINISH OP1(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(JIZ,11); ! USING ZERO=FALSE EQUIVALENCE %CONTINUE TRIPSW(7): ! FOR PREAMBLE LRES=LOAD(OPND1); ! FORCE INITIAL TO ESTACK %CONTINUE TRIPSW(8): ! FOR POSTAMBLE OP1(DISCARD) %CONTINUE TRIPSW(9): ! VALIDATE FOR LRES=LOAD(OPND1) LRES=LOAD(OPND2) OP1(IREM) PPJ(JINZ,11); ! USING ZERO=FALSE EQIVALENCE %CONTINUE TRIPSW(10): ! BACK JUMP _X1 HAS TF&MASK ! OPND1_XTRA HAS LABEL CELL LCELL==ASLIST(OPND1_XTRA) D=XTRA; ! 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(XTRA) 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) %FINISHELSESTART C=LCELL_S2>>16 REDUCE ENV(C); ! LATER USE MUST MERGE %FINISH LCELL_S2=C<<16!(LCELL_S2&X'FFFF') %FINISH %CONTINUE TRIPSW(12): ! REMOVE LABEL %BEGIN %INTEGER S1,S2,S3 %INTEGERNAME CELL CELL==CURRINF_LABEL %WHILE CELL>0 %CYCLE %IF ASLIST(CELL)_S3=OPND1_D %THEN POP(CELL,S1,S2,S3) %ANDEXIT CELL==ASLIST(CELL)_LINK %REPEAT 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) %ELSESTART C=LCELL_S2>>16 %IF D&4=0 %THEN REDUCE ENV(C); ! MERGE WITH CURRENT RESTORE(C) %FINISH LCELL_S2=0; ! NO JUMPLIST&NO ENVIRONMENT %CONTINUE TRIPSW(14): ! FOR 2ND PREAMBLE ! MAY BE UNNECESSARY OP1(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 %THENSTART C=0 TCELL==ASLIST(TAGS(OPND1_D)) H=TCELL_SNDISP %FINISHELSE C=1 %IF H=0 %THEN H=-1 %IF OPND1_XTRA#0 %THEN PPROC(STRING(OPND1_XTRA),CURRINF_RBASE<<16!C<<1!1,H) %ELSEIF OPND1_D>=0 %THEN %C PPROC(STRING(ADDR(WORKA_LETT(WORKA_WORD(OPND1_D)))),CURRINF_RBASE<<16,H) %IF OPND1_D>=0 %THEN TCELL_SNDISP=H %END %CONTINUE TRIPSW(67): ! RDISPLY CREATE DISPLAY FORGET(-1) D=CURRINF_RBASE %CONTINUE TRIPSW(16): ! RDAREA - INITIALISE DAIGS AREA ! OPND1_D=N FOR DIAGS AREA OPDIR(LDW,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 (WORKT_OPERN=BJUMP %AND WORKT_X1&15=15) %IF PARM_OPT#0 %THEN PLOADCONST(21) %AND PPJ(0,2) %CONTINUE TRIPSW(19): ! RTXIT - "%RETURN" %IF OPND1_D=0 %START; ! JUMP TO END FOR RETURNS PROTEM ! TILL REGISTER RESTORING SOLVED PJUMP(JUMP,CURRINF_ENTRYAD) %FINISHELSESTART PLABEL(CURRINF_ENTRYAD); ! ENTRAD HOLDS LAB FOR RETURN OP1(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 PRECALL PLOADCONST(0) OP1(IPUSH) PLOADCONST(0) OP1(IPUSH) PPJ(0,2) FORGET(-1) %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 OP1(DUPL); OPIND(LDB,0) LRES=LOAD(OPND1) OP1(EXCH); PLOADCONST(2); OP1(IADD) OP1(MVB) 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) PRECALL OP1(IPUSH) LRES=LOAD(OPND1) OP1(IPUSH) PPJ(0,24) OPND1_FLAG=7; ! RESULT IS LOCAL %CONTINUE TRIPSW(39): ! GENERAL STRING ASSIGN LRES=LOAD(OPND1); ! PTR (2 WORDS) TO LHS %IF OPND2_FLAG=LCONST %THENSTART; ! CONST STRING ASSN %IF OPND2_XTRA=0 %START; ! CONST IS NULL OP1(DISCARD); PLOADCONST(0); OP1(EXCH); OPIND(STH,0) %FINISHELSESTART %IF PARM_OPT#0 %THEN OP1(EXCH) %ELSE OP1(DISCARD) LRES=LOAD(OPND2) OP1(EXCH) PLOADCONST(OPND2_XTRA+1) OP1(MVB) %IF PARM_OPT#0 %START PLOADCONST(OPND2_XTRA) PPJ(JILT,9) %FINISH %FINISH %FINISHELSESTART %IF CURRT_FLAGS&LOADOP2=0 %START; ! RHS(OP 2) FN OR MAP OP1(IPUSH) %FINISH %IF PARM_OPT#0 %THEN OP1(EXCH) %ELSE OP1(DISCARD) ! MAX LEN TO BTM FOR CHK OR DISCARDED %IF CURRT_FLAGS&LOADOP2=0 %THEN OP3(IPOP,DUPL,IPUSH) %ELSESTART LRES=LOAD(OPND2) OP2(DUPL,IPUSH); ! SOURCE BYTE ADDRE TO REG %FINISH OP1(EXCH); ! DEST OVER SOURCE FOR MVB OP1(IPOP); ! FURTHER COPY OF SOURCE OPIND(LDB,0) %IF PARM_OPT#0 %THEN OP2(DUPL,IPUSH) PLOADCONST(1); OP1(IADD); ! ASSIGN OP1(MVB) %IF PARM_OPT#0 %START; ! CHECK LENGTH OP1(IPOP); ! RETRIEVE CURRENT LENGTH PPJ(JILT,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') OPIND(STH,0) %FINISHELSESTART; ! ASSIGN CONSTANT STRING LRES=LOAD(OPND2) LRES=LOAD(OPND1) PLOADCONST(OPND2_XTRA+1) OP1(MVB) %FINISH %CONTINUE %FINISH LRES=LOAD(OPND2) OP2(DUPL,IPUSH) LRES=LOAD(OPND1) OP1(IPOP); OPIND(LDB,0); ! LENGTH OF RHS %IF PARM_OPT#0 %START OP1(DUPL) PLOADCONST(TCELL_ACC-1); ! LMAX PPJ(JIGT,9) %FINISH PLOADCONST(1) OP1(IADD) OP1(MVB) %CONTINUE TRIPSW(41): ! STRING JT VIA SUBROUTINE PRECALL LRES=LOAD(OPND1); ! SET BY GETPTR (IE LOADED) LRES=LRES<<1!LOAD(OPND2); ! MAY OR MAY NOT NEED LOADING %IF LRES=B'10' %THEN OP2(IPUSH,EXCH) %AND OP2(IPOP,EXCH) OP1(IPUSH); OP1(IPUSH) OP1(IPUSH) PPJ(0,18) %CONTINUE TRIPSW(46): ! STRING COMPARISONS INCL DSIDED BFFLAG=0 %IF OPND2_FLAG=LCONST %AND OPND2_XTRA=0 %THEN OPND==OPND1 %AND ->NULLSC %IF OPND1_FLAG=LCONST %AND OPND1_XTRA=0 %THEN OPND==OPND2 %AND BFFLAG=1 %AND ->NULLSC %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 D=FCOMP(XTRA+16*BFFLAG) %IF D=IEQ %OR D=INE %START; ! COMMON CASES IN LINE OP1(DUPL) OPIND(LDB,0) PLOADCONST(1) OP1(IADD) D=D+CPBEQ-IEQ %FINISHELSESTART PRECALL OP2(IPUSH,IPUSH) PPJ(0,28) PLOADCONST(0); ! RETURNED AS DIFFERENCE FROM ZERO %FINISH OP1(D) %CONTINUE NULLSC: ! TEST FOR A NULL STRING LRES=LOAD(OPND) OPIND(LDB,0); PLOADCONST(0); OP1(FCOMP(XTRA+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 OP1(DUPL) DSTORE(ESTK,4,CURRINF_RBASE,D); ! 32 BIT ADDR TO WK AREA OPIND(LDB,0) 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' PRECALL DFETCHAD(NO,4,CURRINF_RBASE,D+4) DFETCH(ESTK,4,CURRINF_RBASE,D) OP1(IPUSH); ! RESLN STRING ADDR STACKED OP1(IPUSH); ! POINTER TO BYTES USED IS STCKD %IF OPND2_FLAG=SCONST %START; ! NO STRING FOR FRAGMENT PLOADCONST(0); PLOADCONST(0); ! TWO ZERO WORD %FINISHELSE LRES=LOAD(OPND2); ! OR 2 POINTER WORDS OP1(IPUSH); OP1(IPUSH); ! ARE STACKED %CONTINUE TRIPSW(49): ! RESOLUTION ! OPND1 IS STRING RES EXPR ! OPND2 IS LABEL NO LRES=LOAD(OPND1) OP1(IPUSH) PPJ(0,16) %IF OPND2_D=0 %THEN PPJ(JIZ,12); ! UNCONDITIONAL FAILS ! NDAIG PARAMETER LEFT BY SUBROUITNE %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 %IF PARM_OPT#0 %THEN OP1(EXCH) %ELSE OP1(DISCARD) ! MAX LEN TO BTM FOR CHK OR DISCARDED OP1(DUPL); ! DEST(TWICE) OVER LMAX DFETCH(ESTK,4,CURRINF_RBASE,D) DFETCH(ESTK,4,CURRINF_RBASE,D+4) PLOADCONST(16); OP1(ISHRL); ! BYTES USED OP2(DUPL,IPUSH); OP2(IADD,EXCH); ! SOURCE UNDER DEST BUT OVER LMAX DFETCH(ESTK,4,CURRINF_RBASE,D+4); ! BYTESUSED<<16! ORIGINAL BYTES PLOADCONST(X'FFFF'); OP1(IAND); OP1(IPOP); ! FETCH BACK BYTES USED OP1(ISUB); ! LENGTH OF FINAL STRING OP2(DUPL,IPUSH); ! TO TEMP %IF PARM_OPT#0 %THEN OP2(DUPL,IPUSH); ! FOR CAP CHK PLOADCONST(1); OP1(IADD) OP1(MVB); ! CALL MOVE OVERLAPPING OP1(IPOP); OP1(EXCH); OPIND(STB,0); ! STORE LENGTH WITH SECOND COPY OF DEST %IF PARM_OPT#0 %START; ! CHECK CAPACITY OP1(IPOP) PPJ(JILT,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 %UNLESS OPND2_FLAG=SCONST %AND OPND2_D=0 %START; ! LENGTH = 0 OFFSET LRES=LOAD(OPND2) OP1(IADD) %FINISH %FINISHELSE OP1(EXCH) %AND OP1(IADD) CURRT_OPTYPE=X'51'; ! 32 BIT ADDRESS MAY NEED SAVING ->STRES !*********************************************************************** !* 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 D=0 %IF C>0 %THENSTART GET WSP(C,4) C=CURRINF_DISPLAY-(C+16) PSAVE(C,D) %FINISH PUSH(FPHEAD,FPPTR,C,D) PRECALL FPPTR=0 %CONTINUE TRIPSW(25): ! ROUTINE CALL (AFTER PARAMS) ! OPND1 HAS RT NAME TCELL==ASLIST(TAGS(OPND1_D)) JJ=PCALLPARAM(TCELL_PTYPE) %IF TCELL_UIOJ&15=14 %START; ! EXTERNAL CALL PCALL(TCELL_SNDISP,JJ,FPPTR) %FINISHELSEIF TCELL_PTYPE&X'400'#0 %START DFETCH(ESTK,8,TCELL_UIOJ>>4&15,TCELL_SNDISP) IMPABORT ! OP1(CALLT); ! CALL FORMAL PROCEDURE %FINISHELSESTART 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 PCALL(D,JJ,FPPTR) %FINISH POP(FPHEAD,FPPTR,C,D) %IF C#0 %START; ! ESTACK WAS SAVED PRESTORE(C,D,JJ&1) %FINISH 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) OP1(DUPL); OPIND(LDB,0) OPDIR(LDW,0,2+4*2); OP1(EXCH) PLOADCONST(1); OP1(IADD); OP1(MVB) OPDIR(LDW,0,2+4*2); ! 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 FOP2(D,0,OPND2_XB-FR0) REGS(OPND2_XB)_CL=0 %FINISHELSE 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 %THENSTART 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 PLOADCONST(-C); OP1(ASF) FPPTR=FPPTR+C LRES=LOAD(OPND2); ! PTR TO STRING %IF C<=32 %START; ! SHORT STRINGS OP1(SFA) PLOADCONST(C) %FINISHELSESTART; ! LONG STRINGS COMPUTE MOVE SIZE OP1(DUPL); OPIND(LDB,0); PLOADCONST(1) OP1(IADD); OP1(SFA); OP1(EXCH) %FINISH OP1(MVB) %IF PARM_OPT#0 %START OP1(SFA); OPIND(LDB,0); ! LENGTH FROM DEST PLOADCONST(D); ! FOR ASSNMNT CHECK PPJ(JIGE,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) PLOADCONST(-C); OP1(ASF) OP1(SFA) BULKM(D,C,0) FPPTR=FPPTR+C %FINISHELSESTART LRES=LOAD(OPND2) C=OPND1_PTYPE %IF C=X'62' %THENSTART FOP1(RDPUSHD,OPND2_XB-FR0) FPPTR=FPPTR+8 %FINISHELSEIF C=X'52' %THENSTART FOP1(RSPUSHS,OPND2_XB-FR0) FPPTR=FPPTR+4 %FINISHELSESTART ! %IF C=X'31' %THEN PLOADCONST(8) %AND OP1(ISHLL) OP1(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 OP1(EXCH); OP1(IPUSH) %FINISH OP1(IPUSH) FPPTR=FPPTR+4 %CONTINUE TRIPSW(32): ! PARAM PASSING(3) ARRAYS ! ALSO (4) PASS RT PARAM SAME CODE LRES=LOAD(OPND2) OP1(EXCH); OP1(IPUSH); OP1(IPUSH) FPPTR=FPPTR+8 %CONTINUE TRIPSW(69): ! PASS 6 STORE STR FN RES PTR ! OPND2_D HAS OFFSET PLOADCONST(255) LRES=LOAD(OPND2) OP1(IPUSH); OP1(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 OPDIR(LDA,TCELL_SNDISP,0); ! RT FIXUP AREA== RT ID NO %FINISHELSESTART 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 OPDIR(LDA,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) %FINISHELSESTART LRES=LOAD(OPND1); ! 32 BIT ADDRESS PLOADCONST(OPND2_D) OP1(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 %IF PARM_OPT#0 %THEN PLOADCONST(X'802') %AND PPJ(0,2) ! 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 OP1(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.49999999999999999; D=RDSUB %FINISHELSESTART COPND_R=0.49999999; D=RSSUB %FINISH LRES=LOAD(COPND) REGS(COPND_XB)_CL=0 FOP2(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 FOP1(RDROUND,OPND1_XB-FR0) %FINISHELSESTART FOP1(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) DSTORE(ESTK,1,CURRINF_RBASE,D+2) PLOADCONST(1) DSTORE(ESTK,1,CURRINF_RBASE,D+3) 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=RECORDELAD(TCELL,OPND1_PTYPE,OPND1_XTRA) DSTORE(ESTK,8,TCELL_UIOJ>>4&15,C) %FINISHELSESTART IMPABORT %UNLESS OPND1_FLAG=INDIRECT %OR OPND1_FLAG=REFTRIP %OR OPND1_FLAG=INDNAME %OR PARM_FAULTY#0 LRES=LOAD(OPND2) D=FINDREG(FRN) REGS(D)_USE=0 OP1(EXCH); OP1(IPUSH); OP1(IPUSH) FOP1(RDPOPD,D-FR0) %IF OPND1_FLAG=INDIRECT %AND OPND1_XTRA>0 %START PLOADCONST(OPND1_XTRA) OP1(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=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) %FINISHELSEIF D=4 %THEN OP1(EXCH) %ELSESTART OP1(IPUSH); OP1(EXCH); OP1(IPOP); OP1(EXCH) %FINISH %IF OPND1_FLAG=INDIRECT %AND OPND1_XTRA>0 %THEN PLOADCONST(OPND1_XTRA) %AND OP1(IADD) %IF OPND1_FLAG=INDNAME %THEN LOADAD(OPND1) INDSTORE(ESTK,D) %CONTINUE TRIPSW(62): ! RECORD ASSIGNMENT %IF OPND2_FLAG=SCONST %THENSTART LRES=LOAD(OPND1) BULKM(0,XTRA,OPND2_D) %CONTINUE %FINISH LRES=LOAD(OPND2) %IF CURRT_FLAGS&LOAD OP1=0 %THEN EXCHANGE(OPND1,OPND2) LRES=LOAD(OPND1) BULKM(1,XTRA,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 OP1(IADD); ! ADDITION ->STRES TRIPSW(65): ! AHADJ ARRAY MAPPING OPND1 1 ! HAS ADJUSTMENT OPND2 THE HEAD ! ARRAY PTYPE<<4!MODE IS IN XTRA 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 JJ=RECORDELAD(TCELL,OPND2_PTYPE,OPND2_XTRA) %FINISH %IF OPND2_FLAG=7 %THEN JJ=OPND2_D&X'FFFF' %AND D=OPND2_D>>16 %IF JJ#-1 %START; ! HEAD ACCESSIBLE AVOID COMPLEX ! ESTACH MANIPULATIONS %IF XTRA&1=0 %THENSTART FETCH LOW AD END(ESTK,D,JJ) %FINISHELSESTART FETCH HIGH AD END(ESTK,D,JJ) OP1(IADD) FETCH LOW AD END(ESTK,D,JJ) %FINISH %CONTINUE %FINISH LRES=LOAD(OPND2); ! ARRAY HEAD BEFORE ADJMNT %IF XTRA&1=0 %START; ! ARRAY MAPPING OPND1 IS BASE OP1(EXCH); OP1(DISCARD); ! DISCARD OLD BASE %FINISHELSESTART OP1(IPUSH) OP1(IADD); ! ADDRESSES ADDED OP1(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 OP1(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) %ELSE C=4 JJ=TCELL_SLINK+OPND1_XTRA %IF D=1 %THEN DFETCHAD(NO,C,TCELL_UIOJ>>4&15,JJ) %ELSEIF D=2 %THEN DSTORE(ESTK,C,TCELL_UIOJ>>4&15,JJ) %ELSE %C 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 OP1(DUPL) %FINISHELSESTART C=BYTES(OPND1_PTYPE>>4&15) %IF C<4 %THEN C=4 GET WSP(D,C>>2) %IF OPND1_XB=ESTK %THEN OP1(DUPL) DSTORE(OPND1_XB,C,CURRINF_RBASE,D) OPND1_D=CURRINF_RBASE<<16!D OPND1_XTRA=M'DUPL' 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,PTYPE,TYPE,PREC %STRING (255) SVAL %LONGREAL RVAL %RECORD (RD) ROPND %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) OPDIR(LDA,CAREA,KK) %IF PREC=5 %THEN KK=RSLDIS %ELSE KK=RDLDID FOP1(KK,PREG-FR0) %FINISH ->LDED SCONST: ! STRING CONSTANT OPND_DIS AR PTR %IF HOST=EMAS %THEN SVAL=STRING(ADDR(WORKA_A(OPND_D))) %ELSESTART 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) OPDIR(LDA,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) %FINISHELSEIF TYPE=5 %THEN KK=STRINGLBAD(TCELL) %ELSE KK=TCELL_SLINK %IF TYPE=5 %THEN DFETCHAD(NO,1,TCELL_UIOJ>>4&15,KK&X'FFFF') %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 %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) %FINISHELSE 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) %AND OP1(IADD) ! ADDRESS OF POINTER NOW IN ESTK OPIND(LDW,0); ! 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 ROPND=OPND ROPND_PTYPE=REFTRIP_OPTYPE ROPND_FLAG=8 KK=LOAD(ROPND) %FINISH IFETCH: %IF TYPE=5 %START PLOADCONST(OPND_XTRA) %AND OP1(IADD) %IF OPND_XTRA>0 %FINISHELSEIF TYPE=1 %AND PREC=3 %START KK=OPND_XTRA ! KK=KK!!1 PLOADCONST(KK) %AND OP1(IADD) %UNLESS KK<=0 INDLOAD(ESTK,1) %FINISHELSESTART PLOADCONST(OPND_XTRA) %AND OP1(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 %THENSTART %IF OPND_XTRA=M'DUPL' %THEN DFETCH(PREG,4,B,D) %ELSE DFETCHAD(NO,1,B,D+OPND_XTRA-1) %FINISHELSESTART %IF OPND_XTRA=M'ARRH' %THEN FETCH HIGH AD END(PREG,B,D) %ELSE DFETCH(PREG,BYTES(PREC),B,D) %FINISH ->LDED SW(8): ! TRIPLE REFTRIP==TRIPLES(OPND_D) %IF TYPE#5 %AND 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 REGS(PREG)_AT=WTRIPNO %RESULT=0 %END %INTEGERFN PCALLPARAM(%INTEGER RTPTYPE) !*********************************************************************** !* PROVIDES THE RESULT DESCRIPTION FOR A CALL * !*********************************************************************** %INTEGER TYPE TYPE=RTPTYPE&7 %RESULT=0 %IF TYPE=0 %RESULT=X'401' %IF TYPE=3 %OR TYPE=5 %RESULT=BYTES(RTPTYPE>>4&15)<<8!TYPE %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 %THENRESULT=D INF==WORKA_LEVELINF(RLEVTOLEVEL(B)) X=INF_DISPLAY %IF D>4&15 %IF B=0 %THENRESULT=D+XDISP D=D+TCELL_ACC-XDISP %IF SPTYPE&7=5 %THENRESULT=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 OPIND(LDB,0); %RETURN SW(2): ! HALF OPIND(LDH,0); %RETURN SW(4): ! WORD %IF FR0<=REG<=FR3 %THEN FOP1(RSLDIS,REG-FR0) %ANDRETURN OPIND(LDW,0) %RETURN SW(8): ! LONGREAL %IF REG=ESTK %START; ! DOUBLE WORD IN ESTACK OP1(DUPL) OPIND(LDW,4); ! HIGH AD END OP1(EXCH) OPIND(LDW,0); ! SO LOW AD END ON TOP %FINISHELSE FOP1(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 OPIND(STB,0); %RETURN SW(2): ! HALF OPIND(STH,0); %RETURN SW(4): ! WORD %IF FR0<=REG<=FR3 %THEN FOP1(RSASSS,REG-FR0) %ANDRETURN OPIND(STW,0) %RETURN SW(8): ! LONGREAL %IF REG=ESTK %START; ! DOUBLE WORD IN ESTACK OP1(DUPL) OP1(IPUSH) OPIND(STW,0); ! LOW AD END FROM TOP OP1(IPOP) OPIND(STW,4); ! HIGH AD END FROM LOWER POSN %FINISHELSE FOP1(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 %RECORD (RD) ROPND %INTEGER B,D,X,K,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)) B=TCELL_UIOJ>>4&15 %IF TCELL_PTYPE&X'3FFF'=X'33' %THEN D=RECORDELAD(TCELL,PTYPE,X) %ELSEIF PTYPE&255=X'35' %THEN %C D=STRINGLBAD(TCELL) %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) %AND OP1(IADD) ! ADDRESS OF POINTER NOW IN ESTK OPIND(LDW,0); ! ADDRESS IN ESTACK ->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 %THENSTART ROPND=OPND ROPND_PTYPE=REFTRIP_OPTYPE ROPND_FLAG=8 LRES=LOAD(ROPND) %FINISH INC ADDR: ! X>=0 RECORD: X<0 POINTER %IF OPND_PTYPE&X'FF'=X'31' %AND X<0 %START; ! BYTE INTEGER ARRAYS %FINISHELSESTART; ! ALL OTHER ITEMS WORD ADDRESSES %IF X>0 %THEN PLOADCONST(X) %AND OP1(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 %RECORD (RD) ROPND %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' %THENSTART D=RECORDELAD(TCELL,PTYPE,X) %FINISHELSEIF PTYPE&255=X'35' %THEN D=STRINGLBAD(TCELL) %ELSE D=TCELL_SLINK %IF PTYPE&255=X'35' %THENSTART PTYPE=CURRT_X1>>16 DFETCHAD(NO,1,TCELL_UIOJ>>4&15,D&X'FFFF') ->STR %FINISH %IF PTYPE&255=X'31' %THEN 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) %AND OP1(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 %THENSTART ROPND=OPND ROPND_PTYPE=REFTRIP_OPTYPE ROPND_FLAG=8 LRES=LOAD(ROPND) %FINISH INC ADDR: ! FOR RECORD ELEMENTS %IF PTYPE&255=X'31' %START; ! BYTE POINTER WANTED ! X=X!!1 %IF X>0 %THEN PLOADCONST(X) %AND OP1(IADD) %FINISHELSESTART; ! WORD POINTER WANTED %IF X>0 %THEN PLOADCONST(X) %AND OP1(IADD) %FINISH STR: ! ORGANISE WORD2 OF STR PNTR ! OPND2_XTRA=BML<<16!DML ->LDED %UNLESS PTYPE&255=X'35'; ! ALL NON STRING %IF OPND2_FLAG=SCONST %THEN PLOADCONST(OPND2_D&X'FFFF'+1) %ELSESTART CHOP OPERAND(OPND2,x'51',0) LRES=LOAD(OPND2) ! FOR STRINGNAMES PTR NOW LOADED ! FR STRINGARRAYNAMES DVBASE NOW LDED ! HAVE TO EXTRACT ELSIZE AND DECREMENT BY 1 %IF PTYPE&X'300'#0 %THENSTART OPIND(LDH,6) PLOADCONST(1) OP1(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 * !*********************************************************************** %RECORD (RD) DOPND %INTEGER DVPOS,PR,CM DVPOS=-1 PR=OPND1_PTYPE>>4&15 CM=-1 %IF OPND2_FLAG=SCONST %THEN DVPOS=OPND2_D %ELSESTART CHOP OPERAND(OPND2,x'51',0); ! to dv ptr DOPND=OPND2; ! for second load if needed %FINISH %IF PARM_ARR#0 %START %IF DVPOS>0 %START; ! BOUND KNOWN PLOADCONST(DRSSWOP(CTABLE(DVPOS+3*C+1))) PLOADCONST(DRSSWOP(CTABLE(DVPOS+3*C))) %FINISHELSESTART LRES=LOAD(OPND2); ! fetch dv ptr OP1(DUPL) OPIND(LDW,12*C+4) OP1(EXCH) OPIND(LDW,12*C) %FINISH OP1(CHK) %FINISH %IF C#1 %START; ! ALL DIMENSION BAR 1ST %IF DVPOS>0 %THENSTART PLOADCONST(DRSSWOP(CTABLE(DVPOS+3*C-1))) %FINISHELSESTART LRES=LOAD(DOPND); ! fetch dv ptr OPIND(LDW,12*C-4); ! MULTIPLIER %FINISH OP1(IMULT) %FINISH %END %ROUTINE REXP !*********************************************************************** !* CALLS A PERM ROUTINE TO PERFORM REAL**REAL * !*********************************************************************** IMPABORT %END %ROUTINE SET DVREG(%INTEGER DVBD) !*********************************************************************** !* SET UP ETOS FOR A DOPEVECTOR IN ARRAY WHOSE HEAD B&D GIVEN * !*********************************************************************** FETCHLOW AD END(ESTK,DVBD>>16,DVBD&X'FFFF') %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 %THENRESULT=I %REPEAT %RESULT=-1 %END %ROUTINE CHOP OPERAND(%RECORD (RD) %NAME OPND, %INTEGER NEWPT,XOFFSET) !*********************************************************************** !* CHANGES RECORD OPERAND TO REFER TO A SMALLER BIT AT XOFFSET FROM * !* THE ORIGINAL START. USED TO LOAD ONE WORD OF STRING&ARRAY HEADERS* !* MUST COPE WITH GLA GOING FORWARD BUT STACK FRAMES GOING BACKWARDS* !*********************************************************************** %INTEGER OLDPT,S1,S2 %RECORD (TAGF) %NAME TCELL OLDPT=OPND_PTYPE&255 OPND_PTYPE=OPND_PTYPE&X'FF00'!NEWPT %IF OPND_FLAG=9 %THEN IMPABORT %IF XOFFSET<0 %THENRETURN %IF OPND_FLAG=DNAME %START TCELL==ASLIST(TAGS(OPND_D)) OPND_D=(TCELL_UIOJ>>4&15)<<16!TCELL_SLINK OPND_FLAG=LOCAL IR %FINISH %IF OPND_FLAG=INDIRECT %OR OPND_FLAG=INDNAME %THEN OPND_XTRA=OPND_XTRA&X'FFFF'+XOFFSET %IF OPND_FLAG=LOCALIR %THENSTART %IF OPND_D>>16=0 %THEN OPND_D=OPND_D+XOFFSET %ELSESTART S1=BYTES(OLDPT>>4) S2=BYTES(NEWPT>>4) OPND_D=OPND_D+S1-S2-XOFFSET %FINISH %FINISH %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 %THENRESULT=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 RLEVEL=CURRINF_RBASE %THEN LEVELCODE=1 %ELSE LEVELCODE=2 %IF SIZE=4 %START %IF FR0<=REG<=FR3 %THEN DFETCHAD(NO,4,RLEVEL,DISP) %AND FOP1(RSASSS,REG-FR0) %ANDRETURN %FINISH ->SW(8*LEVELCODE+SIZE) SW(*): ! FUNNY SIZES IMPABORT SW(1): ! GLOBAL BYTE STORE OPDIR(STB,2,DISP) %RETURN SW(9): ! LOCAL BYTE STORE OPDIR(STB,0,CURRINF_DISPLAY-(DISP+SIZE)) %RETURN SW(17): ! INTERMEDIATE BYTE STORE DFETCHAD(YES,SIZE,RLEVEL,DISP); ! SIMPLE WAY FOR NOW OPIND(STB,0) %RETURN SW(2): ! GLOBAL HALF STORE OPDIR(STH,2,DISP) %RETURN SW(10): ! LOCAL HALF STORE OPDIR(STH,0,CURRINF_DISPLAY-(DISP+SIZE)) %RETURN SW(18): ! INTERMEDIATE HALF STORE DFETCHAD(NO,SIZE,RLEVEL,DISP) OPIND(STH,0) %RETURN SW(4): ! GLOBAL WORD STORE OPDIR(STW,2,DISP) %RETURN SW(12): ! LOCAL WORD STORE OPDIR(STW,0,CURRINF_DISPLAY-(DISP+SIZE)) %RETURN SW(20): ! INTERMEDIATE WORD STORE INF==WORKA_LEVELINF(RLEVTOLEVEL(RLEVEL)) OPDIS(STW,0,-4*(RLEVEL+1),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) STORE HIGH AD END(ESTK,RLEVEL,DISP) %FINISHELSESTART DFETCHAD(NO,SIZE,RLEVEL,DISP) FOP1(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 %ELSEIF RLEVEL=CURRINF_RBASE %THEN LEVELCODE=1 %ELSE LEVELCODE=2 ->GENERAL %IF LEVELCODE=2 %IF LEVELCODE#0 %THEN OPDIS(LDW,0,CURRINF_DISPLAY-(DISP+4),0) %ELSE OPDIS(LDW,2,DISP,0) %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 OPDIR(LDA,2,DISP) %FINISHELSEIF RLEVEL=CURRINF_RBASE %START; ! CURRENT LOCAL LEVEL WDISP=DISP+SIZE-CURRINF_DISPLAY OPDIR(LDA,0,-WDISP) %FINISHELSESTART; ! INTERMEDIATE LEVEL INF==WORKA_LEVELINF(RLEVTOLEVEL(RLEVEL)) WDISP=(DISP+SIZE)-INF_DISPLAY OPDIS(LDA,0,-4*(RLEVEL+1),-WDISP) %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) FOP1(RSLDIS,REG-FR0) %RETURN %FINISH %IF RLEVEL=0 %THEN LEVELCODE=0 %ELSEIF RLEVEL=CURRINF_RBASE %THEN LEVELCODE=1 %ELSE LEVELCODE=2 ->SW(8*LEVELCODE+SIZE) SW(*): ! FUNNY SIZES IMPABORT SW(1): ! GLOBAL BYTE FETCH OPDIR(LDB,2,DISP) %RETURN SW(9): ! LOCAL BYTE FETCH OPDIR(LDB,0,CURRINF_DISPLAY-(DISP+SIZE)) %RETURN SW(17): ! INTERMEDIATE BYTE FETCH DFETCHAD(YES,SIZE,RLEVEL,DISP); ! SIMPLE WAY FOR NOW OPIND(LDB,0) %RETURN SW(2): ! GLOBAL HALF FETCH OPDIR(LDH,2,DISP); %RETURN SW(10): ! LOCAL HALF FETCH OPDIR(LDH,0,CURRINF_DISPLAY-(DISP+SIZE)) %RETURN SW(18): ! INTERMEDIATE HALF FETCH DFETCHAD(NO,SIZE,RLEVEL,DISP) OPIND(LDH,0) %RETURN SW(4): ! GLOBAL WORD FETCH OPDIR(LDW,2,DISP) %RETURN SW(12): ! LOCAL WORD FETCH OPDIR(LDW,0,CURRINF_DISPLAY-(DISP+SIZE)) %RETURN SW(20): ! INTERMEDIATE WORD FETCH INF==WORKA_LEVELINF(RLEVTOLEVEL(RLEVEL)) OPDIS(LDW,0,-4*(RLEVEL+1),INF_DISPLAY-(DISP+4)) %RETURN 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) %FINISHELSESTART DFETCHAD(NO,SIZE,RLEVEL,DISP) FOP1(RDLDID,REG-FR0) %FINISH %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=JIZ %RESULT=JINZ %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) %ANDRESULT=LASTREG IMPABORT %END %ROUTINE ISTARSTAR !*********************************************************************** !* PLANT IN LINE CODE FOR INTEGER****INTEGER * !* IN LINE CODE RATHER THAN SUBROUTINE BECAUSE OF NO JLK * !*********************************************************************** %INTEGER EXPWORD,RESWORD,LBASE LBASE=GLABEL; GLABEL=GLABEL+4 GET WSP(EXPWORD,1) GET WSP(RESWORD,1) ! ! CODE PLANTED IS AS FOLLOWS ! ! DUPL, ST EXPWORD, JIGEZ L0 COPY ORIGINAL SIGNED EXPONENT ! CALL PLABS7, ! ILLEGAL !L0 LCONST 1, ST RESWORD 1 TO RESULT WORD !L1 L EXPWORD, LCONST 1 ! ILAND, JIZ L2 USES ZERO=FALSE EQUIVALENCE ! DUPL, L RESWORD ! IMULT, ST RESWORD !L2 L EXPWORD, ISHL -1, DUPL ! ST EXPWORD ! JIZ L3 FINISHED USES ZERO=FALSE ! DUPL, IMULT, JUMP L1 SQUARE AND CONTINUE !L3 ERASE DISCARD SQUARED EXPONENT ! L RESWORD OBTAIN RESULT ! OP1(DUPL) DSTORE(ESTK,4,CURRINF_RBASE,EXPWORD) PJUMP(JIGEZ,LBASE) PPJ(0,7) PLABEL(LBASE) PLOADCONST(1) DSTORE(ESTK,4,CURRINF_RBASE,RESWORD) PLABEL(LBASE+1) DFETCH(ESTK,4,CURRINF_RBASE,EXPWORD) PLOADCONST(1); OP1(IAND) PJUMP(JIZ,LBASE+2) OP1(DUPL) DFETCH(ESTK,4,CURRINF_RBASE,RESWORD) OP1(IMULT) DSTORE(ESTK,4,CURRINF_RBASE,RESWORD) PLABEL(LBASE+2) DFETCH(ESTK,4,CURRINF_RBASE,EXPWORD) PLOADCONST(1) OP1(ISHRL) OP1(DUPL) DSTORE(ESTK,4,CURRINF_RBASE,EXPWORD) PJUMP(JIZ,LBASE+3) OP1(DUPL) OP1(IMULT) PJUMP(JUMP,LBASE+1) PLABEL(LBASE+3) OP1(DISCARD) DFETCH(ESTK,4,CURRINF_RBASE,RESWORD) %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) FORGET(OREG) 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 %FINISHELSESTART MOP=RSMULT; DOP=RSDIV FLOP=RSFLOAT; COPOP=RSCPY %FINISH ! ! CODE PLANTED IS AS FOLLOWS ! ! DUPL, DUPL, JIGEZ L0 COPY ORIGINAL SIGNED EXPONENT ! INEG, !L0 LCONST 1, FLOAT 1 1 TO WORK REG !L1 DUPL, LCONST 1 ! ILAND, JIZ L2 USES ZERO=FALSE EQUIVALENCE ! RMULT WREG,OREG !L2 ISHL -1, DUPL ! JIZ L3 FINISHED USES ZERO=FALSE ! RMULT OREG,OREG, JUMP L1 SQUARE AND CONTINUE !L3 ERASE EXPOSE ORIGINAL SIGNED EXPONENT ! RCOPY OREG,WREG COPY RESULT TO ORIGINAL ! JIGEZ L4 ! LCONST 1, FLOAT OREG ! RDIV OREG,WREG INVERT !L4 ! OP1(DUPL); OP1(DUPL) PJUMP(JIGEZ,LBASE) OP1(INEG) PLABEL(LBASE) PLOADCONST(1) FOP1(FLOP,WREG) PLABEL(LBASE+1) OP1(DUPL) PLOADCONST(1); OP1(IAND) PJUMP(JIZ,LBASE+2) FOP2(MOP,WREG,OREG) PLABEL(LBASE+2) PLOADCONST(1) OP1(ISHRL) OP1(DUPL) PJUMP(JIZ,LBASE+3) FOP2(MOP,OREG,OREG) PJUMP(JUMP,LBASE+1) PLABEL(LBASE+3) OP1(DISCARD) FOP2(COPOP,OREG,WREG) PJUMP(JIGEZ,LBASE+4) PLOADCONST(1) FOP1(FLOP,OREG) FOP2(DOP,OREG,WREG) PLABEL(LBASE+4) %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 %FINISHELSESTART MULT=RSMULT; PUSH=RSPUSHS; POP=RSPOPS %FINISH %WHILE I>1 %CYCLE %IF I&1#0 %START FOP1(PUSH,REG) MULTS=MULTS+1 %FINISH FOP2(MULT,REG,REG) I=I>>1 %REPEAT %IF MULTS=0 %THENRETURN; ! **2,**4 ETC WREG=FINDREG(FRN) FORGET(WREG) WREG=WREG-FR0 %WHILE MULTS>0 %CYCLE MULTS=MULTS-1 FOP1(POP,WREG) FOP2(MULT,REG,WREG) %REPEAT %RETURN INTEXP: %WHILE I>1 %CYCLE %IF I&1#0 %START; ! PRESERVE THIS POWER FOR LATER OP1(DUPL) OP1(IPUSH) %UNLESS MULTS=0; ! USE ONLY 3 ESTACK CELLS MULTS=MULTS+1 %FINISH OP1(DUPL); OP1(IMULT) I=I>>1 %REPEAT %WHILE MULTS>0 %CYCLE MULTS=MULTS-1 OP1(IPOP) %UNLESS MULTS=0 OP1(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,X,ID C=CURRT_DPTH SAVE IRS PRECALL OP1(IPUSH) PLOADCONST(N) OP1(IPUSH) %IF C>0 %START; ! OFFLOAD ESTACK GET WSP(C,4) C=CURRINF_DISPLAY-(C+16) PSAVE(C,ID) %FINISH %IF 1<