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 / istin / ISTIN.MAC.f
Encoding:
Text File  |  1989-03-04  |  5.9 KB  |  167 lines
  1. C---------------------------------------------------------
  2. C    TOOLPACK/1    Release: 3.1
  3. C---------------------------------------------------------
  4. C ----------------------------------------------------------------------
  5. C
  6. C       I S T I N   -   INclude files
  7. C
  8. C       This program reads in a file (presumable containing a Fortran
  9. C       program) and produces a copy with all "include" references
  10. C       included.  The INCLUDE statement format is the same as for
  11. C       TIEMAC, i.e. "INCLUDE filename" where the INCLUDE begins in
  12. C       column 1.  Source-embedded directives are produced surrounding
  13. C       the included text, so that later tools (e.g. ISTDS) can detect
  14. C       the fact that the text does not come from the original and
  15. C       should not be processed.  The SEDs are:
  16. C           *$in$ begin filename
  17. C       and
  18. C           *$in$ end
  19. C
  20. C       INCLUDE files may be nested to a maximum of MXDEEP (a parameter
  21. C       set in subroutine PROFIL), the default being 10.
  22. C
  23. C       The INCLUDE files can come either from the host filestore or the
  24. C       PFS filestore (in which case names beginning with '#' will have
  25. C       the hash stripped off and the result looked for in the host fs).
  26. C
  27. C       Execution is immediately terminated if an INCLUDE file cannot be
  28. C       found, or if the maximum nesting depth is exceeded. Other error
  29. C       messages indicate internal errors either in the program, the
  30. C       TIE implementation or the STRING supplementary library.
  31. C
  32. C       Programmed by: Malcolm Cohen, Numerical Algorithms Group,
  33. C                      January 1986.
  34. C
  35.  
  36.         PROGRAM ISTIN
  37.  
  38.         INTEGER IODIN,IODOUT,INPTH(81),OUTPTH(81),HFTEXT(3),
  39.      +          PROMPT(32,3)
  40.         LOGICAL HFILES
  41.  
  42.         INTEGER GETARG,OPEN,CREATE,ZGTCMD
  43.         EXTERNAL GETARG,OPEN,CREATE,ZGTCMD,ZINIT,ZQUIT,ZMESS,ERROR
  44.  
  45. C "Input file: "
  46. C "Output file: "
  47. C "Host (H) or PFS (P) filenames: "
  48.  
  49.         DATA (PROMPT(I,1),I=1,13)/73,110,112,117,116,32,102,
  50.      +105,108,101,58,32,129/,
  51.      +       (PROMPT(I,2),I=1,14)/79,117,116,112,117,116,32,
  52.      +102,105,108,101,58,32,129/,
  53.      +       (PROMPT(I,3),I=1,32)/72,111,115,116,32,40,72,
  54.      +41,32,111,114,32,80,70,83,32,40,80,
  55.      +41,32,102,105,108,101,110,97,109,101,115,58,
  56.      +32,129/
  57.  
  58.         CALL ZINIT
  59.  
  60.         IF (GETARG(1,INPTH,81).EQ.-100) THEN
  61.             CALL ZPRMPT(PROMPT(1,1))
  62.             IF (ZGTCMD(INPTH,0).EQ.-1)
  63.      +          CALL ERROR('Couldn''t get input filename')
  64.         END IF
  65.         IF (GETARG(2,OUTPTH,81).EQ.-100) THEN
  66.             CALL ZPRMPT(PROMPT(1,2))
  67.             IF (ZGTCMD(OUTPTH,0).EQ.-1)
  68.      +          CALL ERROR('Couldn''t get output filename')
  69.         END IF
  70.         IF (GETARG(3,HFTEXT,2).EQ.-100) THEN
  71.             CALL ZPRMPT(PROMPT(1,3))
  72.             IF (ZGTCMD(HFTEXT,0).EQ.-1)
  73.      +          CALL ERROR('I/O ERROR READING FILE OPTIONS')
  74.         END IF
  75.         HFILES=HFTEXT(1).EQ.104 .OR. HFTEXT(1).EQ.72
  76.         IF (HFTEXT(1).NE.112 .AND. HFTEXT(1).NE.80 .AND..NOT.HFILES)
  77.      +      CALL REMARK('Warning: Assuming PFS filenames in input')
  78.  
  79.         IODIN=OPEN(INPTH,0)
  80.         IF (IODIN.EQ.-1) CALL ERROR('Can''t open input file')
  81.         IODOUT=CREATE(OUTPTH,1)
  82.         IF (IODOUT.EQ.-1) CALL ERROR('Can''t create output file')
  83.  
  84.         CALL PROCES(IODIN,IODOUT,HFILES)
  85.         CALL ZMESS('[ISTIN Normal Termination]',1)
  86.         CALL ZQUIT(-2)
  87.  
  88.         END
  89. C ----------------------------------------------------------------------
  90. C
  91. C       P R O C E S   -   Process file
  92. C
  93.  
  94.         SUBROUTINE PROCES(INFDA,OUTFD,HFILES)
  95.         INTEGER INFDA,OUTFD
  96.         LOGICAL HFILES
  97.  
  98.         INTEGER MXDEEP
  99.         PARAMETER (MXDEEP=10)
  100.  
  101.         INTEGER BUFF(134),INFD(MXDEEP),NEST,STATUS,PATTRN(16),
  102.      +          REPLCE(15),GETFNR(3),NEWBUF(134)
  103.  
  104.         INTEGER GETLIN,ZSETP,ZSETR,ZPREPL,OPEN,LENGTH
  105.         EXTERNAL GETLIN,PUTLIN,CLOSE,ZSETP,ZSETR,ZPREPL,ERROR,OPEN,
  106.      +           LENGTH
  107.  
  108. C PATTRN: "%include +<?+>$"
  109. C REPLCE: "*$in$ begin &1"
  110. C GETFNR: "&1"
  111.  
  112.         DATA PATTRN/37,105,110,99,108,117,100,101,32,
  113.      +43,60,63,43,62,36,129/,
  114.      +       REPLCE/42,36,105,110,36,32,98,101,103,
  115.      +105,110,32,38,49,129/,
  116.      +       GETFNR/38,49,129/
  117.  
  118.         NEST=1
  119.         INFD(1)=INFDA
  120.         IF (ZSETP(PATTRN,.TRUE.).EQ.-1) CALL ERROR('ZSETP failed')
  121.         IF (ZSETR(REPLCE).EQ.-1) CALL ERROR('ZSETR failed')
  122.  
  123.  100    STATUS=GETLIN(BUFF,INFD(NEST))
  124.         IF (STATUS.EQ.-100) THEN
  125.             CALL CLOSE(INFD(NEST))
  126.             NEST=NEST-1
  127.             IF (NEST.EQ.0) RETURN
  128.             CALL ZMESS('*$in$ end',OUTFD)
  129.         ELSE IF (STATUS.EQ.-1) THEN
  130.             CALL ERROR('I/O ERROR READING FILE')
  131.         ELSE IF (BUFF(1).EQ.105 .OR. BUFF(1).EQ.73) THEN
  132.             IF (ZPREPL(BUFF,NEWBUF,.FALSE.).EQ.-1) THEN
  133.                 CALL ZCHOUT('Invalid INCLUDE statement: ',2)
  134.                 CALL PUTLIN(BUFF,2)
  135.                 CALL PUTLIN(BUFF,OUTFD)
  136.             ELSE IF (NEST.EQ.MXDEEP) THEN
  137.                 CALL ZCHOUT('Error in: ',2)
  138.                 CALL PUTLIN(BUFF,2)
  139.                 CALL ERROR('INCLUDE files too deeply nested')
  140.             ELSE
  141.                 NEST=NEST+1
  142.                 CALL PUTLIN(NEWBUF,OUTFD)
  143.                 IF (ZSETR(GETFNR).EQ.-1) CALL ERROR('ZSETR failed 2')
  144.                 IF (ZPREPL(BUFF,NEWBUF(2),.FALSE.).EQ.-1)
  145.      +              CALL ERROR('ZPREPL failed')
  146.                 NEWBUF(LENGTH(NEWBUF))=129
  147.                 IF (HFILES) THEN
  148.                     NEWBUF(1)=35
  149.                     INFD(NEST)=OPEN(NEWBUF,0)
  150.                 ELSE
  151.                     NEWBUF(1)=32
  152.                     INFD(NEST)=OPEN(NEWBUF(2),0)
  153.                 END IF
  154.                 IF (INFD(NEST).EQ.-1) THEN
  155.                     CALL CANT(NEWBUF)
  156.                     CALL ERROR('Processing terminated')
  157.                 ELSE IF (ZSETR(REPLCE).EQ.-1) THEN
  158.                     CALL ERROR('ZSETR failed 3')
  159.                 END IF
  160.             END IF
  161.         ELSE
  162.             CALL PUTLIN(BUFF,OUTFD)
  163.         END IF
  164.         GOTO 100
  165.  
  166.         END
  167.