home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / toolpack.000 / toolpack / toolpack1.2 / tools / istpf / PFLIB2.MAC.f < prev    next >
Encoding:
Text File  |  1989-03-04  |  38.9 KB  |  1,067 lines
  1.  
  2. C type PFPU = record
  3. C               NAME: integer; (* index into NAMTXT *)
  4. C               NARGS: integer;
  5. C               ARGS: ^(heap) HEAD (PFPUARG); (* 0 = nil *)
  6. C               COMMONS: ^(heap) HEAD (PFPUCU); (* 0 for ENTRY points *)
  7. C               PARENTS: ^(heap) HEAD (PARENT); (* ditto *)
  8. C               DESC: ^(heap) HEAD (PFPUDESC);  (* ditto *)
  9. C               DTYPE: integer;
  10. C               CHRLEN: integer;
  11. C               ACTUAL: ^PFPU         (* 0 except for ENTRY points *)
  12. C             end;
  13.  
  14. C type PFEX = record
  15. C               NAME: integer;
  16. C               DTYPE: integer;
  17. C               CHRLEN: integer;
  18. C               NARGS: integer;
  19. C               ARGS: ^(heap) HEAD(PFEXARG);
  20. C               INDARG: ^PFPUARG    (* only for indirect refs *)
  21. C             end;
  22.  
  23. C type PFPUARG = record
  24. C                   DTYPE: integer;
  25. C                   CHLEN: integer;
  26. C                   case STRUC of
  27. C                       var,array: (USAGE: (arg,read,update));
  28. C                       proc: (REF: integer (EXNODE index))
  29. C                       end;
  30. C                   STRUC: (var,array,proc);
  31. C                   SIZE: integer;
  32. C                   DESC: ^(heap) HEAD (PUARGDES);
  33. C                   PROCS: ^(heap) HEAD (PFPROC);
  34. C                   PRNTS: ^(heap) HEAD (LATPAR)
  35. C                end;
  36.  
  37. C type PFEXARG = record
  38. C                   DTYPE: integer;
  39. C                   ATYPE: integer;
  40. C                   PROCS: ^(heap) HEAD (PFPROC);
  41. C                   if (DTYPE=type_char) then
  42. C                       CHMIN,CHMAX: integer
  43. C                   end if
  44. C                 end;
  45.  
  46. C type PFPUDESC = record
  47. C                   NODE: integer (* +ve => index into PUNODE,
  48. C                                    -ve => -index into EXNODE *)
  49. C                 end;
  50. C
  51. C type PFPUCU = record
  52. C                   CBNUM: integer; (* index into CBDATA *)
  53. C                   USAGE: (readonly,update)
  54. C               end;
  55.  
  56. C type PUARGDES = record
  57. C                   TYPE: (direct,indirect);
  58. C                   ANUM: integer;  (* argument number passed out as *)
  59. C                   case TYPE of
  60. C                       direct: (NODE: integer); (* PUNODE/EXNODE index *)
  61. C                       indirect: (INUM: integer)   (* arg no. passed to *)
  62. C                       end
  63. C                 end;
  64.  
  65. C type PFPROC = record
  66. C                   NODE: integer;  (* PUNODE/EXNODE index of associated pu *)
  67. C                   ASSOC: integer; (* ditto of associating pu. *)
  68. C                   STMTNO: integer (* statement number of association *)
  69. C               end;
  70.  
  71. C
  72. C type PARENT = record (* routine parent *)
  73. C                   NODE: integer   (* PUNODE index of parent routine *)
  74. C               end;
  75. C
  76. C type APARENT = record (* argument parent *)
  77. C                   NODE: integer;  (* PUNODE index of parent routine *)
  78. C                   ANUM: integer   (* argument number passed down *)
  79. C                end;
  80.  
  81. C type PFUS = record (* unsafe reference check record *)
  82. C               TYPE: 1..5;      (* unsafe reference type *)
  83. C               ASSOC: integer;  (* punode index of calling p.u. *)
  84. C               STMTNO: integer; (* statement number of reference *)
  85. C               EXTRA: integer;  (* type-dependent extra data *)
  86. C               CALLED: integer; (* punode/exnode index of called routine *)
  87. C               ARGNUM: integer  (* argument number for unsafe check *)
  88. C             end;
  89. C---------------------------------------------------------
  90. C    TOOLPACK/1    Release: 2.5
  91. C---------------------------------------------------------
  92. C YXLIB Customisation Parameters
  93. C ------------------------------
  94.  
  95. C Routine Names
  96. C -------------
  97.  
  98. C Field Definitions: Parse Tree Attributes
  99. C ----------------------------------------
  100. C Note: The high-order bit in the word (bit 31 in a 32-bit machine) MUST
  101. C       NOT BE USED, as ordinary arithmetic is used to extract some fields
  102.  
  103. C Attribute Table Macros
  104. C ----------------------
  105.  
  106. C YXLIB Bits
  107. C ----------
  108.  
  109. C YXLIB Local Record Macros
  110. C -------------------------
  111. C   type VARX = record
  112. C                   su: integer;    (* Storage units for variable *)
  113. C                   common: ^(S_COMMON) or -maxint..-1;
  114. C                                   (* ^(common block symbol), nil (0) or
  115. C                                      negative of equivalence class number *)
  116. C                   comsize: integer;(* Offset in common or equiv class *)
  117. C                   equiv: ^EQV;    (* Pointer to equivalence link *)
  118. C                   if SYMBOL(var_arr_decl)<>0 then array: ARRAYX
  119. C                                   (* array information stored here *)
  120. C               end;
  121. C
  122. C   type ARRAYX = record
  123. C                   elts: integer;  (* Number of elements in the array *)
  124. C                   dims: integer;  (* Number of dimensions of the array *)
  125. C                   limits: array [1..dims] of
  126. C                               record LOWER,UPPER: integer end
  127. C                 end;
  128.  
  129.  
  130. C   type EQH = HEAD record          (* Equivalence head record *)
  131. C                       common: ^(S_COMMON) or -maxint..-1;
  132. C                       usage: set of usage_bits
  133. C                   end;
  134.  
  135. C   type EQV = LINK record          (* Equivalence variable record (link) *)
  136. C                       sudif: integer;
  137. C                       symbol: ^(S_VAR)
  138. C                   end;
  139.  
  140. C   type LPR = record
  141. C                   glob: ^(GPU) or -^(GEX);
  142. C                   nargs: integer;
  143. C                   args: array [1..nargs] of packed record
  144. C                               dtype: min_dtype..max_dtype;
  145. C                               argument_type: atype;
  146. C                               descendents: ^HEAD;
  147. C                               if dtype=type_char then
  148. C                                   min_length, max_length: integer
  149. C                               end if
  150. C                           end record
  151. C              end;
  152.  
  153. C                                   (* Argument type definitions *)
  154. C   type ATYPE = (scalar,arelm,array,proc,label);
  155. C   const min_atype = scalar; max_atype = label;
  156.  
  157. C YXLIB Record Definition: Semi-Local
  158. C -----------------------------------
  159. C   type PAREC = LINK record
  160. C                   argnum: integer; (* Argument number passed down as *)
  161. C                   prsym: ^(S_PROC); (* Procedure passed down to *)
  162. C                   argsym: ^symbol; (* Actual argument being passed down *)
  163. C                   pusym: ^(S_PU); (* Associating program-unit (context) *)
  164. C                   stmtno: integer; (* Statement number of assoc (context) *)
  165. C                end;
  166.  
  167. C   type UNSAF = LINK record
  168. C                   code: 1..5;     (* Type of unsafe reference to be checked *)
  169. C                   argnum: integer;(* Argument number applicable *)
  170. C                   extra: anything;(* Extra data (not used by inherit_expr) *)
  171. C                   pusym: ^(S_PU); (* Context: associating program-unit *)
  172. C                   stmtno: integer;(* Context: statement number *)
  173. C                   prsym: ^(S_PROC)(* proc being called *)
  174. C                end;
  175.  
  176. C YXLIB Global Record Macros
  177. C --------------------------
  178. C
  179. C   type G_COM = record             Global common block record
  180. C                   size: integer;
  181. C                   type: (character,numeric,mixed); (* logical = numeric *)
  182. C                   save: (saved,not_saved,only_in_main);
  183. C                   init: integer   (* Number of times init'ed by block data *)
  184. C                end;
  185.  
  186. C
  187. C   type G_PU = record              Global program-unit record
  188. C                   dtype: integer;
  189. C                   chrlen: integer;
  190. C                   culist: ^HEAD;  (* common block usage list header ptr *)
  191. C                   nargs: integer;
  192. C                   descend: ^HEAD; (* descendent routine list header ptr *)
  193. C                   entrys: ^(HEAD) record ^G_ENT end;
  194. C                   args: array [1..nargs] of gpuarg
  195. C               end;
  196.  
  197. C   type G_ENT = record
  198. C                   dtype: integer;
  199. C                   chrlen: integer;
  200. C                   pu: ^G_PU;
  201. C                   nargs: integer;
  202. C                   descend: ^HEAD; (* descendent routine list header ptr *)
  203. C                   args: array [1..nargs] of ^guparg
  204. C                end;
  205.  
  206. C type gpuarg = record
  207. C                   dtype,chlen: integer;
  208. C                   usage: (arg,read,update);
  209. C                   struc: (scal,array,proc,label);
  210. C                   size: integer;
  211. C                   pass: ^HEAD;
  212. C                   inh: ^HEAD(inherit)
  213. C               end;
  214. C type inherit = record
  215. C                   type: (proc,expr,dupl,comm,sfa,doix,arg);
  216. C                   ass: ^(GPU);    (* associating program-unit *)
  217. C                   snum: integer;  (* statement number of association *)
  218. C                   if (type=proc) then
  219. C                       gsyptr: ^(GPU)/-^(GEX)
  220. C                   else
  221. C                       extra: integer (* unsafe ref extra data *)
  222. C                   end if
  223.  
  224.  
  225. C Global Descendant Routine Types
  226. C -------------------------------
  227.  
  228. C Error Codes returned by YXLIB
  229. C -----------------------------
  230.  
  231.  
  232.  
  233.  
  234.  
  235.  
  236.  
  237.  
  238. C                                   parameter length
  239.  
  240.  
  241.  
  242.  
  243.  
  244.  
  245.  
  246. C ----------------------------------------------------------------------
  247. C
  248. C       P F R E A D   -   Read PFORT information from the attribute area
  249. C
  250.  
  251.         SUBROUTINE PFREAD
  252.  
  253. C---------------------------------------------------------
  254. C    TOOLPACK/1    Release: 2.5
  255. C---------------------------------------------------------
  256.         COMMON/PFWMRK/NPU,NEX
  257.         INTEGER NPU,NEX
  258.         SAVE /PFWMRK/
  259. C---------------------------------------------------------
  260. C    TOOLPACK/1    Release: 2.5
  261. C---------------------------------------------------------
  262.         COMMON/PFPU/ NPUS,MAINND,PUNODE
  263.         INTEGER NPUS,MAINND,PUNODE(500)
  264.         SAVE /PFPU/
  265. C---------------------------------------------------------
  266. C    TOOLPACK/1    Release: 2.5
  267. C---------------------------------------------------------
  268.         COMMON/PFCB/NCB,CBDATA
  269.         INTEGER NCB,CBDATA(6,250)
  270.         SAVE /PFCB/
  271. C---------------------------------------------------------
  272. C    TOOLPACK/1    Release: 2.5
  273. C---------------------------------------------------------
  274.         COMMON/PFEXTS/NEXTS,EXNODE
  275.         INTEGER NEXTS,EXNODE(500)
  276.         SAVE /PFEXTS/
  277.  
  278.         CALL PFADCB
  279.         CALL PFADPU
  280.         CALL PFADEN
  281.         CALL PFADEX
  282.         CALL PFADP2
  283.         CALL PFADE2
  284.         NPU=NPUS
  285.         NEX=NEXTS
  286.  
  287.         END
  288. C ----------------------------------------------------------------------
  289. C
  290. C       P F A D N A   -   Add a global name to the PFORT-77 database
  291. C
  292. C       Input argument:
  293. C           INAME   - The name as an IST string.
  294. C
  295. C       Output arguments:
  296. C           STATUS  - 0 => New name
  297. C                     1 => Name of an existing program-unit
  298. C                     2 => Name of an existing common block
  299. C                     3 => Name of an existing external reference
  300. C
  301. C           NAMPTR  - Index into NAMTXT, except for STATUS.EQ.2, when it
  302. C                     is an index into CBDATA.
  303. C
  304.  
  305.         SUBROUTINE PFADNA(INAME,NAMPTR,STATUS)
  306.         INTEGER INAME(*),NAMPTR,STATUS
  307.  
  308. C---------------------------------------------------------
  309. C    TOOLPACK/1    Release: 2.5
  310. C---------------------------------------------------------
  311.         COMMON/PFNAME/NAMTXT
  312.         COMMON/PFNAMI/NNAMES,NAMEPU
  313.         CHARACTER*6 NAMTXT(800)
  314.         INTEGER NNAMES,NAMEPU(800)
  315.         SAVE /PFNAME/,/PFNAMI/
  316. C---------------------------------------------------------
  317. C    TOOLPACK/1    Release: 2.5
  318. C---------------------------------------------------------
  319.         COMMON/PFPU/ NPUS,MAINND,PUNODE
  320.         INTEGER NPUS,MAINND,PUNODE(500)
  321.         SAVE /PFPU/
  322. C---------------------------------------------------------
  323. C    TOOLPACK/1    Release: 2.5
  324. C---------------------------------------------------------
  325.         COMMON/PFCB/NCB,CBDATA
  326.         INTEGER NCB,CBDATA(6,250)
  327.         SAVE /PFCB/
  328. C---------------------------------------------------------
  329. C    TOOLPACK/1    Release: 2.5
  330. C---------------------------------------------------------
  331.         COMMON/PFEXTS/NEXTS,EXNODE
  332.         INTEGER NEXTS,EXNODE(500)
  333.         SAVE /PFEXTS/
  334. C---------------------------------------------------------
  335. C    TOOLPACK/1    Release: 2.5
  336. C---------------------------------------------------------
  337.         COMMON/PFHEAP/USHEAD,HEAP
  338.         INTEGER USHEAD,HEAP(200000)
  339.  
  340.         SAVE /PFHEAP/
  341.  
  342.         INTEGER I
  343.         CHARACTER*6 NAME
  344.  
  345.         EXTERNAL ZITOF,ERROR
  346.  
  347.         CALL ZITOF(INAME,1,6,NAME,.FALSE.)
  348.  
  349.         DO 100 I=1,NPUS
  350.             IF (NAMTXT(HEAP(PUNODE(I))).EQ.NAME) THEN
  351.                 STATUS=1
  352.                 NAMPTR=HEAP(PUNODE(I))
  353.                 RETURN
  354.             END IF
  355.  100    CONTINUE
  356.         DO 200 I=1,NCB
  357.             IF (NAMTXT(CBDATA(1,I)).EQ.NAME) THEN
  358.                 STATUS=2
  359.                 NAMPTR=I
  360.                 RETURN
  361.             END IF
  362.  200    CONTINUE
  363.         DO 300 I=1,NEXTS
  364.             IF (NAMTXT(HEAP(EXNODE(I))).EQ.NAME) THEN
  365.                 STATUS=3
  366.                 NAMPTR=HEAP(EXNODE(I))
  367.                 RETURN
  368.             END IF
  369.  300    CONTINUE
  370.         STATUS=0
  371.         IF (NNAMES.EQ.800) CALL ERROR('PFADNA: Too many names')
  372.         NNAMES=NNAMES+1
  373.         NAMTXT(NNAMES)=NAME
  374.         NAMEPU(NNAMES)=0
  375.         NAMPTR=NNAMES
  376.  
  377.         END
  378. C ----------------------------------------------------------------------
  379. C
  380. C       P F A D C B   -   Add common blocks to the PFORT-77 database
  381. C
  382.  
  383.         SUBROUTINE PFADCB
  384.  
  385. C---------------------------------------------------------
  386. C    TOOLPACK/1    Release: 2.5
  387. C---------------------------------------------------------
  388.         COMMON/PFCB/NCB,CBDATA
  389.         INTEGER NCB,CBDATA(6,250)
  390.         SAVE /PFCB/
  391.  
  392.         INTEGER GCBPTR,COMLEN,COMTYP,COMSAV,COMINI,NAMPTR,STATUS,
  393.      +          INAME(134),BLNKCM(8)
  394.  
  395.         INTEGER EQUAL
  396.         EXTERNAL ZYXGCB,ZCHOUT,PUTLIN,ZMESS,EQUAL
  397.  
  398.         DATA BLNKCM/36,67,79,77,77,79,78,129/
  399.  
  400.         GCBPTR=-1
  401.  100    CALL ZYXGCB(GCBPTR,INAME,COMLEN,COMTYP,COMSAV,COMINI)
  402.         IF (GCBPTR.GE.0) THEN
  403.             CALL PFADNA(INAME,NAMPTR,STATUS)
  404.             IF (STATUS.NE.2 .AND. STATUS.NE.0) THEN
  405.                 CALL ZCHOUT('Error: Name clash: "',2)
  406.                 CALL PUTLIN(INAME,2)
  407.                 CALL ZCHOUT('" is both a common block & a ',2)
  408.                 IF (STATUS.EQ.1) THEN
  409.                     CALL ZMESS('program-unit',2)
  410.                 ELSE
  411.                     CALL ZMESS('called subprogram',2)
  412.                 END IF
  413.             ELSE IF (STATUS.EQ.0) THEN
  414.                 IF (NCB.EQ.250)
  415.      +              CALL ERROR ('PFADCB: Too many Common Blocks.')
  416.                 NCB=NCB+1
  417.                 CBDATA(1,NCB)=NAMPTR
  418.                 CBDATA(2,NCB)=COMLEN
  419.                 CBDATA(3,NCB)=COMTYP
  420.                 IF (COMTYP.EQ.2) CALL PFERR(
  421.      +'E: Common block /$T/ mixes character a'//'nd numeric data',
  422.      +                     CBDATA(1,NAMPTR),0,0,0)
  423.                 CBDATA(4,NCB)=COMSAV
  424.                 CBDATA(5,NCB)=COMINI
  425.             ELSE IF (COMLEN.NE.CBDATA(2,NAMPTR)) THEN
  426.                 IF (EQUAL(INAME,BLNKCM).EQ.-3)
  427.      +              CALL PFERR(
  428.      +                  'E: Common block /$T/ has differing lengths',
  429.      +                  CBDATA(1,NAMPTR),0,0,0)
  430.             ELSE IF (COMINI.NE.0) THEN
  431.                 CBDATA(5,NAMPTR)=CBDATA(5,NAMPTR)+COMINI
  432.                 IF (CBDATA(5,NAMPTR).GT.1) THEN
  433.                     CALL PFERR(
  434.      +'E: Common block /$T/ initialised more than once',
  435.      +                         CBDATA(1,NAMPTR),0,0,0)
  436.                 END IF
  437.             ELSE IF (COMTYP.NE.CBDATA(3,NAMPTR) .AND.
  438.      +               CBDATA(3,NAMPTR).NE.2) THEN
  439.                 CALL PFERR(
  440.      +'E: Common block /$T/ mixes character a'//'nd numeric data',
  441.      +                     CBDATA(1,NAMPTR),0,0,0)
  442.                 CBDATA(3,NAMPTR)=2
  443.             END IF
  444.             IF (GCBPTR.NE.0) GOTO 100
  445.         END IF
  446.  
  447.         END
  448. C ----------------------------------------------------------------------
  449. C
  450. C       P F A D P U   -   Add a program-unit node to the PFORT-77 graph
  451. C
  452.  
  453.         SUBROUTINE PFADPU
  454.  
  455. C---------------------------------------------------------
  456. C    TOOLPACK/1    Release: 2.5
  457. C---------------------------------------------------------
  458.         COMMON/PFHEAP/USHEAD,HEAP
  459.         INTEGER USHEAD,HEAP(200000)
  460.  
  461.         SAVE /PFHEAP/
  462. C---------------------------------------------------------
  463. C    TOOLPACK/1    Release: 2.5
  464. C---------------------------------------------------------
  465.         COMMON/PFCB/NCB,CBDATA
  466.         INTEGER NCB,CBDATA(6,250)
  467.         SAVE /PFCB/
  468. C---------------------------------------------------------
  469. C    TOOLPACK/1    Release: 2.5
  470. C---------------------------------------------------------
  471.         COMMON/PFWMRK/NPU,NEX
  472.         INTEGER NPU,NEX
  473.         SAVE /PFWMRK/
  474. C---------------------------------------------------------
  475. C    TOOLPACK/1    Release: 2.5
  476. C---------------------------------------------------------
  477.         COMMON/PFPU/ NPUS,MAINND,PUNODE
  478.         INTEGER NPUS,MAINND,PUNODE(500)
  479.         SAVE /PFPU/
  480. C---------------------------------------------------------
  481. C    TOOLPACK/1    Release: 2.5
  482. C---------------------------------------------------------
  483.         COMMON/PFNAME/NAMTXT
  484.         COMMON/PFNAMI/NNAMES,NAMEPU
  485.         CHARACTER*6 NAMTXT(800)
  486.         INTEGER NNAMES,NAMEPU(800)
  487.         SAVE /PFNAME/,/PFNAMI/
  488.  
  489.         INTEGER GPUPTR,INAME(134),DTYPE,CHRLEN,NARGS,CULIST,I,DESC,
  490.      +          ARG(7,60),NAMPTR,STATUS,NODE,GSYPTR,CUSAGE,TMP,
  491.      +          PUARG(0:8-1),ELIST,CBNAME(134),COMLEN,
  492.      +          COMTYP,COMSAV,COMINI,CBI
  493.  
  494.         INTEGER HALLOC,LLCRHE,LLCRED,ZYXGIC,ZIAND,LLCREL
  495.         EXTERNAL ZYXGPU,ZITOF,HALLOC,LLCRHE,LLCRED,ZYXGIC,ZIAND,
  496.      +           ZYXGCU,LLCREL,ZCHOUT,PUTLIN,ZMESS,LLINTO,ERROR
  497.  
  498.         GPUPTR=-1
  499.  
  500.  100    CALL ZYXGPU(GPUPTR,INAME,DTYPE,CHRLEN,NARGS,CULIST,DESC,ELIST,
  501.      +                ARG)
  502.         CALL PFADNA(INAME,NAMPTR,STATUS)
  503.         IF (STATUS.EQ.2) THEN
  504.             CALL ZCHOUT('Error: Name clash - ',2)
  505.             CALL PUTLIN(INAME,2)
  506.             CALL ZMESS(' is both a program unit a'//'nd a common block',
  507.      +                 2)
  508.         ELSE IF (STATUS.EQ.1) THEN
  509.             CALL ZCHOUT('Error: Program unit ',2)
  510.             CALL PUTLIN(INAME,2)
  511.             CALL ZMESS(' occurs more than once',2)
  512.         ELSE
  513.             NPUS=NPUS+1
  514.             NAMEPU(NAMPTR)=NPUS
  515.             NODE=HALLOC(HEAP,9)
  516.             IF (NPUS.GT.500)
  517.      +          CALL ERROR ('PFADPU: Too many program units.')
  518.             PUNODE(NPUS)=NODE
  519.             HEAP(NODE+0)=NAMPTR
  520.             HEAP(NODE+1)=NARGS
  521.             HEAP(NODE+2)=0
  522.             HEAP(NODE+3)=0
  523.             HEAP(NODE+4)=0
  524.             HEAP(NODE+8)=0
  525.             IF (NARGS.GT.0) THEN
  526.                 HEAP(NODE+2)=LLCRHE(HEAP,0)
  527.                 DO 200 I=1,NARGS
  528.                     PUARG(0)=ARG(1,I)
  529.                     PUARG(1)=ARG(2,I)
  530.                     PUARG(2)=ARG(3,I)
  531.                     PUARG(3)=ARG(4,I)
  532.                     PUARG(4)=ARG(5,I)
  533.                     PUARG(5)=ARG(6,I)
  534.                     PUARG(6)=ARG(7,I)
  535.                     PUARG(7)=0
  536.                     IF (PUARG(3).EQ.2)
  537.      +                  PUARG(2)=0
  538.                     CALL LLINTO(HEAP,
  539.      +                          LLCRED(HEAP,8,PUARG),
  540.      +                          HEAP(NODE+2))
  541.  200            CONTINUE
  542.             END IF
  543.             IF (CULIST.NE.0) THEN
  544.                 HEAP(NODE+3)=LLCRHE(HEAP,0)
  545.  300            CALL ZYXGCU(CULIST,GSYPTR,CUSAGE)
  546.                 CALL ZYXGCB(GSYPTR,CBNAME,COMLEN,COMTYP,COMSAV,
  547.      +                        COMINI)
  548. C Call PFADNA in order to obtain the COMMON block index.
  549.                 CALL PFADNA(CBNAME,CBI,STATUS)
  550.                 TMP=LLCREL(HEAP,2)
  551.                 HEAP(TMP+0)=CBI
  552. C *** NOTE ***
  553. C * A common block is considered to be modified if an element is passed
  554. C * out as an actual argument to an external routine - we do not check
  555. C * to see if the external routine modifies the argument...
  556. C ***
  557. C * We could of course, since we may have this information as part of
  558. C * the unsafe reference checks, but this is too expensive to do
  559. C * properly.
  560. C *** END NOTE ***
  561.                 IF (ZIAND(CUSAGE,16+32+64+
  562.      +                           65536+131072).EQ.0) THEN
  563.                     HEAP(TMP+1)=0
  564.                 ELSE
  565.                     HEAP(TMP+1)=1
  566.                 END IF
  567.                 CALL LLINTO(HEAP,TMP,HEAP(NODE+3))
  568.                 IF (CULIST.NE.0) GOTO 300
  569.             END IF
  570.             HEAP(NODE+5)=DESC
  571.             HEAP(NODE+6)=DTYPE
  572.             HEAP(NODE+7)=CHRLEN
  573.         END IF
  574.         IF (GPUPTR.GT.0) GOTO 100
  575.  
  576.         END
  577. C ----------------------------------------------------------------------
  578. C
  579. C       P F A D E N   -   Add an entry point node to the PFORT-77 graph
  580. C
  581.  
  582.         SUBROUTINE PFADEN
  583.  
  584. C---------------------------------------------------------
  585. C    TOOLPACK/1    Release: 2.5
  586. C---------------------------------------------------------
  587.         COMMON/PFHEAP/USHEAD,HEAP
  588.         INTEGER USHEAD,HEAP(200000)
  589.  
  590.         SAVE /PFHEAP/
  591. C---------------------------------------------------------
  592. C    TOOLPACK/1    Release: 2.5
  593. C---------------------------------------------------------
  594.         COMMON/PFCB/NCB,CBDATA
  595.         INTEGER NCB,CBDATA(6,250)
  596.         SAVE /PFCB/
  597. C---------------------------------------------------------
  598. C    TOOLPACK/1    Release: 2.5
  599. C---------------------------------------------------------
  600.         COMMON/PFWMRK/NPU,NEX
  601.         INTEGER NPU,NEX
  602.         SAVE /PFWMRK/
  603. C---------------------------------------------------------
  604. C    TOOLPACK/1    Release: 2.5
  605. C---------------------------------------------------------
  606.         COMMON/PFPU/ NPUS,MAINND,PUNODE
  607.         INTEGER NPUS,MAINND,PUNODE(500)
  608.         SAVE /PFPU/
  609. C---------------------------------------------------------
  610. C    TOOLPACK/1    Release: 2.5
  611. C---------------------------------------------------------
  612.         COMMON/PFNAME/NAMTXT
  613.         COMMON/PFNAMI/NNAMES,NAMEPU
  614.         CHARACTER*6 NAMTXT(800)
  615.         INTEGER NNAMES,NAMEPU(800)
  616.         SAVE /PFNAME/,/PFNAMI/
  617.  
  618.         INTEGER GENPTR,INAME(134),DTYPE,CHRLEN,NARGS,GPU,I,DESC,
  619.      +          ARG(0:7-1,60),NAMPTR,STATUS,NODE,
  620.      +          GSYPTR,CUSAGE,TMP,PUARG(0:8-1)
  621.         CHARACTER*6 NAME
  622.  
  623.         INTEGER HALLOC,LLCRHE,LLCRED,ZYXGIC,ZIAND,LLCREL
  624.         EXTERNAL ZITOF,HALLOC,LLCRHE,LLCRED,ZYXGIC,ZIAND,
  625.      +           ZYXGCU,LLCREL,ZCHOUT,PUTLIN,ZMESS,LLINTO,ERROR
  626.  
  627.         GENPTR=-1
  628.  
  629.  100    CALL ZYXGEN(GENPTR,INAME,DTYPE,CHRLEN,NARGS,GPU,DESC,ARG)
  630.         IF (GENPTR.EQ.-1) RETURN
  631.         CALL PFADNA(INAME,NAMPTR,STATUS)
  632.         IF (STATUS.EQ.2) THEN
  633.             CALL ZCHOUT('Error: Name clash - ',2)
  634.             CALL PUTLIN(INAME,2)
  635.             CALL ZMESS(' is both a program unit a'//'nd a common block',
  636.      +                 2)
  637.         ELSE IF (STATUS.EQ.1) THEN
  638.             CALL ZCHOUT('Error: Program unit ',2)
  639.             CALL PUTLIN(INAME,2)
  640.             CALL ZMESS(' occurs more than once',2)
  641.         ELSE
  642.             NPUS=NPUS+1
  643.             NAMEPU(NAMPTR)=NPUS
  644.             NODE=HALLOC(HEAP,9)
  645.             IF (NPUS.GT.500)
  646.      +          CALL ERROR ('PFADEN: Too many program units.')
  647.             PUNODE(NPUS)=NODE
  648.             HEAP(NODE+0)=NAMPTR
  649.             HEAP(NODE+1)=NARGS
  650.             HEAP(NODE+2)=0
  651.             HEAP(NODE+3)=0
  652.             HEAP(NODE+4)=0
  653.             HEAP(NODE+8)=GPU
  654.             IF (NARGS.GT.0) THEN
  655.                 HEAP(NODE+2)=LLCRHE(HEAP,0)
  656.                 DO 200 I=1,NARGS
  657.                     PUARG(0)=ARG(0,I)
  658.                     PUARG(1)=ARG(1,I)
  659.                     PUARG(2)=ARG(2,I)
  660.                     PUARG(3)=ARG(3,I)
  661.                     PUARG(4)=ARG(4,I)
  662.                     PUARG(5)=ARG(5,I)
  663.                     PUARG(6)=ARG(6,I)
  664.                     PUARG(7)=0
  665.                     CALL LLINTO(HEAP,
  666.      +                          LLCRED(HEAP,8,PUARG),
  667.      +                          HEAP(NODE+2))
  668.  200            CONTINUE
  669.             END IF
  670.             HEAP(NODE+5)=DESC
  671.             HEAP(NODE+6)=DTYPE
  672.             HEAP(NODE+7)=CHRLEN
  673.         END IF
  674.         IF (GENPTR.GT.0) GOTO 100
  675.  
  676.         END
  677. C ----------------------------------------------------------------------
  678. C
  679. C       P F A D E X   -   Add external references to the PFORT-77 graph
  680. C
  681.  
  682.         SUBROUTINE PFADEX
  683.  
  684. C---------------------------------------------------------
  685. C    TOOLPACK/1    Release: 2.5
  686. C---------------------------------------------------------
  687.         COMMON/PFEXTS/NEXTS,EXNODE
  688.         INTEGER NEXTS,EXNODE(500)
  689.         SAVE /PFEXTS/
  690. C---------------------------------------------------------
  691. C    TOOLPACK/1    Release: 2.5
  692. C---------------------------------------------------------
  693.         COMMON/PFHEAP/USHEAD,HEAP
  694.         INTEGER USHEAD,HEAP(200000)
  695.  
  696.         SAVE /PFHEAP/
  697.  
  698.         INTEGER GEXPTR,INAME(134),DTYPE,CHRLEN,NARGS,STATUS,NAMPTR,
  699.      +          ARGBLK(4*60),NODE,I,ARGNOD,ARGPTR
  700.  
  701.         INTEGER HALLOC,LLCRHE,LLCREL
  702.         EXTERNAL ZYXGEX,HALLOC,LLCRHE,LLCREL,LLINTO,ZCHOUT,PUTLIN,
  703.      +           ZMESS,ERROR
  704.  
  705.         GEXPTR=-1
  706.  
  707.  100    CALL ZYXGEX(GEXPTR,INAME,DTYPE,CHRLEN,NARGS,ARGBLK)
  708.         IF (GEXPTR.GE.0) THEN
  709.             CALL PFADNA(INAME,NAMPTR,STATUS)
  710.             IF (STATUS.EQ.2) THEN
  711.                 CALL ZCHOUT('Error: Name clash - ',2)
  712.                 CALL PUTLIN(INAME,2)
  713.                 CALL ZMESS(' is both a common block 38 an external '//
  714.      +                     'reference',2)
  715.             ELSE IF (NEXTS.EQ.500) THEN
  716.                 CALL ERROR('Too many external references')
  717.             ELSE
  718.                 NEXTS=NEXTS+1
  719.                 NODE=HALLOC(HEAP,6)
  720.                 EXNODE(NEXTS)=NODE
  721.                 HEAP(NODE+0)=NAMPTR
  722.                 HEAP(NODE+1)=DTYPE
  723.                 HEAP(NODE+2)=CHRLEN
  724.                 HEAP(NODE+3)=NARGS
  725.                 HEAP(NODE+5)=0
  726.                 IF (NARGS.GT.0) THEN
  727.                     HEAP(NODE+4)=LLCRHE(HEAP,0)
  728.                     ARGPTR=1
  729.                     DO 200 I=1,NARGS
  730.                         DTYPE=ARGBLK(ARGPTR+0)/8+(-3)
  731.                         IF (DTYPE.EQ.6) THEN
  732.                             ARGNOD=LLCREL(HEAP,5)
  733.                             HEAP(ARGNOD+0)=DTYPE
  734.                             HEAP(ARGNOD+1)=
  735.      +                          MOD(ARGBLK(ARGPTR+0),8)
  736.                             HEAP(ARGNOD+2)=
  737.      +                          ARGBLK(ARGPTR+1)
  738.                             HEAP(ARGNOD+3)=
  739.      +                          ARGBLK(ARGPTR+2)
  740.                             HEAP(ARGNOD+4)=
  741.      +                          ARGBLK(ARGPTR+3)
  742.                             ARGPTR=ARGPTR+4
  743.                         ELSE
  744.                             ARGNOD=LLCREL(HEAP,3)
  745.                             HEAP(ARGNOD+0)=DTYPE
  746.                             HEAP(ARGNOD+1)=
  747.      +                          MOD(ARGBLK(ARGPTR+0),8)
  748.                             HEAP(ARGNOD+2)=
  749.      +                          ARGBLK(ARGPTR+1)
  750.                             ARGPTR=ARGPTR+2
  751.                         END IF
  752.                         CALL LLINTO(HEAP,ARGNOD,HEAP(NODE+4))
  753.  200                CONTINUE
  754.                 END IF
  755.             END IF
  756.             IF (GEXPTR.GT.0) GOTO 100
  757.         END IF
  758.  
  759.         END
  760. C ----------------------------------------------------------------------
  761. C
  762. C       P F A D P 2   -   Add program-units, pass two
  763. C
  764.  
  765.         SUBROUTINE PFADP2
  766.  
  767. C---------------------------------------------------------
  768. C    TOOLPACK/1    Release: 2.5
  769. C---------------------------------------------------------
  770.         COMMON/PFHEAP/USHEAD,HEAP
  771.         INTEGER USHEAD,HEAP(200000)
  772.  
  773.         SAVE /PFHEAP/
  774. C---------------------------------------------------------
  775. C    TOOLPACK/1    Release: 2.5
  776. C---------------------------------------------------------
  777.         COMMON/PFPU/ NPUS,MAINND,PUNODE
  778.         INTEGER NPUS,MAINND,PUNODE(500)
  779.         SAVE /PFPU/
  780. C---------------------------------------------------------
  781. C    TOOLPACK/1    Release: 2.5
  782. C---------------------------------------------------------
  783.         COMMON/PFWMRK/NPU,NEX
  784.         INTEGER NPU,NEX
  785.         SAVE /PFWMRK/
  786. C---------------------------------------------------------
  787. C    TOOLPACK/1    Release: 2.5
  788. C---------------------------------------------------------
  789.         COMMON/PFEXTS/NEXTS,EXNODE
  790.         INTEGER NEXTS,EXNODE(500)
  791.         SAVE /PFEXTS/
  792. C---------------------------------------------------------
  793. C    TOOLPACK/1    Release: 2.5
  794. C---------------------------------------------------------
  795.         COMMON/PFCB/NCB,CBDATA
  796.         INTEGER NCB,CBDATA(6,250)
  797.         SAVE /PFCB/
  798. C---------------------------------------------------------
  799. C    TOOLPACK/1    Release: 2.5
  800. C---------------------------------------------------------
  801.         COMMON/PFNAME/NAMTXT
  802.         COMMON/PFNAMI/NNAMES,NAMEPU
  803.         CHARACTER*6 NAMTXT(800)
  804.         INTEGER NNAMES,NAMEPU(800)
  805.         SAVE /PFNAME/,/PFNAMI/
  806.  
  807.         INTEGER I,DESC,ARG,REFTYP,ARGNUM,DESREC(6),PASSX,INHX,GSYPTR,
  808.      +          ASSOC,INHTYP,STMTNO,EXTRA,ANUM,STATUS,TEXT(134)
  809.         LOGICAL CRHEAD
  810.  
  811.         INTEGER ZYXGIP,ZYXGIE,LLFIRS,LLCRHE,LLCRED,LLNEXT
  812.         EXTERNAL ZYXGGD,ZYXGIP,ZYXGIE,ZYXGPA,
  813.      +           ZYXGIR,LLFIRS,LLCRHE,LLCRED,LLNEXT,LLINTO,
  814.      +           ZYXGNA
  815.  
  816.         DO 500 I=NPU+1,NPUS
  817.             DESC=HEAP(PUNODE(I)+5)
  818.             HEAP(PUNODE(I)+5)=0
  819. C Resolve pointer to actual p.u. for entry points
  820.             IF (HEAP(PUNODE(I)+8).NE.0) THEN
  821.                 HEAP(PUNODE(I)+8)=
  822.      +              NPU+ZYXGIP(HEAP(PUNODE(I)+8))
  823. C And make the actual p.u. a descendent of the ENTRY point...
  824.                 HEAP(PUNODE(I)+5)=LLCRHE(HEAP,0)
  825.                 CALL LLINTO(HEAP,LLCRED(HEAP,1,HEAP(PUNODE(I)+8)),
  826.      +                      HEAP(PUNODE(I)+5))
  827.             END IF
  828.             IF (DESC.NE.0) THEN
  829. C
  830. C Add descendent routines of the program-unit
  831. C
  832.  100            CALL ZYXGGD(DESC,REFTYP,GSYPTR,ARGNUM)
  833.                 IF (REFTYP.EQ.1) THEN
  834.                     CALL ZYXGNA(GSYPTR,TEXT)
  835.                     CALL PFADNA(TEXT,DESREC(1),STATUS)
  836.                     IF (STATUS.NE.1) CALL PFERR(
  837.      +'I: PFADP2-A: unexpected return from PFADNA ($I)',STATUS,0,0,0)
  838.                     DESREC(1)=NAMEPU(DESREC(1))
  839.                     IF (HEAP(PUNODE(I)+5).EQ.0)
  840.      +                  HEAP(PUNODE(I)+5)=LLCRHE(HEAP,0)
  841.                     CALL LLINTO(HEAP,
  842.      +                          LLCRED(HEAP,1,DESREC),
  843.      +                          HEAP(PUNODE(I)+5))
  844.                 ELSE IF (REFTYP.EQ.2) THEN
  845.                     DESREC(1)=-(NEX+ZYXGIE(GSYPTR))
  846.                     IF (HEAP(PUNODE(I)+5).EQ.0)
  847.      +                  HEAP(PUNODE(I)+5)=LLCRHE(HEAP,0)
  848.                     CALL LLINTO(HEAP,
  849.      +                          LLCRED(HEAP,1,DESREC),
  850.      +                          HEAP(PUNODE(I)+5))
  851.                 ELSE IF (REFTYP.EQ.5) THEN
  852.                     CALL PFERR(
  853.      +'D: Indirect ref descriptor ($I) added for argument $I of $N',
  854.      +                         GSYPTR,ARGNUM,PUNODE(I),0)
  855.                     ARG=LLFIRS(HEAP,HEAP(PUNODE(I)+2))
  856.  150                IF (ARGNUM.GT.1) THEN
  857.                         ARG=LLNEXT(HEAP,ARG)
  858.                         ARGNUM=ARGNUM-1
  859.                         GOTO 150
  860.                     END IF
  861.                     HEAP(ARG+2)=NEX+ZYXGIE(GSYPTR)
  862.                 END IF
  863.                 IF (DESC.NE.0) GOTO 100
  864.             END IF
  865.             IF (HEAP(PUNODE(I)+1).GT.0) THEN
  866. C
  867. C For each argument, ...
  868. C
  869.                 ARG=LLFIRS(HEAP,HEAP(PUNODE(I)+2))
  870.                 ANUM=1
  871. C
  872. C ... If this is a procedure argument, add a pointer from the procedure
  873. C     back to the argument record
  874. C
  875.  200            IF (HEAP(ARG+3).EQ.2 .AND.
  876.      +              HEAP(ARG+2).NE.0)
  877.      +              HEAP(EXNODE(HEAP(ARG+2))+5)=ARG
  878.                 IF (HEAP(ARG+5).NE.0) THEN
  879. C
  880. C ... add argument descendents
  881. C
  882.                     PASSX=HEAP(ARG+5)
  883.                     HEAP(ARG+5)=LLCRHE(HEAP,0)
  884.  300                CALL ZYXGPA(PASSX,ARGNUM,DESC)
  885.                     DESREC(1+0)=0
  886.                     DESREC(1+1)=ARGNUM
  887.                     CALL ZYXGGD(DESC,REFTYP,GSYPTR,ARGNUM)
  888.                     IF (REFTYP.EQ.5) THEN
  889.                         DESREC(1+0)=1
  890.                         DESREC(1+2)=ARGNUM
  891.                     ELSE IF (REFTYP.EQ.1) THEN
  892.                         CALL ZYXGNA(GSYPTR,TEXT)
  893.                         CALL PFADNA(TEXT,DESREC(1+2),STATUS)
  894.                         IF (STATUS.NE.1) CALL PFERR(
  895.      +'I: PFADP2-B: unexpected return from PFADNA ($I)',STATUS,0,0,0)
  896.                         DESREC(1+2)=
  897.      +                      NAMEPU(DESREC(1+2))
  898.                     ELSE
  899.                         IF (REFTYP.NE.2) CALL PFERR(
  900.      +'I: Unexpected reference type ($I) in $N',REFTYP,PUNODE(I),0,0)
  901.                         DESREC(1+2)=
  902.      +                      -(NEX+ZYXGIE(ABS(GSYPTR)))
  903.                     END IF
  904.                     CALL LLINTO(HEAP,LLCRED(HEAP,3,DESREC),
  905.      +                          HEAP(ARG+5))
  906.                     IF (PASSX.NE.0) GOTO 300
  907.                 END IF
  908.                 IF (HEAP(ARG+6).NE.0) THEN
  909. C
  910. C ... add procedure arguments inherited, and unsafe reference checks
  911. C
  912.                     INHX=HEAP(ARG+6)
  913.                     HEAP(ARG+6)=0
  914.  400                CALL ZYXGIR(INHX,INHTYP,ASSOC,STMTNO,EXTRA)
  915.                     IF (INHTYP.EQ.0) THEN
  916.                         IF (HEAP(ARG+6).EQ.0)
  917.      +                      HEAP(ARG+6)=LLCRHE(HEAP,0)
  918.                         IF (EXTRA.GT.0) THEN
  919.                             CALL ZYXGNA(EXTRA,TEXT)
  920.                             CALL PFADNA(TEXT,DESREC(1+0),STATUS)
  921.                             IF (STATUS.NE.1) CALL PFERR(
  922.      +'I: PFADP2-C: unexpected return from PFADNA ($I)',STATUS,0,0,0)
  923.                             DESREC(1+0)=
  924.      +                          NAMEPU(DESREC(1+0))
  925.                         ELSE
  926.                             DESREC(1+0)=-NEX-ZYXGIE(-EXTRA)
  927.                         END IF
  928.                         CALL ZYXGNA(ASSOC,TEXT)
  929.                         CALL PFADNA(TEXT,DESREC(1+1),STATUS)
  930.                         IF (STATUS.NE.1) CALL PFERR(
  931.      +'I: PFADP2-D: unexpected return from PFADNA ($I)',STATUS,0,0,0)
  932.                         DESREC(1+1)=NAMEPU(DESREC(1+1))
  933.                         DESREC(1+2)=STMTNO
  934.                         CALL LLINTO(HEAP,LLCRED(HEAP,3,DESREC),
  935.      +                              HEAP(ARG+6))
  936.                     ELSE
  937.                         DESREC(1+0)=INHTYP
  938.                         CALL ZYXGNA(ASSOC,TEXT)
  939.                         CALL PFADNA(TEXT,DESREC(1+1),STATUS)
  940.                         IF (STATUS.NE.1) CALL PFERR(
  941.      +'I: PFADP2-E: unexpected return from PFADNA ($I)',STATUS,0,0,0)
  942.                         DESREC(1+1)=NAMEPU(DESREC(1+1))
  943.                         DESREC(1+2)=STMTNO
  944.                         IF (INHTYP.EQ.3) THEN
  945.                             CALL ZYXGNA(EXTRA,TEXT)
  946.                             CALL PFADNA(TEXT,DESREC(1+3),STATUS)
  947.                             IF (STATUS.NE.2) CALL PFERR(
  948.      +'I: PFADP2-F: unexpected return from PFADNA ($I)',STATUS,0,0,0)
  949.                         ELSE
  950.                             DESREC(1+3)=EXTRA
  951.                         END IF
  952.                         DESREC(1+4)=I
  953.                         DESREC(1+5)=ANUM
  954.                         CALL LLINTO(HEAP,LLCRED(HEAP,6,DESREC),
  955.      +                              USHEAD)
  956.                     END IF
  957.                     IF (INHX.NE.0) GOTO 400
  958.                 END IF
  959.                 ARG=LLNEXT(HEAP,ARG)
  960.                 ANUM=ANUM+1
  961.                 IF (ARG.NE.0) GOTO 200
  962.             END IF
  963.  500    CONTINUE
  964.  
  965.         END
  966. C ----------------------------------------------------------------------
  967. C
  968. C       P F A D E 2   -   Add external references, part two
  969. C
  970.  
  971.         SUBROUTINE PFADE2
  972.  
  973. C---------------------------------------------------------
  974. C    TOOLPACK/1    Release: 2.5
  975. C---------------------------------------------------------
  976.         COMMON/PFHEAP/USHEAD,HEAP
  977.         INTEGER USHEAD,HEAP(200000)
  978.  
  979.         SAVE /PFHEAP/
  980. C---------------------------------------------------------
  981. C    TOOLPACK/1    Release: 2.5
  982. C---------------------------------------------------------
  983.         COMMON/PFEXTS/NEXTS,EXNODE
  984.         INTEGER NEXTS,EXNODE(500)
  985.         SAVE /PFEXTS/
  986. C---------------------------------------------------------
  987. C    TOOLPACK/1    Release: 2.5
  988. C---------------------------------------------------------
  989.         COMMON/PFWMRK/NPU,NEX
  990.         INTEGER NPU,NEX
  991.         SAVE /PFWMRK/
  992. C---------------------------------------------------------
  993. C    TOOLPACK/1    Release: 2.5
  994. C---------------------------------------------------------
  995.         COMMON/PFNAME/NAMTXT
  996.         COMMON/PFNAMI/NNAMES,NAMEPU
  997.         CHARACTER*6 NAMTXT(800)
  998.         INTEGER NNAMES,NAMEPU(800)
  999.         SAVE /PFNAME/,/PFNAMI/
  1000.  
  1001.         INTEGER I,INHX,ASSOC,DESREC(6),ARG,STMTNO,INHTYP,EXTRA,ANUM,
  1002.      +          TEXT(134),STATUS
  1003.  
  1004.         INTEGER ZYXGIE,LLCRHE,LLCRED,LLFIRS,LLNEXT
  1005.         EXTERNAL ZYXGIE,LLCRHE,LLCRED,LLFIRS,LLNEXT,ZYXGIR,
  1006.      +           LLINTO
  1007.  
  1008.         DO 300 I=NEX+1,NEXTS
  1009.             IF (HEAP(EXNODE(I)+3).GT.0) THEN
  1010.                 ARG=LLFIRS(HEAP,HEAP(EXNODE(I)+4))
  1011.                 ANUM=1
  1012.  100            IF (HEAP(ARG+2).NE.0) THEN
  1013.                     INHX=HEAP(ARG+2)
  1014.                     HEAP(ARG+2)=0
  1015.  200                CALL ZYXGIR(INHX,INHTYP,ASSOC,STMTNO,EXTRA)
  1016.                     IF (INHTYP.EQ.0) THEN
  1017.                         IF (HEAP(ARG+2).EQ.0)
  1018.      +                      HEAP(ARG+2)=LLCRHE(HEAP,0)
  1019.                         CALL ZYXGNA(ASSOC,TEXT)
  1020.                         CALL PFADNA(TEXT,DESREC(1+1),STATUS)
  1021.                         IF (STATUS.NE.1) CALL PFERR(
  1022.      +'I: PFADE2-A: unexpected return from PFADNA ($I)',STATUS,0,0,0)
  1023.                         DESREC(1+1)=NAMEPU(DESREC(1+1))
  1024.                         IF (EXTRA.GT.0) THEN
  1025.                             CALL ZYXGNA(EXTRA,TEXT)
  1026.                             CALL PFADNA(TEXT,DESREC(1+0),STATUS)
  1027.                             IF (STATUS.NE.1) CALL PFERR(
  1028.      +'I: PFADE2-B: unexpected return from PFADNA ($I)',STATUS,0,0,0)
  1029.                             DESREC(1+0)=
  1030.      +                          NAMEPU(DESREC(1+0))
  1031.                         ELSE
  1032.                             DESREC(1+0)=-(NEX+ZYXGIE(-EXTRA))
  1033.                         END IF
  1034.                         DESREC(1+2)=STMTNO
  1035.                         CALL LLINTO(HEAP,LLCRED(HEAP,3,DESREC),
  1036.      +                              HEAP(ARG+2))
  1037.                     ELSE
  1038.                         DESREC(1+0)=INHTYP
  1039.                         CALL ZYXGNA(ASSOC,TEXT)
  1040.                         CALL PFADNA(TEXT,DESREC(1+1),STATUS)
  1041.                         IF (STATUS.NE.1) CALL PFERR(
  1042.      +'I: PFADE2-C: unexpected return from PFADNA ($I)',STATUS,0,0,0)
  1043.                         DESREC(1+1)=NAMEPU(DESREC(1+1))
  1044.                         DESREC(1+2)=STMTNO
  1045.                         IF (INHTYP.EQ.3) THEN
  1046.                             CALL ZYXGNA(EXTRA,TEXT)
  1047.                             CALL PFADNA(TEXT,DESREC(1+3),STATUS)
  1048.                             IF (STATUS.NE.2) CALL PFERR(
  1049.      +'I: PFADE2-D: unexpected return from PFADNA ($I)',STATUS,0,0,0)
  1050.                         ELSE
  1051.                             DESREC(1+3)=EXTRA
  1052.                         END IF
  1053.                         DESREC(1+4)=-I
  1054.                         DESREC(1+5)=ANUM
  1055.                         CALL LLINTO(HEAP,LLCRED(HEAP,6,DESREC),
  1056.      +                              USHEAD)
  1057.                     END IF
  1058.                     IF (INHX.NE.0) GOTO 200
  1059.                 END IF
  1060.                 ARG=LLNEXT(HEAP,ARG)
  1061.                 ANUM=ANUM+1
  1062.                 IF (ARG.NE.0) GOTO 100
  1063.             END IF
  1064.  300    CONTINUE
  1065.  
  1066.         END
  1067.