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 / PFLIB0.MAC.f < prev    next >
Encoding:
Text File  |  1989-03-04  |  10.6 KB  |  318 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.  
  90.  
  91.  
  92.  
  93.  
  94.  
  95.  
  96.  
  97. C                                   parameter length
  98.  
  99.  
  100.  
  101.  
  102.  
  103.  
  104.  
  105. C ----------------------------------------------------------------------
  106. C
  107. C       P F E T O P   -   Convert EXNODE index to PUNODE index
  108. C
  109.  
  110.         INTEGER FUNCTION PFETOP(ENUM)
  111.         INTEGER ENUM
  112.  
  113. C---------------------------------------------------------
  114. C    TOOLPACK/1    Release: 2.5
  115. C---------------------------------------------------------
  116.         COMMON/PFNAME/NAMTXT
  117.         COMMON/PFNAMI/NNAMES,NAMEPU
  118.         CHARACTER*6 NAMTXT(800)
  119.         INTEGER NNAMES,NAMEPU(800)
  120.         SAVE /PFNAME/,/PFNAMI/
  121. C---------------------------------------------------------
  122. C    TOOLPACK/1    Release: 2.5
  123. C---------------------------------------------------------
  124.         COMMON/PFHEAP/USHEAD,HEAP
  125.         INTEGER USHEAD,HEAP(200000)
  126.  
  127.         SAVE /PFHEAP/
  128. C---------------------------------------------------------
  129. C    TOOLPACK/1    Release: 2.5
  130. C---------------------------------------------------------
  131.         COMMON/PFEXTS/NEXTS,EXNODE
  132.         INTEGER NEXTS,EXNODE(500)
  133.         SAVE /PFEXTS/
  134.  
  135.         PFETOP=HEAP(EXNODE(ABS(ENUM))+0)
  136.         IF (NAMTXT(PFETOP).EQ.'      ') THEN
  137.             PFETOP=-ABS(ENUM)
  138.         ELSE
  139.             PFETOP=NAMEPU(PFETOP)
  140.         END IF
  141.  
  142.         END
  143. C ----------------------------------------------------------------------
  144. C
  145. C       P F E R R   -   Produce an error message
  146. C
  147.  
  148.         SUBROUTINE PFERR(S,N1,N2,N3,N4)
  149.         CHARACTER*(*) S
  150.         INTEGER N1,N2,N3,N4
  151.  
  152. C---------------------------------------------------------
  153. C    TOOLPACK/1    Release: 2.5
  154. C---------------------------------------------------------
  155.         COMMON/PFNAME/NAMTXT
  156.         COMMON/PFNAMI/NNAMES,NAMEPU
  157.         CHARACTER*6 NAMTXT(800)
  158.         INTEGER NNAMES,NAMEPU(800)
  159.         SAVE /PFNAME/,/PFNAMI/
  160. C---------------------------------------------------------
  161. C    TOOLPACK/1    Release: 2.5
  162. C---------------------------------------------------------
  163.         COMMON/PFERRC/NPFERR,NPFWRN
  164.         INTEGER NPFERR,NPFWRN
  165.         SAVE/PFERRC/
  166. C---------------------------------------------------------
  167. C    TOOLPACK/1    Release: 2.5
  168. C---------------------------------------------------------
  169.         COMMON/PFHEAP/USHEAD,HEAP
  170.         INTEGER USHEAD,HEAP(200000)
  171.  
  172.         SAVE /PFHEAP/
  173.  
  174.         LOGICAL DEBUGM
  175.         PARAMETER (DEBUGM=.FALSE.)
  176.  
  177.         INTEGER I,L,ICNT,INSERT(4),SLEN,NODNAM,TEXT(134),
  178.      +          SYMBOL(8)
  179.         CHARACTER LTYPE
  180.         LOGICAL FIRSTU,FIRSTE
  181.  
  182.         SAVE FIRSTU,FIRSTE,LTYPE
  183.  
  184.         INTRINSIC INDEX,LEN
  185.  
  186.         INTEGER ZYGPUS
  187.         EXTERNAL ZCHOUT,ZMESS,PUTCH,ERROR,ZPTINT,ZYGTSY,ZYGTST,PUTLIN,
  188.      +           ZYGPUS
  189.  
  190.         DATA FIRSTU,FIRSTE/2*.TRUE./,LTYPE/' '/
  191.  
  192.         IF ((S(1:1).EQ.'E' .OR. S(1:1).EQ.'F') .AND. FIRSTE) THEN
  193.             CALL PUTCH(10,2)
  194.             CALL ZMESS('*********************************************',
  195.      +                 2)
  196.             CALL ZMESS('*                                           *',
  197.      +                 2)
  198.             CALL ZMESS('*  Error(s) have been detected by PFORT-77  *',
  199.      +                 2)
  200.             CALL ZMESS('*                                           *',
  201.      +                 2)
  202.             CALL ZMESS('*********************************************',
  203.      +                 2)
  204.             CALL PUTCH(10,2)
  205.             FIRSTE=.FALSE.
  206.         ELSE IF (S(1:1).EQ.'U' .AND. FIRSTU .AND. FIRSTE) THEN
  207.             CALL PUTCH(10,2)
  208.             CALL ZMESS('*******************************',2)
  209.             CALL ZMESS('*                             *',2)
  210.             CALL ZMESS('*  Unsafe Reference(s) found  *',2)
  211.             CALL ZMESS('*                             *',2)
  212.             CALL ZMESS('*******************************',2)
  213.             CALL PUTCH(10,2)
  214.             FIRSTU=.FALSE.
  215.         ELSE IF ((S(1:1).EQ.'D' .OR. S(1:1).EQ.' '.AND.LTYPE.EQ.'D')
  216.      +           .AND. .NOT.DEBUGM) THEN
  217.             LTYPE='D'
  218.             RETURN
  219.         END IF
  220.  
  221. C First: output the error type
  222.         IF (S(1:1).NE.' ') LTYPE=S(1:1)
  223.         IF (S(1:1).EQ.'E') THEN
  224.             CALL ZCHOUT('Error',2)
  225.             NPFERR=NPFERR+1
  226.         ELSE IF (S(1:1).EQ.'W') THEN
  227.             CALL ZCHOUT('Warning',2)
  228.             NPFWRN=NPFWRN+1
  229.         ELSE IF (S(1:1).EQ.'F') THEN
  230.             CALL ZCHOUT('Fatal Error',2)
  231.         ELSE IF (S(1:1).EQ.'I') THEN
  232.             CALL ZCHOUT('Internal Error',2)
  233.         ELSE IF (S(1:1).EQ.'D') THEN
  234.             CALL ZCHOUT('Debugging',2)
  235.         ELSE IF (S(1:1).EQ.'U') THEN
  236.             CALL ZCHOUT('Unsafe',2)
  237.             NPFERR=NPFERR+1
  238.         ELSE IF (S(1:1).EQ.' ') THEN
  239.             IF (LTYPE.EQ.'E') THEN
  240.                 CALL ZCHOUT('       ',2)
  241.             ELSE IF (LTYPE.EQ.'W') THEN
  242.                 CALL ZCHOUT('         ',2)
  243.             ELSE IF (LTYPE.EQ.'U') THEN
  244.                 CALL ZCHOUT('        ',2)
  245.             ELSE IF (LTYPE.EQ.'D') THEN
  246.                 CALL ZCHOUT('           ',2)
  247.             END IF
  248.         END IF
  249.  
  250. C Second: begin parsing the error string, looking for key chars
  251. C
  252. C The idea is: '$' in the string signals an insertion, the char
  253. C following specifying what type, i.e.
  254. C   '$I' - "integer" - CALL ZPTINT(N,1,stderr)
  255. C   '$T' - "text"    - CALL ZCHOUT(NAMTXT(N),stderr)
  256. C   '$N' - "node"    - CALL ZCHOUT(NAMTXT(HEAP(N)),stderr)
  257. C   '$S' - "symbol"  - CALL ZYGTSY(N,SYMBOL)
  258. C                      CALL ZYGTST(SYMBOL(symbol_name),TEXT)
  259. C                      CALL PUTLIN(TEXT,stderr)
  260. C   '$P' - "p.u."    - CALL ZYGTSY(ZYGPUS(N),SYMBOL)
  261. C                      CALL ZYGTST(SYMBOL(symbol_name),TEXT)
  262. C                      CALL PUTLIN(TEXT,stderr)
  263.  
  264.         L=2
  265.         I=2
  266.         ICNT=0
  267.         INSERT(1)=N1
  268.         INSERT(2)=N2
  269.         INSERT(3)=N3
  270.         INSERT(4)=N4
  271.  100    IF (S(I:I).NE.'$') THEN
  272.             I=I+1
  273.             IF (I.LT.LEN(S)) GOTO 100
  274.             IF (I.GE.L) CALL ZCHOUT(S(L:I),2)
  275.         ELSE
  276.             IF (I.GT.L) CALL ZCHOUT(S(L:I-1),2)
  277.             I=I+1
  278.             ICNT=ICNT+1
  279.             IF (S(I:I).EQ.'I') THEN
  280.                 CALL ZPTINT(INSERT(ICNT),1,2)
  281.             ELSE IF (S(I:I).EQ.'T') THEN
  282.                 SLEN=INDEX(NAMTXT(INSERT(ICNT)),' ')-1
  283.                 IF (SLEN.LT.0) SLEN=6
  284.                 CALL ZCHOUT(NAMTXT(INSERT(ICNT))(:SLEN),2)
  285.             ELSE IF (S(I:I).EQ.'N') THEN
  286.                 NODNAM=HEAP(INSERT(ICNT))
  287.                 SLEN=INDEX(NAMTXT(NODNAM),' ')-1
  288.                 IF (SLEN.LT.0) SLEN=6
  289.                 IF (SLEN.EQ.0) THEN
  290.                     CALL ZCHOUT('procedure argument',2)
  291.                 ELSE
  292.                     CALL ZCHOUT(NAMTXT(NODNAM)(:SLEN),2)
  293.                 END IF
  294.             ELSE IF (S(I:I).EQ.'S') THEN
  295.                 CALL ZYGTSY(INSERT(ICNT),SYMBOL)
  296.                 CALL ZYGTST(SYMBOL(2),TEXT)
  297.                 CALL PUTLIN(TEXT,2)
  298.             ELSE
  299.                 CALL ZYGTSY(ZYGPUS(INSERT(ICNT)),SYMBOL)
  300.                 CALL ZYGTST(SYMBOL(2),TEXT)
  301.                 CALL PUTLIN(TEXT,2)
  302.             END IF
  303.             I=I+1
  304.             L=I
  305.             IF (I.LT.LEN(S)) GOTO 100
  306.             IF (I.EQ.LEN(S)) CALL ZCHOUT(S(I:I),2)
  307.         END IF
  308.         CALL PUTCH(10,2)
  309.  
  310. C Terminate program if required
  311.         IF (S(1:1).EQ.'F') THEN
  312.             CALL ERROR('PFORT-77 terminated by Fatal Error')
  313.         ELSE IF (S(1:1).EQ.'I') THEN
  314.             CALL ERROR('PFORT-77 terminated by Internal Error')
  315.         END IF
  316.  
  317.         END
  318.