program fvi
c OBSOLETE (see make_custom.f)
c
c  create function variable interface (fvi) for FORTRAN
c  the argument is the name of a file containing a list of subroutine/function names
c
c  - first part: function type
c        sys_ifun_  integer function
c        sys_rfun_  real function
c        sys_dfun_  double function
c        sys_call_  subroutine
c  - subsequent letters:
c        i          integer argument
c        r          real argument
c        d          double argument
c        c          character(*) argument
c        e          external argument
c  if the argument list is empty, 0 is used
c
c 
c usage examples:
c
c   subroutine test1(cc, rr, ii)
c   character cc*(*)
c   real rr
c   integer ii
c   ...
c   end
c
c   integer function test2()
c   ...
c   end
c 
c   program test
c   ...
c   external test1, test2
c   integer*8 cod1, cod2
c   integer sys_ifun_0 ! function
c   character c8
c   real r
c   integer i
c   
c   ...

c   call sys_funadr(test1, cod1)
c   call sys_funadr(test2, cod2)
c   ...
c   call sys_call_cri(test1, c, r, i)
c   i=sys_ifun_0(test2)
c   ...
c   end
c
	integer vms, tru64, gnu
	parameter (vms=1, tru64=2, gnu=3)

	character line*80, typ*8, system*16
	integer i,l,lc,lt,sys, nest, iostat

	call sys_check_system(system)
	call sys_get_cmdpar(line, l)
	call sys_open(1, line(1:l), 'r', iostat)
	if (iostat .ne. 0) stop 'FVI: open failed'
	call sys_open(2, 'sys_fvi.c', 'wo', iostat)
	if (iostat .ne. 0) stop 'FVI: open write failed'
	if (system .eq. 'VMS') then
	  sys=vms
	  system='Alpha VMS'
	elseif (system .eq. 'TRU64') then
	  sys=tru64
	  system='Alpha Unix'
	elseif (system .eq. 'GNU') then
	  sys=gnu
	  system='GNU (g77/gcc)'
	else
	  print *,system
	  stop 'unimplemented system'
	endif
	write(2,'(2a)')
	1 '/* FORTRAN function variable interface for ',system
	write(2,'(a)')
	1 ' * this file is created by fvi and should not be modified */'
1	read(1,'(a)',end=99) line
	if (line(1:1) .eq. '!') goto 1
	do i=1,len(line)
	  if (line(i:i) .lt. 'a') then
	    if (line(i:i) .le. ' ') then
	      l=i-1
	      goto 10
	    endif
	    if (line(i:i) .ge. 'A' .and. line(i:i) .le. 'Z')
	1      line(i:i)=char(ichar(line(i:i))+32)
	  endif
	enddo
	print *,line
	stop 'too many arguments'
10	if (line(1:9) .eq. 'sys_ifun_') then
	  typ='int'
	  lt=3
	elseif (line(1:9) .eq. 'sys_rfun_') then
	  lt=5
	  typ='float'
	elseif (line(1:9) .eq. 'sys_dfun_') then
	  typ='double'
	  lt=6
	elseif (line(1:9) .eq. 'sys_call_') then
	  typ='void'
	  lt=4
	else
	  goto 19
	endif
	call fvi_putstr(typ(1:lt+1))
	call fvi_putstr(line(1:l))
	if (sys .eq. tru64) call fvi_putstr('_') ! digital unix
	if (sys .eq. gnu) call fvi_putstr('__') ! gnu
	call fvi_putstr('(')
	call fvi_putstr(typ(1:lt))
	call fvi_putstr(' (**rtn)(')
	if (line(10:l) .eq. '0') then
	  call fvi_putstr('void))')
	  call fvi_putln
	  call fvi_putstr('	{ ')
	  if (typ .ne. 'void') call fvi_putstr('return')
	  call fvi_putstr('((*rtn)()); }')
	  call fvi_putln
	  goto 1
	endif
	do nest=1,2
	  lc=0
	  do i=10,l
	    if (nest+i .gt. 11) call fvi_putstr(',')
	    if (line(i:i) .eq. 'i') then
	      call fvi_putstr('int *a')
	      call fvi_putint(i-9)
	    elseif (line(i:i) .eq. 'r') then
	      call fvi_putstr('float *a')
	      call fvi_putint(i-9)
	    elseif (line(i:i) .eq. 'd') then
	      call fvi_putstr('double *a')
	      call fvi_putint(i-9)
	    elseif (line(i:i) .eq. 'c') then
	      if (sys .eq. vms) then
	        call fvi_putstr('void *a') ! descriptor
	      elseif (sys .eq. tru64 .or. sys .eq. gnu) then
	        call fvi_putstr('char *a') ! lengths are passed at end of argument list
	        lc=lc+1
	      else
	        stop 'unimplemented system'
	      endif
	      call fvi_putint(i-9)
	    elseif (line(i:i) .eq. 'e') then
	      call fvi_putstr('void (*a')
	      call fvi_putint(i-9)
	      call fvi_putstr(')(void)')
	    else
	      call fvi_putstr('*** error ***')
	      print *,line(1:l),' unknown type: ',line(i:i)
	    endif
	  enddo
	  do i=1,lc
	    call fvi_putstr(',int a')
	    call fvi_putint(i+l-9)
	  enddo
	  call fvi_putstr(')')
	enddo
	call fvi_putln
	call fvi_putstr('	{ ')
	if (typ .eq. 'void') then
	  call fvi_putstr('if(*rtn){')
	else
	  call fvi_putstr('return(')
	endif
	call fvi_putstr('(*rtn)(a1')
	do i=11,l+lc
	  call fvi_putstr(',a')
	  call fvi_putint(i-9)
	enddo
	if (typ .eq. 'void') then
	  call fvi_putstr(');};}')
	else
	  call fvi_putstr('));}')
	endif
	call fvi_putln
	goto 1

19	call fvi_putstr('*** error ***')
	call fvi_putln
	print *,line(1:l),' < illegal prototype name'
	goto 1

99	close(1)
	close(2)
	end


	subroutine fvi_putstr(str)

	character str*(*)
	integer n

	character out*132/' '/,num*12
	integer l/0/,i

	if (l+len(str) .gt. len(out)-12) then  ! let space for an integer number on the same line
	  write(2,'(a)') out(1:l)
	  l=0
	endif
	out(l+1:l+len(str))=str
	l=l+len(str)
	return

	entry fvi_putint(n)

	write(num, '(i12)') n
	do i=11,1,-1
	  if (num(i:i) .eq. ' ') then
	    out(l+1:l+12-i)=num(i+1:12)
	    l=l+12-i
	    return
	  endif
	enddo
	stop 'FVI_PUTINT: error'

	entry fvi_putln

	if (l .gt. 0) then
	  write(2,'(a)') out(1:l)
	  l=0
	endif
	end