!* modified 07/05/82
!*
!***********************************************************************
!***********************************************************************
!*
!*
!***********************************************************************
!* Formats for accessing dictionary records                            *
!***********************************************************************
!*
%RECORDFORMAT PRECF( %C
               %BYTEINTEGER CLASS,TYPE,X0,X1, %C
               %INTEGER LINK1, LINK2, LINK3, ADDR4,  %C
               %HALFINTEGER DISP,LEN,IDEN,IIN,  %C
               %INTEGER 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(%HALFINTEGER DIMS, ADDRDV,  %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   = 16
%CONSTINTEGER CNSTRECMIN   =  4
%CONSTINTEGER IMPDORECSIZE = 12;! size of DATA-implied-DO list item
%CONSTINTEGER LABRECSIZE   = 40
%CONSTINTEGER PLABRECSIZE  = 16
%CONSTINTEGER XREFSIZE     =  8
%CONSTINTEGER CMNRECEXT    = 16;! extra space on iden record for common block name
%CONSTINTEGER TMPRECSIZE    = 12
%CONSTINTEGER DVRECSIZE    = 20
!*
!***********************************************************************
!* 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))
!*
!***********************************************************************
!***********************************************************************
!*
!*
%RECORDFORMAT COMFMT(%INTEGER CONTROL,OPTIONS,OPTIONS1,OPTIONS2,PTRACE,
      ADICT,ANAMES,ADOUTPUT,ADBLKDTAID,DICLEN,DPTR,
      MAXTRIADS,NEXTPLAB,ALABH,ADLHEAD,
      SUBPROGTYPE,SFPTR,EXTERNALS,CBNPTR,SCPTR,CHECKLIST,
      RESCOM1,RESCOM2,GLACA,FNO,FAULTY,LINEST,CMNIIN,SFMK,
      LISTL,LISTSTREAM,DIAGSTREAM,LISTPOINT,XREF,
      PACKCMN,ITSMODE,PATHANAL,CHARACTER CODE,SPACE CHAR,
      HEADINGS,ARRAYCHECKS,JBRMODE,MESSLEN,NAMESLEN,
      NEXTCH,FUNRESDISP,WARNCOUNT,INP,MAXINP,MESSCOUNT,
      UNASSPATTERN,LISTCODE,PI21INT,DOPTR,SUBPROGPTR,
      FNLST,LAB,NAMESFREE,ALGOLREF,FIRSTSTATNUM,CEXPDICT,
      COMMONBASE,FASTPROLOGUE,STATEMENT,IFPTR,
      CNSTCA,COMMENTCNT,ADIDENT,ADERRIDEN,
      ADEXT,MAXDICT,MAXNAMES,MAXOUTPUT,MAXEXT,
      ACOMP,ASUBNAMES,MAXPSTACK,
      ATRIADS,TRFILEID,TRBLOCK,CMNCNT,SCANONLY,NOISY)
!*
%OWNINTEGER ANAMES
%OWNINTEGER ADICT
%OWNSTRING(32) AREANAME
!************************************************** SATISFY REFS*****
!*
%CONSTINTEGER BLCMPTR=48
!*
%EXTERNALROUTINE MAP(%INTEGER ATTR,XREF,MAPS,AREA5 OFFSET,COMAD)
%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)
%integerarrayformat lheadf(0:154)
%integerarrayname lhead
%record(comfmt)%name com
      com==record(comad)
      lhead==array(com_adlhead,lheadf)
      adict=com_adict
      anames=com_anames
      xref=1
      NEWLINES(3)
      PRINTSTRING("Identifier  Attributes")
         PRINTSTRING("                       References")
      NEWLINE
      %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=CHARNO(STRING(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=12-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)
         %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
      I=40-LEN
      %IF I<=0 %THEN I=1
      SPACES(I)
      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=8
      %WHILE J#0 %CYCLE
         SS==RECORD(ADICT+J)
         I=SS_INF0
         %IF I#K %THENSTART
            K=I
            %IF L=0 %THEN NEWLINE %AND SPACES(40) %AND L=8
            L=L-1
            WRITE(I,4)
         %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=4 %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