%INCLUDE "ERCC07:iTRIMP_HOSTCODES"
%CONSTINTEGER HOST=AMDAHL
%CONSTINTEGER TARGET=PNX
%INCLUDE "ERCS04:PNX_CCODES"
%INCLUDE "ERCC07:TRIPCNSTS"
%INCLUDE "ERCC07:ITRIMP_TFORM2S"
%CONSTINTEGER ESTK=0,BR0=1,BR1=2,BR2=3,BR3=4,FR0=5,FR1=6,FR2=7,FR3=8,
BRN=BR0<<16!BR3,FRN=FR0<<16!FR3
%RECORDFORMAT REGF(%INTEGER CL,(%INTEGER USE %ORHALF SECUSE,PRIMUSE), %INTEGER INF1,INF2,AT,
LINK)
%OWNINTEGER CABUF,GLACABUF,GLABEL,FPPTR,FPHEAD
%OWNINTEGERNAME CA,GLACA,PPCURR
%OWNINTEGERARRAYNAME CTABLE,TAGS
!%OWNBYTEINTEGERARRAYNAME CODE
%OWNRECORD (LISTF) %ARRAYNAME ASLIST
%EXTRINSICINTEGERARRAY CAS(0:12)
%EXTRINSICRECORD (WORKAF) WORKA
%EXTRINSICRECORD (PARMF) PARM
%CONSTINTEGER MAXREG=8
%OWNRECORD (REGF) %ARRAY REGS(0:MAXREG)
%EXTERNALROUTINESPEC FLAGAND FOLD(%RECORD (TRIPF) %ARRAYNAME T)
%EXTERNALINTEGERMAPSPEC COMREG %ALIAS "S#COMREGMAP"(%INTEGER N)
%EXTERNALROUTINESPEC FAULT(%INTEGER I,J,K)
%INCLUDE "ERCS04:PNX_PUTSPECS"
%CONSTINTEGER MAXKXREF=5
%OWNINTEGERARRAY KXREFS(0:MAXKXREF)=-1(*)
%CONSTSTRING (7) %ARRAY PLNAME(0:31)="plabs00","plabs01",
"p_cndgs","plabs03","plabs04",
"p_unass","p_swerr","p_exper",
"p_xblks","p_capex","p_nores",
"p_forer","p_reser","p_aberr",
"plabs14","plabs15","p_stres",
"plabs17","p_strjt","plabs19",
"p_iexpn","p_rexpn","p_lrexp",
"plabs23","p_conct","plabs25",
"p_chkbp","plabs27","p_stcmp",
"p_mvbb","plabs30","plabs31"
%CONSTSTRING (11) %ARRAY KXREFNAME(0:MAXKXREF)="s#stop","s#ndiag",
"s#ilog","s#iexp","s#iocp",
"icl9ceauxst"
%EXTERNALSTRING (255) %FNSPEC PRINTNAME(%INTEGER NAME)
%EXTERNALROUTINESPEC PRINT TRIPS(%RECORD (TRIPF) %ARRAYNAME T)
%ROUTINESPEC CNOP(%INTEGER I,J)
%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)
%ROUTINESPEC REFORMATC(%RECORD (RD) %NAME OPND)
%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;
%CONSTBYTEINTEGERARRAY WORDS(0:7)=0(3),1,1,1,2,4;
%CONSTINTEGER DAREA=6; ! AREA FOR DIAG TABLES
%CONSTINTEGER CAREA=10; ! AREA FOR CONSTANTS
!
! FIXED GLA CURRENTLY USED AS FOLLOWS
! 0-7 FREE(WAS 2900 ENTRY DESCRIPTOR)
! 8-11 ADDRESS OF UNSHARED SYMBOL TABLES
! 12-15 ADDRESS OF SHARED SYMBOL TABLES
! 16-19 LANGUAGE & COMPILER DATA
! 20-23 ADDRESS OF DAREA WHEN DAREA#SST
! 24-27 ADDRESS OF CONSTANT TABLE
! 28-31 ADDRESS OF A WORD CONTAINING STACKTOP 0FOR NO CHECKS
! 32-35 HOLDS M'IDIA' FOR DIAGNOSTIC IDENTIFICATION
! 36-39 FREE
! 40-55 DEFINES THE ENTRY POINT OF MDIAGS
!
%CONSTINTEGER FIXEDGLALEN=56
%OWNINTEGERARRAY FIXED GLA(0:FIXEDGLALEN>>2-1)=M'IMP ',M'GLAP',
0(6),M'IDIA',0(*)
!
!***********************************************************************
!* IMP CODE PLANTING ROUTINES *
!* CODE AND GLAP ARE PUT INTO THE BUFFERS 'CODE,GLABUF(0:268)' *
!* BY A NUMBER OF TRIVIAL ROUTINES.QPUT IS CALLED TO ADD THE *
!* BUFFER TO THE OUTPUT FILE. THE BUFFERS ARE BASICALLY 0:255 *
!* WITH A 12-BYTE MARGIN TO MINIMISE THE NUMBER OF TESTS FOR *
!* THE BUFFER FULL CONDITION *
!* *
!* PPCURR(GLACURR) IS THE BUFFER POINTER *
!* CA(GLACA) IS THE RELATIVE ADDRESS OF THE NEXT BYTE *
!* CABUF(GLACABUF) IS CA(GLACA) FOR START OF BUFFER *
!***********************************************************************
!*DELSTART
%ROUTINE CPINIT
!***********************************************************************
!* PERFORMS ANY NECESSARY TARGET DEPENDANT INITIALISING *
!************************************************************************
PINITIALISE(1,WORKA_RELEASE,1); ! OPEN OBJECT FILE
TAGS==WORKA_TAGS
PMONON %IF PARM_DCOMP#0 %AND PARM_Z#0
%END
%EXTERNALROUTINE CODEOUT
!***********************************************************************
!* NEEDED TO SATISFY REFERENCE IN PASS2 *
!***********************************************************************
%END
%ROUTINE CNOP(%INTEGER I,J)
PI(NULL) %WHILE CA&(J-1)#I
%END
%ROUTINE STORE CONST(%INTEGERNAME D, %RECORD (RD) %NAME OPND)
!***********************************************************************
!* PUT THE CONSTANT OPND INTO THE CONSTANT TABLE *
!* ONLY USED FOR LONG REALS ON PNX *
!* A CHECK IS MADE TO SEE IF THE CONSTANT HAS ALREADY *
!* BEEN INSERTED IN WHICH CASE THE OLD COPY IS REUSED *
!***********************************************************************
%INTEGER J,K,LP,PR
%INTEGERNAME CONST PTR
CONST PTR==WORKA_CONST PTR
K=WORKA_CONST BTM; ! AFTER STRINGS IN CTABLE
PR=OPND_PTYPE>>4&15
LP=WORDS(PR); ! MAINTAIN GENERALITY
J=CONSTPTR-LP
%WHILE K<=J %CYCLE
%IF CTABLE(K)=OPND_D %AND (LP=1 %OR CTABLE(K+1)=OPND_XTRA) %THEN D=4*K %ANDRETURN
K=K+1
%REPEAT
! %IF CONST PTR&1#0 %THEN CONSTHOLE=CONST PTR %AND CONSTPTR=CONST PTR+1
D=4*CONST PTR
CTABLE(CONSTPTR)=OPND_D
%IF LP>1 %THEN CTABLE(CONSTPTR+1)=OPND_XTRA
CONST PTR=CONST PTR+LP
%IF CONST PTR>WORKA_CONST LIMIT %THEN FAULT(102,WORKA_WKFILEK,0)
%END
%ROUTINE STORE STRING(%INTEGERNAME D, %STRINGNAME S)
!***********************************************************************
!* PUT THE STRING CONSTANT "S" INTO THE CONSTANT TABLE *
!* A CHECK IS MADE TO SEE IF THE CONSTANT HAS ALREADY *
!* BEEN INSERTED IN WHICH CASE THE OLD COPY IS REUSED *
!***********************************************************************
%INTEGER J,K,LP
%INTEGERNAME CONST PTR
%IF S="" %THEN D=4 %ANDRETURN; ! NULL STRING SET UP IN PROLOGUE
CONST PTR==WORKA_CONST PTR
K=WORKA_CONST BTM; ! AFTER STRINGS IN CTABLE
LP=1+LENGTH(S)//4
J=CONSTPTR-LP
%WHILE K<=J %CYCLE
%IF S=STRING(ADDR(CTABLE(K))) %THEN D=4*K %ANDRETURN
K=K+1
%REPEAT
! %IF CONST PTR&1#0 %THEN CONSTHOLE=CONST PTR %AND CONSTPTR=CONST PTR+1
D=4*CONST PTR
CTABLE(CONSTPTR+LP-1)=0; ! MAKE TRAILING BYTES ZERO
STRING(ADDR(CTABLE(CONSTPTR)))=S
%IF HOST#TARGET %THEN PREVERSEBYTES(CAREA,D,4*LP)
CONST PTR=CONST PTR+LP
%IF CONST PTR>WORKA_CONST LIMIT %THEN FAULT(102,WORKA_WKFILEK,0)
%END
%ROUTINE GET ENV(%INTEGERNAME HEAD)
!***********************************************************************
!* SAVE A COPY OF THE REGISTER STATE FOR FUTURE REFERENCE *
!***********************************************************************
%INTEGER I,USE
%RECORD (REGF) %NAME REG
%CYCLE I=0,1,MAXREG
REG==REGS(I)
USE=REG_USE&X'FF'; ! MAIN USE ONLY
PUSH(HEAD,REG_INF1,REG_AT,I<<8!USE) %IF USE#0
%REPEAT
%END
%ROUTINE RESTORE(%INTEGER HEAD)
!***********************************************************************
!* RESET THE REGISTERS TO ENVIRONMENT IN LIST HEADED BY 'HEAD' *
!***********************************************************************
%INTEGER I,R,USE,INF,AT
%RECORD (REGF) %NAME REG
%CYCLE I=0,1,MAXREG
REG==REGS(I)
%IF REG_CL>=0 %THEN REG_USE=0
%REPEAT
%WHILE HEAD#0 %CYCLE
POP(HEAD,INF,AT,I)
R=I>>8; USE=I&255
REG==REGS(R)
%IF REG_CL>=0 %THEN REG_USE=USE %AND REG_INF1=INF
REG_AT=AT
%REPEAT
%END
%ROUTINE REDUCE ENV(%INTEGERNAME OLDHEAD)
!***********************************************************************
!* REMOVES FROM ENVIRONMENT OLDHEAD ANYTHING INCOMPATABLE WITH *
!* THE CURRENT ENVIRONMENT. FOR MULTIPLE JUMPS TO LABELS *
!***********************************************************************
%INTEGERNAME HEAD
%INTEGER R,U,S1,S2,S3
%RECORD (LISTF) %NAME LCELL
%RECORD (REGF) %NAME REG
HEAD==OLDHEAD
%WHILE HEAD>0 %CYCLE
LCELL==ASLIST(HEAD)
R=LCELL_S3>>8
U=LCELL_S3&255
REG==REGS(R)
%IF (REG_PRIMUSE=U %AND REG_INF1=LCELL_S1) %OR (REG_SECUSE=U %AND %C
REG_INF2=LCELL_S1) %START
HEAD==LCELL_LINK
%IF REG_AT>LCELL_S2 %THEN LCELL_S2=REG_AT
! TAKE MOST RECENT VERSION OF AT
%FINISHELSE POP(HEAD,S1,S2,S3)
%REPEAT
%END
%ROUTINE FORGET(%INTEGER REG)
!***********************************************************************
!* CLEARS OUT USES OF NON LOCKED REGISTERS *
!***********************************************************************
%INTEGER L,U
%RECORD (REGF) %NAME FREG
L=REG; U=L
%IF L<0 %THEN L=0 %AND U=MAXREG
%CYCLE REG=L,1,U
FREG==REGS(REG); ! FORGETABLE REG
%IF FREG_CL>=0 %THEN FREG_USE=0
%REPEAT
%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)
PDBYTES(AREA,PTR,AD,L)
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 *
!***********************************************************************
%INTEGERNAME PTR
PTR==CAS(AREA)
PTR=(PTR+BNDRY-1)&(-BNDRY)
PDPATTERN(AREA,PTR,REP,L,AD)
PTR=PTR+REP*L
%END
%EXTERNALINTEGERFN PINITOWN(%INTEGER PTYPE,ACC, %RECORD (RD) %NAME INIT, %STRINGNAME XNAME)
!***********************************************************************
!* PUTS AN INITIALISED OWN INTO THE GLA. SHOULD DEAL WITH ALL TYPES *
!***********************************************************************
%RECORD (RD) OPND
%INTEGER PREC,TYPE,RL,RES,X,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
PD4(2,RES,OPND_XTRA)
PD4(2,RES+4,OPND_D)
GLACA=GLACA+8
%FINISHELSESTART
PD4(2,RES,OPND_D)
GLACA=GLACA+4
%FINISH
%IF LITL=3 %START; ! EXTRINSICS ARE NAMES
X=PXNAME(0,XNAME)
J=2
%IF TYPE=1 %AND PREC=3 %THEN J=X'80000002'; ! BYTE ADDRESS
%IF TYPE=5 %THEN pdxref(j,RES+4,X) %else PDXREF(J,RES,X)
%FINISH
->END
%FINISH
%IF TYPE=2 %THEN REFORMATC(OPND)
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
PDPATTERN(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
PDPATTERN(2,RES,1,ACC,ADDR(IS)); ! ALLOW FOR ALIGNMENT ON PNX
%IF HOST#TARGET %THEN PREVERSEBYTES(2,RES,ACC)
%FINISHELSESTART
%IF PREC=3 %THEN PD(2,RES,OPND_D)
%IF PREC=4 %THEN PD2(2,RES,OPND_D)
%IF PREC>=5 %THEN PD4(2,RES,OPND_D)
%IF PREC=6 %THEN PD4(2,RES+4,OPND_XTRA)
%FINISH
END: ! NOTE ENTRYT IF EXTERNAL
%IF LITL=2 %THEN PDATAENTRY(XNAME,2 {GLA},ACC,RES)
%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,X,AHW0,AHW1,HAREA
AHW0=AOFFSET>>1
AHW1=DVOFFSET>>1
HAREA=2; ! NORMAL GLA
%IF PTYPE&255=X'31' %START; ! BYTE ARRAYS
HAREA=X'80000002'; ! GLA BUT BYTE NOT WORD RELOCATION
AHW0=AOFFSET; ! BYTE NOT WORD OFFSET
%FINISH
GLACA=(GLACA+3)&(-4)
RES=GLACA
GLACA=GLACA+8
LITL=PTYPE>>14&3
PFIX(2,RES,CAREA,DVOFFSET); ! RELOCATE DV PTR
%IF LITL=3 %START; ! EXTRINSIC ARRAYS
X=PXNAME(0,XNAME)
PDXREF(HAREA,RES+4,X)
%FINISHELSESTART
%IF AAREA=0 %THEN PD4(2,RES+4,AHW0) %ELSE PFIX(HAREA,RES+4,AAREA,AOFFSET)
%FINISH
%IF LITL=2 %THEN PDATAENTRY(XNAME,AAREA,SIZE,AOFFSET)
%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=PXNAME(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=PXNAME(1,S)
KXREFS(N)=D
%RESULT=D
%END
%ROUTINE CALL STOP
!***********************************************************************
!* CALLS STOP ROUTINE. NOT VIA EPILOGUE ON PERQ *
!***********************************************************************
PI1(CALL,KNOWN XREF(0)); ! S#STOP
%END
%ROUTINE ERASE(%INTEGER WORDS)
!***********************************************************************
!* REMOVES 1 OR 2 WORDS FROM THE ESTACK *
!***********************************************************************
%INTEGER I
PI(DISCARD) %FOR I=1,1,WORDS
%END
%ROUTINE EXCHANGE(%RECORD (RD) %NAME OPND1,OPND2)
!***********************************************************************
!* REVERSES NEST SO OPERAND 1 IS AT TOP FOR FLOATS ETC *
!* NO ACTION IF OPND2 IS A CONSTANT *
!***********************************************************************
%RETURNUNLESS OPND1_FLAG<=8 %AND OPND2_FLAG>=8 %AND OPND1\==OPND2
PI(EXCH)
%END
%ROUTINE BULKM(%INTEGER MODE,L,D2)
!***********************************************************************
!* PLANT CODE TO MOVE L BYTES (L KNOWN AT COMPILE TIME) FROM *
!* ETOS-2,ETOS-3 TO ETOS,ETOS-1 *
!* IF MODE =0 SET L BYTES TO D2(0 OR X'80') *
!* *
!* L MAY BE GREATER THAN 4095 *
!***********************************************************************
%INTEGER W2
%IF MODE=0 %START; ! CLEAR
W2=D2<<8!D2
%UNLESS L=2 %START; ! SET END 16? BIT WORD
PI(DUPL)
%FINISH
PLOADCONST(W2)
P2I(EXCH,ASSH)
L=L-2
%RETURNIF L=0
P2I(EXCH,DUPL); ! INIT NOT REMOVED FROM STACK
P2I(CI1,IADD)
%FINISH
PLOADCONST(L>>1)
PI(MVWD)
%END; ! OF ROUTINE BULK M
%ROUTINE PRINTUSE
!***********************************************************************
!* UP TO TWO USES ARE REMEMBERED INFO IN GRINF1 & GRINF2 *
!* BOTTOM HALF OF GRUSE RELATES TO INF1 TOP HALF TO INF2 *
!* THE MEANS CLEARING GRUSE TO FORGETS THE REG COMPLETELY *
!* ARRAY REGISTER KEEPS THE CLAIM STATUS AND GRAT THE LAST USE *
!***********************************************************************
%CONSTSTRING (3) %ARRAY REGNAMES(0:MAXREG)="ESK","BR0","BR1","BR2",
"BR3","FR0","FR1","FR2","FR3"
%CONSTSTRING (15) %ARRAY USES(0:15)=" NOT KNOWN "," I-RESULT ",
" TEMPORARY "," PLTBASE ",
" NAMEBASE "," LIT CONST ",
" TAB CONST "," DESC FOR ",
" RECD BASE "," LOCAL VAR ",
" NAME+CNST "," AUXSTPTR- ",
" BYTE DES "," HALF DES ",
" VMY RES "," DV BASE "
%CONSTSTRING (11) %ARRAY STATE(-1:3)= %C
" LOCKED "," FREE ",
" I-RESULT "," TEMPORARY ",
" RT-PARAM "
%ROUTINESPEC OUT(%INTEGER USE,INF)
%INTEGER I,USE
%RECORD (REGF) %NAME REG
NEWLINE
%CYCLE I=0,1,MAXREG
REG==REGS(I)
%IF REG_CL!REG_USE#0 %START
USE=REG_USE
PRINTSTRING(REGNAMES(I).STATE(REG_CL))
WRITE(REG_AT,3); SPACE
OUT(USE&255,REG_INF1)
%IF USE>>16#0 %THEN PRINTSTRING(" ALSO ") %AND OUT(USE>>16,REG_INF2)
NEWLINE
%FINISH
%REPEAT
%RETURN
%ROUTINE OUT(%INTEGER USE,INF)
%CONSTINTEGER LNMASK=B'0100011110000000'
%CONSTINTEGER UNMASK=B'0100001110000000'
PRINTSTRING(" USE = ".USES(USE))
%IF LNMASK&1<<USE#0 %THEN PRINTSTRING(PRINTNAME(INF&X'FFFF')) %ELSE WRITE(INF,1)
%IF USE=10 %THEN PRINTSYMBOL('+') %AND WRITE(INF>>16,1)
%IF UNMASK&1<<USE#0 %AND INF>>16#0 %THEN %C
PRINTSTRING(" MODBY ") %AND PRINTSTRING(PRINTNAME(INF>>16))
%END
%END
%EXTERNALROUTINE IMPABORT
PRINTSTRING("
**************** ABORT******************** ABORT *******")
!*DELSTART
PCODELINE
PRINT USE
!*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
CPINIT; ! INITIALISE CODE PLANTING
ASLIST==ALIST
GLABEL=WORKA_NNAMES+1; ! FOR GENERATING LABELS
FPPTR=0
FPHEAD=0
CA==CAS(1)
GLACA==CAS(2)
GLACA=FIXEDGLALEN
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,FR3; ! HIGHEST PNX REG
REGS(I)=0
KXREFS(I)=-1 %IF I<=MAXKXREF
%REPEAT
!
! GENERATE THE RUN TIME ERROR ROUTINE :-
! MDIAGS FOR PERQ IS %ROUTINE MDIAGS(%INT PC,AP,ERROR,XTRA)
! PC IS A DUMMY EXCEPT AFTER CONTINGENCY
! ON ENTRY TO THIS SUBROUTINE ERROR & XTRA ARE IN ETOS
! ENTRY HAS BEEN BY JMPW LINKREG SO RETURN ADDRESS IS NOT AVAILABLE
!
! LAS 0 CURRENT LNB TO ETOS
! CI0 DUMMY CALLING PC
! IPUSH, IPUSH ABOVE TWO REVERSED TO MEMMORY
! IPUSH, IPUSH ZERO AND EXTRA TO MEMORY
! CALL N CALL TO NDIAGS
! RETURN
!
K=KNOWN XREF(1); ! NDIAG XREF (AS NO ZERO) OBTAINED
S=PLNAME(2)
PPROC(S,0,WORKA_PLABS(2))
%IF PARAMS BWARDS=YES %THENSTART
P3I(EXCH,IPUSH,IPUSH)
PI1(LAS,0)
PI(LI)
P3I(IPUSH,CI0,IPUSH)
%FINISHELSESTART
PI1(LAS,0)
PI(LI)
PI(CI0)
P4I(IPUSH,IPUSH,IPUSH,IPUSH)
%FINISH
PI1(CALL,K)
PI1(ASFW,16)
PI(RETURN); ! ONLY NEEDED FOR %MONITOR
PPROCEND(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(1)=0; ! NULL STRING
WORKA_CONST PTR=2
WORKA_CONST BTM=WORKA_CONST PTR
%IF PARM_PROF#0 %THENSTART; ! ALLOCATE PROFILE COUNT AREA
%FINISH
PLINESTART(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)
PPROC(S,2,WORKA_PLABS(LAB))
%IF MODE=0 %THEN PLOAD CONST(0)
PLOADCONST(ERRNO)
PI1(CALL,WORKA_PLABS(2))
PPROCEND(0)
%END
%END
%EXTERNALROUTINE EPILOGUE(%INTEGER STMTS)
!***********************************************************************
!* PLANT ANY SUBROUINES THAT HAVE BEEN REQUIRED DURING *
!* THE CODE GENERATION PHASE *
!***********************************************************************
%ROUTINESPEC FILL(%INTEGER LAB)
PLINESTART(9999); ! PSEUDO LINE NO
!
! STRING RESOLUTION ROUTINE (ENTERED BY CALL)
! P6 = WORD ADDRESS OF STRING BEING RESOLVED
! P5 = WORD ADDR OF (ORIGINAL LENGTH! BYTES USED UP<<16)
! P4 = LMAXOF FRAGMENT HOLING STRING(=0 NO SUCH STRING)
! P3 = WORD ADDRESS OF FRAGMENT STRING
! P2 = WORD ADRESS OF RESOLUTION STRING(CONVERTED TO BYTE FORM ON ENTRY)
! P1 = DUMMY SET IN ROUTINE TO ORIGINAL LENGTH
! 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 = CH COMPARE CONTRO FOR LOOP 1,1,L2
! L6&7 = 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
!
! SAVE2
! CI1 ISL4 INITIALISE CONTROL
! LLOS(P5), MASKH, ISP1 COPY BYTES IN ORIGINAL STRING
! LHLOS(P5), ISL1 COPY OF BYTES USED UP
! ISUB BYTES LEFT OF LHS
! ILP2, CVBA, ISP2 EXAMINE RESOLUTION STRING
! LBI, ISL2 AND GET ITS CURRENT LENGTH
! JFALSE <RESOK (L5)> RESOLVING ON NULL STRING
! ILL2, ISUB 0 LENGTH DIFF =1 VALID COMP
! CI1, IADD, ISL3 MAX NO OF VALID COMPARISONS
! CI0, IJLE <RESFAIL (L4)> NOT ENOUGH LEFT OF LHS
! ILP6, CVBA, ILL1, IADD, ISL8
!
! STAGE 2 CYCLE ROUND WITH BYTEARRAY COMPARISONS TO LOCATE STRING
!
!OUTERLOOP(L0): REPITIONS TO HERE
! ILP2, CI1, ISL5, IADD, ISL6 INIT CONTRO & SET BYTE PTR TO RESOLUTION
! ILL8, ILL4, IADD, ISL7 POINTER TO RIGHT BYTE IN LHS
!INNERLOOP(L1): REPEAT ON BYTE BY BYTE
! LBI, EXCH, LBI GET NEXT BYTE PAIR
! IJNE <DIFF FOUND (L3)> NOT THE SAME
! ILL5, CI1, IADD, ISL5 UPDATE CONTROL
! ILL2, IJGT<RESOK (L5)> ALL FOUND WITH NO NONEQIVALENCE
! CI1, LAS (L6), OAADD UPDATE FIRST POINTER
! CI1, LAS (L7), OAADD UPDATE SECOND PTR
! JUMP <INNERLOOP (L1)> AND REPEAT
!DIFF FOUND(L3): THIS COMPARISON FAILS
! ADVANCE DOWN BY ONE
! ILL4, CI1, IADD,ISL4 INCREMENT CONTROL
! ILL3, IJLE<OUTER LOOP (L0)> AND CONTINUE
!
!RESFAIL(L4): RESOLUTION HAS FAILED
! C1 X'701' SET ERROR NO IN CASE UNCONDITIONAL
! CI0, RETURN2 EXIT WITH FALSE SET
!RESOK(L5): RESOLUTION HAS WORKED
! ILP4, JFALSE <NOSTORE (L6)> FRAGMENT TO BE DISCARDED
!
! CONTROL IS NO OF BYTES TO BE STORED (IE L+1) OF FRAGMENT
! FIRST COPY IN BYTES + RUBBISH LENGTH THEN OVERWRITE
! WITH CORRECT LENGTH
!
! ILL8, SR1 SOURCE PTR
! ILP3, CVBA, SR0 DEST POINTER
! ILL4 BYTES TO MOVE
!MOVEMORE(L7): ASSIGN POSSIBLY OVERLAPPING
! ATR1,1, LBI
! ATR0,1, ASSB, DISCARD
! CI1, ISUB,DUPL
! JTRUE<MOVEMORE>
! ILL4, CI1, ISUB FRAGMENT LENGTH
! ILP3,CVBA, ASSB STORED WITH PTR
! ILP4, IJLE <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, SHLOS(P5) AND STORE VIA HALFWORD PTR
! CI1, RETURN2 EXIT WITH RESULT=TRUE
!
%IF WORKA_PLINK(16)=0 %THEN ->P17
FILL(16)
P2I(CI1,ISL4)
PI1(LLO,24)
P2I(MASKS,ISP1)
PI1(LHLO,24)
P2I(ISL1,ISUB)
P3I(ILP2,CVBA,ISP2)
P2I(LBI,ISL2)
PJUMP(JFALSE,GLABEL+5)
P2I(ILL2,ISUB)
P4I(CI1,IADD,ISL3,CI0)
PJUMP(IJLE,GLABEL+4)
PI1(ILL,28)
P4I(CVBA,ILL1,IADD,ISL8)
! THIS IS "OUTERLOOP"
PLABEL(GLABEL)
P4I(ILP2,CI1,ISL5,IADD)
PI(ISL6)
P4I(ILL8,ILL4,IADD,ISL7)
! THIS IS "INNERLOOP"
PLABEL(GLABEL+1)
P3I(LBI,EXCH,LBI)
PJUMP(IJNE,GLABEL+3)
P4I(ILL5,CI1,IADD,ISL5)
PI(ILL2)
PJUMP(IJGT,GLABEL+5)
PI(CI1)
PI1(LAS,-24)
P2I(OAADD,CI1)
PI1(LAS,-28)
PI(OAADD)
PJUMP(JUMP,GLABEL+1)
! THIS IS "DIFF FOUND"
PLABEL(GLABEL+3)
P4I(ILL4,CI1,IADD,ISL4)
PI(ILL3)
PJUMP(IJLE,GLABEL)
! THIS IS "RESFAIL"
PLABEL(GLABEL+4)
PLOADCONST(X'701')
PI(CI0)
PI(RETURN2)
! THIS IS "RESOK"
PLABEL(GLABEL+5)
PI(ILP4)
PJUMP(JFALSE,GLABEL+6)
P2I(ILL8,SR1)
P4I(ILP3,CVBA,SR0,ILL4)
PLABEL(GLABEL+7)
PI1(ATR1,1)
PI(LBI)
PI1(ATR0,1)
P2I(ASSB,DISCARD)
P3I(CI1,ISUB,DUPL)
PJUMP(JTRUE,GLABEL+7)
P3I(ILL4,CI1,ISUB)
P3I(ILP3,CVBA,ASSB)
PI(ILP4)
PJUMP(IJLE,GLABEL+6)
PI1(JLK,WORKA_PLABS(9))
! THIS IS "NOSTORE"
PLABEL(GLABEL+6)
P4I(ILL1,ILL2,IADD,ILL4)
P3I(IADD,CI1,ISUB)
PI1(SHLO,24)
P2I(CI1,RETURN2)
PPROCEND(32)
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
! P4 = VIRT (WORD) ADDR OF SOURCE
! P3 = MAX LENGTH OF DEST
! P2 = VIRT (WORD) ADDR OF DEST
! P1 = DUMMY FOR ALIGNMENT
! L1 = LOCAL THE ACTUAL STRING BYTES TO BE MOVED
!
! ILP4, CVBA, LBI, ISL1 LENGTH OF SOURCE
! ILP3, IJLE <L0> NO TRUNCATION
! ILP3, ISL1 TRUNCATED LENGTH
!L0: ILP4, CVBA
! ILP2, CVBA,ILL1
! CI1, IADD, MOVE LBYTES + LENGTH BYTE
! MVB
! ILL1, ILP2, CVBA, ASSB AND OVERWRITE LENGTH
! RETURN
!
%IF WORKA_PLINK(18)=0 %THEN ->P19
FILL(18)
P4I(ILP4,CVBA,LBI,ISL1)
PI(ILP3)
PJUMP(IJLE,GLABEL)
P2I(ILP3,ISL1)
PLABEL(GLABEL)
P4I(ILP4,CVBA,ILP2,CVBA)
P3I(ILL1,CI1,IADD)
PI(MVB)
P4I(ILL1,ILP2,CVBA,ASSB)
PI(RETURN)
PPROCEND(8)
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
! fault recorded unless 0<=n
!
! ISL1, STORE N IN LOCAL 1
! LCONST 0, IJGE L0
! LIX'505', CALL NDAIGS
!L0 LCONST 1, EXCH TO ACCUMLATOR SQUARES PRODUCT
!L1 ILL1, LCONST ILAND CHECK BOTTOM BIT
! JFALSE L2 USING ZERO=FALSE EQUIVALENC
! ISL2, IMULT, ILL2 MULTIPLY INTO SQUARES PRODUCT
!L2 ILL1, ISHL,-1, ISL1 SHIFT DOWN BITMASK
! JFALSE L3 AND EXIT WHEN NO MORE SQUARING NEEDED
! DUPL, IMULT, JUMP L1 SQUARE AND CONTINUE
!L3 DISCARD, RETURN LOSE FINAL SQUARE AND EXIT
!
%IF WORKA_PLINK(20)=0 %THEN ->P21; ! ROUTINE NOT USED
FILL(20)
PI(ISL1)
PLOADCONST(0)
PJUMP(IJGE,GLABEL)
PLOADCONST(X'505')
PI1(CALL,WORKA_PLABS(2)); ! TO NDIAGS ILLEGAL EXP
PLABEL(GLABEL)
PLOADCONST(1)
PI(EXCH)
PLABEL(GLABEL+1)
PI(ILL1)
PLOADCONST(1)
PI(ILAND)
PJUMP(JFALSE,GLABEL+2)
P2I(ISL2,IMULT)
PI(ILL2)
PLABEL(GLABEL+2)
PI(ILL1)
PI1(ISHL,-1)
PI(ISL1)
PJUMP(JFALSE,GLABEL+3)
PI(DUPL)
PI(IMULT)
PJUMP(JUMP,GLABEL+1)
PLABEL(GLABEL+3)
PI(DISCARD)
PI(RETURN)
PPROCEND(8)
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, CVBA, DUPL, LBI
! ISL1, EXCH, CI1, IADD, EXCH LENGTH OF MOVE OVER SOURCE
! ILP1, CVBA, DUPL, LBI
! ISL2, IADD, CI1, IADD
! EXCH, MVB STRINGS JOINED
! ILL1, ILL2, IADD, ILP1
! CVBA, ASSB,
! DISCARD REMOVE LENGTH
! RETURN
!
%IF WORKA_PLINK(24)=0 %THEN ->P25
FILL(24)
P4I(ILP2,CVBA,DUPL,LBI)
P3I(ISL1,EXCH,CI1)
P2I(IADD,EXCH)
P4I(ILP1,CVBA,DUPL,LBI)
P4I(ISL2,IADD,CI1,IADD)
PI(EXCH)
PI(MVB)
P4I(ILL1,ILL2,IADD,ILP1)
P3I(CVBA,ASSB,DISCARD)
PI(RETURN)
PPROCEND(8)
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
! ESTACK HAS TWO WORD ADDRESS AND ROUTINE RETURNS FIRST DIFFERENCE
!
! L1 HAS UPPER (BYTE) ADDRESS
! L2 HAS UPPER STRING LENGTH
! L3 HAS LOWER (BYTE) ADDRESS
! L4 HAS LOWER STRING LENGTH
! L5 HAS SHORTER STRING LENGTH
!
! CVBA ISL1, LBI, ISL2
! EXCH, CVBA, ISL3, LBI, ISL4, ISL5
! IJGE <L0>
! ILL2, ISL5 SHORTER LENGTH SET
! DISCARD NEEDED TO EMPTY ESTACK
! ILL3, CI1, IADD
! ILL1, CI1, IADD
! ILL5, STRCMP
! DUPL, JFALSE<L1>
! RETURN IPUSH EXCH DISCARD&IPOP
! NEEDED TO LEAVE ESTACK EMPTY
!L1: NO DIFFERENCE RETURN LENGTHS
! 3 DISCARDS TO EMPTY ESTACK
! ILL4, ILL2, RETURN
!
%IF WORKA_PLINK(28)=0 %THEN ->P29
FILL(28)
P4I(CVBA,ISL1,LBI,ISL2)
P3I(EXCH,CVBA,ISL3)
P3I(LBI,ISL4,ISL5)
PJUMP(IJGE,GLABEL)
P2I(ILL2,ISL5)
PLABEL(GLABEL)
P3I(ILL3,CI1,IADD)
P3I(ILL1,CI1,IADD)
P3I(ILL5,STRCMP,DUPL)
PJUMP(JFALSE,GLABEL+1)
PI(RETURN)
PLABEL(GLABEL+1)
P3I(ILL4,ILL2,RETURN)
PPROCEND(24)
GLABEL=GLABEL+2
P29:
!
! GENERATE A MOVE BYTES ROUTINE ENTERED BY CALL
! USED IN RESOLUTION FOR POSSIBLY OVERLAPPED MOVES
! (ETOS)=LENGTH
! (ETOS-2=>R0)=DEST ADDRESS IN BYTES
! (ETOS-4=>R1)=SOURCE ADDRESS IN BYTES
!
! SAVE2,EXCH,SR0,DISCARD DEST TO R0
! EXCH,SR1,DISCARD SOURCE TO R1
! DUPL,CI0,IJLE <L0>
!L1: ATR1 1, LBI, ATR0 1 GET CURRENT DEST&SRCE AND INC
! ASSB, DISCARD MOVE A SINGLE BYTE
! ILL4, ILL2,IADD,ASSB
! CI1,ISUB,DUPL,JTRUE <L1>
!L0: DISCRD,RETURN2
!
%IF WORKA_PLINK(29)=0 %THEN ->P30
FILL(29)
P4I(SAVE2,EXCH,SR0,DISCARD)
P3I(EXCH,SR1,DISCARD)
P2I(DUPL,CI0)
PJUMP(IJLE,GLABEL)
PLABEL(GLABEL+1)
PI1(ATR1,1)
PI(LBI)
PI1(ATR0,1)
P2I(ASSB,DISCARD)
P3I(CI1,ISUB,DUPL)
PJUMP(JTRUE,GLABEL+1)
PLABEL(GLABEL)
P2I(DISCARD,RETURN2)
PPROCEND(0)
GLABEL=GLABEL+2
P30:
%IF PARM_DCOMP#0 %THEN PRINTSTRING("
CODE FOR LINE 99999") %AND PCODELINE
%BEGIN
!***********************************************************************
!* PASS INFORMATION TO QPUT TO ENABLE IT TO GENERATE THE *
!* LOADER DATA AND COMPLETE THE PROGRAM FILE. *
!***********************************************************************
%ROUTINESPEC DUMPCONSTS
%INTEGERARRAY SIZES(0:10)
%INTEGER LANGFLAG,PARMS,I,K
! CODE OUT
! CNOP(0,8)
! FIXED GLA(6)=CA; ! CONST TABLE ADDRESS
DUMP CONSTS
%IF PARM_TRACE=0 %THEN LANGFLAG=6 %ELSE LANGFLAG=1
LANGFLAG=LANGFLAG<<24
PARMS=(PARM_DIAG<<1!PARM_LINE)<<1!PARM_TRACE
FIXED GLA(4)=LANGFLAG!WORKA_RELEASE<<16!(PARM_CPRMODE&1)<<8!PARMS; ! LANG RLSE & MAINPROG
I=GLACA-GLACABUF
%IF PARM_INHCODE=0 %THENSTART
! QPUT(42, I, GLACABUF, ADDR(GLABUF(0))) %UNLESS I=0
! BACK OF GLAP
PDBYTES(2,0,ADDR(FIXED GLA(0)),FIXEDGLALEN); ! FRONT OF GLAP
PFIX(2,8,5,0); ! RELOCATE GLA ST ADDRESS
PFIX(2,12,4,0); ! RELOCATE CODE ST ADDRESS
%IF PARM_TRACE#0 %THEN PFIX(2,20,DAREA,0); ! RELOCATE DAREA POINTER
PFIX(2,24,CAREA,0); ! RELOCATE CONSTANT TABLE
%IF PARM_TRACE#0 %THEN I=X'E2E2E2E2' %AND PDATA(DAREA,4,4,ADDR(I))
%FINISH
%CYCLE I=1,1,10
SIZES(I)=0
SIZES(I)=(CAS(I)+7)&(-8) %IF 2<=I<=6
%REPEAT
SIZES(CAREA)=((WORKA_CONSTPTR+1)>>1)*8
PTERMINATE(ADDR(SIZES(1))); ! SUMMARY INFO.
PRINTSTRING("
PNX CODE")
WRITE(SIZES(1)+SIZES(CAREA),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(CAREA)+SIZES(2)+SIZES(4)+SIZES(5)+SIZES(6)
WRITE(K,5); PRINTSTRING(" BYTES
")
%IF PARM_FAULTY=0 %THENSTART
WRITE(STMTS,7); PRINTSTRING(" STATEMENTS COMPILED")
COMREG(47)=STMTS; ! NO OF STMTS FOR COMPER
%FINISHELSESTART
PRINTSTRING("PROGRAM CONTAINS"); WRITE(PARM_FAULTY,2)
PRINTSTRING(" FAULT"); PRINTSYMBOL('S') %IF PARM_FAULTY>1
COMREG(47)=PARM_FAULTY; ! NO OF FAULTS FOR COMPER
%FINISH
NEWLINES(2)
I=0; I=8 %IF PARM_FAULTY#0
COMREG(24)=I
%ROUTINE DUMP CONSTS
!***********************************************************************
!* OUTPUT THE CONSTANT TABLE AND MAKE ANY RELEVANT RELOCATIONS *
!***********************************************************************
%INTEGER I,J,K,BASE
BASE=ADDR(WORKA_CTABLE(0))
%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
%IF HOST=EMAS %THEN K=BYTEINTEGER(BASE+4*I+J) %ELSE K=BYTEINTEGER(2*BASE+4*I+J)
%IF K<31 %OR K>125 %THEN K=32
PRINT SYMBOL(K)
%REPEAT
I=I+8
%EXITIF I>=WORKA_CONSTPTR
%REPEAT
%FINISH
PDBYTES(CAREA,0,BASE,4*WORKA_CONSTPTR)
%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)
PPROC(S,0,WORKA_PLINK(LAB))
%END
%END
%REALFN ICL REAL TO PERQ(%REAL ICL REAL)
!***********************************************************************
!* This is a function which converts a real number in ICL *
!* floating-point format into one that is in ICL PERQ *
!* floating-point format. *
!* *
!* At Exit: RESULT= +infinity if ICL Real is too large *
!* RESULT= -infinity if ICL Real is too small *
!* RESULT= PERQ Real otherwise *
!* *
!*Assumptions: (i). PERQ floating-point format conforms with the *
!* proposed IEEE draft standard, *
!* (ii). conversion is to be applied to 32-bit Reals, *
!* (iii). conversion is to be applied on ICLs, *
!* (iv). the hexadecimal representation of 1.0, *
!* on ICL PERQ's is R'3F800000' *
!***********************************************************************
%CONSTREAL MINUS INFINITY= R'FF800000'; ! ie sign=1,exp=255,fraction=0
%CONSTREAL PLUS INFINITY= R'7F800000'; ! ie sign=0, exp=255,fraction=0
%CONSTREAL PERQ ZERO= R'00000000'; ! ie sign=0,exp=0,fraction=0
%INTEGER BITS SHIFTED LEFT; ! by a SHZ instruction on ICL Fraction
%INTEGER ICL EXP; !exponent of ICL Real - 70
%INTEGER SIGN; !sign bit of ICL Real (1 if minus: 0 if plus)
%INTEGER PERQ EXP; !exponent of PERQ Real (calculated)
%INTEGER PERQ FRACTION; !fraction of PERQ Real (derived from ICL Fraction)
%REAL PERQ REAL; !--the Result
%IF 1<<HOST&IBMFPFORMAT#0 %AND 1<<TARGET&IBMFPFORMAT=0 %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(PERQ REAL))
ICL EXP=PERQ FRACTION>>24&x'7f'-70
PERQ FRACTION=PERQ FRACTION<<8
BITS SHIFTED LEFT=8
%WHILE PERQ FRACTION>0 %CYCLE
PERQ FRACTION=PERQ FRACTION<<1
BITS SHIFTED LEFT=BITS SHIFTED LEFT+1
%REPEAT
PERQ FRACTION=PERQ FRACTION<<1>>9
%FINISH
! Calculate PERQ Exponent:
PERQ EXP=((ICL EXP+5)*4 {as exponent is a hexadecimal exp})+(11-BITS SHIFTED LEFT) %C
{equals either 0,1,2, or 3}+127
{the bias of the exponent}
! -and examine its range:
%IF PERQ EXP<=0 %THENRESULT=MINUS INFINITY {ie Real Underflow}
%IF PERQ EXP>=255 %THENRESULT=PLUS INFINITY { Real Overflow}
! Construct the PERQ Real
INTEGER(ADDR(PERQ REAL))=(SIGN<<8!PERQ EXP)<<23!PERQ FRACTION
%RESULT=PERQ REAL
%FINISHELSERESULT=ICL REAL
%END; !of ICL Real to PERQ
%LONGREALFN ICL LONGREAL TO PERQ(%LONGREAL ICL2900 REAL)
!***********************************************************************
!* This is a function which converts a double precision real *
!* in ICL 2900 floating-point format into one that is *
!* in ICL PERQ floating-point format. *
!* At Exit: RESULT= equivalent PERQ real *
!* *
!*Assumptions: (i). PERQ floating-point format conforms with the *
!* proposed IEEE draft standard, *
!* (ii). conversion is to be applied to 64-bit Reals, *
!* (iii). conversion is to be applied on ICL2900s, *
!* (iv). the hexadecimal representation of 1.0, *
!* on ICL PERQ's is R'3FF0000000000000' *
!************************************************************************
%INTEGER BITS SHIFTED LEFT; ! by a SHZ instruction on ICL2900 Fraction
%INTEGER ICL2900 EXP; !exponent of ICL2900 Real - 78
%INTEGER SIGN; !sign bit of ICL2900 Real (1 if minus: 0 if plus)
%INTEGER PERQ EXP; !exponent of PERQ Real (calculated)
%LONGREAL PERQ REAL; !--the Result
%IF 1<<HOST&IBMFPFORMAT#0 %AND 1<<TARGET&IBMFPFORMAT=0 %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>>9
%FINISH
! Calculate PERQ Exponent:
PERQ EXP=(ICL2900 EXP+78 {which was subtracted by FIX above}-64 %C
{which is the ICL2900 bias}-1 %C
{ as the most significant digit is <1 and >=1/16})*4 %C
{ as the ICL2900 exponent is a hex exponent}+(11-BITS SHIFTED LEFT) %C
{bits shifted left equals 11, or 10, or 9, or 8}+1023
{bias of PERQ double precision reals}
! Construct the PERQ Real
LONGINTEGER(ADDR(PERQ REAL))=(LENGTHENI(SIGN<<11!PERQ EXP)<<52)!PERQ FRACTION
%RESULT=PERQ REAL
%FINISHELSERESULT=ICL2900 REAL
%END; ! of ICL2900 LongReal to PERQ
%ROUTINE PPJ(%INTEGER JUMP,N)
!***********************************************************************
!* PLANT A 'JUMP PERMENTRY(N)' *
!* IF JUMP=0 THEN PLANT A CALL *
!***********************************************************************
%INTEGER VAL,J,LAB,OP
%CONSTINTEGER JLKMASK=X'FFF8'
LAB=0
%IF 1<<N&JLKMASK#0 %THEN OP=JLK %ELSE OP=CALL
VAL=WORKA_PLABS(N)
%IF VAL<0 %START
VAL=PNEXTSYMBOL
WORKA_PLABS(N)=VAL
WORKA_PLINK(N)=VAL
%FINISH
%IF JUMP=JTRUE %OR JUMP=JFALSE %THEN LAB=GLABEL %AND GLABEL=LAB+1
%IF LAB>0 %THEN PJUMP(JTRUE+JFALSE-JUMP,LAB)
%IF FPPTR&7#0 %THEN PI(ALIGN)
PI1(OP,VAL)
%IF FPPTR&7#0 %THEN PI1(ASFW,4)
%IF LAB>0 %THEN PLABEL(LAB)
%END
%EXTERNALROUTINE REFORMATC(%RECORD (RD) %NAME OPND)
!***********************************************************************
!* REFORMATS A CONSTANT TO TAKE INTO ACCOUNT DIFFERENT HOST-TARGET *
!* REPRESENTATIONS *
!***********************************************************************
%IF HOST#TARGET %START
%INTEGER TYPE,PREC,I
%LONGREAL LR
I=OPND_D; ! ALL INTEGER UP TO 32 BIT
TYPE=OPND_PTYPE&7
%IF TYPE=1 %THENRETURN
PREC=OPND_PTYPE>>4&7
%IF TYPE=2 %THENSTART
%IF PREC=5 %THEN OPND_R=ICLREALTOPERQ(OPND_R) %ANDRETURN
%IF PREC=6 %START
MOVE BYTES(8,ADDR(OPND_D),0,ADDR(LR),0); ! obtaing unaligned longreal
LR=ICLLONGREALTOPERQ(LR)
MOVE BYTES(8,ADDR(LR),0,ADDR(OPND_D),0)
%FINISH
%FINISH
%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 %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
PSETOPD(JJ,CAS(DAREA))
%FINISHELSESTART
PD2(Q,JJ+2,CAS(DAREA))
! THE PLUG ONLY ALLOWS 16 BIT OFFSET
! BUT TABLE FORM ALLOWS 18 BIT OFFSET
! EXTRA PLUG NEEDED IF >65K DIAGS
%FINISH
%REPEAT
%END
%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 CIOCP(%INTEGER N)
%INTEGERFNSPEC FINDREG(%INTEGER MASK)
%INTEGERFNSPEC RLEVTOLEVEL(%INTEGER RLEV)
%ROUTINESPEC CONSTEXP(%INTEGER PTYPE,REG,VALUE)
%INTEGERFNSPEC LOAD(%RECORD (RD) %NAME OP)
%INTEGERFNSPEC STRINGLBAD(%RECORD (TAGF) %NAME TCELL)
%INTEGERFNSPEC RECORDELAD(%RECORD (TAGF) %NAME TCELL, %INTEGER SPTYPE,XTRA)
%ROUTINESPEC INDLOAD(%INTEGER REG,SIZE)
%ROUTINESPEC INDSTORE(%INTEGER REG,SIZE)
%ROUTINESPEC LOADAD(%RECORD (RD) %NAME OPND)
%ROUTINESPEC LOADPTR(%RECORD (RD) %NAME OPND,OPND2)
%ROUTINESPEC DSTORE(%INTEGER REG,SIZE,LEVEL,DISP)
%ROUTINESPEC SAVE IRS
%ROUTINESPEC BOOT OUT(%INTEGER REG)
%ROUTINESPEC DFETCH(%INTEGER REG,SIZE,LEVEL,DISP)
%ROUTINESPEC DPTRFETCH(%INTEGER REG,SIZE,LEVEL,DISP)
%ROUTINESPEC DFETCHAD(%INTEGER BA,SIZE,LEVEL,DISP)
%ROUTINESPEC FETCH LOW AD END(%INTEGER REG,B,D)
%ROUTINESPEC FETCH HIGH AD END(%INTEGER REG,B,D)
%ROUTINESPEC STORE LOW AD END(%INTEGER REG,B,D)
%ROUTINESPEC STORE HIGH AD END(%INTEGER REG,B,D)
%INTEGERFNSPEC SET LEVELREG(%INTEGER WHICH,RLEV)
%INTEGERFNSPEC FIND USE(%INTEGER MASK,USE,INF)
%INTEGERFNSPEC SET DVREG(%INTEGER WHICH,DVBD)
!
%RECORD (RD) %NAME OPND1,OPND2,OPND
%RECORD (TRIPF) %NAME CURRT,WORKT
%RECORD (LEVELF) %NAME LINF,CURRINF
%RECORD (TAGF) %NAME TCELL
%RECORD (LISTF) %NAME LCELL
!
%INTEGER C,D,WTRIPNO,JJ,COMM,XTRA,PT,BFFLAG,TRIPINF,TRIPVAL,PTYPE,TYPE,PREC,STPTR,DPTYPE,
DACC,L0,B1,B2,B3,LRES
%REAL CV1
%LONGREAL CV2
!
! TRIPDATA GIVES INFORMATION ON TRIPLE
! TOP 4 BITS HAVE TYPE
! NEXT 12 BITS HAVE FLAGS:-
! 2**16 SET IF COMMUTATIVE
! 2**17 SET DONT LOAD OPERAND2
! 2**18 SET DONT LOAD OPERAND1
! 2**19 DONT SWOP NON COMMUTABLE OPERANDS
! NEXT 8 BITS HAVE MAX CODE PLANTED IN BYTES NOT INCLUDING ANY CONSTANSTS
! OR STRINGS WHICH MAY HAVE TO GO INLINE
! BOTTOM 8 BITS HAVE A POINTER OR VALUE
! TYPE 0 TRIPLES ARE IGNORED
! TYPE 1 TRIPLES VALUE HAS INDEX INTO SWITCH "TRIPSW"
! TYPE 2 TRIPLES VALUE HAS POINTER TO ISEQS
!
%CONSTINTEGERARRAY TRIPDATA(0:199)=0,
X'1000070F'{RTHD ROUTINE/BKK HDR},
X'10001043'{RDSPLY MAKE DISPLAY},
X'10000410'{RDAREA INITIALISE DIAGS AREA},
X'10000511'{RDPTR RESET DIAGS PTR},
X'10000312'{RTBAD ERROR XIT FOR FN-MAP},
X'10000113'{RTXIT "%RETURN"},
X'10000314'{XSTOP "%STOP"},
0(2),
X'2000040A'{10 LOGICAL NOT},
X'2000040B'{11 LOGICAL NEGATE},
X'2000040C'{12 FLOAT},
X'2000040D'{13 MODULUS},
X'2000080E'{14 SHORTEN},
X'2000040F'{15 LENGTHEN},
X'20000610'{16 JAM SHORTEN},
X'10000000'{17 ERROR},
0{18 NULL TRIPLE},
X'20000413'{19 PRELOAD},
X'10000001'{20 UNUSED},
X'10000303'{21 STORE STACKPOINTER},
X'10000602'{22 RESTORE STACK POINTER},
X'10000505'{23 ADVANCE STACK POINTER},
X'10000D04'{24 DECLARE ARRAY},
X'10000301'{25 UPDATE LINE NO},
X'10000906'{26 CHECK ZERO FOR STEP},
X'10000307'{27 FOR PREAMBLE},
X'10000208'{28 FOR POSTAMBLE},
X'1000010E'{29 FOR SECOND PREAMBLE},
X'10000218'{30 PRECALL},
X'10000519'{31 ROUTINE CALL},
X'1000021A'{32 RECOVER FN RESULT},
X'1000021B'{33 RECOVER MAP RESULT},
X'00000000'{34 NOT CURRENTLY USED},
X'1000081D'{35 GETAD GET 32BIT ADDREESS},
X'10000424'{36 RTOI1 INT FN},
X'10000C25'{37 RTOI2 INTPT FN},
X'10000B26'{38 STOI1 TOSTRING FN},
X'1000093D'{39 MNITR FOR %MONITOR},
X'00000000'{40 PPROF PRINT PROFILE IGNORED},
X'1000053F'{41 RTFP TURN RTNAME TO FORMAL},
X'00000000'{42 ON EVENT1 NO CODE AS YET},
X'00000000'{43 ON EVENT2 NO CODE AS YET},
X'10000846'{44 DVSTART FILL IN ELSIZE&ND},
X'10001047'{45 DVEND WORK OUT TOTSIZE ETC},
X'20000413'{46 FOREND EXACTLY AS PRELD FOR PNX},
0(3),
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'20080527'{147 ARR INDEX},
X'20050428'{148 INDEXED FETCH},
X'200E0629'{149 LOCAL ASSIGN},
X'10000C09'{150 VALIDATE FOR},
X'10000B15'{151 PRE CONCAT},
X'10000A16'{152 COCNCATENEATION},
X'10000C17'{153 IOCP CALL},
X'10000C1C'{154 PARAMETER ASSIGNMENT 1 NORMAL VALUES},
X'1000041F'{155 PARAM ASSNG 2 NORMAL PTRS},
X'10000220'{156 PARAM ASSGN 3 ARRAYS},
X'10000220'{157 ASSGN FORMAL RT-CODE AS 156},
X'10000220'{158 PASS5 TYPE GENERAL NAME},
X'10000445'{159 PASS6 RESULT AREA FOR STR&REC FNS},
X'1000030A'{160 BACK JUMP},
X'1000030B'{161 FORWARD JUMP},
X'1000000C'{162 REMOVE LAB},
X'1000000D'{163 ENTER LABEL},
X'1000FF21'{164 DECLARE SWITCH},
X'10000022'{165 SET SWITCH LABEL TO CA},
X'10000523'{166 GOTO SWITCH LABEL},
X'10000D27'{167 STRING ASS1 GENERAL},
X'10001128'{168 STRING ASS 2 L KNOWN},
X'10000D29'{169 STRING JAM TRANSFER},
X'10000C2A'{170 ARRAY HEAD ASSIGNMENT},
X'10000C2B'{171 PTR ASSIGNMENT},
X'1000052C'{172 MAP RESULT ASSIGNMENT},
X'1000052D'{173 FN RESULT ASSIGNMENT},
X'10000C2E'{174 STRING COMPARISON},
X'10000C2E'{175 STRING DSIDED COMPARISON},
X'10000C2F'{176 PRE RESOLUTION 1},
X'10001230'{177 PRE RESOLUTION 2},
X'10000B31'{178 RESOLUTION PROPER},
X'1000233C'{179 RESOLUTION FINISH ASSN FRAGMNT},
X'00000000'{180 SIGEV SIGNAL EVENT NOT IMPLEMENTED},
X'10000A3E'{181 RECASS WHOLE RECORD ASSIGNMENT},
X'10000A40'{182 ARRAY ADDR INC},
X'10000A41'{183 AHADJ FOR ARRAY MAPPING},
X'10000A42'{184 CREATE TYPE GENERAL PARAMETER},
X'1000081E'{185 GET POINTER FOR PASSING BY NAME},
X'10000444'{186 INDEX STRING FOR CHARNO},
X'2002042A'{187 ZCOMP COMPARE W ZERO},
X'2002022B'{188 CONSTANT LOGICAL SHIFT},
X'2002022B'{189 COSNTANT ARITHMETIC SHIFT},
X'10001048'{190 DV BPAIR ENTER LB,UB &RANGE IN CORRECT FORM},
X'10000449'{191 REG TO STORE OPERATION},
0(*)
%CONSTHALFINTEGERARRAY FCOMP(0:95)=0(2),
ILT(2),IGT(2),INE(2),IEQ(2),
ILE(2),IGE(2),0(2),
0(2),
IGT(2),ILT(2),INE(2),IEQ(2),
IGE(2),ILE(2),0(2),
0(2),
IJGT(2),IJLT(2),IJNE(2),IJEQ(2),
IJGE(2),IJLE(2),0(2),
0(2),
IJLT(2),IJGT(2),IJNE(2),IJEQ(2),
IJLE(2),IJGE(2),0(2),
0(2),
RDLT(2),RDGT(2),RDNE(2),RDEQ(2),
RDLE(2),RDGE(2),0(2),
0(2),
RDGT(2),RDLT(2),RDNE(2),RDEQ(2),
RDGE(2),RDLE(2),0(2)
!
! OPCODE FOR ESTACK TO STORE VARIANT OPERATIONS
!
%CONSTBYTEINTEGERARRAY OOPC(128:137)=OAADD,OASUB,OAXOR,OAOR,OAMULT,
OADIV,HALT,OAAND,OASRL,OASLL
!
! 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*(2*NISEQS+10)-1)={FIRST 32 BIT INTEGER FORMS} %C
2,ILNOT,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},
9,0,8,0 {13 32 BIT MODULUS},
10,0,0,0 {14 SHORTEN 32 BIT TO 16 BIT},
1,0,0,109 {15 LENGTHEN 32 BIT TO 64 BIT},
21,0,0,0 {16 SHORTEN 32 BIT FOR JAM},
1,0,0,109 {17 COMPILER ERROR},
7,0,0,0 {18 NOOP},
7,0,0,0 {19 PRELOAD},
2,IADD,0,0 {20 32 BIT ADDITION},
2,ISUB,0,0 {21 32 BIT SUBTRACTION},
2,IXOR,0,0 {22 32 BIT NONEQUIVALENCE},
2,ILOR,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,ILAND,0,0 {27 32 BIT AND},
2,ISRLT,0,0 {28 32 BIT RIGTH SHIFT},
2,ISLLT,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,RDNEG>>8,RDNEG&255,0 {11 REAL LOGICAL NEGATE},
1,0,0,109 {12 FLOAT REAL COMPILER ERROR},
11,0,8,0 {13 REAL MODULUS},
5,RDCNVS>>8,RDCNVS&255,0 {14 SHORTEN REAL},
5,RDCNVS>>8,RDCNVS&255,0 {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,RDADD>>8,RDADD&255,0 {20 REAL ADDITION},
4,RDSUB>>8,RDSUB&255,0 {21 REAL SUBTRACTION},
7,0,0,0 {22 REAL NONEQUIVALENCE},
7,0,0,0 {23 REAL LOGICAL OR},
4,RDMULT>>8,RDMULT&255,0 {24 REAL MULTIPLY},
7,0,0,0 {25 REAL INTEGER DIVIDE},
4,RDDIV>>8,RDDIV&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:73)
!
CV1=0; CV2=0
CURRINF==WORKA_LEVELINF(CURRLEVEL)
FLAG AND FOLD(TRIPLES) %IF PARM_OPT#0; ! ALREADY DONE FOR OPT=0
%IF PARM_DCOMP#0 %THEN PRINT TRIPS(TRIPLES)
STPTR=TRIPLES(0)_FLINK
%WHILE STPTR>0 %CYCLE
CURRT==TRIPLES(STPTR)
WTRIPNO=STPTR
STPTR=CURRT_FLINK
COMM=1
OPND1==CURRT_OPND1
OPND2==CURRT_OPND2
XTRA=CURRT_X1
JJ=CURRT_OPERN
TRIPINF=TRIPDATA(JJ)
C=TRIPINF>>28; ! TRIPLE TYPE
TRIPVAL=TRIPINF&255
%IF C=0 %THENCONTINUE
%IF C=1 %THEN ->TRIPSW(TRIPVAL)
LRES=0
!
! CARE IS NEEDED IN DETECTING WHEN OPERANDS ARE REVERSED IN STACK
!
%IF JJ>=128 %AND CURRT_FLAGS&(LOADOP1+LOADOP2)=0 %AND 1<<OPND1_FLAG&BTREFMASK#0 %AND %C
1<<OPND2_FLAG&BTREFMASK#0 %START
L0=CURRT_BLINK
L0=TRIPLES(L0)_BLINK %WHILE L0#0 %AND L0#OPND1_D %AND L0#OPND2_D
%IF L0=OPND1_D %AND OPND1_PTYPE&7#2 %THEN COMM=2
%FINISH
%IF TRIPINF&X'40000'=0 %START; ! OP1 NOT LOADED
LRES=LOAD(OPND1)<<1
%IF JJ>=128 %AND CURRT_FLAGS&6=2 %AND OPND1_PTYPE&7#2 %AND OPND2_PTYPE&7#2 %START
! OPERANDS REVERSED IN ESTACK
COMM=2
%FINISH
%FINISH
%IF TRIPINF&X'F0000'=0 %AND COMM=2 %THEN EXCHANGE(OPND2,OPND1) %AND COMM=1
! I-RS THE WRONG WAY ROUND
! FOR NON COMMUTABLE OPS
%UNLESS JJ<128 %OR TRIPINF&X'20000'#0 %THEN LRES=LOAD(OPND2)
PTYPE=OPND1_PTYPE&255; TYPE=PTYPE&7
%IF TYPE=2 %THEN C=4*(TRIPVAL+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(*):
PI(NULL); ! USEFUL IN DEBUGGING TO HAVE
! ERROR POSITION PINPOINTED
->STRES
SW(2): ! PLANT ONE BYTE
PI(B1)
OPND1_FLAG=9; ! PREVENT RELOAD IF THIS IS LAST
->STRES
SW(6): ! PLANT 2 BYTES & SET PTYPE
OPND1_PTYPE=B3
SW(3): ! PLANT 2 BYTES
PI1(B1,B2)
OPND1_FLAG=9; ! PREVENT RELOAD IF THIS IS LAST
->STRES
SW(4): ! PLANT REAL OPERATION
D=B1<<8!B2
%IF CURRT_OPTYPE=X'52' %THEN D=D+8; ! USE SHORT OPCODE FORM
PI2(D,(OPND1_XB-FR0)&3,(OPND2_XB-FR0)&3)
%UNLESS OPND1_XB=OPND2_XB %THEN REGS(OPND2_XB)_CL=0
OPND1_FLAG=9; ! PREVENT RELOAD IF THIS IS LAST
->STRES
SW(5): ! REAL UNARY OPERATION
D=B1<<8!B2
%IF CURRT_OPTYPE=X'52' %THEN D=D+8
C=OPND1_XB-FR0
PI2(D,C,C)
OPND1_FLAG=9
->STRES
SW(7): ! NULL OPERATION
->STRES
SUSE:
->STRES
SW(9): ! INTEGER MODULUS
P2I(DUPL,CI0)
PJUMP(IJGE,GLABEL)
PI(INEG)
PLABEL(GLABEL)
GLABEL=GLABEL+1
->SUSE
SW(10): ! SHORTEN INTEGER TO BYTE
%IF PARM_OPT#0 %START
%UNLESS CURRT_CNT=1 %AND TRIPLES(CURRT_PUSE)_OPERN=SHRTN %START
PI(DUPL)
%IF CURRT_OPTYPE>X'31' %THEN D=X'FFFF' %ELSE D=255
PLOADCONST(D)
PI(ULE)
PPJ(JFALSE,9)
%FINISH
%FINISH
OPND1_PTYPE=OPND1_PTYPE-X'10'
->SUSE
SW(11): ! REAL MODULUS (DIFFICULT)
D=FINDREG(FRN)
REGS(D)_USE=0; ! FORGET PREVIOUS USE
PLOADCONST(0)
%IF PTYPE>>4&7=6 %THENSTART
B1=RDFLOAT; B2=RDGE; B3=RDNEG
%FINISHELSESTART
B1=RSFLOAT; B2=RSGE; B3=RSNEG
%FINISH
PI1(B1,D-FR0)
PI2(B2,OPND1_XB-FR0,D-FR0)
PJUMP(JTRUE,GLABEL)
PI2(B3,OPND1_XB-FR0,OPND1_XB-FR0)
PLABEL(GLABEL)
GLABEL=GLABEL+1
->SUSE
SW(12): ! FLOAT
D=FINDREG(FRN)
PI1(RDFLOAT,D-FR0)
OPND1_PTYPE=X'62'
OPND1_XB=D
REGS(D)_CL=1
REGS(D)_AT=WTRIPNO
REGS(D)_LINK=WTRIPNO
->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 %THENSTART
%IF OPND2_FLAG<=1 %AND 2<=OPND2_D<=255 %THEN %C
CONSTEXP(OPND1_PTYPE&255,OPND1_XB,OPND2_D) %ELSE ->PCALL
->SUSE
%FINISH
! REAL**REAL BY SUBROUTINE
REXP; ->SUSE
SW(17): ! EXP IN INTEGER CONTEXT
%IF OPND2_FLAG<=1 %AND 2<=OPND2_D<=63 %THEN %C
CONSTEXP(OPND1_PTYPE&255,OPND1_XB,OPND2_D) %AND ->STRES
PCALL: ! CALL SUBROUTINE AS DEFINED
! IN CODE TABLE
LRES=LOAD(OPND2)
%IF CURRT_OPTYPE&7=1 %THENSTART; ! INTEGERS
%IF CURRT_FLAGS&LOADOP1#0 %AND LRES=0 %THEN PI(EXCH)
PPJ(0,20); ! CALL ROUTINE
%FINISHELSESTART
STARSTAR; ! PLANT COMPLEX IN LINE ROUTINE
%FINISH
->SUSE
SW(14): ! DSIDED COMPARISONS
! COPY MIDDLE OPERAND(SIZE IN TABLE)
%IF TYPE=1 %THENSTART
GET WSP(D,2)
DSTORE(ESTK,4,CURRINF_RBASE,D)
OPND2_FLAG=7; OPND2_D=CURRINF_RBASE<<16!D
CURRT_FLAGS=CURRT_FLAGS!NOTINREG; ! STORE COPY TO BE USED
WORKT==TRIPLES(CURRT_PUSE)
WORKT_FLAGS=WORKT_FLAGS!LOADOP1; ! ENSURE ESTACK IS RIGHT WAY ROUND
%FINISH; ! PDS THINKS REALS CAN BE LEFT IN REG
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
%IF CURRT_OPTYPE=X'51' %START
WORKT==TRIPLES(CURRT_FLINK); ! ON TO FOLLOWING TRIPLE
%IF WORKT_OPERN=FJUMP %OR WORKT_OPERN=BJUMP %THEN %C
WORKT_X1=WORKT_X1!X'40' %AND CURRT_OPND1=OPND2 %AND ->STRES
%FINISH
%IF TYPE=1 %THEN PI(C) %ELSESTART
%IF CURRT_OPTYPE=X'52' %THEN C=C+8; ! USE 16BIT FORMS
PI2(C,OPND2_XB-FR0,OPND1_XB-FR0); ! NB BEFORE CHANGING
! THE PNX COMPARISONS ARE BETWEEND
! ETOS & ETOS-1 IE OPND2&OPND1
! SINCE THE REAL FORMS ARE DERIVED
! FROM THE INTEGER FORMS THIS MUST BE BACKWARDS.
REGS(OPND1_XB)_CL=0
REGS(OPND2_XB)_LINK=WTRIPNO; ! WILL BE "RESULT"
%FINISH
CURRT_OPND1=OPND2; ! OPND2 IS RESULT
->STRES; ! 2ND OPERAND MAY BE NEEDED IN
SW(15): ! SPECIAL MH FOR ARRAY ACCESS
C=OPND2_D>>24; ! CURRENT DIMENSION
D=OPND2_D>>16&31; ! TOTAL NO OF DIMENSIONS
VMY
->STRES
SW(18): ! BASE ADJUST ARRAY INDEX
DPTYPE=XTRA>>16
%UNLESS PARM_COMPILER#0 %OR DPTYPE&X'300'=X'200' %START
D=OPND2_D&X'FFFF'
%IF D>0 %START; ! DV KNOWN
C=CTABLE(D)
PLOADCONST(C)
%FINISHELSESTART
C=FIND USE(BRN,15,OPND2_XTRA)
%IF C>0 %START
PI1(LRO0-BR0+C,0); ! BASE OFFSET FROM DV
%FINISHELSESTART
%IF OPND2_XTRA>>16=0 %THEN PFIXI(LGPO,2,OPND2_XTRA&X'FFFF') %ELSE %C
DPTRFETCH(ESTK,4,OPND2_XTRA>>16,OPND2_XTRA&X'FFFF'+4)
%FINISH
%FINISH
PI(IADD)
%FINISH
->STRES
SW(19): ! ARRAY INDEX
DACC=XTRA>>20
%IF DACC>0 %START; ! NORMAL CASE EL SIZE KNOWN
%IF COMM=2 %AND DACC>2 %THEN PI(EXCH)
%IF DACC<=2 %THEN PI(IADD) %ELSEIF DACC=4 %THEN PI(INDINT) %ELSEIF %C
DACC<=510 %THEN PI1(INDEX,(DACC+1)>>1) %ELSE %C
PLOADCONST((DACC+1)>>1) %AND P2I(IMULT,IADD)
%FINISHELSESTART; ! RARE CASE GO TO DV FOR SIZE
! ONLY FOR ACCESS OF STRING&RECORD
! ARRAYNAMES
%IF COMM=2 %THEN PI(EXCH)
D=SET DVREG(-1,XTRA); ! BR TO START OF DV
PI1(LROA0-BR0+D,6)
P4I(LHI,IMULT,CVIA,IADD)
%FINISH
->STRES
SW(20): ! INDEXED FETCH
%IF TYPE#2 %THEN D=ESTK %ELSE D=FINDREG(FRN)
INDLOAD(D,BYTES(PTYPE>>4&7))
OPND1_PTYPE=OPND1_PTYPE&255
OPND1_FLAG=9
OPND1_XB=D
%IF D#ESTK %THEN REGS(D)_CL=1 %AND REGS(D)_AT=WTRIPNO %AND REGS(D)_LINK=WTRIPNO
->STRES
SW(16): ! ASSIGN(=)
! ASSIGN(<-)
PT=XTRA&255; ! ORIGINAL PT OF LHS HERE
%IF PT=0 %THEN PT=CURRT_OPTYPE
%IF OPND1_FLAG=2 %START; ! OPERAND A NAME
LRES=LOAD(OPND2)
TCELL==ASLIST(TAGS(OPND1_D))
%IF TCELL_PTYPE&X'3FFF'=X'33' %THEN D=RECORDELAD(TCELL,PT,OPND1_XTRA) %ELSE %C
D=TCELL_SLINK
DSTORE(OPND2_XB,BYTES(PT>>4),TCELL_UIOJ>>4&15,D)
%FINISHELSESTART; ! OPERAND A POINTER
%IF OPND1_FLAG=INDNAME %START; ! POINTER NOT LOADED
LRES=LOAD(OPND2)
LOADPTR(OPND1,OPND1)
%FINISHELSESTART
LOADPTR(OPND1,OPND1)
LRES=LOAD(OPND2)
%IF TYPE#2 %AND (LRES>0 %OR (CURRT_FLAGS&LOADOP1=0 %AND COMM=1)) %THEN PI(EXCH)
%FINISH
INDSTORE(OPND2_XB,BYTES(PT>>4))
%FINISH
%IF OPND2_XB<=FR3 %THEN REGS(OPND2_XB)_CL=0
->STRES
SW(23): ! LOCAL ASSIGNMENT
D=BYTES(PTYPE>>4&15)
LRES=LOAD(OPND2)
DSTORE(OPND2_XB,D,OPND1_D>>16,OPND1_D&X'FFFF')
OPND1_FLAG=7; OPND1_XB=OPND2_XB; ! IN CASE USED AGAIN
%IF CURRT_DPTH>0 %AND CURRT_CNT=0 %THEN ERASE((D+3)>>2)
%IF CURRT_PUSE#CURRT_FLINK %THEN CURRT_FLAGS=CURRT_FLAGS!NOTINREG
! FORCE RELOAD FROM STORE IN ALL BUT
! BUT ONE SIMPLE CASE
%FOR D=BR0,1,FR3 %CYCLE
%IF REGS(D)_INF1=OPND1_D %THEN FORGET(D)
%REPEAT
->STRES
SW(24): ! COMPARE WITH ZERO (OPND2=0)
WORKT==TRIPLES(CURRT_FLINK); ! NEXT OR JUMP TRIPLE
D=WORKT_X1; ! IBM TYPE JUMP MASK
%IF TYPE=1 %START; ! INTEGERS
%IF D=8 %OR D=X'87' %THEN WORKT_X1=D!!X'8F'
%FINISHELSESTART
C=OPND1_XB
%IF CURRT_OPTYPE=X'52' %THEN B1=RSTEST %ELSE B1=RDTEST
PI1(B1,C-FR0)
REGS(C)_CL=0
%IF XTRA&X'F'#7 %THEN WORKT_X1=D!!X'8F'
%FINISH
->STRES
SW(25): ! SHIFT BY CONSTANT
D=OPND2_D
%IF CURRT_OPERN=CASHIFT %AND D=-1 %THEN PI(CVIA) %ELSEIF %C
D>0 %OR CURRT_OPERN=CLSHIFT %THEN PI1(ISHL,D) %ELSE PI1(ISRA,-D)
%CONTINUE
TRIPSW(73): ! OPERATE AND ASSIGN OPERATION
! PRODUCED BY OPT PASS ONLY
LRES=LOAD(OPND2)
LOADAD(OPND1)
PI(OOPC(XTRA))
->STRES
TRIPSW(1): ! SET LINE NO
! RECODING A BIT MESSY ON OPT
! HENCE FUNNY CONDITION ON NEXT LINE
PLINESTART(OPND1_D>>16) %IF PARM_DCOMP=0 %OR WTRIPNO=1
%IF PARM_LINE#0 %START
PLOADCONST(OPND1_D>>16)
DSTORE(ESTK,2,CURRINF_RBASE,OPND1_D&X'FFFF')
%FINISH
%CONTINUE
TRIPSW(2): ! RESET STACK PTR TO STORED VALUE
DFETCH(ESTK,4,CURRINF_RBASE,OPND1_D)
PI(SFA); PI(ISUB)
PI(ASFT)
%CONTINUE
TRIPSW(3): ! SAVE STACK POINTER
! OPND1 IS TEMPORARY(16 BITS) FOR SAVE
PI(SFA)
DSTORE(ESTK,4,CURRINF_RBASE,OPND1_D)
%CONTINUE
TRIPSW(70): ! START OF DOPE VECTOR
! OPND1_D=ND<<16!ELSIZE
! OPND1_XTRA=PTYPE<<16!DVDISP
D=OPND1_XTRA&X'FFFF'
PLOADCONST(OPND1_D)
DSTORE(ESTK,4,CURRINF_RBASE,D-4)
%CONTINUE
TRIPSW(71): ! END OF DOPE VECTOR
! OPND1_D=DVF<<16!ELSIZE
! OPND1_XTRA=PTYPE
! XTRA=ND<<16!DVDISP
D=OPND1_D&X'FFFF'; ! ELSIZE
%IF D=1 %START; ! BYTES
P2I(CI1,IADD)
PI1(ISHL,-1)
%FINISHELSEIF D>2 %START
PLOADCONST(D>>1)
PI(IMULT)
%FINISH
DSTORE(ESTK,4,CURRINF_RBASE,XTRA&X'FFFF'-8)
! NOW WORK OUT THE BASE OFFSET USING
! MASK OF NONZERO LBS PASSED IN DVF
D=XTRA&X'FFFF'; ! DVDISP
C=OPND1_D>>16; ! THE MASK
%IF C=0 %THEN PLOADCONST(0) %ELSESTART
B1=0
%FOR JJ=1,1,XTRA>>16 %CYCLE
%IF C&(1<<JJ)#0 %START; ! THIS LB NONZERO
DFETCH(ESTK,4,CURRINF_RBASE,D-12*JJ-4); ! LB
%IF JJ>1 %THENSTART
DFETCH(ESTK,4,CURRINF_RBASE,D-12*JJ+4)
PI(IMULT)
%FINISH
%IF B1>0 %THEN PI(IADD)
B1=B1+1; ! COUNT PRODUCTS
%FINISH
%REPEAT
PI(INEG)
%FINISH
DSTORE(ESTK,4,CURRINF_RBASE,D)
%CONTINUE
TRIPSW(72): ! DV BOUND PAIR
! OPND1&2 ARE LB & UB RESPECTIVLY
! XTRA=CURRD<<24!ND<<16!DVDISP
D=XTRA&X'FFFF'-12*(XTRA>>24); ! TRIPLE POSN
%IF OPND1_FLAG=SCONST %START; ! LB A CONST
PLOADCONST(OPND1_D)
DSTORE(ESTK,4,CURRINF_RBASE,D-4)
LRES=LOAD(OPND2)
%IF LRES=0 %THEN PI(DISCARD)
DSTORE(ESTK,4,CURRINF_RBASE,D)
%IF OPND1_D#1 %THEN PLOADCONST(OPND1_D-1) %AND PI(ISUB)
%FINISHELSESTART
LRES=LOAD(OPND1)<<1!LOAD(OPND2)
%IF LRES=B'10' %THEN PI(EXCH)
DSTORE(ESTK,4,CURRINF_RBASE,D)
PI(EXCH)
DSTORE(ESTK,4,CURRINF_RBASE,D-4)
P3I(ISUB,CI1,IADD)
%FINISH
C=XTRA>>24&255; ! CURRENT DIMENSION
%IF C>1 %START; ! MULTPLY UP BY LOWER RNAGES
DFETCH(ESTK,4,CURRINF_RBASE,D+4)
PI(IMULT)
%FINISH
DSTORE(ESTK,4,CURRINF_RBASE,D-8)
%CONTINUE
TRIPSW(4): ! DECLARE ARRAY
! OPND1_D=CDV<<31!C<<24!D<<16!DVDISP
! OPND1_XTRA HAS DICT ENTRY NO
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(NO,4,CURRINF_RBASE,OPND1_D&X'FFFF')
%FINISHELSESTART; ! DV IN SHAREABLE SYMBOL TABLES
PFIXI(LGA,10,OPND1_D&X'FFFF')
%FINISH
DSTORE(ESTK,4,CURRINF_RBASE,TCELL_SLINK+4)
%IF TRIPLES(STPTR)_OPERN=ASPTR %START; ! IF ARRAY NOT FORMAT
%IF OPND1_D<0 %START; ! ARRAY SIZE KNOWN
C=CTABLE((OPND1_D&X'FFFF')>>2+2)
C=(C+3)&(-4); ! TO 64 BIT BNDRY
PI1(ASFW,-64000) %AND C=C-32000 %WHILE C>32000
PI1(ASFW,-2*C); ! C IN 16BIT WORDS
%FINISHELSESTART; ! DYNAMIC NEEDS LOOP !
DFETCH(ESTK,4,CURRINF_RBASE,OPND1_D&X'FFFF'-8)
P2I(CI3,IADD)
PLOADCONST(-4)
P3I(ILAND,INEG,ASFT)
%FINISH
%FINISH
PI(SFA); ! STACK FRONT ADDRESS=BASE ADDRESS
%IF TCELL_PTYPE&255=X'31' %THEN PI(CVBA)
DSTORE(ESTK,4,CURRINF_RBASE,TCELL_SLINK)
%CONTINUE
TRIPSW(5): ! CLAIM ARRAY SPACE
! OPND1_D=CDV<<31!SNDISP!DVDISP
! NOT NEEDED ON PNX AS THIS MUST
! BE DONE DURING DECLN(SEE ABOVE)
%CONTINUE
TRIPSW(6): ! CHECK FOR ZERO FOR STEP
LRES=LOAD(OPND1); ! STEP TO ESTACK
PPJ(JFALSE,11); ! USING ZERO=FALSE EQUIVALENCE
%CONTINUE
TRIPSW(7): ! FOR PREAMBLE
LRES=LOAD(OPND1); ! FORCE INITIAL TO ESTACK
%CONTINUE
TRIPSW(8): ! FOR POSTAMBLE
%CONTINUE
TRIPSW(9): ! VALIDATE FOR
LRES=LOAD(OPND1)
LRES=LOAD(OPND2)
PI(IREM)
PPJ(JTRUE,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
PJUMP(JCODE(D),OPND1_D&X'FFFF')
%CONTINUE
TRIPSW(11): ! FORWARD JUMP _X1 HAS TF&MASK
! OPND1_XTRA HAS LABEL CELL<<16!JUMP CELL
LCELL==ASLIST(OPND1_XTRA>>16)
C=JCODE(XTRA)
PJUMP(C,OPND1_D&X'FFFF')
D=OPND1_D>>24; ! ENTER JUMP FLAGS
%IF D&2#0 %START; ! ENVIRONMENT MANIPULATION
%IF D&128#0 %START; ! FIRST JUMP TO THIS LAB
C=0; GET ENV(C)
%FINISHELSESTART
C=LCELL_S2>>16
REDUCE ENV(C); ! LATER USE MUST MERGE
%FINISH
LCELL_S2=C<<16!(LCELL_S2&X'FFFF')
%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
PDISCARDLABEL(OPND1_D)
%END
%CONTINUE
TRIPSW(13): ! INSERT LABEL
! OPND1_XTRA HAS LABEL CELL
LCELL==ASLIST(OPND1_XTRA)
D=LCELL_S2&X'FFFF'; ! JUMP LIST REDUNDANT ON PNX
%WHILE D#0 %CYCLE; ! FILL FORWARD REFS
POP(D,B1,B2,B3); ! B2=1 IF SHORT JUMP PLANTED
%REPEAT
PLABEL(OPND1_D&X'FFFF')
D=OPND1_D>>24; ! ENVIRONMENT MANIPULATION FLAGS
%IF D&2=0 %THEN FORGET(-1) %ELSESTART
C=LCELL_S2>>16
%IF D&4=0 %THEN REDUCE ENV(C); ! MERGE WITH CURRENT
RESTORE(C)
%FINISH
LCELL_S2=0; ! NO JUMPLIST&NO ENVIRONMENT
%CONTINUE
TRIPSW(14): ! FOR 2ND PREAMBLE
! MAY BE UNNECESSARY
PI(DUPL)
OPND1_XB=ESTK; OPND1_FLAG=9
%CONTINUE
TRIPSW(15): ! RT HEADING OPND1_D=RTNAME
! OPND1_XTRA=AXNAME #0 IF AN ENTRY
%BEGIN
%INTEGER H
H=0
CURRINF_ENTRYAD=GLABEL; ! FOR RETURN=JUMP TO END
GLABEL=GLABEL+1
%IF OPND1_D>=0 %THENSTART
C=0
TCELL==ASLIST(TAGS(OPND1_D))
H=TCELL_SNDISP
%FINISHELSE C=1
%IF H=0 %THEN H=-1
%IF OPND1_XTRA#0 %THEN PPROC(STRING(OPND1_XTRA),C<<31!1,H) %ELSEIF OPND1_D>=0 %THEN %C
PPROC(STRING(ADDR(WORKA_LETT(WORKA_WORD(OPND1_D)))),0,H)
%IF OPND1_D>=0 %THEN TCELL_SNDISP=H
%END
%CONTINUE
TRIPSW(67): ! RDISPLY CREATE DISPLAY
FORGET(-1)
D=CURRINF_RBASE
%IF D>1 %START; ! SOME DISPLAY TO COPY
PLOADCONST(2*D)
PI(ISUB)
! PI1(LROA0,-4*D)
%IF D=2 %THEN PI1(RDLDID,0)
PI1(LAS,0)
PI1(ISL,-4*D-4)
PLOADCONST(2*D)
PI(ISUB)
%IF D=2 %THEN PI1(RDASSD,0) %ELSE PLOADCONST(2*D) %AND PI(MVWD)
%FINISHELSESTART; ! SET GLAPTR IN EXTERNALS
PFIXI(LGA,2,0)
PI1(ISL,-4*D)
PI1(LAS,0); ! CURRENT LNB
PI1(ISL,-4*D-4)
%FINISH
%CONTINUE
TRIPSW(16): ! RDAREA - INITIALISE DAIGS AREA
! OPND1_D=N FOR DIAGS AREA
PFIXI(LGI,2,32); ! PICK UP M'IDIA'
DSTORE(ESTK,4,CURRINF_RBASE,OPND1_D)
%CONTINUE
TRIPSW(17): ! RDPTR SET DAIGS POINTER
! OPND1_D=LEVEL NOT CURRINF ALWAYS
LINF==WORKA_LEVELINF(OPND1_D)
D=PMARKER
PLOADCONST(X'7F7F'); ! 7F7F ARBITARY & WILL BE OVERWRITTEN
! BUT <16BITS OPTIMISED !
PUSH(LINF_RAL,1,D,0); ! TO OVERWRITE LATER
DSTORE(ESTK,2,LINF_RBASE,LINF_DIAGINF)
%CONTINUE
TRIPSW(18): ! RTBAD FN-MAP ERROR EXIT
WORKT==TRIPLES(CURRT_BLINK); ! PREVIOUS TRIPLE
%CONTINUEIF WORKT_OPERN=RTXIT %OR WORKT_OPERN=XSTOP %OR (WORKT_OPERN=BJUMP %AND %C
WORKT_X1&15=15)
%IF PARM_OPT#0 %THEN PLOADCONST(21) %AND PPJ(JUMP,2)
%CONTINUE
TRIPSW(19): ! RTXIT - "%RETURN"
%IF OPND1_D=0 %START; ! JUMP TO END FOR RETURNS PROTEM
! TILL REGISTER RESTORING SOLVED
PJUMP(JUMP,CURRINF_ENTRYAD)
%FINISHELSESTART
PLABEL(CURRINF_ENTRYAD); ! ENTRAD HOLDS LAB FOR RETURN
PI(RETURN)
PPROCEND(CURRINF_SNMAX-CURRINF_DISPLAY)
FORGET(-1)
%FINISH
%CONTINUE
TRIPSW(20): ! XSTOP - "%STOP"
CALL STOP
%IF OPND1_D#0 %THEN PPROCEND(CURRINF_SNMAX-CURRINF_DISPLAY)
%CONTINUE
TRIPSW(61): ! %MONITOR
P2I(CI0,CI0)
PPJ(0,2)
FORGET(-1)
%CONTINUE
!***********************************************************************
!* SECTION FOR STRING CONCATENATION AND ASSIGNMENT *
!***********************************************************************
TRIPSW(21): ! PRECONCAT
! OPND1 IS WORK AREA
! OPND2 HAS FIRST STRING
LRES=LOAD(OPND2); ! 32 BIT AD OF STRING2
P3I(DUPL,LHI,MASKC)
LRES=LOAD(OPND1)
P3I(EXCH,CI2,IADD)
P2I(CVIA,MVWD)
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)
D=FPPTR
%IF D&7#0 %THEN PI(ALIGN) %AND FPPTR=FPPTR+4
PI(IPUSH)
LRES=LOAD(OPND1)
PI(IPUSH)
PPJ(0,24)
%IF D=FPPTR %THEN PI1(ASFW,8) %ELSE PI1(ASFW,12) %AND FPPTR=D
OPND1_FLAG=7; ! RESULT IS LOCAL
%CONTINUE
TRIPSW(39): ! GENERAL STRING ASSIGN
LRES=LOAD(OPND1); ! PTR (2 WORDS) TO LHS
%IF OPND2_FLAG=LCONST %THENSTART; ! CONST STRING ASSN
%IF OPND2_XTRA=0 %START; ! CONST IS NULL
P4I(DISCARD,CI0,EXCH,ASSH)
%FINISHELSESTART
%IF PARM_OPT#0 %THEN PI(EXCH) %ELSE PI(DISCARD)
LRES=LOAD(OPND2)
PI(EXCH)
PLOADCONST((OPND2_XTRA+2)>>1)
PI(MVWD)
%IF PARM_OPT#0 %START
PLOADCONST((OPND2_XTRA+2)>>1)
PI(ILE)
PPJ(JFALSE,9)
%FINISH
%FINISH
%FINISHELSESTART
D=FINDREG(BRN)
REGS(D)_USE=0
%IF CURRT_FLAGS&LOADOP2=0 %START; ! RHS(OP 2) FN OR MAP
P3I(CVBA,SR0-BR0+D,DISCARD)
REGS(D)_CL=1
%FINISH
%IF PARM_OPT#0 %THEN PI(EXCH) %ELSE PI(DISCARD)
! MAX LEN TO BTM FOR CHK OR DISCARDED
PI(CVBA)
%IF CURRT_FLAGS&LOADOP2=0 %THEN PI(LR0-BR0+D) %ELSESTART
LRES=LOAD(OPND2)
PI(CVBA)
PI(SR0-BR0+D); ! SOURCE BYTE ADDRE TO REG
REGS(D)_CL=1
%FINISH
PI(EXCH); ! DEST OVER SOURCE FOR MVB
PI(LR0-BR0+D); ! FURTHER COPY OF SOURCE
REGS(D)_CL=0
P3I(LBI,CI1,IADD); ! ASSIGN
PI(MVB)
%IF PARM_OPT#0 %START; ! CHECK LENGTH
PI(LR0-BR0+D)
PI(LBI); ! CURRENT LENGTN = BYTE1 OF DEST
PI(ILE)
PPJ(JFALSE,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
PLOADCONST(0)
D=STRINGLBAD(TCELL)
DFETCHAD(NO,1,TCELL_UIOJ>>4&15,D&X'FFFF')
PI(ASSH)
%FINISHELSESTART; ! ASSIGN CONSTANT STRING
LRES=LOAD(OPND2)
LRES=LOAD(OPND1)
PLOADCONST((OPND2_XTRA+2)>>1)
PI(MVWD)
%FINISH
%CONTINUE
%FINISH
D=FINDREG(BRN)
REGS(D)_USE=0
LRES=LOAD(OPND2)
PI(SR0-BR0+D)
REGS(D)_CL=1
LRES=LOAD(OPND1)
P3I(LR0-BR0+D,LHI,MASKC); ! LENGTH OF RHS
REGS(D)_CL=0
%IF PARM_OPT#0 %START
PI(DUPL)
PLOADCONST(TCELL_ACC-1); ! LMAX
PI(IGE)
PPJ(JFALSE,9)
%FINISH
P3I(CI2,IADD,CVIA)
PI(MVWD)
%CONTINUE
TRIPSW(41): ! STRING JT VIA SUBROUTINE
LRES=LOAD(OPND1); ! SET BY GETPTR (IE LOADED)
LRES=LRES<<1!LOAD(OPND2); ! MAY OR MAY NOT NEED LOADING
%IF LRES=B'10' %THEN P4I(IPUSH,EXCH,IPOP,EXCH)
P2I(IPUSH,IPUSH)
P2I(IPUSH,ALIGN)
PPJ(0,18)
PI1(ASFW,16)
%CONTINUE
TRIPSW(46): ! STRING COMPARISONS INCL DSIDED
BFFLAG=0
%IF OPND2_FLAG=LCONST %AND OPND2_XTRA=0 %THEN OPND==OPND1 %AND ->NULLSC
%IF OPND1_FLAG=LCONST %AND OPND1_XTRA=0 %THEN OPND==OPND2 %AND BFFLAG=1 %AND ->NULLSC
%IF CURRT_FLAGS&LOADOP2#0 %START; ! OPND2 NOT LOADED
LRES=LOAD(OPND1)
LRES=LOAD(OPND2)
%FINISHELSEIF CURRT_FLAGS&LOADOP1=0 %START; ! BOTH LOADED
%FINISHELSESTART; ! ONLY 2 LDED BACK COMP
BFFLAG=1
LRES=LOAD(OPND1)
%FINISH
PPJ(0,28)
D=FCOMP(XTRA+16*BFFLAG)
PI(D)
%CONTINUE
NULLSC: ! TEST FOR A NULL STRING
LRES=LOAD(OPND)
P4I(CVBA,LBI,CI0,FCOMP(XTRA+16*BFFLAG))
%CONTINUE
TRIPSW(47): ! PRE RESOLUTION 1
! OPND1 IS 4 WORD WK AREA
! OPND2 IS STRING BEING RESLVD
! IN PNX WORK AREA IS USED AS FOLLOWS
! W1 WORD ADDRESS OF STRING BEING RESOLVED
! W2 ORIGINAL LENGTH! BYTES USED<<16
! W3&4 WORKSPACE
D=OPND1_D&X'FFFF'
LRES=LOAD(OPND2); ! 32 BIT ADDRESS TO ESTACK
DSTORE(ESTK,4,CURRINF_RBASE,D); ! 32 BIT ADDR TO WK AREA
P2I(CVBA,LBI)
DSTORE(ESTK,4,CURRINF_RBASE,D+4); ! WHOLE LENGTH STILL AVAILABLE
! 0 BYTES USED UP SO FAR
%CONTINUE
TRIPSW(48): ! PRE RESOLUTION 2
! OPND1 IS 4 WORD WK AREA
! OPND2 IS POINTER TO STRING TO HOLD
! FRAGMENT OR ZERO(=DISCARD FRGMNT)
D=OPND1_D&X'FFFF'
DFETCHAD(NO,4,CURRINF_RBASE,D+4)
DFETCH(ESTK,4,CURRINF_RBASE,D)
PI(IPUSH); ! RESLN STRING ADDR STACKED
PI(IPUSH); ! POINTER TO BYTES USED IS STCKD
%IF OPND2_FLAG=SCONST %START; ! NO STRING FOR FRAGMENT
P2I(CI0,CI0); ! TWO ZERO WORD
%FINISHELSE LRES=LOAD(OPND2); ! OR 2 POINTER WORDS
P2I(IPUSH,IPUSH); ! ARE STACKED
%CONTINUE
TRIPSW(49): ! RESOLUTION
! OPND1 IS STRING RES EXPR
! OPND2 IS LABEL NO
LRES=LOAD(OPND1)
P2I(IPUSH,ALIGN)
PPJ(0,16)
PI1(ASFW,24); ! RECLAIM PARM SPACE
%IF OPND2_D=0 %THEN PPJ(JFALSE,2); ! UNCONDITIONAL FAILS
! NDAIG PARAMETER LEFT BY SUBROUITNE
%CONTINUE
TRIPSW(60): ! RESFN FINAL POST RES ASSIGN
! OPND2 HAS POINTER
! SINCE RESOLVED STRING MAY BE CONST
! CAN NOT USE NORMAL ASSIGN
LRES=LOAD(OPND2); ! POINTER TO NEST
D=OPND1_D&X'FFFF'; ! TO 4 WORD WK AREA
C=FINDREG(BRN); ! TEMP REG FOR WORKSPACE
REGS(C)_USE=0; ! FORGET PREVIOUS USE
%IF PARM_OPT#0 %THEN PI(EXCH) %ELSE PI(DISCARD)
! MAX LEN TO BTM FOR CHK OR DISCARDED
P2I(CVBA,DUPL); ! DEST(TWICE) OVER LMAX
DFETCH(ESTK,4,CURRINF_RBASE,D)
PI(CVBA)
DFETCH(ESTK,4,CURRINF_RBASE,D+4)
PI1(ISHL,-16); ! BYTES USED
P3I(SR0-BR0+C,IADD,EXCH); ! SOURCE UNDER DEST BUT OVER LMAX
DFETCH(ESTK,4,CURRINF_RBASE,D+4); ! BYTESUSED<<16! ORIGINAL BYTES
P2I(MASKS,LR0-BR0+C); ! FETCH BACK BYTES USED
PI(ISUB); ! LENGTH OF FINAL STRING
PI(SR0-BR0+C); ! TO TEMP
P2I(CI1,IADD)
PPJ(0,29); ! CALL MOVE OVERLAPPING
P3I(LR0-BR0+C,EXCH,ASSB); ! STORE LENGTH WITH SECOND COPY OF DEST
%IF PARM_OPT#0 %START; ! CHECK CAPACITY
PI(ILE); ! COMPARED WITH ORIGINAL LMAX
PPJ(JFALSE,9); ! CAPACITY EXCEEDED
%FINISH
%CONTINUE
TRIPSW(68): ! SINDX INDEX STRING FOR CHARNO
! ON ALL M-CS WITH CONSISTENT BYTE ADDRESSING
! THIS CAN ROUTED WITH AINDX. SPECIAL
! CODE NEEDED ON PNX HOWEVER
LRES=LOAD(OPND1); ! THE "GOT ADDR" OF STRING
%IF CURRT_FLAGS&LOADOP2#0 %START; ! OFFSET NEDS LOADING
PI(CVBA)
%UNLESS OPND2_FLAG=SCONST %AND OPND2_D=0 %START; ! LENGTH = 0 OFFSET
LRES=LOAD(OPND2)
PI(IADD)
%FINISH
%FINISHELSE P3I(EXCH,CVBA,IADD)
CURRT_OPTYPE=X'51'; ! 32 BIT ADDRESS MAY NEED SAVING
->STRES
!***********************************************************************
!* THIS NEXT SECTION DEALS WITH ROUTINE CALLS AND PARAMETER *
!* PASSING. ALSO STORING AND RECOVERY OF FN & MAP RESULTS *
!***********************************************************************
TRIPSW(23): ! IOCP CALL
LRES=LOAD(OPND2)
CIOCP(OPND1_D); ! ALWAYS CONSTANTS
OPND1_FLAG=9; ! FOR WHEN RES NEEDED
OPND1_XB=ESTK
FORGET(-1)
%CONTINUE
TRIPSW(24): ! PRECALL OPND1 HAS RT NAME
TCELL==ASLIST(TAGS(OPND1_D))
D=TCELL_SLINK
%IF D#0 %THEN D=ASLIST(D)_SNDISP; ! FIRST PARAM OFFSET
PTYPE=TCELL_PTYPE
SAVE IRS
C=(CURRT_DPTH+1)>>1; ! DEPTH IN PAIRS
PUSH(FPHEAD,FPPTR,C,0)
PI(ALIGN) %IF FPPTR&7#0
PI1(ESAVE,C) %UNLESS C=0
FPPTR=0
%IF D#0 %THEN PI(ALIGN) %AND FPPTR=FPPTR+4
%CONTINUE
TRIPSW(25): ! ROUTINE CALL (AFTER PARAMS)
! OPND1 HAS RT NAME
TCELL==ASLIST(TAGS(OPND1_D))
%IF FPPTR&7#0 %AND PARM_FAULTY=0 %THEN IMPABORT
%IF TCELL_UIOJ&15=14 %START; ! EXTERNAL CALL
PI1(CALL,TCELL_SNDISP)
%FINISHELSEIF TCELL_PTYPE&X'400'#0 %START
DFETCH(ESTK,8,TCELL_UIOJ>>4&15,TCELL_SNDISP)
! P3I(EXCH,SR0,EXCH); ! BERTS BUG
PI(CALLT); ! 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
%IF D=0 %THEN D=P NEXT SYMBOL %AND TCELL_SNDISP=D
PI1(CALL,D)
%FINISH
PI1(ASFW,FPPTR) %UNLESS FPPTR=0
POP(FPHEAD,FPPTR,C,D)
D=TCELL_PTYPE&X'80F'; ! MAP & TYPE BITS
%IF C#0 %START; ! ESTACK WAS SAVED
%IF C=5 %THEN PI1(RESE,C) %ELSE PI1(ERES,C)
%FINISH
%IF FPPTR&7#0 %THEN PI1(ASFW,4); ! ALIGN WAS DONE AT PRECALL
FORGET(-1)
%CONTINUE
TRIPSW(44): ! MAP RESULT ASSIGNMENT
! CALLED BEFORE RETURN TO CALLER
RES: LRES=LOAD(OPND2)
%CONTINUE
TRIPSW(45): ! FN RESULT ASSIGNMENT
! CALLED BEFORE RETURN TO CALLER
%IF OPND2_PTYPE&7=5 %START; ! STRING FN RESULTS
LRES=LOAD(OPND2)
P3I(DUPL,LHI,MASKC)
P2I(ILP2,EXCH)
P4I(CI2,IADD,CVIA,MVWD)
PI(ILP2); ! THE "RESULT"
%CONTINUE
%FINISH
->RES %UNLESS OPND2_PTYPE&7=2
%IF REGS(FR0)_CL=0 %THEN REGS(FR0)_USE=0
LRES=LOAD(OPND2)
%IF OPND2_XB#FR0 %START
%IF CURRT_OPTYPE=X'52' %THEN D=RSCPY %ELSE D=RDCPY
PI2(D,0,OPND2_XB-FR0)
REGS(OPND2_XB)_CL=0
%FINISHELSE REGS(FR0)_CL=0
%CONTINUE
TRIPSW(26): ! RECOVER FN RESULT
! CALLED AFTER RETURN TO CALLER
OPND1_FLAG=9; OPND1_XB=ESTK
%IF OPND1_PTYPE&7=2 %THENSTART
OPND1_XB=FR0
REGS(FR0)_CL=1
REGS(FR0)_AT=WTRIPNO
REGS(FR0)_LINK=WTRIPNO
%FINISH
%CONTINUE
TRIPSW(27): ! RECOVER MAP RESULT
! CALLED AFTER RETURN TO CALLER
OPND1_FLAG=9
OPND1_XB=ESTK
%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
PI1(ASFW,-C)
FPPTR=FPPTR+C
LRES=LOAD(OPND2); ! PTR TO STRING
%IF C<=32 %START; ! SHORT STRINGS
PI(SFA)
PLOADCONST(C>>1)
%FINISHELSESTART; ! LONG STRINGS COMPUTE MOVE SIZE
P4I(DUPL,LHI,MASKC,CI2)
P4I(IADD,CVIA,SFA,EXCH)
%FINISH
PI(MVWD)
%IF PARM_OPT#0 %START
P3I(SFA,LHI,MASKC); ! LENGTH FROM DEST
PLOADCONST(D); ! FOR ASSNMNT CHECK
PI(IGE)
PPJ(JFALSE,9)
%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)
PI1(ASFW,-C)
PI(SFA)
BULKM(D,C,0)
FPPTR=FPPTR+C
%FINISHELSESTART
LRES=LOAD(OPND2)
C=OPND1_PTYPE
%IF C=X'62' %THENSTART
PI1(RDPUSHD,OPND2_XB-FR0)
FPPTR=FPPTR+8
%FINISHELSEIF C=X'52' %THENSTART
PI1(RSPUSHS,OPND2_XB-FR0)
FPPTR=FPPTR+4
%FINISHELSESTART
%IF C=X'31' %THEN PI1(ISHL,8)
PI(IPUSH)
FPPTR=FPPTR+4
%FINISH
%IF C&7=2 %THEN REGS(OPND2_XB)_CL=0
%FINISH
%CONTINUE
TRIPSW(29): ! GET 32 BIT ADDRESS
LOADAD(OPND1)
->STRES
%CONTINUE
TRIPSW(30): ! GET POINTER FOR %NAME
LOADPTR(OPND1,OPND2)
->STRES
%CONTINUE
TRIPSW(31): ! PARAM PASSING (2) NORMAL PTRS
LRES=LOAD(OPND2)
PTYPE=OPND1_PTYPE&255; ! FOR PARAM
%IF PTYPE=X'35' %START; ! STRING(2 WORD) PTRS
FPPTR=FPPTR+4
P2I(EXCH,IPUSH)
%FINISH
PI(IPUSH)
FPPTR=FPPTR+4
%CONTINUE
TRIPSW(32): ! PARAM PASSING(3) ARRAYS
! ALSO (4) PASS RT PARAM SAME CODE
LRES=LOAD(OPND2)
P3I(EXCH,IPUSH,IPUSH)
FPPTR=FPPTR+8
%CONTINUE
TRIPSW(69): ! PASS 6 STORE STR FN RES PTR
! OPND2_D HAS OFFSET
PLOADCONST(255)
LRES=LOAD(OPND2)
P2I(IPUSH,IPUSH)
FPPTR=FPPTR+8
%CONTINUE
TRIPSW(63): ! RTFP TURN RTNAME INTO FORMAL
TCELL==ASLIST(TAGS(OPND1_D))
%IF TCELL_PTYPE&X'400'#0 %START; ! NAM>0 PASS A FORMAL
DFETCH(ESTK,8,TCELL_UIOJ>>4&15,TCELL_SNDISP)
%FINISHELSEIF TCELL_UIOJ&15=14 %START; ! EXTERNAL PASSED
PLOADCONST(0); ! DUMMY DISPLAY DESC
PFIXI(LGA,TCELL_SNDISP,0); ! RT FIXUP AREA== RT ID NO
%FINISHELSESTART
C=TCELL_UIOJ>>4&15
%IF C>0 %THEN PI1(ILL,-4*(C+1)) %ELSE PLOADCONST(0)
D=TCELL_SNDISP
%IF D=0 %THEN D=PNEXT SYMBOL %AND TCELL_SNDISP=D
PFIXI(LGA,1,TCELL_SNDISP)
%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(ESTK,8,TCELL_UIOJ>>4&15,TCELL_SNDISP)
%FINISHELSESTART
LRES=LOAD(OPND1); ! 32 BIT ADDRESS
PLOADCONST(OPND2_D)
PI(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
PSWITCH(OPND2_XTRA-OPND2_D+1,GLABEL)
GLABEL=GLABEL+1
%IF PARM_OPT#0 %THEN PLOADCONST(X'802') %AND PPJ(JUMP,2)
! 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
PSWITCHLABEL(TCELL_SNDISP,OPND2_D-LCELL_S2); ! REFS REL START OF 0
FORGET(-1)
%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)
%IF C#0 %THEN PLOADCONST(C) %AND PI(ISUB)
PJUMP(JUMP,TCELL_SNDISP); ! JUMP TO INDEXED JUMP
%CONTINUE
TRIPSW(37): ! REAL TO INTGER INTPT(OPND1)
! WORK OUT AS(INT(X-0.5)
%BEGIN
%RECORD (RD) COPND
LRES=LOAD(OPND1)
COPND_PTYPE=OPND1_PTYPE&255
COPND_FLAG=1
%IF OPND1_PTYPE>>4&15=6 %START; ! LONGREAL
CV2=0.49999999999999999; D=RDSUB
MOVE BYTES(8,ADDR(CV2),0,ADDR(COPND_D),0)
%FINISHELSESTART
COPND_R=0.49999999; D=RSSUB
%FINISH
LRES=LOAD(COPND)
REGS(COPND_XB)_CL=0
PI2(D,OPND1_XB-FR0,COPND_XB-FR0)
%END
TRIPSW(36): ! REAL TO INTEGER AS INT
LRES=LOAD(OPND1)
C=FINDREG(FRN)-FR0
%IF OPND1_PTYPE>>4&7=6 %START
PI1(RDROUND,OPND1_XB-FR0)
%FINISHELSESTART
PI1(RSROUND,OPND1_XB-FR0)
%FINISH
REGS(OPND1_XB)_CL=0
OPND1_XB=0
OPND1_PTYPE=X'51'
%CONTINUE
TRIPSW(38): ! INTEGER TO STRING AS TOSTRING
GET WSP(D,1)
LRES=LOAD(OPND1)
PI1(ISHL,8)
PLOADCONST(1)
PI(IADD)
PI1(ISHL,16)
DSTORE(ESTK,4,CURRINF_RBASE,D)
PI(DISCARD) %IF CURRT_DPTH>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)
TCELL==ASLIST(TAGS(OPND1_D))
C=TCELL_SLINK
%IF TCELL_PTYPE&X'3FFF'=X'33' %THEN C=RECORDELAD(TCELL,OPND1_PTYPE,OPND1_XTRA)
DSTORE(ESTK,8,TCELL_UIOJ>>4&15,C)
%FINISHELSESTART
IMPABORT %UNLESS OPND1_FLAG=INDIRECT %OR OPND1_FLAG=REFTRIP %OR %C
OPND1_FLAG=INDNAME %OR PARM_FAULTY#0
LRES=LOAD(OPND2)
D=FINDREG(FRN)
REGS(D)_USE=0
P3I(EXCH,IPUSH,IPUSH)
PI1(RDPOPD,D-FR0)
%IF OPND1_FLAG=INDIRECT %AND OPND1_XTRA>0 %START
PLOADCONST(OPND1_XTRA>>1)
PI(IADD)
%FINISH
%IF OPND1_FLAG=INDNAME %THEN LOADAD(OPND1)
INDSTORE(D,8)
%FINISH
%CONTINUE
TRIPSW(43): ! POINTER ASSIGNMENT
D=BYTES(CURRT_OPTYPE>>4)
LRES=LOAD(OPND2)
%IF OPND1_FLAG=DNAME %START; ! LOCAL PTR
TCELL==ASLIST(TAGS(OPND1_D))
C=TCELL_SLINK
%IF TCELL_PTYPE&X'3FFF'=X'33' %THEN C=RECORDELAD(TCELL,OPND1_PTYPE,OPND1_XTRA)
DSTORE(ESTK,D,TCELL_UIOJ>>4&15,C)
%CONTINUE
%FINISH
%UNLESS CURRT_FLAGS&LOADOP1=0 %START; ! DEST NOT LOADED
LRES=LOAD(OPND1)
%FINISHELSEIF D=4 %THEN PI(EXCH) %ELSE P4I(IPUSH,EXCH,IPOP,EXCH)
%IF OPND1_FLAG=INDIRECT %AND OPND1_XTRA>0 %THEN %C
PLOADCONST(OPND1_XTRA>>1) %AND PI(IADD)
%IF OPND1_FLAG=INDNAME %THEN LOADAD(OPND1)
INDSTORE(ESTK,D)
%CONTINUE
TRIPSW(62): ! RECORD ASSIGNMENT
%IF OPND2_FLAG=SCONST %THENSTART
LRES=LOAD(OPND1)
BULKM(0,XTRA,OPND2_D)
%CONTINUE
%FINISH
LRES=LOAD(OPND2)
%IF CURRT_FLAGS&LOAD OP1=0 %THEN EXCHANGE(OPND1,OPND2)
LRES=LOAD(OPND1)
BULKM(1,XTRA,0)
%CONTINUE
TRIPSW(64): ! AAINC INCREMENT RECORD RELATIVE
! ARRAY ACCESS BY RECORD BASE(OPND1)
! TO GIVE ABSOLUTE ACCESS.
LRES=LOAD(OPND1)
LRES=LOAD(OPND2); ! THE RELATIVE ACCESS
%IF XTRA=X'31' %START; ! BYTE ARRAY ACCESS REL OFFSET BYTE
P2I(EXCH,INDINT)
%FINISHELSE PI(IADD); ! ADDITION
->STRES
TRIPSW(65): ! AHADJ ARRAY MAPPING OPND1 1
! HAS ADJUSTMENT OPND2 THE HEAD
! ARRAY PTYPE<<4!MODE IS IN XTRA
LRES=LOAD(OPND1); ! LOAD NEW BASE
%IF XTRA>>4&255=X'31' %THEN PI(CVBA)
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(ESTK,D,JJ)
%FINISHELSESTART
FETCH HIGH AD END(ESTK,D,JJ)
PI(IADD)
FETCH LOW AD END(ESTK,D,JJ)
%FINISH
%CONTINUE
%FINISH
LRES=LOAD(OPND2); ! ARRAY HEAD BEFORE ADJMNT
%IF XTRA&1=0 %START; ! ARRAY MAPPING OPND1 IS BASE
P2I(EXCH,DISCARD); ! DISCARD OLD BASE
%FINISHELSESTART
PI(IPUSH)
PI(IADD); ! ADDRESSES ADDED
PI(IPOP)
%FINISH
%CONTINUE
!***********************************************************************
!* SECTION FOR GENERATING CODE FOR INLINE ASSEMBLER *
!***********************************************************************
TRIPSW(50): ! UC NOOP
! CNOP(OPND1_D>>8,OPND1_D&255)
FORGET(-1)
%CONTINUE
TRIPSW(51): ! UCB1 ONE BYTE ASSEMBLER
PI(OPND1_D)
FORGET(-1)
%CONTINUE
TRIPSW(52): ! UCB2 TWO BYTE ASSEMBLER
PPUT2(OPND1_D&X'FFFF'); ! FOR *PUTS ALSO
FORGET(-1)
%CONTINUE
TRIPSW(53): ! UCB3 3 BYTE ASSEMBLER
PI2(OPND1_D>>16,OPND1_D>>8&255,OPND1_D&255)
FORGET(-1)
%CONTINUE
TRIPSW(54): ! UCW ASSEMBLER WITH WORD OPERAND
PI1(OPND1_D,OPND1_XTRA)
FORGET(-1)
%CONTINUE
TRIPSW(55): ! UCBW BYTE&WORD OPERAND ASSEMBLER
PI2(OPND1_D>>24,OPND1_D>>16&255,OPND1_D&X'FFFF')
FORGET(-1)
%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(NO,C,TCELL_UIOJ>>4&15,JJ) %ELSEIF D=2 %THEN %C
DSTORE(ESTK,C,TCELL_UIOJ>>4&15,JJ) %ELSE DFETCH(ESTK,C,TCELL_UIOJ>>4&15,JJ)
%CONTINUE
STRES:
CURRT_OPTYPE<-OPND1_PTYPE
%IF CURRT_CNT>1 %AND CURRT_OPERN#LASS %START; ! USED MORE THAN ONCE
! AND NOT ALREADY STORED
%IF CURRT_FLAGS&USE ESTACK#0 %START; ! IMPLIES _CNT=2 %AND TYPE=1
PI(DUPL)
%FINISHELSESTART
C=BYTES(OPND1_PTYPE>>4&15)
%IF C<4 %THEN C=4
GET WSP(D,C>>2)
DSTORE(OPND1_XB,C,CURRINF_RBASE,D)
OPND1_D=CURRINF_RBASE<<16!D
OPND1_XTRA=M'DUPL'
OPND1_FLAG=7
%FINISH
%FINISH
! %IF CURRT_CNT=1 %AND CURRT_OPTYPE&7=2 %AND ! CURRT_PUSE-WTRIPNO>2 %START
! BOOT OUT(OPND1_XB)
! %FINISH
%IF CURRT_CNT=0 %AND 0<OPND1_XB<=FR3 %AND REGS(OPND1_XB)_CL>0 %THEN %C
REGS(OPND1_XB)_CL=0
%REPEAT
%IF PARM_DCOMP#0 %START
PRINTSTRING("
CODE FOR LINE")
WRITE(WORKA_LINE,3)
PCODELINE; PRINT USE
PLINESTART(WORKA_LINE); ! PREVENT CODE COMING AGAIN
%FINISH
%RETURN
%INTEGERFN LOAD(%RECORD (RD) %NAME OPND)
!***********************************************************************
!* LOAD OPERAND OPND INTO TOP OF NEST(ESTACK) *
!***********************************************************************
%INTEGER K,KK,X,PREG,B,D,RES,PTYPE,TYPE,PREC
%STRING (255) SVAL
%RECORD (RD) ROPND
%RECORD (TRIPF) %NAME REFTRIP
%RECORD (TAGF) %NAME TCELL
%SWITCH SW(0:9)
K=OPND_FLAG
RES=1; ! SOMETHING LOADED
PTYPE=OPND_PTYPE
TYPE=PTYPE&15
PREC=PTYPE>>4&15
%IF K<=7 %START
%IF TYPE#2 %THEN PREG=ESTK %ELSE PREG=FINDREG(FRN)
%FINISH
%IF K>9 %THEN IMPABORT
->SW(K)
SW(0): ! CONSTANT < 16 BITS
SW(1):
%IF TYPE=5 %THEN ->SCONST
%IF TYPE=1 %THEN PLOAD CONST(OPND_D) %AND ->LDED
%IF TYPE=2 %THENSTART
! VALUES WHICH GIVE SPURIOUS 0
%IF HOST=EMAS %THEN REFORMATC(OPND)
STORE CONST(KK,OPND)
PFIXI(LGA,CAREA,KK)
%IF PREC=5 %THEN KK=RSLDIS %ELSE KK=RDLDID
PI1(KK,PREG-FR0)
%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
STORE STRING(KK,SVAL)
PFIXI(LGA,CAREA,KK)
->LDED
SW(3): ! 128 BIT CONSTANT
IMPABORT
SW(2): ! NAME
TCELL==ASLIST(TAGS(OPND_D))
K=BYTES(OPND_PTYPE>>4&15)
%IF TCELL_PTYPE&X'3FFF'=X'33' %START
KK=RECORDELAD(TCELL,PTYPE,OPND_XTRA)
%FINISHELSEIF TYPE=5 %THEN KK=STRINGLBAD(TCELL) %ELSE KK=TCELL_SLINK
%IF TYPE=5 %THEN DFETCHAD(NO,1,TCELL_UIOJ>>4&15,KK&X'FFFF') %ELSE %C
DFETCH(PREG,K,TCELL_UIOJ>>4&15,KK)
LDED:
%IF TYPE=1 %AND PREC<5 %THEN OPND_PTYPE=X'51'
OPND_FLAG=9
OPND_XB=PREG
%IF PREG>0 %THEN REGS(PREG)_CL=1 %AND REGS(PREG)_AT=WTRIPNO %AND REGS(PREG)_LINK=WTRIPNO
%RESULT=RES
SW(5): ! INDIRECT VIA DICTIONARY
! ONLY RECORD SCALAR(_XTRA>=0)
! OR POINTER(_XTRA<0)
TCELL==ASLIST(TAGS(OPND_D))
%IF TYPE=5 %AND OPND_XTRA<0 %START; ! STRING POINTER
FETCH HIGH AD END(ESTK,TCELL_UIOJ>>4&15,TCELL_SLINK)
%FINISHELSE DFETCH(ESTK,4,TCELL_UIOJ>>4&15,TCELL_SLINK)
->IFETCH
SW(4): ! VIA POINTER AT OFFSET FROM
! A COMPUTED ADDRESS
X=OPND_XTRA; ! CAN GET CHANGED BY RECURSIVE LD
REFTRIP==TRIPLES(OPND_D)
%IF REFTRIP_PUSE#WTRIPNO %THEN OPND_FLAG=8 %AND LRES=LOAD(OPND)
%IF TYPE=5 %THEN X=X+4
%IF X>0 %THEN PLOADCONST(X>>1) %AND PI(IADD)
! ADDRESS OF POINTER NOW IN ESTK
PI(LI); ! POINTER OR ADDRESS PORTION IN ESTK
%IF TYPE#5 %THEN INDLOAD(PREG,BYTES(PREC))
->LDED
SW(6): ! INDIRECT WITH OFFSET
REFTRIP==TRIPLES(OPND_D)
%IF REFTRIP_PUSE#WTRIPNO %START; ! NEED TO LOAD TRIPLE
ROPND=OPND
ROPND_PTYPE=REFTRIP_OPTYPE
ROPND_FLAG=8
KK=LOAD(ROPND)
%FINISH
IFETCH:
%IF TYPE=5 %START
PLOADCONST(OPND_XTRA>>1) %AND PI(IADD) %IF OPND_XTRA>0
%FINISHELSEIF TYPE=1 %AND PREC=3 %START
%IF OPND_XTRA>=0 %THEN PI(CVBA); ! RECORDS ARE WORD PTRS?
KK=OPND_XTRA!!1
PLOADCONST(KK) %AND PI(IADD) %UNLESS KK<=0
INDLOAD(ESTK,1)
%FINISHELSESTART
PLOADCONST(OPND_XTRA>>1) %AND PI(IADD) %UNLESS OPND_XTRA<=0
INDLOAD(PREG,BYTES(PREC))
%FINISH
->LDED
SW(7): ! I-R IN A STACK FRAME
B=OPND_D>>16; D=OPND_D&X'FFFF'
%IF TYPE=5 %THENSTART
%IF OPND_XTRA=M'DUPL' %THEN DFETCH(PREG,4,B,D) %ELSE DFETCHAD(NO,1,B,D+OPND_XTRA-1)
%FINISHELSESTART
%IF OPND_XTRA=M'ARRH' %THEN FETCH HIGH AD END(PREG,B,D) %ELSE %C
DFETCH(PREG,BYTES(PREC),B,D)
%FINISH
->LDED
SW(8): ! TRIPLE
REFTRIP==TRIPLES(OPND_D)
%IF TYPE#5 %AND REFTRIP_PUSE=WTRIPNO %AND REFTRIP_FLAGS&NOTINREG=0 %THEN %C
PREG=REFTRIP_OPND1_XB %AND RES=0 %AND ->LDED
OPND=REFTRIP_OPND1
%RESULT=LOAD(OPND)
SW(9): ! I-R IN A REGISTER
PREG=OPND_XB
%IF PREG>0 %THEN REGS(PREG)_LINK=WTRIPNO %AND REGS(PREG)_AT=WTRIPNO
%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
%IF B=0 %THENRESULT=D+XDISP
D=D+TCELL_ACC-XDISP
%IF SPTYPE&7=5 %THENRESULT=D-1
D=D-BYTES(SPTYPE>>4&7)
%IF SPTYPE=X'31' %THEN D=D!!1
%RESULT=D
%END
%ROUTINE INDLOAD(%INTEGER REG,SIZE)
!***********************************************************************
!* LOADS REG VIA INDIRECTION POINTER ON ETOS *
!***********************************************************************
%INTEGER BR
%SWITCH SW(0:8)
->SW(SIZE)
SW(*): ! UNKNOWN SIZES
IMPABORT
SW(1): ! BYTE
PI(LBI); %RETURN
SW(2): ! HALF
PI(LHUI); %RETURN
SW(4): ! WORD
%IF FR0<=REG<=FR3 %THEN PI1(RSLDIS,REG-FR0) %ANDRETURN
PI(LI)
%IF BR0<=REG<=BR3 %THEN PI(SR0-BR0+REG)
%RETURN
SW(8): ! LONGREAL
%IF REG=ESTK %START; ! DOUBLE WORD IN ESTACK
BR=FINDREG(BRN)
REGS(BR)_USE=0
PI(SR0-BR0+BR)
PI(LI); ! LOW AD END
PI1(LRO0-BR0+BR,4); ! HIGH AD END
PI(EXCH); ! SO LOW AD END ON TOP
%FINISHELSE PI1(RDLDID,REG-FR0)
%END
%ROUTINE INDSTORE(%INTEGER REG,SIZE)
!***********************************************************************
!* STORES REG VIA INDIRECTION POINTER ON ETOS *
!* WHEN REG ALSO = ETOS %THEN ROUTINE ASSUMES CORRECT ORDERING *
!***********************************************************************
%INTEGER BR
%SWITCH SW(0:8)
->SW(SIZE)
SW(*): ! UNKNOWN SIZES
IMPABORT
SW(1): ! BYTE
PI(ASSB); %RETURN
SW(2): ! HALF
PI(ASSH); %RETURN
SW(4): ! WORD
%IF FR0<=REG<=FR3 %THEN PI1(RSASSS,REG-FR0) %ANDRETURN
%IF BR0<=REG<=BR3 %THEN P2I(LR0-BR0+REG,EXCH)
PI(ASS)
%RETURN
SW(8): ! LONGREAL
%IF REG=ESTK %START; ! DOUBLE WORD IN ESTACK
BR=FINDREG(BRN)
REGS(BR)_USE=0;
P2I(SR0-BR0+BR,ASS); ! LOW AD END FROM TOP
PI(EXCH)
PI1(SRO0-BR0+BR,4); ! HIGH AD END FROM LOWER POSN
%FINISHELSE PI1(RDASSD,REG-FR0)
%END
%ROUTINE LOADAD(%RECORD (RD) %NAME OPND)
!***********************************************************************
!* MUCH AS LOAD BUT PRODUCES THE 32 BIT ADDRESS OF OPERAND *
!* ABORT ON NON RELEVANT ALTERNATIVES OF OPND *
!***********************************************************************
%RECORD (TRIPF) %NAME REFTRIP
%RECORD (TAGF) %NAME TCELL
%RECORD (RD) ROPND
%INTEGER B,D,X,K,PTYPE
%SWITCH SW(0:9)
PTYPE=OPND_PTYPE
X=OPND_XTRA
K=OPND_FLAG
->SW(K)
SW(*): ! INVALID
IMPABORT
SW(2): ! DNAME
TCELL==ASLIST(TAGS(OPND_D))
B=TCELL_UIOJ>>4&15
%IF TCELL_PTYPE&X'3FFF'=X'33' %THEN D=RECORDELAD(TCELL,PTYPE,X) %ELSEIF %C
PTYPE&255=X'35' %THEN D=STRINGLBAD(TCELL) %ELSE D=TCELL_SLINK
DFETCHAD(NO,BYTES(PTYPE>>4&15),B,D)
LDED:
OPND_PTYPE=X'51'; ! 32 BIT ADDRESS IS INTEGER
OPND_FLAG=9
OPND_XB=ESTK
%RETURN
SW(4): ! VIA POINTER AT OFFSET FROM
! A COMPUTED ADDRESS
REFTRIP==TRIPLES(OPND_D)
%IF REFTRIP_PUSE#WTRIPNO %THEN OPND_FLAG=8 %AND LRES=LOAD(OPND)
%IF PTYPE&255=X'35' %THEN X=X+4
%IF X>0 %THEN PLOADCONST(X>>1) %AND PI(IADD)
! ADDRESS OF POINTER NOW IN ESTK
PI(LI); ! ADDRESS IN ESTACK
%IF PTYPE&X'FF'=X'31' %THEN PI(CVIA); ! BYTE POINTERS ARE BYTE ADDRESSES
->LDED
SW(5): ! INDIRECT VIA PTR
TCELL==ASLIST(TAGS(OPND_D))
B=TCELL_UIOJ>>4&15
D=TCELL_SLINK
%IF PTYPE&X'FF'=X'35' %AND OPND_XTRA<0 %START; ! STRING POINTER
FETCH HIGH AD END(ESTK,B,D)
->LDED
%FINISH
DFETCH(ESTK,4,B,D)
->INC ADDR
SW(6): ! INDIRECT OFFSET
REFTRIP==TRIPLES(OPND_D)
%IF REFTRIP_PUSE#WTRIPNO %THENSTART
ROPND=OPND
ROPND_PTYPE=REFTRIP_OPTYPE
ROPND_FLAG=8
LRES=LOAD(ROPND)
%FINISH
INC ADDR: ! X>=0 RECORD: X<0 POINTER
%IF OPND_PTYPE&X'FF'=X'31' %AND X<0 %START; ! BYTE INTEGER ARRAYS
PI(CVIA)
%FINISHELSESTART; ! ALL OTHER ITEMS WORD ADDRESSES
%IF X>0 %THEN PLOADCONST(X>>1) %AND PI(IADD)
%FINISH
->LDED
SW(7): ! LOCAL-IR IN BASE&OFFSET FORM
B=OPND_D>>16
D=OPND_D&X'FFFF'
DFETCHAD(NO,BYTES(PTYPE>>4&7),B,D)
->LDED
%END
%ROUTINE LOADPTR(%RECORD (RD) %NAME OPND,OPND2)
!***********************************************************************
!* MUCH AS LOAD BUT PRODUCES THE POINTER TO THE OPERAND *
!* ABORT ON NON RELEVANT ALTERNATIVES OF OPND *
!***********************************************************************
%RECORD (TRIPF) %NAME REFTRIP
%RECORD (TAGF) %NAME TCELL
%RECORD (RD) ROPND
%INTEGER K,B,D,X,PTYPE
%SWITCH SW(0:9)
PTYPE=OPND_PTYPE
X=OPND_XTRA
K=OPND_FLAG
->SW(K)
SW(*): ! INVALID
IMPABORT
SW(2): ! DNAME
TCELL==ASLIST(TAGS(OPND_D))
%IF TCELL_PTYPE&X'3FFF'=X'33' %THENSTART
D=RECORDELAD(TCELL,PTYPE,X)
%FINISHELSEIF PTYPE&255=X'35' %THEN D=STRINGLBAD(TCELL) %ELSE D=TCELL_SLINK
%IF PTYPE&255=X'35' %THENSTART
PTYPE=OPND2_D>>16
DFETCHAD(NO,1,TCELL_UIOJ>>4&15,D&X'FFFF')
->STR
%FINISH
%IF PTYPE&255=X'31' %THEN DFETCHAD(YES,1,TCELL_UIOJ>>4&15,D) %ELSE %C
DFETCHAD(NO,BYTES(OPND_PTYPE>>4&7),TCELL_UIOJ>>4&15,D)
LDED:
OPND_PTYPE=X'51'
OPND_FLAG=9
OPND_XB=ESTK
%RETURN
SW(4): ! VIA POINTER AT OFFSET FROM
! A COMPUTED ADDRESS
REFTRIP==TRIPLES(OPND_D)
%IF REFTRIP_PUSE#WTRIPNO %THEN OPND_FLAG=8 %AND LRES=LOAD(OPND)
%IF X>0 %THEN PLOADCONST(X>>1) %AND PI(IADD)
! ADDRESS OF POINTER NOW IN ESTK
%IF PTYPE&255=X'35' %THEN INDLOAD(ESTK,8) %AND ->SLDED
INDLOAD(ESTK,4)
->LDED
SW(5): ! INDIRECT VIA DICT
TCELL==ASLIST(TAGS(OPND_D))
%IF X<0 %START; ! IS A POINTER
D=4
%IF PTYPE&255=X'35' %THEN D=8
DFETCH(ESTK,D,TCELL_UIOJ>>4&15,TCELL_SLINK)
->LDED
%FINISH
DFETCH(ESTK,4,TCELL_UIOJ>>4&15,TCELL_SLINK)
->INC ADDR
SW(6): ! INDIRECT OFFSET
REFTRIP==TRIPLES(OPND_D)
%IF REFTRIP_PUSE#WTRIPNO %THENSTART
ROPND=OPND
ROPND_PTYPE=REFTRIP_OPTYPE
ROPND_FLAG=8
LRES=LOAD(ROPND)
%FINISH
INC ADDR: ! FOR RECORD ELEMENTS
%IF PTYPE&255=X'31' %START; ! BYTE POINTER WANTED
PI(CVBA) %IF X>=0; ! RECORD POINTER IN WORDS
X=X!!1
%IF X>0 %THEN PLOADCONST(X) %AND PI(IADD)
%FINISHELSESTART; ! WORD POINTER WANTED
%IF X>0 %THEN PLOADCONST(X>>1) %AND PI(IADD)
%FINISH
STR: ! ORGANISE WORD2 OF STR PNTR
! OPND2_XTRA=BML<<16!DML
->LDED %UNLESS PTYPE&255=X'35'; ! ALL NON STRING
%IF OPND2_XTRA<0 %THEN PLOADCONST(OPND2_XTRA&X'FFFF') %ELSESTART
FETCHLOW AD END(ESTK,OPND2_XTRA>>16,OPND2_XTRA&X'FFFF')
! FOR STRINGNAMES PTR NOW LOADED
! FR STRINGARRAYNAMES DVBASE NOW LDED
! HAVE TO EXTRACT ELSIZE AND DECREMENT BY 1
%IF PTYPE&X'300'#0 %THENSTART
P3I(CI3,IADD,LHI)
PLOADCONST(1)
PI(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(NO,BYTES(PTYPE>>4&7),B,D)
->LDED
SW(8): ! A TRIPLE MEANS PREVIOUSLY USED
! POINTER A SECOND TIME
REFTRIP==TRIPLES(OPND_D)
IMPABORT %UNLESS REFTRIP_OPERN=GETPTR
LRES=LOAD(OPND)
%END
%ROUTINE VMY
!***********************************************************************
!* DOES ALL VECTOR MULTIPLIES *
!***********************************************************************
%INTEGER DVPOS,PR,CM
DVPOS=OPND2_D&X'FFFF'
PR=OPND1_PTYPE>>4&15
CM=-1
%IF PARM_ARR#0 %START
%IF DVPOS>0 %START; ! BOUND KNOWN
PLOADCONST(CTABLE(DVPOS+3*C+1))
PLOADCONST(CTABLE(DVPOS+3*C))
%FINISHELSESTART
CM=SETDVREG(-1,OPND2_XTRA)
PI1(LRO0-BR0+CM,12*C+4)
PI1(LRO0-BR0+CM,12*C)
%FINISH
PI(CHK)
%FINISH
%IF C#1 %START; ! ALL DIMENSION BAR 1ST
%IF DVPOS>0 %THENSTART
PLOADCONST(CTABLE(DVPOS+3*C-1))
%FINISHELSESTART
CM=SET DVREG(-1,OPND2_XTRA) %IF CM<0
PI1(LRO0-BR0+CM,12*C-4); ! MULTIPLIER
%FINISH
PI(IMULT)
%FINISH
%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 OREG,WREG,MOP,DOP,FLOP,COPOP,LBASE
OREG=OPND1_XB-FR0; ! OPERAND REGISTER
WREG=FINDREG(FRN); ! WORKING FLOATING REGISTER
FORGET(WREG)
FORGET(OREG)
WREG=WREG-FR0
LBASE=GLABEL; GLABEL=GLABEL+5
%IF CURRT_OPTYPE>>4&15=6 %START; ! LONG MODE
MOP=RDMULT; DOP=RDDIV
FLOP=RDFLOAT; COPOP=RDCPY
%FINISHELSESTART
MOP=RSMULT; DOP=RSDIV
FLOP=RSFLOAT; COPOP=RSCPY
%FINISH
! CODE PLANTED IS AS FOLLOWS
!
! DUPL, DUPL, LCONST 0, IJLE L0 COPY ORIGINAL SIGNED EXPONENT
! INEG,
!L0 LCONST 1, FLOAT 1 1 TO WORK REG
!L1 DUPL, LCONST 1
! ILAND, JFALSE L2 USES ZERO=FALSE EQUIVALENCE
! RMULT WREG,OREG
!L2 ISHL -1, DUPL
! JFALSE L3 FINISHED USES ZERO=FALSE
! RMULT OREG,OREG, JUMP L1 SQUARE AND CONTINUE
!L3 ERASE EXPOSE ORIGINAL SIGNED EXPONENT
! RCOPY OREG,WREG COPY RESULT TO ORIGINAL
! LCONST 0, IJGE L4
! LCONST 1, FLOAT OREG
! RDIV OREG,WREG INVERT
!L4
!
P3I(DUPL,DUPL,CI0)
PJUMP(IJGE,LBASE)
PI(INEG)
PLABEL(LBASE)
PLOADCONST(1)
PI1(FLOP,WREG)
PLABEL(LBASE+1)
PI(DUPL)
PLOADCONST(1)
PI(ILAND)
PJUMP(JFALSE,LBASE+2)
PI2(MOP,WREG,OREG)
PLABEL(LBASE+2)
PI1(ISHL,-1)
PI(DUPL)
PJUMP(JFALSE,LBASE+3)
PI2(MOP,OREG,OREG)
PJUMP(JUMP,LBASE+1)
PLABEL(LBASE+3)
PI(DISCARD)
PI2(COPOP,OREG,WREG)
PLOADCONST(0)
PJUMP(IJGE,LBASE+4)
PLOADCONST(1)
PI1(FLOP,OREG)
PI2(DOP,OREG,WREG)
PLABEL(LBASE+4)
%END
%ROUTINE REXP
!***********************************************************************
!* CALLS A PERM ROUTINE TO PERFORM REAL**REAL *
!***********************************************************************
IMPABORT
%END
%INTEGERFN SET DVREG(%INTEGER WHICH,DVBD)
!***********************************************************************
!* SELECT(USUALLY) AND SET UP A C REGISTER AS A BASE REGISTER *
!* FOR A DOPEVECTOR IN ARRAY WHOSE HEAD B&D GIVEN *
!***********************************************************************
%INTEGER I
%RECORD (REGF) %NAME REG
%IF WHICH<0 %START; ! ANY REG
WHICH=FIND USE(BRN,15,DVBD)
%RESULT=WHICH %IF WHICH>0
WHICH=FINDREG(BRN)
%FINISH
REG==REGS(WHICH)
%UNLESS REG_USE=15 %AND REG_INF1=DVBD %START
FETCHLOW AD END(WHICH,DVBD>>16,DVBD&X'FFFF')
PI(DISCARD)
REG_USE=15; REG_INF1=DVBD
%FINISH
%RESULT=WHICH
%END
%INTEGERFN FIND USE(%INTEGER MASK,USE,INF)
!***********************************************************************
!* SEARCHES FOR A REGISTER LOADED WITH USEFULL INFO *
!***********************************************************************
%INTEGER I,L,U
%RECORD (REGF) %NAME REG
L=MASK>>16
U=MASK&255
%CYCLE I=L,1,U
REG==REGS(I)
%IF REG_USE=USE %AND REG_INF1=INF %THENRESULT=I
%REPEAT
%RESULT=-1
%END
%INTEGERFN SET LEVELREG(%INTEGER WHICH,RLEV)
!***********************************************************************
!* SELECT(USUALLY) AND SET UP A C REGISTER AS A BASE REGISTER *
!* FOR ROUTINELEVEL RLEV *
!***********************************************************************
%INTEGER I
%RECORD (REGF) %NAME REG
%IF WHICH<0 %START; ! ANY REG
WHICH=FINDUSE(BRN,4,RLEV)
%RESULT=WHICH %IF WHICH>0
WHICH=FINDREG(BRN)
%FINISH
REG==REGS(WHICH)
%UNLESS REG_USE=4 %AND REG_INF1=RLEV %START
PI1(ILL,-4*(RLEV+1))
P2I(SR0+WHICH-BR0,DISCARD)
REG_USE=4; REG_INF1=RLEV
%FINISH
%RESULT=WHICH
%END
%ROUTINE SAVE IRS
!***********************************************************************
!* DUMP REGISTERS INTO LOCAL SPACE. USED BEFORE CALLING FNS *
!* IN EXPRESSIONS. *
!***********************************************************************
%INTEGER I
%CYCLE I=FR0,1,FR1
%IF REGS(I)_CL>=1 %THEN BOOT OUT(I)
%REPEAT
%END
%ROUTINE BOOT OUT(%INTEGER REG)
!***********************************************************************
!* REMOVE TEMPORARIES FROM REG INTO LOCAL STORE *
!***********************************************************************
%INTEGER SIZE
%RECORD (REGF) %NAME BOOTREG
%RECORD (RD) %NAME R
%RECORD (TRIPF) %NAME RTRIP
BOOTREG==REGS(REG)
IMPABORT %UNLESS 1<=BOOTREG_CL<=3
RTRIP==TRIPLES(BOOTREG_LINK)
R==RTRIP_OPND1
IMPABORT %UNLESS R_XB=REG
SIZE=BYTES(R_PTYPE>>4&15)
GET WSP(R_D,SIZE>>2)
DSTORE(REG,SIZE,CURRINF_RBASE,R_D)
R_FLAG=7; R_XB=0
R_D=R_D!CURRINF_RBASE<<16
BOOTREG_CL=0
RTRIP_FLAGS=RTRIP_FLAGS!NOTINREG
%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 REG,SIZE,RLEVEL,DISP)
!***********************************************************************
!* STORE SIZE(BYTES) FROM DISP(BYTES) IN DISPLAY 'LEVEL' *
!***********************************************************************
%INTEGER LEVELCODE,BREG
%RECORD (LEVELF) %NAME INF
%SWITCH SW(0:24)
IMPABORT %UNLESS REG=ESTK %OR SIZE=4 %OR (SIZE=8 %AND FR0<=REG<=FR3)
%IF RLEVEL=0 %THEN LEVELCODE=0 %ELSEIF RLEVEL=CURRINF_RBASE %THEN LEVELCODE=1 %ELSE %C
LEVELCODE=2
%IF SIZE=4 %START
%IF FR0<=REG<=FR3 %THEN DFETCHAD(NO,4,RLEVEL,DISP) %AND PI1(RSASSS,REG-FR0) %ANDRETURN
%IF BR0<=REG<=BR1 %THEN PI(LR0-BR0+REG)
%FINISH
->SW(8*LEVELCODE+SIZE)
SW(*): ! FUNNY SIZES
IMPABORT
SW(1): ! GLOBAL BYTE STORE
SW(9): ! LOCAL BYTE STORE
SW(17): ! INTERMEDIATE BYTE STORE
DFETCHAD(YES,SIZE,RLEVEL,DISP); ! SIMPLE WAY FOR NOW
PI(ASSB)
%RETURN
SW(2): ! GLOBAL HALF STORE
SW(10): ! LOCAL HALF STORE
SW(18): ! INTERMEDIATE HALF STORE
DFETCHAD(NO,SIZE,RLEVEL,DISP)
PI(ASSH)
%RETURN
SW(4): ! GLOBAL WORD STORE
PFIXI(SGI,2,DISP); ! FIXED INSTRN NEEDED
%RETURN
SW(12): ! LOCAL WORD STORE
PI1(ISL,CURRINF_DISPLAY-(DISP+4))
%RETURN
SW(20): ! INTERMEDIATE WORD STORE
INF==WORKA_LEVELINF(RLEVTOLEVEL(RLEVEL))
BREG=SET LEVELREG(-1,RLEVEL)
PI1(SRO0-BR0+BREG,INF_DISPLAY-(DISP+4))
%RETURN
SW(8): ! DOUBLE REAL GLOBAL STORE
SW(16): ! DOUBLE REAL LOCAL STORE
SW(24): ! DOUBLE REAL INTERMEDIATE STORE
%IF REG=ESTK %START; ! DOUBLE INTEGER IN ESTK
STORE LOW AD END(ESTK,RLEVEL,DISP)
PI(EXCH); ! STORE NON DESTRUCTIVE)
STORE HIGH AD END(ESTK,RLEVEL,DISP)
%FINISHELSESTART
DFETCHAD(NO,SIZE,RLEVEL,DISP)
PI1(RDASSD,REG-FR0)
%FINISH
%END
%ROUTINE DPTRFETCH(%INTEGER REG,SIZE,RLEVEL,DISP)
!***********************************************************************
!* FETCHES SIZE(BYTES) VIA PTR AT DISP IN DISPLAY *
!***********************************************************************
%INTEGER LEVELCODE
->GENERAL %UNLESS SIZE=4 %AND REG=ESTK
! SIZE =2 SIGN EXTENDS!
%IF RLEVEL=0 %THEN LEVELCODE=0 %ELSEIF RLEVEL=CURRINF_RBASE %THEN LEVELCODE=1 %ELSE %C
LEVELCODE=2
->GENERAL %IF LEVELCODE=2
%IF LEVELCODE#0 %THEN PI1(LLO,CURRINF_DISPLAY-(DISP+4)) %ELSE PFIXI(LGPO,2,DISP)
%RETURN
GENERAL: ! LONG WAY FOR DIFFICULT CASES
DFETCH(ESTK,4,RLEVEL,DISP)
INDLOAD(REG,SIZE)
%END
%ROUTINE DFETCHAD(%INTEGER BA,SIZE,RLEVEL,DISP)
!***********************************************************************
!* FETCH ADDRESS OF DISP(BYTES) IN DISPLAY 'LEVEL' *
!* WORD ADDRESS FETCHED UNLESS BA=YES WHEN BYTE ADDR FETCHED *
!* SIZE IS NEED BECAUSE OF WRONG END LOW ADDRESS FOR STACKS *
!***********************************************************************
%INTEGER I,WDISP,REG
%RECORD (LEVELF) %NAME INF
%IF RLEVEL=0 %START; ! GLOBAL ADDRESS NORMAL
%IF BA=YES %THEN PFIXI(LGAB,2,DISP!!1) %ANDRETURN
PFIXI(LGA,2,DISP)
%FINISHELSEIF RLEVEL=CURRINF_RBASE %START; ! CURRENT LOCAL LEVEL
WDISP=(DISP+SIZE+1)&(-2)-CURRINF_DISPLAY
PI1(LAS,-WDISP)
%FINISHELSESTART; ! INTERMEDIATE LEVEL
INF==WORKA_LEVELINF(RLEVTOLEVEL(RLEVEL))
WDISP=(DISP+SIZE+1)&(-2)-INF_DISPLAY
REG=SET LEVELREG(-1,RLEVEL)
PI1(LROA0+REG-BR0,-WDISP)
%FINISH
%IF BA=YES %START; ! CONVERT TO BYTE FORM
PI(CVBA)
%IF DISP&1=0 %THEN PLOADCONST(1) %AND PI(IADD)
%FINISH
%END
%ROUTINE DFETCH(%INTEGER REG,SIZE,RLEVEL,DISP)
!***********************************************************************
!* FETCH SIZE(BYTES) FROM DISP(BYTES) IN DISPLAY 'LEVEL' *
!***********************************************************************
%INTEGER LEVELCODE,BREG
%RECORD (LEVELF) %NAME INF
%SWITCH SW(0:24)
IMPABORT %UNLESS REG=ESTK %OR SIZE=4 %OR (SIZE=8 %AND FR0<=REG<=FR3)
%IF SIZE=4 %AND FR0<=REG<=FR3 %START
DFETCHAD(NO,4,RLEVEL,DISP)
PI1(RSLDIS,REG-FR0)
%RETURN
%FINISH
%IF RLEVEL=0 %THEN LEVELCODE=0 %ELSEIF RLEVEL=CURRINF_RBASE %THEN LEVELCODE=1 %ELSE %C
LEVELCODE=2
->SW(8*LEVELCODE+SIZE)
SW(*): ! FUNNY SIZES
IMPABORT
SW(1): ! GLOBAL BYTE FETCH
SW(9): ! LOCAL BYTE FETCH
SW(17): ! INTERMEDIATE BYTE FETCH
DFETCHAD(YES,SIZE,RLEVEL,DISP); ! SIMPLE WAY FOR NOW
PI(LBI)
%RETURN
SW(2): ! GLOBAL HALF FETCH
SW(10): ! LOCAL HALF FETCH
SW(18): ! INTERMEDIATE HALF FETCH
DFETCHAD(NO,SIZE,RLEVEL,DISP)
PI(LHUI)
%RETURN
SW(4): ! GLOBAL WORD FETCH
PFIXI(LGI,2,DISP); ! FIXED INSTRN NEEDED
->WAYOUT
SW(12): ! LOCAL WORD FETCH
PI1(ILL,CURRINF_DISPLAY-(DISP+4))
->WAYOUT
SW(20): ! INTERMEDIATE WORD FETCH
INF==WORKA_LEVELINF(RLEVTOLEVEL(RLEVEL))
BREG=SET LEVELREG(-1,RLEVEL)
PI1(LRO0-BR0+BREG,INF_DISPLAY-(DISP+4))
->WAYOUT
SW(8): ! DOUBLE REAL GLOBAL FETCH
SW(16): ! DOUBLE REAL LOCAL FETCH
SW(24): ! DOUBLE REAL INTERMEDIATE FETCH
%IF REG=ESTK %START; ! DOUBLE INTEGER IN ESTK
FETCH HIGH AD END(ESTK,RLEVEL,DISP)
FETCH LOW AD END(ESTK,RLEVEL,DISP)
%FINISHELSESTART
DFETCHAD(NO,SIZE,RLEVEL,DISP)
PI1(RDLDID,REG-FR0)
%FINISH
%RETURN
WAYOUT:
%IF SIZE=4 %AND BR0<=REG<=BR3 %THEN PI(SR0-BR0+REG)
%END
%ROUTINE FETCH HIGH AD END(%INTEGER REG,B,D)
!***********************************************************************
!* FETCHES THE HIGH END OF ARRAYHEAD(IE @A(FIRST)) OR STRINGNAME *
!***********************************************************************
%IF B=0 %THEN D=D+4
DFETCH(REG,4,B,D)
%END
%ROUTINE FETCH LOW AD END(%INTEGER REG,B,D)
!***********************************************************************
!* FETCHES LOW END OF ARRAYHD(IE DV PTR) OR STRINGHEAD(IE ACC) *
!***********************************************************************
%IF B#0 %THEN D=D+4
DFETCH(REG,4,B,D)
%END
%ROUTINE STORE HIGH AD END(%INTEGER REG,B,D)
!***********************************************************************
!* STORES THE HIGH END OF ARRAYHEAD(IE @A(FIRST)) OR STRINGNAME *
!***********************************************************************
%IF B=0 %THEN D=D+4
DSTORE(REG,4,B,D)
%END
%ROUTINE STORE LOW AD END(%INTEGER REG,B,D)
!***********************************************************************
!* STORES LOW END OF ARRAYHD(IE DV PTR) OR STRINGHEAD(IE ACC) *
!***********************************************************************
%IF B#0 %THEN D=D+4
DSTORE(REG,4,B,D)
%END
%INTEGERFN JCODE(%INTEGER TFMASK)
!***********************************************************************
!* PRODUCES JUMP CODE FROM IBM TYPE BRANCH MASK AND EXTRA BITS *
!***********************************************************************
%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!
%RESULT=FCOMP(32+16*BFFLAG+TFMASK&15)
%FINISH
%IF TFMASK&128#0 %THENRESULT=JFALSE
%RESULT=JTRUE
%END
%INTEGERFN FINDREG(%INTEGER MASK)
!***********************************************************************
!* FINDS A FREE REGISTER FROM RANGE DEFINED BY MASK *
!***********************************************************************
%INTEGER I,L,U,USED,LASTUSED,LASTREG
%RECORD (REGF) %NAME REG
L=MASK>>16
U=MASK&255
%FOR I=L,1,U %CYCLE
REG==REGS(I)
%RESULT=I %IF REG_CL=0 %AND REG_USE=0
%REPEAT
!
! IN NEXT CYCLE LOOK FOR TEMPORAY THAT WILL NOT BE USED FOR THE
! LARGEST FUTURE TIME MEASURED BY NO OF TRIPLES
! NB NOT 100% PERFECT AS SHUFFLES CAN OCCUR IN OPTIMISING)
!
LASTUSED=WTRIPNO
LASTREG=-1
%FOR I=L,1,U %CYCLE
REG==REGS(I)
%RESULT=I %IF REG_CL=0
%IF REG_AT#WTRIPNO %START; ! NOT USED IN THIS OPERATION
USED=TRIPLES(REG_AT)_PUSE
%IF USED>LASTUSED %THEN LASTUSED=USED %AND LASTREG=I
%FINISH
%REPEAT
%IF LASTREG>0 %THEN BOOT OUT(LASTREG) %ANDRESULT=LASTREG
IMPABORT
%END
%ROUTINE CONSTEXP(%INTEGER PTYPE,REG,VALUE)
!***********************************************************************
!* EXPONENTIATION TO A KNOWN POWER *
!* VALUE = 2 UPWARDS. VALUE=1 HAS BEEN OPTIMISED OUT *
!***********************************************************************
%INTEGER WREG,I,MULTS,MULT,PUSH,POP
MULTS=0; I=VALUE
%IF PTYPE&7=1 %THEN ->INTEXP
REG=REG-FR0
%IF PTYPE>>4&7=6 %START
MULT=RDMULT; PUSH=RDPUSHD; POP=RDPOPD
%FINISHELSESTART
MULT=RSMULT; PUSH=RSPUSHS; POP=RSPOPS
%FINISH
%WHILE I>1 %CYCLE
%IF I&1#0 %START
PI1(PUSH,REG)
MULTS=MULTS+1
%FINISH
PI2(MULT,REG,REG)
I=I>>1
%REPEAT
%IF MULTS=0 %THENRETURN; ! **2,**4 ETC
WREG=FINDREG(FRN)
FORGET(WREG)
WREG=WREG-FR0
%WHILE MULTS>0 %CYCLE
MULTS=MULTS-1
PI1(POP,WREG)
PI2(MULT,REG,WREG)
%REPEAT
%RETURN
INTEXP:
%WHILE I>1 %CYCLE
%IF I&1#0 %START; ! PRESERVE THIS POWER FOR LATER
PI(DUPL)
PI(IPUSH) %UNLESS MULTS=0; ! USE ONLY 3 ESTACK CELLS
MULTS=MULTS+1
%FINISH
P2I(DUPL,IMULT)
I=I>>1
%REPEAT
%WHILE MULTS>0 %CYCLE
MULTS=MULTS-1
PI(IPOP) %UNLESS MULTS=0
PI(IMULT)
%REPEAT
%END
%ROUTINE CIOCP(%INTEGER N)
!***********************************************************************
!* COMPILES A CALL ON IOCP ENTRY POINT NO 'N' *
!* 2ND PARAMETER IS ALREADY IN ETOS *
!***********************************************************************
%CONSTINTEGER NEEDS RES=X'20016'; ! FLAGS EPS 1,2,4&18
%INTEGER C
C=(CURRT_DPTH+1)>>1
SAVE IRS
PI(ALIGN) %IF FPPTR&7#0
PI1(ESAVE,C) %UNLESS C=0
%IF PARAMS BWARDS=YES %THENSTART
PI(IPUSH)
PLOADCONST(N)
%FINISHELSESTART
PLOADCONST(N)
PI(IPUSH)
%FINISH
PI(IPUSH)
PI1(CALL,KNOWN XREF(4))
PI1(ASFW,8); ! REMOVE PARAMETERS
%IF C#0 %THENSTART
PI1(ERES,C)
%IF 1<<N&NEEDS RES#0 %THEN PI(EXCH)
PI(DISCARD)
%FINISH
! ERES RESTORES FIRST PARAM (UGH)
! NEED TO DISCARD IT
%IF FPPTR&7#0 %THEN PI1(ASFW,4)
%END
%END; ! OF ROUTINE GENERATE
%ENDOFFILE