classf.for

linux 下的源代码分析阅读器 red hat公司新版

      SUBROUTINE CLASSF
*-----------------------------------------------------------------------
*
*--- classifies a FORTRAN statement.
*    modified by JJB to understand mixed case Fortran
*
*--- input
*    SSTA       string containing the statement
*    NCHST      last ch. of statement in SSTA
*    SSTM (,ISTMDS,IALPHA,IPRIOR,IHEADR) statement descriptors
*--- output
*    ICURCL = statement numbers of first part and second part
*          ( ICURCL(2) set for ICURCL(1) = IIF = logical IF, else = ILL)
*                 ICURCL(1) = ILL for illegal statements
*
*-----------------------------------------------------------------------
      include 'param.h'
      include 'alcaza.h'
      include 'class.h'
      include 'flags.h'
      include 'flwork.h'
      include 'cursta.h'
      CHARACTER STEMP*1,STRING*25,ssta_t*(mdimst),touppr*(mdimst)
      external touppr
      include 'convex.h'
      ICURCL(1)=ILL
      ICURCL(2)=ILL
*--- if illegal during extraction (EXTRAC), return
      IF (STATUS(3)) GOTO 999
      if (nchst.eq.0) then
          icurcl(1) = 0
          goto 999
      endif
      KSTART=1
      ssta_t(:nchst) = touppr(ssta(:nchst))
*--- loop over (possibly) two parts of statement
      DO 50 IPRTS=1,2
         KPOS=0
   10    STEMP=SSTA_t(KSTART:)
         IF (STEMP.EQ.' ')  THEN
*--- skip blanks
            KSTART=KSTART+1
            GOTO 10
         ENDIF
*--- check priority statements first if '=' present
         IF(INDEX(SSTA_t(KSTART:NCHST),'=').NE.0) THEN
            DO 20 JS=1,NPRIOR
               JSS=IPRIOR(JS)
               CALL MATCH(SSTM,ISTMDS(3,JSS),ISTMDS(4,JSS),
     &              SSTA_t,KSTART,NCHST,.FALSE.,KPOS,ILEV,
     &              NDUMMY,IWS,IWS)
               IF (KPOS.NE.0) GOTO 40
   20       CONTINUE
         ENDIF
*--- no match yet - get alphabetic group and compare
         IF (ALPHCH(STEMP))  THEN
            K=ICVAL(STEMP)
         ELSE
            K=53
         ENDIF
         if(k.le.0.or.k.gt.53) goto 999
C?J         IF(K.LE.0.OR.K.GT.53) GOTO 999
*--- KBLP = pos. of first blank after start of keyword,
         KBLP=INDEX(SSTA_t(KSTART:NCHST),' ')
         DO 30 JSS=IALPHA(1,K),IALPHA(2,K)
            IF (ISTMDS(7,JSS).EQ.0.AND.ISTMDS(3,JSS).NE.0)  THEN
               IF(ISTMDS(13,JSS).GE.2) THEN
*--- simple match is sufficient
                  I1=ISTMDS(3,JSS)
                  I2=ISTMDS(4,JSS)
                  N1=I2-I1
                  N2=N1+1
                  IF(KBLP.EQ.0.OR.KBLP.GT.N2) THEN
                    IF(SSTA_t(KSTART:KSTART+N1).EQ.SSTM(I1:I2))KPOS=1
                  ELSE
                    CALL GETNBL(SSTA_t(KSTART:NCHST),STRING(1:N2),KEXT)
                    IF(KEXT.GE.N2) THEN
                      IF(STRING(:N2).EQ.SSTM(I1:I2)) KPOS=1
                    ENDIF
                  ENDIF
               ELSE
                  CALL MATCH(SSTM,ISTMDS(3,JSS),ISTMDS(4,JSS),SSTA_t,
     +            KSTART, NCHST,.FALSE.,KPOS,ILEV,NDUMMY,IWS,IWS)
               ENDIF
               IF (KPOS.NE.0) GOTO 40
            ENDIF
   30    CONTINUE
*--- exit if no match at all
         GOTO 999
   40    CONTINUE
*--- matched
         IF (IPRTS.EQ.1)  THEN
            ICURCL(1)=JSS
            IF (ICURCL(1).NE.IIF.and.icurcl(1).ne.iif+71) GOTO 999
*--- skip to end of if(...)
            KMT=INDEX(SSTA_t(1:NCHST),'(')
            CALL SKIPLV(SSTA_t,KMT+1,NCHST,.FALSE.,KPOS,ILEV)
            KSTART=KPOS+1
         ELSE
*--- second part matched
            ICURCL(2)=JSS
         ENDIF
   50 CONTINUE
  999 END