%MAINEP ICL9CEZPERQIMP %TRUSTEDPROGRAM %BEGIN %CONSTINTEGER RELEASE=4 %CONSTINTEGER YES=1,NO=0 %CONSTINTEGER ON PERQ=NO %CONSTSTRING(9) LADATE="9 Sep 82"; ! LAST ALTERED %INTEGER I, J, K %CONSTINTEGER NO OF SNS=63 %CONSTINTEGER LRLPT=X'62' ! %CONSTBYTEINTEGERARRAY BYTES(0:7)=0(3),1,2,4,8,16; %CONSTBYTEINTEGERARRAY WORDS(0:7)=0(3),1,1,2,4,8; %CONSTINTEGER MAXLEVELS=31,CONCOP=13 ! %INCLUDE "ERCC07.PERQ_OPCODES" %INCLUDE "ERCC07.TRIPCNSTS" %INCLUDE "ERCC07.PERQ_FORMAT3S" %CONSTINTEGER SNPT=X'1006'; ! SPECIALNAME PTYPE %CONSTINTEGER UNASSPAT=X'80808080' %CONSTINTEGER LABUSEDBIT=X'01000000' %CONSTINTEGER LABSETBIT=X'02000000' %CONSTSTRING(8)MDEP="S#NDIAG" ! %INTEGER DUMMYFORMAT, P1SIZE, STARSIZE, ASL, ARSIZE, OLDLINE, NEXTP, SNUM, RLEVEL, NMAX, PLABEL, LEVEL, PROFAAD, LAST INST, LINE, BFFLAG, RBASE, N, EXITLAB, CONTLAB, Q, R, FNAME, STMTS, FILE PTR, FILE END, FILE SIZE, BIMSTR, MAX ULAB, SFLABEL, NEXTTRIP %INTEGERNAME CA,GLACA,SSTL,USTPTR %STRING(31)MAINEP ! %EXTERNALRECORD(CODEPF)CODEP %EXTERNALRECORD(PARMF) PARM %EXTERNAL%RECORD(WORKAF)WORKA %SYSTEMINTEGERMAPSPEC COMREG(%INTEGER N) %BEGIN WORKA_FILE ADDR=COMREG(46); ! SOURCE FILE IF CLEAN PARM=0 PARM_BITS1=COMREG(27) PARM_BITS2=COMREG(28) WORKA_WKFILEAD=COMREG(14) WORKA_WKFILEK=INTEGER(WORKA_WKFILEAD+8)>>10 %IF WORKA_FILE ADDR<=0 %THEN %START FILESIZE=64000 WORKA_FILE ADDR=0 %FINISH %ELSE %START FILE PTR=WORKA_FILE ADDR+INTEGER(WORKA_FILE ADDR+4) FILE END=WORKA_FILE ADDR+INTEGER(WORKA_FILE ADDR) FILE SIZE=INTEGER(WORKA_FILE ADDR) %FINISH WORKA_NNAMES=511 %IF FILESIZE>32000 %THEN WORKA_NNAMES=1023 %IF FILESIZE>256*1024 %OR WORKA_WKFILEK>512 %THEN WORKA_NNAMES=2047 ASL=3*WORKA_NNAMES %IF ASL>4095 %THEN ASL=4095 WORKA_ASL MAX=ASL ARSIZE=WORKA_WKFILEK*768-300 %END %BYTEINTEGERARRAYFORMAT AF(0:ARSIZE) %BYTEINTEGERARRAYNAME A %RECORD(LISTF)%ARRAY ASLIST(0:ASL) %INTEGERARRAY WORD, TAGS(0:WORKA_NNAMES) %INTEGERARRAY DVHEADS(0:12) %RECORD(LEVELF)%ARRAY LEVELINF(0:MAXLEVELS) %INTEGERFNSPEC FROMAR4(%INTEGER PTR) %INTEGERFNSPEC FROMAR2(%INTEGER PTR) %EXTERNALROUTINESPEC INITASL(%RECORD(LISTF)%ARRAYNAME A,%INTEGERNAME B) %EXTERNALINTEGERFNSPEC MORE SPACE !%EXTERNALINTEGERFNSPEC NEWCELL %EXTERNALROUTINESPEC INSERTATEND(%INTEGERNAME S, %INTEGER A, B, C) %EXTERNALROUTINESPEC INSERT AFTER(%INTEGERNAME S,%INTEGER A,B,C) %EXTERNALROUTINESPEC FROM12(%INTEGER CELL, %INTEGERNAME S1, S2) %EXTERNALROUTINESPEC FROM123(%INTEGER CELL, %INTEGERNAME S1, S2, S3) %EXTERNALROUTINESPEC POP(%INTEGERNAME C, P, Q, R) %EXTERNALROUTINESPEC PUSH(%INTEGERNAME C, %INTEGER S1, S2, S3) %EXTERNALINTEGERFNSPEC FIND(%INTEGER LAB, LIST) %EXTERNALROUTINESPEC MLINK(%INTEGERNAME CELL) %EXTERNALROUTINESPEC REPLACE1(%INTEGER CELL, S1) %EXTERNALROUTINESPEC REPLACE123(%INTEGER CELL,A1,A2,S3) %EXTERNALINTEGERFNSPEC FROM2(%INTEGER CELL) %EXTERNALINTEGERFNSPEC FROM1(%INTEGER CELL) %EXTERNALINTEGERFNSPEC FROM3(%INTEGER CELL) %EXTERNALROUTINESPEC BINSERT(%INTEGERNAME T,B,%INTEGER S1,S2,S3) %EXTERNALROUTINESPEC CLEARLIST(%INTEGERNAME HEAD) %EXTERNALROUTINESPEC CODEOUT %EXTERNALROUTINESPEC PTLATE(%INTEGER WORD) %EXTERNALROUTINESPEC PWORD(%INTEGER WORD) %EXTERNALROUTINESPEC PB1(%INTEGER OPCODE) %EXTERNALROUTINESPEC PB2(%INTEGER OPCODE,BYTE) %EXTERNALROUTINESPEC PB3(%INTEGER OPCODE,BYTE1,BYTE2) %EXTERNALROUTINESPEC PB4(%INTEGER OPCODE,B1,B3,B3) %EXTERNALROUTINESPEC PBW(%INTEGER OPCODE,WORD) %EXTERNALROUTINESPEC PWW(%INTEGER OPCODE,W1,W2) %EXTERNALROUTINESPEC PB2W(%INTEGER OPCODE,BYTE1,WORD) %EXTERNALROUTINESPEC PERM %EXTERNALROUTINESPEC CAB %EXTERNALROUTINESPEC CNOP(%INTEGER I, J) %EXTERNALROUTINESPEC PGLA(%INTEGER BDRY, L, INF ADR) %EXTERNALROUTINESPEC PLUG(%INTEGER AREA, AT, VALUE, BYTES) %EXTERNALROUTINESPEC GXREF(%STRING(31) NAME,%INTEGER MODE,XTRA,AT) %EXTERNALROUTINESPEC CIOCP(%INTEGER N) %EXTERNALROUTINESPEC RELOCATE(%INTEGER BITS,GLARAD,AREA) %EXTERNALROUTINESPEC ABORT %EXTERNALROUTINESPEC PERQPROLOGUE %EXTERNALROUTINESPEC REPEAT PROLOGUE %EXTERNALROUTINESPEC PERQEPILOGUE(%INTEGER STMTS) %DYNAMICROUTINESPEC QPUT(%INTEGER A,B,C,D) %EXTERNALROUTINESPEC FAULT(%INTEGER A,B,C) %EXTERNALROUTINESPEC WARN(%INTEGER N,V) %EXTERNALROUTINESPEC PPJ(%INTEGER MASK,N) %EXTERNALROUTINESPEC ERASE(%INTEGER WORDS) %EXTERNALREALFNSPEC ICLREALTOPERQ(%REAL ICLREAL) %EXTERNALLONGREALFNSPEC ICLLONGREALTOPERQ(%LONGREAL ICLREAL) %EXTERNALROUTINESPEC PRINTTRIPS(%RECORD(TRIPF)%ARRAYNAME T) ! END OF "ERCC07.PERQ_XSPECS" %EXTERNALROUTINESPEC STACKDUMP(%INTEGER WORDS) %EXTERNALROUTINESPEC STACKUNDUMP(%INTEGER WORDS) %EXTERNALROUTINESPEC CTOP(%INTEGERNAME OP,MASK,%INTEGER XTRA, %RECORD(RD)%NAME OPND1,OPND2) %EXTERNALROUTINESPEC GENERATE(%RECORD(TRIPF)%ARRAYNAME T, %RECORD(LEVELF)%NAME L,%ROUTINE GETWSP(%INTEGERNAME PL,%INTEGER SIZE)) %EXTERNALROUTINESPEC PRINTLIST(%INTEGER HEAD) ! START OF COMPILATION A==ARRAY(WORKA_WKFILE AD+256*WORKA_WKFILEK, AF) %BEGIN !*********************************************************************** !* THIS BLOCK INITIALISE THE COMPILER SCALARS AND ARRAYS * !* WAS ORIGINALLY ROUTINE 'INITIALISE'. * !* THE INITIALISATION OF THE CONSTANT LISTS WITH THE VALUES * !* IN PERM MAY BE OMITTED IN BATCH OR CUT-DOWN VERSIONS. * !*********************************************************************** %EXTERNALINTEGERFNSPEC PASSONE WORKA_CCSIZE=256*(WORKA_WKFILEK-1) %BYTEINTEGERARRAYFORMAT CCF(0:WORKA_CCSIZE) %BYTEINTEGERARRAYNAME CC CC==ARRAY(WORKA_WKFILEAD+32,CCF) WORKA_CC==CC WORKA_A==A WORKA_WORD==WORD WORKA_TAGS==TAGS WORKA_LINE==LINE WORKA_RELEASE=RELEASE WORKA_LADATE=LADATE WORKA_AASL0=ADDR(ASLIST(0)) PLABEL=24999 N=12; MAX ULAB=WORKA_NNAMES+16384; ! LARGEST VALID USER LABEL LAST INST=0 SFLABEL=20999 EXITLAB=0; CONTLAB=0 RLEVEL=0; NMAX=0; BFFLAG=0 RBASE=1 CA==CODEP_CAS(1); GLACA==CODEP_CAS(2) SSTL==CODEP_CAS(4); USTPTR==CODEP_CAS(5) STMTS=1; SNUM=0 BIMSTR=0 WORKA_RTCOUNT=1; ! ROUTINE 0 RESERVED FOR MAIN PROG MAINEP="S#GO"; ! DEFAULT MAIN ENTRY ! ! OPEN OBJECT FILE HERE BEFORE MORE PAGES OF COMPILER CODE ! ARE PAGED IN AND SUB-SYSTEM PAGES MOVE OUT ! QPUT(0,0,0,0) INITASL(ASLIST,ASL) %CYCLE I=0,1,12 DVHEADS(I)=0 %REPEAT ! DUMMY FORMAT=0; ! DUMMY RECORD FORMAT PUSH(DUMMY FORMAT,0,0,0); ! FOR BETTER ERROR RECOVERY P1SIZE=PASSONE R=P1SIZE WORKA_ARTOP=P1SIZE %END; ! OF BLOCK CONTAINING PASS 1 %BEGIN !*********************************************************************** !* SECOND OR TRIPLES GENERATING PASS * !*********************************************************************** %RECORD(LEVELF)%NAME CURRINF %INTEGER TWSPHEAD %RECORD(TRIPF)%ARRAY TRIPLES(0:999) %INTEGERARRAYFORMAT CF(0:12*WORKA_NNAMES) %INTEGERARRAYNAME CTABLE !%ROUTINESPEC NOTE CREF(%INTEGER CA) !%ROUTINESPEC STORE CONST(%INTEGERNAME D,%INTEGER L,AD) !%INTEGERFNSPEC WORD CONST(%INTEGER VALUE) %ROUTINESPEC REUSE TEMPS %ROUTINESPEC GET WSP(%INTEGERNAME PLACE,%INTEGER SIZE) %ROUTINESPEC RETURN WSP(%INTEGER PLACE,SIZE) %ROUTINESPEC COMPILE A STMNT %INTEGERFNSPEC NEW TRIP %INTEGERFNSPEC UCONSTTRIP(%INTEGER OPERN,OPTYPE,FLAGS,CONST) %INTEGERFNSPEC UNAMETRIP(%INTEGER OPERN,OPTYPE,FLAGS,NAME) %INTEGERFNSPEC UTEMPTRIP(%INTEGER OPERN,OPTYPE,FLAGS,TEMP) %INTEGERFNSPEC BRECTRIP(%INTEGER OPERN,OPTYPE,FLAGS, %RECORD(RD)%NAME OPND1,OPND2) %INTEGERFNSPEC URECTRIP(%INTEGER OPERN,OPTYPE,FLAG,%RECORD(RD)%NAME OPND1) %ROUTINESPEC CSS(%INTEGER P) %CYCLE I=0, 1, MAXLEVELS LEVELINF(I)=0 LEVELINF(I)_NAMES=-1 %REPEAT CTABLE==ARRAY(ADDR(ASLIST(1)),CF) WORKA_CTABLE==CTABLE WORKA_LEVELINF==LEVELINF CTABLE(0)=M'CTAB' LINE=0 TWSPHEAD=0 PERQPROLOGUE NEXTTRIP=1 NEXTP=1; LEVEL=1; STMTS=0 CURRINF==LEVELINF(LEVEL) RLEVEL=0; RBASE=0 %WHILE A(NEXTP+3)!A(NEXTP+4)#0 %CYCLE COMPILE A STMNT %REPEAT LINE=99999 PERQEPILOGUE(STMTS) %STOP %ROUTINE FORCE TRIPS !*********************************************************************** !* FORCE OUT THE TRIPLES TO CODE. NEEDED IN CEND ETC * !*********************************************************************** %IF PARM_DCOMP#0 %THEN CODEOUT %RETURN %IF NEXT TRIP=1 GENERATE(TRIPLES,CURRINF,GET WSP) %IF PARM_DCOMP#0 %THEN CODEOUT TRIPLES(0)=0 NEXTTRIP=1 TRIPLES(0)_FLINK=NEXT TRIP %END %ROUTINE COMPILE A STMNT %INTEGER I %IF TWSPHEAD#0 %THEN REUSE TEMPS FORCE TRIPS %IF NEXT TRIP>1 I=NEXTP STARSIZE=A(NEXTP)<<16+A(NEXTP+1)<<8+A(NEXTP+2) NEXTP=NEXTP+STARSIZE LINE=A(I+3)<<8+A(I+4) STMTS=STMTS+1 CSS(I+5) ! %CYCLE I=0,1,4 ! %REPEAT ! CHECK ASL %IF LINE&7=0 %END %ROUTINE CSS(%INTEGER P) %RECORDFORMAT RD((%INTEGER S1 %OR %BYTEINTEGER UPTYPE,PTYPE,XB,FLAG),%C %INTEGER D,XTRA) %ROUTINESPEC ENTER JUMP(%INTEGER MASK,STAD,FLAG) %INTEGERFNSPEC ENTER LAB(%INTEGER M,FLAG) %ROUTINESPEC REMOVE LAB(%INTEGER LAB) %ROUTINESPEC CEND(%INTEGER KKK) %INTEGERFNSPEC CCOND(%INTEGER CTO,A,B,JFLAGS) %INTEGERFNSPEC REVERSE(%INTEGER MASK) %ROUTINESPEC SET LINE %ROUTINESPEC CUI(%INTEGER CODE) %ROUTINESPEC ASSIGN(%INTEGER A,B) %ROUTINESPEC CSTART(%INTEGER CCRES,MODE) %INTEGERFNSPEC CHECKBLOCK(%INTEGER P,PIN) %ROUTINESPEC CCYCBODY(%INTEGER UA,ELAB,CLAB) %ROUTINESPEC CLOOP(%INTEGER ALT,MARKC,MARKUI) %ROUTINESPEC CIFTHEN(%INTEGER MARKIU,MARKC,MARKUI,MARKE,MARKR,SKIP) %ROUTINESPEC CREATE AH(%INTEGER MODE) %ROUTINESPEC TORP(%INTEGERNAME HEAD,BOT,NOPS) %INTEGERFNSPEC INTEXP(%INTEGERNAME VALUE,%INTEGER PRECTYPE) %INTEGERFNSPEC CONSTEXP(%INTEGER PRECTYPE) %ROUTINESPEC CSEXP(%INTEGER MODE) %ROUTINESPEC CSTREXP(%INTEGER B) %ROUTINESPEC CRES(%INTEGER LAB) %ROUTINESPEC EXPOP(%INTEGERNAME A,B,%INTEGER C,D) %ROUTINESPEC TEST APP(%INTEGERNAME NUM) %ROUTINESPEC SKIP EXP %ROUTINESPEC SKIP APP %ROUTINESPEC NO APP %INTEGERFNSPEC DOPE VECTOR(%INTEGER A,B,MODE,ID,%INTEGERNAME C,D) %ROUTINESPEC DECLARE ARRAYS(%INTEGER A,B) %ROUTINESPEC DECLARE SCALARS(%INTEGER A,B) %ROUTINESPEC CRSPEC(%INTEGER M) %INTEGERFNSPEC SET SWITCHLAB(%INTEGER HEAD,LAB,FNAME,BIT) %ROUTINESPEC CFPLIST(%INTEGERNAME A,B) %ROUTINESPEC CFPDEL %ROUTINESPEC CLT %ROUTINESPEC CQN(%INTEGER P) %INTEGERFNSPEC TSEXP(%INTEGERNAME VALUE) %ROUTINESPEC CRCALL(%INTEGER RTNAME) %ROUTINESPEC NAMEOP(%INTEGER Z,SIZE,NAMEP) %ROUTINESPEC CNAME(%INTEGER Z) %ROUTINESPEC AATORP(%INTEGERNAME A,B,C,%INTEGER D,E,F) %ROUTINESPEC CANAME(%INTEGER Z,ARRP,BS,DP) %ROUTINESPEC CSNAME(%INTEGER Z) %ROUTINESPEC COPY TAG(%INTEGER KK) %ROUTINESPEC REDUCE TAG %ROUTINESPEC STORE TAG(%INTEGER KK,SLINK) %ROUTINESPEC UNPACK %ROUTINESPEC PACK(%INTEGERNAME PTYPE) %ROUTINESPEC DIAG POINTER(%INTEGER LEVEL) %ROUTINESPEC RDISPLAY(%INTEGER KK) %ROUTINESPEC RHEAD(%INTEGER RTNAME,AXNAME) %ROUTINESPEC EVEN ALIGN %INTEGERFNSPEC CFORMATREF %ROUTINESPEC CRFORMAT(%INTEGERNAME OPHEAD,OPBOT,NLIST,MRL,%INTEGER INIT) %INTEGERFNSPEC DISPLACEMENT(%INTEGER LINK) %INTEGERFNSPEC COPY RECORD TAG(%INTEGERNAME SUBS) %ROUTINESPEC BULKM(%INTEGER M,L,D2) %ROUTINESPEC BYTECUT(%INTEGER ODDEVEN) %ROUTINESPEC DFETCHAD(%INTEGER SEGNO,LEVEL,DISP) %ROUTINESPEC DFETCH(%INTEGER SIZE,LEVEL,DISP) %ROUTINESPEC DSTORE(%INTEGER SIZE,LEVEL,DISP) %SWITCH SW(1:24) %CONSTBYTEINTEGERARRAY FCOMP(0:14)=0, 8,10,2,7,12,4,7, 8,12,4,7,10,2,7; %INTEGER SNDISP,ACC,K,KFORM,STNAME,MIDCELL %INTEGER TCELL,JJ,JJJ,KK,QQ,MARKER,REPORTUI,XDISP,MASK, %C BASE,AREA,ACCESS,DISP,EXTRN, CURR INST,VALUE,STRINGL, %C PTYPE,I,J,OLDI,USEBITS,STRFNRES,BML,DML, %C MARKIU,MARKUI,MARKC,MARKE,MARKR,INAFORMAT %INTEGER LITL,ROUT,NAM,ARR,PREC,TYPE %OWNINTEGER FPTR %RECORD(RD) EXPOPND; ! RESULT RECORD FOR EXPOP CURR INST=0; INAFORMAT=0 ->SW(A(P)) SW(13): ! INCLUDE SOMETHING SW(24): ! REDUNDANT SEP SW(2): ! CSSEXIT: LAST INST=CURR INST %RETURN SW(1): !(UI)(S) FAULT(57,0,0) %UNLESS LEVEL>=2 MARKER=P+1+A(P+1)<<8+A(P+2) P=P+3 ->LABFND %IF A(MARKER)=1 %IF A(MARKER)=2 %THEN SET LINE %AND CUI(0) %AND ->CSSEXIT MARKE=0; MARKR=0 MARKUI=P; MARKIU=MARKER+1 MARKC=MARKIU+1 %IF A(MARKER)=3 %THEN CIFTHEN(MARKIU,MARKC,MARKUI,0,0,NO) %C %AND ->CSSEXIT CLOOP(A(MARKIU),MARKC+2,MARKUI) ->CSSEXIT LABFND: OLDLINE=0 ->SWITCH %UNLESS A(P)=1 %AND A(P+5)=2; ! 1ST OF UI AND NO APP ->SWITCH %UNLESS A(P+6)=2 %AND A(P+7)=2;! NO ENAMSE OR ASSNMNT JJ=ENTER LAB(FROM AR2(P+3),0); ->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) J=FROM AR4(P+2) CODEOUT PARM_DCOMP=J>>28; ->CSSEXIT ! SW(3): ! (%IU)(COND)%THEN(UI)(ELSE') MARKIU=P+1; MARKC=MARKIU+3 MARKR=P+2+A(P+2)<<8+A(P+3); ! ! FROMAR2(P+2) MARKE=0 %IF A(MARKR)=3 %THEN %START MARKE=MARKR+1+FROMAR2(MARKR+1) MARKUI=MARKR+3 %FINISH CIFTHEN(MARKIU,MARKC,MARKUI,MARKE,MARKR,NO) ->CSSEXIT SW(4): ! '%FINISH(ELSE')(S) ->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,X'41')=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) %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; ->CSSEXIT SW(23): ! SWITCH(*): %BEGIN %INTEGER FNAME,LB,UB,JJ,RES FNAME=FROM AR2(P+1) COPY TAG (FNAME) %IF OLDI=LEVEL %AND TYPE=6 %START FROM123(K,JJ,LB,UB) %CYCLE JJ=LB,1,UB RES=SET SWITCHLAB(K,JJ,FNAME,0) %REPEAT %FINISH %ELSE FAULT(4,0,FNAME) %END; ->CSSEXIT ! SW(7): ! (%WU)(SC)(COND)(RESTOFWU) FAULT(57,0,0) %UNLESS LEVEL>=2 MARKIU=P+1; ! TO WHILE/UNTIL MARKC=MARKIU+3; ! TO (SC)(COND) CLOOP(A(MARKIU)+3,MARKC,MARKIU+1+FROMAR2(MARKIU+1)) ->CSSEXIT ! SW(8): ! SIMPLE DECLN FAULT(57,0,0) %UNLESS LEVEL>=2 FAULT(40,0,0) %IF CURRINF_NMDECS&1#0 P=P+1 MARKER=P+FROMAR2(P); ! TO ALT OF DECLN P=P+2; ROUT=0; LITL=0 %IF A(MARKER)#1 %THEN %START; ! ARRAY DECLARATIONS CLT %IF TYPE=5 %AND (ACC<=0 %OR ACC>256) %THEN %C FAULT(70,ACC-1,0) %AND ACC=255 NAM=0 SET LINE QQ=2-A(P+1); P=P+2; ! QQ=1 FOR ARRAYFORMATS DECLARE ARRAYS(QQ,KFORM) %FINISH %ELSE %START CLT CQN(P+1); P=P+2 DECLARE SCALARS(1,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 %RECORD(LISTF)%NAME LCELL P=P+1; MARKER1=FROM AR2(P)+P; ! (SEX)(RT)(SPEC')(NAME)(FPP) AGN: Q=P; RTNAME=FROM AR2(MARKER1+1); ! RTNAME ON NAME EXTRN=A(P+2); ! 1=SYSTEM,2=EXTERNAL ! 3=DYNAMIC, 4=INTERNAL LITL=EXTRN&3 %IF A(MARKER1)=1 %THEN %START; ! P<%SPEC'>='%SPEC' P=P+3; CRSPEC(1-EXTRN>>2); ! 0 FOR ROUTINESPEC ! 1 FOR EXTERNAL (ETC) SPEC ->BEND %FINISH COPY TAG(RTNAME) AXNAME=WORKA_DICTBASE+WORD(RTNAME) %IF EXTRN=3 %THEN EXTRN=2 %IF A(MARKER1+3)=1 %THEN AXNAME=ADDR(A(MARKER1+4)) %IF EXTRN=4 %THEN AXNAME=0 %IF OLDI=LEVEL %THEN %START; ! NAME ALREADY KNOWN AT THIS LEVEL %IF PARM_CPRMODE=0 %THEN PARM_CPRMODE=2; ! FLAG AS FILE OF ROUTINES FAULT(56,0,RTNAME) %UNLESS EXTRN=4 %OR %C (PARM_CPRMODE=2 %AND LEVEL=1) %IF A(P+3)=1 %THEN KKK=LITL<<14!X'1000' %ELSE %START ROUT=1; P=P+4; ! FIGURE OUT PTYPE FOR FNS&MAPS CLT; ARR=0; NAM=0 %IF A(P)=2 %THEN NAM=2; ! SET NAME ARRAY BIT FOR MAPS PACK(KKK); ! AND STORE PTYPE IN KKK %FINISH %FINISH ! ! UNLESS A MATCH WAS OBTAINED BETWEEN HEADING AND SPEC SOMETHING ! HAS GONE WRONG. COMPILE HEADING AGAIN AS SPEC. THIS WILL ! PREVENT ANY INCONSISTENCIED AND CAUSE A "NAME SET TWICE" ! FOR ANY ERROR ! %UNLESS OLDI=LEVEL %AND (J=15 %OR J=7*EXTRN) %AND %C PTYPE=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 COPYTAG IN THIS SEQUENCE ! LCELL==ASLIST(TAGS(RTNAME)) LCELL_S1=LCELL_S1&X'3FF0'!PTYPE<<16!USEBITS<<14 ! NEWPTYPE & SET J=0 %IF J=14 %THEN LCELL_S2=WORKA_RTCOUNT %AND %C WORKA_RTCOUNT=WORKA_RTCOUNT+1; ! NO RT NO ALLOCATED TO EXTERNAL SPECS PTYPEP=PTYPE PCHAIN=K; ! CHAIN OF PARAMETER DESCRIPTUONS RHEAD(RTNAME,AXNAME); ! FIRST PART OF ENTRY SEQUENCE ! ! NOW DECLARE THE FORMAL PARAMETERS. FOLLOW BY CLAIMING DISPLAY ! AND SETTING DIAGNOSTIC PTR IN ROUTINE RDISPLAY ! P=MARKER1+4 %IF A(P-1)=1 %THEN P=P+A(P)+1; ! SKIP OVER ALIASNAME N=0; CNT=1 PTYPE=PTYPEP; UNPACK %IF TYPE#0 %THEN N=(BYTES(PREC)+1)&(-2) %IF NAM#0 %OR TYPE=5 %THEN N=4; ! MAPS %WHILE A(P)=1 %CYCLE; ! WHILE SOME (MORE) FP PART PP=P+1+FROMAR2(P+1) P=P+3 CFPDEL PTR=P %UNTIL A(PTR-1)=2 %CYCLE; ! CYCLE DOWN NAMELIST %IF PCHAIN#0 %THEN %START FROM12(PCHAIN,J,JJJ); ! EXTRACT PTYPE XTRA INFO %UNLESS J>>16=PTYPE %AND(PTYPE#5 %OR JJJ>>16=ACC)%C %THEN FAULT(9,CNT,RTNAME) %FINISH %ELSE FAULT(8,0,RTNAME);! MORE FPS THAN IN SPEC PTR=PTR+3 CNT=CNT+1 MLINK(PCHAIN) %REPEAT DECLARE SCALARS(0,KFORM) P=PP %REPEAT; ! UNTIL NO MORE FP-PART N=(N+1)&(-2); ! TO WORD BOUNDARY AFTER ALL SYSTEM ! STANDARD PARAMETERS HAVE BEEN DECLARED FAULT(10,0,RTNAME) %UNLESS PCHAIN=0 PTYPE=PTYPEP ! %IF PTYPE&X'F0F'=5 %THEN N=N+8; ! STR FNS RESULT PARAM IS STACKED ! AS XTRA PARM JUST BEFORE DISPLAY RDISPLAY(RTNAME) BEND: %END; ->CSSEXIT ! SW(14): ! %BEGIN %BEGIN PTYPE=0 %IF LEVEL=1 %AND RLEVEL=0 %START %IF PARM_CPRMODE=0 %THEN %START RLEVEL=1; RBASE=1 CURRINF_ENTRYAD=CA; ! MAIN ENTRY PARM_CPRMODE=1 RHEAD(-1,ADDR(MAINEP)) N=0 %FINISH %ELSE FAULT(58,0,0) %FINISH %ELSE %START SET LINE; ! SO 'ENTERED FROM LINE' IS OK RHEAD(-1,0) %FINISH RDISPLAY(-1) %END ->CSSEXIT ! SW(15): ! '%ON'(EVENT')(N)(NLIST)'%START' FAULT(57,0,0) %UNLESS LEVEL>=2 FAULT(40,0,0) %IF CURRINF_NMDECS&1#0 CURRINF_NMDECS=CURRINF_NMDECS!X'11';! NO MORE DECS AND IN ONCOND PB1(NOOP); ! GET PROGRAM MASK ! DUMPRX(ST,0,0,RBASE,N+8); ! AND SAVE IT 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,X'41')=0 %AND 1<=KK<=14 JJ=JJ!1<<(KK-1) %REPEAT P=P+1 KK=CA; PGLA(4,4,ADDR(CA)) ! RELOCATE(GLACA-4,KK,1); ! ENTRY ADDRESS IN PLT CURRINF_ONWORD=JJ<<18!(GLACA-4) ! DUMPM(STM,0,1,RBASE,N); ! AND SAVE THEM ! DUMPRX(LGR,1,0,RBASE,N+8); ! RETRIEVE PROGRAM MASK PB1(NOOP); ! AND RESET IT CURRINF_ONINF=N; N=N+12 OLDLINE=0 CSTART(0,3) CURRINF_NMDECS=CURRINF_NMDECS!!X'10';! NOT IN ONCOND JJ=ENTER LAB(JJJ,B'111'); ! REPLACE ENVIRONMENT ->CSSEXIT SW(16): %BEGIN; ! %SWITCH (SWITCH LIST) %INTEGER Q,RANGE,KKK,LB,UB,PP,D0,OPHEAD,V,R FAULT(57,0,0) %UNLESS LEVEL>=2 Q=P PLABEL=PLABEL-1 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,X'41'); ! EXTRACT LOWER BOUND P=P+3 KKK=KKK!INTEXP(UB,X'41'); ! 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 %IF CA&1=0 %THEN PB1(NOOP) SNDISP=CA; ! OF CASE JUMP PB1(XJP) PWORD(LB) PWORD(UB) V=WORKA_PLABS(6)-CA PWORD(V); ! TO PLABS(6) IF BOUND FAULT D0=CA; ! START OF TABLE PUSH(OPHEAD,D0,LB,UB) KFORM=0; ACC=4 J=1; STORE TAG(K,OPHEAD) ! !THE TABLE WILL CONSIST OF RELATIVE DISPLACEMENTS FROM EACH ENTRY ! TO THE LABEL POSN. SET ALL TO GO TO PLAB(6) INITIALLY ! V=V-2 %CYCLE KKK=LB,1,UB PWORD(V) V=V-2 %REPEAT %REPEAT; ! FOR ANY MORE NAMES IN NAMELIST Q=PP; P=Q %REPEAT; ! UNTIL A(Q)=2 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. * !*********************************************************************** %ROUTINESPEC CLEAR(%INTEGER L) %ROUTINESPEC STAG(%INTEGER J, DATALEN) %ROUTINESPEC XTRACT CONST(%INTEGER CONTYPE, CONPREC) %ROUTINESPEC INIT SPACE(%INTEGER A, B) %HALFINTEGER AH1, AH2, AH3, AH4 %INTEGER LENGTH, PP, SIGN, FICONST, ICONST, TAGDISP, EPTYPE, EPDISP, AD, STALLOC, SPOINT, CONSTSFOUND, CPREC, EXTRN, NNAMES, %C MARK, QPUTP, LB, CTYPE, CONSTP, FORMAT,DPTYPE, %C DIMEN, SACC, TYPEP %LONGREAL RCONST, FRCONST %OWNLONGREAL ZERO=0 %STRING (255) SCONST, NAMTXT %RECORD(LISTF)%NAME LCELL %INTEGERNAME STPTR QPUTP=45; STPTR==USTPTR; ! NORMAL CASE GLA SYMBOLTABLES ! FAULT(40,0,0) %IF NMDECS&1#0 EXTRN=A(P+1) P=P+2 %IF EXTRN>=4 %THEN EXTRN=0; ! CONST & CONSTANT->0 SNDISP=0 CONSTS FOUND=0 %IF EXTRN=0 %THEN QPUTP=44 %AND STPTR==SSTL CLT ! ! CHECK FOR %SPEC AND CHANGE EXTERNAL SPEC TO EXTRINSIC ! %IF A(P+2)=1 %START %IF EXTRN=2 %THEN EXTRN=3 %ELSE FAULT(46,0,0) %FINISH %IF 2<=EXTRN<=3 %AND ((A(P)=1 %AND A(P+1)#3) %OR %C (A(P)=2 %AND A(P+1)#2)) %THEN FAULT(46,0,0) LITL=EXTRN %IF LITL<=1 %THEN LITL=LITL!!1 %IF A(P)=1 %THEN CQN(P+1) %ELSE ARR=1 %AND NAM=0 %IF TYPE=5 %AND NAM=0 %AND (ACC<=0 %OR ACC>256) %THEN %C FAULT(70,ACC-1,0) %AND ACC=2 STALLOC=ACC; ! ALLOCATION OF STORE FOR ITEM OR POINTER %IF 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(WORKA_DICTBASE+WORD(K)) %IF A(P)=1 %THEN NAMTXT<-STRING(ADDR(A(P+1))) %AND %C P=P+A(P+1)+1 P=P+1; ! P ON CONST' ! ! OBTAIN THE INITIAL CONSTANT,ITS TYPE(CTYPE) AND SIGN(SIGN) ! ICONST=0; FICONST=0 RCONST=0; FRCONST=0; 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 %FINISH J=0 %IF NAM#0 %THEN %START; ! OWNNAMES AND ARRAYNAMES AH1<-FICONST>>16 AH2<-FICONST %IF ARR=0 %THEN %START %IF TYPE=5 %THEN STALLOC=6 %AND AH3=ACC-1 PGLA(2,STALLOC,ADDR(AH1)) %FINISH %ELSE %START; ! ARRAYNAMES AH3=DOPE VECTOR(TYPE,ACC,-1,K,QQ,LB)>>1 AH4=0 %IF PARM_COMPILER#0 %AND LB#0 %THEN FAULT(99,0,0) %IF EXTRN#0 %THEN SNDISP=0 %ELSE %C SNDISP=(SNDISP&X'3FFFF')>>2 PGLA(4,STALLOC,ADDR(AH1)) RELOCATE(32,GLACA-4,4) %FINISH TAGDISP=GLACA-STALLOC; EPDISP=TAGDISP STAG(TAGDISP,STALLOC) P=MARK %CONTINUE %FINISH %IF EXTRN=3 %THEN %START; ! EXTRINISIC PTYPE=PTYPE!X'400'; ! FORCE NAM=1 (IE VIA POINTER) AH3=0; AH2=0 PGLA(4,4,ADDR(AH2)) TAGDISP=GLACA-4 GXREF(NAMTXT,2,2<<24,TAGDISP);! RELOCATE BY EXTERNAL STAG(TAGDISP,STALLOC) P=MARK %CONTINUE %FINISH %IF TYPE=5 %THEN %START; ! STRING PTYPE=PTYPE!X'400'; ! FORCE NAM = 1 AH1=STPTR>>1 AH2=0; ! WILL HAVE SEGMENT NO AH3=ACC-1 AD=ADDR(SCONST) %IF PARM_INHCODE=0 %START QPUT(QPUTP,STALLOC,STPTR,AD) %IF ONPERQ=NO %THEN QPUT(9,QPUTP-40,STPTR,STALLOC) %FINISH ! O/P STRING STPTR=(STPTR+STALLOC+1)&(-2) PGLA(2,6,ADDR(AH1)) TAGDISP=GLACA-6 RELOCATE(32,TAGDISP,QPUTP-40) EPTYPE=5; EPDISP=AH1; ! DATA IN GLA SYMBOL TABLES %FINISH %IF TYPE=3 %THEN %START; ! RECORDS EPDISP=GLACA TAGDISP=EPDISP; ! AND RELOCATE REL APPROPIATE AREA EPTYPE=2; ! DATA IN GLA TABLES I=0; ICONST=ICONST&255 ICONST=ICONST<<8!ICONST %WHILE IBEND 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(WORKA_DICTBASE+WORD(K)) SACC=ACC; TYPEP=PTYPE AH3=DOPE VECTOR(TYPE,STALLOC,0,K,QQ,LB)>>1 %IF SNDISP=-1 %THEN SNDISP=0; ! BUM DOPE VECTOR SNDISP=(SNDISP&X'3FFFF')>>2; ! AS WORD DISPLACEMENT DIMEN=J; ! SAVE NO OF DIMENESIONS ACC=SACC; PTYPE=TYPEP; UNPACK %IF LB=0 %AND FORMAT=0 %THEN ARR=2 %AND PACK(PTYPE) %IF TYPE=3 %THEN LENGTH=QQ %ELSE LENGTH=QQ//STALLOC;! NO OF ELEMENTS SPOINT=STPTR %IF FORMAT=0 %THEN %START %IF A(P)=1 %THEN P=P+1 %AND INIT SPACE(QQ,LENGTH) %FINISH %IF CONSTS FOUND=0 %THEN %START; ! NO CONSTANTS GIVEN ! SO CLEAR AN AREA TO ZERO CONSTS FOUND=LENGTH CLEAR(QQ) %UNLESS LENGTH<1 %OR EXTRN=3 %OR FORMAT#0 %FINISH %ELSE %START FAULT(49,0,K) %IF EXTRN=3 %OR FORMAT#0 %FINISH %IF EXTRN=3 %THEN EPDISP=0 %ELSE EPDISP=SPOINT ! OUTPUT AN ARRAYHEAD INTO THE GLA RELATIVE TO THE START OF THE SYMBOL- ! TABLES IN WHICH THE ARRAY RESIDES. J=DIMEN; ! RESET DIMENSIONS AFTER INITTING AH1=EPDISP>>1 AH2=0; ! WILL BE SEG NO AH4=0; ! WILL BE DV SEG NO PGLA(4,8,ADDR(AH1)) TAGDISP=GLACA-8 %IF EXTRN=3 %THEN %START; ! EXTRINSIC ARRAYS GXREF(NAMTXT,2,2<<24,TAGDISP); ! RELOCATE ADDR(A(0)) %FINISH %ELSE %START RELOCATE(32,TAGDISP,QPUTP-40) %FINISH RELOCATE(32,TAGDISP+4,4); ! RELOCATE DV POINTER EPTYPE=5; ! DATA IN GLA SYMBOL TABLES STAG(TAGDISP,QQ) ->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 * !*********************************************************************** %INTEGER RF, I, II, ELSIZE, AD, SPP, LENGTH, SAVER, WRIT %BYTEINTEGERARRAYNAME SP %BYTEINTEGERARRAYFORMAT SPF(0:4096+256) SAVER=R; R=R+(4096+256) %IF R>ARSIZE %THEN FAULT(102, WORKA_WKFILEK,0) SP==ARRAY(ADDR(A(SAVER)),SPF) %IF TYPE=1 %THEN AD=ADDR(FICONST) %IF TYPE=2 %THEN AD=ADDR(FRCONST)+8-ACC %IF TYPE=3 %THEN AD=ADDR(ICONST)+3 %IF TYPE=5 %THEN AD=ADDR(SCONST) SPP=0; WRIT=0 ELSIZE=SIZE//NELS %UNTIL A(P-1)=2 %CYCLE XTRACT CONST(TYPE,PREC) %IF A(P)=1 %START; ! REPITITION FACTOR P=P+2 %IF A(P-1)=2 %THEN RF=NELS-CONSTS FOUND %ELSE %START P=P+2 %IF INTEXP(RF,X'41')#0 %THEN FAULT(41,0,0) %AND RF=1 %FINISH P=P+1 %FINISH %ELSE RF=1 %AND P=P+2 FAULT(42,RF,0) %IF RF<=0 %CYCLE I=RF,-1,1 %IF TYPE=1=ACC %OR TYPE=3 %START %CYCLE II=0,1,ELSIZE-1 %IF CONSTS FOUND<=NELS %THEN SP(SPP)<- %C ICONST %AND SPP=SPP+1 %REPEAT %FINISH %ELSE %START %CYCLE II=0,2,ELSIZE-2 %IF CONSTS FOUND<=NELS %THEN %C HALFINTEGER(ADDR(SP(SPP)))=HALFINTEGER(AD+II) %C %AND SPP=SPP+2 %REPEAT %FINISH CONSTS FOUND=CONSTS FOUND+1 %IF SPP>=4096 %START; ! EMPTY BUFFER %IF PARM_INHCODE=0 %THEN %START QPUT(QPUTP,SPP,STPTR+WRIT,ADDR(SP(0))) %IF ONPERQ=NO %AND (TYPE=5 %OR (TYPE=1 %AND PREC=3))%C %THEN QPUT(9,QPUTP-40,STPTR+WRIT,SPP) %FINISH WRIT=WRIT+SPP SPP=0 %FINISH %REPEAT %REPEAT; ! UNTIL P=%NULL %IF CONSTS FOUND#NELS %THEN FAULT(45,CONSTS FOUND,NELS) LENGTH=(SIZE+3)&(-4) %IF PARM_INHCODE=0 %START QPUT(QPUTP,LENGTH-WRIT,STPTR+WRIT,ADDR(SP(0))) %IF ONPERQ=NO %AND(TYPE=5 %OR(TYPE=1 %AND PREC=3)) %C %THEN QPUT(9,QPUTP-40,STPTR+WRIT,LENGTH-WRIT) %FINISH STPTR=STPTR+LENGTH R=SAVER %END %ROUTINE CLEAR(%INTEGER LENGTH) STPTR=(STPTR+3)&(-4) LENGTH=(LENGTH+3)&(-4) QPUT(QPUTP,LENGTH<<14!4,STPTR,ADDR(ZERO)) %IF PARM_INHCODE=0 STPTR=STPTR+LENGTH %END %ROUTINE STAG(%INTEGER J, DATALEN) %IF EXTRN=2 %THEN QPUT(14,EPTYPE<<24!DATALEN,EPDISP,ADDR( %C NAMTXT)) RBASE=0 STORE TAG(K,J) RBASE=RLEVEL %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 LENGTH, STYPE, SACC, CPREC, MODE, I %LONGREAL LRCONST; ! TO ASSIST IN FORMAT CHANGES STYPE=PTYPE; SACC=ACC; ! MAY BE CHANGED IF CONST IS EXPR %IF CONTYPE=5 %THEN %START CTYPE=5 %IF A(P)=4 %AND A(P+1)=2 %AND A(P+2)=X'35' %C %AND A(P+A(P+3)+4)=2 %START SCONST=STRING(ADDR(A(P+3))) LENGTH=A(P+3) P=P+A(P+3)+5 %FINISH %ELSE %START FAULT(44,CONSTS FOUND,K); SCONST="" LENGTH=0; P=P-3; SKIP EXP %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) %AND CONSTP=ADDR(ZERO) ! CANT EVALUATE EXPT CTYPE=TYPE; CPREC=PREC %IF CTYPE=1 %THEN %START ICONST=INTEGER(CONSTP) %FINISH %ELSE %START RCONST=LONGREAL(CONSTP) %FINISH %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 (CTYPE=5 %AND LENGTH>=ACC) %C %OR (CONTYPE=1 %AND ((CONPREC=3 %AND ICONST>255) %C %OR (CONPREC=4 %AND ICONST>X'FFFF'))) %C %THEN FAULT(44,CONSTS FOUND,K) ! ! IF CROSS COMPILING THEN A CONSTANT FORMAT CHANGE IS NEED FROM ! IBM&ICL FORM TO PERQ FORM. IF ON PERQ FORMAT IS CORRECT ! FICONST=ICONST; FRCONST=RCONST %IF ON PERQ=NO %THEN %START FICONST=(ICONST>>16)!(ICONST<<16) %IF CONPREC=6 %THEN LRCONST=ICLLONGREALTOPERQ(RCONST) %ELSE %C LRCONST=ICLREALTOPERQ(RCONST) %CYCLE I=0,2,6 HALFINTEGER(ADDR(FRCONST)+6-I)=HALFINTEGER(ADDR(LRCONST)+I) %REPEAT %FINISH %END BEND: %END; ->CSSEXIT SW(18): ABORT SW(10): %BEGIN; ! %RECORDFORMAT (RDECLN) %INTEGER NAME,OPHEAD,OPBOT,NLIST,MRL,CELLREF %RECORD(LISTF)%NAME LCELL,FRCELL SNDISP=0 NAME=FROM AR2(P+1); P=P+3 COPY TAG(NAME) %UNLESS PTYPE=4 %AND J=15 %AND OLDI=LEVEL %START KFORM=0 PUSH(KFORM,0,0,0) ACC=X'7FFF' PTYPE=4; J=0 STORETAG(NAME,KFORM); ! IN CASE OF REFS IN FORMAT %FINISH%ELSE %START LCELL==ASLIST(TAGS(NAME)) LCELL_S1=LCELL_S1&X'FFFFFFF0';! J=15 TO J=0 %FINISH LCELL==ASLIST(KFORM) 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 ! %WHILE LCELL_S3#0 %CYCLE; ! THROUGH FORWARD REFS POP(LCELL_S3,CELLREF,I,I) FRCELL==ASLIST(CELLREF) FRCELL_S1=FRCELL_S1&X'FFFFFFF0';! SET J BACK TO 0 FRCELL_S2=FRCELL_S2&X'FFFF0000'!ACC;! ACC TO CORRECT VALUE %REPEAT POP(OPHEAD,LCELL_S1,LCELL_S2,LCELL_S3) LCELL_LINK=OPHEAD LCELL==ASLIST(TAGS(NAME)) LCELL_S2=LCELL_S2&X'FFFF0000'!ACC %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:4),QINST(1:7) %INTEGER ALT,AALT,FNAME,OPTINC,OPC,KK,VAL1,VAL2,I,TR ALT=A(P+1); P=P+2 ->UCITYPE(ALT) UCITYPE(1): ! **@'(NAME)(OPTINC) 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) FAULT(97,FNAME,0) %IF TYPE>=6 %OR ROUT#0 %IF AALT=1 %THEN DFETCHAD(NO,I,K+OPTINC) %ELSE %C %IF AALT=2 %THEN DSTORE(2,I,K+OPTINC) %ELSE %C DFETCH(2,I,K+OPTINC) ->BEND 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 KK=FROM AR2(P+1); I=UCB2 ->OTRIP UCITYPE(4): ! CNOP I=UCNOP; KK=FROM AR2(P) ->OTRIP UCITYPE(3): ! ASSEMBLER AALT=A(P); P=P+1 OPC=A(P); P=P+4 %IF AALT>1 %THEN %START KK=INTEXP(VAL1,X'41') FAULT(96,0,1) %UNLESS KK=0 %FINISH %IF AALT>=5 %START P=P+3 KK=INTEXP(VAL2,X'41') FAULT(96,0,2) %UNLESS KK=0 %FINISH ->QINST(AALT) QINST(1): ! ONE BYTE INSTRUCTION I=UCB1; KK=OPC; ->OTRIP QINST(2): ! UNSIGNED BYTE OPERAND FAULT(96,0,1) %UNLESS 0<=VAL1<=255 I=UCB2; KK=OPC<<8!VAL1 ->OTRIP QINST(3): ! SIGNED BYTE OPERAND FAULT(96,0,1) %UNLESS -128<=VAL1<=127 I=UCB2; KK=OPC<<8!(VAL1&255) ->OTRIP QINST(4): ! SIGNED WORD OPERAND FAULT(96,0,1) %UNLESS IMOD(VAL1)<=X'7FFF' I=UCW; KK=OPC<<16!(VAL1&X'FFFF') ->OTRIP QINST(5): ! 2 UNSIGNED BYTE OPERANDS FAULT(96,0,1) %UNLESS 0<=VAL1<=255 FAULT(96,0,2) %UNLESS 0<=VAL2<=255 I=UCB3; KK=OPC<<16!VAL1<<8!VAL2 ->OTRIP QINST(6): ! BYTE & WORD OPERANDS FAULT(96,0,1) %UNLESS 0<=VAL1<=255 FAULT(96,0,2) %UNLESS IMOD(VAL2)<=X'7FFFF' I=UCBW; KK=OPC<<24!VAL1<<16!(VAL2&X'FFFF') ->OTRIP OTRIP: TR=UCONSTTRIP(I,0,DONT OPT,KK) 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(WORKA_DICTBASE+WORD(KK)) ->CSSEXIT %INTEGERFN CFORMATREF !*********************************************************************** !* P IS TO ALT OF FORMAT REF * !* P::=(NAME),(RFDEC)(RESTOFRFDEC)(ALTRFDEC) * !* RETURNS CELL NO OF TOP CELL OF THE FORMATLIST * !*********************************************************************** %INTEGER FNAM,OPHEAD,OPBOT,NHEAD,MRL %RECORD(LISTF)%NAME LCELL %IF A(P)=1 %START; ! A RECORD OF RECORDFORMAT NAME FNAM=FROM AR2(P+1) P=P+3 COPY TAG(FNAM) %IF 3<=TYPE<=4 %THEN %RESULT=KFORM %IF INAFORMAT#0 %AND OLDI#LEVEL %START KFORM=0; SNDISP=0;ACC=X'7FFF' PTYPE=4; J=15 PUSH(KFORM,0,0,0) STORE TAG(FNAM,KFORM) %RESULT=KFORM %FINISH FAULT(62,0,FNAM); ! NOT A RECORD OF FORMAT NAME ACC=8; ! GUESS A RECORD SIZE %RESULT=DUMMY FORMAT %FINISH ! FORMAT ACTUALLY SPECIFIED P=P+1 OPHEAD=0; OPBOT=0 NHEAD=0; MRL=0 CRFORMAT(OPHEAD,OPBOT,NHEAD,MRL,X'80000000') CLEAR LIST(NHEAD) %IF CURRINF_UNATT FORMATS#0 %START LCELL==ASLIST(CURRINF_UNATT FORMATS) %IF LCELL_S2=0 %THEN LCELL_S2=OPHEAD %AND %RESULT=OPHEAD %IF LCELL_S3=0 %THEN LCELL_S3=OPHEAD %AND %RESULT=OPHEAD %FINISH PUSH(CURRINF_UNATT FORMATS,OPHEAD,0,0) %RESULT=OPHEAD %END %ROUTINE CRFORMAT(%INTEGERNAME OPHEAD, OPBOT, NLIST, MRL, %INTEGER INIT) !*********************************************************************** !* CONVERTS A RECORDFORMAT STATEMENT TO A LIST HEADED BY OPHEAD * !* FORMAT OF AN ENTRY. * !* S1=SUBNAME<<20!PTYPE<<4!J * !* S2,S3=4 16 BIT DISPLACEMENTS D2,ACC,D1,KFORM * !* NORMALLY D1=RECORD RELATIVE DISPLACEMENT AND ACC=LMAX(STRINGS)* !* FOR ARRAYS D2=FIRST ELEMENT DISPLACEMENT AND D1=DISPLACEMENT * !* OF RECORD RELATIVE ARRAYHEAD IN THE GLA * !* KFORM IS ONLY USED FOR RECORDS AND POINTS TO THE FORMAT * !* ON EXIT ACC HAS THE RECORD SIZE ROUNDED UP TO THE BOUNDARY * !* REQUIRED BY ITS LARGEST COMPONENT * !*********************************************************************** %INTEGER D1, D2, FORM, RL, STALLOC, INC, Q, R, RFD, LB, TYPEP, SACC %HALFINTEGER A0, A1, A2, A3 %ROUTINESPEC SN(%INTEGER Q) %ROUTINESPEC ROUND FORM=0; ACC=0 INC=INIT&X'FFFF'; ! INC COUNTS DOWN RECORD %CYCLE ROUT=0; LITL=0; NAM=0; RFD=A(P) P=P+1 %IF RFD=1 %THEN %START CLT FORM=KFORM STALLOC=ACC %IF PTYPE=X'35' %THEN STALLOC=(STALLOC+1)&(-2) P=P+1 %IF A(P-1)=1 %START ! (TYPE) (QNAME')(NAMELIST) FORM=KFORM CQN(P); P=P+1 %IF NAM=1 %THEN %START STALLOC=4 %IF TYPE=5 %OR(TYPE=1 %AND PREC=3) %THEN STALLOC=6 %IF ARR#0 %THEN STALLOC=8 %FINISH PACK(PTYPE); D2=0 %IF STALLOC=1 %THEN RL=0 %ELSE RL=1 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 A2=DOPE VECTOR(TYPE,ACC,0,FROMAR2(Q)>>1,R,LB)>>1 ! DOPE VECTOR INTO SHAREABLE S.T. ACC=SACC; PTYPE=TYPEP; UNPACK RL=1 ROUND %CYCLE A0=INC>>1 A1=0 A3=0 PGLA(2,8,ADDR(A0)) D1=GLACA-8 RELOCATE(32,D1+4,4); ! RELOCATE DV POINTER D2=INC SN(Q); INC=INC+R Q=Q+3 %REPEAT %UNTIL A(Q-1)=2;! TILL NAMELIST NULL P=P+1; Q=P+1 %REPEAT %UNTIL A(P-1)=2; ! UNTIL 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 ACC=INC; ! SIZE ROUNDED APPROPRIATELY FAULT(63,X'7FFF',0) %UNLESS INC<=X'7FFF' %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. * !*********************************************************************** FNAME=FROM AR2(Q) FAULT(61,0,FNAME) %UNLESS FIND(FNAME,NLIST)=-1 BINSERT(OPHEAD,OPBOT,FNAME<<20!PTYPE<<4!J,D2<<16!ACC,D1<< %C 16!FORM) PUSH(NLIST,0,FNAME,0) %IF PTYPE=X'433' %AND ACC=X'7FFF' %THEN %C PUSH(ASLIST(FORM)_S3,OPBOT,0,0);! NOTE FORWARD REFERENCE %END %ROUTINE ROUND MRL=RL %IF RL>MRL INC=INC+1 %WHILE INC&RL#0 %END %END; ! OF ROUTINE CRFORMAT %INTEGERFN DISPLACEMENT(%INTEGER LINK) !*********************************************************************** !* SEARCH A FORMAT LIST FOR A SUBNAME * !* A(P) HAS ENAME--LINK IS HEAD OF RFORMAT LIST. RESULT IS DISP * !* FROM START OF RECORD * !*********************************************************************** %RECORD(LISTF)%NAME FCELL,PCELL,LCELL %INTEGER RR,II,ENAME,CELL ENAME=A(P)<<8+A(P+1); CELL=0 %IF LINK#0 %THEN %START; ! CHK RECORDSPEC NOT OMITTED FCELL==ASLIST(LINK); ! ONTO FIRST CELL CELL=LINK; II=-1; ACC=-1 %WHILE LINK>0 %CYCLE LCELL==ASLIST(LINK) %IF LCELL_S1>>20=ENAME %START;! RIGHT SUBNAME LOCATED TCELL=LINK RR=LCELL_S1 SNDISP=LCELL_S2 K=LCELL_S3 J=RR&15; PTYPE=RR>>4&X'FFFF' ACC=SNDISP&X'FFFF'; SNDISP=SNDISP&X'FFFF0000'//X'10000' KFORM=K&X'FFFF'; K=K>>16 %IF LINK#CELL %START; ! NOT TOP CELL OF FORMAT PCELL_LINK=LCELL_LINK LCELL_LINK=FCELL_LINK FCELL_LINK=LINK %FINISH; ! ARRANGING LIST WITH THIS SUBNAME ! NEXT TO THE TOP %RESULT=K %FINISH PCELL==LCELL LINK=LCELL_LINK %REPEAT %FINISH FAULT(65,0,ENAME) %IF CELL>0 %THEN %C PUSH(ASLIST(CELL)_LINK,ENAME<<20!7<<4,0,0) PTYPE=X'57'; TCELL=0 %RESULT=-1 %END %INTEGERFN COPY RECORD TAG(%INTEGERNAME 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 %ROUTINE CRNAME(%INTEGER Z,MODE,BS,DP,%INTEGERNAME 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 %ROUTINESPEC CENAME(%INTEGER MODE,FNAME,BS,DP,XD) DEPTH=0 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 CANAME(Z,ARR,BS,DP) NAMEP=0 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 * !*********************************************************************** %ROUTINESPEC FETCH RAD %ROUTINESPEC LOCALISE(%INTEGER SIZE) %INTEGER Q,QQ,D,C,W DEPTH=DEPTH+1 %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,NAMEP&X'FFFF'); 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 UNPACK; ! INFO ABOUT THE SUBNAME %IF Q=-1=ACC %OR PTYPE=X'57' %START; ! WRONG SUBNAME(HAS BEEN FAULTED) P=P+2; SKIP APP; P=P-3 ACCESS=0; BASE=RBASE; DISP=0 %RETURN %FINISH NAMEP=(A(P)<<8!A(P+1))<<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 %C (TYPE=3 %AND A(P)=2 %AND (3<=Z<=4 %OR Z=6)) %START ACCESS=MODE+4+4*NAM; BASE=BS; DISP=DP; XDISP=XD+Q %RETURN %FINISH ! ! NOW CODING BECOMES HAIRY:- STILL LEFT ARE ! A) RECORDS IN RECORDS Q POINTS TO SECONDARY RECORD ! B) RECORDNAMES IN RECORDS Q HAS OFF-SET OF A POINTER ! C) RECORDARRAYNAMES IN RECORDS Q HAS OFF-SET A HEADER IN RECORD ! D) RECORDARRAYS IN RECORDS NOT YET ALLOWED ! Q WOULD HAVE OFF-SET OF A RECORD RELATIVE HEADER IN THE GLA ! XD=XD+Q NAMEP=-1 %IF NAM=1 %THEN %START %IF MODE=0 %START DP=DP+XD; XD=0; MODE=2 %FINISH %ELSE %START LOCALISE(4); ! PICK UP RECNAME DESCR &STCK DP=DISP; BS=BASE %FINISH %FINISH CENAME(MODE,KFORM,BS,DP,XD) %RETURN AE: ! ARRAYS AND ARRAYNAMES AS ELEMEN FROM123(TCELL,Q,SNDISP,K) ACC=SNDISP&X'FFFF'; SNDISP=SNDISP&X'FFFF0000'//X'10000' KFORM=K&X'FFFF'; K=K>>16 C=ACC; D=SNDISP; Q=K; QQ=KFORM %IF (Z=6 %OR Z>=11) %AND A(P+2)=2 %START;! 'GET ARRAYHEAD' CALL P=P+3 %IF NAM=1 %THEN %START ACCESS=MODE+8; BASE=BS DISP=DP; XDISP=XD+Q NAMEOP(6,8,NAMEP); ! PTR TO HEAD %IF Z=12 %THEN PB1(TLATE1) %AND PB2(ROPS,37) %RETURN %FINISH ! ! PASSING AN ARRAY IN A RECORD BY NAME MUST CONSTRUCT PROPER ARRAYHEAD ! FROM THE RECORD RELATIVE ONE AT Q(GLA) ! NAMEP=-1 FETCH RAD ACCESS=2; DFETCHAD(NO,0,Q) PB2(ROPS,37); ! HEAD TO ESTACK CREATE AH(1) %FINISH %ELSE %START; ! ARRAY ELEMENTS IN RECORDS NAMEP=-1 %IF NAM=1 %THEN %START; ! ARRAYNAMES-FULLHEAD IN RECORD XD=XD+Q LOCALISE(8); ! MOVE HEAD UNDER LNB D=DISP CANAME(Z,3,BASE,DISP); ! ARRAY MODE SETS DISP,AREA&BASE BASE=RBASE; DISP=D; ! ONLY NEEDED FOR STRINGARRAYNAMES %FINISH %ELSE %START; ! ARRAY RELATIVE HEAD IN GLA FETCH RAD; ! 32 BIT ADDR TO ETOS CANAME(Z,3,0,Q); ! RECORD REL ARRAY ACCESS ! CAN RETURN ACCESS=1 OR 3 ONLY %IF PTYPE&255=X'31' %THEN PB1(MMS);! REMOVE OFFSET BYTE PB2(LOPS,2); ! ADD 2 32 BIT POINTERS %IF PTYPE&255=X'31' %THEN PB1(MES) %FINISH XDISP=XD %IF TYPE=3 %THEN CENAME(ACCESS,QQ,BASE,DISP,XD) %FINISH ACC=C; ! NEEDED FOR STRING ARRAYS %RETURN %ROUTINE FETCH RAD !*********************************************************************** !* SET ACC TO 32 BIT ADDRESS OF RECORD. * !*********************************************************************** %INTEGER PRECP ACCESS=MODE+4 BASE=BS DISP=DP; XDISP=XD PRECP=PREC; PREC=5 NAMEOP(3,4,-1) PREC=PRECP; ! ENSURE 32BIT PICKUP %END %ROUTINE LOCALISE(%INTEGER SIZE) !*********************************************************************** !* REMOVES A POINTER OR ARRAYHEAD FROM A RECORD AND STORES * !* IT IN A TEMPORARY UNDER LNB. * !*********************************************************************** %INTEGER HOLE,PRECP ACCESS=MODE+4 BASE=BS; DISP=DP XDISP=XD PRECP=PREC; PREC=5 NAMEOP(3,SIZE,-1) PREC=PRECP GET WSP(HOLE,SIZE>>1) %IF SIZE=8 %START; ! LOCALISE ARRAY HEAD PB1(TLATE1) PB2(ROPS,37) %FINISH DSTORE(SIZE,RBASE,HOLE) MODE=2 BASE=RBASE; DISP=HOLE; XD=0 %END; ! OF ROUTINE LOCALISE %END; ! OF ROUTINE CENAME %END; ! OF ROUTINE CRNAME %ROUTINE CSTREXP(%INTEGER MODE) !*********************************************************************** !* PLANT IN-LINE CODE FOR CONCATENATION. A WORK AREA IN THE * !* CURRENT STACK FRAME IS USUALLY REQUIRED. * !* ON ENTRY:- * !* MODE=0 NORMAL. WK AREA NOT USED FOR ONE OPERAND EXPSSNS * !* MODE=1 STRING MUST GO TO WORK AREA * !* 2**5 BIT OF MODE SET IF FULL VIRTUAL ADDRESS REQUIRED * !* 2**4 BIT OF MODE IS SET IF WK-AREA NOT TO BE FREED ON EXIT * !* ON EXIT:- * !* VALUE#0 %IF RESULT IN A WORK AREA(CCOND MUST KNOW) * !*********************************************************************** %INTEGER PP,WKAREA,DOTS,ERR,KEEPWA,FNAM,I,ENDFLAG %RECORD(RD) OPND1,OPND2,OPND3 %INTEGERFNSPEC STROP(%RECORD(RD) %NAME OPND) KEEPWA=MODE&16; MODE=MODE&15 PP=P; STRINGL=0; FNAM=0; WKAREA=0 P=P+3; ! LENGTH OF CONSTANT PART ERR=72; ->ERROR %UNLESS A(P)=4 P=P+1 DOTS=0; ! NO OPERATORS YET ENDFLAG=0 STRINGL=0 ERR=STROP(OPND2); ! GET FIRST OPERAND ->ERROR %UNLESS ERR=0 NEXT: %IF A(P)=2 %THEN ENDFLAG=1 %ELSESTART %IF A(P+1)#CONCOP %THEN ERR=72 %AND ->ERROR P=P+2 ERR=STROP(OPND3) ->ERROR %UNLESS ERR=0 %FINISH %IF ENDFLAG=0 %AND OPND2_FLAG=LCONST=OPND3_FLAG %START ! ! CAN FOLD OUT A CONCATENATION HERE ! I=CONCAT CTOP(I,ERR,0,OPND2,OPND3) %IF I=0 %THEN ->NEXT; ! FOLDED OUR %FINISH %IF DOTS=0 %START %IF MODE=0 %AND ENDFLAG#0 %START; ! NO RUN-TIME OPERATIONS OPND1=OPND2; ->TIDY %FINISH GET WSP(WKAREA,X'80000000'!268); ! GET NEXT OPERAND OPND1_PTYPE=X'35' OPND1_FLAG=LOCALIR OPND1_D=RBASE<<16!WKAREA I=BRECTRIP(PRECC,X'35',0,OPND1,OPND2) DOTS=1 %FINISH %IF ENDFLAG=0 %THENSTART I=BRECTRIP(CONCAT,X'35',0,OPND1,OPND3) ->NEXT %FINISH TIDY: ! FINISH OFF EXPOPND=OPND1; ! LEAVE REULT IN EXPOPND VALUE=WKAREA P=P+1; ! PAST REST OF EXPRN RETURN WSP(WKAREA,268) %IF KEEPWA=0 %AND WKAREA>0 STRINGL=0 %RETURN ERROR:FAULT(ERR,0,FNAM) BASE=RBASE; DISP=0 VALUE=0; ACCESS=0 P=PP; SKIP EXP %RETURN %INTEGERFN STROP(%RECORD(RD) %NAME OPND) !*********************************************************************** !* DEALS WITH OPERAND FOR CONCATENATION. RETURN RESULT=0 FOR * !* VALID OPERAND OTHERWISE AN ERROR NUMBER. * !*********************************************************************** %INTEGER CTYPE,MODE,I MODE=A(P); ! ALTERNATIVE OF OPERAND OPND=0 %RESULT=75 %IF MODE>2 %IF MODE#1 %THENSTART CTYPE=A(P+1); ! GET CONST TYPE & LOSE AMCK FLAGS %IF CTYPE=X'35' %THENSTART STRINGL=A(P+2) OPND_PTYPE=CTYPE OPND_FLAG=LCONST OPND_D=P+2 OPND_XTRA=STRINGL P=P+STRINGL+3 %FINISHELSERESULT=73 %FINISHELSESTART P=P+1; ! MUST CHECK FIRST %IF 5#TYPE#7 %THEN FNAM=FROMAR2(P) %ANDRESULT=71 %IF PTYPE=X'35' %AND A(P+2)=2=A(P+3) %START OPND_FLAG=DNAME OPND_PTYPE=PTYPE OPND_D=FROMAR4(P) P=P+4 %FINISHELSESTART CNAME(2) OPND_FLAG=REFTRIP OPND_PTYPE<-PTYPE OPND_D=TRIPLES(0)_BLINK %FINISH STRINGL=0 DISP=0 %FINISH %RESULT=0 %END; ! OF INTEGERFN STROP %END; ! OF ROUTINE CSTREXP %ROUTINE CRES (%INTEGER LAB) !********************************************************************** !* COMPILES A RESOLUTION E.G A->B.(C).D.(E).F AND JUMPS TO LAB * !* ON FAILURE. (LAB=0 FOR UNCONDITIONAL RESOLUTION TO PERM ON * !* FAILURE ). * !* THE METHOD IS TO CALL A SUBROUTINE PASSING 5 PARAMS:- * !* P1(32BITS) POINTS TO LHS(A) * !* P2(16BITS) ORIGINAL LENGTH OF A * !* P3(32BITS) FULL POINTER TO BYTES USED UP INITIALLY 0 * !* P4(48BITS) STRING TO CONTAIN FRAGMENT * !* (PASSED AS LMAX FOLLOWED BY 32BIT ADDRESS) * !* P5(32BITS) THE EXPRESSION PASSED AS 32 BIT ADDRESS * !* SUBROUTINE TRIES TO PERFORM THE RESOLUTION AND SETS THE * !* RESULT TO TRUE IF IT SUCCEEDS. * !* * !* ON ENTRY LHS IS IN THE ESTACK(32BITS). * !* P POINTS TO P(+') OF RHS DEFINED AS (+')(OPERAND)(RESTOFEXP) * !* * !$ THE ROUTINE IS COMPACT BUT DIFFICULT TO FOLLOW (OR ALTER) * !* THE TIME IN PERM IS LARGE SO IT IS NOT WORTHWHILE TO PERSUE * !* CODE EFFICIENCY TOO INDUSTRIOUSLY . * !********************************************************************** %INTEGER P1,P2,SEXPRN,W,LAST,ERR,FNAM LAST=0; FNAM=0; ! =1 WHEN END OF EXPRNSN FOUND SEXPRN=0; ! RESOLUTION(BRKTD) EXPRESSNS ERR=74; ! NORMAL CRES FAULT GET WSP(W,X'80000004'); ! TO HOLD P1,P2 AND VALUE OF P3 PB1(REPL2) DSTORE(4,RBASE,W); ! SAVE 32BIT ADDR OF LHS PB1(LDC0) DSTORE(2,RBASE,W+6); ! 0 BYTES USED UP SO FAR PB3(LDC0,TLATE2,LDCH) DSTORE(2,RBASE,W+4); ! ORIGINAL LENGTH OF LHS P1=P; 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) PB2(ATPB,1); ! HOLE FOR RESULT(=T/F) DFETCH(4,RBASE,W) PB1(MMS2); ! P1 IS STACKED DFETCH(2,RBASE,W+4) PB1(MMS); ! P2 IS STACKED DFETCHAD(YES,RBASE,W+6) PB1(MMS2); ! POINTER TO P3 %IF A(P)=3 %THEN %START; ! B OMITTED PB3(LDC0,REPL,REPL) %FINISH %ELSE %START ->ERROR %UNLESS A(P)=1; ! P(OPERAND)=NAME P=P+1; P2=P CNAME(3) %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 PB2(MMS,MMS2); ! LAMX&ADDRESS AS PARAMETERS ->ERROR %UNLESS A(P)=3; ! P(OPERAND)='('(EXPR)')' SEXPRN=SEXPRN+1; P=P+1 CSTREXP(32); ! FULL 32 BIT ADDRESS PB1(MMS2); ! IS STACKED ! PPJ(0,16) PB1(MES); ! DEAL WITH FALSE IE RESLN FAILED %IF LAB#0 %THEN ENTER JUMP(JFW,LAB,B'11') %ELSE PPJ(JFW,12) ! -> 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) PB1(MMS); ! LMAX TO MSTACK PB1(REPL2); ! 2 COPIES OF VRT ADDR DFETCH(2,RBASE,W+4) DFETCH(2,RBASE,W+6) PB3(SBI,REPL,REPL); ! LENGTH OF FRAGMENT PB2(MMS2,MMS); ! 3 COPIES TO MSTACK PB1(LDC0+1); ! DEST FOR MVBYTES DFETCH(4,RBASE,W) DFETCH(2,RBASE,W+6) PB2(LDC0+1,ADI); ! SOURCE FOR MOVE PB1(MES); ! LENGTH ON TOP PB3(STLATE,X'63',MVBW); ! ASSIGN ALL BAR LENGTH PB4(LDC0,MES,TLATE3,STCH); ! ASSIGN LENGTH PB2(MES2,LEQI) PPJ(JFW,9); ! CAPACITY EXCEEDED P=P1 END: RETURN WSP(W,4) P=P+1 %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,ID,ML %ROUTINESPEC DTABLE(%INTEGER LEVEL) %RECORD(RTDICTF) RTDICT SET LINE %UNLESS KKK=2 BIT=1<X'1000' %AND PARM_COMPILER=0 %C %AND LAST INST=0 %THEN %C JJ=UCONSTTRIP(RTBAD,X'51',0,0); ! RUN FAULT 11 ! ! NOW PLANT THE BLOCK EXIT SEQUENCE ! %IF KKK&X'3FFF'=X'1000' %AND LAST INST=0 %THEN %C JJ=UCONSTTRIP(RTXIT,X'51',0,0) JJ=UCONSTTRIP(XSTOP,X'51',0,0) %IF KKK=1 %AND LAST INST=0;! %STOP AT %ENDOFPROGRAM %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_NMDECS>>14 %IF JJ#0 %THEN %START; ! ARRAYS TO BE UNDECLARED JJ=UCONSTTRIP(RSPTR,X'51',0,JJ) %FINISH %FINISH FORCE TRIPS 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>1 DTABLE(LEVEL); ! OUTPUT DIAGNOSTIC TABLES %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 ! NMAX=(NMAX+7)&(-8) %IF KKK=2 %THEN %RETURN %IF KKK>=X'1000' %OR KKK=1 %THEN %START ML=CURRINF_M-1 %IF KKK=1 %THEN ID=X'80000000' %AND JJ=ADDR(MAINEP) %ELSE %C ID=FROM2(TAGS(ML))&X'FFFF' %AND JJ=WORKA_DICTBASE+WORD(ML) PTYPE=KKK; UNPACK RTDICT_PS=0 %IF ROUT#0 %THEN %START %IF NAM#0 %OR TYPE=5 %THEN RTDICT_PS=4 %C %ELSE RTDICT_PS=(BYTES(PREC)+1)&(-2) %FINISH RTDICT_PS=(CURRINF_PSIZE-RTDICT_PS)//2 RTDICT_RPS=CURRINF_PSIZE//2 RTDICT_LTS=NMAX//2-RTDICT_RPS RTDICT_ENTRY=CURRINF_ENTRYAD RTDICT_EXIT=CA-1 RTDICT_LL=RLEVEL %IF RLEVEL=1 %THEN ID=ID!1<<16;! FLAG AS EXTERNAL QPUT(11,ID,ADDR(RTDICT),JJ) %IF CA>30000 %AND WORKA_PLABS(1)<30000 %THEN REPEAT PROLOGUE %FINISH ! ! 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' %THEN %START RLEVEL=CURRINF_RBASE RBASE=RLEVEL %FINISH ! ! RESTORE INFORMATION ABOUT THE (NEW) CURRENT LEVEL ! NMAX=CURRINF_SNMAX %IF KKK>=X'1000' 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' %AND PARM_COMPILER=0 %AND %C (RLEVEL>0 %OR PARM_CPRMODE#2) %THEN %START JJ=NEXTP+6 %UNLESS A(NEXTP+5)=11 %AND A(JJ+FROMAR2(JJ))=2 %START JJ=ENTER LAB(CURRINF_JROUND,0) 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. * !*********************************************************************** %CONSTINTEGER DAREA=6 %STRING(31) RT NAME %STRING(11) LOCAL NAME %RECORD(LISTF)%NAME LCELL %CONSTINTEGER LARRROUT=X'F300' %INTEGER DPTR,LNUM,ML,KK,JJ,Q,DEND,BIT,S1,S2,S3,S4,LANGD,II %INTEGERARRAY DD(0:500); ! BUFFER FOR SEGMENT OF SST ! ! FILL ALL OUTSTANDING REFERENCES TO THIS DIAGS BLOCK ! BIT=1<>14<<30!LEVEL<<18; ! GET LITL FROM PTYPE %WHILE CURRINF_RAL#0 %CYCLE POP(CURRINF_RAL,Q,JJ,KK) %IF Q=1 %THEN %START PLUG(1,JJ+2,CODEP_CAS(DAREA)>>9&255,1) PLUG(1,JJ+1,CODEP_CAS(DAREA)>>1&255,1) %FINISH %ELSE PLUG(Q,JJ,KK!CODEP_CAS(DAREA),4) %REPEAT PUSH(LEVELINF(LEVEL-1)_RAL,DAREA,CODEP_CAS(DAREA)+4,LANGD) %IF PARM_TRACE#0 DD(0)=CURRINF_L<<16!(CURRINF_DIAGINF+2) DD(1)=LANGD DD(2)=4*RBASE!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=BYTEINTEGER(WORKA_DICTBASE+ML); ! LENGTH OF THE NAME DPTR=4; DEND=0 %IF LNUM=0 %THEN DD(3)=0 %ELSE %START Q=WORKA_DICTBASE+ML RT NAME<-STRING(Q); ! FOR RTS MOVE IN 1ST 32 CHARS LNUM=BYTE INTEGER(ADDR(RT NAME)) STRING(ADDR(DD(3)))=RTNAME; ! AND UPDATE POINTER PAST %IF ON PERQ=NO %AND PARM_TRACE#0 %THEN %C QPUT(9,DAREA,CODEP_CAS(DAREA)+12,LNUM+1) DPTR=DPTR+LNUM>>2; ! ACTUAL NO OF CHARS %FINISH DD(DPTR)=CURRINF_ONWORD; ! ON CONDITION WORD DPTR=DPTR+1 JJ=CURRINF_NAMES %WHILE 0<=JJ>16; TYPE=PTYPE&15 ! ! FAULT ALL UNUSED NAMES EXCEPT CONSTINTEGERS&REALS ! %IF (TYPE>2 %OR PTYPE&X'FF00'#X'4000') %C %AND S1&X'C000'=0 %THEN WARN(2,JJ) I=S1>>4&15 J=S1&15 K=S3>>16 ! ! ALLOW OWNS (LITL=0) AND EXTERNALS (=2) NOT CONSTS(=1) OR EXTRINSIC(=3) ! %IF PARM_DIAG#0 %AND PTYPE&X'7300'<=X'200' %AND DPTR<497 %C %AND (TYPE=1 %OR TYPE=2 %OR TYPE=5) %START Q=WORKA_DICTBASE+WORD(JJ); ! ADDRESS OF NAME %IF I=0 %THEN II=1 %ELSE II=0; ! GLA OR LNB BIT DD(DPTR)=PTYPE<<20!II<<18!K LOCAL NAME<-STRING(Q); ! TEXT OF NAME FROM DICTIONARY LNUM=BYTE INTEGER(ADDR(LOCAL NAME)) STRING(ADDR(DD(DPTR))+4)=LOCAL NAME;! MOVE IN NAME %IF ON PERQ=NO %AND PARM_TRACE#0 %THEN %C QPUT(9,DAREA,CODEP_CAS(DAREA)+4*DPTR+4,LNUM+1) DPTR=DPTR+(LNUM+8)>>2 %FINISH %IF J=15 %AND PTYPE&X'3000'#0 %AND S1&X'C000'#0 %THEN %C FAULT(28,0,JJ) ! SPEC&USED BUT NO BODY GIVEN %IF J=15 %AND TYPE=4 %THEN FAULT(62,0,JJ) %IF PTYPE&X'3000'#0 %OR TYPE=4 %OR TYPE=6 %THEN %C CLEAR LIST(K) %ELSE %START %IF I#0 %AND K>4095 %AND PTYPE&LARRROUT=0 %AND TYPE#7 %C %THEN WARN(5,JJ) %FINISH JJ=S4>>18 %REPEAT DD(DPTR)=-1; ! 'END OF SEGMENT' MARK DPTR=DPTR<<2+4 %IF PARM_TRACE=1 %THEN %START QPUT(40+DAREA,DPTR,CODEP_CAS(DAREA),ADDR(DD(0)));! ADD TO SHARABLE SYM TABS CODEP_CAS(DAREA)=CODEP_CAS(DAREA)+DPTR %FINISH %END; ! OF ROUTINE DTABLE %END %ROUTINE DECLARE SCALARS(%INTEGER PERMIT,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. * !* PERMIT IS 0 IF DECLARING FORMAL PARAMETERS * !*********************************************************************** %INTEGER INC,Q,SCHAIN,NPARMS,SCAL NAME,TYPEP PACK(PTYPE); J=0 INC=ACC; SNDISP=0 %IF PTYPE=X'35' %THEN INC=(INC+1)&(-2) %IF NAM#0 %AND ARR=0 %AND ROUT=0 %THEN %START INC=4 %IF TYPE=5 %OR (PREC=3 %AND TYPE=1) %THEN INC=6 %FINISH %IF NAM>0 %AND ARR>0 %THEN INC=8 %IF PTYPE=X'35' %AND (ACC<=0 %OR ACC>256) %THEN %C FAULT(70,ACC-1,0) %AND ACC=255 N=(N+1)&(-2) %UNTIL A(P-1)=2 %CYCLE; ! DOWN THE NAMELIST SCAL NAME=FROM AR2(P) %IF PTYPE=X'31' %AND PERMIT=0 %THEN N=N+1;! BYTE PARAMS SCHAIN=N KFORM=XTRA %IF ROUT=1 %THEN %START TYPEP=PTYPE; ! CHANGED BY CFPLIST! Q=P P=P+3 %UNTIL A(P-1)=2; ! TO FPP CFPLIST(SCHAIN,NPARMS) P=Q J=13 KFORM=NPARMS; ! NO OF PARAMS OF FORMAL ACC=N; ! DISPLACEMENT TO MIDCELL PTYPE=TYPEP; UNPACK %FINISH P=P+3 %IF PTYPE=X'33' %THEN %START SCHAIN=N %FINISH STORE TAG(SCAL NAME,SCHAIN) N=N+INC %REPEAT %IF PERMIT#0 %THEN N=(N+1)&(-2); ! THIS IS NECESSARY ! %END %INTEGERFN DOPE VECTOR(%INTEGER TYPEP,ELSIZE,MODE,IDEN, %INTEGERNAME ASIZE,LB) !*********************************************************************** !* CONSTRUCTS THE DOPE-VECTOR FOR A CONSTANT ARRAY IN THE * !* SHAREABLE SYMBOL TABLES AND RETURNS ITS DISPLACEMENT AS RESULT* !* P IS TO ALT (MUST BE 1!) OF P * !* 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 SIZE(IN WORDS OF ENTIRE ARRAY)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) * !* 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,PTR %RECORD(LISTF) %NAME LCELL %INTEGERARRAY LBH,LBB,UBH,UBB(0:12) %INTEGERARRAY DV(0:39); ! ENOUGH FOR 12 DIMENSIONS ND = 0; NOPS = 0; TYPEPP = 0; PIN = P M0 = 1 %IF MODE=-1 %THENSTART ND = 1; DV(4) = 0 M0 = X'7FFF' DV(3) = M0 DV(5) = M0 ASIZE = M0 %FINISHELSESTART %UNTIL A(P)=2 %CYCLE ND = ND+1; P = P+4 FAULT(37,0,IDEN) %AND ND = 1 %IF ND>12 LBH(ND) = 0; LBB(ND) = 0 UBB(ND) = 0; UBH(ND) = 0 TORP(LBH(ND),LBB(ND),NOPS) P = P+3 TYPEPP = TYPEPP!TYPE TORP(UBH(ND),UBB(ND),NOPS) TYPEPP = TYPEPP!TYPE %REPEAT P = P+1 ->NONCONST %UNLESS TYPEPP=1 %AND NOPS&X'40040000'=0 ! ! NOW ONE CAN WORK OUT AND FILL IN THE TRIPLES ! PTR = 1 %CYCLE D = 1,1,ND K = 3*D EXPOP(LBH(PTR),LBB(PTR),NOPS,X'251') EXPOPND_D = 0 %AND FAULT(41,0,0) %UNLESS %C EXPOPND_FLAG<=1 %AND EXPOPND_PTYPE=X'51' DV(K+1) = EXPOPND_D EXPOP(UBH(PTR),UBB(PTR),NOPS,X'251') EXPOPND_D = 10 %AND FAULT(41,0,0) %UNLESS %C EXPOPND_FLAG<=1 %AND EXPOPND_PTYPE=X'51' JJ = EXPOPND_D DV(K) = JJ DV(K+2) = JJ-DV(K+1)+1 FAULT(38,1-DV(K+2),IDEN) %UNLESS JJ>=DV(K) M0 = M0*DV(K+2) PTR = PTR+1 %REPEAT ASIZE = M0*ELSIZE %FINISH ! ! CALCULATE THE OFF SET OF A(FIRST,..) FROM A(0,..) ! LB = DV(4); I = 6 %WHILE I<=3*ND %CYCLE LB = LB+DV(I+1)*DV(I-1) I = I+3 %REPEAT FAULT(39,0,IDEN) %IF ASIZE>X'FFFF' DV(2) = (ASIZE+1)>>1 DV(0) = -LB DV(1) = ND<<16!ELSIZE K = 3*ND+2 J = ND; ! DIMENSIONALITY FOR DECLN HEAD = DVHEADS(ND) %WHILE HEAD#0 %CYCLE LCELL == ASLIST(HEAD) %IF LCELL_S2=ASIZE %START %CYCLE D = 0,1,K ->ON %UNLESS DV(D)=CTABLE(D+LCELL_S1) %REPEAT SNDISP = 4*LCELL_S1 %RESULT = LCELL_S3 %FINISH ON: HEAD = LCELL_LINK %REPEAT SSTL = (SSTL+3)&(-4); ! ALIGN SHAREABLE ST SNDISP = 4*WORKA_CONST PTR I = SSTL 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 %IF ONPERQ=NO %THEN DV(D) = DV(D)>>16!DV(D)<<16 %REPEAT %IF WORKA_CONST PTR>WORKA_CONST LIMIT %THEN FAULT(102,WORKA_WKFILEK,0) QPUT(44,4*(K+1),SSTL,ADDR(DV(0))) SSTL = SSTL+K*(K+1) WAYOUT: %IF MODE=-1 %THENRESULT = I; ! NO EXPRESSION CELLS TO RETURN %RESULT = I NONCONST: ! NOT A CONST DV J = ND; I = -1; SNDISP = -1 LB = 0; ASIZE = ELSIZE %IF MODE=0 %THEN FAULT(41,0,0) %ELSE P = PIN ->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,QQ,CDV,LWB, PTYPEPP,JJJ,JJ,TRIP1,TRIP2 %RECORD(RD) OPND1,OPND2,OPND3 %RECORD(TRIPF)%NAME CURRT %INTEGERARRAY BTRIPS(0:12,0:2) %IF CURRINF_FLAG=0 %AND CURRINF_NMDECS>>14=0 %START JJJ=UTEMPTRIP(SSPTR,X'41',0,N); ! SAVE THE STACK POINTER CURRINF_NMDECS=CURRINF_NMDECS!N<<14 N=N+2 %FINISH ARRP=2*FORMAT+1; ARR=ARRP; PACK(PTYPEP) ELSIZE=ACC 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 DVDISP=DOPE VECTOR(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=1; TOTSIZE=X'FFFF' N=(N+3)&(-4); ! MAY BE BENEFITS IN WORD ALIGNMENT DVDISP=N; ! DVDISP IS D-V POSITION N=N+12*ND+12; ! CLAIM SPACE FOR THE D-V OPND1_S1=X'41'<<16!LOCALIR OPND1_D=RBASE<<16!DVDISP+4 OPND2_S1=X'41'<<16!SCONST OPND2_D=ND TRIP1=BRECTRIP(LASS,X'41',0,OPND1,OPND2); ! ASSN DIMEN->DVDIPS+4 OPND1_D=RBASE<<16!DVDISP+6 OPND2_D=ELSIZE TRIP1=BRECTRIP(LASS,X'41',0,OPND1,OPND2); ! ASSN ELSIZE-> DVDISP+6 ! %CYCLE II=1,1,ND P=P+1 QQ=DVDISP+12*II; ! TRIPLE FOR IITH DIMENSION %CYCLE JJ=0,1,1; ! LOWER&UPPER BNDS CSEXP(X'51') OPND1_S1=X'51'<<16!LOCALIR OPND1_D=RBASE<<16!(QQ+4-4*JJ); ! BPAIRS BACKWARD FOR PERQ! %IF JJ=0 %AND(EXPOPND_FLAG>0 %OR EXPOPND_D#0) %THEN DVF=0 ! BASE OFFSET NOT ZERO TRIP1=BRECTRIP(LASS,X'51',0,OPND1,EXPOPND) BTRIPS(II,JJ)=TRIP1 %REPEAT OPND1_S1=X'51'<<16!REFTRIP OPND1_D=BTRIPS(II,1); ! UPPER BND OPND2_S1=X'51'<<16!REFTRIP OPND2_D=BTRIPS(II,0) OPND1_D=BRECTRIP(SUB,X'51',0,OPND1,OPND2); ! UB-LB OPND2_S1=X'51'<<16!SCONST OPND2_D=1 OPND1_D=BRECTRIP(ADD,X'51',0,OPND1,OPND2); ! UB-LB+1 OPND2_S1=X'51'<<16!LOCALIR OPND2_D=RBASE<<16!(QQ+8) BTRIPS(II,2)=BRECTRIP(LASS,X'51',0,OPND2,OPND1) %IF II=1 %THEN TRIP2=BTRIPS(II,2) %ELSESTART OPND1_S1=X'51'<<16!REFTRIP OPND1_D=TRIP2 OPND2_S1=X'51'<<16!REFTRIP OPND2_D=BTRIPS(II,2) TRIP2=BRECTRIP(MULT,X'51',0,OPND1,OPND2) %FINISH %REPEAT P=P+1 ! ! WORK OUT TOTAL SIZE IN WORDS. TRIP2 HAS NO OF ELEMENTS ! OPND1_D=TRIP2 OPND2_S1=X'51'<<16!SCONST %IF ELSIZE&1#0 %THEN OPND2_D=ELSIZE %ELSE OPND2_D=ELSIZE>>1 OPND1_D=BRECTRIP(MULT,X'51',0,OPND1,OPND2) %IF ELSIZE&1#0 %START; ! ROUND UP TO NEXT BUT ONE WORD OPND2_D=1 OPND1_D=BRECTRIP(ADD,X'51',0,OPND1,OPND2) OPND2_D=-1 OPND2_S1=X'41'<<16!SCONST OPND1_D=BRECTRIP(RSHIFT,X'51',0,OPND1,OPND2) %FINISH OPND2_S1=X'51'<<16!LOCALIR OPND2_D=RBASE<<16!(DVDISP+8) JJ=BRECTRIP(LASS,X'51',0,OPND2,OPND1) SNDISP=0; ! DV NOT AVAILABLE AT COMPILETIME %IF DVF=1 %THENSTART LWB=0 %IF FORMAT=0 %THEN PTYPEPP=PTYPEP+256 OPND2_S1=X'51'<<16!SCONST OPND2_D=0; ! ZERO BASE OFFSET %FINISHELSESTART !*********************************************************************** !* FIND THE OFFSET OF A(0...) FROM A(FIRST...) BY COMPUTING * !* THE OFFSET OF A(FIRST...) FROM A(0...) AND NEGATING * !*********************************************************************** OPND2_S1=X'51'<<16!REFTRIP OPND3_S1=X'51'<<16!REFTRIP OPND1_S1=X'51'<<16!REFTRIP OPND2_D=BTRIPS(ND,0); ! LB OF TOP DIMEN %CYCLE JJ=ND,-1,2 OPND3_D=BTRIPS(JJ,0) OPND1_D=BTRIPS(JJ-1,2) OPND1_D=BRECTRIP(MULT,X'51',0,OPND1,OPND3) OPND2_D=BRECTRIP(ADD,X'51',0,OPND1,OPND2) %UNLESS JJ=ND %REPEAT OPND2_D=URECTRIP(LNEG,X'51',0,OPND2) %FINISH OPND1_S1=X'51'<<16!LOCALIR OPND1_D=RBASE<<16!DVDISP OPND2_D=BRECTRIP(LASS,X'51',0,OPND1,OPND2) ->DECL CONSTDV: ! ONE DIMENSION - CONSTANT BOUNDS DVF=1; 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 PTYPE=PTYPEPP; UNPACK %CYCLE JJJ=0,1,NN-1; ! DOWN NAMELIST CURRT==TRIPLES(UCONSTTRIP(DARRAY,X'61',0, CDV<<31!JJJ<<24!(NN-1)<<16!DVDISP)) CURRT_OPND1_XTRA=N ACC=ELSIZE; ! RESET ACC AFTER DV CMPLD KFORM=FINF; ! FORMAT INFORMATION K=FROM AR2(PP+3*JJJ) STORE TAG(K,N) JJ=UCONSTTRIP(ASPTR,X'51',0,CDV<<31!SNDISP<<16!DVDISP) %IF FORMAT=0 N=N+8 %REPEAT P=P+1; ! PAST REST OF ARRAYLIST %IF A(P-1)=1 %THEN ->START %RETURN %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. * !*********************************************************************** %CONSTBYTEINTEGERARRAY TYPEFLAG(0:8)=0, %C X'51',X'52',LRLPT,X'31',X'35', X'41'(2),X'33'; %INTEGER ALT,PTYPEP,I ALT=A(P) TYPE=TYPEFLAG(ALT) %IF ALT=4 %OR ALT=6 %OR ALT=7 %THEN P=P+1 PREC=TYPE>>4 TYPE=TYPE&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,X'41')#0 %THEN FAULT(41,0,0) ACC=I+1 PTYPE=PTYPEP; UNPACK %FINISH %ELSE ACC=0 %AND P=P+2 %FINISH %ELSE ACC=0 %AND P=P+1 %FINISH KFORM=0 %IF TYPE=3 %THEN KFORM=CFORMATREF %AND PTYPE=PTYPEP %AND UNPACK %END %ROUTINE CQN(%INTEGER P) !*********************************************************************** !* SET NAM & ARR FROM ALTERNATIVE OF PHRASE * !* P='%ARRAYNAME','%NAME',<%NULL> * !* P POINTS TO THE ANALYSIS RECORD ENTRY AS IS NOT UPDATED * !*********************************************************************** %INTEGER I I=A(P);NAM=0;ARR=0 %IF I=1 %THEN ARR=1; ! ARRAYNAMES %IF I<=2 %THEN NAM=1; ! ARRAYNAMES & NAMES %END %INTEGERFN SET SWITCHLAB(%INTEGER HEAD,LAB,FNAME,BIT) !*********************************************************************** !* SET A SWITCH LABEL AND RETURNS RESULT=0 %UNLESS THE LABEL * !* HAS BEEN ALREADY SET WHEN IT RETURNS RESULT#0 * !* HEAD IS HEAD OF THE TAGS SIDECHAIN FOR THE SWITCH * !*********************************************************************** %INTEGER Q,QQ,JJJ,LB,UB,BASEPT %RECORDFORMAT BITFORM(%INTEGERARRAY BITS(0:2),%INTEGER LINK) %RECORD(BITFORM)%NAME BCELL %RECORD(LISTF)%NAME LCELL OLDLINE=0 LCELL==ASLIST(HEAD) BASEPT=LCELL_S1 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<X'7FFF' %THEN FAULT(98,0,0) PLUG(1,QQ,Q,1) PLUG(1,QQ+1,Q>>8,1) %RESULT=0 %END %ROUTINE CRSPEC (%INTEGER M) !*********************************************************************** !* MODE=0 FOR NORMAL ROUTINE SPEC * !* MODE=1 FOR EXTERNAL(ETC) ROUTINE SPECS XREF NEEDED * !* P ON ENTRY TO P(RT) IN (RT)(MARK)(%SPEC')(NAME)(FPP) * !*********************************************************************** %INTEGER KK,JJ,TYPEP,OPHEAD,NPARMS,AXNAME LITL=EXTRN&3 %IF A(P)=1 %THEN %START; ! P=%ROUTINE TYPEP=LITL<<14!X'1000' P=P+2; ! IGNORING ALT OF P(SPEC') %FINISH %ELSE %START; ! P= ROUT=1; ARR=0; P=P+1 CLT; NAM=0 %IF A(P)=2 %THEN NAM=2; ! 2 FOR MAP 0 FOR FN PACK(TYPEP) P=P+2; ! AGAIN IGNORING ALT OF P(SPEC') %FINISH KK=FROM AR2(P) AXNAME=WORKA_DICTBASE+WORD(KK) JJ=0 P=P+3 %IF A(P-1)=1 %THEN AXNAME=ADDR(A(P)) %AND P=P+A(P)+1 CFPLIST(OPHEAD,NPARMS) %IF M=1 %THEN %START ! CXREF(XNAME,PARM_DYNAMIC!(EXTRN//3),2,JJ); ! %STSTEM & %EXTERNAL =STATIC ! %DYNAMIC = DYNAMIC JJ=AXNAME %FINISH %ELSE %START JJ=WORKA_RTCOUNT WORKA_RTCOUNT=WORKA_RTCOUNT+1 %FINISH %IF M=0 %AND RLEVEL=0 %START %IF PARM_CPRMODE=0 %THEN PARM_CPRMODE=2 %IF PARM_CPRMODE#2 %THEN FAULT(56,0,KK) %FINISH J=15-M; PTYPE=TYPEP KFORM=NPARMS SNDISP=JJ>>16 ACC<-JJ&X'FFFF' STORE TAG(KK,OPHEAD) %END %ROUTINE CFPLIST(%INTEGERNAME OPHEAD,NPARMS) !*********************************************************************** !* COMPILE A FORMAL PARAMETER PART INTO A LIST OF PARAMETER TYPES * !* P(FPP)='('{(HOLE)(FPDEL)(NAMELIST)(MARK)}*')',0. * !* * !* THE LIST OF PARAMETER LOOKS LIKE:- * !* S1 = PTYPE FOR PARAM<<16! DIMENSION (DIMEN DEDUCED LATER) * !* S2 = ACC <<16 ! SPARE * !* S3 = 0 (RESERVED FOR FPP OF RTS) * !* * !* ON ENTRY P IS AT ALT OF FPP (WHICH MAY BE NULL) * !*********************************************************************** %INTEGER OPBOT, PP OPHEAD=0; OPBOT=0 NPARMS=0; ! ZERO PARAMETERS AS YET %WHILE A(P)=1 %CYCLE; ! WHILE SOME(MORE) FPS PP=P+1+FROMAR2(P+1); ! TO NEXT FPDEL P=P+3; ! TO ALT OF FPDEL CFPDEL; ! GET TYPE & ACC FOR NEXT GROUP %UNTIL A(P-1)=2 %CYCLE; ! DOWN FOR EACH DEL BINSERT(OPHEAD,OPBOT,PTYPE<<16,ACC<<16,0) NPARMS=NPARMS+1 P=P+3 %REPEAT P=PP %REPEAT P=P+1 %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=8 ->PK FP(3): ! %NAME ACC=8; NAM=1 ROUT=0; TYPE=0 ARR=0; PREC=0 PK: PACK(PTYPE) %END %ROUTINE DIAG POINTER(%INTEGER LEVEL) !*********************************************************************** !* PLANT CODE TO UPDATE THE DIAGNOSTIC POINTER. SINCE THE * !* VALUE WILL NOT BE KNOWN TILL THE DTABLE IS GENERATED PLANT * !* NO-OPS AND OVERWRITE IN ROUTINE DTABLE * !*********************************************************************** %IF PARM_TRACE#0 %THEN %START PUSH(CURRINF_RAL,1,CA,0) PBW(LDCW,256); ! 256 ARBITARY BUT 0 IS OPTIMISED! %FINISH %END %ROUTINE RHEAD(%INTEGER RTNAME,AXNAME) !*********************************************************************** !* COMPILES CODE FOR BLOCK AND ROUTINE ENTRY * !* RTNAME IS THE RT/FN/MAP NAME (=-1 FOR %BEGIN BLOCKS) * !* XNAME IS THE EXTERNAL NAME (="" FOR INTERNALS&BLOCKS * !* ACTIONS INCLUDE PLANTING JUMPS ROUND RT BODY AND * !* DEFINING EXTERNAL ENTRIES AS WELL AS PLANTING ENTRY CODE * !*********************************************************************** %INTEGER W3 %RECORD(TRIPF)%NAME CURRT %RECORD(LISTF)%NAME LCELL CURRINF_SNMAX=NMAX; CURRINF_SN=N %IF RTNAME>=0 %THEN %START; ! SECTION FOR ROUTINES LCELL==ASLIST(TAGS(RTNAME)) ! ! FIRST JUMP ROUND BODY UNLESS AT TOP LEVEL OR IN COMPILER ! OR A JUMP IS ALREADY OUTSTANDING AT THIS LEVEL ! MUST DO THIS HERE BEFORE LEVEL IS CHANGED OR LABEL LIST IS WRONG ! %IF PARM_COMPILER=0 %AND LEVEL>1 %AND CURRINF_JROUND=0 %START PLABEL=PLABEL-1 CURRINF_JROUND=PLABEL ENTER JUMP(15,PLABEL,0) %FINISH RLEVEL=RLEVEL+1; RBASE=RLEVEL %FINISH LEVEL=LEVEL+1 CURRINF==LEVELINF(LEVEL) CURRINF=0 CURRINF_RBASE=RBASE CURRINF_NAMES=-1 CURRINF_DIAGINF=LEVELINF(LEVEL-1)_DIAGINF 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; ! CURRENT BLOCK TYPE MARKER ! ! TILL LOADER COPIES GLAP TO GLA MUST CALL A FRIG ROUTINE TO DO ! THIS ESSENTIAL AS SOON AS POSSIBLE IN ANYTHING EXTERNAL ! CURRT==TRIPLES(UCONSTTRIP(RTHD,X'51',0,RTNAME)) CURRT_OPND1_XTRA=AXNAME %END %ROUTINE RDISPLAY(%INTEGER KK) !*********************************************************************** !* SET UP OR COPY THE DISPLAY * !* SINCE THIS IS IN REGISTERS ON 360 IT IS EASY * !* ALSO CLAIM STACK SPACE AND SET DIAGNOSTIC POINTERS * !*********************************************************************** %INTEGER TRIPNO %IF KK>=0 %OR LEVEL=2 %START; ! DISPLAY NEEDED ! DONE BY THE QCODE CALL CURRINF_PSIZE=N; ! REMEMBER PARAMETER SIZE FOR RTDICT TRIPNO=UCONSTTRIP(RDSPY,X'51',0,N) %FINISH ! ! IF IN DIAGNOSTIC MODE PLANT CODE TO SAVE THE LINE & ROUTINE NO OF ! THE CALLING ROUTINE AND SET UP THE NEW BLOCK/ROUTINE IDENT NO. ! %IF PARM_TRACE#0 %START %IF KK>=0 %OR LEVEL=2 %START; ! ROUTINE NEW AREA NEEDED TRIPNO=UCONSTTRIP(RDAREA,X'51',0,N) N=N+4 CURRINF_DIAGINF=N N=N+4 %FINISH TRIPNO=UCONSTTRIP(RDPTR,X'51',0,LEVEL) DSTORE(2,RBASE,CURRINF_DIAGINF) %FINISH OLDLINE=0 SET LINE ! ! NORMALLY CODE IS PLANTED HERE TO CHECK PARAMETERS BUT I CANNOT ! SEE HOW TO DO THIS ON PERQ ARCHITECTURE. IT MAY BE IN THE QCODE ANYHOW ! ! ! CLAIM (THE REST OF) THE STACK FRAME ! %IF KK>=0 %OR LEVEL=2 %START NMAX=N %FINISH %END %ROUTINE CUI(%INTEGER CODE) !*********************************************************************** !* COMPILE AN UNCONDITIONAL INSTRN WHEREEVER IT OCCURS * !* CODE=0 UNCONDITIOALLY,=1 AFTER %THEN, =2 AFTER %ELSE * !*********************************************************************** %INTEGER MARKER,J,LNAME,TYPEP,PRECP,GWRDD,ALT,KK %INTEGER HEAD1,BOT1,NOPS %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) GWRDD=SNDISP; ! BYTE DISP OF CASEJUMP %UNLESS OLDI=LEVEL %AND TYPE=6 %START FAULT(4,0,LNAME); P=P-1; SKIP APP %RETURN %FINISH CSEXP(X'41') KK=GWRDD-(CA+2) %IF KK>=-128 %THEN PB2(JMPB,KK) %ELSE PBW(JMPW,KK-1) REPORTUI=1 %FINISH %RETURN SW(3): ! RETURN FAULT(30,0,0) %UNLESS CURRINF_FLAG&X'3FFF'=X'1000' P=P+1 RET: PB1(RETURN) REPORT UI=1 CURR INST=1 %IF CODE=0 %IF CA>30000 %AND WORKA_PLABS(1)<30000 %THEN REPEAT PROLOGUE %RETURN SW(4): ! %RESULT(ASSOP)(EXPR) PTYPE=CURRINF_FLAG&X'3FFF'; UNPACK %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) DSTORE(4,RLEVEL,0); ! INTO RESULT WORDS FAULT(81,0,0) %UNLESS A(P)=2; P=P+1 FAULT(83,CURRINF_M-1,FROMAR2(J)) %C %UNLESS TYPEP=TYPE %AND PRECP=PREC ->RET %FINISH %IF A(P+1)=2 %THEN %START; ! ASSOP='=' P=P+2 %IF NAM#0 %THEN TYPE=1; ! MAPS HAVE INTEGER RESULTS %IF TYPE=5 %THEN %START CSTREXP(32); ! FULL VIRTAD DSTORE(4,RLEVEL,0) %FINISH %ELSE %START %IF PREC<4 %THEN PREC=4 %IF NAM=0 %THEN KK=PREC<<4!TYPE %ELSE KK=X'51' CSEXP(KK) DSTORE(BYTES(KK>>4),RLEVEL,0) %FINISH; ->RET %FINISH %FINISH FAULT(31,0,0) P=P+2; SKIP EXP; ! IGNORE SPURIOUS RESULT %RETURN SW(5): ! %MONITOR (AUI) PB1(LDC0); ! ERR=0 PB1(LDC0); ! EXTRA=0 PB4(LDAP,LDC0,MMS2,MMS2) PB3(CALLXB,1,0) GXREF(MDEP,0,0,CA-3) 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,X'41'); ! EVENT NO TO J FAULT(26,J,0) %UNLESS KK=0 %AND 1<=J<=15 HEAD1=0; NOPS=0 PUSH(HEAD1,X'51'<<16!1,256*J,0); ! EVENT<<8 AS CONST BOT1=HEAD1 %IF A(P)=1 %START; ! SUBEVENT SPECIFIED PUSH(HEAD1,ANDL,0,0); ! OPERATOR & PUSH(HEAD1,X'51'<<16!1,255,0); ! CONST=F'255' P=P+4; TORP(HEAD1,BOT1,NOPS) BINSERT(HEAD1,BOT1,ORL,0,0); ! OPERATOR ! NOPS=NOPS+2 %FINISH EXPOP(HEAD1,BOT1,NOPS,X'51'); ! EVALUATE %IF CURRINF_NMDECS&16 #0 %START; ! IN AN 'ON' GROUP %IF CURRINF_FLAG<=2 %START; ! IN A BEGIN BLOCK DIAGPOINTER(LEVEL-1); ! TO NEXT OUTER BLOCK %FINISH %ELSE %START; ! 'ON IN A RT/FN/MAP PB1(NOOP) %FINISH %FINISH PPJ(0,2) 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 EXITLAB=0 %THEN FAULT(54+ALT,0,0) %AND %RETURN KK=INTEGER(ADDR(EXITLAB)+4*ALT) ENTER JUMP(15,KK&X'FFFFFF',B'10'!KK>>31) 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, %C ELSEALT,K,CS %CONSTINTEGER NULL ELSE=4 %SWITCH ESW(1:NULL ELSE) SET LINE %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 %C USERLAB=FROM AR2(MARKUI+1); ! UI = SIMPLE LABEL %IF 8<=ALTUI<=9 %AND EXITLAB#0 %START; ! VALID EXIT %IF ALTUI=8 %THEN USERLAB=EXITLAB %ELSE USERLAB=CONTLAB %FINISH ! %IF SKIP=YES %THEN %START; ! NO CODE NEEDED %IF START#0 %START P=MARKR+1 CSTART(2,1); ! NO CODE MARKE=P %FINISH CCRES=1; ! NO CODE FOR ELSE ->ELSE %FINISH ! %IF USERLAB>=0 %THEN %START; ! FIRST UI IS'->'