230 lines
5.0 KiB
Fortran
230 lines
5.0 KiB
Fortran
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
|