! ! Warning this module has the revised triples spec. ! ! In first attempt at Triple Imp considerable use was made of constant operands ! to pass information from Pass2 to GEN. Although for specialised operations like ! passing Labels this still applies, this adhocery has caused problems with arrays ! and pointers particularly in mapped records. The operands for four triples ! have thus been redefined in a more standard way. ! ! GETPTR X1 is now (ptype of passed)<<16! DIMENSION ! Opnd2 is either a 32 bit const with the size (ACC) as value or ! the ptr or arrayhead as normal operand. ! ! VMY X1 is now dim<<28!maxdim<<24!array name(where known) ! Opnd2 is either a 32 bit const with DV offset into const area or ! the arrayhead as a standard operand ! ! AINDX X1 is ELSIZE<<20 !spare ! Opnd2 is arrayhead as standard operand ! NOTE:- The Operands have been swopped for consistency with norm. ! ! BADJ X1 is arrayptype<<16!no of Dimensions (latter in case of backward dvs) ! Opnd2 exactly as for VMY ! %INCLUDE "ERCC07.TRIMP_HOSTCODES" %CONSTINTEGER HOST=EMAS %CONSTINTEGER TARGET=EMAS %CONSTINTEGER USE IMP=NO ! ! THE PRINCIPAL OPCODES ARE HERE DEFINED AS THEIR MNEMONICS(AMENDED) ! %CONSTINTEGER LB=X'7A',SLB=X'52',STB=X'5A',ADB=X'20',CPB=X'26', %C MYB=X'2A',SBB=X'22',CPIB=X'2E',OUT=X'3C',CPSR=X'34' %CONSTINTEGER LD=X'78',LDA=X'72',INCA=X'14',STD=X'58',LDB=X'76', %C LDTB=X'74',LDRL=X'70',CYD=X'12',MODD=X'16',SLD=X'50' %CONSTINTEGER STLN=X'5C',ASF=X'6E',ST=X'48',RALN=X'6C',LXN=X'7E',%C LLN=X'7C',LSS=X'62',SLSS=X'42',MPSR=X'32',STSF=X'5E',%C LUH=X'6A',STUH=X'4A',LSD=X'64',SLSD=X'44',PRCL=X'18', %C LSQ=X'66',SLSQ=X'46',STXN=X'4C',LCT=X'30',STCT=X'36' %CONSTINTEGER JUNC=X'1A',JLK=X'1C',CALL=X'1E',EXIT=X'38',JCC=2, %C JAT=4,JAF=6,DEBJ=X'24' %CONSTINTEGER IAD=X'E0',ICP=X'E6',USH=X'C8',ISB=X'E2',IRSB=X'E4',%C OR=X'8C',UCP=X'C6',IMY=X'EA',IMDV=X'AE',AND=X'8A', %C ISH=X'E8',IMYD=X'EC',IDV=X'AA',IRDV=X'AC',NEQ=X'8E' %CONSTINTEGER RAD=X'F0',RSB=X'F2',RRSB=X'F4',FLT=X'A8',RRDV=X'BC', %C RSC=X'F8',FIX=X'B8',RDV=X'BA',RDDV=X'BE',RMYD=X'FC', %C RMY=X'FA',RCP=X'F6' ! %CONSTINTEGER MVL=X'B0',MV=X'B2',SWEQ=X'A0',SWNE=X'A2',CPS=X'A4' ! ! DEFINE SOME MNEMONICS FOR THE VISIBLE REGISTERS (XCEPT LNB) ! %CONSTINTEGER ACCR=0,DR=1,LNB=2,XNB=3,PC=4,CTB=5,TOS=6,BREG=7 %CONSTBYTEINTEGERARRAY LDCODE(0:7)=LSS,LD,LLN,LXN,0,LCT,0,LB; %CONSTBYTEINTEGERARRAY STCODE(0:7)=ST,STD,STLN,STXN,0,STCT,STSF,STB; %CONSTBYTEINTEGERARRAY INCCODE(0:7)=IAD,INCA,0(5),ADB; ! %INCLUDE "ERCC07.TRIPCNSTS" %INCLUDE "ERCC07.TRIMP_TFORM1S" %RECORDFORMAT REGF(%INTEGER CL,(%INTEGER USE %OR %HALF SECUSE,PRIMUSE), %INTEGER INF1,INF2,AT,LINK) %OWNINTEGER CABUF,GLACABUF,CDCOUNT,CONSTHOLE,CREFHEAD,PROFDATA %OWNINTEGERNAME CA,GLACA %OWNINTEGER PPCURR=0,GLACURR=0 !%OWNINTEGERNAME ASL %OWNRECORD(LISTF)%ARRAYNAME ASLIST %OWNBYTEINTEGERARRAY CODE(0:268) %OWNBYTEINTEGERARRAY GLABUF(0:268) %OWNINTEGERARRAYNAME CTABLE %OWNINTEGERARRAYNAME TAGS %EXTRINSICINTEGERARRAY CAS(0:10) %EXTRINSICRECORD(WORKAF)WORKA %EXTRINSICRECORD(PARMF) PARM %OWNRECORD(REGF)%ARRAY REGS(0:7) %OWNRECORD(REGF)%NAME ACCREG,DRREG,BREGREG %OWNINTEGERARRAY DESADS(0:31) %CONSTINTEGER MAXKXREF=5 %OWNINTEGERARRAY KXREFS(0:MAXKXREF) %CONSTSTRING(11)%ARRAY KXREFNAME(0:MAXKXREF)="S#STOP","S#NDIAG", "S#ILOG","S#IEXP","S#IOCP", "ICL9CEAUXST"; %STRING(255)%FNSPEC PRINTNAME(%INTEGER N) %EXTERNALROUTINESPEC FLAGAND FOLD(%RECORD(TRIPF)%ARRAYNAME T) %SYSTEMINTEGERMAPSPEC COMREG(%INTEGER N) %SYSTEMROUTINESPEC NCODE(%INTEGER A,B,C) %SYSTEMROUTINESPEC LPUT(%INTEGER A,B,C,D) %EXTERNALSTRING(255)%FNSPEC UCSTRING(%STRING(255) S) %EXTERNALROUTINESPEC FAULT(%INTEGER I,J,K) %ROUTINESPEC PF1(%INTEGER OPCODE,A,B,N) %ROUTINESPEC PRINT USE %ROUTINESPEC IMPABORT %EXTERNALROUTINESPEC PUSH(%INTEGERNAME CELL,%INTEGER S1,S2,S3) %ROUTINESPEC NOTE CREF(%INTEGER CA) %ROUTINESPEC STORECONST(%INTEGERNAME D,%INTEGER L,AD) %INTEGERFNSPEC WORDCONST(%INTEGER VAL) %ROUTINESPEC CNOP(%INTEGER I,J) %EXTERNALROUTINESPEC POP(%INTEGERNAME A,B,C,D) %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 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(1:16)=X'31',X'41',X'57',X'51', X'57'(3),X'62',X'57'(7),X'72'; %CONSTINTEGERARRAY DESCTOP(0:7)=1,-1,-1,X'18000001',X'58000002', X'28000001',X'30000001',X'38000001'; %CONSTINTEGER DAREA=4; ! AREA FOR DIAG TABLES ! ! FIXED GLA CURRENTLY USED AS FOLLOWS ! 0-7 FREE(WAS 2900 ENTRY DESCRIPTOR) ! 8-11 ADDRESS OF UNSHARED SYMBOL TABLES ! 12-15 ADDRESS OF SHARED SYMBOL TABLES ! 16-19 LANGUAGE & COMPILER DATA ! 20-23 RESERVED (BUT IN MAIN PROGS IS FILLED WITH STACKPTR@ENTRY) ! 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 ! 40-55 DEFINES THE ENTRY POINT OF MDIAGS ! %CONSTINTEGER FIXEDGLALEN=56 %OWNINTEGERARRAY FIXED GLA(0:FIXEDGLALEN>>2-1)=M'IMP ',M'GLAP', 0(6),M'IDIA',0(*); ! !*********************************************************************** !* IMP CODE PLANTING ROUTINES * !* CODE AND GLAP ARE PUT INTO THE BUFFERS 'CODE,GLABUF(0:268)' * !* BY A NUMBER OF TRIVIAL ROUTINES.LPUT IS CALLED TO ADD THE * !* BUFFER TO THE OUTPUT FILE. THE BUFFERS ARE BASICALLY 0:255 * !* WITH A 12-BYTE MARGIN TO MINIMISE THE NUMBER OF TESTS FOR * !* THE BUFFER FULL CONDITION * !* * !* PPCURR(GLACURR) IS THE BUFFER POINTER * !* CA(GLACA) IS THE RELATIVE ADDRESS OF THE NEXT BYTE * !* CABUF(GLACABUF) IS CA(GLACA) FOR START OF BUFFER * !*********************************************************************** %ROUTINE CPINIT !*********************************************************************** !* PERFORMS ANY NECESSARY TARGET DEPENDANT INITIALISING * !************************************************************************ %INTEGER I %STRING(63)S TAGS==WORKA_TAGS KXREFS(I)=0 %FOR I=0,1,MAXKXREF DESADS(I)=0 %FOR I=0,1,31 PPCURR=0; GLACURR=0 S=" OPTIMISING IMP80 RELEASE ".TOSTRING(WORKA_RELEASE+'0')." VSN 1" LPUT(0,-1,WORKA_RELEASE,ADDR(S));! OPEN OBJECT FILE ACCREG==REGS(ACCR) DRREG==REGS(DR) BREGREG==REGS(BREG) %END %ROUTINE RECODE(%INTEGER S,F,AD) %IF S#F %START PRINTSTRING(" CODE FOR LINE"); WRITE(WORKA_LINE,3) NCODE(S,F,AD) PRINT USE NEWLINE %FINISH %END %EXTERNALROUTINE CODEOUT %IF PPCURR>0 %THEN %START RECODE(ADDR(CODE(0)), ADDR(CODE(PPCURR)), CABUF) %C %IF PARM_DCOMP#0 LPUT(1, PPCURR, CABUF, ADDR(CODE(0))) %IF PARM_INHCODE=0 PPCURR=0; CABUF=CA %FINISH %END %ROUTINE PLANT(%INTEGER HALFWORD) !*********************************************************************** !* ADD A HALF WORD OF BINARY TO THE BUFFER * !*********************************************************************** %IF USE IMP=YES %THEN %START CODE(PPCURR)<-HALFWORD>>8 CODE(PPCURR+1)<-HALFWORD PPCURR=PPCURR+2 %FINISH %ELSE %START *LDA_CODE+4 *LDTB_X'58000002' *LB_PPCURR *LSS_HALFWORD *ST_(%DR+%B) *ADB_2 *STB_PPCURR %FINISH CA=CA+2 CODEOUT %IF PPCURR>=256 %END %ROUTINE PCONST(%INTEGER WORD) !*********************************************************************** !* ADD A WORD OF BINARY TO THE BUFFER * !*********************************************************************** %IF USE IMP=YES %THEN %START %INTEGER I %CYCLE I=24,-8,0 CODE(PPCURR)=WORD>>I&255 PPCURR=PPCURR+1 %REPEAT %FINISH %ELSE %START *LDA_CODE+4 *LDTB_X'58000004' *LSS_WORD *LB_PPCURR *ST_(%DR+%B) *ADB_4 *STB_PPCURR %FINISH CA=CA+4 CODE OUT %IF PPCURR>=256 %END %ROUTINE PSF1(%INTEGER OPCODE,K,N) !*********************************************************************** !* PLANT THE HALFWORD FORMS OF PRIMARY FORMAT NR INSTRNS * !* IF N IS TOO LARGE FOR THE SHORT FORM PF1 IS CALLED TO PLANT * !* THE CORRESPONDING LONG FORM * !*********************************************************************** %INTEGER KPP ! IMPABORT %UNLESS 0<=K<=2 %AND OPCODE&1=0 %IF (K=0 %AND -64<=N<=63) %OR (K#0 %AND 0<=N<=511) %START %IF K#0 %THEN N=N//4 %IF USE IMP=YES %THEN %START CODE(PPCURR)=OPCODE!K>>1 CODE(PPCURR+1)=(K&1)<<7!N&127 PPCURR=PPCURR+2 %FINISH %ELSE %START *LSS_OPCODE *USH_1 *OR_K *USH_7 *SLSS_N *AND_127 *LB_PPCURR *OR_%TOS *LDA_CODE+4 *LDTB_X'58000002' *ST_(%DR+%B) *ADB_2 *STB_PPCURR %FINISH CA=CA+2 CODEOUT %IF PPCURR>=256 %FINISH %ELSE %START %IF K=0 %THEN KPP=0 %ELSE KPP=2 PF1(OPCODE,K>>1<<1,KPP,N) %FINISH %END %ROUTINE PF1(%INTEGER OPCODE,KP,KPP,N) !*********************************************************************** !* PLANT THE NORMAL FORMS OF PRIMARY FORMAT INSTRNS(IE THOSE * !* WHICH DO NOT DEPEND ON THE SIZE OF N) * !*********************************************************************** %INTEGER INC ! IMPABORT %UNLESS 0<=KP<=3 %AND 0<=KPP<=7 %AND OPCODE&1=0 INC=2 %IF KP=0=KPP %AND (NX'1FFFF') %START KPP=PC; N=WORD CONST(N) %FINISH %IF KPP=PC %THEN %START %IF N<0 %THEN N=N&X'7FFFFFFF' %AND NOTE CREF(CA) N=(N-CA)//2 %FINISH %IF (1<>16&3) CODE(PPCURR+2)=N>>8&255 CODE(PPCURR+3)=N&255 %FINISH %ELSE %START *LSS_OPCODE *USH_1 *OR_3 *USH_2 *OR_KP *USH_3 *OR_KPP *USH_18 *SLSS_N *AND_X'3FFFF' *OR_%TOS *LDTB_X'58000004' *LDA_CODE+4 *LB_PPCURR *ST_(%DR+%B) %FINISH %IF KPP<=5 %THEN INC=4 PPCURR=PPCURR+INC CA=CA+INC CODEOUT %IF PPCURR>=256 %END %ROUTINE PSORLF1(%INTEGER OPCODE,KP,KPP,N) !*********************************************************************** !* AS PF1 BUT CUT VALID FORMS TO SHORT FORM * !*********************************************************************** %INTEGER INC INC=2 %IF (KPP=0=KP %AND -64<=N<=63) %OR%C (KPP=LNB %AND KP&1=0 %AND 0<=N<=511) %START %IF KPP=LNB %THEN KP=1+KP>>1 %IF KP#0 %THEN N=N//4 %IF USE IMP=YES %THEN %START CODE(PPCURR)=OPCODE!KP>>1 CODE(PPCURR+1)=(KP&1)<<7!(N&127) %FINISH %ELSE %START *LSS_OPCODE *USH_1 *OR_KP *USH_7 *SLSS_N *AND_127 *LB_PPCURR *OR_%TOS *LDA_CODE+4 *LDTB_X'58000002' *ST_(%DR+%B) %FINISH %FINISH %ELSE %START %IF KP=0=KPP %AND (NX'1FFFF') %START KPP=PC; N=WORD CONST(N) %FINISH %IF KPP=PC %THEN %START %IF N<0 %THEN N=N&X'7FFFFFFF' %AND NOTE CREF(CA) N=(N-CA)//2 %FINISH %IF (1<>16&3) CODE(PPCURR+2)=N>>8&255 CODE(PPCURR+3)=N&255 %FINISH %ELSE %START *LSS_OPCODE *USH_1 *OR_3 *USH_2 *OR_KP *USH_3 *OR_KPP *USH_18 *SLSS_N *AND_X'3FFFF' *OR_%TOS *LDTB_X'58000004' *LDA_CODE+4 *LB_PPCURR *ST_(%DR+%B) %FINISH %IF KPP<=5 %THEN INC=4 %FINISH CA=CA+INC; PPCURR=PPCURR+INC CODEOUT %IF PPCURR>=256 %END %ROUTINE PF2(%INTEGER OPCODE,H,Q,N,MASK,FILLER) !*********************************************************************** !* PLANT SECONDARY(STORE TO STORE) FORMAT INSTRNS * !* THESE MAY BE 16 OR 32 BIT DEPENDING ON Q * !*********************************************************************** ! IMPABORT %UNLESS 0<=H<=1 %AND 0<=Q<=1 %AND 0<=N<=127 %C %AND OPCODE&1=0 PLANT(OPCODE<<8!H<<8!Q<<7!N) %IF Q#0 %THEN PLANT(MASK<<8!FILLER) %END %ROUTINE PF3(%INTEGER OPCODE,MASK,KPPP,N) !*********************************************************************** !* PLANT THE TERTIARY(JUMP) FORMAT INSTRUCTIONS * !*********************************************************************** ! IMPABORT %UNLESS 0<=MASK<=15 %AND 0<=KPPP<=7 %AND OPCODE&1=0 %IF KPPP=PC %THEN %START %IF N<0 %THEN N=N&X'7FFFFFFF' %AND NOTE CREF(CA) N=(N-CA)//2 %FINISH CODE(PPCURR)=OPCODE!MASK>>3&1 CODE(PPCURR+1)=(MASK&7)<<5!KPPP<<2!(N>>16&3) PPCURR=PPCURR+2 CA=CA+2 %IF KPPP<=5 %THEN %START CODE(PPCURR)=N>>8&255 CODE(PPCURR+1)=N&255 PPCURR=PPCURR+2; CA=CA+2 %FINISH CODEOUT %IF PPCURR>=256 %END %ROUTINE NOTE CREF(%INTEGER CA) !*********************************************************************** !* NOTE THAT A (PC+N) INSTRUCTION HAS N RELATIVE TO CONST TABLE * !* NOT REATIVE TO CODE. REMEMBER THE ADDRESS OF THE INSTRUCTION * !* SO THAT AN LPUT(18) CORRECTION CAN BE MADE AT END OF COMPILATION * !*********************************************************************** %RECORD(LISTF)%NAME CELL CELL==ASLIST(CREFHEAD) %IF CREFHEAD=0 %OR CELL_S3#0 %THEN %C PUSH(CREFHEAD,CA,0,0) %AND %RETURN %IF CELL_S2=0 %THEN CELL_S2=CA %ELSE CELL_S3=CA %END %ROUTINE CNOP(%INTEGER I, J) PSF1(JUNC,0,1) %WHILE CA&(J-1)#I %END %INTEGERFN MAPDES(%INTEGER PREC) !*********************************************************************** !* SET UP 8BIT ZERO ADDRESS UNSCALED BCI DESCRTR FOR MAPPING * !*********************************************************************** %INTEGER K,DES0,DES1 K=DESADS(PREC+8) %RESULT=K %UNLESS K=0 DES0=DESCTOP(PREC) %IF PREC#4 %THEN DES0=DES0!X'03000000' DES1=0; STORE CONST(K,8,ADDR(DES0)) DESADS(PREC+8)=K %RESULT=K %END %INTEGERFN SPECIAL CONSTS(%INTEGER WHICH) !*********************************************************************** !* PUTS CERTAIN SPECIAL CONSTANTS INTO THE CONSTANT TABLE ON * !* DEMAND AND REMEMBERS THEIR POSN TO AVOID SEARCHONG * !*********************************************************************** %CONSTINTEGERARRAY SCS(0:7) = X'40800000',0, X'41100000',0, 1,0, X'4F000000',0; %INTEGER K K=DESADS(WHICH+16) %RESULT=K %UNLESS K=0 STORE CONST(K,8,ADDR(SCS(2*WHICH))) DESADS(WHICH+16)=K %RESULT=K %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 %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; 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=4 %THEN %START J=CONST PTR %IF USE IMP=YES %THEN %START %WHILE K *ICP_(%DR+%B) *JCC_7, *CPB_CONSTHOLE *JCC_8, *LSS_%B *IMY_4 *OR_X'80000000' *ST_(D) *EXIT_-64 %FINISH %FINISH %ELSE %START J=CONSTPTR-LP %WHILE K<=J %CYCLE %IF CTABLE(K)=C1 %AND CTABLE(K+1)=C2 %AND %C (CONSTHOLE=K+LP) %START %IF L=8 %OR (CTABLE(K+2)=C3 %C %AND CTABLE(K+3)=C4) %THEN D=4*K!X'80000000' %C %AND %RETURN %FINISH K=K+2 %REPEAT %FINISH SKIP: %IF L=4 %AND CONSTHOLE#0 %START CTABLE(CONSTHOLE)=C1 D=4*CONSTHOLE!X'80000000' CONSTHOLE=0 %RETURN %FINISH %IF L>4 %AND CONST PTR&1#0 %C %THEN CONSTHOLE=CONST PTR %AND CONSTPTR=CONST PTR+1 D=4*CONST PTR!X'80000000' 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 I,J,K,C0,C1,LP %INTEGERNAME CONST PTR CONST PTR==WORKA_CONST PTR K=WORKA_CONST BTM; ! AFTER STRINGS IN CTABLE C0=X'18000000'!LENGTH(S) C1=8; ! SET UP FOR LDRL INSTRN LP=1+LENGTH(S)//4 J=CONSTPTR-LP %WHILE K<=J %CYCLE %IF CTABLE(K)=C0 %AND CTABLE(K+1)=C1 %AND %C S=STRING(ADDR(CTABLE(K+2))) %THEN D=4*K!X'80000000' %ANDRETURN K=K+2 %REPEAT %IF CONST PTR&1#0 %THEN CONSTHOLE=CONST PTR %AND CONSTPTR=CONST PTR+1 D=4*CONST PTR!X'80000000' CTABLE(CONSTPTR)=C0 CTABLE(CONSTPTR+1)=C1 STRING(ADDR(CTABLE(CONSTPTR+2)))=S CONST PTR=CONST PTR+2+LP %IF CONST PTR>WORKA_CONST LIMIT %THEN FAULT(102,WORKA_WKFILEK,0) %END %ROUTINE GET ENV(%INTEGERNAME HEAD) !*********************************************************************** !* SAVE A COPY OF THE REGISTER STATE FOR FUTURE REFERENCE * !*********************************************************************** %INTEGER I, USE %RECORD(REGF)%NAME REG IMPABORT %UNLESS HEAD=0 %CYCLE I=0, 1, 7 REG==REGS(I) USE=REG_USE&X'FF'; ! MAIN USE ONLY PUSH(HEAD, REG_INF1, REG_AT, I<<8!USE) %IF USE#0 %REPEAT %END %ROUTINE RESTORE(%INTEGER HEAD) !*********************************************************************** !* RESET THE REGISTERS TO ENVIRONMENT IN LIST HEADED BY 'HEAD' * !*********************************************************************** %INTEGER I, R, USE, INF, AT %RECORD(REGF)%NAME REG %CYCLE I=0, 1, 7 REG==REGS(I) %IF REG_CL>=0 %THEN REG_USE=0 %REPEAT %WHILE HEAD#0 %CYCLE POP(HEAD, INF, AT, I) R=I>>8; USE=I&255 REG==REGS(R) %IF REG_CL>=0 %THEN REG_USE=USE %AND REG_INF1=INF REG_AT=AT %REPEAT %END %ROUTINE REDUCE ENV(%INTEGERNAME OLDHEAD) !*********************************************************************** !* REMOVES FROM ENVIRONMENT OLDHEAD ANYTHING INCOMPATABLE WITH * !* THE CURRENT ENVIRONMENT. FOR MULTIPLE JUMPS TO LABELS * !*********************************************************************** %INTEGERNAME HEAD %INTEGER R,U,S1,S2,S3 %RECORD(LISTF)%NAME LCELL %RECORD(REGF)%NAME REG HEAD==OLDHEAD %WHILE HEAD>0 %CYCLE LCELL==ASLIST(HEAD) R=LCELL_S3>>8 U=LCELL_S3&255 REG==REGS(R) %IF (REG_PRIMUSE=U %AND REG_INF1=LCELL_S1) %OR %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 %ROUTINE FORGET(%INTEGER REG) !*********************************************************************** !* CLEARS OUT USES OF NON LOCKED REGISTERS * !*********************************************************************** %INTEGER L,U %RECORD(REGF)%NAME FREG L=REG; U=L %IF L<0 %THEN L=0 %AND U=7 %CYCLE REG=L,1,U FREG==REGS(REG); ! FORGETABLE REG %IF FREG_CL>= 0 %THEN FREG_USE=0 %REPEAT %END %ROUTINE PGLA(%INTEGER BDRY, L, INF ADR) %INTEGER I, J J=GLACA; GLACA=(J+BDRY-1)&(-BDRY) GLACURR=GLACURR+GLACA-J; ! COMPLETE THE ROUNDING %IF L+GLACURR>256 %THEN %START %IF PARM_INHCODE=0 %C %THEN LPUT(2, GLACURR, GLACABUF, ADDR(GLABUF(0))) GLACURR=0; GLACABUF=GLACA %FINISH %CYCLE I=0,1,L-1 GLABUF(GLACURR+I)=BYTE INTEGER(I+INF ADR) %REPEAT GLACA=GLACA+L; GLACURR=GLACURR+L %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 LPUT(AREA,L,PTR,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 LPUT(40+AREA,L<<24!REP,PTR,AD) PTR=PTR+REP*L %END %ROUTINE CODEDES(%INTEGERNAME AT,%INTEGER AFIELD) !*********************************************************************** !* PUT A CODE DESCRIPTOR INTO THE PLT FOR USE BY DEFINE EP * !*********************************************************************** %INTEGER DESC1,DESC2 DESC1=X'E1000000'; DESC2=AFIELD %IF CDCOUNT=0 %THEN %START FIXED GLA(0)=DESC1 FIXED GLA(1)=DESC2 AT=0 %FINISH %ELSE PGLA(4,4,ADDR(DESC2)) %AND AT=GLACA-8 CDCOUNT=CDCOUNT+1 %END %ROUTINE PLUG(%INTEGER AREA, AT, VALUE, BYTES) !*********************************************************************** !* WRITE UP TO ONE WORD INTO OBJECT FILE OUT OF SEQUENCE * !*********************************************************************** %INTEGERNAME WCABUF %INTEGER I, RELAD, BUFAD WCABUF==CABUF; BUFAD=ADDR(CODE(0)) %IF AREA=2 %THEN WCABUF==GLACABUF %AND BUFAD=ADDR(GLABUF(0)) RELAD=AT-WCABUF %IF 0<=RELAD<=256 %AND AREA<=3 %THEN %START %CYCLE I=0,1,BYTES-1 BYTEINTEGER(RELAD+BUFAD+I)<-VALUE>>((BYTES-1-I)<<3) %REPEAT %FINISH %ELSE %START %IF AREA=1 %AND RELAD=-2 %THEN CODEOUT %IF PARM_INHCODE=0 %THEN %C LPUT(AREA,BYTES,AT,ADDR(VALUE)+4-BYTES) NCODE(ADDR(VALUE)+4-BYTES,ADDR(VALUE)+4,AT) %C %IF PARM_DCOMP=1=AREA %FINISH %END %EXTERNALROUTINE FILL DTABREFS(%INTEGERNAME CURRINFRAL) !*********************************************************************** !* PLUGS REFENCES TO THE DIAG TABLES FOR CURRINF WHICH ARE * !* ABOUT TO BE GENERATED AT CAS(DAREA). THE LIST POPPED HAS * !* S1=AREA 1=CODE, DAREA FOR DIAGNOSTIC AREA * !* S2= THE OFFSET OF INSTRUCTION OR FORWARD POINTER * !* S3=THE WORD BEFORE FILLING - NOT USED FOR AREA 1 * !*********************************************************************** %INTEGER Q,JJ,KK %WHILE CURRINFRAL#0 %CYCLE POP(CURRINFRAL,Q,JJ,KK) %IF Q=1 %THEN %START LPUT(18,0,JJ,CAS(DAREA)) %FINISH %ELSE %START PLUG(Q,JJ,KK!CAS(DAREA),4) %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 %IF TYPE=5 %AND ACC=0 %THEN ACC=255;! CONST STRING NAMES NO LENGTH %IF PREC=4 %THEN X=X'58000002' %ELSE X=PREC<<27!(ACC//BYTES(PREC)) PGLA(4,4,ADDR(X)) RES=GLACA-4 PGLA(4,4,ADDR(OPND_D)) %IF LITL=3 %START; ! EXTRINSICS ARE NAMES LPUT(15,2<<24!ACC,RES+4,ADDR(XNAME));! RELOCATE BY EXTERNAL %FINISH ->END %FINISH RL=BYTES(PREC) %IF TYPE=5 %OR TYPE=3 %THEN RL=4 %IF RL>4 %THEN RL=4 PGLA(RL,0,ADDR(OPND_D)) RES=GLACA; %IF TYPE=3 %OR (TYPE=5 %AND OPND_D=0) %START PGLA(1,1,ADDR(OPND_D)+3) %FOR X=1,1,ACC ->END %FINISH %IF TYPE=5 %THEN %START PGLA(1,ACC,ADDR(WORKA_A(OPND_D))) %FINISH %ELSE %START %IF PREC=3 %THEN PGLA(1,1,ADDR(OPND_D)+3) %IF PREC=4 %THEN PGLA(1,2,ADDR(OPND_D)+2) %IF 5<=PREC<=6 %THEN PGLA(1,4,ADDR(OPND_D)) %IF PREC=6 %THEN PGLA(1,4,ADDR(OPND_XTRA)) %IF PREC=7 %THEN PGLA(1,16,ADDR(WORKA_A(OPND_D))) %FINISH END: ! NOTE ENTRYT IF EXTERNAL %IF LITL=2 %THEN LPUT(14,2<<24!ACC,RES,ADDR(XNAME)) %RESULT=RES %END %EXTERNALINTEGERFN POWNARRAYHEAD(%INTEGER PTYPE,J,LB,SIZE,AOFFSET,AAREA, DVOFFSET,%STRING(31)XNAME) !*********************************************************************** !* SOME PARAMETERS ARE ONLY REQUIRED FOR CREATING DESCRIPORS ON * !* 2900 ARCHITECTURE. THESE ARE REDUNDANT HERE * !*********************************************************************** %INTEGER LITL,RES,X,AHW0,AHW1,AHW2,AHW3,PREC,TYPE XNAME=UCSTRING(XNAME) TYPE=PTYPE&7 PREC=PTYPE>>4&15 %IF PREC=4 %THEN AHW0=X'58000002' %ELSE %IF TYPE<=2 %THEN %C AHW0=PREC<<27!(SIZE//BYTES(PREC)) %ELSE %C AHW0=3<<27!SIZE AHW1=AOFFSET AHW3=DVOFFSET+12 AHW2=5<<27!3*J PGLA(8,16,ADDR(AHW0)) RES=GLACA-16 LITL=PTYPE>>14&3 %IF LITL=3 %START; ! EXTRINSIC ARRAYS LPUT(15,2<<24!SIZE,RES+4,ADDR(XNAME));! RELOCATE BY EXTERNAL %FINISH %ELSE %START %IF AAREA#0 %THEN RELOCATE(RES+4,AHW1,AAREA) %FINISH RELOCATE(RES+12,AHW3,1); ! RELOCATE DV PTR NOTE CREF(X'80000000'!AHW3!(RES+12)>>2<<16) %IF LITL=2 %THEN LPUT(14,AAREA<<24!SIZE,AOFFSET,ADDR(XNAME)) %RESULT=RES %END %ROUTINE GXREF(%STRING(31) NAME,%INTEGER MODE,XTRA,AT) !*********************************************************************** !* ASK LPUT 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 DATA * !* MODE=4 DATA XREF XTRA=MINIMIUM LENGTH (SINGLE WORD ONLY) * !*********************************************************************** %CONSTBYTEINTEGERARRAY LPUTCODE(0:4)= 12,12,12,13,15 NAME=UCSTRING(NAME) %if name="S#READSTRING" %THEN name="READSTRING" %if name="S#CLOSESTREAM" %then name="CLOSESTREAM" %IF MODE<4 %THEN XTRA=2; ! IN GLA LPUT(LPUTCODE(MODE),XTRA,AT,ADDR(NAME)) %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 Z1=0; Z2=0 PGLA(8,8,ADDR(Z1)); ! 2 ZERO WORDS AT=GLACA-8 %IF MODE=1 %THEN NAME="S#".NAME GXREF(NAME,MODE,XTRA,AT) %END %INTEGERFN KNOWN XREF(%INTEGER N) %INTEGER D %RESULT= KXREFS(N) %UNLESS KXREFS(N)=0 CXREF(KXREFNAME(N),0,0,D) KXREFS(N)=D %RESULT=D %END %ROUTINE CALL STOP !*********************************************************************** !* CALLS STOP ROUTINE. NOT VIA EPILOGUE ON PERQ * !************************************************************************ PSF1(PRCL,0,4) PSF1(LCT,1,16) PSF1(RALN,0,5) PF1(CALL,2,CTB,KNOWNXREF(0)) %END %ROUTINE BULKM(%INTEGER MODE,L,D2) !*********************************************************************** !* PLANT CODE TO MOVE L BYTES (L KNOWN AT COMPILE TIME) FROM * !* (ACCR) TO (DR) * !* IF MODE =0 SET L BYTES TO D2(0 OR X'80') * !* * !* L MAY BE GREATER THAN 4095 * !*********************************************************************** %INTEGER W2,OP W2=0; ! L IN INSTRUCTIO %IF L>128 %THEN PF1(LDB,0,0,L) %AND L=1 %AND W2=1 %IF MODE=0 %THEN OP=MVL %ELSE OP=MV PF2(OP,W2,MODE!!1,L-1,0,D2) %END; ! OF ROUTINE BULK M %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 * !*********************************************************************** %INTEGER QP LPUT(19,2,GLARAD,AREA) %END %ROUTINE DEFINE EP(%STRING(255)XNAME, %INTEGER AREA,AT,MAINORMIN) !*********************************************************************** !* TO DEFINE AN EP SIMPLY TELL LPUT THE EP ADDRESS RELATIVE TO THE * !* START IF CODE. THIS IS STORED IN THE LOAD DATA. AT LOAD TIME * !* THE THREE WORDS IN THE GLA OF THE CALLING ROUTINE ARE FILLED * !* WITH START IF CODE,START OF GLA AND EP ADDRESS RESPECTIVELY * !* (DOCUMENTATION OF OBJECT FORMAT & LPUT DIFFER HEREABOUTS!) * !*********************************************************************** XNAME=UCSTRING(XNAME) %IF AREA=1 %START; ! CODE ENTRIES LPUT(11,MAINORMIN<<31!2,AT,ADDR(XNAME)) %FINISH %ELSE %START LPUT(14,AREA<<24!MAINORMIN,AT,ADDR(XNAME)) %FINISH %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:7)="ACC"," DR","LNB","XNB", " PC","CTB","TOS"," B"; %CONSTSTRING(15)%ARRAY USES(0:15) =" NOT KNOWN "," I-RESULT ", " TEMPORARY "," PLTBASE ", " NAMEBASE "," LIT CONST ", " TAB CONST "," DESC FOR ", " RECD BASE "," LOCAL VAR ", " NAME+CNST "," AUXSTPTR- ", " BYTE DES "," HALF DES ", " VMY DES "," REC HDES "; %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,7 REG==REGS(I) %IF REG_CL!REG_USE#0 %START USE=REG_USE PRINTSTRING(REGNAMES(I).STATE(REG_CL)) 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'1000011110000000' %CONSTINTEGER UNMASK=B'0000001110000000' PRINTSTRING(" USE = ".USES(USE)) %IF LNMASK&1<>16,1) %IF UNMASK&1<>16#0 %THEN PRINTSTRING(" MODBY ") %C %AND PRINTSTRING(PRINTNAME(INF>>16)) %END %END %EXTERNALROUTINE IMPABORT PRINTSTRING(" **************** ABORT******************** ABORT *******") RECODE(ADDR(CODE(0)), ADDR(CODE(PPCURR)), CABUF) %C %UNLESS CA=CABUF %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, L, STCA CPINIT; ! INITIALISE CODE PLANTING ASLIST==ALIST CA==CAS(1) GLACA==CAS(2) GLACA=FIXEDGLALEN GLACABUF=FIXEDGLALEN CABUF=CA CONST HOLE=0; CREFHEAD=0 CDCOUNT=0 CTABLE==WORKA_CTABLE I=X'C2C2C2C2' LPUT(0+DAREA,4,0,ADDR(I)) CAS(DAREA)=4 %CYCLE I=0, 1, 31 WORKA_PLABS(I)=0; WORKA_PLINK(I)=0 %REPEAT %CYCLE I=0,1,7 REGS(I)=0 KXREFS(I)=0 %IF I<=MAXKXREF %REPEAT ! ! GENERATE THE FIXED-FLOAT CONSTANTS THAT MAY BE NEEDED ! PCONST(UNASSPAT) %FOR I=1,1,2 WORKA_PLABS(1)=CA ! ! 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 ACC AS 64 BIT INTEGER ! ENTRY HAS BEEN BY JLK SO RETURN ADDRESS STACKED ! !RTF LXN (LNB+4) POINTER TO GLA ! PRCL 4 TO PLANT PARAMS ! JLK +1 STACK DUMMY PC ! STLN TOS LNB AS SECOND PARAMETER ! ST TOS ERROR NO AS THIRD PARAM ! RALN 9 TO STORED LNB ! CALL ((XNB+10)) VIA XREF=DESCRIPTOR-DESCRIPTOR ! J TOS BACK AFTER A MONITOR ! WORKA_PLABS(2)=CA PSF1(LXN,1,16) PSF1(PRCL,0,4) PSF1(JLK,0,1) PF1(STLN,0,TOS,0) PF1(ST,0,TOS,0) PSF1(RALN,0,9) PF1(CALL,2,XNB,KNOWN XREF(1)) PF1(JUNC,0,TOS,0) ! ! SUBROUTINE TO CALL DEBUG ROUTINE(S#IMPMON) LINE NO IN ACC ! ! PRCL 4 ! ST TOS ! LXN (LNB+4) ! RALN 6 ! CALL ((XNB+IMPMONEPDISP)) ! JUNC TOS ! %IF PARM_DBUG#0 %THEN %START WORKA_PLABS(3)=CA CXREF("S#IMPMON",0,2,K) PSF1(PRCL,0,4) PF1(ST,0,TOS,0) PSF1(LXN,1,16) PSF1(RALN,0,6) PF1(CALL,2,XNB,K) PF1(JUNC,0,TOS,0) %FINISH ! ! SUBROUTINE TO ADVANCE STACK FRONT BY B WORDS AND FILL WITH UNASSIGNED ! ! JAT 12,*+13 B IS ZERO ! LSS TOS ! STSF TOS ! LDTB STRING DECRIPTOR SET UP DESCRIPTOR FOR MVL ! LDA TOS ! ASF B ADVANCE BY B WORDS ! MYB 4 CHANGE B TO BYTES ! LDB B AND MOVE TO BOUND FIELD ! MVL L=DR AND FILL WITH X80S ! ST TOS ! J TOS RETURN ! %IF PARM_CHK=1 %THEN %START; ! ONLY REQUIRED WITH CHKING CNOP(0,4); K=CA PCONST(X'58000000') WORKA_PLABS(4)=CA PF3(JAT,12,0,13) PF1(LSS,0,TOS,0) PF1(STSF,0,TOS,0) PF1(LDTB,0,PC,K) PF1(LDA,0,TOS,0) PF1(ASF,0,BREG,0) PSF1(MYB,0,4) PF1(LDB,0,BREG,0) PF2(MVL,1,1,0,0,UNASSPAT&255) PF1(ST,0,TOS,0) PF1(JUNC,0,TOS,0) %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,36,0) %IF PARM_OPT#0; ! WRONG NO OF PARAMS CTABLE(1)=M'IDIA' WORKA_CONST PTR=2 WORKA_CONST BTM=0 %IF PARM_PROF#0 %THEN %START; ! ALLOCATE PROFILE COUNT AREA I=X'38000001'+WORKA_LINE K=8 PROFDATA=GLACA PGLA(4,8,ADDR(I)) K=0 %CYCLE I=0,1,WORKA_LINE PGLA(4,4,ADDR(K)) %REPEAT WORKA_LINE=0 %FINISH %RETURN %ROUTINE ERR EXIT(%INTEGER LAB, ERRNO, MODE) !*********************************************************************** !* MODE=0 FOR DUMMY(ZERO) XTRA - MODE=1 XTRA IN BREG * !*********************************************************************** %INTEGER EXTRA EXTRA=0; ! NORMALLY ENTER AT PLABS 2 WORKA_PLABS(LAB)=CA %IF ERRNO=36 %THEN %START; ! WRONG NO OF PARAMS PSF1(LXN,1,16); ! GET PLT BASE PSF1(LLN,1,0); ! RESET TO CALLING FRAME EXTRA=2; ! ENTER 2 BYTE ON (PAST LXN) %FINISH %IF MODE=0 %THEN PSF1(LSS,0,0) %ELSE PF1(LSS,0,BREG,0) PSF1(LUH,0,ERRNO) PSF1(JLK,0,(WORKA_PLABS(2)+EXTRA-CA)//2) %END %END %EXTERNALROUTINE EPILOGUE(%INTEGER STMTS) !*********************************************************************** !* PLANT ANY SUBROUINES THAT HAVE BEEN REQUIRED DURING * !* THE CODE GENERATION PHASE * !*********************************************************************** %INTEGER D,J %ROUTINESPEC FILL(%INTEGER LAB) P16: ! ! STRING RESOLUTION SUBROUTINE ! THIS IS ENTERED VIA A CALL INSTRN AND HAS 3 PARAMETERS ! P1(LNB+5) = RESD A CURRENT LENGTH DESCRIPTOR POINTING AT THE FIRST BYTE ! OF THE STRING BEING RESOLVED ! P2(LNB+7) = STD A MAX LENGTH DESCRIPTOR TO THE STRING IN WHICH ANY ! FRAGMENT IS TO BE STORED ! P3(LNB+9) - EXPD A CURRENT LENGTH DESCRIPTOR POINTING AT THE ! LENGTH BYTE OF STRING TO BE SEARCHED FOR ! ! IF RESOLUTION IS SUCCESSFULL CC IS SET TO 0 AND AN UPDATED VERSION ! OF RESD IS RETURNED IN THE ACC IN CASE THERE ARE FURTHER RESLNS ! ! CODE IS AS FOLLOWS:- ! ! LXN (LNB+0) OLD LNB ! LD (XNB+3) PLT DESCRIPTOR ! LDB 0 ZERO BOUND FOR MDIAG ! STD (LNB+3) STANDARD PLACE ! ASF 4 GRAB 2 TEMPORARIES ! LD (LNB+5) RESULT IF NULL ROUTE TAKEN ! SLD (LNB+9) EXPD ! LB 0 ! JAT 11,LNULL JUMP IF EXP NULL ! INCA 1 TO FIRST CHAR ! LB @DR FIRST CHAR INTO B ! STD (LNB+11) TEMP1 ! LSS (LNB+5) TYPE&BND OF RESD ! AND XIFF ! JAT 4,RESFAIL RESD IS NULL &EXPD NOT NULL ! LD (LNB+5) RESD TO DR !AGN SWNE L=DR SEARCH FOR FIRST CHAR ! JCC 8,RESFAIL NOT FOUND ! STD (LNB+13) SAVE IN TEMP 2 ! CYD 0 ! LD (LNB+11) EXP DESCRIPTOR FOR COMPARISON ! CPS L=DR,FILLER=FF CHECK REST OF EXPRSN ! JCC 8,L2 RESLN HAS SUCCEEDED ! LD (LNB+13) RESUME SCANNING ! SWEQ L=1 ADVANCE BY 1 AVOIDING MODD ! J AGN ! ! RESOLUTION COMPLETE. ARRANGE TO STORE FRAGMENT WITHOUT ANY FILLER CHARS ! SO S->S.(T).Z WORKS OK AND ALLOWING STD TO BE NULL ! !L2 SLSS (LNB+5) STORE UPDATED DES & GET BND ! ISB (LNB+13) GIVE LENGTH OF FRAGMENT ! ST B ! LSS (LNB+7) LENGTH OF STD ! JAT 4,LNULL ! ZERO FOR NO 1ST PART RESLN ! AND X1FF ! ICP B ! JCC 12,RESFAIL !LNULL LD (LNB+7) STD TO DR ! JAT 11,L3 STD NULL DONT SET LENGTH ! LSD (LNB+5) ORIGINIAL STRING ! MVL L=1 SET LENGTH BYTE FROM B ! LDB B TO STORE CHARS ! MV L=DR,FILLER=X'80' ASSIGN !L3 LD TOS RESULT AND SET CC=0 ! CYD 0 ! EXIT !RESFAIL MPSR X'24' SET CC=1 ! EXIT %IF WORKA_PLINK(16)=0 %THEN ->P17 FILL(16) PSF1(LXN,1,0) PF1(LD,0,XNB,12) PSF1(LDB,0,0) PSF1(STD,1,12) PSF1(ASF,0,4) PSF1(LD,1,20) PSF1(SLD,1,36) PSF1(LB,0,0) PF3(JAT,11,0,X'23') PSF1(INCA,0,1) PF1(LB,2,7,0) PSF1(STD,1,44) PSF1(LSS,1,20) PF1(AND,0,0,X'1FF') PF3(JAT,4,0,X'26') PSF1(LD,1,22) PF2(SWNE,1,0,0,0,0) PF3(JCC,8,0,X'22') PSF1(STD,1,52) PSF1(CYD,0,0) PSF1(LD,1,44) PF2(CPS,1,1,0,0,X'FF') PF3(JCC,8,0,5) PSF1(LD,1,52) PF2(SWEQ,0,0,0,0,0) PSF1(JUNC,0,-12) PSF1(SLSS,1,20) PSF1(ISB,1,52) PF1(ST,0,BREG,0) PSF1(LSS,1,28) PF3(JAT,4,0,7) PF1(AND,0,0,X'1FF') PF1(ICP,0,BREG,0) PF3(JCC,12,0,13) PSF1(LD,1,28) PF3(JAT,11,0,7) PSF1(LSD,1,20) PF2(MVL,0,0,0,0,0) PF1(LDB,0,BREG,0) PF2(MV,1,1,0,0,UNASSPAT&255) PF1(LD,0,TOS,0) PSF1(CYD,0,0) PSF1(EXIT,0,-X'40') PSF1(MPSR,0,X'24') PSF1(EXIT,0,-X'40') P17: ! ! EVALUATE X**Y ! ******** **** ! Y IS IN ACC X IS STACKED BELOW THE LINK(UNAVOIDABLE) ! EVENT 5/5 IS SIGNALLED IF X<0 OR (X=0 AND Y<=0) ! REPEATED MULTIPLICATION IS USED IF Y>0 AND FRACPT(Y)=0 ! OTHERWISE RESULT=EXP(Y*LOG(Y)) ! ! LB TOS SWOP RETURN ADDRESS & X ! LD TOS X TO DR ! STB TOS ! STD TOS ! SLSD TOS X TO ACC Y TO TOS ! JAT 2,EXPERR ERROR IF X<0 ! JAF 0,TRYMULT JUMP X#0 ! SLSD TOS STACK X & GET Y ! JAF 1.EXPERR Y<=0 ! LSD TOS X (=0) =RESULT TO ACC ! J TOS RETURN !TRYMULT X IS IN ACC & Y STACKED ! SLSD TOS Y TO ACC AND X STACKED ! ST TOS Y STACKED ! JAT 2,NONINT Y IS NEGATAIVE ! RSC 55 ! RSC -55 ! FIX B FIX PINCHED FROM ICL ALGOL ! MYB 4 ! CPB -64 ! JCC 10,*+3 ! LB -64 ! ISH B ! STUH B ACC TO 1 WORD ! JCC 7,NONINT JUMP IF TRUNCATION ! ASF -2 LOSE Y OF STACK ! ST B INTEGER VERSION OF Y TO B ! LSS 1 ! FLT 0 ! JAF 12,MUL JUMP IF B#0 ! ASF -2 LOSE X OFF STACK ! J TOS X**0 =1 !AGN STD TOS STACK ANOTHER COPY OF X !MUL RMY TOS ! DEBJ AGN REPEATED MULTIPLICATION ! J TOS !NONINT Y IS STACKED OVER X ! LSD TOS ! SLSD TOS ! PRCL 4 ! ST TOS ! LXN (LNB+4) ! RALN 7 ! CALL ((XNB+LOGEPDISP) ! RMY TOS ! PRCL 4 ! ST TOS ! LXN (LNB+4) TO PLT ! RALN 7 ! CALL ((XNB+EXPEPDISP)) CALL EXP ! J TOS !EXPERR J ERROR RT NO 7 ! %IF WORKA_PLINK(17)=0 %THEN ->P18 FILL(17) PF1(LB,0,TOS,0) PF1(LD,0,TOS,0) PF1(STB,0,TOS,0) PF1(STD,0,TOS,0) PF1(SLSD,0,TOS,0) PF3(JAT,2,0,X'35') PF3(JAF,0,0,7) PF1(SLSD,0,TOS,0) PF3(JAF,1,0,X'30') PF1(LSD,0,TOS,0) PF1(JUNC,0,TOS,0) PF1(SLSD,0,TOS,0) PF1(ST,0,TOS,0) PF3(JAT,2,0,26) PSF1(RSC,0,55) PSF1(RSC,0,-55) PF1(FIX,0,BREG,0) PSF1(MYB,0,4) PSF1(CPB,0,-64) PF3(JCC,10,0,3) PSF1(LB,0,-64) PF1(ISH,0,BREG,0) PF1(STUH,0,BREG,0) PF3(JCC,7,0,14) PSF1(ASF,0,-2) PF1(ST,0,BREG,0) PSF1(LSS,0,1) PSF1(FLT,0,0) PF3(JAF,12,0,5) PSF1(ASF,0,-2) PF1(JUNC,0,TOS,0) PF1(STD,0,TOS,0) PF1(RMY,0,TOS,0) PSF1(DEBJ,0,-2) PF1(JUNC,0,TOS,0) PF1(LSD,0,TOS,0) PF1(SLSD,0,TOS,0) PSF1(PRCL,0,4) PF1(ST,0,TOS,0) PSF1(LXN,1,16) PSF1(RALN,0,7) PF1(CALL,2,XNB,KNOWN XREF(2)) PF1(RMY,0,TOS,0) PSF1(PRCL,0,4) PF1(ST,0,TOS,0) PSF1(LXN,1,16) PSF1(RALN,0,7) PF1(CALL,2,XNB,KNOWN XREF(3)) PF1(JUNC,0,TOS,0) PF1(JUNC,0,0,(WORKA_PLABS(7)-CA)//2) P18: ! ! MAPPED STRING ASSIGNMENT CHECK. NOW DONE INLINE %IF WORKA_PLINK(18)=0 %THEN ->P19 P19: ! CONCATENATION ONE ! NOW DONE IN LINE %IF WORKA_PLINK(19)!WORKA_PLINK(20)=0 %THEN ->P21 P21: %BEGIN !*********************************************************************** !* PASS INFORMATION TO LPUT TO ENABLE IT TO GENERATE THE * !* LOADER DATA AND COMPLETE THE PROGRAM FILE. * !*********************************************************************** %ROUTINESPEC DUMPCONSTS %INTEGER LANGFLAG,PARMS,I,J,K CODE OUT CNOP(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 I=GLACA-GLACABUF %IF PARM_INHCODE=0 %THEN %START LPUT(2, I, GLACABUF, ADDR(GLABUF(0))) %UNLESS I=0 ! BACK OF GLAP LPUT(2, FIXEDGLALEN, 0, ADDR(FIXED GLA(0)));! FRONT OF GLAP LPUT(19,2,8,5); ! RELOCATE GLA ST ADDRESS LPUT(19,2,12,4); ! RELOCATE CODE ST ADDRESS LPUT(19,2,24,1); ! RELOCATE HEAD OF CODE I=X'E2E2E2E2' LPUT(0+DAREA, 4, CAS(DAREA), ADDR(I)) CAS(DAREA)=CAS(DAREA)+4 %FINISH %CYCLE I=1,1,6 CAS(I)=(CAS(I)+7)&(-8) %REPEAT %if worka_optcnt>0 %then %Start newline; write(worka_optcnt,2) printstring(" Optimisations have been made") %finish PRINTSTRING(" 2900 CODE") WRITE(CA, 6) PRINTSTRING(" BYTES GLAP") WRITE(GLACA, 3); PRINTSTRING("+") WRITE(CAS(5), 1); PRINTSTRING(" BYTES DIAG TABLES") WRITE(CAS(DAREA), 3); PRINTSTRING(" BYTES TOTAL") K=CA+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 CAS(7)=K %IF PARM_INHCODE=0 %THEN LPUT(7, 28, 0, ADDR(CAS(1))) ! SUMMARY INFO. PPROFILE %STOP %ROUTINE DUMP CONSTS !*********************************************************************** !* OUTPUT THE CONSTANT TABLE AND MAKE ANY RELEVANT RELOCATIONS * !*********************************************************************** %ROUTINESPEC DOIT(%INTEGER VAL) %ROUTINESPEC FILL(%INTEGER CREFHEAD) %INTEGER I,J,K,DISP,SIZE,BASE BASE=0 SIZE=WORKA_CONSTPTR-BASE %IF SIZE<=0 %THEN %RETURN CNOP(0,8) %UNLESS CA&7=0 CODE OUT LPUT(1,SIZE*4,CA,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 %FINISH !*DELEND ! FILL(CREFHEAD) SIZE=(SIZE+1)&(-2) CA=CA+4*SIZE CABUF=CA %RETURN %ROUTINE FILL(%INTEGER CREFHEAD) DISP=(CA-4*BASE)//2; ! RELOCATION FACTOR %WHILE CREFHEAD#0 %CYCLE POP(CREFHEAD,I,J,K) DOIT(I) %IF J#0 %THEN DOIT(J) %IF K#0 %THEN DOIT(K) %REPEAT %END %ROUTINE DOIT(%INTEGER VAL) !*********************************************************************** !* IF VAL +VE THEN VAL IS CODE ADDRESS FOR LPUT(18) UPDATE * !* IF VAL -VE IT IS GLAWRDADDRR<<16!CTABLE WRD ADDR * !* THE GLA WORD IS TO RELOCATED BY HEAD OF CODE(ALREADY DONE) * !* HOWEVER THE GLAWORD NEEDS UPDATING FROM REL CTABLE TO REL CODE * !*********************************************************************** %INTEGER I,J %IF VAL>0 %THEN %START LPUT(18,0,VAL,DISP) %FINISH %ELSE %START I=(VAL>>16&X'7FFF')<<2; ! GLA BYTE ADDRESS J=(VAL&X'FFFF')+CA; ! CTABLE ENTRY REL HD OF CODE PLUG(2,I,J,4); ! UPDATE THE GLA WORD %FINISH %END %END %END %RETURN %ROUTINE FILL(%INTEGER LAB) !*********************************************************************** !* FILL JUMPS TO THIS LAB WITH JUMP TO CURRENT ADDRESS * !*********************************************************************** %INTEGER AT,INSTRN,I %INTEGERARRAY A(0:2) %WHILE WORKA_PLINK(LAB)#0 %CYCLE POP(WORKA_PLINK(LAB),A(0),A(1),A(2)) %CYCLE I=0,1,2 INSTRN=A(I) %IF INSTRN#0 %THEN %START AT=INSTRN&X'3FFFF' INSTRN=INSTRN&X'FFFC0000' INSTRN=INSTRN!(CA-AT)>>1 PLUG(1,AT,INSTRN,4) %FINISH %REPEAT %REPEAT WORKA_PLABS(LAB)=CA %END %END %STRINGFN PRINTNAME(%INTEGER N) %INTEGER V, K %STRING(255)S S="???" %IF 0<=N<=WORKA_NNAMES %START V=WORKA_WORD(N) K=WORKA_LETT(V) %IF K#0 %THEN S=STRING(ADDR(WORKA_LETT(V))) %FINISH %RESULT=S %END %EXTERNALROUTINE GENERATE(%RECORD(TRIPF) %ARRAYNAME TRIPLES, %INTEGER CURRLEVEL, %ROUTINE GET WSP(%INTEGERNAME PLACE, %INTEGER SIZE)) !*********************************************************************** !* EVALUATE A LIST OF TRIPLES PLABTING CODE IN BUFFERS * !*********************************************************************** %INTEGERFNSPEC SET LEVREG(%INTEGER WHICH,RLEV) %ROUTINESPEC CIOCP(%INTEGER A,B) %ROUTINESPEC CONSTEXP(%INTEGER PTYPE,VALUE) %ROUTINESPEC SAVE IRS %INTEGERFNSPEC XORYNB(%INTEGER USE,INF) %INTEGERFNSPEC PTROFFSET(%INTEGER RLEV) %ROUTINESPEC DEVELOP BD(%RECORD(RD)%NAME OPND) %ROUTINESPEC PPJ(%INTEGER MASK,N) %ROUTINESPEC VMULTIPLY %routinespec chop operand(%record(rd)%name opnd,%integer newpt,xoffset) %ROUTINESPEC REXP %ROUTINESPEC STARSTAR %ROUTINESPEC NOTE ASSMENT(%INTEGER REG,ASSOP,VAR) %ROUTINESPEC CEND(%INTEGER KKK) %INTEGERFNSPEC REACHABLE(%INTEGER LAB,LINK) %ROUTINESPEC LOAD(%RECORD(RD) %NAME OP,%INTEGER REG,MODE) %ROUTINESPEC SETSTRD(%INTEGER REG,SIZE,BASE,DISP) %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 COPY DR %ROUTINESPEC CHANGE RD(%INTEGER REG) %ROUTINESPEC GET IN ACC(%INTEGER REG,SIZE,%RECORD(RD)%NAME OPND) %ROUTINESPEC BOOT OUT(%INTEGER REG) %ROUTINESPEC DFETCH(%INTEGER REG,SIZE,LEVEL,DISP) %ROUTINESPEC DFETCHAD(%INTEGER REG,LEVEL,DISP) %ROUTINESPEC PUT(%INTEGER REG,CODE,%RECORD(RD)%NAME OPND) ! %RECORD(RD) %NAME OPND1,OPND2,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,COMM,XTRA,PT,BFFLAG,TRIPINF,TRIPVAL,PTYPE,TYPE,PREC, STPTR,L0,B1,B2,B3,EVALREG,LASTPARREG %OWNINTEGER RESTEMPAD=0; ! REMEMBERS CURRENT RESLN WK AD %LONGINTEGER DESC %LONGLONGREAL HALF ! ! TRIPDATA GIVES INFORMATION ON TRIPLE ! TOP 4 BITS HAVE TYPE ! NEXT 12 BITS HAVE FLAGS:- ! 2**16 SET IF COMMUTATIVE ! 2**17 SET DONT LOAD OPERAND2 ! 2**18 SET DONT LOAD OPERAND1 ! 2**19 DONT SWOP NON COMMUTABLE OPERANDS ! NEXT 8 BITS HAVE MAX CODE PLANTED IN BYTES NOT INCLUDING ANY CONSTANSTS ! OR STRINGS WHICH MAY HAVE TO GO INLINE ! BOTTOM 8 BITS HAVE A POINTER OR VALUE ! TYPE 0 TRIPLES ARE IGNORED ! TYPE 1 TRIPLES VALUE HAS INDEX INTO SWITCH "TRIPSW" ! TYPE 2 TRIPLES VALUE HAS POINTER TO ISEQS ! %CONSTINTEGERARRAY TRIPDATA(0:199)=0, X'1000070F'{RTHD ROUTINE/BKK HDR}, X'10000C43'{RDSPLY MAKE DISPLAY}, X'10000410'{RDAREA INITIALISE DIAGS AREA}, X'10000511'{RDPTR RESET DIAGS PTR}, X'10000312'{RTBAD ERROR XIT FOR FN-MAP}, X'10000113'{RTXIT "%RETURN"}, X'10000314'{XSTOP "%STOP"}, 0(2), X'2000040A'{10 LOGICAL NOT}, X'2000040B'{11 LOGICAL NEGATE}, X'2000040C'{12 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'20040413'{19 PRELOAD}, X'10000001'{20 UNUSED}, X'10000303'{21 STORE STACKPOINTER}, X'10000002'{22 RESTORE STACK POINTER}, X'10000505'{23 ADVANCE STACK POINTER}, X'10000D04'{24 DECLARE ARRAY}, X'10000601'{25 UPDATE LINE NO}, X'10000906'{26 CHECK ZERO FOR STEP}, X'10000307'{27 FOR PREAMBLE}, X'10000208'{28 FOR POSTAMBLE}, X'1000010E'{29 FOR SECOND PREAMBLE}, X'10000218'{30 PRECALL}, X'10000819'{31 ROUTINE CALL}, X'1000021A'{32 RECOVER FN RESULT}, X'1000021B'{33 RECOVER MAP RESULT}, X'00000000'{34 NOT CURRENTLY USED}, X'1000081D'{35 GETAD GET 32BIT ADDREESS}, X'10000424'{36 RTOI1 INT FN}, X'10000C25'{37 RTOI2 INTPT FN}, X'10000B26'{38 STOI1 TOSTRING FN}, X'1000093D'{39 MNITR FOR %MONITOR}, X'00000000'{40 PPROF PRINT PROFILE IGNORED}, X'1000053F'{41 RTFP TURN RTNAME TO FORMAL}, X'10000849'{42 ON EVENT1 NO CODE AS YET}, X'1000084A'{43 ON EVENT2 NO CODE AS YET}, X'10000846'{44 DVSTART FILL IN ELSIZE&ND}, X'10001047'{45 DVEND WORK OUT TOTSIZE ETC}, X'20000413'{46 FOREND TREAT AS PRELOAD}, 0(3), X'10000132'{50 UCNOP}, X'10000133'{51 UCB1}, X'10000234'{52 UCB2}, X'10000335'{53 UCB3}, X'10000336'{54 UCW}, X'10000437'{55 UCBW}, 0(3), X'1000063B'{59 UCNAM U-C ACCESS TO NAMES}, 0(68), X'20010414'{128 +}, X'20000415'{129 -}, X'20010416'{130 !!}, X'20010417'{131 !}, X'20010418'{132 *}, X'20000419'{133 //}, X'2000041A'{134 /}, X'2001041B'{135 &}, X'2000041C'{136 >>}, X'2000041D'{137 <<}, X'2000301E'{138 **}, X'2001041F'{139 COMP}, X'20040420'{140 DCOMP}, X'20060A21'{141 VMY}, X'20010422'{142 COMB}, X'200E0823'{143 ASSIGN=}, X'200E0824'{144 ASSIGN<-}, X'20023025'{145 ****}, X'20060926'{146 BASE ADJ}, X'200E0527'{147 ARR INDEX}, X'20060428'{148 INDEXED FETCH}, X'200E0629'{149 LOCAL ASSIGN}, X'10000C09'{150 VALIDATE FOR}, X'10003815'{151 PRE CONCAT}, X'10002016'{152 COCNCATENEATION}, X'10000C17'{153 IOCP CALL}, X'10000C1C'{154 PARAMETER ASSIGNMENT 1 NORMAL VALUES}, X'1000041F'{155 PARAM ASSNG 2 NORMAL PTRS}, X'10000220'{156 PARAM ASSGN 3 ARRAYS}, X'10000220'{157 ASSGN FORMAL RT-CODE AS 156}, X'10000220'{158 PASS5 TYPE GENERAL NAME}, X'10000445'{159 PASS STR WORK AREA}, X'1000040A'{160 BACK JUMP}, X'1000040B'{161 FORWARD JUMP}, X'1000000C'{162 REMOVE LAB}, X'1000000D'{163 ENTER LABEL}, X'1000FF21'{164 DECLARE SWITCH}, X'10000022'{165 SET SWITCH LABEL TO CA}, X'10000523'{166 GOTO SWITCH LABEL}, X'10002427'{167 STRING ASS1 GENERAL}, X'10001828'{168 STRING ASS 2 L KNOWN}, X'10000D29'{169 STRING JAM TRANSFER}, X'10000C2A'{170 ARRAY HEAD ASSIGNMENT}, X'10000C2B'{171 PTR ASSIGNMENT}, X'1000052C'{172 MAP RESULT ASSIGNMENT}, X'1000052D'{173 FN RESULT ASSIGNMENT}, X'1000202E'{174 STRING COMPARISON}, X'1000202E'{175 STRING DSIDED COMPARISON}, X'10000C2F'{176 PRE RESOLUTION 1}, X'10000830'{177 PRE RESOLUTION 2}, X'10000C31'{178 RESOLUTION PROPER}, X'1000233C'{179 RESOLUTION FINISH ASSN FRAGMNT}, X'1000084B'{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'2002022B'{188 CONSTANT LOGICAL SHIFT}, X'2002022B'{189 COSNTANT ARITHMETIC SHIFT}, X'10001048'{190 DV BPAIR ENTER LB,UB &RANGE IN CORRECT FORM}, 0 {191 REG TO STORE OPRN NOT USED}, X'2001042C'{192 MULTIPLY AND EXTENDED}, 0(*) %CONSTBYTEINTEGERARRAY JCODE(-1:48)=CALL,JLK,JCC(14),JUNC,JAT(16),JAF(16),DEBJ; %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=35 %CONSTBYTEINTEGERARRAY ISEQS(40:4*(2*NISEQS+10)-1)={FIRST INTEGER FORMS} %C 4,NEQ,0,X'FF' {10 INTEGER LOGICAL NOT}, 4,IRSB,0,0 {11 INTEGER LOGICAL NEGATE}, 12,0,0,0 {12 INTEGER FLOAT TO REAL}, 11,0,0,0 {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}, 7,0,0,0 {19 PRELOAD}, 3,IAD,IAD,ADB {20 INTEGER ADDITION}, 3,ISB,IRSB,SBB {21 INTEGER SUBTRACTION}, 3,NEQ,NEQ,0 {22 INTEGER NONEQUIVALENCE}, 3,OR,OR,0 {23 INTEGER LOGICAL OR}, 3,IMY,IMY,MYB {24 INTEGER MULTIPLY}, 3,IDV,IRDV,0 {25 INTEGER INTEGER DIVIDE}, 1,0,0,109 {26 INTEGER REAL DIVIDE}, 3,AND,AND,0 {27 INTEGER AND}, 17,USH,0,0 {28 INTEGER RIGHT SHIFT}, 3,USH,0,0 {29 INTEGER LEFT SHIFT}, 1,0,0,109 {30 REAL EXP OPERATOR}, 13,ICP,ICP,CPB {31 COMPARISONS}, 14,ICP,ICP,CPB {32 FIRST PART OF DOUBLE COMPARISONS}, 15,0,0,0 {33 VMY}, 3,IAD,IAD,ADB {34 COMBINE VMY RESULTS}, 16,0,0,0 {35 ASSIGN}, 16,0,0,0 {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,0 {41 LASS}, 24,0,0,0 {42 ZCOMP COMPARISON WITH ZERO}, 25,0,0,0 {43 INTEGER SHIFT BY CONSTANT}, 5,IMYD,IMYD,0 {44 MULTIPLY AND EXTEND INTEGER}, 7,0,0,0 {10 REAL LOGICAL NOT}, 4,RRSB,0,0 {11 REAL LOGICAL NEGATE}, 1,0,0,109 {12 FLOAT REAL COMPILER ERROR}, 11,0,0,0 {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}, 7,0,0,0 {19 PRELOAD}, 3,RAD,RAD,0 {20 REAL ADDITION}, 3,RSB,RRSB,0 {21 REAL SUBTRACTION}, 7,0,0,0 {22 REAL NONEQUIVALENCE}, 7,0,0,0 {23 REAL LOGICAL OR}, 3,RMY,RMY,0 {24 REAL MULTIPLY}, 7,0,0,0 {25 REAL INTEGER DIVIDE}, 3,RDV,RRDV,0 {26 REAL REAL DIVIDE}, 7,0,0,0 {27 REAL AND}, 7,0,0,0 {28 REAL LEFT SHIFT}, 7,0,0,0 {29 REAL RIGHT SHIFT}, 22,2,0,0 {30 REAL EXP OPERATOR}, 13,RCP,RCP,0 {31 COMPARISONS}, 14,RCP,RCP,0 {32 FIRST PART OF DOUBLE COMPARISONS}, 7,0,0,0 {33 VMY}, 7,0,0,0 {34 COMBINE VMY RESULTS}, 16,0,0,0 {35 ASSIGN}, 16,0,0,0 {36 ASSIGN(<-)}, 7,0,0,0 {37 REAL INTEGER EXPONENTIATION}, 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,0 {41 LASS}, 24,0,0,0 {42 ZCOMP COMPARISONS WITH ZERO}, 7,0,0,0 {43 SHIFT BY CONST -ERROR}, 5,RMYD,RMYD,0 {44 MULTIPLY AND EXTEND REAL} %SWITCH SW(0:25),TRIPSW(0:75) ! CURRINF==WORKA_LEVELINF(CURRLEVEL) FLAG AND FOLD(TRIPLES) %IF PARM_OPT#0;! ALREADY DONE FOR OPT=0 %IF PARM_DCOMP#0 %THEN PRINT TRIPS(TRIPLES) STPTR=TRIPLES(0)_FLINK %WHILE STPTR>0 %CYCLE %IF PARM_Z#0 %AND PARM_DCOMP#0 %THEN %START %IF PPCURR>0 %THEN %START NCODE(ADDR(CODE(0)),ADDR(CODE(PPCURR)),CABUF) LPUT(1,PPCURR,CABUF,ADDR(CODE(0))) PPCURR=0; CABUF=CA PRINT USE %FINISH 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) EVALREG=CURRT_DPTH EVALREG=ACCR %UNLESS EVALREG=DR %OR EVALREG=BREG 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+NISEQS) %ELSE C=4*TRIPVAL L0=ISEQS(C); B1=ISEQS(C+1) B2=ISEQS(C+2); B3=ISEQS(C+3) %IF B2#0 %AND OPND2_FLAG=REFTRIP %START WORKT==TRIPLES(OPND2_D) %IF WORKT_OPND1_FLAG=9 %AND WORKT_OPND1_XB>>4=EVALREG %C %THEN COMM=2 %FINISH %IF COMM=1 %THEN OPND==OPND1 %ELSE OPND==OPND2 %IF OPND_FLAG#9 %AND TRIPINF&X'40000'=0 %START; ! OP1 NOT LOADED LOAD(OPND,EVALREG,1) %FINISH %IF JJ>=128 %AND COMM=1 %THEN OPND==OPND2 %ELSE OPND==OPND1 %UNLESS JJ<128 %OR OPND_FLAG=9 %OR TRIPINF&X'20000'#0 %THEN %C LOAD(OPND,EVALREG,0) ->SW(L0) SW(1): ! ERROR CONDITION TRIPSW(0): FAULT(B3,0,0) %UNLESS TYPE=7 TRIPSW(*): PLANT(X'1A01'); ! USEFUL IN DEBUGGING TO HAVE ! ERROR POSITION PINPOINTED ->STRES SW(5): ! PLANT ONE BYTE & EXTEND PTYPE %IF COMM=2 %THEN PUT(EVALREG,B2,OPND1) %AND OPND1=OPND2 %C %ELSE PUT(EVALREG,B1,OPND2) OPND1_PTYPE=OPND1_PTYPE+X'10' ->SUSE OPND1_PTYPE=B3 SW(2): ! PLANT ONE BYTE ->STRES SW(6): ! PLANT 2 BYTES & SET PTYPE OPND1_PTYPE=B3 ->STRES SW(3): ! PLANT ONE INSTRUCTION %IF COMM=2 %THEN %START %IF EVALREG=BREG %START %IF TRIPINF&X'10000'#0 %THEN PUT(BREG,B3,OPND1) %C %ELSE IMPABORT %FINISH %ELSE PUT(EVALREG,B2,OPND1) OPND1=OPND2; ! TRIPLE RESULT ALWAYS OPND1 %FINISH %ELSE %START %IF EVALREG=BREG %THEN C=B3 %ELSE C=B1 PUT(EVALREG,C,OPND2) %FINISH SUSE: OPND1_FLAG=9; ! PREVENT RELOAD IF THIS IS LAST OPND1_XB=EVALREG<<4 OPND1_D=0 REGS(EVALREG)_LINK=ADDR(OPND1) ->STRES SW(4): ! PLANT 3 BYTES %IF B3&X'80'#0 %THEN B3=B3!X'FFFFFF00' PSF1(B1,B2,B3) forget(evalreg) ->STRES SW(7): ! NULL OPERATION %IF CURRT_CNT>1 %AND (CURRT_OPTYPE>>4<=4 %OR %C 1<STRES SW(9): ! SHORTEN INTEGER OR REAL LOAD(OPND1,ACCR,1) C=OPND1_PTYPE&7 %IF C=2 %START; ! REALS PF1(RDDV,0,PC,SPECIAL CONSTS(1)) %FINISH %ELSE %IF OPND1_PTYPE>>4&15=6 %START %IF PARM_OPT#0 %THEN PSF1(ISH,0,32) %AND PSF1(USH,0,-32) PSF1(MPSR,0,17) %FINISH ACCREG_USE=0 OPND1_PTYPE=CURRT_OPTYPE ->STRES SW(10): ! LENGTHEN INTEGER OR REAL LOAD(OPND1,ACCR,1) %IF TYPE=2 %THEN %START PF1(RMYD,0,PC,SPECIAL CONSTS(1)) %FINISH %ELSE %START %IF CURRT_OPTYPE=X'61' %THEN PSF1(IMYD,0,1) %FINISH ACCREG_USE=0 OPND1_PTYPE=CURRT_OPTYPE ->SUSE SW(11): ! MODULUS OR ABS ACCREG_USE=0 %IF TYPE=1 %THEN C=5 %AND D=IRSB %ELSE %START %IF PTYPE>>4=5 %THEN PF1(AND,0,PC,WORD CONST(X'7FFFFFFF')) %AND ->STRES %IF PTYPE>>4=6 %THEN PF1(AND,0,PC,LONG CONST(X'7FFFFFFFFFFFFFFF')) %AND ->STRES C=1; D=RRSB %FINISH PF3(JAT,C,0,3) PSF1(D,0,0) ->SUSE SW(12): ! FLOAT LOAD(OPND1,ACCR,1) PSF1(FLT,0,0) ACCREG_USE=0 OPND1_PTYPE=CURRT_OPTYPE ->STRES SW(21): ! SHORTEN FOR JAM TRANSFER C=CURRT_OPTYPE>>4 LOAD(OPND1,ACCR,1) %IF C=5 %THEN PSF1(MPSR,0,17) %ELSE %C %IF C=4 %THEN %START PF1(AND,0,0,X'FFFF') %UNLESS %C CURRT_CNT=1 %AND TRIPLES(CURRT_PUSE)_OPERN=JAMSHRTN %FINISH %ELSE PF1(AND,0,0,255) OPND1_PTYPE=CURRT_OPTYPE ACCREG_USE=0 ->SUSE SW(22): ! EXP IN ANY EXPRSN %IF OPND2_PTYPE&7=1 %THENSTART %IF OPND2_FLAG=10 %AND OPND2_XB=0 %AND 2<=OPND2_D %THEN %C CONST EXP(B1,OPND2_D) %ELSE STARSTAR ->SUSE %FINISH ! REAL**REAL BY SUBROUTINE REXP; ->SUSE SW(17): ! INTEGER RIGHTSHIFT %IF OPND2_FLAG=10 %AND OPND2_XB=0 %THEN %C OPND_D=-OPND_D %AND ->SW(3);! >> BY CONST== <<(-CONST) TOPND=0; TOPND_PTYPE=X'51' GET IN ACC(BREG,4,TOPND) PUT(BREG,SBB,OPND2); ! 0-OPND2 TO BREG OPND2_XB=BREG<<4; OPND2_D=0 PUT(ACCR,USH,OPND2) BREGREG_USE=0 ->SUSE SW(14): ! DSIDED COMPARISONS LOAD(OPND2,EVALREG,1) LOAD(OPND1,EVALREG,0) OPND==OPND1; COMM=2 SW(13): ! COMPARISONS BFFLAG=COMM-1; ! NOTE BACKWARDS OR FORWARDS C=FCOMP(XTRA&15+16*BFFLAG) COMM=2 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 D=B1; %IF EVALREG=BREG %THEN D=B3 %IF XTRA<0 %AND D=CPB %THEN D=CPIB PUT(EVALREG,D,OPND); ! OPND==OPND1 IF COMM=2 %IF CURRT_OPERN=DCOMP %THEN REGS(EVALREG)_CL=1 %AND ->SUSE ->STRES; ! 2ND OPERAND MAY BE NEEDED IN SW(15): ! SPECIAL MH FOR ARRAY ACCESS C=xtra>>28; ! CURRENT DIMENSION D=xtra>>24&15; ! TOTAL NO OF DIMENSIONS VMULTIPLY ->STRES SW(18): ! BASE ADJUST ARRAY INDEX ! NOT USED FOR EMAS IMP ->STRES SW(19): ! ARRAY INDEX WORKT==TRIPLES(STPTR) %IF CURRT_CNT=1 %AND CURRT_PUSE=CURRT_FLINK %AND %C WORKT_OPTYPE#X'35' %AND WORKT_DPTH#BREG %AND %C (WORKT_OPERN#AAINC %OR (WORKT_CNT=1 %AND WORKT_PUSE=WORKT_FLINK)) %START; ! ONLY ARITHMETIC TYPES USED ! IN NEXT TRIPLE TAKE THIS ALT ! OR INCREMENTED IN NEXT TRIP AND ! USED IN NEXT BUT ONE LOAD(opnd1,BREG,1) %UNLESS opnd1_FLAG=SCONST %AND opnd1_D=0 C=opnd2_PTYPE; opnd2_PTYPE=X'61' LOAD(opnd2,EVALREG,0) %IF opnd2_XB&3=0 %Start %IF opnd1_FLAG=SCONST %AND opnd1_D=0 %THEN opnd2_XB=opnd2_XB!2 %C %ELSE opnd2_XB=opnd2_XB!3 opnd2_PTYPE=C EVALREG=BREG ptype=opnd1_ptype topnd=opnd1 opnd1=opnd2 opnd2=topnd opnd1_ptype=ptype regs(evalreg)_link=addr(opnd2) ->stres %finish %FINISH LOAD(opnd1,BREG,0) %IF opnd1_XB&3#0 %THEN LOAD(opnd1,BREG,1) %AND LOAD(opnd1,BREG,0) chop operand(opnd2,x'61',0) load(opnd2,dr,1) %UNLESS opnd1_XB=0=opnd1_D %THEN %START %IF XTRA>>20=2{HALF} %THEN PUT(DR,INCA,opnd1) %ELSE %C PUT(DR,MODD,opnd1) %FINISH DRREG_USE=0 opnd1_FLAG=10; opnd1_XB=X'72'; opnd1_D=0 %IF CURRT_CNT>1 %THEN %START GETWSP(D,2) PSF1(STD,1,D) DRREG_CL=0; DRREG_USE=2 DRREG_INF1=D opnd1_XB=LNB<<4!2 opnd1_D=D %FINISH EVALREG=DR regs(dr)_link=addr(opnd1) ->STRES SW(20): ! INDEXED FETCH LOAD(OPND2,EVALREG,0) %IF OPND2_XB=X'72' %OR OPND2_XB=X'73' %THEN DRREG_CL=0 %IF OPND2_XB&3=3 %THEN BREGREG_CL=0 LOAD(OPND2,EVALREG,1) OPND1_FLAG=9; OPND1_XB=EVALREG<<4 OPND1_D=0 REGS(EVALREG)_LINK=ADDR(OPND1) ->STRES SW(16): ! ASSIGN(=) ! ASSIGN(<-) PT=XTRA&255; ! ORIGINAL PT OF LHS HERE %IF PT=0 %THEN PT=CURRT_OPTYPE TOPND=OPND1; ! SAVE OPND FOR NOTE ASSMENT LOAD(OPND2,EVALREG,1) %IF OPND1_FLAG=2 %START; ! OPERAND A NAME TCELL==ASLIST(TAGS(OPND1_D)) DSTORE(EVALREG,BYTES(PT>>4),TCELL_UIOJ>>4&15,TCELL_SLINK+OPND1_XTRA) %FINISH %ELSE %IF OPND1_FLAG=LOCALIR %START;! MAP OPTIMISATIONS DSTORE(EVALREG,BYTES(PT>>4),OPND1_D>>16,OPND1_D&X'FFFF') %FINISHELSESTART; ! OPERAND A POINTER LOAD(OPND1,EVALREG,0) %IF OPND1_XB&3=3 %THEN BREGREG_CL=0 %IF OPND1_XB=X'72' %OR OPND1_XB=X'73' %THEN DRREG_CL=0 %IF OPND1_XB&3=0 %THEN OPND1_XB=OPND1_XB!2;! PTR DUMPED IN LOCAL PUT(EVALREG,STCODE(EVALREG),OPND1) %FINISH %IF TOPND_XTRA<=0 %AND (TOPND_FLAG=DNAME %OR TOPND_FLAG=INDNAME) %C %THEN NOTE ASSMENT(EVALREG,TRIPVAL-33,TOPND_D) ->STRES SW(23): ! LOCAL ASSIGNMENT LOAD(OPND2,ACCR,1) DSTORE(EVALREG,BYTES(OPND1_PTYPE>>4&15),OPND1_D>>16,OPND1_D&X'FFFF') REGS(EVALREG)_CL=0 ->STRES SW(24): ! COMPARIONS WITH ZERO (OPND2 ZERO) D=FCOMP(CURRT_X1+32) %IF TYPE=2 %THEN D=D-4 %IF EVALREG=BREG %THEN D=D+8 WORKT==TRIPLES(CURRT_FLINK) %IF WORKT_OPERN=FJUMP %OR WORKT_OPERN=BJUMP %START %IF WORKT_X1&X'80'#0 %THEN WORKT_X1=X'80'!(D!!X'30') %C %ELSE WORKT_X1=D %FINISH %ELSE IMPABORT ->STRES SW(25): ! SHIFT BY CONSTANT D=OPND2_D; ! THE CONSTANT %IF CURRT_OPERN=CASHIFT %THEN C=ISH %ELSE C=USH %IF EVALREG=BREG %START; ! CAN NOT SHIFT IN BREG ! DEOPTIMISE BACK TO MULTIPLY IMPABORT %UNLESS D>0 %AND C=ISH C=MYB; ! MUST HAVE BEEN A MULTIPLY D=2****D %FINISH PSF1(C,0,D) FORGET(EVALREG) ->SUSE TRIPSW(1): ! SET LINE NO %IF PARM_LINE#0 %START PSF1(LSS,0,OPND1_D>>16) ACCREG_USE=0 DSTORE(EVALREG,4,CURRINF_RBASE,OPND1_D&X'FFFF') %FINISH %CONTINUE TRIPSW(2): ! RESTORE STACK POINTER ! USED AT BEGIN BLOCK EXIT ONLY ! OPND1_D HAS SAVE AREA OFFSET D=OPND1_D %IF PARM_STACK=0 %START; ! ARRAYS ON AUX STACK(NORMAL) PSF1(LSS,1,D+8) PSF1(ST,2,D); ! VIA SAVED DESCRIPTOR DRREG_USE=0 %FINISH %ELSE %START; ! ON AUTOSTACK PF1(STSF,0,TOS,0) PF1(LSS,0,TOS,0) PSF1(IRSB,1,D) PSF1(ISH,0,-2) PF1(ST,0,TOS,0) PF1(ASF,0,TOS,0) %FINISH ACCREG_USE=0 %CONTINUE TRIPSW(3): ! SAVE STACK POINTER ! OPND1 IS TEMPORARY(16 BITS) FOR SAVE %IF PARM_STACK=0 %START; ! MAKE AUXSTACK DESC LOCAL %IF KXREFS(5)=0 %START; ! FIRST SET XREF C=X'30000001'; D=0 PGLA(8,8,ADDR(C)) GXREF(KXREFNAME(5),4,X'02000008',GLACA-4) KXREFS(5)=GLACA-8 %FINISH D=SET LEVREG(-1,-1) PF1(LD,2,D,KXREFS(5)) PF1(LSS,2,7,0); ! CURRENT STACK TOP PSF1(STD,1,OPND1_D) PSF1(ST,1,OPND1_D+8) DRREG_USE=0 ACCREG_USE=11 ACCREG_INF1=0 %FINISH %ELSE %START; ! ARRAYS ON STACK %IF CURRINF_FLAG=0 %THEN PSF1(STSF,1,OPND1_D) %FINISH %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) DESC=DESC<<32!12 PF1(LD,0,PC,LONG CONST(DESC)) PSF1(STD,1,D) DRREG_USE=0 PTYPE=OPND1_XTRA>>16; ! TARGET ARRAY PTYPE TYPE=PTYPE&7 PREC=PTYPE>>4&7 %IF PREC=4 %OR TYPE>2 %THEN C=OPND1_D&X'FFFF'{ELSIZE} %ELSE C=1 PSF1(LSS,0,C) PSF1(ST,1,D+12*(OPND1_D>>16)+4) ACCREG_USE=0 %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 TYPE=PTYPE&7; PREC=PTYPE>>4&7 %IF TYPE<=2 %AND PREC#4 %THEN D=OPND1_D&X'FFFF' %ELSE D=1 PSF1(IMY,0,D) %UNLESS D=1 PSF1(ST,1,XTRA&X'FFFF'{DVDISP}+8) %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*(C+1-XTRA>>24); ! TRIPLE POSN B1=X'80000000' %IF OPND1_FLAG=SCONST %THEN B1=OPND1_D;! CONST LB LOAD(OPND1,ACCR,1); ! LB PSF1(ST,1,D) ACCREG_CL=0 LOAD(OPND2,ACCR,1); ! UB %IF B1=X'80000000' %THEN %START PSF1(ISB,1,D) PSF1(IAD,0,1) %FINISH %ELSE %START PSF1(ISB,0,B1-1) %UNLESS B1=1 %FINISH ACCREG_CL=0 PSF1(IMY,1,D+4) PSF1(ST,1,D+8) %IF C#XTRA>>24 %THEN PSF1(ST,1,D-8);! NEXT MULTIPLIER ACCREG_USE=0 %CONTINUE TRIPSW(4): ! DECLARE ARRAY ! OPND1=CDV<<31!C<<24!D<<16!DVDISP ! OPND1_XTRA HAS NAME %BEGIN %INTEGER DVDISP,D0 TCELL==ASLIST(TAGS(OPND1_XTRA)) C=OPND1_D>>24&127 D=OPND1_D>>16&255 %IF C=0 %START; ! DV DESC AND TOP OF ARRAY DESC ! SET UP FOR ALL ARRAYS ! ON FIRST DECL DVDISP=OPND1_D&X'FFFF' %IF OPND1_D>0 %START; ! DYNAMIC DOPE VECTOR ! DESC=X'2800000000000000'+DVDISP ! DESC=DESC+TCELL_UIOJ&15*X'300000000' ! PF1(LD,0,PC,LONG CONST(DESC)) ! PSF1(INCA,1,PTROFFSET(CURRINF_RBASE)) PSF1(LDRL,1,DVDISP); ! WHILE RELATIVE DECSR STILL ! ON THE FRONT OF DVS %FINISH %ELSE %START PF1(LDRL,0,PC,X'80000000'+DVDISP) %FINISH TYPE=TCELL_PTYPE&15 PREC=TCELL_PTYPE>>4&15 %IF TYPE>2 %THEN D0=3<<27!1<<25 %ELSE D0=PREC<<27 %IF PARM_ARR=0 %THEN D0=D0!1<<24;! SET BCI %IF PREC=4 %THEN D0=X'58000002' %IF OPND1_D<=0 %AND PREC#4 %THEN D0=D0+CTABLE(DVDISP>>2+5) PF1(LB,0,PC,WORD CONST(D0));! USE B AS ACCR MAY HAVE STPTR %IF PREC#4 %AND OPND1_D>0 %THEN PSF1(ADB,1,DVDISP+20) %FOR JJ=0,1,D %CYCLE; ! FOR ALL ARRAY HEADERS PSF1(STB,1,TCELL_SLINK+16*JJ) PSF1(STD,1,TCELL_SLINK+16*JJ+8) %REPEAT %FINISH %IF PARM_STACK=0 %START; ! USE AUX STACK PSF1(LSS,2,CURRINF_AUXSBASE) %UNLESS ACCREG_USE=11 %C %AND ACCREG_INF1=0 ACCREG_USE=11 ACCREG_INF1=0 PSF1(ST,1,TCELL_SLINK+4) %FINISH %ELSE PSF1(STSF,1,TCELL_SLINK+4) %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 PARM_STACK=0 %START; ! USING AUXSTACK PSF1(LSS,2,CURRINF_AUXSBASE) %UNLESS ACCREG_USE=11 %C %AND ACCREG_INF1=0 %IF OPND1_D>0 %START; ! DYNAMIC DOPE VECTOR PSF1(IAD,1,D+8); ! ADD ARRAY SIZE IN BYTES %IF PREC<=5 %THEN PSF1(IAD,0,7) %AND PSF1(AND,0,-8) %FINISH %ELSE %START; ! STATIC DOPE VECTOR JJ=CTABLE(OPND1_D>>16&X'7FFF'+2) JJ=(JJ+7)&(-8); ! D-WORD ALING PSF1(IAD,0,JJ) %FINISH PSF1(ST,2,CURRINF_AUXSBASE) %IF PARM_OPT#0 %THEN %START PF1(ICP,1,0,2); ! COMPARE WITH STACK LIMIT PPJ(2,8) %FINISH ACCREG_USE=11 ACCREG_INF1=0 %FINISH %ELSE %START; ! ARRAYS ON AUTO STACK %IF OPND1_D>0 %START; ! DYNAMIC DOPE VECTOR %IF PREC=5 %OR PREC=6 %START;! WORDS &LWORDS PSF1(ASF,1,D+20) %FOR C=PREC,1,6 %FINISH %ELSE %START DFETCH(ACCR,2,CURRINF_RBASE,D+8) PSF1(IAD,0,3) %IF PREC<5 PSF1(USH,0,2) PF1(ST,0,TOS,0) PF1(ASF,0,TOS,0) ACCREG_USE=0 %FINISH %FINISHELSESTART; ! STATIC DOPE VECTORS C=CTABLE(OPND1_D>>16&X'7FFF'+2); ! ARRAYSIZE IN BYTES PSF1(ASF,0,C//4) %FINISH %FINISH %CONTINUE TRIPSW(6): ! CHECK FOR ZERO FOR STEP LOAD(OPND1,EVALREG,1); ! STEP TO EVALREG PPJ(20,11); ! ASSUMES EVALREG IS ACCR %CONTINUE TRIPSW(7): ! FOR PREAMBLE LOAD(OPND1,EVALREG,1); ! FORCE INITIAL TO EVALREG %CONTINUE TRIPSW(8): ! FOR POSTAMBLE %CONTINUE TRIPSW(9): ! VALIDATE FOR LOAD(OPND1,ACCR,1); ! OPND1 IS FINAL-INIT LOAD(OPND2,EVALREG,0); ! OPND2 IS STEP PUT(ACCR,IMDV,OPND2); ! REMAINDER DIVIDE PF1(X'60',0,TOS,0); ! REPLACE QUOTIENT(ANY LENGTH) BY REMAINDER PPJ(36,11) ACCREG_CL=0 %CONTINUE TRIPSW(10): ! BACK JUMP _X1 HAS TF&MASK ! OPND1_XTRA HAS LABEL CELL LCELL==ASLIST(OPND1_XTRA) C=LCELL_S1&X'FFFFFF'; ! CA OF THE LABEL D=CURRT_X1&X'3F'; ! THE MASK C=(C-CA)//2 B=JCODE(D) %IF B>=16{PRIMARY FORMAT} %THEN PSF1(B,0,C) %ELSE %C PF3(B,D&15,0,C) %CONTINUE TRIPSW(11): ! FORWARD JUMP _X1 HAS TF&MASK ! OPND1_XTRA HAS LABEL CELL<<16!JUMP CELL LCELL==ASLIST(OPND1_XTRA&X'FFFF') C=CURRT_X1&X'3F' B=JCODE(C) %IF B>=16{PRIM FORMAT} %AND REACHABLE(OPND1_D&X'FFFF',STPTR)=YES %START PSF1(B,0,0) LCELL_S1=(CA-2)!X'80000000';! MARK AS SHORT PLANTED %FINISH %ELSE %START %IF B>=16{PRIM FORMAT} %THEN PF1(B,0,0,0) %ELSE %C PF3(B,C&15,0,0) LCELL_S1=CA-4; ! AFTER ROUNDING FOR ACCENT %FINISH D=OPND1_D>>24; ! ENTER JUMP FLAGS %IF D&2#0 %START; ! ENVIRONMENT MANIPULATION LCELL==ASLIST(OPND1_XTRA>>16);! ONTO LABEL CELL FOR ENVRMNT %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 LCELL==ASLIST(OPND1_XTRA) JJ=LCELL_S2&X'FFFF' %WHILE JJ#0 %CYCLE; ! FILL FORWARD REFS POP(JJ,B1,B2,B3); ! B1<0 IF SHORT JUMP PLANTED ! B1=0 IF JUMP DISCARDED BY OPTIMISER ! B2 HAS ENVIRONMENT WHEN IMPLEMENTEED %IF B1<0 %START B1=B1&X'3FFFF' D=(CA-B1)//2 %IF D>63 %THEN FAULT(98,0,0) PLUG(1,B1+1,D,1) %FINISH %ELSE %IF B1>0 %START D=(CA-B1)//2 LPUT(18,0,B1,D); ! RELOCATE 18 BITS %FINISH %REPEAT LCELL_S1=LCELL_S1&X'FF000000'!CA D=OPND1_D>>24; ! ENVIRONMENT MANIPULATION FLAGS %IF D&2=0 %THEN FORGET(-1) %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 ! THIS IS LABEL TRIP IN DEBJ CASE ASSTRIP==TRIPLES(ADDTRIP_FLINK);! AND ASSIGNMENT CTRIP_DPTH=EVALREG %IF ADDTRIP_OPERN=ADD %THEN ADDTRIP_DPTH=EVALREG ASSTRIP_DPTH=EVALREG; ! ENSURE ALL USE SAME REG %IF XTRA&X'080002'=X'080002' %AND CTRIP_OPERN=COMP %START;! INCREMENT IS 1 ! FINAL NOT ZERO WHEN ZCOMP USED 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 %BEGIN %INTEGER W1,W2,W3 ! OPND1_XTRA=AXNAME #0 IF AN ENTRY %IF OPND1_XTRA#0 %START; ! EXTERNAL NEEDS INITIALISE CODEDES(D,CA); ! CODE DESCRIPTOR TO CURRENT ADDRESS RELOCATE(D+4,CA,1); ! AND ADDRESS RELOCATED BY CODE %IF OPND1_D<0 %THEN %START; ! FIRST BEGIN OR MAIN ENTRY C=1; ! FLAG MAIN ENTRY %FINISH %ELSE C=0; ! NOT MAIN ENTRY %IF D#0 %THEN PSF1(INCA,0,-D);! DR BACK TO GLAP DEFINEEP(STRING(OPND1_XTRA),1,D,C) %IF OPND1_D<0 %START; ! MAIN PROG PF1(MPSR,0,0,X'40C0'); ! SET PROGRAM MASK %FINISH %ELSE %C %IF CA&2=0 %THEN PF1(JUNC,0,0,4) %ELSE PSF1(JUNC,0,3);! JOIN WITH INTERNAL ENTRY %FINISH CNOP(0,4) CURRINF_ENTRYAD=CA %IF OPND1_D>=0 %START; ! ROUTINE PLANT INTERNAL ENTRY TCELL==ASLIST(TAGS(OPND1_D)) D=TCELL_SNDISP; ! LIST OF OUTSTANDING JUMPS %WHILE D>0 %CYCLE POP(D,W1,W2,W3); ! W1=INSTRN,W2 =ADDRESS W3=CA-W2 W3=W3//2 %IF W1=CALL; ! CALL WORKS IN HALFWORDS LPUT(18,0,W2,W3) %REPEAT TCELL_SNDISP=(CA>>2) PF1(LD,0,XNB,12); ! LOADD PLT DESRCPTR ! AND JOIN EXTERNAL PATH %FINISH %END %CONTINUE TRIPSW(67): ! RDSPY CREATE DIPLAY OPND1_D=DISPLAY OFFSET %BEGIN %INTEGER W1,W2,STACK,OP,INC STACK=0 FORGET(-1) %IF PARM_TRACE#0 %THEN PUSH(CURRINF_RAL,1,CA,0) %AND %C PF1(LDB,0,0,0) PSF1(STD,1,12) W1=CURRINF_RBASE-1 W2=WORKA_LEVELINF(CURRINF_CLEVEL-1)_DISPLAY;! OFSET OF DISPLAY TO BE COPIED %IF W1>0 %THEN REGS(XNB)_USE=4 %AND REGS(XNB)_INF1=W1 %IF W1=1 %THEN PF1(STXN,0,TOS,0) %ELSE %START %WHILE W1>0 %CYCLE OP=LSS; INC=1 %IF W1>=2 %THEN OP=LSD %AND INC=2 %IF W1>=4 %THEN OP=LSQ %AND INC=4 PF1(OP+STACK,0,XNB,W2) STACK=-32 W2=W2+4*INC; W1=W1-INC %REPEAT %FINISH %IF STACK#0 %THEN PF1(ST,0,TOS,0); ! ST TOS PF1(STLN,0,TOS,0) CURRINF_SET=CA; ! REMEMBER ASF PF1(ASF,0,0,0); ! FILLED AT CEND %END %CONTINUE TRIPSW(16): ! RDAREA - INITIALISE DAIGS AREA ! OPND1_D=N FOR DIAGS AREA %IF PARM_OPT#0 %THEN %START PF1(LSS,0,PC,X'80000004'); ! PICK UP M'IDIA' PSF1(ST,1,OPND1_D) ACCREG_USE=0 %FINISH %CONTINUE TRIPSW(17): ! RDPTR SET DAIGS POINTER ! OPND1_D=LEVEL NOT CURRINF ALWAYS LINF==WORKA_LEVELINF(OPND1_D) %IF LINF==CURRINF %AND (OPND1_D<=2 %OR CURRINF_FLAG>=X'1000') %C %THEN %CONTINUE PF1(LSS,0,0,0); ! WILL BE FILLED LATER PUSH(LINF_RAL,1,CA-3,0); ! TO OVERWRITE LATER PSF1(ST,1,12); ! INTO TOP OF PLT DESCPTR ACCREG_USE=0 %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) %CONTINUE TRIPSW(19): ! RTXIT - "%RETURN" D=CURRINF_AUXSBASE %IF PARM_STACK=0 %AND D>0 %START;! REMOVE ARRAYS FROM THE AUX STACK PSF1(LB,1,D+8) PSF1(STB,2,D); ! USE B AS FN RESULT IN ACC %FINISH PSF1(EXIT,0,-64) %IF OPND1_D#0 %THEN CEND(OPND1_D) %AND FORGET(-1) %CONTINUE TRIPSW(20): ! XSTOP - "%STOP" CALL STOP %IF OPND1_D#0 %THEN CEND(OPND1_D) %CONTINUE TRIPSW(61): ! %MONITOR PSF1(LSD,0,0); ! NOFAULT ZERO EXTRA PPJ(0,2) %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 LOAD(OPND2,DR,1); ! STRIBG DES TO DR PF1(LB,2,7,0); ! LENGTH TO BREG PSF1(STB,1,D+8); ! AND INTO WK AREA COPY DR DRREG_CL=0 SETSTRD(DR,256,CURRINF_RBASE,D+11) PSF1(STD,1,D); ! DES TO WK AREA PSF1(MODD,0,1); ! PAST LENGTH ALREADY TRANSFERRED PF1(LDB,0,BREG,0) PSF1(IAD,0,1) PF2(MV,1,0,0,0,0) DRREG_CL=0 ACCREG_USE=0 DRREG_USE=0 BREGREG_USE=0 OPND1_FLAG=7; ! RESULT IS LOCAL %CONTINUE TRIPSW(22): ! CONCATENATE OPND1 WORK AREA ! OPND2 THE NEXT BIT OPND1=TRIPLES(OPND1_D)_OPND1 %WHILE OPND1_FLAG=REFTRIP D=OPND1_D&X'FFFF'; ! WOTF AREA OFFSET FROM LNB LOAD(OPND2,DR,1) PF1(LB,2,7,0); ! NEXT LENGTH TO B PSF1(INCA,0,1) COPYDR DRREG_CL=0 PSF1(LD,1,D); ! DES TO BIT IN WK AREA PSF1(MODD,1,D+8); PSF1(MODD,0,1);! PASST PRESENT FRAGMENT PF1(LDB,0,BREG,0); ! MOVE ONLY THE MINIMUM PF2(MV,1,0,0,0,0) PSF1(ADB,1,D+8) PSF1(STB,1,D+8) ACCREG_USE=0 DRREG_USE=0 BREGREG_USE=0 %CONTINUE TRIPSW(39): ! GENERAL STRING ASSIGN %IF OPND2_FLAG=LCONST %AND OPND2_XTRA=0 %START; ! NULL STRING ASSN LOAD(OPND1,DR,1); ! LHS TO DR PF2(MVL,0,1,0,0,0); ! ZERO TO LENGTH BYTE DRREG_CL=0 DRREG_USE=0 %CONTINUE %FINISH ->GENSASS TRIPSW(40): ! SIMPLE STRING ASSIGN TCELL==ASLIST(TAGS(OPND1_D)) D=OPND2_XTRA; ! RHS LENGTH IF A CONST %IF OPND2_FLAG=LCONST %AND D128 %THEN PF2(MV,0,0,127,0,0) %AND D=D-128 PF2(MV,0,0,D,0,0) %FINISH ACCREG_USE=0 %FINISHELSESTART GENSASS: ! GENERAL ASSIGN TO HERE ! PENDING FURTHER OPTIMISATIONS LOAD(OPND2,DR,1); ! THE RHS PF1(LB,2,7,0); ! CURRENT LENGTH PSF1(ADB,0,1); ! BYTES TO MOVE PF1(LDB,0,BREG,0); ! DR SET JUST RIGHT FOR MIN MOVE COPYDR DRREG_CL=0 LOAD(OPND1,DR,1) %IF PARM_OPT#0 %START; ! FORCE CAPACITY CHK PF1(STD,0,TOS,0); ! EFFICENCY SACRIFICED FOR OPT CASE! PSF1(SBB,0,1) PF1(MODD,0,BREG,0) PSF1(ADB,0,1) PF1(LD,0,TOS,0); ! DR NOW UNCHANGED %FINISH PF1(LDB,0,BREG,0) PF2(MV,1,0,0,0,0) ACCREG_USE=0 BREGREG_USE=0 %FINISH DRREG_CL=0 DRREG_USE=0 %CONTINUE TRIPSW(41): ! STRING JT VIA SUBROUTINE LOAD(OPND2,DR,1); ! RHS TO ACCR PF1(LDB,2,7,0); COPY DR DRREG_CL=0 LOAD(OPND1,DR,1) PF1(STD,0,TOS,0); ! FOR STORING AMENDED LENGTH PF1(IAD,0,PC,LONG CONST(X'100000000')) PF2(MV,1,1,0,0,UNASSPAT&255); ! ASSIGN AND PAD IF TOO SHORT PSF1(USH,0,8); PSF1(USH,0,-40);! BYTES LEFT OVER OR 0 PF1(IRSB,2,TOS,0); ! ORIGINAL - LEFT OVERS PF1(ST,2,7,0); ! IS NOW THE LENGTH ACCREG_CL=0; ACCREG_USE=0 DRREG_CL=0; DRREG_USE=0 %CONTINUE TRIPSW(46): ! STRING COMPARISONS INCL DSIDED BFFLAG=0 %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 C=FCOMP(D+64); ! CHANGE FOR CPS FUNNIES WORKT==TRIPLES(CURRT_FLINK) %IF WORKT_OPERN=FJUMP %OR WORKT_OPERN=BJUMP %START %IF WORKT_X1&X'80'#0 %THEN WORKT_X1=C!!X'8F' %ELSE WORKT_X1=C %FINISH LOAD(OPND1,DR,1) PF1(LDB,2,7,0) PSF1(INCA,0,1) COPY DR DRREG_CL=0 LOAD(OPND2,DR,1) PF1(LDB,2,7,0) PSF1(INCA,0,1) PF2(CPS,1,1,0,0,0) %IF 0#C&X'C'#X'C' %START PF3(JCC,7,0,4) PSF1(USH,0,-32) PSF1(ISH,0,-24) %FINISH DRREG_CL=0; ACCREG_CL=0 DRREG_USE=0; ACCREG_USE=0 %CONTINUE NULLSC: ! TEST FOR A NULL STRING LOAD(OPND,DR,1) TOPND=0; TOPND_PTYPE=X'31' TOPND_XB=X'72'; TOPND_FLAG=10 GET IN ACC(ACCR,1,TOPND) D=FCOMP(CURRT_X1+32+16*BFFLAG) WORKT==TRIPLES(CURRT_FLINK) %IF WORKT_OPERN=FJUMP %OR WORKT_OPERN=BJUMP %START %IF WORKT_X1&X'80'#0 %THEN WORKT_X1=X'80'!(D!!X'30') %C %ELSE WORKT_X1=D %FINISH %ELSE IMPABORT DRREG_CL=0 %CONTINUE TRIPSW(47): ! PRE RESOLUTION 1 ! OPND1 IS 4 WORD WK AREA ! OPND2 IS STRING BEING RESLVD D=OPND1_D&X'FFFF' LOAD(OPND2,DR,1); ! 32 BIT ADDRESS TO ESTACK PF1(LDB,2,7,0); ! CURRENT LENGTH TO BOUND PSF1(INCA,0,1) PSF1(STD,1,D); ! DESCRIPTOR TO 4 WORD AREA DRREG_CL=0 %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 PSF1(LD,0,0) PSF1(STD,1,RESTEMPAD+8); ! TO WORK AREA DRREG_CL=0 %FINISHELSE %START LOAD(OPND2,EVALREG,1); ! OR MAX LENGTH DESCPTR PSF1(STCODE(EVALREG),1,RESTEMPAD+8) REGS(EVALREG)_CL=0 %FINISH %CONTINUE TRIPSW(49): ! RESOLUTION ! OPND1 IS STRING RES EXPR ! OPND2 IS LABEL NO LOAD(OPND1,DR,1) PF1(LDB,2,7,0) DRREG_CL=0 PSF1(PRCL,0,4) PSF1(LSQ,1,RESTEMPAD) PF1(ST,0,TOS,0) PF1(STD,0,TOS,0) PSF1(RALN,0,11) PPJ(-1,16) PSF1(ST,1,RESTEMPAD); ! UPDATED DESCPTR BACK TO WK AREA %IF OPND2_D=0 %THEN PPJ(7,12); ! UNCONDITIONAL FAILS %CONTINUE TRIPSW(60): ! RESFN FINAL POST RES ASSIGN ! OPND2 HAS POINTER ! SINCE RESOLVED STRING MAY BE CONST ! CAN NOT USE NORMAL ASSIGN D=OPND1_D&X'FFFF'; ! TO 4 WORD WK AREA LOAD(OPND2,DR,1); ! POINTER TO DR DRREG_CL=0 PSF1(LSD,1,D); ! REMNANT DESC TO ACC PSF1(LB,1,D); ! TO HALF (IE LENGTH) TO B PF2(MVL,0,0,0,0,0); ! MOVES IN LENGTH BYTE FROM B %IF PARM_OPT#0 %START; ! FORCE IN CAP CHK PF1(STD,0,TOS,0) PSF1(INCA,0,-1); ! BACK TO LENGTH PF1(LB,2,7,0); ! B HAS LENGTH LESS TYPE BITS PF1(MODD,0,BREG,0); ! WILL FAIL IF FRAG TOO LARGE PF1(LD,0,TOS,0); ! ASSNG DESC BACK %FINISH PF1(LDB,0,BREG,0) PF2(MV,1,0,0,0,0) BREGREG_USE=0 DRREG_USE=0 ACCREG_USE=0 %CONTINUE TRIPSW(68): ! INDEX STRING FOR CHARNO ! OPND1 32 BIT ADDRESS OF STR ! OPND2 THE INDEX %IF OPND2_FLAG=SCONST %AND OPND2_D=0 %START LOAD(OPND1,BREG,2) %FINISH %ELSE %IF PARM_OPT=0 %START LOAD(OPND2,BREG,2) LOAD(OPND1,ACCR,0) PF1(ADB,OPND1_XB&15,OPND1_XB>>4,OPND1_D) %FINISH %ELSE %START LOAD(OPND2,BREG,1) LOAD(OPND1,ACCR,0) DESC=X'1800000100000000' PF1(LD,0,PC,LONG CONST(DESC)) PSORLF1(INCA,OPND1_XB&15,OPND1_XB>>4,OPND1_D) DRREG_USE=0 PF1(LDB,2,7,0); ! FOR CORECT BOUND FAULT PF3(JAT,12,0,5); ! JUMP ON B=0 PAST MODD PSF1(INCA,0,1) PSF1(SBB,0,1) PF1(MODD,0,BREG,0); ! FORCE BOUND FAULT IF OUTSIDE STR PF1(LB,2,0,11); ! DR ADDR PART TO B VIA IMAGE STORE INSTR %FINISH BREGREG_USE=0 EVALREG=BREG 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 LOAD(OPND2,ACCR,1) %IF D=7 %OR D=15 %THEN PSF1(MPSR,0,17) CIOCP(D,ACCR); ! ALWAYS CONSTANTS OPND1_FLAG=9; ! FOR WHEN RES NEEDED OPND1_D=0 OPND1_XB=EVALREG<<4 ACCREG_LINK=ADDR(OPND1) ->STRES TRIPSW(24): ! PRECALL OPND1 HAS RT NAME ! TCELL==ASLIST(TAGS(OPND1_D)) SAVE IRS LAST PAR REG=ACCR; ! LAST PAREMETER REG PSF1(PRCL,0,4) %CONTINUE TRIPSW(25): ! ROUTINE CALL (AFTER PARAMS) ! OPND1 HAS RT NAME TCELL==ASLIST(TAGS(OPND1_D)) %IF REGS(LASTPARREG)_CL=3 %THEN BOOTOUT(LASTPARREG) D=(OPND1_XTRA+20)>>2; ! RALN VALUE C=TCELL_UIOJ>>4&15; ! ROUTINE LEVEL NO %IF TCELL_UIOJ&15=14 %START; ! EXTERNAL CALL JJ=SET LEVREG(-1,-1); ! TO PLT PSF1(RALN,0,D) PF1(CALL,2,JJ,TCELL_SNDISP) %FINISHELSEIF TCELL_PTYPE&X'400'#0 %START JJ=SET LEVREG(-1,C) PSORLF1(LD,0,JJ,TCELL_SNDISP) PSORLF1(LXN,0,JJ,TCELL_SNDISP+12) PSF1(RALN,0,D) PF1(CALL,2,7,0); ! CALL ON DR %FINISHELSE %START %IF C=0 %THEN C=1; ! NEED VALID PLT DES @ XNB+12 JJ=SETLEVREG(XNB,C) PSF1(RALN,0,D) JJ=TCELL_SNDISP %IF TCELL_UIOJ&15=15 %START;! NO BODY AS YET PUSH(JJ,CALL,CA,0) TCELL_SNDISP=JJ PF1(CALL,0,0,0) %FINISH %ELSE PSF1(CALL,0,(JJ<<2-CA)//2) %FINISH FORGET(-1) %CONTINUE TRIPSW(44): ! MAP RESULT ASSIGNMENT ! CALLED BEFORE RETURN TO CALLER RES: LOAD(OPND2,ACCR,1) ACCREG_CL=0 %CONTINUE TRIPSW(45): ! FN RESULT ASSIGNMENT ! CALLED BEFORE RETURN TO CALLER TCELL==ASLIST(TAGS(OPND1_D)) %IF CURRT_OPTYPE=X'35' %START;! STRING FNS LOAD(OPND2,ACCR,1) D=CURRINF_DISPLAY-8; ! DESC TO RESULT AREA PSF1(LD,1,D) PF1(IAD,0,PC,LONG CONST(X'100000000')) PF2(MV,1,1,0,0,UNASSPAT&255) ACCREG_CL=0 %IF TCELL_PTYPE>>14#0 %THEN %START;! IMP80 COMPATABILIT PSF1(LDB,2,D) COPY DR %FINISH %CONTINUE %FINISH %IF CURRT_OPTYPE=X'33' %START;! RECORD FUNCTIONS LOAD(OPND2,ACCR,1) D=CURRINF_DISPLAY-8 PSF1(LD,1,D) BULKM(1,TCELL_ACC,0) ACCREG_CL=0; ACCREG_USE=0 DRREG_USE=0 PSF1(LSS,1,D+4); ! 32 POINTER IN ACC %CONTINUE %FINISH ->RES TRIPSW(26): ! RECOVER FN RESULT ! CALLED AFTER RETURN TO CALLER %IF CURRT_OPTYPE=X'35' %START; ! STRING FNS ! RESULTS ALREADY IN WORK AREA OPND1_FLAG=7 OPND1_D=CURRINF_RBASE<<16!OPND1_XTRA %CONTINUE %FINISH OPND1_FLAG=9; OPND1_XB=ACCR<<4 OPND1_D=0 ACCREG_CL=1 ACCREG_LINK=ADDR(OPND1) %CONTINUE TRIPSW(27): ! RECOVER MAP RESULT ! CALLED AFTER RETURN TO CALLER OPND1_FLAG=9; OPND1_XB=ACCR<<4 OPND1_PTYPE=X'51'; ! AS INTEGER SINCE USED AS REFTRIP OPND1_D=0 ACCREG_CL=1 ACCREG_LINK=ADDR(OPND1) %CONTINUE TRIPSW(28): ! PASS PARAMETER(1)= NORMAL VALUE LCELL==ASLIST(OPND1_XTRA&X'FFFF'); ! PARAM DESCTR CELL D=LCELL_ACC; ! PARAM_ACC MISPLACED %IF OPND1_PTYPE&7=5 %START; ! STRINGS BY VALUE - LABORIOUS LOAD(OPND2,DR,1) %IF PARM_OPT#0 %START; ! TOPND=0; TOPND_PTYPE=X'51' TOPND_D=D GETINACC(BREG,4,TOPND); ! MAX LENGTH+1 TO BREG PF1(CPB,2,7,0) PPJ(12,9); ! BLE TO CAP EX PF1(LDB,0,BREG,0); ! MAXL+1 TO BOUND %FINISH %ELSE PSF1(LDB,0,D) EVALREG=DR %FINISHELSEIF OPND1_PTYPE&7=3 %START; ! RECORD BY VALUE C=(D+3)&(-4) DESC=X'18000000'+C DESC=DESC<<32+8 %IF OPND2_FLAG=SCONST %THEN D=0 %ELSE D=1 %AND LOAD(OPND2,ACCR,1) %IF REGS(LASTPARREG)_CL=3 %THEN BOOT OUT(LASTPARREG) %IF DRREG_CL#0 %THEN BOOT OUT(DR) PF1(LD,0,PC,LONG CONST(DESC)) PF1(STSF,0,TOS,0) PF1(INCA,0,TOS,0) PF1(STD,0,TOS,0) PSF1(ASF,0,C>>2) BULKM(D,C,0) ACCREG_CL=0 LAST PAR REG=ACCR %CONTINUE %FINISHELSESTART LOAD(OPND2,ACCR,1) EVALREG=ACCR %FINISH ->PARCHK TRIPSW(29): ! GET 32 BIT ADDRESS %IF OPND1_FLAG=INDNAME %AND OPND1_XTRA<=0 %START ! POINTER IN STORE THIS IS NOOP TCELL==ASLIST(TAGS(OPND1_D)) OPND1_FLAG=7 OPND1_PTYPE=X'51' OPND1_D=(TCELL_UIOJ>>4&15)<<16!(TCELL_SLINK+4) OPND1_XTRA=0 %FINISH %ELSE LOADAD(OPND1,EVALREG) ->STRES TRIPSW(30): ! GET POINTER FOR %NAME %IF OPND1_FLAG=INDNAME %AND OPND1_XTRA<0 %START ! POINTER IN STORE TCELL==ASLIST(TAGS(OPND1_D)) OPND1_FLAG=7 OPND1_PTYPE=X'61' OPND1_D=(TCELL_UIOJ>>4&15)<<16!TCELL_SLINK OPND1_XTRA=0 %FINISH %ELSE LOADPTR(OPND1,OPND2,EVALREG) ->STRES TRIPSW(31): ! PARAM PASSING (2) NORMAL PTRS PTYPE=OPND1_PTYPE&255; ! FOR PARAM LOAD(OPND2,EVALREG,1) ->PARCHK TRIPSW(32): ! PARAM PASSING(3) ARRAYS ! ALSO (4) PASS RT PARAM SAME CODE LOAD(OPND2,ACCR,1) EVALREG=ACCR PARCHK: ! KEEP AUTO STACKING CORRECT %IF LAST PAR REG#EVALREG %AND REGS(LAST PAR REG)_CL=3 %C %THEN BOOT OUT(LAST PAR REG) LAST PAR REG=EVALREG REGS(EVALREG)_CL=3 %CONTINUE TRIPSW(69): ! PASS6 PASS WKAREA FOR STR&RECORDS D=OPND2_D&X'FFFF' %IF OPND2_PTYPE&7=5 %THEN D=D+11;! STRINGS LEAVE DESC SPACE SETSTRD(DR,256,CURRINF_RBASE,D) %IF OPND2_PTYPE&7=5 %THEN PSF1(STD,1,D-11) EVALREG=DR ->PARCHK TRIPSW(63): ! RTFP TURN RTNAME INTO FORMAL %BEGIN %RECORD(RD) ZOPND TCELL==ASLIST(TAGS(OPND1_D)) %IF TCELL_PTYPE&X'400'#0 %START; ! NAM>0 PASS A FORMAL DFETCH(EVALREG,16,TCELL_UIOJ>>4&15,TCELL_SNDISP) %FINISHELSEIF TCELL_UIOJ&15=14 %START; ! EXTERNAL PASSED D=SET LEVREG(-1,-1) ZOPND=0 ZOPND_FLAG=10; ZOPND_PTYPE=X'61' GET IN ACC(ACCR,8,ZOPND) PF1(LUH,0,D,TCELL_SNDISP) %FINISHELSE %START %IF DRREG_CL#0 %THEN BOOT OUT(DR) PSF1(JLK,0,1) C=TCELL_UIOJ>>4&15 %IF C=0 %THEN C=1 JJ=TCELL_SNDISP %IF TCELL_UIOJ&15=15 %START;! BODY NOT GIVEN PUSH(JJ,LDA,CA,0) TCELL_SNDISP=JJ PF1(LDA,0,0,0) %FINISH %ELSE PSF1(LDA,0,JJ<<2-CA) PF1(INCA,0,TOS,0) PF1(LDTB,0,PC,WORD CONST(X'E0000001')) TOPND_FLAG=10; TOPND_PTYPE=X'51' TOPND_XB=LNB<<4; TOPND_D=PTROFFSET(C) GET IN ACC(ACCR,4,TOPND) PF1(LUH,0,PC,WORD CONST(M'IMP')) PF1(STD,0,TOS,0) PF1(LUH,0,TOS,0) %FINISH OPND1_FLAG=9 OPND1_D=0 OPND1_XB=ACCR<<4 ACCREG_CL=1 %END %CONTINUE TRIPSW(66): ! TYPE GENERAL PARAMETER ! OPND1 THE ACTUAL ! OPND2 HAS PTYPE&ACC %IF OPND1_FLAG=DNAME %AND OPND1_PTYPE&15=0 %START TCELL==ASLIST(TAGS(OPND1_D)) DFETCH(EVALREG,8,TCELL_UIOJ>>4&15,TCELL_SNDISP) %FINISH %ELSE %IF OPND2_D&7=5 %AND OPND2_D&X'C00'#0 %START;!STRING(ARRAY)NAMES LOAD(OPND1,ACCR,1); ! 64 BIT POINTER PF1(OR,0,PC,LONG CONST(X'0200000000000000'));! OR UNSC BIT %FINISH %ELSE %START LOAD(OPND1,ACCR,1); ! 32 BIT ADDRESS TYPE=OPND2_D&7; PREC=OPND2_D>>4&7 %IF TYPE<=2 %START %IF PREC=4 %THEN JJ=X'58000002' %ELSE JJ=PREC<<27!TYPE %FINISH %ELSE JJ=X'1A'<<24!OPND2_D>>16 PF1(LUH,0,PC,WORD CONST(JJ)) OPND1_PTYPE=X'61' %FINISH %CONTINUE !*********************************************************************** !* SECTION TO DEAL WITH SWITCHES INCLUDING ->SW(EXP) * !*********************************************************************** TRIPSW(33): ! DECLARE SWITCH OPND2 HAS BNDS %BEGIN %INTEGER D0,D1,RANGE,LB %INTEGERNAME SSTL TCELL==ASLIST(TAGS(OPND1_D)) SSTL==CAS(4); ! TABLE BOUND FOR SST SSTL=(SSTL+3)&(-4); ! WRD BNDRY D1=SSTL; ! SAVE TABLE BASE LB=OPND2_D RANGE=OPND2_XTRA-LB+1 D0=X'28000000'!RANGE; ! WORD DESCRIPTOR %IF PARM_OPT=0 %THEN D0=D0!1<<24 %AND D1=D1-4*LB;! SET BCI PGLA(8,8,ADDR(D0)) TCELL_SNDISP=(GLACA-8)>>2; ! REMEMBER DESC LOCATION RELOCATE(GLACA-4,D1,4); ! RELOCATE SST ADDRESS C=WORKA_PLABS(6); ! DEFAULT ASLIST(TCELL_SLINK)_S1=SSTL LPUT(44,4<<24!RANGE,SSTL,ADDR(C));! REPEATED INIT OF SST SSTL=SSTL+4*RANGE %END %CONTINUE TRIPSW(34): ! SET SWITCH LABEL(OPND2) TCELL==ASLIST(TAGS(OPND1_D)) LCELL==ASLIST(TCELL_SLINK); ! SIDECHAIN HAS TDISP LB&UB C=LCELL_S1+(OPND2_D-LCELL_S2)*4; ! LAB POSITION D=CA PLUG(4,C,D,4) FORGET(-1) %CONTINUE TRIPSW(35): ! GOTO SW LABEL TCELL==ASLIST(TAGS(OPND1_D)) LCELL==ASLIST(TCELL_SLINK); ! ONTO DISP & BOUNDS LOAD(OPND2,BREG,1) C=TCELL_SNDISP %IF PARM_OPT#0 %AND LCELL_S2#0 %THEN PSF1(SBB,0,LCELL_S2) D=SET LEVREG(-1,-1) PF1(LB,3,D,4*C); ! LOAD SST ENTRY PF1(ADB,0,D,24); ! RELOCATE IT PF1(JUNC,0,BREG,0); ! AND JUMP TO IT BREGREG_CL=0 BREGREG_USE=0 %CONTINUE TRIPSW(36): ! REAL TO INTEGER AS INT C=BYTES(PTYPE>>4) LOAD(OPND1,ACCR,1) HALF=0.5 STORE CONST(D,C,ADDR(HALF)) PF1(RAD,0,PC,D); ! RAD 0.5 WITH EITHER 64 OR 128 BIT MODE TRIPSW(37): ! REAL TO INTGER INTPT(OPND1) PREC=PTYPE>>4 LOAD(OPND1,ACCR,1) %IF PREC=7 %START %IF PARM_OPT#0 %START HALF=R'50800000000000004200000000000000' STORE CONST(D,16,ADDR(HALF)) PF1(ST,0,TOS,0) PF1(RCP,0,PC,D) PPJ(10,9) PSF1(RRSB,0,0) PF1(RCP,0,PC,D) PPJ(2,9) PF1(LSQ,0,TOS,0) %FINISH HALF=R'D188000000000000C300000000000000' STORE CONST(D,16,ADDR(HALF)) PF1(RSB,0,PC,D) PF1(STUH,0,TOS,0) PSF1(USH,0,-44) PSF1(AND,0,4095) PF1(SLSD,0,TOS,0) PF1(NEQ,0,PC,LONGCONST(X'0008000000000000')) PSF1(USH,0,12) PF1(OR,0,TOS,0) %FINISH %ELSE %START %IF PARM_OPT#0 %THEN %start pf1(st,0,tos,0) pf1(st,0,tos,0) pf1(rad,0,tos,0) PSF1(RSC,0,55) pf1(lsd,0,tos,0) %finish %IF BREGREG_CL#0 %THEN BOOT OUT(BREG) PF1(FIX,0,BREG,0) PSF1(MYB,0,4) PSF1(CPB,0,-64) PF3(JCC,10,0,3) PSF1(LB,0,-64) PF1(ISH,0,BREG,0) PF1(STUH,0,BREG,0) BREGREG_USE=0 %FINISH ACCREG_USE=0 OPND1_PTYPE=OPND1_PTYPE-X'11' %CONTINUE TRIPSW(38): ! INTEGER TO STRING AS TOSTRING GET WSP(D,4) LOAD(OPND1,ACCR,1) PF1(OR,0,0,256) PSF1(ST,1,D+8) ACCREG_CL=0 SET STRD(ACCR,1,CURRINF_RBASE,D+10) PSF1(ST,1,D) ACCREG_CL=0 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 %IF OPND1_FLAG=DNAME %START; ! LHS IN LOCAL SPACE LOAD(OPND2,ACCR,1) TCELL==ASLIST(TAGS(OPND1_D)) DSTORE(EVALREG,16,TCELL_UIOJ>>4&15,TCELL_SLINK+OPND1_XTRA&X'FFFF') %FINISHELSESTART LOADAD(OPND1,BREG) LOAD(OPND2,ACCR,1) PF1(ST,3,PC,MAPDES(7)) BREGREG_CL=0 %FINISH ACCREG_CL=0 %CONTINUE TRIPSW(43): ! POINTER ASSIGNMENT %IF OPND1_FLAG=DNAME %START; ! LOCAL PTR LOAD(OPND2,ACCR,1) TCELL==ASLIST(TAGS(OPND1_D)) DSTORE(EVALREG,8,TCELL_UIOJ>>4&15,TCELL_SLINK+OPND1_XTRA&X'FFFF') ACCREG_CL=0 %CONTINUE %FINISH LOADAD(OPND1,BREG) LOAD(OPND2,ACCR,1) PF1(ST,3,PC,MAPDES(6)) BREGREG_CL=0 ACCREG_CL=0 %CONTINUE TRIPSW(62): ! RECORD ASSIGNMENT LOAD(OPND1,DR,1) %IF OPND2_FLAG=SCONST %THEN BULKM(0,CURRT_X1,OPND2_D) %ELSE %START LOAD(OPND2,ACCR,1) BULKM(1,CURRT_X1,0) ACCREG_CL=0; ACCREG_USE=0 %FINISH DRREG_CL=0; DRREG_USE=0 %CONTINUE TRIPSW(64): ! AAINC INCREMENT RECORD RELATIVE ! ARRAY ACCESS BY RECORD BASE(OPND1) ! TO GIVE ABSOLUTE ACCESS. LOAD(OPND1,EVALREG,0); ! THE RECORD BASE LOAD(OPND2,EVALREG,0); ! THE RELATIVE ACCESS %IF OPND2_XB&7>=2 %AND OPND2_XB>>4<7 %START;! DESC NOT YET IN DR TOPND=OPND2 TOPND_XB=TOPND_XB&X'F0' GET IN ACC(DR,8,TOPND) %UNLESS DRREG_CL=0 %AND DRREG_USE=2 %AND %C DRREG_INF1=TOPND_D&X'FFFF' %FINISH PUT(DR,INCA,OPND1) OPND1=OPND2 OPND1_XB=OPND1_XB!X'70'; ! EITHER (DR) OR (DR+B) DRREG_USE=0 DRREG_CL=1 DRREG_LINK=ADDR(OPND1) %IF CURRT_CNT>1 %THEN %START GETWSP(D,2) PSF1(STD,1,D) DRREG_CL=0; DRREG_USE=2 DRREG_INF1=D OPND1_XB=LNB<<4!2 OPND1_D=D %FINISH %CONTINUE TRIPSW(65): ! AHADJ ARRAY MAPPING OPND1 1 ! HAS ADJUSTMENT OPND2 THE HEAD ! ARRAY PTYPE<<4!MODE IS IN CURRT_X1 OPND2_PTYPE=X'71' LOAD(OPND2,ACCR,1) LOAD(OPND1,BREG,1); ! BASE ADDRESS OR ADJMNT PF1(STUH,0,TOS,0) PF1(SLSD,0,TOS,0) %IF CURRT_X1&1=0 %START; ! ARRAY MAPPING OPND1 IS BASE PF1(STUH,0,TOS,0) PF1(LSS,0,BREG,0) %FINISH %ELSE %START PF1(SLSS,0,BREG,0) PF1(IAD,0,TOS,0); ! ADDRESSES ADDED %FINISH PF1(LUH,0,TOS,0) PF1(SLSD,0,TOS,0) PF1(LUH,0,TOS,0) OPND1_PTYPE=X'71' BREGREG_CL=0 ACCREG_USE=0 ->SUSE TRIPSW(73): ! ON EVENT 1 BEFORE THE TRAP ! SAVE PSW ETC %IF PARM_STACK=0 %START; ! AUXSTACK USED NOTE TOP D=CURRINF_AUXSBASE PSF1(LSS,2,D) PSF1(ST,1,D+12) ACCREG_USE=0 %FINISH PSF1(CPSR,1,CURRINF_ONINF+8) %CONTINUE TRIPSW(74): ! ON EVENT 2 TRAP ENTRYPOINT FORGET(-1) D=CA PGLA(4,4,ADDR(D)) RELOCATE(GLACA-4,D,1); ! GLAWORD TO ON ENTRY ADDRESS CURRINF_ONWORD=CURRINF_ONWORD!(GLACA-4) PSF1(ST,1,CURRINF_ONINF); ! SAVE EVENT,SUBEVENT&LEVEL PSF1(MPSR,1,CURRINF_ONINF+8); ! RESET PSR %IF PARM_STACK=0 %START PSF1(LSS,1,CURRINF_AUXSBASE+12) PSF1(ST,2,CURRINF_AUXSBASE) %FINISH %CONTINUE TRIPSW(75): ! SIGEV SIGNAL EVENT&SUBEVENT ! OPND1_D HAS SIGNAL LEVEL ! OPND2(COMPUTED) HAS EVENT ETC LOAD(OPND2,ACCR,1) PSF1(SLSS,0,0) PF1(LUH,0,TOS,0) LINF==WORKA_LEVELINF(OPND1_D) %IF LINF##CURRINF %START %IF CURRINF_FLAG<=2 %START PF1(LB,0,0,0) PUSH(LINF_RAL,1,CA-3,0) PSF1(STB,1,12); ! UPDATE DIAGS WORD %FINISH %ELSE %START PSF1(LLN,1,0); ! OTHERWISE FRIG LNB %FINISH %FINISH ACCREG_USE=0 ACCREG_CL=0 PPJ(0,2); ! MONITOR %CONTINUE !*********************************************************************** !* SECTION FOR GENERATING CODE FOR INLINE ASSEMBLER * !*********************************************************************** TRIPSW(50): ! UC NOOP CNOP(OPND1_D>>8,OPND1_D&255) %CONTINUE TRIPSW(51): ! UCB1 PRIMARY FORMAT ASSEMBLER C=XTRA&15 D=XTRA>>16 LOAD(OPND1,ACCR,0); ! PREPARE OPERAND PSORLF1(D,OPND1_XB&3!C,OPND1_XB>>4,OPND1_D) UCFORGET: ! FORGET AFTER UC INSTRN FORGET(ACCR) FORGET(BREG) FORGET(DR) %IF D=CALL %OR D=OUT %OR D=JLK %THEN FORGET(XNB) %AND FORGET(CTB) %IF D=LXN %THEN FORGET(XNB) %IF D=LCT %THEN FORGET(CTB) %CONTINUE TRIPSW(52): ! UCB2 TWO BYTE ASSEMBLER ! ALSO SECONDARY FORMAT INSTRNS D=XTRA>>16 %IF XTRA=0 %START PLANT(OPND1_D&X'FFFF'); ! ALLOWS *PUT AT LEAST %FINISH %ELSE %START C=OPND1_D PF2(D,C>>31,C>>30&1,C>>16&255,C>>8&255,C&255) %FINISH ->UCFORGET TRIPSW(53): ! UCB3 TERTIARY ASSEMBLER D=XTRA>>16 LOAD(OPND1,ACCR,0) PF3(D,XTRA&15,OPND1_XB,OPND1_D) ->UCFORGET TRIPSW(54): ! UCW ASSEMBLER WITH WORD OPERAND ! PBW(OPND1_D>>16,OPND1_D&X'FFFF') %CONTINUE TRIPSW(55): ! UCBW BYTE&WORD OPERAND ASSEMBLER ! PB2W(OPND1_D>>24,OPND1_D>>16&255,OPND1_D&X'FFFF') %CONTINUE TRIPSW(59): ! UCNAM ACCESS TO NAMES FROM U-C D=OPND1_D>>28 C=OPND1_D>>16&63; ! LEVEL JJ=OPND1_D&X'FFFF' %IF D=1 %THEN DFETCHAD(EVALREG,C,JJ) %ELSEIF D=2 %THEN %C DSTORE(EVALREG,2,C,JJ) %ELSE DFETCH(EVALREG,2,C,JJ) FORGET(-1) %CONTINUE STRES: CURRT_OPTYPE<-OPND1_PTYPE %IF CURRT_CNT>1 %AND CURRT_OPERN#LASS %AND CURRT_OPERN#AINDX %C %AND OPND1_FLAG=9 %START ! USED MORE THAN ONCE, IN A REG ! AND NOT ALREADY STORED C=BYTES(OPND1_PTYPE>>4&15) %IF CURRT_FLAGS&USE ESTACK=0 %START; ! DUPLICATE NOT LEFT IN ESTACK GET WSP(D,(C+3)>>2) DSTORE(EVALREG,C,CURRINF_RBASE,D) OPND1_FLAG=7 OPND1_D=CURRINF_RBASE<<16!D REGS(EVALREG)_CL=0 REGS(EVALREG)_USE=2 REGS(EVALREG)_INF1=OPND1_D %FINISH %FINISH %IF CURRT_CNT=0 %AND 1<=REGS(EVALREG)_CL<=2 %THEN REGS(EVALREG)_CL=0 %REPEAT %IF PARM_DCOMP#0 %THEN CODEOUT %RETURN %INTEGERFN SET LEVREG(%INTEGER WHICH,RLEV) !*********************************************************************** !* SET EXTRA NAME BASE TO ADDRESS ROUTINE LEVEL 'RLEV' * !* RLEV=0 FOR OWNS, =-1 FOR THE PLT THESE ARE THE SAME! BUT CODED* !* SEPARATELY SO THAT THEY CAN BE SEPARATED IF NECESSARY * !*********************************************************************** %INTEGER USE,INF,OFFSET %RECORD(REGF)%NAME REG IMPABORT %UNLESS -1<=RLEV<=CURRINF_RBASE %IF WHICH<=0 %AND RLEV=CURRINF_RBASE %THEN %RESULT=LNB %IF RLEV<=0 %THEN USE=3 %AND INF=0 %ELSE USE=4 %AND INF=RLEV %IF WHICH<=0 %THEN WHICH=XORYNB(USE,INF) REG==REGS(WHICH) %IF REG_USE=USE %AND REG_INF1=INF %THEN %C REG_AT=CA %AND %RESULT=WHICH OFFSET=PTR OFFSET(RLEV) PSF1(LDCODE(WHICH),1,OFFSET) REG_USE=USE; REG_INF1=INF; REG_AT=CA %RESULT=WHICH %END %INTEGERFN XORYNB(%INTEGER USE,INF) !*********************************************************************** !* CHECKS IF XNB OR YNB SET UP. IF NOT DECIDES WHICH TO OVERWRITE * !*********************************************************************** %RECORD(REGF)%NAME XREG,YREG XREG==REGS(XNB); YREG==REGS(CTB) %IF XREG_USE=USE %AND XREG_INF1=INF %THEN XREG_AT=CA %C %AND %RESULT=XNB %IF YREG_USE=USE %AND YREG_INF1=INF %THEN YREG_AT=CA %C %AND %RESULT=CTB %IF XREG_USE!YREG_USE=0 %THEN %START;! BOTH REGS ARE FREE %IF USE=3 %THEN %RESULT=CTB %RESULT=XNB %FINISH ! ! IF ONLY ONE FREE THEN NO PROBLEM %IF XREG_USE=0 %THEN %RESULT=XNB %IF YREG_USE=0 %THEN %RESULT=CTB ! ! BOTH ARE IN USE. THIS IS WORTH CAREFUL CONSIDERATION AND EXPERIMENT ! A VALUE TABLE MAY BE USE AS MAY LOOK AHEAD. CURRENTLY TRY LRU ! %IF XREG_AT>16#CURRINF_RBASE%THEN YNB=XNB;! BUT XNB IN ASSEMBLER PT=OPND_PTYPE&255 %IF OPND_FLAG=7 %START %IF PT<=X'41' %START %IF PT=X'31' %THEN DR0=X'1B000001' %ELSE DR0=X'58000002' DR0=DR0<<32!OPND_D&X'FFFF' DOPND_PTYPE=X'61'; DOPND_XB=PC<<4 DOPND_D=LONG CONST(DR0) GET IN ACC(DR,8,DOPND) %UNLESS %C DRREG_USE=6 %AND DRREG_INF1=DOPND_D&X'FFFF' DRREG_USE=6; DRREG_INF1=DOPND_D&X'FFFF' OPND_FLAG=10; OPND_XB=LNB<<4!1 OPND_D=PTROFFSET(OPND_D>>16) %RETURN %FINISH YNB=SET LEVREG(YNB,OPND_D>>16) OPND_FLAG=10 OPND_XB=YNB<<4 OPND_D=OPND_D&X'FFFF' %RETURN %FINISH %END %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 LOAD INTO SPECIFIED REG * !*********************************************************************** %INTEGER K,KK,D,YNB,PTYPE,PREC,TYPE,USE,INF,X %LONGINTEGER DESC %RECORD(TRIPF) %NAME REFTRIP %RECORD(REGF)%NAME REQREG %RECORD(TAGF) %NAME TCELL %SWITCH SW(0:10) USE=0 K=OPND_FLAG X=OPND_XTRA PTYPE=OPND_PTYPE TYPE=PTYPE&15 PREC=PTYPE>>4&15 REQREG==REGS(REG) %IF K>10 %THEN IMPABORT ->SW(K) SW(0): ! CONSTANT < 16 BITS %IF PREC>4 %THEN ->SW1 SW0: OPND_PTYPE=X'51' %IF OPND_PTYPE<=X'41' OPND_XB=0; OPND_FLAG=10 %IF PREC<=5 %THEN USE=5 %AND INF=OPND_D ->OPTLOAD SW(1): SW1: ! LONG CONSTANT %IF TYPE=5 %THEN ->SCONST %IF TYPE=1 %AND PREC<=5 %AND X'FFFE0000'<=OPND_D<=X'1FFFF' %THEN ->SW0 %IF PTYPE=X'61' %AND X'FFFE0000'<=LONGINTEGER(ADDR(OPND_D))<=X'1FFFF' %THEN %C OPND_D=X %AND ->SW0 %IF PREC=7 %THEN KK=ADDR(WORKA_A(OPND_D)) %ELSE KK=ADDR(OPND_D) STORE CONST(D,BYTES(PREC),KK) OPND_FLAG=10; OPND_XB=PC<<4 OPND_D=D USE=6; INF=D&X'FFFF' ->OPTLOAD SCONST: ! STRING CONSTANT OPND_DIS AR PTR STORE STRING(D,STRING(ADDR(WORKA_A(OPND_D)))) %IF DRREG_CL#0 %THEN BOOT OUT(DR) PF1(LDRL,0,PC,D) DRREG_USE=0 %IF REG=ACCR %THEN COPY DR OPND_FLAG=9 OPND_D=0 OPND_XB=REG<<4 %RETURN SW(3): ! 128 BIT CONSTANT IMPABORT SW(2): ! NAME (+POSSIBLE OFFSET) TCELL==ASLIST(TAGS(OPND_D)) %IF TYPE=5 %THENSTART SETSTRD(REG,TCELL_ACC,TCELL_UIOJ>>4&15,TCELL_SLINK+X) REQREG_CL=1 ->LDED %FINISH OPND_FLAG=7 %IF X<=0 %THEN %START USE=9; INF=OPND_D %IF REQREG_USE=USE %AND REQREG_INF1=INF %AND REQREG_CL=0 %THEN ->LDED %FINISH OPND_D=(TCELL_UIOJ&X'F0')<<12!(TCELL_SLINK+X) OPND_XTRA=0 ->OPTLOAD LDED: REQREG_USE=USE REQREG_INF1=INF NULLOAD: %IF TYPE=1 %AND PREC<5 %THEN OPND_PTYPE=X'51' OPND_XB=REG<<4 OPND_FLAG=9 OPND_D=0 REQREG_LINK=ADDR(OPND) REQREG_CL=1 %RETURN SW(5): ! INDIRECT VIA DICTIONARY ! ONLY RECORDNAME SCALAR(_XTRA>=0) ! OR POINTER(_XTRA<0) TCELL==ASLIST(TAGS(OPND_D)) YNB=SET LEVREG(-1,TCELL_UIOJ>>4&15) %IF X<0 %START; ! %NAME OPND_FLAG=10 OPND_XB=YNB<<4!2 USE=9; INF=OPND_D OPND_D=TCELL_SLINK ->OPTLOAD %FINISH DESC=3<<24!1!PREC<<27; ! UNSCALED AND BCI %IF TYPE=5 %THEN DESC=DESC!X'FF' %IF PREC=4 %THEN DESC=X'58000002' DESC=DESC<<32!X D=LONG CONST(DESC) %IF DRREG_CL#0 %THEN BOOT OUT(DR) %UNLESS DRREG_USE=6 %AND DRREG_INF1=D %START PF1(LD,0,PC,D) DRREG_USE=6 DRREG_INF1=D %FINISH OPND_FLAG=10 OPND_XB=YNB<<4!1 OPND_D=TCELL_SLINK+4; ! SECND HALF OF RECORDNAME DESCR ->OPTLOAD SW(4): ! VIA DESC AT OFFSET FROM ! A COMPUTED POINTER REFTRIP==TRIPLES(OPND_D) TOPND=REFTRIP_OPND1 LOAD(TOPND,BREG,0) YNB=XORYNB(-1,-1) PF1(LDCODE(YNB),TOPND_XB&3,TOPND_XB>>4,TOPND_D) OPND_FLAG=10; OPND_XB=YNB<<4!2 OPND_D=X OPND_D=0 %IF OPND_D<0 ->OPTLOAD SW(6): ! INDIRECT WITH OFFSET REFTRIP==TRIPLES(OPND_D) %IF X<0 %AND %C (REFTRIP_OPERN=AINDX %OR REFTRIP_OPERN=AAINC) %START ! TRIPLES NOT DESIGN FOR DESC M-C ! A SPECIAL CASE IS NEEDED HERE OPND=REFTRIP_OPND1 %IF REFTRIP_OPERN=AINDX %AND REFTRIP_OPND1_XB&7=3 %AND %C REFTRIP_OPND2_FLAG#9 %THEN LOAD(REFTRIP_OPND2,BREG,1) ! ABOVE LINES CHECKS B HAS NOT BEEN ! DUMPED I((?)+%B) FORMS OPND_PTYPE=PTYPE LOAD(OPND,REG,MODE) %RETURN %FINISH %IF TYPE=5 %THEN DESC=X'1B00010000000000' %ELSE %C DESC=LENGTHENI(DESCTOP(PREC)!X'03000000')<<32 %IF X>0 %THEN DESC=DESC+X %AND OPND_XTRA=0 %IF REFTRIP_OPND1_FLAG<=1 %AND REFTRIP_OPND1_PTYPE<=X'51' %THEN %START INTEGER(ADDR(DESC)+4)=INTEGER(ADDR(DESC)+4)+REFTRIP_OPND1_D OPND_XB=PC<<4!2 %ELSE LOADAD(OPND,BREG) OPND_XB=PC<<4!3 OPND_PTYPE=PREC<<4!TYPE; ! LOADAD WILL HAVE RESET IT %FINISH OPND_FLAG=10 OPND_D=LONG CONST(DESC) ->OPTLOAD SW(7): ! I-R IN A STACK FRAME %IF TYPE=5 %THEN %START DFETCH(REG,8,CURRINF_RBASE,OPND_D&X'FFFF') REQREG_CL=1 ->LDED %FINISH USE=2; INF=OPND_D %IF MODE>0 %AND REQREG_USE=2 %AND REQREG_INF1=OPND_D %C %AND REQREG_CL=0 %THEN ->LDED OPTLOAD: %IF OPND_FLAG#10 %THEN DEVELOP BD(OPND) SW(10): ! DEVELOPPED BD FORM %IF MODE>0 %THEN %START %IF TYPE=5 %THEN LOADPTR(OPND,OPND,REG) %AND %RETURN %IF USE>0 %AND REQREG_CL=0 %AND %C ((REQREG_PRIMUSE=USE %AND REQREG_INF1=INF) %OR %C (REQREG_SECUSE=USE %AND REQREG_INF2=INF)) %THEN ->NULLOAD %IF OPND_XB=X'70' %AND REG=BREG %THEN ->NULLOAD GETINACC(REG,BYTES(PREC),OPND) ->LDED %FINISH %RETURN SW(8): ! TRIPLE REFTRIP==TRIPLES(OPND_D) OPND=REFTRIP_OPND1 LOAD(OPND,REG,MODE) %RETURN SW(9): ! I-R IN A REGISTER %IF MODE>0 %START %IF OPND_XB>>4=REG %THEN REQREG_LINK=ADDR(OPND) %AND %RETURN %IF OPND_XB>>4=ACCR %AND REG=BREG %AND BREGREG_CL=0 %START PF1(ST,0,BREG,0) ACCREG_CL=0 BREGREG_CL=1 BREGREG_USE=ACCREG_USE BREGREG_INF1=ACCREG_INF1 BREGREG_INF2=ACCREG_INF2 BREGREG_LINK=ADDR(OPND) OPND_XB=REG<<4 %RETURN %FINISH %IF OPND_XB>>4=DR %AND REG=ACCR %AND PREC=6 %START COPY DR DRREG_CL=0 ACCREG_CL=1 ACCREG_USE=DRREG_USE ACCREG_INF1=DRREG_INF1 ACCREG_INF2=DRREG_INF2 ACCREG_LINK=ADDR(OPND) OPND_XB=ACCR<<4 %RETURN %FINISH %FINISH %IF OPND_XB>>4=BREG %THEN %START OPND_FLAG=10 OPND_XB=BREG<<4 OPND_D=0 ->OPTLOAD %FINISH REGS(OPND_XB>>4)_LINK=ADDR(OPND) BOOT OUT(OPND_XB>>4) ->OPTLOAD %END %ROUTINE SETSTRD(%INTEGER REG,SIZE,BASE,DISP) !*********************************************************************** !* SETS A STRING DESCRIPTOR IN ACC OR DR * !*********************************************************************** %LONGINTEGER DESC IMPABORT %UNLESS REG=DR %OR REG=ACCR %IF REGS(REG)_CL#0 %THEN BOOT OUT(REG) %IF REG=DR %START; ! USING DESCRIPTOR REG DESC=X'18000000'+SIZE DESC=DESC<<32!DISP PF1(LD,0,PC,LONG CONST(DESC)) PSF1(INCA,1,PTR OFFSET(BASE)) %FINISH %ELSE %START PSF1(LSS,0,DISP) PSF1(IAD,1,PTR OFFSET(BASE)) PF1(LUH,0,PC,WORD CONST(X'18000000'+SIZE)) %FINISH REGS(REG)_USE=0 %END %ROUTINE LOADAD(%RECORD(RD) %NAME OPND,%INTEGER REG) !*********************************************************************** !* MUCH AS LOAD BUT PRODUCES THE 32 BIT ADDRESS OF OPERAND * !* ABORT ON NON RELEVANT ALTERNATIVES OF OPND * !************************************************************************ %RECORD(TRIPF)%NAME REFTRIP %RECORD(TAGF) %NAME TCELL %INTEGER B,D,YNB,XTRA %RECORD(RD) TOPND %SWITCH SW(0:10) PTYPE=OPND_PTYPE XTRA=OPND_XTRA ->SW(OPND_FLAG) SW(*): ! INVALID IMPABORT SW(2): ! DNAME TCELL==ASLIST(TAGS(OPND_D)) DFETCHAD(REG,TCELL_UIOJ>>4&15,TCELL_SLINK+XTRA) LDED: OPND_PTYPE=X'51'; ! 32 BIT ADDRESS IS INTEGER OPND_FLAG=9 OPND_D=0 OPND_XB=REG<<4 REGS(REG)_LINK=ADDR(OPND) REGS(REG)_CL=1 %RETURN SW(4): ! VIA PTR AT OFFSET FROM ! COMPUTED EXPRESSION REFTRIP==TRIPLES(OPND_D) TOPND=REFTRIP_OPND1 LOAD(TOPND,BREG,0) YNB=XORYNB(-1,-1) PF1(LDCODE(YNB),TOPND_XB&3,TOPND_XB>>4,TOPND_D) REGS(YNB)_USE=0 TOPND_FLAG=10; TOPND_XB=YNB<<4 TOPND_D=XTRA TOPND_D=0 %IF TOPND_D<0 TOPND_D=TOPND_D+4 GETINACC(REG,4,TOPND) ->LDED SW(5): ! INDIRECT VIA PTR TCELL==ASLIST(TAGS(OPND_D)) B=TCELL_UIOJ>>4&15 D=TCELL_SLINK+4 PF: DFETCH(REG,4,B,D) %UNLESS REGS(REG)_USE=2 %AND %C B=CURRINF_RBASE %AND REGS(REG)_INF1=D %IF XTRA>0 %THEN PSF1(INCCODE(REG),0,XTRA) ->LDED SW(6): ! INDIRECT OFFSET REFTRIP==TRIPLES(OPND_D) D=REFTRIP_OPERN OPND=REFTRIP_OPND1; ! MUST COPY IF MULTIPLE USE %IF D=AINDX %OR D=AAINC %START; ! DESC ITEMS AN AWKARD SPECIAL CASE LOADAD(OPND,REG) %ELSE LOAD(OPND,REG,1) %FINISH %IF XTRA>0 %THEN PSF1(INCCODE(REG),0,XTRA) ->LDED SW(7): ! LOCAL-IR IN BASE&OFFSET FORM B=OPND_D>>16 D=OPND_D&X'FFFF' OPND_XTRA=0 %IF TYPE=5 %THEN D=D+4 %AND ->PF DFETCHAD(REG,B,D); ->LDED SW(10): ! DEVELOPPED BD FORM ! NORMALLY ARRAY ELEMENTS ONLY B=OPND_XB&3; ! B=0 DIRECT ADDRESS(IE BOOTED) ! B=1 VIA DR ! B=2 VIA DESCR IN STORE ! AS 2 BUT MODIFIED %IF B=0 %THEN GETINACC(REG,BYTES(OPND_PTYPE>>4&15),OPND) %AND ->LDED %IF B>=2 %AND X'73'#OPND_XB#X'72' %START TOPND_PTYPE=X'61'; TOPND_FLAG=10 TOPND_XB=OPND_XB&X'F0' TOPND_D=OPND_D %IF B=2 %START; ! UNMODIFIED DESCPTR ! AVOID GOING VIA DR AND IS INSTRN TOPND_D=TOPND_D+4 TOPND_PTYPE=X'51' GET IN ACC(REG,4,TOPND) ->LDED; ! BTM HALF TO CORRECT REG %FINISH %UNLESS DRREG_USE=2 %AND TOPND_D=DRREG_INF1 %AND %C TOPND_XB=LNB<<4 %THEN GET IN ACC(DR,8,TOPND);! DESC TO DR %FINISH %IF B=3 %THEN PF1(MODD,0,BREG,0) %AND BREGREG_CL=0 DRREG_CL=0 %IF B=1 %THEN PSORLF1(MODD,0,OPND_XB>>4,OPND_D) %IF B&1#0 %THEN DRREG_USE=0 TOPND_PTYPE=X'51'; TOPND_XB=X'02';! ISN N TOPND_FLAG=10; TOPND_D=11; ! ADDRESS FIELD IN DR GET IN ACC(REG,4,TOPND) ->LDED %END %ROUTINE LOADPTR(%RECORD(RD) %NAME OPND,OPND2,%INTEGER REG) !*********************************************************************** !* MUCH AS LOAD BUT PRODUCES THE POINTER TO THE OPERAND * !* ABORT ON NON RELEVANT ALTERNATIVES OF OPND * !*********************************************************************** %RECORD(TAGF) %NAME TCELL %RECORD(TRIPF)%NAME REFTRIP %INTEGER K,X,YNB,ZNB,WREG,D,B,OP %ROUTINESPEC TOPHALF(%INTEGER BS,DP) %SWITCH SW(0:10) PTYPE=OPND_PTYPE X=OPND_XTRA K=OPND_FLAG D=DESCTOP(PTYPE>>4&15) %IF PTYPE&X'FF'=X'33' %THEN D=D-1+OPND2_D&X'FFFF' IMPABORT %UNLESS REG=DR %OR REG=ACCR WREG=REG %IF REG=DR %THEN WREG=BREG ->SW(K) SW(*): ! INVALID IMPABORT SW(2): ! DNAME TCELL==ASLIST(TAGS(OPND_D)) DFETCHAD(WREG,TCELL_UIOJ>>4&15,TCELL_SLINK+X) %IF PTYPE&255=X'35' %THEN D=D+OPND2_D&X'FFFF';! CORRECT STR BOUND TOPHALF(PC,WORD CONST(D)) LDED: OPND_PTYPE=X'61' OPND_XB=REG<<4 OPND_FLAG=9 OPND_D=0 REGS(REG)_LINK=ADDR(OPND) REGS(REG)_CL=1 %RETURN SW(4): ! VIA PTR AT OFFSET FROM COMPUTER ADDDRESS REFTRIP==TRIPLES(OPND_D) TOPND=REFTRIP_OPND1 LOAD(TOPND,BREG,0) YNB=XORYNB(-1,-1) PF1(LDCODE(YNB),TOPND_XB&3,TOPND_XB>>4,TOPND_D) REGS(YNB)_USE=0 TOPND_FLAG=10; TOPND_XB=YNB<<4 TOPND_D=X TOPND_D=0 %IF TOPND_D<0 GETINACC(REG,8,TOPND) ->LDED SW(5): ! INDIRECT VIA DICT TCELL==ASLIST(TAGS(OPND_D)) %IF X<0 %START; ! IS A POINTER DFETCH(REG,8,TCELL_UIOJ>>4&15,TCELL_SLINK) ->LDED %FINISH ! THING IN A RECORD NAME DFETCH(WREG,4,TCELL_UIOJ>>4&15,TCELL_SLINK+4);! ADDRESS PART OF DESC ->INC ADDR SW(6): ! INDIRECT OFFSET REFTRIP==TRIPLES(OPND_D) OP=REFTRIP_OPERN OPND=REFTRIP_OPND1; ! MUST COPY IN CASE MULTIPLE USE %IF OP=AINDX %OR OP=AAINC %START; ! SEE LOADAD LOADPTR(OPND,OPND2,REG) %IF REG=DR %THEN WREG=DR %IF REG=ACCR %THEN PSF1(MPSR,0,17) %ELSE LOAD(OPND,WREG,1) %FINISH INC ADDR: ! BY ANY OFFSET %IF X>0 %THEN PSF1(INCCODE(WREG),0,X) STR: ! SET TOP HALF OF STRING DESC ! MESSY FOR STRING ARRAY NAMES ! OPND2_XTRA=BML<<16!DML PTYPE=currt_x1>>16; ! BACK TO REFFED VARS PTYPE %IF PTYPE&7#5 %THEN TOPHALF(PC,WORD CONST(D)) %AND ->LDED %IF OPND2_flag=sconst %THEN %START; ! STRING LENGTH KNOWN D=D+OPND2_D&X'FFFF'; ! DML IS BYTES IN STRING(IE ACC-1) TOPHALF(PC,WORD CONST(D)) ->LDED %FINISH %IF PTYPE&X'300'=0 %START; ! STRINGNAMES DML&BML FOR HEAD chop operand(opnd2,x'51',0);! chopdown operand load(opnd2,0,0) TOPHALF(opnd2_xb>>4,OPND2_D&X'FFFF') ->LDED %FINISH ! stringarraynames chop operand(opnd2,X'51',12) load(opnd2,0,0) ZNB=XORYNB(-1,-1) PF1(LDCODE(ZNB),opnd2_xb&3,opnd2_xb>>4,OPND2_D&X'FFFF');! DV BASE AD TO ZNB %if opnd_flag#9 %then load(opnd,wreg,1) %IF REG=ACCR %START PF1(LUH,0,ZNB,12*(currt_x1&15)-8); ! ELSIZE TO UPPER HALF(XTRA HAS DIMENSIONALITY) PF1(IAD,0,PC,LONG CONST(X'17FFFFFF00000000')) %ELSE TOPHALF(PC,WORDCONST(X'18000001')) PF1(LDB,0,ZNB,12*(currt_x1&15)-8); ! BOUND TO STR SIZE+1 PSF1(INCA,0,-1) PSF1(MODD,0,1); ! ONE OFF SIZE CURIOUSLY DRREG_USE=0 %FINISH ->LDED SW(7): ! LOCAL BASE&DISP ! CAN ARISE FROM OPTMAP IN CSNAME ! IMPROVING ==INTEGER(ADDR(X+4)) %IF PTYPE&X'FF'=X'35' %THEN %C DFETCH(REG,8,OPND_D>>16,OPND_D&X'FFFF') %AND ->LDED DFETCHAD(WREG,OPND_D>>16,OPND_D&X'FFFF') ->STR SW(10): ! DEVELOPPED BD FORM ! NORMALLY ARRAY ELEMENTS ONLY B=OPND_XB&3; ! B=0 DIRECT ADDRESS(IE BOOTED) ! B=1 VIA DR ! B=2 VIA DESCR IN STORE ! AS 2 BUT MODIFIED %IF B=0 %THEN GETINACC(REG,8,OPND) %AND ->LDED OP=MODD %IF PTYPE&255=X'35' %OR PTYPE&255=X'41' %THEN OP=INCA %IF B>=2 %AND X'73'#OPND_XB#X'72' %START TOPND_PTYPE=X'61'; TOPND_FLAG=10 TOPND_XB=OPND_XB&X'F0' TOPND_D=OPND_D %IF B=2 %AND REG=ACCR %THEN GETINACC(ACCR,8,TOPND) %AND ->lded %UNLESS DRREG_USE=2 %AND DRREG_INF1=TOPND_D %AND %C TOPND_XB=LNB<<4 %THEN GET IN ACC(DR,8,TOPND);! DESC TO DR %FINISH %IF B=3 %THEN PF1(OP,0,BREG,0) %AND BREGREG_CL=0 DRREG_CL=0 %IF B=1 %THEN PSORLF1(OP,0,OPND_XB>>4,OPND_D) %IF B&1#0 %THEN DRREG_USE=0 %IF REG=ACCR %THEN COPY DR ->LDED %ROUTINE TOPHALF(%INTEGER BS,DP) %IF REG=DR %THEN %START %IF WREG# DR %START BOOT OUT(DR) %IF DRREG_CL#0 PF1(LDA,0,BREG,0) BREGREG_CL=0 %FINISH PF1(LDTB,0,BS,DP) DRREG_USE=0 %FINISH %ELSE PF1(LUH,0,BS,DP) %AND ACCREG_USE=0 %END %END %routine chop operand(%record(rd)%name opnd,%integer newpt,xoffset) !*********************************************************************** !* changes opnd record to refer to a smaller bit at xoffset from * !* the original start. Used to load part of arrayheads etc * !*********************************************************************** opnd_ptype=opnd_ptype&x'ff00'!newpt %if opnd_flag=9 %then impabort %if xoffset<=0 %then %return %if opnd_flag=dname %or opnd_flag=indirect %or opnd_flag=indname %c %then opnd_xtra=opnd_xtra&x'ffff'+xoffset %if opnd_flag=localir %or opnd_flag=developped %then opnd_d=opnd_d+xoffset %end %ROUTINE VMULTIPLY !*********************************************************************** !* DOES ALL VECTOR MULTIPLIES * !*********************************************************************** %INTEGER DVPOS,CM1,CM2,DINF,YNB dvpos=-1 %if opnd2_flag=sconst %then DVPOS=OPND2_D&X'FFFF' %IF DVPOS>0 %THENSTART DVPOS=DVPOS+3*(D+1-C) CM1=CTABLE(DVPOS) CM2=CTABLE(DVPOS+1) LOAD(OPND1,BREG,1) %AND BREGREG_USE=0 %UNLESS CM1=0 %AND CM2=1 PSF1(SBB,0,CM1) %UNLESS CM1=0 PSF1(MYB,0,CM2) %UNLESS CM2=1 %FINISH %ELSE %IF C=D=1 %AND XTRA>>16&7<=2 %AND %C XTRA>>16&255#X'41' %START;! NOT HALF BUT INTEGER OR REAL LOAD(OPND1,BREG,1) %IF PARM_COMPILER=0 %START; ! IF COMPILER SET ALL ARRAYS START AT 0 chop operand(opnd2,x'61',8) load(opnd2,dr,0) %IF DRREG_CL>0 %THEN BOOT OUT(DR) %if opnd2_xb&3=0 %then PSORLF1(SBB,2,opnd2_xb>>4,OPND2_d) %else %c load(opnd2,dr,1) %and psorlf1(sbb,2,7,0) %and drreg_cl=0 BREGREG_USE=0 DRREG_USE=0; ! NOT WORTH ANY REMEMBERING AS ! DR WILL BE OVERWRITTEN WITH ! THE FETCH OR STORE %FINISH %FINISHELSESTART LOAD(OPND1,BREG,0) %IF OPND1_XB&3>0 %OR BREGREG_CL>0 %THEN %C LOAD(OPND1,BREG,1) %AND OPND1_FLAG=10 CM1=3*(D-C); ! WORD TO RELEVANT TRIPLE chop operand(opnd2,x'61',8) DINF=OPND2_D!CM1<<24 %UNLESS DRREG_USE=14 %AND DRREG_INF1=DINF %START load(opnd2,dr,1); ! DV PTR PSF1(MODD,0,CM1) %UNLESS CM1=0 %FINISH PUT(BREG,X'2C',OPND1); ! 2C IS VMY BREGREG_USE=0 OPND1_FLAG=9; OPND1_D=0 OPND1_XB=BREG<<4 BREGREG_CL=1 drreg_cl=0 DRREG_INF1=DINF+(3<<24) DRREG_USE=14 %FINISH %END %ROUTINE STARSTAR !*********************************************************************** !* PLANT IN-LINE CODE FOR EXPONENTIATION * !* IMP ALLOWS EXPONENTS IN INTEGER EXPRESSIONS FROM 0-63 AND * !* IN REAL EXPRESSIONS FROM-255 TO +255 * !*********************************************************************** %INTEGER TYPEP,PRECP,WORK,C,EXPWORK,VALUE,J1,J2,OPCODE J1=0; J2=0 TYPEP=OPND1_PTYPE&7; PRECP=OPND1_PTYPE>>4&7 %IF TYPEP=2 %THEN OPCODE=RMY %ELSE OPCODE=IMY VALUE=0 %IF OPND2_FLAG=0 %AND 1<=OPND2_D<=63*TYPE %THEN %C VALUE=OPND2_D; ! EXPONENT IS #0 AND CONSTANT LOAD(OPND1,ACCR,2); ! FETCH OPERAND TO ACC ! ! STORE OPERAND IN 'WORK' AND GET HOLD OF EXPONENT ! GET WSP(WORK,BYTES(PRECP)>>2) %IF TYPEP=2 %THEN GET WSP(EXPWORK,1) PSF1(ST,1,WORK) ACCREG_CL=0 LOAD(OPND2,BREG,1); ! EXPONENT TO B REGISTER %IF TYPEP=2 %THEN PSF1(STB,1,EXPWORK) ! ! GET '1' INTO ACC IN APPROPIATE FORM ! %IF PRECP<=5 %THEN C=LSS %ELSE C=LSD %IF TYPE=1 %THEN PSF1(C,0,1) %ELSE %C %IF PRECP=7 %THEN PSF1(LSD,0,1) %AND PSF1(FLT,0,0) %ELSE %C PF1(C,0,PC,SPECIAL CONSTS(1)) ! ! IF EXPONENT NOT KNOWN AT COMPILE TIME TO BE +VE CONSTANT MUST ! ALLOW FOR ZERO :- XX**0=1 FOR ALL XX ! ALSO ALLOW FOR X**(-N) WHICH IS 1/(X**N) FOR ALL X & N ! %IF VALUE=0 %THEN %START; ! NOT +VE CONSTANT J1=CA PF3(JAT,12,0,0); ! J(B=0) END OF EXP ROUTINE %IF TYPEP=2 %THEN %START PF3(JAT,13,0,4); ! J*+4 IF B>0 PSF1(SLB,0,0) PF1(SBB,0,TOS,0) %FINISH ! ! IN CHECKING MODE PLANT CODE TO CHECK RANGE OF EXPONENT ! %IF PARM_OPT#0 %THEN %START %IF TYPEP=1 %THEN PPJ(30,7);! JUMP B<0 PSF1(CPB,0,64*TYPEP*TYPEP-1) PPJ(2,7) %FINISH %FINISH C=CA PSF1(OPCODE,1,WORK) PSF1(DEBJ,0,(C-CA)//2) ! ! FOR REAL EXPONENTS CHECK IF NEGATIVE AND EVALUATE INVERSE ! %IF VALUE=0 %AND TYPEP=2 %THEN %START PSF1(LB,1,EXPWORK); ! LB ON ORIGINAL EXPONENT J2=CA; PF3(JAF,14,0,0); ! BP END OF EXP ROUTINE %IF PRECP<7 %THEN PF1(RRDV,0,PC,SPECIAL CONSTS(1))%ELSESTART PSF1(SLSD,0,1); PSF1(FLT,0,0) PF1(RDV,0,TOS,0) %FINISH %FINISH ! ! ALL OVER. REAL RESULTS ARE IN FR WORK. INT RESULTS IN GR WORK+1 ! FREE AND FORGET ANY OTHER REGISTERS ! BREGREG_CL=0 ACCREG_USE=0 BREGREG_USE=0 ACCREG_CL=1 OPND1_XB=0; OPND1_D=ACCR ! ! FILL JUMPS TO END OF EXP ROUTINE ! %IF J1>0 %THEN PLUG(1,J1+2,(CA-J1)//2,2) %IF J2>0 %THEN PLUG(1,J2+2,(CA-J2)//2,2) %END %ROUTINE REXP !*********************************************************************** !* CALLS A PERM ROUTINE TO PERFORM REAL**REAL * !*********************************************************************** %INTEGER I,PR %RECORD(RD)%NAME OPND %FOR I=1,1,2 %CYCLE %IF I=1 %THEN OPND==OPND1 %ELSE OPND==OPND2 LOAD(OPND,ACCR,1) PR=OPND_PTYPE>>4 %IF PR=5 %THEN PF1(RMYD,0,PC,SPECIAL CONSTS(1)) %IF PR=7 %THEN PF1(RDDV,0,PC,SPECIAL CONSTS(1)) %REPEAT %IF DRREG_CL>0 %THEN BOOT OUT(DR) %IF BREGREG_CL>0 %THEN BOOT OUT(BREG) PPJ(0,17) %IF PR=5 %THEN PF1(RDDV,0,PC,SPECIALCONSTS(1)) %IF PR=7 %THEN PF1(RMYD,0,PC,SPECIAL CONSTS(1)) %END %ROUTINE SAVE IRS !*********************************************************************** !* DUMP ACC AND-OR B ONTO THE STACK. USED BEFORE CALLING FNS * !* IN EXPRESSIONS. * !*********************************************************************** IMPABORT %IF ACCREG_CL=1=BREGREG_CL %IF ACCREG_CL>=1 %THEN BOOT OUT(ACCR) %IF BREGREG_CL>=1 %THEN BOOT OUT(BREG) %IF DRREG_CL>=1 %THEN BOOT OUT(DR) %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 * !*********************************************************************** %INTEGER CODE %RECORD(REGF)%NAME BOOTREG %RECORD(RD)%NAME R CODE=STCODE(REG) BOOTREG==REGS(REG) IMPABORT %UNLESS 1<=BOOTREG_CL<=3 %AND CODE#0 R==RECORD(BOOTREG_LINK) %IF REG#ACCR %AND ACCREG_CL=3 %THEN BOOT OUT(ACCR) %IF REG#DR %AND DRREG_CL=3 %THEN BOOT OUT(DR) %IF REG=DR %AND BOOTREG_CL=1 %THEN %C BOOTREG_CL=2 %AND GET WSP(R_D,2); ! CONFUSION WITH DR ON TOS %IF BOOTREG_CL=2 %THEN %START %IF R_D=0 %THEN GET WSP(R_D,BYTES(R_PTYPE>>4&15)>>2) PSF1(CODE,1,R_D) %FINISH %ELSE %START %IF REG#ACCR %AND ACCREG_CL=1 %THEN ACCREG_CL=2 PF1(CODE,0,TOS,0) %FINISH CHANGE RD(REG) BOOTREG_CL=0 %END %ROUTINE COPY DR !*********************************************************************** !* COPY THE DR TO ACC SAVING ANYTHING IN ACC * !*********************************************************************** %IF ACCREG_CL#0 %THEN BOOT OUT(ACCR) PSF1(CYD,0,0) ACCREG_USE=0 %END %ROUTINE CHANGE RD(%INTEGER REG) !*********************************************************************** !* CHANGE A RESULT DESCRIPTOR WHEN OPERAND IS STACKED * !*********************************************************************** %RECORD(REGF)%NAME CREG %RECORD(RD)%NAME OPND %INTEGER ADR IMPABORT %UNLESS 1<=REGS(REG)_CL<=3;! I-R OR PARAM CREG==REGS(REG) OPND==RECORD(CREG_LINK) ADR=ADDR(OPND) %IF CREG_CL=1 %THEN %START; ! CHANGE RESULT DESCRIPTOR %IF REG=DR %AND (OPND_XB=X'72' %OR OPND_XB=X'73') %START OPND_XB=OPND_XB-X'10' %FINISH %ELSE %START IMPABORT %UNLESS OPND_FLAG=9 %AND OPND_XB>>4=REG OPND_XB=TOS<<4 OPND_D=0 %FINISH OPND_FLAG=10; ! CHANGE TO 'STACKED' %FINISH %IF CREG_CL=2 %START %IF REG=DR %AND X'72'<=OPND_XB<=X'73' %THEN %C OPND_XB=OPND_XB-X'50' %ELSE OPND_XB=LNB<<4 OPND_FLAG=10 %FINISH %END %ROUTINE GET IN ACC(%INTEGER REG,SIZE,%RECORD(RD)%NAME OPND) !*********************************************************************** !* LOADS THE REGISTER SPECIFIED ARRANGING FOR AUTOMATIC * !* STACKING WHEN THIS IS NEEDED * !* 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 * !*********************************************************************** %INTEGER OPCODE,ACCESS,AREA,DISP SIZE=1 %IF SIZE=0; ! BITS ABD BYTES! ACCESS=OPND_XB&3 AREA=OPND_XB>>4 IMPABORT %UNLESS REG=ACCR %OR(REG=DR %AND SIZE=8) %OR %C (REG=BREG %AND SIZE<=4) IMPABORT %IF SIZE>4 %AND OPND_XB=X'70' %IF REG=DR %THEN OPCODE=LD %ELSE %START %IF REG=BREG %THEN OPCODE=LB %ELSE OPCODE=LSS+(SIZE>>2)&6 %FINISH %IF ACCESS=3 %OR OPND_XB=X'70' %THEN BREGREG_CL=0 %IF ACCESS=1 %OR (AREA=7 %AND ACCESS>=2) %THEN DRREG_CL=0 %IF REGS(REG)_CL>=1 %THEN %START %IF reg=DR %or REGS(REG)_CL=2 %OR OPND_XB=X'02' %THEN %C BOOT OUT(REG) %ELSE %START; ! CANNOT SLSS ISN ON ALL MCS %IF REG#ACCR %THEN %START %IF ACCREG_CL=3 %THEN BOOT OUT(ACCR) %IF ACCREG_CL=1 %THEN ACCREG_CL=2;! DIVERT TO LOCAL TEMP %FINISH CHANGE RD(REG) REGS(REG)_CL=0 %IF REG=ACCR %THEN OPCODE=OPCODE-32 %ELSE OPCODE=OPCODE-40 %FINISH %FINISH %IF ACCESS>=2 %AND 0#AREA#7 %AND DRREG_CL>0 %THEN %C BOOT OUT(DR) DISP=OPND_D %IF ACCESS>=2 %AND DRREG_USE=2 %AND DISP=DRREG_INF1 %AND AREA=LNB %C %THEN AREA=7 %AND DISP=0 PSORLF1(OPCODE,ACCESS,AREA,OPND_D) %IF ACCESS>=2 %AND 0#AREA#7 %THEN DRREG_USE=0 REGS(REG)_USE=0 %END %ROUTINE DSTORE(%INTEGER REG,SIZE,LEVEL,DISP) !*********************************************************************** !* STORE SIZE(BYTES) FROM DISP(BYTES) IN DISPLAY 'LEVEL' * !*********************************************************************** %INTEGER OPCODE %RECORD(RD)TOPND TOPND_PTYPE=BYTESTOPT(SIZE) TOPND_XB=0 TOPND_FLAG=LOCALIR TOPND_D=LEVEL<<16!DISP OPCODE=STCODE(REG) DEVELOP BD(TOPND) PUT(REG,OPCODE,TOPND) %END %ROUTINE DFETCHAD(%INTEGER REG,LEVEL,DISP) !*********************************************************************** !* FETCH ADDRESS OF DISP(BYTES) IN DISPLAY 'LEVEL' * !*********************************************************************** %INTEGER OPCODE %RECORD(RD)TOPND OPCODE=INCCODE(REG) TOPND_PTYPE=X'51'; TOPND_FLAG=10 TOPND_XB=0 TOPND_D=DISP GET IN ACC(REG,4,TOPND) PSF1(OPCODE,1,PTROFFSET(LEVEL)) REGS(REG)_USE=0 %END %ROUTINE DFETCH(%INTEGER REG,SIZE,LEVEL,DISP) !*********************************************************************** !* FETCH SIZE(BYTES) FROM DISP(BYTES) IN DISPLAY 'LEVEL' * !*********************************************************************** %RECORD(RD)TOPND TOPND=0 TOPND_PTYPE=BYTESTOPT(SIZE) TOPND_FLAG=LOCALIR TOPND_D=LEVEL<<16!DISP DEVELOP BD(TOPND) GET IN ACC(REG,SIZE,TOPND) %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=127; ! 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(%INTEGER KKK) !************************************************************************ !* NOW CLAIM THE STACK FRAME BY SPECIFYING RT DICT ENTRY * !************************************************************************ %INTEGER JJ JJ=CURRINF_SNMAX-CURRINF_DISPLAY-4*CURRINF_RBASE JJ=JJ>>2; ! ASF WORKS IN WORDS LPUT(18,0,CURRINF_SET,JJ) %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 MULTS=0; I=VALUE %IF PTYPE&7=1 %START MULT=IMY %FINISH %ELSE %START MULT=RMY %FINISH %WHILE I>1 %CYCLE %IF I&1#0 %START PF1(ST,0,TOS,0) MULTS=MULTS+1 %FINISH PF1(ST,0,TOS,0) PF1(MULT,0,TOS,0) I=I>>1 %REPEAT %IF MULTS=0 %THEN %RETURN; ! **2,**4 ETC %WHILE MULTS>0 %CYCLE MULTS=MULTS-1 PF1(MULT,0,TOS,0) %REPEAT %END %ROUTINE CIOCP(%INTEGER N,REG) !*********************************************************************** !* COMPILES A CALL ON IOCP ENTRY POINT NO 'N' * !* 2ND (32 BIT) PARAMETER IS ALREAD IN REG * !*********************************************************************** %INTEGER XYNB,OP1,OP2 %CONSTINTEGER NEED RES=X'40016' %IF BREGREG_CL#0 %THEN BOOT OUT(BREG) %IF REG=ACCR %THEN OP1=LUH %AND OP2=ST %C %ELSE OP1=LDTB %AND OP2=STD PSF1(OP1,0,N) PSF1(PRCL,0,4) PF1(OP2,0,TOS,0) XYNB=SET LEVREG(-1,-1); ! TO PLT PSF1(RALN,0,7) PF1(CALL,2,XYNB,KNOWN XREF(4)) REGS(REG)_CL=0 FORGET(-1) %IF 1<0 %THEN INSTRN=INSTRN!((VAL-CA)//2)&X'3FFFF' %ELSESTART LCELL==ASLIST(WORKA_PLINK(N)) J=INSTRN!CA; ! ONLY 18 BITS NEEDED FOR CA %IF LCELL_S3#0 %THEN PUSH(WORKA_PLINK(N),J,0,0) %ELSE %START %IF LCELL_S2=0 %THEN LCELL_S2=J %ELSE LCELL_S3=J %FINISH %FINISH PCONST(INSTRN) FORGET(-1) %IF MASK<=0 %END %ROUTINE PUT(%INTEGER EVALREG, CODE,%RECORD(RD)%NAME OPND) !*********************************************************************** !* THIS ROUTINE PLANTS CODE TO PERFORM THE BASIC * !* OPERATION DEFINED BY OPND & OPCODE * !*********************************************************************** %RECORD(REGF)%NAME REG %INTEGER AREA,ACCESS,DISP DISP=OPND_D AREA=OPND_XB>>4 ACCESS=OPND_XB&3 %IF ACCESS>=2 %START %IF DISP=DRREG_INF1 %AND DRREG_USE=2 %C %AND AREA=LNB %THEN AREA=7 %AND DISP=0 %IF DRREG_CL>0 %AND 0#AREA#7 %THEN BOOT OUT(DR) DRREG_USE=0 %UNLESS AREA=7; ! DR WILL BE LOADED %FINISH PSORLF1(CODE,ACCESS,AREA,DISP) %IF EVALREG#BREG %AND ((ACCESS=0 %AND AREA=7) %OR ACCESS=3) %C %THEN BREGREG_CL=0 %IF AREA=1 %OR (AREA=7 %AND ACCESS>=2) %THEN DRREG_CL=0 REG==REGS(EVALREG) %IF CODE=IAD %AND REG_USE=9 %AND OPND_XB=0 %C %AND DISP<4095 %AND REG_INF1>>16=0 %THEN %START REG_USE=10 REG_INF1=REG_INF1&X'FFFF'!DISP<<16 %FINISH %ELSE %START REG_USE=0 %UNLESS CODE=ICP %OR CODE=RCP %OR CODE=ST %OR CODE=STB %FINISH REG_LINK=ADDR(CURRT_OPND1); ! OPND1 IS ALWAYS THE TRIPLE RESULT %END %ROUTINE NOTE ASSMENT(%INTEGER REG, ASSOP, VAR) !*********************************************************************** !* 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 = %CONSTINTEGER NREGS=5 %RECORD(REGF)%NAME WREG %CONSTINTEGER RELREGS=16*16*16*16*CTB+16*16*16*XNB+16*16*ACCR+16*BREG+DR %INTEGER I,II %RETURN %IF VAR<=0 %IF ASSOP=1 %THEN %START %CYCLE I=0,1,7 WREG==REGS(I) %IF EEMASK&1<>16=VAR) %THEN WREG_SECUSE=0 %IF EEMASK&1<>16=VAR) %THEN WREG_USE=WREG_SECUSE %AND %C WREG_INF1=WREG_INF2 %REPEAT WREG==REGS(REG) WREG_USE=7 WREG_INF1=VAR %FINISH %ELSE %START %CYCLE II=0,4,4*(NREGS-1) I=RELREGS>>II&15 WREG==REGS(I) %IF EMASK&1<>16=VAR %OR WREG_INF2=VAR) %THEN WREG_SECUSE=0 %IF EMASK&1<>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 %START WREG==REGS(REG) %IF 5<=WREG_PRIMUSE&255<=6 %START; ! ASSIGN CONST TO VAR WREG_SECUSE=9 WREG_INF2=VAR %FINISH %ELSE %START; ! ASSIGN VAR OR EXP TO VAR WREG_SECUSE=WREG_PRIMUSE WREG_PRIMUSE=9 WREG_INF2=WREG_INF1; ! PREVIOUS USE BECOMES 2NDRY WREG_INF1=VAR %FINISH %FINISH %FINISH %END %END; ! OF ROUTINE GENERATE %ENDOFFILE