gcc/testsuite/lib/chill.exp

   1 #
   2 # Expect script for Chill Regression Tests
   3 #   Copyright (C) 1993, 1996, 1997 Free Software Foundation
   4 #
   5 # This file is free software; you can redistribute it and/or modify
   6 # it under the terms of the GNU General Public License as published by
   7 # the Free Software Foundation; either version 2 of the License, or
   8 # (at your option) any later version.
   9 #
  10 # This program is distributed in the hope that it will be useful,
  11 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 # GNU General Public License for more details.
  14 #
  15 # You should have received a copy of the GNU General Public License
  16 # along with this program; if not, write to the Free Software
  17 # Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  18 #
  19 # Written by Jeffrey Wheat (cassidy@cygnus.com)
  20 #
  21
  22 #
  23 # chill support library procedures and testsuite specific instructions
  24 #
  25
  26 #
  27 # default_chill_version
  28 #       extract and print the version number of the chill compiler
  29 #       exits if compiler does not exist
  30 #
  31 proc default_chill_version { } {
  32     global GCC_UNDER_TEST
  33
  34     # ignore any arguments after the command
  35     set compiler [lindex $GCC_UNDER_TEST 0]
  36
  37     # verify that the compiler exists
  38     if {[which $compiler] != 0} then {
  39         set tmp [ exec $compiler -v ]
  40         regexp "version.*$" $tmp version
  41
  42         if [info exists version] then {
  43             clone_output "[which $compiler] $version\n"
  44         }
  45     } else {
  46         warning "$compiler does not exist"
  47         exit -1
  48     }
  49 }
  50
  51 #
  52 # chill_compile
  53 #       compile the specified file
  54 #
  55 #       returns values:
  56 #               return 0 on success
  57 #               return 1 on failure with $result containing compiler output
  58 #               exit with -1 if compiler doesn't exist
  59 #
  60 #       verbosity output:
  61 #               1 - indicate compile in progress
  62 #               2 - indicate compile, target name
  63 #               3 - indicate compile, target name, exec command, and result
  64 #
  65 proc chill_compile { src obj } {
  66     global GCC_UNDER_TEST
  67     global CFLAGS
  68
  69     global errno
  70     global result
  71     global verbose
  72
  73     global subdir
  74     global tmpdir
  75
  76     set errno 0
  77     set cflags $CFLAGS
  78     set dumpfile [file rootname $obj].cmp    ;# name of file to dump stderr in
  79
  80     # verify that the compiler exists
  81     if { [which $GCC_UNDER_TEST] == 0 } then {
  82         warning "$GCC_UNDER_TEST does not exist"
  83         exit -1
  84     }
  85
  86     if { $verbose == 1 } then {
  87         send_user "Compiling... "
  88     } else {
  89         verbose " -  CMPL: Compiling [file tail $src]" 2
  90     }
  91
  92     # if object type is a grt file, then only build a grant file
  93     if [string match "*.grt" $obj] then {
  94         set cflags [concat $cflags -fgrant-only]
  95     }
  96
  97     # build command line
  98     set commandline "$GCC_UNDER_TEST $cflags -I$subdir -c $src"
  99
 100     # write command line to logfile
 101     send_log "\n### EXEC: $commandline\n"
 102
 103     # tell us whats going on if verbose
 104     verbose "### EXEC: $commandline" 3
 105
 106     # exec the compiler with the appropriate flags
 107     set errno [catch "exec $commandline" result]
 108
 109     # dump compiler's stderr output into $dumpfile - this is a gross hack
 110     set dumpfile [open $dumpfile w+]; puts $dumpfile $result; close $dumpfile
 111
 112     # log any compiler output unless its null
 113     if ![string match "" $result] then { send_log "\n$result\n" }
 114     unset cflags
 115     return
 116 }
 117
 118 #
 119 # chill_link
 120 #       link the specified files
 121 #
 122 #       returns values:
 123 #               return 0 on success
 124 #               return 1 on failure with $result containing compiler output
 125 #               exit with -1 if compiler doesn't exist
 126 #
 127 #       verbosity output:
 128 #               1 - indicate linking in progress
 129 #               2 - indicate linking, target name
 130 #               3 - indicate linking, target name, exec command, and result
 131 #
 132 proc chill_link { target } {
 133     global GCC_UNDER_TEST
 134     global CFLAGS
 135
 136     global errno
 137     global result
 138     global verbose
 139     global tmptarget
 140
 141     global crt0
 142     global libs
 143     global objs
 144
 145     set errno 0
 146
 147     # verify that the compiler exists
 148     if { [which $GCC_UNDER_TEST] == 0 } then {
 149         warning "$GCC_UNDER_TEST does not exist"
 150         exit -1
 151     }
 152
 153     if { $verbose == 1 } then {
 154         send_user "Linking... "
 155     } else {
 156         verbose " -  LINK: Linking [file tail $target]" 2
 157     }
 158
 159     # verify that the object exists
 160     if ![file exists $target.o] then {
 161         set errno 1
 162         set result "file $target.o doesn't exist"
 163         return
 164     }
 165
 166     # build command line
 167     set commandline "$GCC_UNDER_TEST $CFLAGS -o $target $target.o $objs $crt0 $libs"
 168
 169     # write command line to logfile
 170     send_log "\n### EXEC: $commandline\n"
 171
 172     # tell us whats going on if we are verbose
 173     verbose "### EXEC: $commandline" 3
 174
 175     # link the objects, sending any linker output to $result
 176     set errno [catch "exec $commandline > $tmptarget.lnk" result]
 177
 178     # log any linker output unless its null
 179     if ![string match "" $result] then { send_log "\n$result\n" }
 180     return
 181 }
 182
 183 #
 184 # default_chill_start
 185 #
 186 proc default_chill_start { } {
 187     global srcdir
 188     global subdir
 189     global tmpdir
 190     global verbose
 191
 192     if { $verbose > 1 } then { send_user "Configuring testsuite... " }
 193
 194     # tmpdir is obtained from $objdir/site.exp. if not, set it to /tmp
 195     if ![info exists tmpdir] then { set tmpdir /tmp }
 196
 197     # save and convert $srcdir to an absolute pathname, stomp on the old value
 198     # stomp on $subdir and set to the absolute path to the subdirectory
 199     global osrcdir; set osrcdir $srcdir; set srcdir [cd $srcdir; pwd]
 200     global osubdir; set osubdir $subdir; set subdir $srcdir/$subdir
 201
 202     # cd the temporary directory, $tmpdir
 203     cd $tmpdir; verbose "### PWD: [pwd]" 5
 204
 205     # copy init files to the tmpdir
 206     foreach initfile [glob -nocomplain $subdir/*.init] {
 207         set targfile $tmpdir/[file tail [file rootname $initfile]]
 208         verbose "### EXEC: cp $initfile $targfile" 5
 209         if [catch "exec cp $initfile $targfile"] then {
 210             send_user "\nConfigure failed.\n"
 211             exit -1
 212         }
 213     }
 214     if { $verbose > 1 } then { send_user "Configuring finished.\n" }
 215 }
 216
 217 #
 218 # default_chill_exit
 219 #
 220 #
 221 proc default_chill_exit { } {
 222     global srcdir
 223     global objdir
 224     global tmpdir
 225     global osrcdir
 226     global osubdir
 227
 228     # reset directory variables
 229     set srcdir $osrcdir; set subdir $osubdir
 230
 231     # remove all generated targets and objects
 232     verbose "### EXEC: rm -f $tmpdir/*" 3
 233     catch "exec rm -f $tmpdir/*" result
 234
 235     # change back to the main object directory
 236     cd $objdir
 237     verbose "### SANITY: [pwd]" 5
 238 }
 239
 240 #
 241 # chill_diff
 242 #       compare two files line-by-line
 243 #
 244 #       returns values:
 245 #               return 0 on success
 246 #               return 1 if different
 247 #               return -1 if output file doesn't exist
 248 #
 249 #       verbosity output:
 250 #               1 - indicate diffing in progress
 251 #               2 - indicate diffing, target names
 252 #               3 - indicate diffing, target names, and result
 253 #
 254 proc chill_diff { file_1 file_2 } {
 255     global errno
 256     global result
 257     global target
 258     global tmptarget
 259
 260     global verbose
 261
 262     set eof -1
 263     set errno 0
 264     set differences 0
 265
 266     if { $verbose == 1 } then {
 267         send_user "Diffing... "
 268     } else {
 269         verbose " -  DIFF: Diffing [file tail $file_1] [file tail $file_2]" 2
 270     }
 271
 272     # write command line to logfile
 273     send_log "### EXEC: diff $file_1 $file_2\n"
 274
 275     # tell us whats going on if we are verbose
 276     verbose "### EXEC: diff $file_1 $file_2" 3
 277
 278     # verify file exists and open it
 279     if [file exists $file_1] then {
 280         set file_a [open $file_1 r]
 281     } else {
 282         set errno -1; set result "$file_1 doesn't exist"
 283         return
 284     }
 285
 286     # verify file exists and is not zero length, and then open it
 287     if [file exists $file_2] then {
 288         if [file size $file_2]!=0 then {
 289             set file_b [open $file_2 r]
 290         } else {
 291             set errno -1; set result "$file_2 is zero bytes"; return
 292         }
 293     } else {
 294         set errno -1; set result "$file_2 doesn't exist"; return
 295     }
 296
 297     # spoof the diff routine
 298     lappend list_a $target
 299
 300     while { [gets $file_a line] != $eof } {
 301         if [regexp "^#.*$" $line] then {
 302             continue
 303         } else {
 304             lappend list_a $line
 305         }
 306     }
 307     close $file_a
 308
 309     # spoof the diff routine
 310     lappend list_b $target
 311
 312     while { [gets $file_b line] != $eof } {
 313         if [regexp "^#.*$" $line] then {
 314             continue
 315         } else {
 316             # use [file tail $line] to strip off pathname
 317             lappend list_b [file tail $line]
 318         }
 319     }
 320     close $file_b
 321
 322     for { set i 0 } { $i < [llength $list_a] } { incr i } {
 323         set line_a [lindex $list_a $i]
 324         set line_b [lindex $list_b $i]
 325
 326         if [string compare $line_a $line_b] then {
 327             set errno 1
 328             set count [expr $i+1]
 329             set linenum [format %dc%d $count $count]
 330             verbose "$linenum" 3
 331             verbose "< $line_a" 3
 332             verbose "---" 3
 333             verbose "> $line_b" 3
 334
 335             send_log "$file_1: < $count: $line_a\n"
 336             send_log "$file_2: > $count: $line_b\n"
 337             set result "differences found"
 338         }
 339     }
 340     return
 341 }
 342
 343 #
 344 # chill_fail
 345 #       a wrapper around the framework fail proc
 346 #
 347 proc chill_fail { target result } {
 348     global verbose
 349
 350     if { $verbose == 1 } then { send_user "\n" }
 351     fail $target
 352     verbose "--------------------------------------------------" 3
 353     verbose "### RESULT: $result" 3
 354 }
 355
 356 #
 357 # chill_pass
 358 #       a wrapper around the framework fail proc
 359 #
 360 proc chill_pass { target } {
 361     global verbose
 362
 363     if { $verbose == 1 } then { send_user "\n" }
 364     pass $target
 365 }