! ! Warning this module has the revised triples spec. ! ! In first attempt at Triple Imp considerable use was made of constant operands ! to pass information from Pass2 to GEN. Although for specialised operations like ! passing Labels this still applies, this adhocery has caused problems with arrays ! and pointers particularly in mapped records. The operands for four triples ! have thus been redefined in a more standard way. ! ! GETPTR X1 is now (ptype of passed)<<16! DIMENSION ! Opnd2 is either a 32 bit const with the size (ACC) as value or ! the ptr or arrayhead as normal operand. ! ! VMY X1 is now dim<<28!maxdim<<24!array name(where known) ! Opnd2 is either a 32 bit const with DV offset into const area or ! the arrayhead as a standard operand ! ! AINDX X1 is ELSIZE<<20 !spare ! Opnd2 is arrayhead as standard operand ! NOTE:- The Operands have been swopped for consistency with norm. ! ! BADJ X1 is arrayptype<<16!no of Dimensions (latter in case of backward dvs) ! Opnd2 exactly as for VMY ! %INCLUDE "ERCC07:ITRIMP_HOSTCODES" %CONSTINTEGER HOST=AMDAHL %CONSTINTEGER TARGET=WWC %INCLUDE "ercs01:ebits_ECODES5" %INCLUDE "ERCC07:TRIPCNSTS" %INCLUDE "ERCC07:ITRIMP_TFORM2S" %CONSTINTEGER ESTK=0 %OWNINTEGER GLACABUF,GLABEL,FPPTR,FPHEAD,SWAPMODE %OWNINTEGERNAME CA,GLACA %OWNINTEGERARRAYNAME CTABLE,TAGS !%OWNBYTEINTEGERARRAYNAME CODE %OWNRECORD (LISTF) %ARRAYNAME ASLIST %OWNRECORD (LEVELF) %NAME WORKINGINF %EXTRINSICINTEGERARRAY CAS(0:12) %EXTRINSICRECORD (WORKAF) WORKA %EXTRINSICRECORD (PARMF) PARM %CONSTINTEGER MAXREG=4 %EXTERNALROUTINESPEC FLAGAND FOLD(%RECORD (TRIPF) %ARRAYNAME T) %EXTERNALROUTINESPEC FAULT(%INTEGER I,J,K) %INCLUDE "ercs01:ebits_ESPECS" %CONSTINTEGER MAXKXREF=5 %OWNINTEGERARRAY KXREFS(0:MAXKXREF)=-1(*) %CONSTSTRING (7) %ARRAY PLNAME(0:31)="plabs00","plabs01", "p_cndgs","plabs03","plabs04", "p_unass","p_swerr","p_exper", "p_xblks","p_capex","p_nores", "p_forer","p_reser","p_aberr", "plabs14","plabs15","p_stres", "plabs17","p_strjt","plabs19", "p_iexpn","p_rexpn","p_lrexp", "plabs23","p_conct","plabs25", "p_chkbp","plabs27","p_stcmp", "p_mvbb","plabs30","plabs31" %CONSTSTRING (11) %ARRAY KXREFNAME(0:MAXKXREF)="s#stop","s#ndiag", "s#ilog","s#iexp","s#iocp", "icl9ceauxst" %EXTERNALROUTINESPEC PRINT TRIPS(%RECORD (TRIPF) %ARRAYNAME T) %EXTERNALROUTINESPEC POP(%INTEGERNAME A,B,C,D) !%EXTERNALROUTINESPEC PRINT LIST(%INTEGER HEAD) %EXTERNALROUTINESPEC PUSH(%INTEGERNAME A, %INTEGER B,C,D) %EXTERNALROUTINESPEC MOVE BYTES(%INTEGER L,FB,FO,TB,TO) %INTEGERFNSPEC BYTESWOP(%INTEGER VAL) %ROUTINESPEC REFORMATC(%RECORD (RD) %NAME OPND) %ROUTINESPEC CHANGESEX(%INTEGER BASE,OFFSET,L) %ROUTINESPEC PPJ(%INTEGER A,B) %ROUTINESPEC IMPABORT %EXTERNALROUTINESPEC PRHEX(%INTEGER VALUE,PLACES) %CONSTINTEGER PARAMS BWARDS=YES %CONSTBYTEINTEGERARRAY BYTES(0:7)=0(3),1,2,4,8,16; %CONSTINTEGER DAREA=6; ! AREA FOR DIAG TABLES %CONSTINTEGER CAREA=10; ! AREA FOR CONSTANTS ! ! FIXED GLA CURRENTLY USED AS FOLLOWS ! 0-7 FREE(WAS 2900 ENTRY DESCRIPTOR) ! 8-11 ADDRESS OF UNSHARED SYMBOL TABLES ! 12-15 ADDRESS OF SHARED SYMBOL TABLES ! 16-19 LANGUAGE & COMPILER DATA ! 20-23 ADDRESS OF DAREA WHEN DAREA#SST ! 24-27 ADDRESS OF CONSTANT TABLE ! 28-31 ADDRESS OF A WORD CONTAINING STACKTOP 0FOR NO CHECKS ! 32-35 HOLDS M'IDIA' FOR DIAGNOSTIC IDENTIFICATION ! 36-39 FREE ! 40-55 DEFINES THE ENTRY POINT OF MDIAGS ! %CONSTINTEGER FIXEDGLALEN=56 %OWNINTEGERARRAY FIXED GLA(0:FIXEDGLALEN>>2-1)=M'IMP ',M'GLAP', 0(6),M'IDIA',0(*) ! !*********************************************************************** !* IMP CODE PLANTING ROUTINES * !* CODE AND GLAP ARE PUT INTO THE BUFFERS 'CODE,GLABUF(0:268)' * !* BY A NUMBER OF TRIVIAL ROUTINES.QPUT IS CALLED TO ADD THE * !* BUFFER TO THE OUTPUT FILE. THE BUFFERS ARE BASICALLY 0:255 * !* WITH A 12-BYTE MARGIN TO MINIMISE THE NUMBER OF TESTS FOR * !* THE BUFFER FULL CONDITION * !* * !* PPCURR(GLACURR) IS THE BUFFER POINTER * !* CA(GLACA) IS THE RELATIVE ADDRESS OF THE NEXT BYTE * !* CABUF(GLACABUF) IS CA(GLACA) FOR START OF BUFFER * !*********************************************************************** !*DELSTART ! temp frig routines %ROUTINE CPINIT !*********************************************************************** !* PERFORMS ANY NECESSARY TARGET DEPENDANT INITIALISING * !************************************************************************ %STRING (63) HD HD=" ERCC Ecode IMP*) Compiler Release ".TOSTRING(WORKA_RELEASE)." Version ".WORKA_LADATE EINITIALISE(1,ADDR(HD),ADDR(WORKA_LINE)+4 {frig},ADDR(CAS(2)),0); ! OPEN OBJECT FILE TAGS==WORKA_TAGS EMONON %IF PARM_DCOMP#0 SWAPMODE=ESWAPMODE WORKINGINF==WORKA_LEVELINF(1) %END %EXTERNALROUTINE CODEOUT !*********************************************************************** !* NEEDED TO SATISFY REFERENCE IN PASS2 * !*********************************************************************** %END %EXTERNALROUTINE PDATA(%INTEGER AREA,BNDRY,L,AD) !*********************************************************************** !* ADDS L(BYTES) TO AREA FOR UST,SST AND DIAGS AREAS * !*********************************************************************** %INTEGERNAME PTR PTR==CAS(AREA) PTR=(PTR+BNDRY-1)&(-BNDRY) EDBYTES(AREA,PTR,L,AD) PTR=PTR+L %END %EXTERNALROUTINE PRDATA(%INTEGER AREA,BNDRY,L,REP,AD) !*********************************************************************** !* ADDS L(BYTES) REP TIMES TO AREA FOR UST,SST AND DIAGS AREAS * !* DATA ALREADY BYTE SWAPPED BY PASS2 * !*********************************************************************** %INTEGERNAME PTR PTR==CAS(AREA) PTR=(PTR+BNDRY-1)&(-BNDRY) EDPATTERN(AREA,PTR,REP,L,AD) PTR=PTR+L*REP %END %EXTERNALINTEGERFN PINITOWN(%INTEGER PTYPE,ACC, %RECORD (RD) %NAME INIT, %STRINGNAME XNAME) !*********************************************************************** !* PUTS AN INITIALISED OWN INTO THE GLA. SHOULD DEAL WITH ALL TYPES * !* INIT IS ALREADY BYTE SWAPPED. ACC ETC NORMAL * !* However strings in the A.R. can not be swopped till the last * !* moment since they can be reused. These are copied&swopped here * !*********************************************************************** %RECORD (RD) OPND %INTEGER PREC,TYPE,RL,RES,LITL,I,J %STRING (255) IS TYPE=PTYPE&7 PREC=PTYPE>>4&7 LITL=PTYPE>>14&3 OPND=INIT %IF PTYPE&X'400'#0 %START; ! OWN NAMES GLACA=(GLACA+3)&(-4) RES=GLACA %IF TYPE=5 %START; ! OWNSTRINGNAMES ! HAVE LENGTH @LOW AD END ! AND ADDR AT HIGH AD END ! IN ESTACK LENGTH IS ON TOP OPND_XTRA=ACC-1 ED4(2,RES,OPND_XTRA) EDBYTES(2,RES+4,4,ADDR(OPND_D)) GLACA=GLACA+8 %FINISHELSESTART EDBYTES(2,RES,4,ADDR(OPND_D)) GLACA=GLACA+4 %FINISH %IF LITL=3 %START; ! EXTRINSICS ARE NAMES J=res %IF TYPE=5 %THEN j=RES+4 EDATAREF(2 {gla},j,ACC,XNAME) %FINISH ->END %FINISH RL=BYTES(PREC) %IF TYPE=5 %THEN RL=2 %IF TYPE=3 %THEN RL=4 %IF RL>4 %THEN RL=4 GLACA=(GLACA+RL-1)&(-RL) RES=GLACA; GLACA=GLACA+ACC %IF TYPE=3 %OR (TYPE=5 %AND OPND_D=0) %START EDPATTERN(2,RES,ACC,1,ADDR(OPND_D)) ->END %FINISH %IF TYPE=5 %THENSTART I=WORKA_A(OPND_D) LENGTH(IS)=I %FOR I=1,1,I %CYCLE CHARNO(IS,I)=WORKA_A(OPND_D+I) %REPEAT CHANGE SEX(ADDR(IS),0,ACC) %IF HOST#TARGET EDPATTERN(2,RES,1,ACC,ADDR(IS)); ! ALLOW FOR ALIGNMENT %FINISHELSESTART %IF PREC=3 %THEN ED1(2,RES,OPND_D&255) %IF PREC=4 %THEN ED2(2,RES,OPND_D&x'ffff') %IF PREC=5 %THEN EDBYTES(2,RES,4,ADDR(OPND_D)) %IF PREC=6 %THEN EDBYTES(2,RES,8,ADDR(OPND_D)) %FINISH END: ! NOTE ENTRYT IF EXTERNAL %IF LITL=2 %THEN EDATAENTRY(2 {GLA},RES,ACC,XNAME) %RESULT=RES %END %EXTERNALINTEGERFN POWNARRAYHEAD(%INTEGER PTYPE,J,LB,SIZE,AOFFSET,AAREA,DVOFFSET, %STRING (31) XNAME) !*********************************************************************** !* SOME PARAMETERS ARE ONLY REQUIRED FOR CREATING DESCRIPORS ON * !* 2900 ARCHITECTURE. THESE ARE REDUNDANT HERE * !* PNX ARRAY HEAD HAS DV PTR AT LOW ADDRESS END AND @A(FIRST) AT * !* THE HIGH ADDRESS END. WHEN IN ESTACK DV PTR IS ON TOP * !*********************************************************************** %INTEGER LITL,RES,AHW0,AHW1,HAREA AHW0=AOFFSET AHW1=DVOFFSET %IF HOST#TARGET %START AHW0=BYTESWOP(AHW0) AHW1=BYTESWOP(AHW1) %FINISH HAREA=2; ! NORMAL GLA GLACA=(GLACA+3)&(-4) RES=GLACA GLACA=GLACA+8 LITL=PTYPE>>14&3 EFIX(2,RES,4,DVOFFSET); ! RELOCATE DV PTR %IF LITL=3 %START; ! EXTRINSIC ARRAYS EDATAREF(HAREA,RES+4,SIZE,XNAME) %FINISHELSESTART %IF AAREA=0 %THEN ED4(2,RES+4,AHW0) %ELSE EFIX(HAREA,RES+4,AAREA,AOFFSET) %FINISH %IF LITL=2 %THEN EDATAENTRY(AAREA,AOFFSET,SIZE,XNAME) %RESULT=RES %END %EXTERNALROUTINE CXREF(%STRING (255) NAME, %INTEGER MODE,XTRA, %INTEGERNAME AT) !*********************************************************************** !* OBTAIN A REFERENCE NO FOR EXTERNAL PROCEDURES * !* MODE=0 STATIC CODE XREF * !* MODE=1 DYNAMIC CODE XREF * !*********************************************************************** AT=EXNAME(1,NAME) %END %INTEGERFN KNOWN XREF(%INTEGER N) !*********************************************************************** !* RETURNS THE RT NO OF A KNOWN EXTERNAL NAME DEFINING IT ON * !* THE FIRST OCCURRENCE ONLY * !*********************************************************************** %INTEGER D %STRING (255) S %RESULT=KXREFS(N) %UNLESS KXREFS(N)<0 S=KXREFNAME(N) D=EXNAME(1,S) KXREFS(N)=D %RESULT=D %END %ROUTINE CALL STOP !*********************************************************************** !* CALLS STOP ROUTINE. NOT VIA EPILOGUE ON PERQ * !*********************************************************************** eprecall(known xref(0)) ECALL(KNOWN XREF(0),0,0); ! S#STOP %END %ROUTINE EXCHANGE(%RECORD (RD) %NAME OPND1,OPND2) !*********************************************************************** !* REVERSES NEST SO OPERAND 1 IS AT TOP FOR FLOATS ETC * !* NO ACTION IF OPND2 IS A CONSTANT * !*********************************************************************** %RETURNUNLESS OPND1_FLAG<=8 %AND OPND2_FLAG>=8 %AND OPND1\==OPND2 EOP(EXCH) %END %ROUTINE BULKM(%INTEGER MODE,L,D2) !*********************************************************************** !* PLANT CODE TO MOVE L BYTES (L KNOWN AT COMPILE TIME) FROM * !* ETOS-2,ETOS-3 TO ETOS,ETOS-1 * !* IF MODE =0 SET L BYTES TO D2(0 OR X'80') * !* * !* L MAY BE GREATER THAN 4095 * !*********************************************************************** %INTEGER W2 %IF MODE=0 %START; ! CLEAR W2=D2<<8!D2 %UNLESS L=2 %START; ! SET END 16? BIT WORD EOP(DUPL) %FINISH ESTKLIT(W2) EOP(EXCH); EREFER(0,2); EOP(ESTORE) L=L-2 %RETURNIF L=0 EOP(DUPL) ESTKLIT(2); ! one halfword is two bytes EOP(IADD) %FINISH ESTKLIT(L) EOP(MVB) %END; ! OF ROUTINE BULK M %EXTERNALROUTINE IMPABORT PRINTSTRING(" **************** ABORT******************** ABORT *******") !*DELSTART ELINEDECODE !*DELEND %MONITOR %STOP %END %EXTERNALROUTINE PROLOGUE(%RECORD (LISTF) %ARRAYNAME ALIST) !*********************************************************************** !* GENERATES THE SUBROUTINE THAT ALWAYS ARE REQUIRED ONTO THE * !* FRONT OF THE OBJECT PROGRAM WHERE THEY ARE DIRECTLY ADDRESABLE* !*********************************************************************** %ROUTINESPEC ERR EXIT(%INTEGER A,B,C) %INTEGER I,K %STRING (31) S ASLIST==ALIST GLABEL=WORKA_NNAMES+1; ! FOR GENERATING LABELS FPPTR=0 FPHEAD=0 CA==CAS(1) GLACA==CAS(2) GLACA=FIXEDGLALEN CPINIT; ! INITIALISE CODE PLANTING CTABLE==WORKA_CTABLE %IF PARM_TRACE#0 %THEN I=X'C2C2C2C2' %AND PDATA(DAREA,4,4,ADDR(I)) %CYCLE I=0,1,31 WORKA_PLABS(I)=-1; WORKA_PLINK(I)=0 %REPEAT %CYCLE I=0,1,MAXKXREF KXREFS(I)=-1 %REPEAT ! ! GENERATE THE RUN TIME ERROR ROUTINE :- ! MDIAGS IS %ROUTINE MDIAGS(%INT PC,AP,ERROR,XTRA) ! PC IS A DUMMY EXCEPT AFTER CONTINGENCY ! ON ENTRY TO THIS SUBROUTINE ERROR & XTRA ARE AS PARAMETERS(P1&P2) ! ! ILP2, IPUSH XTRA STACKED ! ILP1, IPUSH ERROR STACKED ! LAS 0 CURRENT LNB TO ETOS ! IPUSH AND STACKED ! CI0 DUMMY CALLING PC ! IPUSH ! CALL N CALL TO NDIAGS ! RETURN ! K=KNOWN XREF(1); ! NDIAG XREF (AS NO ZERO) OBTAINED S=PLNAME(2) EPROC(S,12,0,0,0,WORKA_PLABS(2)); ! NO DISPLAY OR LOCALS ESTKPAR(1,8 {p2},0,4); ! P2 EOP(PUSHVAL) ESTKPAR(1,4 {p1},0,4); ! P1 (ERROR) EOP(PUSHVAL) ESTKDIR(0,0,0,4); EOP(EADDRESS) EOP(PUSHVAL) ESTKLIT(0) EOP(PUSHVAL) ECALL(K,2,16) EOP(RETURN); ! ONLY NEEDED FOR %MONITOR EPROCEND(0,0,0); ! 0 BYTES OF LOCALS ! ! SUBROUTINE TO CALL DEBUG ROUTINE(S#IMPMON) LINE NO IN GR0 ! ! STM 4,0,16(11) ! LM CODER,EPREG,EPDIST ! BCR 15,LINKREG RETURN ADDR ALREADY IN GR15 ! %IF PARM_DBUG#0 %THENSTART ! WORKA_PLABS(3)=CA ! CXREF("S#IMPMON",PARM_DYNAMIC,2,K) %FINISH ! ! SUBROUTINE TO ADVANCE STACK FRONT BY ETOS WORDS AND CHECK FOR OFLOW ! %IF PARM_OPT=1 %THENSTART; ! ONLY REQUIRED WITH CHKING ! WORKA_PLABS(4)=CA %FINISH ! ! SOME ERROR ROUTINES ! ! ERR EXIT(5, X'801', 0) %IF PARM_OPT#0; ! UNASSIGNED VARIABLE ! ERR EXIT(6, X'802', 0); ! SWITCH LABEL UNSET ERR EXIT(7,X'505',1); ! ILLEGEAL EXPONENTIATION ERR EXIT(8,X'201',0) %IF PARM_OPT#0; ! EXCESS BLOCKS ERR EXIT(9,X'601',0); ! CAPACITY EXCEEDED ! ERR EXIT(10,21, 0) ; ! NO RESULT ERR EXIT(11,X'501',0) %IF PARM_OPT#0; ! CYCLE NOT VALID ERR EXIT(12,X'701',0); ! RES FAILS ERR EXIT(13,X'602',0) %IF PARM_OPT#0; ! ARRAY BOUND FAULT CTABLE(0)=BYTESWOP(M'CTAB') CTABLE(1)=0; ! NULL STRING WORKA_CONST PTR=2 WORKA_CONST BTM=WORKA_CONST PTR %IF PARM_PROF#0 %THENSTART; ! ALLOCATE PROFILE COUNT AREA %FINISH ELINESTART(1); ! FOR PNX DEBUGGER %RETURN %ROUTINE ERR EXIT(%INTEGER LAB,ERRNO,MODE) !*********************************************************************** !* MODE=0 FOR DUMMY(ZERO) XTRA - MODE=1 XTRA IN GR1 * !*********************************************************************** %INTEGER J %STRING (31) S S=PLNAME(LAB) EPROC(S,12,0,0,0,WORKA_PLABS(LAB)); ! NO DISPLAY OR LOCALS REQD ESTKLIT(0) EOP(PUSHVAL) ESTKLIT(ERRNO) EOP(PUSHVAL) ECALL(WORKA_PLABS(2),0,8) EPROCEND(0,0,0) %END %END %EXTERNALROUTINE EPILOGUE(%INTEGER STMTS) !*********************************************************************** !* PLANT ANY SUBROUINES THAT HAVE BEEN REQUIRED DURING * !* THE CODE GENERATION PHASE * !*********************************************************************** %ROUTINESPEC FILL(%INTEGER LAB) ELINESTART(9999); ! PSEUDO LINE NO ! ! STRING RESOLUTION ROUTINE (ENTERED BY CALL) ! P5 = ADDRESS OF STRING BEING RESOLVED ! P4 = ADDR OF (ORIGINAL LENGTH! BYTES USED UP<<16) ! P3 = LMAXOF FRAGMENT HOLING STRING(=0 NO SUCH STRING) ! P2 = ADDRESS OF FRAGMENT STRING ! P1 = ADDRESS OF RESOLUTION STRING(CONVERTED TO BYTE FORM ON ENTRY) ! END OF PARAMETER ! L1 = LOCAL COPY OF BYTES USED UP ! L2 = LENGTH OF RESOLUTION STRING ! L3 = NO OF POSSIBLE VAILD COMPARISONS ! L4 = COMPARISON LOOP CONTROL OF FORM 1,1,L3 ! L5 = COPY OF ORIGNAL LHS LENGTH ! L6&7 = NOT USED (WAS WORK VARIABLES IN CH COMPARE LOOP) ! L8 = BYTE POINTER TO FIRST RELEVANT BYTE OF RESTRING ! ! ! STAGE 1 INITIALISE LOOP CONTROL AND WORK OUT THE NO OF VALID ! COMPARISONS AND STORE IN L3 ! ! CI1 ISL4 INITIALISE CONTROL ! LDW ((P4)), CI255, IAND COPY BYTES IN ORIGINAL STRING ! DUPL, ISLL5 AND SAVED IN LOCAL ! LDW ((P4)), CI16, ISHRL ! DUPL, ISL1 COPY OF BYTES USED UP ! ISUB BYTES LEFT OF LHS ! LDB ((P1)), DUPL, ISL2 CURRENT LENGTH OF RESLN STRING ! JINTZ RESOLVING ON NULL STRING ! ILL2, ISUB 0 LENGTH DIFF =1 VALID COMP ! CI1, IADD, DUPL, ISL3 MAX NO OF VALID COMPARISONS ! JINTLEZ NOT ENOUGH LEFT OF LHS ! ILP5, ILL1, IADD, ISL8 ! ! STAGE 2 CYCLE ROUND WITH BYTEARRAY COMPARISONS TO LOCATE STRING ! !OUTERLOOP(L0): REPITIONS TO HERE ! ILP1, CI1, IADD, SET BYTE PTR TO RESOLUTION ! ILL8, ILL4, IADD, POINTER TO RIGHT BYTE IN LHS ! ILL2, CPBEQ TEST FOR EQUALITY ! JINTNZ ALL FOUND WITH NO NONEQIVALENCE ! THIS COMPARISON FAILS ! ADVANCE DOWN BY ONE ! ILL4, CI1, IADD, DUPL, ISL4 INCREMENT CONTROL ! ILL3, JILE AND CONTINUE ! !RESFAIL(L4): RESOLUTION HAS FAILED ! CI0, RETURN EXIT WITH FALSE SET !RESOK(L5): RESOLUTION HAS WORKED ! ILP3, JINTZ FRAGMENT TO BE DISCARDED ! ! CONTROL(L4) IS NO OF BYTES TO BE STORED (IE L+1) OF FRAGMENT ! FIRST COPY IN BYTES + RUBBISH LENGTH THEN OVERWRITE ! WITH CORRECT LENGTH ! ! ILL8 SOURCE PTR ! ILP2 DEST POINTER ! ILL4 BYTES TO MOVE ! ASSIGN POSSIBLY OVERLAPPING ! MVB ASSIGN OK IF OVERLAPPED ! ILL4, CI1, ISUB FRAGMENT LENGTH ! DUPL, STB ((P2)) STORED WITH PTR ! ILP3, JILE CHECK FOR CAP EXCEED ! CALL PLABS9 AND FAIL IF SO !NOSTORE(L6): ENTERS HERE IF FRAGMENT IS DISCARDED ! ILL1,ILL2,IADD,ILL4,IADD RECALCULATE BYTES USED UP ! CI1, ISUB, CI16, ISHLL ! ILL5, IOR, STW((P4)) AND STORE VIA HALFWORD PTR ! CI1, RETURN EXIT WITH RESULT=TRUE ! %IF WORKA_PLINK(16)=0 %THEN ->P17 FILL(16) ESTKLIT(1) ESTKDIR(0,-4*4,0,4); EOP(ESTORE) ESTKPARIND(1 {lev},4*4,0,4 {word}); ! ldw ((p4) ESTKLIT(255); EOP(IAND); EOP(DUPL) ESTKDIR(0,-4*5,0,4); EOP(ESTORE) ESTKPARIND(1,4*4,0,4); ! ldw ((p4) ESTKLIT(16); EOP(ISHRL) EOP(DUPL) ESTKDIR(0,-4*1,0,4); EOP(ESTORE) EOP(ISUB) ESTKPARIND(1,4*1,0,1 {byte}) EOP(DUPL) ESTKDIR(0,-4*2,0,4); EOP(ESTORE) EJUMP(JINTZ,GLABEL+5) ESTKDIR(0,-4*2,0,4) EOP(ISUB) ESTKLIT(1) EOP(IADD); EOP(DUPL) ESTKDIR(0,-4*3,0,4); EOP(ESTORE) EJUMP(JINTLEZ,GLABEL+4) ESTKPAR(1,4*5,0,4) ESTKDIR(0,-4*1,0,4) EOP(IADD) ESTKDIR(0,-4*8,0,4); EOP(ESTORE) ! THIS IS "OUTERLOOP" ELABEL(GLABEL) ESTKPAR(1,4*1,0,4) ESTKLIT(1) EOP(IADD) ESTKDIR(0,-4*8,0,4) ESTKDIR(0,-4*4,0,4) EOP(IADD) ESTKDIR(0,-4*2,0,4) EOP(CPBEQ) EJUMP(JINTNZ,GLABEL+5) ESTKDIR(0,-4*4,0,4) ESTKLIT(1) EOP(IADD); EOP(DUPL) ESTKDIR(0,-4*4,0,4); EOP(ESTORE) ESTKDIR(0,-4*3,0,4) EJUMP(JILE,GLABEL) ! THIS IS "RESFAIL" ELABEL(GLABEL+4) ESTKLIT(0) EOP(EINTRES) EOP(RETURN) ! THIS IS "RESOK" ELABEL(GLABEL+5) ESTKPAR(1,4*3,0,4) EJUMP(JINTZ,GLABEL+6) ESTKDIR(0,-4*8,0,4) ESTKPAR(1,4*2,0,4) ESTKDIR(0,-4*4,0,4) EOP(MVB) ESTKDIR(0,-4*4,0,4) ESTKLIT(1) EOP(ISUB); EOP(DUPL) ESTKPAR(1,4*2,0,4); erefer(0,1); EOP(ESTORE) ESTKPAR(1,4*3,0,4) EJUMP(JILE,GLABEL+6) EPRECALL(WORKA_PLABS(9)) ECALL(WORKA_PLABS(9),0,0) ! THIS IS "NOSTORE" ELABEL(GLABEL+6) ESTKDIR(0,-4*1,0,4) ESTKDIR(0,-4*2,0,4) EOP(IADD) ESTKDIR(0,-4*4,0,4) EOP(IADD) ESTKLIT(1) EOP(ISUB) ESTKLIT(16) EOP(ISHLL) ESTKDIR(0,-4*5,0,4) EOP(IOR) ESTKPARIND(1,4*4,0,4 {pointer}); EOP(ESTORE) ESTKLIT(1) EOP(EINTRES) EOP(RETURN) EPROCEND(32,0,0) GLABEL=GLABEL+8 P17: ! ! EVALUATE X**Y ! ******** **** ! Y IS IN FR0 AND X IS AT TOP OF STACK ! EVENT 5/5 IS SIGNALLED IF X<0 OR (X=0 AND Y<=0) ! OTHERWISE RESULT=EXP(Y*LOG(Y)) ! ! ST 15,12(WSPR) SAVE LINK ! BALR 1,0 ! LTDR 0,0 ! BC 4,PLAB7 ! BC 7,20(1) ! LD 2,0(WSPR) ! LTDR 2,2 ! BC 12,PLAB7 ! LA WSPR,16(WSPR) PROTECT X AND RETURN ADD ! STD 0,64(WSPR) PARAMETER X TO LOG ! STM 4,14,16(WSPR) SAVE ENVIRONMENT ! LM CODER,EPREG,LOGEPDISP ! BALR LINKREG,EPREG ! LA 0,16 ! SR WSPR,0 ! MD 0,0(WSPR) ! STD 0,64(WSPR) Y*LOG(X) TO EXP ! STM 4,14,16(WSPR) ! LGR LINKREG,12(WSPR) ! LM CODER,EPREG,EXPEPDISP ! BCR 15,LINKREG RETURNS DIRECT TO PROGRAM ! %IF WORKA_PLINK(17)=0 %THEN ->P18 FILL(17) ! %IF LOGEPDISP=0 %THEN CXREF("S#ILOG",0,2,LOGEPDISP) ! %IF EXPEPDISP=0 %THEN CXREF("S#IEXP",0,2,EXPEPDISP) P18: ! ! STRING JAM TRANSFER ENTERED BY CALL WITH 5 PARAMS ! P2 = VIRT (WORD) ADDR OF SOURCE ! P2 = MAX LENGTH OF DEST ! P1 = VIRT (WORD) ADDR OF DEST ! L1 = LOCAL THE ACTUAL STRING BYTES TO BE MOVED ! ! ILP2, LBI, DUPL, ISL1 LENGTH OF SOURCE ! ILP2, JILE NO TRUNCATION ! ILP2, ISL1 TRUNCATED LENGTH !L0: ILP2 ! ILP1, ILL1 ! CI1, IADD, MOVE LBYTES + LENGTH BYTE ! MVB ! ILL1, ILP1, ASSB AND OVERWRITE LENGTH ! RETURN ! %IF WORKA_PLINK(18)=0 %THEN ->P19 FILL(18) ESTKPAR(1,4*3,0,4); EREFER(0,1); EOP(DUPL); ESTKDIR(0,-4*1,0,4); EOP(ESTORE) ESTKPAR(1,4*2,0,4) EJUMP(JILE,GLABEL) ESTKPAR(1,4*2,0,4); ESTKDIR(0,-4*1,0,4); EOP(ESTORE) ELABEL(GLABEL) ESTKPAR(1,4*3,0,4); ESTKPAR(1,4*1,0,4) ESTKDIR(0,-4*1,0,4) ESTKLIT(1) EOP(IADD) EOP(MVB) ESTKDIR(0,-4*1,0,4); ESTKPAR(1,4*1,0,4); EREFER(0,1); EOP(ESTORE) EOP(RETURN) EPROCEND(8,0,0) GLABEL=GLABEL+1 P19: ! called subroutine to evaluate i****4 ! ! %IF WORKA_PLINK(19)=0 %THEN ->P20;! ROUTINE NOT USED !P20: ! called subroutine to evaluate i****N ( I 32 BITS) ! N OVER I IN ESTACK NO C PARAMETERS ! IN LINE CODE USED AS NO JLK INSTRUCTION %IF WORKA_PLINK(20)=0 %THEN ->P21; ! ROUTINE NOT USED FILL(20) EPROCEND(8,0,0) GLABEL=GLABEL+5 P21: ! called subroutine to evaluate X**N ( X 32 BITS) ! In-line code now genererated for this !P22: ! called subroutine to evaluate X**N ( X 64 BITS) ! IN LINE CODE NOW USED ! !P23: ! ! STRING PRE-CONCATENATION SUBROUTINE ! NOT USED ON PNX ALL DONE AT P24 ! !P24: ! ! STRING CONCATENATION SUBROUTINE ! MUST LEAVE NO RUBBISH IN ESTACK IN CASE LHS DEST IN NEST ! ! P2 HAS WORD ADDRESS OF NEXT BIT ! P1 HAS WORD ADDRESS OF WORKAREA CONTAINING PREVIOUS BITS ! L1 HAS BYTE LENGTH OF P2 ! L2 HAS BYTE LENGTH OF P1 ! ! ILP2, DUPL, LBI, DUPL ! ISL1, EXCH, CI1, IADD, EXCH LENGTH OF MOVE OVER SOURCE ! ILP1, DUPL, LBI, DUPL ! ISL2, IADD, CI1, IADD ! EXCH, MVB STRINGS JOINED ! ILL1, ILL2, IADD, ILP1 ! ASSB, ! RETURN ! %IF WORKA_PLINK(24)=0 %THEN ->P25 FILL(24) ESTKPAR(1,4*2,0,4); EOP(DUPL); EREFER(0,1); EOP(DUPL) ESTKDIR(0,-4*1,0,4); EOP(ESTORE); EOP(EXCH); ESTKLIT(1) EOP(IADD); EOP(EXCH) ESTKPAR(1,4*1,0,4); EOP(DUPL); EREFER(0,1); EOP(DUPL) ESTKDIR(0,-4*2,0,4); EOP(ESTORE); EOP(IADD); ESTKLIT(1); EOP(IADD) EOP(EXCH) EOP(MVB) ESTKDIR(0,-4*1,0,4); ESTKDIR(0,-4*2,0,4); EOP(IADD); ESTKPAR(1,4*1,0,4) EREFER(0,1); EOP(ESTORE) EOP(RETURN) EPROCEND(8,0,0) P25: ! ! CHECK ARRAY BOUND WITH 16 BIT INDEX ! NO RELEVANCE TO PNX !P26: ! ! CHECK ARRAY BOUND WITH 32 BIT INDEX ! NOW DONE IN LINE WITH CHK INSTR !P27: ! REDUCE LONG BYTE INDEX ! NOT NEEDED FOR PNX ! !P28: ! DIFFERENCE IMP STRINGS ! PARAMETERS ARE TWO BYTE ADDRESS AND ROUTINE RETURNS FIRST DIFFERENCE ! ! P1 HAS FIRST OPERAND (BYTE) ADDRESS ! P2 HAS SECOND OPERAND ADDRESS ! L1 HAS FIRST OPERAND CURRENT (BYTE) ADDRESS ! L2 HAS SECOND OPERAND CURREMT BYTE ADDRESS ! L3 HAS SHORTER STRING LENGTH ! ! ILP1 DUPL, CI1 IADD ! ISL1, LBI, ISL3 ! ILP2, DUPL, CI1, IADD ! ISL2, LBI, ILL3, ! JIGE ! LDB ((P2)), ISL3 SHORTER LENGTH SET !L0: ILL3, JINTZ ZERO LENGTH WITH NO DIFFERENCE ! ILL3, CI1, ISUB, ISL3 LENGTH DECREMENTED ! LDB ((L1)), LDB ((L2)) NEXT TWO CHARS ! JINE DIFFERENC FOUND ! ILL2, CI1, IADD, ISL2 UPDATE 2ND POINTER ! ILL1, CI1, IADD, ISL1 UPDATE 1ST POINTER ! JUMP !L1: RETURN DIFFERENCE OF CHS ! LDB ((L1)), LDB ((L2)), ISUB, RETURN !L2: NO DIFFERENCES RETURN LENGTHS ! LDB ((P1)),LDB ((P2)), ISUB ! RETURN ! %IF WORKA_PLINK(28)=0 %THEN ->P29 FILL(28) ESTKPAR(1,4*1 {P1},0,4); EOP(DUPL) ESTKLIT(1); EOP(IADD) ESTKDIR(0,-4 {L1},0,4); EOP(ESTORE) EREFER(0,1); ESTKDIR(0,-12 {L3},0,4); EOP(ESTORE) ESTKPAR(1,4*2 {P2},0,4); EOP(DUPL) ESTKLIT(1); EOP(IADD) ESTKDIR(0,-8 {L2},0,4); EOP(ESTORE) EREFER(0,1); ESTKDIR(0,-12 {L3},0,4) EJUMP(JIGE,GLABEL) ESTKPARIND(1,P2,0,1 {ldb ((p2))}) ESTKDIR(0,-12 {(l3)},0,4); EOP(ESTORE) ELABEL(GLABEL) ESTKDIR(0,-12 {l3},0,4) EJUMP(JINTZ,GLABEL+2) ESTKDIR(0,-12 {L3},0,4) ESTKLIT(1) EOP(ISUB) ESTKDIR(0,-12 {L3},0,4); EOP(ESTORE) ESTKIND(0,-4,0,1 {ldb ((L1))}) ESTKIND(0,-8,0,1 {ldb ((L2))}) EJUMP(JINE,GLABEL+1) ESTKDIR(0,-4 {L1},0,4); ESTKLIT(1); EOP(IADD) ESTKDIR(0,-4 {L1},0,4); EOP(ESTORE) ESTKDIR(0,-8 {L2},0,4); ESTKLIT(1); EOP(IADD) ESTKDIR(0,-8 {L2},0,4); EOP(ESTORE) EJUMP(JUMP,GLABEL) ELABEL(GLABEL+1); ! LABEL L1 HERE ESTKIND(0,-4,0,1 { ldb((L1))}) ESTKIND(0,-8,0,1 {ldb ((L2))}) EOP(ISUB); EOP(EINTRES) EOP(RETURN) ELABEL(GLABEL+2); ! LABEL L2 IS HERE ESTKPARIND(1,4*1,0,1 {ldb ((P1))}) ESTKPARIND(1,4*2,0,1 {ldb ((P2))}) EOP(ISUB); EOP(EINTRES) EOP(RETURN) EPROCEND(16,0,0) GLABEL=GLABEL+3 P29: ! ! GENERATE A MOVE BYTES ROUTINE ENTERED BY CALL ! USED IN RESOLUTION FOR POSSIBLY OVERLAPPED MOVES ! NO RELEVANCE TO Emachines MOVE BYTES INTRUCTION ADEQUATE %IF WORKA_PLINK(29)=0 %THEN ->P30 FILL(29) EPROCEND(0,0,0) P30: %IF PARM_DCOMP#0 %THEN PRINTSTRING(" CODE FOR LINE 99999") %AND ELINEDECODE %BEGIN !*********************************************************************** !* PASS INFORMATION TO QPUT TO ENABLE IT TO GENERATE THE * !* LOADER DATA AND COMPLETE THE PROGRAM FILE. * !*********************************************************************** %INTEGERARRAY SIZES(0:10) %ROUTINESPEC DUMP CONSTS %INTEGER LANGFLAG,PARMS,I,K ! CODE OUT ! CNOP(0,8) ! FIXED GLA(6)=CA; ! CONST TABLE ADDRESS %IF PARM_TRACE=0 %THEN LANGFLAG=6 %ELSE LANGFLAG=1 LANGFLAG=LANGFLAG<<24 DUMP CONSTS PARMS=(PARM_DIAG<<1!PARM_LINE)<<1!PARM_TRACE FIXED GLA(4)=LANGFLAG!WORKA_RELEASE<<16!(PARM_CPRMODE&1)<<8!PARMS; ! LANG RLSE & MAINPROG FIXED GLA(8)=BYTESWOP(M'IDIA') I=GLACA-GLACABUF %IF PARM_INHCODE=0 %THENSTART ! BACK OF GLAP EDBYTES(2,28,FIXEDGLALEN-28,ADDR(FIXED GLA(7))); ! FRONT OF GLAP ! word 0-6 are standard and set up by ecode ! on call of initialise from cpinit %IF PARM_TRACE#0 %THEN I=X'E2E2E2E2' %AND PDATA(DAREA,4,4,ADDR(I)) %FINISH %CYCLE I=1,1,10 SIZES(I)=0 SIZES(I)=(CAS(I)+7)&(-8) %IF 2<=I<=6 %REPEAT ETERMINATE(ADDR(SIZES(1))); ! SUMMARY INFO. PRINTSTRING(" WWC CODE") WRITE(SIZES(1),6) %IF SIZES(4)>0 %THEN PRINTSTRING("+") %AND WRITE(SIZES(4),4) PRINTSTRING(" BYTES GLAP") WRITE(SIZES(2),3); PRINTSTRING("+") WRITE(SIZES(5),1); PRINTSTRING(" BYTES DIAG TABLES") WRITE(SIZES(DAREA),3); PRINTSTRING(" BYTES TOTAL") K=SIZES(1)+SIZES(2)+SIZES(4)+SIZES(5)+SIZES(6) WRITE(K,5); PRINTSTRING(" BYTES ") %IF PARM_FAULTY=0 %THENSTART WRITE(STMTS,7); PRINTSTRING(" STATEMENTS COMPILED") %FINISHELSESTART PRINTSTRING("PROGRAM CONTAINS"); WRITE(PARM_FAULTY,2) PRINTSTRING(" FAULT"); PRINTSYMBOL('S') %IF PARM_FAULTY>1 %FINISH NEWLINES(2) %ROUTINE DUMP CONSTS %INTEGER I,J,K %IF PARM_DCOMP#0 %START PRINTSTRING(" Constant Table") I=0 %CYCLE NEWLINE PRHEX(4*I,5) %CYCLE J=0,1,7 SPACES(2) PRHEX(WORKA_CTABLE(I+J),8) %REPEAT SPACE %CYCLE J=0,1,31 K=ADDR(WORKA_CTABLE(0))+4*I+J K=BYTEINTEGER(K) %IF K<=31 %OR K>125 %THEN K=32 PRINT SYMBOL(K) %REPEAT I=I+8 %EXITIF I>=WORKA_CONSTPTR %REPEAT %FINISH %END %END %RETURN %ROUTINE FILL(%INTEGER LAB) !*********************************************************************** !* NOT NECESSARY ACTUALLY TO FILL JUMPS ON PNX * !* CONSTRUCT THE RIGHT PPROC STATEMENT AND LOADER DOES THE REST * !*********************************************************************** %STRING (15) S S=PLNAME(LAB) EPROC(S,4,0,0,0,WORKA_PLINK(LAB)); ! NO DISPALY REQD %END %END %REALFN ICL REAL TO PERQ(%REAL ICL REAL) !*********************************************************************** !* This is a function which converts a real number in ICL * !* floating-point format into one that is in ICL PERQ * !* floating-point format. * !* * !* At Exit: RESULT= +infinity if ICL Real is too large * !* RESULT= -infinity if ICL Real is too small * !* RESULT= PERQ Real otherwise * !* * !*Assumptions: (i). PERQ floating-point format conforms with the * !* proposed IEEE draft standard, * !* (ii). conversion is to be applied to 32-bit Reals, * !* (iii). conversion is to be applied on ICLs, * !* (iv). the hexadecimal representation of 1.0, * !* on ICL PERQ's is R'3F800000' * !*********************************************************************** %CONSTREAL MINUS INFINITY= R'FF800000'; ! ie sign=1,exp=255,fraction=0 %CONSTREAL PLUS INFINITY= R'7F800000'; ! ie sign=0, exp=255,fraction=0 %CONSTREAL PERQ ZERO= R'00000000'; ! ie sign=0,exp=0,fraction=0 %INTEGER BITS SHIFTED LEFT; ! by a SHZ instruction on ICL Fraction %INTEGER ICL EXP; !exponent of ICL Real - 70 %INTEGER SIGN; !sign bit of ICL Real (1 if minus: 0 if plus) %INTEGER PERQ EXP; !exponent of PERQ Real (calculated) %INTEGER PERQ FRACTION; !fraction of PERQ Real (derived from ICL Fraction) %REAL PERQ REAL; !--the Result %IF HOST#TARGET %AND HOST#PNX %START %IF PARM_X#0 %THENRESULT=ICL REAL; ! FOR SIMULATOR %IF ICL REAL=0.0 %THENRESULT=PERQ ZERO %IF ICL REAL<0.0 %THEN SIGN=1 %AND ICL REAL=-ICL REAL %ELSE SIGN=0 ! ICL Real is now positive ! Decompose the ICL Real: %IF HOST=EMAS %START *LSS_ICL REAL *FIX_ICL EXP *SHZ_BITS SHIFTED LEFT *USH_1; *USH_-9 *ST_PERQ FRACTION %ELSE PERQ FRACTION=INTEGER(ADDR(ICL REAL)) ICL EXP=PERQ FRACTION>>24&x'7f'-70 PERQ FRACTION=PERQ FRACTION<<8 BITS SHIFTED LEFT=8 %WHILE PERQ FRACTION>0 %CYCLE PERQ FRACTION=PERQ FRACTION<<1 BITS SHIFTED LEFT=BITS SHIFTED LEFT+1 %REPEAT PERQ FRACTION=PERQ FRACTION<<1>>9 %FINISH ! Calculate PERQ Exponent: PERQ EXP=((ICL EXP+5)*4 {as exponent is a hexadecimal exp})+(11-BITS SHIFTED LEFT) %C {equals either 0,1,2, or 3}+127 {the bias of the exponent} ! -and examine its range: %IF PERQ EXP<=0 %THENRESULT=MINUS INFINITY {ie Real Underflow} %IF PERQ EXP>=255 %THENRESULT=PLUS INFINITY { Real Overflow} ! Construct the PERQ Real INTEGER(ADDR(PERQ REAL))=(SIGN<<8!PERQ EXP)<<23!PERQ FRACTION %RESULT=PERQ REAL %FINISHELSERESULT=ICL REAL %END; !of ICL Real to PERQ %LONGREALFN ICL LONGREAL TO PERQ(%LONGREAL ICL2900 REAL) !*********************************************************************** !* This is a function which converts a double precision real * !* in ICL 2900 floating-point format into one that is * !* in ICL PERQ floating-point format. * !* At Exit: RESULT= equivalent PERQ real * !* * !*Assumptions: (i). PERQ floating-point format conforms with the * !* proposed IEEE draft standard, * !* (ii). conversion is to be applied to 64-bit Reals, * !* (iii). conversion is to be applied on ICL2900s, * !* (iv). the hexadecimal representation of 1.0, * !* on ICL PERQ's is R'3FF0000000000000' * !************************************************************************ %INTEGER BITS SHIFTED LEFT; ! by a SHZ instruction on ICL2900 Fraction %INTEGER ICL2900 EXP; !exponent of ICL2900 Real - 78 %INTEGER SIGN; !sign bit of ICL2900 Real (1 if minus: 0 if plus) %INTEGER PERQ EXP; !exponent of PERQ Real (calculated) %LONGREAL PERQ REAL; !--the Result %IF HOST#TARGET %AND HOST#PNX %START %LONGINTEGER PERQ FRACTION; !fraction of PERQ Real (derived from ICL2900 Fraction) %IF PARM_X#0 %THENRESULT=ICL2900REAL; ! FOR SIMULATOR %IF ICL2900 REAL=0.0 %THENRESULT=0.0 %IF ICL2900 REAL<0.0 %THEN SIGN=1 %AND ICL2900 REAL=-ICL2900 REAL %ELSE SIGN=0 ! ICL2900 Real is now positive ! Decompose the ICL2900 Real: %IF HOST=EMAS %START *LSD_ICL2900 REAL *FIX_ICL2900 EXP *SHZ_BITS SHIFTED LEFT *USH_1; *USH_-12 *ST_PERQ FRACTION %ELSE PERQ FRACTION=LONGINTEGER(ADDR(ICL 2900 REAL)) ICL2900EXP=PERQ FRACTION>>56&x'7f'-78 PERQ FRACTION=PERQ FRACTION<<8 BITS SHIFTED LEFT=8 %WHILE PERQ FRACTION>0 %CYCLE PERQ FRACTION=PERQ FRACTION<<1 BITS SHIFTEDLEFT=BITS SHIFTED LEFT+1 %REPEAT PERQ FRACTION=PERQ FRACTION<<1>>12 %FINISH ! Calculate PERQ Exponent: PERQ EXP=(ICL2900 EXP+78 {which was subtracted by FIX above}-64 %C {which is the ICL2900 bias}-1 %C { as the most significant digit is <1 and >=1/16})*4 %C { as the ICL2900 exponent is a hex exponent}+(11-BITS SHIFTED LEFT) %C {bits shifted left equals 11, or 10, or 9, or 8}+1023 {bias of PERQ double precision reals} ! Construct the PERQ Real LONGINTEGER(ADDR(PERQ REAL))=(LENGTHENI(SIGN<<11!PERQ EXP)<<52)!PERQ FRACTION %RESULT=PERQ REAL %FINISHELSERESULT=ICL2900 REAL %END; ! of ICL2900 LongReal to PERQ %ROUTINE PPJ(%INTEGER JUMP,N) !*********************************************************************** !* PLANT A 'JUMP PERMENTRY(N)' * !* IF JUMP=0 THEN PLANT A CALL * !*********************************************************************** %INTEGER VAL,LAB,INF %CONSTBYTEINTEGERARRAY INVJ(24:35)= JILE{JIGT},JIGE{JILT}, JINE{JIEQ},JIEQ{JINE}, JILT{JIGE},JIGT{JILE}, JINTLEZ{JINTGZ},JINTGEZ{JINTLZ}, JINTNZ{JINTZ},JINTZ{JINTNZ}, JINTLZ{JINTGEZ},JINTGZ{JINTLEZ} %CONSTINTEGERARRAY INFO(0:30)=0,0,x'00020008',0(13), X'02050014'{16 RESLN}, 0,x'0003000c'{18 STRINGJT}, 0(5),X'00020008'{24 CONCAT}, 0(3),X'02020008'{28 STRING COMP}, 0(*) LAB=0 VAL=WORKA_PLABS(N) INF=INFO(N); ! RESULTFLAGS<<24! npars<<16 ! BYTES OF PARAMS %IF VAL<0 %START VAL=ENEXTPROC WORKA_PLABS(N)=VAL WORKA_PLINK(N)=VAL %FINISH %IF JUMP>=24 %THEN LAB=GLABEL %AND GLABEL=LAB+1 %IF LAB>0 %THEN EJUMP(INVJ(JUMP),LAB) EPRECALL(VAL) %UNLESS INF&255#0; ! PRECALL MUST BE DONE BEFOR PARAMS ECALL(VAL,(INF>>16)&255,INF&X'FF') %IF INF>>24#0 %THEN ESTKRESULT(0,1,4) %IF LAB>0 %THEN ELABEL(LAB) %END %INTEGERFN BYTESWOP(%INTEGER VAL) !*********************************************************************** !* PERFORMS A COMPLETE BYTE REVERSAL OF VAL * !*********************************************************************** %SWITCH SW(0:3) %IF HOST#TARGET %THEN ->SW(SWAPMODE&3) SW(0):%RESULT=VAL SW(1):%RESULT=(VAL<<8&x'ff00ff00')!(VAL>>8&x'ff00ff') SW(2):%RESULT=VAL<<16!VAL>>16 SW(3):%RESULT=(VAL<<24)!(VAL<<8&X'FF0000')!(VAL>>8&X'FF00')!(VAL>>24) %END %EXTERNALROUTINE REFORMATC(%RECORD (RD) %NAME OPND) !*********************************************************************** !* REFORMATS A CONSTANT TO TAKE INTO ACCOUNT DIFFERENT HOST-TARGET * !* REPRESENTATIONS. HOST MAY BE EMAS OR PNX. * !*********************************************************************** %IF HOST#TARGET %START %INTEGER TYPE,PREC,I %LONGREAL LR %RECORD (RD) TEMP %IF SWAPMODE=0 %THENRETURN TEMP=OPND I=OPND_D; ! ALL INTEGER UP TO 32 BIT TYPE=OPND_PTYPE&7 PREC=OPND_PTYPE>>4&7 %IF TYPE=1 %START; ! INTEGERS %IF PREC=3 %THEN OPND_B0<-I %AND OPND_B1<-I %AND OPND_B2<-I %AND OPND_B3<-I %AND %C %RETURN %IF PREC=4 %THENSTART OPND_D=BYTESWOP(I<<16!(I&X'FFFF')) %RETURN %FINISH %IF PREC=5 %THEN OPND_D=BYTESWOP(OPND_D) %ANDRETURN IMPABORT %FINISH %IF TYPE=2 %THENSTART %IF PREC=5 %START TEMP_R=ICLREALTOPERQ(OPND_R) OPND_D=BYTESWOP(TEMP_D) %RETURN %FINISH %IF PREC=6 %START MOVE BYTES(8,ADDR(OPND_D),0,ADDR(LR),0); ! obtaing unaligned longreal LR=ICLLONGREALTOPERQ(LR) MOVE BYTES(8,ADDR(LR),0,ADDR(TEMP_D),0) OPND_D=TEMP_D; OPND_XTRA=TEMP_XTRA %IF SWAPMODE&4#0 %THEN OPND_D=TEMP_XTRA %AND OPND_XTRA=TEMP_D OPND_D=BYTESWOP(OPND_D) OPND_XTRA=BYTESWOP(OPND_XTRA) %RETURN %FINISH %FINISH %IF TYPE=5 %THENRETURN; ! CANT CHANGE SEX HERE ! MIGHT BE USED IN COMPILE TIME OP IMPABORT %FINISH %END %EXTERNALROUTINE CHANGESEX(%INTEGER BASEAD,OFFSET,L) !*********************************************************************** !* ALTERERS INITIALISED DATA FOR A BYTE SEX CHANGE * !*********************************************************************** %OWNBYTEINTEGERARRAYFORMAT F(0:X'FFFF') %BYTEINTEGERARRAYNAME A %INTEGER I,J %IF HOST#TARGET %AND X'10001'#SWAPMODE&X'10001'#0 %START A==ARRAY(BASEAD,F) %MONITORUNLESS OFFSET&1=0 I=OFFSET %WHILE L>0 %CYCLE J=A(I) A(I)=A(I!!1) A(I!!1)=J I=I+2; L=L-2 %REPEAT %FINISH %END %EXTERNALROUTINE FILL DTABREFS(%INTEGERNAME CURRINFRAL) !*********************************************************************** !* PLUGS REFENCES TO THE DIAG TABLES FOR CURRINF WHICH ARE * !* ABOUT TO BE GENERATED AT CAS(DAREA). THE LIST POPPED HAS * !* S1=AREA 1=CODE, DAREA FOR DIAGNOSTIC AREA * !* S2= THE OFFSET OF INSTRUCTION OR FORWARD POINTER * !* S3=THE WORD BEFORE FILLING - NOT USED FOR AREA 1 * !*********************************************************************** %INTEGER Q,JJ,KK %WHILE CURRINFRAL#0 %CYCLE POP(CURRINFRAL,Q,JJ,KK) %IF Q=1 %THENSTART ESETMARKER(JJ,CAS(DAREA)) %FINISHELSESTART ED2(Q,JJ+2,CAS(DAREA)) ! THE PLUG ONLY ALLOWS 16 BIT OFFSET ! BUT TABLE FORM ALLOWS 18 BIT OFFSET ! EXTRA PLUG NEEDED IF >65K DIAGS %FINISH %REPEAT %END !%ROUTINE GET WSP(%INTEGERNAME PLACE,%INTEGER SIZE) !*********************************************************************** !* FIND OR CREATE A TEMPORARY VARIABLE OF 'SIZE' WORDS * !*********************************************************************** !%INTEGER J,K,L,F ! %IF SIZE>4 %THEN SIZE=0 ! K=worka_n ! %IF SIZE=0 %THEN worka_n=worka_n+268 %ELSE worka_n=worka_n+SIZE<<2 ! PLACE=K !%END %EXTERNALINTEGERFN ETEMPWORKSPACE(%INTEGER SIZE{in bytes}) !************************************************************************ !* provides a temporary for the emachine in the current stack fram * !* which kept in workinginf and updated on every entry to generate * !* This version uses unix conventions and the result is negative * !************************************************************************ %INTEGER K %IF SIZE<4 %THEN SIZE=4 %IF SIZE>8 %THEN IMPABORT K=WORKA_N WORKA_N=K+SIZE %RESULT=WORKINGINF_DISPLAY-(K+SIZE) %END %EXTERNALROUTINE GENERATE(%RECORD (TRIPF) %ARRAYNAME TRIPLES, %INTEGER CURRLEVEL, %ROUTINE GET WSP(%INTEGERNAME PLACE, %INTEGER SIZE)) !*********************************************************************** !* EVALUATE A LIST OF TRIPLES PLABTING CODE IN BUFFERS * !*********************************************************************** %INTEGERFNSPEC JCODE(%INTEGER TFMASK) %ROUTINESPEC VMY %ROUTINESPEC REXP %ROUTINESPEC STARSTAR %ROUTINESPEC ISTARSTAR %ROUTINESPEC CIOCP(%INTEGER N) %INTEGERFNSPEC RLEVTOLEVEL(%INTEGER RLEV) %INTEGERFNSPEC LOAD(%RECORD (RD) %NAME OP) %INTEGERFNSPEC STRINGLBAD(%RECORD (TAGF) %NAME TCELL) %INTEGERFNSPEC RECORDELAD(%RECORD (TAGF) %NAME TCELL, %INTEGER SPTYPE,XTRA) %ROUTINESPEC INDLOAD(%INTEGER TYPE,SIZE,OFFSET) %ROUTINESPEC INDSTORE(%INTEGER TYPE,SIZE,OFFSET) %ROUTINESPEC LOADAD(%RECORD (RD) %NAME OPND) %ROUTINESPEC LOADPTR(%RECORD (RD) %NAME OPND,OPND2) %ROUTINESPEC DSTORE(%INTEGER TYPE,OPCODE,SIZE,LEVEL,DISP) %ROUTINESPEC CHOP OPERAND(%RECORD (RD) %NAME OPND, %INTEGER PT,X) %ROUTINESPEC DFETCH(%INTEGER TYPE,SIZE,LEVEL,DISP) %ROUTINESPEC DFETCHAD(%INTEGER SIZE,LEVEL,DISP) %ROUTINESPEC FETCH LOW AD END(%INTEGER B,D) %ROUTINESPEC FETCH HIGH AD END(%INTEGER B,D) %ROUTINESPEC STORE LOW AD END(%INTEGER B,D) %ROUTINESPEC STORE HIGH AD END(%INTEGER B,D) ! %RECORD (RD) %NAME OPND1,OPND2,OPND %RECORD (RD) TOPND %RECORD (TRIPF) %NAME CURRT,WORKT %RECORD (LEVELF) %NAME LINF,CURRINF %RECORD (TAGF) %NAME TCELL %RECORD (LISTF) %NAME LCELL ! %INTEGER C,D,WTRIPNO,JJ,COMM,XTRA,PT,BFFLAG,TRIPINF,TRIPVAL,PTYPE,TYPE,PREC,STPTR,DPTYPE, DACC,L0,B1,B2,B3,LRES,STACKATCALL,SKEY,TEMPLOC ! ! TRIPDATA GIVES INFORMATION ON TRIPLE ! TOP 4 BITS HAVE TYPE ! NEXT 12 BITS HAVE FLAGS:- ! 2**16 SET IF COMMUTATIVE ! 2**17 SET DONT LOAD OPERAND2 ! 2**18 SET DONT LOAD OPERAND1 ! 2**19 DONT SWOP NON COMMUTABLE OPERANDS ! NEXT 8 BITS HAVE MAX CODE PLANTED IN BYTES NOT INCLUDING ANY CONSTANSTS ! OR STRINGS WHICH MAY HAVE TO GO INLINE ! BOTTOM 8 BITS HAVE A POINTER OR VALUE ! TYPE 0 TRIPLES ARE IGNORED ! TYPE 1 TRIPLES VALUE HAS INDEX INTO SWITCH "TRIPSW" ! TYPE 2 TRIPLES VALUE HAS POINTER TO ISEQS ! %CONSTINTEGERARRAY TRIPDATA(0:199)=0, X'1000070F'{RTHD ROUTINE/BKK HDR}, X'10001043'{RDSPLY MAKE DISPLAY}, X'10000410'{RDAREA INITIALISE DIAGS AREA}, X'10000511'{RDPTR RESET DIAGS PTR}, X'10000312'{RTBAD ERROR XIT FOR FN-MAP}, X'10000113'{RTXIT "%RETURN"}, X'10000314'{XSTOP "%STOP"}, 0(2), X'2000040A'{10 LOGICAL NOT}, X'2000040B'{11 LOGICAL NEGATE}, X'2000040C'{12 FLOAT}, X'2000040D'{13 MODULUS}, X'2000080E'{14 SHORTEN}, X'2000040F'{15 LENGTHEN}, X'20000610'{16 JAM SHORTEN}, X'10000000'{17 ERROR}, 0{18 NULL TRIPLE}, X'20000413'{19 PRELOAD}, X'10000001'{20 UNUSED}, X'10000303'{21 STORE STACKPOINTER}, X'10000602'{22 RESTORE STACK POINTER}, X'10000505'{23 ADVANCE STACK POINTER}, X'10000D04'{24 DECLARE ARRAY}, X'10000301'{25 UPDATE LINE NO}, X'10000906'{26 CHECK ZERO FOR STEP}, X'10000307'{27 FOR PREAMBLE}, X'10000208'{28 FOR POSTAMBLE}, X'1000010E'{29 FOR SECOND PREAMBLE}, X'10000218'{30 PRECALL}, X'10000519'{31 ROUTINE CALL}, X'1000021A'{32 RECOVER FN RESULT}, X'1000021B'{33 RECOVER MAP RESULT}, X'00000000'{34 NOT CURRENTLY USED}, X'1000081D'{35 GETAD GET 32BIT ADDREESS}, X'10000424'{36 RTOI1 INT FN}, X'10000C25'{37 RTOI2 INTPT FN}, X'10000B26'{38 STOI1 TOSTRING FN}, X'1000093D'{39 MNITR FOR %MONITOR}, X'00000000'{40 PPROF PRINT PROFILE IGNORED}, X'1000053F'{41 RTFP TURN RTNAME TO FORMAL}, X'00000000'{42 ON EVENT1 NO CODE AS YET}, X'00000000'{43 ON EVENT2 NO CODE AS YET}, X'10000846'{44 DVSTART FILL IN ELSIZE&ND}, X'10001047'{45 DVEND WORK OUT TOTSIZE ETC}, X'00000000'{46 FOREND noop}, X'00000000'{47 DMASS noop}, X'1000044A'{48 RTOI3 TRUNC function}, 0, X'10000132'{50 UCNOP}, X'10000133'{51 UCB1}, X'10000234'{52 UCB2}, X'10000335'{53 UCB3}, X'10000336'{54 UCW}, X'10000437'{55 UCBW}, 0(3), X'1000063B'{59 UCNAM U-C ACCESS TO NAMES}, 0(68), X'20010414'{128 +}, X'20000415'{129 -}, X'20010416'{130 !!}, X'20010417'{131 !}, X'20010418'{132 *}, X'20000419'{133 //}, X'2000041A'{134 /}, X'2001041B'{135 &}, X'2000041C'{136 >>}, X'2000041D'{137 <<}, X'200A0E1E'{138 **}, X'2001041F'{139 COMP}, X'20000420'{140 DCOMP}, X'200A0A21'{141 VMY}, X'20010422'{142 COMB}, X'200E0623'{143 ASSIGN=}, X'200E0624'{144 ASSIGN<-}, X'200A0E25'{145 ****}, X'20020926'{146 BASE ADJ}, X'200A0527'{147 ARR INDEX}, X'20050428'{148 INDEXED FETCH}, X'200E0629'{149 LOCAL ASSIGN}, X'10000C09'{150 VALIDATE FOR}, X'10000B15'{151 PRE CONCAT}, X'10000A16'{152 COCNCATENEATION}, X'10000C17'{153 IOCP CALL}, X'10000C1C'{154 PARAMETER ASSIGNMENT 1 NORMAL VALUES}, X'1000041F'{155 PARAM ASSNG 2 NORMAL PTRS}, X'10000220'{156 PARAM ASSGN 3 ARRAYS}, X'10000220'{157 ASSGN FORMAL RT-CODE AS 156}, X'10000220'{158 PASS5 TYPE GENERAL NAME}, X'10000445'{159 PASS6 RESULT AREA FOR STR&REC FNS}, X'1000030A'{160 BACK JUMP}, X'1000030B'{161 FORWARD JUMP}, X'1000000C'{162 REMOVE LAB}, X'1000000D'{163 ENTER LABEL}, X'1000FF21'{164 DECLARE SWITCH}, X'10000022'{165 SET SWITCH LABEL TO CA}, X'10000523'{166 GOTO SWITCH LABEL}, X'10000D27'{167 STRING ASS1 GENERAL}, X'10001128'{168 STRING ASS 2 L KNOWN}, X'10000D29'{169 STRING JAM TRANSFER}, X'10000C2A'{170 ARRAY HEAD ASSIGNMENT}, X'10000C2B'{171 PTR ASSIGNMENT}, X'1000052C'{172 MAP RESULT ASSIGNMENT}, X'1000052D'{173 FN RESULT ASSIGNMENT}, X'10000C2E'{174 STRING COMPARISON}, X'10000C2E'{175 STRING DSIDED COMPARISON}, X'10000C2F'{176 PRE RESOLUTION 1}, X'10001230'{177 PRE RESOLUTION 2}, X'10000B31'{178 RESOLUTION PROPER}, X'1000233C'{179 RESOLUTION FINISH ASSN FRAGMNT}, X'00000000'{180 SIGEV SIGNAL EVENT NOT IMPLEMENTED}, X'10000A3E'{181 RECASS WHOLE RECORD ASSIGNMENT}, X'10000A40'{182 ARRAY ADDR INC}, X'10000A41'{183 AHADJ FOR ARRAY MAPPING}, X'10000A42'{184 CREATE TYPE GENERAL PARAMETER}, X'1000081E'{185 GET POINTER FOR PASSING BY NAME}, X'10000444'{186 INDEX STRING FOR CHARNO}, X'2002042A'{187 ZCOMP COMPARE W ZERO}, X'2002022B'{188 CONSTANT LOGICAL SHIFT}, X'2002022B'{189 COSNTANT ARITHMETIC SHIFT}, X'10001048'{190 DV BPAIR ENTER LB,UB &RANGE IN CORRECT FORM}, X'10000449'{191 REG TO STORE OPERATION}, 0(*) %CONSTBYTEINTEGERARRAY FCOMP(0:127)=0(2), IGT(2),ILT(2),INE(2),IEQ(2), IGE(2),ILE(2),0(2), 0(2), ILT(2),IGT(2),INE(2),IEQ(2), ILE(2),IGE(2),0(2), 0(2), JIGT(2),JILT(2),JINE(2),JIEQ(2), JIGE(2),JILE(2),0(2), 0(2), JILT(2),JIGT(2),JINE(2),JIEQ(2), JILE(2),JIGE(2),0(2), 0(2), RGT(2),RLT(2),RNE(2),REQ(2), RGE(2),RLE(2),0(2), 0(2), RLT(2),RGT(2),RNE(2),REQ(2), RLE(2),RGE(2),0(2), 0(2), JRGT(2),JRLT(2),JRNE(2),JREQ(2), JRGE(2),JRLE(2),0(2), 0(2), JRLT(2),JRGT(2),JRNE(2),JREQ(2), JRLE(2),JRGE(2),0(2) ! ! OPCODE FOR ESTACK TO STORE VARIANT OPERATIONS ! ! ! THE FOLLOWING ARRAY HAS INSTRUCTION SEQUENCES FOR THE VARIOUS IMP ! IMP OPERATION PRECCED BY A SWITH LABEL AT WHICH THEY ARE PLANTED ! TOUGH CASES LIKE ** HAS A UNIQUE ONE-OFF SWITCH. ! LOOK UP THE SWITCH LABEL FOR PARAMETER DECODING IN DIFFICULT CASES ! %CONSTINTEGER NISEQS=34 %CONSTBYTEINTEGERARRAY ISEQS(40:4*(3*NISEQS+10)-1)={FIRST INTEGER FORMS} %C 2,INOT,0,0 {10 16 BIT LOGICAL NOT}, 2,INEG,0,0 {11 16 BIT LOGICAL NEGATE}, 12,0,0,0 {12 16 BIT FLOAT TO 64 BIT REAL}, 2,IABS,0,0 {13 16 BIT MODULUS}, 10,0,0,0 {14 SHORTEN 16 BIT TO 16 BIT}, 6,CVTII,0,X'51' {15 LENGTHEN 16 BIT TO 32 BIT}, 21,0,0,0 {16 SHORTEN 16 BIT FOR JAM}, 1,0,0,109 {17 COMPILER ERROR}, 7,0,0,0 {18 NOOP}, 7,0,0,0 {19 PRELOAD}, 2,IADD,0,0 {20 16 BIT ADDITION}, 2,ISUB,0,0 {21 16 BIT SUBTRACTION}, 2,IXOR,0,0 {22 16 BIT NONEQUIVALENCE}, 2,IOR,0,0 {23 16 BIT LOGICAL OR}, 2,IMULT,0,0 {24 16 BIT MULTIPLY}, 2,IDIV,0,0 {25 16 BIT INTEGER DIVIDE}, 1,0,0,109 {26 16 BIT REAL DIVIDE}, 2,IAND,0,0 {27 16 BIT AND}, 2,ISHRL,0,0 {28 16 BIT RIGHT SHIFT}, 2,ISHLL,0,0 {29 16 BIT LEFT SHIFT}, 1,0,0,109 {30 REAL EXP OPERATOR}, 13,0,0,0 {31 COMPARISONS}, 14,0,0,0 {32 FIRST PART OF DOUBLE COMPARISONS}, 15,0,0,0 {33 VMY}, 2,IADD,0,0 {34 COMBINE VMY RESULTS}, 16,0,0,0 {35 ASSIGN}, 16,0,0,0 {36 ASSIGN(<-)}, 17,1,2,20 {37 16 BIT INTEGER EXPONENTIATION}, 18,2,0,0 {38 BASE ADJUST ARRAY 16 BIT INDEX}, 19,2,0,0 {39 ARRAY INDEX 16 BIT INDEX}, 20,0,0,0 {40 INDEXED FETCH 16 BIT INDEX}, 23,0,0,0 {41 LASS}, 24,0,0,0 {42 ZCOMP COMPARISONS W ZERO}, 25,0,0,0 {43 SHIFT BY CONSTANT}, 2,INOT,0,0 {10 32 BIT LOGICAL NOT}, 2,INEG,0,0 {11 32 BIT LOGICAL NEGATE}, 12,0,0,0 {12 32 BIT FLOAT TO 64 BIT REAL}, 2,IABS,0,0 {13 32 BIT MODULUS}, 10,0,0,0 {14 SHORTEN 32 BIT TO 16 BIT}, 1,0,0,109 {15 LENGTHEN 32 BIT TO 64 BIT}, 21,0,0,0 {16 SHORTEN 32 BIT FOR JAM}, 1,0,0,109 {17 COMPILER ERROR}, 7,0,0,0 {18 NOOP}, 7,0,0,0 {19 PRELOAD}, 2,IADD,0,0 {20 32 BIT ADDITION}, 2,ISUB,0,0 {21 32 BIT SUBTRACTION}, 2,IXOR,0,0 {22 32 BIT NONEQUIVALENCE}, 2,IOR,0,0 {23 32 BIT LOGICAL OR}, 2,IMULT,0,0 {24 32 BIT MULTIPLY}, 2,IDIV,0,0 {25 32 BIT INTEGER DIVIDE}, 1,0,0,109 {26 32 BIT REAL DIVIDE}, 2,IAND,0,0 {27 32 BIT AND}, 2,ISHRL,0,0 {28 32 BIT RIGHT SHIFT}, 2,ISHLL,0,0 {29 32 BIT LEFT SHIFT}, 1,0,0,109 {30 REAL EXP OPERATOR}, 13,0,0,0 {31 COMPARISONS}, 14,0,0,0 {32 FIRST PART OF DOUBLE COMPARISONS}, 15,0,0,0 {33 VMY}, 2,IADD,0,0 {34 COMBINE VMY RESULTS}, 16,0,0,0 {35 ASSIGN}, 16,0,0,0 {36 ASSIGN(<-)}, 17,1,2,20 {37 32 BIT INTEGER EXPONENTIATION}, 18,2,0,0 {38 BASE ADJUST ARRAY 32 BIT INDEX}, 19,2,0,0 {39 ARRAY INDEX 32 BIT INDEX}, 20,0,0,0 {40 INDEXED FETCH 32 BIT INDEX}, 23,0,0,0 {41 LASS}, 24,0,0,0 {42 ZCOMP COMPARISONS W ZERO}, 25,0,0,0 {43 SHIFT BY CONSTANT}, 7,0,0,0 {10 REAL LOGICAL NOT}, 5,RNEG>>8,RNEG&255,0 {11 REAL LOGICAL NEGATE}, 1,0,0,109 {12 FLOAT REAL COMPILER ERROR}, 2,RABS,0,0 {13 REAL MODULUS}, 6,CVTRR,0,x'52' {14 SHORTEN REAL}, 6,CVTRR,0,x'62' {15 LENGTHEN REAL TO 64 BIT}, 1,0,0,109 {16 SHORTEN REAL FOR JAM}, 1,0,0,109 {17 COMPILER ERROR}, 7,0,0,0 {18 NOOP}, 7,0,0,0 {19 PRELOAD}, 4,RADD>>8,RADD&255,0 {20 REAL ADDITION}, 4,RSUB>>8,RSUB&255,0 {21 REAL SUBTRACTION}, 7,0,0,0 {22 REAL NONEQUIVALENCE}, 7,0,0,0 {23 REAL LOGICAL OR}, 4,RMULT>>8,RMULT&255,0 {24 REAL MULTIPLY}, 7,0,0,0 {25 REAL INTEGER DIVIDE}, 4,RDIV>>8,RDIV&255,0 {26 REAL REAL DIVIDE}, 7,0,0,0 {27 REAL AND}, 7,0,0,0 {28 REAL LEFT SHIFT}, 7,0,0,0 {29 REAL RIGHT SHIFT}, 22,2,2,21 {30 REAL EXP OPERATOR}, 13,0,0,0 {31 COMPARISONS}, 14,0,0,0 {32 FIRST PART OF DOUBLE COMPARISONS}, 7,0,0,0 {33 VMY}, 7,0,0,0 {34 COMBINE VMY RESULTS}, 16,0,0,0 {35 ASSIGN}, 16,0,0,0 {36 ASSIGN(<-)}, 7,0,0,0 {37 REAL INTEGER EXPONENTIATION}, 7,0,0,0 {38 BASE ADJUST ARRAY REAL INDEX}, 7,0,0,0 {39 ARRAY INDEX REAL INDEX}, 20,0,0,0 {40 INDEXED FETCH REAL INDEX}, 23,0,0,0 {41 LASS}, 24,0,0,0 {42 ZCOMP COMPARISON W ZERO}, 7,0,0,0 {43 SHIFT BY CNST ERROR} %SWITCH SW(0:25),TRIPSW(0:74) ! CURRINF==WORKA_LEVELINF(CURRLEVEL) WORKINGINF==CURRINF FLAG AND FOLD(TRIPLES) %IF PARM_OPT#0; ! ALREADY DONE FOR OPT=0 %IF PARM_DCOMP#0 %THEN PRINT TRIPS(TRIPLES) STPTR=TRIPLES(0)_FLINK %WHILE STPTR>0 %CYCLE CURRT==TRIPLES(STPTR) WTRIPNO=STPTR STPTR=CURRT_FLINK COMM=1 OPND1==CURRT_OPND1 OPND2==CURRT_OPND2 XTRA=CURRT_X1 JJ=CURRT_OPERN TRIPINF=TRIPDATA(JJ) C=TRIPINF>>28; ! TRIPLE TYPE TRIPVAL=TRIPINF&255 %IF C=0 %THENCONTINUE %IF C=1 %THEN ->TRIPSW(TRIPVAL) LRES=0 ! ! CARE IS NEEDED IN DETECTING WHEN OPERANDS ARE REVERSED IN STACK ! %IF JJ>=128 %AND CURRT_FLAGS&(LOADOP1+LOADOP2)=0 %AND 1<=128 %AND CURRT_FLAGS&6=2 %START ! OPERANDS REVERSED IN ESTACK COMM=2 %FINISH %FINISH %IF TRIPINF&X'F0000'=0 %AND COMM=2 %THEN EXCHANGE(OPND2,OPND1) %AND COMM=1 ! I-RS THE WRONG WAY ROUND ! FOR NON COMMUTABLE OPS %UNLESS JJ<128 %OR TRIPINF&X'20000'#0 %THEN LRES=LOAD(OPND2) PTYPE=OPND1_PTYPE&255; TYPE=PTYPE&7 %IF TYPE=2 %THEN C=4*(TRIPVAL+2*NISEQS) %ELSEIF PTYPE=X'51' %THEN %C C=4*(TRIPVAL+NISEQS) %ELSE C=4*TRIPVAL L0=ISEQS(C); B1=ISEQS(C+1) B2=ISEQS(C+2); B3=ISEQS(C+3) ->SW(L0) SW(1): ! ERROR CONDITION TRIPSW(0): FAULT(B3,0,0) %UNLESS TYPE=7 TRIPSW(*): EOP(HALT); ! USEFUL IN DEBUGGING TO HAVE ! ERROR POSITION PINPOINTED ->STRES SW(6): ! PLANT BYTE & SET PTYPE OPND1_PTYPE=B3 ESTKLIT(BYTES(B3>>4)) SW(2): ! PLANT ONE BYTE EOP(B1) OPND1_FLAG=9; ! PREVENT RELOAD IF THIS IS LAST ->STRES SW(3): ! PLANT 2 BYTES EOP(B1); EOP(B2) OPND1_FLAG=9; ! PREVENT RELOAD IF THIS IS LAST ->STRES SW(4): ! PLANT REAL OPERATION SW(5): ! REAL UNARY OPERATION D=B1<<8!B2 EOP(D) OPND1_FLAG=9 ->STRES SW(7): ! NULL OPERATION ->STRES SUSE: ->STRES SW(9): ! INTEGER MODULUS ->SW(1); ! now unused SW(10): ! SHORTEN INTEGER TO BYTE %IF PARM_OPT#0 %START %UNLESS CURRT_CNT=1 %AND TRIPLES(CURRT_PUSE)_OPERN=SHRTN %START %IF CURRT_OPTYPE>X'31' %THENSTART ESTKLIT(-x'8000') ESTKLIT(X'7FFF') %FINISHELSESTART ESTKLIT(0) ESTKLIT(255) %FINISH EOP(CHK) %FINISH %FINISH OPND1_PTYPE=OPND1_PTYPE-X'10' ->SUSE SW(11): ! REAL MODULUS (DIFFICULT) ->SW(1); ! now unused SW(12): ! FLOAT ESTKLIT(8); EOP(CVTIR) OPND1_PTYPE=X'62' OPND1_XB=0 ->SUSE SW(21): ! SHORTEN FOR JAM TRANSFER ! NO CODE NEEDED ON PNX OPND1_PTYPE=OPND1_PTYPE-X'10' ->SUSE SW(22): ! EXP IN REAL EXPRSN %IF OPND2_PTYPE&7=1 %THEN ->PCALL ! REAL**REAL BY SUBROUTINE LRES=LOAD(OPND2) %IF CURRT_FLAGS&LOAD OP1#0 %AND LRES=0 %THEN EOP(EXCH) REXP; ->SUSE SW(17): ! EXP IN INTEGER CONTEXT PCALL: ! CALL SUBROUTINE AS DEFINED ! IN CODE TABLE LRES=LOAD(OPND2) %IF CURRT_FLAGS&LOADOP1#0 %AND LRES=0 %THEN EOP(EXCH) %IF CURRT_OPTYPE&7=1 %THENSTART; ! INTEGERS ISTARSTAR %FINISHELSESTART STARSTAR; ! PLANT COMPLEX IN LINE ROUTINE %FINISH ->SUSE SW(14): ! DSIDED COMPARISONS ! COPY MIDDLE OPERAND(SIZE IN TABLE) GET WSP(D,2) DSTORE(TYPE,EDUPSTORE,BYTES(PTYPE>>4),CURRINF_RBASE,D) OPND2_FLAG=7; OPND2_D=CURRINF_RBASE<<16!D CURRT_FLAGS=CURRT_FLAGS!NOTINREG; ! STORE COPY TO BE USED WORKT==TRIPLES(CURRT_PUSE) WORKT_FLAGS=WORKT_FLAGS!LOADOP1; ! ENSURE ESTACK IS RIGHT WAY ROUND SW(13): ! COMPARISONS BFFLAG=COMM-1; ! NOTE BACKWARDS OR FORWARDS C=XTRA&15+16*BFFLAG %IF TYPE=2 %THEN C=C+64; ! FLOATING COMPARATORS C=FCOMP(C) COMM=2 WORKT==TRIPLES(CURRT_FLINK); ! ON TO FOLLOWING TRIPLE %IF CURRT_OPTYPE=X'51' %OR CURRT_OPTYPE=X'41' %START %IF WORKT_OPERN=FJUMP %OR WORKT_OPERN=BJUMP %THEN %C WORKT_X1=WORKT_X1!X'40' %AND CURRT_OPND1=OPND2 %AND ->STRES %FINISH %IF TYPE=2 %START %IF WORKT_OPERN=FJUMP %OR WORKT_OPERN=BJUMP %THEN %C WORKT_X1=WORKT_X1!x'140' %AND CURRT_OPND1=OPND2 %AND ->STRES %FINISH EOP(C) CURRT_OPND1=OPND2; ! OPND2 IS RESULT ->STRES; ! 2ND OPERAND MAY BE NEEDED IN SW(15): ! SPECIAL MH FOR ARRAY ACCESS C=XTRA>>28; ! CURRENT DIMENSION D=XTRA>>24&15; ! TOTAL NO OF DIMENSIONS VMY ->STRES SW(18): ! BASE ADJUST ARRAY INDEX DPTYPE=XTRA>>16 %UNLESS PARM_COMPILER#0 %OR DPTYPE&X'300'=X'200' %START D=OPND2_D&X'FFFF' %IF OPND2_FLAG=SCONST %START; ! DV KNOWN C=CTABLE(D) C=BYTESWOP(C) ESTKLIT(C) %FINISHELSESTART CHOP OPERAND(OPND2,x'51',0) LRES=LOAD(OPND2) EREFER(0,4) %FINISH EOP(IADD) %FINISH ->STRES SW(19): ! ARRAY INDEX DACC=XTRA>>20 %IF DACC>0 %START; ! NORMAL CASE EL SIZE KNOWN CHOP OPERAND(OPND2,x'51',4); ! array base LRES=LOAD(OPND2) EOP(EXCH) %IF DACC<=1 %THEN EOP(INDEX1) %ELSEIF DACC=2 %THEN EOP(INDEX2) %ELSEIF %C DACC=4 %THEN EOP(INDEX4) %ELSEIF DACC=8 %THEN EOP(INDEX8) %ELSE %C ESTKLIT(DACC) %AND EOP(INDEX) %FINISHELSESTART; ! RARE CASE GO TO DV FOR SIZE ! ONLY FOR ACCESS OF STRING&RECORD ! ARRAYNAMES LRES=LOAD(OPND2); ! full head dvptr on top EREFER(4,2); ! el size halfword out of swopped dv EPROMOTE(3); EOP(EXCH) EOP(INDEX) %FINISH ->STRES SW(20): ! INDEXED FETCH INDLOAD(1,BYTES(PTYPE>>4&7),0) OPND1_PTYPE=OPND1_PTYPE&255 OPND1_FLAG=9 OPND1_XB=0 ->STRES SW(16): ! ASSIGN(=) ! ASSIGN(<-) PT=XTRA&255; ! ORIGINAL PT OF LHS HERE %IF PT=0 %THEN PT=CURRT_OPTYPE %IF OPND1_FLAG=2 %START; ! OPERAND A NAME LRES=LOAD(OPND2) TCELL==ASLIST(TAGS(OPND1_D)) %IF TCELL_PTYPE&X'3FFF'=X'33' %THEN D=RECORDELAD(TCELL,PT,OPND1_XTRA) %ELSE %C D=TCELL_SLINK DSTORE(PT&7,ESTORE,BYTES(PT>>4),TCELL_UIOJ>>4&15,D) %FINISHELSESTART; ! OPERAND A POINTER %IF OPND1_FLAG=INDNAME %START; ! POINTER NOT LOADED LRES=LOAD(OPND2) LOADPTR(OPND1,OPND1) %FINISHELSESTART LOADPTR(OPND1,OPND1) LRES=LOAD(OPND2) %IF LRES>0 %OR (CURRT_FLAGS&LOADOP1=0 %AND COMM=1) %THEN EOP(EXCH) %FINISH INDSTORE(PT&7,BYTES(PT>>4),0) %FINISH ->STRES SW(23): ! LOCAL ASSIGNMENT D=BYTES(PTYPE>>4&15) LRES=LOAD(OPND2) %IF CURRT_PUSE=CURRT_FLINK %AND OPND2_XB=ESTK %THEN EOP(DUPL) DSTORE(PTYPE&7,ESTORE,D,OPND1_D>>16,OPND1_D&X'FFFF') OPND1_FLAG=7; OPND1_XB=OPND2_XB; ! IN CASE USED AGAIN %IF CURRT_PUSE#CURRT_FLINK %THEN CURRT_FLAGS=CURRT_FLAGS!NOTINREG ! FORCE RELOAD FROM STORE IN ALL BUT ! BUT ONE SIMPLE CASE ->STRES SW(24): ! COMPARE WITH ZERO (OPND2=0) WORKT==TRIPLES(CURRT_FLINK); ! NEXT OR JUMP TRIPLE D=WORKT_X1; ! IBM TYPE JUMP MASK BFFLAG=0 %IF TYPE=1 %START; ! INTEGERS WORKT_X1=D!X'60'; ! with zero and compare omitted %FINISHELSESTART WORKT_X1=D!!X'160'; ! with zero(2),comp omitted & real(256) %FINISH ->STRES SW(25): ! SHIFT BY CONSTANT D=OPND2_D %IF CURRT_OPERN=CASHIFT %AND D=-1 %THEN EOP(HALT) %ELSEIF %C D>0 %OR CURRT_OPERN=CLSHIFT %THEN ESTKLIT(D) %AND EOP(ISHLL) %ELSE %C ESTKLIT(D) %AND EOP(ISHLA) ->stres TRIPSW(73): ! OPERATE AND ASSIGN OPERATION ! PRODUCED BY PNX OPT PASS ONLY %BEGIN %CONSTBYTEINTEGERARRAY OOPC(128:135)=IADDST,ISUBST,IXORST,IORST,IMULTST, IDIVST,HALT,IANDST LRES=LOAD(OPND2) LOADAD(OPND1) EOP(EXCH) EOP(OOPC(XTRA)) %END ->STRES TRIPSW(1): ! SET LINE NO ELINESTART(OPND1_D>>16) %IF PARM_LINE#0 %START ESTKLIT(OPND1_D>>16) DSTORE(1,ESTORE,2,CURRINF_RBASE,OPND1_D&X'FFFF') %FINISH %CONTINUE TRIPSW(2): ! RESET STACK PTR TO SAVED VAL DFETCH(1,4,CURRINF_RBASE,OPND1_D) EOP(SFA) EOP(ISUB) EOP(ASF) %CONTINUE TRIPSW(3): ! SAVE STACK POINTER ! OPND1 IS TEMPORARY(16 BITS) FOR SAVE EOP(SFA) DSTORE(1,ESTORE,4,CURRINF_RBASE,OPND1_D) %CONTINUE TRIPSW(70): ! START OF DOPE VECTOR ! OPND1_D=ND<<16!ELSIZE ! OPND1_XTRA=PTYPE<<16!DVDISP D=OPND1_XTRA&X'FFFF' ESTKLIT(OPND1_D) DSTORE(1,ESTORE,4,CURRINF_RBASE,D-4) %CONTINUE TRIPSW(71): ! END OF DOPE VECTOR ! OPND1_D=DVF<<16!ELSIZE ! OPND1_XTRA=PTYPE ! XTRA=ND<<16!DVDISP D=OPND1_D&X'FFFF'; ! ELSIZE %IF D>1 %THEN ESTKLIT(D) %AND EOP(IMULT) DSTORE(1,ESTORE,4,CURRINF_RBASE,XTRA&X'FFFF'-8) ! NOW WORK OUT THE BASE OFFSET USING ! MASK OF NONZERO LBS PASSED IN DVF D=XTRA&X'FFFF'; ! DVDISP C=OPND1_D>>16; ! THE MASK %IF C=0 %THEN ESTKLIT(0) %ELSESTART B1=0 %FOR JJ=1,1,XTRA>>16 %CYCLE %IF C&(1<1 %THENSTART DFETCH(1,4,CURRINF_RBASE,D-12*JJ+4) EOP(IMULT) %FINISH %IF B1>0 %THEN EOP(IADD) B1=B1+1; ! COUNT PRODUCTS %FINISH %REPEAT EOP(INEG) %FINISH DSTORE(1,ESTORE,4,CURRINF_RBASE,D) %CONTINUE TRIPSW(72): ! DV BOUND PAIR ! OPND1&2 ARE LB & UB RESPECTIVLY ! XTRA=CURRD<<24!ND<<16!DVDISP D=XTRA&X'FFFF'-12*(XTRA>>24); ! TRIPLE POSN %IF OPND1_FLAG=SCONST %START; ! LB A CONST ESTKLIT(OPND1_D) DSTORE(1,ESTORE,4,CURRINF_RBASE,D-4) LRES=LOAD(OPND2) DSTORE(1,EDUPSTORE,4,CURRINF_RBASE,D) %IF OPND1_D#1 %THEN ESTKLIT(OPND1_D-1) %AND EOP(ISUB) %FINISHELSESTART LRES=LOAD(OPND1)<<1!LOAD(OPND2) %IF LRES=B'10' %THEN EOP(EXCH) DSTORE(1,EDUPSTORE,4,CURRINF_RBASE,D) EOP(EXCH) DSTORE(1,EDUPSTORE,4,CURRINF_RBASE,D-4) EOP(ISUB); ESTKLIT(1); EOP(IADD) %FINISH C=XTRA>>24&255; ! CURRENT DIMENSION %IF C>1 %START; ! MULTPLY UP BY LOWER RNAGES EOP(IMULT) %FINISH DSTORE(1,EDUPSTORE,4,CURRINF_RBASE,D-8) %CONTINUE TRIPSW(4): ! DECLARE ARRAY ! OPND1_D=CDV<<31!C<<24!D<<16!DVDISP ! OPND1_XTRA HAS DICT ENTRY NO ! dvdisp refers to sst ! sndisp has disp to ctables TCELL==ASLIST(TAGS(OPND1_XTRA)) C=OPND1_D>>24&127 D=OPND1_D>>16&255 ! NO OPTIMISING OF MULTIPLE DECS YET ! HENCE C & D NOT USED %IF OPND1_D>0 %START; ! DYNAMIC DOPE VECTOR DFETCHAD(4,CURRINF_RBASE,OPND1_D&X'FFFF') %FINISHELSESTART; ! DV IN SHAREABLE SYMBOL TABLES ESTKADDR(4,OPND1_D&X'FFFF',0,4) %FINISH DSTORE(1,ESTORE,4,CURRINF_RBASE,TCELL_SLINK+4) %IF TRIPLES(STPTR)_OPERN=ASPTR %START; ! IF ARRAY NOT FORMAT %IF OPND1_D<0 %START; ! ARRAY SIZE KNOWN C=CTABLE(TCELL_SNDISP+2) C=BYTESWOP(C) C=(C+3)&(-4); ! TO 64 BIT BNDRY ESTKLIT(-C) EOP(ASF) %FINISHELSESTART; ! DYNAMIC NEEDS LOOP ! DFETCH(1,4,CURRINF_RBASE,OPND1_D&X'FFFF'-8) ESTKLIT(3); EOP(IADD) ESTKLIT(-4) EOP(IAND); EOP(INEG); EOP(ASF) %FINISH %FINISH EOP(SFA); ! STACK FRONT ADDRESS=BASE ADDRESS DSTORE(1,ESTORE,4,CURRINF_RBASE,TCELL_SLINK) %CONTINUE TRIPSW(5): ! CLAIM ARRAY SPACE ! OPND1_D=CDV<<31!SNDISP!DVDISP ! NOT NEEDED ON PNX AS THIS MUST ! BE DONE DURING DECLN(SEE ABOVE) %CONTINUE TRIPSW(6): ! CHECK FOR ZERO FOR STEP LRES=LOAD(OPND1); ! STEP TO ESTACK PPJ(JINTZ,11); ! USING ZERO=FALSE EQUIVALENCE %CONTINUE TRIPSW(7): ! FOR PREAMBLE LRES=LOAD(OPND1); ! FORCE INITIAL TO ESTACK WORKT==TRIPLES(CURRT_FLINK) WORKT==TRIPLES(WORKT_FLINK) %WHILE WORKT_OPERN#VASS TOPND=WORKT_OPND1; ! control var name TCELL==ASLIST(TAGS(TOPND_D)) %IF TOPND_FLAG=INDNAME %START DFETCH(1,4,TCELL_UIOJ>>4&15,TCELL_SLINK) INDSTORE(1,4,0) %FINISHELSE DSTORE(1,ESTORE,4,TCELL_UIOJ>>4&15,TCELL_SLINK) %CONTINUE TRIPSW(8): ! FOR POSTAMBLE %CONTINUE TRIPSW(9): ! VALIDATE FOR LRES=LOAD(OPND1) LRES=LOAD(OPND2) EOP(IREM) PPJ(JINTNZ,11); ! USING ZERO=FALSE EQIVALENCE %CONTINUE TRIPSW(10): ! BACK JUMP _X1 HAS TF&MASK ! OPND1_XTRA HAS LABEL CELL LCELL==ASLIST(OPND1_XTRA) D=XTRA; ! THE MASK EJUMP(JCODE(D),OPND1_D&X'FFFF') %CONTINUE TRIPSW(11): ! FORWARD JUMP _X1 HAS TF&MASK ! OPND1_XTRA HAS LABEL CELL<<16!JUMP CELL LCELL==ASLIST(OPND1_XTRA>>16) C=JCODE(XTRA) EJUMP(C,OPND1_D&X'FFFF') D=OPND1_D>>24; ! ENTER JUMP FLAGS %IF D&2#0 %START; ! ENVIRONMENT MANIPULATION ! no environments in this machine %FINISH %CONTINUE TRIPSW(12): ! REMOVE LABEL %BEGIN %INTEGER S1,S2,S3 %INTEGERNAME CELL CELL==CURRINF_LABEL %WHILE CELL>0 %CYCLE %IF ASLIST(CELL)_S3=OPND1_D %THEN POP(CELL,S1,S2,S3) %ANDEXIT CELL==ASLIST(CELL)_LINK %REPEAT EDISCARDLABEL(OPND1_D) %END %CONTINUE TRIPSW(13): ! INSERT LABEL ! OPND1_XTRA HAS LABEL CELL LCELL==ASLIST(OPND1_XTRA) D=LCELL_S2&X'FFFF'; ! JUMP LIST REDUNDANT ON PNX %WHILE D#0 %CYCLE; ! FILL FORWARD REFS POP(D,B1,B2,B3); ! B2=1 IF SHORT JUMP PLANTED %REPEAT ELABEL(OPND1_D&X'FFFF') D=OPND1_D>>24; ! ENVIRONMENT MANIPULATION FLAGS ! no environments in this machine LCELL_S2=0; ! NO JUMPLIST&NO ENVIRONMENT %CONTINUE TRIPSW(14): ! FOR 2ND PREAMBLE ! MAY BE UNNECESSARY WORKT==TRIPLES(CURRT_FLINK) WORKT==TRIPLES(WORKT_FLINK) %WHILE WORKT_OPERN#VASS TOPND=WORKT_OPND1; ! control var name OPND1=TOPND WORKT==TRIPLES(CURRT_PUSE) WORKT_FLAGS=WORKT_FLAGS!LOADOP1 CURRT_FLAGS=CURRT_FLAGS!NOTINREG %CONTINUE TRIPSW(15): ! RT HEADING OPND1_D=RTNAME ! OPND1_XTRA=AXNAME #0 IF AN ENTRY %BEGIN %INTEGER H,PCHKWORD H=0; PCHKWORD=0 CURRINF_ENTRYAD=GLABEL; ! FOR RETURN=JUMP TO END GLABEL=GLABEL+1 %IF OPND1_D>=0 %THENSTART C=0 TCELL==ASLIST(TAGS(OPND1_D)) PCHKWORD=TCELL_SLINK %IF PCHKWORD>0 %THEN PCHKWORD=ASLIST(PCHKWORD)_S3; ! size<<16!num H=TCELL_SNDISP %FINISHELSE C=1 %IF H=0 %THEN H=-1 %IF OPND1_XTRA#0 %THEN %C EPROC(STRING(OPND1_XTRA),CURRINF_RBASE<<16!C<<1!1,PCHKWORD&x'fff',PCHKWORD>>16, ADDR(WORKA_N),H) %ELSEIF OPND1_D>=0 %THEN %C EPROC(STRING(ADDR(WORKA_LETT(WORKA_WORD(OPND1_D)))),CURRINF_RBASE<<16, PCHKWORD&x'fff',PCHKWORD>>16,ADDR(WORKA_N),H) %IF OPND1_D>=0 %THEN TCELL_SNDISP=H %END %CONTINUE TRIPSW(67): ! RDISPLY CREATE DISPLAY D=CURRINF_RBASE %CONTINUE TRIPSW(16): ! RDAREA - INITIALISE DAIGS AREA ! OPND1_D=N FOR DIAGS AREA ESTKDIR(2,32,0,4); ! PICK UP M'IDIA' DSTORE(1,ESTORE,4,CURRINF_RBASE,OPND1_D) %CONTINUE TRIPSW(17): ! RDPTR SET DAIGS POINTER ! OPND1_D=LEVEL NOT CURRINF ALWAYS LINF==WORKA_LEVELINF(OPND1_D) D=ESTKMARKER ! BUT <16BITS OPTIMISED ! PUSH(LINF_RAL,1,D,0); ! TO OVERWRITE LATER DSTORE(1,ESTORE,2,LINF_RBASE,LINF_DIAGINF) %CONTINUE TRIPSW(18): ! RTBAD FN-MAP ERROR EXIT WORKT==TRIPLES(CURRT_BLINK); ! PREVIOUS TRIPLE %CONTINUEIF WORKT_OPERN=RTXIT %OR WORKT_OPERN=XSTOP %OR (WORKT_OPERN=BJUMP %AND %C WORKT_X1&15=15) %IF PARM_OPT#0 %THENSTART EPRECALL(WORKA_PLABS(2)) ESTKLIT(21) EOP(PUSHVAL) ESTKLIT(0) EOP(PUSHVAL) PPJ(0,2) %FINISH %CONTINUE TRIPSW(19): ! RTXIT - "%RETURN" %IF OPND1_D=0 %START; ! JUMP TO END FOR RETURNS PROTEM ! TILL REGISTER RESTORING SOLVED EJUMP(JUMP,CURRINF_ENTRYAD) %FINISHELSESTART ELABEL(CURRINF_ENTRYAD); ! ENTRAD HOLDS LAB FOR RETURN EOP(RETURN) EPROCEND(CURRINF_SNMAX-CURRINF_DISPLAY,0,ADDR(WORKA_N)) %FINISH %CONTINUE TRIPSW(20): ! XSTOP - "%STOP" CALL STOP %IF OPND1_D#0 %THEN EPROCEND(CURRINF_SNMAX-CURRINF_DISPLAY,0,ADDR(WORKA_N)) %CONTINUE TRIPSW(61): ! %MONITOR EPRECALL(WORKA_PLABS(2)) ESTKLIT(0) EOP(PUSHVAL) ESTKLIT(0) EOP(PUSHVAL) PPJ(0,2) %CONTINUE !*********************************************************************** !* SECTION FOR STRING CONCATENATION AND ASSIGNMENT * !*********************************************************************** TRIPSW(21): ! PRECONCAT ! OPND1 IS WORK AREA ! OPND2 HAS FIRST STRING LRES=LOAD(OPND2); ! 32 BIT AD OF STRING2 EOP(DUPL); EREFER(0,1) LRES=LOAD(OPND1) EOP(EXCH); ESTKLIT(1); EOP(IADD) EOP(MVB) OPND1_FLAG=7; ! RESULT IS LOCAL %CONTINUE TRIPSW(22): ! CONCATENATE OPND1 WORK AREA ! OPND2 THE NEXT BIT OPND1=TRIPLES(OPND1_D)_OPND1 %WHILE OPND1_FLAG=REFTRIP LRES=LOAD(OPND2) EPRECALL(WORKA_PLABS(24)) EOP(PUSHVAL) LRES=LOAD(OPND1) EOP(PUSHVAL) PPJ(0,24) OPND1_FLAG=7; ! RESULT IS LOCAL %CONTINUE TRIPSW(39): ! GENERAL STRING ASSIGN LRES=LOAD(OPND1); ! PTR (2 WORDS) TO LHS %IF OPND2_FLAG=LCONST %THENSTART; ! CONST STRING ASSN %IF OPND2_XTRA=0 %START; ! CONST IS NULL EOP(DISCARD); ESTKLIT(0); EOP(EXCH); EREFER(0,2); EOP(ESTORE) %FINISHELSESTART %IF PARM_OPT#0 %THEN EOP(EXCH) %ELSE EOP(DISCARD) LRES=LOAD(OPND2) EOP(EXCH) ESTKLIT(OPND2_XTRA+1) EOP(MVB) %IF PARM_OPT#0 %START ESTKLIT(OPND2_XTRA) PPJ(JILT,9) %FINISH %FINISH %FINISHELSESTART GET WSP(D,1); ! temporary %IF CURRT_FLAGS&LOADOP2=0 %START; ! RHS(OP 2) FN OR MAP DSTORE(1,ESTORE,4,CURRINF_RBASE,D) %FINISH %IF PARM_OPT#0 %THEN EOP(EXCH) %ELSE EOP(DISCARD) ! MAX LEN TO BTM FOR CHK OR DISCARDED %IF CURRT_FLAGS&LOADOP2=0 %THEN %C DFETCH(1,4,CURRINF_RBASE,D) { retrieve temp} %ELSESTART LRES=LOAD(OPND2) DSTORE(1,EDUPSTORE,4,CURRINF_RBASE,D); ! SOURCE BYTE ADDRE TO REG %FINISH EOP(EXCH); ! DEST OVER SOURCE FOR MVB DFETCH(1,4,CURRINF_RBASE,D); ! FURTHER COPY OF SOURCE EREFER(0,1) %IF PARM_OPT#0 %THENSTART GET WSP(TEMPLOC,1); ! extra temporary reuse confuses ecode rts DSTORE(1,EDUPSTORE,4,CURRINF_RBASE,TEMPLOC) %FINISH ESTKLIT(1); EOP(IADD); ! ASSIGN EOP(MVB) %IF PARM_OPT#0 %START; ! CHECK LENGTH DFETCH(1,4,CURRINF_RBASE,TEMPLOC); ! RETRIEVE CURRENT LENGTH PPJ(JILT,9) %FINISH %FINISH %CONTINUE TRIPSW(40): ! SIMPLE STRING ASSIGN ! LHS A SIMPLE STRING TCELL==ASLIST(TAGS(OPND1_D)) %IF OPND2_FLAG=LCONST %AND OPND2_XTRA>4&15,D&X'FFFF') EREFER(0,2); EOP(ESTORE) %FINISHELSESTART; ! ASSIGN CONSTANT STRING LRES=LOAD(OPND2) LRES=LOAD(OPND1) ESTKLIT(OPND2_XTRA+1) EOP(MVB) %FINISH %CONTINUE %FINISH LRES=LOAD(OPND2) EOP(DUPL); LRES=LOAD(OPND1) EOP(EXCH); EREFER(0,1); ! LENGTH OF RHS %IF PARM_OPT#0 %and tcell_acc<256 %START ESTKLIT(0) ESTKLIT(TCELL_ACC-1); ! LMAX EOP(CHK) %FINISH ESTKLIT(1) EOP(IADD) EOP(MVB) %CONTINUE TRIPSW(41): ! STRING JT VIA SUBROUTINE EPRECALL(WORKA_PLABS(18)) LRES=LOAD(OPND1); ! SET BY GETPTR (IE LOADED) LRES=LRES<<1!LOAD(OPND2); ! MAY OR MAY NOT NEED LOADING %IF LRES=B'10' %THEN EPROMOTE(3) EOP(PUSHVAL); EOP(PUSHVAL) EOP(PUSHVAL) PPJ(0,18) %CONTINUE TRIPSW(46): ! STRING COMPARISONS INCL DSIDED BFFLAG=0 %IF OPND2_FLAG=LCONST %AND OPND2_XTRA=0 %THEN OPND==OPND1 %AND ->NULLSC %IF OPND1_FLAG=LCONST %AND OPND1_XTRA=0 %THEN OPND==OPND2 %AND BFFLAG=1 %AND ->NULLSC %IF CURRT_FLAGS&LOADOP2#0 %START; ! OPND2 NOT LOADED LRES=LOAD(OPND1) LRES=LOAD(OPND2) %FINISHELSEIF CURRT_FLAGS&LOADOP1=0 %START; ! BOTH LOADED %FINISHELSESTART; ! ONLY 2 LDED BACK COMP BFFLAG=1 LRES=LOAD(OPND1) %FINISH D=FCOMP(XTRA+16*BFFLAG) %IF D=IEQ %OR D=INE %START; ! COMMON CASES IN LINE EOP(DUPL) EREFER(0,1) ESTKLIT(1) EOP(IADD) D=D+CPBEQ-IEQ %FINISHELSESTART EPRECALL(WORKA_PLABS(28)) EOP(PUSHVAL); EOP(PUSHVAL) PPJ(0,28) ESTKLIT(0); ! RETURNED AS DIFFERENCE FROM ZERO %FINISH EOP(D) %CONTINUE NULLSC: ! TEST FOR A NULL STRING LRES=LOAD(OPND) EREFER(0,1); ESTKLIT(0); EOP(FCOMP(XTRA+16*BFFLAG)) %CONTINUE TRIPSW(47): ! PRE RESOLUTION 1 ! OPND1 IS 4 WORD WK AREA ! OPND2 IS STRING BEING RESLVD ! IN PNX WORK AREA IS USED AS FOLLOWS ! W1 WORD ADDRESS OF STRING BEING RESOLVED ! W2 ORIGINAL LENGTH! BYTES USED<<16 ! W3&4 WORKSPACE D=OPND1_D&X'FFFF' LRES=LOAD(OPND2); ! 32 BIT ADDRESS TO ESTACK DSTORE(1,EDUPSTORE,4,CURRINF_RBASE,D); ! 32 BIT ADDR TO WK AREA EREFER(0,1) DSTORE(1,ESTORE,4,CURRINF_RBASE,D+4); ! WHOLE LENGTH STILL AVAILABLE ! 0 BYTES USED UP SO FAR %CONTINUE TRIPSW(48): ! PRE RESOLUTION 2 ! OPND1 IS 4 WORD WK AREA ! OPND2 IS POINTER TO STRING TO HOLD ! FRAGMENT OR ZERO(=DISCARD FRGMNT) D=OPND1_D&X'FFFF' EPRECALL(WORKA_PLABS(16)) DFETCHAD(4,CURRINF_RBASE,D+4) DFETCH(1,4,CURRINF_RBASE,D) EOP(PUSHVAL); ! RESLN STRING ADDR STACKED EOP(PUSHVAL); ! POINTER TO BYTES USED IS STCKD %IF OPND2_FLAG=SCONST %START; ! NO STRING FOR FRAGMENT ESTKLIT(0); ESTKLIT(0); ! TWO ZERO WORD %FINISHELSE LRES=LOAD(OPND2); ! OR 2 POINTER WORDS EOP(PUSHVAL); EOP(PUSHVAL); ! ARE STACKED %CONTINUE TRIPSW(49): ! RESOLUTION ! OPND1 IS STRING RES EXPR ! OPND2 IS LABEL NO LRES=LOAD(OPND1) EOP(PUSHVAL) PPJ(0,16) %IF OPND2_D=0 %THEN PPJ(JINTZ,12); ! UNCONDITIONAL FAILS ! NDAIG PARAMETER LEFT BY SUBROUITNE %CONTINUE TRIPSW(60): ! RESFN FINAL POST RES ASSIGN ! OPND2 HAS POINTER ! SINCE RESOLVED STRING MAY BE CONST ! CAN NOT USE NORMAL ASSIGN LRES=LOAD(OPND2); ! POINTER TO NEST D=OPND1_D&X'FFFF'; ! TO 4 WORD WK AREA %IF PARM_OPT#0 %THEN EOP(EXCH) %ELSE EOP(DISCARD) ! MAX LEN TO BTM FOR CHK OR DISCARDED EOP(DUPL); ! DEST(TWICE) OVER LMAX DFETCH(1,4,CURRINF_RBASE,D) DFETCH(1,4,CURRINF_RBASE,D+4) GET WSP(C,1) ESTKLIT(16); EOP(ISHRL); ! BYTES USED DSTORE(1,EDUPSTORE,4,CURRINF_RBASE,C) EOP(IADD) EOP(EXCH) DFETCH(1,4,CURRINF_RBASE,D+4) ESTKLIT(x'ffff') EOP(IAND) DFETCH(1,4,CURRINF_RBASE,C); ! feth back bytes used EOP(ISUB); ! and subtract from orig DSTORE(1,EDUPSTORE,4,CURRINF_RBASE,C) ESTKLIT(1); EOP(IADD) EOP(MVB); ! call move overlapping DFETCH(1,4,CURRINF_RBASE,C); EOP(EXCH); EREFER(0,1); EOP(ESTORE); ! store length using 2nd copy of dest %IF PARM_OPT#0 %START DFETCH(1,4,CURRINF_RBASE,C) PPJ(JILT,9); ! capacity exceeded %FINISH %CONTINUE TRIPSW(68): ! sindx index string for charno ! on all m-cs with consistent byte addressing ! this is the same as aindx LRES=LOAD(OPND1); ! the base address of string %IF CURRT_FLAGS&LOADOP2#0 %START; ! offset needs loading %UNLESS OPND2_FLAG=SCONST %AND OPND2_D=0 %START; ! LENGTH = 0 OFFSET LRES=LOAD(OPND2) EOP(IADD) %FINISH %FINISHELSE EOP(EXCH) %AND EOP(IADD) CURRT_OPTYPE=X'51'; ! 32 BIT ADDRESS MAY NEED SAVING ->STRES !*********************************************************************** !* THIS NEXT SECTION DEALS WITH ROUTINE CALLS AND PARAMETER * !* PASSING. ALSO STORING AND RECOVERY OF FN & MAP RESULTS * !*********************************************************************** TRIPSW(23): ! IOCP CALL LRES=LOAD(OPND2) CIOCP(OPND1_D); ! ALWAYS CONSTANTS OPND1_FLAG=9; ! FOR WHEN RES NEEDED OPND1_XB=ESTK %CONTINUE TRIPSW(24): ! PRECALL OPND1 HAS RT NAME TCELL==ASLIST(TAGS(OPND1_D)) %IF TCELL_SNDISP=0 %and tcell_ptype&x'400'=0{not formal} %THEN TCELL_SNDISP=ENEXTPROC D=TCELL_SLINK %IF D#0 %THEN D=ASLIST(D)_SNDISP; ! FIRST PARAM OFFSET PTYPE=TCELL_PTYPE C=(CURRT_DPTH+1)>>1; ! DEPTH IN PAIRS D=0 %IF C>0 %THENSTART GET WSP(C,4) C=CURRINF_DISPLAY-(C+16) ESAVE(C,D) %FINISH PUSH(FPHEAD,FPPTR,C,D) EPRECALL(TCELL_SNDISP) FPPTR=0 %CONTINUE TRIPSW(25): ! ROUTINE CALL (AFTER PARAMS) ! OPND1 HAS RT NAME TCELL==ASLIST(TAGS(OPND1_D)) JJ=0 %IF TCELL_SLINK#0 %THEN JJ=ASLIST(TCELL_SLINK)_S3&255 {n params} %IF TCELL_UIOJ&15=14 %START; ! EXTERNAL CALL ECALL(TCELL_SNDISP,JJ,FPPTR) %FINISHELSEIF TCELL_PTYPE&X'400'#0 %START fetch low ad end(tcell_uioj>>4&15,tcell_sndisp);! proc addr fetch high ad end(tcell_uioj>>4&15,tcell_sndisp);! env ESTKLIT(FPPTR) EOP(ARGPROC); ! CALL FORMAL PROCEDURE %FINISHELSESTART C=TCELL_UIOJ>>4&15 ! %IF C>0 %THEN PI1(ILL,-4*(C+1));! DISPLAY PTR FOR INTERNAL RTS D=TCELL_SNDISP ECALL(D,JJ,FPPTR) %FINISH POP(FPHEAD,FPPTR,STACKATCALL,SKEY) !the estack restore is done after recovering ! the fn or map result. there is never anything ! in the estack for routine call %CONTINUE TRIPSW(44): ! MAP RESULT ASSIGNMENT ! CALLED BEFORE RETURN TO CALLER LRES=LOAD(OPND2) EOP(EINTRES) %CONTINUE TRIPSW(45): ! FN RESULT ASSIGNMENT ! CALLED BEFORE RETURN TO CALLER LRES=LOAD(OPND2) %IF OPND2_PTYPE&7=5 %START; ! STRING FN RESULTS EOP(DUPL); EREFER(0,1) ESTKPAR(1,4*2,0,4); EOP(EXCH) ESTKLIT(1); EOP(IADD); EOP(MVB) ESTKPAR(1,4*2,0,4); ! THE "RESULT" EOP(EINTRES) %CONTINUE %FINISH %UNLESS OPND2_PTYPE&7=2 %THEN EOP(EINTRES) %ELSE EOP(EREALRES) %CONTINUE TRIPSW(26): ! RECOVER FN RESULT ! CALLED AFTER RETURN TO CALLER OPND1_FLAG=9; OPND1_XB=ESTK ESTKRESULT(0,OPND1_PTYPE&7,BYTES(OPND1_PTYPE>>4&15)) %IF STACKATCALL#0 %THEN ERESTORE(STACKATCALL,SKEY,1) %CONTINUE TRIPSW(27): ! RECOVER MAP RESULT ! CALLED AFTER RETURN TO CALLER OPND1_FLAG=9 OPND1_XB=ESTK ESTKRESULT(0,1,4) %IF STACKATCALL#0 %THEN ERESTORE(STACKATCALL,SKEY,1) %CONTINUE TRIPSW(28): ! PASS PARAMETER(1)= NORMAL VALUE LCELL==ASLIST(OPND1_XTRA&X'FFFF'); ! PARAM DESCTR CELL D=LCELL_ACC; ! PARAM_ACC %IF OPND1_PTYPE&7=5 %START; ! STRINGS BY VALUE - LABORIOUS C=(D+3)&(-4); ! PNX WORDS FOR STRING VALUE ESTKLIT(-C); EOP(ASF) FPPTR=FPPTR+C LRES=LOAD(OPND2); ! PTR TO STRING %IF C<=32 %START; ! SHORT STRINGS EOP(SFA) ESTKLIT(C) %FINISHELSESTART; ! LONG STRINGS COMPUTE MOVE SIZE EOP(DUPL); EREFER(0,1); ESTKLIT(1) EOP(IADD); EOP(SFA); EOP(EXCH) %FINISH EOP(MVB) %IF PARM_OPT#0 %and d<256 %START EOP(SFA); EREFER(0,1); ! LENGTH FROM DEST estklit(0) ESTKLIT(D-1); ! FOR ASSNMNT CHECK eop(chk) eop(discard) %FINISH %FINISHELSEIF OPND1_PTYPE&7=3 %START; ! RECORD BY VALUE C=(D+3)&(-4) %IF OPND2_FLAG=SCONST %THEN D=0 %ELSE D=1 %AND LRES=LOAD(OPND2) ESTKLIT(-C); EOP(ASF) EOP(SFA) BULKM(D,C,0) FPPTR=FPPTR+C %FINISHELSESTART LRES=LOAD(OPND2) C=OPND1_PTYPE %IF C=X'62' %THENSTART EOP(PUSHVAL) FPPTR=FPPTR+8 %FINISHELSEIF C=X'52' %THENSTART EOP(PUSHVAL) FPPTR=FPPTR+4 %FINISHELSESTART %IF C=X'31' %THEN ESTKLIT(24) %AND EOP(ISHLL) %IF C=X'41' %THEN ESTKLIT(16) %AND EOP(ISHLL) EOP(PUSHVAL) FPPTR=FPPTR+4 %FINISH %FINISH %CONTINUE TRIPSW(29): ! GET 32 BIT ADDRESS LOADAD(OPND1) ->STRES %CONTINUE TRIPSW(30): ! GET POINTER FOR %NAME LOADPTR(OPND1,OPND2) ->STRES %CONTINUE TRIPSW(31): ! PARAM PASSING (2) NORMAL PTRS LRES=LOAD(OPND2) PTYPE=OPND1_PTYPE&255; ! FOR PARAM %IF PTYPE=X'35' %START; ! STRING(2 WORD) PTRS FPPTR=FPPTR+4 EOP(EXCH); EOP(PUSHVAL) %FINISH EOP(PUSHVAL) FPPTR=FPPTR+4 %CONTINUE TRIPSW(32): ! PARAM PASSING(3) ARRAYS ! ALSO (4) PASS RT PARAM SAME CODE LRES=LOAD(OPND2) EOP(EXCH) %if params bwards=yes EOP(PUSHVAL); EOP(PUSHVAL) FPPTR=FPPTR+8 %CONTINUE TRIPSW(69): ! PASS 6 STORE STR FN RES PTR ! OPND2_D HAS OFFSET ESTKLIT(255) ESTKLIT(4); EOP(CVTII); ! as 4 byte integer LRES=LOAD(OPND2) EOP(PUSHVAL); EOP(PUSHVAL) FPPTR=FPPTR+8 %CONTINUE TRIPSW(63): ! RTFP TURN RTNAME INTO FORMAL TCELL==ASLIST(TAGS(OPND1_D)) %IF TCELL_PTYPE&X'400'#0 %START; ! NAM>0 PASS A FORMAL fetch low ad end(tcell_uioj>>4&15,tcell_sndisp);! proc addr fetch high ad end(tcell_uioj>>4&15,tcell_sndisp);! env %FINISHELSESTART C=TCELL_UIOJ>>4&15 D=TCELL_SNDISP %IF D=0 %THEN D=ENEXT PROC %AND TCELL_SNDISP=D eprocref(d,c); ! This puts env over entry address eop(exch); ! On Unix stacks push env first ! Normal stacks push addr first ! Note there may be a further exch at tripsw(32) %FINISH %CONTINUE TRIPSW(66): ! TYPE GENERAL PARAMETER ! OPND1 THE ACTUAL ! OPND2 HAS PTYPE&ACC %IF OPND1_FLAG=DNAME %AND OPND1_PTYPE&15=0 %START TCELL==ASLIST(TAGS(OPND1_D)) DFETCH(1,8,TCELL_UIOJ>>4&15,TCELL_SNDISP) %FINISHELSESTART LRES=LOAD(OPND1); ! 32 BIT ADDRESS ESTKLIT(OPND2_D) EOP(EXCH) %FINISH %CONTINUE !*********************************************************************** !* SECTION TO DEAL WITH SWITCHES INCLUDING ->SW(EXP) * !*********************************************************************** TRIPSW(33): ! DECLARE SWITCH OPND2 HAS BNDS TCELL==ASLIST(TAGS(OPND1_D)) TCELL_SNDISP=GLABEL; ! LABEL FOR SWITCH REFS ESWITCH(OPND2_D,OPND2_XTRA,GLABEL,GLABEL+1,CAS(4)) ELABEL(GLABEL+1) GLABEL=GLABEL+2 %IF PARM_OPT#0 %THENSTART EPRECALL(WORKA_PLABS(2)) ESTKLIT(X'802') ESTKLIT(0) EOP(PUSHVAL) EOP(PUSHVAL) PPJ(0,2) %FINISH ! ERROR EXIT AFTER TABLE %CONTINUE TRIPSW(34): ! SET SWITCH LABEL(OPND2) TCELL==ASLIST(TAGS(OPND1_D)) LCELL==ASLIST(TCELL_SLINK); ! SIDECHAIN HAS TDISP LB&UB ESWITCHENTRY(TCELL_SNDISP,OPND2_D); ! REFS REL TO ACTUAL START %CONTINUE TRIPSW(35): ! GOTO SW LABEL TCELL==ASLIST(TAGS(OPND1_D)) LCELL==ASLIST(TCELL_SLINK) C=LCELL_S2; ! ADJUST TO START OF 0 LRES=LOAD(OPND2) ESWITCHJUMP(TCELL_SNDISP); ! JUMP TO INDEXED JUMP %CONTINUE TRIPSW(37): ! REAL TO INTGER INTPT(OPND1) LRES=LOAD(OPND1) ESTKLIT(4) EOP(EFLOOR) OPND1_XB=0 OPND1_PTYPE=x'51' %CONTINUE TRIPSW(36): ! REAL TO INTEGER AS INT LRES=LOAD(OPND1) ESTKLIT(4); EOP(RNDRI) OPND1_XB=0 OPND1_PTYPE=X'51' %CONTINUE TRIPSW(74): ! REAL to INT as TRunc LRES=LOAD(OPND1) ESTKLIT(4) EOP(TNCRI) OPND1_XB=0 OPND1_PTYPE=x'51' %CONTINUE TRIPSW(38): ! INTEGER TO STRING AS TOSTRING GET WSP(D,1) LRES=LOAD(OPND1) DSTORE(1,ESTORE,1,CURRINF_RBASE,D+2) ESTKLIT(1) DSTORE(1,ESTORE,1,CURRINF_RBASE,D+3) OPND1_FLAG=LOCALIR OPND1_PTYPE=X'35' OPND1_D=CURRINF_RBASE<<16!D OPND1_XTRA=4; ! LENGTH OF TEMP SPACE %CONTINUE TRIPSW(42): ! ARRAYHEAD ASSIGNMENT OPND2_PTYPE=X'61'; ! SO LOAD LOADS HEAD NOT ELEMNT %IF OPND1_FLAG=DNAME %START; ! LHS IN LOCAL SPACE LRES=LOAD(OPND2) TCELL==ASLIST(TAGS(OPND1_D)) C=TCELL_SLINK %IF TCELL_PTYPE&X'3FFF'=X'33' %THEN C=RECORDELAD(TCELL,OPND1_PTYPE,OPND1_XTRA) DSTORE(1,ESTORE,8,TCELL_UIOJ>>4&15,C) %FINISHELSESTART IMPABORT %UNLESS OPND1_FLAG=INDIRECT %OR OPND1_FLAG=REFTRIP %OR %C OPND1_FLAG=INDNAME %OR PARM_FAULTY#0 LRES=LOAD(OPND2) %IF OPND1_FLAG=REFTRIP %OR OPND1_FLAG=INDIRECT %THEN EPROMOTE(3) %IF OPND1_FLAG=INDIRECT %AND OPND1_XTRA>0 %START ESTKLIT(OPND1_XTRA) EOP(IADD) %FINISH %IF OPND1_FLAG=INDNAME %THEN LOADAD(OPND1) INDSTORE(1,8,0) %FINISH %CONTINUE TRIPSW(43): ! POINTER ASSIGNMENT D=BYTES(CURRT_OPTYPE>>4) LRES=LOAD(OPND2) %IF OPND1_FLAG=DNAME %START; ! LOCAL PTR TCELL==ASLIST(TAGS(OPND1_D)) C=TCELL_SLINK %IF TCELL_PTYPE&X'3FFF'=X'33' %THEN C=RECORDELAD(TCELL,OPND1_PTYPE,OPND1_XTRA) DSTORE(1,ESTORE,D,TCELL_UIOJ>>4&15,C) %CONTINUE %FINISH %IF OPND1_FLAG=INDNAME %THEN LOADAD(OPND1) %else %Start %UNLESS CURRT_FLAGS&LOADOP1=0 %START; ! DEST NOT LOADED LRES=LOAD(OPND1) %FINISHELSEIF D=4 %THEN EOP(EXCH) %ELSESTART EPROMOTE(3) %FINISH %IF OPND1_FLAG=INDIRECT %AND OPND1_XTRA>0 %THEN ESTKLIT(OPND1_XTRA) %AND EOP(IADD) %finish INDSTORE(1,D,0) %CONTINUE TRIPSW(62): ! RECORD ASSIGNMENT %IF OPND2_FLAG=SCONST %THENSTART LRES=LOAD(OPND1) BULKM(0,XTRA,OPND2_D) %CONTINUE %FINISH LRES=LOAD(OPND2) %IF CURRT_FLAGS&LOAD OP1=0 %THEN EXCHANGE(OPND1,OPND2) LRES=LOAD(OPND1) BULKM(1,XTRA,0) %CONTINUE TRIPSW(64): ! AAINC INCREMENT RECORD RELATIVE ! ARRAY ACCESS BY RECORD BASE(OPND1) ! TO GIVE ABSOLUTE ACCESS. LRES=LOAD(OPND1) LRES=LOAD(OPND2); ! THE RELATIVE ACCESS EOP(IADD); ! ADDITION ->STRES TRIPSW(65): ! AHADJ ARRAY MAPPING OPND1 1 ! HAS ADJUSTMENT OPND2 THE HEAD ! ARRAY PTYPE<<4!MODE IS IN XTRA LRES=LOAD(OPND1); ! LOAD NEW BASE JJ=-1 %IF OPND2_FLAG=DNAME %START TCELL==ASLIST(TAGS(OPND2_D)) JJ=TCELL_SLINK; D=TCELL_UIOJ>>4&15 %IF TCELL_PTYPE&X'3FFF'=X'33' %THEN JJ=RECORDELAD(TCELL,OPND2_PTYPE,OPND2_XTRA) %FINISH %IF OPND2_FLAG=7 %THEN JJ=OPND2_D&X'FFFF' %AND D=OPND2_D>>16 %IF JJ#-1 %START; ! HEAD ACCESSIBLE AVOID COMPLEX ! ESTACH MANIPULATIONS %IF XTRA&1=0 %THENSTART FETCH LOW AD END(D,JJ) %FINISHELSESTART FETCH HIGH AD END(D,JJ) EOP(IADD) FETCH LOW AD END(D,JJ) %FINISH %CONTINUE %FINISH LRES=LOAD(OPND2); ! ARRAY HEAD BEFORE ADJMNT %IF XTRA&1=0 %START; ! ARRAY MAPPING OPND1 IS BASE EOP(EXCH); EOP(DISCARD); ! DISCARD OLD BASE %FINISHELSESTART EOP(EXCH) EPROMOTE(3) EOP(IADD); ! ADDRESSES ADDED EOP(EXCH) %FINISH %CONTINUE !*********************************************************************** !* SECTION FOR GENERATING CODE FOR INLINE ASSEMBLER * !*********************************************************************** TRIPSW(50): ! UC NOOP ! CNOP(OPND1_D>>8,OPND1_D&255) %CONTINUE TRIPSW(51): ! UCB1 ONE BYTE ASSEMBLER EOP(OPND1_D) %CONTINUE TRIPSW(52): ! UCB2 TWO BYTE ASSEMBLER ! PPUT2(OPND1_D&X'FFFF'); ! FOR *PUTS ALSO %CONTINUE TRIPSW(53): ! UCB3 3 BYTE ASSEMBLER ! PI2(OPND1_D>>16,OPND1_D>>8&255,OPND1_D&255) %CONTINUE TRIPSW(54): ! UCW ASSEMBLER WITH WORD OPERAND ESTKLIT(OPND1_XTRA) %CONTINUE TRIPSW(55): ! UCBW BYTE&WORD OPERAND ASSEMBLER ! PI2(OPND1_D>>24,OPND1_D>>16&255,OPND1_D&X'FFFF') %CONTINUE TRIPSW(59): ! UCNAM ACCESS TO NAMES FROM U-C D=OPND1_D>>16 JJ=OPND1_D&X'FFFF' TCELL==ASLIST(TAGS(JJ)) %IF TCELL_PTYPE&X'3F00'=0 %THEN C=BYTES(TCELL_PTYPE>>4&15) %ELSE C=4 JJ=TCELL_SLINK+OPND1_XTRA %IF D=1 %THEN DFETCHAD(C,TCELL_UIOJ>>4&15,JJ) %ELSEIF D=2 %THEN %C DSTORE(1,ESTORE,C,TCELL_UIOJ>>4&15,JJ) %ELSE DFETCH(1,C,TCELL_UIOJ>>4&15,JJ) %CONTINUE STRES: CURRT_OPTYPE<-OPND1_PTYPE %IF CURRT_CNT>1 %AND CURRT_OPERN#LASS %START; ! USED MORE THAN ONCE ! AND NOT ALREADY STORED %IF CURRT_FLAGS&USE ESTACK#0 %START; ! IMPLIES _CNT=2 %AND TYPE=1 EOP(DUPL) %FINISHELSESTART %if opnd1_ptype&7>2 %then c=4 %else C=BYTES(OPND1_PTYPE>>4&15) D=C %IF C<4 %THEN C=4 %IF D<2 %THEN D=2 GET WSP(TEMPLOC,C>>2) DSTORE(opnd1_ptype&7,EDUPSTORE,D,CURRINF_RBASE,TEMPLOC) OPND1_D=CURRINF_RBASE<<16!TEMPLOC OPND1_XTRA=M'DUPL' OPND1_FLAG=7 %FINISH %FINISH %REPEAT %IF PARM_DCOMP#0 %START PRINTSTRING(" CODE FOR LINE") WRITE(WORKA_LINE,3) ELINEDECODE ELINESTART(WORKA_LINE); ! PREVENT CODE COMING AGAIN %FINISH %RETURN %INTEGERFN LOAD(%RECORD (RD) %NAME OPND) !*********************************************************************** !* LOAD OPERAND OPND INTO TOP OF NEST(ESTACK) * !*********************************************************************** %INTEGER K,KK,X,PREG,B,D,RES,PTYPE,TYPE,PREC %STRING (255) SVAL %LONGREAL RVAL %RECORD (RD) ROPND %RECORD (TRIPF) %NAME REFTRIP %RECORD (TAGF) %NAME TCELL %SWITCH SW(0:9) K=OPND_FLAG RES=1; ! SOMETHING LOADED PTYPE=OPND_PTYPE TYPE=PTYPE&15 PREC=PTYPE>>4&15 %IF K>9 %THEN IMPABORT ->SW(K) SW(0): ! CONSTANT < 16 BITS SW(1): %IF TYPE=5 %THEN ->SCONST %IF TYPE=1 %THEN ESTKLIT(OPND_D) %AND ->LDED %IF TYPE=2 %THENSTART %IF HOST#TARGET %THEN REFORMATC(OPND) ESTKCONST(BYTES(PREC),ADDR(OPND_D)) %FINISH ->LDED SCONST: ! STRING CONSTANT OPND_DIS AR PTR %IF HOST=EMAS %THEN SVAL=STRING(ADDR(WORKA_A(OPND_D))) %ELSESTART KK=WORKA_A(OPND_D) LENGTH(SVAL)=KK %FOR KK=1,1,KK %CYCLE CHARNO(SVAL,KK)=WORKA_A(OPND_D+KK) %REPEAT %FINISH %IF HOST#TARGET %THEN CHANGE SEX(ADDR(SVAL),0,KK+1) ESTKCONST(KK+1,ADDR(SVAL)) EOP(EADDRESS) ->LDED SW(3): ! 128 BIT CONSTANT IMPABORT SW(2): ! NAME TCELL==ASLIST(TAGS(OPND_D)) K=BYTES(OPND_PTYPE>>4&15) %IF TCELL_PTYPE&X'3FFF'=X'33' %START KK=RECORDELAD(TCELL,PTYPE,OPND_XTRA) %FINISHELSEIF TYPE=5 %THEN KK=STRINGLBAD(TCELL) %ELSE KK=TCELL_SLINK %IF TYPE=5 %THEN DFETCHAD(1,TCELL_UIOJ>>4&15,KK&X'FFFF') %ELSE %C DFETCH(TYPE,K,TCELL_UIOJ>>4&15,KK) LDED: %IF TYPE=1 %AND PREC<4 %THEN OPND_PTYPE=X'41' OPND_FLAG=9 OPND_XB=ESTK %RESULT=RES SW(5): ! INDIRECT VIA DICTIONARY ! ONLY RECORD SCALAR(_XTRA>=0) ! OR POINTER(_XTRA<0) TCELL==ASLIST(TAGS(OPND_D)) %IF TYPE=5 %AND OPND_XTRA<0 %START; ! STRING POINTER FETCH HIGH AD END(TCELL_UIOJ>>4&15,TCELL_SLINK) %FINISHELSE DFETCH(1,4,TCELL_UIOJ>>4&15,TCELL_SLINK) ->IFETCH SW(4): ! VIA POINTER AT OFFSET FROM ! A COMPUTED ADDRESS REFTRIP==TRIPLES(OPND_D) x=opnd_xtra %IF REFTRIP_PUSE#WTRIPNO %THEN OPND_FLAG=8 %AND LRES=LOAD(OPND) %IF TYPE=5 %THEN x=x+4 EREFER(x,4); ! POINTER OR ADDRESS PORTION IN ESTK %IF TYPE#5 %THEN INDLOAD(TYPE,BYTES(PREC),0) ->LDED SW(6): ! INDIRECT WITH OFFSET REFTRIP==TRIPLES(OPND_D) %IF REFTRIP_PUSE#WTRIPNO %START; ! NEED TO LOAD TRIPLE ROPND=OPND ROPND_PTYPE=REFTRIP_OPTYPE ROPND_FLAG=8 KK=LOAD(ROPND) %FINISH IFETCH: KK=OPND_XTRA KK=0 %IF KK<0 %IF TYPE=5 %START ESTKLIT(KK) %AND EOP(IADD) %IF KK>0 %FINISHELSESTART INDLOAD(TYPE,BYTES(PREC),KK) %FINISH ->LDED SW(7): ! I-R IN A STACK FRAME B=OPND_D>>16; D=OPND_D&X'FFFF' %IF TYPE=5 %THENSTART %IF OPND_XTRA=M'DUPL' %THEN DFETCH(1,4,B,D) %ELSE DFETCHAD(1,B,D+OPND_XTRA-1) %FINISHELSESTART %IF OPND_XTRA=M'ARRH' %THEN FETCH HIGH AD END(B,D) %ELSE DFETCH(TYPE,BYTES(PREC),B,D) %FINISH ->LDED SW(8): ! TRIPLE REFTRIP==TRIPLES(OPND_D) %IF TYPE#5 %AND REFTRIP_PUSE=WTRIPNO %AND REFTRIP_FLAGS&NOTINREG=0 %THEN %C PREG=REFTRIP_OPND1_XB %AND RES=0 %AND ->LDED OPND=REFTRIP_OPND1 %RESULT=LOAD(OPND) SW(9): ! I-R IN A REGISTER PREG=OPND_XB %RESULT=0 %END %INTEGERFN STRINGLBAD(%RECORD (TAGF) %NAME TCELL) !*********************************************************************** !* RETURNS B<<16!D OF THE STRING LENGTH BYTE * !* FN NEEDED AS GLA FORWARD & STACK BACKWARD * !*********************************************************************** %INTEGER B,D,X,RL %RECORD (LEVELF) %NAME INF D=TCELL_SLINK B=TCELL_UIOJ>>4&15 %IF B=0 %THENRESULT=D INF==WORKA_LEVELINF(RLEVTOLEVEL(B)) X=INF_DISPLAY %IF D>4&15 %IF B=0 %THENRESULT=D+XDISP D=D+TCELL_ACC-XDISP %IF SPTYPE&7=5 %THENRESULT=D-1 D=D-BYTES(SPTYPE>>4&7) ! %IF SPTYPE=X'31' %THEN D=D!!1 %RESULT=D %END %ROUTINE INDLOAD(%INTEGER TYPE,SIZE,OFFSET) !*********************************************************************** !* LOADS REG VIA INDIRECTION POINTER ON ETOS * !*********************************************************************** %IF TYPE=1 %AND SIZE=8 %START EOP(DUPL) EREFER(OFFSET+4,4) EOP(EXCH) EREFER(OFFSET,4) %FINISHELSE EREFER(OFFSET,SIZE) %END %ROUTINE INDSTORE(%INTEGER TYPE,SIZE,OFFSET) !*********************************************************************** !* STORES REG VIA INDIRECTION POINTER ON ETOS * !* WHEN REG ALSO = ETOS %THEN ROUTINE ASSUMES CORRECT ORDERING * !*********************************************************************** %IF TYPE=1 %AND SIZE=8 %START EOP(DUPL) EPROMOTE(4) EOP(EXCH) EREFER(OFFSET+4,4) EOP(ESTORE) EREFER(OFFSET,4) EOP(ESTORE) %ELSE EREFER(OFFSET,SIZE) EOP(ESTORE) %FINISH %END %ROUTINE LOADAD(%RECORD (RD) %NAME OPND) !*********************************************************************** !* MUCH AS LOAD BUT PRODUCES THE 32 BIT ADDRESS OF OPERAND * !* ABORT ON NON RELEVANT ALTERNATIVES OF OPND * !*********************************************************************** %RECORD (TRIPF) %NAME REFTRIP %RECORD (TAGF) %NAME TCELL %RECORD (RD) ROPND %INTEGER B,D,X,K,PTYPE %SWITCH SW(0:9) PTYPE=OPND_PTYPE X=OPND_XTRA K=OPND_FLAG ->SW(K) SW(*): ! INVALID IMPABORT SW(2): ! DNAME TCELL==ASLIST(TAGS(OPND_D)) B=TCELL_UIOJ>>4&15 %IF TCELL_PTYPE&X'3FFF'=X'33' %THEN D=RECORDELAD(TCELL,PTYPE,X) %ELSEIF %C PTYPE&255=X'35' %THEN D=STRINGLBAD(TCELL) %ELSE D=TCELL_SLINK DFETCHAD(BYTES(PTYPE>>4&15),B,D) LDED: OPND_PTYPE=X'51'; ! 32 BIT ADDRESS IS INTEGER OPND_FLAG=9 OPND_XB=ESTK %RETURN SW(4): ! VIA POINTER AT OFFSET FROM ! A COMPUTED ADDRESS REFTRIP==TRIPLES(OPND_D) %IF REFTRIP_PUSE#WTRIPNO %THEN OPND_FLAG=8 %AND LRES=LOAD(OPND) %IF PTYPE&255=X'35' %THEN X=X+4 EREFER(X,4); ! ADDRESS IN ESTACK ->LDED SW(5): ! INDIRECT VIA PTR TCELL==ASLIST(TAGS(OPND_D)) B=TCELL_UIOJ>>4&15 D=TCELL_SLINK %IF PTYPE&X'FF'=X'35' %AND OPND_XTRA<0 %START; ! STRING POINTER FETCH HIGH AD END(B,D) ->LDED %FINISH DFETCH(1,4,B,D) ->INC ADDR SW(6): ! INDIRECT OFFSET REFTRIP==TRIPLES(OPND_D) %IF REFTRIP_PUSE#WTRIPNO %THENSTART ROPND=OPND ROPND_PTYPE=REFTRIP_OPTYPE ROPND_FLAG=8 LRES=LOAD(ROPND) %FINISH INC ADDR: ! X>=0 RECORD: X<0 POINTER %IF X>0 %THEN ESTKLIT(X) %AND EOP(IADD) ->LDED SW(7): ! LOCAL-IR IN BASE&OFFSET FORM B=OPND_D>>16 D=OPND_D&X'FFFF' DFETCHAD(BYTES(PTYPE>>4&7),B,D) ->LDED %END %ROUTINE LOADPTR(%RECORD (RD) %NAME OPND,OPND2) !*********************************************************************** !* MUCH AS LOAD BUT PRODUCES THE POINTER TO THE OPERAND * !* ABORT ON NON RELEVANT ALTERNATIVES OF OPND * !*********************************************************************** %RECORD (TRIPF) %NAME REFTRIP %RECORD (TAGF) %NAME TCELL %RECORD (RD) ROPND %INTEGER K,B,D,X,PTYPE %SWITCH SW(0:9) PTYPE=OPND_PTYPE X=OPND_XTRA K=OPND_FLAG ->SW(K) SW(*): ! INVALID IMPABORT SW(2): ! DNAME TCELL==ASLIST(TAGS(OPND_D)) %IF TCELL_PTYPE&X'3FFF'=X'33' %THENSTART D=RECORDELAD(TCELL,PTYPE,X) %FINISHELSEIF PTYPE&255=X'35' %THEN D=STRINGLBAD(TCELL) %ELSE D=TCELL_SLINK %IF PTYPE&255=X'35' %THENSTART PTYPE=CURRT_X1>>16 DFETCHAD(1,TCELL_UIOJ>>4&15,D&X'FFFF') ->STR %FINISH %IF PTYPE&255=X'31' %THEN DFETCHAD(1,TCELL_UIOJ>>4&15,D) %ELSE %C DFETCHAD(BYTES(OPND_PTYPE>>4&7),TCELL_UIOJ>>4&15,D) LDED: OPND_PTYPE=X'51' OPND_FLAG=9 OPND_XB=ESTK %RETURN SW(4): ! VIA POINTER AT OFFSET FROM ! A COMPUTED ADDRESS REFTRIP==TRIPLES(OPND_D) %IF REFTRIP_PUSE#WTRIPNO %THEN OPND_FLAG=8 %AND LRES=LOAD(OPND) %IF PTYPE&255=X'35' %THEN INDLOAD(1,8,X) %AND ->SLDED INDLOAD(1,4,X) ->LDED SW(5): ! INDIRECT VIA DICT TCELL==ASLIST(TAGS(OPND_D)) %IF X<0 %START; ! IS A POINTER D=4 %IF PTYPE&255=X'35' %THEN D=8 DFETCH(1,D,TCELL_UIOJ>>4&15,TCELL_SLINK) ->LDED %FINISH DFETCH(1,4,TCELL_UIOJ>>4&15,TCELL_SLINK) ->INC ADDR SW(6): ! INDIRECT OFFSET REFTRIP==TRIPLES(OPND_D) %IF REFTRIP_PUSE#WTRIPNO %THENSTART ROPND=OPND ROPND_PTYPE=REFTRIP_OPTYPE ROPND_FLAG=8 LRES=LOAD(ROPND) %FINISH INC ADDR: ! FOR RECORD ELEMENTS %IF X>0 %THEN ESTKLIT(X) %AND EOP(IADD) STR: ! ORGANISE WORD2 OF STR PNTR ! OPND2_XTRA=BML<<16!DML ->LDED %UNLESS PTYPE&255=X'35'; ! ALL NON STRING ! string lengths are maxl not acc which includes the length byte ! hence for arrays which have acc one must be removed ! %IF OPND2_FLAG=SCONST %THEN ESTKLIT(OPND2_D&X'FFFF') %ELSESTART CHOP OPERAND(OPND2,x'51',0) LRES=LOAD(OPND2) ! FOR STRINGNAMES PTR NOW LOADED ! FR STRINGARRAYNAMES DVBASE NOW LDED ! HAVE TO EXTRACT ELSIZE AND DECREMENT BY 1 %IF PTYPE&X'300'#0 %THENSTART EREFER(4,2) ESTKLIT(1) EOP(ISUB) %FINISH %FINISH SLDED: ! STRING PTR LOADED OPND_PTYPE=X'61'; ! STR PNTERS ARE 64 BIT OPND_FLAG=9 OPND_XB=ESTK %RETURN SW(7): ! LOCAL BASE&DISP(RESULTS FROM MAP OPTIMISATIONS) B=OPND_D>>16 D=OPND_D&X'FFFF' DFETCHAD(BYTES(PTYPE>>4&7),B,D) ->LDED SW(8): ! A TRIPLE MEANS PREVIOUSLY USED ! POINTER A SECOND TIME REFTRIP==TRIPLES(OPND_D) IMPABORT %UNLESS REFTRIP_OPERN=GETPTR LRES=LOAD(OPND) %END %ROUTINE VMY !*********************************************************************** !* DOES ALL VECTOR MULTIPLIES * !*********************************************************************** %RECORD (RD) DOPND %INTEGER DVPOS,PR,CM DVPOS=-1 PR=OPND1_PTYPE>>4&15 CM=-1 %IF OPND2_FLAG=SCONST %THEN DVPOS=OPND2_D %ELSESTART CHOP OPERAND(OPND2,x'51',0); ! to dv ptr DOPND=OPND2; ! for second load if needed %FINISH %IF PARM_ARR#0 %START %IF DVPOS>0 %START; ! BOUND KNOWN ESTKLIT(BYTESWOP(CTABLE(DVPOS+3*C+1))) ESTKLIT(BYTESWOP(CTABLE(DVPOS+3*C))) %FINISHELSESTART LRES=LOAD(OPND2); ! fetch dv ptr EOP(DUPL) EREFER(12*C+4,4) EOP(EXCH) EREFER(12*C,4) %FINISH EOP(CHK) %FINISH %IF C#1 %START; ! ALL DIMENSION BAR 1ST %IF DVPOS>0 %THENSTART ESTKLIT(BYTESWOP(CTABLE(DVPOS+3*C-1))) %FINISHELSESTART LRES=LOAD(DOPND); ! fetch dv ptr EREFER(12*C-4,4); ! MULTIPLIER %FINISH EOP(IMULT) %FINISH %END %ROUTINE REXP !*********************************************************************** !* CALLS A PERM ROUTINE TO PERFORM REAL**REAL * !*********************************************************************** ESTKLIT(2) EOP(EPOWER) %END %ROUTINE CHOP OPERAND(%RECORD (RD) %NAME OPND, %INTEGER NEWPT,XOFFSET) !*********************************************************************** !* CHANGES RECORD OPERAND TO REFER TO A SMALLER BIT AT XOFFSET FROM * !* THE ORIGINAL START. USED TO LOAD ONE WORD OF STRING&ARRAY HEADERS* !* MUST COPE WITH GLA GOING FORWARD BUT STACK FRAMES GOING BACKWARDS* !*********************************************************************** %INTEGER OLDPT,S1,S2 %RECORD (TAGF) %NAME TCELL OLDPT=OPND_PTYPE&255 OPND_PTYPE=OPND_PTYPE&X'FF00'!NEWPT %IF OPND_FLAG=9 %THEN IMPABORT %IF XOFFSET<0 %THENRETURN %IF OPND_FLAG=DNAME %START TCELL==ASLIST(TAGS(OPND_D)) %IF TCELL_PTYPE&x'3FFF'=x'33' %THEN S1=RECORDELAD(TCELL,OLDPT,OPND_XTRA) %ELSE %C S1=TCELL_SLINK OPND_D=(TCELL_UIOJ>>4&15)<<16!S1 OPND_FLAG=LOCAL IR %FINISH %IF OPND_FLAG=INDIRECT %OR OPND_FLAG=INDNAME %THEN OPND_XTRA=OPND_XTRA&X'FFFF'+XOFFSET %IF OPND_FLAG=LOCALIR %THENSTART %IF OPND_D>>16=0 %THEN OPND_D=OPND_D+XOFFSET %ELSESTART S1=BYTES(OLDPT>>4) S2=BYTES(NEWPT>>4) OPND_D=OPND_D+S1-S2-XOFFSET %FINISH %FINISH %END %INTEGERFN RLEVTOLEVEL(%INTEGER RLEV) !********************************************************************* !* FIND LEVEL FOR VAR WHOSE RLEVEL IS KNOWN * !*********************************************************************** %INTEGER I %RECORD (LEVELF) %NAME INF I=1 %CYCLE INF==WORKA_LEVELINF(I) %IF INF_RBASE=RLEV %THENRESULT=I I=I+1 %REPEAT %END %ROUTINE DSTORE(%INTEGER TYPE,OPCODE,SIZE,RLEVEL,DISP) !*********************************************************************** !* STORE SIZE(BYTES) FROM DISP(BYTES) IN DISPLAY 'LEVEL' * !*********************************************************************** %IF TYPE=1 %AND SIZE=8 %START %IF OPCODE=EDUPSTORE %THEN EOP(DUPL) STORE LOW AD END(RLEVEL,DISP) %IF OPCODE=EDUPSTORE %THEN EOP(EXCH) %AND EOP(DUPL) STORE HIGH AD END(RLEVEL,DISP) %IF OPCODE=EDUPSTORE %THEN EOP(EXCH) %ELSE DFETCH(TYPE,SIZE,RLEVEL,DISP) EOP(OPCODE) %FINISH %END %ROUTINE DFETCHAD(%INTEGER SIZE,RLEVEL,DISP) !*********************************************************************** !* FETCH ADDRESS OF DISP(BYTES) IN DISPLAY 'LEVEL' * !* SIZE IS NEED BECAUSE OF WRONG END LOW ADDRESS FOR STACKS * !*********************************************************************** DFETCH(0,SIZE,RLEVEL,DISP) EOP(EADDRESS) %END %ROUTINE DFETCH(%INTEGER TYPE,SIZE,RLEVEL,DISP) !*********************************************************************** !* FETCH SIZE(BYTES) FROM DISP(BYTES) IN DISPLAY 'LEVEL' * !*********************************************************************** %INTEGER LEVELCODE %RECORD (LEVELF) %NAME INF %SWITCH SW(0:3) %IF TYPE=1 %AND SIZE=8 %START FETCH HIGH AD END(RLEVEL,DISP) FETCH LOW AD END(RLEVEL,DISP) %RETURN %FINISH %IF RLEVEL=0 %THEN LEVELCODE=0 %ELSEIF RLEVEL=CURRINF_RBASE %THEN LEVELCODE=1 %ELSE %C LEVELCODE=2 ->SW(LEVELCODE) SW(*): ! FUNNY SIZES IMPABORT SW(0): ! GLOBAL FETCH ESTKDIR(2 {gla},DISP,0,SIZE) %RETURN SW(1): ! LOCAL FETCH ESTKDIR(0 {stack},CURRINF_DISPLAY-(DISP+SIZE),0,SIZE) %RETURN SW(2): ! INTERMEDIATE WORD FETCH INF==WORKA_LEVELINF(RLEVTOLEVEL(RLEVEL)) ESTKGLOBAL(RLEVEL,INF_DISPLAY-(DISP+SIZE),0,SIZE) %END %ROUTINE FETCH HIGH AD END(%INTEGER B,D) !*********************************************************************** !* FETCHES THE HIGH END OF ARRAYHEAD(IE @A(FIRST)) OR STRINGNAME * !*********************************************************************** %IF B=0 %THEN D=D+4 DFETCH(1,4,B,D) %END %ROUTINE FETCH LOW AD END(%INTEGER B,D) !*********************************************************************** !* FETCHES LOW END OF ARRAYHD(IE DV PTR) OR STRINGHEAD(IE ACC) * !*********************************************************************** %IF B#0 %THEN D=D+4 DFETCH(1,4,B,D) %END %ROUTINE STORE HIGH AD END(%INTEGER B,D) !*********************************************************************** !* STORES THE HIGH END OF ARRAYHEAD(IE @A(FIRST)) OR STRINGNAME * !*********************************************************************** %IF B=0 %THEN D=D+4 DSTORE(1,ESTORE,4,B,D) %END %ROUTINE STORE LOW AD END(%INTEGER B,D) !*********************************************************************** !* STORES LOW END OF ARRAYHD(IE DV PTR) OR STRINGHEAD(IE ACC) * !*********************************************************************** %IF B#0 %THEN D=D+4 DSTORE(1,ESTORE,4,B,D) %END %INTEGERFN JCODE(%INTEGER TFMASK) !*********************************************************************** !* PRODUCES JUMP CODE FROM IBM TYPE BRANCH MASK AND EXTRA BITS * !* x20 bit set for comparisons with zero * !* x40 bit if compare has been omitted * !* x100 bit set for real comparisons * !* x80 bit set for reversed comparisons * !*********************************************************************** %INTEGER D %IF TFMASK&15=15 %THENRESULT=JUMP %IF TFMASK&X'40'#0 %START; ! OPTIMISED BY CCOMP ! NEXT LINE ASSUMES BFFLAG IS ! STILL AS SET BY CCOMP! D=32+16*BFFLAG+TFMASK&15 %IF TFMASK&x'100'#0 %THEN D=D+64 D=FCOMP(D) %IF TFMASK&x'20'#0 %THEN D=D+(JINTGZ-JIGT) %RESULT=D %FINISH %IF TFMASK&128#0 %THENRESULT=JFALSE %RESULT=JTRUE %END %ROUTINE ISTARSTAR !*********************************************************************** !* PLANT IN LINE CODE FOR INTEGER****INTEGER * !* IN LINE CODE RATHER THAN SUBROUTINE BECAUSE OF NO JLK * !*********************************************************************** ESTKLIT(0) EOP(EPOWER) %END %ROUTINE STARSTAR !*********************************************************************** !* PLANT IN LINE CODE FOR REAL**INTEGER * !* IN LINE CODE RATHER THAN SUBROUTINE BECAUSE OF THE NO OF CASES * !* NEEDED ON A REGISTER MACHINE WITH 2 LENGTHS OF ARITHMETIC * !*********************************************************************** ESTKLIT(1) EOP(EPOWER) %END %ROUTINE CIOCP(%INTEGER N) !*********************************************************************** !* COMPILES A CALL ON IOCP ENTRY POINT NO 'N' * !* 2ND PARAMETER IS ALREADY IN ETOS * !*********************************************************************** %CONSTINTEGER NEEDS RES=X'20016'; ! FLAGS EPS 1,2,4&18 %INTEGER C,X,ID C=CURRT_DPTH EPRECALL(KNOWN XREF(4)) EOP(PUSHVAL) ESTKLIT(N) EOP(PUSHVAL) %IF C>0 %START; ! OFFLOAD ESTACK GET WSP(C,4) C=CURRINF_DISPLAY-(C+16) ESAVE(C,ID) %FINISH %IF 1<