!* 06/03/86
!*
{\VAX}%include "ftn_ht"
{\VAX}%include "ftn_csynt62"
{\VAX}%include "ftn_fmts1"
{\VAX}%include "ftn_consts2"
!*
!{VAX}%include "ht.inc"
!{VAX}%include "csynt62.inc"
!{VAX}%include "fmts1.inc"
!{VAX}%include "consts1.inc"
!*
!***********************************************************************
!* Exports                                                             *
!***********************************************************************
!*
%routinespec   Init Alloc(%integer Mode,Adcom,Rel,Avers)
%routinespec   Alloc(%integer PTR)
%integerfnspec Freesp(%integer n)
%routinespec   Free List Cell(%integername listhead,%integer n)
%integerfnspec New List Cell(%integername listhead,%integer n)
%integerfnspec Setlab(%integer lab,%integername labrecptr)
%integerfnspec Setconrec(%record(resf) res)
%integerfnspec Dict Space(%integer Length)
%integerfnspec Genfmt(%byteintegerarrayname Input,Type,
                      %string(*)%name Identifier)
%routinespec   New Temp(%record(Resf)%name Res,%integer Mode,Use)
%integerfnspec Conin(%integer Val)
%integerfnspec Alloc Const(%integer Resw,%integername IIN)
%integerfnspec New Subprogram(%integer Ptr,P1,Ctyp,%integername Er)
%integerfnspec Formal Parameter(%integer Ptr,Mode,Ctyp)
%routinespec   Dumpdict(%integer Mode)
!*
!***********************************************************************
!* Imports                                                             *
!***********************************************************************
!*
%externalroutinespec Edbytes(%integer area, Disp, len, ad)
%externalroutinespec Ed4(%integer area, Disp, DataQuadbyte)
!*
%externalroutinespec fault(%integer er)
%externalroutinespec ifault(%integer er,val)
%externalroutinespec lfault(%integer er)
%externalroutinespec tfault(%integer er,ta,tb)
%externalintegerfnspec formatcd(%integer fmtbase,fmtdisp,arraybase,
            inlen,outlen,inout,type,%integername tablen,fmtlen)
%externalroutinespec dicful
%externalintegerfnspec Dv Space(%integer LEN,%integername IIN)
%externalintegerfnspec Stack Space(%integer Len)
%externalintegerfnspec Scalar Space(%integer Len,%integername IIN)
%externalintegerfnspec Array Space(%integer Len,%integername IIN)
%externalintegerfnspec Const Space(%integer Len,%integername IIN)
%externalintegerfnspec Alloc Char(%integer Len,Ad,%integername IIN)
%externalintegerfnspec Char Ref(%integer IIN,Disp,Len)
%externalroutinespec Set Array Head(%integer Adv,IIN,Disp,Addrzero,Type)
%externalintegerfnspec Newcmn(%integer Init,Iden,%integername Refad)
%externalroutinespec Init Data(%integer Mode,Adcom,Rel,Avers)
%externalintegerfnspec Op4 Ref(%string(63) S)
!*
!***********************************************************************
!*                                                                     *
!* OWN variables                                                       *
!*                                                                     *
!***********************************************************************
!*
%ownrecord(COMFMT)%name COM
%owninteger ADICT;! local copy for efficiency
%owninteger ANAMES;! ditto
%owninteger CHEAD0,CHEAD1,CHEAD2,CHEAD3
%owninteger Lastsubprogep,Paramlink,Mainprog
!*
%ownintegerarray LABH(0:31)
%externalintegerarray ASL(0:10)
%ownintegerarray Cmnbits(0:15)
!*
%owninteger COMAD
!*
!***********************************************************************
!* Consts                                                              *
!***********************************************************************
!*
%CONSTINTEGER MAX AREA SIZE=X'400000'
%CONSTBYTEINTEGERARRAY NUMBYTES(0:7)=0(3),1,2,4,8,16
%CONSTINTEGERARRAY ROND(0 : 3) =    %C
X'FFFFFFFF',X'FFFFFFFE',0,X'FFFFFFFC'
!*
%CONSTBYTEINTEGERARRAY HEX(0 : 15) =   %C
 '0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'
!*
{\VAX}%include "ftn_copy1"
!{VAX}%include "copy1.inc"
!*
%externalintegerfn Dictspace(%integer Length)
!***********************************************************************
!* Reserve Length bytes in Dict                                        *
!***********************************************************************
%integer I,L
      %if Length&3#0 %then %monitor
      %if HOST=PERQPNX %or HOST=ACCENT %thenstart
         L=Length>>1
      %finishelsestart
         L=Length
      %finish
      I=Com_Dptr
      Com_Dptr=Com_Dptr+L
      %if Com_Dptr>Com_Diclen %then Dicful
      Zero(Com_Adict+I,Length)
      %result=I
%end;! Dictspace
!*
!******************************************************************************
!*                                                                            *
!*         LIST MANIPULATION                                                  *
!*                                                                            *
!******************************************************************************
!*
!*
%externalintegerfn FREESP(%integer N)
!***********************************************************************
!* OBTAIN N-WORD(32 BIT) LIST ITEM                                     *
!***********************************************************************
%integer PTR
%record(SRECF) %name SS
         PTR=ASL(N)
         %if PTR = 0 %thenstart
            PTR = Dict Space(N<<2)
            SS == RECORD(ADICT+PTR)
         %finishelsestart
            SS == RECORD(ADICT+PTR)
            ASL(N) = SS_LINK1
         %finish
         SS_LINK1 = 0
         %result=PTR
%end;                                   ! FREESP
!*
%externalroutine FREE LIST CELL(%integername LISTHEAD,%integer N)
%integer J
%record(SRECF) %name SS
      SS==record(ADICT+LISTHEAD)
      J=SS_LINK1;! NEW LISTHEAD
      SS_LINK1=ASL(N)
      ASL(N)=LISTHEAD
      LISTHEAD=J
