275 lines
6.3 KiB
Fortran
275 lines
6.3 KiB
Fortran
subroutine make_fvi(lunin)
|
|
c
|
|
c create function variable interface (fvi) for FORTRAN
|
|
c input contains 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_ for 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_ifun0(test2)
|
|
c ...
|
|
c end
|
|
c
|
|
integer lunin
|
|
|
|
character line*80, typ*8, system*16
|
|
integer i,l,lc,lt, phase, iostat, lunout, typno
|
|
integer underscores
|
|
integer descriptor
|
|
|
|
lunout=2
|
|
if (lunout .eq. lunin) then
|
|
print *,'lun mismatch'
|
|
stop 'error in MAKE_FVI'
|
|
endif
|
|
call sys_check_system(system)
|
|
call sys_fortran_interface(underscores, descriptor)
|
|
call sys_open(lunout, 'sys_fvi.c', 'wo', iostat)
|
|
if (iostat .ne. 0) then
|
|
print *,'cannot write sys_fvi.c'
|
|
stop 'error in MAKE_FVI'
|
|
endif
|
|
if (system .eq. 'VMS') then
|
|
system='Alpha VMS'
|
|
elseif (system .eq. 'TRU64') then
|
|
system='Alpha Unix'
|
|
elseif (system .eq. 'GNU') then
|
|
system='GNU (g77/gcc)'
|
|
else
|
|
system = 'strange system'
|
|
endif
|
|
write(lunout,'(2a)')
|
|
1 '/* FORTRAN function variable interface for ',system
|
|
write(lunout,'(a)')
|
|
1 ' * this file is created by fvi and should not be modified */'
|
|
write(lunout,'(a)')
|
|
1 '#include "fvi.c"'
|
|
typno=1964
|
|
1 read(lunin,'(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))
|
|
do i=1,underscores
|
|
call fvi_putstr('_')
|
|
enddo
|
|
call fvi_putstr('(int *funno')
|
|
do phase=1,2
|
|
lc=0
|
|
if (line(10:l) .ne. '0') then
|
|
do i=10,l
|
|
if (i .ne. 10 .or. phase .eq. 1) then
|
|
call fvi_putstr(',')
|
|
endif
|
|
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 (descriptor .eq. 1) then
|
|
call fvi_putstr('void *a') ! descriptor
|
|
elseif (descriptor .eq. 0) then
|
|
call fvi_putstr('char *a') ! lengths are passed at end of argument list
|
|
lc=lc+1
|
|
else
|
|
stop 'unknown descriptor code'
|
|
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
|
|
else if (phase .eq. 2) then
|
|
call fvi_putstr('void')
|
|
endif
|
|
do i=1,lc
|
|
call fvi_putstr(',int a')
|
|
call fvi_putint(i+l-9)
|
|
enddo
|
|
call fvi_putstr(')')
|
|
if (phase .eq. 1) then
|
|
call fvi_putstr(' {')
|
|
call fvi_putln(lunout)
|
|
call fvi_putstr(' typedef ')
|
|
call fvi_putstr(typ(1:lt))
|
|
call fvi_putstr(' (*R)(')
|
|
endif
|
|
enddo
|
|
call fvi_putstr(';')
|
|
call fvi_putln(lunout)
|
|
call fvi_putstr(' int no=*funno;')
|
|
call fvi_putln(lunout)
|
|
call fvi_putstr(' if (list[no].t == ')
|
|
call fvi_putint(typno)
|
|
call fvi_putstr(') {')
|
|
call fvi_putln(lunout)
|
|
call fvi_putstr(' ')
|
|
if (typ .ne. 'void') then
|
|
call fvi_putstr('return ')
|
|
endif
|
|
call fvi_putstr('(*(R)list[no].r)(')
|
|
if (line(10:10) .ne. '0') then
|
|
call fvi_putstr('a1')
|
|
endif
|
|
do i=11,l+lc
|
|
call fvi_putstr(',')
|
|
call fvi_putstr('a')
|
|
call fvi_putint(i-9)
|
|
enddo
|
|
call fvi_putstr(');')
|
|
call fvi_putln(lunout)
|
|
call fvi_putstr(' } else {')
|
|
call fvi_putln(lunout)
|
|
call fvi_putstr(' assert(no == 0 && list[no].t == 0);')
|
|
if (typ .ne. 'void') then
|
|
call fvi_putln(lunout)
|
|
call fvi_putstr(' return 0;')
|
|
endif
|
|
call fvi_putln(lunout)
|
|
call fvi_putstr(' }')
|
|
call fvi_putln(lunout)
|
|
call fvi_putstr('}')
|
|
call fvi_putln(lunout)
|
|
call fvi_putstr('int sys_adr')
|
|
if (typ .ne. 'void') then
|
|
call fvi_putstr(line(5:5))
|
|
endif
|
|
call fvi_putstr('_')
|
|
call fvi_putstr(line(10:l))
|
|
do i=1,underscores
|
|
call fvi_putstr('_')
|
|
enddo
|
|
call fvi_putstr('(Routine r) {')
|
|
call fvi_putln(lunout)
|
|
call fvi_putstr(' return idx(r, ')
|
|
call fvi_putint(typno)
|
|
call fvi_putstr(');')
|
|
call fvi_putln(lunout)
|
|
call fvi_putstr('}')
|
|
call fvi_putln(lunout)
|
|
typno=typno+1
|
|
goto 1
|
|
|
|
19 call fvi_putstr('*** error ***')
|
|
call fvi_putln(lunout)
|
|
print *,line(1:l),' < illegal prototype name'
|
|
goto 1
|
|
|
|
99 close(lunin)
|
|
close(lunout)
|
|
end
|
|
|
|
|
|
subroutine fvi_putstr(str)
|
|
|
|
character str*(*)
|
|
integer n
|
|
integer lun
|
|
|
|
character out*132/' '/,num*12
|
|
integer l/0/,i,lunout/2/
|
|
|
|
if (l+len(str) .gt. len(out)-12) then ! let space for an integer number on the same line
|
|
write(lunout,'(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(lun)
|
|
|
|
if (lun .ne. lunout) stop 'MAKE_FVI: lun mismatch'
|
|
if (l .gt. 0) then
|
|
write(lunout,'(a)') out(1:l)
|
|
l=0
|
|
endif
|
|
end
|