;+
; NAME:
;  f2idl
; PURPOSE: (one line)
;  write idl wrapper
; DESCRIPTION:
;  write idl wrapper <name>_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 = <fileroot>.f - file with original fortran code
;   cfile = <fileroot>_c.f - file with f2c code
;   docfile = <fileroot>.f or <fileroot>_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 = <fileroot>_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 <FUNC>
;C     <catagory>: <doc lines>
;C     <more doc lines under the same catagory>
;C     ENDDOC <FUNC>
;  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
;  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 sofn = sofile else sofn = sofile+'.so'

    ;==============================
    ; FIND THE FUNCTION IN forfile
    ; AND READ FROM FUNCTION <forfunc> or SUBROUTINE <forfunc>
    ; 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(line,'      FUNCTION* *'+forfunc+'*', /fold) then begin
            func = 1
            forlines = [line]
            done = 1
        endif
        if strmatch(line,'      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'
    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, '; '

    ; 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 + '(' 
                    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
                    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
    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, ''

    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, '        ', 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,forfunc,': ',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,forfunc,': ',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,forfunc,': ',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 + '/../zhu-f'"
;    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 = '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