!
! m88p205f.3.i Sep93 pds Change in CRNAME to return correct size
! when recordarrayelement in a record has a record as a subname
!
! m88p205f.i 3Mar 92 PDS
! changes to allow record alignment to go to pass4 on record assignment
%externalroutine ICL9CEZRS6IMP
%constinteger RELEASE=4
%include "hostcodes.inc"
!
%CONSTINTEGER HOST=mips
%CONSTINTEGER TARGET=MIPS
%CONSTINTEGER STANDARDPT=X'51'
%CONSTINTEGER MINAPT=X'51';             ! MINIMUM PTYPE FOR WHICH ARITHMETIC
                                        ! OPERATORS ARE AVAILABLE
%CONSTINTEGER MINAPREC=MINAPT>>4
%CONSTHALFINTEGERARRAY TYPEFLAG(0:12)=0,
                                        X'51'{%INTEGER},
                                        X'52'{%REAL},
                                        X'8009'{%LONG SOMETHING},
                                        X'4031'{%BYTE},
                                        X'35'{%STRING},
                                        X'6051'{%HALF->%INTEGER+WARNING},
                                        X'4041'{%SHORT},
                                        X'33'{%RECORD},
                                        0,
                                        X'61'{%LONG INTEGER FAULT},
                                        X'62'{%LONG REAL},
                                        X'72'{%LONGLONGREAL WARN};
!
! 2****15 SET FOR RELAY TO LOWER PART OF TYPEFLAGS
! 2****14 SET TO SKIP NEXT AR ENTRY FOR BYTE(INTEGER?) ETC
! 2****13 SET IF A DIFFERENT PRECISION USED GIVES WARNING
! 2****12 SET FOR COMBINATION WE CANT SUPPORT GIVES FAULT99
!
%CONSTBYTEINTEGERARRAY PTRSIZE(0:127)= %C
                                        8,0(15)                 {PREC=0},   
                                        0(16)                   {PREC=1},
                                        0(16)                   {PREC=2},
                                        8,4,0,4,0,8,0,4,0(8)    {PREC=3},
                                        8,4,0(14)               {PREC=4},
                                        8,4,4,0(13)             {PREC=5},
                                        8,0,4,0(13)             {PREC=6},
                                        8,0(15)                 {PREC=7};
%CONSTBYTEINTEGERARRAY PTRROUNDING(0:3*128-1)=%C
                  3(128)                {ALL PTRS IN RECORDS},
                  3(128)                {ALL PTRS IN STACK FRAMES},
                  3(128)                {ALL PTRS IN PARAMETERS};
%CONSTINTEGER SFRAMEMISALIGN=0;         ! NEEDED ONLY FOR 2900 WHERE PRECALL
                                        ! MISALIGNS STACK FRAMES !
%CONSTINTEGER AHEADPT=X'61';            ! PTYPE OF ARRAYHEAD WHEN USED AS SCALAR
%CONSTINTEGER AHEADSIZE=8;              ! SIZE OF ARRAY HEAD(BYTES)
%CONSTINTEGER MINPARAMSIZE=4;           ! MINIMUM STACKABLE PARAMETER(BYTES)
%CONSTINTEGER RTPARAMPT=X'51';          ! PTYPER OF RTPARAM WHEN USED AS SCALAR
%CONSTINTEGER RTPARAMSIZE=4;            ! SIZE OF RT PARAMETER (BYTES)
%CONSTINTEGER ARRAYROUNDING=7;          ! ALL ARRAYS TO 4 BYTE BNDR
%CONSTINTEGER ARRAYINRECROUNDING=0;     ! ARRAYS IN RECORDS TO 4 BYTE BOUNDARY
%CONSTINTEGER STRVALINWA=YES;           ! STRING VALUE PARAMETERS STACKED
%CONSTINTEGER STRRESINWA=YES;           ! STRING&RECORD FN RESULTS STACKED
%CONSTINTEGER RECVALINWA=NO;           ! Record values passed via work area
!
%CONSTBYTEINTEGERARRAY RNDING(0:3*128-1)= %C
                  {VALUES FOR SCALARS PTYPES 0->X'7F' IN SITUATIONS}
                  {FIRST SITUATION IS IN RECORDS}
                  {SECOND SITUATION IS IN STACK FRAMES}
                  {THIRD SITUATION IS AS PARAMETERS}

         0(16)                          {PREC=0},
         0(16)                          {PREC=1},
         0(16)                          {PREC=2},
         0(3),3,0,0,0(10)               {PREC=3},
         0,1,0(14)                      {PREC=4},
         0,3,3,0(13)                    {PREC=5},
         0,7,7,0(13)                    {PREC=6},
         0,7,7,0(13)                    {PREC=7},


         0(16)                          {PREC=0},
         0(16)                          {PREC=1},
         0(16)                          {PREC=2},
         0(3),3,0,1,0(10)               {PREC=3},
         0,1,0(14)                      {PREC=4},
         0,3,3,0(13)                    {PREC=5},
         0,7,7,0(13)                    {PREC=6},
         0,7,7,0(13)                    {PREC=7},


         0(16)                          {PREC=0},
         0(16)                          {PREC=1},
         0(16)                          {PREC=2},
         0,3,0,3,0,3,0(10)              {PREC=3},
         0,3,0(14)                      {PREC=4},
         0,3,3,0(13)                    {PREC=5},
        0,7,7,0(13)                     {PREC=6},   {for non-SPARC}
         {0,3,3,0(13)                   PREC=6,}    {for SPARC and RS6000}
         0,7,7,0(13)                    {PREC=7};

%CONSTBYTEINTEGERARRAY BYTES(0:7)=0(3),1,2,4,8,16;
%CONSTBYTEINTEGERARRAY WORDS(0:7)=0(3),1,1,2,4,8;
%CONSTINTEGER DAREA=6;                  ! SPECIAL DIAGS AREA ON PERQ
%CONSTINTEGER DVAREA=4;                 ! CONST DOPE VECTORS IN sst
%CONSTINTEGER LHSADDRFIRST=NO;          ! EVALUATE LHS ADDR BEFORE RHS ON ASSNMNT
%CONSTINTEGER JRNDBODIES=NO;            ! NO NEED TO JUMP ROUNT RT BODIES
%CONSTINTEGER STACK DOWN=YES
%CONSTINTEGER PARAMSBWARDS=NO;          ! YES FOR REVERSED PARAMETERS
%CONSTINTEGER DISPLAY NEEDED=YES;       ! DISPLAY NEEDED IN LOCAL SPACE
%CONSTINTEGER DISPLAY ROUNDING=7;      ! Display on D-W bndry
%CONSTINTEGER DISPLAY C1=4;             ! 4 bytes per routine level on RS6000
%CONSTINTEGER DISPLAY C0=4;             ! 4 for globals
%CONSTINTEGER RTPARAM1OFFSET=0;         ! OFFSET FROM LNB TO PARAM1
%CONSTINTEGER ALPHA=0;                  ! post parmeter linkage
!
! END OF CONCATENATED DEFINITIONS
!
!
! Recent Source Changes
!**********************
!
!*                                                                p205e.i
!* 06/12/91 - Changes (pds) to base dictionary size directly on workfile
!*              and/or MAXDICT. Source file size is poor indicator in view
!*              of many large includes.
!*
! Oct 89   Version 5
! Chnages (mostly in CRCALL) to pass record values via work area & pointer
! for risc chips. Controlled by const integer in steering file
!
! DEc88 Version 3 produced
! Changes to note included procedures for Gould and others
! Also change to allow LINT &LINTPT to compile when lonlongs are treated as longs
!
! 8May87 Changes in FPlist so that RT Parameters are aligned according
!        the rules of array Rnding
!
!
! Warning this module has the revised triples spec.
!
! In first attempt at Triple Imp considerable use was made of constant operands
! to pass information from Pass2 to GEN. Although for specialised operations%c
like
! passing Labels this still applies, this adhocery has caused problems with%c
arrays
! and pointers particularly in mapped records. The operands for four triples
! have thus been redefined in a more standard way.
!
! GETPTR    X1 is now (ptype of passed)<<16! DIMENSION
!           Opnd2 is either a 32 bit const with the size (ACC) as value or
!           the ptr or arrayhead as normal operand.
!
! VMY       X1 is now dim<<28!maxdim<<24!array name(where known)
!           Opnd2 is either a 32 bit const with DV offset into const area or
!           the arrayhead as a standard operand
!
! AINDX     X1 is ELSIZE<<20 !spare
!           Opnd2 is arrayhead as standard operand
!           NOTE:- The Operands have been swopped for consistency with norm.
!
! BADJ      X1 is arrayptype<<16!no of Dimensions (latter in case of backward%c
dvs)
!           Opnd2 exactly as for VMY
!

!!{GT:}%include "impcompdate.inc"
   %const %string (9) LADATE="Apr 95";  ! LAST ALTERED
   %const %integer MAXRECSIZE=x'ffff'
   %const %integer NO OF SNS=67
   %const %integer LRLPT=X'62'
!
   %const %integer MAXLEVELS=31,CONCOP=13
!
!
! FIRST THE OPERAND FLAG CONSTANTS
!
%CONSTINTEGER SCONST=0;                 ! CONST UPTO 64 BITS value is carried
                                        ! in opnd_d and opnd_xtra
%CONSTINTEGER LCONST=1;                 ! CONST LONGER THAN SCONST const can be
                                        ! found elsewhere(at top of ar) by
                                        ! meanse of base&offset inf in_d and _xtra
%CONSTINTEGER DNAME=2;                  ! NAME BY DICTIONARY NO the base and disp in
                                        ! the dictionary after adjusting by
                                        ! possible offset for item in
                                        ! in records lead to the variable
%CONSTINTEGER ARNAME=3;                 ! NAME BY AR POINTER opnd_d the ar pointer
                                        ! this form local to pass2
                                        ! and used to identify functions
                                        ! with params before the call
                                        ! is planted
%CONSTINTEGER VIAPTR=4;                 ! VIA TRIPLE WITHOFFSET TO POINTER
                                        ! At an offset(_xtra) from address in
                                        ! referenced triple can be found a
                                        ! pointer to the required operand
%CONSTINTEGER INDNAME=5;                ! INDIRECT VIA DICTIONARY base&disp
                                        ! in dictionary identify a pointer
                                        ! variable at possible offset from
                                        ! this pointer
%CONSTINTEGER INDIRECT=6;               ! INDIRECT VIA TRIPLE WITH OFFSET
                                        ! the refenced triple has computed
                                        ! the (32bit) address of an item
                                        ! an offset may have to be applied
                                        ! before the fetch or store
%CONSTINTEGER LOCALIR=7;                ! BASE DISP REF IN CURRENT STACK FRAME
                                        ! opnd_b=base<<16!offset used only for
                                        ! compiler generated temporaries
%CONSTINTEGER REFTRIP=8;                ! REFERENCE TO A TRIPLE the operand is the result of 
                                        ! triple opnd_d
%CONSTINTEGER INAREG=9;                 ! REGISTER OPERAND this form is local to the
                                        ! code generating pass(es)
%CONSTINTEGER developped=10;            ! also local to generator
%CONSTINTEGER DEVADDR=11;               ! ALSO LOCAL TO GENERATOR
%CONSTINTEGER BTREFMASK=1<<REFTRIP!1<<INDIRECT!1<<VIAPTR
%CONSTINTEGER REFER NEEDED=1<<INDIRECT!1<<VIAPTR
!
! NOW THE DEFINITIONS OF ONE OPERAND TRIPLES <128
!
%CONSTINTEGER RTHD=1;                   ! ROUTINE-BLOCK HEADING
%CONSTINTEGER RDSPY=2;                  ! ROUTINE ENTRY SET DISPLAY
%CONSTINTEGER RDAREA=3;                 ! ROUTINE LEAVE DIAGNOSTIC SPACE
%CONSTINTEGER RDPTR=4;                  ! SET DIAGNOSTIC POINTER
%CONSTINTEGER RTBAD=5;                  ! ROUTINE-FN BAD EXIT
%CONSTINTEGER RTXIT=6;                  ! "%RETURN"
%CONSTINTEGER XSTOP=7;                  ! EXECUTE "%STO"
%CONSTINTEGER NOTL=10;                  ! LOGICAL NOT
%CONSTINTEGER LNEG=11;                  ! LOGICAL NEGATE
%CONSTINTEGER IFLOAT=12;                ! CONVERT INTEGER TO REAL
%CONSTINTEGER MODULUS=13;               ! AS USED BY IMOD&RMOD
%CONSTINTEGER SHRTN=14;                 ! SHORTEN TO LOWER PRECISION
%CONSTINTEGER LNGTHN=15;                ! LENGTHEN TO HIGHER PRECISION
%CONSTINTEGER JAMSHRTN=16;              ! SHORTEN FOR JAM TRANSFER
%CONSTINTEGER NULLT=18;                 ! FOR REDUNDANT TRIPLES
%CONSTINTEGER PRELOAD=19;               ! PREFETCH FOR OPTIMISATION REASONS
%CONSTINTEGER SSPTR=21;                 ! STORE STACK POINTER
%CONSTINTEGER RSPTR=22;                 ! RESTORE STACK POINTER
%CONSTINTEGER ASPTR=23;                 ! ADVANCE STACK PTR
%CONSTINTEGER DARRAY=24;                ! DECLARE ARRAY(IE STORE HD)
%CONSTINTEGER SLINE=25;                 ! UPDATE LINE NO
%CONSTINTEGER STPCK=26;                 ! CHECK FOR ZERO STEPS
%CONSTINTEGER FORPRE=27;                ! PREAMBLE FOR "FOR"
%CONSTINTEGER FORPOST=28;               ! POSTAMBLE FOR "FOR"
%CONSTINTEGER FORPR2=29;                ! FOR SECOND PREAMBLE
%CONSTINTEGER PRECL=30;                 ! PREPARATION FOR CALL
%CONSTINTEGER RCALL=31;                 ! THE CALL
%CONSTINTEGER RCRFR=32;                 ! RECOVER FN RESULT
%CONSTINTEGER RCRMR=33;                 ! RECOVER MAP RESULT
%CONSTINTEGER GETAD=35;                 ! GET ADDRESS OF NAME
%CONSTINTEGER RTOI1=36;                 ! REAL TO INTEGER AS INT
%CONSTINTEGER RTOI2=37;                 ! REAL TO INTEGER INTPT
%CONSTINTEGER ITOS1=38;                 ! INTEGER TO STRING AS TOSTRING
%CONSTINTEGER MNITR=39;                 ! %MONITOR
%CONSTINTEGER PPROF=40;                 ! PRINT PROFILE
%CONSTINTEGER RTFP=41;                  ! TURN RT INTO FORMAL PARAMETER
%CONSTINTEGER ONEV1=42;                 ! ON EVENT 1 PRIOR TO TRAP
%CONSTINTEGER ONEV2=43;                 ! ON EVENT 2 AFTER TRAP
%CONSTINTEGER DVSTT=44;                 ! START OF DOPE VECTOR
%CONSTINTEGER DVEND=45;                 ! END OF DV EVALUATE TOTSIZE ETC
%CONSTINTEGER FOREND=46;                ! END OF FOR LOOP
%CONSTINTEGER DMASS=47;                 ! assign via bim warning to opt only
%CONSTINTEGER RTOI3=48;                 ! real to integer as TRUNC
!
! CODES FOR USER WRITTEN ASSEMBLER. NATURALLY THESE ARE NOT
! MACHINE INDEPENDENT
!
%CONSTINTEGER UCNOP=50;                 ! FOR CNOPS
%CONSTINTEGER UCB1=51;                  ! ONE BYTE OPERATIONS
%CONSTINTEGER UCB2=52;                  ! FOR 2 BYTE OPERATIONE
%CONSTINTEGER UCB3=53;                  ! FOR 3 BYTE OPERATIONS
%CONSTINTEGER UCW=54;                   ! FOR WORD OPERATIONS
%CONSTINTEGER UCBW=55;                  ! FOR OPC,BYTEWORD OPERATIONE
%CONSTINTEGER UCWW=56;                  ! FOR OPC,WORD,WORD OPERAIONS
%CONSTINTEGER UCLW=57;                  ! FOR LONGWORD OPERATIONS
%CONSTINTEGER UCB2W=58;                 ! FOR OPC,B1,B2,WORD OPERATIONS
%CONSTINTEGER UCNAM=59;                 ! FOR ACESS TO NAMES FROM ASSEMBLER
!
! NOW THE BINARY OPERATIONS
!
%CONSTINTEGER ADD=128;                  ! ADDITION
%CONSTINTEGER SUB=129;                  ! SUBTRACTION
%CONSTINTEGER NONEQ=130;                ! INTEGER NONEQUIVALENCE
%CONSTINTEGER ORL=131;                  ! LOGICAL OR
%CONSTINTEGER MULT=132;                 ! MULTIPLICATION
%CONSTINTEGER INTDIV=133;               ! INTEGER DIVISION
%CONSTINTEGER REALDIV=134;              ! REAL DIVISION
%CONSTINTEGER ANDL=135;                 ! LOGICAL AND
%CONSTINTEGER RSHIFT=136;               ! LOGICAL RIGHT SHIFT
%CONSTINTEGER LSHIFT=137;               ! LOGICAL LEFT SHIFT
%CONSTINTEGER REXP=138;                 ! REAL EXPONENTIATION
%CONSTINTEGER COMP=139;                 ! COMPARISONS
%CONSTINTEGER DCOMP=140;                ! FIRST PART OF DSIDED(NEEDED?)
%CONSTINTEGER VMY=141;                  ! VECTOR MULTIPLY
%CONSTINTEGER COMB=142;                 ! COMBINE (IE ADD OF LA) ON VMY RESULTS
%CONSTINTEGER VASS=143;                 ! VARAIABLE ASSIGN WITH CHECKING
%CONSTINTEGER VJASS=144;                ! VARIABLE JAMMED ASSIGN
%CONSTINTEGER IEXP=145;                 ! INTEGER EXPONENTIAITION
%CONSTINTEGER BADJ=146;                 ! BASE ADJUST ARRAY INDEX
%CONSTINTEGER AINDX=147;                ! INDEX ARRAY(COMBINE BS&IX)
%CONSTINTEGER IFETCH=148;               ! NO LONGER USED
%CONSTINTEGER LASS=149;                 ! ASSIGN LOCAL TEMPORARY
%CONSTINTEGER FORCK=150;                ! VALIDATE FOR
%CONSTINTEGER PRECC=151;                ! PRELIMINARY CONNCATENATION
%CONSTINTEGER CONCAT=152;               ! CONCATENATION
%CONSTINTEGER IOCPC=153;                ! CALL IOCP
%CONSTINTEGER PASS1=154;                ! PRIMARY PARAMETER ASSIGNMENT
%CONSTINTEGER PASS2=155;                ! PARAMETER PASSING POINTER PARAMS
%CONSTINTEGER PASS3=156;                ! PARAMETERPASSING ARRAY PARAMETERS
%CONSTINTEGER PASS4=157;                ! PASS A FORMAL PROCEDURE
%CONSTINTEGER PASS5=158;                ! PASS AN UNTYPE(%NAME) PARAMETER
%CONSTINTEGER PASS6=159;                ! PASS STRFN OR RECFN RESULT AREA
%CONSTINTEGER BJUMP=160;                ! BACKWARDS JUMPS
%CONSTINTEGER FJUMP=161;                ! FORWARD JUMPS
%CONSTINTEGER REMLB=162;                ! REMOVE LAB FROM LABELIST
                                        ! NEEDS TO BE TRIPLE IF COMBINED
                                        ! LABEL LIST IS USED
%CONSTINTEGER TLAB=163;                 ! TO ENTER A LABEL
%CONSTINTEGER DCLSW=164;                ! DECLARE A SWITCH ARRAY
%CONSTINTEGER SETSW=165;                ! SET A SWITCH TO "CA"
%CONSTINTEGER GOTOSW=166;               ! GO TO A SWITCH LABEL
%CONSTINTEGER STRASS1=167;              ! STRING GENERAL ASSIGNMET
%CONSTINTEGER STRASS2=168;              ! STRING FIXED LENGTH ASSNMENT
%CONSTINTEGER STRJT=169;                ! STRING JAM TRANSFER
%CONSTINTEGER AHASS=170;                ! ASSIGNMENT OF ARRAYHEADS
%CONSTINTEGER PTRAS=171;                ! ASSIGNMENT OF POINTERS
%CONSTINTEGER MAPRES=172;               ! ASSIGN MAPPING FN RESULT
%CONSTINTEGER FNRES=173;                ! ASSIGN FN RESULT
%CONSTINTEGER SCOMP=174;                ! STRING COMPARISON
%CONSTINTEGER SDCMP=175;                ! FIRST PART OF STRING D-SIDED
%CONSTINTEGER PRES1=176;                ! PRE RESOLUTION 1
%CONSTINTEGER PRES2=177;                ! PRE RESOLUTION 2
%CONSTINTEGER RESLN=178;                ! STRING RESOLUTION
%CONSTINTEGER RESFN=179;                ! RESOLUTION FINALE
%CONSTINTEGER SIGEV=180;                ! SIGNAL EVENT
%CONSTINTEGER RECASS=181;               ! WHOLE RECORD ASSIGNMENT
%CONSTINTEGER AAINC=182;                ! ARRAY ADDRESS ADJUST FOR
                                        ! RECORD RELATIVE TO ABSOLUTE
%CONSTINTEGER AHADJ=183;                ! MODIFY HEAD FOR MAPPING
%CONSTINTEGER CTGEN=184;                ! CREATE TYPE GENERAL PARAMETER
%CONSTINTEGER GETPTR=185;               ! POINTER FOR PASSING BY NAME
%CONSTINTEGER SINDX=186;                ! INDEX STRING IE CHARNO
                                        ! SAME AS AINDX FOR ALL TARGETS
                                        ! BUT PNX !
%CONSTINTEGER ZCOMP=187;                ! COMPARISONS WITH ZERO
                                        ! GENERATED BY OPTIMISER
%CONSTINTEGER CLSHIFT=188;              ! CONSTANT LOGICAL SHIFT
                                        ! GENERATED BY OPTIMISER
%CONSTINTEGER CASHIFT=189;              ! CONSTANT ARITHMETIC SHIFT
                                        ! GENERATED BYOPTIMISER
%CONSTINTEGER DVBPR=190;                ! GENERATE DV ENTRY FOR BOUND PAIR
%CONSTINTEGER RSTORE=191;               ! REGISTER TO STORE OPERATION
%CONSTINTEGER MULTX=192;                ! MULTIPLY AND EXTEND PRECISION
!
! RECORDFORMAT FOR ALL THE OPTION AND FLAG VARAIBLES
!
! amended to remove non-alined longreal prior to bootstrapping to gould
!
%RECORDFORMAT PARMF(%INTEGER BITS1,BITS2,TTOPUT,
      %BYTEINTEGER LET,DYNAMIC,LINE,TRACE,ARR,DBUG,CHK,DIAG,OPT,FREE,
      LIST,CPRMODE,COMPILER,Z,Y,PROF,INHCODE,DCOMP,FAULTY,X,STACK,MAP,QUOTES,S2,
      %INTEGER LPOPUT,SP0)
%RECORDFORMAT LEVELF(%INTEGER RBASE, DIAGINF, RAL, FLAG, L, M, NMDECS, ONWORD, ONINF,
         LABEL, JROUND, UNATT FORMATS, PSIZE, ENTRYAD, DISPLAY, AUXSBASE, 
         NAMES, SNMAX,SN,RESSIZE,CLEVEL,SET, iblkid, EXITLAB, CONTLAB, S3,
       %INTEGERARRAY AVL WSP(0:4))

%IF 1<<host&unsignedshorts=0 %START
%RECORDFORMAT RD((%INTEGER S1 %OR %SHORT PTYPE,%BYTE XB,FLAG),
      ((%INTEGER D %OR %REAL R),
      %INTEGER XTRA %OR %SHORT H0,H1,H2,H3 %OR %BYTE B0,B1,B2,B3,B4,B5,B6,B7))
%RECORDFORMAT TAGF((%SHORTINTEGER PTYPE,UIOJ,SNDISP,ACC,SLINK,KFORM %OR %C
      %INTEGER S1,S2,S3),%INTEGER LINK)
%RECORDFORMAT TRIPF(%BYTE OPERN,OPTYPE,CNT,DPTH,
      %SHORTINTEGER FLAGS,PUSE,FLINK,BLINK,%INTEGER X1,
      %RECORD(RD) OPND1,OPND2)
%RECORDFORMAT LISTF((%SHORTINTEGER PTYPE,(%SHORT UIOJ %OR %BYTE XB,FLAG),
      %SHORT SNDISP,ACC,SLINK,KFORM %OR  %INTEGER S1,S2,S3),%INTEGER LINK)
%FINISH %ELSE %START
%RECORDFORMAT RD((%INTEGER S1 %OR %HALF PTYPE,%BYTE XB,FLAG),
      ((%INTEGER D %OR %REAL R),
      %INTEGER XTRA %OR %HALF H0,H1,H2,H3 %OR %BYTE B0,B1,B2,B3,B4,B5,B6,B7))
%RECORDFORMAT TAGF((%HALFINTEGER PTYPE,UIOJ,SNDISP,ACC,SLINK,KFORM %OR %C
      %INTEGER S1,S2,S3),%INTEGER LINK)
%RECORDFORMAT TRIPF(%BYTE OPERN,OPTYPE,CNT,DPTH,
      %HALFINTEGER FLAGS,PUSE,FLINK,BLINK,%INTEGER X1,
      %RECORD(RD) OPND1,OPND2)
%RECORDFORMAT LISTF((%HALFINTEGER PTYPE,(%HALF UIOJ %OR %BYTE XB,FLAG),
      %HALF SNDISP,ACC,SLINK,KFORM %OR  %INTEGER S1,S2,S3),%INTEGER LINK)
%FINISH
%RECORDFORMAT WORKAF(%INTEGER NNAMES,CCSIZE,DSIZE,ASL MAX,ASL CUR BTM,CONST PTR,
      CONST BTM,LASTTRIP,WKFILEAD,WKFILEK,FILE ADDR,RELEASE,AASL0,CONST LIMIT,
      RTCOUNT,ARTOP,AMAINEP,DICTBASE,OPTCNT,INCLHEAD,S2,S3,S4,
      %INTEGERNAME LINE,N,S5,%STRING(9)LADATE,
      %BYTEINTEGERARRAYNAME CC,A,LETT,
      %INTEGERARRAYNAME WORD,TAGS,CTABLE,
      %RECORD(LEVELF)%ARRAYNAME LEVELINF,
      %INTEGERARRAY PLABS,PLINK(0:31),
      %RECORD(LISTF)%ARRAYNAME ASLIST)
!
! TRIPF_FLAGS SIGNIFY AS FOLLOWS
%CONSTINTEGER LEAVE STACKED=2****0;     ! SET LEAVE RESULT IN ESTACK
%CONSTINTEGER LOADOP1=2****1;           ! OPERAND 1 NEEDS LOADING
%CONSTINTEGER LOADOP2=2****2;           ! OPERAND 2 NEEDS LOADING
%CONSTINTEGER NOTINREG=2****3;          ! PREVENT REG OPTIMISNG
                                        ! OF TEMPS OVER LOOPS&JUMPS
%CONSTINTEGER USE ESTACK=2****4;        ! KEEP DUPLICATE IN ESTACK
%CONSTINTEGER USE MSTACK=2****5;        ! PUT DUPLICAT ON MSTACK
%CONSTINTEGER CONSTANTOP=2****6;        ! ONE OPERAND IS CONSTANT(FOR FOLDING)
%CONSTINTEGER COMMUTABLE=2****7;        ! OPERATION IS COMMUTABLE
%CONSTINTEGER BSTRUCT=2****12;          ! Proc contains inner blks or RTs
%CONSTINTEGER USED LATE=2****13;        ! I-RESULT USED AFTER LAB OR A LONG WAY AHEAD
%CONSTINTEGER ASS LEVEL=2****14;        ! ASSEMBLER LEVEL OPERATION
%CONSTINTEGER DONT OPT=2****15;         ! DONT DUPLICATE THIS RESULT
                                        ! USED FOR BYTE PTR & OTHER SODS!
!
%RECORDFORMAT EMASFHDRF(%INTEGER ENDRA,STARTRA,FBYTESIZE,W3,W4,W5,W6,W7)
                                        ! FORMAT FOR ARRAY HEADS
! %END %OF  %FILE "ERCC07.TRIMP_TFORM1S"
   %const %integer SNPT=X'1006';         ! SPECIALNAME PTYPE
   %const %integer UNASSPAT=X'80808080'
   %const %integer LABUSEDBIT=X'01000000'
   %const %integer LABSETBIT=X'02000000'
   %const %integer MAXDICT=X'100';       ! PARM MAXDICT BIT
!
   %integer I,K,DUMMYFORMAT,P1SIZE,STARSIZE,ASL,ARSIZE,OLDLINE,NEXTP,SNUM,
      RLEVEL,NMAX,PLABEL,LEVEL,PROFAAD,LAST INST,LINE,N,BFFLAG,RBASE,Q,R,
      FNAME,STMTS,FILE SIZE,BIMSTR,MAX ULAB,SFLABEL,NEXTTRIP
   %integer %name SSTL,USTPTR
   %integer curlinead,nextlinead,currentSSalt
   %string (31) MAINEP
!
   %external %integer %array CAS(0:12)
   %external %record (PARMF) PARM
   %external %record (WORKAF) WORKA
   %if HOST=IBM %or HOST=AMDAHL %or HOST=IBMXA %or HOST=Vax %start
      %external %integer %map %spec COMREG %alias "s#comregmap"(%integer N)
   %finish %else %if HOST=Gould%or Host=M88k %or Host=RS6 %or Host=MIPS  %then %Start
      %externalintegermapspec COMREG  (%integer N)
   %else
      %external %integer %map %spec COMREG %alias "s#comreg"(%integer N)
   %finish
   %const %integer BYTESPERKFORSOURCE=256;  ! FRACTION OF KB IN WK FILE
                                         ! THATS IS ALLOCATE FOR SOURCE (&LPUT)
   %begin
      %record (EMASFHDRF) %name SHDR,WHDR
      worka = 0
      WORKA_FILE ADDR = COMREG(46);      ! SOURCE FILE IF CLEAN
      PARM = 0
      PARM_BITS1 = COMREG(27)
      PARM_BITS2 = COMREG(28)! MAXDICT
      PARM_TTOPUT = COMREG(40)
      PARM_LPOPUT = COMREG(23)
      WORKA_WKFILEAD = COMREG(14)
      COMREG(24) = 16;                   ! failure as return code
      WHDR == RECORD(WORKA_WKFILEAD)
      WORKA_WKFILEK = WHDR_FBYTESIZE>>10
      %if WORKA_FILE ADDR<=0 %then %start
         %if WORKA_FILE ADDR<-1 %then FILESIZE = IMOD(WORKA_FILE ADDR) %else %c
            FILESIZE = 64000
         WORKA_FILE ADDR = 0
      %finish %else %start
         SHDR == RECORD(WORKA_FILE ADDR)
         FILE SIZE = SHDR_ENDRA
      %finish
!
! Derive nnames form workfile K ignoring source size because of includes
!
! Note if nnames goes over 4095 the linking of arrayname parameters
! in sw(11) goes wong as their are only 12 bits left intags_uioj
! this is an absolute limit unless pds in prepared to be very ingenious
!

      WORKA_NNAMES = 1023
      %if WORKA_WKFILEK>513 %then WORKA_NNAMES=2047
     %if WORKA_WKFILEK>1000 %or PARM_BITS2&MAXDICT#0  %then WORKA_NNAMES = 4095
      ASL = 3*WORKA_NNAMES
!      %if ASL>4095 %and (HOST#EMAS %or PARM_BITS2&MAXDICT=0) %then ASL = 4095
      WORKA_ASL MAX = ASL
      ARSIZE = WORKA_WKFILEK*(1024-BYTESPERKFORSOURCE)-300
   %end
   %byte %integer %array %format AF(0:ARSIZE)
   %byte %integer %array %name A
   %record (LISTF) %array ASLIST(0:ASL)
   %integer %array TAGS(0:WORKA_NNAMES)
   %integer %array WORD(0:WORKA_NNAMES)
   %integer %array DVHEADS(0:12)
   %record (LEVELF) %array LEVELINF(0:MAXLEVELS)
  %record%format swdataform(%integer lseen,default,%integerarray slabs(0:1023))
   %externalroutinespec free(%integer ad)
   %externalintegerfnspec malloc(%integer space)
   %external %routine %spec INITASL(%record (LISTF) %array %name A,
      %integer %name B)
 %externalroutinespec printtrips(%record(tripf)%arrayname trops)
 %externalroutinespec phex (%integer val)
   %external %integer %fn %spec MORE SPACE
!%externalintegerfnspec NEWCELL
   %external %routine %spec INSERTATEND(%integer %name S, %integer A,B,C)
   %external %routine %spec INSERT AFTER(%integer %name S, %integer A,B,C)
   %external %routine %spec POP(%integer %name C,P,Q,R)
   %external %routine %spec PUSH(%integer %name C, %integer S1,S2,S3)
   %external %integer %fn %spec FIND(%integer LAB,LIST)
   %external %routine %spec BINSERT(%integer %name T,B, %integer S1,S2,S3)
   %external %routine %spec CLEARLIST(%integer %name HEAD)
   %external %routine %spec FILL DTABREFS(%integer %name HEAD)
   %external %routine %spec CXREF(%string (255) NAME, %integer MODE,XTRA,
      %integer %name AT)
   %external %routine %spec IMPABORT
   %external %routine %spec PROLOGUE(%record (LISTF) %array %name ALIST)
   %external %routine %spec EPILOGUE(%integer STMTS)
   %external %routine %spec PDATA(%integer AREA,BNDRY,L,AD)
   %external %routine %spec PRDATA(%integer AREA,BNDRY,L,REP,AD)
   %external %integer %fn %spec PINITOWN(%integer PTYPE,ACC,
      %record (RD) %name INIT, %string %name XNAME)
   %external %integer %fn %spec POWNARRAYHEAD(%integer PTYPE,J,LB,SIZE,
      AOFFSET,AAREA,DVOFFSET, %string (31) XNAME)
   %external %routine %spec FAULT(%integer A,B,C)
   %external %routine %spec WARN(%integer N,V)
   %external %routine %spec TRIP OPT(%record (TRIPF) %array %name T,
      %integer  first TRIP)
   %external %routine %spec MOVE BYTES(%integer LENGTH,FBASE,FOFF,TOBASE,TOOFF)
   %external %routine %spec CTOP(%integer %name OP,MASK, %integer XTRA,
      %record (RD) %name OPND1,OPND2)
   %if HOST#TARGET %start
      %external %routine %spec REFORMATC(%record (RD) %name OPND)
      %external %routine %spec CHANGE SEX(%integer BASEAD,OFFSET,L)
   %finish
   %external %routine %spec GENERATE(%record (TRIPF) %array %name T,
      %integer CURRLEVEL, %routine GETWSP(%integer %name PL, %integer SIZE))
%externalstringfnspec printname (%integer jj)
   %external %routine %spec PRINTLIST(%integer HEAD)
                                         ! START OF COMPILATION
   K = host//10
      %if k=0 %then k=1
   K = BYTESPERKFORSOURCE//K;             ! DISTINGUISH BYTE&WORD ADDRESSED%c
                                         HOSTS
                                         ! ALLOW FOR BYTE & WORD ADDRESS M-CS
   A == ARRAY(WORKA_WKFILE AD+K*WORKA_WKFILEK,AF)
   %begin
!***********************************************************************
!*       THIS BLOCK INITIALISE THE COMPILER SCALARS AND ARRAYS         *
!*       WAS ORIGINALLY ROUTINE 'INITIALISE'.                          *
!*       THE INITIALISATION OF THE CONSTANT LISTS WITH THE VALUES      *
!*       IN PERM MAY BE OMITTED IN BATCH OR CUT-DOWN VERSIONS.         *
!***********************************************************************
      %external %integer %fn %spec PASSONE
      WORKA_CCSIZE = BYTESPERKFORSOURCE*(WORKA_WKFILEK-1);  ! CCSIZE ALWAYS AS%c
                                                            BYTES
      %byte %integer %array %format CCF(0:WORKA_CCSIZE)
      %byte %integer %array %name CC
      CC == ARRAY(WORKA_WKFILEAD+32,CCF)
      WORKA_CC == CC
      WORKA_A == A
      WORKA_WORD == WORD
      WORKA_TAGS == TAGS
      WORKA_LINE == LINE
      WORKA_N == N
      WORKA_RELEASE = RELEASE
      WORKA_LADATE = LADATE
      WORKA_AASL0 = ADDR(ASLIST(0))
      WORKA_AMAINEP = ADDR(MAINEP)
      WORKA_LASTTRIP = WORKA_CCSIZE//40-2;  ! 40 IS SIZE OF THE TRIP ARRAY
      %if WORKA_LASTTRIP>699 %then WORKA_LASTTRIP = 699
      WORKA_OPTCNT = 0;                  ! ZERO COUNT OF OPTIMISATIONS
      worka_const ptr=1;                ! leaving zero for dont knows
      WORKA_ASLIST == ASLIST
      PLABEL = 24999
      N = 12;
      MAX ULAB = WORKA_NNAMES+16384;     ! LARGEST VALID USER LABEL
      LAST INST = 0
      SFLABEL = 20999
      RLEVEL = 0; NMAX = 0; BFFLAG = 0
      RBASE = 1
      SSTL == CAS(4); USTPTR == CAS(5)
      STMTS = 1; SNUM = 0
      BIMSTR = 0
      WORKA_RTCOUNT = 1;                 ! ROUTINE 0 RESERVED FOR MAIN PROG
      MAINEP = "s#go";                   ! DEFAULT MAIN ENTRY
      INITASL(ASLIST,ASL)
      %cycle I = 0,1,12
         CAS(I) = 0; DVHEADS(I) = 0
      %repeat
!
      DUMMY FORMAT = 0;                  ! DUMMY RECORD FORMAT
      PUSH(DUMMY FORMAT,0,0,0);          ! FOR BETTER ERROR RECOVERY
      P1SIZE = PASSONE
      R = P1SIZE
      WORKA_ARTOP = P1SIZE
   %end;                                 ! OF BLOCK CONTAINING PASS 1
   %if PARM_FAULTY#0 %start
      COMREG(24) = 8
      COMREG(47) = PARM_FAULTY
      %return
   %finish
   %begin
!***********************************************************************
!*    SECOND OR TRIPLES GENERATING PASS                                *
!***********************************************************************
      %record (LEVELF) %name CURRINF
      %integer TWSPHEAD,FORCNT,FORDPTH,FORCECNT,internalblockid
      %if HOST=EMAS %or HOST=IBM %or HOST=AMDAHL %or HOST=IBMXA %start
                                         ! LPUT BASED WORKFILE USED FOR OBJECT
         %record (TRIPF) %array TRIPLES(0:WORKA_LASTTRIP)
      %finish %else %start
         %record (TRIPF) %array %format TRIPLESFORM(0:WORKA_LASTTRIP)
         %record (TRIPF) %array %name TRIPLES
         TRIPLES == ARRAY(WORKA_WKFILEAD+32,TRIPLESFORM)
      %finish
      %integer %array %format CF(0:12*WORKA_NNAMES)
      %integer %array %name CTABLE
!%routinespec NOTE CREF(%integer CA)
!%routinespec STORE CONST(%integername D,%integer L,AD)
!%integerfnspec WORD CONST(%integer VALUE)
      %routine %spec REUSE TEMPS
      %routine %spec GET WSP(%integer %name PLACE, %integer SIZE)
      %routine %spec RETURN WSP(%integer PLACE,SIZE)
      %routine %spec COMPILE A STMNT
      %routine %spec outsym(%integer sym)
      %routinespec force line
      %routine %spec outstring(%string(255) str)
      %routinespec outint(%integer id)
      %integer %fn %spec NEW TRIP
      %integer %fn %spec FROMAR4(%integer PTR)
      %integer %fn %spec FROMAR2(%integer PTR)
      %integer %fn %spec UCONSTTRIP(%integer OPERN,OPTYPE,FLAGS,CONST)
      %integer %fn %spec ULCONSTTRIP(%integer OPERN,OPTYPE,FLAGS,CONST1,CONST2)
      %integer %fn %spec UNAMETRIP(%integer OPERN,OPTYPE,FLAGS,NAME)
      %integer %fn %spec UTEMPTRIP(%integer OPERN,OPTYPE,FLAGS,TEMP)
      %integer %fn %spec BRECTRIP(%integer OPERN,OPTYPE,FLAGS,
         %record (RD) %name OPND1,OPND2)
      %integer %fn %spec URECTRIP(%integer OPERN,OPTYPE,FLAG,
         %record (RD) %name OPND1)
      %routine %spec KEEPUSECOUNT(%record (RD) %name OPND)
      %routine %spec CSS(%integer P)
       %recordformat outform(%integer line,length,lastnl,prevlast,%bytearrayname l)
      %ownbyteintegerarray lspace(0:128*1024)
      %ownrecord(outform) opline
      %constinteger breakoplines=99

      opline=0
      opline_l==lspace
      %cycle I = 0,1,MAXLEVELS
         LEVELINF(I) = 0
         LEVELINF(I)_NAMES = -1
      %repeat
      CTABLE == ARRAY(ADDR(ASLIST(1)),CF)
      WORKA_CTABLE == CTABLE
      WORKA_LEVELINF == LEVELINF
      CTABLE(0) = M'CTAB'
      TWSPHEAD = 0
      FORCNT = 0;                        ! COUNTS FORS TO DETECT NESTING
      FORDPTH = 0;                       ! COUNTS DEPTH OF NESTED FORS
      FORCECNT = 0;                      ! UPDATED WHEN TRIPLES FORCED OUT
                                         ! KEPT SO THAT GLAENING IS POSSIBLE
      internalblockid=0
      PROLOGUE(ASLIST)
      LINE = 0
      NEXTTRIP = 1
      TRIPLES(0) = 0
      NEXTP = 1; LEVEL = 1; STMTS = 0
      CURRINF == LEVELINF(LEVEL)
      RLEVEL = 0; RBASE = 0
      CURRINF = 0
      CURRINF_CLEVEL = LEVEL
      CURRINF_NAMES = -1
!      %if target=gould %then currinf_maxpp = 8;  ! max parameters passed
      %while A(NEXTP+3)!A(NEXTP+4)#0 %cycle
         COMPILE A STMNT
      %repeat
      outsym(NL)
      outstring("/* end of automatic translation */")
      outsym(NL)
      force line
      LINE = 99999
      EPILOGUE(STMTS)

      %if PARM_FAULTY#0 %start
         COMREG(24) = 8
         STMTS = PARM_FAULTY
      %else
         COMREG(24) = 0
      %finish
      COMREG(47) = STMTS
      %if HOST=PERQ %start
         *RETURN;                        ! JUMP WONT REACH!
      %finish %else ->P2END
%integerfn insert curly(%integer cad,at)
!***********************************************************************
!*  Adds in a curly bracket comment                                    *
!*  Checks for the case of a C macro (Ist char #) %and reinserts       *
!*  The 'comment' unchanged                                            *
!***********************************************************************
%integer i,j,k,scount,res
%ownbytearray save (1:64*1024)
      scount=0
      %if at >opline_length %then at=opline_length { should not happen }
      %for i=at,1,opline_length-1 %cycle
          scount=scount+1
          save(scount)=opline_l(i)
      %repeat
      opline_length=at

      %if byteinteger(curlinead)#'#' { C macro } %start
         outsym(9)            { Tab }
         outstring("/*")
      %else
         outsym('{')
      %finish
      j=cad
      i=0
      %cycle
         j=j+1; i=i+1
         %if byteinteger(j)=NL %or byteinteger(j)='}' %start
            %if byteinteger(curlinead)#'#' { C macro } %start
               outstring("*/")
            %else
               %if byteinteger(j)='}' %then outsym('}')
            %finish
            res=i+1
            %exit
          %else
             opline_l(opline_length)=byteinteger(j)
             opline_length=opline_length+1
          %finish
        %repeat
      %for i=1,1,scount %cycle
        opline_l(opline_length)=save(i)
        opline_length=opline_length+1
      %repeat
      %result=res
%end
%integerfn locate curly(%integer cad)
!***********************************************************************
!* Try to find where to insert a curly comment by counting commas      *
!***********************************************************************
%integer ccount,firstc,i,bcount,commaafter
      ccount=0; bcount=0; commaafter=0
!
! first check if there is a comma after the curly comment
!
     i=cad
     i=i+1 %until byteinteger(i)='}' %or byteinteger(i)=NL
     %if byteinteger(i)='}' %start
        i=i+1
        i=i+1 %while byteinteger(i)=' '
        %if byteinteger(i)=',' %then commaafter=1 %and ccount=1
     %finish
      %for i=cad,-1,curlinead %cycle
         %if byteinteger(i)=',' %start
            %if ccount=0 %then firstc=i
            ccount=ccount+1
         %finish
      %repeat
      %if ccount=0 %then %result=opline_length
      %if commaafter=0 %start
         %for i=firstc,1,cad-1 %cycle
             %if 33<=byteinteger(i)<=127 %then bcount=bcount+1
             %if byteinteger(i)='{' %or byteinteger(i)='}' %then bcount=bcount+1
         %repeat
      %finish
      %for i=0,1,opline_length %cycle
         %if opline_l(i)=',' %or opline_l(i)=';' %start
            ccount=ccount-1
            %if ccount=0 %then -> next
         %finish
      %repeat
      %result=opline_length
next:
!printstring("locate "); write(commaafter,1); write(bcount,0)
!     write(opline_l(i),4);  write(opline_l(i+1),4); newline
      %if commaafter#0 %then %result=i
      %if bcount=0 %then %result=i+1
      %for i=i,1,opline_length %cycle
        %if 33<=opline_l(i)<=127 %then bcount=bcount-1
        %if bcount=0 %then %start
            i=i+1 %while i<opline_length-1 %andc
               ('a'<=opline_l(i+1)<='z' %or 'A'<=opline_l(i+1)<='Z' %orc
                 '0'<=opline_l(i+1)<='9' %or opline_l(i+1)='_') %andc
               ('a'<=opline_l(i)<='z' %or 'A'<=opline_l(i)<='Z' %orc
                 '0'<=opline_l(i)<='9' %or opline_l(i)='_')
            %if opline_l(i+1)='*' %and opline_l(i)='/' %then i=i-1
            %if opline_l(i+1)='/'  %and opline_l(i)='*' %then i=i+1
             %if opline_l(i+1)='*' %and opline_l(i+2)='/' %then i=i+2
!printstring("locate2 ");     write(opline_l(i),4);  write(opline_l(i+1),4); newline
            %result=i+1
        %finish
      %repeat
      %result=opline_length
%end
%routine curly check(%integer mode)
%owninteger last linead
%integer i,at

!printstring("checking curly"); write(nextlinead,6); write(curlinead,6)
!write(last linead,6); printsymbol(byteinteger(curlinead));
!printsymbol(byteinteger(curlinead+1)); printsymbol(byteinteger(curlinead+2)); 
!printsymbol(byteinteger(curlinead+3)); printsymbol(byteinteger(curlinead+4));newline
!         %if nextlinead=curlinead %start
!           i=curlinead
!           i=i+1 %while byteinteger(i)=' '
!           %if byteinteger(i)='{' %then warn(12,0)
!        %finish
         %if nextlinead>curlinead %and curlinead#last linead  %c
           %and nextlinead-curlinead <=2047 %start
            %for i=curlinead,1,nextlinead-1 %cycle
               %if byteinteger(i)='{' %then %start
                 at=locate curly(i)
                 i=i+insert curly(i,at)
!                 %if mode=1 %then warn(12,0)
               %finish
            %repeat
           last linead=curlinead     { avoid multiple copies of curlies }
         %finish
%end
!*
%routine force line
!***********************************************************************
!*   Push out current line after dealing with any missed or            *
!*   faulty lines and merging back any {} comments                     *
!***********************************************************************
%integer i,at
%externalintegerspec filesseen
      %if filesseen=0 %or line <20000 %start { omit include ifiles if any }
!printstring("Force line"); write(nextlinead,5); write(curlinead,5); write(lastlinead,5); newline
!      %for i=curlinead,1,nextlinead %cycle
!          printsymbol(byteinteger(i))
!      %repeat
!      newline
!      %for i=0,1,opline_length-1 %cycle
!           printsymbol(opline_l(i))
!      %repeat
!     newline
!        printstring("  end of force line daignostics"); newline
         curlycheck(0)
         %return %if opline_length=0
         %for i=0,1,opline_length-1 %cycle
            print symbol(opline_l(i))
         %repeat
         newline
      %finish
      i=opline_length-1
      i=i-1 %while I>0 %and (opline_l(i)='}' %or opline_l(i)=NL )
	%if i>=0 %then opline_prevlast=opline_l(i)
      opline_length=0
      opline_lastnl=-1
%end
%routine outsym(%integer sym)
      %if sym=NL %then opline_lastnl=opline_length
      opline_l(opline_length)=sym
      opline_length=opline_length+1
      %if currentSSalt=12{Const integers and constlists } %and sym=',' %c
         %and opline_length-opline_lastnl > breakoplines>>1 %start
         outsym(NL); %return
      %finish
      %if opline_length-opline_lastnl > breakoplines %start
         %if opline_l(opline_lastnl+1)#'#' %start
            %if sym=' ' %or sym=',' %or sym=')' %then outsym(NL)
         %finish
      %finish
%end {outsym}
!*
%routine outsep
!***********************************************************************
!*    Outputs a semicolon avoiding obvious duplicates                  *
!***********************************************************************
%integer i
      i=opline_length-1
      %while i>=0 %and %c
         (opline_l(i)=NL %or opline_l(i)='}') %cycle
         i=i-1
      %repeat
!      printstring("Outsep i,l(i),prev="); write(i,1); space
!      printsymbol(opline_l(i))%if i>=0
!      space; printsymbol(opline_prevlast); newline
      %if i>=0 %and opline_l(i)=';' %then %return
      %if i<0 %and opline_prevlast=';' %then %return
      outsym(';')
%end {outsep}
!*
%routine outstring(%string(255) s)
%integer i,j,sym
      j=opline_length
      %for i=1,1,length(s) %cycle
         sym=charno(s,i)
         %if sym=NL %then %start
            opline_l(j)='\'; opline_l(j+1)='n'; j=j+2
         %finish %else %if sym='"' %start
            opline_l(j)='\'; opline_l(j+1)='"'; j=j+2
         %else
            opline_l(j)=sym
            j=j+1
         %finish
      %repeat
      opline_length=j
%end
%routine outcommentend
      %if opline_l(opline_length-1)#'*' %start
{GT:}    ! Let 'indent' take care of this ...
         !outsym(' ') %while opline_length-opline_lastnl <78
      %finish
      outstring("*/")
%end
%string(255)%fn validname(%string(255) name)
!***********************************************************************
!* Check name is not a C reserved word. If so amaned it                *
{GT:} ! Should also check for std library names???
!***********************************************************************
%constinteger nr=34+1
%conststring(11)%array rnames(0:nr)="sizeof","auto","static","extern","register",
                                    "typedef","char","short","long","int",
                                    "unsigned","float","double","void","enum",
                                    "struct","union","if","else","while",
                                    "do","for","switch","case","default",
                                    "break","continue","return","goto","abs",
                                    "fabs","volatile","asm","const","signed",
                    { AND NOW LIBS }"exit"
%integer i
      %for i=0,1,nr %cycle
         %if name=rnames(i) %then %start
            charno(name,1)=charno(name,1)-32
            %result=name
         %finish
      %repeat
      %result=name
%end
!*
%routine revisename(%string(255)%name name)
%integer i
     %{if parm_quotes#0 %then} %return
     %for i=1,1,length(name) %cycle
        %if 'a'<=charno(name,i)<='z' %then charno(name,i)=charno(name,i)-32
     %repeat
%end
!*
%routine outname(%integer id)
!***********************************************************************
!*    produce name text from an id                                     *
!***********************************************************************
%integer i,ad
%record(listf)%name lcell
%string(255) name
      i=worka_word(id)
      ad=addr(worka_lett(i))
      name=string(ad)
      lcell==aslist(worka_tags(id))
      %if lcell_ptype&x'ff00'=x'4000' %and lcell_uioj&x'f0'=0 %c
         %then revisename(name)
      name=validname(name) %unless lcell_ptype=x'156'   { Dont revise switches CmcP }
      outstring(name)
      %if opline_length-opline_lastnl > breakoplines %start
         %if opline_l(opline_lastnl+1)#'#' %then outsym(NL)
      %finish
%end
!*
%routine outswadname(%integer id)
!***********************************************************************
!*   output a sw name adjusting it if in an inner block
!***********************************************************************
%integer i,ad
%record(listf)%name lcell
%string(255) name
      i=worka_word(id)
      ad=addr(worka_lett(i))
      name=string(ad)
      lcell==aslist(worka_tags(id))
      %if lcell_ptype&x'ff00'=x'4000' %and lcell_uioj&x'f0'=0 %c
         %then revisename(name)
      outstring(name)
      %if currinf_iblkid>0 %start
         outsym('_'); outint(currinf_iblkid)
      %finish
%end

%integerfn possible typename(%integer id,%stringname typename)
!***********************************************************************
!*   if id ends in "...type" set typename to ..._type                  *
!***********************************************************************
%integer i,ad,j
%string(255) name,firstpart,s,t
      i=worka_word(id)
      ad=addr(worka_lett(i))
      name=string(ad)
      j=0;
      %while name -> s.("type").name %cycle
         %if j=0 %then firstpart=s %else firstpart=firstpart."type".s
        j=j+1
      %repeat
      %if name="" %and length(firstpart)>3 %start      { ended in ...type }
         typename=firstpart."_type"
         %result=1
      %else
         typename="not_a_valid_type_name"
         %result=0
      %finish
%end

%routine outrevisablename(%integer id)
!***********************************************************************
!*    produce name text from an id  and revise without tag check       *
!***********************************************************************
%integer i,ad
%string(255) name
      i=worka_word(id)
      ad=addr(worka_lett(i))
      name=string(ad)
      revisename(name)
      outstring(validname(name))
      %if opline_length-opline_lastnl > breakoplines %start
         %if opline_l(opline_lastnl+1)#'#' %then outsym(NL)
      %finish
%end
!*
%routine out formatname(%integer kf)
%integer i,kk
%record(listf)%name lcell
%string(255) s
      %for i=0,1,worka_nnames %cycle
         kk=tags(i)
         %if kk#0 %start
            lcell==aslist(kk)
            %if lcell_ptype&15=4 %and lcell_kform=kf %start
               %if possible typename(i,s)>0 %start
                  outstring(s)
               %else
                  %if lcell_ptype=4 %then outstring("struct ") %else outstring("union ")
                  outname(i)
               %finish
               %return
            %finish
         %finish
       %repeat
       outstring(" ? unknown format name ?")
!      %monitor
%end
!*
!*
%routine out extern(%integer extern)
      %if extern&3=0 %start
         outstring("static const ")
      %finish %else %if extern=1 %start
        outstring("static ")
      %finish %else %if extern=3 %start
        outstring("extern ")
      %finish
%end
%routine outhex(%integer value)
%CONSTSTRING(1)%ARRAY HEX(0:15)="0","1","2","3","4",
               "5","6","7","8","9","A","B","C","D","E","F"
%INTEGER I,digit
%STRING(8)RES
      RES=""
      %FOR I=8<<2-4,-4,0 %CYCLE
         digit=VALUE>>I&15
          %if res#"" %or digit#0 %then RES=RES.HEX(digit)
      %REPEAT
      %if res="" %then res="0"
      outstring("0x".res)
%end

%routine outtype(%integer type,kf)
      %if type=x'31' %start
         outstring("unsigned char ")
      %finish %else %if type=x'41' %start
         outstring("short int ")
      %finish %else %if type=x'51' %start
         outstring("int ")
      %finish %else %if type=x'61' %start
         outstring("INT64 ")
      %finish %else %if type=x'52' %start
         outstring("float ")
      %finish %else %if type=x'62' %start
         outstring("double ")
      %finish %else %if type=x'72' %start
         outstring("long double ")
      %finish %else %if type=x'35'  %start
          outstring("char * ")
      %finish %else %if type=x'33' %start
          outformatname(kf)
         outsym(' ')
      %else
         outstring("void ")
{GT:DEBUG outstring("/*");outhex(type);outstring("*/")}
      %finish
%end {outtype }
!*
%routine outxtype(%integer xtype,kf)
%integer rout,nam,arr,type
       rout=xtype>>12&1
       nam=xtype>>10&3
       arr=xtype>>8&3
       type=xtype&7
       outtype(xtype&255,kf)
       %if (rout#0 %or arr#0 %or nam&1#0) %and type#5 %then outsym('*')
%end

%routine outlhex(%integer msh,lsh)
%CONSTSTRING(1)%ARRAY HEX(0:15)="0","1","2","3","4",
               "5","6","7","8","9","A","B","C","D","E","F"
%INTEGER I,digit
%string(16)res
      RES=""
      %FOR I=8<<2-4,-4,0 %CYCLE
         digit=msh>>I&15
          %if res#"" %or digit#0 %then RES=RES.HEX(digit)
      %REPEAT
      %FOR I=8<<2-4,-4,0 %CYCLE
         digit=lsh>>I&15
          %if res#"" %or digit#0 %then RES=RES.HEX(digit)
      %REPEAT
      %if res="" %then res="0"
      outstring("0x".res)
%end
{GT: outhex moved higher up}
!*
%routine outint(%integer value)
!***********************************************************************
!*    SIMPLE MINDED ALL IMP VERSION NOT USING STRINGS                  *
!***********************************************************************
%INTEGER SIGN,WORK,PTR
%BYTEINTEGERARRAY CH(0:15)
      %if value=x'80000000' %then outhex(value) %and %return
      SIGN=' '
      %IF VALUE<0 %THEN SIGN='-' %AND VALUE=-VALUE
      PTR=0
      %CYCLE
         WORK=VALUE//10
         CH(PTR)=VALUE-10*WORK
         VALUE=WORK
         PTR=PTR+1
      %REPEATUNTIL VALUE=0
      WORK=PTR-1
      OUTSYM(SIGN) %if sign='-'
      outSYM(CH(PTR)+'0') %FOR PTR=WORK,-1,0
%end
!*
%routine outinternames(%integer info)
!***********************************************************************
!* output any intermediate (union) names needed to access              *
!* elements of imps more general record as C struct                    *
!************************************************************************

%integer k,id
      %for k=12,-4,0 %cycle
         id=info>>k&15
         %if id#0 %start
            %if id&8#0 %then %start
               outstring("s")
               outint(id&7)
            %else
               outstring("u")
               outint(id&7-1{ union update })
            %finish
            outsym('.')
         %finish
      %repeat
%end
!*
%ROUTINESPEC OUTFL (%LONGREAL X, %INTEGER N)
%ROUTINE PRINT (%LONGREAL X, %INTEGER N,M)
!***********************************************************************
!*       PRINTS A REAL NUMBER (X) ALLOWING N PLACES BEFORE THE DECIMAL *
!*       POINT AND M PLACES AFTER.IT REQUIRES (M+N+2) PRINT PLACES     *
!*       UNLESS (M=0) WHEN  (N+1) PLACES ARE REQUIRED.                 *
!*                                                                     *
!*       A LITTLE CARE IS NEEDED TO AVOID UNNECESSARY LOSS OF ACCURACY *
!*       AND TO AVOID OVERFLOW WHEN DEALING WITH VERY LARGE NUMBERS    *
%CONSTLONGREAL DZ=0
!***********************************************************************
%LONGREAL Y,Z,ROUND,FACTOR
%INTEGER I,J,L,MORIG
%BYTEINTEGER SIGN
      M=M&63;                           ! DEAL WITH STUPID PARAMS
      MORIG=M
      %IF N<0 %THEN N=1; N=N&31;        ! DEAL WITH STUPID PARAMS
      X=X+DZ;                           ! NORMALISE
      SIGN=' ';                         ! '+' IMPLIED
      %IF X<0 %THEN SIGN='-'
      Y=MOD(X);                         ! ALL WORK DONE WITH Y
      ROUND=0.5/10**M;                  ! ROUNDING FACTOR
      %IF Y>1.0*10**16 %OR N=0 %THENSTART;    ! MEANINGLESS FIGURES GENERATED
         %IF N>M %THEN M=N;             ! FOR FIXED POINT PRINTING
         OUTFL(X,M);                 ! OF ENORMOUS NUMBERS
         %RETURN;                       ! SO PRINT IN FLOATING FORM
      %FINISH
      I=0; Z=1; Y=Y+ROUND
      %UNTIL Z>Y %CYCLE;                ! COUNT LEADING PLACES
         I=I+1; Z=10*Z;                 ! NO DANGER OF OVERFLOW HERE
      %REPEAT
      OUTSYM(SIGN)
      J=I-1; Z=10**J
      FACTOR=1/10
      %CYCLE
         %UNTIL J<0 %CYCLE
            L=INT PT(Y/Z);              ! OBTAIN NEXT DIGIT
            Y=Y-L*Z; Z=Z*FACTOR;        ! AND REDUCE TOTAL
            OUTSYM(L+'0')
            J=J-1
         %REPEAT
         %IF M=0 %THENEXIT;           ! NO DECIMAL PART TO BE O/P
         OUTSTRING(".")
         J=M-1; Z=10**(J-1); M=0
         Y=10*Y*Z
      %REPEAT
      %if MORIG>0 %start          { Chop any redundant trailing 0s}
         opline_length=opline_length-1 %while %c
           opline_l(opline_length-1)='0' %and opline_l(opline_length-2)#'.'
      %finish
%END;                                   ! OF ROUTINE PRINT
%ROUTINE OUTFL (%LONGREAL X, %INTEGER N)
!***********************************************************************
!*       PRINTS IN FLOATING POINT FORMAT WITH N PLACES AFTER THE       *
!*       DECIMAL POINT. ALWAYS TAKES N+7 PRINTING POSITIONS.           *
!*       CARE REQUIRED TO AVOID OVERFLOW WITH LARGE X                  *
!***********************************************************************
%LONGREAL SIGN,ROUND,FACTOR,LB,UB
%CONSTLONGREAL DZ=0
%INTEGER COUNT,INC
     inc=integer(addr(x))
      %if inc>>20&x'7ff'=x'7ff' %start
         outstring("NAN {"); outhex(inc); outhex(integer(addr(x)+4))
         outsym('}'); %return
      %finish
      ROUND=0.5/10**N;                  ! TO ROUND SCALED NO
      LB=1-ROUND; UB=10-ROUND
      SIGN=1
      X=X+DZ;                           ! NORMALISE
      %IF X=0 %THEN COUNT=0 %ELSESTART
         %IF X<0 %THEN X=-X %AND SIGN=-SIGN
         INC=1; COUNT=0
         FACTOR=1/10
         %IF X<=1 %THEN FACTOR=10 %AND INC=-1
                                        ! FORCE INTO RANGE 1->10
         %WHILE X<LB %OR X>=UB %CYCLE
            X=X*FACTOR; COUNT=COUNT+INC
         %REPEAT
      %FINISH
      PRINT(SIGN*X,1,N)
      %if count#0 %start
         OUTSTRING("E")
         OUTINT(COUNT)
      %finish
%END;                                   ! OF ROUTINE OUTFL
   %routine FORCE TRIPS
!***********************************************************************
!*    FORCE OUT THE TRIPLES TO CODE. NEEDED IN CEND ETC                *
!***********************************************************************
      triples(0)=0
      nexttrip=1
      triples(0)_flink=1       { return any triples }
      %end

      %routine COMPILE A STMNT
         %integer I
         force trips
         I = NEXTP
         STARSIZE = A(NEXTP)<<16+A(NEXTP+1)<<8+A(NEXTP+2)
         NEXTP = NEXTP+STARSIZE
         LINE = A(I+3)<<8+A(I+4)
         curlinead=fromar4(I+5)
         nextlinead=fromar4(NEXTP+5)
         STMTS = STMTS+1
         opline_line=line
         CSS(I+9)
          %if a(NEXTP+3)<<8!A(NEXTP+4)=line %then %start
           curly check(1)
           outsym(9)
         %else
            force line
         %finish
      %end
%integerfn nextstmntalt
      %result=a(NEXTP+9)
%end
      %routine CSS(%integer Pinit)
         %routine %spec ENTER JUMP(%integer MASK,STAD,FLAG)
         %integer %fn %spec ENTER LAB(%integer M,FLAG)
         %routine %spec REMOVE LAB(%integer LAB)
         %routine %spec SAVE STACK PTR
         %routine %spec CEND(%integer KKK)
         %integer %fn %spec CCOND(%integer CTO,A,B,JFLAGS)
         %integer %fn %spec REVERSE(%integer MASK)
         %routine %spec SET LINE
         %routine %spec CUI(%integer CODE)
         %routine %spec ASSIGN(%integer A,B)
         %routine %spec CSTART(%integer CCRES,MODE)
         %routine %spec CCYCBODY(%integer UA,ELAB,CLAB)
         %routine %spec CLOOP(%integer ALT,MARKC,MARKUI)
         %routine %spec CIFTHEN(%integer MARKIU,MARKC,MARKUI,MARKE,MARKR,Afterelse)
         %integer %fn %spec CREATE AH(%integer MODE,
            %record (RD) %name EOPND,NOPND)
         %routine %spec TORP(%integer %name HEAD,BOT,NOPS,%integer mode)
         %integer %fn %spec INTEXP(%integer %name VALUE, %integer PRECTYPE)
         %integer %fn %spec CONSTEXP(%integer PRECTYPE)
         %routine %spec CSEXP(%integer MODE)
         %routine %spec labexp
         %routine %spec outopnd(%record(rd)%name opnd,%integer mode)
         %routine %spec outtriple(%integer tripno,mode)
         %routine %spec CSTREXP(%integer B)
         %routine %spec CRES(%integer LAB)
         %routine %spec EXPOP(%integer %name A,B, %integer C,D)
         %routine %spec TEST APP(%integer %name NUM)
         %routine %spec SKIP EXP
         %routine %spec SKIP APP
         %routine %spec NO APP
         %integer %fn %spec DOPE VECTOR(%integer A,B,C,MODE,ID)
         %routine %spec DECLARE ARRAYS(%integer A,B)
         %routine %spec DECLARE SCALARS(%integer B)
         %routine %spec CRSPEC(%integer M)
         %routine %spec CFPLIST(%integer %name A,B)
         %routine %spec CFPDEL
         %routine %spec CLT
         %integer %fn %spec ROUNDING LENGTH(%integer PTYPE,RULES)
         %routine %spec CQN(%integer P)
         %integer %fn %spec TSEXP(%integer %name VALUE)
          %integer %fn %spec tcond
         %routine %spec CRCALL(%integer RTNAME)
         %routine %spec NAMEOP(%integer Z,SIZE,NAMEP)
         %routine %spec CNAME(%integer Z)
         %routine %spec CANAME(%integer Z,ARRP, %record (RD) %name HDOPND)
         %routine %spec CSNAME(%integer Z)
         %routine %spec COPY TAG(%integer KK,DECLARE)
         %routine %spec REDUCE TAG(%integer DECLARE)
         %routine %spec STORE TAG(%integer KK,LEVEL,RBASE,J,SNDISP,ACC,SLINK,
            KFORM)
         %routine %spec UNPACK
         %routine %spec PACK(%integer %name PTYPE)
         %routine %spec RDISPLAY(%integer KK)
         %routine %spec RHEAD(%integer RTNAME,AXNAME,Xtra)
         %integer %fn %spec CFORMATREF
         %routine %spec CRFORMAT(%integer myrflevel)
            %routinespec process format(%integer level,alt,structor union,intid,
                  %integername strid,ophed,opbot)
         %integer %fn %spec DISPLACEMENT(%integer LINK)
         %integer %fn %spec COPY RECORD TAG(%integer %name SUBS)
         %integer %fn %spec CHK REC ALIGN(%integer p1)
         %switch SW(1:24)
         %const %byte %integer %array FCOMP(0:14)=0,
                                   8,10,2,7,12,4,7,
                                   8,12,4,7,10,2,7
%integer %array rfhead,rfbot(0:12,0:12),rfalt(0:12)
%integer rflevel

         %integer P,SNDISP,ACC,K,KFORM,STNAME,MIDCELL
         %integer TCELL,JJ,JJJ,KK,QQ,MARKER,REPORTUI,XDISP,MASK,BASE,AREA,
            ACCESS,DISP,EXTRN,CURR INST,VALUE,STRINGL,PTYPE,I,J,OLDI,USEBITS,
            STRFNRES,MARKIU,MARKUI,MARKC,MARKE,MARKR,INAFORMAT
         %integer LITL,ROUT,NAM,ARR,PREC,TYPE,lhformatname,doinglabel
         %record (RD) EXPOPND,NAMEOPND,MLOPND;  ! RESULT RECORD FOR EXPOP&CNAME
!
! on some machines global parameters are difficult to access hence
! copy pinit into local P which is frequently updated globally
!
         P = Pinit
        doinglabel=0
         CURR INST = 0; INAFORMAT = 0
         currentSSalt=a(p)
         ->SW(currentSSalt)
SW(13):                                  ! INCLUDE SOMETHING
      %begin
      %string(255) s,head,tail
      s=string(addr(a(P+2)))       { File name}
      %if s-> head.(".inc").tail %then s=head.".h"
      outstring("#include "); outsym('"')
      outstring(s)
      outsym('"')
      %end
      ->cssexit2
SW(24):                                  ! REDUNDANT SEP
      %if a(p+1)=10 %then outsym(' ')         { extar neline }
      ->css exit2
SW(2):                                   ! <CMARK> <COMMENT TEXT>
      p=p+1
      kk=a(p); p=p+1;                    ! kk=1 # comment, =2 ! comment, =3 %comment
       jj=a(p); jjj=0
      %if KK=1 %then outsym('#') %else outstring("/*")    { preserve any #defines in the imp}
      %while jj#NL %cycle
         %if JJ>128 %and jjj<128 %then outsym('%')
         outsym(jj&127)
         jjj=jj
         p=p+1; jj=a(p)
         %if jjj='\' %and JJ=13{CR} %and KK=1 %then outsym(NL) %and p=p+1 %and %continue
         %if jjj=',' %and ((kk=2 %and jj='!') %or (kk=1 %and jj='#')) %start { unscramble comments ending with a comma = continuation}
            %if kk=1 %start
               outsym(NL); outsym('#')
            %else
               outcommentend; outsym(NL)
               outstring("/*")
            %finish
            jjj=jj; p=p+1; jj=a(p)
         %finish
      %repeat
      %if kk>1 %then outcommentend
      ->CSSEXIT2
CSSEXIT: outsep %unless opline_length>0 %and  opline_l(opline_length-1)='}'
Cssexit2: LAST INST = CURR INST
         %return
SW(1):                                   !(UI)(S)
!         FAULT(57,0,0) %unless LEVEL>=2
         MARKER = P+1+A(P+1)<<8+A(P+2)
         P = P+3
         ->LABFND %if A(MARKER)=1
         %if A(MARKER)=2 %then SET LINE %and CUI(0) %and ->CSSEXIT
         MARKE = 0; MARKR = 0
         MARKUI = P; MARKIU = MARKER+1
         MARKC = MARKIU+1
         %if A(MARKER)=3 %then %c
            CIFTHEN(MARKIU,MARKC,MARKUI,0,0,NO) %and ->CSSEXIT
         CLOOP(A(MARKIU),MARKC+2,MARKUI)
         ->CSSEXIT
LABFND:  OLDLINE = 0
         ->SWITCH %unless A(P)=1 %and A(P+5)=2;  ! 1ST OF UI AND NO APP
         ->SWITCH %unless A(P+6)=2 %and A(P+7)=2;  ! NO ENAMSE OR ASSNMNT
         JJ = ENTER LAB(FROM AR2(P+3),0)
         outname(from ar2(P+3))
         outsym(':'); curly check(0);  outsym(NL);
        %if 1<<next stmntalt&(1<<6!1<<4!1<<18!1<<9)#0 %then outsep
         ->CSSEXIT2
SW(5):                                   ! %cycle
!         FAULT(57,0,0) %unless LEVEL>=2
         %if A(P+5)=2 %then %start;      ! OPEN CYCLE
            CLOOP(0,P+1,P+1)
         %finish %else %start
            SET LINE
            CLOOP(6,P+6,P+1)
         %finish
         ->CSSEXIT
!
SW(6):                                   ! REPEAT
         ->CSSEXIT2
SW(22):                                  ! '%CONTROL' (CONST)
         ->CSSEXIT2
!
SW(3):                                   ! (%iu)(COND)%then(UI)(ELSE')
         MARKIU = P+1; MARKC = MARKIU+3
         MARKR = P+2+A(P+2)<<8+A(P+3);   ! ! FROMAR2(P+2)
         MARKE = 0
         %if A(MARKR)=3 %then %start
            MARKE = MARKR+1+FROMAR2(MARKR+1)
            MARKUI = MARKR+3
         %finish
         CIFTHEN(MARKIU,MARKC,MARKUI,MARKE,MARKR,NO)
         ->CSSEXIT
SW(4):
                                         ! '%FINISH(ELSE')(S)
SW(18):
                                         ! '%ELSE' MEANING FINISH ELSE START
         ->CSSEXIT2
SWITCH:  %begin;                         ! SWITCH LABEL
            %record (LISTF) %name LCELL
            %record(swdataform)%name swdata
            %integer NAPS,FNAME
            FNAME = FROM AR2(P+3)
            %unless A(P)=1 %and A(P+5)=1 %then FAULT(5,0,FNAME) %and ->BEND
                                         ! 1ST OF UI + APP
            P = P+6
            COPY TAG(FNAME,NO)
            %if OLDI#LEVEL %or TYPE#6 %then FAULT(4,0,FNAME) %and ->BEND
            LCELL==aslist(k)
            swdata==record(LCELL_S1)
            swdata_slabs(swdata_lseen)=p
            swdata_lseen=swdata_lseen+1
            outswadname(fname); outstring("_"); labexp; outsym(':')
            curly check(0); outsym(NL);
           %if 1<<next stmntalt&(1<<6!1<<4!1<<18!1<<9)#0 %then outsep
BEND:    %end
         FORCE TRIPS %if PARM_OPT=0
         ->CSSEXIT2
SW(23):
                                         ! SWITCH(*):
         %begin
            %record (LISTF) %name LCELL
            %record(swdataform)%name swdata
            %integer FNAME,JJ,RES
            FNAME = FROM AR2(P+1)
            COPY TAG(FNAME,NO)
            %if OLDI=LEVEL %and TYPE=6 %start
               LCELL == ASLIST(K)
               swdata==record(LCELL_S1)
               swdata_default=p
               outswadname(fname); outstring("_default:")
            %finish %else FAULT(4,0,FNAME)
         %end
         FORCE TRIPS %if PARM_OPT=0
         ->CSSEXIT2
!
SW(7):                                   ! (%wu)(SC)(COND)(RESTOFWU)
!         FAULT(57,0,0) %unless LEVEL>=2
         MARKIU = P+1;                   ! TO WHILE/UNTIL
         MARKC = MARKIU+3;               ! TO (SC)(COND)
         CLOOP(A(MARKIU)+3,MARKC,MARKIU+1+FROMAR2(MARKIU+1))
         ->CSSEXIT
!
SW(8):                                   ! SIMPLE DECLN
!         FAULT(57,0,0) %unless LEVEL>=2
         P = P+1
         MARKER = P+FROMAR2(P);          ! TO ALT OF DECLN
         P = P+2; ROUT = 0; LITL = 0
         %if A(MARKER)#1 %then %start;   ! ARRAY DECLARATIONS
            CLT
            %if TYPE=5 %and (ACC<=0 %or ACC>256) %then %c
               FAULT(70,ACC-1,0) %and ACC = 255
            NAM = 0
            SET LINE
            QQ = 2-A(P+1); P = P+2;      ! QQ=1 FOR ARRAYFORMATS
            DECLARE ARRAYS(QQ,KFORM)
            %if qq=1 %then ->cssexit2   { ignore formats }
            FORCE TRIPS %if PARM_OPT=0
         %finish %else %start
            CLT
            CQN(P+1); P = P+2
            DECLARE SCALARS(KFORM)
         %finish
         ->CSSEXIT
!
SW(9):                                   ! %end
         %begin
            %switch S(1:5)
           %integer etype
            etype=A(P+1)
            ->S(etype)
S(1):                                    ! ENDOFPROGRAM
{GT:}       outstring("exit(0);"{"imp_stop();"}); outsym(NL)
S(2):                                    ! ENDOFFILE
            %if PARM_CPRMODE=0 %then PARM_CPRMODE = 2
            FAULT(15,LEVEL+PARM_CPRMODE-3,0) %unless LEVEL+PARM_CPRMODE=3
            CEND(PARM_CPRMODE)
            outsym('}') %if etype=1
            ->BEND
S(3):                                    ! ENDOFLIST
            ->BEND
S(4):                                    ! END
            %if PARM_CPRMODE=1 %and LEVEL=2 %then FAULT(14,0,0) %else %c
               CEND(CURRINF_FLAG)
            outstring("}"); ! outstring(" /* proc */")
BEND:    %end
         ->CSSEXIT2
!
SW(11):
         %begin
            %integer MARKER1,RTNAME,KKK,PTR,PTYPEP,CNT,PP,PCHAIN,AXNAME,
               PNAME,NPARAMS,SCHAIN,PARMSPACE,D,PARAMPTYPE,PARAMACC,pcount
            %record (LISTF) %name LCELL,LCELL2,TCELL
            P = P+1; MARKER1 = FROM AR2(P)+P;  ! (SEX)(RT)(SPEC')(NAME)(FPP)
           markc=a(marker1)
AGN:        Q = P; RTNAME = FROM AR2(MARKER1+3);  ! RTNAME ON NAME
            EXTRN = A(P+2);              ! 1=SYSTEM,2=EXTERNAL
                                         ! 3=DYNAMIC, 4=INTERNAL

            LITL = EXTRN&3
            %if A(MARKER1)=1 %then %start;  ! P<%spec'>='%spec'
               P = P+3; CRSPEC(1-EXTRN>>2);  ! 0 FOR ROUTINESPEC
                                         ! 1 FOR EXTERNAL (ETC) SPEC
               ->BEND
            %finish
            FORCE TRIPS;                 ! IN CASE OPTIMISING
            COPY TAG(RTNAME,NO)
            AXNAME = ADDR(WORKA_LETT(WORD(RTNAME)))
            %if EXTRN=3 %then EXTRN = 2
            %if TARGET=EMAS %and EXTRN=1 %then WARN(11,0)
            %if A(MARKER1+5)=1 %then %start;! extract alias name
               MOVE BYTES(A(MARKER1+6)+1,ADDR(A(0)),MARKER1+6,ADDR(A(0)),
                  WORKA_ARTOP)
               AXNAME = ADDR(A(WORKA_ARTOP))
               WORKA_ARTOP = (WORKA_ARTOP+4+A(MARKER1+6))&(-4)
            %finish
            %if EXTRN=4 %then AXNAME = 0
            %if OLDI#LEVEL %then %start;  ! NAME NOT KNOWN AT THIS LEVEL
               P = Q+3; CRSPEC(2); P = Q; ->AGN
            %finish %else %start;        ! NAME ALREADY KNOWN AT THIS LEVEL
               %if PARM_CPRMODE=0 %then PARM_CPRMODE = 2;  ! FLAG AS FILE OF%c
                                                           ROUTINES
               FAULT(56,0,RTNAME) %unless %c
                  EXTRN=4 %or (PARM_CPRMODE=2 %and LEVEL=1)
               %if A(P+3)=1 %then KKK = LITL<<14!X'1000' %else %start
                  ROUT = 1; P = P+4;     ! FIGURE OUT PTYPE FOR FNS&MAPS
                  CLT; ARR = 0; NAM = 0
                  %if A(P)=2 %then NAM = 2;  ! SET NAME ARRAY BIT FOR MAPS
                  PACK(KKK);             ! AND STORE PTYPE IN KKK
               %finish
            %finish
!
! UNLESS A MATCH WAS OBTAINED BETWEEN HEADING AND SPEC SOMETHING
! HAS GONE WRONG. COMPILE HEADING AGAIN AS SPEC. THIS WILL
! PREVENT ANY INCONSISTENCIED AND CAUSE A "NAME SET TWICE"
! FOR ANY ERROR
!
            %unless (J=15 %or J=7*EXTRN) %and PTYPE&X'FFFF'=KKK %start
               P = Q+3; CRSPEC(2); P = Q; ->AGN
            %finish
{GT:} ! BUG !!!  %externalroutinespec fred(%int i)
!       translates to void fred(void)

            PTYPE = PTYPE!(EXTRN&3)<<14;  ! DEAL WITH %routinespec FOLLOWED
                                         ! BY %externalroutine
!
! RESET THE TAGS TO BODY GIVEN AND ALLOWING FOR SPEC/EXTERNALROUTINE
! AND EXTERNALSPEC/EXTERNAL ROUTINE COMBINATIONS. RESTORE THE USE
! BITS WHICH WILL SHOW USED AS A RESULT OF THE COPY TAG IN THIS SEQUENCE
!
            TCELL == ASLIST(TAGS(RTNAME))
            TCELL_PTYPE <- PTYPE
            %if PTYPE&x'c000'=x'8000' %then USEBITS = 2;  ! externals presumed%c
                                                          'used'

            TCELL_UIOJ <- TCELL_UIOJ&X'3FF0'!USEBITS<<14
                                         ! NEWPTYPE & SET J=0
            %if (target=Perq %or Target=Accent) %and J=14 %then %c
              TCELL_S2 = WORKA_RTCOUNT %and WORKA_RTCOUNT = WORKA_RTCOUNT+1
                                         ! NO RT NO ALLOCATED TO EXTERNAL SPECS
            PTYPEP = PTYPE
               %if ptypep&x'c000'=0 %then outstring("static ")
               outtype(ptypep&255,tcell_kform)
               %if ptypep&x'800'#0 %and ptypep&7#5 %then outsym('*')
               %if axname=0 %then outname(rtname) %else outstring(string(axname))
               outsym('(')
            PCHAIN = TCELL_SLINK;        ! CHAIN OF PARAMETER DESCRIPTUONS
            RHEAD(RTNAME,AXNAME,fromar2(marker1+1));! FIRST PART OF ENTRY SEQUENCE
!
! NOW DECLARE THE FORMAL PARAMETERS. FOLLOW BY CLAIMING DISPLAY
! AND SETTING DIAGNOSTIC PTR IN ROUTINE RDISPLAY
!
            P = MARKER1+6
            %if A(P-1)=1 %then P = P+A(P)+1;  ! SKIP OVER ALIASNAME
            CNT = 0
            PTYPE = PTYPEP; UNPACK
            N = RTPARAM1OFFSET
            %if TARGET=PERQ %or TARGET=ACCENT %start
               %if TYPE#0 %then N = (BYTES(PREC)+1)&(-2)
               %if TYPE=5 %or TYPE=3 %then N = 4;  ! MAPS
               %if NAM#0 %then %start
                  %if TYPE=5 %then N = 4 %else N = PTRSIZE(PTYPE&127)
                                         ! BYTE MAPS RETURN BYTE PTR
               %finish
               CURRINF_RESSIZE = N
            %finish
            NPARAMS = 0; PARMSPACE = 0
            %if PCHAIN#0 %then NPARAMS = ASLIST(PCHAIN)_S3
            %if NPARAMS#0 %then %c
               PARMSPACE = NPARAMS>>16 %and NPARAMS = NPARAMS&X'FF'
                                         ! ALLOW ACTUAL PARAMETER SPACE
            %while A(P)=1 %cycle;        ! WHILE SOME (MORE) FP PART
               PP = P+1+FROMAR2(P+1)
               P = P+3
               CFPDEL
               PARAMPTYPE = PTYPE; PARAMACC = ACC;  ! may get cahnged for rt%c
                                                    types
               PTR = P
               %until A(PTR-1)=2 %cycle;  ! CYCLE DOWN NAMELIST
                  %if PARAMS BWARDS=YES %start;  ! MAP PCHAIN TO REVERSE ORDER%c
                                                 LIST
                     PCHAIN = TCELL_SLINK
                     PCHAIN = ASLIST(PCHAIN)_LINK %for KKK = 2,1,NPARAMS-CNT
                  %finish
                  LCELL == ASLIST(PCHAIN);  ! EXTRACT PTYPE XTRA INFO
                  %if PCHAIN#0 %then %start
                     %unless LCELL_PTYPE=PARAMPTYPE %and %c
                        LCELL_ACC&x'FFFF'=PARAMACC %then FAULT(9,CNT+1,RTNAME)
                  %finish
                  PNAME = FROM AR2(PTR);  ! NAME FOR PARAM INTERNALLY
                  LCELL_UIOJ <- LCELL_UIOJ!PNAME<<4;  ! SAVED IN LIST( max 12 bits!)
                  D = LCELL_SNDISP+N;    ! PARAMETER OFFSET
                  %if PARAMPTYPE&x'1000'#0 %start;  ! PROCEDURE PARAMETERS
                     P = PTR
                     P = P+3 %until A(P-1)=2
                     CFPLIST(SCHAIN,KKK);  ! PARAMETERLIST FOR PASSED PROC
                     PTYPE = PARAMPTYPE;  ! CHANGED BY CFPLIST
                     outtype(paramptype&255,kform); outname(pname); outstring("(")
                     lcell2==aslist(schain)
                     %if KKK=0 %then outstring("void ") %else %start
                        %for pcount=1,1,KKK %cycle
                           %if lcell2_s1&x'10000000'#0 %start
                              outtype(lcell2_s1>>16&255,lcell2_sndisp); outstring("()")
                           %else
                              outxtype(lcell2_s1>>16,lcell2_sndisp)
                           %finish
                           %if lcell2_link#0 %then outsym(',')
                           lcell2==aslist(lcell2_link)
                        %repeat
                     %finish
                     outstring(")")
                     STORETAG(PNAME,LEVEL,RBASE,13,D,LCELL_ACC,SCHAIN,0)
                  %finish %else %start
                     %if TARGET=EMAS %and PTYPE=X'33' %then D = D+8
                                         ! FOR HISTORIC PARAMTER COMPATABILITY
                     %if STRVALINWA=YES %and PTYPE=X'35' %then PTYPE = X'435'
!                      %if recvalinwa=yes %and ptype=X'33' %and acc#4 %then ptype=x'433'
                     outxtype(paramptype,kform); outname(pname);
                     STORE TAG(PNAME,LEVEL,RBASE,LCELL_UIOJ&15,0,ACC,D,KFORM)
                     PTYPE = PARAMPTYPE
                  %finish
                  PTR = PTR+3
                  CNT = CNT+1
                  PCHAIN = LCELL_LINK %if PARAMS BWARDS=NO
            outsym(',') %unless pchain=0
               %repeat
               P = PP
            %repeat;                     ! UNTIL NO MORE FP-PART
            outstring(") {")
            N = N+PARMSPACE
            N = (N+MINPARAMSIZE-1)&(-MINPARAMSIZE);  ! TO WORD BOUNDARY AFTER%c
                                                     ALL SYSTEM
                                         ! STANDARD PARAMETERS HAVE BEEN%c
                                         DECLARED
            FAULT(8,0,RTNAME) %if CNT>NPARAMS
            FAULT(10,0,RTNAME) %if CNT<NPARAMS
            PTYPE = PTYPEP
            %if STRRESINWA=YES %start;   ! NEEDS FN RESULT DESC
               %unless 3#PTYPE&X'F0F'#5 %then N = N+PTRSIZE(X'35')
                                         ! STR FNS RESULT PARAM IS STACKED
               CURRINF_RESSIZE = N
            %finish
            N = N+ALPHA;                 ! allow for link bytes on unix(etc)
            %if TARGET=PNX %then %start
               IMPABORT %if N&7#0
            %finish
                                         ! AS XTRA PARM JUST BEFORE DISPLAY
            RDISPLAY(RTNAME)
BEND:    %end
      Force trips %if parm_opt=0;! Problems if procname redeclared
                                         ! as new proc before entry code planted
         ->cssexit2
!
SW(14):                                  ! %begin
         %begin
            FORCE TRIPS;                 ! IN CASE OPTIMISING
            PTYPE = 0
            %if LEVEL=1 %and RLEVEL=0 %start
               %if PARM_CPRMODE=0 %then %start
                  RLEVEL = 1; RBASE = 1
                  PARM_CPRMODE = 1
                  RHEAD(-1,ADDR(MAINEP),1)
                  N = RTPARAM1OFFSET+alpha
                  outstring("main() {")
               %finish %else FAULT(58,0,0)
            %finish %else %start
               SET LINE;                 ! SO 'ENTERED FROM LINE' IS OK
               outstring("{")
               RHEAD(-1,0,1)
            %finish
            RDISPLAY(-1)
         %end
         ->CSSEXIT2
!
SW(15):
                               ! '%ON'(EVENT')(N)(NLIST)'%start'

! Shouldn't we compile a CSTART(..., 3) here? ... Yes! - code supplied by PDS:

         p=p+2; skip exp;
         %while a(p)=1 %cycle
           p=p+1
           skip exp
         %repeat
         p=p+1
         outstring("if (0) {")
         outsym(NL)
         cstart(0,3)
         outstring(" }")

! and in cstart, do...  %if code=3 %then outstring("#endif /* On event */") %and outsym(NL)
! so ... where is the %FINISH handled if not there???

         ->CSSEXIT

SW(16):
         %begin;                         ! %switch (SWITCH LIST)
            %integer Q,RANGE,KKK,LB,UB,PP,D0,OPHEAD,V,R,datad
            %record (RD) OPND1,OPND2
            %record(swdataform)%name swdata
!            FAULT(57,0,0) %unless LEVEL>=2
            Q = P
            %until A(Q)=2 %cycle;        ! UNTIL NO'REST OF SW LIST'
               P = P+3
               P = P+3 %while A(P)=1
               P = P+4;                  ! TO P(+')
               KKK = INTEXP(LB,MINAPT);  ! EXTRACT LOWER BOUND
               P = P+3
               KKK = KKK!INTEXP(UB,MINAPT);  ! EXTRACT UPPER BOUND
               RANGE = (UB-LB+1)
               %if RANGE<=0 %or KKK#0 %start
                  LB = 0; UB = 10; RANGE = 1024
               %finish
               datad=malloc(4*range+8)
               swdata==record(datad)
               swdata_lseen=0; swdata_default=0
               PTYPE = X'56'+1<<8;       ! WORD LABEL ARRAY
               PP = P; P = Q+1
               %until A(P-1)=2 %cycle;   !  DOWN NAMELIST
                  K = FROM AR2(P)
                  P = P+3
                  OPHEAD = 0
                  OPND1_PTYPE <- PTYPE
                  OPND1_XB = 0
                  OPND1_FLAG = DNAME
                  OPND1_D = K
                  OPND1_XTRA = 0
                  OPND2_PTYPE = X'61'
                  OPND2_XB = 0
                  OPND2_FLAG = DNAME
                  OPND2_D = LB
                  OPND2_XTRA = UB
                  V = BRECTRIP(DCLSW,PTYPE,0,OPND1,OPND2)
                  PUSH(OPHEAD,datad,LB,UB)
                  STORE TAG(K,LEVEL,RBASE,1,0,4,OPHEAD,0)
{GT:}             outstring("int "); outswadname(k); outstring("_value;")
{GT:}             outstring("int "); outswadname(k); outstring("_line;")
{GT:}             outstring("char *"); outswadname(k); outstring("_file;")
               %repeat;                  ! FOR ANY MORE NAMES IN NAMELIST
               Q = PP; P = Q
            %repeat;                     ! UNTIL A(Q)=2
         %end; ->CSSEXIT2
!
SW(17):  ->CSSEXIT
!
SW(12):                                  ! '%OWN' (TYPE)(OWNDEC)
         %begin
!***********************************************************************
!*       INITIALISED DECLARATION GO INTO THE GLA OR GLA SYMBOL TABLES  *
!*       EXCEPT FOR CONST ARRAYS WHICH GO INTO THE CODE SYMBOL TABLES  *
!*       STRINGS AND ARRAYS HAVE A HEADER IN THE GLA. QPUT ARRANGES    *
!*       FOR THE LOADER TO RELOCATE THE HEADERS.                       *
!*       EXTERNALS ARE IDENTICAL WITH OWN BUT ALSO HAVE A DATA EP DEFN *
!*       IN THE LOAD DATA SO THEY CAN BE FOUND AT LOAD TIME            *
!*       EXTRINSICS HAVE A DATA REFERENCE AND A DUMMY HEADER IN THE GLA*
!*       THE LOADER USES THE FORMER TO RELOCATE THE LATTER.            *
!***********************************************************************
            %routine %spec CLEAR(%integer L)
            %routine %spec XTRACT CONST(%integer CONTYPE,CONPREC)
            %integerfn %spec INIT SPACE(%integer A,B)
            %integer SLENGTH,PP,SIGN,TAGDISP,DVO,K,STALLOC,SPOINT,tp,savep,
               CONSTSFOUND,CPREC,EXTRN,NNAMES,MARK,QPUTP,LB,CTYPE,CONSTP,
               FORMAT,DPTYPE,DIMEN,SACC,TYPEP,KK,orlevel,savesndisp,savekform,II
            %record (RD) COPND,FCOPND
            %own %long %real ZERO=0
            %string (255) SCONST,NAMTXT
            %record (LISTF) %name LCELL
            QPUTP = 5;                  ! NORMAL CASE GLA SYMBOLTABLES
            EXTRN = A(P+1)
            P = P+2
            %if EXTRN>=4 %then EXTRN = 0;  ! CONST & CONSTANT->0
            SNDISP = 0
            CONSTS FOUND = 0
            %if EXTRN=0 %then QPUTP = 4
            CLT
!
! CHECK FOR %spec AND CHANGE EXTERNAL SPEC TO EXTRINSIC
!
            %if A(P+2)=1 %start
               %if EXTRN=2 %then EXTRN = 3 %else FAULT(46,0,0)
            %finish
            %if 2<=EXTRN<=3 %and ((A(P)=1 %and A(P+1)#3) %or (A(P)=2 %and %c
               A(P+1)#2)) %then FAULT(46,0,0)
            %if type=5 %and a(p)#1 %and extrn=0 %then extrn=1
            LITL = EXTRN
            %if LITL<=1 %then LITL = LITL!!1
            %if A(P)=1 %then CQN(P+1) %else ARR = 1 %and NAM = 0
            %if TYPE=5 %and NAM=0 %and (ACC<=0 %or ACC>256) %then %c
               FAULT(70,ACC-1,0) %and ACC = 2
            STALLOC = ACC;               ! ALLOCATION OF STORE FOR ITEM OR%c
                                         POINTER
            %if (TARGET=PERQ %or TARGET=ACCENT %or TARGET=PNX) %and %c
               TYPE=5 %then STALLOC = (STALLOC+1)&X'FFE'
            ROUT = 0; PACK(PTYPE); DPTYPE = PTYPE;  ! FOR DECLARATION
            %if NAM#0 %start;            ! OWN POINTERS
               %if ARR#0 %then STALLOC = 8 %else STALLOC = 4
            %finish %else %start;        ! OWN VARS & ARRAYS
               ->NON SCALAR %if ARR#0
            %finish
            P = P+2
            %until A(MARK)=2 %cycle;     ! UNTIL <RESTOFOWNDEC> NULL
               MARK = P+1+FROM AR2(P+1)
               PP = P+3; P = PP+2;       ! PP ON FIRST NAME'
               K = FROM AR2(PP);         ! FOR ERROR MESSAGES RE CONST
               NAMTXT = STRING(ADDR(WORKA_LETT(WORD(K))))
               %if A(P)=1 %then %start;  ! ALAIS GIVEN
                  %if LITL=0 %then WARN(10,0)
                  LENGTH(NAMTXT) = A(P+1)
                  CHARNO(NAMTXT,KK) = A(P+KK+1) %for KK = 1,1,A(P+1)
                  P = P+A(P+1)+1
                  outstring("#define "); outname(k); outsym(' ')
                  outstring(namtxt); outsym(NL)
               %finish
               P = P+1;                  ! P ON CONST'
!
! OBTAIN THE INITIAL CONSTANT,ITS TYPE(CTYPE) AND SIGN(SIGN)
!
               SCONST = ""
               PTYPE = DPTYPE; UNPACK;   ! MAY HAVE BEEN CONSTANT EVALUATIONS
                                         ! WHICH HAVE CHANGED PTYPE
               SIGN = 3; CTYPE = TYPE; CONSTSFOUND = 0; CPREC = PREC
               %if TYPE=3 %then CTYPE = 1;  ! RECS INITTED TO REPEATED BYTE
               %if NAM#0 %then CTYPE = 1 %and CPREC = 5
               P = P+1
               %if RLEVEL=0 %and EXTRN=0 %start
                  outstring("#define ")
                  outrevisablename(k)
               %else
                  out extern(EXTRN)
                  %if ptype=x'35' %then outstring("char ") %else outtype(ptype&255,kform)
                  %if nam#0 %then outsym('*')
                  outname(k)
               %finish
               %if ptype=x'35' %then %start
                  outstring(" ["); outint(stalloc); outsym(']')
               %finish
               tp=1
               %if A(P-1)=1 %then %start;  ! CONSTANT GIVEN
                  savep=p; p=p-3; tp=tsexp(kk); p=savep
                  %if RLEVEL=0 %and EXTRN=0 %start
                     outstring(" "); outstring("(") %if tp<=0
                  %else
                     outsym('=')
                  %finish
                  XTRACT CONST(CTYPE,CPREC)
               %finish %else %start
                  WARN(7,K) %if EXTRN=0;  ! %const NOT INITIALISED
                  FCOPND = 0; COPND = 0
               %finish
               %if RLEVEL=0 %and EXTRN=0 %start
                 outsym(')') %if tp<=0
               %else
                 outsep
               %finish
               outsym(NL) %unless a(MARK)=2
               PTYPE = DPTYPE; UNPACK;   ! MAY HAVE BEEN CONSTANT EVALUATIONS
                                         ! WHICH HAVE CHANGED PTYPE
               J = 0; orlevel = 0
               %if NAM#0 %then %start;   ! OWNNAMES AND ARRAYNAMES
                  %if ARR=0 %then %start
                     %if (target=ibm %or target=amdahl %or target=ibmxa) %and %c
                        extrn=0 %start
                        tagdisp = worka_const ptr
                        %if type=5 %then ctable(tagdisp)=acc %and %c
                             worka_const ptr=worka_const ptr+1
                        ctable(worka_const ptr) = fcopnd_d
                        worka_const ptr = worka_const ptr+1
                        %if worka_const ptr>worka_const limit %then %c
                           fault(102,worka_wkfilek,0)
                        tagdisp = 4*tagdisp; orlevel = 14
                     %finish %else TAGDISP = PINITOWN(PTYPE,ACC,FCOPND,NAMTXT)
                  %finish %else %start;  ! ARRAYNAMES
!                     DVO = DOPE VECTOR(NO,TYPE,ACC,-1,K,QQ,LB)
                     %if PARM_COMPILER#0 %and LB#0 %then FAULT(99,0,0)
                     %if EXTRN#0 %then SNDISP = 0 %and J = 0 %else %c
                        J = 1 %and SNDISP = (SNDISP&X'3FFFF')>>2
                     TAGDISP = POWNARRAYHEAD(PTYPE,J,LB,X'FFFFFF',COPND_D,0,
                        DVO,NAMTXT)
                  %finish
                  STORE TAG(K,LEVEL,orlevel,J,SNDISP,ACC,TAGDISP,KFORM)
                  P = MARK
                  %continue
               %finish
               %if EXTRN=3 %then %start;  ! EXTRINISIC
!                  PTYPE = PTYPE!X'400';  ! FORCE NAM=1 (IE VIA POINTER)
                  FCOPND_D = 0
                  TAGDISP = PINITOWN(PTYPE,ACC,FCOPND,NAMTXT)
                  STORE TAG(K,LEVEL,0,J,SNDISP,ACC,TAGDISP,KFORM)
                  P = MARK
                  %continue
               %finish
               %if TYPE=3 %then %start;  ! RECORDS
                  TAGDISP = PINITOWN(PTYPE,ACC,FCOPND,NAMTXT)
               %finish
               %if 1<<TYPE&B'100110'#0 %start;  ! INTEGER & REAL & STRING
                  %if EXTRN#0 %then %start
                     TAGDISP = PINITOWN(PTYPE,ACC,FCOPND,NAMTXT)
                  %finish %else TAGDISP = 0
               %finish
               STORE TAG(K,LEVEL,0,J,SNDISP,ACC,TAGDISP,KFORM)
               %if EXTRN=0=NAM %and 1<<TYPE&B'100110'#0 %start
                                         ! CONST = LITERAL
                  LCELL == ASLIST(TAGS(K))
                  lcell_s1=lcell_S1!(copnd_ptype&8)<<16
                  LCELL_S2 = COPND_D
                  LCELL_S3 = COPND_XTRA
                  %if TYPE=5 %then %start
                     LCELL_S2 = WORKA_ARTOP
                     WORKA_ARTOP = (WORKA_ARTOP+COPND_XTRA+4)&(-4)
                  %finish
               %finish
               P = MARK
            %repeat
            ->BEND
NONSCALAR:                               ! OWN AND OWNRECORD ARRAYS
!***********************************************************************
!*       OWN ARRAYS CAN BE INITIALISED BUT ONLY ONE ARRAY CAN BE       *
!*       DECLARED IN A STATEMENT.(THANK HEAVENS!)                      *
!*       OWN RECORD ARRAYS ARE INITIALISED AS BYTE ARRAYS              *
!***********************************************************************
            P = P+1
            FORMAT = 2-A(P)
            %if FORMAT#0 %then arr=3 %and pack(ptype)
            PP = P+2; P = P+4; NNAMES = 1
            K = FROM AR2(PP)
            NAMTXT = STRING(ADDR(WORKA_LETT(WORD(K))))
            %if A(P)=1 %then %start;     ! ALAIS GIVEN
               %if LITL=0 %then WARN(10,0)
               LENGTH(NAMTXT) = A(P+1)
               CHARNO(NAMTXT,KK) = A(P+KK+1) %for KK = 1,1,A(P+1)
               P = P+A(P+1)+1
            %finish
            P = P+1;                     ! P ON CONSTLIST
            SACC = ACC; TYPEP = PTYPE; savekform=kform
            DVO = DOPE VECTOR(NO,TYPE,STALLOC,0,K)
            %if SNDISP=-1 %then SNDISP = 0;  ! BUM DOPE VECTOR
            SNDISP = (SNDISP&X'3FFFF')>>2;  ! AS WORD DISPLACEMENT
            savesndisp=sndisp           { Not proof against C-T concatenation !}
            DIMEN = J;                   ! SAVE NO OF DIMENESIONS
            ACC = SACC; PTYPE = TYPEP; UNPACK
            PP=p
%begin
            %shortinteger savedp, savedp2, savedptype
            %integer i;
            %integer count; count = 0
!GT: This is where arrays are declared.  We want to adjust the base of
!    each array if the lower bound is non-0 so that accesses to the array
!    can use the natural bounds (which in Imp are not forced to start at 0)

! Ideally we would allow static declarations to remain static declarations,
! but this does not work for multi-dimensional arrays so these too will
! come off the heap for now

! Also dynamic arrays simply are not converted correctly at the moment, so
! this code takes care of that too.

! We must plant code at the end of each procedure to free the heap arrays
! Note if we use a mark/release scheme this can be very cheap.

! Remember to initialise if members given, and to initialise to zero otherwise
! (can be done in the allocate heap space procedure)

            %if format=0 %start
               savedptype = ptype&255
               outextern(EXTRN)
               outtype(savedptype,savekform)
               %for ii=dimen,-1,1 %cycle
                 outsym('*') %for i = 1,1,ii
                 outname(k);
                 outsym('_') %and outint(ii) %if ii#dimen
                 outsym(',') %if ii#1
               %repeat
               outsym(';'); outsym(NL)

               outextern(EXTRN)
               outstring("int ");
               %for ii=dimen,-1,1 %cycle
                 outname(k);
                 outstring("_dim_")
                 outint(ii)
                 outsym(',') %if ii#1
               %repeat
               outsym(';'); outsym(NL)

               %for ii=dimen,-1,1 %cycle
                  outname(k);
                  outsym('_') %and outint(ii) %if ii#dimen
                  p=ctable(savesndisp+3*ii+2)
                  savedp = p
                  outstring(" = (")
                  outtype(savedptype,savekform)
                  outsym('*') %for i = 1,1,ii
                  outstring(")malloc(((")
                  csexp(x'51'); outsym(')')
                  %if ctable(savesndisp+3*ii)=x'80000000'%start
                     outsym('-'); p=ctable(savesndisp+3*ii+1)
                     outsym('('); csexp(x'51'); outstring(")+1")
                  %finish %else %if ctable(savesndisp+3*ii)<1 %start
                     outsym('+'); outint(1-ctable(savesndisp+3*ii))
                  %finish %else %if ctable(savesndisp+3*ii)>1 %start
                     outsym('-'); outint(ctable(savesndisp+3*ii)-1)
                  %finish
                  outstring(") * sizeof(");
                  outtype(savedptype,savekform)
                  outsym('*') %for i = 1,1,ii-1
                  outstring(") );"); outsym(NL);

                  %if ctable(savesndisp+3*ii)=x'80000000'%start
                     outname(k);
                     outsym('_') %and outint(ii) %if ii#dimen
                     outstring(" -= ");
                     p=ctable(savesndisp+3*ii+1)
                     csexp(x'51')
                  %finish %else %if ctable(savesndisp+3*ii)#0 %start
                     outname(k);
                     outsym('_') %and outint(ii) %if ii#dimen
                     outstring(" -= ");
                     outint(ctable(savesndisp+3*ii))
                  %finish; ! otherwise based at 0 already

                  outsym(';'); outsym(NL);

                  outstring("for ("); outname(k)
                  outstring("_dim_"); outint(ii);
                  outstring(" = ")

                  %if ctable(savesndisp+3*ii)=x'80000000'%start
                     p=ctable(savesndisp+3*ii+1)
                     csexp(x'51')
                  %finish %else %if ctable(savesndisp+3*ii)#0 %start
                     outint(ctable(savesndisp+3*ii))
                  %finish %else outint(0);

                  outstring("; "); outname(k)
                  outstring("_dim_"); outint(ii);
                  outstring(" <= ")

                  csexp(x'51')
                  outstring("; "); outname(k)
                  outstring("_dim_"); outint(ii);
                  outstring("++) {"); outsym(NL);
               %repeat
               %for ii=1,1,dimen %cycle
                 %if ii#1 %then %start
                   outname(k);outsym('_') %and outint(ii) %if ii#dimen
                   outstring("["); outname(k)
                   outstring("_dim_"); outint(ii);
                   outstring("] = "); outname(k)
                   outsym('_'); outint(ii-1)
                   outstring(";"); outsym(NL)
                 %finish %else %start
                   outstring("/* Assign initialised elements if any */"); outsym(NL)
                 %finish
                 outsym('}'); outsym(NL)
               %repeat

            outsym('{'); outsym(NL); ! for static decl after code!
            outextern(EXTRN)
            outtype(savedptype,savekform)
            outname(k); outstring("_data[] ")


            %finish


            PTYPE = TYPEP; UNPACK
            %if LB=0 %and FORMAT=0 %then ARR = 2 %and PACK(PTYPE)
            %if TYPE=3 %then SLENGTH = QQ %else SLENGTH = QQ//STALLOC
                                         ! NO OF ELEMENTS
            cas(qputp)=(cas(qputp)+arrayrounding)&(\arrayrounding)
            SPOINT = cas(qputp)

            %if FORMAT=0 %then %start
               %if A(PP)=1 %then %start
                 P = PP+1
                 count = INIT SPACE(QQ,SLENGTH)
               %finish
            %finish
            outsep  %if format=0

            %if EXTRN=3 %then SPOINT = 0
!
! OUTPUT AN ARRAYHEAD INTO THE GLA RELATIVE TO THE START OF THE SYMBOL-
! TABLES IN WHICH THE ARRAY RESIDES.
!
            PTYPE = TYPEP; UNPACK
            %if Format#0 %then qputp=0     { avoid data fixup in pownarrayhead}
            TAGDISP = POWNARRAYHEAD(PTYPE,dimen,LB,QQ,SPOINT,QPUTP,DVO,NAMTXT)
            SNDISP=savesndisp
            STORE TAG(K,LEVEL,0,dimen,SNDISP,ACC,TAGDISP,saveKFORM)

            /* if no init declarations, don't do this... */
            outsym(NL);
            outstring("int "); outname(k); outstring("_inels = 0;"); outsym(NL);

            ACC = SACC; PTYPE = TYPEP; UNPACK
            PP=p

            %for ii=dimen,-1,1 %cycle
                  p=ctable(savesndisp+3*ii+2)
                  outstring("for ("); outname(k)
                  outstring("_dim_"); outint(ii);
                  outstring(" = ")

                  savedp = p;

!                  outstring(" /* 1:")
!                  csexp(x'51')
!                  outstring(" */ ")


                  %if ctable(savesndisp+3*ii)=x'80000000'%start
                     p=ctable(savesndisp+3*ii+1)
                     csexp(x'51')
                  %finish %else %if ctable(savesndisp+3*ii)#0 %start
                     outint(ctable(savesndisp+3*ii))
                  %finish %else outint(0);

                  outstring("; "); outname(k)
                  outstring("_dim_"); outint(ii);
                  outstring(" <= ")
                  p = savedp;
                  csexp(x'51')
                  outstring("; "); outname(k)
                  outstring("_dim_"); outint(ii);

                  outstring("++) {"); outsym(NL);

                  outstring("if (")
                  outname(k)
                  outstring("_inels == "); outint(count); outstring(") break;");outsym(NL)


                  %if ctable(savesndisp+3*ii)=x'80000000'%start
                     p=ctable(savesndisp+3*ii+1)
!                     outstring(" /* 2:")
!                     csexp(x'51')
!                     outstring(" */ ")
                  %finish
            %repeat

            outname(k)
            %for ii=dimen,-1,1 %cycle
              outstring("["); outname(k); outstring("_dim_")
              outint(ii)
              outstring("]")
            %repeat
            outstring(" = ")
            outname(k)
            outstring("_data[")
            outname(k)
            outstring("_inels++];"); outsym(NL)
            %for ii=dimen,-1,1 %cycle
                  outstring("}"); outsym(NL);
            %repeat
            outsym('}'); outsym(NL); ! End of static init 

%end; ! of tweak to make arrays based at non-0

            ->BEND
%integerfn INIT SPACE(%integer SIZE,NELS)
!***********************************************************************
!*       P IS TO FIRST ENTRY FOR CONSTLIST                             *
!*    MAP SPACE ONTO WORKFILE END TO GIVE SANE ERROR MESSAGE IF        *
!*    THERE WAS NOT ENOUGH SPACE                                       *
!***********************************************************************
%const %integer BUFSIZE=512
%integer RF,I,II,ELSIZE,AD,SPP,SLENGTH,WRIT,PIN,PP,contype,conprec,ppp,value
%integer nels out
      nels out = 0
      pIN=p; contype=type
      conprec=prec
 outstring(" = {")
      SPP = 0; WRIT = 0
      %until A(P-1)=2 %cycle
         p=p-3; PP=p; skip exp
         %if A(P)=1 %start;     ! REPITITION FACTOR
            P = P+2
            %if A(P-1)=2 %then %start     { * found issue warning }
               RF = 1                     { Except for 0(*) when detectable }
               %unless a(PP+3)=4 %and a(PP+4)=2 %and a(PP+5)=x'41' %andc
                  a(PP+6)=a(PP+7)=0 %and a(PP+8)=2 %then warn(10,0)
            %finish %else %start
               P = P+2
               %if INTEXP(RF,MINAPT)#0 %then warn(10,0) %and RF = 1
            %finish
            P = P+1
         %finish %else RF = 1 %and P = P+2
         nels out = nels out + RF
         warn(10,0) %if RF<=0
          spp=p
         %cycle I = RF,-1,1
            p=pp
            %if contype=5 %then cstrexp(1) %else csexp(conprec<<4!contype)
            consts found=consts found+1
            outsym(',') %unless i=1 %and a(spp-1)=2  { very last const}
         %if (contype=5 %and consts found&3=0) %or consts found&7=0 %c
              %then outsym(NL)
         %repeat
         p=spp
      %repeat
      outstring("}")
      %result = nels out
%end
%routine XTRACT CONST(%integer CONTYPE,CONPREC)
!***********************************************************************
!*       P POINTS TO P<+'> OF <+'><OPERNAD><RESTOFEXPR>  AND IS UPDATED*
!*       THE CONST IS CONVERTED TO REQUIRED FORM AND IF INTEGER        *
!*       IS LEFT IN ICONST, IF REAL IN RCONST AND IF STRING IN SCONST  *
!***********************************************************************
               %integer SLENGTH,STYPE,SACC,MODE,CH,WR,I,PP
               STYPE = PTYPE; SACC = ACC;  ! MAY BE CHANGED IF CONST IS EXPR
               %if CONTYPE=5 %then %start
                  P = P-3; CSTREXP(1)
                  WR = WORKA_ARTOP
                  %if EXPOPND_FLAG=LCONST %and EXPOPND_PTYPE=X'35' %start
                     SLENGTH = EXPOPND_XTRA
                     LENGTH(SCONST) = SLENGTH
                     A(WR) = SLENGTH
                     %for I = 1,1,SLENGTH %cycle
                        CH = A(EXPOPND_D+I)
                        CHARNO(SCONST,I) = CH
                        A(WR+I) = CH
                     %repeat
                     COPND_PTYPE = X'35'; COPND_FLAG = LCONST
                     COPND_D = EXPOPND_D
                     COPND_XTRA = SLENGTH
                  %finish %else %start
                     FAULT(44,CONSTS FOUND,K); SCONST = ""
                     SLENGTH = 0
                  %finish
               %finish %else %start
                  MODE = CONPREC<<4!CONTYPE
                  %if CONPREC<5 %then MODE = CONTYPE!X'50'
                  PP=P; p=p-3; csexp(mode)
                  p=pp; I = CONSTEXP(MODE)   { Evaluate again to get storeable value }
!                  %if CONSTP=0 %then FAULT(41,0,0)
                                         ! CANT EVALUATE EXPT
                  COPND = EXPOPND;       ! GET RESULT OPND
                  COPND_PTYPE = MODE
               %finish
               PTYPE = STYPE; UNPACK; ACC = SACC

               FCOPND = COPND
            %end
BEND:    %end; ->CSSEXIT2
SW(10):
      %begin;                         ! %recordformat (RDECLN)
      %integer NAME,OPHEAD,OPBOT,NLIST,HeadCell,FHEAD,SPEC,l1,l2,strid,fpt
      %record (LISTF) %name LCELL,FRCELL
       %string(255) typename
      SNDISP = 0
      SPEC = A(P+1);               ! 1 FOR SPEC 2 FOR FORMAT
      NAME = FROM AR2(P+2); P = P+4
      COPY TAG(NAME,NO)
      %if SPEC=1 %or %not (PTYPE=4 %and J=15 %and OLDI=LEVEL) %start
         KFORM = 0
         PUSH(KFORM,0,0,0)
         PTYPE = 4
         STORE TAG(NAME,LEVEL,RBASE,15,0,MAXRECSIZE,KFORM,KFORM)
                                   ! IN CASE OF REFS IN FORMAT
      %finish
      %if SPEC=2 %start
         ophead=0; opbot=0; nlist=0
         %for l1=0,1,12 %cycle
           %for l2=0,1,12 %cycle
              rfhead(l1,l2)=0
              rfbot(l1,l2)=0
           %repeat
           rfalt(l1)=0
          %repeat
         INAFORMAT = 1
         rflevel=0
         crformat(rflevel)
         INAFORMAT = 0
         %if PARM_Z#0 %start
            %for l1=0,1,12 %cycle
              %for l2=0,1,12 %cycle
                  %if rfhead(l1,l2)#0 %start
                      printstring("level&rfalt="); write(l1,5); write(l2,5); newline
                      printlist(rfhead(l1,l2))
                  %finish
               %repeat
            %repeat
         %finish
         strid=0;                 { for generating internal names }
        HeadCell=rfhead(0,1)
         %if HeadCell=0 %start      { No alternatives at top level }
            outstring("struct "); outname(name)
            outsym('{'); outsym(NL)
            process format(0,0,'s',0,strid,ophead,opbot)
            fpt=4
         %else
            outstring("union "); outname(name)
            outsym('{'); outsym(NL)
            process format(0,0,'u',0,strid,ophead,opbot)
            fpt=x'14'
         %finish
         outsym('}'); outsym(';'); outsym(NL)
         %if PARM_Z#0 %start
            printstring("after processing")
            printlist(ophead)
         %finish
         %if possible typename(name,typename)#0 %start
            outsym(NL)
            outstring("typedef ")
            %if HeadCell=0 %start      { No alternatives at top level }
               outstring("struct ")
            %else
               outstring("union ")
            %finish
            outname(name)
            outstring(" ".typename.";")
            outsym(NL)
         %finish
         CLEAR LIST(NLIST)
!
! IN CASE OF FORWARD REFS COPY TOP CELL OF FORMAT CHAIN INTO DUMMY
! SET UP BEFORE CALL OF CRFORMAT. ALSO RESET J&ACC TO CORRECT VALUE
           LCELL == ASLIST(TAGS(NAME))
         KFORM = LCELL_KFORM
         %if PARM_Z#0 %start
                printstring("before throwing dummy cell")
                printlist(kform)
         %finish
         POP(KFORM,I,I,FHEAD);     ! THROW DUMMY CELL
                                   ! GET HEAD OF FORWARD REFS
         fhead=ophead
         %while FHEAD>0 %cycle;    ! THROUGH format changeFORWARD REFS
            FRCELL == ASLIST(fhead)
            %if frcell_ptype=x'433' %and frcell_kform=lcell_kform %start
               FRCELL_UIOJ = FRCELL_UIOJ&X'FFFFFFF0';  ! SET J BACK TO 0
               FRCELL_ACC <- ACC;     ! ACC TO CORRECT VALUE
               FRCELL_KFORM = OPHEAD;  ! CORRECT KFORM
            %finish
            fhead=frcell_link
         %repeat
         LCELL_UIOJ = LCELL_UIOJ&X'FFFFFFF0';  ! J BACK TO ZERO
         LCELL_ACC <- ACC
         LCELL_SLINK = name;     ! KFORM&SLINK TO SIDECHAIN & name
         LCELL_PTYPE=fpt        { To distinguish unions from structs }
         LCELL_KFORM = OPHEAD
         %if PARM_Z#0 %start
            printstring("after processing self refs")
            printlist(ophead)
         %finish
      %finish
%end; ->CSSEXIT2
!
SW(19):
                                         ! '*' (UCI) (S)
!         FAULT(57,0,0) %unless LEVEL>=2
        outstring("***Untranslateable stmnt***")
         i=curlinead
         %while i<nextlinead %cycle
            outsym(byteinteger(i))
            i=i+1
         %repeat
         ->CSSEXIT
SW(20):
                                         ! '%TRUSTEDPROGRAM'
         PARM_COMPILER = 1 %if PARM_ARR=0 %and PARM_CHK=0; ->CSSEXIT
SW(21):                                  ! '%MAINEP'(NAME)
         KK = FROM AR2(P+1)
         FAULT(97,0,0) %unless PARM_CPRMODE=0
         MAINEP <- STRING(ADDR(WORKA_LETT(WORD(KK))))
         ->CSSEXIT
         %integer %fn CFORMATREF
!***********************************************************************
!*    P IS TO ALT OF FORMAT REF                                        *
!*    P<FORMTAREF>::=(NAME),(RFDEC)(RESTOFRFDEC)(ALTRFDEC)             *
!*    RETURNS CELL NO OF TOP CELL OF THE FORMATLIST                    *
!***********************************************************************
            %integer FNAM,OPHEAD,OPBOT,NHEAD,MRL
            %record (LISTF) %name LCELL
            %if A(P)=1 %start;           ! A RECORD OF RECORDFORMAT NAME
               FNAM = FROM AR2(P+1)
               P = P+3
               COPY TAG(FNAM,NO)
               %if 3<=TYPE<=4 %then %result = KFORM
               %if INAFORMAT#0 %and OLDI#LEVEL %start
                  PTYPE = 4; ACC = MAXRECSIZE
                  PUSH(KFORM,0,0,0)
                  STORE TAG(FNAM,LEVEL,RBASE,15,0,MAXRECSIZE,KFORM,KFORM)
                  %result = KFORM
               %finish
               FAULT(62,0,FNAM);         ! NOT A RECORD OF FORMAT NAME
               ACC = 8;                  ! GUESS A RECORD SIZE
               %result = DUMMY FORMAT
            %finish
                                         ! FORMAT ACTUALLY SPECIFIED
            P = P+1
            OPHEAD = 0; OPBOT = 0
              outstring("*** imp construction too difficult***")
            %result = OPHEAD
         %end

         %routine CRFORMAT(%integer myrflevel)
!***********************************************************************
!*       CONVERTS A RECORDFORMAT STATEMENT TO A LIST HEADED BY OPHEAD  *
!*       FORMAT OF AN ENTRY.                                           *
!*       S1=SUBNAME<<20!PTYPE<<4!J                                     *
!*       S2,S3=4  16 BIT DISPLACEMENTS  D2,ACC,D1,KFORM                *
!*       NORMALLY D1=RECORD RELATIVE DISPLACEMENT AND ACC=LMAX(STRINGS)*
!*       FOR ARRAYS D2=FIRST ELEMENT DISPLACEMENT AND D1=DISPLACEMENT  *
!*       OF RECORD RELATIVE ARRAYHEAD IN THE GLA                       *
!*       KFORM IS ONLY USED FOR RECORDS AND POINTS TO THE FORMAT       *
!*       ON EXIT ACC HAS THE RECORD SIZE ROUNDED UP TO THE BOUNDARY    *
!*       REQUIRED BY ITS LARGEST COMPONENT                             *
!***********************************************************************
            %integer D1,D2,FORM,RL,STALLOC,INC,Q,R,RFD,LB,TYPEP,SACC,DVO
            %routine %spec SN(%integer Q)
            %routine %spec ROUND
            FORM = 0; ACC = 0
            INC = 0;          ! INC COUNTS DOWN RECORD
            %cycle
               ROUT = 0; LITL = 0; NAM = 0; RFD = A(P)
               P = P+1
               %if RFD=1 %then %start
                  CLT
                  FORM = KFORM
                  STALLOC = ACC
                  P = P+1
                  %if A(P-1)=1 %start
                                         ! (TYPE) (QNAME')(NAMELIST)
                     FORM = KFORM
                     CQN(P); P = P+1
                     PACK(PTYPE); D2 = 0
                     RL = ROUNDING LENGTH(PTYPE,0)
                     %if NAM=1 %then %start
                        STALLOC = PTRSIZE(PREC<<4!TYPE)
                         RL=PTRrounding(ptype&127)
                        %if ARR#0 %then STALLOC = AHEADSIZE %and RL=ROUNDINGLENGTH(AHEADPT,0)
                     %finish
                     fault(70,0,0) %if type=5 %and stalloc=0
                     ROUND; J = 0
                     %until A(P-1)=2 %cycle
                        D1 = 0; SN(P)
                        P = P+3; INC = INC+STALLOC
                     %repeat
                  %finish %else %start
                                         ! (TYPE)%array(NAMELIST)(BPAIR)
                     Q = P+1; ARR = 1; PACK(PTYPE)
                     %cycle
                        P = Q
                        P = P+3 %until A(P-1)=2
                        TYPEP = PTYPE; SACC = ACC
                        D2=dope vector(NO,typep&7,acc,0,fromar2(q))>>2
                                         ! DOPE VECTOR INTO SHAREABLE S.T.
                        ACC = SACC; PTYPE = TYPEP; UNPACK
                        RL = ROUNDING LENGTH(PTYPE&255,0);  ! FOR ELEMENT AS%c
                                                            SCALAR
                        %if RL<ARRAYINREC ROUNDING %then %c
                           RL = ARRAYINREC ROUNDING
                        %cycle
                           ROUND
                           D1 = 0
                           SN(Q);! INC = INC+R
                           Q = Q+3
                        %repeat %until A(Q-1)=2;  ! TILL NAMELIST NULL
                        P = P+1; Q = P+1
                     %repeat %until A(P-1)=2;  ! UNTIL <RESTOFARRAYLIST> NULL
                  %finish
               %finish %else %start
                                         ! (FORMAT)
                  rflevel=rflevel+1
                  binsert(rfhead(myrflevel,rfalt(myrflevel)),rfbot(myrflevel,rfalt(myrflevel)),
                    0,rflevel,0)
                  CRFORMAT(rflevel)
                  INC = ACC
               %finish
               P = P+1
            %repeat %until A(P-1)=2;     ! UNTIL <RESTOFRFDEC> NULL
                                         ! FINISH OFF
            %if A(P)=1 %start;           ! WHILE %or CLAUSES
               P = P+1
                  rfalt(myrflevel)=rfalt(myrflevel)+1
               CRFORMAT(myrflevel)
               %if ACC>INC %then INC = ACC
            %finish %else P = P+1
            ACC = INC;                   ! SIZE ROUNDED APPROPRIATELY
            %return
            %routine SN(%integer Q)
!***********************************************************************
!*       CHECK THE SUBNAME HAS NOT BEEN USED BEFORE IN THIS FORMAT     *
!*       AND ENTER IT WITH ITS DESCRIPTORS INTO THE LIST.              *
!*       CARE IS NEEDED TO MATCH TAG LAYOUT ON BYTE SWOPPED HOSTS      *
!***********************************************************************
               %record (TAGF) CELL
               FNAME = FROM AR2(Q)
               %if aslist(tags(fname))_ptype=x'4051' %then warn(11,0)
               CELL_PTYPE <- PTYPE; CELL_UIOJ <- FNAME<<4!J
               CELL_ACC <- ACC
               CELL_SNDISP <- D2&X'FFFF';  ! IN CASE OF BUM FORMATS
               CELL_SLINK <- D1&X'FFFF';  ! IN CASE OF BUM FORMATS
               CELL_KFORM = FORM
               BINSERT(rfhead(myrflevel,rfalt(myrflevel)),rfbot(myrflevel,rfalt(myrflevel)),
                  CELL_S1,CELL_S2,CELL_S3)
!               %if PTYPE=X'433' %and ACC=MAXRECSIZE %then %c
                  PUSH(ASLIST(FORM)_S3,OPBOT,0,0)
! NOTE FORWARD REFERENCE
            %end
            %routine ROUND
            %end
         %end;                           ! OF ROUTINE CRFORMAT
%routine out fmt cell(%record(listf)%name lcell)
!***********************************************************************
!* print out a single cell of a format list                            *
!***********************************************************************
%integer pt,name,dvdisp,nd,ii
%record(listf)%name fcell
      pt=lcell_s1>>16
      name=lcell_S1>>4&X'FFF'
      %if pt&x'cff'=x'35' %start
         outstring("char "); outname(name)
      %else
         OUT XTYPE(PT&x'cff',lcell_kform)
         outname(name)
      %finish
      %if PT&x'300'#0 %start
         nd=lcell_s1&15
         dvdisp=lcell_sndisp
            %for ii=nd,-1,1 %cycle
               p=ctable(dvdisp+3*ii+2)
               outstring(" [")
               csexp(x'51')
               %if ctable(dvdisp+3*ii)=x'80000000'%start
                  outsym('-'); p=ctable(dvdisp+3*ii+1)
                  outsym('('); csexp(x'51'); outstring(")+1")
               %finish %else %if ctable(dvdisp+3*ii)<1 %start
                  outsym('+'); outint(1-ctable(dvdisp+3*ii))
               %finish %else %if ctable(dvdisp+3*ii)>1 %start
                  outsym('-'); outint(ctable(dvdisp+3*ii)-1)
               %finish
               outsym(']')
            %repeat
      %finish
      %if pt&x'cff'=x'35' %start
         outsym('['); outint(lcell_acc); outsym(']')
      %finish
      outsep
      outsym(NL)
%end
%routine process format(%integer level,alt,structor union,intid,
      %integername strid,ophead,opbot)
!***********************************************************************
!* process one level of the recordformay data structure and call       &
!* itself recursively to handle lower levels. Note C unions cal        &
!* can have only one element in each alternative so imp multi-         &
!* element alternatives have to be coalesced into structures           &
!* this is the main problem                                            &
!***********************************************************************
%record (listf)lcell
%integer i,j,k,newid,lstrid

      %if structorunion='s' %start   { struct only 1 alt }
         %while rfhead(level,alt)#0 %cycle
            pop(rfhead(level,alt),lcell_s1,lcell_s2,lcell_s3)
            %if lcell_s1#0 %start
               out fmt cell(lcell)
               lcell_slink=intid
               binsert(ophead,opbot,lcell_s1,lcell_s2,lcell_s3)
            %else                   { union within struct }
               newid=intid<<4!(lcell_s2{-1}{ union update })
               outstring("union {"); outsym(NL)
               process format(lcell_s2,0,'u',newid,strid,ophead,opbot)
               outstring("} u"); outint(lcell_s2-1)
               outsym(';'); outsym(NL)
            %finish
         %repeat
      %else                          { union with at least 2 alternatives }
         %for i=alt,1,rfalt(level) %cycle
            %if rfhead(level,i)=rfbot(level,i) %start   { only 1 alt }
               pop(rfhead(level,i),lcell_s1,lcell_s2,lcell_s3)
               %if lcell_s1#0 %start
                  out fmt cell(lcell)
                  lcell_slink=intid
                  binsert(ophead,opbot,lcell_s1,lcell_s2,lcell_s3)
               %else                   { union within union }
                  newid=intid<<4!(lcell_s2{-1}{ union update })
                  outstring("union {"); outsym(NL)
                  process format(lcell_s2,0,'u',newid,strid,ophead,opbot)
                  outstring("} u"); outint(lcell_s2-1)
                  outsym(';'); outsym(NL)
               %finish
            %else                 { force in a struct }
               lstrid=strid; strid=strid+1
               newid=intid<<4!8!lstrid
               outstring("struct {"); outsym(NL)
               process format(level,i,'s',newid,strid,ophead,opbot)
               outstring("} s"); outint(lstrid)
               outsym(';'); outsym(NL)
            %finish
        %repeat
      %finish
%end

         %integer %fn DISPLACEMENT(%integer LINK)
!***********************************************************************
!*         SEARCH A FORMAT LIST FOR A SUBNAME                          *
!*      A(P) HAS ENAME--LINK IS HEAD OF RFORMAT LIST. RESULT IS DISP   *
!*      FROM START OF RECORD                                           *
!***********************************************************************
            %record (LISTF) %name FCELL,PCELL,LCELL
            %record (TAGF) TOPND
            %integer RR,II,ENAME,CELL
            ENAME = A(P)<<8+A(P+1); CELL = 0
            %if LINK#0 %then %start;     ! CHK RECORDSPEC NOT OMITTED
               FCELL == ASLIST(LINK);    ! ONTO FIRST CELL
               CELL = LINK; II = -1; ACC = -1
               %while LINK>0 %cycle
                  LCELL == ASLIST(LINK)
                  %if LCELL_UIOJ<<16>>20=ENAME %start;  ! RIGHT SUBNAME LOCATED
                     TCELL = LINK
                     SNDISP = LCELL_SNDISP
                     K = LCELL_SLINK
                     J = LCELL_UIOJ&15; PTYPE = LCELL_PTYPE
                     ACC = LCELL_ACC&X'FFFF'
                     SNDISP = LCELL_SNDISP
                     KFORM = LCELL_KFORM
                     %if LINK#CELL %start;  ! NOT TOP CELL OF FORMAT
                        PCELL_LINK = LCELL_LINK
                        LCELL_LINK = FCELL_LINK
                        FCELL_LINK = LINK
                     %finish;            ! ARRANGING LIST WITH THIS SUBNAME
                                         ! NEXT TO THE TOP
                     %result = K
                  %finish
                  PCELL == LCELL
                  LINK = LCELL_LINK
               %repeat
            %finish
            FAULT(65,0,ENAME)
            %if CELL>0 %then %start
               TOPND_PTYPE = x'51'
               TOPND_UIOJ <- ENAME<<4
               PUSH(ASLIST(CELL)_LINK,TOPND_S1,0,0)
            %finish
            PTYPE = X'51'; TCELL = 0; unpack
            %result = -1
         %end
         %integer %fn COPY RECORD TAG(%integer %name SUBS)
!***********************************************************************
!*       PRODUCE PTYPE ETC FOR A COMPOUND NAME BY CHAINING DOWN ONE    *
!*       ONE OR MORE RECORD FORMAT LISTS. ON EXIT RESULT =0 IF NO      *
!*       SUBNAME FOUND OR SUBNAME IS OF TYPE RECORD WITH NO FURTHER    *
!*       SUBNAME ATTACHED. RESULT#0 IF BONE-FIDE SUBNAME LOCATED       *
!*       ON ENTRY KFORM HAS POINTER TO THE (FIRST ) FORMAT LIST AND    *
!*       P POINTS TO THE A.R. ENTRY FOR (FIRST) ENAME                  *
!***********************************************************************
            %integer Q,FNAME
            SUBS = 0
            %until TYPE#3 %cycle
               FNAME = KFORM
               P = P+2; SKIP APP
               %result = 0 %if A(P)=2 %or FNAME<=0;  ! NO (FURTHER) ENAME
               SUBS = SUBS+1
               P = P+1; Q = DISPLACEMENT(FNAME)
               UNPACK
            %repeat
            %result = Q+1;               ! GIVES 0 IF SUBNAME NOT KNOWN
         %end
%integerfn chk rec align(%integer p1)
!***********************************************************************
!*      Tiddles down chain looking for an integer or larger            *
!*      returns 0 unless at least word aligned                         *
!***********************************************************************
%integer cell,i
%integerfnspec scan(%integer cell)
      p=p1; reduce tag(no);    ! leaves kform set for records
      cell=kform
!        printstring("chk align ".printname(a(p1)<<8!a(p1+1)))
!        write(kform,5); newline
!           printlist(cell)
      %result=scan(cell)
%integerfn scan(%integer cell)
%integer j
      %while cell #0 %cycle
         i=aslist(cell)_ptype>>4&7
         %if i>=5 %then %result=i
         %if aslist(cell)_ptype=x'33' %then %start
            i=scan(aslist(cell)_kform)
          %if i>=5 %then %result=i
         %finish
         cell=aslist(cell)_link
      %repeat
      %result=0
%end
%end { chk rec align }
         %routine CRNAME(%integer Z,MODE,BS,DP, %integer %name NAMEP)
!***********************************************************************
!*       DEAL WITH RECORD ELEMENT NAMES.Z AS FOR CNAME.CLINK=TAGS(RN)  *
!*       MODE=ACCESS FOR RECORD(NOT THE ELEMENT!)                      *
!*       ON EXIT BASE,AREA & DISP POINT TO REQUIRED ELEMENT            *
!*       RECURSIVE CALL IS NEEDED TO DEAL WITH RECORDS IN RECORDS      *
!*       DEPTH SHEWS  RECURSIVE LEVELS- NEEDED TO AVOID MIS SETTING    *
!*       REGISTER IN USE IF RECORDNAME IN RECORD HAS THE SAME NAME AS  *
!*       A GENUINE RECORD NAME.                                        *
!***********************************************************************
            %integer DEPTH,FNAME,EMNAME
            %routine %spec CENAME(%integer MODE,FNAME,BS,DP,XD)
            %record (RD) HDOPND
            HDOPND = 0
            DEPTH = 0
            EMNAME = NAMEP&X'FFFF';      ! ORIGINAL RECORD NAME FOR ERROR%c
                                         MESSES
            FNAME = KFORM;               ! POINTER TO FORMAT
            %if ARR=0 %or (6<=z<=7 %and A(P+2)=2) %start;  ! SIMPLE RECORD
               %if A(P+2)=2 %then P = P+3 %else NO APP
               CENAME(MODE,FNAME,BS,DP,0)
            %finish %else %start
               HDOPND_PTYPE = AHEADPT
               HDOPND_FLAG = LOCALIR
               HDOPND_D = BS<<16!DP
               CANAME(Z,ARR,HDOPND)
               NAMEP = -1
               CENAME(ACCESS,FNAME,BASE,DISP,0)
            %finish; %return
!
%routine CENAME(%integer MODE,FNAME,BS,DP,XD)
!***********************************************************************
!*       FINDS OUT ABOUT SUBNAME AND ACTS ACCORDINGLY.MOSTLY ACTION    *
!*       CONSISTS OF UPPING XD BY OFFSET OF THE SUBNAME BUT IS VERY    *
!*       HAIRY FOR RECORDS IN RECORDS ETC                              *
!*       MODE IS ACCESS FOR THE RECORD                                 *
!***********************************************************************
%routine %spec FETCH RAD
%integer Q,QQ,D,C,TR,ENAME,RPTYPE,EPTYPE
%record (RD) RADOPND,OPND1
%record (LISTF) %name LCELL
               DEPTH = DEPTH+1
              RPTYPE=PTYPE
               %if A(P)=2 %then %start;  ! ENAME MISSING
                  ACCESS = MODE; XDISP = XD
                  BASE = BS; DISP = DP;  ! FOR POINTER
                  %if Z<14 %then %start;  ! NOT A RECORD OPERATION
                     %unless 3<=Z<=4 %or Z=6 %or Z=7 %start;  ! ADDR(RECORD)
                        FAULT(64,0,EMNAME); BASE = RBASE
                        DISP = 0; ACCESS = 0; PTYPE = X'51'
                        UNPACK
                     %finish
                  %finish
                  %return
               %finish
               P = P+1;                  ! FIND OUT ABOUT SUBNAME
               Q = DISPLACEMENT(FNAME);  ! TCELL POINTS TO CELL HOLDING
              EPTYPE=PTYPE;                ! Save ptype of ename
               UNPACK;                   ! INFO ABOUT THE SUBNAME
!               %if Q=-1=ACC %or PTYPE=X'51' %start;  ! WRONG SUBNAME(HAS BEEN%c
!                                                     FAULTED)
!                  P = P+2; SKIP APP; P = P-3
!                  ACCESS = 0; BASE = RBASE; DISP = 0
!                  %return
!               %finish
               ENAME = A(P)<<8!A(P+1)
               NAMEP = ENAME<<16!NAMEP;  ! NAMEP=-1 UNALTERED !
               %if rptype&x'f00'=x'400' %then outstring("->") %else outstring(".")
               outinternames(q)
               outname(ename)
               ->AE %if ARR=1;           ! ARRAYS INCLUDING RECORDARRAYS
               %if A(P+2)=2 %then P = P+3 %else NO APP
               %if TYPE<=2 %or TYPE=5 %or (TYPE=3 %and A(P)=2 %and %c
                  (3<=Z<=4 %or 6<=z<=7)) %start
                  ACCESS = MODE+4+4*NAM; BASE = BS;
                  DISP = DP; XDISP = XD+Q
                  %return
               %finish
!
! NOW CODING BECOMES HAIRY:- STILL LEFT ARE
! A) RECORDS IN RECORDS   Q POINTS TO SECONDARY RECORD
! B) RECORDNAMES IN RECORDS   Q HAS OFF-SET OF A POINTER
! C) RECORDARRAYNAMES IN RECORDS   Q HAS OFF-SET A HEADER IN RECORD
! D) RECORDARRAYS IN RECORDS   NOT YET ALLOWED
!    Q WOULD HAVE OFF-SET OF A RECORD RELATIVE HEADER IN THE GLA
!
               XD = XD+Q
               NAMEP = NAMEP!X'FFFF0000'
               %if NAM=1 %then %start
                  MODE = MODE+4;         ! SO ADDRESS OF POINTER FETCHED
                  FETCH RAD;             ! NEW METHOD IS AS FOR REC FNS
                  EXPOPND = RADOPND;     ! EXPOPND IS ADDRESS TO WHICH POINTER%c
                                         POINTED
                  MODE = 3
                  DP = 0; XD = 0; BS = 0
                  NAMEP = -1
               %finish
               CENAME(MODE,KFORM,BS,DP,XD)
               %return
AE:                                      ! ARRAYS AND ARRAYNAMES AS ELEMEN
               LCELL == ASLIST(TCELL)
               ACC = LCELL_ACC&X'FFFF'; SNDISP = LCELL_SNDISP&X'FFFF'
               KFORM = LCELL_KFORM; K = LCELL_SLINK&x'ffff'
               C = ACC; D = SNDISP; Q = K; QQ = KFORM
               %if (Z=6 %or Z>=11) %and A(P+2)=2 %start;  ! 'GET ARRAYHEAD'%c
                                                          CALL
                  P = P+3
                  %if NAM=1 %then %start
                     ACCESS = MODE+8; BASE = BS
                     DISP = DP; XDISP = XD+Q
                     PTYPE = AHEADPT
                     NAMEOP(6,8,NAMEP);  ! PTR TO HEAD
                     %return
                  %finish
!
! PASSING AN ARRAY IN A RECORD BY NAME MUST CONSTRUCT PROPER ARRAYHEAD
! FROM THE RECORD RELATIVE ONE AT Q(GLA)
!
                  FETCH RAD
                  NAMEP = -1
                  OPND1 = 0
                  OPND1_PTYPE = AHEADPT
                  OPND1_FLAG = LOCALIR
                  OPND1_D = Q
                  NAMEOPND_D = CREATE AH(1,RADOPND,OPND1)
                  NAMEOPND_PTYPE = AHEADPT; NAMEOPND_FLAG = REFTRIP
                  NAMEOPND_XTRA = 0
               %finish %else %start;     ! ARRAY ELEMENTS IN RECORDS
                  %if NAM=1 %then %start;  ! ARRAYNAMES-FULLHEAD IN RECORD
                     XD = XD+Q
                     ACCESS = MODE+8
                     BASE = BS; DISP = DP; XDISP = XD
                     NAMEOP(6,AHEADSIZE,NAMEP)
                     OPND1 = NAMEOPND
                     OPND1_PTYPE = AHEADPT
                     PTYPE = LCELL_PTYPE; UNPACK
                     CANAME(Z,3,OPND1);  ! ARRAY MODE SETS DISP,AREA&BASE
                     XD = 0
                  %finish %else %start;  ! ARRAY RELATIVE HEAD IN GLA
                     FETCH RAD;          ! 32 BIT ADDR TO ETOS
                     OPND1 = 0; OPND1_PTYPE = AHEADPT
                     OPND1_FLAG = LOCALIR
                     OPND1_D = Q
                     CANAME(Z,3,OPND1);  ! RECORD REL ARRAY ACCESS
                                         ! CAN RETURN ACCESS=1 OR 3 ONLY
                      TR =0
!                     TR = BRECTRIP(AAINC,X'51',0,RADOPND,EXPOPND)
                     EXPOPND_FLAG = REFTRIP
                     EXPOPND_D = TR
!                     TRIPLES(TR)_X1 = PTYPE&255;  ! FRIG FOR PERQ&ACCENT 3%c
                                                  WORD BYTE PTRS!
                     XD = 0
                  %finish
                  NAMEP = -1
                  XDISP = XD
                  %if TYPE=3 %then%start
                     CENAME(ACCESS,QQ,BASE,DISP,XD)
                     c=acc;         ! to return element size
                  %else
                        %if Z>=11 %then FAULT(17,0,ENAME)
                  %finish
                                         ! AN ELEMENT IS NOT AN ARRAY FOR P-P
               %finish
               ACC = C;                  ! NEEDED FOR STRING ARRAYS
               %return
%routine FETCH RAD
!***********************************************************************
!*       SET ACC TO 32 BIT ADDRESS OF RECORD.                          *
!***********************************************************************
                  ACCESS = MODE+4
                  BASE = BS
                  DISP = DP; XDISP = XD
               ptype=rptype; unpack
                  NAMEOP(4,4,NAMEP)
                 ptype=eptype; unpack
                  RADOPND = NAMEOPND
               %end
            %end;                        ! OF ROUTINE CENAME
         %end;                           ! OF ROUTINE CRNAME
         %routine CSTREXP(%integer MODE)
!***********************************************************************
!*       PLANT IN-LINE CODE FOR CONCATENATION. A WORK AREA IN THE      *
!*       CURRENT STACK FRAME IS USUALLY REQUIRED.                      *
!*       ON ENTRY:-                                                    *
!*       MODE=0    NORMAL. WK AREA NOT USED FOR ONE OPERAND EXPSSNS    *
!*       MODE=1     STRING MUST GO TO WORK AREA                        *
!*       2**5 BIT OF MODE SET IF FULL VIRTUAL ADDRESS REQUIRED         *
!*       2**4 BIT OF MODE IS SET IF WK-AREA NOT TO BE FREED ON EXIT    *
!*       ON EXIT:-                                                     *
!*       VALUE#0 %if RESULT IN A WORK AREA(CCOND MUST KNOW)            *
!***********************************************************************
            %integer PP,WKAREA,DOTS,ERR,KEEPWA,FNAM,I,ENDFLAG,Firsttrip,trip
            %record (RD) OPND1,OPND2,OPND3
            %integer %fn %spec STROP(%record (RD) %name OPND)
            KEEPWA = MODE&16; MODE = MODE&15
            OPND1 = 0
            OPND1_PTYPE = X'35'
            OPND1_FLAG = LOCALIR
            OPND1_XTRA = 268;            ! THE WORK AREA SIZE NEEDED FOR
            PP = P; STRINGL = 0; FNAM = 0; WKAREA = 0
            P = P+3;                     ! LENGTH OF CONSTANT PART
            ERR = 72; ->ERROR %unless A(P)=4
            P = P+1
            DOTS = 0;                    ! NO OPERATORS YET
            ENDFLAG = 0
            STRINGL = 0
            ERR = STROP(OPND2);          ! GET FIRST OPERAND
            %if STRRESINWA=NO %and PTYPE&X'1000'#0 %then MODE = 1
                                         ! IF FN RESULT NOT IN A WORK AREA
                                         ! COPY IN FROM TOP OF STACK
                                         ! SOMETIMES NOT NECESSARY BUT FN=FN%c
                                         COMPARISONS
                                         ! WILL GO WRONG WITHOUT THIS
            ->ERROR %unless ERR=0
NEXT:       %if A(P)=2 %then ENDFLAG = 1 %else %start
               %if A(P+1)#CONCOP %then ERR = 72 %and ->ERROR
               P = P+2
!
! LEFT TO RIGHT EVALUATION IS DEFINED BUT IF FIRST OPERAND IS ACONST
! WE CAN EVALUATE THE SECOND. THIS ENABLES US TO FOLD "TOSTRING(NL)" ETC
!
               %if DOTS=0 %and OPND2_FLAG=LCONST %then %start
                  ERR = STROP(OPND3)
                  ->ERROR %unless ERR=0
               %finish %else OPND3_FLAG = 255
            %finish
            %if ENDFLAG=0 %and OPND2_FLAG=LCONST=OPND3_FLAG  %and mode=1 %start
!
! CAN FOLD OUT A CONCATENATION HERE
!
               I = CONCAT
               CTOP(I,ERR,0,OPND2,OPND3)
               %if I=0 %then ->NEXT;     ! FOLDED OUR
            %finish
            %if DOTS=0 %start
               %if  ENDFLAG#0 %start;  ! NO RUN-TIME OPERATIONS
                  outopnd(opnd2,0)
                  OPND1 = OPND2; ->TIDY
               %finish
               Firsttrip = BRECTRIP(PRECC,X'35',0,OPND1,OPND2)
               OPND1_FLAG = REFTRIP
               OPND1_D = Firsttrip;              ! CHANGE TO TRIPLES REFERENCE
               DOTS = DOTS + 1
            %finish
            %if ENDFLAG=0 %then %start
               %if OPND3_FLAG=255 %start;  ! 3 NEED EVALUATION
                  ERR = STROP(OPND3)
                  ->ERROR %unless ERR=0
               %finish
               OPND1_D = BRECTRIP(CONCAT,X'35',0,OPND1,OPND3)
               dots = dots +1; ->NEXT
            %finish
!          printtrips(triples)
            outstring("imp_concat(") %for i=2,1,DOTS
            trip=Firsttrip
            %while trip #0 %cycle
               outopnd(Triples(trip)_opnd2,0)
               %if trip=Firsttrip %then outstring(",") %else %start
                  outstring(")")
                  outsym(',') %unless Triples(trip)_puse=0
               %finish
               trip=Triples(trip)_puse
            %repeat
TIDY:                                    ! FINISH OFF
            EXPOPND = OPND1;             ! LEAVE REULT IN EXPOPND
            VALUE = WKAREA
            P = P+1;                     ! PAST REST OF EXPRN
            RETURN WSP(WKAREA,268) %if KEEPWA=0 %and WKAREA>0
            STRINGL = 0
            %return
ERROR:      FAULT(ERR,0,FNAM)
            EXPOPND = OPND1
            BASE = RBASE; DISP = 0
            VALUE = 0; ACCESS = 0
            P = PP; SKIP EXP
            %return
            %integer %fn STROP(%record (RD) %name OPND)
!***********************************************************************
!*       DEALS WITH OPERAND FOR CONCATENATION. RETURN RESULT=0 FOR     *
!*       VALID OPERAND OTHERWISE AN ERROR NUMBER.                      *
!***********************************************************************
               %integer CTYPE,alt,I
               alt  = A(P);              ! ALTERNATIVE OF OPERAND
               OPND = 0
               %result = 75 %if alt >2
               %if alt #1 %then %start
                  CTYPE = A(P+1);        ! GET CONST TYPE & LOSE AMCK FLAGS
                  %if CTYPE=X'35' %then %start
                     PTYPE = CTYPE
                     STRINGL = A(P+2)
                     OPND_PTYPE = CTYPE
                     OPND_FLAG = LCONST
                     OPND_D = P+2
                     OPND_XTRA = STRINGL
                     P = P+STRINGL+3
                  %finish %else %result = 73
               %finish %else %start
                  P = P+1;               ! MUST CHECK FIRST
                  COPYTAG(FROMAR2(P),NO)
                  %if PTYPE=x'1006' %then TYPE = ACC&7;  ! special for "string"
                  %if TYPE=3 %then REDUCE TAG(NO)
                  %if 5#TYPE#7 %then FNAM = FROMAR2(P) %and %result = 71
                  %if ptype=x'4035' %and A(P+2)=2=A(P+3) %and mode#0 %start
                      opnd_flag=lconst; opnd_ptype=x'35'
                      opnd_d=midcell; opnd_xtra=kform
                      stringl=opnd_xtra
                      p=p+4
                      %result=0
                  %finish
                  %if PTYPE=X'35' %and A(P+2)=2=A(P+3) %start
                     OPND_FLAG = DNAME
                     OPND_XTRA = 0
                     OPND_PTYPE <- PTYPE
                     OPND_D = FROMAR2(P)
                     P = P+4
                  %finish %else %start
                     OPND_FLAG = ARNAME
                     OPND_D = P
                     p=p+2; skip app
                     %while a(p)=1 %cycle
                        p=p+3; skip app;
                     %repeat
                     p=p+1
                  %finish
                  STRINGL = 0
               %finish
               %result = 0
            %end;                        ! OF INTEGERFN STROP
         %end;                           ! OF ROUTINE CSTREXP
%routine CRES(%integer LAB)
!**********************************************************************
!*       COMPILES A RESOLUTION E.G A->B.(C).D.(E).F AND JUMPS TO LAB   *
!*       ON FAILURE. (LAB=0 FOR UNCONDITIONAL RESOLUTION TO PERM ON    *
!*       FAILURE ).                                                    *
!*       THE  METHOD IS TO CALL A SUBROUTINE PASSING 5 PARAMS:-        *
!*       P1(32BITS)  POINTS TO LHS(A)                                  *
!*       P2(16BITS) ORIGINAL LENGTH OF A                               *
!*       P3(32BITS) FULL POINTER TO BYTES USED UP INITIALLY 0          *
!*       P4(48BITS) STRING TO CONTAIN FRAGMENT                         *
!*                (PASSED AS LMAX FOLLOWED BY 32BIT ADDRESS)           *
!*       P5(32BITS) THE EXPRESSION PASSED AS 32 BIT ADDRESS            *
!*       SUBROUTINE TRIES TO PERFORM THE RESOLUTION AND SETS THE       *
!*       RESULT TO TRUE IF IT SUCCEEDS.                                *
!*                                                                     *
!*       ON ENTRY LHS IS IN THE ESTACK(32BITS).                        *
!*       P POINTS TO P(+') OF RHS DEFINED AS (+')(OPERAND)(RESTOFEXP)  *
!*                                                                     *
!$       THE ROUTINE IS COMPACT BUT DIFFICULT TO FOLLOW (OR ALTER)     *
!*       THE TIME IN PERM IS LARGE SO IT IS NOT WORTHWHILE TO PERSUE   *
!*       CODE EFFICIENCY TOO INDUSTRIOUSLY .                           *
!**********************************************************************
%integer P1,P2,SEXPRN,W,LAST,ERR,FNAM,JJ
%record (RD) OPND1,OPND2
      LAST = 0; FNAM = 0;          ! =1 WHEN END OF EXPRNSN FOUND
      SEXPRN = 0;                  ! RESOLUTION(BRKTD) EXPRESSNS
      P1 = P
      ERR = 43
      %if NAMEOPND_PTYPE&X'C700'=X'4000' %then %c
         FNAM = NAMEOPND_D %and ->ERROR
                                   !  CANT RESOLVE A CONST STRING
      ERR = 74;                    ! NORMAL CRES FAULT
      GET WSP(W,4);                ! TO HOLD P1,P2 AND VALUE OF P3
      OPND1_PTYPE = X'61'
      OPND1_FLAG = LOCALIR
      OPND1_D = RBASE<<16!W
      P = P+3
      ->RES %if A(P)=4;            ! LHS MUST BE A STRING
                                   ! BUT THIS CHECKED BEFORE CALL
            ERR = 72
ERROR:FAULT(ERR,0,FNAM)
      P = P1; SKIP EXP; %return
RES:  P = P+1;                     !    TO P(OPERAND)
      %if A(P)=3 %then %start;     ! B OMITTED
         OPND2_PTYPE = X'51'
         OPND2_FLAG = SCONST
         OPND2_D = 0;              ! ZERO CONST FOR NO DEST
         outstring("NULL,")
      %finish %else %start
         ->ERROR %unless A(P)=1;   ! P(OPERAND)=NAME
         P = P+1; P2 = P
         CNAME(2)
         outsym(',')
         OPND2 = NAMEOPND
         %if TYPE#5 %then ERR = 71 %and FNAM = FROMAR2(P2) %and ->ERROR
         %if A(P+1)#CONCOP %then ERR = 72 %and ->ERROR
         P = P+2
      %finish
      ->ERROR %unless A(P)=3;      ! P(OPERAND)='('(EXPR)')'
      SEXPRN = SEXPRN+1; P = P+1
      CSTREXP(0);                 ! FULL 32 BIT ADDRESS
      outsym(',')
      OPND2_PTYPE = X'51'; OPND2_FLAG = SCONST
      OPND2_D = LAB
      %if A(P)=2 %then outstring("NULL") %and ->END
      %if A(P+1)#CONCOP %then ERR = 72 %and ->ERROR
      P2 = P+1; P = P2+1
      %if A(P)=3 %then %start
        P = P2
         outstring("_imptempstring)")
         %if lab=0 %then outsym(';') %else outsym('+')
         outstring("imp_resolve(_imptempstring,")
         ->RES
      %finish
      ->ERROR %unless A(P)=1
      P = P+3 %and SKIP APP %until A(P)=2
      %if A(P+1)=1 %then %start
        P = P2
         outstring("_imptempstring)")
         %if lab=0 %then outsym(';') %else outsym('+')
         outstring("imp_resolve(_imptempstring,")
         ->RES
      %finish
      P1 = P+1
      P = P2+2
      CNAME(2)
      P = P1
END:
      P = P+1
%end
         %routine SAVE STACK PTR
!***********************************************************************
!*    SAVE THE CURRENT STACK TOP AND POSSIBLY A DESCRIPTOR TO IT       *
!*    NEEDED ON AUX STACK IMPLEMENTATIONS AND ALSO IN BEGIN-END BLOCKS *
!*    SO ARRAYS CAN BE UNDECLARED ON BLOCK EXIT. ONLY ACTS ON THE FIRST*
!*    CALL IN ANY BLOCK OR ROUITNE                                     *
!***********************************************************************
            %integer JJJ
            %if CURRINF_AUXSBASE=0 %start
               JJJ = UTEMPTRIP(SSPTR,MINAPT,0,N);  ! SAVE THE STACK POINTER
               CURRINF_AUXSBASE = N
               %if TARGET=EMAS %and PARM_STACK=0 %then N = N+16 %else N = N+4
            %finish
         %end
         %routine CEND(%integer KKK)
!***********************************************************************
!*       DEAL WITH ALL OCCURENCES OF '%END'                            *
!*       KKK=PTYPE(>=X'1000') FOR ROUTINES,FNS AND MAPS                *
!*       KKK=0 FOR ENDS OF '%BEGIN' BLOCKS                             *
!*       KKK=1 FOR '%ENDOFPROGRAM'                                     *
!*       %endofprogram IS REALLY TWO ENDS. THE FIRST IS THE USERS      *
!*       AND THE SECOND IS PERMS. KKK=2 FOR A RECURSIVE CALL OF CEND   *
!*       ON END OF PROGRAM TO DEAL WITH THE %end CORRESPONDING TO      *
!*       THE %begin COMPILED IN THE INITIALISATION SEQUENCE            *
!***********************************************************************
            %integer KP,JJ,BIT
            %record (TAGF) %name RCELL,TCELL,PCELL
            %routine %spec DTABLE(%integer LEVEL)
            SET LINE %unless KKK=2
            BIT = 1<<LEVEL
!
! NOW PLANT AN ERROR EXIT FOR FNS AND MAPS - CONTROL SHOULD BE RETURNED
! VIA %result= AN SHOULD NEVVER REACH THE %end INSTRUCTION
!
            %if KKK&X'3FFF'>X'1000' %and PARM_COMPILER=0 %and %c
               LAST INST=0 %then JJ = UCONSTTRIP(RTBAD,X'51',0,0)
                                         ! RUN FAULT 11
            %if KKK=0 %then %start;      ! BEGIN BLOCK EXIT
               %if PARM_TRACE=1 %then %start;  ! RESTORE DIAGS POINTERS
                  JJ = UCONSTTRIP(RDPTR,X'51',0,LEVEL-1)
               %finish
               JJ = CURRINF_AUXSBASE
               %if JJ#0 %then %start;    ! ARRAYS TO BE UNDECLARED
                  JJ = UCONSTTRIP(RSPTR,X'51',0,JJ)
               %finish
            %finish
            FORCE TRIPS;                 ! BEFOR LABEL LIST CLEARED IN OPT MODE
            NMAX = N %if N>NMAX;         ! WORK SPACE POINTER
!
! CLEAR OUT THE LABEL LIST FAULTING LABELS WITH JUMPS OUTSTANDING
! AS NOT SET AND COMMENTING ON LABELS NOT USED
!
            %while CURRINF_LABEL#0 %cycle
               POP(CURRINF_LABEL,I,J,KP)
               %if J&X'FFFF'#0 %then %start
                  J = J&X'FFFF'
                  %if 0<KP<=MAX ULAB %then FAULT(11,ASLIST(J)_S3&X'FFFF',KP)
                  CLEAR LIST(J)
               %finish %else %start
                  %if I&LABUSEDBIT=0 %and KP<MAX ULAB %then WARN(3,KP)
               %finish
            %repeat
!
            NMAX = (NMAX+7)&(-8)
            CURRINF_SNMAX = NMAX
!
! FOR ROUITNE CHECK PARAMETER LIST FOR ARRAY PARAMETERS AND PASS
! BACK ANY INFORMATION ON DIMENSIONALAITY GLEANED DURING THE BODY
!
            JJ = CURRINF_M-1;            ! RT NALE
            %if JJ>=0 %start
               RCELL == ASLIST(TAGS(JJ))
               %if RCELL_PTYPE&X'1000'#0 %start;  ! NAME COULD BE REDECLARED%c
                                                  AS LOCAL
                                         ! IF THIS HAPPENS SKIP GLEANING
                  K = RCELL_SLINK
                  %while K>0 %cycle;     ! DOWN PARAM LIST
                     TCELL == ASLIST(K)
                     %if TCELL_PTYPE&X'F00'=X'500' %and TCELL_UIOJ&15=0 %start
                                         ! TCELL IS ARRAY OF UNKNOWN DIMENSION
                        PCELL == ASLIST(TAGS((TCELL_UIOJ>>4)&4095))
                                         ! ONTO LOCAL TAGS
                        TCELL_UIOJ = TCELL_UIOJ!PCELL_UIOJ&15
                                         ! COPY BACK DIMENSIO
                     %finish
                     K = TCELL_LINK
                  %repeat
               %finish
            %finish
!
! NOW PLANT THE BLOCK EXIT SEQUENCE
!
            %if KKK&X'1000'#0 %then JJ = UCONSTTRIP(RTXIT,X'51',0,KKK)
            JJ = UCONSTTRIP(XSTOP,X'51',0,KKK) %if KKK=1;  ! %stop AT%c
                                                           %endofprogram
            CLEAR LIST(TWSPHEAD);        ! CAN NOT CARRY FORWARD
            %cycle JJ = 0,1,4
               CLEAR LIST(CURRINF_AVL WSP(JJ));  ! RELEASE TEMPORARY LOCATIONS
            %repeat
            %if TARGET=PERQ %or TARGET=ACCENT %then FORCE TRIPS
                                         ! PERQ NEED THIS BEFORE DTABLE AS
                                         ! DTABLE OFFSET GOES IN RTDICT

                                         ! PNX MUST HAVE DATBLE FIRST OR
                                         ! FILLING OF DTABLE REFS FAILS
            DTABLE(LEVEL);               ! OUTPUT DIAGNOSTIC TABLES
            FORCE TRIPS
                                         ! ALL TRIPS MUST BE DEALT WITH
                                         ! BEFORE CURRENT LEVELS ARE CHANGED
            %while CURRINF_UNATT FORMATS#0 %cycle
               POP(CURRINF_UNATT FORMATS,I,J,JJ)
               CLEAR LIST(I)
               CLEAR LIST(J)
               CLEAR LIST(JJ)
            %repeat
!
! NOW CLAIM THE STACK FRAME BY FILING THE ASF IN THE BLOCK ENTRY CODING
!
            %if KKK=2 %then %return
!
! RETURN TO PREVIOUS LEVEL PROVIDED THERE IS A VALID ONE !
!
            %unless LEVEL>2 %or (LEVEL=2 %and PARM_CPRMODE=2) %then %start
               %if KKK=1 %and LEVEL=2 %then KKK = 2 %else FAULT(109,0,0)
                                         ! SHOULD BE CHKD IN PASS1
            %finish
            LEVEL = LEVEL-1
            CURRINF == LEVELINF(LEVEL)
            %if KKK&X'1000'#0 %then %start
               RLEVEL = CURRINF_RBASE
               RBASE = RLEVEL
            %finish
!
! RESTORE INFORMATION ABOUT THE (NEW) CURRENT LEVEL
!
            NMAX = CURRINF_SNMAX %if KKK&X'1000'#0
            N = CURRINF_SN
            %if KKK=2 %then CEND(KKK);   ! ROUND AGAIN FOR 'ENDOFPROGRAM'
!
! COMPLETE THE JUMP AROUND ALL NON-EXTERNAL ROUTINES EXCEPT WHEN
! %trustedprogram IS IN OPERATION.
!
            %if KKK&X'1000'#0 %and PARM_COMPILER=0 %and (RLEVEL>0 %or %c
               PARM_CPRMODE#2) %then %start
               JJ = NEXTP+6
               %unless A(NEXTP+5)=11 %and A(JJ+FROMAR2(JJ))=2 %start
                  JJ = ENTER LAB(CURRINF_JROUND,1)
                  CURRINF_JROUND = 0
               %finish
            %finish
            %return
!
! LAYOUT OF DIAGNOSIC TABLES
! ****** ** ********* ******
!
! THE BOUND FIELD OF PLT DESCRIPTOR STORED AT (LNB+3 & LNB+4) IF
! USED TO CONTAIN A DISPLACEMENT RELATIVE TO THE START OF SST OF THE
! DIAGNOSTIC TABLES FOR THE BLOCK OR ROUTINE BEING EXECUTED.
! A ZERO BOUND MEANS NO DIAGNOSTIC REQUESTED.(NB THIS MAY MEAN A DUMMY
! FIRST WORD IN THE SST).
! THE ABSOLUTE ADDRESS OF THE SST FOR THE CURRENT CODE SEGMENT WILL
! ALWAYS BE FOUND IN THE STANDARD 10 WORDS OF THE GLA/PLT
!
! FORM OF THE TABLES:-
!
! WORD 0    =   LINE OF RT IN SOURCE PROG <<16 ! LINE NO POSN(FROM LNB)
! WORD 1    =   (12 LANG DEPENDENT BITS)<<18 ! ENVIRONMENT
!                ( TOP 2 BITS OF LANG DEPENDENT HAS LITL FROM PTYPE)
!                 ( BOTTOM 4 BITS HAVE TEXTUAL LEVEL)
! WORD 2    =   DISPLAY POSN (FROM LNB)<<16 ! RT TYPE INFO
! WORD 3    =   ZERO FOR BLKS OR STRING(<=11BYTES) BEING THE
!               RT NAME. THIS WILL TAKE WORDS 4 AND 5 IF NEEDED
! WORD 6    =  LANGUAGE DEPENDENT INFO . IMP ON CONDITIONS ETC
!
! THE REST IS MADE UP OF VARIABLE ENTRIES AND THE SECTION IS TERMINATED BY
! A WORD OF X'FFFFFFFF'
!
!  EACH VARIABLE ENTRY CONSISTS OF THE VARIABLE WORD FOLLOWED BY
! THE VARIABLE NAME AS A STRING. THE WORD CONSISTS OF
! BITS 2**31 TO 2**20 TYPE INFORMATION (MAY BE LANGUAGE DEPENDENT
! BIT  2**19  =0 UNDER LNB =1 IN GLA
! BITS 2**18 TO 2**0 DISPLACEMENT FROM LNB(GLA) IN BYTES
!
!
! THE ENVIRONMENT IS A POINTER (RELATIVE TO SST) OF THE NEXT OUTERMOST
! BLOCK OR A POINTER TO GLOBAL OWNS, EXTERNAL OR COMMON AREAS
! A ZERO MEANS NO ENCLOSING BLOCK. WORD1=WORD3=0 IS AN
! IMP MAIN PROGRAM AND WILL TERMINATE THE DIAGNOSTICS.
!
            %routine DTABLE(%integer LEVEL)
!***********************************************************************
!*      THIS ROUTINE LOOKS AT THE DECLARATIONS FOR THE CURRENT LEVEL & *
!*      SETS UP THE SEGMENT OF SHARABLE SYMBOL TABLES TO DESCRIBE THEM.*
!*      FOR MAIN PROGRAMS OR EXTERNAL ROUTINES THE 'GLOBAL' VARIABLES  *
!*      (IF ANY) ARE ALSO INCLUDED.                                    *
!***********************************************************************
%integerfnspec swopof(%integer ptype,value)
%string (11) RT NAME
%string (11) LOCAL NAME
%if 1<<host&unsignedshorts=0 %start
   %record %format HEADF(%short RTLINE,LINEOFF,OFLAGS,ENV,
      DISPLAY,RTFLAGS,(%integer IDHEAD %or %string (11) RTNAME))
   %record %format VARF(%short FLAGS,DISP, %string (11) VNAME)
%finish %else %start
   %record %format HEADF(%half %integer RTLINE,LINEOFF,OFLAGS,
      ENV,DISPLAY,RTFLAGS,
      (%integer IDHEAD %or %string (11) RTNAME))
   %record %format VARF(%half %integer FLAGS,DISP,
      %string (11) VNAME)
%finish
%record (HEADF) %name DHEAD
%record (VARF) %name VAR
%record (LISTF) %name LCELL,scell
%record(swdataform)%name swdata
%const %integer LARRROUT=X'F300'
%record (TAGF) T
%integer DPTR,LNUM,ML,KK,JJ,Q,DEND,BIT,S4,LANGD,RULES,II
%const %integer DLIMIT=700
%integer %array DD(0:DLIMIT);  ! BUFFER FOR SEGMENT OF SST
!
! FILL ALL OUTSTANDING REFERENCES TO THIS DIAGS BLOCK
!
      BIT = 1<<LEVEL
      LANGD = KKK>>14<<30!LEVEL<<18;    ! GET LITL FROM PTYPE
      %if PARM_TRACE=1 %then PDATA(DAREA,4,0,ADDR(DD(0)));    ! TO WORD BOUNDARY
      FILL DTABREFS(CURRINF_RAL)
      PUSH(LEVELINF(LEVEL-1)_RAL,DAREA,CAS(DAREA)+4,LANGD) %if PARM_TRACE#0
      DHEAD == RECORD(ADDR(DD(0)))
      DHEAD_RTLINE <-swopof(X'41', CURRINF_L)
      DHEAD_LINEOFF <-Swop of(x'41', CURRINF_DIAGINF)
      DHEAD_OFLAGS <-Swop of(x'41', LANGD>>16)
      DHEAD_ENV = 0
      %if TARGET=IBM %or TARGET=IBMXA %or TARGET=AMDAHL %then %c
         DHEAD_DISPLAY = CURRINF_RBASE %else %c
         DHEAD_DISPLAY <-Swop of(x'41', CURRINF_DISPLAY)
      DHEAD_RTFLAGS <-Swop of(x'41', CURRINF_FLAG&X'3FFF')
      ML = CURRINF_M;                   ! ROUTINE NAME(=0 FOR %begin)
      %if ML#0 %then ML = WORD(ML-1);   ! IF NOT BLOCK GET DIRPTR
      LNUM = WORKA_LETT(ML);            ! LENGTH OF THE NAME
      DPTR = 4; DEND = 0
      %if LNUM=0 %then DHEAD_IDHEAD = 0 %else %start
         Q = ADDR(WORKA_LETT(ML))
         RT NAME <- STRING(Q);          ! FOR RTS MOVE IN 1ST 32 CHARS
         LNUM = LENGTH(RT NAME)
         DHEAD_RTNAME = RTNAME;         ! AND UPDATE POINTER PAST
!         %if HOST#TARGET %and PARM_TRACE#0 %then %c
!            CHANGE SEX(ADDR(DD(0)),12,LNUM+1)
         DPTR = DPTR+LNUM>>2;           ! ACTUAL NO OF CHARS
      %finish
      DD(DPTR) <-Swop of(X'51',CURRINF_ONWORD);! ON CONDITION WORD
      DPTR = DPTR+1
      JJ = CURRINF_NAMES
      %while 0<=JJ<X'3FFF' %cycle
         LCELL == ASLIST(TAGS(JJ))
         T = LCELL
!     printstring("undeclaring"); printstring(printname(jj)); newline
                                         ! OBTAIN NEXT NAME FORM DECLNS
!
! GET ONLY THE MINIMUM OF DETALS NECESSARY
!
         S4 = LCELL_LINK
         PTYPE = T_PTYPE; TYPE = PTYPE&15
!
! FAULT ALL UNUSED NAMES EXCEPT CONSTINTEGERS&REALS
!
         %if (TYPE>2 %or PTYPE&X'FF00'#X'4000' %or %c
            PARM_STACK#0) %and T_UIOJ&X'C000'=0 %then WARN(2,JJ)
         I = T_UIOJ>>4&15
         J = T_UIOJ&15
         K = T_SLINK
!
! ALLOW OWNS (LITL=0) AND EXTERNALS (=2) NOT CONSTS(=1) OR EXTRINSIC(=3)
!
         %if PARM_DIAG#0 %and PTYPE&X'7300'<=X'200' %and %c
            DPTR<DLIMIT-3 %and (1<=TYPE<=3 %or TYPE=5) %start
            Q = ADDR(WORKA_LETT(WORD(JJ)));  ! ADDRESS OF NAME
            %if I=0 %then II = 1 %else II = 0;! GLA OR LNB BIT
            VAR == RECORD(ADDR(DD(DPTR)))
            VAR_FLAGS <- swopof(X'41',PTYPE<<4!II<<2)
            %if ((PARAMS BWARDS=YES %and k<currinf_display) %or (STACK DOWN=YES %and k>Currinf_display))%c
                  %and PTYPE&X'C00'=0 %and II=0 %and %c
               (TYPE=3 %or TYPE=5) %start;! VALUE RECS&STRS
               %if K<Currinf_display %then rules=2 %else rules=1
                KK=rounding length(ptype,rules)
               K = (K+T_ACC+kk)&(\KK)
            %finish
            VAR_DISP <- swopof(X'41', K)
           %if target=eamd %and I#0 %Then var_disp=k+64;! frig so standard diags work
            LOCAL NAME <- STRING(Q);   ! TEXT OF NAME FROM DICTIONARY
            LNUM = LENGTH(LOCAL NAME)
            VAR_VNAME = LOCAL NAME;     ! MOVE IN NAME
            %if HOST#TARGET %and PARM_TRACE#0 %then %c
               CHANGE SEX(ADDR(DD(0)),4*DPTR+4,LNUM+1)
            DPTR = DPTR+(LNUM+8)>>2
         %finish
         %if J=15 %and PTYPE&X'3000'#0 %and T_UIOJ&X'C000'#0 %then %c
            FAULT(28,0,JJ)
                                         ! SPEC&USED BUT NO BODY GIVEN
         %if J=15 %and TYPE=4 %then FAULT(62,0,JJ)
         %if PTYPE&X'3000'#0  %then %start
!            printstring("clearing list for "); printstring(printname(jj)); newline; printlist(k)
            CLEAR LIST(K)
         %Finish
         %if TYPE=4  %then %start
!            printstring("clearing list for "); printstring(printname(jj)); newline; printlist(t_kform)
            CLEAR LIST(t_kform)
         %Finish
         %if type=6 %start
            scell==aslist(lcell_slink)
            swdata==record(scell_s1)
            outstring("goto "); outswadname(jj); outstring("_skip;"); outsym(NL)
{GT:}  ! NOTE goto t_despatch ... should pass in __LINE__ and __FILE__
       ! rather than allow them to be picked up at point of dispatch
       ! by which time they are meaningless
            outswadname(jj); outstring("_despatch:"); outsym(NL)
            outstring("switch ("); outswadname(jj);
            outstring("_value) {"); outsym(NL)
            %for lnum=0,1,swdata_lseen-1 %cycle
               outstring("case ")
               p=swdata_slabs(lnum); csexp(x'51') { No symbolic consts}
               outstring(": goto "); outswadname(jj)
               outsym('_')
               p=swdata_slabs(lnum); labexp
               outsym(';'); outsym(NL)
            %repeat
            outstring("default:")
            %if swdata_default#0 %then %start
                outstring("goto "); outswadname(jj)
                outstring("_default;")
            %else
{GT:}   ! NOTE: using __LINE__ and __FILE__ from the dispatch table
        ! is not very helpful.  We really want to know where the switch
        ! was jumped to from, at the source of the original ->sw(i)
        ! so I now note the originals into name_file and name_line
        ! at the point of the jump.  I think it's worth the overhead
        ! of the two extra assignments.

        ! NOTE ALSO: I assume the body of BADSWITCH is 
        ! dumped at a %endofprogram - would be better not to,
        ! and to supply it in "imptoc.h" instead
        ! because of problems described elsewhere to
        ! do with limitations of this traslator
        ! (though I haven't yet found where it's dumped so I may be wrong)

                outstring("BADSWITCH("); outswadname(jj);
{GT:}!          outstring("_value,__LINE__,__FILE__);")
                outstring("_value,")
                outswadname(jj); outstring("_line,")
                outswadname(jj);outstring("_file);")
            %finish
            outsym(NL); outsym('}'); outsym(NL)
            outswadname(jj); outstring("_skip:;"); outsym(NL)
            free(addr(swdata))
            kk=t_slink
            clear list(kk)
         %finish
         LCELL_LINK = ASL; ASL = TAGS(JJ)
         TAGS(JJ) = S4&X'3FFFF'
         JJ = S4>>18
      %repeat
      DD(DPTR) = -1;                    ! 'END OF SEGMENT' MARK (Not swopped!)
      DPTR = DPTR<<2+4
      %if PARM_TRACE=1 %then PDATA(DAREA,4,DPTR,ADDR(DD(0)))
                                         ! ADD TO SHARABLE SYM TABS
      %return
%integerfn Swopof(%integer ptype,value)
!***********************************************************************
!*      Does the byte swopping for cross compilers using rt in P4      *
!***********************************************************************
%record(rd)opnd
      %if host#target %then %start
         Opnd=0
         Opnd_d=value
        Opnd_ptype=ptype
         Reformatc(Opnd)
         value=Opnd_d
      %finish
      %result=Value
%end
%end;                        ! OF ROUTINE DTABLE
         %end
%routine DECLARE SCALARS(%integer XTRA)
!***********************************************************************
!*       THIS ROUTINE DECLARES A LIST OF SCALARS FROM INFORMATION      *
!*       IN THE GLOBAL VARIABLES ROUT,NAM,ARR,PREC,TYPE & ACC.IT WORKS *
!*       OUT ROUNDING FACTORS FOR ITSELF.                              *
!*       P POINTS TO THE NAMELIST ON ENTRY AND IS UPDATED.             *
!***********************************************************************
%integer INC,SCAL NAME,RL
      PACK(PTYPE)
      INC = ACC; SNDISP = 0
      RL = ROUNDING LENGTH(PTYPE,1)
      %if NAM#0 %and ARR=0 %then INC = PTRSIZE(PTYPE&127) %and RL=ptrrounding(ptype&127+128)
      %if NAM>0 %and ARR>0 %then INC = AHEADSIZE %and RL=rounding length(aheadpt,1)
      %if PTYPE=X'35' %and (ACC<=0 %or ACC>256) %then %c
         FAULT(70,ACC-1,0) %and ACC = 255
      %if type=5 %start
        outstring("char ")
      %finish %else outtype(ptype&255,xtra)
      %until A(P-1)=2 %cycle;      ! DOWN THE NAMELIST
         N = (N+RL+SFRAME MISALIGN)&(\RL)-SFRAME MISALIGN
         SCAL NAME = FROM AR2(P)
         %if nam#0 %then outstring("*")
         outname(scalname)
         P = P+3
         STORE TAG(SCAL NAME,LEVEL,RBASE,0,SNDISP,ACC,N,XTRA)
         N = N+INC
         %if type=5 %and nam=0 %start
           outstring(" ["); outint(acc);
           outstring("] ")
         %finish
         %if a(p-1)=1 %then outsym(',')
      %repeat
      N = (N+MIN PARAM SIZE-1)&(-MIN PARAM SIZE);  ! THIS IS NECESSARY !
%end
%integer %fn DOPE VECTOR(%integer TAMPER,TYPEP,ELSIZE,MODE,IDEN)
!***********************************************************************
!* Construcst a pseudo dope vector for the handling of arrays          *
!* which is as much like the compiler one as possible. Since           *
!* C arrays all start from 0 but Imp ones can start from anywhere      *
!* provision is needed to take off the lower bound from each index     *
!* on every access.                                                    *
!* The dope vector consists of:-                                       *
!*     word 0 ignored                                                  *
!*     word 1 dimensions<<16 ! element size                            *
!*     word 2 ignored                                                  *
!*     and then a triple for each dimension                            *
!*     word 0 the lower bound if constant                              *
!*     word 1 pointer to the lb expression                             *
!*     word 2 pointer to the ub expression                             *
!*                                                                     *
!* If TAMPER =YES then small +ve lower bounds are reset                *
!* to zero in the interests of access efficiency                       *
!*  IDEN is only for error messages                                    *
!*  Mode not relevant                                                  *
!***********************************************************************
%integer I,JJ,K,ND,D,M0,HEAD,NOPS,TYPEPP,PIN,etype,value
%record (RD) OPND
%record (LISTF) %name LCELL
%integer %array LBH,LBB,LBp,UBp(0:12)
%integer %array DV(0:39);    ! ENOUGH FOR 12 DIMENSIONS
      ND = 0; TYPEPP = 0; PIN = P
      M0 = 1
      %until A(P)=2 %cycle
         ND = ND+1; P = P+1
         LBp(ND)=p; etype=tsexp(value)
         p= LBp(ND)+3
         FAULT(37,0,IDEN) %and ND = 1 %if ND>12
         LBH(ND) = 0; LBB(ND) = 0
         NOPS=0
         TORP(LBH(ND),LBB(ND),NOPS,1)
         UBp(ND)=p
         skip exp
         %if imod(etype)=1 %start
            expop(LBH(ND),LBB(ND),NOPS,x'251')
            lbb(ND)=expopnd_d
         %else
            lbb(ND)=x'80000000'       { Mark as not known }
         %finish
      %repeat
      P = P+1
!
! now tamper with the lower bounds if permitted
!
      %if TAMPER=YES %start
         %cycle D = 1,1,ND
            %if LBB(d)>0 %and LBB(d)*ND<=6 %then LBB(d)=0
         %repeat
      %finish
!
! SET UP THE DOPEVECTOR 
!
      DV(1) = ND<<16!ELSIZE
      %for d=1,1,nd %cycle
         k=3*d
         DV(k)=LBB(d)
         DV(K+1)=LBp(d)
         DV(k+2)=UBp(d)
      %repeat

      K = 3*ND+2
      j = ND;                 ! set dimensionality
      SNDISP = 4*WORKA_CONST PTR
      I = SNDISP
      %cycle D = 0,1,K
         CTABLE(WORKA_CONST PTR) = DV(D)
         WORKA_CONST PTR = WORKA_CONST PTR+1
      %repeat
      %if WORKA_CONST PTR>WORKA_CONST LIMIT %then %c
         FAULT(102,WORKA_WKFILEK,0)
      %result = I
%end

%routine DECLARE ARRAYS(%integer FORMAT,FINF)
!***********************************************************************
!*       FORMAT=1 FOR 'ARRAYFORMAT'   =0 OTHERWISE                     *
!*       FINF>0 FOR RECORD FORMAT INFORMATION =0 OTHERWISE             *
!*       P IS AT P<ADECLN>   IN                                        *
!*                                                                     *
!*       P<ADECLN>=<NAMELIST> <BPAIR> <RESTOFDECLN>                    *
!*       P<BPAIR> = '('<EXPR>':'<EXRR><RESTOFBP>*')'                   *
!*                                                                     *
!*       ARRAYS WITH CONSTANT BOUNDS HAVE THEIR D-V IN THE SST         *
!*       ALL OTHER ARRAYS HAVE A DOPE VECTOR AMONG THE LOCALS AND GET  *
!*       THEIR SPACE OFF THE STACK AT RUN TIME                         *
!*       BOTH SORTS OF ARRAYS HAVE A FOUR WORD HEAD AND D-V TO EMAS    *
!*       SYSTEM STANDARDS                                              *
!***********************************************************************
%integer DVDISP,PP,DVF,ELSIZE,TOTSIZE,PTYPEP,ARRP,NN,ND,II,CDV,
   LWB,PTYPEPP,JJJ,JJ,TRIP1,RL,TOPp,iden
%record (RD) OPND1
      SAVE STACK PTR;              ! FOR LATER UNDECLARING
      ARRP = 2*FORMAT+1; ARR = ARRP; PACK(PTYPEP)
      ELSIZE = ACC
START:NN = 1; P = P+1;             ! NO OF NAMES IN NAMELIST
      PP = P; CDV = 0; PTYPEPP = PTYPEP
      P = P+3 %and NN = NN+1 %while A(P+2)=1
      P = P+3
      DVDISP = DOPE VECTOR(YES,TYPE,ELSIZE,1,FROMAR2(PP))
      TOPP=P
      ND = J
      CDV = 1
      %if LWB=0 %and FORMAT=0 %then PTYPEPP = PTYPEP+256
      SNDISP = SNDISP>>2
      DVDISP=DVDISP>>2
DECL:                                    ! MAKE DECLN - BOTH WAYS
      J = ND
      RL=ROUNDINGLENGTH(AHEADPT,1)
      N = (N+RL)&(\RL);              ! MAY BE BENEFITS IN WORD ALIGNMENT
      %cycle JJJ = 0,1,NN-1;       ! DOWN NAMELIST
         iden = FROM AR2(PP+3*JJJ)
         PTYPE = PTYPEPP; UNPACK
         STORE TAG(iden,LEVEL,RBASE,ND,dvdisp,ELSIZE,N,FINF)
         N = N+AHEADSIZE
         %if format=0 %start
             %if ptypepp&15=5 %then outstring("char ") %else outtype(ptypepp&255,finf)
            outname(iden)
            %for ii=nd,-1,1 %cycle
               p=ctable(dvdisp+3*ii+2)
               outstring(" [")
               csexp(x'51')
               %if ctable(dvdisp+3*ii)=x'80000000'%start
                  outsym('-'); p=ctable(dvdisp+3*ii+1)
                  outsym('('); csexp(x'51'); outstring(")+1")
               %finish %else %if ctable(dvdisp+3*ii)<1 %start
                  outsym('+'); outint(1-ctable(dvdisp+3*ii))
               %finish %else %if ctable(dvdisp+3*ii)>1 %start
                  outsym('-'); outint(ctable(dvdisp+3*ii)-1)
               %finish
               outsym(']')
               %if ptypepp&15=5 %start
                 outstring(" ["); outint(elsize);
                 outstring("] ")
               %finish
            %repeat
            %if jjj#NN-1 %then outsym(';') %and outsym(NL)
         %finish
      %repeat
      P = TOPP+1;                     ! PAST REST OF ARRAYLIST
      %if A(P-1)=2 %then %return
      outsym(';') %and outsym(NL)
      ->start
%end
         %integer %fn ROUNDING LENGTH(%integer PTYPE,RULES)
!***********************************************************************
!*    RULES=0 IN RECORDS(BEST DEFINED)                                 *
!*    RULES=1 IN STACK FRAME(MOST LATITUDE)                            *
!*    RULES=2 AS PARAMETERS(FUNNY HARDWARE CONSIDERATIONS)             *
!***********************************************************************
            %if PTYPE&X'1000'#0 %then %result = PTR ROUNDING(128*RULES)
                                         ! TREAT RT PARAMS AS %name
            %if PTYPE&X'C00'#0 %then %c
               %result = PTR ROUNDING(PTYPE&X'7F'+128*RULES)
            %result = RNDING(PTYPE&X'7F'+128*RULES)
         %end
         %routine CLT
!***********************************************************************
!*       DEAL WITH PHRASE TYPE AND SET PREC,TYPE & ACC                 *
!*       ONLY PROBLEM ARE STRINGS WHICH HAS OPTIONAL MAX LENGTH ALSO   *
!*       RECORD WHICH HAVE A FORMAT                                    *
!*       P ON PHRASE TYPE AT ENTRY - TO NEXT PHRASE AT EXIT.           *
!***********************************************************************
            %integer ALT,PTYPEP,I,FLAGS,SJ
            ALT = A(P)
            FLAGS = TYPEFLAG(ALT)
            %if FLAGS&X'8000'#0 %then %c
               P = P+1 %and FLAGS = TYPEFLAG(A(P)+FLAGS&15)
            %if FLAGS&X'4000'#0 %then P = P+1;  ! ALLOWS BYTE OR BYTEINTEGER%c
                                                ETC
            %if FLAGS&X'2000'#0 %then WARN(8,0);  ! SUBSTITUTION MADE
            %if FLAGS&X'1000'#0 %then FAULT(99,0,0)
            PREC = FLAGS>>4&15
            TYPE = FLAGS&7
            P = P+1
            ACC = BYTES(PREC)
            PACK(PTYPEP);                ! PRESERVE ALL COMPONENT
                                         ! BEFORE CALLINT INTEXP ETC
            %if TYPE=5 %then %start;     ! P<TYPE>='%STRING'
               %if A(P)=1 %then %start;  ! MAX LENGTH GIVEN
                  %if A(P+1)=1 %start;   ! EXPRESSION NOT STAR
                     P = P+4
                     %if INTEXP(I,MINAPT)#0 %then FAULT(41,0,0) %and i=255
                     FAULT(70,I,0) %unless 1<=I<=255
                     ACC = I+1
                     PTYPE = PTYPEP; UNPACK
                  %finish %else ACC = 0 %and P = P+2
               %finish %else ACC = 0 %and P = P+1
            %finish
            KFORM = 0
            %if TYPE=3 %then %start
               SJ = J
               KFORM = CFORMATREF
               PTYPE = PTYPEP
               UNPACK
               J = SJ
            %finish
         %end
         %routine CQN(%integer P)
!***********************************************************************
!*       SET NAM & ARR FROM ALTERNATIVE OF PHRASE <QNAME'>             *
!*       P<QNAME'>='%arrayname','%name',<%NULL>                        *
!*       P POINTS TO THE ANALYSIS RECORD ENTRY AS IS NOT UPDATED       *
!***********************************************************************
            %integer I
            I = A(P); NAM = 0; ARR = 0
            %if I=1 %then ARR = 1;       ! ARRAYNAMES
            %if I<=2 %then NAM = 1;      ! ARRAYNAMES & NAMES
         %end

%routine CRSPEC(%integer M)
!***********************************************************************
!*    MODE=0  FOR NORMAL ROUTINE SPEC                                  *
!*    MODE=1 FOR EXTERNAL(ETC) ROUTINE SPECS XREF NEEDED               *
!*    P ON ENTRY TO P(RT) IN (RT)(MARK)(%spec')(NAME)(FPP)             *
!***********************************************************************
%integer KK,JJ,TYPEP,OPHEAD,NPARMS,AXNAME,SACC,SKFORM,PCHKWORD,pcount
%record(listf) %name lcell
%string(255) ss
      LITL = EXTRN&3
      ACC = 0; KFORM = 0;          ! FOR NORMAL RTS-CLT WILL REVISE
      %if A(P)=1 %then %start;     ! P<RT>=%routine
         TYPEP = LITL<<14!X'1000'
         P = P+4;                  ! IGNORING ALT OF P(SPEC') and hole
      %finish %else %start;        ! P<RT>=<TYPE><FNORMAP>
         ROUT = 1; ARR = 0; P = P+1
         CLT; NAM = 0
         %if A(P)=2 %then NAM = 2;  ! 2 FOR MAP 0 FOR FN
         PACK(TYPEP)
         P = P+4;                  ! AGAIN IGNORING ALT OF P(SPEC') and hole
      %finish
      KK = FROM AR2(P)
      AXNAME = ADDR(WORKA_LETT(WORD(KK)))
      JJ = 0
      P = P+3
      SACC = ACC; SKFORM = KFORM;  ! FOR RECORD MAPS WITH PARAMS
      %if A(P-1)=1 %then %start
         %if LITL=0 %then WARN(10,0)
         MOVE BYTES(A(P)+1,ADDR(A(0)),P,ADDR(A(0)),WORKA_ARTOP)
         outstring("#define "); outstring(string(axname))
         AXNAME = ADDR(A(WORKA_ARTOP))
         outsym(' ')
         %if string(axname)="s_cstring" %then outstring("s__cstring") %else outstring(string(axname))
          outsym(NL)
         WORKA_ARTOP = (WORKA_ARTOP+4+A(P))&(-4)
         P = P+A(P)+1
      %finish
      CFPLIST(OPHEAD,NPARMS)
      PCHKWORD = 0
      ss=string(axname)             { symbol table vsn of name }
      %if 0<=m<=1 %start
         %unless typep&x'c000'#0 %andc
             (ss="malloc" %or ss="free" %or ss="realloc" %or ss="perror" %orc
              ss="getcwd"  %or ss="strlen") %c
             %then %start
!            %if typep&x'c000'=0 %then outstring("static ")
            %if typep&x'c000'=x'8000' %then outstring("extern ")
            outtype(typep&255,skform)
            %if typep&x'800'#0 %and typep&7#5 %then outsym('*')
            outname(kk); outsym('('); outsym(' ')
            lcell==aslist(ophead)
            %if nparms=0 %then outstring("void ") %else %start
               %for pcount=1,1,nparms %cycle
                  %if lcell_s1&x'10000000'#0 %start
{GT: Unfixed bug.  Type parameter i 0 in an externalspec }
{    and shows up as  extern void itos(void, void)       }
{    instead of       extern void itos(int, int)         } 
                     outtype(lcell_s1>>16&255,lcell_sndisp); outstring("()")
                  %else
                     outxtype(lcell_s1>>16,lcell_sndisp)
                  %finish
                  %if lcell_link#0 %then outsym(',')
                  lcell==aslist(lcell_link)
               %repeat
            %finish
            outstring(");")
         %finish
      %finish
      %if NPARMS>0 %then PCHKWORD = NPARMS<<16!ASLIST(OPHEAD)_S3>>16
      %if M=1 %then %start
         %if TARGET=EMAS %or TARGET=PNX %or TARGET=IBM %or %c
            TARGET=IBMXA %or target=amdahl %or %c
            1<<target&emachine#0 %then %c
            CXREF(STRING(AXNAME),3*PARM_DYNAMIC!EXTRN,PCHKWORD,JJ)
                                   ! %system & %external =STATIC
                                   ! UNLESS PARM DYNAMIC SET
                                   ! %dynamic = DYNAMIC
         %if TARGET=PERQ %or TARGET=ACCENT %then %c
            JJ = AXNAME-ADDR(A(WORKA_DICTBASE))
      %finish %else %start
         %if TARGET=PERQ %or TARGET=ACCENT %then %c
            JJ = WORKA_RTCOUNT %and WORKA_RTCOUNT = WORKA_RTCOUNT+1
      %finish
      %if M=0 %and RLEVEL=0 %start
         %if PARM_CPRMODE=0 %then PARM_CPRMODE = 2
         %if PARM_CPRMODE#2 %then FAULT(56,0,KK)
      %finish
      J = 15-M&1; PTYPE = TYPEP
      STORE TAG(KK,LEVEL,RBASE,j,JJ,SACC,OPHEAD,SKFORM)
%end
         %routine CFPLIST(%integer %name OPHEAD,NPARMS)
!***********************************************************************
!*    COMPILE A FORMAL PARAMETER PART INTO A LIST OF PARAMETER TYPES   *
!*    P(FPP)='('{(HOLE)(FPDEL)(NAMELIST)(MARK)}*')',0.                 *
!*                                                                     *
!*    THE LIST OF PARAMETER LOOKS LIKE:-                               *
!*    S1 = PTYPE FOR PARAM<<16!LNAME<<12!DIMENSION(DIMEN DEDUCED LATER)*
!*                                      LNAME IS PARAMS LOCAL NAME     *
!*    S2 = PARAMETER OFFSET(SNDISP) <<16 ! ACC                         *
!*    S3 = 0                                 (RESERVED FOR FPP OF RTS) *
!*                                                                     *
!*    ON ENTRY P IS AT ALT OF FPP (WHICH MAY BE NULL)                  *
!***********************************************************************
            %integer OPBOT,PP,INC,RL,RSIZE,CELL,PSIMPLE
            %record (LISTF) %name LCELL
            OPHEAD = 0; OPBOT = 0
            NPARMS = 0;                  ! ZERO PARAMETERS AS YET
            PSIMPLE = 1;                 ! NO COMPLEX PARAMS YET
            %while A(P)=1 %cycle;        ! WHILE SOME(MORE) FPS
               PP = P+1+FROMAR2(P+1);    ! TO NEXT FPDEL
               P = P+3;                  ! TO ALT OF FPDEL
               CFPDEL;                   ! GET TYPE & ACC FOR NEXT GROUP
               PSIMPLE = 0 %unless %c
                  PTYPE=X'51' %or (ROUT=ARR=0 %and NAM=1 %and 0<TYPE<=3)
               %if rout#0 %Start
                  INC = RT PARAM SIZE
                  RL = ROUNDING LENGTH(RTPARAMPT,2)
               %finish %else %if ARR=1 %then %start
                  INC = AHEADSIZE;
                  RL = ROUNDING LENGTH(AHEADPT,2)
               %finish %else %if NAM=1 %then %start
                  INC = PTRSIZE(PTYPE&X'7F')
                  RL = PTRROUNDING(PTYPE&X'7F'+256)
               %finish %else %if STRVALINWA=YES %and PTYPE=X'35' %then %start
                  INC = PTRSIZE(X'35')
                  RL = PTRROUNDING(256+X'35')
               %finish %else %if RECVALINWA=YES %and PTYPE=X'33' %then %start
                  INC = PTRSIZE(X'33')
                  RL = PTRROUNDING(256+X'33')
              %finish %else %if TARGET=EMAS %and PTYPE=X'33' %then %start
                  INC = ACC+8;           ! ALLOW FOR DESCRPTR FOR IMP80%c
                                         COMPATABILITY
                  RL = 3;                ! STRICTLY ROUNDING LENGTH(X'33',2)
               %finish %else INC = ACC %and RL = ROUNDING LENGTH(PTYPE,2)
               %until A(P-1)=2 %cycle;   ! DOWN <NAMELIST> FOR EACH DEL
                  %if PARAMS BWARDS=YES %then %start
                     PUSH(OPHEAD,0,0,RL)
                     CELL = OPHEAD
                  %finish %else %start
                     BINSERT(OPHEAD,OPBOT,0,0,RL)
                     CELL = OPBOT
                  %finish
                  LCELL == ASLIST(CELL)
                  LCELL_PTYPE <- PTYPE;  ! DIRECT "PUSH" FAILS ON HALF SWOPPED%c
                                         MACHINES
                  LCELL_SNDISP = kform
                  LCELL_ACC <- ACC
                  NPARMS = NPARMS+1
                  P = P+3
               %repeat
               P = PP
            %repeat
            OPBOT = OPHEAD; INC = 0;     ! FURTHER PASS TO ALLOCATE SPACE
!            %while OPBOT>0 %cycle
!               LCELL == ASLIST(OPBOT)
!               RL = LCELL_S3; LCELL_S3 = 0;  ! EXTRACT ROUNDIMG LENGTH
!               RSIZE = LCELL_SNDISP;     ! INC EXTRACTED
!               INC = (INC+RL+SFRAME MISALIGN)&(\RL)-SFRAME MISALIGN
!               %if PARAMSBWARDS=NO %and RSIZE<MINPARAMSIZE %and %c
!                  LCELL_PTYPE&7<=2 %then INC = INC+MINPARAMSIZE-RSIZE
!                                         ! MAINTAIN BYTES &SHORTS IN BTM
!                                         ! OF WORDS FOR 2900&IBM ARCHITECTURE
!               LCELL_SNDISP <- INC;      ! THE PARAMETER OFFSET
!               INC = INC+RSIZE
!               OPBOT = LCELL_LINK
!            %repeat
            INC = (INC+RL+SFRAME MISALIGN)&(\RL)-SFRAME MISALIGN
            P = P+1
            PRINT LIST(OPHEAD) %if PARM_Z#0
            PP = INC<<16!NPARMS
            %if (TARGET=IBM %or TARGET=IBMXA %or TARGET=AMDAHL) %then %c
               PP = PP!PSIMPLE<<15
            %if NPARMS>0 %then ASLIST(OPHEAD)_S3 = PP
            PRINTLIST(OPHEAD) %if PARM_Z#0
         %end
         %routine CFPDEL
!***********************************************************************
!*    SET UP PTYPE & ACC FOR A FORMAL PARAMETER DEFINITION             *
!*    P<FPDEL>=<TYPE><%qname'>,                                        *
!*             (RT)(%name')(NAMELIST)(FPP),                            *
!*             '%NAME'.                                                *
!***********************************************************************
            %switch FP(1:3)
            %integer FPALT
            FPALT = A(P); P = P+1
            KFORM = 0; LITL = 0
            ->FP(FPALT)
FP(1):                                   ! (TYPE)(%qname')
            ROUT = 0; CLT
            CQN(P)
            %if TYPE=5 %and NAM=0 %and (ACC<=0 %or ACC>256) %then %c
               FAULT(70,ACC-1,0) %and ACC = 255
            P = P+1
            ->PK
FP(2):                                   ! (RT)(%name')(NAMELIST)(FPP)
            ROUT = 1; NAM = 1
            ARR = 0
            %if A(P)=1 %then %start;     ! RT=%rouitne
               TYPE = 0; PREC = 0
               P = P+2
            %finish %else %start
               P = P+1; CLT;             ! RT=(TYPE)(FM)
               NAM = 1
               %if A(P)=2 %then NAM = 3;  ! 1 FOR FN 3 FOR MAP
               P = P+2;                  ! PAST (%name') WHICH IS IGNORED
            %finish
            ACC = RT PARAM SIZE
            ->PK
FP(3):                                   ! %name
            ACC = PTRSIZE(0); NAM = 1
            ROUT = 0; TYPE = 0
            ARR = 0; PREC = 0
PK:         PACK(PTYPE)
         %end
         %routine RHEAD(%integer RTNAME,AXNAME,Xtra)
!***********************************************************************
!*       COMPILES CODE FOR BLOCK AND ROUTINE ENTRY                     *
!*       RTNAME IS THE RT/FN/MAP NAME (=-1 FOR %begin BLOCKS)          *
!*       XNAME IS THE EXTERNAL NAME (="" FOR INTERNALS&BLOCKS          *
!*       ACTIONS INCLUDE PLANTING JUMPS ROUND RT BODY AND              *
!*       DEFINING EXTERNAL ENTRIES AS WELL AS PLANTING ENTRY CODE      *
!***********************************************************************
            %integer W3,Flags
            %record (LISTF) %name LCELL
            Flags=0
            %if Xtra#0 %then flags=Bstruct
            CURRINF_SNMAX = NMAX; CURRINF_SN = N
            %if RTNAME>=0 %then %start;  ! SECTION FOR ROUTINES
               LCELL == ASLIST(TAGS(RTNAME))
!
! FIRST JUMP ROUND BODY UNLESS AT TOP LEVEL OR IN COMPILER
! OR A JUMP IS ALREADY OUTSTANDING AT THIS LEVEL
! MUST DO THIS HERE BEFORE LEVEL IS CHANGED OR LABEL LIST IS WRONG
!
               %if PARM_COMPILER=0 %and LEVEL>1 %and CURRINF_JROUND=0 %start
                  PLABEL = PLABEL-1
                  CURRINF_JROUND = PLABEL
                  %if JRNDBODIES=YES %then ENTER JUMP(15,PLABEL,0)
               %finish
               RLEVEL = RLEVEL+1; RBASE = RLEVEL
{GT:}!         FAULT(105,0,0) %if RLEVEL>=2  {REMOVING THIS ALLOWS NESTED PROCS}
            %finish
            LEVEL = LEVEL+1
            CURRINF == LEVELINF(LEVEL)
            CURRINF = 0
            CURRINF_RBASE = RBASE
            CURRINF_CLEVEL = LEVEL;      ! SELF POINTER IS NEEDED IN GENERATE
            CURRINF_NAMES = -1
            CURRINF_DIAGINF = LEVELINF(LEVEL-1)_DIAGINF
!            %if target=gould %then currinf_maxpp = levelinf(level-1)_maxpp
            CURRINF_DISPLAY = LEVELINF(LEVEL-1)_DISPLAY
            FAULT(34,0,0) %if LEVEL=MAX LEVELS
            FAULT(105,0,0) %if LEVEL>MAX LEVELS
!
! DEAL WITH EXTERNAL ENTRIES SO THAT THEY COME TO THIS POINT
! IN THE CODE. THE DESCRIPTORS SET UP ARE OF NO INTEREST TO THIS MODULE
! ONLY TO OTHER MODULES SO NO DETAILS OF THEN ARE RECORDED IN TAGS
!
            %if RTNAME<0 %then %start      { For begin blocks  }
               %if axname=0  %start        { not initial begin }
                  currinf_iblkid=internalblockid
                  internalblockid=internalblockid+1   { keep a blk no for switches & labels }
               %finish
               W3 = 0
            %else
               W3 = RTNAME+1
               internalblockid=0
            %finish
            CURRINF_L = LINE; CURRINF_M = W3
            CURRINF_FLAG = PTYPE&X'FFFF';  ! CURRENT BLOCK TYPE MARKER
                                         ! SIGN MUST NOT PROPOGATE
!
! TILL LOADER COPIES GLAP TO GLA MUST CALL A FRIG ROUTINE TO DO
! THIS ESSENTIAL AS SOON AS POSSIBLE IN ANYTHING EXTERNAL
!
            W3 = ULCONSTTRIP(RTHD,X'61',Flags,RTNAME,AXNAME)
         %end
         %routine RDISPLAY(%integer KK)
!***********************************************************************
!*       SET UP OR COPY THE DISPLAY                                    *
!*       SINCE THIS IS IN REGISTERS ON 360 IT IS EASY                  *
!*       ALSO CLAIM STACK SPACE AND SET DIAGNOSTIC POINTERS            *
!***********************************************************************
            %integer TRIPNO
            %if KK>=0 %or LEVEL=2 %start;  ! DISPLAY NEEDED
                                         ! DONE BY THE QCODE CALL
               CURRINF_PSIZE = N-alpha;  ! REMEMBER PARAMETER SIZE FOR RTDICT
               %if 1<<target&riskmc#0 %then N=(N+display rounding)&(\display rounding)
               CURRINF_DISPLAY = N
               %if DISPLAY NEEDED=YES %start
                  N = N+DISPLAY C1*RLEVEL+DISPLAY C0;  ! RESERVE DISPLAY SPACE
               %finish
               TRIPNO = UCONSTTRIP(RDSPY,X'51',0,CURRINF_DISPLAY)
            %finish
!
! IF IN DIAGNOSTIC MODE PLANT CODE TO SAVE THE LINE & ROUTINE NO OF
! THE CALLING ROUTINE AND SET UP THE NEW BLOCK/ROUTINE IDENT NO.
!
            %if PARM_TRACE#0 %start
               %if KK>=0 %or LEVEL=2 %start;  ! ROUTINE NEW AREA NEEDED
                  %if target=vns %then %c
                     currinf_diaginf = currinf_psize+8 %else %start
                     TRIPNO = UCONSTTRIP(RDAREA,X'51',0,N)
                     N = N+4
                     N = N+4 %if 1<<Target & Riskmc#0;! extra word here on risks
                     CURRINF_DIAGINF = N
                     N = N+4
!
! For risk and some others it is better to use words for line & diag pointers
! if half word access is slow.
!
                     %if target=ORN %or 1<<target&riskmc#0 %then N=N+4
                  %finish
               %finish
               TRIPNO = UCONSTTRIP(RDPTR,X'51',0,LEVEL)
            %finish
            OLDLINE = 0
            SET LINE
!
! NORMALLY CODE IS PLANTED HERE TO CHECK PARAMETERS BUT I CANNOT
! SEE HOW TO DO THIS ON PERQ ARCHITECTURE. IT MAY BE IN THE QCODE ANYHOW
!
!
! CLAIM (THE REST OF) THE STACK FRAME
!
            %if KK>=0 %or LEVEL=2 %start
               NMAX = N
            %finish
         %end
         %routine CUI(%integer CODE)
!***********************************************************************
!*       COMPILE AN UNCONDITIONAL INSTRN WHEREEVER IT OCCURS           *
!*       CODE=0 UNCONDITIOALLY,=1 AFTER %then, =2 AFTER %else          *
!***********************************************************************
%integer PT,MARKER,J,LNAME,TYPEP,PRECP,ALT,KK
%record (RD) OPND1
%integer HEAD1,BOT1,NOPS,savepos
%record (RD) RPOP
%record (LISTF) %name LCELL
%record(swdataform)%name swdata
%owninteger depth
%switch SW(1:9)
      depth=depth+1
      %if depth=1 %then savepos=opline_length %and outsym(' ')
      REPORTUI = 0
      ALT = A(P)
      ->SW(ALT)
SW(1):                                   ! (NAME)(APP)(ASSMNT?)
      P = P+1; MARKER = P+FROMAR2(P)
      %if A(MARKER)=1 %then %start
         J = P+2; P = MARKER+2
         ASSIGN(A(MARKER+1),J)
      %finish %else %start
         P = P+2
         CNAME(0)
         P = P+1
      %finish
AUI:  J = A(P); P = P+1
      %if j=1 %start
         %if depth=1 %then opline_l(savepos)='{'
{GT:}    %if opline_l(opline_length-1) # '{' %then outstring("; ")
         CUI(CODE)
        %if depth=1 %then outstring(";}")
      %finish
      depth=depth-1
      %return
SW(2):                                   ! -> (NAME)(APP)
      CURRINF_NMDECS = CURRINF_NMDECS!1
      CURR INST = 1 %if CODE=0
      LNAME = FROM AR2(P+1)
      J = A(P+3); P = P+4
      %if J=2 %then %start;        ! SIMPLE LABEL
         ENTER JUMP(15,LNAME,0)
         REPORTUI = 1
         outstring("goto "); outname(lname)
      %finish %else %start;        ! SWITCH LABELS
         COPY TAG(LNAME,NO)
         %unless OLDI=LEVEL %and TYPE=6 %start
            FAULT(4,0,LNAME); P = P-1; SKIP APP
            %return
         %finish
         outsym('{'); outswadname(lname); outstring("_value=")
         CSEXP(MINAPT)
{GT:}  ! NOTE goto t_despatch ... should pass in __LINE__ and __FILE__
       ! rather than allow them to be picked up at point of dispatch
       ! by which time they are meaningless
{GT:}    outstring("; "); outswadname(lname); outstring("_line = __LINE__")
{GT:}    outstring("; "); outswadname(lname); outstring("_file = __FILE__")
         outstring("; goto "); outswadname(lname)
         outstring("_despatch;}")
         REPORTUI = 1
      %finish
      depth=depth-1
      %return
SW(3):                                   ! RETURN
      FAULT(30,0,0) %unless CURRINF_FLAG&X'3FFF'=X'1000'
      P = P+1
      outstring("return ")
RET:  KK = UCONSTTRIP(RTXIT,X'51',0,0)
      REPORT UI = 1
      CURR INST = 1 %if CODE=0
      depth=depth-1
      %return
SW(4):                                   ! %result(ASSOP)(EXPR)
      outstring("return ")
      PTYPE = CURRINF_FLAG&X'3FFF'; UNPACK
      PT=ptype&255
      OPND1 = 0
      OPND1_PTYPE <- PTYPE; OPND1_FLAG = DNAME
      OPND1_D = CURRINF_M-1
      %if PTYPE>X'1000' %and A(P+1)#3 %then %start;  ! ASSOP #'->'
         %if A(P+1)=1 %and NAM#0 %and A(P+5)=4 %and A(P+6)=1 %start
            P = P+7; TYPEP = TYPE; PRECP = PREC; J = P
            CNAME(4)
            KK = BRECTRIP(MAPRES,PTYPE&255,0,OPND1,NAMEOPND)
            FAULT(81,0,0) %unless A(P)=2; P = P+1
            FAULT(83,CURRINF_M-1,FROMAR2(J)) %unless %c
               TYPEP=TYPE %and PRECP=PREC
            ->RET
         %finish
         %if A(P+1)=2 %and NAM=0 %then %start;  ! ASSOP='='
            P = P+2
            %if TYPE=5 %then %start
               CSTREXP(0);        ! FULL VIRTAD
            %finish %else %if TYPE=3 %start
               ->BAD RES %unless A(P+3)=4 %and A(P+4)=1
               P = P+5
               CNAME(3)
               FAULT(66,0,OPND1_D) %unless TYPE=3
               EXPOPND = NAMEOPND
            %finish %else %start
               %if PREC<4 %then PREC = 4
               CSEXP(PREC<<4!TYPE)
            %finish
            %if PT=X'31' %or PT=X'41' %Start
               kk=urectrip(SHRTN,PT,0,expopnd)
               expopnd_flag=reftrip; expopnd_d=kk
               expopnd_ptype=PT
            %finish
            KK = BRECTRIP(FNRES,PTYPE&255,0,OPND1,EXPOPND)
            ->RET
         %finish
      %finish
      P = P+2
BAD RES:
      FAULT(31,0,0)
      SKIP EXP;                    ! IGNORE SPURIOUS RESULT
      depth=depth-1
      %return
SW(5):                                   ! %monitor (AUI)
! Woud be nice to intercept this at the level above and translate
! %if <cond> %then %monitor
! to
! assert(!(cond))
{GT:} outstring("assert(_IMP_MONITOR_)")
      P = P+1; ->AUI
SW(6):                                   ! %stop
{GT:} outstring("exit(0)"{"imp_stop()"})
!      KK = UCONSTTRIP(XSTOP,X'51',0,0)
      P = P+1
      CURR INST = 1 %if CODE=0
      REPORTUI = 1
      depth=depth-1
      %return
SW(7):                                   !'%SIGNAL'(EVENT')(N)(OPEXPR)
      P = P+5
      KK = INTEXP(J,MINAPT);       ! EVENT NO TO J
      %if A(P)=1 %start;           ! SUBEVENT SPECIFIED
               P = P+3;  skip exp
      %finish
      outstring("*** IMP signals untranslateable *****")
      depth=depth-1
      %return
SW(8):                                   ! %exit
      outstring(" break ")
      REPORTUI = 1
      CURR INST = 1 %if CODE=0
      depth=depth-1
      %return
SW(9):                                   ! %continue
      REPORTUI = 1
      CURR INST = 1 %if CODE=0
      outstring(" continue ")
      depth=depth-1
      %return
         %end
         %routine CIFTHEN(%integer MARKIU,MARKC,MARKUI,MARKE,MARKR,Afterelse)
!***********************************************************************
!*    THIS ROUTINE COMPILES CONDITIONAL EXPRESSIONS.IT REQUIRES THE    *
!*    FOLLOWING PARAMETERS TO BE SET TO THEIR A .R. ENTRY.             *
!*    MARKIU TO THE ENTRY FOR P(%iu)                                   *
!*    MARKC  TO THE ENTRY FOR P(COND)                                  *
!*    MARKUI TO THE ENTRY FOR (FIRST OCCURRENCE OF)  P(UI)             *
!*    MARKE  TO THE ENTRY FOR P(ELSE')  - =0 FOR BACKWARDS CONDITION   *
!*    MARKR  TO ENTRY FOR P(RESTOFIU)   - =0 FOR BACKWARDS CONDITION   *
!***********************************************************************
%integer ALTUI,CCRES,ELRES,THENLAB,ELSELAB,USERLAB,REPORT,START,
   ELSEALT,K,J,CS,LINETRIP,ctype
%const %integer NULL ELSE=4
%switch ESW(1:NULL ELSE)
%owninteger depth=0
            depth=depth+1
            LINETRIP = -1
            SET LINE %and LINETRIP = TRIPLES(0)_BLINK
            MARKIU = A(MARKIU);          ! ALT OF IU 1=%if,2=%unless
            PLABEL = PLABEL-1
            THENLAB = PLABEL
            START = 0; CS = 0;           ! NO START IN CONDITION YET
            CS = 1 %if STARSIZE>100;     ! LONG JUMPS FOR COMPLEX STMTS
            ELSELAB = 0;                 ! MEANS NO ELSE CLAUSE
            P = MARKC
            %if MARKR>0 %and A(MARKR)<=2 %then %c
               START = 1
! '%START' OR '%THENSTART'
!            %if MARKE#0 %and LEVEL<2 %and START=0 %then FAULT(57,0,0)
            USERLAB = -1
            %if START#0 %then ALTUI = 0 %else ALTUI = A(MARKUI)
            %if ALTUI=2 %and A(MARKUI+3)=2 %then USERLAB = FROM AR2(MARKUI+1)
                                         ! UI = SIMPLE LABEL
            %if 8<=ALTUI<=9 %and currinf_EXITLAB#0 %start;  ! VALID EXIT
               %if ALTUI=8 %then USERLAB = currinf_EXITLAB %else %c
                  USERLAB = currinf_CONTLAB
            %finish
!
            ctype=rlevel
            %if tcond#0 %then ctype=0
            P = MARKC                   { may be changed by tcond }
            %if ctype=0 %start
                %if Afterelse=NO %then outsym(NL) %and outstring("#if")
            %else
               outstring("if ")
            %finish
            CCRES = CCOND(1,MARKIU,THENLAB,B'11'!!START!!CS)
            %if START#0 %then %start;  ! %then %start
               %if CCRES=0 %start;    ! CONDITIONAL
!                  FAULT(57,0,0) %if LEVEL<2
                  CURRINF_NMDECS = CURRINF_NMDECS!1
               %finish %else %start
                                      ! DELETE LINE NO UPDATE FOR%c
                                      CONDITIONAL STARTR
                                      ! (IT MIGHT CONTAIN M-C CODE!)
                  %if LINE TRIP>0 %then TRIPLES(LINETRIP)_OPERN = NULLT
               %finish
               P = MARKR+1
               %If ctype#0 %then  curly check(1) %and outsym('{'); outsym(NL)
               CSTART(CCRES,1)
               %If ctype#0 %then outstring("}");! outstring(" /* if clause */")
               %if A(P)<=2 %then PLABEL = PLABEL-1 %and ELSELAB = PLABEL
               MARKE = P
               REPORT = LAST INST
            %finish %else %start
               %if CCRES#2 %start
                  %if ctype=0 %then outsym(NL)
                  P = MARKUI; CUI(1)
                  %if MARKE#0 %and a(MARKE)#NULL ELSE %and opline_l(opline_length-1)#'}' %then outsep
                  REPORT = REPORTUI
               %finish %else %start;  ! FIRST UI NEVER EXECUTED
                  REPORT = 1
               %finish
            %finish
ELSE:                                    ! ELSE PART
            %if MARKE=0 %then ELSEALT = NULL ELSE %else ELSEALT = A(MARKE)
            %if ELSEALT<NULL ELSE %then PLABEL = PLABEL-1 %and ELSELAB = PLABEL
            P = MARKE+1
                                         ! CONDITIONAL&MERGE OR REPLACE
            ->ESW(ELSEALT)
ESW(1):                                  ! '%ELSESTART'
            %if ctype=0 %start
               outsym(NL); outstring("#else"); curly check(1); outsym(NL)
            %else
               outstring(" else {"); curly check(1);  outsym(NL)
             %finish
            %if CCRES=0 %then CURRINF_NMDECS = CURRINF_NMDECS!1
            CSTART(CCRES,2)
            %If ctype#0 %then outstring("}"); ! outstring(" /* else clause*/")
            %if ctype=0 %start
               outsym(NL); outstring("#endif")
            %finish
            ->ENTER ELSELAB
ESW(2):                                  ! '%ELSE' (%iu) ETC
            MARKE = 0; MARKUI = 0
            MARKR = P+1+FROMAR2(P+1)
            %if A(MARKR)=3 %then %start
               MARKE = MARKR+1+FROM AR2(MARKR+1)
               MARKUI = MARKR+3
            %finish
            J = NEXT TRIP
            %if ctype=0 %start
               outsym(NL); outstring("#else"); outsym(NL)
               CIFTHEN(P,P+3,MARKUI,MARKE,MARKR,no)
               outsym(NL); outstring("#endif")
            %else
               outstring(" else ");       ! outsym('{')
               CIFTHEN(P,P+3,MARKUI,MARKE,MARKR,NO)
               outsym(NL);                !  outsym('}')
            %finish
            REPORT = 0;                  ! CANT TELL IN GENERAL
            ->ENTER ELSELAB
ESW(3):                                  ! '%ELSE'<UI>
             %if ctype=0 %start
               outsym(nl); outstring("#else"); outsym(NL)
           %else
               outstring(" else ")
           %finish
            %if CCRES#1 %then %start
               %if START#0 %then SET LINE;  ! FOR CORRECT LINE IF FAILS IN UI
               %if THENLAB=0 %then K = 0 %else K = 2
               CUI(K)
               REPORT = REPORTUI
               %if ctype=0 %then %start
                  outsep
                  outsym(NL)
                  outstring("#endif")
               %else
                  %if depth>1 %then outsep
               %finish
            %finish
ENTER ELSELAB:
            %if ELSELAB>0 %then ELRES = ENTER LAB(ELSELAB,B'11'!REPORT<<2)
      depth=depth-1; %return
                                         ! CONDITIONAL MERGE
ESW(NULL ELSE):                          ! NULL ELSE CLAUSE
           %if ctype=0 %start
               outsep %if start=0
               outsym(NL); outstring("#endif")
           %finish
         depth=depth-1; 
         %end
         %routine CSTART(%integer CCRES,CODE)
!***********************************************************************
!*    COMPILE A COMPLETE START-FINISH BLOCK BY RECURSION               *
!*    IF START NEVER EXECUTED SKIP TO CORRESPONDING FINISH             *
!*    CODE=0 WAS UNCONDITIONAL NOW SHOULD BE UNUSED                    *
!*    CODE=1 AFTER THEN                                                *
!*    CODE=2 AFTER ELSE                                                *
!*    CODE=3 AFTER ONEVENT                                             *
!*    P ON ENTRY TO FORWARD POINTER TO THE RIGHT FINISH                *
!*    P ON EXIT TO THE ELSE CLAUSE AFTER THE RIGHT FINISH              *
!***********************************************************************
%integer SKIPCODE,FINISHAR,OLDNEXTP,OLDLINE
{GT:}%if CODE=3 %then outstring("/* beginning of onevent block */") %and outsym(NL)
      SKIPCODE = NO
      %if 1<=CODE<=2 %and CCRES!CODE=3 %then SKIPCODE = YES
                                   ! NEVER EXECUTED
      FINISHAR = FROMAR4(P);       ! TO START OF AR FOR FINISH
      OLDLINE = LINE;              ! FOR ERROR MESSAGES
      %cycle;                      ! THROUGH INTERVENING STATMNTS
         OLDNEXTP = NEXTP
         COMPILE A STMNT
      %repeat %until OLDNEXTP>=FINISHAR;  ! HAVING COMPILED FINISH
{GT:}%if CODE=3 %then outstring("/* end of onevent block */") %and outsym(NL)

      P = FINISHAR+10;              ! TO ELSE CLAUSE
!
      %if A(P)<=3 %and CODE#1 %then FAULT(45+CODE,OLDLINE,0)

      %if SKIPCODE=YES %then LAST INST = 1
%end
         %routine CCYCBODY(%integer UA,ELAB,CLAB)
!***********************************************************************
!*    COMPILES A CYCLE REPEAT BODY BY RECURSION                        *
!*    ON ENTRY P IS TO FORWARD POINTER. ON EXIT TO ALT OF UNTIL        *
!*    UA = O IF UNTIL NOT ALLOWED                                      *
!*    ELAB&CLAB ARE LABELS FOR ELSE & CONTINUE                         *
!***********************************************************************
%integer FINISHAR,OLDLINE,SAVEE,SAVEC
      FINISHAR = FROMAR4(P)
      %if FINISHAR<=P %then IMPABORT
      FORDPTH = FORDPTH+1
      OLDLINE = LINE; SAVEE = currinf_EXITLAB; SAVEC = currinf_CONTLAB
      currinf_EXITLAB = ELAB; currinf_CONTLAB = CLAB
      curly check(1)
      outsym('{'); outsym(NL)
      %while NEXTP<=FINISHAR %cycle
         COMPILE A STMNT
      %repeat
      outstring("}"); ! outstring(" /* loop */")
      currinf_EXITLAB = SAVEE; currinf_CONTLAB = SAVEC
      P = FINISHAR+10
      FORDPTH = FORDPTH-1
      %if A(P)=1 %and UA=0 %then FAULT(12,OLDLINE,0)
%end

%routine CLOOP(%integer ALT,MARKC,MARKUI)
!***********************************************************************
!*    ALT=1 FOR %while, =2 FOR %until, =3 FOR %for                     *
!*    MARKC IS TO THE CONDITION OR CONTROL CLAUSE                      *
!*    MARKUI IS TO THE UI, SPECIAL FOR %cycle                          *
!*    FORBITS DEFINES FOR LOOP AS FOLLOWS:-                            *
!*    2**2 TO 2**0 SET FOR CONSTANT INITIAL,INC &FINAL                 *
!*    CORRESPONDING UPPER BYTE SET DEFINES CONSTANT FURTHER            *
!*       2**7 NEGATIVE CONSTANT                                        *
!*       2**4 CONSTANT IS 2                                            *
!*       2**3 CONSTANT IS 1                                            *
!*       2**2 CONSTANT IS 0                                            *
!*       2**1 CONSTANT IS -1                                           *
!*       2**0 CONSTANT IS -2                                           *
!*    THESE BITS ARE PASSED ON TO GENERATOR FOR SPECIAL CASE           *
!***********************************************************************
%integer L1,L2,L3,L4,CCRES,ELRES,FLINE,TRIP,FOT,PP,DEBJ,JJ,FSTRIP
%integer FORNAME,INITP,STEPP,FINALP,REPMASK,FORPT,FORWORDS,FORBITS
%record (RD) INITOPND,STEPOPND,FINALOPND,DIFFOPND,ZOPND,OPND
%record (TRIPF) %name CURRT
%routine %spec FOREXP(%record (RD) %name EOPND, %integer TT,SH)
%switch SW(0:6)
      P = MARKC
      FORBITS = 0
      SFLABEL = SFLABEL-2
      L1 = SFLABEL; L2 = L1+1
!
! SET L3 FOR ALTS 0,5&6 ONLY
!
      L3 = 0
      %if B'1100001'&1<<ALT#0 %then L3 = SFLABEL-1 %and SFLABEL = L3
!
! UPDATE THE LINE NUMBER FOR ALTS 1 TO 3 ONLY
!
            %if 1<=ALT<=3 %then SET LINE
!
! ENTER THE FIRST LABEL FOR ALL ALTS EXCEPT 3 & 6
!
!            %if B'0110111'&1<<ALT#0 %then ELRES = ENTER LAB(L1,0)
      ->SW(ALT)
SW(0):                                   ! %cycle
      PP = FROM AR4(P)+10;          ! TO UNTIL CLAUSE IF ANY
      %if A(PP)=1 %start;          ! %repeat %until <COND>
         outstring("do ")
         C CYC BODY(1,L2,L3)
!         L3 = L3*ENTER LAB(L3,B'011');  ! DELETE IF NOT NEEDED
         SET LINE
         outstring(" while ")
         P = PP+1; CCRES = CCOND(0,2,L1,0)
      %finish %else %start
         outstring("for (;;) ")
         C CYC BODY(1,L2,L1);      ! CONTINUES DIRECT TO TOP
         !outstring(" while (1) /* FOR EVER */")
!         ENTER JUMP(15,L1,0)
      %finish
!      L2 = L2*ENTER LAB(L2,B'011');  ! DELETE IF NOT NEEDED
WAYOUT:                                  ! REMOVE LABELS NOT REQUIRED
      %return
sw(1):                            ! UI while cond
      outstring("while ")
      ccres=ccond(0,1,l2,b'11')
      p=markui
      cui(1)
!      enter jump(15,l1,0)         ! uncoditional back to while
!      L2 = L2*ENTER LAB(L2,B'111');  ! CONDITIONAL(?) & REPLACE ENV
      ->WAYOUT
SW(2):                                   ! UI %until COND
      P = MARKUI
      outstring("do ")
      CUI(1)
      P = MARKC
      outsep; outstring(" while ")
      CCRES = CCOND(0,2,L1,0)
      ->WAYOUT
SW(6):                                   ! %for ... %cycle
SW(3):                                   ! UI %for ....
      FORCNT = FORCNT+1;           ! TO DETCT FORS IN ENCLOSED STMTS
      FORNAME = FROMAR2(P)
      INITP = P+2
      COPY TAG(FORNAME,YES);       ! DECLARE IF UNKNOWN TO COMPILER
      FAULT(91,0,FORNAME) %and ptype=X'51'  %unless %c
         (TYPE=7 %or TYPE=1) %and 4<=PREC<=5 %and ROUT=0=ARR %and LITL#1
      FOT = DNAME;                 ! FOR OPERAND TYPE
      %if NAM#0 %then FOT = INDNAME
      FORPT = PTYPE&255;           ! SAVE TYPE&PREC OF CONTROL
!
      P = INITP
      SKIP EXP;                    ! P TO STEP EXPRSN
      STEPP = P; SKIP EXP;         ! P TO FINAL
      FINALP=p
!
      P = STEPP
      FOR EXP(STEPOPND,1,1);       ! Investigate step and evaluate if constant
      outstring(" for (")
      %if FOT=INDNAME %then outsym('*')
      outname(FORNAME)
      outsym('=')
      P = INITP; csexp(FORPT)
      outsep
      outsym(' ')
      %if FOT=INDNAME %then outsym('*')
      outname(FORNAME)
      %if STEPOPND_FLAG<=1 %start
         FAULT(92,0,0) %if STEPOPND_D=0;  ! ZERO STEP
         %if STEPOPND_D<0 %then outstring(">=") %else outstring("<=")
      %finish %else %start
         outstring("<=")
         warn(10,0)
      %finish
      p=finalp; csexp(FORPT)
      outsep
      outsym(' ')
      %if FOT=INDNAME %then outsym('*')
      outname(FORNAME)
      %if STEPOPND_FLAG<=1 %and iMOD(STEPOPND_D)=1 %start
         %if STEPOPND_D<0 %then outstring("--") %else outstring("++")
      %else
         outstring("+=")
         p=STEPP; csexp(FORPT)
      %finish
      outstring(") ")
!
      P = MARKUI;                  ! TO UI OR '%CYCLE'(HOLE)
      %if ALT=3 %then %start;      ! DEAL WITH CONTROLLED STMNTS
         CUI(0)
      %finish %else %start
         CCYCBODY(0,L2,L3)
         %finish
      ->WAYOUT
SW(4):                                   ! %while COND %cycle
      SET LINE
      outstring("while ")
      CCRES = CCOND(0,1,L2,2);     ! merge but not short
      C CYC BODY(0,L2,L1)
!      ENTER JUMP(15,L1,0)
!      L2 = L2*ENTER LAB(L2,B'111');  ! CONDITIONAL & REPLACE ENV
      ->WAYOUT
SW(5):                                   ! %until ... %cycle
                                         ! ALSO %cycle... %repeat %until
                                         ! MARKUI TO %cycle
      P = MARKUI
      FLINE = LINE
      outstring("do ")
      C CYC BODY(0,L2,L3)
      P = MARKC
!      L3 = L3*ENTER LAB(L3,B'011');  ! CONTINUE LABEL IF NEEDED
      LINE = FLINE; SET LINE
      outsep; outstring(" while ")
      CCRES = CCOND(0,2,L1,0)
!      L2 = L2*ENTER LAB(L2,B'011')
      ->WAYOUT
%routine FOR EXP(%record (RD) %name EOPND, %integer TOTEMP,SHIFT)
!***********************************************************************
!*    P INDEXES EXPRESSION.  IF CONST PUT INTO EVALUE OTHERWISE        *
!*    dont generate anything                                           *
!***********************************************************************
%integer INP,VAL,SUBBITS
%integer exphead,expbot,nops
      exphead=0; expbot=0; nops=0
      INP = P; P = P+3
      torp(exphead,expbot,nops,1)
      %if nops>>16&7=0 %start        { nothing difficult }
         expop(exphead,expbot,nops,x'200'+FORPT)
         EOPND = EXPOPND;       ! EXPRESSION A LITERAL CONST
      %else
         eopnd_flag=255
      %finish
%end
%end
!*
         %routine ASSIGN(%integer ASSOP,P1)
!***********************************************************************
!*       HANDLES ARITHMETIC,STRING & ADDRESS ASSIGNMENTS TO VARIABLES  *
!*       FORMAL PARAMETERS AND DOPEVECTORS                             *
!*       ASSOP:-                                                       *
!*        1 IS FOR '=='                                                *
!*        2 IS FOR '='                                                 *
!*        3 IS FOR '<-' (JAM TRANSFER)                                 *
!*        4 IS FOR '->' (UNCONDITIONAL RESOLUTION)                     *
!*                                                                     *
!*       P POINTS TO THE EXPRESSION. P1 TO THE NAME ON LHS             *
!***********************************************************************
            %integer Q,KK,TYPEP,PRECP,PTYPEP,JJJ,P2,JJ,B,D,HEAD2,BOT2,ACCP,
               II,HEAD1,NOPS,TPCELL,LVL,BOT1,LHNAME,RHNAME,a1,a2
            %record (LISTF) %name LHCELL
            %record (RD) OPND1,OPND2
            %switch SW(0:4);             ! TO SWITCH ON ASSOP
            P2 = P
            LHNAME = A(P1)<<8!A(P1+1)
            LHCELL == ASLIST(TAGS(LHNAME))
            P = P1; REDUCE TAG(NO);      ! LOOK AT LH SIDE
            PTYPEP = PTYPE; JJ = J
            KK = K; II = I; LVL = OLDI
            TPCELL = TCELL; ACCP = ACC
            P = P2; TYPEP = TYPE; PRECP = PREC;  ! SAVE USEFUL INFO FOR LATER
            ->SW(ASSOP)
SW(2):
SW(3):                                   ! ARITHMETIC ASSIGNMENTS
            %if TYPE=3 %then ->RECOP
            TYPE = 1 %unless TYPE=2 %or TYPE=5;  ! IN CASE OF RUBBISHY SUBNAMES
            ->ST %if TYPE=5;             ! LHS IS A STRING
BACK:       HEAD1 = 0; BOT1 = 0;         ! CLEAR TEMPORAYRY LIST HEADS
            HEAD2 = 0; BOT2 = 0
            TYPE = 1 %unless TYPE=2;     ! DEAL WITH UNSET NAMES
            TYPEP = TYPE
            NOPS = 1<<18+1
            PTYPE = PTYPEP; UNPACK
            %if LHSADDRFIRST=NO %or (NAM=0=ARR %and A(P1+2)=2=A(P1+3)) %start
                                         ! SCALAR
               OPND1 = 0
               OPND1_PTYPE <- PTYPE; OPND1_FLAG = ARNAME
               BINSERT(HEAD1,BOT1,OPND1_S1,P1,LHNAME)
            %finish %else %start
               P = P1; CNAME(3);         ! 32 BIT ADDR TO STACK
               BINSERT(HEAD1,BOT1,NAMEOPND_S1,NAMEOPND_D,NAMEOPND_XTRA)
            %finish
            P = P2+3
            TORP(HEAD2,BOT2,NOPS,0);       ! RHS TO REVERSE POLISH
            OPND2 = 0; OPND2_FLAG = VASS+ASSOP-2
            BINSERT(HEAD2,BOT2,OPND2_S1,LHNAME<<16!PTYPEP,0)
                                         ! = OR <-OPERATOR
            ASLIST(BOT1)_LINK = HEAD2
            HEAD2 = 0; BOT1 = BOT2
            PRINT LIST(HEAD1) %if PARM_Z#0
            EXPOP(HEAD1,BOT1,NOPS,256+PRECP<<4+TYPEP);  ! PLANT CODE
         tripopt(triples,triples(0)_flink)
            outopnd(expopnd,0)
            %return
ST:                                      ! STRINGS
            p = p1
            %if assop=3 %then %start
               outstring("imp_strjam(")
               %if nam#0 %then warn(10,0)
            %finish %else outstring("strcpy(")
            CNAME(2)
            outsym(',')
         p = p2
            CSTREXP(0)
            %if assop=3 %then outsym(',') %and outint(accp-1)
            outsym(')')
            %return
!
! THIS SECTION DEALS WITH OPERATIONS ON COMPLETE RECORDS
!
RECOP:                                   ! LHS IS RECORD WITHOUT SUBNAME
            Q = TSEXP(JJJ)
            %if Q=1 %and JJJ=0 %start;   ! CLEAR A RECORD TO ZERO
               outstring("memset(")
               P = P1; CNAME(3)
               outstring(",0,")
               OPND1 = NAMEOPND
               OPND2 = 0
               OPND2_PTYPE = X'51'; OPND2_FLAG = SCONST
               outstring("sizeof( ")
               p=p1; reducetag(NO)
               outformatname(kform)
               outsym(')'); outsym(')')
               P = P2; SKIP EXP
               %return
            %finish
            %if assop=3 {<-} %start
               ->BACK %unless TYPE=3 %and A(P2+3)=4 %and A(P2+4)=1
               outstring("memcpy(")
               P = P1; CNAME(3)
               outsym(',')
               OPND1 = NAMEOPND
               ACCP = ACC
               P = P2+5; CNAME(3)
               outsym(',')
               OPND2 = NAMEOPND
               %unless A(P)=2 %then FAULT(66,0,LHNAME) %and ->F00
!               %if ASSOP=2 %and ACCP#ACC %then %c
!                  FAULT(67,LHNAME,FROMAR2(P2+5)) %and ->F00
               %if ACCP>ACC %then ACCP = ACC
               outstring("sizeof( ")
               p=p1; reducetag(NO)
               outformatname(kform)
               outsym(')'); outsym(')')
               P = P2; SKIP EXP
               %return
            %finish
            p=P1; cname(7)
            outstring("=")
            p=p2+5; cname(7)
            P = P2; SKIP EXP
            %return
SW(4):                                   ! RESOLUTION
            outstring("imp_resolve(")
            P = P1; CNAME(2)
            outsym(',')
            P = P2;
            %if TYPE=5 %then CRES(0) %else %start
               SKIP EXP
               FAULT(71,0,LHNAME) %unless TYPE=7
            %finish
            outsym(')')
            %return
SW(1):                                   ! '==' AND %name PARAMETERS
            ->F81 %unless A(P2+3)=4 %and A(P2+4)=1
            FAULT(82,0,LHNAME) %and ->F00 %unless NAM=1 %and LITL#1
                                         ! ONLY NON-CONST POINTERS ON LHS OF==
           lhformatname=kform
            %if ARR=1 %then %start
               JJ = 11; KK = 12
               II = AHASS; B = AHEADPT
            %finish %else %start
               JJ = 6; KK = 3
               II = PTRAS; B = X'51'
               %if PTRSIZE(PTYPE&255)>4 %then B = X'61'
            %finish
            P = P1; CNAME(JJ)
            outsym('=')
            P = P2+5
            RHNAME = A(P)<<8!A(P+1)
            %if typep=3 %start
              reduce tag(NO)
              %if kform#lhformatname %start
                 outsym('('); outformatname(lhformatname)
                 outstring("*)")
              %finish
            %finish
            CNAME(KK);                   ! DESCRPTR FETCHED
            %if kk=12 %start
!printstring("dv reset "); write( LHCELL_SNDISP,5); write(sndisp,5); write(ctable(sndisp+3),5); newline
            %if lhcell_uioj&15=0 %then  lhcell_uioj= lhcell_uioj!(j&15)
            %if LHCELL_SNDISP=0 %then LHCELL_SNDISP=sndisp
         %finish
            ->F81 %unless A(P)=2;        ! NO REST OF EXP ON RHS
!            ->F83 %unless TYPE=TYPEP %and PREC=PRECP %and (ARR>0 %or II=PTRAS)
!            ->F86 %unless OLDI<=LVL %or I=0 %or NAM#0
                                         ! GLOBAL == NONOWN LOCAL
            P = P+1
            %return
F83:        FAULT(83,LHNAME,RHNAME); ->F00
F86:        FAULT(86,LHNAME,RHNAME); ->F00
F81:        FAULT(81,0,LHNAME)
F00:
            P = P2; SKIP EXP
         %end
%routine outopnd(%record(rd)%name opnd,%integer mode)
!***********************************************************************
!*   Outputs an operand which may be a complete tree                   *
!*      mode&1 = 0 output as is                                        *
!*      mode&1 = 1 output enclosed in ( and )                          *
!*       mode&2#0 output as a store not a load                         *
!*       Mode&256#0 all consts as numeric for switches                 *
!***********************************************************************
%integer i,pp
%longreal r
%switch sw(0:9)
      %if mode&1=1 %then outsym('(')
      ->sw(opnd_flag)
sw(0):                                {short const }
sw(1):                               {long const }
      %if opnd_ptype&7=1 %start
         %if opnd_ptype&x'f0'=x'60' %then outlhex(opnd_d,opnd_xtra) %else %start
            %if opnd_ptype&8#0 %and doinglabel=0 %then %start
               %if opnd_ptype>>4&7=3 %start
{GT:}             outsym('''');
                  %if opnd_d = '\' %or opnd_d = '''' %c
                   %then outsym('\');
                  outsym(opnd_d);
                  outsym('''')
               %finish %else outhex(opnd_d)
            %finish %else outint(opnd_d)
         %finish
      %finish
      %if opnd_ptype=x'52' %then outfl(opnd_r,7)
      %if opnd_ptype=x'62' %start
         integer(addr(r))=opnd_d
         integer(addr(r)+4)=opnd_xtra
         outfl(r,15)
      %finish
      %if opnd_ptype=x'72' %start
         outstring("NAN or unrepresentable value")
      %finish
      %if opnd_ptype=x'35' %start
         outsym('"')
         outstring(string(addr(a(opnd_d))))
         outsym('"')
      %finish
wayout:
      %if mode&1=1 %then outsym(')')
      %return
sw(2):                              { name as dictionary no }
      outname(opnd_d)
      ->wayout
sw(3):                              { name(app) as ar pointer }
      pp=p; p=opnd_d
      %if mode&2#0 %then cname(1) %else cname(2)
      p=pp; ->wayout
sw(8):                              { triple }
      outtriple(opnd_d,mode&x'ff00')
      ->wayout
%end
%routine outtriple(%integer tripno,mode)
!***********************************************************************
!*  output an expression defined by a triple which can head a tree     *
!*  mode as for outopnd                                                *
!***********************************************************************
%record(tripf)%name trip
%conststring(3)%array rsassop(ADD:ANDL)="+=","-=","^=",
                                       "|=","*=","/="(2),"&=";
%string(15) op,opl
%integer case,i,j
%switch sw(0:192)
      trip==triples(tripno)
      %if mode=1 %and doinglabel=0 %then outsym('(')
      case=trip_opern
      ->sw(case)
sw(ADD):
      op="+"; opl="plus"
binop:
      outopnd(trip_opnd1,mode&x'ff00'!trip_opnd1_flag>>3&1)
       %if doinglabel#0 %then outstring(opl) %else outstring(op)
      outopnd(trip_opnd2,mode&x'ff00'!trip_opnd2_flag>>3&1)
wayout:
      %if mode=1 %and doinglabel=0 %then outsym(')')
      %return
sw(SUB): op="-"; opl="minus"; ->binop
sw(NONEQ): op="^"; opl="non"; ->binop
sw(ORL): op="|"; opl="or"; ->binop
sw(MULT): op="*"; opl="mul"; ->binop
sw(INTDIV): op=" / "; opl="idiv"; ->binop
sw(REALDIV): op=" / "; opl="div"; ->binop
sw(ANDL): op="&"; opl="and"; ->binop
sw(RSHIFT): op=">>"; opl="rsh";  
      %if doinglabel=0 %then %start
         %if trip_opnd1_ptype&x'ff'=x'61' %then %start
             outstring("(UINT64)")
         %else
             outstring("(unsigned)")
         %finish
      %finish; ->binop
sw(LSHIFT): op="<<"; opl="lsh"; ->binop
sw(iexp):
      outstring("(int)")
sw(REXP):
      outstring("pow(")
      outopnd(trip_opnd1,mode&x'ff00')
      outstring(",")
      outopnd(trip_opnd2,mode&x'ff00')
      outstring(")")
      ->wayout
sw(RSTORE):
!     printstring("Rstore:")
      %if ADD<=trip_x1<=SUB %and 0<=trip_opnd2_flag<=1 %andc
          trip_opnd2_d=1 %and trip_opnd1_ptype&x'ff00'=0{not pointer}%start
         outopnd(trip_opnd1,mode&x'ff00')
         %if trip_x1=ADD %then outstring("++") %else outstring("--")
         ->wayout
      %finish
      op=rsassop(trip_x1); ->assop
sw(VASS):sw(VJASS):
      op="="
assop:
      outopnd(trip_opnd1,mode&x'ff00'!2)
      outstring(op)
      outopnd(trip_opnd2,mode&x'ff00'!0)
      ->wayout
sw(NOTL): op="~"; opl="not"
unaryop:
       %if doinglabel#0 %then outstring(opl) %else outstring(op)
       outopnd(trip_opnd1,mode&x'ff00'!trip_opnd1_flag>>3&1)
      ->wayout
sw(LNEG):
      op="-"; opl="uminus"; ->unaryop
sw(IFLOAT):
      %if trip_opnd1_flag=SCONST %start
           trip_opnd1_ptype=x'62'
           %begin
           %longreal x;
           x=trip_opnd1_d
           trip_opnd1_d=integer(addr(x))
           trip_opnd1_xtra=integer(addr(x)+4)
           %end
           op=""
           ->unaryop
      %finish
      op="(double)"; ->unaryop
sw(SHRTN):sw(LNGTHN):sw(JAMSHRTN):sw(NULLT):sw(PRELOAD):
      outopnd(trip_opnd1,mode&x'ff00'!0)
%end {outtriple }
         %routine CSEXP(%integer MODE)
!***********************************************************************
!*       COMPILE A SIGNED EXPRESSION TO REGISTER 'REG' IN MODE 'MODE'  *
!*       MODE=1 FOR %integer, =2 REAL, =3 LONG,=0 INTEGER %if POSSIBLE *
!*       MODE=5 FOR ADDRESS EXPRESSNS(IE LEAVE ANY CONSTANT IN 'ADISP')*
!***********************************************************************
            %integer EXPHEAD,NOPS,EXPBOT,form
            EXPHEAD = 0; EXPBOT = 0
            NOPS = 0; Form=0
            P = P+3
            %if a(p)=4 %and a(P+1)=3 %then Form=1   { Bracketed expr }
            TORP(EXPHEAD,EXPBOT,NOPS,0)
            EXPOP(EXPHEAD,EXPBOT,NOPS,MODE&x'ffff')
!            tripopt(triples,triples(0)_flink)
            outopnd(expopnd,Form! mode>>16)
         %end
%routine labexp
!***********************************************************************
!*    Evaluates the expression in a switch label to a valid cname      *
!*    This means operators have to be replaced by lettere              *
!***********************************************************************
      doinglabel=1
      csexp(x'51')
      doinglabel=0
%end
         %integer %fn CONSTEXP(%integer PRECTYPE)
!***********************************************************************
!*    COMPILES AN EXPRESSION WHICH SHOULD EVALUATE TO A CONSTANT OF    *
!*    TYPE 'PRECTYPE'. P AS FOR FN INTEXP.                             *
!***********************************************************************
            %integer EXPHEAD,EXPBOT,NOPS,RES
            EXPHEAD = 0; EXPBOT = 0; NOPS = 0; RES = 0
            TORP(EXPHEAD,EXPBOT,NOPS,1)
!      ->WAYOUT %unless NOPS&X'00040000'=0
            EXPOP(EXPHEAD,EXPBOT,NOPS,X'200'+PRECTYPE)
            ->WAYOUT %unless EXPOPND_FLAG<=1
            RES = ADDR(EXPOPND_D)
WAYOUT:
            %result = RES
         %end
         %integer %fn INTEXP(%integer %name VALUE, %integer PRECTYPE)
!***********************************************************************
!*    COMPILES AN EXPRESSION WHICH SHOULD EVALUATE TO A CONSTANT       *
!*    VALUE RETURNED IN VALUE. RESULT#0 IF FAILED TO EVALUATE          *
!*    IN THIS CASE RESULT IS IN ETOS. USED FOR BOUND CALCULATIONS      *
!*    P POINTS TO P(+') IN (+')(OPERNAD)(RESTOFEXPR)                   *
!***********************************************************************
            %integer EXPHEAD,EXPBOT,NOPS,CODE,SPTYPE,SACC
            EXPHEAD = 0; EXPBOT = 0; NOPS = 0; CODE = 0
            SPTYPE = PTYPE; SACC = ACC;  ! CALLED IN DECLARATIONS
            TORP(EXPHEAD,EXPBOT,NOPS,1)
            EXPOP(EXPHEAD,EXPBOT,NOPS,X'200'+PRECTYPE)
            CODE = 1 %unless EXPOPND_FLAG<=1 %and EXPOPND_PTYPE&x'77'=PRECTYPE
            VALUE = EXPOPND_D
            ACC = SACC; PTYPE = SPTYPE
            UNPACK
            %result = CODE
         %end
         %routine TORP(%integer %name HEAD,BOT,NOPS,%integer mode)
!***********************************************************************
!*       CONVERT THE SIGNED EXPRESSION INDEXED BY P INTO REVERSE       *
!*      POLISH NOTATION. THE REVERSE POLISH LIST IS ADDED TO 'HEAD'    *
!*      WHICH MAY CONTAIN ANOTHER EXPRESSION. THE NUMBER OF OPERATORS  *
!*      IS ADDED TO NOPS.                                              *
!*      N.B. AN INTEGER EXPRESSION IS A SPECIAL CASE OF A REAL EXPRSN  *
!*    THE TOP 20 BITS OF NOPS ARE USED TO RETURN DETAILS OF THE EXPR   *
!*    THESE BITS SIGNIFY AS FOLLOWS:-                                  *
!*    1<<17    CONTAINS VARIABLE OF MORE THAN 32 BITS                  *
!*    1<<18    NOT CONSTANT EXPRSSN IE CONTAINS AT LEAST 1 VARIABLE    *
!*    1<<19    COMPLEX IE CONTAINS FN CALL OR NEEDS DR TO EVALUATE     *
!*    mode # 0 if const expressions to be evaluated                    *
!***********************************************************************
            %switch OPERAND(1:3)
            %const %byte %integer %array PRECEDENCE(0:20)=0,3,3,4,5,5,4,3,3,4,4,5,5,3,5,5,
                                        0(3),3,5

            %const %byte %integer %array OPVAL(0:20)=0,ADD,SUB,ANDL,IEXP,REXP,MULT,NONEQ,
                  ORL,INTDIV,REALDIV,RSHIFT,LSHIFT,ADD,IEXP,REXP,0(3),LNEG,NOTL

            %integer RPHEAD,PASSHEAD,SAVEHEAD,REAL,REALOP,OPERATOR,OPPREC,
               OPND,C,D,E,BDISP,OPNAME,OPMASK,RPBOT,OPSTK,OPPSTK,PASSBOT,PIN
            %record (TAGF) %name LCELL
            %record (RD) RPOP
!
            PASSHEAD = 0; RPHEAD = 0; SAVEHEAD = 0
            REAL = 0; REALOP = 0; BDISP = 0
            RPBOT = 0; OPSTK = 0; OPPSTK = 0
            PIN=p
!
            C = A(P)
            %if 2<=C<=3 %then %start;    ! INITIAL '-' OR '\'
               NOPS = NOPS+1
                                         ! '-' =(11,3)   '\' =(10,5)
               OPSTK = C+17
               OPPSTK = PRECEDENCE(OPSTK)
               OPMASK = 1<<(19+C);       ! - %or !!
            %finish %else OPMASK = 0
NEXTOPND:   OPND = A(P+1); P = P+2
            RPOP = 0
            ->OPERAND(OPND);             ! SWITCH ON OPERAND
OPERAND(1):                              ! NAME
            OPNAME = A(P)<<8+A(P+1)
            LCELL == ASLIST(TAGS(OPNAME))
            LCELL_UIOJ <- LCELL_UIOJ!X'8000';  ! SET USED BIT
            PTYPE = LCELL_PTYPE
            TYPE = PTYPE&7; PREC = PTYPE>>4&15
            %if PTYPE=X'FFFF' %then PTYPE = X'51';  ! NAME NOT SET
            %if PTYPE=SNPT %then PTYPE = LCELL_ACC %and UNPACK
            %if (mode#0 %or string(addr(worka_lett(word(opname))))="pi") %c
               %and PTYPE&X'FF00'=X'4000' %and A(P+2)=2=A(P+3) %and 1<=TYPE<=2 %then %start
                                         ! CONST VAR
               RPOP_D = LCELL_S2; RPOP_XTRA = LCELL_S3
               RPOP_FLAG = 1; PTYPE = PTYPE&255
               %if TYPE=1 %and PREC<=5 %and X'FFFF8000'<RPOP_D<=X'7FFF' %then %c
                  RPOP_FLAG = 0 %and PTYPE = MINAPT
               REAL = 1 %if TYPE=2
               P = P+2; ->SKNAM
            %finish
            RPOP_XTRA = OPNAME
            RPOP_FLAG = ARNAME; RPOP_D = P; PTYPE = X'51' %if PTYPE=X'57'
            %if TYPE=3 %then %start
               D = P; KFORM = LCELL_KFORM
               C = COPY RECORD TAG(E); P = D;
            %finish
            %if TYPE=5 %then FAULT(76,0,OPNAME) %and RPOP_FLAG = 0 %and %c
               PTYPE = X'51'
            %if PREC>=6 %then OPMASK = OPMASK!1<<17;  ! MORE THAN 32 BITS
            %if TYPE=2 %then REAL = 1
            P = P+2
SKNAM:      %if A(P)=2 %then P = P+1 %else SKIP APP
            %if A(P)=1 %then P = P+3 %and ->SKNAM
            P = P+2
INS:        %if RPOP_FLAG=ARNAME %then OPMASK = OPMASK!1<<18
            %if PTYPE>>4&15>5 %then OPMASK = OPMASK!1<<17;  ! CONTINS LONG
            %if 3<=PTYPE&7<=7 %then PTYPE = X'51';  ! NOT SET TO INTEGER
            RPOP_PTYPE <- PTYPE
            BINSERT(RPHEAD,RPBOT,RPOP_S1,RPOP_D,RPOP_XTRA)
            ->OP
OPERAND(2):                              ! CONSTANT
            PTYPE = A(P); D = PTYPE>>4
            C = PTYPE&7
            %if (PTYPE=x'61' %and 1<<TARGET&LINTAVAIL=0) %or %c
               (D=7 %and c=2 %and 1<<TARGET&LLREALAVAIL=0) %then FAULT(99,0,0)
            %if D>=6 %then OPMASK = OPMASK!1<<17;  ! MORE THAN 32 BIT OPERAND
            %if D=4 %or d=3 %then %start
               d=4; RPOP_D = FROM AR2(P+1)
!               PTYPE = ptype&8!X'51'
            %finish %else RPOP_D = FROM AR4(P+1)
            REAL = 1 %if C=2; RPOP_FLAG = 1
            %if D=6 %then RPOP_XTRA = FROM AR4(P+5)
            %if C=5 %then %start;        ! STRING CONSTANT
               FAULT(77,0,0); RPOP_D = 1; RPOP_FLAG = 0
               P = P+A(P+1)+3; PTYPE = X'51'
            %finish %else %start
               %if D=7 %then RPOP_XTRA = RPOP_D %and RPOP_D = P+1
               %if PTYPE=X'51' %and X'FFFF8000'<=RPOP_D<=X'7FFF' %then %c
                  RPOP_FLAG = 0 %and PTYPE = MINAPT
               P = P+2+BYTES(D)
            %finish; ->INS
OPERAND(3):                              ! SUB EXPRESSION
            PASSHEAD = 0; PASSBOT = 0
            P = P+3
            TORP(PASSHEAD,PASSBOT,NOPS,mode)
            REAL = 1 %if TYPE=2
!         CONCAT(RPHEAD,PASSHEAD)
            %if RPBOT=0 %then RPHEAD = PASSHEAD %else %c
               ASLIST(RPBOT)_LINK = PASSHEAD
            RPBOT = PASSBOT
            P = P+1
OP:                                      ! DEAL WITH OPERATOR
            RPOP = 0
            ->EOE %if A(P-1)=2;          ! EXPR FINISHED
            OPERATOR = A(P)
!
! THE STRING OPERATOR '.' CAUSES CHAOS IN AN ARITHMETIC EXPRSN
! SO FAULT IT AND CHANGE IT TO THE INNOCUOUS '+'
!
            %if OPERATOR=CONCOP %then FAULT(78,0,0)
            OPPREC = PRECEDENCE(OPERATOR)
            C = OPVAL(OPERATOR)
            %if C=REALDIV %or C=REXP %then REAL = 1
            NOPS = NOPS+1
!
! UNLOAD THE OPERATOR STACK OF ALL OPERATORS WHOSE PRECEDENCE IS
! NOT LOWER THAN THE CURRENT OPERATOR. AN EMPTY STACK GIVES'-1'
! AS PRECEDENCE.
!
            %while OPPREC<=OPPSTK&31 %cycle
               RPOP_FLAG = OPVAL(OPSTK&31)
               BINSERT(RPHEAD,RPBOT,RPOP_S1,0,0)
               OPSTK = OPSTK>>5; OPPSTK = OPPSTK>>5
            %repeat
!
! THE CURRENT OPERATOR CAN NOW BE STORED
!
            OPSTK = OPSTK<<5!OPERATOR
            OPPSTK = OPPSTK<<5!OPPREC
            ->NEXTOPND
EOE:                                     ! END OF EXPRESSION
                                         ! EMPTY REMAINING OPERATORS
            %while OPSTK#0 %cycle
               RPOP_FLAG = OPVAL(OPSTK&31)
               BINSERT(RPHEAD,RPBOT,RPOP_S1,0,0)
               OPSTK = OPSTK>>5
            %repeat
            PTYPE = REAL+1
            TYPE = PTYPE
!         CONCAT(RPHEAD,HEAD)
            %if HEAD=0 %then BOT = RPBOT %else ASLIST(RPBOT)_LINK = HEAD
            HEAD = RPHEAD;               ! HEAD BACK TO TOP OF LIST
            NOPS = NOPS!OPMASK
         %end
         %routine EXPOP(%integer %name HEAD,BOT, %integer NOPS,MODE)
!***********************************************************************
!*    EVALUATE A LIST OF OPERAND AND'NOPS' OPERATORS AND LEAVE         *
!*    THE RESULT IN REG                                                *
!*    INHEAD HOLDS THE LIST THE BOTTOM BYTE OF STREAM 1 DEFINES THE    *
!*    ENTRY AS FOLLOWS:-                                               *
!*       0 = SHORT (INTEGER) CONSTANT <18 BITS --S2=CONSTANT           *
!*       1 = OTHER CONSTANT    S2 (+S3 IF NEEDED) = CONSTANT           *
!*       2 = VARIABLE S2 POINT TO AR ENTRY FOR NAME&SUBSCRIPTS         *
!*      (3 = DOPE VECTOR ITEM IF NEEDED)                               *
!*      (4 = CONDITONAL EXPRESSION AS IN ALGOL)                        *
!*       7 = INTERMEDIATE RESULT UNDER LNB  S2=DISPLCMNT FROM LNB      *
!*       8 = INTERMEDIATE RESULT STACKED                               *
!*       9 = INTERMEDIATE RESULT IN A REGISTER S2 = REG                *
!*                                                                     *
!*       10-19 = UNARY OPERATOR S2=OP S3 =EXTRA                        *
!*       20 UP = BINARY OPERATOR                                       *
!*                                                                     *
!*       MODE HAS TYPE & PREC REQD +256 BIT IF NO RESULT REQD          *
!***********************************************************************
            %routine %spec PSEVAL
!
            %integer %array OPERAND(0:2),STK(0:99)
            %record (LISTF) %name LIST
            %record (RD) %name OPND1,OPND2,OPND
            %record (TRIPF) %name CURRT

!
            %integer C,D,KK,JJ,COMM,XTRA,INHEAD,CURR TRIP,STPTR,CONSTFORM,
               CONDFORM,SAVEP,INITTRIP
!
! CORULES GIVE INFORMATION ON OPERATORS.
!     BTM 4 BITS HAVE TYPE CONVERSION RULES(SEE COERCET)
!     NEXT 4 BITS HAVE PREC RULES (SEE COERCEP)
!     2**8 SET IF COMMUTATIVE
!
            %const %half %integer %array CORULES(0:20)= %c
                                        X'1FF'{+},X'FF'{-},
                                        X'1F1'{!!},X'1F1'{!},
                                        X'1FF'{*},X'F1'{//},
                                        X'F2'{/},X'1F1'{&},X'71'{>>},
                                        X'71'{<<},X'43'{**},
                                        X'1FF'{COMP},X'FF'{DCOMP},
                                        X'21'{VMY},X'1F1'{COMB},
                                        X'14'{ASSIGN=},
                                        X'54'{ASSIGN<-},X'71'{****},
                                        X'01'{ARR BADJ},
                                        X'001'{ARR INDEX},
                                        X'100'{INDEXED FETCH}

            %const %integer %array PTYPECH(0:19)=0(12),X'11',0,-X'10',X'10',-X'10',0(3)


!
            STPTR = 0; CONSTFORM = MODE&512
            INITTRIP = NEXTTRIP
            CONDFORM = MODE&256
            SAVEP = P
            INHEAD = HEAD
            PSEVAL
NEXT:       LIST == ASLIST(INHEAD)
            XTRA = LIST_S2
            JJ = LIST_FLAG; D = INHEAD
            INHEAD = LIST_LINK
            ->OPERATOR %if JJ>=10
!
! ANY OPERAND WHICH MAY NEED DR OR B OR ACC IN THEIR EVALUATION
! EG FUNCTIONS,ARRAY ELEMENTS ETC ARE FETCHED AND STACKKED FIRST
!
            OPND1 == ASLIST(D)
            STK(STPTR) = D
            STPTR = STPTR+1
            IMPABORT %if STPTR>99
ANYMORE:
            ->NEXT %unless INHEAD=0
            OPND1 == ASLIST(STK(STPTR-1))
            EXPOPND = OPND1
            ->FINISH
OPERATOR:
            %if JJ<128 %then KK = 1 %else KK = 2;  ! UNARY OR BINARY
            %cycle KK = KK,-1,1
               STPTR = STPTR-1
               OPERAND(KK) = STK(STPTR)
            %repeat
            COMM = 1
            OPND1 == ASLIST(OPERAND(1))
            %if JJ>=128 %then %start
               OPND2 == ASLIST(OPERAND(2))

            %finish %else OPND2 == RECORD(0)
! next line must be wrong 32 is not dsided
!            %if JJ=32 %then COMM = 2;    ! DSIDED RESULT=2ND OPERAND
                                         ! ALL OTHERS RESULT=1ST OPERAND
            %if JJ<128 %then C = 0 %else C = CORULES(JJ-128)
            %if JJ=VASS %or JJ=VJASS %then KK = 1 %else KK = 2
                                         ! CNAME FETCH-STORE
!            %if OPND1_FLAG=ARNAME %and (LHSADDRFIRST=YES %or KK=2) %start
!                                         ! EXPAND UP NAMES BUT NOT LHS
!                                         ! ASSIGNMENT NAMES
!               P = OPND1_D; CNAME(KK)
!               OPND1 = NAMEOPND
!            %finish
!            %if JJ>=128 %and OPND2_FLAG=ARNAME %then %start
!               P = OPND2_D
!               CNAME(2)
!               OPND2 = NAMEOPND
!            %finish
!            %if OPND1_FLAG=ARNAME %then %start
!               P = OPND1_D
!               CNAME(KK)
!               OPND1 = NAMEOPND
!            %finish
            %if constform#0 %and OPND1_FLAG<2 %and (JJ<128 %or OPND2_FLAG<2) %then %c
               CTOP(JJ,MASK,XTRA,OPND1,OPND2)
            %if JJ#0 %then %start;       ! CODE REQUIRED OP TRIPLE
               CURR TRIP = NEW TRIP
               CURRT == TRIPLES(CURR TRIP)
               CURRT_DPTH = 0;           ! LEAVE DEPTHS TO BE WORKED OUT IN%c
                                         OPT PASS
               CURRT_CNT = 0
               CURRT_FLAGS = 1!(C>>1&128)
               CURRT_OPERN = JJ
               CURRT_OPTYPE <- OPND1_PTYPE
               %if 12<=JJ<=16 %start;    ! UNARY(TYPECHANGE)OPN
                  CURRT_OPTYPE <- XTRA; XTRA = 0
               %finish %else %if %c
                  OPND1_PTYPE&7=1 %and OPND1_PTYPE&255<MINAPT %then %c
                  CURRT_OPTYPE = MINAPT
                                         ! PREVENT OPTIMISING BYTE ARRAY SCALE
                                         ! AS THESE CREATE EXTRA WORD
                                         ! WHICH DEFEATS ALGORITHMS
               %if (TARGET=PERQ %or TARGET=ACCENT %or TARGET=PNX) %and %c
                  JJ=39 %and XTRA>>20=1 %then %c
                  CURRT_FLAGS <- CURRT_FLAGS!DONT OPT
               CURRT_X1 = XTRA
               CURRT_OPND1 = OPND1
               %if 1<<OPND1_FLAG&BTREFMASK#0 %then KEEP USE COUNT(OPND1)
               %if JJ>=128 %then %start
                  CURRT_OPND2 = OPND2
                  %if 1<<OPND2_FLAG&BTREFMASK#0 %then KEEP USE COUNT(OPND2)
               %finish
               OPND1_FLAG = 8
               OPND1_PTYPE = CURRT_OPTYPE
               OPND1_D = CURR TRIP
            %finish
            STK(STPTR) = OPERAND(COMM)
            STPTR = STPTR+1
            ->ANYMORE
FINISH:
!            %if EXPOPND_FLAG=ARNAME %then %start
!               P = EXPOPND_D
!               CNAME(2)
!               EXPOPND = NAMEOPND
!            %finish
            PTYPE = EXPOPND_PTYPE
            TYPE = PTYPE&7; PREC = PTYPE>>4
            P = SAVEP
            ASLIST(BOT)_LINK = ASL
            ASL = HEAD
            HEAD = 0; BOT = 0
            %return
            %routine PSEVAL
!***********************************************************************
!*    PERFORMS A PSEUDO EVALUATION ON THE EXPRESSION TO DETERMINE      *
!*    THE POSITION OF ANY TYPE CHANGES AND THEN INSERTS                *
!*    THESE UNARY OPERATIONS                                           *
!***********************************************************************
               %routine %spec AMEND(%record (RD) %name OPND, %integer OP)
               %routine %spec COERCET(%integer RULES)
               %routine %spec COERCEP(%integer RULES)
               %integer TMPHEAD,INHEAD,C,JJ,NEXT
               %record (RD) %name OPND1
               %record (RD) OPND2,RPOP
               %record (LISTF) %name CELL
               PRINT LIST(HEAD) %and IMPABORT %unless ASLIST(BOT)_LINK=0
               RPOP = 0
               TMPHEAD = 0
               INHEAD = HEAD
!
               %while INHEAD#0 %cycle
                  CELL == ASLIST(INHEAD)
                  NEXT = CELL_LINK
                  RPOP <- CELL;          ! COPY BEFOR ADJUSTING PTYPE
                  JJ = RPOP_FLAG;        ! FLAG
                  %if JJ<10 %start;      ! AN OPERAND
!            %if RPOP_PTYPE>>4&15<MINAPREC %then RPOP_PTYPE%c
=RPOP_PTYPE&X'FF0F'!(MINAPREC<<4)
                     PUSH(TMPHEAD,RPOP_S1,RPOP_D,INHEAD)
                  %finish %else %start;  ! AN OPERATOR
                     %if JJ>=128 %start;  ! BINARY OPERATOR
                        POP(TMPHEAD,OPND2_S1,OPND2_D,OPND2_XTRA)
                        OPND1 == ASLIST(TMPHEAD);  ! MAPPING SAVES POP&PUSH
                        C = CORULES(JJ-128)
                        %if JJ=REXP %and OPND2_PTYPE&7=2 %then C = X'F2'
                                         ! REAL TO THE REAL
                        %if C&15#0 %then COERCET(C&15)
                        %if C>>4&15#0 %then COERCEP(C>>4&15)
                     %else
                        OPND1 == ASLIST(TMPHEAD)
                        %if JJ=MODULUS %start
                           %if OPND1_PTYPE&7=1 %and RPOP_D&7=2 %then COERCET(3)
                           %if OPND1_PTYPE>>4&15<RPOP_D>>4&15 %then %c
                              AMEND(OPND1,LNGTHN)
                           %if OPND1_PTYPE>>4&15>RPOP_D>>4&15 %then %c
                              AMEND(OPND1,SHRTN)
                         %else
                            %if jj<19 %then opnd1_ptype=opnd1_ptype+ptypech(jj)
                        %finish
                     %finish
                     OPND1_XTRA = INHEAD;  ! IN CASE(FURTHER)TYPE CHANGE
                  %finish
                  INHEAD = NEXT
               %repeat
!
! FINAL COERCION ON RESULT
!
               POP(TMPHEAD,OPND2_S1,OPND2_D,OPND2_XTRA)
               PRINT LIST(HEAD) %and IMPABORT %unless TMPHEAD=0
               %if CONDFORM=0 %start
                  %if MODE&7=1 %and OPND2_PTYPE&7=2 %then FAULT(25,0,0)
                  %if OPND2_PTYPE&7=1 %and MODE&7=2 %then AMEND(OPND2,IFLOAT)
                  C = MODE>>4&15;        ! TARGET PREC
                  AMEND(OPND2,SHRTN) %while C<OPND2_PTYPE>>4&15
                  AMEND(OPND2,LNGTHN) %while C>OPND2_PTYPE>>4&15
               %finish
               PRINTLIST(HEAD) %if PARM_DCOMP#0 %and PARM_Z#0
               BOT = ASLIST(BOT)_LINK %while ASLIST(BOT)_LINK#0
               %return
               %routine AMEND(%record (RD) %name OPND, %integer OP)
!***********************************************************************
!*    ADDS IN AN OPERATION TO CHANGE THE TYPE OR PREC OF OPND          *
!*     On E machines we can not elide uneceesary changes               *
!***********************************************************************
                  %record (RD) RPOP
                  %if 1<<target&Emachine=0 %and OP=LNGTHN %and OPND_PTYPE&255<MINAPT %then %c
                     OPND_PTYPE <- OPND_PTYPE&X'FF00'!MINAPT %and %return
                  RPOP = 0
                  RPOP_FLAG = OP
                  %if OP=IFLOAT %and OPND_PTYPE&255<MINAPT %then %c
                     OPND_PTYPE = MINAPT
                  OPND_PTYPE = OPND_PTYPE+PTYPECH(OP)
                    %if 1<<target&Llrealavail=0 %and op=ifloat %c
                       %and Opnd_ptype&255=X'72' %then OPnd_ptype=opnd_ptype-x'10'
                                       ! float longinteger when longlongreal not available
                  INSERT AFTER(OPND_XTRA,RPOP_S1,OPND_PTYPE,0)
                  NOPS = NOPS+1
               %end
               %routine COERCET(%integer RULES)
!***********************************************************************
!*         RULES=1 BOTH OPERANDS INTEGER ELSE ERROR                    *
!*         RULES=2 FORCE BOTH OPERAND TO BE OF TYPE REAL               *
!*         RULES=3 OPND1 ONLY TO BE REAL(FOR **)                       *
!*         RULES=4 OPND2 TO BE OPND 1(ASSIGNMENT)                      *
!*         RULES=15  BOTH OPERANDS TO BE OF LARGEST TYPE               *
!***********************************************************************
                  %integer PT1,PT2
                  %record (RD) RPOP
                  RPOP = 0; RPOP_FLAG = 12;  ! FLOAT
                  PT1 = OPND1_PTYPE&7;
                  PT2 = OPND2_PTYPE&7; %if PT2=7 %then PT2=1
                  %if RULES=4 %then PT1 = CELL_S2&7;  ! ORIGINAL PT FOR ARRAYS%c
                                                      ETC
                  %if PT1=7 %then PT1=1
                  %if (RULES=1 %or RULES=15 %or RULES=4) %and PT1=1=PT2 %then %c
                     %return
                  %if RULES=1 %or (RULES=4 %and PT1=1) %then %c
                     FAULT(24,0,0) %and %return
                  %if PT1=1 %then AMEND(OPND1,IFLOAT)
                  %if PT2=1 %and (RULES=2 %or RULES=4 %or RULES=15) %then %c
                     AMEND(OPND2,IFLOAT)
               %end
               %routine COERCEP(%integer RULES)
!***********************************************************************
!*       RULES DEFINE COERCION AS FOLLOWS:                             *
!*       RULES=1 FORCE OPND2 TO BE OPND1(ASSIGNMENT)                   *
!*       RULES=2 OPERAND 1 TO BE 'STANDARD' INTEGER                    *
!*       RULES=4 OPERAND 2 TO BE 'STANDARD' INTEGER                    *
!*       RULES=5 AS RULES=1 BUT FOR <- ASSIGNMENT                      *
!*       RULES=6 BOTH OPERANDS TO BE 'STANDARD' INTEGER                *
!*       RULES=7 OPND1>=32BITS, OPND2 TO BE 'STANDARD'                 *
!*       RULES=15 BOTH OPERANDS TO THE LARGEST PRECISION               *
!***********************************************************************
                  %integer PREC1,PREC2,TPREC,OPER
                  %record (RD) %name OPND
                  %record (RD) RPOP
                  RPOP = 0
                  %if RULES=6 %then COERCEP(4) %and RULES = 2
                  PREC1 = OPND1_PTYPE>>4&15
                  PREC2 = OPND2_PTYPE>>4&15
                  %if RULES=5 %or RULES=1 %start;  !  ASSIGN
                     PREC1 = CELL_S2>>4&15;  ! ORIGINAL PREC FOR ARRAY ASSIGN
                     %if PREC2>PREC1 %start
                        %cycle
                           %if RULES=1 %then OPER = SHRTN %else OPER = JAMSHRTN
                           AMEND(OPND2,OPER)
                           PREC2 = PREC2-1
                        %repeat %until PREC1=PREC2
                        %return
                     %finish %else RULES = 1;  ! IN CASE LENGTHEN NEEDED
                  %finish
                  %if PREC1<MINAPREC %then %c
                     PREC1 = MINAPREC %and %c
                     OPND1_PTYPE <- OPND1_PTYPE&X'FF0F'!(MINAPREC<<4)
                  %if PREC2<MINAPREC %then %c
                     PREC2 = MINAPREC %and %c
                     OPND2_PTYPE <- OPND2_PTYPE&X'FF0F'!(MINAPREC<<4)
                  %if RULES=7 %start;    ! FORCE SHIFT INTO 32 BIT MIN REG
                     RULES = 4
                     %if PREC1=4 %then AMEND(OPND1,LNGTHN) %and PREC1 = 5
                  %finish
                  %if 2<=RULES<=4 %start
                     %if RULES<=2 %then OPND == OPND1 %else OPND == OPND2
                     %if OPND_PTYPE&X'FF'>MINAPT %then AMEND(OPND,SHRTN)
                     %return
                  %finish
                  %if PREC1<PREC2 %then %c
                     TPREC = PREC2 %and OPND == OPND1 %else %c
                     TPREC = PREC1 %and OPND == OPND2
                  OPER = OPND_PTYPE
                  AMEND(OPND,LNGTHN) %while OPND_PTYPE>>4&15<TPREC
               %end
            %end
         %end;                           ! OF ROUTINE EXPOP
         %integer %fn CCOND(%integer CTO,IU,FARLAB,JFLAGS)
!***********************************************************************
!*       COMPILES <IU><SC><RESTOFCOND>%then<UI1>%else<UI2>             *
!*       CTO=0 JUMP TO FARLAB MUST BE PLANTED IF COND UNCONDITIONAL    *
!*       CTO#0 JUMP MAY BE OMITTED                                     *
!*       IU=1 FOR %if   =2 FOR UNLESS. FARLAB TO GO ON UI2             *
!*       THE ROUTINE MAKES FOUR PASSES THROUGH THE CONDITION           *
!*       PASS 1 ANALYSES THE STRUCTURE AND DECIDES TO BRANCH ON TRUE   *
!*       (TF=2)   OR ON FALSE (TF=1) FOR EACH COMPARISON               *
!*       PASS 2 WORKS OUT WHERE THE BRANCHES OF PASS 1 SHOULD GO TO    *
!*       PASS 3 ASSIGNS LABEL NUMBERS                                  *
!*       PASS 4 EVALUATES COMPARISIONS AND PLANTS THE CODE             *
!*                                                                     *
!*       ON ENTRY P POINTS TO <SC> IN<HOLE><SC><RESTOFCOND>            *
!*       RESULT=0 CONDITION COMPILED                                   *
!*       RESULT=1 UNCONDITIONALLY TO 1ST ALTERNATIVE                   *
!*       RESULT=2 UNCONDITIONALLY TO 2ND ALTERNATIVE(FARLAB)           *
!***********************************************************************
!%routinespec WRITE CONDLIST
            %routine %spec SKIP SC(%integer REVERSED)
            %routine %spec SKIP COND(%integer REVERSED)
            %integer %fn %spec CCOMP
            %routine %spec JUMP(%integer MASK,LAB,FLAGS)
            %routine %spec NOTE JUMP(%integer LAB)
            %routine %spec LAB UNUSED(%integer LAB)
            %routine %spec OMIT TO(%integer LAB)
!
! FCOMP HAS BC MASKS FOR EACH STRING COMPARATOR.
! THE FIRST 7 ARE TO BRANCH IF TRUE WITH NORMAL COMPARISON
! THE SECOND SEVEN ARE TO BRANCH IF TRUE WITH BACKWARDS COMPARISON
!
!
            %integer PIN,PP,II,L,CPTR,CMAX,LL,BITMASK,LLA
            %record %format CF(%byte %integer TF,CMP1,CMP2,LABU,LVL,JMP,REV,
               JUMPED, %integer LABNO,SP1,SP2,sp3)
            %record (CF) %array CLIST(0:30)
            %record (CF) %name C1,C2
!
! PASS 1.   ANALYSES THE CONDITION
!
            PIN = P;                     ! SAVE INITIAL AR POINTER
            CPTR = 1; L = 3;             ! LEVEL=3 TO ALLOW 2 LOWER
            C1 == CLIST(CPTR);           ! SET UP RECORD FOR FIRST CMPARSN
            C1 = 0

{GT:} ! Would be nice to apply de-morgan's law below and invert the actual
      ! conditional tests, eg
      !        a=1 %and b>fred
      ! ->     a#1 %or b<=fred
      ! 
      ! Since Imp80 has no %predicates, we don't need to re-insert any "!"s
      ! at a lower level, except for conditional string resolution, i.e.
      !       a->a.("->").b
      ! ->    (%not a->a.("->").b)
      ! 
      ! If we add this as a general mechanism, then when translating to
      ! C we can clean up 'unless' and 'repeat until' statements, which map
      ! to C's if and while statements.
      !
      ! Also it would be useful in my %if <cond> %then %monitor
      ! extension, which maps to assert(!(<cond>))
      !
      ! NOTE: ** it would appear SKIP SC(1) and SKIP COND()
      ! do exactly what I want here!
      !
!           %if iu=2 %then outstring("(!")
            outsym('(')
            %if iu=2 %then %start
              SKIP SC(1);                  ! SKIP THE 1ST CMPARSN
              SKIP COND(1);                ! AND ANY %and/%or CLAUSES
            %else
              SKIP SC(0);                  ! SKIP THE 1ST CMPARSN
              SKIP COND(0);                ! AND ANY %and/%or CLAUSES
            %finish
            outstring(") ")
!           %if iu=2 %then outsym(')')
            %result=0
%routine SKIP SC(%integer REVERSED)
!***********************************************************************
!*       REVERSED=1 FOR RECURSIVE CALL IN %not(SC)                     *
!*       SKIPS OVER A SIMPLE CONDITION. P ON ALT OF<SC>                *
!***********************************************************************

!
! In Imp to C translator we do NOT generate jumps so the logic
! for REVERSED which changes the jump destinations does not
! do anything.  Instead we must explicity apply de-morgan's
! law to the operands and operators.  I am in the process
! of adding that code now.  SKIP COND is done already

%conststring(5) %array CMP(0:10)=" ??? ","==",">=",">",
                       "!=","<=","<","!=","?->??",
                       "==","!="

%conststring(6) %array REVCMP(0:10)=" ??? ","!=","<","<=",
                       "==",">",">=","==","!?->??",
                       "!=","=="

%switch SCALT(1:4)
%integer ALT,TE1,TE2,PRECP,TYPEp,finalp,rexp
      ALT = A(P); P = P+1
      ->SCALT(ALT)
SCALT(1):                                ! <EXP><COMP><EXP><SECONDSIDE>
      C1_SP1 = P
      te1=tsexp(TE2)
      typep=type; precp=prec
      p = c1_sp1             { tsexp may not reset p }
      SKIP EXP
      C1_CMP1 = A(P)
      C1_REV = 3*REVERSED
      P = P+1; C1_SP2 = P
      SKIP EXP
      %if A(P)=2 %then P = P+1 %else %start
         C1_CMP2 = A(P+1);      ! DEAL WITH 2ND HALF OF D-SIDED
         P = P+2; C1_SP3=P; SKIP EXP
      %finish
      finalp=p
!      outsym('(') %unless a(finalp)=3
      %if typep=5 %start
         p=c1_sp1
         %if c1_cmp1=8 %start
           outstring("imp_resolve(")
           p=p+5; cname(2)
            outsym(',')
           p=c1_sp2; cres(1)
           %if REVERSED=1 %then %start
             outstring(")!=0"); ! De-Morgan's law
           %else
             outstring(")==0")
           %finish
           %if c1_cmp2#0 %then outstring("untranslateable cond")
        %else
            %if c1_cmp2#0 %then outsym('(')
            outstring("strcmp(")
            cstrexp(0)
            outsym(',')
            p=c1_sp2; cstrexp(0)
            outsym(')')
            %if REVERSED=1 %then %start
              outstring(REVcmp(c1_cmp1)); ! de-morgan's law
            %else
              outstring(cmp(c1_cmp1))
            %finish
            outsym('0')
            %if c1_cmp2#0 %then %start
               %if REVERSED=1 %then %start
                  outstring(") || ("); ! De-Morgan's Law
               %else
                  outstring(") && (")
               %finish
               p=c1_sp2; cstrexp(0)
               outsym(',')
               p=c1_sp3
               cstrexp(0)
               outsym(')')
            %finish
        %finish
      %else
         %if c1_cmp2#0 %then outsym('(')
         p=c1_sp1
         REXP = 2-A(P+1+FROM AR2(P+1))
         %if rexp#0 %then outsym('(')
         %if c1_cmp1>8 %then p=p+5 %and cname(4) %else csexp(precp<<4!typep!256)
         %if rexp#0 %then outsym(')')
         %if REVERSED=1 %then %start
            outstring(REVcmp(c1_cmp1)); ! DeMorgan's law
         %else
            outstring(cmp(c1_cmp1))
         %finish
         p=c1_sp2
         REXP = 2-A(P+1+FROM AR2(P+1))
         %if rexp#0 %then outsym('(')
         %if c1_cmp1>8 %then p=p+5 %and cname(4) %else csexp(precp<<4!typep!256)
         %if rexp#0 %then outsym(')')
         %if c1_cmp2#0 %start
            %if REVERSED=1 %then %start
               outstring(") || (")
            %else
               outstring(") && (")
            %finish
            %if rexp#0 %then outsym('(')
            p=c1_sp2; csexp(precp<<4!typep)
            %if rexp#0 %then outsym(')')
            %if REVERSED=1 %then %start
               outstring(REVcmp(c1_cmp1)); ! DeMorgan's law
            %else
               outstring(cmp(c1_cmp2))
            %finish
            p=c1_sp3
            REXP = 2-A(P+1+FROM AR2(P+1))
            %if rexp#0 %then outsym('(')
            csexp(precp<<4!typep)
            %if rexp#0 %then outsym(')')
            outsym(')')
         %finish
      %finish
      p=finalp
!      outsym(')') %unless a(finalp)=3
      %return
SCALT(2):                                ! '('<SC><RESTOFCOND>')'
      outsym('(')
      L = L+1
      SKIP SC(REVERSED)
      SKIP COND(REVERSED)
      L = L-1
      outsym(')')
      %return
SCALT(3):                                ! %not(SC)
{GT:}!outstring("!(")
     ! now that SKIP SC and SKIP COND reverse properly,
     ! we do not need to negate here as well...
      SKIP SC(REVERSED!!1)
     !outsym(')')
      %return
SCALT(4):
      %if REVERSED=1 %then outstring("/* what is a pseudo-boolean? - is the conditio accidentally inverted? */");
      csexp(x'51');             ! single pseudo boolean expr
   %end;                        ! OF ROUTINE SKIP SC
            %routine SKIP COND(%integer REVERSED)
!***********************************************************************
!*       SKIPS OVER <RESTOFCOND>                                       *
!***********************************************************************
               %integer ALT,ALTP
               ALT = A(P);               ! 1=%and<ANDC>,2=%or<ORC>,3=NULL
               P = P+1
               %if ALT\=3 %then %start;  ! NULL ALTERNATIVE NOTHING TO DO
                  %until ALTP=2 %cycle;  ! UNTIL NO MORE <SC>S
                     C1_LVL = L; C1_TF = ALT
                     C1_TF = C1_TF!!(3*REVERSED)
{GT: experimenting with reversing}

                     %if REVERSED=1 %then %start
                       ! Apply de-morgan to operators
                       %if alt=1 %then outstring(" || ") %else outstring(" && ")
                     %else
                       %if alt=1 %then outstring(" && ") %else outstring(" || ")
                     %finish


                     CPTR = CPTR+1
                     C1 == CLIST(CPTR); C1 = 0
                     SKIP SC(REVERSED)
                     ALTP = A(P); P = P+1
                  %repeat
               %finish
            %end
!%routine WRITE CONDLIST
!%conststring(5) %array CM(0:10)="     ","    =","   >=","    >",
!                       "    #","   <=","    <","   \=","   ->",
!                       "   ==","  \=="
!      PRINTSTRING("
! NO   TF   C1   C2   LABU   LVL  JMP  REV   LABNO JUMPED
!")
!      %cycle CPTR=1,1,CMAX
!         C1==CLIST(CPTR)
!         WRITE(CPTR,2)
!         WRITE(C1_TF,4)
!         PRINTSTRING(CM(C1_CMP1))
!         PRINTSTRING(CM(C1_CMP2))
!         WRITE(C1_LABU,6)
!         WRITE(C1_LVL,5)
!         WRITE(C1_JMP,4)
!         WRITE(C1_REV,4)
!         WRITE(C1_LABNO,7)
!         WRITE(C1_JUMPED,6)
!         NEWLINE
!      %repeat
!%end
         %end;                           ! OF CCOND
         %integer %fn REVERSE(%integer MASK)
!***********************************************************************
!*       REVERSE THE MASK FOR A JCC(MASK<=15),JAT(>15) OR JAF(>31)     *
!***********************************************************************
            %if MASK=0 %or MASK=15 %then %result = MASK!!15
            %result = MASK!!X'8F'
         %end

         %integer %fn ENTER LAB(%integer LAB,FLAGS)
         %result=0
         %end
         %routine ENTER JUMP(%integer TFMASK,LAB,FLAGS)
         %end
         %routine REMOVE LAB(%integer LAB)
         %end
         %integer %fn CREATE AH(%integer MODE, %record (RD) %name EOPND,NOPND)
!***********************************************************************
!*       CREATES AN ARRAYHEAD IN THE ESTACK BY MODIFYING THE           *
!*       HEAD ALREADY THERE AS FOLLOWS:-                               *
!*       MODE=0 (ARRAYMAPPING)  ETOS-4&5 HAS 32BIT ADDR OF FIRST ELEMNT*
!*       MODE=1 (ARRAYS IN RECORDS)ETOS-4&5 HAS 32BIT RELOCATION FACTOR*
!***********************************************************************
            %integer JJ
            JJ = BRECTRIP(AHADJ,AHEADPT,0,EOPND,NOPND)
            TRIPLES(JJ)_X1 = PTYPE<<4!MODE
            %result = JJ
         %end;                           ! OF ROUTINE CREATE AH
         %routine CSNAME(%integer Z)
!***********************************************************************
!*       COMPILE A SPECIAL NAME - PTYPE=10006 (=%routine %label)       *
!*       THEIR TRUE PTYPE IS IN GLOBAL ARRAY TAGS_S2.                  *
!*       SNINFO HAS A FOUR BYTE RECORD FOR EACH NAME (%bi FLAG,PTR,    *
!*       %si XTRA). THE TOP BITS OF FLAG CATEGORISE AS FOLLOWS:-       *
!*       2**7 SET FOR IMPLICITLY SPECIFIED CONSTRUCT A %spec           *
!*       2**6 SET FOR IOCP CALL                                        *
!*       2**5 SET FOR BUILT IN MAPPING FUNCTIONS                       *
!*       2**4 SET IF AD-HOC CODE PLANTED BY THIS ROUTINE               *
!*       2**3 SET IF FIRST PARAMETER IS OF %name TYPE                  *
!*       2**2-2**0 HOLD NUMBER OF PARAMS                               *
!*                                                                     *
!*       THE FULL SPECS ARE AS FOLLOWS:-                               *
!*       0=%routine SELECT INPUT(%integer STREAM)                      *
!*       1=%routine SELECT OUTPUT(%integer STREAM)                     *
!*       2=%routine NEWLINE                                            *
!*       3=%routine SPACE                                              *
!*       4=%routine SKIP SYMBOL                                        *
!*       5=%routine READ STRING(%stringname S)                         *
!*       6=%routine NEWLINES(%integer N)                               *
!*       7=%routine SPACES(%integer N)                                 *
!*       8=%integerfn NEXT SYMBOL                                      *
!*       9=%routine PRINT SYMBOL(%integer SYMBOL)                      *
!*       10=%routine READ SYMBOL(%name SYMBOL)                         *
!*       11=%routine READ(%name NUMBER)                                *
!*       12=%routine WRITE(%integer VALUE,PLACES)                      *
!*       13=%routine NEWPAGE                                           *
!*       14=%integerfn ADDR(%name VARIABLE)                            *
!*       15=%longrealfn ARCSIN(%longreal X)                            *
!*       16=%integerfn INT(%longreal X)                                *
!*       17=%integerfn INTPT(%lonrgreal X)                             *
!*       18=%longrealfn FRACPT(%longreal X)                            *
!*       19=%routine PRINT(%longreal NUMBER,%integer BEFORE,AFTER)     *
!*       20=%routine PRINTFL(%longreal NUMBER,%integer PLACES)         *
!*       21=%realmap REAL(%integer VAR ADDR)                           *
!*       22=%integermap INTEGER(%integer VAR ADDR)                     *
!*       23=%longrealfn MOD(%longreal X)                               *
!*       24=%longrealfn ARCCOS(%longreal X)                            *
!*       25=%longrealfn SQRT(%longreal X)                              *
!*       26=%longrealfn LOG(%longreal X)                               *
!*       27=%longrealfn SIN(%longreal X)                               *
!*       28=%longrealfn COS(%longreal X)                               *
!*       29=%longrealfn TAN(%longreal X)                               *
!*       30=%longrealfn EXP(%longreal X)                               *
!*       31=%routine CLOSE STREAM(%integer STREAM)                     *
!*       32=%byteintegermap BYTE INTEGER(%integer VAR ADDR)            *
!*       33=%integerfn EVENTINF                                        *
!*       34=%longrealfn RADIUS(%longreal X,Y)                          *
!*       35=%longrealfn ARCTAN(%longreal X,Y)                          *
!*       36=%byteintegermap LENGTH(%stringname  S)                     *
!*       37=%routine PRINT STRING(%string(255) MESSAGE)                *
!*       38=%integerfn NL                                              *
!*       39=%longrealmap LONG REAL(%integer VAR ADDR)                  *
!*       40=%routine PRINT CH(%integer CHARACTER)                      *
!*       41=%routine READ CH(%name CHARACTER)                          *
!*       42=%stringmap STRING(%integer VAR ADDR)                       *
!*       43=%routine READ ITEM(%stringname ITEM)                       *
!*       44=%string(1)%fn NEXT ITEM                                    *
!*       45=%byteintegermap CHARNO(%stringname STR,%integer CHARREQD)  *
!*       46=%string(1)%fn TOSTRING(%integer SYMBOL)                    *
!*       47=%string(255)%fn SUBSTRING(%stringname S,%integer BEG,END)  *
!*       48=%recordmap RECORD(%integer REC ADDR)                       *
!*       49=%arraymap ARRAY(%integer A1ADDR,%arrayname FORMAT)         *
!*       50=%integerfn SIZEOF(%name X)                                 *
!*       51=%integerfn IMOD(%integer VALUE)                            *
!*       52=%longrealfn PI                                             *
!*       53=%integerfn EVENTLINE                                       *
!*       54=%longintegermap LONGINTEGER(%integer ADR)                  *
!*       55=%longlongrealmap LONGLONGREAL(%integer ADR)                *
!*       56=%longintgerefn LENGTHENI(%integer VAL)                     *
!*       57=%longlongrealfn LENGTHENR(%longreal VAL)                   *
!*       58=%integerfn SHORTENI(%longinteger VAL)                      *
!*       59=%longrealfn SHORTENR(%longlongreal VAL)                    *
!*       60=%integerfn NEXTCH                                          *
!*       61=%halfintegermap HALFINTEGER(%integer ADDR)                 *
!*       62=%routine PPROFILE                                          *
!*       63=%longrealfn FLOAT(%integer VALUE)                          *
!*       64=%longintegerfn LINT(%longlongreal X)                       *
!*       65=%longintegerfn LINTPT(%longlongreal X)                     *
!*       66=%shortintegermap SHORTINTEGER(%integer N)                  *
!*       67=%integerfn TRUNC(%longreal X)                              *
!***********************************************************************
%integer %fn %spec OPTMAP
%switch ADHOC(0:67)

%const %string(80) %array SMDETAILS(0:NO OF SNS) = %c
  /* 0 */ "%routine SELECT INPUT(%integer STREAM)",
  /* 1 */ "%routine SELECT OUTPUT(%integer STREAM)",
  /* 2 */ "%routine NEWLINE",
  /* 3= */ "%routine SPACE",
  /* 4= */ "%routine SKIP SYMBOL",
  /* 5= */ "%routine READ STRING(%stringname S)",
  /* 6 */ "%routine NEWLINES(%integer N)",
  /* 7 */ "%routine SPACES(%integer N)",
  /* 8 */ "%integerfn NEXT SYMBOL",
  /* 9= */ "%routine PRINT SYMBOL(%integer SYMBOL)",
  /* 10 */ "%routine READ SYMBOL(%name SYMBOL)",
  /* 11 */ "%routine READ(%name NUMBER)",
  /* 12 */ "%routine WRITE(%integer VALUE,PLACES)",
  /* 13 */ "%routine NEWPAGE",
  /* 14= */ "%integerfn ADDR(%name VARIABLE)",
  /* 15 */ "%longrealfn ARCSIN(%longreal X)",
  /* 16 */ "%integerfn INT(%longreal X)",
  /* 17 */ "%integerfn INTPT(%lonrgreal X)",
  /* 18 */ "%longrealfn FRACPT(%longreal X)",
  /* 19 */ "%routine PRINT(%longreal NUMBER,%integer BEFORE,AFTER)",
  /* 20 */ "%routine PRINTFL(%longreal NUMBER,%integer PLACES)",
  /* 21 */ "%realmap REAL(%integer VAR ADDR)",
  /* 22 */ "%integermap INTEGER(%integer VAR ADDR)",
  /* 23 */ "%longrealfn MOD(%longreal X)",
  /* 24 */ "%longrealfn ARCCOS(%longreal X)",
  /* 25 */ "%longrealfn SQRT(%longreal X)",
  /* 26 */ "%longrealfn LOG(%longreal X)",
  /* 27 */ "%longrealfn SIN(%longreal X)",
  /* 28 */ "%longrealfn COS(%longreal X)",
  /* 29 */ "%longrealfn TAN(%longreal X)",
  /* 30 */ "%longrealfn EXP(%longreal X)",
  /* 31 */ "%routine CLOSE STREAM(%integer STREAM)",
  /* 32 */ "%byteintegermap BYTE INTEGER(%integer VAR ADDR)",
  /* 33 */ "%integerfn EVENTINF",
  /* 34= */ "%longrealfn RADIUS(%longreal X,Y)",
  /* 35 */ "%longrealfn ARCTAN(%longreal X,Y)",
  /* 36 */ "%byteintegermap LENGTH(%stringname  S)",
  /* 37 */ "%routine PRINT STRING(%string(255)",
  /* 38 */ "%integerfn NL",
  /* 39= */ "%longrealmap LONG REAL(%integer VAR ADDR)",
  /* 40 */ "%routine PRINT CH(%integer CHARACTER)",
  /* 41 */ "%routine READ CH(%name CHARACTER)",
  /* 42 */ "%stringmap STRING(%integer VAR ADDR)",
  /* 43 */ "%routine READ ITEM(%stringname ITEM)",
  /* 44 */ "%string(1)",
  /* 45 */ "%byteintegermap CHARNO(%stringname STR,%integer CHARREQD)",
  /* 46 */ "%string(1)",
  /* 47 */ "%string(255)",
  /* 48 */ "%recordmap RECORD(%integer REC ADDR)",
  /* 49 */ "%arraymap ARRAY(%integer A1ADDR,%arrayname FORMAT)",
  /* 50 */ "%integerfn SIZEOF(%name X)",
  /* 51 */ "%integerfn IMOD(%integer VALUE)",
  /* 52 */ "%longrealfn PI",
  /* 53= */ "%integerfn EVENTLINE",
  /* 54= */ "%longintegermap LONGINTEGER(%integer ADR)",
  /* 55 */ "%longlongrealmap LONGLONGREAL(%integer ADR)",
  /* 56 */ "%longintgerefn LENGTHENI(%integer VAL)",
  /* 57 */ "%longlongrealfn LENGTHENR(%longreal VAL)",
  /* 58 */ "%integerfn SHORTENI(%longinteger VAL)",
  /* 59 */ "%longrealfn SHORTENR(%longlongreal VAL)",
  /* 60 */ "%integerfn NEXTCH",
  /* 61= */ "%halfintegermap HALFINTEGER(%integer ADDR)",
  /* 62 */ "%routine PPROFILE",
  /* 63= */ "%longrealfn FLOAT(%integer VALUE)",
  /* 64 */ "%longintegerfn LINT(%longlongreal X)",
  /* 65 */ "%longintegerfn LINTPT(%longlongreal X)",
  /* 66 */ "%shortintegermap SHORTINTEGER(%integer N)",
  /* 67 */ "%integerfn TRUNC(%longreal X)"


%const %integer %array SNINFO(0:NO OF SNS)= %c
        X'41080001',X'41090001',X'408A0001',X'40A00001',
        X'40010001',X'800D0000',X'11010001',X'11010001',
        X'10020024',X'41030001',X'19030001',X'80130001',
        X'80170014',X'408C0001',X'19050024',X'80010002',
        X'11040024',X'11040024',X'80010005',X'80090006',
        X'80060007',X'2100003E',X'2100003E',X'11060024',
        X'80010008',X'80010009',X'8001000A',X'8001000B',
        X'8001000C',X'8001000D',X'8001000E',X'8015000F',
        X'2100003E',X'100D0024',X'80030010',X'80030011',
        X'1907003E',X'41070001',X'10080024',X'2100003E',
        X'41050001',X'19030001',X'2100003E',X'19030001',
        X'10020024',X'1A07003E',X'11090024',X'800F0012',
        X'110A0018',X'120B1000',X'80130013',X'11060024',
        X'100C0024',X'100D0024',X'2100003E'(2),
        X'110E0024'(4),
        X'10020024',X'2100003E',X'100F0001',X'11100024',
        X'11110024',X'11110024',X'2100003E',X'11040024'


%const %string (13) %array SNXREFS(0:20)= %c
      "s#readstring", "s#read",   "s#iarcsin", "s#int",
      "s#intpt" , "s#fracpt", "s#print" , "s#printfl",
      "s#iarccos","sqrt" , "log"  , "sin",
      "cos"  , "tan"  , "exp"  , "s#closestream",
      "s#iradius","atan2","imp_substring","s#sizeof",
      "s#write"

!
! SNPARAMS HOLDS NUMBER AND PTYPE OF FORMAL PARAMETER FOR IMPLICITLY
! SPECIFIED EXTERNAL ROUTINES. A POINTER IN SNINFO MEANS THAT NO
! DUPLICATES NEED TO BE RECORDED.
!
            %if PARAMS BWARDS=YES %then %start
   %const %integer %array SNPARAMS(0:25)=0{NO PARAMS},
   8<<16!1,LRLPT{%LONGREAL X},
   16<<16!2,8<<16!LRLPT,LRLPT{%LONGREAL X,Y},
   12<<16!2,12<<16!LRLPT,4<<16!X'51'{%LONGREAL X,%INTEGER I},
   16<<16!3,8<<16!LRLPT,4<<16!X'51',X'51'{%LONGREAL X,%INTEGER I,J},
   8<<16!1,X'435'{%STRINGNAME S},
   16<<16!3,8<<16!X'435',4<<16!X'51',X'51'{%STRINGNAME S,%INTEGER I,J},
   8<<16!1,X'400'{%NAME X},
   4<<16!1,X'51'{%INTEGER I},
   8<<16!2,4<<16!X'51',X'51'{%INTEGER I,J}
 %finish %else %start
   %const %integer %array SNPARAMS(0:25)=0{NO PARAMS},
   8<<16!1,LRLPT{%LONGREAL X},
   16<<16!2,LRLPT,8<<16!LRLPT{%LONGREAL X,Y},
   12<<16!2,LRLPT,8<<16!X'51'{%LONGREAL X,%INTEGER I},
   16<<16!3,LRLPT,8<<16!X'51',12<<16!X'51'{%LONGREAL X,%INTEGER I,J},
   8<<16!1,X'435'{%STRINGNAME S},
   16<<16!3,X'435',8<<16!X'51',12<<16!X'51'{%STRINGNAME S,%INTEGER I,J},
   8<<16!1,X'400'{%NAME X},
   4<<16!1,X'51'{%INTEGER I},
   8<<16!2,X'51',4<<16!X'51'{%INTEGER I,J}
 %finish
!
%const %byte %integer %array WRONGZ(0:15)=27,29,23,29,29,23,82,109(5),
                            23,27,109(2)

%routine %spec RTOS
%integer %fn %spec CIOCP(%integer N, %record (RD) %name PARAM)
%record (LISTF) %name LCELL
%record (LISTF) PCELL
%record (RD) OPND,OPERATOR
%record (TRIPF) %name CURRT
%string (31) SNXREF
%integer ERRNO,FLAG,POINTER,PIN,SNNO,SNNAME,NAPS,SNPTYPE,JJ,XTRA,
   IOCPEP,B,D,SNINF,P0,OPHEAD,ERRVAL,EXPHEAD,EXPBOT,formatname,NOPS
      SNNAME = FROM AR2(P)
      SNNO = K;                    ! INDEX INTO SNINFO
      TESTAPP(NAPS);               ! COUNT ACTUAL PARAMETERS
      PIN = P; P = P+2
      SNPTYPE = ACC
      SNINF = SNINFO(SNNO)
      XTRA = SNINF&X'FFFF'
      POINTER = (SNINF>>16)&255
      FLAG = SNINF>>24
      %if snptype&255=x'61' %and 1<<Target&LINTAVAIL=0 %then %c
         errno=99 %and ->errexit
!
! THE IMPLICITLY SPECIFIED ROUTINE ARE THE EASIEST OF ALL TO DEAL WITH.
! JUST SET UP THE EXTERNAL SPEC & PARAMETERS. THEN A RECURSIVE CALL
! OF CNAME THEN FINDS THE ROUTINE UNDER ITS TRUE COLOURS AND COMPILES
! THE CALL. ALL CALLS EXCEPT THE FIRST ARE DEALT WITH DIRECTLY BY CNAME.
! ALL NONTRIVIAL ROUTINES SHOULD BE DEALT WITH IN THIS MANNER
! XTRA HAS INDEX INTO ARRAY OF EXTERNAL NAMES SO THAT THESE
! CAN EASILY BE CHANGED.
!
      ->adhoc(snno)
adhoc(47):                                   ! substring
         outstring("imp_substring(")
      p=p+1; cstrexp(0); outsym(',')
      p=p+1; csexp(x'51'); outsym(',')
      p=p+1; csexp(x'51'); outsym(')');
      p=p+1; ->OKEXIT
adhoc(24):                                   ! arccos
adhoc(25):                                   ! sqrt
adhoc(26):                                   ! log
adhoc(27):                                   ! sin
adhoc(28):                                   ! cos
adhoc(29):                                   !tan
adhoc(30):                                   ! exp
      SNXREF = SNXREFS(XTRA)
      P0 = SNPARAMS(POINTER)
      %if TARGET=PERQ %or TARGET=ACCENT %then %start
         JJ = ADDR(SNXREF)
         D = LENGTH(SNXREF)
         MOVE BYTES(D+1,JJ,0,ADDR(A(0)),WORKA_ARTOP)
         JJ = ADDR(A(WORKA_ARTOP))-ADDR(A(WORKA_DICTBASE))
         WORKA_ARTOP = (WORKA_ARTOP+D+4)&(-4)
      %finish %else CXREF(SNXREF,3*PARM_DYNAMIC,P0<<16!P0>>16,JJ)
                                ! JJ SET WITH REF DISPLACEMENT
      OPHEAD = 0
      K = OPHEAD; D = 1
      %while D<=P0&15 %cycle
         B = SNPARAMS(POINTER+D)
         PTYPE = B&X'FFFF'
         UNPACK
         %if NAM=0 %then ACC = BYTES(PREC) %else ACC = 8
         %if PTYPE=X'35' %then ACC = 256;  !STRING BY VALUE
         PCELL = 0;             ! SET UP PARAMETER DESC VIA RECORD
         PCELL_PTYPE <- PTYPE;  ! FOR CONSISTENCY ON BYTE SWOPPED%c
                                HOSTS
         PCELL_SNDISP = B>>16
         PCELL_ACC <- ACC
         %if PARAMS BWARDS=YES %then %c
            PUSH(OPHEAD,PCELL_S1,PCELL_S2,0) %else %c
            INSERTAT END(OPHEAD,PCELL_S1,PCELL_S2,0)
         D = D+1
      %repeat
      %if P0>0 %then ASLIST(OPHEAD)_S3 = P0;  ! INSERT NO OF PARAMS
                                ! UPPER PART OF P0(TOTAL PARAMSPACE)
                                ! APPARENTLY NOT NEEDED AS NO BODIES
                                ! ARE PROVIDED.
      LCELL == ASLIST(TAGS(SNNAME))
      LCELL_PTYPE = SNPTYPE
      LCELL_UIOJ = 1<<4!14;     ! I=1 & J=14
      LCELL_SNDISP <- JJ;       ! RT ENTRY DISPLACEMENT
      LCELL_ACC = BYTES(SNPTYPE>>4&15)
      LCELL_SLINK = OPHEAD
      LCELL_KFORM = 0;          ! KFORM(=FORMAT INFO)
      P = PIN; CNAME(Z);        ! RECURSIVE CALL
      P = P-1; %return;         ! DUPLICATES CHECK OF <ENAME>
ADHOC(6):ADHOC(7):                       ! NEWLINES(=6) & SPACES(=7)
      %if parm_arr=0 %start
         %if snno=6 %then outstring("_imp_newlines(") %else outstring("_imp_spaces(")
         p=p+1; csexp(x'51')
         outsym(')')
         p=p+1
         ->OKEXIT
      %finish
      p=p+1
      %if tsexp(jj)>0 %and jj>0 %start
{GT:}    outstring("fprintf(out_file, "); outsym('"')
         %for xtra=1,1,jj %cycle
            %if snno=6 %then outstring("\n") %else outstring(" ")
        %repeat
         outsym('"'); outsym(')')
      %else
         p=PIN+3
         outstring("{ for (_imptempint=1; _imptempint<=")
         csexp(x'51')
         outstring("; _imptempint++) fprintf(out_file, "); outsym('"')
         %if snno=6 %then outstring("\n") %else outstring(" ")
         outsym('"')
         outstring(");}")
      %finish
      P = P+1
      ->OKEXIT
ADHOC(37):                                  ! printstring
      %if parm_arr=0 %then %start
        outstring("_imp_printstring(")
      %finishelsestart
{GT:}   outstring("fprintf(out_file, "); outsym('"'); outstring("%s")
        outsym('"'); outstring(", ")
      %finish
      p=p+1
      cstrexp(0)
      outstring(")")
      P=P+1; ->OKEXIT
adhoc(2):                                   ! newline
      %if parm_arr=0 %start
         outstring("_imp_newlines(1)")
      %else
{GT:}    outstring("fprintf(out_file, "); outsym('"'); outstring("%s")
         outsym('"'); outstring(", "); outsym('"'); outsym('\')
         outsym('n'); outsym('"');outsym(')')
      %finish
      P=P+1; ->OKEXIT
adhoc(3):                                        ! space
      %if parm_arr=0 %start
         outstring("_imp_spaces(1)")
      %else
{GT:}    outstring("fprintf(out_file, "); outsym('"'); outstring("%s")
         outsym('"'); outstring(", "); outsym('"'); outsym(' ')
         outsym('"'); outsym(')')
      %finish
      P=P+1; ->OKEXIT
adhoc(21):                                  ! real
adhoc(22):                                  ! integer
adhoc(61):                                  ! halfinteger
adhoc(66):                                  ! shortinteger
adhoc(39):                                  ! longreal
adhoc(32):                                  ! byteinteger
adhoc(54):adhoc(55):                         ! long int & longlongreal
      outstring("(*(")
      outtype(snptype&255,0)
      outstring(" *)(")
      p=p+1; csexp(x'51')
      outstring("))")
      P=P+1; ->OKEXIT
adhoc(42):                                  ! string
      outstring("((char *)")
      p=p+1; csexp(x'51')
      outstring(")")
      P=P+1; ->OKEXIT
adhoc(45):                                   ! charno
{GT: Needs special handling for charno(s,0); also for LHS = ..}
      %if z#2 %then warn(10,0)
      p=p+1; cstrexp(0)
      outsym('[')
      p=p+1; csexp(x'51')
      outstring("-1]")
      p=p+1
      ->OKexit
ADHOC(36):                               ! length
{GT: Also needs special treatment on LHS }
      %if z#2 %then warn(10,0)
      outstring("strlen(")
      p=p+1; cstrexp(0)
      outstring(")")
      P=P+1; ->OKEXIT
adhoc(46):                                  ! tostring
      outstring("imp_tostring(")
      p=p+1; csexp(x'51')
      outstring(")")
      P=P+1; ->OKEXIT
ADHOC(9): adhoc(40):                      ! printsymbol & printch
      %if parm_arr=0 %start
         outstring("_imp_printsymbol(")
      %else
{GT:}    outstring("fprintf(out_file, ");
         outsym('"')
         outstring("%c")
         outsym('"');
         outstring(", ");
      %finish
      p=p+1; csexp(x'51')
      outstring(")")
      P = P+1
      ->OKEXIT
ADHOC(12):                               ! write
      %if parm_arr=0 %start
         outstring("_imp_write(")
         p=p+1; csexp(x'51'); outsym(',')
         p=p+1; csexp(x'51'); outsym(')')
         p=P+1; ->OKEXIT
      %finish
      p=p+1; skip exp; p=p+1; jj=tsexp(xtra)
      p=PIN+2
      %if jj#0 %start
         outstring("fprintf(out_file, "); outsym('"'); outstring("%")
         outint(imod(xtra)+1); outstring("d"); outsym('"'); outstring(",")
      %else
         outstring("fprintf(out_file, "); outsym('"'); outstring(" %d"); outsym('"'); outstring(",")
      %finish
      p=p+1; csexp(x'51')
      outstring(")")
      p=PIN+2; skip app
      p=p-1; ->OKEXIT
ADHOC(19):                               ! print
      %if parm_arr=0 %start
         outstring("_imp_print(")
         p=p+1; csexp(x'62'); outsym(',')
         p=p+1; csexp(x'51'); outsym(',')
         p=p+1; csexp(x'51'); outsym(')')
      %else
         outstring("fprintf(out_file, "); outsym('"'); outstring(" %f"); outsym('"'); outstring(",")
         p=p+1; csexp(x'62')
         outstring(")")
      %Finish
      p=PIN+2; skip app
      p=p-1; ->OKEXIT
ADHOC(20):                               ! printfl
      %if parm_arr=0 %start
         outstring("_imp_printf(")
         p=p+1; csexp(x'62'); outsym(',')
         p=p+1; csexp(x'51'); outsym(')')
      %else
         outstring("fprintf(out_file, "); outsym('"'); outstring(" %e"); outsym('"'); outstring(",")
         p=p+1; csexp(x'62')
         outstring(")")
      %finish
      p=PIN+2; skip app
      p=p-1; ->OKEXIT

ADHOC(0):                               ! SELECT INPUT
      %if parm_arr=0 %start
         outstring("_imp_selectinput(")
         p=p+1; csexp(x'51'); outsym(')')
         p=p+1; ->OKEXIT
      %finish
      ! if C i-o we can not handle this so fall thru
{GT:} 
      outstring("selectinput(")
      p=p+1; csexp(x'51'); outstring(")")
      p=p+1;
      ->OKEXIT

ADHOC(1):                               ! SELECT OUTPUT
      %if parm_arr=0 %start
         outstring("_imp_selectoutput(")
         p=p+1; csexp(x'51'); outsym(')')
         p=p+1; ->OKEXIT
      %finish
      ! if C i-o we can not handle this so fall thru
{GT:} 
      outstring("selectoutput(")
      p=p+1; csexp(x'51'); outstring(")")
      p=p+1;
      ->OKEXIT

ADHOC(*):                                ! NEXTSYMBOL(=8) & NEXTITEM(=44)
                                         ! ALSO ANY WITH NO C EQUIVALENTS
{GT:} outstring("/* Call to ");
      outstring(SMDETAILS(snno));
      outstring (" - please modify pass2.i to handle it */")
      skip app; p=p-1; -> OKEXIT
ADHOC(64):ADHOC(65):                      ! LINT(=64) AND LINTPT(=65)
            %unless TYPEFLAG(10)&255=X'61' %and TYPEFLAG(12)&255>=X'62' %then %c
               ERRNO = 99 %and ->ERREXIT
! NEED LONGINTS&LLREALS
      outstring("((long int) floor(")
      p=p+1
      CSEXP(typeflag(12)&255);    ! LONGLONGREAL MODE or longreal if defaulted
      %if SNNO=64 %then outstring("+0.5")
      outstring("))")
      P = P+1
      P0 = X'61'; ->OKEXIT
ADHOC(16):ADHOC(17):                      ! INT(=16) AND INTPT (=17)
      outstring("((int) floor(")
      p=p+1
      CSEXP(LRLPT)
      %if SNNO=16 %then outstring("+0.5")
      outstring("))")
      P = P+1
      ->OKEXIT
ADHOC(67):                                 ! trunc
      outstring("((int)(")
      p=p+1
      CSEXP(LRLPT)
      outstring("))")
      P = P+1
      ->OKEXIT

{GT:}
ADHOC(4):                                ! SKIP SYMBOL
      outstring("(void)fgetc(in_file)")
      P = P+2 { DON'T KNOW HOW MUCH TO ALTER P BY }; ->OKEXIT

ADHOC(8):                                ! NEXT SYMBOL
      P = P+6;
      CNAME(1);
      outstring("ungetc(fgetc(in_file), in_file)")
      P = P+2; ->OKEXIT

ADHOC(10):                                ! READ SYMBOL
ADHOC(41):                                ! READ CH
      P = P+6;
      CNAME(1);
      outstring(" = fgetc(in_file)")
      P = P+2; ->OKEXIT

ADHOC(14):                                ! ADDR(=14)
      P = P+6; CNAME(4);           ! FETCH ADDRESS MODE
      P = P+2; ->OKEXIT
ADHOC(23):                                ! MOD(=23)
      outstring("fabs(")
      p=p+1
      csexp(x'62')
      outstring(")")
      P = P+1
      ->OKEXIT
ADHOC(51):                               ! imod
      outstring("abs(")
      p=p+1
      csexp(x'51')
      outstring(")")
      P = P+1
      ->OKEXIT
ADHOC(52):                               ! PI(=52)
ADHOC(38):                                ! NL(=38). THIS FN IS PICKED OFF
            P = P+1
            ->OKEXIT;                    ! ERROR EG NL=A+B
ADHOC(48):                               ! RECORD(=48)
      p=p+1
      %if tsexp(jj)=1 %and jj=0 %start
         outstring("NULL")
      %else
         %if z#4 %start
            outsym('(')
!            outsym('('); outtype(x'33',lhformatname)
!            outsym('*')
!            outsym(')')
         %finish
         p=PIN+3
         CSEXP(X'51')
         P = P+1
         outsym(')')
      %finish
      DISP = 0; BASE = 0; ACCESS = 3
      OLDI = 0; ACC = X'FFFF'
      SNPTYPE = SNPTYPE+X'1C00';   ! ADD MAP BITS
      PTYPE = SNPTYPE; UNPACK
      %return
ADHOC(49):                               ! ARRAY(=49)
      p=p+1
      skip exp
      ERRNO = 22; ERRVAL = 2
      ->ERREXIT %unless A(P+4)=4 %and A(P+5)=1
      P = P+6; formatname=fromar2(p)
      copytag(formatname,NO)
      p=p+4
      ->ERREXIT %unless A(P)=2
      xtra=p+2
      outstring("(("); outtype(ptype&255,lhformatname)
      outstring("*)(")
      p=PIN+3
      CSEXP(X'51');                ! ADDR(A(0)) TO NEST
      outstring("))")
      copytag(formatname,NO)
      P = xtra
      %return
ADHOC(13):                               ! EVENTINF(=33) & EVENTLINE
            D = CURRINF_ONINF
            FAULT(16,0,SNNAME) %if D=0
            D = D+4 %if SNNO#33
            BASE = RBASE; ACCESS = 0
            DISP = D; SNPTYPE = SNPTYPE+X'1C00';  ! ADD MAP BITS
            ->OKEXIT
!ADHOC(14):                               ! LENGTHEN AND SHORTEN
            D = (SNNO&3)*8
            JJ = X'62517261'>>D&255
            %if 1<<TARGET&LLREALAVAIL=0 %and JJ=X'72' %then JJ = X'62'
            %if 1<<TARGET&LINTAVAIL=0 %and JJ=X'61' %then JJ = X'51'
            CSEXP(JJ)
            P = P+1
            NAMEOPND = EXPOPND
            ->OKEXIT
ADHOC(15):                               ! PPROFILE(IGNORED UNLESS PARM SET)
            JJ = UCONSTTRIP(PPROF,X'51',0,PROFAAD) %unless PARM_PROF=0
            ->OKEXIT
!ADHOC(16):                               ! FLOAT
            CSEXP(LRLPT)
            NAMEOPND = EXPOPND
            P = P+1
OKEXIT:                                  ! NORMAL EXIT
            PTYPE = SNPTYPE; UNPACK
            ACC = BYTES(PREC)
            %return
ERREXIT:                                 ! ERROR EXIT
            FAULT(ERRNO,ERRVAL,SNNAME)
            NAMEOPND = 0; NAMEOPND_PTYPE = X'51'
            BASE = 0; DISP = 0; ACCESS = 0; AREA = 0
            PTYPE = SNPTYPE; UNPACK
            P = PIN+2; SKIP APP
            P = P-1; %return
            %integer %fn CIOCP(%integer EP, %record (RD) %name PARAM)
!***********************************************************************
!*    CALL IOCP PASSING A PARAMETER
!*    RETURNS THE TRIPLE NO OF THE CALL
!***********************************************************************
               %record (RD) OPND
               OPND_PTYPE = MINAPT; OPND_FLAG = SCONST
               OPND_D = EP
               %result = BRECTRIP(IOCPC,MINAPT,DONT OPT,OPND,PARAM)
            %end
            %routine RTOS
!***********************************************************************
!*       PLANTS CODE TO CONVERT A SYMBOL IN EXPOPND TO A ONE           *
!*       CHARACTER STRING IN A TEMPORARARY VARIABLE.                   *
!***********************************************************************
               %integer KK,JJ
               %if EXPOPND_FLAG<=1 %start
                  KK = ITOS1
                  CTOP(KK,JJ,0,EXPOPND,NAMEOPND)
                  %if KK=0 %then NAMEOPND = EXPOPND %and %return
               %finish
               JJ = URECTRIP(ITOS1,X'35',0,EXPOPND)
               NAMEOPND_PTYPE = X'35'; NAMEOPND_FLAG = REFTRIP
               NAMEOPND_D = JJ
            %end
         %end;                           ! OF ROUTINE CSNAME
         %routine CANAME(%integer Z,ARRP, %record (RD) %name HDOPND)
!***********************************************************************
!*       BS & DP DEFINE THE POSITION OF THE ARRAY HEAD                 *
!*       ARRP=1 FOR ARRAYS,2 FOR VECTORS,3 FOR ARRAYS IN RECORDS       *
!*       BASIC DISP = DISPMNT OF A(0) FOR VECTORS OR ARRAYS IN RECORDS *
!***********************************************************************
%integer HEAD1,BOT1,NOPS,ELSIZE,PTYPEP,JJ,SOLDI,KK,PP,TYPEP,LB,
   ARRNAME,Q,PRECP,NAMINF,DVD,DVDP,PRIVOPS
%record (RD) VMYOP,RPOP
%record (TAGF) %name LCELL
%integer %array HEADS,BOTS(0:12)
            NOPS = 0; HEAD1 = 0; BOT1 = 0
            PP = P; TYPEP = TYPE
            JJ = J; PTYPEP = PTYPE; PRECP = PREC; SOLDI = OLDI
            %if TYPE<=2 %then ELSIZE = BYTES(PRECP) %else ELSIZE = ACC
            %if ELSIZE>4095 %or (TYPE=5 %and NAM#0) %then ELSIZE = 0
            DVD = SNDISP;                ! LOCATION OF DV IF CONSTANT
            VMYOP_FLAG = 0; VMYOP_XB = 0
            ARRNAME = FROM AR2(P);       ! NAME OF ENTITY
            NAMINF = TAGS(ARRNAME)
            FAULT(87,0,ARRNAME) %if ARR=3;  ! ARRAYFORMAT USED AS ARRAY
!            NAMINF = -2 %and DVD = 0 %if ARRP>2;  ! ARRAYS IN RECORDS
            %if DVD>0 %then VMYOP_PTYPE = X'51' %and VMYOP_D = DVD %else %c
               VMYOP = HDOPND
            TEST APP(Q);                 ! COUNT NO OF SUBSCRIPTS
!
! CHECK CORRECT NO OF SUBSCRIPTS PROVIDED. HOWEVER ENTITIES DECLARED
! AS %<TYPE>ARRAYNAME HAVE NO DIMENSION . THIS SECTION SETS THE
! DIMENSION FROM THE FIRST USE OF THE NAME.
!
            %if JJ=0 %then %start;       ! 0 DIMENSIONS = NOT KNOWN
               LCELL == ASLIST(TCELL)
               LCELL_UIOJ = LCELL_UIOJ!Q;  ! DIMSN IS BOTTOM 4 BITS OF TAG
               JJ = Q
            %finish
            %if JJ=Q#0 %then %start;     ! IN LINE CODE
!
! FOR IN-LINE CODE WE SET UP A CHAIN OF REVERSE POLISH OPERATIONS TO
! EVALUATE THE VARIOUS SUBSCRIPTS,MULTIPLY BY THE MULTIPLIERS AND
! ADD THEM TOGETHER.
!
!
! NOW PROCESS THE SUBSCRIPTS CALLING TORP TO CONVERT THE EXPRESSIONS
! TO REVERSE POLISH AND ADDING THE EXTRA OPERATIONS.
!
               P = PP+3
               %cycle KK = 1,1,JJ;       ! THROUGH THE SUBSCRIPTS
                  heads(kk)=p; skip exp
                  P = P+1
               %repeat
               pp=p; outstring(" [")
               DVDP=DVD+3*jj
               %cycle KK = jj,-1,1
                  p=heads(kk); csexp(x'51')
                  LB=Ctable(DVDP)
                  %if DVD#0 %start    { we know how to adjust bounds }

!GT: remove the correction for the lower bound from array accesses
!    because we now do the correction at the point of declaration

                     %if LB=x'80000000' %start
!GT:                    outstring("-(")
!GT:                    p=Ctable(DVDP+1); csexp(x'51'); outsym(')')
                     %finish %else %if lb>0 %start
!GT:                    outsym('-'); outint(LB)
                     %finish %else %if LB=0 %start
!                        outint(LB)
                     %finish %else %if LB<0 %start
!GT:                    outsym('+'); outint(-LB)
                     %finish
                  %else
                     warn(13,0)
                  %finish
                  outstring("] [") %unless kk=1
                  DVDP=DVDP-3
               %repeat
               p=pp; outsym(']')
            %finish %else %start
               RPOP = 0; RPOP_FLAG = SCONST
               BINSERT(HEAD1,BOT1,RPOP_S1,0,0)
               %if JJ>Q %then FAULT(20,JJ-Q,ARRNAME) %else %c
                  FAULT(21,Q-JJ,ARRNAME)
               P = P+2; SKIP APP
            %finish
            SOLDI = OLDI
            ACCESS = 3
            ACC = ELSIZE; PTYPE = PTYPEP; UNPACK; J = JJ
            %if TYPE=5 %and NAM>0 %then MLOPND = HDOPND
            OLDI = SOLDI;                ! FOR NAME==A(EL) VALIDATION
            %return
         %end;                           ! OF ROUTINE CANAME
%routine namepreamble(%integer z,fname)
!***********************************************************************
!*     puts any unary operators on front of the name                   *
!*     assumes ptype has been set and unpacked                         *
!***********************************************************************
%integer typep,qq,subs,pp
      typep=type
      pp=p
      %if typep=3 %then qq=copy record tag(subs) %and p=pp
      %if z=3 %and type#5 %and (nam=0 %or arr#0) %then outsym('&')
      %if z=4 %and type#5 %and (nam=0 %or arr#0) %then outstring("(int)&")
      %if z=4 %and (type=5 %or (nam#0 %and arr=0)) %then outstring("(int)")
      %if (z=1 %or z=2) %and ((nam#0 %and arr=0=rout) %orc
      (nam>=2 %and rout=1{mapping fn call })) %and type#5 %c
       %and %not(typep=3 %and qq=0){ NOT RECORD WITHOUT SUBNAME} %then outsym('*')
      %if z=7 %and typep=3 %and qq=0 %and nam#0 %and arr=0 %thenc
         outsym('*')          { record pointer without subname }
      outname(fname)
      %if typep=3 %then copy tag(fname,no)
%end
!*
         %routine CNAME(%integer Z)
!***********************************************************************
!*       THIS IS THE MAIN ROUTINE FOR PROCESSING NAMES.CANAME,CSNAME   *
!*       AND CRNAME ARE ONLY CALLED FROM HERE,THE NAME (AND ANY PARAMS *
!*       OR SUBNAMES) ARE ACCESSED BY P WHICH IS ADVANCED.             *
!*       Z SPECIFIES ACTION AS FOLLOWS:-                               *
!*       Z=0 COMPILE A ROUTINE CALL                                    *
!*       Z=1 ARRANGE  A 'STORE' OPERATION FROM ESTACK                  *
!*       Z=2 FETCH NAME TO ESTACK                                      *
!*       Z=3 GET 32 BIT ADDRESS(48BIT FOR BYTES) FOR PASSING BY NAME   *
!*       Z=4 SET 20 BIT ADDRESS(36BIT FOR BYTES) OF NAME IN REG        *
!*       Z=5  AS Z=2                                                   *
!*       Z=6 STORE ETOS (CONTAINS POINTER) INTO POINTER VARIABLE       *
!*       Z=7->10  NOT NOW USED                                         *
!*       Z=11 FETCH 32 BIT ADDRESS OF ARRAYHEAD                        *
!*       Z=12 FETCH ARRAYHEAD TO ESTACK                                *
!*       Z=13 GET 4 WORD ROUTINE DISCRIPTOR                            *
!*              (INTERNAL ROUTINES FIRST CREATE THE DISCRIPTOR)        *
!*                                                                     *
!***********************************************************************
            %integer JJ,KK,LEVELP,DISPP,NAMEP,PP,SAVESL,FNAME
            %record (RD) TOPND
            %switch S,FUNNY(11:13),SW(0:8)
            PP = P
            FNAME = A(P)<<8+A(P+1)
            %if Z=1 %or Z=6 %then STNAME = FNAME
            copy tag(Fname,YES);         ! DECLARE IF UNKNOWN AT THIS POINT
            SAVESL = ACC
            JJ = J; JJ = 0 %if JJ=15
            NAMEP = FNAME
            LEVELP = I; DISPP = K
            FAULT(43,0,FNAME) %if %c
               LITL=1 %and ROUT=0=NAM %and (Z=1 %or Z=3 %or (Z=4 %and ARR=0))
            ->NOT SET %if TYPE=7
            %if (Z=0 %and (ROUT#1 %or 0#TYPE#6)) %or (Z=13 %and ROUT=0) %then %c
               FAULT(27,0,FNAME) %and ->NOT SET
            ->FUNNY(Z) %if Z>=10
            ->RTCALL %if ROUT=1
           namepreamble(z,fname)
            ->SW(TYPE)
SW(6):
            FAULT(5,0,FNAME)
            ->NOT SET
SW(4):                                   !RECORD FORMAT NAME
            FAULT(87,0,FNAME)
NOT SET:                                 ! NAME NOT SET
           namepreamble(z,fname)
SW(7):
            BASE = I; DISP = K; ACCESS = 0
            NAMEOPND = 0; NAMEOPND_PTYPE = X'51'
            PTYPE = X'51'; UNPACK
            P = P+2
            %if a(p)=1 %start
               {%if z=1 %or z=3 %or z=4 %then jj='[' %else} jj='('
               outsym(jj)
               p=p+1; csexp(x'51')
               %while a(p)=1 %cycle
                   outsym(','); p=p+1; csexp(x'51')
               %repeat
               outsym(jj+1+jj>>6)      { ')' or ']' }
           %finish
           p=p+1
          ->CHKEN
FUNNY(11):                               ! SET 32 BIT ADRESS OF ARRAYHEAD
FUNNY(12):                               ! MOVE ARRAYHEAD TO ESTACK
            %if PTYPE=SNPT %then CSNAME(12) %and ->CHKEN
            namepreamble(z,fname)
            ->SW(3) %if TYPE=3 %and (ARR=0 %or A(P+2)=1)
            %if A(P+2)=2 %then P = P+3 %else NO APP
            NAMEOPND_FLAG = DNAME
            NAMEOPND_D = FNAME
            NAMEOPND_XTRA = 0
S(12):
S(11):                                   ! ARRAYS IN RECORDS BY NAME
            NAMEOPND_PTYPE = AHEADPT
            ->CHKEN
FUNNY(13):                               ! LOAD ADDR FOR RT-TYPE
            %if PTYPE=SNPT %then CSNAME(Z) %and P = P+1 %and ->CHKEN
           namepreamble(z,fname)
            JJ = UNAMETRIP(RTFP,RTPARAMPT,0,FNAME)
            NAMEOPND_PTYPE = RTPARAMPT; NAMEOPND_FLAG = REFTRIP
            NAMEOPND_D = JJ
            NAMEOPND_XTRA = 0
            %if A(P+2)=2 %then P = P+3 %else NO APP
            ->CHKEN
RFUN:                                    ! RECORD FUNCTIONS
            EXPOPND = NAMEOPND
RMAP:                                    ! RECORD MAPS
            COPY TAG(NAMEP,NO);          ! SET KFORM ETC
            P = P-3
            NAMEP = -1
            CRNAME(Z,3,0,0,NAMEP)
            ->RBACK
SW(3):                                   ! RECORD
            CRNAME(Z,2*NAM,I,K,NAMEP)
RBACK:
            ->S(Z) %if Z>=10
            ->STRINREC %if TYPE=5 %and Z#6
            ->NOT SET %if TYPE=7
            NAMEOP(Z,BYTES(PREC),NAMEP)
            STNAME = NAMEP %if Z=1 %or Z=6
            ->CHKEN
SW(5):                                   ! TYPE =STRING
!
! ALL STRING OPERATIONS ARE ON THE RELEVANT DESCRIPTOR. Z=2 &Z=5
! REQUIRE A CURRENT LENGTH(IE MODIFIED) DESCRIPTOR. OTHER OPERATIONS
! REQUIRE THE MAX LENGTH DESCRIPTOR (IE UNMODIFIED HEADER)
!
            %if Z=6 %then ->SW(1)
            ->STRARR %if ARR>=1
            %if A(P+2)=2 %then P = P+3 %else NO APP
            BASE = I; ACCESS = 2*NAM; DISP = K
SMAP:       MLOPND = 0
            %if NAM#1 %then %start
               MLOPND_PTYPE = X'51'
               MLOPND_D = SAVESL-1
            %else
               MLOPND_PTYPE = X'61'
               MLOPND_FLAG = LOCALIR
               MLOPND_D = I<<16!K
            %finish
            NAMEOP(Z,4,NAMEP)
            ->CHKEN
STRARR:                                  ! STRINGARRAYS &  ARRAYNAMES
            TOPND = 0
            TOPND_PTYPE = AHEADPT; TOPND_FLAG = DNAME
            TOPND_D = FNAME
            CANAME(Z,ARR,TOPND)
            ->SMAP %unless Z=3 %and NAM#0
                                         ! MLOPND LEFT SET BY CANAME
            NAMEOP(3,4,NAMEP)
            ->CHKEN
STRINREC:                                ! STRINGS IN RECORDS
            SAVESL = ACC
            ->SMAP %unless Z=3 %and NAM#0 %and ARR#0
                                         ! MLOPND SET BY CANAME & SET LEFT SET%c
                                         BY CENAME
            NAMEOP(3,4,NAMEP)
            ->CHKEN
!
! SECTION TO DEAL WITH ALL NAMES INVOLVING ROUTINE CALL
!
RTCALL:                                  ! FIRST CHECK
            %if TYPE=0 %and Z#0 %then FAULT(23,0,FNAME) %and ->NOT SET
                                         ! RT NAME IN EXPRSN
            %if PTYPE=SNPT %then %start
               CSNAME(Z);                ! SPECIAL NAME
               ->BIM %if ROUT=1 %and NAM>1 %and Z#0
               ->CHKEN
            %finish
           namepreamble(z,fname)
            CRCALL(FNAME); P = P+1;      ! DEAL WITH PARAMS
            ->CHKEN %if PTYPE&15=0
            ->UDM %if NAM>1;             ! MAPS
            %unless Z=2 %or Z=5 %or Z=3=TYPE %start;  ! FUNCTIONS
               FAULT(29,0,FNAME); BASE = 0
               ACCESS = 0; DISP = 0
            %finish
            ->RFUN %if TYPE=3
            ->CHKEN
UDM:                                     ! USER DEFINED MAPS
            DISP = 0
            ACCESS = 3
            BASE = 0
            EXPOPND = NAMEOPND
            ->RMAP %if TYPE=3
BIM:                                     ! BUILT IN MAPS
            NAMEP = -1
            STNAME = -1
            %if TYPE=5 %then SAVESL = 256 %and ->SMAP
            KK = Z; KK = 2 %if Z=5
            NAMEOP(Z,BYTES(PREC),NAMEP)
            ->CHKEN
SW(0):                                   ! %name PARAMETERS NO TYPE
                                         ! ALLOW FETCH ADDR OPERATIONS
                                         ! AND SPECIAL FOR BUILTIN MAPS
            %unless 3<=Z<=4 %then %start
               FAULT(90,0,FNAME); TYPE = 1
            %finish
SW(1):                                   ! TYPE =INTEGER
SW(2):                                   ! TYPE=REAL
            %if ARR=0 %or (Z=6 %and A(P+2)=2) %then %start
               BASE = I; ACCESS = 2*NAM
               DISP = K
               %if A(P+2)=2 %then P = P+3 %else NO APP
            %finish %else %start
               TOPND = 0
               TOPND_PTYPE = AHEADPT; TOPND_FLAG = DNAME
               TOPND_D = FNAME
               CANAME(Z,ARR,TOPND)
               NAM = 0
            %finish
            NAMEOP(Z,BYTES(PREC),NAMEP)
            ->CHKEN
!
CHKEN:      %while A(P)=1 %cycle
               FAULT(69,FROMAR2(P+1),FNAME)
               outsym('_'); outname(fromar2(P+1))
               P = P+3; SKIP APP
            %repeat
            P = P+1
         %end

         %routine NAMEOP(%integer Z,SIZE,NAMEP)
         %end
         %routine CRCALL(%integer RTNAME)
!***********************************************************************
!*       COMPILE A ROUTINE OR FN CALL                                  *
!*       THE PROCEDURE CONSIST OF THREE PARTS:-                        *
!*       A) PLANT THE PARAMETER (IF ANY)                               *
!*       B) ENTER THE ROUTINE OR FN                                    *
!*       C) FORGET ANY REGISTERS WHICH HOLD ENTITIES THAT CAN BE       *
!*          ALTERED BY THE CALLED PROCEDURE.                           *
!***********************************************************************
%integer II,III,QQQ,JJ,JJJ,NPARMS,PT,LP,PSIZE,TWSP,PARMNO,ERRNO,
   FPTR,TYPEP,PRECP,NAMP,TL,CLINK,PSPECED,OUTP,PPTYPE,DVD,DVDP,LB,KK
%record (RD) OPND,OPND1,OPND2
%record (LISTF) %name LCELL
            PT = PTYPE; JJJ = J; TL = OLDI
            TWSP = 0; FPTR = 0
            LP = I; CLINK = K
            TYPEP = TYPE; PRECP = PREC; NAMP = NAM
            %if CLINK=0 %then PSPECED = 0 %else PSPECED = ASLIST(CLINK)_S3&255
!
            %begin
               %integer %array ARP(0:PSPECED)
               %switch FPD(0:3)
! NOW CHECK THAT THE RIGHT NUMBER OF PARAMETERS HAVE BEEN PROVIDED
! ALSO NOTE THE POINTERS TO ACTUAL PARAMETERS ALLOWING FOC 'C' COMPATABILITY
!
               P = P+2
               NPARMS = 0
               %while A(P)=1 %cycle
                  P = P+1
                  %if NPARMS<PSPECED %start
                     %if PARAMS BWARDS=YES %then %c
                        ARP(PSPECED-NPARMS) = P %else ARP(NPARMS+1) = P
                  %finish
                  NPARMS = NPARMS+1
                  SKIP EXP
               %repeat
               OUTP = P
               %if PSPECED#NPARMS %then %start
                                         ! WRONG NO OF PARAMETERS GIVEN
                  %if PSPECED=0 %then ERRNO = 17 %else %start
                     %if NPARMS<PSPECED %then ERRNO = 18 %else ERRNO = 19
                  %finish
                  FAULT(ERRNO,IMOD(PSPECED-NPARMS),RTNAME)
                  SKIP APP; P = P-1
                  NAMEOPND = 0; NAMEOPND_PTYPE = X'51';  ! ENSURE SENSIBLE%c
                                                         RESULT TRIPLE
                  ->OVER
               %finish
!
               II = UNAMETRIP(PRECL,PT&255,0,RTNAME)
               PARMNO = 0
               outsym('(')
               ->FIRST PARM
!
BAD PARM:                                ! BAD PARAMETER FAULT IT
            %if PARAMS BWARDS=Yes %then II=pspeced-parmno+1 %else ii=parmno
               FAULT(22,II,RTNAME)
NEXT PARM:     CLINK = LCELL_LINK
              outsym(',') %unless clink=0
FIRSTPARM:     ->ENTRY SEQ %if CLINK=0;  ! DEPART AT ONCE IF NO PARAMS
               LCELL == ASLIST(CLINK)
               PSIZE = LCELL_ACC&X'FFFF'
               PARMNO = PARMNO+1
               P = ARP(PARMNO)
               PTYPE = LCELL_PTYPE
               UNPACK
               II = TYPE; III = PREC
               JJ = (NAM<<1!ARR)&3
               ->BAD PARM %unless %c
                  (JJ=0 %and ROUT=0) %or JJ=2 %or (A(P+3)=4 %and %c
                  A(P+4)=1 %and A(P+FROMAR2(P+1)+1)=2)
               OPND_PTYPE <- PTYPE; OPND_FLAG = DNAME
               OPND_D = RTNAME
               OPND_XTRA = PARMNO<<24!CLINK
!
! RT TYPE PARAMS, PASS 4 WORDS AS SET UP  BY QCODE INSTRN LVRD
!
               %if ROUT=1 %then %start
                  II = PTYPE; P = P+5
                  CNAME(13);             ! SET UP 4 WDS IN ACC
                  ->BAD PARM %if II&255#PTYPE&255;  ! PREC&TYPE SIMILAR
                  P = P+1
                  FPTR = FPTR+RTPARAMSIZE
                  ->NEXT PARM
               %finish
               ->FPD(JJ)
FPD(0):                                  ! VALUE PARAMETERS
               %if TYPE=3 %start;        ! RECORDS BY VALUE
                  II = TSEXP(III);       ! CHECK FOR ZERO AS RECORD VALUE
                  %if II=1 %and III=0 %start
                     -> bad parm
                  %finish %else %start
                     P = ARP(PARMNO);    ! RESET NEEDED AFTER TSEXP
                     ->BAD PARM %unless %c
                        A(P+3)=4 %and A(P+4)=1 %and A(P+FROMAR2(P+1)+1)=2
                     P = P+5
                     CNAME(6)
                     P = P+1
                     JJ = 1
                     EXPOPND = NAMEOPND
                     ->BAD PARM %unless ACC=PSIZE
                  %finish
                  FPTR = FPTR+PSIZE
                  %if TARGET=EMAS %then FPTR = FPTR+8;  ! TIRESOME BACK%c
                                                        COMPATIBILITY
                                         ! WITH EMAS IMP ON RECORD VALUES
               %finish %else %if TYPE=5 %then %start
                  %if STRVALINWA=YES %start;  ! USING WORK AREA (2900)
                     CSTREXP(0)
                     PUSH(TWSP,VALUE,0,0);  ! REMEBER WA
                     FPTR = FPTR+PTRSIZE(X'35')
                     pptype = x'51'
                     %if ptrsize(x'35')>4 %then pptype = x'61'
                     opnd1 = 0; opnd2 = 0
                     opnd2_flag = sconst; opnd2_ptype = x'51'
                     opnd2_d = lcell_acc-1
                     opnd1_flag = localir; opnd1_ptype = x'35'
                     opnd1_d = rbase<<16!value
                     opnd1_flag = reftrip; opnd1_ptype = pptype
                     ->next parm
                  %finish %else %start
                     CSTREXP(0)
                     FPTR = FPTR+ACC
                  %finish
               %finish %else %start
                  CSEXP(III<<4!II)
                  FPTR = FPTR+BYTES(III)
               %finish
               FPTR = (FPTR+MINPARAMSIZE-1)&(-MINPARAMSIZE)
               ->NEXT PARM
!
FPD(2):                                  ! NAME PARAMETERS
               PPTYPE = X'51';           ! PTYPE OF RESULTANT POINTER
               %if PTRSIZE(PTYPE&255)>4 %then PPTYPE = X'61'
               %if II#0 %start;          ! NOT A GENERAL NAME
                  QQQ = 0
                  %if A(P+3)=4 %and A(P+4)=1 %and A(P+FROMAR2(P+1)+1)=2 %start
                     P = P+5
                     REDUCE TAG(YES)
                     %if II=TYPE %and III=PREC %and (LITL#1 %or NAM#0) %and %c
                        (ROUT=0 %or NAM=2) %then QQQ = 1 %else P = P-5
                  %finish
                  %if QQQ#0 %then CNAME(3) {TRUE REF} %else %start
                                         ! EXPRESSION BY REFERENCE
                     ->BAD PARM %unless JJJ=14 %or LP=0
                     ->BAD PARM %if II=3
                     %if II=5 %start;    ! STRING EXPRESSION
                        CSTREXP(0)
                        PUSH(TWSP,VALUE,0,0)
                        QQQ = VALUE
                        OPND2_D = 255
                     %finish %else %start
                        GET WSP(QQQ,BYTES(III)>>2)
                        CSEXP(LCELL_PTYPE&255)
                        OPND2_D = BYTES(III)
                     %finish
                     OPND2_FLAG = SCONST
                     OPND2_PTYPE = X'51'
                     OPND1_FLAG = LOCALIR
                     OPND1_PTYPE = LCELL_PTYPE&255
                     OPND1_D = RBASE<<16!QQQ
                     OPND1_XTRA = 268;               ! size of area needed for stack dowm m-cs
                     %if II#5 %then %c
                     NAMEOPND_FLAG = REFTRIP
                     NAMEOPND_PTYPE = PPTYPE
                     NAMEOPND_D = QQQ
                  %finish
                  JJ = PTRSIZE(III<<4!II)
                  FPTR = FPTR+JJ
               %finish %else %start
                  ->BAD PARM %unless %c
                     A(P+3)=4 %and A(P+4)=1 %and A(P+1+FROMAR2(P+1))=2
                  P = P+5
                  FNAME = FROM AR2(P)
                  REDUCE TAG(NO)
                  OPND2_PTYPE = X'51'; OPND2_FLAG = SCONST
                  OPND2_D = ACC<<16!PTYPE
                  OPND2_XTRA = 0
                  %if TYPE=0 %start;     ! NAME AS GENERAL NAME
                     NAMEOPND_PTYPE <- PTYPE; NAMEOPND_FLAG = DNAME
                     NAMEOPND_D = FNAME
                     NAMEOPND_XTRA = X'80000000'
                  %finish %else %if NAM#0 %and TYPE=5 %start
                     CNAME(3)
                  %finish %else CNAME(4)
                  EXPOPND_PTYPE = X'61'; EXPOPND_FLAG = REFTRIP
                  EXPOPND_XTRA = 0
                  FPTR = FPTR+PTRSIZE(0)
               %finish
               P = P+1
               ->NEXT PARM
FPD(1):
FPD(3):                                  ! ARRAY NAME (&VALUE)
!
! FOR ARRAYNAME PARAMETERS THE NO OF DIMENSIONS OF THE ARRAY IS
! DEDUCED FROM THE FIRST CALL AND STORED IN STREAM3 OF THE PARAMETER
! LIST. ON ANY SUBSEQUENT CALL ONLY ARRAYS OF THE SAME DIMENSION CAN
! BE PASSED
!
               P = P+5
               reduce tag(NO)
               DVD = SNDISP
               %if DVD#0 %then outsym('&'); CNAME(12)
               P = P+1
               ->BAD PARM %unless 1<=ARR<=2 %and II=TYPE %and III=PREC
               QQQ = ASLIST(TCELL)_UIOJ&15;  ! DIMENSION OF ACTUAL(IF KNOWN)
               JJ = LCELL_UIOJ&15;       ! DIMENSION OF FORMAL
               %if JJ=0 %then JJ = QQQ %and LCELL_UIOJ = LCELL_UIOJ!JJ
               %if QQQ=0 %then QQQ = JJ %and %c
                  ASLIST(TCELL)_UIOJ = ASLIST(TCELL)_UIOJ!JJ
               ->BAD PARM %unless JJ=QQQ
               %if DVD#0 %start    { have info to adjust basepoint }
                  DVDP=DVD+3*jj
                  %cycle KK = jj,-1,1
                     LB=Ctable(DVDP)
                     outsym('[')
                     %if LB=x'80000000' %start
                        outstring("-(")
                        p=Ctable(DVDP+1); csexp(x'51'); outsym(')')
                     %finish %else %if lb>0 %start
                        outsym('-'); outint(LB)
                     %finish %else %if LB<=0 %start
                        {outsym('+');} outint(-LB)
                     %finish
                     outstring("] ")
                     DVDP=DVDP-3
                  %repeat
               %finish
               FPTR = FPTR+AHEADSIZE
               ->NEXT PARM
ENTRY SEQ:                               ! CODE FOR RT ENTRY
               outsym(')')
               %while TWSP>0 %cycle
                  POP(TWSP,QQQ,JJ,III);  ! ONLY IF STR VALS & EMAS
                  RETURN WSP(QQQ,268)
               %repeat
               %if STRRESINWA=YES %and NAMP<=1 %and (TYPEP=3 %or %c
                  TYPEP=5) %start
                  GET WSP(QQQ,268);      ! AUTOMATIC RETURN
                  OPND2_PTYPE <- PT
                  OPND2_FLAG = LOCALIR
                  OPND2_D = RBASE<<16!QQQ
                  OPND2_XTRA = 268
                  Opnd_ptype<-pt; opnd_flag=dname
                  opnd_d=rtname; opnd_xtra=(pspeced+1)<<24
                  FPTR = FPTR+PTRSIZE(X'35')
               %finish
               II = UNAMETRIP(RCALL,PT&255,0,RTNAME)
               TRIPLES(II)_OPND1_XTRA = FPTR;  ! PASS PARAM SIZE TOTAL
               CURRINF_NMDECS = CURRINF_NMDECS!2
               ROUT = 1; TYPE = TYPEP; NAM = NAMP
               PREC = PRECP; PTYPE = PT
!
! RECOVER THE RESULT OF FNS & MAPS. OFTEN NOCODE WILL BE NEEDED
!
               %if PT&255#0 %start
                  %if NAM>=2 %then II = RCRMR %else II = RCRFR
                  II = UNAMETRIP(II,PT&255,0,RTNAME)
                  %if STRRESINWA=YES %then TRIPLES(II)_OPND1_XTRA = QQQ
                                         ! WORK AREA OFFSET
                  NAMEOPND_PTYPE = PT&255; NAMEOPND_FLAG = REFTRIP
                  NAMEOPND_D = II
                  NAMEOPND_XTRA = 0
               %finish
OVER:          P = OUTP
            %end;                        ! OF INNER BLOCK
         %end
%integer %fn TSEXP(%integer %name VALUE)
%switch SW(1:3)
%integer PP,KK,SIGN,CT
      TYPE = 1; PP = P
      P = P+3
      SIGN = A(P)
      ->TYPED %unless SIGN=4 %or A(P+1)=2
      ->SW(A(P+1))
SW(1):                                   ! NAME
      P = P+2; REDUCE TAG(NO)
      %if ptype&x'ff0f'=x'4001' %start   { any const int }
         %if a(p+2)=2 %and a(p+3)=2 %and a(p+4)=2 %then %start
            value=midcell
            p=p+5
            %if sign#2 %then %result = 2
            value=-value; %result=-2
         %finish
      %finish
      ->TYPED
SW(2):                                   ! CONSTANT
      CT = A(P+2); TYPE = CT&7
      ->TYPED %unless CT=X'41' %and SIGN#3
      KK = FROMAR2(P+3)
      ->TYPED %unless a(p+5)=2
      VALUE = KK
      P = P+6
      %if SIGN#2 %then %result = 1
      VALUE = -VALUE; %result = -1
SW(3):                                   ! SUB EXPRN
TYPED:P = PP; %result = 0
%end
!*
%integerfn tsc
%integer value,res,PP
%switch sw(1:4)
!printstring("tsc  with p="); write(p,5); newline
      PP=p
      ->sw(a(p))
sw(1):
         p=p+1
         res=tsexp(value)
         %if res=0 %then %result=0
         p=p+1
!printstring("tcond part2 with p="); write(p,5); newline
         res=tsexp(value)
         %if res=0 %then %result=0
         p=p+1
         %if a(p-1)=1 %then %result=0
         %RESULT=1
SW(2):
         p=p+1; res=tcond
!printstring("returns from tcond with res & p "); write(res,1); write(p,5); newline
         %result=res
SW(3):
         P=P+1
         %result=tsc
sw(4):                   ! boolean
      %result=tsexp(value)
%end
%integerfn tcond
!***********************************************************************
!*     Check for a simple compile time condition. PP to First exp      *
!***********************************************************************
%integer value,res,PP
!printstring("tcond with p="); write(p,5); newline
      PP=p
      res=tsc
      %if res=0 %then %result=0
      %if a(p)=3 %then p=p+1 %and %result=1
      %until a(p)=2 %cycle
         p=p+1; res=tsc
         %if res=0 %then %result=0
      %repeat
      p=p+1
      %result=1
%end
         %routine SKIP EXP
!***********************************************************************
!*       SKIPS OVER THE EXPRESSION POINTED AT BY P. USED FOR ERROR     *
!*       RECOVERY AND TO EXTRACT INFORMATION ABOUT THE EXPRESSION.     *
!***********************************************************************
%integer OPTYPE,PIN,J,precp
            PIN = P
            P = P+3;                     ! TO P<+'>
            %cycle;                      ! DOWN THE LIST OF OPERATORS
               OPTYPE = A(P+1);          ! ALT OF P<OPERAND>
               P = P+2
               %if OPTYPE=0 %or OPTYPE>3 %then IMPABORT
               %if OPTYPE=3 %then SKIP EXP;  ! SUB EXPRESSIONS
!
               %if OPTYPE=2 %then %start;  ! OPERAND IS A CONSTANT
                  J = A(P)&7;            ! CONSTANT TYPE
                  %if J=5 %then P = P+A(P+1)+2 %else %start
                     precp=A(P)>>4
                     %if precp=3 %then precp=4
                     P = P+1+BYTES(precp)
                  %finish
               %finish
!
               %if OPTYPE=1 %then %start;  ! NAME
                  P = P-1
                  P = P+3 %and SKIP APP %until A(P)=2;  ! TILL NO ENAME
                  P = P+1
               %finish
!
               P = P+1
               %if A(P-1)=2 %then %exit;  ! NO MORE REST OF EXP
            %repeat
         %end;                           ! OF ROUTINE SKIP EXP
         %routine SKIP APP
!***********************************************************************
!*       SKIPS ACTUAL PARAMETER PART                                   *
!*       P IS ON ALT OF P<APP> AT ENTRY                                *
!***********************************************************************
            %integer PIN
            PIN = P
            P = P+1 %and SKIP EXP %while A(P)=1
            P = P+1
         %end
%routine NO APP
!***********************************************************************
!*  Deals with unexpected parameters                                   *
!***********************************************************************
      P = P+2
      %if A(P)=1 %then %start;     ! <APP> PRESENT
         FAULT(17,0,FROM AR2(P-2))
         outsym('[')
         %while a(p)=1 %cycle
           p=p+1
           csexp(x'51')
           %if a(p)=1 %then outsym(',')
         %repeat
        p=p+1; outsym(']')
      %finish %else P = P+1;       ! P NOW POINTS TO ENAME
%end
         %routine TEST APP(%integer %name NUM)
!***********************************************************************
!*       THIS ROUTINE COUNTS THE NUMBER OF ACTUAL PARAMETERS           *
!*       WHICH IT RETURNS IN NUM.                                      *
!***********************************************************************
            %integer PP,Q
            Q = 0; PP = P; P = P+2;      ! P ON NAME AT ENTRY
            %while A(P)=1 %cycle;        ! NO (MORE) PARAMETERS
               P = P+1; Q = Q+1
               SKIP EXP
            %repeat
            P = PP; NUM = Q
         %end
         %routine SET LINE
!***********************************************************************
!*       UPDATE THE STATEMENT NO                                       *
!***********************************************************************
%integer I,offset
            %return %if RLEVEL=0;        ! AMONG CONDITIONAL GLOBAL DECS
            offset=CURRINF_DIAGINF+2
            %if target=ORN %or 1<<target&riskmc#0 %Then Offset=Offset+2
            I = UCONSTTRIP(SLINE,X'41',0,LINE<<16!Offset)
            %if PARM_PROF#0 %then %start
               I = PROFAAD+4+4*LINE
            %finish
         %end
%routine STORE TAG(%integer KK,LEVEL,RBASE,J,SNDISP,ACC,SLINK,KFORM)
            %integer Q,I,TCELL
            %record (TAGF) %name LCELL
            TCELL = TAGS(KK)
!
! above line to stop local and routine having the same name
!
            Q = LEVEL<<8!RBASE<<4!J
            IMPABORT %unless (KFORM!ACC)>>16=0
            LCELL == ASLIST(TCELL)
            %if LCELL_UIOJ>>8&63=LEVEL %or kk=currinf_m-1 %then %start
!               FAULT(7,0,KK)
               LCELL_UIOJ <- LCELL_UIOJ&X'C000'!Q;  ! COPY USED BITS ACCROSS
            %finish %else %start
               I = ASL; %if I=0 %then I = MORE SPACE
               LCELL == ASLIST(I)
               ASL = LCELL_LINK
               LCELL_LINK = TCELL!CURRINF_NAMES<<18
               LCELL_UIOJ = Q
               TAGS(KK) = I
               CURRINF_NAMES = KK
            %finish
            LCELL_PTYPE <- PTYPE
            LCELL_ACC <- ACC
            LCELL_SNDISP <- SNDISP
            LCELL_KFORM = KFORM
            LCELL_SLINK <- SLINK
         %end
         %routine COPY TAG(%integer TNAME,DECLARE)
!***********************************************************************
!*    A TAG IS A LIST CELL POINTED AT BY TAGS(NAME)                    *
!*    S1 HAS PTYPE<<16!USEBITS(2)!TEXT LEVEL(OLDI6)!RTLEVE(4)!DIMEN    *
!*    S2 HAS SECONDARY DISP(SIGNED)<<16! ACC OR ITEM SIZE IN BYTES     *
!*    S3 HAS PRIMARY DISP(K)<<16!KFORM WHICH IS POINTER TO FORMAT      *
!*                SIDE CHAIN FOR ITEMS OF TYPE RECORD                  *
!*    LINK HAS PTR TO TAG OF NAME HIDDEN WHEN THIS ONE DECLARED        *
!***********************************************************************
            %record (TAGF) %name LCELL
            TCELL = TAGS(TNAME)
            %if TCELL=0 %then %start;    ! NAME NOT SET
               TYPE = 7; PTYPE = X'57'; PREC = 5
               %if DECLARE=YES %start
                  FAULT(16,0,TNAME)
                  STORE TAG(TNAME,LEVEL,RBASE,0,0,4,N,0)
                  N = N+4
                  COPY TAG(TNAME,NO);    ! TO SET USE BITS
                  %return
               %finish
               ROUT = 0; NAM = 0; ARR = 0; LITL = 0; ACC = 4
               I = -1; J = -1; K = -1; OLDI = -1; kform = -1
            %finish %else %start
               LCELL == ASLIST(TCELL)
               PTYPE = LCELL_PTYPE&X'FFFF'
               USEBITS = LCELL_UIOJ>>14&3
               OLDI = LCELL_UIOJ>>8&63
               I = LCELL_UIOJ>>4&15
               J = LCELL_UIOJ&15
               LCELL_UIOJ <- LCELL_UIOJ!X'8000'
               MIDCELL = LCELL_S2
               SNDISP = LCELL_SNDISP&X'FFFF';  ! Sign extension on some hosts
               ACC = LCELL_ACC&X'FFFF'
               K = LCELL_SLINK&X'FFFF';  ! Sign extension on some hosts
               KFORM = LCELL_KFORM
               LITL = PTYPE>>14&3;       ! SIGNEXTENSION ON 16 BIT MACHINES
               ROUT = PTYPE>>12&3
               NAM = PTYPE>>10&3
               ARR = PTYPE>>8&3
               PREC = PTYPE>>4&15
               TYPE = PTYPE&15
            %finish
         %end
         %routine REDUCE TAG(%integer DECLARE)
!***********************************************************************
!*       AS COPY TAG FOR NAME AT A(P) EXCEPT:-                         *
!*       1) SPECIAL NAMES HAVE THEIR CORRECT PREC & TYPE SUBSTITUTED   *
!*       2) RECORD ELEMENTS HAVE THE SUBNAME PARTICULARS RETURNED      *
!***********************************************************************
            %integer SUBS,QQ,PP
            COPY TAG(FROMAR2(P),DECLARE)
            %if PTYPE=SNPT %then %start
               PTYPE = ACC; UNPACK
               %if k=42 {string} %then acc = 256 %else %if %c
                  k=48 {record} %then acc = x'7fff' %else ACC = BYTES(PREC)
            %finish;                     ! TO AVOID CHECKING PARAMS
            %if TYPE=3 %then %start
               PP = P; QQ = COPY RECORD TAG(SUBS); P = PP
            %finish
         %end
! LAYOUT OF PTYPE
! ****** ** *****
! PTYPE REQUIRES 16 BITS TO DEFINE A VARIABLE AND CAN BE REGARDED AS
! AS TWO BYTEINTEGERS:=
! UPPER ONE(UPTYPE):= LITL<<6!ROUT<<4!NAM<<2!ARR
! LOWER ONE(PTYPE) :=PREC<<4!TYPE
! OFTEN (EG IN EXPOP) ONLY THE LOWER PART IS REQUIRED AS FUNCTIONS
! ETC ARE PREFETCHED AND STACKED.
! LITL:= 1=CONST,2=EXTERNAL,3=EXTRINSIC(OR DYNAMIC), 0=NONE OF THESE
! ROUT:= 1 FOR ROUTINE OR FN OR MAP, =0 NONE OF THESE
! NAM := 2 FOR MAPS AND 'REFREFS',=1 FOR NAMES ,=0 DIRECTLY ADDRESSED
! ARR :=1 FOR ARRAYS =0 SCALARS
! PREC IS DESCRIPTOR SIZE CODE FOR EACH PRECISION:-
!     :=0 BITS,=3 BYTES, =5 WORDS, =6 D-WRDS, =7,QUAD WRDS
! TYPE:= THE VARIABLE TYPE
!     :=0 (TYPE GENERAL),=1 INTEGER, =2 REAL, =3 RECORD
!     :=4 (RECORDFORMAT),=5 STRING,  =6 LABEL/SWITCH. =7 NOT SET
!
         %routine UNPACK
            LITL = PTYPE>>14
            ROUT = PTYPE>>12&3
            NAM = PTYPE>>10&3
            ARR = PTYPE>>8&3
            PREC = PTYPE>>4&15
            TYPE = PTYPE&15
         %end
         %routine PACK(%integer %name PTYPE)
            PTYPE = (((((LITL&3)<<2!ROUT&3)<<2!NAM&3)<<2!ARR&3)<<4!PREC&15) %c
               <<4!TYPE&15
         %end
      %end;                              ! OF ROUTINE CSS

      %integer %fn NEWTRIP
!***********************************************************************
!*    SETS UP A NEW TRIPLE AND LINKS IT IN
!***********************************************************************
         %record (TRIPF) %name CURRT
         %integer I
         CURRT == TRIPLES(NEXT TRIP)
         I = NEXT TRIP
         %if I>=WORKA_LAST TRIP %then i=1{FAULT(102,WORKA_WKFILEK,0)}
         NEXT TRIP = i +1
         CURRT = 0
         CURRT_BLINK = TRIPLES(0)_BLINK
         TRIPLES(0)_BLINK = I
         TRIPLES(CURRT_BLINK)_FLINK = I
         %result = I
      %end
      %integer %fn UCONSTTRIP(%integer OPERN,OPTYPE,FLAGS,CONST)
!***********************************************************************
!*    SETS UP A UNARY TRIPLE WITH CONSTANT OPERAND                     *
!***********************************************************************
         %record (TRIPF) %name CURRT
         %integer CELL
         CELL = NEW TRIP
         CURRT == TRIPLES(CELL)
         CURRT_OPERN = OPERN
         CURRT_OPTYPE <- OPTYPE
         CURRT_FLAGS <- FLAGS
         CURRT_OPND1_PTYPE = X'51'
         CURRT_OPND1_D = CONST
         %result = CELL
      %end
      %integer %fn ULCONSTTRIP(%integer OPERN,OPTYPE,FLAGS,CONST1,CONST2)
!***********************************************************************
!*    SETS UP A UNARY TRIPLE WITH CONSTANT OPERAND                     *
!***********************************************************************
         %record (TRIPF) %name CURRT
         %integer CELL
         CELL = NEW TRIP
         CURRT == TRIPLES(CELL)
         CURRT_OPERN = OPERN
         CURRT_OPTYPE <- OPTYPE
         CURRT_FLAGS <- FLAGS
         CURRT_OPND1_PTYPE = X'61'
         CURRT_OPND1_D = CONST1
         CURRT_OPND1_XTRA = CONST2
         %result = CELL
      %end
      %integer %fn UNAMETRIP(%integer OPERN,OPTYPE,FLAGS,NAME)
!***********************************************************************
!*    SETS UP A UNARY TRIPLE WITH ONE NAME OPERAND                     *
!***********************************************************************
         %record (TAGF) %name TAGINF
         %record (TRIPF) %name CURRT
         %integer CELL
         TAGINF == ASLIST(TAGS(NAME))
         CELL = NEW TRIP
         CURRT == TRIPLES(CELL)
         CURRT_OPERN = OPERN
         CURRT_OPTYPE <- OPTYPE
         CURRT_FLAGS <- FLAGS
         CURRT_OPND1_PTYPE = TAGINF_PTYPE
         CURRT_OPND1_FLAG = DNAME
         CURRT_OPND1_D = NAME
         CURRT_OPND1_XTRA = 0
         %result = CELL
      %end
      %integer %fn UTEMPTRIP(%integer OPERN,OPTYPE,FLAGS,TEMP)
!***********************************************************************
!*    SETS UP A UNARY TRIPLE WITH LOCAL TEMPORARY OPND                 *
!***********************************************************************
         %integer CELL
         %record (TRIPF) %name CURRT
         CELL = NEWTRIP
         CURRT == TRIPLES(CELL)
         CURRT_OPERN = OPERN
         CURRT_OPTYPE <- OPTYPE
         CURRT_FLAGS <- FLAGS
         CURRT_OPND1_PTYPE = OPTYPE; CURRT_OPND1_FLAG = LOCALIR
         CURRT_OPND1_D = TEMP
         %result = CELL
      %end
      %routine KEEPUSECOUNT(%record (RD) %name OPND)
!***********************************************************************
!*    KEEPS PUSE AND CNT UP TO DATE                                    *
!***********************************************************************
         %record (TRIPF) %name REFT
         REFT == TRIPLES(OPND_D)
         %if REFT_CNT=0 %then %start
!            printstring("setting puse ")
!            write(opnd_d,4); write(triples(0)_blink,4); write(reft_puse,3)
!             newline
           REFT_PUSE = TRIPLES(0)_BLINK
         %finish
         REFT_CNT = REFT_CNT+1
      %end
      %integer %fn URECTRIP(%integer OPERN,OPTYPE,FLAGS,
         %record (RD) %name OPND1)
!***********************************************************************
!*    SETS UP A BINARY TRIPLE WITH  COMPLETE OPERANDS PROVIDED         *
!***********************************************************************
         %integer CELL
         %record (TRIPF) %name CURRT
         CELL = NEWTRIP
         CURRT == TRIPLES(CELL)
         CURRT_OPERN = OPERN
         CURRT_OPTYPE <- OPTYPE
         CURRT_FLAGS <- FLAGS
         CURRT_OPND1 = OPND1
         %if 1<<OPND1_FLAG&BTREFMASK#0 %then KEEPUSECOUNT(OPND1)
         %result = CELL
      %end
      %integer %fn BRECTRIP(%integer OPERN,OPTYPE,FLAGS,
         %record (RD) %name OPND1,OPND2)
!***********************************************************************
!*    SETS UP A BINARY TRIPLE WITH  COMPLETE OPERANDS PROVIDED         *
!***********************************************************************
         %integer CELL
         %record (TRIPF) %name CURRT
         CELL = NEWTRIP
         CURRT == TRIPLES(CELL)
         CURRT_OPERN = OPERN
         CURRT_OPTYPE <- OPTYPE
         CURRT_FLAGS <- FLAGS
         CURRT_OPND1 = OPND1
         CURRT_OPND2 = OPND2
         %if 1<<OPND1_FLAG&BTREFMASK#0 %then KEEP USE COUNT(OPND1)
         %if 1<<OPND2_FLAG&BTREFMASK#0 %then KEEP USE COUNT(OPND2)
         %result = CELL
      %end
      %routine GET WSP(%integer %name PLACE, %integer SIZE)
!***********************************************************************
!*       FIND OR CREATE A TEMPORARY VARIABLE OF 'SIZE' WORDS           *
!***********************************************************************
         %integer J,K,L,F
         F = SIZE>>31;                   ! TOP BIT SET FOR MANUAL RETURN
                                         ! OTHERWISE NOTE IN TWSP LIST
                                         ! FOR AUTOMATIC RETURN
         SIZE = SIZE<<1>>1
         %if SIZE>4 %then SIZE = 0
         POP(CURRINF_AVL WSP(SIZE),J,K,L)
         %if K<=0 %then %start;          ! MUST CREATE TEMPORARY
            %if size=4 %then l=rnding(128+x'72') %else %if Size=2 %c
                %then l=rnding(128+x'62') %else l=3
            n=(n+L)&(\l)
            K = N
            %if SIZE=0 %then N = N+268 %else N = N+SIZE<<2
         %finish
         PLACE = K
         PUSH(TWSPHEAD,K,SIZE,0) %unless F#0
      %end
      %routine RETURN WSP(%integer PLACE,SIZE)
!***********************************************************************
!*    RETURNS WORKSPACE TO ORDERED FREE LIST. ADDRESSABLE CELLS        *
!*    ARE PUT AT THE TOP. NON-ADDRESSABLE ON THE BACK                  *
!***********************************************************************
         %integer CELL
         IMPABORT %unless PLACE<=N %and PLACE&1=0
         %if SIZE>4 %then SIZE = 0
         CELL = CURRINF_AVL WSP(SIZE)
         %while CELL>0 %cycle
            IMPABORT %if ASLIST(CELL)_S2=PLACE
            CELL = ASLIST(CELL)_LINK
         %repeat
         %if PLACE<511 %then PUSH(CURRINF_AVL WSP(SIZE),0,PLACE,0) %else %c
            INSERT AT END(CURRINF_AVL WSP(SIZE),0,PLACE,0)
      %end
      %routine REUSE TEMPS
         %integer JJ,KK,QQ
         %while TWSPHEAD#0 %cycle
            POP(TWSPHEAD,JJ,KK,QQ)
            RETURN WSP(JJ,KK)
         %repeat
      %end
      %integer %fn FROMAR2(%integer PTR)
         %result = A(PTR)<<8!A(PTR+1)
      %end
      %integer %fn FROMAR4(%integer PTR)
         %integer I
         MOVE BYTES(4,ADDR(A(0)),PTR,ADDR(I),0)
         %result = I
      %end
P2END:                                   ! EXITS AFTER COMPILATION
   %end;                                 ! OF SUBBLOCK CONTAINING PASS2
%end
%end %of %file
