| #===-test/lib/invalid.exp - Script for invalid input 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-invalid-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 != 0 } { |
| if {[lindex $::errorCode 0] eq "CHILDSTATUS"} { |
| set status [lindex $::errorCode 2] |
| if { $status eq 0 } { |
| fail "$test: $tool return $retval\n$msg" |
| } else { |
| pass "$test" |
| } |
| } else { |
| fail "$test: $tool return $::errorCode\n$msg" |
| } |
| } else { |
| fail "$test: $tool return $retval\n$msg" |
| } |
| } |
| } |