linse/fit
0
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial commit

Browse Source
This commit is contained in:
zolliker
2022-08-19 15:22:33 +02:00
commit d682fae506
545 changed files with 48172 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

274
gen/make_fvi.f Normal file
View File

@@ -0,0 +1,274 @@
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