lib/specs.exp

   1 # Copyright (C) 2021 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, see <http://www.gnu.org/licenses/>.
  17
  18 # This file was written by Jacob Bachmeyer.
  19
  20 # Procedures for handling specs strings similar to those used in GCC.
  21
  22 # These spec strings support substitutions introduced using "%":
  23 #
  24 #       %%      -- literal "%" character
  25 #       %{...}  -- substitute data value with recursive evaluation
  26 #       %[...]  -- evaluate Tcl code and substitute result literally
  27 #
  28 # All other uses of "%" in specs strings are reserved.  Data item names
  29 # containing colon (":") are generally reserved for future expansion; a few
  30 # are currently used as shorthand for certain DejaGnu API calls.
  31 # Convention for hierarchical name parts is separation using ".", while "/"
  32 # is used for variations intended to be selected using another value.
  33
  34 # Specs are stored in a Tcl array, referred to as the "database" array.
  35 # Spec strings are organized into layers, providing a hierarchical
  36 # structure of fallback and default values by searching layers in the order
  37 # given by the "_layers" option.
  38
  39 # The external data structures used by this module are mostly association
  40 # lists, but they are internally referenced using Tcl arrays.
  41
  42 # All procedures in this module are currently internal to DejaGnu and
  43 # subject to change without notice.
  44 namespace eval ::dejagnu::specs {
  45     namespace export eval_specs validate_specs
  46 }
  47
  48 # Expand one data substitution token.
  49 # internal procedure; uses SPECS and OPTION arrays in caller's context
  50 proc ::dejagnu::specs::subst_token { key } {
  51     upvar 1 specs specs option option
  52
  53     # check for an option first
  54     if { [info exists option($key)] } {
  55         return $option($key)
  56     }
  57
  58     # check for a board configuration value
  59     if { [regexp {^board_info\(([^)]+)\):(.*)$} $key -> machine info_key] } {
  60         return [board_info $machine $info_key]
  61     }
  62
  63     # search the specs database if a layer path was given
  64     if { [info exists option(_layers)] } {
  65         foreach layer $option(_layers) {
  66             if { [info exists specs(layer,$layer,$key)] } {
  67                 return $specs(layer,$layer,$key)
  68             }
  69         }
  70     }
  71
  72     # check for suitable default entry in the specs database
  73     if { [info exists specs(base,$key)] } {
  74         return $specs(base,$key)
  75     }
  76
  77     error "unresolved specs token: $key"
  78 }
  79
  80 # Evaluate excess open or close delimiters.
  81 proc ::dejagnu::specs::delimiter_balance { text } {
  82     # first, remove all backslashes that cannot quote delimiters
  83     regsub -all {\\+[^][\\{}]} $text "" text
  84     # strip backslash-quoted backslashes
  85     regsub -all {(?:\\{2})+} $text "" text
  86     # strip backslash-quoted delimiters
  87     regsub -all {(^|[^\\])\\[][{}]} $text "\\1" text
  88     # remove all unrelated characters
  89     regsub -all {[^][{}]+} $text "" text
  90
  91     # separate the text into only-left and only-right subsets
  92     regsub -all "\\\\*\[\]\}\]" $text "" left
  93     regsub -all "\\\\*\[\[\{\]" $text "" right
  94
  95     return [expr { [string length $left] - [string length $right] }]
  96 }
  97
  98 # Find the end of a token.
  99 proc ::dejagnu::specs::token_end { text start end_pat } {
 100     set balance 1
 101     set point $start
 102     while { $balance > 0 } {
 103         regexp -indices -start [expr { 1 + $point }] -- $end_pat $text item
 104         set point [lindex $item 0]
 105         # optimization: if delimiter_balance returns N, we need at least N
 106         #     more closing delimiters, but that could be any combination of
 107         #     braces and brackets, not only the main endpoint delimiter
 108         for {
 109             set balance [delimiter_balance [string range $text $start $point]]
 110         } { $balance > 1 } { incr balance -1 } {
 111             regexp -indices -start [expr { 1 + $point }] -- \
 112                 "\[\\\}\\\]\]" $text item
 113             set point [lindex $item 0]
 114         }
 115     }
 116     return [lindex $item 1]
 117 }
 118
 119 # Abstract parsing loop.
 120 # internal procedure; sets TOKEN variable in caller's context
 121 proc ::dejagnu::specs::scan_specs_string { text literal char data code } {
 122     upvar 1 token token
 123
 124     for {
 125         set mark -1
 126         set point 0
 127     } { [regexp -indices -start $point -- {%.} $text item] } {
 128         set point [expr { 1 + $mark }]
 129     } {
 130         # extract literal from preceding range
 131         set token [string range $text \
 132                        [expr { $mark + 1 }] \
 133                        [expr { [lindex $item 0] - 1 }]]
 134         uplevel 1 $literal
 135         # advance point
 136         set point [lindex $item 1]
 137         # extract first character of substitution
 138         set enter [string index $text $point]
 139         if { $enter eq "%" } {
 140             # %% -- literal "%"
 141             set mark $point
 142             uplevel 1 $char
 143         } elseif { $enter eq "\{" } {
 144             # %{...} -- substitute data item
 145             set mark [token_end $text $point "\\\}"]
 146             set token [string range $text \
 147                            [expr { $point + 1 }] [expr { $mark  - 1 }]]
 148             uplevel 1 $data
 149         } elseif { $enter eq "\[" } {
 150             # %[...] -- substitute value from Tcl code fragment
 151             set mark [token_end $text $point "\\\]"]
 152             set token [string range $text \
 153                            [expr { $point + 1 }] [expr { $mark  - 1 }]]
 154             uplevel 1 $code
 155         } else {
 156             error "unrecognized sequence %$enter in spec string"
 157         }
 158     }
 159     # leave the trailing literal in TOKEN
 160     set token [string range $text [expr { $mark + 1 }] end]
 161 }
 162
 163 # Generate parse report for specs string; for debugging
 164 proc ::dejagnu::specs::parse_specs_string { text } {
 165     set tokens [list]
 166     scan_specs_string $text {
 167         # intervening literal text
 168         lappend tokens [list text $token]
 169     } { # %% escape
 170         lappend tokens [list text %]
 171     } { # data item
 172         lappend tokens [list data $token]
 173     } { # code item
 174         lappend tokens [list code $token]
 175     }
 176     lappend tokens [list text $token]
 177     return $tokens
 178 }
 179
 180 # Expand substitutions in specs string.
 181 # internal procedure; uses SPECS and OPTION arrays and BASE_LEVEL variable
 182 # in caller's context
 183 proc ::dejagnu::specs::eval_specs_string { text } {
 184     upvar 1 specs specs option option base_level base_level
 185
 186     set output ""
 187     scan_specs_string $text {
 188         # copy intervening literal text to output
 189         append output $token
 190     } {
 191         # emit "%" where string contains "%%"
 192         append output "%"
 193     } {
 194         # substitute data item
 195         append output [eval_specs_string \
 196                            [subst_token [eval_specs_string $token]]]
 197     } {
 198         # evaluate Tcl code fragment
 199         append output [uplevel "#$base_level" [eval_specs_string $token]]
 200     }
 201     # copy trailing literal
 202     append output $token
 203
 204     return $output
 205 }
 206
 207 # Check that the provided specs string can be evaluated; that is, that all
 208 # substitutions have definitions.
 209 # internal procedure; uses SPECS and OPTION arrays in caller's context
 210 proc ::dejagnu::specs::validate_specs_string { text } {
 211     upvar 1 specs specs option option
 212
 213     scan_specs_string $text {
 214         # ignore literal text
 215     } {
 216         # ignore literal "%"
 217     } {
 218         # check substitution
 219     } {
 220         # check Tcl code fragment
 221     }
 222     # ignore trailing literal
 223
 224     # an error is thrown if validation fails
 225     return 1
 226 }
 227
 228 # Perform spec substitutions to evaluate %{GOAL}.
 229 #
 230 #  The DATABASE_NAME is the name (in the caller's context) of the database
 231 #  array to use, while OPTIONS is a list of additional KEY VALUE pairs that
 232 #  should be available for substitution.
 233 proc ::dejagnu::specs::eval_specs { database_name goal options } {
 234     upvar 1 $database_name specs
 235     array set option $options
 236     set base_level [expr { [info level] - 1 }]
 237
 238     return [eval_specs_string "%{$goal}"]
 239 }
 240
 241 # Load specs strings into DATABASE_NAME; as:
 242 #       load_specs DATABASE_NAME BASE_STRINGS (LAYER_NAME LAYER_STRINGS)...
 243 #  to load only into a layer:
 244 #       load_specs DATABASE_NAME {} LAYER_NAME LAYER_STRINGS
 245 proc ::dejagnu::specs::load_specs { database_name base_strings args } {
 246     upvar 1 $database_name specs
 247
 248     if { ([llength $args] & 1) != 0 } {
 249         error "specs layer names and contents must be in pairs"
 250     }
 251     foreach {k v} $base_strings {
 252         set specs(base,$k) $v
 253     }
 254     foreach {layer layer_strings} $args {
 255         foreach {k v} $layer_strings {
 256             set specs(layer,$layer,$k) $v
 257         }
 258     }
 259 }
 260
 261 # Display contents of specs database array; for debugging
 262 proc ::dejagnu::specs::dump_specs { database_name } {
 263     upvar 1 $database_name specs
 264
 265     set keys [lsort -dictionary [array names specs]]
 266     # all defaults (base,*) sort ahead of all layers (layer,*,*)
 267
 268     puts "Specs $database_name:\n"
 269     for { set i 0 } { ($i < [llength $keys])
 270                       && [regexp {^base,(.*)$} [lindex $keys $i] \
 271                               -> name] } \
 272         { incr i } {
 273             puts "*$name:\n$specs([lindex $keys $i])\n"
 274         }
 275
 276     for { set prev "" } { ($i < [llength $keys])
 277                           && [regexp {^layer,([^,]+),(.*)$} [lindex $keys $i] \
 278                                   -> layer name] } \
 279         { incr i } {
 280             if { $prev ne $layer } {
 281                 puts "\[$layer\]"
 282                 set prev $layer
 283             }
 284             puts "*$name:\n$specs([lindex $keys $i])\n"
 285         }
 286 }
 287
 288 # Validate a specs database
 289 proc ::dejagnu::specs::validate_specs { database_name } {
 290     upvar 1 $database_name specs
 291
 292     # TODO
 293 }