%MAINEP ICL9CEZPERQIMP %TRUSTEDPROGRAM %BEGIN %CONSTINTEGER RELEASE=1 %CONSTINTEGER YES=1,NO=0 %CONSTINTEGER ON PERQ=NO %CONSTSTRING(9) LADATE="3 Dec 81"; ! LAST ALTERED %INTEGER I, J, K %CONSTINTEGER NO OF SNS=63 %CONSTINTEGER LRLPT=X'52' ! ! FIXED GLA CURRENTLY USED AS FOLLOWS ! 0-7 FREE(WAS 2900 ENTRY DESCRIPTOR) ! 8-11 ADDRESS OF UNSHARED SYMBOL TABLES ! 12-15 ADDRESS OF SHARED SYMBOL TABLES ! 16-19 LANGUAGE & COMPILER DATA ! 20-23 RESERVED (BUT IN MAIN PROGS IS FILLED WITH STACKPTR@ENTRY) ! 24-27 ADDRESS OF CONSTANT TABL ! 28-31 ADDRESS OF A WORD CONTAINING STACKTOP 0FOR NO CHECKS ! 32-39 FREE ! 40-55 DEFINES THE ENTRY POINT OF MDIAGS ! %OWNINTEGERARRAY FIXED GLA(0:13)=M'IMP ',M'GLAP',0(12); %CONSTBYTEINTEGERARRAY BYTES(0:7)=0(3),1,2,4,8,16; %CONSTINTEGER MAXLEVELS=31,CONCOP=13,FIXEDGLALEN=56 ! %INCLUDE "ERCC07.PERQ_OPCODES" %INCLUDE "ERCC07.PERQ_FORMATS" %CONSTINTEGER SNPT=X'1006'; ! SPECIALNAME PTYPE %CONSTINTEGER UNASSPAT=X'80808080' ! %INTEGER DUMMYFORMAT, P1SIZE, LEVELINF, RTCOUNT ! %INTEGER ASL, ARSIZE, CONSTLIMIT, OLDLINE, %C NEXTP, SNUM, RLEVEL, NMAX, USTPTR, PLABEL, LEVEL ! %INTEGER PROFAAD, LAST INST, LINE, BFFLAG ! %INTEGER RBASE, N, EXITLAB, CONTLAB, %C Q, R, FNAME, SSTL, STMTS, FILE PTR, FILE END, FILE SIZE, %C BIMSTR,ASL WARN ! %INTEGER MAX ULAB, SFLABEL %LONGREAL CTIME %STRING(31)MAINEP %INTEGER LOGEPDISP,EXPEPDISP ! %EXTERNALINTEGER CA=0,CABUF=0,GLACA=FIXEDGLALEN,GLACABUF=FIXEDGLALEN %EXTERNALINTEGER PPCURR=0 %EXTERNALRECORD(PARMF) PARM %EXTERNAL%RECORD(WORKAF)WORKA %EXTERNALBYTEINTEGERARRAY CODE(0:268) %EXTERNALBYTEINTEGERARRAY GLABUF(0:268) %INTEGERARRAY PLABS,PLINK(0:31) %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 ASL=3*WORKA_NNAMES 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) %INTEGERFNSPEC FROMAR4(%INTEGER PTR) %INTEGERFNSPEC FROMAR2(%INTEGER PTR) %INTEGERFNSPEC MORE SPACE !%INTEGERFNSPEC NEWCELL %ROUTINESPEC INSERTATEND(%INTEGERNAME S, %INTEGER A, B, C) %ROUTINESPEC INSERT AFTER(%INTEGERNAME S,%INTEGER A,B,C) %ROUTINESPEC FROM12(%INTEGER CELL, %INTEGERNAME S1, S2) %ROUTINESPEC FROM123(%INTEGER CELL, %INTEGERNAME S1, S2, S3) %ROUTINESPEC POP(%INTEGERNAME C, P, Q, R) %ROUTINESPEC PUSH(%INTEGERNAME C, %INTEGER S1, S2, S3) %INTEGERFNSPEC FIND(%INTEGER LAB, LIST) %ROUTINESPEC MLINK(%INTEGERNAME CELL) %ROUTINESPEC REPLACE1(%INTEGER CELL, S1) %ROUTINESPEC REPLACE123(%INTEGER CELL,A1,A2,S3) %INTEGERFNSPEC FROM2(%INTEGER CELL) %INTEGERFNSPEC FROM1(%INTEGER CELL) %INTEGERFNSPEC FROM3(%INTEGER CELL) %ROUTINESPEC BINSERT(%INTEGERNAME T,B,%INTEGER S1,S2,S3) %ROUTINESPEC CLEARLIST(%INTEGERNAME HEAD) %INCLUDE "ERCC07.PERQ_XSPECS" %SYSTEMLONGREALFNSPEC CPUTIME !*DELSTART %ROUTINESPEC PRINTLIST(%INTEGER HEAD) %ROUTINESPEC CHECK ASL !*DELEND ! 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(%ROUTINE POP(%INTEGERNAME A,B,C,D), %ROUTINE PUSH(%INTEGERNAME A,%INTEGER B,C,D)) 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_PLABS==PLABS WORKA_PLINK==PLINK 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; USTPTR=0; BFFLAG=0 RBASE=1; LOGEPDISP=0; EXPEPDISP=0 SSTL=0; STMTS=1; SNUM=0; LEVELINF=0 BIMSTR=0 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) CTIME=CPUTIME ASL WARN=0 WORKA_ASL CUR BTM=ASL-240 CONST LIMIT=4*WORKA_ASL CUR BTM-8 %CYCLE I=WORKA_ASL CUR BTM,1,ASL-1 ASLIST(I+1)_LINK=I %REPEAT ASLIST(WORKA_ASL CUR BTM)_LINK=0 ASLIST(0)_S1=-1 ASLIST(0)_S2=-1 ASLIST(0)_S3=-1 ASLIST(0)_LINK=0 %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(POP,PUSH) R=P1SIZE %END; ! OF BLOCK CONTAINING PASS 1 %BEGIN !*********************************************************************** !* SECOND OR CODE GENERATING PASS * !*********************************************************************** %INTEGERARRAY DIAGINF, RAL, FLAG, L, M, NMDECS, ONWORD, ONINF,%C JUMP, LABEL, JROUND, UNATT FORMATS, PSIZE, ENTRYAD, %C NAMES (0:MAXLEVELS) %INTEGERARRAY AVL WSP(0:4,0:MAXLEVELS) %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 COMPILE A STMNT %ROUTINESPEC CSS(%INTEGER P) %ROUTINESPEC LOAD DATA %CYCLE I=0, 1, MAXLEVELS RAL(I)=0 JUMP(I)=0; JROUND(I)=0 LABEL(I)=0; FLAG(I)=0; UNATT FORMATS(I)=0 L(I)=0; M(I)=0 ONWORD(I)=0; ONINF(I)=0 NAMES(I)=-1 %CYCLE J=0,1,4 AVL WSP(J,I)=0 %REPEAT %REPEAT CTABLE==ARRAY(ADDR(ASLIST(1)),CF) CTABLE(1)=M'CTAB' LINE=0 PERQPROLOGUE SSTL=4 NEXTP=1; LEVEL=1; STMTS=0 RLEVEL=0; RBASE=0 %WHILE A(NEXTP+3)!A(NEXTP+4)#0 %CYCLE COMPILE A STMNT %REPEAT LINE=99999 PERQEPILOGUE(LOGEPDISP,EXPEPDISP,POP) LOAD DATA %STOP %ROUTINE COMPILE A STMNT %INTEGER I !*DELSTART %IF PARM_DCOMP#0 %AND CA>CABUF %THEN CODEOUT !*DELEND I=NEXTP NEXTP=NEXTP+A(NEXTP)<<16+A(NEXTP+1)<<8+A(NEXTP+2) 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 LOAD DATA !*********************************************************************** !* PASS INFORMATION TO QPUT TO ENABLE IT TO GENERATE THE * !* LOADER DATA AND COMPLETE THE PROGRAM FILE. * !*********************************************************************** %INTEGERARRAY SUMMARY(0:5) %INTEGER LANGFLAG,PARMS GLACA=(GLACA+7)&(-8) USTPTR=(USTPTR+7)&(-8) CODE OUT CNOP(0, 8) ! FIXED GLA(6)=CA; ! CONST TABLE ADDRESS DUMP CONSTS %IF PARM_TRACE=0 %THEN LANGFLAG=6 %ELSE LANGFLAG=1 LANGFLAG=LANGFLAG<<24 PARMS=(PARM_DIAG<<1!PARM_LINE)<<1!PARM_TRACE FIXED GLA(4)=LANGFLAG!RELEASE<<16!(PARM_CPRMODE&1)<<8!PARMS;! LANG RLSE & MAINPROG I=GLACA-GLACABUF %IF PARM_INHCODE=0 %THEN %START QPUT(42, I, GLACABUF, ADDR(GLABUF(0))) %UNLESS I=0 ! BACK OF GLAP QPUT(42, FIXEDGLALEN, 0, ADDR(FIXED GLA(0)));! FRONT OF GLAP QPUT(19,2,8,5); ! RELOCATE GLA ST ADDRESS QPUT(19,2,12,4); ! RELOCATE CODE ST ADDRESS ! QPUT(19,2,24,1); ! RELOCATE CONSTANT TABLE I=X'E2E2E2E2' QPUT(44, 4, SSTL, ADDR(I)) ! %FINISH SSTL=(SSTL+11)&(-8) PRINTSTRING(" CODE") WRITE(CA, 6); PRINTSTRING(" BYTES GLAP") WRITE(GLACA, 3); PRINTSTRING("+") WRITE(USTPTR, 1); PRINTSTRING(" BYTES DIAG TABLES") WRITE(SSTL, 3); PRINTSTRING(" BYTES TOTAL") SUMMARY(0)=CA; SUMMARY(1)=GLACA SUMMARY(2)=0 SUMMARY(3)=SSTL SUMMARY(4)=USTPTR K=CA+GLACA+SSTL+USTPTR; SUMMARY(5)=K WRITE(K, 5); PRINTSTRING(" BYTES ") %IF PARM_FAULTY=0 %THEN %START WRITE(STMTS, 7); PRINTSTRING(" STATEMENTS COMPILED IN") WRITE(INT(1000*(CPUTIME-CTIME)),5) PRINTSTRING(" MSECS") COMREG(47)=STMTS; ! NO OF STMTS FOR COMPER %FINISH %ELSE %START PRINTSTRING("PROGRAM CONTAINS"); WRITE(PARM_FAULTY, 2) PRINTSTRING(" FAULT"); PRINTSYMBOL('S') %IF PARM_FAULTY>1 COMREG(47)=PARM_FAULTY; ! NO OF FAULTS FOR COMPER %FINISH NEWLINES(2) I=0; I=8 %IF PARM_FAULTY#0 COMREG(24)=I %IF PARM_INHCODE=0 %THEN QPUT(7, 24, 0, ADDR(SUMMARY(0))) ! SUMMARY INFO. PPROFILE %STOP %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) %ROUTINESPEC CHECK STOF %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) %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) %ROUTINESPEC GET WSP(%INTEGERNAME PLACE,%INTEGER SIZE) %ROUTINESPEC RETURN WSP(%INTEGER PLACE,SIZE) %INTEGERFNSPEC TSEXP(%INTEGERNAME VALUE) %ROUTINESPEC STACKDUMP(%INTEGER WORDS) %ROUTINESPEC STACKUNDUMP(%INTEGER WORDS) %ROUTINESPEC CRCALL(%INTEGER RTNAME) %ROUTINESPEC NAMEOP(%INTEGER Z,SIZE,NAMEP) %ROUTINESPEC CNAME(%INTEGER Z) %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 %ROUTINESPEC PPJ(%INTEGER MASK,N) %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(1:14)=%C EQUI,GEQI,GTRI,NEQI,LEQI,LESI,NEQI, EQUI,LEQI,LESI,NEQI,GEQI,GTRI,NEQI; %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,TWSPHEAD,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 TWSPHEAD=0 ->SW(A(P)) SW(13): ! INCLUDE SOMETHING SW(24): ! REDUNDANT SEP SW(2): ! CSSEXIT: LAST INST=CURR INST %WHILE TWSPHEAD#0 %CYCLE POP(TWSPHEAD,JJ,KK,QQ) RETURN WSP(JJ,KK) %REPEAT %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 NMDECS(LEVEL)&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(FLAG(LEVEL)) 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=0; ! NO OUTSTANDING JUMP TO EXTERNAL 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 ENTRYAD(1)=CA; ! MAIN ENTRY L(1)=0; M(1)=0 PARM_CPRMODE=1 RHEAD(-1,ADDR(MAINEP)) N=0 RDISPLAY(-1) ! ! THE CODE PLANTED IS AS FOLLOWS:- ! L CTABLEREG,24(GLA) LOAD POINTER TO CONSTANT ! PB1(NOOP) ! ! SET THE PROGRAM MASK TO MASK OUT UNDERFLOW AND ALLOW ALL OTHER INTS ! ! LA 1,8 ! SLL 1,244 SET 8 IN TOP BYTE ! SPM 1 ALLOW OVERFLOW MASK OTHER ! PTYPE=1 %FINISH %ELSE FAULT(58,0,0) %FINISH %ELSE %START SET LINE; ! SO 'ENTERED FROM LINE' IS OK RHEAD(-1,0) RDISPLAY(-1) %FINISH %END ->CSSEXIT ! SW(15): ! '%ON'(EVENT')(N)(NLIST)'%START' FAULT(57,0,0) %UNLESS LEVEL>=2 FAULT(40,0,0) %IF NMDECS(LEVEL)&1#0 NMDECS(LEVEL)=NMDECS(LEVEL)!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(JMPW,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 ONWORD(LEVEL)=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 ONINF(LEVEL)=N; N=N+12 OLDLINE=0 CSTART(0,3) NMDECS(LEVEL)=NMDECS(LEVEL)!!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(JMPW,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=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, %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) %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="" 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<--LB %IF EXTRN#0 %THEN SNDISP=0 %ELSE %C SNDISP=(SNDISP&X'3FFFF')>>2 PGLA(4,STALLOC,ADDR(AH1)) RELOCATE(16,GLACA-4,2) %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,AH2,AD) %IF ONPERQ=NO %THEN QPUT(9,QPUTP-40,STPTR,STALLOC) %FINISH ! O/P STRING STPTR=(STPTR+ACC+3)&(-4) 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<--LB; ! BASE OFFSET 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(16,TAGDISP+4,2); ! 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) STPTR=(STPTR+3)&(-4) 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 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) RCONST=ICLREALTOPERQ(RCONST) %CYCLE I=0,2,6 HALFINTEGER(ADDR(FRCONST)+6-I)=HALFINTEGER(ADDR(RCONST)+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 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 PWORD(FROM AR2(P+1)) ->BEND UCITYPE(4): ! CNOP CNOP(A(P),A(P+1)) ->BEND 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 PB1(OPC); ->BEND QINST(2): ! UNSIGNED BYTE OPERAND FAULT(96,0,1) %UNLESS 0<=VAL1<=255 PB2(OPC,VAL1) ->BEND QINST(3): ! SIGNED BYTE OPERAND FAULT(96,0,1) %UNLESS -128<=VAL1<=127 PB2(OPC,VAL1) ->BEND QINST(4): ! SIGNED WORD OPERAND FAULT(96,0,1) %UNLESS IMOD(VAL1)<=X'7FFFF' PBW(OPC,VAL1) ->BEND QINST(5): ! 2 UNSIGNED BYTE OPERANDS FAULT(96,0,1) %UNLESS 0<=VAL1<=255 FAULT(96,0,2) %UNLESS 0<=VAL2<=255 PB3(OPC,VAL1,VAL2) ->BEND QINST(6): ! BYTE & WORD OPERANDS FAULT(96,0,1) %UNLESS 0<=VAL1<=255 FAULT(96,0,2) %UNLESS IMOD(VAL2)<=X'7FFFF' PB2W(OPC,VAL1,VAL2) ->BEND 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 UNATT FORMATS(LEVEL)#0 %START LCELL==ASLIST(UNATT FORMATS(LEVEL)) %IF LCELL_S2=0 %THEN LCELL_S2=OPHEAD %AND %RESULT=OPHEAD %IF LCELL_S3=0 %THEN LCELL_S3=OPHEAD %AND %RESULT=OPHEAD %FINISH PUSH(UNATT FORMATS(LEVEL),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 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<--LB PGLA(2,8,ADDR(A0)) D1=GLACA-8 RELOCATE(16,D1+4,2); ! 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 PB3(LDC0+4,TLATE2,LDMW) %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(LDC0+4,LDMW); ! HEAD TO MSTACK 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 PB2(LOPS,2); ! ADD 2 32 BIT POINTERS %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. * !*********************************************************************** ACCESS=MODE+4 BASE=BS DISP=DP; XDISP=XD NAMEOP(3,4,-1) %END %ROUTINE LOCALISE(%INTEGER SIZE) !*********************************************************************** !* REMOVES A POINTER OR ARRAYHEAD FROM A RECORD AND STORES * !* IT IN A TEMPORARY UNDER LNB. * !*********************************************************************** %INTEGER HOLE ACCESS=MODE+4 BASE=BS; DISP=DP XDISP=XD NAMEOP(3,SIZE,-1) GET WSP(HOLE,SIZE>>1) %IF SIZE=8 %START; ! LOCALISE ARRAY HEAD PB3(LDC0+4,TLATE2,LDMW) DFETCHAD(NO,RBASE,HOLE) PB2(LDC0+4,STMW) %FINISH %ELSE 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 UNDER * !* BASE REGISTER COVER IS USUALLY REQUIRED. THE CURRENT LENGTH * !* OF STRING IN THE WORK AREA IS KEPT IN A REGISTER (BREG) * !* WHICH IS PROTECTED THROUGH THE NORMAL INTERMEDIATE-RESULT * !* MECHANISMS. * !* ON ENTRY:- * !* MODE=0 NORMAL. WK AREA NOT USED FOR ONE OPERAND EXPSSNS * !* MODE=1 STRING MUST GO TO WORK AREA * !* (AND TO COME) * !* MODE=3 CONCATENATE INTO LHS OF =ASSNMNT (E.G. A=B.C) * !* MODE=4 OPTIMISE S=S.T BY NOT COPYING S * !* 2**8 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:- * !* WORD OFFSET OF WORKAREA IS IN ETOS * !* VALUE#0 %IF RESULT IN A WORK AREA(CCOND MUST KNOW) * !* STRINGL SET IF STRING LENGTH KNOWN. STRFNRES DEFINES LENREG * !*********************************************************************** %INTEGER PP,WKAREA,DOTS,REXP,ERR,CLEN,KEEPWA,FNAM,I,FULLVAD %INTEGERFNSPEC STROP FULLVAD=MODE&32 KEEPWA=MODE&16; MODE=MODE&15 PP=P; STRINGL=0; FNAM=0; WKAREA=0 REXP=2-A(P+1+FROM AR2(P+1)); ! =0 %IF ONE OPERAND EXP -> NORMAL %UNLESS A(P+3)=4 %AND REXP=0 %AND MODE=0 ->NORMAL %IF FULLVAD=0 -> SIMPLE %IF A(P+4)=2 -> NORMAL %UNLESS A(P+4)=1 COPY TAG(FROM AR2(P+5)) %IF PTYPE=SNPT %THEN PTYPE=ACC -> NORMAL %UNLESS PTYPE=X'35' ; ! BEWARE OF TRANSLATES SIMPLE: P=P+4 ERR=STROP -> ERROR %UNLESS ERR=0 VALUE=WKAREA P=P+1; STRFNRES=0 %RETURN ERROR:FAULT(ERR,0,FNAM) BASE=RBASE; DISP=0 VALUE=0; ACCESS=0 P=PP; SKIP EXP %RETURN NORMAL: CLEN=0; P=P+3; ! LENGTH OF CONSTANT PART ERR=72; ->ERROR %UNLESS A(P)=4 P=P+1 GET WSP(WKAREA,268); ! GET NEXT OPERAND DOTS=0; ! NO OPERATORS YET NEXT: STRINGL=0 ! SET POINTER TO STRING ! IN WORK AREA PBW(LLAW,WKAREA>>1); ! OFFSET OF WORK AREA %IF DOTS=0 %THEN PB1(LDC0) %ELSE %START %IF CLEN>0 %THEN %START PBW(LDCW,CLEN) PB1(MMS); ! LENGTH TO MEMORY STACK PBW(LDCW,CLEN+1) %FINISH %ELSE %START PB3(REPL,LDC0,LDB) PB2(REPL,MMS); ! LENGTH SAVED FOR ADDN ON MMS PB2(LDC0+1,ADI) %FINISH %FINISH ERR=STROP; ! GET NEXT OPERAND ! ! AT THIS POINT ESTACK HAS TWO STRING POINTERS AND MSTACK HAS ! LENGTH OF STRING ALREADY IN WK AREA ! -> ERROR %UNLESS ERR=0 %IF DOTS=0 %START PB1(LDC0) PBW(LDCW,255) PB2(TLATE3,SAS); ! ASSIGN 1ST STRING TO WKAREA %FINISH %ELSE %START PB4(REPL2,LDC0,TLATE2,LDCH); ! LENGTH OF 2ND OPERAND PB2(REPL,MMS); ! IS SAVED PB2(MMS,LDC0+1) PB3(MES,TLATE3,MVBW); ! STRINGS JOINED PBW(LLAW,WKAREA>>1) PB3(LDC0,MES2,ADI); ! NEWLENGTH CALCULATED PB1(STB); ! AND STORED %IF CLEN>0 %AND STRINGL>0 %THEN CLEN=CLEN+STRINGL %C %ELSE CLEN=0 %FINISH %IF A(P)=2 %THEN -> TIDY; ! NO MORE OPERATIONS ERR=72; -> ERROR %UNLESS A(P+1)=CONCOP; ! CONCATENATE DOTS=DOTS!1 P=P+2; -> NEXT TIDY: ! FINISH OFF VALUE=WKAREA %IF FULLVAD#0 %THEN PB1(LSSN) PBW(LLAW,WKAREA>>1) P=P+1; ! PAST REST OF EXPRN RETURN WSP(WKAREA,268) %IF KEEPWA=0 STRINGL=0 %RETURN %INTEGERFN STROP !*********************************************************************** !* 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 %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 STRINGL=A(P+2) CNOP(1,2) PB2(LSA,STRINGL) PB1(A(P+2+I)) %FOR I=1,1,STRINGL P=P+STRINGL+3 %FINISH %ELSE %RESULT=73 %FINISH %ELSE %START P=P+1; ! MUST CHECK FIRST REDUCE TAG; ! SINCE CNAME ONLY LOADS STRINGS ! AND LONGINTS TO DR! %IF 5#TYPE#7 %THEN FNAM=FROMAR2(P) %AND %RESULT=71 CNAME(2) 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,4); ! 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: 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 PPJ(15,10); ! RUN FAULT 11 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 LABEL(LEVEL)#0 %CYCLE POP(LABEL(LEVEL),I,J,KP) I=I>>24 %IF J&X'FFFF'#0 %THEN %START J=J&X'FFFF' %IF 0>1 DTABLE(LEVEL); ! OUTPUT DIAGNOSTIC TABLES %WHILE UNATT FORMATS(LEVEL)#0 %CYCLE POP(UNATT FORMATS(LEVEL),I,J,JJ) CLEAR LIST(I) CLEAR LIST(J) CLEAR LIST(JJ) %REPEAT ! ! CLEAR DECLARATIONS - POP UP ANY GLOBAL NAMES THAT WERE REDECLARED ! DESTROY SIDE CHAINS FOR ROUTINES,FORMATS AND SWITCHES ! ! ! NOW PLANT THE BLOCK EXIT SEQUENCE ! ! %IF KKK&X'3FFF'=X'1000' %AND LAST INST=0 %THEN RT EXIT CSTOP %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 DIAG POINTER(LEVEL-1) DSTORE(2,RBASE,DIAGINF(RLEVEL)) %FINISH JJ=NMDECS(LEVEL)>>14 %IF JJ#0 %THEN %START; ! ARRAYS TO BE UNDECLARED DFETCH(2,RBASE,JJ); ! OLD TOP POINTER PB3(LDTP,SBI,ATPW); ! AND RESET %FINISH %FINISH ! ! 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=M(LEVEL)-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=(PSIZE(RLEVEL)-RTDICT_PS)//2 RTDICT_RPS=PSIZE(RLEVEL)//2 RTDICT_LTS=NMAX//2-RTDICT_RPS RTDICT_ENTRY=ENTRYAD(RLEVEL) RTDICT_EXIT=CA PB1(RETURN); ! DUMMY EXIT SEQUENCE PROTEM RTDICT_LL=RLEVEL %IF RLEVEL=1 %THEN ID=ID!1<<16;! FLAG AS EXTERNAL QPUT(11,ID,ADDR(RTDICT),JJ) %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 %IF KKK>=X'1000' %THEN %START RLEVEL=RLEVEL-1 RBASE=RLEVEL %FINISH ! ! RESTORE INFORMATION ABOUT THE (NEW) CURRENT LEVEL ! POP(LEVELINF,KP,N,KP) NMAX=N>>16 %IF KKK>=X'1000' N=N&X'7FFF' %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 ASL WARN#0 %THEN %C ASL WARN=0 %AND PERQEPILOGUE(LOGEPDISP,EXPEPDISP,POP) %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(JROUND(LEVEL+1),0) JROUND(LEVEL+1)=0 %FINISH %FINISH %RETURN ! ! LAYOUT OF DIAGNOSIC TABLES ! ****** ** ********* ****** ! ! THE BOUND FIELD OF PLT DESCRIPTOR STORED AT (LNB+3 & LNB+4) IF ! USED TO CONTAIN A DISPLACEMENT RELATIVE TO THE START OF SST OF THE ! DIAGNOSTIC TABLES FOR THE BLOCK OR ROUTINE BEING EXECUTED. ! A ZERO BOUND MEANS NO DIAGNOSTIC REQUESTED.(NB THIS MAY MEAN A DUMMY ! FIRST WORD IN THE SST). ! THE ABSOLUTE ADDRESS OF THE SST FOR THE CURRENT CODE SEGMENT WILL ! ALWAYS BE FOUND IN THE STANDARD 10 WORDS OF THE GLA/PLT ! ! FORM OF THE TABLES:- ! ! WORD 0 = LINE OF RT IN SOURCE PROG <<16 ! LINE NO POSN(FROM LNB) ! WORD 1 = (12 LANG DEPENDENT BITS)<<18 ! ENVIRONMENT ! ( TOP 2 BITS OF LANG DEPENDENT HAS LITL FROM PTYPE) ! ( BOTTOM 4 BITS HAVE TEXTUAL LEVEL) ! WORD 2 = DISPLAY POSN (FROM LNB)<<16 ! RT TYPE INFO ! WORD 3 = ZERO FOR BLKS OR STRING(<=11BYTES) BEING THE ! RT NAME. THIS WILL TAKE WORDS 4 AND 5 IF NEEDED ! WORD 6 = LANGUAGE DEPENDENT INFO . IMP ON CONDITIONS ETC ! ! THE REST IS MADE UP OF VARIABLE ENTRIES AND THE SECTION IS TERMINATED BY ! A WORD OF X'FFFFFFFF' ! ! EACH VARIABLE ENTRY CONSISTS OF THE VARIABLE WORD FOLLOWED BY ! THE VARIABLE NAME AS A STRING. THE WORD CONSISTS OF ! BITS 2**31 TO 2**20 TYPE INFORMATION (MAY BE LANGUAGE DEPENDENT ! BIT 2**19 =0 UNDER LNB =1 IN GLA ! BITS 2**18 TO 2**0 DISPLACEMENT FROM LNB(GLA) IN BYTES ! ! ! THE ENVIRONMENT IS A POINTER (RELATIVE TO SST) OF THE NEXT OUTERMOST ! BLOCK OR A POINTER TO GLOBAL OWNS, EXTERNAL OR COMMON AREAS ! A ZERO MEANS NO ENCLOSING BLOCK. WORD1=WORD3=0 IS AN ! IMP MAIN PROGRAM AND WILL TERMINATE THE DIAGNOSTICS. ! %ROUTINE DTABLE(%INTEGER LEVEL) !*********************************************************************** !* THIS ROUTINE LOOKS AT THE DECLARATIONS FOR THE CURRENT LEVEL & * !* SETS UP THE SEGMENT OF SHARABLE SYMBOL TABLES TO DESCRIBE THEM.* !* FOR MAIN PROGRAMS OR EXTERNAL ROUTINES THE 'GLOBAL' VARIABLES * !* (IF ANY) ARE ALSO INCLUDED. * !*********************************************************************** %STRING(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 RAL(LEVEL)#0 %CYCLE POP(RAL(LEVEL),Q,JJ,KK) %IF Q=1 %THEN %START PLUG(1,JJ+2,SSTL>>9&255,1) PLUG(1,JJ+1,SSTL>>1&255,1) %FINISH %ELSE PLUG(Q,JJ,KK!SSTL,4) %REPEAT PUSH(RAL(LEVEL-1),4,SSTL+4,LANGD) %IF PARM_TRACE#0 DD(0)=L(LEVEL)<<16!(DIAGINF(RLEVEL)+2) DD(1)=LANGD DD(2)=4*RBASE!FLAG(LEVEL)&X'3FFF' ML=M(LEVEL); ! 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,4,SSTL+12,LNUM+1) DPTR=DPTR+LNUM>>2; ! ACTUAL NO OF CHARS %FINISH DD(DPTR)=ONWORD(LEVEL); ! ON CONDITION WORD DPTR=DPTR+1 JJ=NAMES(LEVEL) %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,4,SSTL+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(44,DPTR,SSTL,ADDR(DD(0)));! ADD TO SHARABLE SYM TABS SSTL=SSTL+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, %C %INTEGERNAME ASIZE,LB) !*********************************************************************** !* CONSTRUCTS THE DOPE-VECTOR FOR A CONSTANT ARRAY IN THE * !* SHAREABLE SYMBOL TABLES AND RETURNS ITS DISPLACEMENT AS RESULT* !* EVENTUALLY ALL NON DYNAMIC DOPE VECTORS SHOULD GO VIA HERE * !* P IS TO ALT (MUST BE 1!) OF P * !* DOPE VECTOR CONSISTS OF :- * !* WORD CONTAINING THE NO OF DIMENSIONS ND * !* SIZE (IN BYTES) OF A SINGLE ELEMENT * !* SIZE (IN BYTES OF ENTIRE ARRAY) FOR STACK ADJUSTMENT * !* AND ND 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 * !* P TO ALT (ALWAYS=1) OF P(BPAIR) * !*********************************************************************** %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 %HALFINTEGERARRAY HDV(0:39) ND=0; NOPS=0; TYPEPP=0; PIN=P M0=1 %IF MODE=-1 %THEN %START ND=1; DV(4)=0 M0=X'7FFF' DV(3)=M0 DV(5)=M0 ASIZE=M0 %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 ! 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)&(-2) DV(0)=ND DV(1)=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 PGLA(2,0,0); ! ALIGN SNDISP=4*WORKA_CONST PTR I=GLACA PUSH(DVHEADS(ND),WORKA_CONSTPTR,ASIZE,I) %CYCLE D=0,1,K HDV(D)<-DV(D) CTABLE(WORKA_CONST PTR)=DV(D) WORKA_CONST PTR=WORKA_CONST PTR+1 %REPEAT %IF WORKA_CONST PTR>CONST LIMIT %THEN FAULT(102, WORKA_WKFILEK,0) PGLA(2,2*(K+1),ADDR(HDV(0))) WAYOUT: %IF MODE=-1 %THEN %RESULT=I; ! NO EXPRESSION CELLS TO RETURN %RESULT =I NONCONST: ! NOT A CONST DV J=ND; I=0; 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 * !*********************************************************************** %ROUTINESPEC CLAIM AS %ROUTINESPEC COMPUTE ZAD %INTEGER DVDISP, PP, DVF, ELSIZE, TOTSIZE, LB, PTYPEP, %C ARRP, NN, ND, II, QQ, CDV, LWB, PTYPEPP, JJJ %INTEGERARRAY LBNDS(0:12) %IF FLAG(LEVEL)=0 %AND NMDECS(LEVEL)>>14=0 %START PB1(LDTP); ! SAVE STACK PTR DSTORE(2,RBASE,N) NMDECS(LEVEL)=NMDECS(LEVEL)!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' DVDISP=N; ! DVDISP IS D-V POSITION N=N+6*ND+6; ! CLAIM SPACE FOR THE D-V PB1(LDC0+ND) DSTORE(2,RBASE,DVDISP) PBW(LDCW,ELSIZE) PB1(REPL) %UNLESS ELSIZE=1 DSTORE(2,RBASE,DVDISP+2) ! %CYCLE II=1,1,ND P=P+4 QQ=DVDISP+6*II; ! TRIPLE FOR IITH DIMENSION JJJ=INTEXP(LBNDS(II),X'41'); ! LOWER BOUND %IF JJJ=0 %START; ! CONST L BOUND PBW(LDCW,LBNDS(II)) DVF=0 %UNLESS LBNDS(II)=0 %FINISH %ELSE %START DVF=0 LBNDS(II)=X'01000000' PB1(REPL) %FINISH DSTORE(2,RBASE,QQ+2) ! ! KEEP TRACK OF LOWER BOUNDS TO MINIMISE RUN TIME WORK IN COMPUTING ! THE BASE ADDRESS ! CSEXP(X'41'); ! UPPER BOUND PB1(REPL) DSTORE(2,RBASE,QQ) %IF LBNDS(II)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 %IF CDV#0 %START; ! COMPILETIME DV PBW(LDCW,-LWB); ! BASE OFFSET PB2(LSSN,LDTP) PBW(LOAW,DVDISP>>1); ! ADDR OF DV IN GLA %FINISH %ELSE %START; ! DYNAMIC ARRAYS %IF JJJ=0 %THEN COMPUTE ZAD %IF JJJ#NN-1 %THEN PB1(REPL);! PRESERVE A COPY OF ZAD PB2(LSSN,LDTP) PBW(LLAW,DVDISP>>1) %FINISH DSTORE(2,RBASE,N+4) DSTORE(4,RBASE,N) DSTORE(2,RBASE,N+6) ACC=ELSIZE; ! RESET ACC AFTER DV CMPLD KFORM=FINF; ! FORMAT INFORMATION K=FROM AR2(PP+3*JJJ) STORE TAG(K,N) CLAIM AS %IF FORMAT = 0 N=N+8 %REPEAT P=P+1; ! PAST REST OF ARRAYLIST %IF A(P-1)=1 %THEN ->START %RETURN %ROUTINE COMPUTE ZAD !*********************************************************************** !* FIND THE OFFSET OF A(0...) FROM A(FIRST...) BY COMPUTING * !* THE OFFSET OF A(FIRST...) FROM A(0...) AND NEGATING * !*********************************************************************** %INTEGER JJ %IF DVF#0 %THEN PBW(LDCW,0) %AND %RETURN FAULT(99,0,0) %IF PARM_COMPILER#0 DFETCH(2,RBASE,DVDISP+6*ND+2) %IF ND>1 %THEN %START; ! MULTI DIMENSION DFETCH(2,RBASE,6*ND-2); ! PREVIOUS MULTIPLIER PB1(MPI) %CYCLE JJ=ND-1,-1,2 %IF LBNDS(JJ)#0 %THEN %START DFETCH(2,RBASE,DVDISP+6*JJ+2) DFETCH(2,RBASE,DVDISP+6*JJ-2) PB2(MPI,ADI) %FINISH %REPEAT %FINISH PB1(NGI) %END %ROUTINE CLAIM AS !*********************************************************************** !* CLAIM THE SPACE FOR AN ARRAY FROM STACK * !*********************************************************************** %INTEGER J %IF CDV#0 %START; ! SIZE KNOWN AT COMPILE TIME J=(TOTSIZE+1)>>1; ! IN WORDS %IF J<=127 %THEN PB2(ATPB,J) %ELSE %C PBW(LDCW,J) %AND PB1(ATPW) %FINISH %ELSE %START DFETCH(2,RBASE,DVDISP+4) PB1(ATPW) %FINISH CHECK STOF %IF PARM_OPT#0 %END %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(1:8)= %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<>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=RTCOUNT RTCOUNT=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(RAL(LEVEL),1,CA,0) PB1(LDCW) PWORD(0) %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 %STRING(31) INITNAME %RECORD(LISTF)%NAME LCELL PUSH(LEVELINF, 0, NMAX<<16!N, 0); ! SAVE DETAIL OF CURRENT LEVEL %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 JROUND(LEVEL+1)=0 %START PLABEL=PLABEL-1 JROUND(LEVEL+1)=PLABEL ENTER JUMP(JMPW,PLABEL,0) %FINISH RLEVEL=RLEVEL+1; RBASE=RLEVEL %FINISH LEVEL=LEVEL+1 NMDECS(LEVEL)=0 NAMES(LEVEL)=-1 ONINF(LEVEL)=0; ONWORD(LEVEL)=0 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 ENTRYAD(RLEVEL)=CA %IF RTNAME<0 %THEN W3=0 %ELSE W3=RTNAME+1 L(LEVEL)=LINE; M(LEVEL)=W3 FLAG(LEVEL)=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 ! %IF AXNAME#0 %START %IF RTNAME>=0 %THEN INITNAME="S#INITGLA" %C %ELSE INITNAME="S#INITMAIN" PINITCALL(INITNAME) %FINISH %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 * !*********************************************************************** %IF KK>=0 %OR LEVEL=2 %START; ! DISPLAY NEEDED ! DONE BY THE QCODE CALL PSIZE(RLEVEL)=N; ! REMEMBER PARAMETER SIZE FOR RTDICT %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 PBW(LDDC,M'IA') PWORD(M'ID') DSTORE(4,RBASE,N) N=N+4 DIAGINF(RLEVEL)=N N=N+4 %FINISH DIAG POINTER(LEVEL) DSTORE(2,RBASE,DIAGINF(RLEVEL)) %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 CHECK STOF %FINISH %END %ROUTINE CHECK STOF !*********************************************************************** !* CHECK THE STACK FOR OVERFLOW. WORD 7 OF GLA HOLDS * !* THE ADDRESS OF A SYSTEM WORD HOLDING THE STACK LIMIT * !*********************************************************************** %IF PARM_OPT#0 %THEN %START ! ! L 1,28(GLA) GET ADDRESS ! LTR 1,1 CHECK FOR ZERO ! BC 8,*+12 AND OMIT THE CHECK ! C WSPR,0(1) ! BC 2,STACK OVERFLOW ! ! PPJ(2,8) %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) NMDECS(LEVEL)=NMDECS(LEVEL)!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(JMPW,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 FLAG(LEVEL)&X'3FFF'=X'1000' P=P+1 RET: PB1(RETURN) REPORT UI=1 CURR INST=1 %IF CODE=0 %RETURN SW(4): ! %RESULT(ASSOP)(EXPR) PTYPE=FLAG(LEVEL)&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,M(LEVEL)-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 PPJ(0,2); ! TO ERROR ROUTINE P=P+1; ->AUI SW(6): ! %STOP CSTOP 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,27,0,0); ! OPERATOR & PUSH(HEAD1,X'51'<<16!1,255,0); ! CONST=F'255' P=P+4; TORP(HEAD1,BOT1,NOPS) BINSERT(HEAD1,BOT1,23,0,0); ! OPERATOR ! NOPS=NOPS+2 %FINISH EXPOP(HEAD1,BOT1,NOPS,X'51'); ! EVALUATE %IF NMDECS(LEVEL)&16 #0 %START; ! IN AN 'ON' GROUP %IF FLAG(LEVEL)<=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(JMPW,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 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);! '%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'->'