%end;! FREE LIST CELL
!*
%externalintegerfn NEW LIST CELL(%integername LISTHEAD,%integer N)
%integer PTR
%record(SRECF) %name SS
      PTR=FREESP(N)
      SS==record(ADICT+PTR)
      SS_LINK1=LISTHEAD
      LISTHEAD=PTR
      %result=PTR
%end;! NEW LIST CELL
!*
!******************************************************************************
!*                                                                            *
!*        NAME, LABEL AND CONST HANDLING                                      *
!*                                                                            *
!******************************************************************************
!*
!*
%externalintegerfn SETLAB(%integer LAB,%integername LABRECPTR)
!***********************************************************************
!* LOCATE ENTRY IN LABEL LIST OR CREATE NEW ENTRY                      *
!***********************************************************************
%integer LPTR,PTR,I,J
%record(LABRECF) %name LABREC
         PTR = LABH(LAB&31)
         LPTR=PTR
         %while PTR # 0 %cycle
            LABREC == RECORD(ADICT+PTR)
            %if LABREC_LAB = LAB %C
               %then LABRECPTR=PTR %AND %result=0
            PTR = LABREC_LINK1
         %repeat
         PTR = Dictspace(LABRECSIZE)
         LABREC == RECORD(ADICT+PTR)
         LABREC_BLKIND=0
         LABREC_LINK1 = LPTR
         LABREC_LAB = LAB
         LPTR = PTR
         LABH(LAB&31) = LPTR
         LABRECPTR=PTR
         Com_Labcnt=Com_Labcnt+1  ;! for Op4
         %result=1
%end;                                   ! SETLAB
!*
%externalintegerfn SETCONREC(%record(RESF) RES)
!***********************************************************************
!* On entry a copy of the const is held as the item last added to DICT *
!* RES = (PTR>>DSCALE) << 16 ! x'100' ! mode                           *
!* For numeric constants a search is made of the appropriate list      *
!* of 4, 8, or 16 byte entries to see whether a copy is already held.  *
!* If not, and also for non-numeric constants, a new 4 word record is  *
!* added to the appropriate list                                       *
!* Content is  MODE   mode                                             *
!*             LINK1  link through chain of consts of same size        *
!*             DADDR  DICT @ of const                                  *
!*             CADDR  @ of const in CONSTS if allocated, else 0        *
!***********************************************************************
%CONSTBYTEINTEGERARRAY LIST(0:15)=1,1,2,1,2,0,2,0,0,1,0,0,0,0,0,0
%integer I,J,K,M,R,Val,Len
%record(CONSTRECF) %name CON
%SWITCH S(0:3)
      M=RES_MODE
      R=RES_H0<<DSCALE
      K=ADICT+R
      Val=integer(K)
      I=LIST(M)
      ->S(I)
!*
S(1): J=CHEAD1
      %while J#0 %cycle
         CON==record(ADICT+J)
         %if Val=INTEGER(ADICT+CON_DADDR)   %C
                                    %AND M=CON_MODE %thenstart
HIT:        %result=J
         %finish
         J=CON_LINK1
      %repeat
      J=CHEAD1
      CHEAD1=COM_DPTR
      Len=4
SET:  I=Dict Space(CONRECSIZE)
      CON==record(ADICT+I)
      CON_MODE=M
      %if M=HOLMODE %thenstart
         Val=((Val+3)>>2)<<2
         %if Val>Len %then Len=Val
      %finish
      Con_Length=Len
      CON_LINK1=J
      CON_DADDR=R
      CON_CADDR=0
      %result=I
!*
S(2): J=CHEAD2
      %while J#0 %cycle
         CON==record(ADICT+J)
         %if Val=integer(Adict+Con_Daddr)   %c
                       %and M=Con_Mode %thenstart
            %if integer(K+Com_W1)=integer(Adict+Con_Daddr+Com_W1) %then ->Hit
         %finish
         J=CON_LINK1
      %repeat
      J=CHEAD2
      CHEAD2=COM_DPTR
      Len=8
      ->SET
!*
S(0): J=CHEAD0
      CHEAD0=COM_DPTR
      Len=16
      ->SET
%end;! SETCONREC
!*
%externalintegerfn Conin(%integer Val)
%record(RESF) R
      R_Mode=INT4
      %if 0<=Val<=X'7FFF' %thenstart
         R_Form=LIT
         R_H0=Val
         %result=R_W
      %finish
      %if -X'7FFF'<=Val<0 %thenstart
         R_Form=NEGLIT
         R_H0=-Val
         %result=R_W
      %finish
      integer(Adict+Com_Dptr)=Val
      R_H0=Com_Dptr>>DSCALE
      R_Form=1
      Com_Dptr=Com_Dptr+W1
      R_H0=Setconrec(R)>>DSCALE
      R_Form=CNSTID
      %result=R_W
%end;! Conin
!*
{%include "pf_setbit"}
!*
%ROUTINE SETBIT(%INTEGER STRIPADDR,INDEX)
%INTEGER WD,BIT
%INTEGERARRAYNAME BS
%INTEGERARRAYFORMAT BSFMT(0:100)
!$BS==ARRAY(STRIPADDR,BSFMT)
!$WD=INDEX>>5
!$BIT=31-INDEX&X'1F'
!$BS(WD)=BS(WD)!(1<<BIT)
%END;! SETBIT
!*
{end "pf_setbit"}
!*
%externalroutine Init Alloc(%integer Mode,Adcom,Rel,Avers)
!***********************************************************************
!* Mode = 0  first time - reset everything                             *
!*        1  reset for start of new subprog                            *
!***********************************************************************
%integer I
      %if Mode=0 %thenstart
         Comad=Adcom
         Com==record(Adcom)
         Com_Acmnbits=Addr(Cmnbits(0))
         Com_Acomp=Addr(Comp(0))
         Adict=Com_Adict
         Anames=Com_Anames
         Com_Alabh=addr(Labh(0))
         Mainprog=0;! will trap multiple main programs
      %finish
      Init Data(Mode,Adcom,Rel,Avers)
      %cycle i=0,1,15
         Cmnbits(I)=0
      %repeat
      Cmnbits(0)=X'10000000'
      %cycle I=0,1,31
         Labh(I)=0
      %repeat
      %cycle I=0,1,10
         Asl(I)=0
      %repeat
      Chead0=0
      Chead1=0
      Chead2=0
