%MAINEP ICL9CEZPERQIMP
%TRUSTEDPROGRAM
%BEGIN
%CONSTINTEGER RELEASE=4
%CONSTINTEGER YES=1,NO=0
%CONSTINTEGER ON PERQ=NO
%CONSTSTRING(9) LADATE="9 Sep 82"; ! LAST ALTERED
%INTEGER I, J, K
%CONSTINTEGER NO OF SNS=63
%CONSTINTEGER LRLPT=X'62'
!
%CONSTBYTEINTEGERARRAY BYTES(0:7)=0(3),1,2,4,8,16;
%CONSTBYTEINTEGERARRAY WORDS(0:7)=0(3),1,1,2,4,8;
%CONSTINTEGER MAXLEVELS=31,CONCOP=13
!
%INCLUDE "ERCC07.PERQ_OPCODES"
%INCLUDE "ERCC07.TRIPCNSTS"
%INCLUDE "ERCC07.PERQ_FORMAT3S"
%CONSTINTEGER SNPT=X'1006'; ! SPECIALNAME PTYPE
%CONSTINTEGER UNASSPAT=X'80808080'
%CONSTINTEGER LABUSEDBIT=X'01000000'
%CONSTINTEGER LABSETBIT=X'02000000'
%CONSTSTRING(8)MDEP="S#NDIAG"
!
%INTEGER DUMMYFORMAT, P1SIZE, STARSIZE, ASL, ARSIZE, OLDLINE,
NEXTP, SNUM, RLEVEL, NMAX, PLABEL, LEVEL, PROFAAD, LAST INST,
LINE, BFFLAG, RBASE, N, EXITLAB, CONTLAB, Q, R, FNAME, STMTS,
FILE PTR, FILE END, FILE SIZE, BIMSTR, MAX ULAB, SFLABEL, NEXTTRIP
%INTEGERNAME CA,GLACA,SSTL,USTPTR
%STRING(31)MAINEP
!
%EXTERNALRECORD(CODEPF)CODEP
%EXTERNALRECORD(PARMF) PARM
%EXTERNAL%RECORD(WORKAF)WORKA
%SYSTEMINTEGERMAPSPEC COMREG(%INTEGER N)
%BEGIN
WORKA_FILE ADDR=COMREG(46); ! SOURCE FILE IF CLEAN
PARM=0
PARM_BITS1=COMREG(27)
PARM_BITS2=COMREG(28)
WORKA_WKFILEAD=COMREG(14)
WORKA_WKFILEK=INTEGER(WORKA_WKFILEAD+8)>>10
%IF WORKA_FILE ADDR<=0 %THEN %START
FILESIZE=64000
WORKA_FILE ADDR=0
%FINISH %ELSE %START
FILE PTR=WORKA_FILE ADDR+INTEGER(WORKA_FILE ADDR+4)
FILE END=WORKA_FILE ADDR+INTEGER(WORKA_FILE ADDR)
FILE SIZE=INTEGER(WORKA_FILE ADDR)
%FINISH
WORKA_NNAMES=511
%IF FILESIZE>32000 %THEN WORKA_NNAMES=1023
%IF FILESIZE>256*1024 %OR WORKA_WKFILEK>512 %THEN WORKA_NNAMES=2047
ASL=3*WORKA_NNAMES
%IF ASL>4095 %THEN ASL=4095
WORKA_ASL MAX=ASL
ARSIZE=WORKA_WKFILEK*768-300
%END
%BYTEINTEGERARRAYFORMAT AF(0:ARSIZE)
%BYTEINTEGERARRAYNAME A
%RECORD(LISTF)%ARRAY ASLIST(0:ASL)
%INTEGERARRAY WORD, TAGS(0:WORKA_NNAMES)
%INTEGERARRAY DVHEADS(0:12)
%RECORD(LEVELF)%ARRAY LEVELINF(0:MAXLEVELS)
%INTEGERFNSPEC FROMAR4(%INTEGER PTR)
%INTEGERFNSPEC FROMAR2(%INTEGER PTR)
%EXTERNALROUTINESPEC INITASL(%RECORD(LISTF)%ARRAYNAME A,%INTEGERNAME B)
%EXTERNALINTEGERFNSPEC MORE SPACE
!%EXTERNALINTEGERFNSPEC NEWCELL
%EXTERNALROUTINESPEC INSERTATEND(%INTEGERNAME S, %INTEGER A, B, C)
%EXTERNALROUTINESPEC INSERT AFTER(%INTEGERNAME S,%INTEGER A,B,C)
%EXTERNALROUTINESPEC FROM12(%INTEGER CELL, %INTEGERNAME S1, S2)
%EXTERNALROUTINESPEC FROM123(%INTEGER CELL, %INTEGERNAME S1, S2, S3)
%EXTERNALROUTINESPEC POP(%INTEGERNAME C, P, Q, R)
%EXTERNALROUTINESPEC PUSH(%INTEGERNAME C, %INTEGER S1, S2, S3)
%EXTERNALINTEGERFNSPEC FIND(%INTEGER LAB, LIST)
%EXTERNALROUTINESPEC MLINK(%INTEGERNAME CELL)
%EXTERNALROUTINESPEC REPLACE1(%INTEGER CELL, S1)
%EXTERNALROUTINESPEC REPLACE123(%INTEGER CELL,A1,A2,S3)
%EXTERNALINTEGERFNSPEC FROM2(%INTEGER CELL)
%EXTERNALINTEGERFNSPEC FROM1(%INTEGER CELL)
%EXTERNALINTEGERFNSPEC FROM3(%INTEGER CELL)
%EXTERNALROUTINESPEC BINSERT(%INTEGERNAME T,B,%INTEGER S1,S2,S3)
%EXTERNALROUTINESPEC CLEARLIST(%INTEGERNAME HEAD)
%EXTERNALROUTINESPEC CODEOUT
%EXTERNALROUTINESPEC PTLATE(%INTEGER WORD)
%EXTERNALROUTINESPEC PWORD(%INTEGER WORD)
%EXTERNALROUTINESPEC PB1(%INTEGER OPCODE)
%EXTERNALROUTINESPEC PB2(%INTEGER OPCODE,BYTE)
%EXTERNALROUTINESPEC PB3(%INTEGER OPCODE,BYTE1,BYTE2)
%EXTERNALROUTINESPEC PB4(%INTEGER OPCODE,B1,B3,B3)
%EXTERNALROUTINESPEC PBW(%INTEGER OPCODE,WORD)
%EXTERNALROUTINESPEC PWW(%INTEGER OPCODE,W1,W2)
%EXTERNALROUTINESPEC PB2W(%INTEGER OPCODE,BYTE1,WORD)
%EXTERNALROUTINESPEC PERM
%EXTERNALROUTINESPEC CAB
%EXTERNALROUTINESPEC CNOP(%INTEGER I, J)
%EXTERNALROUTINESPEC PGLA(%INTEGER BDRY, L, INF ADR)
%EXTERNALROUTINESPEC PLUG(%INTEGER AREA, AT, VALUE, BYTES)
%EXTERNALROUTINESPEC GXREF(%STRING(31) NAME,%INTEGER MODE,XTRA,AT)
%EXTERNALROUTINESPEC CIOCP(%INTEGER N)
%EXTERNALROUTINESPEC RELOCATE(%INTEGER BITS,GLARAD,AREA)
%EXTERNALROUTINESPEC ABORT
%EXTERNALROUTINESPEC PERQPROLOGUE
%EXTERNALROUTINESPEC REPEAT PROLOGUE
%EXTERNALROUTINESPEC PERQEPILOGUE(%INTEGER STMTS)
%DYNAMICROUTINESPEC QPUT(%INTEGER A,B,C,D)
%EXTERNALROUTINESPEC FAULT(%INTEGER A,B,C)
%EXTERNALROUTINESPEC WARN(%INTEGER N,V)
%EXTERNALROUTINESPEC PPJ(%INTEGER MASK,N)
%EXTERNALROUTINESPEC ERASE(%INTEGER WORDS)
%EXTERNALREALFNSPEC ICLREALTOPERQ(%REAL ICLREAL)
%EXTERNALLONGREALFNSPEC ICLLONGREALTOPERQ(%LONGREAL ICLREAL)
%EXTERNALROUTINESPEC PRINTTRIPS(%RECORD(TRIPF)%ARRAYNAME T)
! END OF "ERCC07.PERQ_XSPECS"
%EXTERNALROUTINESPEC STACKDUMP(%INTEGER WORDS)
%EXTERNALROUTINESPEC STACKUNDUMP(%INTEGER WORDS)
%EXTERNALROUTINESPEC CTOP(%INTEGERNAME OP,MASK,%INTEGER XTRA,
%RECORD(RD)%NAME OPND1,OPND2)
%EXTERNALROUTINESPEC GENERATE(%RECORD(TRIPF)%ARRAYNAME T,
%RECORD(LEVELF)%NAME L,%ROUTINE GETWSP(%INTEGERNAME PL,%INTEGER SIZE))
%EXTERNALROUTINESPEC PRINTLIST(%INTEGER HEAD)
! START OF COMPILATION
A==ARRAY(WORKA_WKFILE AD+256*WORKA_WKFILEK, AF)
%BEGIN
!***********************************************************************
!* THIS BLOCK INITIALISE THE COMPILER SCALARS AND ARRAYS *
!* WAS ORIGINALLY ROUTINE 'INITIALISE'. *
!* THE INITIALISATION OF THE CONSTANT LISTS WITH THE VALUES *
!* IN PERM MAY BE OMITTED IN BATCH OR CUT-DOWN VERSIONS. *
!***********************************************************************
%EXTERNALINTEGERFNSPEC PASSONE
WORKA_CCSIZE=256*(WORKA_WKFILEK-1)
%BYTEINTEGERARRAYFORMAT CCF(0:WORKA_CCSIZE)
%BYTEINTEGERARRAYNAME CC
CC==ARRAY(WORKA_WKFILEAD+32,CCF)
WORKA_CC==CC
WORKA_A==A
WORKA_WORD==WORD
WORKA_TAGS==TAGS
WORKA_LINE==LINE
WORKA_RELEASE=RELEASE
WORKA_LADATE=LADATE
WORKA_AASL0=ADDR(ASLIST(0))
PLABEL=24999
N=12;
MAX ULAB=WORKA_NNAMES+16384; ! LARGEST VALID USER LABEL
LAST INST=0
SFLABEL=20999
EXITLAB=0; CONTLAB=0
RLEVEL=0; NMAX=0; BFFLAG=0
RBASE=1
CA==CODEP_CAS(1); GLACA==CODEP_CAS(2)
SSTL==CODEP_CAS(4); USTPTR==CODEP_CAS(5)
STMTS=1; SNUM=0
BIMSTR=0
WORKA_RTCOUNT=1; ! ROUTINE 0 RESERVED FOR MAIN PROG
MAINEP="S#GO"; ! DEFAULT MAIN ENTRY
!
! OPEN OBJECT FILE HERE BEFORE MORE PAGES OF COMPILER CODE
! ARE PAGED IN AND SUB-SYSTEM PAGES MOVE OUT
!
QPUT(0,0,0,0)
INITASL(ASLIST,ASL)
%CYCLE I=0,1,12
DVHEADS(I)=0
%REPEAT
!
DUMMY FORMAT=0; ! DUMMY RECORD FORMAT
PUSH(DUMMY FORMAT,0,0,0); ! FOR BETTER ERROR RECOVERY
P1SIZE=PASSONE
R=P1SIZE
WORKA_ARTOP=P1SIZE
%END; ! OF BLOCK CONTAINING PASS 1
%BEGIN
!***********************************************************************
!* SECOND OR TRIPLES GENERATING PASS *
!***********************************************************************
%RECORD(LEVELF)%NAME CURRINF
%INTEGER TWSPHEAD
%RECORD(TRIPF)%ARRAY TRIPLES(0:999)
%INTEGERARRAYFORMAT CF(0:12*WORKA_NNAMES)
%INTEGERARRAYNAME CTABLE
!%ROUTINESPEC NOTE CREF(%INTEGER CA)
!%ROUTINESPEC STORE CONST(%INTEGERNAME D,%INTEGER L,AD)
!%INTEGERFNSPEC WORD CONST(%INTEGER VALUE)
%ROUTINESPEC REUSE TEMPS
%ROUTINESPEC GET WSP(%INTEGERNAME PLACE,%INTEGER SIZE)
%ROUTINESPEC RETURN WSP(%INTEGER PLACE,SIZE)
%ROUTINESPEC COMPILE A STMNT
%INTEGERFNSPEC NEW TRIP
%INTEGERFNSPEC UCONSTTRIP(%INTEGER OPERN,OPTYPE,FLAGS,CONST)
%INTEGERFNSPEC UNAMETRIP(%INTEGER OPERN,OPTYPE,FLAGS,NAME)
%INTEGERFNSPEC UTEMPTRIP(%INTEGER OPERN,OPTYPE,FLAGS,TEMP)
%INTEGERFNSPEC BRECTRIP(%INTEGER OPERN,OPTYPE,FLAGS,
%RECORD(RD)%NAME OPND1,OPND2)
%INTEGERFNSPEC URECTRIP(%INTEGER OPERN,OPTYPE,FLAG,%RECORD(RD)%NAME OPND1)
%ROUTINESPEC CSS(%INTEGER P)
%CYCLE I=0, 1, MAXLEVELS
LEVELINF(I)=0
LEVELINF(I)_NAMES=-1
%REPEAT
CTABLE==ARRAY(ADDR(ASLIST(1)),CF)
WORKA_CTABLE==CTABLE
WORKA_LEVELINF==LEVELINF
CTABLE(0)=M'CTAB'
LINE=0
TWSPHEAD=0
PERQPROLOGUE
NEXTTRIP=1
NEXTP=1; LEVEL=1; STMTS=0
CURRINF==LEVELINF(LEVEL)
RLEVEL=0; RBASE=0
%WHILE A(NEXTP+3)!A(NEXTP+4)#0 %CYCLE
COMPILE A STMNT
%REPEAT
LINE=99999
PERQEPILOGUE(STMTS)
%STOP
%ROUTINE FORCE TRIPS
!***********************************************************************
!* FORCE OUT THE TRIPLES TO CODE. NEEDED IN CEND ETC *
!***********************************************************************
%IF PARM_DCOMP#0 %THEN CODEOUT
%RETURN %IF NEXT TRIP=1
GENERATE(TRIPLES,CURRINF,GET WSP)
%IF PARM_DCOMP#0 %THEN CODEOUT
TRIPLES(0)=0
NEXTTRIP=1
TRIPLES(0)_FLINK=NEXT TRIP
%END
%ROUTINE COMPILE A STMNT
%INTEGER I
%IF TWSPHEAD#0 %THEN REUSE TEMPS
FORCE TRIPS %IF NEXT TRIP>1
I=NEXTP
STARSIZE=A(NEXTP)<<16+A(NEXTP+1)<<8+A(NEXTP+2)
NEXTP=NEXTP+STARSIZE
LINE=A(I+3)<<8+A(I+4)
STMTS=STMTS+1
CSS(I+5)
! %CYCLE I=0,1,4
! %REPEAT
! CHECK ASL %IF LINE&7=0
%END
%ROUTINE CSS(%INTEGER P)
%RECORDFORMAT RD((%INTEGER S1 %OR %BYTEINTEGER UPTYPE,PTYPE,XB,FLAG),%C
%INTEGER D,XTRA)
%ROUTINESPEC ENTER JUMP(%INTEGER MASK,STAD,FLAG)
%INTEGERFNSPEC ENTER LAB(%INTEGER M,FLAG)
%ROUTINESPEC REMOVE LAB(%INTEGER LAB)
%ROUTINESPEC CEND(%INTEGER KKK)
%INTEGERFNSPEC CCOND(%INTEGER CTO,A,B,JFLAGS)
%INTEGERFNSPEC REVERSE(%INTEGER MASK)
%ROUTINESPEC SET LINE
%ROUTINESPEC CUI(%INTEGER CODE)
%ROUTINESPEC ASSIGN(%INTEGER A,B)
%ROUTINESPEC CSTART(%INTEGER CCRES,MODE)
%INTEGERFNSPEC CHECKBLOCK(%INTEGER P,PIN)
%ROUTINESPEC CCYCBODY(%INTEGER UA,ELAB,CLAB)
%ROUTINESPEC CLOOP(%INTEGER ALT,MARKC,MARKUI)
%ROUTINESPEC CIFTHEN(%INTEGER MARKIU,MARKC,MARKUI,MARKE,MARKR,SKIP)
%ROUTINESPEC CREATE AH(%INTEGER MODE)
%ROUTINESPEC TORP(%INTEGERNAME HEAD,BOT,NOPS)
%INTEGERFNSPEC INTEXP(%INTEGERNAME VALUE,%INTEGER PRECTYPE)
%INTEGERFNSPEC CONSTEXP(%INTEGER PRECTYPE)
%ROUTINESPEC CSEXP(%INTEGER MODE)
%ROUTINESPEC CSTREXP(%INTEGER B)
%ROUTINESPEC CRES(%INTEGER LAB)
%ROUTINESPEC EXPOP(%INTEGERNAME A,B,%INTEGER C,D)
%ROUTINESPEC TEST APP(%INTEGERNAME NUM)
%ROUTINESPEC SKIP EXP
%ROUTINESPEC SKIP APP
%ROUTINESPEC NO APP
%INTEGERFNSPEC DOPE VECTOR(%INTEGER A,B,MODE,ID,%INTEGERNAME C,D)
%ROUTINESPEC DECLARE ARRAYS(%INTEGER A,B)
%ROUTINESPEC DECLARE SCALARS(%INTEGER A,B)
%ROUTINESPEC CRSPEC(%INTEGER M)
%INTEGERFNSPEC SET SWITCHLAB(%INTEGER HEAD,LAB,FNAME,BIT)
%ROUTINESPEC CFPLIST(%INTEGERNAME A,B)
%ROUTINESPEC CFPDEL
%ROUTINESPEC CLT
%ROUTINESPEC CQN(%INTEGER P)
%INTEGERFNSPEC TSEXP(%INTEGERNAME VALUE)
%ROUTINESPEC CRCALL(%INTEGER RTNAME)
%ROUTINESPEC NAMEOP(%INTEGER Z,SIZE,NAMEP)
%ROUTINESPEC CNAME(%INTEGER Z)
%ROUTINESPEC AATORP(%INTEGERNAME A,B,C,%INTEGER D,E,F)
%ROUTINESPEC CANAME(%INTEGER Z,ARRP,BS,DP)
%ROUTINESPEC CSNAME(%INTEGER Z)
%ROUTINESPEC COPY TAG(%INTEGER KK)
%ROUTINESPEC REDUCE TAG
%ROUTINESPEC STORE TAG(%INTEGER KK,SLINK)
%ROUTINESPEC UNPACK
%ROUTINESPEC PACK(%INTEGERNAME PTYPE)
%ROUTINESPEC DIAG POINTER(%INTEGER LEVEL)
%ROUTINESPEC RDISPLAY(%INTEGER KK)
%ROUTINESPEC RHEAD(%INTEGER RTNAME,AXNAME)
%ROUTINESPEC EVEN ALIGN
%INTEGERFNSPEC CFORMATREF
%ROUTINESPEC CRFORMAT(%INTEGERNAME OPHEAD,OPBOT,NLIST,MRL,%INTEGER INIT)
%INTEGERFNSPEC DISPLACEMENT(%INTEGER LINK)
%INTEGERFNSPEC COPY RECORD TAG(%INTEGERNAME SUBS)
%ROUTINESPEC BULKM(%INTEGER M,L,D2)
%ROUTINESPEC BYTECUT(%INTEGER ODDEVEN)
%ROUTINESPEC DFETCHAD(%INTEGER SEGNO,LEVEL,DISP)
%ROUTINESPEC DFETCH(%INTEGER SIZE,LEVEL,DISP)
%ROUTINESPEC DSTORE(%INTEGER SIZE,LEVEL,DISP)
%SWITCH SW(1:24)
%CONSTBYTEINTEGERARRAY FCOMP(0:14)=0,
8,10,2,7,12,4,7,
8,12,4,7,10,2,7;
%INTEGER SNDISP,ACC,K,KFORM,STNAME,MIDCELL
%INTEGER TCELL,JJ,JJJ,KK,QQ,MARKER,REPORTUI,XDISP,MASK, %C
BASE,AREA,ACCESS,DISP,EXTRN, CURR INST,VALUE,STRINGL, %C
PTYPE,I,J,OLDI,USEBITS,STRFNRES,BML,DML, %C
MARKIU,MARKUI,MARKC,MARKE,MARKR,INAFORMAT
%INTEGER LITL,ROUT,NAM,ARR,PREC,TYPE
%OWNINTEGER FPTR
%RECORD(RD) EXPOPND; ! RESULT RECORD FOR EXPOP
CURR INST=0; INAFORMAT=0
->SW(A(P))
SW(13): ! INCLUDE SOMETHING
SW(24): ! REDUNDANT SEP
SW(2): ! <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)
CODEOUT
PARM_DCOMP=J>>28; ->CSSEXIT
!
SW(3): ! (%IU)(COND)%THEN(UI)(ELSE')
MARKIU=P+1; MARKC=MARKIU+3
MARKR=P+2+A(P+2)<<8+A(P+3); ! ! FROMAR2(P+2)
MARKE=0
%IF A(MARKR)=3 %THEN %START
MARKE=MARKR+1+FROMAR2(MARKR+1)
MARKUI=MARKR+3
%FINISH
CIFTHEN(MARKIU,MARKC,MARKUI,MARKE,MARKR,NO)
->CSSEXIT
SW(4):
! '%FINISH(ELSE')(S)
->CSSEXIT
SWITCH: %BEGIN; ! SWITCH LABEL
%INTEGER NAPS,FNAME
FNAME=FROM AR2(P+3)
%UNLESS A(P)=1 %AND A(P+5)=1 %THEN FAULT(5,0,FNAME) %AND ->BEND
! 1ST OF UI + APP
P=P+3; TEST APP(NAPS)
P=P+6
%UNLESS INTEXP(JJ,X'41')=0 %THEN FAULT(41,0,0) %AND ->BEND
! UNLESS EXPRESSION EVALUATES AND
%UNLESS NAPS=1 %THEN FAULT(21,NAPS-1,FNAME) %AND ->BEND
! NO REST OF APP
%UNLESS A(P+1)=2=A(P+2) %THEN FAULT(5,0,FNAME) %AND ->BEND
! NO ENAME OR REST OF ASSIGMENT
COPY TAG(FNAME)
%IF OLDI#LEVEL %OR TYPE#6 %THEN FAULT(4,0,FNAME) %AND ->BEND
%IF SET SWITCHLAB(K,JJ,FNAME,1)#0 %THEN FAULT(6,JJ,FNAME)
BEND: %END; ->CSSEXIT
SW(23):
! SWITCH(*):
%BEGIN
%INTEGER FNAME,LB,UB,JJ,RES
FNAME=FROM AR2(P+1)
COPY TAG (FNAME)
%IF OLDI=LEVEL %AND TYPE=6 %START
FROM123(K,JJ,LB,UB)
%CYCLE JJ=LB,1,UB
RES=SET SWITCHLAB(K,JJ,FNAME,0)
%REPEAT
%FINISH %ELSE FAULT(4,0,FNAME)
%END; ->CSSEXIT
!
SW(7): ! (%WU)(SC)(COND)(RESTOFWU)
FAULT(57,0,0) %UNLESS LEVEL>=2
MARKIU=P+1; ! TO WHILE/UNTIL
MARKC=MARKIU+3; ! TO (SC)(COND)
CLOOP(A(MARKIU)+3,MARKC,MARKIU+1+FROMAR2(MARKIU+1))
->CSSEXIT
!
SW(8): ! SIMPLE DECLN
FAULT(57,0,0) %UNLESS LEVEL>=2
FAULT(40,0,0) %IF CURRINF_NMDECS&1#0
P=P+1
MARKER=P+FROMAR2(P); ! TO ALT OF DECLN
P=P+2; ROUT=0; LITL=0
%IF A(MARKER)#1 %THEN %START; ! ARRAY DECLARATIONS
CLT
%IF TYPE=5 %AND (ACC<=0 %OR ACC>256) %THEN %C
FAULT(70,ACC-1,0) %AND ACC=255
NAM=0
SET LINE
QQ=2-A(P+1); P=P+2; ! QQ=1 FOR ARRAYFORMATS
DECLARE ARRAYS(QQ,KFORM)
%FINISH %ELSE %START
CLT
CQN(P+1); P=P+2
DECLARE SCALARS(1,KFORM)
%FINISH
->CSSEXIT
!
SW(9): ! %END
%BEGIN
%SWITCH S(1:5)
-> S(A(P+1))
S(1): ! ENDOFPROGRAM
S(2): ! ENDOFFILE
%IF PARM_CPRMODE=0 %THEN PARM_CPRMODE=2
FAULT(15,LEVEL+PARM_CPRMODE-3,0) %UNLESS LEVEL+PARM_CPRMODE=3
CEND(PARM_CPRMODE)
->BEND
S(3): ! ENDOFLIST
->BEND
S(4): ! END
%IF PARM_CPRMODE=1 %AND LEVEL=2 %THEN FAULT(14,0,0) %ELSE %C
CEND(CURRINF_FLAG)
BEND: %END
->CSSEXIT
!
SW(11):
%BEGIN
%INTEGER MARKER1,RTNAME,KKK,PTR,PTYPEP,CNT,PP,PCHAIN,AXNAME
%RECORD(LISTF)%NAME LCELL
P=P+1; MARKER1=FROM AR2(P)+P; ! (SEX)(RT)(SPEC')(NAME)(FPP)
AGN: Q=P; RTNAME=FROM AR2(MARKER1+1); ! RTNAME ON NAME
EXTRN=A(P+2); ! 1=SYSTEM,2=EXTERNAL
! 3=DYNAMIC, 4=INTERNAL
LITL=EXTRN&3
%IF A(MARKER1)=1 %THEN %START; ! P<%SPEC'>='%SPEC'
P=P+3; CRSPEC(1-EXTRN>>2); ! 0 FOR ROUTINESPEC
! 1 FOR EXTERNAL (ETC) SPEC
->BEND
%FINISH
COPY TAG(RTNAME)
AXNAME=WORKA_DICTBASE+WORD(RTNAME)
%IF EXTRN=3 %THEN EXTRN=2
%IF A(MARKER1+3)=1 %THEN AXNAME=ADDR(A(MARKER1+4))
%IF EXTRN=4 %THEN AXNAME=0
%IF OLDI=LEVEL %THEN %START; ! NAME ALREADY KNOWN AT THIS LEVEL
%IF PARM_CPRMODE=0 %THEN PARM_CPRMODE=2; ! FLAG AS FILE OF ROUTINES
FAULT(56,0,RTNAME) %UNLESS EXTRN=4 %OR %C
(PARM_CPRMODE=2 %AND LEVEL=1)
%IF A(P+3)=1 %THEN KKK=LITL<<14!X'1000' %ELSE %START
ROUT=1; P=P+4; ! FIGURE OUT PTYPE FOR FNS&MAPS
CLT; ARR=0; NAM=0
%IF A(P)=2 %THEN NAM=2; ! SET NAME ARRAY BIT FOR MAPS
PACK(KKK); ! AND STORE PTYPE IN KKK
%FINISH
%FINISH
!
! UNLESS A MATCH WAS OBTAINED BETWEEN HEADING AND SPEC SOMETHING
! HAS GONE WRONG. COMPILE HEADING AGAIN AS SPEC. THIS WILL
! PREVENT ANY INCONSISTENCIED AND CAUSE A "NAME SET TWICE"
! FOR ANY ERROR
!
%UNLESS OLDI=LEVEL %AND (J=15 %OR J=7*EXTRN) %AND %C
PTYPE=KKK %START
P=Q+3; CRSPEC(0); P=Q; ->AGN
%FINISH
PTYPE=PTYPE!(EXTRN&3)<<14; ! DEAL WITH %ROUTINESPEC FOLLOWED
! BY %EXTERNALROUTINE
!
! RESET THE TAGS TO BODY GIVEN AND ALLOWING FOR SPEC/EXTERNALROUTINE
! AND EXTERNALSPEC/EXTERNAL ROUTINE COMBINATIONS. RESTORE THE USE
! BITS WHICH WILL SHOW USED AS A RESULT OF THE COPYTAG IN THIS SEQUENCE
!
LCELL==ASLIST(TAGS(RTNAME))
LCELL_S1=LCELL_S1&X'3FF0'!PTYPE<<16!USEBITS<<14
! NEWPTYPE & SET J=0
%IF J=14 %THEN LCELL_S2=WORKA_RTCOUNT %AND %C
WORKA_RTCOUNT=WORKA_RTCOUNT+1; ! NO RT NO ALLOCATED TO EXTERNAL SPECS
PTYPEP=PTYPE
PCHAIN=K; ! CHAIN OF PARAMETER DESCRIPTUONS
RHEAD(RTNAME,AXNAME); ! FIRST PART OF ENTRY SEQUENCE
!
! NOW DECLARE THE FORMAL PARAMETERS. FOLLOW BY CLAIMING DISPLAY
! AND SETTING DIAGNOSTIC PTR IN ROUTINE RDISPLAY
!
P=MARKER1+4
%IF A(P-1)=1 %THEN P=P+A(P)+1; ! SKIP OVER ALIASNAME
N=0; CNT=1
PTYPE=PTYPEP; UNPACK
%IF TYPE#0 %THEN N=(BYTES(PREC)+1)&(-2)
%IF NAM#0 %OR TYPE=5 %THEN N=4; ! MAPS
%WHILE A(P)=1 %CYCLE; ! WHILE SOME (MORE) FP PART
PP=P+1+FROMAR2(P+1)
P=P+3
CFPDEL
PTR=P
%UNTIL A(PTR-1)=2 %CYCLE; ! CYCLE DOWN NAMELIST
%IF PCHAIN#0 %THEN %START
FROM12(PCHAIN,J,JJJ); ! EXTRACT PTYPE XTRA INFO
%UNLESS J>>16=PTYPE %AND(PTYPE#5 %OR JJJ>>16=ACC)%C
%THEN FAULT(9,CNT,RTNAME)
%FINISH %ELSE FAULT(8,0,RTNAME);! MORE FPS THAN IN SPEC
PTR=PTR+3
CNT=CNT+1
MLINK(PCHAIN)
%REPEAT
DECLARE SCALARS(0,KFORM)
P=PP
%REPEAT; ! UNTIL NO MORE FP-PART
N=(N+1)&(-2); ! TO WORD BOUNDARY AFTER ALL SYSTEM
! STANDARD PARAMETERS HAVE BEEN DECLARED
FAULT(10,0,RTNAME) %UNLESS PCHAIN=0
PTYPE=PTYPEP
! %IF PTYPE&X'F0F'=5 %THEN N=N+8; ! STR FNS RESULT PARAM IS STACKED
! AS XTRA PARM JUST BEFORE DISPLAY
RDISPLAY(RTNAME)
BEND: %END; ->CSSEXIT
!
SW(14): ! %BEGIN
%BEGIN
PTYPE=0
%IF LEVEL=1 %AND RLEVEL=0 %START
%IF PARM_CPRMODE=0 %THEN %START
RLEVEL=1; RBASE=1
CURRINF_ENTRYAD=CA; ! MAIN ENTRY
PARM_CPRMODE=1
RHEAD(-1,ADDR(MAINEP))
N=0
%FINISH %ELSE FAULT(58,0,0)
%FINISH %ELSE %START
SET LINE; ! SO 'ENTERED FROM LINE' IS OK
RHEAD(-1,0)
%FINISH
RDISPLAY(-1)
%END
->CSSEXIT
!
SW(15):
! '%ON'(EVENT')(N)(NLIST)'%START'
FAULT(57,0,0) %UNLESS LEVEL>=2
FAULT(40,0,0) %IF CURRINF_NMDECS&1#0
CURRINF_NMDECS=CURRINF_NMDECS!X'11';! NO MORE DECS AND IN ONCOND
PB1(NOOP); ! GET PROGRAM MASK
! DUMPRX(ST,0,0,RBASE,N+8); ! AND SAVE IT
PLABEL=PLABEL-1
JJJ=PLABEL
ENTER JUMP(15,JJJ,B'10'); ! JUMP ROUND ON BODY
!
P=P+1; JJ=0; ! SET UP A BITMASK IN JJ
%UNTIL A(P)=2 %CYCLE; ! UNTIL NO MORE NLIST
KK=-1; P=P+4
FAULT(26,KK,0) %UNLESS INTEXP(KK,X'41')=0 %AND 1<=KK<=14
JJ=JJ!1<<(KK-1)
%REPEAT
P=P+1
KK=CA; PGLA(4,4,ADDR(CA))
! RELOCATE(GLACA-4,KK,1); ! ENTRY ADDRESS IN PLT
CURRINF_ONWORD=JJ<<18!(GLACA-4)
! DUMPM(STM,0,1,RBASE,N); ! AND SAVE THEM
! DUMPRX(LGR,1,0,RBASE,N+8); ! RETRIEVE PROGRAM MASK
PB1(NOOP); ! AND RESET IT
CURRINF_ONINF=N; N=N+12
OLDLINE=0
CSTART(0,3)
CURRINF_NMDECS=CURRINF_NMDECS!!X'10';! NOT IN ONCOND
JJ=ENTER LAB(JJJ,B'111'); ! REPLACE ENVIRONMENT
->CSSEXIT
SW(16):
%BEGIN; ! %SWITCH (SWITCH LIST)
%INTEGER Q,RANGE,KKK,LB,UB,PP,D0,OPHEAD,V,R
FAULT(57,0,0) %UNLESS LEVEL>=2
Q=P
PLABEL=PLABEL-1
ENTER JUMP(15,PLABEL,0)
%UNTIL A(Q)=2 %CYCLE; ! UNTIL NO'REST OF SW LIST'
P=P+3
P=P+3 %WHILE A(P)=1
P=P+4; ! TO P(+')
KKK=INTEXP(LB,X'41'); ! EXTRACT LOWER BOUND
P=P+3
KKK=KKK!INTEXP(UB,X'41'); ! EXTRACT UPPER BOUND
RANGE=(UB-LB+1)
%IF RANGE<=0 %OR KKK#0 %START
FAULT(38,1-RANGE,FROMAR2(Q+1))
LB=0; UB=10; RANGE=11
%FINISH
PTYPE=X'56'+1<<8; ! WORD LABEL ARRAY
PP=P; P=Q+1
%UNTIL A(P-1)=2 %CYCLE; ! DOWN NAMELIST
K=FROM AR2(P)
P=P+3
OPHEAD=0; R=LB
!
! SET UP A BIT LIST (96 BITS PER CELL) TO CHECK FOR SWITCH LABELS
! SET TWICE
!
%UNTIL R>UB %CYCLE
PUSH(OPHEAD,0,0,0)
R=R+96
%REPEAT
%IF CA&1=0 %THEN PB1(NOOP)
SNDISP=CA; ! OF CASE JUMP
PB1(XJP)
PWORD(LB)
PWORD(UB)
V=WORKA_PLABS(6)-CA
PWORD(V); ! TO PLABS(6) IF BOUND FAULT
D0=CA; ! START OF TABLE
PUSH(OPHEAD,D0,LB,UB)
KFORM=0; ACC=4
J=1; STORE TAG(K,OPHEAD)
!
!THE TABLE WILL CONSIST OF RELATIVE DISPLACEMENTS FROM EACH ENTRY
! TO THE LABEL POSN. SET ALL TO GO TO PLAB(6) INITIALLY
!
V=V-2
%CYCLE KKK=LB,1,UB
PWORD(V)
V=V-2
%REPEAT
%REPEAT; ! FOR ANY MORE NAMES IN NAMELIST
Q=PP; P=Q
%REPEAT; ! UNTIL A(Q)=2
KKK=ENTER LAB(PLABEL,0); ! COMPLETE JUMP AROUND TABLE
%END;->CSSEXIT
!
SW(17): ->CSSEXIT
!
SW(12): ! '%OWN' (TYPE)(OWNDEC)
%BEGIN
!***********************************************************************
!* INITIALISED DECLARATION GO INTO THE GLA OR GLA SYMBOL TABLES *
!* EXCEPT FOR CONST ARRAYS WHICH GO INTO THE CODE SYMBOL TABLES *
!* STRINGS AND ARRAYS HAVE A HEADER IN THE GLA. QPUT ARRANGES *
!* FOR THE LOADER TO RELOCATE THE HEADERS. *
!* EXTERNALS ARE IDENTICAL WITH OWN BUT ALSO HAVE A DATA EP DEFN *
!* IN THE LOAD DATA SO THEY CAN BE FOUND AT LOAD TIME *
!* EXTRINSICS HAVE A DATA REFERENCE AND A DUMMY HEADER IN THE GLA*
!* THE LOADER USES THE FORMER TO RELOCATE THE LATTER. *
!***********************************************************************
%ROUTINESPEC CLEAR(%INTEGER L)
%ROUTINESPEC STAG(%INTEGER J, DATALEN)
%ROUTINESPEC XTRACT CONST(%INTEGER CONTYPE, CONPREC)
%ROUTINESPEC INIT SPACE(%INTEGER A, B)
%HALFINTEGER AH1, AH2, AH3, AH4
%INTEGER LENGTH, PP, SIGN, FICONST, ICONST, TAGDISP, EPTYPE, EPDISP,
AD, STALLOC, SPOINT, CONSTSFOUND, CPREC, EXTRN, NNAMES, %C
MARK, QPUTP, LB, CTYPE, CONSTP, FORMAT,DPTYPE, %C
DIMEN, SACC, TYPEP
%LONGREAL RCONST, FRCONST
%OWNLONGREAL ZERO=0
%STRING (255) SCONST, NAMTXT
%RECORD(LISTF)%NAME LCELL
%INTEGERNAME STPTR
QPUTP=45; STPTR==USTPTR; ! NORMAL CASE GLA SYMBOLTABLES
! FAULT(40,0,0) %IF NMDECS&1#0
EXTRN=A(P+1)
P=P+2
%IF EXTRN>=4 %THEN EXTRN=0; ! CONST & CONSTANT->0
SNDISP=0
CONSTS FOUND=0
%IF EXTRN=0 %THEN QPUTP=44 %AND STPTR==SSTL
CLT
!
! CHECK FOR %SPEC AND CHANGE EXTERNAL SPEC TO EXTRINSIC
!
%IF A(P+2)=1 %START
%IF EXTRN=2 %THEN EXTRN=3 %ELSE FAULT(46,0,0)
%FINISH
%IF 2<=EXTRN<=3 %AND ((A(P)=1 %AND A(P+1)#3) %OR %C
(A(P)=2 %AND A(P+1)#2)) %THEN FAULT(46,0,0)
LITL=EXTRN
%IF LITL<=1 %THEN LITL=LITL!!1
%IF A(P)=1 %THEN CQN(P+1) %ELSE ARR=1 %AND NAM=0
%IF TYPE=5 %AND NAM=0 %AND (ACC<=0 %OR ACC>256) %THEN %C
FAULT(70,ACC-1,0) %AND ACC=2
STALLOC=ACC; ! ALLOCATION OF STORE FOR ITEM OR POINTER
%IF TYPE=5 %THEN STALLOC=(STALLOC+1)&X'FFE'
ROUT=0; PACK(PTYPE); DPTYPE=PTYPE;! FOR DECLARATION
%IF NAM#0 %START; ! OWN POINTERS
%IF ARR#0 %THEN STALLOC=8 %ELSE STALLOC=4
%FINISH %ELSE %START; ! OWN VARS & ARRAYS
->NON SCALAR %IF ARR#0
%FINISH
P=P+2
%UNTIL A(MARK)=2 %CYCLE; ! UNTIL <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(WORKA_DICTBASE+WORD(K))
%IF A(P)=1 %THEN NAMTXT<-STRING(ADDR(A(P+1))) %AND %C
P=P+A(P+1)+1
P=P+1; ! P ON CONST'
!
! OBTAIN THE INITIAL CONSTANT,ITS TYPE(CTYPE) AND SIGN(SIGN)
!
ICONST=0; FICONST=0
RCONST=0; FRCONST=0; SCONST=""
PTYPE=DPTYPE; UNPACK; ! MAY HAVE BEEN CONSTANT EVALUATIONS
! WHICH HAVE CHANGED PTYPE
SIGN=3; CTYPE=TYPE; CONSTSFOUND=0; CPREC=PREC
%IF TYPE=3 %THEN CTYPE=1; ! RECS INITTED TO REPEATED BYTE
%IF NAM#0 %THEN CTYPE=1 %AND CPREC=5
P=P+1
%IF A(P-1)=1 %THEN %START; ! CONSTANT GIVEN
XTRACT CONST(CTYPE,CPREC)
%FINISH %ELSE %START
WARN(7,K) %IF EXTRN=0; ! %CONST NOT INITIALISED
%FINISH
J=0
%IF NAM#0 %THEN %START; ! OWNNAMES AND ARRAYNAMES
AH1<-FICONST>>16
AH2<-FICONST
%IF ARR=0 %THEN %START
%IF TYPE=5 %THEN STALLOC=6 %AND AH3=ACC-1
PGLA(2,STALLOC,ADDR(AH1))
%FINISH %ELSE %START; ! ARRAYNAMES
AH3=DOPE VECTOR(TYPE,ACC,-1,K,QQ,LB)>>1
AH4=0
%IF PARM_COMPILER#0 %AND LB#0 %THEN FAULT(99,0,0)
%IF EXTRN#0 %THEN SNDISP=0 %ELSE %C
SNDISP=(SNDISP&X'3FFFF')>>2
PGLA(4,STALLOC,ADDR(AH1))
RELOCATE(32,GLACA-4,4)
%FINISH
TAGDISP=GLACA-STALLOC; EPDISP=TAGDISP
STAG(TAGDISP,STALLOC)
P=MARK
%CONTINUE
%FINISH
%IF EXTRN=3 %THEN %START; ! EXTRINISIC
PTYPE=PTYPE!X'400'; ! FORCE NAM=1 (IE VIA POINTER)
AH3=0; AH2=0
PGLA(4,4,ADDR(AH2))
TAGDISP=GLACA-4
GXREF(NAMTXT,2,2<<24,TAGDISP);! RELOCATE BY EXTERNAL
STAG(TAGDISP,STALLOC)
P=MARK
%CONTINUE
%FINISH
%IF TYPE=5 %THEN %START; ! STRING
PTYPE=PTYPE!X'400'; ! FORCE NAM = 1
AH1=STPTR>>1
AH2=0; ! WILL HAVE SEGMENT NO
AH3=ACC-1
AD=ADDR(SCONST)
%IF PARM_INHCODE=0 %START
QPUT(QPUTP,STALLOC,STPTR,AD)
%IF ONPERQ=NO %THEN QPUT(9,QPUTP-40,STPTR,STALLOC)
%FINISH
! O/P STRING
STPTR=(STPTR+STALLOC+1)&(-2)
PGLA(2,6,ADDR(AH1))
TAGDISP=GLACA-6
RELOCATE(32,TAGDISP,QPUTP-40)
EPTYPE=5; EPDISP=AH1; ! DATA IN GLA SYMBOL TABLES
%FINISH
%IF TYPE=3 %THEN %START; ! RECORDS
EPDISP=GLACA
TAGDISP=EPDISP; ! AND RELOCATE REL APPROPIATE AREA
EPTYPE=2; ! DATA IN GLA TABLES
I=0; ICONST=ICONST&255
ICONST=ICONST<<8!ICONST
%WHILE I<STALLOC %CYCLE; ! RECORDS INITIALISED AS REPEATED BYTE
PGLA(2,2,ADDR(ICONST))
I=I+2
%REPEAT
%FINISH
%IF 1<=TYPE<=2 %START; ! INTEGER & REAL
%IF TYPE=2 %THEN %START
AD=ADDR(FRCONST)+8-STALLOC
%FINISH %ELSE %START; ! INTEGER VARIABLES
AD=ADDR(FICONST)
%FINISH
%IF EXTRN#0 %THEN %START
%IF PARM_DCOMP#0 %THEN WRITE(FICONST,10)
%IF PREC=3 %THEN PGLA(2,2,AD) %ELSE %C
PGLA(ACC,ACC,AD)
%FINISH
! PUT CONSTANT INTO GLA
TAGDISP=GLACA-ACC; ! OFFSET OF VAR FOR TAGS
EPDISP=TAGDISP; ! AND FOR ENTRY DEFN
EPTYPE=2; ! DATA IN ADRESSABLE GLA
%FINISH
STAG(TAGDISP,ACC)
%IF EXTRN=0=NAM %AND 1<=TYPE<=2 %START;! CONST = LITERAL
LCELL==ASLIST(TAGS(K))
%IF TYPE=1 %THEN LCELL_S2=ICONST %ELSE %C
LONGREAL(ADDR(LCELL_S2))=RCONST
%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(WORKA_DICTBASE+WORD(K))
SACC=ACC; TYPEP=PTYPE
AH3=DOPE VECTOR(TYPE,STALLOC,0,K,QQ,LB)>>1
%IF SNDISP=-1 %THEN SNDISP=0; ! BUM DOPE VECTOR
SNDISP=(SNDISP&X'3FFFF')>>2; ! AS WORD DISPLACEMENT
DIMEN=J; ! SAVE NO OF DIMENESIONS
ACC=SACC; PTYPE=TYPEP; UNPACK
%IF LB=0 %AND FORMAT=0 %THEN ARR=2 %AND PACK(PTYPE)
%IF TYPE=3 %THEN LENGTH=QQ %ELSE LENGTH=QQ//STALLOC;! NO OF ELEMENTS
SPOINT=STPTR
%IF FORMAT=0 %THEN %START
%IF A(P)=1 %THEN P=P+1 %AND INIT SPACE(QQ,LENGTH)
%FINISH
%IF CONSTS FOUND=0 %THEN %START; ! NO CONSTANTS GIVEN
! SO CLEAR AN AREA TO ZERO
CONSTS FOUND=LENGTH
CLEAR(QQ) %UNLESS LENGTH<1 %OR EXTRN=3 %OR FORMAT#0
%FINISH %ELSE %START
FAULT(49,0,K) %IF EXTRN=3 %OR FORMAT#0
%FINISH
%IF EXTRN=3 %THEN EPDISP=0 %ELSE EPDISP=SPOINT
! OUTPUT AN ARRAYHEAD INTO THE GLA RELATIVE TO THE START OF THE SYMBOL-
! TABLES IN WHICH THE ARRAY RESIDES.
J=DIMEN; ! RESET DIMENSIONS AFTER INITTING
AH1=EPDISP>>1
AH2=0; ! WILL BE SEG NO
AH4=0; ! WILL BE DV SEG NO
PGLA(4,8,ADDR(AH1))
TAGDISP=GLACA-8
%IF EXTRN=3 %THEN %START; ! EXTRINSIC ARRAYS
GXREF(NAMTXT,2,2<<24,TAGDISP); ! RELOCATE ADDR(A(0))
%FINISH %ELSE %START
RELOCATE(32,TAGDISP,QPUTP-40)
%FINISH
RELOCATE(32,TAGDISP+4,4); ! RELOCATE DV POINTER
EPTYPE=5; ! DATA IN GLA SYMBOL TABLES
STAG(TAGDISP,QQ)
->BEND
%ROUTINE INIT SPACE(%INTEGER SIZE, NELS)
!***********************************************************************
!* P IS TO FIRST ENTRY FOR CONSTLIST *
!* MAP SPACE ONTO WORKFILE END TO GIVE SANE ERROR MESSAGE IF *
!* THERE WAS NOT ENOUGH SPACE *
!***********************************************************************
%INTEGER RF, I, II, ELSIZE, AD, SPP, LENGTH, SAVER, WRIT
%BYTEINTEGERARRAYNAME SP
%BYTEINTEGERARRAYFORMAT SPF(0:4096+256)
SAVER=R; R=R+(4096+256)
%IF R>ARSIZE %THEN FAULT(102, WORKA_WKFILEK,0)
SP==ARRAY(ADDR(A(SAVER)),SPF)
%IF TYPE=1 %THEN AD=ADDR(FICONST)
%IF TYPE=2 %THEN AD=ADDR(FRCONST)+8-ACC
%IF TYPE=3 %THEN AD=ADDR(ICONST)+3
%IF TYPE=5 %THEN AD=ADDR(SCONST)
SPP=0; WRIT=0
ELSIZE=SIZE//NELS
%UNTIL A(P-1)=2 %CYCLE
XTRACT CONST(TYPE,PREC)
%IF A(P)=1 %START; ! REPITITION FACTOR
P=P+2
%IF A(P-1)=2 %THEN RF=NELS-CONSTS FOUND %ELSE %START
P=P+2
%IF INTEXP(RF,X'41')#0 %THEN FAULT(41,0,0) %AND RF=1
%FINISH
P=P+1
%FINISH %ELSE RF=1 %AND P=P+2
FAULT(42,RF,0) %IF RF<=0
%CYCLE I=RF,-1,1
%IF TYPE=1=ACC %OR TYPE=3 %START
%CYCLE II=0,1,ELSIZE-1
%IF CONSTS FOUND<=NELS %THEN SP(SPP)<- %C
ICONST %AND SPP=SPP+1
%REPEAT
%FINISH %ELSE %START
%CYCLE II=0,2,ELSIZE-2
%IF CONSTS FOUND<=NELS %THEN %C
HALFINTEGER(ADDR(SP(SPP)))=HALFINTEGER(AD+II) %C
%AND SPP=SPP+2
%REPEAT
%FINISH
CONSTS FOUND=CONSTS FOUND+1
%IF SPP>=4096 %START; ! EMPTY BUFFER
%IF PARM_INHCODE=0 %THEN %START
QPUT(QPUTP,SPP,STPTR+WRIT,ADDR(SP(0)))
%IF ONPERQ=NO %AND (TYPE=5 %OR (TYPE=1 %AND PREC=3))%C
%THEN QPUT(9,QPUTP-40,STPTR+WRIT,SPP)
%FINISH
WRIT=WRIT+SPP
SPP=0
%FINISH
%REPEAT
%REPEAT; ! UNTIL P<ROCL>=%NULL
%IF CONSTS FOUND#NELS %THEN FAULT(45,CONSTS FOUND,NELS)
LENGTH=(SIZE+3)&(-4)
%IF PARM_INHCODE=0 %START
QPUT(QPUTP,LENGTH-WRIT,STPTR+WRIT,ADDR(SP(0)))
%IF ONPERQ=NO %AND(TYPE=5 %OR(TYPE=1 %AND PREC=3)) %C
%THEN QPUT(9,QPUTP-40,STPTR+WRIT,LENGTH-WRIT)
%FINISH
STPTR=STPTR+LENGTH
R=SAVER
%END
%ROUTINE CLEAR(%INTEGER LENGTH)
STPTR=(STPTR+3)&(-4)
LENGTH=(LENGTH+3)&(-4)
QPUT(QPUTP,LENGTH<<14!4,STPTR,ADDR(ZERO)) %IF PARM_INHCODE=0
STPTR=STPTR+LENGTH
%END
%ROUTINE STAG(%INTEGER J, DATALEN)
%IF EXTRN=2 %THEN QPUT(14,EPTYPE<<24!DATALEN,EPDISP,ADDR( %C
NAMTXT))
RBASE=0
STORE TAG(K,J)
RBASE=RLEVEL
%END
%ROUTINE XTRACT CONST(%INTEGER CONTYPE, CONPREC)
!***********************************************************************
!* P POINTS TO P<+'> OF <+'><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 LENGTH, STYPE, SACC, CPREC, MODE, I
%LONGREAL LRCONST; ! TO ASSIST IN FORMAT CHANGES
STYPE=PTYPE; SACC=ACC; ! MAY BE CHANGED IF CONST IS EXPR
%IF CONTYPE=5 %THEN %START
CTYPE=5
%IF A(P)=4 %AND A(P+1)=2 %AND A(P+2)=X'35' %C
%AND A(P+A(P+3)+4)=2 %START
SCONST=STRING(ADDR(A(P+3)))
LENGTH=A(P+3)
P=P+A(P+3)+5
%FINISH %ELSE %START
FAULT(44,CONSTS FOUND,K); SCONST=""
LENGTH=0; P=P-3; SKIP EXP
%FINISH
%FINISH %ELSE %START
MODE=CONPREC<<4!CONTYPE
%IF CONPREC<5 %THEN MODE=CONTYPE!X'50'
CONSTP=CONSTEXP(MODE)
%IF CONSTP=0 %THEN FAULT(41,0,0) %AND CONSTP=ADDR(ZERO)
! CANT EVALUATE EXPT
CTYPE=TYPE; CPREC=PREC
%IF CTYPE=1 %THEN %START
ICONST=INTEGER(CONSTP)
%FINISH %ELSE %START
RCONST=LONGREAL(CONSTP)
%FINISH
%FINISH
PTYPE=STYPE; UNPACK; ACC=SACC
! FAULT ANY OBVIOUS ERRORS IE:-
! CONSTANT FOR EXTRINSIC OR INCOMPATIBLE TYPE OR STRING TOO LONG
%IF EXTRN=3 %THEN FAULT(49,0,K) %AND %RETURN
%IF (CTYPE=5 %AND LENGTH>=ACC) %C
%OR (CONTYPE=1 %AND ((CONPREC=3 %AND ICONST>255) %C
%OR (CONPREC=4 %AND ICONST>X'FFFF'))) %C
%THEN FAULT(44,CONSTS FOUND,K)
!
! IF CROSS COMPILING THEN A CONSTANT FORMAT CHANGE IS NEED FROM
! IBM&ICL FORM TO PERQ FORM. IF ON PERQ FORMAT IS CORRECT
!
FICONST=ICONST; FRCONST=RCONST
%IF ON PERQ=NO %THEN %START
FICONST=(ICONST>>16)!(ICONST<<16)
%IF CONPREC=6 %THEN LRCONST=ICLLONGREALTOPERQ(RCONST) %ELSE %C
LRCONST=ICLREALTOPERQ(RCONST)
%CYCLE I=0,2,6
HALFINTEGER(ADDR(FRCONST)+6-I)=HALFINTEGER(ADDR(LRCONST)+I)
%REPEAT
%FINISH
%END
BEND: %END; ->CSSEXIT
SW(18):
ABORT
SW(10):
%BEGIN; ! %RECORDFORMAT (RDECLN)
%INTEGER NAME,OPHEAD,OPBOT,NLIST,MRL,CELLREF
%RECORD(LISTF)%NAME LCELL,FRCELL
SNDISP=0
NAME=FROM AR2(P+1); P=P+3
COPY TAG(NAME)
%UNLESS PTYPE=4 %AND J=15 %AND OLDI=LEVEL %START
KFORM=0
PUSH(KFORM,0,0,0)
ACC=X'7FFF'
PTYPE=4; J=0
STORETAG(NAME,KFORM); ! IN CASE OF REFS IN FORMAT
%FINISH%ELSE %START
LCELL==ASLIST(TAGS(NAME))
LCELL_S1=LCELL_S1&X'FFFFFFF0';! J=15 TO J=0
%FINISH
LCELL==ASLIST(KFORM)
OPHEAD=0; OPBOT=0
NLIST=0; MRL=0
INAFORMAT=1
CRFORMAT(OPHEAD,OPBOT,NLIST,MRL,X'80000000')
INAFORMAT=0
CLEAR LIST(NLIST)
!
! IN CASE OF FORWARD REFS COPY TOP CELL OF FORMAT CHAIN INTO DUMMY
! SET UP BEFORE CALL OF CRFORMAT. ALSO RESET J&ACC TO CORRECT VALUE
!
%WHILE LCELL_S3#0 %CYCLE; ! THROUGH FORWARD REFS
POP(LCELL_S3,CELLREF,I,I)
FRCELL==ASLIST(CELLREF)
FRCELL_S1=FRCELL_S1&X'FFFFFFF0';! SET J BACK TO 0
FRCELL_S2=FRCELL_S2&X'FFFF0000'!ACC;! ACC TO CORRECT VALUE
%REPEAT
POP(OPHEAD,LCELL_S1,LCELL_S2,LCELL_S3)
LCELL_LINK=OPHEAD
LCELL==ASLIST(TAGS(NAME))
LCELL_S2=LCELL_S2&X'FFFF0000'!ACC
%END;->CSSEXIT
!
SW(19):
! '*' (UCI) (S)
FAULT(57,0,0) %UNLESS LEVEL>=2
%BEGIN
!***********************************************************************
!* COMPILE USERCODE INSTRUCTION. MOST WORK IS DONE BY HAIRY *
!* BUILT-IN PHRASE IN COMPARE. SINCE ALMOST ANYTHING IS LEGAL *
!* IN USERCODE THIS BLOCK HAS ONLT TO ASSEMBLE AND PLANT THE *
!* THE INSTRUCTION. *
!***********************************************************************
%SWITCH UCITYPE(1:4),QINST(1:7)
%INTEGER ALT,AALT,FNAME,OPTINC,OPC,KK,VAL1,VAL2,I,TR
ALT=A(P+1); P=P+2
->UCITYPE(ALT)
UCITYPE(1): ! **@'(NAME)(OPTINC)
AALT=A(P); ! ALT OF @'
FNAME=A(P+1)<<8!A(P+2)
P=P+3; OPTINC=0
%IF A(P)#3 %START; ! THERE IS AN OPTINC
OPTINC=FROMAR2(P+1)
%IF A(P)=2 %THEN OPTINC=-OPTINC
%FINISH
COPY TAG(FNAME)
FAULT(97,FNAME,0) %IF TYPE>=6 %OR ROUT#0
%IF AALT=1 %THEN DFETCHAD(NO,I,K+OPTINC) %ELSE %C
%IF AALT=2 %THEN DSTORE(2,I,K+OPTINC) %ELSE %C
DFETCH(2,I,K+OPTINC)
->BEND
UCITYPE(2): ! PUT (HEX HALFWORD)
TYPE=A(P)
PREC=TYPE>>4; TYPE=TYPE&7
FAULT(97,0,0) %UNLESS TYPE=1 %AND PREC<6
%IF PREC=5 %THEN P=P+2
KK=FROM AR2(P+1); I=UCB2
->OTRIP
UCITYPE(4): ! CNOP
I=UCNOP; KK=FROM AR2(P)
->OTRIP
UCITYPE(3): ! ASSEMBLER
AALT=A(P); P=P+1
OPC=A(P); P=P+4
%IF AALT>1 %THEN %START
KK=INTEXP(VAL1,X'41')
FAULT(96,0,1) %UNLESS KK=0
%FINISH
%IF AALT>=5 %START
P=P+3
KK=INTEXP(VAL2,X'41')
FAULT(96,0,2) %UNLESS KK=0
%FINISH
->QINST(AALT)
QINST(1): ! ONE BYTE INSTRUCTION
I=UCB1; KK=OPC; ->OTRIP
QINST(2): ! UNSIGNED BYTE OPERAND
FAULT(96,0,1) %UNLESS 0<=VAL1<=255
I=UCB2; KK=OPC<<8!VAL1
->OTRIP
QINST(3): ! SIGNED BYTE OPERAND
FAULT(96,0,1) %UNLESS -128<=VAL1<=127
I=UCB2; KK=OPC<<8!(VAL1&255)
->OTRIP
QINST(4): ! SIGNED WORD OPERAND
FAULT(96,0,1) %UNLESS IMOD(VAL1)<=X'7FFF'
I=UCW; KK=OPC<<16!(VAL1&X'FFFF')
->OTRIP
QINST(5): ! 2 UNSIGNED BYTE OPERANDS
FAULT(96,0,1) %UNLESS 0<=VAL1<=255
FAULT(96,0,2) %UNLESS 0<=VAL2<=255
I=UCB3; KK=OPC<<16!VAL1<<8!VAL2
->OTRIP
QINST(6): ! BYTE & WORD OPERANDS
FAULT(96,0,1) %UNLESS 0<=VAL1<=255
FAULT(96,0,2) %UNLESS IMOD(VAL2)<=X'7FFFF'
I=UCBW; KK=OPC<<24!VAL1<<16!(VAL2&X'FFFF')
->OTRIP
OTRIP:
TR=UCONSTTRIP(I,0,DONT OPT,KK)
BEND:
%END
->CSSEXIT
SW(20):
! '%TRUSTEDPROGRAM'
PARM_COMPILER=1 %IF PARM_ARR=0 %AND PARM_CHK=0; ->CSSEXIT
SW(21): ! '%MAINEP'(NAME)
KK=FROM AR2(P+1)
FAULT(97,0,0) %UNLESS PARM_CPRMODE=0
MAINEP<-STRING(WORKA_DICTBASE+WORD(KK))
->CSSEXIT
%INTEGERFN CFORMATREF
!***********************************************************************
!* P IS TO ALT OF FORMAT REF *
!* P<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
KFORM=0; SNDISP=0;ACC=X'7FFF'
PTYPE=4; J=15
PUSH(KFORM,0,0,0)
STORE TAG(FNAM,KFORM)
%RESULT=KFORM
%FINISH
FAULT(62,0,FNAM); ! NOT A RECORD OF FORMAT NAME
ACC=8; ! GUESS A RECORD SIZE
%RESULT=DUMMY FORMAT
%FINISH
! FORMAT ACTUALLY SPECIFIED
P=P+1
OPHEAD=0; OPBOT=0
NHEAD=0; MRL=0
CRFORMAT(OPHEAD,OPBOT,NHEAD,MRL,X'80000000')
CLEAR LIST(NHEAD)
%IF CURRINF_UNATT FORMATS#0 %START
LCELL==ASLIST(CURRINF_UNATT FORMATS)
%IF LCELL_S2=0 %THEN LCELL_S2=OPHEAD %AND %RESULT=OPHEAD
%IF LCELL_S3=0 %THEN LCELL_S3=OPHEAD %AND %RESULT=OPHEAD
%FINISH
PUSH(CURRINF_UNATT FORMATS,OPHEAD,0,0)
%RESULT=OPHEAD
%END
%ROUTINE CRFORMAT(%INTEGERNAME OPHEAD, OPBOT, NLIST, MRL, %INTEGER INIT)
!***********************************************************************
!* CONVERTS A RECORDFORMAT STATEMENT TO A LIST HEADED BY OPHEAD *
!* FORMAT OF AN ENTRY. *
!* S1=SUBNAME<<20!PTYPE<<4!J *
!* S2,S3=4 16 BIT DISPLACEMENTS D2,ACC,D1,KFORM *
!* NORMALLY D1=RECORD RELATIVE DISPLACEMENT AND ACC=LMAX(STRINGS)*
!* FOR ARRAYS D2=FIRST ELEMENT DISPLACEMENT AND D1=DISPLACEMENT *
!* OF RECORD RELATIVE ARRAYHEAD IN THE GLA *
!* KFORM IS ONLY USED FOR RECORDS AND POINTS TO THE FORMAT *
!* ON EXIT ACC HAS THE RECORD SIZE ROUNDED UP TO THE BOUNDARY *
!* REQUIRED BY ITS LARGEST COMPONENT *
!***********************************************************************
%INTEGER D1, D2, FORM, RL, STALLOC, INC, Q, R, RFD, LB, TYPEP, SACC
%HALFINTEGER A0, A1, A2, A3
%ROUTINESPEC SN(%INTEGER Q)
%ROUTINESPEC ROUND
FORM=0; ACC=0
INC=INIT&X'FFFF'; ! INC COUNTS DOWN RECORD
%CYCLE
ROUT=0; LITL=0; NAM=0; RFD=A(P)
P=P+1
%IF RFD=1 %THEN %START
CLT
FORM=KFORM
STALLOC=ACC
%IF PTYPE=X'35' %THEN STALLOC=(STALLOC+1)&(-2)
P=P+1
%IF A(P-1)=1 %START
! (TYPE) (QNAME')(NAMELIST)
FORM=KFORM
CQN(P); P=P+1
%IF NAM=1 %THEN %START
STALLOC=4
%IF TYPE=5 %OR(TYPE=1 %AND PREC=3) %THEN STALLOC=6
%IF ARR#0 %THEN STALLOC=8
%FINISH
PACK(PTYPE); D2=0
%IF STALLOC=1 %THEN RL=0 %ELSE RL=1
ROUND; J=0
%UNTIL A(P-1)=2 %CYCLE
D1=INC; SN(P)
P=P+3; INC=INC+STALLOC
%REPEAT
%FINISH %ELSE %START
! (TYPE)%ARRAY(NAMELIST)(BPAIR)
Q=P+1; ARR=1; PACK(PTYPE)
%CYCLE
P=Q
P=P+3 %UNTIL A(P-1)=2
TYPEP=PTYPE; SACC=ACC
A2=DOPE VECTOR(TYPE,ACC,0,FROMAR2(Q)>>1,R,LB)>>1
! DOPE VECTOR INTO SHAREABLE S.T.
ACC=SACC; PTYPE=TYPEP; UNPACK
RL=1
ROUND
%CYCLE
A0=INC>>1
A1=0
A3=0
PGLA(2,8,ADDR(A0))
D1=GLACA-8
RELOCATE(32,D1+4,4); ! RELOCATE DV POINTER
D2=INC
SN(Q); INC=INC+R
Q=Q+3
%REPEAT %UNTIL A(Q-1)=2;! TILL NAMELIST NULL
P=P+1; Q=P+1
%REPEAT %UNTIL A(P-1)=2; ! UNTIL <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. *
!***********************************************************************
FNAME=FROM AR2(Q)
FAULT(61,0,FNAME) %UNLESS FIND(FNAME,NLIST)=-1
BINSERT(OPHEAD,OPBOT,FNAME<<20!PTYPE<<4!J,D2<<16!ACC,D1<< %C
16!FORM)
PUSH(NLIST,0,FNAME,0)
%IF PTYPE=X'433' %AND ACC=X'7FFF' %THEN %C
PUSH(ASLIST(FORM)_S3,OPBOT,0,0);! NOTE FORWARD REFERENCE
%END
%ROUTINE ROUND
MRL=RL %IF RL>MRL
INC=INC+1 %WHILE INC&RL#0
%END
%END; ! OF ROUTINE CRFORMAT
%INTEGERFN DISPLACEMENT(%INTEGER LINK)
!***********************************************************************
!* SEARCH A FORMAT LIST FOR A SUBNAME *
!* A(P) HAS ENAME--LINK IS HEAD OF RFORMAT LIST. RESULT IS DISP *
!* FROM START OF RECORD *
!***********************************************************************
%RECORD(LISTF)%NAME FCELL,PCELL,LCELL
%INTEGER RR,II,ENAME,CELL
ENAME=A(P)<<8+A(P+1); CELL=0
%IF LINK#0 %THEN %START; ! CHK RECORDSPEC NOT OMITTED
FCELL==ASLIST(LINK); ! ONTO FIRST CELL
CELL=LINK; II=-1; ACC=-1
%WHILE LINK>0 %CYCLE
LCELL==ASLIST(LINK)
%IF LCELL_S1>>20=ENAME %START;! RIGHT SUBNAME LOCATED
TCELL=LINK
RR=LCELL_S1
SNDISP=LCELL_S2
K=LCELL_S3
J=RR&15; PTYPE=RR>>4&X'FFFF'
ACC=SNDISP&X'FFFF'; SNDISP=SNDISP&X'FFFF0000'//X'10000'
KFORM=K&X'FFFF'; K=K>>16
%IF LINK#CELL %START; ! NOT TOP CELL OF FORMAT
PCELL_LINK=LCELL_LINK
LCELL_LINK=FCELL_LINK
FCELL_LINK=LINK
%FINISH; ! ARRANGING LIST WITH THIS SUBNAME
! NEXT TO THE TOP
%RESULT=K
%FINISH
PCELL==LCELL
LINK=LCELL_LINK
%REPEAT
%FINISH
FAULT(65,0,ENAME)
%IF CELL>0 %THEN %C
PUSH(ASLIST(CELL)_LINK,ENAME<<20!7<<4,0,0)
PTYPE=X'57'; TCELL=0
%RESULT=-1
%END
%INTEGERFN COPY RECORD TAG(%INTEGERNAME SUBS)
!***********************************************************************
!* PRODUCE PTYPE ETC FOR A COMPOUND NAME BY CHAINING DOWN ONE *
!* ONE OR MORE RECORD FORMAT LISTS. ON EXIT RESULT =0 IF NO *
!* SUBNAME FOUND OR SUBNAME IS OF TYPE RECORD WITH NO FURTHER *
!* SUBNAME ATTACHED. RESULT#0 IF BONE-FIDE SUBNAME LOCATED *
!* ON ENTRY KFORM HAS POINTER TO THE (FIRST ) FORMAT LIST AND *
!* P POINTS TO THE A.R. ENTRY FOR (FIRST) ENAME *
!***********************************************************************
%INTEGER Q,FNAME
SUBS=0
%UNTIL TYPE#3 %CYCLE
FNAME=KFORM
P=P+2; SKIP APP
%RESULT=0 %IF A(P)=2 %OR FNAME<=0;! NO (FURTHER) ENAME
SUBS=SUBS+1
P=P+1; Q=DISPLACEMENT (FNAME)
UNPACK
%REPEAT
%RESULT=Q+1; ! GIVES 0 IF SUBNAME NOT KNOWN
%END
%ROUTINE CRNAME(%INTEGER Z,MODE,BS,DP,%INTEGERNAME NAMEP)
!***********************************************************************
!* DEAL WITH RECORD ELEMENT NAMES.Z AS FOR CNAME.CLINK=TAGS(RN) *
!* MODE=ACCESS FOR RECORD(NOT THE ELEMENT!) *
!* ON EXIT BASE,AREA & DISP POINT TO REQUIRED ELEMENT *
!* RECURSIVE CALL IS NEEDED TO DEAL WITH RECORDS IN RECORDS *
!* DEPTH SHEWS RECURSIVE LEVELS- NEEDED TO AVOID MIS SETTING *
!* REGISTER IN USE IF RECORDNAME IN RECORD HAS THE SAME NAME AS *
!* A GENUINE RECORD NAME. *
!***********************************************************************
%INTEGER DEPTH,FNAME
%ROUTINESPEC CENAME(%INTEGER MODE,FNAME,BS,DP,XD)
DEPTH=0
FNAME=KFORM; ! POINTER TO FORMAT
%IF ARR=0 %OR (Z=6 %AND A(P+2)=2) %START;! SIMPLE RECORD
%IF A(P+2)=2 %THEN P=P+3 %ELSE NO APP
CENAME(MODE,FNAME,BS,DP,0)
%FINISH %ELSE %START
CANAME(Z,ARR,BS,DP)
NAMEP=0
CENAME(ACCESS,FNAME,BASE,DISP,0)
%FINISH; %RETURN
!
%ROUTINE CENAME(%INTEGER MODE,FNAME,BS,DP,XD)
!***********************************************************************
!* FINDS OUT ABOUT SUBNAME AND ACTS ACCORDINGLY.MOSTLY ACTION *
!* CONSISTS OF UPPING XD BY OFFSET OF THE SUBNAME BUT IS VERY *
!* HAIRY FOR RECORDS IN RECORDS ETC *
!* MODE IS ACCESS FOR THE RECORD *
!***********************************************************************
%ROUTINESPEC FETCH RAD
%ROUTINESPEC LOCALISE(%INTEGER SIZE)
%INTEGER Q,QQ,D,C,W
DEPTH=DEPTH+1
%IF A(P)=2 %THEN %START; ! ENAME MISSING
ACCESS=MODE; XDISP=XD
BASE=BS; DISP=DP; ! FOR POINTER
%IF Z<14 %THEN %START; ! NOT A RECORD OPERATION
%UNLESS 3<=Z<=4 %OR Z=6 %START; ! ADDR(RECORD)
FAULT(64,0,NAMEP&X'FFFF'); BASE=RBASE
DISP=0; ACCESS=0; PTYPE=X'51'; UNPACK
%FINISH
%FINISH
%RETURN
%FINISH
P=P+1; ! FIND OUT ABOUT SUBNAME
Q=DISPLACEMENT(FNAME); ! TCELL POINTS TO CELL HOLDING
UNPACK; ! INFO ABOUT THE SUBNAME
%IF Q=-1=ACC %OR PTYPE=X'57' %START; ! WRONG SUBNAME(HAS BEEN FAULTED)
P=P+2; SKIP APP; P=P-3
ACCESS=0; BASE=RBASE; DISP=0
%RETURN
%FINISH
NAMEP=(A(P)<<8!A(P+1))<<16!NAMEP; ! NAMEP=-1 UNALTERED !
->AE %IF ARR=1; ! ARRAYS INCLUDING RECORDARRAYS
%IF A(P+2)=2 %THEN P=P+3 %ELSE NO APP
%IF TYPE<=2 %OR TYPE=5 %OR %C
(TYPE=3 %AND A(P)=2 %AND (3<=Z<=4 %OR Z=6)) %START
ACCESS=MODE+4+4*NAM; BASE=BS;
DISP=DP; XDISP=XD+Q
%RETURN
%FINISH
!
! NOW CODING BECOMES HAIRY:- STILL LEFT ARE
! A) RECORDS IN RECORDS Q POINTS TO SECONDARY RECORD
! B) RECORDNAMES IN RECORDS Q HAS OFF-SET OF A POINTER
! C) RECORDARRAYNAMES IN RECORDS Q HAS OFF-SET A HEADER IN RECORD
! D) RECORDARRAYS IN RECORDS NOT YET ALLOWED
! Q WOULD HAVE OFF-SET OF A RECORD RELATIVE HEADER IN THE GLA
!
XD=XD+Q
NAMEP=-1
%IF NAM=1 %THEN %START
%IF MODE=0 %START
DP=DP+XD; XD=0; MODE=2
%FINISH %ELSE %START
LOCALISE(4); ! PICK UP RECNAME DESCR &STCK
DP=DISP; BS=BASE
%FINISH
%FINISH
CENAME(MODE,KFORM,BS,DP,XD)
%RETURN
AE: ! ARRAYS AND ARRAYNAMES AS ELEMEN
FROM123(TCELL,Q,SNDISP,K)
ACC=SNDISP&X'FFFF'; SNDISP=SNDISP&X'FFFF0000'//X'10000'
KFORM=K&X'FFFF'; K=K>>16
C=ACC; D=SNDISP; Q=K; QQ=KFORM
%IF (Z=6 %OR Z>=11) %AND A(P+2)=2 %START;! 'GET ARRAYHEAD' CALL
P=P+3
%IF NAM=1 %THEN %START
ACCESS=MODE+8; BASE=BS
DISP=DP; XDISP=XD+Q
NAMEOP(6,8,NAMEP); ! PTR TO HEAD
%IF Z=12 %THEN PB1(TLATE1) %AND PB2(ROPS,37)
%RETURN
%FINISH
!
! PASSING AN ARRAY IN A RECORD BY NAME MUST CONSTRUCT PROPER ARRAYHEAD
! FROM THE RECORD RELATIVE ONE AT Q(GLA)
!
NAMEP=-1
FETCH RAD
ACCESS=2;
DFETCHAD(NO,0,Q)
PB2(ROPS,37); ! HEAD TO ESTACK
CREATE AH(1)
%FINISH %ELSE %START; ! ARRAY ELEMENTS IN RECORDS
NAMEP=-1
%IF NAM=1 %THEN %START; ! ARRAYNAMES-FULLHEAD IN RECORD
XD=XD+Q
LOCALISE(8); ! MOVE HEAD UNDER LNB
D=DISP
CANAME(Z,3,BASE,DISP); ! ARRAY MODE SETS DISP,AREA&BASE
BASE=RBASE; DISP=D; ! ONLY NEEDED FOR STRINGARRAYNAMES
%FINISH %ELSE %START; ! ARRAY RELATIVE HEAD IN GLA
FETCH RAD; ! 32 BIT ADDR TO ETOS
CANAME(Z,3,0,Q); ! RECORD REL ARRAY ACCESS
! CAN RETURN ACCESS=1 OR 3 ONLY
%IF PTYPE&255=X'31' %THEN PB1(MMS);! REMOVE OFFSET BYTE
PB2(LOPS,2); ! ADD 2 32 BIT POINTERS
%IF PTYPE&255=X'31' %THEN PB1(MES)
%FINISH
XDISP=XD
%IF TYPE=3 %THEN CENAME(ACCESS,QQ,BASE,DISP,XD)
%FINISH
ACC=C; ! NEEDED FOR STRING ARRAYS
%RETURN
%ROUTINE FETCH RAD
!***********************************************************************
!* SET ACC TO 32 BIT ADDRESS OF RECORD. *
!***********************************************************************
%INTEGER PRECP
ACCESS=MODE+4
BASE=BS
DISP=DP; XDISP=XD
PRECP=PREC; PREC=5
NAMEOP(3,4,-1)
PREC=PRECP; ! ENSURE 32BIT PICKUP
%END
%ROUTINE LOCALISE(%INTEGER SIZE)
!***********************************************************************
!* REMOVES A POINTER OR ARRAYHEAD FROM A RECORD AND STORES *
!* IT IN A TEMPORARY UNDER LNB. *
!***********************************************************************
%INTEGER HOLE,PRECP
ACCESS=MODE+4
BASE=BS; DISP=DP
XDISP=XD
PRECP=PREC; PREC=5
NAMEOP(3,SIZE,-1)
PREC=PRECP
GET WSP(HOLE,SIZE>>1)
%IF SIZE=8 %START; ! LOCALISE ARRAY HEAD
PB1(TLATE1)
PB2(ROPS,37)
%FINISH
DSTORE(SIZE,RBASE,HOLE)
MODE=2
BASE=RBASE; DISP=HOLE; XD=0
%END; ! OF ROUTINE LOCALISE
%END; ! OF ROUTINE CENAME
%END; ! OF ROUTINE CRNAME
%ROUTINE CSTREXP(%INTEGER MODE)
!***********************************************************************
!* PLANT IN-LINE CODE FOR CONCATENATION. A WORK AREA IN THE *
!* CURRENT STACK FRAME IS USUALLY REQUIRED. *
!* ON ENTRY:- *
!* MODE=0 NORMAL. WK AREA NOT USED FOR ONE OPERAND EXPSSNS *
!* MODE=1 STRING MUST GO TO WORK AREA *
!* 2**5 BIT OF MODE SET IF FULL VIRTUAL ADDRESS REQUIRED *
!* 2**4 BIT OF MODE IS SET IF WK-AREA NOT TO BE FREED ON EXIT *
!* ON EXIT:- *
!* VALUE#0 %IF RESULT IN A WORK AREA(CCOND MUST KNOW) *
!***********************************************************************
%INTEGER PP,WKAREA,DOTS,ERR,KEEPWA,FNAM,I,ENDFLAG
%RECORD(RD) OPND1,OPND2,OPND3
%INTEGERFNSPEC STROP(%RECORD(RD) %NAME OPND)
KEEPWA=MODE&16; MODE=MODE&15
PP=P; STRINGL=0; FNAM=0; WKAREA=0
P=P+3; ! LENGTH OF CONSTANT PART
ERR=72; ->ERROR %UNLESS A(P)=4
P=P+1
DOTS=0; ! NO OPERATORS YET
ENDFLAG=0
STRINGL=0
ERR=STROP(OPND2); ! GET FIRST OPERAND
->ERROR %UNLESS ERR=0
NEXT: %IF A(P)=2 %THEN ENDFLAG=1 %ELSESTART
%IF A(P+1)#CONCOP %THEN ERR=72 %AND ->ERROR
P=P+2
ERR=STROP(OPND3)
->ERROR %UNLESS ERR=0
%FINISH
%IF ENDFLAG=0 %AND OPND2_FLAG=LCONST=OPND3_FLAG %START
!
! CAN FOLD OUT A CONCATENATION HERE
!
I=CONCAT
CTOP(I,ERR,0,OPND2,OPND3)
%IF I=0 %THEN ->NEXT; ! FOLDED OUR
%FINISH
%IF DOTS=0 %START
%IF MODE=0 %AND ENDFLAG#0 %START; ! NO RUN-TIME OPERATIONS
OPND1=OPND2; ->TIDY
%FINISH
GET WSP(WKAREA,X'80000000'!268); ! GET NEXT OPERAND
OPND1_PTYPE=X'35'
OPND1_FLAG=LOCALIR
OPND1_D=RBASE<<16!WKAREA
I=BRECTRIP(PRECC,X'35',0,OPND1,OPND2)
DOTS=1
%FINISH
%IF ENDFLAG=0 %THENSTART
I=BRECTRIP(CONCAT,X'35',0,OPND1,OPND3)
->NEXT
%FINISH
TIDY: ! FINISH OFF
EXPOPND=OPND1; ! LEAVE REULT IN EXPOPND
VALUE=WKAREA
P=P+1; ! PAST REST OF EXPRN
RETURN WSP(WKAREA,268) %IF KEEPWA=0 %AND WKAREA>0
STRINGL=0
%RETURN
ERROR:FAULT(ERR,0,FNAM)
BASE=RBASE; DISP=0
VALUE=0; ACCESS=0
P=PP; SKIP EXP
%RETURN
%INTEGERFN STROP(%RECORD(RD) %NAME OPND)
!***********************************************************************
!* DEALS WITH OPERAND FOR CONCATENATION. RETURN RESULT=0 FOR *
!* VALID OPERAND OTHERWISE AN ERROR NUMBER. *
!***********************************************************************
%INTEGER CTYPE,MODE,I
MODE=A(P); ! ALTERNATIVE OF OPERAND
OPND=0
%RESULT=75 %IF MODE>2
%IF MODE#1 %THENSTART
CTYPE=A(P+1); ! GET CONST TYPE & LOSE AMCK FLAGS
%IF CTYPE=X'35' %THENSTART
STRINGL=A(P+2)
OPND_PTYPE=CTYPE
OPND_FLAG=LCONST
OPND_D=P+2
OPND_XTRA=STRINGL
P=P+STRINGL+3
%FINISHELSERESULT=73
%FINISHELSESTART
P=P+1; ! MUST CHECK FIRST
%IF 5#TYPE#7 %THEN FNAM=FROMAR2(P) %ANDRESULT=71
%IF PTYPE=X'35' %AND A(P+2)=2=A(P+3) %START
OPND_FLAG=DNAME
OPND_PTYPE=PTYPE
OPND_D=FROMAR4(P)
P=P+4
%FINISHELSESTART
CNAME(2)
OPND_FLAG=REFTRIP
OPND_PTYPE<-PTYPE
OPND_D=TRIPLES(0)_BLINK
%FINISH
STRINGL=0
DISP=0
%FINISH
%RESULT=0
%END; ! OF INTEGERFN STROP
%END; ! OF ROUTINE CSTREXP
%ROUTINE CRES (%INTEGER LAB)
!**********************************************************************
!* COMPILES A RESOLUTION E.G A->B.(C).D.(E).F AND JUMPS TO LAB *
!* ON FAILURE. (LAB=0 FOR UNCONDITIONAL RESOLUTION TO PERM ON *
!* FAILURE ). *
!* THE METHOD IS TO CALL A SUBROUTINE PASSING 5 PARAMS:- *
!* P1(32BITS) POINTS TO LHS(A) *
!* P2(16BITS) ORIGINAL LENGTH OF A *
!* P3(32BITS) FULL POINTER TO BYTES USED UP INITIALLY 0 *
!* P4(48BITS) STRING TO CONTAIN FRAGMENT *
!* (PASSED AS LMAX FOLLOWED BY 32BIT ADDRESS) *
!* P5(32BITS) THE EXPRESSION PASSED AS 32 BIT ADDRESS *
!* SUBROUTINE TRIES TO PERFORM THE RESOLUTION AND SETS THE *
!* RESULT TO TRUE IF IT SUCCEEDS. *
!* *
!* ON ENTRY LHS IS IN THE ESTACK(32BITS). *
!* P POINTS TO P(+') OF RHS DEFINED AS (+')(OPERAND)(RESTOFEXP) *
!* *
!$ THE ROUTINE IS COMPACT BUT DIFFICULT TO FOLLOW (OR ALTER) *
!* THE TIME IN PERM IS LARGE SO IT IS NOT WORTHWHILE TO PERSUE *
!* CODE EFFICIENCY TOO INDUSTRIOUSLY . *
!**********************************************************************
%INTEGER P1,P2,SEXPRN,W,LAST,ERR,FNAM
LAST=0; FNAM=0; ! =1 WHEN END OF EXPRNSN FOUND
SEXPRN=0; ! RESOLUTION(BRKTD) EXPRESSNS
ERR=74; ! NORMAL CRES FAULT
GET WSP(W,X'80000004'); ! TO HOLD P1,P2 AND VALUE OF P3
PB1(REPL2)
DSTORE(4,RBASE,W); ! SAVE 32BIT ADDR OF LHS
PB1(LDC0)
DSTORE(2,RBASE,W+6); ! 0 BYTES USED UP SO FAR
PB3(LDC0,TLATE2,LDCH)
DSTORE(2,RBASE,W+4); ! ORIGINAL LENGTH OF LHS
P1=P; P=P+3
->RES %IF A(P)=4; ! LHS MUST BE A STRING
! BUT THIS CHECKED BEFORE CALL
ERR=72
ERROR:FAULT(ERR,0,FNAM)
P=P1; SKIP EXP; %RETURN
RES: P=P+1; ! TO P(OPERAND)
PB2(ATPB,1); ! HOLE FOR RESULT(=T/F)
DFETCH(4,RBASE,W)
PB1(MMS2); ! P1 IS STACKED
DFETCH(2,RBASE,W+4)
PB1(MMS); ! P2 IS STACKED
DFETCHAD(YES,RBASE,W+6)
PB1(MMS2); ! POINTER TO P3
%IF A(P)=3 %THEN %START; ! B OMITTED
PB3(LDC0,REPL,REPL)
%FINISH %ELSE %START
->ERROR %UNLESS A(P)=1; ! P(OPERAND)=NAME
P=P+1; P2=P
CNAME(3)
%IF TYPE#5 %THEN ERR=71 %AND FNAM=FROMAR2(P2) %AND ->ERROR
%IF A(P+1)#CONCOP %THEN ERR=72 %AND ->ERROR
P=P+2
%FINISH
PB2(MMS,MMS2); ! LAMX&ADDRESS AS PARAMETERS
->ERROR %UNLESS A(P)=3; ! P(OPERAND)='('(EXPR)')'
SEXPRN=SEXPRN+1; P=P+1
CSTREXP(32); ! FULL 32 BIT ADDRESS
PB1(MMS2); ! IS STACKED
!
PPJ(0,16)
PB1(MES); ! DEAL WITH FALSE IE RESLN FAILED
%IF LAB#0 %THEN ENTER JUMP(JFW,LAB,B'11') %ELSE PPJ(JFW,12)
!
-> END %IF A(P)=2
%IF A(P+1)#CONCOP %THEN ERR=72 %AND ->ERROR
P2=P+1; P=P2+1
%IF A(P)=3 %THEN P=P2 %AND ->RES
->ERROR %UNLESS A(P)=1
P=P+3 %AND SKIP APP %UNTIL A(P)=2
%IF A(P+1)=1 %THEN P=P2 %AND ->RES
P1=P+1
P=P2+2
CNAME(3)
PB1(MMS); ! LMAX TO MSTACK
PB1(REPL2); ! 2 COPIES OF VRT ADDR
DFETCH(2,RBASE,W+4)
DFETCH(2,RBASE,W+6)
PB3(SBI,REPL,REPL); ! LENGTH OF FRAGMENT
PB2(MMS2,MMS); ! 3 COPIES TO MSTACK
PB1(LDC0+1); ! DEST FOR MVBYTES
DFETCH(4,RBASE,W)
DFETCH(2,RBASE,W+6)
PB2(LDC0+1,ADI); ! SOURCE FOR MOVE
PB1(MES); ! LENGTH ON TOP
PB3(STLATE,X'63',MVBW); ! ASSIGN ALL BAR LENGTH
PB4(LDC0,MES,TLATE3,STCH); ! ASSIGN LENGTH
PB2(MES2,LEQI)
PPJ(JFW,9); ! CAPACITY EXCEEDED
P=P1
END:
RETURN WSP(W,4)
P=P+1
%END
%ROUTINE CEND (%INTEGER KKK)
!***********************************************************************
!* DEAL WITH ALL OCCURENCES OF '%END' *
!* KKK=PTYPE(>=X'1000') FOR ROUTINES,FNS AND MAPS *
!* KKK=0 FOR ENDS OF '%BEGIN' BLOCKS *
!* KKK=1 FOR '%ENDOFPROGRAM' *
!* %ENDOFPROGRAM IS REALLY TWO ENDS. THE FIRST IS THE USERS *
!* AND THE SECOND IS PERMS. KKK=2 FOR A RECURSIVE CALL OF CEND *
!* ON END OF PROGRAM TO DEAL WITH THE %END CORRESPONDING TO *
!* THE %BEGIN COMPILED IN THE INITIALISATION SEQUENCE *
!***********************************************************************
%INTEGER KP,JJ,BIT,ID,ML
%ROUTINESPEC DTABLE(%INTEGER LEVEL)
%RECORD(RTDICTF) RTDICT
SET LINE %UNLESS KKK=2
BIT=1<<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
!
! NOW PLANT THE BLOCK EXIT SEQUENCE
!
%IF KKK&X'3FFF'=X'1000' %AND LAST INST=0 %THEN %C
JJ=UCONSTTRIP(RTXIT,X'51',0,0)
JJ=UCONSTTRIP(XSTOP,X'51',0,0) %IF KKK=1 %AND LAST INST=0;! %STOP AT %ENDOFPROGRAM
%IF KKK=0 %THEN %START; ! BEGIN BLOCK EXIT
%IF PARM_TRACE=1 %THEN %START; ! RESTORE DIAGS POINTERS
JJ=UCONSTTRIP(RDPTR,X'51',0,LEVEL-1)
%FINISH
JJ=CURRINF_NMDECS>>14
%IF JJ#0 %THEN %START; ! ARRAYS TO BE UNDECLARED
JJ=UCONSTTRIP(RSPTR,X'51',0,JJ)
%FINISH
%FINISH
FORCE TRIPS
NMAX=N %IF N>NMAX; ! WORK SPACE POINTER
!
! CLEAR OUT THE LABEL LIST FAULTING LABELS WITH JUMPS OUTSTANDING
! AS NOT SET AND COMMENTING ON LABELS NOT USED
!
%WHILE CURRINF_LABEL#0 %CYCLE
POP(CURRINF_LABEL,I,J,KP)
%IF J&X'FFFF'#0 %THEN %START
J=J&X'FFFF'
%IF 0<KP<=MAX ULAB %THEN FAULT(11,FROM3(J),KP)
CLEAR LIST(J)
%FINISH %ELSE %START
%IF I&LABUSEDBIT=0 %AND KP<MAX ULAB %THEN WARN(3,KP)
%FINISH
%REPEAT
!
%CYCLE JJ=0,1,4
CLEAR LIST(CURRINF_AVL WSP(JJ));! RELEASE TEMPORARY LOCATIONS
%REPEAT
!
RTDICT=0
RTDICT_DIAGS=SSTL>>1
DTABLE(LEVEL); ! OUTPUT DIAGNOSTIC TABLES
%WHILE CURRINF_UNATT FORMATS#0 %CYCLE
POP(CURRINF_UNATT FORMATS,I,J,JJ)
CLEAR LIST(I)
CLEAR LIST(J)
CLEAR LIST(JJ)
%REPEAT
!
! NOW CLAIM THE STACK FRAME BY FILING THE ASF IN THE BLOCK ENTRY CODING
!
NMAX=(NMAX+7)&(-8)
%IF KKK=2 %THEN %RETURN
%IF KKK>=X'1000' %OR KKK=1 %THEN %START
ML=CURRINF_M-1
%IF KKK=1 %THEN ID=X'80000000' %AND JJ=ADDR(MAINEP) %ELSE %C
ID=FROM2(TAGS(ML))&X'FFFF' %AND JJ=WORKA_DICTBASE+WORD(ML)
PTYPE=KKK; UNPACK
RTDICT_PS=0
%IF ROUT#0 %THEN %START
%IF NAM#0 %OR TYPE=5 %THEN RTDICT_PS=4 %C
%ELSE RTDICT_PS=(BYTES(PREC)+1)&(-2)
%FINISH
RTDICT_PS=(CURRINF_PSIZE-RTDICT_PS)//2
RTDICT_RPS=CURRINF_PSIZE//2
RTDICT_LTS=NMAX//2-RTDICT_RPS
RTDICT_ENTRY=CURRINF_ENTRYAD
RTDICT_EXIT=CA-1
RTDICT_LL=RLEVEL
%IF RLEVEL=1 %THEN ID=ID!1<<16;! FLAG AS EXTERNAL
QPUT(11,ID,ADDR(RTDICT),JJ)
%IF CA>30000 %AND WORKA_PLABS(1)<30000 %THEN REPEAT PROLOGUE
%FINISH
!
! RETURN TO PREVIOUS LEVEL PROVIDED THERE IS A VALID ONE !
!
%UNLESS LEVEL>2 %OR (LEVEL=2 %AND PARM_CPRMODE=2) %THEN %START
%IF KKK=1 %AND LEVEL=2 %THEN KKK=2 %ELSE FAULT(109,0,0)
! SHOULD BE CHKD IN PASS1
%FINISH
LEVEL=LEVEL-1
CURRINF==LEVELINF(LEVEL)
%IF KKK>=X'1000' %THEN %START
RLEVEL=CURRINF_RBASE
RBASE=RLEVEL
%FINISH
!
! RESTORE INFORMATION ABOUT THE (NEW) CURRENT LEVEL
!
NMAX=CURRINF_SNMAX %IF KKK>=X'1000'
N=CURRINF_SN
%IF KKK=2 %THEN CEND(KKK); ! ROUND AGAIN FOR 'ENDOFPROGRAM'
!
! COMPLETE THE JUMP AROUND ALL NON-EXTERNAL ROUTINES EXCEPT WHEN
! %TRUSTEDPROGRAM IS IN OPERATION.
!
%IF KKK>=X'1000' %AND PARM_COMPILER=0 %AND %C
(RLEVEL>0 %OR PARM_CPRMODE#2) %THEN %START
JJ=NEXTP+6
%UNLESS A(NEXTP+5)=11 %AND A(JJ+FROMAR2(JJ))=2 %START
JJ=ENTER LAB(CURRINF_JROUND,0)
CURRINF_JROUND=0
%FINISH
%FINISH
%RETURN
!
! LAYOUT OF DIAGNOSIC TABLES
! ****** ** ********* ******
!
! THE BOUND FIELD OF PLT DESCRIPTOR STORED AT (LNB+3 & LNB+4) IF
! USED TO CONTAIN A DISPLACEMENT RELATIVE TO THE START OF SST OF THE
! DIAGNOSTIC TABLES FOR THE BLOCK OR ROUTINE BEING EXECUTED.
! A ZERO BOUND MEANS NO DIAGNOSTIC REQUESTED.(NB THIS MAY MEAN A DUMMY
! FIRST WORD IN THE SST).
! THE ABSOLUTE ADDRESS OF THE SST FOR THE CURRENT CODE SEGMENT WILL
! ALWAYS BE FOUND IN THE STANDARD 10 WORDS OF THE GLA/PLT
!
! FORM OF THE TABLES:-
!
! WORD 0 = LINE OF RT IN SOURCE PROG <<16 ! LINE NO POSN(FROM LNB)
! WORD 1 = (12 LANG DEPENDENT BITS)<<18 ! ENVIRONMENT
! ( TOP 2 BITS OF LANG DEPENDENT HAS LITL FROM PTYPE)
! ( BOTTOM 4 BITS HAVE TEXTUAL LEVEL)
! WORD 2 = DISPLAY POSN (FROM LNB)<<16 ! RT TYPE INFO
! WORD 3 = ZERO FOR BLKS OR STRING(<=11BYTES) BEING THE
! RT NAME. THIS WILL TAKE WORDS 4 AND 5 IF NEEDED
! WORD 6 = LANGUAGE DEPENDENT INFO . IMP ON CONDITIONS ETC
!
! THE REST IS MADE UP OF VARIABLE ENTRIES AND THE SECTION IS TERMINATED BY
! A WORD OF X'FFFFFFFF'
!
! EACH VARIABLE ENTRY CONSISTS OF THE VARIABLE WORD FOLLOWED BY
! THE VARIABLE NAME AS A STRING. THE WORD CONSISTS OF
! BITS 2**31 TO 2**20 TYPE INFORMATION (MAY BE LANGUAGE DEPENDENT
! BIT 2**19 =0 UNDER LNB =1 IN GLA
! BITS 2**18 TO 2**0 DISPLACEMENT FROM LNB(GLA) IN BYTES
!
!
! THE ENVIRONMENT IS A POINTER (RELATIVE TO SST) OF THE NEXT OUTERMOST
! BLOCK OR A POINTER TO GLOBAL OWNS, EXTERNAL OR COMMON AREAS
! A ZERO MEANS NO ENCLOSING BLOCK. WORD1=WORD3=0 IS AN
! IMP MAIN PROGRAM AND WILL TERMINATE THE DIAGNOSTICS.
!
%ROUTINE DTABLE(%INTEGER LEVEL)
!***********************************************************************
!* THIS ROUTINE LOOKS AT THE DECLARATIONS FOR THE CURRENT LEVEL & *
!* SETS UP THE SEGMENT OF SHARABLE SYMBOL TABLES TO DESCRIBE THEM.*
!* FOR MAIN PROGRAMS OR EXTERNAL ROUTINES THE 'GLOBAL' VARIABLES *
!* (IF ANY) ARE ALSO INCLUDED. *
!***********************************************************************
%CONSTINTEGER DAREA=6
%STRING(31) RT NAME
%STRING(11) LOCAL NAME
%RECORD(LISTF)%NAME LCELL
%CONSTINTEGER LARRROUT=X'F300'
%INTEGER DPTR,LNUM,ML,KK,JJ,Q,DEND,BIT,S1,S2,S3,S4,LANGD,II
%INTEGERARRAY DD(0:500); ! BUFFER FOR SEGMENT OF SST
!
! FILL ALL OUTSTANDING REFERENCES TO THIS DIAGS BLOCK
!
BIT=1<<LEVEL
LANGD=KKK>>14<<30!LEVEL<<18; ! GET LITL FROM PTYPE
%WHILE CURRINF_RAL#0 %CYCLE
POP(CURRINF_RAL,Q,JJ,KK)
%IF Q=1 %THEN %START
PLUG(1,JJ+2,CODEP_CAS(DAREA)>>9&255,1)
PLUG(1,JJ+1,CODEP_CAS(DAREA)>>1&255,1)
%FINISH %ELSE PLUG(Q,JJ,KK!CODEP_CAS(DAREA),4)
%REPEAT
PUSH(LEVELINF(LEVEL-1)_RAL,DAREA,CODEP_CAS(DAREA)+4,LANGD) %IF PARM_TRACE#0
DD(0)=CURRINF_L<<16!(CURRINF_DIAGINF+2)
DD(1)=LANGD
DD(2)=4*RBASE!CURRINF_FLAG&X'3FFF'
ML=CURRINF_M; ! ROUTINE NAME(=0 FOR %BEGIN)
%IF ML#0 %THEN ML=WORD(ML-1); ! IF NOT BLOCK GET DIRPTR
LNUM=BYTEINTEGER(WORKA_DICTBASE+ML); ! LENGTH OF THE NAME
DPTR=4; DEND=0
%IF LNUM=0 %THEN DD(3)=0 %ELSE %START
Q=WORKA_DICTBASE+ML
RT NAME<-STRING(Q); ! FOR RTS MOVE IN 1ST 32 CHARS
LNUM=BYTE INTEGER(ADDR(RT NAME))
STRING(ADDR(DD(3)))=RTNAME; ! AND UPDATE POINTER PAST
%IF ON PERQ=NO %AND PARM_TRACE#0 %THEN %C
QPUT(9,DAREA,CODEP_CAS(DAREA)+12,LNUM+1)
DPTR=DPTR+LNUM>>2; ! ACTUAL NO OF CHARS
%FINISH
DD(DPTR)=CURRINF_ONWORD; ! ON CONDITION WORD
DPTR=DPTR+1
JJ=CURRINF_NAMES
%WHILE 0<=JJ<X'3FFF' %CYCLE
LCELL==ASLIST(TAGS(JJ))
! OBTAIN NEXT NAME FORM DECLNS
!
! GET ONLY THE MINIMUM OF DETALS NECESSARY
!
S1=LCELL_S1; S2=LCELL_S2
S3=LCELL_S3; S4=LCELL_LINK
LCELL_LINK=ASL; ASL=TAGS(JJ)
TAGS(JJ)=S4&X'3FFFF'
PTYPE=S1>>16; TYPE=PTYPE&15
!
! FAULT ALL UNUSED NAMES EXCEPT CONSTINTEGERS&REALS
!
%IF (TYPE>2 %OR PTYPE&X'FF00'#X'4000') %C
%AND S1&X'C000'=0 %THEN WARN(2,JJ)
I=S1>>4&15
J=S1&15
K=S3>>16
!
! ALLOW OWNS (LITL=0) AND EXTERNALS (=2) NOT CONSTS(=1) OR EXTRINSIC(=3)
!
%IF PARM_DIAG#0 %AND PTYPE&X'7300'<=X'200' %AND DPTR<497 %C
%AND (TYPE=1 %OR TYPE=2 %OR TYPE=5) %START
Q=WORKA_DICTBASE+WORD(JJ); ! ADDRESS OF NAME
%IF I=0 %THEN II=1 %ELSE II=0; ! GLA OR LNB BIT
DD(DPTR)=PTYPE<<20!II<<18!K
LOCAL NAME<-STRING(Q); ! TEXT OF NAME FROM DICTIONARY
LNUM=BYTE INTEGER(ADDR(LOCAL NAME))
STRING(ADDR(DD(DPTR))+4)=LOCAL NAME;! MOVE IN NAME
%IF ON PERQ=NO %AND PARM_TRACE#0 %THEN %C
QPUT(9,DAREA,CODEP_CAS(DAREA)+4*DPTR+4,LNUM+1)
DPTR=DPTR+(LNUM+8)>>2
%FINISH
%IF J=15 %AND PTYPE&X'3000'#0 %AND S1&X'C000'#0 %THEN %C
FAULT(28,0,JJ)
! SPEC&USED BUT NO BODY GIVEN
%IF J=15 %AND TYPE=4 %THEN FAULT(62,0,JJ)
%IF PTYPE&X'3000'#0 %OR TYPE=4 %OR TYPE=6 %THEN %C
CLEAR LIST(K) %ELSE %START
%IF I#0 %AND K>4095 %AND PTYPE&LARRROUT=0 %AND TYPE#7 %C
%THEN WARN(5,JJ)
%FINISH
JJ=S4>>18
%REPEAT
DD(DPTR)=-1; ! 'END OF SEGMENT' MARK
DPTR=DPTR<<2+4
%IF PARM_TRACE=1 %THEN %START
QPUT(40+DAREA,DPTR,CODEP_CAS(DAREA),ADDR(DD(0)));! ADD TO SHARABLE SYM TABS
CODEP_CAS(DAREA)=CODEP_CAS(DAREA)+DPTR
%FINISH
%END; ! OF ROUTINE DTABLE
%END
%ROUTINE DECLARE SCALARS(%INTEGER PERMIT,XTRA)
!***********************************************************************
!* THIS ROUTINE DECLARES A LIST OF SCALARS FROM INFORMATION *
!* IN THE GLOBAL VARIABLES ROUT,NAM,ARR,PREC,TYPE & ACC.IT WORKS *
!* OUT ROUNDING FACTORS FOR ITSELF. *
!* P POINTS TO THE NAMELIST ON ENTRY AND IS UPDATED. *
!* PERMIT IS 0 IF DECLARING FORMAL PARAMETERS *
!***********************************************************************
%INTEGER INC,Q,SCHAIN,NPARMS,SCAL NAME,TYPEP
PACK(PTYPE); J=0
INC=ACC; SNDISP=0
%IF PTYPE=X'35' %THEN INC=(INC+1)&(-2)
%IF NAM#0 %AND ARR=0 %AND ROUT=0 %THEN %START
INC=4
%IF TYPE=5 %OR (PREC=3 %AND TYPE=1) %THEN INC=6
%FINISH
%IF NAM>0 %AND ARR>0 %THEN INC=8
%IF PTYPE=X'35' %AND (ACC<=0 %OR ACC>256) %THEN %C
FAULT(70,ACC-1,0) %AND ACC=255
N=(N+1)&(-2)
%UNTIL A(P-1)=2 %CYCLE; ! DOWN THE NAMELIST
SCAL NAME=FROM AR2(P)
%IF PTYPE=X'31' %AND PERMIT=0 %THEN N=N+1;! BYTE PARAMS
SCHAIN=N
KFORM=XTRA
%IF ROUT=1 %THEN %START
TYPEP=PTYPE; ! CHANGED BY CFPLIST!
Q=P
P=P+3 %UNTIL A(P-1)=2; ! TO FPP
CFPLIST(SCHAIN,NPARMS)
P=Q
J=13
KFORM=NPARMS; ! NO OF PARAMS OF FORMAL
ACC=N; ! DISPLACEMENT TO MIDCELL
PTYPE=TYPEP; UNPACK
%FINISH
P=P+3
%IF PTYPE=X'33' %THEN %START
SCHAIN=N
%FINISH
STORE TAG(SCAL NAME,SCHAIN)
N=N+INC
%REPEAT
%IF PERMIT#0 %THEN N=(N+1)&(-2); ! THIS IS NECESSARY !
%END
%INTEGERFN DOPE VECTOR(%INTEGER TYPEP,ELSIZE,MODE,IDEN, %INTEGERNAME ASIZE,LB)
!***********************************************************************
!* CONSTRUCTS THE DOPE-VECTOR FOR A CONSTANT ARRAY IN THE *
!* SHAREABLE SYMBOL TABLES AND RETURNS ITS DISPLACEMENT AS RESULT*
!* P IS TO ALT (MUST BE 1!) OF P<BPAIR> *
!* DOPE VECTOR CONSISTS OF :- *
!* @0 DWORD CONTAINING THE BASE OFFSET *
!* @4 WORD CONTAINING THE NO OF DIMENSIONS ND *
!* @6 WORD HOLDING SIZE (IN BYTES) OF A SINGLE ELEMENT *
!* @8 DWORD OF SIZE(IN WORDS OF ENTIRE ARRAY)FOR STACK ADJUSTMENT*
!* AND ND DWORD TRIPLES EACH CONSISTING OF:- *
!* UBI THE UPPER BOUND OF THE ITH DIMENSION *
!* LBI - THE LOWER BOUND OF THE ITH DIMENSION *
!* RI - THE STRIDE FOR THE ITH DIMENSION=(UBI-LBI+1) *
!* MODE=0 DV MUST BE CONST, MODE#0 CAN BE DYNAMIC *
!* MODE=-1 SPECIAL FOR CONSTARRAYNAMES 1D 0:INFINITY *
!***********************************************************************
%INTEGER I,JJ,K,ND,D,M0,HEAD,NOPS,TYPEPP,PIN,PTR
%RECORD(LISTF) %NAME LCELL
%INTEGERARRAY LBH,LBB,UBH,UBB(0:12)
%INTEGERARRAY DV(0:39); ! ENOUGH FOR 12 DIMENSIONS
ND = 0; NOPS = 0; TYPEPP = 0; PIN = P
M0 = 1
%IF MODE=-1 %THENSTART
ND = 1; DV(4) = 0
M0 = X'7FFF'
DV(3) = M0
DV(5) = M0
ASIZE = M0
%FINISHELSESTART
%UNTIL A(P)=2 %CYCLE
ND = ND+1; P = P+4
FAULT(37,0,IDEN) %AND ND = 1 %IF ND>12
LBH(ND) = 0; LBB(ND) = 0
UBB(ND) = 0; UBH(ND) = 0
TORP(LBH(ND),LBB(ND),NOPS)
P = P+3
TYPEPP = TYPEPP!TYPE
TORP(UBH(ND),UBB(ND),NOPS)
TYPEPP = TYPEPP!TYPE
%REPEAT
P = P+1
->NONCONST %UNLESS TYPEPP=1 %AND NOPS&X'40040000'=0
!
! NOW ONE CAN WORK OUT AND FILL IN THE TRIPLES
!
PTR = 1
%CYCLE D = 1,1,ND
K = 3*D
EXPOP(LBH(PTR),LBB(PTR),NOPS,X'251')
EXPOPND_D = 0 %AND FAULT(41,0,0) %UNLESS %C
EXPOPND_FLAG<=1 %AND EXPOPND_PTYPE=X'51'
DV(K+1) = EXPOPND_D
EXPOP(UBH(PTR),UBB(PTR),NOPS,X'251')
EXPOPND_D = 10 %AND FAULT(41,0,0) %UNLESS %C
EXPOPND_FLAG<=1 %AND EXPOPND_PTYPE=X'51'
JJ = EXPOPND_D
DV(K) = JJ
DV(K+2) = JJ-DV(K+1)+1
FAULT(38,1-DV(K+2),IDEN) %UNLESS JJ>=DV(K)
M0 = M0*DV(K+2)
PTR = PTR+1
%REPEAT
ASIZE = M0*ELSIZE
%FINISH
!
! CALCULATE THE OFF SET OF A(FIRST,..) FROM A(0,..)
!
LB = DV(4); I = 6
%WHILE I<=3*ND %CYCLE
LB = LB+DV(I+1)*DV(I-1)
I = I+3
%REPEAT
FAULT(39,0,IDEN) %IF ASIZE>X'FFFF'
DV(2) = (ASIZE+1)>>1
DV(0) = -LB
DV(1) = ND<<16!ELSIZE
K = 3*ND+2
J = ND; ! DIMENSIONALITY FOR DECLN
HEAD = DVHEADS(ND)
%WHILE HEAD#0 %CYCLE
LCELL == ASLIST(HEAD)
%IF LCELL_S2=ASIZE %START
%CYCLE D = 0,1,K
->ON %UNLESS DV(D)=CTABLE(D+LCELL_S1)
%REPEAT
SNDISP = 4*LCELL_S1
%RESULT = LCELL_S3
%FINISH
ON:
HEAD = LCELL_LINK
%REPEAT
SSTL = (SSTL+3)&(-4); ! ALIGN SHAREABLE ST
SNDISP = 4*WORKA_CONST PTR
I = SSTL
PUSH(DVHEADS(ND),WORKA_CONSTPTR,ASIZE,I)
%CYCLE D = 0,1,K
CTABLE(WORKA_CONST PTR) = DV(D)
WORKA_CONST PTR = WORKA_CONST PTR+1
%IF ONPERQ=NO %THEN DV(D) = DV(D)>>16!DV(D)<<16
%REPEAT
%IF WORKA_CONST PTR>WORKA_CONST LIMIT %THEN FAULT(102,WORKA_WKFILEK,0)
QPUT(44,4*(K+1),SSTL,ADDR(DV(0)))
SSTL = SSTL+K*(K+1)
WAYOUT:
%IF MODE=-1 %THENRESULT = I; ! NO EXPRESSION CELLS TO RETURN
%RESULT = I
NONCONST: ! NOT A CONST DV
J = ND; I = -1; SNDISP = -1
LB = 0; ASIZE = ELSIZE
%IF MODE=0 %THEN FAULT(41,0,0) %ELSE P = PIN
->WAYOUT
%END
%ROUTINE DECLARE ARRAYS(%INTEGER FORMAT,FINF)
!***********************************************************************
!* FORMAT=1 FOR 'ARRAYFORMAT' =0 OTHERWISE *
!* FINF>0 FOR RECORD FORMAT INFORMATION =0 OTHERWISE *
!* P IS AT P<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,QQ,CDV,LWB,
PTYPEPP,JJJ,JJ,TRIP1,TRIP2
%RECORD(RD) OPND1,OPND2,OPND3
%RECORD(TRIPF)%NAME CURRT
%INTEGERARRAY BTRIPS(0:12,0:2)
%IF CURRINF_FLAG=0 %AND CURRINF_NMDECS>>14=0 %START
JJJ=UTEMPTRIP(SSPTR,X'41',0,N); ! SAVE THE STACK POINTER
CURRINF_NMDECS=CURRINF_NMDECS!N<<14
N=N+2
%FINISH
ARRP=2*FORMAT+1; ARR=ARRP; PACK(PTYPEP)
ELSIZE=ACC
START:NN=1; P=P+1; ! NO OF NAMES IN NAMELIST
PP=P; CDV=0; PTYPEPP=PTYPEP
P=P+3 %AND NN=NN+1 %WHILE A(P+2)=1
P=P+3
DVDISP=DOPE VECTOR(TYPE,ELSIZE,1,FROMAR2(PP),TOTSIZE,LWB)
ND=J
->CONSTDV %UNLESS DVDISP<0
!
! NORMAL CASE - PLANT CODE TO SET UP DOPE-VECTOR AT RUN TIME
!
DVF=1; TOTSIZE=X'FFFF'
N=(N+3)&(-4); ! MAY BE BENEFITS IN WORD ALIGNMENT
DVDISP=N; ! DVDISP IS D-V POSITION
N=N+12*ND+12; ! CLAIM SPACE FOR THE D-V
OPND1_S1=X'41'<<16!LOCALIR
OPND1_D=RBASE<<16!DVDISP+4
OPND2_S1=X'41'<<16!SCONST
OPND2_D=ND
TRIP1=BRECTRIP(LASS,X'41',0,OPND1,OPND2); ! ASSN DIMEN->DVDIPS+4
OPND1_D=RBASE<<16!DVDISP+6
OPND2_D=ELSIZE
TRIP1=BRECTRIP(LASS,X'41',0,OPND1,OPND2); ! ASSN ELSIZE-> DVDISP+6
!
%CYCLE II=1,1,ND
P=P+1
QQ=DVDISP+12*II; ! TRIPLE FOR IITH DIMENSION
%CYCLE JJ=0,1,1; ! LOWER&UPPER BNDS
CSEXP(X'51')
OPND1_S1=X'51'<<16!LOCALIR
OPND1_D=RBASE<<16!(QQ+4-4*JJ); ! BPAIRS BACKWARD FOR PERQ!
%IF JJ=0 %AND(EXPOPND_FLAG>0 %OR EXPOPND_D#0) %THEN DVF=0
! BASE OFFSET NOT ZERO
TRIP1=BRECTRIP(LASS,X'51',0,OPND1,EXPOPND)
BTRIPS(II,JJ)=TRIP1
%REPEAT
OPND1_S1=X'51'<<16!REFTRIP
OPND1_D=BTRIPS(II,1); ! UPPER BND
OPND2_S1=X'51'<<16!REFTRIP
OPND2_D=BTRIPS(II,0)
OPND1_D=BRECTRIP(SUB,X'51',0,OPND1,OPND2); ! UB-LB
OPND2_S1=X'51'<<16!SCONST
OPND2_D=1
OPND1_D=BRECTRIP(ADD,X'51',0,OPND1,OPND2); ! UB-LB+1
OPND2_S1=X'51'<<16!LOCALIR
OPND2_D=RBASE<<16!(QQ+8)
BTRIPS(II,2)=BRECTRIP(LASS,X'51',0,OPND2,OPND1)
%IF II=1 %THEN TRIP2=BTRIPS(II,2) %ELSESTART
OPND1_S1=X'51'<<16!REFTRIP
OPND1_D=TRIP2
OPND2_S1=X'51'<<16!REFTRIP
OPND2_D=BTRIPS(II,2)
TRIP2=BRECTRIP(MULT,X'51',0,OPND1,OPND2)
%FINISH
%REPEAT
P=P+1
!
! WORK OUT TOTAL SIZE IN WORDS. TRIP2 HAS NO OF ELEMENTS
!
OPND1_D=TRIP2
OPND2_S1=X'51'<<16!SCONST
%IF ELSIZE&1#0 %THEN OPND2_D=ELSIZE %ELSE OPND2_D=ELSIZE>>1
OPND1_D=BRECTRIP(MULT,X'51',0,OPND1,OPND2)
%IF ELSIZE&1#0 %START; ! ROUND UP TO NEXT BUT ONE WORD
OPND2_D=1
OPND1_D=BRECTRIP(ADD,X'51',0,OPND1,OPND2)
OPND2_D=-1
OPND2_S1=X'41'<<16!SCONST
OPND1_D=BRECTRIP(RSHIFT,X'51',0,OPND1,OPND2)
%FINISH
OPND2_S1=X'51'<<16!LOCALIR
OPND2_D=RBASE<<16!(DVDISP+8)
JJ=BRECTRIP(LASS,X'51',0,OPND2,OPND1)
SNDISP=0; ! DV NOT AVAILABLE AT COMPILETIME
%IF DVF=1 %THENSTART
LWB=0
%IF FORMAT=0 %THEN PTYPEPP=PTYPEP+256
OPND2_S1=X'51'<<16!SCONST
OPND2_D=0; ! ZERO BASE OFFSET
%FINISHELSESTART
!***********************************************************************
!* FIND THE OFFSET OF A(0...) FROM A(FIRST...) BY COMPUTING *
!* THE OFFSET OF A(FIRST...) FROM A(0...) AND NEGATING *
!***********************************************************************
OPND2_S1=X'51'<<16!REFTRIP
OPND3_S1=X'51'<<16!REFTRIP
OPND1_S1=X'51'<<16!REFTRIP
OPND2_D=BTRIPS(ND,0); ! LB OF TOP DIMEN
%CYCLE JJ=ND,-1,2
OPND3_D=BTRIPS(JJ,0)
OPND1_D=BTRIPS(JJ-1,2)
OPND1_D=BRECTRIP(MULT,X'51',0,OPND1,OPND3)
OPND2_D=BRECTRIP(ADD,X'51',0,OPND1,OPND2) %UNLESS JJ=ND
%REPEAT
OPND2_D=URECTRIP(LNEG,X'51',0,OPND2)
%FINISH
OPND1_S1=X'51'<<16!LOCALIR
OPND1_D=RBASE<<16!DVDISP
OPND2_D=BRECTRIP(LASS,X'51',0,OPND1,OPND2)
->DECL
CONSTDV: ! ONE DIMENSION - CONSTANT BOUNDS
DVF=1; CDV=1
%IF LWB=0 %AND FORMAT=0 %THEN PTYPEPP=PTYPEP+256
SNDISP=SNDISP>>2
! SET ARR=2 IF LWB=ZERO
%IF PARM_COMPILER#0 %AND LWB#0 %THEN FAULT(99,0,0)
DECL: ! MAKE DECLN - BOTH WAYS
J=ND
PTYPE=PTYPEPP; UNPACK
%CYCLE JJJ=0,1,NN-1; ! DOWN NAMELIST
CURRT==TRIPLES(UCONSTTRIP(DARRAY,X'61',0,
CDV<<31!JJJ<<24!(NN-1)<<16!DVDISP))
CURRT_OPND1_XTRA=N
ACC=ELSIZE; ! RESET ACC AFTER DV CMPLD
KFORM=FINF; ! FORMAT INFORMATION
K=FROM AR2(PP+3*JJJ)
STORE TAG(K,N)
JJ=UCONSTTRIP(ASPTR,X'51',0,CDV<<31!SNDISP<<16!DVDISP) %IF FORMAT=0
N=N+8
%REPEAT
P=P+1; ! PAST REST OF ARRAYLIST
%IF A(P-1)=1 %THEN ->START
%RETURN
%END
%ROUTINE CLT
!***********************************************************************
!* DEAL WITH PHRASE TYPE AND SET PREC,TYPE & ACC *
!* ONLY PROBLEM ARE STRINGS WHICH HAS OPTIONAL MAX LENGTH ALSO *
!* RECORD WHICH HAVE A FORMAT *
!* P ON PHRASE TYPE AT ENTRY - TO NEXT PHRASE AT EXIT. *
!***********************************************************************
%CONSTBYTEINTEGERARRAY TYPEFLAG(0:8)=0, %C
X'51',X'52',LRLPT,X'31',X'35',
X'41'(2),X'33';
%INTEGER ALT,PTYPEP,I
ALT=A(P)
TYPE=TYPEFLAG(ALT)
%IF ALT=4 %OR ALT=6 %OR ALT=7 %THEN P=P+1
PREC=TYPE>>4
TYPE=TYPE&7
P=P+1
ACC=BYTES(PREC)
PACK(PTYPEP); ! PRESERVE ALL COMPONENT
! BEFORE CALLINT INTEXP ETC
%IF TYPE=5 %THEN %START; ! P<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,X'41')#0 %THEN FAULT(41,0,0)
ACC=I+1
PTYPE=PTYPEP; UNPACK
%FINISH %ELSE ACC=0 %AND P=P+2
%FINISH %ELSE ACC=0 %AND P=P+1
%FINISH
KFORM=0
%IF TYPE=3 %THEN KFORM=CFORMATREF %AND PTYPE=PTYPEP %AND UNPACK
%END
%ROUTINE CQN(%INTEGER P)
!***********************************************************************
!* SET NAM & ARR FROM ALTERNATIVE OF PHRASE <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(BITFORM)%NAME BCELL
%RECORD(LISTF)%NAME LCELL
OLDLINE=0
LCELL==ASLIST(HEAD)
BASEPT=LCELL_S1
LB=LCELL_S2
UB=LCELL_S3
HEAD=LCELL_LINK
BCELL==ASLIST(HEAD)
%UNLESS LB<=LAB<=UB %THEN FAULT(50,LAB,FNAME) %AND %RESULT=0
Q=LAB-LB
%WHILE Q>=96 %%CYCLE
HEAD=BCELL_LINK
BCELL==ASLIST(HEAD)
Q=Q-96
%REPEAT
!
! ASLIST(HEAD) IS THE START OF 96 BIT ENTRY IN THE BIT LIST
! CHECK BIT NO Q TO SEE IF LABEL ALREADY SET AND THEN SET BIT Q
!
QQ=Q>>5; ! RIGHT WORD
Q=Q&31; JJJ=1<<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
QQ=BASEPT+(LAB-LB)*2; ! REL POSITION OF LABEL
Q=CA-QQ; ! SELF RELATIVE PTR
%IF Q>X'7FFF' %THEN FAULT(98,0,0)
PLUG(1,QQ,Q,1)
PLUG(1,QQ+1,Q>>8,1)
%RESULT=0
%END
%ROUTINE CRSPEC (%INTEGER M)
!***********************************************************************
!* MODE=0 FOR NORMAL ROUTINE SPEC *
!* MODE=1 FOR EXTERNAL(ETC) ROUTINE SPECS XREF NEEDED *
!* P ON ENTRY TO P(RT) IN (RT)(MARK)(%SPEC')(NAME)(FPP) *
!***********************************************************************
%INTEGER KK,JJ,TYPEP,OPHEAD,NPARMS,AXNAME
LITL=EXTRN&3
%IF A(P)=1 %THEN %START; ! P<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=WORKA_DICTBASE+WORD(KK)
JJ=0
P=P+3
%IF A(P-1)=1 %THEN AXNAME=ADDR(A(P)) %AND P=P+A(P)+1
CFPLIST(OPHEAD,NPARMS)
%IF M=1 %THEN %START
! CXREF(XNAME,PARM_DYNAMIC!(EXTRN//3),2,JJ); ! %STSTEM & %EXTERNAL =STATIC
! %DYNAMIC = DYNAMIC
JJ=AXNAME
%FINISH %ELSE %START
JJ=WORKA_RTCOUNT
WORKA_RTCOUNT=WORKA_RTCOUNT+1
%FINISH
%IF M=0 %AND RLEVEL=0 %START
%IF PARM_CPRMODE=0 %THEN PARM_CPRMODE=2
%IF PARM_CPRMODE#2 %THEN FAULT(56,0,KK)
%FINISH
J=15-M; PTYPE=TYPEP
KFORM=NPARMS
SNDISP=JJ>>16
ACC<-JJ&X'FFFF'
STORE TAG(KK,OPHEAD)
%END
%ROUTINE CFPLIST(%INTEGERNAME OPHEAD,NPARMS)
!***********************************************************************
!* COMPILE A FORMAL PARAMETER PART INTO A LIST OF PARAMETER TYPES *
!* P(FPP)='('{(HOLE)(FPDEL)(NAMELIST)(MARK)}*')',0. *
!* *
!* THE LIST OF PARAMETER LOOKS LIKE:- *
!* S1 = PTYPE FOR PARAM<<16! DIMENSION (DIMEN DEDUCED LATER) *
!* S2 = ACC <<16 ! SPARE *
!* S3 = 0 (RESERVED FOR FPP OF RTS) *
!* *
!* ON ENTRY P IS AT ALT OF FPP (WHICH MAY BE NULL) *
!***********************************************************************
%INTEGER OPBOT, PP
OPHEAD=0; OPBOT=0
NPARMS=0; ! ZERO PARAMETERS AS YET
%WHILE A(P)=1 %CYCLE; ! WHILE SOME(MORE) FPS
PP=P+1+FROMAR2(P+1); ! TO NEXT FPDEL
P=P+3; ! TO ALT OF FPDEL
CFPDEL; ! GET TYPE & ACC FOR NEXT GROUP
%UNTIL A(P-1)=2 %CYCLE; ! DOWN <NAMELIST> FOR EACH DEL
BINSERT(OPHEAD,OPBOT,PTYPE<<16,ACC<<16,0)
NPARMS=NPARMS+1
P=P+3
%REPEAT
P=PP
%REPEAT
P=P+1
%END
%ROUTINE CFPDEL
!***********************************************************************
!* SET UP PTYPE & ACC FOR A FORMAL PARAMETER DEFINITION *
!* P<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=8
->PK
FP(3): ! %NAME
ACC=8; NAM=1
ROUT=0; TYPE=0
ARR=0; PREC=0
PK: PACK(PTYPE)
%END
%ROUTINE DIAG POINTER(%INTEGER LEVEL)
!***********************************************************************
!* PLANT CODE TO UPDATE THE DIAGNOSTIC POINTER. SINCE THE *
!* VALUE WILL NOT BE KNOWN TILL THE DTABLE IS GENERATED PLANT *
!* NO-OPS AND OVERWRITE IN ROUTINE DTABLE *
!***********************************************************************
%IF PARM_TRACE#0 %THEN %START
PUSH(CURRINF_RAL,1,CA,0)
PBW(LDCW,256); ! 256 ARBITARY BUT 0 IS OPTIMISED!
%FINISH
%END
%ROUTINE RHEAD(%INTEGER RTNAME,AXNAME)
!***********************************************************************
!* COMPILES CODE FOR BLOCK AND ROUTINE ENTRY *
!* RTNAME IS THE RT/FN/MAP NAME (=-1 FOR %BEGIN BLOCKS) *
!* XNAME IS THE EXTERNAL NAME (="" FOR INTERNALS&BLOCKS *
!* ACTIONS INCLUDE PLANTING JUMPS ROUND RT BODY AND *
!* DEFINING EXTERNAL ENTRIES AS WELL AS PLANTING ENTRY CODE *
!***********************************************************************
%INTEGER W3
%RECORD(TRIPF)%NAME CURRT
%RECORD(LISTF)%NAME LCELL
CURRINF_SNMAX=NMAX; CURRINF_SN=N
%IF RTNAME>=0 %THEN %START; ! SECTION FOR ROUTINES
LCELL==ASLIST(TAGS(RTNAME))
!
! FIRST JUMP ROUND BODY UNLESS AT TOP LEVEL OR IN COMPILER
! OR A JUMP IS ALREADY OUTSTANDING AT THIS LEVEL
! MUST DO THIS HERE BEFORE LEVEL IS CHANGED OR LABEL LIST IS WRONG
!
%IF PARM_COMPILER=0 %AND LEVEL>1 %AND CURRINF_JROUND=0 %START
PLABEL=PLABEL-1
CURRINF_JROUND=PLABEL
ENTER JUMP(15,PLABEL,0)
%FINISH
RLEVEL=RLEVEL+1; RBASE=RLEVEL
%FINISH
LEVEL=LEVEL+1
CURRINF==LEVELINF(LEVEL)
CURRINF=0
CURRINF_RBASE=RBASE
CURRINF_NAMES=-1
CURRINF_DIAGINF=LEVELINF(LEVEL-1)_DIAGINF
FAULT(34, 0, 0) %IF LEVEL=MAX LEVELS
FAULT(105, 0, 0) %IF LEVEL>MAX LEVELS
!
! DEAL WITH EXTERNAL ENTRIES SO THAT THEY COME TO THIS POINT
! IN THE CODE. THE DESCRIPTORS SET UP ARE OF NO INTEREST TO THIS MODULE
! ONLY TO OTHER MODULES SO NO DETAILS OF THEN ARE RECORDED IN TAGS
!
%IF RTNAME<0 %THEN W3=0 %ELSE W3=RTNAME+1
CURRINF_L=LINE; CURRINF_M=W3
CURRINF_FLAG=PTYPE; ! CURRENT BLOCK TYPE MARKER
!
! TILL LOADER COPIES GLAP TO GLA MUST CALL A FRIG ROUTINE TO DO
! THIS ESSENTIAL AS SOON AS POSSIBLE IN ANYTHING EXTERNAL
!
CURRT==TRIPLES(UCONSTTRIP(RTHD,X'51',0,RTNAME))
CURRT_OPND1_XTRA=AXNAME
%END
%ROUTINE RDISPLAY(%INTEGER KK)
!***********************************************************************
!* SET UP OR COPY THE DISPLAY *
!* SINCE THIS IS IN REGISTERS ON 360 IT IS EASY *
!* ALSO CLAIM STACK SPACE AND SET DIAGNOSTIC POINTERS *
!***********************************************************************
%INTEGER TRIPNO
%IF KK>=0 %OR LEVEL=2 %START; ! DISPLAY NEEDED
! DONE BY THE QCODE CALL
CURRINF_PSIZE=N; ! REMEMBER PARAMETER SIZE FOR RTDICT
TRIPNO=UCONSTTRIP(RDSPY,X'51',0,N)
%FINISH
!
! IF IN DIAGNOSTIC MODE PLANT CODE TO SAVE THE LINE & ROUTINE NO OF
! THE CALLING ROUTINE AND SET UP THE NEW BLOCK/ROUTINE IDENT NO.
!
%IF PARM_TRACE#0 %START
%IF KK>=0 %OR LEVEL=2 %START; ! ROUTINE NEW AREA NEEDED
TRIPNO=UCONSTTRIP(RDAREA,X'51',0,N)
N=N+4
CURRINF_DIAGINF=N
N=N+4
%FINISH
TRIPNO=UCONSTTRIP(RDPTR,X'51',0,LEVEL)
DSTORE(2,RBASE,CURRINF_DIAGINF)
%FINISH
OLDLINE=0
SET LINE
!
! NORMALLY CODE IS PLANTED HERE TO CHECK PARAMETERS BUT I CANNOT
! SEE HOW TO DO THIS ON PERQ ARCHITECTURE. IT MAY BE IN THE QCODE ANYHOW
!
!
! CLAIM (THE REST OF) THE STACK FRAME
!
%IF KK>=0 %OR LEVEL=2 %START
NMAX=N
%FINISH
%END
%ROUTINE CUI(%INTEGER CODE)
!***********************************************************************
!* COMPILE AN UNCONDITIONAL INSTRN WHEREEVER IT OCCURS *
!* CODE=0 UNCONDITIOALLY,=1 AFTER %THEN, =2 AFTER %ELSE *
!***********************************************************************
%INTEGER MARKER,J,LNAME,TYPEP,PRECP,GWRDD,ALT,KK
%INTEGER HEAD1,BOT1,NOPS
%SWITCH SW(1:9)
REPORTUI=0
ALT=A(P)
->SW(ALT)
SW(1): ! (NAME)(APP)(ASSMNT?)
P=P+1; MARKER=P+FROMAR2(P)
%IF A(MARKER)=1 %THEN %START
J=P+2; P=MARKER+2
ASSIGN(A(MARKER+1),J)
%FINISH %ELSE %START
P=P+2
CNAME(0)
P=P+1
%FINISH
AUI: J=A(P); P=P+1
%IF J=1 %THEN CUI(CODE)
%RETURN
SW(2): ! -> (NAME)(APP)
CURRINF_NMDECS=CURRINF_NMDECS!1
CURR INST=1 %IF CODE=0
LNAME=FROM AR2(P+1)
J=A(P+3); P=P+4
%IF J=2 %THEN %START; ! SIMPLE LABEL
ENTER JUMP(15,LNAME,0)
REPORTUI=1
%FINISH %ELSE %START; ! SWITCH LABELS
COPY TAG(LNAME)
GWRDD=SNDISP; ! BYTE DISP OF CASEJUMP
%UNLESS OLDI=LEVEL %AND TYPE=6 %START
FAULT(4,0,LNAME); P=P-1; SKIP APP
%RETURN
%FINISH
CSEXP(X'41')
KK=GWRDD-(CA+2)
%IF KK>=-128 %THEN PB2(JMPB,KK) %ELSE PBW(JMPW,KK-1)
REPORTUI=1
%FINISH
%RETURN
SW(3): ! RETURN
FAULT(30,0,0) %UNLESS CURRINF_FLAG&X'3FFF'=X'1000'
P=P+1
RET: PB1(RETURN)
REPORT UI=1
CURR INST=1 %IF CODE=0
%IF CA>30000 %AND WORKA_PLABS(1)<30000 %THEN REPEAT PROLOGUE
%RETURN
SW(4): ! %RESULT(ASSOP)(EXPR)
PTYPE=CURRINF_FLAG&X'3FFF'; UNPACK
%IF PTYPE>X'1000' %AND A(P+1)#3 %THEN %START;! ASSOP #'->'
%IF A(P+1)=1 %AND NAM#0 %AND A(P+5)=4 %AND A(P+6)=1 %START
P=P+7; TYPEP=TYPE; PRECP=PREC; J=P
CNAME(4)
DSTORE(4,RLEVEL,0); ! INTO RESULT WORDS
FAULT(81,0,0) %UNLESS A(P)=2; P=P+1
FAULT(83,CURRINF_M-1,FROMAR2(J)) %C
%UNLESS TYPEP=TYPE %AND PRECP=PREC
->RET
%FINISH
%IF A(P+1)=2 %THEN %START; ! ASSOP='='
P=P+2
%IF NAM#0 %THEN TYPE=1; ! MAPS HAVE INTEGER RESULTS
%IF TYPE=5 %THEN %START
CSTREXP(32); ! FULL VIRTAD
DSTORE(4,RLEVEL,0)
%FINISH %ELSE %START
%IF PREC<4 %THEN PREC=4
%IF NAM=0 %THEN KK=PREC<<4!TYPE %ELSE KK=X'51'
CSEXP(KK)
DSTORE(BYTES(KK>>4),RLEVEL,0)
%FINISH; ->RET
%FINISH
%FINISH
FAULT(31,0,0)
P=P+2; SKIP EXP; ! IGNORE SPURIOUS RESULT
%RETURN
SW(5): ! %MONITOR (AUI)
PB1(LDC0); ! ERR=0
PB1(LDC0); ! EXTRA=0
PB4(LDAP,LDC0,MMS2,MMS2)
PB3(CALLXB,1,0)
GXREF(MDEP,0,0,CA-3)
P=P+1; ->AUI
SW(6): ! %STOP
KK=UCONSTTRIP(XSTOP,X'51',0,0)
P=P+1
CURR INST=1 %IF CODE=0
REPORTUI=1
%RETURN
SW(7): !'%SIGNAL'(EVENT')(N)(OPEXPR)
P=P+5
KK=INTEXP(J,X'41'); ! EVENT NO TO J
FAULT(26,J,0) %UNLESS KK=0 %AND 1<=J<=15
HEAD1=0; NOPS=0
PUSH(HEAD1,X'51'<<16!1,256*J,0); ! EVENT<<8 AS CONST
BOT1=HEAD1
%IF A(P)=1 %START; ! SUBEVENT SPECIFIED
PUSH(HEAD1,ANDL,0,0); ! OPERATOR &
PUSH(HEAD1,X'51'<<16!1,255,0); ! CONST=F'255'
P=P+4; TORP(HEAD1,BOT1,NOPS)
BINSERT(HEAD1,BOT1,ORL,0,0); ! OPERATOR !
NOPS=NOPS+2
%FINISH
EXPOP(HEAD1,BOT1,NOPS,X'51'); ! EVALUATE
%IF CURRINF_NMDECS&16 #0 %START; ! IN AN 'ON' GROUP
%IF CURRINF_FLAG<=2 %START; ! IN A BEGIN BLOCK
DIAGPOINTER(LEVEL-1); ! TO NEXT OUTER BLOCK
%FINISH %ELSE %START; ! 'ON IN A RT/FN/MAP
PB1(NOOP)
%FINISH
%FINISH
PPJ(0,2)
CURR INST=1 %IF CODE=0
REPORTUI=1; %RETURN
SW(8): ! %EXIT
SW(9): ! %CONTINUE
ALT=ALT&7; ! 0 FOR EXIT 1 FOR CONTINUE
%IF EXITLAB=0 %THEN FAULT(54+ALT,0,0) %AND %RETURN
KK=INTEGER(ADDR(EXITLAB)+4*ALT)
ENTER JUMP(15,KK&X'FFFFFF',B'10'!KK>>31)
REPORTUI=1
CURR INST=1 %IF CODE=0
%END
%ROUTINE CIFTHEN(%INTEGER MARKIU,MARKC,MARKUI,MARKE,MARKR,SKIP)
!***********************************************************************
!* THIS ROUTINE COMPILES CONDITIONAL EXPRESSIONS.IT REQUIRES THE *
!* FOLLOWING PARAMETERS TO BE SET TO THEIR A .R. ENTRY. *
!* MARKIU TO THE ENTRY FOR P(%IU) *
!* MARKC TO THE ENTRY FOR P(COND) *
!* MARKUI TO THE ENTRY FOR (FIRST OCCURRENCE OF) P(UI) *
!* MARKE TO THE ENTRY FOR P(ELSE') - =0 FOR BACKWARDS CONDITION *
!* MARKR TO ENTRY FOR P(RESTOFIU) - =0 FOR BACKWARDS CONDITION *
!***********************************************************************
%INTEGER ALTUI,CCRES,ELRES,THENLAB,ELSELAB,USERLAB,REPORT,START, %C
ELSEALT,K,CS
%CONSTINTEGER NULL ELSE=4
%SWITCH ESW(1:NULL ELSE)
SET LINE %UNLESS SKIP=YES
MARKIU=A(MARKIU); ! ALT OF IU 1=%IF,2=%UNLESS
PLABEL=PLABEL-1
THENLAB=PLABEL
START=0; CS=0; ! NO START IN CONDITION YET
CS=1 %IF STARSIZE>100; ! LONG JUMPS FOR COMPLEX STMTS
ELSELAB=0; ! MEANS NO ELSE CLAUSE
P=MARKC
%IF MARKR>0 %AND A(MARKR)<=2 %THEN %C
START=1 %AND CS=CHECK BLOCK(MARKR+1,MARKC);! '%START' OR '%THENSTART'
%IF MARKE#0 %AND LEVEL<2 %AND START=0 %THEN FAULT(57,0,0)
USERLAB=-1
%IF START#0 %THEN ALTUI=0 %ELSE ALTUI=A(MARKUI)
%IF ALTUI=2 %AND A(MARKUI+3)=2 %THEN %C
USERLAB=FROM AR2(MARKUI+1); ! UI = SIMPLE LABEL
%IF 8<=ALTUI<=9 %AND EXITLAB#0 %START; ! VALID EXIT
%IF ALTUI=8 %THEN USERLAB=EXITLAB %ELSE USERLAB=CONTLAB
%FINISH
!
%IF SKIP=YES %THEN %START; ! NO CODE NEEDED
%IF START#0 %START
P=MARKR+1
CSTART(2,1); ! NO CODE
MARKE=P
%FINISH
CCRES=1; ! NO CODE FOR ELSE
->ELSE
%FINISH
!
%IF USERLAB>=0 %THEN %START; ! FIRST UI IS'->'<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 ABORT; ! 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 ABORT
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 *
!***********************************************************************
%INTEGER L1,L2,L3,L4,CCRES,ELRES,FLINE,TRIP
%INTEGER FORNAME,INITP,REPMASK,FORPT,FORWORDS
%RECORD(RD) INITOPND,STEPOPND,FINALOPND,DIFFOPND,ZOPND,OPND
%RECORD(TRIPF) %NAME CURRT
%ROUTINESPEC FOREXP(%RECORD(RD) %NAME EOPND, %INTEGER TT)
%ROUTINESPEC VALIDATE FOR
%SWITCH SW(0:6)
P=MARKC
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)
ELRES=ENTER LAB(L3,B'011')
%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)
ELRES=ENTER LAB(L2,B'011')
WAYOUT: ! REMOVE LABELS NOT REQUIRED
REMOVE LAB(L1)
REMOVE LAB(L2)
REMOVE LAB(L3) %IF L3>0
%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
ELRES=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; P=INITP
COPY TAG(FORNAME)
FAULT(91,0,FORNAME) %UNLESS TYPE=1 %AND 4<=PREC<=5 %AND ROUT=0=ARR
FORPT=PTYPE&255; ! SAVE TYPE&PREC OF CONTROL
FORWORDS=WORDS(FORPT>>4); ! NO OF WORDS FOR TEMPS
WARN(4,FORNAME) %UNLESS I=RBASE
!
SKIP EXP; ! P TO STEP EXPRSN
FOR EXP(STEPOPND,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
!
FOR EXP(FINALOPND,1); ! EVALUATE FINAL
!
P=INITP
FOR EXP(INITOPND,0); ! INITIAL VALUE TO ETOS
%IF PARM_OPT#0 %THEN VALIDATE FOR
!
DIFFOPND_D=BRECTRIP(SUB,FORPT,0,INITOPND,STEPOPND)
DIFFOPND_S1=FORPT<<16!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_S1=FORPT<<16!REFTRIP
OPND_D=BRECTRIP(IDIV,FORPT,0,OPND,STEPOPND)
ZOPND_D=0; ZOPND_S1=FORPT<<16!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)
ELRES=ENTER LAB(L1,0); ! LABEL FOR REPEATING
DIFFOPND_D=URECTRIP(FORPR2,FORPT,USE ESTACK,DIFFOPND)
!
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_S1=FORPT<<16!REFTRIP
ZOPND_S1=FORPT<<16!DNAME
ZOPND_D=FORNAME
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)
ELRES=ENTER LAB(L3,B'011'); ! LABEL FOR CONTINUE
%FINISH
TRIP=UNAMETRIP(PRELOAD,FORPT,0,FORNAME)
ENTER JUMP(15,L1,0)
ELRES=ENTERLAB(L4,B'11')
TRIP=UCONSTTRIP(FORPOST,FORPT,0,0)
REMOVE LAB(L4)
ELRES=ENTERLAB(L2,B'111'); ! REPLACE ENV
! WHEN MERGE ENV
%IF STEPOPND_FLAG>1 %THEN RETURN WSP(FORWORDS,STEPOPND_XTRA)
%IF FINALOPND_FLAG>1 %THEN RETURN WSP(FORWORDS,FINALOPND_XTRA)
->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)
ELRES=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; ELRES=ENTER LAB(L3,B'011'); ! CONTINUE LABEL IF NEEDED
LINE=FLINE; SET LINE
CCRES=CCOND(0,1,L1,0)
ELRES=ENTER LAB(L2,B'011')
->WAYOUT
%ROUTINE FOR EXP(%RECORD(RD) %NAME EOPND, %INTEGER TOTEMP)
!***********************************************************************
!* P INDEXES EXPRESSION. IF CONST PUT INTO EVALUE OTHERWISE *
!* COMPILE TO ETOS AND STORE IN TEMP IF TOTEMP#0 *
!***********************************************************************
%INTEGER INP,VAL
INP=P; P=P+3
%IF INTEXP(VAL,FORPT)=0 %AND IMOD(VAL)<X'FFFF' %START
EOPND=EXPOPND; ! EXPRESSION A LITERAL CONST
%RETURN
%FINISH
EOPND=EXPOPND
%IF TOTEMP#0 %START
GET WSP(VAL,FORWORDS!X'80000000')
EOPND_S1=FORPT<<16!LOCALIR
EOPND_D=RBASE<<16!VAL; EOPND_XTRA=VAL
EOPND_D=BRECTRIP(LASS,FORPT,0,EXPOPND,EOPND)
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(J//STEPOPND_D)*STEPOPND_D#J %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_S1=FORPT<<16!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
%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 NAM=0=ARR %AND A(P1+2)=2=A(P1+3) %THEN %START;! SCALAR
BINSERT(HEAD1,BOT1,PTYPE<<16!2,P1,LHNAME)
%FINISH %ELSE %START
%IF ARR>0 %AND LHCELL_S1>>16&15#3 %START;! SCALAR ARRAYS
P=P1
COPY TAG(LHNAME); ! SET SNDISP ETC FOR AATORP
AATORP(NOPS,HEAD1,BOT1,ARR,II,KK)
%FINISH %ELSE %START
P=P1; CNAME(3); ! 32 BIT ADDR TO STACK
BINSERT(HEAD1,BOT1,PTYPE<<16!9,P1,LHNAME)
%FINISH
%FINISH
P=P2+3
TORP(HEAD2,BOT2,NOPS); ! RHS TO REVERSE POLISH
BINSERT(HEAD2,BOT2,VASS+ASSOP-2,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
!
! PICK OFF NULL STRINGS AND SUBSTITUTE A CRAFTY STB FOR S=""
!
%IF A(P+3)=4 %AND A(P+4)=2 %AND %C
A(P+5)=X'35' %AND A(P+10)=0 %AND A(P+11)=2 %THEN %START
Q=P+12
P=P1; CNAME(2)
PB2(LDC0,STB)
P=Q; %RETURN
%FINISH
P=P1; CNAME(3); ! 3 WORD POINTER TO ESTACK
PB1(MMS); ! MAX LENGTH OFF ESTACK
%IF ASSOP=3 %THEN PB1(MMS2) %ELSE PB1(LDC0);! TOP HALF OF STRING POINTER
P=P2; CSTREXP(32)
%IF ASSOP=3 %THEN %START
PB1(MMS2)
PPJ(0,18)
%FINISH %ELSE %START
PB2(LDC0,MES); ! MAX LENGTH BACK
PB2(STLATE,X'63')
PB1(SAS)
%FINISH
%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)
BULKM(0,ACC,0)
%FINISH %ELSE %START
->BACK %UNLESS TYPE=3 %AND A(P2+3)=4 %AND A(P2+4)=1
P=P2+5; CNAME(3)
ACCP=ACC
%UNLESS A(P)=2 %THEN FAULT(66,0,LHNAME) %AND ->F00
P=P1; CNAME(3)
%IF ASSOP=2 %AND ACCP#ACC %THEN %C
FAULT(67,LHNAME,FROMAR2(P2+5)) %AND ->F00
%IF ACCP>ACC %THEN ACCP=ACC
BULKM(1,ACCP,0)
%FINISH
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==
P=P2+5
RHNAME=A(P)<<8!A(P+1)
->ARRNAME %IF ARR=1
CNAME(3); ! DESCRPTR TO NEST
->F81 %UNLESS A(P)=2; ! NO REST OF EXP ON RHS
Q=P+1; P=P1
->F83 %UNLESS TYPE=TYPEP %AND PREC=PRECP
->F86 %UNLESS OLDI<=LVL %OR BASE=0 %OR NAM#0
! GLOBAL == NONOWN LOCAL
CNAME(6)
%IF TYPEP=5 %OR(TYPEP=1 %AND PRECP=3) %START;! 3 WORD POINTERS
PB4(REPL2,MMS2,INCB,2)
CAB; PB3(TLATE2,STIND,MES2); ! STORE 3RD WORD
%FINISH
PB3(EXCH2,TLATE3,STDW)
! NOTE ASSMENT(REG,1,LHNAME)
P=Q; %RETURN
ARRNAME:
CNAME(12); ! ARRAYHEAD TO ESTACK
->F83 %UNLESS TYPE=TYPEP %AND PREC=PRECP %AND ARR>0
->F86 %UNLESS OLDI<=LVL %OR BASE=0 %OR NAM#0
! GLOBAL == NONOWN LOCAL
B=BASE; D=DISP
->F81 %UNLESS A(P)=2
Q=P+1; P=P1
CNAME(11); ! 32BIT ADDRESS OF POINTER TO ETOS
PB1(PERMD); ! ADRESS UNDER HEAD
PTLATE(5)
PB2(ROPS,38); ! AND STORE HEAD
! NOTE ASSMENT(-1,1,LHNAME)
P=Q; %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,PP
EXPHEAD=0; EXPBOT=0
NOPS=0
P=P+3
TORP(EXPHEAD,EXPBOT,NOPS)
PP=P
!
EXPOP(EXPHEAD,EXPBOT,NOPS,MODE)
P=PP
%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)
%IF EXPOPND_FLAG=3 %THEN RES=EXPOPND_XTRA %AND ->WAYOUT
->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,IDIV,RDIV,LSHIFT,RSHIFT,ADD,IEXP,REXP,0(3),LNEG,NOTL;
%INTEGER RPHEAD,PASSHEAD,SAVEHEAD,REAL,REALOP,COMPLEX,%C
OPERATOR,OPPREC,OPND,C,D,E,RPTYPE,RPINF,BDISP,%C
OPNAME,OPMASK,XTRA,RPBOT,OPSTK,OPPSTK,PASSBOT
%RECORD(LISTF)%NAME LCELL
!
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
COMPLEX=0; XTRA=0
-> OPERAND(OPND); ! SWITCH ON OPERAND
OPERAND(1): ! NAME
OPNAME=A(P)<<8+A(P+1)
LCELL==ASLIST(TAGS(OPNAME))
PTYPE=LCELL_S1>>16
%IF PTYPE=X'FFFF' %THEN PTYPE=X'57';! NAME NOT SET
TYPE=PTYPE&7; PREC=PTYPE>>4&15
%IF PTYPE=SNPT %THEN PTYPE=LCELL_S2 %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
LCELL_S1=LCELL_S1!X'8000'; ! SET USED BIT
RPINF=LCELL_S2; XTRA=LCELL_S3
RPTYPE=1; PTYPE=PTYPE&255
%IF TYPE=1 %AND PREC<=5 %AND IMOD(RPINF)<=X'7FFF'%C
%THEN RPTYPE=0 %AND PTYPE=X'41'
%IF PREC=7 %THEN RPTYPE=3
REAL=1 %IF TYPE=2
P=P+2; ->SKNAM
%FINISH
XTRA=OPNAME
OPMASK=OPMASK!(COMPLEX<<19)
RPTYPE=2; RPINF=P; PTYPE=X'51' %IF PTYPE=X'57'
%IF TYPE=5 %THEN FAULT(76,0,OPNAME) %AND RPTYPE=0 %AND %C
PTYPE=X'51'
%IF TYPE=3 %THEN %START
D=P; KFORM=LCELL_S3&X'FFFF'
C=COPY RECORD TAG(E); P=D;
%FINISH %ELSE %START
%IF PTYPE&X'300'#0 %START;! ARRAYS
COPY TAG(OPNAME)
BINSERT(RPHEAD,RPBOT,PTYPE<<16!2,OPNAME,XTRA)
AATORP(NOPS,RPHEAD,RPBOT,ARR,I,K)
P=RPINF; RPTYPE=IFETCH
XTRA=0; RPINF=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 RPTYPE=2 %THEN OPMASK=OPMASK!1<<18
BINSERT(RPHEAD,RPBOT,PTYPE<<16!COMPLEX<<8!RPTYPE,RPINF,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
RPINF=FROM AR2(P+1)
PTYPE=X'51'
%FINISH %ELSE RPINF=FROM AR4(P+1)
REAL=1 %IF C=2; RPTYPE=1
%IF D=6 %THEN XTRA=FROM AR4(P+5)
%IF C=5 %THEN %START; ! STRING CONSTANT
FAULT(77,0,0); RPINF=1; RPTYPE=0
P=P+A(P+1)+3; PTYPE=X'51'
%FINISH %ELSE %START
%IF D=7 %THEN XTRA=ADDR(A(P+1)) %AND RPTYPE=3
%IF PTYPE=X'51' %AND X'FFFF8000'<=RPINF<=X'7FFF' %THEN %C
RPTYPE=0 %AND PTYPE=X'41'
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
-> 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=RDIV %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
BINSERT(RPHEAD,RPBOT,OPVAL(OPSTK&31),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
BINSERT(RPHEAD,RPBOT,OPVAL(OPSTK&31),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
%ROUTINESPEC CHECKOP(%RECORD(RD)%NAME OP,%INTEGER DONTLOAD)
!
%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(128:148)= %C
X'1FF'{+},X'FF'{-},
X'1F1'{!!},X'1F1'{!},
X'1FF'{*},X'F1'{//},
X'F2'{/},X'1F1'{&},X'41'{>>},
X'41'{<<},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(10:19)=0,0,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)
C=LIST_S1; XTRA=LIST_S2
JJ=C&255; 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
ABORT %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 OPND1_FLAG=8 %START
NDEPTH=NDEPTH-WORDS(OPND1_PTYPE>>4)
%FINISH
%IF JJ>=128 %THEN %START
OPND2==ASLIST(OPERAND(2))
%IF OPND2_FLAG=8 %START
NDEPTH=NDEPTH-WORDS(OPND2_PTYPE>>4)
%FINISH
%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)
CURR TRIP=NEW TRIP
CHECKOP(OPND1,C&(2**10))
CHECKOP(OPND2,C&(2**9)) %UNLESS JJ<128
CURRT==TRIPLES(CURR TRIP)
CURRT_DPTH=NDEPTH
%IF OPND1_PTYPE=X'31' %THEN CURRT_OPTYPE=X'41' %ELSE %C
CURRT_OPTYPE=OPND1_PTYPE
%IF JJ<128 %START; ! UNARY(TYPECHANGE)OPN
CURRT_OPERN=JJ
CURRT_OPTYPE=CURRT_OPTYPE+PTYPECH(JJ)
%FINISH %ELSE CURRT_OPERN=JJ
%IF JJ=COMP %OR JJ=DCOMP %THEN MASK=FCOMP(LIST_S2)
CURRT_CNT=0
CURRT_FLAGS=1!(C>>1&128)
%IF OPND1_FLAG<=1 %OR OPND2_FLAG<=1 %THEN %C
CURRT_FLAGS=CURRT_FLAGS!64;! HAS CONST OPERAND
%UNLESS OPND1_FLAG=8 %OR 35<=JJ<=36 %THEN %C
CURRT_FLAGS=CURRT_FLAGS!LOAD OP1
%IF JJ>=128 %AND OPND2_FLAG#8 %THEN CURRT_FLAGS=CURRT_FLAGS!4
! 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 JJ>=128 %THEN CURRT_OPND2=OPND2
OPND1_FLAG=8
OPND1_PTYPE=CURRT_OPTYPE
OPND1_UPTYPE=0
OPND1_D=CURR TRIP
NDEPTH=NDEPTH+WORDS(CURRT_OPTYPE>>4)
%FINISH
STK(STPTR)=OPERAND(COMM)
STPTR=STPTR+1
->ANYMORE
FINISH:
CHECKOP(EXPOPND,0) %IF EXPOPND_FLAG<8;! DONT UP USE COUNT
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 COERCET(%INTEGER RULES)
%ROUTINESPEC COERCEP(%INTEGER RULES)
%INTEGER TMPHEAD,INHEAD,C,JJ,NEXT
%RECORD(RD)%NAME OPND1
%RECORD(RD)OPND2
%RECORD(LISTF)%NAME CELL
PRINT LIST(HEAD) %AND ABORT %UNLESS ASLIST(BOT)_LINK=0
TMPHEAD=0
INHEAD=HEAD
!
%WHILE INHEAD#0 %CYCLE
CELL==ASLIST(INHEAD)
C=CELL_S1
NEXT=CELL_LINK
JJ=C&255; ! FLAG
%IF JJ<10 %START; ! AN OPERAND
%IF C>>20&15<=3 %THEN C=C&X'FF0FFFFF'!X'400000'
PUSH(TMPHEAD,C,CELL_S2,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)
%IF C&15#0 %THEN COERCET(C&15)
%IF C>>4&15#0 %THEN COERCEP(C>>4&15)
OPND1_XTRA=INHEAD; ! IN CASE(FURTHER)TYPE CHANGE
%FINISH
%FINISH
INHEAD=NEXT
%REPEAT
!
! FINAL COERCION ON RESULT
!
POP(TMPHEAD,OPND2_S1,OPND2_D,OPND2_XTRA)
PRINT LIST(HEAD) %AND ABORT %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 %START
INSERT AFTER(OPND2_XTRA,FLOAT,0,0);! FLOAT
OPND2_PTYPE=OPND2_PTYPE+X'11'
NOPS=NOPS+1
%FINISH
C=MODE>>4&15; ! TARGET PREC
%WHILE C<OPND2_PTYPE>>4&15 %CYCLE
INSERT AFTER(OPND2_XTRA,SHRTN,0,0)
OPND2_PTYPE=OPND2_PTYPE-X'10'
NOPS=NOPS+1
%REPEAT
%WHILE C>OPND2_PTYPE>>4&15 %CYCLE
INSERT AFTER(OPND2_XTRA,LNGTHN,0,0)
OPND2_PTYPE=OPND2_PTYPE+X'10'
NOPS=NOPS+1
%REPEAT
%FINISH
PRINTLIST(HEAD) %IF PARM_DCOMP#0 %AND PARM_SMAP#0
BOT=ASLIST(BOT)_LINK %WHILE ASLIST(BOT)_LINK#0
%RETURN
%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
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 OPND1_PTYPE=OPND1_PTYPE+X'11' %AND %C
INSERT AFTER(OPND1_XTRA,FLOAT,0,0) %AND NOPS=NOPS+1
%IF PT2=1 %AND (RULES=2 %OR RULES=4 %OR RULES=15) %THEN %START
OPND2_PTYPE=OPND2_PTYPE+X'11'
NOPS=NOPS+1
INSERT AFTER(OPND2_XTRA,FLOAT,0,0)
%FINISH
%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=15 BOTH OPERANDS TO THE LARGEST PRECISION *
!***********************************************************************
%INTEGER PREC1,PREC2,TPREC,OP
%RECORD(RD)%NAME OPND
%IF RULES=6 %THEN COERCEP(4) %AND RULES=2
PREC1=OPND1_PTYPE>>4
PREC2=OPND2_PTYPE>>4
%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 OP=SHRTN %ELSE OP=JAMSHRTN
INSERT AFTER(OPND2_XTRA,OP,0,0)
NOPS=NOPS+1
OPND2_PTYPE=OPND2_PTYPE-X'10'
PREC2=PREC2-1
%REPEAT %UNTIL PREC1=PREC2
%RETURN
%FINISH %ELSE RULES=1; ! IN CASE LENGTHEN NEEDED
%FINISH
%IF PREC1=3 %THEN PREC1=4 %AND OPND1_PTYPE=OPND1_PTYPE+X'10'
%IF PREC2=3 %THEN PREC2=4 %AND OPND2_PTYPE=OPND2_PTYPE+X'10'
%IF 2<=RULES<=4 %START
%IF RULES<=2 %THEN OPND==OPND1 %ELSE OPND==OPND2
%IF OPND_PTYPE=X'51' %THEN %START
INSERTAFTER(OPND_XTRA,SHRTN,0,0)
OPND_PTYPE=OPND_PTYPE-X'10'
NOPS=NOPS+1
%FINISH
%RETURN
%FINISH
%IF PREC1<PREC2 %THEN TPREC=PREC2 %AND OPND==OPND1 %ELSE %C
TPREC=PREC1 %AND OPND==OPND2
%WHILE OPND_PTYPE>>4&15<TPREC %CYCLE
INSERT AFTER(OPND_XTRA,LNGTHN,0,0);! LENGTHEN
OPND_PTYPE=OPND_PTYPE+X'10'
NOPS=NOPS+1
%REPEAT
%END
%END
%ROUTINE CHECKOP(%RECORD(RD)%NAME OPND,%INTEGER DONTLOAD)
!***********************************************************************
!* LOAD OPERAND OPND INTO TOP OF NEST(ESTACK) *
!***********************************************************************
%INTEGER K,KK
%RECORD(TRIPF)%NAME REFTRIP
%SWITCH SW(0:9)
K=OPND_FLAG
PTYPE=OPND_PTYPE
TYPE=PTYPE&15
PREC=PTYPE>>4
%IF K>9 %THEN ABORT
->SW(K)
SW(0): ! CONSTANT < 16 BITS
SW(1): ! LONG CONSTANT
%RETURN
SW(3): ! 128 BIT CONSTANT
ABORT
SW(2): ! NAME
%RETURN %IF DONTLOAD#0
P=OPND_D
%IF OPND_UPTYPE=0 %AND OPND_XB=0 %AND OPND_PTYPE#X'57' %THEN %C
OPND_D=OPND_XTRA %AND %RETURN
CNAME(2)
LDED:
%IF PREC<4 %THEN OPND_PTYPE=OPND_PTYPE&15!X'40'
OPND_FLAG=8; OPND_D=TRIPLES(0)_BLINK
SW(8): ! TRIPLE
REFTRIP==TRIPLES(OPND_D)
%IF REFTRIP_CNT=0 %THEN REFTRIP_PUSE=CURR TRIP
REFTRIP_CNT=REFTRIP_CNT+1
%RETURN
SW(4): ! CONDITIONAL EXPRESSION
ABORT
SW(5): ! INTEGER AS ADDR(NAME.APP)
%RETURN %IF DONTLOAD#0
P=OPND_D
CNAME(4); ! GET 32 BIT ADDRESS
OPND_PTYPE=X'51'; ! ADDRESSES ARE INTEGERS
->LDED
SW(6): ! OPTIMISED INTERMEDIATE
ABORT
SW(7): ! I-R IN A STACK FRAME
%RETURN
SW(9): ! I-R IN A REGISTER
%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(JMPW,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 SCOMP(%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(JMPW,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
%IF C1_CMP2=0 %AND 7<=FCOMP(C1_CMP1)<=8 %AND A(P2+3)=4 %AND %C
A(P2+4)=2 %AND A(P2+5)=X'35' %AND A(P2+10)=0 %C
%AND A(P2+11)=2 %THEN %START; ! ="" AND #""
CSTREXP(32)
PB3(LDB,LDC0,FCOMP(C1_CMP1))
PB2(LDC0,TLATE2)
MASK=JTW
%IF C1_REV!!C1_TF=1 %THEN MASK=REVERSE(MASK)
JUMP(MASK,FEXIT,B'11')
%RESULT=0
%FINISH
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
SCOMP(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
!
SCOMP(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
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
PUSH(HEAD1,COMP,CMP,0)
BOT1=HEAD1
NOPS=1
P=P1+1
->FLT %UNLESS A(P1+3)=4 %AND A(P1+4)=1 %AND A(P+FROMAR2(P))=2
P=P1+5; REDUCETAG
TYPEP=TYPE; PRECP=PREC
PUSH(HEAD1,X'51'<<16!5,P,LHNAME)
!
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; REDUCE TAG
FAULT(83,LHNAME,RHNAME) %UNLESS TYPEP=TYPE %AND PRECP=PREC
PUSH(HEAD1,X'51'<<16!5,P,RHNAME)
EXPOP(HEAD1,BOT1,NOPS,256+X'51')
%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,REG
PRECP=PTYPE>>4&15; TYPEP=TYPE
!
! ADD OPERATOR AT BOTTOM. EITHER COMPARE(COMP) OR DS COMPARE(DCOMP)
!
PUSH(HEAD2,COMP+DS,CMP,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,INTEGER(ADDR(EXPOPND)),EXPOPND_D,EXPOPND_XTRA)
BOT1=HEAD1
%IF EXPOPND_FLAG=9 %START
REG=EXPOPND_XB
%FINISH
%FINISH
%IF TF=1 %THEN MASK=REVERSE(MASK)
%END
%ROUTINE SCOMP(%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
PB1(LDC0)
CSTREXP(48); ! SAVE WK-AREA
WA=VALUE
%IF DS#0 %START; ! D-SIDED SAVE MIDDLE
GET WSP(D,2)
PB1(REPL2)
DSTORE(4,RBASE,D)
%FINISH
PB3(LDC0,STLATE,X'52')
PB1(FCOMP(CMP)-EQUI+EQUSTR)
MASK=JTW
%IF TF=1 %THEN MASK=REVERSE(MASK); ! REVERSE MASK TO JMP IF FALS
JUMP(MASK,LAB,B'11')
%IF DS#0 %THEN DFETCH(4,RBASE,D);! RETRIEVE MIDDLE FOR D-S
%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 *
!* S3 = LAB NO - RESET TO FFFF WHEN USED FOR INTERNAL LABELS *
!* RESULT = 1 LABEL ENTERED *
!* RESULT = 0 CONDITIONAL LABEL NOT REQUIRED *
!***********************************************************************
%INTEGER CELL,OLDCELL
%RECORD(TRIPF)%NAME CURRT
%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'
!
CURRT==TRIPLES(UCONSTTRIP(TLAB,0,0,LAB))
CURRT_OPND1_XTRA=CELL
!
! NEED ANOTHER TRIPLE HERE TO REMOVE THE TEMPORARY LABLES ?
!
%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(NOT IMPLEMENTED) *
!***********************************************************************
%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,0,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)
CELL=CURRINF_LABEL
LCELL==ASLIST(CELL)
NOT YET SET: ! LABEL REFERENCED BEFORE
I=FJUMP
CURRT==TRIPLES(UCONSTTRIP(I,0,0,LAB))
CURRT_X1=TFMASK; ! CONDITIONAL OR NOT ETC
PUSH(LCELL_S2,0,FLAGS&1,LINE)
CURRT_OPND1_XTRA=LCELL_S2; ! 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 *
!***********************************************************************
!
! SOME SORT OF TRIPLE IS NEEDED HERE. CAN NOT REMOVE THE LAB TILL CODE GENERATED
!
%END
%ROUTINE CREATE AH(%INTEGER MODE)
!***********************************************************************
!* 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*
!***********************************************************************
%IF MODE=0 %START
ERASE(2); ! IS LOST
PB1(EXCH2); ! ADDRESS OVER DV
%FINISH %ELSE %START
PB1(EXCH2); ! DV TO TOP
PB1(PERMD); ! DV ADDRESS TO BOTTOM
PB2(LOPS,2); ! 32 BIT ADD
%FINISH
%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) *
!***********************************************************************
%INTEGERFNSPEC OPTMAP
%SWITCH ADHOC(1:16)
%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';
%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.
!
%CONSTHALFINTEGERARRAY SNPARAMS(0:25)=0,
1,LRLPT, 2,LRLPT,LRLPT, 2,LRLPT,X'51',
3,LRLPT,X'51',X'51', 1,X'435', 3,X'435',X'51',X'51',
1,X'400', 1,X'51', 2,X'51',X'51';
! KEY TO PARAMETER TABLE
! 0 X0 == (NO PARAMS)
! 1 X1 == (%LONGREAL X)
! 3 X3 == (%LONGREAL X,Y)
! 6 X6 == (%LONGREAL X,%INTEGER I)
! 9 X9 == (%LONGREAL X,%INTEGER I,J)
! 13 XD == (%STRINGNAME S)
! 15 XF == (%STRINGNAME S,%INTEGER I,J)
! 19 X13 == (%NAME X)
! 21 X15 == (%INTEGER I)
! 23 X17 == (%INTEGER I,J)
!
!
%CONSTBYTEINTEGERARRAY WRONGZ(0:15)=27,29,23,29,29,23,82,109(5),
23,27,109(2);
%ROUTINESPEC RTOS
%RECORD(LISTF)%NAME LCELL
%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
! CXREF(SNXREFS(XTRA),PARM_DYNAMIC,2,JJ);! JJ SET WITH REF DISPLACEMENT
JJ=ADDR(SNXREFS(XTRA))
! %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
PTYPE=SNPARAMS(POINTER+D)
UNPACK
%IF NAM=0 %THEN ACC=BYTES(PREC) %ELSE ACC=8
%IF PTYPE=X'35' %THEN ACC=256;!STRING BY VALUE
INSERTAT END(OPHEAD,PTYPE<<16,ACC<<16,0)
D=D+1
%REPEAT
LCELL==ASLIST(TAGS(SNNAME))
LCELL_S1=1<<4!14!SNPTYPE<<16; ! I=1 & J=14
LCELL_S2=JJ; ! RT ENTRY DISPLACEMENT
LCELL_S3=OPHEAD<<16!P0; ! K & KFORM(=NPARAMS)
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
%IF IOCPEP>127 %THEN %START
PBW(LDCW,IOCPEP&127)
PB2(LOPS,1)
IOCPEP=5
%FINISH
CIOCP(IOCPEP); ! 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
JJ=SNPTYPE>>4&15
%IF SNPTYPE&X'FF'=X'31' %THEN PB1(LDC0);! BYTE INTEGER DIFFERENT
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,0,0); ! OPERATOR '!'
EXPBOT=EXPHEAD
PUSH(EXPHEAD,X'510000',JJ,0); ! CONST JJ
PUSH(EXPHEAD,LSHIFT,0,0); ! OPERATOR '<<'
PUSH(EXPHEAD,X'510000',8,0); ! CONST 8
P=P+3; TORP(EXPHEAD,EXPBOT,NOPS)
EXPOP(EXPHEAD,EXPBOT,NOPS,X'51'); ! EVAL REPTN<<8!SYMBOL IN GR1
CIOCP(17)
P=P+1
->OKEXIT
ADHOC(2): ! NEXTSYMBOL(=8) & NEXTITEM(=44)
! ALSO NEXTCH(=60)
%IF SNNO=60 %THEN JJ=18 %ELSE JJ=2
CIOCP(JJ); ! LEAVES THE SYMBOL IN GR1
PB1(MES)
%IF SNNO=44 %THEN ->TOST; ! TREAT AS TOSTRING
->OKEXIT
ADHOC(3): ! READSYMBOL(=10),CH(=41)&ITEM(=43)
%IF SNNO=41 %THEN JJ=4 %ELSE JJ=1
PB1(LDCN)
CIOCP(JJ); ! SYMBOL OR CH TO GR1
P=P+5
%IF SNNO=43 %THEN %START
CNAME(4); ! 32 BIT ADRESS
PB2(LDC0,MES)
TYPE=5; RTOS
PB2(LDC0,LDC0+1)
PB3(STLATE,X'63',SAS)
%FINISH %ELSE %START
PB1(MES)
REDUCE TAG
EXPHEAD=0; NOPS=1
PUSH(EXPHEAD,VASS,FROMAR2(P)<<16!PTYPE,0); ! ASSIGN
EXPBOT=EXPHEAD
PUSH(EXPHEAD,X'41'<<16!9,0,0);! ITEM IN ETOS
PUSH(EXPHEAD,PTYPE<<16!2,P,0)
FAULT(25,0,0) %UNLESS TYPE=1
EXPOP(EXPHEAD,EXPBOT,NOPS,PTYPE&255!256)
%FINISH
P=PIN+6+FROM AR2(PIN+4)
->OKEXIT
ADHOC(4): ! INT(=16) AND INTPT (=17)
CSEXP(LRLPT)
%IF SNNO=16 %THEN JJ=23 %ELSE JJ=16
PB2(ROPS,JJ)
P=P+1
->OKEXIT
ADHOC(5): ! ADDR(=14)
P=P+5; CNAME(4); ! FETCH ADDRESS MODE
P=P+2; ->OKEXIT
ADHOC(6): ! MOD(=23), IMOD(=51)
%IF SNNO=51 %THEN %START
CSEXP(X'51'); PB2(LOPS,2)
%FINISH %ELSE %START
CSEXP(X'62'); PB2(ROPS,24)
%FINISH
P=P+1
->OKEXIT
ADHOC(7): ! CHARNO(=45) & LENGTH(=36)
P=P+5
CNAME(2)
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(X'41')
P=P+1
%FINISH %ELSE PB1(LDC0)
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(X'41'); ! 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
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
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
CREATE AH(0)
%RETURN
ADHOC(13): ! EVENTINF(=33) & EVENTLINE
D=CURRINF_ONINF
FAULT(16,0,SNNAME) %IF D=0
D=D+4 %IF SNNO#33
DFETCH(4,RBASE,D)
->OKEXIT
ADHOC(14): ! LENGTHEN AND SHORTEN
D=(SNNO&3)*8
CSEXP(X'52415251'>>D&255)
P=P+1
->OKEXIT
ADHOC(15): ! PPROFILE(IGNORED UNLESS PARM SET)
PPJ(0,22) %UNLESS PARM_PROF=0
->OKEXIT
ADHOC(16): ! FLOAT
CSEXP(LRLPT)
P=P+1
OKEXIT: ! NORMAL EXIT
PTYPE=SNPTYPE; UNPACK
%RETURN
ERREXIT: ! ERROR EXIT
FAULT(ERRNO,ERRVAL,SNNAME)
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
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
%ROUTINE RTOS
!***********************************************************************
!* PLANTS CODE TO CONVERT A SYMBOL IN ETOS TO A ONE *
!* CHARACTER STRING IN A TEMPORARARY VARIABLE. *
!***********************************************************************
%INTEGER KK
GET WSP(KK,1); ! GET 1 WORD WK AREA
STRINGL=1; DISP=KK
PBW(LDCW,256)
PB3(MPI,LDC0+1,ADI)
DSTORE(2,RBASE,KK)
DFETCHAD(YES,RBASE,KK)
%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 *
!***********************************************************************
%INTEGER HEAD2,PTYPEP,KK,PP,JJ,SOLDI, %C
TYPEP,ARRNAME,Q,PRECP,ELSIZE,NAMINF,BOT2,DVD,VMYOP,VMYOPPT
PP=P; TYPEP=TYPE
JJ=J; PTYPEP=PTYPE; PRECP=PREC; SOLDI=OLDI
%IF TYPE<=2 %THEN ELSIZE=BYTES(PRECP) %C
%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 VMYOPPT=X'51' %ELSE VMYOPPT=X'61'
VMYOPPT=VMYOPPT<<16; ! FOR OPTIMISER PASS ONLY
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 %THEN %START; ! 0 DIMENSIONS = NOT KNOWN
REPLACE1(TCELL,FROM1(TCELL)!Q);! DIMSN IS BOTTOM 4 BITS OF TAG
JJ=Q
%FINISH
%IF JJ=Q#0 %THEN %START; ! 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.
!
HEAD2=0; ! CLEAR LISTHEADS
!
! NOW PROCESS THE SUBSCRIPTS CALLINR TORP TO CONVERT THE EXPRESSIONS
! TO REVERSE POLISH AND ADDING THE EXTRA OPERATIONS.
!
BINSERT(HEAD1,BOT1,X'51'<<16!7,BS<<16!DP,0)
P=PP+3
%CYCLE KK=1,1,JJ; ! THROUGH THE SUBSCRIPTS
P=P+3; BOT2=0
TORP(HEAD2,BOT2,NOPS); ! SUBSCRIPT TO REVERSE POLISH
P=P+1
!
! MULTIPLIERS ARE DOPE VECTOR ITEMS (OPTYPE=3)
!
! N SUBSCRIPTS WILL REQUIRE (N-1) MULTIPLICATIONS AND ADDITIONS
!
NOPS=NOPS+2
VMYOP=KK<<24!JJ<<16!DVD
%IF KK>1 %OR PARM_ARR#0 %START
BINSERT(HEAD2,BOT2,VMYOPPT,VMYOP,BS<<16!DP);! MULTIPLIER
BINSERT(HEAD2,BOT2,VMY,PTYPEP<<16!ARRNAME,0);! DOPE VECTOR MULTIPLY
%FINISH
BINSERT(HEAD2,BOT2,COMB,0,0) %IF KK>1;! COMBINE WITH PREVIOUS
! VMY RESULT
ASLIST(BOT1)_LINK=HEAD2
BOT1=BOT2; HEAD2=0
%REPEAT
%UNLESS ARRP=2 %OR PARM_COMPILER#0 %START;! BASE ADJUST
BINSERT(HEAD1,BOT1,VMYOPPT,JJ<<16!DVD,BS<<16!DP)
BINSERT(HEAD1,BOT1,BADJ,PTYPEP<<16!ARRNAME,0)
%FINISH
BINSERT(HEAD1,BOT1,BSADD,BS<<16!DP!ELSIZE<<20,0);! SCALE
NOPS=NOPS+2
%FINISH %ELSE %START
BINSERT(HEAD1,BOT1,X'51'<<16,0,0)
%IF JJ>Q %THEN FAULT(20,JJ-Q,ARRNAME) %C
%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+12
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)
I=RLEVEL; J=0; K=FNAME
KFORM=0; SNDISP=0; ACC=4
PTYPE=X'57'; STORE TAG(K, N)
K=N; 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 TYPE<5 %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
PTYPE=X'51'; UNPACK
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
%IF Z=11 %THEN DFETCHAD(YES,I,K) %ELSE DFETCHAD(NO,I,K) %AND %C
PB2(ROPS,37)
->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
DISP=MIDCELL; BASE=I
%IF NAM&1#0 %THEN %START
DFETCH(8,BASE,DISP); ! RT TYPE COPY POINTER
%FINISH %ELSE %START
%IF J=14 %THEN %START; ! EXTERNAL ROUTINE PASSED
PWW(LVRD,0,X'0100'); ! NB BYTES FLIPPED IN WORD 2!
GXREF(STRING(DISP),0,0,CA-5)
%FINISH %ELSE %START
PWW(LVRD,0,DISP&255!(BASE+1)<<8);! LEVEL OF BODY NOT DECLN
%FINISH
%FINISH
%IF A(P+2)=2 %THEN P=P+3 %ELSE NO APP; ->CHKEN
SW(3): ! RECORD
CRNAME(Z, 2*NAM, I, K, NAMEP)
->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+4
%IF Z=2 %THEN Z=4
NAMEOP(Z,4,NAMEP)
%IF Z=3 %START
%IF BML<0 %THEN PBW(LDCW,DML)%ELSE DFETCH(2,BML,DML)
%FINISH
->CHKEN
STRARR: ! STRINGARRAYS & ARRAYNAMES
CANAME(Z, ARR, I, K)
->SMAP %UNLESS Z=3 %AND NAM#0
NAMEOP(3,4,NAMEP)
DFETCH(4,LEVELP,DISPP+4); ! DV POINTER
ADDLMAX: ! PUT LMAX (16 BITS) OVER PTR
PB1(TLATE1)
PB1(SIND0+2)
PB1(LDC0+1)
PB1(SBI)
->CHKEN
->CHKEN
STRINREC: ! STRINGS IN RECORDS
->SMAP %UNLESS Z=3 %AND NAM#0 %AND ARR#0
NAMEOP(3,4,NAMEP)
DFETCH(2,BASE,DISP); ! LEFT SET BY CENAME
->ADDLMAX
!
! 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
%IF TYPE=5 %THEN %START; ! STRING FNS
PB1(MES2); ! PICKUP 32BIT ADDR OF RESULT
%FINISH %ELSE %START
STACKUNDUMP(WORDS(PREC))
%FINISH
->CHKEN
UDM: ! USER DEFINED MAPS
PB1(MES2); ! GET RESULT = 32 BIT ADDR
%IF TYPE=1 %AND PREC=3 %THEN PB1(LDC0)
DISP=0
ACCESS=3
BASE=0
BIM: ! BUILT IN MAPS
->CHKEN %IF TYPE=3; ! MAP RECORD USE VERY LIMITED
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
!
! GENERAL FETCHING & STORING
!SECTION
!
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 MOD(0:15),BIGACC(0:11)
%RECORD(TRIPF)%NAME CURRT
%INTEGER KK, OPTION, PTRSIZE
KK=Z; KK=2 %IF Z=5
PTRSIZE=4
%IF (TYPE=1 %AND PREC=3) %THEN PTRSIZE=6
%IF Z=6 %THEN %START
FAULT(82,0,NAMEP) %UNLESS NAM!ARR#0 %AND ROUT=0 %C
%AND (ACCESS>=8 %OR ACCESS=2)
KK=3; SIZE=4; PTRSIZE=4
%IF ACCESS>=8 %THEN ACCESS=ACCESS-4 %ELSE ACCESS=0
%FINISH
KK=KK&3
OPTION=ACCESS<<2!KK
->BIGACC(ACCESS)
BIGACC(0):BIGACC(3):
->MOD(OPTION)
BIGACC(5):
BIGACC(1): ABORT; ! NO LONGER USED?
!
! ACCESS
! ******
! THIS VARIABLE DEFINES HOW TO ACCESS ANY IMP VARIABLE:-
! =0 VARIABLE DIRECTLY ADDRESSED IN 'BASE' BY 'DISP'
! =1 VARIABLE ADDRESSED BY SHORTPOINTER ON ESTACK
! =2 POINTER TO VARIABLE DIRECTLY ADDRESS BY 'BASE' & 'DISP'
! =3 POINTER AS IN =2 ALREADY ON ESTACK
! =4 VARIABLE 'XDISP' INTO RECORD AT BY 'BASE' &'DISP'
! =5 VARIABLE 'XDISP' INTO RECORD ADDRESSED BY POINTER MODIFIED AS =1
! =6 VAR 'XDISP' INTO RECORD ADDRESSED BY POINTER AT 'BASE' & 'DISP'
! =7 AS =6 BUT POINTER ALREADY IN ESTACK
! =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
!
MOD(0): ! ACCESS=0 FETCH ADDRESS
MOD(3): ! ACCESS=0 SET DESCRIPTOR
CURRT==TRIPLES(UNAMETRIP(GETAD,X'51',0,NAMEP))
CURRT_OPND1_XTRA=NAMEP
%RETURN
MOD(1): ! ACCESS=0 STORE
! ABORT
%RETURN
MOD(2): ! ACCESS=0 FETCH
CURRT==TRIPLES(UNAMETRIP(PRELOAD,PTYPE,0,NAMEP))
CURRT_OPND1_XTRA=NAMEP
%RETURN
BIGACC(2): ! ALL ACCESS=2
DFETCH(PTRSIZE,BASE,DISP); ! GET 32 BIT ADDRESS
ACCESS=3; ->MOD(KK+12); ! NOW AS ACCESS=3
MOD(12): ! ACCESS=3 FETCH ADDRESS
%IF TYPE=1 %AND PTRSIZE>4 %THEN PB3(LDC0+2,DVI,ADI)
MOD(15): ! ACCESS=3 SET DESCRIPTOR
%RETURN
MOD(14): ! ACCESS=3 FETCH
%IF PREC=3 %THEN PB2(TLATE2,LDB) %AND %RETURN
%IF PREC=4 %THEN PB2(TLATE1,LDIND) %AND %RETURN
%IF PREC=5 %THEN PB2(TLATE1,LDDW) %AND %RETURN
PB1(TLATE1)
PB2(ROPS,37)
%RETURN
MOD(13): ! ACCESS=3 STORE
%IF PREC=3 %START
PB4(MMS2,EXCH,MES,EXCH)
PB4(MES,EXCH,TLATE3,STB)
%RETURN
%FINISH
%IF PREC=5 %START; ! DOUBLE WORDS
PB3(EXCH2,TLATE3,STDW)
%RETURN
%FINISH
%IF PREC=6 %START
PB1(PERMD)
PTLATE(5)
PB2(ROPS,38); ! STQ
%FINISH
! SINGLE WORD
CAB
PB2(TLATE2,STIND)
%RETURN
BIGACC(4): ! ALL ACCESS=4
DISP=DISP+XDISP
ACCESS=0
->MOD(KK); ! REDUCES TO ACCESS=0
BIGACC(6): ! ALL ACCESS=6
DFETCH(4,BASE,DISP)
! REDUCED TO ACCESS=7
! SO DROP THROUGH
BIGACC(7): ! ALL ACCESS=7
NAMEP=0; ACCESS=1
%IF TYPE=1 %AND PREC=3 %THEN PBW(LDCW,XDISP!!1) %ELSE %C
PBW(INCW,XDISP>>1) %AND PTRSIZE=4
->MOD(KK+12); ! REDUCED TO ACCESS=3
BIGACC(8): ! ALL ACCESS=8
DISP=DISP+XDISP
NAMEP=0
->BIGACC(2)
BIGACC(10): ! ALL ACCESS=10
DFETCH(4,BASE,DISP)
! HAS BECOME ACESS=11
BIGACC(11): ! ALL ACCESS=11
NAMEP=0
ACCESS=9; DISP=XDISP
BIGACC(9): ! ALL ACCESS=9
PBW(INCW,XDISP>>1)
PB1(LDDW)
ACCESS=3; NAMEP=0
->MOD(KK+12); ! HAS REDUCED TO ACCESS=3
%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. *
!***********************************************************************
%SWITCH FPD(0:3)
%INTEGER II,III,QQQ,JJ,JJJ,NPARMS,PT,LP,PSIZE,TWSP,PARMNO,ERRNO,PP,%C
TYPEP,PRECP,NAMP,TL,CLINK,RDISP
%RECORD(LISTF)%NAME LCELL
PT=PTYPE; JJJ=J; TL=OLDI
TWSP=0
LP=I; CLINK=K
TYPEP=TYPE; PRECP=PREC; NAMP=NAM
RDISP=MIDCELL
!
! NOW CHECK THAT THE RIGHT NUMBER OF PARAMETERS HAVE BEEN PROVIDED
!
TEST APP(NPARMS)
P=P+2
%IF KFORM#NPARMS %THEN %START
! WRONG NO OF PARAMETERS GIVEN
%IF KFORM=0 %THEN ERRNO=17 %ELSE %START
%IF NPARMS<KFORM %THEN ERRNO=18 %ELSE ERRNO=19
%FINISH
FAULT(ERRNO,IMOD(KFORM-NPARMS),RTNAME)
SKIP APP; P=P-1
%RETURN
%FINISH
!
%IF TYPEP#0 %START; ! LEAVE RESULT HOLE FOR FNS
%IF NAM>=2 %THEN II=4 %ELSE %IF TYPEP=5 %THEN II=4 %ELSE %C
II=BYTES(PRECP)
PB2(ATPB,II//2)
%FINISH
PARMNO=0
->FIRST PARM
!
BAD PARM: ! BAD PARAMETER FAULT IT
P=PP
FAULT(22,PARMNO,RTNAME)
SKIP EXP
NEXT PARM:CLINK=LCELL_LINK
FIRSTPARM:->ENTRY SEQ %IF CLINK=0; ! DEPART AT ONCE IF NO PARAMS
LCELL==ASLIST(CLINK)
PSIZE=LCELL_S2>>16
PARMNO=PARMNO+1
P=P+1; PP=P
PTYPE=LCELL_S1>>16
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)
!
! RT TYPE PARAMS, PASS 4 WORDS AS SET UP BY QCODE INSTRN LVRD
!
%IF ROUT=1 %THEN %START
FPTR=(FPTR+3)&(-4)
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
STACKDUMP(4)
->NEXT PARM
%FINISH
->FPD(JJ)
FPD(0): ! VALUE PARAMETERS
%IF TYPE=5 %THEN %START
PB2(LDTP,LDC0); ! POINTER TO DEST
PBW(LDCW,(PSIZE+1)>>1)
PB1(ATPW); ! SPACE CALIMED
CSTREXP(32)
PB1(LDC0)
PBW(LDCW,PSIZE-1)
PB2(TLATE3,SAS)
->NEXT PARM
%FINISH
%IF TYPE=3 %START; ! RECORDS BY VALUE
II=TSEXP(III); ! CHECK FOR ZERO AS RECORD VALUE
%IF II=1 %AND III=0 %START
JJ=0
%FINISH %ELSE %START
P=PP; ! 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
->BAD PARM %UNLESS ACC=PSIZE
%FINISH
PB2(LSSN,LDTP)
PBW(LDCW,PSIZE>>1)
PB1(ATPW)
BULKM(JJ,PSIZE,0)
->NEXT PARM
%FINISH
CSEXP(III<<4!II)
STACKDUMP((PSIZE+1)>>1)
->NEXT PARM
!
FPD(2): ! NAME PARAMETERS
P=P+5
%IF II#0 %START; ! NOT A GENERAL NAME
CNAME(3)
%IF TYPE=5 %THEN PERM; ! LMAX TO BOTTOM OUT LAST
%IF PREC=3 %AND (TYPE=5 %OR TYPE=1) %THEN STACKDUMP(3) %ELSE %C
STACKDUMP(2)
->BAD PARM %UNLESS II=TYPE %AND III=PREC
FPTR=FPTR+4
%FINISH %ELSE %START
%IF TYPE#0 %START; ! NOT GENERAL NAME PASSED AS NAME
CNAME(4)
STACKDUMP(2)
PWW(LDDC,PTYPE,ACC)
STACKDUMP(2)
%FINISH %ELSE %START; ! NAME AS GENERAL NAME
FNAME=FROM AR2(P)
COPY TAG(FNAME)
DFETCH(8,I,K); ! FETCH THE 4 WORDS
STACKDUMP(4); ! AND STUFF THEM OFF
%FINISH
FPTR=FPTR+8
%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
!
FPTR=(FPTR+3)&(-4)
P=P+5
CNAME(12)
STACKDUMP(4)
P=P+1
->BAD PARM %UNLESS 1<=ARR<=2 %AND II=TYPE %AND III=PREC
QQQ=FROM1(TCELL)&15; ! DIMENSION OF ACTUAL(IF KNOWN)
JJ=LCELL_S1&15; ! DIMENSION OF FORMAL
%IF JJ=0 %THEN JJ=QQQ %AND LCELL_S1=LCELL_S1!JJ
%IF QQQ=0 %THEN QQQ=JJ %AND REPLACE1(TCELL,FROM1(TCELL)!JJ)
->BAD PARM %UNLESS JJ=QQQ
FPTR=FPTR+16
->NEXT PARM
ENTRY SEQ: ! CODE FOR RT ENTRY
!
! RETURN ANY STRING WSPACE HERE. CAN BE USED AGAIN FOR RESULT
!
%WHILE TWSP#0 %CYCLE
POP(TWSP,QQQ,JJ,III)
RETURN WSP(QQQ,268)
%REPEAT
%IF JJJ=14 %THEN %START; ! EXTERNAL
CURRINF_NMDECS=CURRINF_NMDECS!2
PB3(CALLXB,1,0)
GXREF(STRING(RDISP),0,0,CA-3)
%FINISH %ELSE %START
%IF NAMP&1=0 %THEN %START;! INTERNAL RT CALLS
PB2(CALL,RDISP&255)
%FINISH %ELSE %START
DFETCH(8,LP,RDISP)
PB1(CALLV)
%FINISH
%FINISH
!
! CHECK THE PRESERVED REGS 4-RBASE AND FORGET IF CONTENTS
! ARE VULNERABLE TO A ROUTINE CALL
!
ROUT=1; TYPE=TYPEP; NAM=NAMP
PREC=PRECP; PTYPE=PT
%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 ABORT
%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 SETLINE
!***********************************************************************
!* UPDATE THE STATEMENT NO *
!***********************************************************************
%INTEGER I
%IF PARM_LINE#0 %START
I=UCONSTTRIP(SLINE,X'41',0,LINE<<16!CURRINF_DIAGINF+2)
%FINISH
%IF PARM_PROF#0 %THEN %START
I=PROFAAD+4+4*LINE
%FINISH
%END
%ROUTINE STORE TAG(%INTEGER KK, SLINK)
%INTEGER Q, QQ, QQQ, I, TCELL
%RECORD(LISTF)%NAME LCELL
TCELL=TAGS(KK)
Q=PTYPE<<16!LEVEL<<8!RBASE<<4!J
ABORT %UNLESS (KFORM!ACC)>>16=0
QQQ=SLINK<<16!KFORM
QQ=SNDISP<<16!ACC
%IF FROM1(TCELL)>>8&63=LEVEL %THEN %START
FAULT(7,0,KK)
Q=FROM1(TCELL)&X'C000'!Q;! COPY USED BITS ACCROSS
REPLACE123(TCELL,Q,QQ,QQQ)
%FINISH %ELSE %START
I=ASL; %IF I=0 %THEN I=MORE SPACE
LCELL==ASLIST(I)
ASL=LCELL_LINK
LCELL_LINK=TAGS(KK)!CURRINF_NAMES<<18
LCELL_S1=Q; LCELL_S2=QQ; LCELL_S3=QQQ
TAGS(KK)=I
CURRINF_NAMES=KK
%FINISH
%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 *
!***********************************************************************
%INTEGER QQQ,KK
%RECORD(LISTF)%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)
KK=LCELL_S1
LCELL_S1=KK!X'8000'
MIDCELL=LCELL_S2
QQQ=LCELL_S3
PTYPE=KK>>16; USEBITS=KK>>14&3
OLDI=KK>>8&63; I=KK>>4&15; J=KK&15
SNDISP=MIDCELL&X'FFFF0000'//X'10000'
ACC=MIDCELL&X'FFFF'
K=QQQ>>16
KFORM=QQQ&X'FFFF'
LITL=PTYPE>>14
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
%ROUTINE EVEN ALIGN
!***********************************************************************
!* SETS N TO EVEN WORD BOUNDARY. SINCE FRAMES ARE DOUBLE *
!* WORD ALIGNED THIS MEANS 64 BIT QUANTITIES ARE 64 BIT ALIGNED *
!* AND CAN BE REFERNCED IN A SINGLE CORE CYCLE *
!***********************************************************************
%IF N&7=4 %THEN RETURN WSP(N,1) %AND N=N+4
%END
%ROUTINE BYTECUT(%INTEGER ODDEVEN)
!***********************************************************************
!* ETOS HAS A WORD. EXTRACT HIGH OR LOW ORDER BYTE *
!***********************************************************************
%IF ODDEVEN=0 %THEN %START
PB2(LDCB,-8)
PB2(ROTSHI,0)
%FINISH %ELSE %START
PBW(LDCW,255)
PB1(LAND)
%FINISH
%END
%ROUTINE DSTORE(%INTEGER SIZE,LEVEL,DISP)
!***********************************************************************
!* STORE SIZE(BYTES) FROM DISP(BYTES) IN DISPLAY 'LEVEL' *
!***********************************************************************
%INTEGER LEVELCODE,WDISP,OPCODE,WSTORE
ABORT %UNLESS 0<=DISP<=4096
WDISP=DISP//2
WSTORE=SIZE
%IF LEVEL=0 %THEN LEVELCODE=0 %AND OPCODE=STOW %ELSE %C
%IF LEVEL=RLEVEL %THEN LEVELCODE=1 %AND OPCODE=STLW %ELSE %C
LEVELCODE=2 %AND OPCODE=STIW
%IF SIZE=1 %START; ! BYTE STORE VIA ARRAY METHOD
%IF LEVELCODE=2 %THEN PB2W(LIAW,RLEVEL-LEVEL,WDISP) %C
%ELSE PBW(OPCODE-2,WDISP)
PB1(EXCH)
PB1(LDC0+(1!!DISP&1))
PB1(EXCH)
PB1(STB)
%RETURN
%FINISH
%WHILE WSTORE>0 %CYCLE
%IF WSTORE>=4 %AND LEVELCODE#2 %START;! OPTIMISE WITH ST DOUBLES
PBW(STODW-2*LEVELCODE,WDISP)
WSTORE=WSTORE-4
WDISP=WDISP+2
%FINISH %ELSE %START
%IF LEVELCODE=2 %THEN PB2W(OPCODE,RLEVEL-LEVEL,WDISP) %C
%ELSE PBW(OPCODE,WDISP)
WSTORE=WSTORE-2
WDISP=WDISP+1
%FINISH
%REPEAT
%END
%ROUTINE DFETCHAD(%INTEGER SEGNO,LEVEL,DISP)
!***********************************************************************
!* FETCH ADDRESS OF DISP(BYTES) IN DISPLAY 'LEVEL' *
!***********************************************************************
%INTEGER LEVELCODE,WDISP,OPCODE
WDISP=DISP//2
%IF LEVEL=0 %THEN LEVELCODE=0 %AND OPCODE=LOAW%ELSE %C
%IF LEVEL=RLEVEL %THEN LEVELCODE=1 %AND OPCODE=LLAW %ELSE %C
LEVELCODE=2 %AND OPCODE=LIAW
PB1(LSSN) %IF SEGNO=YES
%IF LEVELCODE=2 %THEN PB2W(OPCODE,RLEVEL-LEVEL,WDISP) %C
%ELSE PBW(OPCODE,WDISP)
%END
%ROUTINE DFETCH(%INTEGER SIZE,LEVEL,DISP)
!***********************************************************************
!* FETCH SIZE(BYTES) FROM DISP(BYTES) IN DISPLAY 'LEVEL' *
!***********************************************************************
%INTEGER LEVELCODE,WDISP,OPCODE,WFETCH
WDISP=DISP//2+(SIZE-1)>>1
WFETCH=SIZE
%IF SIZE=8 %START
DFETCHAD(NO,LEVEL,DISP)
PB2(ROPS,37); ! FETCH LONREAL
%RETURN
%FINISH
%IF LEVEL=0 %THEN LEVELCODE=0 %AND OPCODE=LDOW %ELSE %C
%IF LEVEL=RLEVEL %THEN LEVELCODE=1 %AND OPCODE=LDLW %ELSE %C
LEVELCODE=2 %AND OPCODE=LDIW
%IF SIZE=4 %AND LEVELCODE=2 %THEN %START
DFETCHAD(NO,LEVEL,DISP)
PB1(LDDW)
%RETURN
%FINISH
%WHILE WFETCH>0 %CYCLE
%IF WFETCH>=4 %AND LEVELCODE#2 %START;! NO LD INTERMEDIATE AS YET!
PBW(LDODW-2*LEVELCODE,WDISP-1)
WDISP=WDISP-2
WFETCH=WFETCH-4
%FINISH %ELSE %START
%IF LEVELCODE=2 %THEN PB2W(OPCODE,RLEVEL-LEVEL,WDISP) %C
%ELSE PBW(OPCODE,WDISP)
WFETCH=WFETCH-2
WDISP=WDISP-1
%FINISH
%REPEAT
%IF SIZE=1 %THEN BYTECUT(DISP&1)
%END
%ROUTINE BULKM(%INTEGER MODE,L,D2)
!***********************************************************************
!* PLANT CODE TO MOVE L BYTES (L KNOWN AT COMPILE TIME) FROM *
!* ETOS-2,ETOS-3 TO ETOS,ETOS-1 *
!* IF MODE =0 SET L BYTES TO D2(0 OR X'80') *
!* *
!* L MAY BE GREATER THAN 4095 *
!***********************************************************************
%INTEGER W2
%IF MODE=0 %START; ! CLEAR
W2=D2<<8!D2
PB1(REPL2) %UNLESS L=2
PBW(LDCW,D2)
PB2(TLATE2,STIND); ! CLEAR FIRST WORD
L=L-2
%RETURN %IF L=0
PB3(REPL2,INCB,1); ! FOR PROPAGATION
%FINISH
PB1(EXCH2); ! PARAMS WRONG WAY UP
%IF L<=511 %START
PB2(STLATE,X'31')
PB2(MOVB,L>>1)
%FINISH %ELSE %START
PBW(LDCW,L>>1)
PB3(STLATE,X'42',MOVW)
%FINISH
%END; ! OF ROUTINE BULK M
%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
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 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_S1 = TAGINF_PTYPE<<16!2
CURRT_OPND1_D = NAME
CURRT_OPND1_XTRA = NAME
%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_S1=OPTYPE<<16!LOCALIR
CURRT_OPND1_D=TEMP
%RESULT=CELL
%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,REFT
CELL=NEWTRIP
CURRT==TRIPLES(CELL)
CURRT_OPERN=OPERN
CURRT_OPTYPE=OPTYPE
CURRT_FLAGS=FLAGS
CURRT_OPND1=OPND1
%IF OPND1_FLAG=REFTRIP %START
REFT==TRIPLES(OPND1_D)
%IF REFT_CNT=0 %THEN REFT_PUSE=CELL
REFT_CNT=REFT_CNT+1
%FINISH
%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,REFT
CELL=NEWTRIP
CURRT==TRIPLES(CELL)
CURRT_OPERN=OPERN
CURRT_OPTYPE=OPTYPE
CURRT_FLAGS=FLAGS
CURRT_OPND1=OPND1
CURRT_OPND2=OPND2
%IF OPND1_FLAG=REFTRIP %START
REFT==TRIPLES(OPND1_D)
%IF REFT_CNT=0 %THEN REFT_PUSE=CELL
REFT_CNT=REFT_CNT+1
%FINISH
%IF OPND2_FLAG=REFTRIP %START
REFT==TRIPLES(OPND2_D)
%IF REFT_CNT=0 %THEN REFT_PUSE=CELL
REFT_CNT=REFT_CNT+1
%FINISH
%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 *
!***********************************************************************
ABORT %UNLESS PLACE<=N %AND PLACE&1=0
%IF SIZE>4 %THEN SIZE=0
%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
%END; ! OF SUBBLOCK CONTAINING PASS2
%INTEGERFN FROMAR2(%INTEGER PTR)
%RESULT=A(PTR)<<8!A(PTR+1)
%END
%INTEGERFN FROMAR4(%INTEGER PTR)
%RESULT=A(PTR)<<24!A(PTR+1)<<16!A(PTR+2)<<8!A(PTR+3)
%END
%ENDOFPROGRAM