src/linp.f

Fortran project RESTRAX, source module src/linp.f.

Source module last modified on Wed, 13 Jul 2005, 16:20;
HTML image of Fortran source automatically generated by for2html on Mon, 29 May 2006, 15:06.


#///////////////////////////////////////////////////////////////////////////
#////                                                                   //// 
#////  LINP - v.1.2, (c) J.Saroun, 1999-2001                            ////
#////                                                                   //// 
#////  Universal command line interpreter                               //// 
#////                                                                   //// 
#////                                                                   //// 
#///////////////////////////////////////////////////////////////////////////
#////
#////
#////  Usage:
#////
#////  CALL LINPSET(NLINES,' PROMPT',COMMANDS,HINTS)
#////   ..... to set the prompt, commands and hints 
#//// 
#////  LINE=LINPEXEC(ICOM,NPAR)
#////   ..... reads the input and returns command number(ICOM), 
#/////        number of following parameters (NPAR)
#////         and the rest of the input string after the command (LINE)
#//// 
#////  LINE=FUNCTION LINPEXECSTR(SCOMM,ICOM,NPAR)
#////  .....  as LINPEXEC, but treats the string SCOMM instead of std. input
#//// 
#////  CALL LINPGETIO(IN,OUT,ERR), LINPSETIO(IN,OUT,ERR) 
#////   .... get or set the inout, output and error unit numbers
#//// 
#////
#///////////////////////////////////////////////////////////////////////////

#     ---------------------------------------------------
      integer*4 FUNCTION ORDCOM(what,commands,ncmd)
#     returns ordinal number of command
#     copy of GETICOM from "linp", but with var 'commands' argument      
#     ---------------------------------------------------
      implicit none
      character*(*) what
      integer*4 i,l,ipos,nc,ncmd
      character*(*) commands(ncmd)

      ipos=1
      nc=0
      ORDCOM=0
      call FINDPAR(what,1,ipos,l)      
      if (l.le.0) return
      call MKUPCASE(what(ipos:ipos+l-1))
      do i=1,ncmd
        if (index(commands(i),what(ipos:ipos+l-1)).eq.1) then
          ORDCOM=i  
          nc=nc+1
        endif
        if (nc.gt.1) then
           ORDCOM=-3     ! ambiguous command
           return  
        endif            
      enddo
      
      end    


#---------------------------------------------------
      integer*4 FUNCTION GETICOM(what)
# returns ordinal number of command 
# command not found  ... return 0
# ambiguous command  ... return -3
#---------------------------------------------------
      implicit none
      INCLUDE 'linp.inc'
      character*(*) what
      integer*4 i,l,ipos,nc,i1,i2
      character*5 cm

      ipos=1
      nc=0
      GETICOM=0
      call FINDPAR(what,1,ipos,l)
      if (l.gt.5) l=5
      
      if (l.le.0) return
      call MKUPCASE(what(ipos:ipos+l-1))
      do i=1,linp_nc
        cm=linp_c(i)
        call MKUPCASE(cm)
        if (index(cm,what(ipos:ipos+l-1)).eq.1) then
          GETICOM=i  
          nc=nc+1
          i1=1
          call FINDPAR(cm,1,i1,i2)
          if (cm(i1:i1+i2-1).eq.what(ipos:ipos+l-1)) return             
        endif
      enddo
      if (nc.gt.1) then
           GETICOM=-3     ! ambiguous command
           return  
      endif            
      
      end    

#     ---------------------------------------------------
      SUBROUTINE LINPGETIO(in,out,err)
#     ---------------------------------------------------
      implicit none
      INCLUDE 'linp.inc'
      integer*4 in,out,err
        in=linp_in
        out=linp_out
        err=linp_err
      end  


#     ---------------------------------------------------
      SUBROUTINE LINPSETIO(in,out,err)
#     ---------------------------------------------------
      implicit none
      INCLUDE 'linp.inc'
      integer*4 in,out,err
        linp_in=in
        linp_out=out
        linp_err=err
        linp_eof=0
      end  

#     ---------------------------------------------------
      SUBROUTINE LINPSET(nc,prompt,commands,hints)
#     ---------------------------------------------------
      implicit none
      INCLUDE 'linp.inc'
      integer*4 nc,i,dimc,dimh
      character*(*) commands(nc)
      character*(*) hints(nc),prompt
      
      call BOUNDS(prompt,i,linp_np)
      if (i+linp_np-1.gt.20) linp_np=21-i
      linp_p=prompt(1:i+linp_np-1)