%end;! Init Alloc
!*
%externalintegerfn Alloc Const(%integer Resw,%integername IIN)
%record(CONSTRECF)%name Con
%record(RESF) R
%integer Val,Ad,Cad,Bytes
%switch f(64:66)
      R_W=Resw
      Val=R_H0
      ->F(R_Form)
!*
F(NEGLIT):
      Val=-Val
!*
F(LIT):
      Ad=Dictspace(4)
      integer(Com_Adict+Ad)=Val
      R_H0=Ad>>DSCALE
      Ad=Setconrec(R)
Set:  Con==record(Adict+Ad)
!      %if Con_Caddr=0 %thenstart
         Con_Caddr=Const Space(Con_Length,IIN)
         Cad=Con_Caddr
         Ad=Adict+Con_Daddr
         %if Con_Mode=HOLMODE %then Ad=Ad+W1
         Edbytes(IIN,Cad,Con_Length,Ad)
!      %finish
      %result=Con_Caddr
!*
F(CNSTID):
      Ad=R_H0<<DSCALE
      ->Set
%end;! Alloc Const
!*
%externalroutine NEW TEMP(%record(RESF)%name RES,%integer MODE,USE)
!***********************************************************************
!* Get temp scalar DICT record                                         *
!***********************************************************************
%integer IIN,J
%record(TMPF)%name TMP
%record(COMFMT)%name COM
      COM==record(COMAD)
      J=Dict Space(TMPRECSIZE)
      TMP==record(COM_ADICT+J)
      TMP_MODE=MODE
      TMP_REG=0
      TMP_LINK1=0
      TMP_ADDR=0
      TMP_W0=0
      TMP_USECNT=USE
      TMP_INDEX=COM_NEXT TEMP
      COM_NEXT TEMP=COM_NEXT TEMP+1
      %IF COM_NEXTBIT<512 %THENSTART
         TMP_COORD=COM_NEXTBIT
         COM_NEXTBIT=COM_NEXTBIT+1
      %FINISHELSE TMP_COORD=3
      RES_FORM=TMPID
      RES_MODE=MODE
      RES_H0=J>>DSCALE
%end;! GET TEMP
!*
!*
%externalroutine Alloc(%integer PTR)
!***********************************************************************
!* ON ENTRY PTR POINTS AT RECORD FOR AN IDENTIFIER FOR WHICH           *
!* STORAGE MUST BE ALLOCATED. THIS MAY REQUIRE ALLOCATION OF A COMPLETE*
!* COMMON BLOCK, OR ALL ITEMS INVOLVED IN EQUIVALENCE CHAINS.          *
!***********************************************************************
!*
%routinespec DV(%integer DVADDR,MODE)
%integerfnspec Next Coord
!*
%record(ARRAYDVF) %name DVREC
!*
%integer I, T, IIN
%integer J, K, L, M, N, P, Q, U, V, W, TEMP,CHAR,CMNBLKAD
%integer SAVEPTR, DATAMODE, CMNIND, CCOORD
%integer CLASS,SZTYPE,DR1
%integer BOUND, BEND, ER
%owninteger Curbit;! to carry across recursive call to Alloc equiv item
%record(PRECF) %name PP
%record(PRECF) %name QQ
%record(SRECF) %name WW
%record(SRECF) %name SS
%record(PRECF) %name CMNBLK
%SWITCH SW(0 : 6)
%SWITCH TW(8 : 14)
!*
      PP == RECORD(COM_ADICT+PTR)
      I = PP_X1
      DATAMODE = I&2
      SAVEPTR = PTR
      CLASS = PP_CLASS&X'1F'
      SZTYPE=PP_TYPE
      %if I&1#0 %thenstart;! allocated (at least partially)
         %unless PP_CLASS&6=6 %then %RETURN;! unless COMMON array
         %if COM_SUBPROGTYPE=5 %then %RETURN;! blockdata
         DVREC==record(COM_ADICT+PP_ADDR4)
         %if DVREC_ADDRDV#0 %then %RETURN;! fully allocated
         DV(PP_ADDR4,2);! complete allocation
         SET ARRAY HEAD(DVREC_ADDRDV,PP_IIN,DVREC_ADFIRST,  %c
                                      Dvrec_Addrzero,Sztype)
         %RETURN
      %finish
      Curbit = 3
      L = PP_ADDR4
      N = NUMBYTES(SZTYPE>>4)
      %if SZTYPE=5 %then N=PP_LEN
      %if N>0 %then T=N-1;! NO OF BYTES IN ELEMENT-1
      %if SZTYPE&15 = 3 %then N=N+N;! complex
      -> SW(CLASS&3!(PP_X1&4));      ! EQUIV:COMMON:PARAM
!*
!*** LOCAL SCALARS OR ARRAYS
SW(0):PP_X1=PP_X1!1;                 ! SET ALLOCATED BIT
      PP_Coord=Next Coord
      PP_Link2=Com_Scptr;! ADD TO DIAGS LIST
      Com_Scptr=Ptr
      %if Class&4 # 0 %thenstart;    ! ARRAY
         Dv(PP_Addr4,0)
         Dvrec_Adfirst = Array Space(N,IIN)
         Dvrec_Addrzero= Dvrec_Adfirst-Dvrec_Addrzero
         Set Array Head(Dvrec_Addrdv,IIN,Dvrec_Adfirst,  %c
                         Dvrec_Addrzero,PP_Type)
      %finishelsestart;              ! SCALAR
         %if Sztype=5 %thenstart
            PP_Addr4=Alloc Char(N,0,IIN)
         %finishelsestart
            PP_Addr4 = Scalar Space(N,IIN)
         %finish
      %finish
      PP_IIN=IIN
      %return
