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 / istpp / ISTPP.f
Encoding:
Text File  |  1989-03-04  |  13.1 KB  |  384 lines
  1. * $pp$PARLEN=48
  2. C---------------------------------------------------------
  3. C    TOOLPACK/1    Release: 3.1
  4. C---------------------------------------------------------
  5. C
  6. C       I S T P P   -   P R O G R A M   P A R A M E T E R S
  7. C       ---------       -------------   -------------------
  8. C
  9. C       This program processes a source file (at the token stream level)
  10. C       looking for $pp$ source-embedded directives.
  11. C
  12. C       A $pp$ SED defines a program-wide parameter.  ISTPP then looks
  13. C       through the rest of the program for PARAMETER statements which
  14. C       mention this name, and ensures that they all have the correct
  15. C       value.
  16. C
  17. C       There is also a facility for including a "library" file which
  18. C       contains SED's only (not a token stream).
  19. C
  20.  
  21.       PROGRAM ISTPP
  22.  
  23.       INTEGER MINUS,EOS,MAXPTH,READ,ERR,EOF,NO,STDERR,OK,WRITE,STDOUT
  24.       PARAMETER (MINUS=45,EOS=129,MAXPTH=81,READ=0,ERR=-1,EOF=-100,
  25.      +          NO=-3,STDERR=2,OK=-2,WRITE=1,STDOUT=1)
  26.  
  27.       INTEGER TKNPTH(MAXPTH),CMTPTH(MAXPTH),TKOPTH(MAXPTH),
  28.      +        CMOPTH(MAXPTH),LIBPTH(MAXPTH),IODTKN,IODCMT,IODTKO,IODCMO,
  29.      +        IODLIB,TKIDES,TKODES,NOLIB(2)
  30.       LOGICAL ASKUSR
  31.  
  32.       INTEGER GETARG,OPEN,CREATE,ZTKGTI,ZTKPTI,EQUAL
  33.       EXTERNAL GETARG,OPEN,CREATE,ZTKGTI,ZTKPTI,EQUAL,ZINIT,ZQUIT,ERROR,
  34.      +         ZMESS
  35.  
  36.       DATA NOLIB/MINUS,EOS/
  37.  
  38.       CALL ZINIT
  39.  
  40.       IF (GETARG(1,TKNPTH,MAXPTH).EQ.EOF) CALL PPARGS(1,TKNPTH)
  41.       IODTKN = OPEN(TKNPTH,READ)
  42.       IF (IODTKN.EQ.ERR) CALL ERROR('Can''t open token stream')
  43.       IF (GETARG(2,CMTPTH,MAXPTH).EQ.EOF) CALL PPARGS(2,CMTPTH)
  44.       IODCMT = OPEN(CMTPTH,READ)
  45.       IF (IODCMT.EQ.ERR) CALL ERROR('Can''t open comment file')
  46.       IF (GETARG(3,TKOPTH,MAXPTH).EQ.EOF) CALL PPARGS(3,TKOPTH)
  47.       IODTKO = CREATE(TKOPTH,WRITE)
  48.       IF (IODTKO.EQ.ERR) CALL ERROR('Can''t create token output')
  49.       IF (GETARG(4,CMOPTH,MAXPTH).EQ.EOF) CALL PPARGS(4,CMOPTH)
  50.       IODCMO = CREATE(CMOPTH,WRITE)
  51.       IF (IODCMO.EQ.ERR) CALL ERROR('Can''t create comment output')
  52.       ASKUSR = GETARG(5,LIBPTH,MAXPTH) .EQ. EOF
  53.       IF (ASKUSR) THEN
  54.           CALL ZMESS('Input library filenames, end with bla'//'nk line',
  55.      +               STDOUT)
  56.           CALL PPARGS(5,LIBPTH)
  57.       END IF
  58.  
  59.       IF (EQUAL(LIBPTH,NOLIB).EQ.NO .AND. LIBPTH(1).NE.EOS) THEN
  60.           IODLIB = OPEN(LIBPTH,READ)
  61.           IF (IODLIB.EQ.ERR) CALL ERROR('Can''t open library input')
  62.       ELSE
  63.           IODLIB = -1
  64.       END IF
  65.  
  66.       TKIDES = ZTKGTI(1,IODTKN,IODCMT)
  67.       TKODES = ZTKPTI(1,IODTKO,IODCMO)
  68.  
  69.       CALL PPMAIN(TKIDES,TKODES,IODLIB,ASKUSR)
  70.  
  71.       CALL ZMESS('[ISTPP Normal Termination]',STDERR)
  72.       CALL ZQUIT(OK)
  73.  
  74.       END
  75. C ----------------------------------------------------------------------
  76. C
  77. C       P P A R G S   -   Input ISTPP command arguments from user
  78. C
  79.  
  80.       SUBROUTINE PPARGS(N,PATH)
  81.  
  82.       INTEGER MAXPTH
  83.       PARAMETER (MAXPTH=81)
  84.  
  85.       INTEGER N,PATH(MAXPTH)
  86.  
  87.       INTEGER BIGI,LETP,LETU,LETT,BLANK,LETO,LETK,LETE,LETN,LETS,LETR,
  88.      +        LETA,LETM,COLON,EOS,LETC,LETF,LETI,LETL,BIGO,LETB,STDIN,
  89.      +        LETY
  90.       PARAMETER (BIGI=73,LETN=110,LETP=112,LETU=117,LETT=116,BLANK=32,
  91.      +          LETO=111,LETK=107,LETE=101,LETS=115,LETR=114,LETA=97,
  92.      +          LETM=109,COLON=58,EOS=129,LETC=99,LETF=102,LETI=105,
  93.      +          LETL=108,BIGO=79,LETB=98,STDIN=0,LETY=121)
  94.  
  95.       INTEGER I,PROMPT(22,5)
  96.  
  97.       SAVE PROMPT
  98.  
  99.       INTEGER ZGTCMD
  100.       EXTERNAL ZGTCMD,ZPRMPT
  101.  
  102. C "Input token stream: "
  103. C "Input comment file: "
  104. C "Output token stream: "
  105. C "Output comment file: "
  106. C "Input library file: "
  107.  
  108.       DATA (PROMPT(I,1),I=1,21)/BIGI,LETN,LETP,LETU,LETT,BLANK,LETT,
  109.      +     LETO,LETK,LETE,LETN,BLANK,LETS,LETT,LETR,LETE,LETA,LETM,
  110.      +     COLON,BLANK,EOS/, (PROMPT(I,2),I=1,21)/BIGI,LETN,LETP,LETU,
  111.      +     LETT,BLANK,LETC,LETO,LETM,LETM,LETE,LETN,LETT,BLANK,LETF,
  112.      +     LETI,LETL,LETE,COLON,BLANK,EOS/, (PROMPT(I,3),I=1,22)/BIGO,
  113.      +     LETU,LETT,LETP,LETU,LETT,BLANK,LETT,LETO,LETK,LETE,LETN,
  114.      +     BLANK,LETS,LETT,LETR,LETE,LETA,LETM,COLON,BLANK,EOS/,
  115.      +     (PROMPT(I,4),I=1,22)/BIGO,LETU,LETT,LETP,LETU,LETT,BLANK,
  116.      +     LETC,LETO,LETM,LETM,LETE,LETN,LETT,BLANK,LETF,LETI,LETL,LETE,
  117.      +     COLON,BLANK,EOS/, (PROMPT(I,5),I=1,21)/BIGI,LETN,LETP,LETU,
  118.      +     LETT,BLANK,LETL,LETI,LETB,LETR,LETA,LETR,LETY,BLANK,LETF,
  119.      +     LETI,LETL,LETE,COLON,BLANK,EOS/
  120.  
  121.       CALL ZPRMPT(PROMPT(1,N))
  122.       I = ZGTCMD(PATH,STDIN)
  123.  
  124.       END
  125. C ----------------------------------------------------------------------
  126. C
  127. C       P P M A I N   -   ISTPP Main Processing
  128. C
  129.  
  130.       SUBROUTINE PPMAIN(TKIDES,TKODES,IODLIB,ASKUSR)
  131.       INTEGER TKIDES,TKODES,IODLIB
  132.       LOGICAL ASKUSR
  133.  
  134.       INTEGER MAXTLN,MAXBUF,PERCNT,LETI,LETN,LETC,LETL,LETU,LETD,LETE,
  135.      +        BLANK,PLUS,LESS,QMARK,GREATR,DOLLAR,EOS,AND,DIG1,ERR,STAR,
  136.      +        YES,LETP,OK,STDERR,BIGI,READ,MAXPRM,MAXPTH,EOF,TNAME,
  137.      +        TCOMMA,TRPARN,TEQUAL,TCMMNT,TPARAM,TZEOF,TZEOS
  138.       PARAMETER (MAXTLN=1322,MAXBUF=134,PERCNT=37,LETI=105,LETN=110,
  139.      +          LETC=99,LETL=108,LETU=117,LETD=100,LETE=101,BLANK=32,
  140.      +          PLUS=43,QMARK=63,GREATR=62,DOLLAR=36,EOS=129,AND=38,
  141.      +          DIG1=49,ERR=-1,STAR=42,YES=-2,LETP=112,OK=-2,STDERR=2,
  142.      +          BIGI=73,READ=0,MAXPRM=10,MAXPTH=81,EOF=-100,TNAME=76,
  143.      +          TCOMMA=48,TRPARN=52,TEQUAL=49,TPARAM=28,TZEOF=1,
  144.      +          TZEOS=79,LESS=60,TCMMNT=80)
  145.  
  146.       INTEGER PARLEN
  147.       PARAMETER (PARLEN=48)
  148.  
  149.       INTEGER MAXPAR,MAXINC
  150.       PARAMETER (MAXPAR=500,MAXINC=3)
  151.  
  152.       INTEGER NPARMS,TOKTYP,TOKLEN,TOKTXT(MAXTLN),STATUS,BIND,ID(3),
  153.      +        BODY(MAXBUF),LHS(MAXBUF),RHS(MAXBUF),INCDEP,
  154.      +        RESULT(MAXBUF),IODINC(MAXINC),PATTRN(16),REPLCE(3),PARNUM
  155.       LOGICAL INPARA
  156.       CHARACTER*(PARLEN) PTABLE(2,MAXPAR)
  157.  
  158.       LOGICAL LOOKUP
  159.  
  160.       INTEGER ZSEDID,ZSPLIT,LENGTH,ZGTCMD,ZPREPL,ZSETR,ZSETP,OPEN,GETARG
  161.       EXTERNAL ZSEDID,ZSPLIT,LENGTH,ZGTCMD,ZPREPL,ZSETR,ZSETP,OPEN,
  162.      +         GETARG,ZGETTK,ZPUTTK,ERROR,ZMESS,PUTLIN,ZCHOUT,CANT,
  163.      +         ZPTMES
  164.  
  165. C PATTRN: "%include +<?+>$"
  166. C REPLCE: "&1"
  167.  
  168.       DATA PATTRN/PERCNT,LETI,LETN,LETC,LETL,LETU,LETD,LETE,BLANK,PLUS,
  169.      +     LESS,QMARK,PLUS,GREATR,DOLLAR,EOS/,REPLCE/AND,DIG1,EOS/
  170.  
  171. C
  172. C Initialise
  173. C
  174.       NPARMS = 0
  175.       INPARA = .FALSE.
  176.       ID(1) = EOS
  177.       ID(2) = 0
  178.       INCDEP = 1
  179.       IODINC(1) = IODLIB
  180.       IF (ZSETP(PATTRN,.TRUE.).EQ.ERR) CALL ERROR('ZSETP failed')
  181.       IF (ZSETR(REPLCE).EQ.ERR) CALL ERROR('ZSETR failed')
  182.       PARNUM = 6
  183. C
  184. C Process library file if necessary
  185. C
  186.       IF (IODLIB.GE.0) THEN
  187.   100     TOKLEN = ZGTCMD(TOKTXT,IODINC(INCDEP))
  188.           IF (TOKLEN.EQ.ERR) CALL ERROR('PPMAIN: I/O ERROR')
  189.           IF (TOKLEN.GE.0 .AND. TOKTXT(1).EQ.STAR) THEN
  190.               STATUS = ZSEDID(TOKTXT,BIND,ID,BODY)
  191.               IF (STATUS.EQ.YES .AND. ID(1).EQ.LETP .AND. ID(2).EQ.
  192.      +            LETP) THEN
  193.                   IF (ZSPLIT(BODY,LHS,RHS).NE.OK) THEN
  194.                       CALL ZCHOUT('Erroneous ISTPP directive:',stderr)
  195.                       CALL PUTLIN(BODY,stderr)
  196.                       CALL ZMESS(' - ignored',stderr)
  197.                   ELSE IF (NPARMS.EQ.MAXPAR) THEN
  198.                       CALL ERROR('Too many parameters')
  199.                   ELSE
  200.                       CALL ENTER(LHS,PTABLE,NPARMS,MAXPAR,RHS)
  201.                   END IF
  202.               END IF
  203.           ELSE IF (TOKLEN.GE.0 .AND. TOKTXT(1).EQ.LETI .OR.
  204.      +             TOKTXT(1).EQ.BIGI) THEN
  205.               IF (ZPREPL(TOKTXT,BODY,.FALSE.).EQ.ERR) THEN
  206.                   CALL ZCHOUT('Invalid INCLUDE statement: ',STDERR)
  207.                   CALL ZPTMES(TOKTXT,STDERR)
  208.               ELSE IF (INCDEP.EQ.MAXINC) THEN
  209.                   CALL ZCHOUT('Error in: ',STDERR)
  210.                   CALL ZPTMES(TOKTXT,STDERR)
  211.                   CALL ERROR('INCLUDE files too deeply nested')
  212.               ELSE
  213.                   INCDEP = INCDEP + 1
  214.                   IODINC(INCDEP) = OPEN(BODY,READ)
  215.                   IF (IODINC(INCDEP).EQ.ERR) THEN
  216.                       CALL CANT(BODY)
  217.                       CALL ERROR('ISTPP aborted')
  218.                   END IF
  219.               END IF
  220.           END IF
  221.  
  222.           IF (TOKLEN.NE.eof) GO TO 100
  223. C End of file - close it and decrement include nesting level
  224.           CALL CLOSE(IODINC(INCDEP))
  225.           INCDEP = INCDEP - 1
  226. C Keep going until end of top level library file
  227.           IF (INCDEP.GT.0) GO TO 100
  228.           PARNUM = PARNUM + 1
  229. C End of library file - see if we should do some more
  230.           IF (PARNUM.LE.MAXPRM) THEN
  231.               IF (ASKUSR) THEN
  232.                   CALL PPARGS(5,BODY)
  233.               ELSE IF (GETARG(PARNUM,BODY,MAXPTH).EQ.EOF) THEN
  234.                   BODY(1) = EOS
  235.               END IF
  236.               IF (BODY(1).NE.EOS) THEN
  237.                   INCDEP = 1
  238.                   IODINC(INCDEP) = OPEN(BODY,READ)
  239.                   IF (IODINC(INCDEP).NE.ERR) GO TO 100
  240.                   CALL CANT(BODY)
  241.                   CALL ERROR('ISTPP aborted')
  242.               END IF
  243.           END IF
  244.       END IF
  245. C
  246. C Process input
  247. C
  248.   200 CALL ZGETTK(TOKTYP,TOKLEN,TOKTXT,TKIDES,STATUS)
  249.       IF (STATUS.EQ.ERR .OR. STATUS.EQ.
  250.      +    EOF) CALL ERROR('ZGETTK call failed')
  251.       IF (TOKTYP.EQ.TCMMNT .AND. TOKTXT(1).EQ.STAR) THEN
  252.           STATUS = ZSEDID(TOKTXT,BIND,ID,BODY)
  253.           IF (STATUS.EQ.YES .AND. ID(1).EQ.LETP .AND. ID(2).EQ.
  254.      +        LETP) THEN
  255.               IF (ZSPLIT(BODY,LHS,RHS).NE.OK) THEN
  256.                   CALL ZCHOUT('Erroneous ISTPP directive:',STDERR)
  257.                   CALL PUTLIN(BODY,STDERR)
  258.                   CALL ZMESS(' - ignored',STDERR)
  259.               ELSE IF (NPARMS.EQ.MAXPAR) THEN
  260.                   CALL ERROR('Too many parameters')
  261.               ELSE
  262.                   CALL ENTER(LHS,PTABLE,NPARMS,MAXPAR,RHS)
  263.               END IF
  264.           END IF
  265.       ELSE IF (TOKTYP.EQ.TPARAM) THEN
  266.           INPARA = .TRUE.
  267.       ELSE IF (INPARA) THEN
  268.           IF (TOKTYP.EQ.TZEOS) THEN
  269.               INPARA = .FALSE.
  270.           ELSE IF (TOKTYP.EQ.TNAME .AND. NPARMS.GT.0) THEN
  271.               IF (LOOKUP(TOKTXT,PTABLE,NPARMS,RESULT)) THEN
  272.                   CALL ZPUTTK(TOKTYP,TOKLEN,TOKTXT,TKODES)
  273.                   CALL ZGETTK(TOKTYP,TOKLEN,TOKTXT,TKIDES,STATUS)
  274.                   IF (TOKTYP.EQ.TEQUAL) THEN
  275.                       CALL ZPUTTK(TOKTYP,TOKLEN,TOKTXT,TKODES)
  276.                       CALL ZGETTK(TOKTYP,TOKLEN,TOKTXT,TKIDES,STATUS)
  277. C Pretend the result is a "name" though it may actually not be
  278.                       CALL ZPUTTK(TNAME,LENGTH(RESULT),RESULT,TKODES)
  279.   300                 CALL ZGETTK(TOKTYP,TOKLEN,TOKTXT,TKIDES,STATUS)
  280.                       IF (TOKTYP.EQ.TZEOS)
  281.      +                    CALL ERROR('Invalid PARAMETER statement')
  282.                       IF (TOKTYP.NE.TCOMMA .AND. TOKTYP.NE.TRPARN)
  283.      +                    GO TO 300
  284.                   END IF
  285.               END IF
  286.           END IF
  287.       END IF
  288.  
  289.       CALL ZPUTTK(TOKTYP,TOKLEN,TOKTXT,TKODES)
  290.       IF (TOKTYP.NE.TZEOF) GO TO 200
  291.  
  292.       END
  293. C ----------------------------------------------------------------------
  294. C
  295. C       E N T E R   -   Enter a parameter definition into the table
  296. C
  297.  
  298.       SUBROUTINE ENTER(IPNAME,PTABLE,NPARMS,MAXPAR,IPDEFN)
  299.  
  300.       INTEGER STDERR
  301.       PARAMETER (STDERR=2)
  302.  
  303.       INTEGER PARLEN
  304.       PARAMETER (PARLEN=48)
  305.  
  306.       INTEGER IPNAME(*),NPARMS,MAXPAR,IPDEFN(*)
  307.       CHARACTER*(PARLEN) PTABLE(2,MAXPAR)
  308.  
  309.       INTEGER NAMLEN,I
  310.       CHARACTER*(PARLEN) PNAME,PDEFN
  311.  
  312.       INTEGER LENGTH
  313.       EXTERNAL LENGTH,ZCHOUT,PUTLIN,ZMESS,ZTOCAP,ZITOF
  314.  
  315.       NAMLEN = LENGTH(IPNAME)
  316.       IF (NPARMS.EQ.MAXPAR) THEN
  317.           CALL ERROR('Too many parameters')
  318.       ELSE IF (NAMLEN.GE.PARLEN) THEN
  319.           CALL ZCHOUT('Parameter name "',STDERR)
  320.           CALL PUTLIN(IPNAME,STDERR)
  321.           CALL ZMESS('" is too long',STDERR)
  322.           CALL ERROR('ENTER: Fatal Error')
  323.       ELSE IF (LENGTH(IPDEFN).GE.PARLEN) THEN
  324.           CALL ZCHOUT('Parameter definition of "',STDERR)
  325.           CALL PUTLIN(IPNAME,STDERR)
  326.           CALL ZMESS('" is too long',STDERR)
  327.           CALL ERROR('ENTER: Fatal Error')
  328.       END IF
  329.  
  330.       CALL ZTOCAP(IPNAME)
  331.       CALL ZITOF(IPNAME,1,PARLEN,PNAME,.FALSE.)
  332.       CALL ZITOF(IPDEFN,1,PARLEN,PDEFN,.FALSE.)
  333.  
  334.       I = 1
  335.   100 IF (I.LE.NPARMS) THEN
  336.           IF (PNAME.EQ.PTABLE(1,I)) CALL ERROR('Parameter '//
  337.      +        PNAME(:NAMLEN)//' duplicated')
  338.           I = I + 1
  339.           GO TO 100
  340.       END IF
  341.  
  342.       NPARMS = NPARMS + 1
  343.       PTABLE(1,NPARMS) = PNAME
  344.       PTABLE(2,NPARMS) = PDEFN
  345.  
  346.       END
  347. C ----------------------------------------------------------------------
  348. C
  349. C       L O O K U P   -   Look a parameter definition up in a table
  350. C
  351.  
  352.       LOGICAL FUNCTION LOOKUP(IPNAME,PTABLE,NPARMS,IPDEFN)
  353.  
  354.       INTEGER EOS
  355.       PARAMETER (EOS=129)
  356.  
  357.       INTEGER PARLEN
  358.       PARAMETER (PARLEN=48)
  359.  
  360.       INTEGER NPARMS,IPNAME(*),IPDEFN(*)
  361.       CHARACTER*(PARLEN) PTABLE(2,NPARMS)
  362.  
  363.       INTEGER I,J
  364.       CHARACTER*(PARLEN) PNAME
  365.  
  366.       EXTERNAL ZITOF,ZFTOI,ZTOCAP
  367.  
  368.       CALL ZTOCAP(IPNAME)
  369.       CALL ZITOF(IPNAME,1,PARLEN,PNAME,.FALSE.)
  370.       DO 200 I = 1,NPARMS
  371.           IF (PNAME.EQ.PTABLE(1,I)) THEN
  372.               LOOKUP = .TRUE.
  373.               CALL ZFTOI(PTABLE(2,I),1,PARLEN,IPDEFN,.FALSE.)
  374.               DO 100 J = PARLEN,1,-1
  375.                   IF (PTABLE(2,I) (J:J).NE.' ') RETURN
  376.                   IPDEFN(J) = EOS
  377.   100         CONTINUE
  378.               RETURN
  379.           END IF
  380.   200 CONTINUE
  381.       LOOKUP = .FALSE.
  382.  
  383.       END
  384.