!* modified 30/01/82
!*
!***********************************************************************
!*
!*
!***********************************************************************
!* Formats for accessing dictionary records                            *
!***********************************************************************
!*
%RECORDFORMAT PRECF( %C
               %BYTEINTEGER CLASS,TYPE,X0,X1, %C
               %INTEGER LINK1, LINK2, LINK3, ADDR4,  %C
               %HALFINTEGER DISP,LEN,  %C
               %INTEGER IDEN,LINE,XREF,CMNLENGTH, CMNREFAD)
!*
%RECORDFORMAT SRECF(%INTEGER INF0, LINK1, INF2, INF3, INF4)
!*
%RECORDFORMAT RESF((%INTEGER W %OR %HALFINTEGER H0,
                      (%HALFINTEGER H1 %OR %BYTEINTEGER FORM,MODE)))
!*
%RECORDFORMAT DORECF( %C
    %INTEGER LABEL, LINK1, LOOPAD, ENDREF,
    %RECORD(RESF) INDEXRD, INCRD, FINALRD, ICRD,
    %INTEGER LABLIST,LINE)
!*
%RECORDFORMAT BFMT(%INTEGER L,U,M)
!*
%RECORDFORMAT ARRAYDVF(%INTEGER DIMS, ADDRDV,GLADV,  %C
            %INTEGER ZEROTOFIRST, ADFIRST, NUMELS, ELLENGTH,  %C
            %RECORD(BFMT) %ARRAY B(1 : 7))
!*
!*
%RECORDFORMAT LRECF(%INTEGER NOTFLAG,LINK1,ORLIST,ANDLIST,RELOP)
!*
%RECORDFORMAT IFRECF(%INTEGER TYPE,LINK1,ENDIFJUMP,FALSELIST,  %C
                                        LABLIST,LINE)
!*
%RECORDFORMAT LABRECF(%BYTEINTEGER CLASS,TYPE,X0,X1,  %C
            %INTEGER LINK1,LINK2,LINK3,ADDR4,LINK5,LAB,LINE,  %C
            %HALFINTEGER DOSTART,DOEND,IFSTART,IFEND)
!*
%RECORDFORMAT PLABF(%INTEGER INDEX,CODEAD,REF,REFCHAIN)
!*
%RECORDFORMAT IMPDORECF(%INTEGER VAL,LINK,IDEN)
!*
%RECORDFORMAT CONRECF(%INTEGER MODE,LINK1,DADDR,CADDR)
!*
%RECORDFORMAT TMPF(%BYTEINTEGER REG,MODE,%HALFINTEGER INDEX,  %C
                    %INTEGER LINK1,ADDR)
!*
%RECORDFORMAT CHARF(%INTEGER ADESC,LINK,LEN)
!*
%RECORDFORMAT FNRECF(%INTEGER FPTR,LINK1,HEAD,PCT)
!*
!*
!***********************************************************************
!* Constants defining the size of DICT records                         *
!***********************************************************************
!*
%CONSTINTEGER IDRECSIZE    = 14;! size of dict entry reserved for a new identifier
%CONSTINTEGER CONRECSIZE   = 8
%CONSTINTEGER CNSTRECMIN   =  2
%CONSTINTEGER IMPDORECSIZE = 6;! size of DATA-implied-DO list item
%CONSTINTEGER LABRECSIZE   = 20
%CONSTINTEGER PLABRECSIZE  = 8
%CONSTINTEGER XREFSIZE     =  4
%CONSTINTEGER CMNRECEXT    = 6;! extra space on iden record for common block name
%CONSTINTEGER TMPRECSIZE     = 6
%CONSTINTEGER DVRECSIZE    = 14
!*
!***********************************************************************
!* TRIAD record format                                                 *
!***********************************************************************
!*
%RECORDFORMAT TRIADF(  %C
               %BYTEINTEGER OP,
               (%BYTEINTEGER USE %OR %BYTEINTEGER VAL2),
               %HALFINTEGER CHAIN,
               (%RECORD(RESF) RES1      %OR     %C
               (%HALFINTEGER OPD1,%BYTEINTEGER QOPD1,MODE  %OR  %C
               (%INTEGER SLN %OR %INTEGER VAL1))),
               (%RECORD(RESF) RES2      %OR   %C
                %HALFINTEGER OPD2,%BYTEINTEGER QOPD2,MODE2))
