!
! Warning this module has the revised triples spec.
!
! In first attempt at Triple Imp considerable use was made of constant operands
! to pass information from Pass2 to GEN. Although for specialised operations like
! passing Labels this still applies, this adhocery has caused problems with arrays
! and pointers particularly in mapped records. The operands for four triples
! have thus been redefined in a more standard way.
!
! GETPTR X1 is now (ptype of passed)<<16! DIMENSION
! Opnd2 is either a 32 bit const with the size (ACC) as value or
! the ptr or arrayhead as normal operand.
!
! VMY X1 is now dim<<28!maxdim<<24!array name(where known)
! Opnd2 is either a 32 bit const with DV offset into const area or
! the arrayhead as a standard operand
!
! AINDX X1 is ELSIZE<<20 !spare
! Opnd2 is arrayhead as standard operand
! NOTE:- The Operands have been swopped for consistency with norm.
!
! BADJ X1 is arrayptype<<16!no of Dimensions (latter in case of backward dvs)
! Opnd2 exactly as for VMY
!
%INCLUDE "ERCC07:ITRIMP_HOSTCODES"
%CONSTINTEGER HOST=AMDAHL
%CONSTINTEGER TARGET=vax
%INCLUDE "ercs01:ebits_ECODES28"
%INCLUDE "ERCC07:TRIPCNSTS"
%INCLUDE "ERCC07:ITRIMP_TFORM2S"
%CONSTINTEGER ESTK=0
%owninteger profgla,profzgst; ! OFFSETS FOR PROFILING DATA
%OWNINTEGER GLACABUF,GLABEL,FPPTR,FPHEAD,SWAPMODE
%OWNINTEGERNAME CA,GLACA
%OWNINTEGERARRAYNAME CTABLE,TAGS,WORD
%OWNBYTEINTEGERARRAYNAME lett
%OWNRECORD (LISTF) %ARRAYNAME ASLIST
%OWNRECORD (LEVELF) %NAME WORKINGINF
%EXTRINSICINTEGERARRAY CAS(0:12)
%EXTRINSICRECORD (WORKAF) WORKA
%EXTRINSICRECORD (PARMF) PARM
%CONSTINTEGER MAXREG=4
%EXTERNALROUTINESPEC FLAGAND FOLD(%RECORD (TRIPF) %ARRAYNAME T)
%EXTERNALROUTINESPEC FAULT(%INTEGER I,J,K)
%INCLUDE "ercs01:ebits_ESPECS5"
%CONSTINTEGER MAXKXREF=6
%OWNINTEGERARRAY KXREFS(0:MAXKXREF)=-1(*)
%CONSTSTRING (7) %ARRAY PLNAME(0:31)="plabs00","plabs01",
"p_cndgs","plabs03","plabs04",
"p_unass","p_swerr","p_exper",
"p_xblks","p_capex","p_nores",
"p_forer","p_reser","p_aberr",
"plabs14","plabs15","p_stres",
"plabs17","p_strjt","plabs19",
"p_iexpn","p_rexpn","p_lrexp",
"plabs23","p_conct","plabs25",
"p_chkbp","plabs27","p_stcmp",
"p_mvbb","plabs30","plabs31"
%CONSTSTRING (11) %ARRAY KXREFNAME(0:MAXKXREF)="s#stop","s#ndiag",
"s#ilog","s#iexp","s#iocp",
"icl9ceauxst","s#pprofile"
%EXTERNALROUTINESPEC PRINT TRIPS(%RECORD (TRIPF) %ARRAYNAME T)
%EXTERNALROUTINESPEC POP(%INTEGERNAME A,B,C,D)
!%EXTERNALROUTINESPEC PRINT LIST(%INTEGER HEAD)
%EXTERNALROUTINESPEC PUSH(%INTEGERNAME A, %INTEGER B,C,D)
%EXTERNALROUTINESPEC MOVE BYTES(%INTEGER L,FB,FO,TB,TO)
%INTEGERFNSPEC BYTESWOP(%INTEGER VAL)
%ROUTINESPEC REFORMATC(%RECORD (RD) %NAME OPND)
%ROUTINESPEC CHANGESEX(%INTEGER BASE,OFFSET,L)
%ROUTINESPEC PPJ(%INTEGER A,B)
%ROUTINESPEC IMPABORT
%EXTERNALROUTINESPEC PRHEX(%INTEGER VALUE,PLACES)
%CONSTINTEGER PARAMS BWARDS=YES
%CONSTBYTEINTEGERARRAY BYTES(0:7)=0(3),1,2,4,8,16;
%CONSTINTEGER DAREA=6; ! AREA FOR DIAG TABLES
%CONSTINTEGER CAREA=10; ! AREA FOR CONSTANTS
%constinteger zgst=9; ! profile area into here
%constinteger gla=2
!
! FIXED GLA CURRENTLY USED AS FOLLOWS
! 0-7 FREE(WAS 2900 ENTRY DESCRIPTOR)
! 8-11 ADDRESS OF UNSHARED SYMBOL TABLES
! 12-15 ADDRESS OF SHARED SYMBOL TABLES
! 16-19 LANGUAGE & COMPILER DATA
! 20-23 ADDRESS OF DAREA WHEN DAREA#SST
! 24-27 ADDRESS OF CONSTANT TABLE
! 28-31 ADDRESS OF A WORD CONTAINING STACKTOP 0FOR NO CHECKS
! 32-35 HOLDS M'IDIA' FOR DIAGNOSTIC IDENTIFICATION
! 36-39 FREE
! 40-55 DEFINES THE ENTRY POINT OF MDIAGS
!
%CONSTINTEGER FIXEDGLALEN=56
%OWNINTEGERARRAY FIXED GLA(0:FIXEDGLALEN>>2-1)=M'IMP ',M'GLAP',
0(6),M'IDIA',0(*)
%owninteger prevline=0
%constinteger p0=-4,L0=0
%constinteger 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
%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
!
!***********************************************************************
!* 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="IMP Compiler Rlse ".TOSTRING(WORKA_RELEASE+'0')." Vsn ".WORKA_LADATE
EINITIALISE(1,ADDR(HD),ADDR(WORKA_LINE)+4 {frig},ADDR(CAS(2)),
parm_chk<<8!parm_arr<<9)
TAGS==WORKA_TAGS
WORD==WORKA_WORD
LETT==WORKA_LETT
EMONON %IF PARM_DCOMP#0
SWAPMODE=ESWAPMODE
WORKINGINF==WORKA_LEVELINF(1)
%END
%EXTERNALROUTINE CODEOUT
!***********************************************************************
!* NEEDED TO SATISFY REFERENCE IN PASS2 *
!***********************************************************************
%END
%EXTERNALROUTINE PDATA(%INTEGER AREA,BNDRY,L,AD)
!***********************************************************************
!* ADDS L(BYTES) TO AREA FOR UST,SST AND DIAGS AREAS *
!***********************************************************************
%INTEGERNAME PTR
PTR==CAS(AREA)
PTR=(PTR+BNDRY-1)&(-BNDRY)
EDBYTES(AREA,PTR,L,AD)
PTR=PTR+L
%END
%EXTERNALROUTINE PRDATA(%INTEGER AREA,BNDRY,L,REP,AD)
!***********************************************************************
!* ADDS L(BYTES) REP TIMES TO AREA FOR UST,SST AND DIAGS AREAS *
!* DATA ALREADY BYTE SWAPPED BY PASS2 *
!***********************************************************************
%INTEGERNAME PTR
PTR==CAS(AREA)
PTR=(PTR+BNDRY-1)&(-BNDRY)
EDPATTERN(AREA,PTR,REP,L,AD)
PTR=PTR+L*REP
%END
%EXTERNALINTEGERFN PINITOWN(%INTEGER PTYPE,ACC, %RECORD (RD) %NAME INIT, %STRINGNAME XNAME)
!***********************************************************************
!* PUTS AN INITIALISED OWN INTO THE GLA. SHOULD DEAL WITH ALL TYPES *
!* INIT IS ALREADY BYTE SWAPPED. ACC ETC NORMAL *
!* However strings in the A.R. can not be swopped till the last *
!* moment since they can be reused. These are copied&swopped here *
!***********************************************************************
%RECORD (RD) OPND
%INTEGER PREC,TYPE,RL,RES,LITL,I,J
%STRING (255) IS
TYPE=PTYPE&7
PREC=PTYPE>>4&7
LITL=PTYPE>>14&3
OPND=INIT
%IF PTYPE&X'400'#0 %START; ! OWN NAMES
GLACA=(GLACA+3)&(-4)
RES=GLACA
%IF TYPE=5 %START; ! OWNSTRINGNAMES
! HAVE LENGTH @LOW AD END
! AND ADDR AT HIGH AD END
! IN ESTACK LENGTH IS ON TOP
OPND_XTRA=ACC-1
ED4(2,RES,OPND_XTRA)
EDBYTES(2,RES+4,4,ADDR(OPND_D))
GLACA=GLACA+8
%FINISHELSESTART
EDBYTES(2,RES,4,ADDR(OPND_D))
GLACA=GLACA+4
%FINISH
%IF LITL=3 %START; ! EXTRINSICS ARE NAMES
J=RES
%IF TYPE=5 %THEN J=RES+4
EDATAREF(2 {gla},J,ACC,XNAME)
%FINISH
->END
%FINISH
RL=BYTES(PREC)
%IF TYPE=5 %THEN RL=2
%IF TYPE=3 %THEN RL=4
%IF RL>4 %THEN RL=4
GLACA=(GLACA+RL-1)&(-RL)
RES=GLACA; GLACA=GLACA+ACC
%IF TYPE=3 %OR (TYPE=5 %AND OPND_D=0) %START
EDPATTERN(2,RES,ACC,1,ADDR(OPND_D))
->END
%FINISH
%IF TYPE=5 %THENSTART
I=WORKA_A(OPND_D)
LENGTH(IS)=I
%FOR I=1,1,I %CYCLE
CHARNO(IS,I)=WORKA_A(OPND_D+I)
%REPEAT
CHANGE SEX(ADDR(IS),0,ACC) %IF HOST#TARGET
EDPATTERN(2,RES,1,ACC,ADDR(IS)); ! ALLOW FOR ALIGNMENT
%FINISHELSESTART
%IF PREC=3 %THEN ED1(2,RES,OPND_D&255)
%IF PREC=4 %THEN ED2(2,RES,OPND_D&x'ffff')
%IF PREC=5 %THEN EDBYTES(2,RES,4,ADDR(OPND_D))
%IF PREC=6 %THEN EDBYTES(2,RES,8,ADDR(OPND_D))
%FINISH
END: ! NOTE ENTRYT IF EXTERNAL
%IF LITL=2 %THEN EDATAENTRY(2 {GLA},RES,ACC,XNAME)
%RESULT=RES
%END
%EXTERNALINTEGERFN POWNARRAYHEAD(%INTEGER PTYPE,J,LB,SIZE,AOFFSET,AAREA,DVOFFSET,
%STRING (31) XNAME)
!***********************************************************************
!* SOME PARAMETERS ARE ONLY REQUIRED FOR CREATING DESCRIPORS ON *
!* 2900 ARCHITECTURE. THESE ARE REDUNDANT HERE *
!* PNX ARRAY HEAD HAS DV PTR AT LOW ADDRESS END AND @A(FIRST) AT *
!* THE HIGH ADDRESS END. WHEN IN ESTACK DV PTR IS ON TOP *
!***********************************************************************
%INTEGER LITL,RES,AHW0,AHW1,HAREA
AHW0=AOFFSET
AHW1=DVOFFSET
%IF HOST#TARGET %START
AHW0=BYTESWOP(AHW0)
AHW1=BYTESWOP(AHW1)
%FINISH
HAREA=2; ! NORMAL GLA
GLACA=(GLACA+3)&(-4)
RES=GLACA
GLACA=GLACA+8
LITL=PTYPE>>14&3
EFIX(2,RES,4,DVOFFSET); ! RELOCATE DV PTR
%IF LITL=3 %START; ! EXTRINSIC ARRAYS
EDATAREF(HAREA,RES+4,SIZE,XNAME)
%FINISHELSESTART
%IF AAREA=0 %THEN ED4(2,RES+4,AHW0) %ELSE EFIX(HAREA,RES+4,AAREA,AOFFSET)
%FINISH
%IF LITL=2 %THEN EDATAENTRY(AAREA,AOFFSET,SIZE,XNAME)
%RESULT=RES
%END
%EXTERNALROUTINE CXREF(%STRING (255) NAME, %INTEGER MODE,XTRA, %INTEGERNAME AT)
!***********************************************************************
!* OBTAIN A REFERENCE NO FOR EXTERNAL PROCEDURES *
!* MODE=0 STATIC CODE XREF *
!* MODE=1 DYNAMIC CODE XREF *
!***********************************************************************
AT=EXNAME(1,NAME)
%END
%INTEGERFN KNOWN XREF(%INTEGER N)
!***********************************************************************
!* RETURNS THE RT NO OF A KNOWN EXTERNAL NAME DEFINING IT ON *
!* THE FIRST OCCURRENCE ONLY *
!***********************************************************************
%INTEGER D
%STRING (255) S
%RESULT=KXREFS(N) %UNLESS KXREFS(N)<0
S=KXREFNAME(N)
D=EXNAME(1,S)
KXREFS(N)=D
%RESULT=D
%END
%ROUTINE CALL STOP
!***********************************************************************
!* CALLS STOP ROUTINE. NOT VIA EPILOGUE ON PERQ *
!***********************************************************************
EPRECALL(KNOWN XREF(0))
ECALL2(KNOWN XREF(0),1,0,0); ! S#STOP
%END
%integerfn 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<<opnd2_flag&refer needed#0
EOP(EXCH)
%result=1
%END
%ROUTINE BULKM(%INTEGER MODE,L,D2)
!***********************************************************************
!* PLANT CODE TO MOVE L BYTES (L KNOWN AT COMPILE TIME) FROM *
!* ETOS-2,ETOS-3 TO ETOS,ETOS-1 *
!* IF MODE =0 SET L BYTES TO D2(0 OR X'80') *
!* *
!* L MAY BE GREATER THAN 4095 *
!***********************************************************************
%INTEGER W2
ESTKLIT(L)
%IF MODE=0 %START; ! CLEAR
ESTKLIT(D2&255)
EOP(EFILL)
%else
EOP(MVB)
%FINISH
%END; ! OF ROUTINE BULK M
%EXTERNALROUTINE IMPABORT
PRINTSTRING("
**************** ABORT******************** ABORT *******")
!*DELSTART
ELINEDECODE
!*DELEND
%MONITOR
%STOP
%END
%EXTERNALROUTINE PROLOGUE(%RECORD (LISTF) %ARRAYNAME ALIST)
!***********************************************************************
!* GENERATES THE SUBROUTINE THAT ALWAYS ARE REQUIRED ONTO THE *
!* FRONT OF THE OBJECT PROGRAM WHERE THEY ARE DIRECTLY ADDRESABLE*
!***********************************************************************
%ROUTINESPEC ERR EXIT(%INTEGER A,B,C)
%INTEGER I,K
%STRING (31) S
ASLIST==ALIST
GLABEL=WORKA_NNAMES+1; ! FOR GENERATING LABELS
%if glabel<4096 %then glabel=4096
FPPTR=0
FPHEAD=0
CA==CAS(1)
GLACA==CAS(2)
GLACA=FIXEDGLALEN
CPINIT; ! INITIALISE CODE PLANTING
CTABLE==WORKA_CTABLE
%IF PARM_TRACE#0 %THEN I=X'C2C2C2C2' %AND PDATA(DAREA,4,4,ADDR(I))
%CYCLE I=0,1,31
WORKA_PLABS(I)=-1; WORKA_PLINK(I)=0
%REPEAT
%CYCLE I=0,1,MAXKXREF
KXREFS(I)=-1
%REPEAT
!
! GENERATE THE RUN TIME ERROR ROUTINE :-
! MDIAGS IS %ROUTINE MDIAGS(%INT PC,AP,ERROR,XTRA)
! PC IS A DUMMY EXCEPT AFTER CONTINGENCY
! ON ENTRY TO THIS SUBROUTINE ERROR & XTRA ARE AS PARAMETERS(P1&P2)
!
! ILP2, IPUSH XTRA STACKED
! ILP1, IPUSH ERROR STACKED
! LAS 0 CURRENT LNB TO ETOS
! IPUSH AND STACKED
! CI0 DUMMY CALLING PC
! IPUSH
! CALL N CALL TO NDIAGS
! RETURN
!
K=KNOWN XREF(1); ! NDIAG XREF (AS NO ZERO) OBTAINED
S=PLNAME(2)
EPROC(S,12,0,0,0,WORKA_PLABS(2)); ! NO DISPLAY OR LOCALS
ESTKPAR(1,p2,0,4); ! P2
EOP(PUSHVAL)
ESTKPAR(1,p1,0,4); ! P1 (ERROR)
EOP(PUSHVAL)
Eop(EOLDLNB)
EOP(PUSHVAL)
ESTKLIT(0)
EOP(PUSHVAL)
ECALL2(K,1,4,16)
EOP(RETURN); ! ONLY NEEDED FOR %MONITOR
EPROCEND(0,0,0); ! 0 BYTES OF LOCALS
!
! SUBROUTINE TO CALL DEBUG ROUTINE(S#IMPMON) LINE NO IN GR0
!
! STM 4,0,16(11)
! LM CODER,EPREG,EPDIST
! BCR 15,LINKREG RETURN ADDR ALREADY IN GR15
!
%IF PARM_DBUG#0 %THENSTART
! WORKA_PLABS(3)=CA
! CXREF("S#IMPMON",PARM_DYNAMIC,2,K)
%FINISH
!
! SUBROUTINE TO ADVANCE STACK FRONT BY ETOS WORDS AND CHECK FOR OFLOW
!
%IF PARM_OPT=1 %THENSTART; ! ONLY REQUIRED WITH CHKING
! WORKA_PLABS(4)=CA
%FINISH
!
! SOME ERROR ROUTINES
!
! ERR EXIT(5, X'801', 0) %IF PARM_OPT#0; ! UNASSIGNED VARIABLE
! ERR EXIT(6, X'802', 0); ! SWITCH LABEL UNSET
ERR EXIT(7,X'505',1); ! ILLEGEAL EXPONENTIATION
ERR EXIT(8,X'201',0) %IF PARM_OPT#0; ! EXCESS BLOCKS
ERR EXIT(9,X'601',0); ! CAPACITY EXCEEDED
! ERR EXIT(10,21, 0) ; ! NO RESULT
ERR EXIT(11,X'501',0) %IF PARM_OPT#0; ! CYCLE NOT VALID
ERR EXIT(12,X'701',0); ! RES FAILS
ERR EXIT(13,X'602',0) %IF PARM_OPT#0; ! ARRAY BOUND FAULT
CTABLE(0)=BYTESWOP(M'CTAB')
CTABLE(1)=0; ! NULL STRING
WORKA_CONST PTR=2
WORKA_CONST BTM=WORKA_CONST PTR
%IF PARM_PROF#0 %THEN %START; ! ALLOCATE PROFILE COUNT AREA
profgla=glaca; glaca=glaca+8
Ed4(gla,profgla,worka_line)
Ed4(gla,profgla+4,0)
profzgst=CAS(zgst)
Efix(Gla,profgla+4,Zgst,profzgst)
CAS(zgst)=profzgst+4+worka_line*4
%FINISH
Eboundlab(Glabel)
Elabel(Glabel)
Glabel=Glabel+1
PPJ(15,13) %if PARM_OPT#0
%if PARM_Chk#0 %start
Euchecklab(Glabel)
Elabel(Glabel)
Glabel=Glabel+1
Eprecall(worka_plabs(2))
Estklit(0); Eop(PUSHVAL)
Estklit(X'801'); Eop(PUSHVAL)
Ecall2(Worka_Plabs(2),1,2,8)
%finish
ELINESTART(1); ! FOR PNX DEBUGGER
%RETURN
%ROUTINE ERR EXIT(%INTEGER LAB,ERRNO,MODE)
!***********************************************************************
!* MODE=0 FOR DUMMY(ZERO) XTRA - MODE=1 XTRA IN GR1 *
!***********************************************************************
%INTEGER J
%STRING (31) S
S=PLNAME(LAB)
EPROC(S,12,0,0,0,WORKA_PLABS(LAB)); ! NO DISPLAY OR LOCALS REQD
Eop(EOLDLNB)
EOP(PUSHVAL)
ESTKLIT(ERRNO)
EOP(PUSHVAL)
ECALL2(WORKA_PLABS(2),1,2,8)
EPROCEND(0,0,0)
%END
%END
%EXTERNALROUTINE EPILOGUE(%INTEGER STMTS)
!***********************************************************************
!* PLANT ANY SUBROUINES THAT HAVE BEEN REQUIRED DURING *
!* THE CODE GENERATION PHASE *
!***********************************************************************
%ROUTINESPEC FILL(%INTEGER LAB)
ELINESTART(9999); ! PSEUDO LINE NO
!
! STRING RESOLUTION ROUTINE (ENTERED BY CALL)
! P5 = ADDRESS OF STRING BEING RESOLVED
! P4 = ADDR OF (ORIGINAL LENGTH! BYTES USED UP<<16)
! P3 = LMAXOF FRAGMENT HOLING STRING(=0 NO SUCH STRING)
! P2 = ADDRESS OF FRAGMENT STRING
! P1 = ADDRESS OF RESOLUTION STRING(CONVERTED TO BYTE FORM ON ENTRY)
! END OF PARAMETER
! L1 = LOCAL COPY OF BYTES USED UP
! L2 = LENGTH OF RESOLUTION STRING
! L3 = NO OF POSSIBLE VAILD COMPARISONS
! L4 = COMPARISON LOOP CONTROL OF FORM 1,1,L3
! L5 = COPY OF ORIGNAL LHS LENGTH
! L6&7 = NOT USED (WAS WORK VARIABLES IN CH COMPARE LOOP)
! L8 = BYTE POINTER TO FIRST RELEVANT BYTE OF RESTRING
!
!
! STAGE 1 INITIALISE LOOP CONTROL AND WORK OUT THE NO OF VALID
! COMPARISONS AND STORE IN L3
!
! CI1 ISL4 INITIALISE CONTROL
! LDW ((P4)), CI255, IAND COPY BYTES IN ORIGINAL STRING
! DUPL, ISLL5 AND SAVED IN LOCAL
! LDW ((P4)), CI16, ISHRL
! DUPL, ISL1 COPY OF BYTES USED UP
! ISUB BYTES LEFT OF LHS
! LDB ((P1)), DUPL, ISL2 CURRENT LENGTH OF RESLN STRING
! JINTZ <RESOK (L5)> RESOLVING ON NULL STRING
! ILL2, ISUB 0 LENGTH DIFF =1 VALID COMP
! CI1, IADD, DUPL, ISL3 MAX NO OF VALID COMPARISONS
! JINTLEZ <RESFAIL (L4)> 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 <RESOK (L5)> ALL FOUND WITH NO NONEQIVALENCE
! THIS COMPARISON FAILS
! ADVANCE DOWN BY ONE
! ILL4, CI1, IADD, DUPL, ISL4 INCREMENT CONTROL
! ILL3, JILE<OUTER LOOP (L0)> AND CONTINUE
!
!RESFAIL(L4): RESOLUTION HAS FAILED
! CI0, RETURN EXIT WITH FALSE SET
!RESOK(L5): RESOLUTION HAS WORKED
! ILP3, JINTZ <NOSTORE (L6)> 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 <NOSTORE (L6)> CHECK FOR CAP EXCEED
! CALL PLABS9 AND FAIL IF SO
!NOSTORE(L6): ENTERS HERE IF FRAGMENT IS DISCARDED
! ILL1,ILL2,IADD,ILL4,IADD RECALCULATE BYTES USED UP
! CI1, ISUB, CI16, ISHLL
! ILL5, IOR, STW((P4)) AND STORE VIA HALFWORD PTR
! CI1, RETURN EXIT WITH RESULT=TRUE
!
%IF WORKA_PLINK(16)=0 %THEN ->P17
FILL(16)
ESTKLIT(1)
ESTKDIR(0,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)
EPRECALL(WORKA_PLABS(9))
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(32,0,0)
GLABEL=GLABEL+8
P17:
!
! EVALUATE X**Y
! ******** ****
! Y IS IN FR0 AND X IS AT TOP OF STACK
! EVENT 5/5 IS SIGNALLED IF X<0 OR (X=0 AND Y<=0)
! OTHERWISE RESULT=EXP(Y*LOG(Y))
!
! ST 15,12(WSPR) SAVE LINK
! BALR 1,0
! LTDR 0,0
! BC 4,PLAB7
! BC 7,20(1)
! LD 2,0(WSPR)
! LTDR 2,2
! BC 12,PLAB7
! LA WSPR,16(WSPR) PROTECT X AND RETURN ADD
! STD 0,64(WSPR) PARAMETER X TO LOG
! STM 4,14,16(WSPR) SAVE ENVIRONMENT
! LM CODER,EPREG,LOGEPDISP
! BALR LINKREG,EPREG
! LA 0,16
! SR WSPR,0
! MD 0,0(WSPR)
! STD 0,64(WSPR) Y*LOG(X) TO EXP
! STM 4,14,16(WSPR)
! LGR LINKREG,12(WSPR)
! LM CODER,EPREG,EXPEPDISP
! BCR 15,LINKREG RETURNS DIRECT TO PROGRAM
!
%IF WORKA_PLINK(17)=0 %THEN ->P18
FILL(17)
! %IF LOGEPDISP=0 %THEN CXREF("S#ILOG",0,2,LOGEPDISP)
! %IF EXPEPDISP=0 %THEN CXREF("S#IEXP",0,2,EXPEPDISP)
P18:
!
! STRING JAM TRANSFER ENTERED BY CALL WITH 5 PARAMS
! P2 = VIRT (WORD) ADDR OF SOURCE
! P2 = MAX LENGTH OF DEST
! P1 = VIRT (WORD) ADDR OF DEST
! L1 = LOCAL THE ACTUAL STRING BYTES TO BE MOVED
!
! ILP2, LBI, DUPL, ISL1 LENGTH OF SOURCE
! ILP2, JILE <L0> NO TRUNCATION
! ILP2, ISL1 TRUNCATED LENGTH
!L0: ILP2
! ILP1, ILL1
! CI1, IADD, MOVE LBYTES + LENGTH BYTE
! MVB
! ILL1, ILP1, ASSB AND OVERWRITE LENGTH
! RETURN
!
%IF WORKA_PLINK(18)=0 %THEN ->P19
FILL(18)
ESTKPAR(1,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(8,0,0)
GLABEL=GLABEL+1
P19:
! called subroutine to evaluate i****4
!
! %IF WORKA_PLINK(19)=0 %THEN ->P20;! ROUTINE NOT USED
!P20:
! called subroutine to evaluate i****N ( I 32 BITS)
! N OVER I IN ESTACK NO C PARAMETERS
! IN LINE CODE USED AS NO JLK INSTRUCTION
%IF WORKA_PLINK(20)=0 %THEN ->P21; ! ROUTINE NOT USED
FILL(20)
EPROCEND(8,0,0)
GLABEL=GLABEL+5
P21:
! called subroutine to evaluate X**N ( X 32 BITS)
! In-line code now genererated for this
!P22:
! called subroutine to evaluate X**N ( X 64 BITS)
! IN LINE CODE NOW USED
!
!P23:
!
! STRING PRE-CONCATENATION SUBROUTINE
! NOT USED ON PNX ALL DONE AT P24
!
!P24:
!
! STRING CONCATENATION SUBROUTINE
! MUST LEAVE NO RUBBISH IN ESTACK IN CASE LHS DEST IN NEST
!
! P2 HAS WORD ADDRESS OF NEXT BIT
! P1 HAS WORD ADDRESS OF WORKAREA CONTAINING PREVIOUS BITS
! L1 HAS BYTE LENGTH OF P2
! L2 HAS BYTE LENGTH OF P1
!
! ILP2, DUPL, LBI, DUPL
! ISL1, EXCH, CI1, IADD, EXCH LENGTH OF MOVE OVER SOURCE
! ILP1, DUPL, LBI, DUPL
! ISL2, IADD, CI1, IADD
! EXCH, MVB STRINGS JOINED
! ILL1, ILL2, IADD, ILP1
! ASSB,
! RETURN
!
%IF WORKA_PLINK(24)=0 %THEN ->P25
FILL(24)
ESTKPAR(1,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(8,0,0)
P25:
!
! CHECK ARRAY BOUND WITH 16 BIT INDEX
! NO RELEVANCE TO PNX
!P26:
!
! CHECK ARRAY BOUND WITH 32 BIT INDEX
! NOW DONE IN LINE WITH CHK INSTR
!P27:
! REDUCE LONG BYTE INDEX
! NOT NEEDED FOR PNX
!
!P28:
! DIFFERENCE IMP STRINGS
! PARAMETERS ARE TWO BYTE ADDRESS AND ROUTINE RETURNS FIRST DIFFERENCE
!
! P1 HAS FIRST OPERAND (BYTE) ADDRESS
! P2 HAS SECOND OPERAND ADDRESS
! L1 HAS FIRST OPERAND CURRENT (BYTE) ADDRESS
! L2 HAS SECOND OPERAND CURREMT BYTE ADDRESS
! L3 HAS SHORTER STRING LENGTH
!
! ILP1 DUPL, CI1 IADD
! ISL1, LBI, ISL3
! ILP2, DUPL, CI1, IADD
! ISL2, LBI, ILL3,
! JIGE <L0>
! LDB ((P2)), ISL3 SHORTER LENGTH SET
!L0: ILL3, JINTZ <L2> ZERO LENGTH WITH NO DIFFERENCE
! ILL3, CI1, ISUB, ISL3 LENGTH DECREMENTED
! LDB ((L1)), LDB ((L2)) NEXT TWO CHARS
! JINE <L1> DIFFERENC FOUND
! ILL2, CI1, IADD, ISL2 UPDATE 2ND POINTER
! ILL1, CI1, IADD, ISL1 UPDATE 1ST POINTER
! JUMP <L0>
!L1: RETURN DIFFERENCE OF CHS
! LDB ((L1)), LDB ((L2)), ISUB, RETURN
!L2: NO DIFFERENCES RETURN LENGTHS
! LDB ((P1)),LDB ((P2)), ISUB
! RETURN
!
%IF WORKA_PLINK(28)=0 %THEN ->P29
FILL(28)
ESTKPAR(1,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{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,-4,0,1 {ldb ((L1))})
ESTKIND(0,-8,0,1 {ldb ((L2))})
EJUMP(JINE,GLABEL+1)
ESTKDIR(0,L1,0,4); ESTKLIT(1); EOP(IADD)
ESTKDIR(0,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,-4,0,1 { ldb((L1))})
ESTKIND(0,-8,0,1 {ldb ((L2))})
EOP(ISUB); EOP(EINTRES)
EOP(RETURN)
ELABEL(GLABEL+2); ! LABEL L2 IS HERE
ESTKPARIND(1,P1,0,1 {ldb ((P1))})
ESTKPARIND(1,P2,0,1 {ldb ((P2))})
EOP(ISUB); EOP(EINTRES)
EOP(RETURN)
EPROCEND(16,0,0)
GLABEL=GLABEL+3
P29:
!
! GENERATE A MOVE BYTES ROUTINE ENTERED BY CALL
! USED IN RESOLUTION FOR POSSIBLY OVERLAPPED MOVES
! NO RELEVANCE TO Emachines MOVE BYTES INTRUCTION ADEQUATE
%IF WORKA_PLINK(29)=0 %THEN ->P30
FILL(29)
EPROCEND(0,0,0)
P30:
%IF PARM_DCOMP#0 %THEN PRINTSTRING("
CODE FOR LINE 99999") %AND ELINEDECODE
%BEGIN
!***********************************************************************
!* PASS INFORMATION TO QPUT TO ENABLE IT TO GENERATE THE *
!* LOADER DATA AND COMPLETE THE PROGRAM FILE. *
!***********************************************************************
%INTEGERARRAY SIZES(0:10)
%ROUTINESPEC DUMP CONSTS
%INTEGER LANGFLAG,PARMS,I,K
! CODE OUT
! CNOP(0,8)
! FIXED GLA(6)=CA; ! CONST TABLE ADDRESS
%IF PARM_TRACE=0 %THEN LANGFLAG=6 %ELSE LANGFLAG=1
LANGFLAG=LANGFLAG<<24
DUMP CONSTS
PARMS=(PARM_DIAG<<1!PARM_LINE)<<1!PARM_TRACE
FIXED GLA(4)=LANGFLAG!WORKA_RELEASE<<16!(PARM_CPRMODE&1)<<8!PARMS; ! LANG RLSE & MAINPROG
FIXED GLA(8)=BYTESWOP(M'IDIA')
I=GLACA-GLACABUF
%IF PARM_INHCODE=0 %THENSTART
! BACK OF GLAP
EDBYTES(2,28,FIXEDGLALEN-28,ADDR(FIXED GLA(7))); ! FRONT OF GLAP
! word 0-6 are standard and set up by ecode
! on call of initialise from cpinit
%IF PARM_TRACE#0 %THEN I=X'E2E2E2E2' %AND PDATA(DAREA,4,4,ADDR(I))
%FINISH
%CYCLE I=1,1,10
SIZES(I)=(CAS(I)+7)&(-8)
%REPEAT
ETERMINATE(ADDR(SIZES(1))); ! SUMMARY INFO.
PRINTSTRING("
VAX CODE")
WRITE(SIZES(1),6)
%IF SIZES(4)>0 %THEN PRINTSTRING("+") %AND WRITE(SIZES(4),4)
PRINTSTRING(" BYTES GLAP")
WRITE(SIZES(2),3); PRINTSTRING("+")
WRITE(SIZES(5),1); PRINTSTRING(" BYTES DIAG TABLES")
WRITE(SIZES(DAREA),3); PRINTSTRING(" BYTES
TOTAL")
K=SIZES(1)+SIZES(2)+SIZES(4)+SIZES(5)+SIZES(6)
WRITE(K,5); PRINTSTRING(" BYTES
")
%IF PARM_FAULTY=0 %THENSTART
WRITE(STMTS,7); PRINTSTRING(" STATEMENTS COMPILED")
%FINISHELSESTART
PRINTSTRING("PROGRAM CONTAINS"); WRITE(PARM_FAULTY,2)
PRINTSTRING(" FAULT"); PRINTSYMBOL('S') %IF PARM_FAULTY>1
%FINISH
NEWLINES(2)
%ROUTINE DUMP CONSTS
%INTEGER I,J,K
%IF PARM_DCOMP#0 %START
PRINTSTRING("
Constant Table")
I=0
%CYCLE
NEWLINE
PRHEX(4*I,5)
%CYCLE J=0,1,7
SPACES(2)
PRHEX(WORKA_CTABLE(I+J),8)
%REPEAT
SPACE
%CYCLE J=0,1,31
K=ADDR(WORKA_CTABLE(0))+4*I+J
K=BYTEINTEGER(K)
%IF K<=31 %OR K>125 %THEN K=32
PRINT SYMBOL(K)
%REPEAT
I=I+8
%EXITIF I>=WORKA_CONSTPTR
%REPEAT
%FINISH
%END
%END
%RETURN
%ROUTINE FILL(%INTEGER LAB)
!***********************************************************************
!* NOT NECESSARY ACTUALLY TO FILL JUMPS ON PNX *
!* CONSTRUCT THE RIGHT PPROC STATEMENT AND LOADER DOES THE REST *
!***********************************************************************
%STRING (15) S
S=PLNAME(LAB)
EPROC(S,4,0,0,0,WORKA_PLINK(LAB)); ! NO display REQD
%END
%END
%REALFN ICL REAL TO PERQ(%REAL ICL REAL)
!***********************************************************************
!* This is a function which converts a real number in ICL *
!* floating-point format into one that is in ICL PERQ *
!* floating-point format. *
!* *
!* At Exit: RESULT= +infinity if ICL Real is too large *
!* RESULT= -infinity if ICL Real is too small *
!* RESULT= PERQ Real otherwise *
!* *
!*Assumptions: (i). PERQ floating-point format conforms with the *
!* proposed IEEE draft standard, *
!* (ii). conversion is to be applied to 32-bit Reals, *
!* (iii). conversion is to be applied on ICLs, *
!* (iv). the hexadecimal representation of 1.0, *
!* on ICL PERQ's is R'3F800000' *
!* on Vax F Format is R'4080000' *
!***********************************************************************
%CONSTREAL MINUS INFINITY= R'FF800000'; ! ie sign=1,exp=255,fraction=0
%CONSTREAL PLUS INFINITY= R'7F800000'; ! ie sign=0, exp=255,fraction=0
%CONSTREAL PERQ ZERO= R'00000000'; ! ie sign=0,exp=0,fraction=0
%INTEGER BITS SHIFTED LEFT; ! by a SHZ instruction on ICL Fraction
%INTEGER ICL EXP; !exponent of ICL Real - 70
%INTEGER SIGN; !sign bit of ICL Real (1 if minus: 0 if plus)
%INTEGER PERQ EXP; !exponent of PERQ Real (calculated)
%INTEGER PERQ FRACTION; !fraction of PERQ Real (derived from ICL Fraction)
%REAL PERQ REAL; !--the Result
%IF HOST#TARGET %AND HOST#PNX %START
%IF PARM_X#0 %THENRESULT=ICL REAL; ! FOR SIMULATOR
%IF ICL REAL=0.0 %THENRESULT=PERQ ZERO
%IF ICL REAL<0.0 %THEN SIGN=1 %AND ICL REAL=-ICL REAL %ELSE SIGN=0
! ICL Real is now positive
! Decompose the ICL Real:
%IF HOST=EMAS %START
*LSS_ICL REAL
*FIX_ICL EXP
*SHZ_BITS SHIFTED LEFT
*USH_1; *USH_-9
*ST_PERQ FRACTION
%ELSE
PERQ FRACTION=INTEGER(ADDR(ICL REAL))
ICL EXP=PERQ FRACTION>>24&x'7f'-70
PERQ FRACTION=PERQ FRACTION<<8
BITS SHIFTED LEFT=8
%WHILE PERQ FRACTION>0 %CYCLE
PERQ FRACTION=PERQ FRACTION<<1
BITS SHIFTED LEFT=BITS SHIFTED LEFT+1
%REPEAT
PERQ FRACTION=PERQ FRACTION<<1>>9
%FINISH
! Calculate PERQ Exponent:
PERQ EXP=((ICL EXP+5)*4 {as exponent is a hexadecimal exp})+(11-BITS SHIFTED LEFT) %C
{equals either 0,1,2, or 3}+127
{the bias of the exponent}
%if Target=Vax %then PERQ EXP=PERQ EXP+2
! -and examine its range:
%IF PERQ EXP<=0 %THENRESULT=MINUS INFINITY {ie Real Underflow}
%IF PERQ EXP>=255 %THENRESULT=PLUS INFINITY { Real Overflow}
! Construct the PERQ Real
INTEGER(ADDR(PERQ REAL))=(SIGN<<8!PERQ EXP)<<23!PERQ FRACTION
%RESULT=PERQ REAL
%FINISHELSERESULT=ICL REAL
%END; !of ICL Real to PERQ
%LONGREALFN ICL LONGREAL TO PERQ(%LONGREAL ICL2900 REAL)
!***********************************************************************
!* This is a function which converts a double precision real *
!* in ICL 2900 floating-point format into one that is *
!* in ICL PERQ floating-point format. *
!* At Exit: RESULT= equivalent PERQ real *
!* *
!*Assumptions: (i). PERQ floating-point format conforms with the *
!* proposed IEEE draft standard, *
!* (ii). conversion is to be applied to 64-bit Reals, *
!* (iii). conversion is to be applied on ICL2900s, *
!* (iv). the hexadecimal representation of 1.0, *
!* on ICL PERQ's is R'3FF0000000000000' *
!* on Vax G Format is R'4010000000000000' *
!************************************************************************
%INTEGER BITS SHIFTED LEFT; ! by a SHZ instruction on ICL2900 Fraction
%INTEGER ICL2900 EXP; !exponent of ICL2900 Real - 78
%INTEGER SIGN; !sign bit of ICL2900 Real (1 if minus: 0 if plus)
%INTEGER PERQ EXP; !exponent of PERQ Real (calculated)
%LONGREAL PERQ REAL; !--the Result
%IF HOST#TARGET %AND HOST#PNX %START
%LONGINTEGER PERQ FRACTION; !fraction of PERQ Real (derived from ICL2900 Fraction)
%IF PARM_X#0 %THENRESULT=ICL2900REAL; ! FOR SIMULATOR
%IF ICL2900 REAL=0.0 %THENRESULT=0.0
%IF ICL2900 REAL<0.0 %THEN SIGN=1 %AND ICL2900 REAL=-ICL2900 REAL %ELSE SIGN=0
! ICL2900 Real is now positive
! Decompose the ICL2900 Real:
%IF HOST=EMAS %START
*LSD_ICL2900 REAL
*FIX_ICL2900 EXP
*SHZ_BITS SHIFTED LEFT
*USH_1; *USH_-12
*ST_PERQ FRACTION
%ELSE
PERQ FRACTION=LONGINTEGER(ADDR(ICL 2900 REAL))
ICL2900EXP=PERQ FRACTION>>56&x'7f'-78
PERQ FRACTION=PERQ FRACTION<<8
BITS SHIFTED LEFT=8
%WHILE PERQ FRACTION>0 %CYCLE
PERQ FRACTION=PERQ FRACTION<<1
BITS SHIFTEDLEFT=BITS SHIFTED LEFT+1
%REPEAT
PERQ FRACTION=PERQ FRACTION<<1>>12
%FINISH
! Calculate PERQ Exponent:
PERQ EXP=(ICL2900 EXP+78 {which was subtracted by FIX above}-64 %C
{which is the ICL2900 bias}-1 %C
{ as the most significant digit is <1 and >=1/16})*4 %C
{ as the ICL2900 exponent is a hex exponent}+(11-BITS SHIFTED LEFT) %C
{bits shifted left equals 11, or 10, or 9, or 8}+1023
{bias of PERQ double precision reals}
%if Target=Vax %then PERQ EXP=PERQ EXP+2
! Construct the PERQ Real
LONGINTEGER(ADDR(PERQ REAL))=(LENGTHENI(SIGN<<11!PERQ EXP)<<52)!PERQ FRACTION
%RESULT=PERQ REAL
%FINISHELSERESULT=ICL2900 REAL
%END; ! of ICL2900 LongReal to PERQ
%ROUTINE PPJ(%INTEGER JUMP,N)
!***********************************************************************
!* PLANT A 'JUMP PERMENTRY(N)' *
!* IF JUMP=0 THEN PLANT A CALL *
!***********************************************************************
%INTEGER VAL,LAB,INF
%CONSTBYTEINTEGERARRAY INVJ(24:35)= JILE{JIGT},JIGE{JILT},
JINE{JIEQ},JIEQ{JINE},
JILT{JIGE},JIGT{JILE},
JINTLEZ{JINTGZ},JINTGEZ{JINTLZ},
JINTNZ{JINTZ},JINTZ{JINTNZ},
JINTLZ{JINTGEZ},JINTGZ{JINTLEZ}
%CONSTINTEGERARRAY INFO(0:30)=0,0,x'00020008',0(13),
X'02050014'{16 RESLN},
0,x'0003000c'{18 STRINGJT},
0(5),X'00020008'{24 CONCAT},
0(3),X'02020008'{28 STRING COMP},
0(*)
LAB=0
VAL=WORKA_PLABS(N)
INF=INFO(N); ! RESULTFLAGS<<24! npars<<16 ! BYTES OF PARAMS
%IF VAL<0 %START
VAL=ENEXTPROC
WORKA_PLABS(N)=VAL
WORKA_PLINK(N)=VAL
%FINISH
%IF JUMP>=24 %THEN LAB=GLABEL %AND GLABEL=LAB+1
%IF LAB>0 %THEN EJUMP(INVJ(JUMP),LAB)
EPRECALL(VAL) %UNLESS INF&255#0; ! PRECALL MUST BE DONE BEFOR PARAMS
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
%INTEGERFN BYTESWOP(%INTEGER VAL)
!***********************************************************************
!* PERFORMS A COMPLETE BYTE REVERSAL OF VAL *
!***********************************************************************
%SWITCH SW(0:3)
%IF HOST#TARGET %THEN ->SW(SWAPMODE&3)
SW(0):%RESULT=VAL
SW(1):%RESULT=(VAL<<8&x'ff00ff00')!(VAL>>8&x'ff00ff')
SW(2):%RESULT=VAL<<16!VAL>>16
SW(3):%RESULT=(VAL<<24)!(VAL<<8&X'FF0000')!(VAL>>8&X'FF00')!(VAL>>24)
%END
%EXTERNALROUTINE REFORMATC(%RECORD (RD) %NAME OPND)
!***********************************************************************
!* REFORMATS A CONSTANT TO TAKE INTO ACCOUNT DIFFERENT HOST-TARGET *
!* REPRESENTATIONS. HOST MAY BE EMAS OR PNX. *
!***********************************************************************
%IF HOST#TARGET %START
%INTEGER TYPE,PREC,I
%LONGREAL LR
%RECORD (RD) TEMP
%IF SWAPMODE=0 %THENRETURN
TEMP=OPND
I=OPND_D; ! ALL INTEGER UP TO 32 BIT
TYPE=OPND_PTYPE&7
PREC=OPND_PTYPE>>4&7
%IF TYPE=1 %START; ! INTEGERS
%IF PREC=3 %THEN OPND_B0<-I %AND OPND_B1<-I %AND OPND_B2<-I %AND OPND_B3<-I %AND %C
%RETURN
%IF PREC=4 %THENSTART
OPND_D=BYTESWOP(I<<16!(I&X'FFFF'))
%RETURN
%FINISH
%IF PREC=5 %THEN OPND_D=BYTESWOP(OPND_D) %ANDRETURN
IMPABORT
%FINISH
%IF TYPE=2 %THENSTART
%if target=vax %then swapmode=swapmode!!6
! Vax real formats are in effect half&word swopped
%IF PREC=5 %START
TEMP_R=ICLREALTOPERQ(OPND_R)
OPND_D=BYTESWOP(TEMP_D)
%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)
%FINISH
%if target=vax %then swapmode=swapmode!!6; ! restore swapmode
%return
%FINISH
%IF TYPE=5 %THENRETURN; ! CANT CHANGE SEX HERE
! MIGHT BE USED IN COMPILE TIME OP
IMPABORT
%FINISH
%END
%EXTERNALROUTINE CHANGESEX(%INTEGER BASEAD,OFFSET,L)
!***********************************************************************
!* ALTERERS INITIALISED DATA FOR A BYTE SEX CHANGE *
!***********************************************************************
%OWNBYTEINTEGERARRAYFORMAT F(0:X'FFFF')
%BYTEINTEGERARRAYNAME A
%INTEGER I,J
%IF HOST#TARGET %AND X'10001'#SWAPMODE&X'10001'#0 %START
A==ARRAY(BASEAD,F)
%MONITORUNLESS OFFSET&1=0
I=OFFSET
%WHILE L>0 %CYCLE
J=A(I)
A(I)=A(I!!1)
A(I!!1)=J
I=I+2; L=L-2
%REPEAT
%FINISH
%END
%EXTERNALROUTINE FILL DTABREFS(%INTEGERNAME CURRINFRAL)
!***********************************************************************
!* PLUGS REFENCES TO THE DIAG TABLES FOR CURRINF WHICH ARE *
!* ABOUT TO BE GENERATED AT CAS(DAREA). THE LIST POPPED HAS *
!* S1=AREA 1=CODE, DAREA FOR DIAGNOSTIC AREA *
!* S2= THE OFFSET OF INSTRUCTION OR FORWARD POINTER *
!* S3=THE WORD BEFORE FILLING - NOT USED FOR AREA 1 *
!***********************************************************************
%INTEGER Q,JJ,KK
%WHILE CURRINFRAL#0 %CYCLE
POP(CURRINFRAL,Q,JJ,KK)
%IF Q=1 %THENSTART
ESETMARKER(JJ,CAS(DAREA))
%FINISHELSESTART
KK=CAS(DAREA)
%if Host#Target %and swapmode&1#0 %then kk=kk<<8!(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
!%ROUTINE GET WSP(%INTEGERNAME PLACE,%INTEGER SIZE)
!***********************************************************************
!* FIND OR CREATE A TEMPORARY VARIABLE OF 'SIZE' WORDS *
!***********************************************************************
!%INTEGER J,K,L,F
! %IF SIZE>4 %THEN SIZE=0
! K=worka_n
! %IF SIZE=0 %THEN worka_n=worka_n+268 %ELSE worka_n=worka_n+SIZE<<2
! PLACE=K
!%END
%EXTERNALINTEGERFN ETEMPWORKSPACE(%INTEGER SIZE{in bytes})
!***********************************************************************
!* provides a temporary for the emachine in the current stack 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
WORKA_N=K+SIZE
%RESULT=WORKINGINF_DISPLAY-(K+SIZE)
%END
%EXTERNALROUTINE GENERATE(%RECORD (TRIPF) %ARRAYNAME TRIPLES, %INTEGER CURRLEVEL,
%ROUTINE GET WSP(%INTEGERNAME PLACE, %INTEGER SIZE))
!***********************************************************************
!* EVALUATE A LIST OF TRIPLES PLABTING CODE IN BUFFERS *
!***********************************************************************
%INTEGERFNSPEC JCODE(%INTEGER TFMASK)
%ROUTINESPEC VMY
%ROUTINESPEC REXP
%ROUTINESPEC STARSTAR
%ROUTINESPEC ISTARSTAR
%ROUTINESPEC CIOCP(%INTEGER N,xtra)
%INTEGERFNSPEC RLEVTOLEVEL(%INTEGER RLEV)
%INTEGERFNSPEC LOAD(%RECORD (RD) %NAME OP,%integer mode)
%INTEGERFNSPEC STRINGLBAD(%RECORD (TAGF) %NAME TCELL)
%INTEGERFNSPEC RECORDELAD(%RECORD (TAGF) %NAME TCELL, %INTEGER SPTYPE,XTRA)
%ROUTINESPEC INDLOAD(%INTEGER TYPE,SIZE,OFFSET)
%ROUTINESPEC INDSTORE(%INTEGER TYPE,SIZE,OFFSET)
%ROUTINESPEC LOADAD(%RECORD (RD) %NAME OPND)
%ROUTINESPEC LOADPTR(%RECORD (RD) %NAME OPND,OPND2)
%ROUTINESPEC DSTORE(%INTEGER TYPE,OPCODE,SIZE,LEVEL,DISP,Adid)
%ROUTINESPEC CHOP OPERAND(%RECORD (RD) %NAME OPND, %INTEGER PT,X)
%ROUTINESPEC DFETCH(%INTEGER TYPE,SIZE,LEVEL,DISP,Adid)
%ROUTINESPEC DFETCHAD(%INTEGER SIZE,LEVEL,DISP,Adid)
%ROUTINESPEC FETCH LOW AD END(%INTEGER B,D,Adid)
%ROUTINESPEC FETCH HIGH AD END(%INTEGER B,D,Adid)
%ROUTINESPEC STORE LOW AD END(%INTEGER B,D,Adid)
%ROUTINESPEC 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
!
%CONSTINTEGERARRAY TRIPDATA(0:199)=0,
X'1000070F'{RTHD ROUTINE/BKK HDR},
X'10001043'{RDSPLY MAKE DISPLAY},
X'10000410'{RDAREA INITIALISE DIAGS AREA},
X'10000511'{RDPTR RESET DIAGS PTR},
X'10000312'{RTBAD ERROR XIT FOR FN-MAP},
X'10000113'{RTXIT "%RETURN"},
X'10000314'{XSTOP "%STOP"},
0(2),
X'2000040A'{10 LOGICAL NOT},
X'2000040B'{11 LOGICAL NEGATE},
X'2000040C'{12 FLOAT},
X'2000040D'{13 MODULUS},
X'2000080E'{14 SHORTEN},
X'2000040F'{15 LENGTHEN},
X'20000610'{16 JAM SHORTEN},
X'10000000'{17 ERROR},
0{18 NULL TRIPLE},
X'20000413'{19 PRELOAD},
X'10000001'{20 UNUSED},
X'10000303'{21 STORE STACKPOINTER},
X'10000602'{22 RESTORE STACK POINTER},
X'10000505'{23 ADVANCE STACK POINTER},
X'10000D04'{24 DECLARE ARRAY},
X'10000301'{25 UPDATE LINE NO},
X'10000906'{26 CHECK ZERO FOR STEP},
X'10000307'{27 FOR PREAMBLE},
X'10000208'{28 FOR POSTAMBLE},
X'1000010E'{29 FOR SECOND PREAMBLE},
X'10000218'{30 PRECALL},
X'10000519'{31 ROUTINE CALL},
X'1000021A'{32 RECOVER FN RESULT},
X'1000021B'{33 RECOVER MAP RESULT},
X'00000000'{34 NOT CURRENTLY USED},
X'1000081D'{35 GETAD GET 32BIT ADDREESS},
X'10000424'{36 RTOI1 INT FN},
X'10000C25'{37 RTOI2 INTPT FN},
X'10000B26'{38 STOI1 TOSTRING FN},
X'1000093D'{39 MNITR FOR %MONITOR},
X'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'10000220'{157 ASSGN FORMAL RT-CODE AS 156},
X'10000220'{158 PASS5 TYPE GENERAL NAME},
X'10000445'{159 PASS6 RESULT AREA FOR STR&REC FNS},
X'1000030A'{160 BACK JUMP},
X'1000030B'{161 FORWARD JUMP},
X'1000000C'{162 REMOVE LAB},
X'1000000D'{163 ENTER LABEL},
X'1000FF21'{164 DECLARE SWITCH},
X'10000022'{165 SET SWITCH LABEL TO CA},
X'10000523'{166 GOTO SWITCH LABEL},
X'10000D27'{167 STRING ASS1 GENERAL},
X'10001128'{168 STRING ASS 2 L KNOWN},
X'10000D29'{169 STRING JAM TRANSFER},
X'10000C2A'{170 ARRAY HEAD ASSIGNMENT},
X'10000C2B'{171 PTR ASSIGNMENT},
X'1000052C'{172 MAP RESULT ASSIGNMENT},
X'1000052D'{173 FN RESULT ASSIGNMENT},
X'10000C2E'{174 STRING COMPARISON},
X'10000C2E'{175 STRING DSIDED COMPARISON},
X'10000C2F'{176 PRE RESOLUTION 1},
X'10001230'{177 PRE RESOLUTION 2},
X'10000B31'{178 RESOLUTION PROPER},
X'1000233C'{179 RESOLUTION FINISH ASSN FRAGMNT},
X'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(*)
%CONSTBYTEINTEGERARRAY FCOMP(0:127)=0(2),
IGT(2),ILT(2),INE(2),IEQ(2),
IGE(2),ILE(2),0(2),
0(2),
ILT(2),IGT(2),INE(2),IEQ(2),
ILE(2),IGE(2),0(2),
0(2),
JIGT(2),JILT(2),JINE(2),JIEQ(2),
JIGE(2),JILE(2),0(2),
0(2),
JILT(2),JIGT(2),JINE(2),JIEQ(2),
JILE(2),JIGE(2),0(2),
0(2),
RGT(2),RLT(2),RNE(2),REQ(2),
RGE(2),RLE(2),0(2),
0(2),
RLT(2),RGT(2),RNE(2),REQ(2),
RLE(2),RGE(2),0(2),
0(2),
JRGT(2),JRLT(2),JRNE(2),JREQ(2),
JRGE(2),JRLE(2),0(2),
0(2),
JRLT(2),JRGT(2),JRNE(2),JREQ(2),
JRLE(2),JRGE(2),0(2)
!
! OPCODE FOR ESTACK TO STORE VARIANT OPERATIONS
!
!
! THE FOLLOWING ARRAY HAS INSTRUCTION SEQUENCES FOR THE VARIOUS IMP
! IMP OPERATION PRECCED BY A SWITH LABEL AT WHICH THEY ARE PLANTED
! TOUGH CASES LIKE ** HAS A UNIQUE ONE-OFF SWITCH.
! LOOK UP THE SWITCH LABEL FOR PARAMETER DECODING IN DIFFICULT CASES
!
%CONSTINTEGER NISEQS=34
%CONSTBYTEINTEGERARRAY ISEQS(40:4*(3*NISEQS+10)-1)={FIRST INTEGER FORMS} %C
2,INOT,0,0 {10 16 BIT LOGICAL NOT},
2,INEG,0,0 {11 16 BIT LOGICAL NEGATE},
12,0,0,0 {12 16 BIT FLOAT TO 64 BIT REAL},
2,IABS,0,0 {13 16 BIT MODULUS},
10,0,0,0 {14 SHORTEN 16 BIT TO 16 BIT},
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)
C=TRIPINF>>28; ! TRIPLE TYPE
TRIPVAL=TRIPINF&255
%IF C=0 %THENCONTINUE
%IF C=1 %THEN ->TRIPSW(TRIPVAL)
LRES=0
!
! CARE IS NEEDED IN DETECTING WHEN OPERANDS ARE REVERSED IN STACK
! 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<<OPND1_FLAG&BTREFMASK#0 %AND 1<<OPND2_FLAG&BTREFMASK#0 %START
workt==triples(opnd1_d)
workt2==triples(opnd2_d)
%if workt_puse=wtripno %and workt_flags¬inreg=0 %c
%and workt2_puse=wtripno %and workt2_flags¬inreg=0 %start
Both loaded=1
L0=CURRT_BLINK
L0=TRIPLES(L0)_BLINK %WHILE L0#0 %AND L0#OPND1_D %AND L0#OPND2_D
%IF L0=OPND1_D %THEN COMM=2
%finish
%FINISH
%IF TRIPINF&X'40000'=0 %START; ! EOP NOT LOADED
%if Both loaded#0 %and 1<<opnd1_flag&refer needed#0 %c
%and comm=1 %then comm=comm+exchange(opnd1,opnd2)
! Above is in case of refer on wrong operand
LRES=LOAD(OPND1,0)<<1
%IF JJ>=128 %AND CURRT_FLAGS&6=2 %START
! OPERANDS REVERSED IN ESTACK
COMM=2
%FINISH
%FINISH
%IF TRIPINF&X'F0000'=0 %AND COMM=2 %THEN %C
comm=comm-EXCHANGE(OPND2,OPND1)
! I-RS THE WRONG WAY ROUND
! FOR NON COMMUTABLE OPS
%if 1<<opnd2_flag&refer needed#0 %and (comm=2 %or lres=2) %then %c
comm=exchange(Opnd2,opnd1) %and comm=1;! again to ensure refer on correct opnd
%UNLESS JJ<128 %OR TRIPINF&X'20000'#0 %THEN LRES=LOAD(OPND2,0)
PTYPE=OPND1_PTYPE&255; TYPE=PTYPE&7
%IF TYPE=2 %THEN C=4*(TRIPVAL+2*NISEQS) %ELSEIF PTYPE=X'51' %THEN %C
C=4*(TRIPVAL+NISEQS) %ELSE C=4*TRIPVAL
L0=ISEQS(C); B1=ISEQS(C+1)
B2=ISEQS(C+2); B3=ISEQS(C+3)
->SW(L0)
SW(1): ! ERROR CONDITION
TRIPSW(0):
FAULT(B3,0,0) %UNLESS TYPE=7
TRIPSW(*):
EOP(HALT); ! USEFUL IN DEBUGGING TO HAVE
! ERROR POSITION PINPOINTED
->STRES
SW(6): ! PLANT BYTE & SET PTYPE
OPND1_PTYPE=B3
ESTKLIT(BYTES(B3>>4))
SW(2): ! PLANT ONE BYTE
EOP(B1)
OPND1_FLAG=9; ! PREVENT RELOAD IF THIS IS LAST
->STRES
SW(3): ! PLANT 2 BYTES
EOP(B1); EOP(B2)
OPND1_FLAG=9; ! PREVENT RELOAD IF THIS IS LAST
->STRES
SW(4): ! PLANT REAL OPERATION
SW(5): ! REAL UNARY OPERATION
D=B1<<8!B2
EOP(D)
OPND1_FLAG=9
->STRES
SW(7): ! NULL OPERATION
->STRES
SUSE:
->STRES
SW(9): ! INTEGER MODULUS
->SW(1); ! now unused
SW(10): ! SHORTEN INTEGER TO BYTE
%IF PARM_OPT#0 %START
%UNLESS CURRT_CNT=1 %AND TRIPLES(CURRT_PUSE)_OPERN=SHRTN %START
%IF CURRT_OPTYPE>X'31' %THENSTART
ESTKLIT(-x'8000')
ESTKLIT(X'7FFF')
%FINISHELSESTART
ESTKLIT(0)
ESTKLIT(255)
%FINISH
EOP(CHK)
%FINISH
%FINISH
estklit(bytes(currt_optype>>4))
eop(cvtii)
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 %THENSTART; ! INTEGERS
ISTARSTAR
%FINISHELSESTART
STARSTAR; ! PLANT COMPLEX IN LINE ROUTINE
%FINISH
->SUSE
SW(14): ! DSIDED COMPARISONS
! COPY MIDDLE OPERAND(SIZE IN TABLE)
GET WSP(D,2)
DSTORE(TYPE,EDUPSTORE,BYTES(opnd2_PTYPE>>4&15),CURRINF_RBASE,D,0)
OPND2_FLAG=7; OPND2_D=CURRINF_RBASE<<16!D
CURRT_FLAGS=CURRT_FLAGS!NOTINREG; ! STORE COPY TO BE USED
WORKT==TRIPLES(CURRT_PUSE)
WORKT_FLAGS=WORKT_FLAGS!LOADOP1; ! ENSURE ESTACK IS RIGHT WAY ROUND
SW(13): ! COMPARISONS
BFFLAG=COMM-1; ! NOTE BACKWARDS OR FORWARDS
C=XTRA&15+16*BFFLAG
%IF TYPE=2 %THEN C=C+64; ! FLOATING COMPARATORS
C=FCOMP(C)
COMM=2
WORKT==TRIPLES(CURRT_FLINK); ! ON TO FOLLOWING TRIPLE
%IF CURRT_OPTYPE=X'51' %OR CURRT_OPTYPE=X'41' %START
%IF WORKT_OPERN=FJUMP %OR WORKT_OPERN=BJUMP %THEN %C
WORKT_X1=WORKT_X1!X'40' %AND CURRT_OPND1=OPND2 %AND ->STRES
%FINISH
%IF TYPE=2 %START
%IF WORKT_OPERN=FJUMP %OR WORKT_OPERN=BJUMP %THEN %C
WORKT_X1=WORKT_X1!x'140' %AND CURRT_OPND1=OPND2 %AND ->STRES
%FINISH
EOP(C)
CURRT_OPND1=OPND2; ! OPND2 IS RESULT
->STRES; ! 2ND OPERAND MAY BE NEEDED IN
SW(15): ! SPECIAL MH FOR ARRAY ACCESS
C=XTRA>>28; ! CURRENT DIMENSION
D=XTRA>>24&15; ! TOTAL NO OF DIMENSIONS
VMY
->STRES
SW(18): ! BASE ADJUST ARRAY INDEX
DPTYPE=XTRA>>16
%UNLESS PARM_COMPILER#0 %OR DPTYPE&X'300'=X'200' %START
D=OPND2_D&X'FFFF'
%IF OPND2_FLAG=SCONST %START; ! DV KNOWN
C=CTABLE(D)
C=BYTESWOP(C)
ESTKLIT(C)
%FINISHELSESTART
CHOP OPERAND(OPND2,x'51',0)
LRES=LOAD(OPND2,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) %ELSEIF DACC=2 %THEN EOP(INDEX2) %ELSEIF %C
DACC=4 %THEN EOP(INDEX4) %ELSEIF DACC=8 %THEN EOP(INDEX8) %ELSE %C
ESTKLIT(DACC) %AND EOP(INDEX)
%FINISHELSESTART; ! RARE CASE GO TO DV FOR SIZE
! ONLY FOR ACCESS OF STRING&RECORD
! ARRAYNAMES
LRES=LOAD(OPND2,0); ! full head dvptr on top
EREFER(4,2); ! el size halfword out of swopped dv
EPROMOTE(3); EOP(EXCH)
EOP(INDEX)
%FINISH
->STRES
SW(20): ! INDEXED FETCH
INDLOAD(1,BYTES(PTYPE>>4&7),0)
OPND1_PTYPE=OPND1_PTYPE&255
OPND1_FLAG=9
OPND1_XB=0
->STRES
SW(16): ! ASSIGN(=)
! ASSIGN(<-)
%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,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
%FINISHELSESTART
WORKT_X1=D!!X'160'; ! with zero(2),comp omitted & real(256)
%FINISH
->STRES
SW(25): ! SHIFT BY CONSTANT
D=OPND2_D
%IF CURRT_OPERN=CASHIFT %AND D=-1 %THEN EOP(HALT) %ELSEIF %C
D>0 %OR CURRT_OPERN=CLSHIFT %THEN ESTKLIT(D) %AND EOP(ISHLL) %ELSE %C
ESTKLIT(D) %AND EOP(ISHLA)
->stres
TRIPSW(76): ! OPERATE AND ASSIGN OPERATION
! PRODUCED BY PNX OPT PASS ONLY
%BEGIN
%CONSTBYTEINTEGERARRAY OOPC(128:135)=IADDST,ISUBST,IXORST,IORST,IMULTST,
IDIVST,HALT,IANDST
LRES=LOAD(OPND2,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
%IF PARM_LINE#0 %START
ESTKLIT(D)
ELINESTART(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)
EOP(SFA)
EOP(ISUB)
EOP(ASF)
%CONTINUE
TRIPSW(3): ! SAVE STACK POINTER
! OPND1 IS TEMPORARY(16 BITS) FOR SAVE
EOP(SFA)
DSTORE(1,ESTORE,4,CURRINF_RBASE,OPND1_D,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,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,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) %ELSESTART
B1=0
%FOR JJ=1,1,XTRA>>16 %CYCLE
%IF C&(1<<JJ)#0 %START; ! THIS LB NONZERO
DFETCH(1,4,CURRINF_RBASE,D-12*JJ-4,0); ! LB
%IF JJ>1 %THENSTART
DFETCH(1,4,CURRINF_RBASE,D-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*(XTRA>>24); ! TRIPLE POSN
%IF OPND1_FLAG=SCONST %START; ! LB A CONST
ESTKLIT(OPND1_D)
DSTORE(1,ESTORE,4,CURRINF_RBASE,D-4,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)
%FINISHELSESTART
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,0)
EOP(ISUB); ESTKLIT(1); EOP(IADD)
%FINISH
C=XTRA>>24&255; ! CURRENT DIMENSION
%IF C>1 %START; ! MULTPLY UP BY LOWER RNAGES
EOP(IMULT)
%FINISH
DSTORE(1,EDUPSTORE,4,CURRINF_RBASE,D-8,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)
%FINISHELSESTART; ! 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 TRIPLES(STPTR)_OPERN=ASPTR %START; ! IF ARRAY NOT FORMAT
%IF OPND1_D<0 %START; ! ARRAY SIZE KNOWN
C=CTABLE(TCELL_SNDISP+2)
C=BYTESWOP(C)
C=(C+3)&(-4); ! TO 64 BIT BNDRY
ESTKLIT(-C)
EOP(ASF)
%FINISHELSESTART; ! DYNAMIC NEEDS LOOP !
DFETCH(1,4,CURRINF_RBASE,OPND1_D&X'FFFF'-8,0)
ESTKLIT(3); EOP(IADD)
ESTKLIT(-4)
EOP(IAND); EOP(INEG); EOP(ASF)
%FINISH
%FINISH
EOP(SFA); ! STACK FRONT ADDRESS=BASE ADDRESS
DSTORE(1,ESTORE,4,CURRINF_RBASE,TCELL_SLINK,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,0)
INDSTORE(1,4,0)
%FINISHELSE DSTORE(1,ESTORE,4,TCELL_UIOJ>>4&15,TCELL_SLINK,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
%INTEGERNAME CELL
CELL==CURRINF_LABEL
%WHILE CELL>0 %CYCLE
%IF ASLIST(CELL)_S3=OPND1_D %THEN POP(CELL,S1,S2,S3) %ANDEXIT
CELL==ASLIST(CELL)_LINK
%REPEAT
EDISCARDLABEL(OPND1_D)
%END
%CONTINUE
TRIPSW(13): ! INSERT LABEL
! OPND1_XTRA HAS LABEL CELL
LCELL==ASLIST(OPND1_XTRA)
%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 %THENSTART
C=0
TCELL==ASLIST(TAGS(OPND1_D))
PCHKWORD=TCELL_SLINK
%IF PCHKWORD>0 %THEN PCHKWORD=ASLIST(PCHKWORD)_S3; ! size<<16!num
H=TCELL_SNDISP
%FINISHELSE C=1
PBITS=CURRINF_RBASE<<16
%if INNER=0 %then pbits=pbits!2****5
%IF H=0 %THEN H=-1
%IF OPND1_XTRA#0 %THEN %C
EPROC(STRING(OPND1_XTRA),Pbits!C<<1!1,PCHKWORD&x'fff',PCHKWORD>>16,
ADDR(WORKA_N),H) %ELSEIF OPND1_D>=0 %THEN %C
EPROC(STRING(ADDR(WORKA_LETT(WORKA_WORD(OPND1_D)))),Pbits,
PCHKWORD&x'fff',PCHKWORD>>16,ADDR(WORKA_N),H)
%IF OPND1_D>=0 %THEN TCELL_SNDISP=H
%END
%CONTINUE
TRIPSW(67): ! RDISPLY CREATE DISPLAY
D=CURRINF_RBASE
%CONTINUE
TRIPSW(16): ! RDAREA - INITIALISE DAIGS AREA
! OPND1_D=N FOR DIAGS AREA
ESTKDIR(2,32,0,4); ! PICK UP M'IDIA'
DSTORE(1,ESTORE,4,CURRINF_RBASE,OPND1_D,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,2,LINF_RBASE,LINF_DIAGINF,0)
%CONTINUE
TRIPSW(18): ! RTBAD FN-MAP ERROR EXIT
WORKT==TRIPLES(CURRT_BLINK); ! PREVIOUS TRIPLE
%CONTINUEIF WORKT_OPERN=RTXIT %OR WORKT_OPERN=XSTOP %OR (WORKT_OPERN=BJUMP %AND %C
WORKT_X1&15=15)
%IF PARM_OPT#0 %THENSTART
EPRECALL(WORKA_PLABS(2))
ESTKLIT(21)
EOP(PUSHVAL)
ESTKLIT(0)
EOP(PUSHVAL)
PPJ(0,2)
%FINISH
%CONTINUE
TRIPSW(19): ! RTXIT - "%RETURN"
%IF OPND1_D=0 %START; ! JUMP TO END FOR RETURNS PROTEM
! TILL REGISTER RESTORING SOLVED
EJUMP(JUMP,CURRINF_ENTRYAD)
%FINISHELSESTART
ELABEL(CURRINF_ENTRYAD); ! ENTRAD HOLDS LAB FOR RETURN
EOP(RETURN)
EPROCEND(CURRINF_SNMAX-CURRINF_DISPLAY,0,ADDR(WORKA_N))
%FINISH
%CONTINUE
TRIPSW(20): ! XSTOP - "%STOP"
CALL STOP
%IF OPND1_D#0 %THEN EPROCEND(CURRINF_SNMAX-CURRINF_DISPLAY,0,ADDR(WORKA_N))
%CONTINUE
TRIPSW(61): ! %MONITOR
EPRECALL(WORKA_PLABS(2))
ESTKLIT(0)
EOP(PUSHVAL)
ESTKLIT(0)
EOP(PUSHVAL)
PPJ(0,2)
%CONTINUE
!***********************************************************************
!* SECTION FOR STRING CONCATENATION AND ASSIGNMENT *
!***********************************************************************
TRIPSW(21): ! PRECONCAT
! OPND1 IS WORK AREA
! OPND2 HAS FIRST STRING
LRES=LOAD(OPND2,0); ! 32 BIT AD OF STRING2
EOP(DUPL); EREFER(0,1)
LRES=LOAD(OPND1,0)
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)
EPRECALL(WORKA_PLABS(24))
EOP(PUSHVAL)
LRES=LOAD(OPND1,0)
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<x'61' %then estklit(255) %and EOP(EXCH)
%IF OPND2_FLAG=LCONST %THENSTART; ! CONST STRING ASSN
%IF OPND2_XTRA=0 %START; ! CONST IS NULL
EOP(DISCARD); ESTKLIT(0); EOP(EXCH); EREFER(0,2); EOP(ESTORE)
%FINISHELSESTART
%IF PARM_OPT#0 %THEN EOP(EXCH) %ELSE EOP(DISCARD)
LRES=LOAD(OPND2,0)
EOP(EXCH)
ESTKLIT(OPND2_XTRA+1)
EOP(MVB)
%IF PARM_OPT#0 %START
ESTKLIT(OPND2_XTRA)
PPJ(JILT,9)
%FINISH
%FINISH
%FINISHELSESTART
GET WSP(D,1); ! temporary
%IF CURRT_FLAGS&LOADOP2=0 %START; ! RHS(OP 2) FN OR MAP
DSTORE(1,ESTORE,4,CURRINF_RBASE,D,0)
%FINISH
%IF PARM_OPT#0 %THEN EOP(EXCH) %ELSE EOP(DISCARD)
! MAX LEN TO BTM FOR CHK OR DISCARDED
%IF CURRT_FLAGS&LOADOP2=0 %THEN %C
DFETCH(1,4,CURRINF_RBASE,D,0) { retrieve temp} %ELSESTART
LRES=LOAD(OPND2,0)
DSTORE(1,EDUPSTORE,4,CURRINF_RBASE,D,0); ! SOURCE BYTE ADDRE TO REG
%FINISH
EOP(EXCH); ! DEST OVER SOURCE FOR MVB
DFETCH(1,4,CURRINF_RBASE,D,0); ! FURTHER COPY OF SOURCE
EREFER(0,1)
%IF PARM_OPT#0 %THENSTART
GET WSP(TEMPLOC,1); ! extra temporary reuse confuses ecode rts
DSTORE(1,EDUPSTORE,4,CURRINF_RBASE,TEMPLOC,0)
%FINISH
ESTKLIT(1); EOP(IADD); ! ASSIGN
EOP(MVB)
%IF PARM_OPT#0 %START; ! CHECK LENGTH
DFETCH(1,4,CURRINF_RBASE,TEMPLOC,0); ! RETRIEVE CURRENT LENGTH
PPJ(JILT,9)
%FINISH
%FINISH
%CONTINUE
TRIPSW(40): ! SIMPLE STRING ASSIGN
! LHS A SIMPLE STRING
TCELL==ASLIST(TAGS(OPND1_D))
%IF OPND2_FLAG=LCONST %AND OPND2_XTRA<TCELL_ACC %START
%IF OPND2_XTRA=0 %START; ! NULL STRING ASSIGN
ESTKLIT(0)
D=STRINGLBAD(TCELL)
DFETCHAD(1,TCELL_UIOJ>>4&15,D&X'FFFF',0)
EREFER(0,2); EOP(ESTORE)
%FINISHELSESTART; ! ASSIGN CONSTANT STRING
LRES=LOAD(OPND2,0)
LRES=LOAD(OPND1,0)
ESTKLIT(OPND2_XTRA+1)
EOP(MVB)
%FINISH
%CONTINUE
%FINISH
LRES=LOAD(OPND2,0)
EOP(DUPL);
LRES=LOAD(OPND1,0)
EOP(EXCH); EREFER(0,1); ! LENGTH OF RHS
%IF PARM_OPT#0 %and tcell_acc<256 %START
ESTKLIT(0)
ESTKLIT(TCELL_ACC-1); ! LMAX
EOP(CHK)
%FINISH
ESTKLIT(1)
EOP(IADD)
EOP(MVB)
%CONTINUE
TRIPSW(41): ! STRING JT VIA SUBROUTINE
EPRECALL(WORKA_PLABS(18))
LRES=LOAD(OPND1,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 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)
%FINISHELSEIF CURRT_FLAGS&LOADOP1=0 %START; ! BOTH LOADED
%FINISHELSESTART; ! 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
%FINISHELSESTART
EPRECALL(WORKA_PLABS(28))
EOP(PUSHVAL); EOP(PUSHVAL)
PPJ(0,28)
ESTKLIT(0); ! RETURNED AS DIFFERENCE FROM ZERO
%FINISH
EOP(D)
%CONTINUE
NULLSC: ! TEST FOR A NULL STRING
LRES=LOAD(OPND,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'
EPRECALL(WORKA_PLABS(16))
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
%FINISHELSE 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,0); ! 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); ! feth 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); 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,0); ! 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
%FINISHELSE EOP(EXCH) %AND EOP(Index1)
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 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)
EPRECALL(TCELL_SNDISP)
FPPTR=0
%CONTINUE
TRIPSW(25): ! ROUTINE CALL (AFTER PARAMS)
! OPND1 HAS RT NAME
TCELL==ASLIST(TAGS(OPND1_D))
JJ=0
%IF TCELL_SLINK#0 %THEN JJ=ASLIST(TCELL_SLINK)_S3&255 {n params}
%IF TCELL_UIOJ&15=14 %START; ! EXTERNAL CALL
ECALL2(TCELL_SNDISP,1,JJ,FPPTR)
%FINISHELSEIF TCELL_PTYPE&X'400'#0 %START
fetch low ad end(tcell_uioj>>4&15,tcell_sndisp,0);! proc addr
fetch high ad end(tcell_uioj>>4&15,tcell_sndisp,0);! env
ESTKLIT(FPPTR)
EOP(ARGPROC); ! CALL FORMAL PROCEDURE
%FINISHELSESTART
C=TCELL_UIOJ>>4&15
! %IF C>0 %THEN PI1(ILL,-4*(C+1));! DISPLAY PTR FOR INTERNAL RTS
D=TCELL_SNDISP
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
LRES=LOAD(OPND2,0)
%IF OPND2_PTYPE&7=5 %START; ! STRING FN RESULTS
EOP(DUPL); EREFER(0,1)
ESTKPAR(0,P2,0,4); EOP(EXCH)
ESTKLIT(1); EOP(IADD); EOP(MVB)
ESTKPAR(0,P2,0,4); ! THE "RESULT"
EOP(EINTRES)
%CONTINUE
%FINISH
%if Opnd1_ptype&7=3 %Start;! record functions
estkpar(0,P2,0,4)
tcell==aslist(tags(opnd1_d))
estklit(Tcell_acc)
Eop(MVB)
estkpar(0,P2,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
ESTKRESULT(0,OPND1_PTYPE&7,BYTES(OPND1_PTYPE>>4&15))
%CONTINUE
TRIPSW(27): ! RECOVER MAP RESULT
! CALLED AFTER RETURN TO CALLER
OPND1_FLAG=9
OPND1_XB=ESTK
ESTKRESULT(0,1,4)
%CONTINUE
TRIPSW(28): ! PASS PARAMETER(1)= NORMAL VALUE
LCELL==ASLIST(OPND1_XTRA&X'FFFF'); ! PARAM DESCTR CELL
D=LCELL_ACC; ! PARAM_ACC
%IF OPND1_PTYPE&7=5 %START; ! STRINGS BY VALUE - LABORIOUS
C=(D+3)&(-4); ! PNX WORDS FOR STRING VALUE
ESTKLIT(-C); EOP(ASF)
FPPTR=FPPTR+C
LRES=LOAD(OPND2,0); ! PTR TO STRING
%IF C<=32 %START; ! SHORT STRINGS
EOP(SFA)
ESTKLIT(C)
%FINISHELSESTART; ! LONG STRINGS COMPUTE MOVE SIZE
EOP(DUPL); EREFER(0,1); ESTKLIT(1)
EOP(IADD); EOP(SFA); EOP(EXCH)
%FINISH
EOP(MVB)
%IF PARM_OPT#0 %and d<256 %START
EOP(SFA); EREFER(0,1); ! LENGTH FROM DEST
estklit(0)
ESTKLIT(D-1); ! FOR ASSNMNT CHECK
eop(chk)
eop(discard)
%FINISH
%FINISHELSEIF OPND1_PTYPE&7=3 %START; ! RECORD BY VALUE
C=(D+3)&(-4)
%IF OPND2_FLAG=SCONST %THEN D=0 %ELSE D=1 %AND LRES=LOAD(OPND2,0)
ESTKLIT(-C); EOP(ASF)
EOP(SFA)
BULKM(D,C,0)
FPPTR=FPPTR+C
%FINISHELSESTART
LRES=LOAD(OPND2,0)
C=OPND1_PTYPE
%IF C=X'62' %THENSTART
EOP(PUSHVAL)
FPPTR=FPPTR+8
%FINISHELSEIF C=X'52' %THENSTART
EOP(PUSHVAL)
FPPTR=FPPTR+4
%FINISHELSESTART
%IF C=X'31' %THEN ESTKLIT(24) %AND EOP(ISHLL)
%IF C=X'41' %THEN ESTKLIT(16) %AND EOP(ISHLL)
EOP(PUSHVAL)
FPPTR=FPPTR+4
%FINISH
%FINISH
%CONTINUE
TRIPSW(29): ! GET 32 BIT ADDRESS
LOADAD(OPND1)
->STRES
%CONTINUE
TRIPSW(30): ! GET POINTER FOR %NAME
LOADPTR(OPND1,OPND2)
->STRES
%CONTINUE
TRIPSW(31): ! PARAM PASSING (2) NORMAL PTRS
LRES=LOAD(OPND2,0)
PTYPE=OPND1_PTYPE&255; ! FOR PARAM
%IF PTYPE=X'35' %START; ! STRING(2 WORD) PTRS
FPPTR=FPPTR+4
EOP(EXCH); EOP(PUSHVAL)
%FINISH
EOP(PUSHVAL)
FPPTR=FPPTR+4
%CONTINUE
TRIPSW(32): ! PARAM PASSING(3) ARRAYS
! ALSO (4) PASS RT PARAM SAME CODE
LRES=LOAD(OPND2,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
ESTKLIT(255)
ESTKLIT(4); EOP(CVTII); ! as 4 byte integer
LRES=LOAD(OPND2,64)
EOP(PUSHVAL); EOP(PUSHVAL)
FPPTR=FPPTR+8
%CONTINUE
TRIPSW(63): ! RTFP TURN RTNAME INTO FORMAL
TCELL==ASLIST(TAGS(OPND1_D))
%IF TCELL_PTYPE&X'400'#0 %START; ! NAM>0 PASS A FORMAL
fetch low ad end(tcell_uioj>>4&15,tcell_sndisp,0);! proc addr
fetch high ad end(tcell_uioj>>4&15,tcell_sndisp,0);! env
%FINISHELSESTART
! externalspecs at any level need no env
%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 env over entry address
eop(exch); ! On Unix stacks push env first
! Normal stacks push addr first
! Note there may be a further exch at tripsw(32)
%FINISH
%CONTINUE
TRIPSW(66): ! TYPE GENERAL PARAMETER
! OPND1 THE ACTUAL
! OPND2 HAS PTYPE&ACC
%IF OPND1_FLAG=DNAME %AND OPND1_PTYPE&15=0 %START
TCELL==ASLIST(TAGS(OPND1_D))
DFETCH(1,8,TCELL_UIOJ>>4&15,TCELL_Slink,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)
%FINISHELSESTART
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 %THENSTART
EPRECALL(WORKA_PLABS(2))
ESTKLIT(X'802')
ESTKLIT(0)
EOP(PUSHVAL)
EOP(PUSHVAL)
PPJ(0,2)
%FINISH
! ERROR EXIT AFTER TABLE
%CONTINUE
TRIPSW(34): ! SET SWITCH LABEL(OPND2)
TCELL==ASLIST(TAGS(OPND1_D))
LCELL==ASLIST(TCELL_SLINK); ! SIDECHAIN HAS TDISP LB&UB
ESWITCHENTRY(TCELL_SNDISP,OPND2_D); ! REFS REL TO ACTUAL START
%CONTINUE
TRIPSW(35): ! GOTO SW LABEL
TCELL==ASLIST(TAGS(OPND1_D))
LCELL==ASLIST(TCELL_SLINK)
C=LCELL_S2; ! ADJUST TO START OF 0
LRES=LOAD(OPND2,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=RECORDELAD(TCELL,OPND1_PTYPE,OPND1_XTRA)
DSTORE(1,ESTORE,8,TCELL_UIOJ>>4&15,C,0)
%FINISHELSESTART
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=RECORDELAD(TCELL,OPND1_PTYPE,OPND1_XTRA)
DSTORE(1,ESTORE,D,TCELL_UIOJ>>4&15,C,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)
%FINISHELSEIF D=4 %THEN EOP(EXCH) %ELSESTART
EPROMOTE(3)
%FINISH
%IF OPND1_FLAG=INDIRECT %AND OPND1_XTRA>0 %THEN ESTKLIT(OPND1_XTRA) %AND EOP(IADD)
%finish
INDSTORE(1,D,0)
%CONTINUE
TRIPSW(62): ! RECORD ASSIGNMENT
%IF OPND2_FLAG=SCONST %THENSTART
LRES=LOAD(OPND1,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(IADD); ! ADDITION
->STRES
TRIPSW(65): ! AHADJ ARRAY MAPPING OPND1 1
! HAS ADJUSTMENT OPND2 THE HEAD
! ARRAY PTYPE<<4!MODE IS IN XTRA
LRES=LOAD(OPND1,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 JJ=RECORDELAD(TCELL,OPND2_PTYPE,OPND2_XTRA)
%FINISH
%IF OPND2_FLAG=7 %THEN JJ=OPND2_D&X'FFFF' %AND D=OPND2_D>>16
%IF JJ#-1 %START; ! HEAD ACCESSIBLE AVOID COMPLEX
! ESTACH MANIPULATIONS
%IF XTRA&1=0 %THENSTART
FETCH LOW AD END(D,JJ,0)
%FINISHELSESTART
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
%FINISHELSESTART
EOP(EXCH)
EPROMOTE(3)
EOP(IADD); ! ADDRESSES ADDED
EOP(EXCH)
%FINISH
%CONTINUE
TRIPSW(73): ! on event1 On entering the routine
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
Eprecall(Worka_plabs(2))
lres=load(opnd2,0)
eop(Pushval)
Estklit(0)
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
Eprecall(D)
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
Eprecall(Known xref(6))
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+OPND1_XTRA
%IF D=1 %THEN DFETCHAD(C,TCELL_UIOJ>>4&15,JJ,0) %ELSEIF D=2 %THEN %C
DSTORE(1,ESTORE,C,TCELL_UIOJ>>4&15,JJ,0) %ELSE 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)
%FINISHELSESTART
%if opnd1_ptype&7>2 %then c=4 %else C=BYTES(OPND1_PTYPE>>4&15)
D=C
%IF C<4 %THEN C=4
! %IF D<2 %THEN D=2
GET WSP(TEMPLOC,C>>2)
DSTORE(opnd1_ptype&7,EDUPSTORE,D,CURRINF_RBASE,TEMPLOC,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
%INTEGERFN 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
%LONGREAL 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<<k&B'11110100'=0;! k=2 & 4-7 only
%IF K>9 %THEN IMPABORT
->SW(K)
SW(0): ! CONSTANT < 16 BITS
SW(1):
%IF TYPE=5 %THEN ->SCONST
%IF TYPE=1 %THEN ESTKLIT(OPND_D) %AND ->LDED
%IF TYPE=2 %or type=10 %THENSTART;! 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))) %ELSESTART
KK=WORKA_A(OPND_D)
LENGTH(SVAL)=KK
%FOR KK=1,1,KK %CYCLE
CHARNO(SVAL,KK)=WORKA_A(OPND_D+KK)
%REPEAT
%FINISH
%IF HOST#TARGET %THEN CHANGE SEX(ADDR(SVAL),0,KK+1)
ESTKCONST(KK+1,ADDR(SVAL))
EOP(EADDRESS)
->LDED
SW(3): ! 128 BIT CONSTANT
IMPABORT
SW(2): ! NAME
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)
%FINISHELSEIF 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,Adid)
%FINISHELSE DFETCH(1,4,B,TCELL_SLINK,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
%FINISHELSESTART
INDLOAD(TYPE,BYTES(PREC),KK)
%FINISH
->LDED
SW(7): ! I-R IN A STACK FRAME
B=OPND_D>>16; D=OPND_D&X'FFFF'
Chkass=0 %if B=0
%IF TYPE=5 %or type=3 %THENSTART
%IF OPND_XTRA=M'DUPL' %THEN DFETCH(1,4,B,D,0) %ELSE DFETCHAD(1,B,D+OPND_XTRA-1,0)
%FINISHELSESTART
%IF OPND_XTRA=M'ARRH' %THEN FETCH HIGH AD END(B,D,Adid) %ELSE 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
%INTEGERFN STRINGLBAD(%RECORD (TAGF) %NAME TCELL)
!***********************************************************************
!* RETURNS B<<16!D OF THE STRING LENGTH BYTE *
!* FN NEEDED AS GLA FORWARD & STACK BACKWARD *
!***********************************************************************
%INTEGER B,D,X,RL
%RECORD (LEVELF) %NAME INF
D=TCELL_SLINK
B=TCELL_UIOJ>>4&15
%IF B=0 %THENRESULT=D
INF==WORKA_LEVELINF(RLEVTOLEVEL(B))
X=INF_DISPLAY
%IF D<X %THEN RL=3 %ELSE RL=1; ! PARAMETER 32 BIT ALIGNED OTHERS 16 BIT
D=(D+TCELL_ACC+RL)&(\RL)-1
%RESULT=D
%END
%INTEGERFN RECORDELAD(%RECORD (TAGF) %NAME TCELL, %INTEGER SPTYPE,XDISP)
!***********************************************************************
!* RETURNS THE DISP OF A RECORD ELEMENT *
!***********************************************************************
%INTEGER B,D
D=TCELL_SLINK
B=TCELL_UIOJ>>4&15
XDISP=XDISP&X'FFFF'
%IF B=0 %THENRESULT=D+XDISP
D=D+TCELL_ACC-XDISP
%IF SPTYPE&7=5 %THENRESULT=D-1
D=D-BYTES(SPTYPE>>4&7)
! %if 1<<target&halfswopped#0 %and (sptype=X'31' %or sptype=x'41') %c
%then d=d!!2
! %IF 1<<target&byteswopped#0 %and SPTYPE=X'31' %THEN D=D!!1
%RESULT=D
%END
%ROUTINE INDLOAD(%INTEGER TYPE,SIZE,OFFSET)
!***********************************************************************
!* LOADS REG VIA INDIRECTION POINTER ON ETOS *
!***********************************************************************
%IF TYPE=1 %AND SIZE=8 %START
EOP(DUPL)
EREFER(OFFSET+4,4)
EOP(EXCH)
EREFER(OFFSET,4)
%FINISHELSE EREFER(OFFSET,SIZE)
%END
%ROUTINE INDSTORE(%INTEGER TYPE,SIZE,OFFSET)
!***********************************************************************
!* STORES REG VIA INDIRECTION POINTER ON ETOS *
!* WHEN REG ALSO = ETOS %THEN ROUTINE ASSUMES CORRECT ORDERING *
!***********************************************************************
%IF TYPE=1 %AND SIZE=8 %START
EOP(DUPL)
EPROMOTE(4)
EOP(EXCH)
EREFER(OFFSET+4,4)
EOP(ESTORE)
EREFER(OFFSET,4)
EOP(ESTORE)
%ELSE
EREFER(OFFSET,SIZE)
EOP(ESTORE)
%FINISH
%END
%ROUTINE LOADAD(%RECORD (RD) %NAME OPND)
!***********************************************************************
!* MUCH AS LOAD BUT PRODUCES THE 32 BIT ADDRESS OF OPERAND *
!* ABORT ON NON RELEVANT ALTERNATIVES OF OPND *
!***********************************************************************
%RECORD (TRIPF) %NAME REFTRIP
%RECORD (TAGF) %NAME TCELL
%RECORD (RD) ROPND
%INTEGER B,D,X,K,PTYPE,Adid
%SWITCH SW(0:9)
PTYPE=OPND_PTYPE
Adid=0
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))
B=TCELL_UIOJ>>4&15
%IF TCELL_PTYPE&X'3FFF'=X'33' %THEN D=RECORDELAD(TCELL,PTYPE,X) %ELSEIF %C
PTYPE&255=X'35' %THEN D=STRINGLBAD(TCELL) %ELSE D=TCELL_SLINK
DFETCHAD(BYTES(PTYPE>>4&15),B,D&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
%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 %THENSTART
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'
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' %THENSTART
D=RECORDELAD(TCELL,PTYPE,X)
%FINISHELSEIF PTYPE&255=X'35' %THEN D=STRINGLBAD(TCELL) %ELSE D=TCELL_SLINK
%IF PTYPE&255=X'35' %THENSTART
PTYPE=CURRT_X1>>16
DFETCHAD(1,TCELL_UIOJ>>4&15,D&X'FFFF',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,Adid)
->LDED
%FINISH
DFETCH(1,4,TCELL_UIOJ>>4&15,TCELL_SLINK,Adid)
->INC ADDR
SW(6): ! INDIRECT OFFSET
REFTRIP==TRIPLES(OPND_D)
%IF REFTRIP_PUSE#WTRIPNO %THENSTART
ROPND=OPND
ROPND_PTYPE=REFTRIP_OPTYPE
ROPND_FLAG=8
LRES=LOAD(ROPND,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') %ELSESTART
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 %THENSTART
EREFER(4,2)
ESTKLIT(1)
EOP(ISUB)
%FINISH
%FINISH
SLDED: ! STRING PTR LOADED
OPND_PTYPE=X'61'; ! STR PNTERS ARE 64 BIT
OPND_FLAG=9
OPND_XB=ESTK
%RETURN
SW(7): ! LOCAL BASE&DISP(RESULTS FROM MAP OPTIMISATIONS)
B=OPND_D>>16
D=OPND_D&X'FFFF'
DFETCHAD(BYTES(PTYPE>>4&7),B,D,0)
->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 %ELSESTART
CHOP OPERAND(OPND2,x'51',0); ! to dv ptr
DOPND=OPND2; ! for second load if needed
%FINISH
%IF PARM_ARR#0 %START
%IF DVPOS>0 %START; ! BOUND KNOWN
ESTKLIT(BYTESWOP(CTABLE(DVPOS+3*C+1)))
ESTKLIT(BYTESWOP(CTABLE(DVPOS+3*C)))
%FINISHELSESTART
LRES=LOAD(OPND2,0); ! fetch dv ptr
EOP(DUPL)
EREFER(12*C+4,4)
EOP(EXCH)
EREFER(12*C,4)
%FINISH
EOP(CHK)
%FINISH
%IF C#1 %START; ! ALL DIMENSION BAR 1ST
%IF DVPOS>0 %THENSTART
ESTKLIT(BYTESWOP(CTABLE(DVPOS+3*C-1)))
%FINISHELSESTART
LRES=LOAD(DOPND,0); ! 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
%RECORD (TAGF) %NAME TCELL
OLDPT=OPND_PTYPE&255
OPND_PTYPE=OPND_PTYPE&X'FF00'!NEWPT
%IF OPND_FLAG=9 %THEN IMPABORT
%IF XOFFSET<0 %THENRETURN
%IF OPND_FLAG=DNAME %START
TCELL==ASLIST(TAGS(OPND_D))
%IF TCELL_PTYPE&x'3FFF'=x'33' %THEN S1=RECORDELAD(TCELL,OLDPT,OPND_XTRA) %ELSE %C
S1=TCELL_SLINK
OPND_D=(TCELL_UIOJ>>4&15)<<16!S1
OPND_FLAG=LOCAL IR
%FINISH
%IF OPND_FLAG=INDIRECT %OR OPND_FLAG=INDNAME %THEN OPND_XTRA=OPND_XTRA&X'FFFF'+XOFFSET
%IF OPND_FLAG=LOCALIR %THENSTART
%IF OPND_D>>16=0 %THEN OPND_D=OPND_D+XOFFSET %ELSESTART
S1=BYTES(OLDPT>>4)
S2=BYTES(NEWPT>>4)
OPND_D=OPND_D+S1-S2-XOFFSET
%FINISH
%FINISH
%END
%INTEGERFN RLEVTOLEVEL(%INTEGER RLEV)
!*********************************************************************
!* FIND LEVEL FOR VAR WHOSE RLEVEL IS KNOWN *
!***********************************************************************
%INTEGER I
%RECORD (LEVELF) %NAME INF
I=1
%CYCLE
INF==WORKA_LEVELINF(I)
%IF INF_RBASE=RLEV %THENRESULT=I
I=I+1
%REPEAT
%END
%ROUTINE DSTORE(%INTEGER TYPE,OPCODE,SIZE,RLEVEL,DISP,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
%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 %ELSEIF RLEVEL=CURRINF_RBASE %THEN LEVELCODE=1 %ELSE %C
LEVELCODE=2
->SW(LEVELCODE)
SW(*): ! FUNNY SIZES
IMPABORT
SW(0): ! GLOBAL FETCH
ESTKDIR(2 {gla},DISP,Adid,SIZE)
%RETURN
SW(1): ! LOCAL FETCH
%if disp<currinf_display %then inf==currinf %and ->param
ESTKDIR(0 {stack},CURRINF_DISPLAY-(DISP+SIZE),Adid,SIZE)
%RETURN
SW(2): ! INTERMEDIATE WORD FETCH
INF==WORKA_LEVELINF(RLEVTOLEVEL(RLEVEL))
%if disp>inf_display %then %start
ESTKGLOBAL(RLEVEL,INF_DISPLAY-(DISP+SIZE),Adid,SIZE)
%return
%finish
param:
estkpar(Rlevel,inf_display-(disp+size),Adid,size)
%END
%ROUTINE FETCH HIGH AD END(%INTEGER B,D,Adid)
!***********************************************************************
!* FETCHES THE HIGH END OF ARRAYHEAD(IE @A(FIRST)) OR STRINGNAME *
!***********************************************************************
%IF B=0 %THEN D=D+4
DFETCH(1,4,B,D,Adid)
%END
%ROUTINE FETCH LOW AD END(%INTEGER B,D,Adid)
!***********************************************************************
!* FETCHES LOW END OF ARRAYHD(IE DV PTR) OR STRINGHEAD(IE ACC) *
!***********************************************************************
%IF B#0 %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 *
!***********************************************************************
%IF B=0 %THEN D=D+4
DSTORE(1,ESTORE,4,B,D,Adid)
%END
%ROUTINE STORE LOW AD END(%INTEGER B,D,Adid)
!***********************************************************************
!* STORES LOW END OF ARRAYHD(IE DV PTR) OR STRINGHEAD(IE ACC) *
!***********************************************************************
%IF B#0 %THEN D=D+4
DSTORE(1,ESTORE,4,B,D,Adid)
%END
%INTEGERFN JCODE(%INTEGER TFMASK)
!***********************************************************************
!* PRODUCES JUMP CODE FROM IBM TYPE BRANCH MASK AND EXTRA BITS *
!* x20 bit set for comparisons with zero *
!* x40 bit if compare has been omitted *
!* x100 bit set for real comparisons *
!* x80 bit set for reversed comparisons *
!***********************************************************************
%INTEGER D
%IF TFMASK&15=15 %THENRESULT=JUMP
%IF TFMASK&X'40'#0 %START; ! OPTIMISED BY CCOMP
! NEXT LINE ASSUMES BFFLAG IS
! STILL AS SET BY CCOMP!
D=32+16*BFFLAG+TFMASK&15
%IF TFMASK&x'100'#0 %THEN D=D+64
D=FCOMP(D)
%IF TFMASK&x'20'#0 %THEN D=D+(JINTGZ-JIGT)
%RESULT=D
%FINISH
%IF TFMASK&128#0 %THENRESULT=JFALSE
%RESULT=JTRUE
%END
%ROUTINE ISTARSTAR
!***********************************************************************
!* PLANT IN LINE CODE FOR INTEGER****INTEGER *
!* IN LINE CODE RATHER THAN SUBROUTINE BECAUSE OF NO JLK *
!***********************************************************************
ESTKLIT(0)
EOP(EPOWER)
%END
%ROUTINE STARSTAR
!***********************************************************************
!* PLANT IN LINE CODE FOR REAL**INTEGER *
!* IN LINE CODE RATHER THAN SUBROUTINE BECAUSE OF THE NO OF CASES *
!* NEEDED ON A REGISTER MACHINE WITH 2 LENGTHS OF ARITHMETIC *
!***********************************************************************
%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 *
!***********************************************************************
%CONSTINTEGER NEEDS RES=X'40016'; ! FLAGS EPS 1,2,4&18
%INTEGER C,X,ID
EPRECALL(KNOWN XREF(4))
EOP(PUSHVAL)
ESTKLIT(N)
EOP(PUSHVAL)
%IF 1<<N&NEEDS RES=0 %or xtra=-1{skip symbol special} %THEN X=0 %ELSE X=4<<8!1; ! 4 BYTE INTEGER RESULT
ECALL2(KNOWN XREF(4),1,0,8)
%if X#0 %then Estkresult(0,1,4)
%END
%END; ! OF ROUTINE GENERATE
%ENDOFFILE