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 / istun / ISTUN.MAC.f
Encoding:
Text File  |  1989-03-04  |  3.2 KB  |  105 lines
  1. C---------------------------------------------------------
  2. C    TOOLPACK/1    Release: 3.1
  3. C---------------------------------------------------------
  4. C ----------------------------------------------------------------------
  5. C
  6. C       I S T U N   -   UN-include files
  7. C
  8. C       This program reads in a file produced by ISTIN and replaces the
  9. C       included text from ISTIN with INCLUDE statements.
  10. C
  11. C       Programmed by: Malcolm Cohen, Numerical Algorithms Group,
  12. C                      September 1986.
  13. C
  14.  
  15.         PROGRAM ISTUN
  16.  
  17.         INTEGER IODIN,IODOUT,INPTH(81),OUTPTH(81),PROMPT(14,2)
  18.  
  19.         INTEGER GETARG,OPEN,CREATE,ZGTCMD
  20.         EXTERNAL GETARG,OPEN,CREATE,ZGTCMD,ZINIT,ZQUIT,ERROR
  21.  
  22. C "Input file: "
  23. C "Output file: "
  24.  
  25.         DATA (PROMPT(I,1),I=1,13)/73,110,112,117,116,32,102,
  26.      +105,108,101,58,32,129/,
  27.      +       (PROMPT(I,2),I=1,14)/79,117,116,112,117,116,32,
  28.      +102,105,108,101,58,32,129/
  29.  
  30.         CALL ZINIT
  31.  
  32.         IF (GETARG(1,INPTH,81).EQ.-100) THEN
  33.             CALL ZPRMPT(PROMPT(1,1))
  34.             IF (ZGTCMD(INPTH,0).EQ.-1)
  35.      +          CALL ERROR('Couldn''t get input filename')
  36.         END IF
  37.         IF (GETARG(2,OUTPTH,81).EQ.-100) THEN
  38.             CALL ZPRMPT(PROMPT(1,2))
  39.             IF (ZGTCMD(OUTPTH,0).EQ.-1)
  40.      +          CALL ERROR('Couldn''t get output filename')
  41.         END IF
  42.  
  43.         IODIN=OPEN(INPTH,0)
  44.         IF (IODIN.EQ.-1) CALL ERROR('Can''t open input file')
  45.         IODOUT=CREATE(OUTPTH,1)
  46.         IF (IODOUT.EQ.-1) CALL ERROR('Can''t create output file')
  47.  
  48.         CALL PROCES(IODIN,IODOUT)
  49.         CALL REMARK('[ISTUN Normal Termination]')
  50.         CALL ZQUIT(-2)
  51.  
  52.         END
  53. C ----------------------------------------------------------------------
  54. C
  55. C       P R O C E S   -   Process file
  56. C
  57.  
  58.         SUBROUTINE PROCES(INFD,OUTFD)
  59.         INTEGER INFD,OUTFD
  60.  
  61.         INTEGER BUFF(134),NEST,STATUS,PATTRN(21),REPLCE(11),
  62.      +          NEWBUF(134),ENDFLG(11)
  63.  
  64.         INTEGER GETLIN,ZSETP,ZSETR,ZPREPL,EQUAL
  65.         EXTERNAL GETLIN,PUTLIN,CLOSE,ZSETP,ZSETR,ZPREPL,EQUAL,ERROR
  66.  
  67. C PATTRN: "%&*&$in&$ begin <?+>"
  68. C REPLCE: "include &1"
  69.  
  70.         DATA REPLCE/73,78,67,76,85,68,69,32,38,49,
  71.      +129/,
  72.      +       PATTRN/37,64,42,64,36,105,110,64,
  73.      +36,32,98,101,103,105,110,32,60,63,43,
  74.      +62,129/,
  75.      +       ENDFLG/42,36,105,110,36,32,101,110,100,
  76.      +10,129/
  77.  
  78.         NEST=0
  79.         IF (ZSETP(PATTRN,.TRUE.).EQ.-1) CALL ERROR('ZSETP failed')
  80.         IF (ZSETR(REPLCE).EQ.-1) CALL ERROR('ZSETR failed')
  81.  
  82.  100    STATUS=GETLIN(BUFF,INFD)
  83.         IF (STATUS.EQ.-100) THEN
  84.             CALL CLOSE(INFD)
  85.             IF (NEST.NE.0) CALL ERROR('Incomplete input file')
  86.             RETURN
  87.         ELSE IF (STATUS.EQ.-1) THEN
  88.             CALL ERROR('I/O ERROR READING FILE')
  89.         ELSE IF (BUFF(1).EQ.42) THEN
  90.             IF (ZPREPL(BUFF,NEWBUF,.FALSE.).NE.-1) THEN
  91.                 IF (NEST.EQ.0) CALL PUTLIN(NEWBUF,OUTFD)
  92.                 NEST=NEST+1
  93.             ELSE IF (EQUAL(BUFF,ENDFLG).EQ.-2) THEN
  94.                 NEST=NEST-1
  95.                 IF (NEST.LT.0) CALL ERROR('TOO MANY END MARKERS')
  96.             ELSE IF (NEST.EQ.0) THEN
  97.                 CALL PUTLIN(BUFF,OUTFD)
  98.             END IF
  99.         ELSE IF (NEST.EQ.0) THEN
  100.             CALL PUTLIN(BUFF,OUTFD)
  101.         END IF
  102.         GOTO 100
  103.  
  104.         END
  105.