%INCLUDE "ERCC07.PERQ_OPCODES" %INCLUDE "ERCC07.TRIPCNSTS" %INCLUDE "ERCC07.TRIMP_TFORM1S" %RECORDFORMAT RTDICTF(%HALFINTEGER PS,RPS,LTS,ENTRY,EXIT, LL,W7,W8,DIAGS,W10,%INTEGER W1112) %OWNINTEGER CABUF,GLACABUF %OWNINTEGERNAME CA,GLACA,PPCURR,GLACURR %OWNBYTEINTEGERARRAYNAME CODE,GLABUF %EXTRINSICRECORD(CODEPF) CODEP %EXTRINSICRECORD(WORKAF)WORKA %EXTRINSICRECORD(PARMF) PARM %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) %EXTERNALROUTINESPEC FAULT(%INTEGER I,J,K) %ROUTINESPEC CNOP(%INTEGER I,J) %ROUTINESPEC POP(%INTEGERNAME A,B,C,D) %ROUTINESPEC PRHEX(%INTEGER VALUE,PLACES) %CONSTINTEGER CODEBNDRY=X'1FF'; ! INSTRUCTIONS MUST NOT ! CROSS THIS IN ACCENT MODE %CONSTINTEGER YES=1,NO=0 %CONSTINTEGER EMAS=10 %CONSTINTEGER PERQ=11 %CONSTINTEGER PNX=12 %CONSTINTEGER HOST=EMAS %CONSTINTEGER TARGET=PERQ %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 %OWNINTEGERARRAY FIXED GLA(0:FIXEDGLALEN>>2-1)=M'IMP ',M'GLAP', 0(6),M'IDIA',0(*); ! !*********************************************************************** !* IMP CODE PLANTING ROUTINES * !* CODE AND GLAP ARE PUT INTO THE BUFFERS 'CODE,GLABUF(0:268)' * !* BY A NUMBER OF TRIVIAL ROUTINES.QPUT IS CALLED TO ADD THE * !* BUFFER TO THE OUTPUT FILE. THE BUFFERS ARE BASICALLY 0:255 * !* WITH A 12-BYTE MARGIN TO MINIMISE THE NUMBER OF TESTS FOR * !* THE BUFFER FULL CONDITION * !* * !* PPCURR(GLACURR) IS THE BUFFER POINTER * !* CA(GLACA) IS THE RELATIVE ADDRESS OF THE NEXT BYTE * !* CABUF(GLACABUF) IS CA(GLACA) FOR START OF BUFFER * !*********************************************************************** !*DELSTART %ROUTINE CPINIT !*********************************************************************** !* PERFORMS ANY NECESSARY TARGET DEPENDANT INITIALISING * !************************************************************************ 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 %CYCLE I=0,1,L-1 GLABUF(GLACURR+I)=BYTE INTEGER(I+INF ADR) %REPEAT 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==CODEP_CAS(AREA) PTR=(PTR+BNDRY-1)&(-BNDRY) QPUT(40+AREA,L,PTR,AD) %IF PARM_INHCODE=0 %IF L>>16#0 %THEN PTR=PTR+(L>>16)*(L&X'FFFF') %ELSE PTR=PTR+L %END %EXTERNALROUTINE PLUG(%INTEGER AREA, AT, VALUE, BYTES) !*********************************************************************** !* WRITE UP TO ONE WORD INTO OBJECT FILE OUT OF SEQUENCE * !*********************************************************************** %INTEGERNAME WCABUF %INTEGER I, RELAD, BUFAD WCABUF==CABUF; BUFAD=ADDR(CODE(0)) %IF AREA=2 %THEN WCABUF==GLACABUF %AND BUFAD=ADDR(GLABUF(0)) RELAD=AT-WCABUF %IF 0<=RELAD<=256 %AND AREA<=3 %THEN %START %CYCLE I=0,1,BYTES-1 BYTEINTEGER(RELAD+BUFAD+I)<-VALUE>>((BYTES-1-I)<<3) %REPEAT %FINISH %ELSE %START %IF RELAD=-2 %THEN CODEOUT %IF PARM_INHCODE=0 %THEN %C QPUT(AREA+40,BYTES,AT,ADDR(VALUE)+4-BYTES) !*DELSTART ! QCODE(ADDR(VALUE)+4-BYTES,ADDR(VALUE)+4,AT,16) %C %IF PARM_DCOMP=1=AREA !*DELEND %FINISH %END %EXTERNALROUTINE GXREF(%STRING(31) NAME,%INTEGER MODE,XTRA,AT) !*********************************************************************** !* ASK QPUT TO ARRANGE FOR A TRIPLE WORD AT 'AT' IN THE GLA * !* TO CONTAIN A DESCRIPTOR FOR NAME 'NAME'. * !* MODE=0 STATIC CODE XREF * !* MODE=1 DYNAMIC CODE XREF * !* MODE=2 DATA XREF XTRA=MINIMIUM LENGTH (SINGLE WORD ONLY) * !*********************************************************************** %INTEGER QPUTNO %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. * !*********************************************************************** %INTEGER Z1,Z2,Z3,Z4 Z1=0; Z2=0; Z3=0; Z4=0 PGLA(4,16,ADDR(Z1)); ! 4 ZERO WORDS AT=GLACA-16 GXREF(NAME,MODE,XTRA,AT) %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 P2=OPND2_PTYPE>>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,39) %END %ROUTINE BULKM(%INTEGER MODE,L,D2) !*********************************************************************** !* PLANT CODE TO MOVE L BYTES (L KNOWN AT COMPILE TIME) FROM * !* ETOS-2,ETOS-3 TO ETOS,ETOS-1 * !* IF MODE =0 SET L BYTES TO D2(0 OR X'80') * !* * !* L MAY BE GREATER THAN 4095 * !*********************************************************************** %INTEGER W2 %IF MODE=0 %START; ! CLEAR W2=D2<<8!D2 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 %ELSE PB1(EXCH2); ! PARAMS WRONG WAY UP %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 DUPLICATE(%INTEGER WORDS) !*********************************************************************** !* REPLCATES 1,2 OR 4 WORDS IN THE ESTACK. WRITTEN TO AVOID * !* THE ABSENCE OF REPL4 INSTRUCTIO * !************************************************************************ %IF WORDS=1 %THEN PB1(REPL) %AND %RETURN %IF WORDS=2 %THEN PB1(REPL2) %AND %RETURN PB1(EXCH2) PB1(REPL2) PB1(PERMD) PB1(EXCH2) PB1(REPL2) PB1(PERMD) %END %ROUTINE SMALLEXP(%INTEGER FLAG,VALUE) !************************************************************************ !* FLAG=0 FOR 16BIT INT,=1 FOR 32BIT INT,=2&3 FOR 32&64BIT REALS * !* VALUE = 2,3 OR 4. VALUE=1 HAS BEEN OPTIMISED OUT * !*********************************************************************** %INTEGER ESC %SWITCH SW(2:13) %IF FLAG<=1 %THEN ESC=LOPS %ELSE ESC=ROPS ->SW(3*FLAG+VALUE) SW(4): ! 16BIT****4 PB1(REPL) PB1(MPI) SW(2): ! 16BIT****2 PB1(REPL) PB1(MPI) %RETURN SW(3): ! 16BIT****3 PB1(REPL) PB1(REPL) PB1(MPI) PB1(MPI) %RETURN SW(7): ! 32BIT****4 SW(10): ! 32BIT**4 PB1(REPL2) PB2(ESC,5) SW(5): ! 32BIT****2 SW(8): ! 32BIT**2 PB1(REPL2) PB2(ESC,5) %RETURN SW(6): ! 32BIT****3 SW(9): ! 32BIT**3 PB1(REPL2) PB1(REPL2) PB2(ESC,5) PB2(ESC,5) %RETURN SW(13): ! 64BIT**4 DUPLICATE(4) PB2(ESC,21) SW(11): ! 64BIT**2 DUPLICATE(4) PB2(ESC,21) %RETURN SW(12): ! 64BIT**3 ! CARE TO USE ONLY ESTACK CELLS DUPLICATE(4) PB1(MMS2); PB1(MMS2) DUPLICATE(4) PB2(ESC,21) PB1(MES2); PB1(MES2) PB2(ESC,21) %END %ROUTINE CIOCP(%INTEGER N) !*********************************************************************** !* COMPILES A CALL ON IOCP ENTRY POINT NO 'N' * !* 2ND PARAMETER IS ALREADY IN ETOS * !*********************************************************************** %CONSTINTEGER NEEDS RES=X'20016'; ! FLAGS EPS 1,2,4&18 %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<>I&15)) %REPEAT %END %EXTERNALROUTINE ABORT PRINTSTRING(" **************** ABORT******************** ABORT *******") !*DELSTART RECODE(ADDR(CODE(0)), ADDR(CODE(PPCURR)), CABUF) %C %UNLESS CA=CABUF !*DELEND %MONITOR %STOP %END %EXTERNALROUTINE PROLOGUE !*********************************************************************** !* GENERATES THE SUBROUTINE THAT ALWAYS ARE REQUIRED ONTO THE * !* FRONT OF THE OBJECT PROGRAM WHERE THEY ARE DIRECTLY ADDRESABLE* !*********************************************************************** %ROUTINESPEC ERR EXIT(%INTEGER A, B, C) %INTEGER I, K, L, STCA CPINIT; ! INITIALISE CODE PLANTING CA==CODEP_CAS(1) GLACA==CODEP_CAS(2) GLACA=FIXEDGLALEN GLACABUF=FIXEDGLALEN CODE==CODEP_CODE GLABUF==CODEP_GLABUF PPCURR==CODEP_CACURR(1) GLACURR==CODEP_CACURR(2) I=X'C2C2C2C2' QPUT(40+DAREA,4,0,ADDR(I)) CODEP_CAS(DAREA)=4 %CYCLE I=0, 1, 31 WORKA_PLABS(I)=0; WORKA_PLINK(I)=0 %REPEAT ! ! GENERATE THE FIXED-FLOAT CONSTANTS THAT MAY BE NEEDED ! PWORD(0) %FOR I=1,1,4 WORKA_PLABS(1)=CA ! ! GENERATE THE RUN TIME ERROR ROUTINE :- ! MDIAGS FOR PERQ IS %ROUTINE MDIAGS(%INT PC,AP,ERROR,XTRA) ! PC IS A DUMMY EXCEPT AFTER CONTINGENCY ! ON ENTRY TO THIS SUBROUTINE ERROR & XTRA ARE IN ETOS ! ENTRY HAS BEEN BY JMPW LINKREG SO RETURN ADDRESS IS NOT AVAILABLE ! ! LDAP ACTIVATION POINTER TO ETOS ! LDC0 ZERO AS DUMMY PC ! MMS2 ABOVE TWO REVERSED TO MEMMORY ! MMS2 ZERO AND EXTRA TO MEMORY ! CALXB 0,0 CALL TO NDIAGS ! WORKA_PLABS(2)=CA PB2(LDAP,LDC0) PB2(MMS2,MMS2) PB3(CALLXB,1,0) GXREF(MDEP,0,0,CA-3); ! RELOCATION OF CALL ! ! SUBROUTINE TO CALL DEBUG ROUTINE(S#IMPMON) LINE NO IN GR0 ! ! STM 4,0,16(11) ! LM CODER,EPREG,EPDIST ! BCR 15,LINKREG RETURN ADDR ALREADY IN GR15 ! %IF PARM_DBUG#0 %THEN %START WORKA_PLABS(3)=CA ! CXREF("S#IMPMON",PARM_DYNAMIC,2,K) %FINISH ! ! SUBROUTINE TO ADVANCE STACK FRONT BY ETOS WORDS AND CHECK FOR OFLOW ! ! REPL,LDC0,EXCH ! KEEP COPY AND MAKE LONG ! LDC0,LDTP,ADDL ! LENGTH AFTER PROOSED ADJUST ! LDC0,LDCW X'F000',LEQI L ! JTB ! LDC0,LDCW X'201', JMP ! EXCESS BLOCKS ERROR !OK: MES, EXCH ! ATPW, MMS, 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,2) PB1(LDC0) PBW(LDCW,X'F000') PB2(LOPS,11) 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 = MAX LENGTH OF DEST ! L1&2= VIRT ADDR OF DEST ! L3&4= VIRT ADDR OF SOURCE ! L6 = LOCAL THE ACTUAL STRING BYTES TO BE MOVED ! ! LLAB 3,LDDW PICK UP SOURCE ! LDC0,TLATE2,LDB LENGTH ! REPL STL6 ! LDL0,LEQI JTB ! LDL0,STL6 !OK: ! LDL2,LDL1,LDC1 POINTER TO DEST ! LDL4,LDL3,LDC1 AND TO SOURCE ! LDL6,STLATE X'63',MVBW MOVE TEXT ! LDL2,LDL1,LDC0,LDL6 ! TLATE3,STB ADD LENGTH ! RETURN %IF WORKA_PLINK(18)=0 %THEN ->P19 R=0 R_PS=5 R_RPS=5 R_LTS=2 R_ENTRY=CA PB2(LLAB,3) PB1(LDDW) PB1(LDC0) PB1(TLATE2) PB1(LDB) PB1(REPL) PB1(STL0+6) PB1(LDL0) PB1(LEQI) PB2(JTB,2) PB1(LDL0) PB1(STL0+6) ! LABEL "OK" IS HERE PB1(LDL0+2) PB1(LDL0+1) PB1(LDC0+1) PB1(LDL0+4) PB1(LDL0+3) PB1(LDC0+1) PB1(LDL0+6) PB2(STLATE,X'63') PB1(MVBW) PB1(LDL0+2) PB1(LDL0+1) 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,5) 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,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(ROPS,5) 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,1) PB2(LDLDB,0) PB2(ROPS,6) 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,17) ! 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,37) PB2(ROPS,21) 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,17) PB2(LDLDB,2) PB2(LDLDB,0) PB2(ROPS,22) 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 %IF WORKA_PLINK(23)=0 %THEN ->P24 FILL(23) PB1(REPL) PB1(LDC0) PB1(LDB) PB1(REPL) PB1(MES) PB1(EXCH) PB1(MMS2) PB1(LDC0+1) PB1(ADI) PB1(JMS) 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 %IF WORKA_PLINK(24)=0 %THEN ->P25 FILL(24) PB1(MES2) PB1(EXCH) PB1(MMS2) PB1(EXCH2) PB1(EXCH) PB1(REPL) PB1(LDC0) PB1(PERMD) PB1(EXCH) PB1(EXCH2) PB1(REPL2) PB1(LDC0) PB1(TLATE2) PB1(LDCH) PB1(REPL) PB1(MMS) PB1(LDC0+1) PB1(EXCH) PB1(TLATE3) PB1(MVBW) PB1(MES2) PB1(ADI) PB1(STB) PB1(JMS) 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 ! REPL2, TLATE1, SIND0, MMS ! TLATE1, SIND2,MES ! CHK, JMS %IF WORKA_PLINK(25)=0 %THEN ->P26 FILL(25) PB1(LDC0+6) PB1(MPI) PB1(ADI) PB1(REPL2) PB1(TLATE1) PB1(SIND0) PB1(MMS) PB1(TLATE1) PB1(SIND0+2) PB1(MES) PB1(CHK) 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,37) 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,15) PB2(LOPS,2) 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,1) PB2(LOPS,5) PB1(LDCMO) PB2(LOPS,15) PB2(LOPS,2) 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, CODEP_CAS(DAREA), ADDR(I)) CODEP_CAS(DAREA)=CODEP_CAS(DAREA)+4 %FINISH %CYCLE I=1,1,6 CODEP_CAS(I)=(CODEP_CAS(I)+7)&(-8) %REPEAT PRINTSTRING(" CODE") WRITE(CA, 6) %IF CODEP_CAS(4)>0 %THEN PRINTSTRING("+") %AND %C WRITE(CODEP_CAS(4),4) PRINTSTRING(" BYTES GLAP") WRITE(GLACA, 3); PRINTSTRING("+") WRITE(CODEP_CAS(5), 1); PRINTSTRING(" BYTES DIAG TABLES") WRITE(CODEP_CAS(DAREA), 3); PRINTSTRING(" BYTES TOTAL") K=CA+GLACA+CODEP_CAS(4)+CODEP_CAS(5)+CODEP_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 CODEP_CACURR(0)=K; ! SERVES AS CAS(7) %IF PARM_INHCODE=0 %THEN QPUT(7, 28, 0, ADDR(CODEP_CAS(1))) ! SUMMARY INFO. PPROFILE %STOP %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 %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 %STRINGFN PRINTNAME(%INTEGER N) %INTEGER V, K %STRING(255)S S="???" %IF 0<=N<=WORKA_NNAMES %START V=WORKA_WORD(N) K=WORKA_LETT(V) %IF K#0 %THEN S=STRING(ADDR(WORKA_LETT(V))) %FINISH %RESULT=S %END %EXTERNALROUTINE PRINT TRIPS(%RECORD(TRIPF)%ARRAYNAME TRIPS) !*********************************************************************** !* OUTPUTS A TRIPLES LIST IN READABLE FORM * !*********************************************************************** %CONST%STRING(5)%ARRAY OPERATION(0:190)= %C " ? ","RT HD","RDSPY","RDARE","RDPTR", "RTBAD","RTXIT","XSTOP"," ? "," ? ", " \ "," -U "," FLT "," ABS ","SHRNK", "STRCH"," JAM "," ??? ","NO OP","PRELD", " ? ","SSPTR","RSPTR","ASPTR","DARRY", "SLINE","STPCK","FRPRE","FPOST","FRPR2", "PRECL","RCALL","RCRFR","RCRMR"," ? ", "GETAD"," INT ","INTPT","TOSTR","MNITR", "PPROF","RTFP ","ONEV1","ONEV2"," ? "(6), "UCNOP","UCB1 ","UCB2 ","UCB3 ","UCB4 ", "UCBW ","UCWW ","UCLW ","UCB2W","UCNAM", " ? "(68), " + "," - "," !! "," ! "," * ", " // "," / "," & "," >> "," << ", " ** "," COMP","DCOMP"," VMY "," COMB", " = "," <- "," ****"," ADJ "," INDX", "IFTCH","LASS ","FORCK","PRECC","CNCAT", "IOCPC","PASS1","PASS2","PASS3", "PASS4"," ? "(2), "BJUMP","FJUMP","REMLB","TLAB ","DCLSW", "SETSW","-> SW"," S=1 "," S=2 "," S<- ", "AHASS","PTRAS","MAPRS","FNRES","SCOMP", "SDCMP","PRES1","PRES2","RESLN","RESFN", "SIGEV","RECAS","AAINC","AHADJ","CTGEN", "GETPR", " ? "(*); %RECORD(TRIPF)%NAME CURR %INTEGER I %ROUTINESPEC OPOUT(%RECORD(RD)%NAME OPND) PRINTSTRING(" TRIPLES FOR LINE"); WRITE(WORKA_LINE,3) PRINTSTRING(" NO OPRN PT C D FLGS PUSE X1 OPERAND 1 OPERAND 2") I=TRIPS(0)_FLINK %WHILE I>0 %CYCLE NEWLINE CURR==TRIPS(I) WRITE(I,2) SPACE PRINTSTRING(OPERATION(CURR_OPERN)) SPACE PRHEX(CURR_OPTYPE,2) WRITE(CURR_CNT,2) WRITE(CURR_DPTH,2) SPACES(1) PRHEX(CURR_FLAGS,4) WRITE(CURR_PUSE,3) SPACE PRHEX(CURR_X1,8) SPACE OPOUT(CURR_OPND1) OPOUT(CURR_OPND2) %IF CURR_OPERN>=128 I=CURR_FLINK %REPEAT %RETURN %ROUTINE OPOUT(%RECORD(RD)%NAME OPND) %STRING(17)T %STRING(12)S %INTEGER I %SWITCH SW(0:9) PRHEX(OPND_PTYPE,4) ->SW(OPND_FLAG) SW(0):SW(1): ! COCNSTANT PRINTSTRING(" ") %IF OPND_PTYPE&7=5 %START; ! STRING CONSTS %CYCLE I=0,1,17 BYTEINTEGER(ADDR(T)+I)=WORKA_A(OPND_D+I) %REPEAT T<-T." " PRINTSTRING(T) %FINISH %ELSE %START PRHEX(OPND_D,8) SPACE %IF OPND_PTYPE>>4>5 %THEN PRHEX(OPND_XTRA,8) %ELSE SPACES(8) %FINISH SPACES(2) %RETURN SW(2): ! NAME PRINTSTRING(" NAME ") NAM: S<-PRINTNAME(OPND_D)." " PRINTSTRING(S) %IF OPND_XTRA#0 %THEN PRINTSTRING("+ ") %ELSE SPACES(2) %RETURN SW(5): ! 32 BIT ADDRESS PRINTSTRING(" ADDR ") ->NAM SW(7): ! IN A STACK FRAME PRINTSTRING(" VAR/TEMP ") PRHEX(OPND_D,8) SPACES(2) %RETURN SW(6): ! INDIRECT PRINTSTRING("INDIRECT-OFFSET") WRITE(OPND_D,2) SPACES(2) %RETURN SW(8): ! A TRIPLE PRINTSTRING(" TRIPLE ") WRITE(OPND_D,2) SPACES(9) %RETURN SW(9): ! REGISTER ITEM PRINTSTRING(" ITEM IN ESTACK ") SPACES(4) %END %END %EXTERNALREALFN ICL Real to PERQ (%REAL ICL Real) ! ! ! ! ! This is a function which converts a real number in ICL ! ! floating-point format into one that is in ICL PERQ ! ! floating-point format. ! ! ! At Exit: RESULT= +infinity if ICL Real is too large ! RESULT= -infinity if ICL Real is too small ! RESULT= PERQ Real otherwise ! ! !Assumptions: (i). PERQ floating-point format conforms with the %C 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' ! ! ! Constants ! ! %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} ! Locals %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 !Examine the ICL Real: ! ! %IF PARM_X#0 %THEN %RESULT=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 %C %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} %C + 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 ! %END; !of ICL Real to PERQ %EXTERNALLONGREALFN ICL LongReal to PERQ (%LONGREAL ICL2900 Real) ! ! ! ! ! This is a function which converts a double precision real ! ! in ICL 2900 floating-point format into one that is ! ! in ICL PERQ floating-point format. ! ! ! At Exit: RESULT= equivalent PERQ real ! ! !Assumptions: (i). PERQ floating-point format conforms with the %C 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' ! ! ! Locals ! ! %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) %LONGINTEGER PERQ Fraction; !fraction of PERQ Real (derived from ICL2900 Fraction) %LONGREAL PERQ Real !--the Result !Examine the ICL2900 Real: ! ! %IF PARM_X#0 %THEN %RESULT=ICL2900REAL; ! FOR SIMULATOR %IF ICL2900 Real= 0.0 %THENRESULT= 0.0 ! %IF ICL2900 Real< 0.0 %THEN SIGN= 1 %AND ICL2900 Real=-ICL2900 Real %C %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} %C - 64{which is the ICL2900 bias} %C - 1{ as the most significant digit is <1 and >=1/16} %C ) * 4{ as the ICL2900 exponent is a hex exponent} %C %C + (11 - bits shifted left) %C {bits shifted left equals 11, or 10, or 9, or 8} %C %C + 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 ! %END; !of ICL2900 LongReal to PERQ %OWNINTEGERNAME ASL %OWNRECORD(LISTF)%ARRAYNAME ASLIST %EXTERNALROUTINE INITASL(%RECORD(LISTF)%ARRAYNAME SPACE,%INTEGERNAME PTR) !*********************************************************************** !* INITIALISES THE ASL AND REMEMBERS IT LOCATION !*********************************************************************** %INTEGER I ASLIST==SPACE ASL==PTR WORKA_ASL CUR BTM=ASL-240 WORKA_CONST LIMIT=4*WORKA_ASL CUR BTM-8 %CYCLE I=WORKA_ASL CUR BTM,1,ASL-1 ASLIST(I+1)_LINK=I %REPEAT ASLIST(WORKA_ASL CUR BTM)_LINK=0 ASLIST(0)_S1=-1 ASLIST(0)_S2=-1 ASLIST(0)_S3=-1 ASLIST(0)_LINK=0 %END %EXTERNALROUTINE PRINT LIST(%INTEGER HEAD) !*********************************************************************** !* A DEBUGGING ONLY ROUTINE. !*********************************************************************** %RECORD(LISTF)%NAME LCELL %INTEGER I,J,K PRINTSTRING(" PRINT OF LIST ") WRITE(HEAD,2) NEWLINE %WHILE HEAD#0 %CYCLE LCELL==ASLIST(HEAD) WRITE(HEAD,3) SPACES(3) PRHEX(LCELL_S1,8) SPACES(3) PRHEX(LCELL_S2,8) SPACES(3) PRHEX(LCELL_S3,8) NEWLINE HEAD=LCELL_LINK&X'FFFF'; ! EXTRA LINK IN TAGS LIST!! %REPEAT %END %EXTERNALROUTINE CHECK ASL !*********************************************************************** !* CHECK ASL AND PRINT NO OF FREE CELLS. DEBUGGING SERVICE ONLY * !*********************************************************************** %INTEGER N,Q Q=ASL; N=0 %WHILE Q#0 %CYCLE N=N+1 Q=ASLIST(Q)_LINK %REPEAT NEWLINE PRINTSTRING("FREE CELLS AFTER LINE ") WRITE(WORKA_LINE,3) PRINTSYMBOL('=') WRITE(N,3) %END %EXTERNALINTEGERFN MORE SPACE !*********************************************************************** !* FORMATS UP SOME MORE OF THE ASL * !*********************************************************************** %INTEGER I,N,CL,AMOUNT N=WORKA_ASL CUR BTM-1 AMOUNT=(WORKA_NNAMES+1)>>3; ! EIGHTTH OF NNAMES I=WORKA_ASL CUR BTM-((WORKA_CONST PTR+8)>>2);! GAP BETWEEN CONSTS &ASL %IF I>>1>1;! TAKE ONLY HALF THE REMAINDER %IF AMOUNT<20 %THEN AMOUNT=0 WORKA_ASL CUR BTM=WORKA_ASL CUR BTM-AMOUNT %IF WORKA_ASL CUR BTM<=1 %THEN WORKA_ASL CUR BTM=1 CL=4*WORKA_ASL CUR BTM-8 %IF WORKA_ASL CUR BTM>=N %OR WORKA_CONST PTR>CL %THEN %START FAULT(102, WORKA_WKFILEK,0) %FINISH %ELSE WORKA_CONST LIMIT=CL; ! NEW VALUE WITH BIGGER ASL %CYCLE I=WORKA_ASL CUR BTM,1,N-1 ASLIST(I+1)_LINK=I %REPEAT ASLIST(WORKA_ASL CUR BTM)_LINK=0 ASL=N; %RESULT=N %END !%EXTERNALINTEGERFN NEW CELL !*********************************************************************** !* PROVIDE A NEW LIST PROCESSING CELL. CRAPOUT IF NONE AVAILABLE * !*********************************************************************** !%INTEGER I ! %IF ASL=0 %THEN ASL=MORE SPACE ! I=ASL ! ASL=ASLIST(ASL)_LINK ! ASLIST(I)_LINK=0 ! %RESULT =I !%END %EXTERNALROUTINE PUSH(%INTEGERNAME CELL, %INTEGER S1, S2, S3) !*********************************************************************** !* PUSH A CELL CONTAINING THE 3 STREAMS OF INFORMATION GIVEN * !* ONTO THE TOP OF THE LIST POINTED AT BY CELL. * !*********************************************************************** %RECORD(LISTF)%NAME LCELL %INTEGER I I=ASL %IF I=0 %THEN I=MORE SPACE LCELL==ASLIST(I) ASL=LCELL_LINK LCELL_LINK=CELL CELL=I LCELL_S1=S1 LCELL_S2=S2 LCELL_S3=S3 %END %EXTERNALROUTINE POP(%INTEGERNAME CELL, S1, S2, S3) !*********************************************************************** !* COPY THE INFORMATION FROM THE TOP CELL OF LIST 'CELL' INTO * !* S1,S2&S3 AND THEN POP THE LIST UP 1 CELL. EMPTYLIST GIVE -1S* !*********************************************************************** %INTEGER I %RECORD(LISTF)%NAME LCELL I=CELL LCELL==ASLIST(I) S1=LCELL_S1 S2=LCELL_S2 S3=LCELL_S3 %IF I# 0 %THEN %START CELL=LCELL_LINK LCELL_LINK=ASL ASL=I %FINISH %END %EXTERNALROUTINE BINSERT(%INTEGERNAME TOP,BOT,%INTEGER S1,S2,S3) !*********************************************************************** !* INSERT A CELL AT THE BOTTOM OF A LIST * !* UPDATING TOP AND BOTTOM POINTERS APPROPIATELY * !*********************************************************************** %INTEGER I,J %RECORD(LISTF)%NAME LCELL I=ASL %IF I=0 %THEN I=MORE SPACE LCELL==ASLIST(I) ASL=LCELL_LINK LCELL_S1=S1; LCELL_S2=S2 LCELL_S3=S3; LCELL_LINK=0 J=BOT %IF J=0 %THEN BOT=I %AND TOP=BOT %ELSE %START ASLIST(J)_LINK=I BOT=I %FINISH %END %EXTERNALROUTINE INSERT AFTER(%INTEGERNAME PLACE,%INTEGER S1,S2,S3) !*********************************************************************** !* ADDS A CELL INT THE MIDDLE OF A LIST AFTER "CELL" WHICH * !* IS UPDATED * !*********************************************************************** %INTEGER I %RECORD(LISTF)%NAME OLDCELL,CELL FAULT(109,0,0) %IF PLACE<=0 I=ASL %IF I=0 %THEN I=MORE SPACE CELL==ASLIST(I) ASL=CELL_LINK OLDCELL==ASLIST(PLACE) CELL_S1=S1; CELL_S2=S2 CELL_S3=S3 CELL_LINK=OLDCELL_LINK OLDCELL_LINK=I PLACE=I %END %EXTERNALROUTINE INSERT AT END(%INTEGERNAME CELL, %INTEGER S1, S2, S3) !*********************************************************************** !* ADD A CELL TO THE BOTTOM OF THE LIST HEADED BY 'CELL' * !*********************************************************************** %INTEGER I,J,N %RECORD(LISTF)%NAME LCELL I=CELL; J=I %WHILE I#0 %CYCLE J=I I=ASLIST(J)_LINK %REPEAT N=ASL %IF N=0 %THEN N=MORE SPACE LCELL==ASLIST(N) ASL=LCELL_LINK %IF J=0 %THEN CELL=N %ELSE ASLIST(J)_LINK=N LCELL_S1=S1 LCELL_S2=S2 LCELL_S3=S3 LCELL_LINK=0 %END %EXTERNALINTEGERFN FIND(%INTEGER LAB, LIST) !*********************************************************************** !* THIS FUNCTION SEARCHES LIST 'LIST' FOR LAB IN STREAM2 AND * !* RETURNS THE CORRESPONDING CELL NO.IT USED FOR MORE THAN * !* SCANNING LABEL LISTS. * !*********************************************************************** %WHILE LIST#0 %CYCLE %RESULT=LIST %IF LAB=ASLIST(LIST)_S2 LIST=ASLIST(LIST)_LINK %REPEAT %RESULT=-1 %END %EXTERNALROUTINE CLEAR LIST(%INTEGERNAME OPHEAD) !*********************************************************************** !* THROW AWAY A COMPLETE LIST (MAY BE NULL!) * !*********************************************************************** %INTEGER I, J I=OPHEAD; J=I %WHILE I#0 %CYCLE J=I I=ASLIST(J)_LINK %REPEAT %IF J#0 %START ASLIST(J)_LINK=ASL ASL=OPHEAD; OPHEAD=0 %FINISH %END !%EXTERNALROUTINE CONCAT(%INTEGERNAME LIST1, LIST2) !!*********************************************************************** !!* ADDS LIST2 TO BOTTOM OF LIST1 * !!*********************************************************************** !%INTEGER I,J ! I=LIST1 ! J=I ! %WHILE I#0 %THEN J=I %AND I=ASLIST(J)_LINK ! %IF J=0 %THEN LIST1=LIST2 %ELSE ASLIST(J)_LINK=LIST2 ! LIST2=0 !%END; ! AN ERROR PUTS CELL TWICE ONTO ! FREE LIST - CATASTROPHIC! %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,15); ! SACLE BY SHIFTING %FINISH %ELSE %START PLW(LDDC,(DACC+1)>>1) PB2(LOPS,5); ! MULTIPLY LONG %FINISH %FINISH PB2(LOPS,2); ! 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 %RETURN %IF PREC=4 %THEN OPND_H0<-I %AND %RETURN %IF PREC=5 %THEN OPND_H0<-I %AND OPND_H1<-I>>16 %AND %RETURN ABORT %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 ABORT %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,CODEP_CAS(DAREA)>>9&255,1) PLUG(1,JJ+1,CODEP_CAS(DAREA)>>1&255,1) %FINISH %ELSE %START PLUG(Q,JJ+2,CODEP_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, %RECORD(LEVELF) %NAME CURRINF, %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 CEND(%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 DSTORE(%INTEGER SIZE,LEVEL,DISP) %ROUTINESPEC DFETCH(%INTEGER SIZE,LEVEL,DISP) %ROUTINESPEC DFETCHAD(%INTEGER SEGNO,LEVEL,DISP) ! %RECORD(RD) %NAME OPND1,OPND2,OPND %RECORD(TRIPF) %NAME CURRT,WORKT %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}, 0(6), 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'20000E1E'{138 **}, X'2001041F'{139 COMP}, X'20010420'{140 DCOMP}, X'20020A21'{141 VMY}, X'20010422'{142 COMB}, X'200E0623'{143 ASSIGN=}, X'200E0624'{144 ASSIGN<-}, X'20020E25'{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'10000B15'{151 PRE CONCAT}, X'10000A16'{152 COCNCATENEATION}, X'10000C17'{153 IOCP CALL}, X'10000C1C'{154 PARAMETER ASSIGNMENT 1 NORMAL VALUES}, X'1000041F'{155 PARAM ASSNG 2 NORMAL PTRS}, X'10000220'{156 PARAM ASSGN 3 ARRAYS}, X'10000220'{157 ASSGN FORMAL RT-CODE AS 156}, X'10000220'{158 PASS5 TYPE GENERAL NAME}, 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}, 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 ! %CONSTBYTEINTEGERARRAY ISEQS(40:4*138-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,1,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,1,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}, 3,LOPS,16,0 {10 32 BIT LOGICAL NOT}, 3,LOPS,3,0 {11 32 BIT LOGICAL NEGATE}, 6,ROPS,17,X'62' {12 32 BIT FLOAT TO 64 BIT REAL}, 3,LOPS,8,0 {13 32 BIT MODULUS}, 6,LOPS,0,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,2,0 {20 32 BIT ADDITION}, 3,LOPS,4,0 {21 32 BIT SUBTRACTION}, 3,LOPS,19,0 {22 32 BIT NONEQUIVALENCE}, 3,LOPS,18,0 {23 32 BIT LOGICAL OR}, 3,LOPS,5,0 {24 32 BIT MULTIPLY}, 3,LOPS,6,0 {25 32 BIT INTEGER DIVIDE}, 1,0,0,109 {26 32 BIT REAL DIVIDE}, 3,LOPS,17,0 {27 32 BIT AND}, 4,NGI,LOPS,15 {28 32 BIT LEFT SHIFT}, 3,LOPS,15,0 {29 32 BIT RIGHT SHIFT}, 12,0,0,0 {30 REAL EXP OPERATOR}, 13,2,LOPS,EQUI-9 {31 COMPARISONS}, 14,2,LOPS,EQUI-9 {32 FIRST PART OF DOUBLE COMPARISONS}, 15,0,0,0 {33 VMY}, 3,LOPS,2,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}, 7,0,0,0 {10 32 BIT LOGICAL NOT}, 3,ROPS,3,0 {11 32 BIT LOGICAL NEGATE}, 1,0,0,109 {FLOAT REAL COMPILER ERROR}, 3,ROPS,8,0 {13 32 BIT REAL MODULUS}, 1,0,0,109 {14 SHORTEN 32 BIT TO 16 BIT}, 6,ROPS,35,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,2,0 {20 32 BIT ADDITION}, 3,ROPS,4,0 {21 32 BIT SUBTRACTION}, 7,0,0,0 {22 32 BIT NONEQUIVALENCE}, 7,0,0,0 {23 32 BIT LOGICAL OR}, 3,ROPS,5,0 {24 32 BIT MULTIPLY}, 7,0,0,0 {25 32 BIT INTEGER DIVIDE}, 3,ROPS,6,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-9 {31 COMPARISONS}, 14,2,ROPS,EQUI-9 {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}, 7,0,0,0 {10 64 BIT LOGICAL NOT}, 3,ROPS,19,0 {11 64 BIT LOGICAL NEGATE}, 1,0,0,109 {FLOAT REAL COMPILER ERROR}, 3,ROPS,24,0 {13 64 BIT MODULUS}, 6,ROPS,34,X'52' {14 SHORTEN 64 BIT TO 32 BIT}, 1,0,0,109 {15 LENGTHEN 64 BIT TO 64 BIT}, 6,ROPS,34,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,18,0 {20 64 BIT ADDITION}, 3,ROPS,20,0 {21 64 BIT SUBTRACTION}, 7,0,0,0 {22 64 BIT NONEQUIVALENCE}, 7,0,0,0 {23 64 BIT LOGICAL OR}, 3,ROPS,21,0 {24 64 BIT MULTIPLY}, 7,0,0,0 {25 64 BIT INTEGER DIVIDE}, 3,ROPS,22,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-25 {31 COMPARISONS}, 14,2,ROPS,EQUI-25 {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,37 {40 INDEXED FETCH 64 BIT INDEX}, 23,0,0,0 {41 LASS} %SWITCH SW(0:23),TRIPSW(0:70) ! FLAG AND FOLD(TRIPLES) %IF PARM_OPT#0;! ALREADY DONE FOR OPT=0 %IF PARM_DCOMP#0 %THEN PRINT TRIPS(TRIPLES) STPTR=TRIPLES(0)_FLINK %WHILE STPTR>0 %CYCLE CURRT==TRIPLES(STPTR) WTRIPNO=STPTR STPTR=CURRT_FLINK COMM=1 OPND1==CURRT_OPND1 OPND2==CURRT_OPND2 XTRA=CURRT_X1 JJ=CURRT_OPERN TRIPINF=TRIPDATA(JJ) C=TRIPINF>>28; ! TRIPLE TYPE TRIPVAL=TRIPINF&255 %IF C=0 %THENCONTINUE %IF C=1 %THEN ->TRIPSW(TRIPVAL) %IF OPND1_FLAG#9 %AND TRIPINF&X'40000'=0 %START; ! OP1 NOT LOADED LOAD(OPND1) %IF JJ>=128 %AND CURRT_FLAGS&6=2 %START; ! OPERANDS REVERSED IN ESTACK %UNLESS TRIPINF&X'90000'#0 %THEN EXCHANGE(OPND2,OPND1) %ELSE %C COMM=2 %FINISH %FINISH %UNLESS JJ<128 %OR OPND2_FLAG=9 %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+64) %ELSE C=4*(TRIPVAL+96) %FINISHELSEIF PTYPE=X'51' %THEN C=4*(TRIPVAL+32) %ELSE C=4*TRIPVAL L0=ISEQS(C); B1=ISEQS(C+1) B2=ISEQS(C+2); B3=ISEQS(C+3) ->SW(L0) SW(1): ! ERROR CONDITION TRIPSW(0): FAULT(B3,0,0) %UNLESS TYPE=7 TRIPSW(*): 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<=4 %THEN %C SMALL EXP(B1,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<=4 %THEN %C SMALL EXP(B1,OPND2_D) %AND ->STRES PCALL: ! CALL SUBROUTINE AS DEFINED ! IN CODE TABLE LOAD(OPND2) 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 DUPLICATE(B1); ! COPY MIDDLE OPERAND(SIZE IN TABLE) GET WSP(D,B1) DSTORE(2*B1,CURRINF_RBASE,D) 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 %IF CURRT_OPTYPE=X'41' %AND(C=EQUI %OR C=NEQI) %START WORKT==TRIPLES(CURRT_FLINK); ! ON TO FOLLOWING TRIPLE %IF WORKT_OPERN=FJUMP %OR WORKT_OPERN=BJUMP %THEN %C WORKT_X1=WORKT_X1!X'40' %AND ->STRES %FINISH PB1(B2) %UNLESS B2=0 PB1(C-B3) ->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=WORKA_CTABLE(D) %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,2) %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(WORKA_TAGS(OPND1_D)) DSTORE(BYTES(PT>>4),TCELL_UIOJ>>4&15,TCELL_SLINK) %FINISHELSESTART; ! OPERAND A POINTER %IF CURRT_FLAGS&LOADOP1#0 %START; ! POINTER NOT LOADED LOAD(OPND1) %IF CURRT_FLAGS&LOADOP2=0 %THEN EXCHANGE(OPND1,OPND2) %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 TRIPSW(1): ! SET LINE NO PBW(LDCW,OPND1_D>>16) DSTORE(2,CURRINF_RBASE,OPND1_D&X'FFFF') %CONTINUE TRIPSW(3): ! SAVE STACK POINTER ! OPND1 IS TEMPORARY(16 BITS) FOR SAVE PB1(LDTP) DSTORE(2,CURRINF_RBASE,OPND1_D) %CONTINUE TRIPSW(4): ! DECLARE ARRAY ! OPND1=CDV<<31!C<<24!D<<16!DVDISP ! OPND1_XTRA HAS HED OFFSET 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=WORKA_CTABLE(OPND1_D>>16&X'7FFF'+2); ! ARRAYSIZE IN WORDS %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,9) %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 PREC=5 %START; ! 32 BIT FOR PB2(LOPS,7) PB1(LDC0); PB1(REPL) PB2(LOPS,9) %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 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 JUMP CELL LCELL==ASLIST(OPND1_XTRA) C=JCODE(CURRT_X1) %IF REACHABLE(OPND1_D,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 DUPLICATE(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 %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" PB1(RETURN) %IF OPND1_D#0 %THEN CEND(OPND1_D) %CONTINUE TRIPSW(20): ! XSTOP - "%STOP" CALL STOP %IF OPND1_D#0 %THEN CEND(OPND1_D) %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 DFETCHAD(NO,OPND1_D>>16,OPND1_D&X'FFFF') PB1(LDC0); ! STRING POINTER (TLATED!) %IF CURRT_FLAGS&LOADOP2=0 %THEN PB1(EXCH2) %ELSE %C LOAD(OPND2); ! 32 BIT AD OF STRING2 PB1(LDC0) PBW(LDCW,255); ! MAX LENGTH PB1(TLATE3); ! TLATE OPND2 ADDRESS 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 DFETCHAD(NO,OPND1_D>>16,OPND1_D&X'FFFF') PPJ(JLK,23); ! THIS SR LEAVE 32 BITS IN ESTACK %IF CURRT_FLAGS&LOADOP2#0 %THEN LOAD(OPND2) %ELSE PB1(EXCH2) PPJ(JLK,24) OPND1_FLAG=7; ! RESULT IS LOCAL %CONTINUE TRIPSW(39): ! GENERAL STRING ASSIGN LOAD(OPND1); ! PTR (3 WORDS) TO LHS %IF OPND2_FLAG=LCONST %AND OPND2_XTRA=0 %START; ! NULL STRING ASSN PB1(REPL) PB1(NEQBOOL); ! FORCE A ZERO PB1(TLATE2) PB1(STIND) %FINISHELSESTART PB1(MMS); ! SAVE MAX LENGTH PB1(LDC0) LOAD(OPND2) PB1(LDC0) PB1(MES); ! MAX LENGTH BACK PB2(STLATE,X'63') PB1(SAS) %FINISH %CONTINUE TRIPSW(40): ! SIMPLE STRING ASSIGN TCELL==ASLIST(WORKA_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) STACKDUMP(3) LOAD(OPND2) STACKDUMP(2) 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(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); ! 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 TO NEST 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) CIOCP(OPND1_D); ! ALWAYS CONSTANTS OPND1_FLAG=9; ! FOR WHEN RES NEEDED %CONTINUE TRIPSW(24): ! PRECALL OPND1 HAS RT NAME TCELL==ASLIST(WORKA_TAGS(OPND1_D)) PTYPE=TCELL_PTYPE %IF PTYPE&15#0 %START; ! FN OR MAP LEAVE RESULT SP %IF PTYPE>>10&3>=2 %OR PTYPE&15=5 %THEN D=2 %ELSE %C D=WORDS(PTYPE>>4&15) PB2(ATPB,D) %FINISH %CONTINUE TRIPSW(25): ! ROUTINE CALL (AFTER PARAMS) ! OPND1 HAS RT NAME TCELL==ASLIST(WORKA_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=3 %ELSE D=2 STACKUNDUMP(D); %CONTINUE TRIPSW(28): ! PASS PARAMETER(1)= NORMAL VALUE LCELL==ASLIST(OPND1_XTRA&X'FFFF'); ! PARAM DESCTR CELL D=LCELL_S2>>16; ! PARAM_ACC MISPLACED %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 D=1 %AND LOAD(OPND2) BULKM(D,C,0) %FINISHELSESTART LOAD(OPND2) STACKDUMP(WORDS(CURRT_OPTYPE>>4)) %FINISH %CONTINUE TRIPSW(29): ! GET 32 BIT ADDRESS LOADAD(OPND1) %CONTINUE TRIPSW(30): ! GET POINTER FOR %NAME LOADPTR(OPND1,OPND2) %CONTINUE TRIPSW(31): ! PARAM PASSING (2) NORMAL PTRS PTYPE=OPND1_PTYPE&255; ! FOR PARAM %IF PTYPE=X'35' %OR PTYPE=X'31' %START; ! STRING(3 WORD) PTRS PB1(EXCH) STACKDUMP(1) PB1(EXCH) %FINISH STACKDUMP(2) %CONTINUE TRIPSW(32): ! PARAM PASSING(3) ARRAYS ! ALSO (4) PASS RT PARAM SAME CODE STACKDUMP(4) %CONTINUE TRIPSW(63): ! RTFP TURN RTNAME INTO FORMAL TCELL==ASLIST(WORKA_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(WORKA_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(WORKA_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(WORKA_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(WORKA_TAGS(OPND1_D)) LOAD(OPND2) C=TCELL_SNDISP 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,20) %FINISHELSESTART CV1=0.5 %IF HOST=EMAS %THEN CV1=ICLREALTOPERQ(CV1) PLW(LDDC,INTEGER(ADDR(CV1))) PB2(ROPS,4) %FINISH TRIPSW(36): ! REAL TO INTEGER AS INT LOAD(OPND1) %IF OPND1_PTYPE>>4&7=6 %START PB2(ROPS,23) %FINISHELSESTART PB2(ROPS,32) %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(WORKA_TAGS(OPND1_D)) DSTORE(8,TCELL_UIOJ>>4&15,TCELL_SLINK) %FINISHELSESTART ABORT %UNLESS OPND1_FLAG=INDIRECT %OR OPND1_FLAG=REFTRIP %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 LOAD(OPND2) PTLATE(5) PB2(ROPS,38) %FINISH %CONTINUE TRIPSW(43): ! POINTER ASSIGNMENT D=4 %UNLESS X'31'#OPND1_PTYPE&255#X'35' %THEN D=6 LOAD(OPND2) %IF OPND1_FLAG=DNAME %START; ! LOCAL PTR TCELL==ASLIST(WORKA_TAGS(OPND1_D)) %IF D=6 %THEN DSTORE(2,TCELL_UIOJ>>4&15,TCELL_SLINK+4) DSTORE(4,TCELL_UIOJ>>4&15,TCELL_SLINK) %CONTINUE %FINISH %UNLESS CURRT_FLAGS&LOADOP1=0 %AND D=4 %START STACKDUMP(D>>1) LOAD(OPND1) %IF D=6 %START PB1(REPL2); ! DUPLICATE DEST VA STACKUNDUMP(1) PB1(TLATE2) PB1(STIND) PB2(INCB,1); ! FOR SECOND&THIRD WORD %FINISH STACKUNDUMP(2) %FINISH PB1(TLATE3) PB1(STDW) %CONTINUE TRIPSW(62): ! RECORD ASSIGNMENT LOAD(OPND1) %IF CURRT_FLAGS&LOAD OP2=0 %THEN EXCHANGE(OPND1,OPND2) %IF OPND2_FLAG=SCONST %THEN BULKM(0,CURRT_X1,OPND2_D) %ANDCONTINUE LOAD(OPND2) BULKM(1,CURRT_X1,0) %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,2); ! LONG ADDITION %IF CURRT_X1=X'31' %THEN PB1(MES);! RETRIEVE BYTE OFFSET %CONTINUE TRIPSW(65): ! AHADJ ARRAY MAPPING OPND1 1 ! HAS ADJUSTMENT OPND2 THE HEAD ! 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=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,2); ! 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>>28 C=OPND1_D>>16&63; ! LEVEL JJ=OPND1_D&X'FFFF' %IF D=1 %THEN DFETCHAD(NO,C,JJ) %ELSEIF D=2 %THEN %C DSTORE(2,C,JJ) %ELSE DFETCH(2,C,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) DUPLICATE(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 %RETURN %ROUTINE LOAD(%RECORD(RD) %NAME OPND) !*********************************************************************** !* LOAD OPERAND OPND INTO TOP OF NEST(ESTACK) * !*********************************************************************** %INTEGER K,KK %RECORD(TRIPF) %NAME REFTRIP %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 ABORT ->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_D) PLW(LDDC,OPND_XTRA) %IF 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 ABORT SW(2): ! NAME TCELL==ASLIST(WORKA_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(WORKA_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) %ELSE %C DFETCH(2,TCELL_UIOJ>>4&15,TCELL_SLINK+4) PB1(TLATE2); PB1(LDB); ->LDED %FINISH ->IFETCH SW(4): ! CONDITIONAL EXPRESSION ABORT 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 OPND_FLAG=8 LOAD(OPND) %FINISH IFETCH: %IF TYPE=5 %START PBW(INCW,OPND_XTRA>>1) %IF OPND_XTRA>0 %FINISH %ELSE %IF TYPE=1 %AND PREC=3 %START PBW(LDCW,OPND_XTRA) %UNLESS %C REFTRIP_OPERN=AINDX %OR REFTRIP_OPERN=GETPTR 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,37) %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 %THEN LOAD(REFTRIP_OPND1) %ANDRETURN %IF REFTRIP_OPERN=LASS %THEN %C 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 3WORDS TO 2 !*********************************************************************** PB1(LDC0); PB1(EXCH) PB1(LDCMO) PB2(LOPS,15); ! >>1 PB2(LOPS,2); ! ADD %END %ROUTINE LOADAD(%RECORD(RD) %NAME OPND) !*********************************************************************** !* MUCH AS LOAD BUT PRODUCES THE 32 BIT ADDRESS OF OPERAND * !* ABORT ON NON RELEVANT ALTERNATIVES OF OPND * !************************************************************************ %RECORD(TAGF) %NAME TCELL %INTEGER B,D %SWITCH SW(0:9) PTYPE=OPND_PTYPE ->SW(OPND_FLAG) SW(*): ! INVALID ABORT SW(2): ! DNAME TCELL==ASLIST(WORKA_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(5): ! INDIRECT VIA PTR TCELL==ASLIST(WORKA_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(2,B,D+4) REDUCE BPTR %FINISH %ELSE %START %IF OPND_XTRA>0 %THEN PBW(INCW,OPND_XTRA) %FINISH ->LDED SW(6): ! INDIRECT OFFSET %IF OPND_PTYPE&255=X'31' %START %IF OPND_XTRA>0 %THEN PBW(INCW,OPND_XTRA) 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 * !* ABORT ON NON RELEVANT ALTERNATIVES OF OPND * !************************************************************************ %RECORD(TAGF) %NAME TCELL %INTEGER K %SWITCH SW(0:9) PTYPE=OPND_PTYPE ->SW(OPND_FLAG) SW(*): ! INVALID ABORT SW(2): ! DNAME TCELL==ASLIST(WORKA_TAGS(OPND_D)) DFETCHAD(YES,TCELL_UIOJ>>4&15,TCELL_SLINK+OPND_XTRA) %IF PTYPE&255=X'31' %THEN PB1(LDC0+(((TCELL_SLINK+OPND_XTRA)&1)!!1)) STR: %IF PTYPE&255=X'35' %THEN %START PTYPE=OPND2_D>>16; ! ORIGINAL PTYPE AGAIN %IF PTYPE&X'400'=0 %THEN PBW(LDCW,OPND2_D&X'FFF'-1) %ELSE %C %IF PTYPE&X'300'=0 %THEN %C DFETCH(2,OPND2_XTRA>>16,OPND2_XTRA&X'FFFF') %ELSE %START DFETCH(4,OPND2_XTRA>>16,OPND2_XTRA&X'FFFF') PB1(TLATE1); ! DV ADDRESS PB1(SIND0+2) PB1(LDC0+1) PB1(SBI) %FINISH %FINISH LDED: OPND_FLAG=9 %RETURN SW(5): ! INDIRECT VIA DICT TCELL==ASLIST(WORKA_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(2,TCELL_UIOJ>>4&15,TCELL_SLINK+4) ->LDED %FINISH DFETCH(4,TCELL_UIOJ>>4&15,TCELL_SLINK) %IF PTYPE&255=X'31' %THEN PBW(LDCW,OPND_XTRA) %ELSE %C %IF OPND_XTRA>0 %THEN PBW(INCW,OPND_XTRA>>1) ->STR SW(6): ! INDIRECT OFFSET %IF OPND_XTRA>0 %THEN PBW(INCW,OPND_XTRA>>1) %IF PTYPE&255=X'31' %AND TRIPLES(OPND_D)_OPERN#AINDX %THEN %C PBW(LDCW,OPND_XTRA) ->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=WORKA_CTABLE(DVPOS+3*C-1) %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,5) %ELSE PB1(MPI) %FINISH %END %ROUTINE REXP !*********************************************************************** !* CALLS A PERM ROUTINE TO PERFORM REAL**REAL * !*********************************************************************** ABORT %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 DSTORE(%INTEGER SIZE,LEVEL,DISP) !*********************************************************************** !* STORE SIZE(BYTES) FROM DISP(BYTES) IN DISPLAY 'LEVEL' * !*********************************************************************** %INTEGER LEVELCODE,WDISP,OPCODE,WSTORE ABORT %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,37); ! 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=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 CEND(%INTEGER KKK) !************************************************************************ !* NOW CLAIM THE STACK FRAME BY SPECIFYING RT DICT ENTRY * !************************************************************************ %INTEGER KP,JJ,BIT,ID,ML %RECORD(RTDICTF) RTDICT RTDICT=0 RTDICT_DIAGS=CODEP_CAS(DAREA)>>1 ML=CURRINF_M-1 %IF KKK=1 %THEN ID=X'80000000' %AND JJ=WORKA_AMAINEP %ELSE %C ID=ASLIST(WORKA_TAGS(ML))_SNDISP %AND JJ=ADDR(WORKA_LETT(WORKA_WORD(ML))) 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),JJ) %IF CA>30000 %AND WORKA_PLABS(1)<30000 %THEN REPEAT PROLOGUE %END %END; ! OF ROUTINE GENERATE %ENDOFFILE