# if nc=0, only prompt can be set up
      if (nc.le.0) return 
      dimc=len(commands(1))      
      dimh=len(hints(1))
      linp_nc=nc      
      if (dimc.gt.5) dimc=5
      if (dimh.gt.60) dimh=60
      if (linp_nc.gt.linp_dim) linp_nc=linp_dim
      do i=1,linp_nc
        linp_c(i)=commands(i)(1:dimc)
        linp_h(i)=hints(i)(1:dimh)
#        write(*,*) i,' ',linp_c(i),'  ',linp_h(I)
      enddo
      
      end  
           
#---------------------------------------------------
      character*(*) FUNCTION LINPEXECSTR(scomm,icom,npar)
#  Treat command string 
#  input:   
#    SCOMM ... command string
#  output:  
#    ICOM: command ID
#    NPAR: number of command arguments
#  return: command with arguments
#  NOTE:
#  - ICOM=-5 ... command is an integer => return this integer as NPAR
#  - ICOM=-4 ... end of input file
#  - ICOM=-3 ... ambiguous command 
#  - ? gives a list of commands with hints
#  - 
#---------------------------------------------------
      implicit none
      INCLUDE 'linp.inc'
      integer*4 icom,i,j,k,l,ip,ll,GETICOM,npar
      character*128 line
      character*(*) scomm
      logical*4 IsInteger
      
      data linp_in,linp_out,linp_err /5,6,7/
      data linp_np,linp_p /4, 'LINP'/

1     format(a)
      l=len(scomm)
      line=scomm(1:l)
            
#// if the input is integer, return it as string, and in NPAR as value    
      if (IsInteger(line(1:l))) then
        read(line(1:l),*,err=20) i
        LINPEXECSTR=scomm(1:l)
#c        WRITE(LINPEXECSTR,*) I
        icom=-5
        npar=i        
        return
      endif
            
20    icom=GETICOM(line)      ! find command number 
      ll=len(line)      
      if (icom.eq.-3) write(linp_err,1)  'Ambiguous command !'
      if (icom.lt.0) return
      
      k=1
      call FINDPAR(line,1,k,l)
      if (l.eq.0) return   ! line was empty
      if (icom.gt.0) then
        call BOUNDS(line(k+l:ll),ip,i)
        ip=ip+k+l-1
        LINPEXECSTR=line(ip:ip+i-1)    ! return string with parameters
        npar=0
        do while (l.gt.0)
          k=k+l
          call FINDPAR(line,1,k,l)
          if (l.gt.0) npar=npar+1          
        enddo
        return
      else if (icom.eq.0) then
        if (line(1:k).eq. '?') then
           k=k+l      
           call FINDPAR(line,1,k,l)
           i=GETICOM(line(k:k+l-1))
           if (i.gt.0) then
              if (linp_h(i) .ne. ' ') then 
               write(linp_out,*) linp_c(i)// '  '//linp_h(i)
              endif 
           else
               do j=1,linp_nc
                 if (linp_h(j).ne. ' ') then 
                   write(linp_out,*) linp_c(j)// '  '//linp_h(j)
                 endif 
               enddo
               write(linp_out,*)  'LIST   list values'
               write(linp_out,*)  'QUIT   quit this menu'
           endif
        else
           call MKUPCASE(line(1:k))
           if (index( 'QUIT',line(1:k)).eq.1) then
              LINPEXECSTR= 'QUIT'
              npar=0
              return
           else if (index( 'LIST',line(1:k)).eq.1) then
              LINPEXECSTR= 'LIST'
              npar=0
              return
           else
              write(linp_out,*)  'type ? for help'        
           endif
        endif
      endif
      LINPEXECSTR= ' '
      npar=0
      end

#     ---------------------------------------------------
      character*(*) FUNCTION GETCOM(icom)
#     returns ICOM-th command name      
#     ---------------------------------------------------
      implicit none
      INCLUDE 'linp.inc'
      integer*4 icom
      if (icom.gt.0.and.icom.le.linp_nc) then
         GETCOM=linp_c(icom)
      else if (icom.eq.-1) then
         GETCOM= 'QUIT'         
      else if (icom.eq.-2) then
         GETCOM= '?'
      else       
         GETCOM= ' '
      endif
      end

#     ---------------------------------------------------
      character*(*) FUNCTION GETHINT(icom)
#     ---------------------------------------------------
      implicit none
      INCLUDE 'linp.inc'
      integer*4 icom
      if (icom.gt.0.and.icom.le.linp_nc) then
         GETHINT=linp_h(icom)
      else if (icom.eq.-1) then
         GETHINT= 'Quit interpreter'         
      else if (icom.eq.-2) then
         GETHINT= 'Show hints'
      else if (icom.eq.-3) then
         GETHINT= 'Ambiguous command'
      else       
         GETHINT= ' '
      endif
      end