argtyp.for

This Source-Navigator, an IDE for C/C++/Fortran/Java/Tcl/PHP/Python and a host of other languages.

      SUBROUTINE ARGTYP(STRING,CALLFL,I1,I2,ARG)
*-----------------------------------------------------------------------
*
*--- returns a list of argument types
*--- input
*    STRING(I1:I2) = '(...)' argument list
*    CALLFL        = .TRUE. if argument list of a caller, else .FALSE.
*--- output
*    ARG           character variable, 1 ch./argument
*                  'I' = integer
*                  'R' = real
*                  'D' = double prec.
*                  'K' = complex
*                  'C' = character
*                  'L' = logical
*                  'P' = procedure (subroutine or function passed)
*                  '*' = alternate ret.
*                  '$' = not determined
*
*   the rest is blank.
*-----------------------------------------------------------------------
      include 'param.h'
      include 'alcaza.h'
      include 'condec.h'
      include 'state.h'
      CHARACTER STRING*(*),ARG*(*),STYP*1, STEMP*1,SNAME*(MXNMCH),
     +ATYP*7
      LOGICAL BRNONE,CALLFL
      DATA ATYP/'IRLKDC$'/
      include 'condat.h'
      KPOS=I1
      N=0
   10 CONTINUE
      IPT=KPOS
*--- find end of each argument
      CALL POSCH(',',STRING,IPT+1,I2, .FALSE.,0,KPOS,ILEV)
      IF(KPOS.EQ.0)  KPOS=I2
      N=N+1
      STEMP=STRING(IPT+1:IPT+1)
      IF(STEMP.EQ.' ')  THEN
         IPT=IPT+1
         STEMP=STRING(IPT+1:IPT+1)
      ENDIF
      IF(STEMP.EQ.'*')  THEN
         ARG(N:N)='*'
      ELSE
         IF(STEMP.EQ.'+'.OR.STEMP.EQ.'-') THEN
            IPT=IPT+1
            STEMP=STRING(IPT+1:IPT+1)
            IF(STEMP.EQ.' ') THEN
               IPT=IPT+1
               STEMP=STRING(IPT+1:IPT+1)
            ENDIF
         ENDIF
         IF(INDEX('0123456789(.{',STEMP).NE.0) THEN
            CALL GETCON(STRING,IPT+1,KPOS,KLCH,STYP)
            IF(KLCH.EQ.0) GOTO 60
            IF(KLCH+1.EQ.KPOS.OR.(KLCH+2.EQ.KPOS .AND.STRING(KLCH+1:KLCH
     +      +1).EQ.' ' )) THEN
*--- argument is a simple constant
               ARG(N:N)=STYP
            ELSE
               GOTO 60
            ENDIF
         ELSEIF(ALPHCH(STEMP)) THEN
            CALL GETNAM(STRING,IPT+1,KPOS,KFCH, KNAM)
            KLCH=KNAM
            STEMP=STRING(KLCH+1:KLCH+1)
            IF(STEMP.EQ.' ') THEN
               KLCH=KLCH+1
               STEMP=STRING(KLCH+1:KLCH+1)
            ENDIF
            IF(STEMP.EQ.'(') THEN
*--- check for dimensioned variable, or function
               CALL SKIPLV(STRING,KLCH+2,KPOS, .FALSE.,KLCH,ILEV)
               STEMP=STRING(KLCH+1:KLCH+1)
               IF(STEMP.EQ.' ') THEN
                  KLCH=KLCH+1
                  STEMP=STRING(KLCH+1:KLCH+1)
               ENDIF
               BRNONE=.FALSE.
            ELSE
               BRNONE=.TRUE.
            ENDIF
            IF(KLCH+1.EQ.KPOS) THEN
*--- simple argument
               SNAME=' '
               CALL GETNBL(STRING(KFCH:KNAM),SNAME, NN)
               DO 20 IPOS=1,NSNAME
                  IF(SNAME.EQ.SNAMES(ISNAME+IPOS)) GOTO 30
   20          CONTINUE
               GOTO 60
   30          CONTINUE
               NT=NAMTYP(ISNAME+IPOS)
               IF(BRNONE.AND. (CALLFL.AND.(ITBIT(NT,15).NE.0.OR.ITBIT
     +         (NT,17).NE.0) .OR.(.NOT.CALLFL.AND.ITBIT(NT,12).NE.0)))
     +         THEN
*--- subroutine or function passed as argument
                  ARG(N:N)='P'
               ELSE
                  DO 40 I=1,6
                     K=NT/2
                     IF(NT-2*K.GT.0) GOTO 50
                     NT=K
   40             CONTINUE
   50             CONTINUE
                  ARG(N:N)=ATYP(I:I)
               ENDIF
            ELSE
               GOTO 60
            ENDIF
         ELSE
            GOTO 60
         ENDIF
      ENDIF
      GOTO 70
   60 CONTINUE
      ARG(N:N)=ATYP(7:7)
   70 CONTINUE
      IF(KPOS.LT.I2) GOTO 10
  999 END