# DOC
#
# testmake.tcl - Tcl script to make automatic test programs
#
# Copyright (C) 2001 Arjen Markus
#
#
# General information:
# The script reads the reports generated by the McCabe toolset
# and generates tests that will exercise all or part of the
# test paths indicated.
# It is limited in the sense that it will try to identify
# only those paths that are influenced by externally modifiable
# variables. This in practice means that a lot of paths, especially
# those concerned with I/O may be left out.
#
# The generated program, however, mentions this.
#
# Assumptions:
# - the test paths are described in a file called $1.testpaths
# - the data used by the module are found in a file called $1.data
#   ($1 being the first argument)
# - the name of the module is $2 (the second argument)
# - for the actual declaration of the parameters etc. there are
#   code fragments available, in the file testmake.code. This file
#   is sourced from the current directory.
#
# ENDDOC
#
#  $Author$
#  $Date$
#  $Source$
#
# --------------------------------------------------------------------
#   Procedure: GetModules
#   Author:    Arjen Markus
#   Purpose:   Source the file with the module(s)
#   Context:   Used by the main code
#   Summary:
#              Read the file with modules. Make sure nothing gets
#              inadvertently executed (by replacing [ and ] by \[
#              and \], if in a Module statement.
#   Arguments:
#   default    Name of the default file to be sourced
#   filename   Name of the file to be sourced (if given; extension
#              is "module")
# --------------------------------------------------------------------
#
proc GetModules { default filename } {

   if { [catch { set infile [open "${filename}.module" "r"] }] != 0 } {
      set infile   [open "$default" "r"]
      puts "Module file: $default"
   } else {
      puts "Module file: ${filename}.module"
   }
   set all_data [read $infile]
   close $infile

   #
   # Make sure sequences like "int [10]" do not cause problems
   # when eval-ing the file's contents. This is more involved
   # than one might think, and the escapes make it really messy.
   #

   regsub -all {"([^\["\{]*)\[([^\]"\{]*)\]([^"\{]*)"} $all_data \
      {"\1\[\2\]\3"} all_data

   eval $all_data
}

#
# --------------------------------------------------------------------
#   Procedure: GetArguments
#   Author:    Arjen Markus
#   Purpose:   Get the names of the dummy arguments
#   Context:   Used by the main code
#   Summary:
#              Read the .data file line by line. Store all names
#              that are indicated as parameter.
#   Arguments:
#   filename   Root name of the file to be scanned
# --------------------------------------------------------------------
#
proc GetArguments { filename } {
   global module_data
   upvar #0 $module_data params
   global template

   set    fullname $filename
   append fullname ".data"

   if { [ catch { set infile [ open $fullname "r" ] } msg ] == 0 } {
      while { [ gets $infile line ] >= 0 } {

         set varname  [ lindex  $line 0     ]
         set declared [ lindex  $line end   ]
         set no_elems [ llength $line       ]
         set vartype  [ lindex  $line [expr $no_elems-2] ]

         if { $declared == "parameter" } {
            if { [ lsearch $params(all) $varname ] <= -1 } {
               lappend params(all) $varname
            }
            GenerateDefinition $varname $vartype
         }
      }
      close $infile
   } else {
      puts "Note:"
      puts "   No file with data usage report: $fullname"
      puts "   Relying on information in the module definition instead"
   }
   return
}

# --------------------------------------------------------------------
#   Procedure: GenerateDefinition
#   Author:    Arjen Markus
#   Purpose:   Write the code for defining a parameter
#   Context:   Used by CheckPaths
#   Summary:
#              Write an entry in the template file that more or less
#              defines the variable - except for the initial value.
#   Arguments:
#   varname    Name of the parameter in the module's header
#   vartype    Type of the variable (according to McCabe, may not be
#              totally accurate, but it is a start
# --------------------------------------------------------------------
#
proc GenerateDefinition { varname vartype } {
   global module_data
   upvar #0 $module_data fragments
   global outfile
   global template

   if { ! [info exists fragments($varname,initcode)] } {
      puts $template "   Input? \"$varname\" \"$vartype\" \{"
      puts $template "      $varname = ..."
      puts $template "   \}"

      set fragments($varname,initcode)  "  $varname = ..."
      set fragments($varname,checkcode) ""
      set fragments($varname,type)     "in/out"
      set fragments($varname,vartype)  $vartype
   }

   return
}

# --------------------------------------------------------------------
#   Procedure: GenerateCondition
#   Author:    Arjen Markus
#   Purpose:   Write the code for this particular condition
#   Context:   Used by CheckPaths
#   Summary:
#              Check if for this expression and this particular value
#              some code has been defined. Write out the code.
#              Otherwise log the condition in the template.
#   Arguments:
#   expression Logical expression to be satisfied
#   logvalue   Required value
#   varname    Associated parameter
#   lineno     Line number in the module's source code
# --------------------------------------------------------------------
#
proc GenerateCondition { expression logvalue varname lineno } {
   global module_data
   upvar #0 $module_data fragments
   global outfile
   global tmpfile
   global template

   if { [info exists fragments($expression,$logvalue)] } {
      puts $outfile "! Condition: $expression ===> $logvalue (at line $lineno)"
      puts $outfile "   $fragments($expression,$logvalue)"
      puts $tmpfile "   $fragments($expression,$logvalue,checkcode)"
   } else {
      puts $outfile "! Condition: $expression ===> $logvalue (at line $lineno)"
      puts $outfile "      $varname = ..."
      puts $template "   Condition \"$expression\" $logvalue \{"
      puts $template "      $varname = ..."
      puts $template "   \} { ... specific check }"

      set fragments($expression,$logvalue) "? Unknown"
      set fragments($expression,$logvalue,checkcode) ""
   }

   return
}

# --------------------------------------------------------------------
#   Procedure: CopyChecks
#   Author:    Arjen Markus
#   Purpose:   Copy the check code into the source file
#   Context:   Used by CheckPaths
#   Summary:
#              Rewind the temporary file that contains the check code.
#              Copy its contents into the source file.
#   Arguments:
#              -- none --
# --------------------------------------------------------------------
#
proc CopyChecks { } {
   global outfile
   global tmpfile

   seek $tmpfile 0 start

   while { [ gets $tmpfile inline ] > -1 } {
      puts $outfile $inline
   }

   return
}

# --------------------------------------------------------------------
#   Procedure: Fragment
#   Author:    Arjen Markus
#   Purpose:   Define a code fragment
#   Context:   Used in the configuration file
#   Summary:
#              Set the array element to the given code fragment.
#   Arguments:
#   codename   Name of the code fragment
#   code       The code itself
# --------------------------------------------------------------------
#
proc Fragment { codename code } {
   global fragment
   global module

   set fragment($module,$codename) $code
   return
}

# --------------------------------------------------------------------
#   Procedure: WriteFragment
#   Author:    Arjen Markus
#   Purpose:   Write out a code fragment
#   Context:   Used by various routines
#   Summary:
#              Substitute the various variables. Then write the
#              fragment to the file.
#   Arguments:
#   codename   Name of the code fragment
# --------------------------------------------------------------------
#
proc WriteFragment { codename } {
   global fragment
   global outfile
   global module

   set fragm  "[list subst $fragment($module,$codename)]"
   set output [uplevel $fragm]
   puts $outfile $output
   return
}

# --------------------------------------------------------------------
#   Procedure: WriteDeclarations
#   Author:    Arjen Markus
#   Purpose:   Write out the declarations for the main program
#   Context:   Used in main code
#   Summary:
#              Loop over all known parameters:
#              - Define these according to the given type and
#                define their test companions
#   Arguments:
#              -- none --
# --------------------------------------------------------------------
#
proc WriteDeclarations { } {
   global module_data
   global outfile
   global varname
   global vartype

   upvar #0 $module_data params

   WriteFragment "user_declarations"

   foreach var $params(all) {
      set varname $var
      set vartype $params($var,vartype)
      WriteFragment "declaration"
      switch $params($varname,type) {
         "input"  { set varname "in__$var"  }
         "output" { set varname "out__$var" }
         "in/out" { set varname "io__$var"  }
         "error"  { set varname "err__$var" }
         default  { puts "===> Type unknown: $params($varname,type) for $var" }
      }
      WriteFragment "declaration"
   }

   return
}

# --------------------------------------------------------------------
#   Procedure: WriteInitialise
#   Author:    Arjen Markus
#   Purpose:   Write out the initialisation routine
#   Context:   Used in main code
#   Summary:
#              Loop over all known parameters:
#              - Write the initialisation code
#              - Write the code to copy the values into the guard
#                variable
#   Arguments:
#              -- none --
# --------------------------------------------------------------------
#
proc WriteInitialise { } {
   global module_data
   global outfile
   global varname
   global vartype

   upvar #0 $module_data params

   WriteFragment "initialise"

   foreach var $params(all) {
      set varname $var
      set vartype $params($var,vartype)

      puts $outfile $params($varname,initcode)
   }

   WriteFragment "user_initialisation"

   #
   # The copying of the variables comes just before the call
   # to take care of the extra test cases - see WriteRunModule
   #

   WriteFragment "end_initialise"

   return
}

# --------------------------------------------------------------------
#   Procedure: WriteRunModule
#   Author:    Arjen Markus
#   Purpose:   Write out the code for run routine
#   Context:   Used in main code
#   Summary:
#              Loop over all known parameters:
#              - Write the code to copy the values into the guard
#                variable
#              Then the call to the module
#   Arguments:
#              -- none --
# --------------------------------------------------------------------
#
proc WriteRunModule { } {
   global module_data
   global outfile
   global varname
   global vartype

   upvar #0 $module_data params

   WriteFragment "run_module"

   #
   # The copying of the variables comes after any user-initialisation!
   #
   foreach var $params(all) {
      set varname $var
      set vartype $params($var,vartype)

      switch $params($varname,type) {
         "input"  { set varcopy "in__$var"  }
         "output" { set varcopy "out__$var" }
         "in/out" { set varcopy "io__$var"  }
         "error"  { set varcopy "err__$var" }
         default  { puts "===> Type unknown: $params($varname,type) for $var" }
      }
      WriteFragment "copy_variable"
   }

   WriteFragment "call_module"
   WriteFragment "end_run_module"

   return
}

# --------------------------------------------------------------------
#   Procedure: WriteCheckResult
#   Author:    Arjen Markus
#   Purpose:   Write out the checking routine
#   Context:   Used in main code
#   Summary:
#              Loop over all known parameters:
#              - Write the checking code
#              - Write the code to check that changes have been to
#                output variables if there is no error, and that
#                input variables have not been changed
#   Arguments:
#              -- none --
# --------------------------------------------------------------------
#
proc WriteCheckResult { } {
   global module_data
   global outfile
   global varname
   global vartype

   upvar #0 $module_data params

   WriteFragment "check_result"

   foreach var $params(all) {
      set varname $var
      set vartype $params($var,vartype)

      switch $params($varname,type) {
         "input"  { set varcopy "in__$var"
                    WriteFragment "should_be_equal"
                  }

         "output" { set varcopy "out__$var"
                    WriteFragment "should_differ"
                    puts $outfile "$params($var,checkcode)"
                  }

         "in/out" { set varcopy "io__$var"
                    WriteFragment "should_differ"
                    puts $outfile "$params($var,checkcode)"
                  }
         "error"  { set varcopy "err__$var"
                    WriteFragment "error_if_differs"
                    puts $outfile "$params($var,checkcode)"
                  }
         default  { puts "===> Type unknown: $params($varname,type) for $var" }
      }
   }
   WriteFragment "epilogue"
   WriteFragment "end_check_result"

   return
}

# --------------------------------------------------------------------
#   Procedure: Module
#   Author:    Arjen Markus
#   Purpose:   Define the dummy parameters etc. for a particular module
#   Context:   Used in main code
#   Summary:
#              Set the module name and execute the given code,
#              which will define the various elements for the module.
#   Arguments:
#   module_name Name of the module
#   definitions Code containing the definitions
# --------------------------------------------------------------------
#
proc Module { module_name definitions } {
   global fragment
   global module
   global module_data

   #
   # This dearly needs revision!
   #
   set module      $module_name
   set module_data data_$module_name
   upvar #0 $module_data a_name
   set a_name(name) $module_name
   set a_name(all)  {}

   set fragment($module,no_testcases) 0

   eval $definitions

   return
}

# --------------------------------------------------------------------
#   Procedure: Input, Output, In/out, Error, Condition, Call,
#              Epilogue, Testcase, Declarations, Preparation,
#              Initialisation, Headers
#   Author:    Arjen Markus
#   Purpose:   Define an input, output, in/out or error parameter, etc.
#   Context:   Used within the module definition
#   Summary:
#              Set the various array elements that make up the
#              definitions.
#   Arguments:
#   varname    Name of the variable
#   vartype    Type of the variable (should be correct for the
#              host language)
#   initcode   Code that will initialise the variable
# --------------------------------------------------------------------
#
proc Input { varname vartype initcode } {
   global module_data
   upvar #0 $module_data params

   if { [ lsearch $params(all) $varname ] <= -1 } {
      lappend params(all) $varname
   }
   set params($varname,type)     "input"
   set params($varname,vartype)  $vartype
   set params($varname,initcode) $initcode
   return
}

proc Output { varname vartype initcode { checkcode {} } } {
   global module_data
   upvar #0 $module_data params

   if { [ lsearch $params(all) $varname ] <= -1 } {
      lappend params(all) $varname
   }
   set params($varname,type)      "output"
   set params($varname,vartype)   $vartype
   set params($varname,initcode)  $initcode
   set params($varname,checkcode) $checkcode
   return
}

proc In/out { varname vartype initcode { checkcode {} } } {
   global module_data
   upvar #0 $module_data params

   if { [ lsearch $params(all) $varname ] <= -1 } {
      lappend params(all) $varname
   }
   set params($varname,type)      "in/out"
   set params($varname,vartype)   $vartype
   set params($varname,initcode)  $initcode
   set params($varname,checkcode) $checkcode
   return
}

proc Error { varname vartype initcode { checkcode {} } } {
   global module_data
   upvar #0 $module_data params

   if { [ lsearch $params(all) $varname ] <= -1 } {
      lappend params(all) $varname
   }
   set params($varname,type)      "error"
   set params($varname,vartype)   $vartype
   set params($varname,initcode)  $initcode
   set params($varname,checkcode) $checkcode
   return
}

proc Condition { expression value exprcode { checkcode {} }} {
   global module_data
   upvar #0 $module_data params

   set params($expression,$value)           $exprcode
   set params($expression,$value,checkcode) $checkcode
   return
}

proc Call { call_module } {
   global module
   global fragment

   set fragment($module,call_module)  $call_module
   return
}

proc Epilogue { code } {
   global module
   global fragment

   set fragment($module,epilogue)  $code
   return
}

proc Testcase { title code { checkcode {} } } {
   global module
   global fragment

   set  no_testcases $fragment($module,no_testcases)
   set  fragment($module,test,$no_testcases) $code
   set  fragment($module,title,$no_testcases) $title
   set  fragment($module,check,$no_testcases) $checkcode
   incr fragment($module,no_testcases)
   return
}

proc Declarations { code } {
   global module
   global fragment

   set fragment($module,user_declarations)  $code
   return
}

proc Preparation { code } {
   global module
   global fragment

   set fragment($module,preparations)  $code
   return
}

proc Initialisation { code } {
   global module
   global fragment

   set fragment($module,initialisation)  $code
   return
}

proc Headers { code } {
   global module
   global fragment

   set fragment($module,headers)  $code
   return
}

# --------------------------------------------------------------------
#   Procedure: CheckPaths
#   Author:    Arjen Markus
#   Purpose:   Analyse the path definitions
#   Context:   Used by the main code
#   Summary:
#              Read the .testpaths file line by line. Issue a new
#              test for each path that contains a reference to a
#              parameter. Do not try to be too smart though.
#   Arguments:
#   filename   Root name of the file to be scanned
# --------------------------------------------------------------------
#
proc CheckPaths { filename } {
   global module_data
   upvar #0 $module_data params
   global outfile
   global tmpfile
   global code
   global module
   global fragment
   global pathcount
   global path_success
   global path_io

   set    pathcount    0
   set    path_success 0
   set    path_io      0
   set    io_spec      0
   set    newpath      0

   set    fullname     $filename
   append fullname     ".testpaths"

   if { [ catch { set infile [ open $fullname "r" ] } msg ] == 0 } {

      while { [ gets $infile line ] >= 0 } {

         set firstw   [ lindex $line 0   ]

         #
         # Check for the beginning of a new path
         #
         if { $firstw == "Cyclomatic" } {
            incr pathcount
            set  newpath     1
            set  interesting 0
            continue
         } else {
            if { $firstw == "" } {
               if { $newpath == 2 } {
                  if { $interesting == 1 } {
                     incr path_success
                     WriteFragment "run_test"
                     CopyChecks
                     close $tmpfile
                  }
                  if { $io_spec == 1 } {
                     incr path_io
                  }
                  set newpath 0
               }
            }
         }

         #
         # Check the variables in question
         #
         if { [ regexp {:(.+)==> (.+)} $line full_match vars logvalue ] } {
            foreach varname $vars {
               if { [ lsearch $params(all) $varname ] > -1 } {
                  #
                  # Arrange for the initialisation
                  #
                  if { $newpath == 1 } {
                     set newpath 2
                     puts $outfile "! Path: $pathcount"
                     set title "Path: $pathcount"
                     WriteFragment "call_initialise"
                     set tmpfile [ open "testmake.tmp" "w+" ]
                  }
                  regexp {([0-9]+)\(} $line full_match lineno
                  set interesting 1
                  GenerateCondition $vars $logvalue $varname $lineno
                  #puts $outfile "! Condition: $vars ===> $logvalue (at line $lineno)"
                  #puts $outfile "   $varname = ..."
                  break
               }
            }

            if { [ lindex $vars 0 ] == "IO_SPEC" } {
               set io_spec 1
            }
         }
      }
      close $infile
   } else {
      puts "Note:"
      puts "   No file with report on test paths: $fullname"
      puts "   Relying on extra test cases in the module definition instead"
   }

   #
   # Write all the extra test cases
   #
   set no_testcases $fragment($module,no_testcases)
   for { set case 0 } { $case < $no_testcases } { incr case } {
      set title $fragment($module,title,$case)
      WriteFragment "call_initialise"
      WriteFragment "test,$case"
      WriteFragment "run_test"
      WriteFragment "check,$case"
   }

   WriteFragment "end_test_suite"

   return
}

# --------------------------------------------------------------------
#   Procedure: main code
#   Author:    Arjen Markus
#   Purpose:   Steering code
#   Context:   --
#   Summary:
#              Open the report file. Set the messages database
#              Initialise the other data
# --------------------------------------------------------------------
#
global outfile
global code
global module
global module_data
global template
global no_testcases

set filename [ lindex $argv 0 ]
if { [ llength $argv ] > 1 } {
   set module_name [ lindex $argv 1 ]
} else {
   set module_name $filename
}
set module "$module_name"
set module_data "data_$module"
upvar #0 $module_data a_name
set a_name(name) $module
set a_name(all)  {}

set template [ open "$filename.template" "w" ]
#set outfile  [ open "test_$filename.f90" "w" ]
#set outfile  [ open "test_$filename.c" "w" ]
set outfile  [ open "test_$filename.java" "w" ]

#source "codef90.tcl"
#source "codec.tcl"
source [file join [file dirname [info script]] "codejava.tcl"]
GetModules "modules.tcl" $filename

#
# This piece of code needs revision!
# - not as easy as it looks. Or is it?
#
set module "$module_name"
set module_data "data_$module"

puts "Module: $module"
puts $template "Module $module \{"

GetArguments $filename

WriteFragment "head"
WriteFragment "headers"
WriteFragment "initdecl"
WriteDeclarations
WriteFragment "init_preparations"
WriteFragment "preparations"

CheckPaths   $filename

WriteInitialise
WriteRunModule
WriteCheckResult
WriteFragment "summary"

puts $template "   Call \{\n       ? Call to module\n   \}\n\}"

puts "Done"
