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