%INCLUDE "ERCC07.PERQ_OPCODES" %INCLUDE "ERCC07.TRIPCNSTS" %INCLUDE "ERCC07.PERQ_FORMAT3S" %OWNINTEGER CABUF,GLACABUF %OWNINTEGERNAME CA,GLACA,PPCURR,GLACURR %OWNBYTEINTEGERARRAYNAME CODE,GLABUF %EXTRINSICRECORD(CODEPF) CODEP %EXTRINSICRECORD(WORKAF)WORKA %EXTRINSICRECORD(PARMF) PARM %SYSTEMINTEGERMAPSPEC COMREG(%INTEGER N) %DYNAMICROUTINESPEC QCODE(%INTEGER A,B,C,MODE) %DYNAMICROUTINESPEC QPUT(%INTEGER A,B,C,D) %ROUTINESPEC 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 ON PERQ=NO %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 ! ! 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 %EXTERNALROUTINE 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 %EXTERNALROUTINE 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 %EXTERNALROUTINE 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 %EXTERNALROUTINE 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 %EXTERNALROUTINE 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 %EXTERNALROUTINE 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 %EXTERNALROUTINE 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 %EXTERNALROUTINE 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 %EXTERNALROUTINE 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 %EXTERNALROUTINE 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 %EXTERNALROUTINE PTLATE(%INTEGER DEPTH) !*********************************************************************** !* SELECT A SUITABLE TRANSLATE INSTRUCTION * !*********************************************************************** %IF 1<=DEPTH<=3 %THEN PB1(TLATE1+DEPTH-1) %ELSE %C PB2(STLATE,DEPTH*16) %END %EXTERNALROUTINE PERM !*********************************************************************** !* EX KDF9 ROUTINE REARRANGE ESTACK FROM ABC TO BCA * !*********************************************************************** PB1(EXCH); ! BAC PB1(MMS); ! AC PB1(EXCH); ! CA PB1(MES); ! BCA %END %EXTERNALROUTINE CAB !*********************************************************************** !* EX KDF9 ROUTINE REARRANGE ESTACK FROM ABC TO CAB !*********************************************************************** PB1(MMS); ! BC PB1(EXCH); ! CB PB1(MES); ! ACB PB1(EXCH); ! CAB %END %EXTERNALROUTINE 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 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,0,0) GXREF(S,0,0,CA-3) %END %ROUTINE CALL STOP !*********************************************************************** !* CALLS STOP ROUTINE. NOT VIA EPILOGUE ON PERQ * !************************************************************************ %INTEGER J J=CA PB3(CALLXB,0,0) GXREF("S#STOP",0,0,J) %END %EXTERNALROUTINE ERASE(%INTEGER WORDS) !*********************************************************************** !* REMOVES 1 OR 2 WORDS FROM THE ESTACK * !*********************************************************************** %IF WORDS=1 %THEN PB2(JTB,0) %ELSE PB2(JEQB,0) %END %EXTERNALROUTINE 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 %EXTERNALROUTINE 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 %EXTERNALROUTINE 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 %EXTERNALROUTINE 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 %EXTERNALROUTINE 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 %EXTERNALROUTINE CIOCP(%INTEGER N) !*********************************************************************** !* COMPILES A CALL ON IOCP ENTRY POINT NO 'N' * !* 2ND PARAMETER IS ALREADY IN ETOS * !*********************************************************************** %CONSTSTRING(8)IOCPEP="S#IOCP"; ! EP FOR IOCP PB2(ATPB,1); ! HOLE FOR 16BIT RESULT PBW(LDCW,N) PB2(MMS,MMS2) PB3(CALLXB,0,0) GXREF(IOCPEP,0,0,CA-3) %END %EXTERNALROUTINE RELOCATE(%INTEGER BITS,GLARAD,AREA) !*********************************************************************** !* PLANTS A WORD IN THE GLA (IF GLARAD<0) AND ARRANGES TO * !* RELOCATE IT RELATIVE TO AN AREA(CODE=1,GLA=2,CST=4,GST=5 * !*********************************************************************** %INTEGER QP %IF BITS=16 %THEN QP=20 %ELSE QP=19 QPUT(QP,0,GLARAD,AREA) %END %EXTERNALROUTINE DEFINE EP(%STRING(255)NAME, %INTEGER ADR,AT,MAIN) !*********************************************************************** !* TO DEFINE AN EP SIMPLY TELL QPUT THE EP ADDRESS RELATIVE TO THE * !* START IF CODE. THIS IS STORED IN THE LOAD DATA. AT LOAD TIME * !* THE THREE WORDS IN THE GLA OF THE CALLING ROUTINE ARE FILLED * !* WITH START IF CODE,START OF GLA AND EP ADDRESS RESPECTIVELY * !* (DOCUMENTATION OF OBJECT FORMAT & QPUT DIFFER HEREABOUTS!) * !*********************************************************************** QPUT(11,MAIN<<31!1,AT,ADDR(NAME)) %END %EXTERNALROUTINE PRHEX(%INTEGER VALUE, PLACES) %CONSTBYTEINTEGERARRAY HEX(0:15)='0','1','2','3','4', '5','6','7','8','9','A','B','C','D','E','F' %INTEGER I %CYCLE I=PLACES<<2-4, -4, 0 PRINT SYMBOL(HEX(VALUE>>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 PERQPROLOGUE !*********************************************************************** !* 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) %CONSTSTRING(8)MDEP="S#NDIAG" %INTEGER I, K, L, STCA 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,0,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 GR0 WORDS AND FILL WITH UNASSIGNED ! GR1 HAS BYTES OF PARAMETERS WHICH MUST NOT BE OVERWRITTEN ! ! ! AR 1,11 BYTE TO START CLEARING ! AR 11,0 CLAIM SPACE !AGN CR 1,11 ! BCR 10,LINKREG ! MVI 0(1),UNASSPAT ! MVC 1(255,1),0(1) ! LA 1,256(1) ! BC 15,AGN ! %IF PARM_CHK=1 %THEN %START; ! ONLY REQUIRED WITH CHKING WORKA_PLABS(4)=CA %FINISH ! ! SOME ERROR ROUTINES ! ERR EXIT(5, X'801', 0) %IF PARM_OPT#0; ! UNASSIGNED VARIABLE ERR EXIT(6, X'802', 0); ! SWITCH LABEL UNSET ERR EXIT(7, X'505', 1); ! ILLEGEAL EXPONENTIATION ERR EXIT(8,X'201', 0) %IF PARM_OPT#0; ! EXCESS BLOCKS ERR EXIT(9, X'601', 0); ! CAPACITY EXCEEDED ERR EXIT(10,21, 0) ; ! NO RESULT ERR EXIT(11,X'501', 0) %IF PARM_OPT#0; ! CYCLE NOT VALID ERR EXIT(12,X'701',0); ! RES FAILS ERR EXIT(13,X'602',0) %IF PARM_OPT#0; ! ARRAY BOUND FAULT WORKA_CONST PTR=1 WORKA_CONST BTM=WORKA_CONST PTR %IF PARM_PROF#0 %THEN %START; ! ALLOCATE PROFILE COUNT AREA %FINISH %RETURN %ROUTINE ERR EXIT(%INTEGER LAB, ERRNO, MODE) !*********************************************************************** !* MODE=0 FOR DUMMY(ZERO) XTRA - MODE=1 XTRA IN GR1 * !*********************************************************************** WORKA_PLABS(LAB)=CA %IF MODE=0 %THEN PB1(LDC0) PBW(LDCW,ERRNO) I=CA-WORKA_PLABS(2)+2 PB2(JMPB,-I) %END %END %EXTERNALROUTINE 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=BYTE INTEGER(WORKA_DICTBASE+V) %IF K#0 %THEN S=STRING(WORKA_DICTBASE+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:163)= %C " ? ","RT HD","RDSPY","RDARE","RDPTR", "RTBAD","RTXIT","XSTOP"," ? "," ? ", " \ "," -U "," FLT "," ABS ","SHRNK", "STRCH"," JAM "," ??? ","NO OP","PRELD", "GETAD","SSPTR","RSPTR","ASPTR","DARRY", "SLINE","STPCK","FRPRE","FPOST","FRPR2", " ? "(10), "UCNOP","UCB1 ","UCB2 ","UCB3 ","UCB4 ", "UCBW ","UCWW ","UCLW ","UCB2W"," ? ", " ? "(78), " + "," - "," !! "," ! "," * ", " // "," / "," & "," >> "," << ", " ** "," COMP","DCOMP"," VMY "," COMB", " = "," <- "," ****"," ADJ "," INDX", "IFTCH","LASS ","FORCK","PRECC","CNCAT", " ? "(7), "BJUMP","FJUMP","REMLB","TLAB "; %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(12)S %SWITCH SW(0:9) PRHEX(OPND_PTYPE,2) ->SW(OPND_FLAG) SW(0):SW(1): ! COCNSTANT PRINTSTRING(" ") PRHEX(OPND_D,8) SPACE %IF OPND_PTYPE>>4>5 %THEN PRHEX(OPND_XTRA,8) %ELSE SPACES(8) SPACES(2) %RETURN SW(2): ! NAME PRINTSTRING(" NAME ") NAM: S<-PRINTNAME(OPND_D)." " PRINTSTRING(S) 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): ! A TRIPLE 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 %STRINGFN MESSAGE(%INTEGER N) !*********************************************************************** !* OUTPUTS AN ERROR MESSAGE STORED IN A COMPRESSED FORMAT * !* 1 %REPEAT is not required * !* 2 Label & has already been set in this block * !* 4 & is not a Switch name at current textual level * !* 5 Switch name & in expression or assignment * !* 6 Switch label &(#) set a second time * !* 7 Name & has already been declared * !* 8 Routine or fn & has more parameters than specified * !* 9 Parameter # of & differs in type from specification * !* 10 Routine or fn & has fewer parameters than specified * !* 11 Label & referenced at line # has not been set * !* 12 %CYCLE at line # has two control clauses * !* 13 %REPEAT for %CYCLE at line # is missing * !* 14 %END is not required * !* 15 # %ENDs are missing * !* 16 Name & has not been declared * !* 17 Name & does not require parameters or subscripts * !* 18 # too few parameters provided for & * !* 19 # too many parameters provided for & * !* 20 # too few subscripts provided for array & * !* 21 # too many subscripts provided for array & * !* 22 Actual parameter # of & conflicts with specification * !* 23 Routine name & in an expression * !* 24 Integer operator has Real operands * !* 25 Real expression in integer context * !* 26 # is not a valid %EVENT number * !* 27 & is not a routine name * !* 28 Routine or fn & has specification but no body * !* 29 %FUNCTION name & not in expression * !* 30 %RETURN outwith routine body * !* 31 %RESULT outwith fn or map body * !* 34 Too many textual levels * !* 37 Array & has too many dimensions * !* 38 Array & has upper bound # less than lower bound * !* 39 Size of Array & is more than X'FFFFFF' bytes * !* 40 Declaration is not at head of block * !* 41 Constant cannot be evaluated at compile time * !* 42 # is an invalid repetition factor * !* 43 %CONSTANT name & not in expression * !* 44 Invalid constant initialising & after # items * !* 45 Array initialising items expected ## items given # * !* 46 Invalid %EXTERNAL %EXTRINSIC or variable %SPEC * !* 47 %ELSE already given at line # * !* 48 %ELSE invalid after %ON %EVENT * !* 49 Attempt to initialise %EXTRINSIC or %FORMAT & * !* 50 Subscript of # is outwith the bounds of & * !* 51 %FINISH is not required * !* 52 %REPEAT instead of %FINISH for %START at line # * !* 53 %FINISH for %START at line # is missing * !* 54 %EXIT outwith %CYCLE %REPEAT body * !* 55 %CONTINUE outwith %CYCLE %REPEAT body * !* 56 %EXTERNALROUTINE & at wrong textual level * !* 57 Executable statement found at textual level zero * !* 58 Program among external routines * !* 59 %FINISH instead of %REPEAT for %CYCLE at line # * !* 61 Name & has already been used in this %FORMAT * !* 62 & is not a %RECORD or %RECORD %FORMAT name * !* 63 %RECORD length is greater than # bytes * !* 64 Name & requires a subname in this context * !* 65 Subname & is not in the %RECORD %FORMAT * !* 66 Expression assigned to record & * !* 67 Records && and & have different formats * !* 69 Subname && is attached to & which is not of type %RECORD * !* 70 String declaration has invalid max length of # * !* 71 & is not a String variable * !* 72 Arithmetic operator in a String expression * !* 73 Arithmetic constant in a String expression * !* 74 Resolution is not the correct format * !* 75 String expression contains a sub expression * !* 76 String variable & in arithmetic expression * !* 77 String constant in arithmetic expression * !* 78 String operator '.' in arithmetic expression * !* 80 Pointer variable & compared with expression * !* 81 Pointer variable & equivalenced to expression * !* 82 & is not a pointer name * !* 83 && and & are not equivalent in type * !* 86 Global pointer && equivalenced to local & * !* 87 %FORMAT name & use in expression * !* 90 Untyped name & used in expression * !* 91 %FOR control variable & not integer * !* 92 %FOR clause has zero step * !* 93 %FOR clause has noninteger number of traverses * !* 95 Name & not valid in assembler * !* 96 Operand # not valid in assembler * !* 97 Assembler construction not valid * !* 98 Addressability * !* 99 Facility not implemented in PERQ Imp * !* 101 Source line has too many continuations * !* 102 Workfile of # Kbytes is too small * !* 103 Dictionary completely full * !* 104 Dictionary completely full * !* 105 Too many textual levels * !* 106 String constant too long * !* 107 Compiler tables are completely full * !* 108 Condition too complicated * !* 109 Compiler inconsistent * !* 110 Input ended * !* 201 Long integers are inefficient as subscripts * !* 202 Name & not used * !* 203 Label & not used * !* 204 Global %FOR control variable & * !* 205 Name & not addressable * !* 206 Semicolon in comment text * !* 207 %CONSTANT variable & not initialised * !* 255 SEE IMP MANUAL * !*********************************************************************** %CONSTBYTEINTEGERARRAY OUTTT(0:63)='?','A','B','C','D','E','F','G', 'H','I','J','K','L','M','N', 'O','P','Q','R','S','T','U', 'V','W','X','Y','Z','&','-', '/','''','(',')', 'a','b','c','d','e','f','g', 'h','i','j','k','l','m','n', 'o','p','q','r','s','t','u', 'v','w','x','y','z','.','%', '#','?'(2) %CONSTINTEGER WORDMAX= 762,DEFAULT= 758 %CONSTHALFINTEGERARRAY WORD(0:WORDMAX)=0,%C 1, 32769, 32771, 32772, 32773, 2, 32775, 32776, 32777, 32778, 32780, 32781, 32782, 32783, 32784, 4, 32776, 32771, 32772, 32785, 32786, 32788, 32789, 32790, 32792, 32794, 5, 32786, 32788, 32776, 32782, 32795, 32797, 32798, 6, 32786, 32800, 32801, 32781, 32785, 32802, 32804, 7, 32805, 32776, 32777, 32778, 32780, 32806, 8, 32808, 32797, 32810, 32776, 32777, 32811, 32812, 32814, 32815, 9, 32817, 32819, 32820, 32776, 32821, 32782, 32823, 32824, 32825, 10, 32808, 32797, 32810, 32776, 32777, 32828, 32812, 32814, 32815, 11, 32775, 32776, 32829, 32789, 32831, 32819, 32777, 32772, 32780, 32781, 12, 32832, 32789, 32831, 32819, 32777, 32834, 32835, 32837, 13, 32769, 32839, 32832, 32789, 32831, 32819, 32771, 32840, 14, 32842, 32771, 32772, 32773, 15, 32819, 32843, 32844, 32840, 16, 32805, 32776, 32777, 32772, 32780, 32806, 17, 32805, 32776, 32845, 32772, 32846, 32812, 32797, 32848, 18, 32819, 32850, 32851, 32812, 32852, 32839, 32776, 19, 32819, 32850, 32854, 32812, 32852, 32839, 32776, 20, 32819, 32850, 32851, 32848, 32852, 32839, 32855, 32776, 21, 32819, 32850, 32854, 32848, 32852, 32839, 32855, 32776, 22, 32856, 32858, 32819, 32820, 32776, 32860, 32862, 32825, 23, 32808, 32788, 32776, 32782, 32863, 32795, 24, 32864, 32866, 32777, 32868, 32869, 25, 32868, 32795, 32782, 32871, 32873, 26, 32819, 32771, 32772, 32785, 32875, 32876, 32878, 27, 32776, 32771, 32772, 32785, 32880, 32788, 28, 32808, 32797, 32810, 32776, 32777, 32825, 32882, 32883, 32884, 29, 32885, 32788, 32776, 32772, 32782, 32795, 30, 32887, 32889, 32880, 32884, 31, 32891, 32889, 32810, 32797, 32893, 32884, 34, 32894, 32854, 32792, 32895, 37, 32897, 32776, 32777, 32850, 32854, 32898, 38, 32897, 32776, 32777, 32900, 32901, 32819, 32902, 32814, 32903, 32901, 39, 32904, 32820, 32897, 32776, 32771, 32811, 32814, 32905, 32907, 40, 32908, 32771, 32772, 32789, 32911, 32820, 32784, 41, 32912, 32914, 32916, 32917, 32789, 32919, 32804, 42, 32819, 32771, 32863, 32921, 32923, 32925, 43, 32927, 32788, 32776, 32772, 32782, 32795, 44, 32929, 32931, 32933, 32776, 32936, 32819, 32937, 45, 32897, 32933, 32937, 32938, 32940, 32937, 32941, 32819, 46, 32929, 32942, 32944, 32797, 32946, 32948, 47, 32949, 32778, 32941, 32789, 32831, 32819, 48, 32949, 32921, 32936, 32950, 32876, 49, 32951, 32953, 32954, 32944, 32797, 32956, 32776, 50, 32958, 32820, 32819, 32771, 32889, 32960, 32961, 32820, 32776, 51, 32963, 32771, 32772, 32773, 52, 32769, 32965, 32820, 32963, 32839, 32967, 32789, 32831, 32819, 53, 32963, 32839, 32967, 32789, 32831, 32819, 32771, 32840, 54, 32969, 32889, 32832, 32769, 32884, 55, 32970, 32889, 32832, 32769, 32884, 56, 32972, 32776, 32789, 32976, 32792, 32794, 57, 32977, 32979, 32981, 32789, 32792, 32794, 32982, 58, 32983, 32985, 32986, 32988, 59, 32963, 32965, 32820, 32769, 32839, 32832, 32789, 32831, 32819, 61, 32805, 32776, 32777, 32778, 32780, 32990, 32782, 32783, 32956, 62, 32776, 32771, 32772, 32785, 32991, 32797, 32991, 32956, 32788, 63, 32991, 32993, 32771, 32995, 32814, 32819, 32907, 64, 32805, 32776, 32997, 32785, 32999, 32782, 32783, 32873, 65, 33001, 32776, 32771, 32772, 32782, 32960, 32991, 32956, 66, 33003, 33005, 32953, 33007, 32776, 67, 33009, 33011, 33012, 32776, 33013, 33014, 33016, 69, 33001, 33011, 32771, 33018, 32953, 32776, 33020, 32771, 32772, 32820, 32823, 32991, 70, 33021, 33023, 32777, 32921, 33026, 32993, 32820, 32819, 71, 32776, 32771, 32772, 32785, 33021, 32946, 72, 33027, 32866, 32782, 32785, 33021, 32795, 73, 33027, 32931, 32782, 32785, 33021, 32795, 74, 33029, 32771, 32772, 32960, 33031, 33033, 75, 33021, 32795, 33035, 32785, 33037, 32795, 76, 33021, 32946, 32776, 32782, 33038, 32795, 77, 33021, 32931, 32782, 33038, 32795, 78, 33021, 32866, 33040, 32782, 33038, 32795, 80, 33041, 32946, 32776, 33043, 32862, 32795, 81, 33041, 32946, 32776, 33045, 32953, 32795, 82, 32776, 32771, 32772, 32785, 33048, 32788, 83, 33011, 33012, 32776, 32844, 32772, 33050, 32782, 32823, 86, 33052, 33048, 33011, 33045, 32953, 33054, 32776, 87, 32956, 32788, 32776, 33055, 32782, 32795, 90, 33056, 32788, 32776, 32990, 32782, 32795, 91, 33058, 32835, 32946, 32776, 32772, 32871, 92, 33058, 33059, 32777, 32982, 33061, 93, 33058, 33059, 32777, 33062, 32878, 32820, 33064, 90, 33056, 32788, 32776, 32990, 33066, 32946, 95, 32805, 32776, 32772, 32875, 32782, 33067, 96, 33069, 32819, 32772, 32875, 32782, 33067, 97, 33071, 33073, 32772, 32875, 98, 33076, 99, 33079, 32772, 33081, 32782, 33084, 33085, 101, 33086, 32831, 32777, 32850, 32854, 33088, 102, 33091, 32820, 32819, 33093, 32771, 32850, 33095, 103, 33096, 33098, 33100, 104, 33096, 33098, 33100, 105, 32894, 32854, 32792, 32895, 106, 33021, 32931, 32850, 33101, 107, 33102, 33104, 32844, 33098, 33100, 108, 33106, 32850, 33108, 109, 33102, 33111, 110, 33114, 33115, 201, 33116, 33117, 32844, 33119, 33066, 32848, 202, 32805, 32776, 32772, 32990, 203, 32775, 32776, 32772, 32990, 204, 33052, 33058, 32835, 32946, 32776, 205, 32805, 32776, 32772, 33122, 206, 33125, 32782, 33127, 33129, 207, 32927, 32946, 32776, 32772, 33130, 255, 33133, 33134, 33135, 0 %CONSTINTEGERARRAY LETT(0: 368)=0,%C X'7890A80B',X'02A00000',X'53980000',X'5D7E8000', X'652E3AD3',X'652C8000',X'190C52D8',X'36000000', X'510E6000',X'436652C3',X'49C80000',X'452CB700', X'672E8000',X'53700000',X'69453980',X'4565F1D6', X'42000000',X'27BD3A47',X'50000000',X'5D0DB280', X'43A00000',X'47AE594B',X'5DA00000',X'692F1A6B', X'43600000',X'592ED2D8',X'4BC6194B',X'679D37DC', X'5F900000',X'439E74CF',X'5D6CB768',X'590C52D8', X'36FFB000',X'672C77DD',X'48000000',X'694DB280', X'1D0DB280',X'492C7643',X'652C8000',X'257EBA53', X'5D280000',X'4D700000',X'5B7E5280',X'610E50DB', X'4BA4B966',X'69443700',X'6784B1D3',X'4D4CB200', X'210E50DB',X'4BA4B900',X'7A000000',X'5F300000', X'494CD34B',X'65980000',X'69CE1280',X'4D95F680', X'6784B1D3',X'4D4C70E9',X'537DC000',X'4D2EF2E4', X'652CD2E5',X'4B7472C8',X'594DD280',X'781B2199', X'0A000000',X'69BDE000',X'477DDA65',X'5F600000', X'47643AE7',X'4B980000',X'4D7E4000',X'5B4E79D3', X'5D380000',X'7829C200',X'7829C266',X'4394A000', X'497CB980',X'652E3AD3',X'65280000',X'67AC59C7', X'654E1A66',X'697DE000',X'4D2EE000',X'6195FB53', X'492C8000',X'5B0DDC80',X'439650F2',X'031E9AC3', X'58000000',X'610E50DB',X'4BA4B900',X'477DD359', X'531E9980',X'6F4E9400',X'43700000',X'137692CF', X'4B900000',X'5F84B943',X'697E4000',X'252C3600', X'5F84B943',X'5D266000',X'537692CF',X'4B900000', X'477DDA4B',X'71A00000',X'6D0D94C8',X'782AC29D', X'28000000',X'5DADB14B',X'64000000',X'657EBA53', X'5D280000',X'45AE8000',X'5D780000',X'457C9C80', X'7832A707',X'2849E700',X'7890AA2B',X'24700000', X'5FAE9BD3',X'69400000',X'7890A9AB',X'18A00000', X'5B0E0000',X'297DE000',X'592ED2D9',X'66000000', X'039650F2',X'494DB2DD',X'674DF766',X'6B8612E4', X'457EB748',X'592E7980',X'597EF2E4',X'274F5280', X'30F0C30D',X'0C30CF00',X'45CE92E6',X'092C7643', X'650E94DF',X'5C000000',X'512C3200',X'077DD9E9', X'43768000',X'470DD75F',X'68000000',X'45280000', X'4BB4366B',X'43A4B200',X'477DB853',X'59280000', X'5376D0D9',X'53200000',X'652E12E9',X'53A537DC', X'4D0C7A5F',X'64000000',X'7819E727',X'2809CA00', X'1376D0D9',X'53200000',X'477DD9E9',X'43768000', X'53753A53',X'436539D3',X'5D380000',X'433692E4', X'53A4B6E6',X'4BC612C7',X'692C8000',X'7BE80000', X'4F4ED2DC',X'782B0A0B',X'24702600',X'782B0A25', X'12726486',X'6D0E54C3',X'4564A000',X'789A0286', X'7829898A',X'7879C000',X'03A692DB',X'61A00000', X'69780000',X'53753A53',X'436539CA',X'7831E91B', X'02A00000',X'27AC59C7',X'654E1A00',X'6944A000', X'457EB749',X'66000000',X'78312713',X'26400000', X'53767A4B',X'43200000',X'789A80A5',X'28000000', X'782B04A8',X'7819E729',X'1272A280',X'782B0A0B', X'24702625',X'1EAA849D',X'0A000000',X'6F95F74E', X'0BC4B1EB',X'690C564A',X'67A43A4B',X'5B2DDA00', X'4D7EB748',X'752E5780',X'2195F3E5',X'43680000', X'436DF74E',X'4BC692E5',X'5D0D8000',X'657EBA53', X'5D2E6000',X'6B9CB200',X'7890A19F',X'24200000', X'592DD3E9',X'50000000',X'4F94B0E9',X'4B900000', X'652E3AD3',X'652E6000',X'67AC5743',X'5B280000', X'27AC5743',X'5B280000',X'0BC6194B',X'679D37DC', X'439E74CF',X'5D2C8000',X'652C77E5',X'48000000', X'252C77E5',X'49980000',X'36D80000',X'43748000', X'510ED280',X'494CD34B',X'652DDA00',X'4D7E56C3', X'69980000',X'43A690C7',X'512C8000',X'6F4531D0', X'27A654DD',X'4E000000',X'492C7643',X'650E94DF', X'5C000000',X'5B0F0000',X'03953A51',X'5B2E94C6', X'252E77D9',X'6BA537DC',X'477E594B',X'47A00000', X'4D7E56C3',X'68000000',X'477DDA43',X'53766000', X'67AC4000',X'43953A51',X'5B2E94C6',X'3DDBC000', X'217D3769',X'4B900000',X'477DB843',X'652C8000', X'4B8EB4ED',X'4364B747',X'4B200000',X'617D3769', X'4B900000',X'4B8EB4ED',X'4364B768',X'0F65F143', X'58000000',X'597C70D8',X'6B9CA000',X'2B769CE1', X'4B200000',X'7831E900',X'47643AE7',X'4A000000', X'67A4B800',X'5D7DD4DD',X'692CF2E4',X'69943B4B', X'659CB980',X'43980000',X'439E72DB',X'4564B900', X'1F84B943',X'5D200000',X'039E72DB',X'4564B900', X'477DD9E9',X'65AC7A53',X'5F700000',X'0324994B', X'679C3153',X'594E9C80',X'0D0C74D9',X'53A72000', X'536E164B',X'5B2DDA4B',X'48000000',X'202A4880', X'136E0000',X'277EB947',X'4A000000',X'477DDA53', X'5DAC3A53',X'5F766000',X'2F7E55CD',X'5364A000', X'17173A4B',X'66000000',X'676C3658',X'094C7A53', X'5F743972',X'477DB859',X'4BA4B672',X'4DAD9600', X'597DD380',X'077DB853',X'592E4000',X'690C564B', X'66000000',X'077DD253',X'694DF700',X'477DB859', X'531C3A4B',X'48000000',X'537477DD',X'674E7A4B', X'5DA00000',X'13761AE8',X'4B7492C8',X'197DD380', X'537692CF',X'4B966000',X'5374B34D',X'531D32DD', X'68000000',X'4324994B',X'679C3159',X'4A000000', X'272DB4C7',X'5F65F700',X'477DB6CB',X'5DA00000', X'692F1A00',X'53753A53',X'436539CB',X'48000000', X'2628A000',X'126A0000',X'1A09CA83',X'18000000' %INTEGER I,J,K,M,Q,S %STRING(70)OMESS OMESS=" " %CYCLE I=1,1,WORDMAX-1 ->FOUND %IF N=WORD(I) %REPEAT I=DEFAULT FOUND: J=1 %CYCLE K=WORD(I+J) %IF K&X'8000'=0 %THEN %EXIT K=K!!X'8000' OMESS=OMESS." " %UNLESS J=1 %UNTIL M&1=0 %CYCLE M=LETT(K); S=25 %UNTIL S<0 %CYCLE Q=M>>S&63; %IF Q\=0 %THEN OMESS=OMESS.TOSTRING(OUTTT(Q)) S=S-6 %REPEAT K=K+1 %REPEAT J=J+1 %REPEAT %RESULT=OMESS %END %STRING(16)%FN SWRITE(%INTEGER VALUE, PLACES) %STRING (16) S %STRING(1)SIGN %INTEGER D0, D1, D2 PLACES=PLACES&15 SIGN=" " S="" %IF VALUE<0 %THEN SIGN="-" %AND VALUE=-VALUE D0=VALUE %CYCLE D1=D0//10 D2=D0-10*D1 S=TOSTRING(D2+'0').S D0=D1 %REPEAT %UNTIL D0=0 S=SIGN.S S=" ".S %WHILE BYTEINTEGER(ADDR(S))<=PLACES %RESULT=S %END %EXTERNALROUTINE FAULT(%INTEGER N, DATA, IDENT) !*********************************************************************** !* SETS UP AN ERROR MESSAGE AND SHOVES IT OUT ONTO THE LISTING * !* AN ALSO OPTIONALLY TO THE TERMINAL * !*********************************************************************** %INTEGER I, J, S, T, Q, QMAX, LENGTH %STRING(255)MESS1,MESS2,WK1,WK2 !*DELSTART %MONITOR %IF PARM_FAULTY=0 %AND (PARM_SMAP#0 %OR PARM_DCOMP#0) !*DELEND MESS1=""; MESS2="" PARM_FAULTY=PARM_FAULTY+1 %IF N=100 %THEN %START; ! SYNTAX FAULTS ARE SPECIAL MESS1=" * Failed to analyse line ".SWRITE(WORKA_LINE,2)." " J=0; S=0; T=0; Q=0; QMAX=IDENT>>16 LENGTH=IDENT&X'FFFF' %UNTIL (J=';' %AND Q>QMAX) %OR Q=LENGTH %CYCLE I=J; J=BYTEINTEGER(DATA+Q);! DATA HAS ADDR(CC(0)) %IF J>128 %AND I<128 %THEN MESS2=MESS2." %" %AND T=T+2 %IF I>128 %AND J<128 %THEN MESS2=MESS2." " %AND T=T+1 MESS2=MESS2.TOSTRING(J) T=T+1 %IF Q=QMAX %THEN S=T Q=Q+1 %EXIT %IF T>=250 %REPEAT %IF Q=QMAX %THEN S=T %FINISH %ELSE %START MESS1=" *".SWRITE(WORKA_LINE, 4)." " PARM_OPT=1 PARM_INHCODE=1 %IF PARM_LET=0; ! STOP GENERATING CODE MESS1=MESS1."FAULT".SWRITE(N,2) MESS2=MESSAGE(N) %IF MESS2->WK1.("##").WK2 %THEN %C MESS2=WK1.SWRITE(IDENT,1).WK2 %IF MESS2->WK1.("#").WK2 %THEN %C MESS2=WK1.SWRITE(DATA,1).WK2 %IF MESS2->WK1.("&&").WK2 %THEN %C MESS2=WK1.PRINTNAME(DATA).WK2 %IF MESS2->WK1.("&").WK2 %THEN %C MESS2=WK1.PRINTNAME(IDENT).WK2 %IF N>100 %THEN MESS2=MESS2." Disaster" %FINISH %CYCLE I=2,-1,1 SELECT OUTPUT(PARM_TTOPUT) %IF I=1 PRINTSTRING(MESS1) PRINTSTRING(MESS2) %IF MESS2#"" %IF N=100 %AND S<115 %THEN %START NEWLINE; SPACES(S+4); PRINTSYMBOL('!') %FINISH NEWLINE SELECT OUTPUT(82) %IF I=1 %EXIT %IF PARM_TTOPUT<=0 %REPEAT %IF N>=200 %THEN %MONITOR %IF N=109 %THEN PARM_DCOMP=1 %AND CODEOUT %IF N>100 %THEN %STOP %END %EXTERNALROUTINE WARN(%INTEGER N,V) %STRING(30) T; %STRING(120) S S=MESSAGE(N+200) %IF S->S.("&").T %THEN S=S.PRINTNAME(V).T PRINTSTRING(" ? Warning :- ".S." at line No".SWRITE(WORKA_LINE,1)) NEWLINE %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 REPLACE1(%INTEGER CELL, S1) ASLIST(CELL)_S1=S1 %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 %EXTERNALROUTINE REPLACE123(%INTEGER CELL,S1,S2,S3) ASLIST(CELL)_S1=S1 ASLIST(CELL)_S2=S2 ASLIST(CELL)_S3=S3 %END %EXTERNALROUTINE MLINK(%INTEGERNAME CELL) CELL=ASLIST(CELL)_LINK %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 FROM123(%INTEGER CELL, %INTEGERNAME S1, S2, S3) !*********************************************************************** !* ALL THE FROMS RETURN INFO FROM CELLS OF A LIST WITHOUT * !* AFFECTING THE LIST IN ANY WAY. * !*********************************************************************** %RECORD(LISTF)%NAME LCELL LCELL==ASLIST(CELL) S1=LCELL_S1 S2=LCELL_S2 S3=LCELL_S3 %END %EXTERNALROUTINE FROM12(%INTEGER CELL, %INTEGERNAME S1, S2) %RECORD(LISTF)%NAME LCELL LCELL==ASLIST(CELL) S1=LCELL_S1 S2=LCELL_S2 %END %EXTERNALINTEGERFN FROM1(%INTEGER CELL) %RESULT =ASLIST(CELL)_S1 %END %EXTERNALINTEGERFN FROM2(%INTEGER CELL) %RESULT =ASLIST(CELL)_S2 %END %EXTERNALINTEGERFN FROM3(%INTEGER CELL) %RESULT =ASLIST(CELL)_S3 %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! %EXTERNALROUTINE 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 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 %EXTERNALROUTINE 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) 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 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 LOAD(%RECORD(RD) %NAME OP) %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 ! ! 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 ! BOTTOM 16 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'1000000F'{RTHD ROUTINE/BKK HDR}, 0 {RDSPLY MAKE DISPLAY}, X'10000010'{RDAREA INITIALISE DIAGS AREA}, X'10000011'{RDPTR RESET DIAGS PTR}, X'10000012'{RTBAD ERROR XIT FOR FN-MAP}, X'10000013'{RTXIT "%RETURN"}, X'10000014'{XSTOP "%STOP"}, 0(2), X'2000000A'{10 LOGICAL NOT}, X'2000000B'{11 LOGICAL NEGATE}, X'2000000C'{12 FLOAT}, 0{13 NOT USED}, X'2000000E'{14 SHORTEN}, X'2000000F'{15 LENGTHEN}, X'20000010'{16 JAM SHORTEN}, X'10000000'{17 ERROR}, 0{18 NULL TRIPLE}, X'20000013'{19 PRELOAD}, X'10000001'{20 GETAD}, X'10000003'{21 STORE STACKPOINTER}, X'10000002'{22 RESTORE STACK POINTER}, X'10000005'{23 ADVANCE STACK POINTER}, X'10000004'{24 DECLARE ARRAY}, X'10000001'{25 UPDATE LINE NO}, X'10000006'{26 CHECK ZERO FOR STEP}, X'10000007'{27 FOR PREAMBLE}, X'10000008'{28 FOR POSTAMBLE}, X'1000000E'{29 FOR SECOND PREAMBLE}, 0(10), X'10000038'{40 UCNOP}, X'10000039'{41 UCB1}, X'1000003A'{42 UCB2}, X'1000003B'{43 UCB3}, X'1000003C'{44 UCW}, X'1000003D'{45 UCBW}, 0(82), X'20010014'{128 +}, X'20000015'{129 -}, X'20010016'{130 !!}, X'20010017'{131 !}, X'20010018'{132 *}, X'20000019'{133 //}, X'2000001A'{134 /}, X'2001001B'{135 &}, X'2000001C'{136 >>}, X'2000001D'{137 <<}, X'10000001'{138 **}, X'2001001F'{139 COMP}, X'20010020'{140 DCOMP}, X'20020021'{141 VMY}, X'20010022'{142 COMB}, X'200E0023'{143 ASSIGN=}, X'200E0024'{144 ASSIGN<-}, X'20020025'{145 ****}, X'20020026'{146 ARR SCALE}, X'20000027'{ 147 ARR INDEX}, X'20050028'{148 INDEXED FETCH}, X'200E0029'{149 LOCAL ASSIGN}, X'10000009'{150 VALIDATE FOR}, X'10000015'{151 PRE CONCAT}, X'10000016'{152 COCNCATENEATION}, 0(7), X'1000000A'{160 BACK JUMP}, X'1000000B'{161 FORWARD JUMP}, X'1000000C'{162 REMOVE LAB}, X'1000000D'{163 ENTER LABEL}, 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}, 1,0,0,109 {13 COMPILER ERROR}, 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}, 1,0,0,109 {13 COMPILER ERROR}, 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}, 1,0,0,109 {13 COMPILER ERROR (ABS)}, 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}, 1,0,0,109 {13 COMPILER ERROR (ABS)}, 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:50) ! PRINT TRIPS(TRIPLES) ! TRIP OPT(TRIPLES,NEXTTRIP) 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'10000'#0 %OR 35<=JJ<=36 %THEN %C EXCHANGE(OPND2,OPND1) %ELSE COMM=2 %FINISH %FINISH %UNLESS JJ<128 %OR OPND2_FLAG=9 %OR TRIPINF&X'20000'#0 %THEN %C LOAD(OPND2) PTYPE=OPND1_PTYPE; 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); ! 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) PB1(ATPW) %FINISHELSESTART C=WORKA_CTABLE(OPND1_D>>16&X'7FFF'+2); ! ARRAYSIZE IN WORDS %IF C<=127 %THEN PB2(ATPB,C) %ELSE PBW(LDCW,C) %AND PB1(ATPW) %FINISH %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 %IF(CA+2)&CODEBNDRY<2 %THEN CNOP(0,4) C=CA+2-C %IF C<127 %THEN PB2(JCODE(CURRT_X1)-1,-C) %ELSE %C PBW(JCODE(CURRT_X1),-(C+1)) %CONTINUE TRIPSW(11): ! FORWARD JUMP _X1 HAS TF&MASK ! OPND1_XTRA HAS JUMP CELL LCELL==ASLIST(OPND1_XTRA) PBW(JCODE(CURRT_X1),0) LCELL_S1=CA-3; ! AFTER ROUNDING FOR ACCENT %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) D=CA-(B1+3) %IF D>X'7FFFF' %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); %CONTINUE TRIPSW(20): ! XSTOP - "%STOP" CALL STOP; %CONTINUE 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!) LOAD(OPND2); ! 32 BIT AD OF STRING2 PB1(LDC0) PBW(LDCW,255); ! MAX LENGTH PB1(TLATE3); ! TLATE OPND2 ADDRESS PB1(SAS) %CONTINUE TRIPSW(22): ! CONCATENATE OPND1 WORK AREA ! OPND2 THE NEXT BIT DFETCHAD(NO,OPND1_D>>16,OPND1_D&X'FFFF') PPJ(JLK,23) LOAD(OPND2) PPJ(JLK,24) %CONTINUE TRIPSW(40): ! UC NOOP CNOP(OPND1_D>>8,OPND1_D&255) %CONTINUE TRIPSW(41): ! UCB1 ONE BYTE ASSEMBLER PB1(OPND1_D); %CONTINUE TRIPSW(42): ! UCB2 TWO BYTE ASSEMBLER PB2(OPND1_D>>8,OPND1_D&255) %CONTINUE TRIPSW(43): ! UCB3 3 BYTE ASSEMBLER PB3(OPND1_D>>16,OPND1_D>>8&255,OPND1_D&255) %CONTINUE TRIPSW(44): ! UCW ASSEMBLER WITH WORD OPERAND PBW(OPND1_D>>16,OPND1_D&X'FFFF') %CONTINUE TRIPSW(45): ! UCBW BYTE&WORD OPERAND ASSEMBLER PB2W(OPND1_D>>24,OPND1_D>>16&255,OPND1_D&X'FFFF') %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 %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 ON PERQ=NO %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)) %IF TYPE=5 %THEN ->FAD; ! STRING LOAD = FETCH ADDRESS DFETCH(BYTES(OPND_PTYPE>>4),TCELL_UIOJ>>4&15,TCELL_SLINK) LDED: %IF TYPE=1 %AND PREC<4 %THEN OPND_PTYPE=X'41' OPND_FLAG=9; OPND_D=0 %RETURN SW(4): ! CONDITIONAL EXPRESSION ABORT SW(5): ! INTEGER AS ADDR(NAME.APP) TCELL==ASLIST(WORKA_TAGS(OPND_D)) OPND_PTYPE=X'51'; ! ADDRESSES ARE INTEGERS FAD: DFETCHAD(YES,TCELL_UIOJ>>4&15,TCELL_SLINK) ->LDED SW(6): ! OPTIMISED INTERMEDIATE ABORT SW(7): ! I-R IN A STACK FRAME DFETCH(BYTES(PREC),OPND_D>>16,OPND_D&X'FFFF') ->LDED SW(8): ! TRIPLE REFTRIP==TRIPLES(OPND_D) %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 VMY !*********************************************************************** !* DOES ALL VECTOR MULTIPLIES * !*********************************************************************** %INTEGER DVPOS,PR,CM DVPOS=OPND2_D&X'FFFF' PR=OPND1_PTYPE>>4 %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=X'48' %OR TFMASK=X'C7' %THENRESULT=JEQW %RESULT=JNEW %FINISH %IF TFMASK&128#0 %THENRESULT=JFW %RESULT=JTW %END %END; ! OF ROUTINE GENERATE %ENDOFFILE