;+ ; NAME: ; f2idl ; PURPOSE: (one line) ; write idl wrapper ; DESCRIPTION: ; write idl wrapper _w.pro from fortran file ; CATEGORY: ; util ; CALLING SEQUENCE: ; f2idl, forfunc, fileroot = fileroot ; INPUTS: ; forfunc - name in original fortran code ; OPTIONAL INPUT PARAMETERS: ; fileroot - root filename s.t. ; forfile = .f - file with original fortran code ; cfile = _c.f - file with f2c code ; docfile = .f or _d.f - file with extra documentation ; sofile - name of the shared object (so) file ; KEYWORD INPUT PARAMETERS: ; none ; KEYWORD OUTPUT PARAMETERS: ; none ; OUTPUTS: ; none ; COMMON BLOCKS: ; None ; SIDE EFFECTS: ; Writes idlfile wrapper ; idlfile = _w.pro ; RESTRICTIONS: ; (1) FORFILE - FORTRAN FILE ; Must contain lines starting ; ' FUNCTION* *'+forfunc+'*' or ; ' SUBROUTINE* *'+forfunc+'*' or ; ; (2) CFILE ; normally the output of f2c ; This is parsed to get the types of the parameters ; ; (3) DOCFILE ; Has legal FORTRAN comment lines of the form ;C STARTDOC ;C : ;C ;C ENDDOC ; Catagories are 'PURPOSE', 'CATAGORY', 'CALLING SEQUENCE',$ ; 'INPUTS', 'OPTIONAL INPUTS', 'KEYWORD PARAMETERS', $ ; 'OUTPUTS', 'OPTIONAL OUTPUTS', 'COMMON BLOCKS', $ ; 'SIDE EFFECTS', 'RESTRICTIONS', 'PROCEDURE', $ ; 'EXAMPLE', 'MODIFICATION HISTORY' ; The OUTPUTS doc lines are used to preset variables to be the proper ; format (type, dimension) before they are passed to the fortran ; routine. For example, in init_zm.f ;C ------------------- ;C STARTDOC INIT_ZM ;C PURPOSE: Return initial altitudes ;C CALLING SEQUENCE: init_zm, zm, km, delz0, fac1 ;C INPUTS: ;C km - number of layers ;C DELZ0 - delta z of the lowest layer (m) ;C FAC1 - factor by which to increase successive layers ;C OUTPUTS: zm - altitude [m, km array] ;C MODIFICATION HISTORY: Written 2007 Feb 7, LAY ;C ENDDOC INIT_ZM ;C ------------------- ; is used to make the following lines in init_zm.pro ;;------------------------- ;; setup the output variables that will be passed to the fortran ;; routine ; ; ZM = make_array(KM,type= 5) ; ; PROCEDURE: ; From the fortran file, get: ; - whether this is a function or procedue (subroutine) ; - names and order of all arguments ; - rank (eg scaler, 1-D array, 2-D matrix) of all arguments ; - string with dimensions of all arguments ; From the C file, get: ; - return type, if a function ; - type (integer, doublereal) of all arguments ; MODIFICATION HISTORY: ; Written 2007 Feb 7, LAY ; 2008 Nov 9 LAY. ; - changed search in forfunc to allow more than 6 spaces before ; FUNCTION or SUBROUTINE ; 2007 Aug 20 LAY. ; - expanded documentation ; - changed outer loop index from idim to idiml to avoid ; name conflict in the dimension and rank loop ; - change how we split variables in the fortran dimension ; statements to deal with mutli-dimensioned arrays (with ; commas inside the parantheses) ; - in idl output, use array_equal rather than eq to check proper ; dimensions of 2-d arrays ; 2007 Aug 28 LAY. ; - correct return types for functions ; 2007 Aug 31 LAY ; - change integer type from 2 (integer) to 3 (longword integer) ;- pro f2idl, forfunc, fileroot=fileroot, sofile=sofile ; SET THE FILE ROOT if not keyword_set(fileroot) then begin fileroot = forfunc endif ; SET THE SHARED OBJECT FILE if not keyword_set(sofile) then begin cd, current = cwd sofile = file_basename(cwd) endif if strmatch(sofile, '*.so') then begin soroot = strmid(sofile, 0, strlen(sofile)-3) endif else begin soroot = sofile endelse sofn = soroot+'.so' ;============================== ; FIND THE FUNCTION IN forfile ; AND READ FROM FUNCTION or SUBROUTINE ; TO END INTO FORLINES forfile = fileroot + '.f' if not isfile(forfile) then begin print, 'f2idl: ', forfile, ' does not exist' return endif line = ' ' forlines = [' '] openr, forlun, forfile, /get_lun done = 0 func = 0 proc = 0 while done eq 0 and not eof(forlun) do begin readf, forlun, line if strmatch(strtrim(line,2),'FUNCTION* *'+forfunc+'*', /fold) then begin func = 1 forlines = [line] done = 1 endif if strmatch(strtrim(line,2),'SUBROUTINE* *'+forfunc+'*', /fold) then begin proc = 1 forlines = [line] done = 1 endif endwhile if eof(forlun) then begin print, 'f2idl: Function or subroutine ', forfunc, ' not found in ', forfile close, forlun & free_lun, forlun return endif done = 0 while done eq 0 and not eof(forlun) do begin readf, forlun, line forlines = [forlines,line] if strmatch(line,'*END *', /fold) or $ strmatch(line,'*END', /fold) then begin done = 1 endif endwhile close, forlun & free_lun, forlun ;================================ ; split forlines into the parameters in the function ; or subroutine heading ; Get the complete function of subroutine header line, ; even if it continues over several lines forhead = forlines[0] ; done = 0 i = 1 contpref = ' &' contlen = strlen(contpref) while done eq 0 do begin next = forlines[i] if strmatch(next,contpref+'*') then begin forhead = forhead + strmid(next, contlen, strlen(next)-contlen) i = i + 1 endif else begin done = 1 end end ; location of ( and ) openparen = strpos(forhead, '(') closeparen = strpos(forhead, ')') ; check for zero-length argument list if (openparen eq -1 and closeparen eq -1) or $ (closeparen eq openparen + 1) then begin fornarg = 0 endif else begin forargstr = strmid(forhead, openparen+1, closeparen-openparen-1) forarg = strtrim(strsplit(forargstr, ',', /extract),2) fornarg = n_elements(forarg) endelse ; get parameters forparvar = [' '] forparval = [' '] parlineindx = where(strmatch(forlines,' PARAMETER*'), nparline) if nparline eq 0 then begin npar = 0 endif else begin for ipar = 0, nparline-1 do begin i = parlineindx[ipar] forpar = forlines[i] done = 0 i = i + 1 ; glom continued lines onto the parameter line while done eq 0 do begin next = forlines[i] if strmatch(next,contpref+'*') then begin forpar = forpar + strmid(next, contlen, strlen(next)-contlen) i = i + 1 endif else begin done = 1 endelse endwhile ; get the part between the parantheses openparen = strpos(forpar, '(') closeparen = strpos(forpar, ')') forpar = strmid(forpar, openparen+1, closeparen-openparen-1) forparvv = strtrim(strsplit(forpar, ',', /extract),2) ; vv for var,val nparvv = n_elements(forparvv) for iparvv = 0, nparvv-1 do begin tok = strtrim(strsplit(forparvv[iparvv], '=', /extract),2) forparvar = [forparvar, tok[0]] forparval = [forparval, tok[1]] endfor endfor npar = n_elements(forparvar) forparvar = forparvar[1:npar-1] forparval = forparval[1:npar-1] npar = npar - 1 endelse ; get dimensions and ranks ; DIMENSION lines may be more than 1 line (eg ZTPRN) if fornarg ne 0 then begin fordimstr = strarr(fornarg) forrank = intarr(fornarg) dimlineindx = where(strmatch(forlines,' DIMENSION*'), ndimline) for idiml = 0, ndimline-1 do begin ; get dimension statement idim i = dimlineindx[idiml] fordim = forlines[i] done = 0 i = i + 1 ; glom continued lines onto the dimension line while done eq 0 do begin next = forlines[i] if strmatch(next,contpref+'*') then begin fordim = fordim + strmid(next, contlen, strlen(next)-contlen) i = i + 1 endif else begin done = 1 endelse endwhile ; strip off the dimension statement itself dimlen = strlen(' DIMENSION') fordim = strmid(fordim, dimlen, strlen(fordim)-dimlen) fordim = strcompress(fordim, /remove_all) ; If there are two or more dimensions, then the comma ; separated dimensions and arguments both. ; So, change comma-separated arguments into ; slash separated arguments fordim = repstr(fordim,'),',')/') ; split it into separate dimension statements dims = strsplit(fordim, '/', /extract) ndim = n_elements(dims) for idim = 0, ndim-1 do begin dim = dims[idim] openparen = strpos(dim, '(') closeparen = strpos(dim, ')') dimarg = strtrim(strmid(dim,0,openparen), 2) dimstr = strmid(dim,openparen+1, closeparen-openparen-1) dimstrarr = strtrim(strsplit(dimstr,',', /extract),2) iarg = where( strmatch(forarg, dimarg, /fold), count) if count eq 1 then begin fordimstr[iarg] = dimstr forrank[iarg] = n_elements(dimstrarr) endif endfor endfor ; forprint, forarg, forrank, fordimstr end ;============================== ; FIND THE FUNCTION IN cfile ; ; CHECK IF C FILE EXISTS. IF NOT, MAKE IT. cfile = fileroot + '_f.c' if not isfile(cfile) then begin makecmd = 'make ' + cfile print, 'f2idl: ', cfile, ' not found.' print, ' executing: ', makecmd spawn, makecmd if not isfile(cfile) then begin print, ' ', makecmd, 'failed to make ', cfile, '. Exiting f2idl' return endif endif ; GET THE FUNCTION NAME IN C ; F2C appends one underscore normally, two if there is already an ; underscore in the fortran function name if strmatch(forfunc,'*_*') then begin cpost = '__' endif else begin cpost = '_' endelse cfunc = forfunc + cpost ; LOOK FOR ROUTINE IN CFILE openr, clun, cfile, /get_lun done = 0 cfunctype = '' while done eq 0 and not eof(clun) do begin readf, clun, line if proc then begin if strmatch(line,'/* Subroutine */ int '+cfunc+'*', /fold) then begin clines = [line] done = 1 endif endif if func then begin if strmatch(line,'doublereal '+cfunc+'(*', /fold) then begin cfunctype = 'doublereal' clines = [line] done = 1 endif if strmatch(line,'integer '+cfunc+'(*', /fold) then begin cfunctype = 'integer' clines = [line] done = 1 endif endif endwhile if func then begin case cfunctype of 'integer': cfunctypecode = 3 'doublereal': cfunctypecode = 5 else: begin print, 'f2idl: function return type not recognized' print, ' ' + line return end endcase end if eof(clun) then begin print, 'f2idl: Function or subroutine ', cfunc, ' not found in ', cfile close, clun & free_lun, clun return endif done = 0 while done eq 0 and not eof(clun) do begin readf, clun, line if strmatch(line,'*{*', /fold) then begin done = 1 endif else begin clines = [clines,line] endelse endwhile close, clun & free_lun, clun ; Get the function name and argument list ; Since this is the output of f2c, it's easy -- ; it's just the clines concatinated chead = strjoin(clines) openparen = strpos(chead, '(') closeparen = strpos(chead, ')') ; check for zero-length argument list if (openparen eq -1 and closeparen eq -1) or $ (closeparen eq openparen + 1) then begin cnarg = 0 endif else begin cargstr = strmid(chead, openparen+1, closeparen-openparen-1) if cargstr eq 'void' then begin cnarg = 0 endif else begin ctypearg = strtrim(strsplit(cargstr, ',', /extract),2) cnarg = n_elements(ctypearg) if cnarg ne fornarg then begin print, 'f2idl: argument count differs between ', $ forfunc, ' in ', forfile, $ 'and ', cfunc, ' in ', cfile return endif carg = strarr(cnarg) ctype = strarr(cnarg) ctypecode = strarr(cnarg) for iarg = 0, cnarg-1 do begin if strpos(ctypearg[iarg],'*') eq -1 then begin print, 'f2idl: badly formed argument ', ctypearg[iarg], $ ' for function ', cfunc, ' in ', cfile return end tok = strtrim(strsplit(ctypearg[iarg],'*',/extract), 2) if n_elements(tok) ne 2 then begin print, 'f2idl: badly formed argument ', ctypearg[iarg], $ ' for function ', cfunc, ' in ', cfile return end ctype[iarg] = tok[0] carg[iarg] = tok[1] if not strmatch(carg[iarg], forarg[iarg], /fold) and $ not strmatch(carg[iarg], forarg[iarg]+'_', /fold) and $ not strmatch(carg[iarg], forarg[iarg]+'__', /fold) then begin print, 'f2idl: argument ', iarg, $ ' is ', forarg[iarg], ' for ', forfunc, ' in ', forfile, ' but ',$ carg[iarg], ' for ', cfunc, ' in ', cfile return endif case ctype[iarg] of 'integer': ctypecode[iarg] = 3 'doublereal': ctypecode[iarg] = 5 else: begin print, 'f2idl: type ', ctype[iarg], ' not recognized' return end endcase endfor endelse endelse ;============================== ; FIND THE FILE WITH DOCUMENTATION ; if isfile(fileroot + '_d.f') then begin docfile = fileroot + '_d.f' endif else begin docfile = forfile endelse docfunc = forfunc line = ' ' doclines = [' '] openr, doclun, docfile, /get_lun done = 0 doc = 0 while done eq 0 and not eof(doclun) do begin readf, doclun, line if strmatch(line,'C*STARTDOC*'+docfunc+'*', /fold) then begin done = 1 doc = 1 ; yes, there is documentation endif endwhile if eof(doclun) then begin close, doclun & free_lun, doclun endif else begin done = 0 while done eq 0 and not eof(doclun) do begin readf, doclun, line if strmatch(line,'C*ENDDOC*'+docfunc+'*', /fold) then begin done = 1 endif else begin doclines = [doclines,strmid(line,6,strlen(line)-6)] endelse endwhile close, doclun & free_lun, doclun endelse ; parse the doc lines ndoc = n_elements(doclines) docsecnames = strarr(ndoc) ; documentation section names docinfo = strarr(ndoc) ; documentation information lastsecname = '' for idoc = 0, ndoc-1 do begin docline = doclines[idoc] colon = strpos(docline,':') if colon eq -1 then begin docsecnames[idoc] = lastsecname docinfo[idoc] = docline endif else begin lastsecname = strtrim(strmid(docline,0,colon), 2) docsecnames[idoc] = lastsecname docinfo[idoc] = strtrim(strmid(docline,colon+1,strlen(docline)-colon-1),2) endelse endfor ;============================== ; IDLFILE ; ; idlfile = forfunc + '.pro' idlfunc = soroot + '_' + forfunc idlfile = idlfunc + '.pro' openw, idllun, idlfile, /get_lun, width=132 printf, idllun, '; '+idlfile+' -- translated by f2idl' printf, idllun, '; using argument information from ', forfile, ' and ', cfile printf, idllun, '; and documentation information from ', docfile printf, idllun, '' printf, idllun, ';+' printf, idllun, '; NAME:' ; printf, idllun, '; ' + forfunc printf, idllun, '; ' + idlfunc printf, idllun, '; ' ; print the following doc sections in order, ; keeping track of what lines we've printed, ; then print the rest. docprinted = intarr(ndoc) stdsecnames = ['PURPOSE', 'CATAGORY', 'CALLING SEQUENCE',$ 'INPUTS', 'OPTIONAL INPUTS', 'KEYWORD PARAMETERS', $ 'OUTPUTS', 'OPTIONAL OUTPUTS', 'COMMON BLOCKS', $ 'SIDE EFFECTS', 'RESTRICTIONS', 'PROCEDURE', $ 'EXAMPLE', 'MODIFICATION HISTORY' ] nstdsecnames = n_elements(stdsecnames) for istd = 0, nstdsecnames - 1 do begin stdsecname = stdsecnames[istd] infoindx = where(docsecnames eq stdsecname, ninfo) if ninfo gt 0 then begin printf, idllun, '; '+stdsecname+':' for iinfo = 0, ninfo-1 do begin printf, idllun, '; ' + docinfo[infoindx[iinfo]] endfor docprinted[infoindx] = 1 endif else begin if stdsecname eq 'CALLING SEQUENCE' then begin if func then begin ; callseq = 'res = ' + forfunc + '(' callseq = 'res = ' + idlfunc + '(' for iarg = 0, fornarg-1 do begin callseq = callseq + forarg[iarg] if iarg lt fornarg-1 then begin callseq = callseq + ',' endif endfor callseq = callseq + ')' endif else begin ; callseq = forfunc callseq = idlfunc for iarg = 0, fornarg-1 do begin callseq = callseq + ','+forarg[iarg] endfor endelse printf, idllun, '; CALLING SEQUENCE:' printf, idllun, '; ' + callseq printf, idllun, '; ' endif endelse endfor toprintindx = where(docprinted eq 0, count) if count ne 0 then begin docsecnames2 = docsecnames[toprintindx] docinfo2 = docinfo[toprintindx] othersecnames = docsecnames2[uniq(docsecnames2)] nothersecnames = n_elements(othersecnames) for iother = 0, nothersecnames - 1 do begin othersecname = othersecnames[iother] infoindx = where(docsecnames2 eq othersecname, ninfo) if ninfo gt 0 then begin printf, idllun, '; '+othersecname+':' for iinfo = 0, ninfo-1 do begin printf, idllun, '; ' + docinfo2[infoindx[iinfo]] endfor endif endfor end printf, idllun, ';-' if func then begin module = 'FUNCTION ' endif else begin module = 'PRO ' endelse ; module = module + forfunc module = module + idlfunc for iarg = 0, fornarg-1 do begin module = module + ','+forarg[iarg] endfor printf, idllun, module printf, idllun, ' ' q = ''' printf, idllun, '; -------------------- This function name' printf, idllun, '' ; printf, idllun, " fcn = '", forfunc,"'" printf, idllun, " fcn = '", idlfunc,"'" printf, idllun, '' printf, idllun, '; -------------------- assign parameters (including dimensions)' if npar ge 0 then begin for ipar = 0, npar-1 do begin printf, idllun, forparvar[ipar], ' = ', forparval[ipar] endfor endif printf, idllun, '' printf, idllun, ';-------------------------' printf, idllun, '; setup the output variables that will be passed to the fortran' printf, idllun, '; routine' printf, idllun, '' outdocindx = where( strmatch(docsecnames, 'OUTPUTS',/fold), noutdoc) if noutdoc ne 0 then begin outinfo = docinfo[outdocindx] for iarg = 0, fornarg - 1 do begin arg = forarg[iarg] if total(strmatch(outinfo,arg+' - *', /fold)) gt 0 then begin typecode = ctypecode[iarg] if forrank[iarg] eq 0 then begin valstr = (['none','0b','0','0L','0.','0.d',$ 'complex','string','struct','dcomplex','pointer',$ 'objref','uint','ulong','long64','ulong64'])[typecode] endif else begin valstr = 'make_array('+fordimstr[iarg]+',type='+$ string(typecode)+')' endelse printf, idllun, ' ',arg,' = ', valstr endif endfor endif printf, idllun, '' printf, idllun, ';-------------------------' printf, idllun, '; check all variables' if func then rtnstr = 'return, 0' else rtnstr = 'return' printf, idllun, ' if n_params() ne ',string(fornarg), ' then begin' ; printf, idllun, ' print,', q,forfunc,': wrong number of arguments',q printf, idllun, ' print,', q,idlfunc,': wrong number of arguments',q printf, idllun, ' ', rtnstr printf, idllun, ' endif' for iarg = 0, fornarg - 1 do begin arg = forarg[iarg] type = ctype[iarg] case type of 'integer': typecode = 3 'doublereal': typecode = 5 else: begin print, 'f2idl: type ', type, ' not recognized' return end endcase printf, idllun, ' if size(',arg,',/type) ne ', string(typecode), ' then begin' printf, idllun, ' print,', q,idlfunc,': ',arg, ' of wrong data type',q printf, idllun, ' ', rtnstr printf, idllun, ' endif' rank = forrank[iarg] printf, idllun, ' if size(',arg,',/n_dim) ne ', string(rank), ' then begin' printf, idllun, ' print,', q,idlfunc,': ',arg, ' of wrong n_dim',q printf, idllun, ' ', rtnstr printf, idllun, ' endif' if rank gt 0 then begin dim = '[' + fordimstr[iarg] + ']' ; printf, idllun, ' if size(',arg,',/dim) ne ', dim, ' then begin' printf, idllun, ' if not array_equal(size(',arg,',/dim), ', dim, ' ) then begin' printf, idllun, ' print,', q,idlfunc,': ',arg, ' of wrong dim',q printf, idllun, ' ', rtnstr printf, idllun, ' endif' endif endfor printf, idllun, '' printf, idllun, ';-------------------------' printf, idllun, '; Find root directory for library tname' printf, idllun, ' findpro, fcn, dirlist=dirlist, /noprint' printf, idllun, " if dirlist[0] eq '' then root = '.' else root = dirlist[0]" ; printf, idllun, ';-------------------------' ; printf, idllun, '; cd to root directory' ; printf, idllun, " datadir = root " ; printf, idllun, ' CD, datadir, CURRENT=PWD ; printf, idllun, '' printf, idllun, ';-------------------------' printf, idllun, '; CALL' printf, idllun, " lib_name = root + '/"+sofn+"'" ; printf, idllun, " entry_name = '"+soroot+"_" + cfunc + "'" printf, idllun, " entry_name = 'idl_ce_call_" + cfunc + "'" printf, idllun, ' RESULT = CALL_EXTERNAL( lib_name, ENTRY_NAME, $' if fornarg gt 0 then begin printf, idllun, ' ', forargstr, ', $' endif if func eq 1 then begin printf, idllun, ' ', 'return_type = ', cfunctypecode, ', $' endif printf, idllun, ' /verbose )' printf, idllun, '' ; printf, idllun, ';-------------------------' ; printf, idllun, '; cd to original directory' ; printf, idllun, ' cd, pwd' ; printf, idllun, '' if func eq 1 then begin printf, idllun, 'return, RESULT' endif printf, idllun, 'end' close, idllun & free_lun, idllun end