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