%INCLUDE "ERCC07.TRIMP_HOSTCODES"
%CONSTINTEGER HOST=EMAS
%CONSTINTEGER TARGET=AMDAHL
%CONSTINTEGER FOURKTDISP=0
%INCLUDE "ERCC10.OPOUTS"
!
%CONSTINTEGER LGR=X'58',AND=X'54',ICP=X'59'; ! VARIANT MNEMONICS
%IF TARGET=IBM %THEN %START
%OWNINTEGER BALCODE=BAL
%FINISH %ELSE %START
%OWNINTEGER BALCODE=BAS
%FINISH
%CONSTINTEGER MARGIN=512; ! MARGIN FOR ADRESSABILITY
%CONSTINTEGER MAXREG=19; ! FOR DECLARING REGISTER ETC
%CONSTINTEGER CODER=12
%CONSTINTEGER WSPR =11
%CONSTINTEGER GLAREG =13
%CONSTINTEGER LINKREG=15; ! REGISTER FOR RETURN ADDRESS
%CONSTINTEGER EPREG=14; ! REGISTER HOLDING RT ENTRYPOINT
%CONSTINTEGER CTABLEREG=14; ! REGISTER HOLDING CONSTANT TABLE
%CONSTINTEGER GR0=X'000F0000'; ! ANY GR FROM 0-15
%CONSTINTEGER GR1=X'0001000F'; ! ANY GR BAR GR0
%CONSTINTEGER FR0=X'00100013'; ! ANY FR
%CONSTINTEGER GRSAFE=X'00040009'; ! ANY GR SAFE AGAINT RT CALL
%CONSTINTEGER GRPAIR=X'01000008'
%CONSTINTEGER FRPAIR=X'01100012'
%CONSTINTEGER GRSEQ=X'81000008'
%CONSTINTEGER GRQUAD=X'83000006'
%CONSTINTEGER ANYGR=-1,ANYGRBAR0=-2,ANYFR=-3,ANYSAFEGR=-4,
ANYGRPAIR=-5,ANYFRPAIR=-6,ANY2SEQ=-7,ANY4SEQ=-8
%CONSTINTEGERARRAY NEGREG(-8:-1)=GRQUAD,GRSEQ,FRPAIR,GRPAIR,GRSAFE,FR0,GR1,GR0;
!
! PARAMETERISE THE REGISTER USESES
!
%CONSTINTEGER IRESULT=1,TEMPBASE=2,RTPARAM=3,NAMEBASE=4,LITCONST=5,
TABCONST=6,ADDROF=7,BASEOF=8,LOCALVAR=9,LOCALTEMP=10,
FOURKMULT=11,LABFOURK=12,BASEREG=13,PERMFOURK=14,DVBASE=15,
STRWKAREA=16
%CONSTBYTEINTEGERARRAY REGWORDS(0:127)=X'11'(96){PRECS 0-5},
X'11',X'22',X'12',X'11'(13){PREC=6},
X'11',X'44',X'24',X'11'(13){PREC=7};
! ABOVE IS NO OF REGS<<4!NO OF 32 BIT WORS
%CONSTBYTEINTEGERARRAY REGCODE(0:MAXREG)= 0,1,2,3,4,5,6,7,8,9,
10,11,12,13,14,15,0,2,4,6;
%CONSTBYTEINTEGERARRAY DISPREG(-1:8)=WSPR,GLAREG,10,9,8,7,6,5,4,3;
%CONSTBYTEINTEGERARRAY GRMAP(0:14)=0,1,2,3,15,16,17,18,19,
4,5,6,7,8,9;
%CONSTBYTEINTEGERARRAY LDCODE(0:15)=IC(4),LH,LGR,LM,LM,0(5),LE,LD,LD;
%CONSTBYTEINTEGERARRAY STCODE(0:15)=STC(4),STH,ST,STM,STM,0(5),STE,STD,STD;
%CONSTBYTEINTEGERARRAY WHICHREG(0:15)=0(3),-ANYGR(3),-ANYGRPAIR,-ANY4SEQ,
0(5),-ANYFR(2),-ANYFRPAIR
!
%INCLUDE "ERCC07.TRIPCNSTS"
%INCLUDE "ERCC07.TRIMP_TFORM1S"
%INCLUDE "ERCS12.XAOPT_SPECS"
%IF HOST=EMAS %START
%RECORDFORMAT REGF(%INTEGER CL,CNT,AT,(%INTEGER USE %OR %HALF SECUSE,PRIMUSE),
%INTEGER INF1,INF2,LINK)
%ELSE
%RECORDFORMAT REGF(%INTEGER CL,CNT,AT,(%INTEGER USE %OR %SHORT SECUSE,PRIMUSE),
%INTEGER INF1,INF2,LINK)
%FINISH
%OWNINTEGER CONSTHOLE,PROFDATA,
OLDLINE,HALFHOLE
%OWNINTEGERNAME CA,GLACA
%OWNINTEGER FPPTR=0,FPHEAD=0,LASTPARREG=0
%OWNINTEGER MAX4KMULT=0,GLABEL=X'7FFF',UNASSOFFSET=0,SWITEMSIZE=0
%OWNINTEGER USINGR=12,USINGAT=0; ! REMEMBERS ASSEMBLER USINGS
%OWNRECORD(LISTF)%ARRAYNAME ASLIST
%OWNINTEGERARRAY COFFSET(0:31)
%OWNINTEGERARRAYNAME CTABLE
%OWNINTEGERARRAYNAME TAGS
%EXTRINSICINTEGERARRAY CAS(0:10)
%EXTRINSICRECORD(WORKAF)WORKA
%EXTRINSICRECORD(PARMF) PARM
%OWNRECORD(REGF)%ARRAY REGS(0:MAXREG)
%CONSTINTEGER MAXKXREF=5
%OWNINTEGERARRAY KXREFS(0:MAXKXREF)
%CONSTSTRING(11)%ARRAY KXREFNAME(0:MAXKXREF)="S#STOP","S#NDIAG",
"S#ILOG","S#IEXP","S#IOCP",
"ICL9CEAUXST";
%CONSTINTEGERARRAY KXREFPWORD(0:MAXKXREF)=0,X'00040010',
X'00010008'(2),X'00020008',
-1(*);
%%EXTERNALSTRING(255)%FNSPEC PRINTNAME(%INTEGER N)
%EXTERNALROUTINESPEC FLAGAND FOLD(%RECORD(TRIPF)%ARRAYNAME T)
%IF HOST=IBM %OR HOST=IBMXA %OR HOST=AMDAHL %START
%EXTERNALINTEGERMAPSPEC COMREG %ALIAS "S#COMREGMAP"(%INTEGER N)
%ELSE
%EXTERNALINTEGERMAPSPEC COMREG %ALIAS "S#COMREG" (%INTEGER N)
%FINISH
%EXTERNALSTRING(255)%FNSPEC UCSTRING(%STRING(255) S)
%EXTERNALROUTINESPEC FAULT(%INTEGER I,J,K)
%ROUTINESPEC PRINT USE
%EXTERNALROUTINESPEC PUSH(%INTEGERNAME CELL,%INTEGER S1,S2,S3)
%ROUTINESPEC STORECONST(%INTEGERNAME D,%INTEGER L,AD)
%INTEGERFNSPEC WORD CONST(%INTEGER VAL)
%EXTERNALROUTINESPEC POP(%INTEGERNAME A,B,C,D)
!%EXTERNALROUTINESPEC PRINTLIST(%INTEGER HEAD)
%EXTERNALROUTINESPEC PRHEX(%INTEGER VALUE,PLACES)
%EXTERNALROUTINESPEC PRINTTHISTRIP(%RECORD(TRIPF)%ARRAYNAME T,
%INTEGER I)
%EXTERNALROUTINESPEC PRINT TRIPS(%RECORD(TRIPF)%ARRAYNAME T)
%ROUTINESPEC RELOCATE(%INTEGER GLARAD,VALUE,AREA)
%CONSTINTEGER USE IMP=NO
%CONSTINTEGER UNASSPAT=X'80808080'
%CONSTBYTEINTEGERARRAY BYTES(0:7)=0(3),1,2,4,8,16;
%CONSTBYTEINTEGERARRAY WORDS(0:7)=0(3),1,1,1,2,4;
%CONSTBYTEINTEGERARRAY BYTESTOPT(0:16)=0,X'31',X'41',X'57',X'51',
X'57'(3),X'62',X'57'(7),X'72';
%CONSTINTEGER DAREA=4; ! AREA FOR DIAG TABLES
%CONSTINTEGER CAREA=10; ! CONSTANTS AT BACK OF CODE
!
! FIXED GLA CURRENTLY USED AS FOLLOWS
! 0-3 FREE(WAS 2900 ENTRY DESCRIPTOR)
! 4-7 ADDRESS OF HEAD OF CODE
! 8-11 ADDRESS OF UNSHARED SYMBOL TABLES
! 12-15 ADDRESS OF SHARED SYMBOL TABLES
! 16-19 LANGUAGE & COMPILER DATA
! 20-23 ADDRESS OF DIAGS TABLES
! 24-27 ADDRESS OF CONSTANT TABL
! 28-31 ADDRESS OF A WORD CONTAINING STACKTOP 0FOR NO CHECKS
! 32-35 HOLDS M'IDIA' FOR DIAGNOSTIC IDENTIFICATION
! 36-39 FREE
!
%CONSTINTEGER FIXEDGLALEN=56
%OWNINTEGERARRAY FIXED GLA(0:FIXEDGLALEN>>2-1)=M'IMPG',0,
0(6),M'IDIA',0(*);
!
%ROUTINE CPINIT
!***********************************************************************
!* PERFORMS ANY NECESSARY TARGET DEPENDANT INITIALISING *
!***********************************************************************
%INTEGER I
%STRING(63)HD
TAGS==WORKA_TAGS
FPPTR=0; FPHEAD=0
GLABEL=X'7FFF'; ! RESET FOR WHEN COMPILER NOT RELOADED
HD=" ERCC IBMImp80 Compiler Release ".TOSTRING(WORKA_RELEASE+'0'). %C
" Version ".WORKA_LADATE
PINITIALISE(-1{STRING},WORKA_RELEASE,ADDR(HD));! OPEN OBJECT FILE
%IF HOST=EMAS %AND PARM_BITS1&1{QUOTES}#0 %THEN BALCODE=BAL
%END
%EXTERNALROUTINE CODEOUT
%IF PARM_DCOMP#0 %THEN %START
PRINTSTRING("
CODE FOR LINE")
WRITE(WORKA_LINE,3)
NEWLINE
PLINEDECODE
PRINT USE
NEWLINE
%FINISH
%END
%ROUTINE PMVC(%INTEGER L,B1,D1,B2,D2)
!***********************************************************************
!* PLANTS AN MVC INSTRN. IN OPTIMISING MODE TRIES TO GLUE IT *
!* ON TO THE LAST ONE PLANTED *
!***********************************************************************
PIX SS(MVC,0,L,B1,D1,B2,D2)
%END
%INTEGERFN LONG CONST(%LONGINTEGER VALUE)
!***********************************************************************
!* SIMPLE INTERFACE TO STORE DESCRIPTOR CONSTANT *
!***********************************************************************
%INTEGER K
STORE CONST(K,8,ADDR(VALUE))
%RESULT=K
%END
%INTEGERFN WORD CONST(%INTEGER VALUE)
!***********************************************************************
!* SIMPLE INTERFACE TO STORE CONST FOR 32 BIT CONSTS *
!***********************************************************************
%INTEGER K
STORE CONST(K,4,ADDR(VALUE))
%RESULT=K
%END
%INTEGERFN SHORT CONST(%INTEGER VALUE)
!***********************************************************************
!* STORE A 16 BIT CONSTANT VIA STORE CONST *
!***********************************************************************
%INTEGER K
STORE CONST(K,2,ADDR(VALUE)+2)
%RESULT=K
%END
%ROUTINE STORE CONST(%INTEGERNAME D, %INTEGER L, AD)
!***********************************************************************
!* PUT THE CONSTANT VAL OF LENGTH 'L' 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 I, J, K, C1, C2, C3, C4, LP
%INTEGERNAME CONST PTR
CONST PTR==WORKA_CONST PTR
LP=L//4; C1=0; C2=0; C3=0; C4=0
%CYCLE I=0,1,L-1
BYTEINTEGER(ADDR(C1)+I)=BYTEINTEGER(AD+I)
%REPEAT
K=WORKA_CONST BTM; ! AFTER STRINGS IN CTABLE
%IF L=2 %START
J=HALF HOLE
%IF J=0 %THEN J=CONST PTR
%FOR K=K,1,J-1 %CYCLE
%IF C1=CTABLE(K)&X'FFFF0000' %THEN D=4*K %AND %RETURN
%IF C1=CTABLE(K)<<16 %THEN D=4*K+2 %AND %RETURN
%REPEAT
%FINISH %ELSE %IF L=4 %THEN %START
J=CONST PTR
! %IF USE IMP=YES %THEN %START
%FOR K=K,1,J-1 %CYCLE
%IF CTABLE(K)=C1 %AND CONSTHOLE#K %C
%THEN D=4*K %AND %RETURN
%REPEAT
! %FINISH %ELSE %START
! %FINISH
%FINISH %ELSE %IF L=6 %START
%FOR K=K,1,CONST PTR-2 %CYCLE
%IF CTABLE(K)=C1 %AND CTABLE(K+1)&X'FFFF0000'=C2 %C
%THEN D=4*K %AND %RETURN
%IF CTABLE(K)<<16=C1&X'FFFF0000' %AND C1&X'FFFF' %C
=CTABLE(K)>>16 %AND CTABLE(K+1)>>16=C2 %THEN %C
D=4*K+2 %AND %RETURN
%REPEAT
%FINISH %ELSE %START
J=CONSTPTR-LP
%WHILE K<=J %CYCLE
%IF CTABLE(K)=C1 %AND CTABLE(K+1)=C2 %AND %C
(CONSTHOLE<K %OR CONSTHOLE>=K+LP) %START
%IF L=8 %OR (CTABLE(K+2)=C3 %C
%AND CTABLE(K+3)=C4) %THEN D=4*K %C
%AND %RETURN
%FINISH
K=K+2
%REPEAT
%FINISH
%IF L=2 %START
%IF HALFHOLE#0 %THEN %START
CTABLE(HALFHOLE)=CTABLE(HALFHOLE)!(C1>>16)
D=4*HALFHOLE+2
HALFHOLE=0
%RETURN
%FINISH
%IF CONSTHOLE#0 %START
CTABLE(CONSTHOLE)=C1
HALFHOLE=CONSTHOLE
CONSTHOLE=0
D=4*HALFHOLE
%RETURN
%FINISH
CTABLE(CONST PTR)=C1
HALFHOLE=CONST PTR
D=4*HALFHOLE
CONST PTR=CONST PTR+1
%RETURN
%FINISH
%IF L=4 %AND CONSTHOLE#0 %START
CTABLE(CONSTHOLE)=C1
D=4*CONSTHOLE
CONSTHOLE=0
%RETURN
%FINISH
%IF L=6 %START
%IF 0<HALFHOLE=CONSTHOLE-1 %START
CTABLE(HALFHOLE)=CTABLE(HALFHOLE)!C1>>16
CTABLE(CONSTHOLE)=C1<<16!C2>>16
D=4*HALFHOLE+2
HALFHOLE=0; CONSTHOLE=0
%RETURN
%FINISH
%IF 0<HALFHOLE=CONST PTR-1 %START
CTABLE(HALFHOLE)=CTABLE(HALFHOLE)!C1>>16
CTABLE(CONSTPTR)=C1<<16!C2>>16
D=4*HALFHOLE+2
HALFHOLE=0
CONST PTR=CONST PTR+1
%RETURN
%FINISH
CTABLE(CONST PTR)=C1
CTABLE(CONST PTR+1)=C2
HALFHOLE=CONST PTR+1
D=4*CONST PTR
CONST PTR =CONST PTR+2
%RETURN
%FINISH
%IF L>4 %AND CONST PTR&1#0 %C
%THEN CONSTHOLE=CONST PTR %AND CONSTPTR=CONST PTR+1
D=4*CONST PTR
CTABLE(CONSTPTR)=C1
CTABLE(CONSTPTR+1)=C2
%IF L=16 %THEN CTABLE(CONSTPTR+2)=C3 %C
%AND CTABLE(CONSTPTR+3)=C4
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,L
%INTEGERNAME CONST PTR
CONST PTR==WORKA_CONST PTR
K=WORKA_CONST BTM
L=LENGTH(S)
LP=1+L//4
%IF L=1 %START
K=256!CHARNO(S,1)
D=SHORT CONST(K)
%RETURN
%FINISH
J=CONSTPTR-LP
%FOR K=1,1,J %CYCLE
%IF S=STRING(ADDR(CTABLE(K))) %THEN D=4*K %ANDRETURN
%REPEAT
%IF L<=3 %AND CONSTHOLE>0 %START
STRING(ADDR(CTABLE(CONSTHOLE)))=S
D=4*CONSTHOLE
CONSTHOLE=0
%RETURN
%FINISH
D=4*CONST PTR
STRING(ADDR(CTABLE(CONSTPTR)))=S
CONST PTR=CONST PTR+LP
%IF CONST PTR>WORKA_CONST LIMIT %THEN FAULT(102,WORKA_WKFILEK,0)
%END
%INTEGERFN KWCONSTS(%INTEGER WHICH)
!***********************************************************************
!* PUTS CERTAIN KNOWN WORD CONSTANTS INTO THE CONSTANT TABLE ON *
!* DEMAND AND REMEMBERS THEIR POSN TO AVOID SEARCHING *
!***********************************************************************
%CONSTINTEGERARRAY SCS(0:4) = X'80000000',255,
X'FFFFFFFF',1,
X'41100000';
%INTEGER K
K=COFFSET(WHICH)
%RESULT=K %UNLESS K=0
STORE CONST(K,4,ADDR(SCS(WHICH)))
COFFSET(WHICH)=K
%RESULT=K
%END
%INTEGERFN KLCONSTS(%INTEGER WHICH)
!***********************************************************************
!* PUTS CERTAIN KNOWN LONG CONSTANTS INTO THE CONSTANT TABLE ON *
!* DEMAND AND REMEMBERS THEIR POSN TO AVOID SEARCHING *
!***********************************************************************
%CONSTINTEGERARRAY SCS(0:19) =%C
0, 0,
X'4E000000', 0,
X'4E000001', 0,
X'4E000000', -1,
X'50800000', 0,
X'51880000', 0,
X'5C000000', X'80',
X'41100000', 0,
X'4E000000', X'80000000',
X'43000000',8;
%INTEGER K
K=COFFSET(WHICH+16)
%RESULT=K %UNLESS K=0
STORE CONST(K,8,ADDR(SCS(2*WHICH)))
COFFSET(WHICH+16)=K
%RESULT=K
%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
%CONTINUE %IF 10<=I<=14; ! SKIP FIXED USE REGS
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' *
!* RATHER NOTTED ON IBM AS ONE CANNOT RESTORE A DROPPED REG *
!***********************************************************************
%INTEGER I, R, USE, INF, AT, DROPMASK
%RECORD(REGF)%NAME REG
DROPMASK=0
%CYCLE I=0, 1, MAXREG
REG==REGS(I)
%IF REG_CL>=0 %THEN %START
%IF REG_USE=BASEREG %THEN DROPMASK=DROPMASK!(1<<I) %ELSE REG_USE=0
%FINISH
%REPEAT
%WHILE HEAD#0 %CYCLE
POP(HEAD, INF, AT, I)
R=I>>8; USE=I&255
REG==REGS(R)
%IF REG_CL>=0 %START
%IF USE#BASEREG %THEN REG_USE=USE %AND REG_INF1=INF %ELSE %START
%IF REG_USE=BASEREG %AND INF=REG_INF1 %THEN %C
DROPMASK=DROPMASK&(\(1<<R))
%FINISH
%FINISH
REG_AT=AT
%REPEAT
%IF DROPMASK#0 %START
%FOR I=0,1,MAXREG %CYCLE
%IF 1<<I&DROPMASK#0 %THEN PDROP(I) %AND REGS(I)_USE=0
%REPEAT
%FINISH
%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 %C
(REG_SECUSE=U %AND REG_INF2=LCELL_S1) %START
HEAD==LCELL_LINK
%IF REG_AT>LCELL_S2 %THEN LCELL_S2=REG_AT
! TAKE MOST RECENT VERSION OF AT
%FINISH %ELSE POP(HEAD,S1,S2,S3)
%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)
%RETURN %IF PARM_INHCODE#0
PDBYTES(AREA,PTR,L,AD)
PTR=PTR+L
%END
%EXTERNALROUTINE PRDATA(%INTEGER AREA,BNDRY,L,REP,AD)
!***********************************************************************
!* ADDS L(BYTES) REP TIMES TO AREA FOR UST,SST AND DIAGS AREAS *
!***********************************************************************
%INTEGERNAME PTR
PTR==CAS(AREA)
PTR=(PTR+BNDRY-1)&(-BNDRY)
%RETURN %IF PARM_INHCODE#0
PDPATTERN(AREA,PTR,REP,L,AD)
PTR=PTR+REP*L
%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 %THEN %START
KK=CAS(DAREA)
PSETOPD(JJ,0,MVI<<8!((KK>>8)&255))
PSETOPD(JJ,2,MVI<<8!(KK&255))
%FINISH %ELSE %START
PD4(Q,JJ,KK!CAS(DAREA))
%FINISH
%REPEAT
%END
%EXTERNALINTEGERFN PINITOWN(%INTEGER PTYPE,ACC,%RECORD(RD)%NAME INIT,
%STRINGNAME YNAME)
!***********************************************************************
!* PUTS AN INITIALISED OWN INTO THE GLA. SHOULD DEAL WITH ALL TYPES *
!***********************************************************************
%RECORD(RD)OPND
%INTEGER PREC,TYPE,RL,RES,X,LITL
%STRING(255)XNAME
XNAME=UCSTRING(YNAME)
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 %THEN PD4(2,GLACA,ACC) %AND GLACA=GLACA+4
PD4(2,GLACA,OPND_D)
GLACA=GLACA+4
%IF LITL=3 %START; ! EXTRINSICS ARE NAMES
PDXREF(ACC,2,GLACA-4,XNAME);! RELOCATE BY EXTERNAL
%FINISH
->END
%FINISH
RL=BYTES(PREC)
%IF TYPE=5 %THEN RL=4
%IF TYPE=3 %THEN RL=8
%IF RL>8 %THEN RL=8
GLACA=(GLACA+RL-1)&(-RL); ! ROUND TO RL
RES=GLACA;
%IF TYPE=3 %OR (TYPE=5 %AND OPND_D=0) %START
PDPATTERN(2,RES,ACC,1,ADDR(OPND_D)+3)
GLACA=GLACA+ACC
->END
%FINISH
%IF TYPE=5 %THEN %START
PDBYTES(2,GLACA,ACC,ADDR(WORKA_A(OPND_D)))
GLACA=GLACA+ACC
%FINISH %ELSE %START
%IF PREC=3 %THEN PDBYTES(2,GLACA,1,ADDR(OPND_D)+3)
%IF PREC=4 %THEN PDBYTES(2,GLACA,2,ADDR(OPND_D)+2)
%IF 5<=PREC<=6 %THEN PD4(2,GLACA,OPND_D)
%IF PREC=6 %THEN PD4(2,GLACA+4,OPND_XTRA)
%IF PREC=7 %THEN PDBYTES(2,GLACA,16,ADDR(WORKA_A(OPND_D)))
GLACA=GLACA+BYTES(PREC)
%FINISH
END: ! NOTE ENTRYT IF EXTERNAL
%IF LITL=2 %THEN PDATAENTRY(XNAME,2,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 *
!***********************************************************************
%INTEGER LITL,RES,AHW0,AHW1,AHW2,AHW3,PREC,TYPE
XNAME=UCSTRING(XNAME)
TYPE=PTYPE&7
PREC=PTYPE>>4&15
AHW0=AOFFSET-LB*CTABLE(DVOFFSET>>2+2)
AHW1=AOFFSET
AHW2=DVOFFSET
AHW3=CTABLE(DVOFFSET>>2+2+3*J);! THE RELEVANE STRIDE
GLACA=(GLACA+3)&(-4)
PDBYTES(2,GLACA,16,ADDR(AHW0))
RES=GLACA
GLACA=GLACA+16
LITL=PTYPE>>14&3
%IF LITL=3 %START; ! EXTRINSIC ARRAYS
PDXREF(SIZE,2,RES,XNAME)
PDXREF(SIZE,2,RES+4,XNAME); ! RELOCATE BY EXTERNAL
%FINISH %ELSE %START
%IF AAREA#0 %THEN RELOCATE(RES,AHW0,AAREA) %AND %C
RELOCATE(RES+4,AHW1,AAREA)
%FINISH
RELOCATE(RES+8,AHW2,CAREA); ! RELOCATE DV PTR
%IF LITL=2 %THEN PDATAENTRY(XNAME,AAREA,SIZE,AOFFSET)
%RESULT=RES
%END
%ROUTINE GXREF(%STRING(31) NAME,%INTEGER MODE,XTRA,AT)
!***********************************************************************
!* ASK IPUT TO ARRANGE FOR A TRIPLE WORD AT 'AT' IN THE GLA *
!* TO CONTAIN A DESCRIPTOR FOR NAME 'NAME'. *
!* MODE=0 "DONT CARE" XREF *
!* MODE=1 SYSTEM CODE XREF *
!* MODE=2 EXTERNAL CODE XREF *
!* MODE=3 DYNAMIC CODE XREF *
!* FOR MODES 0-3 XTRA IS PARAMETER CHECKING WORD *
!***********************************************************************
NAME=UCSTRING(NAME)
AT=PXNAME(MODE//3{1 FOR DYNAMIC ELSE 0},NAME,AT)
%END
%EXTERNALROUTINE CXREF(%STRING(255) NAME,
%INTEGER MODE,XTRA,%INTEGERNAME AT)
!***********************************************************************
!* CREATE A ZEROED AREA IN THE GLA AND CALL GXREF TO GET *
!* IT FILLED AT LOAD TIME WITH INFORMATION ON AN EXTERNAL OBJECT *
!* PARAMETERS ARE AS FOR GXREF. *
!***********************************************************************
%INTEGER Z1,Z2,Z3,Z4
Z1=0; Z2=0; Z3=0; Z4=XTRA
GLACA=(GLACA+3)&(-4)
PDBYTES(2,GLACA,16,ADDR(Z1)); ! 3 ZERO WORDS+PARAMETER WORD
AT=GLACA
GLACA=GLACA+16
GXREF(NAME,MODE,XTRA,AT)
%END
%INTEGERFN KNOWN XREF(%INTEGER N)
%INTEGER D
%RESULT= KXREFS(N) %UNLESS KXREFS(N)=0
CXREF(KXREFNAME(N),0,KXREFPWORD(N),D)
KXREFS(N)=D
%RESULT=D
%END
%ROUTINE CALL STOP
!***********************************************************************
!* CALLS STOP ROUTINE. NOT VIA EPILOGUE ON PERQ *
!************************************************************************
PIX RS(STM,4,14,WSPR,16)
PIX RS(LM,12,14,GLAREG,KNOWNXREF(0))
PIX RR(BALCODE-X'40',15,14)
%END
%EXTERNALROUTINE RELOCATE(%INTEGER GLARAD,VALUE,AREA)
!***********************************************************************
!* PLANTS A WORD IN THE GLA (IF GLARAD<0) AND ARRANGES TO *
!* RELOCATE IT RELATIVE TO AN AREA(CODE=1,GLA=2,CST=4,GST=5,CNTS=6) *
!***********************************************************************
PFIX(2,GLARAD,AREA,VALUE)
%END
%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)="GR0","GR1","GR2","GR3",
"GR4","GR5","GR6","GR7",
"GR8","GR9","GRA","GRB",
"GRC","GRD","GRE","GRF",
"FR0","FR2","FR4","FR6";
%CONSTSTRING(15)%ARRAY USES(0:16) =" NOT KNOWN "," I-RESULT ",
" TEMPORARY "," RTPARAM ",
" NAMEBASE "," LIT CONST ",
" TAB CONST "," ADDR OF ",
" BASE OF "," LOCAL VAR ",
" LOCALTEMP "," 4K MULT ",
" 4K FORLAB "," BASE REG ",
" 4K FOR EPI"," DV BASE ",
" STRWKAREA ";
%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
%CYCLE I=0,1,MAXREG
REG==REGS(I)
%IF REG_CL<0 %AND 10<=I<=14 %THEN %CONTINUE
%IF REG_CL!REG_USE#0 %OR REG_CNT>0 %START
USE=REG_USE
PRINTSTRING(REGNAMES(I).STATE(REG_CL))
WRITE(REG_CNT,1)
WRITE(REG_AT,2)
OUT(USE&255,REG_INF1)
%IF USE>>16#0 %THEN PRINTSTRING(" ALSO ") %C
%AND OUT(USE>>16,REG_INF2)
NEWLINE
%FINISH
%REPEAT
%RETURN
%ROUTINE OUT(%INTEGER USE,INF)
%CONSTINTEGER LNMASK=B'1000001110000000'
%CONSTINTEGER UNMASK=B'0000001110000000'
%IF USE&128#0 %THEN PRINTSYMBOL('*') %AND USE=USE&127 %ELSE SPACE
PRINTSTRING("USE = ".USES(USE))
%IF LNMASK&1<<USE#0 %THEN PRINTSTRING(PRINTNAME(INF&X'FFFF')) %C
%ELSE WRITE(INF,1)
%IF UNMASK&1<<USE#0 %AND INF>>16#0 %THEN PRINTSTRING(" MODBY ") %C
%AND PRINTSTRING(PRINTNAME(INF>>16))
%END
%END
%EXTERNALROUTINE IMPABORT
NEWLINE
PLINEDECODE
PRINTSTRING("
**************** IMPABORT ***************** IMPABORT *******")
write(worka_line,5)
newline
PRINT USE
%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
MAX4KMULT=WORKA_ARTOP//4096+3
%IF MAX4KMULT<10 %THEN SWITEMSIZE=2 %ELSE SWITEMSIZE=4
CPINIT; ! INITIALISE CODE PLANTING
ASLIST==ALIST
CA==CAS(1)
GLACA==CAS(2)
CA=0
GLACA=FIXEDGLALEN
HALF HOLE=0; OLD LINE=-1
CONST HOLE=0
CTABLE==WORKA_CTABLE
PD4(DAREA,0,X'C2C2C2C2')
CAS(DAREA)=4
%CYCLE I=0, 1, 31
COFFSET(I)=0
WORKA_PLABS(I)=0; WORKA_PLINK(I)=0
%REPEAT
%CYCLE I=0,1,MAXREG
REGS(I)=0
KXREFS(I)=0 %IF I<=MAXKXREF
%REPEAT
REGS(WSPR)_CL=-1
REGS(CODER)_CL=-1
REGS(GLAREG)_CL=-1
REGS(CTABLEREG)_CL=-1
USINGR=12; USINGAT=0
!
! GENERATE THE TABLE OF 4K MULTIPLES
!
PCODEWORD(4096*I) %FOR I=0,1,MAX4KMULT
!
! GENERATE THE FIXED-FLOAT CONSTANTS THAT MAY BE NEEDED
!
WORKA_CONST PTR=1
WORKA_CONST BTM=0
I=KWCONSTS(3); ! ENSURE F'1' IS IN CINST TABLE FOR EXP
%IF PARM_CHK#0 %START
UNASS OFFSET=8
CTABLE(2)=UNASSPAT
CTABLE(3)=UNASSPAT
WORKA_CONST PTR=4
%FINISH
!
! GENERATE THE RUN TIME ERROR ROUTINE :-
! MDIAGS FOR NR IS %ROUTINE MDIAGS(%INT PC,LNB,ERROR,XTRA)
! PC IS A DUMMY (SEG FIELD ONLY USED) EXCEPT AFTER CONTINGENCY
! ON ENTRY TO THIS SUBROUTINE ERROR & XTRA ARE IN GRS 0&1
! ENTRY HAS BEEN BY BAS LINKREG SO RETURN ADDRESS IS AVAILABLE
!
! ST 15,64(11)
! STM 0,1,72(11)
! LR 0,10
! LR 1,9
! BAS LINKREG,CHECK IF R9 A VALID LNB
! LR 1,8
! BAS LINKREG,CHECK DITTO FOR R8
! LR 1,7
! BAS LINKREG,CHECK DITTO
! LR 1,6
! BAS LINKREG,CHECK DITTO
! LR 1,5
! BAS LINKREG,CHECK DITTO
!CHFAIL ST 0,68(11)
! STM 4,14,16(11)
! LM CODER,EPREG,40(13) MDIAG ENTRY POINT
! L 15,64(11)
! BCR 15,EPREG
!CHECK CR 1,11
! BC 2,CHFAIL
! CR 1,0
! BC 12,CHKAIL
! C 1,44(1) CHECK STORE STACK POINTER
! BC 7,CHFAIL
! LR 0,1
! BCR 15,LINKREG
!
PLABEL(GLABEL)
WORKA_PLABS(2)=GLABEL; GLABEL=GLABEL-1
PIX RX(ST,15,0,11,64)
PIX RS(STM,0,1,11,72)
PIX RR(LR,0,10)
%CYCLE I=9,-1,5
PIX RR(LR,1,I)
PJUMP(BALCODE,GLABEL-1,LINKREG,0)
%REPEAT
K=GLABEL; GLABEL=GLABEL-1
PLABEL(K)
PIX RX(ST,0,0,11,68)
PIX RS(STM,4,14,11,16)
PIX RS(LM,CODER,EPREG,GLAREG,KNOWN XREF(1))
PIX RX(LGR,15,0,11,64)
PIX RR(BCR,15,EPREG)
PLABEL(GLABEL)
GLABEL=GLABEL-1
PIX RR(CR,1,11)
PJUMP(BC,K,2,0)
PIX RR(CR,1,0)
PJUMP(BC,K,12,0)
PIX RX(ICP,1,0,1,44)
PJUMP(BC,K,7,0)
PIX RR(LR,0,1)
PIX RR(BCR,15,LINKREG)
!
! SUBROUTINE TO CALL DEBUG ROUTINE(S#IMPMON) LINE NO IN GR0
!
! STM 4,0,16(11)
! LM CODER,EPREG,EPDIST
! BCR 15,LINKREG RETURN ADDR ALREADY IN GR15
!
%IF PARM_DBUG#0 %THEN %START
PLABEL(GLABEL)
WORKA_PLABS(3)=GLABEL; GLABEL=GLABEL-1
PIX RS(STM,4,0,16,11)
PIX RS(LM,CODER,EPREG,GLAREG,KNOWN XREF(5))
PIX RR(BCR,15,LINKREG)
%FINISH
!
! SUBROUTINE TO ADVANCE STACK FRONT BY GR0 WORDS AND FILL WITH UNASSIGNED
! GR1 HAS BYTES OF PARAMETERS WHICH MUST NOT BE OVERWRITTEN
!
!
! AR 1,11 BYTE TO START CLEARING
! AR 11,0 CLAIM SPACE
!AGN CR 1,11
! BCR 10,LINKREG
! MVI 0(1),UNASSPAT
! MVC 1(255,1),0(1)
! LA 1,256(1)
! BC 15,AGN
!
! THIS NEXT VERSION IS FOR XA ARCHITECTURE ONLY
!
! LA 2,0(1,11)
! AR 11,0 ADVANCE STACK FRONT
! SR 0,1 LENGTH OF FILL
! LR 1,0 TO CORRECT PLACE
! LR 0,2
! LA 3,UNASSPAT&255
! SLL 3,24
! MVCL 0,2
! BCR 15,LINKREG
%IF PARM_CHK=1 %THEN %START; ! ONLY REQUIRED WITH CHKING
PLABEL(GLABEL)
WORKA_PLABS(4)=GLABEL; GLABEL=GLABEL-1
PIX RX(LA,2,1,WSPR,0)
PIX RR(AR,WSPR,0)
PIX RR(SR,0,1)
PIX RR(LR,1,0)
PIX RR(LR,0,2)
PIX RX(LA,3,0,0,UNASSPAT&255)
PIX RS(SLL,3,0,0,24)
PIX RR(MVCL,0,2)
PIX RR(BCR,15,LINKREG)
%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 CHECK
%IF PARM_PROF#0 %THEN %START; ! ALLOCATE PROFILE COUNT AREA
PROFDATA=GLACA
PD4(2,GLACA,WORKA_LINE)
GLACA=GLACA+4
%CYCLE I=0,1,WORKA_LINE
PD4(2,GLACA,0)
GLACA=GLACA+4
%REPEAT
WORKA_LINE=0
%FINISH
%RETURN
%ROUTINE ERR EXIT(%INTEGER LAB, ERRNO, MODE)
!***********************************************************************
!* MODE=0 FOR DUMMY(ZERO) XTRA - MODE=1 XTRA IN GR1 *
!***********************************************************************
PLABEL(GLABEL)
WORKA_PLABS(LAB)=GLABEL; GLABEL=GLABEL-1
%IF MODE=0 %THEN PIX RR(SR,1,1)
PIX RX(LA,0,0,0,ERRNO)
PJUMP(BC,WORKA_PLABS(2),15,0)
%END
%END
%EXTERNALROUTINE EPILOGUE(%INTEGER STMTS)
!***********************************************************************
!* PLANT ANY SUBROUINES THAT HAVE BEEN REQUIRED DURING *
!* THE CODE GENERATION PHASE *
!***********************************************************************
%ROUTINESPEC LONGOP(%INTEGER OP)
%ROUTINESPEC FILL(%INTEGER LAB)
!
! STRING RESOLUTION SUBROUTINE
! ON ENTRY GR0 HAS ADDRESS OF WK AREA HOLDING
! W1(GR2) HAS ADDRESS OF ORIGINAL STRING
! W2(GR3) BYTE0 HAS ORIGINAL LENGTH OF LHS
! BYTE1 HAS BYTES USED UP IN PREV RESOLUTIONS.
! BYTES 2&3 HAVE MAX LENGTH OF FRAGMENT STRING
! W3(GR4) HAS ZERO OR STRINGNAME TO HOLD FRAGMENT
! W4(GR5) HAS ADDRESS OF RESOLUTION EXPRESSION(READ ONLY)
!
! ON EXIT RESULT IS SET BY CC AND W2 UPDATED. NO OTHER EFFECTS
! EXCEPT POSSIBLY STORING INTO FRAGMENT W3
!
! STM 1,10,4(WSPR) LOTS OF REGISTERS NEEDED
! LR 1,0 NOW PICK UP W1-4
! SR 0,0 FOR VARIOUS ICS LATER
! LM 2,5,0(1)
! BASR 9,0 BASE REGISTER COVER VIA 9
! CLI 5(1),0 FIRST ENTRY ?
! BC 7,NOT FIRST 14(9)
! MVC 4(1,1),0(2) COPY ORIGINAL LENGTH
!NOTFIRST
! WORK OUT NO OF VALID COMPARISONS
! SR 6,6
! IC 6,4(1) ORIGINAL LENGTH
! IC 0,5(1)
! SR 6,0 MINUS BYTES USED
! SR 7,7
! IC 7,0(5) LENGTH OF EXPRESSION
! SR 6,7
! BL RESFAIL 74(9) NOT ENOUGH LENGTH
! LA 6,1(6) EQUAL LENGTHS = 1 VALID COMP
! LTR 7,7
! BC 8,NULL RES 150(9) RESOLVING FOR NULL STRING
! BCTR 7,0 FOR EXECUTING
! IC 0,5(1)
! AR 2,0 POINT TO START SEARCH -1
! LR 10,2 SAVE THIS FOR STORING FRAGMNT
!NRLOOP
! EX 7,COMP 82(9) COMPARE
! BC 8,NROK 88(9) FOUND IT
! LA 2,1(2) STEP ALONG 1
! BCT 6,NRLOOP 58(9) AND KEEP GOING
!RESFAIL LM 1,10,4(WSPR) WONT RESOLVE
! NR WSPR,WSPR SET NON ZERO CC
! BCR 15,LINKREG AND RETURN
!COMP CLC 1(1,5),1(2)
!NROK
! SR 2,10 LENGTH OF FRAGMENT
! LTR 4,4 IS FRAGMNT TO BE STORED
! BC 8,NOSTORE 112(9)
! EX 2,MOVE 136(9) COPY IT +RUBBISH LENGTH BYTE
! STC 2,0(4) RESET LENGTH BYTE
! CH 2,6(1) PERFORM CAP EXCEEDED CHECK
! BC 10,CPE 142(9)
!NOSTORE IC 0(5(1)
! AR 2,0 R2=FRAG LENGTH + ORIG USED
! AR 2,7 PLUS BYTES OF EXPR
! LA 2,1(2)
! STC 2,5(1) BACK INTO WORK AREA
!REND LM 1,10,4(WSPR)
! CR WSPR,WSPR SET CC TO 0
! BCR 15,LINKREG
!MOVE MVC 0(1,4),0(10)
!CPE LM 1,10,4(WSPR)
! BC 15,PLABS9
!NULL RES RESOLVING ON NULL STRING
! LTR 4,4 ANY FRAG STRING
! BC 8,REND 128(9) NO SO EXIT
! MVI 0(4),0 SET IT TO NULL
! BC 15,REND 128(9)
! BCR 15,LINREG
%IF WORKA_PLINK(16)=0 %THEN ->P17
FILL(16)
PIX RS(STM,1,10,WSPR,4)
PIX RR(LR,1,0)
PIX RR(SR,0,0)
PIX RS(LM,2,5,1,0)
PIX RR(BALCODE-X'40',9,0)
PIX SI(CLI,0,1,5)
PIX RX(BC,7,0,9,14)
PIX SS(MVC,0,1,1,4,2,0)
PIX RR(SR,6,6)
PIX RX(IC,6,0,1,4)
PIX RX(IC,0,0,1,5)
PIX RR(SR,6,0)
PIX RR(SR,7,7)
PIX RX(IC,7,0,5,0)
PIX RR(SR,6,7)
PIX RX(BC,4,0,9,74)
PIX RX(LA,6,0,6,1)
PIX RR(LTR,7,7)
PIX RX(BC,8,0,9,150)
PIX RR(BCTR,7,0)
PIX RX(IC,0,0,1,5)
PIX RR(AR,2,0)
PIX RR(LR,10,2)
PIX RX(EX,7,0,9,82)
PIX RX(BC,8,0,9,88)
PIX RX(LA,2,0,2,1)
PIX RX(BCT,6,0,9,58)
PIX RS(LM,1,10,WSPR,4)
PIX RR(NR,WSPR,WSPR)
PIX RR(BCR,15,LINKREG)
PIX SS(CLC,0,1,5,1,2,1)
PIX RR(SR,2,10)
PIX RR(LTR,4,4)
PIX RX(BC,8,0,9,112)
PIX RX(EX,2,0,9,136)
PIX RX(STC,2,0,4,0)
PIX RX(CH,2,0,1,6)
PIX RX(BC,10,0,9,142)
PIX RX(IC,0,0,1,5)
PIX RR(AR,2,0)
PIX RR(AR,2,7)
PIX RX(LA,2,0,2,1)
PIX RX(STC,2,0,1,5)
PIX RS(LM,1,10,WSPR,4)
PIX RR(CR,WSPR,WSPR)
PIX RR(BCR,15,LINKREG)
PIX SS(MVC,0,1,4,0,10,0)
PIX RS(LM,1,10,WSPR,4)
PJUMP(BC,WORKA_PLABS(9),15,0)
PIX RR(LTR,4,4)
PIX RX(BC,8,0,9,128)
PIX SI(MVI,0,4,0)
PIX RX(BC,15,0,9,128)
P17:
!
! MULTIPLY TWO LONG INTEGERS AT WSPR+8 AND WSPR+16
%IF WORKA_PLINK(17)=0 %THEN ->P18
FILL(17)
LONGOP(MXR)
P18:
!
! DIVIDE TWO LONG INTEGES AT WSPR+8 AND WSPR+16S
!
%IF WORKA_PLINK(18)=0 %THEN ->P19
!
! BASR 1,0
! NC OPND2(5),OPND2 CHECK FOR SMALL +VE DIVISOR
! BC 7,LONGWAY
! LM 0,1,OPND1
! D 0,OPND2+4
! LR 0,1
! SRDA 0,32
! BCR 15,15
!LONGWAY
FILL(18)
! PIX RR(BALCODE-X'40',1,0)
! PIX SS(NC,0,5,WSPR,16,WSPR,16)
! PIX RX(BC,7,0,1,26)
! PIX RS(LM,0,1,WSPR,8)
! PIX RX(D,0,0,WSPR,20)
! PIX RR(LR,0,1)
! PIX RS(SRDA,0,0,0,32)
! PIX RR(BCR,15,15)
LONGOP(DXR)
P19:
! CONCATENATION ONE
! NOW DONE IN LINE
%IF WORKA_PLINK(19)!WORKA_PLINK(20)=0 %THEN ->P21
P21:
%BEGIN
!***********************************************************************
!* PASS INFORMATION TO IPUT TO ENABLE IT TO GENERATE THE *
!* LOADER DATA AND COMPLETE THE PROGRAM FILE. *
!***********************************************************************
%ROUTINESPEC DUMPCONSTS
%INTEGER LANGFLAG,PARMS,I,J,K
CODE OUT
PCNOP(0, 8)
DUMP CONSTS
%IF PARM_TRACE=0 %THEN LANGFLAG=6 %ELSE LANGFLAG=3
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
%IF PARM_INHCODE=0 %THEN %START
! BACK OF GLAP
PDBYTES(2, 0, FIXEDGLALEN, ADDR(FIXED GLA(0)));! FRONT OF GLAP
PFIX(2,4,1,0); ! RELOCATE HEAD OF CODE
PFIX(2,8,5,0); ! RELOCATE GLA ST ADDRESS
PFIX(2,12,4,0); ! RELOCATE CODE ST ADDRESS
PFIX(2,20,DAREA,0); ! RELOCATE DIAG AREA PTYR
PFIX(2,24,CAREA,0); ! RELOCATE CONSTANT AREA
PD4(DAREA,CAS(DAREA),X'E2E2E2E2')
CAS(DAREA)=CAS(DAREA)+4
%FINISH
%CYCLE I=1,1,10
CAS(I)=(CAS(I)+7)&(-8)
%REPEAT
%IF PARM_INHCODE=0 %THEN PTERMINATE(ADDR(CAS(1)),MAX4KMULT)
%IF WORKA_OPTCNT>0 %THEN %START
NEWLINE
WRITE(WORKA_OPTCNT,2)
PRINTSTRING(" OPTIMISATIONS HAVE BEEN MADE")
%FINISH
PRINTSTRING("
IBM CODE")
WRITE(CA, 6)
PRINTSTRING("+"); WRITE(CAS(CAREA),4)
PRINTSTRING(" BYTES GLAP")
WRITE(GLACA, 3); PRINTSTRING("+")
WRITE(CAS(5), 1); PRINTSTRING(" BYTES DIAG TABLES")
WRITE(CAS(DAREA), 3); PRINTSTRING(" BYTES
TOTAL")
K=CA+CAS(CAREA)+GLACA+CAS(4)+CAS(5)+CAS(6)
WRITE(K, 5); PRINTSTRING(" BYTES
")
%IF PARM_FAULTY=0 %THEN %START
WRITE(STMTS, 7); PRINTSTRING(" STATEMENTS COMPILED")
COMREG(47)=STMTS; ! NO OF STMTS FOR COMPER
%FINISH %ELSE %START
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
! SUMMARY INFO.
PPROFILE
->BLKEND
%ROUTINE DUMP CONSTS
!***********************************************************************
!* OUTPUT THE CONSTANT TABLE AND MAKE ANY RELEVANT RELOCATIONS *
!***********************************************************************
%INTEGER I,J,K,SIZE,BASE
BASE=0
SIZE=WORKA_CONSTPTR-BASE
CAS(CAREA)=4*SIZE
%IF SIZE<=0 %THEN %RETURN
PDBYTES(CAREA,0,SIZE*4,ADDR(CTABLE(BASE)))
!*DELSTART
%IF PARM_DCOMP#0 %START
PRINTSTRING("
CONSTANT TABLE")
I=BASE
%CYCLE
NEWLINE
PRHEX(4*(I-BASE),5)
%CYCLE J=0,1,7
SPACES(2)
PRHEX(CTABLE(I+J),8)
%REPEAT
SPACE
%CYCLE J=0,1,31
K=BYTEINTEGER(ADDR(CTABLE(I))+J)
%IF K<31 %OR K>125 %THEN K=32
PRINT SYMBOL(K)
%REPEAT
I=I+8
%EXIT %IF I>=WORKA_CONSTPTR
%REPEAT
NEWLINE
%FINISH
!*DELEND
!
%RETURN
%END
BLKEND:
%END
%RETURN
%ROUTINE LONGOP(%INTEGER OP)
!***********************************************************************
!* PLANTS A SUBROUTINE TO CARRY OUT AN OPERATION ON 2 LONG *
!* INTEGER AT WSPR+8 &WSPR+16. THE METHOD IS TO FLOAT BOTH AND *
!* USE 128 REAL OPERATIONS AND THE FIX. RESULT IS LEFT IN GR0&1 *
!* GRS 0-3 AND FRS 0-3 SHOULD BE SAVED BY PPJ *
!***********************************************************************
%INTEGER B1,D1,R1,B2,D2,R2,B3,D3,R3
!
! THE CODE PLANTED IS
!
! LD 4,X'5C00000000000080'
! SDR 6,6
! STD 4,0(WSPR)
! XC 7(1,WSPR),8(WSPR)
! LD 2,8(WSPR)
! STD 4,8(WSPR) READY FOR NEXT FIT
! LD 0,0(WSPR)
! SXR 0,4 COMPLETE FLOAT AND NORMALISE
! STD 0,24(WSPR)
! STD 2,32(WSPR) SAVE FLTED OPND1
! XC 15(1,WSPR),8(WSPR)
! LD 0,8(WSPR)
! LD 2,16(WSPR)
! SXR 0,4 COMPLETE FLOAT OF OPND2
! LD 4,24(WSPR)
! LD 6,32(WSPR)
! MXR(OR DXR) 4,0
! LD 0,X'5188000000000000'
! LD 2,X'4300000000000008' ROUNDING BIT AT BTM
! AXR 0,4
! STD 0,16(WSPR)
! STD 2,24(WSPR)
! XI 17(WSPR),X'08'
! MVC 24(2,WSPR),25(WSPR) CLOSE UP MANTISSA
! MVO 7(10,WSPR),17(9,WSPR)
! LM 0,1,8(WSPR)
! BCR 15,15
!
D1=KLCONSTS(6); ! X'5C00000000000080'
B1=D1>>12; R1=0
D2=KLCONSTS(5); ! X'5188000000000000'
B2=D2>>12; R2=0
D3=KLCONSTS(9)
B3=D3>>12; R3=0
%IF B1#0 %THEN R1=1 %AND PIX RX(L,1,0,CODER,4*B1);! 4K MULT LDED
PIX RX(LD,4,R1,CTABLEREG,D1&X'FFF')
PIX RR(SDR,6,6)
PIX RX(STD,4,0,WSPR,0)
PIX SS(XC,0,1,WSPR,7,WSPR,8)
PIX RX(LD,2,0,WSPR,8)
PIX RX(STD,4,0,WSPR,8)
PIX RX(LD,0,0,WSPR,0)
PIX RR(SXR,0,4)
PIX RX(STD,0,0,WSPR,24)
PIX RX(STD,2,0,WSPR,32)
PIX SS(XC,0,1,WSPR,15,WSPR,16)
PIX RX(LD,0,0,WSPR,8)
PIX RX(LD,2,0,WSPR,16)
PIX RR(SXR,0,4)
PIX RX(LD,4,0,WSPR,24)
PIX RX(LD,6,0,WSPR,32)
%IF OP<255 %THEN PIX RR(OP,4,0) %ELSE PIX RRE(OP,4,0)
%IF B1=B2 %THEN R2=R1 %ELSE %IF B2>0 %THEN %C
PIX RX(L,1,0,CODER,4*B2) %AND R2=1
PIX RX(LD,0,R2,CTABLEREG,D2&X'FFF')
%IF B2=B3 %THEN R3=R2 %ELSE %IF B3>0 %THEN %C
PIX RX(L,1,0,CODER,4*B3) %AND R3=1
PIX RX(LD,2,R3,CTABLEREG,D3&X'FFF')
PIX RR(AXR,0,4)
PIX RX(STD,0,0,WSPR,16)
PIX RX(STD,2,0,WSPR,24)
PIX SI(XI,X'08',WSPR,17)
PIX SS(MVC,0,2,WSPR,24,WSPR,25)
PIX SS(MVO,0,X'99',WSPR,7,WSPR,17)
PIX RS(LM,0,1,WSPR,8)
PIX RR(BCR,15,15)
%END
%ROUTINE FILL(%INTEGER LAB)
!***********************************************************************
!* FILL JUMPS TO THIS LAB WITH JUMP TO CURRENT ADDRESS *
!* TOP BIT SET IN INSTRN WHEN 4K MULT ALREADY LOADED *
!***********************************************************************
PLABEL(WORKA_PLABS(LAB))
%END
%END
%EXTERNALROUTINE CHANGESEX(%INTEGER BASEAD,OFFSET,L)
!***********************************************************************
!* ALTERERS INITIALISED DATA FOR A BYTE SEX CHANGE *
!* HOWEVER IBMS AND EMAS HAVE THE SAME BYTE SEX *
!***********************************************************************
%END
%EXTERNALROUTINE REFORMATC(%RECORD(RD)%NAME OPND)
!***********************************************************************
!* REFORMATS A CONSTANT TO TAKE INTO ACCOUNT DIFFERENT HOST-TARGET *
!* REPRESENTATIONS. HOWEVER EMAS FORMAT IS IBMXA FORMAT *
!***********************************************************************
%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 *
!***********************************************************************
%ROUTINESPEC CIOCP(%INTEGER A,B)
%ROUTINESPEC CONSTEXP(%INTEGER PTYPE,VALUE)
%ROUTINESPEC SAVE IRS(%INTEGER UPPER)
%ROUTINESPEC SET USE(%INTEGER REG,PTYPE,USE,INF)
%ROUTINESPEC FREE AND FORGET(%INTEGER REG)
%ROUTINESPEC FORGET(%INTEGER REG)
%ROUTINESPEC COPY USE(%INTEGER TO,FROM)
%ROUTINESPEC FORGETM(%INTEGER UPPER)
%ROUTINESPEC CLAIM THIS REG(%INTEGER REG)
%ROUTINESPEC CLAIM ALL4 FRS
%INTEGERFNSPEC CLAIM OTHER FRPAIR(%INTEGER PAIR0)
%ROUTINESPEC FIND USE(%INTEGERNAME REG,%INTEGER PTYPE,USE,INF)
%INTEGERFNSPEC FINDREG(%INTEGER MASK,CLVAL)
%INTEGERFNSPEC FINDSEQREG(%INTEGER MASK,CLVAL)
%INTEGERFNSPEC CHECKSEQREG(%INTEGER MASK)
%INTEGERFNSPEC ACCEPTABLE REG(%INTEGER MASK,REG)
%ROUTINESPEC SET LOCAL BASE
%ROUTINESPEC PPJ(%INTEGER MASK,N,SAVE)
%INTEGERFNSPEC SET DVREG(%INTEGER WHICH,DVBD,ANAME)
%ROUTINESPEC SSTRASS(%RECORD(RD)%NAME LHOPND,RHOPND,%INTEGER ACC)
%INTEGERFNSPEC SSVARASS(%INTEGER S,B,D,%RECORD(RD)%NAME OPND)
%ROUTINESPEC VMULTIPLY
%ROUTINESPEC LNEGATE(%INTEGER REG)
%ROUTINESPEC REALEXP
%ROUTINESPEC STARSTAR
%ROUTINESPEC NOTE ASSMENT(%INTEGER REG,ASSOP,VAR,PTYPE)
%ROUTINESPEC CEND
%INTEGERFNSPEC REACHABLE(%INTEGER LAB,LINK)
%ROUTINESPEC LOAD(%RECORD(RD) %NAME OP,%INTEGER REG,MODE)
%ROUTINESPEC LOAD PAIR(%INTEGER TYPE,ODDEVEN,%RECORD(RD)%NAME OPND)
%ROUTINESPEC LOADAD(%RECORD(RD) %NAME OPND,%INTEGER REG)
%ROUTINESPEC LOADPTR(%RECORD(RD) %NAME OPND,OPND2,%INTEGER REG)
%ROUTINESPEC DSTORE(%INTEGER REG,SIZE,LEVEL,DISP)
%ROUTINESPEC CALL COMING(%INTEGER UPPER)
%ROUTINESPEC CALL MADE
%ROUTINESPEC GET IN ACC(%INTEGERNAME REG,%INTEGER SIZE,%RECORD(RD)%NAME OPND)
%ROUTINESPEC GET OUT OF ACC(%INTEGER REG,SIZE,%RECORD(RD)%NAME OPND)
%ROUTINESPEC BOOT OUT(%INTEGER REG)
%ROUTINESPEC DFETCH(%INTEGERNAME REG,%INTEGER SIZE,LEVEL,DISP)
%ROUTINESPEC INC REG(%INTEGER REG,AMOUNT,LAOK)
%ROUTINESPEC DFETCHAD(%INTEGERNAME REG,%INTEGER LEVEL,DISP)
%ROUTINESPEC ADJUST INDEX(%INTEGER MODE,%INTEGERNAME INDEX,DISP)
%ROUTINESPEC DUMPRXE(%INTEGER CODE,%INTEGERNAME REG,%INTEGER X,B,D)
%ROUTINESPEC DUMPRX(%INTEGER CODE,REG,X,LEVEL,DIS)
%ROUTINESPEC DUMPLA(%INTEGER REG,X,LEVEL,DIS)
%ROUTINESPEC DUMPSI(%INTEGER CODE,L,B,D)
%ROUTINESPEC DUMPM(%INTEGER CODE,R1,R2,B,D)
%ROUTINESPEC DUMPSS(%INTEGER OP,L,B1,D1,B2,D2)
%ROUTINESPEC EXECUTESS(%INTEGER XREG,OPCODE,B1,D1,B2,D2)
%ROUTINESPEC PUT(%INTEGER REG,CODE,OFFSET,FINISHED,%RECORD(RD)%NAME OPND)
%ROUTINESPEC REDUCE BASE(%RECORD(RD)%NAME OPND)
%ROUTINESPEC OPERAND USED(%RECORD(RD)%NAME OPND)
%ROUTINESPEC OPERAND LOADED(%RECORD(RD)%NAME OPND,%INTEGER REG)
%ROUTINESPEC OPERAND RELOADED(%RECORD(RD)%NAME OPND,%INTEGER REG)
%INTEGERFNSPEC RESULTREG(%INTEGER PTYPE)
%ROUTINESPEC BULKM(%INTEGER MODE,L,B1,D1,B2,D2)
%ROUTINESPEC POLISH LOOP(%RECORD(TRIPF)%NAME R)
!
%RECORD(RD) %NAME OPND1,OPND2,OPNDC,OPNDNC,OPND
%RECORD(TRIPF) %NAME CURRT,WORKT
%RECORD(LEVELF) %NAME LINF,CURRINF
%RECORD(TAGF) %NAME TCELL
%RECORD(LISTF) %NAME LCELL
%RECORD(RD) TOPND; ! TEMPORARY OPERANDS
!
%INTEGER B,C,D,WTRIPNO,JJ,KK,COMM,XTRA,PT,BFFLAG,TRIPINF,TRIPVAL,PTYPE,TYPE,PREC,
STPTR,L0,B1,B2,B3,EVALREG,CLNB
%OWNINTEGER RESTEMPAD=0; ! REMEMBERS CURRENT RESLN WK AD
%OWNRECORD(RD) UOPND; ! TO SAVE SS OPERAND IN ASSEMBLER
%LONGINTEGER DESC
!
! 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'10000E0F'{RTHD ROUTINE/BKK HDR},
X'10000E43'{RDSPLY MAKE DISPLAY},
X'10000010'{RDAREA INITIALISE DIAGS AREA},
X'10000811'{RDPTR RESET DIAGS PTR},
X'10000412'{RTBAD ERROR XIT FOR FN-MAP},
X'10000613'{RTXIT "%RETURN"},
X'10000A14'{XSTOP "%STOP"},
0(2),
X'2000040A'{10 LOGICAL NOT},
X'2000040B'{11 LOGICAL NEGATE},
X'2000020C'{12 IFLOAT},
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'10000403'{21 STORE STACKPOINTER},
X'10000402'{22 RESTORE STACK POINTER},
X'10000805'{23 ADVANCE STACK POINTER},
X'10001004'{24 DECLARE ARRAY},
X'10000801'{25 UPDATE LINE NO},
X'10000A06'{26 CHECK ZERO FOR STEP},
X'10000407'{27 FOR PREAMBLE},
X'10000008'{28 FOR POSTAMBLE},
X'1000000E'{29 FOR SECOND PREAMBLE},
X'10000418'{30 PRECALL},
X'10000C19'{31 ROUTINE CALL},
X'1000081A'{32 RECOVER FN RESULT},
X'1000041B'{33 RECOVER MAP RESULT},
X'00000000'{34 NOT CURRENTLY USED},
X'1000081D'{35 GETAD GET 32BIT ADDREESS},
X'10002C24'{36 RTOI1 INT FN},
X'10002C25'{37 RTOI2 INTPT FN},
X'10000C26'{38 STOI1 TOSTRING FN},
X'10000C3D'{39 MNITR FOR %MONITOR},
X'00000000'{40 PPROF PRINT PROFILE IGNORED},
X'1000143F'{41 RTFP TURN RTNAME TO FORMAL},
X'10000649'{42 ON EVENT1},
X'10000E4A'{43 ON EVENT2},
X'10001446'{44 DVSTART FILL IN ELSIZE&ND},
X'10002047'{45 DVEND WORK OUT TOTSIZE ETC},
X'1000044C'{46 FOREND },
0(3),
X'10000232'{50 UCNOP},
X'10000233'{51 UCB1},
X'10000234'{52 UCB2},
X'10000435'{53 UCB3},
X'10000436'{54 UCW},
X'10000637'{55 UCBW},
0(3),
X'1000003B'{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'2000401E'{138 **},
X'2001041F'{139 COMP},
X'20000420'{140 DCOMP},
X'20061021'{141 VMY},
X'20010422'{142 COMB},
X'200E0623'{143 ASSIGN=},
X'200E0624'{144 ASSIGN<-},
X'20022025'{145 ****},
X'20060026'{146 BASE ADJ},
X'200E0C27'{147 ARR INDEX},
X'20060428'{148 INDEXED FETCH},
X'200E0629'{149 LOCAL ASSIGN},
X'10001609'{150 VALIDATE FOR},
X'10001015'{151 PRE CONCAT},
X'10001C16'{152 COCNCATENEATION},
X'10001817'{153 IOCP CALL},
X'10000C1C'{154 PARAMETER ASSIGNMENT 1 NORMAL VALUES},
X'1000081F'{155 PARAM ASSNG 2 NORMAL PTRS},
X'10000820'{156 PARAM ASSGN 3 ARRAYS},
X'10000C20'{157 ASSGN FORMAL RT-CODE AS 156},
X'10000220'{158 PASS5 TYPE GENERAL NAME},
X'10000845'{159 PASS STR WORK AREA},
X'1000080A'{160 BACK JUMP},
X'1000080B'{161 FORWARD JUMP},
X'1000000C'{162 REMOVE LAB},
X'1000000D'{163 ENTER LABEL},
X'10000021'{164 DECLARE SWITCH},
X'10000022'{165 SET SWITCH LABEL TO CA},
X'10001023'{166 GOTO SWITCH LABEL},
X'10001027'{167 STRING ASS1 GENERAL},
X'10000A28'{168 STRING ASS 2 L KNOWN},
X'10002029'{169 STRING JAM TRANSFER},
X'10000C2A'{170 ARRAY HEAD ASSIGNMENT},
X'10000C2B'{171 PTR ASSIGNMENT},
X'1000042C'{172 MAP RESULT ASSIGNMENT},
X'1000082D'{173 FN RESULT ASSIGNMENT},
X'1000122E'{174 STRING COMPARISON},
X'1000122E'{175 STRING DSIDED COMPARISON},
X'10000C2F'{176 PRE RESOLUTION 1},
X'10000C30'{177 PRE RESOLUTION 2},
X'10001C31'{178 RESOLUTION PROPER},
X'1000283C'{179 RESOLUTION FINISH ASSN FRAGMNT},
X'10000C4B'{180 SIGEV SIGNAL EVENT NOT IMPLEMENTED},
X'10000A3E'{181 RECASS WHOLE RECORD ASSIGNMENT},
X'10000A40'{182 ARRAY ADDR INC},
X'10000A41'{183 AHADJ FOR ARRAY MAPPING},
X'10000A42'{184 CREATE TYPE GENERAL PARAMETER},
X'1000081E'{185 GET POINTER FOR PASSING BY NAME},
X'10000844'{186 INDEX STRING FOR CHARNO},
X'2002042A'{187 ZCOMP COMPARE W ZERO},
X'2002082B'{188 CONSTANT LOGICAL SHIFT},
X'2002082B'{189 COSNTANT ARITHMETIC SHIFT},
X'10001048'{190 DV BPAIR ENTER LB,UB &RANGE IN CORRECT FORM},
0(*)
%CONSTBYTEINTEGERARRAY FCOMP(0:79)=0(2),2(2),4(2),6(2),8(2),10(2),12(2),14(2),
0(2),4(2),2(2),6(2),8(2),12(2),10(2),14(2),
0(2),21(2),22(2),36(2),20(2),38(2),37(2),15(2),
0(2),22(2),21(2),36(2),20(2),37(2),38(2),15(2),
0(2),5(2),2(2),7(2),8(2),13(2),10(2),15(2);
!
! 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*(4*NISEQS+10)-1)={FIRST INTEGER FORMS} %C
8,0,0,-ANYGR {10 INTEGER LOGICAL NOT},
2,LCR,0,-ANYGR {11 INTEGER LOGICAL NEGATE},
12,0,0,0 {12 INTEGER FLOAT TO REAL},
2,LPR,0,-ANYGR {13 INTEGER MODULUS},
9,0,0,0 {14 SHORTEN INTEGER TO 16 BIT},
10,0,0,0 {15 LENGTHEN INTEGER},
21,0,0,0 {16 SHORTEN INTEGER FOR JAM},
1,0,0,109 {17 COMPILER ERROR},
7,0,0,0 {18 NOOP},
6,0,0,-ANYGR {19 PRELOAD},
3,A,AH,0 {20 INTEGER ADDITION},
3,S,SH,0 {21 INTEGER SUBTRACTION},
4,X,0,-ANYGR {22 INTEGER NONEQUIVALENCE},
4,O,0,-ANYGR {23 INTEGER LOGICAL OR},
11,M,0,-ANYGR {24 INTEGER MULTIPLY},
11,DR+X'40',0,0 {25 INTEGER INTEGER DIVIDE},
1,0,0,109 {26 INTEGER REAL DIVIDE},
4,AND,0,-ANYGR {27 INTEGER AND},
17,SRL,0,-ANYGR {28 INTEGER RIGHT SHIFT},
17,SLL,0,-ANYGR {29 INTEGER LEFT SHIFT},
1,0,0,109 {30 REAL EXP OPERATOR},
13,ICP,CH,-ANYGR {31 INTEGER COMPARISONS},
14,ICP,CH,-ANYGR {32 FIRST PART OF DOUBLE COMPARISONS},
15,0,0,0 {33 VMY},
4,A,0,-ANYGR {34 COMBINE VMY RESULTS},
16,0,0,-ANYGR {35 ASSIGN},
16,0,0,-ANYGR {36 ASSIGN(<-)},
22,1,0,0 {37 INTEGER EXPONENTIATION},
18,2,0,0 {38 BASE ADJUST ARRAY INTEGER INDEX},
19,2,0,0 {39 ARRAY INDEX INTEGER INDEX},
20,0,0,0 {40 INDEXED FETCH INTEGER INDEX},
23,0,0,-ANYGR {41 LASS},
24,LTR,0,-ANY GR {42 ZCOMP COMPARISON WITH ZERO},
25,0,0,-ANYGR {43 INTEGER SHIFT BY CONSTANT},
8,0,0,-ANY2SEQ {10 LONG INTEGER LOGICAL NOT},
29,0,0,-ANY2SEQ {11 LONG INTEGER LOGICAL NEGATE},
27,0,0,0 {12 LONG INTEGER FLOAT TO REAL},
30,0,0,-ANY2SEQ {13 LONG INTEGER MODULUS},
9,0,0,0 {14 SHORTEN LONG INTEGER TO 16 BIT},
10,0,0,0 {15 LENGTHEN LONG INTEGER},
21,0,0,0 {16 SHORTEN LONG INTEGER FOR JAM},
1,0,0,109 {17 COMPILER ERROR},
7,0,0,0 {18 NOOP},
6,0,0,-ANYGRPAIR {19 PRELOAD},
26,AL,A,12 {20 LONG INTEGER ADDITION},
26,SL,S,3 {21 LONG INTEGER SUBTRACTION},
26,X,X,0 {22 LONG INTEGER NONEQUIVALENCE},
26,O,O,0 {23 LONG INTEGER LOGICAL OR},
28,0,0,17 {24 LONG INTEGER MULTIPLY},
28,0,0,18 {25 LONG INTEGER LONG INTEGER DIVIDE},
1,0,0,109 {26 LONG INTEGER REAL DIVIDE},
26,AND,AND,0 {27 LONG INTEGER AND},
17,SRDL,0,-ANYGRPAIR {28 LONG INTEGER RIGHT SHIFT},
17,SLDL,0,-ANYGRPAIR {29 LONG INTEGER LEFT SHIFT},
1,0,0,109 {30 REAL EXP OPERATOR},
13,ICP,CL,-ANY2SEQ {31 LONG INTEGER COMPARISONS},
14,ICP,CL,-ANY2SEQ {32 FIRST PART OF DOUBLE COMPARISONS},
15,0,0,0 {33 VMY},
4,A,0,1 {34 COMBINE VMY RESULTS},
16,0,0,-ANY2SEQ {35 ASSIGN},
16,0,0,-ANY2SEQ {36 ASSIGN(<-)},
1,0,0,99 {37 LONG INTEGER EXPONENTIATION},
1,0,0,109 {38 BASE ADJUST ARRAY LONG INTEGER INDEX},
1,0,0,109 {39 ARRAY INDEX LONG INTEGER INDEX},
1,0,0,109 {40 INDEXED FETCH LONG INTEGER INDEX},
23,0,0,-ANY2SEQ {41 LASS},
24,SLDA,0,-ANYGRPAIR {42 ZCOMP COMPARISON WITH ZERO},
25,0,0,-ANYGRPAIR {43 LONG INTEGER SHIFT BY CONSTANT},
7,0,0,0 {10 REAL LOGICAL NOT},
2,LCDR,LCER,3 {11 REAL LOGICAL NEGATE},
1,0,0,109 {12 FLOAT REAL COMPILER ERROR},
2,LPDR,LPER,3 {13 REAL MODULUS},
9,0,0,0 {14 SHORTEN REAL},
10,0,0,0 {15 LENGTHEN REAL},
9,0,0,0 {16 SHORTEN REAL FOR JAM},
1,0,0,109 {17 COMPILER ERROR},
7,0,0,0 {18 NOOP},
6,0,0,-ANYFR {19 PRELOAD},
4,AD,AE,3 {20 REAL ADDITION},
4,SD,SE,3 {21 REAL SUBTRACTION},
7,0,0,0 {22 REAL NONEQUIVALENCE},
7,0,0,0 {23 REAL LOGICAL OR},
4,MD,ME,3 {24 REAL MULTIPLY},
7,0,0,0 {25 REAL INTEGER DIVIDE},
4,DD,DE,3 {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,0,0 {30 REAL EXP OPERATOR},
13,CD,CE,3 {31 REAL COMPARISONS},
14,CD,CE,3 {32 FIRST PART OF DOUBLE COMPARISONS},
7,0,0,0 {33 VMY},
7,0,0,0 {34 COMBINE VMY RESULTS},
16,0,0,-ANYFR {35 ASSIGN},
16,0,0,-ANYFR {36 ASSIGN(<-)},
7,0,0,0 {37 REAL INTEGER EXPONENTIATION},
1,0,0,109 {38 BASE ADJUST ARRAY REAL INDEX},
7,0,0,0 {39 ARRAY INDEX REAL INDEX},
3,0,0,0 {40 INDEXED FETCH REAL},
23,0,0,3 {41 LASS},
24,LTDR,LTER,-ANYFR {42 ZCOMP COMPARISONS WITH ZERO},
7,0,0,0 {43 SHIFT BY CONST -ERROR},
7,0,0,0 {10 EXTENDED REAL LOGICAL NOT},
2,LCDR,LCDR,-ANYFRPAIR {11 EXTENDED REAL LOGICAL NEGATE},
1,0,0,109 {12 FLOAT EXTENDED REAL COMPILER ERROR},
2,LPDR,LPDR,-ANYFRPAIR {13 EXTENDED REAL MODULUS},
9,0,0,0 {14 SHORTEN EXTENDED REAL},
10,0,0,0 {15 LENGTHEN EXTENDED REAL},
9,0,0,0 {16 SHORTEN EXTENDED REAL FOR JAM},
1,0,0,109 {17 COMPILER ERROR},
7,0,0,0 {18 NOOP},
6,0,0,-ANYFRPAIR {19 PRELOAD},
31,0,AXR,-ANYFRPAIR {20 EXTENDED REAL ADDITION},
31,0,SXR,-ANYFRPAIR {21 EXTENDED REAL SUBTRACTION},
7,0,0,0 {22 EXTENDED REAL NONEQUIVALENCE},
7,0,0,0 {23 EXTENDED REAL LOGICAL OR},
31,0,MXR,-ANYFRPAIR {24 EXTENDED REAL MULTIPLY},
7,0,0,0 {25 EXTENDED REAL INTEGER DIVIDE},
31,DXR>>8,DXR&255,-ANYFRPAIR {26 EXTENDED REAL EXTENDED REAL DIVIDE},
7,0,0,0 {27 EXTENDED REAL AND},
7,0,0,0 {28 EXTENDED REAL LEFT SHIFT},
7,0,0,0 {29 EXTENDED REAL RIGHT SHIFT},
22,2,0,0 {30 EXTENDED REAL EXP OPERATOR},
13,CD,CD,-ANYFRPAIR {31 EXTENDED REAL COMPARISONS},
14,CD,CD,-ANYFRPAIR {32 FIRST PART OF DOUBLE COMPARISONS},
7,0,0,0 {33 VMY},
7,0,0,0 {34 COMBINE VMY RESULTS},
16,0,0,-ANYFRPAIR {35 ASSIGN},
16,0,0,-ANYFRPAIR {36 ASSIGN(<-)},
7,0,0,0 {37 EXTENDED REAL INTEGER EXPONENTIATION},
1,0,0,109 {38 BASE ADJUST ARRAY EXTENDED REAL INDEX},
7,0,0,0 {39 ARRAY INDEX EXTENDED REAL INDEX},
3,0,0,0 {40 INDEXED FETCH EXTENDED REAL},
23,0,0,-ANYFRPAIR {41 LASS},
24,LTDR,0,-ANYFRPAIR {42 ZCOMP COMPARISONS WITH ZERO},
7,0,0,0 {43 SHIFT BY CONST -ERROR}
%SWITCH SW(0:35),TRIPSW(0:76)
!
CURRINF==WORKA_LEVELINF(CURRLEVEL)
CLNB=DISPREG(CURRINF_RBASE)
%FOR JJ=11,1,14 %CYCLE
IMPABORT %UNLESS REGS(JJ)_CL=-1
%REPEAT
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
%IF PARM_Z#0 %AND PARM_DCOMP#0 %THEN %START
NEWLINE
PLINEDECODE
PRINT USE
PRINT THIS TRIP(TRIPLES,STPTR)
%FINISH
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)
CA=CA+TRIPINF>>8&255;! APPROX WORDRST CA FOR BASE REGISTER COVER
C=TRIPINF>>28; ! TRIPLE TYPE
TRIPVAL=TRIPINF&255
PTYPE=OPND1_PTYPE&255; TYPE=PTYPE&7
%IF C=0 %THENCONTINUE
%IF C=1 %THEN ->TRIPSW(TRIPVAL)
COMM=1
%IF TYPE=2 %THEN C=4*(TRIPVAL+2*NISEQS) %C
%ELSE C=4*TRIPVAL
%IF PTYPE=X'61' %OR PTYPE=X'72' %THEN C=C+4*NISEQS
L0=ISEQS(C); B1=ISEQS(C+1)
B2=ISEQS(C+2); B3=ISEQS(C+3)
%IF TRIPINF&X'10000'#0 %AND OPND2_FLAG=REFTRIP %START
WORKT==TRIPLES(OPND2_D)
%IF WORKT_OPND1_FLAG=9 %THEN COMM=2
%FINISH
%IF COMM=1 %THEN OPNDC==OPND1 %ELSE OPNDC==OPND2
%IF JJ>=128 %AND COMM=1 %THEN OPNDNC==OPND2 %ELSE OPNDNC==OPND1
%UNLESS JJ<128 %OR OPNDNC_FLAG=9 %OR TRIPINF&X'20000'#0 %THEN %C
LOAD(OPNDNC,ANY GR,0)
->SW(L0)
SW(1): ! ERROR CONDITION
TRIPSW(0):
FAULT(B3,0,0) %UNLESS TYPE=7
TRIPSW(*):
PIX RR(X'1A',0,1); ! USEFUL IN DEBUGGING TO HAVE
! ERROR POSITION PINPOINTED
->STRES
SW(5): ! PLANT ONE BYTE & SET PTYPE
OPND1_PTYPE=B3
SW(2): ! PLANT UNARY OP
LOAD(OPND1,-B3,2)
%IF PTYPE=X'52' %THEN B1=B2
EVALREG=OPND1_XB
PIX RR(B1,REGCODE(EVALREG),REGCODE(EVALREG))
%IF PTYPE=X'72' %THEN PIX RR(B2,REGCODE(EVALREG+1),REGCODE(EVALREG+1)) %C
%AND FORGET(EVALREG+1)
FORGET(EVALREG)
->SUSE
->STRES
SW(3): ! INTEGER FORM NO PROBLEMS
D=OPNDNC_PTYPE&255
%IF D=X'51' %AND B2#0 %AND OPNDNC_FLAG=0 %AND %C
X'FFFF8000'<=OPNDNC_D<=X'7FFF' %THEN D=X'41' %AND OPNDNC_PTYPE=D
%IF D=X'31' %OR (D=X'41' %AND B2=0) %THEN ->SW(4)
C=2; ! TO REGISTER
! %IF JJ=COMP %OR JJ=DCOMP %THEN C=18;! TO REGISTER BUT READONLY
LOAD(OPNDC,ANY GR,C); ! FIRST OPERAND TO ANY
EVALREG=OPNDC_XB
%IF OPNDNC_FLAG<=8 %THEN LOAD(OPNDNC,ANY GR,1)
%IF OPNDNC_PTYPE&255=X'41' %THEN B1=B2;! USE HALFWORD VSN OF OP
! LOAD MAY HAVE EXPANDED IT(!)
PUT(EVALREG,B1,0,YES,OPNDNC)
%IF COMM=2 %THEN OPND1=OPND2; ! TRIPLE RESULT ALWAYS OPND1
SUSE:
OPERAND LOADED(OPND1,EVALREG)
->STRES
SW(4): ! ANY FORM NO PROBLEMS
C=2; ! TO REGISTER
! %IF JJ=COMP %OR JJ=DCOMP %THEN C=18;! TO REGISTER BUT READONLY
LOAD(OPNDC,-B3,C); ! TO ANY FR REG
EVALREG=OPNDC_XB
D=OPNDNC_PTYPE&255
%IF D=X'31' %OR D=X'41' %THEN LOAD(OPNDNC,ANY GR,2)
%IF OPNDNC_FLAG<=8 %THEN LOAD(OPNDNC,ANY GR,1)
%IF D=X'52' %THEN B1=B2; ! USE SHORT FORM
PUT(EVALREG,B1,0,YES,OPNDNC)
%IF COMM=2 %THEN OPND1=OPND2
->SUSE
SW(6): ! PRELOAD
! CA OMIT UNLESS RTCALL ETCE INTERVENES
%UNLESS CURRT_CNT=1 %AND (CURRT_PUSE=STPTR %OR %C
CURRT_PUSE=TRIPLES(STPTR)_FLINK) %THEN LOAD(OPND1,-B3,2)
SW(7): ! NULL OPERATION
->STRES
SW(8): ! LOGICAL NOT
LOAD(OPND1,-B3,2)
EVALREG=OPND1_XB
DUMPRX(X,EVALREG,0,CTABLEREG,KWCONSTS(2))
FORGET(EVALREG)
%IF PTYPE=X'61' %START
DUMPRX(X,EVALREG+1,0,CTABLEREG,KWCONSTS(2))
FORGET(EVALREG+1)
%FINISH
->SUSE
SW(9): ! SHORTEN INTEGER OR REAL
PTYPE=CURRT_OPTYPE
%IF PTYPE=X'62' %START
LOAD(OPND1,ANY FRPAIR,2); ! TO ANY FR PAIR
EVALREG=OPND1_XB
PIX RR(LRDR,REGCODE(EVALREG),REGCODE(EVALREG))
FORGET(EVALREG)
FREE AND FORGET(EVALREG+1)
%FINISH %ELSE %IF PTYPE=X'52' %START
LOAD(OPND1,ANY FR,2); ! TO ANY FR
EVALREG=OPND1_XB
PIX RR(LRER,REGCODE(EVALREG),REGCODE(EVALREG))
FORGET(EVALREG)
%FINISH %ELSE %IF PTYPE=X'51' %START
LOAD(OPND1,ANY GRPAIR,2); ! TO ANY GR PAIR
EVALREG=OPND1_XB
%IF PARM_OPT=0 %START
REGS(EVALREG)_CL=0
FORGET(EVALREG)
EVALREG=EVALREG+1
OPND1_XB=EVALREG
%FINISH %ELSE %START
PIX RS(SLDA,EVALREG,0,0,32)
FORGET(EVALREG)
REGS(EVALREG+1)_CL=0
%FINISH
%FINISH %ELSE %IF PTYPE=X'41' %START
LOAD(OPND1,ANY GR,2)
EVALREG=OPND1_XB
%IF PARM_OPT#0 %AND TRIPLES(CURRT_PUSE)_OPERN#SHRTN %THEN %START
PIX RX(SLA,EVALREG,0,0,16)
PIX RX(SRA,EVALREG,0,0,16)
FORGET(EVALREG)
%FINISH
%FINISH %ELSE %IF PTYPE=X'31' %START
LOAD(OPND1,ANY GR,2)
EVALREG=OPND1_XB
%IF PARM_OPT#0 %THEN %START
DUMPRX(CL,EVALREG,0,CTABLEREG,KWCONSTS(1))
PPJ(2,9,NO)
%FINISH
%FINISH
OPND1_PTYPE=CURRT_OPTYPE
->SUSE
SW(10): ! LENGTHEN INTEGER OR REAL
%IF TYPE=2 %THEN %START
%IF CURRT_OPTYPE=X'62' %START; ! 32 TO 64 BIT
LOAD(OPND1,ANY FR,2)
EVALREG=OPND1_XB
DUMPRX(ME,REGCODE(EVALREG),0,CTABLEREG,KWCONSTS(4))
%FINISH %ELSE %START
LOAD PAIR(2,0,OPND1)
EVALREG=OPND1_XB
DUMPRX(MXD,REGCODE(EVALREG),0,CTABLEREG,KLCONSTS(7));! =D'1'
%FINISH
%FINISH %ELSE %START
%IF CURRT_OPTYPE=X'61' %THEN %START
LOAD PAIR(1,0,OPND1)
EVALREG=OPND1_XB
DUMPRX(SRDA,EVALREG,0,0,32)
%FINISH %ELSE %START
LOAD(OPND1,ANY GR,2)
EVALREG=OPND1_XB
%FINISH
%FINISH
OPND1_PTYPE=CURRT_OPTYPE
FORGET(EVALREG)
%IF CURRT_OPTYPE=X'61' %OR CURRT_OPTYPE=X'72' %THEN FORGET(EVALREG+1)
->SUSE
SW(11): ! INTEGER MULT&DIV
%IF PARM_OPT=0 %AND JJ=MULT %START
%IF OPNDC_FLAG=SCONST %AND X'FFFF8000'<=OPNDC_D<=X'7FFF'%C
%THEN ->MH1
%IF OPNDNC_FLAG=SCONST %AND X'FFFF8000'<=OPNDNC_D<=X'7FFF'%C
%THEN ->MH2
%FINISH
LOAD PAIR(1,B3,OPND1)
C=OPND2_PTYPE>>4&7; ! OPND2 PREC
%IF C<5 %THEN LOAD(OPND2,ANYGR,18) %ELSE LOAD(OPND2,ANY GR,17)
EVALREG=OPND1_XB
%IF CURRT_OPERN=INTDIV %THEN PIX RX(SRDA,EVALREG,0,0,32)
PUT(EVALREG,B1,0,YES,OPND2)
FORGET(EVALREG)
FORGET(EVALREG+1)
%IF CURRT_OPERN=INTDIV %OR PARM_OPT=0 %THEN %START
REGS(EVALREG)_CL=0
EVALREG=EVALREG+1
%ELSE
PIX RS(SLDA,EVALREG,0,0,32);! TEST FOR OVERFLOW
REGS(EVALREG+1)_CL=0
%FINISH
->SUSE
MH1: LOAD(OPNDNC,ANYGR,2)
D=SHORT CONST(OPNDC_D)
EVALREG=OPNDNC_XB
->MH3
MH2: LOAD(OPNDC,ANYGR,2)
D=SHORT CONST(OPNDNC_D)
EVALREG=OPNDC_XB
MH3: DUMPRX(MH,EVALREG,0,CTABLEREG,D)
FORGET(EVALREG)
%IF COMM=2 %THEN OPND1=OPND2
->SUSE
SW(12): ! FLOAT
%BEGIN
%INTEGER P1,D
LOAD(OPND1,ANY GR,2)
P1=OPND1_XB
D=KLCONSTS(8); ! X'4E00000080000000'
DUMPRX(X,P1,0,CTABLEREG,D+4); ! X'80000000'
PIX RX(ST,P1,0,WSPR,4)
PIX SS(MVC,0,4,WSPR,0,CTABLEREG,D);! X4E000000
EVALREG=FINDREG(FR0,1)
DUMPRX(LD,REGCODE(EVALREG),0,WSPR,0)
DUMPRX(SD,REGCODE(EVALREG),0,CTABLEREG,D);! X'4E00000080000000'
REGS(P1)_CL=0
FORGET(P1)
FORGET(EVALREG)
OPND1_XB=EVALREG
%END
OPND1_PTYPE=X'62'
->SUSE
SW(21): ! SHORTEN INTEGER FOR JAM TRANSFER
%IF CURRT_OPTYPE=X'51' %START;! LOMG TO NORMAL
LOAD(OPND1,ANY2SEQ,2)
EVALREG=OPND1_XB
REGS(EVALREG)_CL=0
EVALREG=EVALREG+1
%FINISH %ELSE %START
LOAD(OPND1,ANY GR,2)
! NO CODE NEEDED FOR 32BITS & LESS
EVALREG=OPND1_XB
%FINISH
OPND1_PTYPE=CURRT_OPTYPE
->SUSE
SW(22): ! EXP IN ANY EXPRSN
%IF OPND2_PTYPE&7=1 %THENSTART
%IF OPND2_FLAG=SCONST %AND 2<=OPND2_D %THEN %C
CONST EXP(OPND1_PTYPE&255,OPND2_D) %ELSE STARSTAR
->SUSE
%FINISH
! REAL**REAL BY SUBROUTINE
REALEXP; ->SUSE
SW(17): ! INTEGER SHIFT
LOAD(OPND1,-B3,2)
LOAD(OPND2,ANYGR BAR0,2)
EVALREG=OPND1_XB
PIX RX(B1,EVALREG,0,OPND2_XB,0)
OPERAND USED(OPND2)
FORGET(EVALREG)
->SUSE
SW(14): ! DSIDED COMPARISONS
COMM=2
OPNDC==OPND2; OPNDNC==OPND1
SW(13): ! COMPARISONS
BFFLAG=COMM-1; ! NOTE BACKWARDS OR FORWARDS
C=FCOMP(XTRA&15+16*BFFLAG)
WORKT==TRIPLES(CURRT_FLINK); ! NEXT TRIPLE
%IF WORKT_OPERN=FJUMP %OR WORKT_OPERN=BJUMP %THEN %C
WORKT_X1=WORKT_X1!!(C!!(XTRA&15));! PASS MASK ON FOR JUMP
! SUITABLY AMENDED FOR BACK COMPARISON
%IF TYPE=1 %AND PTYPE>>4<=5 %THEN ->SW(3)
%IF TYPE=2%AND PTYPE>>4<=6 %THEN ->SW(4)
! COMPARISON OF MULTIREGISTER ITEMS
LOAD(OPNDC,-B3,2)
LOAD(OPNDNC,-B3,1)
EVALREG=OPNDC_XB
PUT(EVALREG,B1,0,NO,OPNDNC)
SET LOCAL BASE
D=GLABEL; GLABEL=GLABEL-1
PJUMP(BC,D,7,0)
PUT(EVALREG,B2,TYPE,YES,OPNDNC)
PLABEL(D)
%IF COMM=2 %THEN OPND1=OPND2
->SUSE
SW(15): ! SPECIAL MH FOR ARRAY ACCESS
! OPND1 IS SUBSCRIPT
! OPND2_D=CURRD<<24!MAXD<<16!DVDISP
! DVDISP=0 UNLESS BOUNDS ARE CONST
! OPND2_XTRA=BS<<16!DP FOR ARRAYHEAD
C=OPND2_D>>24; ! CURRENT DIMENSION
D=OPND2_D>>16&31; ! TOTAL NO OF DIMENSIONS
VMULTIPLY
->STRES
SW(18): ! BASE ADJUST ARRAY INDEX
! NOT USED FOR IBM AS HEAD ADJUSTED
->STRES
SW(19): ! ARRAY INDEX
! OPND1 THE ARRAYHEAD AS B&D
! OPND2 THE EVALUATED SUBSRCIPT(S)
! TOP 12 BITS OF XTRA HAVE ARRAY EL SIZE
! OR 0 FOR STRINGARRAYNAMES
WORKT==TRIPLES(CURRT_FLINK)
%IF CURRT_CNT=1 %START;
LOAD(OPND1,ANYGR BAR0,18)
D=OPND1_XB
%IF REGS(D)_CL>=0 %and REGS(d)_CNT<=1 %THEN REGS(D)_CL=2 %AND REGS(D)_LINK=ADDR(OPND1)
%IF OPND2_FLAG=SCONST %AND 0<=OPND2_D<=4095 %THEN %START
OPND1_D=OPND2_D
%FINISH %ELSE %START
LOAD(OPND2,ANYGR BAR0,18)
C=OPND2_XB
%IF REGS(C)_CL>=0 %and regs(c)_CNT<=1 %THEN REGS(C)_CL=2 %AND %C
REGS(C)_LINK=ADDR(OPND1)
OPND1_XB=D<<4!C
OPND1_D=0
%FINISH
OPND1_FLAG=11
%FINISH %ELSE %START
LOAD(OPND2,ANYGRBAR0,2)
LOAD(OPND1,ANY GR,17)
EVALREG=OPND2_XB
PUT(EVALREG,A,0,YES,OPND1)
OPERAND LOADED(OPND1,EVALREG)
%FINISH
->STRES
SW(20): ! INDEXED FETCH
! NO LONGER GENERATED BY PASS2
->STRES
SW(16): ! ASSIGN(=)
! ASSIGN(<-)
PT=XTRA&255; ! ORIGINAL PT OF LHS HERE
%IF PT=0 %THEN PT=CURRT_OPTYPE
TYPE=PT&15
TOPND=OPND1
EVALREG=-1; ! IN CASE SS ASSGNMNT MADE
%IF OPND1_FLAG=2 %START; ! OPERAND A NAME
TCELL==ASLIST(TAGS(OPND1_D))
%IF SSVARASS(BYTES(PT>>4),DISPREG(TCELL_UIOJ>>4&15),
TCELL_SLINK+OPND1_XTRA,OPND2)=NO %THEN %START
LOAD(OPND2,-B3,18)
EVALREG=OPND2_XB
DSTORE(EVALREG,BYTES(PT>>4),TCELL_UIOJ>>4&15,TCELL_SLINK+OPND1_XTRA)
%FINISH
%FINISHELSESTART; ! OPERAND A POINTER
LOAD(OPND2,-B3,18)
LOAD(OPND1,ANYGR BAR0,32)
EVALREG=OPND2_XB
GET OUT OF ACC(EVALREG,BYTES(PT>>4&7),OPND1)
OPERAND USED(OPND1)
%FINISH
%IF TOPND_XTRA<=0 %AND (TOPND_FLAG=DNAME %OR TOPND_FLAG=INDNAME) %C
%THEN NOTE ASSMENT(EVALREG,TRIPVAL-33,TOPND_D,PT)
OPND1=OPND2; ! IN CASE RESULT USED AGAIN
->STRES
SW(23): ! LOCAL ASSIGNMENT
EVALREG=-1
D=REGWORDS(PTYPE)>>4-1
%FOR C=0,1,MAXREG %CYCLE
%IF REGS(C)_USE=LOCALTEMP %AND OPND1_D&X'FFFF'<=REGS(C)_INF1&X'FFFF' %C
<= OPND1_D&X'FFFF'+BYTES(PTYPE>>4) %THEN FORGET(C)
%REPEAT
%IF SSVARASS(BYTES(PTYPE>>4&15),CLNB,OPND1_D&X'FFFF',
OPND2)=NO %THEN %START
%IF PTYPE=X'71' %THEN B3=-ANY4SEQ
LOAD(OPND2,-B3,2)
EVALREG=OPND2_XB
DSTORE(EVALREG,BYTES(PTYPE>>4&15),OPND1_D>>16,OPND1_D&X'FFFF')
SET USE(EVALREG+C,PTYPE,LOCAL TEMP,OPND1_D+C*BYTES(PTYPE>>4)) %C
%FOR C=0,1,D
%FINISH
OPERAND USED(OPND2)
OPND1_FLAG=7
->STRES
SW(24): ! COMPARIONS WITH ZERO (OPND2 ZERO)
WORKT==TRIPLES(CURRT_FLINK)
LOAD(OPND1,-B3,18)
EVALREG=OPND1_XB
%IF PTYPE=X'52' %THEN B1=B2
%IF PTYPE=X'61' %THEN PIX RX(B1,EVALREG,0,0,0) %ELSE %C
PIX RR(B1,REGCODE(EVALREG),REGCODE(EVALREG))
! OPERAND USED(OPND1)
->STRES
SW(25): ! SHIFT BY CONSTANT
D=OPND2_D; ! THE CONSTANT
%IF CURRT_OPERN=CASHIFT %THEN C=SLA %ELSE %C
%IF D>=0 %THEN C=SLL %ELSE C=SRL
%IF PTYPE=X'61' %THEN C=C+4; ! TO DOUBLE OPCODES
LOAD(OPND1,-B3,2)
EVALREG=OPND1_XB
PIX RS(C,EVALREG,0,0,IMOD(D))
FORGET(EVALREG)
->SUSE
SW(26): ! LONG INTEGER OPERATUION
! B3 IS THE MASK FOR CARRY
LOAD(OPNDC,ANY2SEQ,2)
EVALREG=OPNDC_XB
SET LOCAL BASE %UNLESS B3=0
PUT(EVALREG,B1,1,NO,OPNDNC); ! OPERATE ON L-S HALF
%IF B3>0 %START
PJUMP(BC,GLABEL,B3,0); ! JUMP ROUND CARRY
DUMPRX(B2,EVALREG,0,CTABLEREG,KWCONSTS(3));! CARRY OF 1
PLABEL(GLABEL)
GLABEL=GLABEL-1
%FINISH
PUT(EVALREG,B2,0,YES,OPNDNC)
%IF COMM=2 %THEN OPND1=OPND2
->SUSE
SW(27): ! FLOAT LONG INTEGER
CLAIM ALL4FRS
LOAD(OPND1,ANY2SEQ,2)
DUMPM(STM,OPND1_XB,OPND1_XB+1,WSPR,8)
DUMPRX(LD,4,0,CTABLEREG,KLCONSTS(6));! X'5C00000000000080'
DUMPRX(STD,4,0,WSPR,0)
OPERAND USED(OPND1)
PIX SS(XC,0,1,WSPR,7,WSPR,8)
PIX RR(SDR,6,6)
DUMPRX(LD,0,0,WSPR,0)
DUMPRX(LD,2,0,WSPR,8)
PIX RR(SXR,0,4)
FREE AND FORGET(18)
FREE AND FORGET(19)
FORGET(16)
FORGET(18)
EVALREG=16
OPND1_PTYPE=X'72'
->SUSE
SW(28): ! MULT & DIV LONG INTEGERS
LOAD(OPNDC,ANY2SEQ,2)
DUMPM(STM,OPNDC_XB,OPNDC_XB+1,WSPR,8)
OPERAND USED(OPNDC)
LOAD(OPNDNC,ANY2SEQ,2)
DUMPM(STM,OPNDNC_XB,OPNDNC_XB+1,WSPR,16)
OPERAND USED(OPNDNC)
PPJ(0,B3,YES)
EVALREG=0
REGS(0)_CL=1
REGS(1)_CL=1
->SUSE
SW(29): ! NEGATE LONG INTEGER
LOAD(OPND1,ANY2SEQ,2)
EVALREG=OPND1_XB
LNEGATE(EVALREG)
->SUSE
SW(30): ! LONGINTEGR ABS
%BEGIN
%INTEGER D
LOAD(OPND1,ANY2SEQ,2)
SET LOCAL BASE
EVALREG=OPND1_XB
PIX RR(LTR,EVALREG,EVALREG)
D=GLABEL; GLABEL=GLABEL-1
PJUMP(BC,D,10,0)
LNEGATE(EVALREG)
PLABEL(D)
%END
->SUSE
SW(31): ! BINARY EXTENDED OPERATION
LOAD(OPND1,-B3,2)
LOAD(OPND2,-B3,2)
EVALREG=OPND1_XB
IMPABORT %UNLESS OPND1_FLAG=9 %AND OPND2_FLAG=9
%IF B1>0 %THEN PIX RRE(B1<<8!B2,REGCODE(EVALREG),REGCODE(OPND2_XB)) %C
%ELSE PIX RR(B2,REGCODE(EVALREG),REGCODE(OPND2_XB))
OPERAND USED(OPND2)
FORGET(EVALREG)
FORGET(EVALREG+1)
->SUSE
TRIPSW(1): ! SET LINE NO
%BEGIN
%INTEGER I,LINE
LINE=OPND1_D>>16
PLINESTART(LINE) %UNLESS PARM_OPT=0 %AND PARM_DCOMP#0
%IF PARM_DBUG#0 %START
DUMPRX(LA,0,0,0,LINE)
PPJ(0,3,YES)
%FINISH %ELSE %IF PARM_LINE#0 %AND LINE#OLDLINE %START
PIX SI(MVI,LINE&255,CLNB,3)
%IF OLDLINE=0 %OR OLDLINE>>8#LINE>>8 %THEN %C
PIX SI(MVI,LINE>>8,CLNB,2)
OLDLINE=LINE
%FINISH
%IF PARM_PROF#0 %THEN %START
DUMPRX(LA,0,0,0,1)
I=PROFDATA+4+4*LINE
DUMPRX(ADD,0,0,GLAREG,I)
DUMPRX(ST,0,0,GLAREG,I)
FORGET(0)
%FINISH
%END
%CONTINUE
TRIPSW(2): ! RESTORE STACK POINTER
! USED AT BEGIN BLOCK EXIT ONLY
! OPND1_D HAS SAVE AREA OFFSET
D=WSPR
DFETCH(D,4,CURRINF_RBASE,OPND1_D)
%CONTINUE
TRIPSW(3): ! SAVE STACK POINTER
! OPND1 IS TEMPORARY(16 BITS) FOR SAVE
DSTORE(WSPR,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'
DESC=5<<27!3*(OPND1_D>>16)
TOPND_FLAG=SCONST; TOPND_PTYPE=X'51'
TOPND_D=OPND1_D>>16
LOAD(TOPND,ANY GR,2)
DUMPRX(ST,TOPND_XB,0,CLNB,D)
OPERAND USED(TOPND)
TOPND_FLAG=SCONST
TOPND_D=OPND1_D&X'FFFF'
LOAD(TOPND,ANY GR,2)
DUMPRX(ST,TOPND_XB,0,CLNB,D+8+C) %FOR C=0,12,12
! ELSIZE INTO DV AS ITSELF AND
! ALSO AS FIRST STRIDE
OPERAND USED(TOPND)
%CONTINUE
TRIPSW(71): ! END OF DOPE VECTOR
! OPND1_D=DVF<<16!ELSIZE
! OPND1_XTRA=PTYPE
! XTRA=ND<<16!DVDISP
PTYPE=OPND1_XTRA; ! DELARED ARRAY PTYPE
! 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
CLAIM THIS REG(0); ! SHOULD ALWAYS BE FREE HERE
PIX RR(SLR,0,0); ! AND SET IT TO ZERO
%FOR JJ=1,1,XTRA>>16 %CYCLE
%IF C&(1<<JJ)#0 %START; ! THIS LB NONZERO
B1=ANYGR
DUMPRXE(LGR,B1,0,CLNB,D+12*JJ)
REGS(B1)_CL=1
DUMPRX(MH,B1,0,CLNB,D+12*JJ+10);! STRIDE
PIX RR(SR,0,B1)
FREE AND FORGET(B1)
%FINISH
%REPEAT
%CONTINUE
TRIPSW(72): ! DV BOUND PAIR
! OPND1&2 ARE LB & UB RESPECTIVLY
! XTRA=CURRD<<24!ND<<16!DVDISP
C=XTRA>>16&255; ! NO OF DIMENSIONS
D=XTRA&X'FFFF'+12*(XTRA>>24); ! TRIPLE POSN
B1=X'80000000'
%IF OPND1_FLAG=SCONST %THEN B1=OPND1_D;! CONST LB
LOAD(OPND1,ANY GR,2); ! LB
DUMPRX(ST,OPND1_XB,0,CLNB,D)
LOAD(OPND2,ANY GR,2); ! UB
DUMPRX(ST,OPND2_XB,0,CLNB,D+4)
%IF B1=X'80000000' %THEN %START
PIX RR(SR,OPND2_XB,OPND1_XB)
DUMPRX(A,OPND2_XB,0,CTABLEREG,KWCONSTS(3));! F'1'
%FINISH %ELSE INC REG(OPND2_XB,1-B1,YES)
DUMPRX(MH,OPND2_XB,0,CLNB,D+10);! MULT BY STRIDE
FORGET(OPND2_XB)
%IF C#XTRA>>24 %THEN D=D+20 %ELSE D=XTRA&X'FFFF'+4;! NEXT MULTIPLIER
! BUT LAST MULTIPLIER = TOTSIZE
DUMPRX(ST,OPND2_XB,0,CLNB,D)
OPERAND USED(OPND1)
OPERAND USED(OPND2)
%CONTINUE
TRIPSW(4): ! DECLARE ARRAY
! OPND1=CDV<<31!C<<24!D<<16!DVDISP
! OPND1_XTRA HAS NAME
%BEGIN
%INTEGER DVDISP,B0,D0,ND
TCELL==ASLIST(TAGS(OPND1_XTRA))
ND=TCELL_UIOJ&15
%IF ND=2 %THEN D0=32 %ELSE D0=20;! STRIDE OFFSET FROM DV START
C=OPND1_D>>24&127
D=OPND1_D>>16&255
%IF C=0 %START; ! DV ADDR AND STRIDE
! SET UP FOR ALL ARRAYS
! ON FIRST DECL
DVDISP=OPND1_D&X'FFFF'
%IF OPND1_D>0 %START; ! DYNAMIC DOPE VECTOR
CLAIM THIS REG(JJ) %FOR JJ=1,1,3
DUMPRX(LA,2,0,CLNB,DVDISP)
DUMPRX(LGR,3,0,CLNB,DVDISP+D0)
%FINISH %ELSE %START
CLAIM THIS REG(JJ) %FOR JJ=0,1,3
B0=0
B0=B0-CTABLE(DVDISP>>2+3*JJ)*CTABLE(DVDISP>>2+3*JJ+2) %C
%FOR JJ=1,1,ND
%IF B0=0 %THEN PIX RR(SLR,0,0) %ELSE %C
DUMPRX(LGR,0,0,CTABLEREG,WORD CONST(B0))
DUMPRX(LA,2,0,CTABLEREG,DVDISP)
DUMPRX(LA,3,0,0,CTABLE((DVDISP+D0)>>2))
%FINISH
%FINISH %ELSE PIX RR(SR,0,1)
PIX RR(AR,0,WSPR)
PIX RR(LR,1,WSPR)
DSTORE(0,16,CURRINF_RBASE,TCELL_SLINK);! STORE AWAY HEAD
%IF C=D %START; ! LAST IN THIS STMNT
FREE AND FORGET(JJ) %FOR JJ=0,1,3
%FINISH
%END
%CONTINUE
TRIPSW(5): ! CLAIM ARRAY SPACE
! OPND1_D=CDV<<31!SNDISP!DVDISP
! OPND1_XTRA HAS THE ARRAY NAME
TCELL==ASLIST(TAGS(OPND1_XTRA))
PREC=TCELL_PTYPE>>4&15
D=OPND1_D&X'FFFF'
%IF OPND1_D>0 %START; ! DYNAMIC DOPE VECTOR
DUMPRX(A,WSPR,0,CLNB,D+4)
%IF PREC<6 %AND TCELL_ACC&7#0 %START
INC REG(WSPR,7,YES)
DUMPRX(N,WSPR,0,CTABLEREG,WORD CONST(-8))
%FINISH
%FINISHELSESTART; ! STATIC DOPE VECTORS
C=CTABLE(OPND1_D>>16&X'7FFF'+1); ! ARRAYSIZE IN BYTES
INC REG(WSPR,(C+7)&(-8),YES)
%FINISH
%CONTINUE
TRIPSW(6): ! CHECK FOR ZERO FOR STEP
LOAD(OPND1,ANY GR,2); ! STEP TO EVALREG
EVALREG=OPND1_XB
PIX RR(LTR,EVALREG,EVALREG)
PPJ(8,11,NO)
OPERAND USED(OPND1)
%CONTINUE
TRIPSW(7): ! FOR PREAMBLE
CLAIM THIS REG(1)
LOAD(OPND1,1,2); ! FORCE INITIAL TO GR1
FORGET(1)
REGS(1)_USE=1; ! FRIG TILL COUNTS WORK
%IF PARM_OPT=0 %AND TRIPLES(CURRT_PUSE)_OPERN=FORPOST %THEN %C
POLISH LOOP(CURRT)
%CONTINUE
TRIPSW(8): ! FOR POSTAMBLE
REGS(1)_CL=0
%FOR D=4,1,9 %CYCLE
%IF 1<<D&OPND1_D#0 %THEN REGS(D)_CL=0 %AND REGS(D)_CNT=0
%REPEAT
%CONTINUE
TRIPSW(9): ! VALIDATE FOR
LOADPAIR(1,0,OPND1); ! OPND1 IS FINAL-INIT
LOAD(OPND2,ANY GR,1); ! OPND2 IS STEP
EVALREG=OPND1_XB
PIX RX(SRDA,EVALREG,0,0,32)
PUT(EVALREG,DR+X'40',0,YES,OPND2)
PIX RR(LTR,EVALREG,EVALREG)
PPJ(7,11,NO)
REGS(EVALREG)_CL=0
FORGET(EVALREG)
REGS(EVALREG+1)_CL=0
FORGET(EVALREG+1)
%CONTINUE
TRIPSW(76): ! FOREND GET OPND1 TO RIGHT REG
CLAIM THIS REG(1)
LOAD(OPND1,1,2)
%CONTINUE
TRIPSW(10): ! BACK JUMP _X1 HAS TF&MASK
! OPND1_XTRA HAS LABEL CELL
LCELL==ASLIST(OPND1_XTRA)
C=LCELL_S1&X'FFFFFF'; ! ID OF THE LABEL
%IF OPND1_D&X'40000000'#0 %START;! ASSEMBLER JUMP VIA USING
D=XTRA&15
%IF D=0 %START
B=0
%IF XTRA>>8=LA %OR XTRA>>8=BAL %OR XTRA>>8=BAS %THEN B=XTRA>>4&15
PJUMP(XTRA>>8,C,XTRA>>4&15,B)
%FINISH %ELSE PJINDEX(XTRA>>8,C,XTRA>>4&15,D)
%FINISH %ELSE %START
B=BC
%IF XTRA&63=48 %THEN B=BCT %AND XTRA=1;! SPECIAL FOR FORS
D=FINDREG(GR1,0)
FORGET(D)
PJUMP(B,C,XTRA&15,D)
%FINISH
%CONTINUE
TRIPSW(11): ! FORWARD JUMP _X1 HAS TF&MASK
! OPND1_XTRA HAS LABEL CELL<<16!JUMP CELL
LCELL==ASLIST(OPND1_XTRA>>16)
%IF LCELL_S1&X'FFFF'=0 %THEN LCELL_S1=LCELL_S1!GLABEL %C
%AND GLABEL=GLABEL-1
B=BC
C=XTRA&63
D=OPND1_D>>24; ! ENTER JUMP FLAGS
%IF C=48 %AND D&X'40'=0 %THEN B=BCT %AND C=1
%IF D&X'40'#0 %START;! ASSEMBLER JUMP
C=XTRA&15; ! INDEX REG IN ASSEMBLER JUMP
%IF C=0 %START; ! JUMP HAS NO INDEX
B=0; ! NO OWRK REGISTER
%IF XTRA>>8=LA %OR XTRA>>8=BAS %OR XTRA>>8=BAL %THEN %C
B=XTRA>>4&15
PJUMP(XTRA>>8,LCELL_S1&X'FFFF',XTRA>>4&15,B)
%FINISH %ELSE %START
PJINDEX(XTRA>>8,LCELL_S1&X'FFFF',XTRA>>4&15,C)
%FINISH
%FINISH %ELSE %IF D&1#0 %OR REACHABLE(OPND1_D&X'FFFF',STPTR)=YES %START
SET LOCAL BASE
PJUMP(B,LCELL_S1&X'FFFF',C,0)
%FINISH %ELSE %START
D=FINDREG(GR1,0)
FORGET(D)
PJUMP(B,LCELL_S1&X'FFFF',C,D)
%FINISH
%IF D&2#0 %START; ! ENVIRONMENT MANIPULATION
%IF D&128#0 %START; ! FIRST JUMP TO THIS LAB
C=0; GET ENV(C)
%FINISH %ELSE %START
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) %C
%AND %EXIT
CELL==ASLIST(CELL)_LINK
%REPEAT
%END
%CONTINUE
TRIPSW(13): ! INSERT LABEL
! OPND1_XTRA HAS LABEL CELL
OLDLINE=0
LCELL==ASLIST(OPND1_XTRA)
JJ=LCELL_S2&X'FFFF'; ! UNFILLED JUMPS LIST
%WHILE JJ#0 %CYCLE; ! FILL FORWARD REFS
POP(JJ,B1,B2,B3); ! B1<0 IF SHORT JUMP PLANTED
%REPEAT
%IF LCELL_S1&X'FFFF'=0 %THEN LCELL_S1=LCELL_S1!GLABEL %C
%AND GLABEL=GLABEL-1
PLABEL(LCELL_S1&X'FFFF')
D=OPND1_D>>24; ! ENVIRONMENT MANIPULATION FLAGS
%IF D&2=0 %THEN FORGETM(14) %ELSE %START
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
%BEGIN
%RECORD(TRIPF)%NAME CTRIP,JTRIP,ADDTRIP,ASSTRIP
CTRIP==TRIPLES(STPTR); ! NEXT TRIP IC COMPARE
JTRIP==TRIPLES(CTRIP_FLINK); ! FOLLOWED BY CONDITIONAL JUMP
ADDTRIP==TRIPLES(JTRIP_FLINK); ! AND THEN ADDITION OF INC
ASSTRIP==TRIPLES(ADDTRIP_FLINK);! AND ASSIGNMENT
%IF XTRA&X'080002'=X'080002' %START;! INCREMENT IS 1
! CTRIP_X1=CTRIP_X1!X'80000000';! MARK TO USE CPIB
! ASSTRIP_OPND2=ADDTRIP_OPND1
! ADDTRIP_OPERN=NULLT
%FINISH
%END
%CONTINUE
TRIPSW(15): ! RT HEADING OPND1_D=RTNAME
! OPND1_XTRA=AXNAME OR 0
%BEGIN
%INTEGER W1,PCKWORD
W1=-1; PCKWORD=0; ! OPND1_XTRA=AXNAME #0 IF AN ENTRY
%IF OPND1_XTRA#0 %START; ! EXTERNAL NEEDS INITIALISE
%IF OPND1_D<0 %THEN %START; ! FIRST BEGIN OR MAIN ENTRY
C=1; ! FLAG MAIN ENTRY
%FINISH %ELSE %START; ! NOT MAIN ENTRY
C=0
TCELL==ASLIST(TAGS(OPND1_D))
D=TCELL_SLINK; ! TO PARAM CHAIN
%IF D>0 %THEN %START
PCKWORD=ASLIST(D)_S3
PCKWORD=(PCKWORD&X'FFF')<<16!PCKWORD>>16
%FINISH
%FINISH
PPROC(STRING(OPND1_XTRA),C<<31!1,PCKWORD,W1)
DUMPRX(LGR,CTABLEREG,0,GLAREG,24)
%IF OPND1_D<0 %START; ! MAIN PROG
DUMPRX(LGR,1,0,CTABLEREG,WORD CONST(X'08000000'))
PIX RR(SPM,1,0); ! SET PROGRAM MASK
%FINISH
%FINISH %ELSE %IF OPND1_D>=0 %THEN %C
PPROC(STRING(ADDR(WORKA_LETT(WORKA_WORD(OPND1_D)))),0,0,W1)
OLDLINE=0
%IF OPND1_D>=0 %START; ! ROUTINE PLANT INTERNAL ENTRY
TCELL==ASLIST(TAGS(OPND1_D))
D=TCELL_SNDISP; ! LIST OF OUTSTANDING JUMPS
%IF D=0 %THEN D=GLABEL %AND TCELL_SNDISP=D %AND GLABEL=GLABEL-1
PLABEL(TCELL_SNDISP)
%FINISH
PIX RX(ST,LINKREG,0,WSPR,60) %if opnd1_d>=0 %or opnd1_xtra#0
%END
%CONTINUE
TRIPSW(67): ! RDSPY CREATE DIPLAY OPND1_D=DISPLAY OFFSET
FORGETM(14)
PIX RR(LR,CLNB,WSPR)
REGS(CLNB)_CL=-1
REGS(CLNB)_USE=NAMEBASE
REGS(CLNB)_INF1=CURRINF_RBASE
CURRINF_SET=PMARKER(2); ! 2 HALF WORDS FOR ASF
%FOR JJ=0,1,CLNB-1 %CYCLE
IMPABORT %IF REGS(JJ)_CL#0
%REPEAT
%IF PARM_CHK#0 %THEN %START
DUMPRX(LA,1,0,0,CURRINF_PSIZE)
PPJ(0,4,YES)
%FINISH
%CONTINUE
TRIPSW(16): ! RDAREA - INITIALISE DAIGS AREA
! OPND1_D=N FOR DIAGS AREA
%CONTINUE
TRIPSW(17): ! RDPTR SET DAIGS POINTER
! OPND1_D=LEVEL NOT CURRINF ALWAYS
LINF==WORKA_LEVELINF(OPND1_D)
C=PMARKER(4)
PUSH(LINF_RAL,1,C,0); ! TO OVERWRITE LATER
PSETOPD(C,1,CLNB<<12)
PSETOPD(C,3,CLNB<<12!1)
%CONTINUE
TRIPSW(18): ! RTBAD FN-MAP ERROR EXIT
WORKT==TRIPLES(CURRT_BLINK); ! PREVIOUS TRIPLE
%CONTINUEIF WORKT_OPERN=RTXIT %OR WORKT_OPERN=XSTOP %OR %C
(WORKT_OPERN=BJUMP %AND WORKT_X1&15=15)
PPJ(15,10,NO)
%CONTINUE
TRIPSW(19): ! RTXIT - "%RETURN"
DUMPM(LM,4,LINKREG,CLNB,16)
PIX RR(BCR,15,LINKREG)
%IF OPND1_D#0 %THEN CEND %AND FORGETM(14)
%CONTINUE
TRIPSW(20): ! XSTOP - "%STOP"
CALL STOP
%IF OPND1_D#0 %THEN CEND
%CONTINUE
TRIPSW(61): ! %MONITOR
CLAIM THIS REG(0)
CLAIM THIS REG(1)
PIX RR(SLR,0,0); PIX RR(SLR,1,1)
REGS(0)_CL=0; REGS(1)_CL=0
PPJ(0,2,YES)
%CONTINUE
!***********************************************************************
!* SECTION FOR STRING CONCATENATION AND ASSIGNMENT *
!***********************************************************************
TRIPSW(21): ! PRECONCAT
! OPND1 IS WORK AREA
! OPND2 HAS FIRST STRING
D=OPND1_D&X'FFFF'; ! OFFSET OF WK AREA
%IF OPND2_FLAG=LCONST %START
LOAD(OPND2,ANY GR,1)
DUMPSS(MVC,OPND2_XTRA+1,CLNB,D,OPND2_XB,OPND2_D)
%FINISH %ELSE %START
LOAD(OPND2,ANY GR,1)
EVALREG=ANYGRBAR0
DUMPRXE(IC,EVALREG,0,OPND2_XB,OPND2_D)
SET USE(EVALREG,X'51',LITCONST,-1000)
REGS(EVALREG)_CL=-1
EXECUTESS(EVALREG,MVC,CLNB,D,OPND2_XB,OPND2_D)
REGS(EVALREG)_CL=0
%FINISH
OPERAND USED(OPND2)
OPND1_FLAG=7; ! RESULT IS LOCAL
%CONTINUE
TRIPSW(22): ! CONCATENATE OPND1 WORK AREA
! OPND2 THE NEXT BIT
%BEGIN
%INTEGER OLENREG,ALENREG,ADDREG
OPND1=TRIPLES(OPND1_D)_OPND1 %WHILE OPND1_FLAG=REFTRIP
D=OPND1_D&X'FFFF'; ! WOTF AREA OFFSET FROM LNB
OLENREG=ANYGRBAR0
DUMPRXE(IC,OLENREG,0,CLNB,D); ! LENGTH OF BIT IN WK AREA
SET USE(OLENREG,X'51',LITCONST,-1000)
REGS(OLENREG)_CL=-1
ADDREG=ANYGRBAR0
DUMPRXE(LA,ADDREG,CLNB,OLENREG,0);! PTR T0 STR END
REGS(ADDREG)_CL=-1
FORGET(ADDREG)
%IF OPND2_FLAG=LCONST %START; ! STRING LITERAL BEING ADDED
%IF OPND2_XTRA=1 %START
DUMPSI(MVI,WORKA_A(OPND2_D+1),ADDREG,D+1)
%FINISH %ELSE %START
LOAD(OPND2,ANY GR,1)
DUMPSS(MVC,OPND2_XTRA,ADDREG,D+1,OPND2_XB,OPND2_D+1)
%FINISH
DUMPRX(LA,OLENREG,0,OLENREG,OPND2_XTRA)
%FINISH %ELSE %START
LOAD(OPND2,ANY GR,1)
ALENREG=ANYGRBAR0
DUMPRXE(IC,ALENREG,0,OPND2_XB,OPND2_D);! LENGTH OF BIT TO BE ADDED
SET USE(ALENREG,X'51',LITCONST,-1000)
REGS(ALENREG)_CL=-1
EXECUTESS(ALENREG,MVC,ADDREG,D+1,OPND2_XB,OPND2_D+1)
PIX RR(AR,OLENREG,ALENREG)
REGS(ALENREG)_CL=0
%FINISH
DUMPRX(STC,OLENREG,0,CLNB,D); ! STORE NEW LENGTH
REGS(OLENREG)_CL=0
REGS(ADDREG)_CL=0
OPERAND USED(OPND2)
%END
%CONTINUE
TRIPSW(39): ! GENERAL STRING ASSIGN
! OPND1 IS A STRING POINTER
%BEGIN
%INTEGER XREG
LOAD(OPND1,ANY 2SEQ,2); ! PTR 2WORDS TO ANY CONSECUTIVE
%IF OPND2_FLAG=LCONST %START
%IF OPND2_XTRA=0 %START; ! NULL STRING ASSN
DUMPSI(MVI,0,OPND1_XB+1,0)
%FINISH %ELSE %START
LOAD(OPND2,ANY GR,1)
DUMPSS(MVC,OPND2_XTRA+1,OPND1_XB+1,0,OPND2_XB,OPND2_D)
%IF PARM_OPT#0 %START; ! CHECK LENGTH
XREG=SHORT CONST(OPND2_XTRA)
PIX RX(CH,OPND1_XB,0,CTABLEREG,XREG)
PPJ(4,9,NO)
%FINISH
%FINISH
%FINISH %ELSE %START
LOAD(OPND2,ANYGR BAR0,1); ! LHS TO ANY BAR 0
XREG=ANYGRBAR0
DUMPRXE(IC,XREG,0,OPND2_XB,OPND2_D)
SET USE(XREG,X'51',LITCONST,-1000)
REGS(XREG)_CL=-1
EXECUTESS(XREG,MVC,OPND1_XB+1,0,OPND2_XB,OPND2_D)
REGS(XREG)_CL=0
%IF PARM_OPT#0 %START
PIX RR(CR,XREG,OPND1_XB)
PPJ(2,9,NO)
%FINISH
%FINISH
OPERAND USED(OPND1)
OPERAND USED(OPND2)
%END
%CONTINUE
TRIPSW(40): ! SIMPLE STRING ASSIGN
TCELL==ASLIST(TAGS(OPND1_D))
LOAD(OPND1,ANY GR,1); ! LHS
SSTRASS(OPND1,OPND2,TCELL_ACC)
%CONTINUE
TRIPSW(41): ! STRING JT VIA SUBROUTINE
%BEGIN
%INTEGER XREG
LOAD(OPND1,ANY 2SEQ,2); ! PTR 2WORDS TO ANY CONSECUTIVE
LOAD(OPND2,ANYGR BAR0,1); ! LHS TO ANY BAR 0
XREG=ANYGRBAR0
DUMPRXE(IC,XREG,0,OPND2_XB,OPND2_D)
SET USE(XREG,X'51',LITCONST,-1000)
REGS(XREG)_CL=-1
PIX RR(BCTR,OPND1_XB,0)
PIX RR(CR,XREG,OPND1_XB); ! COMPARE LEN WITH LMAX
SET LOCAL BASE
PJUMP(BC,GLABEL,4,0)
PIX RR(LR,XREG,OPND1_XB)
PLABEL(GLABEL)
GLABEL=GLABEL-1
EXECUTESS(XREG,MVC,OPND1_XB+1,0,OPND2_XB,OPND2_D)
! MOVE CHARS PLUS GASH LENGTH BYTE
DUMPRX(STC,XREG,0,OPND1_XB+1,0);! OVERWRITE LB WITH CORRECT LB
REGS(XREG)_CL=0
OPERAND USED(OPND1)
OPERAND USED(OPND2)
%END
%CONTINUE
TRIPSW(46): ! STRING COMPARISONS INCL DSIDED
BFFLAG=0
WORKT==TRIPLES(CURRT_FLINK)
%IF OPND2_FLAG=LCONST %AND OPND2_XTRA=0 %THEN %C
OPND==OPND1 %AND ->NULLSC
%IF OPND1_FLAG=LCONST %AND OPND1_XTRA=0 %THEN %C
OPND==OPND2 %AND BFFLAG=1 %AND ->NULLSC
D=CURRT_X1&15; ! THE "NORMAL" IBM MASK
%IF 7<=D<=8 %START; ! = & # ARE EASIER
C=-1
%IF OPND1_FLAG=LCONST %THEN C=OPND1_XTRA
%IF OPND2_FLAG=LCONST %THEN C=OPND2_XTRA
LOAD(OPND1,ANY GR,1)
LOAD(OPND2,ANY GR,1)
%IF C>0 %THEN %START
DUMPSS(CLC,C+1,OPND1_XB,OPND1_D,OPND2_XB,OPND2_D)
%FINISH %ELSE %START
JJ=ANYGRBAR0
DUMPRXE(IC,JJ,0,OPND1_XB,OPND1_D)
REGS(JJ)_CL=1
SET USE(JJ,X'51',LITCONST,-1000)
EXECUTESS(JJ,CLC,OPND1_XB,OPND1_D,OPND2_XB,OPND2_D)
REGS(JJ)_CL=0
%FINISH
OPERAND USED(OPND1)
OPERAND USED(OPND2)
%CONTINUE
%FINISH
C=FINDSEQREG(GRPAIR,1)
LOAD(OPND1,ANY GR,1)
DUMPRX(LA,C,0,OPND1_XB,OPND1_D+1)
DUMPRX(IC,C+1,0,OPND1_XB,OPND1_D)
OPERAND USED(OPND1)
D=FINDSEQREG(GRPAIR,1)
LOAD(OPND2,ANY GR,1)
DUMPRX(LA,D,0,OPND2_XB,OPND2_D+1)
DUMPRX(IC,D+1,0,OPND2_XB,OPND2_D)
OPERANDUSED(OPND2)
PIX RR(CLCL,C,D)
%FOR JJ=0,1,1 %CYCLE
FREE AND FORGET(C+JJ)
FREE AND FORGET(D+JJ)
%REPEAT
%CONTINUE
NULLSC: ! TEST FOR A NULL STRING
LOAD(OPND,ANY GR,1)
D=FCOMP(CURRT_X1&15+16*BFFLAG)
DUMPSI(CLI,0,OPND_XB,OPND_D)
OPERAND USED(OPND)
%IF WORKT_OPERN=FJUMP %OR WORKT_OPERN=BJUMP %START
%IF WORKT_X1&X'80'#0 %THEN WORKT_X1=X'80'!(D!!X'F') %C
%ELSE WORKT_X1=D
%FINISH %ELSE IMPABORT
%CONTINUE
TRIPSW(47): ! PRE RESOLUTION 1
! OPND1 IS 4 WORD WK AREA
! OPND2 IS STRING BEING RESLVD
D=OPND1_D&X'FFFF'
C=FINDSEQREG(GRSEQ,1)
LOADAD(OPND2,C)
PIX RR(SLR,C+1,C+1)
DUMPM(STM,C,C+1,CLNB,D)
FREE AND FORGET(C)
FREE AND FORGET(C+1)
SET USE(C+1,X'51',LITCONST,0)
OPERAND USED(OPND2)
%CONTINUE
TRIPSW(48): ! PRE RESOLUTION 2
! OPND1 IS 4 WORD WK AREA
! OPND2 IS POINTER TO STRING TO HOLD
! FRAGMENT OR ZERO(=DISCARD FRGMNT)
RESTEMPAD=OPND1_D&X'FFFF'
%IF OPND2_FLAG=SCONST %START; ! NO STRING FOR FRAGMENT
PMVC(4,CLNB,RESTEMPAD+8,CODER,0)
%FINISHELSESTART
LOAD(OPND2,ANY GR,1)
DUMPRX(STH,OPND2_XB,0,CLNB,RESTEMPAD+6)
DUMPRX(ST,OPND2_XB+1,0,CLNB,RESTEMPAD+8)
OPERAND USED(OPND2)
%FINISH
%CONTINUE
TRIPSW(49): ! RESOLUTION
! OPND1 IS STRING RES EXPR
! OPND2 IS LABEL NO
LOADAD(OPND1,-1)
DUMPRX(ST,OPND1_XB,0,CLNB,RESTEMPAD+12)
OPERAND USED(OPND1)
CLAIM THIS REG(0)
DUMPRX(LA,0,0,CLNB,RESTEMPAD)
FREE AND FORGET(0)
PPJ(0,16,YES)
%IF OPND2_D=0 %THEN PPJ(7,12,NO); ! UNCONDITIONAL FAILS
%CONTINUE
TRIPSW(60): ! RESFN FINAL POST RES ASSIGN
! OPND2 HAS POINTER
! SINCE RESOLVED STRING MAY BE CONST
! CAN NOT USE NORMAL ASSIGN
%BEGIN
%INTEGER XREG,BREG,LB
D=OPND1_D&X'FFFF'; ! TO 4 WORD WK AREA
LOAD(OPND2,ANY 2SEQ,2); ! POINTER TO DR
XREG=ANYGRBAR0
DUMPRXE(IC,XREG,0,CLNB,D+4); ! ORIGINAL LHS LENGTH
REGS(XREG)_CL=1
SET USE(XREG,X'51',LITCONST,-1000)
BREG=ANYGRBAR0
DUMPRXE(IC,BREG,0,CLNB,D+5); ! BYTES USED UP
REGS(BREG)_CL=1
PIX RR(SR,XREG,BREG)
FORGET(BREG)
DUMPRX(A,BREG,0,CLNB,D); ! ADD IN ORIGINAL ADDRESS
%IF PARM_OPT#0 %START; ! FORCE IN CAP CHK
PIX RR(CR,OPND2_XB,XREG)
PPJ(12,9,NO); ! BLE FAIL
%FINISH
DUMPRX(STC,XREG,0,OPND2_XB+1,0);! ST LENGTH BYTE
SET LOCAL BASE
PIX RR(LTR,XREG,XREG)
PJUMP(BC,GLABEL,8,0)
PIX RR(BCTR,XREG,0)
PLABEL(GLABEL)
GLABEL=GLABEL-1
EXECUTESS(XREG,MVC,OPND2_XB+1,1,BREG,1)
REGS(XREG)_CL=0
REGS(BREG)_CL=0
OPERAND USED(OPND2)
%END
%CONTINUE
TRIPSW(68): ! INDEX STRING FOR CHARNO
! OPND1 32 BIT ADDRESS OF STR
! OPND2 THE INDEX
LOAD(OPND2,-2,2) %UNLESS OPND2_FLAG=SCONST %AND OPND2_D=0
LOAD(OPND1,-2,2)
EVALREG=OPND1_XB
%IF PARM_OPT#0 %AND OPND2_FLAG#SCONST %START
KK=ANYGR
DUMPRXE(IC,KK,0,EVALREG,0); ! FETCH CURRENT LENGTH
PIX RR(CLR,OPND2_XB,KK)
PPJ(2,9,NO)
SET USE(KK,X'51',LITCONST,-1000)
%FINISH
PIX RR(AR,EVALREG,OPND2_XB) %AND FORGET(EVALREG) %C
%UNLESS OPND2_FLAG=SCONST
OPERAND USED(OPND2)
OPND1_PTYPE=X'51'
->SUSE
!***********************************************************************
!* THIS NEXT SECTION DEALS WITH ROUTINE CALLS AND PARAMETER *
!* PASSING. ALSO STORING AND RECOVERY OF FN & MAP RESULTS *
!***********************************************************************
TRIPSW(23): ! IOCP CALL
D=OPND1_D
EVALREG=1
%IF REGS(1)_CL#0 %THEN EVALREG=-1
LOAD(OPND2,EVALREG,2)
OPERAND USED(OPND2)
CIOCP(D,OPND2_XB); ! ALWAYS CONSTANTS
EVALREG=1
OPERAND LOADED(OPND1,EVALREG)
->STRES
TRIPSW(24): ! PRECALL OPND1 HAS RT NAME
! TCELL==ASLIST(TAGS(OPND1_D))
CALL COMING(8)
LAST PAR REG=14; ! LAST PAREMETER REG
%CONTINUE
TRIPSW(25): ! ROUTINE CALL (AFTER PARAMS)
! OPND1 HAS RT NAME
%BEGIN
%RECORD(REGF)%NAME REG
TCELL==ASLIST(TAGS(OPND1_D))
C=TCELL_UIOJ>>4&15; ! ROUTINE LEVEL NO
DUMPM(STM,4,LAST PAR REG,WSPR,16)
FORGETM(8)
%IF TCELL_UIOJ&15=14 %START; ! EXTERNAL CALL
DUMPM(LM,CODER,EPREG,GLAREG,TCELL_SNDISP)
PIX RR(BALCODE-X'40',LINKREG,EPREG)
%FINISHELSEIF TCELL_PTYPE&X'400'#0 %START
DUMPRX(LGR,LINKREG,0,DISPREG(C),TCELL_SNDISP)
PIX RS(LM,CODER,LINKREG,LINKREG,0)
PIX RS(LM,5,10,LINKREG,20)
PIX RR(LR,1,EPREG)
PIX RX(LGR,EPREG,0,LINKREG,56)
PIX RR(BALCODE-X'40',LINKREG,1)
%FINISHELSE %START
JJ=TCELL_SNDISP
%IF JJ=0 %THEN JJ=GLABEL %AND TCELL_SNDISP=JJ %AND GLABEL=GLABEL-1
PJUMP(BALCODE,JJ,15,15)
%FINISH
%CYCLE C=4,1,CLNB-1
REG==REGS(C)
%IF ((1<<REG_PRIMUSE)!(1<<REG_SECUSE))&X'0600'#0 %C
%THEN FORGET(C)
%REPEAT
CALL MADE
%END
%CONTINUE
TRIPSW(44): ! MAP RESULT ASSIGNMENT
! CALLED BEFORE RETURN TO CALLER
D=1
RES: LOAD(OPND2,D,2)
OPERAND USED(OPND2)
%CONTINUE
TRIPSW(45): ! FN RESULT ASSIGNMENT
! CALLED BEFORE RETURN TO CALLER
D=RESULT REG(PTYPE)
->RES
TRIPSW(26): ! RECOVER FN RESULT
! CALLED AFTER RETURN TO CALLER
D=RESULT REG(PTYPE)
%IF PTYPE=X'35' %START; ! STRING FN
REGS(D)_CL=2
OPND1_FLAG=10
OPND1_XB=D
OPND1_D=0
%ELSE
OPERAND LOADED(OPND1,D)
%IF PTYPE=X'33' %THEN OPND1_PTYPE=X'51'
%FINISH
%CONTINUE
TRIPSW(27): ! RECOVER MAP RESULT
! CALLED AFTER RETURN TO CALLER
OPERAND LOADED(OPND1,1)
%CONTINUE
TRIPSW(28): ! PASS PARAMETER(1)= NORMAL VALUE
LCELL==ASLIST(OPND1_XTRA&X'FFFF'); ! PARAM DESCTR CELL
D=LCELL_ACC; ! PARAM_ACC
%IF OPND1_PTYPE&7=5 %START; ! STRINGS BY VALUE - LABORIOUS
LOAD(OPND2,ANY GR,1)
TOPND_PTYPE=X'51'; TOPND_FLAG=10
TOPND_XB=WSPR; TOPND_D=LCELL_SNDISP+64
SSTRASS(TOPND,OPND2,D)
FPPTR=FPPTR+D
%CONTINUE
%FINISH
%IF OPND1_PTYPE&7=3 %START; ! RECORD BY VALUE
C=(D+3)&(-4)
%IF OPND2_FLAG=SCONST %THEN D=0 %ELSE %C
D=1 %AND LOAD(OPND2,ANYGRBAR0,2)
BULKM(D,C,WSPR,LCELL_SNDISP+64,OPND2_XB,0)
OPERAND USED(OPND2)
%CONTINUE
%FINISH
D=BYTES(OPND1_PTYPE>>4&15)
%IF SSVARASS(D,WSPR,LCELL_SNDISP+64,OPND2)=YES %THEN ->PARDONE
%IF OPND1_PTYPE&7=2 %THEN C=-3 %ELSE C=-1
LOAD(OPND2,C,2)
EVALREG=OPND2_XB
->PARCHK
TRIPSW(29): ! GET 32 BIT ADDRESS
LOADAD(OPND1,ANYGRBAR0)
EVALREG=OPND1_XB
->SUSE
TRIPSW(30): ! GET POINTER FOR %NAME
%IF TYPE=5 %THEN EVALREG = ANY2SEQ %ELSE EVALREG=ANYGRBAR0
LOADPTR(OPND1,OPND2,EVALREG)
EVALREG=OPND1_XB
->SUSE
TRIPSW(31): ! PARAM PASSING (2) NORMAL PTRS
LCELL==ASLIST(OPND1_XTRA&X'FFFF')
PTYPE=OPND1_PTYPE&255; ! FOR PARAM
%IF PTYPE=X'35' %THEN C=ANY2SEQ %AND D=8 %ELSE C=ANYGR %AND D=4
LOAD(OPND2,C,2)
EVALREG=OPND2_XB
->PARCHK
TRIPSW(32): ! PARAM PASSING(3) ARRAYS
! ALSO (4) PASS RT PARAM SAME CODE
LCELL==ASLIST(OPND1_XTRA&X'FFFF')
%IF CURRT_OPERN=PASS4 %THEN C=ANYGR %AND D=4 %ELSE %C
%IF CURRT_OPERN=PASS5 %THEN C=ANY2SEQ %AND D=8 %ELSE %C
D=16 %AND C=ANY4SEQ
%IF SSVARASS(D,WSPR,LCELL_SNDISP+64,OPND2)=YES %THEN ->PARDONE
LOAD(OPND2,C,2)
EVALREG=OPND2_XB
PARCHK: ! KEEP AUTO STACKING CORRECT
C=LCELL_SNDISP+64
DSTORE(EVALREG,D,-1,C)
PARDONE: FPPTR=FPPTR+D
OPERAND USED(OPND2)
%CONTINUE
TRIPSW(69): ! PASS6 PASS WKAREA FOR STR&RECORDS
! NOT USED IN IBMIMP
%CONTINUE
TRIPSW(63): ! RTFP TURN RTNAME INTO FORMAL
TCELL==ASLIST(TAGS(OPND1_D))
EVALREG=ANYGR
%IF TCELL_PTYPE&X'400'#0 %START; ! NAM>0 PASS A FORMAL
DFETCH(EVALREG,4,TCELL_UIOJ>>4&15,TCELL_SNDISP)
%FINISHELSEIF TCELL_UIOJ&15=14 %START; ! EXTERNAL PASSED
DUMPRXE(LA,EVALREG,0,GLAREG,TCELL_SNDISP)
%FINISHELSE %START
GET WSP (D,4); ! PARAM INTO LOCAL
DUMPM(STM,CODER,GLAREG,CLNB,D)
DUMPRX(ST,WSPR,0,CLNB,D+12)
EVALREG=FINDREG(GR1,0)
FORGET(EVALREG)
JJ=TCELL_SNDISP
%IF JJ=0 %THEN JJ=GLABEL %AND TCELL_SNDISP=JJ %AND GLABEL=JJ-1
PJUMP(LA,JJ,EVALREG,EVALREG)
DUMPRX(ST,EVALREG,0,CLNB,D+8)
DUMPRX(LA,EVALREG,0,CLNB,D)
%FINISH
OPERAND LOADED(OPND1,EVALREG)
%CONTINUE
TRIPSW(66): ! TYPE GENERAL PARAMETER
! OPND1 THE ACTUAL
! OPND2 HAS PTYPE&ACC
%IF OPND1_FLAG=DNAME %AND OPND1_PTYPE&15=0 %START
JJ=FINDSEQREG(GRSEQ,1)
TCELL==ASLIST(TAGS(OPND1_D))
DFETCH(JJ,8,TCELL_UIOJ>>4&15,TCELL_SLINK)
%FINISH %ELSE %IF OPND2_D&7=5 %AND OPND2_D&X'C00'#0 %START
! STRING(ARRAY) NAMES
LOAD(OPND1,ANY2SEQ,2); ! OPND1 IS 64 BIT POINTER
JJ=OPND1_XB
PIX RS(SLL,JJ,0,0,16)
DUMPRX(O,JJ,0,CTABLEREG,WORD CONST(OPND2_D&255))
%FINISH %ELSE %START
JJ=FINDSEQREG(GRSEQ,1)
LOAD(OPND1,JJ+1,2); ! 32 BIT ADDRESS
TYPE=OPND2_D&7; PREC=OPND2_D>>4&7
DUMPRX(LGR,JJ,0,CTABLEREG,WORD CONST(OPND2_D&X'FFFF00FF'))
OPND1_PTYPE=X'61'
%FINISH
OPND1_FLAG=9
OPND1_XB=JJ
REGS(JJ)_LINK=ADDR(OPND1)
REGS(JJ+1)_LINK=ADDR(OPND1)
%CONTINUE
!***********************************************************************
!* SECTION TO DEAL WITH SWITCHES INCLUDING ->SW(EXP) *
!***********************************************************************
TRIPSW(33): ! DECLARE SWITCH OPND2 HAS BNDS
%BEGIN
%INTEGER D1,RANGE,LB
%INTEGERNAME SSTL
TCELL==ASLIST(TAGS(OPND1_D))
SSTL==CAS(4); ! TABLE BOUND FOR SST
SSTL=(SSTL+3)&(-4); ! WRD BNDRY
LB=OPND2_D
RANGE=OPND2_XTRA-LB+1
D1=SSTL-SWITEMSIZE*LB; ! POINTER TO ELEMENT ZERO
GLACA=(GLACA+3)&(-4)
PD4(2,GLACA,D1)
TCELL_SNDISP=(GLACA)>>2; ! REMEMBER POINTER LOCATION
RELOCATE(GLACA,D1,4); ! RELOCATE SST ADDRESS
GLACA=GLACA+4
C=WORKA_PLABS(6); ! DEFAULT
ASLIST(TCELL_SLINK)_S1=SSTL
PSWITCH(SSTL,LB,OPND2_XTRA,SWITEMSIZE);! DEFINE SWITCH IN SST
PSDEFAULT(SSTL,C); ! PLABS(6) IS DEFAULT
SSTL=SSTL+SWITEMSIZE*RANGE
%END
%CONTINUE
TRIPSW(34): ! SET SWITCH LABEL(OPND2)
OLDLINE=0
TCELL==ASLIST(TAGS(OPND1_D))
LCELL==ASLIST(TCELL_SLINK); ! SIDECHAIN HAS TDISP LB&UB
PSLABEL(LCELL_S1,OPND2_D)
FORGETM(14)
%CONTINUE
TRIPSW(35): ! GOTO SW LABEL
TCELL==ASLIST(TAGS(OPND1_D))
LCELL==ASLIST(TCELL_SLINK); ! ONTO DISP & BOUNDS
LOAD(OPND2,ANYGR BAR0,2)
D=OPND2_XB
C=TCELL_SNDISP
%IF PARM_ARR#0 %START
DUMPRX(CH,D,0,CTABLEREG,SHORT CONST(LCELL_S2));! CHK LB
PPJ(4,6,NO)
DUMPRX(CH,D,0,CTABLEREG,SHORT CONST(LCELL_S3));! CHK UB
PPJ(2,6,NO)
%FINISH
EVALREG=ANYGRBAR0
DUMPRXE(LGR,EVALREG,0,GLAREG,4*C); ! LOAD SST ENTRY
%IF SWITEMSIZE=2 %THEN PIX RR(AR,D,D) %ELSE PIX RS(SLL,D,0,0,2)
DUMPRX(LGR-32+8*SWITEMSIZE,EVALREG,EVALREG,D,0)
DUMPRX(BC,15,CODER,EVALREG,0)
FORGET(EVALREG)
FORGET(D)
OPERAND USED(OPND2)
%CONTINUE
TRIPSW(36): ! REAL TO INTEGER AS INT
C=BYTES(PTYPE>>4)
%IF C<=8 %START; ! REAL AND LONGREAL
LOAD(OPND1,ANY FR,2); ! TO ANY FR
DUMPRX(AD,REGCODE(OPND1_XB),0,CTABLEREG,LONGCONST(X'4080000000000000'))
FORGET(OPND1_XB)
%FINISH %ELSE %START; ! LONGLONGREALS
LOAD(OPND1,ANYFRPAIR,2)
D=OPND1_XB
C=CLAIM OTHER FRPAIR(D)
DUMPRX(LD,REGCODE(C),0,CTABLEREG,LONGCONST(X'4080000000000000'));! 0.5
PIX RR(SDR,REGCODE(C+1),REGCODE(C+1))
PIX RR(AXR,REGCODE(D),REGCODE(C))
FREEANDFORGET(C)
FREEAND FORGET(C+1)
FORGET(D)
FORGET(D+1)
%FINISH
TRIPSW(37): ! REAL TO INTEGER INTPT(OPND1)
%BEGIN
%INTEGER WREG,RWREG,LREG,RLREG,TEMP
PREC=PTYPE>>4
GETWSP(TEMP,2)
%IF PREC<=6 %START; ! REAL AND LONGREAL
LOAD(OPND1,ANY FR,2); ! TO ANY FR
LREG=OPND1_XB; RLREG=REGCODE(LREG)
WREG=FINDREG(FR0,1)
RWREG=REGCODE(WREG)
%IF PARM_OPT#0 %THEN %START
PIX RR(LPDR,RWREG,RLREG)
DUMPRX(CD,RWREG,0,CTABLEREG,LONGCONST(X'4880000000000000'))
PPJ(10,9,NO); ! THIS FAULT FIXING TO EXACTLY
! X80000000 !
%FINISH
PIX RR(LDR,RWREG,RLREG)
DUMPRX(AW,RWREG,0,CTABLEREG,KLCONSTS(1));! X'4E00000000000000'
SET LOCAL BASE
PIX RR(LTDR,RLREG,RLREG)
PJUMP(BC,GLABEL-1,10,0)
DUMPRX(AD,RWREG,0,CTABLEREG,KLCONSTS(0));! AD =D'0' TO RENORMALISE -VE
PIX RR(CDR,RLREG,RWREG); ! CHECK FOR TRUNCATION
PJUMP(BC,GLABEL,4,0)
DUMPRX(AW,RWREG,0,CTABLEREG,KLCONSTS(2));! AW X'4E00000100000000
PJUMP(BC,GLABEL-1,15,0)
PLABEL(GLABEL)
DUMPRX(AW,RWREG,0,CTABLEREG,KLCONSTS(3));! AW X'4E000000FFFFFFFF
PLABEL(GLABEL-1)
DUMPRX(STD,RWREG,0,CLNB,TEMP)
GLABEL=GLABEL-2
FREEAND FORGET(WREG)
REGS(LREG)_CL=0; ! UNCHANGED
TEMP=TEMP+4; ! RESULT IN LOWER WORD
%FINISH %ELSE %START; ! LONGLONG REALS
LOAD(OPND1,ANYFRPAIR,2)
LREG=OPND1_XB; RLREG=REGCODE(LREG)
WREG=CLAIM OTHER FR PAIR(LREG)
RWREG=REGCODE(WREG)
DUMPRX(LD,RWREG,0,CTABLEREG,KLCONSTS(4));! 2**63 NORMALISED
%IF PARM_OPT#0 %START; ! CHECK RANGE
PIX RR(LPDR,RWREG+2,RLREG)
PIX RR(CDR,RWREG+2,RWREG); ! CHECK MOD(X)<2**63 NB EXCLUDES
! -2**64 WHICH IS VALID
PPJ(10,9,NO)
%FINISH
DUMPRX(LD,RWREG,0,CTABLEREG,KLCONSTS(5));! X'5188000000000000'
PIX RR(SDR,RWREG+2,RWREG+2); ! CLEAR BOTTOM HALF
PIX RR(AXR,RLREG,RWREG); ! LREG=(X-2**63)+2**64
DUMPRX(STD,RLREG,0,WSPR,16)
DUMPRX(STD,RLREG+2,0,WSPR,24);! USE TOP OF STACK AS SPACE
DUMPSI(XI,X'08',WSPR,17); ! FLIP SIGN BIT
DUMPSS(MVC,2,WSPR,24,WSPR,25);! CLOSE UPPER MANTISSA
DUMPSS(MVO,X'99',WSPR,7,WSPR,17)
DUMPSS(MVC,8,CLNB,TEMP,WSPR,8);! BTM BYTE TOP OF LOWER WORD
FREE AND FORGET(LREG); FREE AND FORGET(LREG+1)
FREE AND FORGET(WREG); FREE AND FORGET(WREG+1)
%FINISH
OPND1_D=CURRINF_RBASE<<16!TEMP
OPND1_FLAG=7; ! UNDER LNB
OPND1_PTYPE=OPND1_PTYPE-X'11'
%END
%CONTINUE
TRIPSW(38): ! INTEGER TO STRING AS TOSTRING
GET WSP(D,1)
LOAD(OPND1,ANYGR,2)
DUMPRX(STC,OPND1_XB,0,CLNB,D+1)
DUMPSI(MVI,1,CLNB,D)
OPERAND USED(OPND1)
OPND1_FLAG=LOCALIR
OPND1_PTYPE=X'35'
OPND1_D=CURRINF_RBASE<<16!D
%CONTINUE
TRIPSW(42): ! ARRAYHEAD ASSIGNMENT
OPND2_PTYPE=X'71'; ! SO LOAD LOADS HEAD NOT ELEMNT
! AND DROP THRO TO PTR ASSGN
TRIPSW(43): ! POINTER ASSIGNMENT
D=BYTES(OPND2_PTYPE>>4&15)
%IF D=16 %THEN C=ANY4SEQ %ELSE %IF D=8 %THEN C=ANY2SEQ %ELSE C=ANYGR
%IF OPND1_FLAG=DNAME %START; ! LOCAL PTR
TCELL==ASLIST(TAGS(OPND1_D))
EVALREG=-1
%IF SSVARASS(D,DISPREG(TCELL_UIOJ>>4&15),TCELL_SLINK+OPND1_XTRA,
OPND2)=NO %THEN %START
LOAD(OPND2,C,2)
EVALREG=OPND2_XB
DSTORE(EVALREG,D,TCELL_UIOJ>>4&15,TCELL_SLINK+OPND1_XTRA)
%FINISH
%IF OPND1_XTRA=0 %THEN NOTE ASSMENT(EVALREG,1,OPND1_D,OPND2_PTYPE&X'F0'!1)
%FINISH %ELSE %START
LOAD(OPND2,C,2)
EVALREG=OPND2_XB
LOADAD(OPND1,ANYGRBAR0)
%IF D=4 %THEN DUMPRX(ST,EVALREG,0,OPND1_XB,0) %ELSE %C
DUMPRX(STM,EVALREG,EVALREG+(D-4)>>2,OPND1_XB,0)
OPERAND USED(OPND1)
%FINISH
OPERAND USED(OPND2)
%CONTINUE
TRIPSW(62): ! RECORD ASSIGNMENT
LOAD(OPND1,ANYGRBAR0,18)
%IF OPND2_FLAG=SCONST %THEN %START
BULKM(0,CURRT_X1,OPND1_XB,0,0,OPND2_D)
%FINISH %ELSE %START
LOAD(OPND2,ANYGRBAR0,18)
BULKM(1,CURRT_X1,OPND1_XB,0,OPND2_XB,0)
OPERAND USED(OPND2)
%FINISH
OPERAND USED(OPND1)
%CONTINUE
TRIPSW(64): ! AAINC INCREMENT RECORD RELATIVE
! ARRAY ACCESS BY RECORD BASE(OPND1)
! TO GIVE ABSOLUTE ACCESS.
%IF OPND1_FLAG=SCONST %THEN %START
LOAD(OPND2,ANYGRBAR0,0)
%IF OPND2_FLAG=11 %THEN %C
OPND2_D=OPND2_D+OPND1_D %AND OPND1=OPND2 %AND ->STRES
%IF OPND2_FLAG#9 %THEN LOAD(OPND2,ANYGRBAR0,18)
%IF OPND2_FLAG=9 %AND OPND2_XB>0 %START
OPND2_FLAG=11; OPND2_D=OPND1_D
OPND1=OPND2
->STRES
%FINISH
%FINISH
LOAD(OPND1,ANYGRBAR0,2); ! THE RECORD BASE
LOAD(OPND2,ANYGR,1); ! THE RELATIVE ACCESS
EVALREG=OPND1_XB
PUT(EVALREG,A,0,YES,OPND2)
FORGET(EVALREG)
OPERAND USED(OPND1)
OPND1=OPND2
->SUSE
TRIPSW(65): ! AHADJ ARRAY MAPPING OPND1 1
! HAS ADJUSTMENT OPND2 THE HEAD
! ARRAY PTYPE<<4!MODE IS IN CURRT_X1
OPND2_PTYPE=X'71'
D=CHECKSEQREG(NEGREG(ANY4SEQ));! CHECK FOUR REGS AVAILABLE
! OPND1 MIGHT BE ARRAY ELEAMENT
%IF D<0 %START; ! 4 REGS NOT AVAILABLE
LOAD(OPND1,ANYGR,2); ! FETCH OPND1
BOOT OUT(OPND1_XB); ! AND PUT INTO LOCAL SPACE
%FINISH
LOAD(OPND2,ANY4SEQ,2); ! HEAD TO 4 GENERAL REGS
LOAD(OPND1,ANY GR,1); ! BASE ADDRESS OR ADJMNT
EVALREG=OPND2_XB; ! THE LOWEST OF 4 GRS
%IF CURRT_X1&1=0 %START; ! ARRAY MAPPING OPND1 IS BASE
PIX RR(SR,EVALREG,EVALREG+1)
LOAD(OPND1,EVALREG+1,2)
PIX RR(AR,EVALREG,EVALREG+1)
%FINISH %ELSE %START
PUT(EVALREG,A,0,NO,OPND1)
PUT(EVALREG+1,A,0,YES,OPND1)
FORGET(EVALREG+1)
%FINISH
FORGET(EVALREG)
OPERAND USED(OPND1)
OPND1_PTYPE=X'71'
->SUSE
TRIPSW(73): ! ON EVENT 1 BEFORE THE TRAP
! SAVE PSW ETC
DUMPRX(ST,WSPR,0,CLNB,CURRINF_ONINF+12)
! AUXSTACK USED NOTE TOP
D=FINDREG(GR0,1)
%IF TARGET#IBMXA %THEN PIXRR(BALR,D,0) %ELSE PIX RRE(IPM,D,0)
DUMPRX(ST,D,0,CLNB,CURRINF_ONINF+8)
REGS(D)_CL=0
%CONTINUE
TRIPSW(74): ! ON EVENT 2 TRAP ENTRYPOINT
FORGETM(14)
GLACA=(GLACA+3)&(-4)
PD4(2,GLACA,0)
C=PMARKER(0)
PFIX(2,GLACA,1,C); ! GLAWORD TO ON ENTRY ADDRESS
CURRINF_ONWORD=CURRINF_ONWORD!(GLACA)
GLACA=GLACA+4
CLAIM THIS REG(0)
CLAIM THIS REG(1)
DUMPM(STM,0,1,CLNB,CURRINF_ONINF)
DUMPRX(LGR,1,0,CLNB,CURRINF_ONINF+8)
PIX RR(SPM,1,0)
DUMPRX(LGR,WSPR,0,CLNB,CURRINF_ONINF+12)
REGS(0)_CL=0
REGS(1)_CL=0
%CONTINUE
TRIPSW(75): ! SIGEV SIGNAL EVENT&SUBEVENT
! OPND1_D HAS SIGNAL LEVEL
! OPND2(COMPUTED) HAS EVENT ETC
CLAIM THIS REG(0)
CLAIM THIS REG(1)
LOAD(OPND2,1,2)
LINF==WORKA_LEVELINF(OPND1_D)
%IF LINF##CURRINF %START
%IF CURRINF_FLAG<=2 %START
C=PMARKER(4)
PUSH(LINF_RAL,1,C,0)
PSETOPD(C,1,CLNB<<12)
PSETOPD(C,3,CLNB<<12!1)
%FINISH %ELSE %START
DUMPM(LM,4,10,CLNB,16); ! OTHERWISE FRIG DISPLAY
%FINISH
%FINISH
REGS(0)_CL=0
REGS(1)_CL=0
PPJ(0,2,YES); ! MONITOR
%CONTINUE
!***********************************************************************
!* SECTION FOR GENERATING CODE FOR INLINE ASSEMBLER *
!***********************************************************************
TRIPSW(50): ! UC NOOP
PCNOP(OPND1_D>>8,OPND1_D&255)
%CONTINUE
TRIPSW(51): ! UCB1 ONE REGISTER ASSEMBLER
C=OPND1_D>>16
%IF C=X'FF01' %THEN USINGR=OPND1_D&15 %AND PUSING(USINGR) %AND %CONTINUE
%IF C=X'FF02' %THEN PDROP(USINGR) %AND USINGR=12 %AND %CONTINUE
%IF C=SVC %THEN PIX RR(SVC,OPND1_D>>4&15,OPND1_D&15) %AND %CONTINUE
TRIPSW(52): ! UCB2 TWO REG RR &RRE ASSEMBLER
C=OPND1_D>>16; D=OPND1_D&15; ! D IS REG1
%IF (TARGET=IBM %OR(HOST=EMAS %AND PARM_BITS1&1#0)) %AND C=BASR %THEN C=BALR
%IF C>255 %THEN PCODEWORD(C<<16!D<<4!OPND1_D>>8&15) %ELSE %C
PCODEHALF(C<<8!D<<4!OPND1_D>>8&15)
FORGETM(14)
%CONTINUE
TRIPSW(53): ! UCB3 RX ASSEMBLER
LOAD(OPND1,ANYGR,1)
! XTRA HAS OPCODE,R1 &INDEX
! OPND HAS DB NOW IN FLAG=10 FORM
C=XTRA>>16
%IF (TARGET=IBM %OR(HOST=EMAS %AND PARM_BITS1&1#0)) %AND C=BAS %THEN C=BAL
PIX RX(C,XTRA&15,XTRA>>8&15,OPND1_XB,OPND1_D)
FORGETM(14)
%CONTINUE
TRIPSW(54): ! UCW ASSEMBLER WITH STORE OR SI FORMAT
LOAD(OPND1,ANYGR,1)
C=XTRA>>16
%IF C>255 %OR C=LPSW %OR C=SSM %OR C=TS %THEN %C
PIX S(C,OPND1_XB,OPND1_D) %ELSE PIX SI(C,XTRA&255,OPND1_XB,OPND1_D)
FORGETM(14)
%CONTINUE
TRIPSW(55): ! UCBW BYTE&WORD OPERAND ASSEMBLER
! IBM SS &SSE FORMATS
C=XTRA>>16
LOAD(UOPND,ANYGR,1)
LOAD(OPND1,ANYGR,1)
%IF C>255 %THEN PIX SSE(C,UOPND_XB,UOPND_D,OPND1_XB,OPND1_D) %C
%ELSE PIX SS(C,0,XTRA&X'1FF',UOPND_XB,UOPND_D,OPND1_XB,OPND1_D)
FORGETM(14)
%CONTINUE
TRIPSW(59): ! UCNAM ACCESS TO NAMES FROM U-C
! IN IBM PASSES IST OPERAND OF 2OPND
! SS INSTRUCTIONS SINCE PORTABLE ASSEMBLER
! ONLY ALLOWS ONE OPERAND FORMATS
UOPND=OPND1; ! SAVE IN OWN VARAIBLE
%CONTINUE
STRES:
CURRT_OPTYPE<-OPND1_PTYPE
%IF CURRT_CNT>1 %START
! USED MORE THAN ONCE, IN A REG
%IF CURRT_OPERN#LASS %START
! AND NOT ALREADY STORED
%IF OPND1_FLAG#9 %START
D=(CURRT_OPTYPE&7-1)*8+CURRT_OPTYPE>>4&7
LOAD(OPND1,-WHICHREG(D),2)
%FINISH
EVALREG=OPND1_XB
REGS(EVALREG)_CNT=CURRT_CNT
%IF CURRT_FLAGS&USED LATE #0 %THEN BOOT OUT(EVALREG)
%FINISH %ELSE %START
! LASS EVALREG=OPND2_XB!
REGS(EVALREG)_CL=0
C=BYTES(CURRT_OPTYPE>>4)<<24!CURRINF_RBASE<<16!OPND1_D
SET USE(EVALREG,CURRT_OPTYPE,LOCALTEMP,C)
%FINISH
%FINISH
%IF CURRT_CNT=0 %THEN OPERAND USED(OPND1)
%REPEAT
%IF PARM_DCOMP#0 %THEN CODEOUT
%RETURN
%ROUTINE SET LOCAL BASE
!***********************************************************************
!* FIND OR SET UP A REGISTER FOR BRANCHING A SMALL DISTANCE FORWARD *
!***********************************************************************
%INTEGER I,J,LOCAL BASE
%CONSTBYTEINTEGERARRAY CHOICE(0:9)=15,9,8,7,6,5,4,3,2,1;
%RECORD(REGF)%NAME REG
LOCAL BASE=CODER
%IF 4095-MARGIN>CA %THEN %RETURN; ! CAN USE MAIN BASE REGISTER(GR12)
%CYCLE J=0,1,9
I=CHOICE(J)
REG==REGS(I)
%IF REG_USE=BASEREG %AND 4095-MARGIN>CA-REG_INF1 %START
LOCAL BASE=I
REG_AT=WTRIPNO
%RETURN
%FINISH
%REPEAT
LOCAL BASE=FIND REG(GR1,0)
PIX RR(BALCODE-X'40',LOCAL BASE,0)
SET USE(LOCAL BASE,X'51',BASEREG,CA)
PUSING(LOCAL BASE)
%END; ! OF ROUTINE SET LOCAL BASE
%ROUTINE LOAD(%RECORD(RD) %NAME OPND,%INTEGER REG,MODE)
!***********************************************************************
!* DEVELOP OPERAND OPND WITH OPTIONAL LOAD TO SPECIFIC REG *
!* MODE=0 DEVELOP OPERAND ONLY *
!* MODE=1 DEVELOP OPERAND AND DEAL WITH "LA" CONST AND OPERAND FORM*
!* MODE=2 DEVELOP OPERAND AND LOAD INTO SPECIFIED REG *
!***********************************************************************
%INTEGER K,KK,D,PTYPE,PREC,TYPE,USE,INF,LEAVEINSTR,READONLY,X
%RECORD(TRIPF) %NAME REFTRIP
%RECORD(REGF)%NAME REQREG
%RECORD(TAGF) %NAME TCELL
%SWITCH SW(0:11)
USE=0; INF=0
K=OPND_FLAG
X=OPND_XTRA
PTYPE=OPND_PTYPE
TYPE=PTYPE&15
PREC=PTYPE>>4&15
LEAVEINSTR=MODE&32
READONLY=MODE&16; MODE=MODE&15
%IF REG>=0 %THEN REQREG==REGS(REG)
%IF K>11 %THEN IMPABORT
->SW(K)
SW(0): ! CONSTANT < 16 BITS
%IF TYPE=1 %AND PREC<=5 %AND 0<=OPND_D<=4095 %START
%RETURN %IF MODE=0; ! LAVE "LA" CONSTS
USE=LITCONST; INF=OPND_D
FIND USE(D,X'51',USE,INF)
%IF D>=0 %THEN OPERAND RELOADED(OPND,D) %AND ->SW9
%IF MODE=2 %THEN %START
%IF REG<0 %THEN %START
REG=FIND REG(NEGREG(REG),0)
REQREG==REGS(REG)
%FINISH %ELSE %START
%IF REQREG_USE=USE %AND REQREG_INF1=INF %THEN ->LDED
%FINISH
%IF INF=0 %THEN PIX RR(SLR,REG,REG) %ELSE DUMPRX(X'41',REG,0,0,INF)
->LDED
%FINISH
%FINISH
SW(1):
! LONG CONSTANT
%IF TYPE=5 %THEN ->SCONST
%IF PREC=7 %THEN KK=ADDR(WORKA_A(OPND_D)) %ELSE KK=ADDR(OPND_D)
%IF TYPE=1 %AND PREC=5 %AND MODE=2 %AND K=0 %AND X'FFFF8000'<=OPND_D<=X'7FFF' %C
%THEN PREC=4 %AND PTYPE=X'41' %AND OPND_PTYPE=PTYPE
%IF PREC=4 %THEN KK=KK+2
STORE CONST(D,BYTES(PREC),KK)
OPND_FLAG=10; OPND_XB=CTABLEREG
OPND_D=D
USE=6; INF=D
->OPTLOAD
SCONST: ! STRING CONSTANT OPND_DIS AR PTR
STORE STRING(D,STRING(ADDR(WORKA_A(OPND_D))))
OPND_FLAG=10
OPND_D=D
OPND_XB=CTABLEREG
->OPTLOAD
SW(3): ! 128 BIT CONSTANT
IMPABORT
SW(2): ! NAME (+POSSIBLE OFFSET)
TCELL==ASLIST(TAGS(OPND_D))
OPND_FLAG=10
%IF X<=0 %AND TCELL_PTYPE&15<3 %THEN USE=9 %AND INF=OPND_D
OPND_XB=DISPREG(TCELL_UIOJ>>4&X'F')
OPND_D=TCELL_SLINK+X
OPND_XTRA=0
->OPTLOAD
LDED:
SET USE(REG,PTYPE,USE,INF)
NULLOAD:
OPERAND LOADED(OPND,REG)
%RETURN
SW(4): ! VIA DESC AT OFFSET FROM
! A COMPUTED POINTER
REFTRIP==TRIPLES(OPND_D)
OPND=REFTRIP_OPND1
LOAD(OPND,ANYGRBAR0,2)
D=OPND_XB
%IF X<0 %THEN X=0
%IF TYPE=5 %THEN X=X+4
KK=ANYGRBAR0
DUMPRXE(LGR,KK,0,D,X)
OPERAND USED(OPND)
OPND_PTYPE=PTYPE&255
OPND_FLAG=10; OPND_XB=KK
REGS(KK)_CL=2
REGS(KK)_CNT=1
REGS(KK)_LINK=ADDR(OPND)
FORGET(KK)
OPND_XTRA=0
->OPTLOAD
SW(5): ! INDIRECT VIA DICTIONARY
! ONLY RECORDNAME SCALAR(_XTRA>=0)
! OR POINTER(_XTRA<0)
TCELL==ASLIST(TAGS(OPND_D))
D=TCELL_SLINK
%IF TYPE=5 %AND X<0 %THEN D=D+4
INF=OPND_D
FIND USE(KK,X'51',ADDROF,INF)
%IF KK>0 %THEN %START
%IF REGS(KK)_CL#0 %THEN REGS(KK)_CNT=REGS(KK)_CNT+1
%FINISH %ELSE %START
KK=ANYGRBAR0
DUMPRXE(LGR,KK,0,DISPREG(TCELL_UIOJ>>4&15),D)
%FINISH
SET USE(KK,X'51',ADDROF,INF)
OPND_XB=KK
REGS(KK)_CL=2 %AND REGS(KK)_CNT=1 %IF REGS(KK)_CL=0
OPND_FLAG=10
%IF X>=0 %THEN OPND_D=X %ELSE OPND_D=0 %AND USE=LOCALVAR
->OPTLOAD
SW(6): ! INDIRECT WITH OFFSET
REFTRIP==TRIPLES(OPND_D)
OPND=REFTRIP_OPND1
%IF X<0 %THEN X=0
%IF OPND_FLAG=11 %START
OPND_FLAG=10
OPND_D=OPND_D+X
%FINISH %ELSE %START
LOAD(OPND,ANYGRBAR0,18)
D=OPND_XB
REGS(D)_CL=2 %IF REGS(D)_CL=0
REGS(D)_LINK=ADDR(OPND)
OPND_FLAG=10
OPND_XB=D
OPND_D=X
%FINISH
OPND_PTYPE=PTYPE&255
->OPTLOAD
SW(7): ! I-R IN A STACK FRAME
USE=LOCALTEMP
INF=OPND_D
%IF PREC#5 %THEN INF=BYTES(PREC)<<24!INF
OPND_FLAG=10
OPND_XB=DISPREG(OPND_D>>16)
OPND_D=OPND_D&X'FFFF'
->OPTLOAD
SW(8): ! TRIPLE
REFTRIP==TRIPLES(OPND_D)
OPND=REFTRIP_OPND1
LOAD(OPND,REG,READONLY!MODE)
OPND_PTYPE=PTYPE&255
%RETURN
SW(9):SW9: ! I-R IN A REGISTER
! MAY NEED SHUFFLED
%IF MODE=2 %START
%IF REGS(OPND_XB)_CL>=0 %AND REGS(OPND_XB)_CNT<=1 %THEN %START
%IF OPND_XB=REG %THEN REQREG_LINK=ADDR(OPND) %AND %RETURN
%IF REG<0 %AND ACCEPTABLE REG(NEGREG(REG),OPND_XB)=YES %THEN %C
REG=OPND_XB %AND REQREG==REGS(REG) %AND ->NULLOAD
%FINISH
%IF READONLY#0 %AND REG<0 %AND %C
ACCEPTABLE REG(NEGREG(REG),OPND_XB)=YES %THEN %RETURN
%IF REG<0 %THEN REG=FINDREG(NEGREG(REG),0) %AND REQREG==REGS(REG)
%IF REG<=15 %THEN KK=LR %ELSE KK=LDR
PIX RR(KK,REGCODE(REG),REGCODE(OPND_XB))
COPY USE(REG,OPND_XB)
%IF PTYPE=X'61' %OR PTYPE=X'72' %THEN %C
PIX RR(KK,REGCODE(REG+1),REGCODE(OPND_XB+1)) %AND COPY USE(REG+1,OPND_XB+1)
OPERAND USED(OPND)
->NULLOAD
%FINISH
%RETURN
OPTLOAD:
%IF USE>0 %AND LEAVEINSTR=0 %THEN %START
FIND USE(D,OPND_PTYPE&255,USE,INF)
%IF D>0 %AND (READONLY#0 %OR REGS(D)_CL=0) %THEN %C
OPERAND USED(OPND) %AND OPERAND RELOADED(OPND,D) %AND ->SW9
%FINISH
SW(10): ! DEVELOPPED BD FORM
%IF MODE=2 %THEN %START
%IF TYPE=5 %THEN LOADAD(OPND,REG) %AND %RETURN
GETINACC(REG,BYTES(PREC),OPND)
OPERAND USED(OPND)
REQREG==REGS(REG)
->LDED
%FINISH
%IF TYPE=5 %AND OPND_XB>15 %THEN REDUCE BASE(OPND)
%RETURN
SW(11): ! OPERAND IS CONSTRUCTED BY
! DOING A LA ON OPERAND
%IF MODE>0 %START
DUMPRXE(LA,REG,OPND_XB>>4,OPND_XB&15,OPND_D)
OPERAND USED(OPND)
REQREG==REGS(REG)
->LDED
%FINISH
%END
%ROUTINE LOAD PAIR(%INTEGER TYPE,ODDEVEN,%RECORD(RD)%NAME OPND)
!***********************************************************************
!* THIS ROUTINE LOADS OPERAND INTO AN EVEN-ODD PAIR *
!* THE PAIR IS CLAIMED AS LATE AS POSSIBLE *
!***********************************************************************
%INTEGER PAIR,TOTHER
LOAD(OPND,ANY GR,0); ! IN STORE UNLESS RT ETC
-> IN STORE %UNLESS OPND_FLAG=9
TOTHER=OPND_XB!!1
-> INSTORE %UNLESS REGS(TOTHER)_CL=0
PAIR=TOTHER&X'FE'
%IF ODDEVEN+PAIR=TOTHER %THEN LOAD(OPND,TOTHER,2)
REGS(PAIR)_CL=1
REGS(PAIR+1)_CL=1
FORGET(PAIR)
FORGET(PAIR+1)
->FIN
INSTORE:
PAIR=FINDSEQREG(NEGREG(-4-TYPE),1)
LOAD(OPND,PAIR+ODDEVEN,2)
FIN: OPND_XB=PAIR; ! ALWAYS LH MEMBER
%END
%ROUTINE LOADAD(%RECORD(RD) %NAME OPND,%INTEGER REG)
!***********************************************************************
!* MUCH AS LOAD BUT PRODUCES THE 32 BIT ADDRESS OF OPERAND *
!* IMPABORT ON NON RELEVANT ALTERNATIVES OF OPND *
!************************************************************************
%RECORD(TRIPF)%NAME REFTRIP
%RECORD(TAGF) %NAME TCELL
%INTEGER B,D,TYPE,X,USE,INF
%SWITCH SW(0:11)
TYPE=OPND_PTYPE&7
X=OPND_XTRA
USE=0; INF=0
->SW(OPND_FLAG)
SW(*): ! INVALID
IMPABORT
SW(0):SW(1): ! ADDR OF CONSTANTS NEEDED ON IBM
LOAD(OPND,ANY GR,1)
->SW10
SW(2): ! DNAME
%IF X<=0 %THEN USE=ADDROF %AND INF=OPND_D
TCELL==ASLIST(TAGS(OPND_D))
D=-1
%IF X<=0 %THEN FIND USE(D,X'51',USE,INF)
%IF D>0 %AND (D=REG %OR (REG<0 %AND ACCEPTABLE REG(NEGREG(REG),D)=YES)) %C
%THEN REG=D %AND ->LDED
DFETCHAD(REG,TCELL_UIOJ>>4&15,TCELL_SLINK+X)
LDED:
OPND_PTYPE=X'51'; ! 32 BIT ADDRESS IS INTEGER
OPERAND LOADED(OPND,REG)
SET USE(REG,X'51',USE,INF)
%RETURN
SW(4): ! VIA PTR AT OFFSET FROM
! COMPUTED EXPRESSION
REFTRIP==TRIPLES(OPND_D)
OPND=REFTRIP_OPND1; ! MUST COPY FOR MULTIPLY USED OPNDS
LOAD(OPND,ANYGR BAR0,2)
D=OPND_XB
REGS(D)_CL=2
%IF X<0 %THEN X=0
%IF TYPE=5 %THEN X=X+4; ! TO ADDRESS PART OF STR HEADER
DUMPRXE(LGR,REG,0,D,X)
REGS(D)_CL=0
->LDED
SW(5): ! INDIRECT VIA PTR
%IF X<=0 %THEN USE=ADDROF %AND INF=OPND_D
TCELL==ASLIST(TAGS(OPND_D))
FIND USE(D,X'51',ADDROF,OPND_D); ! LOOK FOR BAS PTR
%IF D>0 %THEN ->FND
B=TCELL_UIOJ>>4&15
D=TCELL_SLINK
%IF (TYPE=0 %OR TYPE=5) %AND X<0 %THEN D=D+4
DFETCH(REG,4,B,D)
%IF REGS(REG)_CL=0 %THEN REGS(REG)_CL=2
INC: %IF X>0 %THEN INC REG(REG,X,YES)
->LDED
FND: ! BASE ADDRESS FOUND
%IF REG>=0 %THEN DUMPLA(REG,0,D,X) %AND ->LDED
%IF ACCEPTABLEREG(NEGREG(REG),D)=YES %AND %C
REGS(D)_CL=0 %THEN REG=D %AND ->INC
! where already claimed further optimisation
! are possible too but attempt 1 caused bugs
DUMPRXE(LA,REG,0,D,X)
->LDED
SW(6): ! INDIRECT OFFSET
REFTRIP==TRIPLES(OPND_D)
OPND=REFTRIP_OPND1
LOAD(OPND,REG,2)
REG=OPND_XB
->INC
SW(7): ! LOCAL-IR IN BASE&OFFSET FORM
B=OPND_D>>16
D=OPND_D&X'FFFF'
OPND_XTRA=0
DFETCHAD(REG,B,D); ->LDED
SW(8): ! A TRIPLE
IMPABORT %UNLESS TYPE=5; ! ONLY STRING INTERMEDIATES HAVE ADDRESS
REFTRIP==TRIPLES(OPND_D)
OPND=REFTRIP_OPND1
LOADAD(OPND,REG)
%RETURN
SW(10):SW10: ! DEVELOPPED BD FORM
DUMPRXE(LA,REG,OPND_XB>>4,OPND_XB&15,OPND_D)
OPERAND USED(OPND)
->LDED
%END
%ROUTINE LOADPTR(%RECORD(RD) %NAME OPND,OPND2,%INTEGER REG)
!***********************************************************************
!* MUCH AS LOAD BUT PRODUCES THE POINTER TO THE OPERAND *
!* IMPABORT ON NON RELEVANT ALTERNATIVES OF OPND *
!***********************************************************************
%RECORD(TAGF) %NAME TCELL
%RECORD(TRIPF)%NAME REFTRIP
%INTEGER K,X,WREG,B
%SWITCH SW(0:11)
PTYPE=OPND_PTYPE
K=OPND_FLAG
%IF PTYPE&7#5 %THEN LOADAD(OPND,REG) %AND %RETURN
X=OPND_XTRA
%IF REG<0 %THEN REG=FINDREG(NEGREG(REG),1)
WREG=REG+1
->SW(K)
SW(*): ! INVALID
IMPABORT
SW(2): ! DNAME
TCELL==ASLIST(TAGS(OPND_D))
DFETCHAD(WREG,TCELL_UIOJ>>4&15,TCELL_SLINK+X)
STR: ! SET TOP HALF OF STRING DESC
! MESSY FOR STRING ARRAY NAMES
! OPND2_XTRA=BML<<16!DML
PTYPE=OPND2_D>>16; ! BACK TO REFFED VARS PTYPE
%IF OPND2_XTRA<0 %THEN %START; ! STRING LENGTH KNOWN
DUMPRX(LA,REG,0,0,OPND2_XTRA&X'FFFF'+1);! DML IS ACC-1 DOES NOT INCLUDE LENGTHBYTE
->LDED
%FINISH
%IF PTYPE&X'300'=0 %START; ! STRINGNAMES DML&BML FOR HEAD
DFETCH(REG,4,OPND2_XTRA>>16,OPND2_XTRA&X'FFFF')
->LDED
%FINISH
B=-2
DFETCH(B,4,OPND2_XTRA>>16,OPND2_XTRA&X'FFFF'+8);! DV ADDR TO B
FORGET(B)
DUMPRX(LGR,REG,0,B,8)
LDED:
OPND_PTYPE=X'61'
OPERAND LOADED(OPND,REG)
%RETURN
SW(4): ! VIA PTR AT OFFSET FROM COMPUTER ADDDRESS
REFTRIP==TRIPLES(OPND_D)
OPND=REFTRIP_OPND1
LOAD(OPND,ANYGR BAR0,2)
B=OPND_XB
%IF X<0 %THEN X=0
DUMPM(LM,REG,WREG,B,X)
OPERAND USED(OPND)
->LDED
SW(5): ! INDIRECT VIA DICT
SW(6): ! INDIRECT OFFSET
SW(7): ! LOCAL IR (OCCURRS WHEN EXPR PASSED BT REF)
SW(10): ! DEVELOPPED BD FORM
! NORMALLY ARRAY ELEMENTS ONLY
LOADAD(OPND,WREG)
->STR
%END
%INTEGERFN SSVARASS(%INTEGER SIZE,BASE,DISP,%RECORD(RD)%NAME RHOPND)
!***********************************************************************
!* ATTEMPTS TO ASSIGN BY MVC(ETC) WHERE THIS IS ADVANTAGEOUS *
!* SET RESULT=YES IF ASSIGNMENT MADE *
!***********************************************************************
%INTEGER I,TYPE,PREC
%RESULT=NO %IF CURRT_CNT>0; ! IF REUSED GO VIA REGISTERS
%RESULT=NO %IF RHOPND_FLAG=INAREG; ! ALREADY LOADED
%RESULT=NO %IF DISP>4095
TYPE=RHOPND_PTYPE&7
PREC=RHOPND_PTYPE>>4&15
%IF TYPE=1 %AND RHOPND_FLAG<=1 %START;! RHS IS A CONSTANT
%IF SIZE=1 %AND 0<=RHOPND_D<=255 %START
DUMPSI(MVI,RHOPND_D,BASE,DISP)
%RESULT=YES
%FINISH
%RESULT=NO %IF SIZE<=4 %AND 0<=RHOPND_D<=4095;! LA QUICKER IN THESE CASES
%FINISH
%RESULT=NO %UNLESS SIZE=BYTES(PREC)
%IF TYPE=2 %START
%IF PREC=7 %THEN I=ANYFRPAIR %ELSE I=ANY FR
%FINISH %ELSE %START
%IF PREC=6 %THEN I=ANYGRPAIR %ELSE I=ANYGR
%FINISH
LOAD (RHOPND,I,1)
%RESULT=NO %UNLESS RHOPND_FLAG=10 %AND RHOPND_XB<=15 %AND %C
RHOPND_D<=4095
PMVC(SIZE,BASE,DISP,RHOPND_XB,RHOPND_D)
%RESULT=YES
%END
%ROUTINE SSTRASS(%RECORD(RD)%NAME LHOPND,RHOPND,%INTEGER ACC)
!***********************************************************************
!* DOES SIMPLE STRING ASSIGNMENTS WHEN ACC OF LHS IS KNOWN *
!***********************************************************************
%INTEGER C,D
D=RHOPND_XTRA; ! RHS LENGTH IF A CONST
%IF RHOPND_FLAG=LCONST %AND D<ACC %START
%IF D=0 %START; ! NULL STRING ASSIGN
DUMPSI(MVI,0,LHOPND_XB,LHOPND_D)
%FINISH %ELSE %START
LOAD(RHOPND,ANY GR,1)
DUMPSS(MVC,D+1,LHOPND_XB,LHOPND_D,RHOPND_XB,RHOPND_D)
%FINISH
%FINISHELSESTART
LOAD(RHOPND,ANY GR,1); ! THE RHS
%IF ACC<=16 %THEN %START;! AVOID EXECUTE MOVE THE LOT
DUMPSS(MVC,ACC,LHOPND_XB,LHOPND_D,RHOPND_XB,RHOPND_D)
%FINISH %ELSE %START
C=ANYGRBAR0
DUMPRXE(IC,C,0,RHOPND_XB,RHOPND_D);! PICK UP LENGTH
SET USE(C,X'51',LITCONST,-1000)
REGS(C)_CL=-1
EXECUTESS(C,MVC,LHOPND_XB,LHOPND_D,RHOPND_XB,RHOPND_D)
REGS(C)_CL=0
%FINISH
%IF PARM_OPT#0 %START; ! FORCE CAPACITY CHK
DUMPSI(CLI,ACC-1,LHOPND_XB,LHOPND_D)
PPJ(2,9,NO)
%FINISH
%FINISH
OPERAND USED(LHOPND)
OPERAND USED(RHOPND)
%END
%INTEGERFN SET DVREG(%INTEGER WHICH,DVBD,ANAME)
!***********************************************************************
!* SELECT(USUALLY) AND SET UP A GENERAL 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
I=-1
%IF ANAME>0 %THEN FIND USE(I,X'51',DVBASE,ANAME)
%IF I>0 %THEN WHICH=I %ELSE WHICH=FINDREG(NEGREG(WHICH),0)
%FINISH
REG==REGS(WHICH)
%UNLESS REG_USE=DVBASE %AND REG_INF1=ANAME>0 %START
DFETCH(WHICH,4,DVBD>>16,DVBD&X'FFFF'+8)
SET USE(WHICH,X'51',DVBASE,ANAME)
%FINISH
REG_CL=2
%RESULT=WHICH
%END
%ROUTINE VMULTIPLY
!***********************************************************************
!* DOES ALL VECTOR MULTIPLIES *
!***********************************************************************
%ROUTINESPEC BCHECK(%INTEGER IREG,DVREG,OFFSET)
%ROUTINESPEC SCALE(%INTEGER IREG,DACC)
%INTEGER DVPOS,DVPTYPE,DVD,DACC,DVREG,IREG,DVNAME,MAXD
DVNAME=XTRA&X'FFFF'; ! ZERO FOR ARRAYS IN RECORDS
DVPTYPE=XTRA>>16
DACC=-1; ! EL SIZE NOT KNOWN
%IF DVPTYPE&X'C00'=0 %AND DVNAME>0 %THEN DACC=ASLIST(TAGS(DVNAME))_ACC
%IF DVPTYPE&7<=2 %THEN DACC=BYTES(DVPTYPE>>4&15)
DVPOS=OPND2_D&X'FFFF'
MAXD=D; ! NO OC DIMENSIONS OF ARRAY
DVD=3*C; DVREG=-1
LOAD(OPND1,ANYGR BAR0,2)
IREG=OPND1_XB
%IF DVPOS>0 %START; ! DV IN CONST AREA
DVD=DVD+DVPOS
%IF PARM_ARR#0 %THEN BCHECK(IREG,CTABLEREG,4*DVD)
DACC=CTABLE(DVD+2)
SCALE(IREG,DACC)
%FINISH %ELSE %START
! FOR FIRST DIMENSION USE DACC IF KNOWN
! ELSE THE STRIDE IN ARRAYHEAD
! FOR SECOND OF 2 DIM USE STRIDE IN AH
! ALL OTHER CASES AND BOUND CHECKS
! NEED TO GO VIA THE DOPEVECTOR
%IF PARM_ARR#0 %OR C>=2<MAXD %OR (DACC<0 %AND MAXD>1) %THEN %C
DVREG=SET DVREG(-2,OPND2_XTRA,DVNAME)
%IF PARM_ARR#0 %THEN BCHECK(IREG,DVREG,4*DVD)
%IF DACC>0 %AND C=1 %THEN SCALE(IREG,DACC) %ELSE %C
%IF (DACC<0 %AND C=1=MAXD) %OR C=2=MAXD %THEN %C
DUMPRX(MH,IREG,0,DISPREG(OPND2_XTRA>>16),OPND2_XTRA&X'FFFF'+14) %ELSE %C
DUMPRX(MH,IREG,0,DVREG,4*DVD+10)
%IF DVREG>0 %THEN REGS(DVREG)_CL=0
%FINISH
FORGET(IREG) %UNLESS DACC=1
%RETURN
%ROUTINE SCALE(%INTEGER IREG,DACC)
!***********************************************************************
!* SCALE AN INDEXING REG AS EFFICIENTLY AS POSSIBLE *
!***********************************************************************
%INTEGER SH,RES
%IF DACC<=1 %THEN %RETURN
%IF DACC=2 %THEN PIX RR(AR,IREG,IREG) %AND %RETURN
RES=DACC; SH=0
SH=SH+1 %AND RES=RES>>1 %WHILE RES&1=0
%IF RES=1 %THEN PIX RS(SLL,IREG,0,0,SH) %C
%ELSE DUMPRX(MH,IREG,0,CTABLEREG,SHORT CONST(DACC))
%END
%ROUTINE BCHECK(%INTEGER IREG,DVREG,OFFSET)
!***********************************************************************
!* PLANTS AN IN LINE BOUND CHECK *
!***********************************************************************
DUMPRX(ICP,IREG,0,DVREG,OFFSET)
PPJ(4,13,NO)
DUMPRX(ICP,IREG,0,DVREG,OFFSET+4)
PPJ(2,13,NO)
%END
%END
%ROUTINE LNEGATE(%INTEGER REG)
!***********************************************************************
!* NEGATES THE LONG INTEGER IN REGS REG®+1 BY SUBTRACTING *
!* IT FROM ZERO WITH SOFTWARE CARRY *
!***********************************************************************
%INTEGER WORK
WORK=FIND REG(GR0,1)
PIX RR(SLR,WORK,WORK)
FORGET(WORK)
SET LOCAL BASE
PIX RR(SLR,WORK,REG+1)
PJUMP(BC,GLABEL,3,0)
PIX RX(A,REG,0,CTABLEREG,KWCONSTS(3));! =F'1'
PLABEL(GLABEL)
GLABEL=GLABEL-1
PIX RR(LCR,REG,REG)
PIX RR(LR,REG+1,WORK)
FORGET(REG); FORGET(REG+1)
FREE AND FORGET(WORK)
%END
%ROUTINE STARSTAR
!***********************************************************************
!* PLANT IN-LINE CODE FOR EXPONENTIATION *
!* THERE IS NO EXPONENT RABGE CHECKING ON IBMIMP80 *
!***********************************************************************
%INTEGER TYPEP,PRECP,WORK,INTREG,COUNT,RREG,WMASK,LVAL,OPCODE,TM
PTYPE=OPND1_PTYPE&255
TYPEP=PTYPE&7; PRECP=PTYPE>>4&15
TM=WORD CONST(X'9100E003'+KWCONSTS(3));! TEST UNDER MASK OF 1
%IF TYPEP=1 %START
WORK=FINDSEQREG(GRPAIR,1)
LOADPAIR(1,1,OPND1)
LOAD(OPND2,ANY GR,2)
RREG=OPND1_XB
COUNT=OPND2_XB
PIX RX(LA,WORK+1,0,0,1)
SET LOCAL BASE
PIX RR(LTR,COUNT,COUNT)
PPJ(4,7,NO); ! NEGATIVE INTEGER EXPONOENTS NONSENSE
PLABEL(GLABEL)
DUMPRX(EX,COUNT,0,CTABLEREG,TM)
PJUMP(BC,GLABEL-1,8,0)
PIX RR(MR,WORK,RREG+1)
%IF PARM_OPT#0 %THEN %START
PIX RS(SLDA,WORK,0,0,32)
PIX RR(LR,WORK+1,WORK)
%FINISH
PLABEL(GLABEL-1); ! LABEL AFTER PRODUCT
PIX RX(SRA,COUNT,0,0,1)
PJUMP(BC,GLABEL-2,8,0)
PIX RR(MR,RREG,RREG+1)
%IF PARM_OPT#0 %THEN %START
PIX RS(SLDA,RREG,0,0,32)
PIX RR(LR,RREG+1,RREG)
%FINISH
PJUMP(BC,GLABEL,15,0)
PLABEL(GLABEL-2)
GLABEL=GLABEL-3
FORGET(RREG)
FREE AND FORGET(RREG+1)
EVALREG=WORK+1
FREE AND FORGET(WORK)
%FINISH %ELSE %START
%IF PRECP=5 %THEN OPCODE=MER %AND WMASK=FR0 %AND LVAL=-3
%IF PRECP=6 %THEN OPCODE=MDR %AND WMASK=FR0 %AND LVAL=-3
%IF PRECP=7 %THEN OPCODE=MXR %AND WMASK=FRPAIR %AND LVAL=-6
!
! NOW REGISTERS CAN BE OBTAINED FOR THE IN-LINE SUBROUTINE
! WORK HOLDS INITIALLY 1 PRIOR TO MULTIPLICATION
! INTREG HOLDS THE EXPONENT AS CALCULATED
! COUNT HOLDS A +VE VERSION OF INTREG FOR COUNTING THE MULTIPLIES
! RREG HOLD THE OPERAND.
!
WORK=FINDREG(WMASK,1)
LOAD(OPND1,LVAL,2); ! OPERAND TO ANY SUITABLE
LOAD(OPND2,ANY GR,2); ! EXPONENT TO ANY GENERAL REG
RREG=OPND1_XB
INTREG=OPND2_XB
!
! GET '1' INTO WORK IN APPROPIATE FORM
!
DUMPRX(LDCODE(8+PRECP),REGCODE(WORK),0,CTABLEREG,KLCONSTS(7));! =D'1'
%IF PRECP=7 %THEN PIX RR(SDR,REGCODE(WORK+1),REGCODE(WORK+1))
!
! ALLOW FOR ZERO :- XX**0=1 FOR ALL XX
! ALSO ALLOW FOR X**(-N) WHICH IS 1/(X**N) FOR ALL X & N
!
COUNT=FINDREG(GR0,1)
PIX RR(LPR,COUNT,INTREG)
SET LOCAL BASE
PLABEL(GLABEL)
DUMPRX(EX,COUNT,0,CTABLEREG,TM)
PJUMP(BC,GLABEL-1,8,0); ! J(BOTTOM BIT=0) ROUND NEXT INSTRN
PIX RR(OPCODE,REGCODE(WORK),REGCODE(RREG))
PLABEL(GLABEL-1)
PIX RX(SRA,COUNT,0,0,1); ! SHIFT OFF BOTTOM BIT
PJUMP(BC,GLABEL-2,8,0); ! EXIT IF ALL ZERO
PIX RR(OPCODE,REGCODE(RREG),REGCODE(RREG));! SQUARE OPERAND
PJUMP(BC,GLABEL,15,0)
PLABEL(GLABEL-2)
!
! FOR REAL EXPONENTS CHECK IF NEGATIVE AND EVALUATE INVERSE
!
PIX RR(LTR,INTREG,INTREG)
PJUMP(BC,GLABEL-3,2,0); ! BP END OF EXP ROUTINE
DUMPRX(LDCODE(8+PRECP),REGCODE(RREG),0,CTABLEREG,KLCONSTS(7));! =D'1'
%IF PRECP#7 %THEN %START
PIX RR(DDR-MDR+OPCODE,REGCODE(RREG),REGCODE(WORK))
%FINISH %ELSE %START
PIX RR(SDR,REGCODE(RREG+1),REGCODE(RREG+1));! CLEAR BTM 64 BITS
PIX RRE(DXR,REGCODE(RREG),REGCODE(WORK))
PIX RR(LDR,REGCODE(WORK+1),REGCODE(RREG+1))
%FINISH
PIX RR(LDR-MDR+OPCODE,REGCODE(WORK),REGCODE(RREG))
FORGET(RREG)
FREE AND FORGET(INTREG)
EVALREG=WORK
PLABEL(GLABEL-3)
GLABEL=GLABEL-4
%FINISH
!
! ALL OVER. REAL RESULTS ARE IN FR WORK. INT RESULTS IN GR WORK+1
! FREE AND FORGET ANY OTHER REGISTERS
!
OPERAND USED(OPND1)
FREE AND FORGET(COUNT)
%END
%ROUTINE REALEXP
!***********************************************************************
!* CALLS A PERM ROUTINE TO PERFORM REAL**REAL *
!***********************************************************************
IMPABORT
%END
%ROUTINE CONST EXP(%INTEGER PTYPE,VALUE)
!***********************************************************************
!* EXPONENTIATION TO A KNOWN POWER *
!* VALUE = 2 UPWARDS. VALUE=1 HAS BEEN OPTIMISED OUT *
!***********************************************************************
%INTEGER I,MULTS,MULT,DEST,REG,J,PREC,SIZE
DEST=(FPPTR+7)&(-8)
MULTS=0; I=VALUE
%IF PTYPE&7=1 %START
LOADPAIR(1,1,OPND1)
EVALREG=OPND1_XB+1
%WHILE I>1 %CYCLE
%IF I&1#0 %START
DUMPRX(ST,EVALREG,0,WSPR,DEST)
DEST=DEST+4
MULTS=MULTS+1
%FINISH
PIX RR(MR,EVALREG-1,EVALREG)
%IF PARM_OPT#0 %THEN PIX RS(SLDA,EVALREG-1,0,0,32) %C
%AND PIX RR(LR,EVALREG,EVALREG-1)
I=I>>1
%REPEAT
%WHILE MULTS>0 %CYCLE
MULT=MULTS-1
DEST=DEST-4
DUMPRX(M,EVALREG-1,0,WSPR,DEST)
%IF PARM_OPT#0 %THEN PIX RS(SLDA,EVALREG-1,0,0,32) %C
%AND PIX RR(LR,EVALREG,EVALREG-1)
%REPEAT
REGS(EVALREG-1)_CL=0
FORGET(EVALREG-1)
%RETURN
%FINISH
PREC=PTYPE>>4&7
SIZE=BYTES(PREC)
J=-3; ! ANF FR
%IF PREC=7 %THEN J=-6 %AND MULT=MXR %ELSE %C
%IF PREC=6 %THEN MULT=MDR %ELSE MULT=MER
LOAD(OPND1,J,2)
EVALREG=OPND1_XB
%WHILE I>1 %CYCLE
%IF I&1#0 %START
DSTORE(EVALREG,SIZE,-1,DEST)
DEST=DEST+SIZE
MULTS=MULTS+1
%FINISH
PIX RR(MULT,REGCODE(EVALREG),REGCODE(EVALREG))
I=I>>1
%REPEAT
%IF MULTS=0 %THEN %RETURN; ! **2,**4 ETC
%IF PREC=7 %START
REG=CLAIM OTHERFRPAIR(EVALREG)
FREE AND FORGET(REG)
FREE AND FORGET(REG+1)
%FINISH
%WHILE MULTS>0 %CYCLE
DEST=DEST-SIZE
%IF PREC<=6 %THEN %START
DUMPRX(MULT+X'40',REGCODE(EVALREG),0,WSPR,DEST)
%FINISH %ELSE %START
DFETCH(REG,16,-1,DEST)
PIX RR(MXR,REGCODE(EVALREG),REGCODE(REG))
%FINISH
MULTS=MULTS-1
%REPEAT
%END
%INTEGERFN FINDREG(%INTEGER MASK,CLVAL)
!***********************************************************************
!* FINDS A FREE REGISTER FROM RANGE DEFINED BY MASK *
!***********************************************************************
%INTEGER I,L,U,USED,LASTUSED,LASTREG,STEP,BOOTMASK
%RECORD(REGF)%NAME REG
%IF MASK&X'0F000000'#0 %THEN %RESULT=FINDSEQREG(MASK,CLVAL)
L=MASK>>16&255
U=MASK&255
%IF L<=U %THEN STEP=1 %ELSE STEP=-1
%FOR I=L,STEP,U %CYCLE
REG==REGS(I)
->FOUND %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)
!
BOOTMASK=1<<3; ! BOOT PARAMETERS FIRST
AGN:
LASTUSED=-1
LASTREG=-1
%FOR I=L,STEP,U %CYCLE
REG==REGS(I)
->FOUND %IF REG_CL=0
%IF REG_AT#WTRIPNO %START; ! NOT USED IN THIS OPERATION
USED=TRIPLES(REG_AT)_PUSE
%IF USED >LASTUSED %AND 1<<REG_CL&BOOTMASK#0 %THEN %C
LASTUSED=USED %AND LASTREG=I
%FINISH
%REPEAT
%IF LASTREG>=0 %THEN %START
BOOT OUT(LASTREG)
I=LASTREG
REG==REGS(I)
->FOUND
%FINISH
%IF BOOTMASK&(1<<1)=0 %THEN BOOTMASK=BOOTMASK!(1<<1) %AND ->AGN
%IF BOOTMASK&(1<<2)=0 %THEN BOOTMASK=BOOTMASK!(1<<2) %AND ->AGN
IMPABORT
FOUND:
! REG HAS BEEN FOUND
%IF CLVAL#0 %THEN REG_CL=CLVAL %AND REG_CNT=1 %AND FORGET(I)
%RESULT=I
%END
%INTEGERFN FINDSEQREG(%INTEGER MASK,CLVAL)
!***********************************************************************
!* FINDS A FREE REGISTER PAIR FROM RANGE DEFINED BY MASK *
!* PAIRS ARE EVEN-ODD UNLESS TOP BIT OF MASK SET *
!***********************************************************************
%INTEGER I,J,L,U,USED,LASTUSED,LASTREG,STEP,MISS,NREGS
%RECORD(REGF)%NAME REG
L=MASK>>16&255
U=MASK&255
NREGS=MASK>>24&7
%IF L<=U %THEN STEP=1 %ELSE STEP=-1
%IF MASK>0 %THEN STEP=2*STEP
%FOR I=L,STEP,U %CYCLE
MISS=0
%FOR J=0,1,NREGS %CYCLE
REG==REGS(I+J)
MISS=1 %UNLESS REG_CL=0 %AND REG_USE=0
%REPEAT
->FOUND %IF MISS=0
%REPEAT
I=CHECKSEQREG(MASK); ! USE MORE ELABORATE CODE IN CHECK
%IF I>=0 %THEN ->FOUND
IMPABORT
FOUND:
! REG HAS BEEN FOUND
%IF CLVAL#0 %THEN %START
%FOR J=0,1,NREGS %CYCLE
REG==REGS(I+J)
REG_CL=CLVAL
REG_CNT=1
FORGET(I+J)
%REPEAT
%FINISH
REGS(I+J)_AT=WTRIPNO %FOR J=0,1,NREGS
%RESULT=I
%END
%INTEGERFN CHECKSEQREG(%INTEGER MASK)
!***********************************************************************
!* CHECKS FOR AVAILABILITY OF A REGISTER PAIR FROM RANGE DEFINED *
!* BY MASK. PAIRS ARE EVEN-ODD UNLESS TOP BIT OF MASK SET *
!***********************************************************************
%INTEGER I,J,L,U,USED,LASTUSED,LASTREG,STEP,MISS,NREGS,BOOTMASK
%RECORD(REGF)%NAME REG
L=MASK>>16&255
U=MASK&255
NREGS=MASK>>24&7
%IF L<=U %THEN STEP=1 %ELSE STEP=-1
%IF MASK>0 %THEN STEP=2*STEP
%FOR I=L,STEP,U %CYCLE
MISS=0
%FOR J=0,1,NREGS %CYCLE
REG==REGS(I+J)
MISS=1 %UNLESS REG_CL=0 %AND REG_USE=0
%REPEAT
->FOUND %IF MISS=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)
!
BOOTMASK=1<<3; ! FIRST BOOT PARAMETERS
AGN: LASTUSED=-1
LASTREG=-1
%FOR I=L,STEP,U %CYCLE
MISS=0
%FOR J=0,1,NREGS %CYCLE
REG==REGS(I+J)
MISS=1 %AND %EXIT %IF REG_CL#0
%REPEAT
->FOUND %IF MISS=0
%IF REG_AT#WTRIPNO %START; ! NOT USED IN THIS OPERATION
USED=TRIPLES(REG_AT)_PUSE
%IF USED >LASTUSED %AND 1<<REG_CL&BOOTMASK#0 %THEN %C
LASTUSED=USED %AND LASTREG=I+J
%FINISH
%REPEAT
%IF LASTREG>0 %THEN BOOT OUT(LASTREG) %AND ->AGN
%IF BOOTMASK&(1<<1)=0 %THEN BOOTMASK=BOOTMASK!(1<<1) %AND ->AGN
%IF BOOTMASK&(1<<2)=0 %THEN BOOTMASK=BOOTMASK!(1<<2) %AND ->AGN
%RESULT=-1; ! NOT FOUND
FOUND:
%RESULT=I
%END
%INTEGERFN ACCEPTABLE REG(%INTEGER MASK,REG)
!***********************************************************************
!* CHECKS IF REG IN WHICH A RESULT HAPPENS TO BE SATISFIES *
!* THE REGISTER CONSTRAINTS OF MASK *
!***********************************************************************
%INTEGER L,U,STEP,I
L=MASK>>16&255
U=MASK&255
%IF U>=L %THEN STEP=1 %ELSE STEP=-1
%IF MASK>0 %AND MASK&X'0F000000'#0 %THEN STEP=2*STEP
%FOR I=L,STEP,U %CYCLE
%RESULT=YES %IF I=REG
%REPEAT
%RESULT=NO
%END
%ROUTINE FORGETM(%INTEGER UPPER)
!***********************************************************************
!* FORGETS A BLOCK OF REGISTERS DEFINED BY UPPER AND THE *
!* GLOBAL ARRAY GRMAP *
!* UPPER= 3 FOR GRS 0-3 *
!* UPPER= 4 FOR GRS 0-3 AND 15 *
!* UPPER= 8 FOR GRS 0-3 AND 15 PLUS ALL FRS *
!* UPPER=14 FOR GRS 0-9,15 AND ALL FRS *
!***********************************************************************
%INTEGER I,REG
%CYCLE I=0,1,UPPER
REG=GRMAP(I)
%IF REGS(REG)_CL=0 %THEN FORGET(REG)
%REPEAT
%END
%ROUTINE SAVE IRS(%INTEGER UPPER)
!***********************************************************************
!* INSPECTS THE REGISTERS DEFINED BY UPPER AND THE GLOBAL *
!* ARRAY 'GRMAP'. ANY INTERMEDIATE RESULTS IN THESE REGISTERS *
!* ARE TRANSFERED TO CORE BY 'BOOT OUT' *
!* UPPER=4 FOR GRS 1-3 & 15 (CORRUPTED BY PERM) *
!* UPPER=8 FOR GRS 1-3 & 15 +FRS 0-6 (CORRUPTED BY FN CALL) *
!***********************************************************************
%INTEGER I,REG
%CYCLE I=0,1,UPPER
REG=GRMAP(I)
BOOT OUT(REG) %IF REGS(REG)_CL>=1
%REPEAT
%END
%ROUTINE CLAIM THIS REG(%INTEGER REG)
!***********************************************************************
!* CLAIMS THE REGISTER AND PRESERVES CONTENTS IF *
!* THE REGISTER IS ALREADY CLAIMED *
!***********************************************************************
BOOT OUT(REG) %IF REGS(REG)_CL>0
%IF REGS(REG)_CL#0 %THEN IMPABORT
REGS(REG)_CL=1
%END
%ROUTINE CLAIM ALL4FRS
%INTEGER I
CLAIM THIS REG(I) %FOR I=16,1,19
%END
%INTEGERFN CLAIM OTHER FRPAIR(%INTEGER PAIR0)
!***********************************************************************
!* FOR EXTENDED OPS THAT NEED BOTH FR PAIRS. SPECIAL ROUTINES IN *
!* CASE SPECIAL MEASURES ARE NEEDED *
!***********************************************************************
%INTEGER PAIR1
IMPABORT %UNLESS PAIR0=16 %OR PAIR0=18
PAIR1=PAIR0!!2
CLAIM THIS REG(PAIR1)
CLAIM THIS REG(PAIR1+1)
%RESULT=PAIR1
%END
%ROUTINE FORGET(%INTEGER REGNO)
!***********************************************************************
!* CLEARS THE USE OF ANY REGISTER. ALL CHANNELED THRO ONE RT *
!* IN CASE NEED ANY DROP CALL TO PUT ETC *
!***********************************************************************
%RECORD(REGF)%NAME REG
REG==REGS(REGNO)
%IF REG_USE=BASEREG %THEN PDROP(REGNO)
REG_USE=0
REG_INF1=0
%END
%ROUTINE FREE AND FORGET(%INTEGER REGNO)
!***********************************************************************
!* AS FORGET BUT CLEARS CCLAIM FLAG ALSO *
!***********************************************************************
REGS(REGNO)_CL=0
FORGET(REGNO)
%END
%ROUTINE SET USE(%INTEGER REG,PTYPE,U,I)
!***********************************************************************
!* NOTE THAT THE USE OF REGISTER 'R' IS NOW 'U' & 'I' *
!* WORKS FOR MULTI REGISTER ITEMS *
!***********************************************************************
%INTEGER XREGS
%RECORD(REGF)%NAME UREG
XREGS=REGWORDS(PTYPE&127)>>4-1
%FOR REG=REG,1,REG+XREGS %CYCLE
UREG==REGS(REG)
%IF UREG_CL>=0 %THEN %START
%IF UREG_USE>0 %THEN FORGET(REG)
UREG_USE=U
UREG_INF1=I
UREG_AT=WTRIPNO
%FINISH
U=U!128; ! CONTINUATION BIT FOR MULT REG ITEMS
%REPEAT
%END
%ROUTINE COPY USE(%INTEGER TO,FROM)
!***********************************************************************
!* TRANSFER USE INFO FROM 1 REG TO ANOTHER *
!***********************************************************************
%RECORD(REGF)%NAME RTO,RFROM
RTO==REGS(TO)
RFROM==REGS(FROM)
%IF RTO_USE#0 %THEN FORGET(TO)
RTO_USE=RFROM_USE
RTO_INF1=RFROM_INF1
RTO_INF2=RFROM_INF2
RTO_AT=WTRIPNO
%END
%ROUTINE FIND USE(%INTEGERNAME REG, %INTEGER PTYPE, USE, INF)
!***********************************************************************
!* SEARCHES FOR A REGISTER WITH THE REQUIRED CONTENTS *
!***********************************************************************
%INTEGER I, L, U, J, NREGS
%RECORD(REGF)%NAME TREG
%CONSTBYTEINTEGERARRAY FMAP(1:15)=1,2,3,4,5,6,7,8,9,15,0,16,17,18,19;
%IF PTYPE&7=2 %THEN L=12 %AND U=15 %ELSE L=1 %AND U=11
NREGS=REGWORDS(PTYPE&127)>>4; ! NO OF GRS(FRS)
REG=-1 %AND %RETURN %IF NREGS>2;! 4 REG ITEMS TOO COMPILCATED TO SHUFFLE
%CYCLE J=L,1,U+1-NREGS
I=FMAP(J)
TREG==REGS(I)
%IF TREG_PRIMUSE=USE %AND (TREG_INF1=INF %OR INF=-1) %C
%AND (NREGS=1 %OR(REGS(I+1)_PRIMUSE=USE!128 %AND %C
(REGS(I+1)_INF1=INF %OR INF=-1))) %THEN ->HIT
%IF TREG_SECUSE=USE %AND(TREG_INF2=INF %OR INF=-1) %C
%AND (NREGS=1 %OR(REGS(I+1)_SECUSE=USE!128 %AND %C
(REGS(I+1)_INF2=INF %OR INF=-1))) %THEN ->HIT
%REPEAT
REG=-1
%RETURN
HIT:
TREG_AT=WTRIPNO
REG=I
%END
%ROUTINE BOOT OUT(%INTEGER REG)
!***********************************************************************
!* REMOVE TEMPORARIES FROM REG INTO LOCAL OR ONTO STACK *
!* IT IS VITAL THAT ACC IS STACKED FIRST BEFORE B OR DR *
!* OTHERWISE MIXUPS OCCUR WHEN PASSING MULTI-DIMENSION ARRAY *
!* ELEMENTS WITH FNS AS SUBSCRIPTS AS VALUE SCALARS *
!***********************************************************************
%SWITCH BOOT(1:3)
%INTEGER BSIZE,WSIZE,NREGS,D,J
%RECORD(REGF)%NAME BOOTREG
%RECORD(RD)%NAME R
BOOTREG==REGS(REG)
IMPABORT %UNLESS 1<=BOOTREG_CL<=3
R==RECORD(BOOTREG_LINK)
BSIZE=BYTES(R_PTYPE>>4&15)
WSIZE=REGWORDS(R_PTYPE&127)
NREGS=WSIZE>>4; WSIZE=WSIZE&15
->BOOT(BOOTREG_CL)
BOOT(1): ! INTERMEDIATE RESULT
%IF R_D=0 %THEN %START
GET WSP(D,WSIZE)
R_D=CURRINF_RBASE<<16!D
%FINISH %ELSE D=R_D&X'FFFF'
DSTORE(REG,BSIZE,R_D>>16,D)
D=D!BSIZE<<24 %UNLESS BSIZE=4
SET USE(REG,R_PTYPE,LOCALTEMP,D)
R_FLAG=7
->FREE
BOOT(2): ! TEMPORARY BASE
%IF 10<=R_FLAG<=11 %AND (R_XB&15=REG %OR 0#REG=R_XB>>4) %AND %C
BOOTREG_CNT<=1 %START
J=FINDREG(GRSAFE,2)
DUMPLA(J,R_XB>>4,R_XB&15,R_D)
OPERAND USED(R)
R_XB=J
%IF R_FLAG=11 %THEN R_FLAG=9 %ELSE R_D=0
REGS(J)_LINK=BOOTREG_LINK
%IF BOOTREG_CL=0 %THEN %RETURN
%FINISH
IMPABORT
BOOT(3): ! PARAMETER AWAITONG STACKING
DSTORE(REG,BSIZE,-1,64+4*REG)
FREE:
%FOR J=0,1,NREGS-1 %CYCLE
BOOTREG==REGS(REG+J)
BOOTREG_CL=0
BOOTREG_CNT=0
BOOTREG_LINK=0
%REPEAT
%END
%ROUTINE CALL COMING (%INTEGER UPPER)
!***********************************************************************
!* CALLED TO SAVE RESULTS AND PARAMETERS IN CASE CALL WITHIN CALL *
!***********************************************************************
%INTEGER J
SAVE IRS(UPPER); ! FRS NOT ALWAYS SAVED FOR PERM
J=(FPPTR+7)&(-8)
PUSH(FPHEAD,FPPTR,LAST PAR REG,J)
%IF FPPTR>64 %THEN DUMPRX(LA,WSPR,0,WSPR,J)
FPPTR=64
%END
%ROUTINE CALL MADE
!***********************************************************************
!* CALL HAS BEEN MADE. EXPOSE ANY PARAMETERS *
!***********************************************************************
%INTEGER J
POP(FPHEAD,FPPTR,LAST PAR REG,J)
%IF CA>4096-MARGIN %THEN %C
PUSING(LINKREG) %AND SET USE(LINKREG,X'51',BASEREG,CA)
%IF FPPTR>64 %THEN %START
REGS(1)_CL=1
DUMPRX(SH,WSPR,0,CTABLEREG,SHORT CONST(J))
REGS(1)_CL=0; ! IN CASE OF RESULT AND CONST TABLE>4096 ONLY
%FINISH
%END
%ROUTINE GET IN ACC(%INTEGERNAME SREG,%INTEGER SIZE,%RECORD(RD)%NAME OPND)
!***********************************************************************
!* SIMILAR TO DFETCH BUT HAS MORE GENERAL OPND PARAMETER *
!***********************************************************************
%INTEGER COUNT,TY,PR,OPCODE,I
TY=0
%IF SREG>=16 %OR SREG=ANYFR %OR SREG=ANYFRPAIR %THEN TY=1
PR=BYTESTOPT(SIZE)>>4
OPCODE=LDCODE(8*TY+PR)
COUNT=SIZE>>2-1
%IF OPCODE=LM %START
%IF SREG<0 %THEN SREG=FINDREG(NEGREG(SREG),0)
%IF OPND_XB>>4=0 %THEN DUMPM(OPCODE,SREG,SREG+COUNT,OPND_XB,
OPND_D) %ELSE %START
DUMPRX(LGR,SREG+I,OPND_XB>>4,OPND_XB&15,OPND_D+I) %C
%FOR I=0,1,COUNT
%FINISH
%FINISH %ELSE %START
DUMPRXE(OPCODE,SREG,OPND_XB>>4,OPND_XB&15,OPND_D)
%IF SIZE=16 %THEN %C
DUMPRX(OPCODE,REGCODE(SREG+1),OPND_XB>>4,OPND_XB&15,OPND_D+8)
%FINISH
%END
%ROUTINE GET OUT OF ACC(%INTEGER REG,%INTEGER SIZE,%RECORD(RD)%NAME OPND)
!***********************************************************************
!* SIMILAR TO DSTORE BUT WITH OPND TYPE PARAMETER *
!***********************************************************************
%INTEGER COUNT,TY,PR,OPCODE,I
TY=REG>>4
PR=BYTESTOPT(SIZE)>>4
OPCODE=STCODE(8*TY+PR)
COUNT=SIZE>>2-1
%IF OPCODE=STM %START
%IF OPND_XB>>4=0 %THEN DUMPM(OPCODE,REG,REG+COUNT,OPND_XB,
OPND_D) %ELSE %START
DUMPRX(ST,REG+I,OPND_XB>>4,OPND_XB&15,OPND_D+4*I) %C
%FOR I=0,1,COUNT
%FINISH
%FINISH %ELSE %START
DUMPRX(OPCODE,REGCODE(REG),OPND_XB>>4,OPND_XB&15,OPND_D)
%IF SIZE=16 %THEN %C
DUMPRX(OPCODE,REGCODE(REG+1),OPND_XB>>4,OPND_XB&15,OPND_D+8)
%FINISH
%END
%ROUTINE DSTORE(%INTEGER REG,SIZE,LEVEL,DISP)
!***********************************************************************
!* STORE SIZE(BYTES) FROM DISP(BYTES) IN DISPLAY 'LEVEL' *
!***********************************************************************
%RECORD(RD) DOPND
DOPND_FLAG=10
DOPND_XB=DISPREG(LEVEL)
DOPND_D=DISP
GET OUT OF ACC(REG,SIZE,DOPND)
%END
%ROUTINE DFETCHAD(%INTEGERNAME REG,%INTEGER LEVEL,DISP)
!***********************************************************************
!* FETCH ADDRESS OF DISP(BYTES) IN DISPLAY 'LEVEL' *
!***********************************************************************
DUMPRXE(LA,REG,0,DISPREG(LEVEL),DISP)
FORGET(REG)
%END
%ROUTINE DFETCH(%INTEGERNAME REG,%INTEGER SIZE,LEVEL,DISP)
!***********************************************************************
!* FETCH SIZE(BYTES) FROM DISP(BYTES) IN DISPLAY 'LEVEL' *
!***********************************************************************
%RECORD(RD) DOPND
DOPND_FLAG=10
DOPND_XB=DISPREG(LEVEL)
DOPND_D=DISP
GET IN ACC(REG,SIZE,DOPND)
%END
%ROUTINE INC REG(%INTEGER REG,AMOUNT,LAOK)
!***********************************************************************
!* ADDS OR SUBTRACTS AMOUNT INTO REG. IF LAOK=YES THEN USES LA *
!* FOR SMALL INCREMENTS. NORMALLY USES AH *
!***********************************************************************
%INTEGER OP,DIS
%IF AMOUNT=0 %THEN %RETURN
%IF LAOK=YES %AND 0<AMOUNT<=4095 %AND REG#0 %THEN %C
PIX RX(LA,REG,0,REG,AMOUNT) %AND %RETURN
%IF X'FFFF8000'<AMOUNT<=X'7FFF' %THEN %C
OP=AH %AND DIS=SHORT CONST(AMOUNT) %ELSE %C
OP=A %AND DIS=WORD CONST(AMOUNT)
DUMPRX(OP,REG,0,CTABLEREG,DIS)
%END
%INTEGERFN REACHABLE(%INTEGER LAB,LINK)
!***********************************************************************
!* FIND IF A SHORT JUMP CAN REACH THE LABEL USING MAX TRIPCODE FIELD*
!* IN TRIPDATA AND ADDING EXTRA FOR IN LINE CONSTS *
!***********************************************************************
%INTEGER DIST
%RECORD(TRIPF)%NAME CURRT
%CONSTINTEGER LIMIT=4095; ! 63 HALFWORDS
DIST=0
%CYCLE
%RESULT=NO %IF LINK=0 %OR DIST>LIMIT
CURRT==TRIPLES(LINK)
LINK=CURRT_FLINK
%RESULT=YES %IF CURRT_OPERN=TLAB %AND CURRT_OPND1_D&X'FFFF'=LAB
DIST=DIST+TRIPDATA(CURRT_OPERN)>>8&255
%REPEAT
%END
%ROUTINE CEND
!************************************************************************
!* NOW CLAIM THE STACK FRAME BY SPECIFYING RT DICT ENTRY *
!************************************************************************
%INTEGER JJ,D,TOP
PPROCEND
JJ=CURRINF_SNMAX
%IF JJ<4095 %THEN %START
%IF PARM_CHK=0 %THEN D=LA<<8!WSPR<<4!WSPR %ELSE D=LA<<8
PSETOPD(CURRINF_SET,0,D)
PSETOPD(CURRINF_SET,1,JJ)
%FINISH %ELSE %START
D=SHORT CONST(JJ)
%IF PARM_CHK=0 %THEN TOP=AH<<8!WSPR<<4 %ELSE TOP=LH<<8
PSETOPD(CURRINF_SET,0,TOP)
%IF D<4095 %THEN %START
PSETOPD(CURRINF_SET,1,CTABLEREG<<12!D)
%FINISH %ELSE %START
D=JJ>>12<<2+4; ! OFFSET OF NEXT HIGHER 4K MULTIPLE
PSETOPD(CURRINF_SET,1,CODER<<12!(D+2));! USE BTM HALF
%FINISH
%FINISH
REGS(CLNB)_CL=0
%END
%ROUTINE CIOCP(%INTEGER N,REG)
!***********************************************************************
!* COMPILES A CALL ON IOCP ENTRY POINT NO 'N' *
!* 2ND (32 BIT) PARAMETER IS ALREAD IN REG *
!***********************************************************************
%CONSTINTEGER NEED RES=X'40016'
%INTEGER MREG
MREG=ANYGR
REGS(REG)_CL=-1
CALL COMING(8)
DSTORE(REG,4,-1,68)
REGS(REG)_CL=0
DUMPRXE(LA,MREG,0,0,N)
DSTORE(MREG,4,-1,64)
FORGETM(8)
DUMPM(STM,4,14,WSPR,16)
DUMPM(LM,CODER,EPREG,GLAREG,KNOWN XREF(4))
PIX RR(BALCODE-X'40',15,14)
CALL MADE
%END
%ROUTINE PPJ(%INTEGER MASK,N,SAVE)
!***********************************************************************
!* PLANT A 'BC MASK,PERMENTRY(N)' *
!* IF MASK=0 THEN PLANT A BAS *
!* QUITE DIFFICULT IF PERM LABEL NOT YET SET. HAVE TO ARRANGE TO *
!* LOAD RELEVANT 4K MULTIPLE AND NOTE CA FOR LATER FILLING *
!***********************************************************************
%INTEGER VAL, CODE, J, WREG
CODE=BC
%IF MASK=0 %THEN %START
CODE=BALCODE
MASK=LINKREG
SAVEIRS(8) %IF SAVE=YES
%FINISH
VAL=WORKA_PLABS(N)
%IF VAL<=0 %THEN VAL=GLABEL %AND WORKA_PLABS(N)=VAL %C
%AND WORKA_PLINK(N)=VAL %AND GLABEL=VAL-1
%IF N<=15 %THEN WREG=0 %ELSE %IF CODE=BALCODE %THEN WREG=LINKREG %C
%ELSE IMPABORT
PJUMP(CODE,VAL,MASK&15,WREG)
%IF CODE=BALCODE %START; ! IF WE ARE COMING BACK
FORGETM(8) %IF SAVE=YES
%IF REGS(LINKREG)_CL#0 %THEN IMPABORT
FORGET(LINKREG)
%IF 4096-CA<MARGIN %THEN %C
PUSING(LINKREG) %AND SET USE(LINKREG,X'51',BASEREG,CA)
! CAN USE SUBSIDARY BASEREG
%FINISH
%END
%ROUTINE REDUCE BASE(%RECORD(RD)%NAME OPND)
!***********************************************************************
!* AN OPERAND IS TOO COMPLEX FOR A "DB" OPERATION. REDUCE TO *
!* BASE AND DISPLACEMENT. OPTIMISATIONS ARE POSSIBLE *
!***********************************************************************
%INTEGER NEWBASE
NEWBASE=ANYGRBAR0
IMPABORT %UNLESS OPND_FLAG=10
DUMPRXE(LA,NEWBASE,OPND_XB>>4,OPND_XB&15,OPND_D)
OPERAND USED(OPND)
OPND_XB=NEWBASE
OPND_D=0
REGS(NEWBASE)_CL=TEMPBASE
FORGET(NEWBASE)
%END
%ROUTINE OPERAND USED(%RECORD(RD)%NAME OPND)
!***********************************************************************
!* AFTER OPERAND IS USED FREES UP TEMP BASES ETC *
!***********************************************************************
%INTEGER X,B,J
%RECORD(REGF)%NAME REG
%IF OPND_FLAG=9 %START
X=WORDS(OPND_PTYPE>>4&7)
X=X>>1 %IF OPND_PTYPE&7=2 %AND X>1;! X IS NO OF REGISTERS
%FOR J=OPND_XB,1,OPND_XB+X-1 %CYCLE
REG==REGS(J)
%IF REG_CL=IRESULT %OR REG_CL=TEMPBASE %THEN %START
REG_CNT=REG_CNT-1
%IF REG_CNT<=0 %THEN REG_CL=0
%FINISH
%REPEAT
%FINISH
%IF 10<=OPND_FLAG<=11 %START
X=OPND_XB>>4
B=OPND_XB&15
REG==REGS(X)
%IF X>0 %START
REG_CNT=REG_CNT-1 %IF REG_CL>=0
%IF REG_CNT<=0 %AND (REG_CL=IRESULT %OR REG_CL=TEMPBASE) %C
%THEN REG_CL=0
%FINISH
REG==REGS(B)
%IF B>0 %START
REG_CNT=REG_CNT-1 %IF REG_CL>=0
%IF REG_CNT<=0 %AND (REG_CL=IRESULT %OR REG_CL=TEMPBASE) %C
%THEN REG_CL=0
%FINISH
%FINISH
%END
%ROUTINE OPERAND LOADED(%RECORD(RD)%NAME OPND,%INTEGER REG)
!***********************************************************************
!* UPDATES OPERAND AND REG DESCRIPTORS AFTER A LOAD *
!* NORMALLY IN LINE CODE BUT 360 REGS SUCH A MESS *
!***********************************************************************
%INTEGER TYPE,PREC,X,J
%RECORD(REGF)%NAME LREG
TYPE=OPND_PTYPE&7
PREC=OPND_PTYPE>>4&15
%IF TYPE=1 %AND PREC<5 %THEN %START
%IF PREC=3 %AND REGS(REG)_USE=0 %AND CURRT_OPERN#JAMSHRTN %THEN %C
REGS(REG)_USE=LITCONST %AND REGS(REG)_INF1=-1000
PREC=5
OPND_PTYPE=X'51'
%FINISH
OPND_FLAG=9
OPND_D=0
OPND_XB=REG
X=WORDS(PREC)
X=X>>1 %IF TYPE=2 %AND X>1
%FOR J=REG,1,REG+X-1 %CYCLE
LREG==REGS(J)
IMPABORT %IF LREG_CL=1 %AND LREG_CNT>1
LREG_LINK=ADDR(OPND)
LREG_CL=1
LREG_CNT=1
LREG_AT=WTRIPNO
%REPEAT
%END
%ROUTINE OPERAND RELOADED(%RECORD(RD)%NAME OPND,%INTEGER REG)
!***********************************************************************
!* OPERAND HAS BEEN FOUND IN A REG. IT MAY JUST BE AROUND(OFTEN) *
!* OR MAY BE BEING HELD THERE FOR A DIFFERENT OPERATION(RARE) *
!* UPDATES OPERAND AND REG DESCRIPTORS AFTER THE DISCOVERY *
!* NORMALLY IN LINE CODE BUT 360 REGS SUCH A MESS *
!***********************************************************************
%INTEGER TYPE,PREC,X,J
%RECORD(REGF)%NAME LREG
TYPE=OPND_PTYPE&7
PREC=OPND_PTYPE>>4&15
%IF TYPE=1 %AND PREC<5 %THEN %START
PREC=5
OPND_PTYPE=X'51'
%FINISH
OPND_FLAG=9
OPND_D=0
OPND_XB=REG
X=WORDS(PREC)
X=X>>1 %IF TYPE=2 %AND X>1
%FOR J=REG,1,REG+X-1 %CYCLE
LREG==REGS(J)
%IF LREG_CL=0 %THEN LREG_LINK=ADDR(OPND) %AND %C
LREG_CNT=0 %AND LREG_CL=1
LREG_CNT=LREG_CNT+1
LREG_AT=WTRIPNO
%REPEAT
%END
%INTEGERFN RESULT REG(%INTEGER PTYPE)
!***********************************************************************
!* DECIDES ON THE REGISTER FOR FN RESULTS *
!***********************************************************************
PTYPE=PTYPE&255
%IF PTYPE&7=2 %THEN %RESULT=16{FR0} %ELSE %C
%IF PTYPE=X'61' %THEN %RESULT=0 %ELSE %RESULT=1
%END
%ROUTINE PUT(%INTEGER EVALREG, CODE,OFFSET,FINISHED,%RECORD(RD)%NAME OPND)
!***********************************************************************
!* THIS ROUTINE PLANTS CODE TO PERFORM THE BASIC *
!* OPERATION DEFINED BY OPND & OPCODE *
!* OFFSET AND FINISHED NEED FOR MULTILENGTH INTEGER OPERATIONS *
!* SINCE EITHER PART MAY NEED TO COME FIRST *
!***********************************************************************
%RECORD(REGF)%NAME REG
%IF OPND_FLAG=9 %START; ! SECOND OPERAND IN REG
%IF CODE&X'FF00'#0 %THEN %C
PIX RRE(CODE,REGCODE(EVALREG)+OFFSET,REGCODE(OPND_XB)+OFFSET) %ELSE %START
%IF CODE>=X'40' %THEN CODE=CODE-X'40'
PIX RR(CODE,REGCODE(EVALREG)+OFFSET,REGCODE(OPND_XB)+OFFSET)
%FINISH
%FINISH %ELSE %START
IMPABORT %UNLESS OPND_FLAG=10 %AND CODE>=X'40'
DUMPRX(CODE,REGCODE(EVALREG)+OFFSET,OPND_XB>>4,OPND_XB&15,OPND_D+4*OFFSET)
%FINISH
REG==REGS(EVALREG)
FORGET(EVALREG) %UNLESS (CODE<X'80' %AND CODE&15=9) %OR %C
CODE=CL %OR CODE=STH %OR CODE=ST %OR CODE=STE %OR CODE=STD
REG_LINK=ADDR(CURRT_OPND1); ! OPND1 IS ALWAYS THE TRIPLE RESULT
OPERAND USED(OPND) %IF FINISHED=YES
%END
%ROUTINE ADJUST INDEX(%INTEGER MODE, %INTEGERNAME INDEX, DISP)
!***********************************************************************
!* THIS IS THE GENERAL SOLUTION TO LACK OF ADDRESSABILITY. IT IS *
!* CALLED WHEN DISP IS OUTSIDE THE RANGE 0->4095 AND MANIPULATES *
!* INDEX ACCORDINGLY. FREQUENTLY INDEX=0 (NO INDEXING) WHEN THE *
!* SOLUTION IS TRIVIAL. MODE=0 IF INDEX MUST BE COPIED BEFORE *
!* BEING ADJUSTED. MODE#0 MAKE USUAL USE CHECKS ON INDEX *
!***********************************************************************
%INTEGER J, K, D, PN
J=FIND REG(GR1,0); ! MAY NOT BE NEEDED
%IF DISP>0 %THEN K=X'5A' %AND D=DISP %ELSE K=X'5B' %AND D=4095-DISP
PN=D>>12; FAULT(98, 0, 0) %IF PN>MAX4KMULT
%IF INDEX=0 %AND DISP>0 %THEN %START
FIND USE(INDEX,X'51',FOURKMULT,PN);! LOOK FOR 4K MULTIPLE
->REND %IF INDEX>0
SET USE(J,X'51', FOURKMULT, PN)
INDEX=J; K=LGR
%FINISH %ELSE %START
%IF REGS(INDEX)_CL<0 %OR REGS(INDEX)_CNT>1 %THEN MODE=0
%IF MODE=0 %OR INDEX=0 %THEN %START
%IF MODE=0 %THEN PIX RR(LR, J, INDEX) %ELSE PIX RR(SR, J, J)
INDEX=J
%FINISH
FORGET(INDEX)
%FINISH
PIX RX(K, INDEX, CODER, 0, PN<<2)
REND: DISP=DISP&4095
%END
%ROUTINE DUMPRXE(%INTEGER CODE,%INTEGERNAME REG,%INTEGER X,LEVEL,DISP)
!***********************************************************************
!* AS DUMPRX BUT SELCTS THE REG ALSO
!***********************************************************************
%INTEGER K
%RECORD(REGF)%NAME UREG
%IF REG=ANYGR %OR REG=ANYGRBAR0 %START
%IF CODE=IC %START; ! TRY TO AVOID CLEARING A REG
FIND USE(K,X'51',LITCONST,-1000)
%IF (K>0 %OR (K=0 %AND REG=ANYGR)) %AND REGS(K)_CL=0 %C
%THEN REG=K %ELSE %START
K=1
%WHILE REG<0 %AND K<=15 %CYCLE
UREG==REGS(K)
%IF UREG_CL=0 %AND %C
((UREG_PRIMUSE=LITCONST %AND UREG_INF1<=255) %C
%OR (UREG_SECUSE=LITCONST %AND UREG_INF2<=255)) %C
%THEN REG=K
K=K+1
%REPEAT
%FINISH
%FINISH
%FINISH
%IF REG<0 %THEN REG=FIND REG(NEGREG(REG),0)
DUMPRX(CODE,REGCODE(REG),X,LEVEL,DISP)
%END
%ROUTINE DUMPRX(%INTEGER CODE, REG, X, LEVEL, DIS)
!***********************************************************************
!* PUTS OUT AN RX INSTRUCTION COMPENSATING FOR SHORTCOMINGS OF IC *
!* NO LONGER ATTEMPTS TO OPTIMISE "LA" BUT DEALS WITH DIS>4095 *
!***********************************************************************
%INTEGER K,ANDR
%RECORD(REGF)%NAME UREG
ANDR=0
%IF CODE<X'40' %AND PARM_FAULTY=0 %THEN IMPABORT
%IF REG<0 %THEN IMPABORT
%IF CODE=LA %THEN DUMPLA(REG,X,LEVEL,DIS) %AND %RETURN
%UNLESS 0<=DIS<=4095 %C
%THEN ADJUST INDEX(1, X, DIS)
%IF CODE=IC %THEN %START
UREG==REGS(REG)
->NORMAL %IF UREG_PRIMUSE=LITCONST %AND UREG_INF1<=255
->NORMAL %IF UREG_SECUSE=LITCONST %AND UREG_INF1<=255
%IF REG=0 %OR X#REG#LEVEL %THEN PIX RR(SR, REG, REG) %ELSE ANDR=1
%FINISH
NORMAL: PIX RX(CODE, REG, X, LEVEL, DIS)
%IF ANDR#0 %THEN PIX RX(AND, REG, 0, CTABLEREG, KWCONSTS(1)); !=F'255'
%END
%ROUTINE DUMPLA(%INTEGER REG,X,LEVEL,DIS)
!***********************************************************************
!* A VERSION OF DUMPRX SOLEY FOR LOAD ADDRESS. MAKES ALL THE *
!* SHORT CUTS THAT PDS CAN THINK OF *
!***********************************************************************
%IF DIS=0 %START; ! VARIOUS NOOPS AND LRS POSSIBLE
%IF X=LEVEL=0 %THEN PIXRR(SLR,REG,REG) %AND %RETURN
%IF REG=X %AND LEVEL=0 %THEN %RETURN
%IF REG=LEVEL %AND X=0 %THEN %RETURN
%IF LEVEL=0 %OR X=0 %THEN PIX RR(LR,REG,LEVEL+X) %AND %RETURN
%FINISH
%IF REG#0 %AND ((REG=LEVEL %AND X=0) %OR (REG=X %AND LEVEL=0)) %THEN %C
INC REG(REG,DIS,YES) %AND %RETURN; ! IMPROVES CODE IF DIS>4095
%IF DIS>4095 %THEN ADJUST INDEX(1,X,DIS)
PIX RX(LA,REG,X,LEVEL,DIS)
%END
%ROUTINE DUMPSI(%INTEGER OPCODE, L, B, D)
!***********************************************************************
!* OUTPUTS A SI INSTRUCTION DEALING WITH DISPLACEMENTS>4095 *
!***********************************************************************
%IF D>4095 %THEN ADJUST INDEX(1, B, D)
PIX SI(OPCODE, L, B, D)
%END
%ROUTINE DUMPM(%INTEGER OPCODE, R1, R2, B, D)
!***********************************************************************
!* OUTPUTS A STM TYPE OF INSTRUCTION COMPENSATIONG FOR D>4095 *
!***********************************************************************
%IF D>4095 %THEN ADJUST INDEX(1, B, D)
PIX RS(OPCODE, R1, R2, B, D)
%END
%ROUTINE DUMPSS(%INTEGER OP,L,B1,D1,B2,D2)
!***********************************************************************
!* OUTPUTS AN SS INSTRN DEALING WITH EITHER OR BOTH DISPLACEMENTS *
!* OF MORE THAN 4096 (PROVIDED BASES ARE CORRECTLY CLAIMED *
!***********************************************************************
%INTEGER C1,C2
C1=B1; C2=B2
%IF D1>4095 %THEN ADJUST INDEX(0,B1,D1) %AND REGS(B1)_CL=2
%IF D2>4095 %THEN ADJUST INDEX(0,B2,D2) %AND REGS(B2)_CL=2
%IF OP=MVC %THEN PMVC(L,B1,D1,B2,D2) %ELSE %C
PIX SS(OP,0,L,B1,D1,B2,D2)
%IF B1#C1 %THEN REGS(B1)_CL=0
%IF B2#C2 %THEN REGS(B2)_CL=0
%END
%ROUTINE EXECUTESS(%INTEGER XREG,OPCODE,B1,D1,B2,D2)
!***********************************************************************
!* PUTS A ZERO LENGTH STORE TO STORE INSTRUCTION INTO CONSTANTS *
!* AND EXECUTES IT WITH 'EX' *
!***********************************************************************
%INTEGER I,J,K,C1,C2
C1=B1; C2=B2
%IF D1>4095 %THEN ADJUST INDEX(0,B1,D1) %AND REGS(B1)_CL=2
%IF D2>4095 %THEN ADJUST INDEX(0,B2,D2) %AND REGS(B2)_CL=2
I=OPCODE<<24!B1<<12!D1
J=B2<<28!D2<<16
STORE CONST(K,6,ADDR(I))
DUMPRX(EX,XREG,0,CTABLEREG,K)
%IF B1#C1 %THEN REGS(B1)_CL=0
%IF B2#C2 %THEN REGS(B2)_CL=0
%END
%ROUTINE NOTE ASSMENT(%INTEGER REG, ASSOP, VAR,PTYPE)
!***********************************************************************
!* NOTES THE ASSIGNMENT TO SCALAR 'VAR'. THIS INVOLVES REMOVING *
!* OLD COPIES FROM REGISTERS TO AVOID CONFUSING OLD AND NEW VALUE*
!* ASSOP =1 FOR'==',=2 FOR '=',=3 FOR '<-' *
!***********************************************************************
%CONSTINTEGER EEMASK=B'1100011110000000';! MASK OF USES RELEVANT TO ==
%CONSTINTEGER EMASK=B'100011000000000';! MASK OF USES RELEVANT TO =
%RECORD(REGF)%NAME WREG
%INTEGER I,II,NREGS,UU
%RETURN %IF VAR<=0
NREGS=REGWORDS(PTYPE)>>4
%IF ASSOP=1 %THEN %START
%CYCLE II=0,1,14; ! THROUGH ALL REGISTERS
I=GRMAP(II)
WREG==REGS(I)
%IF EEMASK&1<<WREG_SECUSE#0 %AND (WREG_INF2&X'FFFF'=VAR %OR %C
WREG_INF2>>16=VAR) %THEN WREG_SECUSE=0
%IF EEMASK&1<<WREG_PRIMUSE#0 %AND (WREG_INF1&X'FFFF'=VAR %OR %C
WREG_INF1>>16=VAR) %THEN WREG_USE=WREG_SECUSE %AND %C
WREG_INF1=WREG_INF2
%REPEAT
%IF REG>=0 %AND NREGS<=2 %THEN SET USE(REG+NREGS-1,X'51',ADDROF,VAR)
%FINISH %ELSE %START
%CYCLE II=0,1,14
I=GRMAP(II)
WREG==REGS(I)
%IF EMASK&1<<WREG_SECUSE#0 %AND (WREG_INF2&X'FFFF'=VAR %OR %C
WREG_INF2>>16=VAR %OR WREG_INF2=VAR) %THEN WREG_SECUSE=0
%IF EMASK&1<<WREG_PRIMUSE#0 %AND (WREG_INF1&X'FFFF'=VAR %OR %C
WREG_INF1>>16=VAR %OR WREG_INF1=VAR) %THEN %C
WREG_USE=WREG_SECUSE %AND WREG_INF1=WREG_INF2
!
! ALL THE FOREGOING CONDITIONS ARE NOT AS SILLY AS THEY SEEM. MUST
! BEAR IN MIND THAT BOTH GRINF&VAR MAY BE RECORD ELEMENTS DEFINED
! BY ALL 32 BITS OF INF AS WELL AS MODIFIED SCALARS WHEN THE NAME
! ONLY TAKES 16 BITS
!
%REPEAT
%IF ASSOP=2 %AND VAR>0 %AND REG>=0 %START
UU=LOCAL VAR
%FOR REG=REG,1,REG+NREGS-1 %CYCLE
WREG==REGS(REG)
%IF LITCONST<=WREG_PRIMUSE&255<=TABCONST %START; ! ASSIGN CONST TO VAR
WREG_SECUSE=UU
WREG_INF2=VAR
%FINISH %ELSE %START; ! ASSIGN VAR OR EXP TO VAR
WREG_SECUSE=WREG_PRIMUSE
WREG_PRIMUSE=UU
WREG_INF2=WREG_INF1; ! PREVIOUS USE BECOMES 2NDRY
WREG_INF1=VAR
%FINISH
UU=UU!128; ! CONTINUATION BIT FOR SUBSEQUENT REGS
%REPEAT
%FINISH
%FINISH
%END
%ROUTINE BULK M(%INTEGER MODE,L,B1,D1,B2,D2)
!***********************************************************************
!* PLANT CODE TO MOVE L BYTES (L KNOWN AT COMPILE TIME) FROM *
!* D1(B1) TO D2(B2) *
!* IF MODE =0 SET L BYTES TO D2(0 OR X'80') *
!* *
!* L MAY BE GREATER THAN 4095 *
!***********************************************************************
%ROUTINESPEC UPDATE(%INTEGERNAME WI,DI)
%INTEGERFNSPEC USE LONG
%INTEGER I,J,W1,W2,OPCODE,CONST
W1=B1; W2=B2
%IF L>1024 %AND USE LONG=0 %THEN %RETURN
OPCODE=MVC
%IF L+D1> 4092 %THEN UPDATE(W1,D1)
%IF MODE#0 %AND L+D2>4092 %THEN UPDATE(W2,D2)
%IF MODE=0 %THEN %START; ! PROPAGATE CONSTANT
J=L; W2=W1
CONST=D2; D2=D1
%IF CONST=0 %AND L<=32 %THEN %START
! CCSTATE=-1
OPCODE=X'D7'; ! CAN USE XC
%FINISH %ELSE %START; ! USE MVI & MVC TO PROPOGATE
PIX SI(MVI,CONST,W1,D1)
L=L-1; D1=D1+1
%FINISH
%FINISH
!
! END OF PREPARATION - CYCLE ROUND PLANTING MVC
!
%WHILE L>0 %CYCLE
%IF L>256 %THEN J=256 %ELSE J=L
%IF D1>4092 %THEN %START
I=D1; UPDATE(W1,D1)
%IF W2=W1 %THEN D2=D2-I+D1; ! OVERLAPPING PROPAGATION W1=W2
%FINISH
%IF D2>4092 %THEN UPDATE(W2,D2)
PIX SS(OPCODE,0,J,W1,D1,W2,D2)
D1=D1+J
D2=D2+J
L=L-J
%REPEAT
!
%RETURN
%INTEGERFN USE LONG
!***********************************************************************
!* ATTEMPTS TO USE MVCL FOR THIS BULK MOVE. MAY FAIL (RESULT#0) *
!* SINCE TWO EVENODD PAIRS ARE NOT ALWAYS AVAILABLE *
!***********************************************************************
%INTEGER PAIR0,PAIR1
PAIR0=CHECKSEQREG(GRPAIR)
%IF PAIR0<0 %THEN %RESULT=1
REGS(PAIR0)_CL=-1
PAIR1=CHECKSEQREG(GRPAIR)
%IF PAIR1<0 %THEN REGS(PAIR0)_CL=0 %AND %RESULT=1
DUMPLA(PAIR0,0,B1,D1)
FORGET(PAIR0)
DUMPLA(PAIR0+1,0,0,L)
FORGET(PAIR0+1)
%IF MODE=0 %START; ! CLEAR TO ZERO OR BYTE
PIXRR(LR,PAIR1,PAIR0); ! ANY VALIDE ADDRESS
DUMPLA(PAIR1+1,0,0,D2&255)
%IF D2#0 %THEN PIX RS(SLL,PAIR1+1,0,0,24);! FILLER TO TOP
%ELSE
DUMPLA(PAIR1,0,B2,D2)
PIX RR(LR,PAIR1+1,PAIR0+1)
%FINISH
FORGET(PAIR1)
FORGET(PAIR1+1)
PIX RR(MVCL,PAIR0,PAIR1)
REGS(PAIR0)_CL=0
%RESULT=0
%END
%ROUTINE UPDATE(%INTEGERNAME WI,DI)
%INTEGER WK,J
WK=WI
%IF REGS(WK)_CL#0 %THEN WK=FIND REG(GR1,0)
%IF DI<4092 %THEN J=DI %ELSE J=4092
DUMPLA(WK,0,WI,J)
FORGET(WK)
DI=DI-J; WI=WK
%END
%END; ! OF ROUTINE BULK M
%ROUTINE POLISH LOOP(%RECORD (TRIPF) %NAME FPTRIP)
!***********************************************************************
!* POLISHES THE CODE AROUND A LOOP THAT IS KNOWN TO BE SHORT *
!* AND FREE FROM CONTAINED LOOPS. A BXH IS ARRANGED WHERE POSSIBLE *
!* AND SPARE REGISTERS ARE USED FOR BASES AND CONSTANTS *
!***********************************************************************
%INTEGER I,J,K,REGMASK,USEDMASK,OP,FORBITS,FREE REGS,ADEX,CPTR
%INTEGER INCFLAG,INCVAL,FINALFLAG,FINALVAL
%RECORDFORMAT IOPNDF(%INTEGER CNT,MODE,%RECORD(RD)OPND)
%CONSTINTEGER MAX=15
%RECORD(IOPNDF)%ARRAY IOPNDA(0:MAX)
%RECORD(IOPNDF)%NAME IOPND
%ROUTINESPEC QUICKSORT(%RECORD(IOPNDF)%ARRAYNAME X,%INTEGER L,U)
%ROUTINESPEC ADDIN(%INTEGER MODE,%RECORD(RD)%NAME OPND)
%RECORD(RD) TOPND
%CONSTLONGINTEGER LO=1
%CONSTLONGINTEGER BOPMASK=LO<<(ZCOMP-128)!LO<<(CLSHIFT-128)! %C
LO<<(CASHIFT-128)!LO<<(IEXP-128)!LO<<(REXP-128)!LO<<(AAINC-128)! %C
LO<<(IOCPC-128)!LO<<(MULT-128){MH OPTIMISATION!}
%LONGINTEGER UOP,BOP
%CONSTLONGINTEGER L1=1
%RECORD (TRIPF) %NAME COMPTRIP,ADDTRIP,JTRIP,ASSTRIP,POSTTRIP,LTRIP,
CURRT,FP2TRIP
FORBITS=FPTRIP_X1; ! BITS DEFINED IN CLOOP OF PASS2
OP=0
INCFLAG=-1; FINALFLAG=-1
%IF FORBITS&2#0 %START; ! CONST INCREMENT
%IF FORBITS&X'FFFF03'=X'820803' %THEN OP=BCT %ELSE %C
%IF FORBITS&X'800000'#0 %THEN OP=BXLE %ELSE OP=BXH
%FINISH
%IF OP=BCT %START
FP2TRIP==TRIPLES(FPTRIP_FLINK)
COMPTRIP==TRIPLES(FP2TRIP_FLINK)
JTRIP==TRIPLES(COMPTRIP_FLINK)
LTRIP==TRIPLES(JTRIP_FLINK)
ASSTRIP==TRIPLES(LTRIP_FLINK)
%ELSE
LTRIP==TRIPLES(FPTRIP_FLINK); ! THE LABEL FOR REPEATING
FP2TRIP==TRIPLES(LTRIP_FLINK); ! THE SECOND PREAMBLE
COMPTRIP==TRIPLES(FP2TRIP_FLINK); ! THE COMPARISION
JTRIP==TRIPLES(COMPTRIP_FLINK)
ADDTRIP==TRIPLES(JTRIP_FLINK)
ASSTRIP==TRIPLES(ADDTRIP_FLINK); ! THE ASSIGNMENT TO THE CONTROL
%FINISH
POSTTRIP==TRIPLES(FPTRIP_PUSE); ! THE POSTAMBLE
IMPABORT %UNLESS (COMPTRIP_OPERN=COMP %OR COMPTRIP_OPERN=ZCOMP) %AND %C
JTRIP_OPERN=FJUMP %AND ASSTRIP_OPERN=VASS
!
REGMASK=0; ! NO USABLE REGISTERS AS YET
USEDMASK=0; ! NO REGISTERS USED AS YET
FREE REGS=0; ! COUNT OF FREE REGISTERS
%FOR I=4,1,9 %CYCLE
%IF REGS(I)_CL=0 %THEN %C
REGMASK=REGMASK!(1<<I) %AND FREE REGS=FREE REGS+1
%REPEAT
!
J=FPTRIP_FLINK
CPTR=0; UOP=0; BOP=0
%UNTIL J=0 %OR J=FPTRIP_PUSE %CYCLE
CURRT==TRIPLES(J)
K=CURRT_OPERN
%IF K=NULLT %THEN J=CURRT_FLINK %AND %CONTINUE
%IF K<128 %THEN UOP=UOP!(L1<<K) %ELSE BOP=BOP!(L1<<(K&63))
%IF K=AINDX %THEN ADDIN(1,CURRT_OPND1)
%FOR I=0,1,K>>7 %CYCLE
%IF I=0 %THEN TOPND=CURRT_OPND1 %ELSE TOPND=CURRT_OPND2
%IF X'41'<=TOPND_PTYPE<=X'51' %AND TOPND_FLAG=0 %C
%AND 0<=TOPND_D<=4095 %AND (K<128 %OR LO<<(K-128)&BOPMASK=0) %START
TOPND_XTRA=0
ADDIN(2,TOPND); ! RECORD ANY CNST
%FINISH
%REPEAT
J=CURRT_FLINK
%REPEAT
%IF BOP&(LO<<(SCOMP-128))#0 %START
FREE REGS=FREE REGS-1
%FINISH %ELSE %IF UOP&LO<<RCALL#0 %THEN FREE REGS=FREE REGS-1
->SKIP BXH %UNLESS %C
FREE REGS>=3 %AND (OP=BXLE %OR OP=BXH)
%FOR I=8,-2,4 %CYCLE; ! CHOOSE A PAIR FOR BXH
%IF REGMASK>>I&3=3 %THEN K=I %AND ->CHOSEN
%REPEAT
->SKIP BXH; ! NO PAIR AVAILABLE
CHOSEN: ! K HAS A VALID PAIR FOR BXH
INCFLAG=0; INCVAL=ADDTRIP_OPND2_D; ! RECORD INCREMENT VAL
LOAD(ADDTRIP_OPND2,K,2); ! INC(CONST) TO EVEN REG
REGS(K)_CL=-1
TOPND=COMPTRIP_OPND2
FINALFLAG=TOPND_FLAG
%IF FINALFLAG=0 %AND OP=BXLE %THEN TOPND_D=TOPND_D+INCVAL
FINALVAL=TOPND_D
LOAD(TOPND,K+1,2); ! FINAL TO ODD REG
REGS(K+1)_CL=-1
%IF OP=BXLE %AND FINALFLAG#0 %THEN PIX RR(AR,K+1,K) %AND REGS(K+1)_USE=0
REGMASK=REGMASK!!(3<<K)
USEDMASK=USEDMASK!(3<<K)
FREE REGS=FREE REGS-2
!
! REAARANGE THE TRIPLES CANCELLING UNNECESSARY ONES
!
ASSTRIP_OPND2=COMPTRIP_OPND1
FP2TRIP_CNT=1
FP2TRIP_PUSE=ADDTRIP_FLINK
COMPTRIP_OPERN=NULLT
ADDTRIP_OPERN=NULLT
!
! FORCE IN A BXH BY PATCHING AN ASSEMBLER JUMP INTO JTRIP
!
JTRIP_OPND1_D=JTRIP_OPND1_D!X'40000000'; ! ASSEMBLER BIT
JTRIP_X1=OP<<8!1<<4!K
SKIPBXH:
!
! SET UP A BASE REGISTER IF POSSIBLE
!
%IF FREE REGS>0 %AND 4095-MARGIN<=CA %START
%FOR I=9,-1,4 %CYCLE
%IF 1<<I®MASK#0 %THENEXIT
%REPEAT
PIX RR(BALCODE-X'40',I,0)
SET USE(I,X'51',BASEREG,CA)
PUSING(I)
REGMASK=REGMASK!!(1<<I)
USEDMASK=USEDMASK!(1<<I)
FREE REGS=FREE REGS-1
REGS(I)_CL=-1
%FINISH
!
! CAN NOW CHECK AND PRELOAD ARRAY BASES ETC
!
%IF FREE REGS=0 %THEN ->FINALE
%IF INCFLAG=0 %START
%FOR I=0,1,CPTR-1 %CYCLE; ! DELETE CNSTS SAME AS INC OR FINAL
IOPND==IOPNDA(I)
%IF IOPND_MODE=2 %AND (IOPND_OPND_D=INCVAL %OR %C
(FINAL FLAG=0 %AND IOPND_OPND_D=FINALVAL)) %THEN IOPND_CNT=0
%REPEAT
%FINISH
%IF CPTR>0 %THEN QUICKSORT(IOPNDA,0,CPTR-1)
%IF PARM_DCOMP#0 %START
PRINTSTRING("
PRELOAD LIST")
%FOR I=0,1,CPTR-1 %CYCLE
IOPND==IOPNDA(I)
NEWLINE
WRITE(IOPND_CNT,1)
WRITE(IOPND_MODE,4)
SPACE
PRHEX(IOPND_OPND_S1,8)
SPACE
PRHEX(IOPND_OPND_D,8)
SPACE
PRHEX(IOPND_OPND_XTRA,8)
%REPEAT
NEWLINE
%FINISH
%FOR ADEX=0,1,CPTR-1 %CYCLE
IOPND==IOPNDA(ADEX)
%IF FREE REGS<=0 %OR IOPND_CNT=0 %THEN %EXIT
%IF IOPND_MODE=1 %AND BOP&(LO<<(AHASS-128))#0 %THEN %CONTINUE
%FOR I=9,-1,4 %CYCLE
%IF REGMASK&1<<I#0 %THEN %EXIT
%REPEAT
TOPND=IOPND_OPND; ! THE ARRAY BASE
LOAD(TOPND,I,2)
REGS(I)_CL=-1
USEDMASK=USEDMASK!(1<<I)
REGMASK=REGMASK!!(1<<I)
FREE REGS=FREE REGS-1
%REPEAT
FINALE:
!
! FINALLY PASSED USEDMASK TO POSTAMBLE SO REGISTERS CAN BE RELEASED
!
POSTTRIP_OPND1_D=USEDMASK
%RETURN
%ROUTINE ADDIN(%INTEGER MODE,%RECORD(RD)%NAME OPND)
%INTEGER I
%RECORD(IOPNDF)%NAME IOPND
%FOR I=0,1,CPTR-1 %CYCLE
IOPND==IOPNDA(I)
%IF OPND_S1=IOPND_OPND_S1 %AND OPND_D=IOPND_OPND_D %AND %C
OPND_XTRA=IOPND_OPND_XTRA %THEN %START
IOPND_CNT=IOPND_CNT+1
%RETURN
%FINISH
%REPEAT
%RETURN %IF CPTR>MAX
IOPND==IOPNDA(CPTR)
IOPND_CNT=1
IOPND_MODE=MODE
IOPND_OPND=OPND
CPTR=CPTR+1
%END
%ROUTINE QUICKSORT(%RECORD(IOPNDF)%ARRAYNAME X,%INTEGER FROM,TO)
%INTEGER L,U
%RECORD(IOPNDF)D
%RETURN %IF FROM>=TO; ! NOTHING (LEFT) TO SORT
L=FROM; U=TO
D=X(U); ! THE PARTITION BOUND
%CYCLE
L=L+1 %WHILE L<U %AND D_CNT<X(L)_CNT
%EXIT %IF L>=U
X(U)=X(L);
U=U-1 %WHILE L<U %AND X(U)_CNT<D_CNT
X(L)=X(U)
L=L+1
%REPEAT %UNTIL L>=U
X(U)=D
L=L-1; U=U+1
QUICKSORT(X,FROM,L) %IF FROM<L
QUICKSORT(X,U,TO) %IF TO>U
%END
%END
%END; ! OF ROUTINE GENERATE
%ENDOFFILE