Article 6051 of alt.sources:
Path: jac.zko.dec.com!crl.dec.com!crl.dec.com!bloom-beacon.mit.edu!panix!news.mathworks.com!europa.chnt.gtegsc.com!news.sprintlink.net!howland.reston.ans.net!news.cac.psu.edu!news.pop.psu.edu!ra.nrl.navy.mil!mitch.nrl.navy.mil!grunes
From: grunes@news.nrl.navy.mil (Mitchell R Grunes)
Newsgroups: alt.sources
Subject: diagrami: Simple Diagrammer for IDL & PV-WAVE Language Programs: Update
Date: Wed, 28 Jun 1995 20:43:10 GMT
Organization: AlliedSignal Technical Services Corp.
Lines: 443
Message-ID: <grunes.258.804372190@news.nrl.navy.mil>
NNTP-Posting-Host: mitch.nrl.navy.mil

Archive-name: diagrami
Submitted-by: grunes@nrlvax.nrl.navy.mil (Mitchell R Grunes)

****diagrami: Simple Diagrammer for IDL & PV-WAVE Language Programs****

The most recent changes:
  Improve the way CASE constructs are diagrammed,
   but some complex CASE instances will still be missed.
  Try to recognize some Fortran 90 structures,
   but this is untested, and probably doesn't work.
  Allow you to choose IBM PC graphics symbols instead of +, | and -.

If you like or dislike it, send e-mail.  DON'T POST to alt.sources.
Sorry, little or no help can be provided for this program, and
I can't find problems without an example of where it failed.

CONTENTS:
  diagrami.for     Fortran language source code.
  diagrami.bat     Sample MS-DOS procedure to run without answering
                   questions. Executable must be in c:\grunes.
---diagrami.for--------------CUT HERE-----------------------------
c EXAMPLE OF OUTPUT (looks better with IBM PC graphics):

c     +---------pro Sample,a,b,c                               |   1
c     |         a=indgen(15)^2                                 |   2
c     |+--------if a eq b then begin                           |   3
c     ||          print,'A equals B'                           |   4
c     ||          c=0                                          |   5
c     |+--------else begin                                     |   6
c     ||          print,'A does not equal B'                   |   7
c     ||          c=1                                          |   8
c     |+--------endif                                          |   9
c     +---------end                                            |  10

c Diagrams IDL and PV-Wave begin(or case)-end constructs, functions
c  and procedures, places a * next to goto and return statements.
c
c Program by Mitchell R Grunes, ATSC/NRL (grunes@nrlvax.nrl.navy.mil).
c Revision date: 6/28/95.
c If you find it useful, please send me an e-mail comment.

c This program was written in FORTRAN, the One True Language.

c Note--this is a quick and dirty attempt--may not always work quite right.
c  It does not yet handle CASE instances, unless the case labels are
c   simple numeric or literal constants, or they use BEGIN...END
c   constructs, but it should draw a line around the entire CASE block.

