Linux Cubed Series 3: Developer Tools/Linux Cubed Series 3 - Developer Tools.iso/devel/lang/fortran/toolpack.000/toolpack/toolpack1.2/tools/istds/ISTDS.MAC.f

Text File | 1989-03-04 | 5.4 KB | 163 lines

C---------------------------------------------------------
C    TOOLPACK/1    Release: 3.1
C---------------------------------------------------------
        PROGRAM ISTDS
C ----------------------------------------------------------------------
C
C       I S T D S   -   Toolpack Declaration Standardiser
C
C       Malcolm Cohen, NAG Central Office, 1985.
C
C       This program does one of two things:
C           (1) Rebuild the declarative part of a  program completely.
C           (2) Declare the types of all implicitly typed variables.
C
C       Program Structure (Module Tree):
C       --------------------------------
C
C       ISTDS
C               NAMES
C               DSOPT
C               DS
C                       SRTIDX
C                               LESS
C                       PROPU1
C                               REMUNU
C                               SEC
C                               EXISTS
C                               DMPALL
C                                       EXISTS
C                                       PUTHDR
C                                       OUTDEC*
C                                       PUTEOS
C                               PUTHDR
C                               PTDEC
C                               PUTEOS
C                       PROPU2
C                               SEC
C                               EXISTS
C                                       EXIUND
C                               PUTHDR
C                               OUTDEC*
C                               PUTEOS
C       ... Module OUTDEC:
C
C       OUTDEC*
C               OUTLST
C               OUTPAR
C               OUTSAV
C               OUTCMN
C               OUTSD
C               OUTUND
C               OUTSPC
C

        INTEGER TREPTH(81),SYMPTH(81),CMIPTH(81),
     +          CMTPTH(81),TKOPTH(81),CMOPTH(81),
     +          OPTSTR(81),NERROR,NWARN,IODTRE,IODSYM,IODCMI,
     +          IODCMT,IODTKO,IODCMO

        INTEGER GETARG,OPEN,CREATE,ZTKPTI,ZYINCI
        EXTERNAL ZINIT,GETARG,OPEN,CREATE,ZYINPT,ZYINSY,ZMESS,ZQUIT,
     +           ZCHOUT,ZPTINT,PUTC,ZYINCI,CLOSE,ZTKPTI,ERROR

        CALL ZINIT

        IF (GETARG(1,TREPTH,81).EQ.-100) CALL DSARGS(1,TREPTH)
        IF (GETARG(2,SYMPTH,81).EQ.-100) CALL DSARGS(2,SYMPTH)
        IF (GETARG(3,CMIPTH,81).EQ.-100) CALL DSARGS(3,CMIPTH)
        IF (GETARG(4,CMTPTH,81).EQ.-100) CALL DSARGS(4,CMTPTH)
        IF (GETARG(5,TKOPTH,81).EQ.-100) CALL DSARGS(5,TKOPTH)
        IF (GETARG(6,CMOPTH,81).EQ.-100) CALL DSARGS(6,CMOPTH)
        IF (GETARG(7,OPTSTR,81).EQ.-100) CALL DSARGS(7,OPTSTR)

        IODTRE=OPEN(TREPTH,0)
        IF (IODTRE.EQ.-1) CALL ERROR('Can''t open tree path')
        IODSYM=OPEN(SYMPTH,0)
        IF (IODSYM.EQ.-1) CALL ERROR('Can''t open symbol path')
        IODCMI=OPEN(CMIPTH,0)
        IF (IODCMI.EQ.-1) CALL ERROR('Can''t open comment index')
        IODCMT=OPEN(CMTPTH,0)
        IF (IODCMT.EQ.-1) CALL ERROR('Can''t open old comment file')
        IODTKO=CREATE(TKOPTH,1)
        IF (IODTKO.EQ.-1) CALL ERROR('Can''t create token stream')
        IODCMO=CREATE(CMOPTH,1)
        IF (IODCMO.EQ.-1) CALL ERROR('Can''t create new comment file')

        CALL ZYINPT(IODTRE)
        CALL CLOSE(IODTRE)
        CALL ZYINSY(IODSYM)
        CALL CLOSE(IODSYM)
        IF (ZYINCI(IODCMI).NE.-2) CALL ERROR('ZYINCI failed')

        CALL DS(OPTSTR,IODCMT,ZTKPTI(1,IODTKO,IODCMO),NERROR,NWARN)

        IF (NERROR+NWARN.EQ.0) THEN
            CALL ZMESS('[ISTDS Normal Termination]',1)
            CALL ZQUIT(-2)
        ELSE IF (NERROR.EQ.0) THEN
            CALL ZCHOUT('[ISTDS Terminated with ',1)
            CALL ZPTINT(NWARN,1,1)
            CALL ZCHOUT(' war'//'ning',1)
            IF (NWARN.GT.1) CALL PUTC(115)
            CALL ZMESS(']',1)
            CALL ZQUIT(-1002)
        ELSE
            CALL ZCHOUT('[ISTDS Error Terminated, ',1)
            CALL ZPTINT(NERROR,1,1)
            CALL ZCHOUT(' er'//'ror',1)
            IF (NERROR.GT.1) CALL PUTC(115)
            CALL ZMESS(' found]',1)
            CALL ZQUIT(-1)
        END IF

        END
C ----------------------------------------------------------------------
C
C       D S A R G S   -   Input ISTDS command arguments from user
C

        SUBROUTINE DSARGS(NUMBER,PATH)
        INTEGER NUMBER,PATH(*)

        INTEGER PROMPT(24,7),I

        SAVE PROMPT

        INTEGER ZGTCMD
        EXTERNAL ZPRMPT,ZGTCMD

C "Input parse tree: "
C "Input symbol table: "
C "Input comment index: "
C "Input comment stream: "
C "Output token stream: "
C "Output comment stream: "
C "Processing Options: "

        DATA (PROMPT(I,1),I=1,19)/73,110,112,117,116,32,112,
     +97,114,115,101,32,116,114,101,101,58,32,129/,
     +       (PROMPT(I,2),I=1,21)/73,110,112,117,116,32,115,
     +121,109,98,111,108,32,116,97,98,108,101,58,
     +32,129/,
     +       (PROMPT(I,3),I=1,22)/73,110,112,117,116,32,
     +99,111,109,109,101,110,116,32,105,110,100,101,120,
     +58,32,129/,
     +       (PROMPT(I,4),I=1,23)/73,110,112,117,116,32,
     +99,111,109,109,101,110,116,32,115,116,114,101,97,
     +109,58,32,129/,
     +       (PROMPT(I,5),I=1,22)/79,117,116,112,117,116,32,
     +116,111,107,101,110,32,115,116,114,101,97,109,
     +58,32,129/,
     +       (PROMPT(I,6),I=1,24)/79,117,116,112,117,116,32,
     +99,111,109,109,101,110,116,32,115,116,114,101,97,
     +109,58,32,129/,
     +       (PROMPT(I,7),I=1,21)/80,114,111,99,101,115,115,
     +105,110,103,32,79,112,116,105,111,110,115,58,
     +32,129/

        CALL ZPRMPT(PROMPT(1,NUMBER))
        I=ZGTCMD(PATH,0)

        END