!*
!*** PARAM
SW(1):PP_X1=PP_X1!1;                 ! SET ALLOCATED BIT
      %if PP_CLASS=9 %thenstart;! SUBPROG
         PP_Addr4=Scalar Space(8,IIN);! space for ref and length
         PP_IIN=IIN
         %return
      %finish
      PP_Link2=Com_Scptr;! FOR DIAGNOSTICS
      Com_Scptr=Ptr
      %if Class = 5 %thenstart;      ! PARAMETER ARRAY
         DV(PP_Addr4,0);               ! CONSTRUCT REST OF DOPE VECTOR
         PP_Coord=1;! bit for array and char params(i.e. ref values)
         Setbit(Com_Acmnbits,1)
      %finishelsestart;              ! SCALAR
         I=Com_Checklist;! OF ITEMS WHICH SHOULD APPEAR AS PARAMS
         %while I#0 %cycle
            SS==record(Com_Adict+I)
            %if SS_Inf0=Ptr %then SS_Inf2=0;! ENTRY TO BE IGNORED
            I=SS_Link1
         %repeat
!!         %if PP_X0&1 # 0 %and Sztype#5 %thenstart;! 'VALUE' PARAM SCALAR
!!            PP_Coord=Next Coord;! same as local scalar
!!         %finishelsestart;! 'NAME' PARAM SCALAR - only char in F77
            PP_Coord=1
            Setbit(Com_Acmnbits,1)
            PP_X0=PP_X0&X'FE'
            %if PP_Type=CHARTYPE %then N=8 %else N=4
!!         %finish
         PP_Addr4=Scalar Space(N,IIN)
         PP_IIN=IIN
      %finish
      %return
!*** COMMON
SW(2):Cmnblk == record(Com_Adict+PP_Link3<<DSCALE);  ! RECORD DESCRIBING COMMON BLOCK
      M=Cmnblk_Cmnlength
      Char=0
      %if Com_Subprogtype = 5 %thenstart;    ! BLOCKDATA - SPACE WILL BE ALLOCATED
         M=0
         IIN=Newcmn(1,Cmnblk_Iden,Cmnblk_Cmnrefad)
         Cmnblk_IIN=IIN
      %finishelsestart
         %if Cmnblk_Cmnrefad=0 %thenstart
            IIN=Newcmn(0,Cmnblk_Iden,Cmnblk_Cmnrefad)
            Cmnblk_IIN=IIN
         %finishelse IIN=Cmnblk_IIN
      %finish
      Er = 304;                      ! ALLIGNMENT
      Ptr = Cmnblk_Link2;            ! FIRST ITEM IN THIS COMMON AREA
      %while PTR # 0 %cycle
         PP == record(Com_Adict+Ptr)
         %if PP_X1&1 = 0 %thenstart; ! NOT YET ALLOCATED
            PP_IIN=IIN
            %if PP_Type=5 %thenstart
               N=PP_Len
               Char=Char!1
            %finishelsestart
               N = Numbytes (PP_Type>>4)
               Char=Char!2
               %if PP_Type&15=3 %then N=N+N;! COMPLEX
               %if N>2 %then T=3 %else T=N-1
                                        ! NO. OF BYTES IN ELEMENT - 1
                                        ! (PER PART IF COMPLEX)
               %unless M = (M+T)&ROND(T) %or Er = 0 %thenstart
                                        ! UNLESS ALLIGNMENT O.K. OR FAULT ALREADY REPORTED
!                  LFAULT(ER)   **** CANNOT HAPPEN UNTIL I*2 ALLOWED
                  ER = 0
               %finish
            %finish
            PP_X1=PP_X1!1;           ! SET ALLOCATED BIT
            %if PP_CLASS&4 # 0 %thenstart;! ARRAY
               SZTYPE=PP_TYPE
               %if PTR=SAVEPTR %OR COM_SUBPROGTYPE=1 %then I=0  %C
                                                     %else I=1
                                        ! full alloc if specifically referenced
                                        ! or in main program
               DV(PP_ADDR4,I);         ! SET DOPE VECTOR(UNLESS BLOCK DATA) 
                                     ! CALCULATE TOTAL ARRAY SIZE
               DVREC_ADFIRST=M
               Dvrec_Addrzero=M-Dvrec_Addrzero
!* N.B. RELOCATION BY COMMON BASE AS FOR LOCAL ARRAYS
               %unless COM_SUBPROGTYPE=5 %OR I=1 %thenstart
                  SET ARRAY HEAD(DVREC_ADDRDV,IIN,M,Dvrec_Addrzero,Sztype)
               %finish
            %finishelsestart
               PP_ADDR4=M;! bytes
            %finish
            M = M+N
         %finish
         PP_Coord=Curbit
         PP_Coord=Next Coord;! to be suppressed if in trouble
         Setbit(Com_Acmnbits,PP_Coord)
         PTR = PP_LINK2;             ! NEXT ITEM ON THE LIST
      %repeat
      %if CHAR=3 %thenstart
         TFAULT(183,COM_ANAMES+CMNBLK_IDEN,0)
      %finish
      CMNBLK_CMNLENGTH = M
      %if M>MAX AREA SIZE %thenstart
         TFAULT(317,COM_ANAMES+CMNBLK_IDEN,0)
      %finish
      %RETURN
