CONSTSTRING (9) LADATE="28 NOV 83"; ! LAST ALTERED
CONSTINTEGER NO OF SNS=66
CONSTINTEGER LRLPT=X'62'
UNLESS HOST=PERQ OR HOST=ACCENT THEN START
CONSTINTEGER PTSHIFT=16,FLAGSHIFT=0
FINISH ELSE START
CONSTINTEGER PTSHIFT=0,FLAGSHIFT=16
FINISH
!
CONSTINTEGER MAXLEVELS=31,CONCOP=13
!
INCLUDE "ERCC07.TRIPCNSTS"
INCLUDE "ERCC07.TRIMP_TFORM1S"
CONSTINTEGER SNPT=X'1006'; ! SPECIALNAME PTYPE
CONSTINTEGER UNASSPAT=X'80808080'
CONSTINTEGER LABUSEDBIT=X'01000000'
CONSTINTEGER LABSETBIT=X'02000000'
CONSTINTEGER MAXDICT=X'100'; ! PARM MAXDICT BIT
!
INTEGER I, K, DUMMYFORMAT, P1SIZE, STARSIZE, ASL, ARSIZE, OLDLINE,
NEXTP, SNUM, RLEVEL, NMAX, PLABEL, LEVEL, PROFAAD, LAST INST,
LINE, BFFLAG, RBASE, N, EXITLAB, CONTLAB, Q, R, FNAME, STMTS,
FILE SIZE, BIMSTR, MAX ULAB, SFLABEL, NEXTTRIP
INTEGERNAME SSTL,USTPTR
STRING (31)MAINEP
!
EXTERNALINTEGERARRAY CAS(0:12)
EXTERNALRECORD (PARMF) PARM
EXTERNAL RECORD (WORKAF)WORKA
SYSTEMINTEGERMAPSPEC COMREG(INTEGER N)
CONSTINTEGER BYTESPERKFORSOURCE=256;! FRACTION OF KB IN WK FILE
! THATS IS ALLOCATE FOR SOURCE (&LPUT)
BEGIN
RECORD (EMASFHDRF)NAME SHDR,WHDR
WORKA_FILE ADDR=COMREG(46); ! SOURCE FILE IF CLEAN
PARM=0
PARM_BITS1=COMREG(27)
PARM_BITS2=COMREG(28)
WORKA_WKFILEAD=COMREG(14)
WHDR==RECORD(WORKA_WKFILEAD)
WORKA_WKFILEK=WHDR_FBYTESIZE>>10
IF WORKA_FILE ADDR<=0 THEN START
IF WORKA_FILE ADDR<-1 THEN FILESIZE=IMOD(WORKA_FILE ADDR) C
ELSE FILESIZE=64000
WORKA_FILE ADDR=0
FINISH ELSE START
SHDR==RECORD(WORKA_FILE ADDR)
FILE SIZE=SHDR_ENDRA
FINISH
WORKA_NNAMES=511
IF FILESIZE>32000 THEN WORKA_NNAMES=1023
IF FILESIZE>256*1024 OR PARM_BITS2&MAXDICT#0 OR WORKA_WKFILEK>512 C
THEN WORKA_NNAMES=2047
ASL=3*WORKA_NNAMES
IF ASL>4095 AND (HOST#EMAS OR PARM_BITS2&MAXDICT=0) THEN ASL=4095
WORKA_ASL MAX=ASL
ARSIZE=WORKA_WKFILEK*(1024-BYTESPERKFORSOURCE)-300
END
BYTEINTEGERARRAYFORMAT AF(0:ARSIZE)
BYTEINTEGERARRAYNAME A
RECORD (LISTF)ARRAY ASLIST(0:ASL)
INTEGERARRAY TAGS(0:WORKA_NNAMES)
INTEGERARRAY WORD(0:WORKA_NNAMES)
INTEGERARRAY DVHEADS(0:12)
RECORD (LEVELF)ARRAY LEVELINF(0:MAXLEVELS)
EXTERNALROUTINESPEC INITASL(RECORD (LISTF)ARRAYNAME A,INTEGERNAME B)
EXTERNALINTEGERFNSPEC MORE SPACE
!%EXTERNALINTEGERFNSPEC NEWCELL
EXTERNALROUTINESPEC INSERTATEND(INTEGERNAME S, INTEGER A, B, C)
EXTERNALROUTINESPEC INSERT AFTER(INTEGERNAME S,INTEGER A,B,C)
EXTERNALROUTINESPEC POP(INTEGERNAME C, P, Q, R)
EXTERNALROUTINESPEC PUSH(INTEGERNAME C, INTEGER S1, S2, S3)
EXTERNALINTEGERFNSPEC FIND(INTEGER LAB, LIST)
EXTERNALROUTINESPEC BINSERT(INTEGERNAME T,B,INTEGER S1,S2,S3)
EXTERNALROUTINESPEC CLEARLIST(INTEGERNAME HEAD)
EXTERNALROUTINESPEC FILL DTABREFS(INTEGERNAME HEAD)
EXTERNALROUTINESPEC CXREF(STRING (255)NAME,INTEGER MODE,XTRA,
INTEGERNAME AT)
EXTERNALROUTINESPEC IMPABORT
EXTERNALROUTINESPEC PROLOGUE(RECORD (LISTF)ARRAYNAME ALIST)
EXTERNALROUTINESPEC EPILOGUE(INTEGER STMTS)
EXTERNALROUTINESPEC PDATA(INTEGER AREA,BNDRY,L,AD)
EXTERNALROUTINESPEC PRDATA(INTEGER AREA,BNDRY,L,REP,AD)
EXTERNALINTEGERFNSPEC PINITOWN(INTEGER PTYPE,ACC,RECORD (RD)NAME INIT,
STRINGNAME XNAME)
EXTERNALINTEGERFNSPEC POWNARRAYHEAD(INTEGER PTYPE,J,LB,SIZE,
AOFFSET,AAREA,DVOFFSET,STRING (31) XNAME)
EXTERNALROUTINESPEC FAULT(INTEGER A,B,C)
EXTERNALROUTINESPEC WARN(INTEGER N,V)
EXTERNALROUTINESPEC TRIP OPT(RECORD (TRIPF)ARRAYNAME T, INTEGERNAME NEXT TRIP)
EXTERNALROUTINESPEC MOVE BYTES(INTEGER LENGTH,FBASE,FOFF,TOBASE,TOOFF)
EXTERNALROUTINESPEC CTOP(INTEGERNAME OP,MASK,INTEGER XTRA,
RECORD (RD)NAME OPND1,OPND2)
IF HOST#TARGET START
EXTERNALROUTINESPEC REFORMATC(RECORD (RD)NAME OPND)
EXTERNALROUTINESPEC CHANGE SEX(INTEGER BASEAD,OFFSET,L)
FINISH
EXTERNALROUTINESPEC GENERATE(RECORD (TRIPF)ARRAYNAME T,
INTEGER CURRLEVEL,ROUTINE GETWSP(INTEGERNAME PL,INTEGER SIZE))
EXTERNALROUTINESPEC PRINTLIST(INTEGER HEAD)
! START OF COMPILATION
K=BYTESPERKFORSOURCE//(HOST//10); ! DISTINGUISH BYTE&WORD ADDRESSED HOSTS
! ALLOW FOR BYTE & WORD ADDRESS M-CS
A==ARRAY(WORKA_WKFILE AD+K*WORKA_WKFILEK, AF)
BEGIN
!***********************************************************************
!* THIS BLOCK INITIALISE THE COMPILER SCALARS AND ARRAYS *
!* WAS ORIGINALLY ROUTINE 'INITIALISE'. *
!* THE INITIALISATION OF THE CONSTANT LISTS WITH THE VALUES *
!* IN PERM MAY BE OMITTED IN BATCH OR CUT-DOWN VERSIONS. *
!***********************************************************************
EXTERNALINTEGERFNSPEC PASSONE
WORKA_CCSIZE=BYTESPERKFORSOURCE*(WORKA_WKFILEK-1);! CCSIZE ALWAYS AS BYTES
BYTEINTEGERARRAYFORMAT CCF(0:WORKA_CCSIZE)
BYTEINTEGERARRAYNAME CC
CC==ARRAY(WORKA_WKFILEAD+32,CCF)
WORKA_CC==CC
WORKA_A==A
WORKA_WORD==WORD
WORKA_TAGS==TAGS
WORKA_LINE==LINE
WORKA_RELEASE=RELEASE
WORKA_LADATE=LADATE
WORKA_AASL0=ADDR(ASLIST(0))
WORKA_AMAINEP=ADDR(MAINEP)
WORKA_LASTTRIP=WORKA_CCSIZE//40 -2; ! 40 IS SIZE OF THE TRIP ARRAY
IF WORKA_LASTTRIP>699 THEN WORKA_LASTTRIP=699
PLABEL=24999
N=12;
MAX ULAB=WORKA_NNAMES+16384; ! LARGEST VALID USER LABEL
LAST INST=0
SFLABEL=20999
EXITLAB=0; CONTLAB=0
RLEVEL=0; NMAX=0; BFFLAG=0
RBASE=1
SSTL==CAS(4); USTPTR==CAS(5)
STMTS=1; SNUM=0
BIMSTR=0
WORKA_RTCOUNT=1; ! ROUTINE 0 RESERVED FOR MAIN PROG
MAINEP="s#go"; ! DEFAULT MAIN ENTRY
INITASL(ASLIST,ASL)
CYCLE I=0,1,12
CAS(I)=0; DVHEADS(I)=0
REPEAT
!
DUMMY FORMAT=0; ! DUMMY RECORD FORMAT
PUSH(DUMMY FORMAT,0,0,0); ! FOR BETTER ERROR RECOVERY
P1SIZE=PASSONE
R=P1SIZE
WORKA_ARTOP=P1SIZE
END ; ! OF BLOCK CONTAINING PASS 1
BEGIN
!***********************************************************************
!* SECOND OR TRIPLES GENERATING PASS *
!***********************************************************************
RECORD (LEVELF)NAME CURRINF
INTEGER TWSPHEAD
IF HOST=EMAS OR HOST=IBM OR HOST=IBMXA START ; ! LPUT BASED WORKFILE USED FOR OBJECT
RECORD (TRIPF)ARRAY TRIPLES(0:WORKA_LASTTRIP)
FINISH ELSE START
RECORD (TRIPF)ARRAYFORMAT TRIPLESFORM(0:WORKA_LASTTRIP)
RECORD (TRIPF)ARRAYNAME TRIPLES
TRIPLES==ARRAY(WORKA_WKFILEAD+32,TRIPLESFORM)
FINISH
INTEGERARRAYFORMAT CF(0:12*WORKA_NNAMES)
INTEGERARRAYNAME CTABLE
!%ROUTINESPEC NOTE CREF(%INTEGER CA)
!%ROUTINESPEC STORE CONST(%INTEGERNAME D,%INTEGER L,AD)
!%INTEGERFNSPEC WORD CONST(%INTEGER VALUE)
ROUTINESPEC REUSE TEMPS
ROUTINESPEC GET WSP(INTEGERNAME PLACE,INTEGER SIZE)
ROUTINESPEC RETURN WSP(INTEGER PLACE,SIZE)
ROUTINESPEC COMPILE A STMNT
INTEGERFNSPEC NEW TRIP
INTEGERFNSPEC FROMAR4(INTEGER PTR)
INTEGERFNSPEC FROMAR2(INTEGER PTR)
INTEGERFNSPEC UCONSTTRIP(INTEGER OPERN,OPTYPE,FLAGS,CONST)
INTEGERFNSPEC ULCONSTTRIP(INTEGER OPERN,OPTYPE,FLAGS,CONST1,CONST2)
INTEGERFNSPEC UNAMETRIP(INTEGER OPERN,OPTYPE,FLAGS,NAME)
INTEGERFNSPEC UTEMPTRIP(INTEGER OPERN,OPTYPE,FLAGS,TEMP)
INTEGERFNSPEC BRECTRIP(INTEGER OPERN,OPTYPE,FLAGS,
RECORD (RD)NAME OPND1,OPND2)
INTEGERFNSPEC URECTRIP(INTEGER OPERN,OPTYPE,FLAG,RECORD (RD)NAME OPND1)
ROUTINESPEC KEEPUSECOUNT(RECORD (RD)NAME OPND)
ROUTINESPEC CSS(INTEGER P)
CYCLE I=0, 1, MAXLEVELS
LEVELINF(I)=0
LEVELINF(I)_NAMES=-1
REPEAT
CTABLE==ARRAY(ADDR(ASLIST(1)),CF)
WORKA_CTABLE==CTABLE
WORKA_LEVELINF==LEVELINF
CTABLE(0)=M'CTAB'
LINE=0
TWSPHEAD=0
PROLOGUE(ASLIST)
NEXTTRIP=1
TRIPLES(0)=0
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
EPILOGUE(STMTS)
IF HOST=PERQ START
*RETURN; ! JUMP WONT REACH!
FINISH ELSE ->P2END
ROUTINE FORCE TRIPS
!***********************************************************************
!* FORCE OUT THE TRIPLES TO CODE. NEEDED IN CEND ETC *
!***********************************************************************
RETURN IF NEXT TRIP=1
IF PARM_OPT=0 THEN TRIP OPT(TRIPLES,NEXT TRIP)
GENERATE(TRIPLES,LEVEL,GET WSP)
TRIPLES(0)=0
NEXTTRIP=1
TRIPLES(0)_FLINK=NEXT TRIP
END
ROUTINE COMPILE A STMNT
INTEGER I
FORCE TRIPS IF NEXT TRIP>1
IF TWSPHEAD#0 THEN REUSE TEMPS
I=NEXTP
STARSIZE=A(NEXTP)<<16+A(NEXTP+1)<<8+A(NEXTP+2)
NEXTP=NEXTP+STARSIZE
LINE=A(I+3)<<8+A(I+4)
STMTS=STMTS+1
CSS(I+5)
! %CYCLE I=0,1,4
! %REPEAT
! CHECK ASL %IF LINE&7=0
END
ROUTINE CSS(INTEGER P)
ROUTINESPEC ENTER JUMP(INTEGER MASK,STAD,FLAG)
INTEGERFNSPEC ENTER LAB(INTEGER M,FLAG)
ROUTINESPEC REMOVE LAB(INTEGER LAB)
ROUTINESPEC SAVE STACK PTR
ROUTINESPEC CEND(INTEGER KKK)
INTEGERFNSPEC CCOND(INTEGER CTO,A,B,JFLAGS)
INTEGERFNSPEC REVERSE(INTEGER MASK)
ROUTINESPEC SET LINE
ROUTINESPEC CUI(INTEGER CODE)
ROUTINESPEC ASSIGN(INTEGER A,B)
ROUTINESPEC CSTART(INTEGER CCRES,MODE)
INTEGERFNSPEC CHECKBLOCK(INTEGER P,PIN)
ROUTINESPEC CCYCBODY(INTEGER UA,ELAB,CLAB)
ROUTINESPEC CLOOP(INTEGER ALT,MARKC,MARKUI)
ROUTINESPEC CIFTHEN(INTEGER MARKIU,MARKC,MARKUI,MARKE,MARKR,SKIP)
INTEGERFNSPEC CREATE AH(INTEGER MODE,RECORD (RD)NAME EOPND,NOPND)
ROUTINESPEC TORP(INTEGERNAME HEAD,BOT,NOPS)
INTEGERFNSPEC INTEXP(INTEGERNAME VALUE,INTEGER PRECTYPE)
INTEGERFNSPEC CONSTEXP(INTEGER PRECTYPE)
ROUTINESPEC CSEXP(INTEGER MODE)
ROUTINESPEC CSTREXP(INTEGER B)
ROUTINESPEC CRES(INTEGER LAB)
ROUTINESPEC EXPOP(INTEGERNAME A,B,INTEGER C,D)
ROUTINESPEC TEST APP(INTEGERNAME NUM)
ROUTINESPEC SKIP EXP
ROUTINESPEC SKIP APP
ROUTINESPEC NO APP
INTEGERFNSPEC DOPE VECTOR(INTEGER A,B,MODE,ID,INTEGERNAME C,D)
ROUTINESPEC DECLARE ARRAYS(INTEGER A,B)
ROUTINESPEC DECLARE SCALARS(INTEGER B)
ROUTINESPEC CRSPEC(INTEGER M)
INTEGERFNSPEC SET SWITCHLAB(INTEGER HEAD,LAB,FNAME,BIT)
ROUTINESPEC CFPLIST(INTEGERNAME A,B)
ROUTINESPEC CFPDEL
ROUTINESPEC CLT
INTEGERFNSPEC ROUNDING LENGTH(INTEGER PTYPE,RULES)
ROUTINESPEC CQN(INTEGER P)
INTEGERFNSPEC TSEXP(INTEGERNAME VALUE)
ROUTINESPEC CRCALL(INTEGER RTNAME)
ROUTINESPEC NAMEOP(INTEGER Z,SIZE,NAMEP)
ROUTINESPEC CNAME(INTEGER Z)
ROUTINESPEC 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,LEVEL,RBASE,J,SNDISP,ACC,SLINK,KFORM)
ROUTINESPEC UNPACK
ROUTINESPEC PACK(INTEGERNAME PTYPE)
ROUTINESPEC RDISPLAY(INTEGER KK)
ROUTINESPEC RHEAD(INTEGER RTNAME,AXNAME)
INTEGERFNSPEC CFORMATREF
ROUTINESPEC CRFORMAT(INTEGERNAME OPHEAD,OPBOT,NLIST,MRL,INTEGER INIT)
INTEGERFNSPEC DISPLACEMENT(INTEGER LINK)
INTEGERFNSPEC COPY RECORD TAG(INTEGERNAME SUBS)
SWITCH SW(1:24)
CONSTBYTEINTEGERARRAY FCOMP(0:14)=0,
8,10,2,7,12,4,7,
8,12,4,7,10,2,7;
INTEGER SNDISP,ACC,K,KFORM,STNAME,MIDCELL
INTEGER TCELL,JJ,JJJ,KK,QQ,MARKER,REPORTUI,XDISP,MASK, C
BASE,AREA,ACCESS,DISP,EXTRN, CURR INST,VALUE,STRINGL, C
PTYPE,I,J,OLDI,USEBITS,STRFNRES,BML,DML, C
MARKIU,MARKUI,MARKC,MARKE,MARKR,INAFORMAT
INTEGER LITL,ROUT,NAM,ARR,PREC,TYPE
RECORD (RD) EXPOPND,NAMEOPND; ! RESULT RECORD FOR EXPOP&CNAME
CURR INST=0; INAFORMAT=0
->SW(A(P))
SW(13): ! INCLUDE SOMETHING
SW(24): ! REDUNDANT SEP
SW(2): ! <CMARK> <COMMENT TEXT>
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)
PARM_DCOMP=J>>28; ->CSSEXIT
!
SW(3): ! (%IU)(COND)%THEN(UI)(ELSE')
MARKIU=P+1; MARKC=MARKIU+3
MARKR=P+2+A(P+2)<<8+A(P+3); ! ! FROMAR2(P+2)
MARKE=0
IF A(MARKR)=3 THEN START
MARKE=MARKR+1+FROMAR2(MARKR+1)
MARKUI=MARKR+3
FINISH
CIFTHEN(MARKIU,MARKC,MARKUI,MARKE,MARKR,NO)
->CSSEXIT
SW(4):
! '%FINISH(ELSE')(S)
SW(18):
! '%ELSE' MEANING FINISH ELSE START
->CSSEXIT
SWITCH: BEGIN ; ! SWITCH LABEL
INTEGER NAPS,FNAME
FNAME=FROM AR2(P+3)
UNLESS A(P)=1 AND A(P+5)=1 THEN FAULT(5,0,FNAME) AND ->BEND
! 1ST OF UI + APP
P=P+3; TEST APP(NAPS)
P=P+6
UNLESS INTEXP(JJ,MINAPT)=0 THEN FAULT(41,0,0) AND ->BEND
! UNLESS EXPRESSION EVALUATES AND
UNLESS NAPS=1 THEN FAULT(21,NAPS-1,FNAME) AND ->BEND
! NO REST OF APP
UNLESS A(P+1)=2=A(P+2) THEN FAULT(5,0,FNAME) AND ->BEND
! NO ENAME OR REST OF ASSIGMENT
COPY TAG(FNAME)
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
RECORD (LISTF)NAME LCELL
INTEGER FNAME,JJ,RES
FNAME=FROM AR2(P+1)
COPY TAG (FNAME)
IF OLDI=LEVEL AND TYPE=6 START
LCELL==ASLIST(K)
CYCLE JJ=LCELL_S2,1,LCELL_S3
RES=SET SWITCHLAB(K,JJ,FNAME,0)
REPEAT
FINISH ELSE FAULT(4,0,FNAME)
END ; ->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(KFORM)
FINISH
->CSSEXIT
!
SW(9): ! %END
BEGIN
SWITCH S(1:5)
-> S(A(P+1))
S(1): ! ENDOFPROGRAM
S(2): ! ENDOFFILE
IF PARM_CPRMODE=0 THEN PARM_CPRMODE=2
FAULT(15,LEVEL+PARM_CPRMODE-3,0) UNLESS LEVEL+PARM_CPRMODE=3
CEND(PARM_CPRMODE)
->BEND
S(3): ! ENDOFLIST
->BEND
S(4): ! END
IF PARM_CPRMODE=1 AND LEVEL=2 THEN FAULT(14,0,0) ELSE C
CEND(CURRINF_FLAG)
BEND: END
->CSSEXIT
!
SW(11):
BEGIN
INTEGER MARKER1,RTNAME,KKK,PTR,PTYPEP,CNT,PP,PCHAIN,AXNAME,PNAME,
NPARAMS,SCHAIN,PARMSPACE,D
RECORD (LISTF)NAME LCELL,TCELL
P=P+1; MARKER1=FROM AR2(P)+P; ! (SEX)(RT)(SPEC')(NAME)(FPP)
AGN: Q=P; RTNAME=FROM AR2(MARKER1+1); ! RTNAME ON NAME
EXTRN=A(P+2); ! 1=SYSTEM,2=EXTERNAL
! 3=DYNAMIC, 4=INTERNAL
LITL=EXTRN&3
IF A(MARKER1)=1 THEN START ; ! P<%SPEC'>='%SPEC'
P=P+3; CRSPEC(1-EXTRN>>2); ! 0 FOR ROUTINESPEC
! 1 FOR EXTERNAL (ETC) SPEC
->BEND
FINISH
COPY TAG(RTNAME)
AXNAME=ADDR(WORKA_LETT(WORD(RTNAME)))
IF EXTRN=3 THEN EXTRN=2
IF TARGET=EMAS AND EXTRN=1 THEN WARN(11,0)
IF A(MARKER1+3)=1 THEN START
MOVE BYTES(A(MARKER1+4)+1,ADDR(A(0)),MARKER1+4,
ADDR(A(0)),WORKA_ARTOP)
AXNAME=ADDR(A(WORKA_ARTOP))
WORKA_ARTOP=(WORKA_ARTOP+3+A(MARKER1+4))&(-4)
FINISH
IF EXTRN=4 THEN AXNAME=0
IF OLDI#LEVEL THEN START ; ! NAME NOT KNOWN AT THIS LEVEL
P=Q+3; CRSPEC(0); P=Q; ->AGN
FINISH ELSE START ; ! NAME ALREADY KNOWN AT THIS LEVEL
IF PARM_CPRMODE=0 THEN PARM_CPRMODE=2; ! FLAG AS FILE OF ROUTINES
FAULT(56,0,RTNAME) UNLESS EXTRN=4 OR C
(PARM_CPRMODE=2 AND LEVEL=1)
IF A(P+3)=1 THEN KKK=LITL<<14!X'1000' ELSE START
ROUT=1; P=P+4; ! FIGURE OUT PTYPE FOR FNS&MAPS
CLT; ARR=0; NAM=0
IF A(P)=2 THEN NAM=2; ! SET NAME ARRAY BIT FOR MAPS
PACK(KKK); ! AND STORE PTYPE IN KKK
FINISH
FINISH
!
! UNLESS A MATCH WAS OBTAINED BETWEEN HEADING AND SPEC SOMETHING
! HAS GONE WRONG. COMPILE HEADING AGAIN AS SPEC. THIS WILL
! PREVENT ANY INCONSISTENCIED AND CAUSE A "NAME SET TWICE"
! FOR ANY ERROR
!
UNLESS (J=15 OR J=7*EXTRN) AND PTYPE&X'FFFF'=KKK START
P=Q+3; CRSPEC(0); P=Q; ->AGN
FINISH
PTYPE=PTYPE!(EXTRN&3)<<14; ! DEAL WITH %ROUTINESPEC FOLLOWED
! BY %EXTERNALROUTINE
!
! RESET THE TAGS TO BODY GIVEN AND ALLOWING FOR SPEC/EXTERNALROUTINE
! AND EXTERNALSPEC/EXTERNAL ROUTINE COMBINATIONS. RESTORE THE USE
! BITS WHICH WILL SHOW USED AS A RESULT OF THE COPYTAG IN THIS SEQUENCE
!
TCELL==ASLIST(TAGS(RTNAME))
TCELL_PTYPE<-PTYPE
TCELL_UIOJ<-TCELL_UIOJ&X'3FF0'!USEBITS<<14
! NEWPTYPE & SET J=0
IF J=14 THEN TCELL_S2=WORKA_RTCOUNT AND C
WORKA_RTCOUNT=WORKA_RTCOUNT+1; ! NO RT NO ALLOCATED TO EXTERNAL SPECS
PTYPEP=PTYPE
PCHAIN=TCELL_SLINK; ! CHAIN OF PARAMETER DESCRIPTUONS
RHEAD(RTNAME,AXNAME); ! FIRST PART OF ENTRY SEQUENCE
!
! NOW DECLARE THE FORMAL PARAMETERS. FOLLOW BY CLAIMING DISPLAY
! AND SETTING DIAGNOSTIC PTR IN ROUTINE RDISPLAY
!
P=MARKER1+4
IF A(P-1)=1 THEN P=P+A(P)+1; ! SKIP OVER ALIASNAME
CNT=0
PTYPE=PTYPEP; UNPACK
N=RTPARAM1OFFSET
IF TARGET=PERQ OR TARGET=ACCENT START
IF TYPE#0 THEN N=(BYTES(PREC)+1)&(-2)
IF NAM#0 OR TYPE=5 THEN N=4; ! MAPS
CURRINF_RESSIZE=N
FINISH
NPARAMS=0; PARMSPACE=0
IF PCHAIN#0 THEN NPARAMS=ASLIST(PCHAIN)_S3
IF NPARAMS#0 THEN PARMSPACE=NPARAMS>>16 AND NPARAMS=NPARAMS&X'FFFF'
! ALLOW ACTUAL PARAMETER SPACE
WHILE A(P)=1 CYCLE ; ! WHILE SOME (MORE) FP PART
PP=P+1+FROMAR2(P+1)
P=P+3
CFPDEL
PTR=P
UNTIL A(PTR-1)=2 CYCLE ; ! CYCLE DOWN NAMELIST
IF PARAMS BWARDS=YES START ;! MAP PCHAIN TO REVERSE ORDER LIST
PCHAIN=TCELL_SLINK
PCHAIN=ASLIST(PCHAIN)_LINK FOR KKK=2,1,NPARAMS-CNT
FINISH
IF PCHAIN#0 THEN START
LCELL==ASLIST(PCHAIN); ! EXTRACT PTYPE XTRA INFO
UNLESS LCELL_PTYPE=PTYPE AND LCELL_ACC=ACC C
THEN FAULT(9,CNT+1,RTNAME)
FINISH
PNAME=FROM AR2(PTR); ! NAME FOR PARAM INTERNALLY
LCELL_UIOJ=LCELL_UIOJ!PNAME<<4;! SAVED IN LIST
D=LCELL_SNDISP+N; ! PARAMETER OFFSET
IF ROUT=1 START ; ! PROCEDURE PARAMETERS
P=PTR
P=P+3 UNTIL A(P-1)=2
CFPLIST(SCHAIN,KKK); ! PARAMETERLIST FOR PASSED PROC
PTYPE=LCELL_PTYPE; ! CHANGED BY CFPLIST
STORETAG(PNAME,LEVEL,RBASE,13,D,LCELL_ACC,SCHAIN,0)
FINISH ELSE START
IF TARGET=EMAS AND PTYPE=X'33' C
THEN D=D+8; ! FOR HISTORIC PARAMTER COMPATABILITY
IF STRVALINWA=YES AND PTYPE=X'35' THEN PTYPE=X'435'
STORE TAG(PNAME,LEVEL,RBASE,LCELL_UIOJ&15,0,ACC,D,KFORM)
IF STRVALINWA=YES AND PTYPE=X'435' THEN PTYPE=LCELL_PTYPE
FINISH
PTR=PTR+3
CNT=CNT+1
PCHAIN=LCELL_LINK IF PARAMS BWARDS=NO
REPEAT
P=PP
REPEAT ; ! UNTIL NO MORE FP-PART
N=N+PARMSPACE
N=(N+MINPARAMSIZE-1)&(-MINPARAMSIZE);! TO WORD BOUNDARY AFTER ALL SYSTEM
! STANDARD PARAMETERS HAVE BEEN DECLARED
FAULT(8,0,RTNAME) IF CNT>NPARAMS
FAULT(10,0,RTNAME) IF CNT<NPARAMS
PTYPE=PTYPEP
IF STRRESINWA=YES START ; ! NEEDS FN RESULT DESC
UNLESS 3#PTYPE&X'F0F'#5 THEN N=N+PTRSIZE(X'35'); ! STR FNS RESULT PARAM IS STACKED
CURRINF_RESSIZE=N
FINISH
IF TARGET=PNX THEN START
N=N+8; ! SPACE FOR PC&OLDLNB
IMPABORT IF N&7#0
FINISH
! 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
PARM_CPRMODE=1
RHEAD(-1,ADDR(MAINEP))
N=RTPARAM1OFFSET
FINISH ELSE FAULT(58,0,0)
FINISH ELSE START
SET LINE; ! SO 'ENTERED FROM LINE' IS OK
RHEAD(-1,0)
FINISH
RDISPLAY(-1)
END
->CSSEXIT
!
SW(15):
! '%ON'(EVENT')(N)(NLIST)'%START'
FAULT(57,0,0) UNLESS LEVEL>=2
FAULT(40,0,0) IF CURRINF_NMDECS&1#0
CURRINF_NMDECS=CURRINF_NMDECS!X'11';! NO MORE DECS AND IN ONCOND
IF TARGET=EMAS THEN SAVE STACK PTR;! NEEDED WITH AUXSTACKS ONLY
JJ=UCONSTTRIP(ONEV1,X'51',DONTOPT,0);! SAVE PROGRAM MASK ETC
PLABEL=PLABEL-1
JJJ=PLABEL
ENTER JUMP(15,JJJ,B'10'); ! JUMP ROUND ON BODY
!
P=P+1; JJ=0; ! SET UP A BITMASK IN JJ
UNTIL A(P)=2 CYCLE ; ! UNTIL NO MORE NLIST
KK=-1; P=P+4
FAULT(26,KK,0) UNLESS INTEXP(KK,MINAPT)=0 AND 1<=KK<=14
JJ=JJ!1<<(KK-1)
REPEAT
P=P+1
CURRINF_ONWORD=JJ<<18
LEVELINF(0)_ONWORD=LEVELINF(0)_ONWORD!JJ<<18
CURRINF_ONINF=N; N=N+12
JJ=UCONSTTRIP(ONEV2,X'51',DONTOPT,JJ)
OLDLINE=0
CSTART(0,3)
CURRINF_NMDECS=CURRINF_NMDECS!!X'10';! NOT IN ONCOND
JJ=ENTER LAB(JJJ,B'111'); ! REPLACE ENVIRONMENT
->CSSEXIT
SW(16):
BEGIN ; ! %SWITCH (SWITCH LIST)
INTEGER Q,RANGE,KKK,LB,UB,PP,D0,OPHEAD,V,R
RECORD (RD) OPND1,OPND2
FAULT(57,0,0) UNLESS LEVEL>=2
Q=P
UNLESS TARGET=EMAS THEN PLABEL=PLABEL-1 AND ENTER JUMP(15,PLABEL,0)
UNTIL A(Q)=2 CYCLE ; ! UNTIL NO'REST OF SW LIST'
P=P+3
P=P+3 WHILE A(P)=1
P=P+4; ! TO P(+')
KKK=INTEXP(LB,MINAPT); ! EXTRACT LOWER BOUND
P=P+3
KKK=KKK!INTEXP(UB,MINAPT); ! EXTRACT UPPER BOUND
RANGE=(UB-LB+1)
IF RANGE<=0 OR KKK#0 START
FAULT(38,1-RANGE,FROMAR2(Q+1))
LB=0; UB=10; RANGE=11
FINISH
PTYPE=X'56'+1<<8; ! WORD LABEL ARRAY
PP=P; P=Q+1
UNTIL A(P-1)=2 CYCLE ; ! DOWN NAMELIST
K=FROM AR2(P)
P=P+3
OPHEAD=0; R=LB
!
! SET UP A BIT LIST (96 BITS PER CELL) TO CHECK FOR SWITCH LABELS
! SET TWICE
!
UNTIL R>UB CYCLE
PUSH(OPHEAD,0,0,0)
R=R+96
REPEAT
OPND1_S1=PTYPE<<PTSHIFT!DNAME<<FLAGSHIFT
OPND1_D=K
OPND1_XTRA=0
OPND2_S1=X'61'<<PTSHIFT!DNAME<<FLAGSHIFT
OPND2_D=LB
OPND2_XTRA=UB
V=BRECTRIP(DCLSW,PTYPE,0,OPND1,OPND2)
PUSH(OPHEAD,0,LB,UB)
STORE TAG(K,LEVEL,RBASE,1,0,4,OPHEAD,0)
!
!THE TABLE WILL CONSIST OF RELATIVE DISPLACEMENTS FROM EACH ENTRY
! TO THE LABEL POSN. SET ALL TO GO TO PLAB(6) INITIALLY
!
REPEAT ; ! FOR ANY MORE NAMES IN NAMELIST
Q=PP; P=Q
REPEAT ; ! UNTIL A(Q)=2
UNLESS TARGET=EMAS THEN KKK=ENTER LAB(PLABEL,0);! COMPLETE JUMP AROUND TABLE
END ;->CSSEXIT
!
SW(17): ->CSSEXIT
!
SW(12): ! '%OWN' (TYPE)(OWNDEC)
BEGIN
!***********************************************************************
!* INITIALISED DECLARATION GO INTO THE GLA OR GLA SYMBOL TABLES *
!* EXCEPT FOR CONST ARRAYS WHICH GO INTO THE CODE SYMBOL TABLES *
!* STRINGS AND ARRAYS HAVE A HEADER IN THE GLA. QPUT ARRANGES *
!* FOR THE LOADER TO RELOCATE THE HEADERS. *
!* EXTERNALS ARE IDENTICAL WITH OWN BUT ALSO HAVE A DATA EP DEFN *
!* IN THE LOAD DATA SO THEY CAN BE FOUND AT LOAD TIME *
!* EXTRINSICS HAVE A DATA REFERENCE AND A DUMMY HEADER IN THE GLA*
!* THE LOADER USES THE FORMER TO RELOCATE THE LATTER. *
!***********************************************************************
ROUTINESPEC CLEAR(INTEGER L)
ROUTINESPEC XTRACT CONST(INTEGER CONTYPE, CONPREC)
ROUTINESPEC INIT SPACE(INTEGER A, B)
INTEGER SLENGTH, PP, SIGN, TAGDISP, DVO, K,
STALLOC, SPOINT, CONSTSFOUND, CPREC, EXTRN, NNAMES, C
MARK, QPUTP, LB, CTYPE, CONSTP, FORMAT,DPTYPE, C
DIMEN, SACC, TYPEP, KK
RECORD (RD) COPND,FCOPND
OWNLONGREAL ZERO=0
STRING (255) SCONST, NAMTXT
RECORD (LISTF)NAME LCELL
INTEGERNAME STPTR
QPUTP=5; STPTR==USTPTR; ! NORMAL CASE GLA SYMBOLTABLES
! FAULT(40,0,0) %IF NMDECS&1#0
EXTRN=A(P+1)
P=P+2
IF EXTRN>=4 THEN EXTRN=0; ! CONST & CONSTANT->0
SNDISP=0
CONSTS FOUND=0
IF EXTRN=0 THEN QPUTP=4 AND STPTR==SSTL
CLT
!
! CHECK FOR %SPEC AND CHANGE EXTERNAL SPEC TO EXTRINSIC
!
IF A(P+2)=1 START
IF EXTRN=2 THEN EXTRN=3 ELSE FAULT(46,0,0)
FINISH
IF 2<=EXTRN<=3 AND ((A(P)=1 AND A(P+1)#3) OR C
(A(P)=2 AND A(P+1)#2)) THEN FAULT(46,0,0)
LITL=EXTRN
IF LITL<=1 THEN LITL=LITL!!1
IF A(P)=1 THEN CQN(P+1) ELSE ARR=1 AND NAM=0
IF TYPE=5 AND NAM=0 AND (ACC<=0 OR ACC>256) THEN C
FAULT(70,ACC-1,0) AND ACC=2
STALLOC=ACC; ! ALLOCATION OF STORE FOR ITEM OR POINTER
IF (TARGET=PERQ OR TARGET=ACCENT OR TARGET=PNX) AND TYPE=5 THEN C
STALLOC=(STALLOC+1)&X'FFE'
ROUT=0; PACK(PTYPE); DPTYPE=PTYPE;! FOR DECLARATION
IF NAM#0 START ; ! OWN POINTERS
IF ARR#0 THEN STALLOC=8 ELSE STALLOC=4
FINISH ELSE START ; ! OWN VARS & ARRAYS
->NON SCALAR IF ARR#0
FINISH
P=P+2
UNTIL A(MARK)=2 CYCLE ; ! UNTIL <RESTOFOWNDEC> NULL
MARK=P+1+FROM AR2(P+1)
PP=P+3; P=PP+2; ! PP ON FIRST NAME'
K=FROM AR2(PP); ! FOR ERROR MESSAGES RE CONST
NAMTXT=STRING(ADDR(WORKA_LETT(WORD(K))))
IF A(P)=1 THEN START ; ! ALAIS GIVEN
IF LITL=0 THEN WARN(10,0)
LENGTH(NAMTXT)=A(P+1)
CHARNO(NAMTXT,KK)=A(P+KK+1) FOR KK=1,1,A(P+1)
P=P+A(P+1)+1
FINISH
P=P+1; ! P ON CONST'
!
! OBTAIN THE INITIAL CONSTANT,ITS TYPE(CTYPE) AND SIGN(SIGN)
!
SCONST=""
PTYPE=DPTYPE; UNPACK; ! MAY HAVE BEEN CONSTANT EVALUATIONS
! WHICH HAVE CHANGED PTYPE
SIGN=3; CTYPE=TYPE; CONSTSFOUND=0; CPREC=PREC
IF TYPE=3 THEN CTYPE=1; ! RECS INITTED TO REPEATED BYTE
IF NAM#0 THEN CTYPE=1 AND CPREC=5
P=P+1
IF A(P-1)=1 THEN START ; ! CONSTANT GIVEN
XTRACT CONST(CTYPE,CPREC)
FINISH ELSE START
WARN(7,K) IF EXTRN=0; ! %CONST NOT INITIALISED
FCOPND=0; COPND=0
FINISH
J=0
IF NAM#0 THEN START ; ! OWNNAMES AND ARRAYNAMES
IF ARR=0 THEN START
TAGDISP=PINITOWN(PTYPE,ACC,FCOPND,NAMTXT)
FINISH ELSE START ; ! ARRAYNAMES
DVO=DOPE VECTOR(TYPE,ACC,-1,K,QQ,LB)
IF PARM_COMPILER#0 AND LB#0 THEN FAULT(99,0,0)
IF EXTRN#0 THEN SNDISP=0 AND J=0 ELSE C
J=1 AND SNDISP=(SNDISP&X'3FFFF')>>2
TAGDISP=POWNARRAYHEAD(PTYPE,J,LB,X'FFFFFF',
FCOPND_D,0,DVO,NAMTXT)
FINISH
STORE TAG(K,LEVEL,0,J,SNDISP,ACC,TAGDISP,KFORM)
P=MARK
CONTINUE
FINISH
IF EXTRN=3 THEN START ; ! EXTRINISIC
PTYPE=PTYPE!X'400'; ! FORCE NAM=1 (IE VIA POINTER)
FCOPND_D=0
TAGDISP=PINITOWN(PTYPE,ACC,FCOPND,NAMTXT)
STORE TAG(K,LEVEL,0,J,SNDISP,ACC,TAGDISP,KFORM)
P=MARK
CONTINUE
FINISH
IF TYPE=3 THEN START ; ! RECORDS
TAGDISP=PINITOWN(PTYPE,ACC,COPND,NAMTXT)
FINISH
IF 1<<TYPE&B'100110'#0 START ; ! INTEGER & REAL & STRING
IF EXTRN#0 THEN START
TAGDISP=PINITOWN(PTYPE,ACC,COPND,NAMTXT)
FINISH ELSE TAGDISP=0
FINISH
STORE TAG(K,LEVEL,0,J,SNDISP,ACC,TAGDISP,KFORM)
IF EXTRN=0=NAM AND 1<<TYPE&B'100110'#0 START ;! CONST = LITERAL
LCELL==ASLIST(TAGS(K))
LCELL_S2=COPND_D
LCELL_S3=COPND_XTRA
IF TYPE=5 THEN START
LCELL_S2=WORKA_ARTOP
WORKA_ARTOP=(WORKA_ARTOP+COPND_XTRA+4)&(-4)
FINISH
FINISH
P=MARK
REPEAT
->BEND
NONSCALAR: ! OWN AND OWNRECORD ARRAYS
!***********************************************************************
!* OWN ARRAYS CAN BE INITIALISED BUT ONLY ONE ARRAY CAN BE *
!* DECLARED IN A STATEMENT.(THANK HEAVENS!) *
!* OWN RECORD ARRAYS ARE INITIALISED AS BYTE ARRAYS *
!***********************************************************************
P=P+1
FORMAT=2-A(P)
IF FORMAT#0 THEN ARR=3 AND PACK(PTYPE)
PP=P+2; P=P+4; NNAMES=1
K=FROM AR2(PP)
NAMTXT=STRING(ADDR(WORKA_LETT(WORD(K))))
IF A(P)=1 THEN START ; ! ALAIS GIVEN
IF LITL=0 THEN WARN(10,0)
LENGTH(NAMTXT)=A(P+1)
CHARNO(NAMTXT,KK)=A(P+KK+1) FOR KK=1,1,A(P+1)
P=P+A(P+1)+1
FINISH
P=P+1; ! P ON CONSTLIST
SACC=ACC; TYPEP=PTYPE
DVO=DOPE VECTOR(TYPE,STALLOC,0,K,QQ,LB)
IF SNDISP=-1 THEN SNDISP=0; ! BUM DOPE VECTOR
SNDISP=(SNDISP&X'3FFFF')>>2; ! AS WORD DISPLACEMENT
DIMEN=J; ! SAVE NO OF DIMENESIONS
ACC=SACC; PTYPE=TYPEP; UNPACK
IF LB=0 AND FORMAT=0 THEN ARR=2 AND PACK(PTYPE)
IF TYPE=3 THEN SLENGTH=QQ ELSE SLENGTH=QQ//STALLOC;! NO OF ELEMENTS
SPOINT=STPTR
IF FORMAT=0 THEN START
IF A(P)=1 THEN P=P+1 AND INIT SPACE(QQ,SLENGTH)
FINISH
IF CONSTS FOUND=0 THEN START ; ! NO CONSTANTS GIVEN
! SO CLEAR AN AREA TO ZERO
CONSTS FOUND=SLENGTH
CLEAR(QQ) UNLESS SLENGTH<1 OR EXTRN=3 OR FORMAT#0
FINISH ELSE START
FAULT(49,0,K) IF EXTRN=3 OR FORMAT#0
FINISH
IF EXTRN=3 THEN SPOINT=0
!
! OUTPUT AN ARRAYHEAD INTO THE GLA RELATIVE TO THE START OF THE SYMBOL-
! TABLES IN WHICH THE ARRAY RESIDES.
!
TAGDISP=POWNARRAYHEAD(PTYPE,J,LB,QQ,SPOINT,QPUTP,DVO,NAMTXT)
STORE TAG(K,LEVEL,0,J,SNDISP,ACC,TAGDISP,KFORM)
->BEND
ROUTINE INIT SPACE(INTEGER SIZE, NELS)
!***********************************************************************
!* P IS TO FIRST ENTRY FOR CONSTLIST *
!* MAP SPACE ONTO WORKFILE END TO GIVE SANE ERROR MESSAGE IF *
!* THERE WAS NOT ENOUGH SPACE *
!***********************************************************************
CONSTINTEGER BUFSIZE=512
INTEGER RF, I, II, ELSIZE, AD, SPP, SLENGTH, WRIT
BYTEINTEGERARRAY SP(0:BUFSIZE+256)
AD=ADDR(FCOPND_B0)
ELSIZE=SIZE//NELS
IF ELSIZE=2 AND TARGET#PERQ AND TARGET#ACCENT THEN AD=ADDR(FCOPND_H1)
IF TYPE=5 THEN AD=ADDR(SCONST)
SPP=0; WRIT=0
UNTIL A(P-1)=2 CYCLE
XTRACT CONST(TYPE,PREC)
IF A(P)=1 START ; ! REPITITION FACTOR
P=P+2
IF A(P-1)=2 THEN RF=NELS-CONSTS FOUND ELSE START
P=P+2
IF INTEXP(RF,MINAPT)#0 THEN FAULT(41,0,0) AND RF=1
FINISH
P=P+1
FINISH ELSE RF=1 AND P=P+2
FAULT(42,RF,0) IF RF<=0
CYCLE I=RF,-1,1
IF TYPE=1=ACC OR TYPE=3 START
CYCLE II=0,1,ELSIZE-1
IF CONSTS FOUND<=NELS THEN SP(SPP)<- C
COPND_D AND SPP=SPP+1
REPEAT
FINISH ELSE START
IF CONSTS FOUND<=NELS THEN C
MOVE BYTES(ELSIZE,AD,0,ADDR(SP(0)),SPP) AND SPP=SPP+ELSIZE
FINISH
CONSTS FOUND=CONSTS FOUND+1
IF SPP>=BUFSIZE START ; ! EMPTY BUFFER
IF HOST#TARGET AND (TYPE=5 OR (TYPE=1 AND PREC=3))C
THEN CHANGE SEX(ADDR(SP(0)),0,SPP)
PDATA(QPUTP,1,SPP,ADDR(SP(0)))
WRIT=WRIT+SPP
SPP=0
FINISH
REPEAT
REPEAT ; ! UNTIL P<ROCL>=%NULL
IF CONSTS FOUND#NELS THEN FAULT(45,CONSTS FOUND,NELS)
SLENGTH=(SIZE+3)&(-4)
IF HOST#TARGET AND (TYPE=5 OR (TYPE=1 AND PREC=3)) C
THEN CHANGE SEX(ADDR(SP(0)),0,SLENGTH-WRIT)
PDATA(QPUTP,1,SLENGTH-WRIT,ADDR(SP(0)))
END
ROUTINE CLEAR(INTEGER SLENGTH)
SLENGTH=(SLENGTH+3)&(-4)
PRDATA(QPUTP,4,4,SLENGTH>>2,ADDR(ZERO))
END
ROUTINE XTRACT CONST(INTEGER CONTYPE, CONPREC)
!***********************************************************************
!* P POINTS TO P<+'> OF <+'><OPERNAD><RESTOFEXPR> AND IS UPDATED*
!* THE CONST IS CONVERTED TO REQUIRED FORM AND IF INTEGER *
!* IS LEFT IN ICONST, IF REAL IN RCONST AND IF STRING IN SCONST *
!***********************************************************************
INTEGER SLENGTH, STYPE, SACC, MODE, CH, WR, I
STYPE=PTYPE; SACC=ACC; ! MAY BE CHANGED IF CONST IS EXPR
IF CONTYPE=5 THEN START
P=P-3; CSTREXP(0)
WR=WORKA_ARTOP
IF EXPOPND_FLAG=LCONST AND EXPOPND_PTYPE=X'35' START
SLENGTH=EXPOPND_XTRA
LENGTH(SCONST)=SLENGTH
A(WR)=SLENGTH
FOR I=1,1,SLENGTH CYCLE
CH=A(EXPOPND_D+I)
CHARNO(SCONST,I)=CH
A(WR+I)=CH
REPEAT
COPND_PTYPE=X'35'; COPND_FLAG=LCONST
COPND_D=EXPOPND_D
COPND_XTRA=SLENGTH
FINISH ELSE START
FAULT(44,CONSTS FOUND,K); SCONST=""
SLENGTH=0
FINISH
FINISH ELSE START
MODE=CONPREC<<4!CONTYPE
IF CONPREC<5 THEN MODE=CONTYPE!X'50'
CONSTP=CONSTEXP(MODE)
IF CONSTP=0 THEN FAULT(41,0,0)
! CANT EVALUATE EXPT
COPND=EXPOPND; ! GET RESULT OPND
COPND_PTYPE=MODE
FINISH
PTYPE=STYPE; UNPACK; ACC=SACC
! FAULT ANY OBVIOUS ERRORS IE:-
! CONSTANT FOR EXTRINSIC OR INCOMPATIBLE TYPE OR STRING TOO LONG
IF EXTRN=3 THEN FAULT(49,0,K) AND RETURN
IF (CONTYPE=5 AND SLENGTH>=ACC) C
OR (CONTYPE=1 AND ((CONPREC=3 AND COPND_D>255) C
OR (CONPREC=4 AND COPND_D>X'FFFF'))) C
THEN FAULT(44,CONSTS FOUND,K)
!
! IF CROSS COMPILING THEN A CONSTANT FORMAT CHANGE IS NEED FROM
! IBM&ICL FORM TO PERQ FORM. IF ON PERQ FORMAT IS CORRECT
!
FCOPND=COPND
IF HOST#TARGET THEN START
REFORMATC(FCOPND)
FINISH
END
BEND: END ; ->CSSEXIT
SW(10):
BEGIN ; ! %RECORDFORMAT (RDECLN)
INTEGER NAME,OPHEAD,OPBOT,NLIST,MRL,CELLREF,FHEAD,SPEC
RECORD (LISTF)NAME LCELL,FRCELL
SNDISP=0
SPEC=A(P+1); ! 1 FOR SPEC 2 FOR FORMAT
NAME=FROM AR2(P+2); P=P+4
COPY TAG(NAME)
IF SPEC=1 OR NOT (PTYPE=4 AND J=15 AND OLDI=LEVEL) START
KFORM=0
PUSH(KFORM,0,0,0)
PTYPE=4
STORE TAG(NAME,LEVEL,RBASE,15,0,X'7FFF',KFORM,KFORM);! IN CASE OF REFS IN FORMAT
FINISH
IF SPEC=2 START
OPHEAD=0; OPBOT=0
NLIST=0; MRL=0
INAFORMAT=1
CRFORMAT(OPHEAD,OPBOT,NLIST,MRL,X'80000000')
INAFORMAT=0
CLEAR LIST(NLIST)
!
! IN CASE OF FORWARD REFS COPY TOP CELL OF FORMAT CHAIN INTO DUMMY
! SET UP BEFORE CALL OF CRFORMAT. ALSO RESET J&ACC TO CORRECT VALUE
!
LCELL==ASLIST(TAGS(NAME))
KFORM=LCELL_KFORM
POP(KFORM,I,I,FHEAD); ! THROW DUMMY CELL
! GET HEAD OF FORWARD REFS
WHILE FHEAD>0 CYCLE ; ! THROUGH FORWARD REFS
POP(FHEAD,CELLREF,I,I)
FRCELL==ASLIST(CELLREF)
FRCELL_UIOJ=FRCELL_UIOJ&X'FFFFFFF0';! SET J BACK TO 0
FRCELL_ACC=ACC; ! ACC TO CORRECT VALUE
FRCELL_KFORM=OPHEAD; ! CORRECT KFORM
REPEAT
LCELL_UIOJ=LCELL_UIOJ&X'FFFFFFF0'; ! J BACK TO ZERO
LCELL_ACC=ACC
LCELL_SLINK=OPHEAD; ! KFORM&SLINK(HISTORIC) TO SIDECHAIN
LCELL_KFORM=OPHEAD
FINISH
END ;->CSSEXIT
!
SW(19):
! '*' (UCI) (S)
FAULT(57,0,0) UNLESS LEVEL>=2
BEGIN
!***********************************************************************
!* COMPILE USERCODE INSTRUCTION. MOST WORK IS DONE BY HAIRY *
!* BUILT-IN PHRASE IN COMPARE. SINCE ALMOST ANYTHING IS LEGAL *
!* IN USERCODE THIS BLOCK HAS ONLT TO ASSEMBLE AND PLANT THE *
!* THE INSTRUCTION. *
!***********************************************************************
SWITCH UCITYPE(1:5),QINST(1:7)
RECORD (RD) OPND
RECORD (TAGF)NAME TCELL
INTEGER ALT,AALT,FNAME,OPTINC,OPC,KK,VAL1,VAL2,UCOP,TR,XTRA,H,Q
IF TARGET=EMAS OR TARGET=IBM OR TARGET=IBMXA START
ROUTINE CUCS
!***********************************************************************
!* SETS UP OPND FOR ASSEMBLER NAME(IE LOCAL OR CONST) *
!***********************************************************************
INTEGER ALT,FN0,D
FN0=FROM AR2(P); P=P+2
COPY TAG(FN0)
IF (LITL=1 AND NAM=ARR=0) START
TCELL==ASLIST(TAGS(FN0))
OPND_PTYPE=PTYPE&255
OPND_D=TCELL_S2
OPND_XTRA=TCELL_S3
FINISH ELSE START
IF TYPE>=6 OR TYPE=4 OR C
(ROUT=1 AND NAM=0) THEN FAULT(95,0,FN0) AND RETURN
IF ROUT=1 THEN K=SNDISP; ! FORMAL RT DESCPTR OFFSET
ALT=A(P); D=FROM AR2(P+1)
IF ALT=1 THEN K=K+D
IF ALT=2 THEN K=K-D
P=P+1; P=P+2 IF ALT<=2
OPND_FLAG=LOCALIR
OPND_D=I<<16!K
FINISH
END
FINISH
IF TARGET=EMAS START
ROUTINE CIND
!***********************************************************************
!* COMPILE A SYMBOLIC OPERAND BY SETTING ACCESS,AREA &DISP *
!***********************************************************************
INTEGER ALT,FN0,JJ,D,CTYPE,CPREC,AREA
SWITCH SW(1:4)
ALT=A(P)
P=P+1; ->SW(ALT)
SW(1): ! (PLUS')(ICONST)
D=A(P); CTYPE=A(P+1)
OPND_PTYPE=CTYPE
CPREC=CTYPE>>4; CTYPE=CTYPE&7
IF CPREC=4 THEN OPND_D=FROM AR2(P+2) ELSE C
IF CPREC=7 THEN OPND_D=P+2 ELSE C
MOVE BYTES(BYTES(CPREC),ADDR(A(0)),P+2,ADDR(OPND_D),0)
P=P+2+BYTES(CPREC)
IF D=2 THEN START
JJ=11; ! UNARY NEGATE
CTOP(JJ,D,0,OPND,OPND); ! NEGATE CONSTANT
FINISH
FAULT(96,FN0,0) UNLESS 1<=CTYPE<=2 AND 4<=CPREC<=7
RETURN
SW(2): ! (NAME)(OPTINC)
CUCS
RETURN
SW(3): ! '('(REG)(OPTINC)')'
AREA=A(P)+1; ALT=A(P+1); P=P+2
DISP=0
D=FROM AR2(P)
IF ALT=1 THEN DISP=D
IF ALT=2 THEN FAULT(96,-D,0)
DISP=4*DISP
P=P+2 UNLESS ALT=3
OPND_FLAG=10
OPND_XB=AREA<<4
OPND_D=DISP
RETURN
SW(4): ! '%TOS'
OPND_FLAG=10; OPND_XB=X'60'
END
ROUTINE ULABREF
!***********************************************************************
!* COMPILES USERCODE REF TO 2900 LABELS *
!* LABELS MAY ONLY BE USED WITH JCC(2),JAT(4),JAF(6),J(1A),JLK(1C) *
!* AND ALSO DEBJ(24) *
!* FAULTED IN OTHER SITUATIONS.(IE MORE RESTRICTIVE THAN 2900IMP) *
!***********************************************************************
INTEGER MASK,LAB
IF OPC<=6 THEN MASK=FROMAR2(P)+8*(OPC-2) AND P=P+3 C
ELSE IF OPC=X'1A' THEN MASK=15 ELSE C
IF OPC=X'1C' THEN MASK=0 ELSE C
IF OPC=X'24' THEN MASK=48 ELSE FAULT(97,0,0)
LAB=FROMAR2(P)
ENTER JUMP(MASK,LAB,0)
END
FINISH
IF TARGET=IBM OR TARGET=IBMXA START
ROUTINE DB
!***********************************************************************
!* COMPILES AN IBM DB FORMAT SECOND OPERAND REFERENCE *
!***********************************************************************
INTEGER ALT
ALT=A(P); P=P+1; ! ALT OF DB
IF ALT=1 START ; ! NAME LOCAL OR CONST
CUCS
FINISH ELSE START ; ! EXPLICIT NUMERICAL FORM
OPND_D=FROMAR2(P); P=P+2
OPND_FLAG=10
ALT=A(P); P=P+1
IF ALT=1 THEN OPND_XB=A(P) AND P=P+1
FINISH
END
ROUTINE DXB
!***********************************************************************
!* COMPILES AN IBM DXB (AND DLB) FORMAT SECOND OPERAND REFERENCE *
!* THE L IN DLB CAN BE UP TO 256 SO NEEDS 2 AR ENTRIES *
!***********************************************************************
INTEGER ALT
ALT=A(P); P=P+1; ! ALT OF DXB
IF ALT=1 START ; ! NAME LOCAL OR CONST
CUCS
IF A(P)=1 AND OPND_FLAG=7 THEN XTRA=FROMAR2(P+1) AND P=P+2
P=P+1
FINISH ELSE START ; ! EXPLICIT NUMERICAL FORM
OPND_D=FROMAR2(P); P=P+2
OPND_FLAG=10
ALT=A(P); P=P+1
IF ALT=1 THEN START
XTRA=FROMAR2(P); OPND_XB=A(P+2)
P=P+3
FINISH
IF ALT=2 THEN OPND_XB=A(P) AND P=P+1
FINISH
END
FINISH
OPC=0; XTRA=0
OPND=0
OPND_PTYPE=X'51'
OPND_FLAG=1
ALT=A(P+1); P=P+2
->UCITYPE(ALT)
UCITYPE(1): ! **@'(NAME)(OPTINC)
! INVALID ON IBM ARCHITECTURES
! AS THERE IS NO ACCUMULATOR
AALT=A(P); ! ALT OF @'
FNAME=A(P+1)<<8!A(P+2)
P=P+3; OPTINC=0
IF A(P)#3 START ; ! THERE IS AN OPTINC
OPTINC=FROMAR2(P+1)
IF A(P)=2 THEN OPTINC=-OPTINC
FINISH
COPY TAG(FNAME)
IF TARGET=IBM OR TARGET=IBMXA OR TYPE>=6 OR ROUT#0 THEN FAULT(97,FNAME,0)
UCOP=UCNAM
OPND_PTYPE=X'61'
OPND_D=AALT<<16!FNAME
OPND_XTRA=OPTINC
->OTRIP
UCITYPE(2): ! PUT (HEX HALFWORD)
TYPE=A(P)
PREC=TYPE>>4; TYPE=TYPE&7
FAULT(97,0,0) UNLESS TYPE=1 AND PREC<6
IF PREC=5 THEN P=P+2
OPND_D=FROM AR2(P+1); UCOP=UCB2
->OTRIP
UCITYPE(4): ! CNOP
UCOP=UCNOP; OPND_D=FROM AR2(P)
->OTRIP
UCITYPE(3): ! ASSEMBLER
AALT=A(P); P=P+1
OPC=FROMAR2(P); P=P+2
IF TARGET=PNX OR TARGET=PERQ OR TARGET=ACCENT START
P=P+3; ! TO START OF EXPR
IF AALT>1 THEN START
KK=INTEXP(VAL1,MINAPT)
FAULT(96,0,1) UNLESS KK=0
FINISH
IF AALT>=5 START
P=P+3
KK=INTEXP(VAL2,MINAPT)
FAULT(96,0,2) UNLESS KK=0
FINISH
FINISH
->QINST(AALT)
UCITYPE(5): ! OTHER M-CS ASSEMBLER
FAULT(97,0,0)
->BEND
QINST(1): ! ONE BYTE INSTRUCTION
! 2900 IS PRIMARY FORMAT INSTRUCTIONS
! IBM ONE REGISTER RR INSTRUCTIONS
UCOP=UCB1
IF TARGET=PNX OR TARGET=PERQ OR TARGET=ACCENT THEN OPND_D=OPC ELSE C
IF TARGET=EMAS START
ALT=A(P); P=P+1
IF ALT=1 THEN ULABREF AND ->BEND
IF ALT=2 THEN CIND ELSE C
IF ALT=3 THEN CIND AND XTRA=4-A(P) ELSE C
IF ALT=4 THEN CIND AND XTRA=1 ELSE C
IF ALT=5 THEN OPND_FLAG=10 AND OPND_XB=X'74'-A(P) ELSE C
IF ALT=6 THEN OPND_FLAG=10 AND OPND_XB=X'70'
FINISH ELSE IF TARGET=IBM OR TARGET=IBMXA START
VAL1=A(P); P=P+1
IF OPC#10 AND VAL1>15 THEN FAULT(97,0,0)
OPND_D=OPC<<16!VAL1
FINISH
->OTRIP
QINST(2): ! UNSIGNED BYTE OPERAND
! EMAS 2NDARY (STORE TO STORE) FORMAT
! IBM RR AND RRE INSTRUCTIONS
UCOP=UCB2
IF TARGET=PNX OR TARGET=PERQ OR TARGET=ACCENT START
FAULT(96,0,1) UNLESS 0<=VAL1<=255
OPND_D=OPC<<8!VAL1
FINISH ELSE IF TARGET=EMAS START
VAL1=0; VAL2=0; Q=0; JJ=0
H=2-A(P)
IF H=0 THEN JJ=FROM AR2(P+1)-1 AND P=P+2
FAULT(96,JJ+1,0) UNLESS 0<=JJ<=127
ALT=A(P+1); P=P+2
IF ALT=1 THEN START
Q=1
VAL1=FROM AR2(P)
VAL2=FROM AR2(P+2)
P=P+4
IF VAL1>255 THEN FAULT(96,VAL1,0)
IF VAL2>255 THEN FAULT(96,VAL2,0)
FINISH
OPND_D=H<<31!Q<<30!JJ<<16!VAL1<<8!VAL2
FINISH ELSE IF TARGET=IBM OR TARGET=IBMXA START
VAL1=A(P); VAL2=A(P+1); P=P+2
FAULT(97,0,0) IF VAL1>15 OR VAL2>15
OPND_D=OPC<<16!VAL2<<8!VAL1
FINISH
->OTRIP
QINST(3): ! PERQ SIGNED BYTE OPERAND
! EMAS TERTIARY (JUMP) FORMAT
! IBM REGISTER STORE RX FORMAT
IF TARGET=PNX OR TARGET=PERQ OR TARGET=ACCENT START
UCOP=UCB2
FAULT(96,0,1) UNLESS -128<=VAL1<=127
OPND_D=OPC<<8!(VAL1&255)
FINISH ELSE IF TARGET=EMAS START
UCOP=UCB3; ! DIFFERENT TRIPLE NEEDED FOR EMAS
XTRA=FROMAR2(P)
ALT=A(P+2)
IF ALT=1 THEN ULABREF AND ->BEND
P=P+3
IF ALT=2 THEN START
CIND
FAULT(97,0,0) IF OPND_XB=X'60'
FINISH ELSE IF ALT=3 START
OPND_FLAG=10
OPND_XB=8-A(P)
FINISH ELSE OPND_XB=1 AND OPND_D=FROMAR2(P)
FINISH ELSE IF TARGET=IBM OR TARGET=IBMXA START
UCOP=UCB3
VAL1=A(P); P=P+1; ! FIRST REGISTER OPERAND
DXB
FAULT(97,0,0) IF XTRA>15 OR VAL1>15 OR OPND_XB>15
XTRA=XTRA<<8!VAL1
! OPCODE R1 & INDEX IN _X1
! DB VARIOUSLY IN OPND
FINISH
->OTRIP
QINST(4): ! SIGNED WORD OPERAND
! IBM RS (REGISTER TO STORE) FORMAT
IF TARGET=PNX OR TARGET=PERQ OR TARGET=ACCENT START
FAULT(96,0,1) IF C
(TARGET=PERQ OR TARGET=ACCENT) AND IMOD(VAL1)>X'7FFF'
UCOP=UCW; OPND_PTYPE=X'61'
OPND_D=OPC
OPND_XTRA=VAL1
FINISH ELSE IF TARGET=IBM OR TARGET=IBMXA START
UCOP=UCB3; ! GENERATORS TREATS AS DXB
VAL1=A(P); XTRA=A(P+1)
P=P+2; DB
FAULT(97,0,0) IF XTRA>15 OR VAL1>15 OR OPND_XB>15
XTRA=XTRA<<8!VAL1
FINISH
->OTRIP
QINST(5): ! 2 UNSIGNED BYTE OPERANDS
! IBM STORE IMMEDIATE OR STORE FORMATS
IF TARGET=PNX OR TARGET=PERQ OR TARGET=ACCENT START
FAULT(96,0,1) UNLESS 0<=VAL1<=255
FAULT(96,0,2) UNLESS 0<=VAL2<=255
UCOP=UCB3; OPND_D=OPC<<16!VAL1<<8!VAL2
FINISH ELSE IF TARGET=IBM OR TARGET=IBMXA START
UCOP=UCW; DB
ALT=A(P); P=P+1
IF ALT=1 START ; ! IMMEDIATE OPERAND GIVEN
P=P+3
KK=INTEXP(XTRA,X'51')
FAULT(97,0,0) UNLESS KK=0 AND 0<=XTRA<=255 AND OPC<255
FINISH ; ! NO OPERAND 0 ASSUMED
->OTRIP
FINISH
->OTRIP
QINST(6): ! BYTE & WORD OPERANDS
! IBM SS AND SSE FORMATS
IF TARGET=PNX OR TARGET=PERQ OR TARGET=ACCENT START
FAULT(96,0,1) UNLESS 0<=VAL1<=255
FAULT(96,0,2) UNLESS IMOD(VAL2)<=X'7FFFF'
I=UCBW; OPND_D=OPC<<24!VAL1<<16!(VAL2&X'FFFF')
FINISH ELSE IF TARGET=IBM OR TARGET=IBMXA START
DXB
TR=URECTRIP(UCNAM,0,DONT OPT!ASSLEVEL,OPND)
! PASS ON OPND FIRST DUE TO
! LIMITATIONS OF PORTABLE ASSEMBLER
OPND=0
DB; UCOP=UCBW
IF (OPC>255 AND XTRA#0) OR XTRA>256 THEN FAULT(97,0,0)
FINISH
->OTRIP
OTRIP:
TR=URECTRIP(UCOP,0,DONT OPT!ASS LEVEL,OPND)
TRIPLES(TR)_X1=OPC<<16!XTRA
BEND:
END
->CSSEXIT
SW(20):
! '%TRUSTEDPROGRAM'
PARM_COMPILER=1 IF PARM_ARR=0 AND PARM_CHK=0; ->CSSEXIT
SW(21): ! '%MAINEP'(NAME)
KK=FROM AR2(P+1)
FAULT(97,0,0) UNLESS PARM_CPRMODE=0
MAINEP<-STRING(ADDR(WORKA_LETT(WORD(KK))))
->CSSEXIT
INTEGERFN CFORMATREF
!***********************************************************************
!* P IS TO ALT OF FORMAT REF *
!* P<FORMTAREF>::=(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
PTYPE=4
PUSH(KFORM,0,0,0)
STORE TAG(FNAM,LEVEL,RBASE,15,0,X'7FFF',KFORM,KFORM)
RESULT =KFORM
FINISH
FAULT(62,0,FNAM); ! NOT A RECORD OF FORMAT NAME
ACC=8; ! GUESS A RECORD SIZE
RESULT =DUMMY FORMAT
FINISH
! FORMAT ACTUALLY SPECIFIED
P=P+1
OPHEAD=0; OPBOT=0
NHEAD=0; MRL=0
CRFORMAT(OPHEAD,OPBOT,NHEAD,MRL,X'80000000')
CLEAR LIST(NHEAD)
IF CURRINF_UNATT FORMATS#0 START
LCELL==ASLIST(CURRINF_UNATT FORMATS)
IF LCELL_S2=0 THEN LCELL_S2=OPHEAD AND RESULT =OPHEAD
IF LCELL_S3=0 THEN LCELL_S3=OPHEAD AND RESULT =OPHEAD
FINISH
PUSH(CURRINF_UNATT FORMATS,OPHEAD,0,0)
RESULT =OPHEAD
END
ROUTINE CRFORMAT(INTEGERNAME OPHEAD, OPBOT, NLIST, MRL, INTEGER INIT)
!***********************************************************************
!* CONVERTS A RECORDFORMAT STATEMENT TO A LIST HEADED BY OPHEAD *
!* FORMAT OF AN ENTRY. *
!* S1=SUBNAME<<20!PTYPE<<4!J *
!* S2,S3=4 16 BIT DISPLACEMENTS D2,ACC,D1,KFORM *
!* NORMALLY D1=RECORD RELATIVE DISPLACEMENT AND ACC=LMAX(STRINGS)*
!* FOR ARRAYS D2=FIRST ELEMENT DISPLACEMENT AND D1=DISPLACEMENT *
!* OF RECORD RELATIVE ARRAYHEAD IN THE GLA *
!* KFORM IS ONLY USED FOR RECORDS AND POINTS TO THE FORMAT *
!* ON EXIT ACC HAS THE RECORD SIZE ROUNDED UP TO THE BOUNDARY *
!* REQUIRED BY ITS LARGEST COMPONENT *
!***********************************************************************
INTEGER D1, D2, FORM, RL, STALLOC, INC, Q, R, RFD, LB, TYPEP, SACC, DVO
ROUTINESPEC SN(INTEGER Q)
ROUTINESPEC ROUND
FORM=0; ACC=0
INC=INIT&X'FFFF'; ! INC COUNTS DOWN RECORD
CYCLE
ROUT=0; LITL=0; NAM=0; RFD=A(P)
P=P+1
IF RFD=1 THEN START
CLT
FORM=KFORM
STALLOC=ACC
P=P+1
IF A(P-1)=1 START
! (TYPE) (QNAME')(NAMELIST)
FORM=KFORM
CQN(P); P=P+1
IF NAM=1 THEN START
STALLOC=PTRSIZE(PREC<<4!TYPE)
IF ARR#0 THEN STALLOC=AHEADSIZE
FINISH
PACK(PTYPE); D2=0
RL=ROUNDING LENGTH(PTYPE,0)
ROUND; J=0
UNTIL A(P-1)=2 CYCLE
D1=INC; SN(P)
P=P+3; INC=INC+STALLOC
REPEAT
FINISH ELSE START
! (TYPE)%ARRAY(NAMELIST)(BPAIR)
Q=P+1; ARR=1; PACK(PTYPE)
CYCLE
P=Q
P=P+3 UNTIL A(P-1)=2
TYPEP=PTYPE; SACC=ACC
DVO=DOPE VECTOR(TYPE,ACC,0,FROMAR2(Q)>>1,R,LB)
! DOPE VECTOR INTO SHAREABLE S.T.
ACC=SACC; PTYPE=TYPEP; UNPACK
RL=ARRAYINREC ROUNDING
CYCLE
ROUND
D1=POWNARRAYHEAD(PTYPE,J,LB,R,INC,0,DVO,"")
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 <RESTOFARRAYLIST> 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 <RESTOFRFDEC> 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. *
!* CARE IS NEEDED TO MATCH TAG LAYOUT ON BYTE SWOPPED HOSTS *
!***********************************************************************
RECORD (TAGF) CELL
FNAME=FROM AR2(Q)
FAULT(61,0,FNAME) UNLESS FIND(FNAME,NLIST)=-1
CELL_PTYPE<-PTYPE; CELL_UIOJ<-FNAME<<4!J
CELL_ACC=ACC
CELL_SNDISP=D2
CELL_SLINK=D1
CELL_KFORM=FORM
BINSERT(OPHEAD,OPBOT,CELL_S1,CELL_S2,CELL_S3)
PUSH(NLIST,0,FNAME,0)
IF PTYPE=X'433' AND ACC=X'7FFF' THEN C
PUSH(ASLIST(FORM)_S3,OPBOT,0,0);! NOTE FORWARD REFERENCE
END
ROUTINE ROUND
MRL=RL IF RL>MRL
INC=INC+1 WHILE INC&RL#0
END
END ; ! OF ROUTINE CRFORMAT
INTEGERFN DISPLACEMENT(INTEGER LINK)
!***********************************************************************
!* SEARCH A FORMAT LIST FOR A SUBNAME *
!* A(P) HAS ENAME--LINK IS HEAD OF RFORMAT LIST. RESULT IS DISP *
!* FROM START OF RECORD *
!***********************************************************************
RECORD (LISTF)NAME FCELL,PCELL,LCELL
INTEGER RR,II,ENAME,CELL
ENAME=A(P)<<8+A(P+1); CELL=0
IF LINK#0 THEN START ; ! CHK RECORDSPEC NOT OMITTED
FCELL==ASLIST(LINK); ! ONTO FIRST CELL
CELL=LINK; II=-1; ACC=-1
WHILE LINK>0 CYCLE
LCELL==ASLIST(LINK)
IF LCELL_UIOJ<<16>>20=ENAME START ;! RIGHT SUBNAME LOCATED
TCELL=LINK
SNDISP=LCELL_SNDISP
K=LCELL_SLINK
J=LCELL_UIOJ&15; PTYPE=LCELL_PTYPE
ACC=LCELL_ACC
SNDISP=LCELL_SNDISP
KFORM=LCELL_KFORM
IF LINK#CELL START ; ! NOT TOP CELL OF FORMAT
PCELL_LINK=LCELL_LINK
LCELL_LINK=FCELL_LINK
FCELL_LINK=LINK
FINISH ; ! ARRANGING LIST WITH THIS SUBNAME
! NEXT TO THE TOP
RESULT =K
FINISH
PCELL==LCELL
LINK=LCELL_LINK
REPEAT
FINISH
FAULT(65,0,ENAME)
IF CELL>0 THEN C
PUSH(ASLIST(CELL)_LINK,(ENAME<<4)<<FLAGSHIFT!X'57'<<PTSHIFT,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=-1
CENAME(ACCESS,FNAME,BASE,DISP,0)
FINISH ; RETURN
!
ROUTINE CENAME(INTEGER MODE,FNAME,BS,DP,XD)
!***********************************************************************
!* FINDS OUT ABOUT SUBNAME AND ACTS ACCORDINGLY.MOSTLY ACTION *
!* CONSISTS OF UPPING XD BY OFFSET OF THE SUBNAME BUT IS VERY *
!* HAIRY FOR RECORDS IN RECORDS ETC *
!* MODE IS ACCESS FOR THE RECORD *
!***********************************************************************
ROUTINESPEC FETCH RAD
ROUTINESPEC LOCALISE(INTEGER SIZE)
INTEGER Q,QQ,D,C,W,TR
RECORD (RD) RADOPND,OPND1
RECORD (LISTF)NAME LCELL
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=NAMEP!X'FFFF0000'
IF NAM=1 THEN START
LOCALISE(1); ! PICK UP RECNAME DESCR &STCK IF NECESSARY
DP=DISP; BS=BASE
FINISH
CENAME(MODE,KFORM,BS,DP,XD)
RETURN
AE: ! ARRAYS AND ARRAYNAMES AS ELEMEN
LCELL==ASLIST(TCELL)
ACC=LCELL_ACC; SNDISP=LCELL_SNDISP
KFORM=LCELL_KFORM; K=LCELL_SLINK
C=ACC; D=SNDISP; Q=K; QQ=KFORM
IF (Z=6 OR Z>=11) AND A(P+2)=2 START ;! 'GET ARRAYHEAD' CALL
P=P+3
IF NAM=1 THEN START
ACCESS=MODE+8; BASE=BS
DISP=DP; XDISP=XD+Q
PTYPE=AHEADPT
NAMEOP(6,8,NAMEP); ! PTR TO HEAD
RETURN
FINISH
!
! PASSING AN ARRAY IN A RECORD BY NAME MUST CONSTRUCT PROPER ARRAYHEAD
! FROM THE RECORD RELATIVE ONE AT Q(GLA)
!
FETCH RAD
NAMEP=-1
OPND1_S1=AHEADPT<<PTSHIFT!LOCALIR<<FLAGSHIFT
OPND1_D=Q
OPND1_XTRA=0
NAMEOPND_D=CREATE AH(1,RADOPND,OPND1)
NAMEOPND_PTYPE=AHEADPT; NAMEOPND_FLAG=REFTRIP
NAMEOPND_XTRA=0
FINISH ELSE START ; ! ARRAY ELEMENTS IN RECORDS
IF NAM=1 THEN START ; ! ARRAYNAMES-FULLHEAD IN RECORD
XD=XD+Q
LOCALISE(2); ! MOVE HEAD UNDER LNB IF NECESSARY
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
TR=BRECTRIP(AAINC,X'51',0,RADOPND,EXPOPND)
EXPOPND_FLAG=REFTRIP
EXPOPND_D=TR
TRIPLES(TR)_X1=PTYPE&255; ! FRIG FOR PERQ&ACCENT 3 WORD BYTE PTRS!
FINISH
NAMEP=-1
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(4,4,NAMEP)
PREC=PRECP; ! ENSURE 32BIT PICKUP
RADOPND=NAMEOPND
END
ROUTINE LOCALISE(INTEGER LMODE)
!***********************************************************************
!* REMOVES A RECORD POINTER OR ARRAYHEAD FROM A RECORD AND STORES*
!* IT IN A TEMPORARY UNDER LNB. *
!* LMODE=1 NORMAL POINTERS, LMODE=2 ARRAY POINTERS *
!***********************************************************************
RECORD (RD)TOPND
INTEGER HOLE,PRECP,SIZE,JJ,PTYPEP
IF MODE=0 AND TARGET#PNX START ;! MOVE NOT NECESSARY
! BUT ON PNX CANT ADD OFFSETS LIKE THIS
BASE=BS; DISP=DP+XD
XD=0; MODE=2
RETURN
FINISH
BASE=BS; DISP=DP
XDISP=XD
PRECP=PREC; PTYPEP=PTYPE
IF LMODE=1 THEN SIZE=4 AND PREC=5 C
ELSE SIZE=AHEADSIZE AND PREC=AHEADPT>>4
GET WSP(HOLE,SIZE>>1)
TOPND_PTYPE=1!PREC<<4
TOPND_FLAG=LOCALIR
TOPND_D=RBASE<<16!HOLE
TOPND_XTRA=0
IF LMODE=1 START
ACCESS=MODE+4
NAMEOP(4,SIZE,NAMEP)
NAMEOPND_PTYPE=TOPND_PTYPE
FINISH ELSE START
ACCESS=MODE+8
NAMEOP(6,SIZE,NAMEP)
NAMEOPND_PTYPE=TOPND_PTYPE
JJ=URECTRIP(PRELOAD,NAMEOPND_PTYPE,0,NAMEOPND)
NAMEOPND_FLAG=REFTRIP
NAMEOPND_D=JJ
FINISH
JJ=BRECTRIP(LASS,1+16*PREC,0,TOPND,NAMEOPND)
PREC=PRECP; PTYPE=PTYPEP
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
!
! LEFT TO RIGHT EVALUATION IS DEFINED BUT IF FIRST OPERAND IS ACONST
! WE CAN EVALUATE THE SECOND. THIS ENABLES US TO FOLD "TOSTRING(NL)" ETC
!
IF DOTS=0 AND OPND2_FLAG=LCONST THEN START
ERR=STROP(OPND3)
->ERROR UNLESS ERR=0
FINISH ELSE OPND3_FLAG=255
FINISH
IF ENDFLAG=0 AND OPND2_FLAG=LCONST=OPND3_FLAG START
!
! CAN FOLD OUT A CONCATENATION HERE
!
I=CONCAT
CTOP(I,ERR,0,OPND2,OPND3)
IF I=0 THEN ->NEXT; ! FOLDED OUR
FINISH
IF DOTS=0 START
IF MODE=0 AND ENDFLAG#0 START ; ! NO RUN-TIME OPERATIONS
OPND1=OPND2; ->TIDY
FINISH
GET WSP(WKAREA,X'80000000'!268); ! GET NEXT OPERAND
OPND1_PTYPE=X'35'
OPND1_FLAG=LOCALIR
OPND1_D=RBASE<<16!WKAREA
OPND1_XTRA=268; ! THE WORK AREA SIZE NEEDED FOR
! BACKWARD STACKS
I=BRECTRIP(PRECC,X'35',0,OPND1,OPND2)
OPND1_FLAG=REFTRIP
OPND1_D=I; ! CHANGE TO TRIPLES REFERENCE
DOTS=1
FINISH
IF ENDFLAG=0 THENSTART
IF OPND3_FLAG=255 START ; ! 3 NEED EVALUATION
ERR=STROP(OPND3)
->ERROR UNLESS ERR=0
FINISH
OPND1_D=BRECTRIP(CONCAT,X'35',0,OPND1,OPND3)
->NEXT
FINISH
TIDY: ! FINISH OFF
EXPOPND=OPND1; ! LEAVE REULT IN EXPOPND
VALUE=WKAREA
P=P+1; ! PAST REST OF EXPRN
RETURN WSP(WKAREA,268) IF KEEPWA=0 AND WKAREA>0
STRINGL=0
RETURN
ERROR:FAULT(ERR,0,FNAM)
BASE=RBASE; DISP=0
VALUE=0; ACCESS=0
P=PP; SKIP EXP
RETURN
INTEGERFN STROP(RECORD (RD) NAME OPND)
!***********************************************************************
!* DEALS WITH OPERAND FOR CONCATENATION. RETURN RESULT=0 FOR *
!* VALID OPERAND OTHERWISE AN ERROR NUMBER. *
!***********************************************************************
INTEGER CTYPE,MODE,I
MODE=A(P); ! ALTERNATIVE OF OPERAND
OPND=0
RESULT =75 IF MODE>2
IF MODE#1 THENSTART
CTYPE=A(P+1); ! GET CONST TYPE & LOSE AMCK FLAGS
IF CTYPE=X'35' THENSTART
STRINGL=A(P+2)
OPND_PTYPE=CTYPE
OPND_FLAG=LCONST
OPND_D=P+2
OPND_XTRA=STRINGL
P=P+STRINGL+3
FINISHELSERESULT =73
FINISHELSESTART
P=P+1; ! MUST CHECK FIRST
REDUCE TAG
IF 5#TYPE#7 THEN FNAM=FROMAR2(P) ANDRESULT =71
IF PTYPE=X'4035' AND A(P+2)=2=A(P+3) START
OPND_FLAG=LCONST; ! CONST STRING
OPND_PTYPE=X'35'
OPND_D=MIDCELL
OPND_XTRA=KFORM
STRINGL=OPND_XTRA
P=P+4
RESULT =0
FINISH
IF PTYPE=X'35' AND A(P+2)=2=A(P+3) START
OPND_FLAG=DNAME
OPND_XTRA=0
OPND_PTYPE=PTYPE
OPND_D=FROMAR2(P)
P=P+4
FINISHELSESTART
CNAME(2)
OPND=NAMEOPND
FINISH
STRINGL=0
FINISH
RESULT =0
END ; ! OF INTEGERFN STROP
END ; ! OF ROUTINE CSTREXP
ROUTINE CRES (INTEGER LAB)
!**********************************************************************
!* COMPILES A RESOLUTION E.G A->B.(C).D.(E).F AND JUMPS TO LAB *
!* ON FAILURE. (LAB=0 FOR UNCONDITIONAL RESOLUTION TO PERM ON *
!* FAILURE ). *
!* THE METHOD IS TO CALL A SUBROUTINE PASSING 5 PARAMS:- *
!* P1(32BITS) POINTS TO LHS(A) *
!* P2(16BITS) ORIGINAL LENGTH OF A *
!* P3(32BITS) FULL POINTER TO BYTES USED UP INITIALLY 0 *
!* P4(48BITS) STRING TO CONTAIN FRAGMENT *
!* (PASSED AS LMAX FOLLOWED BY 32BIT ADDRESS) *
!* P5(32BITS) THE EXPRESSION PASSED AS 32 BIT ADDRESS *
!* SUBROUTINE TRIES TO PERFORM THE RESOLUTION AND SETS THE *
!* RESULT TO TRUE IF IT SUCCEEDS. *
!* *
!* ON ENTRY LHS IS IN THE ESTACK(32BITS). *
!* P POINTS TO P(+') OF RHS DEFINED AS (+')(OPERAND)(RESTOFEXP) *
!* *
!$ THE ROUTINE IS COMPACT BUT DIFFICULT TO FOLLOW (OR ALTER) *
!* THE TIME IN PERM IS LARGE SO IT IS NOT WORTHWHILE TO PERSUE *
!* CODE EFFICIENCY TOO INDUSTRIOUSLY . *
!**********************************************************************
INTEGER P1,P2,SEXPRN,W,LAST,ERR,FNAM,JJ
RECORD (RD) OPND1,OPND2
LAST=0; FNAM=0; ! =1 WHEN END OF EXPRNSN FOUND
SEXPRN=0; ! RESOLUTION(BRKTD) EXPRESSNS
P1=P
ERR=43
IF NAMEOPND_PTYPE&X'C300'=X'4000' THEN FNAM=NAMEOPND_D AND ->ERROR
! CANT RESOLVE A CONST STRING
ERR=74; ! NORMAL CRES FAULT
GET WSP(W,4); ! TO HOLD P1,P2 AND VALUE OF P3
OPND1_PTYPE=X'61'
OPND1_FLAG=LOCALIR
OPND1_D=RBASE<<16!W
JJ=BRECTRIP(PRES1,X'35',DONT OPT,OPND1,NAMEOPND)
P=P+3
->RES IF A(P)=4; ! LHS MUST BE A STRING
! BUT THIS CHECKED BEFORE CALL
ERR=72
ERROR:FAULT(ERR,0,FNAM)
P=P1; SKIP EXP; RETURN
RES: P=P+1; ! TO P(OPERAND)
IF A(P)=3 THEN START ; ! B OMITTED
OPND2_PTYPE=X'51'
OPND2_FLAG=SCONST
OPND2_D=0; ! ZERO CONST FOR NO DEST
FINISH ELSE START
->ERROR UNLESS A(P)=1; ! P(OPERAND)=NAME
P=P+1; P2=P
CNAME(3)
OPND2=NAMEOPND
IF TYPE#5 THEN ERR=71 AND FNAM=FROMAR2(P2) AND ->ERROR
IF A(P+1)#CONCOP THEN ERR=72 AND ->ERROR
P=P+2
FINISH
JJ=BRECTRIP(PRES2,X'35',DONT OPT,OPND1,OPND2)
->ERROR UNLESS A(P)=3; ! P(OPERAND)='('(EXPR)')'
SEXPRN=SEXPRN+1; P=P+1
CSTREXP(32); ! FULL 32 BIT ADDRESS
OPND2_S1=X'51'<<PTSHIFT!SCONST<<FLAGSHIFT
OPND2_D=LAB
JJ=BRECTRIP(RESLN,X'35',DONT OPT,EXPOPND,OPND2)
IF LAB#0 THEN ENTER JUMP(X'87',LAB,B'11')
!
-> END IF A(P)=2
IF A(P+1)#CONCOP THEN ERR=72 AND ->ERROR
P2=P+1; P=P2+1
IF A(P)=3 THEN P=P2 AND ->RES
->ERROR UNLESS A(P)=1
P=P+3 AND SKIP APP UNTIL A(P)=2
IF A(P+1)=1 THEN P=P2 AND ->RES
P1=P+1
P=P2+2
CNAME(3)
JJ=BRECTRIP(RESFN,X'35',DONT OPT,OPND1,NAMEOPND)
P=P1
END:
P=P+1
END
ROUTINE SAVE STACK PTR
!***********************************************************************
!* SAVE THE CURRENT STACK TOP AND POSSIBLY A DESCRIPTOR TO IT *
!* NEEDED ON AUX STACK IMPLEMENTATIONS AND ALSO IN BEGIN-END BLOCKS *
!* SO ARRAYS CAN BE UNDECLARED ON BLOCK EXIT. ONLY ACTS ON THE FIRST*
!* CALL IN ANY BLOCK OR ROUITNE *
!***********************************************************************
INTEGER JJJ
IF CURRINF_AUXSBASE=0 START
JJJ=UTEMPTRIP(SSPTR,MINAPT,0,N); ! SAVE THE STACK POINTER
CURRINF_AUXSBASE=N
IF TARGET=EMAS AND PARM_STACK=0 THEN N=N+16 C
ELSE N=N+4
FINISH
END
ROUTINE CEND (INTEGER KKK)
!***********************************************************************
!* DEAL WITH ALL OCCURENCES OF '%END' *
!* KKK=PTYPE(>=X'1000') FOR ROUTINES,FNS AND MAPS *
!* KKK=0 FOR ENDS OF '%BEGIN' BLOCKS *
!* KKK=1 FOR '%ENDOFPROGRAM' *
!* %ENDOFPROGRAM IS REALLY TWO ENDS. THE FIRST IS THE USERS *
!* AND THE SECOND IS PERMS. KKK=2 FOR A RECURSIVE CALL OF CEND *
!* ON END OF PROGRAM TO DEAL WITH THE %END CORRESPONDING TO *
!* THE %BEGIN COMPILED IN THE INITIALISATION SEQUENCE *
!***********************************************************************
INTEGER KP,JJ,BIT
RECORD (TAGF)NAME TCELL,PCELL
ROUTINESPEC DTABLE(INTEGER LEVEL)
SET LINE UNLESS KKK=2
BIT=1<<LEVEL
!
! NOW PLANT AN ERROR EXIT FOR FNS AND MAPS - CONTROL SHOULD BE RETURNED
! VIA %RESULT= AN SHOULD NEVVER REACH THE %END INSTRUCTION
!
IF KKK&X'3FFF'>X'1000' AND PARM_COMPILER=0 C
AND LAST INST=0 THEN C
JJ=UCONSTTRIP(RTBAD,X'51',0,0); ! RUN FAULT 11
IF KKK=0 THEN START ; ! BEGIN BLOCK EXIT
IF PARM_TRACE=1 THEN START ; ! RESTORE DIAGS POINTERS
JJ=UCONSTTRIP(RDPTR,X'51',0,LEVEL-1)
FINISH
JJ=CURRINF_AUXSBASE
IF JJ#0 THEN START ; ! ARRAYS TO BE UNDECLARED
JJ=UCONSTTRIP(RSPTR,X'51',0,JJ)
FINISH
FINISH
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<KP<=MAX ULAB THEN FAULT(11,ASLIST(J)_S3,KP)
CLEAR LIST(J)
FINISH ELSE START
IF I&LABUSEDBIT=0 AND KP<MAX ULAB THEN WARN(3,KP)
FINISH
REPEAT
!
NMAX=(NMAX+7)&(-8)
CURRINF_SNMAX=NMAX
!
! FOR ROUITNE CHECK PARAMETER LIST FOR ARRAY PARAMETERS AND PASS
! BACK ANY INFORMATION ON DIMENSIONALAITY GLEANED DURING THE BODY
!
JJ=CURRINF_M-1; ! RT NALE
IF JJ>=0 START
COPYTAG(JJ)
WHILE K>0 CYCLE ; ! DOWN PARAM LIST
TCELL==ASLIST(K)
IF TCELL_PTYPE&X'F00'=X'500' AND TCELL_UIOJ&15=0 START
! TCELL IS ARRAY OF UNKNOWN DIMENSION
PCELL==ASLIST(TAGS(TCELL_UIOJ>>4));! ONTO LOCAL TAGS
TCELL_UIOJ=TCELL_UIOJ!PCELL_UIOJ&15;! COPY BACK DIMENSIO
FINISH
K=TCELL_LINK
REPEAT
FINISH
!
! NOW PLANT THE BLOCK EXIT SEQUENCE
!
FORCE TRIPS
IF KKK&X'3FFF'>=X'1000' THEN JJ=UCONSTTRIP(RTXIT,X'51',0,KKK)
JJ=UCONSTTRIP(XSTOP,X'51',0,KKK) IF KKK=1;! %STOP AT %ENDOFPROGRAM
CLEAR LIST(TWSPHEAD); ! CAN NOT CARRY FORWARD
CYCLE JJ=0,1,4
CLEAR LIST(CURRINF_AVL WSP(JJ));! RELEASE TEMPORARY LOCATIONS
REPEAT
FORCE TRIPS; ! PERQ NEED THIS BEFORE DTABLE AS
! DTABLE OFFSET GOES IN RTDICT
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
!
IF KKK=2 THEN RETURN
!
! RETURN TO PREVIOUS LEVEL PROVIDED THERE IS A VALID ONE !
!
UNLESS LEVEL>2 OR (LEVEL=2 AND PARM_CPRMODE=2) THEN START
IF KKK=1 AND LEVEL=2 THEN KKK=2 ELSE FAULT(109,0,0)
! SHOULD BE CHKD IN PASS1
FINISH
LEVEL=LEVEL-1
CURRINF==LEVELINF(LEVEL)
IF KKK>=X'1000' 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,1)
CURRINF_JROUND=0
FINISH
FINISH
RETURN
!
! LAYOUT OF DIAGNOSIC TABLES
! ****** ** ********* ******
!
! THE BOUND FIELD OF PLT DESCRIPTOR STORED AT (LNB+3 & LNB+4) IF
! USED TO CONTAIN A DISPLACEMENT RELATIVE TO THE START OF SST OF THE
! DIAGNOSTIC TABLES FOR THE BLOCK OR ROUTINE BEING EXECUTED.
! A ZERO BOUND MEANS NO DIAGNOSTIC REQUESTED.(NB THIS MAY MEAN A DUMMY
! FIRST WORD IN THE SST).
! THE ABSOLUTE ADDRESS OF THE SST FOR THE CURRENT CODE SEGMENT WILL
! ALWAYS BE FOUND IN THE STANDARD 10 WORDS OF THE GLA/PLT
!
! FORM OF THE TABLES:-
!
! WORD 0 = LINE OF RT IN SOURCE PROG <<16 ! LINE NO POSN(FROM LNB)
! WORD 1 = (12 LANG DEPENDENT BITS)<<18 ! ENVIRONMENT
! ( TOP 2 BITS OF LANG DEPENDENT HAS LITL FROM PTYPE)
! ( BOTTOM 4 BITS HAVE TEXTUAL LEVEL)
! WORD 2 = DISPLAY POSN (FROM LNB)<<16 ! RT TYPE INFO
! WORD 3 = ZERO FOR BLKS OR STRING(<=11BYTES) BEING THE
! RT NAME. THIS WILL TAKE WORDS 4 AND 5 IF NEEDED
! WORD 6 = LANGUAGE DEPENDENT INFO . IMP ON CONDITIONS ETC
!
! THE REST IS MADE UP OF VARIABLE ENTRIES AND THE SECTION IS TERMINATED BY
! A WORD OF X'FFFFFFFF'
!
! EACH VARIABLE ENTRY CONSISTS OF THE VARIABLE WORD FOLLOWED BY
! THE VARIABLE NAME AS A STRING. THE WORD CONSISTS OF
! BITS 2**31 TO 2**20 TYPE INFORMATION (MAY BE LANGUAGE DEPENDENT
! BIT 2**19 =0 UNDER LNB =1 IN GLA
! BITS 2**18 TO 2**0 DISPLACEMENT FROM LNB(GLA) IN BYTES
!
!
! THE ENVIRONMENT IS A POINTER (RELATIVE TO SST) OF THE NEXT OUTERMOST
! BLOCK OR A POINTER TO GLOBAL OWNS, EXTERNAL OR COMMON AREAS
! A ZERO MEANS NO ENCLOSING BLOCK. WORD1=WORD3=0 IS AN
! IMP MAIN PROGRAM AND WILL TERMINATE THE DIAGNOSTICS.
!
ROUTINE DTABLE(INTEGER LEVEL)
!***********************************************************************
!* THIS ROUTINE LOOKS AT THE DECLARATIONS FOR THE CURRENT LEVEL & *
!* SETS UP THE SEGMENT OF SHARABLE SYMBOL TABLES TO DESCRIBE THEM.*
!* FOR MAIN PROGRAMS OR EXTERNAL ROUTINES THE 'GLOBAL' VARIABLES *
!* (IF ANY) ARE ALSO INCLUDED. *
!***********************************************************************
STRING (11) RT NAME
STRING (11) LOCAL NAME
RECORDFORMAT HEADF(HALFINTEGER RTLINE,LINEOFF,OFLAGS,ENV,DISPLAY,
RTFLAGS,(INTEGER IDHEAD OR STRING (11)RTNAME))
RECORD (HEADF)NAME DHEAD
RECORDFORMAT VARF(HALFINTEGER FLAGS,DISP,STRING (11)VNAME)
RECORD (VARF)NAME VAR
RECORD (LISTF)NAME LCELL
CONSTINTEGER LARRROUT=X'F300'
RECORD (TAGF)T
INTEGER DPTR,LNUM,ML,KK,JJ,Q,DEND,BIT,S4,LANGD,II
CONSTINTEGER DLIMIT=700
INTEGERARRAY DD(0:DLIMIT); ! BUFFER FOR SEGMENT OF SST
!
! FILL ALL OUTSTANDING REFERENCES TO THIS DIAGS BLOCK
!
BIT=1<<LEVEL
LANGD=KKK>>14<<30!LEVEL<<18; ! GET LITL FROM PTYPE
FILL DTABREFS(CURRINF_RAL)
PUSH(LEVELINF(LEVEL-1)_RAL,DAREA,CAS(DAREA)+4,LANGD) IF PARM_TRACE#0
DHEAD==RECORD(ADDR(DD(0)))
DHEAD_RTLINE=CURRINF_L
DHEAD_LINEOFF=CURRINF_DIAGINF
IF TARGET=PERQ OR TARGET=ACCENT THEN DHEAD_LINEOFF=DHEAD_LINEOFF+2
DHEAD_OFLAGS<-LANGD>>16
DHEAD_ENV=0
DHEAD_DISPLAY=CURRINF_DISPLAY
DHEAD_RTFLAGS=CURRINF_FLAG&X'3FFF'
ML=CURRINF_M; ! ROUTINE NAME(=0 FOR %BEGIN)
IF ML#0 THEN ML=WORD(ML-1); ! IF NOT BLOCK GET DIRPTR
LNUM=WORKA_LETT(ML); ! LENGTH OF THE NAME
DPTR=4; DEND=0
IF LNUM=0 THEN DHEAD_IDHEAD=0 ELSE START
Q=ADDR(WORKA_LETT(ML))
RT NAME<-STRING(Q); ! FOR RTS MOVE IN 1ST 32 CHARS
LNUM=LENGTH(RT NAME)
DHEAD_RTNAME=RTNAME; ! AND UPDATE POINTER PAST
IF HOST#TARGET AND PARM_TRACE#0 THEN C
CHANGE SEX(ADDR(DD(0)),12,LNUM+1)
DPTR=DPTR+LNUM>>2; ! ACTUAL NO OF CHARS
FINISH
DD(DPTR)=CURRINF_ONWORD; ! ON CONDITION WORD
DPTR=DPTR+1
JJ=CURRINF_NAMES
WHILE 0<=JJ<X'3FFF' CYCLE
LCELL==ASLIST(TAGS(JJ))
T=LCELL
! OBTAIN NEXT NAME FORM DECLNS
!
! GET ONLY THE MINIMUM OF DETALS NECESSARY
!
S4=LCELL_LINK
LCELL_LINK=ASL; ASL=TAGS(JJ)
TAGS(JJ)=S4&X'3FFFF'
PTYPE=T_PTYPE; TYPE=PTYPE&15
!
! FAULT ALL UNUSED NAMES EXCEPT CONSTINTEGERS&REALS
!
IF (TYPE>2 OR PTYPE&X'FF00'#X'4000') C
AND T_UIOJ&X'C000'=0 THEN WARN(2,JJ)
I=T_UIOJ>>4&15
J=T_UIOJ&15
K=T_SLINK
!
! ALLOW OWNS (LITL=0) AND EXTERNALS (=2) NOT CONSTS(=1) OR EXTRINSIC(=3)
!
IF PARM_DIAG#0 AND PTYPE&X'7300'<=X'200' AND DPTR<DLIMIT-3 C
AND (1<=TYPE<=3 OR TYPE=5) START
Q=ADDR(WORKA_LETT(WORD(JJ))); ! ADDRESS OF NAME
IF I=0 THEN II=1 ELSE II=0; ! GLA OR LNB BIT
VAR==RECORD(ADDR(DD(DPTR)))
VAR_FLAGS<-PTYPE<<4!II<<2
IF TARGET=PNX AND PTYPE&X'C00'=0 AND II=0 AND C
(TYPE=3 OR TYPE=5) START ;! VALUE RECS&STRS
K=K+T_ACC
FINISH
VAR_DISP=K
LOCAL NAME<-STRING(Q); ! TEXT OF NAME FROM DICTIONARY
LNUM=LENGTH(LOCAL NAME)
VAR_VNAME=LOCAL NAME; ! MOVE IN NAME
IF HOST#TARGET AND PARM_TRACE#0 THEN C
CHANGE SEX(ADDR(DD(0)),4*DPTR+4,LNUM+1)
DPTR=DPTR+(LNUM+8)>>2
FINISH
IF J=15 AND PTYPE&X'3000'#0 AND T_UIOJ&X'C000'#0 THEN C
FAULT(28,0,JJ)
! SPEC&USED BUT NO BODY GIVEN
IF J=15 AND TYPE=4 THEN FAULT(62,0,JJ)
IF PTYPE&X'3000'#0 OR TYPE=4 OR TYPE=6 THEN C
CLEAR LIST(K) ELSE START
IF I#0 AND K>4095 AND PTYPE&LARRROUT=0 AND TYPE#7 C
THEN WARN(5,JJ)
FINISH
JJ=S4>>18
REPEAT
DD(DPTR)=-1; ! 'END OF SEGMENT' MARK
DPTR=DPTR<<2+4
IF PARM_TRACE=1 THEN C
PDATA(DAREA,4,DPTR,ADDR(DD(0)));! ADD TO SHARABLE SYM TABS
END ; ! OF ROUTINE DTABLE
END
ROUTINE DECLARE SCALARS(INTEGER XTRA)
!***********************************************************************
!* THIS ROUTINE DECLARES A LIST OF SCALARS FROM INFORMATION *
!* IN THE GLOBAL VARIABLES ROUT,NAM,ARR,PREC,TYPE & ACC.IT WORKS *
!* OUT ROUNDING FACTORS FOR ITSELF. *
!* P POINTS TO THE NAMELIST ON ENTRY AND IS UPDATED. *
!***********************************************************************
INTEGER INC,SCAL NAME,RL
PACK(PTYPE)
INC=ACC; SNDISP=0
IF NAM#0 AND ARR=0 AND ROUT=0 THEN INC=PTRSIZE(PTYPE&127)
IF NAM>0 AND ARR>0 THEN INC=AHEADSIZE
IF PTYPE=X'35' AND (ACC<=0 OR ACC>256) THEN C
FAULT(70,ACC-1,0) AND ACC=255
RL=ROUNDING LENGTH(PTYPE,1)
UNTIL A(P-1)=2 CYCLE ; ! DOWN THE NAMELIST
N=(N+RL+SFRAME MISALIGN)&(¬RL)-SFRAME MISALIGN
SCAL NAME=FROM AR2(P)
P=P+3
STORE TAG(SCAL NAME,LEVEL,RBASE,0,SNDISP,ACC,N,XTRA)
N=N+INC
REPEAT
N=(N+MIN PARAM SIZE-1)&(-MIN PARAM SIZE); ! THIS IS NECESSARY !
END
INTEGERFN DOPE VECTOR(INTEGER 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<BPAIR> *
!* PERQ&ACCENT DOPE VECTOR CONSISTS OF :- *
!* @0 DWORD CONTAINING THE BASE OFFSET *
!* @4 WORD CONTAINING THE NO OF DIMENSIONS ND *
!* @6 WORD HOLDING SIZE (IN BYTES) OF A SINGLE ELEMENT *
!* @8 DWORD OF 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) *
!* EMAS DOPE VECTOR CONSISTS OF:- *
!* @0 BOUNDED WORD DESCRPTOR BOUND=3*ND *
!* @8 THE ARRAY SIZE IN BYTES OF ENTIRE ARRAY *
!* @12 ND TRIPLES OF LB,MULT AND UPPER CHK AS PER VMY INSTRN *
!* NOTE TRIPLES IN REVERSE ORDER FOR HISTORIC COMPATABILITY *
!* MODE=0 DV MUST BE CONST, MODE#0 CAN BE DYNAMIC *
!* MODE=-1 SPECIAL FOR CONSTARRAYNAMES 1D 0:INFINITY *
!***********************************************************************
INTEGER I,JJ,K,ND,D,M0,HEAD,NOPS,TYPEPP,PIN
RECORD (LISTF) NAME LCELL
INTEGERARRAY LBH,LBB,UBH,UBB(0:12)
INTEGERARRAY DV(0:39); ! ENOUGH FOR 12 DIMENSIONS
ND = 0; NOPS = 0; TYPEPP = 0; PIN = P
M0 = 1
IF (TARGET=PERQ OR TARGET=ACCENT OR TARGET=PNX) AND ELSIZE>1 THEN C
ELSIZE=(ELSIZE+1)&(-2)
IF MODE=-1 THENSTART
ND = 1; LBB(1) = 0
IF TARGET=PERQ OR TARGET=ACCENT THEN ASIZE=X'7FFF' ELSE ASIZE=X'FFFFFF'
UBB(1)=ASIZE-1
UBH(1)=ASIZE
FINISHELSESTART
UNTIL A(P)=2 CYCLE
ND = ND+1; P = P+4
FAULT(37,0,IDEN) AND ND = 1 IF ND>12
LBH(ND) = 0; LBB(ND) = 0
UBB(ND) = 0; UBH(ND) = 0
TORP(LBH(ND),LBB(ND),NOPS)
P = P+3
TYPEPP = TYPEPP!TYPE
TORP(UBH(ND),UBB(ND),NOPS)
TYPEPP = TYPEPP!TYPE
REPEAT
P = P+1
->NONCONST UNLESS TYPEPP=1 AND NOPS&X'40040000'=0
!
! NOW ONE CAN WORK OUT AND FILL IN THE TRIPLES
!
ASIZE = 1
CYCLE D = 1,1,ND
K = 3*D
EXPOP(LBH(D),LBB(D),NOPS,X'251')
EXPOPND_D = 0 AND FAULT(41,0,0) UNLESS C
EXPOPND_FLAG<=1 AND EXPOPND_PTYPE=X'51'
LBB(D) = EXPOPND_D
EXPOP(UBH(D),UBB(D),NOPS,X'251')
EXPOPND_D = 10 AND FAULT(41,0,0) UNLESS C
EXPOPND_FLAG<=1 AND EXPOPND_PTYPE=X'51'
JJ = EXPOPND_D
UBB(D) = JJ
UBH(D) = JJ-LBB(D)+1; ! RANGE OF DTH DIMENSION
FAULT(38,1-UBH(D),IDEN) UNLESS JJ>=LBB(D)
ASIZE = ASIZE*UBH(D)
REPEAT
ASIZE = ASIZE*ELSIZE
FINISH
!
! CALCULATE THE OFF SET OF A(FIRST,..) FROM A(0,..)
!
LB = 0; I = ND
WHILE I>=2 CYCLE
LB = (LB+LBB(I))*UBH(I-1)
I = I-1
REPEAT
LB = LB+ LBB(1)
FAULT(39,0,IDEN) IF ASIZE>X'FFFFFF'
!
! SET UP THE DOPEVECTOR ALLOWING EACH TARGET ITS ODDITIES
!
IF TARGET=PERQ OR TARGET=ACCENT OR TARGET=PNX START
DV(2) = (ASIZE+1)>>1
DV(0) = -LB
DV(1) = ND<<16!ELSIZE
FINISH
IF TARGET=EMAS START
DV(0)=X'28000000'+3*ND
DV(1)=12; ! SO LDRL POINTS TO TRIPLES
DV(2)=ASIZE; ! FOR ARRAYS BY VALUE
IF TYPEP>=3 OR ELSIZE=2 THEN M0=ELSIZE
FINISH
IF TARGET=IBM OR TARGET=IBMXA START
DV(0)=ND
DV(1)=(ASIZE+7)&(-8)
DV(2)=ELSIZE
FINISH
CYCLE D=1,1,ND
IF TARGET=PERQ OR TARGET=ACCENT OR TARGET=PNX START
K=3*D
DV(K)=UBB(D)
DV(K+1)=LBB(D); ! LOWER BND OVER UPPER
M0=M0*UBH(D)
DV(K+2)=M0; ! RANGE
FINISH
IF TARGET=EMAS START
K=3*(ND+1-D); ! TRIPLES IN REVERSE ORDER
DV(K)=LBB(D)
DV(K+1)=M0; ! RUNNING MULTIPLIER
M0=M0*UBH(D); ! UPPED BY RANGE
DV(K+2)=M0
FINISH
IF TARGET=IBM OR TARGET=IBMXA START
K=3*D
DV(K)=LBB(D)
DV(K+1)=UBB(D)
DV(K+2)=M0*ELSIZE
M0=M0*UBH(D)
FINISH
REPEAT
K = 3*ND+2
J = ND; ! DIMENSIONALITY FOR DECLN
HEAD = DVHEADS(ND)
WHILE HEAD#0 CYCLE
LCELL == ASLIST(HEAD)
IF LCELL_S2=ASIZE START
CYCLE D = 0,1,K
->ON UNLESS DV(D)=CTABLE(D+LCELL_S1)
REPEAT
SNDISP = 4*LCELL_S1
RESULT = LCELL_S3
FINISH
ON:
HEAD = LCELL_LINK
REPEAT
SNDISP = 4*WORKA_CONST PTR
IF TARGET=PERQ OR TARGET=ACCENT THEN SSTL=(SSTL+3)&(-4) AND I = SSTL; ! PERQ DVS IN SST
IF TARGET=EMAS OR TARGET=PNX OR TARGET=IBM OR TARGET=IBMXA THEN I=SNDISP
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 HOST=EMAS AND (TARGET=PERQ OR TARGET=ACCENT) THEN C
DV(D) = DV(D)>>16!DV(D)<<16
REPEAT
IF WORKA_CONST PTR>WORKA_CONST LIMIT THEN FAULT(102,WORKA_WKFILEK,0)
IF TARGET=PERQ OR TARGET=ACCENT THEN C
PDATA(4,4,4*(K+1),ADDR(DV(0))) AND SSTL = SSTL+4*(K+1)
WAYOUT:
IF MODE=-1 THENRESULT = I; ! NO EXPRESSION CELLS TO RETURN
RESULT = I
NONCONST: ! NOT A CONST DV
J = ND; I = -1; SNDISP = -1
LB = 0; ASIZE = ELSIZE
IF MODE=0 THEN FAULT(41,0,0) ELSE P = PIN
CYCLE D=1,1,ND
CLEAR LIST(LBH(D))
CLEAR LIST(UBH(D))
REPEAT
->WAYOUT
END
ROUTINE DECLARE ARRAYS(INTEGER FORMAT,FINF)
!***********************************************************************
!* FORMAT=1 FOR 'ARRAYFORMAT' =0 OTHERWISE *
!* FINF>0 FOR RECORD FORMAT INFORMATION =0 OTHERWISE *
!* P IS AT P<ADECLN> IN *
!* *
!* P<ADECLN>=<NAMELIST> <BPAIR> <RESTOFDECLN> *
!* P<BPAIR> = '('<EXPR>':'<EXRR><RESTOFBP>*')' *
!* *
!* ARRAYS WITH CONSTANT BOUNDS HAVE THEIR D-V IN THE SST *
!* ALL OTHER ARRAYS HAVE A DOPE VECTOR AMONG THE LOCALS AND GET *
!* THEIR SPACE OFF THE STACK AT RUN TIME *
!* BOTH SORTS OF ARRAYS HAVE A FOUR WORD HEAD AND D-V TO EMAS *
!* SYSTEM STANDARDS *
!***********************************************************************
INTEGER DVDISP,PP,DVF,ELSIZE,TOTSIZE,PTYPEP,ARRP,NN,ND,II,CDV,LWB,
PTYPEPP,JJJ,JJ,TRIP1
RECORD (RD) OPND1
SAVE STACK PTR; ! FOR LATER UNDECLARING
ARRP=2*FORMAT+1; ARR=ARRP; PACK(PTYPEP)
ELSIZE=ACC
IF (TARGET=PERQ OR TARGET=ACCENT OR TARGET=PNX) AND ELSIZE>1 THEN C
ELSIZE=(ELSIZE+1)&(-2)
START:NN=1; P=P+1; ! NO OF NAMES IN NAMELIST
PP=P; CDV=0; PTYPEPP=PTYPEP
P=P+3 AND NN=NN+1 WHILE A(P+2)=1
P=P+3
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=0; TOTSIZE=X'FFFF'
N=(N+3)&(-4); ! MAY BE BENEFITS IN WORD ALIGNMENT
DVDISP=N; ! DVDISP IS D-V POSITION
N=N+12*ND+12; ! CLAIM SPACE FOR THE D-V
IF TARGET=PNX THEN DVDISP=N-4
TRIP1=ULCONSTTRIP(DVSTT,X'51',DONT OPT,ND<<16!ELSIZE,PTYPEP<<16!DVDISP); ! ASSN ND&DIMEN->DVDIPS+4
!
CYCLE II=1,1,ND
P=P+1
CSEXP(X'51'); ! LOWER BOUND
IF EXPOPND_FLAG>0 OR EXPOPND_D#0 THEN DVF=DVF!(1<<II);!NON ZERO
! BASE OFFSET NOT ZERO
OPND1=EXPOPND
CSEXP(X'51'); ! UPPER BOUND
TRIP1=BRECTRIP(DVBPR,X'51',DONT OPT,OPND1,EXPOPND)
TRIPLES(TRIP1)_X1=II<<24!ND<<16!DVDISP
REPEAT
P=P+1
SNDISP=0; ! DV NOT AVAILABLE AT COMPILETIME
IF DVF=0 THENSTART
LWB=0
IF FORMAT=0 THEN PTYPEPP=PTYPEP+256
FINISH
!***********************************************************************
!* FIND THE OFFSET OF A(0...) FROM A(FIRST...) BY COMPUTING *
!* THE OFFSET OF A(FIRST...) FROM A(0...) AND NEGATING *
!***********************************************************************
JJ=ULCONSTTRIP(DVEND,X'51',DONT OPT,DVF<<16!ELSIZE,PTYPEPP)
TRIPLES(JJ)_X1=ND<<16!DVDISP
->DECL
CONSTDV: ! ONE DIMENSION - CONSTANT BOUNDS
CDV=1
IF LWB=0 AND FORMAT=0 THEN PTYPEPP=PTYPEP+256
SNDISP=SNDISP>>2
! SET ARR=2 IF LWB=ZERO
IF PARM_COMPILER#0 AND LWB#0 THEN FAULT(99,0,0)
DECL: ! MAKE DECLN - BOTH WAYS
J=ND
N=(N+3)&(-4)
PTYPE=PTYPEPP; UNPACK
CYCLE JJJ=0,1,NN-1; ! DOWN NAMELIST
K=FROM AR2(PP+3*JJJ)
STORE TAG(K,LEVEL,RBASE,J,SNDISP,ELSIZE,N,FINF)
JJ=ULCONSTTRIP(DARRAY,X'61',0,
CDV<<31!JJJ<<24!(NN-1)<<16!DVDISP,K)
JJ=ULCONSTTRIP(ASPTR,X'61',0,
CDV<<31!SNDISP<<16!DVDISP,K) IF FORMAT=0
N=N+AHEADSIZE
REPEAT
P=P+1; ! PAST REST OF ARRAYLIST
IF A(P-1)=1 THEN ->START
RETURN
END
INTEGERFN ROUNDING LENGTH(INTEGER PTYPE,RULES)
!***********************************************************************
!* RULES=0 IN RECORDS(BEST DEFINED) *
!* RULES=1 IN STACK FRAME(MOST LATITUDE) *
!* RULES=2 AS PARAMETERS(FUNNY HARDWARE CONSIDERATIONS) *
!***********************************************************************
IF PTYPE&X'1000'#0 THEN RESULT =PTR ROUNDING(128*RULES)
! TREAT RT PARAMS AS %NAME
IF PTYPE&X'C00'#0 THEN RESULT =PTR ROUNDING(PTYPE&X'7F'+128*RULES)
RESULT =RNDING(PTYPE&X'7F'+128*RULES)
END
ROUTINE CLT
!***********************************************************************
!* DEAL WITH PHRASE TYPE AND SET PREC,TYPE & ACC *
!* ONLY PROBLEM ARE STRINGS WHICH HAS OPTIONAL MAX LENGTH ALSO *
!* RECORD WHICH HAVE A FORMAT *
!* P ON PHRASE TYPE AT ENTRY - TO NEXT PHRASE AT EXIT. *
!***********************************************************************
INTEGER ALT,PTYPEP,I,FLAGS,SJ
ALT=A(P)
FLAGS=TYPEFLAG(ALT)
IF FLAGS&X'8000'#0 THEN P=P+1 AND FLAGS=TYPEFLAG(A(P)+FLAGS&15)
IF FLAGS&X'4000'#0 THEN P=P+1;! ALLOWS BYTE OR BYTEINTEGER ETC
IF FLAGS&X'2000'#0 THEN WARN(8,0);! SUBSTITUTION MADE
IF FLAGS&X'1000'#0 THEN FAULT(99,0,0)
PREC=FLAGS>>4&15
TYPE=FLAGS&7
P=P+1
ACC=BYTES(PREC)
PACK(PTYPEP); ! PRESERVE ALL COMPONENT
! BEFORE CALLINT INTEXP ETC
IF TYPE=5 THEN START ; ! P<TYPE>='%STRING'
IF A(P)=1 THEN START ; ! MAX LENGTH GIVEN
IF A(P+1)=1 START ; ! EXPRESSION NOT STAR
P=P+4
IF INTEXP(I,MINAPT)#0 THEN FAULT(41,0,0)
ACC=I+1
PTYPE=PTYPEP; UNPACK
FINISH ELSE ACC=0 AND P=P+2
FINISH ELSE ACC=0 AND P=P+1
FINISH
KFORM=0
IF TYPE=3 THEN START
SJ=J
KFORM=CFORMATREF
PTYPE=PTYPEP
UNPACK
J=SJ
FINISH
END
ROUTINE CQN(INTEGER P)
!***********************************************************************
!* SET NAM & ARR FROM ALTERNATIVE OF PHRASE <QNAME'> *
!* P<QNAME'>='%ARRAYNAME','%NAME',<%NULL> *
!* P POINTS TO THE ANALYSIS RECORD ENTRY AS IS NOT UPDATED *
!***********************************************************************
INTEGER I
I=A(P);NAM=0;ARR=0
IF I=1 THEN ARR=1; ! ARRAYNAMES
IF I<=2 THEN NAM=1; ! ARRAYNAMES & NAMES
END
INTEGERFN SET SWITCHLAB(INTEGER HEAD,LAB,FNAME,BIT)
!***********************************************************************
!* SET A SWITCH LABEL AND RETURNS RESULT=0 %UNLESS THE LABEL *
!* HAS BEEN ALREADY SET WHEN IT RETURNS RESULT#0 *
!* HEAD IS HEAD OF THE TAGS SIDECHAIN FOR THE SWITCH *
!***********************************************************************
INTEGER Q,QQ,JJJ,LB,UB,BASEPT
RECORDFORMAT BITFORM(INTEGERARRAY BITS(0:2),INTEGER LINK)
RECORD (RD) OPND1,OPND2
RECORD (BITFORM)NAME BCELL
RECORD (LISTF)NAME LCELL
OLDLINE=0
LCELL==ASLIST(HEAD)
LB=LCELL_S2
UB=LCELL_S3
HEAD=LCELL_LINK
BCELL==ASLIST(HEAD)
UNLESS LB<=LAB<=UB THEN FAULT(50,LAB,FNAME) AND RESULT =0
Q=LAB-LB
WHILE Q>=96 CYCLE
HEAD=BCELL_LINK
BCELL==ASLIST(HEAD)
Q=Q-96
REPEAT
!
! ASLIST(HEAD) IS THE START OF 96 BIT ENTRY IN THE BIT LIST
! CHECK BIT NO Q TO SEE IF LABEL ALREADY SET AND THEN SET BIT Q
!
QQ=Q>>5; ! RIGHT WORD
Q=Q&31; JJJ=1<<Q; ! BIT IN WORD
RESULT =1 UNLESS BCELL_BITS(QQ)&JJJ=0
BCELL_BITS(QQ)=BCELL_BITS(QQ)!BIT<<Q;! DONT SET BIT ON SW(*) ENTRIES
OPND1_S1=X'56'<<PTSHIFT!DNAME<<FLAGSHIFT
OPND1_D=FNAME
OPND1_XTRA=0
OPND2_S1=X'51'<<PTSHIFT!SCONST<<FLAGSHIFT
OPND2_D=LAB
QQ=BRECTRIP(SETSW,X'56',0,OPND1,OPND2)
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,SACC,SKFORM
LITL=EXTRN&3
ACC=0; KFORM=0; ! FOR NORMAL RTS-CLT WILL REVISE
IF A(P)=1 THEN START ; ! P<RT>=%ROUTINE
TYPEP=LITL<<14!X'1000'
P=P+2; ! IGNORING ALT OF P(SPEC')
FINISH ELSE START ; ! P<RT>=<TYPE><FNORMAP>
ROUT=1; ARR=0; P=P+1
CLT; NAM=0
IF A(P)=2 THEN NAM=2; ! 2 FOR MAP 0 FOR FN
PACK(TYPEP)
P=P+2; ! AGAIN IGNORING ALT OF P(SPEC')
FINISH
KK=FROM AR2(P)
AXNAME=ADDR(WORKA_LETT(WORD(KK)))
JJ=0
P=P+3
SACC=ACC; SKFORM=KFORM; ! FOR RECORD MAPS WITH PARAMS
IF A(P-1)=1 THEN START
IF LITL=0 THEN WARN(10,0)
MOVE BYTES(A(P)+1,ADDR(A(0)),P,ADDR(A(0)),WORKA_ARTOP)
AXNAME=ADDR(A(WORKA_ARTOP))
WORKA_ARTOP=(WORKA_ARTOP+4+A(P))&(-4)
P=P+A(P)+1
FINISH
CFPLIST(OPHEAD,NPARMS)
IF M=1 THEN START
IF TARGET=EMAS OR TARGET=PNX THEN C
CXREF(STRING(AXNAME),3*PARM_DYNAMIC!EXTRN,2,JJ)
! %SYSTEM & %EXTERNAL =STATIC
! UNLESS PARM DYNAMIC SET
! %DYNAMIC = DYNAMIC
IF TARGET=PERQ OR TARGET=ACCENT THEN JJ=AXNAME-ADDR(A(WORKA_DICTBASE))
FINISH ELSE START
IF TARGET=PERQ OR TARGET=ACCENT THEN JJ=WORKA_RTCOUNT AND WORKA_RTCOUNT=WORKA_RTCOUNT+1
FINISH
IF M=0 AND RLEVEL=0 START
IF PARM_CPRMODE=0 THEN PARM_CPRMODE=2
IF PARM_CPRMODE#2 THEN FAULT(56,0,KK)
FINISH
J=15-M; PTYPE=TYPEP
STORE TAG(KK,LEVEL,RBASE,15-M,JJ,SACC,OPHEAD,SKFORM)
END
ROUTINE CFPLIST(INTEGERNAME OPHEAD,NPARMS)
!***********************************************************************
!* COMPILE A FORMAL PARAMETER PART INTO A LIST OF PARAMETER TYPES *
!* P(FPP)='('{(HOLE)(FPDEL)(NAMELIST)(MARK)}*')',0. *
!* *
!* THE LIST OF PARAMETER LOOKS LIKE:- *
!* S1 = PTYPE FOR PARAM<<16!LNAME<<12!DIMENSION(DIMEN DEDUCED LATER)*
!* LNAME IS PARAMS LOCAL NAME *
!* S2 = PARAMETER OFFSET(SNDISP) <<16 ! ACC *
!* S3 = 0 (RESERVED FOR FPP OF RTS) *
!* *
!* ON ENTRY P IS AT ALT OF FPP (WHICH MAY BE NULL) *
!***********************************************************************
INTEGER OPBOT, PP, INC, RL, RSIZE, CELL
RECORD (LISTF)NAME LCELL
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
IF ARR=1 THEN START
INC=AHEADSIZE;
RL=ROUNDING LENGTH(AHEADPT,2)
FINISH ELSE IF NAM=1 AND ROUT=0 THEN START
INC=PTRSIZE(PTYPE&X'7F')
RL=PTRROUNDING(PTYPE&X'7F'+256)
FINISH ELSE IF STRVALINWA=YES AND PTYPE=X'35' THEN START
INC=PTRSIZE(X'35')
RL=PTRROUNDING(256+X'35')
FINISH ELSE IF TARGET=EMAS AND PTYPE=X'33' THEN START
INC=ACC+8; ! ALLOW FOR DESCRPTR FOR IMP80 COMPATABILITY
RL=3; ! STRICTLY ROUNDING LENGTH(X'33',2)
FINISH ELSE INC=ACC AND RL=ROUNDING LENGTH(PTYPE,2)
UNTIL A(P-1)=2 CYCLE ; ! DOWN <NAMELIST> FOR EACH DEL
IF PARAMS BWARDS=YES THEN START
PUSH(OPHEAD,0,0,RL)
CELL=OPHEAD
FINISH ELSE START
BINSERT(OPHEAD,OPBOT,0,0,RL)
CELL=OPBOT
FINISH
LCELL==ASLIST(CELL)
LCELL_PTYPE=PTYPE; ! DIRECT "PUS" FAILS ON HALF SWOPPED MACHINES
LCELL_SNDISP=INC
LCELL_ACC=ACC
NPARMS=NPARMS+1
P=P+3
REPEAT
P=PP
REPEAT
OPBOT=OPHEAD; INC=0; ! FURTHER PASS TO ALLOCATE SPACE
WHILE OPBOT>0 CYCLE
LCELL==ASLIST(OPBOT)
RL=LCELL_S3; LCELL_S3=0; ! EXTRACT ROUNDIMG LENGTH
RSIZE=LCELL_SNDISP; ! INC EXTRACTED
INC=(INC+RL+SFRAME MISALIGN)&(¬RL)-SFRAME MISALIGN
IF PARAMSBWARDS=NO AND RSIZE<MINPARAMSIZE AND LCELL_PTYPE&7<=2 C
THEN INC=INC+MINPARAMSIZE-RSIZE
! MAINTAIN BYTES &SHORTS IN BTM
! OF WORDS FOR 2900&IBM ARCHITECTURE
LCELL_SNDISP=INC; ! THE PARAMETER OFFSET
INC=INC+RSIZE
OPBOT=LCELL_LINK
REPEAT
INC=(INC+RL+SFRAME MISALIGN)&(¬RL)-SFRAME MISALIGN
P=P+1
PRINT LIST(OPHEAD) IF PARM_Z#0
IF TARGET=PNX AND INC&7#0 START ;! FUNNY STACK RULES ON PNX
INC=INC+4
OPBOT=OPHEAD
WHILE OPBOT#0 CYCLE
LCELL==ASLIST(OPBOT)
LCELL_SNDISP=LCELL_SNDISP+4
OPBOT=LCELL_LINK
REPEAT
FINISH
IF NPARMS>0 THEN ASLIST(OPHEAD)_S3=INC<<16!NPARMS
PRINTLIST(OPHEAD) IF PARM_Z#0
END
ROUTINE CFPDEL
!***********************************************************************
!* SET UP PTYPE & ACC FOR A FORMAL PARAMETER DEFINITION *
!* P<FPDEL>=<TYPE><%QNAME'>, *
!* (RT)(%NAME')(NAMELIST)(FPP), *
!* '%NAME'. *
!***********************************************************************
SWITCH FP(1:3)
INTEGER FPALT
FPALT=A(P); P=P+1
KFORM=0; LITL=0
->FP(FPALT)
FP(1): ! (TYPE)(%QNAME')
ROUT=0; CLT
CQN(P)
IF TYPE=5 AND NAM=0 AND (ACC<=0 OR ACC>256) THEN C
FAULT(70,ACC-1,0) AND ACC=255
P=P+1
->PK
FP(2): ! (RT)(%NAME')(NAMELIST)(FPP)
ROUT=1; NAM=1
ARR=0
IF A(P)=1 THEN START ; ! RT=%ROUITNE
TYPE=0; PREC=0
P=P+2
FINISH ELSE START
P=P+1; CLT; ! RT=(TYPE)(FM)
NAM=1
IF A(P)=2 THEN NAM=3; ! 1 FOR FN 3 FOR MAP
P=P+2; ! PAST (%NAME') WHICH IS IGNORED
FINISH
ACC=RT PARAM SIZE
->PK
FP(3): ! %NAME
ACC=PTRSIZE(0); NAM=1
ROUT=0; TYPE=0
ARR=0; PREC=0
PK: PACK(PTYPE)
END
ROUTINE RHEAD(INTEGER RTNAME,AXNAME)
!***********************************************************************
!* COMPILES CODE FOR BLOCK AND ROUTINE ENTRY *
!* RTNAME IS THE RT/FN/MAP NAME (=-1 FOR %BEGIN BLOCKS) *
!* XNAME IS THE EXTERNAL NAME (="" FOR INTERNALS&BLOCKS *
!* ACTIONS INCLUDE PLANTING JUMPS ROUND RT BODY AND *
!* DEFINING EXTERNAL ENTRIES AS WELL AS PLANTING ENTRY CODE *
!***********************************************************************
INTEGER W3
RECORD (LISTF)NAME LCELL
CURRINF_SNMAX=NMAX; CURRINF_SN=N
IF RTNAME>=0 THEN START ; ! SECTION FOR ROUTINES
LCELL==ASLIST(TAGS(RTNAME))
!
! FIRST JUMP ROUND BODY UNLESS AT TOP LEVEL OR IN COMPILER
! OR A JUMP IS ALREADY OUTSTANDING AT THIS LEVEL
! MUST DO THIS HERE BEFORE LEVEL IS CHANGED OR LABEL LIST IS WRONG
!
IF PARM_COMPILER=0 AND LEVEL>1 AND CURRINF_JROUND=0 START
PLABEL=PLABEL-1
CURRINF_JROUND=PLABEL
IF JRNDBODIES=YES THEN ENTER JUMP(15,PLABEL,0)
FINISH
RLEVEL=RLEVEL+1; RBASE=RLEVEL
FINISH
LEVEL=LEVEL+1
CURRINF==LEVELINF(LEVEL)
CURRINF=0
CURRINF_RBASE=RBASE
CURRINF_CLEVEL=LEVEL; ! SELF POINTER IS NEEDED IN GENERATE
CURRINF_NAMES=-1
CURRINF_DIAGINF=LEVELINF(LEVEL-1)_DIAGINF
CURRINF_DISPLAY=LEVELINF(LEVEL-1)_DISPLAY
FAULT(34, 0, 0) IF LEVEL=MAX LEVELS
FAULT(105, 0, 0) IF LEVEL>MAX LEVELS
!
! DEAL WITH EXTERNAL ENTRIES SO THAT THEY COME TO THIS POINT
! IN THE CODE. THE DESCRIPTORS SET UP ARE OF NO INTEREST TO THIS MODULE
! ONLY TO OTHER MODULES SO NO DETAILS OF THEN ARE RECORDED IN TAGS
!
IF RTNAME<0 THEN W3=0 ELSE W3=RTNAME+1
CURRINF_L=LINE; CURRINF_M=W3
CURRINF_FLAG=PTYPE; ! 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
!
W3=ULCONSTTRIP(RTHD,X'61',0,RTNAME,AXNAME)
END
ROUTINE RDISPLAY(INTEGER KK)
!***********************************************************************
!* SET UP OR COPY THE DISPLAY *
!* SINCE THIS IS IN REGISTERS ON 360 IT IS EASY *
!* ALSO CLAIM STACK SPACE AND SET DIAGNOSTIC POINTERS *
!***********************************************************************
INTEGER TRIPNO
IF KK>=0 OR LEVEL=2 START ; ! DISPLAY NEEDED
! DONE BY THE QCODE CALL
CURRINF_PSIZE=N; ! REMEMBER PARAMETER SIZE FOR RTDICT
IF DISPLAY NEEDED=YES START
CURRINF_DISPLAY=N
N=N+4*RLEVEL; ! RESERVE DISPLAY SPACE
IF TARGET=PNX THEN N=N+4;! GLOBALS ALSO IN PNX DISPLAY
FINISH
TRIPNO=UCONSTTRIP(RDSPY,X'51',0,N)
FINISH
!
! IF IN DIAGNOSTIC MODE PLANT CODE TO SAVE THE LINE & ROUTINE NO OF
! THE CALLING ROUTINE AND SET UP THE NEW BLOCK/ROUTINE IDENT NO.
!
IF PARM_TRACE#0 START
IF KK>=0 OR LEVEL=2 START ; ! ROUTINE NEW AREA NEEDED
TRIPNO=UCONSTTRIP(RDAREA,X'51',0,N)
N=N+4
CURRINF_DIAGINF=N
N=N+4
FINISH
TRIPNO=UCONSTTRIP(RDPTR,X'51',0,LEVEL)
FINISH
OLDLINE=0
SET LINE
!
! NORMALLY CODE IS PLANTED HERE TO CHECK PARAMETERS BUT I CANNOT
! SEE HOW TO DO THIS ON PERQ ARCHITECTURE. IT MAY BE IN THE QCODE ANYHOW
!
!
! CLAIM (THE REST OF) THE STACK FRAME
!
IF KK>=0 OR LEVEL=2 START
NMAX=N
FINISH
END
ROUTINE CUI(INTEGER CODE)
!***********************************************************************
!* COMPILE AN UNCONDITIONAL INSTRN WHEREEVER IT OCCURS *
!* CODE=0 UNCONDITIOALLY,=1 AFTER %THEN, =2 AFTER %ELSE *
!***********************************************************************
INTEGER MARKER,J,LNAME,TYPEP,PRECP,ALT,KK
RECORD (RD) OPND1
INTEGER HEAD1,BOT1,NOPS
RECORD (RD)RPOP
SWITCH SW(1:9)
REPORTUI=0
ALT=A(P)
->SW(ALT)
SW(1): ! (NAME)(APP)(ASSMNT?)
P=P+1; MARKER=P+FROMAR2(P)
IF A(MARKER)=1 THEN START
J=P+2; P=MARKER+2
ASSIGN(A(MARKER+1),J)
FINISH ELSE START
P=P+2
CNAME(0)
P=P+1
FINISH
AUI: J=A(P); P=P+1
IF J=1 THEN CUI(CODE)
RETURN
SW(2): ! -> (NAME)(APP)
CURRINF_NMDECS=CURRINF_NMDECS!1
CURR INST=1 IF CODE=0
LNAME=FROM AR2(P+1)
J=A(P+3); P=P+4
IF J=2 THEN START ; ! SIMPLE LABEL
ENTER JUMP(15,LNAME,0)
REPORTUI=1
FINISH ELSE START ; ! SWITCH LABELS
COPY TAG(LNAME)
UNLESS OLDI=LEVEL AND TYPE=6 START
FAULT(4,0,LNAME); P=P-1; SKIP APP
RETURN
FINISH
CSEXP(MINAPT)
OPND1_S1=PTYPE<<PTSHIFT!DNAME<<FLAGSHIFT
OPND1_D=LNAME
OPND1_XTRA=0
KK=BRECTRIP(GOTOSW,PTYPE,0,OPND1,EXPOPND)
REPORTUI=1
FINISH
RETURN
SW(3): ! RETURN
FAULT(30,0,0) UNLESS CURRINF_FLAG&X'3FFF'=X'1000'
P=P+1
RET: KK=UCONSTTRIP(RTXIT,X'51',0,0)
REPORT UI=1
CURR INST=1 IF CODE=0
RETURN
SW(4): ! %RESULT(ASSOP)(EXPR)
PTYPE=CURRINF_FLAG&X'3FFF'; UNPACK
OPND1=0
OPND1_S1=PTYPE<<PTSHIFT!DNAME<<FLAGSHIFT
OPND1_D=CURRINF_M-1
IF PTYPE>X'1000' AND A(P+1)#3 THEN START ;! ASSOP #'->'
IF A(P+1)=1 AND NAM#0 AND A(P+5)=4 AND A(P+6)=1 START
P=P+7; TYPEP=TYPE; PRECP=PREC; J=P
CNAME(4)
KK=BRECTRIP(MAPRES,PTYPE&255,0,OPND1,NAMEOPND)
FAULT(81,0,0) UNLESS A(P)=2; P=P+1
FAULT(83,CURRINF_M-1,FROMAR2(J)) C
UNLESS TYPEP=TYPE AND PRECP=PREC
->RET
FINISH
IF A(P+1)=2 AND NAM=0 THEN START ;! ASSOP='='
P=P+2
IF TYPE=5 THEN START
CSTREXP(32); ! FULL VIRTAD
FINISH ELSE START
IF PREC<4 THEN PREC=4
CSEXP(PREC<<4!TYPE)
FINISH
KK=BRECTRIP(FNRES,PTYPE&255,0,OPND1,EXPOPND)
->RET
FINISH
FINISH
FAULT(31,0,0)
P=P+2; SKIP EXP; ! IGNORE SPURIOUS RESULT
RETURN
SW(5): ! %MONITOR (AUI)
KK=UCONSTTRIP(MNITR,X'51',0,0)
P=P+1; ->AUI
SW(6): ! %STOP
KK=UCONSTTRIP(XSTOP,X'51',0,0)
P=P+1
CURR INST=1 IF CODE=0
REPORTUI=1
RETURN
SW(7): !'%SIGNAL'(EVENT')(N)(OPEXPR)
P=P+5
KK=INTEXP(J,MINAPT); ! EVENT NO TO J
FAULT(26,J,0) UNLESS KK=0 AND 1<=J<=15
HEAD1=0; NOPS=0
RPOP=0
RPOP_PTYPE=X'51'
RPOP_FLAG=1
RPOP_D=256*J
PUSH(HEAD1,RPOP_S1,RPOP_D,0); ! EVENT<<8 AS CONST
BOT1=HEAD1
IF A(P)=1 START ; ! SUBEVENT SPECIFIED
PUSH(HEAD1,ANDL<<FLAGSHIFT,0,0);! OPERATOR &
RPOP_PTYPE=X'51'
RPOP_FLAG=1
RPOP_D=255
PUSH(HEAD1,RPOP_S1,RPOP_D,0); ! CONST=F'255'
P=P+4; TORP(HEAD1,BOT1,NOPS)
BINSERT(HEAD1,BOT1,ORL<<FLAGSHIFT,0,0); ! OPERATOR !
NOPS=NOPS+2
FINISH
EXPOP(HEAD1,BOT1,NOPS,X'51')
OPND1_PTYPE=X'51'; OPND1_FLAG=SCONST
OPND1_D=LEVEL
IF CURRINF_NMDECS&16 #0 START ; ! IN AN 'ON' GROUP
OPND1_D=LEVEL-1; ! SIGNAL 1 LEVEL UP
FINISH
KK=BRECTRIP(SIGEV,X'51',DONTOPT,OPND1,EXPOPND)
CURR INST=1 IF CODE=0
REPORTUI=1; RETURN
SW(8): ! %EXIT
SW(9): ! %CONTINUE
ALT=ALT&7; ! 0 FOR EXIT 1 FOR CONTINUE
IF EXITLAB=0 THEN FAULT(54+ALT,0,0) AND RETURN
IF ALT=0 THEN KK=EXITLAB ELSE KK=CONTLAB
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'->'<LABEL>
CURRINF_NMDECS=CURRINF_NMDECS!1
CCRES=CCOND(0,3-MARKIU,USERLAB&X'FFFFFF',USERLAB>>31)
IF CCRES#0 THEN CCRES=CCRES!!3;! CONDITION BACKWARDS!
THENLAB=0; ! NO THENLAB IN THIS CASE
REPORT=1; ! UI TRANSFERED CONTROL
FINISH ELSE START
CCRES=CCOND(1,MARKIU,THENLAB,B'11'!!START!!CS)
IF START#0 THEN START ; ! %THEN %START
IF CCRES=0 START ; ! CONDITIONAL
FAULT(57,0,0) IF LEVEL<2
CURRINF_NMDECS=CURRINF_NMDECS!1
FINISH
P=MARKR+1
CSTART(CCRES,1)
IF A(P)<=2 THEN PLABEL=PLABEL-1 AND ELSELAB=PLABEL
MARKE=P
REPORT=LAST INST
FINISH ELSE START
IF CCRES#2 START
P=MARKUI; CUI(1)
REPORT=REPORTUI
FINISH ELSE START ; ! FIRST UI NEVER EXECUTED
REPORT=1
FINISH
FINISH
FINISH
ELSE: ! ELSE PART
IF MARKE=0 THEN ELSEALT=NULL ELSE ELSE ELSEALT=A(MARKE)
IF ELSEALT<NULL ELSE THEN PLABEL=PLABEL-1 AND ELSELAB=PLABEL
P=MARKE+1
IF REPORT=0=CCRES AND ELSEALT<NULL ELSE THEN START
REPORT=1
K=B'10'
IF (ELSEALT=3 AND STARSIZE<100) OR C
(ELSEALT=1 AND CHECK BLOCK(P,P)#0) THEN K=B'11'
ENTER JUMP(15,ELSELAB,K); ! LONG(?) JUMP BUT SAVE ENV
FINISH
IF THENLAB>0 THEN ELRES=ENTER LAB(THENLAB,B'11'!REPORT<<2)
! CONDITIONAL&MERGE OR REPLACE
->ESW(ELSEALT)
ESW(1): ! '%ELSESTART'
IF CCRES=0 THEN CURRINF_NMDECS=CURRINF_NMDECS!1
CSTART(CCRES,2)
REPORT=LAST INST
->ENTER ELSELAB
ESW(2): ! '%ELSE' (%IU) ETC
MARKE=0; MARKUI=0
MARKR=P+1+FROMAR2(P+1)
IF A(MARKR)=3 THEN START
MARKE=MARKR+1+FROM AR2(MARKR+1)
MARKUI=MARKR+3
FINISH
IF CCRES=1 OR SKIP=YES THEN K=YES ELSE K=NO
CIFTHEN(P,P+3,MARKUI,MARKE,MARKR,K)
REPORT=0; ! CANT TELL IN GENERAL
->ENTER ELSELAB
ESW(3): ! '%ELSE'<UI>
IF CCRES#1 THEN START
IF START#0 THEN SET LINE; ! FOR CORRECT LINE IF FAILS IN UI
IF THENLAB=0 THEN K=0 ELSE K=2
CUI(K)
REPORT=REPORTUI
FINISH
ENTER ELSELAB:
IF ELSELAB>0 THEN ELRES=ENTER LAB(ELSELAB,B'11'!REPORT<<2)
! CONDITIONAL MERGE
ESW(NULL ELSE): ! NULL ELSE CLAUSE
END
INTEGERFN CHECKBLOCK(INTEGER P,PIN)
!***********************************************************************
!* WORK OUT IF START-FINISH OR CYCLE REPEAT IS SHORT ENOUGH TO *
!* MANAGE WITH BYTE JUMP. PIN ALLOWS THE CONDITION TO BE INCLUDED *
!* IN THE TEST WHERE RELEVANT. *
!***********************************************************************
INTEGER SIZE
SIZE=FROMAR4(P)-PIN
IF SIZE<64 OR (PARM_OPT=0 AND SIZE<128) THEN RESULT =1
RESULT =0
END
ROUTINE CSTART(INTEGER CCRES,CODE)
!***********************************************************************
!* COMPILE A COMPLETE START-FINISH BLOCK BY RECURSION *
!* IF START NEVER EXECUTED SKIP TO CORRESPONDING FINISH *
!* CODE=0 WAS UNCONDITIONAL NOW SHOULD BE UNUSED *
!* CODE=1 AFTER THEN *
!* CODE=2 AFTER ELSE *
!* CODE=3 AFTER ONEVENT *
!* P ON ENTRY TO FORWARD POINTER TO THE RIGHT FINISH *
!* P ON EXIT TO THE ELSE CLAUSE AFTER THE RIGHT FINISH *
!***********************************************************************
INTEGER SKIPCODE,FINISHAR,OLDNEXTP,OLDLINE
SKIPCODE=NO
IF 1<=CODE<=2 AND CCRES!CODE=3 THEN SKIPCODE=YES;! NEVER EXECUTED
FINISHAR=FROMAR4(P); ! TO START OF AR FOR FINISH
IF FINISHAR<=P THEN IMPABORT; ! FOR TESTING
OLDLINE=LINE; ! FOR ERROR MESSAGES
CYCLE ; ! THROUGH INTERVENING STATMNTS
OLDNEXTP=NEXTP
IF SKIP CODE=NO THEN COMPILE A STMNT ELSE START
LINE=A(NEXTP+3)<<8!A(NEXTP+4)
STARSIZE=A(NEXTP)<<16+A(NEXTP+1)<<8+A(NEXTP+2)
NEXTP=NEXTP+STARSIZE
FINISH
REPEAT UNTIL OLDNEXTP>=FINISHAR;! HAVING COMPILED FINISH
P=FINISHAR+6; ! TO ELSE CLAUSE
!
IF A(P)<=3 AND CODE#1 THEN FAULT(45+CODE,OLDLINE,0)
IF SKIPCODE=YES THEN LAST INST=1
END
ROUTINE CCYCBODY(INTEGER UA,ELAB,CLAB)
!***********************************************************************
!* COMPILES A CYCLE REPEAT BODY BY RECURSION *
!* ON ENTRY P IS TO FORWARD POINTER. ON EXIT TO ALT OF UNTIL *
!* UA = O IF UNTIL NOT ALLOWED *
!* ELAB&CLAB ARE LABELS FOR ELSE & CONTINUE *
!***********************************************************************
INTEGER FINISHAR,OLDLINE,SAVEE,SAVEC
FINISHAR=FROMAR4(P)
IF FINISHAR<=P THEN IMPABORT
OLDLINE=LINE; SAVEE=EXIT LAB; SAVEC=CONTLAB
EXITLAB=ELAB; CONTLAB=CLAB
WHILE NEXTP<=FINISHAR CYCLE
COMPILE A STMNT
REPEAT
EXIT LAB=SAVEE; CONTLAB=SAVEC
P=FINISHAR+6
IF A(P)=1 AND UA=0 THEN FAULT(12,OLDLINE,0)
END
ROUTINE CLOOP(INTEGER ALT,MARKC,MARKUI)
!***********************************************************************
!* ALT=1 FOR %WHILE, =2 FOR %UNTIL, =3 FOR %FOR *
!* MARKC IS TO THE CONDITION OR CONTROL CLAUSE *
!* MARKUI IS TO THE UI, SPECIAL FOR %CYCLE *
!* FORBITS DEFINES FOR LOOP AS FOLLOWS:- *
!* 2**2 TO 2**0 SET FOR CONSTANT INITIAL,INC &FINAL *
!* CORRESPONDING UPPER BYTE SET DEFINES CONSTANT FURTHER *
!* 2**7 NEGATIVE CONSTANT *
!* 2**4 CONSTANT IS 2 *
!* 2**3 CONSTANT IS 1 *
!* 2**2 CONSTANT IS 0 *
!* 2**1 CONSTANT IS -1 *
!* 2**0 CONSTANT IS -2 *
!* THESE BITS ARE PASSED ON TO GENERATOR FOR SPECIAL CASE *
!***********************************************************************
INTEGER L1,L2,L3,L4,CCRES,ELRES,FLINE,TRIP
INTEGER FORNAME,INITP,STEPP,REPMASK,FORPT,FORWORDS,FORBITS
RECORD (RD) INITOPND,STEPOPND,FINALOPND,DIFFOPND,ZOPND,OPND
RECORD (TRIPF) NAME CURRT
ROUTINESPEC FOREXP(RECORD (RD) NAME EOPND, INTEGER TT,SH)
ROUTINESPEC VALIDATE FOR
SWITCH SW(0:6)
P=MARKC
FORBITS=0
SFLABEL=SFLABEL-2
L1=SFLABEL; L2=L1+1
!
! SET L3 FOR ALTS 0,5&6 ONLY
!
L3=0
IF B'1100001'&1<<ALT#0 THEN L3=SFLABEL-1 AND SFLABEL=L3
!
! UPDATE THE LINE NUMBER FOR ALTS 1 TO 3 ONLY
!
IF 1<=ALT<=3 THEN SET LINE
!
! ENTER THE FIRST LABEL FOR ALL ALTS EXCEPT 3 & 6
!
IF B'0110111'&1<<ALT#0 THEN ELRES=ENTER LAB(L1,0)
->SW(ALT)
SW(0): ! %CYCLE
C CYC BODY(1,L2,L3)
L3=L3*ENTER LAB(L3,B'011'); ! DELETE IF NOT NEEDED
IF A(P)=1 START ; ! %REPEAT %UNTIL <COND>
SET LINE
P=P+1; CCRES=CCOND(0,1,L1,0)
FINISHELSE ENTER JUMP(15,L1,0)
L2=L2*ENTER LAB(L2,B'011'); ! DELETE IF NOT NEEDED
WAYOUT: ! REMOVE LABELS NOT REQUIRED
REMOVE LAB(L1)
RETURN
SW(1): ! UI WHILE COND
CCRES=CCOND(0,1,L2,B'11')
P=MARKUI
CUI(1)
ENTER JUMP(15,L1,0); ! UNCONDITIONALLY BACK TO WHILE
L2=L2*ENTER LAB(L2,B'111'); ! CONDITIONAL(?) & REPLACE ENV
->WAYOUT
SW(2): ! UI %UNTIL COND
P=MARKUI
CUI(1)
P=MARKC
CCRES=CCOND(0,1,L1,0)
->WAYOUT
SW(6): ! %FOR ... %CYCLE
SW(3): ! UI %FOR ....
L4=SFLABEL-1; SFLABEL=L4
FORNAME=FROMAR2(P)
INITP=P+2
COPY TAG(FORNAME)
IF I=-1 THEN CNAME(2); ! DECLARE IF UNKNOWN TO COMPILER
FAULT(91,0,FORNAME) UNLESS C
(TYPE=7 OR TYPE=1) AND 4<=PREC<=5 AND ROUT=0=ARR AND LITL#1
FORPT=PTYPE&255; ! SAVE TYPE&PREC OF CONTROL
FORWORDS=WORDS(FORPT>>4); ! NO OF WORDS FOR TEMPS
WARN(4,FORNAME) UNLESS I=RBASE
!
P=INITP
SKIP EXP; ! P TO STEP EXPRSN
STEPP=P; SKIP EXP; ! P TO FINAL
FOR EXP(FINALOPND,1,0); ! EVALUATE FINAL
!
P=STEPP
FOR EXP(STEPOPND,1,1); ! STEP TO REG AND TEMP
IF STEPOPND_FLAG=0 START
FAULT(92,0,0) IF STEPOPND_D=0; ! ZERO STEP
FINISHELSESTART
IF PARM_OPT#0 THENSTART
TRIP=URECTRIP(STPCK,FORPT,0,STEPOPND); ! VALIDATE STEP
FINISH
FINISH
!
P=INITP
FOR EXP(INITOPND,0,2); ! INITIAL VALUE TO ETOS
IF PARM_OPT#0 THEN VALIDATE FOR
!
DIFFOPND_D=BRECTRIP(SUB,FORPT,0,INITOPND,STEPOPND)
DIFFOPND_PTYPE=FORPT; DIFFOPND_FLAG=REFTRIP
!
! HAVE DIFFOPND SET TO INIT-STEP. FOR COMPUTED STEPS NOW MUST CHECK
! FOR NEGATIVE TRAVERSES. FOR FIXED STEPS THIS CAN BE SET
! IN MASK FOR REPEATING
!
IF STEPOPND_FLAG>0 THENSTART
OPND_D=BRECTRIP(SUB,FORPT,0,FINALOPND,DIFFOPND)
OPND_PTYPE=FORPT; OPND_FLAG=REFTRIP
OPND_D=BRECTRIP(INTDIV,FORPT,0,OPND,STEPOPND)
ZOPND_D=0; ZOPND_PTYPE=FORPT; ZOPND_FLAG=SCONST
CURRT==TRIPLES(BRECTRIP(COMP,FORPT,0,OPND,ZOPND))
CURRT_X1=4; ! MASK FOR <0
ENTER JUMP(4,L4,B'10')
REPMASK=8
FINISHELSESTART
IF STEPOPND_D>0 THEN REPMASK=10 ELSE REPMASK=12
FINISH
!
DIFFOPND_D=URECTRIP(FORPRE,FORPT,0,DIFFOPND)
TRIPLES(DIFFOPND_D)_X1=FORBITS
!
! MUST PREVENT OPTIMISING OF UNUSED STEP&FINAL TEMPORAIES IN
! REGISTERS ACCROSS THIS LABEL FOR REPEATING. THE OPTIMISING CAN
! BE REINSTATED BY NEXT PASS AFTER CHECKS
!
IF STEPOPND_FLAG>1 START ; ! NOT A CONST
CURRT==TRIPLES(STEPOPND_D)
IF CURRT_PUSE=0 THEN CURRT_FLAGS=CURRT_FLAGS!NOTINREG
FINISH
IF FINALOPND_FLAG>1 START ; ! NOT A CONST
CURRT==TRIPLES(FINALOPND_D)
IF CURRT_PUSE=0 THEN CURRT_FLAGS=CURRT_FLAGS!NOTINREG
FINISH
ELRES=ENTER LAB(L1,0); ! LABEL FOR REPEATING
DIFFOPND_D=URECTRIP(FORPR2,FORPT,USE ESTACK,DIFFOPND)
TRIPLES(DIFFOPND_D)_X1=FORBITS
!
CURRT==TRIPLES(BRECTRIP(COMP,FORPT,0,DIFFOPND,FINALOPND))
CURRT_X1=REPMASK
ENTER JUMP(REPMASK,L4,B'10')
OPND_D=BRECTRIP(ADD,FORPT,0,DIFFOPND,STEPOPND)
OPND_PTYPE=FORPT; OPND_FLAG=REFTRIP
ZOPND_PTYPE=FORPT; ZOPND_FLAG=DNAME
ZOPND_D=FORNAME
ZOPND_XTRA=0
CURRT==TRIPLES(BRECTRIP(VASS,FORPT,0,ZOPND,OPND))
CURRT_X1=FORPT; ! VASS USES THIS FIELD
!
P=MARKUI; ! TO UI OR '%CYCLE'(HOLE)
IF ALT=3 THENSTART ; ! DEAL WITH CONTROLLED STMNTS
CUI(0)
FINISHELSESTART
CCYCBODY(0,L2,L3)
L3=L3*ENTER LAB(L3,B'011'); ! LABEL FOR CONTINUE
FINISH
TRIP=UNAMETRIP(FOREND,FORPT,0,FORNAME)
TRIPLES(TRIP)_X1=FORBITS
ENTER JUMP(15,L1,0)
ELRES=ENTER LAB(L4,B'10')
TRIP=UCONSTTRIP(FORPOST,FORPT,0,0)
TRIPLES(TRIP)_X1=FORBITS
REMOVE LAB(L4)
L2=L2*ENTER LAB(L2,B'111'); ! REPLACE ENV
! WHEN MERGE ENV
IF STEPOPND_FLAG>1 THEN RETURN WSP(STEPOPND_XTRA,FORWORDS)
IF FINALOPND_FLAG>1 THEN RETURN WSP(FINALOPND_XTRA,FORWORDS)
->WAYOUT
SW(4): ! %WHILE COND %CYCLE
SET LINE
CCRES=CCOND(0,1,L2,0)
C CYC BODY(0,L2,L1)
ENTER JUMP(15,L1,0)
L2=L2*ENTER LAB(L2,B'111'); ! CONDITIONAL & REPLACE ENV
->WAYOUT
SW(5): ! %UNTIL ... %CYCLE
! ALSO %CYCLE... %REPEAT %UNTIL
! MARKUI TO %CYCLE
P=MARKUI
FLINE=LINE
C CYC BODY(0,L2,L3)
P=MARKC; L3=L3*ENTER LAB(L3,B'011'); ! CONTINUE LABEL IF NEEDED
LINE=FLINE; SET LINE
CCRES=CCOND(0,1,L1,0)
L2=L2*ENTER LAB(L2,B'011')
->WAYOUT
ROUTINE FOR EXP(RECORD (RD) NAME EOPND, INTEGER TOTEMP,SHIFT)
!***********************************************************************
!* P INDEXES EXPRESSION. IF CONST PUT INTO EVALUE OTHERWISE *
!* COMPILE TO ETOS AND STORE IN TEMP IF TOTEMP#0 *
!***********************************************************************
INTEGER INP,VAL,SUBBITS
INP=P; P=P+3
IF INTEXP(VAL,FORPT)=0 AND X'FFFF8000'<VAL<X'FFFF' START
EOPND=EXPOPND; ! EXPRESSION A LITERAL CONST
SUBBITS=0
IF VAL<0 THEN SUBBITS=X'80'
IF -2<=VAL<=2 THEN SUBBITS=SUBBITS!(1<<(VAL+2))
SUBBITS=SUBBITS<<(8+8*SHIFT)
FORBITS=FORBITS!SUBBITS!1<<SHIFT
RETURN
FINISH
EOPND=EXPOPND
IF TOTEMP#0 START
GET WSP(VAL,FORWORDS!X'80000000')
EOPND_PTYPE=FORPT; EOPND_FLAG=LOCALIR
EOPND_D=RBASE<<16!VAL; EOPND_XTRA=VAL
EOPND_D=BRECTRIP(LASS,FORPT,0,EOPND,EXPOPND)
EOPND_FLAG=REFTRIP
FINISH
END
ROUTINE VALIDATE FOR
!***********************************************************************
!* INITIAL VALUE IN ETOS *
!***********************************************************************
INTEGER J
RECORD (RD) OPND
IF INITOPND_FLAG!STEPOPND_FLAG!FINALOPND_FLAG=0 START
J=FINALOPND_D-INITOPND_D; ! ALL CONSTANT CAN CHECK NOW
IF STEPOPND_D=0 OR (J//STEPOPND_D)*STEPOPND_D#J C
THEN FAULT(93,0,0)
RETURN
FINISH
IF STEPOPND_FLAG=0 AND IMOD(STEPOPND_D)=1 THENRETURN
!
! CHECK BY PLANTING CODE
!
OPND_D=BRECTRIP(SUB,FORPT,0,FINALOPND,INITOPND)
OPND_PTYPE=FORPT; OPND_FLAG=REFTRIP
J=BRECTRIP(FORCK,FORPT,0,OPND,STEPOPND)
END
END
ROUTINE ASSIGN(INTEGER ASSOP,P1)
!***********************************************************************
!* HANDLES ARITHMETIC,STRING & ADDRESS ASSIGNMENTS TO VARIABLES *
!* FORMAL PARAMETERS AND DOPEVECTORS *
!* ASSOP:- *
!* 1 IS FOR '==' *
!* 2 IS FOR '=' *
!* 3 IS FOR '<-' (JAM TRANSFER) *
!* 4 IS FOR '->' (UNCONDITIONAL RESOLUTION) *
!* *
!* P POINTS TO THE EXPRESSION. P1 TO THE NAME ON LHS *
!***********************************************************************
INTEGER Q,KK,TYPEP,PRECP,PTYPEP,JJJ,P2,JJ,B,D,HEAD2,BOT2, C
ACCP,II,HEAD1,NOPS,TPCELL,LVL,BOT1,LHNAME,RHNAME
RECORD (LISTF)NAME LHCELL
RECORD (RD) OPND1,OPND2
SWITCH SW(0:4); ! TO SWITCH ON ASSOP
P2=P
LHNAME=A(P1)<<8!A(P1+1)
LHCELL==ASLIST(TAGS(LHNAME))
P=P1; REDUCE TAG; ! LOOK AT LH SIDE
PTYPEP=PTYPE; JJ=J
KK=K; II=I; LVL=OLDI
TPCELL=TCELL; ACCP=ACC
P=P2; TYPEP=TYPE; PRECP=PREC; ! SAVE USEFUL INFO FOR LATER
-> SW(ASSOP)
SW(2):SW(3): ! ARITHMETIC ASSIGNMENTS
IF TYPE=3 THEN ->RECOP
TYPE=1 UNLESS TYPE=2 OR TYPE=5; ! IN CASE OF RUBBISHY SUBNAMES
->ST IF TYPE=5; ! LHS IS A STRING
BACK: HEAD1=0; BOT1=0; ! CLEAR TEMPORAYRY LIST HEADS
HEAD2=0; BOT2=0
TYPE=1 UNLESS TYPE=2; ! DEAL WITH UNSET NAMES
TYPEP=TYPE
NOPS=1<<18+1
PTYPE=PTYPEP; UNPACK
IF LHSADDRFIRST=NO OR (NAM=0=ARR AND A(P1+2)=2=A(P1+3)) START ;! SCALAR
BINSERT(HEAD1,BOT1,PTYPE<<PTSHIFT!ARNAME<<FLAGSHIFT,P1,LHNAME)
FINISH ELSE START
P=P1; CNAME(3); ! 32 BIT ADDR TO STACK
BINSERT(HEAD1,BOT1,NAMEOPND_S1,NAMEOPND_D,NAMEOPND_XTRA)
FINISH
P=P2+3
TORP(HEAD2,BOT2,NOPS); ! RHS TO REVERSE POLISH
BINSERT(HEAD2,BOT2,(VASS+ASSOP-2)<<FLAGSHIFT,LHNAME<<16!PTYPEP,0);! = OR <-OPERATOR
ASLIST(BOT1)_LINK=HEAD2
HEAD2=0; BOT1=BOT2
EXPOP(HEAD1,BOT1,NOPS,256+PRECP<<4+TYPEP); ! PLANT CODE
RETURN
ST: ! STRINGS
P=P1
REDUCE TAG
IF A(P1+2)=2=A(P1+3) AND PTYPE=X'35' AND ASSOP=2 C
THEN KK=STRASS2 AND CNAME(2) ELSE KK=STRASS1 AND CNAME(3)
OPND1=NAMEOPND
P=P2; CSTREXP(32)
IF ASSOP=3 THEN KK=STRJT
JJ=BRECTRIP(KK,X'35',0,OPND1,EXPOPND)
RETURN
!
! THIS SECTION DEALS WITH OPERATIONS ON COMPLETE RECORDS
!
RECOP: ! LHS IS RECORD WITHOUT SUBNAME
Q=TSEXP(JJJ)
IF Q=1 AND JJJ=0 START ; ! CLEAR A RECORD TO ZERO
P=P1; CNAME(3)
OPND1=NAMEOPND; ACCP=ACC
OPND2_S1=X'51'<<PTSHIFT!SCONST<<FLAGSHIFT
OPND2_D=0
FINISH ELSE START
->BACK UNLESS TYPE=3 AND A(P2+3)=4 AND A(P2+4)=1
P=P1; CNAME(3)
OPND1=NAMEOPND
ACCP=ACC
P=P2+5; CNAME(3)
OPND2=NAMEOPND
UNLESS A(P)=2 THEN FAULT(66,0,LHNAME) AND ->F00
IF ASSOP=2 AND ACCP#ACC THEN C
FAULT(67,LHNAME,FROMAR2(P2+5)) AND ->F00
IF ACCP>ACC THEN ACCP=ACC
FINISH
JJ=BRECTRIP(RECASS,X'33',0,OPND1,OPND2)
TRIPLES(JJ)_X1=ACCP
P=P2; SKIP EXP
RETURN
SW(4): ! RESOLUTION
P=P1; CNAME(2)
P=P2;
IF TYPE=5 THEN CRES(0) ELSE START
SKIP EXP
FAULT(71,0,LHNAME) UNLESS TYPE=7
FINISH
RETURN
SW(1): ! '==' AND %NAME PARAMETERS
->F81 UNLESS A(P2+3)=4 AND A(P2+4)=1
FAULT(82,0,LHNAME) AND ->F00 UNLESS NAM=1 AND LITL#1
! ONLY NON-CONST POINTERS ON LHS OF==
IF ARR=1 THEN START
JJ=11; KK=12
II=AHASS; B=AHEADPT
FINISH ELSE START
JJ=6; KK=3
II=PTRAS; B=X'51'
IF PTRSIZE(PTYPE&255)>4 THEN B=X'61'
FINISH
P=P1; CNAME(JJ)
P=P2+5; OPND1=NAMEOPND
RHNAME=A(P)<<8!A(P+1)
CNAME(KK); ! DESCRPTR FETCHED
->F81 UNLESS A(P)=2; ! NO REST OF EXP ON RHS
->F83 UNLESS TYPE=TYPEP AND PREC=PRECP AND (ARR>0 OR II=PTRAS)
->F86 UNLESS OLDI<=LVL OR BASE=0 OR NAM#0
! GLOBAL == NONOWN LOCAL
JJ=BRECTRIP(II,B,0,OPND1,NAMEOPND)
P=P+1
RETURN
F83: FAULT(83,LHNAME,RHNAME); ->F00
F86: FAULT(86,LHNAME,RHNAME); ->F00
F81: FAULT(81,0,LHNAME)
F00:
P=P2; SKIP EXP
END
ROUTINE CSEXP(INTEGER MODE)
!***********************************************************************
!* COMPILE A SIGNED EXPRESSION TO REGISTER 'REG' IN MODE 'MODE' *
!* MODE=1 FOR %INTEGER, =2 REAL, =3 LONG,=0 INTEGER %IF POSSIBLE *
!* MODE=5 FOR ADDRESS EXPRESSNS(IE LEAVE ANY CONSTANT IN 'ADISP')*
!***********************************************************************
INTEGER EXPHEAD,NOPS,EXPBOT
EXPHEAD=0; EXPBOT=0
NOPS=0
P=P+3
TORP(EXPHEAD,EXPBOT,NOPS)
EXPOP(EXPHEAD,EXPBOT,NOPS,MODE)
END
INTEGERFN CONSTEXP(INTEGER PRECTYPE)
!***********************************************************************
!* COMPILES AN EXPRESSION WHICH SHOULD EVALUATE TO A CONSTANT OF *
!* TYPE 'PRECTYPE'. P AS FOR FN INTEXP. *
!***********************************************************************
INTEGER EXPHEAD,EXPBOT,NOPS,RES
EXPHEAD=0; EXPBOT=0; NOPS=0; RES=0
TORP(EXPHEAD,EXPBOT,NOPS)
->WAYOUT UNLESS NOPS&X'00040000'=0
EXPOP(EXPHEAD,EXPBOT,NOPS,X'200'+PRECTYPE)
->WAYOUT UNLESS EXPOPND_FLAG<=1
RES=ADDR(EXPOPND_D)
WAYOUT:
RESULT =RES
END
INTEGERFN INTEXP(INTEGERNAME VALUE,INTEGER PRECTYPE)
!***********************************************************************
!* COMPILES AN EXPRESSION WHICH SHOULD EVALUATE TO A CONSTANT *
!* VALUE RETURNED IN VALUE. RESULT#0 IF FAILED TO EVALUATE *
!* IN THIS CASE RESULT IS IN ETOS. USED FOR BOUND CALCULATIONS *
!* P POINTS TO P(+') IN (+')(OPERNAD)(RESTOFEXPR) *
!***********************************************************************
INTEGER EXPHEAD,EXPBOT,NOPS,CODE,SPTYPE,SACC
EXPHEAD=0; EXPBOT=0; NOPS=0; CODE=0
SPTYPE=PTYPE; SACC=ACC; ! CALLED IN DECLARATIONS
TORP(EXPHEAD,EXPBOT,NOPS)
EXPOP(EXPHEAD,EXPBOT,NOPS,X'200'+PRECTYPE)
CODE=1 UNLESS EXPOPND_FLAG<=1 AND EXPOPND_PTYPE=PRECTYPE
VALUE=EXPOPND_D
ACC=SACC; PTYPE=SPTYPE
UNPACK
RESULT =CODE
END
ROUTINE TORP(INTEGERNAME HEAD,BOT,NOPS)
!***********************************************************************
!* CONVERT THE SIGNED EXPRESSION INDEXED BY P INTO REVERSE *
!* POLISH NOTATION. THE REVERSE POLISH LIST IS ADDED TO 'HEAD' *
!* WHICH MAY CONTAIN ANOTHER EXPRESSION. THE NUMBER OF OPERATORS *
!* IS ADDED TO NOPS. *
!* N.B. AN INTEGER EXPRESSION IS A SPECIAL CASE OF A REAL EXPRSN *
!* THE TOP 20 BITS OF NOPS ARE USED TO RETURN DETAILS OF THE EXPR *
!* THESE BITS SIGNIFY AS FOLLOWS:- *
!* 1<<17 CONTAINS VARIABLE OF MORE THAN 32 BITS *
!* 1<<18 NOT CONSTANT EXPRSSN IE CONTAINS AT LEAST 1 VARIABLE *
!* 1<<19 COMPLEX IE CONTAINS FN CALL OR NEEDS DR TO EVALUATE *
!***********************************************************************
SWITCH OPERAND(1:3)
CONSTBYTEINTEGERARRAY PRECEDENCE(0:20)=0,3,3,4,5,5,4,3,3,4,4,5,5,3,5,5,
0(3),3,5;
CONSTBYTEINTEGERARRAY OPVAL(0:20)=0,ADD,SUB,ANDL,IEXP,REXP,MULT,NONEQ,
ORL,INTDIV,REALDIV,RSHIFT,LSHIFT,ADD,IEXP,REXP,0(3),LNEG,NOTL;
INTEGER RPHEAD,PASSHEAD,SAVEHEAD,REAL,REALOP,OPERATOR,OPPREC,OPND,
C,D,E,BDISP,OPNAME,OPMASK,RPBOT,OPSTK,OPPSTK,PASSBOT
RECORD (TAGF)NAME LCELL
RECORD (RD)RPOP
!
PASSHEAD=0; RPHEAD=0; SAVEHEAD=0
REAL=0; REALOP=0; BDISP=0
RPBOT=0; OPSTK=0; OPPSTK=0
!
C=A(P)
IF 2<=C<=3 THEN START ; ! INITIAL '-' OR '¬'
NOPS=NOPS+1
! '-' =(11,3) '¬' =(10,5)
OPSTK=C+17
OPPSTK=PRECEDENCE(OPSTK)
OPMASK=1<<(19+C); ! - %OR !!
FINISH ELSE OPMASK=0
NEXTOPND:OPND=A(P+1); P=P+2
RPOP=0
-> OPERAND(OPND); ! SWITCH ON OPERAND
OPERAND(1): ! NAME
OPNAME=A(P)<<8+A(P+1)
LCELL==ASLIST(TAGS(OPNAME))
LCELL_UIOJ<-LCELL_UIOJ!X'8000'; ! SET USED BIT
PTYPE=LCELL_PTYPE
IF PTYPE=X'FFFF' THEN PTYPE=X'57';! NAME NOT SET
TYPE=PTYPE&7; PREC=PTYPE>>4&15
IF PTYPE=SNPT THEN PTYPE=LCELL_ACC AND UNPACK
IF PTYPE&X'FF00'=X'4000' AND A(P+2)=2=A(P+3) C
AND 1<=TYPE<=2 THEN START ; ! CONST VAR
RPOP_D=LCELL_S2; RPOP_XTRA=LCELL_S3
RPOP_FLAG=1; PTYPE=PTYPE&255
IF TYPE=1 AND PREC<=5 AND X'FFFF8000'<RPOP_D<=X'7FFF'C
THEN RPOP_FLAG=0 AND PTYPE=MINAPT
REAL=1 IF TYPE=2
P=P+2; ->SKNAM
FINISH
RPOP_XTRA=OPNAME
RPOP_FLAG=ARNAME; RPOP_D=P; PTYPE=X'51' IF PTYPE=X'57'
IF TYPE=5 THEN FAULT(76,0,OPNAME) AND RPOP_FLAG=0 AND C
PTYPE=X'51'
IF TYPE=3 THEN START
D=P; KFORM=LCELL_KFORM
C=COPY RECORD TAG(E); P=D;
FINISH ELSE START
! %IF PTYPE&X'300'#0 %START;! ARRAYS
! COPY TAG(OPNAME)
! RPOP_PTYPE=PTYPE
! RPOP_FLAG=DNAME
! BINSERT(RPHEAD,RPBOT,RPOP_S1,OPNAME,RPOP_XTRA)
! AATORP(NOPS,RPHEAD,RPBOT,ARR,I,K)
! P=RPOP_D; RPOP_FLAG=IFETCH
! RPOP_XTRA=0; RPOP_D=0
! %FINISH
FINISH
IF PREC>=6 THEN OPMASK=OPMASK!1<<17;! MORE THAN 32 BITS
IF TYPE=2 THEN REAL=1
P=P+2
SKNAM: IF A(P)=2 THEN P=P+1 ELSE SKIP APP
IF A(P)=1 THEN P=P+3 AND ->SKNAM
P=P+2
INS: IF RPOP_FLAG=ARNAME THEN OPMASK=OPMASK!1<<18
IF PTYPE>>4&15>5 THEN OPMASK=OPMASK!1<<17;! CONTINS LONG
IF 3<=PTYPE&7<=7 THEN PTYPE=MINAPT;! NOT SET TO MIN INTEGER
RPOP_PTYPE=PTYPE
BINSERT(RPHEAD,RPBOT,RPOP_S1,RPOP_D,RPOP_XTRA)
-> OP
OPERAND(2): ! CONSTANT
PTYPE=A(P); D=PTYPE>>4
IF D>=6 THEN OPMASK=OPMASK!1<<17;! MORE THAN 32 BIT OPERAND
C=PTYPE&7
IF D=4 THEN START
RPOP_D=FROM AR2(P+1)
PTYPE=X'51'
FINISH ELSE RPOP_D=FROM AR4(P+1)
REAL=1 IF C=2; RPOP_FLAG=1
IF D=6 THEN RPOP_XTRA=FROM AR4(P+5)
IF C=5 THEN START ; ! STRING CONSTANT
FAULT(77,0,0); RPOP_D=1; RPOP_FLAG=0
P=P+A(P+1)+3; PTYPE=X'51'
FINISH ELSE START
IF D=7 THEN RPOP_XTRA=RPOP_D AND RPOP_D=P+1
IF PTYPE=X'51' AND X'FFFF8000'<=RPOP_D<=X'7FFF' THEN C
RPOP_FLAG=0 AND PTYPE=MINAPT
P=P+2+BYTES(D)
FINISH ; -> INS
OPERAND(3): ! SUB EXPRESSION
PASSHEAD=0; PASSBOT=0
P=P+3
TORP(PASSHEAD,PASSBOT,NOPS)
REAL=1 IF TYPE=2
! CONCAT(RPHEAD,PASSHEAD)
IF RPBOT=0 THEN RPHEAD=PASSHEAD ELSE C
ASLIST(RPBOT)_LINK=PASSHEAD
RPBOT=PASSBOT
P=P+1
OP: ! DEAL WITH OPERATOR
RPOP=0
-> EOE IF A(P-1)=2; ! EXPR FINISHED
OPERATOR=A(P)
!
! THE STRING OPERATOR '.' CAUSES CHAOS IN AN ARITHMETIC EXPRSN
! SO FAULT IT AND CHANGE IT TO THE INNOCUOUS '+'
!
IF OPERATOR=CONCOP THEN FAULT(78,0,0)
OPPREC=PRECEDENCE(OPERATOR)
C=OPVAL(OPERATOR)
IF C=REALDIV OR C=REXP THEN REAL=1
NOPS=NOPS+1
!
! UNLOAD THE OPERATOR STACK OF ALL OPERATORS WHOSE PRECEDENCE IS
! NOT LOWER THAN THE CURRENT OPERATOR. AN EMPTY STACK GIVES'-1'
! AS PRECEDENCE.
!
WHILE OPPREC<=OPPSTK&31 CYCLE
RPOP_FLAG=OPVAL(OPSTK&31)
BINSERT(RPHEAD,RPBOT,RPOP_S1,0,0)
OPSTK=OPSTK>>5; OPPSTK=OPPSTK>>5
REPEAT
!
! THE CURRENT OPERATOR CAN NOW BE STORED
!
OPSTK=OPSTK<<5!OPERATOR
OPPSTK=OPPSTK<<5!OPPREC
-> NEXTOPND
EOE: ! END OF EXPRESSION
! EMPTY REMAINING OPERATORS
WHILE OPSTK#0 CYCLE
RPOP_FLAG=OPVAL(OPSTK&31)
BINSERT(RPHEAD,RPBOT,RPOP_S1,0,0)
OPSTK=OPSTK>>5
REPEAT
PTYPE=REAL+1
TYPE=PTYPE
! CONCAT(RPHEAD,HEAD)
IF HEAD=0 THEN BOT=RPBOT ELSE C
ASLIST(RPBOT)_LINK=HEAD
HEAD=RPHEAD; ! HEAD BACK TO TOP OF LIST
NOPS=NOPS!OPMASK
END
ROUTINE EXPOP(INTEGERNAME HEAD,BOT,INTEGER NOPS,MODE)
!***********************************************************************
!* EVALUATE A LIST OF OPERAND AND'NOPS' OPERATORS AND LEAVE *
!* THE RESULT IN REG *
!* INHEAD HOLDS THE LIST THE BOTTOM BYTE OF STREAM 1 DEFINES THE *
!* ENTRY AS FOLLOWS:- *
!* 0 = SHORT (INTEGER) CONSTANT <18 BITS --S2=CONSTANT *
!* 1 = OTHER CONSTANT S2 (+S3 IF NEEDED) = CONSTANT *
!* 2 = VARIABLE S2 POINT TO AR ENTRY FOR NAME&SUBSCRIPTS *
!* (3 = DOPE VECTOR ITEM IF NEEDED) *
!* (4 = CONDITONAL EXPRESSION AS IN ALGOL) *
!* 7 = INTERMEDIATE RESULT UNDER LNB S2=DISPLCMNT FROM LNB *
!* 8 = INTERMEDIATE RESULT STACKED *
!* 9 = INTERMEDIATE RESULT IN A REGISTER S2 = REG *
!* *
!* 10-19 = UNARY OPERATOR S2=OP S3 =EXTRA *
!* 20 UP = BINARY OPERATOR *
!* *
!* MODE HAS TYPE & PREC REQD +256 BIT IF NO RESULT REQD *
!***********************************************************************
ROUTINESPEC PSEVAL
!
INTEGERARRAY OPERAND(0:2),STK(0:99)
RECORD (LISTF)NAME LIST
RECORD (RD)NAME OPND1,OPND2,OPND
RECORD (TRIPF)NAME CURRT
!
INTEGER C,D,KK,JJ,COMM,XTRA,INHEAD,NDEPTH,CURR TRIP, C
STPTR,CONSTFORM,CONDFORM,SAVEP,INITTRIP
!
! CORULES GIVE INFORMATION ON OPERATORS.
! BTM 4 BITS HAVE TYPE CONVERSION RULES(SEE COERCET)
! NEXT 4 BITS HAVE PREC RULES (SEE COERCEP)
! 2**8 SET IF COMMUTATIVE
! 2**9 SET DONT LOAD OPERAND2
! 2**10 SET DONT LOAD OPERAND1
!
CONSTHALFINTEGERARRAY CORULES(0:20)= C
X'1FF'{+},X'FF'{-},
X'1F1'{!!},X'1F1'{!},
X'1FF'{*},X'F1'{//},
X'F2'{/},X'1F1'{&},X'71'{>>},
X'71'{<<},X'243'{**},
X'1FF'{COMP},X'FF'{DCOMP},
X'200'{VMY},X'1F1'{COMB},
X'214'{ASSIGN=},
X'254'{ASSIGN<-},X'241'{****},
X'201'{ARR SCALE},
X'001'{ARR INDEX},
X'500'{INDEXED FETCH};
CONSTINTEGERARRAY PTYPECH(0:19)=0(12),X'11',0,-X'10',X'10',-X'10',0(3);
!
STPTR=0; NDEPTH=0; CONSTFORM= MODE&512
INITTRIP=NEXTTRIP
CONDFORM=MODE&256
SAVEP=P
INHEAD=HEAD
PSEVAL
NEXT: LIST==ASLIST(INHEAD)
XTRA=LIST_S2
JJ=LIST_FLAG; D=INHEAD
INHEAD=LIST_LINK
-> OPERATOR IF JJ>=10
!
! ANY OPERAND WHICH MAY NEED DR OR B OR ACC IN THEIR EVALUATION
! EG FUNCTIONS,ARRAY ELEMENTS ETC ARE FETCHED AND STACKKED FIRST
!
OPND1==ASLIST(D)
STK(STPTR)=D
STPTR=STPTR+1
IMPABORT IF STPTR>99
ANYMORE:
->NEXT UNLESS INHEAD=0
OPND1==ASLIST(STK(STPTR-1))
EXPOPND=OPND1
->FINISH
OPERATOR:
IF JJ<128 THEN KK=1 ELSE KK=2; ! UNARY OR BINARY
CYCLE KK=KK,-1,1
STPTR=STPTR-1
OPERAND(KK)=STK(STPTR)
REPEAT
COMM=1
OPND1 == ASLIST(OPERAND(1))
IF JJ>=128 THEN START
OPND2==ASLIST(OPERAND(2))
FINISH ELSE OPND2==RECORD(0)
IF JJ=32 THEN COMM=2; ! DSIDED RESULT=2ND OPERAND
! ALL OTHERS RESULT=1ST OPERAND
IF OPND1_FLAG<2 AND (JJ<128 OR OPND2_FLAG<2) THEN C
CTOP(JJ,MASK,XTRA,OPND1,OPND2)
IF JJ#0 THEN START ; ! CODE REQUIRED OP TRIPLE
IF JJ<128 THEN C=0 ELSE C=CORULES(JJ-128)
IF JJ=VASS OR JJ=VJASS THEN KK=1 ELSE KK=2;! CNAME FETCH-STORE
IF OPND1_FLAG=ARNAME AND C
(LHSADDRFIRST=YES OR KK=2) START
! EXPAND UP NAMES BUT NOT LHS
! ASSIGNMENT NAMES
P=OPND1_D; CNAME(KK)
OPND1=NAMEOPND
FINISH
IF JJ>=128 AND OPND2_FLAG=ARNAME THEN START
P=OPND2_D
CNAME(2)
OPND2=NAMEOPND
FINISH
IF OPND1_FLAG=ARNAME THEN START
P=OPND1_D
CNAME(KK)
OPND1=NAMEOPND
FINISH
CURR TRIP=NEW TRIP
CURRT==TRIPLES(CURR TRIP)
CURRT_DPTH=NDEPTH
CURRT_CNT=0
CURRT_FLAGS=1!(C>>1&128)
CURRT_OPERN=JJ
CURRT_OPTYPE<-OPND1_PTYPE
IF OPND1_PTYPE&7=1 AND OPND1_PTYPE&255<MINAPT THEN C
CURRT_OPTYPE=MINAPT
IF JJ<128 START ; ! UNARY(TYPECHANGE)OPN
CURRT_OPTYPE=CURRT_OPTYPE+PTYPECH(JJ)
FINISH
! %IF JJ=COMP %OR JJ=DCOMP %THEN MASK=FCOMP(LIST_S2)
! PREVENT OPTIMISING BYTE ARRAY SCALE
! AS THESE CREATE EXTRA WORD
! WHICH DEFEATS ALGORITHMS
IF JJ=39 AND LIST_S2>>20=1 THEN C
CURRT_FLAGS<-CURRT_FLAGS! DONT OPT
CURRT_X1=LIST_S2
CURRT_OPND1=OPND1
IF 1<<OPND1_FLAG&BTREFMASK#0 THEN KEEP USE COUNT(OPND1)
IF JJ>=128 THEN START
CURRT_OPND2=OPND2
IF 1<<OPND2_FLAG&BTREFMASK#0 THEN KEEP USE COUNT(OPND2)
FINISH
OPND1_FLAG=8
OPND1_PTYPE=CURRT_OPTYPE
OPND1_D=CURR TRIP
! NDEPTH=NDEPTH+WORDS(CURRT_OPTYPE>>4)
FINISH
STK(STPTR)=OPERAND(COMM)
STPTR=STPTR+1
->ANYMORE
FINISH:
IF EXPOPND_FLAG=ARNAME THEN START
P=EXPOPND_D
CNAME(2)
EXPOPND=NAMEOPND
FINISH
PTYPE=EXPOPND_PTYPE
TYPE=PTYPE&7; PREC=PTYPE>>4
P=SAVEP
ASLIST(BOT)_LINK=ASL
ASL=HEAD
HEAD=0; BOT=0
RETURN
ROUTINE PSEVAL
!***********************************************************************
!* PERFORMS A PSEUDO EVALUATION ON THE EXPRESSION TO DETERMINE *
!* THE POSITION OF ANY TYPE CHANGES AND THEN INSERTS *
!* THESE UNARY OPERATIONS *
!***********************************************************************
ROUTINESPEC AMEND(RECORD (RD)NAME OPND,INTEGER OP)
ROUTINESPEC COERCET(INTEGER RULES)
ROUTINESPEC COERCEP(INTEGER RULES)
INTEGER TMPHEAD,INHEAD,C,JJ,NEXT
RECORD (RD)NAME OPND1
RECORD (RD)OPND2,RPOP
RECORD (LISTF)NAME CELL
PRINT LIST(HEAD) AND IMPABORT UNLESS ASLIST(BOT)_LINK=0
RPOP=0
TMPHEAD=0
INHEAD=HEAD
!
WHILE INHEAD#0 CYCLE
CELL==ASLIST(INHEAD)
NEXT=CELL_LINK
RPOP<-CELL; ! COPY BEFOR ADJUSTING PTYPE
JJ=RPOP_FLAG; ! FLAG
IF JJ<10 START ; ! AN OPERAND
! %IF RPOP_PTYPE>>4&15<MINAPREC %THEN %C
RPOP_PTYPE=RPOP_PTYPE&X'FF0F'!(MINAPREC<<4)
PUSH(TMPHEAD,RPOP_S1,RPOP_D,INHEAD)
FINISH ELSE START ; ! AN OPERATOR
IF JJ>=128 START ; ! BINARY OPERATOR
POP(TMPHEAD,OPND2_S1,OPND2_D,OPND2_XTRA)
OPND1==ASLIST(TMPHEAD); ! MAPPING SAVES POP&PUSH
C=CORULES(JJ-128)
IF C&15#0 THEN COERCET(C&15)
IF C>>4&15#0 THEN COERCEP(C>>4&15)
FINISH ELSE OPND1==ASLIST(TMPHEAD)
OPND1_XTRA=INHEAD; ! IN CASE(FURTHER)TYPE CHANGE
FINISH
INHEAD=NEXT
REPEAT
!
! FINAL COERCION ON RESULT
!
POP(TMPHEAD,OPND2_S1,OPND2_D,OPND2_XTRA)
PRINT LIST(HEAD) AND IMPABORT UNLESS TMPHEAD=0
IF CONDFORM=0 START
IF MODE&7=1 AND OPND2_PTYPE&7=2 THEN FAULT(25,0,0)
IF OPND2_PTYPE&7=1 AND MODE&7=2 THEN AMEND(OPND2,IFLOAT)
C=MODE>>4&15; ! TARGET PREC
AMEND(OPND2,SHRTN) WHILE C<OPND2_PTYPE>>4&15
AMEND(OPND2,LNGTHN) WHILE C>OPND2_PTYPE>>4&15
FINISH
PRINTLIST(HEAD) IF PARM_DCOMP#0 AND PARM_Z#0
BOT=ASLIST(BOT)_LINK WHILE ASLIST(BOT)_LINK#0
RETURN
ROUTINE AMEND(RECORD (RD)NAME OPND,INTEGER OP)
!***********************************************************************
!* ADDS IN AN OPERATION TO CHANGE THE TYPE OR PREC OF OPND *
!***********************************************************************
RECORD (RD) RPOP
IF OP=LNGTHN AND OPND_PTYPE&255<MINAPT THEN C
OPND_PTYPE=OPND_PTYPE&X'FF00'!MINAPT AND RETURN
RPOP=0
RPOP_FLAG=OP
INSERT AFTER(OPND_XTRA,RPOP_S1,0,0)
NOPS=NOPS+1
IF OP=IFLOAT AND OPND_PTYPE&255<MINAPT THEN C
OPND_PTYPE=MINAPT
OPND_PTYPE=OPND_PTYPE+PTYPECH(OP)
END
ROUTINE COERCET(INTEGER RULES)
!***********************************************************************
!* RULES=1 BOTH OPERANDS INTEGER ELSE ERROR *
!* RULES=2 FORCE BOTH OPERAND TO BE OF TYPE REAL *
!* RULES=3 OPND1 ONLY TO BE REAL(FOR **) *
!* RULES=4 OPND2 TO BE OPND 1(ASSIGNMENT) *
!* RULES=15 BOTH OPERANDS TO BE OF LARGEST TYPE *
!***********************************************************************
INTEGER PT1,PT2
RECORD (RD)RPOP
RPOP=0; RPOP_FLAG=12; ! FLOAT
PT1=OPND1_PTYPE&7
PT2=OPND2_PTYPE&7
IF RULES=4 THEN PT1=CELL_S2&7; ! ORIGINAL PT FOR ARRAYS ETC
IF (RULES=1 OR RULES=15 OR RULES=4) AND PT1=1=PT2 C
THEN RETURN
IF RULES=1 OR (RULES=4 AND PT1=1) C
THEN FAULT(24,0,0) AND RETURN
IF PT1=1 THEN AMEND(OPND1,IFLOAT)
IF PT2=1 AND (RULES=2 OR RULES=4 OR RULES=15) THEN C
AMEND(OPND2,IFLOAT)
END
ROUTINE COERCEP(INTEGER RULES)
!***********************************************************************
!* RULES DEFINE COERCION AS FOLLOWS: *
!* RULES=1 FORCE OPND2 TO BE OPND1(ASSIGNMENT) *
!* RULES=2 OPERAND 1 TO BE 'STANDARD' INTEGER *
!* RULES=4 OPERAND 2 TO BE 'STANDARD' INTEGER *
!* RULES=5 AS RULES=1 BUT FOR <- ASSIGNMENT *
!* RULES=6 BOTH OPERANDS TO BE 'STANDARD' INTEGER *
!* RULES=7 OPND1>=32BITS, OPND2 TO BE 'STANDARD' *
!* RULES=15 BOTH OPERANDS TO THE LARGEST PRECISION *
!***********************************************************************
INTEGER PREC1,PREC2,TPREC,OPER
RECORD (RD)NAME OPND
RECORD (RD)RPOP
RPOP=0
IF RULES=6 THEN COERCEP(4) AND RULES=2
PREC1=OPND1_PTYPE>>4&15
PREC2=OPND2_PTYPE>>4&15
IF RULES=5 OR RULES=1 START ; ! ASSIGN
PREC1=CELL_S2>>4&15; ! ORIGINAL PREC FOR ARRAY ASSIGN
IF PREC2>PREC1 START
CYCLE
IF RULES=1 THEN OPER=SHRTN ELSE OPER=JAMSHRTN
AMEND(OPND2,OPER)
PREC2=PREC2-1
REPEAT UNTIL PREC1=PREC2
RETURN
FINISH ELSE RULES=1; ! IN CASE LENGTHEN NEEDED
FINISH
! %IF PREC1<MINAPREC %THEN PREC1=MINAPREC %AND %C
OPND1_PTYPE=OPND1_PTYPE&X'FF0F'!(MINAPREC<<4)
! %IF PREC2<MINAPREC %THEN PREC2=MINAPREC %AND %C
OPND2_PTYPE=OPND2_PTYPE&X'FF0F'!(MINAPREC<<4)
IF RULES=7 START ; ! FORCE SHIFT INTO 32 BIT MIN REG
RULES=4
IF PREC1=4 THEN AMEND(OPND1,LNGTHN) AND PREC1=5
FINISH
IF 2<=RULES<=4 START
IF RULES<=2 THEN OPND==OPND1 ELSE OPND==OPND2
IF OPND_PTYPE&X'FF'>MINAPT THEN AMEND(OPND,SHRTN)
RETURN
FINISH
IF PREC1<PREC2 THEN TPREC=PREC2 AND OPND==OPND1 ELSE C
TPREC=PREC1 AND OPND==OPND2
OPER=OPND_PTYPE
AMEND(OPND,LNGTHN) WHILE OPND_PTYPE>>4&15<TPREC
END
END
END ; ! OF ROUTINE EXPOP
INTEGERFN CCOND(INTEGER CTO,IU,FARLAB,JFLAGS)
!***********************************************************************
!* COMPILES <IU><SC><RESTOFCOND>%THEN<UI1>%ELSE<UI2> *
!* CTO=0 JUMP TO FARLAB MUST BE PLANTED IF COND UNCONDITIONAL *
!* CTO#0 JUMP MAY BE OMITTED *
!* IU=1 FOR %IF =2 FOR UNLESS. FARLAB TO GO ON UI2 *
!* THE ROUTINE MAKES FOUR PASSES THROUGH THE CONDITION *
!* PASS 1 ANALYSES THE STRUCTURE AND DECIDES TO BRANCH ON TRUE *
!* (TF=2) OR ON FALSE (TF=1) FOR EACH COMPARISON *
!* PASS 2 WORKS OUT WHERE THE BRANCHES OF PASS 1 SHOULD GO TO *
!* PASS 3 ASSIGNS LABEL NUMBERS *
!* PASS 4 EVALUATES COMPARISIONS AND PLANTS THE CODE *
!* *
!* ON ENTRY P POINTS TO <SC> IN<HOLE><SC><RESTOFCOND> *
!* RESULT=0 CONDITION COMPILED *
!* RESULT=1 UNCONDITIONALLY TO 1ST ALTERNATIVE *
!* RESULT=2 UNCONDITIONALLY TO 2ND ALTERNATIVE(FARLAB) *
!***********************************************************************
!%ROUTINESPEC WRITE CONDLIST
ROUTINESPEC SKIP SC(INTEGER REVERSED)
ROUTINESPEC SKIP COND(INTEGER REVERSED)
INTEGERFNSPEC CCOMP
ROUTINESPEC JUMP(INTEGER MASK,LAB,FLAGS)
ROUTINESPEC NOTE JUMP(INTEGER LAB)
ROUTINESPEC LAB UNUSED(INTEGER LAB)
ROUTINESPEC OMIT TO(INTEGER LAB)
!
! FCOMP HAS BC MASKS FOR EACH STRING COMPARATOR.
! THE FIRST 7 ARE TO BRANCH IF TRUE WITH NORMAL COMPARISON
! THE SECOND SEVEN ARE TO BRANCH IF TRUE WITH BACKWARDS COMPARISON
!
!
INTEGER PIN,PP,II,L,CPTR,CMAX,LL,BITMASK,LLA
RECORDFORMAT CF(BYTEINTEGER TF,CMP1,CMP2,LABU,LVL,JMP,REV,JUMPED, C
INTEGER LABNO,SP1,SP2)
RECORD (CF)ARRAY CLIST(0:30)
RECORD (CF)NAME C1,C2
!
! PASS 1. ANALYSES THE CONDITION
!
PIN=P; ! SAVE INITIAL AR POINTER
CPTR=1; L=3; ! LEVEL=3 TO ALLOW 2 LOWER
C1==CLIST(CPTR); ! SET UP RECORD FOR FIRST CMPARSN
C1=0
SKIP SC(0); ! SKIP THE 1ST CMPARSN
SKIP COND(0); ! AND ANY %AND/%OR CLAUSES
C1_LVL=2; ! LEVEL =-1 FOR %IF/%THEN ENTRY
C1_TF=IU
CMAX=CPTR+1
C1==CLIST(CMAX); C1=0
C1_LVL=1; ! LEVEL =-2 FOR ELSE ENTRY
C1_TF=3-IU; ! C1_REV NEVER SET HERE (PDS HOPES)
C1_LABNO=FARLAB
PP=P; ! SAVE FINAL AR POINTER
FAULT(108,0,0) IF CMAX>29; ! TOO COMPLICATED
!
! PASS 2 WORKS OUT WHERE TO JUMP TO
! THE JUMP IS FORWARD TO THE START OF THE CLAUSE WITH A DIFFERENT
! CONNECTOR (AND/OR) PROVIDED THIS IS AT A LOWER LEVEL THAN THE BRANCH
! AND ALSO AT A LOWER LEVEL THAN THE LOWEST POINT REACHED ENROUTE
!
! ALSO CONTAINS PASS 3 (TRIVIAL)
! ASSIGN LABELS WHERE LABU SHOWS THEY ARE REQUIRED
!
CYCLE CPTR=1,1,CMAX-1
C1==CLIST(CPTR)
L=C1_LVL; LL=L; ! LL FOR LOWEST LEVEL ENROUTE
CYCLE II=CPTR+1,1,CMAX+1
C2==CLIST(II)
EXIT IF C1_TF#C2_TF AND C2_LVL<LL
IF C2_LVL<LL THEN LL=C2_LVL
REPEAT
C1_JMP=II; ! CLAUSE TO JUMP TO
C2_LABU=C2_LABU+1
IF C1_CMP2#0 OR C1_CMP1=8 START ; ! D-SIDED OR RESLN
! REQIUIRES A LABEL ON THE
C1_LABU=C1_LABU+1; ! THE NEXT SIMPLE CONDITION
FINISH
IF C1_LABU#0 AND C1_LABNO<=0 THEN PLABEL=PLABEL-1 C
AND C1_LABNO=PLABEL
REPEAT
!
! PASS 4 GENERATE THE CODE
! MAINTAIN BIT MASK TO HELP. 2**0 JUMP TO FAR LAB PLANTED
! 2**1 JUMP TO INTERMEDIATE LAB PLANTED
!
! WRITE CONDLIST %IF PARM_DCOMP=1
BITMASK=0
CPTR=1
CYCLE
C1==CLIST(CPTR)
LLA=CCOMP
IF LLA#0 START
OMIT TO(LLA)
IF CPTR>=CMAX THEN START
IF CTO=0 THEN ENTER JUMP(15,LLA,B'11')
RESULT =2
FINISH
C1==CLIST(CPTR)
FINISH
IF C1_LABNO>0 THEN II=ENTER LAB(C1_LABNO,B'11')
CPTR=CPTR+1
EXIT IF CPTR>=CMAX
REPEAT
!
P=PP;
RESULT =1 IF BITMASK&1=0
RESULT =0
ROUTINE LAB UNUSED(INTEGER LAB)
!***********************************************************************
!* A LABEL IS NOT JUMPED TO AS CONDITION ALWAYS FALSE *
!* REMOVE IT FROM LIST *
!***********************************************************************
INTEGER I
RECORD (CF)NAME C1
CYCLE I=CPTR,1,CMAX-1
C1==CLIST(I)
IF C1_LABNO=LAB START
C1_LABU=C1_LABU-1; ! COUNT DOWN USE COUNT
IF C1_LABU=0 THEN C1_LABNO=0
RETURN
FINISH
REPEAT
END
ROUTINE OMIT TO(INTEGER LAB)
!***********************************************************************
!* A JUMP TURNS OUT TO BE UNCONDITIONAL. OMIT CODE FOR SKIPPED BIT *
!***********************************************************************
RECORD (CF)NAME C1
CYCLE
C1==CLIST(CPTR)
IF C1_LABNO>0 START
IF C1_LABNO=LAB THEN RETURN
IF C1_JUMPED>0 THEN JUMP(15,LAB,B'11') AND RETURN
FINISH
CPTR=CPTR+1
EXIT IF CPTR>=CMAX
REPEAT
END
ROUTINE SKIP SC(INTEGER REVERSED)
!***********************************************************************
!* REVERSED=1 FOR RECURSIVE CALL IN %NOT(SC) *
!* SKIPS OVER A SIMPLE CONDITION. P ON ALT OF<SC> *
!***********************************************************************
SWITCH SCALT(1:3)
INTEGER ALT
ALT=A(P); P=P+1
->SCALT(ALT)
SCALT(1): ! <EXP><COMP><EXP><SECONDSIDE>
C1_SP1=P-PIN
SKIP EXP
C1_CMP1=A(P)
C1_REV=3*REVERSED
P=P+1; C1_SP2=P-PIN
SKIP EXP
IF A(P)=2 THEN P=P+1 ELSE START
C1_CMP2=A(P+1); ! DEAL WITH 2ND HALF OF D-SIDED
P=P+2; SKIP EXP
FINISH
RETURN
SCALT(2): ! '('<SC><RESTOFCOND>')'
L=L+1
SKIP SC(REVERSED)
SKIP COND(REVERSED)
L=L-1
RETURN
SCALT(3): ! %NOT(SC)
SKIP SC(REVERSED!!1)
END ; ! OF ROUTINE SKIP SC
ROUTINE SKIP COND(INTEGER REVERSED)
!***********************************************************************
!* SKIPS OVER <RESTOFCOND> *
!***********************************************************************
INTEGER ALT,ALTP
ALT=A(P); ! 1=%AND<ANDC>,2=%OR<ORC>,3=NULL
P=P+1
IF ALT¬=3 THEN START ; ! NULL ALTERNATIVE NOTHING TO DO
UNTIL ALTP=2 CYCLE ; ! UNTIL NO MORE <SC>S
C1_LVL=L; C1_TF=ALT
C1_TF=C1_TF!!(3*REVERSED)
CPTR=CPTR+1
C1==CLIST(CPTR); C1=0
SKIP SC(REVERSED)
ALTP=A(P); P=P+1
REPEAT
FINISH
END
!%ROUTINE WRITE CONDLIST
!%CONSTSTRING(5) %ARRAY CM(0:10)=" "," ="," >="," >",
! " #"," <="," <"," ¬="," ->",
! " =="," ¬=="
! PRINTSTRING("
! NO TF C1 C2 LABU LVL JMP REV LABNO JUMPED
!")
! %CYCLE CPTR=1,1,CMAX
! C1==CLIST(CPTR)
! WRITE(CPTR,2)
! WRITE(C1_TF,4)
! PRINTSTRING(CM(C1_CMP1))
! PRINTSTRING(CM(C1_CMP2))
! WRITE(C1_LABU,6)
! WRITE(C1_LVL,5)
! WRITE(C1_JMP,4)
! WRITE(C1_REV,4)
! WRITE(C1_LABNO,7)
! WRITE(C1_JUMPED,6)
! NEWLINE
! %REPEAT
!%END
INTEGERFN CCOMP
!***********************************************************************
!* COMPILES A COMPARISION: THREE DIFFERENT CASES *
!* 1) ARITHMETIC EXPRESSIONS EXPOP IS USED *
!* 2) STRING EXPRESSION AD-HOC CODE PLANTED BY THIS ROUTINE *
!* 3) RESOLUTIONS - CRES CAN BE USED *
!* 4) EQUIVALENCES INTEGER COMPARISONS ON ADDRESSES *
!* RESULT=0 CODE COMPILED *
!* RESULT#0 UNCODITIONAL JUMP TO LAB=RESULT *
!***********************************************************************
ROUTINESPEC ACOMP(INTEGER TF,DS)
ROUTINESPEC ADCOMP(INTEGER TF)
ROUTINESPEC STRCOMP(INTEGER DS,TF,LAB,INTEGERNAME WA)
INTEGER HEAD1,HEAD2,NOPS,TE2,TEX2,P1,P2,FEXIT,IEXIT, C
CMP,BOT1,BOT2
INTEGERARRAY WA(0:3)
!
HEAD1=0; HEAD2=0; NOPS=0
BOT1=0; BOT2=0
FEXIT=CLIST(C1_JMP)_LABNO; ! FINAL EXIT
IEXIT=FEXIT; ! INTERMEDIATE EXIT (D-SIDED ETC)
IF C1_REV!!C1_TF=2 AND (C1_CMP1=8 OR C1_CMP2#0) THEN C
IEXIT=C1_LABNO
!
P=PIN+C1_SP2
P2=P; P1=PIN+C1_SP1
IF C1_CMP1=8 THEN START
! CONDITIONAL RESOLUTION
! NB CRES BRANCHES ON FALSE!!
P=P1
IF A(P+3)=4 AND A(P+4)=1 START
P=P+5; CNAME(2); ! LH STRING TO ANY REG
IF A(P)=2 THEN START
IF TYPE#5 THEN FAULT(71,0,FROMAR2(P1+5)) C
AND RESULT =0
P=P2
CRES(IEXIT); ! FAILURES -> IEXIT
NOTE JUMP(IEXIT)
IF IEXIT=FARLAB THEN BITMASK=BITMASK!1 ELSE C
BITMASK=BITMASK!2
IF C1_REV!!C1_TF=2 THEN JUMP(15,FEXIT,B'11')
RESULT =0
FINISH
FINISH
FAULT(74,0,0)
RESULT =0
FINISH
IF C1_CMP1>8 THEN ->ADRCOMP
MASK=FCOMP(C1_CMP1)
TE2=TSEXP(TEX2)
->STR IF TYPE=5
! ARITHMETIC COMPARISIONS
P=P1+3
TORP(HEAD1,BOT1,NOPS); ! FIRST EXPRESSION TO REVERSE POL
CMP=C1_CMP1
P=P2+3
IF C1_CMP2#0 THEN START ; ! IF D-SIDED DEAL WITH MIDDLE
ACOMP(1,1); ! BRANCH IEXIT %IF FALSE
IF MASK=15 THEN RESULT =IEXIT
JUMP(MASK,IEXIT,B'11')
P=P+5; ! TO THE THIRD EXPRSN
CMP=C1_CMP2; ! COMPARATOR NO 2
FINISH
!
ACOMP(C1_REV!!C1_TF,0); ! SECOND OR ONLY COMPARISION
IF MASK=15 THEN RESULT =FEXIT
JUMP(MASK,FEXIT,B'11')
RESULT =0
STR: ! STRING COMPARISIONS
! SOME CARE IS NEEDED IN FREEING
! STRING WK-AREAS SET BY CSTREXP
P=P1
WA(1)=0; WA(2)=0; WA(3)=0
CSTREXP(48); ! DO NOT FREE WK-AREA
WA(1)=VALUE; ! SAVE ADDRESS OF WK-AREA
CMP=C1_CMP1
P=P2
!
IF C1_CMP2#0 THEN START ; ! D-SIDED DEAL WITH MIDDLE
STRCOMP(1,1,IEXIT,WA(2))
P=P+2; CMP=C1_CMP2
IF WA(1)#0 THEN RETURN WSP(WA(1),268) AND WA(1)=0
FINISH
!
STRCOMP(0,C1_REV!!C1_TF,FEXIT,WA(3))
CYCLE CMP=1,1,3
IF WA(CMP)#0 THEN RETURN WSP(WA(CMP),268)
REPEAT
RESULT =0
ADRCOMP: ! ADRESS COMPARISONS
ADCOMP(C1_REV!!C1_TF)
JUMP(MASK,FEXIT,B'11')
RESULT =0
ROUTINE ADCOMP(INTEGER TF)
!***********************************************************************
!* COMPILES AN == OR ADDRESS COMPARISON WHICH CAN NOT BE *
!* DOUBLESIDED. BETTER CODE COULD BE GENERATED FOR THE *
!* MOST COMMON CASE IE POINTERNAME==VARIABLE *
!************************************************************************
INTEGER TYPEP,PRECP,LHNAME,RHNAME,FNAME,CMP
RECORD (RD)OPND1
RECORD (TRIPF)NAME CURRT
LHNAME=A(P1+5)<<8!A(P1+6)
FNAME=RHNAME
RHNAME=A(P2+5)<<8!A(P2+6)
IF C1_CMP1=10 THEN CMP=7 ELSE CMP=1
MASK=FCOMP(CMP)
P=P1+1
->FLT UNLESS A(P1+3)=4 AND A(P1+4)=1 AND A(P+FROMAR2(P))=2
P=P1+5; CNAME(4)
TYPEP=TYPE; PRECP=PREC
OPND1=NAMEOPND
OPND1_PTYPE=X'51'
!
FNAME=LHNAME
P=P2+1
->FLT UNLESS A(P2+3)=4 AND A(P2+4)=1 AND A(P+FROMAR2(P))=2
P=P2+5; CNAME(4)
FAULT(83,LHNAME,RHNAME) UNLESS TYPEP=TYPE AND PRECP=PREC
CURRT==TRIPLES(BRECTRIP(COMP,X'51',0,OPND1,NAMEOPND))
CURRT_X1=MASK
IF TF=1 THEN MASK=REVERSE(MASK)
RETURN
FLT:
FAULT(80,0,FNAME)
MASK=7
END
ROUTINE ACOMP(INTEGER TF,DS)
!***********************************************************************
!* TYPE & PREC DEFINE THE EXPRSN IN REVERSE POLISH IN HEAD1 *
!* THIS ROUTINE CONVERTS THE NEXT EXPRSN TO REVERSE POLISH AND *
!* ADDS OPERATORS FOR TYPE CHANGING(IF REQ) CMPRSN AND JUMP *
!***********************************************************************
INTEGER PRECP,TYPEP
PRECP=PTYPE>>4&15; TYPEP=TYPE
MASK=FCOMP(CMP)
!
! ADD OPERATOR AT BOTTOM. EITHER COMPARE(COMP) OR DS COMPARE(DCOMP)
!
PUSH(HEAD2,(COMP+DS)<<FLAGSHIFT,MASK,0)
BOT2=HEAD2
NOPS=NOPS+1; ! FLAG COMPARE
!
! CONVERT NEXT EXPRSN TO REVERSE POLISH AND TO THE SAME TYPE AS THE
! FIRST IF POSSIBLE. MODE=0 INTEGER IF POSSIBLE,=2 REAL, =3 LONGREAL
!
TORP(HEAD2,BOT2,NOPS)
IF TYPEP>TYPE THEN TYPE=TYPEP
! CONCAT(HEAD1,HEAD2)
ASLIST(BOT1)_LINK=HEAD2
BOT1=BOT2; BOT2=0; HEAD2=0
EXPOP(HEAD1,BOT1,NOPS,256+16*PRECP+TYPE); ! PLANT THE CODE
IF DS#0 START
PUSH(HEAD1,EXPOPND_S1,EXPOPND_D,EXPOPND_XTRA)
BOT1=HEAD1
FINISH
IF TF=1 THEN MASK=REVERSE(MASK)
END
ROUTINE STRCOMP(INTEGER DS,TF,LAB,INTEGERNAME WA)
!***********************************************************************
!* 1ST STRING IS DEFINED BY (ACCR) *
!* THIS ROUTINE EVALUATES THE NEXT STRING EXPRS AND PERFORMS *
!* THE COMPARISON & BRANCH. *
!* DS=0 UNLESS THIS COMPARISON IS THE FIRST HALF OF A DBLE-SIDED *
!***********************************************************************
INTEGER MASK,D
RECORD (RD)OPND1
RECORD (TRIPF)NAME CURRT
OPND1=EXPOPND
CSTREXP(48); ! SAVE WK-AREA
WA=VALUE
MASK=FCOMP(CMP)
CURRT==TRIPLES(BRECTRIP(SCOMP+DS,X'35',0,OPND1,EXPOPND))
CURRT_X1=MASK
IF TF=1 THEN MASK=REVERSE(MASK); ! REVERSE MASK TO JMP IF FALS
JUMP(MASK,LAB,B'11')
END
END
ROUTINE JUMP(INTEGER MASK,LAB,FLAGS)
!***********************************************************************
!* CALLS ENTER JUMP WHILE MAINTAINING BITMASK *
!***********************************************************************
IF MASK=0 THEN LAB UNUSED(LAB) AND RETURN
IF LAB=FARLAB THEN FLAGS=JFLAGS
ENTER JUMP(MASK,LAB,FLAGS)
NOTE JUMP(LAB)
IF LAB=FARLAB THEN BITMASK=BITMASK!1 ELSE BITMASK=BITMASK!2
END
ROUTINE NOTE JUMP(INTEGER LABEL)
!***********************************************************************
!* RECORD LABEL JUMPED TO FOR SKIPPING COMPLEX CONDITIONS *
!***********************************************************************
INTEGER I
RECORD (CF)NAME C
CYCLE I=1,1,CMAX
C==CLIST(I)
IF C_LABNO=LABEL THEN C_JUMPED=C_JUMPED+1 AND EXIT
REPEAT
END
END ; ! OF CCOND
INTEGERFN REVERSE(INTEGER MASK)
!***********************************************************************
!* REVERSE THE MASK FOR A JCC(MASK<=15),JAT(>15) OR JAF(>31) *
!***********************************************************************
IF MASK=0 OR MASK=15 THEN RESULT =MASK!!15
RESULT =MASK!!X'8F'
END
INTEGERFN ENTER LAB(INTEGER LAB,FLAGS)
!***********************************************************************
!* ENTER A NEW LABEL ON THE LABEL LIST FOR THE CURRENT LEVEL *
!* 2**0 OF FLAGS = 1 CONDITIONAL ENTRY *
!* 2**1 OF FLAGS = 1 UPDATE ENVIRONMENT *
!* 2**2 OF FLAGS = 1 REPLACE ENV =0 MERGE ENV *
!* THE LABEL LIST *
!* S1 = USE BITS<<8 ! LABEL ADDR *
!* S2 = UNFILLED JUMPS LIST & ENVIRONMENT LIST *
!* S3 = LAB NO - RESET TO FFFF WHEN USED FOR INTERNAL LABELS *
!* RESULT = 1 LABEL ENTERED *
!* RESULT = 0 CONDITIONAL LABEL NOT REQUIRED *
!***********************************************************************
INTEGER CELL,OLDCELL,TRIPNO
RECORD (LISTF)NAME LCELL
CELL=CURRINF_LABEL; OLDCELL=0
WHILE CELL>0 CYCLE
LCELL==ASLIST(CELL)
EXIT IF LCELL_S3=LAB
OLDCELL=CELL; CELL=LCELL_LINK
REPEAT
!
IF CELL<=0 THEN START ; ! LABEL NOT KNOWN
IF FLAGS&1#0 THEN RESULT =0; ! CONDITIONAL ENTRY
PUSH(CURRINF_LABEL,0,0,LAB)
CELL=CURRINF_LABEL
LCELL==ASLIST(CELL)
FINISH
!
! LABEL HAS BEEN REFERENCED - FILL IN ITS ADDRESS
!
IF LCELL_S1&LABSETBIT# 0 THEN START
FAULT(2,0,LAB); ! LABEL SET TWICE
FINISH ELSE START
LCELL_S1=LCELL_S1!LABSETBIT; ! FLAG AS SET
FINISH
!
! NOW FILL JUMPS TO THIS LABEL - JUMP LIST FORMAT GIVEN IN 'ENTER JMP'
!
TRIPNO=ULCONSTTRIP(TLAB,X'61',DONT OPT,FLAGS<<24!LAB,CELL)
IF FLAGS&1#0 AND LAB>MAXULAB THEN REMOVELAB(LAB)
RESULT =1
END
ROUTINE ENTER JUMP(INTEGER TFMASK,LAB,FLAGS)
!***********************************************************************
!* IF LAB HAS BEEN ENCOUNTERED THEN PLANT A JCC OTHERWISE ENTER *
!* THE LABEL IN THE LABEL LIST AND ATTACH THE JUMP TO IT SO IT *
!* CAN BE PLANTED WHEN THE LABEL IS FOUND *
!* THE LABEL LIST IS DESCRIBED UNDER 'ENTER LAB' *
!* THE JUMP SUB-LIST HAS THE FORM *
!* S1= ADDR OF JUMP *
!* S2=SHORT OR LONG FLAG *
!* S3=LINE NO OF JUMP FOR DIAGNOSTICS *
!* *
!* FLAGS BITS SIGNIFY AS FOLLOWS *
!* 2**0 =1 JUMP IS KNOWN TO BE SHORT *
!* 2**1 =1 ENVIRONMENT MERGEING REQUIRED *
!* 2**8 =1 ASSEMBLER JUMP TFMASK =RELEVENT ASS INFO *
!***********************************************************************
INTEGER CELL,I
RECORD (TRIPF)NAME CURRT
RECORD (LISTF)NAME LCELL
IF LAB<MAX ULAB THEN FLAGS=0;! NO MERGE
CELL=CURRINF_LABEL
WHILE CELL>0 CYCLE
LCELL==ASLIST(CELL)
IF LAB=LCELL_S3 THEN EXIT
CELL=LCELL_LINK
REPEAT
-> FIRSTREF IF CELL<=0
-> NOT YET SET IF LCELL_S1&LABSETBIT=0
LCELL_S1=LCELL_S1!X'1000000'; ! FLAG LABEL AS USED
CURRT==TRIPLES(UCONSTTRIP(BJUMP,0,DONT OPT,FLAGS<<24!LAB))
CURRT_OPND1_XTRA=CELL; ! LAB CELL FOR BJUMPS
CURRT_X1=TFMASK
RETURN
FIRSTREF: ! FIRST REFERENCE TO A NEW LABEL
PUSH(CURRINF_LABEL,LABUSEDBIT,0,LAB)
FLAGS=FLAGS!128; ! MARK FIRST USE FOR PASS3
CELL=CURRINF_LABEL
LCELL==ASLIST(CELL)
NOT YET SET: ! LABEL REFERENCED BEFORE
CURRT==TRIPLES(UCONSTTRIP(FJUMP,0,DONT OPT,FLAGS<<24!LAB))
CURRT_X1=TFMASK; ! CONDITIONAL OR NOT ETC
I=LCELL_S2&X'FFFF'; ! MAY BE ENVIRONMENT LIST ADDED
PUSH(I,0,0,LINE)
LCELL_S2=LCELL_S2&X'FFFF0000'!I
CURRT_OPND1_XTRA=CELL<<16!LCELL_S2;! LABEL&JUMP CELL FOR FJUMPS
END
ROUTINE REMOVE LAB(INTEGER LAB)
!***********************************************************************
!* REMOVES A ALBEL FROM THE CURRENT LABEL LIST WHEN KNOWN TO *
!* BE REDUNDANT. MAINLY USED FOR CYCLE LABELS *
!***********************************************************************
INTEGER T
T=UCONSTTRIP(REMLB,X'51',DONT OPT,LAB)
END
INTEGERFN CREATE AH(INTEGER MODE,RECORD (RD)NAME EOPND,NOPND)
!***********************************************************************
!* CREATES AN ARRAYHEAD IN THE ESTACK BY MODIFYING THE *
!* HEAD ALREADY THERE AS FOLLOWS:- *
!* MODE=0 (ARRAYMAPPING) ETOS-4&5 HAS 32BIT ADDR OF FIRST ELEMNT*
!* MODE=1 (ARRAYS IN RECORDS)ETOS-4&5 HAS 32BIT RELOCATION FACTOR*
!***********************************************************************
INTEGER JJ
JJ=BRECTRIP(AHADJ,AHEADPT,0,EOPND,NOPND)
TRIPLES(JJ)_X1=PTYPE<<4!MODE
RESULT =JJ
END ; ! OF ROUTINE CREATE AH
ROUTINE CSNAME(INTEGER Z)
!***********************************************************************
!* COMPILE A SPECIAL NAME - PTYPE=10006 (=%ROUTINE %LABEL) *
!* THEIR TRUE PTYPE IS IN GLOBAL ARRAY TAGS_S2. *
!* SNINFO HAS A FOUR BYTE RECORD FOR EACH NAME (%BI FLAG,PTR, *
!* %SI XTRA). THE TOP BITS OF FLAG CATEGORISE AS FOLLOWS:- *
!* 2**7 SET FOR IMPLICITLY SPECIFIED CONSTRUCT A %SPEC *
!* 2**6 SET FOR IOCP CALL *
!* 2**5 SET FOR BUILT IN MAPPING FUNCTIONS *
!* 2**4 SET IF AD-HOC CODE PLANTED BY THIS ROUTINE *
!* 2**3 SET IF FIRST PARAMETER IS OF %NAME TYPE *
!* 2**2-2**0 HOLD NUMBER OF PARAMS *
!* *
!* THE FULL SPECS ARE AS FOLLOWS:- *
!* 0=%ROUTINE SELECT INPUT(%INTEGER STREAM) *
!* 1=%ROUTINE SELECT OUTPUT(%INTEGER STREAM) *
!* 2=%ROUTINE NEWLINE *
!* 3=%ROUTINE SPACE *
!* 4=%ROUTINE SKIP SYMBOL *
!* 5=%ROUTINE READ STRING(%STRINGNAME S) *
!* 6=%ROUTINE NEWLINES(%INTEGER N) *
!* 7=%ROUTINE SPACES(%INTEGER N) *
!* 8=%INTEGERFN NEXT SYMBOL *
!* 9=%ROUTINE PRINT SYMBOL(%INTEGER SYMBOL) *
!* 10=%ROUTINE READ SYMBOL(%NAME SYMBOL) *
!* 11=%ROUTINE READ(%NAME NUMBER) *
!* 12=%ROUTINE WRITE(%INTEGER VALUE,PLACES) *
!* 13=%ROUTINE NEWPAGE *
!* 14=%INTEGERFN ADDR(%NAME VARIABLE) *
!* 15=%LONGREALFN ARCSIN(%LONGREAL X) *
!* 16=%INTEGERFN INT(%LONGREAL X) *
!* 17=%INTEGERFN INTPT(%LONRGREAL X) *
!* 18=%LONGREALFN FRACPT(%LONGREAL X) *
!* 19=%ROUTINE PRINT(%LONGREAL NUMBER,%INTEGER BEFORE,AFTER) *
!* 20=%ROUTINE PRINTFL(%LONGREAL NUMBER,%INTEGER PLACES) *
!* 21=%REALMAP REAL(%INTEGER VAR ADDR) *
!* 22=%INTEGERMAP INTEGER(%INTEGER VAR ADDR) *
!* 23=%LONGREALFN MOD(%LONGREAL X) *
!* 24=%LONGREALFN ARCCOS(%LONGREAL X) *
!* 25=%LONGREALFN SQRT(%LONGREAL X) *
!* 26=%LONGREALFN LOG(%LONGREAL X) *
!* 27=%LONGREALFN SIN(%LONGREAL X) *
!* 28=%LONGREALFN COS(%LONGREAL X) *
!* 29=%LONGREALFN TAN(%LONGREAL X) *
!* 30=%LONGREALFN EXP(%LONGREAL X) *
!* 31=%ROUTINE CLOSE STREAM(%INTEGER STREAM) *
!* 32=%BYTEINTEGERMAP BYTE INTEGER(%INTEGER VAR ADDR) *
!* 33=%INTEGERFN EVENTINF *
!* 34=%LONGREALFN RADIUS(%LONGREAL X,Y) *
!* 35=%LONGREALFN ARCTAN(%LONGREAL X,Y) *
!* 36=%BYTEINTEGERMAP LENGTH(%STRINGNAME S) *
!* 37=%ROUTINE PRINT STRING(%STRING(255) MESSAGE) *
!* 38=%INTEGERFN NL *
!* 39=%LONGREALMAP LONG REAL(%INTEGER VAR ADDR) *
!* 40=%ROUTINE PRINT CH(%INTEGER CHARACTER) *
!* 41=%ROUTINE READ CH(%NAME CHARACTER) *
!* 42=%STRINGMAP STRING(%INTEGER VAR ADDR) *
!* 43=%ROUTINE READ ITEM(%STRINGNAME ITEM) *
!* 44=%STRING(1)%FN NEXT ITEM *
!* 45=%BYTEINTEGERMAP CHARNO(%STRINGNAME STR,%INTEGER CHARREQD) *
!* 46=%STRING(1)%FN TOSTRING(%INTEGER SYMBOL) *
!* 47=%STRING(255)%FN SUBSTRING(%STRINGNAME S,%INTEGER BEG,END) *
!* 48=%RECORDMAP RECORD(%INTEGER REC ADDR) *
!* 49=%ARRAYMAP ARRAY(%INTEGER A1ADDR,%ARRAYNAME FORMAT) *
!* 50=%INTEGERFN SIZEOF(%NAME X) *
!* 51=%INTEGERFN IMOD(%INTEGER VALUE) *
!* 52=%LONGREALFN PI *
!* 53=%INTEGERFN EVENTLINE *
!* 54=%LONGINTEGERMAP LONGINTEGER(%INTEGER ADR) *
!* 55=%LONGLONGREALMAP LONGLONGREAL(%INTEGER ADR) *
!* 56=%LONGINTGEREFN LENGTHENI(%INTEGER VAL) *
!* 57=%LONGLONGREALFN LENGTHENR(%LONGREAL VAL) *
!* 58=%INTEGERFN SHORTENI(%LONGINTEGER VAL) *
!* 59=%LONGREALFN SHORTENR(%LONGLONGREAL VAL) *
!* 60=%INTEGERFN NEXTCH *
!* 61=%HALFINTEGERMAP HALFINTEGER(%INTEGER ADDR) *
!* 62=%ROUTINE PPROFILE *
!* 63=%LONGREALFN FLOAT(%INTEGER VALUE) *
!* 64=%LONGINTEGERFN LINT(%LONGLONGREAL X) *
!* 65=%LONGINTEGERFN LINTPT(%LONGLONGREAL X) *
!* 66=%SHORTINTEGERMAP SHORTINTEGER(%INTEGER N) *
!***********************************************************************
INTEGERFNSPEC OPTMAP
SWITCH ADHOC(1:17)
CONSTINTEGERARRAY SNINFO(0:NO OF SNS)=C
X'41080001',X'41090001',X'408A0001',X'40A00001',
X'40010001',X'800D0000',X'11010001',X'11010001',
X'10020024',X'41030001',X'19030001',X'80130001',
X'80170014',X'408C0001',X'19050024',X'80010002',
X'11040024',X'11040024',X'80010005',X'80090006',
X'80060007',X'2100003E',X'2100003E',X'11060024',
X'80010008',X'80010009',X'8001000A',X'8001000B',
X'8001000C',X'8001000D',X'8001000E',X'8015000F',
X'2100003E',X'100D0024',X'80030010',X'80030011',
X'1907003E',X'41070001',X'10080024',X'2100003E',
X'41050001',X'19030001',X'2100003E',X'19030001',
X'10020024',X'1A07003E',X'11090024',X'800F0012',
X'110A0018',X'120B1000',X'80130013',X'11060024',
X'100C0024',X'100D0024',X'2100003E'(2),
X'110E0024'(4),
X'10020024',X'2100003E',X'100F0001',X'11100024',
X'11110024',X'11110024',X'2100003E';
CONSTSTRING (11)ARRAY SNXREFS(0:20)=C
"readstring", "s#read", "s#iarcsin", "s#int",
"s#intpt" , "s#fracpt", "s#print" , "s#printfl",
"s#iarccos","s#isqrt" , "s#ilog" , "s#isin",
"s#icos" , "s#itan" , "s#iexp" , "closestream",
"s#iradius","s#iarctan","s#substring","s#sizeof",
"s#write" ;
!
! SNPARAMS HOLDS NUMBER AND PTYPE OF FORMAL PARAMETER FOR IMPLICITLY
! SPECIFIED EXTERNAL ROUTINES. A POINTER IN SNINFO MEANS THAT NO
! DUPLICATES NEED TO BE RECORDED.
!
IF PARAMS BWARDS=YES THEN START
CONSTINTEGERARRAY SNPARAMS(0:25)=0{NO PARAMS},
1,LRLPT{%LONGREAL X},
2,8<<16!LRLPT,LRLPT{%LONGREAL X,Y},
2,12<<16!LRLPT,4<<16!X'51'{%LONGREAL X,%INTEGER I},
3,8<<16!LRLPT,4<<16!X'51',X'51'{%LONGREAL X,%INTEGER I,J},
1,X'435'{%STRINGNAME S},
3,8<<16!X'435',4<<16!X'51',X'51'{%STRINGNAME S,%INTEGER I,J},
1,X'400'{%NAME X},
1,4<<16!X'51'{%INTEGER I},
2,4<<16!X'51',X'51'{%INTEGER I,J};
FINISH ELSE START
CONSTINTEGERARRAY SNPARAMS(0:25)=0{NO PARAMS},
1,LRLPT{%LONGREAL X},
2,LRLPT,8<<16!LRLPT{%LONGREAL X,Y},
2,LRLPT,8<<16!X'51'{%LONGREAL X,%INTEGER I},
3,LRLPT,4<<16!X'51',8<<16!X'51'{%LONGREAL X,%INTEGER I,J},
1,X'435'{%STRINGNAME S},
3,X'435',8<<16!X'51',12<<16!X'51'{%STRINGNAME S,%INTEGER I,J},
1,X'400'{%NAME X},
1,4<<16!X'51'{%INTEGER I},
2,X'51',4<<16!X'51'{%INTEGER I,J};
FINISH
!
CONSTBYTEINTEGERARRAY WRONGZ(0:15)=27,29,23,29,29,23,82,109(5),
23,27,109(2);
ROUTINESPEC RTOS
INTEGERFNSPEC CIOCP(INTEGER N,RECORD (RD)NAME PARAM)
RECORD (LISTF)NAME LCELL
RECORD (LISTF)PCELL
RECORD (RD)OPND
RECORD (TRIPF)NAME CURRT
STRING (11)SNXREF
INTEGER ERRNO,FLAG,POINTER,PIN,SNNO,SNNAME,NAPS,SNPTYPE,JJ,C
XTRA,IOCPEP,B,D,SNINF,P0,OPHEAD,ERRVAL,EXPHEAD,EXPBOT,NOPS
SNNAME=FROM AR2(P)
SNNO=K; ! INDEX INTO SNINFO
TESTAPP(NAPS); ! COUNT ACTUAL PARAMETERS
PIN=P; P=P+2
SNPTYPE=ACC
SNINF=SNINFO(SNNO)
XTRA=SNINF&X'FFFF'
POINTER=(SNINF>>16)&255
FLAG=SNINF>>24
!
! THE IMPLICITLY SPECIFIED ROUTINE ARE THE EASIEST OF ALL TO DEAL WITH.
! JUST SET UP THE EXTERNAL SPEC & PARAMETERS. THEN A RECURSIVE CALL
! OF CNAME THEN FINDS THE ROUTINE UNDER ITS TRUE COLOURS AND COMPILES
! THE CALL. ALL CALLS EXCEPT THE FIRST ARE DEALT WITH DIRECTLY BY CNAME.
! ALL NONTRIVIAL ROUTINES SHOULD BE DEALT WITH IN THIS MANNER
! XTRA HAS INDEX INTO ARRAY OF EXTERNAL NAMES SO THAT THESE
! CAN EASILY BE CHANGED.
!
IF FLAG&X'80'#0 THEN START
SNXREF=SNXREFS(XTRA)
IF TARGET=EMAS OR TARGET=IBM OR TARGET=IBMXA OR TARGET=PNX THEN C
CXREF(SNXREF,3*PARM_DYNAMIC,2,JJ);! JJ SET WITH REF DISPLACEMENT
IF TARGET=PERQ OR TARGET=ACCENT THEN START
JJ=ADDR(SNXREF)
D=LENGTH(SNXREF)
MOVE BYTES(D+1,JJ,0,ADDR(A(0)),WORKA_ARTOP)
JJ=ADDR(A(WORKA_ARTOP))-ADDR(A(WORKA_DICTBASE))
WORKA_ARTOP=(WORKA_ARTOP+D+4)&(-4)
FINISH
! %IF SNNO=26 %THEN LOGEPDISP=JJ
! %IF SNNO=30 %THEN EXPEPDISP=JJ
OPHEAD=0; P0=SNPARAMS(POINTER)
K=OPHEAD; D=1
WHILE D<=P0 CYCLE
B=SNPARAMS(POINTER+D)
PTYPE=B&X'FFFF'
UNPACK
IF NAM=0 THEN ACC=BYTES(PREC) ELSE ACC=8
IF PTYPE=X'35' THEN ACC=256;!STRING BY VALUE
PCELL=0; ! SET UP PARAMETER DESC VIA RECORD
PCELL_PTYPE=PTYPE; ! FOR CONSISTENCY ON BYTE SWOPPED HOSTS
PCELL_SNDISP=B>>16
PCELL_ACC=ACC
IF PARAMS BWARDS=YES THEN PUSH(OPHEAD,PCELL_S1,PCELL_S2,0) C
ELSE INSERTAT END(OPHEAD,PCELL_S1,PCELL_S2,0)
D=D+1
REPEAT
IF P0>0 THEN ASLIST(OPHEAD)_S3=P0;! INSERT NO OF PARAMS
! UPPER PART OF P0(TOTAL PARAMSPACE)
! APPARENTLY NOT NEEDED AS NO BODIES
! ARE PROVIDED. FIELD COULD BE
! GIVEN EASILY IN ABOVE TABLES
LCELL==ASLIST(TAGS(SNNAME))
LCELL_PTYPE=SNPTYPE
LCELL_UIOJ=1<<4!14; ! I=1 & J=14
LCELL_SNDISP=JJ; ! RT ENTRY DISPLACEMENT
LCELL_ACC=BYTES(SNPTYPE>>4&15)
LCELL_SLINK=OPHEAD
LCELL_KFORM=0; ! KFORM(=FORMAT INFO)
P=PIN; CNAME(Z); ! RECURSIVE CALL
P=P-1; RETURN ; ! DUPLICATES CHECK OF <ENAME>
FINISH
!
! ALL ROUTINES EXCEPT THE IMPLICITS REQUIRE A CHECK THAT THE USE OF THE
! NAME IS LEGAL AND THAT THE CORRECT NO OF PARAMETERS(BOTTOM 2 BITS OF
! FLAG) HAS BEEN SUPPLIED. THE CHECK IS TRIVIAL - THE PROBLEM
! IS TO GET THE RIGHT ERROR NUMBER.
! XTRA HAS A BITMASK OF ALLOWED USES(IE ALLOWED Z VALUES)
!
ERRVAL=NAPS-FLAG&3
IF ERRVAL>0 THEN ERRNO=19 AND ->ERREXIT
IF ERRVAL<0 THEN ERRNO=18 AND ERRVAL=-ERRVAL AND ->ERREXIT
JJ=1<<Z
IF JJ&XTRA=0 THEN START ; ! ILLEGAL USE
ERRNO=WRONGZ(Z)
->ERR EXIT
FINISH
!
! A NUMBER OF INPUT-OUTPUT ROUTINES ARE MAPPED ONTO CALLS OF IOCP.
! THIS ARRANGEMENT HAS THE ADVANTAGE OF REQUIRING ONL 1 EXTERNAL REF
! IN THE GLA BUT HAS THE DISADVANTAGE THAT THE I-O ROUTINES CAN NOT
! BE PASSED AS RT-TYPE PARAMETERS AS WELL AS REQUIRING MESSY CODE
! HEREABOUTS. SNINF_PTR HOLD EITHER:-
! 1) THE IOCP ENTRY POINT NO
! OR 2) THE SYMBOL TO BE OUTPUT WITH 2**7 BIT SET
!
! THIS SECTION DEALS WITH SELECT INPUT,SELECT OUTPUT,NEWLINE,NEWPAGE
! SPACE,SKIP SYMBOL,PRINT SYMBOL,PRINT STRING
! AND PRINT CH
!
IF FLAG&X'40'#0 THEN START
IOCPEP=POINTER
IF FLAG&3#0 THEN START ; ! RT HAS PARAMS
P=P+1
IF SNNO=37 THEN CSTREXP(32) ELSE CSEXP(X'51')
FINISH ELSE EXPOPND=0 AND EXPOPND_PTYPE=X'51'
IF IOCPEP>127 THEN START
EXPOPND_FLAG=SCONST
EXPOPND_D=IOCPEP&127
IOCPEP=5
FINISH
JJ=CIOCP(IOCPEP,EXPOPND); ! PLANT CALL OF IOCP
P=P+1
->OKEXIT
FINISH
!
! THE BUILT-IN MAPS (INTEGER ETC BUT NOT RECORD OR ARRAY)
!
IF FLAG&X'20'#0 THEN START
SNPTYPE=X'1C00'+SNPTYPE; ! ADD MAP BITS
IF PARM_OPT=0 AND OPTMAP#0 THEN ->OKEXIT
IF Z=1 THEN BIMSTR=1; ! SPECIAL FLAG FOR STORE VIA MAP
P=P+1
CSEXP(X'51'); P=P+1
IF Z=1 THEN BIMSTR=0
DISP=0; ACCESS=3; BASE=0
OLDI=0; ! FOR CHECK IN == ASSGNMNT
->OKEXIT
FINISH
!
! ADHOC CODING IS REQUIRED FOR THE REMAINING ROUTINES APART FROM
! A CHECK FOR NAMETYPE PARAMETERS. THE SWITCH NO IS KEPT IN POINTER
!
P=P+1
IF FLAG&8#0 AND C
(A(P+3)#4 OR A(P+4)#1 OR A(P+FROM AR2(P+1)+1)#2) THEN C
ERRNO=22 AND ERRVAL=1 AND ->ERREXIT
->ADHOC(POINTER)
ADHOC(1): ! NEWLINES(=6) & SPACES(=7)
IF SNNO=6 THEN JJ=10 ELSE JJ=32
EXPHEAD=0; NOPS=2
PUSH(EXPHEAD,ORL<<FLAGSHIFT,0,0); ! OPERATOR '!'
EXPBOT=EXPHEAD
PUSH(EXPHEAD,MINAPT<<PTSHIFT,JJ,0);! CONST JJ
PUSH(EXPHEAD,LSHIFT<<FLAGSHIFT,0,0);! OPERATOR '<<'
PUSH(EXPHEAD,MINAPT<<PTSHIFT,8,0);! CONST 8
P=P+3; TORP(EXPHEAD,EXPBOT,NOPS)
EXPOP(EXPHEAD,EXPBOT,NOPS,X'51'); ! EVAL REPTN<<8!SYMBOL IN GR1
JJ=CIOCP(17,EXPOPND)
P=P+1
->OKEXIT
ADHOC(2): ! NEXTSYMBOL(=8) & NEXTITEM(=44)
! ALSO NEXTCH(=60)
IF SNNO=60 THEN JJ=18 ELSE JJ=2
EXPOPND=0; EXPOPND_PTYPE=X'51'
JJ=CIOCP(JJ,EXPOPND); ! LEAVES THE SYMBOL IN GR1
IF SNNO=44 THEN ->TOST; ! TREAT AS TOSTRING
NAMEOPND_PTYPE=MINAPT
NAMEOPND_FLAG=REFTRIP
NAMEOPND_D=JJ
->OKEXIT
ADHOC(3): ! READSYMBOL(=10),CH(=41)&ITEM(=43)
IF SNNO=41 THEN JJ=4 ELSE JJ=1
EXPOPND=0; EXPOPND_PTYPE=X'51'
P=P+5
IF SNNO=43 THEN START
EXPOPND_D=CIOCP(JJ,EXPOPND)
EXPOPND_PTYPE=X'41'; EXPOPND_FLAG=REFTRIP
TYPE=5; RTOS
OPND=NAMEOPND
CNAME(3)
JJ=BRECTRIP(STRASS1,X'35',0,NAMEOPND,OPND)
FINISH ELSE START
EXPHEAD=0; NOPS=1
FNAME=A(P)<<8!A(P+1)
REDUCE TAG
FAULT(25,0,0) UNLESS TYPE=1
IF LHSADDRFIRST=NO OR (NAM=ARR=0 AND A(P+2)=2=A(P+3)) THEN C
PUSH(EXPHEAD,PTYPE<<PTSHIFT!ARNAME<<FLAGSHIFT,P,FNAME) ELSE C
CNAME(3) AND PUSH(EXPHEAD,NAMEOPND_S1,NAMEOPND_D,NAMEOPND_XTRA)
EXPBOT=EXPHEAD
EXPOPND_PTYPE=X'51'; EXPOPND_FLAG=SCONST
EXPOPND_D=0
JJ=CIOCP(JJ,EXPOPND)
BINSERT(EXPHEAD,EXPBOT,MINAPT<<PTSHIFT!REFTRIP<<FLAGSHIFT,JJ,0)
BINSERT(EXPHEAD,EXPBOT,VASS<<FLAGSHIFT,PTYPE,0)
EXPOP(EXPHEAD,EXPBOT,NOPS,PTYPE&255!256)
FINISH
P=PIN+6+FROM AR2(PIN+4)
->OKEXIT
ADHOC(17): ! LINT(=64) AND LINTPT(=65)
UNLESS TYPEFLAG(10)&255=X'61' AND TYPEFLAG(12)&255=X'72' C
THEN ERRNO=99 AND ->ERREXIT;! NEED LONGINTS&LLREALS
CSEXP(X'72'); ! LONGLONGREAL MODE
IF SNNO=64 THEN JJ=RTOI1 ELSE JJ=RTOI2
P0=X'61'; ->FIXIT
ADHOC(4): ! INT(=16) AND INTPT (=17)
CSEXP(LRLPT)
IF SNNO=16 THEN JJ=RTOI1 ELSE JJ=RTOI2
P0=X'51'; ! FIXES TO INTEGER
FIXIT:JJ=URECTRIP(JJ,P0,0,EXPOPND)
P=P+1
NAMEOPND_PTYPE=P0; NAMEOPND_FLAG=REFTRIP
NAMEOPND_D=JJ
->OKEXIT
ADHOC(5): ! ADDR(=14)
P=P+5; CNAME(4); ! FETCH ADDRESS MODE
P=P+2; ->OKEXIT
ADHOC(6): ! MOD(=23), IMOD(=51)
EXPHEAD=0; NOPS=1
PUSH(EXPHEAD,MODULUS<<FLAGSHIFT,0,0)
EXPBOT=EXPHEAD
P=P+3
TORP(EXPHEAD,EXPBOT,NOPS)
EXPOP(EXPHEAD,EXPBOT,NOPS,SNPTYPE)
NAMEOPND=EXPOPND
P=P+1
->OKEXIT
ADHOC(7): ! CHARNO(=45) & LENGTH(=36)
P=P+5
CNAME(4)
OPND=NAMEOPND
B=BML; D=DML
ERRNO=22; ERRVAL=1
->ERREXIT UNLESS TYPE=5 AND (ROUT=0 OR NAM>=2)
IF NAM=0 AND LITL=1 THEN FAULT(43,0,FROMAR2(PIN+8))
P=P+2
IF SNNO#36 THEN START
CSEXP(MINAPT)
P=P+1
FINISH ELSE EXPOPND=0 AND EXPOPND_PTYPE=X'41' AND EXPOPND_FLAG=SCONST
JJ=BRECTRIP(SINDX,X'31',0,OPND,EXPOPND)
CURRT==TRIPLES(JJ)
CURRT_X1=1<<20; ! ADJUSTMENT BASE ON 1 BYTE ELEMENTS
EXPOPND_PTYPE=X'31'; EXPOPND_FLAG=REFTRIP
EXPOPND_D=JJ
EXPOPND_XTRA=0
DISP=0; ACCESS=3
STNAME=-1 IF Z=1; ! CANT REMEBER NAME
SNPTYPE=SNPTYPE+X'1C00'
->OKEXIT
ADHOC(12): ! PI(=52)
ADHOC(8): ! NL(=38). THIS FN IS PICKED OFF
P=P+1
->OKEXIT; ! ERROR EG NL=A+B
ADHOC(9): ! TOSTRING(=46)
CSEXP(MINAPT); ! RET EXPSN
P=P+1
TOST:
RTOS
STRFNRES=0
SNPTYPE=X'1035'; ! TYPED AS STRING FN
->OKEXIT
ADHOC(10): ! RECORD(=48)
CSEXP(X'51')
P=P+1
DISP=0; BASE=0; ACCESS=3
OLDI=0; ACC=X'FFFF'
SNPTYPE=SNPTYPE+X'1C00'; ! ADD MAP BITS
->OKEXIT
ADHOC(11): ! ARRAY(=49)
CSEXP(X'51'); ! ADDR(A(0)) TO NEST
OPND=EXPOPND
ERRNO=22; ERRVAL=2
->ERREXIT UNLESS A(P+4)=4 AND A(P+5)=1
P=P+6; CNAME(12)
->ERREXIT UNLESS A(P)=2 AND ARR>0
P=P+2
NAMEOPND_D=CREATE AH(0,OPND,NAMEOPND)
NAMEOPND_PTYPE=AHEADPT
NAMEOPND_FLAG=REFTRIP
NAMEOPND_XTRA=0
RETURN
ADHOC(13): ! EVENTINF(=33) & EVENTLINE
D=CURRINF_ONINF
FAULT(16,0,SNNAME) IF D=0
D=D+4 IF SNNO#33
BASE=RBASE; ACCESS=0
DISP=D; SNPTYPE=SNPTYPE+X'1C00';! ADD MAP BITS
->OKEXIT
ADHOC(14): ! LENGTHEN AND SHORTEN
D=(SNNO&3)*8
CSEXP(X'52415251'>>D&255)
P=P+1
NAMEOPND=EXPOPND
->OKEXIT
ADHOC(15): ! PPROFILE(IGNORED UNLESS PARM SET)
JJ=UCONSTTRIP(PPROF,X'51',0,PROFAAD) UNLESS PARM_PROF=0
->OKEXIT
ADHOC(16): ! FLOAT
CSEXP(LRLPT)
NAMEOPND=EXPOPND
P=P+1
OKEXIT: ! NORMAL EXIT
PTYPE=SNPTYPE; UNPACK
RETURN
ERREXIT: ! ERROR EXIT
FAULT(ERRNO,ERRVAL,SNNAME)
NAMEOPND=0; NAMEOPND_PTYPE=X'51'
BASE=0; DISP=0; ACCESS=0; AREA=0
PTYPE=SNPTYPE; UNPACK
P=PIN+2; SKIP APP
P=P-1; RETURN
INTEGERFN OPTMAP
!***********************************************************************
!* LOOK FOR EXPRESSION LIKE INTEGER(ADDR(X)) AND AVOID USING DR *
!***********************************************************************
INTEGER VARNAME,REXP,PP,CVAL,OP
IF SNNO=42 THEN RESULT =0; ! STRINGMAP STRING
PP=P+2; REXP=FROM AR2(PP)+PP; ! TO REST OF EXP
VARNAME=FROM AR2(PP+4); ! SHOULD BE ADDR
RESULT =0 UNLESS A(PP+2)=4 AND A(PP+3)=1
COPY TAG(VARNAME); ! CHECK IT WAS ADDR
->WASADR IF PTYPE=SNPT AND K=14 AND A(PP+6)=1
RESULT =0
WASADR: PP=PP+10
RESULT =0 UNLESS A(PP)=4 AND A(PP+1)=1 AND C
A(PP+4)=2=A(PP+5) AND A(PP+6)=2=A(PP+7) AND A(PP+8)=2
VARNAME=FROM AR2(PP+2); COPY TAG(VARNAME)
RESULT =0 UNLESS PTYPE&X'FF0C'=0
IF A(REXP)=2 THEN P=REXP+2 ELSE START
OP=A(REXP+1)
RESULT =0 UNLESS 1<=OP<=2 AND A(REXP+2)=2 AND C
A(REXP+3)=X'41' AND A(REXP+6)=2
CVAL=FROM AR2(REXP+4)
IF OP=1 THEN K=K+2*CVAL ELSE K=K-2*CVAL
RESULT =0 IF K<0
P=REXP+8
FINISH
BASE=I
DISP=K; ACCESS=0
RESULT =1
END
INTEGERFN CIOCP(INTEGER EP,RECORD (RD)NAME PARAM)
!***********************************************************************
!* CALL IOCP PASSING A PARAMETER
!* RETURNS THE TRIPLE NO OF THE CALL
!***********************************************************************
RECORD (RD) OPND
OPND_PTYPE=MINAPT; OPND_FLAG=SCONST
OPND_D=EP
RESULT =BRECTRIP(IOCPC,MINAPT,0,OPND,PARAM)
END
ROUTINE RTOS
!***********************************************************************
!* PLANTS CODE TO CONVERT A SYMBOL IN EXPOPND TO A ONE *
!* CHARACTER STRING IN A TEMPORARARY VARIABLE. *
!***********************************************************************
INTEGER KK,JJ
IF EXPOPND_FLAG<=1 START
KK=ITOS1
CTOP(KK,JJ,0,EXPOPND,NAMEOPND)
IF KK=0 THEN NAMEOPND=EXPOPND AND RETURN
FINISH
JJ=URECTRIP(ITOS1,X'35',0,EXPOPND)
NAMEOPND_PTYPE=X'35'; NAMEOPND_FLAG=REFTRIP
NAMEOPND_D=JJ
END
END ; ! OF ROUTINE CSNAME
ROUTINE AATORP(INTEGERNAME NOPS,HEAD1,BOT1, INTEGER ARRP,BS,DP)
!***********************************************************************
!* DOES THE HARD WORK OF ARRAY ACCESS BY PRODUCING REVERSE POLISH *
!* EXPRESSION OF THE INDEX EXPRESSIONS & MULTIPLIERS *
!***********************************************************************
RECORD (TAGF) NAME LCELL
INTEGER PTYPEP,KK,PP,JJ,SOLDI,TYPEP,ARRNAME,Q,PRECP,ELSIZE,
NAMINF,DVD,PRIVOPS
INTEGERARRAY HEADS,BOTS(0:12)
RECORD (RD) VMYOP,RPOP
PP=P; TYPEP=TYPE
JJ=J; PTYPEP=PTYPE; PRECP=PREC; SOLDI=OLDI
IF TYPE<=2 THEN ELSIZE=BYTES(PRECP) ELSE ELSIZE=ACC
IF ELSIZE>4095 OR (TYPE=5 AND NAM#0) THEN ELSIZE=0
DVD=SNDISP; ! LOCATION OF DV IF CONSTANT
IF DVD>0 THEN VMYOP_PTYPE=X'51' ELSE VMYOP_PTYPE=X'61'
VMYOP_FLAG=0; VMYOP_XB=0
ARRNAME=FROM AR2(P); ! NAME OF ENTITY
NAMINF=TAGS(ARRNAME)
FAULT(87,0,ARRNAME) IF ARR=3; ! ARRAYFORMAT USED AS ARRAY
NAMINF=-2 AND DVD=0 IF ARRP>2; ! ARRAYS IN RECORDS
TEST APP(Q); ! COUNT NO OF SUBSCRIPTS
!
! CHECK CORRECT NO OF SUBSCRIPTS PROVIDED. HOWEVER ENTITIES DECLARED
! AS %<TYPE>ARRAYNAME HAVE NO DIMENSION . THIS SECTION SETS THE
! DIMENSION FROM THE FIRST USE OF THE NAME.
!
IF JJ=0 THENSTART ; ! 0 DIMENSIONS = NOT KNOWN
LCELL==ASLIST(TCELL)
LCELL_UIOJ=LCELL_UIOJ!Q; ! DIMSN IS BOTTOM 4 BITS OF TAG
JJ=Q
FINISH
IF JJ=Q#0 THENSTART ; ! IN LINE CODE
!
! FOR IN-LINE CODE WE SET UP A CHAIN OF REVERSE POLISH OPERATIONS TO
! EVALUATE THE VARIOUS SUBSCRIPTS,MULTIPLY BY THE MULTIPLIERS AND
! ADD THEM TOGETHER.
!
!
! NOW PROCESS THE SUBSCRIPTS CALLINR TORP TO CONVERT THE EXPRESSIONS
! TO REVERSE POLISH AND ADDING THE EXTRA OPERATIONS.
!
RPOP=0
RPOP_PTYPE=X'51'
RPOP_FLAG=7
RPOP_D=BS<<16!DP
RPOP_XTRA=M'ARRH'
BINSERT(HEAD1,BOT1,RPOP_S1,RPOP_D,RPOP_XTRA)
P=PP+3
CYCLE KK=1,1,JJ; ! THROUGH THE SUBSCRIPTS
P=P+3
HEADS(KK)=0; BOTS(KK)=0; PRIVOPS=0
TORP(HEADS(KK),BOTS(KK),PRIVOPS); ! SUBSCRIPT TO REVERSE POLISH
IF PTYPE=1 AND PRIVOPS&1<<17#0 THEN C
WARN(1,0) AND BINSERT(HEADS(KK),BOTS(KK),SHRTN,0,0)
P=P+1
NOPS=(NOPS+PRIVOPS&X'FFF')!PRIVOPS&X'FFFF0000'
! ADD OPERATORS AND OR FLAGS
!
! MULTIPLIERS ARE DOPE VECTOR ITEMS (OPTYPE=3)
!
! N SUBSCRIPTS WILL REQUIRE (N-1) MULTIPLICATIONS AND ADDITIONS
! ON EMAS HAVE TO ADD ALL OPERATORS AT END SINCE DV ARE BACKWARDS
!
NOPS=NOPS+1
VMYOP_D=KK<<24!JJ<<16!DVD
VMYOP_XTRA=BS<<16!DP
BINSERT(HEADS(KK),BOTS(KK),VMYOP_S1,VMYOP_D,VMYOP_XTRA);! MULTIPLIER
RPOP=0
RPOP_FLAG=VMY
RPOP_D=PTYPEP<<16
IF NAMINF>=0 THEN RPOP_D=RPOP_D!ARRNAME
BINSERT(HEADS(KK),BOTS(KK),RPOP_S1,RPOP_D,0); ! DOPE VECTOR MULTIPLY
IF (TARGET#EMAS AND KK>1) OR (TARGET=EMAS AND KK<JJ) START
RPOP=0; RPOP_FLAG=COMB
BINSERT(HEADS(KK),BOTS(KK),RPOP_S1,0,0); ! COMBINE WITH PREVIOUS
NOPS=NOPS+1
FINISH
REPEAT
CYCLE KK=1,1,JJ
IF TARGET#EMAS START
ASLIST(BOT1)_LINK=HEADS(KK)
BOT1=BOTS(KK)
FINISH ELSE START
ASLIST(BOT1)_LINK=HEADS(JJ+1-KK)
BOT1=BOTS(JJ+1-KK)
FINISH
REPEAT
UNLESS ARRP=2 OR C
((TARGET=PERQ OR TARGET=ACCENT) AND PARM_COMPILER#0) START ; ! BASE ADJUST
VMYOP_D=JJ<<16!DVD
BINSERT(HEAD1,BOT1,VMYOP_S1,VMYOP_D,VMYOP_XTRA)
RPOP=0
RPOP_FLAG=BADJ; RPOP_D=PTYPE<<16!ARRNAME
BINSERT(HEAD1,BOT1,RPOP_S1,RPOP_D,0)
FINISH
RPOP=0; RPOP_FLAG=AINDX
RPOP_D=BS<<16!DP!ELSIZE<<20
BINSERT(HEAD1,BOT1,RPOP_S1,RPOP_D,0); ! SCALE
NOPS=NOPS+2
FINISHELSESTART
RPOP=0; RPOP_FLAG=SCONST
BINSERT(HEAD1,BOT1,RPOP_S1,0,0)
IF JJ>Q THEN FAULT(20,JJ-Q,ARRNAME) ELSE FAULT(21,Q-JJ,ARRNAME)
P=P+2; SKIP APP
FINISH
ACC=ELSIZE
PTYPE=PTYPEP; J=JJ
END
ROUTINE CANAME(INTEGER Z,ARRP,BS,DP)
!***********************************************************************
!* BS & DP DEFINE THE POSITION OF THE ARRAY HEAD *
!* ARRP=1 FOR ARRAYS,2 FOR VECTORS,3 FOR ARRAYS IN RECORDS *
!* BASIC DISP = DISPMNT OF A(0) FOR VECTORS OR ARRAYS IN RECORDS *
!***********************************************************************
INTEGER HEAD1,BOT1,NOPS,ELSIZE,PTYPEP,JJ,SOLDI
NOPS=0; HEAD1=0; BOT1=0
AATORP(NOPS,HEAD1,BOT1,ARRP,BS,DP)
SOLDI=OLDI
PTYPEP=PTYPE; JJ=J; ELSIZE=ACC
EXPOP(HEAD1,BOT1,NOPS,X'51'); ! EVALUATE THE REVERSE POLISH LIST
! CONSTANT ACCEPTABLE AS RESULT
BASE=BS; DISP=DP; ACCESS=3
ACC=ELSIZE; PTYPE=PTYPEP; UNPACK; J=JJ
IF TYPE=5 AND NAM>0 THEN BML=BS AND DML=DP
OLDI=SOLDI; ! FOR NAME==A(EL) VALIDATION
END ; ! OF ROUTINE CANAME
ROUTINE CNAME(INTEGER Z)
!***********************************************************************
!* THIS IS THE MAIN ROUTINE FOR PROCESSING NAMES.CANAME,CSNAME *
!* AND CRNAME ARE ONLY CALLED FROM HERE,THE NAME (AND ANY PARAMS *
!* OR SUBNAMES) ARE ACCESSED BY P WHICH IS ADVANCED. *
!* Z SPECIFIES ACTION AS FOLLOWS:- *
!* Z=0 COMPILE A ROUTINE CALL *
!* Z=1 ARRANGE A 'STORE' OPERATION FROM ESTACK *
!* Z=2 FETCH NAME TO ESTACK *
!* Z=3 GET 32 BIT ADDRESS(48BIT FOR BYTES) FOR PASSING BY NAME *
!* Z=4 SET 20 BIT ADDRESS(36BIT FOR BYTES) OF NAME IN REG *
!* Z=5 AS Z=2 *
!* Z=6 STORE ETOS (CONTAINS POINTER) INTO POINTER VARIABLE *
!* Z=7->10 NOT NOW USED *
!* Z=11 FETCH 32 BIT ADDRESS OF ARRAYHEAD *
!* Z=12 FETCH ARRAYHEAD TO ESTACK *
!* Z=13 GET 4 WORD ROUTINE DISCRIPTOR *
!* (INTERNAL ROUTINES FIRST CREATE THE DISCRIPTOR) *
!* *
!***********************************************************************
INTEGER JJ, KK, LEVELP, DISPP, NAMEP, PP, SAVESL, FNAME
SWITCH S, FUNNY(11:13), SW(0:8)
PP=P
FNAME=A(P)<<8+A(P+1)
IF Z=1 OR Z=6 THEN STNAME=FNAME
COPYTAG(FNAME)
IF I=-1 THEN START
FAULT(16, 0, FNAME)
PTYPE=X'57'
STORE TAG(FNAME,LEVEL,RBASE,0,0,4,N,0)
N=N+4; COPYTAG(FNAME); ! SET USE BITS!
FINISH
SAVESL=ACC
JJ=J; JJ=0 IF JJ=15
NAMEP=FNAME
LEVELP=I; DISPP=K
FAULT(43, 0, FNAME) IF LITL=1 AND ROUT=0=NAM AND C
(Z=1 OR Z=3 OR (Z=4 AND ARR=0))
->NOT SET IF TYPE=7
IF (Z=0 AND (ROUT#1 OR 0#TYPE#6)) OR (Z=13 AND ROUT=0) C
THEN FAULT(27,0,FNAME) AND ->NOT SET
->FUNNY(Z) IF Z>=10
->RTCALL IF ROUT=1
->SW(TYPE)
SW(6):
FAULT(5, 0, FNAME)
->NOT SET
SW(4): !RECORD FORMAT NAME
FAULT(87,0,FNAME)
SW(7):
NOT SET: ! NAME NOT SET
BASE=I; DISP=K; ACCESS=0
NAMEOPND=0; NAMEOPND_PTYPE=X'51'
PTYPE=X'51'; UNPACK
IF 1<=Z<=5 THEN NAMEOP(Z,4,NAMEP)
P=P+2; SKIP APP; ->CHKEN
FUNNY(11): ! SET 32 BIT ADRESS OF ARRAYHEAD
FUNNY(12): ! MOVE ARRAYHEAD TO ESTACK
->SW(3) IF TYPE=3 AND (ARR=0 OR A(P+2)=1)
IF PTYPE=SNPT THEN CSNAME(12) AND ->CHKEN
IF A(P+2)=2 THEN P=P+3 ELSE NO APP
NAMEOPND_PTYPE=AHEADPT
NAMEOPND_FLAG=DNAME
NAMEOPND_D=FNAME
NAMEOPND_XTRA=0
->CHKEN
S(12):S(11): ! ARRAYS IN RECORDS BY NAME
->CHKEN
FUNNY(13): ! LOAD ADDR FOR RT-TYPE
IF PTYPE=SNPT THEN CSNAME(Z) AND P=P+1 AND ->CHKEN
JJ=UNAMETRIP(RTFP,RTPARAMPT,0,FNAME)
NAMEOPND_PTYPE=RTPARAMPT; NAMEOPND_FLAG=REFTRIP
NAMEOPND_D=JJ
NAMEOPND_XTRA=0
IF A(P+2)=2 THEN P=P+3 ELSE NO APP
->CHKEN
RMAP: ! RECORD MAPS
RFUN: ! RECORD FUNCTIONS
COPY TAG(NAMEP); ! SET KFORM ETC
P=P-3
NAMEP=-1
CRNAME(Z,3,0,0,NAMEP)
->RBACK
SW(3): ! RECORD
CRNAME(Z, 2*NAM, I, K, NAMEP)
RBACK:
->S(Z) IF Z>=10
->STRINREC IF TYPE=5 AND Z#6
->NOT SET IF TYPE=7
NAMEOP(Z,BYTES(PREC),NAMEP)
STNAME=NAMEP IF Z=1 OR Z=6
->CHKEN
SW(5): ! TYPE =STRING
!
! ALL STRING OPERATIONS ARE ON THE RELEVANT DESCRIPTOR. Z=2 &Z=5
! REQUIRE A CURRENT LENGTH(IE MODIFIED) DESCRIPTOR. OTHER OPERATIONS
! REQUIRE THE MAX LENGTH DESCRIPTOR (IE UNMODIFIED HEADER)
!
IF Z=6 THEN ->SW(1)
->STRARR IF ARR>=1
IF A(P+2)=2 THEN P=P+3 ELSE NO APP
BASE=I; ACCESS=2*NAM; DISP=K
SMAP: IF NAM#1 THEN BML=-1 AND DML=SAVESL-1 C
ELSE BML=I AND DML=K
NAMEOP(Z,4,NAMEP)
->CHKEN
STRARR: ! STRINGARRAYS & ARRAYNAMES
CANAME(Z, ARR, I, K)
->SMAP UNLESS Z=3 AND NAM#0
BML=LEVELP; DML=DISPP
NAMEOP(3,4,NAMEP)
->CHKEN
STRINREC: ! STRINGS IN RECORDS
SAVESL=ACC
->SMAP UNLESS Z=3 AND NAM#0 AND ARR#0
DML=DISP; BML=BASE; ! LEFT SET BY CENAME
NAMEOP(3,4,NAMEP)
->CHKEN
!
! SECTION TO DEAL WITH ALL NAMES INVOLVING ROUTINE CALL
!
RTCALL: ! FIRST CHECK
IF TYPE=0 AND Z#0 THEN FAULT(23, 0, FNAME) AND ->NOT SET
! RT NAME IN EXPRSN
IF PTYPE=SNPT THEN START
CSNAME(Z); ! SPECIAL NAME
->BIM IF ROUT=1 AND NAM>1 AND Z#0
->CHKEN
FINISH
CRCALL(FNAME); P=P+1; ! DEAL WITH PARAMS
->CHKEN IF PTYPE&15=0
->UDM IF NAM>1; ! MAPS
UNLESS Z=2 OR Z=5 THEN START ; ! FUNCTIONS
FAULT(29, 0, FNAME); BASE=0
ACCESS=0; DISP=0
FINISH
->RFUN IF TYPE=3
->CHKEN
UDM: ! USER DEFINED MAPS
DISP=0
ACCESS=3
BASE=0
EXPOPND=NAMEOPND
->RMAP IF TYPE=3
BIM: ! BUILT IN MAPS
NAMEP=-1
STNAME=-1
IF TYPE=5 THEN SAVESL=256 AND ->SMAP
KK=Z; KK=2 IF Z=5
NAMEOP(Z,BYTES(PREC),NAMEP)
->CHKEN
SW(0): ! %NAME PARAMETERS NO TYPE
! ALLOW FETCH ADDR OPERATIONS
! AND SPECIAL FOR BUILTIN MAPS
UNLESS 3<=Z<=4 THEN START
FAULT(90,0,FNAME); TYPE=1
FINISH
SW(1): ! TYPE =INTEGER
SW(2): ! TYPE=REAL
IF ARR=0 OR (Z=6 AND A(P+2)=2) THEN START
BASE=I; ACCESS=2*NAM
DISP=K
IF A(P+2)=2 THEN P=P+3 ELSE NO APP
FINISH ELSE START
CANAME(Z, ARR, I, K)
NAM=0
FINISH
NAMEOP(Z,BYTES(PREC),NAMEP)
->CHKEN
!
CHKEN: WHILE A(P)=1 CYCLE
FAULT(69,FROMAR2(P+1),FNAME)
P=P+3; SKIP APP
REPEAT
P=P+1
END
ROUTINE NAMEOP(INTEGER Z, SIZE, NAMEP)
!***********************************************************************
!* FETCH OR STORE ETOS FROM OR TO VARIABLE DEFINED BY AREA ACCESS *
!* BASE AND DISP. *
!***********************************************************************
SWITCH BIGACC(0:11)
RECORD (RD)POPND
INTEGER KK,PPTYPE
KK=Z; KK=2 IF Z=5
IF Z=6 THEN START ; ! NAME DEREFENCING
FAULT(82,0,NAMEP) UNLESS NAMEP&X'FFFF'=X'FFFF' OR C
(NAM!ARR#0 AND ROUT=0 AND (ACCESS>=8 OR ACCESS=2))
Z=1; KK=1; SIZE=4
PPTYPE=X'51'
IF PTRSIZE(PTYPE&255)>4 THEN PPTYPE=X'61';! POINTER PTYPE
PTYPE=PPTYPE
IF ACCESS>=8 THEN ACCESS=ACCESS-4 ELSE ACCESS=0
FINISH
KK=KK&3
XDISP=0 IF ACCESS<=3
->BIGACC(ACCESS)
BIGACC(9): ! ALL ACCESS=9
BIGACC(5):
BIGACC(1): IMPABORT; ! NO LONGER USED?
!
! ACCESS
! ******
! THIS VARIABLE DEFINES HOW TO ACCESS ANY IMP VARIABLE:-
! =0 VARIABLE DIRECTLY ADDRESSED IN 'BASE' BY 'DISP'
! =1 NOT USED
! =2 POINTER TO VARIABLE DIRECTLY ADDRESS BY 'BASE' & 'DISP'
! =3 POINTER AS IN =2 COMPUTED IN EXPOPND
! =4 VARIABLE 'XDISP' INTO RECORD AT BY 'BASE' &'DISP'
! =5 NOT USED
! =6 VAR 'XDISP' INTO RECORD ADDRESSED BY POINTER AT 'BASE' & 'DISP'
! =7 AS =6 BUT POINTER COMPUTED IN EXPOPND
! =8-11 AS 4-7 BUT THERE IS A POINTER TO ITEM AT 'XDISP' INTO RECORD
! POINTER HERE MEANS 32 BIT NORMALLY BUT BYTES MUSTBE AND STRING MAY
! HAVE TO BE 48 BIT
!
BIGACC(0): ! DIRECTLY ADDRESS
IF NAMEP&X'FFFF'#X'FFFF' START
NAMEOPND_PTYPE=PTYPE; NAMEOPND_FLAG=DNAME
NAMEOPND_D=NAMEP&X'FFFF'
FINISH ELSE START
NAMEOPND_PTYPE=PTYPE; NAMEOPND_FLAG=LOCALIR
NAMEOPND_D=BASE<<16!DISP
FINISH
NAMEOPND_XTRA=0
ADOP:
RETURN IF Z=1
IF Z=3 THEN START
POPND_PTYPE=X'61'; POPND_FLAG=SCONST
POPND_D=PTYPE<<16!ACC
POPND_XTRA=BML<<16!DML
PPTYPE=X'51'
IF PTRSIZE(PTYPE&255)>4 THEN PPTYPE=X'61'
NAMEOPND_D=BRECTRIP(GETPTR,PPTYPE,0,NAMEOPND,POPND)
NAMEOPND_PTYPE=PPTYPE
IF TARGET=EMAS THEN TRIPLES(NAMEOPND_D)_X1=J
! TO FIND SIZE OF STRINGARRAYNAME
! EMAS NEEDS DIMENSIONALITY
FINISH ELSE START
IF Z=2 OR Z=5 START ; ! FETCHING
RETURN UNLESS NAMEOPND_FLAG=INDIRECT
NAMEOPND_D=URECTRIP(PRELOAD,PTYPE,0,NAMEOPND)
FINISH ELSE START ; ! Z=4 GET ADDRESS
NAMEOPND_D=URECTRIP(GETAD,X'51',0,NAMEOPND)
NAMEOPND_PTYPE=X'51'; ! ADDRESS IS 32 BIT INTEGER
FINISH
FINISH
NAMEOPND_FLAG=REFTRIP
NAMEOPND_XTRA=0
RETURN
BIGACC(2): ! ALL ACCESS=2
IF NAMEP&X'FFFF'#X'FFFF' START
NAMEOPND_PTYPE=PTYPE; NAMEOPND_FLAG=INDNAME
NAMEOPND_D=NAMEP&X'FFFF'
NAMEOPND_XTRA=X'80000000'
->ADOP
FINISH
EXPOPND_PTYPE=PTYPE; EXPOPND_FLAG=LOCALIR
EXPOPND_D=BASE<<16!DISP
BIGACC(3): ! ACCESS=3
IF EXPOPND_FLAG#REFTRIP START
KK=URECTRIP(PRELOAD,EXPOPND_PTYPE,0,EXPOPND)
EXPOPND_PTYPE=PTYPE; EXPOPND_FLAG=REFTRIP
EXPOPND_D=KK
FINISH
NAMEOPND_PTYPE=PTYPE; NAMEOPND_FLAG=INDIRECT
NAMEOPND_D=EXPOPND_D
NAMEOPND_XTRA=X'80000000'; ! OFFSET NOT RELEVANT PERQ ONLY DISTINCTION
->ADOP
BIGACC(4): ! ALL ACCESS=4
IF NAMEP&X'FFFF'#X'FFFF' START
NAMEOPND_PTYPE=PTYPE; NAMEOPND_FLAG=DNAME
NAMEOPND_D=NAMEP&X'FFFF'
NAMEOPND_XTRA=XDISP
FINISH ELSE START
NAMEOPND_PTYPE=PTYPE; NAMEOPND_FLAG=LOCALIR
NAMEOPND_D=DISP+XDISP
IMPABORT IF TARGET=PNX; ! ABOVE LINE DOES NOT WORK ON PNX
! BUT PDS CANT FATHOM WHAT SORT
! OF SOURCE CODING CAN EVER REACH HERE
NAMEOPND_XTRA=0
FINISH
->ADOP
BIGACC(6): ! ALL ACCESS=6
IF NAMEP&X'FFFF'#X'FFFF' START
NAMEOPND_PTYPE=PTYPE; NAMEOPND_FLAG=INDNAME
NAMEOPND_D=NAMEP&X'FFFF'
NAMEOPND_XTRA=XDISP; ->ADOP
FINISH
NAMEOPND_PTYPE=X'51'; NAMEOPND_FLAG=LOCALIR
NAMEOPND_D=BASE<<16!DISP
NAMEOPND_XTRA=0
KK=URECTRIP(PRELOAD,X'51',0,NAMEOPND)
EXPOPND_PTYPE=PTYPE; EXPOPND_FLAG=REFTRIP
EXPOPND_D=KK
BIGACC(7): ! ALL ACCESS=7
NAMEOPND_PTYPE=PTYPE; NAMEOPND_FLAG=INDIRECT
NAMEOPND_D=EXPOPND_D
NAMEOPND_XTRA=XDISP
->ADOP
BIGACC(8): ! ALL ACCESS=8
IF NAMEP&X'FFFF'#X'FFFF' START
NAMEOPND_PTYPE=X'51'; NAMEOPND_FLAG=DNAME
NAMEOPND_D=NAMEP&X'FFFF'
NAMEOPND_XTRA=XDISP; XDISP=0
FINISH ELSE START
NAMEOPND_PTYPE=X'51'; NAMEOPND_FLAG=LOCALIR
NAMEOPND_D=BASE<<16!DISP
NAMEOPND_XTRA=0
FINISH
KK=URECTRIP(GETAD,X'51',0,NAMEOPND)
EXPOPND_PTYPE=X'51'; EXPOPND_FLAG=REFTRIP
EXPOPND_D=KK
->BIGACC(11); ! HAS BECOME ACESS=11
BIGACC(10): ! ALL ACCESS=10
IF NAMEP&X'FFFF'#X'FFFF' START
NAMEOPND_PTYPE=X'51'; NAMEOPND_FLAG=INDNAME
NAMEOPND_D=NAMEP&X'FFFF'
NAMEOPND_XTRA=XDISP; XDISP=0
FINISH ELSE START
NAMEOPND_PTYPE=X'51'; NAMEOPND_FLAG=LOCALIR
NAMEOPND_D=BASE<<16!DISP
KK=URECTRIP(GETAD,X'51',0,NAMEOPND)
NAMEOPND_FLAG=VIAPTR; NAMEOPND_D=KK
NAMEOPND_XTRA=0
FINISH
KK=URECTRIP(GETAD,X'51',0,NAMEOPND)
EXPOPND_D=KK
EXPOPND_FLAG=REFTRIP
BIGACC(11): ! ALL ACCESS=11
NAMEOPND_PTYPE=PTYPE; NAMEOPND_FLAG=VIAPTR
NAMEOPND_D=EXPOPND_D
NAMEOPND_XTRA=XDISP
->ADOP
END
ROUTINE CRCALL(INTEGER RTNAME)
!***********************************************************************
!* COMPILE A ROUTINE OR FN CALL *
!* THE PROCEDURE CONSIST OF THREE PARTS:- *
!* A) PLANT THE PARAMETER (IF ANY) *
!* B) ENTER THE ROUTINE OR FN *
!* C) FORGET ANY REGISTERS WHICH HOLD ENTITIES THAT CAN BE *
!* ALTERED BY THE CALLED PROCEDURE. *
!***********************************************************************
INTEGER II,III,QQQ,JJ,JJJ,NPARMS,PT,LP,PSIZE,TWSP,PARMNO,ERRNO,FPTR,C
TYPEP,PRECP,NAMP,TL,CLINK,PSPECED,OUTP
RECORD (RD)OPND,OPND2
RECORD (LISTF)NAME LCELL
PT=PTYPE; JJJ=J; TL=OLDI
TWSP=0; FPTR=0
LP=I; CLINK=K
TYPEP=TYPE; PRECP=PREC; NAMP=NAM
IF CLINK=0 THEN PSPECED=0 ELSE PSPECED=ASLIST(CLINK)_S3&255
!
BEGIN
INTEGERARRAY ARP(0:PSPECED)
SWITCH FPD(0:3)
! NOW CHECK THAT THE RIGHT NUMBER OF PARAMETERS HAVE BEEN PROVIDED
! ALSO NOTE THE POINTERS TO ACTUAL PARAMETERS ALLOWING FOC 'C' COMPATABILITY
!
P=P+2
NPARMS=0
WHILE A(P)=1 CYCLE
P=P+1
IF NPARMS<PSPECED START
IF PARAMS BWARDS=YES THEN ARP(PSPECED-NPARMS)=P C
ELSE ARP(NPARMS+1)=P
FINISH
NPARMS=NPARMS+1
SKIP EXP
REPEAT
OUTP=P
IF PSPECED#NPARMS THEN START
! WRONG NO OF PARAMETERS GIVEN
IF PSPECED=0 THEN ERRNO=17 ELSE START
IF NPARMS<PSPECED THEN ERRNO=18 ELSE ERRNO=19
FINISH
FAULT(ERRNO,IMOD(PSPECED-NPARMS),RTNAME)
SKIP APP; P=P-1
NAMEOPND=0; NAMEOPND_PTYPE=X'51';! ENSURE SENSIBLE RESULT TRIPLE
->OVER
FINISH
!
II=UNAMETRIP(PRECL,PT&255,0,RTNAME)
PARMNO=0
->FIRST PARM
!
BAD PARM: ! BAD PARAMETER FAULT IT
FAULT(22,PARMNO,RTNAME)
NEXT PARM:CLINK=LCELL_LINK
FIRSTPARM:->ENTRY SEQ IF CLINK=0; ! DEPART AT ONCE IF NO PARAMS
LCELL==ASLIST(CLINK)
PSIZE=LCELL_ACC
PARMNO=PARMNO+1
P=ARP(PARMNO)
PTYPE=LCELL_PTYPE
UNPACK
II=TYPE;III=PREC
JJ=(NAM<<1!ARR)&3
->BAD PARM UNLESS (JJ=0 AND ROUT=0) OR C
(A(P+3)=4 AND A(P+4)=1 AND A(P+FROMAR2(P+1)+1)=2)
OPND_PTYPE=PTYPE; OPND_FLAG=DNAME
OPND_D=RTNAME
OPND_XTRA=PARMNO<<24!CLINK
!
! RT TYPE PARAMS, PASS 4 WORDS AS SET UP BY QCODE INSTRN LVRD
!
IF ROUT=1 THEN START
II=PTYPE; P=P+5
CNAME(13); ! SET UP 4 WDS IN ACC
->BAD PARM IF II&255#PTYPE&255;! PREC&TYPE SIMILAR
P=P+1
II=BRECTRIP(PASS4,X'61',0,OPND,NAMEOPND)
FPTR=FPTR+RTPARAMSIZE
->NEXT PARM
FINISH
->FPD(JJ)
FPD(0): ! VALUE PARAMETERS
IF TYPE=3 START ; ! RECORDS BY VALUE
II=TSEXP(III); ! CHECK FOR ZERO AS RECORD VALUE
IF II=1 AND III=0 START
EXPOPND_PTYPE=X'51'; EXPOPND_FLAG=SCONST
EXPOPND_D=0
FINISH ELSE START
P=ARP(PARMNO); ! RESET NEEDED AFTER TSEXP
->BAD PARM UNLESS A(P+3)=4 AND A(P+4)=1 AND C
A(P+FROMAR2(P+1)+1)=2
P=P+5
CNAME(3)
P=P+1
JJ=1
EXPOPND=NAMEOPND
->BAD PARM UNLESS ACC=PSIZE
FINISH
FPTR=FPTR+PSIZE
IF TARGET=EMAS THEN FPTR=FPTR+8;! TIRESOME BACK COMPATIBILITY
! WITH EMAS IMP ON RECORD VALUES
FINISH ELSE IF TYPE=5 THEN START
IF STRVALINWA=YES START ; ! USING WORK AREA (2900)
CSTREXP(17)
PUSH(TWSP,VALUE,0,0); ! REMEBER WA
FPTR=FPTR+PTRSIZE(X'35')
FINISH ELSE START
CSTREXP(0)
FPTR=FPTR+ACC
FINISH
FINISH ELSE START
CSEXP(III<<4!II)
FPTR=FPTR+BYTES(III)
FINISH
II=BRECTRIP(PASS1,PTYPE&255,0,OPND,EXPOPND)
FPTR=(FPTR+MINPARAMSIZE-1)&(-MINPARAMSIZE)
->NEXT PARM
!
FPD(2): ! NAME PARAMETERS
P=P+5
IF II#0 START ; ! NOT A GENERAL NAME
CNAME(3)
->BAD PARM UNLESS II=TYPE AND III=PREC
JJ=PTRSIZE(III<<4!II)
II=BRECTRIP(PASS2,PTYPE&255,0,OPND,NAMEOPND)
FPTR=FPTR+JJ
FINISH ELSE START
FNAME=FROM AR2(P)
COPY TAG(FNAME)
OPND2_PTYPE=X'51'; OPND2_FLAG=SCONST
OPND2_D=ACC<<16!PTYPE
OPND2_XTRA=0
IF TYPE#0 START ; ! NOT GENERAL NAME PASSED AS NAME
CNAME(4)
FINISH ELSE START ; ! NAME AS GENERAL NAME
NAMEOPND_PTYPE=PTYPE; NAMEOPND_FLAG=DNAME
NAMEOPND_D=FNAME
NAMEOPND_XTRA=X'80000000'
FINISH
EXPOPND_D=BRECTRIP(CTGEN,X'61',0,NAMEOPND,OPND2)
EXPOPND_PTYPE=X'61'; EXPOPND_FLAG=REFTRIP
EXPOPND_XTRA=0
II=BRECTRIP(PASS5,X'61',0,OPND,EXPOPND)
FPTR=FPTR+PTRSIZE(0)
FINISH
P=P+1
->NEXT PARM
FPD(1):FPD(3): ! ARRAY NAME (&VALUE)
!
! FOR ARRAYNAME PARAMETERS THE NO OF DIMENSIONS OF THE ARRAY IS
! DEDUCED FROM THE FIRST CALL AND STORED IN STREAM3 OF THE PARAMETER
! LIST. ON ANY SUBSEQUENT CALL ONLY ARRAYS OF THE SAME DIMENSION CAN
! BE PASSED
!
P=P+5
CNAME(12)
P=P+1
->BAD PARM UNLESS 1<=ARR<=2 AND II=TYPE AND III=PREC
II=BRECTRIP(PASS3,PTYPE&255,0,OPND,NAMEOPND)
QQQ=ASLIST(TCELL)_UIOJ&15; ! DIMENSION OF ACTUAL(IF KNOWN)
JJ=LCELL_UIOJ&15; ! DIMENSION OF FORMAL
IF JJ=0 THEN JJ=QQQ AND LCELL_UIOJ=LCELL_UIOJ!JJ
IF QQQ=0 THEN QQQ=JJ AND ASLIST(TCELL)_UIOJ=ASLIST(TCELL)_UIOJ!JJ
->BAD PARM UNLESS JJ=QQQ
FPTR=FPTR+AHEADSIZE
->NEXT PARM
ENTRY SEQ: ! CODE FOR RT ENTRY
WHILE TWSP>0 CYCLE
POP(TWSP,QQQ,JJ,III); ! ONLY IF STR VALS & EMAS
RETURN WSP(QQQ,268)
REPEAT
IF STRRESINWA=YES AND NAMP<=1 AND (TYPEP=3 OR TYPEP=5) START
GET WSP(QQQ,268); ! AUTOMATIC RETURN
OPND2_PTYPE=PT
OPND2_FLAG=LOCALIR
OPND2_D=RBASE<<16!QQQ
OPND2_XTRA=268
II=BRECTRIP(PASS6,PT,0,OPND,OPND2)
FPTR=FPTR+PTRSIZE(X'35')
FINISH
II=UNAMETRIP(RCALL,PT&255,0,RTNAME)
TRIPLES(II)_OPND1_XTRA=FPTR; ! PASS PARAM SIZE TOTAL
CURRINF_NMDECS=CURRINF_NMDECS!2
ROUT=1; TYPE=TYPEP; NAM=NAMP
PREC=PRECP; PTYPE=PT
!
! RECOVER THE RESULT OF FNS & MAPS. OFTEN NOCODE WILL BE NEEDED
!
IF PT&255#0 START
IF NAM>=2 THEN II=RCRMR ELSE II=RCRFR
II=UNAMETRIP(II,PT&255,0,RTNAME)
IF STRRESINWA =YES THEN C
TRIPLES(II)_OPND1_XTRA=QQQ; ! WORK AREA OFFSET
NAMEOPND_PTYPE=PT&255; NAMEOPND_FLAG=REFTRIP
NAMEOPND_D=II
NAMEOPND_XTRA=0
FINISH
OVER: P=OUTP
END ; ! OF INNER BLOCK
END
INTEGERFN TSEXP(INTEGERNAME VALUE)
SWITCH SW(1:3)
INTEGER PP,REXP,KK,SIGN,CT
TYPE=1; PP=P
REXP=2-A(P+1+FROM AR2(P+1))
P=P+3
SIGN=A(P)
->TYPED UNLESS SIGN=4 OR A(P+1)=2
->SW(A(P+1))
SW(1): ! NAME
P=P+2; REDUCE TAG
->TYPED
SW(2): ! CONSTANT
CT=A(P+2); TYPE=CT&7
->TYPED UNLESS CT=X'41' AND SIGN#3
KK=FROMAR2(P+3)
->TYPED UNLESS REXP=0 AND 0<=KK<=255
VALUE=KK
P=P+6
IF SIGN#2 THEN RESULT =1
VALUE=-VALUE; RESULT =-1
SW(3): ! SUB EXPRN
TYPED: P=PP; RESULT =0
END
ROUTINE SKIP EXP
!***********************************************************************
!* SKIPS OVER THE EXPRESSION POINTED AT BY P. USED FOR ERROR *
!* RECOVERY AND TO EXTRACT INFORMATION ABOUT THE EXPRESSION. *
!***********************************************************************
INTEGER OPTYPE, PIN, J
PIN=P
P=P+3; ! TO P<+'>
CYCLE ; ! DOWN THE LIST OF OPERATORS
OPTYPE=A(P+1); ! ALT OF P<OPERAND>
P=P+2
IF OPTYPE=0 OR OPTYPE>3 THEN IMPABORT
IF OPTYPE=3 THEN SKIP EXP; ! SUB EXPRESSIONS
!
IF OPTYPE=2 THEN START ; ! OPERAND IS A CONSTANT
J=A(P)&7; ! CONSTANT TYPE
IF J=5 THEN P=P+A(P+1)+2 ELSE P=P+1+BYTES(A(P)>>4)
FINISH
!
IF OPTYPE=1 THEN START ; ! NAME
P=P-1
P=P+3 AND SKIP APP UNTIL A(P)=2 ;! TILL NO ENAME
P=P+1
FINISH
!
P=P+1
IF A(P-1)=2 THEN EXIT ; ! NO MORE REST OF EXP
REPEAT
END ; ! OF ROUTINE SKIP EXP
ROUTINE SKIP APP
!***********************************************************************
!* SKIPS ACTUAL PARAMETER PART *
!* P IS ON ALT OF P<APP> AT ENTRY *
!***********************************************************************
INTEGER PIN
PIN=P
P=P+1 AND SKIP EXP WHILE A(P)=1
P=P+1
END
ROUTINE NO APP
P=P+2
IF A(P)=1 THEN START ; ! <APP> PRESENT
FAULT(17,0,FROM AR2(P-2))
SKIP APP
FINISH ELSE P=P+1; ! P NOW POINTS TO ENAME
END
ROUTINE TEST APP(INTEGERNAME NUM)
!***********************************************************************
!* THIS ROUTINE COUNTS THE NUMBER OF ACTUAL PARAMETERS *
!* WHICH IT RETURNS IN NUM. *
!***********************************************************************
INTEGER PP, Q
Q=0; PP=P; P=P+2; ! P ON NAME AT ENTRY
WHILE A(P)=1 CYCLE ; ! NO (MORE) PARAMETERS
P=P+1; Q=Q+1
SKIP EXP
REPEAT
P=PP; NUM=Q
END
ROUTINE SET LINE
!***********************************************************************
!* UPDATE THE STATEMENT NO *
!***********************************************************************
INTEGER I
RETURN IF RLEVEL=0; ! AMONG CONDITIONAL GLOBAL DECS
I=UCONSTTRIP(SLINE,X'41',0,LINE<<16!CURRINF_DIAGINF+2)
IF PARM_PROF#0 THEN START
I=PROFAAD+4+4*LINE
FINISH
END
ROUTINE STORE TAG(INTEGER KK, LEVEL,RBASE,J,SNDISP,ACC,SLINK,KFORM)
INTEGER Q, I, TCELL
RECORD (TAGF)NAME LCELL
TCELL=TAGS(KK)
Q=LEVEL<<8!RBASE<<4!J
IMPABORT UNLESS (KFORM!ACC)>>16=0
LCELL==ASLIST(TCELL)
IF LCELL_UIOJ>>8&63=LEVEL THEN START
FAULT(7,0,KK)
LCELL_UIOJ<-LCELL_UIOJ&X'C000'!Q;! COPY USED BITS ACCROSS
FINISH ELSE START
I=ASL; IF I=0 THEN I=MORE SPACE
LCELL==ASLIST(I)
ASL=LCELL_LINK
LCELL_LINK=TCELL!CURRINF_NAMES<<18
LCELL_UIOJ=Q
TAGS(KK)=I
CURRINF_NAMES=KK
FINISH
LCELL_PTYPE<-PTYPE
LCELL_ACC=ACC
LCELL_SNDISP=SNDISP
LCELL_KFORM=KFORM
LCELL_SLINK=SLINK
END
ROUTINE COPY TAG(INTEGER TNAME)
!***********************************************************************
!* A TAG IS A LIST CELL POINTED AT BY TAGS(NAME) *
!* S1 HAS PTYPE<<16!USEBITS(2)!TEXT LEVEL(OLDI6)!RTLEVE(4)!DIMEN *
!* S2 HAS SECONDARY DISP(SIGNED)<<16! ACC OR ITEM SIZE IN BYTES *
!* S3 HAS PRIMARY DISP(K)<<16!KFORM WHICH IS POINTER TO FORMAT *
!* SIDE CHAIN FOR ITEMS OF TYPE RECORD *
!* LINK HAS PTR TO TAG OF NAME HIDDEN WHEN THIS ONE DECLARED *
!***********************************************************************
RECORD (TAGF)NAME LCELL
TCELL=TAGS(TNAME)
IF TCELL=0 THEN START ; ! NAME NOT SET
TYPE=7; PTYPE=X'57'; PREC=5
ROUT=0; NAM=0; ARR=0; LITL=0; ACC=4
I=-1; J=-1; K=-1; OLDI=-1
FINISH ELSE START
LCELL==ASLIST(TCELL)
LCELL_UIOJ<-LCELL_UIOJ!X'8000'
MIDCELL=LCELL_S2
PTYPE=LCELL_PTYPE; USEBITS=LCELL_UIOJ>>14&3
OLDI=LCELL_UIOJ>>8&63; I=LCELL_UIOJ>>4&15; J=LCELL_UIOJ&15
SNDISP=LCELL_SNDISP
ACC=LCELL_ACC
K=LCELL_SLINK; KFORM=LCELL_KFORM
LITL=PTYPE>>14&3; ! SIGNEXTENSION ON 16 BIT MACHINES
ROUT=PTYPE>>12&3
NAM=PTYPE>>10&3
ARR=PTYPE>>8&3
PREC=PTYPE>>4&15
TYPE=PTYPE&15
FINISH
END
ROUTINE REDUCE TAG
!***********************************************************************
!* AS COPY TAG FOR NAME AT A(P) EXCEPT:- *
!* 1) SPECIAL NAMES HAVE THEIR CORRECT PREC & TYPE SUBSTITUTED *
!* 2) RECORD ELEMENTS HAVE THE SUBNAME PARTICULARS RETURNED *
!***********************************************************************
INTEGER SUBS,QQ,PP
COPY TAG(FROMAR2(P))
IF PTYPE=SNPT THEN START
PTYPE=ACC; UNPACK
ROUT=1
FINISH ; ! TO AVOID CHECKING PARAMS
IF TYPE=3 THEN START
PP=P; QQ=COPY RECORD TAG(SUBS); P=PP
FINISH
END
! LAYOUT OF PTYPE
! ****** ** *****
! PTYPE REQUIRES 16 BITS TO DEFINE A VARIABLE AND CAN BE REGARDED AS
! AS TWO BYTEINTEGERS:=
! UPPER ONE(UPTYPE):= LITL<<6!ROUT<<4!NAM<<2!ARR
! LOWER ONE(PTYPE) :=PREC<<4!TYPE
! OFTEN (EG IN EXPOP) ONLY THE LOWER PART IS REQUIRED AS FUNCTIONS
! ETC ARE PREFETCHED AND STACKED.
! LITL:= 1=CONST,2=EXTERNAL,3=EXTRINSIC(OR DYNAMIC), 0=NONE OF THESE
! ROUT:= 1 FOR ROUTINE OR FN OR MAP, =0 NONE OF THESE
! NAM := 2 FOR MAPS AND 'REFREFS',=1 FOR NAMES ,=0 DIRECTLY ADDRESSED
! ARR :=1 FOR ARRAYS =0 SCALARS
! PREC IS DESCRIPTOR SIZE CODE FOR EACH PRECISION:-
! :=0 BITS,=3 BYTES, =5 WORDS, =6 D-WRDS, =7,QUAD WRDS
! TYPE:= THE VARIABLE TYPE
! :=0 (TYPE GENERAL),=1 INTEGER, =2 REAL, =3 RECORD
! :=4 (RECORDFORMAT),=5 STRING, =6 LABEL/SWITCH. =7 NOT SET
!
ROUTINE UNPACK
LITL=PTYPE>>14
ROUT=PTYPE>>12&3
NAM=PTYPE>>10&3
ARR=PTYPE>>8&3
PREC=PTYPE>>4&15
TYPE=PTYPE&15
END
ROUTINE PACK(INTEGERNAME PTYPE)
PTYPE=(((((LITL&3)<<2!ROUT&3)<<2!NAM&3)<<2!ARR&3)<<4! C
PREC&15)<<4!TYPE&15
END
END ; ! OF ROUTINE CSS
INTEGERFN NEWTRIP
!***********************************************************************
!* SETS UP A NEW TRIPLE AND LINKS IT IN
!***********************************************************************
RECORD (TRIPF)NAME CURRT
INTEGER I
CURRT==TRIPLES(NEXT TRIP)
I=NEXT TRIP
IF I>=WORKA_LAST TRIP THEN FAULT(102,WORKA_WKFILEK,0)
NEXT TRIP=NEXT TRIP+1
CURRT=0
CURRT_BLINK=TRIPLES(0)_BLINK
TRIPLES(0)_BLINK=I
TRIPLES(CURRT_BLINK)_FLINK=I
RESULT =I
END
INTEGERFN UCONSTTRIP(INTEGER OPERN,OPTYPE,FLAGS,CONST)
!***********************************************************************
!* SETS UP A UNARY TRIPLE WITH CONSTANT OPERAND *
!***********************************************************************
RECORD (TRIPF) NAME CURRT
INTEGER CELL
CELL = NEW TRIP
CURRT == TRIPLES(CELL)
CURRT_OPERN = OPERN
CURRT_OPTYPE <- OPTYPE
CURRT_FLAGS <- FLAGS
CURRT_OPND1_S1 = X'00510000'
CURRT_OPND1_D = CONST
RESULT = CELL
END
INTEGERFN ULCONSTTRIP(INTEGER OPERN,OPTYPE,FLAGS,CONST1,CONST2)
!***********************************************************************
!* SETS UP A UNARY TRIPLE WITH CONSTANT OPERAND *
!***********************************************************************
RECORD (TRIPF) NAME CURRT
INTEGER CELL
CELL = NEW TRIP
CURRT == TRIPLES(CELL)
CURRT_OPERN = OPERN
CURRT_OPTYPE <- OPTYPE
CURRT_FLAGS <- FLAGS
CURRT_OPND1_S1 = X'00610000'
CURRT_OPND1_D = CONST1
CURRT_OPND1_XTRA=CONST2
RESULT = CELL
END
INTEGERFN UNAMETRIP(INTEGER OPERN,OPTYPE,FLAGS,NAME)
!***********************************************************************
!* SETS UP A UNARY TRIPLE WITH ONE NAME OPERAND *
!***********************************************************************
RECORD (TAGF) NAME TAGINF
RECORD (TRIPF) NAME CURRT
INTEGER CELL
TAGINF == ASLIST(TAGS(NAME))
CELL = NEW TRIP
CURRT == TRIPLES(CELL)
CURRT_OPERN = OPERN
CURRT_OPTYPE <- OPTYPE
CURRT_FLAGS <- FLAGS
CURRT_OPND1_PTYPE = TAGINF_PTYPE
CURRT_OPND1_FLAG=DNAME
CURRT_OPND1_D = NAME
CURRT_OPND1_XTRA = 0
RESULT = CELL
END
INTEGERFN UTEMPTRIP(INTEGER OPERN,OPTYPE,FLAGS,TEMP)
!***********************************************************************
!* SETS UP A UNARY TRIPLE WITH LOCAL TEMPORARY OPND *
!***********************************************************************
INTEGER CELL
RECORD (TRIPF)NAME CURRT
CELL=NEWTRIP
CURRT==TRIPLES(CELL)
CURRT_OPERN=OPERN
CURRT_OPTYPE<-OPTYPE
CURRT_FLAGS<-FLAGS
CURRT_OPND1_PTYPE=OPTYPE; CURRT_OPND1_FLAG=LOCALIR
CURRT_OPND1_D=TEMP
RESULT =CELL
END
ROUTINE KEEPUSECOUNT(RECORD (RD)NAME OPND)
!***********************************************************************
!* KEEPS PUSE AND CNT UP TO DATE *
!***********************************************************************
RECORD (TRIPF)NAME REFT
REFT==TRIPLES(OPND_D)
IF REFT_CNT=0 THEN REFT_PUSE=TRIPLES(0)_BLINK
REFT_CNT=REFT_CNT+1
END
INTEGERFN URECTRIP(INTEGER OPERN,OPTYPE,FLAGS,RECORD (RD)NAME OPND1)
!***********************************************************************
!* SETS UP A BINARY TRIPLE WITH COMPLETE OPERANDS PROVIDED *
!***********************************************************************
INTEGER CELL
RECORD (TRIPF) NAME CURRT
CELL=NEWTRIP
CURRT==TRIPLES(CELL)
CURRT_OPERN=OPERN
CURRT_OPTYPE<-OPTYPE
CURRT_FLAGS<-FLAGS
CURRT_OPND1=OPND1
IF 1<<OPND1_FLAG&BTREFMASK#0 THEN KEEPUSECOUNT(OPND1)
RESULT =CELL
END
INTEGERFN BRECTRIP(INTEGER OPERN,OPTYPE,FLAGS,RECORD (RD)NAME OPND1,OPND2)
!***********************************************************************
!* SETS UP A BINARY TRIPLE WITH COMPLETE OPERANDS PROVIDED *
!***********************************************************************
INTEGER CELL
RECORD (TRIPF) NAME CURRT
CELL=NEWTRIP
CURRT==TRIPLES(CELL)
CURRT_OPERN=OPERN
CURRT_OPTYPE<-OPTYPE
CURRT_FLAGS<-FLAGS
CURRT_OPND1=OPND1
CURRT_OPND2=OPND2
IF 1<<OPND1_FLAG&BTREFMASK#0 THEN KEEP USE COUNT(OPND1)
IF 1<<OPND2_FLAG&BTREFMASK#0 THEN KEEP USE COUNT(OPND2)
RESULT =CELL
END
ROUTINE GET WSP(INTEGERNAME PLACE,INTEGER SIZE)
!***********************************************************************
!* FIND OR CREATE A TEMPORARY VARIABLE OF 'SIZE' WORDS *
!***********************************************************************
INTEGER J,K,L,F
F=SIZE>>31; ! TOP BIT SET FOR MANUAL RETURN
! OTHERWISE NOTE IN TWSP LIST
! FOR AUTOMATIC RETURN
SIZE=SIZE<<1>>1
IF SIZE>4 THEN SIZE=0
POP(CURRINF_AVL WSP(SIZE),J,K,L)
IF K<=0 THEN START ; ! MUST CREATE TEMPORARY
K=N
IF SIZE=0 THEN N=N+268 ELSE N=N+SIZE<<2
FINISH
PLACE=K
PUSH(TWSPHEAD,K,SIZE,0) UNLESS F#0
END
ROUTINE RETURN WSP(INTEGER PLACE,SIZE)
!***********************************************************************
!* RETURNS WORKSPACE TO ORDERED FREE LIST. ADDRESSABLE CELLS *
!* ARE PUT AT THE TOP. NON-ADDRESSABLE ON THE BACK *
!***********************************************************************
INTEGER CELL
IMPABORT UNLESS PLACE<=N AND PLACE&1=0
IF SIZE>4 THEN SIZE=0
CELL=CURRINF_AVL WSP(SIZE)
WHILE CELL>0 CYCLE
IMPABORT IF ASLIST(CELL)_S2=PLACE
CELL=ASLIST(CELL)_LINK
REPEAT
IF PLACE<511 THEN PUSH(CURRINF_AVL WSP(SIZE),0,PLACE,0) C
ELSE INSERT AT END(CURRINF_AVL WSP(SIZE),0,PLACE,0)
END
ROUTINE REUSE TEMPS
INTEGER JJ,KK,QQ
WHILE TWSPHEAD#0 CYCLE
POP(TWSPHEAD,JJ,KK,QQ)
RETURN WSP(JJ,KK)
REPEAT
END
INTEGERFN FROMAR2(INTEGER PTR)
RESULT =A(PTR)<<8!A(PTR+1)
END
INTEGERFN FROMAR4(INTEGER PTR)
INTEGER I
MOVE BYTES(4,ADDR(A(0)),PTR,ADDR(I),0)
RESULT =I
END
P2END: ! EXITS AFTER COMPILATION
END ; ! OF SUBBLOCK CONTAINING PASS2
END
ENDOFFILE