# vecmat.tcl --
#     Utilities to manipulate Tcl lists that hold
#     binary data that can directly act as Fortran or C arrays
#
#     TODO: error checking
#

# Vecmat --
#     Namespace to hold these utilities
#
namespace eval ::Vecmat {
    namespace export vector matrix
}

# vector --
#     Utility to manipulate vectors
#
# Arguments:
#     method     Method in question
#     args       Any arguments for the method
#
# Returns:
#     Depends on the method
#
proc ::Vecmat::vector {method args} {

    switch -- $method {
        "create" {
             if { [llength $args] != 1 } {
                 return -code error "Invalid number of arguments - should be: vector create number"
             }
             return [::Vecmat::Vcreate {*}$args]
        }
        "set" {
             if { [llength $args] != 3 } {
                 return -code error "Invalid number of arguments - should be: vector set name index number"
             }
             return [::Vecmat::Vset {*}$args]
        }
        "tolist" {
             if { [llength $args] != 1 } {
                 return -code error "Invalid number of arguments - should be: vector tolist vector-value"
             }
             return [::Vecmat::Vtolist {*}$args]
        }
        "fromlist" {
             if { [llength $args] != 1 } {
                 return -code error "Invalid number of arguments - should be: vector fromlist list"
             }
             return [::Vecmat::Vfromlist {*}$args]
        }
        default {
             return -code error "Unknown method: $method"
        }
    }
}

# Vcreate --
#     Create a vector of doubles of a given length
#
# Arguments:
#     number     Number of elements
#
# Returns:
#     Vector with values initialised to 0.0
#
proc ::Vecmat::Vcreate {number} {

    set data [binary format d* [lrepeat $number 0.0]]
    return [list VECTOR $number $data]
}

# Vset --
#     Set a single element in a vector
#
# Arguments:
#     name       Name of the vector
#     index      Index of the element
#     value      The new value
#
# Returns:
#     Vector with new value at position index
#
# Note:
#     This updates the vector variable whose name is $name
#
proc ::Vecmat::Vset {name index value} {
    upvar 2 $name name_

    set data [lindex $name_ 2]
    set data [binary format a*@[expr {8*$index}]d $data $value]
    lset name_ 2 $data
    return $name_
}

# Vtolist --
#     Convert a vector into a regular Tcl list
#
# Arguments:
#     vector     value of the vector
#
# Returns:
#     List containing the values of the vector
#
proc ::Vecmat::Vtolist {vector} {

    binary scan [lindex $vector 2] d* data
    return $data
}

# Vfromlist --
#     Create a vector from a regular Tcl list of doubles
#
# Arguments:
#     list       list of values to be converted
#
# Returns:
#     Vector containing the values of the list
#
proc ::Vecmat::Vfromlist {list} {

    set data [binary format d* $list]
    return [list VECTOR [llength $list] $data]
}

# main --
#     Test the vector and matrix utilities
#
set v [::Vecmat::vector create 10]

foreach index {0 4} {
    ::Vecmat::vector set v $index [expr {cos($index)}]
}

puts [::Vecmat::vector tolist $v]

set w [::Vecmat::vector fromlist {1.0 .2 3.0}]
puts [::Vecmat::vector tolist $w] 

# autowrap.tcl --
#     Program to automatically generate the wrapfort-style
#     wrapper definitions for LAPACK
#
#     TODO:
#     - input/output arguments
#     - functions
#     - recognizing matrix arguments (dlarrv: matrix z for instance)
#     - exposing the actual interface (workspace and output arguments
#       are not included after all!)
#

