         Edinburgh IMP77 Compiler - Version 8.4

    1  %const %integer USE MC = 0,
    2+                 INCLUDE DELSTART = 0
    3  
    4  %BEGIN
    5           {%TRUSTEDPROGRAM}
    6           %INTEGER I,J,K
    7  !%if INCLUDE DELSTART = 1 %start
    8           %CONSTBYTEINTEGERARRAY OPC(0:120)=0,
    9+              8,9,X'10',X'11',X'12',
   10+                X'13',X'20',X'21',X'22',X'23',
   11+                X'30',X'31',X'32',X'33',X'24',
   12+                X'34',0,X'45',X'46',X'47',
   13+                X'54',X'55',X'56',X'57',X'58',X'59',X'5A',X'5B',X'5C',
   14+                X'5D',X'5E',X'5F',X'68',X'69',X'6A',
   15+                X'6B',X'6C',X'6D',X'6E',X'6F',
   16+                X'78',X'79',X'7A',X'7B',X'7C',
   17+                X'7D',X'7E',X'7F',0,X'70',
   18+                X'60',X'50',X'4E',X'4F',X'4C',
   19+                X'4B',X'4A',X'49',X'48',X'44',
   20+                X'43',X'42',X'41',X'40',0,
   21+                X'90',X'98',X'86',X'87',0,
   22+                X'91',X'92',X'94',X'95',X'96',
   23+                X'97',X'9C',X'9E',X'9D',X'9F',
   24+                X'82',X'84',X'85',0,X'88',
   25+                X'89',X'8A',X'8B',X'8C',X'8D',
   26+                X'8E',X'8F',0,X'D0',X'D1',
   27+                X'D2',X'D4',X'D5',X'D6',X'D7',
   28+                X'D8',X'DC',X'DD',X'DE',X'DF',
   29+                X'D3',0,X'F1',X'F2',X'F3',
   30+                X'F8',X'F9',X'FA',X'FB',X'FC',
   31+                X'FD',0,10,4,X'80';
   32           %CONSTINTEGERARRAY NEM(0:120)=M'CNOP',
   33+                 M'SSK',M'ISK',M'LP',M'LN',M'LT',
   34+                M'LC',M'LPD',M'LND',M'LTD',M'LCD',
   35+                M'LPE',M'LNE',M'LTE',M'LCE',M'HD',
   36+                M'HE',0,M'BAL',M'BCT',M'BC',
   37+                'N',M'CL','O','X','L','C','A','S','M','D',
   38+                M'AL',M'SL',M'LD',M'CD',M'AD',
   39+                M'SD',M'MD',M'DD',M'AW',M'SW',
   40+                M'LE',M'CE',M'AE',M'SE',M'ME',
   41+                M'DE',M'AU',M'SU',0,M'STE',
   42+                M'STD',M'ST',M'CVD',M'CVB',M'MH',
   43+                M'SH',M'AH',M'CH',M'LH',M'EX',
   44+                M'IC',M'STC',M'LA',M'STH',0,
   45+                M'STM',M'LM',M'BXH',M'BXLE',0,
   46+                M'TM',M'MVI',M'NI',M'CLI',M'OI',
   47+                M'XI',M'SDV',M'HDV',M'TDV',M'CKC',
   48+                M'PC',M'WRD',M'RDD',0,M'SRL',
   49+                M'SLL',M'SRA',M'SLA',M'SRDL',M'SLDL',
   50+                M'SRDA',M'SLDA',0,M'SSP',M'MVN',
   51+                M'MVC',M'NC',M'CLC',M'OC',M'XC',
   52+                M'LSP',M'TR',M'TRT',M'ED',M'EDMK',
   53+                M'MVZ',0,M'MVO',M'PACK',M'UNPK',
   54+                M'ZAP',M'CP',M'AP',M'SP',M'MP',
   55+                M'DP',0,M'SVC',M'SPM',M'IDL';
   56           %CONSTBYTEINTEGERARRAY HASHALT(0:218)=20(33),6,
   57+          20(11),1,20(2),4(10),20(7),1(26),20(102),
   58+          20,7,2,9,1,13,20,20,5,20,20,7,1,20,17,1(4),20,5,20,6,20(3);
   59  !%finish
   60           %OWNINTEGERARRAY FIXED GLA(0:28)=0,
   61+                X'30000000',0(2),-1,0,255,0(5),
   62+               X'41100000',0,X'80000000',X'FFFFFF',0(2),
   63+          X'4E000000',0,-4,-8,0(4),X'80000000',X'6492350',M'ERMA';
   64           %CONSTSHORTINTEGERARRAY TSNAME (0:53)=10000(8),
   65+                10001,10000(5),10001,10032,10001(2),10032,
   66+                10000(2),2,1,32,10032(7),10000,11,21,10032(2),11,10000,
   67+                1,32,10000(2),5,10000,10005,11,5,10005,3,0,10000,1,2,
   68+                10001;
   69           %CONSTBYTEINTEGERARRAY BYTES(0:7)=4,1,2,8,4,1,2,8;
   70           %CONSTBYTEINTEGERARRAY GRMAP(0:14)=0,1,2,3,15,16,18,20,22,
   71+                                        4,5,6,7,8,14;
   72         %CONSTBYTEINTEGERARRAY PRECEDENCE (1:12)=0,3,3,3,3,4,4,4,4,5,5,5;
   73           %OWNBYTEINTEGERARRAY TRTABS (0:1283)=128(39),
   74+          1,255(8),0(10),255(7),0(26),255(6),255(26),255(133),
   75+          28(34),8,28,8,28(2),12,28(6),4,28,0(10),
   76+          28(8),24,28(8),32,28,20,28(4),36,28(5),16,28(167),
   77+          0(9),1,0(49),2,0(196),
   78+          0(10),12,0(21),8,20(4),16,20,4,
   79+         20(25),24(26),20(32),0,20,0,28,0,0,
   80+         0(10),12,0(21),0,20(4),16,20,4 ,
   81+          20(25),24(26),20(32),0,20,0,28,0,0,
   82+          128(10),12,128(21),8,20(4),16,20,4,
   83+          20(25),0(26),20(32),20,20,20,28,128(2),
   84+          128(32),8,0,4,0,0,16,0,4,
   85+          0(25),0(26),0(32),0,0,0,28,128,128
   86           %COMMENT TABLE 1 FOR NAMES --2 FOR CONSTS -- 3 FOR TEXT
   87           %COMMENT LAST 129 =TABLE FOR READ LINE KEY AS FOLLOWS.
   88           %COMMENT  0=ILLEGAL,4='''',8=SP,12=NL,16=%,20=NONALPHA,24=ALPHA
   89           %OWNBYTEINTEGERARRAY TYPEFLAG(1:6)=1,2,
   90+                B'1001',B'10001',B'11010',5;
   91           %OWNSHORTINTEGERARRAY WARNINGS(0:30)
   92           %OWNINTEGER MASK1=X'0F0F0F0F'
   93           %OWNINTEGER MASK2=X'0F0F0F0F'
   94           %OWNINTEGER PI1=X'413243F6', PI2=X'A8885A31'
   95           %CONSTINTEGER RELEASE=9,VERSION=18
   96           %CONSTSHORTINTEGER MAXLEVELS=11
   97           %CONSTSHORTINTEGER PTBASE=256
   98           %CONSTSHORTINTEGER SNPT=10006;        ! SPECIALNAME PTYPE
   99           %CONSTINTEGER CODER=12
  100           %CONSTINTEGER  WSPR =11
  101           %CONSTINTEGER  GLA =13
  102           %OWNINTEGER HH1=X'0047002F',HH2=X'00610035'
  103  !
  104  ! THE FOLLOWING FUNNY WORDS ARE CYCLE CONTROL WORDS FOR SEARCHING THE
  105  ! LIST OF FREE REGISTERS. THE TOP HALF IS INC(SIGNED) AND THE BOTTOM
  106  ! TWO BYTES ARE START AND FINISH RESPECTIVELY
  107  !
  108           %CONSTINTEGER GR0   =X'10F1E';   !   15,1,14
  109           %CONSTINTEGER GR1   =X'1010F';   !   1,1,15
  110           %CONSTINTEGER FR0   =X'FFFE1610';!   6,-2,0
  111           %CONSTINTEGER ADDREG=X'FFFF0E01';!  14,-1,1
  112           %CONSTINTEGER SAFE  =X'FFFF0E04';!  14,-1,4
  113           %CONSTINTEGER CLMABL=X'1050E';   !  5,1,14
  114           %SHORTINTEGER CCSIZE,ARSIZE,DSIZE,DUMMY FORMAT
  115           %INTEGER ASL,NNAMES,FLAG,GLAFLAG
  116           %INTEGER CABUF,PPCURR,LCA,OLDLINE,LINE,LENGTH,LENGTHP, %C
  117+                N0,NUM,SNUM,RLEVEL,NMAX,LOPCODE,CONSTPTR, %C
  118+                PLABEL,LEVEL,CA,MARKER1,MARKER2,LABSET,CCSTATE, %C
  119+                CYCLE NUM,CSAVED,CUR CYC VAR,CYC REGS,CYC BITS,CYC ASS
  120  !
  121           %BYTEINTEGER FFLAG,CHECKS,SBFLAG,LAST INST,FAULTY,MONE, %C
  122+                HIT,LET,DIAGS2,LIST,ALLLONG,INHCODE,LINENOS, %C
  123+                DIAGS1,IMPS,CHECKSP,CTYPE,DCOMP,COMPILER,CPRMODE, %C
  124+                UNASS,PRINTMAP,BFFLAG,NMDECS
  125  !
  126           %LONGREAL CVALUE,IMAX
  127           %INTEGER MASK,RBASE,SFLABEL,NEXT,N,MAX ULAB,GSAVED,CODEBASE, %C
  128+                P,Q,R,S,TTOPUT,U,V,NEST,FNAME,NOT USED,FILEPTR, %C
  129+                FILE END,SSTL,QMAX,STMTS,MAINEP1,MAINEP2,MAINEP3, %C
  130+                GLACA,GLACURR,GLACABUF,CYC BASE,CYC ADDR
  131  !
  132           %SHORTINTEGER RELHEAD,EPLINK,LEVELINF,DVHEAD,GLAHOLES, %C
  133+                CONSTL2,CONSTL4,CONSTL6,CONSTL8,RNEXT
  134  !
  135  ! THIS IS THE LIMIT OF INITIALISATION OF SCALARS TO ZERO
  136  !
  137           %INTEGER QUICK,MARGIN,IOCP1,IOCP2,IOCP3,XLABEL,IMPMON1, %C
  138+                IMPMON2,IMPMON3,STMTSHELD,STOPSTM,TOPPTR,PREV3CL,FILEADDR
  139           %SHORTINTEGERARRAY STPTRS (1:15)
  140           %ROUTINESPEC FETCH AR
  141           %ROUTINESPEC STORE AR(%INTEGERNAME I)
  142           %INTEGERARRAY REGISTER,GRUSE,GRINF,GRAT(0:22)
  143           %SHORTINTEGERARRAY A(-7:800)
  144           %INTEGERARRAY SET(0:11)
  145           %SHORTINTEGERARRAY CYCLE,LABEL,SBR,L,M,NAMES(0:11)
  146           %SHORTINTEGERARRAY AVLWSP(0:7,0:MAXLEVELS)
  147           %INTEGERARRAY UVARREG(5:14)
  148           %RECORDFORMAT OPTFORM(%BYTEINTEGER COUNT,TYPE,%INTEGER BITS,%C
  149+                   PTYPE,XTRA)
  150           %RECORD(OPTFORM)%ARRAY OPTINF(0:25)
  151           %INTEGER OPTPTR
  152           %BYTEINTEGERARRAY GLABUF,CODE(0:268)
  153           %SYSTEMINTEGERMAPSPEC COMREG(%INTEGER N)
  154           !*INSERT
  155           %BEGIN
  156           {%SHORTROUTINE}
  157           %INTEGER FREE,TOTAL
  158  ! BLOCK TO ALLOCATE AVAILABLE STACK SPACE TO THE MAIN ARRAYS
  159           FILE ADDR=COMREG(46)
  160           %IF FILE ADDR#0 %THEN %START;  ! ON EMAS
  161              TOTAL=INTEGER(FILEADDR); NNAMES=255
  162              %IF TOTAL>8000 %THEN NNAMES=511
  163              %IF TOTAL>32000 %THEN NNAMES=1023
  164              %IF TOTAL>409600 %OR COMREG(27)&8#0 %THEN NNAMES=2047
  165              DSIZE=7*NNAMES; ASL=DSIZE<<2
  166              CCSIZE=100+NNAMES; ->Label2
  167           %FINISH
  168           FREE=COMREG(1)-ADDR(TOTAL)-6000; ! ON IBM 370
  169           %CYCLE I=2,1,4;
?Non-local
  170                          ;   ! ALLOWS 255,511,1023 OR 2047 NAMES
  170              NNAMES=128*2^^I-1
  171              DSIZE=7*NNAMES
  172              ASL=DSIZE<<2
  173              CCSIZE=250+100*I
  174              TOTAL=CCSIZE+ASL+DSIZE<<1
  175              ->Label1 %IF TOTAL>FREE
  176           %REPEAT
  177           ->Label2
  178  Label1:       CCSIZE=CCSIZE-100
  179           NNAMES=NNAMES>>1
  180           ASL=(ASL>>1+(FREE-CCSIZE-DSIZE))//2;! HALF 'EXTRA' SPACE TO ASL
  181           DSIZE=DSIZE>>1
  182  Label2:       ASL=32760%IF ASL>32760
  183           ASL=ASL&X'FFFFFFF0'
  184           %END
  185          %BYTEINTEGERARRAY CC(0:CCSIZE+10), %C
  186+             ASLIST(0:ASL+32),LETT(0:DSIZE+20)
  187           %SHORTINTEGERARRAY WORD,TAGS(0:NNAMES)
  188           %SYSTEMROUTINESPEC IOCP(%INTEGER A,B)
  189           %ROUTINESPEC CODE OUT
  190           %ROUTINESPEC CNOP(%INTEGER I,J)
  191           %ROUTINESPEC PCONST(%INTEGER X)
  192           %ROUTINESPEC PSI(%INTEGER OPCODE,J,BASE,DISP)
  193           %ROUTINESPEC PSS(%INTEGER OPCODE,N,BASE,DISP,P,Q)
  194           %ROUTINESPEC PRX(%INTEGER OPCODE,R1,R2,BASE,DISP)
  195           %ROUTINESPEC PLANT(%INTEGER VALUE)
  196           %ROUTINESPEC PRR (%INTEGER OPCODE,R1,R2)
  197           %ROUTINESPEC PGLA(%INTEGER I,J,K)
  198           %SYSTEMROUTINESPEC LPUT(%INTEGER A,B,C,D)
  199           %ROUTINESPEC SET PERMBASE
  200           %ROUTINESPEC PLUG(%INTEGER AREA,J,K)
  201           %ROUTINESPEC PRHEX(%INTEGER VALUE,PLACES)
  202           %ROUTINESPEC RESTORE(%SHORTINTEGER HEAD)
  203           %ROUTINESPEC GET ENV(%SHORTINTEGERNAME HEAD)
  204  !         %INTEGERFNSPEC NEWCELL
  205           %ROUTINESPEC INSERTAFTER(%SHORTINTEGERNAME STAD,%INTEGER S1,S2)
  206  !         %ROUTINESPEC INSERTATEND(%SHORTINTEGERNAME S,%INTEGER A,B)
  207           %ROUTINESPEC FROM12(%INTEGER CELL,%INTEGERNAME S1,S2)
  208           %ROUTINESPEC FROM123(%INTEGER CELL,%INTEGERNAME S1,S2,S3)
  209           %ROUTINESPEC POP(%SHORTINTEGERNAME CELL,%INTEGERNAME S1,S2)
  210           %ROUTINESPEC POP123(%SHORTINTEGERNAME C,%INTEGERNAME P,Q,R)
  211           %ROUTINESPEC PUSH(%SHORTINTEGERNAME CELL,%INTEGER S1,S2)
  212           %ROUTINESPEC PUSH123(%SHORTINTEGERNAME C,%INTEGER S1,S2,S3)
  213           %INTEGERFNSPEC FIND(%INTEGER LAB,LIST)
  214           %INTEGERFNSPEC FIND3(%INTEGER LAB,LIST)
  215           %ROUTINESPEC MLINK(%INTEGERNAME CELL)
  216           %ROUTINESPEC REPLACE2(%INTEGER CELL,S2)
  217           %ROUTINESPEC REPLACE1(%INTEGER CELL,S1)
  218           %ROUTINESPEC REPLACE123(%INTEGER CELL,S1,S2,S3)
  219           %INTEGERFNSPEC FROM2(%INTEGER CELL)
  220           %INTEGERFNSPEC FROM1(%INTEGER CELL)
  221           %INTEGERFNSPEC FROM3(%INTEGER CELL)
  222  !         %ROUTINESPEC CHECK ASL
  223  !%if INCLUDE DELSTART = 1 %start
  224           %ROUTINESPEC COMPARE
  225           %ROUTINESPEC PNAME
  226           %ROUTINESPEC CONST(%INTEGER MODE)
  227           %ROUTINESPEC CONSTLIST
  228           %ROUTINESPEC TEXTTEXT
  229           %ROUTINESPEC READ LINE(%BYTEINTEGER N,CHAR)
  230  !%finish
  231           %ROUTINESPEC FROMAR8(%INTEGER PTR,%LONGREALNAME VALUE)
  232           %ROUTINESPEC FROMAR4(%INTEGER PTR,%INTEGERNAME VALUE)
  233           %ROUTINESPEC TOAR8(%INTEGER PTR,%LONGREAL VALUE)
  234           %ROUTINESPEC TOAR4(%INTEGER PTR,VALUE)
  235           %ROUTINESPEC CSS(%INTEGER P,MODE)
  236           %ROUTINESPEC FAULT(%INTEGER N,FNAME)
  237            %ROUTINESPEC ABORT
  238           %ROUTINESPEC PRINT USE
  239           %ROUTINESPEC PRINTNAME (%INTEGER N)
  240  %SYSTEM %C
  241+          %ROUTINESPEC RECODE (%INTEGER START,FINISH,CA)
  242           %ROUTINESPEC MESSAGE(%INTEGER N)
  243           {%FAULT 1,2->OFL,9->INEND,18->SUBSCHAR}
  244           %on %event 1,2,9{,18} %start
  245             ->OFL %if event_event = 1
  246             ->OFL %if event_event = 2
  247             ->INEND %if event_event = 9
  248             {->SUBSCHAR %if event_event = 18}
  249           %finish
  250   ! START OF COMPILATION
  251           %BEGIN
  252  !***********************************************************************
  253  !*       THIS BLOCK INITIALISE THE COMPILER SCALARS AND ARRAYS         *
  254  !*       WAS ORIGINALLY ROUTINE 'INITIALISE'.                          *
  255  !*       THE INITIALISATION OF THE CONSTANT LISTS WITH THE VALUES      *
  256  !*       IN PERM MAY BE OMITTED IN BATCH OR CUT-DOWN VERSIONS.         *
  257  !***********************************************************************
  258           {%SHORTROUTINE}
  259  !%if INCLUDE DELSTART = 1 %start
  260           %CONSTBYTEINTEGERARRAY ILETT(0: 410)= 11,
  261+     'S','E','L','E','C','T','I','N','P','U','T', 12,'S','E','L','E',
  262+     'C','T','O','U','T','P','U','T',  7,'N','E','W','L','I','N','E',
  263+       5,'S','P','A','C','E', 10,'S','K','I','P','S','Y','M','B','O',
  264+     'L', 10,'R','E','A','D','S','T','R','I','N','G',  8,'N','E','W',
  265+     'L','I','N','E','S',  6,'S','P','A','C','E','S', 10,'N','E','X',
  266+     'T','S','Y','M','B','O','L', 11,'P','R','I','N','T','S','Y','M',
  267+     'B','O','L', 10,'R','E','A','D','S','Y','M','B','O','L',  4,'R',
  268+     'E','A','D',  5,'W','R','I','T','E',  7,'N','E','W','P','A','G',
  269+     'E',  4,'A','D','D','R',  6,'A','R','C','S','I','N',  3,'I','N',
  270+     'T',  5,'I','N','T','P','T',  6,'F','R','A','C','P','T',  5,'P',
  271+     'R','I','N','T',  7,'P','R','I','N','T','F','L',  4,'R','E','A',
  272+     'L',  7,'I','N','T','E','G','E','R',  3,'M','O','D',  6,'A','R',
  273+     'C','C','O','S',  4,'S','Q','R','T',  3,'L','O','G',  3,'S','I',
  274+     'N',  3,'C','O','S',  3,'T','A','N',  3,'E','X','P', 11,'C','L',
  275+     'O','S','E','S','T','R','E','A','M', 11,'B','Y','T','E','I','N',
  276+     'T','E','G','E','R', 12,'S','H','O','R','T','I','N','T','E','G',
  277+     'E','R',  6,'R','A','D','I','U','S',  6,'A','R','C','T','A','N',
  278+       6,'L','E','N','G','T','H', 11,'P','R','I','N','T','S','T','R',
  279+     'I','N','G',  2,'N','L',  8,'L','O','N','G','R','E','A','L',  7,
  280+     'P','R','I','N','T','C','H',  6,'R','E','A','D','C','H',  6,'S',
  281+     'T','R','I','N','G',  8,'R','E','A','D','I','T','E','M',  8,'N',
  282+     'E','X','T','I','T','E','M',  6,'C','H','A','R','N','O',  8,'T',
  283+     'O','S','T','R','I','N','G', 10,'F','R','O','M','S','T','R','I',
  284+     'N','G',  6,'R','E','C','O','R','D',  5,'A','R','R','A','Y', 10,
  285+     'S','E','T','M','A','R','G','I','N','S',4,'I','M','O','D',
  286+      2,'P','I',6,'N','E','X','T','C','H',255;
  287  !%finish
  288  !%if USE MC = 1 %start
  289  !         *XC_CABUF(108),CABUF ;!CLEAR INTEGER
  290  !         *XC_FFLAG(24),FFLAG;          !CLEAR BYTE FLAG VARIABLES
  291  !         *XC_MASK(144),MASK;           ! CLEAR WORK VARIABLES
  292  !%finish
  293           STMTSHELD=0; TOPPTR=500
  294           IMAX=(-1)>>1;PLABEL=26999
  295           LABSET=3<<30;LETT(0)=0
  296           N0=27; N=12; MARGIN=1024
  297           MAX ULAB=NNAMES+16384;   ! LARGEST VALID USER LABEL
  298           GLACA=N0<<2; GLACABUF=GLACA
  299           CHECKSP=1 ;  CHECKS=1
  300           LINENOS=1; DIAGS1=1;  MONE=1
  301           LIST=1; SFLABEL=21999; UNASS=1
  302           LET=1; XLABEL=19999;      ! FOR EXIT STATEMENTS
  303           ARSIZE=480
  304            QUICK=11009
  305           MAINEP1=4; MAINEP2=M'S#GO';  ! DEFAULT ENTRY POINT
  306           IOCP1=6; IOCP2=M'S#IO'; IOCP3=M'CPXX'
  307           IMPMON1=8; IMPMON2=M'S#IM'; IMPMON3=M'PMON'
  308           !*INSERT
  309           %IF FILE ADDR#0 %THEN %START
  310             FILE PTR=FILE ADDR+INTEGER(FILE ADDR+4)
  311             FILE END=FILE ADDR+INTEGER(FILE ADDR)
  312           %FINISH
  313           I=COMREG(27)
  314           %IF I&2=2 %THEN LIST=0
  315           %IF I&4=4 %THEN LINENOS=0
  316           %IF I&16=16 %THEN UNASS=0
  317           %IF I&32=32  %THEN CHECKS=0
  318           %IF I&(128<<8)#0 %THEN PRINTMAP=1
  319           %IF I&(32<<8)#0 %THEN LET=0
  320           %IF I&64=64 %THEN DIAGS1=0
  321           DIAGS2=I>>18&1
  322           TTOPUT=I>>21&1
  323           %IF I&(1<<16)#0 %THEN %START
  324              CHECKS=0; CHECKSP=0
  325              LINENOS=0; UNASS=0
  326           %FINISH
  327           GLAFLAG=CHECKSP;           ! GLAFLAG SHOULD BE SET TO 0 IF
  328  !                                     IMPS IS COMPILED NON OPTIMISED.
  329           WARNINGS(0)=0
  330           IMPS=I>>23&1;              ! BIT SET IF IMPS REQUESTED
  331  !
  332  ! OPEN OBJECT FILE HERE BEFORE MORE PAGES OF COMPILER CODE
  333  ! ARE PAGED IN AND SUB-SYSTEM PAGES MOVE OUT
  334  !
  335           LPUT(0,IMPS<<1+1,RELEASE,VERSION)
  336           NEWLINES(3); SPACES(20)
  337           printstring("E.R.C.C. IMP")
  338           %IF IMPS#0 %THEN printstring("S")
  339           printstring(" COMPILER RELEASE")
  340           WRITE(RELEASE,1)
  341           printstring(" VERSION")
  342           WRITE(VERSION,2)
  343           NEWLINES(3)
  344           WRITE(NNAMES,5); WRITE(ASL,5)
  345  !%if USE MC = 1 %start
  346  !         *L_1,SET; *XC_0(48,1),0(1)
  347  !         *L_1,CYCLE;  *XC_0(24,1),0(1)
  348  !         *L_1,NAMES; *XC_0(24,1),0(1)
  349  !         *L_1,LABEL;  *XC_0(24,1),0(1)
  350  !         *L_1,SBR;    *XC_0(24,1),0(1)
  351  !         *L_1,AVL WSP; *XC_0(192,1),0(1)
  352  !         *L_1,REGISTER;  *XC_0(92,1),0(1)
  353  !         *L_1,GRUSE;     *XC_0(92,1),0(1)
  354  !         *L_1,GRINF;     *XC_0(92,1),0(1)
  355  !         *L_1,GRAT; *XC_0(92,1),0(1)
  356  !%finish
  357           REGISTER(10)=-1; GRUSE(10)=12
  358           REGISTER(11)=-1; REGISTER(13)=-1
  359  !%if USE MC = 1 %start
  360  !         *L_1,UVARREG+4; *XC_0(40,1),0(1);!NO USER DEFINED REGS
  361  !%finish
  362           %CYCLE I=0,16,ASL-16
?Non-local
  363               SHORT INTEGER(ADDR(ASLIST(I))+30)=I
  364           %REPEAT
  365           INTEGER(ADDR(ASLIST(0)))=-1
  366           INTEGER(ADDR(ASLIST(4)))=-1
  367           INTEGER(ADDR(ASLIST(8)))=-1
  368           INTEGER(ADDR(ASLIST(12)))=X'FFFF0000'
  369           SET PERMBASE
  370           PCONST(X'50FB003C');          ! ST 15,60(11)
  371           PCONST(X'45FC004C');          ! BAL 15,RTI1
  372           %CYCLE I=0,1,NNAMES
?Non-local
  373               WORD(I)=0; TAGS(I)=0
  374           %REPEAT
  375  !
  376  ! NOW DECLARE THE SPECIAL NAMES WHICH ARE IN ARRAY ILETT. A SPECIAL
  377  ! ALTERNATIVE (19) OF PHRASE <SS> IS PROVIDED FOR THIS PURPOSE
  378  !
  379  !%if INCLUDE DELSTART = 1 %start
  380           A(1)=19; K=0; NEXT=1
  381           I=ILETT(0)
  382           %WHILE I<255 %CYCLE
  383              %CYCLE J=1,1,I
?Non-local
  384                  CC(J)=ILETT(K+J)
  385              %REPEAT; CC(J+1)=';'
  386              R=2; Q=ADDR(CC(1)); PNAME
  387              CSS(1,1); K=K+I+1; I=ILETT(K)
  388           %REPEAT
  389  !%finish
  390  !
  391                    A(-7)=2; TOAR4(-6,PI1); TOAR4(-4,PI2)
  392           A(0)=0; A(1)=12; CSS(1,1);      ! COMPILE A BEGIN @ LINE 0
  393           COMREG(24)=16;                ! RETURN CODE
  394           %CYCLE I=1,1,3
?Non-local
  395               PUSH123(CONSTL4,I,0,X'800000E0'+I<<2)
  396               PUSH123(CONSTL4,I<<12,0,X'80000100'+I<<2)
  397           %REPEAT
  398           PUSH123(CONSTL4,-1,0,16)
  399           PUSH123(CONSTL4,255,0,24)
  400           PUSH123(CONSTL4,-4,0,X'800000F8')
  401           PUSH123(CONSTL4,-8,0,X'800000FC')
  402           PUSH123(CONSTL8,X'41100000',0,X'800000C8');! FLOATNG =D'1'
  403           DUMMY FORMAT=0;        ! DUMMY RECORD FORMAT
  404           PUSH(CONSTL6,0,0)
  405           PUSH123(DUMMY FORMAT,0,0,CONSTL6); ! FOR BETTER ERROR RECOVERY
  406           CONSTL6=0
  407           %END
  408  !
  409          ->Label8
  410           %ROUTINE LOAD DATA
  411           {%SHORTROUTINE}
  412  !***********************************************************************
  413  !*       PASS INFORMATION TO LPUT TO ENABLE IT TO GENERATE THE         *
  414  !*       LOADER DATA AND COMPLETE THE PROGRAM FILE.                    *
  415  !***********************************************************************
  416           %INTEGER JJ,KK,FLAG,XTRA,ID1,ID2,ID3
  417           %SHORTINTEGER HEAD
  418           GLACA=(GLACA+7)&(-8)
  419           CONSTPTR=(CONSTPTR+7)&(-8)
  420  !
  421  ! DEFINE ANY DATA EPS FOR DATA IN THE GLA SYMBOL TABLES. THESE CAN NOT
  422  ! BE DEFINED BEFORE THE SIZE OF THE GLA IS KNOWN
  423  !
  424           %WHILE EPLINK#0 %CYCLE
  425              POP123(EPLINK,JJ,XTRA,KK)
  426              HEAD=KK; FLAG=JJ>>24; JJ=JJ&X'FFFFFF'
  427              JJ=JJ+GLACA
  428              POP123(HEAD,ID1,ID2,ID3)
  429              ID3=ID3<<16
  430              LPUT(14,XTRA,JJ,ADDR(ID1))
  431           %REPEAT
  432           CNOP(0,8)
  433           FIXED GLA(2)=GLACA;        ! GLA SYMTABS FROM HEAD OF GLA
  434           FIXED GLA(3)=CA;           ! CODE SYMTABS FROM HEAD OF CODE
  435           FIXED GLA(0)=CA;           ! WILL BE RELOCATED
  436           CODE OUT
  437           I=GLACA-GLACABUF
  438           %IF INHCODE=0 %THEN %START
  439              LPUT(2,I,GLACABUF,ADDR(GLABUF(0))) %UNLESS I=0;! BACK OF GLAP
  440  !
  441  ! NOW SET THE LANGUAGE FLAG(BYTE 4 OF GLA) 1=IMP,3=IMPS
  442  !
  443              BYTE INTEGER(ADDR(FIXED GLA(1)))=16+IMPS<<5;! LANGUAGE FLAG
  444              LPUT(2,N0<<2,0,ADDR(FIXED GLA(0)));     ! FRONT OF GLAP
  445              I=X'E2E2E2E2'
  446              LPUT(4,4,SSTL,ADDR(I))
  447  !
  448  ! NOW PLANT ANY RELOCATION INFO THAT HAS BEEN HELD UP AS IT IS RELATIVE
  449  ! TO THE SYMBOL TABLES. LPUT DEALS ONLY IN CODE & GLA SO THE COMPILER
  450  ! HAS TO ADJUST ST REFEFERNCES TO ALLOW FOR FRONT OF CODE OR GLA
  451  !
  452  !            %WHILE RELHEAD#0 %CYCLE
  453  !               POP123(RELHEAD,JJ,KK,XTRA)
  454  !               %IF XTRA=4 %THEN %START;    ! CODE ST
  455  !                  KK=KK+CA
  456  !               %FINISH %ELSE %START;       ! GLA ST
  457  !                  KK=KK+GLACA
  458  !               %FINISH
  459  !               LPUT(2,4,JJ,ADDR(KK));      ! OUTPUT ADJUSTED POINTER
  460  !               LPUT(XTRA+16,0,JJ,0);       ! AND RELOCATION INFO
  461  !            %REPEAT
  462  !
  463              LPUT(20,0,0,0);                ! RELOCATE POINTER TO CST
  464              LPUT(20,0,28,0);               ! RELOCATE GLA  HDOFCODE WORD
  465              LPUT(12,0,23<<2,ADDR(FIXEDGLA(27)));! O-P PERM REFERENCE
  466              LPUT(16,0,64,0);               ! DEFINE TOPOFSTORE WORD
  467           %FINISH
  468           SSTL=(SSTL+11)&(-8)
  469           printstring("
  470+ CODE")
  471           WRITE(CA,6); PRINTSTRING(" BYTES      GLAP")
  472           WRITE(GLACA,3); printstring("+")
  473           WRITE(CONSTPTR,1); printstring(" BYTES      DIAG TABLES")
  474           WRITE(SSTL,3); printstring(" BYTES
  475+ TOTAL")
  476           REGISTER(0)=CA; REGISTER(1)=GLACA
  477           REGISTER(2)=0
  478           REGISTER(3)=SSTL
  479           REGISTER(4)=CONSTPTR
  480           K=CA+GLACA+SSTL+CONSTPTR;REGISTER(5)=K
  481           WRITE(K,5); printstring(" BYTES")
  482           %IF IMPS=0 %AND WARNINGS(0)>0 %START
  483              J=WARNINGS(0)
  484              PRINTSTRING("
  485+ THE FOLLOWING LINES ARE NOT ACCEPTABLE TO 2900 IMP:-")
  486              NEWLINE
  487              %CYCLE I=1,1,J
?Non-local
  488                 WRITE(WARNINGS(I),3)
  489                 %EXIT %IF I>=30
  490              %REPEAT
  491              NEWLINE
  492              %IF J>30 %THEN PRINTSTRING("PLUS ") %AND WRITE(J-30,3) %C
  493+                %AND PRINTSTRING(" MORE
  494+ ")
  495           %FINISH
  496           NEWLINE; print symbol(13);    ! MARKER FOR COMP TO PRINT SUMMARY
  497           %IF FAULTY=0 %THEN %START
  498              WRITE(STMTS,7); printstring(" STATEMENTS COMPILED")
  499              %IF GLACA>4096 %THEN printstring("
  500+ WARNING:- GLAP ROOT IS GREATER THAN 4096 BYTES!
  501+ ********
  502+           OBJECT PROGRAM IS LIABLE TO BE VERY INEFFICIENT
  503+ ");
  504             COMREG(47) = STMTS
  505           %FINISH %ELSE %START
  506              printstring("PROGRAM CONTAINS"); WRITE(FAULTY,2)
  507              printstring(" FAULT");  PRINTSYMBOL('S') %IF FAULTY>1
  508              COMREG(47)=FAULTY;             ! FOR COMPER
  509           %FINISH
  510           NEWLINES(2)
  511           I=0; I=8 %IF FAULTY#0
  512           COMREG(24)=I
  513           %IF INHCODE=0 %THEN %C
  514+          LPUT(7,24,0,ADDR(REGISTER(0)));! SUMMARY INFO..REGISTER AS BUF
  515           %STOP
  516           %END
  517           %ROUTINE     FAULT(%INTEGER N,FNAME)
  518           {%SHORTROUTINE}
  519           %INTEGER I,J,QP,FLINE
  520           %IF N=100 %THEN FLINE=LINE %ELSE FLINE=A(STPTRS(1)-1)
  521           QP=Q
  522           printstring("
  523+ *");      WRITE(FLINE,4)
  524           I=3; I=3*LEVEL %IF LIST=0; SPACES(I)
  525           CHECKSP=1; FAULTY=FAULTY+1
  526           INHCODE=1 %UNLESS LET=0;    ! STOP GENERATING CODE
  527           %IF N#100 %THEN %START;     ! ALL EXCEPT SYNTAX
  528              printstring("FAULT"); WRITE(N,2)
  529              MESSAGE(N)
  530              %IF N>100 %THEN %START
  531                 printstring(" DISASTER ")
  532                 ABORT %UNLESS N<=108; %STOP
  533              %FINISH
  534              PRINTNAME(FNAME) %UNLESS FNAME=0
  535           %FINISH %ELSE %START;       ! SYMTAX FAULTS
  536              printstring("  SYNTAX   ")
  537              %IF LINE#OLDLINE %THEN %START
  538                 printstring("
  539+  TEXT MODE FAILURE ")
  540                 WRITE(LINE-OLDLINE,1)
  541                 printstring(" LINES LOST 
  542+ ")
  543                 Q=QMAX
  544              %FINISH %ELSE %START
  545                 %CYCLE
  546                    J=BYTE INTEGER(Q)
  547                    PRINT SYMBOL(J)
  548                    Q=Q+1
  549                 %REPEAT %UNTIL J=';' %OR Q=LENGTH
  550                  %IF I+20+Q-QP<=120 %THEN %START
  551                    NEWLINE; SPACES(I+QMAX-QP+17)
  552                    printstring("!
  553+ ")
  554                 %FINISH
  555              %FINISH
  556           %FINISH
  557           %IF TTOPUT#0 %THEN %START
  558              Q=QP; TTOPUT=0
  559              SELECT OUTPUT(87)
  560              FAULT(N,FNAME)
  561              FAULTY=FAULTY-1
  562              NEWLINE
  563              SELECT OUTPUT(82)
  564              TTOPUT=1
  565           %FINISH
  566           %END
  567  
  568  %ROUTINE WARN(%INTEGER LINE)
  569  !***********************************************************************
  570  !*       STORE A WARNING IF STMNT NOT 2900 IMP COMPATIBLE              *
  571  !***********************************************************************
  572  %INTEGER I,J
  573           I=WARNINGS(0); J=I+1
  574           %IF J>30 %THEN WARNINGS(0)=J %AND %RETURN
  575           %IF LINE>WARNINGS(I) %THEN WARNINGS(J)=LINE %AND %C
  576+             WARNINGS(0)=J
  577  %END
  578           %ROUTINE ABORT
  579           printstring("
  580+ ****************      ABORT********************    ABORT    *******")
  581           RECODE(ADDR(CODE(0)),ADDR(CODE(PPCURR)),CABUF) %UNLESS CA=CABUF
  582           PRINT USE
  583           %MONITOR ; %STOP; %END
  584  %ROUTINE PRINT USE
  585  %INTEGER I, J, K
  586  %ROUTINESPEC USES(%INTEGER I)
  587  %OWNSTRING (10) %ARRAY STATUS(-1:2)="  LOCKED  ",
  588+          "   FREE   "," CLAIMED  "," RESERVED "
  589  %INTEGER NNAMES
  590  !%if USE MC = 1 %start
  591  !         *L_1,TAGS+8;  *MVC_NNAMES(4),8(1)
  592  !%finish
  593           NEWLINES(2)
  594           %CYCLE I=0, 1, 15
  595              ->Label9 %IF 10<=I<=13
  596              ->Label9 %IF REGISTER(I)=0 %AND GRUSE(I)=0 %AND (I>6 %C
  597+                %OR (REGISTER(I+16)=0 %AND GRUSE(I+16)=0))
  598              WRITE(I, 2)
  599              PRINTSTRING(STATUS(REGISTER(I)))
  600              USES(I)
  601              ->Label4 %IF I>6 %OR (REGISTER(I+16)=0=GRUSE(I+16))
  602              SPACES(13-K)
  603              PRINTSTRING(STATUS(REGISTER(I+16)))
  604              USES(I+16)
  605  Label4:          NEWLINE
  606  Label9:       %REPEAT
  607           I=CCSTATE>>16
  608           %IF 1<=I<=2 %THEN %START
  609              %IF I=1 %THEN PRINTSTRING("ARITHMETIC CC ON REG") %C
  610+                %ELSE PRINTSTRING("LOGICAL CC ON REG")
  611              WRITE(CCSTATE&255, 5)
  612              NEWLINE
  613           %FINISH
  614           %RETURN
  615  %ROUTINE PN(%INTEGER N)
  616  %INTEGER J, P, Q, R
  617           %CYCLE J=0, 1, NNAMES
  618              ->FOUND %IF N=TAGS(J)
  619           %REPEAT;  PRINTSTRING(" ??")
  620           K=K+3;  ->Label99
  621  FOUND:   P=WORD(J);  R=LETT(P)
  622           %IF R#0 %THEN %START
  623              %CYCLE Q=1, 1, R
  624                 PRINT SYMBOL(LETT(P+Q))
  625              %REPEAT
  626           %FINISH %ELSE PRINTSTRING("?")
  627           K=K+1+R
  628  Label99: %END
  629  %ROUTINE USES(%INTEGER I)
  630  %SWITCH SW(0:18)
  631  %INTEGER INF, J
  632           PRINTSTRING(" USE = ")
  633           K=0;  J=GRUSE(I);  INF=GRINF(I)
  634           ->SW(J)
  635  SW(0):   PRINTSTRING(" NOT KNOWN");  ->Label99
  636  SW(1):   PRINTSTRING(" I/RESULT ")
  637  Label1:       K=7;  WRITE(INF, 6);  ->Label99
  638  SW(2):   PRINTSTRING(" CONST = ");  ->Label1
  639  SW(3):   PRINTSTRING("  LOCAL   ")
  640  Label2:       PN(INF);  ->Label99
  641  SW(4):
  642  SW(5):
  643  SW(6):   PRINTSTRING(" ERROR  ");  ->Label1
  644  SW(7):   PRINTSTRING(" ADDR OF  ");  ->Label2
  645  SW(8):   PRINTSTRING(" BASE OF  ");  ->Label2
  646  SW(9):   PN(INF&X'FFFF')
  647           PRINTSTRING(" TIMES ");  WRITE(INF>>24, 2);  ->Label99
  648  SW(10):  PRINTSTRING("DOPE V OF ");  ->Label2
  649  SW(11):  %IF INF>0 %THEN ->Label111
  650           PRINTSTRING(" 4K FOR LAB ")
  651           K=8;  WRITE(\INF, 6);  ->Label99
  652  Label111:     PRINTSTRING(" 4096 * ");  K=8;  WRITE(INF, 6);  ->Label99
  653  SW(12):  PRINTSTRING(" BASE AT  ");  ->Label1
  654  SW(13):  PRINTSTRING(" STR LEN  ");  ->Label1
  655  SW(14):  PRINTSTRING(" CYCLE VAR ");  ->Label99
  656  SW(15):  PRINTSTRING(" RT PARAM ");  ->Label99
  657  SW(16):  PRINTSTRING(" RSLN PARM ");  ->Label1
  658  SW(17):  PRINTSTRING(" ADDR SST ");  ->Label1
  659  SW(18):  PRINTSTRING(" PERMBASE ");  ->Label99
  660  Label99: %END
  661  %END
?J unused
  662  
  663  
  664           %ROUTINE MESSAGE(%INTEGER N)
  665  !***********************************************************************
  666  !*       OUTPUTS AN ERROR MESSAGE STORED IN A COMPRESSED FORMAT        *
  667  !***********************************************************************
  668           %CONSTBYTEINTEGERARRAY WORD(0: 330)=0,%C
  669+             1,   1,   2,   3,   0,   2,   4,   5,
  670+             7,   8,   4,   9,  10,  11,   7,   5,
  671+             9,   4,  12,   0,   6,   9,   4,   7,
  672+             8,   7,  10,   7,   8,   0,   8,  13,
  673+            14,  11,  16,   9,  13,  14,  11,  16,
  674+            10,  13,  14,  11,  16,  11,   4,  11,
  675+             7,   0,  13,   1,  18,   0,   0,  14,
  676+             2,   3,  20,   0,  15,  18,  20,   0,
  677+             0,  16,  10,  11,   7,   0,  17,  11,
  678+            21,  10,   0,  18,   9,  23,  12,   0,
  679+            19,  24,  25,  26,  14,  20,   9,  10,
  680+            27,  28,  22,  30,  14,  11,  16,  23,
  681+            21,  10,  27,  28,  24,  31,  27,  32,
  682+            28,  25,  34,  35,  11,  32,  26,  37,
  683+            38,  24,  39,  28,  21,  40,  18,   0,
  684+            29,  41,  11,  42,   0,  30,  44,  45,
  685+            26,  46,  31,  48,  45,  26,  46,  34,
  686+             2,   3,  49,   0,  35,   2,   3,  21,
  687+            49,  36,  50,  37,  25,   0,  39,  31,
  688+            52,   0,   0,  40,  23,  53,   0,   0,
  689+            42,  55,  35,  27,  28,  43,  56,  57,
  690+            45,   0,  44,  50,  58,   0,   0,  45,
  691+            24,  25,  26,  58,  47,  50,  59,   0,
  692+             0,  48,  60,  61,  27,  38,  51,  62,
  693+             2,   3,   0,  52,   1,  18,  63,  62,
  694+            53,  62,  18,   0,   0,  54,  64,  45,
  695+            26,  46,  57,  65,  18,   0,   0,  62,
  696+            11,  66,  10,   0,  64,  67,  18,   0,
  697+             0,  65,  67,  11,  27,  66,  66,  50,
  698+            69,  70,   0,  67,  11,  69,  10,   0,
  699+            69,  67,  45,  26,  46,  70,  50,  55,
  700+            23,   0,  71,  35,  27,  55,  28,  72,
  701+            50,  55,  72,   0,  73,  74,  45,  26,
  702+            46,  74,  74,  24,  66,   0,  81,  50,
  703+            76,   0,   0,  82,  41,  11,  78,  10,
  704+            83,  80,  76,   0,   0,  84,  50,  69,
  705+            70,   0,  85,  81,   0,   0,   0,  98,
  706+            84,   0,   0,   0,  99,  84,   0,   0,
  707+             0, 103,  87,   2,  88,   0, 104,   2,
  708+             3,  87,   0, 106,  55,  58,   2,  88,
  709+           108,  89,  61,  27,  38, 127,  90,   0,
  710+             0,   0
  711            %CONSTINTEGERARRAY LETT(0: 92)=0,%C
  712+         X'48B02868',X'51EF0000',X'342EC800',X'30222B00',
  713+         X'25D60B13',X'13EF9000',X'4CB40000',X'52E91940',
  714+         X'4EE9A0D0',X'382D2800',X'39F40000',X'16527C80',
  715+         X'19F26858',X'40320B4B',X'50B29800',X'067F9C0B',
  716+         X'0C000000',X'35339A5D',X'1C000000',X'15C49800',
  717+         X'49F5A25D',X'14000000',X'10A36380',X'5E4F71C0',
  718+         X'39E00000',X'3CC00000',X'25C00000',X'171094E7',
  719+         X'38000000',X'0474A858',X'48A16000',X'25D429CB',
  720+         X'48000000',X'0F236140',X'58324845',X'30A00000',
  721+         X'18356500',X'4E8D7500',X'30B62B00',X'09E4C800',
  722+         X'31130000',X'10B3A3A9',X'38000000',X'48B4AC9C',
  723+         X'3EB40000',X'0DEEA171',X'50000000',X'48B3AB28',
  724+         X'30B62B26',X'258C29C3',X'30000000',X'17107500',
  725+         X'35338303',X'0CA40000',X'4E924B8E',X'06520E40',
  726+         X'25D3490A',X'0DEE9D00',X'15932800',X'4EA20000',
  727+         X'0D019000',X'192E4CD0',X'06800000',X'1709A000',
  728+         X'08A74B80',X'19F26868',X'4EA2705B',X'14000000',
  729+         X'48A37C88',X'3E059069',X'38000000',X'3E059069',
  730+         X'3E400000',X'48B37B2B',X'512F7000',X'16354D83',
  731+         X'30AE1940',X'41E9750B',X'48000000',X'39EE0000',
  732+         X'112D2BA7',X'25EE0B13',X'53200000',X'04849167',
  733+         X'4C224B13',X'53200000',X'382D2CC0',X'31EE3800',
  734+         X'15A00000',X'4CA5FA5B',X'43ED0BAB',X'05800000'
  735          
  736           %INTEGER I,J,K,M,Q,S
  737           printstring(" (")
  738           I=-4
  739           I=I+5 %UNTIL N=WORD(I) %OR I= 326
  740           %CYCLE J=1,1,4
  741              K=WORD(I+J)
  742              %IF K=0 %THEN %EXIT
  743              SPACE %UNLESS J=1
  744              %CYCLE
  745                 M=LETT(K); S=26
  746                 %CYCLE
  747                    Q=M>>S&31; 
  748                    %IF Q=31 %THEN Q=-32
  749                    %IF Q\=0 %THEN PRINT SYMBOL(Q+64)
  750                    S=S-5
  751                 %REPEAT %UNTIL S<0
  752                 K=K+1
  753              %REPEAT %UNTIL M&1=0
  754           %REPEAT
  755           printstring(") ")
  756           %END
  757  INEND:   FAULT(108,0)
  758  OFL:     FAULT(38,0); ->Label8
  759  SUBSCHAR:LINE=LINE+1;FAULT(48,0)
  760           SPACES(5)
  761  Label15:      READSYMBOL(I); ->Label8 %IF I=10
  762           PRINTSYMBOL(I); ->Label15
  763           %ROUTINE PRINTNAME (%INTEGER N)
  764           %IF N<0 %THEN %START
  765              N=-N
  766              %IF 16384<=N<=MAX ULAB %THEN N=N-16384 %ELSE %START
  767                 WRITE(N,5); ->Label99
  768              %FINISH
  769         %FINISH
  770           printstring(" ")
  771  !%if USE MC = 1 %start
  772  !         **1,WORD(N)
  773  !         *A_1,LETT; *->P5;             ! USE PRINTSTRING IN PERM
  774  !%finish
  775  Label99:      %END
  776  !
  777  !***********************************************************************
  778  !*       IMP CODE PLANTING ROUTINES                                    *
  779  !*       CODE AND GLAP ARE PUT INTO THE BUFFERS 'CODE,GLABUF(0:268)'   *
  780  !*       BY A NUMBER OF TRIVIAL ROUTINES.LPUT IS CALLED TO ADD THE     *
  781  !*       BUFFER TO THE OUTPUT FILE. THE BUFFERS ARE BASICALLY 0:255    *
  782  !*       WITH A 12-BYTE MARGIN TO MINIMISE THE NUMBER OF TESTS FOR     *
  783  !*       THE BUFFER FULL CONDITION                                     *
  784  !*                                                                     *
  785  !*       PPCURR(GLACURR) IS THE BUFFER POINTER                         *
  786  !*       CA(GLACA)  IS THE RELATIVE ADDRESS OF THE NEXT BYTE           *
  787  !*       CABUF(GLACABUF) IS CA(GLACA) FOR START OF BUFFER              *
  788  !***********************************************************************
  789           %ROUTINE CODEOUT
  790           %IF PPCURR>0 %THEN %START
  791              %IF DCOMP#0 %THEN %C
  792+                RECODE(ADDR(CODE(0)),ADDR(CODE(PPCURR)),CABUF)
  793              LPUT(1,PPCURR,CABUF,ADDR(CODE(0))) %IF INHCODE=0
  794              PPCURR=0; CABUF=CA
  795           %FINISH
  796           %END
  797           %ROUTINE PLANT(%INTEGER HALFWORD)
  798  !        ADD A HALF WORD OF BINARY TO THE BUFFER
  799           SHORT INTEGER(ADDR(CODE(PPCURR)))<-HALFWORD
  800           PPCURR=PPCURR+2
  801           CA=CA+2
  802           CODEOUT %IF PPCURR>=256
  803           %END
  804           %ROUTINE PCONST(%INTEGER WORD)
  805  !        ADD A WORD OF BINARY TO THE BUFFER
  806  !%if USE MC = 1 %start
  807  !         **1,ADDR(CODE(PPCURR))
  808  !         *MVC_0(4,1),WORD
  809  !%finish
  810           PPCURR=PPCURR+4
  811           CA=CA+4
  812           CODEOUT %IF PPCURR>=256
  813           %END
?WORD unused
  814           %ROUTINE PRR(%INTEGER OPCODE,R1,R2)
  815           CODE(PPCURR)=OPCODE
  816           CODE(PPCURR+1)=R1<<4!R2
  817           PPCURR=PPCURR+2
  818           CA=CA+2
  819           CODEOUT %IF PPCURR>=256
  820           %END
  821           %ROUTINE MOVE BACK PC
  822           %IF LCA<CABUF %THEN CABUF=LCA %AND PPCURR=0 %ELSE %C
  823+             PPCURR=PPCURR-CA+LCA
  824           CA=LCA
  825           %END
  826           %ROUTINE PRX(%INTEGER OPCODE,R1,R2,B,D)
  827           {%SHORTROUTINE}
  828           %OWNINTEGER LR1,LR2,LB,LD
  829           %IF CHECKSP=0 %THEN %START
  830              %IF OPCODE=X'58' %OR OPCODE=X'50' %THEN %START
  831                 %IF LCA+4=CA %AND LB=B %AND R2=0 %AND %C
  832+                   ((LOPCODE=OPCODE %AND (LR1+1)&15=R1 %AND LR2=0 %AND %C
  833+                   D=LD+4) %OR (LOPCODE=OPCODE+X'40' %AND %C
  834+                   (LR2+1)&15=R1 %AND D=LD+((R1-LR1)&15)*4)) %START
  835                    %IF DCOMP#0 %THEN printstring("** LOADS COMBINED **")
  836                    MOVE BACK PC
  837                    CSAVED=CSAVED+4
  838                    PRX(X'90'+OPCODE&15,LR1,R1,LB,LD)
  839                    %RETURN
  840                 %FINISH
  841              %FINISH
  842              LCA=CA; LR1=R1; LR2=R2
  843              LB=B; LD=D; LOPCODE=OPCODE
  844           %FINISH
  845           CODE(PPCURR)=OPCODE
  846           CODE(PPCURR+1)=R1<<4!R2
  847           SHORT INTEGER(ADDR(CODE(PPCURR+2)))<- B<<12!D
  848           PPCURR=PPCURR+4
  849           CA=CA+4
  850           CODEOUT %IF PPCURR>=256
  851           %END
  852           %ROUTINE PSI(%INTEGER OPCODE,J,B,D)
  853           CODE(PPCURR)=OPCODE
  854           CODE(PPCURR+1)=J
  855           SHORT INTEGER(ADDR(CODE(PPCURR+2)))<- B<<12!D
  856           PPCURR=PPCURR+4
  857           CA=CA+4
  858           CODEOUT %IF PPCURR>=256
  859           %END
  860           %ROUTINE PSS(%INTEGER OPCODE,N,B1,D1,B2,D2)
  861           CODE(PPCURR)=OPCODE
  862           N=N-1 %UNLESS N=0
  863           CODE(PPCURR+1)=N
  864           SHORT INTEGER(ADDR(CODE(PPCURR+2)))<- B1<<12!D1
  865           SHORT INTEGER(ADDR(CODE(PPCURR+4)))<- B2<<12!D2
  866           PPCURR=PPCURR+6
  867           CA=CA+6
  868           CODEOUT %IF PPCURR>=256
  869           %END
  870           %ROUTINE PMVC(%INTEGER L,B1,D1,B2,D2)
  871           {%SHORTROUTINE}
  872  !***********************************************************************
  873  !*         PLANTS AN MVC INSTRN. IN OPTIMISING MODE TRIES TO GLUE IT   *
  874  !*         ON TO THE LAST ONE PLANTED                                  *
  875  !***********************************************************************
  876           %OWNINTEGER LL,LB1,LD1,LB2,LD2
  877           %IF CHECKSP#1 %THEN %START
  878              %IF LCA+6=CA %AND B1=LB1 %AND B2=LB2 %AND LOPCODE=X'D2' %C
  879+                 %AND D1=LD1+LL %AND D2=LD2+LL %AND LL+L<=256 %START
  880                 MOVE BACK PC
  881                 CA=LCA; L=L+LL
  882                 D1=LD1; D2=LD2
  883              %FINISH
  884              LCA=CA; LL=L; LB1=B1; LD1=D1
  885              LB2=B2; LD2=D2; LOPCODE=X'D2'
  886           %FINISH
  887           PSS(X'D2',L,B1,D1,B2,D2)
  888           %END
  889           %ROUTINE     CNOP(%INTEGER I,J)
  890           PLANT(X'0700') %WHILE CA&(J-1)#I
  891           %END
  892           %ROUTINE PGLA(%INTEGER BDRY,L,INF ADR)
  893           {%SHORTROUTINE}
  894           %INTEGER I,J
  895           J=GLACA; GLACA=(J+BDRY-1)&(-BDRY)
  896           GLACURR=GLACURR+GLACA-J;      ! COMPLETE THE ROUNDING
  897  !
  898  ! RECORD HOLES IN THE GLA FOR FUTURE USE
  899  !
  900           %IF J&1#0 %THEN J=J+1
  901           %WHILE J+2<=GLACA %CYCLE
  902              PUSH(GLAHOLES,J,0)
  903              J=J+2
  904           %REPEAT
  905           %IF L+GLACURR>256 %THEN %START
  906              %IF INHCODE=0 %THEN LPUT(2,GLACURR,GLACABUF,ADDR(GLABUF(0)))
  907              GLACA=(GLACA+1)&(-2)
  908              GLACURR=0; GLACABUF=GLACA
  909           %FINISH
  910  !%if USE MC = 1 %start
  911  !         *LM_1,2,L; *L_3,GLABUF
  912  !         *A_3,GLACURR; *BCTR_1,0
  913  !         *EX_1,<MOVE>
  914  !%finish
  915           GLACA=GLACA+L; GLACURR=GLACURR+L
  916           %RETURN
  917  !%if USE MC = 1 %start
  918  !MOVE:    *MVC_0(1,3),0(2)
  919  !%finish
  920           %END
?I unused
?INFADR unused
  921           %ROUTINE     PLUG(%INTEGER AREA,AT,VALUE)
  922           {%SHORTROUTINE}
  923  !***********************************************************************
  924  !*       WRITE ONE HALFWORD INTO OBJECT FILE OUT OF SEQUENCE           *
  925  !***********************************************************************
  926           %INTEGERNAME WCABUF
  927           %INTEGER RELAD,BUFAD
  928           WCABUF==CABUF; BUFAD=ADDR(CODE(0))
  929           %IF AREA=2 %THEN WCABUF==GLACABUF %AND BUFAD=ADDR(GLABUF(0))
  930           RELAD=AT-WCABUF
  931           %IF RELAD>=0 %THEN SHORTINTEGER(RELAD+BUFAD)<-VALUE %ELSESTART
  932              %IF INHCODE=0 %THEN LPUT(AREA,2,AT,ADDR(VALUE)+2)
  933           %FINISH
  934           %END
  935           %ROUTINE SET PERMBASE
  936           PCONST(X'58CD005C')
  937           REGISTER(12)=-1
  938           GRUSE(12)=18
  939           GRINF(12)=0
  940           %END
  941           %ROUTINE     PRHEX(%INTEGER VALUE,PLACES)
  942           %OWNINTEGER HT1=M'0123'
  943           %OWNINTEGER HT2=M'4567'
  944           %OWNINTEGER HT3=M'89AB'
  945           %OWNINTEGER HT4=M'CDEF'
  946           %INTEGER W1,W2,W3
  947  !%if USE MC = 1 %start
  948  !         *UNPK_W1+1(9),VALUE(5)
  949  !         *NC_W1+1(8),MASK1
  950  !         *TR_W1+1(8),HT1
  951  !         *LA_1,W1+8; *S_1,PLACES
  952  !         *MVC_ 0(1,1),PLACES+3
  953  !         *-> P5;                       ! PRINTSTRING IN PERM
  954  !%finish
  955           %END
?W3 unused
?W2 unused
?W1 unused
?HT4 unused
?HT3 unused
?HT2 unused
?HT1 unused
?PLACES unused
?VALUE unused
  956           %ROUTINE GET ENV(%SHORTINTEGERNAME HEAD)
  957           {%SHORTROUTINE}
  958  !***********************************************************************
  959  !*       SAVE A COPY OF THE REGISTER STATE FOR FUTURE REFERENCE        *
  960  !***********************************************************************
  961           %INTEGER I,J
  962           %CYCLE J=0,1,14; I=GRMAP(J)
  963              PUSH123(HEAD,GRINF(I),GRAT(I),I<<8!GRUSE(I)) %IF GRUSE(I)>1
  964           %REPEAT
  965           %END
  966           %ROUTINE RESTORE(%SHORTINTEGER HEAD)
  967           {%SHORTROUTINE}
  968  !***********************************************************************
  969  !*       RESET THE REGISTERS TO ENVIRONMENT IN LIST HEADED BY 'HEAD'   *
  970  !***********************************************************************
  971           %INTEGER I,J,R,USE,INF,AT
  972           CCSTATE=-1
  973           %CYCLE J=0,1,14; I=GRMAP(J)
  974              %IF REGISTER(I)>=0 %THEN GRUSE(I)=0 %AND GRINF(I)=0
  975           %REPEAT
  976           %WHILE HEAD#0 %CYCLE
  977              POP123(HEAD,INF,AT,I)
  978              R=I>>8
  979              %IF REGISTER(R)>=0 %THEN GRUSE(R)=I&255 %AND GRINF(R)=INF
  980              GRAT(R)=AT
  981           %REPEAT
  982           %END
?USE unused
  983  !         %ROUTINE PRINT LIST(%INTEGER HEAD)
  984  !         {%SHORTROUTINE}
  985  !         %INTEGER I,J,K
  986  !1:       %IF HEAD=0 %THEN %RETURN
  987  !         FROM123(HEAD,I,J,K)
  988  !         NEWLINE
  989  !         PRHEX(I,8)
  990  !         SPACES(3)
  991  !         PRHEX(J,8)
  992  !         SPACES(3)
  993  !         PRHEX(K,8)
  994  !         NEWLINE
  995  !         MLINK(HEAD)
  996  !         ->Label1
  997  !         %END
  998  !
  999  ! ******* LIST***PROCESSING***ROUTINES
 1000  ! NEW VERSIONS BASED ON A 96BIT(12 BYTE) UNIT
 1001  ! S1=S2=32 BIT STREAM, S3=16 BIT STREAM
 1002  !
 1003  !         %ROUTINE CHECK ASL
 1004  !! CHECK ASL FOR CONSISTENCY AND PRINT OUT FREE CELLS
 1005  !! FOR DEBUGGING OBSCURE LIST PROCESSING FAULTS ONLY
 1006  !         {%SHORTROUTINE}
 1007  !         %INTEGER N,Q
 1008  !         N=0
 1009  !          Q=ASL
 1010  !1:       ->Label2 %IF Q=0
 1011  !         ABORT %UNLESS Q&3=0
 1012  !          MLINK(Q)
 1013  !          N=N+1
 1014  !          ->Label1
 1015  !2:         printstring(" FREE CELLS=")
 1016  !          WRITE(N,3)
 1017  !         NEWLINE
 1018  !           %END
 1019  !
 1020  !         %INTEGERFN NEW CELL
 1021  !         %INTEGER I
 1022  !%if USE MC = 1 %start
 1023  !         *L_1,ASL
 1024  !         *LTR_2,1
 1025  !         *BC_7,<1>
 1026  !%finish
 1027  !         FAULT(107,0)
 1028  !%if USE MC = 1 %start
 1029  !1:       *A_2,ASLIST
 1030  !         *MVC_ASL+2(2),14(2);         !ASL TO NEXT FREE CELL
 1031  !         *XC_0(16,2),0(2);                  ! NEWCELL TO ZERO
 1032  !         *LM_4,15,16(8)
 1033  !         *BCR_15,15
 1034  !%finish
 1035  !         %END
 1036           %ROUTINE PUSH(%SHORTINTEGERNAME CELL,%INTEGER S1,S2)
 1037  !%if USE MC = 1 %start
 1038  !         *L_4,ASL; *LTR_5,4; *BC_7,<1>
 1039  !%finish
 1040           FAULT(107,0)
 1041  !%if USE MC = 1 %start
 1042  !1:       *A_5,ASLIST; *MVC_ASL+2(2),14(5)
 1043  !         *LM_15,1,CELL; *LH_3,0(15); *SR_2,2
 1044  !         *STH_4,0(15); *STM_0,3,0(5)
 1045  !%finish
 1046           %END
?S2 unused
?S1 unused
?CELL unused
 1047           %ROUTINE PUSH123(%SHORTINTEGERNAME CELL,%INTEGER S1,S2,S3)
 1048  !%if USE MC = 1 %start
 1049  !         *L_4,ASL; *LTR_5,4; *BC_7,<1>
 1050  !%finish
 1051           FAULT(107,0)
 1052  !%if USE MC = 1 %start
 1053  !1:       *A_5,ASLIST; *MVC_ASL+2(2),14(5)
 1054  !         *LM_15,2,CELL; *LH_3,0(15)
 1055  !         *STH_4,0(15); *STM_0,3,0(5)
 1056  !%finish
 1057           %END
?S3 unused
?S2 unused
?S1 unused
?CELL unused
 1058           %ROUTINE POP(%SHORTINTEGERNAME CELL,%INTEGERNAME S1,S2)
 1059  !%if USE MC = 1 %start
 1060  !         *LM_1,3,CELL; *LH_4,0(1); *L_15,ASLIST
 1061  !         *L_0,0(4,15); *ST_0,0(2);       ! SET S1
 1062  !         *L_0,4(4,15); *ST_0,0(3);       ! SET S2
 1063  !         *LTR_4,4; *BC_8,<1>;             ! HEAD =0 FOR NULL LIST
 1064  !         *LH_0,14(4,15); *STH_0,0(1);    ! HEADCELL TO OLD 2ND CELL
 1065  !         *L_3,ASL; *STH_3,14(4,15); *ST_4,ASL
 1066  !%finish
 1067  Label1:       %END
?LABEL1 unused
?S2 unused
?S1 unused
?CELL unused
 1068           %ROUTINE POP123(%SHORTINTEGERNAME CELL,%C
 1069+          %INTEGERNAME S1,S2,S3)
 1070  
 1071  !%if USE MC = 1 %start
 1072  !         *LM_1,3,CELL; *LH_4,0(1); *L_15,ASLIST
 1073  !         *L_0,0(4,15); *ST_0,0(2);       ! SET S1
 1074  !         *L_0,4(4,15); *ST_0,0(3);       ! SET S2
 1075  !         *L_0,8(4,15); *L_3,S3; *ST_0,0(3); ! SET S3
 1076  !         *LTR_4,4; *BC_8,<1>;             ! HEAD =0 FOR NULL LIST
 1077  !         *LH_0,14(4,15); *STH_0,0(1);    ! HEADCELL TO OLD 2ND CELL
 1078  !         *L_3,ASL; *STH_3,14(4,15); *ST_4,ASL
 1079  !%finish
 1080  Label1:       %END
?LABEL1 unused
?S3 unused
?S2 unused
?S1 unused
?CELL unused
 1081           %ROUTINE INSERT AFTER(%SHORTINTEGERNAME CELL,%INTEGER S1,S2)
 1082  !%if USE MC = 1 %start
 1083  !         *L_1,ASL; *LTR_2,1; *BC_7,<2>
 1084  !%finish
 1085           FAULT(107,0)
 1086  !%if USE MC = 1 %start
 1087  !2:       *A_2,ASLIST; *MVC_ASL+2(2),14(2)
 1088  !         *SR_0,0; *ST_0,12(2); *ST_0,8(2)
 1089  !         *L_2,ASLIST;*LM_3,4,S1;*ST_3,0(1,2);*ST_4,4(1,2)
 1090  !         *L_4,CELL; *LH_3,0(4); *STH_1,0(4)
 1091  !         *LTR_3,3;*BC_8,<1>;*LH_4,14(3,2)
 1092  !         *STH_4,14(1,2); *STH_1,14(3,2)
 1093  !%finish
 1094  Label1:       %END
?LABEL1 unused
?S2 unused
?S1 unused
?CELL unused
 1095  
 1096  %ROUTINE BINSERT(%SHORTINTEGERNAME TOP,BOT,%INTEGER S1,S2,S3)
 1097  !***********************************************************************
 1098  !*       ADD A NEWCELL AT THE BOTTOM OF A LIST                         *
 1099  !***********************************************************************
 1100  !%if USE MC = 1 %start
 1101  !         *LM_14,2,TOP; *L_3,ASL
 1102  !         *LTR_4,3; *BC_7,<1>
 1103  !%finish
 1104           FAULT(107,0)
 1105  !%if USE MC = 1 %start
 1106  !1:       *L_5,ASLIST; *LH_6,14(3,5); *ST_6,ASL
 1107  !         *LH_6,0(15); *LTR_6,6; *BC_7,<2>; ! IS BOT 0 ?
 1108  !         *STH_3,0(14); *BC_15,<3>;      ! YES SET TOP =NEWCELL
 1109  !2:       *STH_3,14(6,5);                ! LINK NEWCELL TO PREV BOT
 1110  !3:       *STH_3,0(15);                  ! BOT =NEWCELL
 1111  !         *SR_3,3; *AR_4,5
 1112  !         *STM_0,3,0(4)
 1113  !%finish
 1114  %END
?S3 unused
?S2 unused
?S1 unused
?BOT unused
?TOP unused
 1115           %ROUTINE     REPLACE123(%INTEGER CELL,S1,S2,S3)
 1116  !%if USE MC = 1 %start
 1117  !         *LM_15,2,CELL;*A_15,ASLIST
 1118  !         *STM_0,2,0(15)
 1119  !         *LM_8,15,32(8); *BCR_15,15
 1120  !%finish
 1121           %END
?S3 unused
?S2 unused
?S1 unused
?CELL unused
 1122           %ROUTINE     REPLACE1(%INTEGER CELL,S1)
 1123           INTEGER(ADDR(ASLIST(CELL)))=S1
 1124           %END
 1125           %ROUTINE     REPLACE2(%INTEGER CELL,S2)
 1126           INTEGER(ADDR(ASLIST(CELL+4)))=S2
 1127           %END
 1128           %ROUTINE     REPLACE3(%INTEGER CELL,S3)
 1129           INTEGER(ADDR(ASLIST(CELL+8)))=S3
 1130           %END
 1131           %ROUTINE     MLINK(%INTEGERNAME CELL)
 1132           CELL=SHORTINTEGER(ADDR(ASLIST(CELL+14)))
 1133           %END
 1134           %INTEGERFN     FIND(%INTEGER LAB,LIST)
 1135  ! THIS FUNCTION SEARCHES LIST 'LIST' FOR LAB IN STREAM2 AND
 1136  ! RETURNS THE CORRESPONDING CELL NO.IT USED FOR MORE THAN
 1137  ! SCANNING LABEL LISTS.
 1138  !%if USE MC = 1 %start
 1139  !         %MCODE
 1140  !         *LM_0,1,LAB; *L_2,ASLIST
 1141  !         *LTR_15,1; *BC_8,<FAIL>
 1142  !AGAIN:   *C_0,4(1,2);
 1143  !         *BC_8,<FOUND>
 1144  !         *LH_1,14(1,2)
 1145  !         *LTR_15,1
 1146  !         *BC_7,<AGAIN>
 1147  !FAIL:    *L_1,0(15,2);                  ! IF FAIL LOADS-1 ELSE RESULT
 1148  !FOUND:   *LM_8,15,32(8); *BCR_15,15
 1149  !         %ENDOFMCODE
 1150  !%finish
 1151  %result=-1
 1152           %END
?LIST unused
?LAB unused
 1153           %INTEGERFN FIND3(%INTEGER S3,LIST)
 1154  !***********************************************************************
 1155  !*       SEARCHES LIST FOR S3 IN STREAM 3                              *
 1156  !*       RETURNS CELL NO AS RESULT                                     *
 1157  !***********************************************************************
 1158  !%if USE MC = 1 %start
 1159  !         *LM_0,1,S3; *L_2,ASLIST; *SR_3,3
 1160  !         *LTR_1,1; *BC_8,<FAIL>
 1161  !AGAIN:   *C_0,8(1,2)
 1162  !         *BC_8,<FOUND>
 1163  !         *LR_3,1;                       ! SAVE PREVIOUS CELL
 1164  !         *LH_1,14(1,2)
 1165  !         *LTR_1,1
 1166  !         *BC_7,<AGAIN>
 1167  !FAIL:    *BCTR_1,0
 1168  !FOUND:   *ST_3,PREV3CL;
 1169  !         *LM_8,15,32(8); *BCR_15,15
 1170  !%finish
 1171  %result=-1
 1172           %END
?LIST unused
?S3 unused
 1173           %ROUTINE FROM123(%INTEGER CELL,%INTEGERNAME S1,S2,S3)
 1174  !%if USE MC = 1 %start
 1175  !        *LM_1,4,CELL; *A_1,ASLIST;
 1176  !         *LM_15,1,0(1); * ST_15,0(2)
 1177  !         *ST_ 0,0(3); *ST_1,0(4)
 1178  !         *LM_8,15,32(8); *BCR_15,15
 1179  !%finish
 1180           %END
?S3 unused
?S2 unused
?S1 unused
?CELL unused
 1181           %ROUTINE FROM12(%INTEGER CELL,%INTEGERNAME S1,S2)
 1182  !%if USE MC = 1 %start
 1183  !         *LM_1,3,CELL ;*A_1,ASLIST ;
 1184  !         *LM_0,1,0(1); *ST_0,0(2); *ST_1,0(3)
 1185  !%finish
 1186           %END
?S2 unused
?S1 unused
?CELL unused
 1187           %INTEGERFN     FROM1(%INTEGER CELL)
 1188           %RESULT=INTEGER(ADDR(ASLIST(CELL)))
 1189           %END
 1190           %INTEGERFN     FROM2(%INTEGER CELL)
 1191           %RESULT=INTEGER(ADDR(ASLIST(CELL))+4)
 1192           %END
 1193           %INTEGERFN FROM3(%INTEGER CELL)
 1194           %RESULT=INTEGER(ADDR(ASLIST(CELL))+8)
 1195          %END
 1196           %ROUTINE CLEAR LIST (%SHORTINTEGERNAME OPHEAD)
 1197  !%if USE MC = 1 %start
 1198  !         **1,OPHEAD; *LTR_1,1; *BC_8,<EMPTY>
 1199  !         *L_2,ASLIST; *L_0,ASL; *ST_1,ASL
 1200  !AGAIN:  *LR_3,1; *LH_1,14(1,2);         ! NEXT LINK
 1201  !         *LTR_1,1; *BC_7,<AGAIN>;       ! IS IT ZERO?
 1202  !         *STH_0,14(3,2);                ! LAST LINK TO OLD VALUE OF ASL
 1203  !%finish
 1204  EMPTY:   OPHEAD=0;
 1205           %END
?EMPTY unused
 1206  !         %ROUTINE CONCAT(%SHORTINTEGERNAME LIST1,LIST2)
 1207  !         %COMMENT ADDS LIST2 TO BOTTOM OF LIST1
 1208  !%if USE MC = 1 %start
 1209  !         *L_4,LIST1
 1210  !         *L_15,LIST2
 1211  !         *LH_0,0(15)
 1212  !         *L_2,ASLIST
 1213  !         *LH_1,0(4)
 1214  !         *LTR_3,1
 1215  !         *BC_7,<ON>
 1216  !         *STH_0,0(4)
 1217  !         *BC_15,<COMM>
 1218  !ON:      *LR_3,1
 1219  !         *LH_1,14(3,2);                 ! NEXT LINK
 1220  !         *LTR_1,1
 1221  !         *BC_7,<ON>
 1222  !         *STH_0,14(3,2);                ! LAST LINK TO NEW LIST
 1223  !COMM:    *STH_1,0(15);                  ! ZERO HEAD OF LIST2 IN CASE
 1224  !%finish
 1225  !         %END;                          ! AN ERROR PUTS CELL TWICE ONTO
 1226                                         ! FREE LIST - CATASTROPHIC!
 1227  !         %ROUTINE INSERT AT END(%SHORTINTEGERNAME CELL,%INTEGER S1,S2)
 1228  !         {%SHORTROUTINE}
 1229  !!***********************************************************************
 1230  !!*       ADD A CELL TO THE BOTTOM OF THE LIST HEADED BY 'CELL'         *
 1231  !!***********************************************************************
 1232  !%if USE MC = 1 %start
 1233  !         *L_1,ASL
 1234  !         *LTR_2,1
 1235  !         *BC_7,<1>
 1236  !%finish
 1237  !         FAULT(107,0)
 1238  !%if USE MC = 1 %start
 1239  !1:       *A_2,ASLIST
 1240  !         *MVC_ASL+2(2),14(2)
 1241  !         *SR_0,0
 1242  !         *ST_0,12(2)
 1243  !         *L_2,ASLIST
 1244  !         *L_4,CELL
 1245  !         *LH_3,0(4);                 ! GET HEAD CELL
 1246  !         *LTR_3,3
 1247  !         *BC_7,<ON>;                 ! LIST NOT EMPTY
 1248  !         *STH_1,0(4)
 1249  !         *BC_15,<LOAD>;               ! EMPTY LIST -- CELL TO TOP
 1250  !ON:      *LR_4,3
 1251  !         *LH_3,14(2,4);               ! IS NEXT CELL THE BOTTOM??
 1252  !         *LTR_3,3
 1253  !         *BC_7,<ON>
 1254  !         *STH_1,14(2,4)
 1255  !LOAD:    *AR_1,2
 1256  !         *MVC_0(8,1),S1
 1257  !%finish
 1258  !         %END
 1259  ! ************END****OF****LIST****PROCESSING ROUTINES
 1260           %ROUTINE CSS(%INTEGER PIN,CSSMODE)
 1261           %ROUTINESPEC CIOCP(%INTEGER N)
 1262           %ROUTINESPEC DEFINE EP(%INTEGER A,B,C,D)
 1263           %ROUTINESPEC LAB LOOK(%INTEGERNAME A,%INTEGER B)
 1264           %ROUTINESPEC SET LOCAL BASE
 1265           %ROUTINESPEC STRINGOP(%INTEGER Z,L,BTO,DTO,BFRM,DFRM,BML,DML,X)
 1266           %ROUTINESPEC CEND(%INTEGER KKK)
 1267           %ROUTINESPEC CBPAIR(%INTEGERNAME LB,UB)
 1268           %ROUTINESPEC CCOND(%INTEGER IU,FARLAB)
 1269           %ROUTINESPEC SET LINE
 1270           %ROUTINESPEC CUI(%INTEGER CODE)
 1271           %ROUTINESPEC CSTART(%INTEGER CODE)
 1272           %ROUTINESPEC BULKM(%INTEGER A,B,C,D,E,F)
 1273           %ROUTINESPEC TORP(%SHORTINTEGERNAME H,B,NOPS,%INTEGER MODE)
 1274           %ROUTINESPEC SET USE(%INTEGER R,U,I)
 1275           %ROUTINESPEC CSEXP(%INTEGER REG,MODE)
 1276           %ROUTINESPEC DSEXP(%INTEGER REG,MODE)
 1277           %ROUTINESPEC FREE AND FORGET(%INTEGER REG)
 1278           %ROUTINESPEC SAVE IRS(%INTEGER MODE)
 1279           %ROUTINESPEC BOOT OUT(%INTEGER MODE)
 1280           %ROUTINESPEC EXPOP(%INTEGER A,B,C,D)
 1281           %ROUTINESPEC CSTREXP(%INTEGER MODE,REG)
 1282           %ROUTINESPEC ASSIGN (%INTEGER P1,P2)
 1283           %INTEGERFNSPEC COPY RECORD TAG(%INTEGERNAME SUBS)
 1284           %ROUTINESPEC  TEST APP(%INTEGERNAME NUM)
 1285           %INTEGERFNSPEC DISPLACEMENT(%INTEGER LINK)
 1286            %ROUTINESPEC SKIP APP
 1287           %ROUTINESPEC CRFORMAT(%SHORTINTEGERNAME HEAD)
 1288           %INTEGERFNSPEC DOPE VECTOR(%INTEGER A,B,C)
 1289           %ROUTINESPEC DECLARE ARRAYS(%INTEGER MODE,XTRA)
 1290           %ROUTINESPEC DECLARE SCALARS(%INTEGER A,B)
 1291           %ROUTINESPEC CQN(%INTEGER P)
 1292           %ROUTINESPEC CLT
 1293           %ROUTINESPEC MOVE R(%INTEGER R,N)
 1294           %ROUTINESPEC GET WSP(%INTEGERNAME PLACE,%INTEGER SIZE)
 1295           %ROUTINESPEC RETURN WSP(%INTEGER PLACE,SIZE)
 1296           %ROUTINESPEC CRCALL(%INTEGER A)
 1297           %ROUTINESPEC CNAME(%INTEGER Z,REG)
 1298           %ROUTINESPEC CRNAME(%INTEGER Z,REG,MODE,CLINK,BS,IX,DP)
 1299           %ROUTINESPEC CANAME(%INTEGER Z,BS,DP,LINK)
 1300           %ROUTINESPEC ADJUST INDEX(%INTEGER M,%INTEGERNAME I,D)
 1301           %ROUTINESPEC CREATE AH(%INTEGER M,R,B,D)
 1302           %ROUTINESPEC CRES(%INTEGER LAB)
 1303           %ROUTINESPEC CSNAME(%INTEGER Z,REG)
 1304           %ROUTINESPEC COPY TAG(%INTEGER KK)
 1305           %ROUTINESPEC REDUCE TAG(%INTEGER MODE)
 1306           %ROUTINESPEC REPLACE TAG (%INTEGER KK)
 1307           %ROUTINESPEC RT EXIT
 1308           %ROUTINESPEC RT JUMP(%INTEGER CODE,R1,RT,WKREG)
 1309           %ROUTINESPEC MERGE INFO
 1310           %ROUTINESPEC REDUCE ENV(%SHORTINTEGERNAME HEAD)
 1311           %ROUTINESPEC RELOCATE(%INTEGER A,B,C)
 1312           %ROUTINESPEC GXREF(%INTEGER A,B,C,D)
 1313           %ROUTINESPEC CXREF(%INTEGER A,B,C,%INTEGERNAME D)
 1314           %ROUTINESPEC STORE TAG(%INTEGER KK,SLINK)
 1315           %ROUTINESPEC TESTNST
 1316           %ROUTINESPEC CUCI
 1317           %ROUTINESPEC SKIP EXP
 1318           %ROUTINESPEC UNPACK
 1319           %ROUTINESPEC PACK(%INTEGERNAME PTYPE)
 1320           %ROUTINESPEC CRSPEC (%INTEGER M)
 1321           %ROUTINESPEC LOAD DV(%INTEGERNAME REG,%INTEGER B,D,T)
 1322           %ROUTINESPEC DUMP(%INTEGER CODE,REG,DIS,X,LEVEL)
 1323           %ROUTINESPEC DUMPM(%INTEGER OPCODE,R1,R2,B,D)
 1324           %ROUTINESPEC DUMPSI(%INTEGER OPCODE,L,B,D)
 1325           %ROUTINESPEC DUMPSS(%INTEGER OP,L,B1,D1,B2,D2)
 1326           %ROUTINESPEC RHEAD(%INTEGER KK)
 1327           %ROUTINESPEC ENTER JUMP(%INTEGER MASK,STAD,FLAG)
 1328           %ROUTINESPEC CFPDEL
 1329           %ROUTINESPEC PPJ(%INTEGER N)
 1330           %ROUTINESPEC ENTER LAB(%INTEGER M,FLAG)
 1331           %ROUTINESPEC CHECK CAPACITY(%INTEGER REG,DIS,X,LEVEL)
 1332           %INTEGERFNSPEC TSEXP(%INTEGERNAME CODE,%INTEGER I)
 1333           %ROUTINESPEC FIND USE(%INTEGERNAME REG,%INTEGER TYPE,USE,INF)
 1334           %ROUTINESPEC CLAIM THIS REG(%INTEGER A)
 1335           %ROUTINESPEC CLAIM(%INTEGER A,%INTEGERNAME REG)
 1336           %ROUTINESPEC FIND REG (%INTEGER A,%INTEGERNAME REG)
 1337           %ROUTINESPEC FORGET(%INTEGER REG)
 1338           %ROUTINESPEC FORGETM(%INTEGER UPPER)
 1339           %ROUTINESPEC FIND SEQ(%INTEGERNAME ONE,TWO)
 1340           %ROUTINESPEC REMEMBER
 1341           %INTEGERFNSPEC CONST FIND (%INTEGER L,AD)
 1342           %ROUTINESPEC STORE CONST(%INTEGERNAME B,D,%INTEGER L,AD)
 1343           %ROUTINESPEC NOTE ASSMENT(%INTEGER REG,ASSOP,VAR)
 1344           %ROUTINESPEC TEXTOUT(%INTEGER REG)
 1345           %ROUTINESPEC VALLOC(%INTEGER A,B)
 1346           %ROUTINESPEC VDALLOC(%INTEGER A,B)
 1347           %ROUTINESPEC CYCOPT(%INTEGERNAME FLAG,%INTEGER WU)
 1348           %ROUTINESPEC EXTRA PASS(%INTEGER I,J,K)
 1349           %ROUTINESPEC CYC RESTORE
 1350           %SWITCH SW(1:30)
 1351           %RECORDFORMAT RD(%SHORTINTEGER PTYPE,%BYTEINTEGER XB,FLAG,%C
 1352+          %INTEGER D,%SHORTINTEGER XTRA)
 1353           %SHORTINTEGER OPHEAD,SFHEAD,TWSPHEAD,DUMHEAD,SNDISP,ACC,K,KFORM
 1354           %INTEGER BXLE,TCELL,CURRINST,ADISP,BIMSTR,JJ,JJJ,KK,KKK, %C
 1355+                Q,QQ,EXTRN,STARTCOND,MARKIU,MARKUI,MARKC,MARKE,MARKR, %C
 1356+                BASE,INDEX,DISP,VALUE,BML,DML,LOCAL BASE, LOCAL ADDR, %C
 1357+                PTYPE,I,J,OLDI,USEBITS,SENOPS,SEFOP,PTYPEP,STRINGL,LINE
 1358           %BYTEINTEGER ROUT,NAM,ARR,PREC,TYPE,REPORTUI
 1359           {%REGISTER P(14)}%integer P; P=PIN
 1360           %INTEGERARRAY SGRUSE,SGRINF(0:22)
 1361           %CONSTINTEGER WSPTRTAB1=X'00010204',WSPTRTAB2= X'04060607'
 1362           LINE=A(P-1)
 1363           LOCAL BASE=0; TWSPHEAD=0
 1364           STARTCOND=0; CURRINST=0
 1365           CYC BITS=0; BIMSTR=0
 1366           SENOPS=0; SEFOP=0
 1367  !
 1368  ! CHECK THERE ARE SOME CELLS LEFT ON THE AVAILABLE SPACE LIST
 1369  !
 1370           %IF ASL<200 %AND CSSMODE#0 %THEN %START;! GARBAGE COLLECT NEEDED
 1371              %IF PRINTMAP=1 %THEN printstring("
 1372+ ?      LIST SPACE")
 1373              %IF ASL<200 %THEN %START; ! STILL SHORT OF SPACE
 1374                 printstring("?")
 1375                 CLEAR LIST(DVHEAD);    ! REMOVE LIST OF SHAREABLE D-VS
 1376                 CLEAR LIST(CONSTL8);   ! AND SHAREABLE LONG CONSTANTS
 1377                 CLEAR LIST(CONSTL6)
 1378                 %IF ASL<200 %THEN %START
 1379                    printstring("?")
 1380                    CLEAR LIST(CONSTL4);! & INTEGER CONSTANTS
 1381                    CLEAR LIST(CONSTL2);! & SHORT INT CONSTANTS
 1382                 %FINISH
 1383              %FINISH
 1384           %FINISH
 1385           OLDI=0; ->SW(A(P))
 1386  SW(23):
 1387           WARN(LINE)
 1388           SBFLAG=1 %IF CHECKSP=0;       ! '{%SHORTROUTINE}'
 1389  !
 1390  Label1:       LAST INST=CURR INST
 1391           %WHILE TWSPHEAD#0 %CYCLE
 1392              POP(TWSPHEAD,JJ,KK)
 1393              RETURN WSP(JJ,KK)
 1394          %REPEAT
 1395  SW(29):                               ! REDUNDANT SEP
 1396  SW(10):                               ! <CMARK> <COMMENT TEXT>
 1397  !         %CYCLE I=10,1,13
 1398  !              ABORT %UNLESS REGISTER(I)=-1
 1399  !         %REPEAT
 1400           %RETURN
 1401  SW(1):   MARKER2=P+1+A(P+1); P=P+2
 1402           ->LABFND %IF A(MARKER2)=1
 1403           SET LINE %IF LINENOS#0
 1404           ->Label101 %IF A(MARKER2)<=3
 1405           MASK=15; CUI(0); ->Label1
 1406  LABFND:  ->SWITCH %UNLESS A(P)<2 %AND A(P+3)=2;! 1ST ALT UI & NO APP
 1407           ->SWITCH %UNLESS A(P+4)=2 %AND A(P+5)=2;! NO ENAME OR ASSOP
 1408           K=16384+A(P+2); ->Label401
 1409  Label101:     MARKE=0; MARKR=0
 1410           MARKUI=P; MARKIU=MARKER2+1;MARKC=MARKIU+1
 1411           -> CONEXP %IF A(MARKER2)=2; ->WHILE
 1412  !
 1413  SW(2):                                 ! %CYCLE
 1414  !***********************************************************************
 1415  !*       THE LAYOUT OF AN ENTRY ON THE CYCLE LIST IS:-                 *
 1416  !*        S1= CNAME<<16!LABEL N0                                       *
 1417  !*        S2= EL<<16!BXLE<<15! CYCLE WORK AREA DISPLACEMENT FROM RBASE *
 1418  !*        S3= BREG    (THE REGISTER USED FOR INCREMENT AND FINAL VALUE)*
 1419  !*        WHERE :-                                                     *
 1420  !*        CNAME= CYCLE CONTROL NAME(IF SIMPLE SCALAR) OR               *
 1421  !*                      X'3000'!CYCLE NUM FOR CHECKED OR COMPLEX CYCLES*
 1422  !*        LABEL= NO OF INTERNAL LABEL FOR REPEAT TO JUMP TO            *
 1423  !*        BXLE=1 IF 'BXLE' CAN BE USED (IE INCREMENT +VE) ,=0 OTHERWISE*
 1424  !*          EL=LABEL NO FOR EXIT STATEMENT (TOP BIT SET WHEN USED)     *
 1425  !***********************************************************************
 1426           %BEGIN
 1427           {%SHORTROUTINE}
 1428           %INTEGER PP,Q,INC,NAME,TNAME,PASS,WSPL,CFLAG,BREG,OPEN,CREG
 1429           SET LINE
 1430           CUR CYC VAR=0; CYC REGS=0
 1431           BXLE=0; INC=0; BREG=2; CREG=1;    ! DEFAULTS
 1432           OPEN=A(P+1)-1; P=P+2; PP=P
 1433           %IF OPEN #0 %THEN %START
 1434              CYCOPT(CFLAG,2) %IF CHECKSP=0
 1435              PASS=X'10000000'
 1436           %FINISH %ELSE %START
 1437              NAME=A(P); TNAME = TAGS(NAME)
 1438              COPY TAG (NAME)
 1439              FAULT(25,NAME) %UNLESS TYPE=1 %AND PREC=0
 1440              %IF A(P+1)=2=A(P+2)%AND UNASS=0%AND CHECKSP=0 %AND %C
 1441+                  NAM=0 %AND K<4095 %THEN %START;! CONTROL A LOCAL SCALAR
 1442                 WSPL=2; P=P+3; PASS= NAME<<16
 1443                 CUR CYC VAR=NAME
 1444                 Q=P; FFLAG=0;
 1445                 SKIP EXP; SKIP EXP; SKIP EXP
 1446                 P=Q;                        ! CHECK FNS IN CNTRL EXPRSNS
 1447                 CYCOPT(CFLAG,0)
 1448                 P=Q
 1449                 %IF CFLAG=0 %THEN CUR CYC VAR=0
 1450                 %IF CFLAG>0 %THEN BREG=CFLAG&15
 1451                 COPYTAG(NAME)
 1452                 %IF PTYPE=8 %THEN CREG=K
 1453              %FINISH %ELSE %START;    ! CONTROL NAMETYPE OR ARRAY ELEMENT
 1454                 CYCLE NUM=CYCLE NUM+1
 1455                 PASS=X'30000000'!CYCLE NUM<<16
 1456                 WSPL=3; CNAME(3,4)
 1457                 REGISTER(4)=1
 1458              %FINISH
 1459              %IF BREG=2 %THEN %START;    ! REGISTER PAIR NOT AVAILABLE
 1460                 GET WSP(INC,WSPL);       ! WORKAREA TO INC
 1461                 POP(TWSPHEAD,JJ,KK);     ! MUST NOT BE FREED BEFORE REPEAT
 1462              %FINISH
 1463              Q=P; SKIP EXP; JJ=P;        ! Q TO 1ST EXP, JJ TO SECOND
 1464              BXLE=1 %IF (3900>CA-CODEBASE %OR CYC BASE#0) %C
 1465+                         %AND 1<=TSEXP (JJJ,0)<=2 %AND TYPE=1
 1466              P=JJ
 1467  !
 1468  ! LOAD INCREMENT AND FINAL TO BREG & BREG+1 UNLESS THIS HAS BEEN
 1469  ! DONE BY THE LOOP OPTIMISING
 1470  !
 1471              DSEXP(BREG,0) %UNLESS BREG>2 %AND GRUSE(BREG)=14
 1472              %IF BREG=2 %THEN DUMPM(X'90',2,WSPL+1,RBASE,INC);! STORE PARAMS
 1473              DUMPSI(X'92',CYCLE NUM&255,RBASE,INC+8) %IF UNASS=1
 1474              %CYCLE KK=BREG,1,BREG+WSPL-1
?Non-local
 1475                  %IF KK<4 %AND REGISTER(KK)>0 %THEN REGISTER(KK)=0
 1476                  %IF CFLAG=0 %THEN FORGET(KK) %ELSE SET USE(KK,14,TNAME)
 1477              %REPEAT
 1478              P=Q; CSEXP(CREG,1)
 1479              FORGET(CREG);                 ! BEFORE PPJ TO AVOID A BOOTOUT
 1480              REGISTER(CREG)=1
 1481              %IF CHECKSP=1 %THEN  DUMP(0,2,INC,0,RBASE);! LA 2, CYCLE PARAMS
 1482              REGISTER(CREG)=0; MONE=1
 1483              %IF CHECKSP=1 %THEN PPJ(17);! CHECK VALIDITY
 1484           %FINISH
 1485           PLABEL=PLABEL-1; PASS=PASS!PLABEL
 1486           PUSH123(LABEL(LEVEL),CA,0,PLABEL);! STORE LABEL
 1487           CCSTATE=-1; LCA=0
 1488           %IF OPEN#0 %THEN %START
 1489              PLABEL=PLABEL-1
 1490              FORGETM(14)
 1491           %FINISH %ELSE %START
 1492              %CYCLE JJ=0,1,22
?Non-local
 1493                 FORGET(JJ) %IF REGISTER(JJ)=0 %AND GRUSE(JJ)#14
 1494              %REPEAT
 1495              %IF WSPL=3 %THEN %START
 1496                 DUMP(1,1,0,0,4)
 1497                 REGISTER(4)=0
 1498              %FINISH %ELSE %START
 1499                 %IF CREG=1 %THEN %START
 1500                    P=PP; CNAME(1,1)
 1501                    DUMP(1,1,DISP,INDEX,BASE)
 1502                 %FINISH
 1503                 NOTE ASSMENT(CREG,2,NAME)
 1504                 %IF CREG#1 %THEN REGISTER(CREG)=-1
 1505              %FINISH
 1506              INC=INC!BXLE<<15
 1507           %FINISH
 1508           XLABEL=XLABEL-1
 1509           PUSH123(CYCLE(LEVEL),PASS,XLABEL<<16!INC,CREG<<16!BREG)
 1510           %END; ->Label1
 1511  !
 1512   SW(3):        !REPEAT
 1513           %BEGIN
 1514           {%SHORTROUTINE}
 1515  %INTEGER NAME,TOPREG,CNUM,DSP,WSPL,LAB,KK,BREG,ELABEL,EUSED,CREG
 1516  %SHORTINTEGER HEAD
 1517  %SWITCH CTYPE(0:3)
 1518           SET LINE
 1519           %IF -1<=FROM1(CYCLE(LEVEL))<=0 %THEN FAULT(1,0) %AND ->Label1
 1520           CUR CYC VAR=0
 1521           POP123(CYCLE(LEVEL),J,DSP,BREG)
 1522           ELABEL=DSP>>16&X'7FFF'
 1523           EUSED=DSP>>31
 1524           BXLE=DSP>>15&1; DSP=DSP&X'7FFF'; LAB=J&X'FFFF'
 1525           CREG=BREG>>16; BREG=BREG&X'FFFF'
 1526           ->CTYPE(J>>28)
 1527  CTYPE(3):                              ! STEP CYCLE WITH PTR TO CONTROL
 1528         CNUM=J>>16&255; TOPREG=4; WSPL=3; NAME=-1; ->COM
 1529  CTYPE(0):                              ! STEP CYCLE LOCAL SCALAR CONTROL
 1530          TOPREG=3; WSPL=2; NAME=J>>16
 1531  COM:                                   ! ALL STEPWISE CYCLES
 1532           %IF UNASS=1 %THEN %START;     ! CHECK CYCLE ENTERD OK
 1533              DUMPSI(X'95',CNUM,RBASE,DSP+8);! CLI CYCLE WK AREA,CODE NO
 1534              PCONST(X'477C0028');       ! BNE UNASSIGNED VARIABLE USED
 1535           %FINISH
 1536  !
 1537  ! LOAD UP CYCLE PARAMETERS FROM WKAREA UNLESS THEY ARE LOADED ALREADY
 1538  !
 1539           %UNLESS BREG>2 %OR (GRUSE(2)=14=GRUSE(3) %AND %C
 1540+                       (GRUSE(4)=14 %OR NAME>=0)) %THEN %START
 1541              DUMPM(X'98',2,TOPREG,RBASE,DSP);! LM CYCLE PARAMS
 1542              %CYCLE I=1,1,TOPREG
?Non-local
 1543                 FORGET(I);                   ! FORGET REGISTER USED
 1544              %REPEAT
 1545           %FINISH
 1546  !
 1547  ! NOW GET CONTROL TO REG 1 VIA POINTER OR DIRECTLY AS RELEVANT
 1548  !
 1549           %IF NAME<0 %THEN %START;     ! VIA POINTER (REGS NOT ALLOCATED)
 1550              PRX(X'58',1,0,4,0)
 1551              REGISTER(4)=1
 1552           %FINISH %ELSE %START;        ! LOCAL SCALAR USE CNAME
 1553              P=R; A(P)=NAME
 1554              A(P+1)=2; A(P+2)=2;       ! SET NO APP OR ENAME
 1555              CNAME(2,CREG);            ! CONTROL -> R1 OPTIMUM METHOD
 1556           %FINISH
 1557  !
 1558  ! NOW PLANT CODE TO DO THE TEST AND BRANCH.AGAIN 2 WAYS POSSIBLE
 1559  !
 1560           %IF BXLE=0 %THEN %START;    ! THE TEDIOUS BUT VALID ROUTE
 1561              PRR(X'18',0,CREG);                 ! LR 0,1
 1562              PRR(X'1A',CREG,BREG);              ! AR 1,INC
 1563              PRR(X'19',0,BREG+1);            ! CR 0,FINAL
 1564              FORGET(0)
 1565              REGISTER(CREG)=1;          ! JUMP MAY LOAD 4K MULTIPLE
 1566              REGISTER(BREG)=1;       ! SO PROTECT REGISTER IN USE
 1567              REGISTER(BREG+1)=1
 1568              ENTER JUMP(7,LAB,0);    ! BNE <BEGIN ANOTHER TRAVERSE>
 1569           %FINISH %ELSE %START;      ! THE BXLE INSTRUCTION CAN BE USED
 1570              KK=FIND3(LAB,LABEL(LEVEL))
 1571              KK=FROM1(KK);           ! EXTRACT LABEL ADDRESS
 1572              %IF CYC BASE=0 %THEN I=10 %AND KK=KK-CODEBASE %ELSE %C
 1573+                                  I=CYC BASE %AND KK=KK-CYC ADDR
 1574              PRX(X'87',CREG,BREG,I,KK); ! BXLE 1,2,<NEXT TRAVERSE>
 1575           %FINISH
 1576           %IF CREG#1 %THEN CYC REGS=CYCREGS!!(1<<CREG)
 1577           CYC RESTORE;               ! DEALLOCATE PRELOADED REGISTERS
 1578                                          ! EXCEPT CYCLE CONTROL VARIABLE
 1579           %CYCLE I=BREG,1,BREG+1
?Non-local
 1580              FREE AND FORGET(I)
 1581           %REPEAT
 1582           %IF CREG#1 %THEN %START; ! CONTROL ALLOCATED A REG
 1583              VDALLOC(CREG,(BREG+1)*(1-COMPILER))
 1584              NOTE ASSMENT(BREG+1,2,NAME);! SET CONTROL TO FINAL VALUE
 1585           %FINISH %ELSE FREE AND FORGET(CREG)
 1586           %IF NAME<0 %THEN FREE AND FORGET(4)
 1587           %IF DSP#0 %THEN RETURN WSP(DSP,WSPL);!WORKAREA TO FREE LIST
 1588           %IF UNASS=1 %THEN DUMPSI(X'92',0,RBASE,DSP+8)
 1589           CYC REGS=0; CYC BASE=0
 1590           CCSTATE=-1; ->Label1
 1591  CTYPE(1):                               ! '%WHILE' '%CYCLE'
 1592           ENTER JUMP(15,LAB,0);          ! UNCONDITIONALLY TO WHILE CLAUS
 1593           ENTER LAB(LAB-1,B'111');       ! CONDITIONAL/REPLACE ENV
 1594          ->Label2
 1595  CTYPE(2):                               ! '%UNTIL' ... '%CYCLE'
 1596           %IF 500-R>799-TOPPTR %THEN %START
 1597              P=R+1; WSPL=499-P
 1598           %FINISH %ELSE %START
 1599              P=TOPPTR+1; WSPL=799-P
 1600           %FINISH
 1601           %IF WSPL<DSP %THEN FAULT(102,0);  ! NO ROOM FOR A.R.
 1602           WSPL=P; P=P+DSP; HEAD=BREG
 1603           %CYCLE;                           ! RETRIEVE AR FROM LIST
 1604              POP123(HEAD,JJJ,KKK,KK)
 1605              P=P-5
 1606              TOAR4(P,JJJ)
 1607              TOAR4(P+2,KKK)
 1608              A(P+4)=KK
 1609           %REPEAT %UNTIL HEAD=0
 1610           A(PIN-1)=A(P);                  ! SET UP LINE NO OF CONDITION
 1611           P=P+1
 1612           R=R+DSP
 1613           CCOND(1,LAB)
 1614           R=R-DSP
 1615  Label2:       CYC RESTORE
 1616           CYC REGS=0; CYC BASE=0
 1617  Label1:       %IF EUSED#0 %THEN ENTER LAB(ELABEL,B'11')
 1618           %END; ->Label1
 1619  !
 1620  SW(4):                                 ! (LABEL)':'
 1621           K=A(P+1)
 1622           FAULT(2,0) %IF K=0 %OR K>16383
 1623  Label401:     NMDECS=NMDECS!1
 1624           ENTER LAB(K,0)
 1625           CYC BITS=CYC BITS!1;            ! SET 'LABEL' BIT
 1626           ->Label1
 1627  !
 1628  SW(5):                                 ! (%IU)(COND)%THEN(UI)(ELSE')
 1629           MARKIU=P+1; MARKC=MARKIU+2
 1630           MARKR=P+2+A(P+2); MARKE=0
 1631           %IF A(MARKR)=3 %THEN %START
 1632           MARKE=MARKR+1+A(MARKR+1); MARKUI=MARKR+2
 1633           %FINISH
 1634           SET LINE %IF LINENOS#0
 1635  CONEXP:  %BEGIN
 1636  !***********************************************************************
 1637  !*       THIS BLOCK COMPILES CONDITIONAL EXPRESSIONS.IT REQUIRES THE   *
 1638  !*       FOLLOWING GLOBAL POINTERS TO BE SET TO THEIR A .R. ENTRY.     *
 1639  !*       MARKIU TO THE ENTRY FOR P(%IU)                                *
 1640  !*       MARKC  TO THE ENTRY FOR P(COND)                               *
 1641  !*       MARKUI TO THE ENTRY FOR (FIRST OCCURRENCE OF)  P(UI)          *
 1642  !*       MARKE  TO THE ENTRY FOR P(ELSE')  - =0 FOR BACKWARDS CONDITION*
 1643  !*       MARKR  TO ENTRY FOR P(RESTOFIU)                               *
 1644  !***********************************************************************
 1645           {%SHORTROUTINE}
 1646           MARKIU=A(MARKIU);              ! ALT OF IU 1=%IF,2=%UNLESS
 1647           KKK=-1
 1648           %IF MARKR>0 %AND A(MARKR)<=2 %START;! '%START' OR '%THENSTART'
 1649              KKK=SFLABEL-1
 1650              P=MARKC; CCOND(MARKIU,KKK)
 1651              CSTART(1)
 1652              ->Label1
 1653           %FINISH
 1654           %IF A(MARKUI)=2 %AND (A(MARKUI+1)<2 %OR A(MARKUI+3)=2) %THEN %C
 1655+             KKK=A(MARKUI+2)+(A(MARKUI+1)-1)<<14;! UI = SIMPLE LABEL
 1656  !
 1657           %IF A(MARKUI)=8 %AND CYCLE(LEVEL)#0 %START; ! VALID EXIT
 1658              KKK=FROM2(CYCLE(LEVEL))
 1659              REPLACE2(CYCLE(LEVEL),KKK!X'80000000')
 1660              KKK=KKK>>16&X'7FFF'
 1661           %FINISH
 1662  !
 1663           %IF KKK>=0 %THEN %START;  ! FIRST UI IS'->'<LABEL>
 1664              NMDECS=NMDECS!1
 1665              CYC BITS=CYC BITS!2;        ! SET 'JUMP' BIT
 1666              P=MARKC; CCOND(3-MARKIU,KKK)
 1667              %IF MARKE>0 %AND A(MARKE)<=2 %START; ! THERE IS AN ELSE CLAUSE
 1668                 %IF A(MARKE)=1 %THEN CSTART(0) %ELSE %START
 1669                    P=MARKE+1; MASK=15
 1670                    CUI(0)
 1671                 %FINISH
 1672              %FINISH
 1673              ->Label1
 1674           %FINISH
 1675  !
 1676           PLABEL=PLABEL-1; KKK=PLABEL
 1677           P=MARKC; CCOND(MARKIU,KKK)
 1678           P=MARKUI; MASK=15; CUI(1)
 1679           %UNLESS MARKE>0 %AND A(MARKE)<=2 %START;   ! UNLESS %ELSE FOLLOWS
 1680              ENTER LAB(KKK,B'11'!REPORTUI<<2); ->Label1;  ! CONDITIONAL&MERGE
 1681           %FINISH
 1682  !
 1683           %IF A(MARKE)=1 %THEN %START;      ! '%ELSESTART'
 1684              %IF REPORTUI=0 %THEN %C
 1685+                ENTER JUMP(15,SFLABEL-1,B'10');! LONG JUMP BUT SAVE ENV
 1686              CSTART(2)
 1687              ENTER LAB(KKK,B'111');         ! CONDITIONAL & REPLACE ENV
 1688           %FINISH %ELSE %START;             ! '%ELSE<UI>'
 1689              P=MARKE+1
 1690              PLABEL=PLABEL-1; JJJ=PLABEL
 1691              %IF REPORTUI=0 %THEN %C
 1692+                ENTER JUMP(15,JJJ,B'11');   ! SHORT JUMP AND SAVE ENV
 1693              ENTER LAB(KKK,B'111');         ! CONDITIONAL REPLACE ENV
 1694              MASK=15; CUI(2)
 1695              ENTER LAB(JJJ,B'11'!REPORTUI<<2);! CONDITIONAL MERGE
 1696           %FINISH
 1697  Label1:       %END; ->Label1
 1698  SW(14):
 1699           %BEGIN;                       ! '%FINISH(ELSE')(S)
 1700           {%SHORTROUTINE}
 1701  
 1702           %INTEGER J,K,CODE,CYC,FLAB
 1703           POP123(SBR(LEVEL),CODE,FLAB,CYC)
 1704           %IF CODE<0 %THEN FAULT(51,0) %AND ->Label1
 1705           %IF CYC#CYCLE(LEVEL) %THEN FAULT(52,0)
 1706  !
 1707           %IF A(P+1)<=2 %THEN %START;    ! %ELSE CLAUSE PRESENT
 1708              FAULT(47,0) %UNLESS CODE=1;   ! DANGLING ELSE
 1709              %IF A(P+1)=1 %THEN %START;  ! %ELSE %START
 1710  !
 1711  ! PLANT A ROUND NEXT START-FINISH %UNLESS PREVIOUS INSTRUCTION WAS ->
 1712  !
 1713                 ENTER JUMP(15,SFLABEL-1,B'10') %IF LAST INST=0
 1714                 CSTART(2)
 1715              %FINISH %ELSE %START;       ! %ELSE (UI)
 1716                 %IF LAST INST=0 %THEN %START
 1717                    PLABEL=PLABEL-1; J=PLABEL
 1718                    ENTER JUMP(15,J,B'11')
 1719                 %FINISH
 1720                 P=P+2;! K=A(P);           ! K= ALT OF P(UI)
 1721  !
 1722  ! PLANT THE LABEL FOR THE JUMP ROUND THE START FINISH BLOCK JUST ENDED
 1723  ! THE LABEL IS CONDITIONAL ON THERE HAVING BEEN A JUMP. ENVIRONMENTS ARE
 1724  ! MERGED UNLESS THE PREVIOUS INSTN IS A -> ETC WHEN ENV IS REPLACED
 1725  !
 1726                 ENTER LAB(FLAB,B'011'!LAST INST<<2)
 1727                 MONE=1; SET LINE; MASK=15
 1728                 %IF LAST INST#0 %THEN CUI(0) %AND ->Label1
 1729                 CUI(2); FLAB=J
 1730                 LAST INST=REPORT UI
 1731              %FINISH
 1732  !
 1733           %FINISH %ELSE %START
 1734              ->Label1 %IF CODE=0
 1735           %FINISH
 1736  !
 1737           ENTER LAB(FLAB,B'011'!LAST INST<<2)
 1738           MONE=1
 1739  Label1:       %END;
?K unused
 1740                     ; ->Label1
 1740  SWITCH:  %BEGIN;                       ! SWITCH LABEL
 1741           {%SHORTROUTINE}
 1742           %INTEGER HEAD,BASEPT,BP,FNAME
 1743           MONE=1; LCA=0; FORGETM(14)
 1744           CYC BITS=CYC BITS!1;                  ! SET 'LABEL' BIT
 1745           FNAME=A(P+2)
 1746           ->Label1411 %UNLESS A(P)=1 %AND A(P+3)=1;  ! 1ST OF UI + APP
 1747           ->Label1411 %UNLESS A(P+6)#3 %AND A(P+7)=2 %AND A(P+8)&7=1
 1748           ->Label1411 %UNLESS A(P+11)=2=A(P+12);     !NO R.OF.EXP. OR R.OF.APP
 1749           ->Label1411 %UNLESS A(P+13)=2=A(P+14);     ! NO ENAME OR R.OF.UI
 1750           COPY TAG(FNAME)
 1751           HEAD=K
 1752           %IF OLDI#LEVEL %OR TYPE#6 %THEN FAULT(4,FNAME) %AND ->Label1
 1753           FROM123(HEAD,BASEPT,KKK,KK);      ! EXTRACT TABLE ADDR,LB & UB
 1754           MLINK(HEAD);                      ! K POINTS TO BIT LIST
 1755           FROM AR4(P+9,JJ)
 1756           JJ=-JJ %IF A(P+6)=2
 1757           ->Label1402 %IF KKK<=JJ<=KK
 1758  Label1411:    FAULT(5,FNAME); ->Label1
 1759  Label1402:    Q=JJ-KKK
 1760           %WHILE Q>=96 %THEN MLINK(HEAD) %AND Q=Q-96
 1761  !
 1762  ! ASLIST(HEAD) IS THE START OF 96 BIT ENTRY IN THE BIT LIST
 1763  ! CHECK BIT NO Q TO SEE IF LABEL ALREADY SET AND THEN SET BIT Q
 1764  !
 1765           QQ=Q>>3+HEAD;                 ! RIGHT BYTE
 1766           Q=Q&7; JJJ=1<<Q;              ! BIT IN BYTE
 1767           FAULT(6,FNAME) %UNLESS ASLIST(QQ)&JJJ=0
 1768           ASLIST(QQ)=ASLIST(QQ)!JJJ %UNLESS CSSMODE=0
 1769           Q=CA-CODEBASE
 1770           BP=BYTES(PREC)
 1771           QQ=BASEPT+8+(JJ-KKK)*BP; ! REL POSITION OF LABEL IN SST
 1772           %IF INHCODE=0 %THEN LPUT(4,BP,QQ,ADDR(Q)+4-BP)
 1773           FAULT(99,0) %IF Q>X'7FFF' %AND PREC#0
 1774  Label1:       %END;   ->Label1
 1775  SW(6):                                 ! (%WU)(SC)(COND)(RESTOFWU)
 1776           MARKIU=P+1;                   ! TO WHILE/UNTIL
 1777           MARKC=MARKIU+2;               ! TO (SC)(COND)
 1778           MARKR=P+2+A(P+2);             ! TO RESTOF WU
 1779           MARKUI=MARKR+1;               ! TO P(UI) IF ANY
 1780           SET LINE
 1781  WHILE:   %BEGIN
 1782           {%SHORTROUTINE}
 1783           %INTEGER L1,L2,FLAG,XTRA
 1784           %SHORTINTEGER HEAD
 1785           HEAD=0; XTRA=0
 1786           MARKIU=A(MARKIU);             ! =1 FOR'WHILE' =2 FOR'UNTIL'
 1787           SFLABEL=SFLABEL-1
 1788           L1=SFLABEL
 1789           PLABEL=PLABEL-1;              ! RESERVE 2 LABELS
 1790           L2=PLABEL
 1791           ->WCYCLE %IF MARKR>0 %AND A(MARKR)<=2
 1792           %IF CSSMODE#0 %AND STMTSHELD>1 %AND CYCREGS=CYCBASE=0 %C
 1793+             %THEN EXTRA PASS(1,1,100) %AND XTRA=1
 1794           ENTER LAB(L1,0);             ! UNCONDITIONAL LAB FOR REPEAT
 1795           %IF MARKIU=1 %THEN %START
 1796              P=MARKC
 1797              CCOND(1,L2)
 1798           %FINISH
 1799  !
 1800           MASK=15; P=MARKUI
 1801           CUI(1)
 1802  !
 1803           %IF MARKIU=1 %THEN %START
 1804              ENTER JUMP(15,L1,0);        ! UNCODITIONALLY TO WHILE COND
 1805              ENTER LAB(L2,B'111')
 1806           %FINISH %ELSE %START
 1807              P=MARKC; CCOND(1,L1);       ! UNTIL CONDITION AT END
 1808           %FINISH
 1809           %IF XTRA#0 %THEN CYC RESTORE %AND CYCREGS=0 %AND CYCBASE=0
 1810           ->Label1
 1811  WCYCLE:
 1812  !***********************************************************************
 1813  !*       WHILE CYCLES JUST LIKE %WHILE...%THEN<UI> BUT %UNTIL CYCLES   *
 1814  !*       STORE AWWAY AN A.R. TO BE RESET AND COMPILED TO PUT THE       *
 1815  !*       CONDITION AT THE END. IF IT WAS PUT AT THE BEGINING 2 EXTRA   *
 1816  !*       JUMPS ARE NEEDED TO OBTAIN THE CORRECT EFFECT.                *
 1817  !***********************************************************************
 1818           P=MARKC; FLAG=0
 1819           %IF CSSMODE=0 %THEN CCOND(1,SFLABEL-1) %ELSE %START
 1820              CUR CYC VAR=-1
 1821              CYCOPT(FLAG,1);                  ! NOT A PRELIMINARY LOOK
 1822              XLABEL=XLABEL-1
 1823              ENTER LAB(L1,0);                 ! UNCONDITIONAL FOR REPEAT
 1824              %IF MARKIU=2 %THEN %START;       ! '%UNTIL....%CYCLE'
 1825                 L2=MARKR-MARKC+6
 1826                 P=P-1; A(P)=A(PIN-1);         ! GET LINE NO
 1827                 %CYCLE;                       ! DOWN AR FOR <COND>
 1828                   FROMAR4(P,JJJ)
 1829                   FROMAR4(P+2,KKK)
 1830                   PUSH123(HEAD,JJJ,KKK,A(P+4))
 1831                   P=P+5
 1832                 %REPEAT %UNTIL P>=MARKR
 1833              %FINISH %ELSE %START;            ! '%WHILE...%CYCLE
 1834                 CCOND(1,L1-1)
 1835                 SFLABEL=SFLABEL-1
 1836              %FINISH
 1837              PUSH123(CYCLE(LEVEL),L1!MARKIU<<28,XLABEL<<16!L2,HEAD)
 1838          %FINISH
 1839  Label1:         %END; ->Label1
 1840  !
 1841  SW(7):                                 ! SIMPLE DECLN
 1842           FAULT(57,0) %UNLESS LEVEL>=2
 1843           FAULT(40,0) %IF NMDECS&1#0
 1844           SET LINE
 1845           P=P+1;CLT;ROUT=0
 1846           %IF A(P)=1 %THEN %START;      ! SCALAR DECLARATIONS
 1847              CQN(P+1);P=P+2
 1848              DECLARE SCALARS(1,0)
 1849           %FINISH %ELSE %START;         ! ARRAY DECLARATIONS
 1850              FAULT(70,0) %IF TYPE=5 %AND ACC=0
 1851              NAM=0
 1852              QQ=2-A(P+1); P=P+2;        ! QQ=1 FOR ARRAYFORMATS
 1853              DECLARE ARRAYS(QQ,0)
 1854             %FINISH
 1855           ->Label1
 1856  !
 1857           %ROUTINE DECLARE SCALARS(%INTEGER PERMIT,XTRA)
 1858           {%SHORTROUTINE}
 1859  !***********************************************************************
 1860  !*       THIS ROUTINE DECLARES A LIST OF SCALARS FROM INFORMATION      *
 1861  !*       IN THE GLOBAL VARIABLES ROUT,NAM,ARR,PREC,TYPE & ACC.IT WORKS *
 1862  !*       OUT ROUNDING FACTORS FOR ITSELF. IF PERMIT#0 STRINGS AND      *
 1863  !*       RECORDS ARE ALLOCATED AT RUN TIME(ALLOC=1) WHEN SPACE IS      *
 1864  !*       TIGHT. P POINTS TO THE NAMELIST ON ENTRY AND IS UPDATED.      *
 1865  !***********************************************************************
 1866           %INTEGER REP,ALLOC,INC,ROUND,Q,SCHAIN,NIN
 1867           %CONSTBYTEINTEGERARRAY RACC (1:32)=               %C
 1868+                                 X'44' (2),X'80',0,X'10',0(5),
 1869+                                        X'11',0(9),
 1870+                                        X'22',0(9),
 1871+                                        0,X'88'
 1872           PACK(PTYPE); J=0; NIN=N
 1873           %IF PTYPE<=32 %THEN ROUND=RACC(PTYPE) %ELSE %START
 1874               %IF NAM=1 %AND TYPE=0 %AND ROUT=0 %THEN ROUND=X'48' %C
 1875+                                                %ELSE ROUND=X'44'
 1876           %FINISH
 1877           %IF ARR=1 %AND ROUT=0 %THEN INC=16 %ELSE INC=ROUND&15
 1878                                         ! BEWARE MAPS
 1879           %IF INC=0 %THEN INC=ACC
 1880           ROUND=ROUND>>4;               ! ITEM LENGTH AND BOUNDARY O.K.
 1881           %IF PTYPE=5 %AND ACC=0 %THEN FAULT(70,0)
 1882           ALLOC=0; REP=A(P)
 1883           %IF PERMIT#0 %AND(PTYPE=3 %OR PTYPE=5) %AND %C
 1884+             ACC*REP+N>4096-MARGIN %THEN %START
 1885              NAM=1;  PACK(PTYPE)
 1886              ROUND=4; INC=4
 1887              ALLOC=1
 1888           %FINISH
 1889           N=(N+ROUND-1)&(-ROUND)
 1890           %CYCLE Q=1,1,REP;         ! DOWN THE NAMELIST
 1891              K=A(P+Q); TEST NST
 1892              SCHAIN=N
 1893              %IF ROUT=1 %THEN %START
 1894                 SCHAIN=0; J=13; SNDISP=N>>2
 1895                 KFORM=1000
 1896              %FINISH
 1897              %IF TYPE=3 %THEN KFORM=XTRA
 1898              STORE TAG(K,SCHAIN)
 1899              %IF ALLOC=1 %THEN %START
 1900                 %IF UNASS=1 %THEN PSS(X'D2',8,WSPR,0,CODER,216)
 1901                 DUMP(X'50',WSPR,N,0,RBASE)
 1902                 %IF TYPE=5 %THEN DUMPSI(X'92',ACC-1,RBASE,N)
 1903                 MOVER(WSPR,(ACC+7)&(-8))
 1904              %FINISH
 1905              N=N+INC
 1906           %REPEAT
 1907           P=P+REP+1
 1908           N=(N+3)&(-4) %IF PERMIT#0;! NO ROUNDING AMONG PARAMS
 1909           BULKM(0,N-NIN,RBASE,NIN,0,X'80') %IF UNASS=1 %AND %C
 1910+          ALLOC=0 %AND PERMIT\=0
 1911           %END
 1912           %ROUTINE DECLARE ARRAYS(%INTEGER FORMAT,FINF)
 1913           {%SHORTROUTINE}
 1914  !***********************************************************************
 1915  !*       FORMAT=1 FOR 'ARRAYFORMAT'   =0 OTHERWISE                     *
 1916  !*       FINF>0 FOR RECORD FORMAT INFORMATION =0 OTHERWISE             *
 1917  !*       P IS AT P<ADECLN>   IN                                        *
 1918  !*                                                                     *
 1919  !*       P<ADECLN>=<NAMELIST> <BPAIR> <RESTOFDECLN>                    *
 1920  !*       P<BPAIR> = <CBPAIR>,'('<EXPR>':'<EXRR><RESTOFBP>*')'          *
 1921  !*                                                                     *
 1922  !*       ARRAYS OF ONE DIMENSION WITH CONSTANT BOUNDS HAVE THEIR       *
 1923  !*       DOPE-VECTOR IN THE CONSTANT AREA AND MAY HAVE THEIR SPACE     *
 1924  !*       ALLOCATED AT COMPILE TIME AMONG THE SCALARS                   *
 1925  !*       ALL OTHER ARRAYS HAVE A DOPE VECTOR AMONG THE LOCALS AND GET  *
 1926  !*       THEIR SPACE OFF THE STACK AT RUN TIME                         *
 1927  !*       BOTH SORTS OF ARRAYS HAVE A FOUR WORD HEAD AND D-V TO EMAS    *
 1928  !*       SYSTEM STANDARDS                                              *
 1929  !***********************************************************************
 1930           %INTEGER DVDISP,PP,DVF,ELSIZE,TOTSIZE,L,U,D1,D0
 1931           %INTEGER PTYPEP,ARRP,NN,ND,II,JJ,QQ,R,CDV
 1932           ARRP=2*FORMAT+1; ARR=ARRP; PACK(PTYPEP)
 1933           ELSIZE=ACC
 1934  START:   NN=A(P+1);                    ! NO OF NAMES IN NAMELIST
 1935           PP=P; CDV=0
 1936           P=P+2+NN;
 1937           %IF A(P)=1 %THEN -> CONSTDV;  ! P<BPAIR> =<CBPAIR>
 1938  !
 1939  ! NORMAL CASE - PLANT CODE TO SET UP DOPE-VECTOR AT RUN TIME
 1940  !
 1941           ND=0; JJ=P; DVF=0;TOTSIZE=X'FFFF'
 1942           %CYCLE;                       ! TILL NO MORE BPAIRS
 1943              P=P+1; ND=ND+1;            ! COUNT NO OF DIMENSIONS
 1944              SKIP EXP; SKIP EXP
 1945           %REPEAT %UNTIL A(P)=2
 1946           P=JJ; DVDISP=N;               ! DVDISP IS D-V POSITION
 1947           N=N+12*ND+4;                  ! CLAIM SPACE FOR THE D-V
 1948           FAULT(37,0) %IF ND>7;           ! TOO MANY DIMENSIONS
 1949  !
 1950           DUMP(0,-2,ELSIZE,0,0)
 1951           REGISTER(NEST)=1
 1952           DUMP(X'50',NEST,DVDISP,0,RBASE)
 1953           FREE AND FORGET(NEST)
 1954           DUMPSI(X'92',ND,RBASE,DVDISP+1);  ! FIRST ND=ND<<16!ELSIZE
 1955  !
 1956           %CYCLE II=0,1,ND-1
 1957              P=P+1
 1958              %CYCLE JJ=0,1,1
 1959                 QQ=12*II+4*JJ+4+DVDISP
 1960                 TYPE=1; PREC=0; PTYPE=1
 1961                 ASSIGN(2,RBASE<<16!QQ); ! ASSIGN EXPR TO DVITEM
 1962              %REPEAT
 1963           %REPEAT
 1964           P=P+1
 1965           DUMP(0,2,DVDISP,0,RBASE)
 1966  RUN TIME:                              ! ALLOCATE SPACE AT RUN TIME
 1967                                         ! R2 POINTS TO D-V
 1968           DVF=0;                        ! NOT VECTORS
 1969           PRX(X'50',2,0,GLA,36);        ! PUT POINTER INTO GLA
 1970           JJ=FORMAT<<7!UNASS
 1971           PSI(X'92',JJ,GLA,36) %IF JJ#0;! AND ADD FLAGS
 1972           -> DECL
 1973  CONSTDV:                               ! ONE DIMENSION - CONSTANT BOUNDS
 1974           DVF=1; ND=1; P=P+1; CDV=1
 1975           CBPAIR(L,U);                  ! GET BOUNDS
 1976           DVDISP=DOPE VECTOR(ELSIZE,L,U); ! AND GENERATE A D-V
 1977           R=U-L+1;                      ! RANGE=SPACES AS ELEMENTS
 1978           TOTSIZE=R*ELSIZE
 1979  !
 1980           II=DVDISP-GRINF(2)
 1981           %UNLESS GRUSE(2)=17 %AND II>=0 %THEN %START
 1982              PCONST(X'5820D000');       ! LOAD R2,POINTER TO SST
 1983              FORGET(2)
 1984              II=DVDISP
 1985           %FINISH
 1986  !
 1987           REGISTER(2)=1
 1988           DUMP(0,2,II,0,2) %UNLESS II=0
 1989           REGISTER(2)=0
 1990           JJ=4096-N-MARGIN;             ! SPACE AVAILABLE
 1991           JJ=JJ-MARGIN//2 %IF RBASE=9;  ! LEAVE LARGER MARGIN AT TOP
 1992                                         ! LEVEL SINCE DECLNS THERE ARE
 1993                                         ! ONLY EXECUTED ONCE
 1994           -> RUNTIME %UNLESS FORMAT=0 %AND UNASS=0
 1995           -> RUNTIME %IF NN*TOTSIZE>JJ %OR L>U
 1996           II=N-L*ELSIZE
 1997           -> RUNTIME %UNLESS II>0 %AND II+(NN-1)*(TOTSIZE+16)<4000
 1998  !
 1999  ! CAN ALLOCATE ARRAYS AS STRINGS OF LOCALS. THIS SAVES TIME AT DECLARATION
 2000  ! BUT ALSO ALLOWS THE LEVEL POINTER TO BE USED TO ADDRESS
 2001  ! THE ARRAY SAVING A REGISTER ON EACH ACCESS.
 2002  !
 2003           DUMP(0,3,ELSIZE,0,0) %UNLESS COMPILER=1
 2004  DECL:                                  ! MAKE DECLN - BOTH WAYS
 2005           PTYPE=PTYPEP+100*DVF;         ! ARR=2 FOR VECTORS =3 FOR FORMAT
 2006           J=ND
 2007           %CYCLE JJJ=1,1,A(PP+1);
?Non-local
 2008                                  ;       ! DOWN NAMELIST
 2008              %IF DVF#0 %THEN %START;     ! ARRAY IS STRING OF LOCALS
 2009                 N=(N+7)&(-8);           ! ARRAYS START ON D-W BNDARY
 2010                 D1=N+16
 2011                 D0=D1-L*ELSIZE; SNDISP=D0
 2012                 PRX(X'41',0,0,RBASE,D0);! LA 0,ADDR(A(0))
 2013                 PRX(X'41',1,0,RBASE,D1);! LA 1,ADDR(A(L.B))
 2014                 JJ=16+TOTSIZE
 2015                 FORGETM(3)
 2016              %FINISH %ELSE %START;     ! LONGWAY PERM MUST DECLARE
 2017                 PPJ(13); FORGET(4)
 2018                 JJ=16
 2019                 SNDISP=0
 2020              %FINISH
 2021  !
 2022              ACC=ELSIZE;                ! RESET ACC AFTER DV CMPLD
 2023              KFORM=FINF;                 ! FORMAT INFORMATION
 2024              K=A(JJJ+PP+1); TEST NST
 2025              STORE TAG(K,N)
 2026              REGISTER(1)=1;             ! MUST LOCK REGISTERS CONTAINING
 2027              REGISTER(2)=1;             ! ARRAYHEAD IN CASE 4K MULTIPLE
 2028              REGISTER(3)=1;             ! NEEDED TO STORE ARRAYHEAD
 2029              DUMPM(X'90',0,3,RBASE,N)
 2030              %CYCLE II=0,1,3
 2031                 FREE AND FORGET(II);    ! NOW FORGET REGISTERS
 2032              %REPEAT
 2033              N=N+JJ
 2034           %REPEAT
 2035           %IF CDV#0 %THEN SET USE(2,17,DVDISP)
 2036           P=P+1;                        ! PAST REST OF ARRAYLIST
 2037           N=(N+3)&(-4)
 2038           %IF A(P-1)=1 %THEN -> START
 2039           %END
 2040  SW(8):                                 ! %END
 2041           %BEGIN
 2042           {%SHORTROUTINE}
 2043           %SWITCH S(1:5)
 2044           -> S(A(P+1))
 2045  S(1):                                  ! ENDOFPROGRAM
 2046  S(2):                                  ! ENDOFFILE
 2047           %IF CPRMODE=0 %THEN CPRMODE=2
 2048           FAULT(15,0) %UNLESS LEVEL+CPRMODE=3
 2049           FAULT(56,0) %UNLESS A(P+1)=CPRMODE
 2050           CEND(CPRMODE)
 2051           LOAD DATA; {%STOP - load data does a %stop!}
 2052  S(3):                                  ! ENDOFLIST
 2053           LIST=0;
 2054  S(4):                                  ! ENDOFMCODE
 2055           ->Label1
 2056  S(5):                                  ! END
 2057           CEND(FLAG)
 2058  Label1:       %END; ->Label1
 2059  !
 2060  SW(9):   P=P+1; MARKER1=A(P)+P;        ! (SEX)(RT)(SPEC')(NAME)(FPP)
 2061  Label900:     Q=P; KKK=A(MARKER1+1);        ! KKK ON NAME
 2062           EXTRN=A(P+1)
 2063           %IF A(MARKER1)=1 %THEN %START;! P<%SPEC'>='%SPEC'
 2064              P=P+1;  CRSPEC(1-EXTRN>>2);! 0 FOR ROUTINESPEC
 2065                                         ! 1 FOR EXTERNAL (ETC) SPEC
 2066              ->Label1
 2067           %FINISH
 2068           KK=KKK;                       ! ROUTINE HEADING NOT SPEC
 2069           CNOP(0,4)
 2070           COPY TAG(KKK)
 2071           ->Label939 %IF OLDI#LEVEL;        ! NAME DECLARED AT OUTER LEVEL
 2072           %IF CPRMODE=0 %THEN %START;  ! NO BEGIN OR ROUTINE STMNT YET?
 2073              CA=0; CABUF=0
 2074              PPCURR=0;  CPRMODE=2;     ! FLAG AS FILE OF ROUTINES
 2075           %FINISH
 2076  !
 2077           %IF EXTRN#4 %THEN %START;   ! SYSTEM EXTERNAL DYNAMIC
 2078              %IF (CPRMODE=2 %AND LEVEL=1) %OR COMPILER=1=RLEVEL %START
 2079                 %IF EXTRN=3 %THEN EXTRN=2
 2080                 DEFINE EP(EXTRN,KKK,CA,0)
 2081                 SET PERMBASE
 2082              %FINISH %ELSE %START;    ! EXTERNALS IN PRGM OR WRNG LEVEL
 2083                 FAULT(55,0); EXTRN=4
 2084              %FINISH
 2085           %FINISH
 2086           %IF A(P+2)=1 %THEN KKK=10000 %ELSE %START
 2087              ROUT=1; P=P+3;           ! FIGURE OUT PTYPE FOR FNS&MAPS
 2088              CLT; ARR=0
 2089              NAM=(A(P)-1)<<1;         ! SET NAME ARRAY BIT FOR MAPS
 2090              PACK(KKK);              ! AND STORE PTYPE IN KKK
 2091           %FINISH
 2092           ->Label940 %IF J=15 %AND PTYPE=KKK
 2093  Label939:     P=Q+1; CRSPEC(0); P=Q; ->Label900
 2094  Label940:     %BEGIN
 2095           {%SHORTROUTINE}
 2096           %INTEGER PTR,PTYPEP
 2097           J=0; REPLACE TAG(KK);!  BODY GIVEN SO UPDATE TAGS INFO
 2098           JJ=K; PLABEL=PLABEL-1
 2099           ENTER JUMP(15,PLABEL,0) %UNLESS COMPILER=1 %OR %C
 2100+                                 (CPRMODE=2 %AND LEVEL=1)
 2101           PTYPEP=PTYPE
 2102           RHEAD(KK)
 2103           FLAG=PTYPEP
 2104           P=MARKER1+1
 2105           %IF A(P+1)=1 %THEN %START;   ! FORMAL PARAMETERS TO DEAL WITH
 2106              %CYCLE;                   ! UNTIL NO MORE FP-PART
 2107                 P=P+2
 2108                 CFPDEL
 2109                 %CYCLE PTR=1,1,A(P);   ! CYCLE DOWN NAMELIST
 2110                    %IF JJ#0 %THEN %START
 2111                       FROM12(JJ,J,JJJ);! EXTRACT PTYPE XTRA INFO
 2112                       %UNLESS J=PTYPE %AND (PTYPE#5 %OR JJJ>>16=ACC) %C
 2113+                         %THEN FAULT(9,A(P+PTR))
 2114                    %FINISH %ELSE FAULT(8,0);! MORE FPS THAN IN SPEC
 2115                    MLINK(JJ)
 2116                 %REPEAT
 2117                 DECLARE SCALARS(0,0)
 2118              %REPEAT %UNTIL A(P)=2;! UNTIL NO MORE FP-PART
 2119              N=(N+3)&(-4);         ! TO WORD BOUNDARY AFTER ALL SYSTEM
 2120                                    ! STANDARD PARAMETERS HAVE BEEN DECLARED
 2121           %FINISH
 2122           FAULT(10,0) %UNLESS JJ=0
 2123           %END; ->Label1202
 2124  !
 2125  SW(11):                                !REALS(LN)
 2126           ALL LONG=A(P+1)&1;->Label1
 2127  !
 2128  SW(12):                                !%BEGIN
 2129           PTYPE=0; RHEAD(-1)
 2130           ->Label1 %IF LEVEL=1=RLEVEL
 2131           ->Label1202 %UNLESS LEVEL=2
 2132           CPRMODE=1 %IF CPRMODE=0
 2133           DEFINE EP(0,0,0,0)
 2134           FAULT(55,0) %UNLESS CPRMODE=1
 2135  Label1202:    %IF SBFLAG=0 %THEN %START
 2136              PLANT(X'05A0'); CODEBASE=CA;
 2137              GRINF(10)=CA; CUR CYC VAR=0
 2138           %FINISH
 2139           %IF CHECKSP#0 %THEN %START
 2140              PCONST(X'41000004');          ! LA 0,4 --- FAULT 4=EXCESS BLKS
 2141              PCONST(X'9812D040');          ! LM 1,2 TOPSTREF
 2142              PLANT(X'1211');               ! LTR 1,1
 2143              PRX(X'47',10,0,10,CA-CODEBASE+8);! BHE *+8
 2144              PCONST(X'58202000');          ! L 2,0(2)
 2145              PLANT(X'19B2');               ! CR 11,2
 2146              PCONST(X'4720C054');          !  BH  RUN TIME FAULT ROUTINE
 2147              CCSTATE=-1
 2148              FORGET(1); FORGET(2)
 2149           %FINISH
 2150          ->Label1
 2151  !
 2152  SW(13):
 2153                                         ! '%FAULT'(FLIST)(S)
 2154           WARN(LINE)
 2155           FAULT(26,0) %UNLESS LEVEL=2 %AND CPRMODE#2
 2156           NMDECS=NMDECS!1
 2157           %CYCLE;         ! UNTIL RESTOFFAULTLIST IS NULL
 2158              P=P+2; Q=P+1
 2159              Q=Q+2 %WHILE A(Q)#2
 2160              %CYCLE;    ! UNTIL RESTOFNLIST IS NULL
 2161                 K=A(Q+2)+(A(Q+1)-1)<<14
 2162                 KKK=A(P);PCONST(X'41100000'!KKK)
 2163                 FAULT(36,0) %IF KKK>32 %OR KKK=0 %OR KKK=29 %OR 11<KKK<14
 2164                 PPJ(20); QQ=CA
 2165                 ENTER JUMP(15,K,0);           ! JUMP TO LABEL
 2166                 PCONST(X'07000700') %UNLESS CA=QQ+8;! JUMP MUST BE 8 BYTES
 2167                 P=P+2
 2168              %REPEAT %UNTIL A(P-1)=2
 2169              P=P+2
 2170           %REPEAT %UNTIL A(P)=2; ->Label1
 2171  !
 2172  SW(15):  %BEGIN;                       !SWITCH (SWITCH LIST)
 2173           {%SHORTROUTINE}
 2174           %INTEGER Q,RANGE,KKK,KK,LB
 2175           Q=P
 2176           FAULT(56,0) %UNLESS LEVEL>=2
 2177           %IF SBFLAG=1 %OR COMPILER=1 %THEN PREC=2 %ELSE PREC=0
 2178           PTYPE=106+10*PREC;            !(SHORT?) LABEL ARRAY
 2179           %CYCLE;         ! UNTIL NO'REST OF SW LIST'
 2180              P=A(Q+1)+Q+2;              ! PAST 'NAMELIST' TO 'BPAIR'
 2181              CBPAIR(KKK,KK);            ! LOWER BOUND TO KKK UPPER TO KK
 2182              %UNLESS |KKK| <X'7FFF'>|KK| %THEN %START
 2183                 FAULT(18,0); KK=0; KKK=0
 2184              %FINISH
 2185              RANGE=(KK-KKK+1)*BYTES(PREC)
 2186              LB=KKK; KKK=KKK&X'FFFFFF'!PREC<<24
 2187              %CYCLE QQ=1,1,A(Q+1);
?Non-local
 2188                                   ;      !  DOWN NAMELIST
 2188                 K=A(Q+QQ+1)
 2189                 TEST NST
 2190                 SSTL=(SSTL+3)&(-4);     !  CONST TABLES TO WORD BNDRY
 2191                 OPHEAD=0; R=LB
 2192  !
 2193  ! SET UP A BIT LIST (96 BITS PER CELL) TO CHECK FOR SWITCH LABELS
 2194  ! SET TWICE
 2195  !
 2196                 %CYCLE
 2197                    PUSH123(OPHEAD,0,0,0)
 2198                    R=R+96
 2199                 %REPEAT %UNTIL R>KK
 2200  !
 2201  ! OUTPUT ARRAYBOUNDS (CHECKING MODE) AND CLEAR THE TABLE SPACE
 2202  !
 2203                %IF (COMPILER=0 %OR CHECKSP=1) %AND (INHCODE=0)%C
 2204+               %THEN %START
 2205                    LPUT(4,8,SSTL,ADDR(KKK))
 2206                    SSTL=SSTL+8
 2207                 %FINISH
 2208                 PUSH123(OPHEAD,SSTL-8,LB,KK)
 2209                 J=1; STORE TAG(K,OPHEAD)
 2210                 %IF INHCODE=0 %THEN %C
 2211+                   LPUT(4,RANGE,SSTL,COMPILER)
 2212                 SSTL=(SSTL+RANGE+3)&(-4)
 2213              %REPEAT;                   ! FOR ANY MORE NAMES IN NAMELIST
 2214              Q=P
 2215           %REPEAT %UNTIL A(Q)=2;                      ! UNTIL A(Q)=2
 2216           %END;->Label1
 2217  !
 2218  SW(16):  LIST=1; ->Label1;                  ! %LIST
 2219  !
 2220  !
 2221  SW(17):                                ! '%OWN' (TYPE)(OWNDEC)
 2222           %BEGIN
 2223           {%SHORTROUTINE}
 2224  !***********************************************************************
 2225  !*       INITIALISED DECLARATION GO INTO THE GLA OR GLA SYMBOL TABLES  *
 2226  !*       EXCEPT FOR CONST ARRAYS WHICH GO INTO THE CODE SYMBOL TABLES  *
 2227  !*       STRINGS AND ARRAYS HAVE A HEADER IN THE GLA. LPUT ARRANGES    *
 2228  !*       FOR THE LOADER TO RELOCATE THE HEADERS.                       *
 2229  !*      EXTERNALS ARE IDENTICAL WITH OWN BUT ALSO HAVE A DATA EP DEFN  *
 2230  !*       IN THE LOAD DATA SO THEY CAN BE FOUND AT LOAD TIME            *
 2231  !*      EXTRINSICS HAVE A DATA REFERENCE AND A DUMMY HEADER IN THE GLA *
 2232  !*      THE LOADER USES THE FORMER TO RELOCATE THE LATTER.             *
 2233  !***********************************************************************
 2234           %ROUTINESPEC CLEAR(%INTEGER L)
 2235           %ROUTINESPEC STAG(%INTEGER J,DATALEN)
 2236           %INTEGER LENGTH,BP,PP,SIGN,CBASE,MODE
 2237           %INTEGER ICONST,CTYPE,TAGDISP,EPTYPE,EPDISP
 2238           %LONGREAL RCONST
 2239           %STRING(255) SCONST
 2240           %INTEGER AH1,AH2,AH3,AH4,AD,FNAM,FINF
 2241           %INTEGER SPOINT,CONSTSFOUND,EXTRN,NNAMES,MARK,LPUTP
 2242           %INTEGERNAME STPTR
 2243           LPUTP=5; STPTR==CONSTPTR;     ! NORMAL CASE GLA SYMBOLTABLES
 2244  !         FAULT(40,0) %IF NMDECS&1#0
 2245           EXTRN=A(P+1)&3
 2246           %IF EXTRN=0 %THEN LPUTP=4 %AND STPTR==SSTL
 2247           P=P+3; CBASE=GLA
 2248           MODE=A(P-1);                ! MODE =1 FOR NORMAL OWNS
 2249           ->RECORD %IF MODE>1;        ! MODE =2 FOR OWN RECORDS
 2250           CLT;                        ! MODE =3 FOR OWN RECORD ARRAYS
 2251           %IF TYPE=5 %AND ACC=0 %THEN FAULT(70,0) %AND ACC=2
 2252           %IF EXTRN=0 %THEN PREC=PREC!4
 2253           NAM=TYPE>>2; ROUT=0; ARR=A(P)-1; PACK(PTYPE)
 2254           -> NON SCALAR  %UNLESS ARR=0
 2255           %CYCLE;    ! UNTIL <RESTOFOWNDEC> NULL
 2256              MARK= P+1+A(P+1); NNAMES=A(P+2)
 2257              PP=P+3; P=PP+NNAMES;        ! P ON CONST'
 2258     !
 2259     ! OBTAIN THE INITIAL CONSTANT,ITS TYPE(CTYPE) AND SIGN(SIGN)
 2260     ! CONVERT TO ALL LEGAL FORMS AND STORE THE INTEGER IN ICONST
 2261     ! THE REAL IN RCONST AND THE STRING IN SCONST.
 2262     ! NB 65 IS A VALID INTEGER OR REAL AND ALSO A STRING ('A')
 2263     !
 2264              ICONST=0; RCONST=0; SCONST=""
 2265              SIGN=4; CTYPE=TYPE; CONSTSFOUND=0
 2266     !
 2267              %IF A(P)=1 %THEN %START;     ! CONSTANT GIVEN
 2268                 SIGN=A(P+1); CTYPE=A(P+2)&7
 2269                 CONSTSFOUND=1
 2270                 %IF CTYPE=2 %THEN %START; ! REAL CONSTANT
 2271                    FROMAR8(P+3,RCONST)
 2272                    %IF SIGN=2 %THEN RCONST=-RCONST
 2273                 %FINISH
 2274     !
 2275                 %IF CTYPE=5 %THEN SCONST=STRING(ADDR(A(P+3))+1)
 2276     !
 2277                 %IF CTYPE=1 %THEN %START; ! INTEGER CONSTANT
 2278                    FROMAR4(P+3,ICONST)
 2279                    %IF SIGN=2 %THEN ICONST=-ICONST
 2280                    %IF SIGN=3 %THEN ICONST=\ICONST
 2281                    %IF TYPE=2 %THEN %C
 2282+                   RCONST=ICONST;         ! INTEGER A SPECIAL CASE OF REAL
 2283                    %IF 1<=ICONST<=127 %THEN SCONST=TOSTRING(ICONST)
 2284                 %FINISH
 2285              %FINISH
 2286              LENGTH=BYTEINTEGER(ADDR(SCONST))
 2287     !
 2288     !
 2289     ! FAULT ANY OBVIOUS ERRORS IE:-
 2290     ! CONSTANT FOR EXTRINSIC OR INCOMPATIBLE TYPE OR STRING TOO LONG
 2291     !
 2292              %IF (EXTRN=3 %AND CONSTSFOUND#0 ) %OR %C
 2293+                (CTYPE=2 %AND TYPE#2) %OR %C
 2294+                (CTYPE=5 %AND (TYPE#5 %OR SIGN#4 %OR LENGTH>=ACC)) %C
 2295+                %OR (SIGN=3 %AND CTYPE#1) %THEN FAULT(44,0)
 2296     !
 2297              %CYCLE;         ! DOWN <NAMELIST>
 2298                 J=0; K=A(PP)
 2299                 %IF TYPE=5 %THEN %START;         ! STRING
 2300                    QQ=STPTR; AD=ADDR(SCONST)
 2301                    %IF EXTRN<=1 %AND ACC<=8 %THEN %START
 2302                       NAM=0; PACK(PTYPE)
 2303                       TAGDISP=GLACA;    ! SHORT STRING INTO GLA NO POINTER
 2304                       PGLA(1,ACC,AD)
 2305                    %FINISH %ELSE %START
 2306                       %IF EXTRN=3 %THEN %START;  ! EXTRINSIC STRINGS
 2307                          AH3=0;                  ! DUMMY STRING HEADER
 2308                       %FINISH %ELSE %START
 2309                          LPUT(LPUTP,ACC,QQ,AD) %IF INHCODE=0;! O/P STRING
 2310                          STPTR=(STPTR+ACC+3)&(-4)
 2311                          AH3=QQ
 2312                       %FINISH
 2313                       AH3=AH3!(ACC-1)<<24
 2314                       PGLA(4,4,ADDR(AH3))
 2315                       TAGDISP=GLACA-4
 2316                       %IF EXTRN=3 %THEN GXREF(2,K,ACC,TAGDISP) %C
 2317+                         %ELSE RELOCATE(TAGDISP,AH3,LPUTP)
 2318                       EPTYPE=4; EPDISP=QQ;       ! DATA IN GLA SYMBOL TABLES
 2319                    %FINISH
 2320                 %FINISH %ELSE %START;           ! INTEGER & REAL
 2321                    %IF EXTRN=3 %THEN %START;    ! EXTRINSICS
 2322                       NAM=1; PACK(PTYPE);       ! EXTRINSICS VIA PTR
 2323                       CXREF(2,K,ACC,TAGDISP)
 2324                    %FINISH %ELSE %START;        ! OWN,EXTERNAL&CONST
 2325                       %IF TYPE=2 %THEN %START
 2326                          AD=ADDR(RCONST)
 2327                       %FINISH %ELSE %START;     ! INTEGER VARIABLES
 2328                          FAULT(44,0) %IF (PREC&3=1 %AND ICONST>255) %C
 2329+                                   %OR (PREC&3=2 %AND |ICONST|>>16#0)
 2330                          AD=ADDR(ICONST)+4-ACC
 2331                       %FINISH
 2332                       %IF TYPE=1 %AND EXTRN=0 %AND 0<=ICONST<4096 %C
 2333+                         %THEN KFORM=ICONST %ELSE KFORM=-1
 2334                       %IF EXTRN=0 %AND ACC>1 %START;  !CONST VAR==CONST SO SHARE IT
 2335                          STORE CONST(CBASE,TAGDISP,ACC,AD)
 2336                       %FINISH %ELSE %START
 2337                          PGLA(ACC,ACC,AD);      ! PUT CONSTANT INTO GLA
 2338                          CBASE=GLA
 2339                          TAGDISP=GLACA-ACC;     ! OFFSET OF VAR FOR TAGS
 2340                          EPDISP=TAGDISP;        ! AND FOR ENTRY DEFN
 2341                          EPTYPE=3;              ! DATA IN ADRESSABLE GLA
 2342                       %FINISH
 2343                    %FINISH
 2344                 %FINISH
 2345                 STAG(TAGDISP,ACC)
 2346                 PP=PP+1
 2347              %REPEAT %UNTIL NNAMES=0
 2348              P=MARK
 2349           %REPEAT %UNTIL A(MARK)=2
 2350           ->Label99
 2351  RECORD:                                ! <XOWN>'%RECORD'<NAMELIST>
 2352  !***********************************************************************
 2353  !*       NO INITIALISATION OF OWN RECORDS ALLOWED SO THEY ARE ALL      *
 2354  !*       CLEARED TO ZERO.                                              *
 2355  !***********************************************************************
 2356           MARKER1=P+A(P)+3-MODE;     ! TO FORMAT NAME
 2357           FNAM=A(MARKER1)
 2358           COPYTAG(FNAM)
 2359           FINF=TCELL
 2360           %IF PTYPE#4 %THEN FAULT(62,FNAM) %AND ->Label99
 2361           %IF EXTRN=0 %THEN PTYPE=143 %ELSE PTYPE=103
 2362           KFORM=FINF;! UNPACK
 2363  !%if USE MC = 1 %start
 2364  !            *L_1,PTYPE; *CVD_1,0(11)
 2365  !            *UNPK_ROUT(5),5(3,11)
 2366  !            *NC_ROUT(5),MASK1
 2367  !%finish
 2368           ->NONSCALAR %IF MODE=3
 2369           NNAMES=A(P); PTYPE=1003; J=0
 2370           %CYCLE
 2371              P=P+1; K=A(P)
 2372              %IF EXTRN=3 %THEN %START;     ! EXTRINISIC
 2373                 CXREF(2,K,ACC,TAGDISP); ! RELOCATE BY EXTERNAL
 2374              %FINISH %ELSE %START
 2375                 CLEAR(ACC)
 2376                 EPDISP=STPTR-ACC
 2377                 AH3=EPDISP
 2378                 RELOCATE(-1,AH3,LPUTP);! PUT DISP INTO GLA
 2379                 TAGDISP=GLACA-4;        ! AND RELOCATE REL APPROPIATE AREA
 2380                 EPTYPE=4;              ! DATA IN GLA SYMBOL TABLES
 2381              %FINISH
 2382              STAG(TAGDISP,ACC)
 2383           %REPEAT %UNTIL NNAMES=0
 2384           ->Label99
 2385  NONSCALAR:                             ! OWN AND OWNRECORD ARRAYS
 2386  !***********************************************************************
 2387  !*       OWN ARRAYS CAN BE INITIALISED BUT ONLY ONE ARRAY CAN BE       *
 2388  !*       DECLARED IN A STATEMENT.(THANK HEAVENS!)                      *
 2389  !*       OWN RECORD ARRAYS ARE CLEARED TO ZERO                         *
 2390  !***********************************************************************
 2391           PP=P+1; P=P+2; J=1; NNAMES=1
 2392           K=A(PP)
 2393           CBPAIR(KK,KKK)
 2394           %IF TYPE>=3 %THEN BP=ACC %ELSE BP=BYTES(PREC)
 2395           LENGTH=KKK-KK+1; QQ=LENGTH*BP
 2396           CONSTS FOUND=0
 2397           %IF MODE#3 %THEN %START;   ! NOT A RECORD ARRAY
 2398              FROM AR4(P+1,CONSTS FOUND)
 2399              FROM AR4(P+3,SPOINT);    ! DISPLACEMENT OF CONSTANTS
 2400           %FINISH
 2401           !*INSERT
 2402           %IF CONSTS FOUND=0 %THEN %START;! NO CONSTANTS GIVEN
 2403                                           ! SO CLEAR AN AREA TO ZERO
 2404              CONSTS FOUND=LENGTH
 2405              CLEAR(QQ) %UNLESS LENGTH<1 %OR EXTRN=3
 2406              SPOINT=STPTR-QQ
 2407           %FINISH %ELSE %START
 2408           !*INSERT
 2409              FAULT(46,K) %IF EXTRN=3
 2410           %FINISH
 2411           FAULT(45,K) %UNLESS KKK>=KK %AND LENGTH=CONSTS FOUND
 2412  !
 2413  ! NOW OUTPUT A DOPE VECTOR FOR STRING ARRAYS OR IF CHECKS ARE ON
 2414  !
 2415           %UNLESS COMPILER=1 %AND CHECKS=0 %AND TYPE#5 %THEN %START
 2416              AH3=DOPE VECTOR(BP,KK,KKK)
 2417           %FINISH %ELSE AH3=SSTL
 2418           %IF EXTRN=3 %THEN EPDISP=0 %ELSE EPDISP=SPOINT
 2419  !
 2420  ! OUTPUT AN ARRAYHEAD INTO THE GLA RELATIVE TO THE START OF THE SYMBOL-
 2421  ! TABLES IN WHICH THE ARRAY RESIDES. PERM INITIALISATION WILL RELOCATE
 2422  ! BY ADDING INTO AH1-3 THE VIRTUAL ADDRESS OF THE START OF THE
 2423  ! APPROPIATE AREA.
 2424  !
 2425           AH1=EPDISP-KK*BP
 2426           AH2=EPDISP
 2427           AH4=BP; JJ=16-COMPILER<<2
 2428           PGLA(4,JJ,ADDR(AH1))
 2429           TAGDISP=GLACA-JJ
 2430           %IF EXTRN=3 %THEN %START;     ! EXTRINSIC ARRAYS
 2431              GXREF(2,K,QQ,TAGDISP);     ! RELOCATE ADDR(A(0))
 2432              GXREF(2,K,QQ,TAGDISP+4);   ! RELOCATE ADDR(A(FIRST))
 2433           %FINISH %ELSE %START
 2434              RELOCATE(TAGDISP,AH1,LPUTP);! RELOCATE ADDR(A(0))
 2435              RELOCATE(TAGDISP+4,AH2,LPUTP);! RELOCATE ADDR(A(FIRST))
 2436           %FINISH
 2437           RELOCATE(TAGDISP+8,AH3,4);    ! RELOCATE DV POINTER
 2438           EPTYPE=4;                     ! DATA IN GLA SYMBOL TABLES
 2439           STAG(TAGDISP,QQ)
 2440           ->Label99
 2441           %ROUTINE CLEAR(%INTEGER LENGTH)
 2442                 STPTR=(STPTR+7)&(-8)
 2443           LENGTH=(LENGTH+3)&(-4)
 2444           LPUT(LPUTP,LENGTH,STPTR,0)%IF INHCODE=0
 2445           STPTR=STPTR+LENGTH
 2446           %END
 2447           %ROUTINE STAG(%INTEGER J,DATALEN)
 2448           TEST NST
 2449           %IF EXTRN=2 %THEN DEFINE EP(EPTYPE,K,EPDISP,DATALEN)
 2450           RBASE=CBASE
 2451           STORE TAG(K,J)
 2452           RBASE=10-RLEVEL
 2453           NNAMES=NNAMES-1
 2454           %END
 2455  Label99:      %END; ->Label1
 2456  SW(18):
 2457           P=P+1
 2458           CRSPEC(2); ->Label1
 2459  SW(19):
 2460                                          ! '%NAME' SPECIAL NAME
 2461           PUSH123(TAGS(A(P+1)),SNPT<<16!X'8090',0,SNUM<<16)
 2462           SNUM=SNUM+1;->Label1
 2463  SW(20):                          ! TRUSTED PROGRAM
 2464  !
 2465  ! TRUSTED PROGRAMS HAVE:-
 2466  !     1) NO JUMPS ROUND ROUTINE BODIES
 2467  !     2) NO ERROR EXITS FROM FNS & MAPS
 2468  !     3) NO CYCLES OF THE FORM I:=1,1,I
 2469  !     4) NO RELIANCE ON THE VALUE OF CYCLE VARIABLES AT TERMINATION
 2470  !
 2471           MARGIN=512
 2472           COMPILER=1 %IF CHECKSP=0;     ! ONLY WORKS ON PARM OPT
 2473           ->Label1
 2474  SW(21):
 2475                                         ! '%REGISTER'(NAME)(S)
 2476           WARN(LINE)
 2477           %IF A(P+2)=1 %THEN KK=A(P+3) %ELSE FINDREG(CLMABL,KK)
 2478           %IF 4<KK<15 %AND REGISTER(KK)=0 %THEN %START
 2479              UVARREG(KK)=LEVEL
 2480              PTYPE=8; J=0
 2481              K=A(P+1); TESTNST
 2482              KFORM=M'RG'
 2483              STORE TAG(K,KK)
 2484              SET USE(KK,3,TAGS(K))
 2485              REGISTER(KK)=-1
 2486           %FINISH %ELSE FAULT(58,0)
 2487  SW(22):
 2488           ->Label1;                         ! '%MCODE'
 2489  SW(24):
 2490           P=P+1; LCA=0; CUCI; ->Label1;            ! '*'(UCI)(S)
 2491  SW(26):
 2492           %BEGIN;                       ! %COMMENT %DEFINE (SOMETHING)
 2493           {%SHORTROUTINE}
 2494           %SWITCH S(1:3)
 2495           %INTEGER I,J,K
 2496           -> S(A(P+1))
 2497  S(1):    I=ADDR(FIXED GLA(27)); ->Label1
 2498  S(2):    I=ADDR(IOCP1)+3; ->Label1
 2499  S(3):    I=ADDR(MAIN EP1)+3
 2500  Label1:       K=A(P+2)
 2501           FAULT(50,0) %UNLESS CPRMODE=0 %AND K<=7
 2502           J=ADDR(A(P+2))+1
 2503  !%if USE MC = 1 %start
 2504  !         *L_1,I;*L_2,J
 2505  !         *MVC_0(8,1),0(2)
 2506  !%finish
 2507           %END; ->Label1
 2508  SW(25):
 2509                                         ! %CONTROL (CONST)
 2510  !         FAULT(33,0) %UNLESS IMPS=1
 2511           FROM AR4(P+2,J)
 2512           K=J&15; LINENOS=K %UNLESS K=15
 2513           K=J>>4&15; DIAGS1=K&1 %AND DIAGS2=K&2 %UNLESS K=15
 2514           K=J>>8&15
 2515           CHECKS=K %UNLESS K=15
 2516           CHECKSP=K&14 %UNLESS K=15
 2517           GLAFLAG=CHECKSP
 2518           K=J>>12&15
 2519           UNASS=K %UNLESS K=15
 2520           K=J>>24&15
 2521           %IF K=1 %THEN %START;         ! PERMIT LOWER CASE NAMES
 2522              %CYCLE I=1,1,26
 2523                 TRTABS(I+96)=0
 2524              %REPEAT
 2525           %FINISH
 2526           K=J>>28
 2527           %IF K=1 %THEN CODEOUT
 2528           DCOMP=K %UNLESS K=15
 2529           ->Label1
 2530  SW(27):
 2531           %BEGIN;                       ! %RECORD (RDECLN)
 2532  !***********************************************************************
 2533  !*       RECORDS ARE ALLOCATED AT COMPILE TIME WHEN POSSIBLE           *
 2534  !*       SEE CRFORMAT FOR ACTION ON RECORD FORMAT DECLARATIONS         *
 2535  !***********************************************************************
 2536           {%SHORTROUTINE}
 2537           %INTEGER MODE,RECL,ALLOC,FNAM,FINF,NAME
 2538           P=P+1; MODE=A(P)
 2539           %IF MODE=1 %THEN %START;      ! DEAL WITH FORMAT
 2540              NAME=A(P+1); P=P+2
 2541              CRFORMAT(OPHEAD); K=NAME
 2542              PTYPE=4; J=0
 2543              KFORM=OPHEAD
 2544              TEST NST; STORE TAG(K,OPHEAD)
 2545              ->Label99
 2546           %FINISH
 2547           P=P+1; MARKER1=P+A(P)
 2548           FNAM=A(MARKER1);              ! FORMAT NAME
 2549           COPY TAG(FNAM)
 2550           FINF=TCELL
 2551           %IF TYPE#4 %THEN %START
 2552              FINF=DUMMY FORMAT
 2553              ACC=4; FAULT(62,FNAM)
 2554           %FINISH
 2555           RECL=ACC
 2556           %IF MODE=2%THEN %START;       ! '%RECORDSPEC'
 2557              COPY TAG(A(P+1))
 2558              %IF A(P+2)=1 %AND TYPE=4 %START;! SPEC FOR FORMAT ELEMENT
 2559                 P=P+3
 2560                 Q=DISPLACEMENT(TCELL)
 2561                ! UNPACK
 2562  !%if USE MC = 1 %start
 2563  !            *L_1,PTYPE; *CVD_1,0(11)
 2564  !            *UNPK_ROUT(5),5(3,11)
 2565  !            *NC_ROUT(5),MASK1
 2566  !%finish
 2567              %FINISH
 2568              %IF TYPE=3 %AND NAM=1 %AND FROM3(TCELL)&X'FFFF'=0 %START
 2569                 REPLACE3(TCELL,FINF!K<<16)
 2570                 REPLACE2(TCELL,SNDISP<<16!RECL)
 2571              %FINISH %ELSE FAULT(63,0)
 2572           %FINISH %ELSE %START;         ! RECORD DECLARATION
 2573              FAULT(57,0) %UNLESS LEVEL>=2
 2574              FAULT(40,0) %IF NMDECS&1#0
 2575              TYPE=3; PREC=0; ROUT=0
 2576             %IF A(P+1)=1 %THEN %START;  ! SIMPLE RECORD AND RECORDNAMES
 2577                 ALLOC=ACC; CQN(P+2)
 2578                 ACC=ALLOC; P=P+3
 2579                 DECLARE SCALARS(1,FINF)
 2580              %FINISH %ELSE %START;      ! ARRAYS OF RECORDS
 2581                 NAM=0
 2582                 Q=2-A(P+2); P=P+3;      ! Q=1 FOR ARRAY FORMAT
 2583                 DECLARE ARRAYS(Q,FINF)
 2584              %FINISH
 2585           %FINISH
 2586  Label99:      %END;->Label1
 2587  !
 2588  
 2589  SW(28):                                 ! '%ON'(EVENT')(N)(RESTOFNLIST)
 2590  %BEGIN
 2591  {%SHORTROUTINE}
 2592  %INTEGER EL,KK,EF
 2593  %CONSTINTEGERARRAY EFMAP(1:14)=X'04E10003',8,X'20000',X'2000',
 2594+                   X'08100074',X'A0000000',X'2000000',X'40000000',
 2595+                   X'100',X'01000000',X'40000',0(3);
 2596        FAULT(40,0) %IF NMDECS&1#0
 2597        NMDECS=NMDECS!1
 2598        FAULT(26,0) %UNLESS LEVEL=2 %AND CPRMODE#2
 2599        P=P+2; SFLABEL=SFLABEL-1; EL=SFLABEL
 2600        %CYCLE;           ! UNTIL NO MORE RESTOFNLIST
 2601           KK=A(P)
 2602           %IF 1<=KK<=14 %START
 2603              EF=EFMAP(KK)
 2604              %CYCLE I=0,1,31
?Non-local
 2605                 %IF 1<<I&EF#0 %START
 2606                    PCONST(X'41100001'+I)
 2607                    PPJ(20); QQ=CA
 2608                    ENTER JUMP(15,EL,0)
 2609                    PCONST(X'07000700') %UNLESS CA=QQ+8
 2610                 %FINISH
 2611              %REPEAT
 2612           %FINISH %ELSE FAULT(36,0)
 2613           P=P+2
 2614        %REPEAT %UNTIL A(P-1)=2
 2615        ENTER JUMP(15,SFLABEL-1,0);       ! ROUND ON START-FINISH
 2616        CSTART(2)
 2617        ENTER LAB(EL,0); MONE=1
 2618  %END; ->Label1
 2619           %ROUTINE CRFORMAT(%SHORTINTEGERNAME OPHEAD)
 2620           {%SHORTROUTINE}
 2621  !***********************************************************************
 2622  !*       CONVERTS A RECORDFORMAT STATEMENT TO A LIST HEADED BY OPHEAD  *
 2623  !*       FORMAT OF AN ENTRY.                                           *
 2624  !*       S1=SUBNAME<<20!PTYPE<<4!J                                     *
 2625  !*       S2,S3=4  16 BIT DISPLACEMENTS  D2,ACC,D1,KFORM                *
 2626  !*       NORMALLY D1=RECORD RELATIVE DISPLACEMENT AND ACC=LMAX(STRINGS)*
 2627  !*       FOR ARRAYS D2=ZERO ELEMENT DISPLACEMENT AND D1=DISPLACEMENT   *
 2628  !*       OF RECORD RELATIVE ARRAYHEAD IN THE GLA                       *
 2629  !*       KFORM IS ONLY USED FOR RECORDS AND POINTS TO THE FORMAT       *
 2630  !*       ON EXIT ACC HAS THE RECORD SIZE ROUNDED UP TO THE BOUNDARY    *
 2631  !*       REQUIRED BY ITS LARGEST COMPONENT                             *
 2632  !***********************************************************************
 2633           %SHORTINTEGER D1,D2,NLIST,SLIST,FORM
 2634           %INTEGER RL,MRL;               ! ROUNDING LENGTH & MAX
 2635           %INTEGER REP,INC,Q,LB,UB,R,A0,A1,DV,L,RFD
 2636           %SWITCH RFEL(1:5)
 2637           %ROUTINESPEC SN(%INTEGER Q)
 2638           %ROUTINESPEC ROUND
 2639           NLIST=0; OPHEAD=0; FORM=0; ACC=0
 2640           MRL=0; INC=0;                 ! INC COUNTS DOWN RECORD
 2641  NEXT:    ROUT=0; NAM=0; RFD=A(P)
 2642           %IF RFD<=2 %THEN P=P+1 %AND CLT
 2643           ->RFEL(RFD)
 2644  RFEL(1):                               ! (TYPE) (QNAME')(NAMELIST)
 2645           CQN(P); P=P+1
 2646           PACK(PTYPE); D2=0
 2647           %IF ACC>8 %THEN RL=3 %ELSE RL=ACC-1
 2648           %IF PTYPE=5 %THEN RL=0;       ! STRINGS NOT ALIGNED
 2649  Label1:      ROUND ; J=0
 2650           %CYCLE REP=1,1,A(P)
 2651              P=P+1; D1=INC
 2652              SN(P); INC=INC+ACC
 2653           %REPEAT
 2654           P=P+1+RFD>>2;       ! EXTRA  ONE FOR RECORDS TO SKIP FORMAT
 2655  TRY END: -> END %IF A(P)=2
 2656           P=P+1; -> NEXT
 2657  RFEL(2):Label2:                             ! (TYPE)%ARRAY(NAMELIST)(CBPAIR)
 2658           Q=P; ARR=1; PACK(PTYPE)
 2659           %CYCLE;       ! UNTIL <RESTOFARRAYLIST> NULL
 2660              P=A(P)+P+1; CBPAIR(LB,UB)
 2661              R=UB-LB+1
 2662              DV=DOPE VECTOR(ACC,LB,UB); ! DOPE VECTOR INTO SHAREABLE S.T.
 2663              %IF TYPE=5 %THEN RL=0 %ELSE RL=ACC-1
 2664              %IF TYPE=3 %THEN RL=7
 2665              ROUND; J=1
 2666              %CYCLE REP=1,1,A(Q);       ! ARRAYHEAD  INTO GLA FOR EACH AR
 2667                 A1=INC; A0=A1-ACC*LB
 2668                 L=ACC
 2669                 PGLA(4,16,ADDR(A0))
 2670                 D1=GLACA-16
 2671                 RELOCATE(D1+8,DV,4);    ! RELOCATE DV POINTER
 2672                 D2=A0
 2673                 SN(Q+REP); INC=INC+R*ACC
 2674              %REPEAT
 2675              P=P+1; Q=P
 2676           %REPEAT %UNTIL A(P-1)=2
 2677           P=P+1 %IF RFD=5
 2678           -> TRY END
 2679  RFEL(3):                               ! %RECORD (%ARRAY) %NAME
 2680           TYPE=3; PREC=0; NAM=1
 2681           ARR=2-A(P+1); P=P+2
 2682           PACK(PTYPE); D2=0
 2683           RL=3; ACC=4+12*ARR
 2684           FORM=0
 2685           ->Label1
 2686  RFEL(4):                               ! RECORDS IN RECORDS
 2687  RFEL(5):                                ! RECORDARRAYS IN RECORDS
 2688           Q=P+A(P+1)+6-RFD
 2689           COPY TAG(A(Q));               ! COPY FORMAT TAG & SET ACC
 2690           FAULT(62,A(Q)) %UNLESS PTYPE=4
 2691           TYPE=3; FORM=TCELL
 2692           %IF RFD=4 %THEN %START
 2693              PTYPE=3; P=P+1; D2=0
 2694              RL=7; ->Label1
 2695           %FINISH
 2696           P=P+2; ->Label2
 2697  END:                                   ! FINISH OFF
 2698           RL=MRL; ROUND
 2699           ACC=INC;                      ! SIZE ROUNDED APPROPRIATELY
 2700           FAULT(98,0) %UNLESS INC<=X'7FFF'
 2701           OPHEAD=SLIST
 2702           CLEAR LIST(NLIST)
 2703           %RETURN
 2704           %ROUTINE SN(%INTEGER Q)
 2705  !***********************************************************************
 2706  !*       CHECK THE SUBNAME HAS NOT BEEN USED BEFORE IN THIS FORMAT     *
 2707  !*       AND ENTER IT WITH ITS DESCRIPTORS INTO THE LIST.              *
 2708  !***********************************************************************
 2709           FNAME=A(Q)
 2710           FAULT(7,FNAME) %UNLESS FIND(FNAME,NLIST)=-1
 2711           INSERT AFTER(OPHEAD,FNAME<<20!PTYPE<<4!J,D2<<16!ACC)
 2712           REPLACE3(OPHEAD,D1<<16!FORM)
 2713           %IF NLIST=0 %THEN SLIST=OPHEAD
 2714           PUSH(NLIST,0,FNAME)
 2715           %END
 2716           %ROUTINE ROUND
 2717           MRL=RL %IF RL>MRL
 2718           INC=INC+1 %WHILE INC&RL#0
 2719           %END
 2720           %END;                         ! OF ROUTINE CRFORMAT
 2721           %ROUTINE CRNAME(%INTEGER Z,REG,MODE,CLINK,BS,IX,DP)
 2722           {%SHORTROUTINE}
 2723  !***********************************************************************
 2724  !*       DEAL WITH RECORD ELEMENT NAMES.Z AS FOR CNAME.CLINK=TAGS(RN)  *
 2725  !*       MODE=0 IF RECORD AT BS,IX&DP                                  *
 2726  !*       MODE=1 IF POINTER IN CORE AT BS,IX&DP                         *
 2727  !*       ON EXIT BASE,INDEX & DISP POINT TO REQUIRED ELEMENT           *
 2728  !*       RECURSIVE CALL IS NEEDED TO DEAL WITH RECORDS IN RECORDS      *
 2729  !*       DEPTH SHEWS  RECURSIVE LEVELS- NEEDED TO AVOID MIS SETTING    *
 2730  !*       REGISTER IN USE IF RECORDNAME IN RECORD HAS THE SAME NAME AS  *
 2731  !*       A GENUINE RECORD NAME.                                        *
 2732  !***********************************************************************
 2733           %INTEGER DEPTH,FNAME,ACCP
 2734           %ROUTINESPEC CENAME(%INTEGER MODE,FNAME,BS,IX,DP)
 2735           %ROUTINESPEC NOAPP
 2736           DEPTH=0
 2737           FNAME=KFORM;                  ! POINTER TO FORMAT
 2738           %IF ARR\=0 %THEN %START;      ! RECORDARRAY(ARRAYNAME)
 2739              FAULT(217,0) %IF IX\=0
 2740              CANAME(ARR,BS,DP,SNDISP)
 2741              NAM=0; ARR=0;                 ! ARR & NAM AS FOR SCALAR RECORD
 2742              CENAME(0,FNAME,BASE,INDEX,DISP)
 2743           %FINISH %ELSE %START
 2744              %IF A(P+1)=2 %THEN P=P+2 %ELSE NO APP
 2745              CENAME(MODE,FNAME,BS,IX,DP)
 2746           %FINISH; ->Label99
 2747  !
 2748           %ROUTINE NOAPP
 2749              P=P+1
 2750              %IF A(P)=1 %THEN %START;    ! <APP> PRESENT
 2751                 FAULT(19,A(P-1))
 2752                 SKIP APP
 2753              %FINISH %ELSE P=P+1;         ! P NOW POINTS TO ENAME
 2754           %END
 2755           %ROUTINE CENAME(%INTEGER MODE,FNAME,BS,IX,DP)
 2756  !***********************************************************************
 2757  !*       FINDS OUT ABOUT SUBNAME AND ACTS ACCORDINGLY.MOSTLY ACTION    *
 2758  !*       CONSISTS OF UPPING DP BY OFFSET OF THE SUBNAME BUT IS VERY    *
 2759  !*       HAIRY FOR RECORDS IN RECORDS ETC                              *
 2760  !***********************************************************************
 2761           %ROUTINESPEC CHANGE MODE
 2762           %ROUTINESPEC COMBINE(%INTEGER HOW)
 2763           %INTEGER Q,QQ,D,C
 2764           DEPTH=DEPTH+1
 2765           %IF A(P)=2 %THEN %START;      ! ENAME MISSING
 2766              BASE=BS; DISP=DP;INDEX=IX; ! FOR POINTER
 2767              %IF Z<14 %THEN %START;     ! NOT A RECORD OPERATION
 2768                 P=P-2
 2769                 %UNLESS 3<=Z<=4 %OR (Z=1 %AND REG=99) %START;! ADDR(RECORD)
 2770                    FAULT(64,0); BASE=RBASE
 2771                    DISP=0; INDEX=0; PTYPE=1;! UNPACK
 2772  !%if USE MC = 1 %start
 2773  !            *L_1,PTYPE; *CVD_1,0(11)
 2774  !            *UNPK_ROUT(5),5(3,11)
 2775  !            *NC_ROUT(5),MASK1
 2776  !%finish
 2777                 %FINISH
 2778              %FINISH
 2779              %RETURN
 2780           %FINISH
 2781           P=P+1;                        ! FIND OUT ABOUT SUBNAME
 2782           Q=DISPLACEMENT(FNAME);        ! TCELL POINTS TO CELL HOLDING
 2783          ! UNPACK;                       ! INFO ABOUT THE SUBNAME
 2784  !%if USE MC = 1 %start
 2785  !            *L_1,PTYPE; *CVD_1,0(11)
 2786  !            *UNPK_ROUT(5),5(3,11)
 2787  !            *NC_ROUT(5),MASK1
 2788  !%finish
 2789           %IF Q=-1=ACC %OR PTYPE=7 %START;! WRONG SUBNAME(HAS BEEN FAULTED)
 2790              P=P+1; SKIP APP; P=P-2
 2791              INDEX=0; BASE=0; DISP=0
 2792              %RETURN
 2793           %FINISH
 2794           ->Label20 %IF ARR=1
 2795           %IF MODE=1 %THEN CHANGE MODE
 2796           %IF TYPE<=2 %OR TYPE=5 %THEN %START
 2797              BASE=BS;  INDEX=IX;  DISP=DP+Q
 2798           ->Label99; %FINISH
 2799  !
 2800  ! NOW CODING BECOMES HAIRY:- STILL LEFT ARE
 2801  ! A) RECORDS IN RECORDS   Q POINTS TO SECONDARY RECORD
 2802  ! B) RECORDNAMES IN RECORDS   Q HAS OFF-SET OF A POINTER
 2803  ! C) RECORDARRAYNAMES IN RECORDS   Q HAS OFF-SET A HEADER IN RECORD
 2804  ! D) RECORDARRAYS IN RECORDS   NOT YET ALLOWED
 2805  !    Q WOULD HAVE OFF-SET OF A RECORD RELATIVE HEADER IN THE GLA
 2806  !
 2807           %IF A(P+1)=2 %THEN P=P+2 %ELSE NOAPP
 2808           CENAME(NAM,KFORM,BS,IX,DP+Q)
 2809           ->Label99
 2810  Label20:                                    ! ARRAYS AND ARRAYNAMES AS ELEMEN
 2811           FROM123(TCELL,Q,INTEGER(ADDR(SNDISP)),INTEGER(ADDR(K)))
 2812           C=ACC; D=SNDISP; Q=K; QQ=KFORM
 2813           %IF Z=12 %AND A(P+1)=2 %START;! 'GET ARRAYHEAD' CALL
 2814              %IF MODE=1 %THEN CHANGE MODE
 2815              %IF NAM=1 %THEN %START
 2816                 COMBINE(0)
 2817                 INDEX=0; BASE=BS; DISP=DP+Q
 2818                 %RETURN
 2819              %FINISH
 2820  !
 2821  ! PASSING AN ARRAY IN A RECORD BY NAME MUST CONSTRUCT PROPER ARRAYHEAD
 2822  ! FROM THE RECORD RELATIVE ONE AT Q(GLA)
 2823  !
 2824              COMBINE(1);                ! REDUCE TO A SINGLE POINTER
 2825              CREATE AH(1,BS,GLA,Q)
 2826              REGISTER(BS)=0 %IF REGISTER(BS)=2
 2827           %FINISH %ELSE %START;         ! ARRAY ELEMENTS IN RECORDS
 2828              %IF NAM=1 %THEN %START;    ! ARRAYNAMES-FULLHEAD IN RECORD
 2829                 %IF MODE=1 %THEN CHANGE MODE
 2830                 COMBINE(0);             ! IN CASE ARRAYNAME IN RECDARRAY
 2831                 CANAME(17,BS,DP+Q,0);   ! ARRAY MODE SETS DISP,INDEX&BASE
 2832                 REGISTER(BS)=0 %IF REGISTER(BS)=2
 2833                 BML=BS; DML=DP; NAM=0;  ! HEAD POSN STRINGS NEED
 2834                                         ! LMAX FROM DOPEVECTOR
 2835              %FINISH %ELSE %START;      ! ARRAY RELATIVE HEAD IN GLA
 2836                 COMBINE(0); J=1;        ! REDUCE TWO POINTERS TO ONE
 2837                 CANAME(3,GLA,Q,D);      ! VECTOR MODE D= BASIC DISP
 2838                                         ! SETS INDEX AND DISP ONLY
 2839                 %IF INDEX>0 %THEN REGISTER(INDEX)=REGISTER(INDEX)!1
 2840                 %IF MODE=1 %THEN CHANGE MODE
 2841                 %IF INDEX>0<=REGISTER(INDEX) %THEN REGISTER(INDEX)=0
 2842                 BASE=BS; DISP=DISP+DP
 2843                 BML=-1; DML=C&X'FFFF'-1;! FOR STRING ARRAYS
 2844                 ADJUST INDEX(REGISTER(INDEX)+1,INDEX,DISP) %IF DISP<0
 2845              %FINISH
 2846              %IF TYPE=3 %THEN CENAME(0,QQ,BASE,INDEX,DISP)
 2847           %FINISH
 2848           ->Label99
 2849           %ROUTINE CHANGE MODE
 2850  !***********************************************************************
 2851  !*       CHANGES MODE=1 RECORDS TO MODE=0 RECORDS BY PICKING UP THE    *
 2852  !*       POINTER TO SAFE REGISTER AND RESETTING BS,DP AND IX           *
 2853  !***********************************************************************
 2854           %INTEGER REG
 2855           REG=-1
 2856           %IF DEPTH=1 %THEN FIND USE(REG,1,7,CLINK)
 2857           %UNLESS REG>0 %AND REGISTER(REG)#1 %START
 2858              FIND REG(ADDREG,REG)
 2859              DUMP(X'58',REG,DP,IX,BS);     !  L   REG POINTER
 2860              %IF DEPTH=1 %AND CLINK>0 %THEN SET USE(REG,7,CLINK) %C
 2861+                                      %ELSE FORGET(REG)
 2862              %IF REGISTER(BS)=2 %THEN REGISTER(BS)=0
 2863           %FINISH
 2864           REGISTER(REG)=2 %IF REGISTER(REG)=0
 2865           GRAT(REG)=CA
 2866           BS=REG;IX=0; MODE=0; DP=0
 2867           %END;                         ! OF CHANGE MODE
 2868           %ROUTINE COMBINE(%INTEGER HOW)
 2869  !***********************************************************************
 2870  !*       COMBINES IX&BS INTO ONE SAFE REGISTER - IF HOW=1 THEN DP IS   *
 2871  !*       INCLUDED ALSO. IF HOW=0 THEN DP IS LEFT ALONE                 *
 2872  !***********************************************************************
 2873           %INTEGER REG
 2874           %IF IX=0 %AND (HOW=0 %OR DP=0) %THEN %RETURN
 2875           %IF 4<=BS<=14 %AND REGISTER(BS)>=0 %THEN REG=BS %ELSE %C
 2876+          FIND REG(ADDREG,REG)
 2877           DUMP(X'41',REG,DP*HOW,IX,BS)
 2878           %IF REGISTER(BS)=2 %THEN REGISTER(BS)=0
 2879           FORGET(REG); IX=0
 2880           BS=REG;  REGISTER(BS)=2
 2881           %IF HOW=1 %THEN DP=0
 2882           %END;                         ! OF ROUTINE COMBINE
 2883  Label99:      %END;                         ! OF ROUTINE CENAME
 2884  Label99:      REGISTER(BASE)=0 %IF REGISTER(BASE)=2
 2885           %END;
?ACCP unused
 2886                ;                         ! OF ROUTINE CRNAME
 2886           %INTEGERFN     DISPLACEMENT(%INTEGER LINK)
 2887           {%SHORTROUTINE}
 2888  !***********************************************************************
 2889  !*         SEARCH A FORMAT LIST FOR A SUBNAME                          *
 2890  !*      A(P) HAS ENAME--LINK IS HEAD OF RFORMAT LIST. RESULT IS DISP   *
 2891  !*      FROM START OF RECORD                                           *
 2892  !***********************************************************************
 2893           %INTEGER RR,II,ENAME,CELL
 2894           ENAME=A(P); CELL=0
 2895           %IF LINK#0 %THEN %START;    ! CHK RECORDSPEC NOT OMITTED
 2896              LINK=FROM3(LINK)&X'7FFF';   ! LINK TO SIDE CHAIN
 2897              CELL=LINK; II=-1; ACC=-1
 2898  !            %WHILE LINK>0 %CYCLE
 2899  !               FROM123(LINK,RR,INTEGER(ADDR(SNDISP)),INTEGER(ADDR(K)))
 2900  !               TCELL=LINK
 2901  !               MLINK(LINK)
 2902  !               %IF RR>>20=ENAME %THEN %START;      ! RIGHT SUBNAME LOCATED
 2903  !                  J=RR&15; PTYPE=RR>>4&X'FFFF'
 2904  !                  %RESULT=K
 2905  !               %FINISH
 2906  !            %REPEAT
 2907  !%if USE MC = 1 %start
 2908  !            *L_0,ENAME; *L_1,LINK; *L_2,ASLIST
 2909  !AGN:        *LTR_1,1; *BC_12,<END>
 2910  !            *L_3,0(1,2); *SRL_3,20; *CR_3,0
 2911  !            *BC_8,<HIT>; *LH_1,14(1,2); *BC_15,<AGN>
 2912  !HIT:        *ST_1,TCELL
 2913  !         *A_1,ASLIST; *LM_2,4,0(1)
 2914  !         *ST_2,RR; *ST_3,SNDISP; *ST_4,K
 2915  !%finish
 2916              J=RR&15; PTYPE=RR>>4&X'FFFF'
 2917              %RESULT=K
 2918  END:
 2919           %FINISH
 2920           FAULT(65,ENAME)
 2921           %IF CELL>0 %THEN %C
 2922+          PUSH(SHORT INTEGER(ADDR(ASLIST(CELL+14))),ENAME<<20!7<<4,0)
 2923           PTYPE=7; TCELL=0
 2924           %RESULT=-1
 2925           %END
?END unused
 2926           %INTEGERFN     COPY RECORD TAG(%INTEGERNAME SUBS)
 2927           {%SHORTROUTINE}
 2928  !***********************************************************************
 2929  !*       PRODUCE PTYPE ETC FOR A COMPOUND NAME BY CHAINING DOWN ONE    *
 2930  !*       ONE OR MORE RECORD FORMAT LISTS. ON EXIT RESULT =0 IF NO      *
 2931  !*       SUBNAME FOUND OR SUBNAME IS OF TYPE RECORD WITH NO FURTHER    *
 2932  !*       SUBNAME ATTACHED. RESULT#0 IF BONE-FIDE SUBNAME LOCATED       *
 2933  !*       ON ENTRY KFORM HAS POINTER TO THE (FIRST ) FORMAT LIST AND    *
 2934  !*       P POINTS TO THE A.R. ENTRY FOR (FIRST) ENAME                  *
 2935  !***********************************************************************
 2936           %INTEGER Q,FNAME
 2937           SUBS=0
 2938           %CYCLE
 2939              FNAME=KFORM
 2940              P=P+1; %IF A(P)=2 %THEN P=P+1 %ELSE SKIP APP
 2941              %RESULT=0 %IF A(P)=2 %OR FNAME<=0;! NO (FURTHER) ENAME
 2942              SUBS=SUBS+1
 2943              P=P+1; Q=DISPLACEMENT (FNAME)
 2944             ! UNPACK
 2945  !%if USE MC = 1 %start
 2946  !            *L_1,PTYPE; *CVD_1,0(11)
 2947  !            *UNPK_ROUT(5),5(3,11)
 2948  !            *NC_ROUT(5),MASK1
 2949  !%finish
 2950           %REPEAT %UNTIL TYPE#3
 2951           %RESULT=Q+1;       ! GIVES 0 IF SUBNAME NOT KNOWN
 2952           %END
 2953           %ROUTINE STRINGOP(%INTEGER Z,L,BTO,DTO,BFRM,DFRM,BML,DML,XREG)
 2954  !***********************************************************************
 2955  !*       PERFORM ANY STRING OPERATION WHICH INVOLVES EXECUTING SS      *
 2956  !*       INSTRUCTIONS                                                  *
 2957  !*       Z=0 FOR CLC                                                   *
 2958  !*       Z=1 FOR STORE(=)                                              *
 2959  !*       Z=2 FOR CONCATENATE                                           *
 2960  !*       Z=4 FOR STORE(<-)                                             *
 2961  !*       Z=5 FOR LEXIOGRAPHIC STRING ORDERING                          *
 2962  !*       STRINGL>0 %IF LENGTH OF STRING KNOWN =0 NOT KNOWN             *
 2963  !*       BML & DML DEFINE POSITION OF MAX LENGTH BYTE                  *
 2964  !*       BML=0  DML=MAX LENGTH IF THIS KNOWN AT COMPILE TIME           *
 2965  !***********************************************************************
 2966           {%SHORTROUTINE}
 2967           %INTEGER RSTATE1,RSTATE2,RSTATE3,W,FIXL,CCREG,SCA
 2968           %IF Z=4 %AND BML<=0 %AND DML=255 %THEN Z=1
 2969           RSTATE1=REGISTER(BTO); REGISTER(BTO)=1
 2970           RSTATE2=REGISTER(BFRM); REGISTER(BFRM)=1
 2971           %IF BML>0 %THEN RSTATE3=REGISTER(BML) %AND REGISTER(BML)=1
 2972           BML=0 %IF BML<0
 2973           PLABEL=PLABEL-1
 2974           %IF Z=5 %THEN %START;        ! LEXIOGRAPHIC ORDERING
 2975  !
 2976  ! THE CAREFULLY OPTIMISED BUT OBSCURE CODE PLANTED IS:-
 2977  !       SR XREG,XREG. IC XREG, D2(B2)
 2978  ! (OR   LA XREG,STRLENGTH2           WHEN 2ND OPERAND LENGTH KNOWN)
 2979  !       CLC D1(1,B1),D2(B2)          COMPARE THE LENGTHS
 2980  !       BALR CCREG,0                 SAVE CC FOR LATER & SET BASEREG
 2981  !       BNH L3                       SHORTEST LENGTH IN XREG
 2982  !LEX    CLC D1+1(1,B1),D2+1(B1)      FOR EXECUTING BUT QUICKER TO
 2983  !                                    OBEY THIS LINE THAN JUMP ROUND IT
 2984  !       IC XREG,D1(B1)               SHORTEST LENGTH TO XREG
 2985  !L3     LTR  XREG,XREG
 2986  !       BZ    L4
 2987  !       BCTR XREG,0                   XREG = LEASTCHARS-1
 2988  !       EX   XREG,LEX
 2989  !       BC   7,LEND
 2990  !L4     SPM CCREG                     RESTORE SAVED CONDITION COD
 2991  !LEND   EQU   *
 2992  !
 2993              %IF XREG<=0 %THEN CLAIM(GR1,XREG)
 2994              CLAIM(GR1,CCREG)
 2995              %IF L<=0 %THEN DUMP(4,XREG,DTO,0,BTO) %ELSE %C
 2996+                            DUMP(0,XREG,L,0,0)
 2997              SET USE(XREG,2,-2);       ! REMEMBER TO 24 BITS ZERO
 2998              DUMPSS(X'D5',1,BFRM,DFRM,BTO,DTO); ! CLC LENGTHS
 2999              PRR(5,CCREG,0)
 3000              %IF CA-CODEBASE>4095-MARGIN %THEN SETUSE(CCREG,12,CA) %C
 3001+                                         %ELSE FORGET(CCREG)
 3002              SCA=CA
 3003              PRX(X'47',11,CCREG,0,0)
 3004              DUMPSS(X'D5',1,BFRM,DFRM+1,BTO,DTO+1)
 3005              PRX(X'43',XREG,BFRM,0,DFRM)
 3006              PLUG(1,SCA+2,CA-SCA);       ! FILL JUMP
 3007              PRR(X'12',XREG,XREG)
 3008              PRX(X'47',8,CCREG,0,CA+14-SCA)
 3009              PRR(6,XREG,0)
 3010              PRX(X'44',XREG,CCREG,0,CA-18-SCA)
 3011              PRX(X'47',7,CCREG,0,CA-SCA+6)
 3012              PRR(4,CCREG,0);         ! SPM CCREG
 3013              REGISTER(CCREG)=0
 3014           %FINISH %ELSE %START
 3015              %IF Z=4 %THEN %START;         ! JAM TRANSFER NEEDS LMAX
 3016                 %IF BML=0 %THEN W=X'41' %ELSE W=X'43'
 3017                 DUMP(W,XREG,DML,0,BML);    ! IC %OR LA TO GET LMAX TO XREG
 3018                 XREG=NEST; REGISTER(XREG)=1;! CLAIM REGISTER FOR LMAX
 3019                 SET USE(XREG,2,-2)
 3020              %FINISH
 3021  !
 3022  ! FOR JAM TRANSFER OR ASSIGN WITH CHECKS A LENGTH COMPARISION IS NEEDED
 3023  ! THIS CAN BE AVOIDED IF RESULT IS KNOWN AT COMPILE TIME
 3024  !
 3025              %IF (Z=4 %OR Z=1=CHECKS)%AND(BML#0 %OR L<=0 %OR L>DML)%START
 3026                 %IF BML#0 %THEN %START;           ! MAX LENGTH NOT KNOWN
 3027                    DUMPSS(X'D5',1,BFRM,DFRM,BML,DML);! CLC (LENGTHS)
 3028                 %FINISH %ELSE PSI(X'95',DML,BFRM,DFRM)
 3029                 %IF Z=4 %THEN ENTER JUMP(10,PLABEL,B'11') %ELSE %C
 3030+                PRX(X'47',2,0,CODER,88);      ! BH CAP. EXCEEDED
 3031              %FINISH
 3032  !
 3033              %IF Z=0 %THEN W=X'D5' %ELSE W=X'D2'
 3034  !
 3035  ! LENGTHS UP TO 15 IT IS QUICKER TO MOVE XTRA CHARS.
 3036  !
 3037              %IF Z=1 %AND BML=0 %AND DML<=15 %AND L<=0 %THEN L=DML
 3038  !
 3039  ! IF THE LENGTH IS KNOWN AT COMPILE TIME THEN CODE CAN BE PLANTED TO
 3040  ! PERFORM THE OPERATION. IF LENGTH NOT KNOWN UNTIL RUN TIME THEN AN
 3041  ! INSTRUCTION WITH ZERO LENGTH HAS TO BE SET AND CODE PLANTED
 3042  ! TO EXECUTE THE INSTRUCTION AT RUN TIME. EXECUTE ORS THE LENGTH INTO
 3043  ! THE INSTRUCTION BEFORE OBEYING IT.
 3044  !
 3045              %IF L>0 %AND Z#4 %THEN FIXL=L+1 %ELSE %START;! EXECUTE NEEDED
 3046                 FIXL=0
 3047                 %UNLESS DFRM<0 %OR DFRM>4095 %OR Z=2 %THEN %START
 3048                    %IF XREG<0 %THEN FINDREG(GR1,XREG) %AND FORGET(XREG)
 3049                    PRX(X'43',XREG,0,BFRM,DFRM) %UNLESS GRUSE(XREG)=13
 3050                 %FINISH %ELSE %START
 3051                    DUMP(X'43',XREG,DFRM,0,BFRM) 
 3052                    XREG=NEST %IF XREG<0
 3053                    SET USE(XREG,2,-2)
 3054                 %FINISH
 3055                 REGISTER(XREG)=1
 3056                 ENTER LAB(PLABEL,B'11') %IF Z=4
 3057                 SET LOCAL BASE
 3058              %FINISH
 3059              %IF Z=2 %THEN DFRM=DFRM+1
 3060              DUMPSS(W,FIXL,BTO,DTO,BFRM,DFRM)
 3061              %IF FIXL=0 %THEN %START
 3062                 DUMP(X'44',XREG,CA-LOCALADDR-6,0,LOCALBASE);! EXECUTE IT
 3063                 DUMP(X'42',XREG,DTO,0,BTO) %IF Z=4;! STC LENGTH BYTE IF <-
 3064              %FINISH
 3065           %FINISH
 3066           %IF XREG>0 %THEN REGISTER(XREG)=0
 3067           NEST=XREG
 3068           %IF BML>0 %THEN REGISTER(BML)=RSTATE3
 3069           REGISTER(BFRM)=RSTATE2;         ! ORDER OF THESE 3 LINES
 3070           REGISTER(BTO)=RSTATE1;          ! IMPORTANT IF BTO=BFRM!
 3071           CCSTATE=-1
 3072           %END
 3073           %ROUTINE CSTREXP(%INTEGER MODE,REG)
 3074           {%SHORTROUTINE}
 3075  !***********************************************************************
 3076  !*       PLANT IN-LINE CODE FOR CONCATENATION. A WORK AREA UNDER       *
 3077  !*       BASE REGISTER COVER IS USUALLY REQUIRED. THE CURRENT LENGTH   *
 3078  !*       OF STRING IN THE WORK AREA IS KEPT IN A REGISTER (LENREG)     *
 3079  !*       WHICH IS PROTECTED THROUGH THE NORMAL INTERMEDIATE-RESULT     *
 3080  !*       MECHANISMS.                                                   *
 3081  !*       ON ENTRY:-                                                    *
 3082  !*       REG > 0 %IF A REGISTER IS TO BE LEFT POINTING AT THE RESULT   *
 3083  !*       MODE=0    NORMAL. REG IF GIVEN ONLY USED IF NO WK AREA NEEDED *
 3084  !*       MODE=1    AS MODE =0 BUT REG MUST BE SET AS POINTER           *
 3085  !*       (AND TO COME)                                                 *
 3086  !*       MODE=3    CONCATENATE INTO LHS OF =ASSNMNT (E.G. A=B.C)       *
 3087  !*       MODE=4    OPTIMISE  S=S.T   BY NOT COPYING S                  *
 3088  !*       2**4 BIT OF MODE IS SET IF WK-AREA NOT TO BE FREED ON EXIT    *
 3089  !*       ON EXIT:-                                                     *
 3090  !*       BASE,DISP & INDEX DEFINE RESULT                               *
 3091  !*       VALUE=1 %IF RESULT IN A WORK AREA(CCOND MUST KNOW)            *
 3092  !*       STRINGL SET IF STRING LENGTH KNOWN. NEST DEFINES LENREG       *
 3093  !***********************************************************************
 3094           %INTEGER PP,WKBASE,WKAREA,LENREG,REXP,ERR,CLEN,KEEPWA
 3095           %SHORTINTEGER SHEAD
 3096           %RECORD(RD)%NAME OP
 3097           %INTEGERFNSPEC STROP(%INTEGER REG)
 3098           LENREG=0; SHEAD=0
 3099           KEEPWA=MODE&16; MODE=MODE&15
 3100           PP=P; STRINGL=0
 3101           REXP=2-A(P+1+A(P+1));         ! =0 %IF ONE OPERAND EXP
 3102           -> NORMAL %UNLESS A(P+2)=4 %AND REXP=0 %AND MODE<=1
 3103           -> SIMPLE %IF A(P+3)=2
 3104           -> NORMAL %UNLESS A(P+3)=1
 3105           COPY TAG(A(P+4))
 3106           %IF PTYPE=SNPT %THEN PTYPE=TSNAME(K) %AND UNPACK
 3107           -> NORMAL %IF ROUT#0 ; ! BEWARE OF MAP=FN
 3108           -> NORMAL %IF CHECKS=1 %AND(ARR#0 %OR A(P+5)=1)
 3109  SIMPLE:  P=P+3
 3110           %IF MODE=0 %THEN REG=-2
 3111           ERR=STROP(REG)
 3112           -> ERROR %UNLESS ERR=0
 3113           VALUE=0
 3114           P=P+1; NEST=0; ->Label99
 3115  ERROR:   FAULT(ERR,0)
 3116           REGISTER(LENREG)=0
 3117           BASE=11; DISP=0
 3118           VALUE=0
 3119           P=PP; SKIP EXP
 3120           ->Label99
 3121  NORMAL:  PUSH(SHEAD,1<<16!9,-2)
 3122           OP==RECORD(ADDR(ASLIST(SHEAD)));!RESULT DESCRIPTOR FOR LENREG
 3123           CLEN=0; P=P+3;                ! LENGTH OF CONSTANT PART
 3124           WKBASE=RBASE
 3125           GET WSP(WKAREA,256);          ! GET NEXT OPERAND
 3126  NEXT:    STRINGL=0
 3127           ERR=STROP(-2);                ! GET NEXT OPERAND
 3128           -> ERROR %UNLESS ERR=0
 3129           REGISTER(BASE)=2 %IF REGISTER(BASE)=0
 3130           %IF LENREG>0 %THEN %START
 3131              %IF OP_D>0 %THEN %START;   ! LENREG STORED BY RT CALL
 3132                 DUMP(2,-2,OP_D,0,OP_XB);! SO RELOAD IT
 3133                 LENREG=NEST
 3134                 OP_XB=LENREG;OP_D=-2;   ! AND RESET DESCRIPTOR
 3135                 REGISTER(LENREG)=1
 3136                 SET USE(LENREG,1,ADDR(ASLIST(SHEAD)))
 3137              %FINISH
 3138              DUMP(0,-2,0,RBASE,LENREG); ! LA   O(RBASE,LENREG)
 3139              WKBASE=NEST; FORGET(WKBASE)
 3140           %FINISH
 3141           REGISTER(BASE)=0 %IF REGISTER(BASE)=2
 3142           STRINGOP(2,STRINGL,WKBASE,WKAREA+CLEN+1,BASE,DISP,-1,255,-2)
 3143  !
 3144  ! STRINGOP MOVES STRING INTO WORK AREA. IF LENGTH UNKNOWN THEN NEST
 3145  ! IS SET TO THE REGISTER CONTAINING THE LENGTH OF THE STRING
 3146  !
 3147           %IF LENREG>0 %THEN %START;    ! REGISTER SET UP
 3148              %IF STRINGL>0 %THEN %START;! DESCRIPTOR WAS A CONSTANT
 3149                 PRX(X'41',LENREG,LENREG,0,STRINGL);! LA LENREG,STRING(LENREG)
 3150              %FINISH %ELSE %START
 3151                 PRR(X'1A',LENREG,NEST); ! AR LENREG,NEST
 3152              %FINISH
 3153           %FINISH %ELSE %START;         ! NOW SET LENREG
 3154              %IF STRINGL=0 %THEN %START
 3155                 LENREG=NEST;            ! USE ONE SET BY STRINGOP
 3156                 REGISTER(LENREG)=1;     ! CLAIM IT
 3157                 SET USE(LENREG,1,ADDR(ASLIST(SHEAD)));! PROTECT IT
 3158                 OP_XB=LENREG;           ! AND UPDATE RESULT DESCRIPTOR
 3159                 PRX(X'41',LENREG,LENREG,0,CLEN) %UNLESS CLEN=0
 3160                 CLEN=0
 3161              %FINISH %ELSE CLEN=CLEN+STRINGL
 3162           %FINISH
 3163           %IF A(P)=2 %THEN -> TIDY;     ! NO MORE OPERATIONS
 3164           ERR=72; -> ERROR %UNLESS A(P+1)=12; ! CONCATENATE
 3165           P=P+2; -> NEXT
 3166  TIDY:                                  ! FINISH OFF
 3167           VALUE=WKAREA
 3168           %IF LENREG=0 %THEN %START
 3169              DUMPSI(X'92',CLEN,RBASE,WKAREA); ! MAX LENGTH KNOWN
 3170              STRINGL=CLEN; NEST=0
 3171           %FINISH %ELSE %START
 3172              DUMP(X'42',LENREG,WKAREA,0,RBASE); ! MAX LENGTH NOT KNOWN
 3173              PREC=1; TYPE=1;            ! FOR CHECK CAPACITY
 3174              %IF CHECKSP=1 %THEN CHECK CAPACITY(LENREG,WKAREA,0,RBASE)
 3175              REGISTER(LENREG)=0;        ! FREE THE REGISTER
 3176              STRINGL=0;                 ! LENGTH UNKNOWN
 3177           %FINISH
 3178           P=P+1;                        ! PAST REST OF EXPRN
 3179           RETURN WSP(WKAREA,256) %IF KEEPWA=0
 3180           %IF MODE=0 %THEN %START
 3181              BASE=RBASE; DISP=WKAREA
 3182           %FINISH %ELSE %START
 3183              DUMP(0,REG,WKAREA,0,RBASE)
 3184              BASE=REG; DISP=0
 3185           %FINISH
 3186           INDEX=0
 3187           CLEAR LIST(SHEAD)
 3188           CCSTATE=-1
 3189           NEST=LENREG; ->Label99
 3190           %INTEGERFN STROP(%INTEGER REG)
 3191  !***********************************************************************
 3192  !*       DEALS WITH OPERAND FOR CONCATENATION. RETURN RESULT=0 FOR     *
 3193  !*       VALID OPERAND OTHERWISE AN ERROR NUMBER.                      *
 3194  !***********************************************************************
 3195           %BYTEINTEGER CTYPE
 3196           %INTEGER VAL,MODE,REGMODE
 3197           %IF CHECKSP#0 %THEN REGMODE=SAFE %ELSE REGMODE=ADDREG
 3198           MODE=A(P);                    ! ALTERNATIVE OF OPERAND
 3199           %RESULT=75 %IF MODE>2
 3200           %IF MODE#1 %THEN %START
 3201              CTYPE=A(P+1)&7;           ! GET CONST TYPE & LOSE AMCK FLAGS
 3202              %IF CTYPE=5 %THEN %START
 3203                 STRINGL=A(P+2); P=P+2
 3204                 %IF REG<0 %THEN FINDREG(REGMODE,BASE) %ELSE BASE=REG
 3205                 TEXTOUT(BASE)
 3206                 %IF A(P)=1 %THEN %RESULT=72
 3207                 P=P+1; DISP=0
 3208              %FINISH %ELSE %START
 3209                 FROM AR4(P+2,VAL)
 3210                 %RESULT=72 %UNLESS CTYPE=1 %AND 0<=VAL<127 %AND A(P+4)=2
 3211                 P=P+5
 3212                 %IF VAL=0 %THEN %START
 3213                    BASE=CODER; DISP=X'C0'
 3214                 %FINISH %ELSE %START
 3215                    VAL=VAL+256; STRINGL=1
 3216                    STORE CONST(BASE,DISP,2,ADDR(VAL)+2)
 3217                 %FINISH
 3218              %FINISH
 3219              INDEX=0
 3220           %FINISH %ELSE %START
 3221              P=P+1; CNAME(5,REG)
 3222              STRINGL=0
 3223              %RESULT=71 %IF TYPE#5
 3224           %FINISH
 3225           %IF REG>0 %OR INDEX>0 %OR BASE>4095 %THEN %START
 3226              DUMP(0,REG,DISP,INDEX,BASE)
 3227              REG=NEST %IF REG<0
 3228              FORGET(REG)
 3229              BASE=REG; INDEX=0;DISP=0
 3230           %FINISH
 3231           %IF MODE=1 %AND UNASS=1 %THEN %START
 3232              DUMPSS(X'D5',2,BASE,DISP,CODER,216);! CLC =X'8080'
 3233              PCONST(X'4780C028');                ! BE UNASS USED
 3234           %FINISH
 3235           %RESULT=0
 3236           %END;                         ! OF INTEGERFN STROP
 3237  Label99:      %END;                         ! OF ROUTINE CSTREXP
 3238           %ROUTINE CRES (%INTEGER LAB)
 3239           {%SHORTROUTINE}
 3240  !**********************************************************************
 3241  !*       COMPILES A RESOLUTION E.G A->B.(C).D.(E).F AND JUMPS TO LAB   *
 3242  !*       ON FAILURE. (LAB=0 FOR UNCONDITIONAL RESOLUTION TO PERM ON    *
 3243  !*       FAILURE ).                                                    *
 3244  !*       THE  METHOD IS TO SET UP A 4 WORD WORK AREA AS FOLLOWS:-      *
 3245  !*       W1  POINTS TO LHS(A)                                          *
 3246  !*       W2  HAS COUNT OF BYTES OF A USED IN PREVIOUS RESOLUTIONS      *
 3247  !*       W3  PRIVATE SPACE FOR PERM                                    *
 3248  !*       W4    STRING TO CONTAIN FRAGMENT (PASSED BY NAME)             *
 3249  !*       PERM IS ENTERED WITH R1 POINTING TO C AND R2 TO W1 AND THE    *
 3250  !*       SUBROUTINE TRIES TO PERFORM THE RESOLUYION AND SETS THE       *
 3251  !*       CONDITION CODE =8 IF IT SUCCEEDS.                             *
 3252  !*                                                                     *
 3253  !*       ON ENTRY LHS IS DEFINED BY DISP,INDEX AND BASE.               *
 3254  !*       P POINTS TO P(+') OF RHS DEFINED AS (+')(OPERAND)(RESTOFEXP)  *
 3255  !*                                                                     *
 3256  !$       THE ROUTINE IS COMPACT BUT DIFFICULT TO FOLLOW (OR ALTER)     *
 3257  !*       THE TIME IN PERM IS LARGE SO IT IS NOT WORTHWHILE TO PERSUE   *
 3258  !*       CODE EFFICIENCY TOO INDUSTRIOUSLY .                           *
 3259  !**********************************************************************
 3260           %INTEGER P1,P2,R1,R2,SEXPRN,W,LAST
 3261           LAST=0;                       ! =1 WHEN END OF EXPRNSN FOUND
 3262           SEXPRN=0;                     ! RESOLUTION(BRKTD) EXPRESSNS
 3263           GET WSP(W,4);                 ! 4 WORD WORK AREA FOR W1-W4
 3264           P1=P; P=P+2
 3265           ->Label1 %IF A(P)=4 %AND TYPE=5;   ! LHS MUST BE A STRING
 3266  ERROR:   P=P1; SKIP EXP
 3267           FAULT(74,0); ->Label99
 3268  Label1:       FIND SEQ(R1,R2);              ! 2 ADJACENT REGISTERS
 3269           DUMP(0,R1,DISP,INDEX,BASE);   ! ADDR LHS
 3270           REGISTER(R1)=1
 3271           PRR(X'1B',R2,R2);             ! ZERO R2
 3272           REGISTER(R2)=1
 3273           DUMPM(X'90',R1,R2,RBASE,W);   ! SET W1 & W2
 3274           FREE AND FORGET(R1)
 3275           FREE AND FORGET(R2)
 3276  RES:     P=P+1;                        ! TO P(OPERAND)
 3277           P2=-1;                        ! B OMITTED (>0 IF B GIVEN)
 3278  !
 3279  ! THE CODING HERAFTER IS OBSCURE. NOTE HOWEVER:-
 3280  !        1)  IF B OMITTED THEN 0(WSPR) IS PASSED AS ADDR(B)
 3281  !        2)  THE LAST STRING F IS TREATED AS B OR D BUT PERM29 IS
 3282  !              USED INSTEAD OF PERM 28
 3283  !
 3284           %IF A(P)=3 %THEN NEST=WSPR %ELSE %START;! B OMITTED
 3285              ->ERROR %UNLESS A(P)=1;       ! P(OPERAND)=NAME
 3286              P=P+1; P2=P
 3287  !
 3288  !        NORMALLY CNAME(3,REG) USED TO PASS B BY NAME TO PERM
 3289  !        IN OPTIMISING DONT WASTE TIME SETTING FLAGS BYTE INTO ADDRESS
 3290  !        SO USE CNAME(4,REG). PERM SKIPS CHECK IF FLAGS MISSING
 3291  !
 3292              CNAME(4-CHECKSP,-2)
 3293              ->ERROR %UNLESS TYPE=5
 3294              %IF A(P)=2 %AND SEXPRN>0 %THEN LAST=1 %ELSE %START
 3295                 ->ERROR %UNLESS A(P+1)=12;! DOT OPERATOR
 3296                 P=P+2
 3297              %FINISH
 3298           %FINISH
 3299           REGISTER(NEST)=1 %IF REGISTER(NEST)=0;! IN CASE 4K MULTIPLE REQD
 3300           DUMP(X'50',NEST,W+12,0,RBASE);! B (OR DUMMY) TO W4
 3301           REGISTER(NEST)=0 %IF REGISTER(NEST)>0; ! NB NEST CAN BE R11 HERE!
 3302           %IF LAST=0 %THEN %START
 3303              ->ERROR %UNLESS A(P)=3;    ! P(OPERAND)='('(EXPR)')'
 3304              SEXPRN=SEXPRN+1; P=P+1
 3305              CSTREXP(1,1);              ! TO REGISTER 1
 3306           %FINISH
 3307  !
 3308           REGISTER(1)=1
 3309           DUMP(0,2,W,0,RBASE) %UNLESS GRUSE(2)=16 %AND GRINF(2)=W
 3310           REGISTER(1)=0
 3311           PPJ(LAST+28);                 ! 28 TO RESOLVE 29 TO FINISH OFF
 3312           SET USE(2,16,W);              ! USE 16='HOLDS RESLN PARAM'
 3313           -> END %IF LAST#0
 3314  FTEST:                                 ! DEAL WITH CC#8 IE RESLN FAILED
 3315           %IF LAB#0 %THEN ENTER JUMP(7,LAB,B'11') %ELSE %START
 3316              PCONST(X'4770C098')
 3317              CYC BITS=CYC BITS!4;       ! JUMP TO PERM BIT
 3318           %FINISH
 3319  !
 3320           %IF P2<0 %THEN %START;        ! B WAS OMIITED SO CHECK THAT
 3321           PSI(X'95',0,WSPR,0);          ! B WOULD HAVE BEEN NULL
 3322           P2=1; ->FTEST; %FINISH
 3323  !
 3324           -> END %IF A(P)=2
 3325           ->ERROR %UNLESS A(P+1)=12
 3326           P=P+1; ->RES
 3327  END:
 3328           P=P+1
 3329  Label99:      %END
 3330           %ROUTINE CUCI
 3331           {%SHORTROUTINE}
 3332  !***********************************************************************
 3333  !*       COMPILE USERCODE INSTRUCTION. MOST WORK IS DONE BY HAIRY      *
 3334  !*       BUILT-IN PHRASE IN COMPARE. SINCE ALMOST ANYTHING IS LEGAL    *
 3335  !*       IN USERCODE THIS ROUTINE HAS ONLT TO ASSEMBLE AND PLANT THE   *
 3336  !*       THE INSTRUCTION.                                              *
 3337  !***********************************************************************
 3338           %ROUTINESPEC DXB
 3339           %ROUTINESPEC DLB
 3340           %ROUTINESPEC DB
 3341           %ROUTINESPEC CUCS
 3342           %OWNINTEGER USING,AT
 3343           %INTEGER Z,KK,X,OPCODE,REG,OPNUM
 3344           %SWITCH UCITYPE(1:6),OPTYPE(1:8)
 3345           CCSTATE=-1
 3346           FORGETM(8);                  ! ALL UC INSTRNS DANGEROUS
 3347           -> UCITYPE(A(P))
 3348  UCITYPE(1):                           ! **(N),(@')(NAME)(APP)
 3349           NEST=A(P+1); Z=A(P+2); P=P+3
 3350           Z=4 %IF Z=1; CNAME(Z,NEST)
 3351           ->Label99
 3352  UCITYPE(2):                           ! *-> P<N> =JUMP TO PERM
 3353           PPJ(A(P+1)); ->Label99
 3354  UCITYPE(4):                           ! *PUT_<CONST>
 3355           PLANT(A(P+3));               ! LEAST SIGNIFICANT 16 BITS ONLY
 3356           P=P+4; ->Label99
 3357  UCITYPE(3):                           ! '*'<SETUCN>'_' <UCOP>
 3358           OPCODE=A(P+2); OPNUM=A(P+1)
 3359           P=P+3; ->OPTYPE(OPNUM)
 3360  UCITYPE(5):                           ! 'USING' '*,'<N>
 3361           Z=A(P+1)
 3362           %IF 1<=Z<=15 %THEN %START
 3363              USING=Z; AT=CA
 3364           %FINISH %ELSE FAULT(33,0); ->Label99
 3365  UCITYPE(6):                           ! 'DROP' <N>
 3366           Z=A(P+1)
 3367           %IF Z=USING %THEN %START
 3368              USING=0; AT=0
 3369           %FINISH %ELSE FAULT(33,0); ->Label99
 3370  OPTYPE(1):                            ! RR FORMAT INSTRUCTION
 3371           %IF OPCODE=0 %THEN CNOP(A(P),A(P+1)) %ELSE %C
 3372+                             PRR(OPCODE,A(P),A(P+1))
 3373           P=P+2; ->Label99
 3374  OPTYPE(2):                            ! RX FORMAT INSTRUCTION
 3375  OPTYPE(3):                            ! RS FORMAT INSTRUCION
 3376  OPTYPE(5):                            ! SHIFT INSTRUCTION
 3377           REG=A(P)
 3378           %IF OPNUM=2 %THEN P=P+1 %AND DXB %ELSE %START
 3379              %IF OPNUM=5 %THEN X=0 %AND P=P+1 %ELSE X=A(P+1) %AND P=P+2
 3380              DB
 3381           %FINISH
 3382           PRX(OPCODE,REG,X,I,K);->Label99
 3383  OPTYPE(4):                            ! STORE-IMMEDIATE FORMAT
 3384           DB
 3385           %IF A(P)=2 %THEN Z=0 %ELSE %START
 3386              FROM AR4(P+2,Z)
 3387              FAULT(32,0) %UNLESS 0<=Z<=255
 3388              P=P+4
 3389           %FINISH
 3390           PSI(OPCODE,Z,I,K);P=P+1; ->Label99
 3391  OPTYPE(6):                            ! SS FORMAT
 3392  OPTYPE(7):                            ! PACKED DECIMAL FORMAT
 3393           DLB; KK=K; Z=X
 3394           REG=I; Z=1 %IF Z=0
 3395           %IF OPNUM=6 %THEN DB %ELSE %START
 3396              DLB; X=1 %IF X=0
 3397              Z=(Z-1)<<4!X
 3398           %FINISH
 3399           PSS(OPCODE,Z,REG,KK,I,K); ->Label99
 3400  OPTYPE(8):                            ! FUNNIES
 3401           REG=A(P); P=P+1
 3402           %IF OPCODE=X'80' %THEN PSI(OPCODE,REG,0,0) %ELSE %START
 3403             %IF OPCODE=10 %THEN PLANT(X'A00'!REG) %ELSE PRR(OPCODE,REG,0)
 3404           %FINISH
 3405           ->Label99
 3406           %ROUTINE DB
 3407  !***********************************************************************
 3408  !*       DEAL WITH OPERANDS FOR A DB INSTRUCTION. P ON ALT OF P<DB>    *
 3409  !*       P<DB>=<UCS>,<N><RESTOFDB>                                     *
 3410  !*       P<RESTOFDB>='('<N>')',%NULL                                   *
 3411  !***********************************************************************
 3412           %IF A(P)=1 %THEN CUCS %ELSE %START
 3413              K=A(P+1); I=A(P+2); P=P+3; ! I IS ALT OF P<RESTOFDB>
 3414              %IF I=2 %THEN I=0 %ELSE I=A(P) %AND P=P+1
 3415           %FINISH
 3416           FAULT(99,0) %UNLESS 0<=K<=4095
 3417           %END
 3418           %ROUTINE DXB
 3419  !***********************************************************************
 3420  !*       DEAL WITH OPERANDS FOR A DXB INSTRN. P ON ALT OF P<DXB>       *
 3421  !*       P<DXB>=<UCS><RESTOFDB>,<N><RESTOFDXB>                         *
 3422  !*       P<RESTOFDXB>='('<N>','<N>')','('<N>')',%NULL                  *
 3423  !***********************************************************************
 3424           %INTEGER ALT
 3425           X=0
 3426           %IF A(P)=1 %THEN %START
 3427              CUCS
 3428              %IF A(P)=1 %THEN X=A(P+1) %AND P=P+1
 3429           %FINISH %ELSE %START
 3430              K=A(P+1); I=0
 3431              ALT=A(P+2); P=P+2
 3432              %IF ALT=1 %THEN X=A(P+1) %AND P=P+1
 3433              %IF ALT<=2 %THEN I=A(P+1) %AND P=P+1
 3434           %FINISH
 3435           P=P+1
 3436           FAULT(99,0) %UNLESS 0<=K<=4095
 3437           %END
 3438           %ROUTINE DLB
 3439  !***********************************************************************
 3440  !*       DEAL WITH OPERAND FOR A DB INSTRUCTION. P ON ALT OF P<DB>     *
 3441  !*       P<DB>=<N>'('<N>','<N>')',<UCS>'('<N>')'                       *
 3442  !***********************************************************************
 3443           %IF A(P)=1 %THEN %START;   ! EXPLICT FORM
 3444              K=A(P+1); X=A(P+2)
 3445              I=A(P+3); P=P+4
 3446           %FINISH %ELSE %START
 3447              CUCS; X=A(P); P=P+1
 3448           %FINISH
 3449           FAULT(99,0) %UNLESS 0<=K<=4095
 3450           %END
 3451           %ROUTINE     CUCS
 3452  !***********************************************************************
 3453  !*       DEAL WITH SYMBOLIC REFERENCES IN USERCODE STATEMENTS          *
 3454  !*       P<UCS>=<NAME><DISPP>,'<'<LABEL>'>','*'<DISPP>                 *
 3455  !*       P<DISPP>='+'<N>,'-'<N>,%NULL                                  *
 3456  !***********************************************************************
 3457           %INTEGER X,Y,AD,ALT
 3458           X=USING; Y=AT
 3459           %IF X=0 %THEN X=10 %AND Y=CODEBASE
 3460           ALT=A(P+1);                     ! ALT OF P<UCS>
 3461           %IF ALT=2 %THEN %START
 3462  !
 3463  ! OPERAND IS AN IMP LABEL WHICH MAY OR MAY NOT BE SET BUT MUST BE WITHIN
 3464  ! 4095 OF THE BASE REGISTER WHETHER IMPLIED OR SET BY 'USING'
 3465  !
 3466              K=A(P+3)+(A(P+2)-1)<<14
 3467              P=P+4
 3468              J=FIND3(K,LABEL(LEVEL))
 3469              %IF J<0 %THEN PUSH123(LABEL(LEVEL),0,0,K) %AND %C
 3470+                           J=LABEL(LEVEL)
 3471              AD=FROM1(J)
 3472              REPLACE1(J,AD!X'01000000')
 3473              %IF AD&X'FFFFFF'#0 %THEN K<-AD-Y %AND I=X %ELSE %START
 3474                 K=0; I=0
 3475                 PUSH(SHORT INTEGER(ADDR(ASLIST(J+6))),CA,X<<24!Y)
 3476              %FINISH
 3477           %FINISH %ELSE %START
 3478              %IF ALT=1 %THEN %START
 3479                 FNAME=A(P+2)
 3480                 COPY TAG(FNAME)
 3481                 P=P+3
 3482                 FAULT(33,FNAME) %IF ROUT=1 %OR TYPE=4 %OR TYPE>=6
 3483              %FINISH %ELSE %START
 3484                 I=X; K=CA-Y
 3485                 P=P+2
 3486              %FINISH
 3487              ALT=A(P); P=P+1
 3488              %IF ALT#3 %THEN %START
 3489                 %IF ALT=1 %THEN K=K+A(P) %ELSE K=K-A(P)
 3490                 P=P+1
 3491              %FINISH
 3492           %FINISH
 3493           %END
 3494  Label99:      %END
 3495           %ROUTINE LAB LOOK(%INTEGERNAME FLAG,%INTEGER LAB)
 3496  ! THIS ROUTINE LOOKS THRO THE STATEMENTS HELD IN THE CYCLIC BUFFER
 3497  ! TO TRY TO FIND LABEL 'LAB'.
 3498  
 3499           {%SHORTROUTINE}
 3500           %INTEGER I,J,K,F,MUI,ME
 3501           FLAG=0
 3502           %RETURN %UNLESS STMTSHELD>1
 3503           %IF |LAB-SFLABEL|<=1 %THEN F=1 %ELSE F=0
 3504           %CYCLE I=2,1,STMTSHELD;       ! CYCLE THROUGH STATEMENTS
 3505           J=STPTRS(I)
 3506           %IF F>0 %THEN %START
 3507           -> FIN %IF A(J)=14
 3508           -> AGN %UNLESS A(J)=5
 3509           MUI=J+2+A(J+2); ME=MUI+1+A(MUI+1)
 3510           F=F+1 %IF A(MUI)<=2 %OR A(ME)=1
 3511           -> AGN
 3512  FIN:     %IF F=1 %THEN %START
 3513           FLAG=1; %RETURN; %FINISH
 3514           F=F-1
 3515           F=F+1 %IF A(J+1)=1
 3516           -> AGN; %FINISH
 3517           -> numeric LAB %IF A(J)=4;            ! NUMERIC LAB
 3518           -> AGN %UNLESS A(J)=1 %AND A(J+2)=1 %AND A(J+5)=2
 3519           K=J+1+A(J+1); -> AGN %UNLESS A(K)=1
 3520           K=16384+A(J+4)
 3521  SUCC:    -> AGN %UNLESS K=LAB
 3522           FLAG=1; %RETURN
 3523  numeric LAB:     K=A(J+1); -> SUCC
 3524  AGN:     %REPEAT
 3525           %END
 3526  {%RECORDFORMAT F(%INTEGER VAL,S1,S2,S3)}
 3527  !         %RECORDFORMAT OPTFORM(%BYTEINTEGER COUNT,TYPE,%INTEGER BITS,%C
 3528  !                  PTYPE,XTRA)
 3529  !         %RECORD(OPTFORM)%ARRAY OPTINF(0:25)
 3530  !!%ROUTINE QSORT(%RECORD(F)%ARRAYNAME A,%INTEGER I,J)
 3531  %ROUTINE QSORT(%RECORD(OPTFORM)%ARRAYNAME A,%INTEGER I,J)
 3532  {This is totally incompatible with where it was called. Wrong record format entirely.}
 3533  {%RECORDSPEC A(F)}
 3534  !!%RECORD (F)D
 3535  %RECORD (OPTFORM)D
 3536  %INTEGER L,U
 3537           %IF I>=J %THEN %RETURN
 3538           L=I; U=J; D=A(J); ->FIND
 3539  UP:
 3540           L=L+1
 3541           %IF L=U %THEN ->FOUND
 3542  FIND:
 3543           {%UNLESS A(L)_VAL>D_VAL %THEN ->UP}
 3544           %UNLESS A(L)_count>D_count %THEN ->UP
 3545           A(U)=A(L)
 3546  DOWN:
 3547           U=U-1
 3548           %IF L=U %THEN ->FOUND
 3549           {%UNLESS A(U)_VAL<D_VAL %THEN ->DOWN}
 3550           %UNLESS A(U)_count<D_count %THEN ->DOWN
 3551           A(L)=A(U); ->UP
 3552  FOUND:
 3553           A(U)=D
 3554           QSORT(A,I,L-1)
 3555           QSORT(A,U+1,J)
 3556  %END
 3557  %ROUTINE OPTSAVE(%INTEGER TYPE,Z,PTYPE,XTRA)
 3558  %RECORD(OPTFORM)%NAME OPTE
 3559  %INTEGER I
 3560           %IF OPTPTR>=24 %THEN %RETURN
 3561           I=1
 3562           %WHILE I<=OPTPTR %CYCLE
 3563              OPTE==OPTINF(I)
 3564              %IF TYPE=OPTE_TYPE %AND XTRA=OPTE_XTRA %START
 3565                 OPTE_COUNT=OPTE_COUNT+1
 3566                 OPTE_BITS=OPTE_BITS!1<<Z
 3567                 %RETURN
 3568              %FINISH
 3569              I=I+1
 3570           %REPEAT
 3571           OPTPTR=OPTPTR+1
 3572           OPTE==OPTINF(OPTPTR)
 3573           OPTE_COUNT=1
 3574           OPTE_TYPE=TYPE
 3575           OPTE_BITS=1<<Z
 3576           OPTE_PTYPE=PTYPE
 3577           OPTE_XTRA=XTRA
 3578  %END
 3579           %ROUTINE VALLOC(%INTEGER REG,TN)
 3580           {%SHORTROUTINE}
 3581  !***********************************************************************
 3582  !*       ALLOCATE A VARIABLE (TAGS=TN) TO REGISTER REG BY LOADING      *
 3583  !*       THE REGISTER AND FRIGGING THE TAGS. ONLY SIMPLE INTEGERS      *
 3584  !*       (PTYPE=1) CAN BE ALLOCATED TO REGISTERS.                      *
 3585  !*       BYTES AND SHORTS ARE TRUNCATED BY <- ASSIGNMENTS.             *
 3586  !*       NAME-TYPES MAY HAVE AN ALTER EGO                              *
 3587  !*       THE ALLOCATION CAN ONLY BE MADE FOR SECTIONS OF CODE THAT     *
 3588  !*       HAVE NO RT-CALLS OR LABELS/JUMPS                              *
 3589  !********-**************************************************************
 3590           %INTEGER S1,S2,S3,I,Q
 3591           FROM123(TN,S1,S2,S3)
 3592           %IF CUR CYC VAR>=0 %AND TN=TAGS(CUR CYC VAR) %START
 3593              P=STPTRS(1)+5;              ! CHECK INITIAL EXPRSN
 3594              Q=TSEXP(I,0)
 3595           %FINISH %ELSE Q=0
 3596           %IF Q=0 %OR Q>=100 %OR (Q=10 %AND I=CUR CYC VAR)%START
 3597              FIND USE(I,1,3,TN)
 3598              %IF I>=0 %THEN %START
 3599                 PRR(X'18',REG,I) %UNLESS REG=I
 3600              %FINISH %ELSE DUMP(X'58',REG,S3>>16,0,S1>>4&15)
 3601           %FINISH
 3602           SET USE(REG,3,TN)
 3603           REGISTER(REG)=-1;             ! LOCK THE REG
 3604           S1=S1+7<<16;                  ! PTYPE FROM1 TO 8
 3605           S2=S2&X'FFFF'!S3&X'FFFF0000' ; ! K TO SNDISP
 3606           REPLACE123(TN,S1,S2,REG<<16)
 3607           %END
 3608           %ROUTINE VDALLOC(%INTEGER REG,REGP)
 3609           {%SHORTROUTINE}
 3610  !***********************************************************************
 3611  !*       DE-ALLOCATE REG WHICH WAS ALLOCATED BY VALLOC(Q.V.). STORE REG*
 3612  !*       INTO CORE AND RESTORE CORE COPY FROM REGP. REGP<=0 NO RESTORE *
 3613  !*       OFTEN REG=REGP                                                *
 3614  !***********************************************************************
 3615           %INTEGER TN,S1,S2,S3
 3616           TN=GRINF(REG)
 3617           FROM123(TN,S1,S2,S3)
 3618           S3=S2>>16<<16
 3619           S1=S1-7<<16;                  ! BACK TO INTEGER
 3620           %IF REGP#0 %THEN DUMP(X'50',REGP,S3>>16,0,S1>>4&15)
 3621           REGISTER(REG)=0
 3622           REPLACE123(TN,S1,S2,S3)
 3623           %END
 3624           %ROUTINE LOADUP(%INTEGER REGINFO)
 3625           {%SHORTROUTINE}
 3626  !***********************************************************************
 3627  !*       REGINFO IS BIT MASK OF AVAILABLE REGS                         *
 3628  !*       CYC BITS HAS INFORMATION ON OPERATIONS IN THE CYCLE           *
 3629  !*       THIS ROUTINE PRELOADS ANY FREE REGISTERS FROM THE INFORMATION *
 3630  !*       IN THE LIST HEADED BY 'SFHEAD' WHICH WAS ORDERED BY ROUTINE   *
 3631  !*       'ORDER' SO THAT THE TOP HAS THE MOST USED ITEMS               *
 3632  !***********************************************************************
 3633           {%SHORTROUTINE}
 3634           %RECORD(OPTFORM)%NAME OPTE
 3635           %INTEGER I,USE,NEXTREG,INF,X,Y,Z,PTR
 3636           PTR=OPTPTR+1
 3637  AGN:     PTR=PTR-1
 3638           ->Label99 %IF PTR=0
 3639           OPTE==OPTINF(PTR)
 3640           %IF REGINFO=0 %THEN ->Label99
 3641           %CYCLE I=4,1,15
 3642           ->Label1 %IF REGINFO&(1<<I)#0
 3643           %REPEAT
 3644           %MONITOR ; %STOP
 3645  Label1:       REGINFO=REGINFO!!(1<<I)
 3646  Label2:       NEXTREG=I
 3647  Label3:       %IF OPTE_TYPE=12 %THEN ->CODEB
 3648           %IF OPTE_TYPE=0 %THEN ->CONST
 3649           %IF OPTE_TYPE=2 %THEN %START
 3650              INF=TAGS(OPTE_XTRA)
 3651              PTYPE=OPTE_PTYPE; UNPACK
 3652              %IF PTYPE=1 %AND CYCBITS&X'40F'=0 %AND OPTE_BITS&3<<3=0 %C
 3653+                %AND(CYC BITS&X'20'=0 %OR OPTE_XTRA#CUR CYC VAR) %THEN %C
 3654+                VALLOC(NEXTREG,INF) %AND USE=3 %AND ->RSET
 3655  !
 3656              %IF TYPE=3 %AND NAM=1 %AND ARR=0 %AND OPTE_BITS&5<<14=0 %C
 3657+                %AND(CYCBITS&8=0 %OR ((-1<<20)<<FROM1(INF)>>8&15) %C
 3658+                &CYCBITS=0) %THEN ->LOAD RBASE
 3659  !
 3660              %IF ARR=1 %AND(NAM=0 %OR (CYCBITS&8=0 %AND OPTE_BITS %C
 3661+                &(1<<12)=0)) %THEN -> LOAD ABASE
 3662           %FINISH
 3663           PTR=PTR-1
 3664           ->Label99 %IF PTR<=0
 3665           OPTE==OPTINF(PTR); ->Label3
 3666  LOADRBASE:USE=7
 3667  LOADANY: X=FROM1(INF)>>4&15
 3668           Z=FROM3(INF)>>16
 3669           I=X'58'
 3670           ->COM
 3671  LOADABASE:USE=8; ->LOADANY
 3672  CODEB:                          ! BASE REGISTER FOR REPEATING NEEDED
 3673           PRR(5,NEXTREG,0);                 ! BALR NEXTREG,0
 3674           CYC BASE=NEXT REG; CYC ADDR=CA
 3675           USE=12
 3676           INF=CYC ADDR; ->SETU
 3677  COM:     DUMP(I,NEXTREG,Z,0,X)
 3678  SETU:    SET USE(NEXTREG,USE,INF)
 3679           REGISTER(NEXTREG)=-1
 3680  RSET:    CYC REGS=CYC REGS!1<<NEXTREG
 3681  !         %IF DCOMP=1 %THEN %START
 3682  !            printstring("
 3683  !LOADS REGISTER")
 3684  !            WRITE(NEXTREG,3)
 3685  !            WRITE(USE,3)
 3686  !            WRITE(INF,5)
 3687  !        %FINISH
 3688           -> AGN
 3689  CONST:   I=0; Z=OPTE_XTRA
 3690           INF=Z
 3691           USE=2; X=0; -> COM
 3692  Label99:       %END
?LABEL2 unused
?Y unused
 3693           %ROUTINE CYCOPT(%INTEGERNAME FLAG,%INTEGER WU)
 3694           {%SHORTROUTINE}
 3695  ! EXAMINE THE STATEMENTS IN THE CYCLIC BUFFER FOR A '%REPEAT' AND
 3696  ! COMPUTE IF REGISTERS CAN BE ALLOCATED FOR INCREMENT AND FINAL VALUE.
 3697  ! WU=0 FOR OLD TYPE CYCLE =1 FOR WHILE OR UNTIL =2 FOR OPEN CYCLE
 3698           %INTEGER I,J,K,CREGS,SCCSTATE
 3699           FLAG=0; CREGS=0; CYC ASS=0; CYC REGS=0; CYC BASE=0
 3700           %RETURN %UNLESS STMTSHELD>1;   ! NO STATEMENTS IN BUFFER
 3701           %RETURN %IF WU=0 %AND FFLAG#0;! FNS IN P,Q,R
 3702           %CYCLE I=2,1,STMTSHELD
 3703           J=STPTRS(I)
 3704           ->NESTED %IF A(J)=2;    ! CONTAINS NESTED CYCLE DONT OPTIMISE
 3705           ->NESTED %IF A(J)=6 %AND A(J+2+A(J+2))<=2;! WU CYCLE
 3706           -> CR %IF A(J)=3;       ! CORRESPONDING REPEAT FOUND!
 3707           %REPEAT
 3708  NESTED:  %RETURN
 3709  CR:      K=16; ->REGS %IF WU#0
 3710           K=6; ->REGS %IF REGISTER(6)=0 %AND REGISTER(7)=0
 3711           K=4; ->REGS %IF REGISTER(4)=REGISTER(5)=0
 3712           FLAG=-1;     ! WORTH TRYING TO USE GRS2&3
 3713           %RETURN
 3714  REGS:    FLAG=K
 3715  !         %IF DCOMP=1 %THEN %START
 3716  !            printstring("
 3717  !CYCLE OPTIMISABLE")
 3718  !            WRITE(FLAG,2)
 3719  !         %FINISH
 3720           EXTRA PASS(2-WU&1,I-1,FLAG)
 3721           %END
?SCCSTATE unused
 3722           %ROUTINE EXTRA PASS(%INTEGER FST,LST,FLAG)
 3723           {%SHORTROUTINE}
 3724           %INTEGER SAVECA,USE,INF,BITS,J,CREGS,SCCSTATE
 3725           %SHORTINTEGER HEAD
 3726           CREGS=0
 3727           %CYCLE J=4,1,14
 3728              %IF REGISTER(J)=0 %THEN %START
 3729                 CREGS=CREGS!1<<J %UNLESS FLAG<=J<=FLAG+1
 3730              %FINISH
 3731           %REPEAT
 3732           %RETURN %UNLESS LST>=FST
 3733           CODE OUT;                  ! EMPTY CODE BUFFER
 3734           SAVECA=CA;                 ! AND PRESERVE CURRENT ADDRESS
 3735           INF=0; OPTPTR=0
 3736           SCCSTATE=CCSTATE
 3737           HEAD=0; GET ENV(HEAD);     ! AND THE REGISTER CONTENTS
 3738           FORGETM(14)
 3739           %IF 4<=FLAG<=14 %THEN OPTSAVE(2,2,1,CURCYCVAR)
 3740  ! CYCLE BITS SIGNIFY AS FOLLOWS:-
 3741  ! 2**0 = STATEMENT CONTAINS USER LABEL
 3742  ! 2**1 = STATEMENT CONTAINS JUMP INSTRUCTION
 3743  ! 2**2 = STATEMENT CONTAINS PERM SUBROUTINE CALL
 3744  ! 2**3 = STATEMENT CONTAINS NORMAL ROUTINE/FN CALL
 3745  ! 2**4 = STATEMENT USES PERMS CONSTANT LIST
 3746  ! 2**5 = STATEMENT CONTAINS ASSIGNMENT TO CONTROL VARIABLE
 3747  ! 2**6 = STATEMENT REQUIRES EVEN/ODD PAIR
 3748  ! 2**7 = STATEMENT REQUIRES A SAFE REGISTER
 3749  ! 2**8 = STATEMENT CONTAINS == TO RECORD OR SCALAR NAME
 3750  ! 2**9 = STATEMENT CONTAINS == TO ARRAY NAME
 3751  ! 2**10= STATEMENT CONTAINS A STORE VIA A BUILT-IN MAP
 3752  ! 2**20->Label2**31 GIVE TEXTUAL LEVELS OF ANY RTS CALLED
 3753           SFHEAD=0; BITS=0
 3754           %IF SAVECA-CODEBASE>4000 %THEN BITS=X'10';! LONG BRANCH BACK
 3755           %CYCLE J=FST,1,LST;          ! CYCLE THRO' ENCLOSED STMNTS
 3756              CSS(STPTRS(J),0);          ! COMPILE THEM
 3757                                         ! AND DISCARD ANY BINARY
 3758              BITS=BITS!CYC BITS;        ! REMEMBER SALIENT FEATURES
 3759              FORGETM(14)
 3760           %REPEAT
 3761           %IF CA-CODEBASE<4000 %THEN CYC BASE=10 %AND CYC ADDR=CODEBASE
 3762           CYC BITS=BITS
 3763           -> NO PRELOAD %UNLESS CYC BITS&1=0;   ! LABEL IN CYCLE
 3764           %IF CYC BITS&X'80'=0 %THEN ->Label5; ! IS A SAFE REG REQD?
 3765           %CYCLE J=14,-1,4
 3766              %IF CREGS&1<<J#0 %THEN CREGS=CREGS!!1<<J %AND ->Label5
 3767                                          ! REMOVE 1 SAFE REGISTER
 3768           %REPEAT
 3769  Label5:       %IF CYCBITS&X'C'=0 %THEN CREGS=CREGS!(1<<15)
 3770           QSORT(OPTINF,1,OPTPTR)
 3771           %IF DCOMP=1 %THEN %START
 3772              %CYCLE J=1,1,OPTPTR
 3773                 NEWLINE
 3774                 WRITE(OPTINF(J)_COUNT,5)
 3775                 WRITE(OPTINF(J)_TYPE,5)
 3776                 WRITE(OPTINF(J)_BITS,5)
 3777                 WRITE(OPTINF(J)_PTYPE,5)
 3778                 WRITE(OPTINF(J)_XTRA,5)
 3779              %REPEAT
 3780           %FINISH
 3781           %IF CYCBASE=0 %THEN OPTPTR=OPTPTR+1 %AND OPTINF(OPTPTR)_TYPE=12
 3782           -> RELOAD;             ! REARRANGE INFO GLEANED
 3783  NO PRELOAD:  CREGS=0
 3784  RELOAD:  RESTORE(HEAD);                ! RESET REGISTERS
 3785           CCSTATE=SCCSTATE
 3786           CA=SAVECA; CABUF=CA; PP CURR=0
 3787           %IF CREGS=0 %THEN %RETURN
 3788  !
 3789  ! LOAD BASE AND INCREMENT HERE WHEN RELEVANT IN CASE OF CYCLE I=1,1,I
 3790  !
 3791           %IF 4<=FLAG<=14 %START
 3792              P=STPTRS(1)+5
 3793              SKIP EXP
 3794              DSEXP(FLAG,0)
 3795              SET USE(FLAG,14,0)
 3796              SET USE(FLAG+1,14,0)
 3797           %FINISH
 3798           LOAD UP (CREGS)
 3799           %END
?USE unused
 3800           %ROUTINE CYC RESTORE
 3801           {%SHORTROUTINE}
 3802           %INTEGER I
 3803           %CYCLE I=4,1,15
 3804              %IF CYC REGS&1<<I#0 %THEN %START
 3805                 %IF GRUSE(I)=3 %THEN VDALLOC(I,I*(CYCASS>>I&1)) %C
 3806+                   %ELSE REGISTER(I)=0
 3807              %FINISH
 3808           %REPEAT
 3809           %END
 3810           %ROUTINE CREATE AH(%INTEGER MODE,REG,BS,DP)
 3811           {%SHORTROUTINE}
 3812  !***********************************************************************
 3813  !*       CREATES AN ARRAYHEAD IN TEMPORARY SPACE BY MODIFYING THE HEAD *
 3814  !*       AT BS&DP BY THE REGISTER REG,AS FOLLOWS:-                     *
 3815  !*       MODE=0 (ARRAYMAPPING)  REG HAS ADDR OF FIRST ELEMENT          *
 3816  !*       MODE=1 (ARRAYS IN RECORDS)-REG HAS RELOCATION FACTOR          *
 3817  !*       REG IS SET AND PROTECTED BY THE CALLING ROUTINE. ON EXIT DISP *
 3818  !*       INDEX & BASE POINT TO THE NEW ARRAYHEAD                       *
 3819  !***********************************************************************
 3820           %INTEGER I,R1,R2,R3,R4,R5,WK,J
 3821           GET WSP(WK,4);                ! GET FOUR WORDS FOR NEW HEAD
 3822           FIND SEQ(R1,R2);              ! 2 WORK REGISTERS
 3823           R3=(R2+1)&15; R4=(R3+1)&15;   ! TRY FOR 2 MORE
 3824           %UNLESS REGISTER(R3)=0=REGISTER(R4) %THEN R4=R2
 3825           %IF R1>R4 %THEN R5=R4+16 %ELSE R5=R4
 3826           %CYCLE J=R1,1,R5
 3827              I=J&15
 3828              REGISTER(I)=1;             ! CLAIM WORKING REGISTERS
 3829              FORGET(I)
 3830           %REPEAT
 3831           DUMPM(X'98',R1,R4,BS,DP);     ! PICK UP 2 OR 4 ELEMENTS
 3832           %IF MODE=0 %THEN PRR(X'1B',R1,R2); ! SR R1,R2
 3833           PRR(X'18'+2*MODE,R2,REG);     ! LR R2,REG (MODE=0) OR AR R2,REG
 3834           PRR(X'1A',R1,REG);            ! AR R1,REG
 3835           DUMPM(X'90',R1,R4,RBASE,WK);  ! STUFF OFF MODIFIED ELEMENTS
 3836           %IF R2=R4 %THEN %START;       ! ONLY 2 WORK REGISTERS
 3837              DUMPM(X'98',R1,R2,BS,DP+8);! SO REPEAT ON LAST ELEMENTS
 3838              DUMPM(X'90',R1,R2,RBASE,WK+8)
 3839           %FINISH
 3840  !
 3841           %CYCLE J=R1,1,R5
 3842              REGISTER(J&15)=0;          ! FREE WORK REGISTERS
 3843           %REPEAT
 3844           INDEX=0; BASE=RBASE
 3845           DISP=WK;                      ! WK RETURNED ON EXIT FROM CSS
 3846           CCSTATE=-1
 3847           %END;                         ! OF ROUTINE CREATE AH
 3848           %INTEGERFN DOPE VECTOR(%INTEGER ELSIZE,LB,UB)
 3849           {%SHORTROUTINE}
 3850  !***********************************************************************
 3851  !*        CONSTRUCTS THE DOPE-VECTOR FOR A 1-DIMENSIONAL ARRAY IN THE  *
 3852  !*       SHAREABLE SYMBOL TABLES AND RETURNS ITS DISPLACEMENT AS RESULT*
 3853  !*       EVENTUALLY ALL NON DYNAMIC DOPE VECTORS SHOULD GO VIA HERE    *
 3854  !*       AND AS MUCH SHARING AS POSSIBLE SHOULD GO ON.                 *
 3855  !*       THE LIST OF DOPE VECTORS LOOKS LIKE:-                         *
 3856  !*       STREAM1(32 BITS) = LOWER BOUND<<16 ! UPPER BOUND              *
 3857  !*       STREAM2(32 BITS) = DISPLACEMENT OF DOPEVECTOR IN SHAREABLE ST *
 3858  !*       STREAM3(16 BITS) = THE ELEMENT SIZE IN BYTES                  *
 3859  !*       A CHECK IS REQUIRED THAT EACH BOUND FITS INTO 16 BITS         *
 3860  !***********************************************************************
 3861           %INTEGER RANGE,I,J,K,W1,HEAD
 3862           W1=LB<<16!UB&X'FFFF'
 3863           %IF SHORTINTEGER(ADDR(W1))=LB %AND %C
 3864+              SHORTINTEGER(ADDR(W1)+2)=UB %START
 3865              HEAD=DVHEAD
 3866              %WHILE HEAD#0 %CYCLE;       ! SEARCH THE PREVIOUS DVS
 3867                 FROM123(HEAD,I,J,K);     ! FOR ONE THAT IS IDENTICAL
 3868                 MLINK(HEAD)
 3869                 %IF I=W1 %AND K=ELSIZE %THEN %RESULT=J
 3870              %REPEAT
 3871              PUSH123(DVHEAD,W1,SSTL,ELSIZE);! INSERT NEW DOPE VECR INTO LIST
 3872           %FINISH
 3873           RANGE=UB-LB+1
 3874           I=SSTL; ELSIZE=ELSIZE!1<<16
 3875           LPUT(4,16,SSTL,ADDR(ELSIZE))%IF INHCODE=0
 3876           SSTL=SSTL+16
 3877           %RESULT=I
 3878           %END
 3879  %ROUTINE CLAIM ST FRAME(%INTEGER AT,VALUE)
 3880  {%SHORTROUTINE}
 3881  !***********************************************************************
 3882  !*       FILL THE LA INSTN IT RT ENTRY SEQUENCE TO CLAIM THE STACKFRAME*
 3883  !*       DIFFICULT WHEN THE FRAME IS>4095                              *
 3884  !***********************************************************************
 3885  %INTEGER PLUG2
 3886           %IF 4096>VALUE %THEN PLUG(1,AT,VALUE) %AND %RETURN
 3887  !
 3888  ! IF THE FRAME IS >4096 THE WHOLE INSTRN IS OVERWRITTEN WITH AN ADD
 3889  !
 3890           %IF GLACA<4092 %THEN %START
 3891              PGLA(2,2,ADDR(VALUE)+2)
 3892              PLUG2=X'D000'!(GLACA-2)
 3893           %FINISH %ELSE PLUG2=X'C000'!(PTBASE+6+VALUE>>12<<2)
 3894           PLUG(1,AT-2,X'4AB0')
 3895           PLUG(1,AT,PLUG2)
 3896  %END
 3897           %ROUTINE CEND (%INTEGER KKK)
 3898  !***********************************************************************
 3899  !*       DEAL WITH ALL OCCURENCES OF '%END'                            *
 3900  !*       KKK=PTYPE(>=10000) FOR ROUTINES,FNS AND MAPS                  *
 3901  !*       KKK=0 FOR ENDS OF '%BEGIN' BLOCKS                             *
 3902  !*       KKK=1 FOR '%ENDOFPROGRAM'                                     *
 3903  !*       %ENDOFPROGRAM IS REALLY TWO ENDS. THE FIRST IS THE USERS      *
 3904  !*       AND THE SECOND IS PERMS. KKK=2 FOR A RECURSIVE CALL OF CEND   *
 3905  !*       ON END OF PROGRAM TO DEAL WITH THE %END CORRESPONDING TO      *
 3906  !*       THE %BEGIN COMPILED IN THE INITIALISATION SEQUENCE            *
 3907  !***********************************************************************
 3908           {%SHORT %ROUTINE}
 3909           %INTEGER KP
 3910           %SHORTINTEGERNAME THEAD
 3911           %ROUTINESPEC DTABLE(%INTEGER LEVEL,GLOBAL)
 3912           SET LINE; MONE=1; FORGETM(14)
 3913           CUR CYC VAR=0; CCSTATE=-1
 3914  !
 3915  ! FIRST CHECK FOR ANY '%STARTS' WITHOUT FINISHES
 3916  !
 3917           %WHILE SBR(LEVEL)#0 %CYCLE
 3918              FROM12 (SBR(LEVEL),J,KP)
 3919              FAULT(53,0);               ! FINISH MISSING
 3920              A(2)=14; A(3)=3; CSS(2,0); ! SO COMPILE IT IN
 3921           %REPEAT
 3922  !
 3923  ! NOW PLANT AN ERROR EXIT FOR FNS AND MAPS - CONTROL SHOULD BE RETURNED
 3924  ! VIA %RESULT= AN SHOULD NEVVER REACH THE %END INSTRUCTION
 3925  !
 3926           %IF KKK>10000 %AND COMPILER=0 %AND LAST INST=0 %THEN %START
 3927              PCONST(X'4100000B');       ! LA 0,11
 3928              PPJ(21);                   ! RUN FAULT 11
 3929           %FINISH
 3930           NMAX=N %IF N>NMAX;            ! WORK SPACE POINTER
 3931  !
 3932  ! CLEAR OUT THE LABEL LIST FAULTING LABELS WITH JUMPS OUTSTANDING
 3933  ! AS NOT SET AND COMMENTING ON LABELS NOT USED
 3934  !
 3935           %WHILE LABEL(LEVEL)#0 %CYCLE
 3936              POP123(LABEL(LEVEL),I,J,KP)
 3937              I=I>>24
 3938              %IF J&X'FFFF'#0 %THEN %START
 3939                 CLEAR LIST(SHORT INTEGER(ADDR(J)+2))
 3940                 %IF 0<KP<=MAX ULAB %THEN FAULT(11,-KP)
 3941              %FINISH %ELSE %START
 3942                 %IF I=0 %AND KP<MAX ULAB %THEN printstring("
 3943+ ?  UNUSED LABEL") %AND PRINTNAME(-KP)
 3944              %FINISH
 3945           %REPEAT
 3946  !
 3947           %CYCLE J=0,1,6
?Non-local
 3948              THEAD==AVL WSP(J,LEVEL);     ! RELEASE TEMPORARY LOCATIONS
 3949              %IF THEAD#0 %THEN CLEAR LIST(THEAD)
 3950           %REPEAT
 3951  !
 3952           DTABLE(LEVEL,0);              ! OUTPUT DIAGNOSTIC TABLES
 3953  !
 3954  ! CLEAR DECLARATIONS - POP UP ANY GLOBAL NAMES THAT WERE REDECLARED
 3955  ! DESTROY SIDE CHAINS FOR ROUTINES,FORMATS AND SWITCHES
 3956  !
 3957           JJ=NAMES(LEVEL)
 3958           %WHILE JJ>=0 %CYCLE
 3959                                      ! FIND A LOCAL NAME
 3960              I=SHORTINTEGER(ADDR(ASLIST(TAGS(JJ)))+12)
 3961              POP123(TAGS(JJ),KK,INTEGER(ADDR(SNDISP)),INTEGER(ADDR(K)))
 3962              PTYPE=KK>>16
 3963              %IF PTYPE =8 %THEN REGISTER(K)=0 %AND UVARREG(K)=0
 3964              %IF KK&15=15 %THEN FAULT(28,JJ);! SPEC BUT NO BODY GIVEN
 3965              %IF PTYPE>=10000 %OR PTYPE=4 %OR PTYPE=106 %OR %C
 3966+                PTYPE=126 %THEN CLEAR LIST(K)
 3967              JJ=I
 3968           %REPEAT
 3969           NAMES(LEVEL)=-1
 3970           %IF LEVEL=2 %THEN DTABLE(1,1); ! DO GLOBALS TO EXTERNALRTS
 3971  !
 3972  ! CHECK FOR MISSING REPEATS
 3973  !
 3974         %WHILE CYCLE(LEVEL)#0 %THEN FAULT(13,0)%AND POP(CYCLE(LEVEL),I,I)
 3975  !
 3976  ! REMOVE TEXT OF ANY LOCAL NAMES FROM WORD AND LETT
 3977  !
 3978           %IF NEXT#RNEXT %THEN %START
 3979              NEXT=RNEXT
 3980  !            %CYCLE I=0,1,NNAMES
 3981  !               WORD(I)=0 %IF WORD(I)>=NEXT
 3982  !            %REPEAT
 3983  !%if USE MC = 1 %start
 3984  !            *L_0,NEXT; *SR_15,15; *SR_1,1; *LA_2,2
 3985  !            *L_3,NNAMES; *AR_3,3; *L_4,WORD
 3986  !AGN:        *CH_0,0(1,4); *BC_2,*+8
 3987  !            *STH_15,0(1,4); *BXLE_1,2,<AGN>
 3988  !%finish
 3989           %FINISH
 3990  !
 3991  ! NOW CLAIM THE STACK FRAME BY FILING THE LA 11,0(11) IN THE BLOCK ENTRY
 3992  ! CODING. IF MORE THAN 4095 BYTES OF LOCAL VARIABLES ARE NEEDED THEN
 3993  ! THE WHOLE INSTRUCTION MUST BE OVERWRITTEN
 3994  !
 3995           NMAX=(NMAX+7)&(-8)
 3996           %IF KKK=2 %THEN %RETURN
 3997           %IF KKK>=10000 %OR KKK=1 %THEN CLAIM ST FRAME(SET(RLEVEL),NMAX)
 3998  !
 3999  ! NOW PLANT THE BLOCK EXIT SEQUENCE
 4000  !
 4001           %IF KKK=10000 %AND LAST INST=0 %THEN RT EXIT
 4002           PPJ(6) %IF KKK=1 %AND LAST INST=0;! %STOP AT %ENDOFPROGRAM
 4003           %IF KKK=0 %THEN %START;         ! BEGIN BLOCK EXIT
 4004              JJ=FROM2(LEVELINF)&X'FFF';    ! DISP OF SAVE AREA
 4005              DUMPM(X'98',10,11,RBASE,JJ);  ! RESTORE R11 & R10
 4006              %IF DIAGS1=1 %THEN %START;    ! RESTORE DIAGS POINTERS
 4007                 DUMP(X'58',0,JJ+8,0,RBASE)
 4008                 PRX(X'50',0,0,GLA,20)
 4009                 %FINISH
 4010           %FINISH
 4011  !
 4012  ! OUTPUT ANYTHING RELEVANT ONTO THE PROGRAM LISTING
 4013  !
 4014           NEWLINE
 4015           %IF PRINTMAP=1 %AND  KKK#0 %THEN %START
 4016              printstring(" LOCALS EXTEND TO ")
 4017              WRITE(NMAX,2)
 4018              NEWLINE
 4019  !            CHECK ASL
 4020           %FINISH
 4021           %IF LIST=0 %THEN %START;    ! SHORT LISTING REQD
 4022              WRITE(LINE,5)
 4023              %IF PRINTMAP=1 %THEN SPACES(3) %AND PRHEX(CA,5)
 4024              SPACES(3*LEVEL-3)
 4025              PRINTSTRING("END")
 4026           %FINISH
 4027  !
 4028  ! RETURN TO PREVIOUS LEVEL PROVIDED THERE IS A VALID ONE !
 4029  !
 4030           %UNLESS LEVEL>2 %OR (LEVEL=2 %AND CPRMODE=2) %THEN %START
 4031              %IF KKK=1 %AND LEVEL=2 %THEN KKK=2 %ELSE %C
 4032+                                    FAULT(14,0) %AND %STOP
 4033           %FINISH
 4034           LEVEL=LEVEL-1
 4035           %IF KKK>=10000 %THEN %START
 4036              RLEVEL=RLEVEL-1
 4037              RBASE=10-RLEVEL
 4038              REGISTER(9-RLEVEL)=0
 4039           %FINISH
 4040  !
 4041  ! RESTORE INFORMATION ABOUT THE (NEW) CURRENT LEVEL
 4042  !
 4043           POP123(LEVELINF,CODEBASE,N,FLAG)
 4044           NMDECS=CODEBASE>>24
 4045           CODEBASE=CODEBASE&X'FFFFFF'
 4046           GRINF(10)=CODEBASE
 4047           SBFLAG=N>>15&1
 4048           RNEXT=FLAG>>16
 4049           FLAG=FLAG&X'FFFF'
 4050           NMAX=N>>16 %IF KKK>=10000
 4051           N=N&X'7FFF'
 4052           %IF KKK=2 %THEN CEND(KKK);    ! ROUND AGAIN FOR 'ENDOFPROGRAM'
 4053  !
 4054  ! COMPLETE THE JUMP AROUND ALL NON-EXTERNAL ROUTINES EXCEPT WHEN
 4055  ! %TRUSTEDPROGRAM IS IN OPERATION.
 4056  !
 4057           %IF KKK>=10000 %AND COMPILER=0 %AND (RLEVEL#1 %OR CPRMODE#2)%C
 4058+             %THEN ENTER LAB(FROM3(LABEL(LEVEL)),0)
 4059           ->Label99
 4060           %ROUTINE DTABLE(%INTEGER LEVEL,GLOBAL)
 4061  !***********************************************************************
 4062  !*      THIS ROUTINE LOOKS AT THE DECLARATIONS FOR THE CURRENT LEVEL & *
 4063  !*      SETS UP THE SEGMENT OF SHARABLE SYMBOL TABLES TO DESCRIBE THEM.*
 4064  !*      FOR MAIN PROGRAMS OR EXTERNAL ROUTINES THE 'GLOBAL' VARIABLES  *
 4065  !*      (IF ANY) ARE ALSO INCLUDED.                                    *
 4066  !***********************************************************************
 4067           %STRING(32) RT NAME
 4068           %STRING(8) LOCAL NAME
 4069           %INTEGER DPTR,LNUM,ML,KK,JJ,Q,DEND,OL,LC
 4070           %INTEGERARRAY DD(0:300);       ! BUFFER FOR SEGMENT OF SST
 4071           %IF GLOBAL#0 %THEN DPTR=0 %AND ->START
 4072           DD(0)=X'C2C2C2C2';             ! MARKER ==M'BBBB' IN EBCDIC
 4073           ML=M(LEVEL);                   ! ROUTINE NAME(=0 FOR %BEGIN)
 4074           LNUM=LETT(ML);                 ! LENGTH OF THE NAME
 4075           DD(1)=L(LEVEL)<<16!RBASE<<8;   ! RT WORD TO TABLE
 4076           OL=L(LEVEL-1)
 4077           DPTR=3; DEND=0
 4078           %IF LNUM=0 %THEN DD(2)=L(LEVEL-1) %ELSE %START
 4079           Q=ADDR(LETT(ML))
 4080              RT NAME<-STRING(Q);         ! FOR RTS MOVE IN 1ST 32 CHARS
 4081              STRING(ADDR(DD(1))+3)=RTNAME;! AND UPDATE POINTER PAST
 4082              DPTR=DPTR+(LNUM-1)>>2;      ! ACTUAL NO OF CHARS
 4083           %FINISH
 4084  START:
 4085           JJ=NAMES(LEVEL)
 4086           %CYCLE LC=0,1,NNAMES
 4087              %EXIT %IF JJ<0
 4088                 %IF GLOBAL=0 %THEN %START
 4089                    KK=INTEGER(ADDR(ASLIST(TAGS(JJ))))
 4090                    %IF KK&X'F000'=0 %THEN %START
 4091                       printstring("
 4092+ ?  UNUSED NAME ")
 4093                       PRINTNAME(JJ)
 4094                    %FINISH
 4095                 %FINISH
 4096                 ->REP %IF DIAGS1=0 %OR LINENOS=0
 4097                 COPY TAG(JJ);               ! GET DETAILS
 4098                 %IF ARR=0 %AND ROUT=0 %AND DPTR<297 %ANDC
 4099+                   PREC<4 %AND (TYPE=1 %OR TYPE=2 %OR TYPE=5) %C
 4100+                   %AND (GLOBAL=0 %OR OLDI=1) %THEN %START
 4101                    Q=ADDR(LETT(WORD(JJ)));  ! ADDRESS OF NAME
 4102                    DD(DPTR)=NAM<<30!PREC<<27!TYPE<<24!I<<20!K<<8
 4103                    LOCAL NAME<-STRING(Q);   ! TEXT OF NAME FROM DICTIONARY
 4104                    LNUM=BYTE INTEGER(ADDR(LOCAL NAME))
 4105                    STRING(ADDR(DD(DPTR))+3)=LOCAL NAME;! MOVE IN NAME 
 4106                    DPTR=DPTR+(LNUM+7)>>2
 4107                 %FINISH
 4108  REP:           JJ=SHORTINTEGER(ADDR(ASLIST(TAGS(JJ)))+12)
 4109           %REPEAT
 4110           %IF LEVEL=2 %THEN %START;      ! GLOBALS TO FOLLOW
 4111              DD(DPTR)=-2;                ! GLOBAL TO COME MARKER
 4112              DPTR=DPTR+1
 4113           %FINISH %ELSE %START
 4114              DD(DPTR)=-1;                   ! 'END OF SEGMENT' MARK
 4115              DD(DPTR+1)=OL;                 ! SO DEBUG CAN FIND GLOBALS
 4116              DPTR=DPTR+2
 4117           %FINISH
 4118           DPTR=DPTR<<2
 4119           %IF DIAGS1=1 %THEN %START
 4120              %IF GLOBAL=1 %AND DPTR=8 %THEN SSTL=SSTL-4;! PUT -1 ONTOP OF -2
 4121              LPUT(4,DPTR,SSTL,ADDR(DD(0)));! ADD TO SHARABLE SYM TABS
 4122              SSTL=SSTL+DPTR
 4123           %FINISH
 4124           %END;                          ! OF ROUTINE DTABLE
 4125  Label99:      %END
 4126  !***********************************************************************
 4127  !*       VARIOUS ROUTINE THAT ARE REQUIRED ONLY AT BLOCK START         *
 4128  !*       AND BLOCK END ARE GATHERED HERE. HOPEFULLY THEY WILL BE PAGED *
 4129  !*       OUT EXCEPT WHEN NEEDED.                                       *
 4130  !***********************************************************************
 4131  !
 4132           %ROUTINE TEST NST
 4133  !***********************************************************************
 4134  !*       SEE IF NAME 'K' HAS BEEN DECLARED BEFORE AT THIS LEVEL        *
 4135  !***********************************************************************
 4136           FNAME=K
 4137           FAULT(7,FNAME) %IF FROM1(TAGS(FNAME))>>8&15=LEVEL
 4138           %END
 4139           %ROUTINE RELOCATE(%INTEGER GLARAD,VALUE,AREA)
 4140           {%SHORTROUTINE}
 4141  !***********************************************************************
 4142  !*      PLANTS A WORD IN THE GLA (IF GLARAD<0) AND ARRANGES TO         *
 4143  !*       RELOCATE IT RELATIVE TO AN AREA(CODE=1,GLA=2,CST=4,GST=5      *
 4144  !*       RELOCATION RELATIVE TO SYMBOL TABLES CAN NOW BE DONE HERE     *
 4145  !***********************************************************************
 4146           %IF GLARAD<0 %THEN PGLA(4,4,ADDR(VALUE)) %AND GLARAD=GLACA-4
 4147           %IF AREA<3 %THEN LPUT(AREA+19,0,GLARAD,0) %ELSE %C
 4148+             LPUT(AREA+14,0,GLARAD,0)
 4149  !            PUSH123(RELHEAD,GLARAD,VALUE,AREA)
 4150           %END
 4151           %ROUTINE GXREF(%INTEGER MODE,NAME,XTRA,AT)
 4152           {%SHORTROUTINE}
 4153  !***********************************************************************
 4154  !*       ASK LPUT TO ARRANGE TO RELOCATE 1 OR MORE WORDS AT 'AT'       *
 4155  !*       IN THE GLA BY EXTERNAL NAME 'NAME'.                           *
 4156  !*       MODE DEFINES ENTITY:-                                         *
 4157  !*       MODE=0 FOR STATIC XREFS (XTRA='S' OR 'I' FOR #IDENS)          *
 4158  !*       MODE=1 FOR DYNAMIC XREFS                                      *
 4159  !*       MODE=2 FOR DATA REFS XTRA=LMIN                                *
 4160  !*       NAME=0 FOR IOCP REFERENCES                                    *
 4161  !***********************************************************************
 4162           %INTEGER J,LPUTNO
 4163           %STRING(8) ID
 4164           %IF NAME<0 %THEN %START
 4165              %IF NAME=-1 %THEN J=ADDR(IOCP1)+3 %ELSE J=ADDR(IMPMON1)+3
 4166           %FINISH %ELSE J=ADDR(LETT(WORD(NAME)));! J TO NAME TEXT
 4167           ID<-STRING(J);                ! MOVE IN NAME
 4168           %IF MODE<=1 %AND XTRA>0 %THEN %C
 4169+             ID<-TOSTRING(XTRA)."#".ID
 4170           %IF MODE=2 %THEN LPUTNO=15 %ELSE LPUTNO=MODE+12
 4171           LPUT(LPUTNO,XTRA,AT,ADDR(ID))
 4172           %END
 4173  
 4174           %ROUTINE CXREF(%INTEGER MODE,NAME,XTRA,%INTEGERNAME AT)
 4175           {%SHORTROUTINE}
 4176  !***********************************************************************
 4177  !*       CREATE A ZEROED AREA IN THE GLA AND CALL GXREF TO GET         *
 4178  !*       IT FILLED AT LOAD TIME WITH INFORMATION ON AN EXTERNAL OBJECT *
 4179  !*       PARAMETERS ARE AS FOR GXREF.                                  *
 4180  !***********************************************************************
 4181           %INTEGER L
 4182           %IF MODE=2 %THEN L=4 %ELSE L=16;    ! DATA OR ROUTINE
 4183           PGLA(4,L,ADDR(FIXED GLA(7)));       ! 1 OR 4 ZERO WORDS
 4184           AT=GLACA-L
 4185           GXREF(MODE,NAME,XTRA,AT)
 4186           %END
 4187           %ROUTINE CLT
 4188           {%SHORTROUTINE}
 4189  !***********************************************************************
 4190  !*       DEAL WITH PHRASE TYPE AND SET PREC,TYPE & ACC                 *
 4191  !*       ONLY PROBLEM IS STRING WHICH HAS OPTIONAL MAX LENGTH ALSO     *
 4192  !*       P ON PHRASE TYPE AT ENTRY - TO NEXT PHRASE AT EXIT.           *
 4193  !***********************************************************************
 4194           TYPE=TYPEFLAG(A(P));       ! TYPEFLAG HOLDS PREC & TYPE
 4195           PREC=TYPE>>3
 4196           TYPE=TYPE&7
 4197           %IF PREC=2 %THEN WARN(LINE);   ! WARNING FOR SHORTS
 4198           PREC=3 %IF TYPE=2 %AND ALL LONG#0;! DEAL WITH '%REALSLONG'
 4199           ACC=BYTES(PREC)
 4200           %IF TYPE=5 %THEN %START;    ! P<TYPE>='%STRING'
 4201              %IF A(P+1)=1 %THEN %START;! MAX LENGTH GIVEN
 4202                 P=P+2
 4203                 ACC=A(P)+1
 4204                 FAULT(70,0) %UNLESS 2<=ACC<=256
 4205              %FINISH %ELSE ACC=0 %AND P=P+1
 4206           %FINISH
 4207           P=P+1
 4208           %END
 4209           %ROUTINE CQN(%INTEGER P)
 4210           {%SHORTROUTINE}
 4211  !***********************************************************************
 4212  !*       SET NAM,ARR & ACC FROM ALTERNATIVE OF PHRASE <QNAME'>         *
 4213  !*       P<QNAME'>='%ARRAYNAME','%NAME',<%NULL>                        *
 4214  !*       P POINTS TO THE ANALYSIS RECORD ENTRY AS IS NOT UPDATED       *
 4215  !***********************************************************************
 4216           %BYTEINTEGER I
 4217           I=A(P);NAM=0;ARR=0
 4218           %IF I=1 %THEN ARR=1 %AND ACC=16; ! ARRAYNAMES
 4219           %IF I<=2 %THEN NAM=1;           ! ARRAYNAMES & NAMES
 4220           %IF I=2 %THEN ACC=4;            ! NAMES USE 4-BYTE POINTER
 4221           %END
 4222           %ROUTINE     RHEAD(%INTEGER KK)
 4223           {%SHORTROUTINE}
 4224  !***********************************************************************
 4225  !*       COMPILES CODE FOR BLOCK AND ROUTINE ENTRY                     *
 4226  !*       KK IS THE RT/FN/MAP NAME (=-1 FOR %BEGIN BLOCKS)              *
 4227  !*       FLAGP IS AS KK EXCEPT FLAGP=10000 IS USED TO DISTINGUISH      *
 4228  !*       THE FIRST (PERM) BEGIN WHICH HAS TO BE TREATED AS A ROUTINE   *
 4229  !*       ROUTINE TAGS ARE AS FOLLOWS:-                                 *
 4230  !*       SNDISP = WORD(!) DISPLACEMENT OF EP(REF)FROM HEAD OF CODE(GLA)*
 4231  !*        (OR)  = LISTHEAD OF OUTSTANDING FORWARD REFS                 *
 4232  !*       KFORM  = PSIMPLE<<12 ! NO OF PARAMS                           *
 4233  !*       K      = LIST OF FORMAL PARAMETER DESCRIPTIONS                *
 4234  !***********************************************************************
 4235           %INTEGER FLAGP,W1,W2,W3,BASED,AT,WK
 4236           PUSH123(LEVELINF,NMDECS<<24!CODEBASE,NMAX<<16!SBFLAG<<15!N,%C
 4237+              RNEXT<<16!FLAG)
 4238           FLAGP=KK;FLAGP=10000 %IF RLEVEL=0
 4239           %IF LIST=0 %AND RLEVEL#0 %THEN %START;  ! OUTPUT HEADER
 4240              NEWLINE;WRITE(LINE,5)
 4241              %IF PRINTMAP=1 %THEN SPACES(3) %AND PRHEX(CA,5)
 4242              SPACES(3*LEVEL)
 4243              %IF KK<0 %THEN printstring("BEGIN") %ELSE %START
 4244                 %IF PTYPE=10000 %THEN printstring("RT ") %ELSE %C
 4245+                   printstring("FN/MAP ")
 4246                 PRINTNAME(KK)
 4247             %FINISH
 4248           %FINISH
 4249           LEVEL=LEVEL+1
 4250           NAMES(LEVEL)=-1
 4251           %IF FLAGP>=0 %THEN %START
 4252              RLEVEL=RLEVEL+1; RBASE=10-RLEVEL
 4253              FAULT(35,0) %IF RBASE=4 %OR REGISTER(RBASE)#0
 4254              FORGET(RBASE); REGISTER(RBASE)=-1
 4255           %FINISH
 4256           FAULT(34,0) %IF LEVEL=10
 4257           FAULT(105,0) %IF LEVEL>MAX LEVELS
 4258           NMDECS=0
 4259           %IF FLAGP<0 %THEN %START;       ! BEGIN BLOCKS
 4260              PRX(X'90',10,11,RBASE,N);    ! STM 10,11,?
 4261              N=N+12; W2=N-4
 4262           %FINISH
 4263           %IF KK>=0 %THEN %START;      ! ROUTINE ENTRY
 4264              %IF SNDISP=0 %AND EXTRN=4 %START; ! REPLACE 'NOT USED' BIT
 4265                 REPLACE1(TAGS(KK),FROM1(TAGS(KK))&X'FFFF0FFF')
 4266              %FINISH
 4267  !
 4268  ! NOW FILL ANY JUMPS TO THIS ROUTINE PLANTED SINCE
 4269  ! THE ROUTINESPEC WAS COMPILED. SEE ALSO 'RT JUMP'
 4270  !
 4271              %WHILE SNDISP#0 %CYCLE
 4272                 POP123(SNDISP,BASED,AT,W1)
 4273                 W2=CA-BASED
 4274                 %IF W1=0 %THEN %START
 4275                    WK=PTBASE+W2>>12<<2
 4276                    %IF W2<=4095 %THEN %START
 4277                       PLUG(1,AT,X'41DD');      ! OVERWRITE THE ADD
 4278                       WK=0;                  ! WITH LA 13,0(13) AS NO-OP
 4279                    %FINISH
 4280                    PLUG(1,AT+2,WK)
 4281                    AT=AT+4
 4282              
 4283                 %FINISH %ELSE %START
 4284                    FAULT(99,0) %IF W2>4095
 4285                 %FINISH
 4286                 PLUG(1,AT+2,W2&4095)
 4287              %REPEAT
 4288              SNDISP<-CA>>2
 4289              REPLACE2(TCELL,INTEGER(ADDR(SNDISP)));! NOTE ADDR FOR FUTURE CALLS
 4290              PCONST(X'50FB003C');          ! SAVE LINK -- ST 15,60(11)
 4291              W2=0
 4292           %FINISH
 4293           PRR(X'18',RBASE,WSPR) %UNLESS FLAGP<0
 4294           %IF KK<0 %THEN W3=0 %ELSE W3=WORD(KK)
 4295           L(LEVEL)=LINE;M(LEVEL)=W3
 4296           RNEXT=NEXT
 4297           FLAG=PTYPE;                ! CURRENT BLOCK TYPE MARKER
 4298           %IF FLAGP>=0 %THEN %START
 4299              SET(RLEVEL)=CA+2
 4300              PCONST(X'41BB0000');       ! LA WSP, ?(WSP)
 4301              N=64; NMAX=N;
 4302              FORGETM(14);               ! START NEW RT W CLEAN SLATE
 4303              CCSTATE=-1
 4304           %FINISH
 4305  !
 4306  ! IF IN DIAGNOSTIC MODE PLANT CODE TO SAVE THE LINE & ROUTINE NO OF
 4307  ! THE CALLING ROUTINE AND SET UP THE NEW BLOCK/ROUTINE IDENT NO.
 4308  !
 4309           %IF DIAGS1#0 %AND LINE>0 %THEN %START
 4310              PRX(X'58',0,GLA,0,20);     ! L  0,OLD DIAGS INF
 4311              DUMP(X'50',0,W2,0,RBASE);  ! ST 0,SAFE PLACE
 4312              DUMP(X'41',0,LINE,0,0);    ! LA   0,LINE NO
 4313              PCONST(X'4000D014');       ! STH 0,20(GLA)
 4314              FORGET(0);                 ! NEEDED FOR %BEGIN BLOCKS
 4315           %FINISH
 4316           MONE=1; SET LINE;             ! NOW UPDATE LINE NUMBER
 4317           %END;                         ! OF ROUTINE RHEAD
 4318           %ROUTINE  DEFINE EP(%INTEGER MODE,NAME,ADR,XTRA)
 4319           {%SHORTROUTINE}
 4320  !***********************************************************************
 4321  !*        ENTER AN ENTRY POINT ON THE ENTRY POINT LIST                 *
 4322  !*       AN ENTRY POINT LOOKS LIKE:-                                   *
 4323  !*       S1 = FLAG<<24 ! ENTRY POINT ADDRESS RELATIVE TO START OF AREA *
 4324  !*       S2 = XTRA INFO (PRIMARILY LENGTH OF DATA 'COMMON' AREAS)      *
 4325  !*       S3 = LINK TO SINGLE CELL SIDECHAIN CONTAINING NAME AS STRING  *
 4326  !*       FLAG = 0 FOR PROGRAM ENTRY POINT                              *
 4327  !*            = 1 FOR DATA IN GLA (%EXTERNAL)                          *
 4328  !*            = 2 FOR DATA IN GLA SYMBOL TABLE (%EXTERNAL %ARRAY)      *
 4329  !*       MODE=0 FOR S#GO, =1 SYSTEM ROUTINES,=2 EXTERNAL ROUTINES      *
 4330  !*       MODE=3 FOR DATA IN ADDRESSABLE GLA,=4 BACK OF GLA             *
 4331  !***********************************************************************
 4332           %SHORTINTEGER HEAD
 4333           %INTEGER JJ,FLAG,ID1,ID2,ID3
 4334           %STRING(8) ID
 4335           ID=""; FLAG=0
 4336           HEAD=0
 4337           %IF MODE=0 %THEN JJ=ADDR(MAINEP1)+3 %ELSE %C
 4338+                          JJ=ADDR(LETT(WORD(NAME)))
 4339           %IF MODE>=3 %THEN FLAG=MODE-2
 4340           %IF MODE=1 %THEN ID="S#"
 4341           ID<-ID.STRING(JJ)
 4342           STRING(ADDR(ID1))=ID
 4343           %IF FLAG=0 %THEN JJ=11 %ELSE JJ=14
 4344           %IF FLAG<=1 %THEN LPUT(JJ,XTRA,ADR,ADDR(ID)) %ELSE %START
 4345              PUSH123(HEAD,ID1,ID2,ID3>>16)
 4346              PUSH123(EPLINK,FLAG<<24!ADR,XTRA,HEAD)
 4347           %FINISH
 4348           %END
 4349           %ROUTINE     CRSPEC (%INTEGER M)
 4350           {%SHORTROUTINE}
 4351  !***********************************************************************
 4352  !*        MODE=0  FOR NORMAL ROUTINE SPEC                              *
 4353  !*        MODE=1 FOR EXTERNAL(ETC) ROUTINE SPECS XREF NEEDED           *
 4354  !*        MODE=2 FOR %SPEC FOR RT PARAMS                               *
 4355  !*       ROUTINE TAGS ARE AS FOLLOWS:-                                 *
 4356  !*       SNDISP = WORD(!) DISPLACEMENT OF EP(REF)FROM HEAD OF CODE(GLA)*
 4357  !*        (OR)  = LISTHEAD OF OUTSTANDING FORWARD REFS                 *
 4358  !*       KFORM  = PSIMPLE<<12 ! NO OF PARAMS                           *
 4359  !*       K      = LIST OF FORMAL PARAMETER DESCRIPTIONS                *
 4360  !***********************************************************************
 4361           %INTEGER PP,KK,JJ,JJJ,Q,TYPEP,PREFIX,INC,PSIMPLE,PPOSN
 4362           %SHORTINTEGER OPHEAD,OPBOT
 4363           Q=0
 4364           %IF M#2 %THEN %START
 4365  !
 4366  ! WORK OUT TYPEP IE TYPE OF ENTITITY BY INSPECTING AR FOR P<RT>
 4367  !
 4368              %IF A(P+1)=1 %THEN %START;  ! P<RT>=%ROUTINE
 4369                 TYPEP=10000; P=P+3
 4370              %FINISH %ELSE %START;       ! P<RT>=<TYPE><FNORMAP>
 4371                 ROUT=1; ARR=0; P=P+2
 4372                 CLT; NAM=(A(P)-1)<<1
 4373                 PACK(TYPEP)
 4374                 P=P+2
 4375              %FINISH
 4376           %FINISH
 4377           KK=A(P); COPYTAG(KK)
 4378  !
 4379  ! IF KK IS A VALID RT TYPE PARAM IT MUST BE DECLARED AT THE CURRENT
 4380  ! LEVEL AND HAVE 1000 PARAMS. IF KK IS A NEW DECLARATION '%SPEC' CANNOT
 4381  ! BE USED AND THE NAME MUST NOT BE SET AT THE CURRENT LEVEL.
 4382  !
 4383           %IF SNPT#PTYPE>=10000 %THEN Q=KFORM&4095 %AND %C
 4384+                                       JJ=(SNDISP&X'FFFF')<<2
 4385           %UNLESS OLDI=LEVEL %AND Q=1000 %AND %C
 4386+                  (M=2 %OR PTYPE-1000=TYPEP) %THEN %START
 4387  !
 4388  ! KK IS NOT A VALID RT TYPE PARAM
 4389  !
 4390              %UNLESS OLDI#LEVEL %AND M<=1 %THEN %START;! KK VALID DECLN
 4391                 FAULT(7-M>>1<<2,KK);     ! FAULT 3(SPEC?)OR 7(SET TWICE)
 4392                 %RETURN %UNLESS M=0
 4393              %FINISH
 4394              JJ=0;                       ! SO MAKE DECLARATION
 4395              J=15-M; PTYPE=TYPEP
 4396              KFORM=0
 4397              %IF OLDI = LEVEL %THEN %START
 4398                USEBITS = INTEGER(ADDR(ASLIST(TAGS(KK)))) >> 12 & X'F'
 4399                I = RBASE
 4400                REPLACE TAG (KK)
 4401              %FINISH %ELSE STORE TAG(KK,0)
 4402           %FINISH
 4403           OPHEAD=0; OPBOT=0
 4404           PPOSN=64;                      ! DISPLCMENT OF EACH PARAM
 4405           INC=1; JJJ=OPHEAD; PSIMPLE=1
 4406           P=P+1; Q=0;                    ! Q COUNTS NO OF FORMAL PARAMS
 4407           %WHILE A(P)=1 %CYCLE;          ! WHILE SOME(MORE) FPS
 4408              P=P+INC;                    ! P<COMMA'> BETWEEN FPDELS
 4409              CFPDEL;                     ! GET TYPE & ACC FOR NEXT GROUP
 4410              PPOSN=(PPOSN+KFORM-1)&(-KFORM)
 4411              PSIMPLE=0 %UNLESS PTYPE=1 %OR %C
 4412+                  (ROUT=0 %AND ARR=0 %AND NAM=1 %AND TYPE#0)
 4413              %CYCLE PP=1,1,A(P);         ! DOWN <NAMELIST> FOR EACH DEL
 4414                 BINSERT(OPHEAD,OPBOT,PTYPE,ACC<<16!PPOSN,0)
 4415                 Q=Q+1
 4416                 PPOSN=PPOSN+ACC
 4417              %REPEAT
 4418              P=P+PP+1;                   ! ASSUMES PP SET TO A(P) BY REPE
 4419              INC=2;                      ! TO IGNORE ALT OF P<COMMA'>
 4420           %REPEAT
 4421           %IF EXTRN=1 %THEN PREFIX='S' %ELSE PREFIX=0
 4422           %IF M=1 %THEN CXREF((EXTRN-1)>>1,KK,PREFIX,JJ)
 4423           TCELL=TAGS(KK)
 4424           INTEGER(ADDR(SNDISP))=FROM2(TCELL)
 4425           KFORM=PSIMPLE<<12!Q
 4426           K=OPHEAD; SNDISP<-(JJ>>2)
 4427           REPLACE2(TCELL,INTEGER(ADDR(SNDISP)))
 4428           REPLACE3(TCELL,INTEGER(ADDR(K)))
 4429           %END
 4430           %ROUTINE CFPDEL
 4431           {%SHORTROUTINE}
 4432  !***********************************************************************
 4433  !*       SET UP PTYPE & ACC FOR A LIST OF FORMAL PARAMETERS            *
 4434  !*       P<FPDEL>=<RT><%NAME'>,<TYPE><%QNAME'>,'%NAME',                *
 4435  !*                '%RECORD'<%ARRAY'>'%NAME'.                           *
 4436  !***********************************************************************
 4437           %BYTEINTEGER FPALT
 4438           FPALT=A(P); P=P+1; KFORM=4
 4439           %IF FPALT<=2 %THEN %START
 4440              %IF FPALT=1 %THEN %START
 4441                 ACC=4; ROUT=1; ARR=0
 4442                 %IF A(P)=2 %THEN %START;   ! P<RT>=<TYPE><FNORMAP>
 4443                    P=P+1; CLT
 4444                    NAM=(A(P)-1)<<1+1;      ! 1 FOR FN 3 FOR MAP
 4445                    ACC=4
 4446                 %FINISH %ELSE %START;      ! P<RT>='%ROUTINE'
 4447                    NAM=1; PREC=0; TYPE=0
 4448                 %FINISH
 4449                 P=P+2
 4450              %FINISH %ELSE %START;         ! FPALT=2
 4451                 ROUT=0
 4452                 CLT; CQN(P)
 4453                 FAULT(70,0) %IF TYPE=5 %AND ACC=0
 4454                 %IF NAM=0 %THEN %START
 4455                    %IF TYPE=5 %THEN KFORM=1 %ELSE KFORM=ACC
 4456                 %FINISH
 4457                 P=P+1
 4458              %FINISH
 4459           %FINISH %ELSE %START
 4460              ROUT=0; PREC=0; NAM=1
 4461              %IF FPALT=3 %THEN %START;     ! P<FPDEL>='%NAME'
 4462                 ACC=8; ARR=0; TYPE=0
 4463              %FINISH %ELSE %START
 4464                 ARR=2-A(P)
 4465                 ACC=4+12*ARR
 4466                 TYPE=3; P=P+1
 4467              %FINISH
 4468           %FINISH
 4469           PACK(PTYPE)
 4470           %END
 4471           %ROUTINE ASSIGN(%INTEGER ASSOP,P1)
 4472           {%SHORTROUTINE}
 4473  !***********************************************************************
 4474  !*       HANDLES ARITHMETIC,STRING & ADDRESS ASSIGNMENTS TO VARIABLES  *
 4475  !*       FORMAL PARAMETERS AND DOPEVECTORS                             *
 4476  !*       ASSOP:-                                                       *
 4477  !*        1 IS FOR '=='                                                *
 4478  !*        2 IS FOR '='                                                 *
 4479  !*        3 IS FOR '<-' (JAM TRANSFER)                                 *
 4480  !*        4 IS FOR '->' (UNCONDITIONAL RESOLUTION)                     *
 4481  !*       >4 IS A SPECIAL FOR RESOLUTION                                *
 4482  !*               STORE BASE&DISP INTO NAME INDEXED BY P1 (RESLN)       *
 4483  !*                                                                     *
 4484  !*       P POINTS TO THE EXPRESSION. P1 TO THE NAME ON LHS OR          *
 4485  !*       P1=BASE<<16!OFFSET AND TYPE+PREC SET UP FOR FORMAL PARAMETERS *
 4486  !***********************************************************************
 4487           %SHORTINTEGER HEAD1,NOPS,TPCELL,BOT1
 4488           %INTEGER Q,QQ,KK,REG,Z,ZP,TYPEP,PRECP,PTYPEP,JJJ,P2,JJ, %C
 4489+             BASEP,DISPP,RHTYPE,ACCP,II
 4490           %SWITCH SW(0:3);              ! TO SWITCH ON ASSOP
 4491  !
 4492           %IF ASSOP>4 %THEN %START
 4493              BASEP=BASE; DISPP=DISP; RHTYPE=TYPE
 4494           %FINISH
 4495           P2=P
 4496           %IF P1< X'FFFF' %THEN %START
 4497              P=P1; REDUCE TAG(1);       ! LOOK AT LH SIDE
 4498           %FINISH
 4499           PTYPEP=PTYPE; JJ=J
 4500           KK=K; II=I
 4501           TPCELL=TCELL; ACCP=ACC
 4502           P=P2; TYPEP=TYPE; PRECP=PREC; ! SAVE USEFUL INFO FOR LATER
 4503           -> SW(ASSOP&3)
 4504  !
 4505  SW(2):SW(3):                           ! ARITHMETIC ASSIGNMENTS
 4506           ->REGVAR %IF TYPE=8;          ! LHS A REGISTER VARIABLE
 4507           %IF TYPE=3 %THEN %START;      ! RECORD SO EXAMINE SUBNAME
 4508           P=P1; Q=COPY RECORD TAG(QQ)
 4509           P=P2; %IF TYPE=3 %THEN ->RECOP; %FINISH
 4510           TYPE=1 %UNLESS TYPE=2 %OR TYPE=5;! IN CASE OF RUBBISHY SUBNAMES
 4511           ->Label50 %IF TYPE=5;              ! LHS IS A STRING
 4512  !
 4513  ! THE CODING BETWEEN HERE AND 'BACK' EXAMINES FOR DEGENERATE ASSIGNMENT
 4514  ! CASES SUCH AS 'I=I!2' OR BYTE=BYTE&7. THESE CAN BE HANDLED IN ONE SI
 4515  ! M/C INSTRUCTION. THE CODING COULD BE EXTENDED TO FIND'I=I!J'
 4516  ! THIS WHOLE SECTION IS OMITTED FROM SERVICE IMP(AA)
 4517  !
 4518           %IF ASSOP<=3 %AND CHECKSP=0 %AND TYPEP=1 %AND ARR=0 %AND %C
 4519+             NAM=0 %AND P1<X'FFFF' %AND ROUT=0 %AND A(P1+1)=2 %START;! NO APP
 4520              TYPEP=PTYPE; PRECP=PREC
 4521              Q=TSEXP(JJJ,0);            ! EXAMINE RHS
 4522  !
 4523  ! CHECK FORM OF RHS AND THAT THE SAME NAME IS ON BOTH SIDES
 4524  !
 4525              %IF (Q=300 %OR Q=400 %OR (Q=800 %AND PRECP=1)) %AND %C
 4526+                KK=K %AND II=I %AND KK<=4095 %START
 4527                 KK=KK+BYTES(PRECP)-1
 4528                 %IF Q=300 %THEN ZP=X'97' %ELSE ZP=X'96'
 4529                 %IF Q=800 %THEN ZP=X'94'
 4530                 PSI(ZP,JJJ,II,KK)
 4531                 CCSTATE=-1
 4532                 ->NA
 4533              %FINISH %ELSE PTYPE=TYPEP %AND UNPACK
 4534           %FINISH
 4535  BACK:    HEAD1=0;                      ! CLEAR TEMPORAYRY LIST HEADS
 4536           TYPE=1 %UNLESS TYPE=2;        ! DEAL WITH UNSET NAMES
 4537           ZP=TYPE; NOPS=1; P=P2+2
 4538           %IF TYPE=2 %THEN ZP=ZP+PREC&1
 4539           PUSH(HEAD1,ASSOP&3+28,0);       ! ASSIGNMENT OPERATOR
 4540           BOT1=HEAD1
 4541           %IF P1>X'FFFF' %THEN Z=P1>>16<<8!9 %ELSE Z=2
 4542           PUSH(HEAD1,PTYPEP<<16!Z,P1&X'7FFF');! LHS
 4543           %IF ASSOP>4 %THEN %START
 4544              FAULT(24,0) %UNLESS TYPE=RHTYPE
 4545              PUSH(HEAD1,RHTYPE<<16!BASEP<<8!9,DISPP)
 4546              SET USE((RHTYPE&2)<<3+BASEP,1,HEAD1) %IF DISPP<0
 4547           %FINISH %ELSE TORP(HEAD1,BOT1,NOPS,ZP);! RHS TO REVERSE POLISH
 4548           Q=P; EXPOP(HEAD1,-1,NOPS,16); ! PLANT CODE
 4549           P=Q
 4550  !         CLEARLIST(HEAD1)
 4551           SHORTINTEGER(ADDR(ASLIST(BOT1))+14)=ASL
 4552           ASL=HEAD1; ->Label1
 4553  NA:      NOTE ASSMENT(-1,ASSOP&3,A(P1)); ->Label1
 4554  Label50:      Z=0;                          ! STRINGS
 4555           %IF ASSOP<4 %THEN %START;     ! SORT RHS
 4556              FIND REG(SAFE,REG)
 4557              CSTREXP(0,REG); Z=NEST
 4558              %IF Z>0 %THEN SET USE(Z,13,0)
 4559              DISPP=DISP; BASEP=BASE
 4560              %UNLESS CHECKSP=0 %OR 4<=BASEP<=14 %START
 4561                 PRR(X'18',REG,BASEP)
 4562                 SET USE(REG,GRUSE(BASEP),GRINF(BASEP))
 4563                 BASEP=REG
 4564              %FINISH
 4565           %FINISH
 4566           REGISTER(BASEP)=1 %IF REGISTER(BASEP)=0
 4567           QQ=STRINGL; Q=P
 4568           %IF P1>X'FFFF' %THEN %START
 4569              BASE=P1>>16; DISP=P1&X'FFFF'
 4570              BML=0; DML=ACCP
 4571           %FINISH %ELSE %START
 4572              P=P1; CNAME(1,0)
 4573              %IF INDEX>0 %THEN %START
 4574                 PRR(X'1A',INDEX,BASE)
 4575                 FORGET(INDEX)
 4576                 BASE=INDEX; INDEX=0
 4577              %FINISH
 4578           %FINISH
 4579  !
 4580  
 4581           %IF DISPP=X'C0' %AND BASEP=CODER %THEN %START
 4582              DUMPSI(X'92',0,BASE,DISP);         ! MVI IF RHS NULL
 4583           %FINISH %ELSE %START
 4584              REG=(ASSOP&3-1)^^2
 4585              %IF REG#1 %OR Z<=0 %OR GRUSE(Z)#13 %THEN Z=-2
 4586              STRINGOP(REG,QQ,BASE,DISP,BASEP,DISPP,BML,DML,Z)
 4587              %IF Z>0 %AND GRUSE(Z)=13 %THEN SET USE(Z,2,-2)
 4588              REGISTER(BASEP)=0 %IF REGISTER(BASEP)>0
 4589           %FINISH
 4590           P=Q; ->Label1
 4591  REGVAR:  FAULT(59,0) %UNLESS A(P1+1)=2=A(P1+2)
 4592           KK=1<<K
 4593           %IF REGISTER(K)>=0 %THEN ABORT
 4594          %IF CYC REGS&KK#0 %THEN CYC ASS=CYC ASS!KK %ELSE NMDECS=NMDECS!4
 4595           CSEXP(K,1); ->NA
 4596  
 4597  ! THIS SECTION DEALS WITH OPERATIONS ON COMPLETE RECORDS
 4598  RECOP:                                   ! LHS IS RECORD WITHOUT SUBNAME
 4599           Q=TSEXP(JJJ,0)
 4600           -> RZ %IF Q=1=TYPE %AND JJJ=0;  ! CLEAR ENTIRE RECORD TO ZERO
 4601           -> BACK %UNLESS Q=30;           ! ASSIGN RECORD TO RECORD
 4602           P=P2+4; CNAME(16,-2);           ! SET BASE &DISP FOR RHS
 4603           BASEP=BASE; DISPP=DISP
 4604           ZP=ACC
 4605           CYC BITS=CYC BITS!128 %IF COMPILER=0; ! SAFE REG NEEDED
 4606           %UNLESS COMPILER=1 %OR 4<=BASE<=14 %START
 4607              FINDREG(SAFE,NEST)
 4608              PRR(X'18',NEST,BASE)
 4609              SET USE(NEST,GRUSE(BASE),GRINF(BASE))
 4610              BASEP=NEST
 4611           %FINISH
 4612           REG=BASEP
 4613           REGISTER(BASEP)=1 %IF REGISTER(BASEP)=0
 4614  RZ:      P=P1; CNAME(16,-2);             ! BASE & DISP FOR LHS
 4615           KK=DISP; JJ=BASE; ACCP=ACC
 4616  !
 4617           %IF Q=1 %THEN %START
 4618           BASEP=0; DISPP=0
 4619           %FINISH %ELSE %START
 4620           ->F66 %IF ASSOP=2 %AND ACCP#ZP;  ! '=' OPRN BOTH RECORD MUST
 4621                                            ! HAVE THE SAME LENGTH
 4622           %IF ZP<ACCP %THEN ACCP=ZP;       ! ON'<-' MOVE SMALLER
 4623           %FINISH
 4624           REGISTER(JJ)=1 %IF REGISTER(JJ)=0
 4625  !
 4626           BULKM(Q-1,ACCP,JJ,KK,BASEP,DISPP)
 4627           %IF REGISTER(JJ)>0 %THEN REGISTER(JJ)=0
 4628           %IF Q=30 %AND REGISTER(BASEP)>0 %THEN REGISTER(BASEP)=0
 4629           P=P2; SKIP EXP; ->Label1
 4630  SW(0):                                 ! RESOLUTION
 4631           P=P1; CNAME(5,1);             ! LOAD UP LHS
 4632           P=P2; CRES(0); ->Label1;           ! PERFORM UNCONDITIONAL RESOLUTIO
 4633  SW(1):                                 ! '==' AND %NAME PARAMETERS
 4634           ->F2 %UNLESS A(P2+2)=4 %AND A(P2+3)=1;! DISALLOW EXPRESSIONS
 4635           REG=-2
 4636            %UNLESS ROUT=0 %AND ARR=0 %AND (P1>X'FFFF' %OR %C
 4637+          A(P1+1)=2=A(P1+2)) %THEN  CLAIM(SAFE,REG) %AND FORGET(REG)
 4638           %IF TYPE=3 %THEN %START
 4639              ->RECNAME %IF P1>X'FFFF';     ! RECORD NAME PARAMETERS
 4640              P=P1; Q=COPY RECORD TAG(QQ)
 4641              TYPEP=TYPE; PRECP=PREC; JJ=J
 4642              -> RECNAME %IF Q=0 %AND NAM=1
 4643           %FINISH
 4644           -> F1 %UNLESS NAM=1;          ! LHS MUST BE A POINTER
 4645           P=P2+4
 4646           ->ARRNAME %IF ARR=1
 4647           CNAME(3,REG)
 4648           Z=I; ZP=K
 4649           REG=NEST %IF REG<0
 4650           %IF A(P2+5)=2=A(P2+6) %THEN %C
 4651+          NOTE ASSMENT(-1,1,A(P2+4));   ! RHS VARIAVBLE MAY BE CHANGED
 4652                                         ! BY ASSIGNING TO LHS
 4653           KK=6
 4654  COMM:    ->F3 %UNLESS TYPEP=0 %OR TYPE=0 %OR %C
 4655+             (TYPE=TYPEP %AND (PREC&3)=PRECP)
 4656           ->F2 %UNLESS A(P)=2;          ! NO REST OF EXPRSSN
 4657           Q=P+1; P=P1
 4658           %IF P<X'FFFF' %THEN %START
 4659              CNAME(KK,REG)
 4660              %IF A(P1+1)=2=A(P1+2) %THEN NOTE ASSMENT(REG,1,A(P1))
 4661           %FINISH %ELSE %START
 4662              BASE=P>>16; DISP=P&X'7FFF'
 4663              DUMP(1,REG,DISP,0,BASE) %UNLESS KK=12
 4664              %IF TYPEP=0 %THEN %START; ! TO A %NAME PARAM
 4665                 %IF TYPE=0 %THEN %START; ! %NAME TO %NAME
 4666                    JJJ=X'58'; ZP=ZP+4;   ! LOAD INFO WORD
 4667                 %FINISH %ELSE %START;    ! NORMAL VARIABLE TO %NAME
 4668                    PSI(X'92',PREC<<3!TYPE,BASE,DISP);  ! FLAGS BYTE
 4669                    %IF TYPE=5 %THEN JJJ=X'88' %AND ZP=24 %ELSE %START
 4670                       JJJ=X'41'
 4671                       %IF TYPE>=3 %THEN ZP=ACC %ELSE ZP=BYTES(PREC)
 4672                       ZP=ZP-1
 4673                    %FINISH
 4674                 Z=0
 4675                 %FINISH
 4676                 DUMP(JJJ,REG,ZP,0,Z)
 4677                 FORGET(REG)
 4678                 DUMP(X'50',REG,DISP+4,0,BASE);!    STORE XTRA WORD
 4679              %FINISH
 4680           %FINISH
 4681           REGISTER(REG)=0 %IF REGISTER(REG)>=0; P=Q
 4682           %IF KK=12 %THEN %START;       ! == TO ARRAY NAME
 4683              FORGET(REG)
 4684              CYC BITS=CYC BITS!512;     ! ARRAYNAME == BIT
 4685              PMVC(16,BASE,DISP,Z,ZP);   ! MOVE IN ARRAYHEAD
 4686                                         ! DISP>4095 SORTED IN CNAME
 4687              REGISTER(Z)=0 %IF REGISTER(Z)=2
 4688              ->F3 %UNLESS P1>X'FFFF' %OR ARR=1 %OR ARR=2
 4689                                          ! ALLOW ARRAYS&VECTORS \FORMATS
 4690           %FINISH %ELSE CYC BITS=CYC BITS!256;! REC/SCALAR == BIT
 4691           ->Label1
 4692  ARRNAME: CNAME(12,REG);                ! SET BASE & DISP
 4693           Z=BASE; ZP=DISP;              ! AND SAVE THEM
 4694           ->F3 %UNLESS 1<=ARR<=2
 4695           %IF JJ=0 %THEN %START
 4696           JJ=J; %IF P1<X'FFFF' %THEN %START
 4697           KK=FROM1(TPCELL);              ! DEDUDCE NO OF DIMENS
 4698           REPLACE1(TPCELL,KK!JJ); %FINISH; %FINISH
 4699           FAULT(85,0) %UNLESS J=JJ %OR J=0
 4700           REGISTER(Z)=2 %IF REGISTER(Z)=0
 4701           KK=12; ->COMM
 4702  RECNAME: P=P2+4
 4703           ->ARRNAME %IF ARR=1 %AND (P1>X'FFFF' %OR A(P1+1)=2);
 4704           CNAME(15,REG);                ! FETCH/SET POINTER
 4705           REG=NEST %IF REG<0
 4706           KK=14; ->COMM
 4707  F66:      Q=66; ->F00
 4708  F1:      Q=82; ->F00;                  ! LHS NOT A POINTER VARIABLE
 4709  F0:      P=P2; SKIP EXP;               ! SKIP RHS
 4710           %IF 0<=REG<=15 %AND REGISTER(REG)>0 %THEN REGISTER(REG)=0
 4711           ->Label1
 4712  F2:      Q=81;                         ! RHS AN EXPRSSN
 4713  F00:     %IF P1>X'FFFF' %THEN Q=22;    ! IF PARAM GIVE 'ACTUAL PARAM FLT
 4714           %IF Q=82 %THEN JJ=A(P1) %ELSE JJ=0
 4715           FAULT(Q,JJ)
 4716           ->F0
 4717  F3:      Q=83; ->F00;                  ! NON-EQUIVALENCE'
 4718  Label1:       %END
 4719           %ROUTINE     CUI(%INTEGER CODE)
 4720           {%SHORTROUTINE}
 4721           %INTEGER KK,JJ,QQ
 4722           %BYTEINTEGER TYPEP,PRECP
 4723           %SWITCH SW(1:8)
 4724           REPORTUI=0;                  ! =0 CONTINUE,=1 UNCOND JUMP
 4725           ->SW(A(P))
 4726  SW(1):   P=P+1; MARKER1=P+A(P);      !(NAME)(APP)(RESTOFUI)
 4727           ->Label3 %IF A(MARKER 1)=1
 4728           P=P+1; CNAME(0,0); P=P+1; -> AUI
 4729  Label3:       KK=P+1; P=MARKER1+2
 4730           ASSIGN(A(MARKER1+1),KK)
 4731  AUI:     P=P+1
 4732           %IF A(P-1)=1 %THEN CUI(CODE); ->Label1
 4733  SW(2):   !-><NAME><EXRN>
 4734           CURR INST=1 %IF CODE=0
 4735           NMDECS=NMDECS!1
 4736           CYC BITS=CYC BITS!2;     ! SET 'JUMP' BIT
 4737           ->NLAB %IF A(P+1)=1;          ! NUMERIC
 4738           ->SLAB %IF A(P+3)=2;          ! SIMPLE NAME
 4739           COPYTAG(A(P+2))
 4740           KK=K; P=P+2
 4741           PTYPEP=PTYPE
 4742           %UNLESS OLDI=LEVEL %AND TYPE=6 %THEN %START
 4743              FAULT(4,0); P=P+1; SKIP APP; ->Label1
 4744           %FINISH
 4745           FROM12(KK,QQ,JJ)
 4746           JJ=QQ+8-JJ*BYTES(PREC);      ! DISP OF SW(0)
 4747           CANAME(1,GLA,0,QQ)
 4748           %IF CHECKS=0 %THEN %START; ! OPTIMISING PUT JUMP INLINE
 4749              DUMP(2*PREC+2,-2,DISP+JJ,BASE,INDEX)
 4750              PRX(X'47',15,NEST,10,0)
 4751              FORGET(NEST)
 4752           %FINISH; REPORTUI=1; ->Label1
 4753  NLAB:    K=A(P+2); P=P+3
 4754  LCOM:    ENTER JUMP(MASK,K,0)
 4755           REPORTUI=1 %IF MASK=15; ->Label1
 4756  SLAB:    K=16384+A(P+2); P=P+4; ->LCOM
 4757  SW(3):                                 ! printstring("TEXTTEXT")
 4758           WARN(LINE)
 4759           P=P+1; TEXTOUT(0); ->AUI
 4760  SW(4):                                 ! %RETURN
 4761           FAULT(30,0) %UNLESS FLAG=10000 %OR COMPILER=1
 4762           P=P+1
 4763  Label6:       RT EXIT
 4764           CYC BITS=CYC BITS!2;         ! SET 'JUMP OUT' BIT
 4765           REPORTUI=1
 4766           CURR INST=1 %IF CODE=0; ->Label1
 4767  SW(5):                                 ! %RESULT(ASSOP)(EXPR)
 4768           PTYPE=FLAG;! UNPACK
 4769  !%if USE MC = 1 %start
 4770  !            *L_1,PTYPE; *CVD_1,0(11)
 4771  !            *UNPK_ROUT(5),5(3,11)
 4772  !            *NC_ROUT(5),MASK1
 4773  !%finish
 4774           %IF PTYPE>10000 %AND A(P+1)#3 %THEN %START;! ASSOP #'->'
 4775              %IF A(P+1)=1 %AND NAM#0 %AND A(P+4)=4 %AND A(P+5)=1 %START
 4776                 P=P+6; TYPEP=TYPE; PRECP=PREC
 4777                 CNAME(3,1)
 4778                 FAULT(81,0) %UNLESS A(P)=2; P=P+1
 4779                 FAULT(83,0) %UNLESS TYPEP=TYPE %AND PRECP=PREC
 4780                 ->Label6
 4781              %FINISH
 4782              %IF A(P+1)=2 %THEN %START;    ! ASSOP='='
 4783                 P=P+2
 4784                 %IF NAM#0 %THEN TYPE=1;    ! MAPS HAVE INTEGER RESULTS
 4785                 %IF TYPE=5 %THEN CSTREXP(1,1) %ELSE %START
 4786                    PREC=TYPE %UNLESS PREC=3 %AND NAM=0
 4787                    CSEXP(TYPE,PREC)
 4788                 %FINISH; ->Label6
 4789              %FINISH
 4790           %FINISH
 4791           FAULT(31,0)
 4792           P=P+2; SKIP EXP; ->Label1;            ! IGNORE SPURIOUS RESULT
 4793  SW(6):   ->Label601 %IF A(P+1)=2;           ! %MONITOR (SOMETHING)
 4794           %IF DIAGS1=1 %THEN PPJ(31); P=P+1
 4795           ->Label701 %IF A(P)=1; P=P+1; ->Label1
 4796  Label601:     PRX(X'41',0,0,0,A(P+2))
 4797           WARN(LINE)
 4798           PPJ(21); P=P+3; ->Label1
 4799  Label701:     WARN(LINE)
 4800  SW(7):                                 ! %STOP
 4801           PPJ(6); P=P+1; CURR INST=1 %IF CODE=0
 4802           REPORTUI=1; ->Label1
 4803  SW(8):                             ! %EXIT
 4804           CYC BITS=CYCBITS!2;          ! SET JUMP BIT
 4805           KK=FROM2(CYCLE(LEVEL))
 4806           %IF KK=-1 %THEN %START
 4807           FAULT(54,0) %UNLESS CSSMODE=0; ->Label1; %FINISH
 4808           REPLACE2(CYCLE(LEVEL),KK!X'80000000')
 4809           ENTER JUMP(MASK,KK>>16&X'7FFF',B'10')
 4810           REPORTUI=1 %IF MASK=15
 4811  Label1:       %END
 4812           %ROUTINE RT EXIT
 4813           {%SHORTROUTINE}
 4814  !***********************************************************************
 4815  !*       THIS ROUTINE COMPILES CODE FOR ROUTINE EXIT(IE '%RETURN')     *
 4816  !*       THE ONLY PROBLEM IS REGISTER VARIABLES WHICH ARE GLOBAL       *
 4817  !*       THE SAVE AREA MUST BE UPDATED TO PREVENT THE RETURN RESTORING *
 4818  !*       THE REGISTER VARIABLE TO ITS VALUE AT THE TIME OF THE CALL    *
 4819  !***********************************************************************
 4820           %INTEGER KK
 4821           PSS(X'D2',4,GLA,20,RBASE,0) %IF DIAGS1=1;! RESET DIAGS PTRS
 4822           %CYCLE KK=5,1,14;            ! CHECK FOR REGISTER VAR
 4823             %IF 0#UVARREG(KK)<LEVEL %AND(COMPILER=0 %OR NMDECS&X'FE'#0)%C
 4824+             %THEN PRX(X'50',KK,0,RBASE,KK<<2);  ! UPDATE CORE COPY
 4825           %REPEAT
 4826           PRX(X'98',4,15,RBASE,16);     ! LM OLD REGISTERS
 4827           PLANT(X'7FF')
 4828           %END
 4829           %ROUTINE CSTART(%INTEGER CODE)
 4830           {%SHORTROUTINE}
 4831           %INTEGER KK
 4832           SFLABEL=SFLABEL-1
 4833           FIND USE(KK,1,11,\SFLABEL)
 4834           %IF KK>0 %THEN FORGET(KK)  ;! FORGET MULT OF 4K FOR SFLAB
 4835           PUSH123(SBR(LEVEL),CODE,SFLABEL,CYCLE(LEVEL))
 4836           %END
 4837           %ROUTINE     TEXTOUT(%INTEGER REG)
 4838           {%SHORTROUTINE}
 4839  !***********************************************************************
 4840  !*      PLANT A JUMP ROUND THE TEXT WHICH IS PUT IN THE CODE.          *
 4841  !*       REG IS LEFT POINTING AT THE TEXT.                             *
 4842  !*        REG=0 IS SPECIAL CASE PRINTTEXT                              *
 4843  !***********************************************************************
 4844           %INTEGER KK,Q,L
 4845           L=A(P);                       ! NO OF CHARS IN TEXT
 4846           %IF REG=0 %THEN PPJ(30) %ELSE %START
 4847              SET LOCAL BASE
 4848              KK=(CA+6+L-LOCAL ADDR)&(-2)
 4849              PRX(X'45',REG,LOCAL BASE,0,KK);! BAL ROUND TEXT
 4850              FORGET(REG)
 4851           %FINISH
 4852           Q=ADDR(A(P))+1;                ! ADDR OF LENGTH BYTE
 4853           P=P+(L+3)>>1;                 ! P ON ROUND TEXT
 4854           %CYCLE KK=Q,2,Q+L>>1<<1
 4855              BYTE INTEGER(ADDR(J)+2)=BYTE INTEGER (KK)
 4856              BYTE INTEGER(ADDR(J)+3)=BYTE INTEGER (KK+1)
 4857              PLANT(J)
 4858           %REPEAT
 4859           %IF SBFLAG#0 %AND CA-CODEBASE>4096 %THEN FAULT(99,0)
 4860           %IF REG=0 %AND SBFLAG=0 %AND CA-CODEBASE>4095-MARGIN %C
 4861+                   %THEN SET USE(15,12,CA)
 4862           %END
 4863  
 4864           %ROUTINE     CSEXP(%INTEGER REG,MODE)
 4865           {%SHORTROUTINE}
 4866  !***********************************************************************
 4867  !*       COMPILE A SIGNED EXPRESSION TO REGISTER 'REG' IN MODE 'MODE'  *
 4868  !*       MODE=1 FOR %INTEGER, =2 REAL, =3 LONG,=0 INTEGER %IF POSSIBLE *
 4869  !*       MODE=5 FOR ADDRESS EXPRESSNS(IE LEAVE ANY CONSTANT IN 'ADISP')*
 4870  !***********************************************************************
 4871           %SHORTINTEGER EXPHEAD,NOPS,EXPBOT
 4872           %BYTEINTEGER ADDREXP
 4873           %INTEGER PP,BDISP,PPP
 4874           EXPHEAD=0; ADDREXP=0
 4875           NOPS=0; EXPBOT=0
 4876           ADDREXP=MODE>>2&1
 4877           P=P+2
 4878           TORP(EXPHEAD,EXPBOT,NOPS,MODE)
 4879           %IF EXPHEAD=0 %THEN NEST=0 %AND %RETURN;! EXPR  CONSTANT ONLY
 4880  !
 4881  ! MODE=13 IS A SPECIAL FOR THE BUILT IN MAPS. TO ALLOW INTEGER (ADDR(J)) 
 4882  ! TO BE COMPILE AS QUICKLY AS POSSIBLE IT LOOKS FOR 'ADDR'
 4883  ! AND USES CNAME TO OBTAIN 'BASE' & 'DISP' OF THE NAME AND RETURNS THESE
 4884  ! AS THE RESULT OMITTING THE 'LA' THAT ADDR USES INVOKES
 4885  !
 4886           %IF MODE=13 %AND NOPS=0 %AND CHECKSP=0 %THEN %START
 4887              FROM12(EXPHEAD,PP,BDISP)
 4888              %IF PP&255=2 %THEN %START;  ! ONLY OPERAND IS A NAME
 4889                 COPY TAG (A(BDISP))
 4890  !
 4891  ! CHECK THE NAME TO SEE IF IT IS OF THE FORM 'ADDR(<NAME><APP>)'
 4892  !
 4893                 %IF PTYPE=SNPT %AND K=14 %AND A(BDISP+1)=1 %AND %C
 4894+                   A(BDISP+4)=4 %AND A(BDISP+5)=1 %THEN %START
 4895                    PP=P; P=BDISP+6
 4896                    BDISP=ADISP; PPP=P
 4897                    CNAME(1,99);     ! SPECIAL SET 'BASE'&'DISP'
 4898                    FAULT(22,0) %UNLESS A(P)=2
 4899                    %IF BIMSTR#0 %THEN NOTE ASSMENT(-1,2,A(PPP))
 4900                    P=PP; DISP=DISP+BDISP
 4901                    CLEAR LIST(EXPHEAD)
 4902                    ADISP=0; NEST=-1
 4903                    %RETURN
 4904                 %FINISH
 4905              %FINISH
 4906           %FINISH
 4907  !
 4908           BDISP=ADISP
 4909           PP=P
 4910           EXPOP(EXPHEAD,REG,NOPS,MODE&7)
 4911           P=PP
 4912           ADISP=BDISP
 4913  !         CLEARLIST(EXPHEAD)
 4914           SHORTINTEGER(ADDR(ASLIST(EXPBOT))+14)=ASL
 4915           ASL=EXPHEAD
 4916           %END
 4917           %ROUTINE DSEXP(%INTEGER REG,MODE)
 4918           {%SHORTROUTINE}
 4919           %COMMENT COMPILES TWO INTEGER EXPRESSIONS TO REG & REG+1
 4920           %COMMENT REGISTERS LEFT CLAIMED
 4921           %SHORTINTEGER SRD
 4922           SRD=0
 4923           CSEXP(REG,1)
 4924           REGISTER(REG)=1
 4925           PUSH(SRD,1<<16!9!REG<<8,-2)
 4926           SET USE(REG,1,ADDR(ASLIST(SRD)))
 4927           P=P+MODE
 4928           CSEXP(REG+1,1)
 4929           REGISTER(REG+1)=1
 4930           EXPOP(SRD,REG,0,100)
 4931           REGISTER(REG)=1
 4932           GRINF(REG)=0
 4933           CLEAR LIST(SRD)
 4934           %END
 4935           %ROUTINE TORP(%SHORTINTEGERNAME HEAD,BOT,NOPS,%INTEGER MODE)
 4936  !***********************************************************************
 4937  !*       CONVERT THE SIGNED EXPRESSION INDEXED BY P INTO REVERSE       *
 4938  !*      POLISH NOTATION. THE REVERSE POLISH LIST IS ADDED TO 'HEAD'    *
 4939  !*      WHICH MAY CONTAIN ANOTHER EXPRESSION. THE NUMBER OF OPERATORS  *
 4940  !*      IS ADDED TO NOPS. MODE SIGNIFIES :-                            *
 4941  !*      MODE=1   INTEGER EXPRESSION                                    *
 4942  !*      MODE=2   SHORTREAL EXPRESSION                                  *
 4943  !*      MODE=3   LONGREAL EXPRESSION                                   *
 4944  !*      MODE=0   INTEGER IF POSIIBLE OTHERWISE REAL                    *
 4945  !*      N.B. AN INTEGER EXPRESSION IS A SPECIAL CASE OF A REAL EXPRSN  *
 4946  !***********************************************************************
 4947           {%SHORTROUTINE}
 4948           %SWITCH OPERAND(1:4)
 4949           %SHORTINTEGER ORHEAD,RPHEAD,PASSHEAD,SAVEHEAD,OPBOT, %C
 4950+             RPBOT,PASSBOT,SAVEBOT
 4951           %BYTEINTEGER REAL,LONGREAL,REALOP,COMPLEX
 4952           %INTEGER OPERATOR,LASTOP,OPPREC,OPND,C,D,E,RPTYPE,RPINF,RPXTRA
 4953           %BYTEINTEGER ADDREXP
 4954           %INTEGER BDISP,OPSTK,OPPSTK,RPNAM
 4955           %SHORTINTEGERNAME DUPHEAD,NEXTHEAD
 4956  !%if USE MC = 1 %start
 4957  !         *XC_ORHEAD(76),ORHEAD
 4958  !%finish
 4959           LONGREAL=ALL LONG ;           ! IN CASE INTEGER SUBXPRS
 4960           ADDREXP=MODE>>2&1
 4961           C=A(P)
 4962           %IF 2<=C<=3 %THEN %START;     ! INITIAL '-' OR '\'
 4963              NOPS=NOPS+1
 4964              OPSTK=13-C;               ! '-' =(11,3)   '\' =(10,5)
 4965              OPPSTK=C<<1-1
 4966           %FINISH
 4967  Label1:       OPND=A(P+1); P=P+2
 4968           COMPLEX=0
 4969           -> OPERAND(OPND);             ! SWITCH ON OPERAND
 4970  OPERAND(1):                            ! NAME
 4971           RPNAM=TAGS(A(P))
 4972           %IF RPNAM=0 %THEN PTYPE=7 %ELSE %C
 4973+             PTYPE=INTEGER(ADDR(ASLIST(RPNAM)))>>16
 4974  !%if USE MC = 1 %start
 4975  !         *L_1,PTYPE; *CVD_1,0(11);      ! UNPACK
 4976  !         *UNPK_ROUT(5),5(3,11)
 4977  !         *NC_ROUT(5),MASK1
 4978  !%finish
 4979           %IF TYPE=8 %THEN COMPLEX=FROM3(RPNAM)>>16
 4980           %IF PTYPE=SNPT %THEN %START
 4981              K=FROM3(RPNAM)>>16
 4982               %IF K=38 %AND A(P+1)=2 %THEN %START;    ! PICK OFF NL
 4983                  RPTYPE=0; RPINF=10; PTYPE=1; P=P+1; ->SKNAM
 4984               %FINISH
 4985              %IF K=52 %AND A(P+1)=2 %START;! PICK OFF PI
 4986                 RPTYPE=1; PTYPE=2; RPINF=-7
 4987                 P=P+1; REAL=1; ->SKNAM
 4988              %FINISH
 4989              COMPLEX=1;                  ! FOR INTEGER(ADDR(A(I)))
 4990               PTYPE=TSNAME(K);! UNPACK
 4991  !%if USE MC = 1 %start
 4992  !            *L_1,PTYPE; *CVD_1,0(11)
 4993  !            *UNPK_ROUT(5),5(3,11)
 4994  !            *NC_ROUT(5),MASK1
 4995  !%finish
 4996           %FINISH
 4997           %IF ROUT=1 %THEN COMPLEX=1
 4998           %IF ARR>=1 %AND CHECKS=1 %THEN COMPLEX=1
 4999           %IF TYPE=3 %THEN %START
 5000              KFORM=FROM3(RPNAM)&X'FFFF'
 5001              D=P; C=COPY RECORD TAG(E); P=D;
 5002              %IF (ARR>=1 %OR E>1) %AND CHECKS=1 %THEN COMPLEX=1
 5003           %FINISH
 5004           %IF TYPE=5 %THEN FAULT(42,0)
 5005           %IF TYPE=2 %THEN %START
 5006              REAL=1; LONGREAL=1 %IF PREC=3
 5007           %FINISH
 5008           RPTYPE=2; RPINF=P; PTYPE=1 %IF PTYPE=7
 5009           RPTYPE=0 %AND PTYPE=1 %IF TYPE=5;   ! CHANGE TO SHORT CONST
 5010           P=P+1
 5011  SKNAM:   FFLAG=0
 5012           %CYCLE
 5013              %IF A(P)=2 %THEN P=P+1 %ELSE SKIP APP
 5014              C=A(P); P=P+2
 5015           %REPEAT %UNTIL C=2
 5016           %IF FFLAG#0 %THEN COMPLEX=1
 5017  INS:     BINSERT(RPHEAD,RPBOT,PTYPE<<16!COMPLEX<<8!RPTYPE,RPINF,0)
 5018           ->Label50 %UNLESS OPND=2
 5019           %IF A(P-1)=2 %THEN P=P+1 %AND ->Label50
 5020           WARN(LINE)
 5021           P=P-2; OPERATOR=6; ->Label49
 5022  OPERAND(2):                            ! CONSTANT
 5023           C=A(P)&7; RPINF=P
 5024           %IF C=2 %THEN %START;         ! REAL CONSTANT
 5025              PTYPE=2; P=P+6
 5026              REAL=1; RPTYPE=1
 5027           %FINISH %ELSE %START
 5028              %IF C=5 %THEN %START;      ! STRING CONSTANT
 5029                 FAULT(42,0); D=1
 5030                 P=P+(A(P+1)-1)>>1
 5031              %FINISH %ELSE %START
 5032  !%if USE MC = 1 %start
 5033  !               **1,P; *AR_1,1
 5034  !               *LA_1,A+32(1); *MVC_D(4),0(1)
 5035  !%finish
 5036              %FINISH
 5037              %IF D>>12=0 %THEN RPTYPE=0 %AND RPINF=D %ELSE RPTYPE=1
 5038              P=P+4; PTYPE=1
 5039           %FINISH; -> INS
 5040  OPERAND(4):                            ! MODULUS SIGNS
 5041           WARN(LINE)
 5042  OPERAND(3):                            ! SUB EXPRESSION
 5043           D=0; PASSHEAD=0; PASSBOT=0
 5044           D=1 %IF MODE&3=1 %OR LASTOP=12
 5045           P=P+2
 5046           TORP(PASSHEAD,PASSBOT,NOPS,D)
 5047           REAL=1 %IF TYPE=2
 5048           LONGREAL=1 %IF PREC=3
 5049           BINSERT(RPHEAD,RPBOT,PTYPE<<16!3,PASSHEAD,PASSBOT)
 5050           %IF OPND=4 %THEN BINSERT(RPHEAD,RPBOT,13,0,0) %AND NOPS=NOPS+1
 5051           P=P+1
 5052  Label50:      %COMMENT DEAL WITH OPERATOR
 5053           ->Label60 %IF A(P-1)=2;           ! EXPR FINISHED
 5054           OPERATOR=A(P)
 5055  !
 5056  ! THE STRING OPERATOR '.' CAUSES CHAOS IN AN ARITHMETIC EXPRSN
 5057  ! SO FAULT IT AND CHANGE IT TO THE INNOCUOUS '+'
 5058  !
 5059           %IF OPERATOR=12 %THEN FAULT(42,0) %AND OPERATOR=2
 5060           REALOP=1 %IF OPERATOR=1 %OR OPERATOR=8
 5061           OPERATOR=12 %IF OPERATOR=1
 5062  Label49:      LASTOP=OPERATOR
 5063           OPPREC=PRECEDENCE(OPERATOR)
 5064           OPERATOR=OPERATOR+13
 5065           NOPS=NOPS+1
 5066  !
 5067  ! UNLOAD THE OPERATOR STACK OF ALL OPERATORS WHOSE PRECEDENCE IS
 5068  ! NOT LOWER THAN THE CURRENT OPERATOR. AN EMPTY STACK GIVES'-1'
 5069  ! AS PRECEDENCE.
 5070  !
 5071           %WHILE OPPREC<=OPPSTK&31 %CYCLE
 5072              BINSERT(RPHEAD,RPBOT,OPSTK&31,0,0)
 5073              OPSTK=OPSTK>>5; OPPSTK=OPPSTK>>5
 5074           %REPEAT
 5075  !
 5076  ! THE CURRENT OPERATOR CAN NOW BE STORED
 5077  !
 5078           OPSTK=OPSTK<<5!OPERATOR
 5079           OPPSTK=OPPSTK<<5!OPPREC
 5080           ->Label1
 5081  Label60:                                    ! END OF EXPRESSION
 5082           %WHILE OPSTK#0 %CYCLE
 5083              BINSERT(RPHEAD,RPBOT,OPSTK&31,0,0)
 5084              OPSTK=OPSTK>>5
 5085           %REPEAT
 5086           REAL=1 %IF MODE&3#1 %AND REALOP=1
 5087           LONGREAL=1 %IF MODE=3
 5088           FAULT(24,0) %IF REAL=1 %AND MODE&3=1
 5089  !
 5090  ! NOW THE TYPE OF THE EXPRESSION IS KNOWN WE CAN ADD FLOAT &STRETCH
 5091  ! OPERATORS AS NECESSARY. ALSO TAKE THE OPPORTUNITY TO REMOVE
 5092  ! CONSTANTS FROM ADDRESS EXPRESSIONS.
 5093  !
 5094           DUPHEAD==RPHEAD
 5095           %WHILE DUPHEAD#0 %CYCLE
 5096              C=INTEGER(ADDR(ASLIST(DUPHEAD)))
 5097              NEXTHEAD==SHORTINTEGER(ADDR(ASLIST(DUPHEAD))+14)
 5098              RPTYPE=C&255
 5099              %IF ADDREXP=1 %AND RPTYPE=0 %AND FROM2(DUPHEAD)+BDISP<256%C
 5100+                 %AND (NOPS=0 %OR FROM1(NEXTHEAD)&255=15) %START;! CHECK FOR +CONST
 5101                 POP(DUPHEAD,D,RPINF)
 5102                 BDISP=BDISP+RPINF
 5103                 %IF NOPS#0 %THEN POP(DUPHEAD,D,D) %AND NOPS=NOPS-1
 5104                 NEXTHEAD==DUPHEAD
 5105                 %IF DUPHEAD=0 %START
 5106                    RPBOT=RPHEAD
 5107                    %WHILE SHORTINTEGER(ADDR(ASLIST(RPBOT))+14)#0 %THENC
 5108+                      RPBOT=SHORTINTEGER(ADDR(ASLIST(RPBOT))+14)
 5109                 %FINISH
 5110              %FINISH %ELSE %START
 5111                %IF RPTYPE=1 %AND C>>16=2 %AND LONGREAL=1 %THEN %C
 5112+                C=32<<16!1 %AND REPLACE1(DUPHEAD,C)
 5113                 %IF RPTYPE=3 %THEN %START
 5114                    POP123(DUPHEAD,C,RPINF,RPXTRA);! CHUCK AWAY HEADCELL
 5115                    D=DUPHEAD;            ! REPLACE BY SUBEXPRESSION
 5116                    DUPHEAD=RPINF
 5117                    NEXTHEAD==SHORTINTEGER(ADDR(ASLIST(RPXTRA))+14)
 5118                    NEXTHEAD=D
 5119                    %IF D=0 %THEN RPBOT=RPXTRA
 5120                 %FINISH
 5121                 %IF RPTYPE<10 %AND REAL#0 %THEN %START
 5122                    D=0; PTYPE=C>>16;! UNPACK
 5123  !%if USE MC = 1 %start
 5124  !                  *L_1,PTYPE; *CVD_1,0(11)
 5125  !                  *UNPK_ROUT(5),5(3,11)
 5126  !                  *NC_ROUT(5),MASK1
 5127  !%finish
 5128                    %IF (TYPE=1 %OR TYPE=8) %AND FROM1(NEXTHEAD)&255#25%C
 5129+                       %THEN D=12
 5130                    %IF TYPE=2 %AND PREC=0 %AND LONGREAL=1 %THEN D=14
 5131                    %IF D#0 %THEN %START;      ! FLOAT OR STRETCH REQD
 5132                       NOPS=NOPS+1
 5133                       PUSH(NEXTHEAD,D,LONGREAL)
 5134                       NEXTHEAD==SHORTINTEGER(ADDR(ASLIST(NEXTHEAD))+14)
 5135                    %FINISH
 5136                 %FINISH
 5137              %FINISH
 5138              DUPHEAD==NEXTHEAD
 5139           %REPEAT
 5140           %IF MODE&3>=2 %AND REAL=0 %THEN %START
 5141              REAL=1; NOPS=NOPS+1
 5142              BINSERT(RPHEAD,RPBOT,12,LONGREAL,0);! FLT RESULT(IF REQD)
 5143           %FINISH
 5144           PTYPE=1+REAL+30*LONGREAL
 5145           %IF HEAD=0 %THEN BOT=RPBOT %ELSE %C
 5146+             SHORTINTEGER(ADDR(ASLIST(RPBOT))+14)=HEAD
 5147           HEAD=RPHEAD;               ! HEAD BACK TO TOP OF LIST
 5148          ! UNPACK
 5149  !%if USE MC = 1 %start
 5150  !            *L_1,PTYPE; *CVD_1,0(11)
 5151  !            *UNPK_ROUT(5),5(3,11)
 5152  !            *NC_ROUT(5),MASK1
 5153  !%finish
 5154           ADISP=BDISP
 5155           %END
?SAVEBOT unused
?OPBOT unused
?SAVEHEAD unused
?ORHEAD unused
 5156           %ROUTINE EXPOP(%INTEGER INHEAD,REG,NOPS,MODE)
 5157           %INTEGERARRAY OPERAND(1:2),STK(0:24)
 5158           %BYTEINTEGER ADDREXP,RDFORM
 5159           %RECORD(RD)%NAME OPND1,OPND2
 5160           %INTEGER C,D,E,KK,JJ,OPCODE,COMM,XTRA,STPTR
 5161           %INTEGER NEWCC,PP,PT,JJJ
 5162           %INTEGER SPECREG; SPECREG=REG
 5163           %ROUTINESPEC FLOAT
 5164           %ROUTINESPEC CTOP(%INTEGERNAME A)
 5165           %ROUTINESPEC CHOOSE(%INTEGERNAME I)
 5166           %INTEGERFNSPEC FINDR
 5167           %ROUTINESPEC CLAIM PAIR(%INTEGERNAME REG)
 5168           %ROUTINESPEC PUT
 5169           %ROUTINESPEC STARSTAR
 5170           %ROUTINESPEC UNRESERVE(%INTEGER XB)
 5171           %ROUTINESPEC LOAD PAIR(%INTEGER I)
 5172           %ROUTINESPEC LOAD(%RECORD(RD)%NAME OP,%INTEGER REG,MODE)
 5173           %CONSTSHORTINTEGERARRAY MCINST(10:31)=X'297',X'193',
 5174+                X'80',X'190',X'81',X'11A',X'19B',X'217',
 5175+                X'216',X'1C',X'9D',X'9D',X'214',X'88',X'89',
 5176+                X'84',X'19',X'19',X'9C',X'89',X'90',X'90'
 5177           %SHORTINTEGER TEMPHEAD
 5178           %SWITCH SW(10:31)
 5179           %IF INHEAD=0 %THEN %START
 5180              NEST=0; %RETURN
 5181           %FINISH
 5182           RDFORM= MODE&16
 5183           NEWCC=0; STPTR=0
 5184           ADDREXP=MODE>>2&1
 5185  Label1:       C=INTEGER(ADDR(ASLIST(INHEAD)))
 5186           JJ=C&255; D=INHEAD
 5187           INHEAD=SHORTINTEGER(ADDR(ASLIST(D))+14)
 5188           %IF JJ>=10 %THEN XTRA=INTEGER(ADDR(ASLIST(D))+4) %AND %C
 5189+             ->OPERATOR
 5190           STK(STPTR)=D
 5191           STPTR=STPTR+1
 5192  Label2:
 5193           ->Label1 %UNLESS INHEAD=0 %OR MODE=100
 5194           -> FINISH
 5195  OPERATOR:
 5196           %IF JJ<15 %THEN KK=1 %ELSE KK=2; ! UNARY OR BINARY
 5197           %CYCLE KK=KK,-1,1
 5198              STPTR=STPTR-1
 5199              C=STK(STPTR)
 5200              OPERAND(KK)=C
 5201           %REPEAT
 5202  !         PTYPE=FROM1(C)>>16
 5203          ! UNPACK;                       ! SET PREC ETC.
 5204  !%if USE MC = 1 %start
 5205  !            *L_1,C; *A_1,ASLIST
 5206  !            *LH_1,0(1)
 5207  !            *ST_1,PTYPE; *CVD_1,0(11)
 5208  !            *UNPK_ROUT(5),5(3,11)
 5209  !            *NC_ROUT(5),MASK1
 5210  !%finish
 5211           OPCODE=MCINST(JJ)
 5212           COMM=OPCODE>>7&1;              ! BIT SET IF OPERATOR UNCOMMUTVE
 5213           NEWCC=OPCODE>>8;               ! 0=CC UNKNOWN- 1= CC SRITHMETIC
 5214                                          ! 2= CC LOGICAL AFTER OPERATION
 5215           OPCODE=OPCODE&63;             ! OPCODE FOR INTEGER RR INST
 5216           %IF COMM=0 %THEN CHOOSE(COMM)
 5217           OPND1 == RECORD(ADDR(ASLIST(OPERAND(COMM))))
 5218           OPND2== OPND1
 5219           %IF JJ>=15 %THEN OPND2==RECORD(ADDR(ASLIST(OPERAND(3-COMM))))
 5220           %IF OPND1_FLAG<2> OPND2_FLAG %THEN CTOP(JJ)
 5221           ->Label101 %IF JJ=0;              ! CTOP CARRIED OUT
 5222           TYPE=1 %IF TYPE=8
 5223           -> SW(JJ)
 5224  SW(10):                                !  \
 5225           LOAD(OPND1,-1,2)
 5226           FAULT(24,0) %UNLESS TYPE=1
 5227           PRX(X'57',OPND1_XB,0,GLA,16)
 5228  Label100:     SET USE((TYPE&2)<<3+OPND1_XB,1,ADDR(ASLIST(OPERAND(COMM))))
 5229  Label101:     STK(STPTR)=OPERAND(COMM)
 5230           STPTR=STPTR+1
 5231           %IF NEWCC#0 %THEN CCSTATE=NEWCC<<16!(TYPE&2)<<3!OPND1_XB
 5232           ->Label2;                            ! SAVE CONDITION CODE STATE
 5233  SW(11): SW(13):                        ! NEGATE: ABS
 5234           LOAD(OPND1,-1,2)
 5235           TEMPHEAD=0
 5236           %IF NOPS=1 %AND REG>=0 %THEN %START
 5237              PUSH(TEMPHEAD,INTEGER(ADDR(OPND1)),OPND1_D)
 5238              OPND2== RECORD(ADDR(ASLIST(TEMPHEAD)))
 5239              OPND1_XB=REG
 5240           %FINISH
 5241           PUT
 5242           CLEAR LIST(TEMPHEAD) %IF TEMPHEAD#0
 5243           ->Label101
 5244  SW(12):                                ! FLOAT
 5245           LOAD(OPND1,-1,0);                 ! LEAVE IN CORE
 5246           FLOAT
 5247           TYPE=2; OPND1_FLAG=9
 5248           OPND1_XB=D; OPND1_D=-2
 5249           OPND1_PTYPE=30*XTRA+2;  ->Label100
 5250  SW(14):                                ! STRETCH
 5251           LOAD(OPND1,-1,1)
 5252           CLAIM (FR0,D); PRR(X'2B',D,D)
 5253           CCSTATE=-1
 5254           FORGET(D+16)
 5255           LOAD(OPND1,D,2)
 5256           OPND1_PTYPE=32; ->Label100
 5257  SW(15):                                ! ADD
 5258  Label151:     LOAD(OPND1,-1,0) %UNLESS OPND1_FLAG<=2 %C
 5259+                   %AND OPND1_XB=0 %AND OPND1_PTYPE<100
 5260           LOAD(OPND2,-1,1)
 5261           LOAD(OPND1,-1,2)%UNLESS OPND1_FLAG=9 %AND OPND1_D<0;! IN CASE RT CALL
 5262           PUT; ->Label101
 5263  SW(16):                                ! SUBTRACT
 5264           ->Label151%UNLESS(TYPE=1 %OR TYPE=8)%AND OPND2_FLAG=0 %AND OPND2_D=1
 5265           LOAD(OPND1,-1,2)
 5266           PRR(6,OPND1_XB,0);            ! BCTR
 5267           NEWCC=0; ->Label100;               ! BCTR DOES NOT SET CC
 5268  SW(17):                                ! EXCLUSIVE OR
 5269  SW(18):                                ! OR
 5270  SW(22):                                ! AND
 5271           ->Label151 %IF TYPE=1
 5272  F24:         FAULT(24,0)
 5273           JJ=15; OPCODE=X'1A'; ->Label151; ! CHANGE OPN TO +
 5274  SW(23):                                ! SRL
 5275  SW(24):                                ! SLL
 5276           ->F24 %UNLESS TYPE=1
 5277            D=0; D=1 %IF OPND2_FLAG=0
 5278           LOAD(OPND1,-1,D<<1);              ! MUST LOAD %IF CONST
 5279           %IF D=0 %THEN %START
 5280  ! DIFFICULT AS MAY SHIFT BY A FN AND CANNOT SHIFT BY GR0
 5281           LOAD(OPND2,-2,0)          ;! INSPECT SHIFTER
 5282           LOAD(OPND1,-1,2);     ! LOAD UP SHIFTED TO ANY REGISTER
 5283           LOAD(OPND2,-2,1)
 5284           %UNLESS OPND2_FLAG=9 %AND OPND2_D<0 %AND OPND2_XB>0 %THENSTART
 5285           FIND REG(GR1,C);       ! REG TO SHIFT BY (NOT GR0 !)
 5286           LOAD(OPND2,C,2); %FINISH;  ! LOAD SHIFTER ( OR MOVE OUT OF GR0)
 5287           %FINISH;               ! CA NOW PLANT THE OPERATION
 5288           PRX(X'80'+OPCODE,OPND1_XB,0,OPND2_XB,D*OPND2_D)
 5289           REGISTER(OPND2_XB)=0 %IF D=0 %AND REGISTER(OPND2_XB)>=0
 5290           ->Label100
 5291  SW(19):                                ! MULT
 5292           ->Label151 %IF TYPE=2
 5293           LOAD PAIR(1);                 ! 1ST OPERAND TO ODD MEMBER
 5294                                         ! 2ND OPERAND TESTED ALSO
 5295           PUT
 5296           D=OPND1_XB+CHECKSP
 5297           REGISTER(D)=0; FORGET(D)
 5298           %IF CHECKSP#0 %THEN %START
 5299           PRX(X'8F',OPND1_XB,0,0,32)
 5300           %FINISH %ELSE OPND1_XB=OPND1_XB+1
 5301           ->Label100
 5302  SW(20):                                ! INTEGER DIVISION
 5303           ->F24 %UNLESS TYPE=1
 5304           ->Label211
 5305  SW(21):                                ! NORMAL DIVISION
 5306           ->Label151 %IF TYPE=2
 5307           WARN(LINE)
 5308  Label211:     LOAD PAIR(0);                 ! 1ST OPERAND TO EVEN REG
 5309           PRX(X'8E',OPND1_XB,0,0,32);   ! SRDA
 5310           CCSTATE=-1
 5311           PUT; D=OPND1_XB
 5312           %IF CHECKSP=1 %AND JJ=21 %THEN %START
 5313           PRR(X'12',D,D)
 5314           PCONST(X'4770C040'); %FINISH
 5315           REGISTER(D)=0; FORGET(D)
 5316           OPND1_XB=D+1; ->Label100
 5317  SW(25):                                ! EXP
 5318           STARSTAR; ->Label100
 5319  SW(26):                                ! COMPARISONS
 5320  SW(27):                                ! LOGICAL COMPARISONS (IE=&7=)
 5321           PTYPE=OPND1_PTYPE;! UNPACK
 5322  !%if USE MC = 1 %start
 5323  !            *L_1,PTYPE; *CVD_1,0(11)
 5324  !            *UNPK_ROUT(5),5(3,11)
 5325  !            *NC_ROUT(5),MASK1
 5326  !%finish
 5327           -> BC %IF PREC=1 %AND OPND2_FLAG=0
 5328           LOAD(OPND1,-1,0) %UNLESS OPND1_FLAG<=2 %AND ARR=0=OPND1_XB
 5329  CNORM:
 5330           ->Z1 %IF OPND1_FLAG=0=OPND1_D %ORC
 5331+          (OPND1_FLAG=9 %AND OPND1_XB=CODER %AND OPND1_D=X'C0')
 5332           -> Z2 %IF OPND2_FLAG=0=OPND2_D %ORC
 5333+          (OPND2_FLAG=9 %AND OPND2_XB=CODER %AND OPND2_D=X'C0')
 5334           -> RX %UNLESS JJ=27 %OR PREC=1
 5335           LOAD(OPND2,-1,3) %IF OPND2_FLAG<7;! IN CASE BOTH OPERANDS ARE FNS
 5336           LOAD(OPND1,-1,3) %IF OPND1_FLAG<7
 5337           -> RX %UNLESS OPND1_PTYPE=OPND2_PTYPE %AND 0<=OPND1_D<=4095 %C
 5338+          %AND 0<=OPND2_D<=4095 %AND OPND1_XB<16>OPND2_XB
 5339           CCSTATE=-1
 5340           PSS(X'D5',BYTES(PREC),OPND1_XB,OPND1_D,OPND2_XB,OPND2_D)
 5341           UNRESERVE(OPND2_XB)
 5342  Z5:      UNRESERVE(OPND1_XB); ->Z4
 5343  RX:      LOAD(OPND2,-1,1)
 5344           LOAD(OPND1,-1,2)
 5345           CCSTATE=-1
 5346           PUT
 5347  Z4:
 5348           BFFLAG=COMM-1;                ! NOTE BACKWARDS OR FORWARDS
 5349           COMM=2; ->Label101;               ! 2ND OPERAND MAY BE NEEDED IN
 5350                                         ! DOUBLE SIDED AND IS THEREFORE
 5351                                         ! TAKEN AS THE 'RESULT'
 5352  Z1:      COMM=3-COMM;                  ! SWITCH AROUND OPERANDS
 5353           OPND1==OPND2
 5354           OPND2==RECORD(ADDR(ASLIST(OPERAND(3-COMM))))
 5355  Z2:
 5356           LOAD(OPND1,-1,2)
 5357           D=FROM1(OPERAND(COMM))>>8&15
 5358           C=(TYPE&2)<<3+D
 5359           REGISTER(C)=0 %IF REGISTER(C)>0
 5360           -> Z4 %IF 1<<16!C=CCSTATE;      ! CONDITION CODE ALREADY SET
 5361           ->Z4 %IF JJ=27 %AND 2<<16!C=CCSTATE;! CC WILL DO
 5362           PRR((TYPE-1)*(2-PREC>>1)*16+X'12',D,D)
 5363           CCSTATE=1<<16!C; ->Z4
 5364  BC:                                    ! BYTE/CONSTANT COMPARISONS
 5365           LOAD(OPND1,-1,3)
 5366           -> CNORM %UNLESS OPND1_PTYPE=11 %AND %C
 5367+          0<=OPND1_D<=4095 %AND OPND2_D<=255
 5368           NEST=OPND1_XB; D=NEST>>4; NEST=NEST&15
 5369           %IF D>0 %THEN %START
 5370           %IF 1#REGISTER(D)>=0 %AND GRUSE(D)<=1 %THENC
 5371+          NEST=D %ELSE NEST=-2; UNRESERVE(OPND1_XB)
 5372           DUMP(0,NEST,0,D,OPND1_XB&15); OPND1_XB=NEST;
 5373           FORGET(NEST); %FINISH
 5374           PSI(X'95',OPND2_D,NEST,OPND1_D)
 5375           CCSTATE=-1; -> Z5
 5376  SW(28):                                ! SPECIAL MH FOR ARRAY ACCESS
 5377           %IF OPND1_FLAG=2 %AND OPND2_FLAG=0 %AND OPND2_D<=255%THENSTART
 5378              E=OPND1_D; D=TAGS(A(E))
 5379              FIND USE(C,1,9,OPND2_D<<24!D)
 5380              %IF C>0 %AND A(E+1)=2=A(E+2) %START
 5381                 OPND1_FLAG=9; OPND1_XB=C; OPND1_D=-2; ->Label101
 5382              %FINISH
 5383           %FINISH
 5384           LOAD(OPND1,-1,2);                 ! LOAD TO ANY REGISTER
 5385           ->Label2801 %IF OPND2_FLAG=0;      ! CONSTANT SO OPTIMISE
 5386           LOAD(OPND2,-1,3);                 ! LOAD DV POINTER
 5387           LOAD(OPND1,-1,2);                  ! LOAD OF DVBASE MAY DUMP OPND!
 5388           PUT; ->Label100
 5389  Label2801:    D=OPND2_D; C=OPND1_XB
 5390           %IF D=2 %THEN PRR(X'1A',C,C)  %AND CCSTATE=-1 %ELSE %START
 5391           %IF D=4 %OR D=8 %THEN PRX(X'89',C,0,0,2!D>>3) %ELSESTART
 5392           STORE CONST(KK,JJ,2,ADDR(D)+2)
 5393           DUMP(X'4C',C,JJ,0,KK)
 5394           %FINISH; %FINISH
 5395           REGISTER(C)=0
 5396           %IF GRUSE(C)#3 %OR D>255 %THEN ->Label100
 5397           SET USE(C,9,D<<24!GRINF(C)); ->Label101
 5398  
 5399  SW(29):                                   ! ->LAB MASKS AND LAB AS OPND2
 5400                                            ! OPND1 MIDDLE OF D-SIDED
 5401           LOAD(OPND1,-1,0) %IF INHEAD#0;       ! PROTECT MIDDLE OPND IN DSIDED
 5402           C=OPND2_XB>>(4*BFFLAG)
 5403           ENTER JUMP(C&15,OPND2_D,B'11')
 5404           ->Label101;                           ! RETURN MIDDLE OPND AS RESULT
 5405  SW(30):                                   ! ASSIGN(=)
 5406  SW(31):                                   ! ASSIGN(<-)
 5407           PP=OPND2_D;                      ! SAVE POINTER TO NAME
 5408           PT=OPND2_PTYPE;                  ! AND ITS ORIGINAL PTYPE
 5409           D=OPND2_FLAG;                    ! SAVE NAME OR R-DESCRPTOR
 5410           LOAD(OPND1,-1,0) %UNLESS OPND1_FLAG<=2 %AND OPND1_XB=0 %C
 5411+                %AND OPND1_PTYPE<100;   ! DEAL WITH NASTY RH SIDES
 5412           LOAD(OPND2,-1,4);                    ! GET ADDRESS FOR LHS
 5413           ->MVI %IF TYPE=1 %AND PREC=1 %AND OPND1_FLAG=0 %AND %C
 5414+             OPND1_D<=255 %AND OPND2_XB<16 %AND OPND2_D<=4095
 5415           %IF OPND1_FLAG#0 %AND OPND2_XB<16 %AND 0<=OPND2_D<=4095 %C
 5416+             %AND OPND2_PTYPE=OPND1_PTYPE-100*(OPND1_PTYPE//100) %START
 5417              LOAD(OPND1,-1,3) %IF OPND1_FLAG<7;! STILL TRYING TO LEAVE RHS
 5418           ->MVC %IF OPND2_PTYPE=OPND1_PTYPE %AND  %C
 5419+           0<=OPND1_D<=4095 %AND 16>OPND1_XB
 5420           %FINISH
 5421  ! ALL ATTEMPTS AT SHORT CUTTING HAVE FAILED SO ASSIGN NORMALLY
 5422  ! IF LHS ALREADY IN A REGISTER IT IS BEST TO USE THAT REGISTER
 5423  ! FOR ASSIGNMENT(UNLESS RHS ALREADY IN A DIFFERENT REGISTER).
 5424  ! THIS SAVES A REGISTER WHEN COMPILING 'K=0 %IF K<0' ETC.
 5425  ! IT IS RATHER A TEDIOUS SEARCH SO IT IS OMITTED IN NON OPTIMISING MODE
 5426           JJJ=-1
 5427           %IF CHECKSP=0 %AND OPND1_D>=0 %AND PT<3 %AND D=2 %THENSTART
 5428              C=TAGS(A(PP));                   ! TAGS OF LHS
 5429              FIND USE(KK,PT,3,C)
 5430              %IF KK>=0 %AND REGISTER(KK)=0 %THEN JJJ=KK&15
 5431           %FINISH
 5432           LOAD(OPND1,JJJ,2);                   ! RHS TO REGISTER
 5433           PTYPE=OPND2_PTYPE;! UNPACK;       ! SET TYPE & PREC FOR LHS
 5434  !%if USE MC = 1 %start
 5435  !            *L_1,PTYPE; *CVD_1,0(11)
 5436  !            *UNPK_ROUT(5),5(3,11)
 5437  !            *NC_ROUT(5),MASK1
 5438  !%finish
 5439           JJJ=8*TYPE+2*(PREC&3)-7;         ! CODE FOR DUMP
 5440           DUMP(JJJ,OPND1_XB,OPND2_D,OPND2_XB>>4,OPND2_XB&15)
 5441           %IF JJ=30 %AND CHECKS=1 %THEN %C
 5442+          CHECK CAPACITY(OPND1_XB,OPND2_D,OPND2_XB>>4,OPND2_XB&15)
 5443           JJJ=OPND1_XB
 5444  NASS1:   UNRESERVE(OPND2_XB)
 5445           PTYPE=PT;! UNPACK;                ! ORIGINAL PTYPE
 5446  !%if USE MC = 1 %start
 5447  !            *L_1,PTYPE; *CVD_1,0(11)
 5448  !            *UNPK_ROUT(5),5(3,11)
 5449  !            *NC_ROUT(5),MASK1
 5450  !%finish
 5451           COMM=1; ->Label101 %UNLESS D=2;       ! ASSGN TO NAME ONLY
 5452           %IF 1<=TYPE<=2 %AND ARR=0 %AND A(PP+1)=2=A(PP+2) %THEN %C
 5453+          NOTE ASSMENT(JJJ,JJ-28,A(PP))
 5454           ->Label101;                           ! NORMAL EXIT FREES REG USED
 5455  
 5456  MVI:                                      ! ASSIGN CNST(<256) TO BYTE
 5457           PSI(X'92',OPND1_D,OPND2_XB,OPND2_D)
 5458  NASS2:   JJJ=-1; ->NASS1;                 ! ->NOTE ASSMENT(CAPACITY OK)
 5459  MVC:     PMVC(BYTES(PREC),OPND2_XB,OPND2_D,OPND1_XB,OPND1_D)
 5460           UNRESERVE(OPND1_XB)
 5461           ->NASS2
 5462  FINISH:  C=STK(STPTR-1)
 5463           OPERAND(1)=C
 5464           OPND1==RECORD(ADDR(ASLIST(C)))
 5465           LOAD(OPND1,REG,2) %UNLESS RDFORM#0 %OR (OPND1_FLAG=9 %AND %C
 5466+             OPND1_D<0 %AND (REG<0 %OR REG=OPND1_XB))
 5467           PTYPE=OPND1_PTYPE
 5468           NEST=-1
 5469          ! UNPACK
 5470  !%if USE MC = 1 %start
 5471  !            *L_1,PTYPE; *CVD_1,0(11)
 5472  !            *UNPK_ROUT(5),5(3,11)
 5473  !            *NC_ROUT(5),MASK1
 5474  !%finish
 5475           %IF OPND1_FLAG=9 %AND OPND1_D<0 %THEN %START
 5476              NEST=OPND1_XB
 5477              %IF TYPE=2 %THEN NEST=NEST+16
 5478              %IF GRUSE(NEST)=1 %THEN GRINF(NEST)=0;! DONT POINT AT DEAD LIST
 5479              NEST=OPND1_XB
 5480              %IF NEST=0 %AND ADDREXP=1 %THEN %START
 5481                 LOAD(OPND1,FINDR,2)
 5482                 FORGET(0)
 5483                 NEST=OPND1_XB
 5484              %FINISH
 5485              D=NEST+(TYPE&2)<<3
 5486              REGISTER(D)=0 %IF REGISTER(D)>0
 5487           %FINISH
 5488           %RETURN
 5489  !
 5490           %INTEGERFN FINDR
 5491           %INTEGER I,J
 5492           {%SHORTROUTINE}
 5493           %IF REG>=0 %THEN %START
 5494           I=REG; ->Label1 %IF REGISTER(REG)=0; %FINISH
 5495           %IF ADDREXP=1 %THEN J=GR1 %ELSE J=GR0
 5496           FIND REG(J,I)
 5497  Label1:       REGISTER(I)=1;
 5498           %RESULT=I
 5499           %END
 5500           %ROUTINE CHOOSE(%INTEGERNAME CHOICE)
 5501           {%SHORTROUTINE}
 5502          %BYTEINTEGER X1,X2,F1,F2
 5503           %RECORD(RD)%NAME OPND1,OPND2
 5504           OPND1==RECORD(ADDR(ASLIST(OPERAND(1))))
 5505           OPND2==RECORD(ADDR(ASLIST(OPERAND(2))))
 5506           F1=OPND1_FLAG; F2=OPND2_FLAG
 5507           X1=OPND1_XB; X2=OPND2_XB
 5508           -> CHOS1 %IF F1=2 %AND (X1=1 %OR 1<X1=SPECREG)
 5509           -> CHOS2 %IF F2=2 %AND (X2=1 %OR 1<X2=SPECREG)
 5510           -> CHOS0 %IF F1>=7 %AND OPND1_D<0
 5511           -> CHOS2 %IF F2>=7 %AND OPND2_D<0
 5512           PTYPE=OPND1_PTYPE;! UNPACK
 5513  !%if USE MC = 1 %start
 5514  !            *L_1,PTYPE; *CVD_1,0(11)
 5515  !            *UNPK_ROUT(5),5(3,11)
 5516  !            *NC_ROUT(5),MASK1
 5517  !%finish
 5518           -> CHOS1 %IF PREC=1
 5519           PTYPE=OPND2_PTYPE;! UNPACK
 5520  !%if USE MC = 1 %start
 5521  !            *L_1,PTYPE; *CVD_1,0(11)
 5522  !            *UNPK_ROUT(5),5(3,11)
 5523  !            *NC_ROUT(5),MASK1
 5524  !%finish
 5525           -> CHOS2 %IF PREC=1
 5526           -> CHOS1 %IF F1=0 %AND OPND1_D>3 %AND OPCODE#X'19'
 5527           -> CHOS2 %IF F2=0 %AND OPND2_D>3 %AND OPCODE#X'19'
 5528           -> CHOS2 %IF OPND2_PTYPE>OPND1_PTYPE
 5529           -> CHOS2 %IF F2>F1
 5530  CHOS1:   CHOICE=1; ->Label99
 5531  CHOS0:   ->CHOS1 %UNLESS F2>7 %AND OPND2_D<0 %AND X2=REG
 5532  CHOS2:   CHOICE=2
 5533  Label99:      %END
 5534           %ROUTINE LOAD(%RECORD(RD)%NAME OPND,%INTEGER REG,MODE)
 5535  !***********************************************************************
 5536  !*        MODE=0   LEAVE IN STORE IF POSSIBLE                          *
 5537  !*        MODE=1 LEAVE IN STORE IF SUITABLE FOR RX INSTRUCTIONS        *
 5538  !*        MODE=2 LOAD TO REGISTER REGARDLESS                           *
 5539  !*        MODE=3 LEAVE IN STORE IF SUITABLE FOR CLC  INSTRUCTIONS      *
 5540  !***********************************************************************
 5541           {%SHORTROUTINE}
 5542           %INTEGER I,J,K,VALUE,B
 5543           {%RECORDSPEC OPND(RD)}
 5544           %SWITCH SW(0:9)
 5545           PTYPE=OPND_PTYPE;! UNPACK
 5546  !%if USE MC = 1 %start
 5547  !            *L_1,PTYPE; *CVD_1,0(11)
 5548  !            *UNPK_ROUT(5),5(3,11)
 5549  !            *NC_ROUT(5),MASK1
 5550  !%finish
 5551           PREC=PREC&3
 5552           %IF REG<0 %THEN REG=REG-ADDREXP
 5553           -> SW(OPND_FLAG)
 5554  SW(0):                                 ! CONSTANT < 4096
 5555           ->Label99 %UNLESS MODE>0
 5556           VALUE=OPND_D
 5557           %IF CSSMODE=0 %THEN OPTSAVE(0,2,1,VALUE)
 5558           FIND USE(I,1,2,VALUE)
 5559           -> NOT FOUND %IF I<0
 5560           %IF REG<0 %THEN %START
 5561           ->RF %IF REGISTER(I)=0
 5562           ->RF2 %IF REGISTER(I)<0 %AND(26<=JJ<=27 %OR 30<=JJ<=31)
 5563           ->RF2 %IF MODE=1
 5564           %FINISH
 5565           REG=FINDR %IF REG<0
 5566           PRR(X'18',REG,I) %UNLESS REG=I
 5567           REGISTER(REG)=1 %IF REGISTER(REG)=0
 5568  SG:      SET USE(REG,2,VALUE) %UNLESS REGISTER(REG)<0
 5569  Label1:       OPND_PTYPE=1
 5570  Label2:       OPND_FLAG=9
 5571           OPND_XB=REG
 5572           OPND_D=-2
 5573           ->Label99
 5574  RF:      REGISTER(I)=1
 5575  RF2:     REG=I; ->Label1
 5576  NOT FOUND: -> GLA COPY %IF MODE&1#0 %AND VALUE#0 %AND CSSMODE#0
 5577           REG=FINDR %IF REG<0
 5578           DUMP(0,REG,VALUE,0,0); -> SG
 5579  GLA COPY:TYPE=1; K=4; PREC=0
 5580           -> FULL L %UNLESS X'19'<=OPCODE<=X'1B'
 5581           J=CONST FIND(4,ADDR(VALUE))
 5582           %UNLESS J=-1 %START
 5583              %IF J<0 %THEN BASE=CODER %ELSE BASE=GLA
 5584              DISP=J&X'7FFF'; INDEX=0; ->RESET RD
 5585           %FINISH
 5586           PREC=2; K=2
 5587  FULL L:  STORE CONST(BASE,DISP,K,ADDR(VALUE)+4-K)
 5588           INDEX=0; ->RESET RD
 5589  SW(1):                                 ! LONG CONSTANT
 5590           STORE CONST(BASE,DISP,BYTES(PREC),ADDR(A(OPND_D+1)))
 5591           -> PICK UP %IF MODE=2
 5592           INDEX=0; ->RESET RD
 5593  PICKUP:  DUMP(8*(TYPE-1)+2*(PREC&3)+2,REG,DISP,0,BASE)
 5594           MODE=0; ->Label21;        ! ENSURE THAT USE IS CHANGED
 5595  SW(2):                                 ! NAME
 5596           -> LOAD %IF MODE=2
 5597           ->STORE %IF MODE=4
 5598           -> LOAD %IF OPND_XB&127#0 %AND PTYPE#8
 5599           -> LOAD %IF MODE=0 %AND ARR>0
 5600           -> DONT LOAD %IF MODE=3
 5601           ->Label99 %IF MODE=0
 5602           %IF MODE=1 %THEN %START
 5603           -> LOAD %IF PREC=1
 5604           -> DONT LOAD %IF PREC=2 %AND X'19'<=OPCODE<=X'1B'
 5605           -> LOAD %IF PREC=2
 5606           %FINISH
 5607  DONT LOAD: P=OPND_D
 5608           CNAME(5,REG)
 5609           ->Label21 %IF NEST>=0
 5610  RESETRD: REGISTER(BASE)=2 %IF BASE>0 %AND REGISTER(BASE)=0
 5611           REGISTER(INDEX)=2 %IF INDEX>0 %AND REGISTER(INDEX)=0
 5612           OPND_PTYPE=10*(PREC&3)+TYPE
 5613           OPND_FLAG=9
 5614           OPND_XB=INDEX<<4!BASE
 5615           OPND_D=DISP; ->Label99
 5616  STORE:   P=OPND_D
 5617           CNAME(1,0); ->RESET RD
 5618  LOAD:    P=OPND_D
 5619           -> REGVAR %IF PTYPE=8
 5620           CNAME(2,REG)
 5621  Label21:      REG=NEST %IF REG<0
 5622           TYPE=1 %IF TYPE=8
 5623           PTYPE=TYPE; K=(PTYPE&2)<<3+REG
 5624           REGISTER(K)=1 %IF REGISTER(K)>=0;   ! CLAIM THE REGISTER
 5625           PTYPE=32 %IF PREC=3
 5626           ->Label24 %IF MODE>=1 %AND GRUSE(K)>1;    ! DONT CHANGE GRUSE
 5627           SET USE(K,1,ADDR(OPND))
 5628  Label24:      OPND_PTYPE=PTYPE; ->Label2
 5629  REGVAR:  %IF OPCODE=X'19' %OR 30<=JJ<=31 %OR %C
 5630+             (NOPS=1 %AND OPND_XB=SPECREG %AND REG<0) %OR %C
 5631+             (NOPS=0 %AND REG<0) %THEN REG=OPND_XB %AND ->Label1
 5632           REG=FINDR %IF REG<0
 5633           %IF REGISTER(REG)>=0 %THEN %START; ! N.B. REGVAR1=REGVAR2
 5634              FORGET(REG); GRUSE(REG)=3; GRINF(REG)=TAGS(A(P))
 5635           %FINISH
 5636           CNAME(2,REG); TYPE=1; ->Label21
 5637  SW(3):                                 ! DOPE VECTOR ITEM
 5638  ! XB HAS BASE OF ARRAYHEAD  D  IS HEADDISP<<16!ITEM DISP. XTRA HAS TAGS
 5639           ->Label99 %IF MODE=0
 5640           LOAD DV(BASE,OPND_XB,OPND_D>>16,OPND_XTRA)
 5641           INDEX=0; DISP=OPND_D&X'FFFF'
 5642           -> RESET RD;                  ! NOT CALLED WITH MODE=2
 5643  SW(7):SW(8):SW(9):
 5644           ->Label99 %IF  MODE=3 %OR MODE=4
 5645           ->PROTECT %IF MODE=0
 5646           ->Label99 %IF MODE=1 %AND(PREC=0 %OR PREC=3 %OR(PREC=2 %AND %C
 5647+          X'19'<=OPCODE<=X'1B'))
 5648           B=OPND_XB
 5649           -> RDR %IF OPND_D<0
 5650           %IF REG<0 %AND TYPE=1 %THEN REG=FINDR;! IN CASE OF SPECREG
 5651           DUMP(TYPE<<3!2*(PREC&3)-6,REG,OPND_D,B>>4,B&15)
 5652           MODE=0;                       ! ENSURE USE IS CHANGED
 5653           UNRESERVE(B); ->Label21
 5654  PROTECT: BASE=OPND_XB; INDEX=BASE>>4
 5655           BASE=BASE&15; DISP=OPND_D;      ! SAFEGUARD FROM OVERWRITING
 5656           ->RESET RD %IF OPND_D>=0
 5657           K=(TYPE&2)<<3+BASE
 5658           REGISTER(K)=1 %IF REGISTER(K)>=0;   ! CLAIM THE REGISTER
 5659           %IF GRUSE(K)=1 %THEN GRINF(K)=ADDR(OPND) %ELSE %C
 5660+          SET USE(K,1,ADDR(OPND)); ->Label99
 5661  RDR:     ->Label99 %IF REG<0 %OR REG=B
 5662           K=B; J=X'18'
 5663           %IF TYPE=2 %THEN %START
 5664           K=K+16; J=X'38'-16*(PREC&1); %FINISH
 5665           PRR(J,REG,B)
 5666           SET USE((TYPE&2)<<3+REG,GRUSE(K),GRINF(K))
 5667           REGISTER((TYPE&2)<<3+B)=0; OPND_XB=REG
 5668  Label99:      TYPE=1 %IF TYPE=8             ;%END
 5669           %ROUTINE     UNRESERVE(%INTEGER XB)
 5670           {%SHORTROUTINE}
 5671           %INTEGER B
 5672           B=XB&15
 5673           REGISTER(B)=0 %IF REGISTER(B)=2
 5674           XB=XB>>4
 5675           REGISTER(XB)=0 %IF REGISTER(XB)=2
 5676           %END
 5677           %ROUTINE PUT
 5678           {%SHORTROUTINE}
 5679           %COMMENT THIS ROUTINE PLANTS CODE TO PERFORM THE BASIC
 5680           ! OPERATION DEFINED BY OPND1,OPND2 & OPCODE
 5681           ! OPCODE IS IN INTEGER RR FORM
 5682           %INTEGER I,J,K,CODE,X,B,D
 5683           PTYPE=OPND2_PTYPE;! UNPACK
 5684  !%if USE MC = 1 %start
 5685  !            *L_1,PTYPE; *CVD_1,0(11)
 5686  !            *UNPK_ROUT(5),5(3,11)
 5687  !            *NC_ROUT(5),MASK1
 5688  !%finish
 5689           CODE=OPCODE
 5690           %IF TYPE=2 %THEN %START
 5691           CODE=CODE+32; CODE=CODE-16 %IF PREC&3=3
 5692           %FINISH %ELSE %START
 5693           CODE=CODE-16 %IF PREC=2; %FINISH
 5694           ->RROP %IF OPND2_D<0
 5695           X=OPND2_XB>>4; B=OPND2_XB&15
 5696           D=OPND2_D; CODE=CODE+64
 5697           DUMP(CODE,OPND1_XB,D,X,B)
 5698           UNRESERVE(OPND2_XB)
 5699           ->Label99
 5700  RROP:    PRR(CODE,OPND1_XB,OPND2_XB)
 5701           K=(TYPE&2)<<3+OPND2_XB
 5702           REGISTER(K)=0 %UNLESS REGISTER(K)<0 %OR OPND1_XB=OPND2_XB
 5703  Label99:      K=(TYPE&2)<<3+OPND1_XB
 5704           %IF OPCODE=X'19' %THEN %START
 5705           REGISTER(K)=0 %IF REGISTER(K)>0
 5706           %FINISH %ELSE SET USE(K,1,ADDR(OPND1))
 5707           %END
?J unused
?I unused
 5708           %ROUTINE LOAD PAIR(%INTEGER ODDEVEN)
 5709           {%SHORTROUTINE}
 5710           ! THIS ROUTINE LOADS OPERAND 1 INTO AN EVEN0ODDPAIR
 5711           ! THE PAIR IS CLAIMED AS LATE AS POSSIBLE
 5712           %INTEGER PAIR,TOTHER
 5713           CYC BITS=CYC BITS!64;         ! SET EVENODD PAIR BIT
 5714           LOAD(OPND1,-1,0);              ! IN STORE UNLESS RT ETC
 5715           LOAD(OPND2,-1,0)
 5716           -> IN STORE %UNLESS OPND1_FLAG=9 %AND OPND1_D<0
 5717           TOTHER=OPND1_XB!!1
 5718           -> INSTORE %UNLESS REGISTER(TOTHER)=0
 5719           REGISTER(TOTHER)=1; PAIR=TOTHER&14
 5720           -> FIN %IF ODDEVEN+PAIR#TOTHER
 5721           LOAD(OPND1,TOTHER,2); REGISTER(TOTHER!!1)=1; ->FIN
 5722  INSTORE: CLAIM PAIR(PAIR)
 5723           LOAD(OPND1,PAIR+ODDEVEN,2)
 5724  FIN:     OPND1_XB=PAIR;                ! ALWAYS LH MEMBER
 5725           REGISTER(PAIR)=2
 5726           REGISTER(PAIR+1)=2
 5727           LOAD(OPND2,-1,1)
 5728           REGISTER(PAIR)=1
 5729           REGISTER(PAIR+1)=1
 5730           %END
 5731           %ROUTINE CLAIM PAIR(%INTEGERNAME REG)
 5732           {%SHORTROUTINE}
 5733           %INTEGER I,J,K
 5734           %CYCLE I=0,1,2
 5735           %CYCLE K=6,-2,-2
 5736           J=K&15
 5737           -> FOUND %IF REGISTER(J)=REGISTER(J+1)=0 %AND (I>0 %OR  %C
 5738+          GRUSE(J)=0=GRUSE(J+1))
 5739           %REPEAT
 5740           SAVE IRS(4) %IF I=1
 5741           %REPEAT
 5742           ABORT
 5743  FOUND:   REGISTER(J)=1
 5744           REGISTER(J+1)=1
 5745           REG=J
 5746           %END
 5747           %ROUTINE CTOP(%INTEGERNAME FLAG)
 5748           {%SHORTROUTINE}
 5749           %COMMENT ON EXIT FLAG=0 %IF OPERATION CARRIED OUT
 5750           %INTEGER K,VAL1,VAL2,TYPEP,PRECP,OP
 5751           %LONGREAL RVAL1,RVAL2
 5752           %SWITCH SW(10:41)
 5753           NEWCC=0;                       !COMPILE TIME OPS CAN NOT SET CC
 5754           TYPEP=TYPE; PRECP=PREC; OP=FLAG
 5755           ->Label99 %IF OP>25
 5756           %IF TYPEP=2 %THEN %START
 5757           FROM AR8(OPND1_D+1,RVAL1)
 5758           FROMAR8(OPND2_D+1,RVAL2)
 5759           %FINISH %ELSE %START
 5760           %IF OPND1_FLAG=0 %THEN VAL1=OPND1_D %ELSE %C
 5761+          FROMAR4(OPND1_D+1,VAL1)
 5762           %IF OPND2_FLAG=0 %THEN VAL2=OPND2_D %ELSE  %C
 5763+          FROMAR4(OPND2_D+1,VAL2)
 5764           %FINISH
 5765           -> SW(16*(TYPEP-1)+OP)
 5766  SW(10):                                ! \
 5767           VAL1=\VAL1
 5768  INTEND:  A(R)=1; TOAR4(R+1,VAL1)
 5769           FLAG=0; OPND1_PTYPE=1
 5770           OPND1_FLAG=1; OPND1_D=R;
 5771           R=R+3; ->Label99
 5772  SW(11):                                ! INTEGER NEGATE
 5773           VAL1=-VAL1; -> INT END
 5774  SW(13):                                ! INTEGER ABS
 5775           VAL1=|VAL1|; -> INT END
 5776  SW(12):                                ! INTEGER FLOAT
 5777           RVAL1=VAL1; PRECP=3*XTRA
 5778           ->REAL END %UNLESS VAL1=0
 5779           CYC BITS=CYC BITS!16;          ! USES PERMS CONST TABLE
 5780           OPND1_FLAG=9; OPND1_XB=CODER; ! TREAT ZERO SPECIALLY
 5781           OPND1_D=X'C0'; ->Label98;          ! TO ALLOW LTDR ETC
 5782  SW(30):                                ! STRETCH REAL
 5783  REAL END:A(R)=2; TOAR8(R+1,RVAL1)
 5784           OPND1_FLAG=1; OPND1_D=R; R=R+5
 5785  Label98:      FLAG=0; OPND1_PTYPE=10*PRECP+2
 5786           ->Label99
 5787  SW(14):                                ! STRETCH INTEGER
 5788  SW(28):                                ! FLOAT REAL
 5789           ABORT
 5790  SW(15):                                ! ADD
 5791           VAL1=VAL1+VAL2; -> INT END
 5792  SW(16):                                ! MINUS
 5793           VAL1=VAL1-VAL2; -> INT END
 5794  SW(17):                                ! EXCLUSIVE OR
 5795           VAL1=VAL1!!VAL2; -> INT END
 5796  SW(18):                                ! OR
 5797           VAL1=VAL1!VAL2; -> INT END
 5798  SW(19):                                ! MULT
 5799           VAL1=VAL1*VAL2; -> INT END
 5800  SW(21):  ->Label99;                           ! / DIVISION
 5801  SW(20):  ->Label99 %IF VAL2=0;              ! // DIVISION
 5802           VAL1=VAL1//VAL2; -> INT END
 5803  SW(22):                                ! AND
 5804           VAL1=VAL1&VAL2; -> INT END
 5805  SW(24):                                ! SLL
 5806           VAL1=VAL1<<VAL2; -> INT END
 5807  SW(23):                                ! SRL
 5808           VAL1=VAL1>>VAL2; -> INT END
 5809  SW(27):                                ! NEGATE
 5810           RVAL1=-RVAL1; -> REAL END
 5811  SW(29):                                ! ABS
 5812           RVAL1=|RVAL1|; -> REAL END
 5813  SW(31):                                ! ADD
 5814           RVAL1=RVAL1+RVAL2; -> REAL END
 5815  SW(32):                                ! SUBTRACT
 5816           RVAL1=RVAL1-RVAL2; -> REAL END
 5817  SW(35):                                ! MULT
 5818           RVAL1=RVAL1*RVAL2; -> REAL END
 5819  SW(37):                                ! DIVISION
 5820           ->Label99 %IF RVAL2=0;             ! AVOID DIV BY ZERO
 5821           RVAL1=RVAL1/RVAL2; -> REAL END
 5822  SW(41):                                ! EXP
 5823           %IF OPND2_FLAG#0 %THEN  ->Label99
 5824           RVAL1=RVAL1^OPND2_D; -> REAL END
 5825  SW(25):SW(26):SW(33):SW(34):
 5826  SW(36):SW(38):SW(39):SW(40):
 5827  Label99:      %END
?K unused
 5828           %ROUTINE FLOAT
 5829           {%SHORTROUTINE}
 5830  !***********************************************************************
 5831  !*       PLANT CODE TO CONERT OPERAND1 FROM FIXED TO FLOATING          *
 5832  !***********************************************************************
 5833           %INTEGER P1,P2,K
 5834           P1=OPND1_XB; ; P2=(P1+1)&15
 5835           %UNLESS OPND1_FLAG=9 %AND OPND1_D<0 %AND %C
 5836+             REGISTER(P1)>=0=REGISTER(P2) %AND GRUSE(P2)>1 %START
 5837              FIND SEQ(P1,P2)
 5838              LOAD(OPND1,P1,2)
 5839           %FINISH
 5840           PRR(X'10',P2,P1);             ! LPR P2,P1
 5841           PRX(X'54',P1,CODER,0,X'E0');  ! N P1,=X'80000000'
 5842           PRX(X'56',P1,CODER,0,X'D0');  ! O P1,=X'4E000000'
 5843           PRX(X'90',P1,P2,WSPR,0);      ! STM P1,P2,0(11)
 5844           CLAIM (FR0,K); D=K
 5845           PRR(X'2B',K,K);               ! SDR K,K
 5846           PRX(X'6A',K,0,11,0);          ! AD K,0(11)
 5847           FREE AND FORGET(P1)
 5848           FORGET(P2)
 5849           CYC BITS=CYC BITS!16;         ! USES PERMS CONSTANTS
 5850           CCSTATE=-1
 5851           %END
 5852           %ROUTINE STARSTAR
 5853           {%SHORTROUTINE}
 5854  !***********************************************************************
 5855  !*       PLANT IN-LINE CODE FOR EXPONENTIATION                         *
 5856  
 5857  !*       IMP ALLOWS EXPONENTS IN INTEGER EXPRESSIONS FROM 0-63 AND     *
 5858  !*       IN REAL EXPRESSIONS FROM-255 TO +255                          *
 5859  !***********************************************************************
 5860           %INTEGER TYPEP,PRECP,COUNT,WORK,C,RREG,INTREG
 5861           %BYTEINTEGER VALUE
 5862           PTYPE=OPND1_PTYPE;            ! INSPECT THE OPERAND
 5863          ! UNPACK
 5864  !%if USE MC = 1 %start
 5865  !            *L_1,PTYPE; *CVD_1,0(11)
 5866  !            *UNPK_ROUT(5),5(3,11)
 5867  !            *NC_ROUT(5),MASK1
 5868  !%finish
 5869           %IF TYPE=1 %THEN WARN(LINE)
 5870           TYPEP=TYPE
 5871           %IF PREC&3=3 %THEN PRECP=16 %ELSE PRECP=0
 5872           VALUE=0
 5873           %IF OPND2_FLAG=0 %AND 1<=OPND2_D<=63*TYPE %THEN %START
 5874              VALUE=OPND2_D;             ! EXPONENT IS #0 AND CONSTANT
 5875           %FINISH
 5876  !
 5877  ! MUST TEST BOTH OPERANDS BEFORE CLAIMING WORK REGS IN CASE EITHER OR
 5878  ! BOTH ARE FNS AND WE ARE SHORT OF REGS SO THAT THE WORK REGS WILL
 5879  ! NOT SURVIVE A FN CALL
 5880  !
 5881           LOAD(OPND1,-1,0);                 ! INSPECT OPERAND CALL FNS
 5882           LOAD(OPND2,-1,0);                 ! INSPECT EXPNT & CALL IF FN
 5883           %IF TYPEP=1 %THEN CLAIM PAIR(WORK) %ELSE CLAIM (FR0,WORK)
 5884           %IF VALUE#2 %THEN %START;         ! TREAT **2 SPECIALLY
 5885              LOAD(OPND1,-1,2);              ! LOAD OPERAND TO ANY REGISTER
 5886           %FINISH
 5887  !
 5888  ! IF EITHER OPERAND IS A FN IT HAS BEEN FETCHED TO A REGISTER
 5889  ! SO NOW REGISTERS CAN BE OBTAINED FOR THE IN-LINE SUBROUTINE
 5890  !     WORK HOLDS INITIALLY 1 PRIOR TO MULTIPLICATION
 5891  !     INTREG  HOLDS THE EXPONENT AS CALCULATED
 5892  !     COUNT HOLDS A +VE VERSION OF INTREG FOR COUNTING THE MULTIPLIES
 5893  !     RREG HOLD THE OPERAND.
 5894  !     COUNT & INTREG CAN BE THE SAME REGISTER IF EXPONENT IS +VE
 5895  !
 5896           PLABEL=PLABEL-1;              ! LABEL FOR REPITITION
 5897           %IF VALUE=2 %THEN %START;     ! TRANSPOSE X**2 TO X*X
 5898              RREG= WORK+2-TYPEP
 5899              LOAD(OPND1,RREG,2);
 5900           %FINISH %ELSE %START
 5901              LOAD(OPND2,-1,2);              ! EXPONENT TO ANY REGISTER
 5902              INTREG=OPND2_XB
 5903              RREG=OPND1_XB
 5904              %IF TYPE=2 %THEN %START;   ! EXPONENT IS REAL **NOT ALLOWED
 5905                 FAULT(39,0)
 5906                 FREE AND FORGET(INTREG+16)
 5907              %FINISH
 5908              COUNT=INTREG
 5909  !
 5910  ! GET '1' INTO WORK IN APPROPIATE FORM
 5911  !
 5912              %IF TYPEP=1 %THEN PRX(X'41',WORK+1,0,0,1) %ELSE %C
 5913+                PRX(X'78'-PRECP,WORK,0,CODER,X'C8'); ! LD(E) WORK,=D'1'
 5914  !
 5915  ! IF EXPONENT NOT KNOWN AT COMPILE TIME TO BE +VE CONSTANT MUST
 5916  ! ALLOW FOR ZERO  :- XX**0=1 FOR ALL XX
 5917  ! ALSO ALLOW FOR X**(-N) WHICH IS 1/(X**N) FOR ALL X & N
 5918  !
 5919              %IF VALUE=0 %THEN %START;          ! NOT +VE CONSTANT
 5920                 CLAIM (GR1,COUNT) %IF TYPEP=2;  ! NEGATIVE REAL EXPONENTS
 5921                 PRR(X'14'-2*TYPEP,COUNT,INTREG);!  LPR OR LTR
 5922                 ENTER JUMP(8,PLABEL,B'11');     ! BZ END OF EXP ROUTINE
 5923  !
 5924  ! IN CHECKING MODE PLANT CODE TO CHECK RANGE OF EXPONENT
 5925  !
 5926                 %IF CHECKSP=1 %THEN %START
 5927                    %IF TYPEP=2 %THEN PRX(X'59',COUNT,0,GLA,24) %ELSESTART
 5928                       DUMP(X'41',-1,63,0,0);  ! LA NEST,63
 5929                       PRR(X'15',COUNT,NEST);  ! CLR COUNT,NEST
 5930                    %FINISH
 5931                    PCONST(X'4720C048');       !  BH ILLEGAL EXPONENT
 5932                 %FINISH
 5933              %FINISH
 5934              SET LOCAL BASE
 5935              C=CA-LOCAL ADDR;                 ! ADDR OF NEXT INST FOR LOOP
 5936           %FINISH
 5937           PRR(32*TYPEP-4-PRECP,WORK,RREG);  ! MR OR MER OR MDR
 5938           %IF TYPEP=1 %AND CHECKSP=1 %THEN %START
 5939              PRX(X'8F',WORK,0,0,32);    ! SRDA TO CAUSE INTEGER OFLOW
 5940              PRR(X'18',WORK+1,WORK);    ! LR WORK+1,WORK TO RESTORE
 5941           %FINISH
 5942           PRX(X'46',COUNT,LOCAL BASE,0,C) %IF VALUE#2;! BCT COUNT,AGAIN
 5943  !
 5944  ! FOR REAL EXPONENTS CHECK IF NEGATIVE AND EVALUATE INVERSE
 5945  !
 5946           %IF VALUE=0 %AND TYPEP=2 %THEN %START
 5947              PRR(X'12',INTREG,INTREG);  ! LTR ON ORIGINAL EXPONENT
 5948              ENTER JUMP(2,PLABEL,B'11');! BP END OF EXP ROUTINE
 5949              PRX(X'78'-PRECP,RREG,0,CODER,X'C8');! LD(E) RREG,=D'1'
 5950              CYC BITS=CYC BITS!16;      ! USES PERMS CONSTANTS
 5951              PRR(X'3D'-PRECP,RREG,WORK);! DDR  RREG,WORK
 5952              PRR(X'38'-PRECP,WORK,RREG);! LDR  WORK,RREG
 5953           %FINISH
 5954  !
 5955  ! ALL OVER. REAL RESULTS ARE IN FR WORK. INT RESULTS IN GR WORK+1
 5956  ! FREE AND FORGET ANY OTHER REGISTERS
 5957  !
 5958           TYPE=TYPEP; PREC=3*PRECP>>4
 5959           %IF VALUE #2 %THEN %START
 5960              FREE AND FORGET((TYPEP&2)<<3+RREG)
 5961              REGISTER(INTREG)=0
 5962              FREE AND FORGET(COUNT)
 5963           %FINISH
 5964           %IF TYPE=1 %THEN FREE AND FORGET(WORK)
 5965           OPND1_PTYPE=10*PREC+TYPE
 5966           OPND1_XB=WORK+2-TYPEP
 5967           ENTER LAB(PLABEL,B'11');      ! LABEL AT END OF EXP ROUTINE
 5968           %END
 5969           %END
 5970           %INTEGERFN CONST FIND(%INTEGER L,AD)
 5971  !***********************************************************************
 5972  !*       FIND IF THE CONSTANT OF LENGTH 'L' STORED AT ADDRESS 'AD'     *
 5973  !*       HAS ALREADY BEEN INSERTED IN THE GLA                          *
 5974  !***********************************************************************
 5975           {%SHORTROUTINE}
 5976           %INTEGER I,J,K,LIST,C1,C2
 5977           LIST=SHORTINTEGER(ADDR(GLAHOLES)+L)
 5978           C1=0; C2=0
 5979  !         %CYCLE I=0,1,L-1
 5980  !            BYTEINTEGER(ADDR(C1)+I)=BYTEINTEGER(AD)
 5981  !            AD=AD+1
 5982  !         %REPEAT
 5983  !%if USE MC = 1 %start
 5984  !         *LM_1,2,L; *BCTR_1,0
 5985  !         *MVC_C1(1),0(2)
 5986  !         *EX_1,*-6
 5987  !%finish
 5988  !         %WHILE LIST>0 %CYCLE
 5989  !            I=ADDR(ASLIST(LIST))
 5990  !            %IF C1=INTEGER(I) %AND C2=INTEGER(I+4) %C
 5991  !               %THEN %RESULT=INTEGER(I+8)
 5992  !            LIST=SHORT INTEGER(I+14)
 5993  !         %REPEAT
 5994  !%if USE MC = 1 %start
 5995  !         *L_1,LIST; *L_2,ASLIST
 5996  !NEXT:    *LTR_1,1; *BC_12,<MISS>
 5997  !         *LA_3,0(1,2); *CLC_C1(8),0(3)
 5998  !         *BC_8,<HIT>
 5999  !AGN:     *LH_1,14(1,2); *BC_15,<NEXT>
 6000  !HIT:     *L_1,8(1,2); *LM_4,15,16(7); *BCR_15,15
 6001  !%finish
 6002  MISS:
 6003           %RESULT=-1
 6004           %END
?MISS unused
?K unused
?J unused
?I unused
?AD unused
 6005           %ROUTINE STORE CONST(%INTEGERNAME B,D,%INTEGER L,AD)
 6006  !***********************************************************************
 6007  !*       PUT THE CONSTANT OF LENGTH 'L' AT ADDRESS 'AD' INTO THE GLA   *
 6008  !*       AND RECORD ITS POSITION IN CASE THIS CONSTANT IS REUSED       *
 6009  !*       A CHECK IS MADE USING 'CONST FIND' TO SEE IF THE CONSTANT HAS *
 6010  !*       BEEN INSERTED IN WHICH CASE THE OLD COPY IS REUSED            *
 6011  !***********************************************************************
 6012           {%SHORTROUTINE}
 6013           %INTEGER I,J,K
 6014           %SHORTINTEGERNAME LIST
 6015           D=-1
 6016           D=CONST FIND(L,AD) %IF GLAFLAG = 0
 6017           %IF D=-1  %START;! FIRST USE OF CNST
 6018              I=0; J=0
 6019              %CYCLE K=0,1,L-1
 6020                 BYTEINTEGER(ADDR(I)+K)=BYTEINTEGER(AD+K)
 6021              %REPEAT
 6022              %IF L=2 %AND GLAHOLES#0 %START
 6023                 POP(GLAHOLES,D,B)
 6024                 B=13; PLUG(2,D,I>>16)
 6025                 GSAVED=GSAVED+2
 6026              %FINISH %ELSE %START
 6027                 PGLA(L,L,AD)
 6028                 D=GLACA-L; B=GLA
 6029              %FINISH
 6030              LIST==SHORT INTEGER(ADDR(GLAHOLES)+L)
 6031              PUSH123(LIST,I,J,D) %IF GLAFLAG=0
 6032           %FINISH %ELSE %START;            ! CONST ALREADY IN
 6033              %IF D<0 %THEN %START
 6034                 CYC BITS=CYC BITS!16;      ! SET USES PERMS CONSTS BIT
 6035                 B=CODER; D=D&X'FFF'
 6036              %FINISH %ELSE B=GLA
 6037           %FINISH
 6038           %END
 6039           %ROUTINE CCOND(%INTEGER IU,FARLAB)
 6040           {%SHORTROUTINE}
 6041  !***********************************************************************
 6042  !*       COMPILES <IU><SC><RESTOFCOND>%THEN<UI1>%ELSE<UI2>             *
 6043  !*       IU=1 FOR %IF   =2 FOR UNLESS. FARLAB TO GO ON UI2             *
 6044  !*       THE ROUTINE MAKES FOUR PASSES THROUGH THE CONDITION           *
 6045  !*       PASS 1 ANALYSES THE STRUCTURE AND DECIDES TO BRANCH ON TRUE   *
 6046  !*       (TF=2)   OR ON FALSE (TF=1) FOR EACH COMPARISON               *
 6047  !*       PASS 2 WORKS OUT WHERE THE BRANCHES OF PASS 1 SHOULD GO TO    *
 6048  !*       PASS 3 ASSIGNS LABEL NUMBERS                                  *
 6049  !*       PASS 4 EVALUATES COMPARISIONS AND PLANTS THE CODE             *
 6050  !*                                                                     *
 6051  !*       ON ENTRY P POINTS TO <SC> IN<HOLE><SC><RESTOFCOND>            *
 6052  !***********************************************************************
 6053  !         %ROUTINESPEC WRITE CONDLIST
 6054           %ROUTINESPEC SKIP SC
 6055           %ROUTINESPEC SKIP COND
 6056           %ROUTINESPEC CCOMP
 6057  !
 6058  ! FCOMP HAS BC MASKS FOR EACH COMPARATOR.
 6059  ! THE FIRST 7 ARE TO BRANCH IF TRUE WITH NORMAL COMPARISON
 6060  ! THE SECOND SEVEN ARE TO BRANCH IF TRUE WITH BACKWARDS COMPARISON
 6061  ! THE THIRD SEVEN ARE FOR THE TEST UNDER MASK INSTRUCTION
 6062  !
 6063           %CONSTBYTEINTEGERARRAY FCOMP(1:21)=8,10,2,7,12,4,7,
 6064+                                             8,12,4,7,10,2,7,
 6065+                                             8,15,7,7,8,0,7;
 6066  !
 6067           %INTEGER PIN,PP,II,L,CPTR,CMAX,LL
 6068           %RECORDFORMAT CF(%BYTEINTEGER TF,CMP1,CMP2,LABU,LVL,JMP, %C
 6069+                           %SHORTINTEGER LABNO,SP1,SP2)
 6070           %RECORD(CF)%ARRAY CLIST(1:30)
 6071           %RECORD(CF)%NAME C1,C2
 6072  !
 6073  ! PASS 1.   ANALYSES THE CONDITION
 6074  !
 6075           PIN=P;                        ! SAVE INITIAL AR POINTER
 6076           CPTR=1; L=3;                  ! LEVEL=3 TO ALLOW 2 LOWER
 6077           C1==CLIST(CPTR);              ! SET UP RECORD FOR FIRST CMPARSN
 6078           C1=0
 6079           SKIP SC;                      ! SKIP THE 1ST CMPARSN
 6080           SKIP COND;                    ! AND ANY %AND/%OR CLAUSES
 6081           C1_LVL=2;                     ! LEVEL =-1 FOR %IF/%THEN ENTRY
 6082           C1_TF=IU
 6083           CMAX=CPTR+1
 6084           C1==CLIST(CMAX); C1=0
 6085           C1_LVL=1;                     ! LEVEL =-2 FOR ELSE ENTRY
 6086           C1_TF=3-IU; C1_LABNO=FARLAB
 6087           PP=P;                         ! SAVE FINAL AR POINTER
 6088           FAULT(209,0) %IF CMAX>29;     ! TOO COMPLICATED
 6089  !
 6090  ! PASS 2 WORKS OUT WHERE TO JUMP TO
 6091  ! THE JUMP IS FORWARD TO THE START OF THE CLAUSE WITH A DIFFERENT
 6092  ! CONNECTOR (AND/OR) PROVIDED THIS IS AT A LOWER LEVEL THAN THE BRANCH
 6093  ! AND ALSO AT A LOWER LEVEL THAN THE LOWEST POINT REACHED ENROUTE
 6094  !
 6095  ! ALSO CONTAINS PASS 3 (TRIVIAL)
 6096  ! ASSIGN LABELS WHERE LABU SHOWS THEY ARE REQUIRED
 6097  !
 6098           %CYCLE CPTR=1,1,CMAX-1
 6099              C1==CLIST(CPTR)
 6100              L=C1_LVL; LL=L;            ! LL FOR LOWEST LEVEL ENROUTE
 6101              %CYCLE II=CPTR+1,1,CMAX+1
 6102                C2==CLIST(II)
 6103                %EXIT %IF C1_TF#C2_TF %AND C2_LVL<LL
 6104                %IF C2_LVL<LL %THEN LL=C2_LVL
 6105              %REPEAT
 6106              C1_JMP=II;                 ! CLAUSE TO JUMP TO
 6107              C2_LABU=C2_LABU+1
 6108               %IF C1_CMP2#0 %OR C1_CMP1=8 %START; ! D-SIDED OR RESLN
 6109                                         ! REQIUIRES A LABEL ON THE
 6110                 C1_LABU=C1_LABU+1;      ! THE NEXT SIMPLE CONDITION
 6111              %FINISH
 6112              %IF C1_LABU#0 %AND C1_LABNO<=0 %THEN PLABEL=PLABEL-1 %C
 6113+                                            %AND C1_LABNO=PLABEL
 6114           %REPEAT
 6115  !
 6116  ! PASS 4 GENERATE THE CODE
 6117  !
 6118  !         WRITE CONDLIST %IF DCOMP=1
 6119           %CYCLE CPTR=1,1,CMAX-1
 6120              C1==CLIST(CPTR)
 6121              CCOMP
 6122              %IF C1_LABNO>0 %THEN ENTER LAB(C1_LABNO,B'11')
 6123           %REPEAT
 6124  !
 6125           P=PP; %RETURN
 6126           %ROUTINE SKIP SC
 6127  !***********************************************************************
 6128  !*       SKIPS OVER A SIMPLE CONDITION. P ON ALT OF<SC>                *
 6129  !***********************************************************************
 6130           %INTEGER ALT
 6131           ALT=A(P); P=P+1
 6132           %IF ALT=1 %THEN %START;      ! <EXP><COMP><EXP><SECONDSIDE>
 6133              C1_SP1=P-PIN
 6134              SKIP EXP
 6135              C1_CMP1=A(P)
 6136              P=P+1; C1_SP2=P-PIN
 6137              SKIP EXP
 6138              %IF A(P)=2 %THEN P=P+1 %ELSE %START
 6139                 C1_CMP2=A(P+1);        ! DEAL WITH 2ND HALF OF D-SIDED
 6140                 P=P+2; SKIP EXP
 6141              %FINISH
 6142           %FINISH %ELSE %START;        ! '('<SC><RESTOFCOND>')'
 6143               L=L+1
 6144               SKIP SC
 6145               SKIP COND
 6146               L=L-1
 6147           %FINISH
 6148           %END;                        ! OF ROUTINE SKIP SC
 6149           %ROUTINE SKIP COND
 6150  !***********************************************************************
 6151  !*       SKIPS OVER <RESTOFCOND>                                       *
 6152  !***********************************************************************
 6153           %INTEGER ALT,ALTP
 6154           ALT=A(P);                      ! 1=%AND<ANDC>,2=%OR<ORC>,3=NULL
 6155           P=P+1
 6156           %IF ALT\=3 %THEN %START;       ! NULL ALTERNATIVE NOTHING TO DO
 6157              %CYCLE;       ! UNTIL NO MORE <SC>S
 6158                 C1_LVL=L; C1_TF=ALT
 6159                 CPTR=CPTR+1
 6160                 C1==CLIST(CPTR); C1=0
 6161                 SKIP SC
 6162                 ALTP=A(P); P=P+1
 6163              %REPEAT %UNTIL ALTP=2
 6164           %FINISH
 6165           %END
 6166  !         %ROUTINE WRITE CONDLIST
 6167  !         %CONSTSTRING(5) %ARRAY CM(0:8)='     ','    =','   >=','    >',
 6168  !                                '    #','   <=','    <','   \=','   ->'
 6169  !         PRINTSTRING("
 6170  ! NO   TF   C1   C2   LABU   LVL  JMP  LABNO
 6171  !")
 6172  !         %CYCLE CPTR=1,1,CMAX
 6173  !            C1==CLIST(CPTR)
 6174  !            WRITE(CPTR,2)
 6175  !            WRITE(C1_TF,4)
 6176  !            PRINTSTRING(CM(C1_CMP1))
 6177  !            PRINTSTRING(CM(C1_CMP2))
 6178  !            WRITE(C1_LABU,6)
 6179  !            WRITE(C1_LVL,5)
 6180  !            WRITE(C1_JMP,4)
 6181  !            WRITE(C1_LABNO,7)
 6182  !            NEWLINE
 6183  !         %REPEAT
 6184  !         %END
 6185           %ROUTINE CCOMP
 6186  !***********************************************************************
 6187  !*       COMPILES A COMPARISION: THREE DIFFERENT CASES                 *
 6188  !*       1) ARITHMETIC EXPRESSIONS EXPOP IS USED                       *
 6189  !*       2) STRING EXPRESSION AD-HOC CODE PLANTED BY THIS ROUTINE      *
 6190  !*       3) RESOLUTIONS - CRES CAN BE USED                             *
 6191  !***********************************************************************
 6192           %ROUTINESPEC ACOMP(%INTEGER TF,LAB)
 6193           %ROUTINESPEC SCOMP(%INTEGER TF,LAB,%INTEGERNAME WA)
 6194           %SHORTINTEGER HEAD1,HEAD2,NOPS,BOT1,BOT2
 6195           %INTEGER TE1,TE2,TEX1,TEX2,MASK,P1,P2
 6196           %INTEGER FEXIT,IEXIT,CMP,WA1,WA2,WA3,DISPP,BASEP,LL
 6197  !
 6198           HEAD1=0; HEAD2=0; NOPS=0; BOT1=0; BOT2=0
 6199           FEXIT=CLIST(C1_JMP)_LABNO;    ! FINAL EXIT
 6200           IEXIT=FEXIT;                  ! INTERMEDIATE EXIT (D-SIDED ETC)
 6201           %IF C1_TF=2 %AND (C1_CMP1=8 %OR C1_CMP2#0) %THEN %C
 6202+                       IEXIT=C1_LABNO
 6203  !
 6204           P=PIN+C1_SP2
 6205           P2=P; P1=PIN+C1_SP1
 6206           %IF C1_CMP1=8 %OR C1_CMP2=8 %THEN %START
 6207                                         ! CONDITIONAL RESOLUTION
 6208                                         ! NB CRES BRANCHES ON FALSE!!
 6209              P=P1
 6210              %IF C1_CMP2=0 %AND A(P+2)=4 %AND A(P+3)=1 %START
 6211                 P=P+4; CNAME(5,1);      ! LH STRING TO REGISTER 1
 6212                 %IF A(P)=2 %AND TYPE=5 %THEN %START
 6213                    P=P2
 6214                    CRES(IEXIT);         ! FAILURES -> IEXIT
 6215                    %IF C1_TF=2 %THEN MASK=15 %AND ->TBRANCH
 6216                    %RETURN
 6217                 %FINISH
 6218              %FINISH
 6219              FAULT(73,0)
 6220              %RETURN
 6221           %FINISH
 6222           MASK=FCOMP(C1_CMP1)
 6223           TE2=TSEXP(TEX2,0)
 6224           ->STR %IF TYPE=5
 6225           ->ARITH %UNLESS TE2=1
 6226           P=P1; TE1=TSEXP(TEX1,1)
 6227           ->STR %IF TYPE=5
 6228           %IF TE1=800 %AND K<=4095 %AND C1_CMP2=0=CHECKSP %START;! X&N1=N2
 6229              DISPP=K+BYTES(PREC)-1; BASEP=I
 6230              %IF TEX2=0 %THEN %START
 6231                 MASK=FCOMP(C1_CMP1+14)
 6232                 -> T UNDER M;           ! CAN USE TM FOR X&N1=0 IF N1<256
 6233              %FINISH
 6234              %IF TEX1=TEX2 %AND 7<=MASK<=8 %START;  ! X&N1<=/#>N1
 6235                 %IF MASK=8 %THEN MASK=1 %ELSE MASK=14
 6236                 -> T UNDER M
 6237              %FINISH
 6238           %FINISH
 6239  ARITH:                                 ! ARITHMETIC COMPARISIONS
 6240           P=P1+2
 6241           TORP(HEAD1,BOT1,NOPS,0);      ! FIRST EXPRESSION TO REVERSE POL
 6242           CMP=C1_CMP1
 6243           P=P2+2
 6244           %IF C1_CMP2#0 %THEN %START;   ! IF D-SIDED DEAL WITH MIDDLE
 6245              ACOMP(1,IEXIT);            ! BRANCH IEXIT %IF FALSE
 6246              P=P+4;                     ! TO THE THIRD EXPRSN
 6247              CMP=C1_CMP2;               ! COMPARATOR NO 2
 6248           %FINISH
 6249  !
 6250           ACOMP(C1_TF,FEXIT);           ! SECOND OR ONLY COMPARISION
 6251  !
 6252           EXPOP(HEAD1,-1,NOPS,16);      ! PLANT THE CODE
 6253  !         CLEAR LIST(HEAD1)
 6254           SHORTINTEGER(ADDR(ASLIST(BOT1))+14)=ASL
 6255           ASL=HEAD1
 6256           %RETURN
 6257  T UNDER M:                             ! CAN USE TM FOR COMPARISON
 6258           DUMPSI(X'91',TEX1,BASEP,DISPP)
 6259           CCSTATE=-1
 6260  TBRANCH: MASK=MASK!!15 %IF C1_TF=1
 6261           ENTER JUMP(MASK,FEXIT,B'11')
 6262           %RETURN
 6263  STR:                                   ! STRING COMPARISIONS
 6264                                         ! SOME CARE IS NEEDED IN FREEING
 6265                                         ! STRING WK-AREAS SET BY CSTREXP
 6266           P=P1
 6267           WA1=0; WA2=0; WA3=0
 6268           %IF TE2=1 %AND TEX2=0 %AND C1_CMP2=0 %AND 7<=MASK<=8 %START
 6269              CSTREXP(0,-2);            ! USE TM FOR IF S='' ETC
 6270              DISPP=DISP; BASEP=BASE
 6271              TEX1=255
 6272              ->T UNDER M
 6273           %FINISH
 6274           CSTREXP(16,-2);              ! DO NOT FREE WK-AREA
 6275           WA1=VALUE;                   ! SAVE ADDRESS OF WK-AREA
 6276           CMP=C1_CMP1
 6277           P=P2
 6278  !
 6279           %IF C1_CMP2#0 %THEN %START;  ! D-SIDED DEAL WITH MIDDLE
 6280              SCOMP(1,IEXIT,WA2)
 6281              P=P+2; CMP=C1_CMP2
 6282              %IF WA1#0 %THEN RETURN WSP(WA1,256) %AND WA1=0
 6283           %FINISH
 6284  !
 6285           SCOMP(C1_TF,FEXIT,WA3)
 6286           %CYCLE CMP=ADDR(WA1),4,ADDR(WA3)
 6287              %IF INTEGER(CMP)#0 %THEN RETURN WSP(INTEGER(CMP),256)
 6288           %REPEAT
 6289           %RETURN
 6290           %ROUTINE ACOMP(%INTEGER TF,LAB)
 6291  !***********************************************************************
 6292  !*       TYPE & PREC DEFINE THE EXPRSN IN REVERSE POLISH IN HEAD1      *
 6293  !*       THIS ROUTINE CONVERTS THE NEXT EXPRSN TO REVERSE POLISH AND   *
 6294  !*       ADDS OPERATORS FOR TYPE CHANGING(IF REQ) CMPRSN AND JUMP      *
 6295  !***********************************************************************
 6296           %BYTEINTEGER PRECP,TYPEP
 6297           %INTEGER BMASKS,TORPMODE,CMODE,COP
 6298           PRECP=PREC; TYPEP=TYPE
 6299           BMASKS=FCOMP(CMP+7)<<4!FCOMP(CMP)
 6300           %IF TF=1 %THEN BMASKS=BMASKS!!255;! REVERSE MASKS IF FALSE
 6301  !
 6302  ! ADD OPERATORS IN THE REVERSE ORDER TO EXECUTION. IE JUMP(29) THEN
 6303  ! COMPARE(26) OR LOGICAL (IE = & # ONLY) COMPARE(27)
 6304  !
 6305           PUSH(HEAD2,29,0)
 6306           BOT2=HEAD2
 6307           PUSH(HEAD2,1<<16!BMASKS<<8,LAB)
 6308           %IF 7<=BMASKS&15<=8 %THEN CMODE=27 %ELSE CMODE=26
 6309           PUSH(HEAD2,CMODE,0)
 6310  !
 6311  ! CONVERT NEXT EXPRSN TO REVERSE POLISH AND TO THE SAME TYPE AS THE
 6312  ! FIRST IF POSSIBLE. MODE=0 INTEGER IF POSSIBLE,=2 REAL, =3 LONGREAL
 6313  !
 6314           %IF TYPEP=1 %THEN TORPMODE =0 %ELSE TORPMODE=PRECP!2
 6315           TORP(HEAD2,BOT2,NOPS,TORPMODE)
 6316  !
 6317  ! IF THE 2ND EXPRSN IS REAL OR LONGREAL AND THE FIRST IS INTEGER OR
 6318  ! REAL A CONVERSION OPERN (FLOAT=12,STRETCH=14) IS ALSO NEEDED
 6319  !
 6320           COP=0
 6321           %IF TYPE=2 %THEN %START
 6322              %IF TYPEP=1 %THEN COP=12 %ELSE %START
 6323                 %IF PREC#PRECP %THEN COP=14
 6324              %FINISH
 6325           %FINISH
 6326           PUSH(HEAD2,COP,PREC>>1) %IF COP#0
 6327           SHORTINTEGER(ADDR(ASLIST(BOT1))+14)=HEAD2
 6328           BOT1=BOT2; BOT2=0; HEAD2=0
 6329           %END
 6330           %ROUTINE SCOMP(%INTEGER TF,LAB,%INTEGERNAME WA)
 6331  !***********************************************************************
 6332  !*       1ST STRING IS DEFINED BY BASE,DISP & STRINGL(IF KNOWN)        *
 6333  !*       THIS ROUTINE EVALUATES THE NEXT STRING EXPRS AND PERFORMS     *
 6334  !*       THE COMPARISON & BRANCH. = & # CAN BE DONE IN LINE BUT < & >  *
 6335  !*       ARE COMPLICATED BY THE LENGTH BYTE AND ARE PERFORMEDIN PERM   *
 6336  !***********************************************************************
 6337           %INTEGER MASK,CODE,L
 6338  !
 6339  ! A SAFE REGISTER MAY BE NEEDED HERE ON OPTIMUM CODE EVEN IF IT IS NOT
 6340  ! REQUIRED ON THE PRELIMINARY PASS
 6341  !
 6342           CYC BITS=CYC BITS!128;        ! SAFE REGISTER REQD
 6343           %IF REGISTER(BASE)=0 %AND (BASE<4 %OR BASE=15) %START
 6344              CLAIM(SAFE,BASEP); PRR(X'18',BASEP,BASE)
 6345              FORGET(BASEP); BASE=BASEP
 6346           %FINISH
 6347  !
 6348           BASEP=BASE; DISPP=DISP; LL=STRINGL
 6349           MASK=FCOMP(CMP)
 6350           %IF 7<=MASK<=8 %THEN CODE=0 %ELSE CODE=5
 6351           %IF TF=1 %THEN MASK=MASK!!15; ! REVERSE MASK TO JMP IF FALS
 6352           REGISTER(BASEP)=1 %IF REGISTER(BASEP)=0
 6353  !
 6354           CSTREXP(16,0);                ! SAVE WK-AREA
 6355           WA=VALUE
 6356           L=STRINGL
 6357           %IF CODE=0 %THEN L=L!LL
 6358           STRINGOP(CODE,L,BASE,DISP,BASEP,DISPP,0,255,-2)
 6359           REGISTER(BASEP)=0 %IF REGISTER(BASEP)=1
 6360           REGISTER(BASE)=1 %IF REGISTER(BASE)=0;! MAY BE FURTHER CMPRSN!
 6361           ENTER JUMP(MASK,LAB,B'11')
 6362           REGISTER(BASE)=0 %IF REGISTER(BASE)>0
 6363           %END
 6364           %END
 6365           %END
 6366           %ROUTINE REDUCE ENV(%SHORTINTEGERNAME HEAD)
 6367           {%SHORTROUTINE}
 6368  !***********************************************************************
 6369  !*       HEAD HAS AN ENVIRONMENT  - THIS ROUTINE REMOVES ANYTHING      *
 6370  !*       INCOMPATIBLE WITH THE CURRENT REGISTER STATE                  *
 6371  !***********************************************************************
 6372           %SHORTINTEGER NEWHEAD; %INTEGER I,J,K,REG,USE
 6373           NEWHEAD=0
 6374           %WHILE HEAD#0 %CYCLE
 6375              POP123(HEAD,I,J,K)
 6376              REG=K>>8; USE=K&255
 6377              %IF USE=GRUSE(REG) %AND I=GRINF(REG) %THEN %C
 6378+                PUSH123(NEWHEAD,I,J,K)
 6379           %REPEAT
 6380           HEAD=NEWHEAD
 6381           %END
 6382           %ROUTINE ENTER LAB(%INTEGER LAB,FLAGS)
 6383           {%SHORTROUTINE}
 6384  !***********************************************************************
 6385  !*       ENTER A NEW LABEL ON THE LABEL LIST FOR THE CURRENT LEVEL     *
 6386  !*       2**0  OF FLAGS  = 1  CONDITIONAL ENTRY                        *
 6387  !*       2**1  OF FLAGS  = 1  UPDATE ENVIRONMENT                       *
 6388  !*       2**2  OF FLAGS  = 1  REPLACE ENV     =0  MERGE ENV            *
 6389  !*       THE LABEL LIST                                                *
 6390  !*       S1 =   USE BITS<<8 ! LABEL ADDR                               *
 6391  !*       S2 =   ENVIRONMENT LIST << 16 ! UNFILLED JUMPS LIST           *
 6392  !*       S3 = LAB NO - RESET TO ZERO WHEN USED FOR INTERNAL LABELS     *
 6393  !***********************************************************************
 6394           %INTEGER CELL,AT,BBASE,BREG,KREG,DIS,KDIS
 6395           %SHORTINTEGERNAME ENVHEAD,JUMPHEAD
 6396           %RETURN %IF CSSMODE=0
 6397           FLAGS=FLAGS&1 %IF CHECKSP#0
 6398           MONE=1 %IF LAB<MAX ULAB
 6399           %IF 1<=LAB<=16381 %THEN WARN(LINE)
 6400           CELL=FIND3( LAB,LABEL(LEVEL))
 6401           %IF CELL<0 %THEN %START;      ! LABEL NOT KNOWN
 6402              %IF FLAGS&1=0 %THEN %START;! UNCONDITIONAL ENTRY
 6403                 PUSH123(LABEL(LEVEL),CA,0,LAB)
 6404                 FORGETM(14)
 6405                 CCSTATE=-1; LCA=0
 6406              %FINISH
 6407              %RETURN
 6408           %FINISH
 6409  !
 6410  ! LABEL HAS BEEN REFERENCED - FILL IN ITS ADDRESS
 6411  !
 6412           ENVHEAD== SHORT INTEGER(ADDR(ASLIST(CELL+4)))
 6413           JUMPHEAD== SHORT INTEGER(ADDR(ASLIST(CELL+6)))
 6414           %IF FROM1(CELL)&X'FFFFFF'# 0 %THEN %START
 6415              FAULT(2,-LAB);             ! LABEL SET TWICE
 6416           %FINISH %ELSE %START
 6417              CCSTATE=-1; LCA=0
 6418              REPLACE1(CELL,X'1000000'!CA)
 6419           %FINISH
 6420  !
 6421  ! SORT OUT ENVIRONMENTS  -  AS DIRECTED BY FLAGS
 6422  !
 6423           %IF FLAGS&2=0 %THEN %START
 6424              FORGETM(14)
 6425              CLEAR LIST(ENVHEAD) %IF ENVHEAD#0
 6426           %FINISH %ELSE %START
 6427              REMEMBER %IF FLAGS&4=0
 6428              RESTORE (ENVHEAD)
 6429              ENVHEAD=0
 6430              MERGE INFO %IF FLAGS&4=0
 6431           %FINISH
 6432  !
 6433  ! NOW FILL JUMPS TO THIS LABEL - JUMP LIST FORMAT GIVEN IN 'ENTER JMP'
 6434  !
 6435           %WHILE  JUMPHEAD#0  %CYCLE
 6436              POP(JUMPHEAD,AT,BBASE)
 6437              KREG=AT>>24
 6438              BREG=BBASE>>24
 6439              AT=AT&X'FFFFFF'
 6440              DIS=CA-BBASE&X'FFFFFF'
 6441  !
 6442  ! KREG=0 %IF NO INDEX REGISTER REQUIRED
 6443  ! KREG=KREG!16 %IF INDEX REGISTER HAS BEEN SET UP BY EARLIER JUMP
 6444  ! IF INDEX REGISTER SET BUT NOT REQUIRED  OVERWRITE 'L' WITH 'LA'
 6445  !
 6446           %IF 0<KREG<16 %THEN %START
 6447              KDIS= PTBASE+ DIS>>12<<2;! ADDR OF CORRECT 4K MULTIPLE
 6448              %IF KDIS=PTBASE %THEN %START
 6449                 PLUG(1,AT,X'4100'! KREG<<4);!   LOAD ADDRESS
 6450                 KDIS=0
 6451              %FINISH
 6452              PLUG(1,AT+2,KDIS)
 6453              AT=AT+4
 6454           %FINISH
 6455           %IF DIS>4095 %AND KREG=0 %THEN FAULT(99,0)
 6456           PLUG(1,AT+2, (BREG&15)<<12!DIS&4095); ! FILL THE JUMP
 6457           %REPEAT
 6458           %IF LAB> MAX ULAB  %THEN %START
 6459              %IF PREV3CL=0 %THEN JUMPHEAD==LABEL(LEVEL) %C
 6460+                %ELSE JUMPHEAD==SHORT INTEGER(ADDR(ASLIST(PREV3CL+14)))
 6461              POP(JUMPHEAD,AT,AT);        ! REMOVE OLD LABEL
 6462           %FINISH
 6463           %END
 6464           %ROUTINE ENTER JUMP(%INTEGER MASK,LAB,FLAGS)
 6465           {%SHORTROUTINE}
 6466  !***********************************************************************
 6467  !*       IF LAB HAS BEEN ENCOUNTERED THEN PLANT A *BC OTHERWISE ENTER  *
 6468  !*       THE LABEL IN THE LABEL LIST AND ATTACH THE JUMP TO IT SO IT   *
 6469  !*       CAN BE PLANTED WHEN THE LABEL IS FOUND                        *
 6470  !*       THE LABEL LIST IS DESCRIBED UNDER 'ENTER LAB'                 *
 6471  !*       THE JUMP SUB-LIST HAS THE FORM                                *
 6472  !*       S1=KREG<<24! ADDR OF JUMP                                     *
 6473  !*       S2=BREG<<24! (ADDRESS IN BASE(BREG) REGISTER)                 *
 6474  !*                                                                     *
 6475  !*       FLAGS BITS SIGNIFY AS FOLLOWS                                 *
 6476  !*       2**0 =1  JUMP IS KNOWN TO BE SHORT                            *
 6477  !*       2**1 =1  ENVIRONMENT MERGEING REQUIRED                        *
 6478  !***********************************************************************
 6479           %INTEGER AT,CELL,BREG,BBASE,KREG,LABADDR,I
 6480           %SHORTINTEGER ENVHEAD
 6481           %SHORTINTEGERNAME OLDENV
 6482           ENVHEAD=0; AT=CA; KREG=0
 6483           BREG=10; BBASE=CODEBASE; ENVHEAD=0
 6484           %IF LAB=0 %THEN FAULT(2,0) %AND %RETURN
 6485           FLAGS=FLAGS&1 %IF CHECKSP#0
 6486           %IF 1<=LAB<=16381 %THEN WARN(LINE)
 6487           %IF LAB<MAX ULAB %THEN FLAGS=FLAGS&X'FD';! NO MERGE
 6488           %IF LAB<22000 %THEN FLAGS=FLAGS&X'FE'
 6489                                            ! SF OR USER LAB=LONG
 6490           CELL=FIND3(LAB,LABEL(LEVEL))
 6491           -> FIRSTREF %IF CELL<0
 6492           LABADDR=FROM1(CELL)&X'FFFFFF'
 6493           -> NOT YET SET %IF LABADDR=0
 6494           REPLACE1(CELL,LABADDR!X'1000000');! FLAG LABEL AS USED
 6495           %IF CYC BASE#0 %AND CYC ADDR<=LABADDR %THEN %C
 6496+                         BREG=CYC BASE %AND BBASE=CYC ADDR
 6497           I=LABADDR-BBASE
 6498           %IF I=0 %THEN PRR(7,MASK,BREG) %ELSE DUMP(X'47',MASK,I,0,BREG)
 6499           %RETURN
 6500  FIRSTREF:                              ! FIRST REFERENCE TO A NEW LABEL
 6501           %IF CSSMODE#0 %THEN %START
 6502              %IF LAB>MAX ULAB %AND FLAGS&2#0 %THEN GET ENV(ENV HEAD)
 6503              PUSH123(LABEL(LEVEL),X'1000000',ENVHEAD<<16,LAB)
 6504              CELL=LABEL(LEVEL)
 6505           %FINISH
 6506           -> CODE
 6507  NOT YET SET:                           ! LABEL REFERENCED BEFORE
 6508           %IF CSSMODE#0 %THEN %START
 6509              %IF LAB>MAX ULAB %AND FLAGS&2#0 %THEN %START
 6510              OLDENV==SHORT INTEGER(ADDR(ASLIST(CELL+4)))
 6511                 REDUCE ENV(OLD ENV)
 6512              %FINISH
 6513           %FINISH
 6514  CODE:                                  ! ACTUALLY PLANT THE JUMP
 6515           %IF SBFLAG #0 %THEN FLAGS=FLAGS!1
 6516           %IF CYC BASE #0 %AND LAB> MAX ULAB %THEN %START
 6517              BREG=CYC BASE;             ! SOMETHING INSIDE AN OPTIMISED
 6518              BBASE=CYC ADDR;            ! CYCLE. BASE REGISTER COVER
 6519              FLAGS=FLAGS!1;             ! IS PROVIDED BY CYC BASE
 6520           %FINISH
 6521  !
 6522  ! IF THE SHORT JUMP FLAG NOT SET THEN WE CAN TRY :-
 6523  ! A)     TO LOCATE A SUITABLE 4K MULTIPLE ALREADY IN A REGISTER
 6524  ! B)     TO FIND THE LABEL LURKING IN THE CYCLIC BUFFER.
 6525  ! IF THESE FAIL THEN AN 8 BYTE JUMP MUST BE PLANTED
 6526  !
 6527           %IF FLAGS&1=0 %THEN %START
 6528              FIND USE(I,1,11,\LAB)
 6529              %IF I>0 %THEN KREG=I+16 %ELSE %START
 6530                 LABLOOK(I,LAB) %IF CHECKSP=0 %AND CSSMODE#0
 6531                 FLAGS=FLAGS!1 %IF I=1
 6532              %FINISH
 6533           %FINISH
 6534           %IF FLAGS&1#0 %THEN %START
 6535              SET LOCAL BASE
 6536              BREG=  LOCAL BASE
 6537              BBASE= LOCAL ADDR
 6538              AT=CA;                     ! IN CASE BASE HAS BEEN SET
 6539           %FINISH %ELSE %START
 6540              %IF KREG=0 %THEN %START
 6541                 FIND REG(GR1,KREG)
 6542                 SET USE(KREG,11,\LAB)
 6543                 PRX(X'58',KREG,CODER,0,0)
 6544                 CYC BITS=CYC BITS!16;   ! 'USES MULTIPLE OF 4096' BIT SET
 6545              %FINISH
 6546           %FINISH
 6547  !
 6548  ! ENTER JUMP IN SUBLIST
 6549  !
 6550           %IF CSSMODE#0 %THEN %C
 6551+ PUSH(SHORT INTEGER(ADDR(ASLIST(CELL+6))),KREG<<24!AT,BREG<<24!BBASE)
 6552           PRX(X'47',MASK,KREG&15,0,0)
 6553           %END
 6554           %ROUTINE MERGE INFO
 6555  !***********************************************************************
 6556  !*       MERGE THE CURRENT STATUS OF GENERAL AND FLOATING REGISTERS    *
 6557  !*       WITH THOSE AT THE START OF THE CONDITIONAL CLAUSE. THUS       *
 6558  !*       THE COMPILER CAN REMEMBER UNCHANGED REGISTERS BUT NOT THOSE   *
 6559  !*       WHICH DEPEND ON A PARTICULAR RUN TIME ROUTE BEING TAKEN       *
 6560  !***********************************************************************
 6561  {%SHORTROUTINE}
 6562  %INTEGER I,J
 6563           %IF CSSMODE#0 %THEN %START; ! OMIT MERGE ON PRELIM PASS
 6564              %CYCLE J=0,1,14; I=GRMAP(J)
 6565              FORGET(I) %UNLESS SGRUSE(I)=GRUSE(I) %AND SGRINF(I)=GRINF(I)
 6566              %REPEAT
 6567           %FINISH
 6568           LCA=0;            ! NOTE LABEL
 6569           %END
 6570           %ROUTINE     REMEMBER
 6571           {%SHORTROUTINE}
 6572  !%if USE MC = 1 %start
 6573  !         *L_1,SGRUSE; *L_2,GRUSE; *MVC_0(92,1),0(2)
 6574  !         *L_1,SGRINF; *L_2,GRINF; *MVC_0(92,1),0(2)
 6575  !%finish
 6576           %END
 6577           %ROUTINE SET LOCAL BASE
 6578           {%SHORTROUTINE}
 6579  ! FIND OR SET UP A REGISTER FOR BRANCHING A SMALL DISTANCE FORWARD
 6580           %INTEGER I,J
 6581           LOCAL BASE=10; LOCAL ADDR=CODEBASE
 6582           ->Label2 %IF SBFLAG=1 %OR 4095-MARGIN>CA-CODEBASE
 6583           %IF CYC BASE#0 %THEN %START
 6584              LOCAL BASE=CYC BASE; LOCAL ADDR=CYC ADDR
 6585              ->Label2; %FINISH
 6586           %CYCLE J=14,1,24
 6587              I=J&15
 6588              -> SET %IF I>0 %AND GRUSE(I)=12
 6589           %REPEAT
 6590           FIND REG(ADDREG,LOCAL BASE)
 6591           PRR(5,LOCAL BASE,0)
 6592           LOCAL ADDR=CA
 6593           SET USE(LOCAL BASE,12,CA); ->Label2
 6594  SET:
 6595           LOCAL ADDR=GRINF(I)
 6596           LOCAL BASE=I
 6597           %IF 4095-MARGIN<CA-LOCAL ADDR %THEN %START
 6598                 FORGET(I)
 6599                 SET LOCAL BASE
 6600           %FINISH
 6601  Label2:       %END;                      ! OF ROUTINE SET LOCAL BASE
 6602           %ROUTINE CSNAME(%INTEGER Z,REG)
 6603           {%SHORTROUTINE}
 6604  !***********************************************************************
 6605  !*       COMPILE A SPECIAL NAME - PTYPE=10006 (=%ROUTINE %LABEL)       *
 6606  !*       THEIR TRUE PTYPE IS IN GLOBAL ARRAY TSNAME.                   *
 6607  !*       SNINFO HAS A FOUR BYTE RECORD FOR EACH NAME (%BI FLAG,PTR,    *
 6608  !*       %SI XTRA). THE TOP BITS OF FLAG CATEGORISE AS FOLLOWS:-       *
 6609  !*       2**7 SET FOR IMPLICITLY SPECIFIED CONSTRUCT A %SPEC           *
 6610  !*       2**6 SET FOR IOCP CALL                                        *
 6611  !*       2**5 SET FOR BUILT IN MAPPING FUNCTIONS                       *
 6612  !*       2**4 SET IF AD-HOC CODE PLANTED BY THIS ROUTINE               *
 6613  !*       2**3 SET IF FIRST PARAMETER IS OF %NAME TYPE                  *
 6614  !*       2**2-2**0 HOLD NUMBER OF PARAMS                               *
 6615  !*                                                                     *
 6616  !*       THE FULL SPECS ARE AS FOLLOWS:-                               *
 6617  !*       0=%ROUTINE SELECT INPUT(%INTEGER STREAM)                      *
 6618  !*       1=%ROUTINE SELECT OUTPUT(%INTEGER STREAM)                     *
 6619  !*       2=%ROUTINE NEWLINE                                            *
 6620  !*       3=%ROUTINE SPACE                                              *
 6621  !*       4=%ROUTINE SKIP SYMBOL                                        *
 6622  !*       5=%ROUTINE READ STRINWG(%STRINGNAME S)                        *
 6623  !*       6=%ROUTINE NEWLINES(%INTEGER N)                               *
 6624  !*       7=%ROUTINE SPACES(%INTEGER N)                                 *
 6625  !*       8=%INTEGERFN NEXT SYMBOL                                      *
 6626  !*       9=%ROUTINE PRINT SYMBOL(%INTEGER SYMBOL)                      *
 6627  !*       10=%ROUTINE READ SYMBOL(%NAME SYMBOL)                         *
 6628  !*       11=%ROUTINE READ(%NAME NUMBER)                                *
 6629  !*       12=%ROUTINE WRITE(%INTEGER VALUE,PLACES)                      *
 6630  !*       13=%ROUTINE NEWPAGE                                           *
 6631  !*       14=%INTEGERFN ADDR(%NAME VARIABLE)                            *
 6632  !*       15=%LONGREALFN ARCSIN(%LONGREAL X)                            *
 6633  !*       16=%INTEGERFN INT(%LONGREAL X)                               *
 6634  !*       17=%INTEGERFN INTPT(%LONRGREAL X)                             *
 6635  !*       18=%LONGREALFN FRACPT(%LONGREAL X)                            *
 6636  !*       19=%ROUTINE PRINT(%LONGREAL NUMBER,%INTEGER BEFORE,AFTER)     *
 6637  !*       20=%ROUTINE PRINTFL(%LONGREAL NUMBER,%INTEGER PLACES)         *
 6638  !*       21=%REALMAP REAL(%INTEGER VAR ADDR)                           *
 6639  !*       22=%INTEGERMAP INTEGER(%INTEGER VAR ADDR)                     *
 6640  !*       23=%LONGREALFN MOD(%LONGREAL X)                               *
 6641  !*       24=%LONGREALFN ARCCOS(%LONGREAL X)                            *
 6642  !*       25=%LONGREALFN SQRT(%LONGREAL X)                              *
 6643  !*       26=%LONGREALFN LOG(%LONGREAL X)                               *
 6644  !*       27=%LONGREALFN SIN(%LONGREAL X)                               *
 6645  !*       28=%LONGREALFN COS(%LONGREAL X)                               *
 6646  !*       29=%LONGREALFN TAN(%LONGREAL X)                               *
 6647  !*       30=%LONGREALFN EXP(%LONGREAL X)                               *
 6648  !*       31=%ROUTINE CLOSE STREAM(%INTEGER STREAM)                     *
 6649  !*       32=%BYTEINTEGERMAP BYTE INTEGER(%INTEGER VAR ADDR)            *
 6650  !*       33=%SHORTINTEGERMAP SHORTINTEGER(%INTEGER VARADDR)            *
 6651  !*       34=%LONGREALFN RADIUS(%LONGREAL X,Y)                          *
 6652  !*       35=%LONGREALFN ARCTAN(%LONGREAL X,Y)                          *
 6653  !*       36=%BYTEINTEGERMAP LENGTH(%STRINGNAME  S)                     *
 6654  !*       37=%ROUTINE PRINTSTRING(%STRING(255) MESSAGE)                *
 6655  !*       38=%INTEGERFN NL                                              *
 6656  !*       39=%LONGREALMAP LONG REAL(%INTEGER VAR ADDR)                  *
 6657  !*       40=%ROUTINE PRINT CH(%INTEGER CHARACTER)                      *
 6658  !*       41=%ROUTINE READ CH(%NAME CHARACTER)                          *
 6659  !*       42=%STRINGMAP STRING(%INTEGER VAR ADDR)                       *
 6660  !*       43=%ROUTINE READ ITEM(%STRINGNAME ITEM)                       *
 6661  !*       44=%STRING(1)%FN NEXT ITEM                                    *
 6662  !*       45=%BYTEINTEGERMAP CHARNO(%STRINGNAME STR,%INTEGER CHARREQD)  *
 6663  !*       46=%STRING(1)%FN TOSTRING(%INTEGER SYMBOL)                    *
 6664  !*       47=%STRING(255)%FN FROMSTRING(%STRING(255)S,%INTEGER BEG,END) *
 6665  !*       48=%RECORDMAP RECORD(%INTEGER REC ADDR)                       *
 6666  !*       49=%ARRAYMAP ARRAY(%INTEGER A1ADDR,%ARRAYNAME FORMAT)         *
 6667  !*       50=%ROUTINE SETMARGINS(%INTEGER INOUT,LHM,RHM)                *
 6668  !*       51=%INTEGERFN IMOD(%INTEGER VALUE)                            *
 6669  !*       52=%LONGREALFN PI                                             *
 6670  !*       53=%INTEGERFN NEXTCH                                          *
 6671  !***********************************************************************
 6672           %SWITCH ADHOC(1:12)
 6673           %CONSTINTEGERARRAY SNINFO(0:53)=%C
 6674+                     X'41080001',X'41090001',X'408A0001',X'40A00001',
 6675+                     X'40010001',X'800D0000',X'11010001',X'11010001',
 6676+                     X'10020024',X'41030001',X'19030001',X'80130053',
 6677+                     X'12040001',X'408C0001',X'19050024',X'80010049',
 6678+                     X'80010053',X'80010053',X'80010053',X'80090053',
 6679+                     X'80060053',X'2100003E',X'2100003E',X'11060024',
 6680+                     X'80010049'(4),
 6681+                     X'80010049'(3),X'80150000',
 6682+                     X'2100003E'(2),X'80030049'(2),
 6683+                     X'1907003E',X'41070001',X'10080024',X'2100003E',
 6684+                     X'41050001',X'19030001',X'2100003E',X'19030001',
 6685+                     X'10020024',X'1A07003E',X'11090024',X'800F0000',
 6686+                     X'110A8018',X'120B1000',X'80170000',X'11060024',
 6687+                     X'100C0024',X'10020024';
 6688  !
 6689  ! SNPARAMS HOLDS NUMBER AND PTYPE OF FORMAL PARAMETER FOR IMPLICITLY
 6690  ! SPECIFIED EXTERNAL ROUTINES. A POINTER IN SNINFO MEANS THAT NO
 6691  ! DUPLICATES NEED TO BE RECORDED.
 6692  !
 6693           %CONSTSHORTINTEGERARRAY SNPARAMS(0:26)=0,
 6694+                     1,32,       2,32,32,  2,32,1,
 6695+                     3,32,1,1,   1,1005,   3,1005,1,1,
 6696+                     1,1000,     1,1,      3,1,1,1;
 6697  !
 6698           %ROUTINESPEC RTOS(%INTEGER REG)
 6699           %BYTEINTEGER ERRNO,FLAG,POINTER
 6700           %SHORTINTEGER OPHEAD,OPBOT
 6701           %INTEGER PIN,SNNO,SNNAME,NAPS,SNPTYPE,JJ,%C
 6702+                   XTRA,IOCPEP,B,D,SNINF,P0
 6703  !
 6704           SNNAME=A(P)
 6705           SNNO=K;                       ! INDEX INTO SNINFO
 6706           TESTAPP(NAPS);                ! COUNT ACTUAL PARAMETERS
 6707           PIN=P; P=P+1
 6708           SNPTYPE=TSNAME(SNNO)
 6709           SNINF=SNINFO(SNNO)
 6710           XTRA=SNINF&X'FFFF'
 6711           POINTER<-SNINF>>16
 6712           FLAG=SNINF>>24
 6713  !
 6714  ! THE IMPLICITLY SPECIFIED ROUTINE ARE THE EASIEST OF ALL TO DEAL WITH.
 6715  ! JUST SET UP THE EXTERNAL SPEC & PARAMETERS. THEN A RECURSIVE CALL
 6716  ! OF CNAME THEN FINDS THE ROUTINE UNDER ITS TRUE COLOURS AND COMPILES
 6717  ! THE CALL. ALL CALLS EXCEPT THE FIRST ARE DEALT WITH DIRECTLY BY CNAME.
 6718  ! ALL NONTRIVIAL ROUTINES SHOULD BE DEALT WITH IN THIS MANNER
 6719  !
 6720           %IF FLAG&X'80'#0 %THEN %START
 6721              CXREF(0,A(PIN),XTRA,JJ);    ! JJ SET WITH REF DISPLACEMENT
 6722              OPHEAD=0; OPBOT=0; P0=SNPARAMS(POINTER)
 6723              SNDISP=JJ>>2; KFORM=P0
 6724              JJ=1; D=64
 6725              %WHILE JJ<=P0 %CYCLE
 6726                 PTYPE=SNPARAMS(POINTER+JJ)
 6727                ! UNPACK
 6728  !%if USE MC = 1 %start
 6729  !            *L_1,PTYPE; *CVD_1,0(11)
 6730  !            *UNPK_ROUT(5),5(3,11)
 6731  !            *NC_ROUT(5),MASK1
 6732  !%finish
 6733                 %IF NAM=0 %THEN ACC=BYTES(PREC) %ELSE ACC=4
 6734                 BINSERT(OPHEAD,OPBOT,PTYPE,ACC<<16!D,0)
 6735                 D=D+ACC
 6736                 JJ=JJ+1
 6737              %REPEAT
 6738              I=9; J=14
 6739              OLDI=0; PTYPE=SNPTYPE
 6740              K=OPHEAD
 6741              REPLACETAG(A(PIN))
 6742              P=PIN; CNAME(Z,REG);        ! RECURSIVE CALL
 6743              P=P-2; %RETURN;             ! DUPLICATES CHECK OF <ENAME>
 6744           %FINISH
 6745  !
 6746  ! ALL ROUTINES EXCEPT THE IMPLICITS REQUIRE A CHECH THAT THE USE OF THE
 6747  ! NAME IS LEGAL AND THAT THE CORRECT NO OF PARAMETERS(BOTTOM 2 BITS OF
 6748  ! FLAG) HAS BEEN SUPPLIED. THE CHECK IS TRIVIAL - THE PROBLEM
 6749  ! IS TO GET THE RIGHT ERROR NUMBER.
 6750  ! XTRA HAS A BITMASK OF ALLOWED USES(IE ALLOWED Z VALUES)
 6751  !
 6752           NEST=0
 6753           %IF NAPS#FLAG&3 %THEN ERRNO=19 %AND ->ERREXIT
 6754           JJ=1<<Z
 6755           %IF JJ&XTRA=0 %THEN %START;    ! ILLEGAL USE
 6756              ERRNO=23
 6757              %IF Z=0 %THEN ERRNO=17
 6758              %IF Z=1 %OR 3<=Z<=4 %THEN ERRNO=29
 6759              %IF XTRA&X'F000'#0 %THEN ERRNO=84
 6760              ->ERR EXIT
 6761           %FINISH
 6762  !
 6763  ! A NUMBER OF INPUT-OUTPUT ROUTINES ARE MAPPED ONTO CALLS OF IOCP.
 6764  ! THIS ARRANGEMENT HAS THE ADVANTAGE OF REQUIRING ONL 1 EXTERNAL REF
 6765  ! IN THE GLA BUT HAS THE DISADVANTAGE THAT THE I-O ROUTINES CAN NOT
 6766  ! BE PASSED AS RT-TYPE PARAMETERS AS WELL AS REQUIRING MESSY CODE
 6767  ! HEREABOUTS.  SNINF_PTR HOLD EITHER:-
 6768  !       1) THE IOCP ENTRY POINT NO
 6769  !   OR  2) THE SYMBOL TO BE OUTPUT WITH 2**7 BIT SET
 6770  !
 6771  ! THIS SECTION DEALS WITH SELECT INPUT,SELECT OUTPUT,NEWLINE,NEWPAGE
 6772  !                         SPACE,SKIP SYMBOL,PRINT SYMBOL,PRINTSTRING
 6773  !                         AND PRINT CH
 6774  !
 6775           %IF FLAG&X'40'#0 %THEN %START
 6776              IOCPEP=POINTER
 6777              %IF FLAG&3#0 %THEN %START;  ! RT HAS PARAMS
 6778                 P=P+1
 6779                 %IF SNNO=37 %THEN CSTREXP(1,1) %ELSE CSEXP(1,1)
 6780              %FINISH
 6781              %IF IOCPEP>127 %THEN %START
 6782                 DUMP(0,1,IOCPEP&127,0,0)
 6783                 %IF SNNO=3 %THEN IOCPEP=3 %ELSE IOCPEP=5
 6784              %FINISH
 6785              CIOCP(IOCPEP);              ! PLANT CALL OF IOCP
 6786              ->OKEXIT
 6787           %FINISH
 6788  !
 6789  ! THE BUILT-IN MAPS (INTEGER ETC BUT NOT RECORD OR ARRAY)
 6790  ! A SPECIAL MODE(13) IN CSEXP ALLOWS ADDR(I) TO BE EVALUATED TO
 6791  ! A BASE,INDEX &DISP RATHER THAN EVALUATED(IE THE FINAL LA IS OMITTED)
 6792  ! THIS ENABLES INTEGER(ADDR(I)) TO BE COMPLIED EXTREMELY EFFICIENTLY
 6793  !
 6794           %IF FLAG&X'20'#0 %THEN %START
 6795              %IF Z=1 %THEN CYC BITS=CYC BITS!1024 %C
 6796+                %AND BIMSTR=1;           ! SPECIAL FLAG FOR STORE VIA MAP
 6797              P=P+1; CSEXP(-1,13); P=P+1
 6798              %IF Z=1 %THEN BIMSTR=0
 6799              %IF NEST>=0 %THEN BASE=NEST %AND INDEX=0 %AND DISP=ADISP
 6800              SNPTYPE=11000+SNPTYPE;      ! ADD MAP BITS
 6801              ->OKEXIT
 6802           %FINISH
 6803  !
 6804  ! ADHOC CODING IS REQUIRED FOR THE REMAINING ROUTINES APART FROM
 6805  ! A CHECK FOR NAMETYPE PARAMETERS. THE SWITCH NO IS KEPT IN POINTER
 6806  !
 6807           %IF FLAG&3#0 %THEN P=P+1
 6808           %IF FLAG&8#0 %AND(A(P+2)#4 %OR A(P+3)#1 %OR %C
 6809+             A(P+A(P+1)+1)#2) %THEN ERRNO=22 %AND ->ERREXIT
 6810           ->ADHOC(POINTER)
 6811  ADHOC(1):                               ! NEWLINES(=6) & SPACES(=7)
 6812           CSEXP(2,1);                    ! REPITITION NO TO GR2
 6813           %IF SNNO=6 %THEN JJ=10 %ELSE JJ=32
 6814           PRX(X'41',1,0,0,JJ);           ! LA 1,SYMBOL
 6815           PPJ(14);                       ! PERM OPUTS R1 R2 TIMES
 6816           ->OKEXIT
 6817  ADHOC(2):                               ! NEXTSYMBOL(=8) & NEXTITEM(=44)
 6818                                          ! AND NEXTCH=53
 6819           SAVE IRS(4);                   ! PRESERVE ANY INTERMEDIATES
 6820           CLAIM THIS REG(0);             ! FORCE PRESERVATION OF GR0
 6821           FREE AND FORGET(0);            ! SINCE THESE FNS CAN BE IN EXPN
 6822           %IF SNNO=53 %THEN JJ=18 %ELSE JJ=2
 6823           CIOCP(JJ);                     ! LEAVES THE SYMBOL IN GR1
 6824           %IF SNNO#44 %THEN %START;       ! NEXT SYMBOL
 6825              %IF 1#REG>=0 %THEN PRR(X'18',REG,1) %ELSE NEST=1
 6826           %FINISH %ELSE RTOS(1);         ! CONVERT R1 TO STRING
 6827           ->OKEXIT
 6828  ADHOC(3):                               ! READSYMBOL(=10),CH(=41)&ITEM(=43)
 6829           %IF SNNO=41 %THEN JJ=4 %ELSE JJ=1
 6830           CIOCP(JJ);                     ! SYMBOL OR CH TO GR1
 6831           P=P+4
 6832           %IF SNNO=43 %THEN TYPE=5 %AND RTOS(1) %ELSE %START
 6833              REGISTER(1)=1; TYPE=1
 6834              BASE=1; DISP=-2
 6835           %FINISH
 6836           JJ=TYPE
 6837           COPYTAG(A(P));                  !PARAMETER NAME
 6838           %IF TYPE # JJ %THEN %START
 6839             ERRNO = 22
 6840             -> ERREXIT
 6841           %FINISH
 6842           ASSIGN(6,P);                   ! BY '=' TO PARAMETER
 6843           P=PIN+4+A(PIN+3)
 6844           ->OKEXIT
 6845  ADHOC(4):                               ! WRITE(=12). SHOULD BE EXTERNAL
 6846           DSEXP(1,1)
 6847           REGISTER(1)=0; REGISTER(2)=0
 6848           PPJ(4)
 6849           ->OKEXIT
 6850  ADHOC(5):                               ! ADDR(=14)
 6851           P=P+4; CNAME(4,REG);           ! FETCH ADDRESS MODE
 6852           P=P+1; ->OKEXIT
 6853  ADHOC(6):                               ! MOD(=23), IMOD(=51)
 6854           %IF SNNO=51 %THEN JJ=1 %ELSE JJ=3
 6855           CSEXP(REG,JJ);                 ! INTEGER OR LONGREAL MODE
 6856           %IF SNNO=51 %THEN JJ=0 %ELSE JJ=16
 6857           REG=NEST
 6858           PRR(X'10'+JJ,REG,REG);         ! LP(D)R REG,REG
 6859           FORGET(REG+JJ)
 6860           ->OKEXIT
 6861  ADHOC(7):                               ! CHARNO(=45) & LENGTH(=36)
 6862           P=P+4; COPY TAG(A(P))
 6863           %IF ROUT=0=NAM %AND ARR=0 %AND A(P+1)=2=A(P+2) %START
 6864              P=P+3; BASE=I; DISP=K
 6865           %FINISH %ELSE %START
 6866              FINDREG(SAFE,JJ)
 6867              CNAME(4,JJ)
 6868              BASE=JJ; DISP=0
 6869           %FINISH
 6870           P=P+2
 6871           ERRNO=22; ->ERREXIT %UNLESS TYPE=5
 6872           %IF SNNO=36 %THEN INDEX=0 %ELSE %START
 6873              D=DISP; B=BASE
 6874              REGISTER(B)=1 %IF REGISTER(B)=0
 6875              CSEXP(-1,5)
 6876              P=P+1
 6877              REGISTER(B)=0 %IF REGISTER(B)=1
 6878              DISP=D+ADISP; BASE=B
 6879              INDEX=NEST
 6880           %FINISH
 6881           SNPTYPE=SNPTYPE+11000
 6882           ->OKEXIT
 6883  ADHOC(12):                              ! PI(=52)
 6884  ADHOC(8):                               ! NL(=38). THIS FN IS PICKED OFF
 6885           NEST=0;                        ! IN CSEXP.ONLY COMES HERE IN
 6886           PTYPE=SNPTYPE;! UNPACK
 6887  !%if USE MC = 1 %start
 6888  !            *L_1,PTYPE; *CVD_1,0(11)
 6889  !            *UNPK_ROUT(5),5(3,11)
 6890  !            *NC_ROUT(5),MASK1
 6891  !%finish
 6892           NAM=2; ROUT=1
 6893           ->OKEXIT;                      ! ERROR EG NL=A+B
 6894  ADHOC(9):                               ! TOSTRING(=46)
 6895           CSEXP(-1,1);                   ! RET EXPSN
 6896           RTOS(NEST)
 6897           INDEX=0; ->OKEXIT
 6898  ADHOC(10):                              ! RECORD(=48)
 6899           CSEXP(REG,1)
 6900           REG=NEST %IF REG<0
 6901           REGISTER(REG)=1 %IF REGISTER(REG)>=0
 6902           ->OKEXIT
 6903  ADHOC(11):                              ! ARRAY(=49)
 6904           %UNLESS 4<=REG<=14 %THEN FINDREG(SAFE,REG)
 6905           CSEXP(REG,1);                  ! ADDR(A(0)) TO GR REG
 6906           REGISTER(REG)=1
 6907           ERRNO=22
 6908           ->ERREXIT %UNLESS A(P+3)=4 %AND A(P+4)=1
 6909           P=P+5; CNAME(12,0)
 6910           ->ERREXIT %UNLESS A(P)=2 %AND ARR>0
 6911           CREATE AH(0,REG,BASE,DISP)
 6912           ARR=1;                              ! ERRORS REPORTED IF ARR=3
 6913           REGISTER(REG)=0
 6914           %RETURN
 6915  OKEXIT:                                 ! NORMAL EXIT
 6916           PTYPE=SNPTYPE;! UNPACK
 6917  !%if USE MC = 1 %start
 6918  !            *L_1,PTYPE; *CVD_1,0(11)
 6919  !            *UNPK_ROUT(5),5(3,11)
 6920  !            *NC_ROUT(5),MASK1
 6921  !%finish
 6922           %RETURN
 6923  ERREXIT:                                ! ERROR EXIT
 6924           FAULT(ERRNO,SNNAME)
 6925           BASE=0; DISP=0; INDEX=0
 6926           P=PIN+1; SKIP APP
 6927           PTYPE=SNPTYPE;! UNPACK
 6928  !%if USE MC = 1 %start
 6929  !            *L_1,PTYPE; *CVD_1,0(11)
 6930  !            *UNPK_ROUT(5),5(3,11)
 6931  !            *NC_ROUT(5),MASK1
 6932  !%finish
 6933           P=P-1; %RETURN
 6934           %ROUTINE RTOS(%INTEGER REGNO)
 6935  !***********************************************************************
 6936  !*       PLANTS CODE TO CONVERT A SYMBOL IN REGNO TO A ONE             *
 6937  !*       CHARACTER STRING IN A TEMPORARARY VARIABLE.                   *
 6938  !***********************************************************************
 6939           %INTEGER KK
 6940           GET WSP(KK,1);               ! GET 1 WORD WK AREA
 6941           STRINGL=1; DISP=KK+2
 6942           DUMP(X'50',REGNO,KK,0,RBASE)
 6943           DUMPSI(X'92',1,RBASE,DISP);  ! MVI LENGTH BYTE
 6944           BASE=RBASE; INDEX=0
 6945           %END
 6946           %END;                        ! OF ROUTINE CSNAME
 6947           %ROUTINE     CIOCP(%INTEGER N)
 6948           %INTEGER AT
 6949           %IF IOCP1<10 %THEN %START
 6950              CXREF(0,-1,0,AT);             ! INSERT IOCP XREF
 6951              IOCP1=AT
 6952           %FINISH
 6953           PCONST(X'41000000'!N)
 6954           CRCALL(-1)
 6955           %END
 6956           %ROUTINE LOAD DV(%INTEGER %NAME REG,%INTEGER B,D,TN)
 6957           {%SHORTROUTINE}
 6958  !***********************************************************************
 6959  !*       FIND A REGISTER AND LOAD IT WITH POINTER TO D.V. B,D FOR      *
 6960  !*       ARRAYHEAD   TN=TAGS(NAME). NECESSARY TO PASS B&D ALSO IN CASE *
 6961  !*       OF ARRAYNAMES IN RECORDS WHEN TN<0. NO CHECK IS MADE THAT NAME*
 6962  !*       IS CORRECTLY DEFINED                                          *
 6963  !***********************************************************************
 6964           %INTEGER R
 6965           R=-1
 6966           %IF TN>0 %THEN FIND USE(R,1,10,TN)
 6967           %IF R<=0 %THEN %START;       ! REGISTER MUST BE SET
 6968              FIND REG(ADDREG,R)
 6969              DUMP(X'58',R,D+8,0,B)
 6970              %IF TN>0 %THEN SET USE(R,10,TN) %ELSE FORGET(R)
 6971           %FINISH
 6972           REG=R
 6973           %END
 6974           %ROUTINE     CANAME(%INTEGER ARRP,BS,DP,BASIC DISP)
 6975  !***********************************************************************
 6976  !*       BS & DP DEFINE THE POSITION OF THE ARRAY HEAD                 * 
 6977  !*       ARRP=1 FOR ARRAYS,2 FOR VECTORS,3 FOR ARRAYS IN RECORDS       *
 6978  !*       BASIC DISP = DISPMNT OF A(0) FOR VECTORS OR ARRAYS IN RECORDS *
 6979  !*       IN-LINE CODE IS PLANTED IF PARM=NOARRAY IS REQUESTED          *
 6980  !*       OTHERWISE CALLS ARE MADE ON CHECKING SUBROUTINES IN PERM      *
 6981  !***********************************************************************
 6982           {%SHORTROUTINE}
 6983           %INTEGER DVREG,OPTYPE
 6984           %SHORTINTEGER HEAD1,HEAD2,HEAD3,NOPS,BOT1,BOT2,BOT3
 6985           %INTEGER PTYPEP,KK,RR,PP,JJ,JJJ,XTYPE,TYPEP,ARRNAME
 6986           %INTEGER KKK,DIS,Q,PRECP,ELSIZE,BASEREG,NAMINF
 6987           PP=P; TYPEP=TYPE
 6988           JJ=J; PTYPEP=PTYPE; PRECP=PREC
 6989           %IF TYPE<=2 %OR TYPE=6 %THEN ELSIZE=BYTES(PRECP) %C
 6990+                                 %ELSE ELSIZE=ACC
 6991           ARRNAME=A(P);                   ! NAME OF ENTITY
 6992           NAMINF=TAGS(ARRNAME)
 6993           FAULT(29,ARRNAME) %IF ARR=3;    ! ARRAYFORMAT USED AS ARRAY
 6994           NAMINF=-2 %IF ARRP>2 %OR TYPE=6;! SWITCHES&ARRAYS IN RECORDS 
 6995           ARRP=ARRP&X'F';                 ! NOT OPTIMISED
 6996           TEST APP(Q);                    ! COUNT NO OF SUBSCRIPTS
 6997  !
 6998  ! CHECK CORRECT NO OF SUBSCRIPTS PROVIDED. HOWEVER ENTITIES DECLARED
 6999  ! AS %<TYPE>ARRAYNAME HAVE NO DIMENSION . THIS SECTION SETS THE
 7000  ! DIMENSION FROM THE FIRST USE OF THE NAME.
 7001  !
 7002           %IF JJ=0 %THEN %START;        ! 0 DIMENSIONS = NOT KNOWN
 7003              REPLACE1(TCELL,FROM1(TCELL)!Q);! DIMSN IS BOTTOM 4 BITS OF TAG
 7004              JJ=Q
 7005           %FINISH
 7006           %IF JJ>2 %THEN CYC BITS=CYCBITS!128; ! XTRA REG FOR DV BASE
 7007           %IF JJ=Q#0 %AND CHECKS=0 %THEN %START;  ! IN LINE CODE
 7008  !
 7009  ! FOR IN-LINE CODE WE SET UP A CHAIN OF REVERSE POLISH OPERATIONS TO
 7010  ! EVALUATE THE VARIOUS SUBSCRIPTS,MULTIPLY BY THE MULTIPLIERS AND
 7011  ! ADD THEM TOGETHER. THE FINAL OPERATION IS TO CONVERT FROM ELEMENTS
 7012  ! TO BYTES. THIS LAST OPERATION IS DONE FIRST.
 7013  !
 7014  !%if USE MC = 1 %start
 7015  !         *XC_DVREG(16),DVREG;          ! CLEAR LISTHEADS
 7016  !%finish
 7017           XTYPE=0; BOT3=0
 7018           %IF PRECP#1 %THEN %START;     ! BYTE ARRAYS - NO FINAL MULTIPLY
 7019              XTYPE=1;                   ! NOTE 1 XTRA OPERATION
 7020              %IF TYPEP=5 %AND NAM#0 %THEN %START; ! ELSIZE NOT KNOWN
 7021                 OPTYPE=3; JJJ=BS
 7022                 KKK=DP<<16!2;           ! OPERAND 2ND HALFWORD OF DP
 7023                 ELSIZE=0
 7024              %FINISH %ELSE %START;      ! ELSIZE KNOWN
 7025                  OPTYPE=0; JJJ=0
 7026                  KKK=ELSIZE;            ! OPERAND A CONSTANT
 7027              %FINISH
 7028              PUSH(HEAD3,28,0);          ! OPERATOR  (=MH)
 7029              %IF BOT3=0 %THEN BOT3=HEAD3
 7030             PUSH123(HEAD3,((OPTYPE&1)*20+1)<<16!JJJ<<8!OPTYPE,KKK,NAMINF)
 7031           %FINISH
 7032  !
 7033  ! NOW PROCESS THE SUBSCRIPTS CALLINR TORP TO CONVERT THE EXPRESSIONS
 7034  ! TO REVERSE POLISH AND ADDING THE EXTRA OPERATIONS. IF THE FIRST
 7035  ! SUBSCRIPT IS A CONSTANT AND THE ITEM LENGTH IS KNOWN AT COMPLIE TIME
 7036  ! THE OPERATION CAN BE SUPPRESSED AND THE CONSTANT TRANSFERRED TO THE
 7037  ! DISPLACEMENT FIELD OF THE FINAL INSTRUCTION. THIS SAVES 8 BYTES.
 7038  ! A SPECIAL MODE (5) FOR TORP TRANSFERS ANY CONSTANT TO GLOBAL ADISP
 7039  !
 7040           P=PP+2; JJJ=5;                ! MODE FOR TORP FOR 1ST EXPRSN
 7041           %IF TYPEP=5 %AND ELSIZE=0 %THEN JJJ=1; ! ADDR OR NORMAL MODE
 7042           %CYCLE KK=1,1,JJ;             ! THROUGH THE SUBSCRIPTS
 7043              P=P+2; BOT2=0
 7044              TORP(HEAD2,BOT2,NOPS,JJJ); ! SUBSCRIPT TO REVERSE POLISH
 7045              P=P+1
 7046  !
 7047  ! TWO DIMENSION ARRAYS HAVE THE MULTIPLIER IN WORD 4 OF HEAD
 7048  ! ALL OTHER MULTIPLIERS ARE DOPE VECTOR ITEMS (OPTYPE=3)
 7049  !
 7050              %IF JJ=2 %THEN OPTYPE=9 %AND RR=DP+14 %ELSE %START
 7051                 OPTYPE=3; RR=(12*KK-10)!(DP<<16)
 7052              %FINISH
 7053  !
 7054  ! N SUBSCRIPTS WILL REQUIRE (N-1) MULTIPLICATIONS AND ADDITIONS
 7055  !
 7056              %IF KK>1 %THEN %START
 7057                 NOPS=NOPS+2
 7058                 PUSH(HEAD3,15,0) %IF HEAD1#0;! 15=ADD
 7059                 %IF BOT3=0 %THEN BOT3=HEAD3
 7060  !
 7061  ! N.B. THE FIRST SUFFIX CAN BE OPTIMISED OUT OF EXISTENCE IF IT IS
 7062  ! A SHORT CONSTANT AND THE CORRESPONDING ADDITION MUST THEN BE OMITTED
 7063  !
 7064                 PUSH(HEAD3,28,0);       ! MH
 7065                 %IF BOT3=0 %THEN BOT3=HEAD3
 7066                 PUSH123(HEAD3,21<<16!BS<<8!OPTYPE,RR,NAMINF);! MULTIPLIER
 7067              %FINISH %ELSE DIS=ADISP*ELSIZE
 7068              JJJ=1;                     ! SBSCRPTS XCEPT 1ST NORMAL MODE
 7069  !            CONCAT (HEAD1,HEAD2);      ! OPERANDS TO MAIN LIST
 7070              %IF HEAD1=0 %THEN HEAD1=HEAD2 %ELSE %C
 7071+                SHORTINTEGER(ADDR(ASLIST(BOT1))+14)=HEAD2
 7072              BOT1=BOT2; HEAD2=0
 7073           %REPEAT
 7074  !
 7075  ! ADD OPERATORS TO THE BACK OF OPERANDS AND EVALUATE
 7076  !
 7077           CLEAR LIST(HEAD3) %IF HEAD1=0;! THROW AWAY OPERATORS IF NO OPND
 7078  !         CONCAT(HEAD1,HEAD3);          ! OPERATORS  LINKED ON
 7079           %IF HEAD3#0 %START
 7080              SHORTINTEGER(ADDR(ASLIST(BOT1))+14)=HEAD3
 7081              BOT1=BOT3
 7082           %FINISH
 7083           PP=P; NOPS=NOPS+XTYPE
 7084           EXPOP(HEAD1,-1,NOPS,5);       ! EVALUATE THE REVERSE POLISH LIST
 7085           P=PP
 7086           DISP=DIS; INDEX=NEST
 7087  !
 7088  ! REGISTER INDEX AND DSIPLACEMENT NOW DEFINE THE ARRAY RELATIVE POSITION
 7089  ! OF REQUIRED ELEMENT. ALL THAT REMAINS IS TO SET UP OR FIND A SUITABLE
 7090  ! BASE REGISTER TO POINT TO A(0).
 7091  !
 7092  !         CLEAR LIST(HEAD1);            ! RETURN SPACE
 7093           %IF HEAD1#0 %START
 7094              SHORTINTEGER(ADDR(ASLIST(BOT1))+14)=ASL
 7095              ASL=HEAD1
 7096           %FINISH
 7097           %IF ARRP>=2 %THEN %START;     ! VECTOR ACCESED VIA LEVEL POINTER
 7098              DISP=DISP+BASIC DISP
 7099              BASE=BS
 7100           %FINISH %ELSE %START
 7101              FIND USE(BASE,1,8,NAMINF)
 7102              %IF BASE<=0 %START;        ! BASE REG NOT ALREADY SET
 7103                 REGISTER(INDEX)=1 %IF INDEX#0 %AND REGISTER(INDEX)=0
 7104                 FIND REG(ADDREG,BASE)
 7105                 DUMP(X'58',BASE,DP,0,BS);!  L  BASE,=A(A(0))
 7106                 REGISTER(INDEX)=0 %IF INDEX#0 %AND REGISTER(INDEX)>0
 7107                 %IF NAMINF <0 %THEN FORGET(BASE) %ELSE %C
 7108+                                   SET USE(BASE,8,NAMINF)
 7109              %FINISH
 7110           %FINISH
 7111           %FINISH %ELSE %START
 7112           %IF JJ#Q %OR Q=0 %THEN %START;! DIMENSIONALITY ERROR
 7113              FAULT(19,ARRNAME)
 7114              P=P+1; SKIP APP
 7115              BASE=15
 7116           %FINISH %ELSE %START
 7117  !
 7118  ! THREE DIFFERENT SUBROUTINES ARE USED:-
 7119  ! PERM7 CHECKS SWITCHES WITH GR1 HOLDING SUFFIX &GR2 POINTING AT VECTOR
 7120  ! PERM23 CHECKS 1D ARRAYS. GR1 HAS SUFFIX & GR3 POINTS TO ARRAYHEAD
 7121  ! PERM24 CHECKS MULTI-DIMENSION ARRAYS. GR1 POINT TO BACK OF LIST OF
 7122  !         SUFFICES AND GR2 POINT TO ARRAYHEAD
 7123  !
 7124              DIS=0; P=PP+2
 7125              CLAIM THIS REG(1);         ! FORCE PRESERVATION OF CONTENTS
 7126              REGISTER(1)=0
 7127              %IF JJ=1 %THEN %START;     ! 1D+SWITCHES
 7128                 CSEXP(1,1); P=P+1
 7129              %FINISH %ELSE %START
 7130                                         ! MULTI-DIMENSION 
 7131                 GET WSP(RR,JJ)
 7132                 %CYCLE PP=0,1,JJ-1;     ! THROUGH LIST OF SUFFICES
 7133                    CSEXP(-1,1); P=P+1;  ! EVALUATE SUFFIX
 7134                    DUMP(1,NEST,RR+PP<<2,0,RBASE);! AND PUT INTO WK-AREA
 7135                 %REPEAT
 7136                 DUMP(0,1,RR+PP<<2,0,RBASE);!LA  1,<BACK OF WORK AREA>
 7137                 FORGET(1)
 7138              %FINISH
 7139              %IF JJ=1 %AND TYPEP#6 %THEN JJJ=3 %ELSE JJJ=2
 7140              REGISTER(1)=1;             ! PROTECT REG ALREADY SET
 7141              CLAIM THIS REG(JJJ)
 7142              REGISTER(JJJ)=0
 7143              %IF TYPEP=6 %THEN BS=0 %AND DP=BASIC DISP;!SWITCHES SPECIAL
 7144              DUMP(0,JJJ,DP,0,BS);       ! ADDR HEAD TO GR3(1D) OR GR2(MD)
 7145              %IF TYPEP=6 %THEN PRX(X'5A',2,GLA,0,0) %AND JJJ=19
 7146              REGISTER(1)=0
 7147              PPJ(26-JJJ);               ! TO CHECKING SUBROUTINE
 7148              BASE=15
 7149              %IF ARRP=3 %THEN PRR(X'1A',1,15) %AND BASE=0
 7150           %FINISH
 7151           INDEX=1; DISP=0
 7152           %FINISH
 7153           ACC=ELSIZE
 7154           PTYPE=PTYPEP;! UNPACK
 7155  !%if USE MC = 1 %start
 7156  !            *L_1,PTYPE; *CVD_1,0(11)
 7157  !            *UNPK_ROUT(5),5(3,11)
 7158  !            *NC_ROUT(5),MASK1
 7159  !%finish
 7160           J=JJ
 7161           %END;
?BASEREG unused
?DVREG unused
 7162                ;                         ! OF ROUTINE CANAME
 7162  
 7163  %ROUTINE CNAME(%INTEGER Z, REG)
 7164  !***********************************************************************
 7165  !*       THIS IS THE MAIN ROUTINE FOR PROCESSING NAMES.CANAME,CSNAME   *
 7166  !*       AND CRNAME ARE ONLY CALLED FROM HERE,THE NAME (AND ANY PARAMS *
 7167  !*       OR SUBNAMES) ARE INDEXED BY P WHICH IS ADVANCED.              *
 7168  !*       Z SPECIFIES ACTION AS FOLLOWS:-                               *
 7169  !*       Z=0 COMPILE A ROUTINE CALL                                    *
 7170  !*       Z=1 SET BASE,INDEX AND DISP FOR A 'STORE' OPERATION           *
 7171  !*       Z=2 FETCH NAME TO 'REG'                                       *
 7172  !*       Z=3 SET ADDR(NAME) IN REG FOR PASSING BY NAME (TOP BYTE SET)  *
 7173  !*       Z=4 AS FOR Z=3 BUT TOP BYTE MUST BE CLEAR (USED FOR 'ADDR' FN)*
 7174  !*       Z=5 IF NAME IS IN A REGISTER THEN AS Z=2 ELSE SET BASE ETC    *
 7175  !*       Z=6 STORE 'REG' (CONTAINS POINTER) INTO POINTER VARIABLE      *
 7176  !*       Z=7->Label11  NOT NOW USED                                         *
 7177  !*       Z=12 SET BASE AND DISP TO POINT TO ARRAYHEAD                  *
 7178  !*       Z=13 SET REG TO POINT TO 4 WORD ROUTINE DISCRIPTOR            *
 7179  !*              (INTERNAL ROUTINES FIRST CREATE THE DISCRIPTOR)        *
 7180  !*       Z=14 STORE 'REG' INTO A RECORD NAME VARIABLE                  *
 7181  !*       Z=15 SET 'REG' TO POINT TO A RECORD                           *
 7182  !*       Z=16 SET BASE AND DISP (BUT NOT INDEX) FOR RECORD             *
 7183  !*                                                                     *
 7184  !*       REG (WHERE APPROPRIATE) IS SET AS FOLLOWS:-                   *
 7185  !*       >=0  A REGISTER                                               *
 7186  !*       -1   MEANS CHOOSE ANY REGISTER                                *
 7187  !*       -2   MEANS CHOOSE ANY REGISTER EXCEPT GR0                     *
 7188  !*       IF A REGISTER IS CHOSEN THEN NEST IS SET WITH CHOICE          *
 7189  !***********************************************************************
 7190  %INTEGER JJ, JJJ, KK, RR, LEVELP, DISPP, REGP, NAMEP, PP, SAVESL,  %C
 7191+             FNAME
 7192  %LONGREAL WORK
 7193  %SWITCH S, FUNNY(12:16), SW(0:8), MOD(0:7)
 7194           FNAME=A(P)
 7195  Label2:       TCELL=TAGS(FNAME)
 7196  !%if USE MC = 1 %start
 7197  !         *L_1,TCELL; *LTR_1,1; *BC_8,<4>
 7198  !         *XC_PTYPE(20),PTYPE
 7199  !         *A_1,ASLIST
 7200  !         *UNPK_WORK(5),2(3,1)
 7201  !         *LH_0,0(1,0)
 7202  !         *ST_0,PTYPE
 7203  !         *MVN_USEBITS+3(1),WORK
 7204  !         *MVN_OLDI+3(1),WORK+1
 7205  !         *MVN_I+3(1),WORK+2
 7206  !         *MVN_J+3(1),WORK+3
 7207  !         *OI_2(1),X'80';                ! SET USE BIT
 7208  !         *MVC_SNDISP(8),4(1)
 7209  !         *CVD_0,WORK
 7210  !         *UNPK_ROUT(5),WORK+5(3)
 7211  !         *NC_ROUT(5),MASK1
 7212  !%finish
 7213           SAVESL=ACC
 7214           %IF CSSMODE=0 %AND ROUT=0 %THEN OPTSAVE(2,Z,PTYPE,FNAME)
 7215           ->Label3
 7216  Label4:       FAULT(16, FNAME)
 7217           I=LEVEL;  J=0;  K=FNAME
 7218           PTYPE=7;  STORE TAG(K, N)
 7219           K=N;  N=N+4;  ->Label2
 7220  Label3:       JJ=J;  JJ=0 %IF JJ=15
 7221           NAMEP=TCELL
 7222           LEVELP=I;  DISPP=K
 7223           FAULT(29, FNAME) %IF PREC>3 %AND             %C
 7224+                     (Z=1 %OR ((Z=3 %OR Z=4) %AND ARR=0))    %AND REG#99
 7225           PREC=PREC&3
 7226           ->Label502 %IF TYPE=7
 7227           ->Label500 %IF Z=0 %AND (ROUT#1 %OR 0#TYPE#6)
 7228           ->FUNNY(Z) %IF Z>=10
 7229           ->RTCALL %IF ROUT=1
 7230           ->SW(TYPE)
 7231  Label500:
 7232           FAULT(17, FNAME) %UNLESS TYPE=7;  ->Label502
 7233  SW(6):
 7234  
 7235  SW(4):                                  !RECORD FORMAT NAME
 7236           FAULT(20, FNAME)
 7237  SW(7):
 7238  
 7239  Label502:     P=P+1;                         ! NAME NOT SET
 7240           NEST=0;  BASE=I;  DISP=K;  INDEX=0
 7241           PTYPE=1; ! UNPACK
 7242  !%if USE MC = 1 %start
 7243  !            *L_1,PTYPE; *CVD_1,0(11)
 7244  !            *UNPK_ROUT(5),5(3,11)
 7245  !            *NC_ROUT(5),MASK1
 7246  !%finish
 7247           SKIP APP;  ->Label1
 7248  FUNNY(12):                              ! SET BASE & DISP FOR ARRAYHEAD
 7249           ->SW(3) %IF TYPE=3 %AND (ARR=0 %OR A(P+1)=1)
 7250           ->Label1202 %IF PTYPE=SNPT
 7251           BASE=I;  INDEX=0;  DISP=K
 7252  S(12):                                  ! ARRAYS IN RECORDS BY NAME
 7253           FAULT(219, FNAME) %UNLESS INDEX=0
 7254           %UNLESS 0<=DISP<=4095 %THEN ADJUST INDEX(0, BASE, DISP)
 7255           ->Label91
 7256  Label1202:    CSNAME(12, REG);  ->Label91
 7257  FUNNY(13):                              ! LOAD ADDR FOR RT-TYPE
 7258           %IF PTYPE=SNPT %THEN ->Label1302
 7259           ->Label500 %UNLESS ROUT=1
 7260           DISP=4*(SNDISP&X'FFFF')
 7261           %IF NAM&1#0 %THEN %START
 7262              BASE=I; JJJ=X'58'
 7263           %FINISH %ELSE %START
 7264              %IF J=14 %THEN BASE=GLA %ELSE %START;! INTERNAL
 7265                 GET WSP(DISP, 4)
 7266                 JJJ=14;  %IF REGISTER(14)#0 %THEN FIND REG(GR1, JJJ)
 7267                 RT JUMP(X'41', JJJ, TCELL, JJJ)
 7268                 DUMPM(X'90', 12, 13, RBASE, DISP)
 7269                 PRX(X'50', JJJ, 0, RBASE, DISP+8)
 7270                 PRX(X'50', WSPR, 0, RBASE, DISP+12)
 7271                 BASE=RBASE
 7272                 FORGET(JJJ)
 7273              %FINISH
 7274              JJJ=X'41'
 7275           %FINISH
 7276           DUMP(JJJ, REG, DISP, 0, BASE)
 7277           NEST=REG %IF REG>=0;  ->Label91
 7278  Label1302:    CSNAME(Z, REG);  ->Label6
 7279  S(14):   FAULT(67, FNAME) %UNLESS TYPE=3 %AND ARR=0
 7280           P=P-2;  ->Label602
 7281  Label1401:    FAULT(67, FNAME) %UNLESS TYPE=7;  ->Label502
 7282  S(16):
 7283  
 7284  S(15):   ->Label1401 %UNLESS TYPE=3
 7285           P=P+1
 7286           %IF Z=16 %AND INDEX=0 %AND DISP<=4095 %AND NAM=0 %THEN ->Label9005
 7287           P=P-3;  KK=3;  ->Label605 %IF Z=15
 7288           KK=1;  ->Label605 %IF NAM=1
 7289           DUMP(0, REG, DISP, INDEX, BASE)
 7290           REG=NEST %IF REG<0
 7291           DISP=0;  INDEX=0;  BASE=REG
 7292           FORGET(REG);  P=P+3;  ->Label9005
 7293  FUNNY(15):                              ! FETCH RECORD NAME
 7294           ->Label1302 %IF PTYPE=SNPT
 7295  FUNNY(16):                              ! SET BASE & DISP
 7296  FUNNY(14):                              ! STORE INTO RECORD NAME
 7297           PP=P;  ->Label1401 %UNLESS TYPE=3
 7298  SW(3):                                 ! RECORD
 7299           %IF NAM=1 %AND ARR=0 %THEN JJJ=1 %ELSE JJJ=0
 7300           CRNAME(Z, REG, JJJ, NAMEP, I, 0, K)
 7301           ->S(Z) %IF Z>=10
 7302           ->Label5020 %IF TYPE=5
 7303           ->Label502 %IF TYPE=7
 7304           ->Label601
 7305  SW(5):                                  ! TYPE =STRING
 7306  !        1) STRINGS ARE NEVER IN REGISTERS
 7307  !        2) BML &DML MUST BE SET ON Z=1
 7308  !        3) TOP BYTE MUST BE SET ON Z=3
 7309  !        4) TOP BYTE MUST BE CLEARED  ON Z=4
 7310           ->STRARR %IF ARR>=1
 7311           BASE=I;  INDEX=0;  DISP=K
 7312  Label5001:    %IF NAM=1 %THEN %START
 7313              BML=BASE;  DML=DISP;        ! LMAX IN TOP BYTE OF POINTER
 7314           %FINISH %ELSE %START
 7315              BML=-1;  DML=SAVESL-1
 7316           %FINISH
 7317  Label5002:    ->Label601 %UNLESS Z=3 %AND NAM=0
 7318           DUMP(0, REG, DISP, INDEX, BASE)
 7319           REG=NEST %IF REG<0
 7320           FORGET(REG);  JJJ=DML<<24
 7321           STORE CONST(JJ, KK, 4, ADDR(JJJ))
 7322           REGP=REGISTER(REG); REGISTER(REG)=1
 7323           DUMP(X'56', REG, KK, 0, JJ);   !  0  REG,=MAXL<<24
 7324           REGISTER(REG)=REGP
 7325           ->Label9
 7326  STRARR:                                 ! STRINGARRAYS & 
 7327                                          !STRINGARRAYNAMES
 7328           CANAME(ARR, I, K, SNDISP)
 7329           BML=-1;  DML=SAVESL-1
 7330  Label5111:    %IF NAM=1 %AND (Z=1 %OR Z=3) %THEN %START
 7331              %IF Z=1 %THEN %START
 7332                 REGISTER(BASE)=1 %IF REGISTER(BASE)=0
 7333                 REGISTER(INDEX)=1
 7334              %FINISH %ELSE %START
 7335                 DUMP(0, REG, DISP, INDEX, BASE)
 7336                 REG=NEST %IF REG<0
 7337                 FORGET(REG)
 7338                 REGISTER(REG)=1
 7339              %FINISH
 7340              LOAD DV(RR, LEVELP, DISPP, NAMEP)
 7341              FINDREG(GR0, JJ);  FORGET(JJ)
 7342              DUMP(X'58', JJ, 0, 0, RR);  ! LOAD ITEM LENGTH
 7343              PRR(6, JJ, 0);              ! BCTR  TO TAKE 1 OFF
 7344              %IF Z=1 %THEN %START
 7345                 PRX(X'42', JJ, WSPR, 0, 0);   ! STC  LMAX,0(WSPR)
 7346                 BML=WSPR;  DML=0
 7347                 REGISTER(BASE)=0 %IF REGISTER(BASE)>0
 7348                 REGISTER(INDEX)=0
 7349              %FINISH %ELSE %START
 7350                 PRX(X'89', JJ, 0, 0, 24);! SLL 24
 7351                 PRR(X'16', REG, JJ);     ! OR REG,JJ
 7352                 REGISTER(REG)=0
 7353              %FINISH
 7354              ->Label9
 7355           %FINISH
 7356           NAM=0;  ->Label5002;                ! ORDINARY ARRAYS ACC KNOWN
 7357  Label5020:                                   ! STRINGS IN RECORDS
 7358           NAMEP=-1;  SAVESL=ACC
 7359           LEVELP=BML;  DISPP=DML;        ! SET BY CRNAME TO ARRAYHEAD
 7360           ->Label5111 %IF ARR=1;              ! NOW AS NORMAL STRINGARRAYS
 7361           %IF NAM=1 %AND INDEX>0 %THEN %START
 7362              PRR(X'1A', INDEX, BASE);    ! VERY MESSY  STRINGNAME IN A
 7363              FORGET(INDEX);  BASE=INDEX; ! RECORDARRAY MUST MAKE LMAX
 7364              CCSTATE=-1
 7365              INDEX=0
 7366           %FINISH;                       ! BYTE DIRECTLY ADDRESSABLE
 7367           ->Label5001;                        ! NOW AS NORMAL STRINGS
 7368  SW(8):                                  ! REGISTER VARIABLE
 7369           FAULT(29, FNAME) %UNLESS Z=2 %OR Z=5 %OR KFORM#M'RG'
 7370                                          !ONLY FETCH MAKES SENSE
 7371           ABORT %IF REGISTER(K)>=0
 7372           %IF Z=1 %OR 3<=Z<=4 %THEN K=SNDISP %AND ->Label600
 7373           %IF REG<0 %THEN NEST=K %ELSE %START
 7374              PRR(X'18', REG, K) %UNLESS REG=K
 7375           %FINISH
 7376           ->Label9
 7377  ! SECTION TO DEAL WITH ALL NAMES INVOLVING ROUTINE CALL
 7378  RTCALL:                                 ! FIRST CHECK
 7379           %IF TYPE=0 %AND Z#0 %THEN FAULT(23, FNAME) %AND ->Label502
 7380                                          ! RT NAME IN EXPRSN
 7381           %IF PTYPE=SNPT %THEN %START
 7382              CSNAME(Z, REG);             ! SPECIAL NAME
 7383              ->Label202 %IF ROUT=1 %AND NAM>=1 %AND Z#0
 7384              ->Label6
 7385           %FINISH
 7386           %IF KFORM&4095=1000 %THEN FAULT(21, FNAME) %AND ->Label502
 7387                                          ! USE BEFORE %SPEC GIVEN
 7388           CRCALL(TCELL);  P=P+1;        ! DEAL WITH PARAMS
 7389           ->Label1 %IF PTYPE=10000 %OR PTYPE=11000
 7390           ->Label201 %IF NAM>1;               ! MAPS
 7391           %UNLESS Z=2 %OR Z=5 %THEN %START;   ! FUNCTIONS
 7392              FAULT(29, FNAME);  BASE=0
 7393              INDEX=0;  DISP=0
 7394           %FINISH
 7395           ->STRFUN %IF TYPE=5;  P=P-2
 7396           %IF TYPE=2 %THEN REGP=2 %AND JJ=18 %ELSE REGP=1 %AND JJ=1
 7397           NAMEP=0;  ->SWOP
 7398  STRFUN:  DISP=0;  INDEX=0;  BASE=1;  ->Label1
 7399  Label201:                                    ! USER DEFINED MAPS
 7400           DISP=0;  INDEX=0;  BASE=1
 7401  Label202:                                    ! BUILT IN MAPS
 7402           %IF PREC = 2 %THEN WARN(LINE)
 7403           NAM=0;  NAMEP=0;  P=P-2
 7404           %IF TYPE#5 %THEN ->Label601
 7405           BML=-1;  DML=255;              ! STRING MAPS
 7406           ->Label5002
 7407  SW(0):                                  ! %NAME PARAMETERS NO TYPE
 7408                                          ! ALLOW FETCH ADDR OPERATIONS
 7409                                          ! AND SPECIAL FOR BUILTIN MAPS
 7410           %UNLESS 3<=Z<=4 %OR (Z=1 %AND REG=99) %THEN %START
 7411              FAULT(12, FNAME);  TYPE=1
 7412           %FINISH
 7413  SW(1):                                  ! TYPE =INTEGER
 7414  SW(2):                                  ! TYPE=REAL
 7415           ->Label600 %IF ARR=0
 7416           CANAME(ARR, I, K, SNDISP)
 7417           NAM=0;  ->Label601
 7418  !
 7419                                          ! GENERAL FETCHING & STORING 
 7420                                          !SECTION
 7421  Label600:     BASE=I;  INDEX=0;  DISP=K
 7422  Label601:     ->Label602 %IF Z=6
 7423           JJJ=Z;  JJJ=JJJ-3 %IF JJJ>3
 7424           JJJ=TYPE<<3+2*(PREC&3)+JJJ-8
 7425           KK=Z;  KK=2 %IF Z=5
 7426  Label605:     NAMEP=0 %UNLESS INDEX=0 %AND DISP=DISPP %AND BASE=LEVELP
 7427           ->MOD(NAM<<2!KK&3)
 7428  Label602:     FAULT(17, FNAME) %IF NAM=0
 7429           DUMP(1, REG, DISP, INDEX, BASE);  ->Label9
 7430  MOD(1):                                 ! SCALAR STORE
 7431           ->Label9
 7432  MOD(2):                                 ! SCALAR FETCH
 7433  MOD(6):                                 ! SCALARNAME FETCH
 7434           ->Label610 %IF NAMEP=0 %OR CHECKSP#0
 7435  ! HAVE A SIMPLE NAME SO LOOK AT REGISTER POINTED AT BY REGP TO SEE
 7436  ! IF THE LOAD (&UNASSIGNED CHECK) CAN BE AVOIDED
 7437           FIND USE(JJ, TYPE&3, 3, NAMEP)
 7438           ->Label610 %IF JJ<0;  REGP=JJ&15
 7439  ! HAVE FOUND VARIABLE IN REGISTER. MANOEVRE IT TO REQUIRED REGISTER
 7440  SWOP:
 7441           %IF REG<0 %THEN %START
 7442              %IF REGISTER(JJ)=0 %THEN %START
 7443                 NEST=REGP;  ->Label9
 7444              %FINISH;                    ! CAN USE IT AS FOUND
 7445              %IF JJ>=16 %THEN FIND REG(FR0, REG) %C
 7446+                %ELSE FINDREG(GR0, REG)
 7447           %FINISH
 7448  ! MOVE TO NEW REGISTER ALLOWING FOR STRINGS AND ALL TYPES OF ADDRESSES
 7449           %IF REG#REGP %THEN %START
 7450              PRR((JJ>>4+1)<<4+8, REG, REGP);  ! LR OR LDR
 7451              KK=GRUSE(JJ)
 7452              JJ=JJ&16!REG
 7453              FORGET(JJ);                 ! REMEMBER ORIGINAL REGISTER
 7454              %IF NAMEP>0 %AND REGISTER(JJ)>=0 %C
 7455+                %THEN SET USE(JJ, KK, NAMEP)
 7456           %FINISH
 7457           NEST=REG;  ->Label9
 7458  Label610:     ->NAMETYPE %IF NAM=1
 7459  GENFETCH:->DELAY %IF Z=5 %AND (UNASS=0 %OR 1<=PREC<=2)
 7460           ->DELAY %IF TYPE=5
 7461           DUMP(JJJ, REG, DISP, INDEX, BASE)
 7462           REG=NEST %IF REG<0
 7463           %IF UNASS=1 %AND Z#3 %AND BASE#GLA %AND 1<=TYPE<=2 %C
 7464+             %AND (PREC=0 %OR PREC=3) %THEN %START
 7465              PRX((TYPE-1)*(2-PREC>>1)*16+X'59', REG, 0, CODER, 216)
 7466              CCSTATE=-1
 7467              PCONST(X'4780C028')
 7468           %FINISH;                       ! BE UNASS VAR USED
 7469           %IF NAMEP=0 %THEN JJJ=1 %ELSE JJJ=3
 7470           %IF JJJ=1 %AND PREC=1 %THEN JJJ=2 %AND NAMEP=-2
 7471  !         SET USE((TYPE&2)<<3+REG, JJJ, NAMEP)
 7472           KK=(TYPE&2)<<3+REG
 7473           CCSTATE=-1 %IF CCSTATE&255=KK
 7474           %IF REGISTER(KK)>=0 %THEN GRUSE(KK)=JJJ %AND GRINF(KK)=NAMEP
 7475           GRAT(KK)=CA
 7476           ->Label9
 7477  DELAY:   NEST=-1;  ->Label9
 7478  MOD(4):                                 ! SCALAR NAME FETCH ADDR
 7479  MOD(7):                                 ! SACALR NAME FETCH POINTER
 7480           JJJ=2;  ->Label621
 7481  MOD(0):                                 ! SCALAR FETCH POINTER
 7482  MOD(3):                                 ! SCALAR FETCH ADDR
 7483           JJJ=0
 7484  Label621:     ->GENADDR %IF NAMEP=0
 7485  ! MUST BEWARE OF STMNTS LIKE BYTEINTEGER(ADDR(I)+2)=...
 7486  ! WHICH CAN CHANGE LOCAL VARIABLES (I) IN CORE. BIMSTR IS SET FOR ANY
 7487  ! STATEMENT CONTAINING A STORE INTO A BUILTIN MAP. WHEN THIS FLAG IS
 7488  ! SET ANY 'FETCH ADDRESS' OPERATION MUST BE TREATED AS A STORE
 7489           %IF BIMSTR#0 %THEN NOTE ASSMENT(-1, 2, FNAME)
 7490           FIND USE(REGP, 1, 7, NAMEP)
 7491           ->GENADDR %UNLESS REGP>=0
 7492           JJ=REGP;  ->SWOP
 7493  GENADDR: DUMP(JJJ, REG, DISP, INDEX, BASE)
 7494           REG=NEST %IF REG<0
 7495           %IF Z=4 %AND JJJ=2 %AND TYPE&3=0 %THEN %START
 7496              PRX(X'54', REG, GLA, 0, 60);! N REG,=X'00FFFFFF'
 7497              NAMEP=0
 7498           %FINISH
 7499           %IF NAMEP=0 %THEN JJJ=0 %ELSE JJJ=7
 7500           SET USE(REG, JJJ, NAMEP);  ->Label9
 7501  MOD(5):                                 ! SCALAR NAME STORE
 7502  NAMETYPE:->Label630 %UNLESS NAMEP#0
 7503           FIND USE(REGP, 1, 7, NAMEP)
 7504           ->Label631 %IF REGP>0
 7505  Label630:     FIND REG(ADDREG, REGP)
 7506           DUMP(X'58', REGP, DISP, INDEX, BASE);    ! ADDR TO REGP
 7507           %IF NAMEP=0 %THEN RR=0 %ELSE RR=7
 7508           SET USE(REGP, RR, NAMEP)
 7509  Label631:     INDEX=0;  BASE=REGP;  DISP=0
 7510           ->GENFETCH %UNLESS Z=1 %OR Z>10
 7511  Label9:       ->Label1 %UNLESS ARR=0
 7512  Label91:      P=P+1
 7513           ->Label6 %IF A(P)=2
 7514           FAULT(19, FNAME)
 7515           SKIP APP;  ->Label1
 7516  Label6:       P=P+1
 7517  Label1:       P=P+1;  ->Label9005 %IF A(P-1)=2
 7518           FAULT(69, FNAME);  ->Label91
 7519  Label9005: %END
?LABEL4 unused
?WORK unused
 7520           %ROUTINE CRCALL(%INTEGER TCELLP)
 7521           {%SHORTROUTINE}
 7522  !***********************************************************************
 7523  !*       COMPILE A ROUTINE OR FN CALL                                  *
 7524  !*       THE PROCEDURE CONSIST OF THREE PARTS:-                        *
 7525  !*       A) PLANT THE PARAMETER (IF ANY)                               *
 7526  !*       B) ENTER THE ROUTINE OR FN                                    *
 7527  !*       C) FORGET ANY REGISTERS WHICH HOLD ENTITIES THAT CAN BE       *
 7528  !*          ALTERED BY THE CALLED PROCEDURE.                           *
 7529  !*       ALSO CONTAINS A SPECIAL FOR CALLS OF IOCP & MONITOR           *
 7530  !*       ROUTINE TAGS ARE AS FOLLOWS:-                                 *
 7531  !*       SNDISP = WORD(!) DISPLACEMENT OF EP(REF)FROM HEAD OF CODE(GLA)*
 7532  !*        (OR)  = LISTHEAD OF OUTSTANDING FORWARD REFS                 *
 7533  !*       KFORM  = PSIMPLE<<12 ! NO OF PARAMS                           *
 7534  !*       K      = LIST OF FORMAL PARAMETER DESCRIPTIONS                *
 7535  !***********************************************************************
 7536           %INTEGER KK,II,III,QQQ,SCA,JJ,JJJ,NPARMS,PT,LP,KKK,PSIZE, %C
 7537+                   SAVEFPTR,PSIMPLE,RTNAME,R1,R2,TL,MOVEPTR,RDISP,CLINK
 7538           %OWNSHORTINTEGER FPTR
 7539           SAVE IRS(RBASE+4)
 7540  !
 7541  ! IF ANY ROUTINE HAS FUNCTIONS IN ITS PARAMETER LIST THIS ROUTINE
 7542  ! WILL BE CALLED RECURSIVELY. FPTR KEEPS TRACK OF PARAMETERS AHEAD OF
 7543  ! THE STACK TOP WHICH MUST BE PROTECTED
 7544  !
 7545           SAVEFPTR=FPTR; R1=4; R2=14
 7546           LP=I;JJJ=J; CLINK=K; KKK=CLINK; TL=OLDI
 7547           RDISP=4*(SNDISP&X'FFFF'); PSIMPLE=KFORM>>12
 7548           MOVEPTR=(FPTR+7)&(-8)
 7549           %IF FPTR>64 %THEN MOVER(WSPR,MOVEPTR)
 7550                                         ! ADVANCE WSP IF ALREADY IN THE
 7551           FPTR=0;RTNAME=A(P);PT=PTYPE;  ! MIDDLE OF A RT CALL
 7552           %IF TCELLP<0 %THEN %START;   ! CALL OF IOCP
 7553              PT=10000;JJJ=14; PSIMPLE=0
 7554              %IF TCELLP=-1 %THEN %START
 7555                 RDISP=IOCP1; NPARMS=2; R2=1
 7556              %FINISH %ELSE %START
 7557                  RDISP=IMPMON1; NPARMS=0
 7558              %FINISH
 7559              -> ENTRY SEQ
 7560           %FINISH
 7561  !
 7562  ! NOW CHECK THAT THE RIGHT NUMBER OF PARAMETERS HAVE BEEN PROVIDED
 7563  !
 7564           P=P+1
 7565           NPARMS=KFORM&4095
 7566           %IF NPARMS=0 %START
 7567              ->ENTRY SEQ %IF A(P)=2
 7568              FAULT(19,RTNAME);          ! WRONG NO OF PARAMETERS GIVEN
 7569              SKIP APP; P=P-1
 7570              %RETURN
 7571           %FINISH
 7572  !
 7573  ! A ROUTINE IS DEEMED TO HAVE SIMPLE PARAMETERS IF THEY CAN BE LOADED
 7574  ! INTO GRS 0 UP AND PLANTED IN THE SAME 'STM' THAT STORES THE REGISTERS
 7575  ! THIS IS CHECKED AT ROUTINESPEC TIME. ONLY THE REGISTERS NEED BE
 7576  ! LOOKED AT HERE.
 7577  !
 7578           II=0
 7579           %WHILE PSIMPLE=1 %AND II<NPARMS %CYCLE
 7580              PSIMPLE=0 %UNLESS REGISTER(II)=0
 7581              II=II+1
 7582           %REPEAT
 7583           %IF PSIMPLE#0 %THEN %START
 7584              R2=-1
 7585              R1=NPARMS %IF NPARMS>4
 7586           %FINISH
 7587           ->FIRSTP
 7588  !
 7589  NEXT PARM:CLINK=SHORTINTEGER(ADDR(ASLIST(CLINK))+14)
 7590           %IF CLINK=0 %THEN %START
 7591              %IF A(P)=2 %THEN ->ENTRY SEQ
 7592              FAULT(19,RTNAME)
 7593              SKIP APP; P=P-1
 7594              %RETURN
 7595           %FINISH
 7596  FIRSTP:
 7597  !         FROM12(CLINK,PTYPE,II)
 7598  !%if USE MC = 1 %start
 7599  !         *L_1,CLINK; *A_1,ASLIST
 7600  !         *LM_2,3,0(1); *ST_2,PTYPE; *ST_3,II
 7601  !%finish
 7602           FPTR=II&X'FFFF'
 7603           PSIZE=II>>16
 7604           %IF A(P)=2 %THEN FAULT(19,RTNAME) %AND ->ENTRY SEQ
 7605           P=P+1;! UNPACK
 7606  !%if USE MC = 1 %start
 7607  !            *L_1,PTYPE; *CVD_1,0(11)
 7608  !            *UNPK_ROUT(5),5(3,11)
 7609  !            *NC_ROUT(5),MASK1
 7610  !%finish
 7611           II=TYPE;III=PREC
 7612           JJ=(NAM<<1!ARR)&3
 7613           %UNLESS (JJ=0 %AND ROUT=0) %OR %C
 7614+            (A(P+2)=4 %AND A(P+3)=1 %AND A(P+A(P+1)+1)=2) %START
 7615              SKIP EXP; FAULT(22,0)
 7616              ->NEXT PARM
 7617           %FINISH
 7618           %IF PSIMPLE#0 %THEN %START
 7619              R2=R2+1
 7620              %IF JJ=0 %THEN CSEXP(R2,1) %ELSE %START
 7621                 P=P+4; CNAME(3,R2)
 7622                 FAULT(22,0) %UNLESS II=TYPE %AND III=PREC
 7623                 P=P+1
 7624              %FINISH
 7625              GRUSE(R2)=15
 7626              REGISTER(R2)=1
 7627              -> NEXT PARM
 7628           %FINISH
 7629  !
 7630  ! FOR RT TYPE PARAMS, PASS 1 WORD POINTING TO 4 WORDS SET
 7631  ! UP AS CODE,GLA,EP ADDR & ENVIRONMENT
 7632  !
 7633           %IF ROUT=1 %THEN %START
 7634              II=PTYPE; P=P+4
 7635              CNAME(13,-1);              ! SET UP 4 WDS & SET PTR
 7636              FAULT(22,0) %IF 1000#II-PTYPE#0;! PREC&TYPE SIMILAR
 7637              P=P+1
 7638              PRX(X'50',NEST,0,WSPR,FPTR);! STUFF OFF POINTER
 7639           %FINISH %ELSE %START;         ! NAME & VALUE PARAMETERS
 7640  !
 7641  ! FOR ARRAYNAME PARAMETERS THE NO OF DIMENSIONS OF THE ARRAY IS
 7642  ! DEDUCED FROM THE FIRST CALL AND STORED IN STREAM3 OF THE PARAMETER
 7643  ! LIST. ON ANY SUBSEQUENT CALL ONLY ARRAYS OF THE SAME DIMENSION CAN
 7644  ! BE PASSED
 7645  !
 7646              %IF JJ=0 %THEN KK=2 %AND ACC=PSIZE %ELSE KK=1
 7647              %IF PTYPE=5 %THEN ACC=ACC-1
 7648              QQQ=FROM3(CLINK); J=QQQ;   ! GET NO OF DIMENSIONS
 7649              ASSIGN(KK,WSPR<<16!FPTR);  ! ASSIGN 1='==', 2='='
 7650              %IF JJ=3 %AND QQQ=0 %THEN REPLACE3(CLINK,J)
 7651           %FINISH
 7652           -> NEXT PARM
 7653  ENTRY SEQ:                             ! CODE FOR RT ENTRY
 7654           %IF R2=14 %AND REGISTER(14)!GRUSE(14)=0 %THEN R2=13
 7655  !
 7656  ! SIMPLE PARAMETERS SHOULD BE IN GRS 0 UP AWAITING STORAGE. IF HOWEVER
 7657  ! THERE WAS A FUNCTION CALL AMONG THE ACTUAL PARAMETERS SOME MAY HAVE
 7658  ! BEEN STORED ALREADY. THIS CASE MUST BE CHECKED FOR, AND IF FOUND,
 7659  ! ROUTINE SAVE IRS CALLED TO STORE ANY REMAINING PARAMETERS.
 7660  !
 7661           JJ=0
 7662           %WHILE PSIMPLE#0 %AND JJ<NPARMS %CYCLE
 7663              %IF GRUSE(JJ)=15 %THEN REGISTER(JJ)=0 %ELSE %START
 7664                 KK=JJ-1;                 ! RESET REGISTER FOR REGS FREED
 7665                 REGISTER(KK)=1 %AND KK=KK-1 %WHILE KK>=0
 7666                 R2=14; PSIMPLE=0
 7667                 SAVE IRS(RBASE+4)
 7668              %FINISH
 7669              JJ=JJ+1
 7670           %REPEAT
 7671  !
 7672           SCA=CA; PCONST(0);            ! WILL CONTAIN THE 'STM'
 7673           PTYPE=PT;! UNPACK
 7674  !%if USE MC = 1 %start
 7675  !            *L_1,PTYPE; *CVD_1,0(11)
 7676  !            *UNPK_ROUT(5),5(3,11)
 7677  !            *NC_ROUT(5),MASK1
 7678  !%finish
 7679           %UNLESS JJJ=14 %OR NAM&1=1 %START
 7680              NMDECS=NMDECS!2
 7681              J=JJJ; OLDI=TL
 7682              RT JUMP(X'45',15,TCELLP,10)
 7683           %FINISH %ELSE %START
 7684              %IF NAM&1=0 %THEN %START;        ! EXTERNAL CALL
 7685                 JJ=RDISP; TL=0;             ! NOTHING GLOBAL TO XTRN
 7686                 DUMPM(X'98',12,14,GLA,JJ);    ! LM 12,14,EP
 7687              %FINISH %ELSE %START;            ! RT PARAM CALLED
 7688                                               ! ENVIRONMENT MUST BE LOADED
 7689                 DUMP(X'58',15,RDISP,0,LP);  ! LOAD PTR TO RT HEAD
 7690                 PRX(X'98',12,15,15,0);        ! LOAD HEAD
 7691                 PRX(X'98',5,10,15,20);        ! LOAD UP ENVIRONMENT
 7692              %FINISH
 7693              PLANT(X'5FE');                   ! BALR 15,14
 7694           %FINISH
 7695  !
 7696  ! NOW UPDATE REGISTERS AND GLOBAL FLAGS
 7697  !
 7698           MONE=1; CYC BITS=CYC BITS!8;  ! 'RT CALL' BIT
 7699           CYC BITS=CYC BITS!(1<<20)<<TL
 7700           FAULT(201,0) %UNLESS REGISTER(15)=0
 7701           CCSTATE=-1
 7702           FORGETM(8)
 7703           SET USE(15,12,CA) %IF SBFLAG=0 %AND CA-CODEBASE>4095-MARGIN
 7704           %IF R2<R1 %THEN JJJ=14 %ELSE JJJ=R2
 7705           %CYCLE JJ=R1,1,JJJ
 7706              %IF REGISTER(JJ)=0 %THEN %START
 7707                 KK=GRUSE(JJ)
 7708                 %UNLESS 1<=KK<=2 %OR KK=8 %OR 10<=KK<=12 %THEN %START
 7709                    II=0
 7710                    %IF KK=7 %THEN II=FROM1(GRINF(JJ))>>8&15;! LEVEL OF DECLN
 7711                    GRUSE(JJ)=0 %UNLESS II>TL;!  NAME CAN NOT BE ALTERED
 7712                 %FINISH
 7713              %FINISH
 7714           %REPEAT
 7715           R1=R1+1 %WHILE REGISTER(R1)=0 %AND GRUSE(R1)<=1
 7716           PLUG(1,SCA,X'9000'!R1<<4!R2)
 7717           PLUG(1,SCA+2,WSPR<<12!R1<<2)
 7718           FPTR=SAVEFPTR
 7719           %IF FPTR>64 %THEN %START
 7720             REGISTER(1)=1;          !PROTECT PROGS WITH GLA>4096
 7721             MOVER(WSPR,-MOVEPTR);!STEP BACK STACK PTR
 7722             REGISTER(1)=0
 7723             %FINISH
 7724           %END
 7725           %ROUTINE RT JUMP(%INTEGER CODE,R1,LINK,WKREG)
 7726  !***********************************************************************
 7727  !*       PLANTS A 'BAL' TO THE APPROPIATE ENTRY ADDRESS IN ASL(LINK)   *
 7728  !*       DIFFERENT FROM NORMAL JUMPS AS ADDRESS CAN BE BEFORE ((GR10)).*
 7729  !*       IF ROUTINE HAS BEEN SPECIFIED BUT NOT DESCRIBED THE JUMP CAN  *
 7730  !*       NOT BE PLANTED AND IS LINKED INTO A LIST HEADED BY ASL(LINK)  *
 7731  !*       TO AWAIT FILLING (BY ' RHEAD ') WHEN THE BODY IS GIVEN.       *
 7732  !*       THE FORMAT OF AN ENTRY IS :-                                  *
 7733  !*       S1(32 BITS) = VALUE IN BASE REGISTER( GR10)                   *
 7734  !*       S2(32 BITS) = ADDRESS OF JUMP TO BE FILLED                    *
 7735  !*       S3(16 BITS) = FLAG (0 FOR LONG JUMP,#0 SHORT JUMP)            *
 7736  !*       THE CODING ASSUMES I,J&OLDI ARE SET UP FOR THE CALLED ROUTINE *
 7737  !***********************************************************************
 7738           {%SHORTROUTINE}
 7739           %INTEGER DP,AD,XD
 7740           XD=0; AD=ADDR(ASLIST(LINK))+4;!  TO SNDISP FIELD OF TAGS
 7741           DP=4*(SHORTINTEGER(AD)&X'FFFF')-CODEBASE
 7742           PRR(X'18',WKREG,10) %UNLESS WKREG=10 %OR(J#15 %AND 0<DP<4095)
 7743           %IF J=15 %THEN %START;        ! RT BODY NOT GIVEN YET
 7744              %IF SBFLAG=1 %AND OLDI=LEVEL %THEN XD=1 %AND WKREG=10
 7745              DP=0
 7746              PUSH123(SHORT INTEGER(AD),CODEBASE,CA,XD) %IF CSSMODE#0
 7747              PRX(X'5A',WKREG,CODER,0,0) %IF XD=0
 7748           %FINISH %ELSE %START;          ! BODY GIVEN AND ADDRESS KNOWN
 7749              %IF 0<DP<4095 %THEN WKREG=10 %ELSE ADJUST INDEX(1,WKREG,DP)
 7750           %FINISH
 7751           PRX(CODE,R1,WKREG,0,DP&4095)
 7752           %END
 7753           %ROUTINE SKIP EXP
 7754           {%SHORTROUTINE}
 7755  !***********************************************************************
 7756  !*       SKIPS OVER THE EXPRESSION POINTED AT BY P. USED FOR ERROR     *
 7757  !*       RECOVERY AND TO EXTRACT INFORMATION ABOUT THE EXPRESSION.     *
 7758  !*       FFLAG IS SET IF THERE ARE ANY FUNCTIONS IN THE EXPRESSION     *
 7759  !*        SENOPS COUNTS THE OPERATORS IN THE EXPRESSION                *
 7760  !*        SEFOP HOLD THE FIRST OPERATOR.                               *
 7761  !***********************************************************************
 7762           %BYTEINTEGER OPTYPE
 7763           %INTEGER J
 7764           P=P+2;                         ! TO P<+'>
 7765           %CYCLE;                        ! DOWN THE LIST OF OPERATORS
 7766             OPTYPE=A(P+1);               ! ALT OF P<OPERAND>
 7767             P=P+2
 7768              %IF OPTYPE=0 %OR OPTYPE>4 %THEN ABORT
 7769             %IF OPTYPE>=3 %THEN SKIP EXP;! SUB EXPRESSIONS
 7770  !
 7771             %IF OPTYPE=2 %THEN %START;   ! OPERAND IS A CONSTANT
 7772                J=A(P)&7;                 ! CONSTANT TYPE
 7773                %IF J=1 %THEN P=P+3;      ! INTEGER CONSTANT
 7774                %IF J=2 %THEN P=P+5;      ! REAL CONSTANT
 7775                %IF J=5 %THEN P=P+(A(P+1)+1)>>1+2
 7776                %IF A(P)=1 %THEN %START;  ! IMPLIED MULTIPLICATION
 7777                   OPTYPE=1;              ! TO PROCESS THE NAME
 7778                %FINISH
 7779                P=P+1
 7780             %FINISH
 7781  !
 7782             %IF OPTYPE=1 %THEN %START;   ! NAME
 7783                J=ADDR(ASLIST(TAGS(A(P))))
 7784                FFLAG=1 %IF SNPT#SHORT INTEGER(J)>=10000;! ROUT IN PTYPE
 7785                P=P-1
 7786                %CYCLE                     ;! TILL NO ENAME
 7787                   P=P+2
 7788                   %IF A(P)=2 %THEN P=P+1 %ELSE SKIP APP
 7789                %REPEAT %UNTIL A(P)=2
 7790                P=P+1
 7791             %FINISH
 7792  !
 7793             P=P+1
 7794             %IF A(P-1)=2 %THEN %EXIT;    ! NO MORE REST OF EXP
 7795           %REPEAT
 7796           %END;                        ! OF ROUTINE SKIP EXP
 7797            %ROUTINE SKIP APP;           ! SKIPS ACTUAL PARAMETER PART
 7798           %WHILE A(P)=1 %THEN P=P+1 %AND SKIP EXP
 7799           P=P+1
 7800            %END
 7801                 %INTEGERFN TSEXP(%INTEGERNAME CODE,%INTEGER RTMODE)
 7802           {%SHORTROUTINE}
 7803           %INTEGER KK,PP,QQ,REXP
 7804           %SWITCH SW(1:4)
 7805           TYPE=1; PP=P; REXP=2-A(P+1+A(P+1)); P=P+2
 7806           ->Label9 %IF 1#A(P)#4; ->SW(A(P+1))
 7807  SW(1):   P=P+2; CODE=A(P); REDUCE TAG(RTMODE)
 7808           ->Label30 %IF TYPE=3
 7809           ->Label9 %IF K>4095
 7810           ->Label9 %UNLESS A(P+1)=2 =A(P+2); ! NO APP OR ENAME
 7811           ->Label9 %UNLESS ROUT=0
 7812           ->Label20 %IF TYPE=5
 7813           ->Label9 %UNLESS TYPE=1
 7814           ->Label11 %IF A(P+3)=2;            ! NO RST OF EXPS
 7815           ->Label9 %UNLESS NAM=0 %AND ARR=0 %AND A(P+5)=2
 7816           QQ=A(P+4); ->Label9 %UNLESS 1<QQ<=5 %OR QQ=9;! OPERATOR
 7817           ->Label9 %UNLESS A(P+6)&7=1 %AND A(P+7)=0 %AND A(P+8)>>8=0 %C
 7818+          %AND A(P+9)=2=A(P+10)
 7819           CODE=A(P+8); P=P+11; %RESULT=100*(QQ-1)
 7820  Label11:
 7821           P=P+4; %RESULT=10+PREC+100*NAM
 7822  Label20:      ->Label9 %UNLESS A(P+3)=2
 7823           P=P+4; %RESULT=20
 7824  Label30:      QQ=COPY RECORD TAG(KK)
 7825           %IF QQ=0 %AND A(P+1)=2 %THEN %RESULT=30
 7826           ->Label9
 7827  SW(2):   TYPE=A(P+2)&7
 7828           %IF TYPE=5 %AND REXP=0 %AND A(P+3)=0 %AND A(P+4)=2 %C
 7829+             %THEN CODE=0 %AND P=P+6 %AND %RESULT=1;! """"
 7830           ->Label9 %UNLESS TYPE=1 %AND A(P+5)=2; ! NO IMPLIED MULT
 7831           ->Label21 %IF REXP=1
 7832  !%if USE MC = 1 %start
 7833  !         **1,P; *AR_1,1; *LA_1,A+36(1)
 7834  !         *MVC_KK(4),0(1)
 7835  !%finish
 7836           CODE=KK
 7837           P=P+7
 7838           ->Label9 %UNLESS KK>>12=0
 7839           %RESULT=1 %IF 256>CODE
 7840           %RESULT=2
 7841  Label21:      %IF A(P+7)=12 %THEN TYPE=5
 7842  SW(3):SW(4):Label9:P=PP; %RESULT=0
 7843                 %END
 7844           %ROUTINE     MOVE R(%INTEGER R,N)
 7845           {%SHORTROUTINE}
 7846  !***********************************************************************
 7847  !*       ADVANCE OR RETARD ADDRESS IN REGISTER 'R' BY N BYTES          *
 7848  !***********************************************************************
 7849           %INTEGER CODE,BASE,D
 7850           CODE=0; BASE=R; D=N
 7851           %IF N<0 %THEN %START;            ! STORE CONST & USE SH
 7852              CODE=X'4B'; N=|N|
 7853              CCSTATE=-1
 7854              STORE CONST(BASE,D,2,ADDR(N)+2)
 7855           %FINISH
 7856              DUMP(CODE,R,D,0,BASE);        ! LA OR SH -ZERO SORTED
 7857           %END
 7858           %ROUTINE BULK M(%INTEGER MODE,L,B1,D1,B2,D2)
 7859           {%SHORTROUTINE}
 7860  !***********************************************************************
 7861  !*       PLANT CODE TO MOVE L BYTES (L KNOWN AT COMPILE TIME) FROM     *
 7862  !*       D1(B1)  TO D2(B2)                                             *
 7863  !*       IF MODE =0 SET L BYTES TO D2(0 OR X'80')                      *
 7864  !*                                                                     *
 7865  !*       L MAY BE GREATER THAN 4095                                    *
 7866  !***********************************************************************
 7867           %ROUTINESPEC UPDATE(%INTEGERNAME WI,DI)
 7868           %INTEGER I,J,W1,W2,OPCODE,CONST
 7869           W1=B1; W2=B2
 7870           OPCODE=X'D2'
 7871           %IF L+D1> 4092 %THEN UPDATE(W1,D1)
 7872           %IF MODE#0 %AND L+D2>4092 %THEN UPDATE(W2,D2)
 7873  !
 7874           %IF MODE=0 %THEN %START;      ! PROPAGATE CONSTANT
 7875              J=L; W2=W1
 7876              CONST=D2; D2=D1
 7877           %IF CONST=0 %AND L<=32 %THEN %START
 7878                 CCSTATE=-1
 7879                 OPCODE=X'D7';           ! CAN USE XC
 7880              %FINISH %ELSE %START;      ! USE MVI & MVC TO PROPOGATE
 7881                 PSI(X'92',CONST,W1,D1)
 7882                 L=L-1; D1=D1+1
 7883              %FINISH
 7884           %FINISH
 7885  !
 7886  !        END OF PREPARATION - CYCLE ROUND PLANTING MVC
 7887  !
 7888           %WHILE L>0 %CYCLE
 7889              %IF L>256 %THEN J=256 %ELSE J=L
 7890              %IF D1>4092 %THEN %START
 7891                 I=D1; UPDATE(W1,D1)
 7892                 %IF W2=W1 %THEN D2=D2-I+D1;! OVERLAPPING PROPAGATION W1=W2
 7893              %FINISH
 7894              %IF D2>4092 %THEN UPDATE(W2,D2)
 7895              PSS(OPCODE,J,W1,D1,W2,D2)
 7896              D1=D1+J
 7897              D2=D2+J
 7898              L=L-J
 7899           %REPEAT
 7900  !
 7901           REGISTER(W1)=0 %IF REGISTER(W1)>0
 7902           REGISTER(W2)=0 %IF REGISTER(W2)>0
 7903           %RETURN
 7904           %ROUTINE     UPDATE(%INTEGERNAME WI,DI)
 7905           %INTEGER WK,J
 7906           WK=WI
 7907           %IF REGISTER(WK)<0 %THEN FIND REG(GR1,WK)
 7908           %IF DI<4092 %THEN J=DI %ELSE J=4092
 7909           DUMP(0,WK,J,0,WI)
 7910           FORGET(WK)
 7911           DI=DI-J; WI=WK
 7912           %END
 7913           %END;                         ! OF ROUTINE BULK M
 7914           %ROUTINE     CBPAIR(%INTEGERNAME LB,UB)
 7915           {%SHORTROUTINE}
 7916  !***********************************************************************
 7917  !*       EXTRACT UPPER AND LOWER BOUNDS FROM A CONSTANT BOUND PAIR     *
 7918  !***********************************************************************
 7919           %INTEGER KK,KKK,JJ,BP
 7920           P=P+1; KK=0
 7921           %CYCLE JJ=1,1,2
 7922             KKK=KK
 7923             %IF A(P)=2 %THEN KK=-1 %ELSE KK=1;  ! EXTRACT SIGN
 7924             FROM AR4(P+2,BP)
 7925             KK=KK*BP
 7926             P=P+4
 7927           %REPEAT
 7928           %IF KKK>KK %THEN FAULT(43,0) %AND KK=KKK
 7929           LB=KKK; UB=KK
 7930           %END
 7931           %ROUTINE GET WSP(%INTEGERNAME PLACE,%INTEGER SIZE)
 7932           {%SHORTROUTINE}
 7933  !***********************************************************************
 7934  !*       FIND OR CREATE A TEMPORARY VARIABLE OF 'SIZE' WORDS           *
 7935  !*       SIZE=0 FOR STRING TEMPORARIES (260 BYTES)                     *
 7936  !***********************************************************************
 7937           %INTEGER J,K
 7938           SIZE=0 %IF SIZE>7
 7939  !%if USE MC = 1 %start
 7940  !         *TR_SIZE+3(1),WSPTRTAB1
 7941  !%finish
 7942           POP(AVL WSP(SIZE,LEVEL),J,K)
 7943           %IF K<=0 %THEN %START;        ! MUST CREATE TEMPORARY
 7944              %IF SIZE=2 %THEN N=(N+7)&(-8);    ! DBLE WRD BNDRY!
 7945              K=N
 7946              %IF SIZE=0 %THEN N=N+260 %ELSE N=N+SIZE<<2
 7947           %FINISH
 7948           PLACE=K
 7949  !
 7950  ! NORMALLY TEMPORARIES ARE RETURN ON EXITING FROM CSS. WITH STRINGS
 7951  ! THEY ARE RETURNED AS SOON AS POSSIBLE TO TRY AND SAVE SPACE
 7952  !
 7953           PUSH(TWSPHEAD,K,SIZE) %UNLESS SIZE=0
 7954           %END
 7955           %ROUTINE RETURN WSP(%INTEGER PLACE,SIZE)
 7956           {%SHORTROUTINE}
 7957           SIZE=0 %IF SIZE>7
 7958  !%if USE MC = 1 %start
 7959  !         *TR_SIZE+3(1),WSPTRTAB1
 7960  !%finish
 7961           PUSH(AVL WSP(SIZE,LEVEL),0,PLACE)
 7962           %END
 7963           %ROUTINE SETLINE
 7964  !***********************************************************************
 7965  !*       UPDATE THE LINE NO IF THIS STATEMENT HAS A DIFFERENT SOURCE   *
 7966  !*       LINE NO THAN THE LAST STATEMENT. IF IN DIAGNOSTIC MODE THE    *
 7967  !*       MONITOR IS CALLED ALSO TO KEEP IT INFORMED OF THE EXECUTION   *
 7968  !*       OF THE OBJECT PROGRAM.                                        *
 7969  !***********************************************************************
 7970           {%SHORTROUTINE}
 7971           %INTEGER K,AT
 7972           %OWNINTEGER VALUE
 7973           %IF LINENOS=1 %THEN %START
 7974              K=LINE&255
 7975              MONE=1 %IF K=0
 7976              PSI(X'92',K,GLA,23) %UNLESS K=VALUE %AND MONE=0
 7977              VALUE=K
 7978              %IF MONE#0 %THEN PSI(X'92',LINE>>8,GLA,22);   ! MVI
 7979              %IF DIAGS2#0 %THEN %START
 7980                 %IF IMPMON1<10 %THEN CXREF(0,-2,0,AT) %AND IMPMON1=AT
 7981                 CRCALL(-2);             ! CALL THE ONLINE MONITOR
 7982              %FINISH
 7983              MONE=0
 7984            %FINISH
 7985            %END
 7986           %ROUTINE     CHECK CAPACITY(%INTEGER REG,DIS,X,LEVEL)
 7987           {%SHORTROUTINE}
 7988  !***********************************************************************
 7989  !*       CHECK THAT THE ASSIGNMENT JUST MADE DID NOT EXCEED THE        *
 7990  !*       CAPACITY OF THE VARIABLE(BYTES  AND SHORTS ONLY)              *
 7991  !***********************************************************************
 7992           %INTEGER MASK
 7993           %IF 1<=PREC<=2 %THEN %START
 7994              CCSTATE=-1
 7995              %IF PREC=1 %THEN PRX(X'55',REG,0,GLA,24) %AND MASK=2 %C
 7996+                        %ELSE DUMP(X'49',REG,DIS,X,LEVEL) %AND MASK=7
 7997              PRX(X'47',MASK,12,0,88);     ! BC MASK,CAPACITY EXCEEDED
 7998           %FINISH
 7999           %END
 8000  !
 8001  !***********************************************************************
 8002  !*       REGISTER ALLOCATING ROUTINES                                  *
 8003  !*       THE REGISTERS ARE HELD ON A LIST FROM 0->Label22 COVERING          *
 8004  !*       THE 16 GENERAL REGISTERS AND THE FOUR FLOATING REGISTERS.     *
 8005  !*       A FLOATING REGISTER MAY BE DEFINED BY (TYPE=2,REG=0,2,4,6) OR *
 8006  !*       (TYPE =1,REG=16,18,20,22). BOTH ARE  VALID. THE FREE LIST IS  *
 8007  !*       SEARCHED IN DIFFERENT WAYS SO THAT THE MORE VOLATILE REGISTERS*
 8008  !*       I.E. GRS 0-3 AND GR15 ARE USED FOR SHORT-TERM PURPOSES AND    *
 8009  !*       THE SAFE REGISTERS(GRS 4-14) ARE USED WHEN THE PURPOSE MAY    *
 8010  !*       HAVE SOME LONG TERM VALUE.                                    *
 8011  !***********************************************************************
 8012  !
 8013           %ROUTINE FORGET(%INTEGER REG)
 8014           CCSTATE=-1 %IF CCSTATE&255=REG
 8015           %IF REGISTER(REG)>= 0 %THEN GRUSE(REG)=0 %AND GRINF(REG)=0
 8016           %END
 8017           %ROUTINE FREE AND FORGET(%INTEGER REG)
 8018           CCSTATE=-1 %IF CCSTATE&255=REG
 8019           %IF REGISTER(REG)>=0 %THEN  REGISTER(REG)=0 %AND %C
 8020+                 GRUSE(REG)=0 %AND GRINF(REG)=0
 8021           %END
 8022           %ROUTINE FORGETM(%INTEGER UPPER)
 8023           {%SHORTROUTINE}
 8024  !***********************************************************************
 8025  !*       FORGETS A BLOCK OF REGISTERS DEFINED BY UPPER AND THE         *
 8026  !*       GLOBAL ARRAY GRMAP                                            *
 8027  !*       UPPER= 3   FOR   GRS 0-3                                      *
 8028  !*       UPPER= 4   FOR   GRS  0-3  AND 15                             *
 8029  !*       UPPER= 8   FOR   GRS  0-3  AND 15  PLUS ALL FRS               *
 8030  !*       UPPER=14   FOR   GRS  0-8,14,15  AND ALL FRS                  *
 8031  !***********************************************************************
 8032           %INTEGER I,J,REG,U
 8033           %CYCLE I=0,1,UPPER
 8034              REG=GRMAP(I)
 8035              CCSTATE=-1 %IF CCSTATE&255=REG
 8036              %IF REGISTER(REG)=0 %THEN GRUSE(REG)=0 %AND GRINF(REG)=0
 8037           %REPEAT
 8038           %END
?U unused
?J unused
 8039           %ROUTINE SAVE IRS(%INTEGER UPPER)
 8040           {%SHORTROUTINE}
 8041  !***********************************************************************
 8042  !*       INSPECTS THE REGISTERS DEFINED BY UPPER AND THE GLOBAL        *
 8043  !*       ARRAY 'GRMAP'. ANY INTERMEDIATE RESULTS IN THESE REGISTERS    *
 8044  !*       ARE TRANSFERED TO CORE BY 'BOOT OUT'                          *
 8045  !*       UPPER=4 FOR GRS 1-3 & 15   (CORRUPTED BY PERM)                *
 8046  !*       UPPER=8 FOR GRS 1-3 & 15 +FRS 0-6  (CORRUPTED BY FN CALL)     *
 8047  !***********************************************************************
 8048           %INTEGER I,REG
 8049           %CYCLE I=0,1,UPPER
 8050             REG=GRMAP(I)
 8051             BOOT OUT(REG) %IF REGISTER(REG)=1
 8052           %REPEAT
 8053           %END
 8054           %ROUTINE SET USE(%INTEGER R,U,I)
 8055  !***********************************************************************
 8056  !*       NOTE THAT THE USE OF REGISTER 'R' IS NOW 'U' & 'I'            *
 8057  !***********************************************************************
 8058           CCSTATE=-1 %IF CCSTATE&255=R
 8059           %IF REGISTER(R)>=0 %THEN  GRUSE(R)=U %AND GRINF(R)=I%C
 8060+              %AND GRAT(R)=CA
 8061           %END
 8062           %ROUTINE BOOT OUT(%INTEGER REG)
 8063           {%SHORTROUTINE}
 8064  !***********************************************************************
 8065  !*       IF THE SPECIFIED REGISTER CONTAINS AN INTERMEDIATE RESULT     *
 8066  !*       (USE=1) OR PARAMETER EN-ROUTE TO A ROUTINE (USE=15) THEN FREE *
 8067  !*       THE REGISTER BY TRANSFERRING ITS CONTENTS TO CORE             *
 8068  !***********************************************************************
 8069           %INTEGER J,USE,BASE
 8070           %RECORD(RD)%NAME OPND
 8071           USE=GRUSE(REG)
 8072           %IF USE=1 %OR USE=15 %THEN %START
 8073              %IF USE=15 %THEN BASE=WSPR %AND J=REG<<2+64 %ELSE %START
 8074  ABORT %UNLESS ADDR(ASLIST(0))<=GRINF(REG)<=ADDR(ASLIST(32752))
 8075                 OPND==RECORD(GRINF(REG))
 8076                 %RETURN %UNLESS OPND_FLAG=9 %AND OPND_D<0
 8077                 GET WSP(J,1+REG>>4)
 8078                 OPND_XB=RBASE; OPND_D=J; BASE=RBASE
 8079              %FINISH
 8080              DUMP(X'50'+REG&16,REG&15,J,0,BASE)
 8081              FREE AND FORGET(REG)
 8082           %FINISH
 8083           %END
 8084  %ROUTINE FINDREG(%INTEGER CONTROL, %INTEGERNAME REG)
 8085  {%SHORTROUTINE}
 8086  %INTEGER I, J, K, LAST, LAT, AND, AD
 8087           %IF CONTROL=FR0 %THEN AND=31 %ELSE AND=15
 8088           AD=ADDR(CONTROL);  LAST=-1;  LAT=CA
 8089           %CYCLE J=0, 1, 1
 8090              %CYCLE K=BYTE INTEGER(AD+2), SHORT INTEGER(AD),  %C
 8091+                BYTE INTEGER(AD+3)
 8092                 I=K&AND
 8093                 BOOT OUT(I) %IF REGISTER(I)=1 %AND J>0
 8094                 %IF REGISTER(I)=0 %THEN %START
 8095                    ->FOUND %IF GRUSE(I)<=1 %OR J>0
 8096                    %IF GRAT(I)<LAT %THEN  LAST=I %AND LAT=GRAT(I)
 8097                 %FINISH
 8098              %REPEAT
 8099              I=LAST
 8100              %IF J=0 %AND LAST>0 %THEN ->FOUND
 8101           %REPEAT
 8102           %IF CONTROL=CLMABL %THEN I=1 %ELSE ABORT
 8103  FOUND:   REG=I&15
 8104           %IF CONTROL=SAFE %THEN CYC BITS=CYCBITS!128
 8105                                          ! SAFE REG REQD
 8106  %END
 8107  %ROUTINE CLAIM(%INTEGER CONTROL, %INTEGERNAME REG)
 8108  {%SHORTROUTINE}
 8109  %INTEGER I
 8110           FIND REG(CONTROL, I)
 8111           %IF CONTROL=FR0 %THEN I=I+16
 8112           REGISTER(I)=1
 8113           REG=I&15
 8114  %END
 8115  %ROUTINE CLAIM THIS REG(%INTEGER REG)
 8116  {%SHORTROUTINE}
 8117  !***********************************************************************
 8118  !*       CLAIMS THE REGISTER AND PRESERVES CONTENTS IF                 *
 8119  !*       THE REGISTER IS ALREADY CLAIMED                               *
 8120  !***********************************************************************
 8121           BOOT OUT(REG) %IF REGISTER(REG)=1
 8122           %IF REGISTER(REG)#0 %THEN ABORT
 8123           REGISTER(REG)=1
 8124  %END
 8125  %ROUTINE FIND USE(%INTEGERNAME REG, %INTEGER TYPE, USE, INF)
 8126  %INTEGER I, L, U, J
 8127  %CONSTINTEGERARRAY FMAP(1:16)=4,8,12,16,20,24,28,32,56,60,0,
 8128+                                48,64,72,80,88;
 8129           %IF TYPE=2 %THEN L=52 %AND U=64 %ELSE L=4 %AND U=48
 8130  !         %CYCLE J=L,1,U
 8131  !            I=FMAP(J)
 8132  !            %IF GRUSE(I)=USE %AND(GRINF(I)=INF%OR INF=-1) %THEN ->HIT
 8133  !         %REPEAT
 8134  !%if USE MC = 1 %start
 8135  !         *L_1,L; *LA_2,4;*L_3,U
 8136  !         *L_15,FMAP; *SR_0,0; *BCTR_0,0
 8137  !         *LM_4,5,USE
 8138  !AGN:     *L_14,0(1,15);                 ! I=FMAP(J)*4
 8139  !         *C_4,GRUSE+16(14); *BC_7,<REP>
 8140  !         *C_5,GRINF+16(14); *BC_8,<HIT>
 8141  !         *CR_0,5; *BC_8,<HIT>
 8142  !REP:     *BXLE_1,2,<AGN>
 8143  !%finish
 8144           REG=-1
 8145           %RETURN
 8146  HIT:
 8147  !         GRAT(I)=CA
 8148  !         REG=I
 8149  !%if USE MC = 1 %start
 8150  !         *L_0,CA; *ST_0,GRAT+16(14)
 8151  !         *SRL_14,2; *L_1,REG; *ST_14,0(1)
 8152  !%finish
 8153  %END
?HIT unused
?FMAP unused
?J unused
?I unused
?INF unused
?USE unused
 8154  %ROUTINE FIND SEQ(%INTEGERNAME ONE, TWO)
 8155  {%SHORTROUTINE}
 8156  !***********************************************************************
 8157  !*       FINDS TWO REGISTERS FOR LM OR STM THAT ARE ADJACENT           *
 8158  !*       ALLOWING FOR WRAP AROUND. NOT USED VERY MUCH SO IS FAIRLY     *
 8159  !*       PRIMITIVE COMPARED TO 'FIND REG'                              *
 8160  !***********************************************************************
 8161  %INTEGER J, P1, P2, K
 8162           %CYCLE K=0, 1, 1
 8163              %CYCLE J=14, 1, RBASE+31;   ! TWO PASSES THROUGH GRS
 8164                 P1=J&15;  P2=(J+1)&15
 8165                 ->FOUND %IF REGISTER(P1)=0 %AND REGISTER(P2)=0 %C
 8166+                   %AND (J>=30 %OR GRUSE(P1)<=1>=GRUSE(P2))
 8167              %REPEAT
 8168              SAVEIRS(4)
 8169           %REPEAT
 8170           ABORT;                         ! ALMOST INCONCEIVABLE!
 8171  FOUND:   ONE=P1;  TWO=P2
 8172  %END
 8173  !******END OF REGISTER ALLOCATING ROUTINES*******
 8174  !
 8175  !
 8176  !***********************************************************************
 8177  !*           START OF TAG HANDLING ROUTINES                            *
 8178  !*       TAGS TAKE THE FORM                                            *
 8179  !*       S1=PTYPE<<16!USEBITS<<12!LEVEL<<8!BASEREG<<14!DIMENSN         *
 8180  !*       S2=SECONDARY DISP<<16!ITEM SIZE                               *
 8181  !*       S3=PRIMARY DISP<<16!FORM                                      *
 8182  !*       WHERE:-                                                       *
 8183  !*       PTYPE=ROUT,NAM,ARR,PREC & TYPE PACKED INTO 16 BITS            *
 8184  !*       USEBITS(L-R)= ANY USE,STORED,ADDRESSED,READ                   *
 8185  !*       LEVEL=TEXTUAL LEVEL OF DECLARATION                            *
 8186  !*       BASEREG & DIMENSN ARE OBVIOUS                                 *
 8187  !*                                                                     * 
 8188  !*       SNDARY DISP(SIGNED)= DISP OF A0 FROM LEVEL PTR                *
 8189  !*       PRMY DISP= POSITION OF ITEM OR ITS POINTER IN STACK FRAME     *
 8190  !*       FORM=POINTER TO FORMAT(RECORDS) OR VALUE (%CONSTS)            *
 8191  !***********************************************************************
 8192  !
 8193  %ROUTINE NOTE ASSMENT(%INTEGER REG, ASSOP, VAR)
 8194  {%SHORTROUTINE}
 8195  !***********************************************************************
 8196  !*       NOTES THE ASSIGNMENT TO SCALAR 'VAR'.  THIS INVOLVES REMOVING *
 8197  !*       OLD COPIES FROM REGISTERS TO AVOID CONFUSING OLD AND NEW VALUE*
 8198  !*       ASSOP =1 FOR'==',=2 FOR '=',=3 FOR '<-'                       *
 8199  !***********************************************************************
 8200  %INTEGER I, J, K, L, U, AND, STEP, CCS
 8201           %IF VAR=CUR CYC VAR %THEN CYC BITS=CYC BITS!32
 8202           K=TAGS(VAR);  L=14;  U=RBASE+15;  AND=15;  STEP=1
 8203           %IF TYPE=2 %AND ASSOP#1 %THEN %START
 8204              L=16;  U=22;  AND=31;  STEP=2;  REG=REG!16
 8205           %FINISH
 8206           %IF CCSTATE&255=REG %THEN CCS=CCSTATE %ELSE CCS=0
 8207           %CYCLE I=L, STEP, U;  J=I&AND
 8208              FORGET(J) %C
 8209+                %IF K=GRINF(J)&X'FFFF' %AND REGISTER(J)=0 %AND (GRUSE( %C
 8210+                J)=3 %OR GRUSE(J)=9 %OR (GRUSE(J)=7 %AND ASSOP=1))
 8211           %REPEAT
 8212           ->Label99 %IF REG<0 %OR (GRUSE(REG)=2 %AND 0<=GRINF(REG)<=2)
 8213           ->Label99 %IF ASSOP=3 %OR REGISTER(REG)<0
 8214           %IF ASSOP=1 %THEN J=7 %ELSE J=3
 8215  !         SET USE(REG, J, K)
 8216           GRUSE(REG)=J; GRINF(REG)=K; GRAT(REG)=CA
 8217           CCSTATE=CCS %UNLESS CCS=0
 8218  Label99: %END
 8219  %ROUTINE STORE TAG(%INTEGER KK, SLINK)
 8220  %INTEGER Q
 8221           Q=PTYPE<<16!LEVEL<<8!RBASE<<4!J
 8222           SLINK=SLINK<<16!KFORM&X'FFFF'
 8223           PUSH123(TAGS(KK), Q, INTEGER(ADDR(SNDISP)), SLINK)
 8224           SHORTINTEGER(ADDR(ASLIST(TAGS(KK)))+12)=NAMES(LEVEL)
 8225           NAMES(LEVEL)=KK
 8226  %END
 8227  %ROUTINE TEST APP(%INTEGERNAME NUM)
 8228  {%SHORTROUTINE}
 8229  !***********************************************************************
 8230  !*       THIS ROUTINE COUNTS THE NUMBER OF ACTUAL PARAMETERS           *
 8231  !*       WHICH IT RETURNS IN NUM.                                      *
 8232  !***********************************************************************
 8233  %INTEGER PP, Q
 8234           Q=0;  PP=P;  P=P+1;            ! P ON NAME AT ENTRY
 8235           %WHILE A(P)=1 %CYCLE;          ! NO (MORE) PARAMETERS
 8236              P=P+1;  Q=Q+1
 8237              SKIP EXP
 8238           %REPEAT
 8239           P=PP;  NUM=Q
 8240  %END
 8241  %ROUTINE COPY TAG(%INTEGER KK)
 8242  %LONGREAL WORK
 8243           TCELL=TAGS(KK)
 8244  !%if USE MC = 1 %start
 8245  !         *XC_PTYPE(20),PTYPE
 8246  !         *L_1,TCELL
 8247  !         *LTR_1,1;  *BC_8,<NOTSET>
 8248  !         *A_1,ASLIST
 8249  !         *UNPK_WORK(5),2(3,1)
 8250  !         *LH_0,0(1,0)
 8251  !         *ST_0,PTYPE
 8252  !         *MVN_USEBITS+3(1),WORK
 8253  !         *MVN_OLDI+3(1),WORK+1
 8254  !         *MVN_I+3(1),WORK+2
 8255  !         *MVN_J+3(1),WORK+3
 8256  !         *OI_2(1),X'80';                ! SET USE BIT
 8257  !         *MVC_SNDISP(8),4(1)
 8258  !         *CVD_0,WORK
 8259  !         *UNPK_ROUT(5),WORK+5(3)
 8260  !         *NC_ROUT(5),MASK1
 8261  !%finish
 8262           %RETURN
 8263  !%if USE MC = 1 %start
 8264  NOTSET:
 8265  !         *MVI_PTYPE+3,7
 8266  !         *MVI_I,255
 8267  !         *MVC_I+1(11),I
 8268  !         *XC_ROUT(4),ROUT
 8269  !%finish
 8270           TYPE=7
 8271  %END
?NOTSET unused
?WORK unused
 8272  %ROUTINE REDUCE TAG(%INTEGER MODE)
 8273  {%SHORTROUTINE}
 8274  !***********************************************************************
 8275  !*       AS COPY TAG FOR NAME AT A(P) EXCEPT:-                         *
 8276  !*       1) SPECIAL NAMES HAVE THEIR CORRECT PREC & TYPE SUBSTITUTED   *
 8277  !*       2) RECORD ELEMENTS OF SIMPLE RECORDS ARE REDUCED TO A         *
 8278  !*              SIMPLE BASE/OFFSET SITUATION.                          *
 8279  !***********************************************************************
 8280  %INTEGER PTYPEP, QQ, PP, NAMP, JJ, RDISP, SUBS
 8281           PP=P;  COPY TAG(A(P))
 8282           %IF PTYPE=SNPT %THEN %START
 8283              PTYPE=TSNAME(K); ! UNPACK
 8284  !%if USE MC = 1 %start
 8285  !            *L_1,PTYPE; *CVD_1,0(11)
 8286  !            *UNPK_ROUT(5),5(3,11)
 8287  !            *NC_ROUT(5),MASK1
 8288  !%finish
 8289              ROUT=1
 8290           %FINISH;                       ! TO AVOID CHECKING PARAMS
 8291           %UNLESS TYPE=3 %AND A(P+1)=2 %AND A(P+2)=1 %C
 8292+             %AND A(P+4)=2=A(P+5) %THEN ->OUT
 8293  ! NO APP &SINGLE SIMPLE ENAME
 8294           NAMP=NAM
 8295           RDISP=K
 8296           PTYPEP=PTYPE;  QQ=COPY RECORD TAG(SUBS)
 8297           %UNLESS QQ>0 %AND ARR=0 %AND TYPE#3  %AND SUBS=1 %THEN ->RESET
 8298           %IF NAMP=0 %THEN K=K+RDISP %ELSE %START
 8299              FIND USE(JJ, 1, 7, TAGS(A(PP)))
 8300              %IF JJ>0 %THEN I=JJ %ELSE %START
 8301                 ->RESET %UNLESS MODE#0
 8302                 %CYCLE JJ=14,-1,4
 8303                    %IF REGISTER(JJ)=0 %AND GRUSE(JJ)<=1 %START
 8304                       DUMP(X'58',JJ,RDISP,0,I)
 8305                       SET USE(JJ,7,TAGS(A(PP)))
 8306                       P=PP+3; I=JJ; %RETURN
 8307                    %FINISH
 8308                 %REPEAT
 8309                 ->RESET
 8310              %FINISH
 8311           %FINISH;  P=PP+3;  %RETURN
 8312  RESET:   P=PP;  COPY TAG(A(P))
 8313  OUT: %END
 8314  %ROUTINE REPLACE TAG(%INTEGER KK)
 8315  {%SHORTROUTINE}
 8316  %INTEGER P, Q
 8317           P=TAGS(KK)
 8318           Q=PTYPE<<16!USEBITS<<12!OLDI<<8!I<<4!J
 8319           REPLACE123(P, Q, INTEGER(ADDR(SNDISP)), INTEGER(ADDR(K)))
 8320  %END
 8321  %ROUTINE UNPACK
 8322  %LONGREAL WORK
 8323  !%if USE MC = 1 %start
 8324  !         *L_1,PTYPE;  *CVD_1,WORK
 8325  !         *UNPK_ROUT(5),WORK+5(3)
 8326  !         *NC_ROUT(5),MASK1
 8327  !%finish
 8328  %END
?WORK unused
 8329  %ROUTINE PACK(%INTEGERNAME PTYPE)
 8330  %LONGREAL WORK
 8331  !%if USE MC = 1 %start
 8332  !         %MCODE
 8333  !         *PACK_WORK(8),ROUT(5)
 8334  !         *OI_WORK+7,X'0C'     ;         !VALID SIGN
 8335  !         *CVB_1,WORK
 8336  !         *L_2,PTYPE;  *ST_1,0(2)
 8337  !%finish
 8338  %END
?WORK unused
?PTYPE unused
 8339  %ROUTINE PPJ(%INTEGER N)
 8340  ! PLANT A 'BAL' TO PERM SUBROUTINE N0 'N'
 8341  %INTEGER I
 8342           CCSTATE=-1
 8343           CYC BITS=CYC BITS!4;           ! SET 'PERM' BIT
 8344           %IF 20<=N<=24 %THEN I=4 %ELSE I=8
 8345           SAVE IRS(I)
 8346           FAULT(202, 0) %UNLESS REGISTER(15)=0
 8347           PCONST(X'45F0C000'!N<<2);      ! BAL 15,PN
 8348           FORGETM(I)
 8349           SET USE(15, 12, CA) %C
 8350+             %IF SBFLAG=0 %AND I#4 %AND CA-CODEBASE>4095-MARGIN
 8351  %END
 8352  %ROUTINE ADJUST INDEX(%INTEGER MODE, %INTEGERNAME INDEX, DISP)
 8353  {%SHORTROUTINE}
 8354  !***********************************************************************
 8355  !*       THIS IS THE GENERAL SOLUTION TO LACK OF ADDRESSABILITY. IT IS *
 8356  !*       CALLED WHEN DISP IS OUTSIDE THE RANGE 0->Label4095 AND MANIPULATES *
 8357  !*       INDEX ACCORDINGLY. FREQUENTLY INDEX=0 (NO INDEXING) WHEN THE  *
 8358  !*       SOLUTION IS TRIVIAL. MODE=0 IF INDEX MUST BE COPIED BEFORE    *
 8359  !*       BEING ADJUSTED.                                               *
 8360  !***********************************************************************
 8361  %INTEGER J, K, D, PN
 8362           FIND REG(GR1, J);              ! MAY NOT BE NEEDED
 8363           CYC BITS=CYC BITS!16;          ! USES MULTIPLE OF 4K
 8364           %IF DISP>0 %THEN %START
 8365              K=X'5A';  D=DISP
 8366           %FINISH %ELSE %START
 8367              K=X'5B';  D=4095-DISP
 8368           %FINISH
 8369           PN=D>>12;  FAULT(98, 0) %IF PN>63
 8370           %IF INDEX=0 %AND DISP>0 %THEN %START
 8371              FIND USE(INDEX, 1, 11, PN); ! LOOK FOR 4K MULTIPLE
 8372              ->Label98 %IF INDEX>0
 8373              SET USE(J, 11, PN)
 8374              INDEX=J;  K=X'58'
 8375           %FINISH %ELSE %START
 8376              %IF MODE=0 %OR INDEX=0 %THEN %START
 8377                 %IF MODE=0 %THEN PRR(X'18', J, INDEX) %ELSE %START
 8378                    PRR(X'1F', J, J)
 8379                    CCSTATE=-1
 8380                 %FINISH
 8381                 INDEX=J
 8382              %FINISH
 8383              FORGET(INDEX) %UNLESS GRUSE(INDEX)<=1
 8384           %FINISH
 8385           PRX(K, INDEX, CODER, 0, PN<<2+PTBASE)
 8386  Label98:      DISP=DISP&4095
 8387  %END
 8388  %ROUTINE DUMP(%INTEGER CODE, REG, DIS, X, LEVEL)
 8389  {%SHORTROUTINE}
 8390                                          ! CODE=8*(TYPE-1)+2*(PREC&3)+Z
 8391  %INTEGER K
 8392  %BYTEINTEGER ANDR;  ANDR=0
 8393  %CONSTBYTEINTEGERARRAY OPCODE(0:16)=X'41',
 8394+          X'50',X'58',X'42',X'43',X'40',X'48',X'59',X'49',
 8395+          X'70',X'78',0(4),X'60',X'68'
 8396           CODE=OPCODE(CODE) %IF CODE<=16
 8397           FAULT(216,0) %IF CODE<X'40';        ! IN 'RR' RANGE
 8398           %UNLESS 0<=DIS<=4095 %C
 8399+             %THEN ADJUST INDEX(REGISTER(X)+1, X, DIS)
 8400           ->REG KNOWN %IF REG>=0
 8401           %IF CODE=X'43' %START;         ! TRY TO AVOID CLEARING A REG
 8402              K=-1-REG;                   ! 0 OR 1 IF ADDR MODE
 8403              %WHILE REG<0 %AND K<=15 %CYCLE
 8404                 %IF REGISTER(K)=0 %AND GRUSE(K)=2 %AND GRINF(K)<=255 %C
 8405+                    %THEN NEST=K %AND REG=NEST
 8406                 K=K+1
 8407              %REPEAT
 8408           %FINISH
 8409           %IF REG=-1 %THEN K=GR0 %ELSE K=GR1
 8410           %IF 96<=CODE<=127 %THEN K=FR0
 8411           %IF REG<0 %THEN FIND REG(K, REG) %AND NEST=REG
 8412  REGKNOWN:->IC %IF CODE=X'43';           ! BYTES NEED SPECIAL CARE
 8413           ->NORMAL %UNLESS CODE=X'41' %AND DIS=0;  ! OPTIMISE LA
 8414           ->ZERO %IF X=0=LEVEL
 8415           ->SWOP %IF LEVEL=0 %OR X=0
 8416           ->NORMAL %IF X#REG#LEVEL
 8417           PRR(X'1A', REG, X+LEVEL-REG);  CCSTATE=1<<16!REG;  ->Label99
 8418  ZERO:    PRR(X'1F', REG, REG);  CCSTATE=1<<16!REG;  ->Label99
 8419  SWOP:    PRR(X'18', REG, X+LEVEL) %UNLESS REG=X+LEVEL;  ->Label99
 8420  IC:      ->NORMAL %IF GRUSE(REG)=2 %AND GRINF(REG)<=255
 8421           CCSTATE=-1
 8422           %IF REG=0 %OR X#REG#LEVEL %THEN PRR(X'1F', REG, REG) %C
 8423+             %ELSE ANDR=1
 8424  NORMAL:  PRX(CODE, REG, X, LEVEL, DIS)
 8425           %IF ANDR#0 %THEN %START
 8426              PRX(X'54', REG, 0, GLA, 24)
 8427              CCSTATE=2<<16!REG
 8428           %FINISH
 8429  Label99: %END
 8430  %ROUTINE DUMPSI(%INTEGER OPCODE, L, B, D)
 8431  {%SHORTROUTINE}
 8432           %IF D>4095 %THEN ADJUST INDEX(REGISTER(B)+1, B, D)
 8433           PSI(OPCODE, L, B, D)
 8434  %END
 8435  %ROUTINE DUMPM(%INTEGER OPCODE, R1, R2, B, D)
 8436  {%SHORTROUTINE}
 8437           %IF D>4095 %THEN %START
 8438              ADJUST INDEX(REGISTER(B)+1, B, D)
 8439           %FINISH
 8440           PRX(OPCODE, R1, R2, B, D)
 8441  %END
 8442  %ROUTINE DUMPSS(%INTEGER OP,L,B1,D1,B2,D2)
 8443  {%SHORTROUTINE}
 8444           %IF D1>4095 %THEN %C
 8445+             ADJUST INDEX(0,B1,D1)
 8446           %IF D2>4095 %THEN %C
 8447+             ADJUST INDEX(0,B2,D2)
 8448           PSS(OP,L,B1,D1,B2,D2)
 8449  %END
 8450           %END;
?WSPTRTAB2 unused
?WSPTRTAB1 unused
?DUMHEAD unused
 8451                ;                      ! OF ROUTINE CSS
 8451  !%if INCLUDE DELSTART = 1 %start
 8452  %ROUTINE CONSTLIST
 8453  {%SHORTROUTINE}
 8454  %INTEGER PRECP, NCONST, RF, J, K, LPUTP, KK, SIGN, RQ, BPTR,  %C
 8455+             TYPEP, ACC, RP, SHR
 8456  %INTEGERNAME CONSTP
 8457  %BYTEINTEGER CHAR
 8458  %LONGREAL C
 8459  %BYTEINTEGERARRAY BUFFER(0:264)
 8460  %ROUTINESPEC OUT(%INTEGER L, IA)
 8461           NCONST=0;  BPTR=0
 8462           SHR=A(2)&3;                    ! 0='%CONST'
 8463           %IF SHR=0 %THEN CONSTP==SSTL %AND LPUTP=4 %ELSE%C
 8464+                          CONSTP==CONSTPTR %AND LPUTP=5
 8465           CONSTP=(CONSTP+7)&(-8);        ! RELEVANT PTR TO D.W. BOUNDRY
 8466           TOAR4(R+2, CONSTP)
 8467           RP=R;  R=R+4
 8468           TYPEP=TYPEFLAG(A(4));  PRECP=TYPEP>>3
 8469           TYPEP=TYPEP&7
 8470           PRECP=3 %IF TYPEP=2 %AND ALL LONG=1
 8471           %IF TYPEP=5 %THEN  ACC=A(6) %ELSE ACC=BYTES(PRECP)
 8472  Label6:       RQ=Q;  CHAR=BYTE INTEGER(Q)
 8473           SIGN=1
 8474           %IF CHAR='-' %THEN SIGN=-1
 8475           %IF CHAR='+' %OR CHAR='-' %THEN Q=Q+1
 8476           CONST(0);  RF=1
 8477           ->Label98 %IF HIT=0
 8478           ->Label1 %UNLESS BYTE INTEGER(Q)='('
 8479           J=S;  Q=Q+1;  C=CVALUE;  K=CTYPE
 8480           CONST(2)
 8481           ->Label98 %UNLESS HIT=1 %AND S>0 %AND BYTE INTEGER(Q)=')'
 8482           Q=Q+1
 8483           CVALUE=C;  RF=S;  S=J;  CTYPE=K
 8484  Label1:       %IF TYPEP=5 %THEN %START
 8485              %IF CTYPE#5 %THEN %START
 8486                 ->Label98 %UNLESS CTYPE=1 %AND S<127
 8487                 A(RP+6)=S<<8;  S=1 %UNLESS S=0;  A(RP+5)=S
 8488              %FINISH
 8489              ->Label98 %UNLESS SIGN=1 %AND ACC>=A(RP+5)
 8490           %FINISH %ELSE %START
 8491              %IF CTYPE=5 %THEN ->Label98
 8492              %IF TYPEP=2 %THEN %START
 8493                 %IF CTYPE=1 %THEN CVALUE=S
 8494                 %IF SIGN<0 %THEN CVALUE=-CVALUE
 8495                 J=ADDR(CVALUE)
 8496              %FINISH %ELSE %START
 8497                 S=S*SIGN
 8498                 %IF (PRECP=1 %AND S&X'FFFFFF00'#0) %OR %C
 8499+                    (PRECP=2 %AND (|S|)&X'FFFF0000'#0) %THEN ->Label98
 8500                 J=ADDR(S)+4-ACC
 8501              %FINISH
 8502           %FINISH
 8503           %CYCLE KK=1, 1, RF
 8504              %IF TYPEP=5 %THEN OUT(ACC+1, ADDR(A(RP+5))+1) %ELSE %START
 8505  !%if USE MC = 1 %start
 8506  !               **1,@BUFFER(BPTR);  *L_2,J
 8507  !               *MVC_0(8,1),0(2);        ! MOVE IN CONSTANT RUBBISH
 8508  !%finish
 8509                 BPTR=BPTR+ACC
 8510                 %IF BPTR=256 %THEN OUT(256, ADDR(BUFFER(0)))
 8511              %FINISH;  NCONST=NCONST+1
 8512           %REPEAT;  R=RP+4
 8513           ->Label99 %UNLESS BYTE INTEGER(Q)=',';  Q=Q+1
 8514           ->Label6 %UNLESS BYTE INTEGER(Q)=10
 8515           READ LINE(0,0);  Q=ADDR(CC(1));  ->Label6
 8516  Label98:      Q=RQ
 8517  Label99:      R=RP+4;  TOAR4(RP, NCONST)
 8518           %IF TYPEP#5 %AND BPTR>0 %THEN OUT(BPTR, ADDR(BUFFER(0)))
 8519           CONSTP=(CONSTP+3)&(-4)
 8520           ->Label999
 8521  %ROUTINE OUT(%INTEGER L, IA)
 8522           LPUT(LPUTP, L, CONSTP, IA) %IF INHCODE=0
 8523           CONSTP=CONSTP+L
 8524           BPTR=0
 8525  %END
 8526  Label999: %END
 8527  %ROUTINE TEXTTEXT
 8528  %INTEGER J, QU, ARAD
 8529           S=R; HIT=0
 8530           J=0; ARAD=ADDR(A(R+1))
 8531           %RETURN %UNLESS I=M'''' %OR I=34;! FAIL UNLESS  INITIAL QUOTE
 8532           QU=I; Q=Q+1
 8533           %CYCLE
 8534              I=BYTE INTEGER(Q)
 8535              %IF I=QU %THEN %START
 8536                 Q=Q+1
 8537                 %IF BYTE INTEGER(Q)#QU %THEN %EXIT
 8538              %FINISH
 8539              BYTEINTEGER(ARAD)=I
 8540              ARAD=ARAD+1; J=J+1
 8541              %IF I=10 %THEN READ LINE(1,QU) %ELSE Q=Q+1
 8542              FAULT(106,0) %IF J>=256
 8543           %REPEAT
 8544           A(S)=J;   HIT=1
 8545           R=R+(J+1)>>1
 8546  %END
 8547  !%finish
 8548           %ROUTINE     TOAR4(%INTEGER PTR,VALUE)
 8549  !%if USE MC = 1 %start
 8550  !         **1,@A(PTR)
 8551  !         *MVC_0(4,1),VALUE
 8552  !%finish
 8553           %END
?VALUE unused
?PTR unused
 8554           %ROUTINE     TOAR8(%INTEGER PTR,%LONGREAL VALUE)
 8555  
 8556  !%if USE MC = 1 %start
 8557  !         **1,@A(PTR)
 8558  !         *MVC_0(8,1),VALUE
 8559  !%finish
 8560           %END
?VALUE unused
?PTR unused
 8561           %ROUTINE     FROMAR4(%INTEGER PTR,%INTEGERNAME VALUE)
 8562  !%if USE MC = 1 %start
 8563  !         **1,@A(PTR)
 8564  !         *L_2,VALUE
 8565  !         *MVC_0(4,2),0(1)
 8566  !%finish
 8567           %END
?VALUE unused
?PTR unused
 8568           %ROUTINE     FROMAR8(%INTEGER PTR,%LONGREALNAME VALUE)
 8569  
 8570  !%if USE MC = 1 %start
 8571  !         **1,@A(PTR)
 8572  !         *L_2,VALUE
 8573  !         *MVC_0(8,2),0(1)
 8574  !%finish
 8575           %END
?VALUE unused
?PTR unused
 8576  !%if INCLUDE DELSTART = 1 %start
 8577  %ROUTINE CONST(%INTEGER MODE)
 8578  !***********************************************************************
 8579  !*       SYNTAX CHECK AND EVALUATE ALL THE FORMS OF IMP CONSTANT       *
 8580  !*       MODE#0 FOR INTEGER CONSTANTS =0 FOR ANY SORT OF CONSTANT      *
 8581  !***********************************************************************
 8582  %INTEGER Z,T;%LONGREAL X
 8583           HIT=0
 8584           CVALUE=0;  I=BYTE INTEGER(Q)
 8585           S=0;  ->N %IF M'0'<=I<=M'9'
 8586           ->DOT %IF I='.' %AND MODE=0 %AND '0'<=BYTE INTEGER(Q+1)<='9'
 8587                                          ! 1 DIDT MIN
 8588           CTYPE=1
 8589           ->PI %IF I='$'
 8590           ->STR %IF I=M''''
 8591           ->STR2 %IF I=34
 8592           %RETURN %UNLESS BYTE INTEGER(Q+1)=M'''';  Q=Q+2
 8593           ->HEX %IF I='X'
 8594           ->MULT %IF I='M'
 8595           ->BIN %IF I=M'B'
 8596           ->RHEX %IF I='R' %AND MODE=0
 8597           ->OCT %IF I='K'
 8598           Q=Q-2;  %RETURN
 8599  PI:      Q=Q+1;                         ! '$'=3.14159ETC
 8600  !%if USE MC = 1 %start
 8601  !         *MVC_CVALUE(8),PI1
 8602  !%finish
 8603           %IF MODE=0 %THEN CTYPE=2 %AND HIT=1
 8604           WARN(LINE)
 8605           %RETURN
 8606  STR:     A(R)=5;  R=R+1
 8607           TEXTTEXT
 8608           %IF A(S)>1 %THEN CTYPE=5 %AND %RETURN
 8609           R=S-1
 8610           %IF A(S)=0 %THEN S=0 %ELSE S=A(S+1)>>8
 8611           HIT=1; %RETURN
 8612  STR2:                                   ! DOUBLE QUOTED STRING
 8613           A(R)=5; R=R+1; TEXTTEXT
 8614           CTYPE=5; %RETURN
 8615  HEX:     T=0;                           ! HEX CONSTANTS
 8616           %CYCLE
 8617              I=BYTE INTEGER(Q); Q=Q+1; T=T+1
 8618              %EXIT %IF I=M''''
 8619              %RETURN %UNLESS ('0'<=I<='9' %OR 'A'<=I<='F') %AND T<9
 8620              S=S<<4+I&15+9*I>>6
 8621           %REPEAT
 8622           HIT=1; %RETURN
 8623  RHEX:                                   ! REAL HEX CONSTANTS
 8624           T=0
 8625           %CYCLE
 8626              I=BYTE INTEGER(Q); Q=Q+1
 8627              %IF T=8 %THEN INTEGER(ADDR(CVALUE))=S %AND S=0
 8628              %EXIT %IF I=M''''; T=T+1
 8629              %RETURN %UNLESS '0'<=I<='9' %OR 'A'<=I<='F'
 8630              S=S<<4+I&15+9*I>>6
 8631           %REPEAT
 8632           %RETURN %UNLESS T=8 %OR T=16
 8633           INTEGER(ADDR(CVALUE)+4)=S
 8634           HIT=1; CTYPE=2; %RETURN
 8635  OCT:                                    ! OCTAL CONSTANTS
 8636           T=0
 8637           %CYCLE
 8638              I=BYTE INTEGER(Q); Q=Q+1; T=T+1
 8639              %EXIT %IF I=M''''
 8640              %RETURN %UNLESS '0'<=I<='7' %AND T<12
 8641              S=S<<3!(I&7)
 8642           %REPEAT
 8643           HIT=1; %RETURN
 8644  MULT:    T=0;                           ! MULTIPLE CONSTANTS
 8645           %CYCLE
 8646              I=BYTE INTEGER(Q); Q=Q+1; T=T+1
 8647              %IF I=M'''' %THEN %START
 8648                 %IF BYTE INTEGER(Q)#M'''' %THEN %EXIT %ELSE Q=Q+1
 8649              %FINISH
 8650              %RETURN %IF T>=5
 8651              S=S<<8!I
 8652           %REPEAT
 8653           HIT=1; %RETURN
 8654  BIN:     T=0;                           ! BINARY CONST
 8655           %CYCLE
 8656              I=BYTE INTEGER(Q); Q=Q+1; T=T+1
 8657              %EXIT %IF I=M''''
 8658              %RETURN %UNLESS '0'<=I<='1' %AND T<33
 8659              S=S<<1!I&1
 8660           %REPEAT
 8661           HIT=1; %RETURN
 8662  N:                                      ! CONSTANT STARTS WITH DIGIT
 8663           %CYCLE
 8664              %IF S>X'7FFFFFF' %THEN ->BIGN
 8665              S=10*S+I&15
 8666              Q=Q+1; I=BYTEINTEGER(Q)
 8667           %REPEAT %UNTIL I<M'0' %OR I>M'9'
 8668           %IF I='.' %OR I='@' %THEN CVALUE=S %AND ->FTEST
 8669           CTYPE=1; HIT=1; %RETURN
 8670  BIGN:    CVALUE=S;                      ! NUMERIC CONSTANTS TOO BIG
 8671                                          ! FOR EVALUATION IN INTEGERS
 8672           %CYCLE
 8673              CVALUE=10*CVALUE+(I&15)
 8674              Q=Q+1; I=BYTE INTEGER(Q);             ! ONTO NEXT CHAR
 8675           %REPEAT %UNTIL I<M'0' %OR I>M'9'
 8676  FTEST:   ->ALPHA %UNLESS MODE=0 %AND I='.'
 8677  DOT:     Q=Q+1;  X=10; I=BYTE INTEGER(Q)
 8678           %WHILE M'0'<=I<=M'9' %CYCLE
 8679              CVALUE=CVALUE+(I&15)/X
 8680              X=10.0*X; Q=Q+1; I=BYTE INTEGER(Q)
 8681           %REPEAT
 8682  ALPHA:                                  ! TEST FOR EXPONENT
 8683           %IF MODE=0 %AND BYTE INTEGER(Q)='@' %THEN %START
 8684              Q=Q+1;  X=CVALUE
 8685              Z=1; I=BYTE INTEGER(Q)
 8686              %IF I='-' %THEN Z=-1
 8687              %IF I='+' %OR I='-' %THEN Q=Q+1
 8688              CONST(2)
 8689              %IF HIT=0 %THEN %RETURN
 8690               S=S*Z
 8691              %IF S=-99 %THEN CVALUE=0 %ELSE CVALUE=X*10^^S
 8692           %FINISH
 8693                                          ! SEE IF IT IS INTEGER
 8694  FIX:     %COMMENT SEE IF IT IS INTEGER
 8695           -> TOO BIG %IF CVALUE>IMAX
 8696  !
 8697  ! THE NEXT LINE IS HAND CODED TO AVOID CALLING IN FRACPT ETC ON 370
 8698  !
 8699  !         ->Label41 %IF FRACPT(CVALUE)=0
 8700  !
 8701  !%if USE MC = 1 %start
 8702  !         *LD_0,CVALUE
 8703  !         *LDR_2,0
 8704  !         *AW_0,208(12);                 ! -X'4E000000000000000'
 8705  !         *AD_0,192(12);                 ! =D'0'
 8706  !         *SDR_2,0
 8707  !         *BC_8,<41>
 8708  !%finish
 8709  TOO BIG: ->Label150 %UNLESS MODE=0
 8710  Label40:      CTYPE=2; HIT=1; %RETURN
 8711  !%if USE MC = 1 %start
 8712  !41:      *LD_0,CVALUE
 8713  !         *AD_0,192(12);          ! AD_0,=D'0.5'
 8714  !         *AW_0,208(12)
 8715  !         *STD_0,0(11)
 8716  !         *MVC_S(4),4(11);        ! S=INT(CVALUE)
 8717  !%finish
 8718  Label99:      CTYPE=1; HIT=1; %RETURN
 8719  Label150:     HIT=0;                        ! FAILURE
 8720           %END
?LABEL99 unused
?LABEL40 unused
?FIX unused
 8721           %ROUTINE PNAME
 8722           {%SHORTROUTINE}; HIT=0; NUM=0
 8723  !%if USE MC = 1 %start
 8724  !         *L_6,Q
 8725  !         *L_3,TRTABS
 8726  !         *SR_1,1; *LR_2,1; *ST_1,NUM
 8727  !         *STM_1,2,0(11)
 8728  !         *TRT_0(255,6),0(3)
 8729  !         *LR_0,1; *SR_1,6;              ! LENGTH IN GR1
 8730  !%finish
 8731  
 8732  !%if USE MC = 1 %start
 8733  !         *BC_8,<3>;                     ! ZERO LENGTH = NOT A NAME
 8734  !         *BCT_2,*+8
 8735  !         *BC_15,<3>;                    ! NAME END IN QUOTE =FAIL
 8736  !         *L_14,LETT; *L_3,NEXT; *AR_3,14
 8737  !         *STC_1,0(3);                   ! MOVE IN LENGTH
 8738  !         *EX_1,<NAMMOVE>;               ! MOVE IN CHARS (+1 XTRA)
 8739  !         *EX_1,<MOVEP>
 8740  !         *LR_6,0; *ST_6,Q;              ! UPDATE TEXT POINTER
 8741  !         *LH_2,0(11); *MH_2,HH1
 8742  !         *LH_0,2(11); *MH_0,HH1+2; *ALR_2,0
 8743  !         *LH_0,4(11); *MH_0,HH2; *ALR_2,0
 8744  !         *LH_0,6(11); *MH_0,HH2+2; *ALR_2,0
 8745  !         *LR_4,2;                       ! INITIAL HASH VALUE
 8746  !         *SRL_2,9; *STC_2,NUM+3
 8747  !         *OI_NUM+3,2; *NI_NUM+3,62
 8748  !         *L_15,WORD; *L_5,NNAMES
 8749  !         *LA_0,0(5,5)
 8750  !         *ALR_4,4
 8751  !LOOKL:   *NR_4,0;                       ! TO KEEP WITHIN WORD
 8752  !         *LH_2,0(4,15);                 ! GET WORD(I)
 8753  !         *LTR_2,2; *BC_8,<NEWNAME>;     ! EMPTY HOLE FOR NEW NAME
 8754  !         *AR_2,14; *EX_1,<NAMCOMP>;     ! COMPARE
 8755  !         *BC_8,<FOUND>
 8756  !         *A_4,NUM
 8757  !         *BCT_5,<LOOKL>
 8758  !%finish
 8759           FAULT(104,0)
 8760  !%if USE MC = 1 %start
 8761  !NAMCOMP: *CLC_0(1,2),0(3)
 8762  !NAMMOVE: *MVC_1(1,3),0(6)
 8763  !MOVEP:   *MVC_0(1,11),0(3)
 8764  !%finish
 8765  DFULL:   FAULT(103,0)
 8766  !%if USE MC = 1 %start
 8767  !NEWNAME: *SR_3,14; *STH_3,0(4,15)
 8768  !         *LA_3,1(1,3); *ST_3,NEXT;      ! UPDATE NEXT TO INCLUDE NEWNAME
 8769  !         *CH_3,DSIZE; *BC_2,<DFULL>
 8770  !FOUND:   *SRL_4,1; *L_2,R; *AR_2,2
 8771  !         *STH_4,A+30(2)
 8772  !%finish
 8773           HIT=1
 8774  Label3:       %END
?LABEL3 unused
?DFULL unused
 8775  !%finish
 8776  Label8:        %BEGIN
 8777           {%SHORTROUTINE}
 8778           %INTEGER I,J,K
 8779  Label1:       FETCH AR
 8780           STMTSHELD=STMTSHELD+1
 8781           STPTRS(STMTSHELD)=1
 8782           STOPSTM=1 %UNLESS A(1)<=6 %OR A(1)=14
 8783  Label20:      %IF STOPSTM#0 %OR CHECKSP#0 %THEN ->Label10
 8784           STORE AR(I); ->Label10 %IF I=0
 8785           STPTRS(STMTSHELD)=TOPPTR-R
 8786           ->Label1
 8787  Label10:      CSS(STPTRS(1),1)
 8788  !         CHECK ASL %IF PRINTMAP#0
 8789           %IF DCOMP#0 %AND CA>CABUF %THEN %START
 8790              CODE OUT
 8791              PRINT USE
 8792           %FINISH
 8793           STMTSHELD=STMTSHELD-1
 8794           %IF STMTSHELD=0 %THEN %START
 8795           STOPSTM=0
 8796           TOPPTR=500; ->Label1; %FINISH
 8797           %IF STMTSHELD=1 %THEN %START
 8798            STPTRS(1)=1
 8799           TOPPTR=500; ->Label20; %FINISH
 8800           J=STPTRS(2)-STPTRS(1)
 8801  !         %CYCLE I=500,1,TOPPTR-J
 8802  !         A(I)=A(I+J)
 8803  !         %REPEAT
 8804           TOPPTR=TOPPTR-J
 8805  !%if USE MC = 1 %start
 8806  !         *L_3,A; *LA_3,1000(3)
 8807  !         *L_2,J; *AR_2,2; *AR_2,3
 8808  !         *L_1,TOPPTR; *AR_1,1; *LA_0,998; *SR_1,0
 8809  !         *LA_0,256
 8810  !M2:      *SR_1,0; *BC_4,<M3>
 8811  !         *MVC_0(256,3),0(2); *BC_8,<M4>
 8812  !         *AR_3,0; *AR_2,0; *BC_15,<M2>
 8813  !M5:      *MVC_0(1,3),0(2)
 8814  !M3:      *BCTR_1,0; *EX_1,<M5>
 8815  !%finish
 8816  M4:      %CYCLE I=1,1,STMTSHELD-1
 8817           STPTRS(I)=STPTRS(I+1)-J
 8818           %REPEAT; STPTRS(STMTSHELD)=1; ->Label20
 8819           %END
?M4 unused
?K unused
 8820           %ROUTINE FETCH AR
 8821           {%SHORTROUTINE}
 8822  !%if INCLUDE DELSTART = 1 %start
 8823  Label1:       %IF Q>=LENGTH %THEN READ LINE(0,0) %AND Q=ADDR(CC(1))
 8824           R=1; OLDLINE=LINE; A(0)=LINE; QMAX=Q
 8825           COMPARE
 8826           %IF R>ARSIZE %AND R>ARSIZE+300*CHECKSP %THEN FAULT(102,0)
 8827           %IF HIT=0 %THEN %START
 8828           FAULT(100,0); ->Label1
 8829           %FINISH
 8830           ->Label1 %IF  A(1)=10 %OR A(1)=29
 8831  !%finish
 8832           STMTS=STMTS+1
 8833           %END
 8834           %ROUTINE STORE AR(%INTEGERNAME SUCCESS)
 8835           {%SHORTROUTINE}
 8836           %INTEGER I
 8837           SUCCESS=0
 8838           %RETURN %IF STMTSHELD>=14 %OR R+TOPPTR>=799
 8839  !         %CYCLE I=0,1,R
 8840  !         A(TOPPTR+I)=A(I)
 8841  !         %REPEAT
 8842  !%if USE MC = 1 %start
 8843  !         *L_2,A; *L_3,TOPPTR
 8844  !         *AR_3,3; *AR_3,2
 8845  !         *LA_1,1; *A_1,R; *AR_1,1
 8846  !         *LA_0,256
 8847  !M2:      *SR_1,0; *BC_4,<M3>
 8848  !         *MVC_0(256,3),0(2); *BC_8,<M4>
 8849  !         *AR_3,0; *AR_2,0; *BC_15,<M2>
 8850  !M5:      *MVC_0(1,3),0(2)
 8851  !M3:      *BCTR_1,0; *EX_1,<M5>
 8852  !%finish
 8853  M4:      TOPPTR=TOPPTR+R+1
 8854           SUCCESS=1
 8855           %END
?M4 unused
?I unused
 8856  !%if INCLUDE DELSTART = 1 %start
 8857           %ROUTINE     READ LINE(%BYTEINTEGER N,CHAR)
 8858           {%SHORTROUTINE}
 8859           %ROUTINESPEC GET LINE
 8860           %OWNINTEGER LAST=-1
 8861           %BYTEINTEGER NP
 8862           {%REGISTER}%integer ATRTABS
 8863           %OWNINTEGER M127=127
 8864           {%REGISTER}%integer DEL
 8865           %INTEGER LL,L73,PAD
 8866           %CONSTBYTEINTEGERARRAY TR(0:127)=1,0(9),1,0(117)
 8867           %BYTEINTEGERARRAY TLINE(0:255)
 8868           ATRTABS=ADDR(TRTABS(0))
 8869           NP=N; LENGTH=1; LENGTHP=1
 8870           DEL=0; QMAX=ADDR(CC(1))
 8871  Label1:       LENGTH=LENGTH-1
 8872  Label2:                                     ! READ IN A LINE
 8873           %IF FILE ADDR=0 %THEN GET LINE %ELSE %START
 8874              LL=FILE END-FILE PTR-1
 8875              %MONITOR {9} %IF LL<0
 8876  !%if USE MC = 1 %start
 8877  !            *L_14,LL; *LA_15,255
 8878  !            *L_3,FILEPTR; *L_4,TR; *SR_1,1
 8879  !            *CR_14,15; *BC_10,*+6; *LR_15,14
 8880  !            *EX_15,<TRTP>
 8881  !            *BC_7,*+8; *LA_1,0(15,3)
 8882  !            *LA_15,1(1); *SR_1,3
 8883  !            *L_4,TLINE; *EX_1,<MOVEP>
 8884  !            *LA_1,1(1); *ST_1,LL
 8885  !            *ST_15,FILEPTR; *IC_1,73(4); *ST_1,L73
 8886  !            *ST_4,PAD; *MVI_73(4),10
 8887  !%finish
 8888           %FINISH
 8889  !%if USE MC = 1 %start
 8890  !         *L_4,CC; *A_4,LENGTH;      ! SET POINTER TO CC FORRCL
 8891  !         *L_1,TLINE;                ! POINTER TO RAW LINE
 8892  !         *L_0,LL; *AR_0,1;          !ADDR OF LAST CHAR
 8893  !         *SR_2,2;                   ! TO RECEIVE CHAR TYPE FROM TRT
 8894  !         *CLI_NP,0; *BC_8,<NEXT>;      ! TEXT MODE SEPARATE
 8895  !         *MVI_1187(5),0; *MVI_1192(5),0; *BC_15,<TNEXT>
 8896  !UNFIN:   *S_4,CC; *ST_4,LENGTH; *BC_15,<2>
 8897  !NEXT:    *LA_1,1(0,1)
 8898  !SAME:    *TRT_0(255,1),768(5);         ! EXTRACT NEXT VALID CHAR
 8899  !         *CR_1,0; *BC_12,<TAB>(2);     ! SWITCH ON CHAR
 8900  !TAB:     *BC_15,<UNFIN>;               ! UNLESS ENDOFLINE WITHOUT NL
 8901  !         *BC_15,<QUOTE>
 8902  !         *BC_15,<SP>
 8903  !         *BC_15,<NL>
 8904  !         *BC_15,<PERCENT>
 8905  !         *BC_15,<NONALPHA>
 8906  !         *BC_15,<ALPHA>
 8907  !         *BC_15,<MAP>
 8908  !QUOTE:   *XI_NP,1
 8909  !         *MVC_CHAR(1),0(1);             ! SAVE STRING OPENING CHAR
 8910  !         *MVC_1(1,4),CHAR
 8911  !         *LA_1,1(0,1); *LA_4,1(0,4)
 8912  !         *MVI_1281(5),0;               ! TRTAB TO SKIP 7
 8913  !         *MVI_1192(5),0;               ! TRTAB TO SKIP PERCENT
 8914  !         *MVI_1187(5),0; *BC_15,<TCOM>;! TRTAB TO SKIP SPACE
 8915  !SP:      *SR_6,6
 8916  !         *TRT_0(255,1),897(5);         ! NEXT VALID NON SPACE
 8917  !         *CR_1,0; *BC_12,<TAB>(2);     ! SWITCH ON CHAR
 8918  !         *BC_15,<UNFIN>
 8919  !NL:      *SR_6,6                       ;! DEL=0
 8920  !         *MVI_1(4),10;                 ! MOVE IN NEWLINE
 8921  !         *LA_4,1(0,4); *BC_15,<ENDLINE>
 8922  !PERCENT: *LA_6,128;                    ! DEL=128
 8923  !         *LA_1,1(0,1)
 8924  !         *LNR_3,1
 8925  !         *LR_15,1
 8926  !         *TRT_0(39,1),1026(5)
 8927  !         *BC_8,<SAME>
 8928  !         *AR_3,1
 8929  !         *BC_8,<SAME>
 8930  !         *EX_3,<MOVE>
 8931  !         *EX_3,<ULINE>
 8932  !         *LA_4,0(3,4)
 8933  !         *N_2,M127
 8934  !         *BC_7,<TAB>(2)
 8935  !         *BC_15,<SAME>
 8936  !TRTP:    *TRT_0(1,3),0(4)
 8937  !MOVEP:   *MVC_1(1,4),0(3)
 8938  !MOVE:    *MVC_1(0,4),0(15)
 8939  !ULINE:   *OC_1(0,4),0(5);              ! OR WITH X'80'
 8940  !NONALPHA:*SR_6,6;                      ! DEL=0
 8941  !ENBLOCK: *LNR_3,1;*LR_15,1
 8942  !         *TRT_0(255,1),1155(5);        !TEST FOR ALPHANUMERICS
 8943  !         *AR_3,1
 8944  !         *EX_3,<MOVE>;                 ! QUICKER TO MOVE 1 TOO MANY
 8945  !         *LA_4,0(3,4)
 8946  !         *N_2,M127
 8947  !         *BC_7,<TAB>(2)
 8948  !         *BC_15,<SAME>
 8949  !ALPHA:   *LTR_6,6;                     ! -> ENBLOCK %IF DEL=0
 8950  !         *BC_8,<ENBLOCK>
 8951  !         *MVC_1(1,4),0(1)
 8952  !         *OI_1(4),128
 8953  !         *LA_4,1(0,4);*BC_15,<NEXT>
 8954  !MAP:     *SR_6,6;                      ! DEL=0
 8955  !         *MVI_1(4),92;                 ! MAP TWIDDLES INTO '\'
 8956  !         *LA_4,1(0,4); *BC_15,<NEXT>
 8957  !TUNFIN:  *S_4,CC; *ST_4,LENGTH; *BC_15,<2>
 8958  !TNEXT:   *LA_1,1(0,1)
 8959  !%finish
 8960  TSAME:
 8961  !%if USE MC = 1 %start
 8962  !         *TRT_0(255,1),768(5);         ! EXTRACT NEXT VALID CHAR
 8963  !         *CR_1,0; *BC_12,<TTAB>(2);    ! SWITCH ON CHAR
 8964  !TTAB:    *BC_15,<TUNFIN>
 8965  !         *BC_15,<TQUOTE>
 8966  !         *BC_15,<TCOM>
 8967  !         *BC_15,<TNL>
 8968  !         *BC_15,<TCOM>
 8969  !         *BC_15,<TCOM>
 8970  !         *BC_15,<TCOM>
 8971  !         *BC_15,<TCOM>
 8972  !%finish
 8973  TQUOTE:
 8974  !%if USE MC = 1 %start
 8975  !         *MVC_1(1,4),0(1)
 8976  !         *LA_4,1(0,4)
 8977  !         *CLC_CHAR(1),0(1)
 8978  !         *BC_7,<TNEXT>;                 ! NOT THE CLOSING CHAR
 8979  !         *XI_NP,1
 8980  !         *MVI_1281(5),28;              ! TRTAB AS INITIALISED FOR \
 8981  !         *MVI_1187(5),8;               ! TRTAB AS INITIALISED
 8982  !         *MVI_1192(5),16;              ! TRTAB AS INITIALISED
 8983  !         *SR_6,6;
 8984  !         *BC_15,<NEXT>
 8985  !TCOM:    *LNR_3,1; *LR_15,1
 8986  !         *TRT_0(255,1),1155(5)
 8987  !         *AR_3,1; *EX_3,<MOVE>;        ! MOVES ONE MORE THAN NEEDED
 8988  !         *LA_4,0(3,4); *N_2,M127
 8989  !         *BC_7,<TTAB>(2); *BC_15,<TSAME>
 8990  !TNL:     *CLI_0(4),32;                 ! CHECK FOR TRAILING SPACES
 8991  !         *BC_7,<TNL2>
 8992  !         *BCT_4,<TNL>
 8993  !TNL2:    *MVI_1(4),10;                 ! MOVE IN NEWLINE
 8994  !         *MVI_1281(5),28;              ! TRTAB AS INITIALISED FOR \
 8995  !         *MVI_1192(5),16; *MVI_1187(5),8;! TRTAB AS INITIALISED
 8996  !         *LA_4,1(0,4)
 8997  !ENDLINE: *S_4,CC; *ST_4,LENGTH
 8998  !%finish
 8999           ->Label1 %IF LENGTH=LENGTHP %AND N=0;! IGNORE NL IN PRGRMODE
 9000           -> NOLIST %IF LIST=0
 9001           NEWLINE; %IF LINE=LAST %THEN %START
 9002           SPACES(5);PRINT SYMBOL('C')
 9003           %IF PRINTMAP=1 %THEN SPACES(3*LEVEL+5) %ELSE SPACES(4*LEVEL)
 9004           %FINISH %ELSE %START
 9005           WRITE(LINE+1,5)
 9006           LAST=LINE
 9007           PRINTSYMBOL(M'''') %IF N=1
 9008           SPACES(2-N)
 9009           %IF PRINTMAP=1 %THEN PRHEX(CA,5)
 9010           SPACES((4-PRINTMAP)*LEVEL-2)
 9011           %FINISH
 9012           TLINE(73)=L73; BYTE INTEGER(PAD)=LL-1
 9013           IOCP(15,PAD);       ! PRINTSTRING EXCEPT FINAL NL
 9014  NOLIST:
 9015           ->Label5 %UNLESS LENGTH>=2 %AND CC(LENGTH-1)=195;!%C   AT LINE EDN
 9016           LENGTH=LENGTH-2; LENGTHP=LENGTHP+1
 9017  Label20:      %COMMENT ALL THE FOLLOWING IS TO SKIP NLS AFTER '%C'
 9018           GET LINE
 9019  !%if USE MC = 1 %start
 9020  !         *L_4,CC; *A_4,LENGTH;      ! SET POINTER TO CC FORRCL
 9021  !         *L_1,TLINE;                 ! POINTER TO RAW LINE
 9022  !         *L_0,LL; *AR_0,1;          ! ADDR OF LAST CHAR
 9023  !         *SR_2,2;                   ! TO RECEIVE CHAR TYPE FROM TRT
 9024  !NEXTP:   *LA_1,1(0,1); *TM_0(1),128
 9025  !         *BC_1,<NEXTP>; *CLI_0(1),10
 9026  !         *BC_8,<20>; *BC_15,<SAME>
 9027  !%finish
 9028  Label5:       LINE=LINE+1
 9029           FAULT(101,0) %IF LENGTH>=CCSIZE
 9030  !%if USE MC = 1 %start
 9031  !         *L_4,LENGTH; *A_4,CC
 9032  !         *ST_4,LENGTH
 9033  !         *XC_1(3,4),1(4);              !CLEAR BEYOND NL
 9034  !%finish
 9035           Q=ADDR(CC(1))
 9036           %RETURN
 9037           %ROUTINE GET LINE
 9038           %INTEGER J,K
 9039           %IF FILE ADDR=0 %THEN %START;  ! SOURCE NOT A 'CLEAN' FILE
 9040              IOCP(6,0);                  ! RECONSTRUCT A SOURCE LINE
 9041  !%if USE MC = 1 %start
 9042  !            *L_2,TLINE;                  ! TO RECEIVE A COPY
 9043  !            *SR_3,3; *IC_3,0(1);        ! LENGTH
 9044  !            *EX_3,<MOVE>;               ! MAKE COPY OF LINE
 9045  !            *ST_3,LL;                   ! LL=LENGTH+1
 9046  !%finish
 9047              L73=TLINE(73)
 9048             IOCP(14,0)
 9049  !%if USE MC = 1 %start
 9050  !           *ST_1,PAD
 9051  !%finish
 9052           %FINISH %ELSE %START
 9053              LL=FILE END-FILE PTR-1
 9054              %IF LL<0 %THEN %MONITOR {99}
 9055  !            LL=0
 9056  !            %CYCLE
 9057  !               K=BYTE INTEGER(FILEPTR); ! NEXT CHAR FROM SORCE FILE
 9058  !               FILE PTR=FILE PTR+1
 9059  !               TLINE(LL+1)=K
 9060  !               LL=LL+1 %IF LL<250
 9061  !            %REPEAT %UNTIL K=NL %OR K=0
 9062  !            L73=TLINE(73);              ! SAVE 73 CHARACTER
 9063  !            TLINE(73)=10
 9064  !            PAD=ADDR(TLINE(0))
 9065  !%if USE MC = 1 %start
 9066  !            *L_14,LL; *LA_15,255
 9067  !            *L_3,FILEPTR; *L_4,TR; *SR_1,1;! TRT DOES NOT CLEAR R1!
 9068  !            *CR_14,15; *BC_10,*+6; *LR_15,14
 9069  !            *EX_15,<TRTP>
 9070  !            *BC_7,*+8; *LA_1,0(15,3)
 9071  !            *LA_15,1(1); *SR_1,3;       ! LL-1 IN R1
 9072  !            *L_4,TLINE; *EX_1,<MOVEP>
 9073  !            *LA_1,1(1); *ST_1,LL
 9074  !            *ST_15,FILEPTR
 9075  !            *IC_1,73(4); *ST_1,L73
 9076  !         *ST_4,PAD; *MVI_73(4),10
 9077  !%finish
 9078           %FINISH
 9079           %RETURN
 9080  !%if USE MC = 1 %start
 9081  !MOVE:    *MVC_0(1,2),0(1)
 9082  !TRTP:    *TRT_0(1,3),0(4)
 9083  !MOVEP:   *MVC_1(1,4),0(3)
 9084  !%finish
 9085           %END
?K unused
?J unused
 9086           %END
?LABEL20 unused
?TQUOTE unused
?TSAME unused
?LABEL2 unused
?TR unused
?M127 unused
?CHAR unused
 9087                 %ROUTINE COMPARE
 9088           {%SHORTROUTINE}
 9089           %INTEGER RA,RQ,RR,RS
 9090           %SHORTINTEGER RP,PP,ALT,MARKER
 9091           %OWNINTEGER THIRTYTWO=32
 9092  
 9093  
 9094  
 9095  
 9096  
 9097  
 9098  ! GENERATED ON 27/04/77
 9099  %CONSTSHORTINTEGERARRAY SYMBOL( 1059: 2900)= 299,   301,   296,   297,  {   1062
 9100+    289,   300,   713, 50694, 54734, 52421, 54227,  1495, 51401, 52421,  {   1072
 9101+   1493, 52948, 51660,  1987, 53197, 52677, 52948,  1993, 52948, 50631,  {   1082
 9102+  50642,  1234, 50625, 52228, 49881, 54469,  1491, 51407, 53972,  1228,  {   1092
 9103+  53198, 50950, 54228, 53961, 52935,  2002, 53205, 54473, 52933,   710,  {   1102
 9104+  52739, 52673, 53252, 52929, 52677,  1746, 50627, 53202, 50181, 49618,  {   1112
 9105+  53953, 55561, 49618, 53953, 55758, 49613, 50441, 53190, 53458, 53191,  {   1122
 9106+  53953, 52486, 53190, 50889, 52421,  1743, 50892, 51667, 54279, 53190,  {   1132
 9107+  52675, 53188, 50438, 50895, 53965, 49620,  1235, 53445, 49923, 49614,  {   1142
 9108+  50178, 53202,  1742, 53202, 52673, 52225, 14852, 53445, 53965,  1225,  {   1152
 9109+  53187, 53254, 52673, 51662, 50640,   975, 55246,  2245, 55508, 50642,  {   1162
 9110+  52929, 52233, 50648, 54482, 51662, 54217, 49925, 50127, 52947, 54274,  {   1172
 9111+  11582,  1235, 54479, 53253, 54228, 49618, 54281, 54472, 50638, 54228,  {   1182
 9112+  49618, 54276, 54472, 50638,  1475, 55747, 52421,  2516, 51397, 52931,  {   1192
 9113+  55747, 52421,  2501, 52435, 50643, 54465, 53972,  1221, 52435, 50433,  {   1202
 9114+  24325, 50646, 50638, 54273, 15622, 54233, 54228, 50637,  1988, 55758,  {   1212
 9115+  49613, 51651,   316,   318,   298,   336,  1104, 21844, 24327, 21843,  {   1222
 9116+  18766, 18218, 11268, 17490, 20304,   320,  2512, 53961, 52948, 54469,  {   1232
 9117+  55508,  1746, 50644, 54738, 52742, 53957, 54229, 52436,  1997, 53198,  {   1242
 9118+  51668, 53202,  1221, 55497, 54278, 53957, 53445, 49620,   965, 52932,  {   1252
 9119+   1490, 50625, 52435,  1474, 50631, 51662,  1478, 49621, 52436,  1734,  {   1262
 9120+  51662, 51667, 51206, 54231, 51668, 50120,  1228, 51667, 54279, 54224,  {   1272
 9121+  50627, 51649, 52231, 54482, 54739, 54469, 50183, 53458, 53191, 53953,  {   1282
 9122+  52488, 53957, 51145, 54228, 50642,  1485, 50127, 50373,  1987, 53198,  {   1292
 9123+  54482, 53196,  1732, 50630, 51662, 50434, 53198,  2624,  2610,-11008,  {   1302
 9124+  24576, 30791,  2618,-11008, 24576, 30793,  2624, 18416, 12296,  2686,  {   1312
 9125+   2640, 18416, 12300,  2035,  2754,  2035,  4152,  2650, 18416, 12308,  {   1322
 9126+   2035,  2686,  2668,-11008, 24576, 30795,  2035,  2708,-11008, 24576,  {   1332
 9127+  30797,  2686,-11008, 24576, 30799,  2035,  2708,-11008, 24576, 30799,  {   1342
 9128+   2708,  2702, 18416, 12300,  2035,  2754,  2035,  4152,  2708, 18416,  {   1352
 9129+  12296,  2732,  2732, 18416, 12336, 18416, 12384,  2035,  2624, 18416,  {   1362
 9130+  12340,  2035,  2732,  2754,  2748, 18416, 12388,  2035,  2624, 18416,  {   1372
 9131+  12292,  2754, 18416, 12296,  2784,  2778,-11008, 24576, 30795,  2035,  {   1382
 9132+   2708,  2035,  2784,-11008, 24576, 30797,  2784, 18416, 12296,  2808,  {   1392
 9133+   2802,-11008, 24576, 30801,  2035,  2708, 18416, 12292,  2808, 18416,  {   1402
 9134+  12296,  2824,  2818,-11008, 24576, 30801,  2824, 18416, 12296,  2842,  {   1412
 9135+   2834,-11007, 24576, 30803,  2842,-11003, 24576, 30806,  2860,  2852,  {   1422
 9136+ -11004, 24576, 30813,  2860,-11004, 24576, 30819,  2878,  2870,-11008,  {   1432
 9137+  24576, 30799,  2878,-11002, 24576, 30825,  2950,  2888,-11002, 24576,  {   1442
 9138+  30833,  2896,-11005, 24576, 30841,  2910,-11005, 24576, 30846,-11002,  {   1452
 9139+  24576, 30833,  2924,-11004, 24576, 30851,-11002, 24576, 30833,  2938,  {   1462
 9140+ -11005, 24576, 30857,-11005, 24576, 30841,  2950,-11003, 24576, 30862,  {   1472
 9141+   2035,  5106,  2970,  2960,-11002, 24576, 30869,  2970,  2035,  2878,  {   1482
 9142+   2035,  2970,  2988,  2980,-11007, 24576, 30877,  2988,-11006, 24576,  {   1492
 9143+  30880,  3036,  3000,  2035,  2950,  2035,  3084,  3010,  2035,  2878,  {   1502
 9144+   2035,  3100,  3018,-11005, 24576, 30884,  3036,-11003, 24576, 30889,  {   1512
 9145+   2035,  3068,-11005, 24576, 30884,  3050,  3044, 18416, 12316,  3050,  {   1522
 9146+  18416, 12300,  3068,  3058, 18416, 12316,  3068, 18416, 12300,  2035,  {   1532
 9147+   2754,  3084,  3078,-11004, 24576, 30896,  3084, 18416, 12296,  3100,  {   1542
 9148+   3094,-11005, 24576, 30884,  3100, 18416, 12296,  3124,  3110,-11000,  {   1552
 9149+  24576, 30902,  3118,-11005, 24576, 30884,  3124, 18416, 12296,  3158,  {   1562
 9150+   3152,-11008, 24576, 30795,  2035,  2988, 18416, 12332,  2035,  3158,  {   1572
 9151+ -11008, 24576, 30797,  3158, 18416, 12296,  3184,  3178,  2035,  2808,  {   1582
 9152+   2035,  2988, 18416, 12332, 18416, 12292,  3184, 18416, 12296,  3224,  {   1592
 9153+   3194,-11000, 24576, 30912,  3202,-11003, 24576, 30922,  3210,-11003,  {   1602
 9154+  24576, 30929,  3218,-11002, 24576, 30936,  3224, 18416, 12296,  3240,  {   1612
 9155+   3234,-11003, 24576, 30944,  3240, 18416, 12296,  3344,  3274,-11003,  {   1622
 9156+  24576, 30944, 18416, 12300,-11008, 24576, 30795,  2035,  4466,  2035,  {   1632
 9157+   4442,-11008, 24576, 30797,  3314,-11005, 24576, 30951, 18416, 12336,  {   1642
 9158+  18416, 12300,  2035,  4132, 18416, 12340,-11008, 24576, 30795, 18416,  {   1652
 9159+  12300,-11008, 24576, 30797,  3344, 18416, 12336,  2035,  3616, 18416,  {   1662
 9160+  12340,-11008, 24576, 30795, 18416, 12300,-11008, 24576, 30797,  3386,  {   1672
 9161+   3364,  2035,  2708, 18416, 12396,  2035,  2708,  2035,  3386,  3386,  {   1682
 9162+ -11008, 24576, 30795,  2035,  3344,  2035,  3404,-11008, 24576, 30797,  {   1692
 9163+   3404,  3398, 18416, 12396,  2035,  2708,  3404, 18416, 12296,  3444,  {   1702
 9164+   3422,-11006, 24576, 30956,  2035,  3344,  2035,  3444,  3438,-11007,  {   1712
 9165+  24576, 30960,  2035,  3344,  2035,  3468,  3444, 18416, 12296,  3468,  {   1722
 9166+   3462,-11006, 24576, 30956,  2035,  3344, 18416, 12292,  3468, 18416,  {   1732
 9167+  12296,  3492,  3486,-11007, 24576, 30960,  2035,  3344, 18416, 12292,  {   1742
 9168+   3492, 18416, 12296,  3510,  3504, 18416, 12392,  2035,  2708,  3510,  {   1752
 9169+  18416, 12296,  3526,  3520,-11005, 24576, 30951,  3526, 18416, 12296,  {   1762
 9170+   3544,  3536,-11005, 24576, 30857,  3544,-11003, 24576, 30963,  3578,  {   1772
 9171+   3572,-11008, 24576, 30801,  2035,  2708,-11008, 24576, 30970,  2035,  {   1782
 9172+   2708, 18416, 12292,  3578, 18416, 12296,  3616,  3592,-11005, 24576,  {   1792
 9173+  30972, 18416, 12328,  3604,-11005, 24576, 30977, 18416, 12328,  3616,  {   1802
 9174+ -11003, 24576, 30982, 18416, 12328,  3644,  3628,  2035,  3100, 18416,  {   1812
 9175+  12332,  3644,-11004, 24576, 30896,  2035,  3224,  2035,  3644,  3660,  {   1822
 9176+   3660, 18416, 12332,  2035,  4196,  2035,  3660,  3680,  3674,-11008,  {   1832
 9177+  24576, 30801,  2035,  3644,  3680, 18416, 12296,  3732,  3708, 18416,  {   1842
 9178+  12336, 18416, 12332,  2035,  4236, 18416, 12340,  2035,  3732, 18416,  {   1852
 9179+  12320,  3732,-11004, 24576, 30896, 18416, 12300,  2035,  3802,  2035,  {   1862
 9180+   5132, 18416, 12312,  3768,  3762,-11008, 24576, 30801, 18416, 12336,  {   1872
 9181+  18416, 12332,  2035,  4236, 18416, 12340, 18416, 12292,  3768, 18416,  {   1882
 9182+  12296,  3802,  3778,-11006, 24576, 30989,  3786,-11001, 24576, 30993,  {   1892
 9183+   3794,-11000, 24576, 31002,  3802,-11004, 24576, 31012,  3840,  3840,  {   1902
 9184+ -11008, 24576, 30795,  2035,  2600, 18416, 12304,-11008, 24576, 30970,  {   1912
 9185+   2035,  2600, 18416, 12304,-11008, 24576, 30797,  3864,  3858,-11008,  {   1922
 9186+  24576, 30801, 18416, 12316, 18416, 12292,  3864, 18416, 12296,  3890,  {   1932
 9187+   3890, 18416, 12316,  2035,  3840,-11007, 24576, 31018,  2035,  3036,  {   1942
 9188+   2035,  3890,  3910,  3904,-11008, 24576, 30801,  2035,  3864,  3910,  {   1952
 9189+  18416, 12296,  3932,  3920,-11005, 24576, 31021,  3926, 18416, 12316,  {   1962
 9190+   3932, 18416, 12296,  3960,  3954,-11008, 24576, 30801, 18416, 12332,  {   1972
 9191+   2035,  3802, 18416, 12292,  3960, 18416, 12296,  4012,  3970,-11008,  {   1982
 9192+  24576, 30970,  3988,  2035,  2824,  2035,  3344,  2035,  3404, 18416,  {   1992
 9193+  12320,  4006,  2035,  2842,  2035,  3344,  2035,  3404, 18416, 12320,  {   2002
 9194+   4012, 18416, 12320,  4054,  4022,-11004, 24576, 31026,  4030,-11000,  {   2012
 9195+  24576, 31032,  4054,-11005, 24576, 31042, 18416, 12336,  2035,  5164,  {   2022
 9196+  18416, 12340,  2035,  4104,  4084,  4064,-11004, 24576, 31047,  4072,  {   2032
 9197+ -11000, 24576, 31053,  4084,-11005, 24576, 31042,  2035,  5164,  4104,  {   2042
 9198+   4098,-11006, 24576, 30956,  2035,  5164,  4104, 18416, 12296,  4132,  {   2052
 9199+   4114,-11000, 24576, 31063,  4126,-11005, 24576, 31073,  2035,  5164,  {   2062
 9200+   4132, 18416, 12296,  4152,  4146,-11008, 24576, 31078, 18416, 12300,  {   2072
 9201+   4152, 18416, 12296,  4180,  4174,-11008, 24576, 31078, 18416, 12300,  {   2082
 9202+   2035,  2754,  2035,  4152,  4180, 18416, 12296,  4196,  4190,-11004,  {   2092
 9203+  24576, 31080,  4196, 18416, 12296,  4236,  4204,  2035,  3802,  4236,  {   2102
 9204+ -11008, 24576, 30795,  2035,  2708,-11008, 24576, 30970,  2035,  2708,  {   2112
 9205+   2035,  3544,-11008, 24576, 30797,  4260,  4254,-11008, 24576, 31086,  {   2122
 9206+  18416, 12384, 18416, 12308,  4260, 18416, 12296,  4296,  4274,-11003,  {   2132
 9207+  24576, 31088, 18416, 12380,  4282,-11001, 24576, 30993,  4290,-11002,  {   2142
 9208+  24576, 31095,  4296, 18416, 12296,  4348,  4342, 18416, 12300,  2035,  {   2152
 9209+   2754,  2035,  4152,-11008, 24576, 31086,  2035,  2708,-11008, 24576,  {   2162
 9210+  30801,  2035,  2708,-11008, 24576, 30801,  2035,  2708,  4348, 18416,  {   2172
 9211+  12296,  4442,  4360,  2035,  2878,  2035,  3680,  4392,-11003, 24576,  {   2182
 9212+  30889, 18416, 12332,-11008, 24576, 30795, 18416, 12300,-11008, 24576,  {   2192
 9213+  30797, 18416, 12320,  4442,-11003, 24576, 30889,-11004, 24576, 30896,  {   2202
 9214+  18416, 12336, 18416, 12300,  2035,  3802, 18416, 12340,-11008, 24576,  {   2212
 9215+  30795, 18416, 12300,-11008, 24576, 30797, 18416, 12320,  4466,  4460,  {   2222
 9216+ -11008, 24576, 30801,  2035,  4466, 18416, 12292,  4466, 18416, 12296,  {   2232
 9217+   4606,  4482,  2035,  2878,  2035,  3100, 18416, 12332,  4506,  2035,  {   2242
 9218+   2878,-11004, 24576, 30896, 18416, 12332,  2035,  3802,  2035,  3932,  {   2252
 9219+   4528,-11003, 24576, 30889,  2035,  3068,-11005, 24576, 30884, 18416,  {   2262
 9220+  12332,  4556,-11003, 24576, 30889, 18416, 12332,-11008, 24576, 30795,  {   2272
 9221+  18416, 12300,-11008, 24576, 30797,  4606,-11003, 24576, 30889,-11004,  {   2282
 9222+  24576, 30896, 18416, 12336, 18416, 12332,  2035,  3802,  2035,  3932,  {   2292
 9223+  18416, 12340,-11008, 24576, 30795, 18416, 12300,-11008, 24576, 30797,  {   2302
 9224+   4648,  4618, 18416, 12300,  2035,  4974,  4636,-11008, 24576, 31103,  {   2312
 9225+   2035,  3036,-11008, 24576, 31105,  4648,-11008, 24576, 31107,  2035,  {   2322
 9226+   4974,  4704,  4682, 18416, 12316,-11008, 24576, 30795, 18416, 12316,  {   2332
 9227+ -11008, 24576, 30801, 18416, 12316,-11008, 24576, 30797,  4704,  2035,  {   2342
 9228+   4606,-11008, 24576, 30795, 18416, 12316,-11008, 24576, 30797,  4726,  {   2352
 9229+   4716,  2035,  4606,  2035,  5106,  4726, 18416, 12316,  2035,  4726,  {   2362
 9230+   4780,  4756,-11008, 24576, 30795, 18416, 12316,-11008, 24576, 30801,  {   2372
 9231+  18416, 12316,-11008, 24576, 30797,  4774,-11008, 24576, 30795, 18416,  {   2382
 9232+  12316,-11008, 24576, 30797,  4780, 18416, 12296,  4800,  4794,-11008,  {   2392
 9233+  24576, 30801, 18416, 12304,  4800, 18416, 12296,  4818,  4808,  2035,  {   2402
 9234+   4606,  4818, 18416, 12316,  2035,  5106,  4974,  4840, 18416, 12344,  {   2412
 9235+  18416, 12316,-11008, 24576, 30801, 18416, 12316,  4860, 18416, 12348,  {   2422
 9236+  18416, 12316,-11008, 24576, 30801,  2035,  4704,  4890, 18416, 12352,  {   2432
 9237+  18416, 12316,-11008, 24576, 30801, 18416, 12316,-11008, 24576, 30801,  {   2442
 9238+   2035,  4800,  4904, 18416, 12356,  2035,  4800,  2035,  4780,  4924,  {   2452
 9239+  18416, 12360, 18416, 12316,-11008, 24576, 30801,  2035,  4800,  4944,  {   2462
 9240+  18416, 12364,  2035,  4648,-11008, 24576, 30801,  2035,  4800,  4964,  {   2472
 9241+  18416, 12368,  2035,  4648,-11008, 24576, 30801,  2035,  4648,  4974,  {   2482
 9242+  18416, 12372, 18416, 12316,  5006,  4988,-11008, 24576, 30791, 18416,  {   2492
 9243+  12316,  5000,-11008, 24576, 30793, 18416, 12316,  5006, 18416, 12296,  {   2502
 9244+   5106,  5042,-11008, 24576, 31107, 18416, 12316,-11008, 24576, 30801,  {   2512
 9245+   2035,  5148, 18416, 12300,  2035,  2754,  2035,  4152,  5060,-11007,  {   2522
 9246+  24576, 31018,-11008, 24576, 31109, 18416, 12316,  5070, 18416, 12376,  {   2532
 9247+   2035,  4818,  5082,-11005, 24576, 31111, 18416, 12304,  5094,-11002,  {   2542
 9248+  24576, 31116, 18416, 12316,  5106,-11005, 24576, 31124, 18416, 12316,  {   2552
 9249+   5132,  5126,-11008, 24576, 30795, 18416, 12316,-11008, 24576, 30797,  {   2562
 9250+   5132, 18416, 12296,  5148,  5142,-11008, 24576, 31086,  5148, 18416,  {   2572
 9251+  12296,  5164,  5158,-11008, 24576, 31129,  5164, 18416, 12296,  5276,  {   2582
 9252+   5196, 18416, 12336, 18416, 12300,  2035,  2754,  2035,  4152, 18416,  {   2592
 9253+  12340,  2035,  3492,  2035,  4084,  5208,-11007, 24576, 31018,  2035,  {   2602
 9254+   3050,  5224,-11000, 24576, 31131, 18416, 12328,  2035,  4084,  5232,  {   2612
 9255+ -11003, 24576, 31141,  5248,-11003, 24576, 31148, 18416, 12392,  2035,  {   2622
 9256+   2708,  5260,-11002, 24576, 31155,  2035,  3910,  5268,-11005, 24576,  {   2632
 9257+  31021,  5276,-11005, 24576, 31163,  5802,  5296, 18416, 12336,  2035,  {   2642
 9258+   5164, 18416, 12340,  2035,  3960,  5312,-11004, 24576, 31047,  2035,  {   2652
 9259+   4296, 18416, 12320,  5324,-11003, 24576, 31168, 18416, 12320,  5336,  {   2662
 9260+  18416, 12316,-11008, 24576, 30970,  5366,  2035,  2824, 18416, 12336,  {   2672
 9261+   2035,  3344,  2035,  3404, 18416, 12340,  2035,  4012, 18416, 12320,  {   2682
 9262+   5396,  2035,  2842, 18416, 12336,  2035,  3344,  2035,  3404, 18416,  {   2692
 9263+  12340,  2035,  4054, 18416, 12320,  5410,  2035,  2878,  2035,  3616,  {   2702
 9264+  18416, 12320,  5426,-11006, 24576, 31175,  2035,  3184, 18416, 12320,  {   2712
 9265+   5460, 18416, 12336,  2035,  4260,  2035,  2950, 18416, 12340,  2035,  {   2722
 9266+   3510, 18416, 12300,  2035,  3124, 18416, 12320,  5470,  2035,  2860,  {   2732
 9267+  18416, 12324,  5486,-11004, 24576, 31179,  2035,  3526, 18416, 12320,  {   2742
 9268+   5498,-11004, 24576, 31185, 18416, 12320,  5514,-11004, 24576, 31191,  {   2752
 9269+   2035,  3864, 18416, 12320,  5530,-11003, 24576, 31197,  2035,  4104,  {   2762
 9270+  18416, 12320,  5554,-11003, 24576, 31204, 18416, 12332,  2035,  3802,  {   2772
 9271+   2035,  3932, 18416, 12320,  5566,-11005, 24576, 31211, 18416, 12320,  {   2782
 9272+   5576,  2035,  3768,  2035,  4348,  5596,-11005, 24576, 30951, 18416,  {   2792
 9273+  12300,  2035,  3124, 18416, 12320,  5618,-11002, 24576, 31216,-11005,  {   2802
 9274+  24576, 30884, 18416, 12300, 18416, 12320,  5640,-11002, 24576, 31224,  {   2812
 9275+ -11002, 24576, 31232, 18416, 12380, 18416, 12320,  5664,-11001, 24576,  {   2822
 9276+  31240, 18416, 12380, 18416, 12300,  2035,  5106, 18416, 12320,  5676,  {   2832
 9277+ -11004, 24576, 31249, 18416, 12320,  5694,-11004, 24576, 30851,-11002,  {   2842
 9278+  24576, 30869, 18416, 12320,  5714,-11008, 24576, 31107, 18416, 12380,  {   2852
 9279+   2035,  5006, 18416, 12320,  5730,-11002, 24576, 31255, 18416, 12308,  {   2862
 9280+  18416, 12320,  5750,-11003, 24576, 31263, 18416, 12380,  2035,  3578,  {   2872
 9281+  18416, 12320,  5766,-11003, 24576, 30889,  2035,  3240, 18416, 12320,  {   2882
 9282+   5796,-11007, 24576, 31270,  2035,  4180, 18416, 12316,  2035,  3840,  {   2892
 9283+ -11004, 24576, 31026, 18416, 12320,  5802, 18416, 12320;
 9284  %CONSTSHORTINTEGERARRAY SALT(0: 29)= 5802,
 9285+  5278, 5296, 5312, 5324, 5336, 5366, 5396, 5410, 5426, 5460,
 9286+  5470, 5486, 5498, 5514, 5530, 5554, 5566, 5576, 5596, 5618,
 9287+  5640, 5664, 5676, 5694, 5714, 5730, 5750, 5766, 5796;
 9288  {%REGISTER SYMAD(7)}%integer SYMAD
 9289  {%REGISTER QP(6)}%integer QP
 9290  !%if USE MC = 1 %start
 9291  !         *L_7,SYMBOL; *L_6,Q
 9292  !         *BAL_1,<HASHSTART>
 9293  !%finish
 9294           Q=QP
 9295           %RETURN
 9296  HASHSTART:                             ! USE 1ST CHAR TO INDEX PHRASE SS
 9297  !%if USE MC = 1 %start
 9298  !         *ST_1,0(0,11);                ! SAVE RETURN ADDR BUT NOT LOCALS
 9299  !         *LA_11,32(0,11);              ! CLAIM SPACE TO CONFORM W.START
 9300  !         *L_2,R; *ST_2,RR; *ST_6,RQ;   ! RQ=Q;!RR=R
 9301  !         *LA_3,1(0,2); *ST_3,R;        ! R=R+1
 9302  !         *SR_1,1; *IC_1,0(6);          ! R1=CC(Q)=1ST CHAR OF STMNT
 9303  !         *L_3,HASHALT; *IC_1,0(3,1);   ! R1=A(R)=1ST ALT WORTH TRYING
 9304  !         *STH_1,ALT;                   ! ALT    =ALTNO
 9305  !         *L_3,SALT
 9306  !         *LH_0,0(0,3); *STH_0,RP
 9307  !         *AR_1,1; *LH_2,0(3,1);        ! P=SALT(ALT)
 9308  !         *LA_1,2(0,2);                 ! RS=1ST ALT IS 2 BYTES ON
 9309  !         *LH_0,0(2,7); *ST_0,RA;       ! RA=PTR TO NEXT ALT OF SS
 9310  !         *BC_15,<12>
 9311  !START:   *LM_15,4,RA;                  ! CURRENT LOCALS
 9312  !         *STM_14,4,0(11);              ! SAVE RETURN ADDR+LOCALS
 9313  !         *LA_11,32(0,11);              ! CLAIM WORKSPACE
 9314  !         *L_0,P; *STH_0,PP
 9315  !         *BC_15,<COMM>
 9316  !%finish
 9317  Label999:                                    ! REPEATEING PHRASES
 9318  !%if USE MC = 1 %start
 9319  !         *L_1,RR; *AR_1,1
 9320  !         *LH_0,ALT; *STH_0,A+30(1)
 9321  !         *LH_0,PP; *ST_0,P
 9322  !%finish
 9323  COMM:
 9324           %COMMENT  ROUTINE REALLY STARTS HERE
 9325  !%if USE MC = 1 %start
 9326  !         *L_1,R; *ST_1,RR; *ST_6,RQ;   !RQ=Q  RR=R
 9327  !         *LA_2,1(0,1); *ST_2,R;        ! R=R+1
 9328  !         *LA_0,1; *STH_0,ALT;          ! ALT=1
 9329  !         *L_1,P
 9330  !         *LH_0,0(1,7); *STH_0,RP;       ! RP=SYMBOL(P)
 9331  !         *LH_0,2(1,7); *ST_0,RA;       ! RA=SYMBOL(P+1)
 9332  !         *LA_1,4(0,1); *BC_15,<12>;    ! RS=1ST ALTRNTIVE IS 4 BYTES ON
 9333  Label1:
 9334  !         *LA_1,1; *A_1,R
 9335  !         *ST_1,R;                      ! R=R+1
 9336  !%finish
 9337  Label2:                                     !RETURN HERE AFTER SUCCESS
 9338  !%if USE MC = 1 %start
 9339  !         *C_6,QMAX
 9340  !        *BC_12,<NOUPD>; *ST_6,QMAX
 9341  !%finish
 9342  NOUPD:
 9343  !%if USE MC = 1 %start
 9344  !         *L_1,RS; *LA_1,4(0,1);        ! ! UPDATE RS TO NEXT PHRASE%C
 9345  !                                         ! WHICH IN GENERAL WILL BE 4
 9346  !                                         ! BYTES ON DOWN THE TABLE.
 9347  !                                         ! ONLY LITERALS DIFFER
 9348  !12:      *C_1,RA; *BC_8,<8>;           !  ->SUCCESS %IF RA=RS
 9349  !         *ST_1,RS;                     !  RS=RS+1
 9350  !         *LA_3,<TABLE>
 9351  !%finish
 9352  TESTP:                                 ! THE BASIC COMPARISON SEQUENCE
 9353                                         ! EXECUTE THE NEXT INSTRUCTION IN
 9354                                         ! THE TABLE FOR P-TYPE THIS BR3
 9355                                         ! FOR A RECURSIVE CALL.BIP-TYPE
 9356                                         ! BRANCHES VIA TABLE.LITERAL IS
 9357                                         ! THE APPROPRIATE CLC
 9358  !%if USE MC = 1 %start
 9359  !         *EX_0,0(1,7);                 ! CLC IN SYMBOL
 9360  !         *BC_7,<3>;                    ! LITERAL NOT FOUND
 9361  !         *AH_6,0(1,7);                 ! ADD 1ST HALFWORD OF CLC
 9362  !         *A_6,QUICK;                   ! AND A CORRECTING FACTOR TO
 9363  !        *C_6,QMAX; *BC_12,<NOUPD1>; *ST_6,QMAX
 9364  !%finish
 9365  NOUPD1:
 9366  !%if USE MC = 1 %start
 9367  !         *LA_1,6(0,1);                 !  LITERALS NEXT PHRASE 6BYTES ON
 9368  !         *C_1,RA; *BC_8,<8>;           !  ->SUCCESS %IF RA=RS
 9369  !         *ST_1,RS
 9370  !%finish
 9371           ->TESTP;                      ! ON TO NEXT PHRASE
 9372  !%if USE MC = 1 %start
 9373  !4:       *LH_2,2(1,7);                ! POINTER TO PHRASE
 9374  !         *ST_2,P;                      ! P=ITEM
 9375  !         *BAL_14,<START>;              ! PSEUDO RECURSIVE CALL
 9376  !         *CLI_HIT,0; *BC_8,<3>;         ! BIP NOT FOUND
 9377  !%finish
 9378                                          ! IF BIP FOUND CAN USE REGS
 9379                                          ! LEFT SET UP AT LAST RTRN:
 9380  !%if USE MC = 1 %start
 9381  !         *LA_1,4(2);                    ! UPDATE RS
 9382  !         *CR_1,15; *BC_8,<8>;           ! ->SUCCESS IF RA=RS
 9383  !         *ST_1,RS; *LA_3,<TABLE>; *BC_15,<TESTP>
 9384  U3:
 9385  !         *C_6,QMAX; *BC_12,<3>; *ST_6,QMAX
 9386  !%finish
 9387  Label3:                                    !FAILURE TRY NEXT ALTERNATIVE
 9388  !%if USE MC = 1 %start
 9389  !         *L_2,RA; *CH_2,RP;            ! ->Label7 %IF RA=RP (UTTER FAILURE
 9390  !         *BC_8,<7>;                    ! AS NO MORE ALTS LEFT TO TRY)
 9391  !         *L_15,RR; *L_6,RQ;            ! Q=RQ--R=RR
 9392  !         *LA_0,1(0,15); *ST_0,R;       ! R=R+1--
 9393  !         *LH_3,ALT
 9394  !         *LA_3,1(0,3); *STH_3,ALT;     ! ALT=ALT+1  = NEXT ALT
 9395  !         *LA_1,2(0,2);                 ! NEW RS 2 ON FROM OLD RS(=RA)
 9396  !         *LH_0,0(2,7); *ST_0,RA;       ! NEW RA=SYMBOL(OLD RA)
 9397  !         *ST_1,RS
 9398  !         *LA_3,<TABLE>; ->TESTP
 9399  !%finish
 9400  NULL:                                  ! PHRASE NULL-CAN BE MADE FAST.AS
 9401                                         ! ALWAYS LAST & ALWAYS SUCCESSFUL
 9402  Label8:       HIT=1                         ;!SUCCESS
 9403  RTRN:                                  ! PSEUDO RECURSIVE RETURN
 9404  !%if USE MC = 1 %start
 9405  !         *L_1,RR; *AR_1,1
 9406  !         *LH_0,ALT; *STH_0,A+30(1);    ! A(RR)=ALT MATCHED
 9407  !         *S_11,THIRTYTWO;              ! RESET THE STACK POINTER
 9408  !         *LM_14,4,0(11);               ! RETURN ADDR ETC
 9409  !         *STM_15,4,RA;                 ! RESTORE OLD LOCALS
 9410  !         *BCR_15,14    ;               ! AND EXIT
 9411  !%finish
 9412  Label7:       HIT=0;->RTRN                  ;!COMPLETE AND UTTER FAILURE
 9413  !%if USE MC = 1 %start
 9414  !TABLE:   *BC_15,<4>
 9415  !         *BC_15,<999>
 9416  !         *BC_15,<NULL>;                ! THE BIP %NULL
 9417  !         *BC_15,<1001>  ;              !TREE FOR BIPS
 9418  !         *BC_15,<1002>
 9419  !         *BC_15,<1003>
 9420  !         *BC_15,<1004>
 9421  !         *BC_15,<1005>
 9422  !         *BC_15,<1006>
 9423  !         *BC_15,<1007>
 9424  !         *BC_15,<1008>
 9425  !         *BC_15,<1009>
 9426  !         *BC_15,<1010>
 9427  !         *BC_15,<1011>
 9428  !         *BC_15,<1012>
 9429  !         *BC_15,<1013>
 9430  !         *BC_15,<1014>
 9431  !         *BC_15,<1015>
 9432  !         *BC_15,<1016>
 9433  !         *BC_15,<1017>
 9434  !         *BC_15,<1018>
 9435  !         *BC_15,<1019>
 9436  !         *BC_15,<1020>
 9437  !         *BC_15,<1021>
 9438  !         *BC_15,<1022>
 9439  !         *BC_15,<1023>
 9440  !         *BC_15,<1024>
 9441  !         *BC_15,<1025>
 9442  !%finish
 9443  Label1001:                                  !BIP NAME
 9444           ->Label3 %UNLESS 'A'<=BYTEINTEGER(QP)
 9445  !%if USE MC = 1 %start
 9446  !         *L_3,TRTABS
 9447  !         *SR_1,1; *LR_2,1; *ST_1,NUM
 9448  !         *STM_1,2,0(11)
 9449  !         *TRT_0(255,6),0(3)
 9450  !         *LR_0,1; *SR_1,6;              ! LENGTH IN GR1
 9451  !         *BC_8,<3>;                     ! ZERO LENGTH = NOT A NAME
 9452  !         *BCT_2,*+8
 9453  !         *BC_15,<U3>;                   ! NAME END IN QUOTE =FAIL
 9454  !         *L_14,LETT; *L_3,NEXT; *AR_3,14
 9455  !         *STC_1,0(3);                   ! MOVE IN LENGTH
 9456  !         *EX_1,<NAMMOVE>;               ! MOVE IN CHARS (+1 XTRA)
 9457  !         *EX_1,<MOVEP>
 9458  !         *LR_6,0;                       ! UPDATE TEXT POINTER
 9459  !         *LH_2,0(11); *MH_2,HH1
 9460  !         *LH_0,2(11); *MH_0,HH1+2; *ALR_2,0
 9461  !         *LH_0,4(11); *MH_0,HH2; *ALR_2,0
 9462  !         *LH_0,6(11); *MH_0,HH2+2; *ALR_2,0
 9463  !         *LR_4,2;                       ! INITIAL HASH VALUE
 9464  !         *SRL_2,9; *STC_2,NUM+3
 9465  !         *OI_NUM+3,2; *NI_NUM+3,62
 9466  !         *L_15,WORD; *L_5,NNAMES
 9467  !         *LA_0,0(5,5)
 9468  !         *ALR_4,4
 9469  !LOOKL:   *NR_4,0;                       ! TO KEEP WITHIN WORD
 9470  !         *LH_2,0(4,15);                 ! GET WORD(I)
 9471  !         *LTR_2,2; *BC_8,<NEWNAME>;     ! EMPTY HOLE FOR NEW NAME
 9472  !         *AR_2,14; *EX_1,<NAMCOMP>;     ! COMPARE
 9473  !         *BC_8,<FOUND>
 9474  !         *A_4,NUM
 9475  !         *BCT_5,<LOOKL>
 9476  !%finish
 9477           FAULT(104,0)
 9478  !%if USE MC = 1 %start
 9479  !NAMCOMP: *CLC_0(1,2),0(3)
 9480  !NAMMOVE: *MVC_1(1,3),0(6)
 9481  !MOVEP:   *MVC_0(1,11),0(3)
 9482  !%finish
 9483  DFULL:   FAULT(103,0)
 9484  !%if USE MC = 1 %start
 9485  !NEWNAME: *SR_3,14; *STH_3,0(4,15)
 9486  !         *LA_3,1(1,3); *ST_3,NEXT;      ! UPDATE NEXT TO INCLUDE NEWNAME
 9487  !         *CH_3,DSIZE; *BC_2,<DFULL>
 9488  !FOUND:   *SRL_4,1; *L_2,R; *AR_2,2
 9489  !         *STH_4,A+30(2)
 9490  !%finish
 9491           HIT=1; ->Label1
 9492  Label1020:                                  ! SET UP UC FOR LOOK UP &CHECK'_'
 9493           I=BYTE INTEGER(QP)
 9494           ->Label3 %UNLESS 'A'<=I<='Z'
 9495           S=I; J=1
 9496  Label200:     QP=QP+1; I=BYTE INTEGER(QP)
 9497           ->Label201 %UNLESS 'A'<=I<='Z'
 9498           S=S<<8!I;J=J+1; ->Label200
 9499  Label201:     ->Label3 %UNLESS I='_' %AND J<=4
 9500           QP=QP+1; ->Label2
 9501  Label1002:                                  ! INTEGER CONSTANT
 9502  !%if USE MC = 1 %start
 9503  !         *MVI_CTYPE,2; -> 301
 9504  !%finish
 9505  Label1003:                                  !BIP CONST
 9506  !%if USE MC = 1 %start
 9507  !         *MVI_CTYPE,0
 9508  !301:     *SR_1,1
 9509  !        *IC_1,0(0,6);                   ! PICK UP NEXT CHAR
 9510  !         *A_1,TRTABS;                  ! CHECK A CONST IS POSSIBLE
 9511  !         *CLI_256(1),28;*BC_8,<3>;     !QUICK TEST FOR CONST.
 9512  !%finish
 9513           Q=QP; CONST(CTYPE); QP=Q
 9514           %IF HIT=0 %THEN ->U3
 9515           ->Label1 %IF CTYPE=5
 9516           ->Label26 %IF CTYPE=2;             ! %REAL
 9517           A(R)=1
 9518           A(R+1)<-S>>16; A(R+2)<-S; R=R+3; ->Label2
 9519  Label26:      A(R)=2; TOAR8(R+1,CVALUE); R=R+5; ->Label2
 9520  Label1005:                                  !BIP N
 9521  !%if USE MC = 1 %start
 9522  !         *L_3,TRTABS
 9523  !         *TRT_0(10,6),256(3)
 9524  !         *BC_8,<3>;                    ! TOO LONG
 9525  !         *LR_0,1;                       ! UPDATE Q
 9526  !         *SR_1,6; *BC_8,<3>;           ! ZERO LENGTH->FAILURE
 9527  !         *BCTR_1,0;  *EX_1,<PK>;       !PACK
 9528  !         *OI_7(11),15;                 !POSITIVE SIGN
 9529  !         *CVB_2,0(0,11);               ! BINARY IN R2
 9530  !         *L_1,R;  *AR_1,1
 9531  !         *LR_6,0;                      ! FINISH UPDATING Q
 9532  !         *STH_2,A+30(1);                  ! A(R)=N
 9533  !         *SRA_2,15;  *BC_8,<1>
 9534  !%finish
 9535           ->Label3
 9536  !%if USE MC = 1 %start
 9537  !PK:      *PACK_0(8,11),0(0,6)
 9538  !%finish
 9539  Label1004:                                  !BIP CONSTLIST
 9540           Q=QP; CONSTLIST; QP=Q; ->Label1
 9541  Label1006:                                  !BIP S
 9542  !%if USE MC = 1 %start
 9543  !         *CLI_0(6),10; *BC_8,<2>;      ! ->Label2 %IF I='NL'
 9544  !         *CLI_0(6),59; *BC_7,<3>;      ! -> 3 %UNLESS I=;
 9545  !         *LA_6,1(0,6)
 9546  !         *LA_1,4(0,1); *BC_15,<12>
 9547  !%finish
 9548  Label1007:                                  !BIP TEXT (=COMMENT TEXT)
 9549  !%if USE MC = 1 %start
 9550  !         *L_3,TRTABS
 9551  !31:      *TRT_0(255,6),512(3)
 9552  !         *BC_8,<30>;                   ! TEXT LONGER THAN 255 CHARS
 9553  !         *LR_6,1; ->Label2
 9554  !30:      *LA_6,256(0,6); ->Label31
 9555  !%finish
 9556  Label1008:                                  !BIP TEXTTEXT
 9557           I=BYTE INTEGER(QP)
 9558           Q=QP; TEXTTEXT; QP=Q
 9559           ->Label3 %IF HIT=0;->Label1
 9560  Label1009:                                  !BIP NAMELIST
 9561           ! GIVES AR IN FORM NNAMES,NAME1,....NAMEN
 9562           ->Label3 %IF BYTEINTEGER(QP)<'A'
 9563           U=R; V=1; R=R+1
 9564           Q=QP; PNAME; QP=Q; ->Label3 %IF HIT=0
 9565  Label90:      ->Label91 %UNLESS BYTE INTEGER(QP)=','
 9566           QP=QP+1; R=R+1
 9567           ->U3 %IF BYTEINTEGER(QP)<'A'
 9568           Q=QP; PNAME; QP=Q
 9569           ->Label92 %IF HIT=0; V=V+1; ->Label90
 9570  Label92:      R=R-1; QP=QP-1
 9571  Label91:      A(U)=V; ->Label1
 9572  Label1010:                        ! BIP HOLE
 9573  !%if USE MC = 1 %start
 9574  !         *L_15,R
 9575  !         *STH_15,MARKER;               ! MARKER=R
 9576  !         *LA_15,1(0,15);*ST_15,R;      ! R=R+1
 9577  !         *LA_1,4(0,1);                 ! ADVANCE POINTER TO SYMBOL
 9578  !         *C_1,RA; *BC_8,<8>;           ! AS FOR SUCCESS
 9579  !         *ST_1,RS; ->TESTP;            ! BACK INTO NORMAL PAT
 9580  !%finish
 9581  Label1011:                        !BIP MARK
 9582  !%if USE MC = 1 %start
 9583  !         *LH_15,MARKER
 9584  !         *L_14,R; *SR_14,15;           !  R-MARKER
 9585  !         *AR_15,15
 9586  !         *STH_14,A+30(15);                !  A(MARKER)=R-MARKER
 9587  !         *LA_1,4(0,1);                 !  ADVANCE POINTER
 9588  !         *C_1,RA; *BC_8,<8>;           !  ?END OF PHRASE
 9589  !         *ST_1,RS; ->TESTP;            !  TO NORMAL PATH
 9590  !%finish
 9591  Label1012:                                  !BIP UCRR - RR FORMAT
 9592  !%if USE MC = 1 %start
 9593  !         *CLI_S+3,'R';*BC_8,<124>
 9594  !%finish
 9595           %CYCLE I=0,1,2
?Non-local
 9596           ->Label120 %IF S=NEM(I)
 9597           %REPEAT; ->Label3
 9598  Label120:     A(R)=OPC(I)&63; ->Label1
 9599  Label124:       J=S>>8; %CYCLE I=2,1,48
?Non-local
 9600           ->Label120 %IF J=NEM(I)
 9601           %REPEAT; ->Label3
 9602  Label1013:                                  !BIP UCRX - RX FORMAT
 9603           J=18; K=64
 9604  Label131:
 9605           %CYCLE I=J,1,K
?Non-local
 9606           ->Label130 %IF S=NEM(I)
 9607           %REPEAT; ->Label3
 9608  Label130:     A(R)=OPC(I); ->Label1
 9609  Label1014:                                  !BIP UCRS    RRS FORMAT
 9610           J=66; K=69; ->Label131
 9611  Label1015:                                  !PHRASE UCSI STORE IMMEDIATE
 9612           J=71; K=83; ->Label131
 9613  Label1016:                                  !PHRASE UCSHIFT
 9614  !%if USE MC = 1 %start
 9615  !         *CLI_S+3,'A';*BC_8,<161>
 9616  !         *CLI_S+3,'L';*BC_7,<3>
 9617  !%finish
 9618  Label161:     J=85;K=92; ->Label131
 9619  Label1017:                                  !PHRASE UCSS - STORE-TO-STORE
 9620           J=94; K=106; ->Label131
 9621  Label1018:                                  !PHRASE UCPD PACKED DECIMAL
 9622           J=108; K=116; ->Label131
 9623  Label1019:                                  !UCSPEC - THE FUNNIES.
 9624           J=118; K=120; ->Label131
 9625  Label1021:                                     ! P<CHKIMPS>
 9626           ->Label3 %UNLESS IMPS=1; ->Label2
 9627                
 9628  Label1022:                                   ! P(+')=+,-,\,0;
 9629  !         I=BYTEINTEGER(QP)
 9630  !         %IF I='+' %THEN A(R)=1 %AND QP=QP+1 %AND ->Label1
 9631  !         %IF I='-' %THEN A(R)=2 %AND QP=QP+1 %AND ->Label1
 9632  !         %IF I='\' %THEN QP=QP+1 %AND A(R)=3 %AND ->Label1
 9633  !         A(R)=4
 9634  !         ->Label1
 9635  !%if USE MC = 1 %start
 9636  !         *CLI_0(6),'+'; *BC_8,<10221>
 9637  !         *CLI_0(6),'-'; *BC_8,<10222>
 9638  !         *CLI_0(6),'\'; *BC_8,<10223>
 9639  !         *LA_3,4; *L_2,R; *LA_2,1(2); *ST_2,R
 9640  !         *AR_2,2; *STH_3,A+28(2)
 9641  !         *LA_1,4(1); *BC_15,<12>
 9642  !%finish
 9643  Label10221:   A(R)=1; QP=QP+1; ->Label1
 9644  Label10222:   A(R)=2; QP=QP+1; ->Label1
 9645  Label10223:   A(R)=3; QP=QP+1; ->Label1
 9646  Label1023:                                   ! P(OP)=**,+,-,!!,!,*,//,/,
 9647                                          ! &,>>,<<,.;
 9648           I=BYTEINTEGER(QP)
 9649           ->Label3 %UNLESS X'80000000'>>(I-32)&X'4237000A'#0
 9650           QP=QP+1
 9651           %IF I='+' %THEN A(R)=2 %AND ->Label1
 9652           %IF I='-' %THEN A(R)=3 %AND ->Label1
 9653           J=BYTEINTEGER(QP)
 9654           %IF I='*' %THEN %START
 9655              %IF J#I %THEN A(R)=6 %AND ->Label1
 9656              A(R)=1; QP=QP+1; ->Label1
 9657           %FINISH
 9658           %IF I='/' %THEN %START
 9659              %IF J#I %THEN A(R)=8 %AND ->Label1
 9660              A(R)=7; QP=QP+1; ->Label1
 9661           %FINISH
 9662           %IF I='!' %THEN %START
 9663              %IF J#I %THEN A(R)=5 %AND ->Label1
 9664              A(R)=4; QP=QP+1; ->Label1
 9665           %FINISH
 9666           %IF I='&' %THEN A(R)=9 %AND ->Label1
 9667           %IF I='.' %THEN A(R)=12 %AND ->Label1
 9668           %IF I=J='<' %THEN A(R)=11 %AND QP=QP+1 %AND ->Label1
 9669           %IF I=J='>' %THEN A(R)=10 %AND QP=QP+1 %AND ->Label1
 9670           ->Label3
 9671  Label1024:                                   ! P(ASSOP)='==','=','<-','->'
 9672           I=BYTEINTEGER(QP)
 9673           ->Label3 %UNLESS X'80000000'>>(I-32)&X'4000C'#0
 9674           QP=QP+1; J=BYTEINTEGER(QP)
 9675           %IF I='=' %THEN %START
 9676              %IF J=I %THEN QP=QP+1 %AND  A(R)=1 %AND ->Label1
 9677              A(R)=2; ->Label1
 9678           %FINISH
 9679           %IF I='<' %AND J='-' %THEN A(R)=3 %AND QP=QP+1 %AND ->Label1
 9680           %IF I='-' %AND J='>' %THEN A(R)=4 %AND QP=QP+1 %AND ->Label1
 9681           ->Label3
 9682  
 9683  Label1025:                                   ! P(COMP)= =,>=,>,#,<=,<,\=,->
 9684           I=BYTEINTEGER(QP)
 9685           ->Label3 %UNLESS I=92 %OR %C
 9686+             X'80000000'>>(I-32)&X'1004000E'#0
 9687           QP=QP+1
 9688           %IF I='=' %THEN A(R)=1 %AND ->Label1
 9689           %IF I='#' %THEN A(R)=4 %AND ->Label1
 9690           J=BYTEINTEGER(QP)
 9691           %IF I='>' %THEN %START
 9692              %IF J='=' %THEN QP=QP+1 %AND A(R)=2 %AND ->Label1
 9693              A(R)=3; ->Label1
 9694           %FINISH
 9695           %IF I='<' %THEN %START
 9696              %IF J='=' %THEN QP=QP+1 %AND A(R)=5 %AND ->Label1
 9697              A(R)=6; ->Label1
 9698           %FINISH
 9699           %IF I=92 %AND J='=' %THEN QP=QP+1 %AND A(R)=7 %AND ->Label1
 9700           %IF I='-' %AND J='>' %THEN QP=QP+1 %AND A(R)=8 %AND ->Label1
 9701           ->Label3
 9702  %END                    ;
?LABEL1025 unused
?LABEL1024 unused
?LABEL1023 unused
?LABEL10223 unused
?LABEL10222 unused
?LABEL10221 unused
?LABEL1022 unused
?LABEL1021 unused
?LABEL1019 unused
?LABEL1018 unused
?LABEL1017 unused
?LABEL161 unused
?LABEL1016 unused
?LABEL1015 unused
?LABEL1014 unused
?LABEL1013 unused
?LABEL124 unused
?LABEL1012 unused
?LABEL1011 unused
?LABEL1010 unused
?LABEL1009 unused
?LABEL1008 unused
?LABEL1007 unused
?LABEL1006 unused
?LABEL1004 unused
?LABEL1005 unused
?LABEL1003 unused
?LABEL1002 unused
?LABEL1020 unused
?DFULL unused
?LABEL1001 unused
?LABEL7 unused
?LABEL8 unused
?NULL unused
?NOUPD1 unused
?NOUPD unused
?COMM unused
?LABEL999 unused
?HASHSTART unused
?SYMAD unused
?SALT unused
?SYMBOL unused
?THIRTYTWO unused
?MARKER unused
?ALT unused
?PP unused
?RP unused
?RS unused
?RR unused
?RQ unused
?RA unused
 9703                           ;! OF ROUTINE 'COMPARE'
 9703  !%finish
 9704           %ENDOFPROGRAM
?SUBSCHAR unused
?RELHEAD unused
?MAINEP3 unused
?NOTUSED unused
?P unused
?HH2 unused
?HH1 unused
?MASK2 unused
?MASK1 unused
?HASHALT unused

 7242 Statements compiled
