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 / PFLIB3.MAC.f < prev    next >
Encoding:
Text File  |  1989-03-04  |  37.3 KB  |  1,177 lines
  1. C---------------------------------------------------------
  2. C    TOOLPACK/1    Release: 2.5
  3. C---------------------------------------------------------
  4. C type PFPU = record
  5. C               NAME: integer; (* index into NAMTXT *)
  6. C               NARGS: integer;
  7. C               ARGS: ^(heap) HEAD (PFPUARG); (* 0 = nil *)
  8. C               COMMONS: ^(heap) HEAD (PFPUCU); (* 0 for ENTRY points *)
  9. C               PARENTS: ^(heap) HEAD (PARENT); (* ditto *)
  10. C               DESC: ^(heap) HEAD (PFPUDESC);  (* ditto *)
  11. C               DTYPE: integer;
  12. C               CHRLEN: integer;
  13. C               ACTUAL: ^PFPU         (* 0 except for ENTRY points *)
  14. C             end;
  15.  
  16. C type PFEX = record
  17. C               NAME: integer;
  18. C               DTYPE: integer;
  19. C               CHRLEN: integer;
  20. C               NARGS: integer;
  21. C               ARGS: ^(heap) HEAD(PFEXARG);
  22. C               INDARG: ^PFPUARG    (* only for indirect refs *)
  23. C             end;
  24.  
  25. C type PFPUARG = record
  26. C                   DTYPE: integer;
  27. C                   CHLEN: integer;
  28. C                   case STRUC of
  29. C                       var,array: (USAGE: (arg,read,update));
  30. C                       proc: (REF: integer (EXNODE index))
  31. C                       end;
  32. C                   STRUC: (var,array,proc);
  33. C                   SIZE: integer;
  34. C                   DESC: ^(heap) HEAD (PUARGDES);
  35. C                   PROCS: ^(heap) HEAD (PFPROC);
  36. C                   PRNTS: ^(heap) HEAD (LATPAR)
  37. C                end;
  38.  
  39. C type PFEXARG = record
  40. C                   DTYPE: integer;
  41. C                   ATYPE: integer;
  42. C                   PROCS: ^(heap) HEAD (PFPROC);
  43. C                   if (DTYPE=type_char) then
  44. C                       CHMIN,CHMAX: integer
  45. C                   end if
  46. C                 end;
  47.  
  48. C type PFPUDESC = record
  49. C                   NODE: integer (* +ve => index into PUNODE,
  50. C                                    -ve => -index into EXNODE *)
  51. C                 end;
  52. C
  53. C type PFPUCU = record
  54. C                   CBNUM: integer; (* index into CBDATA *)
  55. C                   USAGE: (readonly,update)
  56. C               end;
  57.  
  58. C type PUARGDES = record
  59. C                   TYPE: (direct,indirect);
  60. C                   ANUM: integer;  (* argument number passed out as *)
  61. C                   case TYPE of
  62. C                       direct: (NODE: integer); (* PUNODE/EXNODE index *)
  63. C                       indirect: (INUM: integer)   (* arg no. passed to *)
  64. C                       end
  65. C                 end;
  66.  
  67. C type PFPROC = record
  68. C                   NODE: integer;  (* PUNODE/EXNODE index of associated pu *)
  69. C                   ASSOC: integer; (* ditto of associating pu. *)
  70. C                   STMTNO: integer (* statement number of association *)
  71. C               end;
  72.  
  73. C
  74. C type PARENT = record (* routine parent *)
  75. C                   NODE: integer   (* PUNODE index of parent routine *)
  76. C               end;
  77. C
  78. C type APARENT = record (* argument parent *)
  79. C                   NODE: integer;  (* PUNODE index of parent routine *)
  80. C                   ANUM: integer   (* argument number passed down *)
  81. C                end;
  82.  
  83. C type PFUS = record (* unsafe reference check record *)
  84. C               TYPE: 1..5;      (* unsafe reference type *)
  85. C               ASSOC: integer;  (* punode index of calling p.u. *)
  86. C               STMTNO: integer; (* statement number of reference *)
  87. C               EXTRA: integer;  (* type-dependent extra data *)
  88. C               CALLED: integer; (* punode/exnode index of called routine *)
  89. C               ARGNUM: integer  (* argument number for unsafe check *)
  90. C             end;
  91. C YXLIB Customisation Parameters
  92. C ------------------------------
  93.  
  94. C Routine Names
  95. C -------------
  96.  
  97. C Field Definitions: Parse Tree Attributes
  98. C ----------------------------------------
  99. C Note: The high-order bit in the word (bit 31 in a 32-bit machine) MUST
  100. C       NOT BE USED, as ordinary arithmetic is used to extract some fields
  101.  
  102. C Attribute Table Macros
  103. C ----------------------
  104.  
  105. C YXLIB Bits
  106. C ----------
  107.  
  108. C YXLIB Local Record Macros
  109. C -------------------------
  110. C   type VARX = record
  111. C                   su: integer;    (* Storage units for variable *)
  112. C                   common: ^(S_COMMON) or -maxint..-1;
  113. C                                   (* ^(common block symbol), nil (0) or
  114. C                                      negative of equivalence class number *)
  115. C                   comsize: integer;(* Offset in common or equiv class *)
  116. C                   equiv: ^EQV;    (* Pointer to equivalence link *)
  117. C                   if SYMBOL(var_arr_decl)<>0 then array: ARRAYX
  118. C                                   (* array information stored here *)
  119. C               end;
  120. C
  121. C   type ARRAYX = record
  122. C                   elts: integer;  (* Number of elements in the array *)
  123. C                   dims: integer;  (* Number of dimensions of the array *)
  124. C                   limits: array [1..dims] of
  125. C                               record LOWER,UPPER: integer end
  126. C                 end;
  127.  
  128.  
  129. C   type EQH = HEAD record          (* Equivalence head record *)
  130. C                       common: ^(S_COMMON) or -maxint..-1;
  131. C                       usage: set of usage_bits
  132. C                   end;
  133.  
  134. C   type EQV = LINK record          (* Equivalence variable record (link) *)
  135. C                       sudif: integer;
  136. C                       symbol: ^(S_VAR)
  137. C                   end;
  138.  
  139. C   type LPR = record
  140. C                   glob: ^(GPU) or -^(GEX);
  141. C                   nargs: integer;
  142. C                   args: array [1..nargs] of packed record
  143. C                               dtype: min_dtype..max_dtype;
  144. C                               argument_type: atype;
  145. C                               descendents: ^HEAD;
  146. C                               if dtype=type_char then
  147. C                                   min_length, max_length: integer
  148. C                               end if
  149. C                           end record
  150. C              end;
  151.  
  152. C                                   (* Argument type definitions *)
  153. C   type ATYPE = (scalar,arelm,array,proc,label);
  154. C   const min_atype = scalar; max_atype = label;
  155.  
  156. C YXLIB Record Definition: Semi-Local
  157. C -----------------------------------
  158. C   type PAREC = LINK record
  159. C                   argnum: integer; (* Argument number passed down as *)
  160. C                   prsym: ^(S_PROC); (* Procedure passed down to *)
  161. C                   argsym: ^symbol; (* Actual argument being passed down *)
  162. C                   pusym: ^(S_PU); (* Associating program-unit (context) *)
  163. C                   stmtno: integer; (* Statement number of assoc (context) *)
  164. C                end;
  165.  
  166. C   type UNSAF = LINK record
  167. C                   code: 1..5;     (* Type of unsafe reference to be checked *)
  168. C                   argnum: integer;(* Argument number applicable *)
  169. C                   extra: anything;(* Extra data (not used by inherit_expr) *)
  170. C                   pusym: ^(S_PU); (* Context: associating program-unit *)
  171. C                   stmtno: integer;(* Context: statement number *)
  172. C                   prsym: ^(S_PROC)(* proc being called *)
  173. C                end;
  174.  
  175. C YXLIB Global Record Macros
  176. C --------------------------
  177. C
  178. C   type G_COM = record             Global common block record
  179. C                   size: integer;
  180. C                   type: (character,numeric,mixed); (* logical = numeric *)
  181. C                   save: (saved,not_saved,only_in_main);
  182. C                   init: integer   (* Number of times init'ed by block data *)
  183. C                end;
  184.  
  185. C
  186. C   type G_PU = record              Global program-unit record
  187. C                   dtype: integer;
  188. C                   chrlen: integer;
  189. C                   culist: ^HEAD;  (* common block usage list header ptr *)
  190. C                   nargs: integer;
  191. C                   descend: ^HEAD; (* descendent routine list header ptr *)
  192. C                   entrys: ^(HEAD) record ^G_ENT end;
  193. C                   args: array [1..nargs] of gpuarg
  194. C               end;
  195.  
  196. C   type G_ENT = record
  197. C                   dtype: integer;
  198. C                   chrlen: integer;
  199. C                   pu: ^G_PU;
  200. C                   nargs: integer;
  201. C                   descend: ^HEAD; (* descendent routine list header ptr *)
  202. C                   args: array [1..nargs] of ^guparg
  203. C                end;
  204.  
  205. C type gpuarg = record
  206. C                   dtype,chlen: integer;
  207. C                   usage: (arg,read,update);
  208. C                   struc: (scal,array,proc,label);
  209. C                   size: integer;
  210. C                   pass: ^HEAD;
  211. C                   inh: ^HEAD(inherit)
  212. C               end;
  213. C type inherit = record
  214. C                   type: (proc,expr,dupl,comm,sfa,doix,arg);
  215. C                   ass: ^(GPU);    (* associating program-unit *)
  216. C                   snum: integer;  (* statement number of association *)
  217. C                   if (type=proc) then
  218. C                       gsyptr: ^(GPU)/-^(GEX)
  219. C                   else
  220. C                       extra: integer (* unsafe ref extra data *)
  221. C                   end if
  222.  
  223.  
  224. C Global Descendant Routine Types
  225. C -------------------------------
  226.  
  227. C Error Codes returned by YXLIB
  228. C -----------------------------
  229.  
  230.  
  231.  
  232.  
  233.  
  234.  
  235.  
  236.  
  237. C                                   parameter length
  238.  
  239.  
  240.  
  241.  
  242.  
  243.  
  244.  
  245. C ======================================================================
  246. C
  247. C       PFLIB3 Structure Chart:
  248. C       -----------------------
  249. C
  250. C                           +--------+
  251. C                           | PFCONS |
  252. C                           +---+----+
  253. C                               |
  254. C     +-----------+-----------+-+---------+-----------+-----------+
  255. C     |           |           |           |           |           |
  256. C +---+----+  +---+----+  +---+----+  +---+----+  +---+----+  +---+----+
  257. C | PFSETE |  | PFSETR |  | PFSETM |  | PFSETL |  | PFINVO |  | PFSETP |
  258. C +---+----+  +---+----+  +---+----+  +---+----+  +---+----+  +---+----+
  259. C     |           |                       |           |           |
  260. C     |           +------+                |           |           |
  261. C     |                  |            +---+----+  +---+----+  +---+----+
  262. C     +-----------+      |            | PFASLV*|  | PFPROC |  | PFADPA |
  263. C     |           |      |            +--------+  +---+----+  +--------+
  264. C +---+----+  +---+----+ |                            |
  265. C | PFCHK1*|  | PFMERG | |                +-----------+-----------+
  266. C +--------+  +--------+ |                |           |           |
  267. C                        |            +---+----+  +---+----+  +---+----+
  268. C       +----------+-----+-----+      | PFCHK1*|  | PFADPR |  | PFASLV*|
  269. C       |          |           |      +--------+  +--------+  +--------+
  270. C   +---+---+  +---+----+  +---+----+
  271. C   | PFSRD |  | PFSRAD |  | PFSRAP |
  272. C   +-------+  +--------+  +--------+
  273. C
  274. C '*' indicates that the module occurs more than once in the chart.
  275. C This chart does not include routines from PFLIB0 which are called.
  276. C
  277. C ----------------------------------------------------------------------
  278. C
  279. C       P F C O N S   -   Finish construction of PFORT-77 data structure
  280. C
  281.  
  282.         SUBROUTINE PFCONS
  283.  
  284. C
  285. C Move procarg info from ex nodes to pu nodes, and check that
  286. C matching ex & pu nodes are compatible
  287.         CALL PFSETE
  288. C
  289. C Make all links refer to pu nodes instead of ex nodes;
  290. C delete all direct ex-links (they are not processed further).
  291.         CALL PFSETR
  292. C
  293. C Set the main program-unit pointer
  294.         CALL PFSETM
  295. C
  296. C Set the invocation level of all program-units, ignoring the effects of
  297. C procargs
  298.         CALL PFSETL
  299. C
  300. C Invoke program-units to push procargs down the tree, changing the
  301. C invocation level where appropriate
  302.         CALL PFINVO
  303. C
  304. C Setup parent lists
  305.         CALL PFSETP
  306.  
  307.         END
  308. C ----------------------------------------------------------------------
  309. C
  310. C       P F S E T E   -   set external information;
  311. C                           moves proc-arg inf from ex nodes to pu nodes
  312. C                           and does basic external matchup checks.
  313. C
  314.  
  315.         SUBROUTINE PFSETE
  316.  
  317.         COMMON/PFEXTS/NEXTS,EXNODE
  318.         INTEGER NEXTS,EXNODE(500)
  319.         SAVE /PFEXTS/
  320.         COMMON/PFPU/ NPUS,MAINND,PUNODE
  321.         INTEGER NPUS,MAINND,PUNODE(500)
  322.         SAVE /PFPU/
  323.         COMMON/PFHEAP/USHEAD,HEAP
  324.         INTEGER USHEAD,HEAP(200000)
  325.  
  326.         SAVE /PFHEAP/
  327.  
  328.         INTEGER I,P
  329.  
  330.         LOGICAL PFCHK1
  331.         INTEGER PFETOP
  332.  
  333.         DO 100 I=1,NEXTS
  334.             P=PFETOP(I)
  335.             IF (P.GT.0) THEN
  336.                 IF (PFCHK1(EXNODE(I),PUNODE(P)))
  337.      +              CALL PFMERG(EXNODE(I),PUNODE(P))
  338.             ELSE IF (P.EQ.0) THEN
  339.                 IF (HEAP(EXNODE(I)+1).EQ.-1) THEN
  340.                     CALL PFERR('W: Missing subroutine $N',
  341.      +                         EXNODE(I),0,0,0)
  342.                 ELSE
  343.                     CALL PFERR('W: Missing function $N',
  344.      +                         EXNODE(I),0,0,0)
  345.                 END IF
  346.             END IF
  347.  100    CONTINUE
  348.  
  349.         END
  350. C ----------------------------------------------------------------------
  351. C
  352. C       P F C H K 1   -   Reference checking part 1
  353. C
  354.  
  355.         LOGICAL FUNCTION PFCHK1(E,P)
  356.         INTEGER E,P
  357.  
  358.         COMMON/PFHEAP/USHEAD,HEAP
  359.         INTEGER USHEAD,HEAP(200000)
  360.  
  361.         SAVE /PFHEAP/
  362.  
  363.         INTEGER EARG,PARG,ARGNUM
  364.  
  365.         INTEGER LLFIRS,LLNEXT
  366.         LOGICAL ZYXCAS
  367.         EXTERNAL LLFIRS,LLNEXT,ZYXCAS
  368.  
  369.         PFCHK1=.FALSE.
  370.         IF (HEAP(E+1).NE.HEAP(P+6)) THEN
  371.             CALL PFERR(
  372.      +'E: Wrong datatype of subprogram reference to $N',
  373.      +                 E,0,0,0)
  374.         ELSE IF (HEAP(E+2).NE.HEAP(P+7) .AND.
  375.      +           HEAP(E+2).NE.0 .AND.
  376.      +           HEAP(P+7).NE.0) THEN
  377.             CALL PFERR(
  378.      +'E: Wrong character length of function reference to $N',
  379.      +                 E,0,0,0)
  380.             CALL PFERR(' (length is $I, should be $I)',
  381.      +                 HEAP(E+2),HEAP(P+7),0,0)
  382.         ELSE IF (HEAP(E+3).LT.0) THEN
  383. C No further checking if only passed out as an actual argument
  384.             PFCHK1=.TRUE.
  385.         ELSE IF (HEAP(E+3).NE.HEAP(P+1)) THEN
  386.             CALL PFERR(
  387.      +'E: Wrong nu'//'mber of arguments in reference to $N',
  388.      +                 E,0,0,0)
  389.         ELSE IF (HEAP(E+3).EQ.0) THEN
  390.             PFCHK1=.TRUE.
  391.         ELSE
  392.             EARG=LLFIRS(HEAP,HEAP(E+4))
  393.             PARG=LLFIRS(HEAP,HEAP(P+2))
  394.             ARGNUM=1
  395.  100        IF (HEAP(EARG+0).NE.HEAP(PARG+0))
  396.      +      THEN
  397.                 CALL PFERR(
  398.      +'E: Argument $I of wrong data-type in reference to $N',
  399.      +                     ARGNUM,E,0,0)
  400.             ELSE IF (.NOT.ZYXCAS(HEAP(PARG+3),
  401.      +                           HEAP(EARG+1))) THEN
  402.                 CALL PFERR(
  403.      +'E: Argument $I has the wrong structure in reference to $N',
  404.      +                     ARGNUM,E,0,0)
  405.             ELSE
  406.                 EARG=LLNEXT(HEAP,EARG)
  407.                 PARG=LLNEXT(HEAP,PARG)
  408.                 ARGNUM=ARGNUM+1
  409.                 IF (EARG.NE.0) GOTO 100
  410.                 PFCHK1=.TRUE.
  411.             END IF
  412.         END IF
  413.  
  414.         END
  415. C ----------------------------------------------------------------------
  416. C
  417. C       P F M E R G   -   Merge proc-arg lists from ex node to pu node
  418. C
  419.  
  420.         SUBROUTINE PFMERG(E,P)
  421.         INTEGER E,P
  422.  
  423.         COMMON/PFHEAP/USHEAD,HEAP
  424.         INTEGER USHEAD,HEAP(200000)
  425.  
  426.         SAVE /PFHEAP/
  427.  
  428.         INTEGER EARG,PARG,EPROC
  429.  
  430.         INTEGER LLFIRS,LLNEXT,LLCRHE
  431.         EXTERNAL LLFIRS,LLNEXT,LLCRHE,LLINTO
  432.  
  433.         IF (HEAP(E+3).LE.0) RETURN
  434.         EARG=LLFIRS(HEAP,HEAP(E+4))
  435.         PARG=LLFIRS(HEAP,HEAP(P+2))
  436.  
  437.  100    IF (HEAP(EARG+1).EQ.3 .AND.
  438.      +      HEAP(EARG+2).NE.0) THEN
  439.             IF (HEAP(PARG+6).EQ.0)
  440.      +          HEAP(PARG+6)=LLCRHE(HEAP,0)
  441.  200        EPROC=LLFIRS(HEAP,HEAP(EARG+2))
  442.             IF (EPROC.NE.0) THEN
  443.                 CALL LLINTO(HEAP,EPROC,HEAP(PARG+6))
  444.                 GOTO 200
  445.             END IF
  446.         END IF
  447.         EARG=LLNEXT(HEAP,EARG)
  448.         PARG=LLNEXT(HEAP,PARG)
  449.         IF (EARG.NE.0) GOTO 100
  450.  
  451.         END
  452. C ----------------------------------------------------------------------
  453. C
  454. C       P F S E T R   -   Set reference information
  455. C                           makes links point to pu nodes not ex nodes
  456. C
  457.  
  458.         SUBROUTINE PFSETR
  459.  
  460.         COMMON/PFPU/ NPUS,MAINND,PUNODE
  461.         INTEGER NPUS,MAINND,PUNODE(500)
  462.         SAVE /PFPU/
  463.         COMMON/PFHEAP/USHEAD,HEAP
  464.         INTEGER USHEAD,HEAP(200000)
  465.  
  466.         SAVE /PFHEAP/
  467.  
  468.         INTEGER I,TMP,ARG,USREF
  469.  
  470.         INTEGER PFETOP
  471.  
  472.         INTEGER LLFIRS,LLNEXT
  473.         EXTERNAL LLFIRS,LLNEXT,LLDELE
  474.  
  475.         DO 200 I=1,NPUS
  476.             IF (HEAP(PUNODE(I)+5).GT.0) THEN
  477.                 CALL PFSRD(HEAP(PUNODE(I)+5))
  478.             END IF
  479.             IF (HEAP(PUNODE(I)+2).NE.0) THEN
  480.                 ARG=LLFIRS(HEAP,HEAP(PUNODE(I)+2))
  481.  100            IF (HEAP(ARG+5).NE.0)
  482.      +              CALL PFSRAD(HEAP(ARG+5))
  483.                 IF (HEAP(ARG+3).EQ.2 .AND.
  484.      +              HEAP(ARG+6).NE.0)
  485.      +              CALL PFSRAP(HEAP(ARG+6))
  486.                 ARG=LLNEXT(HEAP,ARG)
  487.                 IF (ARG.NE.0) GOTO 100
  488.             END IF
  489.  200    CONTINUE
  490.  
  491. C Ditto with unsafe references
  492.         USREF=LLFIRS(HEAP,USHEAD)
  493.         IF (USREF.NE.0) THEN
  494.  300        IF (HEAP(USREF+4).LT.0) THEN
  495.                 HEAP(USREF+4)=PFETOP(HEAP(USREF+4))
  496.                 IF (HEAP(USREF+4).EQ.0) THEN
  497.                     TMP=LLNEXT(HEAP,USREF)
  498.                     CALL LLDELE(HEAP,USREF)
  499.                     USREF=TMP
  500.                 ELSE
  501.                     USREF=LLNEXT(HEAP,USREF)
  502.                 END IF
  503.             ELSE
  504.                 USREF=LLNEXT(HEAP,USREF)
  505.             END IF
  506.             IF (USREF.NE.0) GOTO 300
  507.         END IF
  508.  
  509.         END
  510. C ----------------------------------------------------------------------
  511. C
  512. C       P F S R D   -   Set reference information: descendents
  513. C
  514.  
  515.         SUBROUTINE PFSRD(LIST)
  516.         INTEGER LIST
  517.  
  518.         COMMON/PFHEAP/USHEAD,HEAP
  519.         INTEGER USHEAD,HEAP(200000)
  520.  
  521.         SAVE /PFHEAP/
  522.  
  523.         INTEGER L,TMP
  524.  
  525.         INTEGER PFETOP
  526.  
  527.         INTEGER LLFIRS,LLNEXT
  528.         EXTERNAL LLFIRS,LLNEXT,LLDELE,LLDELH
  529.  
  530.         L=LLFIRS(HEAP,LIST)
  531.  100    IF (HEAP(L).LT.0) THEN
  532.             HEAP(L)=PFETOP(HEAP(L))
  533.             IF (HEAP(L).EQ.0) THEN
  534.                 TMP=LLNEXT(HEAP,L)
  535.                 CALL LLDELE(HEAP,L)
  536.                 L=TMP
  537.                 IF (L.EQ.0) THEN
  538.                     IF (LLFIRS(HEAP,LIST).EQ.0) THEN
  539.                         CALL LLDELH(HEAP,LIST)
  540.                         LIST=0
  541.                     END IF
  542.                 END IF
  543.             ELSE
  544.                 L=LLNEXT(HEAP,L)
  545.             END IF
  546.         ELSE
  547.             L=LLNEXT(HEAP,L)
  548.         END IF
  549.         IF (L.NE.0) GOTO 100
  550.  
  551.         END
  552. C ----------------------------------------------------------------------
  553. C
  554. C       P F S R A D   -   Set ref info: argument descendents
  555. C
  556.  
  557.         SUBROUTINE PFSRAD(LIST)
  558.         INTEGER LIST
  559.  
  560.         COMMON/PFHEAP/USHEAD,HEAP
  561.         INTEGER USHEAD,HEAP(200000)
  562.  
  563.         SAVE /PFHEAP/
  564.  
  565.         INTEGER L,TMP
  566.  
  567.         INTEGER PFETOP
  568.  
  569.         INTEGER LLFIRS,LLNEXT
  570.         EXTERNAL LLFIRS,LLNEXT,LLDELE,LLDELH
  571.  
  572.         L=LLFIRS(HEAP,LIST)
  573.  100    IF (HEAP(L+2).LT.0) THEN
  574.             HEAP(L+2)=PFETOP(HEAP(L+2))
  575.             IF (HEAP(L+2).EQ.0) THEN
  576.                 TMP=LLNEXT(HEAP,L)
  577.                 CALL LLDELE(HEAP,L)
  578.                 L=TMP
  579.                 IF (L.EQ.0) THEN
  580.                     IF (LLFIRS(HEAP,LIST).EQ.0) THEN
  581.                         CALL LLDELH(HEAP,LIST)
  582.                         LIST=0
  583.                     END IF
  584.                 END IF
  585.             ELSE
  586.                 L=LLNEXT(HEAP,L)
  587.             END IF
  588.         ELSE
  589.             L=LLNEXT(HEAP,L)
  590.         END IF
  591.         IF (L.NE.0) GOTO 100
  592.  
  593.         END
  594. C ----------------------------------------------------------------------
  595. C
  596. C       P F S R A P   -   Set ref into: argument procedures
  597. C
  598.  
  599.         SUBROUTINE PFSRAP(LIST)
  600.         INTEGER LIST
  601.  
  602.         COMMON/PFHEAP/USHEAD,HEAP
  603.         INTEGER USHEAD,HEAP(200000)
  604.  
  605.         SAVE /PFHEAP/
  606.  
  607.         INTEGER L,TMP
  608.  
  609.         INTEGER PFETOP
  610.  
  611.         INTEGER LLFIRS,LLNEXT
  612.         EXTERNAL LLFIRS,LLNEXT,LLDELE,LLDELH
  613.  
  614.         L=LLFIRS(HEAP,LIST)
  615.  100    IF (HEAP(L+0).LT.0) THEN
  616.             HEAP(L+0)=PFETOP(HEAP(L+0))
  617.             IF (HEAP(L+0).EQ.0) THEN
  618.                 TMP=LLNEXT(HEAP,L)
  619.                 CALL LLDELE(HEAP,L)
  620.                 L=TMP
  621.                 IF (L.EQ.0) THEN
  622.                     IF (LLFIRS(HEAP,LIST).EQ.0) THEN
  623.                         CALL LLDELH(HEAP,LIST)
  624.                         LIST=0
  625.                     END IF
  626.                 END IF
  627.             ELSE
  628.                 L=LLNEXT(HEAP,L)
  629.             END IF
  630.         ELSE
  631.             L=LLNEXT(HEAP,L)
  632.         END IF
  633.         IF (L.NE.0) GOTO 100
  634.  
  635.         END
  636. C ----------------------------------------------------------------------
  637. C
  638. C       P F S E T M   -   Set main program-unit
  639. C
  640.  
  641.         SUBROUTINE PFSETM
  642.  
  643.         COMMON/PFPU/ NPUS,MAINND,PUNODE
  644.         INTEGER NPUS,MAINND,PUNODE(500)
  645.         SAVE /PFPU/
  646.         COMMON/PFHEAP/USHEAD,HEAP
  647.         INTEGER USHEAD,HEAP(200000)
  648.  
  649.         SAVE /PFHEAP/
  650.  
  651.         INTEGER I
  652.  
  653.         MAINND=0
  654.         DO 100 I=1,NPUS
  655.             IF (HEAP(PUNODE(I)+6).EQ.-3) THEN
  656.                 IF (MAINND.NE.0) THEN
  657.                     CALL PFERR('F: Two main programs found - $N a'//
  658.      +                         'nd $N',PUNODE(I),PUNODE(MAINND),0,0)
  659.                 END IF
  660.                 MAINND=I
  661.             END IF
  662.  100    CONTINUE
  663.         IF (MAINND.EQ.0)
  664.      +      CALL PFERR('W: No main program found - analysis may be '//
  665.      +                 'incomplete',0,0,0,0)
  666.  
  667.         END
  668. C ----------------------------------------------------------------------
  669. C
  670. C       P F S E T L   -   Set invocation level of all program-units
  671. C
  672.  
  673.         SUBROUTINE PFSETL
  674.  
  675.         COMMON/PFPU/ NPUS,MAINND,PUNODE
  676.         INTEGER NPUS,MAINND,PUNODE(500)
  677.         SAVE /PFPU/
  678.         COMMON/PFHEAP/USHEAD,HEAP
  679.         INTEGER USHEAD,HEAP(200000)
  680.  
  681.         SAVE /PFHEAP/
  682.         COMMON/PFPULV/ PULVL
  683.         INTEGER PULVL(500)
  684.         SAVE /PFPULV/
  685.  
  686.         INTEGER I,D,NTOPS,ARG
  687.  
  688.         INTEGER LLFIRS,LLNEXT
  689.         EXTERNAL LLFIRS,LLNEXT,ERROR
  690.  
  691. C
  692. C Step one: set level(non-called routines)=0
  693. C
  694.         DO 100 I=1,NPUS
  695.             PULVL(I)=0
  696.  100    CONTINUE
  697.         DO 300 I=1,NPUS
  698.             IF (HEAP(PUNODE(I)+5).NE.0) THEN
  699.                 D=LLFIRS(HEAP,HEAP(PUNODE(I)+5))
  700.  200            IF (HEAP(D).GT.0) PULVL(HEAP(D))=NPUS+1
  701.                 D=LLNEXT(HEAP,D)
  702.                 IF (D.NE.0) GOTO 200
  703.             END IF
  704.             IF (HEAP(PUNODE(I)+2).NE.0) THEN
  705.                 ARG=LLFIRS(HEAP,HEAP(PUNODE(I)+2))
  706.  250            IF (HEAP(ARG+3).EQ.2 .AND.
  707.      +              HEAP(ARG+6).NE.0) THEN
  708.                     D=LLFIRS(HEAP,HEAP(ARG+6))
  709.  275                IF (HEAP(D+0).GT.0)
  710.      +                  PULVL(HEAP(D+0))=NPUS+1
  711.                     D=LLNEXT(HEAP,D)
  712.                     IF (D.NE.0) GOTO 275
  713.                 END IF
  714.                 ARG=LLNEXT(HEAP,ARG)
  715.                 IF (ARG.NE.0) GOTO 250
  716.             END IF
  717.  300    CONTINUE
  718. C
  719. C Step two: count how many apparently top-level routines
  720. C
  721.         NTOPS=0
  722.         DO 400 I=1,NPUS
  723.             IF (PULVL(I).EQ.0) NTOPS=NTOPS+1
  724.  400    CONTINUE
  725.         IF (NPUS.EQ.0) THEN
  726.             CALL ERROR('Fatal Error: No program units')
  727.         ELSE IF (MAINND.EQ.0 .AND. NTOPS.EQ.0) THEN
  728.             CALL ERROR('Fatal Error: Recursive program')
  729.         ELSE IF (NTOPS.EQ.0) THEN
  730.             CALL ERROR('Fatal Internal Error: Recursive main program')
  731.         ELSE IF (NTOPS.GT.1 .AND. MAINND.EQ.0) THEN
  732.             CALL PFERR('W: Incomplete program supplied',0,0,0,0)
  733.         END IF
  734. C
  735. C Step three: If there was a main program, assign levels from it
  736. C             otherwise assign levels from all apparently top-lvl nodes
  737. C
  738.         IF (MAINND.NE.0) THEN
  739.             CALL PFASLV(MAINND,0)
  740.         ELSE
  741.             DO 500 I=1,NPUS
  742.                 IF (PULVL(I).EQ.0) CALL PFASLV(I,0)
  743.  500        CONTINUE
  744.         END IF
  745.  
  746.         END
  747. C ----------------------------------------------------------------------
  748. C
  749. C       P F A S L V   -   Assign an invocation level to a sub-lattice
  750. C
  751.  
  752.         SUBROUTINE PFASLV(N,LVL)
  753.         INTEGER N,LVL
  754.  
  755.         COMMON/PFPU/ NPUS,MAINND,PUNODE
  756.         INTEGER NPUS,MAINND,PUNODE(500)
  757.         SAVE /PFPU/
  758.         COMMON/PFHEAP/USHEAD,HEAP
  759.         INTEGER USHEAD,HEAP(200000)
  760.  
  761.         SAVE /PFHEAP/
  762.         COMMON/PFPULV/ PULVL
  763.         INTEGER PULVL(500)
  764.         SAVE /PFPULV/
  765.  
  766.         INTEGER STACK(2,500),SP,CUR,I,J,RECERR,MAXRE
  767.         PARAMETER (MAXRE=10)
  768.  
  769.         INTEGER LLNEXT
  770.         EXTERNAL LLNEXT,ERROR,REMARK
  771.  
  772.         PULVL(N)=LVL
  773.         CUR=N
  774.         SP=0
  775.         RECERR=0
  776. C Stack first entry
  777.  100    CONTINUE
  778. C or stack another entry
  779.         IF (SP.GE.500) CALL ERROR('PFASLV: STACK OVERFLOW')
  780. C First check for possible recursion
  781.         DO 150 I=1,SP
  782.             IF (STACK(1,I).EQ.CUR) THEN
  783.                 RECERR=RECERR+1
  784.                 CALL PFERR('E: Recursive call of $N by $N',
  785.      +                      PUNODE(STACK(1,I)),PUNODE(STACK(1,SP)),0,0)
  786.                 IF (I+1.LT.SP)
  787.      +              CALL PFERR(' Via $N',PUNODE(STACK(1,I+1)),0,0,0)
  788.                 DO 125 J=I+2,SP-1
  789.                     CALL PFERR(' a'//'nd $N',PUNODE(STACK(1,J)),0,0,0)
  790.  125            CONTINUE
  791.                 IF (RECERR.LE.MAXRE) THEN
  792.                     CALL REMARK('Attempting to continue ......')
  793.                     GOTO 200
  794.                 END IF
  795.                 CALL PFERR('F: Too many recursions found',0,0,0,0)
  796.             END IF
  797.  150    CONTINUE
  798.         SP=SP+1
  799.         STACK(1,SP)=CUR
  800.         STACK(2,SP)=HEAP(PUNODE(CUR)+5)
  801.  
  802. C Proceed to first/next item on descendent list
  803.  200    CONTINUE
  804.         IF (STACK(2,SP).NE.0) STACK(2,SP)=LLNEXT(HEAP,STACK(2,SP))
  805.         IF (STACK(2,SP).EQ.0) THEN
  806. C No more descendents - *POP*
  807.             SP=SP-1
  808.             IF (SP.EQ.0) RETURN
  809.             GOTO 200
  810.         END IF
  811. C Descendent - always traverse (so we detect always detect recursion)
  812. C ... but only set level if new level is higher (i.e. less than)
  813.         CUR=HEAP(STACK(2,SP))
  814.         IF (ABS(PULVL(CUR)).GT.LVL+SP .OR. PULVL(CUR).EQ.0)
  815.      +      PULVL(CUR)=LVL+SP
  816.         GOTO 100
  817.  
  818.         END
  819. C ----------------------------------------------------------------------
  820. C
  821. C       P F I N V O   -   Invoke all subprograms to fill out desc lists
  822. C
  823.  
  824.         SUBROUTINE PFINVO
  825.  
  826.         COMMON/PFPU/ NPUS,MAINND,PUNODE
  827.         INTEGER NPUS,MAINND,PUNODE(500)
  828.         SAVE /PFPU/
  829.         COMMON/PFHEAP/USHEAD,HEAP
  830.         INTEGER USHEAD,HEAP(200000)
  831.  
  832.         SAVE /PFHEAP/
  833.         COMMON/PFPULV/ PULVL
  834.         INTEGER PULVL(500)
  835.         SAVE /PFPULV/
  836.  
  837.         INTEGER ARG,NC,I
  838.  
  839.         INTEGER LLFIRS,LLNEXT
  840.         EXTERNAL LLFIRS,LLNEXT
  841.  
  842.  100    CONTINUE
  843. C
  844. C Search for next node to do, node with lowest positive level
  845. C (root levels are zero & processed nodes are negative)
  846. C
  847.         DO 200 I=1,NPUS
  848.             IF (PULVL(I).GT.0) THEN
  849.                 NC=I
  850.                 GOTO 400
  851.             END IF
  852.  200    CONTINUE
  853. C All done - fix up levels & return
  854.         DO 300 I=1,NPUS
  855.  300        PULVL(I)=ABS(PULVL(I))
  856.         RETURN
  857.  
  858.  400    DO 500 I=NC+1,NPUS
  859.             IF (PULVL(I).GT.0 .AND. PULVL(I).LT.PULVL(NC)) NC=I
  860.  500    CONTINUE
  861. C
  862. C Found the next routine to process
  863. C
  864.         IF (HEAP(PUNODE(NC)+2).NE.0) THEN
  865. C There are arguments - check for procargs
  866.             ARG=LLFIRS(HEAP,HEAP(PUNODE(NC)+2))
  867.             I=1
  868.  600        IF (HEAP(ARG+3).EQ.2) THEN
  869.                 CALL PFERR(
  870.      +'D: PFINVO Invoking $N, procargs for argument $I',
  871.      +                     PUNODE(NC),I,0,0)
  872.                 CALL PFPROC(NC,ARG)
  873.             END IF
  874.             ARG=LLNEXT(HEAP,ARG)
  875.             I=I+1
  876.             IF (ARG.GT.0) GOTO 600
  877.         END IF
  878. C
  879. C This routine done, mark it as done and do the rest
  880. C
  881.         PULVL(NC)=-PULVL(NC)
  882.         GOTO 100
  883.  
  884.         END
  885. C ----------------------------------------------------------------------
  886. C
  887. C       P F P R O C   -   Process a procarg+argdesc list
  888. C                           --pushes the procarg info down the call tree
  889. C
  890.  
  891.         SUBROUTINE PFPROC(N,ARG)
  892.         INTEGER N,ARG
  893.  
  894. C Arguments:
  895. C ----------
  896. C N == PUNODE index of the program-unit which has a procarg.
  897. C ARG == pointer to PFPUARG record for the dummy procarg in question.
  898.  
  899.         COMMON/PFHEAP/USHEAD,HEAP
  900.         INTEGER USHEAD,HEAP(200000)
  901.  
  902.         SAVE /PFHEAP/
  903.         COMMON/PFPU/ NPUS,MAINND,PUNODE
  904.         INTEGER NPUS,MAINND,PUNODE(500)
  905.         SAVE /PFPU/
  906.         COMMON/PFEXTS/NEXTS,EXNODE
  907.         INTEGER NEXTS,EXNODE(500)
  908.         SAVE /PFEXTS/
  909.         COMMON/PFPULV/ PULVL
  910.         INTEGER PULVL(500)
  911.         SAVE /PFPULV/
  912.  
  913.         INTEGER PROCPX,ADESCX,PROC2P,ARG2,INUM
  914.         LOGICAL OK
  915.  
  916. C Variables:
  917. C ----------
  918. C PROCPX == pointer to PFPROC record representing the actual procarg
  919. C           currently being processed.
  920. C ADESCX == pointer to PUARGDES record, for passing this procarg
  921. C           further down the call tree.
  922. C PROC2P == pointer to PFPROC record representing an actual procarg
  923. C           to which the current procarg (in PROCPX) is being passed
  924. C           as an argument (blech!) - i.e. only used if this dummy
  925. C           procarg is passed out as an actual argument to ANOTHER
  926. C           dummy procarg!
  927. C ARG2 == pointer to PFPUARG record for the dummy procarg to which the
  928. C         current procarg is being passed as an argument.
  929. C INUM == dummy argument number to which this procarg is being passed
  930. C (so we discover INUM from the descendent list (PUARGDES), and from
  931. C  that we work out ARG2 by stepping along the argument list (for PUNODE
  932. C  N) and from that we step through each actual procarg PROC2P
  933. C  associated with the dummy argument ARG2 - which is number INUM).
  934.  
  935.  
  936.         LOGICAL PFCHK1
  937.  
  938.         INTEGER LLFIRS,LLNEXT,LLCRED,LLCRHE
  939.         EXTERNAL LLFIRS,LLNEXT,LLCRED,LLCRHE,LLINTO
  940.  
  941.         IF (HEAP(ARG+6).EQ.0) THEN
  942.             CALL PFERR(
  943.      +'W: No actual procedure args found for $N, analysis incomplete',
  944.      +                 PUNODE(N),0,0,0)
  945.             RETURN
  946.         END IF
  947.  
  948. C For each procedure passed in as an argument ...
  949.         PROCPX=LLFIRS(HEAP,HEAP(ARG+6))
  950. C ... Check to make sure it is compatible
  951.  100    IF (HEAP(PROCPX+0).GT.0) THEN
  952.             IF (HEAP(ARG+2).EQ.0) THEN
  953. C No checking if procedure merely passed further down the tree
  954.                 OK=.TRUE.
  955.             ELSE
  956.                 OK=PFCHK1(EXNODE(HEAP(ARG+2)),
  957.      +                    PUNODE(HEAP(PROCPX+0)))
  958.             END IF
  959.             IF (OK) THEN
  960. C ... Scan the argument descendent list
  961.                 IF (HEAP(ARG+5).NE.0) THEN
  962.                     ADESCX=LLFIRS(HEAP,HEAP(ARG+5))
  963.  200                IF (HEAP(ADESCX+0).EQ.0) THEN
  964. C ... passed to a direct procedure - just add it
  965.                         CALL PFADPR(HEAP(PROCPX+0),
  966.      +                              HEAP(ADESCX+2),
  967.      +                              HEAP(ADESCX+1),
  968.      +                              N)
  969. C ... ... and make us process that node again (new info!)
  970.                         IF (HEAP(ADESCX+2).GT.0)
  971.      +                      PULVL(HEAP(ADESCX+2))=
  972.      +                          ABS(PULVL(HEAP(ADESCX+2)))
  973.                     ELSE
  974. C ... passed to another argument (i.e. indirect procedure)
  975. C     - so add it to all of its procargs.
  976.                         ARG2=LLFIRS(HEAP,HEAP(PUNODE(N)+2))
  977.                         INUM=HEAP(ADESCX+2)
  978.  300                    IF (INUM.GT.1) THEN
  979.                             ARG2=LLNEXT(HEAP,ARG2)
  980.                             INUM=INUM-1
  981.                             GOTO 300
  982.                         END IF
  983.                         PROC2P=LLFIRS(HEAP,HEAP(ARG2+6))
  984.  400                    CALL PFADPR(HEAP(PROCPX+0),
  985.      +                              HEAP(PROC2P+0),
  986.      +                              HEAP(ADESCX+1),
  987.      +                              N)
  988. C ... ... and re-process all these procargs
  989.                         PULVL(HEAP(PROC2P+0))=
  990.      +                      ABS(PULVL(HEAP(PROC2P+0)))
  991.                         PROC2P=LLNEXT(HEAP,PROC2P)
  992.                         IF (PROC2P.NE.0) GOTO 400
  993.                     END IF
  994.                     ADESCX=LLNEXT(HEAP,ADESCX)
  995.                     IF (ADESCX.NE.0) GOTO 200
  996.                 END IF
  997. C ... Add this proc to the general descendent list as well
  998. C ... whether it is actually called at this point or not
  999. C <<<FIX THIS LATER>>>
  1000.                 IF (HEAP(PUNODE(N)+5).EQ.0)
  1001.      +              HEAP(PUNODE(N)+5)=LLCRHE(HEAP,0)
  1002.                 CALL LLINTO(HEAP,
  1003.      +                      LLCRED(HEAP,1,HEAP(PROCPX+0)),
  1004.      +                      HEAP(PUNODE(N)+5))
  1005. C ... And change the invocation level settings as appropriate
  1006.                 CALL PFASLV(N,ABS(PULVL(N)))
  1007.             ELSE
  1008.                 CALL PFERR(' Incompatible procedure argument "$N"',
  1009.      +                     PUNODE(HEAP(PROCPX+0)),0,0,0)
  1010.                 CALL PFERR(' In reference to $N by $N at statement $I',
  1011.      +                     PUNODE(N),PUNODE(HEAP(PROCPX+1)),
  1012.      +                     HEAP(PROCPX+2),0)
  1013. C Delete incompatible procedure arguments
  1014.                 PROC2P=LLNEXT(HEAP,PROCPX)
  1015.                 CALL LLDELE(HEAP,PROCPX)
  1016.                 PROCPX=PROC2P
  1017.                 IF (PROCPX.NE.0) GOTO 100
  1018.                 PROCPX=HEAP(ARG+6)
  1019.                 IF (LLFIRS(HEAP,PROCPX).EQ.0) THEN
  1020.                     CALL LLDELH(HEAP,PROCPX)
  1021.                     HEAP(ARG+6)=0
  1022.                 END IF
  1023.                 RETURN
  1024.             END IF
  1025.         END IF
  1026. C Advance to the next procedure on the list
  1027.         PROCPX=LLNEXT(HEAP,PROCPX)
  1028.         IF (PROCPX.NE.0) GOTO 100
  1029.  
  1030.         END
  1031. C ----------------------------------------------------------------------
  1032. C
  1033. C       P F A D P R   -   Add a procedure to the procarg list
  1034. C
  1035.  
  1036.         SUBROUTINE PFADPR(PX,NX,ARGNUM,AX)
  1037.         INTEGER PX,NX,ARGNUM,AX
  1038.  
  1039. C PX: node number of procedure argument being added
  1040. C NX: node number of the program unit it is being added to
  1041. C ARGNUM: argument number it is passed down to
  1042. C AX: node number of associating program-unit
  1043.  
  1044.         COMMON/PFHEAP/USHEAD,HEAP
  1045.         INTEGER USHEAD,HEAP(200000)
  1046.  
  1047.         SAVE /PFHEAP/
  1048.         COMMON/PFPU/ NPUS,MAINND,PUNODE
  1049.         INTEGER NPUS,MAINND,PUNODE(500)
  1050.         SAVE /PFPU/
  1051.  
  1052.         INTEGER ARG,N,TMP(0:3-1)
  1053.  
  1054.         INTEGER LLFIRS,LLNEXT,LLCRHE,LLCRED
  1055.         EXTERNAL LLFIRS,LLNEXT,LLCRHE,LLCRED,LLINTO
  1056.  
  1057.         CALL PFERR('D: PFADPR adding $N as argument $I to $N (from $N)',
  1058.      +             PUNODE(PX),ARGNUM,PUNODE(NX),PUNODE(AX))
  1059.  
  1060.         ARG=LLFIRS(HEAP,HEAP(PUNODE(NX)+2))
  1061.         N=1
  1062.         TMP(0)=PX
  1063.         TMP(1)=AX
  1064.         TMP(2)=0
  1065.  100    IF (N.LT.ARGNUM) THEN
  1066.             ARG=LLNEXT(HEAP,ARG)
  1067.             N=N+1
  1068.             GOTO 100
  1069.         END IF
  1070.         IF (HEAP(ARG+6).EQ.0)
  1071.      +      HEAP(ARG+6)=LLCRHE(HEAP,0)
  1072.         CALL LLINTO(HEAP,LLCRED(HEAP,3,TMP),
  1073.      +              HEAP(ARG+6))
  1074.  
  1075.         END
  1076. C ----------------------------------------------------------------------
  1077. C
  1078. C       P F S E T P   -   Add parent lists to all program-units' desc.s
  1079. C
  1080.  
  1081.         SUBROUTINE PFSETP
  1082.  
  1083.         COMMON/PFPU/ NPUS,MAINND,PUNODE
  1084.         INTEGER NPUS,MAINND,PUNODE(500)
  1085.         SAVE /PFPU/
  1086.         COMMON/PFHEAP/USHEAD,HEAP
  1087.         INTEGER USHEAD,HEAP(200000)
  1088.  
  1089.         SAVE /PFHEAP/
  1090.  
  1091.         INTEGER DESPTR,PARENT(2),X,PNUM,ARG,I,ARGNUM
  1092.  
  1093.         INTEGER LLFIRS,LLNEXT,LLCRED,LLCRHE
  1094.         EXTERNAL LLFIRS,LLNEXT,LLCRED,LLCRHE,LLINTO
  1095.  
  1096.         DO 600 PNUM=1,NPUS
  1097.             PARENT(1+0)=PNUM
  1098.             DESPTR=HEAP(PUNODE(PNUM)+5)
  1099.             IF (DESPTR.NE.0) THEN
  1100.                 DESPTR=LLFIRS(HEAP,DESPTR)
  1101.  100            IF (HEAP(DESPTR).GT.0) THEN
  1102.                     X=PUNODE(HEAP(DESPTR))+4
  1103.                     IF (HEAP(X).EQ.0) HEAP(X)=LLCRHE(HEAP,0)
  1104.                     CALL LLINTO(HEAP,LLCRED(HEAP,1,PARENT),HEAP(X))
  1105.                 END IF
  1106.                 DESPTR=LLNEXT(HEAP,DESPTR)
  1107.                 IF (DESPTR.NE.0) GOTO 100
  1108.             END IF
  1109.             IF (HEAP(PUNODE(PNUM)+1).GT.0) THEN
  1110.                 ARG=LLFIRS(HEAP,HEAP(PUNODE(PNUM)+2))
  1111.                 ARGNUM=1
  1112.  200            IF (HEAP(ARG+5).NE.0) THEN
  1113.                     PARENT(1+1)=ARGNUM
  1114.                     DESPTR=LLFIRS(HEAP,HEAP(ARG+5))
  1115.  300                IF (HEAP(DESPTR+0).EQ.0) THEN
  1116. C Argument passed down to a direct reference
  1117.                         CALL PFADPA(PARENT,
  1118.      +                              HEAP(DESPTR+2),
  1119.      +                              HEAP(DESPTR+1))
  1120.                     ELSE
  1121. C Argument passed down to an indirect reference
  1122.                         X=LLFIRS(HEAP,HEAP(PUNODE(PNUM)+2))
  1123.                         DO 400 I=2,HEAP(DESPTR+2)
  1124.                             X=LLNEXT(HEAP,X)
  1125.  400                    CONTINUE
  1126.                         X=HEAP(X+6)
  1127.                         IF (X.NE.0) THEN
  1128.                             X=LLFIRS(HEAP,X)
  1129.  500                        CALL PFADPA(PARENT,
  1130.      +                                  HEAP(X+0),
  1131.      +                                  HEAP(DESPTR+1))
  1132.                             X=LLNEXT(HEAP,X)
  1133.                             IF (X.NE.0) GOTO 500
  1134.                         END IF
  1135.                     END IF
  1136.                     DESPTR=LLNEXT(HEAP,DESPTR)
  1137.                     IF (DESPTR.NE.0) GOTO 300
  1138.                 END IF
  1139.                 ARG=LLNEXT(HEAP,ARG)
  1140.                 ARGNUM=ARGNUM+1
  1141.                 IF (ARG.NE.0) GOTO 200
  1142.             END IF
  1143.  600    CONTINUE
  1144.  
  1145.         END
  1146. C ----------------------------------------------------------------------
  1147. C
  1148. C       P F A D P A   -   Add parent for argument
  1149. C
  1150.  
  1151.         SUBROUTINE PFADPA(PARENT,N,ARGNUM)
  1152.         INTEGER PARENT(2),N,ARGNUM
  1153.  
  1154.         COMMON/PFPU/ NPUS,MAINND,PUNODE
  1155.         INTEGER NPUS,MAINND,PUNODE(500)
  1156.         SAVE /PFPU/
  1157.         COMMON/PFHEAP/USHEAD,HEAP
  1158.         INTEGER USHEAD,HEAP(200000)
  1159.  
  1160.         SAVE /PFHEAP/
  1161.  
  1162.         INTEGER ARG,I
  1163.  
  1164.         INTEGER LLFIRS,LLNEXT,LLCRHE,LLCRED
  1165.         EXTERNAL LLFIRS,LLNEXT,LLCRHE,LLCRED,LLINTO
  1166.  
  1167.         ARG=LLFIRS(HEAP,HEAP(PUNODE(N)+2))
  1168.         DO 100 I=2,ARGNUM
  1169.             ARG=LLNEXT(HEAP,ARG)
  1170.  100    CONTINUE
  1171.         IF (HEAP(ARG+7).EQ.0)
  1172.      +      HEAP(ARG+7)=LLCRHE(HEAP,0)
  1173.         CALL LLINTO(HEAP,LLCRED(HEAP,2,PARENT),
  1174.      +              HEAP(ARG+7))
  1175.  
  1176.         END
  1177.