# extractInterface --
#     Extract the interface for a LAPACK/BLAS routine
#
# Arguments:
#     filename       Name of the source file to examine
#
# Returns:
#     Description of the interface as a wrapfort command
#
proc extractInterface {filename} {

    set infile [open $filename r]

    #
    # First part: the subroutine/function header
    #
    set header ""
    while {1} {
        gets $infile line
        append header $line
        if { [string first ) $line] >= 0 } {
            break
        }
    }
    set header [string tolower $header]

    #
    # Second part: the description of the arguments
    #
    while { [gets $infile line] >= 0 } {
        if { [regexp {^\* *Arguments} $line] > 0 } {
            gets $infile line
            break
        }
    }

    set arguments {}
    set inputs    {}
    set results   {}
    set count     0

    while { [gets $infile line] >= 0 } {
        if { [string first "======" $line] >= 0 } {
            break
        }

        #
        # Take care of several irregularities in the LAPACK code
        # and of interference with Tcl's list format
        #
        set line [string map {\" "" " - " " "} [string tolower $line]]

        set intent "?"
        regexp {^[^(]*(\([^)]+\))} $line ==> intent
       # puts "Intent: $intent"

        switch -- $intent {
            "(input)" {
                incr count
                set name [lindex $line 1]
                set type [extractType $line]
                lappend arguments [list $type $name input]
            }
            "(output)" {
                incr count
                set name [lindex $line 1]
                set type [extractType $line]
                set size [extractSize $line]
                if { $name != "info" } {
                    if { [string match *array $type] || [string match *matrix $type] } {
                        lappend arguments [list $type $name [list allocate ($size)]]
                    } else {
                        lappend arguments [list $type $name [list assign 0]]
                    }
                    lappend results [list $type $name]
                } else {
                    lappend arguments [list $type $name {assign 0}]
                }
            }
            "(input/ouptut)"            -
            "(input or output)"         -
            "(input/workspace/output)"  -
            "(input / output)"          -
            "(input/output)"            {
                incr count
                set name [lindex $line 1]
                set type [extractType $line]
                set size [extractSize $line]
                lappend arguments [list $type $name input]
                lappend results   [list $type $name]
            }
            "(external procedure)" {
                puts "    External procedure: [string trim $line]"
                incr count
                set name [lindex $line 1]
                set type "external"
                lappend arguments [list $type $name {}]
            }
            "(workspace)" -
            "(workspace/output)" {
                # Note: optional output is ignored
                incr count
                set name [lindex $line 1]
                set type [extractType $line]
                set size [extractSize $line]
                lappend arguments [list $type $name [list allocate $size]]
            }
            default {
                # Ignore
            }
        }
    }

    set results [convertResults $results]

    foreach {routine numberArgs call rtype} [convertHeader $header $arguments $results] {break}

    if { $count != $numberArgs } {
        puts "File: $filename -- not all arguments analysed ($count -- $numberArgs)"
    }

    lappend arguments [list code {} $call]

    return [list [string toupper $routine] [string tolower $routine] $arguments $rtype]
}

# extractType --
#     Extract the data type of an argument
#
# Arguments:
#     line             Line of text describing the argument
#
# Returns:
#     Keyword for wrapfort
#
proc extractType {line} {

    set type "?"

    set dim "?"
    regexp {dimension +(.*)} $line ==> dim
    set dims 1
    if { [string first , $dim] > 0 } {
        set dims 2
    }

    switch -glob -- $line {
        "*integer array*" {
             set type [expr {$dims == 1? "integer-array" : "integer-matrix"}]
        }
        "*integer*" {
             set type "integer"
        }
        "*double precision array*" {
             set type [expr {$dims == 1? "double-array" : "double-matrix"}]
        }
        "*double precision*" {
             set type "double"
        }
        "*real array*" {
             set type [expr {$dims == 1? "real-array" : "real-matrix"}]
        }
        "*real*" {
             set type "real"
        }
        "*character*" {
             set type "string"
        }
        "*logical array*" {
             set type [expr {$dims == 1? "logical-array" : "logical-matrix"}]
        }
        "*logical*" {
             set type "logical"
        }
    }

    return $type
}

# extractSize --
#     Extract the size of an array argument
#
# Arguments:
#     line             Line of text describing the argument
#
# Returns:
#     Size information usable by wrapfort
#
proc extractSize {line} {

    set size "?"

    regexp {dimension (.*)} $line ==> size
    regexp {\((.*)\)} $size ==> size ;# Get rid of the outer parentheses, if any

    if {  [string first , $size] >= 0 &&
         !([string first (max $size] >= 0 || [string first (min $size] >= 0) } {
        set size "sz([string map {" " ""} $size])"
    }

    return $size
}

# convertHeader --
#     Convert the subroutine/function header
#
# Arguments:
#     header           Complete Fortran header
#     arguments        Information about the arguments (types notably)
#     results          Generated code to convert the result variables
#
# Returns:
#     Size information useable by wrapfort
#
proc convertHeader {header arguments results} {

    regexp { ([a-z0-9_]+) *\(} $header ==> routine
    set count [llength [split $header ,]]

    # For now
    set rtype ""

    #
    # Check the individual arguments
    #
    set call     "$routine\("
    set wrapup   ""
    set listargs {}
    set trailer  ""
    foreach arg $arguments {
        foreach {type name size} $arg {break}

        set name [string trimleft $name _]

        switch -glob -- $type {
            "external" -
            "*-array"  -
            "*-matrix" {
                 lappend listargs "$name"
            }
            "string" {
                 lappend listargs "STRING($name)"
                 append  trailer  " STRINGLEN($name)"
            }
            default {
                 lappend listargs "&$name"
            }
        }
        if { $name == "info" } {
            set wrapup "
if ( info != 0 ) {
    Tcl_SetResult( interp, \"Error in $routine\", NULL );
    return TCL_ERROR;
}"
        }
    }

    set call "\n$call [join $listargs ", "] $trailer );\n$results\n$wrapup"

    return [list $routine $count $call $rtype]
}

# convertResults --
#     Convert the list of result variables to code
#
# Arguments:
#     results          List of result variables with their types
#
# Returns:
#     Boiler-plate code to convert the results to a list
#
proc convertResults {results} {

    set number   [llength $results]

    set prologue [string map [list NUMBER $number] "    {
        Tcl_Obj *_result_obj\[NUMBER\];"]

    set epilogue [string map [list NUMBER $number] "
        if ( NUMBER > 1 ) {
            Tcl_SetObjResult( interp, Tcl_NewList( NUMBER, _result_obj ) );
        } else {
            Tcl_SetObjResult( interp, _result_obj\[0\] );
        }
    }"]

    set body ""

    set idx 0
    foreach arg $results {
        foreach {type name} $arg {break}
        switch -glob -- $type {
            "double-array" {
                append body "
        if ( WrapCopyDoubleArrayToList( interp, $name, size__$name, &(result_obj\[$idx\]) ) != TCL_OK ) {
            Tcl_SetResult( interp, \"Can not copy array to Tcl list\", NULL );
        }"
            }
            "double-matrix" {
                append body "
        if ( WrapCopyDoubleMatrixToList( interp, $name, columns__$name, rows__$name, &(result_obj\[$idx\]) ) != TCL_OK ) {
            Tcl_SetResult( interp, \"Can not copy array to Tcl list\", NULL );
        }"
            }
            "integer-array" {
                append body "
        if ( WrapCopyDoubleArrayToList( interp, $name, size__$name, &(result_obj\[$idx\]) ) != TCL_OK ) {
            Tcl_SetResult( interp, \"Can not copy array to Tcl list\", NULL );
        }"
            }
            default {
                append body "/* Unknown type or not yet supported */"
            }
        }

        incr idx
    }

    return "$prologue\n$body\n$epilogue"
}

# main --
#     Get it all going
#
set outfile [open "autowrap_lapack.tcl" w]

foreach file [glob .../lapack/lapack-3.2.1/src/d*.f] {
    puts "File: $file ..."

    foreach {routine cname arguments rtype} [extractInterface $file] {break}

    puts $outfile "\nWrapfort::fproc ::Lapack::$routine $cname {"
    foreach arg $arguments {
        puts $outfile "    $arg"
    }
    puts $outfile "}"
}