Source module last modified on Thu, 10 Mar 2005, 15:03;
HTML image of Fortran source automatically generated by
for2html on Mon, 23 May 2005, 21:29.
#///////////////////////////////////////////////////////////////////////////
#//// ////
#//// 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 LINPEXEC(icom,npar)
# read a string from input and treat through LINPEXECSTR
# output:
# ICOM: command ID
# NPAR: number of command arguments
# return: command with arguments
# NOTE:
# if end of input file => ICOM=-4
#---------------------------------------------------
implicit none
INCLUDE 'linp.inc'
integer*4 icom,npar,ll
character*128 line,LINPEXECSTR
character*1 ch
1 format(a)
2 format(a,$)
10 if (linp_in.eq.5) write(linp_out,2) linp_p(1:linp_np)// '> '
if (linp_eof.gt.0) goto 20
read(linp_in,1,end=20) line
ch=line(1:1)
if (ch.eq. '#'.or.ch.eq. ' '.or.ch.eq.char(0)) goto 10
if (line(1:1).eq. '#') goto 10
ll=len(line)
# IF (linp_in.NE.5) WRITE(linp_out,1) linp_p(1:linp_np)//
# & '> '//LINE(1:LL)
LINPEXEC=LINPEXECSTR(line(1:ll),icom,npar)
if (icom.eq.-3) goto 10
return
20 LINPEXEC= 'EOF'
# write(*,*) 'linpexec: EOF'
npar=0
icom=-4
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)
#3 FORMAT(I)
l=len(scomm)
line=scomm(1:l)
# READ(linp_in,1) LINE
#// try first, whether the input is integer
#// if yes, return it as string, and in NPAR as value
if (IsInteger(line(1:l))) then
read(line(1:l),*,err=20) i
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 if (index( 'PAUSE',line(1:5)).eq.1) then
LINPEXECSTR= 'PAUSE'
call DOPAUSE
npar=0
return
else if (index( 'ECHO',line(1:4)).eq.1) then
LINPEXECSTR= 'ECHO'
call DOECHO
npar=0
return
else
write(linp_out,*) 'type ? for help'
endif
endif
endif
LINPEXECSTR= ' '
npar=0
end
#--------------------------------
SUBROUTINE DOPAUSE
# stop & wait for enter
#--------------------------------
implicit none
INCLUDE 'linp.inc'
character*1 ch
1 format( ' press ENTER ...',$)
2 format(a)
write(linp_out,1)
read(*,2) ch
write(linp_out,*)
if (ch.eq. 'q'.or.ch.eq. 'Q') linp_eof=1
end
#--------------------------------
SUBROUTINE DOECHO
# copy input to output until END - useful in batch files
#--------------------------------
implicit none
INCLUDE 'linp.inc'
character*128 comm,s
integer*4 is,il
logical*4 bk
2 format(a)
bk=.false.
write(linp_out,*)
do while(.not.bk)
read(linp_in,2,end=20) comm
call BOUNDS(comm,is,il)
s=comm(is:is+il-1)
call MKUPCASE(s)
bk=(il.eq.3.and.s(1:il).eq. 'END')
if (.not.bk) write(linp_out,*) comm(is:is+il-1)
enddo
return
20 write(linp_out,*) 'ECHO command: END statement is missing'
call DOPAUSE
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