!*
!*
!***********************************************************************
!***********************************************************************
!*
!*
%EXTERNALROUTINESPEC SET HEADING(%INTEGER TYPE)
!*
%OWNINTEGER ANAMES
%OWNINTEGER ADICT
%OWNINTEGER OPTIONS1
%OWNSTRING(32) AREANAME
%OWNINTEGERARRAY LHEAD(0:154)
!************************************************** SATISFY REFS*****
!*
%CONSTINTEGER BLCMPTR=96
!*
%EXTERNALROUTINE MAP(%INTEGER ATTR,XREF,MAPS,AREA5 OFFSET,STACKBASE)
%INTEGER I, J, K
%INTEGERARRAY ALPHA, COUNT('A' : 'Z')
%RECORD(PRECF) %NAME PP
%ROUTINESPEC SORT
%ROUTINESPEC QKSORT(%STRINGARRAYNAME X, %C
        %INTEGERARRAYNAME PL, %INTEGER A, B)
%ROUTINESPEC DATA MAP(%INTEGER AD)
%ROUTINESPEC PRINTOUT(%INTEGER L)
      %IF MAPS#0 %THENSTART
         SET HEADING(3)
      %FINISHELSESTART
         %IF OPTIONS1&1#0 %THENSTART;! CE
            SPACES(38)
            PRINTSTRING("ATTRIBUTE")
            %IF XREF#0 %THEN PRINTSTRING(" AND CROSS-REFERENCE")
            PRINTSTRING(" LISTING

")
         %FINISHELSE NEWLINES(3)
         PRINTSTRING("IDENTIFIER          ATTRIBUTES")
         %IF XREF#0 %THEN   %C
            PRINTSTRING("                                  REFERENCES")
         NEWLINE
      %FINISH
      %CYCLE I = 'A',1,'Z'
         ALPHA(I) = 0
         COUNT(I) = 0
      %REPEAT
      SORT;                          ! TO ALPHABETIC LISTS
      K = 0;                         ! COUNT OF NO OF ENTRIES PRINTED ON CURRENT LINE
      %CYCLE I = 'A',1,'Z'
         J = COUNT(I)
         %IF J # 0 %THENSTART
         %BEGIN
         %INTEGER NEXTID,P
         %INTEGERARRAY PLACE(0 : J)
         %STRING (32) %ARRAY IDEN(0 : J)
                  P = 0
                  NEXTID = ALPHA(I)
                  %WHILE NEXTID # 0 %CYCLE
                     PP == RECORD(ADICT+NEXTID)
                     P = P+1
                     PLACE(P) = NEXTID
                     IDEN(P) = STRING(ANAMES+PP_IDEN)
                     NEXTID = PP_LINK1
                  %REPEAT
                  QKSORT(IDEN,PLACE,1,P)
                  %CYCLE J = 1,1,P
            %IF MAPS#0 %THEN DATA MAP(PLACE(J)) %ELSE PRINTOUT(PLACE(J))
                  %REPEAT
         %END
            %FINISH
         %REPEAT
         NEWLINE
         %RETURN
%ROUTINE SORT
%INTEGER I, J, NEXTID, K
            %CYCLE I = 0,1,154
               NEXTID = LHEAD(I)
               LHEAD(I)=0
               %WHILE NEXTID # 0 %CYCLE
                  PP == RECORD(ADICT+NEXTID)
                  %UNLESS NEXTID=BLCMPTR %THENSTART
                     J=BYTEINTEGER(ANAMES+PP_IDEN+1)
                     K = NEXTID
                     NEXTID = PP_LINK1
                     PP_LINK1 = ALPHA(J)
                     ALPHA(J) = K
                     COUNT(J) = COUNT(J)+1
                  %FINISHELSE NEXTID=PP_LINK1
               %REPEAT
            %REPEAT
            %CYCLE I=0,1,25
               LHEAD(I)=ALPHA(I+'A');! IN CASE MAP IS CALLED TWICE
            %REPEAT
%END;                                   ! SORT
            %ROUTINE QKSORT(%STRINGARRAYNAME X, %C
                            %INTEGERARRAYNAME PL, %INTEGER A, B)
%STRING (32) D
%INTEGER L, U, E
            %RETURNIF A >= B
            L = A;  
            U = B
            D = X(U)
            E = PL(U)
            -> FIND
UP:         L = L+1
            -> FOUND %IF L = U
FIND:       -> UP %UNLESS X(L) > D
            X(U) = X(L)
            PL(U) = PL(L)
DOWN:       U = U-1
            -> FOUND %IF L = U
            -> DOWN %UNLESS X(U) < D
            X(L) = X(U)
            PL(L) = PL(U)
            -> UP
FOUND:      X(U) = D
            PL(U) = E
            QKSORT(X,PL,A,L-1)
            QKSORT(X,PL,U+1,B)
%END;                                   ! QKSORT
%ROUTINE PRINTOUT(%INTEGER L)
%INTEGER T, C, I, J, K, S, LEN
%STRING (32) ID
%RECORD(PRECF) %NAME PP
%RECORD(SRECF) %NAME SS
%ROUTINESPEC PUT(%STRING(20) S)
%ROUTINESPEC WRIT(%INTEGER I)
%CONSTSTRING(2)%ARRAY SIZE(3:8)="1 ","2 ","4 ","8 ","16","32"
%CONSTSTRING(10)%ARRAY TYPE(1:5)=  %C
   "INTEGER*","REAL*","COMPLEX*","LOGICAL*","CHARACTER*"
%CONSTSTRING(10)%ARRAY SUBPROG(0:3)=  %C
   "PROGRAM","FUNCTION","SUBROUTINE","ENTRY"
%CONSTSTRING(18)%ARRAY SPECIAL(10:13)=  %C
   "NAMELIST","","COMMON BLOCK","STATEMENT FUNCTION"
!*
      PP==RECORD(ADICT+L)
      %RETURN %IF PP_X1>>4=15;! STANDARD FUNCTION
      NEWLINE
      ID=STRING(ANAMES+PP_IDEN)
      PRINTSTRING(ID)
      LEN=LENGTH(ID)
      I=20-LEN
      %IF I<=0 %THEN I=1
      SPACES(I)
      LEN=LEN+I
      C=PP_CLASS&X'1F'
      T=PP_TYPE&15
      S=PP_TYPE>>4
      %IF C<7 %THENSTART;! VARIABLE OR ARRAY
         %IF C&1#0 %THEN PUT("PARAMETER ")
         %IF C&2#0 %AND PP_X0&X'10'=0  %THEN PUT("COMMON ")
         %IF PP_X1&X'80'#0 %THEN PUT("EQUIVALENCED ")
         %IF C&4#0 %THEN PUT("ARRAY, ")  %C
                   %ELSE PUT("VARIABLE, ")
T:       PUT(TYPE(T))
         %IF T=5 %THENSTART;! CHARACTER
            WRIT(PP_LEN)
         %FINISHELSESTART
            %IF T=3 %THEN S=S+1
            PUT(SIZE(S))
         %FINISH
      %FINISHELSESTART;! SPECIAL IDEN
         %IF C=16 %THENSTART
            PUT("CONSTANT ")
            ->T
         %FINISH
         %IF C<10 %OR C=11 %THENSTART;! SUBPROGRAM
           %IF C#11 %THEN PUT("EXTERNAL ")
            PUT(SUBPROG((PP_X1>>4)&3))
         %FINISHELSESTART
            PUT(SPECIAL(C))
         %FINISH
      %FINISH
      %RETURN %IF XREF=0;! NOXREF
      SPACES(59-LEN)
      SPACE
      I=PP_XREF;! LISTHEAD OF REFS
      J=0
      %WHILE I#0 %CYCLE;! REVERSE LIST
         K=I
         SS==RECORD(ADICT+I)
         I=SS_LINK1
         SS_LINK1=J
         J=K
      %REPEAT
      PP_XREF=J
      J=L+IDRECSIZE
      K=0;! FOR NOTE OF LAST LINE WRITTEN
      L=10
      %WHILE J#0 %CYCLE
         SS==RECORD(ADICT+J)
         I=SS_INF0
         %IF I#K %THENSTART
            K=I
            %IF L=0 %THEN NEWLINE %AND SPACES(60) %AND L=10
            L=L-1
            WRITE(I,5)
         %FINISH
         J=SS_LINK1
      %REPEAT
      %RETURN
%ROUTINE PUT(%STRING(20) S)
      PRINTSTRING(S)
      LEN=LEN+LENGTH(S)
%END;! PUT
%ROUTINE WRIT(%INTEGER A)
%CONSTINTEGERARRAY M(0:3)=10000,1000,100,10
%INTEGERARRAY B(0:4)
%INTEGER I,J
         %CYCLE I=0,1,3
            B(I)=A//M(I)
            A=A-B(I)*M(I)
         %REPEAT
         B(4)=A
         J=0
         %CYCLE I=0,1,4
            %IF B(I)#0 %OR J#0 %OR I=2 %THENSTART
               PRINTSYMBOL(B(I)+'0')
               LEN=LEN+1
               J=1
            %FINISH
         %REPEAT
         %RETURN
%END;! WRIT
%END;                                   ! PRINTOUT
!*
%ROUTINE DATA MAP(%INTEGER AD)
%INTEGER CLASS,TYPE,LEN,I,OFFSET
%STRING(34) S
%RECORD(PRECF) %NAME PP
%RECORD(PRECF) %NAME CMN
%RECORD(ARRAYDVF) %NAME DV
      PP==RECORD(ADICT+AD)
      CLASS=PP_CLASS&X'1F'
      TYPE=PP_TYPE
      %RETURN %IF CLASS>7 %OR CLASS=5;! exclude non-data items and param arrays
      %IF K&1=0 %THEN NEWLINE %ELSE SPACES(22)
      K=K+1
      S=STRING(ANAMES+PP_IDEN)
      PRINTSTRING(S)
      I=16-LENGTH(S)
      %IF I<=0 %THEN I=1
      SPACES(I)
      OFFSET=PP_ADDR4
      %IF CLASS&2#0 %THENSTART;! common or scalar in local array area
         %IF PP_X0&X'10'#0 %THENSTART;! scalar in area 5
            OFFSET=OFFSET+AREA5 OFFSET
            S=AREANAME."-G"
         %FINISHELSESTART;! genuine common
            CMN==RECORD(ADICT+PP_LINK3)
            S=STRING(ANAMES+CMN_IDEN);! identifier from common block record
            %IF S="F#BLCM" %THEN S="ICL9LFBC"
            %IF CLASS&4#0 %THENSTART;! array
               DV==RECORD(ADICT+OFFSET)
               OFFSET=DV_ADFIRST
            %FINISH
         %FINISH
      %FINISHELSESTART;! local scalar or array
         %IF CLASS&4=0 %THENSTART;! scalar
            %IF TYPE=5 %THENSTART;! character
               OFFSET=PP_DISP
               S=AREANAME."-G"
            %FINISHELSESTART
               OFFSET=OFFSET+STACKBASE
               S=AREANAME."-S"
            %FINISH
         %FINISHELSESTART;! array
            DV==RECORD(ADICT+OFFSET)
            OFFSET=DV_ADFIRST+AREA5 OFFSET
            S=AREANAME."-G"
         %FINISH
      %FINISH
      PRINTSTRING(S)
      I=22-LENGTH(S)
      %IF I<1 %THEN I=1
      %IF I>15 %THEN SPACES(I-15) %AND I=15
      WRITE(OFFSET,I)
      %IF TYPE=5 %THENSTART;! char
         LEN=PP_LEN
      %FINISHELSESTART
         LEN=1<<(TYPE>>4-3)
         %IF TYPE&15=3 %THEN LEN=LEN<<1;! complex
      %FINISH
      %IF CLASS&4#0 %THEN LEN=DV_NUMELS*LEN
      WRITE(LEN,7)
%END;! DATA MAP
%END;                                   ! MAP
!*
%ENDOFFILE