!*** ITEM IS ON AN EQUIVALENCE LIST
SW(4):
SW(6):
      W = N;                         ! ITEM LENGTH
      K = 0;                         ! FOR DISPLACEMENT
      T = 0
      M = 0;                         ! MAX VALUE OF N DISPL
      J = PTR;                       ! STARTING POINT
      P = PTR
      V = PP_LINK2;                  ! CORRESPONDING EQUIV CHAIN ENTRY
      CHAR=0
      SS == RECORD(COM_ADICT+V)
!*
!* STAGE 1   CHOOSE AN ELEMENT WHOSE @ WILL BE FIXED. COMMON ELSE
!*           ARRAY EL WITH GREATEST DISPLACEMENT ELSE ARRAYNAME ELSE
!*           SCALAR
!*           V POINTS TO LIST & P POINTS TO ELEMENT
!*
      %cycle
         PP==record(COM_ADICT+P)
         %if PP_TYPE=5 %thenstart
            N=PP_LEN 
            CHAR=CHAR!1
         %finishelsestart
            N = NUMBYTES(PP_TYPE>>4)
            CHAR=CHAR!2
            ER=SS_INF3
         %finish
         U = SS_INF2;                ! DISPL OF EQUIVALENCED ITEM FROM BASE
         %if PP_X1&1 # 0 %thenstart; ! ALLOCATED
            K = U
            PTR = P;                 ! SET TO POINT AT ITEM TO BE USED AS ROOT
            T = 3;                   ! ALLOCATED (MAY BE COMMON ITEM IN CHAIN)
         %finishelsestart
            %if PP_Class&2#0 %thenstart;! item in common
               PP_X1=PP_X1&X'F3';! clear equiv flag
               Alloc(P)
               K=U
               Ptr=P
               T=3
            %finishelsestart
               %if PP_TYPE&15=3 %then N=N+N;! COMPLEX
               %if PP_CLASS&4 # 0 %thenstart;! ARRAY
                  %unless K > U %OR T = 3 %thenstart
                                     ! WILL BE ROOT UNLESS ALLOCATED OR COMMON ITEM, OR 
                                     ! ARRAY WITH BIGGER DISPLACEMENT IS FOUND
                     K = U
                     PTR = P
                  %finish
                  SZTYPE=PP_TYPE
                  DV(PP_ADDR4,0);         ! SET UP DOPE VECTOR, N TOTAL SIZE IN BYTES
               %finishelsestart
                  %if PP_TYPE=5 %thenstart
                     %unless K>=U %OR T=3 %thenstart
                        K=U
                        PTR=P
                    %finish
                 %finish
               %finish
               %if N-U > M %then M = N-U;    ! MAX LENGTH REQUIRED BEYOND ALLIGNMENT POINT
            %finish
         %finish
         %if SS_link1=0 %then %exit;! previous error - avoid loop
         SS == RECORD(COM_ADICT+SS_LINK1);    ! NEXT ITEM DESCRIPTOR IN EQUIV CHAIN
         P = SS_INF0
      %repeat %until P = J 
      %if CHAR=3 %thenstart
         IFAULT(182,ER);! equivalence of char and non-char items
      %finish
      CHAR=CHAR&1
      PP == RECORD(COM_ADICT+PTR);       ! ITEM WHOSE ADDRESS IS TO BE FIXED FIRST
      P = PP_ADDR4
      DVREC == RECORD(COM_ADICT+PP_ADDR4)
!*
!* STAGE 2   ALLOCATE @ OF THE CHOSEN ELEMENT
!*
      %unless T > 0 %thenstart;      ! NOT YET ALLOCATED
         PP_X1=(PP_X1&X'F0')!1;                    ! CLEAR EQUIV FLAGS & SET ALLOC BIT
         T=4;! indicate local rather than common
         Q=Array Space(M+K,IIN)
         %if PP_CLASS&4#0 %thenstart
            DVREC==record(COM_ADICT+PP_ADDR4)
            DVREC_ADFIRST=Q
            Dvrec_Addrzero=Q-Dvrec_Addrzero
            SET ARRAY HEAD(DVREC_ADDRDV,IIN,Q,Dvrec_Addrzero,PP_Type)
         %finishelsestart
            PP_ADDR4=Q
         %finish
         PP_IIN=IIN
         PP_Link2=Com_Scptr
         Com_Scptr=Ptr
      %finishelsestart;              ! COMMON ELEMENT (ALREADY ALLOCATED)
         T=3;! indicates common later
         %if PP_CLASS&4=0 %thenstart;! NOT AN  ARRAY
            P=PTR
            Q=PP_ADDR4
         %finishELSE Q=DVREC_ADFIRST
         CMNBLKAD=PP_Link3
         CMNBLK==record(COM_ADICT+CMNBLKAD<<DSCALE);! common block record
         %if M+K+Q>CMNBLK_CMNLENGTH %then CMNBLK_CMNLENGTH=M+K+Q
         IIN=CMNBLK_IIN
!* set all items in this block to the same coord pro tem
         QQ==RECORD(COM_ADICT+CMNBLK_LINK2)
         CCOORD=QQ_COORD
         %WHILE QQ_LINK2#0 %CYCLE
            QQ==RECORD(COM_ADICT+QQ_LINK2)
            QQ_COORD=CCOORD
            %IF COM_OPT#0 %THEN QQ_X1=QQ_X1!X'80';! to ensure always BOEX
         %REPEAT
         CURBIT=CCOORD
      %finish
!*********** STAGE 3
      BOUND = K+Q;                   ! DISPL. OF EQUIVALENCING POINT FROM START OF FIRST ITEM
                                     ! +DISPL. OF FIRST ITEM FROM AREA BASE
