! ! Warning this module has the revised triples spec. ! ! In first attempt at Triple Imp considerable use was made of constant operands ! to pass information from Pass2 to GEN. Although for specialised operations like ! passing Labels this still applies, this adhocery has caused problems with arrays ! and pointers particularly in mapped records. The operands for four triples ! have thus been redefined in a more standard way. ! ! GETPTR X1 is now (ptype of passed)<<16! DIMENSION ! Opnd2 is either a 32 bit const with the size (ACC) as value or ! the ptr or arrayhead as normal operand. ! ! VMY X1 is now dim<<28!maxdim<<24!array name(where known) ! Opnd2 is either a 32 bit const with DV offset into const area or ! the arrayhead as a standard operand ! ! AINDX X1 is ELSIZE<<20 !spare ! Opnd2 is arrayhead as standard operand ! NOTE:- The Operands have been swopped for consistency with norm. ! ! BADJ X1 is arrayptype<<16!no of Dimensions (latter in case of backward dvs) ! Opnd2 exactly as for VMY ! %CONSTSTRING(9) LADATE="31 Jan 85"; ! LAST ALTERED %CONSTINTEGER NO OF SNS=66 %CONSTINTEGER LRLPT=X'62' %UNLESS HOST=PERQ %OR HOST=DRS %OR HOST=ACCENT %THEN %START %CONSTINTEGER PTSHIFT=16,FLAGSHIFT=0 %FINISH %ELSE %START %CONSTINTEGER PTSHIFT=0,FLAGSHIFT=16 %FINISH ! %CONSTINTEGER MAXLEVELS=31,CONCOP=13 ! %INCLUDE "ERCC07.TRIPCNSTS" %INCLUDE "ERCC07.TRIMP_TFORM1S" %CONSTINTEGER SNPT=X'1006'; ! SPECIALNAME PTYPE %CONSTINTEGER UNASSPAT=X'80808080' %CONSTINTEGER LABUSEDBIT=X'01000000' %CONSTINTEGER LABSETBIT=X'02000000' %CONSTINTEGER MAXDICT=X'100'; ! PARM MAXDICT BIT ! %INTEGER I, K, DUMMYFORMAT, P1SIZE, STARSIZE, ASL, ARSIZE, OLDLINE, NEXTP, SNUM, RLEVEL, NMAX, PLABEL, LEVEL, PROFAAD, LAST INST, LINE, BFFLAG, RBASE, N, EXITLAB, CONTLAB, Q, R, FNAME, STMTS, FILE SIZE, BIMSTR, MAX ULAB, SFLABEL, NEXTTRIP %INTEGERNAME SSTL,USTPTR %STRING(31)MAINEP ! %EXTERNALINTEGERARRAY CAS(0:12) %EXTERNALRECORD(PARMF) PARM %EXTERNAL%RECORD(WORKAF)WORKA %IF HOST=IBM %OR HOST=AMDAHL %OR HOST=IBMXA %START %EXTERNALINTEGERMAPSPEC COMREG %ALIAS "S#COMREGMAP"(%INTEGER N) %ELSE %SYSTEMINTEGERMAPSPEC COMREG(%INTEGER N) %FINISH %CONSTINTEGER BYTESPERKFORSOURCE=256;! FRACTION OF KB IN WK FILE ! THATS IS ALLOCATE FOR SOURCE (&LPUT) %BEGIN %RECORD(EMASFHDRF)%NAME SHDR,WHDR WORKA_FILE ADDR=COMREG(46); ! SOURCE FILE IF CLEAN PARM=0 PARM_BITS1=COMREG(27) PARM_BITS2=COMREG(28) WORKA_WKFILEAD=COMREG(14) WHDR==RECORD(WORKA_WKFILEAD) WORKA_WKFILEK=WHDR_FBYTESIZE>>10 %IF WORKA_FILE ADDR<=0 %THEN %START %IF WORKA_FILE ADDR<-1 %THEN FILESIZE=IMOD(WORKA_FILE ADDR) %C %ELSE FILESIZE=64000 WORKA_FILE ADDR=0 %FINISH %ELSE %START SHDR==RECORD(WORKA_FILE ADDR) FILE SIZE=SHDR_ENDRA %FINISH WORKA_NNAMES=511 %IF FILESIZE>32000 %THEN WORKA_NNAMES=1023 %IF FILESIZE>256*1024 %OR PARM_BITS2&MAXDICT#0 %OR WORKA_WKFILEK>512 %C %THEN WORKA_NNAMES=2047 ASL=3*WORKA_NNAMES %IF ASL>4095 %AND (HOST#EMAS %OR PARM_BITS2&MAXDICT=0) %THEN ASL=4095 WORKA_ASL MAX=ASL ARSIZE=WORKA_WKFILEK*(1024-BYTESPERKFORSOURCE)-300 %END %BYTEINTEGERARRAYFORMAT AF(0:ARSIZE) %BYTEINTEGERARRAYNAME A %RECORD(LISTF)%ARRAY ASLIST(0:ASL) %INTEGERARRAY TAGS(0:WORKA_NNAMES) %INTEGERARRAY WORD(0:WORKA_NNAMES) %INTEGERARRAY DVHEADS(0:12) %RECORD(LEVELF)%ARRAY LEVELINF(0:MAXLEVELS) %EXTERNALROUTINESPEC INITASL(%RECORD(LISTF)%ARRAYNAME A,%INTEGERNAME B) %EXTERNALINTEGERFNSPEC MORE SPACE !%EXTERNALINTEGERFNSPEC NEWCELL %EXTERNALROUTINESPEC INSERTATEND(%INTEGERNAME S, %INTEGER A, B, C) %EXTERNALROUTINESPEC INSERT AFTER(%INTEGERNAME S,%INTEGER A,B,C) %EXTERNALROUTINESPEC POP(%INTEGERNAME C, P, Q, R) %EXTERNALROUTINESPEC PUSH(%INTEGERNAME C, %INTEGER S1, S2, S3) %EXTERNALINTEGERFNSPEC FIND(%INTEGER LAB, LIST) %EXTERNALROUTINESPEC BINSERT(%INTEGERNAME T,B,%INTEGER S1,S2,S3) %EXTERNALROUTINESPEC CLEARLIST(%INTEGERNAME HEAD) %EXTERNALROUTINESPEC FILL DTABREFS(%INTEGERNAME HEAD) %EXTERNALROUTINESPEC CXREF(%STRING(255)NAME,%INTEGER MODE,XTRA, %INTEGERNAME AT) %EXTERNALROUTINESPEC IMPABORT %EXTERNALROUTINESPEC PROLOGUE(%RECORD(LISTF)%ARRAYNAME ALIST) %EXTERNALROUTINESPEC EPILOGUE(%INTEGER STMTS) %EXTERNALROUTINESPEC PDATA(%INTEGER AREA,BNDRY,L,AD) %EXTERNALROUTINESPEC PRDATA(%INTEGER AREA,BNDRY,L,REP,AD) %EXTERNALINTEGERFNSPEC PINITOWN(%INTEGER PTYPE,ACC,%RECORD(RD)%NAME INIT, %STRINGNAME XNAME) %EXTERNALINTEGERFNSPEC POWNARRAYHEAD(%INTEGER PTYPE,J,LB,SIZE, AOFFSET,AAREA,DVOFFSET,%STRING(31) XNAME) %EXTERNALROUTINESPEC FAULT(%INTEGER A,B,C) %EXTERNALROUTINESPEC WARN(%INTEGER N,V) %EXTERNALROUTINESPEC TRIP OPT(%RECORD(TRIPF)%ARRAYNAME T, %INTEGERNAME NEXT TRIP) %EXTERNALROUTINESPEC MOVE BYTES(%INTEGER LENGTH,FBASE,FOFF,TOBASE,TOOFF) %EXTERNALROUTINESPEC CTOP(%INTEGERNAME OP,MASK,%INTEGER XTRA, %RECORD(RD)%NAME OPND1,OPND2) %IF HOST#TARGET %START %EXTERNALROUTINESPEC REFORMATC(%RECORD(RD)%NAME OPND) %EXTERNALROUTINESPEC CHANGE SEX(%INTEGER BASEAD,OFFSET,L) %FINISH %EXTERNALROUTINESPEC GENERATE(%RECORD(TRIPF)%ARRAYNAME T, %INTEGER CURRLEVEL,%ROUTINE GETWSP(%INTEGERNAME PL,%INTEGER SIZE)) %EXTERNALROUTINESPEC PRINTLIST(%INTEGER HEAD) ! START OF COMPILATION K=BYTESPERKFORSOURCE//(HOST//10); ! DISTINGUISH BYTE&WORD ADDRESSED HOSTS ! ALLOW FOR BYTE & WORD ADDRESS M-CS A==ARRAY(WORKA_WKFILE AD+K*WORKA_WKFILEK, AF) %BEGIN !*********************************************************************** !* THIS BLOCK INITIALISE THE COMPILER SCALARS AND ARRAYS * !* WAS ORIGINALLY ROUTINE 'INITIALISE'. * !* THE INITIALISATION OF THE CONSTANT LISTS WITH THE VALUES * !* IN PERM MAY BE OMITTED IN BATCH OR CUT-DOWN VERSIONS. * !*********************************************************************** %EXTERNALINTEGERFNSPEC PASSONE WORKA_CCSIZE=BYTESPERKFORSOURCE*(WORKA_WKFILEK-1);! CCSIZE ALWAYS AS BYTES %BYTEINTEGERARRAYFORMAT CCF(0:WORKA_CCSIZE) %BYTEINTEGERARRAYNAME CC CC==ARRAY(WORKA_WKFILEAD+32,CCF) WORKA_CC==CC WORKA_A==A WORKA_WORD==WORD WORKA_TAGS==TAGS WORKA_LINE==LINE WORKA_RELEASE=RELEASE WORKA_LADATE=LADATE WORKA_AASL0=ADDR(ASLIST(0)) WORKA_AMAINEP=ADDR(MAINEP) WORKA_LASTTRIP=WORKA_CCSIZE//40 -2; ! 40 IS SIZE OF THE TRIP ARRAY %IF WORKA_LASTTRIP>699 %THEN WORKA_LASTTRIP=699 WORKA_OPTCNT=0; ! ZERO COUNT OF OPTIMISATIONS WORKA_ASLIST==ASLIST PLABEL=24999 N=12; MAX ULAB=WORKA_NNAMES+16384; ! LARGEST VALID USER LABEL LAST INST=0 SFLABEL=20999 EXITLAB=0; CONTLAB=0 RLEVEL=0; NMAX=0; BFFLAG=0 RBASE=1 SSTL==CAS(4); USTPTR==CAS(5) STMTS=1; SNUM=0 BIMSTR=0 WORKA_RTCOUNT=1; ! ROUTINE 0 RESERVED FOR MAIN PROG MAINEP="s#go"; ! DEFAULT MAIN ENTRY INITASL(ASLIST,ASL) %CYCLE I=0,1,12 CAS(I)=0; DVHEADS(I)=0 %REPEAT ! DUMMY FORMAT=0; ! DUMMY RECORD FORMAT PUSH(DUMMY FORMAT,0,0,0); ! FOR BETTER ERROR RECOVERY P1SIZE=PASSONE R=P1SIZE WORKA_ARTOP=P1SIZE %END; ! OF BLOCK CONTAINING PASS 1 %BEGIN !*********************************************************************** !* SECOND OR TRIPLES GENERATING PASS * !*********************************************************************** %RECORD(LEVELF)%NAME CURRINF %INTEGER TWSPHEAD,FORCNT,FORDPTH,FORCECNT %IF HOST=EMAS %OR HOST=IBM %OR HOST=AMDAHL %OR HOST=IBMXA %START; ! LPUT BASED WORKFILE USED FOR OBJECT %RECORD(TRIPF)%ARRAY TRIPLES(0:WORKA_LASTTRIP) %FINISH %ELSE %START %RECORD(TRIPF)%ARRAYFORMAT TRIPLESFORM(0:WORKA_LASTTRIP) %RECORD(TRIPF)%ARRAYNAME TRIPLES TRIPLES==ARRAY(WORKA_WKFILEAD+32,TRIPLESFORM) %FINISH %INTEGERARRAYFORMAT CF(0:12*WORKA_NNAMES) %INTEGERARRAYNAME CTABLE !%ROUTINESPEC NOTE CREF(%INTEGER CA) !%ROUTINESPEC STORE CONST(%INTEGERNAME D,%INTEGER L,AD) !%INTEGERFNSPEC WORD CONST(%INTEGER VALUE) %ROUTINESPEC REUSE TEMPS %ROUTINESPEC GET WSP(%INTEGERNAME PLACE,%INTEGER SIZE) %ROUTINESPEC RETURN WSP(%INTEGER PLACE,SIZE) %ROUTINESPEC COMPILE A STMNT %INTEGERFNSPEC NEW TRIP %INTEGERFNSPEC FROMAR4(%INTEGER PTR) %INTEGERFNSPEC FROMAR2(%INTEGER PTR) %INTEGERFNSPEC UCONSTTRIP(%INTEGER OPERN,OPTYPE,FLAGS,CONST) %INTEGERFNSPEC ULCONSTTRIP(%INTEGER OPERN,OPTYPE,FLAGS,CONST1,CONST2) %INTEGERFNSPEC UNAMETRIP(%INTEGER OPERN,OPTYPE,FLAGS,NAME) %INTEGERFNSPEC UTEMPTRIP(%INTEGER OPERN,OPTYPE,FLAGS,TEMP) %INTEGERFNSPEC BRECTRIP(%INTEGER OPERN,OPTYPE,FLAGS, %RECORD(RD)%NAME OPND1,OPND2) %INTEGERFNSPEC URECTRIP(%INTEGER OPERN,OPTYPE,FLAG,%RECORD(RD)%NAME OPND1) %ROUTINESPEC KEEPUSECOUNT(%RECORD(RD)%NAME OPND) %ROUTINESPEC CSS(%INTEGER P) %CYCLE I=0, 1, MAXLEVELS LEVELINF(I)=0 LEVELINF(I)_NAMES=-1 %REPEAT CTABLE==ARRAY(ADDR(ASLIST(1)),CF) WORKA_CTABLE==CTABLE WORKA_LEVELINF==LEVELINF CTABLE(0)=M'CTAB' LINE=0 TWSPHEAD=0 FORCNT=0; ! COUNTS FORS TO DETECT NESTING FORDPTH=0; ! COUNTS DEPTH OF NESTED FORS FORCECNT=0; ! UPDATED WHEN TRIPLES FORCED OUT ! KEPT SO THAT GLAENING IS POSSIBLE PROLOGUE(ASLIST) NEXTTRIP=1 TRIPLES(0)=0 NEXTP=1; LEVEL=1; STMTS=0 CURRINF==LEVELINF(LEVEL) RLEVEL=0; RBASE=0 CURRINF=0 CURRINF_CLEVEL=LEVEL CURRINF_NAMES=-1 %WHILE A(NEXTP+3)!A(NEXTP+4)#0 %CYCLE COMPILE A STMNT %REPEAT LINE=99999 EPILOGUE(STMTS) %IF HOST=PERQ %START *RETURN; ! JUMP WONT REACH! %FINISH %ELSE ->P2END %ROUTINE FORCE TRIPS !*********************************************************************** !* FORCE OUT THE TRIPLES TO CODE. NEEDED IN CEND ETC * !*********************************************************************** %RETURN %IF NEXT TRIP=1 FORCECNT=FORCECNT+1 %IF PARM_OPT=0 %THEN TRIP OPT(TRIPLES,NEXT TRIP) GENERATE(TRIPLES,LEVEL,GET WSP) TRIPLES(0)=0 NEXTTRIP=1 TRIPLES(0)_FLINK=NEXT TRIP %IF TWSPHEAD#0 %THEN REUSE TEMPS %END %ROUTINE COMPILE A STMNT %INTEGER I FORCE TRIPS %IF NEXT TRIP>199 %OR(NEXT TRIP>1 %AND PARM_OPT#0) I=NEXTP STARSIZE=A(NEXTP)<<16+A(NEXTP+1)<<8+A(NEXTP+2) NEXTP=NEXTP+STARSIZE LINE=A(I+3)<<8+A(I+4) STMTS=STMTS+1 CSS(I+5) ! %CYCLE I=0,1,4 ! %REPEAT ! CHECK ASL %IF LINE&7=0 %END %ROUTINE CSS(%INTEGER P) %ROUTINESPEC ENTER JUMP(%INTEGER MASK,STAD,FLAG) %INTEGERFNSPEC ENTER LAB(%INTEGER M,FLAG) %ROUTINESPEC REMOVE LAB(%INTEGER LAB) %ROUTINESPEC SAVE STACK PTR %ROUTINESPEC CEND(%INTEGER KKK) %INTEGERFNSPEC CCOND(%INTEGER CTO,A,B,JFLAGS) %INTEGERFNSPEC REVERSE(%INTEGER MASK) %ROUTINESPEC SET LINE %ROUTINESPEC CUI(%INTEGER CODE) %ROUTINESPEC ASSIGN(%INTEGER A,B) %ROUTINESPEC CSTART(%INTEGER CCRES,MODE) %INTEGERFNSPEC CHECKBLOCK(%INTEGER P,PIN) %ROUTINESPEC CCYCBODY(%INTEGER UA,ELAB,CLAB) %ROUTINESPEC CLOOP(%INTEGER ALT,MARKC,MARKUI) %ROUTINESPEC CIFTHEN(%INTEGER MARKIU,MARKC,MARKUI,MARKE,MARKR,SKIP) %INTEGERFNSPEC CREATE AH(%INTEGER MODE,%RECORD(RD)%NAME EOPND,NOPND) %ROUTINESPEC TORP(%INTEGERNAME HEAD,BOT,NOPS) %INTEGERFNSPEC INTEXP(%INTEGERNAME VALUE,%INTEGER PRECTYPE) %INTEGERFNSPEC CONSTEXP(%INTEGER PRECTYPE) %ROUTINESPEC CSEXP(%INTEGER MODE) %ROUTINESPEC CSTREXP(%INTEGER B) %ROUTINESPEC CRES(%INTEGER LAB) %ROUTINESPEC EXPOP(%INTEGERNAME A,B,%INTEGER C,D) %ROUTINESPEC TEST APP(%INTEGERNAME NUM) %ROUTINESPEC SKIP EXP %ROUTINESPEC SKIP APP %ROUTINESPEC NO APP %INTEGERFNSPEC DOPE VECTOR(%INTEGER A,B,C,MODE,ID,%INTEGERNAME C,D) %ROUTINESPEC DECLARE ARRAYS(%INTEGER A,B) %ROUTINESPEC DECLARE SCALARS(%INTEGER B) %ROUTINESPEC CRSPEC(%INTEGER M) %INTEGERFNSPEC SET SWITCHLAB(%INTEGER HEAD,LAB,FNAME,BIT) %ROUTINESPEC CFPLIST(%INTEGERNAME A,B) %ROUTINESPEC CFPDEL %ROUTINESPEC CLT %INTEGERFNSPEC ROUNDING LENGTH(%INTEGER PTYPE,RULES) %ROUTINESPEC CQN(%INTEGER P) %INTEGERFNSPEC TSEXP(%INTEGERNAME VALUE) %ROUTINESPEC CRCALL(%INTEGER RTNAME) %ROUTINESPEC NAMEOP(%INTEGER Z,SIZE,NAMEP) %ROUTINESPEC CNAME(%INTEGER Z) %ROUTINESPEC CANAME(%INTEGER Z,ARRP,%RECORD(RD)%NAME HDOPND) %ROUTINESPEC CSNAME(%INTEGER Z) %ROUTINESPEC COPY TAG(%INTEGER KK,DECLARE) %ROUTINESPEC REDUCE TAG(%INTEGER DECLARE) %ROUTINESPEC STORE TAG(%INTEGER KK,LEVEL,RBASE,J,SNDISP,ACC,SLINK,KFORM) %ROUTINESPEC UNPACK %ROUTINESPEC PACK(%INTEGERNAME PTYPE) %ROUTINESPEC RDISPLAY(%INTEGER KK) %ROUTINESPEC RHEAD(%INTEGER RTNAME,AXNAME) %INTEGERFNSPEC CFORMATREF %ROUTINESPEC CRFORMAT(%INTEGERNAME OPHEAD,OPBOT,NLIST,MRL,%INTEGER INIT) %INTEGERFNSPEC DISPLACEMENT(%INTEGER LINK) %INTEGERFNSPEC COPY RECORD TAG(%INTEGERNAME SUBS) %SWITCH SW(1:24) %CONSTBYTEINTEGERARRAY FCOMP(0:14)=0, 8,10,2,7,12,4,7, 8,12,4,7,10,2,7; %INTEGER SNDISP,ACC,K,KFORM,STNAME,MIDCELL %INTEGER TCELL,JJ,JJJ,KK,QQ,MARKER,REPORTUI,XDISP,MASK, %C BASE,AREA,ACCESS,DISP,EXTRN, CURR INST,VALUE,STRINGL, %C PTYPE,I,J,OLDI,USEBITS,STRFNRES,MARKIU,MARKUI,MARKC,MARKE,MARKR,INAFORMAT %INTEGER LITL,ROUT,NAM,ARR,PREC,TYPE %RECORD(RD) EXPOPND,NAMEOPND,MLOPND; ! RESULT RECORD FOR EXPOP&CNAME CURR INST=0; INAFORMAT=0 ->SW(A(P)) SW(13): ! INCLUDE SOMETHING SW(24): ! REDUNDANT SEP SW(2): ! CSSEXIT: LAST INST=CURR INST %RETURN SW(1): !(UI)(S) FAULT(57,0,0) %UNLESS LEVEL>=2 MARKER=P+1+A(P+1)<<8+A(P+2) P=P+3 ->LABFND %IF A(MARKER)=1 %IF A(MARKER)=2 %THEN SET LINE %AND CUI(0) %AND ->CSSEXIT MARKE=0; MARKR=0 MARKUI=P; MARKIU=MARKER+1 MARKC=MARKIU+1 %IF A(MARKER)=3 %THEN CIFTHEN(MARKIU,MARKC,MARKUI,0,0,NO) %C %AND ->CSSEXIT CLOOP(A(MARKIU),MARKC+2,MARKUI) ->CSSEXIT LABFND: OLDLINE=0 ->SWITCH %UNLESS A(P)=1 %AND A(P+5)=2; ! 1ST OF UI AND NO APP ->SWITCH %UNLESS A(P+6)=2 %AND A(P+7)=2;! NO ENAMSE OR ASSNMNT JJ=ENTER LAB(FROM AR2(P+3),0) FORCE TRIPS %IF PARM_OPT=0 ->CSSEXIT SW(5): ! %CYCLE FAULT(57,0,0) %UNLESS LEVEL>=2 %IF A(P+5)=2 %THEN %START; ! OPEN CYCLE CLOOP(0,P+1,P+1) %FINISH %ELSE %START SET LINE CLOOP(6,P+6,P+1) %FINISH ->CSSEXIT ! SW(6): ! REPEAT ->CSSEXIT SW(22): ! '%CONTROL' (CONST) FORCE TRIPS %IF PARM_OPT=0 J=FROM AR4(P+2) PARM_DCOMP=J>>28; ->CSSEXIT ! SW(3): ! (%IU)(COND)%THEN(UI)(ELSE') MARKIU=P+1; MARKC=MARKIU+3 MARKR=P+2+A(P+2)<<8+A(P+3); ! ! FROMAR2(P+2) MARKE=0 %IF A(MARKR)=3 %THEN %START MARKE=MARKR+1+FROMAR2(MARKR+1) MARKUI=MARKR+3 %FINISH CIFTHEN(MARKIU,MARKC,MARKUI,MARKE,MARKR,NO) ->CSSEXIT SW(4): ! '%FINISH(ELSE')(S) SW(18): ! '%ELSE' MEANING FINISH ELSE START ->CSSEXIT SWITCH: %BEGIN; ! SWITCH LABEL %INTEGER NAPS,FNAME FNAME=FROM AR2(P+3) %UNLESS A(P)=1 %AND A(P+5)=1 %THEN FAULT(5,0,FNAME) %AND ->BEND ! 1ST OF UI + APP P=P+3; TEST APP(NAPS) P=P+6 %UNLESS INTEXP(JJ,MINAPT)=0 %THEN FAULT(41,0,0) %AND ->BEND ! UNLESS EXPRESSION EVALUATES AND %UNLESS NAPS=1 %THEN FAULT(21,NAPS-1,FNAME) %AND ->BEND ! NO REST OF APP %UNLESS A(P+1)=2=A(P+2) %THEN FAULT(5,0,FNAME) %AND ->BEND ! NO ENAME OR REST OF ASSIGMENT COPY TAG(FNAME,NO) %IF OLDI#LEVEL %OR TYPE#6 %THEN FAULT(4,0,FNAME) %AND ->BEND %IF SET SWITCHLAB(K,JJ,FNAME,1)#0 %THEN FAULT(6,JJ,FNAME) BEND: %END FORCE TRIPS %IF PARM_OPT=0 ->CSSEXIT SW(23): ! SWITCH(*): %BEGIN %RECORD(LISTF)%NAME LCELL %INTEGER FNAME,JJ,RES FNAME=FROM AR2(P+1) COPY TAG (FNAME,NO) %IF OLDI=LEVEL %AND TYPE=6 %START LCELL==ASLIST(K) %CYCLE JJ=LCELL_S2,1,LCELL_S3 RES=SET SWITCHLAB(K,JJ,FNAME,0) %REPEAT %FINISH %ELSE FAULT(4,0,FNAME) %END FORCE TRIPS %IF PARM_OPT=0 ->CSSEXIT ! SW(7): ! (%WU)(SC)(COND)(RESTOFWU) FAULT(57,0,0) %UNLESS LEVEL>=2 MARKIU=P+1; ! TO WHILE/UNTIL MARKC=MARKIU+3; ! TO (SC)(COND) CLOOP(A(MARKIU)+3,MARKC,MARKIU+1+FROMAR2(MARKIU+1)) ->CSSEXIT ! SW(8): ! SIMPLE DECLN FAULT(57,0,0) %UNLESS LEVEL>=2 FAULT(40,0,0) %IF CURRINF_NMDECS&1#0 P=P+1 MARKER=P+FROMAR2(P); ! TO ALT OF DECLN P=P+2; ROUT=0; LITL=0 %IF A(MARKER)#1 %THEN %START; ! ARRAY DECLARATIONS CLT %IF TYPE=5 %AND (ACC<=0 %OR ACC>256) %THEN %C FAULT(70,ACC-1,0) %AND ACC=255 NAM=0 SET LINE QQ=2-A(P+1); P=P+2; ! QQ=1 FOR ARRAYFORMATS DECLARE ARRAYS(QQ,KFORM) FORCE TRIPS %IF PARM_OPT=0 %FINISH %ELSE %START CLT CQN(P+1); P=P+2 DECLARE SCALARS(KFORM) %FINISH ->CSSEXIT ! SW(9): ! %END %BEGIN %SWITCH S(1:5) -> S(A(P+1)) S(1): ! ENDOFPROGRAM S(2): ! ENDOFFILE %IF PARM_CPRMODE=0 %THEN PARM_CPRMODE=2 FAULT(15,LEVEL+PARM_CPRMODE-3,0) %UNLESS LEVEL+PARM_CPRMODE=3 CEND(PARM_CPRMODE) ->BEND S(3): ! ENDOFLIST ->BEND S(4): ! END %IF PARM_CPRMODE=1 %AND LEVEL=2 %THEN FAULT(14,0,0) %ELSE %C CEND(CURRINF_FLAG) BEND: %END ->CSSEXIT ! SW(11): %BEGIN %INTEGER MARKER1,RTNAME,KKK,PTR,PTYPEP,CNT,PP,PCHAIN,AXNAME,PNAME, NPARAMS,SCHAIN,PARMSPACE,D %RECORD(LISTF)%NAME LCELL,TCELL P=P+1; MARKER1=FROM AR2(P)+P; ! (SEX)(RT)(SPEC')(NAME)(FPP) AGN: Q=P; RTNAME=FROM AR2(MARKER1+1); ! RTNAME ON NAME EXTRN=A(P+2); ! 1=SYSTEM,2=EXTERNAL ! 3=DYNAMIC, 4=INTERNAL LITL=EXTRN&3 %IF A(MARKER1)=1 %THEN %START; ! P<%SPEC'>='%SPEC' P=P+3; CRSPEC(1-EXTRN>>2); ! 0 FOR ROUTINESPEC ! 1 FOR EXTERNAL (ETC) SPEC ->BEND %FINISH FORCE TRIPS; ! IN CASE OPTIMISING COPY TAG(RTNAME,NO) AXNAME=ADDR(WORKA_LETT(WORD(RTNAME))) %IF EXTRN=3 %THEN EXTRN=2 %IF TARGET=EMAS %AND EXTRN=1 %THEN WARN(11,0) %IF A(MARKER1+3)=1 %THEN %START MOVE BYTES(A(MARKER1+4)+1,ADDR(A(0)),MARKER1+4, ADDR(A(0)),WORKA_ARTOP) AXNAME=ADDR(A(WORKA_ARTOP)) WORKA_ARTOP=(WORKA_ARTOP+3+A(MARKER1+4))&(-4) %FINISH %IF EXTRN=4 %THEN AXNAME=0 %IF OLDI#LEVEL %THEN %START; ! NAME NOT KNOWN AT THIS LEVEL P=Q+3; CRSPEC(0); P=Q; ->AGN %FINISH %ELSE %START; ! NAME ALREADY KNOWN AT THIS LEVEL %IF PARM_CPRMODE=0 %THEN PARM_CPRMODE=2; ! FLAG AS FILE OF ROUTINES FAULT(56,0,RTNAME) %UNLESS EXTRN=4 %OR %C (PARM_CPRMODE=2 %AND LEVEL=1) %IF A(P+3)=1 %THEN KKK=LITL<<14!X'1000' %ELSE %START ROUT=1; P=P+4; ! FIGURE OUT PTYPE FOR FNS&MAPS CLT; ARR=0; NAM=0 %IF A(P)=2 %THEN NAM=2; ! SET NAME ARRAY BIT FOR MAPS PACK(KKK); ! AND STORE PTYPE IN KKK %FINISH %FINISH ! ! UNLESS A MATCH WAS OBTAINED BETWEEN HEADING AND SPEC SOMETHING ! HAS GONE WRONG. COMPILE HEADING AGAIN AS SPEC. THIS WILL ! PREVENT ANY INCONSISTENCIED AND CAUSE A "NAME SET TWICE" ! FOR ANY ERROR ! %UNLESS (J=15 %OR J=7*EXTRN) %AND PTYPE&X'FFFF'=KKK %START P=Q+3; CRSPEC(0); P=Q; ->AGN %FINISH PTYPE=PTYPE!(EXTRN&3)<<14; ! DEAL WITH %ROUTINESPEC FOLLOWED ! BY %EXTERNALROUTINE ! ! RESET THE TAGS TO BODY GIVEN AND ALLOWING FOR SPEC/EXTERNALROUTINE ! AND EXTERNALSPEC/EXTERNAL ROUTINE COMBINATIONS. RESTORE THE USE ! BITS WHICH WILL SHOW USED AS A RESULT OF THE COPY TAG IN THIS SEQUENCE ! TCELL==ASLIST(TAGS(RTNAME)) TCELL_PTYPE<-PTYPE TCELL_UIOJ<-TCELL_UIOJ&X'3FF0'!USEBITS<<14 ! NEWPTYPE & SET J=0 %IF J=14 %THEN TCELL_S2=WORKA_RTCOUNT %AND %C WORKA_RTCOUNT=WORKA_RTCOUNT+1; ! NO RT NO ALLOCATED TO EXTERNAL SPECS PTYPEP=PTYPE PCHAIN=TCELL_SLINK; ! CHAIN OF PARAMETER DESCRIPTUONS RHEAD(RTNAME,AXNAME); ! FIRST PART OF ENTRY SEQUENCE ! ! NOW DECLARE THE FORMAL PARAMETERS. FOLLOW BY CLAIMING DISPLAY ! AND SETTING DIAGNOSTIC PTR IN ROUTINE RDISPLAY ! P=MARKER1+4 %IF A(P-1)=1 %THEN P=P+A(P)+1; ! SKIP OVER ALIASNAME CNT=0 PTYPE=PTYPEP; UNPACK N=RTPARAM1OFFSET %IF TARGET=PERQ %OR TARGET=ACCENT %START %IF TYPE#0 %THEN N=(BYTES(PREC)+1)&(-2) %IF TYPE=5 %OR TYPE=3 %THEN N=4;! MAPS %IF NAM#0 %THEN %START %IF TYPE=5 %THEN N=4 %ELSE N=PTRSIZE(PTYPE&127);! BYTE MAPS RETURN BYTE PTR %FINISH CURRINF_RESSIZE=N %FINISH NPARAMS=0; PARMSPACE=0 %IF PCHAIN#0 %THEN NPARAMS=ASLIST(PCHAIN)_S3 %IF NPARAMS#0 %THEN PARMSPACE=NPARAMS>>16 %AND NPARAMS=NPARAMS&X'FF' ! ALLOW ACTUAL PARAMETER SPACE %WHILE A(P)=1 %CYCLE; ! WHILE SOME (MORE) FP PART PP=P+1+FROMAR2(P+1) P=P+3 CFPDEL PTR=P %UNTIL A(PTR-1)=2 %CYCLE; ! CYCLE DOWN NAMELIST %IF PARAMS BWARDS=YES %START;! MAP PCHAIN TO REVERSE ORDER LIST PCHAIN=TCELL_SLINK PCHAIN=ASLIST(PCHAIN)_LINK %FOR KKK=2,1,NPARAMS-CNT %FINISH %IF PCHAIN#0 %THEN %START LCELL==ASLIST(PCHAIN); ! EXTRACT PTYPE XTRA INFO %UNLESS LCELL_PTYPE=PTYPE %AND LCELL_ACC=ACC %C %THEN FAULT(9,CNT+1,RTNAME) %FINISH PNAME=FROM AR2(PTR); ! NAME FOR PARAM INTERNALLY LCELL_UIOJ=LCELL_UIOJ!PNAME<<4;! SAVED IN LIST D=LCELL_SNDISP+N; ! PARAMETER OFFSET %IF ROUT=1 %START; ! PROCEDURE PARAMETERS P=PTR P=P+3 %UNTIL A(P-1)=2 CFPLIST(SCHAIN,KKK); ! PARAMETERLIST FOR PASSED PROC PTYPE=LCELL_PTYPE; ! CHANGED BY CFPLIST STORETAG(PNAME,LEVEL,RBASE,13,D,LCELL_ACC,SCHAIN,0) %FINISH %ELSE %START %IF TARGET=EMAS %AND PTYPE=X'33' %C %THEN D=D+8; ! FOR HISTORIC PARAMTER COMPATABILITY %IF STRVALINWA=YES %AND PTYPE=X'35' %THEN PTYPE=X'435' STORE TAG(PNAME,LEVEL,RBASE,LCELL_UIOJ&15,0,ACC,D,KFORM) %IF STRVALINWA=YES %AND PTYPE=X'435' %THEN PTYPE=LCELL_PTYPE %FINISH PTR=PTR+3 CNT=CNT+1 PCHAIN=LCELL_LINK %IF PARAMS BWARDS=NO %REPEAT P=PP %REPEAT; ! UNTIL NO MORE FP-PART N=N+PARMSPACE N=(N+MINPARAMSIZE-1)&(-MINPARAMSIZE);! TO WORD BOUNDARY AFTER ALL SYSTEM ! STANDARD PARAMETERS HAVE BEEN DECLARED FAULT(8,0,RTNAME) %IF CNT>NPARAMS FAULT(10,0,RTNAME) %IF CNTCSSEXIT ! SW(14): ! %BEGIN %BEGIN FORCE TRIPS; ! IN CASE OPTIMISING PTYPE=0 %IF LEVEL=1 %AND RLEVEL=0 %START %IF PARM_CPRMODE=0 %THEN %START RLEVEL=1; RBASE=1 PARM_CPRMODE=1 RHEAD(-1,ADDR(MAINEP)) N=RTPARAM1OFFSET %FINISH %ELSE FAULT(58,0,0) %FINISH %ELSE %START SET LINE; ! SO 'ENTERED FROM LINE' IS OK RHEAD(-1,0) %FINISH RDISPLAY(-1) %END ->CSSEXIT ! SW(15): ! '%ON'(EVENT')(N)(NLIST)'%START' FAULT(57,0,0) %UNLESS LEVEL>=2 FAULT(40,0,0) %IF CURRINF_NMDECS&1#0 FORCE TRIPS; ! IN CASE OPTIMISING CURRINF_NMDECS=CURRINF_NMDECS!X'11';! NO MORE DECS AND IN ONCOND %IF TARGET=EMAS %THEN SAVE STACK PTR;! NEEDED WITH AUXSTACKS ONLY JJ=UCONSTTRIP(ONEV1,X'51',DONTOPT,0);! SAVE PROGRAM MASK ETC PLABEL=PLABEL-1 JJJ=PLABEL ENTER JUMP(15,JJJ,B'10'); ! JUMP ROUND ON BODY ! P=P+1; JJ=0; ! SET UP A BITMASK IN JJ %UNTIL A(P)=2 %CYCLE; ! UNTIL NO MORE NLIST KK=-1; P=P+4 FAULT(26,KK,0) %UNLESS INTEXP(KK,MINAPT)=0 %AND 1<=KK<=14 JJ=JJ!1<<(KK-1) %REPEAT P=P+1 CURRINF_ONWORD=JJ<<18 LEVELINF(0)_ONWORD=LEVELINF(0)_ONWORD!JJ<<18 CURRINF_ONINF=N; N=N+12 JJ=UCONSTTRIP(ONEV2,X'51',DONTOPT,JJ) OLDLINE=0 CSTART(0,3) CURRINF_NMDECS=CURRINF_NMDECS!!X'10';! NOT IN ONCOND JJ=ENTER LAB(JJJ,B'011'); ! MERGE ENVIRONMENT ->CSSEXIT SW(16): %BEGIN; ! %SWITCH (SWITCH LIST) %INTEGER Q,RANGE,KKK,LB,UB,PP,D0,OPHEAD,V,R %RECORD(RD) OPND1,OPND2 FAULT(57,0,0) %UNLESS LEVEL>=2 Q=P %UNLESS TARGET=EMAS %THEN PLABEL=PLABEL-1 %AND ENTER JUMP(15,PLABEL,0) %UNTIL A(Q)=2 %CYCLE; ! UNTIL NO'REST OF SW LIST' P=P+3 P=P+3 %WHILE A(P)=1 P=P+4; ! TO P(+') KKK=INTEXP(LB,MINAPT); ! EXTRACT LOWER BOUND P=P+3 KKK=KKK!INTEXP(UB,MINAPT); ! EXTRACT UPPER BOUND RANGE=(UB-LB+1) %IF RANGE<=0 %OR KKK#0 %START FAULT(38,1-RANGE,FROMAR2(Q+1)) LB=0; UB=10; RANGE=11 %FINISH PTYPE=X'56'+1<<8; ! WORD LABEL ARRAY PP=P; P=Q+1 %UNTIL A(P-1)=2 %CYCLE; ! DOWN NAMELIST K=FROM AR2(P) P=P+3 OPHEAD=0; R=LB ! ! SET UP A BIT LIST (96 BITS PER CELL) TO CHECK FOR SWITCH LABELS ! SET TWICE ! %UNTIL R>UB %CYCLE PUSH(OPHEAD,0,0,0) R=R+96 %REPEAT OPND1_S1=PTYPE<CSSEXIT ! SW(17): ->CSSEXIT ! SW(12): ! '%OWN' (TYPE)(OWNDEC) %BEGIN !*********************************************************************** !* INITIALISED DECLARATION GO INTO THE GLA OR GLA SYMBOL TABLES * !* EXCEPT FOR CONST ARRAYS WHICH GO INTO THE CODE SYMBOL TABLES * !* STRINGS AND ARRAYS HAVE A HEADER IN THE GLA. QPUT ARRANGES * !* FOR THE LOADER TO RELOCATE THE HEADERS. * !* EXTERNALS ARE IDENTICAL WITH OWN BUT ALSO HAVE A DATA EP DEFN * !* IN THE LOAD DATA SO THEY CAN BE FOUND AT LOAD TIME * !* EXTRINSICS HAVE A DATA REFERENCE AND A DUMMY HEADER IN THE GLA* !* THE LOADER USES THE FORMER TO RELOCATE THE LATTER. * !*********************************************************************** %ROUTINESPEC CLEAR(%INTEGER L) %ROUTINESPEC XTRACT CONST(%INTEGER CONTYPE, CONPREC) %ROUTINESPEC INIT SPACE(%INTEGER A, B) %INTEGER SLENGTH, PP, SIGN, TAGDISP, DVO, K, STALLOC, SPOINT, CONSTSFOUND, CPREC, EXTRN, NNAMES, %C MARK, QPUTP, LB, CTYPE, CONSTP, FORMAT,DPTYPE, %C DIMEN, SACC, TYPEP, KK %RECORD(RD) COPND,FCOPND %OWNLONGREAL ZERO=0 %STRING (255) SCONST, NAMTXT %RECORD(LISTF)%NAME LCELL %INTEGERNAME STPTR QPUTP=5; STPTR==USTPTR; ! NORMAL CASE GLA SYMBOLTABLES ! FAULT(40,0,0) %IF NMDECS&1#0 EXTRN=A(P+1) P=P+2 %IF EXTRN>=4 %THEN EXTRN=0; ! CONST & CONSTANT->0 SNDISP=0 CONSTS FOUND=0 %IF EXTRN=0 %THEN QPUTP=4 %AND STPTR==SSTL CLT ! ! CHECK FOR %SPEC AND CHANGE EXTERNAL SPEC TO EXTRINSIC ! %IF A(P+2)=1 %START %IF EXTRN=2 %THEN EXTRN=3 %ELSE FAULT(46,0,0) %FINISH %IF 2<=EXTRN<=3 %AND ((A(P)=1 %AND A(P+1)#3) %OR %C (A(P)=2 %AND A(P+1)#2)) %THEN FAULT(46,0,0) LITL=EXTRN %IF LITL<=1 %THEN LITL=LITL!!1 %IF A(P)=1 %THEN CQN(P+1) %ELSE ARR=1 %AND NAM=0 %IF TYPE=5 %AND NAM=0 %AND (ACC<=0 %OR ACC>256) %THEN %C FAULT(70,ACC-1,0) %AND ACC=2 STALLOC=ACC; ! ALLOCATION OF STORE FOR ITEM OR POINTER %IF (TARGET=PERQ %OR TARGET=ACCENT %OR TARGET=PNX) %AND TYPE=5 %THEN %C STALLOC=(STALLOC+1)&X'FFE' ROUT=0; PACK(PTYPE); DPTYPE=PTYPE;! FOR DECLARATION %IF NAM#0 %START; ! OWN POINTERS %IF ARR#0 %THEN STALLOC=8 %ELSE STALLOC=4 %FINISH %ELSE %START; ! OWN VARS & ARRAYS ->NON SCALAR %IF ARR#0 %FINISH P=P+2 %UNTIL A(MARK)=2 %CYCLE; ! UNTIL NULL MARK=P+1+FROM AR2(P+1) PP=P+3; P=PP+2; ! PP ON FIRST NAME' K=FROM AR2(PP); ! FOR ERROR MESSAGES RE CONST NAMTXT=STRING(ADDR(WORKA_LETT(WORD(K)))) %IF A(P)=1 %THEN %START; ! ALAIS GIVEN %IF LITL=0 %THEN WARN(10,0) LENGTH(NAMTXT)=A(P+1) CHARNO(NAMTXT,KK)=A(P+KK+1) %FOR KK=1,1,A(P+1) P=P+A(P+1)+1 %FINISH P=P+1; ! P ON CONST' ! ! OBTAIN THE INITIAL CONSTANT,ITS TYPE(CTYPE) AND SIGN(SIGN) ! SCONST="" PTYPE=DPTYPE; UNPACK; ! MAY HAVE BEEN CONSTANT EVALUATIONS ! WHICH HAVE CHANGED PTYPE SIGN=3; CTYPE=TYPE; CONSTSFOUND=0; CPREC=PREC %IF TYPE=3 %THEN CTYPE=1; ! RECS INITTED TO REPEATED BYTE %IF NAM#0 %THEN CTYPE=1 %AND CPREC=5 P=P+1 %IF A(P-1)=1 %THEN %START; ! CONSTANT GIVEN XTRACT CONST(CTYPE,CPREC) %FINISH %ELSE %START WARN(7,K) %IF EXTRN=0; ! %CONST NOT INITIALISED FCOPND=0; COPND=0 %FINISH J=0 %IF NAM#0 %THEN %START; ! OWNNAMES AND ARRAYNAMES %IF ARR=0 %THEN %START TAGDISP=PINITOWN(PTYPE,ACC,FCOPND,NAMTXT) %FINISH %ELSE %START; ! ARRAYNAMES DVO=DOPE VECTOR(NO,TYPE,ACC,-1,K,QQ,LB) %IF PARM_COMPILER#0 %AND LB#0 %THEN FAULT(99,0,0) %IF EXTRN#0 %THEN SNDISP=0 %AND J=0 %ELSE %C J=1 %AND SNDISP=(SNDISP&X'3FFFF')>>2 TAGDISP=POWNARRAYHEAD(PTYPE,J,LB,X'FFFFFF', FCOPND_D,0,DVO,NAMTXT) %FINISH STORE TAG(K,LEVEL,0,J,SNDISP,ACC,TAGDISP,KFORM) P=MARK %CONTINUE %FINISH %IF EXTRN=3 %THEN %START; ! EXTRINISIC PTYPE=PTYPE!X'400'; ! FORCE NAM=1 (IE VIA POINTER) FCOPND_D=0 TAGDISP=PINITOWN(PTYPE,ACC,FCOPND,NAMTXT) STORE TAG(K,LEVEL,0,J,SNDISP,ACC,TAGDISP,KFORM) P=MARK %CONTINUE %FINISH %IF TYPE=3 %THEN %START; ! RECORDS TAGDISP=PINITOWN(PTYPE,ACC,COPND,NAMTXT) %FINISH %IF 1<BEND NONSCALAR: ! OWN AND OWNRECORD ARRAYS !*********************************************************************** !* OWN ARRAYS CAN BE INITIALISED BUT ONLY ONE ARRAY CAN BE * !* DECLARED IN A STATEMENT.(THANK HEAVENS!) * !* OWN RECORD ARRAYS ARE INITIALISED AS BYTE ARRAYS * !*********************************************************************** P=P+1 FORMAT=2-A(P) %IF FORMAT#0 %THEN ARR=3 %AND PACK(PTYPE) PP=P+2; P=P+4; NNAMES=1 K=FROM AR2(PP) NAMTXT=STRING(ADDR(WORKA_LETT(WORD(K)))) %IF A(P)=1 %THEN %START; ! ALAIS GIVEN %IF LITL=0 %THEN WARN(10,0) LENGTH(NAMTXT)=A(P+1) CHARNO(NAMTXT,KK)=A(P+KK+1) %FOR KK=1,1,A(P+1) P=P+A(P+1)+1 %FINISH P=P+1; ! P ON CONSTLIST SACC=ACC; TYPEP=PTYPE DVO=DOPE VECTOR(NO,TYPE,STALLOC,0,K,QQ,LB) %IF SNDISP=-1 %THEN SNDISP=0; ! BUM DOPE VECTOR SNDISP=(SNDISP&X'3FFFF')>>2; ! AS WORD DISPLACEMENT DIMEN=J; ! SAVE NO OF DIMENESIONS ACC=SACC; PTYPE=TYPEP; UNPACK %IF LB=0 %AND FORMAT=0 %THEN ARR=2 %AND PACK(PTYPE) %IF TYPE=3 %THEN SLENGTH=QQ %ELSE SLENGTH=QQ//STALLOC;! NO OF ELEMENTS SPOINT=STPTR %IF FORMAT=0 %THEN %START %IF A(P)=1 %THEN P=P+1 %AND INIT SPACE(QQ,SLENGTH) %FINISH %IF CONSTS FOUND=0 %THEN %START; ! NO CONSTANTS GIVEN ! SO CLEAR AN AREA TO ZERO CONSTS FOUND=SLENGTH CLEAR(QQ) %UNLESS SLENGTH<1 %OR EXTRN=3 %OR FORMAT#0 %FINISH %ELSE %START FAULT(49,0,K) %IF EXTRN=3 %OR FORMAT#0 %FINISH %IF EXTRN=3 %THEN SPOINT=0 ! ! OUTPUT AN ARRAYHEAD INTO THE GLA RELATIVE TO THE START OF THE SYMBOL- ! TABLES IN WHICH THE ARRAY RESIDES. ! TAGDISP=POWNARRAYHEAD(PTYPE,J,LB,QQ,SPOINT,QPUTP,DVO,NAMTXT) STORE TAG(K,LEVEL,0,J,SNDISP,ACC,TAGDISP,KFORM) ->BEND %ROUTINE INIT SPACE(%INTEGER SIZE, NELS) !*********************************************************************** !* P IS TO FIRST ENTRY FOR CONSTLIST * !* MAP SPACE ONTO WORKFILE END TO GIVE SANE ERROR MESSAGE IF * !* THERE WAS NOT ENOUGH SPACE * !*********************************************************************** %CONSTINTEGER BUFSIZE=512 %INTEGER RF, I, II, ELSIZE, AD, SPP, SLENGTH, WRIT %BYTEINTEGERARRAY SP(0:BUFSIZE+256) AD=ADDR(FCOPND_B0) ELSIZE=SIZE//NELS %IF ELSIZE=2 %AND TARGET#PERQ %AND TARGET#ACCENT %THEN AD=ADDR(FCOPND_H1) %IF TYPE=5 %THEN AD=ADDR(SCONST) SPP=0; WRIT=0 %UNTIL A(P-1)=2 %CYCLE XTRACT CONST(TYPE,PREC) %IF A(P)=1 %START; ! REPITITION FACTOR P=P+2 %IF A(P-1)=2 %THEN RF=NELS-CONSTS FOUND %ELSE %START P=P+2 %IF INTEXP(RF,MINAPT)#0 %THEN FAULT(41,0,0) %AND RF=1 %FINISH P=P+1 %FINISH %ELSE RF=1 %AND P=P+2 FAULT(42,RF,0) %IF RF<=0 %CYCLE I=RF,-1,1 %IF TYPE=1=ACC %OR TYPE=3 %START %CYCLE II=0,1,ELSIZE-1 %IF CONSTS FOUND<=NELS %THEN SP(SPP)<- %C COPND_D %AND SPP=SPP+1 %REPEAT %FINISH %ELSE %START %IF CONSTS FOUND<=NELS %THEN %C MOVE BYTES(ELSIZE,AD,0,ADDR(SP(0)),SPP) %AND SPP=SPP+ELSIZE %FINISH CONSTS FOUND=CONSTS FOUND+1 %IF SPP>=BUFSIZE %START; ! EMPTY BUFFER %IF HOST#TARGET %AND (TYPE=5 %OR (TYPE=1 %AND PREC=3))%C %THEN CHANGE SEX(ADDR(SP(0)),0,SPP) PDATA(QPUTP,1,SPP,ADDR(SP(0))) WRIT=WRIT+SPP SPP=0 %FINISH %REPEAT %REPEAT; ! UNTIL P=%NULL %IF CONSTS FOUND#NELS %THEN FAULT(45,CONSTS FOUND,NELS) SLENGTH=(SIZE+3)&(-4) %IF HOST#TARGET %AND(TYPE=5 %OR(TYPE=1 %AND PREC=3)) %C %THEN CHANGE SEX(ADDR(SP(0)),0,SLENGTH-WRIT) PDATA(QPUTP,1,SLENGTH-WRIT,ADDR(SP(0))) %END %ROUTINE CLEAR(%INTEGER SLENGTH) SLENGTH=(SLENGTH+3)&(-4) PRDATA(QPUTP,4,4,SLENGTH>>2,ADDR(ZERO)) %END %ROUTINE XTRACT CONST(%INTEGER CONTYPE, CONPREC) !*********************************************************************** !* P POINTS TO P<+'> OF <+'> AND IS UPDATED* !* THE CONST IS CONVERTED TO REQUIRED FORM AND IF INTEGER * !* IS LEFT IN ICONST, IF REAL IN RCONST AND IF STRING IN SCONST * !*********************************************************************** %INTEGER SLENGTH, STYPE, SACC, MODE, CH, WR, I STYPE=PTYPE; SACC=ACC; ! MAY BE CHANGED IF CONST IS EXPR %IF CONTYPE=5 %THEN %START P=P-3; CSTREXP(0) WR=WORKA_ARTOP %IF EXPOPND_FLAG=LCONST %AND EXPOPND_PTYPE=X'35' %START SLENGTH=EXPOPND_XTRA LENGTH(SCONST)=SLENGTH A(WR)=SLENGTH %FOR I=1,1,SLENGTH %CYCLE CH=A(EXPOPND_D+I) CHARNO(SCONST,I)=CH A(WR+I)=CH %REPEAT COPND_PTYPE=X'35'; COPND_FLAG=LCONST COPND_D=EXPOPND_D COPND_XTRA=SLENGTH %FINISH %ELSE %START FAULT(44,CONSTS FOUND,K); SCONST="" SLENGTH=0 %FINISH %FINISH %ELSE %START MODE=CONPREC<<4!CONTYPE %IF CONPREC<5 %THEN MODE=CONTYPE!X'50' CONSTP=CONSTEXP(MODE) %IF CONSTP=0 %THEN FAULT(41,0,0) ! CANT EVALUATE EXPT COPND=EXPOPND; ! GET RESULT OPND COPND_PTYPE=MODE %FINISH PTYPE=STYPE; UNPACK; ACC=SACC ! FAULT ANY OBVIOUS ERRORS IE:- ! CONSTANT FOR EXTRINSIC OR INCOMPATIBLE TYPE OR STRING TOO LONG %IF EXTRN=3 %THEN FAULT(49,0,K) %AND %RETURN %IF (CONTYPE=5 %AND SLENGTH>=ACC) %C %OR (CONTYPE=1 %AND ((CONPREC=3 %AND COPND_D>255) %C %OR (CONPREC=4 %AND COPND_D>X'FFFF'))) %C %THEN FAULT(44,CONSTS FOUND,K) ! ! IF CROSS COMPILING THEN A CONSTANT FORMAT CHANGE IS NEED FROM ! IBM&ICL FORM TO PERQ FORM. IF ON PERQ FORMAT IS CORRECT ! FCOPND=COPND %IF HOST#TARGET %THEN %START REFORMATC(FCOPND) %FINISH %END BEND: %END; ->CSSEXIT SW(10): %BEGIN; ! %RECORDFORMAT (RDECLN) %INTEGER NAME,OPHEAD,OPBOT,NLIST,MRL,CELLREF,FHEAD,SPEC %RECORD(LISTF)%NAME LCELL,FRCELL SNDISP=0 SPEC=A(P+1); ! 1 FOR SPEC 2 FOR FORMAT NAME=FROM AR2(P+2); P=P+4 COPY TAG(NAME,NO) %IF SPEC=1 %OR %NOT(PTYPE=4 %AND J=15 %AND OLDI=LEVEL) %START KFORM=0 PUSH(KFORM,0,0,0) PTYPE=4 STORE TAG(NAME,LEVEL,RBASE,15,0,X'7FFF',KFORM,KFORM);! IN CASE OF REFS IN FORMAT %FINISH %IF SPEC=2 %START OPHEAD=0; OPBOT=0 NLIST=0; MRL=0 INAFORMAT=1 CRFORMAT(OPHEAD,OPBOT,NLIST,MRL,X'80000000') INAFORMAT=0 CLEAR LIST(NLIST) ! ! IN CASE OF FORWARD REFS COPY TOP CELL OF FORMAT CHAIN INTO DUMMY ! SET UP BEFORE CALL OF CRFORMAT. ALSO RESET J&ACC TO CORRECT VALUE ! LCELL==ASLIST(TAGS(NAME)) KFORM=LCELL_KFORM POP(KFORM,I,I,FHEAD); ! THROW DUMMY CELL ! GET HEAD OF FORWARD REFS %WHILE FHEAD>0 %CYCLE; ! THROUGH FORWARD REFS POP(FHEAD,CELLREF,I,I) FRCELL==ASLIST(CELLREF) FRCELL_UIOJ=FRCELL_UIOJ&X'FFFFFFF0';! SET J BACK TO 0 FRCELL_ACC=ACC; ! ACC TO CORRECT VALUE FRCELL_KFORM=OPHEAD; ! CORRECT KFORM %REPEAT LCELL_UIOJ=LCELL_UIOJ&X'FFFFFFF0'; ! J BACK TO ZERO LCELL_ACC=ACC LCELL_SLINK=OPHEAD; ! KFORM&SLINK(HISTORIC) TO SIDECHAIN LCELL_KFORM=OPHEAD %FINISH %END;->CSSEXIT ! SW(19): ! '*' (UCI) (S) FAULT(57,0,0) %UNLESS LEVEL>=2 %BEGIN !*********************************************************************** !* COMPILE USERCODE INSTRUCTION. MOST WORK IS DONE BY HAIRY * !* BUILT-IN PHRASE IN COMPARE. SINCE ALMOST ANYTHING IS LEGAL * !* IN USERCODE THIS BLOCK HAS ONLT TO ASSEMBLE AND PLANT THE * !* THE INSTRUCTION. * !*********************************************************************** %SWITCH UCITYPE(1:5),QINST(1:7) %RECORD(RD) OPND %RECORD(TAGF)%NAME TCELL %INTEGER ALT,AALT,FNAME,OPTINC,OPC,KK,VAL1,VAL2,UCOP,TR,XTRA,H,Q %IF TARGET=EMAS %OR TARGET=IBM %OR TARGET=IBMXA %OR TARGET=AMDAHL %START %ROUTINE CUCS !*********************************************************************** !* SETS UP OPND FOR ASSEMBLER NAME(IE LOCAL OR CONST) * !*********************************************************************** %INTEGER ALT,FN0,D FN0=FROM AR2(P); P=P+2 COPY TAG(FN0,NO) %IF (LITL=1 %AND NAM=ARR=0) %START TCELL==ASLIST(TAGS(FN0)) OPND_PTYPE=PTYPE&255 OPND_D=TCELL_S2 OPND_XTRA=TCELL_S3 %FINISH %ELSE %START %IF TYPE>=6 %OR TYPE=4 %OR %C (ROUT=1 %AND NAM=0) %THEN FAULT(95,0,FN0) %AND %RETURN %IF ROUT=1 %THEN K=SNDISP; ! FORMAL RT DESCPTR OFFSET ALT=A(P); D=FROM AR2(P+1) %IF ALT=1 %THEN K=K+D %IF ALT=2 %THEN K=K-D P=P+1; P=P+2 %IF ALT<=2 OPND_FLAG=LOCALIR OPND_D=I<<16!K %FINISH %END %FINISH %IF TARGET=EMAS %START %ROUTINE CIND !*********************************************************************** !* COMPILE A SYMBOLIC OPERAND BY SETTING ACCESS,AREA &DISP * !*********************************************************************** %INTEGER ALT,FN0,JJ,D,CTYPE,CPREC,AREA %SWITCH SW(1:4) ALT=A(P) P=P+1; ->SW(ALT) SW(1): ! (PLUS')(ICONST) D=A(P); CTYPE=A(P+1) OPND_PTYPE=CTYPE CPREC=CTYPE>>4; CTYPE=CTYPE&7 %IF CPREC=4 %THEN OPND_D=FROM AR2(P+2) %ELSE %C %IF CPREC=7 %THEN OPND_D=P+2 %ELSE %C MOVE BYTES(BYTES(CPREC),ADDR(A(0)),P+2,ADDR(OPND_D),0) P=P+2+BYTES(CPREC) %IF D=2 %THEN %START JJ=11; ! UNARY NEGATE CTOP(JJ,D,0,OPND,OPND); ! NEGATE CONSTANT %FINISH FAULT(96,FN0,0) %UNLESS 1<=CTYPE<=2 %AND 4<=CPREC<=7 %RETURN SW(2): ! (NAME)(OPTINC) CUCS %RETURN SW(3): ! '('(REG)(OPTINC)')' AREA=A(P)+1; ALT=A(P+1); P=P+2 DISP=0 D=FROM AR2(P) %IF ALT=1 %THEN DISP=D %IF ALT=2 %THEN FAULT(96,-D,0) DISP=4*DISP P=P+2 %UNLESS ALT=3 OPND_FLAG=10 OPND_XB=AREA<<4 OPND_D=DISP %RETURN SW(4): ! '%TOS' OPND_FLAG=10; OPND_XB=X'60' %END %ROUTINE ULABREF !*********************************************************************** !* COMPILES USERCODE REF TO 2900 LABELS * !* LABELS MAY ONLY BE USED WITH JCC(2),JAT(4),JAF(6),J(1A),JLK(1C) * !* AND ALSO DEBJ(24) * !* FAULTED IN OTHER SITUATIONS.(IE MORE RESTRICTIVE THAN 2900IMP) * !*********************************************************************** %INTEGER MASK,LAB %IF OPC<=6 %THEN MASK=FROMAR2(P)+8*(OPC-2) %AND P=P+3 %C %ELSE %IF OPC=X'1A' %THEN MASK=15 %ELSE %C %IF OPC=X'1C' %THEN MASK=0 %ELSE %C %IF OPC=X'24' %THEN MASK=48 %ELSE FAULT(97,0,0) LAB=FROMAR2(P) ENTER JUMP(MASK,LAB,0) %END %FINISH %IF TARGET=IBM %OR TARGET=IBMXA %OR TARGET=AMDAHL %START %ROUTINE DB !*********************************************************************** !* COMPILES AN IBM DB FORMAT SECOND OPERAND REFERENCE * !*********************************************************************** %INTEGER ALT ALT=A(P); P=P+1; ! ALT OF DB %IF ALT=1 %START; ! NAME LOCAL OR CONST CUCS %FINISH %ELSE %START; ! EXPLICIT NUMERICAL FORM OPND_D=FROMAR2(P); P=P+2 OPND_FLAG=10 ALT=A(P); P=P+1 %IF ALT=1 %THEN OPND_XB=A(P) %AND P=P+1 %FINISH %END %ROUTINE DXB !*********************************************************************** !* COMPILES AN IBM DXB (AND DLB) FORMAT SECOND OPERAND REFERENCE * !* THE L IN DLB CAN BE UP TO 256 SO NEEDS 2 AR ENTRIES * !*********************************************************************** %INTEGER ALT ALT=A(P); P=P+1; ! ALT OF DXB %IF ALT=1 %START; ! NAME LOCAL OR CONST CUCS %IF A(P)=1 %AND OPND_FLAG=7 %THEN XTRA=FROMAR2(P+1) %AND P=P+2 P=P+1 %FINISH %ELSE %START; ! EXPLICIT NUMERICAL FORM OPND_D=FROMAR2(P); P=P+2 OPND_FLAG=10 ALT=A(P); P=P+1 %IF ALT=1 %THEN %START XTRA=FROMAR2(P); OPND_XB=A(P+2) P=P+3 %FINISH %IF ALT=2 %THEN OPND_XB=A(P) %AND P=P+1 %FINISH %END %FINISH OPC=0; XTRA=0 OPND=0 OPND_PTYPE=X'51' OPND_FLAG=1 ALT=A(P+1); P=P+2 ->UCITYPE(ALT) UCITYPE(1): ! **@'(NAME)(OPTINC) ! INVALID ON IBM ARCHITECTURES ! AS THERE IS NO ACCUMULATOR AALT=A(P); ! ALT OF @' FNAME=A(P+1)<<8!A(P+2) P=P+3; OPTINC=0 %IF A(P)#3 %START; ! THERE IS AN OPTINC OPTINC=FROMAR2(P+1) %IF A(P)=2 %THEN OPTINC=-OPTINC %FINISH COPY TAG(FNAME,NO) %IF TARGET=IBM %OR TARGET=IBMXA %OR TARGET=AMDAHL %OR TYPE>=6 %OR ROUT#0 %THEN FAULT(97,FNAME,0) UCOP=UCNAM OPND_PTYPE=X'61' OPND_D=AALT<<16!FNAME OPND_XTRA=OPTINC ->OTRIP UCITYPE(2): ! PUT (HEX HALFWORD) TYPE=A(P) PREC=TYPE>>4; TYPE=TYPE&7 FAULT(97,0,0) %UNLESS TYPE=1 %AND PREC<6 %IF PREC=5 %THEN P=P+2 OPND_D=FROM AR2(P+1); UCOP=UCB2 %IF TARGET=IBM %OR TARGET=IBMXA %OR TARGET=AMDAHL %THEN %C OPND_D=OPND_D>>8<<16!(OPND_D>>4&15)!((OPND_D&15)<<8) ->OTRIP UCITYPE(4): ! CNOP UCOP=UCNOP; OPND_D=FROM AR2(P) ->OTRIP UCITYPE(3): ! ASSEMBLER AALT=A(P); P=P+1 OPC=FROMAR2(P); P=P+2 %IF TARGET=PNX %OR TARGET=PERQ %OR TARGET=ACCENT %START P=P+3; ! TO START OF EXPR %IF AALT>1 %THEN %START KK=INTEXP(VAL1,MINAPT) FAULT(96,0,1) %UNLESS KK=0 %FINISH %IF AALT>=5 %START P=P+3 KK=INTEXP(VAL2,MINAPT) FAULT(96,0,2) %UNLESS KK=0 %FINISH %FINISH ->QINST(AALT) UCITYPE(5): ! OTHER M-CS ASSEMBLER FAULT(97,0,0) ->BEND QINST(1): ! ONE BYTE INSTRUCTION ! 2900 IS PRIMARY FORMAT INSTRUCTIONS ! IBM ONE REGISTER RR INSTRUCTIONS UCOP=UCB1 %IF TARGET=PNX %OR TARGET=PERQ %OR TARGET=ACCENT %THEN OPND_D=OPC %ELSE %C %IF TARGET=EMAS %START ALT=A(P); P=P+1 %IF ALT=1 %THEN ULABREF %AND ->BEND %IF ALT=2 %THEN CIND %ELSE %C %IF ALT=3 %THEN CIND %AND XTRA=4-A(P) %ELSE %C %IF ALT=4 %THEN CIND %AND XTRA=1 %ELSE %C %IF ALT=5 %THEN OPND_FLAG=10 %AND OPND_XB=X'74'-A(P) %ELSE %C %IF ALT=6 %THEN OPND_FLAG=10 %AND OPND_XB=X'70' %FINISH %ELSE %IF TARGET=IBM %OR TARGET=IBMXA %OR TARGET=AMDAHL %START VAL1=A(P); P=P+1 %IF OPC#10 %AND VAL1>15 %THEN FAULT(97,0,0) OPND_D=OPC<<16!VAL1 %FINISH ->OTRIP QINST(2): ! UNSIGNED BYTE OPERAND ! EMAS 2NDARY (STORE TO STORE) FORMAT ! IBM RR AND RRE INSTRUCTIONS UCOP=UCB2 %IF TARGET=PNX %OR TARGET=PERQ %OR TARGET=ACCENT %START FAULT(96,0,1) %UNLESS 0<=VAL1<=255 OPND_D=OPC<<8!VAL1 %FINISH %ELSE %IF TARGET=EMAS %START VAL1=0; VAL2=0; Q=0; JJ=0 H=2-A(P) %IF H=0 %THEN JJ=FROM AR2(P+1)-1 %AND P=P+2 FAULT(96,JJ+1,0) %UNLESS 0<=JJ<=127 ALT=A(P+1); P=P+2 %IF ALT=1 %THEN %START Q=1 VAL1=FROM AR2(P) VAL2=FROM AR2(P+2) P=P+4 %IF VAL1>255 %THEN FAULT(96,VAL1,0) %IF VAL2>255 %THEN FAULT(96,VAL2,0) %FINISH OPND_D=H<<31!Q<<30!JJ<<16!VAL1<<8!VAL2 %FINISH %ELSE %IF TARGET=IBM %OR TARGET=IBMXA %OR TARGET=AMDAHL %START VAL1=A(P); VAL2=A(P+1); P=P+2 FAULT(97,0,0) %IF VAL1>15 %OR VAL2>15 OPND_D=OPC<<16!VAL2<<8!VAL1 %FINISH ->OTRIP QINST(3): ! PERQ SIGNED BYTE OPERAND ! EMAS TERTIARY (JUMP) FORMAT ! IBM REGISTER STORE RX FORMAT %IF TARGET=PNX %OR TARGET=PERQ %OR TARGET=ACCENT %START UCOP=UCB2 FAULT(96,0,1) %UNLESS -128<=VAL1<=127 OPND_D=OPC<<8!(VAL1&255) %FINISH %ELSE %IF TARGET=EMAS %START UCOP=UCB3; ! DIFFERENT TRIPLE NEEDED FOR EMAS XTRA=FROMAR2(P) ALT=A(P+2) %IF ALT=1 %THEN ULABREF %AND ->BEND P=P+3 %IF ALT=2 %THEN %START CIND FAULT(97,0,0) %IF OPND_XB=X'60' %FINISH %ELSE %IF ALT=3 %START OPND_FLAG=10 OPND_XB=8-A(P) %FINISH %ELSE OPND_XB=1 %AND OPND_D=FROMAR2(P) %FINISH %ELSE %IF TARGET=IBM %OR TARGET=IBMXA %OR TARGET=AMDAHL %START UCOP=UCB3 VAL1=A(P); P=P+1; ! FIRST REGISTER OPERAND DXB FAULT(97,0,0) %IF XTRA>15 %OR VAL1>15 %OR OPND_XB>15 XTRA=XTRA<<8!VAL1 ! OPCODE R1 & INDEX IN _X1 ! DB VARIOUSLY IN OPND %FINISH ->OTRIP QINST(4): ! SIGNED WORD OPERAND ! IBM RS (REGISTER TO STORE) FORMAT %IF TARGET=PNX %OR TARGET=PERQ %OR TARGET=ACCENT %START FAULT(96,0,1) %IF %C (TARGET=PERQ %OR TARGET=ACCENT) %AND IMOD(VAL1)>X'7FFF' UCOP=UCW; OPND_PTYPE=X'61' OPND_D=OPC OPND_XTRA=VAL1 %FINISH %ELSE %IF TARGET=IBM %OR TARGET=IBMXA %OR TARGET=AMDAHL %START UCOP=UCB3; ! GENERATORS TREATS AS DXB VAL1=A(P); XTRA=A(P+1) P=P+2; DB FAULT(97,0,0) %IF XTRA>15 %OR VAL1>15 %OR OPND_XB>15 XTRA=XTRA<<8!VAL1 %FINISH ->OTRIP QINST(5): ! 2 UNSIGNED BYTE OPERANDS ! IBM STORE IMMEDIATE OR STORE FORMATS %IF TARGET=PNX %OR TARGET=PERQ %OR TARGET=ACCENT %START FAULT(96,0,1) %UNLESS 0<=VAL1<=255 FAULT(96,0,2) %UNLESS 0<=VAL2<=255 UCOP=UCB3; OPND_D=OPC<<16!VAL1<<8!VAL2 %FINISH %ELSE %IF TARGET=IBM %OR TARGET=IBMXA %OR TARGET=AMDAHL %START UCOP=UCW; DB ALT=A(P); P=P+1 %IF ALT=1 %START; ! IMMEDIATE OPERAND GIVEN P=P+3 KK=INTEXP(XTRA,X'51') FAULT(97,0,0) %UNLESS KK=0 %AND 0<=XTRA<=255 %AND OPC<255 %FINISH; ! NO OPERAND 0 ASSUMED ->OTRIP %FINISH ->OTRIP QINST(6): ! BYTE & WORD OPERANDS ! IBM SS AND SSE FORMATS %IF TARGET=PNX %OR TARGET=PERQ %OR TARGET=ACCENT %START FAULT(96,0,1) %UNLESS 0<=VAL1<=255 FAULT(96,0,2) %UNLESS IMOD(VAL2)<=X'7FFFF' I=UCBW; OPND_D=OPC<<24!VAL1<<16!(VAL2&X'FFFF') %FINISH %ELSE %IF TARGET=IBM %OR TARGET=IBMXA %OR TARGET=AMDAHL %START DXB TR=URECTRIP(UCNAM,0,DONT OPT!ASSLEVEL,OPND) ! PASS ON OPND FIRST DUE TO ! LIMITATIONS OF PORTABLE ASSEMBLER OPND=0 DB; UCOP=UCBW %IF (OPC>255 %AND XTRA#0) %OR XTRA>256 %THEN FAULT(97,0,0) %FINISH ->OTRIP QINST(7): ! JUMPS %IF TARGET=IBM %OR TARGET=IBMXA %OR TARGET=AMDAHL %START VAL1=A(P);P=P+1; ! THE MASK OR EQIVALENT %IF A(P)=1 %THEN XTRA=A(P+1) %AND P=P+1;! THE INDEX P=P+1 VAL2=FROMAR2(P); ! THE NAME ENTER JUMP(OPC<<8!VAL1<<4!XTRA,VAL2,X'40') FAULT(97,0,0) %IF VAL1>15 %OR XTRA>15 ->BEND %FINISH ->OTRIP OTRIP: TR=URECTRIP(UCOP,0,DONT OPT!ASS LEVEL,OPND) TRIPLES(TR)_X1=OPC<<16!XTRA BEND: %END ->CSSEXIT SW(20): ! '%TRUSTEDPROGRAM' PARM_COMPILER=1 %IF PARM_ARR=0 %AND PARM_CHK=0; ->CSSEXIT SW(21): ! '%MAINEP'(NAME) KK=FROM AR2(P+1) FAULT(97,0,0) %UNLESS PARM_CPRMODE=0 MAINEP<-STRING(ADDR(WORKA_LETT(WORD(KK)))) ->CSSEXIT %INTEGERFN CFORMATREF !*********************************************************************** !* P IS TO ALT OF FORMAT REF * !* P::=(NAME),(RFDEC)(RESTOFRFDEC)(ALTRFDEC) * !* RETURNS CELL NO OF TOP CELL OF THE FORMATLIST * !*********************************************************************** %INTEGER FNAM,OPHEAD,OPBOT,NHEAD,MRL %RECORD(LISTF)%NAME LCELL %IF A(P)=1 %START; ! A RECORD OF RECORDFORMAT NAME FNAM=FROM AR2(P+1) P=P+3 COPY TAG(FNAM,NO) %IF 3<=TYPE<=4 %THEN %RESULT=KFORM %IF INAFORMAT#0 %AND OLDI#LEVEL %START PTYPE=4; ACC=X'7FFF' PUSH(KFORM,0,0,0) STORE TAG(FNAM,LEVEL,RBASE,15,0,X'7FFF',KFORM,KFORM) %RESULT=KFORM %FINISH FAULT(62,0,FNAM); ! NOT A RECORD OF FORMAT NAME ACC=8; ! GUESS A RECORD SIZE %RESULT=DUMMY FORMAT %FINISH ! FORMAT ACTUALLY SPECIFIED P=P+1 OPHEAD=0; OPBOT=0 NHEAD=0; MRL=0 CRFORMAT(OPHEAD,OPBOT,NHEAD,MRL,X'80000000') CLEAR LIST(NHEAD) %IF CURRINF_UNATT FORMATS#0 %START LCELL==ASLIST(CURRINF_UNATT FORMATS) %IF LCELL_S2=0 %THEN LCELL_S2=OPHEAD %AND %RESULT=OPHEAD %IF LCELL_S3=0 %THEN LCELL_S3=OPHEAD %AND %RESULT=OPHEAD %FINISH PUSH(CURRINF_UNATT FORMATS,OPHEAD,0,0) %RESULT=OPHEAD %END %ROUTINE CRFORMAT(%INTEGERNAME OPHEAD, OPBOT, NLIST, MRL, %INTEGER INIT) !*********************************************************************** !* CONVERTS A RECORDFORMAT STATEMENT TO A LIST HEADED BY OPHEAD * !* FORMAT OF AN ENTRY. * !* S1=SUBNAME<<20!PTYPE<<4!J * !* S2,S3=4 16 BIT DISPLACEMENTS D2,ACC,D1,KFORM * !* NORMALLY D1=RECORD RELATIVE DISPLACEMENT AND ACC=LMAX(STRINGS)* !* FOR ARRAYS D2=FIRST ELEMENT DISPLACEMENT AND D1=DISPLACEMENT * !* OF RECORD RELATIVE ARRAYHEAD IN THE GLA * !* KFORM IS ONLY USED FOR RECORDS AND POINTS TO THE FORMAT * !* ON EXIT ACC HAS THE RECORD SIZE ROUNDED UP TO THE BOUNDARY * !* REQUIRED BY ITS LARGEST COMPONENT * !*********************************************************************** %INTEGER D1, D2, FORM, RL, STALLOC, INC, Q, R, RFD, LB, TYPEP, SACC, DVO %ROUTINESPEC SN(%INTEGER Q) %ROUTINESPEC ROUND FORM=0; ACC=0 INC=INIT&X'FFFF'; ! INC COUNTS DOWN RECORD %CYCLE ROUT=0; LITL=0; NAM=0; RFD=A(P) P=P+1 %IF RFD=1 %THEN %START CLT FORM=KFORM STALLOC=ACC P=P+1 %IF A(P-1)=1 %START ! (TYPE) (QNAME')(NAMELIST) FORM=KFORM CQN(P); P=P+1 %IF NAM=1 %THEN %START STALLOC=PTRSIZE(PREC<<4!TYPE) %IF ARR#0 %THEN STALLOC=AHEADSIZE %FINISH PACK(PTYPE); D2=0 RL=ROUNDING LENGTH(PTYPE,0) ROUND; J=0 %UNTIL A(P-1)=2 %CYCLE D1=INC; SN(P) P=P+3; INC=INC+STALLOC %REPEAT %FINISH %ELSE %START ! (TYPE)%ARRAY(NAMELIST)(BPAIR) Q=P+1; ARR=1; PACK(PTYPE) %CYCLE P=Q P=P+3 %UNTIL A(P-1)=2 TYPEP=PTYPE; SACC=ACC DVO=DOPE VECTOR(NO,TYPE,ACC,0,FROMAR2(Q)>>1,R,LB) ! DOPE VECTOR INTO SHAREABLE S.T. ACC=SACC; PTYPE=TYPEP; UNPACK %IF DVO<0 %THEN DVO=0;! ERROR HAS BEEN FAULTED RL=ROUNDING LENGTH(PTYPE&255,0);! FOR ELEMENT AS SCALAR %IF RL NULL %FINISH %FINISH %ELSE %START ! (FORMAT) CRFORMAT(OPHEAD,OPBOT,NLIST,MRL,INC) INC=ACC %FINISH P=P+1 %REPEAT %UNTIL A(P-1)=2; ! UNTIL NULL ! FINISH OFF %IF A(P)=1 %START; ! WHILE %OR CLAUSES P=P+1 CRFORMAT(OPHEAD,OPBOT,NLIST,MRL,INIT&X'FFFF') %IF ACC>INC %THEN INC=ACC %FINISH %ELSE P=P+1 %IF INIT<0 %THEN RL=MRL %AND ROUND FAULT(63,X'7FFF',0) %AND INC=X'7FFF' %UNLESS INC<=X'7FFF' ACC=INC; ! SIZE ROUNDED APPROPRIATELY %RETURN %ROUTINE SN(%INTEGER Q) !*********************************************************************** !* CHECK THE SUBNAME HAS NOT BEEN USED BEFORE IN THIS FORMAT * !* AND ENTER IT WITH ITS DESCRIPTORS INTO THE LIST. * !* CARE IS NEEDED TO MATCH TAG LAYOUT ON BYTE SWOPPED HOSTS * !*********************************************************************** %RECORD(TAGF) CELL FNAME=FROM AR2(Q) FAULT(61,0,FNAME) %UNLESS FIND(FNAME,NLIST)=-1 CELL_PTYPE<-PTYPE; CELL_UIOJ<-FNAME<<4!J CELL_ACC=ACC CELL_SNDISP=D2&X'7FFF'; ! IN CASE OF BUM FORMATS CELL_SLINK=D1&X'7FFF'; ! IN CASE OF BUM FORMATS CELL_KFORM=FORM BINSERT(OPHEAD,OPBOT,CELL_S1,CELL_S2,CELL_S3) PUSH(NLIST,0,FNAME,0) %IF PTYPE=X'433' %AND ACC=X'7FFF' %THEN %C PUSH(ASLIST(FORM)_S3,OPBOT,0,0);! NOTE FORWARD REFERENCE %END %ROUTINE ROUND MRL=RL %IF RL>MRL INC=INC+1 %WHILE INC&RL#0 %END %END; ! OF ROUTINE CRFORMAT %INTEGERFN DISPLACEMENT(%INTEGER LINK) !*********************************************************************** !* SEARCH A FORMAT LIST FOR A SUBNAME * !* A(P) HAS ENAME--LINK IS HEAD OF RFORMAT LIST. RESULT IS DISP * !* FROM START OF RECORD * !*********************************************************************** %RECORD(LISTF)%NAME FCELL,PCELL,LCELL %INTEGER RR,II,ENAME,CELL ENAME=A(P)<<8+A(P+1); CELL=0 %IF LINK#0 %THEN %START; ! CHK RECORDSPEC NOT OMITTED FCELL==ASLIST(LINK); ! ONTO FIRST CELL CELL=LINK; II=-1; ACC=-1 %WHILE LINK>0 %CYCLE LCELL==ASLIST(LINK) %IF LCELL_UIOJ<<16>>20=ENAME %START;! RIGHT SUBNAME LOCATED TCELL=LINK SNDISP=LCELL_SNDISP K=LCELL_SLINK J=LCELL_UIOJ&15; PTYPE=LCELL_PTYPE ACC=LCELL_ACC SNDISP=LCELL_SNDISP KFORM=LCELL_KFORM %IF LINK#CELL %START; ! NOT TOP CELL OF FORMAT PCELL_LINK=LCELL_LINK LCELL_LINK=FCELL_LINK FCELL_LINK=LINK %FINISH; ! ARRANGING LIST WITH THIS SUBNAME ! NEXT TO THE TOP %RESULT=K %FINISH PCELL==LCELL LINK=LCELL_LINK %REPEAT %FINISH FAULT(65,0,ENAME) %IF CELL>0 %THEN %C PUSH(ASLIST(CELL)_LINK,(ENAME<<4)<AE %IF ARR=1; ! ARRAYS INCLUDING RECORDARRAYS %IF A(P+2)=2 %THEN P=P+3 %ELSE NO APP %IF TYPE<=2 %OR TYPE=5 %OR %C (TYPE=3 %AND A(P)=2 %AND (3<=Z<=4 %OR Z=6)) %START ACCESS=MODE+4+4*NAM; BASE=BS; DISP=DP; XDISP=XD+Q %RETURN %FINISH ! ! NOW CODING BECOMES HAIRY:- STILL LEFT ARE ! A) RECORDS IN RECORDS Q POINTS TO SECONDARY RECORD ! B) RECORDNAMES IN RECORDS Q HAS OFF-SET OF A POINTER ! C) RECORDARRAYNAMES IN RECORDS Q HAS OFF-SET A HEADER IN RECORD ! D) RECORDARRAYS IN RECORDS NOT YET ALLOWED ! Q WOULD HAVE OFF-SET OF A RECORD RELATIVE HEADER IN THE GLA ! XD=XD+Q NAMEP=NAMEP!X'FFFF0000' %IF NAM=1 %THEN %START MODE=MODE+4; ! SO ADDRESS OF POINTER FETCHED FETCH RAD; ! NEW METHOD IS AS FOR REC FNS EXPOPND=RADOPND; ! EXPOPND IS ADDRESS TO WHICH POINTER POINTED MODE=3 DP=0; XD=0; BS=0 NAMEP=-1 %FINISH CENAME(MODE,KFORM,BS,DP,XD) %RETURN AE: ! ARRAYS AND ARRAYNAMES AS ELEMEN LCELL==ASLIST(TCELL) ACC=LCELL_ACC; SNDISP=LCELL_SNDISP KFORM=LCELL_KFORM; K=LCELL_SLINK C=ACC; D=SNDISP; Q=K; QQ=KFORM %IF (Z=6 %OR Z>=11) %AND A(P+2)=2 %START;! 'GET ARRAYHEAD' CALL P=P+3 %IF NAM=1 %THEN %START ACCESS=MODE+8; BASE=BS DISP=DP; XDISP=XD+Q PTYPE=AHEADPT NAMEOP(6,8,NAMEP); ! PTR TO HEAD %RETURN %FINISH ! ! PASSING AN ARRAY IN A RECORD BY NAME MUST CONSTRUCT PROPER ARRAYHEAD ! FROM THE RECORD RELATIVE ONE AT Q(GLA) ! FETCH RAD NAMEP=-1 OPND1_S1=AHEADPT<=11 %THEN FAULT(17,0,ENAME) %FINISH ! AN ELEMENT IS NOT AN ARRAY FOR P-P %FINISH ACC=C; ! NEEDED FOR STRING ARRAYS %RETURN %ROUTINE FETCH RAD !*********************************************************************** !* SET ACC TO 32 BIT ADDRESS OF RECORD. * !*********************************************************************** %INTEGER PRECP ACCESS=MODE+4 BASE=BS DISP=DP; XDISP=XD PRECP=PREC; PREC=5 NAMEOP(4,4,NAMEP) PREC=PRECP; ! ENSURE 32BIT PICKUP RADOPND=NAMEOPND %END %END; ! OF ROUTINE CENAME %END; ! OF ROUTINE CRNAME %ROUTINE CSTREXP(%INTEGER MODE) !*********************************************************************** !* PLANT IN-LINE CODE FOR CONCATENATION. A WORK AREA IN THE * !* CURRENT STACK FRAME IS USUALLY REQUIRED. * !* ON ENTRY:- * !* MODE=0 NORMAL. WK AREA NOT USED FOR ONE OPERAND EXPSSNS * !* MODE=1 STRING MUST GO TO WORK AREA * !* 2**5 BIT OF MODE SET IF FULL VIRTUAL ADDRESS REQUIRED * !* 2**4 BIT OF MODE IS SET IF WK-AREA NOT TO BE FREED ON EXIT * !* ON EXIT:- * !* VALUE#0 %IF RESULT IN A WORK AREA(CCOND MUST KNOW) * !*********************************************************************** %INTEGER PP,WKAREA,DOTS,ERR,KEEPWA,FNAM,I,ENDFLAG %RECORD(RD) OPND1,OPND2,OPND3 %INTEGERFNSPEC STROP(%RECORD(RD) %NAME OPND) KEEPWA=MODE&16; MODE=MODE&15 PP=P; STRINGL=0; FNAM=0; WKAREA=0 P=P+3; ! LENGTH OF CONSTANT PART ERR=72; ->ERROR %UNLESS A(P)=4 P=P+1 DOTS=0; ! NO OPERATORS YET ENDFLAG=0 STRINGL=0 ERR=STROP(OPND2); ! GET FIRST OPERAND %IF STRRESINWA=NO %AND PTYPE&X'1000'#0 %THEN MODE=1 ! IF FN RESULT NOT IN A WORK AREA ! COPY IN FROM TOP OF STACK ! SOMETIMES NOT NECESSARY BUT FN=FN COMPARISONS ! WILL GO WRONG WITHOUT THIS ->ERROR %UNLESS ERR=0 NEXT: %IF A(P)=2 %THEN ENDFLAG=1 %ELSESTART %IF A(P+1)#CONCOP %THEN ERR=72 %AND ->ERROR P=P+2 ! ! LEFT TO RIGHT EVALUATION IS DEFINED BUT IF FIRST OPERAND IS ACONST ! WE CAN EVALUATE THE SECOND. THIS ENABLES US TO FOLD "TOSTRING(NL)" ETC ! %IF DOTS=0 %AND OPND2_FLAG=LCONST %THEN %START ERR=STROP(OPND3) ->ERROR %UNLESS ERR=0 %FINISH %ELSE OPND3_FLAG=255 %FINISH %IF ENDFLAG=0 %AND OPND2_FLAG=LCONST=OPND3_FLAG %START ! ! CAN FOLD OUT A CONCATENATION HERE ! I=CONCAT CTOP(I,ERR,0,OPND2,OPND3) %IF I=0 %THEN ->NEXT; ! FOLDED OUR %FINISH %IF DOTS=0 %START %IF MODE=0 %AND ENDFLAG#0 %START; ! NO RUN-TIME OPERATIONS OPND1=OPND2; ->TIDY %FINISH GET WSP(WKAREA,X'80000000'!268); ! GET NEXT OPERAND OPND1_PTYPE=X'35' OPND1_FLAG=LOCALIR OPND1_D=RBASE<<16!WKAREA OPND1_XTRA=268; ! THE WORK AREA SIZE NEEDED FOR ! BACKWARD STACKS I=BRECTRIP(PRECC,X'35',0,OPND1,OPND2) OPND1_FLAG=REFTRIP OPND1_D=I; ! CHANGE TO TRIPLES REFERENCE DOTS=1 %FINISH %IF ENDFLAG=0 %THENSTART %IF OPND3_FLAG=255 %START; ! 3 NEED EVALUATION ERR=STROP(OPND3) ->ERROR %UNLESS ERR=0 %FINISH OPND1_D=BRECTRIP(CONCAT,X'35',0,OPND1,OPND3) ->NEXT %FINISH TIDY: ! FINISH OFF EXPOPND=OPND1; ! LEAVE REULT IN EXPOPND VALUE=WKAREA P=P+1; ! PAST REST OF EXPRN RETURN WSP(WKAREA,268) %IF KEEPWA=0 %AND WKAREA>0 STRINGL=0 %RETURN ERROR:FAULT(ERR,0,FNAM) BASE=RBASE; DISP=0 VALUE=0; ACCESS=0 P=PP; SKIP EXP %RETURN %INTEGERFN STROP(%RECORD(RD) %NAME OPND) !*********************************************************************** !* DEALS WITH OPERAND FOR CONCATENATION. RETURN RESULT=0 FOR * !* VALID OPERAND OTHERWISE AN ERROR NUMBER. * !*********************************************************************** %INTEGER CTYPE,MODE,I MODE=A(P); ! ALTERNATIVE OF OPERAND OPND=0 %RESULT=75 %IF MODE>2 %IF MODE#1 %THENSTART CTYPE=A(P+1); ! GET CONST TYPE & LOSE AMCK FLAGS %IF CTYPE=X'35' %THENSTART PTYPE=CTYPE STRINGL=A(P+2) OPND_PTYPE=CTYPE OPND_FLAG=LCONST OPND_D=P+2 OPND_XTRA=STRINGL P=P+STRINGL+3 %FINISHELSERESULT=73 %FINISHELSESTART P=P+1; ! MUST CHECK FIRST REDUCE TAG(NO) %IF 5#TYPE#7 %THEN FNAM=FROMAR2(P) %ANDRESULT=71 %IF PTYPE=X'4035' %AND A(P+2)=2=A(P+3) %START OPND_FLAG=LCONST; ! CONST STRING OPND_PTYPE=X'35' OPND_D=MIDCELL OPND_XTRA=KFORM STRINGL=OPND_XTRA P=P+4 %RESULT=0 %FINISH %IF PTYPE=X'35' %AND A(P+2)=2=A(P+3) %START OPND_FLAG=DNAME OPND_XTRA=0 OPND_PTYPE=PTYPE OPND_D=FROMAR2(P) P=P+4 %FINISHELSESTART CNAME(2) OPND=NAMEOPND %FINISH STRINGL=0 %FINISH %RESULT=0 %END; ! OF INTEGERFN STROP %END; ! OF ROUTINE CSTREXP %ROUTINE CRES (%INTEGER LAB) !********************************************************************** !* COMPILES A RESOLUTION E.G A->B.(C).D.(E).F AND JUMPS TO LAB * !* ON FAILURE. (LAB=0 FOR UNCONDITIONAL RESOLUTION TO PERM ON * !* FAILURE ). * !* THE METHOD IS TO CALL A SUBROUTINE PASSING 5 PARAMS:- * !* P1(32BITS) POINTS TO LHS(A) * !* P2(16BITS) ORIGINAL LENGTH OF A * !* P3(32BITS) FULL POINTER TO BYTES USED UP INITIALLY 0 * !* P4(48BITS) STRING TO CONTAIN FRAGMENT * !* (PASSED AS LMAX FOLLOWED BY 32BIT ADDRESS) * !* P5(32BITS) THE EXPRESSION PASSED AS 32 BIT ADDRESS * !* SUBROUTINE TRIES TO PERFORM THE RESOLUTION AND SETS THE * !* RESULT TO TRUE IF IT SUCCEEDS. * !* * !* ON ENTRY LHS IS IN THE ESTACK(32BITS). * !* P POINTS TO P(+') OF RHS DEFINED AS (+')(OPERAND)(RESTOFEXP) * !* * !$ THE ROUTINE IS COMPACT BUT DIFFICULT TO FOLLOW (OR ALTER) * !* THE TIME IN PERM IS LARGE SO IT IS NOT WORTHWHILE TO PERSUE * !* CODE EFFICIENCY TOO INDUSTRIOUSLY . * !********************************************************************** %INTEGER P1,P2,SEXPRN,W,LAST,ERR,FNAM,JJ %RECORD(RD) OPND1,OPND2 LAST=0; FNAM=0; ! =1 WHEN END OF EXPRNSN FOUND SEXPRN=0; ! RESOLUTION(BRKTD) EXPRESSNS P1=P ERR=43 %IF NAMEOPND_PTYPE&X'C700'=X'4000' %THEN FNAM=NAMEOPND_D %AND ->ERROR ! CANT RESOLVE A CONST STRING ERR=74; ! NORMAL CRES FAULT GET WSP(W,4); ! TO HOLD P1,P2 AND VALUE OF P3 OPND1_PTYPE=X'61' OPND1_FLAG=LOCALIR OPND1_D=RBASE<<16!W JJ=BRECTRIP(PRES1,X'35',DONT OPT,OPND1,NAMEOPND) P=P+3 ->RES %IF A(P)=4; ! LHS MUST BE A STRING ! BUT THIS CHECKED BEFORE CALL ERR=72 ERROR:FAULT(ERR,0,FNAM) P=P1; SKIP EXP; %RETURN RES: P=P+1; ! TO P(OPERAND) %IF A(P)=3 %THEN %START; ! B OMITTED OPND2_PTYPE=X'51' OPND2_FLAG=SCONST OPND2_D=0; ! ZERO CONST FOR NO DEST %FINISH %ELSE %START ->ERROR %UNLESS A(P)=1; ! P(OPERAND)=NAME P=P+1; P2=P CNAME(3) OPND2=NAMEOPND %IF TYPE#5 %THEN ERR=71 %AND FNAM=FROMAR2(P2) %AND ->ERROR %IF A(P+1)#CONCOP %THEN ERR=72 %AND ->ERROR P=P+2 %FINISH JJ=BRECTRIP(PRES2,X'35',DONT OPT,OPND1,OPND2) ->ERROR %UNLESS A(P)=3; ! P(OPERAND)='('(EXPR)')' SEXPRN=SEXPRN+1; P=P+1 CSTREXP(32); ! FULL 32 BIT ADDRESS OPND2_S1=X'51'< END %IF A(P)=2 %IF A(P+1)#CONCOP %THEN ERR=72 %AND ->ERROR P2=P+1; P=P2+1 %IF A(P)=3 %THEN P=P2 %AND ->RES ->ERROR %UNLESS A(P)=1 P=P+3 %AND SKIP APP %UNTIL A(P)=2 %IF A(P+1)=1 %THEN P=P2 %AND ->RES P1=P+1 P=P2+2 CNAME(3) JJ=BRECTRIP(RESFN,X'35',DONT OPT,OPND1,NAMEOPND) P=P1 END: P=P+1 %END %ROUTINE SAVE STACK PTR !*********************************************************************** !* SAVE THE CURRENT STACK TOP AND POSSIBLY A DESCRIPTOR TO IT * !* NEEDED ON AUX STACK IMPLEMENTATIONS AND ALSO IN BEGIN-END BLOCKS * !* SO ARRAYS CAN BE UNDECLARED ON BLOCK EXIT. ONLY ACTS ON THE FIRST* !* CALL IN ANY BLOCK OR ROUITNE * !*********************************************************************** %INTEGER JJJ %IF CURRINF_AUXSBASE=0 %START JJJ=UTEMPTRIP(SSPTR,MINAPT,0,N); ! SAVE THE STACK POINTER CURRINF_AUXSBASE=N %IF TARGET=EMAS %AND PARM_STACK=0 %THEN N=N+16 %C %ELSE N=N+4 %FINISH %END %ROUTINE CEND (%INTEGER KKK) !*********************************************************************** !* DEAL WITH ALL OCCURENCES OF '%END' * !* KKK=PTYPE(>=X'1000') FOR ROUTINES,FNS AND MAPS * !* KKK=0 FOR ENDS OF '%BEGIN' BLOCKS * !* KKK=1 FOR '%ENDOFPROGRAM' * !* %ENDOFPROGRAM IS REALLY TWO ENDS. THE FIRST IS THE USERS * !* AND THE SECOND IS PERMS. KKK=2 FOR A RECURSIVE CALL OF CEND * !* ON END OF PROGRAM TO DEAL WITH THE %END CORRESPONDING TO * !* THE %BEGIN COMPILED IN THE INITIALISATION SEQUENCE * !*********************************************************************** %INTEGER KP,JJ,BIT %RECORD(TAGF)%NAME TCELL,PCELL %ROUTINESPEC DTABLE(%INTEGER LEVEL) SET LINE %UNLESS KKK=2 BIT=1<X'1000' %AND PARM_COMPILER=0 %C %AND LAST INST=0 %THEN %C JJ=UCONSTTRIP(RTBAD,X'51',0,0); ! RUN FAULT 11 %IF KKK=0 %THEN %START; ! BEGIN BLOCK EXIT %IF PARM_TRACE=1 %THEN %START; ! RESTORE DIAGS POINTERS JJ=UCONSTTRIP(RDPTR,X'51',0,LEVEL-1) %FINISH JJ=CURRINF_AUXSBASE %IF JJ#0 %THEN %START; ! ARRAYS TO BE UNDECLARED JJ=UCONSTTRIP(RSPTR,X'51',0,JJ) %FINISH %FINISH FORCE TRIPS; ! BEFOR LABEL LIST CLEARED IN OPT MODE NMAX=N %IF N>NMAX; ! WORK SPACE POINTER ! ! CLEAR OUT THE LABEL LIST FAULTING LABELS WITH JUMPS OUTSTANDING ! AS NOT SET AND COMMENTING ON LABELS NOT USED ! %WHILE CURRINF_LABEL#0 %CYCLE POP(CURRINF_LABEL,I,J,KP) %IF J&X'FFFF'#0 %THEN %START J=J&X'FFFF' %IF 0=0 %START COPY TAG(JJ,NO) %IF PTYPE&X'1000'#0 %START; ! NAME COULD BE REDECLARED AS LOCAL ! IF THIS HAPPENS SKIP GLEANING %WHILE K>0 %CYCLE; ! DOWN PARAM LIST TCELL==ASLIST(K) %IF TCELL_PTYPE&X'F00'=X'500' %AND TCELL_UIOJ&15=0 %START ! TCELL IS ARRAY OF UNKNOWN DIMENSION PCELL==ASLIST(TAGS(TCELL_UIOJ>>4));! ONTO LOCAL TAGS TCELL_UIOJ=TCELL_UIOJ!PCELL_UIOJ&15;! COPY BACK DIMENSIO %FINISH K=TCELL_LINK %REPEAT %FINISH %FINISH ! ! NOW PLANT THE BLOCK EXIT SEQUENCE ! %IF KKK&X'1000'#0 %THEN JJ=UCONSTTRIP(RTXIT,X'51',0,KKK) JJ=UCONSTTRIP(XSTOP,X'51',0,KKK) %IF KKK=1;! %STOP AT %ENDOFPROGRAM CLEAR LIST(TWSPHEAD); ! CAN NOT CARRY FORWARD %CYCLE JJ=0,1,4 CLEAR LIST(CURRINF_AVL WSP(JJ));! RELEASE TEMPORARY LOCATIONS %REPEAT %IF TARGET=PERQ %OR TARGET=ACCENT %THEN FORCE TRIPS;! PERQ NEED THIS BEFORE DTABLE AS ! DTABLE OFFSET GOES IN RTDICT ! PNX MUST HAVE DATBLE FIRST OR ! FILLING OF DTABLE REFS FAILS DTABLE(LEVEL); ! OUTPUT DIAGNOSTIC TABLES FORCE TRIPS ! ALL TRIPS MUST BE DEALT WITH ! BEFORE CURRENT LEVELS ARE CHANGED %WHILE CURRINF_UNATT FORMATS#0 %CYCLE POP(CURRINF_UNATT FORMATS,I,J,JJ) CLEAR LIST(I) CLEAR LIST(J) CLEAR LIST(JJ) %REPEAT ! ! NOW CLAIM THE STACK FRAME BY FILING THE ASF IN THE BLOCK ENTRY CODING ! %IF KKK=2 %THEN %RETURN ! ! RETURN TO PREVIOUS LEVEL PROVIDED THERE IS A VALID ONE ! ! %UNLESS LEVEL>2 %OR (LEVEL=2 %AND PARM_CPRMODE=2) %THEN %START %IF KKK=1 %AND LEVEL=2 %THEN KKK=2 %ELSE FAULT(109,0,0) ! SHOULD BE CHKD IN PASS1 %FINISH LEVEL=LEVEL-1 CURRINF==LEVELINF(LEVEL) %IF KKK&X'1000'#0 %THEN %START RLEVEL=CURRINF_RBASE RBASE=RLEVEL %FINISH ! ! RESTORE INFORMATION ABOUT THE (NEW) CURRENT LEVEL ! NMAX=CURRINF_SNMAX %IF KKK&X'1000'#0 N=CURRINF_SN %IF KKK=2 %THEN CEND(KKK); ! ROUND AGAIN FOR 'ENDOFPROGRAM' ! ! COMPLETE THE JUMP AROUND ALL NON-EXTERNAL ROUTINES EXCEPT WHEN ! %TRUSTEDPROGRAM IS IN OPERATION. ! %IF KKK&X'1000'#0 %AND PARM_COMPILER=0 %AND %C (RLEVEL>0 %OR PARM_CPRMODE#2) %THEN %START JJ=NEXTP+6 %UNLESS A(NEXTP+5)=11 %AND A(JJ+FROMAR2(JJ))=2 %START JJ=ENTER LAB(CURRINF_JROUND,1) CURRINF_JROUND=0 %FINISH %FINISH %RETURN ! ! LAYOUT OF DIAGNOSIC TABLES ! ****** ** ********* ****** ! ! THE BOUND FIELD OF PLT DESCRIPTOR STORED AT (LNB+3 & LNB+4) IF ! USED TO CONTAIN A DISPLACEMENT RELATIVE TO THE START OF SST OF THE ! DIAGNOSTIC TABLES FOR THE BLOCK OR ROUTINE BEING EXECUTED. ! A ZERO BOUND MEANS NO DIAGNOSTIC REQUESTED.(NB THIS MAY MEAN A DUMMY ! FIRST WORD IN THE SST). ! THE ABSOLUTE ADDRESS OF THE SST FOR THE CURRENT CODE SEGMENT WILL ! ALWAYS BE FOUND IN THE STANDARD 10 WORDS OF THE GLA/PLT ! ! FORM OF THE TABLES:- ! ! WORD 0 = LINE OF RT IN SOURCE PROG <<16 ! LINE NO POSN(FROM LNB) ! WORD 1 = (12 LANG DEPENDENT BITS)<<18 ! ENVIRONMENT ! ( TOP 2 BITS OF LANG DEPENDENT HAS LITL FROM PTYPE) ! ( BOTTOM 4 BITS HAVE TEXTUAL LEVEL) ! WORD 2 = DISPLAY POSN (FROM LNB)<<16 ! RT TYPE INFO ! WORD 3 = ZERO FOR BLKS OR STRING(<=11BYTES) BEING THE ! RT NAME. THIS WILL TAKE WORDS 4 AND 5 IF NEEDED ! WORD 6 = LANGUAGE DEPENDENT INFO . IMP ON CONDITIONS ETC ! ! THE REST IS MADE UP OF VARIABLE ENTRIES AND THE SECTION IS TERMINATED BY ! A WORD OF X'FFFFFFFF' ! ! EACH VARIABLE ENTRY CONSISTS OF THE VARIABLE WORD FOLLOWED BY ! THE VARIABLE NAME AS A STRING. THE WORD CONSISTS OF ! BITS 2**31 TO 2**20 TYPE INFORMATION (MAY BE LANGUAGE DEPENDENT ! BIT 2**19 =0 UNDER LNB =1 IN GLA ! BITS 2**18 TO 2**0 DISPLACEMENT FROM LNB(GLA) IN BYTES ! ! ! THE ENVIRONMENT IS A POINTER (RELATIVE TO SST) OF THE NEXT OUTERMOST ! BLOCK OR A POINTER TO GLOBAL OWNS, EXTERNAL OR COMMON AREAS ! A ZERO MEANS NO ENCLOSING BLOCK. WORD1=WORD3=0 IS AN ! IMP MAIN PROGRAM AND WILL TERMINATE THE DIAGNOSTICS. ! %ROUTINE DTABLE(%INTEGER LEVEL) !*********************************************************************** !* THIS ROUTINE LOOKS AT THE DECLARATIONS FOR THE CURRENT LEVEL & * !* SETS UP THE SEGMENT OF SHARABLE SYMBOL TABLES TO DESCRIBE THEM.* !* FOR MAIN PROGRAMS OR EXTERNAL ROUTINES THE 'GLOBAL' VARIABLES * !* (IF ANY) ARE ALSO INCLUDED. * !*********************************************************************** %STRING(11) RT NAME %STRING(11) LOCAL NAME %IF HOST=PERQ %OR HOST=ACCENT %OR HOST=IBM %OR HOST=AMDAHL %OR HOST=IBMXA %START %RECORDFORMAT HEADF(%SHORT RTLINE,LINEOFF,OFLAGS,ENV,DISPLAY, RTFLAGS,(%INTEGER IDHEAD %OR %STRING(11)RTNAME)) %RECORDFORMAT VARF(%SHORT FLAGS,DISP,%STRING(11)VNAME) %FINISH %ELSE %START %RECORDFORMAT HEADF(%HALFINTEGER RTLINE,LINEOFF,OFLAGS,ENV,DISPLAY, RTFLAGS,(%INTEGER IDHEAD %OR %STRING(11)RTNAME)) %RECORDFORMAT VARF(%HALFINTEGER FLAGS,DISP,%STRING(11)VNAME) %FINISH %RECORD(HEADF)%NAME DHEAD %RECORD(VARF)%NAME VAR %RECORD(LISTF)%NAME LCELL %CONSTINTEGER LARRROUT=X'F300' %RECORD(TAGF)T %INTEGER DPTR,LNUM,ML,KK,JJ,Q,DEND,BIT,S4,LANGD,II %CONSTINTEGER DLIMIT=700 %INTEGERARRAY DD(0:DLIMIT); ! BUFFER FOR SEGMENT OF SST ! ! FILL ALL OUTSTANDING REFERENCES TO THIS DIAGS BLOCK ! BIT=1<>14<<30!LEVEL<<18; ! GET LITL FROM PTYPE PDATA(DAREA,4,0,ADDR(DD(0))); ! TO WORD BOUNDARY FILL DTABREFS(CURRINF_RAL) PUSH(LEVELINF(LEVEL-1)_RAL,DAREA,CAS(DAREA)+4,LANGD) %IF PARM_TRACE#0 DHEAD==RECORD(ADDR(DD(0))) DHEAD_RTLINE=CURRINF_L DHEAD_LINEOFF=CURRINF_DIAGINF %IF TARGET=PERQ %OR TARGET=ACCENT %THEN DHEAD_LINEOFF=DHEAD_LINEOFF+2 DHEAD_OFLAGS<-LANGD>>16 DHEAD_ENV=0 %IF TARGET=IBM %OR TARGET=IBMXA %OR TARGET=AMDAHL %THEN %C DHEAD_DISPLAY=CURRINF_RBASE %ELSE DHEAD_DISPLAY=CURRINF_DISPLAY DHEAD_RTFLAGS=CURRINF_FLAG&X'3FFF' ML=CURRINF_M; ! ROUTINE NAME(=0 FOR %BEGIN) %IF ML#0 %THEN ML=WORD(ML-1); ! IF NOT BLOCK GET DIRPTR LNUM=WORKA_LETT(ML); ! LENGTH OF THE NAME DPTR=4; DEND=0 %IF LNUM=0 %THEN DHEAD_IDHEAD=0 %ELSE %START Q=ADDR(WORKA_LETT(ML)) RT NAME<-STRING(Q); ! FOR RTS MOVE IN 1ST 32 CHARS LNUM=LENGTH(RT NAME) DHEAD_RTNAME=RTNAME; ! AND UPDATE POINTER PAST %IF HOST#TARGET %AND PARM_TRACE#0 %THEN %C CHANGE SEX(ADDR(DD(0)),12,LNUM+1) DPTR=DPTR+LNUM>>2; ! ACTUAL NO OF CHARS %FINISH DD(DPTR)=CURRINF_ONWORD; ! ON CONDITION WORD DPTR=DPTR+1 JJ=CURRINF_NAMES %WHILE 0<=JJ2 %OR PTYPE&X'FF00'#X'4000') %C %AND T_UIOJ&X'C000'=0 %THEN WARN(2,JJ) I=T_UIOJ>>4&15 J=T_UIOJ&15 K=T_SLINK ! ! ALLOW OWNS (LITL=0) AND EXTERNALS (=2) NOT CONSTS(=1) OR EXTRINSIC(=3) ! %IF PARM_DIAG#0 %AND PTYPE&X'7300'<=X'200' %AND DPTR>2 %FINISH %IF J=15 %AND PTYPE&X'3000'#0 %AND T_UIOJ&X'C000'#0 %THEN %C FAULT(28,0,JJ) ! SPEC&USED BUT NO BODY GIVEN %IF J=15 %AND TYPE=4 %THEN FAULT(62,0,JJ) %IF PTYPE&X'3000'#0 %OR TYPE=4 %OR TYPE=6 %THEN %C CLEAR LIST(K) %ELSE %START %IF I#0 %AND K>4095 %AND PTYPE&LARRROUT=0 %AND TYPE#7 %C %THEN WARN(5,JJ) %FINISH JJ=S4>>18 %REPEAT DD(DPTR)=-1; ! 'END OF SEGMENT' MARK DPTR=DPTR<<2+4 %IF PARM_TRACE=1 %THEN %C PDATA(DAREA,4,DPTR,ADDR(DD(0)));! ADD TO SHARABLE SYM TABS %END; ! OF ROUTINE DTABLE %END %ROUTINE DECLARE SCALARS(%INTEGER XTRA) !*********************************************************************** !* THIS ROUTINE DECLARES A LIST OF SCALARS FROM INFORMATION * !* IN THE GLOBAL VARIABLES ROUT,NAM,ARR,PREC,TYPE & ACC.IT WORKS * !* OUT ROUNDING FACTORS FOR ITSELF. * !* P POINTS TO THE NAMELIST ON ENTRY AND IS UPDATED. * !*********************************************************************** %INTEGER INC,SCAL NAME,RL PACK(PTYPE) INC=ACC; SNDISP=0 %IF NAM#0 %AND ARR=0 %AND ROUT=0 %THEN INC=PTRSIZE(PTYPE&127) %IF NAM>0 %AND ARR>0 %THEN INC=AHEADSIZE %IF PTYPE=X'35' %AND (ACC<=0 %OR ACC>256) %THEN %C FAULT(70,ACC-1,0) %AND ACC=255 RL=ROUNDING LENGTH(PTYPE,1) %UNTIL A(P-1)=2 %CYCLE; ! DOWN THE NAMELIST N=(N+RL+SFRAME MISALIGN)&(\RL)-SFRAME MISALIGN SCAL NAME=FROM AR2(P) P=P+3 STORE TAG(SCAL NAME,LEVEL,RBASE,0,SNDISP,ACC,N,XTRA) N=N+INC %REPEAT N=(N+MIN PARAM SIZE-1)&(-MIN PARAM SIZE); ! THIS IS NECESSARY ! %END %INTEGERFN DOPE VECTOR(%INTEGER TAMPER,TYPEP,ELSIZE,MODE,IDEN, %INTEGERNAME ASIZE,LB) !*********************************************************************** !* CONSTRUCTS THE DOPE-VECTOR FOR A CONSTANT ARRAY IN THE * !* SHAREABLE SYMBOL TABLES AND RETURNS ITS DISPLACEMENT AS RESULT* !* P IS TO ALT (MUST BE 1!) OF P * !* PERQ,DRS&ACCENT DOPE VECTOR CONSISTS OF :- * !* @0 DWORD CONTAINING THE BASE OFFSET * !* @4 WORD CONTAINING THE NO OF DIMENSIONS ND * !* @6 WORD HOLDING SIZE (IN BYTES) OF A SINGLE ELEMENT * !* @8 DWORD OF ARRAYSIZE WORDS(DRS BYTES) FOR STACK ADJUSTMENT * !* AND ND DWORD TRIPLES EACH CONSISTING OF:- * !* UBI THE UPPER BOUND OF THE ITH DIMENSION * !* LBI - THE LOWER BOUND OF THE ITH DIMENSION * !* RI - THE STRIDE FOR THE ITH DIMENSION=(UBI-LBI+1) * !* EMAS DOPE VECTOR CONSISTS OF:- * !* @0 BOUNDED WORD DESCRPTOR BOUND=3*ND * !* @8 THE ARRAY SIZE IN BYTES OF ENTIRE ARRAY * !* @12 ND TRIPLES OF LB,MULT AND UPPER CHK AS PER VMY INSTRN * !* NOTE TRIPLES IN REVERSE ORDER FOR HISTORIC COMPATABILITY * !* MODE=0 DV MUST BE CONST, MODE#0 CAN BE DYNAMIC * !* MODE=-1 SPECIAL FOR CONSTARRAYNAMES 1D 0:INFINITY * !*********************************************************************** %INTEGER I,JJ,K,ND,D,M0,HEAD,NOPS,TYPEPP,PIN %RECORD(RD)OPND %RECORD(LISTF) %NAME LCELL %INTEGERARRAY LBH,LBB,UBH,UBB(0:12) %INTEGERARRAY DV(0:39); ! ENOUGH FOR 12 DIMENSIONS ND = 0; NOPS = 0; TYPEPP = 0; PIN = P M0 = 1 %IF (TARGET=PERQ %OR TARGET=ACCENT %OR TARGET=PNX) %C %AND ELSIZE>1 %THEN ELSIZE=(ELSIZE+1)&(-2) %IF MODE=-1 %THENSTART ND = 1; LBB(1) = 0 %IF TARGET=PERQ %OR TARGET=DRS %OR TARGET=ACCENT %THEN ASIZE=X'7FFF' %ELSE ASIZE=X'FFFFFF' UBH(1)=ASIZE//ELSIZE UBB(1)=UBH(1)-ELSIZE %FINISHELSESTART %UNTIL A(P)=2 %CYCLE ND = ND+1; P = P+4 FAULT(37,0,IDEN) %AND ND = 1 %IF ND>12 LBH(ND) = 0; LBB(ND) = 0 UBB(ND) = 0; UBH(ND) = 0 TORP(LBH(ND),LBB(ND),NOPS) P = P+3 TYPEPP = TYPEPP!TYPE TORP(UBH(ND),UBB(ND),NOPS) TYPEPP = TYPEPP!TYPE %REPEAT P = P+1 ->NONCONST %UNLESS TYPEPP=1 %AND NOPS&X'40040000'=0 ! ! NOW ONE CAN WORK OUT AND FILL IN THE TRIPLES ! ASIZE = 1 %CYCLE D = 1,1,ND K = 3*D EXPOP(LBH(D),LBB(D),NOPS,X'251') EXPOPND_D = 0 %AND FAULT(41,0,0) %UNLESS %C EXPOPND_FLAG<=1 %AND EXPOPND_PTYPE=X'51' LBB(D) = EXPOPND_D %IF (TARGET=EMAS %OR TARGET=PNX) %AND %C TAMPER=YES %AND PARM_OPT=0 %AND ND=1 %AND %C LBB(D)=1 %THEN LBB(D)=0;! READJUST BASE TO 0 FROM 1 EXPOP(UBH(D),UBB(D),NOPS,X'251') EXPOPND_D = 10 %AND FAULT(41,0,0) %UNLESS %C EXPOPND_FLAG<=1 %AND EXPOPND_PTYPE=X'51' JJ = EXPOPND_D FAULT(38,LBB(D)-JJ,IDEN) %AND JJ=LBB(D) %UNLESS JJ>=LBB(D) UBB(D) = JJ UBH(D) = JJ-LBB(D)+1; ! RANGE OF DTH DIMENSION ASIZE = ASIZE*UBH(D) %REPEAT ASIZE = ASIZE*ELSIZE %FINISH ! ! CALCULATE THE OFF SET OF A(FIRST,..) FROM A(0,..) ! LB = 0; I = ND %WHILE I>=2 %CYCLE LB = (LB+LBB(I))*UBH(I-1) I = I-1 %REPEAT LB = LB+ LBB(1) FAULT(39,0,IDEN) %IF ASIZE>X'FFFFFF' ! ! SET UP THE DOPEVECTOR ALLOWING EACH TARGET ITS ODDITIES ! %IF TARGET=DRS %START DV(2)=ASIZE DV(0)=-LB DV(1)=ND<<16!ELSIZE %FINISH %IF TARGET=PERQ %OR TARGET=ACCENT %OR TARGET=PNX %START DV(2) = (ASIZE+1)>>1 DV(0) = -LB DV(1) = ND<<16!ELSIZE %FINISH %IF TARGET=EMAS %START DV(0)=X'28000000'+3*ND DV(1)=12; ! SO LDRL POINTS TO TRIPLES DV(2)=ASIZE; ! FOR ARRAYS BY VALUE %IF TYPEP>=3 %OR ELSIZE=2 %THEN M0=ELSIZE %FINISH %IF TARGET=IBM %OR TARGET=IBMXA %OR TARGET=AMDAHL %START DV(0)=ND DV(1)=(ASIZE+7)&(-8) DV(2)=ELSIZE %FINISH %CYCLE D=1,1,ND %IF TARGET=PERQ %OR TARGET=DRS %OR TARGET=ACCENT %OR TARGET=PNX %START K=3*D DV(K)=UBB(D) DV(K+1)=LBB(D); ! LOWER BND OVER UPPER M0=M0*UBH(D) DV(K+2)=M0; ! RANGE %FINISH %IF TARGET=EMAS %START K=3*(ND+1-D); ! TRIPLES IN REVERSE ORDER DV(K)=LBB(D) DV(K+1)=M0; ! RUNNING MULTIPLIER M0=M0*UBH(D); ! UPPED BY RANGE DV(K+2)=M0 %FINISH %IF TARGET=IBM %OR TARGET=IBMXA %OR TARGET=AMDAHL %START K=3*D DV(K)=LBB(D) DV(K+1)=UBB(D) DV(K+2)=M0*ELSIZE M0=M0*UBH(D) %FINISH %REPEAT K = 3*ND+2 ! ! REFORMAT THE ARRAY DOPE VECTOR FOR BYTE SWAPPED MACHINES. OPT AND GEN ! MUST ALLOW FOR POSSIBLY SWAPPED DOPE VECTORS IN COMPILE TIME OPERATIONS ! %IF HOST#TARGET %START OPND_PTYPE=X'51'; OPND_FLAG=0 %FOR D=0,1,K %CYCLE OPND_D=DV(D) REFORMATC(OPND) DV(D)=OPND_D %REPEAT %FINISH J = ND; ! DIMENSIONALITY FOR DECLN HEAD = DVHEADS(ND) %WHILE HEAD#0 %CYCLE LCELL == ASLIST(HEAD) %IF LCELL_S2=ASIZE %START %CYCLE D = 0,1,K ->ON %UNLESS DV(D)=CTABLE(D+LCELL_S1) %REPEAT SNDISP = 4*LCELL_S1 %RESULT = LCELL_S3 %FINISH ON: HEAD = LCELL_LINK %REPEAT SNDISP = 4*WORKA_CONST PTR I=SNDISP %IF TARGET=PERQ %OR TARGET=ACCENT %THEN SSTL=(SSTL+3)&(-4) %AND I = SSTL; ! PERQ DVS IN SST PUSH(DVHEADS(ND),WORKA_CONSTPTR,ASIZE,I) %CYCLE D = 0,1,K CTABLE(WORKA_CONST PTR) = DV(D) WORKA_CONST PTR = WORKA_CONST PTR+1 %REPEAT %IF WORKA_CONST PTR>WORKA_CONST LIMIT %THEN FAULT(102,WORKA_WKFILEK,0) %IF TARGET=PERQ %OR TARGET=ACCENT %THEN %C PDATA(4,4,4*(K+1),ADDR(DV(0))) %AND SSTL = SSTL+4*(K+1) WAYOUT: %IF MODE=-1 %THENRESULT = I; ! NO EXPRESSION CELLS TO RETURN %RESULT = I NONCONST: ! NOT A CONST DV J = ND; I = -1; SNDISP = -1 LB = 0; ASIZE = ELSIZE %IF MODE=0 %THEN FAULT(41,0,0) %ELSE P = PIN %CYCLE D=1,1,ND CLEAR LIST(LBH(D)) CLEAR LIST(UBH(D)) %REPEAT ->WAYOUT %END %ROUTINE DECLARE ARRAYS(%INTEGER FORMAT,FINF) !*********************************************************************** !* FORMAT=1 FOR 'ARRAYFORMAT' =0 OTHERWISE * !* FINF>0 FOR RECORD FORMAT INFORMATION =0 OTHERWISE * !* P IS AT P IN * !* * !* P= * !* P = '('':'*')' * !* * !* ARRAYS WITH CONSTANT BOUNDS HAVE THEIR D-V IN THE SST * !* ALL OTHER ARRAYS HAVE A DOPE VECTOR AMONG THE LOCALS AND GET * !* THEIR SPACE OFF THE STACK AT RUN TIME * !* BOTH SORTS OF ARRAYS HAVE A FOUR WORD HEAD AND D-V TO EMAS * !* SYSTEM STANDARDS * !*********************************************************************** %INTEGER DVDISP,PP,DVF,ELSIZE,TOTSIZE,PTYPEP,ARRP,NN,ND,II,CDV,LWB, PTYPEPP,JJJ,JJ,TRIP1 %RECORD(RD) OPND1 SAVE STACK PTR; ! FOR LATER UNDECLARING ARRP=2*FORMAT+1; ARR=ARRP; PACK(PTYPEP) ELSIZE=ACC %IF (TARGET=PERQ %OR TARGET=ACCENT %OR TARGET=PNX) %AND ELSIZE>1 %THEN %C ELSIZE=(ELSIZE+1)&(-2) START:NN=1; P=P+1; ! NO OF NAMES IN NAMELIST PP=P; CDV=0; PTYPEPP=PTYPEP P=P+3 %AND NN=NN+1 %WHILE A(P+2)=1 P=P+3 %IF ARRP=3 %THEN JJ=NO %ELSE JJ=YES DVDISP=DOPE VECTOR(JJ,TYPE,ELSIZE,1,FROMAR2(PP),TOTSIZE,LWB) ND=J ->CONSTDV %UNLESS DVDISP<0 ! ! NORMAL CASE - PLANT CODE TO SET UP DOPE-VECTOR AT RUN TIME ! DVF=0; TOTSIZE=X'FFFF' N=(N+3)&(-4); ! MAY BE BENEFITS IN WORD ALIGNMENT DVDISP=N; ! DVDISP IS D-V POSITION N=N+12*ND+12; ! CLAIM SPACE FOR THE D-V %IF TARGET=PNX %OR TARGET=DRS %THEN DVDISP=N-4 ! FOR DOWNWARD STACK MACHINES TRIP1=ULCONSTTRIP(DVSTT,X'51',DONT OPT,ND<<16!ELSIZE,PTYPEP<<16!DVDISP); ! ASSN ND&DIMEN->DVDIPS+4 ! %CYCLE II=1,1,ND P=P+1 CSEXP(X'51'); ! LOWER BOUND %IF (TARGET=EMAS %OR TARGET=PNX) %AND PARM_OPT=0 %C %AND ND=1 %AND EXPOPND_FLAG=0 %AND EXPOPND_D=1 %C %THEN EXPOPND_D=0; ! ADD ONE ELEMENT ON TO FRONT ! OF OPTIMISED ARRAYS STARTING ! AT UNITY TO SAVE BASE ADJUST %IF EXPOPND_FLAG>0 %OR EXPOPND_D#0 %THEN DVF=DVF!(1<DECL CONSTDV: ! ONE DIMENSION - CONSTANT BOUNDS CDV=1 %IF LWB=0 %AND FORMAT=0 %THEN PTYPEPP=PTYPEP+256 SNDISP=SNDISP>>2 ! SET ARR=2 IF LWB=ZERO %IF PARM_COMPILER#0 %AND LWB#0 %THEN FAULT(99,0,0) DECL: ! MAKE DECLN - BOTH WAYS J=ND N=(N+3)&(-4) PTYPE=PTYPEPP; UNPACK %CYCLE JJJ=0,1,NN-1; ! DOWN NAMELIST K=FROM AR2(PP+3*JJJ) STORE TAG(K,LEVEL,RBASE,J,SNDISP,ELSIZE,N,FINF) JJ=ULCONSTTRIP(DARRAY,X'61',0, CDV<<31!JJJ<<24!(NN-1)<<16!DVDISP,K) JJ=ULCONSTTRIP(ASPTR,X'61',0, CDV<<31!SNDISP<<16!DVDISP,K) %IF FORMAT=0 N=N+AHEADSIZE %REPEAT P=P+1; ! PAST REST OF ARRAYLIST %IF A(P-1)=1 %THEN ->START %RETURN %END %INTEGERFN ROUNDING LENGTH(%INTEGER PTYPE,RULES) !*********************************************************************** !* RULES=0 IN RECORDS(BEST DEFINED) * !* RULES=1 IN STACK FRAME(MOST LATITUDE) * !* RULES=2 AS PARAMETERS(FUNNY HARDWARE CONSIDERATIONS) * !*********************************************************************** %IF PTYPE&X'1000'#0 %THEN %RESULT=PTR ROUNDING(128*RULES) ! TREAT RT PARAMS AS %NAME %IF PTYPE&X'C00'#0 %THEN %RESULT=PTR ROUNDING(PTYPE&X'7F'+128*RULES) %RESULT=RNDING(PTYPE&X'7F'+128*RULES) %END %ROUTINE CLT !*********************************************************************** !* DEAL WITH PHRASE TYPE AND SET PREC,TYPE & ACC * !* ONLY PROBLEM ARE STRINGS WHICH HAS OPTIONAL MAX LENGTH ALSO * !* RECORD WHICH HAVE A FORMAT * !* P ON PHRASE TYPE AT ENTRY - TO NEXT PHRASE AT EXIT. * !*********************************************************************** %INTEGER ALT,PTYPEP,I,FLAGS,SJ ALT=A(P) FLAGS=TYPEFLAG(ALT) %IF FLAGS&X'8000'#0 %THEN P=P+1 %AND FLAGS=TYPEFLAG(A(P)+FLAGS&15) %IF FLAGS&X'4000'#0 %THEN P=P+1;! ALLOWS BYTE OR BYTEINTEGER ETC %IF FLAGS&X'2000'#0 %THEN WARN(8,0);! SUBSTITUTION MADE %IF FLAGS&X'1000'#0 %THEN FAULT(99,0,0) PREC=FLAGS>>4&15 TYPE=FLAGS&7 P=P+1 ACC=BYTES(PREC) PACK(PTYPEP); ! PRESERVE ALL COMPONENT ! BEFORE CALLINT INTEXP ETC %IF TYPE=5 %THEN %START; ! P='%STRING' %IF A(P)=1 %THEN %START; ! MAX LENGTH GIVEN %IF A(P+1)=1 %START; ! EXPRESSION NOT STAR P=P+4 %IF INTEXP(I,MINAPT)#0 %THEN FAULT(41,0,0) ACC=I+1 PTYPE=PTYPEP; UNPACK %FINISH %ELSE ACC=0 %AND P=P+2 %FINISH %ELSE ACC=0 %AND P=P+1 %FINISH KFORM=0 %IF TYPE=3 %THEN %START SJ=J KFORM=CFORMATREF PTYPE=PTYPEP UNPACK J=SJ %FINISH %END %ROUTINE CQN(%INTEGER P) !*********************************************************************** !* SET NAM & ARR FROM ALTERNATIVE OF PHRASE * !* P='%ARRAYNAME','%NAME',<%NULL> * !* P POINTS TO THE ANALYSIS RECORD ENTRY AS IS NOT UPDATED * !*********************************************************************** %INTEGER I I=A(P);NAM=0;ARR=0 %IF I=1 %THEN ARR=1; ! ARRAYNAMES %IF I<=2 %THEN NAM=1; ! ARRAYNAMES & NAMES %END %INTEGERFN SET SWITCHLAB(%INTEGER HEAD,LAB,FNAME,BIT) !*********************************************************************** !* SET A SWITCH LABEL AND RETURNS RESULT=0 %UNLESS THE LABEL * !* HAS BEEN ALREADY SET WHEN IT RETURNS RESULT#0 * !* HEAD IS HEAD OF THE TAGS SIDECHAIN FOR THE SWITCH * !*********************************************************************** %INTEGER Q,QQ,JJJ,LB,UB,BASEPT %RECORDFORMAT BITFORM(%INTEGERARRAY BITS(0:2),%INTEGER LINK) %RECORD(RD) OPND1,OPND2 %RECORD(BITFORM)%NAME BCELL %RECORD(LISTF)%NAME LCELL OLDLINE=0 LCELL==ASLIST(HEAD) LB=LCELL_S2 UB=LCELL_S3 HEAD=LCELL_LINK BCELL==ASLIST(HEAD) %UNLESS LB<=LAB<=UB %THEN FAULT(50,LAB,FNAME) %AND %RESULT=0 Q=LAB-LB %WHILE Q>=96 %%CYCLE HEAD=BCELL_LINK BCELL==ASLIST(HEAD) Q=Q-96 %REPEAT ! ! ASLIST(HEAD) IS THE START OF 96 BIT ENTRY IN THE BIT LIST ! CHECK BIT NO Q TO SEE IF LABEL ALREADY SET AND THEN SET BIT Q ! QQ=Q>>5; ! RIGHT WORD Q=Q&31; JJJ=1<=%ROUTINE TYPEP=LITL<<14!X'1000' P=P+2; ! IGNORING ALT OF P(SPEC') %FINISH %ELSE %START; ! P= ROUT=1; ARR=0; P=P+1 CLT; NAM=0 %IF A(P)=2 %THEN NAM=2; ! 2 FOR MAP 0 FOR FN PACK(TYPEP) P=P+2; ! AGAIN IGNORING ALT OF P(SPEC') %FINISH KK=FROM AR2(P) AXNAME=ADDR(WORKA_LETT(WORD(KK))) JJ=0 P=P+3 SACC=ACC; SKFORM=KFORM; ! FOR RECORD MAPS WITH PARAMS %IF A(P-1)=1 %THEN %START %IF LITL=0 %THEN WARN(10,0) MOVE BYTES(A(P)+1,ADDR(A(0)),P,ADDR(A(0)),WORKA_ARTOP) AXNAME=ADDR(A(WORKA_ARTOP)) WORKA_ARTOP=(WORKA_ARTOP+4+A(P))&(-4) P=P+A(P)+1 %FINISH CFPLIST(OPHEAD,NPARMS) PCHKWORD=0 %IF NPARMS>0 %THEN PCHKWORD=NPARMS<<16!ASLIST(OPHEAD)_S3>>16 %IF M=1 %THEN %START %IF TARGET=EMAS %OR TARGET=PNX %OR TARGET=IBM %OR TARGET =IBMXA %THEN %C CXREF(STRING(AXNAME),3*PARM_DYNAMIC!EXTRN,PCHKWORD,JJ) ! %SYSTEM & %EXTERNAL =STATIC ! UNLESS PARM DYNAMIC SET ! %DYNAMIC = DYNAMIC %IF TARGET=PERQ %OR TARGET=ACCENT %THEN JJ=AXNAME-ADDR(A(WORKA_DICTBASE)) %FINISH %ELSE %START %IF TARGET=PERQ %OR TARGET=ACCENT %THEN JJ=WORKA_RTCOUNT %AND WORKA_RTCOUNT=WORKA_RTCOUNT+1 %FINISH %IF M=0 %AND RLEVEL=0 %START %IF PARM_CPRMODE=0 %THEN PARM_CPRMODE=2 %IF PARM_CPRMODE#2 %THEN FAULT(56,0,KK) %FINISH J=15-M; PTYPE=TYPEP STORE TAG(KK,LEVEL,RBASE,15-M,JJ,SACC,OPHEAD,SKFORM) %END %ROUTINE CFPLIST(%INTEGERNAME OPHEAD,NPARMS) !*********************************************************************** !* COMPILE A FORMAL PARAMETER PART INTO A LIST OF PARAMETER TYPES * !* P(FPP)='('{(HOLE)(FPDEL)(NAMELIST)(MARK)}*')',0. * !* * !* THE LIST OF PARAMETER LOOKS LIKE:- * !* S1 = PTYPE FOR PARAM<<16!LNAME<<12!DIMENSION(DIMEN DEDUCED LATER)* !* LNAME IS PARAMS LOCAL NAME * !* S2 = PARAMETER OFFSET(SNDISP) <<16 ! ACC * !* S3 = 0 (RESERVED FOR FPP OF RTS) * !* * !* ON ENTRY P IS AT ALT OF FPP (WHICH MAY BE NULL) * !*********************************************************************** %INTEGER OPBOT, PP, INC, RL, RSIZE, CELL, PSIMPLE %RECORD(LISTF)%NAME LCELL OPHEAD=0; OPBOT=0 NPARMS=0; ! ZERO PARAMETERS AS YET PSIMPLE=1; ! NO COMPLEX PARAMS YET %WHILE A(P)=1 %CYCLE; ! WHILE SOME(MORE) FPS PP=P+1+FROMAR2(P+1); ! TO NEXT FPDEL P=P+3; ! TO ALT OF FPDEL CFPDEL; ! GET TYPE & ACC FOR NEXT GROUP PSIMPLE=0 %UNLESS PTYPE=X'51' %OR %C (ROUT=ARR=0 %AND NAM=1 %AND TYPE<=3) %IF ARR=1 %THEN %START INC=AHEADSIZE; RL=ROUNDING LENGTH(AHEADPT,2) %FINISH %ELSE %IF NAM=1 %AND ROUT=0 %THEN %START INC=PTRSIZE(PTYPE&X'7F') RL=PTRROUNDING(PTYPE&X'7F'+256) %FINISH %ELSE %IF STRVALINWA=YES %AND PTYPE=X'35' %THEN %START INC=PTRSIZE(X'35') RL=PTRROUNDING(256+X'35') %FINISH %ELSE %IF TARGET=EMAS %AND PTYPE=X'33' %THEN %START INC=ACC+8; ! ALLOW FOR DESCRPTR FOR IMP80 COMPATABILITY RL=3; ! STRICTLY ROUNDING LENGTH(X'33',2) %FINISH %ELSE INC=ACC %AND RL=ROUNDING LENGTH(PTYPE,2) %UNTIL A(P-1)=2 %CYCLE; ! DOWN FOR EACH DEL %IF PARAMS BWARDS=YES %THEN %START PUSH(OPHEAD,0,0,RL) CELL=OPHEAD %FINISH %ELSE %START BINSERT(OPHEAD,OPBOT,0,0,RL) CELL=OPBOT %FINISH LCELL==ASLIST(CELL) LCELL_PTYPE=PTYPE; ! DIRECT "PUS" FAILS ON HALF SWOPPED MACHINES LCELL_SNDISP=INC LCELL_ACC=ACC NPARMS=NPARMS+1 P=P+3 %REPEAT P=PP %REPEAT OPBOT=OPHEAD; INC=0; ! FURTHER PASS TO ALLOCATE SPACE %WHILE OPBOT>0 %CYCLE LCELL==ASLIST(OPBOT) RL=LCELL_S3; LCELL_S3=0; ! EXTRACT ROUNDIMG LENGTH RSIZE=LCELL_SNDISP; ! INC EXTRACTED INC=(INC+RL+SFRAME MISALIGN)&(\RL)-SFRAME MISALIGN %IF PARAMSBWARDS=NO %AND RSIZE0 %THEN ASLIST(OPHEAD)_S3=PP PRINTLIST(OPHEAD) %IF PARM_Z#0 %END %ROUTINE CFPDEL !*********************************************************************** !* SET UP PTYPE & ACC FOR A FORMAL PARAMETER DEFINITION * !* P=<%QNAME'>, * !* (RT)(%NAME')(NAMELIST)(FPP), * !* '%NAME'. * !*********************************************************************** %SWITCH FP(1:3) %INTEGER FPALT FPALT=A(P); P=P+1 KFORM=0; LITL=0 ->FP(FPALT) FP(1): ! (TYPE)(%QNAME') ROUT=0; CLT CQN(P) %IF TYPE=5 %AND NAM=0 %AND (ACC<=0 %OR ACC>256) %THEN %C FAULT(70,ACC-1,0) %AND ACC=255 P=P+1 ->PK FP(2): ! (RT)(%NAME')(NAMELIST)(FPP) ROUT=1; NAM=1 ARR=0 %IF A(P)=1 %THEN %START; ! RT=%ROUITNE TYPE=0; PREC=0 P=P+2 %FINISH %ELSE %START P=P+1; CLT; ! RT=(TYPE)(FM) NAM=1 %IF A(P)=2 %THEN NAM=3; ! 1 FOR FN 3 FOR MAP P=P+2; ! PAST (%NAME') WHICH IS IGNORED %FINISH ACC=RT PARAM SIZE ->PK FP(3): ! %NAME ACC=PTRSIZE(0); NAM=1 ROUT=0; TYPE=0 ARR=0; PREC=0 PK: PACK(PTYPE) %END %ROUTINE RHEAD(%INTEGER RTNAME,AXNAME) !*********************************************************************** !* COMPILES CODE FOR BLOCK AND ROUTINE ENTRY * !* RTNAME IS THE RT/FN/MAP NAME (=-1 FOR %BEGIN BLOCKS) * !* XNAME IS THE EXTERNAL NAME (="" FOR INTERNALS&BLOCKS * !* ACTIONS INCLUDE PLANTING JUMPS ROUND RT BODY AND * !* DEFINING EXTERNAL ENTRIES AS WELL AS PLANTING ENTRY CODE * !*********************************************************************** %INTEGER W3 %RECORD(LISTF)%NAME LCELL CURRINF_SNMAX=NMAX; CURRINF_SN=N %IF RTNAME>=0 %THEN %START; ! SECTION FOR ROUTINES LCELL==ASLIST(TAGS(RTNAME)) ! ! FIRST JUMP ROUND BODY UNLESS AT TOP LEVEL OR IN COMPILER ! OR A JUMP IS ALREADY OUTSTANDING AT THIS LEVEL ! MUST DO THIS HERE BEFORE LEVEL IS CHANGED OR LABEL LIST IS WRONG ! %IF PARM_COMPILER=0 %AND LEVEL>1 %AND CURRINF_JROUND=0 %START PLABEL=PLABEL-1 CURRINF_JROUND=PLABEL %IF JRNDBODIES=YES %THEN ENTER JUMP(15,PLABEL,0) %FINISH RLEVEL=RLEVEL+1; RBASE=RLEVEL %FINISH LEVEL=LEVEL+1 CURRINF==LEVELINF(LEVEL) CURRINF=0 CURRINF_RBASE=RBASE CURRINF_CLEVEL=LEVEL; ! SELF POINTER IS NEEDED IN GENERATE CURRINF_NAMES=-1 CURRINF_DIAGINF=LEVELINF(LEVEL-1)_DIAGINF CURRINF_DISPLAY=LEVELINF(LEVEL-1)_DISPLAY FAULT(34, 0, 0) %IF LEVEL=MAX LEVELS FAULT(105, 0, 0) %IF LEVEL>MAX LEVELS ! ! DEAL WITH EXTERNAL ENTRIES SO THAT THEY COME TO THIS POINT ! IN THE CODE. THE DESCRIPTORS SET UP ARE OF NO INTEREST TO THIS MODULE ! ONLY TO OTHER MODULES SO NO DETAILS OF THEN ARE RECORDED IN TAGS ! %IF RTNAME<0 %THEN W3=0 %ELSE W3=RTNAME+1 CURRINF_L=LINE; CURRINF_M=W3 CURRINF_FLAG=PTYPE&X'FFFF'; ! CURRENT BLOCK TYPE MARKER ! SIGN MUST NOT PROPOGATE ! ! TILL LOADER COPIES GLAP TO GLA MUST CALL A FRIG ROUTINE TO DO ! THIS ESSENTIAL AS SOON AS POSSIBLE IN ANYTHING EXTERNAL ! W3=ULCONSTTRIP(RTHD,X'61',0,RTNAME,AXNAME) %END %ROUTINE RDISPLAY(%INTEGER KK) !*********************************************************************** !* SET UP OR COPY THE DISPLAY * !* SINCE THIS IS IN REGISTERS ON 360 IT IS EASY * !* ALSO CLAIM STACK SPACE AND SET DIAGNOSTIC POINTERS * !*********************************************************************** %INTEGER TRIPNO %IF KK>=0 %OR LEVEL=2 %START; ! DISPLAY NEEDED ! DONE BY THE QCODE CALL CURRINF_PSIZE=N; ! REMEMBER PARAMETER SIZE FOR RTDICT %IF DISPLAY NEEDED=YES %START CURRINF_DISPLAY=N N=N+4*RLEVEL; ! RESERVE DISPLAY SPACE %IF TARGET=PNX %OR TARGET=DRS %THEN N=N+4 ! GLOBALS ALSO IN PNX&DRS DISPLAY %FINISH TRIPNO=UCONSTTRIP(RDSPY,X'51',0,N) %FINISH ! ! IF IN DIAGNOSTIC MODE PLANT CODE TO SAVE THE LINE & ROUTINE NO OF ! THE CALLING ROUTINE AND SET UP THE NEW BLOCK/ROUTINE IDENT NO. ! %IF PARM_TRACE#0 %START %IF KK>=0 %OR LEVEL=2 %START; ! ROUTINE NEW AREA NEEDED TRIPNO=UCONSTTRIP(RDAREA,X'51',0,N) N=N+4 CURRINF_DIAGINF=N N=N+4 %FINISH TRIPNO=UCONSTTRIP(RDPTR,X'51',0,LEVEL) %FINISH OLDLINE=0 SET LINE ! ! NORMALLY CODE IS PLANTED HERE TO CHECK PARAMETERS BUT I CANNOT ! SEE HOW TO DO THIS ON PERQ ARCHITECTURE. IT MAY BE IN THE QCODE ANYHOW ! ! ! CLAIM (THE REST OF) THE STACK FRAME ! %IF KK>=0 %OR LEVEL=2 %START NMAX=N %FINISH %END %ROUTINE CUI(%INTEGER CODE) !*********************************************************************** !* COMPILE AN UNCONDITIONAL INSTRN WHEREEVER IT OCCURS * !* CODE=0 UNCONDITIOALLY,=1 AFTER %THEN, =2 AFTER %ELSE * !*********************************************************************** %INTEGER MARKER,J,LNAME,TYPEP,PRECP,ALT,KK %RECORD(RD) OPND1 %INTEGER HEAD1,BOT1,NOPS %RECORD(RD)RPOP %SWITCH SW(1:9) REPORTUI=0 ALT=A(P) ->SW(ALT) SW(1): ! (NAME)(APP)(ASSMNT?) P=P+1; MARKER=P+FROMAR2(P) %IF A(MARKER)=1 %THEN %START J=P+2; P=MARKER+2 ASSIGN(A(MARKER+1),J) %FINISH %ELSE %START P=P+2 CNAME(0) P=P+1 %FINISH AUI: J=A(P); P=P+1 %IF J=1 %THEN CUI(CODE) %RETURN SW(2): ! -> (NAME)(APP) CURRINF_NMDECS=CURRINF_NMDECS!1 CURR INST=1 %IF CODE=0 LNAME=FROM AR2(P+1) J=A(P+3); P=P+4 %IF J=2 %THEN %START; ! SIMPLE LABEL ENTER JUMP(15,LNAME,0) REPORTUI=1 %FINISH %ELSE %START; ! SWITCH LABELS COPY TAG(LNAME,NO) %UNLESS OLDI=LEVEL %AND TYPE=6 %START FAULT(4,0,LNAME); P=P-1; SKIP APP %RETURN %FINISH CSEXP(MINAPT) OPND1_S1=PTYPE<X'1000' %AND A(P+1)#3 %THEN %START;! ASSOP #'->' %IF A(P+1)=1 %AND NAM#0 %AND A(P+5)=4 %AND A(P+6)=1 %START P=P+7; TYPEP=TYPE; PRECP=PREC; J=P CNAME(4) KK=BRECTRIP(MAPRES,PTYPE&255,0,OPND1,NAMEOPND) FAULT(81,0,0) %UNLESS A(P)=2; P=P+1 FAULT(83,CURRINF_M-1,FROMAR2(J)) %C %UNLESS TYPEP=TYPE %AND PRECP=PREC ->RET %FINISH %IF A(P+1)=2 %AND NAM=0 %THEN %START;! ASSOP='=' P=P+2 %IF TYPE=5 %THEN %START CSTREXP(32); ! FULL VIRTAD %FINISH %ELSE %IF TYPE=3 %START ->BAD RES %UNLESS A(P+3)=4 %AND A(P+4)=1 P=P+5 CNAME(3) FAULT(66,0,OPND1_D) %UNLESS TYPE=3 EXPOPND=NAMEOPND %FINISH %ELSE %START %IF PREC<4 %THEN PREC=4 CSEXP(PREC<<4!TYPE) %FINISH KK=BRECTRIP(FNRES,PTYPE&255,0,OPND1,EXPOPND) ->RET %FINISH %FINISH P=P+2 BAD RES: FAULT(31,0,0) SKIP EXP; ! IGNORE SPURIOUS RESULT %RETURN SW(5): ! %MONITOR (AUI) KK=UCONSTTRIP(MNITR,X'51',0,0) P=P+1; ->AUI SW(6): ! %STOP KK=UCONSTTRIP(XSTOP,X'51',0,0) P=P+1 CURR INST=1 %IF CODE=0 REPORTUI=1 %RETURN SW(7): !'%SIGNAL'(EVENT')(N)(OPEXPR) P=P+5 KK=INTEXP(J,MINAPT); ! EVENT NO TO J FAULT(26,J,0) %UNLESS KK=0 %AND 1<=J<=15 HEAD1=0; NOPS=0 RPOP=0 RPOP_PTYPE=X'51' RPOP_FLAG=1 RPOP_D=256*J PUSH(HEAD1,RPOP_S1,RPOP_D,0); ! EVENT<<8 AS CONST BOT1=HEAD1 %IF A(P)=1 %START; ! SUBEVENT SPECIFIED PUSH(HEAD1,ANDL<100; ! LONG JUMPS FOR COMPLEX STMTS ELSELAB=0; ! MEANS NO ELSE CLAUSE P=MARKC %IF MARKR>0 %AND A(MARKR)<=2 %THEN %C START=1 %AND CS=CHECK BLOCK(MARKR+1,MARKC);! '%START' OR '%THENSTART' %IF MARKE#0 %AND LEVEL<2 %AND START=0 %THEN FAULT(57,0,0) USERLAB=-1 %IF START#0 %THEN ALTUI=0 %ELSE ALTUI=A(MARKUI) %IF ALTUI=2 %AND A(MARKUI+3)=2 %THEN %C USERLAB=FROM AR2(MARKUI+1); ! UI = SIMPLE LABEL %IF 8<=ALTUI<=9 %AND EXITLAB#0 %START; ! VALID EXIT %IF ALTUI=8 %THEN USERLAB=EXITLAB %ELSE USERLAB=CONTLAB %FINISH ! %IF SKIP=YES %THEN %START; ! NO CODE NEEDED %IF START#0 %START P=MARKR+1 CSTART(2,1); ! NO CODE MARKE=P %FINISH CCRES=1; ! NO CODE FOR ELSE ->ELSE %FINISH ! %IF USERLAB>=0 %THEN %START; ! FIRST UI IS'->'