lib/dejagnu.exp

   1 # Copyright (C) 1992-2019, 2020 Free Software Foundation, Inc.
   2 #
   3 # This file is part of DejaGnu.
   4 #
   5 # DejaGnu is free software; you can redistribute it and/or modify it
   6 # under the terms of the GNU General Public License as published by
   7 # the Free Software Foundation; either version 3 of the License, or
   8 # (at your option) any later version.
   9 #
  10 # DejaGnu is distributed in the hope that it will be useful, but
  11 # WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 # General Public License for more details.
  14 #
  15 # You should have received a copy of the GNU General Public License
  16 # along with DejaGnu; if not, write to the Free Software Foundation,
  17 # Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1301, USA.
  18
  19 # This file was written by Rob Savoye <rob@welcomehome.org>.
  20
  21 # A hairy pattern to recognize text.
  22 set text "\[- A-Za-z0-9\.\;\"\_\:\'\`\(\)\!\#\=\+\?\&\*<>]"
  23
  24 set SIZE size
  25 if { [which $SIZE] == 0 } {
  26     perror "Can't find $SIZE." 0
  27 }
  28
  29 # Get the size of the various section in OBJECT.
  30 proc exe_size {object} {
  31     global SIZE
  32
  33     # Make sure size exists
  34     if { [which $SIZE] == 0 } {
  35         return [list "-1" "Can't find $SIZE."]
  36     } else {
  37         verbose "Using $SIZE for \"size\" program." 2
  38     }
  39     set status [catch "exec $SIZE -V" output]
  40     if {[regexp "GNU size" $output] == 0} {
  41         perror "Need GNU size from the binutils" 0
  42         return [list "-1" "Need GNU size."]
  43     }
  44
  45     # Get the object size. We pass -x, to force hex output
  46     verbose "Getting the object file size for $object" 2
  47     set status [catch "exec $SIZE -x $object" output]
  48     verbose -log "Size of $object is\n$output" 2
  49
  50     # Remove the header line from the size output. This currently only
  51     # works with GNU size
  52     regsub "text.*filename\[\r\n\]*" $output "" output
  53
  54     # look for the size of the .text section
  55     regexp "\[\r\n\]*0x\[0-9a-fA-F\]*" $output text
  56     regsub "\[\r\n\]*0x\[0-9a-fA-F\]*\[ \t\]*" $output "" output
  57
  58     # look for the size of the .data section
  59     regexp "0x\[0-9a-fA-F\]*\[ \t\]*" $output data
  60     regsub "0x\[0-9a-fA-F\]*\[ \t\]*" $output "" output
  61
  62     # Values returns as hex
  63     return [list $text $data]
  64 }
  65
  66 # Run the host's native compiler, not the cross one. Filter out the
  67 # warnings and other extraneous stuff.
  68 #    Returns:
  69 #       A "" (empty) string if everything worked, or the
  70 #       output if there was a problem.
  71 #
  72 proc host_compile {compline} {
  73     global INCLUDES
  74     global LIBS
  75     global CXX, CC
  76
  77     # execute the compiler
  78     verbose "Compiling for the host using: $CC $INCLUDES $LIBS $compline" 2
  79     set status [catch "exec $CC $INCLUDES $LIBS $compline" comp_output]
  80     verbose "Compiler returned $comp_output" 2
  81
  82     # prune common warnings and other stuff we can safely ignore
  83     set comp_output [prune_warnings $comp_output]
  84
  85     # Trim multiple CR/LF pairs out to keep things consistent
  86     regsub "^\[\r\n\]+" $comp_output "" comp_output
  87
  88     # if we got a compiler error, log it
  89     if { [lindex $status 0] != 0 } {
  90         verbose -log "compiler exited with status [lindex $status 0]"
  91     }
  92     if { [lindex $status 1] ne "" } {
  93         verbose -log "output is:\n[lindex $status 1]" 2
  94     }
  95
  96     # return the filtered output
  97     return $comp_output
  98 }
  99
 100 # Execute the executable file, and analyse the output for the test
 101 # state keywords.
 102 #    Returns:
 103 #       A "" (empty) string if everything worked, or an error message
 104 #       if there was a problem.
 105 #
 106 proc host_execute {args} {
 107     set timeoutmsg "Timed out: Never got started, "
 108     set timeout 100
 109     set file all
 110     set timetol 0
 111     set arguments ""
 112
 113     if { [llength $args] == 0 } {
 114         return "No executable specified."
 115     } else {
 116         set executable [lindex $args 0]
 117         set arguments [lrange $args 1 end]
 118     }
 119
 120     verbose "The executable is $executable" 2
 121     verbose "The arguments are $arguments" 2
 122     if { [file exists "./${executable}"] } {
 123         set executable "./${executable}"
 124     }
 125     if { ![file exists $executable] } {
 126         perror "The executable, \"$executable\" is missing" 0
 127         return "No source file found"
 128     }
 129
 130     # Spawn the executable and look for the DejaGnu output messages.
 131     eval [list spawn -noecho $executable] $arguments
 132     expect {
 133         -re {(?:\A|\n)\t([][[:upper:]]+):([^\n]+)\n} {
 134             set output [string trim $expect_out(2,string)]
 135             switch -- $expect_out(1,string) {
 136                 NOTE            { verbose $output 2 }
 137                 PASSED          { pass $output }
 138                 FAILED          { fail $output }
 139                 XPASSED         { xpass $output }
 140                 XFAILED         { xfail $output }
 141                 UNTESTED        { untested $output }
 142                 UNRESOLVED      { unresolved $output }
 143                 END {
 144                     expect -re {.+} { exp_continue }
 145                     verbose "All done" 2
 146                 }
 147                 default {
 148                     unresolved "unknown unit test token $expect_out(1,string)"
 149                 }
 150             }
 151             set timetol 0
 152             if { $expect_out(1,string) ne "END" } { exp_continue }
 153         }
 154         -re {^[^\r\n]*([0-9][0-9]:..:..:[^\n]*)\n} {
 155             # No one seems to know why this pattern is here or what it is
 156             # supposed to match.  I suspect that it is obsolete.  -- jcb, 2020
 157             verbose [string trim $expect_out(1,string)] 3
 158             set timetol 0
 159             exp_continue
 160         }
 161         -re {^[^\n]*\n} {
 162             # Skip other lines produced by the test program.
 163             set timetol 0
 164             exp_continue
 165         }
 166         full_buffer {
 167             perror "Expect matching buffer overrun while running\
 168                         $executable $arguments"
 169         }
 170         eof {
 171             warning "Test case did not emit an end marker"
 172         }
 173         timeout {
 174             warning "Timed out executing test case"
 175             if { $timetol <= 2 } {
 176                 incr timetol
 177                 exp_continue
 178             } else {
 179                 catch close
 180                 return "Timed out executing test case"
 181             }
 182         }
 183     }
 184
 185     # force a close of the executable to be safe.
 186     catch close
 187     return ""
 188 }