!      W = V;                         ! POINTS TO FIRST ITEM IN LIST
!      %cycle
!         WW == RECORD(COM_ADICT+W)
!         QQ == RECORD(COM_ADICT+WW_INF0)
!         %unless QQ_TYPE=5 %thenstart
!            L = NUMBYTES(QQ_TYPE>>4)-1
!            %if L>3 %then L=3
!            Q = WW_INF2;                ! DISPLACEMENT
!            %if BOUND-Q # (BOUND-Q+L)&ROND(L) %thenstart
!                                        ! WRONG ALLIGNMENT
!ALLIGNERROR:   FAULT(304)
!               %EXIT
!            %finish
!         %finish
!         W = WW_LINK1
!      %repeat %until W = V ;! I.E. COMPLETE LIST PROCESSED
!*
      K = V;                         ! POINTER TO LIST
      SS == RECORD(COM_ADICT+K)
      PTR = J
      %cycle
         PP == RECORD(COM_ADICT+PTR)
         PP_Coord=Curbit
         %if PP_X1&1 = 0 %thenstart; ! NOT USED/ALLOCATED
            PP_X1=PP_X1!DATAMODE!1;  ! SET DATA IF NEC. AND ALLOCATED BIT
            M = BOUND-SS_INF2;       ! START OF THIS ITEM RELATIVE TO THE BASE
            %if PP_TYPE=5 %AND T=2 %thenstart;! local char scalars
               %if PP_LINK2=0 %thenstart
                  PP_LINK2=COM_SCPTR
                  COM_SCPTR=PTR
               %finish
               PP_ADDR4=M;! bytes
               ->MEET3
            %finish
            W = T;                   ! FIXED ITEM IS:  2 SCALAR  3 COMMON  4 ARRAY
            -> TW(T+6+PP_CLASS&4);   ! 8 SCALAR:SCALAR  12 SCALAR:ARRAY
                                     ! 9 COMMON:SCALAR  13 COMMON:ARRAY
                                     !10 ARRAY :SCALAR  14 ARRAY :ARRAY
TW(13):                              ! ARRAY EQUIV COMMON
            W = 4;                   ! TO INDICATE THAT ADDRESS IS TO GO IN DOPE VECTOR
TW(9):      !SCALAR EQUIV COMMON
            %if M < 0 %then FAULT(268);! ATTEMPT TO EXTEND BACKWARDS
            PP_LINK2=CMNBLK_LINK2
            CMNBLK_LINK2=PTR
            PP_Link3 = CMNBLKAD;            ! ADDRESS OF COMMON BLOCK RECORD
            PP_X0=PP_X0!4
            PP_CLASS=PP_CLASS!2;     ! COMMON MARKER  ??
            -> MEET2
TW(8):                               ! SCALAR EQUIV SCALAR
TW(10):                              ! SCALAR EQUIV ARRAY
            PP_LINK2 = COM_SCPTR;        ! LINK TO SCALAR LIST FOR DIAGNOSTICS
            COM_SCPTR = PTR
            PP_ADDR4=M;! bytes
            -> MEET3
TW(14):     ! ARRAY EQUIV ARRAY
            PP_LINK2=COM_SCPTR
            COM_SCPTR=PTR
MEET2:      %if W = 3 %thenstart; ! COMMON OR SCALAR IN ARRAY AREA
               PP_ADDR4=M;! bytes
            %finishelsestart;     ! ARRAY
               DVREC == RECORD(COM_ADICT+PP_ADDR4)
!* N.B RELOCATE ARRAY BASE BY START OF AREA
               DVREC_ADFIRST = M
               Dvrec_Addrzero=M-Dvrec_Addrzero
               %if COM_SUBPROGTYPE#5 %thenstart;! EXCEPT BLOCKDATA
                  SET ARRAY HEAD(DVREC_ADDRDV,IIN,M,Dvrec_Addrzero,PP_Type)
               %finish
            %finish
         %finish
MEET3:   PTR = K
         PP_IIN=IIN
         K = SS_LINK1;               ! TO POINT AT NEXT ITEM DESCRIPTOR
!!         SS_LINK1=ASL(3)
!!         ASL(3)=PTR                  ! temporarily conceeding this list space
         %if K=0 %then %exit;! previous error
         SS == RECORD(COM_ADICT+K)
         PTR = SS_INF0
      %repeat %until PTR = J 
      %RETURN
!*
%INTEGERFN NEXT COORD
      %IF COM_NEXTBIT<512 %THENSTART
         CURBIT=COM_NEXTBIT
         COM_NEXTBIT=CURBIT+1
      %FINISH
      %RESULT=CURBIT
%END;! NEXT COORD
!*
%routine Dv(%integer Dvaddr,Mode)
!* generate dope vector for array
!* Mode = 0  normal allocation
!*        1  partial allocation (no dvarea descriptors)
!*        2  finalise allocation (set dvarea descriptors)
%integer I,J,K,L,D,Dvbase
      Dvrec ==record(Com_Adict+Dvaddr)
      %if Mode<2 %thenstart
         Dvrec_Ellength = N
         Dvrec_Addrzero=Dvrec_Zerotofirst*Dvrec_Ellength
      %finish
      Dvrec_Addrdv=0;! in case only partial init
      %if Com_Subprogtype # 5 %and Mode#1 %thenstart
         %if DVAREA=GLA %then K=Com_Glaca %else K=Com_Scalarca
         Dvbase=K
         %if Class=5 %thenstart;! param - reserve hole for zerotofirst
            Ed4(DVAREA,K,Dvrec_Zerotofirst)
            K=K+4
         %finish
         %if Sztype=CHARTYPE %thenstart
            %if PP_Len=0 %then K=K+4;! reserve space for actual arg len
            I=Dvrec_Numels*PP_Len
         %finishelsestart
            I=Dvrec_Numels
         %finish
         K=K+4
         Dvrec_Addrdv=K
         K=K+8
         Ed4(DVAREA,K-4,I);! numels or numchars(for char arrays)
         %if PP_Class&X'C0'#0 %and Dvrec_Dims>1 %thenstart;! > 1 adj dim
            %cycle I=2,1,Dvrec_Dims
               Ed4(DVAREA,K,Dvrec_B(I)_M)
               K=K+4
            %repeat
         %finish
         J=Dv Space(K-Dvbase,I)
      %finish
      %if Mode<2 %thenstart;! first time for this array
         N = Dvrec_Numels*N
      %finish
