! ! 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'F0' ! %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; ! %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,PPCURR,GLACURR %OWNINTEGERNAME ASL %OWNRECORD(LISTF)%ARRAYNAME ASLIST %OWNBYTEINTEGERARRAYNAME CODE,GLABUF %OWNINTEGERARRAYNAME CTABLE %EXTRINSICRECORD(CODEPF) CODEP %EXTRINSICRECORD(WORKAF)WORKA %EXTRINSICRECORD(PARMF) PARM %OWNRECORD(REGF)%ARRAY REGS(0:7) %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) %EXTERNALROUTINESPEC FAULT(%INTEGER I,J,K) %ROUTINESPEC PF1(%INTEGER OPCODE,A,B,N) %ROUTINESPEC PRINT USE %ROUTINESPEC 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) %ROUTINESPEC POP(%INTEGERNAME A,B,C,D) %ROUTINESPEC PRHEX(%INTEGER VALUE,PLACES) %CONSTINTEGER CODEBNDRY=X'1FF'; ! INSTRUCTIONS MUST NOT ! CROSS THIS IN ACCENT MODE %CONSTINTEGER YES=1,NO=0 %CONSTINTEGER EMAS=10 %CONSTINTEGER PERQ=11 %CONSTINTEGER PNX=12 %CONSTINTEGER HOST=EMAS %CONSTINTEGER TARGET=EMAS %CONSTINTEGER USE IMP=YES %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'; %CONSTINTEGER DAREA=4; ! AREA FOR DIAG TABLES %CONSTSTRING(8)MDEP="S#NDIAG" ! ! 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 * !************************************************************************ LPUT(0,0,0,0); ! OPEN OBJECT FILE %END %ROUTINE RECODE(%INTEGER S,F,AD) %IF S#F %START PRINTSTRING(" CODE FOR LINE"); WRITE(WORKA_LINE,5) 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 ! ABORT %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 ! ABORT %UNLESS 0<=KP<=3 %AND 0<=KPP<=7 %AND OPCODE&1=0 INC=2 %IF KP=0=KPP %AND IMOD(N)>X'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 IMOD(N)>X'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 * !*********************************************************************** ! ABORT %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 * !*********************************************************************** ! ABORT %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 PARAM DES(%INTEGER PREC) !*********************************************************************** !* SET UP BNDED L=1 DESRIPTOR FOR PASSING VARIABLE BY REFERENCE * !* ONLY THE TOP HALF IS SET UP * !*********************************************************************** %INTEGER K,DES K=DESADS(PREC) %RESULT=K %UNLESS K=0 %IF PREC=4 %THEN DES=X'58000002' %ELSE DES=PREC<<27!1 K=WORD CONST(DES) DESADS(PREC)=K %RESULT=K %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 %IF PREC=4 %THEN DES0=X'58000002' %ELSE DES0=X'03000000'!PREC<<27 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 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 %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 %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 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 %EXTERNALROUTINE 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 * !* L MAY BE REPETITION<<16! BASIC LENGTH * !*********************************************************************** %INTEGERNAME PTR PTR==CODEP_CAS(AREA) PTR=(PTR+BNDRY-1)&(-BNDRY) LPUT(AREA,L,PTR,AD) %IF PARM_INHCODE=0 %IF L>>16#0 %THEN PTR=PTR+(L>>16)*(L&X'FFFF') %ELSE PTR=PTR+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 %EXTERNALROUTINE 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,CODEP_CAS(DAREA)) %FINISH %ELSE %START PLUG(Q,JJ,KK!CODEP_CAS(DAREA),4) %FINISH %REPEAT %END %EXTERNALROUTINE 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 STATIC CODE XREF * !* MODE=1 DYNAMIC CODE XREF * !* MODE=2 DATA XREF XTRA=MINIMIUM LENGTH (SINGLE WORD ONLY) * !*********************************************************************** %INTEGER LPUTNO %IF MODE=2 %THEN LPUTNO=15 %ELSE LPUTNO=MODE+12 LPUT(LPUTNO,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 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 * !* ETOS-2,ETOS-3 TO ETOS,ETOS-1 * !* IF MODE =0 SET L BYTES TO D2(0 OR X'80') * !* * !* L MAY BE GREATER THAN 4095 * !*********************************************************************** %INTEGER W2 %IF MODE=0 %START; ! CLEAR %FINISH %END; ! OF ROUTINE BULK M %ROUTINE ADJUSTSF(%INTEGER C) !************************************************************************ !* ADVANCE OR RETRACT TOP POINTER BY C * !************************************************************************ PSF1(ASF,0,C) %END %ROUTINE STACKDUMP(%INTEGER WORDS) !*********************************************************************** !* DUMP WORDS FROM ESTACK TO MSTACK AVOIDING REVERSING * !* THE ORDER. VALID FOR 1,2,3 OR 4 WORDS ONLY * !*********************************************************************** %END %ROUTINE STACKUNDUMP(%INTEGER WORDS) !*********************************************************************** !* REVERSES THE ABOVE * !*********************************************************************** %END %ROUTINE DUPLICATE(%INTEGER WORDS) !*********************************************************************** !* REPLCATES 1,2 OR 4 WORDS IN THE ESTACK. WRITTEN TO AVOID * !* THE ABSENCE OF REPL4 INSTRUCTIO * !************************************************************************ %END %ROUTINE SMALLEXP(%INTEGER TYPE,VALUE) !************************************************************************ !* TYPE=1 FOR INTEGER =2 FOR REALS * !* VALUE = 2,3 OR 4. VALUE=1 HAS BEEN OPTIMISED OUT * !*********************************************************************** %INTEGER ESC %SWITCH SW(5:11) %IF TYPE=1 %THEN ESC=IMY %ELSE ESC=RMY ->SW(3*TYPE+VALUE) SW(7): ! 32BIT****4 SW(10): ! 32BIT**4 PF1(ST,0,TOS,0) PF1(ESC,0,TOS,0) SW(5): ! 32BIT****2 SW(8): ! 32BIT**2 PF1(ST,0,TOS,0) PF1(ESC,0,TOS,0) %RETURN SW(6): ! 32BIT****3 SW(9): ! 32BIT**3 PF1(ST,0,TOS,0) PF1(ST,0,TOS,0) PF1(ESC,0,TOS,0) PF1(ESC,0,TOS,0) %RETURN %END %EXTERNALROUTINE RELOCATE(%INTEGER BITS,GLARAD,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 %IF BITS=16 %THEN QP=20 %ELSE QP=19 LPUT(QP,2,GLARAD,AREA) %END %EXTERNALROUTINE DEFINE EP(%STRING(255)NAME, %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!) * !*********************************************************************** %IF AREA=1 %START; ! CODE ENTRIES LPUT(11,MAINORMIN<<31!2,AT,ADDR(NAME)) %FINISH %ELSE %START LPUT(14,AREA<<24!MAINORMIN,AT,ADDR(NAME)) %FINISH %END %EXTERNALROUTINE PRHEX(%INTEGER VALUE, PLACES) %CONSTBYTEINTEGERARRAY HEX(0:15)='0','1','2','3','4', '5','6','7','8','9','A','B','C','D','E','F' %INTEGER I %CYCLE I=PLACES<<2-4, -4, 0 PRINT SYMBOL(HEX(VALUE>>I&15)) %REPEAT %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 RES "," 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'1100011110000000' %CONSTINTEGER UNMASK=B'0100001110000000' 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 ABORT PRINTSTRING(" **************** ABORT******************** ABORT *******") RECODE(ADDR(CODE(0)), ADDR(CODE(PPCURR)), CABUF) %C %UNLESS CA=CABUF %MONITOR %STOP %END %EXTERNALROUTINE PROLOGUE !*********************************************************************** !* 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 CA==CODEP_CAS(1) GLACA==CODEP_CAS(2) GLACA=FIXEDGLALEN GLACABUF=FIXEDGLALEN CODE==CODEP_CODE GLABUF==CODEP_GLABUF PPCURR==CODEP_CACURR(1) GLACURR==CODEP_CACURR(2) CONST HOLE=0; CREFHEAD=0 CDCOUNT=0 CTABLE==WORKA_CTABLE I=X'C2C2C2C2' LPUT(0+DAREA,4,0,ADDR(I)) CODEP_CAS(DAREA)=4 %CYCLE I=0, 1, 31 DESADS(I)=0 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. CHECKING MODE ONLY. MUST MOVE ONLY ! CURRENT LENGTH INTO MAPPED STRINGS BUT MUST NOT OMIT THE CAPACITY ! CHECK. ACC & DR SET FOR MV ! ! ST TOS SAVE ACC DESRPTR ! AND X'1FF00000000' GET CURRENT LENGTH ! STUH B INTO BREG ! LSD TOS RESTORE ACC ! STD TOS SAVE DR DESCRPTR ! SBB 1 ! JAF 13,*+3 ! MODD B PROVOKE FAILURE IF RELEVANT ! ADB 1 ! LD TOS ! LDB B BOUND=CURRENT L +1(FOR LBYTE) ! J TOS ! %IF WORKA_PLINK(18)=0 %THEN ->P19 CNOP(0,8) D=CA PCONST(511) PCONST(0); ! XFF00000000 FILL(18) PF1(ST,0,TOS,0) PF1(AND,0,PC,D) PF1(STUH,0,BREG,0) PF1(LSD,0,TOS,0) PF1(STD,0,TOS,0) PSF1(SBB,0,1) PF3(JAF,13,0,3) PF1(MODD,0,BREG,0) PSF1(ADB,0,1) PF1(LD,0,TOS,0) PF1(LDB,0,BREG,0) PF1(JUNC,0,TOS,0) P19: ! CONCATENATION ONE ! COPY THE FIRST STRING INTO THE WORK AREA ! B HAS REL DISP OF THE WORK AREA FROM LNB ! DR HAS CURRENT LENGTH DESCRIPTOR OF FIRST STRING ! RESULT IS A CURRENT LENGTH DESCRIPTOR TO WORK AREA IN DR AND ACC ! ! STLN TOS ! ADB TOS ! LXN B XNB TO WORK AREA ! SLB @DR CURRENT LENGTH TO B ! STB (%XNB+2) INTO LENGTH BYTE OF WK AREA ! INCA 1 DR PAST LENGTH BYTE ! CYD 0 BECOMES SOURCE STRING ! LD =X'180000FF0000000C' ! INCA TOS DESCRIPTOR TO WK STRING ! STD (%XNB+0) STORED FOR LATER ! LDB B ADJUSTED SO NO FILLING ! MV L=DR THE MOVE ! LD (%XNB+0) SET UP DR WITH RESULT ! LDB B CURRENT LENGTH AS BOUND ! INCA -1 TO POINT AT LENGTH BYTE ! CYD 0 TO ACC AS WELL ! J TOS RETURN %IF WORKA_PLINK(19)!WORKA_PLINK(20)=0 %THEN ->P21 CNOP(0,8); ! DOUBLE WORD ALLIGN D=CA PCONST(X'180000FF'); PCONST(12) FILL(19) PF1(STLN,0,TOS,0) PF1(ADB,0,TOS,0) PF1(LXN,0,BREG,0) PF1(SLB,2,7,0) PF1(STB,0,XNB,8) PSF1(INCA,0,1) PSF1(CYD,0,0) PF1(LD,0,PC,D) PF1(INCA,0,TOS,0) PF1(STD,0,XNB,0) PF1(LDB,0,BREG,0) PF2(MV,1,0,0,0,0) PF1(LD,0,XNB,0) PF1(LDB,0,BREG,0) PSF1(INCA,0,-1) PSF1(CYD,0,0) PF1(JUNC,0,TOS,0) ! ! CONCATENATION TWO ! ADD THE SECOND AND SUBSEQUENT STRINGS TO THE FIRST ! PARAMETERS AND RESULTS AS CONCATENATION ONE ! ! STLN TOS ! ADB TOS ! LXN B XNB TO WORK AREA ! LB @DR CURRENT LENGTH TO B ! STB TOS KEEP FOR THE MOVE ! ADB (%XNB+2) ADD OLD LENGTH ! INCA 1 PAST LENGTH BYTE ! CYD 0 BECOMES SOURCE STRING ! LD (%XNB+0) GET DESCRIPTOR TO WK STRING ! MODD (%XNB+2) MOVE ON PAST FIRST STRING ! LDB TOS TO MOVE RIGHT AMOUNT ! MV L=DR ! STB (%XNB+2) UP DATE WK STRING LENGTH ! CPB 255 ! JCC 2,CAPACITY EXCEEDED ! LD (%XNB+0) SET UP DR WITH RESULT ! LDB B CURRENT LENGTH AS BOUND ! INCA -1 TO POINT AT LENGTH BYTE ! CYD 0 TO ACC AS WELL ! J TOS RETURN %IF WORKA_PLINK(20)=0 %THEN ->P21 FILL(20) PF1(STLN,0,TOS,0) PF1(ADB,0,TOS,0) PF1(LXN,0,BREG,0) PF1(LB,2,7,0) PF1(STB,0,TOS,0) PF1(ADB,0,XNB,8) PSF1(INCA,0,1) PSF1(CYD,0,0) PF1(LD,0,XNB,0) PF1(MODD,0,XNB,8) PF1(LDB,0,TOS,0) PF2(MV,1,0,0,0,0) PF1(STB,0,XNB,8) PF1(CPB,0,0,255) PF3(JCC,2,0,(WORKA_PLABS(9)-CA)//2) PF1(LD,0,XNB,0) PF1(LDB,0,BREG,0) PSF1(INCA,0,-1) PSF1(CYD,0,0) PF1(JUNC,0,TOS,0) 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=1 LANGFLAG=LANGFLAG<<24 PARMS=(PARM_DIAG<<1!PARM_LINE)<<1!PARM_TRACE FIXED GLA(4)=LANGFLAG!WORKA_RELEASE<<16!(PARM_CPRMODE&1)<<8!PARMS;! LANG RLSE & MAINPROG I=GLACA-GLACABUF %IF PARM_INHCODE=0 %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, CODEP_CAS(DAREA), ADDR(I)) CODEP_CAS(DAREA)=CODEP_CAS(DAREA)+4 %FINISH %CYCLE I=1,1,6 CODEP_CAS(I)=(CODEP_CAS(I)+7)&(-8) %REPEAT PRINTSTRING(" CODE") WRITE(CA, 6) PRINTSTRING(" BYTES GLAP") WRITE(GLACA, 3); PRINTSTRING("+") WRITE(CODEP_CAS(5), 1); PRINTSTRING(" BYTES DIAG TABLES") WRITE(CODEP_CAS(DAREA), 3); PRINTSTRING(" BYTES TOTAL") K=CA+GLACA+CODEP_CAS(4)+CODEP_CAS(5)+CODEP_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 CODEP_CACURR(0)=K; ! SERVES AS CAS(7) %IF PARM_INHCODE=0 %THEN LPUT(7, 28, 0, ADDR(CODEP_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 DCOMP#0 %START PRINTSTRING(" CONSTANT TABLE") I=BASE %CYCLE NEWLINE PRHEX(CA+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>95 %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 LPUT(18,0,VAL,DISP) %ELSE %START I=(VAL>>16&X'7FFF')<<2; ! GLA BYTE ADDRESS J=4*(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 PRINT THIS TRIP(%RECORD(TRIPF)%ARRAYNAME TRIPS, %INTEGER I) !*********************************************************************** !* OUTPUTS A TRIPLE IN READABLE FORM * !*********************************************************************** %CONST%STRING(5)%ARRAY OPERATION(0:190)= %C " ? ","RT HD","RDSPY","RDARE","RDPTR", "RTBAD","RTXIT","XSTOP"," ? "," ? ", " \ "," -U "," FLT "," ABS ","SHRNK", "STRCH"," JAM "," ??? ","NO OP","PRELD", " ? ","SSPTR","RSPTR","ASPTR","DARRY", "SLINE","STPCK","FRPRE","FPOST","FRPR2", "PRECL","RCALL","RCRFR","RCRMR"," ? ", "GETAD"," INT ","INTPT","TOSTR","MNITR", "PPROF","RTFP ","ONEV1","ONEV2"," ? "(6), "UCNOP","UCB1 ","UCB2 ","UCB3 ","UCB4 ", "UCBW ","UCWW ","UCLW ","UCB2W","UCNAM", " ? "(68), " + "," - "," !! "," ! "," * ", " // "," / "," & "," >> "," << ", " ** "," COMP","DCOMP"," VMY "," COMB", " = "," <- "," ****"," ADJ "," INDX", "IFTCH","LASS ","FORCK","PRECC","CNCAT", "IOCPC","PASS1","PASS2","PASS3", "PASS4"," ? "(2), "BJUMP","FJUMP","REMLB","TLAB ","DCLSW", "SETSW","-> SW"," S=1 "," S=2 "," S<- ", "AHASS","PTRAS","MAPRS","FNRES","SCOMP", "SDCMP","PRES1","PRES2","RESLN","RESFN", "SIGEV","RECAS","AAINC","AHADJ","CTGEN", "GETPR", " ? "(*); %RECORD(TRIPF)%NAME CURR %ROUTINESPEC OPOUT(%RECORD(RD)%NAME OPND) NEWLINE CURR==TRIPS(I) WRITE(I,2) SPACE PRINTSTRING(OPERATION(CURR_OPERN)) SPACE PRHEX(CURR_OPTYPE,2) WRITE(CURR_CNT,2) WRITE(CURR_DPTH,2) SPACES(1) PRHEX(CURR_FLAGS,4) WRITE(CURR_PUSE,3) SPACE PRHEX(CURR_X1,8) SPACE OPOUT(CURR_OPND1) OPOUT(CURR_OPND2) %IF CURR_OPERN>=128 %RETURN %ROUTINE OPOUT(%RECORD(RD)%NAME OPND) %STRING(17)T %STRING(12)S %INTEGER I %SWITCH SW(0:10) PRHEX(OPND_PTYPE,4) ->SW(OPND_FLAG) SW(0):SW(1): ! COCNSTANT PRINTSTRING(" ") %IF OPND_PTYPE&7=5 %START; ! STRING CONSTS %CYCLE I=0,1,17 BYTEINTEGER(ADDR(T)+I)=WORKA_A(OPND_D+I) %REPEAT T<-T." " PRINTSTRING(T) %FINISH %ELSE %START PRHEX(OPND_D,8) SPACE %IF OPND_PTYPE>>4>5 %THEN PRHEX(OPND_XTRA,8) %ELSE SPACES(8) %FINISH SPACES(2) %RETURN SW(2): ! NAME PRINTSTRING(" NAME ") NAM: S<-PRINTNAME(OPND_D)." " PRINTSTRING(S) %IF OPND_XTRA#0 %THEN PRINTSTRING("+ ") %ELSE SPACES(2) %RETURN SW(5): ! 32 BIT ADDRESS PRINTSTRING(" ADDR ") ->NAM SW(7): ! IN A STACK FRAME PRINTSTRING(" VAR/TEMP ") PRHEX(OPND_D,8) SPACES(2) %RETURN SW(6): ! INDIRECT PRINTSTRING("INDIRECT-OFFSET") WRITE(OPND_D,2) SPACES(2) %RETURN SW(8): ! A TRIPLE PRINTSTRING(" TRIP ") WRITE(OPND_D,2) PRINTSTRING(" (") PRHEX(TRIPS(OPND_D)_OPND1_S1,8) PRINTSTRING(")") %RETURN SW(9): ! REGISTER ITEM PRINTSTRING(" ITEM IN ESTACK ") SPACES(4) %RETURN SW(10): ! B-D FORFM PRINTSTRING("BASE&DIS ") PRHEX(OPND_XB,2) SPACE PRHEX(OPND_D,8) %END %END %EXTERNALROUTINE PRINT TRIPS(%RECORD(TRIPF)%ARRAYNAME TRIPS) %INTEGER I PRINTSTRING(" TRIPLES FOR LINE"); WRITE(WORKA_LINE,3) PRINTSTRING(" NO OPRN PT C D FLGS PUSE X1 OPERAND 1 OPERAND 2") I=TRIPS(0)_FLINK %WHILE I>0 %CYCLE PRINT THIS TRIP(TRIPS,I) I=TRIPS(I)_FLINK %REPEAT %END %EXTERNALROUTINE INITASL(%RECORD(LISTF)%ARRAYNAME SPACE,%INTEGERNAME PTR) !*********************************************************************** !* INITIALISES THE ASL AND REMEMBERS IT LOCATION !*********************************************************************** %INTEGER I ASLIST==SPACE ASL==PTR WORKA_ASL CUR BTM=ASL-240 WORKA_CONST LIMIT=4*WORKA_ASL CUR BTM-8 %CYCLE I=WORKA_ASL CUR BTM,1,ASL-1 ASLIST(I+1)_LINK=I %REPEAT ASLIST(WORKA_ASL CUR BTM)_LINK=0 ASLIST(0)_S1=-1 ASLIST(0)_S2=-1 ASLIST(0)_S3=-1 ASLIST(0)_LINK=0 %END %EXTERNALROUTINE PRINT LIST(%INTEGER HEAD) !*********************************************************************** !* A DEBUGGING ONLY ROUTINE. !*********************************************************************** %RECORD(LISTF)%NAME LCELL %INTEGER I,J,K PRINTSTRING(" PRINT OF LIST ") WRITE(HEAD,2) NEWLINE %WHILE HEAD#0 %CYCLE LCELL==ASLIST(HEAD) WRITE(HEAD,3) SPACES(3) PRHEX(LCELL_S1,8) SPACES(3) PRHEX(LCELL_S2,8) SPACES(3) PRHEX(LCELL_S3,8) NEWLINE HEAD=LCELL_LINK&X'FFFF'; ! EXTRA LINK IN TAGS LIST!! %REPEAT %END %EXTERNALROUTINE CHECK ASL !*********************************************************************** !* CHECK ASL AND PRINT NO OF FREE CELLS. DEBUGGING SERVICE ONLY * !*********************************************************************** %INTEGER N,Q Q=ASL; N=0 %WHILE Q#0 %CYCLE N=N+1 Q=ASLIST(Q)_LINK %REPEAT NEWLINE PRINTSTRING("FREE CELLS AFTER LINE ") WRITE(WORKA_LINE,3) PRINTSYMBOL('=') WRITE(N,3) %END %EXTERNALINTEGERFN MORE SPACE !*********************************************************************** !* FORMATS UP SOME MORE OF THE ASL * !*********************************************************************** %INTEGER I,N,CL,AMOUNT N=WORKA_ASL CUR BTM-1 AMOUNT=(WORKA_NNAMES+1)>>3; ! EIGHTTH OF NNAMES I=WORKA_ASL CUR BTM-((WORKA_CONST PTR+8)>>2);! GAP BETWEEN CONSTS &ASL %IF I>>1>1;! TAKE ONLY HALF THE REMAINDER %IF AMOUNT<20 %THEN AMOUNT=0 WORKA_ASL CUR BTM=WORKA_ASL CUR BTM-AMOUNT %IF WORKA_ASL CUR BTM<=1 %THEN WORKA_ASL CUR BTM=1 CL=4*WORKA_ASL CUR BTM-8 %IF WORKA_ASL CUR BTM>=N %OR WORKA_CONST PTR>CL %THEN %START FAULT(102, WORKA_WKFILEK,0) %FINISH %ELSE WORKA_CONST LIMIT=CL; ! NEW VALUE WITH BIGGER ASL %CYCLE I=WORKA_ASL CUR BTM,1,N-1 ASLIST(I+1)_LINK=I %REPEAT ASLIST(WORKA_ASL CUR BTM)_LINK=0 ASL=N; %RESULT=N %END !%EXTERNALINTEGERFN NEW CELL !*********************************************************************** !* PROVIDE A NEW LIST PROCESSING CELL. CRAPOUT IF NONE AVAILABLE * !*********************************************************************** !%INTEGER I ! %IF ASL=0 %THEN ASL=MORE SPACE ! I=ASL ! ASL=ASLIST(ASL)_LINK ! ASLIST(I)_LINK=0 ! %RESULT =I !%END %EXTERNALROUTINE PUSH(%INTEGERNAME CELL, %INTEGER S1, S2, S3) !*********************************************************************** !* PUSH A CELL CONTAINING THE 3 STREAMS OF INFORMATION GIVEN * !* ONTO THE TOP OF THE LIST POINTED AT BY CELL. * !*********************************************************************** %RECORD(LISTF)%NAME LCELL %INTEGER I I=ASL %IF I=0 %THEN I=MORE SPACE LCELL==ASLIST(I) ASL=LCELL_LINK LCELL_LINK=CELL CELL=I LCELL_S1=S1 LCELL_S2=S2 LCELL_S3=S3 %END %EXTERNALROUTINE POP(%INTEGERNAME CELL, S1, S2, S3) !*********************************************************************** !* COPY THE INFORMATION FROM THE TOP CELL OF LIST 'CELL' INTO * !* S1,S2&S3 AND THEN POP THE LIST UP 1 CELL. EMPTYLIST GIVE -1S* !*********************************************************************** %INTEGER I %RECORD(LISTF)%NAME LCELL I=CELL LCELL==ASLIST(I) S1=LCELL_S1 S2=LCELL_S2 S3=LCELL_S3 %IF I# 0 %THEN %START CELL=LCELL_LINK LCELL_LINK=ASL ASL=I %FINISH %END %EXTERNALROUTINE BINSERT(%INTEGERNAME TOP,BOT,%INTEGER S1,S2,S3) !*********************************************************************** !* INSERT A CELL AT THE BOTTOM OF A LIST * !* UPDATING TOP AND BOTTOM POINTERS APPROPIATELY * !*********************************************************************** %INTEGER I,J %RECORD(LISTF)%NAME LCELL I=ASL %IF I=0 %THEN I=MORE SPACE LCELL==ASLIST(I) ASL=LCELL_LINK LCELL_S1=S1; LCELL_S2=S2 LCELL_S3=S3; LCELL_LINK=0 J=BOT %IF J=0 %THEN BOT=I %AND TOP=BOT %ELSE %START ASLIST(J)_LINK=I BOT=I %FINISH %END %EXTERNALROUTINE INSERT AFTER(%INTEGERNAME PLACE,%INTEGER S1,S2,S3) !*********************************************************************** !* ADDS A CELL INT THE MIDDLE OF A LIST AFTER "CELL" WHICH * !* IS UPDATED * !*********************************************************************** %INTEGER I %RECORD(LISTF)%NAME OLDCELL,CELL FAULT(109,0,0) %IF PLACE<=0 I=ASL %IF I=0 %THEN I=MORE SPACE CELL==ASLIST(I) ASL=CELL_LINK OLDCELL==ASLIST(PLACE) CELL_S1=S1; CELL_S2=S2 CELL_S3=S3 CELL_LINK=OLDCELL_LINK OLDCELL_LINK=I PLACE=I %END %EXTERNALROUTINE INSERT AT END(%INTEGERNAME CELL, %INTEGER S1, S2, S3) !*********************************************************************** !* ADD A CELL TO THE BOTTOM OF THE LIST HEADED BY 'CELL' * !*********************************************************************** %INTEGER I,J,N %RECORD(LISTF)%NAME LCELL I=CELL; J=I %WHILE I#0 %CYCLE J=I I=ASLIST(J)_LINK %REPEAT N=ASL %IF N=0 %THEN N=MORE SPACE LCELL==ASLIST(N) ASL=LCELL_LINK %IF J=0 %THEN CELL=N %ELSE ASLIST(J)_LINK=N LCELL_S1=S1 LCELL_S2=S2 LCELL_S3=S3 LCELL_LINK=0 %END %EXTERNALINTEGERFN FIND(%INTEGER LAB, LIST) !*********************************************************************** !* THIS FUNCTION SEARCHES LIST 'LIST' FOR LAB IN STREAM2 AND * !* RETURNS THE CORRESPONDING CELL NO.IT USED FOR MORE THAN * !* SCANNING LABEL LISTS. * !*********************************************************************** %WHILE LIST#0 %CYCLE %RESULT=LIST %IF LAB=ASLIST(LIST)_S2 LIST=ASLIST(LIST)_LINK %REPEAT %RESULT=-1 %END %EXTERNALROUTINE CLEAR LIST(%INTEGERNAME OPHEAD) !*********************************************************************** !* THROW AWAY A COMPLETE LIST (MAY BE NULL!) * !*********************************************************************** %INTEGER I, J I=OPHEAD; J=I %WHILE I#0 %CYCLE J=I I=ASLIST(J)_LINK %REPEAT %IF J#0 %START ASLIST(J)_LINK=ASL ASL=OPHEAD; OPHEAD=0 %FINISH %END !%EXTERNALROUTINE CONCAT(%INTEGERNAME LIST1, LIST2) !!*********************************************************************** !!* ADDS LIST2 TO BOTTOM OF LIST1 * !!*********************************************************************** !%INTEGER I,J ! I=LIST1 ! J=I ! %WHILE I#0 %THEN J=I %AND I=ASLIST(J)_LINK ! %IF J=0 %THEN LIST1=LIST2 %ELSE ASLIST(J)_LINK=LIST2 ! LIST2=0 !%END; ! AN ERROR PUTS CELL TWICE ONTO ! FREE LIST - CATASTROPHIC! %EXTERNALROUTINE GENERATE(%RECORD(TRIPF) %ARRAYNAME TRIPLES, %RECORD(LEVELF) %NAME CURRINF, %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 SAVE IRS %INTEGERFNSPEC XORYNB(%INTEGER USE,INF) %INTEGERFNSPEC PTROFFSET(%INTEGER RLEV) %ROUTINESPEC DEVELOP BD(%RECORD(RD)%NAME OPND) %ROUTINESPEC PPJ(%INTEGER MASK,N) %INTEGERFNSPEC JCODE(%INTEGER TFMASK) %ROUTINESPEC VMULTIPLY %ROUTINESPEC REXP %ROUTINESPEC STARSTAR %ROUTINESPEC CEND(%INTEGER KKK) %INTEGERFNSPEC REACHABLE(%INTEGER LAB,LINK) %ROUTINESPEC LOAD(%RECORD(RD) %NAME OP,%INTEGER REG,MODE) %ROUTINESPEC LOADAD(%RECORD(RD) %NAME OPND) %ROUTINESPEC LOADPTR(%RECORD(RD) %NAME OPND,OPND2) %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 SEGNO,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 %RECORD(TAGF) %NAME TCELL %RECORD(LISTF) %NAME LCELL ! %INTEGER C,D,WTRIPNO,JJ,COMM,XTRA,PT,BFFLAG,TRIPINF,TRIPVAL,PTYPE,TYPE,PREC, STPTR,DPTYPE,DACC,L0,B1,B2,B3,EVALREG,LASTPARREG %REAL CV1 %LONGREAL CV2 ! ! TRIPDATA GIVES INFORMATION ON TRIPLE ! TOP 4 BITS HAVE TYPE ! NEXT 12 BITS HAVE FLAGS:- ! 2**16 SET IF COMMUTATIVE ! 2**17 SET DONT LOAD OPERAND2 ! 2**18 SET DONT LOAD OPERAND1 ! 2**19 DONT SWOP NON COMMUTABLE OPERANDS ! NEXT 8 BITS HAVE MAX CODE PLANTED IN BYTES NOT INCLUDING ANY CONSTANSTS ! OR STRINGS WHICH MAY HAVE TO GO INLINE ! BOTTOM 8 BITS HAVE A POINTER OR VALUE ! TYPE 0 TRIPLES ARE IGNORED ! TYPE 1 TRIPLES VALUE HAS INDEX INTO SWITCH "TRIPSW" ! TYPE 2 TRIPLES VALUE HAS POINTER TO ISEQS ! %CONSTINTEGERARRAY TRIPDATA(0:199)=0, X'1000070F'{RTHD ROUTINE/BKK HDR}, X'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'20000413'{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'10000301'{25 UPDATE LINE NO}, X'10000906'{26 CHECK ZERO FOR STEP}, X'10000307'{27 FOR PREAMBLE}, X'10000208'{28 FOR POSTAMBLE}, X'1000010E'{29 FOR SECOND PREAMBLE}, X'10000218'{30 PRECALL}, X'10000519'{31 ROUTINE CALL}, X'1000021A'{32 RECOVER FN RESULT}, X'1000021B'{33 RECOVER MAP RESULT}, X'00000000'{34 NOT CURRENTLY USED}, X'1000081D'{35 GETAD GET 32BIT ADDREESS}, X'10000424'{36 RTOI1 INT FN}, X'10000C25'{37 RTOI2 INTPT FN}, X'10000B26'{38 STOI1 TOSTRING FN}, X'1000093D'{39 MNITR FOR %MONITOR}, X'00000000'{40 PPROF PRINT PROFILE IGNORED}, X'1000053F'{41 RTFP TURN RTNAME TO FORMAL}, X'00000000'{42 ON EVENT1 NO CODE AS YET}, X'00000000'{43 ON EVENT2 NO CODE AS YET}, 0(6), 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'20000E1E'{138 **}, X'2001041F'{139 COMP}, X'20010420'{140 DCOMP}, X'20060A21'{141 VMY}, X'20010422'{142 COMB}, X'200E0623'{143 ASSIGN=}, X'200E0624'{144 ASSIGN<-}, X'20020E25'{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'10000B15'{151 PRE CONCAT}, X'10000A16'{152 COCNCATENEATION}, X'10000C17'{153 IOCP CALL}, X'10000C1C'{154 PARAMETER ASSIGNMENT 1 NORMAL VALUES}, X'1000041F'{155 PARAM ASSNG 2 NORMAL PTRS}, X'10000220'{156 PARAM ASSGN 3 ARRAYS}, X'10000220'{157 ASSGN FORMAL RT-CODE AS 156}, X'10000220'{158 PASS5 TYPE GENERAL NAME}, 0, X'1000030A'{160 BACK JUMP}, X'1000030B'{161 FORWARD JUMP}, X'1000000C'{162 REMOVE LAB}, X'1000000D'{163 ENTER LABEL}, X'1000FF21'{164 DECLARE SWITCH}, X'10000022'{165 SET SWITCH LABEL TO CA}, X'10000523'{166 GOTO SWITCH LABEL}, X'10000D27'{167 STRING ASS1 GENERAL}, X'10001128'{168 STRING ASS 2 L KNOWN}, X'10000D29'{169 STRING JAM TRANSFER}, X'10000C2A'{170 ARRAY HEAD ASSIGNMENT}, X'10000C2B'{171 PTR ASSIGNMENT}, X'1000052C'{172 MAP RESULT ASSIGNMENT}, X'1000052D'{173 FN RESULT ASSIGNMENT}, X'10000C2E'{174 STRING COMPARISON}, X'10000C2E'{175 STRING DSIDED COMPARISON}, X'10000C2F'{176 PRE RESOLUTION 1}, X'10001230'{177 PRE RESOLUTION 2}, X'10000B31'{178 RESOLUTION PROPER}, X'1000233C'{179 RESOLUTION FINISH ASSN FRAGMNT}, X'00000000'{180 SIGEV SIGNAL EVENT NOT IMPLEMENTED}, X'10000A3E'{181 RECASS WHOLE RECORD ASSIGNMENT}, X'10000A40'{182 ARRAY ADDR INC}, X'10000A41'{183 AHADJ FOR ARRAY MAPPING}, X'10000A42'{184 CREATE TYPE GENERAL PARAMETER}, X'1000081E'{185 GET POINTER FOR PASSING BY NAME}, 0(*) %CONSTHALFINTEGERARRAY STOREINF(3:6)= 0(*) %CONSTBYTEINTEGERARRAY FCOMP(0:31)=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); ! ! 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 ! %CONSTBYTEINTEGERARRAY ISEQS(40:4*74-1)={FIRST INTEGER FORMS} %C 4,0,0,0 {10 INTEGER LOGICAL NOT}, 3,0,0,0 {11 INTEGER LOGICAL NEGATE}, 11,0,0,0 {12 INTEGER FLOAT TO REAL}, 3,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}, 3,USH,0,0 {28 INTEGER LEFT SHIFT}, 3,USH,0,0 {29 INTEGER RIGHT SHIFT}, 12,0,0,0 {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(<-)}, 17,1,2,20 {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 NOW THE REALS}, 7,0,0,0 {10 REAL LOGICAL NOT}, 5,0,0,0 {11 REAL LOGICAL NEGATE}, 1,0,0,109 {FLOAT REAL COMPILER ERROR}, 8,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,RSB,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,2,21 {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}, 7,0,0,0 {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} %SWITCH SW(0:24),TRIPSW(0:70) ! 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_SMAP#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; EVALREG=ACCR OPND1==CURRT_OPND1 OPND2==CURRT_OPND2 XTRA=CURRT_X1 JJ=CURRT_OPERN %IF JJ=VMY %OR JJ=COMB %OR JJ=BADJ %THEN EVALREG=BREG TRIPINF=TRIPDATA(JJ) C=TRIPINF>>28; ! TRIPLE TYPE TRIPVAL=TRIPINF&255 %IF C=0 %THENCONTINUE %IF C=1 %THEN ->TRIPSW(TRIPVAL) COMM=1 PTYPE=OPND1_PTYPE&255; TYPE=PTYPE&7 %IF TYPE=2 %THEN C=4*(TRIPVAL+32) %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,-1,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 & SET PTYPE 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 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 OPND1_FLAG=9; ! PREVENT RELOAD IF THIS IS LAST OPND1_XB=EVALREG<<4 ->STRES SW(4): ! PLANT 3 BYTES ->STRES SW(7): ! NULL OPERATION ->STRES SUSE: ->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 REGS(ACCR)_USE=0 OPND1_PTYPE=OPND1_PTYPE-X'10' ->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 PTYPE=X'51' %THEN PSF1(IMYD,0,1) %FINISH REGS(ACCR)_USE=0 OPND1_PTYPE=OPND1_PTYPE+X'10' ->SUSE SW(11): ! FLOAT LOAD(OPND1,ACCR,1) PSF1(FLT,0,0) OPND1_PTYPE=OPND1_PTYPE+1 ->STRES SW(21): ! SHORTEN FOR JAM TRANSFER LOAD(OPND1,ACCR,1) C=OPND1_PTYPE>>4&15 %IF C=6 %THEN PSF1(MPSR,0,17) %ELSE %C %IF C=5 %THEN PF1(AND,0,0,X'FFFF') %ELSE PF1(AND,0,0,255) OPND1_PTYPE=OPND1_PTYPE-X'10' REGS(ACCR)_USE=0 ->SUSE SW(22): ! EXP IN REAL EXPRSN %IF OPND2_PTYPE&7=1 %THENSTART %IF OPND2_FLAG<=1 %AND 2<=OPND2_D<=4 %THEN %C SMALL EXP(B1,OPND2_D) %ELSE ->PCALL ->SUSE %FINISH ! REAL**REAL BY SUBROUTINE REXP; ->SUSE SW(17): ! EXP IN INTEGER CONTEXT %IF OPND2_FLAG<=1 %AND 2<=OPND2_D<=4 %THEN %C SMALL EXP(B1,OPND2_D) %AND ->STRES PCALL: ! CALL SUBROUTINE AS DEFINED STARSTAR ->SUSE SW(14): ! DSIDED COMPARISONS DUPLICATE(B1); ! COPY MIDDLE OPERAND(SIZE IN TABLE) GET WSP(D,B1) DSTORE(EVALREG,2*B1,CURRINF_RBASE,D) OPND2_FLAG=7; OPND2_D=CURRINF_RBASE<<16!D 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=C; ! PASS MASK ON FOR JUMP PUT(EVALREG,B1,OPND2) ->STRES; ! 2ND OPERAND MAY BE NEEDED IN SW(15): ! SPECIAL MH FOR ARRAY ACCESS C=OPND2_D>>24; ! CURRENT DIMENSION D=OPND2_D>>16&31; ! TOTAL NO OF DIMENSIONS VMULTIPLY ->STRES SW(18): ! BASE ADJUST ARRAY INDEX ! NOT USED FOR EMAS IMP ->STRES SW(19): ! ARRAY INDEX %IF CURRT_CNT=1 %AND CURRT_PUSE=CURRT_FLINK %START LOAD(OPND2,BREG,1) C=OPND1_PTYPE; OPND1_PTYPE=X'61' LOAD(OPND1,-1,0) ABORT %IF OPND1_XB&3#0 OPND1_XB=OPND1_XB!3 OPND1_PTYPE=C EVALREG=BREG %FINISH %ELSE %START LOAD(OPND2,-1,0) DFETCH(DR,8,XTRA>>16&15,XTRA&X'FFFF');! ARRAY PTR REGS(DR)_CL=1 PUT(DR,MODD,OPND2) OPND1_FLAG=10; OPND1_XB=X'72' EVALREG=DR %FINISH ->STRES SW(20): ! INDEXED FETCH LOAD(OPND2,-1,0) %IF OPND2_XB=X'72' %THEN REGS(DR)_CL=0 %IF OPND2_XB&3=3 %THEN REGS(BREG)_CL=0 LOAD(OPND2,EVALREG,1) OPND1_FLAG=9; OPND1_XB=EVALREG<<4 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 %IF OPND1_FLAG=2 %START; ! OPERAND A NAME LOAD(OPND2,EVALREG,1) TCELL==ASLIST(WORKA_TAGS(OPND1_D)) DSTORE(EVALREG,BYTES(PT>>4),TCELL_UIOJ>>4&15,TCELL_SLINK) %FINISHELSESTART; ! OPERAND A POINTER LOAD(OPND2,EVALREG,1) LOAD(OPND1,-1,0) %IF OPND1_XB&3=3 %THEN REGS(BREG)_CL=0 %IF OPND1_XB=X'72' %THEN REGS(DR)_CL=0 PUT(EVALREG,STCODE(EVALREG),OPND1) %FINISH ->STRES SW(23): ! LOCAL ASSIGNMENT LOAD(OPND2,-1,0) DSTORE(EVALREG,BYTES(PTYPE>>4&15),OPND1_D>>16,OPND1_D&X'FFFF') ->STRES TRIPSW(1): ! SET LINE NO PSF1(LSS,0,OPND1_D>>16) DSTORE(EVALREG,4,CURRINF_RBASE,OPND1_D&X'FFFF') %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),2,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) REGS(DR)_USE=0 REGS(ACCR)_USE=11 REGS(ACCR)_INF1=0 %FINISH %ELSE %START; ! ARRAYS ON STACK %IF CURRINF_FLAG=0 %THEN PSF1(STSF,1,OPND1_D) %FINISH %CONTINUE TRIPSW(4): ! DECLARE ARRAY ! OPND1=CDV<<31!C<<24!D<<16!DVDISP ! OPND1_XTRA HAS NAME %BEGIN %LONGINTEGER DESC %INTEGER DVDISP,W0,D0 TCELL==ASLIST(WORKA_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' STORE CONST(W0,8,ADDR(DESC)) PF1(LD,0,PC,W0) PSF1(INCA,1,PTROFFSET(CURRINF_RBASE)) %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 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 REGS(ACCR)_USE=11 %C %AND REGS(ACCR)_INF1=0 REGS(ACCR)_USE=11 REGS(ACCR)_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(WORKA_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 REGS(ACCR)_USE=11 %C %AND REGS(ACCR)_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) REGS(ACCR)_USE=11 REGS(ACCR)_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) REGS(ACCR)_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,-1,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) %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; ! THE MASK BACK JUMP: ! GOTO SW JOINS HERE C=(C-CA)//2 %IF D=15 %THEN PSF1(JUNC,0,C) %ELSE %C PF3(JCODE(D),D&15,0,C) %CONTINUE TRIPSW(11): ! FORWARD JUMP _X1 HAS TF&MASK ! OPND1_XTRA HAS JUMP CELL LCELL==ASLIST(OPND1_XTRA) C=CURRT_X1 %IF C=15 %AND REACHABLE(OPND1_D,STPTR)=YES %START PSF1(JUNC,0,0) LCELL_S1=(CA-2)!X'80000000';! MARK AS SHORT PLANTED %FINISH %ELSE %START %IF C=15 %THEN PF1(JUNC,0,0,0) %ELSE %C PF3(JCODE(C),C&15,0,0) LCELL_S1=CA-4; ! AFTER ROUNDING FOR ACCENT %FINISH %CONTINUE TRIPSW(12): ! REMOVE LABEL %CONTINUE TRIPSW(13): ! INSERT LABEL ! OPND1_XTRA HAS LABEL CELL LCELL==ASLIST(OPND1_XTRA) %WHILE LCELL_S2#0 %CYCLE; ! FILL FORWARD REFS POP(LCELL_S2,B1,B2,B3); ! B1<0 IF SHORT JUMP PLANTED ! 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 %START D=(CA-B1)//2 LPUT(18,0,B1,D); ! RELOCATE 18 BITS %FINISH %REPEAT LCELL_S1=LCELL_S1&X'FF000000'!CA %CONTINUE TRIPSW(14): ! FOR 2ND PREAMBLE ! MAY BE UNNECESSARY DUPLICATE(WORDS(CURRT_OPTYPE>>4)) %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(32,D+4,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 PF1(JUNC,0,0,3+(CA>>1&1)); ! JOIN WITH INTERNAL ENTRY %FINISH CNOP(0,4) CURRINF_ENTRYAD=CA %IF OPND1_D>=0 %START; ! ROUTINE PLANT INTERNAL ENTRY TCELL==ASLIST(WORKA_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(W1)_DISPLAY %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 PF1(LSS,0,PC,X'80000004'); ! PICK UP M'IDIA' PSF1(ST,1,OPND1_D) REGS(ACCR)_USE=0 %CONTINUE TRIPSW(17): ! RDPTR SET DAIGS POINTER ! OPND1_D=LEVEL NOT CURRINF ALWAYS LINF==WORKA_LEVELINF(OPND1_D) %IF LINF==CURRINF %AND CURRINF_FLAG>=X'1000' %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 REGS(ACCR)_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" PSF1(EXIT,0,-64) %IF OPND1_D#0 %THEN CEND(OPND1_D) %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 DFETCHAD(NO,OPND1_D>>16,OPND1_D&X'FFFF') ! PB1(LDC0); ! STRING POINTER (TLATED!) ! %IF CURRT_FLAGS&LOADOP2=0 %THEN PB1(EXCH2) %ELSE %C LOAD(OPND2,-1,0); ! 32 BIT AD OF STRING2 ! PB1(LDC0) ! PBW(LDCW,255); ! MAX LENGTH ! PB1(TLATE3); ! TLATE OPND2 ADDRESS ! PB1(SAS) 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 DFETCHAD(NO,OPND1_D>>16,OPND1_D&X'FFFF') PPJ(JLK,23); ! THIS SR LEAVE 32 BITS IN ESTACK ! %IF CURRT_FLAGS&LOADOP2#0 %THEN LOAD(OPND2,-1,0) %ELSE PB1(EXCH2) PPJ(JLK,24) OPND1_FLAG=7; ! RESULT IS LOCAL %CONTINUE TRIPSW(39): ! GENERAL STRING ASSIGN LOAD(OPND1,-1,0); ! PTR (3 WORDS) TO LHS %IF OPND2_FLAG=LCONST %AND OPND2_XTRA=0 %START; ! NULL STRING ASSN ! PB1(REPL) ! PB1(NEQBOOL); ! FORCE A ZERO ! PB1(TLATE2) ! PB1(STIND) %FINISHELSESTART ! PB1(MMS); ! SAVE MAX LENGTH ! PB1(LDC0) LOAD(OPND2,-1,0) ! PB1(LDC0) ! PB1(MES); ! MAX LENGTH BACK ! PB2(STLATE,X'63') ! PB1(SAS) %FINISH %CONTINUE TRIPSW(40): ! SIMPLE STRING ASSIGN TCELL==ASLIST(WORKA_TAGS(OPND1_D)) %IF OPND2_FLAG=LCONST %AND OPND2_XTRA=0 %START ! PB1(LDC0) DSTORE(EVALREG,2,TCELL_UIOJ>>4&15,TCELL_SLINK) %FINISHELSESTART LOAD(OPND1,-1,0) %IF CURRT_FLAGS&LOADOP2=0 %START; ! OP ALREADY LDED ! PB1(EXCH2) ! PB1(LDC0) ! PERM %FINISHELSE %START ! PB1(LDC0) %AND LOAD(OPND2,-1,0) %FINISH ! PB1(LDC0) ! PBW(LDCW,TCELL_ACC-1); ! LMAX ! PB2(STLATE,X'63') ! PB1(SAS) %FINISH %CONTINUE TRIPSW(41): ! STRING JT VIA SUBROUTINE LOAD(OPND1,-1,0) STACKDUMP(3) LOAD(OPND2,-1,0) STACKDUMP(2) PPJ(0,18) %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 %IF CURRT_FLAGS&LOADOP2#0 %START; ! OPND2 NOT LOADED ! LOAD(OPND1,-1,0); PB1(LDC0) ! LOAD(OPND2,-1,0); PB1(LDC0) %FINISHELSEIF CURRT_FLAGS&LOADOP1=0 %START; ! BOTH LOADED ! PB1(LDC0); PERM ! PB1(LDC0); %FINISHELSESTART; ! ONLY 2 LDED BACK COMP BFFLAG=1 ! PB1(LDC0) LOAD(OPND1,-1,0) ! PB1(LDC0) %FINISH ! PB2(STLATE,X'52') ! D=FCOMP(CURRT_X1+16*BFFLAG)-EQUI+EQUSTR ! PB1(D) %CONTINUE NULLSC: ! TEST FOR A NULL STRING LOAD(OPND,-1,0) ! PB1(LDC0) ! PB1(TLATE2) ! PB1(LDC0) ! PB1(FCOMP(CURRT_X1+16*BFFLAG)) %CONTINUE TRIPSW(47): ! PRE RESOLUTION 1 ! OPND1 IS 4 WORD WK AREA ! OPND2 IS STRING BEING RESLVD D=OPND1_D&X'FFFF' LOAD(OPND2,-1,0); ! 32 BIT ADDRESS TO ESTACK ! PB1(REPL2) DSTORE(EVALREG,4,CURRINF_RBASE,D); ! 32 BIT ADDR TO WK AREA ! PB1(LDC0) ! PB1(TLATE2) ! PB1(LDB); ! CURRENT LENGTH ! PB1(LDC0) DSTORE(EVALREG,4,CURRINF_RBASE,D+4); ! WHOLE LENGTH STILL AVAILABLE ! 0 BYTES USED UP SO FAR %CONTINUE TRIPSW(48): ! PRE RESOLUTION 2 ! OPND1 IS 4 WORD WK AREA ! OPND2 IS POINTER TO STRING TO HOLD ! FRAGMENT OR ZERO(=DISCARD FRGMNT) D=OPND1_D&X'FFFF' ! PB2(ATPB,1); ! HOLE FOR BOOLEAN RESULT DFETCH(EVALREG,4,CURRINF_RBASE,D) ! PB1(MMS2); ! RESLN STRING ADDR STACKED DFETCH(EVALREG,2,CURRINF_RBASE,D+6) ! PB1(MMS); ! BYTES USED ARE STACKED DFETCHAD(YES,CURRINF_RBASE,D+4) ! PB1(MMS2); ! POINTER TO BYTES USED IS STCKD %IF OPND2_FLAG=SCONST %START; ! NO STRING FOR FRAGMENT ! PB1(LDC0); PB1(REPL) ! PB1(REPL); ! THREE ZERO WORD %FINISHELSE LOAD(OPND2,-1,0); ! OR 3 POINTER WORDS ! PB1(MMS); PB1(MMS2); ! ARE STACKED %CONTINUE TRIPSW(49): ! RESOLUTION ! OPND1 IS STRING RES EXPR ! OPND2 IS LABEL NO LOAD(OPND1,-1,0) ! PB1(MMS2) PPJ(0,16) ! PB1(MES); ! BOOLEAN RESULT %IF OPND2_D=0 %THEN PPJ(36,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 LOAD(OPND2,-1,0); ! POINTER TO NEST D=OPND1_D&X'FFFF'; ! TO 4 WORD WK AREA ! PB1(MMS); ! LMAX TO MSTACK ! PB1(REPL2); ! 2 COPIES OF VRT ADDR DFETCH(EVALREG,4,CURRINF_RBASE,D+4) ! PB1(SBI); ! LENGTH OF FRAGMENT ! PB1(REPL) ! PB1(REPL) ! PB1(MMS2); PB1(MMS); ! 3 COPIES TO MSTACK ! PB1(LDC0+1); ! DEST FOR MVBYTES DFETCH(EVALREG,4,CURRINF_RBASE,D) DFETCH(EVALREG,2,CURRINF_RBASE,D+4) ! PB1(LDC0+1); PB1(ADI); ! SOURCE FOR MOVE ! PB1(MES); ! LENGTH ON TOP ! PB2(STLATE,X'63'); ! ASSIGN ALL BAR LENGTH ! PB1(MVBW) ! PB1(LDC0); PB1(MES) ! PB1(TLATE3); PB1(STCH); ! ASSIGN LENGTH ! PB1(MES2); PB1(LEQI) PPJ(36,9); ! CAPACITY EXCEEDED %CONTINUE !*********************************************************************** !* THIS NEXT SECTION DEALS WITH ROUTINE CALLS AND PARAMETER * !* PASSING. ALSO STORING AND RECOVERY OF FN & MAP RESULTS * !*********************************************************************** TRIPSW(23): ! IOCP CALL %IF OPND2_PTYPE&7=5 %THEN EVALREG=DR LOAD(OPND2,EVALREG,1) CIOCP(OPND1_D,EVALREG); ! ALWAYS CONSTANTS OPND1_FLAG=9; ! FOR WHEN RES NEEDED %CONTINUE TRIPSW(24): ! PRECALL OPND1 HAS RT NAME ! TCELL==ASLIST(WORKA_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(WORKA_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 DFETCH(DR,8,C,TCELL_SNDISP) DFETCH(XNB,4,C,TCELL_SNDISP+12) 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 %CONTINUE TRIPSW(44): ! MAP RESULT ASSIGNMENT ! CALLED BEFORE RETURN TO CALLER %IF OPND1_PTYPE&255=X'31' %THEN D=6 %ELSE D=4 RES: LOAD(OPND2,ACCR,0) DSTORE(EVALREG,D,CURRINF_RBASE,0) %CONTINUE TRIPSW(45): ! FN RESULT ASSIGNMENT ! CALLED BEFORE RETURN TO CALLER %IF OPND1_PTYPE&255=X'35' %THEN D=4 %ELSE D=BYTES(OPND1_PTYPE>>4&15) ->RES TRIPSW(26): ! RECOVER FN RESULT ! CALLED AFTER RETURN TO CALLER %CONTINUE TRIPSW(27): ! RECOVER MAP RESULT ! CALLED AFTER RETURN TO CALLER %CONTINUE TRIPSW(28): ! PASS PARAMETER(1)= NORMAL VALUE LCELL==ASLIST(OPND1_XTRA&X'FFFF'); ! PARAM DESCTR CELL D=LCELL_S2>>16; ! PARAM_ACC MISPLACED %IF OPND1_PTYPE&7=5 %START; ! STRINGS BY VALUE - LABORIOUS C=(D+1)>>1; ! PERQ WORDS FOR STRING VALUE ! PB1(LDTP); PB1(LDC0); ! PTR TO DEST(TLATED) ADJUSTSF(C) ! %IF CURRT_FLAGS&LOAD OP2=0 %THEN PB1(EXCH2) %ELSE %C LOAD(OPND2,-1,0); ! PTR TO STRING ! PB1(LDC0) ! PBW(LDCW,D-1); ! FOR ASSNMNT CHECK ! PB1(TLATE3) ! PB1(SAS) %FINISHELSEIF OPND1_PTYPE&7=3 %START; ! RECORD BY VALUE C=D>>1 ! PB1(LSSN) ! PB1(LDTP) ADJUSTSF(C) %IF OPND2_FLAG=SCONST %THEN D=0 %ELSE D=1 %AND LOAD(OPND2,-1,0) BULKM(D,C,0) %FINISHELSESTART LOAD(OPND2,ACCR,1) %IF LAST PAR REG#ACCR %AND REGS(LAST PAR REG)_CL=3 %THEN %C BOOT OUT(LAST PAR REG) LAST PAR REG=ACCR REGS(ACCR)_CL=3 %FINISH %CONTINUE TRIPSW(29): ! GET 32 BIT ADDRESS LOADAD(OPND1) %CONTINUE TRIPSW(30): ! GET POINTER FOR %NAME LOADPTR(OPND1,OPND2) %CONTINUE TRIPSW(31): ! PARAM PASSING (2) NORMAL PTRS PTYPE=OPND1_PTYPE&255; ! FOR PARAM %IF PTYPE=X'35' %OR PTYPE=X'31' %START; ! STRING(3 WORD) PTRS ! PB1(EXCH) STACKDUMP(1) ! PB1(EXCH) %FINISH STACKDUMP(2) %CONTINUE TRIPSW(32): ! PARAM PASSING(3) ARRAYS ! ALSO (4) PASS RT PARAM SAME CODE STACKDUMP(4) %CONTINUE TRIPSW(63): ! RTFP TURN RTNAME INTO FORMAL %BEGIN %RECORD(RD) ZOPND TCELL==ASLIST(WORKA_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,2,ZOPND) PF1(LUH,0,D,TCELL_SNDISP) %FINISHELSE %START ! PWW(LVRD,0,TCELL_SNDISP&255!(TCELL_UIOJ>>4&15+2)<<8) %FINISH OPND1_FLAG=9 OPND1_XB=ACCR<<4 REGS(ACCR)_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(WORKA_TAGS(OPND1_D)) DFETCH(EVALREG,8,TCELL_UIOJ>>4&15,TCELL_SNDISP) %FINISH %ELSE %START LOAD(OPND1,-1,0); ! 32 BIT ADDRESS ! PLW(LDDC,OPND2_D) ! PB1(EXCH2) %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(WORKA_TAGS(OPND1_D)) SSTL==CODEP_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(32,GLACA-4,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(WORKA_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(WORKA_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 REGS(BREG)_CL=0 REGS(BREG)_USE=0 %CONTINUE TRIPSW(36): ! REAL TO INTEGER AS INT LOAD(OPND1,ACCR,1) PF1(RAD,0,PC,SPECIAL CONSTS(0));! RAD 0.5 TRIPSW(37): ! REAL TO INTGER INTPT(OPND1) LOAD(OPND1,ACCR,1) %IF PARM_OPT#0 %THEN PSF1(RSC,0,55) %AND PSF1(RSC,0,-55) %IF REGS(BREG)_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) REGS(ACCR)_USE=0; REGS(BREG)_USE=0 OPND1_PTYPE=X'51' %CONTINUE TRIPSW(38): ! INTEGER TO STRING AS TOSTRING GET WSP(D,1) LOAD(OPND1,-1,0) ! PBW(LDCW,256) ! PB1(MPI) ! PB1(LDC0+1) ! PB1(ADI) DSTORE(EVALREG,2,CURRINF_RBASE,D) OPND1_FLAG=LOCALIR OPND1_PTYPE=X'35' OPND1_D=CURRINF_RBASE<<16!D %CONTINUE TRIPSW(42): ! ARRAYHEAD ASSIGNMENT OPND2_PTYPE=X'61'; ! SO LOAD LOADS HEAD NOT ELEMNT %IF OPND1_FLAG=DNAME %START; ! LHS IN LOCAL SPACE LOAD(OPND2,-1,0) TCELL==ASLIST(WORKA_TAGS(OPND1_D)) DSTORE(EVALREG,8,TCELL_UIOJ>>4&15,TCELL_SLINK) %FINISHELSESTART ABORT %UNLESS OPND1_FLAG=INDIRECT %OR OPND1_FLAG=REFTRIP %IF OPND1_FLAG=INDIRECT %AND OPND1_XTRA>0 %START %IF CURRT_FLAGS&LOADOP2=0 %THEN STACKDUMP(4) ! PBW(INCW,OPND1_XTRA>>1) %IF CURRT_FLAGS&LOADOP2=0 %THEN STACKUNDUMP(4) %FINISH LOAD(OPND2,-1,0) ! PTLATE(5) ! PB2(0,38) %FINISH %CONTINUE TRIPSW(43): ! POINTER ASSIGNMENT D=4 %UNLESS X'31'#OPND1_PTYPE&255#X'35' %THEN D=6 LOAD(OPND2,-1,0) %IF OPND1_FLAG=DNAME %START; ! LOCAL PTR TCELL==ASLIST(WORKA_TAGS(OPND1_D)) %IF D=6 %THEN DSTORE(EVALREG,2,TCELL_UIOJ>>4&15,TCELL_SLINK+4) DSTORE(EVALREG,4,TCELL_UIOJ>>4&15,TCELL_SLINK) %CONTINUE %FINISH %UNLESS CURRT_FLAGS&LOADOP1=0 %AND D=4 %START STACKDUMP(D>>1) LOAD(OPND1,-1,0) %IF D=6 %START ! PB1(REPL2); ! DUPLICATE DEST VA STACKUNDUMP(1) ! PB1(TLATE2) ! PB1(STIND) ! PB2(INCB,1); ! FOR SECOND&THIRD WORD %FINISH STACKUNDUMP(2) %FINISH ! PB1(TLATE3) ! PB1(STDW) %CONTINUE TRIPSW(62): ! RECORD ASSIGNMENT LOAD(OPND1,-1,0) ! %IF CURRT_FLAGS&LOAD OP2=0 %THEN EXCHANGE(OPND1,OPND2) %IF OPND2_FLAG=SCONST %THEN BULKM(0,CURRT_X1,OPND2_D) %ANDCONTINUE LOAD(OPND2,-1,0) BULKM(1,CURRT_X1,0) %CONTINUE TRIPSW(64): ! AAINC INCREMENT RECORD RELATIVE ! ARRAY ACCESS BY RECORD BASE(OPND1) ! TO GIVE ABSOLUTE ACCESS. PERQ MUST ! REMEMBER BYTE ARRAYS ARE NONSTANDARD LOAD(OPND2,-1,0); ! THE RELATIVE ACCESS ! %IF CURRT_X1=X'31' %THEN PB1(MMS);! BYTES REMOVE EXTRA WORD LOAD(OPND1,-1,0) ! PB2(0,2); ! LONG ADDITION ! %IF CURRT_X1=X'31' %THEN PB1(MES);! RETRIEVE BYTE OFFSET %CONTINUE TRIPSW(65): ! AHADJ ARRAY MAPPING OPND1 1 ! HAS ADJUSTMENT OPND2 THE HEAD ! MODE IS IN CURRT_X1 LOAD(OPND1,-1,0); ! BASE ADDRESS OR ADJMNT ! %IF CURRT_FLAGS&LOADOP2=0 %THEN EXCHANGE(OPND1,OPND2) %ELSE %C LOAD(OPND2,-1,0) %IF CURRT_X1=0 %START; ! ARRAY MAPPING OPND1 IS BASE ! ERASE(2); ! DISCARD OLD BASE ! PB1(EXCH2); ! AND BRING IN THE NEW %FINISH %ELSE %START ! PB1(EXCH2); ! DV TO TOP ! PB1(PERMD); ! AND TO VERY BOTTOM ! PB2(0,2); ! ADRESSES ADDED %FINISH %CONTINUE !*********************************************************************** !* SECTION FOR GENERATING CODE FOR INLINE ASSEMBLER * !*********************************************************************** TRIPSW(50): ! UC NOOP CNOP(OPND1_D>>8,OPND1_D&255) %CONTINUE TRIPSW(51): ! UCB1 ONE BYTE ASSEMBLER ! PB1(OPND1_D); %CONTINUE TRIPSW(52): ! UCB2 TWO BYTE ASSEMBLER ! PB2(OPND1_D>>8,OPND1_D&255) %CONTINUE TRIPSW(53): ! UCB3 3 BYTE ASSEMBLER ! PB3(OPND1_D>>16,OPND1_D>>8&255,OPND1_D&255) %CONTINUE 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(NO,C,JJ) %ELSEIF D=2 %THEN %C DSTORE(EVALREG,2,C,JJ) %ELSE DFETCH(EVALREG,2,C,JJ) %CONTINUE STRES: CURRT_OPTYPE<-OPND1_PTYPE %IF CURRT_CNT>1 %AND CURRT_OPERN#LASS %START; ! USED MORE THAN ONCE ! AND NOT ALREADY STORED C=BYTES(OPND1_PTYPE>>4&15) DUPLICATE(C>>1) %IF CURRT_FLAGS&USE ESTACK=0 %START; ! DUPLICATE NOT LEFT IN ESTACK %IF CURRT_FLAGS&32#0 %START; ! USE MEMORY STACK STACKDUMP(C>>1) OPND1_D=0 %FINISHELSESTART; ! STORE IN TEMPORARY GET WSP(D,C>>1) DSTORE(EVALREG,C,CURRINF_RBASE,D) OPND1_D=CURRINF_RBASE<<16!D %FINISH %FINISH %FINISH %IF CURRT_CNT=0 %AND REGS(EVALREG)_CL=1 %THEN REGS(EVALREG)_CL=0 %REPEAT %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 ABORT %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) %RETURN %FINISH YNB=SET LEVREG(-1,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 %RECORD(TRIPF) %NAME REFTRIP %RECORD(TAGF) %NAME TCELL %SWITCH SW(0:10) K=OPND_FLAG PTYPE=OPND_PTYPE TYPE=PTYPE&15 PREC=PTYPE>>4&15 %IF K>10 %THEN ABORT ->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 ->OPTLOAD SW(1): SW1: ! LONG CONSTANT %IF TYPE=5 %THEN ->SCONST %IF TYPE=1 %AND PREC<=5 %AND IMOD(OPND_D)SW0 %IF PTYPE=X'61' %AND LONGINTEGER(ADDR(OPND_D))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 ->OPTLOAD SCONST: ! STRING CONSTANT OPND_DIS AR PTR STORE STRING(D,STRING(ADDR(WORKA_A(OPND_D)))) %IF REGS(DR)_CL#0 %THEN BOOT OUT(DR) PF1(LDRL,0,PC,D) REGS(DR)_USE=0 %IF REG=ACCR %THEN COPY DR OPND_FLAG=9 OPND_XB=REG<<4 %RETURN SW(3): ! 128 BIT CONSTANT ABORT SW(2): ! NAME TCELL==ASLIST(WORKA_TAGS(OPND_D)) K=BYTES(OPND_PTYPE>>4&15) %IF TYPE=5 %OR TYPE=3 %THENSTART %IF PTYPE&X'400'=0 %THEN ->FAD; ! STRING LOAD = FETCH ADDRESS K=4; ! POINTER IS 4 BYTES %FINISH OPND_FLAG=7 OPND_D=(TCELL_UIOJ&X'F0')<<12!(TCELL_SLINK+OPND_XTRA) OPND_XTRA=0 ->OPTLOAD LDED: %IF TYPE=1 %AND PREC<4 %THEN OPND_PTYPE=X'41' OPND_FLAG=9 %RETURN SW(5): ! INDIRECT VIA DICTIONARY ! ONLY RECORD SCALAR(_XTRA>=0) ! OR POINTER(_XTRA<0) TCELL==ASLIST(WORKA_TAGS(OPND_D)) DFETCH(REG,4,TCELL_UIOJ>>4&15,TCELL_SLINK) %IF PREC=3 %AND TYPE=1 %START; ! BYTE SPECIAL AS ALWAYS ! %IF OPND_XTRA>=0 %THEN PBW(LDCW,OPND_XTRA) %ELSE %C DFETCH(REG,2,TCELL_UIOJ>>4&15,TCELL_SLINK+4) ! PB1(TLATE2); PB1(LDB); ->LDED %FINISH ->IFETCH SW(4): ! CONDITIONAL EXPRESSION ABORT FAD: DFETCHAD(YES,TCELL_UIOJ>>4&15,TCELL_SLINK+OPND_XTRA) ->LDED SW(6): ! INDIRECT WITH OFFSET REFTRIP==TRIPLES(OPND_D) OPND=REFTRIP_OPND1 ->OPTLOAD IFETCH: ->LDED SW(7): ! I-R IN A STACK FRAME OPTLOAD: %IF OPND_FLAG#10 %THEN DEVELOP BD(OPND) SW(10): ! DEVELOPPED BD FORM %IF MODE>0 %THEN %START GETINACC(REG,BYTES(PREC),OPND) REGS(REG)_CL=1 OPND_XB=REG<<4 OPND_FLAG=9 REGS(REG)_LINK=ADDR(OPND) %FINISH %RETURN ->LDED SW(8): ! TRIPLE REFTRIP==TRIPLES(OPND_D) %IF TYPE=5 %THEN LOAD(REFTRIP_OPND1,-1,0) %ANDRETURN ! %IF REFTRIP_OPERN=LASS %OR REFTRIP_PUSE=WTRIPNO %THEN %C OPND=REFTRIP_OPND1 %AND LOAD(OPND,REG,MODE) %ANDRETURN 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 REGS(REG)_LINK=ADDR(OPND) %AND %RETURN %IF OPND_XB>>4=ACCR %AND REG=BREG %AND REGS(BREG)_CL=0 %START PF1(ST,0,BREG,0) REGS(ACCR)_CL=0 REGS(BREG)_CL=1 REGS(BREG)_LINK=ADDR(OPND) OPND_XB=REG<<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 LOADAD(%RECORD(RD) %NAME OPND) !*********************************************************************** !* MUCH AS LOAD BUT PRODUCES THE 32 BIT ADDRESS OF OPERAND * !* ABORT ON NON RELEVANT ALTERNATIVES OF OPND * !************************************************************************ %RECORD(TAGF) %NAME TCELL %INTEGER B,D %SWITCH SW(0:9) PTYPE=OPND_PTYPE ->SW(OPND_FLAG) SW(*): ! INVALID ABORT SW(2): ! DNAME TCELL==ASLIST(WORKA_TAGS(OPND_D)) DFETCHAD(YES,TCELL_UIOJ>>4&15,TCELL_SLINK+OPND_XTRA) LDED: OPND_PTYPE=X'51'; ! 32 BIT ADDRESS IS INTEGER OPND_FLAG=9 %RETURN SW(5): ! INDIRECT VIA PTR TCELL==ASLIST(WORKA_TAGS(OPND_D)) B=TCELL_UIOJ>>4&15 D=TCELL_SLINK PF: DFETCH(EVALREG,4,B,D) %IF PTYPE&255=X'31' %AND OPND_XTRA<0 %START DFETCH(EVALREG,2,B,D+4) %FINISH %ELSE %START ! %IF OPND_XTRA>0 %THEN PBW(INCW,OPND_XTRA) %FINISH ->LDED SW(6): ! INDIRECT OFFSET %IF OPND_PTYPE&255=X'31' %START ! %IF OPND_XTRA>0 %THEN PBW(INCW,OPND_XTRA) %FINISH %ELSE %IF OPND_XTRA>0 %THEN %START ! PBW(INCW,OPND_XTRA>>1) %FINISH ->LDED SW(7): ! LOCAL-IR IN BASE&OFFSET FORM B=OPND_D>>16 D=OPND_D&X'FFFF' ->PF %END %ROUTINE LOADPTR(%RECORD(RD) %NAME OPND,OPND2) !*********************************************************************** !* MUCH AS LOAD BUT PRODUCES THE POINTER TO THE OPERAND * !* ABORT ON NON RELEVANT ALTERNATIVES OF OPND * !************************************************************************ %RECORD(TAGF) %NAME TCELL %INTEGER K %SWITCH SW(0:9) PTYPE=OPND_PTYPE ->SW(OPND_FLAG) SW(*): ! INVALID ABORT SW(2): ! DNAME TCELL==ASLIST(WORKA_TAGS(OPND_D)) DFETCHAD(YES,TCELL_UIOJ>>4&15,TCELL_SLINK+OPND_XTRA) ! %IF PTYPE&255=X'31' %THEN PB1(LDC0+(((TCELL_SLINK+OPND_XTRA)&1)!!1)) STR: %IF PTYPE&255=X'35' %THEN %START PTYPE=OPND2_D>>16; ! ORIGINAL PTYPE AGAIN ! %IF PTYPE&X'400'=0 %THEN PBW(LDCW,OPND2_D&X'FFF'-1) %ELSE %C %IF PTYPE&X'300'=0 %THEN %C DFETCH(EVALREG,2,OPND2_XTRA>>16,OPND2_XTRA&X'FFFF') %ELSE %START DFETCH(EVALREG,4,OPND2_XTRA>>16,OPND2_XTRA&X'FFFF') ! PB1(TLATE1); ! DV ADDRESS ! PB1(SIND0+2) ! PB1(LDC0+1) ! PB1(SBI) ! %FINISH %FINISH LDED: OPND_FLAG=9 %RETURN SW(5): ! INDIRECT VIA DICT TCELL==ASLIST(WORKA_TAGS(OPND_D)) %IF OPND_XTRA<0 %START; ! IS A POINTER DFETCH(EVALREG,4,TCELL_UIOJ>>4&15,TCELL_SLINK) %IF PTYPE&255=X'31' %OR PTYPE&255=X'35' %THEN %C DFETCH(EVALREG,2,TCELL_UIOJ>>4&15,TCELL_SLINK+4) ->LDED %FINISH DFETCH(EVALREG,4,TCELL_UIOJ>>4&15,TCELL_SLINK) ! %IF PTYPE&255=X'31' %THEN PBW(LDCW,OPND_XTRA) %ELSE %C ! %IF OPND_XTRA>0 %THEN PBW(INCW,OPND_XTRA>>1) ->STR SW(6): ! INDIRECT OFFSET ! %IF OPND_XTRA>0 %THEN PBW(INCW,OPND_XTRA>>1) ! %IF PTYPE&255=X'31' %AND TRIPLES(OPND_D)_OPERN#AINDX %THEN %C PBW(LDCW,OPND_XTRA) ->STR %END %ROUTINE VMULTIPLY !*********************************************************************** !* DOES ALL VECTOR MULTIPLIES * !*********************************************************************** %INTEGER DVPOS,CM1,CM2 DVPOS=OPND2_D&X'FFFF'+3*(D+1-C) %IF DVPOS>0 %THENSTART CM1=CTABLE(DVPOS) CM2=CTABLE(DVPOS+1) LOAD(OPND1,BREG,1) %UNLESS CM1=0 %AND CM2=1 PSF1(SBB,0,CM1) %UNLESS CM1=0 PSF1(MYB,0,CM2) %UNLESS CM2=1 %FINISHELSESTART LOAD(OPND1,BREG,1) CM1=3*(D-C); ! WORD TO RELEVANT TRIPLE DFETCH(DR,8,OPND2_XTRA>>16,OPND2_XTRA&X'FFFF'+8); ! DV PTR PSF1(MODD,0,CM1) %UNLESS CM1=0 PF1(X'2C',0,BREG,0); ! 2C IS VMY %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) REGS(ACCR)_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 ! REGS(BREG)_CL=0 REGS(ACCR)_USE=0 REGS(BREG)_USE=0 REGS(ACCR)_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 * !*********************************************************************** ABORT %END %ROUTINE SAVE IRS !*********************************************************************** !* DUMP ACC AND-OR B ONTO THE STACK. USED BEFORE CALLING FNS * !* IN EXPRESSIONS. * !*********************************************************************** ABORT %IF REGS(ACCR)_CL=1=REGS(BREG)_CL %IF REGS(ACCR)_CL>=1 %THEN BOOT OUT(ACCR) %IF REGS(BREG)_CL>=1 %THEN BOOT OUT(BREG) %IF REGS(DR)_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) ABORT %UNLESS 1<=BOOTREG_CL<=3 %AND CODE#0 R==RECORD(BOOTREG_LINK) %IF BOOTREG_CL=2 %THEN %START %IF R_D=0 %THEN GET WSP(R_D,BYTES(R_PTYPE>>4)>>2) PSF1(CODE,1,R_D) %FINISH %ELSE %START %IF REG#ACCR %AND(REGS(ACCR)_CL=1 %OR REGS(ACCR)_CL=3)%C %THEN BOOT OUT(ACCR) 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 REGS(ACCR)_CL#0 %THEN BOOT OUT(ACCR) PSF1(CYD,0,0) REGS(ACCR)_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 ABORT %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' %START OPND_XB=X'62' %FINISH %ELSE %START ABORT %UNLESS OPND_FLAG=9 %AND OPND_XB>>4=REG OPND_XB=TOS<<4 %FINISH OPND_FLAG=10; ! CHANGE TO 'STACKED' %FINISH %IF CREG_CL=2 %START OPND_FLAG=10; OPND_XB=LNB<<4 %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 ABORT %UNLESS REG=ACCR %OR(REG=DR %AND SIZE=8) %OR %C (REG=BREG %AND SIZE<=4) %IF REG=DR %THEN OPCODE=LD %ELSE %START %IF REG=BREG %THEN OPCODE=LB %ELSE OPCODE=LSS+(SIZE>>2)&6 %FINISH %IF REGS(REG)_CL>=1 %THEN %START %IF 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 %AND(REGS(ACCR)_CL=1 %OR REGS(ACCR)_CL=3)%C %THEN BOOT OUT(ACCR) 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 REGS(DR)_CL>0 %THEN %C BOOT OUT(DR) PSORLF1(OPCODE,ACCESS,AREA,OPND_D) %IF ACCESS>=2 %AND 0#AREA#7 %THEN REGS(DR)_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 SEGNO,LEVEL,DISP) !*********************************************************************** !* FETCH ADDRESS OF DISP(BYTES) IN DISPLAY 'LEVEL' * !*********************************************************************** %INTEGER LEVELCODE,WDISP,OPCODE %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 JCODE(%INTEGER TFMASK) %IF TFMASK=15 %THENRESULT=JUNC %IF TFMASK>=16 %THEN %RESULT=JAT %IF TFMASK>=32 %THEN %RESULT=JAF %RESULT=JCC %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,I %RECORD(TRIPF)%NAME CURRT %RECORD(RD)%NAME OPND %CONSTINTEGER LIMIT=63 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=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 KP,JJ,BIT,ID,ML JJ=CURRINF_SNMAX-CURRINF_DISPLAY-4*CURRINF_RBASE JJ=JJ>>2; ! ASF WORKS IN WORDS LPUT(18,0,CURRINF_SET,JJ) %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 %IF REGS(BREG)_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)) FORGET(-1) %END %ROUTINE PPJ(%INTEGER MASK,N) !*********************************************************************** !* PLANT A 'JCC MASK,PERMENTRY(N)' * !* IF MASK=0 THEN PLANT A JLK * !* IF MASK=-1 THEN PLANT A CALL TO PERM * !*********************************************************************** %INTEGER VAL, INSTRN, CODE, J %RECORD(LISTF)%NAME LCELL %IF MASK=0 %THEN CODE=JLK %ELSE CODE=CALL %IF MASK>0 %THEN CODE=JCODE(MASK) VAL=WORKA_PLABS(N) %IF MASK<=0 %THEN INSTRN=CODE<<24!3<<23 %ELSE %C INSTRN=CODE<<24!(MASK&15)<<21 %IF VAL>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 PSORLF1(CODE,OPND_XB&15,OPND_XB>>4,OPND_D) %IF EVALREG#BREG %AND (OPND_XB=X'70' %OR OPND_XB&3=3) %C %THEN REGS(BREG)_CL=0 REG==REGS(EVALREG) %IF CODE=IAD %AND REG_USE=9 %AND OPND_XB=0 %C %AND OPND_D<4095 %AND REG_INF1>>16=0 %THEN %START REG_USE=10 REG_INF1=REG_INF1&X'FFFF'!OPND_D<<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 %END; ! OF ROUTINE GENERATE %ENDOFFILE