! rs6p206.1.i jly 94 Conversion to 32 bits before unary ops ! ! rs6p206.i Jun94 Longintegers re-introduced ! m88p205f.3.i Sep93 pds Change in CRNAME to return correct size ! when recordarrayelement in a record has a record as a subname ! ! m88p205f.i 3Mar 92 PDS ! changes to allow record alignment to go to pass4 on record assignment %externalroutine ICL9CEZDRSIMP %constinteger RELEASE=4 %include "hostcodes.inc" ! %CONSTINTEGER HOST=DRS %CONSTINTEGER TARGET=PENTIUM %CONSTINTEGER STANDARDPT=X'51' %CONSTINTEGER MINAPT=X'51'; ! MINIMUM PTYPE FOR WHICH ARITHMETIC ! OPERATORS ARE AVAILABLE %CONSTINTEGER MINAPREC=MINAPT>>4 %if 1<%INTEGER+WARNING}, X'4041'{%SHORT}, X'33'{%RECORD}, 0, TYPELIENTRY, X'62'{%LONG REAL}, TYPELLRENTRY; ! ! 2****15 SET FOR RELAY TO LOWER PART OF TYPEFLAGS ! 2****14 SET TO SKIP NEXT AR ENTRY FOR BYTE(INTEGER?) ETC ! 2****13 SET IF A DIFFERENT PRECISION USED GIVES WARNING ! 2****12 SET FOR COMBINATION WE CANT SUPPORT GIVES FAULT99 ! %CONSTBYTEINTEGERARRAY PTRSIZE(0:127)= %C 8,0(15) {PREC=0}, 0(16) {PREC=1}, 0(16) {PREC=2}, 8,4,0,4,0,8,0,4,0(8) {PREC=3}, 8,4,0(14) {PREC=4}, 8,4,4,0(13) {PREC=5}, 8,4,4,0(13) {PREC=6}, 8,0,4,0(13) {PREC=7}; %CONSTBYTEINTEGERARRAY PTRROUNDING(0:3*128-1)=%C 3(128) {ALL PTRS IN RECORDS}, 3(128) {ALL PTRS IN STACK FRAMES}, 3(128) {ALL PTRS IN PARAMETERS}; %CONSTINTEGER SFRAMEMISALIGN=0; ! NEEDED ONLY FOR 2900 WHERE PRECALL ! MISALIGNS STACK FRAMES ! %CONSTINTEGER AHEADPT=X'61'; ! PTYPE OF ARRAYHEAD WHEN USED AS SCALAR %CONSTINTEGER AHEADSIZE=8; ! SIZE OF ARRAY HEAD(BYTES) %CONSTINTEGER MINPARAMSIZE=4; ! MINIMUM STACKABLE PARAMETER(BYTES) %CONSTINTEGER RTPARAMPT=X'51'; ! PTYPER OF RTPARAM WHEN USED AS SCALAR %CONSTINTEGER RTPARAMSIZE=4; ! SIZE OF RT PARAMETER (BYTES) %CONSTINTEGER ARRAYROUNDING=7; ! ALL ARRAYS TO 4 BYTE BNDR %CONSTINTEGER ARRAYINRECROUNDING=0; ! ARRAYS IN RECORDS TO 4 BYTE BOUNDARY %CONSTINTEGER STRVALINWA=NO; ! STRING VALUE PARAMETERS STACKED %CONSTINTEGER STRRESINWA=YES; ! STRING&RECORD FN RESULTS STACKED %CONSTINTEGER RECVALINWA=NO; ! Record values passed via work area ! %CONSTBYTEINTEGERARRAY RNDING(0:3*128-1)= %C {VALUES FOR SCALARS PTYPES 0->X'7F' IN SITUATIONS} {FIRST SITUATION IS IN RECORDS} {SECOND SITUATION IS IN STACK FRAMES} {THIRD SITUATION IS AS PARAMETERS} 0(16) {PREC=0}, 0(16) {PREC=1}, 0(16) {PREC=2}, 0(3),3,0,0,0(10) {PREC=3}, 0,1,0(14) {PREC=4}, 0,3,3,0(13) {PREC=5}, 0,3,3,0(13) {PREC=6}, 0,3,3,0(13) {PREC=7}, 0(16) {PREC=0}, 0(16) {PREC=1}, 0(16) {PREC=2}, 0(3),3,0,1,0(10) {PREC=3}, 0,1,0(14) {PREC=4}, 0,3,3,0(13) {PREC=5}, 0,3,3,0(13) {PREC=6}, 0,3,3,0(13) {PREC=7}, 0(16) {PREC=0}, 0(16) {PREC=1}, 0(16) {PREC=2}, 0,3,0,3,0,3,0(10) {PREC=3}, 0,3,0(14) {PREC=4}, 0,3,3,0(13) {PREC=5}, {0,7,7,0(13) PREC=6,} {for non-SPARC} 0,3,3,0(13) {PREC=6}, {for SPARC and RS6000} 0,3,3,0(13) {PREC=7}; %CONSTBYTEINTEGERARRAY BYTES(0:7)=0(3),1,2,4,8,16; %CONSTBYTEINTEGERARRAY WORDS(0:7)=0(3),1,1,2,4,8; %CONSTINTEGER DAREA=6; ! SPECIAL DIAGS AREA ON PERQ %CONSTINTEGER DVAREA=4; ! CONST DOPE VECTORS IN sst %CONSTINTEGER LHSADDRFIRST=NO; ! EVALUATE LHS ADDR BEFORE RHS ON ASSNMNT %CONSTINTEGER JRNDBODIES=NO; ! NO NEED TO JUMP ROUNT RT BODIES %CONSTINTEGER STACK DOWN=YES %CONSTINTEGER PARAMSBWARDS=YES; ! YES FOR REVERSED PARAMETERS %CONSTINTEGER DISPLAY NEEDED=YES; ! DISPLAY NEEDED IN LOCAL SPACE %CONSTINTEGER DISPLAY ROUNDING=3; ! Display on S-W bndry %CONSTINTEGER DISPLAY C1=4; ! 4 bytes per routine level on RS6000 %CONSTINTEGER DISPLAY C0=4; ! 4 for globals %CONSTINTEGER RTPARAM1OFFSET=0; ! OFFSET FROM LNB TO PARAM1 %CONSTINTEGER ALPHA=0; ! post parmeter linkage ! ! END OF CONCATENATED DEFINITIONS ! ! ! Recent Source Changes !********************** ! !* p205e.i !* 06/12/91 - Changes (pds) to base dictionary size directly on workfile !* and/or MAXDICT. Source file size is poor indicator in view !* of many large includes. !* ! Oct 89 Version 5 ! Chnages (mostly in CRCALL) to pass record values via work area & pointer ! for risc chips. Controlled by const integer in steering file ! ! DEc88 Version 3 produced ! Changes to note included procedures for Gould and others ! Also change to allow LINT &LINTPT to compile when lonlongs are treated as longs ! ! 8May87 Changes in FPlist so that RT Parameters are aligned according ! the rules of array Rnding ! ! ! 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%c like ! passing Labels this still applies, this adhocery has caused problems with%c 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%c dvs) ! Opnd2 exactly as for VMY ! %include "impcompdate.inc" %const %integer MAXRECSIZE=x'ffff' %const %integer NO OF SNS=67 %const %integer LRLPT=X'62' ! %const %integer MAXLEVELS=31,CONCOP=13 ! ! ! FIRST THE OPERAND FLAG CONSTANTS ! %CONSTINTEGER SCONST=0; ! CONST UPTO 64 BITS value is carried ! in opnd_d and opnd_xtra %CONSTINTEGER LCONST=1; ! CONST LONGER THAN SCONST const can be ! found elsewhere(at top of ar) by ! meanse of base&offset inf in_d and _xtra %CONSTINTEGER DNAME=2; ! NAME BY DICTIONARY NO the base and disp in ! the dictionary after adjusting by ! possible offset for item in ! in records lead to the variable %CONSTINTEGER ARNAME=3; ! NAME BY AR POINTER opnd_d the ar pointer ! this form local to pass2 ! and used to identify functions ! with params before the call ! is planted %CONSTINTEGER VIAPTR=4; ! VIA TRIPLE WITHOFFSET TO POINTER ! At an offset(_xtra) from address in ! referenced triple can be found a ! pointer to the required operand %CONSTINTEGER INDNAME=5; ! INDIRECT VIA DICTIONARY base&disp ! in dictionary identify a pointer ! variable at possible offset from ! this pointer %CONSTINTEGER INDIRECT=6; ! INDIRECT VIA TRIPLE WITH OFFSET ! the refenced triple has computed ! the (32bit) address of an item ! an offset may have to be applied ! before the fetch or store %CONSTINTEGER LOCALIR=7; ! BASE DISP REF IN CURRENT STACK FRAME ! opnd_b=base<<16!offset used only for ! compiler generated temporaries %CONSTINTEGER REFTRIP=8; ! REFERENCE TO A TRIPLE the operand is the result of ! triple opnd_d %CONSTINTEGER INAREG=9; ! REGISTER OPERAND this form is local to the ! code generating pass(es) %CONSTINTEGER developped=10; ! also local to generator %CONSTINTEGER DEVADDR=11; ! ALSO LOCAL TO GENERATOR %CONSTINTEGER BTREFMASK=1<>10 %if WORKA_FILE ADDR<=0 %then %start %if WORKA_FILE ADDR<-1 %then FILESIZE = IMOD(WORKA_FILE ADDR) %else %c FILESIZE = 64000 WORKA_FILE ADDR = 0 %finish %else %start SHDR == RECORD(WORKA_FILE ADDR) FILE SIZE = SHDR_ENDRA %finish ! ! Derive nnames form workfile K ignoring source size because of includes ! ! Note if nnames goes over 4095 the linking of arrayname parameters ! in sw(11) goes wong as their are only 12 bits left intags_uioj ! this is an absolute limit unless pds in prepared to be very ingenious ! WORKA_NNAMES = 1023 %if WORKA_WKFILEK>513 %then WORKA_NNAMES=2047 %if WORKA_WKFILEK>1000 %or PARM_BITS2&MAXDICT#0 %then WORKA_NNAMES = 4095 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 %byte %integer %array %format AF(0:ARSIZE) %byte %integer %array %name A %record (LISTF) %array ASLIST(0:ASL) %integer %array TAGS(0:WORKA_NNAMES) %integer %array WORD(0:WORKA_NNAMES) %integer %array DVHEADS(0:12) %record (LEVELF) %array LEVELINF(0:MAXLEVELS) %external %routine %spec INITASL(%record (LISTF) %array %name A, %integer %name B) %external %integer %fn %spec MORE SPACE !%externalintegerfnspec NEWCELL %external %routine %spec INSERTATEND(%integer %name S, %integer A,B,C) %external %routine %spec INSERT AFTER(%integer %name S, %integer A,B,C) %external %routine %spec POP(%integer %name C,P,Q,R) %external %routine %spec PUSH(%integer %name C, %integer S1,S2,S3) %external %integer %fn %spec FIND(%integer LAB,LIST) %external %routine %spec BINSERT(%integer %name T,B, %integer S1,S2,S3) %external %routine %spec CLEARLIST(%integer %name HEAD) %external %routine %spec FILL DTABREFS(%integer %name HEAD) %external %routine %spec CXREF(%string (255) NAME, %integer MODE,XTRA, %integer %name AT) %external %routine %spec IMPABORT %external %routine %spec PROLOGUE(%record (LISTF) %array %name ALIST) %external %routine %spec EPILOGUE(%integer STMTS) %external %routine %spec PDATA(%integer AREA,BNDRY,L,AD) %external %routine %spec PRDATA(%integer AREA,BNDRY,L,REP,AD) %external %integer %fn %spec PINITOWN(%integer PTYPE,ACC, %record (RD) %name INIT, %string %name XNAME) %external %integer %fn %spec POWNARRAYHEAD(%integer PTYPE,J,LB,SIZE, AOFFSET,AAREA,DVOFFSET, %string (31) XNAME) %external %routine %spec FAULT(%integer A,B,C) %external %routine %spec WARN(%integer N,V) %external %routine %spec TRIP OPT(%record (TRIPF) %array %name T, %integer %name NEXT TRIP) %external %routine %spec MOVE BYTES(%integer LENGTH,FBASE,FOFF,TOBASE,TOOFF) %external %routine %spec CTOP(%integer %name OP,MASK, %integer XTRA, %record (RD) %name OPND1,OPND2) %if HOST#TARGET %start %external %routine %spec REFORMATC(%record (RD) %name OPND) %external %routine %spec CHANGE SEX(%integer BASEAD,OFFSET,L) %finish %external %routine %spec GENERATE(%record (TRIPF) %array %name T, %integer CURRLEVEL, %routine GETWSP(%integer %name PL, %integer SIZE)) %external %routine %spec PRINTLIST(%integer HEAD) ! START OF COMPILATION K = host//10 %if k=0 %then k=1 K = BYTESPERKFORSOURCE//K; ! DISTINGUISH BYTE&WORD ADDRESSED%c 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. * !*********************************************************************** %external %integer %fn %spec PASSONE WORKA_CCSIZE = BYTESPERKFORSOURCE*(WORKA_WKFILEK-1); ! CCSIZE ALWAYS AS%c BYTES %byte %integer %array %format CCF(0:WORKA_CCSIZE) %byte %integer %array %name CC CC == ARRAY(WORKA_WKFILEAD+32,CCF) WORKA_CC == CC WORKA_A == A WORKA_WORD == WORD WORKA_TAGS == TAGS WORKA_LINE == LINE WORKA_N == N 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 = 29999 N = 12; MAX ULAB = WORKA_NNAMES+16384; ! LARGEST VALID USER LABEL LAST INST = 0 SFLABEL = 20999 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 %if PARM_FAULTY#0 %start COMREG(24) = 8 COMREG(47) = PARM_FAULTY %return %finish %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) %array %format TRIPLESFORM(0:WORKA_LASTTRIP) %record (TRIPF) %array %name TRIPLES TRIPLES == ARRAY(WORKA_WKFILEAD+32,TRIPLESFORM) %finish %integer %array %format CF(0:12*WORKA_NNAMES) %integer %array %name CTABLE !%routinespec NOTE CREF(%integer CA) !%routinespec STORE CONST(%integername D,%integer L,AD) !%integerfnspec WORD CONST(%integer VALUE) %routine %spec REUSE TEMPS %routine %spec GET WSP(%integer %name PLACE, %integer SIZE) %routine %spec RETURN WSP(%integer PLACE,SIZE) %routine %spec COMPILE A STMNT %integer %fn %spec NEW TRIP %integer %fn %spec FROMAR4(%integer PTR) %integer %fn %spec FROMAR2(%integer PTR) %integer %fn %spec UCONSTTRIP(%integer OPERN,OPTYPE,FLAGS,CONST) %integer %fn %spec ULCONSTTRIP(%integer OPERN,OPTYPE,FLAGS,CONST1,CONST2) %integer %fn %spec UNAMETRIP(%integer OPERN,OPTYPE,FLAGS,NAME) %integer %fn %spec UTEMPTRIP(%integer OPERN,OPTYPE,FLAGS,TEMP) %integer %fn %spec BRECTRIP(%integer OPERN,OPTYPE,FLAGS, %record (RD) %name OPND1,OPND2) %integer %fn %spec URECTRIP(%integer OPERN,OPTYPE,FLAG, %record (RD) %name OPND1) %routine %spec KEEPUSECOUNT(%record (RD) %name OPND) %routine %spec 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' 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) LINE = 0 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 %if target=gould %then currinf_maxpp = 8; ! max parameters passed %while A(NEXTP+3)!A(NEXTP+4)#0 %cycle COMPILE A STMNT %repeat LINE = 99999 EPILOGUE(STMTS) {bugtrace} printstring("plabel="); write(plabel,5); printstring(" sflabel="); write(sflabel,5); newline %if PARM_FAULTY#0 %start COMREG(24) = 8 STMTS = PARM_FAULTY %else COMREG(24) = 0 %finish COMREG(47) = 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 = 1; ! 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 Pinit) %routine %spec ENTER JUMP(%integer MASK,STAD,FLAG) %integer %fn %spec ENTER LAB(%integer M,FLAG) %routine %spec REMOVE LAB(%integer LAB) %routine %spec SAVE STACK PTR %routine %spec CEND(%integer KKK) %integer %fn %spec CCOND(%integer CTO,A,B,JFLAGS) %integer %fn %spec REVERSE(%integer MASK) %routine %spec SET LINE %routine %spec CUI(%integer CODE) %routine %spec ASSIGN(%integer A,B) %routine %spec CSTART(%integer CCRES,MODE) %integer %fn %spec CHECKBLOCK(%integer P,PIN) %routine %spec CCYCBODY(%integer UA,ELAB,CLAB) %routine %spec CLOOP(%integer ALT,MARKC,MARKUI) %routine %spec CIFTHEN(%integer MARKIU,MARKC,MARKUI,MARKE,MARKR,SKIP) %integer %fn %spec CREATE AH(%integer MODE, %record (RD) %name EOPND,NOPND) %routine %spec TORP(%integer %name HEAD,BOT,NOPS) %integer %fn %spec INTEXP(%integer %name VALUE, %integer PRECTYPE) %integer %fn %spec CONSTEXP(%integer PRECTYPE) %routine %spec CSEXP(%integer MODE) %routine %spec CSTREXP(%integer B) %routine %spec CRES(%integer LAB) %routine %spec EXPOP(%integer %name A,B, %integer C,D) %routine %spec TEST APP(%integer %name NUM) %routine %spec SKIP EXP %routine %spec SKIP APP %routine %spec NO APP %integer %fn %spec DOPE VECTOR(%integer A,B,C,MODE,ID, %integer %name C,D) %routine %spec DECLARE ARRAYS(%integer A,B) %routine %spec DECLARE SCALARS(%integer B) %routine %spec CRSPEC(%integer M) %integer %fn %spec SET SWITCHLAB(%integer HEAD,LAB,FNAME,BIT) %routine %spec CFPLIST(%integer %name A,B) %routine %spec CFPDEL %routine %spec CLT %integer %fn %spec ROUNDING LENGTH(%integer PTYPE,RULES) %routine %spec CQN(%integer P) %integer %fn %spec TSEXP(%integer %name VALUE) %routine %spec CRCALL(%integer RTNAME) %routine %spec NAMEOP(%integer Z,SIZE,NAMEP) %routine %spec CNAME(%integer Z) %routine %spec CANAME(%integer Z,ARRP, %record (RD) %name HDOPND) %routine %spec CSNAME(%integer Z) %routine %spec COPY TAG(%integer KK,DECLARE) %routine %spec REDUCE TAG(%integer DECLARE) %routine %spec STORE TAG(%integer KK,LEVEL,RBASE,J,SNDISP,ACC,SLINK, KFORM) %routine %spec UNPACK %routine %spec PACK(%integer %name PTYPE) %routine %spec RDISPLAY(%integer KK) %routine %spec RHEAD(%integer RTNAME,AXNAME,Xtra) %integer %fn %spec CFORMATREF %routine %spec CRFORMAT(%integer %name OPHEAD,OPBOT,NLIST,MRL, %integer INIT) %integer %fn %spec DISPLACEMENT(%integer LINK) %integer %fn %spec COPY RECORD TAG(%integer %name SUBS) %integer %fn %spec CHK REC ALIGN(%integer p1) %switch SW(1:24) %const %byte %integer %array FCOMP(0:14)=0, 8,10,2,7,12,4,7, 8,12,4,7,10,2,7 %integer P,SNDISP,ACC,K,KFORM,STNAME,MIDCELL %integer TCELL,JJ,JJJ,KK,QQ,MARKER,REPORTUI,XDISP,MASK,BASE,AREA, ACCESS,DISP,EXTRN,CURR INST,VALUE,STRINGL,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 ! ! on some machines global parameters are difficult to access hence ! copy pinit into local P which is frequently updated globally ! P = Pinit CURR INST = 0; INAFORMAT = 0 type=7; prec=5; rout=0; nam=0; litl=0; arr=0; ptype=x'57' acc=4; i=0; j=0; k=0; base=0; disp=0 EXPOPND=0; NAMEOPND=0; MLOPND=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 %c CIFTHEN(MARKIU,MARKC,MARKUI,0,0,NO) %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) I = J>>28 PARM_DCOMP = I %unless I=15 I = J>>24&15 PARM_Y = I %unless I=15 I = J>>20&15 PARM_Z = I %unless I=15 I = J&15 PARM_LINE = I %unless I=15 I = J>>4&15 PARM_DIAG = I %unless I=15 ->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; MARKUI=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; J=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,PARAMPTYPE,PARAMACC %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+3); ! 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+5)=1 %then %start;! extract alias name MOVE BYTES(A(MARKER1+6)+1,ADDR(A(0)),MARKER1+6,ADDR(A(0)), WORKA_ARTOP) AXNAME = ADDR(A(WORKA_ARTOP)) WORKA_ARTOP = (WORKA_ARTOP+4+A(MARKER1+6))&(-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%c ROUTINES FAULT(56,0,RTNAME) %unless %c EXTRN=4 %or (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 %if PTYPE&x'c000'=x'8000' %then USEBITS = 2; ! externals presumed%c 'used' TCELL_UIOJ <- TCELL_UIOJ&X'3FF0'!USEBITS<<14 ! NEWPTYPE & SET J=0 %if (target=Perq %or Target=Accent) %and J=14 %then %c TCELL_S2 = WORKA_RTCOUNT %and WORKA_RTCOUNT = WORKA_RTCOUNT+1 ! NO RT NO ALLOCATED TO EXTERNAL SPECS PTYPEP = PTYPE PCHAIN = TCELL_SLINK; ! CHAIN OF PARAMETER DESCRIPTUONS RHEAD(RTNAME,AXNAME,fromar2(marker1+1));! FIRST PART OF ENTRY SEQUENCE ! ! NOW DECLARE THE FORMAL PARAMETERS. FOLLOW BY CLAIMING DISPLAY ! AND SETTING DIAGNOSTIC PTR IN ROUTINE RDISPLAY ! P = MARKER1+6 %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 %c 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 PARAMPTYPE = PTYPE; PARAMACC = ACC; ! may get cahnged for rt%c types PTR = P %until A(PTR-1)=2 %cycle; ! CYCLE DOWN NAMELIST %if PARAMS BWARDS=YES %start; ! MAP PCHAIN TO REVERSE ORDER%c LIST PCHAIN = TCELL_SLINK PCHAIN = ASLIST(PCHAIN)_LINK %for KKK = 2,1,NPARAMS-CNT %finish LCELL == ASLIST(PCHAIN); ! EXTRACT PTYPE XTRA INFO %if PCHAIN#0 %then %start %unless LCELL_PTYPE=PARAMPTYPE %and %c LCELL_ACC&x'FFFF'=PARAMACC %then FAULT(9,CNT+1,RTNAME) %finish PNAME = FROM AR2(PTR); ! NAME FOR PARAM INTERNALLY LCELL_UIOJ <- LCELL_UIOJ!PNAME<<4; ! SAVED IN LIST( max 12 bits!) D = LCELL_SNDISP+N; ! PARAMETER OFFSET %if PARAMPTYPE&x'1000'#0 %start; ! PROCEDURE PARAMETERS P = PTR P = P+3 %until A(P-1)=2 CFPLIST(SCHAIN,KKK); ! PARAMETERLIST FOR PASSED PROC PTYPE = PARAMPTYPE; ! CHANGED BY CFPLIST STORETAG(PNAME,LEVEL,RBASE,13,D,LCELL_ACC,SCHAIN,0) %finish %else %start %if TARGET=EMAS %and PTYPE=X'33' %then D = D+8 ! FOR HISTORIC PARAMTER COMPATABILITY %if STRVALINWA=YES %and PTYPE=X'35' %then PTYPE = X'435' %if recvalinwa=yes %and ptype=X'33' %and acc#4 %then ptype=x'433' STORE TAG(PNAME,LEVEL,RBASE,LCELL_UIOJ&15,0,ACC,D,KFORM) PTYPE = PARAMPTYPE %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%c ALL SYSTEM ! STANDARD PARAMETERS HAVE BEEN%c 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),1) N = RTPARAM1OFFSET+alpha %finish %else FAULT(58,0,0) %finish %else %start SET LINE; ! SO 'ENTERED FROM LINE' IS OK RHEAD(-1,0,1) %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 N=(N+sframe misalign+7)&(-8)-sframe misalign;! double align CURRINF_ONINF = N; N = N+16 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,OPHEAD,V,R %record (RD) OPND1,OPND2 FAULT(57,0,0) %unless LEVEL>=2 Q = P %unless TARGET=EMAS %then %c 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_PTYPE <- PTYPE OPND1_XB = 0 OPND1_FLAG = DNAME OPND1_D = K OPND1_XTRA = 0 OPND2_PTYPE = X'61' OPND2_XB = 0 OPND2_FLAG = DNAME OPND2_D = LB OPND2_XTRA = UB V = BRECTRIP(DCLSW,PTYPE,0,OPND1,OPND2) PUSH(OPHEAD,0,LB,UB) STORE TAG(K,LEVEL,RBASE,1,0,4,OPHEAD,0) ! !THE TABLE WILL CONSIST OF RELATIVE DISPLACEMENTS FROM EACH ENTRY ! TO THE LABEL POSN. SET ALL TO GO TO PLAB(6) INITIALLY ! %repeat; ! FOR ANY MORE NAMES IN NAMELIST Q = PP; P = Q %repeat; ! UNTIL A(Q)=2 %unless TARGET=EMAS %then KKK = ENTER LAB(PLABEL,0) ! COMPLETE JUMP AROUND TABLE %end; ->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. * !*********************************************************************** %routine %spec CLEAR(%integer L) %routine %spec XTRACT CONST(%integer CONTYPE,CONPREC) %routine %spec INIT SPACE(%integer A,B) %integer SLENGTH,PP,SIGN,TAGDISP,DVO,K,STALLOC,SPOINT, CONSTSFOUND,CPREC,EXTRN,NNAMES,MARK,QPUTP,LB,CTYPE,CONSTP, FORMAT,DPTYPE,DIMEN,SACC,TYPEP,KK,orlevel,savesndisp %record (RD) COPND,FCOPND %own %long %real ZERO=0 %string (255) SCONST,NAMTXT %record (LISTF) %name LCELL QPUTP = 5; ! 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 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 (A(P)=2 %and %c 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%c POINTER %if (TARGET=PERQ %or TARGET=ACCENT %or TARGET=PNX) %and %c TYPE=5 %then 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; orlevel = 0 %if NAM#0 %then %start; ! OWNNAMES AND ARRAYNAMES %if ARR=0 %then %start %if (target=ibm %or target=amdahl %or target=ibmxa) %and %c extrn=0 %start tagdisp = worka_constptr %if type=5 %then ctable(tagdisp)=acc %and %c worka_constptr=worka_constptr+1 ctable(worka_constptr) = fcopnd_d worka_constptr = worka_constptr+1 %if worka_constptr>worka_const limit %then %c fault(102,worka_wkfilek,0) tagdisp = 4*tagdisp; orlevel = 14 %finish %else 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',COPND_D,0, DVO,NAMTXT) %finish STORE TAG(K,LEVEL,orlevel,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,FCOPND,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 savesndisp=sndisp { Not proof against C-T concatenation !} 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 %if (target=IBM %or target=IBMXA %or target=Amdahl %or %c (1<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 * !*********************************************************************** %const %integer BUFSIZE=512 %integer RF,I,II,ELSIZE,AD,SPP,SLENGTH,WRIT %byte %integer %array SP(0:BUFSIZE+256) AD = ADDR(FCOPND_B0) ELSIZE = SIZE//NELS ! fcopnd is in target format ! however must allow for half swopped%c targets %if 1<=BUFSIZE %start; ! EMPTY BUFFER %if HOST#TARGET %and (TYPE=5 %or (TYPE=1 %and %c PREC=3)) %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)) %then %c 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!(copnd_Ptype&8);! preserve R'' bit %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) %or (CONTYPE=1 %and %c ((CONPREC=3 %and COPND_D>255) %or (CONPREC=4 %and %c COPND_D>X'FFFF'))) %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 fcopnd_ptype=conprec<<4!contype!fcopnd_ptype&8;! correct precision before swopping 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,MAXRECSIZE,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 %c 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 (ROUT=1 %and NAM=0) %then %c 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 %if %c 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 %c MASK = FROMAR2(P)+8*(OPC-2) %and P = P+3 %else %if %c OPC=X'1A' %then MASK = 15 %else %if OPC=X'1C' %then %c MASK = 0 %else %if OPC=X'24' %then MASK = 48 %else %c 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 %c 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 %c 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 %or %c 1<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 %or %c 1<BEND %if ALT=2 %then CIND %else %if ALT=3 %then %c CIND %and XTRA = 4-A(P) %else %if ALT=4 %then %c CIND %and XTRA = 1 %else %if ALT=5 %then %c OPND_FLAG = 10 %and OPND_XB = X'74'-A(P) %else %if %c ALT=6 %then OPND_FLAG = 10 %and OPND_XB = X'70' %finish %else %if %c 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 %or %c 1<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 %c 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 %or %c 1<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 %c 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 %or %c 1<X'7FFF' UCOP = UCW; OPND_PTYPE = X'61' OPND_D = OPC OPND_XTRA = VAL1 %finish %else %if %c 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 %or %c 1<OTRIP %finish ->OTRIP QINST(6): ! BYTE & WORD OPERANDS ! IBM SS AND SSE FORMATS %if TARGET=PNX %or TARGET=PERQ %or TARGET=ACCENT %or %c 1<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 %integer %fn 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 = MAXRECSIZE PUSH(KFORM,0,0,0) STORE TAG(FNAM,LEVEL,RBASE,15,0,MAXRECSIZE,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(%integer %name 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 %routine %spec SN(%integer Q) %routine %spec 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 PACK(PTYPE); D2 = 0 RL = ROUNDING LENGTH(PTYPE,0) %if NAM=1 %then %start STALLOC = PTRSIZE(PREC<<4!TYPE) RL=PTRrounding(ptype&127) %if ARR#0 %then STALLOC = AHEADSIZE %and RL=ROUNDINGLENGTH(AHEADPT,0) %finish fault(70,0,0) %if type=5 %and stalloc=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%c 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,MAXRECSIZE,0) %and INC = MAXRECSIZE %unless %c INC<=MAXRECSIZE 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'FFFF'; ! IN CASE OF BUM FORMATS CELL_SLINK <- D1&X'FFFF'; ! 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=MAXRECSIZE %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 %integer %fn 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 %record (TAGF) TOPND %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&X'FFFF' 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 %start TOPND_PTYPE = x'57' TOPND_UIOJ = ENAME<<4 PUSH(ASLIST(CELL)_LINK,TOPND_S1,0,0) %finish PTYPE = X'57'; TCELL = 0 %result = -1 %end %integer %fn COPY RECORD TAG(%integer %name SUBS) !*********************************************************************** !* PRODUCE PTYPE ETC FOR A COMPOUND NAME BY CHAINING DOWN ONE * !* ONE OR MORE RECORD FORMAT LISTS. ON EXIT RESULT =0 IF NO * !* SUBNAME FOUND OR SUBNAME IS OF TYPE RECORD WITH NO FURTHER * !* SUBNAME ATTACHED. RESULT#0 IF BONE-FIDE SUBNAME LOCATED * !* ON ENTRY KFORM HAS POINTER TO THE (FIRST ) FORMAT LIST AND * !* P POINTS TO THE A.R. ENTRY FOR (FIRST) ENAME * !*********************************************************************** %integer Q,FNAME SUBS = 0 %until TYPE#3 %cycle FNAME = KFORM P = P+2; SKIP APP %result = 0 %if A(P)=2 %or FNAME<=0; ! NO (FURTHER) ENAME SUBS = SUBS+1 P = P+1; Q = DISPLACEMENT(FNAME) UNPACK %repeat %result = Q+1; ! GIVES 0 IF SUBNAME NOT KNOWN %end %integerfn chk rec align(%integer p1) !*********************************************************************** !* Tiddles down chain looking for an integer or larger * !* returns 0 unless at least word aligned * !*********************************************************************** %integer cell,i %integerfnspec scan(%integer cell) p=p1; reduce tag(no); ! leaves kform set for records cell=kform ! printstring("chk align ".printname(a(p1)<<8!a(p1+1))) ! write(kform,5); newline ! printlist(cell) %result=scan(cell) %integerfn scan(%integer cell) %integer j %while cell #0 %cycle i=aslist(cell)_ptype>>4&7 %if i>=5 %then %result=i %if aslist(cell)_ptype=x'33' %then %start i=scan(aslist(cell)_kform) %if i>=5 %then %result=i %finish cell=aslist(cell)_link %repeat %result=0 %end %end { chk rec align } %routine CRNAME(%integer Z,MODE,BS,DP, %integer %name NAMEP) !*********************************************************************** !* DEAL WITH RECORD ELEMENT NAMES.Z AS FOR CNAME.CLINK=TAGS(RN) * !* MODE=ACCESS FOR RECORD(NOT THE ELEMENT!) * !* ON EXIT BASE,AREA & DISP POINT TO REQUIRED ELEMENT * !* RECURSIVE CALL IS NEEDED TO DEAL WITH RECORDS IN RECORDS * !* DEPTH SHEWS RECURSIVE LEVELS- NEEDED TO AVOID MIS SETTING * !* REGISTER IN USE IF RECORDNAME IN RECORD HAS THE SAME NAME AS * !* A GENUINE RECORD NAME. * !*********************************************************************** %integer DEPTH,FNAME,EMNAME %routine %spec CENAME(%integer MODE,FNAME,BS,DP,XD) %record (RD) HDOPND HDOPND = 0 DEPTH = 0 EMNAME = NAMEP&X'FFFF'; ! ORIGINAL RECORD NAME FOR ERROR%c MESSES FNAME = KFORM; ! POINTER TO FORMAT %if ARR=0 %or (Z=6 %and A(P+2)=2) %start; ! SIMPLE RECORD %if A(P+2)=2 %then P = P+3 %else NO APP CENAME(MODE,FNAME,BS,DP,0) %finish %else %start HDOPND_PTYPE = AHEADPT HDOPND_FLAG = LOCALIR HDOPND_D = BS<<16!DP CANAME(Z,ARR,HDOPND) NAMEP = -1 CENAME(ACCESS,FNAME,BASE,DISP,0) %finish; %return ! %routine CENAME(%integer MODE,FNAME,BS,DP,XD) !*********************************************************************** !* FINDS OUT ABOUT SUBNAME AND ACTS ACCORDINGLY.MOSTLY ACTION * !* CONSISTS OF UPPING XD BY OFFSET OF THE SUBNAME BUT IS VERY * !* HAIRY FOR RECORDS IN RECORDS ETC * !* MODE IS ACCESS FOR THE RECORD * !*********************************************************************** %routine %spec FETCH RAD %integer Q,QQ,D,C,TR,ENAME,RPTYPE,EPTYPE %record (RD) RADOPND,OPND1 %record (LISTF) %name LCELL DEPTH = DEPTH+1 RPTYPE=PTYPE %if A(P)=2 %then %start; ! ENAME MISSING ACCESS = MODE; XDISP = XD BASE = BS; DISP = DP; ! FOR POINTER %if Z<14 %then %start; ! NOT A RECORD OPERATION %unless 3<=Z<=4 %or Z=6 %start; ! ADDR(RECORD) FAULT(64,0,EMNAME); BASE = RBASE DISP = 0; ACCESS = 0; PTYPE = X'51' UNPACK %finish %finish %return %finish P = P+1; ! FIND OUT ABOUT SUBNAME Q = DISPLACEMENT(FNAME); ! TCELL POINTS TO CELL HOLDING EPTYPE=PTYPE; ! Save ptype of ename UNPACK; ! INFO ABOUT THE SUBNAME %if Q=-1=ACC %or PTYPE=X'57' %start; ! WRONG SUBNAME(HAS BEEN%c FAULTED) P = P+2; SKIP APP; P = P-3 ACCESS = 0; BASE = RBASE; DISP = 0 %return %finish ENAME = A(P)<<8!A(P+1) NAMEP = ENAME<<16!NAMEP; ! NAMEP=-1 UNALTERED ! ->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 (TYPE=3 %and A(P)=2 %and %c (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%c 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&X'FFFF'; SNDISP = LCELL_SNDISP&X'FFFF' KFORM = LCELL_KFORM; K = LCELL_SLINK&x'ffff' C = ACC; D = SNDISP; Q = K; QQ = KFORM %if (Z=6 %or Z>=11) %and A(P+2)=2 %start; ! 'GET ARRAYHEAD'%c 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 = 0 OPND1_PTYPE = AHEADPT OPND1_FLAG = LOCALIR OPND1_D = Q NAMEOPND_D = CREATE AH(1,RADOPND,OPND1) NAMEOPND_PTYPE = AHEADPT; NAMEOPND_FLAG = REFTRIP NAMEOPND_XTRA = 0 %finish %else %start; ! ARRAY ELEMENTS IN RECORDS %if NAM=1 %then %start; ! ARRAYNAMES-FULLHEAD IN RECORD XD = XD+Q ACCESS = MODE+8 BASE = BS; DISP = DP; XDISP = XD NAMEOP(6,AHEADSIZE,NAMEP) OPND1 = NAMEOPND OPND1_PTYPE = AHEADPT PTYPE = LCELL_PTYPE; UNPACK CANAME(Z,3,OPND1); ! ARRAY MODE SETS DISP,AREA&BASE XD = 0 %finish %else %start; ! ARRAY RELATIVE HEAD IN GLA FETCH RAD; ! 32 BIT ADDR TO ETOS OPND1 = 0; OPND1_PTYPE = AHEADPT OPND1_FLAG = LOCALIR OPND1_D = Q CANAME(Z,3,OPND1); ! RECORD REL ARRAY ACCESS ! CAN RETURN ACCESS=1 OR 3 ONLY TR = BRECTRIP(AAINC,X'51',0,RADOPND,EXPOPND) EXPOPND_FLAG = REFTRIP EXPOPND_D = TR TRIPLES(TR)_X1 = PTYPE&255; ! FRIG FOR PERQ&ACCENT 3%c WORD BYTE PTRS! XD = 0 %finish NAMEP = -1 XDISP = XD %if TYPE=3 %then%start CENAME(ACCESS,QQ,BASE,DISP,XD) c=acc; ! to return element size %else %if Z>=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. * !*********************************************************************** ACCESS = MODE+4 BASE = BS DISP = DP; XDISP = XD ptype=rptype; unpack NAMEOP(4,4,NAMEP) ptype=eptype; unpack 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 %integer %fn %spec STROP(%record (RD) %name OPND) KEEPWA = MODE&16; MODE = MODE&15 OPND1 = 0 OPND1_PTYPE = X'35' OPND1_FLAG = LOCALIR OPND1_XTRA = 268; ! THE WORK AREA SIZE NEEDED FOR 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%c COMPARISONS ! WILL GO WRONG WITHOUT THIS ->ERROR %unless ERR=0 NEXT: %if A(P)=2 %then ENDFLAG = 1 %else %start %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_D = RBASE<<16!WKAREA ! 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 %then %start %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) EXPOPND = OPND1 BASE = RBASE; DISP = 0 VALUE = 0; ACCESS = 0 P = PP; SKIP EXP %return %integer %fn 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 %then %start CTYPE = A(P+1); ! GET CONST TYPE & LOSE AMCK FLAGS %if CTYPE=X'35' %then %start PTYPE = CTYPE STRINGL = A(P+2) OPND_PTYPE = CTYPE OPND_FLAG = LCONST OPND_D = P+2 OPND_XTRA = STRINGL P = P+STRINGL+3 %finish %else %result = 73 %finish %else %start P = P+1; ! MUST CHECK FIRST COPYTAG(FROMAR2(P),NO) %if PTYPE=x'1006' %then TYPE = ACC&7; ! special for "string" %if TYPE=3 %then REDUCE TAG(NO) %if 5#TYPE#7 %then FNAM = FROMAR2(P) %and %result = 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 ! ! The use of code for constintegers(etc) for const strings causes an unexpected ! problem on half swopped machines in that kform is not the ls end of _s2 ! %if 1<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 OPND1=0; OPND2=0 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 %c FNAM = NAMEOPND_D %and ->ERROR ! CANT RESOLVE A CONST STRING %if STRRESINWA=NO %and NAMEOPND_FLAG=REFTRIP %and %c TRIPLES(NAMEOPND_D)_OPERN=RCRFR %start GET WSP(W,268) OPND2_PTYPE = x'35' OPND2_FLAG = LOCAL IR OPND2_D = RBASE<<16!W OPND2_XTRA = 268 JJ = BRECTRIP(PRECC,x'35',DONT OPT,OPND2,NAMEOPND) NAMEOPND_FLAG = REFTRIP NAMEOPND_D = JJ NAMEOPND_PTYPE = x'35' %finish 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_PTYPE = X'51'; OPND2_FLAG = SCONST OPND2_D = LAB JJ = BRECTRIP(RESLN,X'35',DONT OPT,EXPOPND,OPND2) %if LAB#0 %then %start %if LAB<=MAX ULAB %then JJ = 0 %else JJ = B'10' ! SET MERGE FOR FAIL JUMPS ! EXCEPT WHEN ROUTED TO USER LAB ENTER JUMP(X'87',LAB,JJ) %finish ! ->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 %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 RCELL,TCELL,PCELL %routine %spec DTABLE(%integer LEVEL) SET LINE %unless KKK=2 BIT = 1<X'1000' %and PARM_COMPILER=0 %and %c LAST INST=0 %then 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 RCELL == ASLIST(TAGS(JJ)) %if RCELL_PTYPE&X'1000'#0 %start; ! NAME COULD BE REDECLARED%c AS LOCAL ! IF THIS HAPPENS SKIP GLEANING K = RCELL_SLINK %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)&4095)) ! 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%c %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 (RLEVEL>0 %or %c 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. * !*********************************************************************** %integerfnspec swopof(%integer ptype,value) %string (11) RT NAME %string (11) LOCAL NAME %if 1<>14<<30!LEVEL<<18; ! GET LITL FROM PTYPE %if PARM_TRACE=1 %then 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 <-swopof(X'41', CURRINF_L) DHEAD_LINEOFF <-Swop of(x'41', CURRINF_DIAGINF) DHEAD_OFLAGS <-Swop of(x'41', LANGD>>16) DHEAD_ENV = 0 %if TARGET=IBM %or TARGET=IBMXA %or TARGET=AMDAHL %then %c DHEAD_DISPLAY = CURRINF_RBASE %else %c DHEAD_DISPLAY <-Swop of(x'41', CURRINF_DISPLAY) DHEAD_RTFLAGS <-Swop of(x'41', 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) <-Swop of(X'51',CURRINF_ONWORD);! ON CONDITION WORD DPTR = DPTR+1 JJ = CURRINF_NAMES %while 0<=JJ2 %or PTYPE&X'FF00'#X'4000' %or %c PARM_STACK#0) %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 %c DPTRCurrinf_display))%c %and PTYPE&X'C00'=0 %and II=0 %and %c (TYPE=3 %or TYPE=5) %start;! VALUE RECS&STRS %if K>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 %c TYPE#7 %then WARN(5,JJ) %finish JJ = S4>>18 %repeat DD(DPTR) = -1; ! 'END OF SEGMENT' MARK (Not swopped!) DPTR = DPTR<<2+4 %if PARM_TRACE=1 %then PDATA(DAREA,4,DPTR,ADDR(DD(0))) ! ADD TO SHARABLE SYM TABS %return %integerfn Swopof(%integer ptype,value) !*********************************************************************** !* Does the byte swopping for cross compilers using rt in P4 * !*********************************************************************** %record(rd)opnd %if host#target %then %start Opnd=0 Opnd_d=value Opnd_ptype=ptype Reformatc(Opnd) value=Opnd_d %finish %result=Value %end %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 RL = ROUNDING LENGTH(PTYPE,1) %if NAM#0 %and ARR=0 %then INC = PTRSIZE(PTYPE&127) %and RL=ptrrounding(ptype&127+128) %if NAM>0 %and ARR>0 %then INC = AHEADSIZE %and RL=rounding length(aheadpt,1) %if PTYPE=X'35' %and (ACC<=0 %or ACC>256) %then %c FAULT(70,ACC-1,0) %and ACC = 255 %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 %integer %fn DOPE VECTOR(%integer TAMPER,TYPEP,ELSIZE,MODE,IDEN, %integer %name 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,WWC&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 %integer %array LBH,LBB,UBH,UBB(0:12) %integer %array 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) %and %c ELSIZE>1 %then ELSIZE = (ELSIZE+1)&(-2) %if MODE=-1 %then %start ND = 1; LBB(1) = 0 %if TARGET=PERQ %or TARGET=DRS %or TARGET=WWC %or %c TARGET=ACCENT %then ASIZE = X'7FFF' %else ASIZE = X'FFFFFF' UBH(1) = ASIZE//ELSIZE UBB(1) = UBH(1)-ELSIZE %finish %else %start %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 TAMPER=YES %and %c PARM_OPT=0 %and ND=1 %and 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 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 1<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 DVAREA=4 %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 %c FAULT(102,WORKA_WKFILEK,0) %if DVAREA=4 %then %c PDATA(4,4,4*(K+1),ADDR(DV(0))) %and SSTL = SSTL+4*(K+1) WAYOUT: %if MODE=-1 %then %result = 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 %Start FAULT(41,0,0) I=dope vector(tamper,typep,elsize,-1,iden,asize,lb) %finish %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,RL %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 %c ELSIZE>1 %then 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) DVDISP = N; ! DVDISP IS D-V POSITION N = N+12*ND+12; ! CLAIM SPACE FOR THE D-V %if STACK DOWN=YES %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 %and %c ND=1 %and EXPOPND_FLAG=0 %and EXPOPND_D=1 %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 RL=ROUNDINGLENGTH(AHEADPT,1) N = (N+RL)&(\RL); ! MAY BE BENEFITS IN WORD ALIGNMENT 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 %integer %fn 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 %c %result = PTR ROUNDING(PTYPE&X'7F'+128*RULES) ! ! The rounding requirements for records are not stored so treat as long reals ! using the correct rules ! %if ptype=x'33' %and rules=1 %then %result=rnding(x'62'+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 %c P = P+1 %and FLAGS = TYPEFLAG(A(P)+FLAGS&15) %if FLAGS&X'4000'#0 %then P = P+1; ! ALLOWS BYTE OR BYTEINTEGER%c 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) %and i=255 FAULT(70,I,0) %unless 1<=I<=255 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 %integer %fn 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 %record %format BITFORM(%integer %array 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+4; ! IGNORING ALT OF P(SPEC') and hole %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+4; ! AGAIN IGNORING ALT OF P(SPEC') and hole %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 %c TARGET=IBMXA %or target=amdahl %or %c 1< 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 "PUSH" FAILS ON HALF SWOPPED%c MACHINES LCELL_SNDISP = INC LCELL_ACC <- ACC NPARMS = NPARMS+1 P = P+3 %repeat P = PP %repeat OPBOT = OPHEAD; INC = 0; RL=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 RSIZEcurrinf_maxpp %then currinf_maxpp = inc PP = INC<<16!NPARMS %if (TARGET=IBM %or TARGET=IBMXA %or TARGET=AMDAHL) %then %c PP = PP!PSIMPLE<<15 %if NPARMS>0 %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,Xtra) !*********************************************************************** !* 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,Flags %record (LISTF) %name LCELL Flags=0 %if Xtra#0 %then flags=Bstruct 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 %if target=gould %then currinf_maxpp = levelinf(level-1)_maxpp 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',Flags,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-alpha; ! REMEMBER PARAMETER SIZE FOR RTDICT %if 1<=0 %or LEVEL=2 %start; ! ROUTINE NEW AREA NEEDED %if target=vns %then %c currinf_diaginf = currinf_psize+8 %else %start TRIPNO = UCONSTTRIP(RDAREA,X'51',0,N) N = N+4 N = N+4 %if 1<=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 PT,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 = 0 OPND1_PTYPE <- PTYPE; OPND1_FLAG = DNAME OPND1_D = LNAME KK = BRECTRIP(GOTOSW,PTYPE,0,OPND1,EXPOPND) REPORTUI = 1 %finish %return SW(3): ! RETURN FAULT(30,0,0) %unless CURRINF_FLAG&X'3FFF'=X'1000' P = P+1 RET: KK = UCONSTTRIP(RTXIT,X'51',0,0) REPORT UI = 1 CURR INST = 1 %if CODE=0 %return SW(4): ! %result(ASSOP)(EXPR) PTYPE = CURRINF_FLAG&X'3FFF'; UNPACK PT=ptype&255 OPND1 = 0 OPND1_PTYPE <- PTYPE; OPND1_FLAG = DNAME OPND1_D = CURRINF_M-1 %if 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)) %unless %c 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 %if PT=X'31' %or PT=X'41' %Start kk=urectrip(SHRTN,PT,0,expopnd) expopnd_flag=reftrip; expopnd_d=kk expopnd_ptype=PT %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 RPOP = 0; RPOP_FLAG = ANDL PUSH(HEAD1,RPOP_S1,0,0); ! OPERATOR & RPOP_PTYPE = X'51' RPOP_FLAG = 1 RPOP_D = 255 PUSH(HEAD1,RPOP_S1,RPOP_D,0); ! CONST=F'255' P = P+4; TORP(HEAD1,BOT1,NOPS) RPOP = 0; RPOP_FLAG = ORL BINSERT(HEAD1,BOT1,RPOP_S1,0,0); ! OPERATOR ! NOPS = NOPS+2 %finish EXPOP(HEAD1,BOT1,NOPS,X'51') OPND1_PTYPE = X'51'; OPND1_FLAG = SCONST OPND1_D = LEVEL; OPND1_XTRA=0 %if CURRINF_NMDECS&16#0 %start; ! IN AN 'ON' GROUP OPND1_D = LEVEL-1; ! SIGNAL 1 LEVEL UP %finish KK = BRECTRIP(SIGEV,X'51',DONTOPT,OPND1,EXPOPND) CURR INST = 1 %if CODE=0 REPORTUI = 1; %return SW(8): ! %exit SW(9): ! %continue ALT = ALT&7; ! 0 FOR EXIT 1 FOR CONTINUE %if currinf_EXITLAB=0 %then FAULT(54+ALT,0,0) %and %return %if ALT=0 %then KK = currinf_EXITLAB %else KK = currinf_CONTLAB ENTER JUMP(15,KK,B'10') REPORTUI = 1 CURR INST = 1 %if CODE=0 %end %routine CIFTHEN(%integer MARKIU,MARKC,MARKUI,MARKE,MARKR,SKIP) !*********************************************************************** !* THIS ROUTINE COMPILES CONDITIONAL EXPRESSIONS.IT REQUIRES THE * !* FOLLOWING PARAMETERS TO BE SET TO THEIR A .R. ENTRY. * !* MARKIU TO THE ENTRY FOR P(%iu) * !* MARKC TO THE ENTRY FOR P(COND) * !* MARKUI TO THE ENTRY FOR (FIRST OCCURRENCE OF) P(UI) * !* MARKE TO THE ENTRY FOR P(ELSE') - =0 FOR BACKWARDS CONDITION * !* MARKR TO ENTRY FOR P(RESTOFIU) - =0 FOR BACKWARDS CONDITION * !*********************************************************************** %integer ALTUI,CCRES,ELRES,THENLAB,ELSELAB,USERLAB,REPORT,START, ELSEALT,K,J,CS,LINETRIP %const %integer NULL ELSE=4 %switch ESW(1:NULL ELSE) REPORT=0; LINETRIP = -1 SET LINE %and LINETRIP = TRIPLES(0)_BLINK %unless SKIP=YES MARKIU = A(MARKIU); ! ALT OF IU 1=%if,2=%unless PLABEL = PLABEL-1 THENLAB = PLABEL START = 0; CS = 0; ! NO START IN CONDITION YET CS = 1 %if STARSIZE>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 USERLAB = FROM AR2(MARKUI+1) ! UI = SIMPLE LABEL %if 8<=ALTUI<=9 %and currinf_EXITLAB#0 %start; ! VALID EXIT %if ALTUI=8 %then USERLAB = currinf_EXITLAB %else %c USERLAB = currinf_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'->'