%end;                                   ! Dv
!*
!*
%end;                                   ! ALLOC
!*
%externalintegerfn New Subprogram(%integer Ptr,P1,Ctyp,%integername Er)
!***********************************************************************
!* FOLLOWS PROGRAM, SUBROUTINE, FUNCTION, ENTRY OR BLOCKDATA           *
!***********************************************************************
!*
%conststring(12)%array Prg(0:5)=  %C
   "main program",
   "program    ",
   "function   ",
   "subroutine ",
   "   entry   ",
   "blockdata  "
!*
%integer I,J
!*
%record(Precf) %name PP
%record(Precf) %name QQ
      PP==record(Com_Adict+Ptr)
      %if P1 = 4 %thenstart;         ! entry
         Com_Entries=Com_Entries+1
         Er = 100;                     ! SYNTAX
         %result = 4 %unless 2 <= Com_Subprogtype <= 3
                                     ! UNLESS FUNCTION OR SUBROUTINE
         Er = 141;                    ! INVALID ENTRY name
         %result=4 %unless Ctyp<0 %or PP_X1&1=0;! MUST BE A 'NEW' OR UNUSED IDENTIFIER
         %result=4 %if PP_Class#0
         Er=235
         %result=4 %unless Com_Doptr=0 %and Com_Ifptr=0;! NOT VALID INSIDE A DO LOOP OR IF BLOCK
         PP_Coord=2;! standard value for fn result
         I = Com_Subprogptr
         QQ==record(Com_Adict+I)
         J=QQ_Type
         %if Com_Subprogtype=2 %thenstart;! function
            %if PP_Type=5 %thenstart
               %unless J=5 %then Er=197 %and %result=4;! entry is char,fn is not
            %finishelsestart
               %if J=5 %then Er=198 %and %result=4;! fn is char,entry is not
            %finish
         %finish
         %while I>0 %cycle;          ! THROUGH ENTRY POINT LIST
            QQ == record(Com_Adict+I)
            I = QQ_Link3<<DSCALE
         %repeat
         QQ_Link3 = Ptr>>DSCALE
      %finishelsestart
         %if P1<=1 %thenstart
            Com_Subprogtype=1
            %if Mainprog#0 %then Lfault(316);! multiple main prog
            Mainprog=1
         %finishelse Com_Subprogtype=P1
         %if Com_Opt=4 %then I=Op4 Ref(string(Com_Anames+PP_Iden))
         Com_Subprogptr=Ptr
         Com_Funresdisp=0;! NO RESULT SPACE YET ASSIGNED FOR FUNCTION
         Com_Pastart=Com_Linest
      %finish
      %if Com_Subprogtype=2 %then PP_Coord=2;! function
      %if P1<=4 %and Com_Noisy#0 %thenstart
         selectoutput(Com_Console)
         spaces(3)
         printstring(Prg(P1))
         {%if P1<=1 %then printstring("MAIN ")}
         %if P1>0 %thenstart
            printstring(string(Anames+PP_Iden))
         %finish
         newline
         %if Com_Liststream>=0 %then selectoutput(Com_Liststream)
      %finish
      %if P1#5 %thenstart
         Lastsubprogep = Ptr;             ! LOCATE THE 'LATEST' SUBPROG ENTRY
         Paramlink = addr(PP_Link2);                ! PARAM CHAIN LINK
         PP_Class = 11
         Com_Rescom1=Ptr;! will identify record for definition of plabel
      %finish
      %if P1=0 %then P1=1;! unnamed main program
      %if P1<5 %then PP_X1=PP_X1!((P1-1)<<4)
      %if Com_Opt>2 %thenstart
         %if P1<4 %then Com_Procindex=Com_Procindex+1
         %if Com_Procindex=1 %or P1=4 %then Com_Inhibop4=1;! first or entries
      %finish
      %result = 1
%end;! New Subprogram
!*
%externalintegerfn Formal Parameter(%integer Ptr,Mode,Ctyp)
!***********************************************************************
!* PROCESS FORMAL PARAMETER                                            *
!* MODE = 0  'value' TYPE                                              *
!*        1  'name' TYPE, I.E. / <IDEN> /                              *
!***********************************************************************
!*
%integer I,Er
%record(Precf) %name PP
%record(Srecf) %name SS
      PP==record(Com_Adict+Ptr)
      Er = 129;                       ! INVALID ARGUMENT
      %if Ctyp >= 0 %thenstart;   ! NOT FIRST OCCURENCE OF THIS IDEN
         %if PP_Class&2#0 %or PP_Class&X'1F'>9  %C
                             %or PP_X1&X'80'#0 %thenstart ;! in common or namelist or equiv etc.
Err:        string(Com_Adident)=string(Anames+PP_Iden)
            %result=4
         %finish
         %if PP_Class&1=0 %and PP_X1&1#0 %then %result=4;! param on entry already referenced
         %unless PP_X1&1#0 %then PP_Class=PP_Class!1;!  MARK AS PARAM UNLESS ALLOC.
         %if PP_Class&X'60'=X'60' %then PP_Class=PP_Class&X'DF';! clear 'not known as param' bit
         PP_X0=PP_X0!1 %unless PP_Type=5 %AND PP_Class&4=0;! except for char scalars
      %finishelsestart;           ! 'NEW' IDENTIFIER
         PP_X0 = 1;               ! 'VALUE' PARAM
         PP_Class=1
      %finish
      I=Freesp(2)
      SS==record(Com_Adict+I)
      SS_Inf0 = Ptr
      integer(Paramlink) = I;    ! PARAMLINK LOCATES PREVIOUS LINK POSITION
      Paramlink = addr(SS_Link1)
      Com_Argcnt=Com_Argcnt+1;! for Op4
      %result = 1
