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 / monolith / ISTQD.MAC.f < prev    next >
Encoding:
Text File  |  1989-03-04  |  4.2 KB  |  129 lines
  1.         PROGRAM ISTQD
  2.  
  3.         INTEGER SRCPTH(134),OUTPTH(134),PLOPTH(134),
  4.      +          CIPTH(134),TMPPTH(134),OPTSTR(134),I,STATUS,
  5.      +          IODSRC,IODOUT,IODTMP,TOKNUM,IODCI,NERROR,NWARN,DESCI,
  6.      +          PLOPT(134),IODPLO
  7.  
  8.         INTEGER TMPFIL
  9.  
  10.         INTEGER YPARSE,GETARG,OPEN,CREATE,ZYINCI,ZTKPTI,ZTKGTI
  11.         EXTERNAL YPARSE,ZINIT,ZMESS,REMARK,ZQUIT,GETARG,OPEN,CREATE,
  12.      +           ZCHOUT,ZPTINT,PUTCH,REMOVE,SEEK,ZYINCI,ZTKPTI,ZTKGTI
  13.  
  14.         DATA (TMPPTH(I),I=1,11)/108,121,112,99,109,116,46,
  15.      +116,109,112,129/,
  16.      +       (CIPTH(I),I=1,11)/108,121,112,99,109,105,46,
  17.      +116,109,112,129/
  18.  
  19.         CALL ZINIT
  20.         CALL INISTR
  21.         CALL INISYM
  22.         CALL INITRE
  23.         NERROR=0
  24.         NWARN=0
  25.  
  26.         IF (GETARG(1,SRCPTH,81).EQ.-100) CALL NAMES(1,SRCPTH)
  27.         IF (GETARG(2,OUTPTH,81).EQ.-100) CALL NAMES(2,OUTPTH)
  28.         IF (GETARG(3,OPTSTR,81).EQ.-100) CALL NAMES(3,OPTSTR)
  29.         IF (GETARG(4,PLOPTH,81).EQ.-100) CALL NAMES(4,PLOPTH)
  30.  
  31.         IODSRC=OPEN(SRCPTH,0)
  32.         IF (IODSRC.EQ.-1) CALL ERROR('Source File Open Failed.')
  33.         IODOUT=CREATE(OUTPTH,1)
  34.         IF (IODOUT.EQ.-1) CALL ERROR('Output File Create Failed.')
  35.         IODPLO=OPEN(PLOPTH,0)
  36.  
  37.         IODTMP=TMPFIL(TMPPTH)
  38.         IODCI=TMPFIL(CIPTH)
  39.         IF (IODTMP.EQ.-1 .OR. IODCI.EQ.-1)
  40.      +      CALL ERROR('Scratch File Creation Failed.')
  41.  
  42.         IF (YPARSE(IODSRC,IODTMP,-1,IODCI,NERROR,NWARN).EQ.0) THEN
  43.             IF (NERROR.GT.0) THEN
  44.                 CALL ZCHOUT('[ISTQD Terminated, .',1)
  45.                 CALL ZPTINT(NERROR,1,1)
  46.                 CALL ZCHOUT(' er'//'ror.',1)
  47.                 IF (NERROR.GT.1) CALL PUTCH(115,1)
  48.                 CALL ZMESS('].',1)
  49.                 STATUS=-1
  50.             ELSE
  51.                 CALL SEEK(0,IODCI)
  52.                 CALL SEEK(0,IODTMP)
  53.                 IF (ZYINCI(IODCI).EQ.-1) CALL ERROR(
  54.      +              'Internal Error: Couldn''t reread comment index')
  55.                 IF (IODPLO.NE.-1) CALL PLOPTF(IODPLO)
  56.                 DO 100 I=5,10
  57.                     IF (GETARG(I,PLOPT,134).NE.-100)
  58.      +                  CALL POLOPT(PLOPT,.FALSE.)
  59.  100            CONTINUE
  60.                 DESCI=ZTKGTI(2,0,0)
  61.                 CALL DS(OPTSTR,IODTMP,ZTKPTI(0,IODOUT,DESCI),NERROR,
  62.      +                  NWARN)
  63.                 IF (NERROR+NWARN.EQ.0) THEN
  64.                     CALL ZMESS('[ISTQD Normal Termination].',1)
  65.                     STATUS=-2
  66.                 ELSE IF (NERROR.EQ.0) THEN
  67.                     CALL ZCHOUT('[ISTQD Terminated, .',1)
  68.                     CALL ZPTINT(NWARN,1,1)
  69.                     CALL ZCHOUT(' war'//'ning.',1)
  70.                     IF (NWARN.GT.1) CALL PUTCH(115,1)
  71.                     CALL ZMESS('].',1)
  72.                     STATUS=-1002
  73.                 ELSE
  74.                     CALL ZCHOUT('[ISTQD Terminated, .',1)
  75.                     CALL ZPTINT(NERROR,1,1)
  76.                     CALL ZCHOUT(' er'//'ror.',1)
  77.                     IF (NERROR.GT.1) CALL PUTCH(115,1)
  78.                     CALL ZMESS('].',1)
  79.                     STATUS=-1
  80.                 END IF
  81.             END IF
  82.         ELSE
  83.             CALL REMARK('[ISTQD Fatal Error -- Terminated].')
  84.             STATUS=-1001
  85.         END IF
  86.  
  87.         CALL CLOSE(IODTMP)
  88.         CALL CLOSE(IODCI)
  89.         CALL REMOVE(TMPPTH)
  90.         CALL REMOVE(CIPTH)
  91.  
  92.         CALL ZQUIT(STATUS)
  93.  
  94.         END
  95. C ----------------------------------------------------------------------
  96. C
  97. C       N A M E S   -   Input the pathname of a required file from stdin
  98. C
  99.  
  100.         SUBROUTINE NAMES(NUMBER,PATH)
  101.         INTEGER NUMBER,PATH(*)
  102.  
  103.         INTEGER JUNK,PROMPT(20,4)
  104.  
  105.         SAVE PROMPT
  106.  
  107.         INTEGER ZGTCMD
  108.         EXTERNAL ZGTCMD,ZPRMPT
  109.  
  110. C "Input source file: "
  111. C "Output file: "
  112. C "DS options: "
  113. C "PL option file: "
  114.  
  115.         DATA (PROMPT(I,1),I=1,20)/73,110,112,117,116,32,115,
  116.      +111,117,114,99,101,32,102,105,108,101,58,
  117.      +32,129/,
  118.      +       (PROMPT(I,2),I=1,14)/79,117,116,112,117,116,32,
  119.      +102,105,108,101,58,32,129/,
  120.      +       (PROMPT(I,3),I=1,13)/68,83,32,111,112,116,105,
  121.      +111,110,115,58,32,129/,
  122.      +       (PROMPT(I,4),I=1,17)/80,76,32,111,112,116,105,
  123.      +111,110,32,102,105,108,101,58,32,129/
  124.  
  125.         CALL ZPRMPT(PROMPT(1,NUMBER))
  126.         JUNK=ZGTCMD(PATH,0)
  127.  
  128.         END
  129.