%INCLUDE "ERCC07.PERQ_OPCODES" %EXTRINSICBYTEINTEGERARRAY CODE(0:268) %EXTRINSICBYTEINTEGERARRAY GLABUF(0:268) %EXTRINSICINTEGER CA,CABUF,GLACA,GLACABUF %EXTRINSICINTEGER PPCURR %INCLUDE "ERCC07.PERQ_FORMATS" %EXTRINSICRECORD(WORKAF)WORKA %EXTRINSICRECORD(PARMF) PARM %DYNAMICROUTINESPEC QCODE(%INTEGER A,B,C,MODE) %DYNAMICROUTINESPEC QPUT(%INTEGER A,B,C,D) %ROUTINESPEC FAULT(%INTEGER I,J,K) ! !*********************************************************************** !* 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 PLANT(%INTEGER HALFWORD) !*********************************************************************** !* ADD A HALF WORD OF BINARY TO THE BUFFER * !*********************************************************************** CODE(PPCURR)<-HALFWORD>>8 CODE(PPCURR+1)<-HALFWORD PPCURR=PPCURR+2 CA=CA+2 CODEOUT %IF PPCURR>=256 %END %EXTERNALROUTINE PWORD(%INTEGER WORD) !*********************************************************************** !* ADD A WORD(16 BITS) TO CODE FLIPPING HALFS AS NEEDED * !*********************************************************************** 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 * !*********************************************************************** 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 * !*********************************************************************** 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 %AND (OPCODE=LDOW %OR OPCODE=LDLW %OR %C OPCODE=STOW %OR OPCODE=STLW %OR OPCODE=INDW %C %OR OPCODE=LLAW %OR OPCODE=LOAW %C %OR OPCODE=INCW) %THEN PB2(OPCODE-1,WORD) %AND %RETURN %IF -128<=WORD<=127 %AND OPCODE=LDCW %THEN %C PB2(LDCB,WORD) %AND %RETURN CODE(PPCURR)=OPCODE CODE(PPCURR+1)<-WORD CODE(PPCURR+2)<-WORD>>8 PPCURR=PPCURR+3 CA=CA+3 CODEOUT %IF PPCURR>=256 %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 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) %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) %OWNINTEGER GLACURR=0 %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 %EXTERNALROUTINE 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 %EXTERNALROUTINE CSTOP !*********************************************************************** !* CALLS STOP ROUTINE. NOT VIA EPILOGUE ON PERQ * !************************************************************************ %INTEGER J J=CA PB3(CALLXB,0,0) GXREF("S#STOP",0,0,J) PB1(RETURN); ! IN CASE %END %EXTERNALROUTINE ERASE(%INTEGER WORDS) !*********************************************************************** !* REMOVES 1 OR 2 WORDS FROM THE ESTACK * !*********************************************************************** %IF WORDS=1 %THEN PB3(MMS,ATPB,-1) %ELSE PB3(MMS2,ATPB,-2) %END %EXTERNALROUTINE ILSHIFT(%INTEGER CONST) !*********************************************************************** !* ARRANGES TO SHIFT A 32 BIT INTEGER BY A CONSTANT USING A PILE * !* OF 16BIT SHIFTS * !*********************************************************************** CONST=CONST&31 %IF CONST>=16 %START PB1(EXCH) ERASE(1); ! BTM 16 BITS ALL ZERO %IF CONST>16 %START PB3(LDC0+CONST&15,ROTSHI,0) %FINISH PB1(LDC0) %FINISH %ELSE %START PB1(REPL); ! 2 COPIES OF BTM 16 PB3(LDC0+CONST,ROTSHI,0) PB3(MMS,LDC0+16-CONST,NGI) PB3(ROTSHI,0,EXCH) PB3(LDC0+CONST,ROTSHI,0) PB2(LOR,MES) %FINISH %END %EXTERNALROUTINE IRSHIFT(%INTEGER CONST) !*********************************************************************** !* ARRANGES TO SHIFT A 32 BIT INTEGER BY A CONSTANT USING A PILE * !* OF 16BIT SHIFTS * !*********************************************************************** CONST=CONST&31 %IF CONST>=16 %START ERASE(1); ! TOP 16 BITS ALL ZERO %IF CONST>16 %START PB2(LDC0+CONST&15,NGI) PB2(ROTSHI,0) %FINISH PB2(LDC0,EXCH) %FINISH %ELSE %START PB2(LDC0+CONST,NGI) PB3(ROTSHI,0,MMS) PB1(REPL); ! 2 COPIES OF TOP 16 PB2(LDC0+CONST,NGI) PB3(ROTSHI,0,EXCH) PB3(LDC0+16-CONST,ROTSHI,0) PB2(MES,LOR) %FINISH %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 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 %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 I=X'C2C2C2C2' QPUT(44,4,0,ADDR(I)) %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); ! WILL BE RT DICT OFFSET PWORD(0) 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 PB4(LDC0+1,STLB,14,LDL0+3) PB4(LLAB,4,LDDW,TLATE1) PB4(LDIND,REPL,STLB,11) PB3(SBI,LLAB,9) PB4(LDDW,LDC0,TLATE2,LDCH) PB3(REPL,STLB,12) PB4(LDC0,EQUI,JTB,38) PB4(LDL0+12,SBI,LDC0+1,ADI) PB4(REPL,STLB,13,LDC0) PB3(LEQI,JTB,27) ! THIS IS "LOOP" PB4(LLAB,9,LDDW,LDC0+1) PB3(LLAB,1,LDDW) PB3(LDL0+11,LDL0+14,ADI) PB3(LDL0+12,STLATE,X'63') PB4(EQUBYT,0,JTB,13) PB3(LDL0+14,LDC0+1,ADI) PB3(REPL,STLB,14) PB4(LDL0+13,GTRI,JFB,-27) ! THIS IS "RESFAIL" PB3(LDC0,STL0,RETURN) ! THIS IS "RESOK" PB3(LDL0+6,LDC0,NEQI) PB2(JFB,21) PB4(LLAB,7,LDDW,LDC0) PB4(LLAB,1,LDDW,LDL0+11) ! PB2(LDL0+12,ADI) ! PB4(LDL0+14,ADI,LDC0+1,SBI) PB4(LDL0+14,STLATE,X'63',MVBW) PB4(LLAB,7,LDDW,LDC0) PB3(LDL0+14,LDC0+1,SBI) PB2(TLATE3,STCH) ! THIS IS "NOSTORE" PB3(LLAB,4,LDDW) PB3(LDL0+11,LDL0+12,ADI) PB4(LDL0+14,ADI,LDC0+1,SBI) PB2(TLATE2,STIND) PB3(LDC0+1,STL0,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 PB4(LLAB,3,LDDW,LDC0) PB4(TLATE2,LDB,REPL,STL0+6) PB4(LDL0,LEQI,JTB,2) PB2(LDL0,STL0+6) ! LABEL "OK" IS HERE PB3(LDL0+2,LDL0+1,LDC0+1) PB3(LDL0+4,LDL0+3,LDC0+1) PB4(LDL0+6,STLATE,X'63',MVBW) PB4(LDL0+2,LDL0+1,LDC0,LDL0+6) PB3(TLATE3,STB,RETURN) R_EXIT=CA-1 R_LL=2 QPUT(11,WORKA_PLINK(18),ADDR(R),ADDR(JAMMER)) P19: ! CONCATENATION ONE ! COPY THE FIRST STRING INTO THE WORK AREA ! GR0 HAS ADDRESS OF WK AREA. GR1 HAS STRING ! ! STM 2,4,8(WSPR) SAVE REGS (MAY BE OPTIMISED) ! LR 3,0 TO WORK AREA ! IC 2,0(1) LENGTH OF STRING ! BALR 4,0 GIVE ADDRESSABILITY ! EX 2,MV EXECUTE PREV INSTRN ! LM 2,4,8(WSPR) ! BCR 15,LINKREG !MV MVC 3(1,3),0(1) MOVEL BYTE & FOR EXECUTE %IF WORKA_PLINK(19)!WORKA_PLINK(20)=0 %THEN ->P21 FILL(19) P20: ! ! INTEGER LEFT SHIFT X< ! LDC0,STL0,LDL3,LDL2 ! LDC15,LAND ! ROTSHI 0,STL1,RETURN !BITS16 SHIFT LESS 16 BITS ! LDL3,LDL2,ROTSHI0,STL0 ! LDL4,LDL2,ROTSHI0,STL1 ! LDL2,LDC0,EQUI,JTB ! LDL3,LDL2,LDCB 16 ! SBI,ROTSHI0 ! LDL1,LOR,STL1 !END ! RETURN %IF WORKA_PLINK(20)=0 %THEN ->P21 R=0; R_PS=3; R_RPS=5 R_LTS=0; R_ENTRY=CA PB4(LDL0+2,LDCB,31,LAND) PB4(REPL,STL0+2,LDC0+15,LEQI) PB2(JTB,10) PB4(LDC0,STL0,LDL0+3,LDL0+2) PB2(LDC0+15,LAND) PB4(ROTSHI,0,STL0+1,RETURN) ! LABEL BITS16 IS HERE PB2(LDL0+3,LDL0+2); PB3(ROTSHI,0,STL0) PB2(LDL0+4,LDL0+2); PB3(ROTSHI,0,STL0+1) PB3(LDL0+2,LDC0,EQUI); PB2(JTB,10) PB4(LDL0+3,LDL0+2,LDCB,16) PB3(SBI,ROTSHI,0) PB3(LDL0+1,LOR,STL0+1) ! LABEL END IS HERE PB1(RETURN) R_EXIT=CA-1 R_LL=2 QPUT(11,WORKA_PLINK(20),ADDR(R),ADDR(LEFTSHIFT)) P21: ! ! INTEGER RIGHT SHIFT X>>I ENETERED BY CALL ! L0&L1 RESULT ! L2 I (16 BITS) ! L3&4 X (32 BIT) ! ! LDL2, LDCB 31,LAND ! REPL,STLB2,LDC15,LEQI ! JTB ! LDC0,STL1,LDL4,LDL2 ! LDC15,LAND,NGI ! ROTSHI 0,STL0,RETURN !BITS16 SHIFT LESS 16 BITS ! LDL3,LDL2,NGI,ROTSHI0,STL0 ! LDL4,LDL2,NGI,ROTSHI0,STL1 ! LDL2,LDC0,EQUI,JTB ! LDL4,LDCB 16,LDL2, ! SBI,ROTSHI0 ! LDL0,LOR,STL0 !END ! RETURN %IF WORKA_PLINK(21)=0 %THEN ->P22 R=0; R_PS=3; R_RPS=5 R_LTS=0; R_ENTRY=CA PB4(LDL0+2,LDCB,31,LAND) PB4(REPL,STL0+2,LDC0+15,LEQI) PB2(JTB,11) PB4(LDC0,STL0+1,LDL0+4,LDL0+2) PB3(LDC0+15,LAND,NGI) PB4(ROTSHI,0,STL0,RETURN) ! LABEL BITS16 IS HERE PB3(LDL0+3,LDL0+2,NGI); PB3(ROTSHI,0,STL0) PB3(LDL0+4,LDL0+2,NGI); PB3(ROTSHI,0,STL0+1) PB3(LDL0+2,LDC0,EQUI); PB2(JTB,10) PB4(LDL0+4,LDCB,16,LDL0+2) PB3(SBI,ROTSHI,0) PB3(LDL0,LOR,STL0) ! LABEL END IS HERE PB1(RETURN) R_EXIT=CA-1 R_LL=2 QPUT(11,WORKA_PLINK(21),ADDR(R),ADDR(RIGHTSHIFT)) P22: ! ! PRINTPROFILE ! %IF WORKA_PLINK(22)=0 %THEN ->P23 FILL(22) CXREF("S#PPROFILE",0,2,J) P23: ! ! FIX FR0 LEAVING RESULT ON STACK TOP. SAVE ALL WORK REGS ! ! CNOP 0,8 ALIGN ! STD 2,8(WSPR) SAVE A WORK FREG ! ST 15,16(WSPR) SAVE RETURN ADDRESS ! BALR 15,0 AND SET A BASE REGISTER ! LDR 2,0 COPY DATAUM ! MD 2,=X'7810000000000000' FORCE OVERFLOW IF TOO LARGE ! LDR 2,0 ! AW 2,=X'4E00000000000000' UNNORMALISED ZERO ! LTDR 0,0 ! BC 10,L1 POSITIVE OR ZERO ! AD 2,=D'0' RENORMALISE ! SDR 0,2 CHECK FOR EXACT INTEGER ! BC 4,L2 WAS NOT EXACT TRUNC OCCURRED ! AW 2,=X'4E00000100000000' ! BC 15,L1 !L2 AW 2,=X'4E000000FFFFFFFF' ROUND DOWN NOT TOWARDS 0 !L1 STD 2,0(WSPR) STACK RESULT ! L 15,16(WSPR) ! LD 2,8(WSPR) ! BCR 15,LINKREG ! =X'7810000000000000' 54(15) ! =X'4E00000000000000' 62(15) ! =X'0000000000000000' 70(15) ! =X'4E00000100000000' 78(15) ! =X'4E000000FFFFFFFF' 86(15) ! %IF WORKA_PLINK(23)=0 %THEN ->P24 CNOP(0,8) FILL(23) P24: %RETURN %ROUTINE FILL(%INTEGER LAB) !*********************************************************************** !* FILL JUMPS TO THIS LAB WITH JUMP TO CURRENT ADDRESS * !*********************************************************************** %INTEGER AT,DIFF,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 DIFF=CA-(AT+3); ! FORWRD DIFFERENCE FAULT(98,0,0) %IF IMOD(DIFF)>X'7FFF' PLUG(1,AT+1,DIFF,1) PLUG(1,AT+2,DIFF>>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(10:40)= %C " \ "," -U "," FLT "," ABS ","SHRNK", "STRCH"," JAM "," ??? ","NO OP","PRELD", " + "," - "," !! "," ! "," * ", " // "," / "," & "," >> "," << ", " ** "," COMP","DCOMP"," VMY "," COMB", " = "," <- "," ****"," ADJ "," INDX", "IFTCH"; %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>=20 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_XTRA)." " 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>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 %ENDOFFILE