%end;! Formal Parameter
!*
%externalintegerfn Genfmt(%byteintegerarrayname Input,Type,
                          %string(*)%name Identifier)
%integer ER,I,J,Ptr,Tablen,Fmtlen,Ad,Len
%record(LABRECF)%name LABREC
      I=SETLAB(COM_LAB,PTR);! 1  NEW    0  ALREADY EXISTS
      LABREC==record(ADICT+PTR)
      COM_PI21INT=COM_LAB;! IN CASE OF FAULT 77
      COM_LAB = 0
      %unless LABREC_ADDR4 = 0 %thenstart
         COM_PI21INT=LABREC_LINE
         %result = 227;! LABEL SET TWICE
      %finish
      COM_LABWARN = 0
      ER=0
      Labrec==record(Com_Adict+Ptr)
      Labrec_Addr4=Com_Ioareaca
      Labrec_Line=Com_Linest
      %if I = 0 %thenstart;! ALREADY REFERENCED
         ER = 302;! AS A STATEMENT LABEL
         %if LABREC_X0=16 %thenstart;! ASSIGNed
            LABREC_X0=8;! mark as definitely format
         %finishelsestart
            %result=ER %if LABREC_X0#8
         %finish
      %finishelsestart
         LABREC_X0=8
      %finish
      I = COM_INP
L870: %unless TYPE(I)=12 %AND INPUT(I)=10 %then I=I+1 %AND ->L870
      %unless TYPE(I)=12 %then I=I+1 %AND ->L870
      Len=I-COM_INP
      LABREC_LINK3=Len
      Ad=Com_Adict+Com_Dptr;!   workspace
      Er=Formatcd(addr(Input(0)),Com_Inp,Ad,Len,Len*4,0,0,Tablen,Fmtlen)
      %if Er=0 %thenstart
         Tablen=(Tablen+3)&X'FFFC'
         Edbytes(IOAREA,Com_Ioareaca,Tablen,Ad)
         Com_Ioareaca=Com_Ioareaca+Tablen
      %finishelsestart
         %if FMTLEN>32 %then FMTLEN=32
         %cycle J=1,1,FMTLEN
            INPUT(J)=INPUT(TABLEN+J-1)
         %repeat
         INPUT(0)=FMTLEN;! this fiddle is to ensure word allignment
         IDENTIFIER=string(addr(Input(0)))
      %finish
      COM_INP=I
      %result=ER
%end;! GEN FMT
!*
!***********************************************************************
!* ROUTINES TO DUMP DICTIONARY RECORDS                                 *
!***********************************************************************
!*
%ROUTINE PRHEX(%INTEGER J)
%INTEGER K
      %CYCLE K = 28,-4,0
         PRINT SYMBOL(HEX((J>>K)&15))
      %REPEAT
%END
!*
%ROUTINE PH(%INTEGER I)
%INTEGER J,K,L
prhex(integer(i))
spaces(2)
%return
%END
!*
%ROUTINE DICREC(%INTEGER A,ID)
%RECORD(PRECF)%NAME PP
%INTEGER I
      I = ADICT+A
      PP==RECORD(I)
      PRHEX(A)
      SPACES(6)
      PH(I)
      PH(I+W1)
      SPACES(2)
      PH(I+W2)
      PH(I+3*W1)
      SPACES(2)
      NEWLINE
      WRITE(A,7)
      SPACES(6)
      PH(I+W4)
      PH(I+5*W1)
      SPACES(2)
      PH(I+6*W1)
      PH(I+7*W1)
      SPACES(2)
      %IF ID#0 %THENSTART
         WRITE(PP_COORD,2)
         SPACES(2)
         PRINTSTRING(STRING(ANAMES+PP_IDEN))
      %FINISH
      NEWLINES(2)
%END
!*
%ROUTINE DICRECLIST(%INTEGER HEAD,ID)
%RECORD(PRECF) %NAME P
      %WHILE HEAD # 0 %CYCLE
         P == RECORD(ADICT+HEAD)
         DICREC(HEAD,ID)
         %IF ID#0 %AND P_CLASS&X'C'=4 %THEN DICREC(P_ADDR4,0);! ARRAY DV
         %IF P_CLASS=12 %THEN DICREC(HEAD+32,0);! common block
         HEAD = P_LINK1
      %REPEAT
%END;                                   ! DICRECLIST
!*
%externalroutine Dumpdict(%integer Mode)
%INTEGER I, J
      NEWLINE
      PRINTSTRING("IDEN LISTS:")
      NEWLINE
      %CYCLE I = 0,1,154
         J = INTEGER(COM_ADLHEAD+I<<2{BSCALE})
         %IF J # 0 %THENSTART
            WRITE(I,1);  NEWLINE
            DICRECLIST(J,1)
         %FINISH
      %REPEAT
      PRINTSTRING("LABEL LISTS:")
       NEWLINE
      %CYCLE I = 0,1,31
         J = INTEGER(COM_ALABH+I<<2{BSCALE})
         %IF J # 0 %THENSTART
            WRITE(I,1)
            NEWLINE
            DICRECLIST(J,0)
         %FINISH
      %REPEAT
      %if Mode=0 %then %return
      printstring("
Full Dict:
")
      I=0
      J=0
      %while I<Com_Dptr %cycle
         %if J=0 %then Prhex(I) %and spaces(4)
         PH(Adict+I)
         I=I+2
         J=J+1
         %if J=6 %then newline %and J=0
      %repeat
      newline
%end;! Dumpdict
!*
%externalroutine Op4 Resetanal
      Chead0=0
      Chead1=0
      Chead2=0
      Chead3=0
%end;! Op4 Resetanal
!*
%endoffile