hlvm/test/lib/identity.exp

#===-test/lib/identity.exp - Script for identity tests ---------------------===#
#
#                      High Level Virtual Machine (HLVM)
# 
#  Copyright (C) 2006 Reid Spencer. All Rights Reserved.
# 
#  This software is free software; you can redistribute it and/or modify it 
#  under the terms of the GNU Lesser General Public License as published by 
#  the Free Software Foundation; either version 2.1 of the License, or (at 
#  your option) any later version.
# 
#  This software is distributed in the hope that it will be useful, but WITHOUT
#  ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
#  FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public License for 
#  more details.
# 
#  You should have received a copy of the GNU Lesser General Public License 
#  along with this library in the file named LICENSE.txt; if not, write to the 
#  Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, 
#  MA 02110-1301 USA
# 
#===------------------------------------------------------------------------===#
proc hlvm-identity-tests { prog pat } {
  global srcdir subdir objdir tmpdir objrootdir
  set outdir [file join $objdir $subdir]
  set tool [file join $objrootdir tools $prog $prog ]
  set source [file join $srcdir $subdir ]
  set files [lsort [
    glob -nocomplain -tails -types {f r} -directory $source $pat]]
  set dirs [lsort [
    glob -nocomplain -tails -types {d r} -directory $source *]]

  if { [file isdirectory $outdir] } {
    cd $outdir
  } else {
    if { [file exists $outdir] } {
      fail "identity: $outdir exists and is not a directory. Remove it"
      exit(2)
    } else {
      file mkdir $outdir
    }
  }
  
  foreach test $files {
    set output [file join $outdir ${test}.out]
    set testsrc [file join $source $test]
    set execout ""
    set retval [ catch { exec -keepnewline $tool $testsrc -o $output } msg ]
    if { $retval == 1 } {
      fail "$test: $tool returned $retval\n$msg"
    } else {
      # Do the identity test
      set diffout [file join ${output}.diff]
      set retval [ catch {exec diff $testsrc $output >&$diffout } ]
      if {$retval == 1} {
        #Get output
        if { [file exists $diffout] } {
          set difffile [open $diffout {RDONLY}]
          set result [read $difffile]
          close $difffile
        } else {
          set result "no diff file"
        }
        fail "$test: identity test failed:\n$result"
      } else {
        file delete $diffout
        pass "$test"
      }
    }
  }
}