# interpfort.tcl --
 #     First attempt to create a kind of Fortran interpreter
 #     Note:
 #     To keep things manageable, it is only a Fortran lookalike
 #     language that this interpreter can handle. But it should
 #     sufficient for scripting purposes: people used to Fortran
 #     can then use a language that looks pretty much like
 #     Fortran.
 #
 #     Limitations:
 #     - You can only define functions right now
 #     - You can not _call_ a function right now
 #     - Support for one-dimensional arrays only
 #     - Arrays will have a different syntax than in Fortran:
 #       array[i,j] instead of array(i,j).
 #     - No exponentiation operator (**)
 #     - No string manipulation, reading/writing files
 #     - Very limited error handling
 #     - Keywords are reserved!
 #

 namespace eval ::InterpFort {

     variable funcname

 }

 # convertFort --
 #     Convert the Fortran like code to valid Tcl
 #
 # Arguments:
 #     code        Code in question
 #
 # Result:
 #     None
 #
 # Side effects:
 #     The functions defined in the code are turned into regular
 #     Tcl procedures
 #
 proc ::InterpFort::convertFort {code} {
     variable funcname

     set newcode {}
     foreach line [split $code \n] {
         set comment [string first "!" $line]
         if { $comment >= 0 } {
             set line [string range $line 0 [expr {$comment-1}]]
         }

         set line [string tolower $line]
         switch -re -- $line {
             {^ *function *} {
                 set line [TreatFunction $line]
             }
             {^ *if *\(} {
                 set line [TreatIf $line]
             }
             {^ *do *} {
                 set line [TreatDo $line]
             }
             {^ *end *do} {
                 set line "\}"
             }
             {^ *end *if} {
                 set line "\}"
             }
             {^ *return} {
                 set line "return \$$funcname"
             }
             {^ *exit} {
                 set line "break"
             }
             {^ *else} {
                 set line "\} else \{"
             }
             {^ *cycle} {
                 set line "continue"
             }
             {^ *end *function} {
                 set line "return \$$funcname\n\}"
             }
             {[a-zA-Z0-9_] *= *[^=]} {
                 set line [TreatAssign $line]
             }
         }
         append newcode "$line\n"
      }

      puts "Code:\n$newcode"

      if { [catch {
               uplevel 1 $newcode
           } msg] } {
          puts "Error during conversion: $msg"
      }
      return
 }


 # TreatFunction --
 #     Convert the function header line to valid Tcl
 #
 # Arguments:
 #     line        Line containing the function keyword
 #
 # Result:
 #     Valid equivalent Tcl code
 #
 proc ::InterpFort::TreatFunction {line} {
     variable funcname

     if { [regexp {function +([a-zA-Z0-9_]+) *\((.+)\)} $line => name arguments] } {

         set funcname $name
         set line "proc $name \{[string map {, " "} $arguments]\} \{"
     } else {
         error "Error converting Fortran function header to Tcl: $line"
     }
     return $line
 }


 # TreatDo --
 #     Convert the do-loop line to valid Tcl
 #
 # Arguments:
 #     line        Line containing the do keyword
 #
 # Result:
 #     Valid equivalent Tcl code
 #
 proc ::InterpFort::TreatDo {line} {

     if { [regexp {do +([a-zA-Z0-9_]+) *= *([^,]+),([^,]+),?(.*)} \
              $line => var begin end step] } {
         if { $step == "" } {
             set step 1
         }
         set line "for {set $var \[expr {$begin}\]} {\$$var <= $end} \
                   {incr $var \[expr {$step}\]} \{"
     } else {
         error "Error converting Fortran do-loop to Tcl: $line"
     }
     return $line
 }


 # TreatIf --
 #     Convert an if statement to valid Tcl
 #
 # Arguments:
 #     line        Line containing an if statement
 #
 # Result:
 #     Valid equivalent Tcl code
 #
 proc ::InterpFort::TreatIf {line} {

     regsub {if *\(} $line "" line
     regsub {\) *then} $line "" line

     set line [TreatExpression $line]

     set line "if \{ $line \} \{"

     return $line
 }


 # TreatAssign --
 #     Convert an assignment to valid Tcl
 #
 # Arguments:
 #     line        Line containing an assignment
 #
 # Result:
 #     Valid equivalent Tcl code
 #
 proc ::InterpFort::TreatAssign {line} {

     set part [string first = $line]

     set var        [string trimleft [string range $line 0 [expr {$part-1}]]]
     set expression [string trimleft [string range $line [expr {$part+1}] end]]

     #
     # No function calls or arrays yet ...
     #
     set expression [TreatExpression $expression]

     set line "set $var \[expr \{$expression\}\]"

     return $line
 }


 # TreatExpression --
 #     Convert an expression to valid Tcl
 #
 # Arguments:
 #     line        Line containing an expression
 #
 # Result:
 #     Valid equivalent Tcl code
 #
 proc ::InterpFort::TreatExpression {line} {

     #
     # Insert the $ for each substring that _might_ be a variable name
     #
     regsub -all {([a-zA-Z_][a-zA-Z0-9_]*)} $line {$\1} line

     #
     # Correct the cases where it is not
     #
     regsub -all {([0-9.])\$e} $line {\1e} line
     regsub -all {\$([a-zA-Z_][a-zA-Z0-9_]*)\(} $line {\1(} line

     return $line
 }

 # main --
 #     Test and sample usage
 #
 ::InterpFort::convertFort {
     function cowboy(x,y)
         r2 = x*x + y*y
         cowboy = (1.0 - r2)*(1.0 - r2)
     end function

     !
     ! This is a slightly more complicated function:
     ! It determines the root of:
     !
     ! exp(y)+y = x
     !
     ! using a Picard iteration.
     !
     ! Note: 
     ! This does not work for x>0 - no conversion.
     ! I should instead use Newton-Raphson
     !
     function invexp(x)
         y = x
         if ( x > 0.0 ) then
             y = 0.5 * x
         endif
         yold = -1.0e20
         do i = 1,20
             if ( abs(yold-y) < 1.0e-6 ) then
                 exit
             endif

             yold = y
             if ( y <= 0 ) then
                 y = x-exp(y)
             else
                 y = log(x-y)
             endif
             #puts $y  ! Yes, you can use Tcl commands ;)
         enddo
         invexp = y
     end function
 }

 for {set i 0} {$i < 20 } {incr i} {
    set x [expr {$i*0.1}]
    set y [expr {$i*0.2-0.5}]
    puts "Cowboy: [cowboy $x $y]"
 }
 for {set i 0} {$i < 20 } {incr i} {
    set x [expr {-$i*0.1}]
    puts "$x [invexp $x]"
 }