%INCLUDE "ERCC07.TRIMP_HOSTCODES" %CONSTINTEGER HOST=EMAS %CONSTINTEGER TARGET=PERQ %INCLUDE "ERCC07.PERQCODE1S" %INCLUDE "ERCC07.TRIPCNSTS" %INCLUDE "ERCC07.TRIMP_TFORM1S" %IF HOST=PERQ %OR HOST=ACCENT %OR HOST=IBM %OR HOST=IBMXA %START %RECORDFORMAT RTDICTF(%SHORTINTEGER PS,RPS,LTS,ENTRY,EXIT, LL,W7,W8,DIAGS,W10,%INTEGER W1112) %FINISH %ELSE %START %RECORDFORMAT RTDICTF(%HALFINTEGER PS,RPS,LTS,ENTRY,EXIT, LL,W7,W8,DIAGS,W10,%INTEGER W1112) %FINISH %OWNINTEGER CABUF,GLACABUF %OWNINTEGERNAME CA,GLACA %OWNINTEGER PPCURR,GLACURR %OWNBYTEINTEGERARRAY CODE(0:268) %OWNBYTEINTEGERARRAY GLABUF(0:268) %OWNINTEGERARRAYNAME CTABLE,TAGS %OWNRECORD(LISTF)%ARRAYNAME ASLIST %EXTRINSICRECORD(WORKAF)WORKA %EXTRINSICRECORD(PARMF) PARM %EXTRINSICINTEGERARRAY CAS(0:10) %EXTERNALROUTINESPEC FLAGAND FOLD(%RECORD(TRIPF)%ARRAYNAME T) %SYSTEMINTEGERMAPSPEC COMREG(%INTEGER N) %DYNAMICROUTINESPEC QCODE(%INTEGER A,B,C,MODE) %DYNAMICROUTINESPEC QPUT(%INTEGER A,B,C,D) !%EXTERNALSTRING(255)%FNSPEC PRINTNAME(%INTEGER N) %EXTERNALROUTINESPEC FAULT(%INTEGER I,J,K) %EXTERNALROUTINESPEC PRINT TRIPS(%RECORD(TRIPF)%ARRAYNAME TRIPS) %EXTERNALROUTINESPEC PRINT THIS TRIP(%RECORD(TRIPF)%ARRAYNAME T, %INTEGER I) %ROUTINESPEC CNOP(%INTEGER I,J) %ROUTINESPEC REFORMATC(%RECORD(RD)%NAME OPND) %ROUTINESPEC RELOCATE(%INTEGER A,B,C) %ROUTINESPEC CHANGESEX(%INTEGER A,B,C) %ROUTINESPEC IMPABORT %ROUTINESPEC GXREF(%STRING(31) NAME,%INTEGER MODE,XTRA,AT) %EXTERNALROUTINESPEC MOVE BYTES(%INTEGER L,FBASE,FOFF,TOBASE,TOOFF) %ROUTINESPEC DEFINE EP(%STRING(255) NAME,%INTEGER AREA,AT,MAINORMIN) %EXTERNALSTRING(255)%FNSPEC UCSTRING(%STRING(255) STR) %%EXTERNALROUTINESPEC POP(%INTEGERNAME A,B,C,D) %%EXTERNALROUTINESPEC PRHEX(%INTEGER VALUE,PLACES) %EXTERNALROUTINESPEC PUSH(%INTEGERNAME HEAD,%INTEGER A,B,C) %CONSTINTEGER CODEBNDRY=X'1FF'; ! INSTRUCTIONS MUST NOT ! CROSS THIS IN ACCENT MODE %CONSTBYTEINTEGERARRAY BYTES(0:7)=0(3),1,2,4,8,16; %CONSTBYTEINTEGERARRAY WORDS(0:7)=0(3),1,1,2,4,8; %CONSTINTEGER DAREA=6; ! AREA FOR DIAG TABLES %CONSTSTRING(8)MDEP="S#NDIAG" ! ! 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 RESERVED (BUT IN MAIN PROGS IS FILLED WITH STACKPTR@ENTRY) ! 24-27 ADDRESS OF CONSTANT TABL ! 28-31 ADDRESS OF A WORD CONTAINING STACKTOP 0FOR NO CHECKS ! 32-35 HOLDS M'IDIA' FOR DIAGNOSTIC IDENTIFICATION ! 36-39 FREE ! 40-55 DEFINES THE ENTRY POINT OF MDIAGS ! %CONSTINTEGER FIXEDGLALEN=56 %IF HOST=EMAS %OR HOST=IBM %OR HOST=IBMXA %START %OWNINTEGERARRAY FIXED GLA(0:FIXEDGLALEN>>2-1)=M'IMP ',M'GLAP', 0(6),M'IDIA',0(*); %FINISH %ELSE %START %OWNINTEGERARRAY FIXED GLA(0:FIXEDGLALEN>>2-1)=M'P IM',M'APGL', 0(6),M'IAID',0(*); %FINISH ! !*********************************************************************** !* 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 * !************************************************************************ PPCURR=0; GLACURR=0 CABUF=0; GLACABUF=0 QPUT(0,0,0,0); ! OPEN OBJECT FILE %END %ROUTINE RECODE(%INTEGER S,F,AD) %IF S#F %START PRINTSTRING(" CODE FOR LINE"); WRITE(WORKA_LINE,5) QCODE(S,F,AD,16) NEWLINE %FINISH %END !*DELEND %EXTERNALROUTINE CODEOUT %IF PPCURR>0 %THEN %START !*DELSTART RECODE(ADDR(CODE(0)), ADDR(CODE(PPCURR)), CABUF) %C %IF PARM_DCOMP#0 !*DELEND QPUT(41, PPCURR, CABUF, ADDR(CODE(0))) %IF PARM_INHCODE=0 PPCURR=0; CABUF=CA %FINISH %END %ROUTINE PWORD(%INTEGER WORD) !*********************************************************************** !* ADD A WORD(16 BITS) TO CODE FLIPPING HALFS AS NEEDED * !*********************************************************************** %IF (CA+1)&CODEBNDRY<1 %THEN CNOP(0,8) CODE(PPCURR)<-WORD CODE(PPCURR+1)<-WORD>>8 PPCURR=PPCURR+2 CA=CA+2 CODEOUT %IF PPCURR>=256 %END %ROUTINE PB1(%INTEGER OPCODE) !*********************************************************************** !* ADD A SINGLE BYTE INSTRUCTION TO THE CODE * !*********************************************************************** CODE(PPCURR)=OPCODE PPCURR=PPCURR+1 CA=CA+1 CODEOUT %IF PPCURR>=256 %END %ROUTINE PB2(%INTEGER OPCODE,BYTE) !*********************************************************************** !* ADD AN INSTRUCTION WITH ONE BYTE OPERAND TO THE CODE * !*********************************************************************** %IF OPCODE=LDCB %AND 0<=BYTE<=15 %THEN PB1(LDC0+BYTE) %AND %RETURN %IF OPCODE=LDLB %AND 0<=BYTE<=15 %THEN PB1(LDL0+BYTE) %AND %RETURN %IF OPCODE=LDOB %AND 0<=BYTE<=15 %THEN PB1(LDO0+BYTE) %AND %RETURN %IF OPCODE=STLB %AND 0<=BYTE<=7 %THEN PB1(STL0+BYTE) %AND %RETURN %IF OPCODE=STOB %AND 0<=BYTE<=7 %THEN PB1(STO0+BYTE) %AND %RETURN %IF OPCODE=INDB %AND 0<=BYTE<=7 %THEN PB1(SIND0+BYTE) %AND %RETURN %IF OPCODE=IXAB %AND 0=256 %END %ROUTINE PB3(%INTEGER OPCODE,BYTE1,BYTE2) !*********************************************************************** !* ADD AN INSTRUCTION WITH TWO ONE BYTE OPERANDS TO THE CODE * !*********************************************************************** %IF (CA+2)&CODEBNDRY<2 %THEN CNOP(0,8) CODE(PPCURR)=OPCODE CODE(PPCURR+1)<-BYTE1 CODE(PPCURR+2)<-BYTE2 PPCURR=PPCURR+3 CA=CA+3 CODEOUT %IF PPCURR>=256 %END %ROUTINE PB4(%INTEGER OPCODE,BYTE1,BYTE2,BYTE3) !*********************************************************************** !* PLANTS 4 BYTES INTO CODE WITHOUT CHECKING ANYTHING * !*********************************************************************** %IF (CA+3)&CODEBNDRY<3 %THEN CNOP(0,8) CODE(PPCURR)=OPCODE CODE(PPCURR+1)<-BYTE1 CODE(PPCURR+2)<-BYTE2 CODE(PPCURR+3)<-BYTE3 PPCURR=PPCURR+4 CA=CA+4 CODEOUT %IF PPCURR>=256 %END %ROUTINE PBW(%INTEGER OPCODE,WORD) !*********************************************************************** !* PUT AN INSTRUCTION WITH ONE (FLIPPED) WORD OPERAND INTO THE CODE * !*********************************************************************** %IF 0<=WORD<=255 %START %IF OPCODE=LDOW %OR OPCODE=LDLW %OR %C OPCODE=STOW %OR OPCODE=STLW %OR OPCODE=INDW %C %THEN PB2(OPCODE-1,WORD) %AND %RETURN %IF OPCODE=LLAW %OR OPCODE=LOAW %OR OPCODE=LDLDW %C %OR OPCODE=LDODW %OR OPCODE=STLDW %OR OPCODE=STODW %C %OR OPCODE=INCW %THEN PB2(OPCODE-1,WORD) %AND %RETURN %FINISH %IF (-128<=WORD<=127 %OR X'FF80'<=WORD<=X'FFFF') %AND OPCODE=LDCW %THEN %C PB2(LDCB,WORD) %AND %RETURN %IF (CA+2)&CODEBNDRY<2 %THEN CNOP(0,8) CODE(PPCURR)=OPCODE CODE(PPCURR+1)<-WORD CODE(PPCURR+2)<-WORD>>8 PPCURR=PPCURR+3 CA=CA+3 CODEOUT %IF PPCURR>=256 %END %ROUTINE PWW(%INTEGER OPCODE,W1,W2) !*********************************************************************** !* PLANT OPCODE FOLLOWED BY TWO BYTE FLIPPED WORDS * !* USED ONLY FOR LDDC AND LVRD * !*********************************************************************** %IF (CA+4)&CODEBNDRY<4 %THEN CNOP(0,8) CODE(PPCURR)=OPCODE CODE(PPCURR+1)<-W1 CODE(PPCURR+2)<-W1>>8 CODE(PPCURR+3)<-W2 CODE(PPCURR+4)<-W2>>8 PPCURR=PPCURR+5 CA=CA+5 CODEOUT %IF PPCURR>=256 %END %ROUTINE PLW(%INTEGER OPCODE,LW) !*********************************************************************** !* PLANT AN OPERATION WITH 32 BIT OPERAND. DESIGNED FOR LDDC * !*********************************************************************** %INTEGER W1,W2 W1=LW>>16 W2=LW&X'FFFF' %IF OPCODE=LDDC %START %IF W1=W2 %THEN PBW(LDCW,W1) %AND PB1(REPL) %AND %RETURN %IF W1=0 %THEN PB1(LDC0) %AND PBW(LDCW,W2) %AND %RETURN %IF W1=X'FFFF' %THEN PB1(LDCMO) %AND PBW(LDCW,W2) %AND %RETURN %FINISH PWW(OPCODE,W1,W2) %END %ROUTINE PB2W(%INTEGER OPCODE,BYTE1,WORD) !*********************************************************************** !* PUT AN INSTRUCTION WITH BYTE&WORD PARAMETERS IN THE CODE * !*********************************************************************** %IF 0<=WORD<=255 %AND (OPCODE=LDIW %OR OPCODE=LIAW %OR %C OPCODE=STIW) %THEN PB3(OPCODE-1,BYTE1,WORD) %AND %RETURN %IF (CA+3)&CODEBNDRY<3 %THEN CNOP(0,8) CODE(PPCURR)=OPCODE CODE(PPCURR+1)<-BYTE1 CODE(PPCURR+2)<-WORD CODE(PPCURR+3)<-WORD>>8 PPCURR=PPCURR+4 CA=CA+4 CODEOUT %IF PPCURR>=256 %END %ROUTINE PTLATE(%INTEGER DEPTH) !*********************************************************************** !* SELECT A SUITABLE TRANSLATE INSTRUCTION * !*********************************************************************** %IF 1<=DEPTH<=3 %THEN PB1(TLATE1+DEPTH-1) %ELSE %C PB2(STLATE,DEPTH*16) %END %ROUTINE PERM !*********************************************************************** !* EX KDF9 ROUTINE REARRANGE ESTACK FROM ABC TO BCA * !*********************************************************************** PB1(EXCH); ! BAC PB1(MMS); ! AC PB1(EXCH); ! CA PB1(MES); ! BCA %END %ROUTINE CAB !*********************************************************************** !* EX KDF9 ROUTINE REARRANGE ESTACK FROM ABC TO CAB !*********************************************************************** PB1(MMS); ! BC PB1(EXCH); ! CB PB1(MES); ! ACB PB1(EXCH); ! CAB %END %ROUTINE CNOP(%INTEGER I, J) PB1(NOOP) %WHILE CA&(J-1)#I %END %EXTERNALROUTINE PGLA(%INTEGER BDRY, L, INF ADR) %INTEGER I, J J=GLACA; GLACA=(J+BDRY-1)&(-BDRY) GLACURR=GLACURR+GLACA-J; ! COMPLETE THE ROUNDING %IF L+GLACURR>256 %THEN %START %IF PARM_INHCODE=0 %C %THEN QPUT(42, GLACURR, GLACABUF, ADDR(GLABUF(0))) GLACURR=0; GLACABUF=GLACA %FINISH MOVE BYTES(L,INF ADR,0,ADDR(GLABUF(0)),GLACURR) GLACA=GLACA+L; GLACURR=GLACURR+L %END %EXTERNALROUTINE PDATA(%INTEGER AREA,BNDRY,L,AD) !************************************************************************ !* ADDS L(BYTES) TO AREA FOR UST,SST AND DIAGS AREAS * !* L MAY BE REPETITION<<16! BASIC LENGTH * !************************************************************************ %INTEGERNAME PTR PTR==CAS(AREA) PTR=(PTR+BNDRY-1)&(-BNDRY) QPUT(40+AREA,L,PTR,AD) %IF PARM_INHCODE=0 PTR=PTR+L %END %EXTERNALROUTINE PRDATA(%INTEGER AREA,BNDRY,L,REP,AD) !*********************************************************************** !* ADDS L(BYTES) REP TIMES TO AREA FOR UST,SST AND DIAGS AREAS * !*********************************************************************** %INTEGERNAME PTR PTR==CAS(AREA) PTR=(PTR+BNDRY-1)&(-BNDRY) IMPABORT %IF L>X'7FFF' %OR REP>X'7FFF' QPUT(40+AREA,REP<<16!L,PTR,AD) PTR=PTR+REP*L %END %EXTERNALINTEGERFN PINITOWN(%INTEGER PTYPE,ACC,%RECORD(RD)%NAME INIT, %STRINGNAME YNAME) !*********************************************************************** !* PUTS AN INITIALISED OWN INTO THE GLA. SHOULD DEAL WITH ALL TYPES * !*********************************************************************** %RECORD(RD)OPND %INTEGER PREC,TYPE,RL,RES,X,LITL,I %STRING(255)XNAME %IF HOST=PERQ %OR HOST=ACCENT %OR HOST=IBM %OR HOST=IBMXA %START %SHORTINTEGER AH0,AH1,AH2,AH3 %FINISH %ELSE %START %HALFINTEGER AH0,AH1,AH2,AH3 %FINISH %STRING(255)IS XNAME=UCSTRING(YNAME) TYPE=PTYPE&7 PREC=PTYPE>>4&7 LITL=PTYPE>>14&3 OPND=INIT AH0<-OPND_D>>16 AH1<-OPND_D AH2<-OPND_XTRA>>16 AH3<-OPND_XTRA %IF PTYPE&X'400'#0 %START; ! OWN NAMES PGLA(4,0,ADDR(IS)) RES=GLACA %IF TYPE=5 %START; ! OWNSTRINGNAMES ! HAVE LENGTH @LOW AD END ! AND ADDR AT HIGH AD END ! IN ESTACK LENGTH IS ON TOP AH2=ACC-1; AH3=0 PGLA(4,8,ADDR(AH0)) %FINISH %ELSE %START PGLA(4,4,ADDR(AH0)) %FINISH %IF LITL=3 %START; ! EXTRINSICS ARE NAMES GXREF(XNAME,2,2<<24!ACC,RES) %FINISH ->END %FINISH %IF TYPE<=2 %THEN OPND_PTYPE=PTYPE&255 %AND REFORMATC(OPND) RL=BYTES(PREC) %IF TYPE=5 %THEN RL=2 %IF TYPE=3 %THEN RL=4 %IF RL>4 %THEN RL=4 %IF TYPE=1 %AND PREC=3 %THEN RL=2;! ALIGN TO A HALF FOR BYTES PGLA(RL,0,ADDR(IS)); ! ROUND RES=GLACA %IF TYPE=3 %OR (TYPE=5 %AND OPND_D=0) %START PGLA(RL,2,ADDR(AH0)) %FOR X=1,1,(ACC+1)>>1 ->END %FINISH %IF TYPE=5 %THEN %START ACC=(ACC+1)&(-2); ! ROUND UP BEFORE BYTE SWAPPING I=WORKA_A(OPND_D) LENGTH(IS)=I %FOR I=1,1,I %CYCLE CHARNO(IS,I)=WORKA_A(OPND_D+I) %REPEAT %IF HOST#TARGET %THEN CHANGE SEX(ADDR(IS),0,ACC) PGLA(RL,ACC,ADDR(IS)) %FINISH %ELSE %START PGLA(RL,ACC,ADDR(OPND_H0)) %IF ACC=1 %THEN PGLA(1,1,ADDR(OPND_H0));! FILL OUT SINGLE BYTE TO HALF %FINISH END: ! NOTE ENTRYT IF EXTERNAL %IF LITL=2 %THEN DEFINE EP(XNAME,2,RES,ACC) %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 HIGH ADDRESS END AND @A(FIRST) AT * !* THE LOW ADDRESS END. WHEN IN ESTACK DV PTR IS ON TOP * !*********************************************************************** %INTEGER LITL,RES,X,AHW0,AHW1,HAREA %IF HOST=PERQ %OR HOST=ACCENT %OR HOST=IBM %OR HOST=IBMXA %START %SHORTINTEGER AH0,AH1,AH2,AH3 %FINISH %ELSE %START %HALFINTEGER AH0,AH1,AH2,AH3 %FINISH XNAME=UCSTRING(XNAME) AHW0=AOFFSET>>1 AHW1=DVOFFSET>>1 HAREA=2; ! NORMAL GLA PGLA(4,0,ADDR(AH0)) RES=GLACA AH0<-AHW0 AH2<-AHW1 AH1=0 AH3=0 LITL=PTYPE>>14&3 PGLA(4,8,ADDR(AH0)) RELOCATE(32,RES+4,4); ! RELOCATE DV PTR (IN SST) %IF LITL=3 %START; ! EXTRINSIC ARRAYS GXREF(XNAME,2,2<<24!SIZE,RES) %FINISH %ELSE %START %IF AAREA#0 %THEN RELOCATE(32,RES,AAREA) %FINISH %IF LITL=2 %THEN DEFINE EP(XNAME,AAREA,AOFFSET,SIZE) %RESULT=RES %END %EXTERNALROUTINE PLUG(%INTEGER AREA, AT, VALUE, BYTES) !*********************************************************************** !* WRITE UP TO ONE WORD INTO OBJECT FILE OUT OF SEQUENCE * !*********************************************************************** %INTEGERNAME WCABUF %BYTEINTEGERARRAYNAME BUF %OWNBYTEINTEGERARRAY B(0:3) %INTEGER I, RELAD WCABUF==CABUF; BUF==CODE %IF AREA=2 %THEN WCABUF==GLACABUF %AND BUF==GLABUF RELAD=AT-WCABUF %IF BYTES=2 %THEN VALUE=VALUE<<16!(VALUE&X'FFFF') %IF BYTES=1 %THEN B(0)<-VALUE %ELSE %C MOVE BYTES(BYTES,ADDR(VALUE),4-BYTES,ADDR(B(0)),0) %IF 0<=RELAD<=256 %AND AREA<=3 %THEN %START %CYCLE I=0,1,BYTES-1 BUF(RELAD+I)=B(I) %REPEAT %FINISH %ELSE %START %IF RELAD=-2 %THEN CODEOUT %IF PARM_INHCODE=0 %THEN %C QPUT(AREA+40,BYTES,AT,ADDR(B(0))) %FINISH %END %ROUTINE GXREF(%STRING(31) NAME,%INTEGER MODE,XTRA,AT) !*********************************************************************** !* ASK QPUT TO ARRANGE FOR A WORD AT 'AT' IN THE GLA * !* OR A CALL AT 'AT' IN THE CODE TO BE RELOCATED TO NAME 'NAME'. * !* MODE=0 STATIC CODE XREF * !* MODE=1 DYNAMIC CODE XREF * !* MODE=2 DATA XREF XTRA=MINIMIUM LENGTH (SINGLE WORD ONLY) * !*********************************************************************** %INTEGER QPUTNO NAME=UCSTRING(NAME); ! PERQ ALL UPPER CASE %IF MODE=2 %THEN QPUTNO=15 %ELSE QPUTNO=MODE+12 QPUT(QPUTNO,XTRA,AT,ADDR(NAME)) %END %EXTERNALROUTINE CXREF(%STRING(255) NAME, %INTEGER MODE,XTRA,%INTEGERNAME AT) !*********************************************************************** !* CREATE A ZEROED AREA IN THE GLA AND CALL GXREF TO GET * !* IT FILLED AT LOAD TIME WITH INFORMATION ON AN EXTERNAL OBJECT * !* PARAMETERS ARE AS FOR GXREF. * !* SHOULD NEVER BE CALLED ON PERQ AS CODE XREFS DONE VIA RTDICT * !*********************************************************************** IMPABORT %END %ROUTINE PINITCALL(%STRING(31) S) !*********************************************************************** !* A FRIG CALL TILL LOADER UP TO IMP&FORTRAN SPEC * !*********************************************************************** PB2(LDO0,LDC0) PB2(JNEB,3) PB3(CALLXB,1,0) GXREF(S,0,0,CA-3) %END %ROUTINE CALL STOP !*********************************************************************** !* CALLS STOP ROUTINE. NOT VIA EPILOGUE ON PERQ * !************************************************************************ PB3(CALLXB,1,0) GXREF("S#STOP",0,0,CA-3) %END %ROUTINE ERASE(%INTEGER WORDS) !*********************************************************************** !* REMOVES 1 OR 2 WORDS FROM THE ESTACK * !*********************************************************************** %IF WORDS=1 %THEN PB2(JTB,0) %ELSE PB2(JEQB,0) %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 * !*********************************************************************** %SWITCH SW(0:8) %INTEGER P1,P2 %RETURN %UNLESS OPND1_FLAG>=8 %AND OPND2_FLAG>=8 %C %AND OPND1\==OPND2 P1=OPND1_PTYPE>>4&15 P2=OPND2_PTYPE>>4&15 %IF P1<4 %THEN P1=4 %IF P2<4 %THEN P2=4 ->SW(3*(P1-4)+P2-4) SW(0): ! 2 16 BIT OPERANDS PB1(EXCH); %RETURN SW(2): ! 16 BIT UNDER 64 BIT PB1(MMS2); CAB PB1(MES2) SW(1): ! 16 BIT UNDER 32 BIT CAB; %RETURN SW(3): ! 32 BIT UNDER 16 BIT PERM; %RETURN SW(4): ! 2 32 BIT QUANTITIES PB1(EXCH2); %RETURN SW(5): ! 32 BIT UNDER 64 PB1(PERMD) SW(7): ! 64 UNDER 32 PB1(PERMD) %RETURN SW(6): ! 64 UNDER 16 PERM; PB1(MMS2) PERM; PB1(MES2) %RETURN SW(8): ! 2 64 BIT VALUES PB2(ROPS,ROPSEXCH4) %END %ROUTINE BULKM(%INTEGER MODE,L,D2) !*********************************************************************** !* PLANT CODE TO MOVE L BYTES (L KNOWN AT COMPILE TIME) FROM * !* ETOS,ETOS-1 TO ETOS-2,ETOS-3 * !* 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 PB1(REPL2) %UNLESS L=2 PBW(INCW,(L-2)>>1) PBW(LDCW,W2) PB1(TLATE2) PB1(STIND) L=L-2 %RETURN %IF L=0 PB1(REPL2) PB2(INCB,1) %FINISH %IF L<=511 %START PB2(STLATE,X'31') PB2(MOVB,L>>1) %FINISH %ELSE %START PBW(LDCW,L>>1) PB2(STLATE,X'42') PB1(MOVW) %FINISH %END; ! OF ROUTINE BULK M %ROUTINE ADJUSTSF(%INTEGER C) !************************************************************************ !* ADVANCE OR RETRACT TOP POINTER BY C * !************************************************************************ %IF IMOD(C)<=127 %THEN PB2(ATPB,C) %ELSE PBW(LDCW,C) %AND PB1(ATPW) %END %ROUTINE STACKDUMP(%INTEGER WORDS) !*********************************************************************** !* DUMP WORDS FROM ESTACK TO MSTACK AVOIDING REVERSING * !* THE ORDER. VALID FOR 1,2,3 OR 4 WORDS ONLY * !*********************************************************************** %IF WORDS&1=1 %THEN PB1(MMS) %AND WORDS=WORDS-1 %IF WORDS>=2 %THEN PB1(MMS2) %AND WORDS=WORDS-2 STACKDUMP(WORDS) %UNLESS WORDS=0 %END %ROUTINE STACKUNDUMP(%INTEGER WORDS) !*********************************************************************** !* REVERSES THE ABOVE * !*********************************************************************** %IF WORDS&1=1 %THEN PB1(MES)%AND WORDS=WORDS-1 %IF WORDS>=2 %THEN PB1(MES2) %AND WORDS=WORDS-2 STACKUNDUMP(WORDS) %UNLESS WORDS=0 %END %ROUTINE NDUPLICATE(%INTEGER WORDS) !*********************************************************************** !* REPLCATES 1,2 OR 4 WORDS IN THE ESTACK. WRITTEN TO AVOID * !* THE ABSENCE OF REPL4 INSTRUCTIO * !************************************************************************ %IF 0<=WORDS<=1 %THEN PB1(REPL) %AND %RETURN %IF WORDS=2 %THEN PB1(REPL2) %AND %RETURN %IF WORDS#4 %THEN IMPABORT PB1(EXCH2) PB1(REPL2) PB1(PERMD) PB1(EXCH2) PB1(REPL2) PB1(PERMD) %END %ROUTINE CALL IOCP(%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 %CONSTSTRING(8)IOCPEP="S#IOCP"; ! EP FOR IOCP PB2(ATPB,1); ! HOLE FOR 16BIT RESULT PBW(LDCW,N) PB1(MMS); PB1(MMS2) PB3(CALLXB,1,0) GXREF(IOCPEP,0,0,CA-3) %IF (1< ! LDC0,LDCW X'201', JMP ! EXCESS BLOCKS ERROR !OK: MES, EXCH ! ATPW, MMS, JMS ! CLAIM SPACE AND RETURN ! %IF PARM_OPT=1 %THEN %START; ! ONLY REQUIRED WITH CHKING WORKA_PLABS(4)=CA PB1(REPL) PB1(LDC0) PB1(EXCH) PB1(LDC0) PB1(LDTP) PB2(LOPS,LOPSADD) PB1(LDC0) PBW(LDCW,X'F000') PB2(LOPS,LOPSLEQ) PB2(JTB,6) PB1(LDC0) PBW(LDCW,X'201') PB2(JMPB,-(CA-WORKA_PLABS(2)+2)) PB1(MES) PB1(EXCH) PB1(ATPW) PB1(MMS) PB1(JMS) %FINISH ! ! SOME ERROR ROUTINES ! ERR EXIT(5, X'801', 0) %IF PARM_OPT#0; ! UNASSIGNED VARIABLE ERR EXIT(6, X'802', 0); ! SWITCH LABEL UNSET ERR EXIT(7, X'505', 1); ! ILLEGEAL EXPONENTIATION ERR EXIT(8,X'201', 0) %IF PARM_OPT#0; ! EXCESS BLOCKS ERR EXIT(9, X'601', 0); ! CAPACITY EXCEEDED ERR EXIT(10,21, 0) ; ! NO RESULT ERR EXIT(11,X'501', 0) %IF PARM_OPT#0; ! CYCLE NOT VALID ERR EXIT(12,X'701',0); ! RES FAILS ERR EXIT(13,X'602',0) %IF PARM_OPT#0; ! ARRAY BOUND FAULT WORKA_CONST PTR=1 WORKA_CONST BTM=WORKA_CONST PTR %IF PARM_PROF#0 %THEN %START; ! ALLOCATE PROFILE COUNT AREA %FINISH %RETURN %ROUTINE ERR EXIT(%INTEGER LAB, ERRNO, MODE) !*********************************************************************** !* MODE=0 FOR DUMMY(ZERO) XTRA - MODE=1 XTRA IN GR1 * !*********************************************************************** WORKA_PLABS(LAB)=CA %IF MODE=0 %THEN PB1(LDC0) PBW(LDCW,ERRNO) I=CA-WORKA_PLABS(2)+2 PB2(JMPB,-I) %END %END %ROUTINE REPEAT PROLOGUE !*********************************************************************** !* CALLED WHEN PROLOGUE IS ABOUT TO BECOME UNADDRESSABLE * !* PLANT 'RELAY' JUMPS SO THAT IT IS STILL AVAILABLE * !*********************************************************************** %INTEGER I,J %CYCLE I=1,1,15 J=WORKA_PLABS(I) %IF 0 RESOLVING ON NULL STRING ! LDL12,SBI 0 LENGTH DIFF =1 VALID COMP ! LDC1,ADI,REPL,STL13 ! LDC0,LEQI,JTB NOT ENOUGH LEFT OF LHS ! ! STAGE 2 CYCLE ROUND WITH BYTEARRAY COMPARISONS TO LOCATE STRING ! !LOOP: ! REPITIONS TO HERE ! LLAB 9,LDDW,LDC1 BYTE POINTER TO RESOLUTION ! LLAB 1, LDDW,LDL11,LDL14,ADI POINTER TO LHS ! LDL12 BYTE TO COMPARE ! STLATE X'63',EQUBYTE 0 COMPARE ! JTB FOUND IT ! LDL14,LDC1,ADI INCREMENT CONTROL ! REPL,STLB 14 STORE IT ! LDL13,GTRI,JFB LOOP ! !RESFAIL: RESOLUTION HAS FAILED ! LDC0,STL0,RETURN EXIT WITH FALSE SET !RESOK RESOLUTION HAS WORKED ! LDL6,LDC0,NEQI ! JFB FRAGMENT TO BE DISCARDED ! ! CONTROL IS NO OF BYTES TO BE STORED (IE L+1) OF FRAGMENT ! FIRST COPY IN BYTES + RUBBISH LENGTH THEN OVERWRITE ! WITH CORRECT LENGTH ! ! LLAB 7,LDDW,LDC0 DEST POINTER ! LLAB 1,LDDW,LDL11 SOURCE POINTER ! LDL14 BYTES TO MOVE ! STLATE X'63',MVBW ASSIGN ! LLAB 7,LDDW,LDC0 POINTER TO LENGTH ! LDL14,LDC1,SBI ! TLATE3,STCH OVERWRITE WITH CORRECT LENGTH !NOSTORE: ENTERS HERE IF FRAGMENT IS DISCARDED ! LLAB 4,LDDW POINTER TO USED BYTES ! LDL11,LDL12,ADI ! LDL14,ADI,LDC1,SBI RECALCULATE ! TLATE2,STIND AND UPDATE ! LDC1,STL0,RETURN EXIT WITH RESULT=TRUE ! %IF WORKA_PLINK(16)=0 %THEN ->P17 R=0 R_PS=10 R_RPS=11 R_LTS=4 R_ENTRY<-CA PB1(LDC0+1) PB2(STLB,14) PB1(LDL0+3) PB2(LLAB,4) PB1(LDDW) PB1(TLATE1) PB1(LDIND) PB1(REPL) PB2(STLB,11) PB1(SBI) PB2(LLAB,9) PB1(LDDW) PB1(LDC0) PB1(TLATE2) PB1(LDCH) PB1(REPL) PB2(STLB,12) PB1(LDC0) PB1(EQUI) PB2(JTB,41); ! TO RESOK A1=CA PB1(LDL0+12) PB1(SBI) PB1(LDC0+1) PB1(ADI) PB1(REPL) PB2(STLB,13) PB1(LDC0) PB1(LEQI) PB2(JTB,27); ! TO RESFAIL ! THIS IS "LOOP" A2=CA PB2(LLAB,9) PB1(LDDW) PB1(LDC0+1) PB2(LLAB,1) PB1(LDDW) PB1(LDL0+11) PB1(LDL0+14) PB1(ADI) PB1(LDL0+12) PB2(STLATE,X'63') PB2(EQUBYT,0) PB2(JTB,13); ! TO RESOK A3=CA PB1(LDL0+14) PB1(LDC0+1) PB1(ADI) PB1(REPL) PB2(STLB,14) PB1(LDL0+13) PB1(GTRI) PB2(JFB,-27) %IF CA-A2#27 %THEN PLUG(1,CA-1,A2-CA,1) ! THIS IS "RESFAIL" %IF CA-A2#27 %THEN PLUG(1,A2-1,CA-A2,1) PB1(LDC0) PB1(STL0) PB1(RETURN) ! THIS IS "RESOK" %IF CA-A1#41 %THEN PLUG(1,A1-1,CA-A1,1) PB1(LDL0+6) PB1(LDC0) PB1(NEQI) PB2(JFB,21); ! TO NOSTORE A1=CA PB2(LLAB,7) PB1(LDDW) PB1(LDC0) PB2(LLAB,1) PB1(LDDW) PB1(LDL0+11) PB1(LDL0+14) PB2(STLATE,X'63') PB1(MVBW) PB2(LLAB,7) PB1(LDDW) PB1(LDC0) PB1(LDL0+14) PB1(LDC0+1) PB1(SBI) PB1(TLATE3) PB1(STCH) ! THIS IS "NOSTORE" %IF CA-A1#27 %THEN PLUG(1,A1-1,CA-A1,1) PB2(LLAB,4) PB1(LDDW) PB1(LDL0+11) PB1(LDL0+12) PB1(ADI) PB1(LDL0+14) PB1(ADI) PB1(LDC0+1) PB1(SBI) PB1(TLATE2) PB1(STIND) PB1(LDC0+1) PB1(STL0) PB1(RETURN) R_EXIT<-CA-1 R_LL=2 QPUT(11,WORKA_PLINK(16),ADDR(R),ADDR(RESOLVE)) 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 ! L0&1= VIRT ADDR OF SOURCE ! L2&3= MAX LENGTH OF DEST ! L4&5= VIRT ADDR OF DEST ! L6 = LOCAL THE ACTUAL STRING BYTES TO BE MOVED ! ! LLAB 0,LDDW PICK UP SOURCE ! LDC0,TLATE2,LDB LENGTH ! REPL STL6 ! LDL2,LEQI JTB ! LDL2,STL6 !OK: ! LDL4,LDL4,LDC1 POINTER TO DEST ! LDL1,LDL0,LDC1 AND TO SOURCE ! LDL6,STLATE X'63',MVBW MOVE TEXT ! LDL5,LDL4,LDC0,LDL6 ! TLATE3,STB ADD LENGTH ! RETURN %IF WORKA_PLINK(18)=0 %THEN ->P19 R=0 R_PS=6 R_RPS=6 R_LTS=2 R_ENTRY<-CA PB2(LLAB,0) PB1(LDDW) PB1(LDC0) PB1(TLATE2) PB1(LDB) PB1(REPL) PB1(STL0+6) PB1(LDL0+2) PB1(LEQI) PB2(JTB,2) PB1(LDL0+2) PB1(STL0+6) ! LABEL "OK" IS HERE PB1(LDL0+5) PB1(LDL0+4) PB1(LDC0+1) PB1(LDL0+1) PB1(LDL0) PB1(LDC0+1) PB1(LDL0+6) PB2(STLATE,X'63') PB1(MVBW) PB1(LDL0+5) PB1(LDL0+4) PB1(LDC0) PB1(LDL0+6) PB1(TLATE3) PB1(STB) PB1(RETURN) R_EXIT<-CA-1 R_LL=2 QPUT(11,WORKA_PLINK(18),ADDR(R),ADDR(JAMMER)) P19: ! called subroutine to evaluate i****4 ! l0 for result ! l1 has n ! l2 has i ! fault recorded unless 0<=n<=63 ! ! LDL1, REPL, LDC0,LESI ! JTW ! LDCB 63, GTRI, JTW ! LDC1 ! FOR PRODUCT !AGN LDL1, REPL, LDC0 EQUI ! JTB ! LDC1, SBI, STL1 ! LDL2, MPI, JTB !END STL2,STL1 ! RETURN ! %IF WORKA_PLINK(19)=0 %THEN ->P20;! ROUTINE NOT USED R=0; R_PS=2; R_RPS=3 R_ENTRY<-CA PB1(LDL0+1) PB1(REPL) PB1(LDC0) PB1(LESI) PBW(JTW,WORKA_PLABS(7)-(CA+3)) PB2(LDCB,63) PB1(GTRI) PBW(JTW,WORKA_PLABS(7)-(CA+3)) PB1(LDC0+1) ! LABEL AGN IS HERE A1=CA PB1(LDL0+1) PB1(REPL) PB1(LDC0) PB1(EQUI) PB2(JTB,7) A2=CA PB1(LDC0+1) PB1(SBI) PB1(STL0+1) PB1(LDL0+2) PB1(MPI) PB2(JMPB,-13) %IF CA-A1#13 %THEN PLUG(1,CA-1,A1-CA,1) ! LABEL END IS HERE %IF CA-A2#7 %THEN PLUG(1,A2-1,CA-A2,1) PB1(STL0+2) PB1(STL0) PB1(RETURN) R_EXIT<-CA-1 R_LL=2 QPUT(11,WORKA_PLINK(19),ADDR(R),ADDR(IEXP16)) P20: ! called subroutine to evaluate i****N ( I 32 BITS) ! L0&1 for result ! l2 has n ! L3&4 has i ! fault recorded unless 0<=n<=63 ! ! LDL2, REPL, LDC0,LESI ! JTW ! LDCB 63, GTRI, JTW ! LDC0, LDC1 ! FOR PRODUCT !AGN LDL2, REPL, LDC0 EQUI ! JTB ! LDC1, SBI, STL1 ! LDLDB 2, MPIL, JTB !END STL2,STLDW 0 ! RETURN ! %IF WORKA_PLINK(20)=0 %THEN ->P21;! ROUTINE NOT USED R=0; R_PS=3; R_RPS=5 R_ENTRY<-CA PB1(LDL0+2) PB1(REPL) PB1(LDC0) PB1(LESI) PBW(JTW,WORKA_PLABS(7)-(CA+3)) PB2(LDCB,63) PB1(GTRI) PBW(JTW,WORKA_PLABS(7)-(CA+3)) PB1(LDC0) PB1(LDC0+1) A1=CA ! LABEL AGN IS HERE PB1(LDL0+2) PB1(REPL) PB1(LDC0) PB1(EQUI) PB2(JTB,9) A2=CA PB1(LDC0+1) PB1(SBI) PB1(STL0+2) PB2(LDLDB,3) PB2(LOPS,LOPSMULT) PB2(JMPB,-15) %IF CA-A1#15 %THEN PLUG(1,CA-1,A1-CA,1) ! LABEL END IS HERE %IF CA-A2#9 %THEN PLUG(1,A2-1,CA-A2,1) PB1(STL0+2) PB2(STLDB,0) PB1(RETURN) R_EXIT<-CA-1 R_LL=2 QPUT(11,WORKA_PLINK(20),ADDR(R),ADDR(IEXP32)) P21: ! called subroutine to evaluate X**N ( X 32 BITS) ! L0&1 for result ! l2 has n ! L3&4 has X ! L5 has copy of l2 ! fault recorded unless -255<=n<=255 ! ! LDL2, REPL, STL5 ! ABI, REPL, STL2 ! LDCW 255, GTRI, JTW ! LDC1, FLT ! FOR PRODUCT !AGN LDL2, REPL, LDC0 EQUI ! JTB ! LDC1, SBI, STL1 ! LDLDB 2, MPR, JTB !END STL2,STLDW 0 ! LDL5, LDC0, GEQI, JTB ! LDC0, FLT, LDLDB 0, RDV 2**(-n)=1/2**n !OUT RETURN ! %IF WORKA_PLINK(21)=0 %THEN ->P22;! ROUTINE NOT USED R=0; R_PS=3; R_RPS=5 R_LTS=1 R_ENTRY<-CA PB1(LDL0+2) PB1(REPL) PB1(STL0+5) PB1(ABI) PB1(REPL) PB1(STL0+2) PBW(LDCW,255) PB1(GTRI) PBW(JTW,WORKA_PLABS(7)-(CA+3)) PB1(LDC0+1) PB2(ROPS,ROPSFLT) A1=CA ! LABEL AGN IS HERE PB1(LDL0+2) PB1(REPL) PB1(LDC0) PB1(EQUI) PB2(JTB,9) A2=CA PB1(LDC0+1) PB1(SBI) PB1(STL0+2) PB2(LDLDB,3) PB2(ROPS,ROPSMULT) PB2(JMPB,-15) %IF CA-A1#15 %THEN PLUG(1,CA-1,A1-CA,1) ! LABEL END IS HERE %IF CA-A2#9 %THEN PLUG(1,A2-1,CA-A2,1) PB1(STL0+2) PB2(STLDB,0) PB1(LDL0+5) PB1(LDC0) PB1(GEQI) PB2(JTB,9) A3=CA PB1(LDC0+1) PB2(ROPS,ROPSFLT) PB2(LDLDB,0) PB2(ROPS,ROPSDIV) PB2(STLDB,0) %IF CA-A3#9 %THEN PLUG(1,A3-1,CA-A3,1) PB1(RETURN) R_EXIT<-CA-1 R_LL=2 QPUT(11,WORKA_PLINK(21),ADDR(R),ADDR(REXP32)) P22: ! called subroutine to evaluate X**N ( X 64 BITS) ! L0-3 for result ! L4 has n ! L5-8 has X ! L9 has copy of l2 ! fault recorded unless -255<=n<=255 ! ! LDL4, REPL, STL9 ! ABI, REPL, STL4 ! LDCW 255, GTRI, JTW ! LDC0, LDC1, FLTL ! FOR PRODUCT !AGN LDL4, REPL, LDC0 EQUI ! JTB ! LDC1, SBI, STL4 ! LLAB 5, LDQ MPR, JTB !END STL4,STLDW 0, STLDB 2 ! LDL9, LDC0, GEQI, JTB ! LDC0, LDC1, FLTL, LLAB 0, LDQ RDV 2**(-n)=1/2**n ! STLDB 0, STLDB 2 !OUT RETURN ! %IF WORKA_PLINK(22)=0 %THEN ->P23;! ROUTINE NOT USED R=0; R_PS=5; R_RPS=9 R_LTS=1 R_ENTRY<-CA PB1(LDL0+4) PB1(REPL) PB2(STLB,9) PB1(ABI) PB1(REPL) PB1(STL0+4) PBW(LDCW,255) PB1(GTRI) PBW(JTW,WORKA_PLABS(7)-(CA+3)) PB1(LDC0) PB1(LDC0+1) PB2(ROPS,ROPSDFLT) ! LABEL AGN IS HERE A1=CA PB1(LDL0+4) PB1(REPL) PB1(LDC0) PB1(EQUI) PB2(JTB,11) A2=CA PB1(LDC0+1) PB1(SBI) PB1(STL0+4) PB2(LLAB,5) PB2(ROPS,ROPSLDQ) PB2(ROPS,ROPSDMULT) PB2(JMPB,-17) %IF CA-A1#17 %THEN PLUG(1,CA-1,A1-CA,1) ! LABEL END IS HERE %IF CA-A2#11 %THEN PLUG(1,A2-1,CA-A2,1) PB1(STL0+4) PB2(STLDB,0) PB2(STLDB,2) PB1(LDL0+9) PB1(LDC0) PB1(GEQI) PB2(JTB,14) A3=CA PB1(LDC0) PB1(LDC0+1) PB2(ROPS,ROPSDFLT) PB2(LDLDB,2) PB2(LDLDB,0) PB2(ROPS,ROPSDDIV) PB2(STLDB,0) PB2(STLDB,2) %IF CA-A3#14 %THEN PLUG(1,CA-1,CA-A3,1) PB1(RETURN) R_EXIT<-CA-1 R_LL=2 QPUT(11,WORKA_PLINK(22),ADDR(R),ADDR(REXP64)) P23: ! ! STRING PRE-CONCATENATION SUBROUTINE ! ! ETOS HAS WK AREA ADDRESS. OBTAIN AND STACK CURRENT LENGTH ! LEAVE A SUITABLE STRING POINTER IN ESTACK FOR ! NEXT SUBROUTINE. ! ! REPL, LDC0,LDB GET CURRENT LENGTH ! REPL, MES, EXCH, MMS2 STORE UNDER RETURN ADDRESS ! LDC1, ADI, JMS STRING POINTER IN ESTACK ! ! NO LONGER NEEDED P24: ! ! STRING CONCATENATION SUBROUTINE ! ! ETOS&-1 HAS 32 BIT ADDRESS OF STRING TO BE ADDED ! ETOS-2&3 HAVE PTR LEFT BY PREVIOUS SUBROUTINE ! CURRENT LENGTH LEFT STACKED UNDER RETURN ADDRESS ! ! MES2,EXCH,MMS2 UNSCRAMBLE RETURN ADDRESS ! EXCH2, EXCH, REPL ! LDC0, PERMD STORE POINTER AT BOTTOM FOR LATER ! EXCH, EXCH2 ! NOW A BYTE POINTER FOR STORING LEBGTH IS UNDER THE ORIGINAL 4 ! REPL2, LDC0,TLATE2, LDCH GET LENGTH TO BE ADDED ! REPL, MMS,LDC0+1, EXCH ! TLATE3,MVBW ASIGN STRING ! MES2, ADI COMBINE LENGTHS ! STB, JMS AND STORE WITH PERMD POINTER! ! NO LONGER NEEDED P25: ! ! CHECK ARRAY BOUND WITH 16 BIT INDEX ! ETOS HAS DIMEN ! ETOS-1&2 HAVE 32 BIT DV ADDRESS ! ETOS-4 HAS 16 BIT INDEX ! ASSUMES THE DV DOES NOT CROSS SEGMENT BOUNDARY ! ! LDC6, MPI,ADI TO RIGTH TRIPLE ! MMS2, CV I-LI, MES2 ! TLATE1, LDQ, CHKD, ! CV LI-I, JMS %IF WORKA_PLINK(25)=0 %THEN ->P26 FILL(25) PB1(LDC0+6) PB1(MPI) PB1(ADI) PB1(MMS2) PB2(LOPS,LOPSLNGTHN) PB1(MES2) PB1(TLATE1) PB2(ROPS,ROPSLDQ) PB1(CHKD) PB2(LOPS,LOPSSHRTN) PB1(JMS) P26: ! ! CHECK ARRAY BOUND WITH 32 BIT INDEX ! ETOS HAS DIMEN ! ETOS-1&2 HAVE 32 BIT DV ADDRESS ! ETOS-4&5 HAS 32BIT INDEX ! ASSUMES THE DV DOES NOT CROSS SEGMENT BOUNDARY ! ! LDC6, MPI, ADI TO CORRECT TRIPLE ! TLATE1, LDQ ! CHKD, JMS ! %IF WORKA_PLINK(26)=0 %THEN ->P27 FILL(26) PB1(LDC0+6) PB1(MPI) PB1(ADI) PB1(TLATE1) PB2(ROPS,ROPSLDQ) PB1(CHKD) PB1(JMS) P27: ! REDUCE LONG BYTE INDEX ! ETOS & ETOS-1 HOLD 32 BIT BYTE ARRAY INDEX ! ETOS-2&3 HOLD 32 BIT BASE ADDRESS ! REDUCE TO PERQ BYTE POINTER ALLOWING FOR SEG BOUNDARIES ! ! REPL, LDC1,LAND, MMS ! LDCMO, SHIFTL, ADDL ! MES, JMS ! %IF WORKA_PLINK(27)=0 %THEN ->P28 FILL(27) PB1(REPL) PB1(LDC0+1) PB1(LAND) PB1(MMS) PB1(LDCMO) PB2(LOPS,LOPSSHIFT) PB2(LOPS,LOPSADD) PB1(MES) PB1(JMS) P28: ! SCALE VIA DV 16 BIT INDEX ! ETOS HAS 32 BIT DV POINTER ! ETOS-2 HAS 16 BIT INDEX ! ETOS-3&4 HAVE 32 ARRAY BASE ! LEAVE 32 BIT POINTER AT ETOS ! ! TLATE1, SIND2 16 BIT MULTIPLIER ! MPI, LDC2, DVI, ADI, JMS ! %IF WORKA_PLINK(28)=0 %THEN ->P29 FILL(28) PB1(TLATE1) PB1(SIND0+2) PB1(MPI) PB1(LDC0+2) PB1(DVI) PB1(ADI) PB1(JMS) P29: ! SCALE VIA DV FOR 32 BIT INDEX ! ETOS HAS 32 BIT DV POINTER ! ETOS-2&3 HAS 32 BIT INDEX ! ETOS-4&5 HAVE 32 ARRAY BASE ! LEAVE 32 BIT POINTER AT ETOS ! ! TLATE1, SIND2 16 BIT MULTIPLIER ! CVTI/LI, MPIL ! LDCMO, SHIFTL, ADDL, JMS ! %IF WORKA_PLINK(29)=0 %THEN ->P30 FILL(29) PB1(TLATE1) PB1(SIND0+2) PB2(LOPS,LOPSLNGTHN) PB2(LOPS,LOPSMULT) PB1(LDCMO) PB2(LOPS,LOPSSHIFT) PB2(LOPS,LOPSADD) PB1(JMS) P30: %BEGIN !*********************************************************************** !* PASS INFORMATION TO QPUT TO ENABLE IT TO GENERATE THE * !* LOADER DATA AND COMPLETE THE PROGRAM FILE. * !*********************************************************************** %ROUTINESPEC DUMPCONSTS %INTEGER LANGFLAG,PARMS,I,J,K CODE OUT CNOP(0, 8) ! FIXED GLA(6)=CA; ! CONST TABLE ADDRESS DUMP CONSTS %IF PARM_TRACE=0 %THEN LANGFLAG=6 %ELSE LANGFLAG=1 LANGFLAG=LANGFLAG<<24 PARMS=(PARM_DIAG<<1!PARM_LINE)<<1!PARM_TRACE FIXED GLA(4)=LANGFLAG!WORKA_RELEASE<<16!(PARM_CPRMODE&1)<<8!PARMS;! LANG RLSE & MAINPROG I=GLACA-GLACABUF %IF PARM_INHCODE=0 %THEN %START QPUT(42, I, GLACABUF, ADDR(GLABUF(0))) %UNLESS I=0 ! BACK OF GLAP QPUT(42, FIXEDGLALEN, 0, ADDR(FIXED GLA(0)));! FRONT OF GLAP QPUT(19,2,8,5); ! RELOCATE GLA ST ADDRESS QPUT(19,2,12,4); ! RELOCATE CODE ST ADDRESS ! QPUT(19,2,24,1); ! RELOCATE CONSTANT TABLE I=X'E2E2E2E2' QPUT(40+DAREA, 4, CAS(DAREA), ADDR(I)) CAS(DAREA)=CAS(DAREA)+4 %FINISH %CYCLE I=1,1,6 CAS(I)=(CAS(I)+7)&(-8) %REPEAT PRINTSTRING(" POS CODE") WRITE(CA, 6) %IF CAS(4)>0 %THEN PRINTSTRING("+") %AND %C WRITE(CAS(4),4) PRINTSTRING(" BYTES GLAP") WRITE(GLACA, 3); PRINTSTRING("+") WRITE(CAS(5), 1); PRINTSTRING(" BYTES DIAG TABLES") WRITE(CAS(DAREA), 3); PRINTSTRING(" BYTES TOTAL") K=CA+GLACA+CAS(4)+CAS(5)+CAS(6) WRITE(K, 5); PRINTSTRING(" BYTES ") %IF PARM_FAULTY=0 %THEN %START WRITE(STMTS, 7); PRINTSTRING(" STATEMENTS COMPILED") COMREG(47)=STMTS; ! NO OF STMTS FOR COMPER %FINISH %ELSE %START PRINTSTRING("PROGRAM CONTAINS"); WRITE(PARM_FAULTY, 2) PRINTSTRING(" FAULT"); PRINTSYMBOL('S') %IF PARM_FAULTY>1 COMREG(47)=PARM_FAULTY; ! NO OF FAULTS FOR COMPER %FINISH NEWLINES(2) I=0; I=8 %IF PARM_FAULTY#0 COMREG(24)=I CAS(7)=K %IF PARM_INHCODE=0 %THEN QPUT(7, 28, 0, ADDR(CAS(1))) ! SUMMARY INFO. PPROFILE ->OUT %ROUTINE DUMP CONSTS !*********************************************************************** !* OUTPUT THE CONSTANT TABLE AND MAKE ANY RELEVANT RELOCATIONS * !*********************************************************************** %INTEGER I,J,K,BASE BASE=WORKA_AASL0+16 %IF PARM_DCOMP#0 %START PRINTSTRING(" CONSTANT TABLE") I=0 %CYCLE NEWLINE PRHEX(CA+4*I,5) %CYCLE J=0,1,7 SPACES(2) PRHEX(INTEGER(BASE+4*(I+J)),8) %REPEAT SPACE %CYCLE J=0,1,31 K=BYTEINTEGER(BASE+4*I+J) %IF K<31 %OR K>95 %THEN K=32 PRINT SYMBOL(K) %REPEAT I=I+8 %EXIT %IF I>=WORKA_CONSTPTR %REPEAT %FINISH !*DELEND ! %END OUT: %END %RETURN %ROUTINE FILL(%INTEGER LAB) !*********************************************************************** !* FILL JUMPS TO THIS LAB WITH JUMP TO CURRENT ADDRESS * !*********************************************************************** %INTEGER AT,I %INTEGERARRAY A(0:2) %WHILE WORKA_PLINK(LAB)#0 %CYCLE POP(WORKA_PLINK(LAB),A(0),A(1),A(2)) %CYCLE I=0,1,2 AT=A(I) %IF AT#0 %THEN %START PLUG(1,AT+1,CA,1) PLUG(1,AT+2,CA>>8,1) %FINISH %REPEAT %REPEAT WORKA_PLABS(LAB)=CA %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 %START %IF PARM_X#0 %THENRESULT=ICL REAL; ! FOR SIMULATOR %IF ICL Real=0.0 %THENRESULT=PERQ ZERO %IF ICL Real<0.0 %THEN SIGN=1 %AND ICL Real=-ICL Real %ELSE SIGN=0 ! ICL Real is now positive ! Decompose the ICL Real: *LSS_ICL Real *FIX_ICL Exp *SHZ_Bits shifted left *USH_1; *USH_-9 *ST_PERQ Fraction ! Calculate PERQ Exponent: PERQ Exp=((ICL Exp+5)*4 {as exponent is a hexadecimal exp})+ %C (11-bits shifted left) {equals either 0,1,2, or 3}+127 {the bias of the exponent} ! -and examine its range: %IF PERQ Exp<=0 %THENRESULT=MINUS INFINITY {ie Real Underflow} %IF PERQ Exp>=255 %THENRESULT=PLUS INFINITY { Real Overflow} ! Construct the PERQ Real *LSS_SIGN *USH_8 *OR_PERQ Exp *USH_23 *OR_PERQ Fraction *ST_PERQ Real *EXIT_-64 ! %RESULT=PERQ Real %FINISHELSERESULT=ICL REAL %END; !of ICL Real to PERQ %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 %START %IF PARM_X#0 %THENRESULT=ICL2900REAL; ! FOR SIMULATOR %IF ICL2900 Real=0.0 %THENRESULT=0.0 %IF ICL2900 Real<0.0 %THEN %C SIGN=1 %AND ICL2900 Real=-ICL2900 Real %ELSE SIGN=0 ! ICL2900 Real is now positive ! Decompose the ICL2900 Real: *LSD_ICL2900 Real *FIX_ICL2900 Exp *SHZ_Bits shifted left *USH_1; *USH_-12 *ST_PERQ Fraction ! Calculate PERQ Exponent: PERQ EXP=(ICL2900 Exp+78 {which was subtracted by FIX above}-64 %C {which is the ICL2900 bias}-1 %C { as the most significant digit is <1 and >=1/16})*4 %C { as the ICL2900 exponent is a hex exponent}+ %C (11-bits shifted left) %C {bits shifted left equals 11, or 10, or 9, or 8}+1023 {bias of PERQ double precision reals} ! Construct the PERQ Real *LSS_SIGN; ! Load sign of PERQ Real *USH_11; ! and shift to make room for PERQ Exp *OR_PERQ Exp; ! Add on the PERQ exponent *MPSR_X'12'; ! Then double ACC size *USH_52; ! and shift sign and exponent to the top *OR_PERQ Fraction; ! Add on the PERQ fraction *ST_PERQ Real; ! and save the result %RESULT=PERQ Real %FINISH %END; ! of ICL2900 LongReal to PERQ %ROUTINE PPJ(%INTEGER JUMP,N) !*********************************************************************** !* PLANT A 'JUMP PERMENTRY(N)' * !* JUMP IN WORD OFFSET FORM. BACKWARDS JUMPS SHORTENED HERE * !* IF JUMP=0 THEN PLANT A CALL * !* QUITE DIFFICULT IF PERM LABEL NOT YET SET. HAVE TO ARRANGE * !* TO NOTE CA FOR LATER FILLING * !*********************************************************************** %INTEGER VAL, J %RECORD(LISTF)%NAME LCELL VAL=WORKA_PLABS(N) %IF JUMP=0 %THEN %START %IF VAL=0 %START VAL=WORKA_RTCOUNT WORKA_PLABS(N)=VAL WORKA_PLINK(N)=VAL WORKA_RTCOUNT=WORKA_RTCOUNT+1 %FINISH PB2(CALL,VAL) %RETURN %FINISH %IF (CA+2)&CODEBNDRY<2 %THEN CNOP(0,8) ! FORCE PAGE BOUNDARY %IF VAL>0 %THEN %START %IF JUMP=JLK %THEN PBW(JLK,VAL) %AND %RETURN J=CA+2-VAL %IF J<=127 %THEN PB2(JUMP-1,-J) %ELSE PBW(JUMP,-J-1) FAULT(98,0,0) %IF J>X'7FFF' %FINISH %ELSE %START J=CA PBW(JUMP,0) ! REST DONE BY FILL IN EPILOGUE LCELL==ASLIST(WORKA_PLINK(N)) %IF LCELL_S3#0 %THEN PUSH(WORKA_PLINK(N),J,0,0) %ELSE %START %IF LCELL_S2=0 %THEN LCELL_S2=J %ELSE LCELL_S3=J %FINISH %FINISH %END %ROUTINE ARRAYSCALE(%INTEGER WORDS,DACC) !*********************************************************************** !* SCALES A SUBSCRIPT FOR AN ARRAY ELEMENT OF DACC BYTES * !* WORDS HAS SUBSCRIPT SIZE IN 16BIT WORDS * !* DACC HAS ARRAY ELEMENT SIZE IN BYTES,=0 NOT KNOWN * !* DV POINTER HAS BEEN LOADED TO ETOS WHEN DACC=0 AND WE * !* MUST GO VIA THE DV SIZE ITEM * !************************************************************************ %INTEGER I,BSIZE %SWITCH SW(1:4) %IF DACC=0 %THEN WORDS=WORDS+2 ->SW(WORDS) SW(1): ! 16 BIT INDEX CONSTANT SCALE %RETURN %IF DACC=1; ! BYTE POINTER ALREADY SET UP BSIZE=(DACC+1)>>1; ! SIZE IN WORDS %IF BSIZE<=255 %THEN PB2(IXAB,BSIZE) %ELSE %START PBW(LDCW,BSIZE) PB1(IXAW) %FINISH %RETURN SW(2): ! 32 BIT INDEX CONSTANT SCALE %IF DACC=1 %THEN PPJ(JLK,27) %AND %RETURN %IF DACC>2 %START; ! DACC=2 NULL SCALE %IF DACC=4 %OR DACC=8 %OR DACC=16 %START I=DACC//4 %IF I=4 %THEN I=3 PB1(LDC0+I) PB2(LOPS,LOPSSHIFT); ! SACLE BY SHIFTING %FINISH %ELSE %START PLW(LDDC,(DACC+1)>>1) PB2(LOPS,LOPSMULT); ! MULTIPLY LONG %FINISH %FINISH PB2(LOPS,LOPSADD); ! ADD LONG OFFSET TO BASE %RETURN SW(3): ! 16 BIT UNKNOWN SIZE SW(4): ! 32 BIT UNKNOWN SIZE PPJ(JLK,25+WORDS) %END %LIST %EXTERNALROUTINE REFORMATC(%RECORD(RD)%NAME OPND) !************************************************************************ !* REFORMATS A CONSTANT TO TAKE INTO ACCOUNT DIFFERENT HOST-TARGET * !* REPRESENTATIONS * !************************************************************************ %IF HOST#TARGET %START %INTEGER TYPE,PREC,I %REAL R %RECORD(RD) TEMP 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 %AND %RETURN %IF PREC=4 %THEN OPND_H0<-I %AND %RETURN %IF PREC=5 %THEN OPND_H0<-I %AND OPND_H1<-I>>16 %AND %RETURN IMPABORT %FINISH %IF TYPE=2 %THEN %START %IF PREC=5 %START TEMP_R=ICLREALTOPERQ(OPND_R) OPND_H0=TEMP_H1 OPND_H1=TEMP_H0 %RETURN %FINISH %IF PREC=6 %START TEMP_LR=ICLLONGREALTOPERQ(OPND_LR) OPND_H0=TEMP_H3 OPND_H1=TEMP_H2 OPND_H2=TEMP_H1 OPND_H3=TEMP_H0 %RETURN %FINISH %FINISH %IF TYPE=5 %THEN %RETURN; ! 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 !************************************************************************ %OWNBYTEINTEGERARRAYFORMAT F(0:X'FFFF') %BYTEINTEGERARRAYNAME A %INTEGER I,J %IF HOST#TARGET %START A==ARRAY(BASEAD,F) %MONITOR %UNLESS OFFSET&1=0 I=OFFSET %WHILE L>0 %CYCLE J=A(I) A(I)=A(I!!1) A(I!!1)=J I=I+2; L=L-2 %REPEAT %FINISH %END %EXTERNALROUTINE FILL DTABREFS(%INTEGERNAME CURRINFRAL) !*********************************************************************** !* PLUGS REFENCES TO THE DIAG TABLES FOR CURRINF WHICH ARE * !* ABOUT TO BE GENERATED AT CAS(DAREA). THE LIST POPPED HAS * !* S1=AREA 1=CODE, DAREA FOR DIAGNOSTIC AREA * !* S2= THE OFFSET OF INSTRUCTION OR FORWARD POINTER * !* S3=THE WORD BEFORE FILLING - NOT USED FOR AREA 1 * !*********************************************************************** %INTEGER Q,JJ,KK %WHILE CURRINFRAL#0 %CYCLE POP(CURRINFRAL,Q,JJ,KK) %IF Q=1 %THEN %START PLUG(1,JJ+2,CAS(DAREA)>>9&255,1) PLUG(1,JJ+1,CAS(DAREA)>>1&255,1) %FINISH %ELSE %START PLUG(Q,JJ+2,CAS(DAREA),2) ! 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 CRTEND(%INTEGER KKK) %INTEGERFNSPEC REACHABLE(%INTEGER LAB,LINK) %ROUTINESPEC LOAD(%RECORD(RD) %NAME OP) %ROUTINESPEC LOADAD(%RECORD(RD) %NAME OPND) %ROUTINESPEC LOADPTR(%RECORD(RD) %NAME OPND,OPND2) %ROUTINESPEC PICKUP PTR(%INTEGER WORDS) %ROUTINESPEC DSTORE(%INTEGER SIZE,LEVEL,DISP) %ROUTINESPEC DFETCH(%INTEGER SIZE,LEVEL,DISP) %ROUTINESPEC DFETCHAD(%INTEGER SEGNO,LEVEL,DISP) %ROUTINESPEC KNOWNEXP(%INTEGER PTYPE,VAL) ! %RECORD(RD) %NAME OPND1,OPND2,OPND %RECORD(TRIPF) %NAME CURRT,WORKT %RECORD(LEVELF) %NAME CURRINF %RECORD(LEVELF) %NAME LINF %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 %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}, 0 {RDSPLY MAKE DISPLAY}, X'10000410'{RDAREA INITIALISE DIAGS AREA}, X'10000511'{RDPTR RESET DIAGS PTR}, X'10000312'{RTBAD ERROR XIT FOR FN-MAP}, X'10000113'{RTXIT "%RETURN"}, X'10000314'{XSTOP "%STOP"}, 0(2), X'2000040A'{10 LOGICAL NOT}, X'2000040B'{11 LOGICAL NEGATE}, X'2000040C'{12 FLOAT}, X'2000040D'{13 MODULUS}, X'2000080E'{14 SHORTEN}, X'2000040F'{15 LENGTHEN}, X'20000610'{16 JAM SHORTEN}, X'10000000'{17 ERROR}, 0{18 NULL TRIPLE}, X'20000413'{19 PRELOAD}, X'10000001'{20 UNUSED}, X'10000303'{21 STORE STACKPOINTER}, X'10000002'{22 RESTORE STACK POINTER}, X'10000505'{23 ADVANCE STACK POINTER}, X'10000D04'{24 DECLARE ARRAY}, X'10000301'{25 UPDATE LINE NO}, X'10000906'{26 CHECK ZERO FOR STEP}, X'10000307'{27 FOR PREAMBLE}, X'10000208'{28 FOR POSTAMBLE}, X'1000010E'{29 FOR SECOND PREAMBLE}, X'10000218'{30 PRECALL}, X'10000519'{31 ROUTINE CALL}, X'1000021A'{32 RECOVER FN RESULT}, X'1000021B'{33 RECOVER MAP RESULT}, X'00000000'{34 NOT CURRENTLY USED}, X'1000081D'{35 GETAD GET 32BIT ADDREESS}, X'10000424'{36 RTOI1 INT FN}, X'10000C25'{37 RTOI2 INTPT FN}, X'10000B26'{38 STOI1 TOSTRING FN}, X'1000093D'{39 MNITR FOR %MONITOR}, X'00000000'{40 PPROF PRINT PROFILE IGNORED}, X'1000053F'{41 RTFP TURN RTNAME TO FORMAL}, X'00000000'{42 ON EVENT1 NO CODE AS YET}, X'00000000'{43 ON EVENT2 NO CODE AS YET}, X'10000846'{44 DVSTART FIL IN ELSIZE&ND}, X'10001047'{45 DVEND WORK OUT TOTSIZE}, X'20000413'{46 FOREND EXACTLY AS PRELD ON PERQ}, 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'20020A21'{141 VMY}, X'20010422'{142 COMB}, X'200E0623'{143 ASSIGN=}, X'200E0624'{144 ASSIGN<-}, X'200A0E25'{145 ****}, X'20020926'{146 BASE ADJ}, X'20000527'{147 ARR INDEX}, X'20050428'{148 INDEXED FETCH}, X'200E0629'{149 LOCAL ASSIGN}, X'10000C09'{150 VALIDATE FOR}, X'10000F15'{151 PRE CONCAT}, X'10002316'{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}, 0, 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'20000527'{186 INDEX STRING FOR CHARNO-AS ARR INDX}, X'2002042A'{187 ZCOMP COMPARE W ZERO}, X'00000000'{188 CONSTANT LOGICAL SHIFT UNUSED ON PERQ}, X'00000000'{189 CONSTANT ARITHMETIC SHIFT UNUSED ON PERQ}, X'10001048'{190 DV BPAIR ENTER LB,UB &RANGE IN CORRECT FORM}, X'00000000'{191 REG TO STORE OPERATION UNUSED}, 0(*) %CONSTHALFINTEGERARRAY STOREINF(3:6)= %C X'300'!STB,X'200'!STIND,X'300'!STDW,X'500'!ROPS %CONSTBYTEINTEGERARRAY FCOMP(0:31)=0(2), GTRI(2),LESI(2),NEQI(2),EQUI(2), GEQI(2),LEQI(2),0(2), 0(2),LESI(2),GTRI(2),NEQI(2),EQUI(2), LEQI(2),GEQI(2),0(2) ! ! THE FOLLOWING ARRAY HAS INSTRUCTION SEQUENCES FOR THE VARIOUS IMP ! IMP OPERATION PRECCED BY A SWITH LABEL AT WHICH THEY ARE PLANTED ! TOUGH CASES LIKE ** HAS A UNIQUE ONE-OFF SWITCH. ! LOOK UP THE SWITCH LABEL FOR PARAMETER DECODING IN DIFFICULT CASES ! %CONSTINTEGER NISEQS=33 %CONSTBYTEINTEGERARRAY ISEQS(40:4*(4*NISEQS+10)-1)={FIRST 16 BIT INTEGER FORMS} %C 2,LNOT,0,0 {10 16 BIT LOGICAL NOT}, 2,NGI,0,0 {11 16 BIT LOGICAL NEGATE}, 6,ROPS,ROPSFLT,X'52' {12 16 BIT FLOAT TO 32 BIT REAL}, 2,ABI,0,0 {13 16 BIT MODULUS}, 10,0,0,0 {14 SHORTEN 16 BIT TO BYTE}, 6,LOPS,LOPSLNGTHN,X'51' {15 LENGTHEN 16 BIT TO 32 BIT}, 11,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,ADI,0,0 {20 16 BIT ADDITION}, 2,SBI,0,0 {21 16 BIT SUBTRACTION}, 2,NEQBOOL,0,0 {22 16 BIT NONEQUIVALENCE}, 2,LOR,0,0 {23 16 BIT LOGICAL OR}, 2,MPI,0,0 {24 16 BIT MULTIPLY}, 2,DVI,0,0 {25 16 BIT INTEGER DIVIDE}, 1,109,0,0 {26 16 BIT REAL DIVIDE}, 2,LAND,0,0 {27 16 BIT AND}, 4,NGI,ROTSHI,0 {28 16 BIT LEFT SHIFT}, 3,ROTSHI,0,0 {29 16 BIT RIGHT SHIFT}, 12,0,0,0 {30 REAL EXP OPERATOR}, 13,1,0,0 {31 COMPARISONS}, 14,1,0,0 {32 FIRST PART OF DOUBLE COMPARISONS}, 15,0,0,0 {33 VMY}, 2,ADI,0,0 {34 COMBINE VMY RESULTS}, 16,0,0,0 {35 ASSIGN}, 16,0,0,0 {36 ASSIGN(<-)}, 17,0,1,19 {37 16 BIT INTEGER EXPONENTIATION}, 18,1,0,0 {38 BASE ADJUST ARRAY 16 BIT INDEX}, 19,1,0,0 {39 ARRAY INDEX 16 BIT INDEX}, 20,0,0,0 {40 INDEXED FETCH 16 BIT INDEX}, 23,0,0,0 {41 LASS NOW THE 32 BIT INTEGERS}, 24,0,0,0 {42 ZCOMP COMPARE =�}, 3,LOPS,LOPSNOT,0 {10 32 BIT LOGICAL NOT}, 3,LOPS,LOPSNEG,0 {11 32 BIT LOGICAL NEGATE}, 6,ROPS,ROPSDFLT,X'62' {12 32 BIT FLOAT TO 64 BIT REAL}, 3,LOPS,LOPSABS,0 {13 32 BIT MODULUS}, 6,LOPS,LOPSSHRTN,X'41' {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}, 3,LOPS,LOPSADD,0 {20 32 BIT ADDITION}, 3,LOPS,LOPSSUB,0 {21 32 BIT SUBTRACTION}, 3,LOPS,LOPSXOR,0 {22 32 BIT NONEQUIVALENCE}, 3,LOPS,LOPSOR,0 {23 32 BIT LOGICAL OR}, 3,LOPS,LOPSMULT,0 {24 32 BIT MULTIPLY}, 3,LOPS,LOPSDIV,0 {25 32 BIT INTEGER DIVIDE}, 1,0,0,109 {26 32 BIT REAL DIVIDE}, 3,LOPS,LOPSAND,0 {27 32 BIT AND}, 4,NGI,LOPS,LOPSSHIFT {28 32 BIT LEFT SHIFT}, 3,LOPS,LOPSSHIFT,0 {29 32 BIT RIGHT SHIFT}, 12,0,0,0 {30 REAL EXP OPERATOR}, 13,2,LOPS,EQUI-LOPSEQU {31 COMPARISONS}, 14,2,LOPS,EQUI-LOPSEQU {32 FIRST PART OF DOUBLE COMPARISONS}, 15,0,0,0 {33 VMY}, 3,LOPS,LOPSADD,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}, 3,TLATE1,LDDW,0 {40 INDEXED FETCH 32 BIT INDEX}, 23,0,0,0 {41 LASS NOW THE 32 BIT REALS}, 24,0,0,0 {42 ZCOMP COMPARE =�}, 7,0,0,0 {10 32 BIT LOGICAL NOT}, 3,ROPS,ROPSNEG,0 {11 32 BIT LOGICAL NEGATE}, 1,0,0,109 {FLOAT REAL COMPILER ERROR}, 3,ROPS,ROPSABS,0 {13 32 BIT REAL MODULUS}, 1,0,0,109 {14 SHORTEN 32 BIT TO 16 BIT}, 6,ROPS,ROPSLNGTHN,X'62' {15 LENGTHEN 32 BIT TO 64 BIT}, 1,0,0,109 {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}, 3,ROPS,ROPSADD,0 {20 32 BIT ADDITION}, 3,ROPS,ROPSSUB,0 {21 32 BIT SUBTRACTION}, 7,0,0,0 {22 32 BIT NONEQUIVALENCE}, 7,0,0,0 {23 32 BIT LOGICAL OR}, 3,ROPS,ROPSMULT,0 {24 32 BIT MULTIPLY}, 7,0,0,0 {25 32 BIT INTEGER DIVIDE}, 3,ROPS,ROPSDIV,0 {26 32 BIT REAL DIVIDE}, 7,0,0,0 {27 32 BIT AND}, 7,0,0,0 {28 32 BIT LEFT SHIFT}, 7,0,0,0 {29 32 BIT RIGHT SHIFT}, 22,2,2,21 {30 REAL EXP OPERATOR}, 13,2,ROPS,EQUI-ROPSEQU {31 COMPARISONS}, 14,2,ROPS,EQUI-ROPSEQU {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 32 BIT INTEGER EXPONENTIATION}, 7,0,0,0 {38 BASE ADJUST ARRAY 32 BIT INDEX}, 7,0,0,0 {39 ARRAY INDEX 32 BIT INDEX}, 3,TLATE1,LDDW,0 {40 INDEXED FETCH 32 BIT INDEX}, 23,0,0,0 {41 LASS NOW THE 64 BIT REALS}, 24,0,0,0 {42 ZCOMP COMPARE =�}, 7,0,0,0 {10 64 BIT LOGICAL NOT}, 3,ROPS,ROPSDNEG,0 {11 64 BIT LOGICAL NEGATE}, 1,0,0,109 {FLOAT REAL COMPILER ERROR}, 3,ROPS,ROPSDABS,0 {13 64 BIT MODULUS}, 6,ROPS,ROPSSHRTN,X'52' {14 SHORTEN 64 BIT TO 32 BIT}, 1,0,0,109 {15 LENGTHEN 64 BIT TO 64 BIT}, 6,ROPS,ROPSSHRTN,X'52' {16 SHORTEN 64 BIT FOR JAM}, 1,0,0,109 {17 COMPILER ERROR}, 7,0,0,0 {18 NOOP}, 7,0,0,0 {19 PRELOAD}, 3,ROPS,ROPSDADD,0 {20 64 BIT ADDITION}, 3,ROPS,ROPSDSUB,0 {21 64 BIT SUBTRACTION}, 7,0,0,0 {22 64 BIT NONEQUIVALENCE}, 7,0,0,0 {23 64 BIT LOGICAL OR}, 3,ROPS,ROPSDMULT,0 {24 64 BIT MULTIPLY}, 7,0,0,0 {25 64 BIT INTEGER DIVIDE}, 3,ROPS,ROPSDDIV,0 {26 64 BIT REAL DIVIDE}, 7,0,0,0 {27 64 BIT AND}, 7,0,0,0 {28 64 BIT LEFT SHIFT}, 7,0,0,0 {29 64 BIT RIGHT SHIFT}, 22,3,4,22 {30 REAL EXP OPERATOR}, 13,2,ROPS,EQUI-ROPSDEQU {31 COMPARISONS}, 14,2,ROPS,EQUI-ROPSDEQU {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 64 BIT INTEGER EXPONENTIATION}, 7,0,0,0 {38 BASE ADJUST ARRAY 64 BIT INDEX}, 7,0,0,0 {39 ARRAY INDEX 64 BIT INDEX}, 4,TLATE1,ROPS,ROPSLDQ {40 INDEXED FETCH 64 BIT INDEX}, 23,0,0,0 {41 LASS}, 24,0,0,0 {42 ZCOMP COMPARE =�} %OWNINTEGERARRAY AXNAMES(0:15) %SWITCH SW(0:24),TRIPSW(0:73) ! 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 %IF PARM_Z#0 %AND PARM_DCOMP#0 %THEN %START %IF PPCURR>0 %THEN %START QCODE(ADDR(CODE(0)),ADDR(CODE(PPCURR)),CABUF,16) QPUT(41,PPCURR,CABUF,ADDR(CODE(0))) PPCURR=0; CABUF=CA %FINISH PRINT THIS TRIP(TRIPLES,STPTR) %FINISH CURRT==TRIPLES(STPTR) WTRIPNO=STPTR STPTR=CURRT_FLINK COMM=1 OPND1==CURRT_OPND1 OPND2==CURRT_OPND2 XTRA=CURRT_X1 JJ=CURRT_OPERN TRIPINF=TRIPDATA(JJ) C=TRIPINF>>28; ! TRIPLE TYPE TRIPVAL=TRIPINF&255 %IF C=0 %THENCONTINUE %IF C=1 %THEN ->TRIPSW(TRIPVAL) ! ! CARE IS NEEDED IN DETECTING WHEN OPERANDS ARE REVERSED IN STACK ! %IF JJ>=128 %AND CURRT_FLAGS&(LOADOP1+LOADOP2)=0 %AND %C 1<=128 %AND CURRT_FLAGS&6=2 %THEN COMM=2; ! OPERANDS REVERSED IN ESTACK %FINISH %IF TRIPINF&X'F0000'=0 %AND COMM=2 %THEN %C EXCHANGE(OPND2,OPND1) %AND COMM=1 %UNLESS JJ<128 %OR TRIPINF&X'20000'#0 %THEN %C LOAD(OPND2) PTYPE=OPND1_PTYPE&255; TYPE=PTYPE&7 %IF TYPE=2 %THENSTART %IF PTYPE=X'52' %THEN C=4*(TRIPVAL+2*NISEQS) %ELSE C=4*(TRIPVAL+3*NISEQS) %FINISHELSESTART %IF PTYPE=X'51' %THEN C=4*(TRIPVAL+NISEQS) %ELSE C=4*TRIPVAL %FINISH 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 %OR PARM_FAULTY#0 TRIPSW(*): PB1(NOOP); ! USEFUL IN DEBUGGING TO HAVE ! ERROR POSITION PINPOINTED ->STRES SW(5): ! PLANT ONE BYTE & SET PTYPE OPND1_PTYPE=B3 SW(2): ! PLANT ONE BYTE PB1(B1) OPND1_FLAG=9; ! PREVENT RELOAD IF THIS IS LAST ->STRES SW(6): ! PLANT 2 BYTES & SET PTYPE OPND1_PTYPE=B3 SW(3): ! PLANT 2 BYTES PB2(B1,B2) OPND1_FLAG=9; ! PREVENT RELOAD IF THIS IS LAST ->STRES SW(4): ! PLANT 3 BYTES PB3(B1,B2,B3) OPND1_FLAG=9; ! PREVENT RELOAD IF THIS IS LAST ->STRES SW(7): ! NULL OPERATION ->STRES SUSE: ->STRES SW(10): ! SHORTEN INTEGER TO BYTE %IF PARM_OPT#0 %START PB1(REPL) PBW(LDCW,255) PB1(GTRI) PPJ(JTW,9) %FINISH OPND1_PTYPE=X'31' ->SUSE SW(21): ! SHORTEN FOR JAM TRANSFER PB1(EXCH) ERASE(1) OPND1_PTYPE=X'41' ->SUSE SW(11): ! JAM SHORTEN INTEGER TO BYTE PBW(LDCW,255) PB1(LAND) OPND1_PTYPE=X'31' ->SUSE SW(22): ! EXP IN REAL EXPRSN %IF OPND2_PTYPE&7=1 %THENSTART %IF OPND2_FLAG<=1 %AND 2<=OPND2_D %THEN %C KNOWNEXP(OPND1_PTYPE,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 %THEN %C KNOWNEXP(OPND1_PTYPE,OPND2_D) %AND ->STRES PCALL: ! CALL SUBROUTINE AS DEFINED ! IN CODE TABLE LOAD(OPND2) %IF CURRT_FLAGS&(LOADOP1!LOADOP2)=LOADOP1 %THEN %C EXCHANGE(OPND2,OPND1) PB2(ATPB,B2); ! FOR RESULT PB1(MMS); ! EXPONENT STACKDUMP(B2); ! BASE SAME SIZE AS RESULT PPJ(0,B3); ! CALL ROUTINE STACKUNDUMP(B2); ! RETRIEVE RESULT ->SUSE SW(14): ! DSIDED COMPARISONS NDUPLICATE(B1); ! COPY MIDDLE OPERAND(SIZE IN TABLE) GET WSP(D,B1) DSTORE(2*B1,CURRINF_RBASE,D) CURRT_FLAGS=CURRT_FLAGS!NOTINREG WORKT==TRIPLES(CURRT_PUSE) WORKT_FLAGS=WORKT_FLAGS!LOAD OP1 OPND2_FLAG=7; OPND2_D=CURRINF_RBASE<<16!D SW(13): ! COMPARISONS BFFLAG=COMM-1; ! NOTE BACKWARDS OR FORWARDS C=FCOMP(XTRA&15+16*BFFLAG) COMM=2 WORKT==TRIPLES(CURRT_FLINK); ! ON TO FOLLOWING TRIPLE %IF CURRT_OPTYPE=X'41' %AND(C=EQUI %OR C=NEQI) %%AND %C (WORKT_OPERN=FJUMP %OR WORKT_OPERN=BJUMP) %THEN %START WORKT_X1=WORKT_X1!X'40' %FINISH %ELSE %START PB1(B2) %UNLESS B2=0 PB1(C-B3) %FINISH CURRT_OPND1=OPND2; ! RESULT = SECOND OPND AS ->STRES; ! 2ND OPERAND MAY BE NEEDED IN SW(15): ! SPECIAL MH FOR ARRAY ACCESS C=OPND2_D>>24; ! CURRENT DIMENSION D=OPND2_D>>16&31; ! TOTAL NO OF DIMENSIONS VMY ->STRES SW(18): ! BASE ADJUST ARRAY INDEX DPTYPE=XTRA>>16 %UNLESS PARM_COMPILER#0 %OR DPTYPE&X'300'=X'200' %START D=OPND2_D&X'FFFF' %IF D>0 %START; ! DV KNOWN C=CTABLE(D) %IF HOST#TARGET %THEN C=C<<16!C>>16 %IF B1=1 %THEN PBW(LDCW,C) %ELSE PLW(LDDC,C) %FINISHELSESTART DFETCH(4,OPND2_XTRA>>16,OPND2_XTRA&X'FFFF'+4) PB1(TLATE1) %IF B1=1 %THEN PB1(LDIND) %ELSE PB1(LDDW) %FINISH %IF B1=1 %THEN PB1(ADI) %ELSE PB2(LOPS,LOPSADD) %FINISH ->STRES SW(19): ! ARRAY INDEX DACC=XTRA>>20 %IF DACC<=0 %THEN DFETCH(4,XTRA>>16&15,XTRA&X'FFFF'+4) ! DV PTR B1=WORDS(OPND2_PTYPE>>4&15); ! INDEX IS OPND2 ARRAYSCALE(B1,DACC) ->STRES SW(20): ! INDEXED FETCH %IF PTYPE>>4=3 %THEN PB2(TLATE2,LDB) %ELSE PB2(TLATE1,LDIND) OPND1_PTYPE=X'41' OPND1_FLAG=9 ->STRES SW(16): ! ASSIGN(=) ! ASSIGN(<-) PT=XTRA&255; ! ORIGINAL PT OF LHS HERE %IF PT=0 %THEN PT=CURRT_OPTYPE %IF OPND1_FLAG=2 %START; ! OPERAND A NAME LOAD(OPND2) TCELL==ASLIST(TAGS(OPND1_D)) DSTORE(BYTES(PT>>4),TCELL_UIOJ>>4&15,TCELL_SLINK) %FINISHELSESTART; ! OPERAND A POINTER %IF OPND1_FLAG=INDNAME %START LOADAD(OPND1) %IF CURRT_FLAGS&LOADOP2=0 %THEN EXCHANGE(OPND1,OPND2) %FINISH %ELSE %IF CURRT_FLAGS&LOADOP1#0 %START; ! POINTER NOT LOADED LOAD(OPND1) %IF PT=X'31' %THEN PB1(LOR);! REDUCE BYTE POINTER %IF CURRT_FLAGS&LOADOP2=0 %THEN EXCHANGE(OPND1,OPND2) %FINISH %ELSE %START; ! POINTER IS LOADED %IF PT=X'31' %START %IF CURRT_FLAGS&LOADOP2#0 %THEN PB1(LOR) %ELSE %C PB3(MMS,LOR,MES) %FINISH %FINISH LOAD(OPND2) C=STOREINF(PT>>4) PTLATE(C>>8); ! TRANSLATE POINTER C=C&255 %IF C=ROPS %THEN PB2(C,38) %ELSE PB1(C); ! APPROPIATE STORE %FINISH ->STRES SW(23): ! LOCAL ASSIGNMENT LOAD(OPND2) DSTORE(BYTES(PTYPE>>4&15),OPND1_D>>16,OPND1_D&X'FFFF') ->STRES SW(24): ! COMPARISON WITH ZERO ! ONLY = & # REACH HERE WORKT==TRIPLES(CURRT_FLINK) D=WORKT_X1; ! IBM TYPE MASK C=OPND1_PTYPE>>4&15; ! PREC %IF C=6 %THEN PB2(LOPS,LOPSOR) %IF C>=5 %THEN PB1(LOR) PB1(LDC0) WORKT_X1=D!X'40' ! %IF D=8 %OR D=X'87' %THEN WORKT_X1=D!!X'8F' ->STRES; ! LEAVING VALUE TO BE TESTED AS TRUE OR FALSE TRIPSW(1): ! SET LINE NO %IF PARM_LINE#0 %THEN %START PBW(LDCW,OPND1_D>>16) DSTORE(2,CURRINF_RBASE,OPND1_D&X'FFFF') %FINISH %CONTINUE TRIPSW(3): ! SAVE STACK POINTER ! OPND1 IS TEMPORARY(16 BITS) FOR SAVE PB1(LDTP) DSTORE(2,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' PBW(LDCW,OPND1_D&X'FFFF'); PB1(LDC0+OPND1_D>>16) DSTORE(4,CURRINF_RBASE,D+4) %CONTINUE TRIPSW(71): ! END OF DOPE VECTOR ! OPND1_D=DVF<<16!ELSIZE ! OPND1_XTRA=PTYPE ! XTRA=ND<<16!DVDISP D=OPND1_D&X'FFFF'; ! ELSIZE %IF D=1 %START; ! BYTES PLW(LDDC,1); PB2(LOPS,LOPSADD) PB1(LDCMO); PB2(LOPS,LOPSSHIFT) %FINISH %ELSE %IF D>2 %START PLW(LDDC,D>>1) PB2(LOPS,LOPSMULT) %FINISH DSTORE(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 PLW(LDDC,0) %ELSE %START B1=0 %FOR JJ=1,1,XTRA>>16 %CYCLE %IF C&(1<1 %THEN %START DFETCH(4,CURRINF_RBASE,D+12*JJ-4) PB2(LOPS,LOPSMULT) %FINISH %IF B1>0 %THEN PB2(LOPS,LOPSADD) B1=B1+1; ! COUNT PRODUCTS %FINISH %REPEAT PB2(LOPS,LOPSNEG) %FINISH DSTORE(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 PLW(LDDC,OPND1_D) DSTORE(4,CURRINF_RBASE,D+4) LOAD(OPND2) PB1(REPL2) DSTORE(4,CURRINF_RBASE,D) %IF OPND1_D#1 %THEN PLW(LDDC,OPND1_D-1) %AND PB2(LOPS,LOPSSUB) %FINISH %ELSE %START LOAD(OPND2) DSTORE(4,CURRINF_RBASE,D) LOAD(OPND1) PB1(REPL2) DSTORE(4,CURRINF_RBASE,D+4) DFETCH(4,CURRINF_RBASE,D) PB1(EXCH2) PB2(LOPS,LOPSSUB) PLW(LDDC,1) PB2(LOPS,LOPSADD) %FINISH C=XTRA>>24&255; ! CURRENT DIMENSION %IF C>1 %START; ! MULTPLY UP BY LOWER RNAGES DFETCH(4,CURRINF_RBASE,D-4) PB2(LOPS,LOPSMULT) %FINISH PB1(REPL2) DSTORE(4,CURRINF_RBASE,D+8) %CONTINUE TRIPSW(4): ! DECLARE ARRAY ! OPND1=CDV<<31!C<<24!D<<16!DVDISP ! OPND1_XTRA HAS DICTIONARY NO TCELL==ASLIST(TAGS(OPND1_XTRA)) C=OPND1_D>>24&127 D=OPND1_D>>16&255 %IF C=0 %START; ! DV POINTER KEPT IN ESTACK ! FROM C=0 TO C=D %IF OPND1_D>0 %START; ! DYNAMIC DOPE VECTOR PB1(LSSN) PBW(LLAW,(OPND1_D&X'FFFF')>>1) %FINISHELSESTART; ! DV IN SHAREABLE SYMBOL TABLES DFETCH(4,0,12); ! SST BASE ADDRESS PBW(INCW,(OPND1_D&X'FFFF')>>1) %FINISH %FINISH %IF C0 %START DFETCH(2,CURRINF_RBASE,D+8) %FINISHELSESTART C=CTABLE(OPND1_D>>16&X'7FFF'+2); ! ARRAYSIZE IN WORDS %IF HOST#TARGET %THEN C=C<<16!C>>16 %IF PARM_OPT=0 %THEN ADJUSTSF(C) %AND %CONTINUE PBW(LDCW,C) %FINISH %IF PARM_OPT=0 %THEN PB1(ATPW) %ELSE PPJ(JLK,4) %CONTINUE TRIPSW(6): ! CHECK FOR ZERO FOR STEP LOAD(OPND1); ! STEP TO ESTACK PB1(LDC0) %IF PREC=5 %THEN PB1(REPL) %AND PB2(LOPS,LOPSEQU) %ELSE PB1(EQUI) PPJ(JTW,11) %CONTINUE TRIPSW(7): ! FOR PREAMBLE LOAD(OPND1); ! FORCE INITIAL TO ESTACK %CONTINUE TRIPSW(8): ! FOR POSTAMBLE ERASE(WORDS(CURRT_OPTYPE>>4)) %CONTINUE TRIPSW(9): ! VALIDATE FOR LOAD(OPND1) LOAD(OPND2) %IF PTYPE>>4&15=5 %START; ! 32 BIT FOR PB2(LOPS,LOPSMOD) PB1(LDC0); PB1(REPL) PB2(LOPS,LOPSEQU) %FINISHELSESTART PB1(MODI) PB1(LDC0) PB1(EQUI) %FINISH PPJ(JFW,11) %CONTINUE TRIPSW(10): ! BACK JUMP _X1 HAS TF&MASK ! OPND1_XTRA HAS LABEL CELL ! OPND1_D HAS FLAGS<<24!LABEL NO LCELL==ASLIST(OPND1_XTRA) C=LCELL_S1&X'FFFFFF'; ! CA OF THE LABEL D=CURRT_X1; ! THE MASK BACK JUMP: ! GOTO SW JOINS HERE %IF(CA+2)&CODEBNDRY<2 %THEN CNOP(0,4) C=CA+2-C %IF C<127 %THEN PB2(JCODE(D)-1,-C) %ELSE PBW(JCODE(D),-(C+1)) %CONTINUE TRIPSW(11): ! FORWARD JUMP _X1 HAS TF&MASK ! OPND1_XTRA HAS LABEL CELL<<16!JUMP CELL ! OPND1_D HAS FLAGS<<24!LABEL NO LCELL==ASLIST(OPND1_XTRA&X'FFFF') C=JCODE(CURRT_X1) %IF REACHABLE(OPND1_D&X'FFFFFF',STPTR)=YES %START PB2(C-1,0) LCELL_S1=CA-2 LCELL_S2=1; ! MARK AS SHORT PLANTED %FINISH %ELSE %START PBW(C,0) LCELL_S1=CA-3; ! AFTER ROUNDING FOR ACCENT %FINISH %CONTINUE TRIPSW(12): ! REMOVE LABEL %CONTINUE TRIPSW(13): ! INSERT LABEL ! OPND1_XTRA HAS LABEL CELL LCELL==ASLIST(OPND1_XTRA) %WHILE LCELL_S2#0 %CYCLE; ! FILL FORWARD REFS POP(LCELL_S2,B1,B2,B3); ! B2=1 IF SHORT JUMP PLANTED D=CA-(B1+3-B2) %IF D>>(15-8*B2)>0 %THEN FAULT(98,0,0) PLUG(1,B1+1,D&255,1) PLUG(1,B1+2,D>>8,1) %IF D>255 %REPEAT LCELL_S1=LCELL_S1&X'FF000000'!CA %CONTINUE TRIPSW(14): ! FOR 2ND PREAMBLE ! MAY BE UNNECESSARY NDUPLICATE(WORDS(CURRT_OPTYPE>>4)) %CONTINUE TRIPSW(15): ! RT HEADING OPND1_D=RTNAME ! OPND1_XTRA=AXNAME #0 IF AN ENTRY CURRINF_ENTRYAD=CA %IF OPND1_XTRA#0 %START; ! EXTERNAL NEEDS INITIALISE %IF OPND1_D>=0 %THEN PINITCALL("S#INITGLA") %ELSE %C PINITCALL("S#INITMAIN") %FINISH AXNAMES(CURRLEVEL)=OPND1_XTRA %CONTINUE TRIPSW(16): ! RDAREA - INITIALISE DAIGS AREA ! OPND1_D=N FOR DIAGS AREA PB2(LDODB,16); ! PICK UP M'IDIA' DSTORE(4,CURRINF_RBASE,OPND1_D) %CONTINUE TRIPSW(17): ! RDPTR SET DAIGS POINTER ! OPND1_D=LEVEL NOT CURRINF ALWAYS LINF==WORKA_LEVELINF(OPND1_D) PBW(LDCW,256); ! 256 ARBITARY & WILL BE OVERWRITTEN ! BUT <255 OPTIMISED ! PUSH(LINF_RAL,1,CA-3,0); ! TO OVERWRITE LATER DSTORE(2,LINF_RBASE,LINF_DIAGINF) %CONTINUE TRIPSW(18): ! RTBAD FN-MAP ERROR EXIT WORKT==TRIPLES(CURRT_BLINK); ! PREVIOUS TRIPLE %CONTINUEIF WORKT_OPERN=RTXIT %OR WORKT_OPERN=XSTOP %OR %C (WORKT_OPERN=BJUMP %AND WORKT_X1&15=15) PPJ(JMPW,10) %CONTINUE TRIPSW(19): ! RTXIT - "%RETURN" %IF OPND1_D#0 %THEN CRTEND(OPND1_D) PB1(RETURN) %IF CA>30000 %AND WORKA_PLABS(1)<30000 %THEN REPEAT PROLOGUE %CONTINUE TRIPSW(20): ! XSTOP - "%STOP" CALL STOP %IF OPND1_D#0 %THEN CRTEND(OPND1_D) PB1(RETURN); ! DUMMY EPILOGUE %CONTINUE TRIPSW(61): ! %MONITOR PB1(LDC0) PB1(REPL) PB1(LDAP) PB1(LDC0) PB1(MMS2) PB1(MMS2) PB3(CALLXB,1,0) GXREF("S#NDIAG",0,0,CA-3) %CONTINUE !*********************************************************************** !* SECTION FOR STRING CONCATENATION AND ASSIGNMENT * !*********************************************************************** TRIPSW(21): ! PRECONCAT ! OPND1 IS WORK AREA ! OPND2 HAS FIRST STRING %IF CURRT_FLAGS&LOADOP2=0 %THEN PB1(MMS2) DFETCHAD(YES,OPND1_D>>16,OPND1_D&X'FFFF') PB1(LDC0); ! STRING POINTER %IF CURRT_FLAGS&LOADOP2=0 %THEN PB1(MES2) %ELSE LOAD(OPND2);! 32 BIT AD OF STRING2 PB1(LDC0) PBW(LDCW,255); ! MAX LENGTH PB2(STLATE,X'63'); ! TLATE BOTH ADDRESSES PB1(SAS) 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 %IF CURRT_FLAGS&LOADOP2=0 %THEN PB1(MMS2);! UNLOAD OPND2 IF IN ESTACK DFETCHAD(YES,OPND1_D>>16,OPND1_D&X'FFFF') PB1(REPL2); PB1(REPL2); ! 3 COPIES OF VIRTADDR PB1(LDC0); PB1(TLATE2) PB1(LDB); ! LENGTH ALREADY IN WORKAREA PB1(REPL); PB1(LDC0+1) PB1(ADI); PB1(EXCH) %IF CURRT_FLAGS&LOADOP2=0 %THEN %START PB1(MES); PB1(EXCH) PB1(MES); PB1(EXCH) PB1(MMS); ! ORIGINAL LENGTH TO MEMSTACK %FINISH %ELSE %START PB1(MMS); ! ORIGINAL LENGTH TO MSTACK LOAD(OPND2) %FINISH PB1(REPL2); PB1(LDC0) PB1(TLATE2); PB1(LDB); ! LENGTH TO BE ADDED PB1(LDC0+1); PB1(EXCH); ! STR POINTER TO SECOND BIT PB1(REPL); PB1(MMS); ! BOTH LENGTHS NOW ON MSTACK PB2(STLATE,X'63') PB1(MVBW); ! MOVE BYTES DOES CONCAT PB1(LDC0); ! BYTE POINTER TO LENGTH PB1(MES2); PB1(ADI); ! LENGTHS FETCHED&COMBINED PB1(TLATE3); PB1(STB) OPND1_FLAG=7; ! RESULT IS LOCAL %CONTINUE TRIPSW(39): ! GENERAL STRING ASSIGN LOAD(OPND1); ! PTR (4 WORDS) TO LHS %IF OPND2_FLAG=LCONST %AND OPND2_XTRA=0 %START; ! NULL STRING ASSN PB1(LAND); ! FORCE A ZERO BY ANDING TWO HALVES OF LMAX PB1(TLATE2) PB1(STIND) %FINISHELSESTART %IF CURRT_FLAGS&LOADOP2=0 %START;! OP2 ALREADY LDED GET WSP(D,2) DSTORE(4,CURRINF_RBASE,D) PB1(MMS); ! SAVE LMAX AS HALF & SET A ZERO DFETCH(4,CURRINF_RBASE,D) %FINISH %ELSE %START PB1(MMS); ! SAVE LMAX AS HALF & SET A ZERO LOAD(OPND2) %FINISH PB1(LDC0) PB1(MES); ! MAX LENGTH BACK PB2(STLATE,X'63') PB1(SAS) %FINISH %CONTINUE TRIPSW(40): ! SIMPLE STRING ASSIGN TCELL==ASLIST(TAGS(OPND1_D)) %IF OPND2_FLAG=LCONST %AND OPND2_XTRA=0 %START PB1(LDC0) DSTORE(2,TCELL_UIOJ>>4&15,TCELL_SLINK) %FINISHELSESTART LOAD(OPND1) %IF CURRT_FLAGS&LOADOP2=0 %START; ! OP ALREADY LDED PB1(EXCH2) PB1(LDC0) PERM %FINISHELSE PB1(LDC0) %AND LOAD(OPND2) PB1(LDC0) PBW(LDCW,TCELL_ACC-1); ! LMAX PB2(STLATE,X'63') PB1(SAS) %FINISH %CONTINUE TRIPSW(41): ! STRING JT VIA SUBROUTINE LOAD(OPND1) LOAD(OPND2) STACKDUMP(6) PPJ(0,18) %CONTINUE TRIPSW(46): ! STRING COMPARISONS INCL DSIDED BFFLAG=0 %IF OPND2_FLAG=LCONST %AND OPND2_XTRA=0 %THEN %C OPND==OPND1 %AND ->NULLSC %IF OPND1_FLAG=LCONST %AND OPND1_XTRA=0 %THEN %C OPND==OPND2 %AND BFFLAG=1 %AND ->NULLSC %IF CURRT_FLAGS&LOADOP2#0 %START; ! OPND2 NOT LOADED LOAD(OPND1); PB1(LDC0) LOAD(OPND2); PB1(LDC0) %FINISHELSEIF CURRT_FLAGS&LOADOP1=0 %START; ! BOTH LOADED PB1(LDC0); PERM PB1(LDC0); %FINISHELSESTART; ! ONLY 2 LDED BACK COMP BFFLAG=1 PB1(LDC0) LOAD(OPND1) PB1(LDC0) %FINISH PB2(STLATE,X'52') D=FCOMP(CURRT_X1+16*BFFLAG)-EQUI+EQUSTR PB1(D) %CONTINUE NULLSC: ! TEST FOR A NULL STRING LOAD(OPND) PB1(LDC0) PB1(TLATE2) PB1(LDB) PB1(LDC0) PB1(FCOMP(CURRT_X1+16*BFFLAG)) %CONTINUE TRIPSW(47): ! PRE RESOLUTION 1 ! OPND1 IS 4 WORD WK AREA ! OPND2 IS STRING BEING RESLVD D=OPND1_D&X'FFFF' LOAD(OPND2); ! 32 BIT ADDRESS TO ESTACK PB1(REPL2) DSTORE(4,CURRINF_RBASE,D); ! 32 BIT ADDR TO WK AREA PB1(LDC0) PB1(TLATE2) PB1(LDB); ! CURRENT LENGTH PB1(LDC0) DSTORE(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' PB2(ATPB,1); ! HOLE FOR BOOLEAN RESULT DFETCH(4,CURRINF_RBASE,D) PB1(MMS2); ! RESLN STRING ADDR STACKED DFETCH(2,CURRINF_RBASE,D+6) PB1(MMS); ! BYTES USED ARE STACKED DFETCHAD(YES,CURRINF_RBASE,D+4) PB1(MMS2); ! POINTER TO BYTES USED IS STCKD %IF OPND2_FLAG=SCONST %START; ! NO STRING FOR FRAGMENT PB1(LDC0); PB1(REPL) PB1(REPL); ! THREE ZERO WORD %FINISHELSE LOAD(OPND2) %AND PB1(LOR);! OR 3(!) POINTER WORDS PB1(MMS); PB1(MMS2); ! ARE STACKED %CONTINUE TRIPSW(49): ! RESOLUTION ! OPND1 IS STRING RES EXPR ! OPND2 IS LABEL NO LOAD(OPND1) PB1(MMS2) PPJ(0,16) PB1(MES); ! BOOLEAN RESULT %IF OPND2_D=0 %THEN PPJ(JFW,12); ! UNCONDITIONAL FAILS %CONTINUE TRIPSW(60): ! RESFN FINAL POST RES ASSIGN ! OPND2 HAS POINTER ! SINCE RESOLVED STRING MAY BE CONST ! CAN NOT USE NORMAL ASSIGN LOAD(OPND2); ! POINTER (4 WORDS) TO NEST PB1(LOR); ! REDUCE TO 3 WORDS D=OPND1_D&X'FFFF'; ! TO 4 WORD WK AREA PB1(MMS); ! LMAX TO MSTACK PB1(REPL2); ! 2 COPIES OF VRT ADDR DFETCH(4,CURRINF_RBASE,D+4) PB1(SBI); ! LENGTH OF FRAGMENT PB1(REPL) PB1(REPL) PB1(MMS2); PB1(MMS); ! 3 COPIES TO MSTACK PB1(LDC0+1); ! DEST FOR MVBYTES DFETCH(4,CURRINF_RBASE,D) DFETCH(2,CURRINF_RBASE,D+4) PB1(LDC0+1); PB1(ADI); ! SOURCE FOR MOVE PB1(MES); ! LENGTH ON TOP PB2(STLATE,X'63'); ! ASSIGN ALL BAR LENGTH PB1(MVBW) PB1(LDC0); PB1(MES) PB1(TLATE3); PB1(STCH); ! ASSIGN LENGTH PB1(MES2); PB1(LEQI) PPJ(JFW,9); ! CAPACITY EXCEEDED %CONTINUE !*********************************************************************** !* THIS NEXT SECTION DEALS WITH ROUTINE CALLS AND PARAMETER * !* PASSING. ALSO STORING AND RECOVERY OF FN & MAP RESULTS * !*********************************************************************** TRIPSW(23): ! IOCP CALL LOAD(OPND2) CALL IOCP(OPND1_D); ! ALWAYS CONSTANTS OPND1_FLAG=9; ! FOR WHEN RES NEEDED %CONTINUE TRIPSW(24): ! PRECALL OPND1 HAS RT NAME TCELL==ASLIST(TAGS(OPND1_D)) PTYPE=TCELL_PTYPE %IF PTYPE&15#0 %START; ! FN OR MAP LEAVE RESULT SP %IF PTYPE>>10&3>=2 %START %IF PTYPE&255=X'31' %THEN D=4 %ELSE D=2 %FINISH %ELSE %START %IF PTYPE&15=5 %THEN D=2 %ELSE D=WORDS(PTYPE>>4&15) %FINISH PB2(ATPB,D) %FINISH %CONTINUE TRIPSW(25): ! ROUTINE CALL (AFTER PARAMS) ! OPND1 HAS RT NAME TCELL==ASLIST(TAGS(OPND1_D)) %IF TCELL_UIOJ&15=14 %START; ! EXTERNAL CALL PB3(CALLXB,1,0) GXREF(STRING(ADDR(WORKA_A(WORKA_DICTBASE))+TCELL_SNDISP),0,0,CA-3) %FINISHELSEIF TCELL_PTYPE&X'400'#0 %START DFETCH(8,TCELL_UIOJ>>4&15,TCELL_SNDISP) PB1(CALLV); ! CALL FORMAL PROCEDURE %FINISHELSE PB2(CALL,TCELL_SNDISP) %CONTINUE TRIPSW(44): ! MAP RESULT ASSIGNMENT ! CALLED BEFORE RETURN TO CALLER %IF OPND1_PTYPE&255=X'31' %THEN D=6 %ELSE D=4 RES: LOAD(OPND2) DSTORE(D,CURRINF_RBASE,0) %CONTINUE TRIPSW(45): ! FN RESULT ASSIGNMENT ! CALLED BEFORE RETURN TO CALLER %IF OPND1_PTYPE&255=X'35' %THEN D=4 %ELSE D=BYTES(OPND1_PTYPE>>4&15) ->RES TRIPSW(26): ! RECOVER FN RESULT ! CALLED AFTER RETURN TO CALLER %IF OPND1_PTYPE&255=X'35' %THEN D=2 %ELSE D=WORDS(CURRT_OPTYPE>>4) STACKUNDUMP(D) %CONTINUE TRIPSW(27): ! RECOVER MAP RESULT ! CALLED AFTER RETURN TO CALLER %IF OPND1_PTYPE&255=X'31' %THEN D=4 %ELSE D=2 STACKUNDUMP(D) %IF D=4 %THEN PB1(EXCH2) %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+1)>>1; ! PERQ WORDS FOR STRING VALUE PB1(LDTP); PB1(LDC0); ! PTR TO DEST(TLATED) ADJUSTSF(C) %IF CURRT_FLAGS&LOAD OP2=0 %THEN PB1(EXCH2) %ELSE %C LOAD(OPND2); ! PTR TO STRING PB1(LDC0) PBW(LDCW,D-1); ! FOR ASSNMNT CHECK PB1(TLATE3) PB1(SAS) %FINISHELSEIF OPND1_PTYPE&7=3 %START; ! RECORD BY VALUE C=D>>1 PB1(LSSN) PB1(LDTP) ADJUSTSF(C) %IF OPND2_FLAG=SCONST %THEN D=0 %ELSE %START D=1 %IF CURRT_FLAGS&LOADOP2=0 %THEN PB1(EXCH2) %ELSE LOAD(OPND2) %FINISH BULKM(D,C,0) %FINISHELSESTART LOAD(OPND2) STACKDUMP(WORDS(CURRT_OPTYPE>>4)) %FINISH %CONTINUE TRIPSW(29): ! GET 32 BIT ADDRESS LOADAD(OPND1) ->STRES TRIPSW(30): ! GET POINTER FOR %NAME LOADPTR(OPND1,OPND2) ->STRES TRIPSW(31): ! PARAM PASSING (2) NORMAL PTRS LOAD(OPND2) PTYPE=OPND1_PTYPE&255; ! FOR PARAM %IF PTYPE=X'35' %OR PTYPE=X'31' %START; ! STRING(4 WORD) PTRS PB1(EXCH2) STACKDUMP(2) %FINISH STACKDUMP(2) %CONTINUE TRIPSW(32): ! PARAM PASSING(3) ARRAYS ! ALSO (4) PASS RT PARAM SAME CODE LOAD(OPND2) STACKDUMP(4) %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(8,TCELL_UIOJ>>4&15,TCELL_SNDISP) %FINISHELSEIF TCELL_UIOJ&15=14 %START; ! EXTERNAL PASSED PWW(LVRD,0,X'0100') GXREF(STRING(ADDR(WORKA_A(WORKA_DICTBASE))+TCELL_SNDISP),0,0,CA-5) %FINISHELSE PWW(LVRD,0,TCELL_SNDISP&255!(TCELL_UIOJ>>4&15+2)<<8) %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(8,TCELL_UIOJ>>4&15,TCELL_SNDISP) %FINISH %ELSE %START LOAD(OPND1); ! 32 BIT ADDRESS PLW(LDDC,OPND2_D) PB1(EXCH2) %FINISH %CONTINUE !*********************************************************************** !* SECTION TO DEAL WITH SWITCHES INCLUDING ->SW(EXP) * !*********************************************************************** TRIPSW(33): ! DECLARE SWITCH OPND2 HAS BNDS TCELL==ASLIST(TAGS(OPND1_D)) CNOP(1,2) TCELL_SNDISP<-CA; ! ADDR OF XJP TO TAGS PB1(XJP) PWORD(OPND2_D); ! LBOUND PWORD(OPND2_XTRA) C=WORKA_PLABS(6)-CA; ! DEFAULT PWORD(C) ASLIST(TCELL_SLINK)_S1=CA C=C-2 %FOR D=OPND2_D,1,OPND2_XTRA %CYCLE PWORD(C) C=C-2 %REPEAT %CONTINUE TRIPSW(34): ! SET SWITCH LABEL(OPND2) TCELL==ASLIST(TAGS(OPND1_D)) LCELL==ASLIST(TCELL_SLINK); ! SIDECHAIN HAS TDISP LB&UB C=LCELL_S1+(OPND2_D-LCELL_S2)*2; ! LAB POSITION D=CA-C %IF D>X'7FFF' %THEN FAULT(98,0,0) PLUG(1,C,D,1) PLUG(1,C+1,D>>8,1) %CONTINUE TRIPSW(35): ! GOTO SW LABEL TCELL==ASLIST(TAGS(OPND1_D)) LOAD(OPND2) C=TCELL_SNDISP&X'FFFF'; ! OP PERQ SIGN BIT PROPOGATES D=15; ! MASK FOR UNCONDITIONAL JUMP ->BACK JUMP TRIPSW(37): ! REAL TO INTGER INTPT(OPND1) ! WORK OUT AS(INT(X-0.5) LOAD(OPND1) %IF OPND1_PTYPE>>4&15=6 %START; ! LONGREAL CV2=0.5 %IF HOST=EMAS %THEN CV2=ICLLONGREALTOPERQ(CV2) PLW(LDDC,INTEGER(ADDR(CV2))) PLW(LDDC,INTEGER(ADDR(CV2)+4)) PB2(ROPS,ROPSDSUB) %FINISHELSESTART CV1=0.5 %IF HOST=EMAS %THEN CV1=ICLREALTOPERQ(CV1) PLW(LDDC,INTEGER(ADDR(CV1))) PB2(ROPS,ROPSSUB) %FINISH TRIPSW(36): ! REAL TO INTEGER AS INT LOAD(OPND1) %IF OPND1_PTYPE>>4&7=6 %START PB2(ROPS,ROPSDRND) %FINISHELSESTART PB2(ROPS,ROPSXTNC) %FINISH OPND1_PTYPE=X'51' %CONTINUE TRIPSW(38): ! INTEGER TO STRING AS TOSTRING GET WSP(D,1) LOAD(OPND1) PBW(LDCW,256) PB1(MPI) PB1(LDC0+1) PB1(ADI) DSTORE(2,CURRINF_RBASE,D) OPND1_FLAG=LOCALIR OPND1_PTYPE=X'35' OPND1_D=CURRINF_RBASE<<16!D %CONTINUE TRIPSW(42): ! ARRAYHEAD ASSIGNMENT OPND2_PTYPE=X'61'; ! SO LOAD LOADS HEAD NOT ELEMNT %IF OPND1_FLAG=DNAME %START; ! LHS IN LOCAL SPACE LOAD(OPND2) TCELL==ASLIST(TAGS(OPND1_D)) DSTORE(8,TCELL_UIOJ>>4&15,TCELL_SLINK+OPND1_XTRA) %FINISHELSESTART IMPABORT %UNLESS OPND1_FLAG=INDIRECT %OR OPND1_FLAG=REFTRIP %C %OR OPND1_FLAG=INDNAME %OR PARM_FAULTY#0 %IF OPND1_FLAG=INDIRECT %AND OPND1_XTRA>0 %START %IF CURRT_FLAGS&LOADOP2=0 %THEN STACKDUMP(4) PBW(INCW,OPND1_XTRA>>1) %IF CURRT_FLAGS&LOADOP2=0 %THEN STACKUNDUMP(4) %FINISH %IF OPND1_FLAG=INDNAME %START LOADAD(OPND1) %IF CURRT_FLAGS&LOADOP2=0 %THEN PB1(PERMD) %FINISH LOAD(OPND2) PTLATE(5) PB2(ROPS,ROPSSTQ) %FINISH %CONTINUE TRIPSW(43): ! POINTER ASSIGNMENT D=4 %IF CURRT_OPTYPE>>4>5 %THEN D=8 LOAD(OPND2) %IF OPND1_FLAG=DNAME %START; ! LOCAL PTR TCELL==ASLIST(TAGS(OPND1_D)) %IF D=8 %THEN DSTORE(4,TCELL_UIOJ>>4&15,TCELL_SLINK+OPND1_XTRA+4) DSTORE(4,TCELL_UIOJ>>4&15,TCELL_SLINK+OPND1_XTRA) %CONTINUE %FINISH %UNLESS CURRT_FLAGS&LOADOP1=0 %AND D=4 %AND %C OPND1_FLAG=INDIRECT %AND OPND1_XTRA<=0 %START STACKDUMP(D>>1) LOADAD(OPND1) %IF D=8 %START PB1(REPL2); ! DUPLICATE DEST VA STACKUNDUMP(2) PB1(TLATE2) PB1(STDW) PB2(INCB,2); ! FOR SECOND&THIRD WORD %FINISH STACKUNDUMP(2) %FINISH PB1(TLATE3) PB1(STDW) %CONTINUE TRIPSW(62): ! RECORD ASSIGNMENT LOAD(OPND1); ! DEST %IF OPND2_FLAG=SCONST %THEN BULKM(0,CURRT_X1,OPND2_D) %ANDCONTINUE LOAD(OPND2) %IF CURRT_FLAGS&(LOADOP1!LOAD OP2)=LOADOP1 %THEN EXCHANGE(OPND1,OPND2) BULKM(1,CURRT_X1,0); ! BULKMOVE PARAMS DEFINED AS SOURCE OVER DEST %CONTINUE TRIPSW(64): ! AAINC INCREMENT RECORD RELATIVE ! ARRAY ACCESS BY RECORD BASE(OPND1) ! TO GIVE ABSOLUTE ACCESS. PERQ MUST ! REMEMBER BYTE ARRAYS ARE NONSTANDARD LOAD(OPND2); ! THE RELATIVE ACCESS %IF CURRT_X1=X'31' %THEN PB1(MMS);! BYTES REMOVE EXTRA WORD LOAD(OPND1) PB2(LOPS,LOPSADD); ! LONG ADDITION %IF CURRT_X1=X'31' %THEN PB1(MES);! RETRIEVE BYTE OFFSET ->STRES TRIPSW(65): ! AHADJ ARRAY MAPPING OPND1 1 ! HAS ADJUSTMENT OPND2 THE HEAD ! ARRAYPTYPE<<4!MODE IS IN CURRT_X1 LOAD(OPND1); ! BASE ADDRESS OR ADJMNT %IF CURRT_FLAGS&LOADOP2=0 %THEN EXCHANGE(OPND1,OPND2) %ELSE %C LOAD(OPND2) %IF CURRT_X1&1=0 %START; ! ARRAY MAPPING OPND1 IS BASE ERASE(2); ! DISCARD OLD BASE PB1(EXCH2); ! AND BRING IN THE NEW %FINISH %ELSE %START PB1(EXCH2); ! DV TO TOP PB1(PERMD); ! AND TO VERY BOTTOM PB2(LOPS,LOPSADD); ! ADRESSES ADDED %FINISH %CONTINUE !*********************************************************************** !* SECTION FOR GENERATING CODE FOR INLINE ASSEMBLER * !*********************************************************************** TRIPSW(50): ! UC NOOP CNOP(OPND1_D>>8,OPND1_D&255) %CONTINUE TRIPSW(51): ! UCB1 ONE BYTE ASSEMBLER PB1(OPND1_D); %CONTINUE TRIPSW(52): ! UCB2 TWO BYTE ASSEMBLER PB2(OPND1_D>>8,OPND1_D&255) %CONTINUE TRIPSW(53): ! UCB3 3 BYTE ASSEMBLER PB3(OPND1_D>>16,OPND1_D>>8&255,OPND1_D&255) %CONTINUE TRIPSW(54): ! UCW ASSEMBLER WITH WORD OPERAND PBW(OPND1_D>>16,OPND1_D&X'FFFF') %CONTINUE TRIPSW(55): ! UCBW BYTE&WORD OPERAND ASSEMBLER PB2W(OPND1_D>>24,OPND1_D>>16&255,OPND1_D&X'FFFF') %CONTINUE TRIPSW(59): ! UCNAM ACCESS TO NAMES FROM U-C D=OPND1_D>>16; ! TYPE OF ACCESS C=2 JJ=OPND1_D&X'FFFF' TCELL==ASLIST(TAGS(JJ)) JJ=TCELL_SLINK+OPND1_XTRA; ! NAME OFFSET+OPT INC(IN BYTES!) %IF D=1 %THEN DFETCHAD(NO,TCELL_UIOJ>>4&15,JJ) %ELSEIF D=2 %THEN %C DSTORE(C,TCELL_UIOJ>>4&15,JJ) %ELSE DFETCH(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 C=BYTES(OPND1_PTYPE>>4&15) NDUPLICATE(C>>1) %IF CURRT_FLAGS&USE ESTACK=0 %START; ! DUPLICATE NOT LEFT IN ESTACK %IF CURRT_FLAGS&32#0 %START; ! USE MEMORY STACK STACKDUMP(C>>1) OPND1_D=0 %FINISHELSESTART; ! STORE IN TEMPORARY GET WSP(D,C>>1) DSTORE(C,CURRINF_RBASE,D) OPND1_D=CURRINF_RBASE<<16!D %FINISH %FINISH %FINISH %REPEAT CODEOUT %IF PARM_DCOMP#0 %RETURN %ROUTINE LOAD(%RECORD(RD) %NAME OPND) !*********************************************************************** !* LOAD OPERAND OPND INTO TOP OF NEST(ESTACK) * !*********************************************************************** %INTEGER K,KK,PTYPE,PREC,TYPE %RECORD(TRIPF) %NAME REFTRIP %RECORD(RD)TOPND %RECORD(TAGF) %NAME TCELL %SWITCH SW(0:9) K=OPND_FLAG PTYPE=OPND_PTYPE TYPE=PTYPE&15 PREC=PTYPE>>4&15 %IF K>9 %THEN IMPABORT ->SW(K) SW(0): ! CONSTANT < 16 BITS %IF PREC>4 %THEN ->SW1 PBW(LDCW,OPND_D); ->LDED SW(1): SW1: ! LONG CONSTANT %IF TYPE=5 %THEN ->SCONST %IF HOST=EMAS %AND TYPE=2 %THENSTART KK=ADDR(OPND_D) %IF PREC=6 %THEN LONGREAL(KK)=ICLLONGREALTOPERQ(LONGREAL(KK)) %ELSE %C REAL(KK)=ICLREALTOPERQ(REAL(KK)) %FINISH PLW(LDDC,OPND_XTRA) %IF HOST=PERQ %AND PREC=6 PLW(LDDC,OPND_D) PLW(LDDC,OPND_XTRA) %IF HOST=EMAS %AND PREC=6 ->LDED SCONST: ! STRING CONSTANT OPND_DIS AR PTR CNOP(1,2) PB1(LSA) PB1(WORKA_A(OPND_D+K)) %FOR K=0,1,OPND_XTRA ->LDED SW(3): ! 128 BIT CONSTANT IMPABORT SW(2): ! NAME TCELL==ASLIST(TAGS(OPND_D)) K=BYTES(OPND_PTYPE>>4&15) %IF TYPE=5 %OR TYPE=3 %THENSTART %IF PTYPE&X'400'=0 %THEN ->FAD; ! STRING LOAD = FETCH ADDRESS K=4; ! POINTER IS 4 BYTES %FINISH DFETCH(K,TCELL_UIOJ>>4&15,TCELL_SLINK+OPND_XTRA) LDED: %IF TYPE=1 %AND PREC<4 %THEN OPND_PTYPE=X'41' OPND_FLAG=9 %RETURN SW(5): ! INDIRECT VIA DICTIONARY ! ONLY RECORD SCALAR(_XTRA>=0) ! OR POINTER(_XTRA<0) TCELL==ASLIST(TAGS(OPND_D)) DFETCH(4,TCELL_UIOJ>>4&15,TCELL_SLINK) %IF PREC=3 %AND TYPE=1 %START; ! BYTE SPECIAL AS ALWAYS %IF OPND_XTRA>=0 %THEN PBW(LDCW,OPND_XTRA!!1) %ELSE %C DFETCH(2,TCELL_UIOJ>>4&15,TCELL_SLINK+4) PB1(TLATE2); PB1(LDB); ->LDED %FINISH ->IFETCH SW(4): ! VIA PTR AT OFFSET FROM ! A COMPUTES EXPRESSION REFTRIP==TRIPLES(OPND_D) %IF REFTRIP_PUSE#WTRIPNO %THEN OPND_FLAG=8 %AND LOAD(OPND) %IF OPND_XTRA>0 %THEN PBW(INCW,OPND_XTRA>>1) %IF PREC=3 %AND TYPE=1 %THEN KK=3 %ELSE KK=2 PICKUP PTR(KK) OPND_XTRA=0 ->IFETCH FAD: DFETCHAD(YES,TCELL_UIOJ>>4&15,TCELL_SLINK+OPND_XTRA) ->LDED SW(6): ! INDIRECT WITH OFFSET REFTRIP==TRIPLES(OPND_D) %IF REFTRIP_PUSE#WTRIPNO %START; ! NEED TO LOAD TRIPLE TOPND=OPND TOPND_PTYPE=REFTRIP_OPTYPE TOPND_FLAG=8 LOAD(TOPND) %FINISH IFETCH: %IF TYPE=5 %START PBW(INCW,OPND_XTRA>>1) %IF OPND_XTRA>0 %FINISH %ELSE %IF TYPE=1 %AND PREC=3 %START %IF ((REFTRIP_OPERN=AINDX %OR REFTRIP_OPERN=SINDX) %AND %C REFTRIP_X1>>20=1) %OR (REFTRIP_OPERN=AAINC %AND REFTRIP_X1&255=X'31') %START PBW(INCW,OPND_XTRA) %IF OPND_XTRA>0 %FINISH %ELSE %IF (REFTRIP_OPERN=GETPTR %AND %C REFTRIP_OPND2_D>>16&255=X'31') %OR K=4 %START PB1(LOR) PBW(INCW,OPND1_XTRA) %IF OPND_XTRA>0 %FINISH %ELSE PBW(LDCW,OPND_XTRA&X'7FFFFFFF'!!1) PB1(TLATE2) PB1(LDB) %FINISHELSESTART PBW(INCW,OPND_XTRA>>1) %UNLESS OPND_XTRA<=0 PB1(TLATE1) %IF PREC=4 %THEN PB1(LDIND) %IF PREC=5 %THEN PB1(LDDW) %IF PREC=6 %THEN PB2(ROPS,ROPSLDQ) %FINISH ->LDED SW(7): ! I-R IN A STACK FRAME %IF TYPE=5 %THEN DFETCHAD(YES,OPND_D>>16,OPND_D&X'FFFF') %ELSE %C DFETCH(BYTES(PREC),OPND_D>>16,OPND_D&X'FFFF') ->LDED SW(8): ! TRIPLE REFTRIP==TRIPLES(OPND_D) %IF TYPE=5 %OR REFTRIP_OPERN=LASS %OR REFTRIP_FLAGS&NOTINREG#0 %C %THEN OPND=REFTRIP_OPND1 %AND LOAD(OPND) %ANDRETURN %IF REFTRIP_PUSE=WTRIPNO %START; ! PRIMARY USE== IN NEST ->LDED %FINISH %IF REFTRIP_FLAGS&USE ESTACK#0 %THEN ->LDED; ! LEFT IN ESTACK KK=REFTRIP_OPND1_D %IF KK=0 %START; ! ON MEMEORY STACK %IF PREC=4 %THEN PB1(MES) %ELSE PB1(MES2) %FINISHELSE DFETCH(BYTES(PREC),CURRINF_RBASE,KK&X'FFFF') ->LDED SW(9): ! I-R IN A REGISTER %END %ROUTINE REDUCE BPTR !*********************************************************************** !* REDUCE 4 WORDS TO 2 * !*********************************************************************** PB1(LDCMO) PB2(LOPS,LOPSSHIFT); ! >>1 PB2(LOPS,LOPSADD); ! ADD %END %ROUTINE LOADAD(%RECORD(RD) %NAME OPND) !*********************************************************************** !* MUCH AS LOAD BUT PRODUCES THE 32 BIT ADDRESS OF OPERAND * !* IMPABORT ON NON RELEVANT ALTERNATIVES OF OPND * !************************************************************************ %RECORD(TAGF) %NAME TCELL %RECORD(TRIPF)%NAME REFTRIP %INTEGER B,D,PTYPE %RECORD(RD)TOPND %SWITCH SW(0:9) PTYPE=OPND_PTYPE ->SW(OPND_FLAG) SW(*): ! INVALID IMPABORT SW(2): ! DNAME TCELL==ASLIST(TAGS(OPND_D)) DFETCHAD(YES,TCELL_UIOJ>>4&15,TCELL_SLINK+OPND_XTRA) LDED: OPND_PTYPE=X'51'; ! 32 BIT ADDRESS IS INTEGER OPND_FLAG=9 %RETURN SW(4): ! VIA PTR AT OFFSET FROM ! A COMPUTES EXPRESSION REFTRIP==TRIPLES(OPND_D) %IF REFTRIP_PUSE#WTRIPNO %THEN OPND_FLAG=8 %AND LOAD(OPND) %IF OPND_XTRA>0 %THEN PBW(INCW,OPND1_XTRA>>1) %IF PTYPE&255=X'31' %START PICKUP PTR(4) REDUCE BPTR %FINISH %ELSE PICKUP PTR(2) ->LDED SW(5): ! INDIRECT VIA PTR TCELL==ASLIST(TAGS(OPND_D)) B=TCELL_UIOJ>>4&15 D=TCELL_SLINK PF: DFETCH(4,B,D) %IF PTYPE&255=X'31' %AND OPND_XTRA<0 %START DFETCH(4,B,D+4) REDUCE BPTR %FINISH %ELSE %START %IF OPND_XTRA>0 %THEN PBW(INCW,OPND_XTRA>>1) %FINISH ->LDED SW(6): ! INDIRECT OFFSET REFTRIP==TRIPLES(OPND_D) %IF REFTRIP_PUSE#WTRIPNO %THEN %START TOPND=OPND TOPND_PTYPE=REFTRIP_OPTYPE TOPND_FLAG=8 LOAD(TOPND) %FINISH %IF OPND_PTYPE&255=X'31' %START %IF REFTRIP_OPERN#GETPTR %THEN PB2(LOPS,LOPSLNGTHN) %IF OPND_XTRA>0 %THEN PLW(LDDC,OPND_XTRA) %AND PB2(LOPS,LOPSADD) REDUCE BPTR %FINISH %ELSE %IF OPND_XTRA>0 %THEN PBW(INCW,OPND_XTRA>>1) ->LDED SW(7): ! LOCAL-IR IN BASE&OFFSET FORM B=OPND_D>>16 D=OPND_D&X'FFFF' ->PF %END %ROUTINE LOADPTR(%RECORD(RD) %NAME OPND,OPND2) !*********************************************************************** !* MUCH AS LOAD BUT PRODUCES THE POINTER TO THE OPERAND * !* IMPABORT ON NON RELEVANT ALTERNATIVES OF OPND * !************************************************************************ %RECORD(TAGF) %NAME TCELL %RECORD(TRIPF)%NAME REFTRIP %RECORD(RD)TOPND %INTEGER K,PTYPE %SWITCH SW(0:9) PTYPE=OPND_PTYPE ->SW(OPND_FLAG) SW(*): ! INVALID IMPABORT SW(2): ! DNAME TCELL==ASLIST(TAGS(OPND_D)) DFETCHAD(YES,TCELL_UIOJ>>4&15,TCELL_SLINK+OPND_XTRA) %IF PTYPE&255=X'31' %THEN PLW(LDDC,(((TCELL_SLINK+OPND_XTRA)&1)!!1)) STR: %IF PTYPE&255=X'35' %THEN %START PTYPE=OPND2_D>>16; ! ORIGINAL PTYPE AGAIN %IF OPND2_XTRA<0 %THEN PLW(LDDC,OPND2_XTRA&X'FFF') %ELSE %C %IF PTYPE&X'300'=0 %THEN %C DFETCH(4,OPND2_XTRA>>16,OPND2_XTRA&X'FFFF'+4) %ELSE %START DFETCH(4,OPND2_XTRA>>16,OPND2_XTRA&X'FFFF'+4) PB1(TLATE1); ! DV ADDRESS PB1(SIND0+2) PB1(LDC0+1) PB1(SBI) PB2(LDC0,EXCH) %FINISH %FINISH LDED: OPND_PTYPE=X'51' %IF PTYPE&255=X'31' %OR PTYPE&255=X'35' %THEN OPND_PTYPE=X'61' OPND_FLAG=9 %RETURN SW(4): ! VIA PTR AT OFFSET FROM ! A COMPUTES EXPRESSION REFTRIP==TRIPLES(OPND_D) %IF REFTRIP_PUSE#WTRIPNO %THEN OPND_FLAG=8 %AND LOAD(OPND) %IF OPND_XTRA>0 %THEN PBW(INCW,OPND1_XTRA>>1) %IF PTYPE&255=X'31' %OR PTYPE&255=X'35' %START PICKUP PTR(4) %FINISH %ELSE PICKUP PTR(2) ->LDED SW(5): ! INDIRECT VIA DICT TCELL==ASLIST(TAGS(OPND_D)) %IF OPND_XTRA<0 %START; ! IS A POINTER DFETCH(4,TCELL_UIOJ>>4&15,TCELL_SLINK) %IF PTYPE&255=X'31' %OR PTYPE&255=X'35' %THEN %C DFETCH(4,TCELL_UIOJ>>4&15,TCELL_SLINK+4) ->LDED %FINISH DFETCH(4,TCELL_UIOJ>>4&15,TCELL_SLINK) %IF PTYPE&255=X'31' %THEN PLW(LDDC,OPND_XTRA!!1) %ELSE %C %IF OPND_XTRA>0 %THEN PBW(INCW,OPND_XTRA>>1) ->STR SW(6): ! INDIRECT OFFSET REFTRIP==TRIPLES(OPND_D) %IF REFTRIP_PUSE#WTRIPNO %THEN %START TOPND=OPND TOPND_PTYPE=REFTRIP_OPTYPE TOPND_FLAG=8 LOAD(TOPND) %FINISH ! WHEN PICKING UP A BYTE MUST CHECK FOR ! CASES WHEN THE RESULT IS A BYTE PTR ! IE INDEX ON BYTE ARRAY OR GET PTR ! ON A BYTE(NOT RECORD)PTR %IF PTYPE&255=X'31' %START %IF ((REFTRIP_OPERN=AINDX %OR REFTRIP_OPERN=SINDX) %AND REFTRIP_X1>>20=1) %C %OR (REFTRIP_OPERN=AAINC %AND REFTRIP_X1&255=X'31') %C %OR (REFTRIP_OPERN=GETPTR %AND REFTRIP_OPND2_D>>16&255=X'31') %C %THEN %START %IF REFTRIP_OPERN#GETPTR %THEN PB2(LDC0,EXCH) %IF OPND_XTRA>0 %THEN PBW(INCW,OPND_XTRA) %FINISH %ELSE %START PLW(LDDC,OPND_XTRA&X'7FFFFFFF'!!1) %FINISH %FINISH %ELSE %IF OPND_XTRA>0 %THEN PBW(INCW,OPND_XTRA>>1) ->STR SW(7): ! BASE &DISP CAN ARISE FROM OPTMAP OPTIMISATIONS DFETCHAD(YES,OPND_D>>16,OPND_D&X'FFFF') %IF PTYPE&255=X'31' %THEN PLW(LDDC,((OPND_D&1)!!1)) ->STR %END %ROUTINE VMY !*********************************************************************** !* DOES ALL VECTOR MULTIPLIES * !*********************************************************************** %INTEGER DVPOS,PR,CM DVPOS=OPND2_D&X'FFFF' PR=OPND1_PTYPE>>4&15 %IF PARM_ARR#0 %START DFETCH(4,OPND2_XTRA>>16,OPND2_XTRA&X'FFFF'+4); ! DV PTR PB1(LDC0+C) PPJ(JLK,21+PR); ! TO BOUND CHECK SR %FINISH %IF C#1 %START; ! ALL DIMENSION BAR 1ST %IF DVPOS>0 %THENSTART CM=CTABLE(DVPOS+3*C-1) %IF HOST#TARGET %THEN CM=CM<<16!CM>>16 %IF PR=5 %THEN PLW(LDDC,CM) %ELSE PBW(LDCW,CM) %FINISHELSESTART DFETCH(4,OPND2_XTRA>>16,OPND2_XTRA&X'FFFF'+4); ! DV PTR %IF PR=5 %THENSTART PB2(INCB,6*C-2) PB1(TLATE1) PB1(LDDW) %FINISHELSESTART PB1(TLATE1) PB2(INDB,6*C-2); ! FETCH MULTIPIER %FINISH %FINISH %IF PR=5 %THEN PB2(LOPS,LOPSMULT) %ELSE PB1(MPI) %FINISH %END %ROUTINE REXP !*********************************************************************** !* CALLS A PERM ROUTINE TO PERFORM REAL**REAL * !*********************************************************************** IMPABORT %END %ROUTINE BYTECUT(%INTEGER ODDEVEN) !*********************************************************************** !* ETOS HAS A WORD. EXTRACT HIGH OR LOW ORDER BYTE * !*********************************************************************** %IF ODDEVEN=0 %THENSTART PB2(LDCB,-8) PB2(ROTSHI,0) %FINISHELSESTART PBW(LDCW,255) PB1(LAND) %FINISH %END %ROUTINE PICKUP PTR(%INTEGER WORDS) !************************************************************************ !* ESTACK HAS 32 BIT ADDRESS OF A TWO OR 4 WORD PTR * !* THIS ROUTINE PICKS IT UP * !*********************************************************************** PB1(TLATE1) %IF WORDS=4 %THEN PB3(ROPS,ROPSLDQ,EXCH2) %ELSE PB1(LDDW) %END %ROUTINE DSTORE(%INTEGER SIZE,LEVEL,DISP) !*********************************************************************** !* STORE SIZE(BYTES) FROM DISP(BYTES) IN DISPLAY 'LEVEL' * !*********************************************************************** %INTEGER LEVELCODE,WDISP,OPCODE,WSTORE IMPABORT %UNLESS 0<=DISP<=4096 WDISP=DISP//2 WSTORE=SIZE %IF LEVEL=0 %THEN LEVELCODE=0 %AND OPCODE=STOW %ELSEIF %C LEVEL=CURRINF_RBASE %THEN LEVELCODE=1 %AND OPCODE=STLW %ELSE %C LEVELCODE=2 %AND OPCODE=STIW %IF SIZE=1 %START; ! BYTE STORE VIA ARRAY METHOD %IF LEVELCODE=2 %THEN PB2W(LIAW,CURRINF_RBASE-LEVEL,WDISP) %ELSE %C PBW(OPCODE-2,WDISP) PB1(EXCH) PB1(LDC0+(1!!DISP&1)) PB1(EXCH) PB1(STB) %RETURN %FINISH %WHILE WSTORE>0 %CYCLE %IF WSTORE>=4 %AND LEVELCODE#2 %START; ! OPTIMISE WITH ST DOUBLES PBW(STODW-2*LEVELCODE,WDISP) WSTORE=WSTORE-4 WDISP=WDISP+2 %FINISHELSESTART %IF LEVELCODE=2 %THEN %C PB2W(OPCODE,CURRINF_RBASE-LEVEL,WDISP) %ELSE PBW(OPCODE,WDISP) WSTORE=WSTORE-2 WDISP=WDISP+1 %FINISH %REPEAT %END %ROUTINE DFETCHAD(%INTEGER SEGNO,LEVEL,DISP) !*********************************************************************** !* FETCH ADDRESS OF DISP(BYTES) IN DISPLAY 'LEVEL' * !*********************************************************************** %INTEGER LEVELCODE,WDISP,OPCODE WDISP=DISP//2 %IF LEVEL=0 %THEN LEVELCODE=0 %AND OPCODE=LOAW %ELSEIF %C LEVEL=CURRINF_RBASE %THEN LEVELCODE=1 %AND OPCODE=LLAW %ELSE %C LEVELCODE=2 %AND OPCODE=LIAW PB1(LSSN) %IF SEGNO=YES %IF LEVELCODE=2 %THEN PB2W(OPCODE,CURRINF_RBASE-LEVEL,WDISP) %ELSE %C PBW(OPCODE,WDISP) %END %ROUTINE DFETCH(%INTEGER SIZE,LEVEL,DISP) !*********************************************************************** !* FETCH SIZE(BYTES) FROM DISP(BYTES) IN DISPLAY 'LEVEL' * !*********************************************************************** %INTEGER LEVELCODE,WDISP,OPCODE,WFETCH WDISP=DISP//2+(SIZE-1)>>1 WFETCH=SIZE %IF SIZE=8 %START DFETCHAD(NO,LEVEL,DISP) PB2(ROPS,ROPSLDQ); ! FETCH LONREAL %RETURN %FINISH %IF LEVEL=0 %THEN LEVELCODE=0 %AND OPCODE=LDOW %ELSEIF %C LEVEL=CURRINF_RBASE %THEN LEVELCODE=1 %AND OPCODE=LDLW %ELSE %C LEVELCODE=2 %AND OPCODE=LDIW %IF SIZE=4 %AND LEVELCODE=2 %THENSTART DFETCHAD(NO,LEVEL,DISP) PB1(LDDW) %RETURN %FINISH %WHILE WFETCH>0 %CYCLE %IF WFETCH>=4 %AND LEVELCODE#2 %START; ! NO LD INTERMEDIATE AS YET! PBW(LDODW-2*LEVELCODE,WDISP-1) WDISP=WDISP-2 WFETCH=WFETCH-4 %FINISHELSESTART %IF LEVELCODE=2 %THEN %C PB2W(OPCODE,CURRINF_RBASE-LEVEL,WDISP) %ELSE PBW(OPCODE,WDISP) WFETCH=WFETCH-2 WDISP=WDISP-1 %FINISH %REPEAT %IF SIZE=1 %THEN BYTECUT(DISP&1) %END %INTEGERFN JCODE(%INTEGER TFMASK) %IF TFMASK&15=15 %THENRESULT=JMPW %IF TFMASK&X'40'#0 %START; ! OPTIMISED BU CCOMP %IF TFMASK&15=7 %THENRESULT=JNEW %RESULT=JEQW %FINISH %IF TFMASK&128#0 %THENRESULT=JFW %RESULT=JTW %END %INTEGERFN REACHABLE(%INTEGER LAB,LINK) !*********************************************************************** !* FIND IF A SHORT JUMP CAN REACH THE LABEL USING MAX TRIPCODE FIELD* !* IN TRIPDATA AND ADDING EXTRA FOR IN LINE CONSTS * !*********************************************************************** %INTEGER DIST,I %RECORD(TRIPF)%NAME CURRT %RECORD(RD)%NAME OPND %CONSTINTEGER LIMIT=127 DIST=0 %CYCLE %RESULT=NO %IF LINK=0 %OR DIST>LIMIT CURRT==TRIPLES(LINK) LINK=CURRT_FLINK %RESULT=YES %IF CURRT_OPERN=TLAB %AND CURRT_OPND1_D&X'FFFF'=LAB DIST=DIST+TRIPDATA(CURRT_OPERN)>>8&255 %FOR I=0,1,CURRT_OPERN>>7 %CYCLE %IF I=0 %THEN OPND==CURRT_OPND1 %ELSE OPND==CURRT_OPND2 %IF OPND_FLAG<=1 %START %IF OPND_PTYPE=X'35' %THEN DIST=DIST+OPND_XTRA %ELSE %C DIST=DIST+BYTES(OPND_PTYPE>>4&15) %FINISH %REPEAT %REPEAT %END %ROUTINE CRTEND(%INTEGER KKK) !************************************************************************ !* NOW CLAIM THE STACK FRAME BY SPECIFYING RT DICT ENTRY * !************************************************************************ %INTEGER KP,JJ,BIT,ID,ML %RECORD(RTDICTF) RTDICT %STRING(15)XNAME RTDICT=0 RTDICT_DIAGS<-CAS(DAREA)>>1 ML=CURRINF_M-1 %IF KKK=1 %THEN ID=X'80000000' %AND JJ=WORKA_AMAINEP %ELSE %C ID=ASLIST(TAGS(ML))_SNDISP %AND JJ=ADDR(WORKA_LETT(WORKA_WORD(ML))) %IF AXNAMES(CURRLEVEL)#0 %THEN JJ=AXNAMES(CURRLEVEL) XNAME<-STRING(JJ) XNAME=UCSTRING(XNAME) RTDICT_PS=(CURRINF_PSIZE-CURRINF_RESSIZE)//2 RTDICT_RPS=CURRINF_PSIZE//2 RTDICT_LTS=CURRINF_SNMAX//2-RTDICT_RPS RTDICT_ENTRY<-CURRINF_ENTRYAD RTDICT_EXIT<-CA RTDICT_LL=CURRINF_RBASE %IF CURRINF_RBASE=1 %THEN ID=ID!1<<16; ! FLAG AS EXTERNAL QPUT(11,ID,ADDR(RTDICT),ADDR(XNAME)) %END %ROUTINE KNOWNEXP(%INTEGER PTYPE,VALUE) !*********************************************************************** !* EXPONENTIATION TO A KNOWN POWER * !* VALUE = 2 UPWARDS. VALUE=1 HAS BEEN OPTIMISED OUT * !*********************************************************************** %INTEGER I,MULTS,MULT,PREC,WRDS MULTS=0; I=VALUE PREC=PTYPE>>4&15 WRDS=WORDS(PREC) %IF PTYPE&7=1 %THEN ->INTEXP %IF PREC=6 %START MULT=ROPSDMULT %FINISH %ELSE %START MULT=ROPSMULT %FINISH %WHILE I>1 %CYCLE %IF I&1#0 %START NDUPLICATE(WRDS) STACKDUMP(WRDS) MULTS=MULTS+1 %FINISH NDUPLICATE(WRDS) PB2(ROPS,MULT) I=I>>1 %REPEAT %IF MULTS=0 %THEN %RETURN; ! **2,**4 ETC %WHILE MULTS>0 %CYCLE MULTS=MULTS-1 STACKUNDUMP(WRDS) PB2(ROPS,MULT) %REPEAT %RETURN INTEXP: %WHILE I>1 %CYCLE %IF I&1#0 %START; ! PRESERVE THIS POWER FOR LATER NDUPLICATE(WRDS) STACKDUMP(WRDS) %UNLESS MULTS=0; ! USE ONLY 3 ESTACK CELLS MULTS=MULTS+1 %FINISH NDUPLICATE(WRDS) %IF PREC=4 %THEN PB1(MPI) %ELSE PB2(LOPS,LOPSMULT) I=I>>1 %REPEAT %WHILE MULTS>0 %CYCLE MULTS=MULTS-1 STACKUNDUMP(WRDS) %UNLESS MULTS=0 %IF PREC=4 %THEN PB1(MPI) %ELSE PB2(LOPS,LOPSMULT) %REPEAT %END %END; ! OF ROUTINE GENERATE %ENDOFFILE