;+
; NAME:
;  f2idl_b
; PURPOSE: (one line)
;  write idl wrapper
; DESCRIPTION:
;  write idl wrapper <name>_w.pro from fortran file
; CATEGORY:
;  util
; CALLING SEQUENCE:
;  f2idl_b, 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
; 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
;  (a) Must contain lines starting
;  '      FUNCTION* *'+forfunc+'*' or
;  '      SUBROUTINE* *'+forfunc+'*' or
;  
;  (2) CFILE
;  (a) if forfile = 
; 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
;  2007 Aug 28 LAY.  
;  - correct return types for functions
;  2007 Aug 31 LAY
;  - change integer type from 2 (integer) to 3 (longword integer)
;  2007 Sep 1 LAY
;  - repair printing of asignment of non-parameter dimensions
;    for multi-dimesional arguments
;  2007 Sep 2 LAY
;  - repair printing of asignment of non-parameter dimensions
;    for multi-dimesional arguments
;-

pro f2idl_b, forfunc, fileroot=fileroot

    ; SET THE FILE ROOT
    if not keyword_set(fileroot) then begin
        fileroot = forfunc
    endif

    ;==============================
    ; 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 idiml
            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
    proc = 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 + '_b.pro'
    openw, idllun, idlfile, /get_lun, width=132

    printf, idllun, '; '+idlfile+' -- translated by f2idl_b'
    printf, idllun, '; using argument information from ', forfile, ' and ', cfile

    q = '''

    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, '; -------------------- assign non-parameter dimensions (to 2)'
    if fornarg gt 0 then begin
        dimarg = intarr(fornarg) ; keep track of which arguments are
                                ; dimensions, and are printed out in
                                ; this step, and should not be printed later
        iarr = where(forrank ne 0, narr)
        if narr gt 0 then begin
            arrdim = fordimstr[0]
            for iarg = 1, fornarg-1 do arrdim = arrdim + ','+fordimstr[iarg]
            arrdim = strsplit(arrdim, ',', /extract, preserve_null=0)
            ;arrdim = arrdim[iarr[uniq(arrdim)]]
            arrdim = arrdim[uniq(arrdim)]
            narrdim = n_elements(arrdim)
            for iarrdim = 0, narrdim-1 do begin
                ; check it's not a parameter
                if npar gt 0 then begin
                    imatch = where(arrdim[iarrdim] eq forparvar,nmatch)
                endif else begin
                    nmatch = 0
                endelse
                if nmatch eq 0 then begin
                    printf, idllun, arrdim[iarrdim], '  = 2'
                endif 
                ; get which argument it is, and mark that as printed
                imatch = where(arrdim[iarrdim] eq forarg,nmatch)
                if nmatch gt 0 then dimarg[imatch] = 1
            endfor ; iarrdim 
        endif ;narr gt 0
    endif ; fornnarg gt 0 then
    printf, idllun, ';-------------------------'
    printf, idllun, '; setup the variables that will be passed to the fortran'
    printf, idllun, '; routine'
    printf, idllun, ''
    for iarg = 0, fornarg - 1 do begin
        arg = forarg[iarg]
        typecode = ctypecode[iarg]
        ; change default integer and long values to 2
        ; since these may also be dimensios
        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
        if dimarg[iarg] eq 0 then begin
            printf, idllun, '    ',arg,' = ', valstr
        endif else begin
            if typecode eq 3 then begin
                printf, idllun, '    ',arg,' = 2L'
            endif
            if typecode eq 2 then begin
                printf, idllun, '    ',arg,' = 2'
            endif
            if typecode ne 2 and typecode ne 3 then begin
                print, 'f2idl_b: ',arg,' illegal type for dimension'
                return
            endif
        endelse
    endfor
    printf, idllun, ''

    printf, idllun, ';-------------------------'
    printf, idllun, '; CALL'
    printf, idllun, "    lib_name = ' '"
    printf, idllun, "    entry_name = '", 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, "        write='",forfunc,"_b.c' )"
    printf, idllun, ''

    close, idllun & free_lun, idllun
    
end