! ! Changes to reduce confusion over dummy parameter pushed for ! alignment purposes (Mostly but not entirely in PARDESLIST ! PDS nov 89 ! ! changes applied for risc development retrofitted (GEM 5/10/89) ! ! 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" %CONST %INTEGER HOST=AMDAHL %CONST %INTEGER TARGET=M88K %INCLUDE "ercs01:ebits_ECODES28" %INCLUDE "ERCC07:TRIPCNSTS" %INCLUDE "ERCC07:ITRIMP_TFORM2S" %CONST %INTEGER ESTK=0 %OWN %INTEGER profgla,profzgst; ! OFFSETS FOR PROFILING DATA %OWN %INTEGER GLACABUF,GLABEL,FPPTR,FPHEAD,SWAPMODE %OWN %INTEGER %NAME CA,GLACA %OWN %INTEGER %ARRAY %NAME CTABLE,TAGS,WORD %OWN %BYTE %INTEGER %ARRAY %NAME lett %OWN %RECORD (LISTF) %ARRAY %NAME ASLIST %OWN %RECORD (LEVELF) %NAME WORKINGINF %EXTRINSIC %INTEGER %ARRAY CAS(0:12) %EXTRINSIC %RECORD (WORKAF) WORKA %EXTRINSIC %RECORD (PARMF) PARM %CONST %INTEGER MAXREG=4 %EXTERNAL %ROUTINE %SPEC FLAGAND FOLD(%RECORD (TRIPF) %ARRAY %NAME T) %EXTERNAL %ROUTINE %SPEC FAULT(%INTEGER I,J,K) %externalroutinespec Einitialise (%integer Lang,Aver,Astackca,Aglaca,options) %externalroutinespec Eterminate (%integer adareasizes) %externalroutinespec Elinestart (%integer lineno) %externalroutinespec Elinedecode %externalintegerfnspec Estkmarker %externalroutinespec Esetmarker (%integer Markerid,New Value) %externalintegerfnspec Eswapmode %externalroutinespec Emonon %externalroutinespec Emonoff %externalroutinespec Efaulty %externalroutinespec Estklit (%integer Val) %externalroutinespec Estkconst (%integer Len,Ad) %externalroutinespec Estkrconst (%integer Len,Ad) %externalroutinespec Estkdir (%integer Area,Offset,Adid,Bytes) %externalroutinespec Estkind (%integer Area,Offset,Adid,Bytes) %externalroutinespec Estkglobal (%integer Level,Offset,Adid,Bytes) %externalroutinespec Estkglobalind (%integer Level,Offset,Adid,Bytes) %externalroutinespec Estkgind (%integer Level,Offset,Adid,Bytes) %externalroutinespec Estkpar (%integer Level,Offset,Adid,Bytes) %externalroutinespec Estkparind (%integer Level,Offset,Adid,Bytes) %externalroutinespec Estkresult (%integer Class,Type,Bytes) %externalroutinespec Erefer (%integer Offset,Bytes) %externalroutinespec Epromote (%integer Level) %externalroutinespec Edemote (%integer Level) %externalroutinespec Estkaddr (%integer Area,Offset,Adid,Bytes) %externalroutinespec Estkgaddr (%integer Level,Offset,Adid,Bytes) %externalroutinespec Estkpaddr (%integer Level,Offset,Adid,Bytes) %externalroutinespec Estkreg (%integer reg,Offset) %externalroutinespec Eregvar (%integer Offset,Size,Loadit) %externalroutinespec Eloseregs (%integer Level) %externalroutinespec Elabel (%integer Id) %externalroutinespec Ediscardlabel (%integer Id) %externalroutinespec Euchecklab (%integer Labid) %externalroutinespec Eboundlab (%integer Labid) %externalroutinespec Ejump (%integer Opcode, Labelid) %externalroutinespec Eswitch (%integer Lower, Upper, Switchid, Errlabid, %integername SSTAD) %externalroutinespec EswitchJump (%integer Switchid) %externalroutinespec EfswitchJump (%integer Switchid) %externalroutinespec Eswitchentry (%integer Switchid, Entry) %externalroutinespec Eswitchdef (%integer Switchid) %externalroutinespec EswitchLabel (%integer Switchid, Entry, Labelid) %externalroutinespec Ed1 (%integer area, Disp, Val) %externalroutinespec Ed2 (%integer area, Disp, Val) %externalroutinespec Ed4 (%integer area, Disp, Val) %externalroutinespec Edbits (%integer area, Disp, Bitoffset, Numbits, Val) %externalroutinespec Edbytes (%integer area, Disp, len, ad) %externalroutinespec Edpattern (%integer area, Disp, ncopies, len, ad) %externalroutinespec Efix (%integer area,disp, tgtarea,tgtdisp) %externalintegerfnspec EXname (%integer type,%string(255)%name Xref) %externalroutinespec Eprecall2(%integer Id,aparprops) %externalroutinespec Ecall2 (%integer Id,Extlev,Numpars,Paramsize) %externalroutinespec Eprocref (%integer Id, Level) %externalintegerfnspec Enextproc %externalroutinespec Eproc2(%stringname Name,%integer Props, Aparprops,%integername ID) %externalroutinespec Eprocend (%integer Localsize,Diagdisp,Astacklen) %externalroutinespec Edataentry (%integer Area,Offset,Length,%stringname Name) %externalroutinespec Edataref (%integer Area,Offset,Length,%stringname Name) %externalroutinespec Eop (%integer Opcode) %CONST %INTEGER MAXKXREF=6 %OWN %INTEGER %ARRAY KXREFS(0:MAXKXREF)=-1(*) %CONST %STRING (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" %CONST %INTEGER %ARRAY PPJINFO(0:30)=0,0,x'00020005',0(13), X'02050014'{16 RESLN}, 0,x'00030009'{18 STRINGJT}, 0(5),X'00020005'{24 CONCAT}, 0(3),X'02020005'{28 STRING COMP}, 0(*) ! resflags<<24!naprs<<16!pardes entry %CONST %STRING (11) %ARRAY KXREFNAME(0:MAXKXREF)="s#stop","s#ndiag", "s#ilog","s#iexp","s#iocp", "icl9ceauxst","s#pprofile" %CONST %INTEGER paramptr=27 %own %INTEGER %ARRAY pardes(0:127)=0,0 { no parameters}, 1,4,1<<24!4 {2 one integer param}, 2,8,1<<24!4(2) {5 two integer params}, 3,12,1<<24!4(3) {9 three integer params}, 4,16,1<<24!4(4) {14 four integer params}, 5,20,1<<24!4(5) {20 five integer params}, 0(*) %EXTERNAL %ROUTINE %SPEC PRINT TRIPS(%RECORD (TRIPF) %ARRAY %NAME T) %EXTERNALROUTINESPEC PRINT THIS TRIP(%record(tripf)%arrayname trips, %integer i) %EXTERNAL %ROUTINE %SPEC POP(%INTEGER %NAME A,B,C,D) !%EXTERNALROUTINESPEC PRINT LIST(%INTEGER HEAD) %EXTERNAL %ROUTINE %SPEC PUSH(%INTEGER %NAME A, %INTEGER B,C,D) %EXTERNAL %ROUTINE %SPEC MOVE BYTES(%INTEGER L,FB,FO,TB,TO) %INTEGER %FN %SPEC BYTESWOP(%INTEGER VAL) %ROUTINE %SPEC REFORMATC(%RECORD (RD) %NAME OPND) %ROUTINE %SPEC CHANGESEX(%INTEGER BASE,OFFSET,L) %ROUTINE %SPEC PPJ(%INTEGER A,B) %ROUTINE %SPEC IMPABORT %EXTERNAL %ROUTINE %SPEC PRHEX(%INTEGER VALUE,PLACES) %CONST %INTEGER PARAMS BWARDS=No %CONSTINTEGER Stack Down=Yes %const %integer aux stack=yes %if Stack Down = Yes %then %Start %constinteger Stack Inc=-1 %else %constinteger Stack Inc=1 %finish %const %integer longs aligned=yes %CONST %BYTE %INTEGER %ARRAY BYTES(0:7)=0(3),1,2,4,8,16; %CONST %INTEGER DAREA=6; ! AREA FOR DIAG TABLES %CONST %INTEGER CAREA=10; ! AREA FOR CONSTANTS %CONST %INTEGER zgst=9; ! profile area into here %CONST %INTEGER gla=2 %OWN %INTEGER prevline=0 %CONST %INTEGER P0=-4,L0=-4 %CONST %INTEGER P1=P0+4,P2=P0+2*4,P3=P0+3*4,P4=P0+4*4,P5=P0+5*4,P6=P0+4*6 ! Paramtere pffsets %if Stack Down=Yes %then %start %CONST %INTEGER L1=L0-4*1,L2=L0-4*2,L3=L0-4*3,L4=L0-4*4,L5=L0-4*5,L6=L0-4*6,L7=L0-4*7,L8=L0-4*8,L9=L0-4*9 %finish %else %Start %CONSTINTEGER L1=L0+4*1,L2=L0+4*2,L3=L0+4*3,L4=L0+4*4,L5=L0+4*5,L6=L0+4*6,L7=L0+4*7,L8=L0+4*8,L9=L0+4*9 %FINISH ! ! 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 ! %CONST %INTEGER FIXEDGLALEN=56 %OWN %INTEGER %ARRAY 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 IMP80 Compiler Release ".TOSTRING(WORKA_RELEASE)." Version ". %C WORKA_LADATE EINITIALISE(1,ADDR(HD),ADDR(WORKA_LINE)+4 {frig},ADDR(CAS(2)), parm_chk<<8!parm_arr<<9) ! OPEN OBJECT FILE TAGS==WORKA_TAGS WORD==WORKA_WORD LETT==WORKA_LETT EMONON %IF PARM_DCOMP#0 SWAPMODE=ESWAPMODE WORKINGINF==WORKA_LEVELINF(1) %END %EXTERNAL %ROUTINE CODEOUT !*********************************************************************** !* NEEDED TO SATISFY REFERENCE IN PASS2 * !*********************************************************************** %END %EXTERNAL %ROUTINE PDATA(%INTEGER AREA,BNDRY,L,AD) !*********************************************************************** !* ADDS L(BYTES) TO AREA FOR UST,SST AND DIAGS AREAS * !*********************************************************************** %INTEGER %NAME PTR PTR==CAS(AREA) PTR=(PTR+BNDRY-1)&(-BNDRY) EDBYTES(AREA,PTR,L,AD) PTR=PTR+L %END %EXTERNAL %ROUTINE 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 * !*********************************************************************** %INTEGER %NAME PTR PTR==CAS(AREA) PTR=(PTR+BNDRY-1)&(-BNDRY) EDPATTERN(AREA,PTR,REP,L,AD) PTR=PTR+L*REP %END %EXTERNAL %INTEGER %FN PINITOWN(%INTEGER PTYPE,ACC, %RECORD (RD) %NAME INIT, %STRING %NAME 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 %FINISH %ELSE %START 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 %THEN %START 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 %FINISH %ELSE %START %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 %EXTERNAL %INTEGER %FN 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) %FINISH %ELSE %START %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 %EXTERNAL %ROUTINE CXREF(%STRING (255) NAME, %INTEGER MODE,XTRA, %INTEGER %NAME AT) !*********************************************************************** !* OBTAIN A REFERENCE NO FOR EXTERNAL PROCEDURES * !* MODE=0 STATIC CODE XREF * !* MODE=1 DYNAMIC CODE XREF * !*********************************************************************** AT=EXNAME(1,NAME) %END %INTEGER %FN 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 * !*********************************************************************** EPRECALL2(KNOWN XREF(0),addr(pardes(0))) ECALL2(KNOWN XREF(0),1,0,0); ! S#STOP %END %INTEGER %FN EXCHANGE(%RECORD (RD) %NAME OPND1,OPND2) !*********************************************************************** !* REVERSES NEST SO OPERAND 1 IS AT TOP FOR FLOATS ETC * !* NO ACTION IF OPND2 IS A CONSTANT * !*********************************************************************** %RESULT=0 %UNLESS OPND1_FLAG<=8 %AND OPND1\==OPND2 %RESULT=0 %UNLESS opnd2_flag>=8 %OR 1< 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 ! JTRUE 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 ! ! ! These routine were coded for Unix type backwards parameters ! For forward paramters alter the offsets rathe than recode ! %if PARAMS Bwards=No %then %start P5=p0+4; P4=P0+8; P3=P0+12; P2=P0+16; P1=P0+20 %finish %IF WORKA_PLINK(16)=0 %THEN ->P17 LSIZE=40 FILL(16) ESTKLIT(1) ESTKDIR(0,L4,0,4); EOP(ESTORE) ESTKPARIND(1 {lev},P4,0,4 {word}); ! ldw ((p4) ESTKLIT(255); EOP(IAND) ESTKDIR(0,L5,0,4); EOP(EDUPSTORE) ESTKPARIND(1,P4,0,4); ! ldw ((p4) ESTKLIT(16); EOP(ISHRL) ESTKDIR(0,L1,0,4); EOP(EDUPSTORE) EOP(ISUB) ESTKPARIND(1,P1,0,1 {byte}) ESTKDIR(0,L2,0,4); EOP(EDUPSTORE) EJUMP(JINTZ,GLABEL+5) ESTKDIR(0,L2,0,4) EOP(ISUB) ESTKLIT(1) EOP(IADD) ESTKDIR(0,L3,0,4); EOP(EDUPSTORE) EJUMP(JINTLEZ,GLABEL+4) ESTKPAR(1,P5,0,4) ESTKDIR(0,L1,0,4) EOP(IADD) ESTKDIR(0,L8,0,4); EOP(ESTORE) ! THIS IS "OUTERLOOP" ELABEL(GLABEL) ESTKPAR(1,P1,0,4) ESTKLIT(1) EOP(IADD) ESTKDIR(0,L8,0,4) ESTKDIR(0,L4,0,4) EOP(IADD) ESTKDIR(0,L2,0,4) EOP(CPBEQ) EJUMP(JTRUE,GLABEL+5) ESTKDIR(0,L4,0,4) ESTKLIT(1) EOP(IADD) ESTKDIR(0,L4,0,4); EOP(EDUPSTORE) ESTKDIR(0,L3,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,P3,0,4) EJUMP(JINTZ,GLABEL+6) ESTKDIR(0,L8,0,4) ESTKPAR(1,P2,0,4) ESTKDIR(0,L4,0,4) EOP(MVB) ESTKDIR(0,L4,0,4) ESTKLIT(1) EOP(ISUB); ESTKPAR(1,P2,0,4); EREFER(0,1); EOP(EDUPSTORE) ESTKPAR(1,P3,0,4) EJUMP(JILE,GLABEL+6) EPRECALL2(WORKA_PLABS(9),addr(pardes(0))) ECALL2(WORKA_PLABS(9),1,0,0) ! THIS IS "NOSTORE" ELABEL(GLABEL+6) ESTKDIR(0,L1,0,4) ESTKDIR(0,L2,0,4) EOP(IADD) ESTKDIR(0,L4,0,4) EOP(IADD) ESTKLIT(1) EOP(ISUB) ESTKLIT(16) EOP(ISHLL) ESTKDIR(0,L5,0,4) EOP(IOR) ESTKPARIND(1,P4,0,4 {pointer}); EOP(ESTORE) ESTKLIT(1) EOP(EINTRES) EOP(RETURN) EPROCEND(LSIZE,0,0) GLABEL=GLABEL+7 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 PARAMS Bwards=No %then %start P3=P0+4; P2=P0+8; P1=P0+12 %finish %IF WORKA_PLINK(18)=0 %THEN ->P19 LSIZE=16 FILL(18) ESTKPAR(1,P3,0,4); EREFER(0,1); ESTKDIR(0,L1,0,4); EOP(EDUPSTORE) ESTKPAR(1,P2,0,4) EJUMP(JILE,GLABEL) ESTKPAR(1,P2,0,4); ESTKDIR(0,L1,0,4); EOP(ESTORE) ELABEL(GLABEL) ESTKPAR(1,P3,0,4); ESTKPAR(1,P1,0,4) ESTKDIR(0,L1,0,4) ESTKLIT(1) EOP(IADD) EOP(MVB) ESTKDIR(0,L1,0,4); ESTKPAR(1,P1,0,4); EREFER(0,1); EOP(ESTORE) EOP(RETURN) EPROCEND(LSIZE,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 PARAMS Bwards=No %then %start P2=P0+4; P1=P0+8 %finish %IF WORKA_PLINK(24)=0 %THEN ->P25 LSIZE=16 FILL(24) ESTKPAR(1,P2,0,4); EOP(DUPL); EREFER(0,1); estklit(4); eop(cvtii) ESTKDIR(0,L1,0,4); EOP(EDUPSTORE); EOP(EXCH); ESTKLIT(1) EOP(IADD); EOP(EXCH) ESTKPAR(1,P1,0,4); EOP(DUPL); EREFER(0,1); estklit(4); eop(cvtii) ESTKDIR(0,L2,0,4); EOP(EDUPSTORE); EOP(IADD); ESTKLIT(1) EOP(IADD) EOP(EXCH) EOP(MVB) ESTKDIR(0,L1,0,4); ESTKDIR(0,L2,0,4); EOP(IADD); ESTKPAR(1,P1,0,4) EREFER(0,1); EOP(ESTORE) EOP(RETURN) EPROCEND(LSIZE,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 LSIZE=24 FILL(28) ESTKPAR(1,P1 {P1},0,4); EOP(DUPL) ESTKLIT(1); EOP(IADD) ESTKDIR(0,L1,0,4); EOP(ESTORE) EREFER(0,1); estklit(4); eop(cvtii); ESTKDIR(0,L3,0,4); EOP(ESTORE) ESTKPAR(1,P2 {P2},0,4); EOP(DUPL) ESTKLIT(1); EOP(IADD) ESTKDIR(0,L2,0,4); EOP(ESTORE) EREFER(0,1); estklit(4); eop(cvtii); ESTKDIR(0,L3,0,4) EJUMP(JIGE,GLABEL) ESTKPARIND(1,P2,0,1 {ldb ((p2))}) ESTKDIR(0,L3,0,4); EOP(ESTORE) ELABEL(GLABEL) ESTKDIR(0,L3,0,4) EJUMP(JINTZ,GLABEL+2) ESTKDIR(0,L3,0,4) ESTKLIT(1) EOP(ISUB) ESTKDIR(0,L3,0,4); EOP(ESTORE) ESTKIND(0,L1,0,1 {ldb ((L1))}) ESTKIND(0,L2,0,1 {ldb ((L2))}) EJUMP(JINE,GLABEL+1) ESTKDIR(0,L1 {L1},0,4); ESTKLIT(1); EOP(IADD) ESTKDIR(0,L1 {L1},0,4); EOP(ESTORE) ESTKDIR(0,L2,0,4); ESTKLIT(1); EOP(IADD) ESTKDIR(0,L2,0,4); EOP(ESTORE) EJUMP(JUMP,GLABEL) ELABEL(GLABEL+1); ! LABEL L1 HERE ESTKIND(0,L1,0,1 { ldb((L1))}) ESTKIND(0,L2,0,1 {ldb ((L2))}) EOP(ISUB); EOP(EINTRES) EOP(RETURN) ELABEL(GLABEL+2); ! LABEL L2 IS HERE ESTKPARIND(1,P1,0,1 {ldb ((P1))}) ESTKPARIND(1,P2,0,1 {ldb ((P2))}) EOP(ISUB); EOP(EINTRES) EOP(RETURN) EPROCEND(LSIZE,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. * !*********************************************************************** %INTEGER %ARRAY SIZES(0:10) %ROUTINE %SPEC 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 %THEN %START ! 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)=(CAS(I)+7)&(-8) %REPEAT ETERMINATE(ADDR(SIZES(1))); ! SUMMARY INFO. PRINTSTRING(" 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 %THEN %START WRITE(STMTS,7); PRINTSTRING(" STATEMENTS COMPILED") %FINISH %ELSE %START 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 %EXIT %IF 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 %INTEGER INF S=PLNAME(LAB) INF=PPJINFO(LAB) EPROC2(S,4,addr(pardes(INF&X'FFF')),WORKA_PLINK(LAB)) ! NO DISPALY REQD %END %END %REAL %FN 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' * !*********************************************************************** %CONST %REAL MINUS INFINITY= R'FF800000'; ! ie sign=1,exp=255,fraction=0 %CONST %REAL PLUS INFINITY= R'7F800000'; ! ie sign=0, exp=255,fraction=0 %CONST %REAL 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 1<>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})+ %C (11-BITS SHIFTED LEFT) {equals either 0,1,2, or 3}+127 {the bias of the exponent} ! -and examine its range: %IF PERQ EXP<=0 %THEN %RESULT=MINUS INFINITY {ie Real Underflow} %IF PERQ EXP>=255 %THEN %RESULT=PLUS INFINITY { Real Overflow} ! Construct the PERQ Real INTEGER(ADDR(PERQ REAL))=(SIGN<<8!PERQ EXP)<<23!PERQ FRACTION %RESULT=PERQ REAL %FINISH %ELSE %RESULT=ICL REAL %END; !of ICL Real to PERQ %LONG %REAL %FN ICL LONGREAL TO PERQ(%LONG %REAL 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) %LONG %REAL PERQ REAL; !--the Result %IF 1<>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 %FINISH %ELSE %RESULT=ICL2900 REAL %END; ! of ICL2900 LongReal to PERQ %INTEGER %FN pardeslist(%record(listf)%name tcell) !*********************************************************************** !* Builds the para descriptor table needed for risk chips * !* where parameters are or may be passed in registers * !*********************************************************************** %RECORD (tagf) %NAME pcell %INTEGER npars,entries,ptr,ptype,tslink,rtptype,offset tslink=tcell_slink rtptype=tcell_ptype&x'1FFF'; ! lose all external (etc) bits Offset=0 ptr=paramptr+1 %IF tslink=0 %THEN %Start %if X'33'#rtptype&255#x'35' %then %RESULT=addr(pardes(0)); ! no params pardes(paramptr+1)=0 ->fn res %finish pcell==aslist(tslink) pardes(paramptr+1)=pcell_s3>>16 %CYCLE ptr=ptr+1 %EXIT %IF tslink=0 pcell==aslist(tslink) tslink=pcell_link ptype=pcell_ptype %IF ptype&x'300' {arr}#0 %THEN %START %if longs aligned=yes %and offset&7=4 %Start;! aligment needed pardes(ptr)=-1; ! dummy ptr=ptr+1; offset=offset+4 %finish pardes(ptr)=4; pardes(ptr+1)=4 offset=offset+8 ptr=ptr+1; ! array is two addresses %CONTINUE %FINISH %IF ptype=x'400' %OR ptype=X'435' %or ptype=X'35' %THEN %START ! general name or string name integer & address %if longs aligned=yes %and offset&7=4 %and ptype=X'400' %Start;! aligment needed pardes(ptr)=-1; ! dummy ptr=ptr+1; offset=offset+4 %finish pardes(ptr)=x'01000004'; pardes(ptr+1)=4 ptr=ptr+1; ! these have two entries offset=offset+8 %CONTINUE %FINISH %IF ptype&x'c00'#0 { all names} %START pardes(ptr)=4 offset=offset+4 %CONTINUE %FINISH %IF ptype&7<=2 %START %if longs aligned=yes %and offset&7=4 %and ptype&X'F0'=X'60' %Start;! aligment needed pardes(ptr)=-1; ! dummy ptr=ptr+1; offset=offset+4 %finish pardes(ptr)=(ptype&7)<<24!pcell_acc %if pcell_acc=8 %then offset=offset+8 %else offset=offset+4 %CONTINUE %FINISH %if ptype&7=3 %start ! pardes(ptr)=x'04000000'!pcell_acc&X'FFFF' pardes(ptr)=4; ! previous line when passed on stack offset=offset+4 %continue %finish impabort %REPEAT fn res: ! extra parameters fpr str &record fns rtptype=rtptype&x'fbff'; ! remove bit that indicates formal proc %if rtptype=x'1035' %or rtptype=x'1033' %Start ! string fns and string fn formals pardes(ptr)=x'01000004' pardes(ptr+1)=4 pardes(paramptr+1)=pardes(paramptr+1)+8; ! 2 extra words ptr=ptr+2 %finish entries=ptr-(paramptr+2) pardes(param ptr)=entries %RESULT=addr(pardes(param ptr)) %END %ROUTINE PPJ(%INTEGER JUMP,N) !*********************************************************************** !* PLANT A 'JUMP PERMENTRY(N)' * !* IF JUMP=0 THEN PLANT A CALL * !*********************************************************************** %INTEGER VAL,LAB,INF %CONST %BYTE %INTEGER %ARRAY 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} LAB=0 VAL=WORKA_PLABS(N) INF=PPJINFO(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) EPRECALL2(VAL,addr(pardes(0))) %UNLESS INF&255#0; ! PRECALL MUST BE DONE BEFOR PARAMS ECALL2(VAL,1,(INF>>16)&255,INF&X'FF') %IF INF>>24#0 %THEN ESTKRESULT(0,1,4) %IF LAB>0 %THEN ELABEL(LAB) %END %INTEGER %FN BYTESWOP(%INTEGER VAL) !*********************************************************************** !* PERFORMS A COMPLETE BYTE REVERSAL OF VAL * !*********************************************************************** %SWITCH SW(0:3) %if Host=Perq3 %thenstart %result=Val %finish %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 %EXTERNAL %ROUTINE 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 %LONG %REAL LR %RECORD (RD) TEMP TEMP=OPND I=OPND_D; ! ALL INTEGER UP TO 32 BIT TYPE=OPND_PTYPE&7 PREC=OPND_PTYPE>>4&7 %IF type=1 %AND SWAPMODE=0 %THEN %RETURN %IF TYPE=1 %START; ! INTEGERS %IF PREC=3 %THEN OPND_B0<-I %AND OPND_B1<-I %AND OPND_B2<-I %AND %C OPND_B3<-I %AND %RETURN %IF PREC=4 %THEN %START OPND_D=BYTESWOP(I<<16!(I&X'FFFF')) %RETURN %FINISH %IF PREC=5 %THEN OPND_D=BYTESWOP(OPND_D) %AND %RETURN IMPABORT %FINISH %IF TYPE=2 %THEN %START %IF PREC=5 %START TEMP_R=ICLREALTOPERQ(OPND_R) %IF opnd_ptype&8=0; ! not if R' const 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) %IF opnd_ptype&8=0; ! not if R' const 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 %THEN %RETURN; ! CANT CHANGE SEX HERE ! MIGHT BE USED IN COMPILE TIME OP ! ! the next line can catch afulty programs so comment out when ! compiler is debugged ! ! IMPABORT %FINISH %END %EXTERNAL %ROUTINE CHANGESEX(%INTEGER BASEAD,OFFSET,L) !*********************************************************************** !* ALTERERS INITIALISED DATA FOR A BYTE SEX CHANGE * !*********************************************************************** %OWN %BYTE %INTEGER %ARRAY %FORMAT F(0:X'FFFF') %BYTE %INTEGER %ARRAY %NAME A %INTEGER I,J %IF HOST#TARGET %AND X'10001'#SWAPMODE&X'10001'#0 %START A==ARRAY(BASEAD,F) %MONITOR %UNLESS OFFSET&1=0 I=OFFSET %WHILE L>0 %CYCLE J=A(I) A(I)=A(I!!1) A(I!!1)=J I=I+2; L=L-2 %REPEAT %FINISH %END %EXTERNAL %ROUTINE FILL DTABREFS(%INTEGER %NAME CURRINFRAL) !*********************************************************************** !* PLUGS REFENCES TO THE DIAG TABLES FOR CURRINF WHICH ARE * !* ABOUT TO BE GENERATED AT CAS(DAREA). THE LIST POPPED HAS * !* S1=AREA 1=CODE, DAREA FOR DIAGNOSTIC AREA * !* S2= THE OFFSET OF INSTRUCTION OR FORWARD POINTER * !* S3=THE WORD BEFORE FILLING - NOT USED FOR AREA 1 * !*********************************************************************** %INTEGER Q,JJ,KK %WHILE CURRINFRAL#0 %CYCLE POP(CURRINFRAL,Q,JJ,KK) %IF Q=1 %THEN %START ESETMARKER(JJ,CAS(DAREA)) %FINISH %ELSE %START KK=CAS(DAREA) %IF Host#Target %AND swapmode&1#0 %THEN kk=kk<<16!(KK>>8&255) ED2(Q,JJ+2,KK&X'FFFF') ! THE PLUG ONLY ALLOWS 16 BIT OFFSET ! BUT TABLE FORM ALLOWS 18 BIT OFFSET ! EXTRA PLUG NEEDED IF >65K DIAGS %FINISH %REPEAT %END %if Host=Perq3 %or host=amdahl %thenstart %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 %finish %EXTERNAL %INTEGER %FN ETEMPSPACE(%INTEGER SIZE{in bytes},align) !*********************************************************************** !* provides a temporary for the emachine in the current stack frame * !* which kept in workarea 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 align=align-1 k=(k+align)&(~align) WORKA_N=K+SIZE %RESULT=WORKINGINF_DISPLAY-(K+SIZE) %END %EXTERNALINTEGERFN EPERMSPACE(%INTEGER SIZE,ALIGN) !*********************************************************************** !* as etempspace but allocates in gla * !*********************************************************************** %integer k align=align-1 glaca=(glaca+align)&(~align) k=glaca; glaca=glaca+size %result=k %end %EXTERNAL %ROUTINE GENERATE(%RECORD (TRIPF) %ARRAY %NAME TRIPLES, %INTEGER CURRLEVEL, %ROUTINE dud WSP(%INTEGER %NAME PLACE, %INTEGER SIZE)) ! should be%EXTERNAL %ROUTINE GENERATE(%RECORD (TRIPF) %ARRAY %NAME TRIPLES, %INTEGER CURRLEVEL, ! should be %ROUTINE GET WSP(%INTEGER %NAME PLACE, %INTEGER SIZE)) !*********************************************************************** !* EVALUATE A LIST OF TRIPLES PLABTING CODE IN BUFFERS * !*********************************************************************** %INTEGER %FN %SPEC JCODE(%INTEGER TFMASK) %ROUTINE %SPEC VMY %ROUTINE %SPEC REXP %ROUTINE %SPEC STARSTAR %ROUTINE %SPEC ISTARSTAR %ROUTINE %SPEC CIOCP(%INTEGER N,xtra) %INTEGER %FN %SPEC RLEVTOLEVEL(%INTEGER RLEV) %INTEGER %FN %SPEC LOAD(%RECORD (RD) %NAME OP, %INTEGER mode) %INTEGER %FN %SPEC STRINGLBAD(%RECORD (TAGF) %NAME TCELL) %INTEGER %FN %SPEC RECORDELAD(%RECORD (TAGF) %NAME TCELL, %INTEGER SPTYPE,XTRA) %ROUTINE %SPEC INDLOAD(%INTEGER TYPE,SIZE,OFFSET) %ROUTINE %SPEC INDSTORE(%INTEGER TYPE,SIZE,OFFSET) %ROUTINE %SPEC LOADAD(%RECORD (RD) %NAME OPND) %ROUTINE %SPEC LOADPTR(%RECORD (RD) %NAME OPND,OPND2) %ROUTINE %SPEC DSTORE(%INTEGER TYPE,OPCODE,SIZE,LEVEL,DISP,Adid) %ROUTINE %SPEC CHOP OPERAND(%RECORD (RD) %NAME OPND, %INTEGER PT,X) %ROUTINE %SPEC DFETCH(%INTEGER TYPE,SIZE,LEVEL,DISP,Adid) %ROUTINE %SPEC DFETCHAD(%INTEGER SIZE,LEVEL,DISP,Adid) %ROUTINE %SPEC FETCH LOW AD END(%INTEGER B,D,Adid) %ROUTINE %SPEC FETCH HIGH AD END(%INTEGER B,D,Adid) %ROUTINE %SPEC STORE LOW AD END(%INTEGER B,D,Adid) %ROUTINE %SPEC STORE HIGH AD END(%INTEGER B,D,Adid) ! %RECORD (RD) %NAME OPND1,OPND2,OPND %RECORD (RD) TOPND %RECORD (TRIPF) %NAME CURRT,WORKT,WORKT2 %RECORD (LEVELF) %NAME LINF,CURRINF %RECORD (TAGF) %NAME TCELL %RECORD (LISTF) %NAME LCELL ! %INTEGER C,D,WTRIPNO,JJ,COMM,Both loaded,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 ! %CONST %INTEGER %ARRAY 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'1000084F'{40 PPROF PRINT PROFILE tripsw(79)}, X'1000053F'{41 RTFP TURN RTNAME TO FORMAL}, X'10000649'{42 ON EVENT1 NO CODE AS YET}, X'10000C4A'{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'1000044E'{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'1000041f'{157 ASSGN FORMAL RT-CODE AS 155}, 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'10000C4B'{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'1000044C'{191 REG TO STORE OPERATION}, 0(*) %CONST %BYTE %INTEGER %ARRAY 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 ! %CONST %INTEGER NISEQS=34 %CONST %BYTE %INTEGER %ARRAY 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}, 11,0,0,0 {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}, 11,0,0,0 {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:79) ! 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; Both loaded=0 OPND1==CURRT_OPND1 OPND2==CURRT_OPND2 XTRA=CURRT_X1 JJ=CURRT_OPERN TRIPINF=TRIPDATA(JJ) %if parm_dcomp#0 %and parm_z#0 %then %c newline %and print this trip(triples,stptr) C=TRIPINF>>28; ! TRIPLE TYPE TRIPVAL=TRIPINF&255 %IF C=0 %THEN %CONTINUE %IF C=1 %THEN ->TRIPSW(TRIPVAL) LRES=0 ! ! CARE IS NEEDED IN DETECTING WHEN OPERANDS ARE REVERSED IN STACK ! The loadop bits are set for indirect via triple operands which ! have some sort of IR in the stack ! %IF JJ>=128 {%AND CURRT_FLAGS&(LOADOP1+LOADOP2)=0} %AND %C 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 comm=comm-EXCHANGE(OPND2,OPND1) ! I-RS THE WRONG WAY ROUND ! FOR NON COMMUTABLE OPS %IF 1<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' %THEN %START ESTKLIT(-x'8000') ESTKLIT(X'7FFF') %FINISH %ELSE %START ESTKLIT(0) ESTKLIT(255) %FINISH EOP(CHK) %FINISH %FINISH OPND1_PTYPE=OPND1_PTYPE-X'10' ->SUSE SW(11): ! Change precision (general) ESTKLIT(Bytes(Currt_optype>>4)) %IF currt_optype&7=2 %THEN c=CVTRR %ELSE c=CVTII EOP(c) Opnd1_ptype=currt_optype ->Suse 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,0) %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,0) %IF CURRT_FLAGS&LOADOP1#0 %AND LRES=0 %THEN EOP(EXCH) %IF CURRT_OPTYPE&7=1 %THEN %START; ! INTEGERS ISTARSTAR %FINISH %ELSE %START 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(CURRT_OPTYPE>>4&15),CURRINF_RBASE,D,0) OPND2_PTYPE=CURRT_OPTYPE 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) %FINISH %ELSE %START CHOP OPERAND(OPND2,x'51',0) LRES=LOAD(OPND2,0) 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,0) EOP(EXCH) %IF DACC<=1 %THEN EOP(INDEX1) %ELSE %IF DACC=2 %THEN EOP(INDEX2) %ELSE %IF %C DACC=4 %THEN EOP(INDEX4) %ELSE %IF DACC=8 %THEN EOP(INDEX8) %ELSE %C ESTKLIT(DACC) %AND EOP(INDEX) %FINISH %ELSE %START; ! RARE CASE GO TO DV FOR SIZE ! ONLY FOR ACCESS OF STRING&RECORD ! ARRAYNAMES LRES=LOAD(OPND2,0); ! full head dvptr on top EREFER(6!!((HALFSWOPPED>>TARGET&1)<<1),2); ! el size halfword out of (un)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(<-) %BEGIN %INTEGER newsize newsize=0 PT=XTRA&255; ! ORIGINAL PT OF LHS HERE %IF PT=0 %THEN PT=CURRT_OPTYPE %IF pt&7=1 %AND pt>>4#opnd2_ptype>>4&15 %THEN newsize=bytes(pt>>4) %IF OPND1_FLAG=2 %START; ! OPERAND A NAME LRES=LOAD(OPND2,0) %IF newsize#0 %THEN estklit(newsize) %AND eop(CVTII) 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&x'ffff',0) %FINISH %ELSE %START; ! OPERAND A POINTER %IF OPND1_FLAG=INDNAME %START; ! POINTER NOT LOADED LRES=LOAD(OPND2,0) %IF newsize#0 %THEN estklit(newsize) %AND eop(CVTII) LOADPTR(OPND1,OPND1) %FINISH %ELSE %START LOADPTR(OPND1,OPND1) LRES=LOAD(OPND2,0) %IF LRES>0 %OR (CURRT_FLAGS&LOADOP1=0 %AND COMM=1) %THEN EOP(EXCH) %IF newsize#0 %THEN %C eop(EXCH) %AND estklit(newsize) %AND eop(CVTII) %AND eop(EXCH) %FINISH INDSTORE(PT&7,BYTES(PT>>4),0) %FINISH %END ->STRES SW(23): ! LOCAL ASSIGNMENT D=BYTES(PTYPE>>4&15) LRES=LOAD(OPND2,0) %IF CURRT_PUSE=CURRT_FLINK %AND OPND2_XB=ESTK %THEN EOP(DUPL) DSTORE(PTYPE&7,ESTORE,D,OPND1_D>>16,OPND1_D&X'FFFF',0) 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 %FINISH %ELSE %START 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) %ELSE %IF %C D>0 %OR CURRT_OPERN=CLSHIFT %THEN ESTKLIT(D) %AND EOP(ISHLL) %ELSE %C ESTKLIT(D) %AND EOP(ISHLA) ->STRES TRIPSW(76): ! OPERATE AND ASSIGN OPERATION ! PRODUCED BY PNX OPT PASS ONLY %BEGIN %CONST %BYTE %INTEGER %ARRAY OOPC(128:135)=IADDST,ISUBST,IXORST,IORST,IMULTST, IDIVST,HALT,IANDST LRES=LOAD(OPND2,0) Lres=LOAD(OPND1,0) EOP(EXCH) EOP(OOPC(XTRA)) %END ->STRES TRIPSW(1): ! SET LINE NO D=opnd1_d>>16 %IF D=prev line %THEN %CONTINUE prev line=D ELINESTART(D) %IF PARM_LINE#0 %START ! ESTKLIT(D) ! DSTORE(1,ESTORE,2,CURRINF_RBASE,OPND1_D&X'FFFF',0) %FINISH %IF parm_prof#0 %START Estkdir(zgst,profzgst+4*(D),0,4) Estklit(1) Eop(IADDST) %FINISH %CONTINUE TRIPSW(2): ! RESET STACK PTR TO SAVED VAL DFETCH(1,4,CURRINF_RBASE,OPND1_D,0) %if aux stack=yes %then EOP(EAUXRES) %else %start EOP(SFA) EOP(ISUB) EOP(ASF) %finish %CONTINUE TRIPSW(3): ! SAVE STACK POINTER ! OPND1 IS TEMPORARY(16 BITS) FOR SAVE %if aux stack=yes %then EOP(Eauxsf) %else EOP(SFA) DSTORE(1,ESTORE,4,CURRINF_RBASE,OPND1_D,0) %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*Stack Inc,0) %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*Stack Inc,0) ! 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) %ELSE %START B1=0 %FOR JJ=1,1,XTRA>>16 %CYCLE %IF C&(1<1 %THEN %START DFETCH(1,4,CURRINF_RBASE,D+Stack Inc*(12*JJ-4),0) 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,0) %CONTINUE TRIPSW(72): ! DV BOUND PAIR ! OPND1&2 ARE LB & UB RESPECTIVLY ! XTRA=CURRD<<24!ND<<16!DVDISP D=XTRA&X'FFFF'+12*Stack Inc*(XTRA>>24); ! TRIPLE POSN %IF OPND1_FLAG=SCONST %START; ! LB A CONST ESTKLIT(OPND1_D) DSTORE(1,ESTORE,4,CURRINF_RBASE,D+4*Stack Inc,0) LRES=LOAD(OPND2,0) DSTORE(1,EDUPSTORE,4,CURRINF_RBASE,D,0) %IF OPND1_D#1 %THEN ESTKLIT(OPND1_D-1) %AND EOP(ISUB) %FINISH %ELSE %START LRES=LOAD(OPND1,0)<<1!LOAD(OPND2,0) %IF LRES=B'10' %THEN EOP(EXCH) DSTORE(1,EDUPSTORE,4,CURRINF_RBASE,D,0) EOP(EXCH) DSTORE(1,EDUPSTORE,4,CURRINF_RBASE,D+4*Stack Inc,0) EOP(ISUB); ESTKLIT(1); EOP(IADD) %FINISH C=XTRA>>24&255; ! CURRENT DIMENSION %IF C>1 %THEN EOP(IMULT); ! MULTPLY UP BY LOWER RNAGES DSTORE(1,EDUPSTORE,4,CURRINF_RBASE,D+8*stack Inc,0) %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',0) %FINISH %ELSE %START; ! DV IN SHAREABLE SYMBOL TABLES ESTKADDR(4,OPND1_D&X'FFFF',0,4) %FINISH DSTORE(1,ESTORE,4,CURRINF_RBASE,TCELL_SLINK+4,0) %if aux stack=yes %then eop(eauxsf) %else %if stack down=no %thenc eop(sfa) %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) %if longs aligned=yes %then C=(C+7)&(-8) %else C=(C+3)&(-4); ! TO 64 BIT BNDRY %if Aux stack=yes %or Stack down=no %then Estklit(c) %else ESTKLIT(-C) %FINISH %ELSE %START; ! DYNAMIC NEEDS LOOP ! DFETCH(1,4,CURRINF_RBASE,OPND1_D&X'FFFF'+8*stack Inc,0) %if longs aligned=yes %then c=7 %else c=3 ESTKLIT(C); EOP(IADD) ESTKLIT(-(C+1)) EOP(IAND) %if auxstack=no %and Stack down=yes %then EOP(INEG) %FINISH %if aux stack=yes %then eop(eauxadd) %else eop(ASF) %FINISH EOP(SFA) %if aux stack=no %and stack down=yes;! STACK FRONT ADDRESS=BASE ADDRESS DSTORE(1,ESTORE,4,CURRINF_RBASE,TCELL_SLINK&x'ffff',0) %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,0); ! STEP TO ESTACK PPJ(JINTZ,11); ! USING ZERO=FALSE EQUIVALENCE %CONTINUE TRIPSW(7): ! FOR PREAMBLE LRES=LOAD(OPND1,0); ! 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&X'ffff',0) INDSTORE(1,4,0) %FINISH %ELSE DSTORE(1,ESTORE,4,TCELL_UIOJ>>4&15,TCELL_SLINK&X'ffff',0) %CONTINUE TRIPSW(8): ! FOR POSTAMBLE %CONTINUE TRIPSW(9): ! VALIDATE FOR LRES=LOAD(OPND1,0) LRES=LOAD(OPND2,0) 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),lcell_s1&X'FFFF') %CONTINUE TRIPSW(11): ! FORWARD JUMP _X1 HAS TF&MASK ! OPND1_XTRA HAS LABEL CELL<<16!JUMP CELL LCELL==ASLIST(OPND1_XTRA>>16) %IF Lcell_s1&X'FFFF'=0 %THEN lcell_S1=lcell_s1!glabel %AND glabel=glabel+1 C=JCODE(XTRA) EJUMP(C,lcell_s1&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 %INTEGER %NAME CELL CELL==CURRINF_LABEL %WHILE CELL>0 %CYCLE %IF ASLIST(CELL)_S3=OPND1_D %THEN POP(CELL,S1,S2,S3) %AND %EXIT CELL==ASLIST(CELL)_LINK %REPEAT EDISCARDLABEL(OPND1_D) %END %CONTINUE TRIPSW(13): ! INSERT LABEL ! OPND1_XTRA HAS LABEL CELL LCELL==ASLIST(OPND1_XTRA) %IF Lcell_s1&X'FFFF'=0 %THEN lcell_S1=lcell_s1!glabel %AND glabel=glabel+1 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(LCELL_S1&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,PBITS,INNER H=0; PCHKWORD=0 INNER=Currt_Flags&Bstruct CURRINF_ENTRYAD=GLABEL; ! FOR RETURN=JUMP TO END GLABEL=GLABEL+1 %IF OPND1_D>=0 %THEN %START C=0 TCELL==ASLIST(TAGS(OPND1_D)) PCHKWORD=pardeslist(TCELL) H=TCELL_SNDISP %FINISH %ELSE C=1 PBITS=CURRINF_RBASE<<16!Parm_Chk<<6;! Rlevel and fill with unass %IF INNER=0 %THEN pbits=pbits!2****5 %IF H=0 %THEN H=-1 %IF OPND1_XTRA#0 %THEN %C Eproc2(STRING(OPND1_XTRA),Pbits!C<<1!1,pchkword,H) %ELSE %IF OPND1_D>=0 %THEN %C Eproc2(STRING(ADDR(WORKA_LETT(WORKA_WORD(OPND1_D)))),Pbits,pchkword,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,0) %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,4,LINF_RBASE,LINF_DIAGINF,0) %CONTINUE TRIPSW(18): ! RTBAD FN-MAP ERROR EXIT WORKT==TRIPLES(CURRT_BLINK); ! PREVIOUS TRIPLE %CONTINUE %IF WORKT_OPERN=RTXIT %OR WORKT_OPERN=XSTOP %OR %C (WORKT_OPERN=BJUMP %AND WORKT_X1&15=15) %IF PARM_OPT#0 %THEN %START Eprecall2(Worka_plabs(2),addr(pardes(14))) ESTKLIT(0) ESTKLIT(21) EOP(PUSHVAL) %if PARAMS BWARDS=yes %then EOP(EXCH) 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) %FINISH %ELSE %START ELABEL(CURRINF_ENTRYAD); ! ENTRAD HOLDS LAB FOR RETURN %IF Aux Stack=yes %and CURRINF_AUXSBASE>0 %THEN %START DFETCH(1,4,CURRINF_RBASE,CURRINF_AUXSBASE,0) EOP(EAUXRES) %FINISH 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 Eprecall2(Worka_plabs(2),addr(pardes(14))) 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,0); ! 32 BIT AD OF STRING2 EOP(DUPL); EREFER(0,1) LRES=LOAD(OPND1,64) 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,0) EPRECALL2(WORKA_PLABS(24),addr(pardes(5))) EOP(PUSHVAL) LRES=LOAD(OPND1,64) EOP(PUSHVAL) PPJ(0,24) OPND1_FLAG=7; ! RESULT IS LOCAL %CONTINUE TRIPSW(39): ! GENERAL STRING ASSIGN LRES=LOAD(OPND1,0); ! PTR (2 WORDS) TO LHS ! Ptr has address over lmax %IF opnd1_ptype&255>4&15,D&X'FFFF',0) EREFER(0,2); EOP(ESTORE) %FINISH %ELSE %START; ! ASSIGN CONSTANT STRING LRES=LOAD(OPND2,0) LRES=LOAD(OPND1,64) ESTKLIT(OPND2_XTRA+1) EOP(MVB) %FINISH %CONTINUE %FINISH LRES=LOAD(OPND2,0) EOP(DUPL); LRES=LOAD(OPND1,64) 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 EPRECALL2(WORKA_PLABS(18),addr(pardes(9))) LRES=LOAD(OPND1,0); ! SET BY GETPTR (IE LOADED) LRES=LRES<<1!LOAD(OPND2,0); ! 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 %C OPND==OPND2 %AND BFFLAG=1 %AND ->NULLSC %IF CURRT_FLAGS&LOADOP2#0 %START; ! OPND2 NOT LOADED LRES=LOAD(OPND1,0) %UNLESS currt_flags&loadop1=0 LRES=LOAD(OPND2,0) %FINISH %ELSE %IF CURRT_FLAGS&LOADOP1=0 %START; ! BOTH LOADED %FINISH %ELSE %START; ! ONLY 2 LDED BACK COMP BFFLAG=1 LRES=LOAD(OPND1,0) %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 %FINISH %ELSE %START EPRECALL2(WORKA_PLABS(28),addr(pardes(5))) 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,0) 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,0); ! 32 BIT ADDRESS TO ESTACK DSTORE(1,EDUPSTORE,4,CURRINF_RBASE,D,0); ! 32 BIT ADDR TO WK AREA EREFER(0,1) Estklit(4); Eop(CVTII) DSTORE(1,ESTORE,4,CURRINF_RBASE,D+4,0); ! 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' EPRECALL2(WORKA_PLABS(16),addr(pardes(20))) DFETCHAD(4,CURRINF_RBASE,D+4,0) DFETCH(1,4,CURRINF_RBASE,D,0) 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 %FINISH %ELSE LRES=LOAD(OPND2,0); ! 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,0) 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,64); ! 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,0) DFETCH(1,4,CURRINF_RBASE,D+4,0) GET WSP(C,1) ESTKLIT(16); EOP(ISHRL); ! BYTES USED DSTORE(1,EDUPSTORE,4,CURRINF_RBASE,C,0) EOP(IADD) EOP(EXCH) DFETCH(1,4,CURRINF_RBASE,D+4,0) ESTKLIT(x'ffff') EOP(IAND) DFETCH(1,4,CURRINF_RBASE,C,0); ! fetch back bytes used EOP(ISUB); ! and subtract from orig DSTORE(1,EDUPSTORE,4,CURRINF_RBASE,C,0) ESTKLIT(1); EOP(IADD) EOP(MVB); ! call move overlapping DFETCH(1,4,CURRINF_RBASE,C,0); estklit(4); eop(cvtii); 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,0) 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,64); ! 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,0) EOP(index1) %FINISH %ELSE EOP(EXCH) %IF lres#0 EOP(index1) %FINISH 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 d=opnd2_d; ! -1 for skip symbol LRES=LOAD(OPND2,0) CIOCP(OPND1_D,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 %C 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 PUSH(FPHEAD,FPPTR,C,D) EPRECALL2(TCELL_SNDISP,pardeslist(tcell)) 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 ECALL2(TCELL_SNDISP,1,JJ,FPPTR) %FINISH %ELSE %IF TCELL_PTYPE&X'400'#0 %START DFETCH(1,4,TCELL_UIOJ>>4&15,TCELL_SNDISP,0) ! proc desc ESTKLIT(FPPTR) EOP(ARGPROC); ! CALL FORMAL PROCEDURE %FINISH %ELSE %START C=TCELL_UIOJ>>4&15 ! %IF C>0 %THEN PI1(ILL,-4*(C+1));! DISPLAY PTR FOR INTERNAL RTS D=TCELL_SNDISP ECALL2(D,C+1,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,0) EOP(EINTRES) %CONTINUE TRIPSW(45): ! FN RESULT ASSIGNMENT ! CALLED BEFORE RETURN TO CALLER %if params bwards=yes %then D=P2 %else d=currinf_psize-4 LRES=LOAD(OPND2,0) %IF OPND2_PTYPE&7=5 %START; ! STRING FN RESULTS EOP(DUPL); EREFER(0,1) ESTKPAR(0,D,0,4); EOP(EXCH); ! The second parameter offset is model dependent ESTKLIT(1); EOP(IADD); EOP(MVB) ESTKPAR(0,D,0,4); ! THE "RESULT" EOP(EINTRES) %CONTINUE %FINISH %IF Opnd1_ptype&7=3 %START; ! record functions estkpar(0,D,0,4) tcell==aslist(tags(opnd1_d)) estklit(Tcell_acc) Eop(MVB) estkpar(0,D,0,4) 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 c=opnd1_ptype&7 %if c>=3 %then estkresult(0,0,4) {addr of length 4} %elsec ESTKRESULT(0,C,BYTES(OPND1_PTYPE>>4&15)) ->stres TRIPSW(27): ! RECOVER MAP RESULT ! CALLED AFTER RETURN TO CALLER OPND1_FLAG=9 OPND1_XB=ESTK ESTKRESULT(0,1,4) ->stres 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); ! WORDS FOR STRING VALUE impabort; ! No string values ESTKLIT(-C); EOP(ASF) FPPTR=FPPTR+C LRES=LOAD(OPND2,0); ! PTR TO STRING %IF C<=32 %START; ! SHORT STRINGS EOP(SFA) ESTKLIT(C) %FINISH %ELSE %START; ! 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 %FINISH %FINISH %ELSE %IF OPND1_PTYPE&7=3 %START; ! RECORD BY VALUE C=(D+3)&(-4) %IF fpptr&3=2 %START estklit(0); estklit(2); eop(cvtii) eop(pushval); fpptr=fpptr+2 %FINISH %IF OPND2_FLAG=SCONST %THEN %Start %for D=4,4,C %cycle Estklit(0); Eop(Pushval) %repeat %else LRES=LOAD(OPND2,0) %if c=4 %then Erefer(0,4) %and Eop(PUSHVAL) %else %Start ESTKLIT(C); EOP(Pushbytes) %finish %finish FPPTR=FPPTR+C %FINISH %ELSE %START LRES=LOAD(OPND2,0) C=OPND1_PTYPE %IF C=X'62' %THEN %START %if longs aligned=yes %and fpptr&7=4 %Start ! Estklit(0); Eop(PUSHVAL) Fpptr=Fpptr+4 %finish EOP(PUSHVAL) FPPTR=FPPTR+8 %FINISH %ELSE %IF C=X'52' %THEN %START EOP(PUSHVAL) FPPTR=FPPTR+4 %FINISH %ELSE %START %IF C=X'31' %THEN estklit(4) %AND EOP(CVTII) %AND C=X'51' %IF C=X'41' %THEN ESTKLIT(4) %AND EOP(CVTII) EOP(PUSHVAL) FPPTR=FPPTR+bytes(c>>4) %FINISH %FINISH %CONTINUE TRIPSW(29): ! GET 32 BIT ADDRESS LOADAD(OPND1) ->STRES TRIPSW(30): ! GET POINTER FOR %NAME LOADPTR(OPND1,OPND2) ->STRES TRIPSW(31): ! PARAM PASSING (2) NORMAL PTRS LRES=LOAD(OPND2,0) PTYPE=OPND1_PTYPE&255; ! FOR PARAM %IF PTYPE=X'35' %START; ! STRING(2 WORD) PTRS FPPTR=FPPTR+4 EOP(EXCH) %if params bwards=yes EOP(PUSHVAL) %FINISH EOP(PUSHVAL) FPPTR=FPPTR+4 %CONTINUE TRIPSW(32): ! PARAM PASSING(3) ARRAYS %if longs aligned=yes %and fpptr&7#0 %Start ! Estklit(0); EOP(PUSHVAL) fpptr=fpptr+4 %finish ! ALSO (4) PASS RT PARAM SAME CODE ! when rt params are 64 bits in size LRES=LOAD(OPND2,0) 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 LRES=LOAD(OPND2,64) ESTKLIT(255) ESTKLIT(4); EOP(CVTII); ! as 4 byte integer %if PARAMS BWARDS=YES %then EOP(EXCH) 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 DFETCH(1,4,TCELL_UIOJ>>4&15,TCELL_SNDISP,0) %FINISH %ELSE %START %IF tcell_uioj&15=14 %THEN c=0 %ELSE C=TCELL_UIOJ>>4&15 D=TCELL_SNDISP %IF D=0 %THEN D=ENEXT PROC %AND TCELL_SNDISP=D EPROCREF(D,C); ! This puts ptr to proc in estack %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_Slink&X'ffff',0) %FINISH %ELSE %IF opnd2_d&7=5 %AND opnd2_d&X'c00'#0 %START ! string name to type general lres=load(opnd1,0) Eop(EXCH) Estklit(16); Eop(ISHLL) Estklit(Opnd2_d&255); Eop(IOR) %IF Params bwards=no %THEN eop(EXCH) %FINISH %ELSE %START LRES=LOAD(OPND1,0); ! 32 BIT ADDRESS ESTKLIT(OPND2_D) %IF Params bwards=no %THEN 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 %THEN %START Eprecall2(Worka_plabs(2),addr(pardes(14))) ESTKLIT(0) ESTKLIT(X'802') %if PARAMS BWARDS=yes %then EOP(EXCH) 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,0) ESWITCHJUMP(TCELL_SNDISP); ! JUMP TO INDEXED JUMP %CONTINUE TRIPSW(37): ! REAL TO INTGER INTPT(OPND1) LRES=LOAD(OPND1,0) ESTKLIT(Bytes(currt_optype>>4)) EOP(EFLOOR) OPND1_XB=0 OPND1_PTYPE=Currt_Optype %CONTINUE TRIPSW(36): ! REAL TO INTEGER AS INT LRES=LOAD(OPND1,0) ESTKLIT(bytes(Currt_optype>>4)); EOP(RNDRI) OPND1_XB=0 OPND1_PTYPE=Currt_Optype %CONTINUE TRIPSW(78): ! REAL to INT as TRunc LRES=LOAD(OPND1,0) ESTKLIT(bytes(Currt_optype>>4)) EOP(TNCRI) OPND1_XB=0 OPND1_PTYPE=Currt_Optype %CONTINUE TRIPSW(38): ! INTEGER TO STRING AS TOSTRING GET WSP(D,1) LRES=LOAD(OPND1,0) DSTORE(1,ESTORE,1,CURRINF_RBASE,D+2,0) ESTKLIT(1) DSTORE(1,ESTORE,1,CURRINF_RBASE,D+3,0) 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,0) TCELL==ASLIST(TAGS(OPND1_D)) C=TCELL_SLINK %IF TCELL_PTYPE&X'3FFF'=X'33' %THEN %C C=RECORDELAD(TCELL,OPND1_PTYPE,OPND1_XTRA) DSTORE(1,ESTORE,8,TCELL_UIOJ>>4&15,C&X'ffff',0) %FINISH %ELSE %START IMPABORT %UNLESS OPND1_FLAG=INDIRECT %OR OPND1_FLAG=REFTRIP %OR %C OPND1_FLAG=INDNAME %OR PARM_FAULTY#0 LRES=LOAD(OPND2,0) %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,0) %IF OPND1_FLAG=DNAME %START; ! LOCAL PTR TCELL==ASLIST(TAGS(OPND1_D)) C=TCELL_SLINK %IF TCELL_PTYPE&X'3FFF'=X'33' %THEN %C C=RECORDELAD(TCELL,OPND1_PTYPE,OPND1_XTRA) DSTORE(1,ESTORE,D,TCELL_UIOJ>>4&15,C&X'ffff',0) %CONTINUE %FINISH %IF OPND1_FLAG=INDNAME %THEN LOADAD(OPND1) %ELSE %START %UNLESS CURRT_FLAGS&LOADOP1=0 %START; ! DEST NOT LOADED LRES=LOAD(OPND1,0) %FINISH %ELSE EPROMOTE(1+d>>2) %IF OPND1_FLAG=INDIRECT %AND OPND1_XTRA>0 %THEN %C ESTKLIT(OPND1_XTRA) %AND EOP(index1) %FINISH INDSTORE(1,D,0) %CONTINUE TRIPSW(62): ! RECORD ASSIGNMENT %IF OPND2_FLAG=SCONST %THEN %START LRES=LOAD(OPND1,0) BULKM(0,XTRA,OPND2_D) %CONTINUE %FINISH LRES=LOAD(OPND2,0) %IF CURRT_FLAGS&LOAD OP1=0 %THEN JJ=EXCHANGE(OPND1,OPND2) LRES=LOAD(OPND1,0) BULKM(1,XTRA,0) %CONTINUE TRIPSW(64): ! AAINC INCREMENT RECORD RELATIVE ! ARRAY ACCESS BY RECORD BASE(OPND1) ! TO GIVE ABSOLUTE ACCESS. LRES=LOAD(OPND1,0) LRES=LOAD(OPND2,0); ! THE RELATIVE ACCESS EOP(index1); ! ADDITION ->STRES TRIPSW(65): ! AHADJ ARRAY MAPPING OPND1 1 ! HAS ADJUSTMENT OPND2 THE HEAD ! ARRAY PTYPE<<4!MODE IS IN XTRA LRES=LOAD(OPND1,0); ! 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 %C 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 jj=jj&x'ffff' %IF XTRA&1=0 %THEN %START FETCH LOW AD END(D,JJ,0) %FINISH %ELSE %START FETCH HIGH AD END(D,JJ,0) EOP(IADD) FETCH LOW AD END(D,JJ,0) %FINISH %CONTINUE %FINISH LRES=LOAD(OPND2,0); ! ARRAY HEAD BEFORE ADJMNT %IF XTRA&1=0 %START; ! ARRAY MAPPING OPND1 IS BASE EOP(EXCH); EOP(DISCARD); ! DISCARD OLD BASE %FINISH %ELSE %START EOP(EXCH) EPROMOTE(3) EOP(IADD); ! ADDRESSES ADDED EOP(EXCH) %FINISH %CONTINUE TRIPSW(73): ! on event1 On entering the routine %if aux stack=yes %then Eop(EAUXSF) %else Eop(SFA) Dstore(1,Estore,4,currinf_rbase,currinf_oninf+12,0) %CONTINUE TRIPSW(74): ! on event2 at the re-entry point Glaca=(Glaca+3)&(-4) Efix(2,Glaca,1,X'80000000' {=CA}) Currinf_Onword=Currinf_Onword!Glaca; ! Offset of resumption address Glaca=Glaca+4 Estkresult(0,2,8); ! 8 Bytes set by Oncond Dstore(2,Estore,8,currinf_rbase,currinf_oninf,0); ! and stored Dfetch(1,4,currinf_Rbase,Currinf_Oninf+12,0); ! Stack front Eop(Eauxres); ! Is restored to value saved at TRIPSW(73) %CONTINUE TRIPSW(75): ! Signal event spring a soft trap ! opnd1_d has thge level (constant) ! opnd2 is the event & subevent combined linf==worka_levelinf(opnd1_d) %IF linf==currinf %OR currinf_flag<=2 %START ! Right level or only begin block exit %IF linf##currinf %START; ! Force begin block exit D=Estkmarker; ! By changing diags pointer(cf tripsw(17)) push(Linf_ral,1,D,0) dstore(1,estore,2,Linf_rbase,Linf_diaginf,0) %FINISH ! Now to ndiags via monitor exit Eprecall2(Worka_plabs(2),addr(pardes(14))) lres=load(opnd2,0) Estklit(0) %if PARAMS Bwards=No %then Eop(EXCH) eop(Pushval) eop(Pushval) PPJ(0,2) %CONTINUE %FINISH ! Must force a routine exit before signalling ! so call ndiags directly giving a faked LNB D=Known Xref(1); ! Ndiags reference Eprecall2(D,addr(pardes(14))) lres=Load(opnd2,0) Eop(Pushval) Estklit(0) Eop(Pushval) Eop(EOLDLNB) Eop(Pushval) Estklit(0) Eop(Pushval) Ecall2(D,1,4,16); ! does not return %CONTINUE TRIPSW(79): ! Pprofile output profiling info Eprecall2(Known xref(6),addr(pardes(2))) Estkaddr(Gla,profgla,0,4) Eop(Pushval) Ecall2(Known xref(6),1,1,4) %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 Estklit(OPND1_D); ! FOR *PUTS ALSO %IF opnd1_d>>16=0 %THEN jj=2 %ELSE jj=4 Estklit(jj) Eop(HALT) %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&x'ffff'+OPND1_XTRA %IF D=1 %THEN DFETCHAD(C,TCELL_UIOJ>>4&15,JJ,0) %ELSE %IF D=2 %THEN %C DSTORE(1,ESTORE,C,TCELL_UIOJ>>4&15,JJ,0) %ELSE %C DFETCH(1,C,TCELL_UIOJ>>4&15,JJ,0) %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) %FINISH %ELSE %START %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,0) 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 %INTEGER %FN LOAD(%RECORD (RD) %NAME OPND, %INTEGER mode) !*********************************************************************** !* LOAD OPERAND OPND INTO TOP OF NEST(ESTACK) * !* 2**6 of Mode set to omit Unassigned check * !*********************************************************************** %INTEGER K,KK,X,PREG,B,D,RES,PTYPE,TYPE,PREC,adid,Chkass %STRING (255) SVAL %LONG %REAL RVAL %RECORD (RD) ROPND %RECORD (TRIPF) %NAME REFTRIP %RECORD (TAGF) %NAME TCELL %SWITCH SW(0:9) Adid=0 K=OPND_FLAG RES=1; ! SOMETHING LOADED PTYPE=OPND_PTYPE TYPE=PTYPE&15 PREC=PTYPE>>4&15 Chkass=PARM_CHK Chkass=0 %IF Mode&64#0 %OR 1<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 %OR type=10 %THEN %START; ! Type 10 is preformated(hex) real in target form ! Only found when cross compilng %IF HOST#TARGET %AND type=2 %THEN REFORMATC(OPND) ESTKRCONST(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))) %ELSE %START 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 Adid=addr(lett(word(opnd_d))) TCELL==ASLIST(TAGS(OPND_D)) B=TCELL_UIOJ>>4&15 Chkass=0 %IF B=0 K=BYTES(OPND_PTYPE>>4&15) %IF TCELL_PTYPE&X'3FFF'=X'33' %START KK=RECORDELAD(TCELL,PTYPE,OPND_XTRA) %FINISH %ELSE %IF TYPE=5 %THEN KK=STRINGLBAD(TCELL) %ELSE KK=TCELL_SLINK %IF TYPE=5 %THEN DFETCHAD(1,B,KK&X'FFFF',Adid) %ELSE %C DFETCH(TYPE,K,B,KK&X'FFFF',Adid) LDED: %IF TYPE=1 %AND PREC<4 %THEN OPND_PTYPE=X'41' %IF Chkass#0 %START %IF type=5 %THEN Erefer(0,2) Eop(UCHECK) %IF type=5 %THEN Eop(Eaddress) %FINISH OPND_FLAG=9 OPND_XB=ESTK %RESULT=RES SW(5): ! INDIRECT VIA DICTIONARY ! ONLY RECORD SCALAR(_XTRA>=0) ! OR POINTER(_XTRA<0) Adid=addr(lett(word(opnd_d))) TCELL==ASLIST(TAGS(OPND_D)) B=TCELL_UIOJ>>4&15 Chkass=0 %IF B=0 %IF TYPE=5 %AND OPND_XTRA<0 %START; ! STRING POINTER FETCH HIGH AD END(B,TCELL_SLINK&x'ffff',Adid) %FINISH %ELSE DFETCH(1,4,B,TCELL_SLINK&x'ffff',Adid) Eop(UCHECK) %IF Chkass#0 ->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,64) %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,64) %FINISH IFETCH: KK=OPND_XTRA KK=0 %IF KK<0 %IF TYPE=5 %START ESTKLIT(KK) %AND EOP(index1) %IF KK>0 %FINISH %ELSE %START INDLOAD(TYPE,BYTES(PREC),KK) %FINISH ->LDED SW(7): ! I-R IN A STACK FRAME B=OPND_D>>16; D=OPND_D&X'FFFF' Chkass=0 %IF B=0 %IF TYPE=5 %OR type=3 %THEN %START %IF OPND_XTRA=M'DUPL' %THEN DFETCH(1,4,B,D,0) %ELSE %START %if Stack Down=yes %then d=d+opnd_xtra-1 DFETCHAD(1,B,D,0) %FINISH %FINISH %ELSE %START %IF OPND_XTRA=M'ARRH' %THEN FETCH HIGH AD END(B,D,Adid) %ELSE %C DFETCH(TYPE,BYTES(PREC),B,D,0) %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,64) SW(9): ! I-R IN A REGISTER PREG=OPND_XB %RESULT=0 %END %INTEGER %FN 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&x'ffff' B=TCELL_UIOJ>>4&15 %IF B=0 %THEN %RESULT=D INF==WORKA_LEVELINF(RLEVTOLEVEL(B)) X=INF_DISPLAY %if D>4&15 XDISP=XDISP&X'FFFF' %IF B=0 %THEN %RESULT=D+XDISP inf==worka_levelinf(rlevtolevel(b)) %if d>4&7) ! %IF 1<SW(K) SW(*): ! INVALID IMPABORT %IF parm_faulty=0; ! can occurr with gross errors x=load(opnd,0) Eop(EADDRESS) ->lded SW(2): ! DNAME Adid=addr(lett(word(opnd_d))) TCELL==ASLIST(TAGS(OPND_D)) B=TCELL_UIOJ>>4&15 %IF TCELL_PTYPE&X'3FFF'=X'33' %THEN D=RECORDELAD(TCELL,PTYPE,X) %ELSE %IF %C PTYPE&255=X'35' %THEN D=STRINGLBAD(TCELL) %ELSE D=TCELL_SLINK DFETCHAD(BYTES(PTYPE>>4&15),B,D&X'FFFF',Adid) 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,0) %IF PTYPE&255=X'35' %THEN X=X+4 EREFER(X,4); ! ADDRESS IN ESTACK ->LDED SW(5): ! INDIRECT VIA PTR Adid=addr(lett(word(opnd_d))) TCELL==ASLIST(TAGS(OPND_D)) B=TCELL_UIOJ>>4&15 D=TCELL_SLINK&x'ffff' %IF PTYPE&X'FF'=X'35' %AND OPND_XTRA<0 %START; ! STRING POINTER FETCH HIGH AD END(B,D,Adid) ->LDED %FINISH DFETCH(1,4,B,D,Adid) ->INC ADDR SW(6): ! INDIRECT OFFSET REFTRIP==TRIPLES(OPND_D) %IF REFTRIP_PUSE#WTRIPNO %THEN %START ROPND=OPND ROPND_PTYPE=REFTRIP_OPTYPE ROPND_FLAG=8 LRES=LOAD(ROPND,0) %FINISH INC ADDR: ! X>=0 RECORD: X<0 POINTER %IF X>0 %THEN ESTKLIT(X) %AND EOP(index1) ->LDED SW(7): ! LOCAL-IR IN BASE&OFFSET FORM B=OPND_D>>16 D=OPND_D&X'FFFF' %if stack down=yes %start %if opnd_xtra<=0 %then opnd_xtra=268;! omission in pass 2 %if ptype=x'35' %or ptype=X'33' %then d=d+opnd_xtra-1 %finish DFETCHAD(BYTES(PTYPE>>4&7),B,D,0) ->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,Adid %SWITCH SW(0:9) Adid=0 PTYPE=OPND_PTYPE X=OPND_XTRA K=OPND_FLAG ->SW(K) SW(*): ! INVALID IMPABORT %IF parm_faulty=0; ! can occurr with gross errors x=load(opnd,0) Eop(EADDRESS) ->lded SW(2): ! DNAME Adid=addr(lett(word(opnd_d))) TCELL==ASLIST(TAGS(OPND_D)) %IF TCELL_PTYPE&X'3FFF'=X'33' %THEN %START D=RECORDELAD(TCELL,PTYPE,X) %FINISH %ELSE %IF PTYPE&255=X'35' %THEN D=STRINGLBAD(TCELL) %ELSE D=TCELL_SLINK %IF PTYPE&255=X'35' %THEN %START PTYPE=CURRT_X1>>16 DFETCHAD(1,TCELL_UIOJ>>4&15,D&X'FFFF',Adid) ->STR %FINISH DFETCHAD(BYTES(OPND_PTYPE>>4&7),TCELL_UIOJ>>4&15,D&X'FFFF',Adid) 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,0) %IF PTYPE&255=X'35' %THEN INDLOAD(1,8,X) %AND ->SLDED INDLOAD(1,4,X) ->LDED SW(5): ! INDIRECT VIA DICT Adid=addr(lett(word(opnd_d))) 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&x'ffff',Adid) ->LDED %FINISH DFETCH(1,4,TCELL_UIOJ>>4&15,TCELL_SLINK&x'ffff',Adid) ->INC ADDR SW(6): ! INDIRECT OFFSET REFTRIP==TRIPLES(OPND_D) %IF REFTRIP_PUSE#WTRIPNO %THEN %START ROPND=OPND ROPND_PTYPE=REFTRIP_OPTYPE ROPND_FLAG=8 LRES=LOAD(ROPND,0) %FINISH INC ADDR: ! FOR RECORD ELEMENTS %IF X>0 %THEN ESTKLIT(X) %AND EOP(index1) 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') %ELSE %START CHOP OPERAND(OPND2,x'51',0) LRES=LOAD(OPND2,0) ! FOR STRINGNAMES PTR NOW LOADED ! FR STRINGARRAYNAMES DVBASE NOW LDED ! HAVE TO EXTRACT ELSIZE AND DECREMENT BY 1 %IF PTYPE&X'300'#0 %THEN %START d=6 %if 1<STR SW(8): ! A TRIPLE MEANS PREVIOUSLY USED ! POINTER A SECOND TIME REFTRIP==TRIPLES(OPND_D) IMPABORT %UNLESS REFTRIP_OPERN=GETPTR LRES=LOAD(OPND,0) %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 %ELSE %START 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))) %FINISH %ELSE %START LRES=LOAD(OPND2,64); ! 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 %THEN %START ESTKLIT(BYTESWOP(CTABLE(DVPOS+3*C-1))) %FINISH %ELSE %START LRES=LOAD(DOPND,64); ! fetch dv ptr EREFER(12*C-4,4); ! MULTIPLIER %FINISH EOP(IMULT) %FINISH %END %ROUTINE REXP !*********************************************************************** !* CALLS A PERM ROUTINE TO PERFORM REAL**REAL * !*********************************************************************** %IF currt_optype>>4=6 %THEN estklit(10) %ELSE ESTKLIT(9) 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,B %record(levelf)%name inf %RECORD (TAGF) %NAME TCELL OLDPT=OPND_PTYPE&255 OPND_PTYPE=OPND_PTYPE&X'FF00'!NEWPT %IF OPND_FLAG=9 %THEN IMPABORT %IF XOFFSET<0 %THEN %RETURN %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&x'ffff' OPND_D=(TCELL_UIOJ>>4&15)<<16!S1 OPND_FLAG=LOCAL IR %FINISH %IF OPND_FLAG=INDIRECT %OR OPND_FLAG=INDNAME %THEN %C OPND_XTRA=OPND_XTRA&X'FFFF'+XOFFSET %IF OPND_FLAG=LOCALIR %THEN %START B=opnd_d>>16 inf==worka_levelinf(rlevtolevel(b)) %unless b=0 %IF stack down=no %or B=0%or opnd_d&x'ffff'>4) S2=BYTES(NEWPT>>4) OPND_D=OPND_D+S1-S2-XOFFSET %FINISH %FINISH %END %INTEGER %FN 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 %THEN %RESULT=I I=I+1 %REPEAT %END %ROUTINE DSTORE(%INTEGER TYPE,OPCODE,SIZE,RLEVEL,DISP,Adid) !*********************************************************************** !* 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,Adid) %IF OPCODE=EDUPSTORE %THEN EOP(EXCH) %AND EOP(DUPL) STORE HIGH AD END(RLEVEL,DISP,Adid) %IF OPCODE=EDUPSTORE %THEN EOP(EXCH) %ELSE DFETCH(TYPE,SIZE,RLEVEL,DISP,Adid) EOP(OPCODE) %FINISH %END %ROUTINE DFETCHAD(%INTEGER SIZE,RLEVEL,DISP,Adid) !*********************************************************************** !* FETCH ADDRESS OF DISP(BYTES) IN DISPLAY 'LEVEL' * !* SIZE IS NEED BECAUSE OF WRONG END LOW ADDRESS FOR STACKS * !*********************************************************************** DFETCH(0,SIZE,RLEVEL,DISP,Adid) EOP(EADDRESS) %END %ROUTINE DFETCH(%INTEGER TYPE,SIZE,RLEVEL,DISP,Adid) !*********************************************************************** !* FETCH SIZE(BYTES) FROM DISP(BYTES) IN DISPLAY 'LEVEL' * !*********************************************************************** %INTEGER LEVELCODE,offset %RECORD (LEVELF) %NAME INF %SWITCH SW(0:3) %IF TYPE=1 %AND SIZE=8 %START FETCH HIGH AD END(RLEVEL,DISP,Adid) FETCH LOW AD END(RLEVEL,DISP,Adid) %RETURN %FINISH %IF RLEVEL=0 %THEN LEVELCODE=0 %ELSE %IF RLEVEL=CURRINF_RBASE %THEN %C LEVELCODE=1 %ELSE LEVELCODE=2 ->SW(LEVELCODE) SW(*): ! FUNNY SIZES IMPABORT SW(0): ! GLOBAL FETCH ESTKDIR(2 {gla},DISP,Adid,SIZE) %RETURN SW(1): ! LOCAL FETCH %IF dispparam %if Stack down=no %then offset=disp-currinf_display %else %c offset=CURRINF_DISPLAY-(DISP+SIZE) ESTKDIR(0 {stack},offset,Adid,SIZE) %RETURN SW(2): ! INTERMEDIATE WORD FETCH INF==WORKA_LEVELINF(RLEVTOLEVEL(RLEVEL)) %IF disp>inf_display %THEN %START %if Stack down=no %then offset=disp-inf_display %else %c offset=INF_DISPLAY-(DISP+SIZE) ESTKGLOBAL(RLEVEL,offset,Adid,SIZE) %RETURN %FINISH param: estkpar(Rlevel,disp,Adid,size) %END %ROUTINE FETCH HIGH AD END(%INTEGER B,D,Adid) !*********************************************************************** !* FETCHES THE HIGH END OF ARRAYHEAD(IE @A(FIRST)) OR STRINGNAME * !*********************************************************************** %record(levelf)%name inf inf==worka_levelinf(rlevtolevel(b)) %unless b=0 %IF stack down=NO %OR B=0 %or dinf_display %THEN D=D+4 DFETCH(1,4,B,D,Adid) %END %ROUTINE STORE HIGH AD END(%INTEGER B,D,Adid) !*********************************************************************** !* STORES THE HIGH END OF ARRAYHEAD(IE @A(FIRST)) OR STRINGNAME * !*********************************************************************** %record(levelf)%name inf inf==worka_levelinf(rlevtolevel(b)) %unless b=0 %IF stack down=NO %OR B=0 %or dinf_display %THEN D=D+4 DSTORE(1,ESTORE,4,B,D,Adid) %END %INTEGER %FN 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 %THEN %RESULT=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 %THEN %RESULT=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 * !*********************************************************************** %INTEGER n n=currt_Optype>>4-4 ESTKLIT(n) EOP(EPOWER) %END %ROUTINE CIOCP(%INTEGER N,xtra) !*********************************************************************** !* COMPILES A CALL ON IOCP ENTRY POINT NO 'N' * !* 2ND PARAMETER IS ALREADY IN ETOS * !*********************************************************************** %CONST %INTEGER NEEDS RES=X'40016'; ! FLAGS EPS 1,2,4&18 %INTEGER C,X,ID EPRECALL2(KNOWN XREF(4),addr(pardes(5))) EOP(PUSHVAL) %if params bwards=yes ESTKLIT(N) EOP(PUSHVAL) Eop(Pushval) %if params bwards=no %IF 1<