| # |
| # Expect script for Chill Regression Tests |
| # Copyright (C) 1993, 1996, 1997 Free Software Foundation |
| # |
| # This file is free software; you can redistribute it and/or modify |
| # it under the terms of the GNU General Public License as published by |
| # the Free Software Foundation; either version 2 of the License, or |
| # (at your option) any later version. |
| # |
| # This program 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 General Public License for more details. |
| # |
| # You should have received a copy of the GNU General Public License |
| # along with this program; if not, write to the Free Software |
| # Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
| # |
| # Written by Jeffrey Wheat (cassidy@cygnus.com) |
| # |
| |
| # |
| # chill support library procedures and testsuite specific instructions |
| # |
| |
| # |
| # default_chill_version |
| # extract and print the version number of the chill compiler |
| # exits if compiler does not exist |
| # |
| proc default_chill_version { } { |
| global GCC_UNDER_TEST |
| |
| # ignore any arguments after the command |
| set compiler [lindex $GCC_UNDER_TEST 0] |
| |
| # verify that the compiler exists |
| if {[which $compiler] != 0} then { |
| set tmp [ exec $compiler -v ] |
| regexp "version.*$" $tmp version |
| |
| if [info exists version] then { |
| clone_output "[which $compiler] $version\n" |
| } |
| } else { |
| warning "$compiler does not exist" |
| exit -1 |
| } |
| } |
| |
| # |
| # chill_compile |
| # compile the specified file |
| # |
| # returns values: |
| # return 0 on success |
| # return 1 on failure with $result containing compiler output |
| # exit with -1 if compiler doesn't exist |
| # |
| # verbosity output: |
| # 1 - indicate compile in progress |
| # 2 - indicate compile, target name |
| # 3 - indicate compile, target name, exec command, and result |
| # |
| proc chill_compile { src obj } { |
| global GCC_UNDER_TEST |
| global CFLAGS |
| |
| global errno |
| global result |
| global verbose |
| |
| global subdir |
| global tmpdir |
| |
| set errno 0 |
| set cflags $CFLAGS |
| set dumpfile [file rootname $obj].cmp ;# name of file to dump stderr in |
| |
| # verify that the compiler exists |
| if { [which $GCC_UNDER_TEST] == 0 } then { |
| warning "$GCC_UNDER_TEST does not exist" |
| exit -1 |
| } |
| |
| if { $verbose == 1 } then { |
| send_user "Compiling... " |
| } else { |
| verbose " - CMPL: Compiling [file tail $src]" 2 |
| } |
| |
| # if object type is a grt file, then only build a grant file |
| if [string match "*.grt" $obj] then { |
| set cflags [concat $cflags -fgrant-only] |
| } |
| |
| # build command line |
| set commandline "$GCC_UNDER_TEST $cflags -I$subdir -c $src" |
| |
| # write command line to logfile |
| send_log "\n### EXEC: $commandline\n" |
| |
| # tell us whats going on if verbose |
| verbose "### EXEC: $commandline" 3 |
| |
| # exec the compiler with the appropriate flags |
| set errno [catch "exec $commandline" result] |
| |
| # dump compiler's stderr output into $dumpfile - this is a gross hack |
| set dumpfile [open $dumpfile w+]; puts $dumpfile $result; close $dumpfile |
| |
| # log any compiler output unless its null |
| if ![string match "" $result] then { send_log "\n$result\n" } |
| unset cflags |
| return |
| } |
| |
| # |
| # chill_link |
| # link the specified files |
| # |
| # returns values: |
| # return 0 on success |
| # return 1 on failure with $result containing compiler output |
| # exit with -1 if compiler doesn't exist |
| # |
| # verbosity output: |
| # 1 - indicate linking in progress |
| # 2 - indicate linking, target name |
| # 3 - indicate linking, target name, exec command, and result |
| # |
| proc chill_link { target } { |
| global GCC_UNDER_TEST |
| global CFLAGS |
| |
| global errno |
| global result |
| global verbose |
| global tmptarget |
| |
| global crt0 |
| global libs |
| global objs |
| |
| set errno 0 |
| |
| # verify that the compiler exists |
| if { [which $GCC_UNDER_TEST] == 0 } then { |
| warning "$GCC_UNDER_TEST does not exist" |
| exit -1 |
| } |
| |
| if { $verbose == 1 } then { |
| send_user "Linking... " |
| } else { |
| verbose " - LINK: Linking [file tail $target]" 2 |
| } |
| |
| # verify that the object exists |
| if ![file exists $target.o] then { |
| set errno 1 |
| set result "file $target.o doesn't exist" |
| return |
| } |
| |
| # build command line |
| set commandline "$GCC_UNDER_TEST $CFLAGS -o $target $target.o $objs $crt0 $libs" |
| |
| # write command line to logfile |
| send_log "\n### EXEC: $commandline\n" |
| |
| # tell us whats going on if we are verbose |
| verbose "### EXEC: $commandline" 3 |
| |
| # link the objects, sending any linker output to $result |
| set errno [catch "exec $commandline > $tmptarget.lnk" result] |
| |
| # log any linker output unless its null |
| if ![string match "" $result] then { send_log "\n$result\n" } |
| return |
| } |
| |
| # |
| # default_chill_start |
| # |
| proc default_chill_start { } { |
| global srcdir |
| global subdir |
| global tmpdir |
| global verbose |
| |
| if { $verbose > 1 } then { send_user "Configuring testsuite... " } |
| |
| # tmpdir is obtained from $objdir/site.exp. if not, set it to /tmp |
| if ![info exists tmpdir] then { set tmpdir /tmp } |
| |
| # save and convert $srcdir to an absolute pathname, stomp on the old value |
| # stomp on $subdir and set to the absolute path to the subdirectory |
| global osrcdir; set osrcdir $srcdir; set srcdir [cd $srcdir; pwd] |
| global osubdir; set osubdir $subdir; set subdir $srcdir/$subdir |
| |
| # cd the temporary directory, $tmpdir |
| cd $tmpdir; verbose "### PWD: [pwd]" 5 |
| |
| # copy init files to the tmpdir |
| foreach initfile [glob -nocomplain $subdir/*.init] { |
| set targfile $tmpdir/[file tail [file rootname $initfile]] |
| verbose "### EXEC: cp $initfile $targfile" 5 |
| if [catch "exec cp $initfile $targfile"] then { |
| send_user "\nConfigure failed.\n" |
| exit -1 |
| } |
| } |
| if { $verbose > 1 } then { send_user "Configuring finished.\n" } |
| } |
| |
| # |
| # default_chill_exit |
| # |
| # |
| proc default_chill_exit { } { |
| global srcdir |
| global objdir |
| global tmpdir |
| global osrcdir |
| global osubdir |
| |
| # reset directory variables |
| set srcdir $osrcdir; set subdir $osubdir |
| |
| # remove all generated targets and objects |
| verbose "### EXEC: rm -f $tmpdir/*" 3 |
| catch "exec rm -f $tmpdir/*" result |
| |
| # change back to the main object directory |
| cd $objdir |
| verbose "### SANITY: [pwd]" 5 |
| } |
| |
| # |
| # chill_diff |
| # compare two files line-by-line |
| # |
| # returns values: |
| # return 0 on success |
| # return 1 if different |
| # return -1 if output file doesn't exist |
| # |
| # verbosity output: |
| # 1 - indicate diffing in progress |
| # 2 - indicate diffing, target names |
| # 3 - indicate diffing, target names, and result |
| # |
| proc chill_diff { file_1 file_2 } { |
| global errno |
| global result |
| global target |
| global tmptarget |
| |
| global verbose |
| |
| set eof -1 |
| set errno 0 |
| set differences 0 |
| |
| if { $verbose == 1 } then { |
| send_user "Diffing... " |
| } else { |
| verbose " - DIFF: Diffing [file tail $file_1] [file tail $file_2]" 2 |
| } |
| |
| # write command line to logfile |
| send_log "### EXEC: diff $file_1 $file_2\n" |
| |
| # tell us whats going on if we are verbose |
| verbose "### EXEC: diff $file_1 $file_2" 3 |
| |
| # verify file exists and open it |
| if [file exists $file_1] then { |
| set file_a [open $file_1 r] |
| } else { |
| set errno -1; set result "$file_1 doesn't exist" |
| return |
| } |
| |
| # verify file exists and is not zero length, and then open it |
| if [file exists $file_2] then { |
| if [file size $file_2]!=0 then { |
| set file_b [open $file_2 r] |
| } else { |
| set errno -1; set result "$file_2 is zero bytes"; return |
| } |
| } else { |
| set errno -1; set result "$file_2 doesn't exist"; return |
| } |
| |
| # spoof the diff routine |
| lappend list_a $target |
| |
| while { [gets $file_a line] != $eof } { |
| if [regexp "^#.*$" $line] then { |
| continue |
| } else { |
| lappend list_a $line |
| } |
| } |
| close $file_a |
| |
| # spoof the diff routine |
| lappend list_b $target |
| |
| while { [gets $file_b line] != $eof } { |
| if [regexp "^#.*$" $line] then { |
| continue |
| } else { |
| # use [file tail $line] to strip off pathname |
| lappend list_b [file tail $line] |
| } |
| } |
| close $file_b |
| |
| for { set i 0 } { $i < [llength $list_a] } { incr i } { |
| set line_a [lindex $list_a $i] |
| set line_b [lindex $list_b $i] |
| |
| if [string compare $line_a $line_b] then { |
| set errno 1 |
| set count [expr $i+1] |
| set linenum [format %dc%d $count $count] |
| verbose "$linenum" 3 |
| verbose "< $line_a" 3 |
| verbose "---" 3 |
| verbose "> $line_b" 3 |
| |
| send_log "$file_1: < $count: $line_a\n" |
| send_log "$file_2: > $count: $line_b\n" |
| set result "differences found" |
| } |
| } |
| return |
| } |
| |
| # |
| # chill_fail |
| # a wrapper around the framework fail proc |
| # |
| proc chill_fail { target result } { |
| global verbose |
| |
| if { $verbose == 1 } then { send_user "\n" } |
| fail $target |
| verbose "--------------------------------------------------" 3 |
| verbose "### RESULT: $result" 3 |
| } |
| |
| # |
| # chill_pass |
| # a wrapper around the framework fail proc |
| # |
| proc chill_pass { target } { |
| global verbose |
| |
| if { $verbose == 1 } then { send_user "\n" } |
| pass $target |
| } |