c I hope this works for you, but bear in mind that nothing short of
c  a full-fledged language parser could really do the job.  Perhaps
c  worth about what you paid for it.    (-:

c Versions: To diagram Fortran: diagramf.for
c                      IDL:     diagrami.for
c                      C:       diagramc.for
c MS-DOS procedures to call above programs without asking so many questions,
c  append output to file diagram.out:
c                       Fortran: diagramf.bat
c                       IDL:     diagrami.bat
c                       C:       diagramc.bat

        program diagrami                        !Diagrammer for IDL and PV-WAVE
        character*80 filnam,filnam2

        print*,'IDL source filename?'
        read(*,'(a80)')filnam
        print*,filnam

        print*,'Output file (blank=screen)?'
        read(*,'(a80)')filnam2
        print*,filnam2

        print*,'Column in which to write line #''s ',
     &   '(67 for 80 col screen, 0 for none):'
        read*,LCol
        print*,LCol

        print*,'Use IBM PC graphics characters (0=no):'
        read*,iGraphics
        print*,iGraphics

        call diagram(filnam,filnam2,LCol,iGraphics)
        end
c-----------------------------------------------------------------------
        subroutine diagram(filnam,filnam2,LCol,iGraphics)
        character*80 filnam,filnam2
        character*160 a,b
        character*16 aa
        character*5 form
        character*8 fm
        character*1 c
        logical find
        external find
        common icol
        logical fout

c Define Block symbols:
        character*1 BlockBegin   (2) /'+','+'/
        character*1 BlockEnd     (2) /'+','+'/
        character*1 BlockElse    (2) /'+','+'/
        character*1 BlockContinue(2) /'|','|'/
        character*1 BlockHoriz   (2) /'-','-'/

        if(iGraphics.ne.0)then
          iGraphics=1

          BlockBegin   (1)=char(218)            ! (1)=normal
          BlockEnd     (1)=char(192)
          BlockElse    (1)=char(195)
          BlockContinue(1)=char(179)
          BlockHoriz   (1)=char(196)

          BlockBegin   (2)=char(214)            ! (2)=DO/FOR loops (doubled)
          BlockEnd     (2)=char(211)            ! (not yet used)
          BlockEnd     (2)=char(211)
          BlockElse    (2)=char(199)
          BlockContinue(2)=char(186)
          BlockHoriz   (2)=char(196)
        endif

        open(1,file=filnam,status='old')
        fout=filnam2.gt.' '
        if(fout)open(2,file=filnam2,status='unknown')

                                                !ASCII 12 is a form feed
        if(fout)write(2,*)char(12),
     &   '=============--',filnam(1:LenA(filnam)),'--============='
        if(fout)     write(2,'(1x,a57,a49)')
     &   '       ....,....1....,....2....,....3....,....4....,....5',
     &          '....,....6....,....7....,....8....,....9....,....'
        if(.not.fout)write(*,'(a57,a49)')' ',
     &   '       ....,....1....,....2....,....3....,....4....,....5',
     &          '....,....6....,....7....,....8....,....9....,....'

        aa=' '
        do i=1,15,2
          aa(i:i)=BlockContinue(1)
        enddo

        i1=0                                    !# of nest levels before current line
        i2=0                                    !# of nest levels on  current line
        i3=0                                    !# of nest levels after current line
        i4=0                                    !1 to flag start or end of block
        InSub=0                                 !Inside a subroutine or function?
        nMain=0                                 !no mainline program yet
        nline=0
10      a=' '
        read(1,'(a160)',end=99)a
        nline=nline+1
        fm=' '
        write(fm,'(i5)')nline
        form=fm
        !if(nline/100*100.eq.nline.and.fout)print*,'Line ',form

        if(a(1:1).eq.char(12))then
          if(fout)write(2,'(a1,:)')char(12)
          if(.not.fout)print*,'------------FORM FEED------------'
          b=a(2:160)
          a=b
        endif

        b=' '                                   !turn tabs to spaces
        j=1
        do i=1,160
          if(a(i:i).eq.char(9))then
            j=(j-1)/8*8+8+1
          elseif(j.le.160)then
            b(j:j)=a(i:i)
            j=j+1
          endif
        enddo
        i=1
        j=1
        a=' '
        iquote=0                                !no ' yet
        idquote=0                               !no " yet
        j=1
        do i=1,160
          c=b(i:i)
          if(c.ge.'A'.and.c.le.'Z')c=char(ichar(c)+32)
          if(c.eq.';')goto 15
          if(c.eq.''''.and.idquote.eq.0)then
            iquote=1-iquote
            c=' '
          endif
          if(c.eq.'"' .and.iquote .eq.0)idquote=1-idquote
          if(iquote.ne.0.or.idquote.ne.0)c=' '
          if(j.gt.1)then                        !(kill multiple spaces)
            if(c.eq.' '.and.a(j-1:j-1).eq.' ')j=j-1
          endif
          a(j:j)=c
          j=j+1
        enddo

15      i2=i1
        i3=i1
        iflag=0                                 !no goto on line

        if(a.ne.' '.and.InSub.eq.0..and..not.
     &   (find(a,'function ',2).or.find(a,'pro ',2)))then       !mainline
          InSub=InSub+1
          nMain=nMain+1
          if(fout)print*,'Line ',form,' ',b(1:LenA(b))
          if(nMain.gt.1)then
            PRINT*,'***ERROR--TOO MANY MAINLINES***'
            if(fout)WRITE(2,*)'***ERROR--TOO MANY MAINLINES!***'
            print*,char(7)
          endif
          i4=i4+1
          i2=i2+1
          i3=i3+1
        endif

        if(find(a,'goto',8+32).or.find(a,'return',1+128))iflag=1
        if(find(a,'endif ',2).or.find(a,'endfor ',2)
     &  .or.find(a,'endelse ',2).or.find(a,'endwhile ',2)
     &  .or.find(a,'endcase ',2).or.find(a,'endrep ',2))then
          i3=i3-1
          i4=i4+1
          if(find(a,'begin  ',1))i3=i3+1
        elseif(find(a,'case ',1).or.find(a,'begin  ',1))then
          i4=i4+1
          i2=i2+1
          i3=i3+1
        elseif(find(a,'end ',2))then
          if(i3.gt.0.or.Insub.gt.0)then         !Problem: IDL end may actually
            i3=i3-1                             ! be an endif, endelse, etc.
            i4=i4+1
            if(i3.eq.0.and.InSub.ne.0)InSub=0
            if(find(a,'begin  ',1))then
              i2=i2+1
              i3=i3+1
            endif
          endif
        elseif(find(a,'function ',2).or.find(a,'pro ',2))then
          if(fout)print*,'Line ',form,' ',b(1:LenA(b))
          InSub=InSub+1
          i2=i2+1
          i3=i3+1
          i4=i4+1
          if(InSub.ne.1.or.i3.ne.1)then
            PRINT*,'***ERROR--INVALID DIAGRAMMING INDEX line',form
            if(fout)
     &       WRITE(2,*)'***ERROR--INVALID DIAGRAMMING INDEX!***'
            print*,char(7)
            i3=1
            InSub=1
          endif
        elseif(find(a,':',256))then             ! CASE instance--simplist case
          i4=i4+1
        endif
        a=' '
        if(i1.lt.0.or.i2.lt.0.or.i3.lt.0.or.i4.lt.0)then
          PRINT*,'***ERROR--INVALID DIAGRAMMING INDEX line',form
          if(fout)WRITE(2,*)'***ERROR--INVALID DIAGRAMMING INDEX!***'
          print*,char(7)
          i1=max(i1,0)
          i2=max(i2,0)
          i3=max(i3,0)
          i4=max(i4,0)
        endif
        jj=max(1,min(16,2*i2-1))
        if(i2.gt.0)a=aa(1:jj)

        iBlock=1                                !for now
        if(i4.ne.0)then
          jjj=1
          dowhile(jjj.lt.160.and.b(jjj:jjj).eq.' ')
            jjj=jjj+1
          enddo
          do jjjj=1,jjj-2
            b(jjjj:jjjj)=BlockHoriz(iBlock)
          enddo
          do jjjj=jj+1,16
            a(jjjj:jjjj)=BlockHoriz(iBlock)
          enddo
          if(jjj.eq.1)a(15:16)=' '
        endif
        do i=0,i4-1
          c=BlockElse(iBlock)
          if(i1+i.lt.i3)c=BlockBegin(iBlock)
          if(i1+i.gt.i3)c=BlockEnd(iBlock)
          a(max(1,min(15,jj-i*2)):max(1,min(15,jj-i*2)))=c
        enddo
        if(LCol.ne.0.and.b(max(1,LCol):160).eq.' ')then
          if(form(1:1).eq.' ')form(1:1)=BlockContinue(iBlock)
          b(LCol:LCol+4)=form
        endif

        i4=0
        n=LenA(b)
        if(iflag.ne.0)a(13:13)='*'
c loop=last minute change to reduce spaces in diagram block:
        if(fout)     write(2,'(80a1,80a1)')
     &   (a(i:i),i=1,15,2),(b(i:i),i=1,n)
        if(.not.fout)write(*,'(1x,80a1,80a1)')
     &   (a(i:i),i=1,15,2),(b(i:i),i=1,n)
        i1=i3
        goto 10
99      if(i3.gt.0.or.InSub.ne.0)then
          PRINT*,'***WARNING--SOME NEST LEVELS LEFT HANGING AT END***'
          print*,char(7)
        endif
        end
c-----------------------------------------------------------------------
        logical function find(a,b,icond)        !find b in a, subject to conditions:
                                                !icond=sum of the following:
                                                !1:  Prior, if exists, must be blank
                                                !2:  Must be first non-blank
                                                !4:  Prior character, if present,
                                                !    must not be alphanumeric.
                                                !8:  Prior character, if present,
                                                !    must be blank or )
                                                !16: Prior character, if present,
                                                !    must be blank or ,
                                                !32: Next character not alphanumeric
                                                !64: Next character not alphabetic
                                                !128:Next character must be blank or (
                                                !256:1st non-blank, possibly except for
                                                !    numeric labels
c Program by Mitchell R Grunes, ATSC/NRL (grunes@nrlvax.nrl.navy.mil).
c Revision date: 6/28/95.
        character*(*) a,b
        character*1   c,cNext
        common icol
        logical result

        ii=len(a)
        jj=len(b)
        result=.false.
        do i=1,ii-jj+1
          if(a(i:i+jj-1).eq.b)then
            icol1=i                             ! icol1=column of item found
            icol =i+jj                          ! icol =colomn after item found

            c=' '
            cNext=' '
            if(icol1.gt.1)c=a(icol1-1:icol1-1)
            if(icol .le.ii)cNext=a(icol:icol)

            result=.true.
            if(result.and.iand(icond,1).ne.0.and.icol1.gt.1)then
              result=c.eq.' '
            endif

            if(result.and.iand(icond,2).ne.0.and.icol1.gt.1)then
              result=a(1:icol1-1).eq.' '
            endif

            if(result.and.iand(icond,4).ne.0)
     &       result=(c.lt.'0'.or.c.gt.'9').and.(c.lt.'a'.or.c.gt.'z')

            if(result.and.iand(icond,8).ne.0)result=c.eq.' '.or.c.eq.')'

            if(result.and.iand(icond,16).ne.0)result=
     &       c.eq.' '.or.c.eq.','

            if(result.and.iand(icond,32).ne.0)
     &       result=(cNext.lt.'0'.or.cNext.gt.'9').and.
     &              (cNext.lt.'a'.or.cNext.gt.'z')

            if(result.and.iand(icond,64).ne.0)
     &       result=(cNext.lt.'a'.or.cNext.gt.'z')

            if(result.and.iand(icond,128).ne.0)
     &       result=cNext.eq.' '.or.cNext.eq.'('

            if(result.and.iand(icond,256).ne.0.and.icol1.gt.1)then
              ii=1
              do iii=1,icol1-1
                c2=a(iii:iii)
                if(c2.ge.'0'.and.c2.le.'9')ii=iii+1
                if(c2.ne.' '.and.(c2.lt.'0'.or.c2.gt.'9'))goto 20
              enddo
20            if(ii.lt.icol1)then
                result=a(ii:icol1-1).eq.' '
              endif
            endif

            find=result
            if(result)return
          endif
        enddo
        find=result
        return
        end
c-----------------------------------------------------------------------
        function LenA(a)                        ! Length of string, at least 1
c Program by Mitchell R Grunes, ATSC/NRL (grunes@nrlvax.nrl.navy.mil).
c Revision date: 6/28/95.
        character*(*) a
        n=len(a)
        dowhile(n.gt.1.and.a(n:n).eq.' ')
          n=n-1
        enddo
        LenA=n
        end
---diagrami.bat--------------CUT HERE-----------------------------
rem procedure to diagram an IDL or PV-WAVE language program

rem  by Mitchell R Grunes.

rem I assume that the executable is in directory c:\grunes on
rem  your PC.

rem Syntax:
rem     diagrami
rem to be prompted for input parameters.

rem Alternate Syntax:
rem     diagrami filename(s)
rem to append diagram of file(s) into diagram.out

if %1a == a  c:\grunes\diagrami
if %1a == a  goto quit

echo off
:loop

  echo ========================-- %1 --========================
  rem Prompt answers: input from %1, output to diagram2.sc (for now),
  rem  place numbers in column 67, use IBM PC graphics.

  echo %1          >  diagram.sc
  echo diagram2.sc >> diagram.sc
  echo 67          >> diagram.sc
  echo 1           >> diagram.sc

  c:\grunes\diagrami < diagram.sc
  type diagram2.sc >> diagram.out
  del diagram.sc
  del diagram2.sc
  shift
  if not %1a == a goto loop

:quit
-----------------------------CUT HERE-----------------------------
-------------------------------------------------------------------------
  Opinions are mine alone.
  I am not a "Real Programmer".  I only program in the Real World.
  Mitchell R Grunes (grunes@nrlvax.nrl.navy.mil)
  AlliedSignal Technical Services Corp.



