diff options
| -rw-r--r-- | ChangeLog | 4 | ||||
| -rw-r--r-- | lib/specs.exp | 294 | ||||
| -rw-r--r-- | testsuite/runtest.libs/specs.test | 162 |
3 files changed, 460 insertions, 0 deletions
@@ -1,3 +1,7 @@ +2021-04-14 Jacob Bachmeyer <jcb@gnu.org> + + * lib/specs.exp, testsuite/runtest.libs/specs.test: New files. + 2021-03-22 Jacob Bachmeyer <jcb@gnu.org> * configure: Regenerate. diff --git a/lib/specs.exp b/lib/specs.exp new file mode 100644 index 0000000..457b4ed --- /dev/null +++ b/lib/specs.exp @@ -0,0 +1,294 @@ +# Copyright (C) 2021 Free Software Foundation, Inc. +# +# This file is part of DejaGnu. +# +# DejaGnu 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 3 of the License, or +# (at your option) any later version. +# +# DejaGnu 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 DejaGnu; if not, write to the Free Software Foundation, +# Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1301, USA. + +# This file was written by Jacob Bachmeyer. + +# Procedures for handling specs strings similar to those used in GCC. + +# These spec strings support substitutions introduced using "%": +# +# %% -- literal "%" character +# %{...} -- substitute data value with recursive evaluation +# %[...] -- evaluate Tcl code and substitute result literally +# +# All other uses of "%" in specs strings are reserved. Data item names +# containing colon (":") are generally reserved for future expansion; a few +# are currently used as shorthand for certain DejaGnu API calls. +# Convention for hierarchical name parts is separation using ".", while "/" +# is used for variations intended to be selected using another value. + +# Specs are stored in a Tcl array, referred to as the "database" array. +# Spec strings are organized into layers, providing a hierarchical +# structure of fallback and default values by searching layers in the order +# given by the "_layers" option. + +# The external data structures used by this module are mostly association +# lists, but they are internally referenced using Tcl arrays. + +# All procedures in this module are currently internal to DejaGnu and +# subject to change without notice. +namespace eval ::dejagnu::specs { + namespace export eval_specs validate_specs +} + +# Expand one data substitution token. +# internal procedure; uses SPECS and OPTION arrays in caller's context +proc ::dejagnu::specs::subst_token { key } { + upvar 1 specs specs option option + + # check for an option first + if { [info exists option($key)] } { + return $option($key) + } + + # check for a board configuration value + if { [regexp {^board_info\(([^)]+)\):(.*)$} $key -> machine info_key] } { + return [board_info $machine $info_key] + } + + # search the specs database if a layer path was given + if { [info exists option(_layers)] } { + foreach layer $option(_layers) { + if { [info exists specs(layer,$layer,$key)] } { + return $specs(layer,$layer,$key) + } + } + } + + # check for suitable default entry in the specs database + if { [info exists specs(base,$key)] } { + return $specs(base,$key) + } + + error "unresolved specs token: $key" +} + +# Evaluate excess open or close delimiters. +proc ::dejagnu::specs::delimiter_balance { text } { + # first, remove all backslashes that cannot quote delimiters + regsub -all {\\+[^][\\{}]} $text "" text + # strip backslash-quoted backslashes + regsub -all {(?:\\{2})+} $text "" text + # strip backslash-quoted delimiters + regsub -all {(^|[^\\])\\[][{}]} $text "\\1" text + # remove all unrelated characters + regsub -all {[^][{}]+} $text "" text + + # separate the text into only-left and only-right subsets + regsub -all "\\\\*\[\]\}\]" $text "" left + regsub -all "\\\\*\[\[\{\]" $text "" right + + return [expr { [string length $left] - [string length $right] }] +} + +# Find the end of a token. +proc ::dejagnu::specs::token_end { text start end_pat } { + set balance 1 + set point $start + while { $balance > 0 } { + regexp -indices -start [expr { 1 + $point }] -- $end_pat $text item + set point [lindex $item 0] + # optimization: if delimiter_balance returns N, we need at least N + # more closing delimiters, but that could be any combination of + # braces and brackets, not only the main endpoint delimiter + for { + set balance [delimiter_balance [string range $text $start $point]] + } { $balance > 1 } { incr balance -1 } { + regexp -indices -start [expr { 1 + $point }] -- \ + "\[\\\}\\\]\]" $text item + set point [lindex $item 0] + } + } + return [lindex $item 1] +} + +# Abstract parsing loop. +# internal procedure; sets TOKEN variable in caller's context +proc ::dejagnu::specs::scan_specs_string { text literal char data code } { + upvar 1 token token + + for { + set mark -1 + set point 0 + } { [regexp -indices -start $point -- {%.} $text item] } { + set point [expr { 1 + $mark }] + } { + # extract literal from preceding range + set token [string range $text \ + [expr { $mark + 1 }] \ + [expr { [lindex $item 0] - 1 }]] + uplevel 1 $literal + # advance point + set point [lindex $item 1] + # extract first character of substitution + set enter [string index $text $point] + if { $enter eq "%" } { + # %% -- literal "%" + set mark $point + uplevel 1 $char + } elseif { $enter eq "\{" } { + # %{...} -- substitute data item + set mark [token_end $text $point "\\\}"] + set token [string range $text \ + [expr { $point + 1 }] [expr { $mark - 1 }]] + uplevel 1 $data + } elseif { $enter eq "\[" } { + # %[...] -- substitute value from Tcl code fragment + set mark [token_end $text $point "\\\]"] + set token [string range $text \ + [expr { $point + 1 }] [expr { $mark - 1 }]] + uplevel 1 $code + } else { + error "unrecognized sequence %$enter in spec string" + } + } + # leave the trailing literal in TOKEN + set token [string range $text [expr { $mark + 1 }] end] +} + +# Generate parse report for specs string; for debugging +proc ::dejagnu::specs::parse_specs_string { text } { + set tokens [list] + scan_specs_string $text { + # intervening literal text + lappend tokens [list text $token] + } { # %% escape + lappend tokens [list text %] + } { # data item + lappend tokens [list data $token] + } { # code item + lappend tokens [list code $token] + } + lappend tokens [list text $token] + return $tokens +} + +# Expand substitutions in specs string. +# internal procedure; uses SPECS and OPTION arrays and BASE_LEVEL variable +# in caller's context +proc ::dejagnu::specs::eval_specs_string { text } { + upvar 1 specs specs option option base_level base_level + + set output "" + scan_specs_string $text { + # copy intervening literal text to output + append output $token + } { + # emit "%" where string contains "%%" + append output "%" + } { + # substitute data item + append output [eval_specs_string \ + [subst_token [eval_specs_string $token]]] + } { + # evaluate Tcl code fragment + append output [uplevel "#$base_level" [eval_specs_string $token]] + } + # copy trailing literal + append output $token + + return $output +} + +# Check that the provided specs string can be evaluated; that is, that all +# substitutions have definitions. +# internal procedure; uses SPECS and OPTION arrays in caller's context +proc ::dejagnu::specs::validate_specs_string { text } { + upvar 1 specs specs option option + + scan_specs_string $text { + # ignore literal text + } { + # ignore literal "%" + } { + # check substitution + } { + # check Tcl code fragment + } + # ignore trailing literal + + # an error is thrown if validation fails + return 1 +} + +# Perform spec substitutions to evaluate %{GOAL}. +# +# The DATABASE_NAME is the name (in the caller's context) of the database +# array to use, while OPTIONS is a list of additional KEY VALUE pairs that +# should be available for substitution. +proc ::dejagnu::specs::eval_specs { database_name goal options } { + upvar 1 $database_name specs + array set option $options + set base_level [expr { [info level] - 1 }] + + return [eval_specs_string "%{$goal}"] +} + +# Load specs strings into DATABASE_NAME; as: +# load_specs DATABASE_NAME BASE_STRINGS (LAYER_NAME LAYER_STRINGS)... +# to load only into a layer: +# load_specs DATABASE_NAME {} LAYER_NAME LAYER_STRINGS +proc ::dejagnu::specs::load_specs { database_name base_strings args } { + upvar 1 $database_name specs + + if { ([llength $args] & 1) != 0 } { + error "specs layer names and contents must be in pairs" + } + foreach {k v} $base_strings { + set specs(base,$k) $v + } + foreach {layer layer_strings} $args { + foreach {k v} $layer_strings { + set specs(layer,$layer,$k) $v + } + } +} + +# Display contents of specs database array; for debugging +proc ::dejagnu::specs::dump_specs { database_name } { + upvar 1 $database_name specs + + set keys [lsort -dictionary [array names specs]] + # all defaults (base,*) sort ahead of all layers (layer,*,*) + + puts "Specs $database_name:\n" + for { set i 0 } { ($i < [llength $keys]) + && [regexp {^base,(.*)$} [lindex $keys $i] \ + -> name] } \ + { incr i } { + puts "*$name:\n$specs([lindex $keys $i])\n" + } + + for { set prev "" } { ($i < [llength $keys]) + && [regexp {^layer,([^,]+),(.*)$} [lindex $keys $i] \ + -> layer name] } \ + { incr i } { + if { $prev ne $layer } { + puts "\[$layer\]" + set prev $layer + } + puts "*$name:\n$specs([lindex $keys $i])\n" + } +} + +# Validate a specs database +proc ::dejagnu::specs::validate_specs { database_name } { + upvar 1 $database_name specs + + # TODO +} diff --git a/testsuite/runtest.libs/specs.test b/testsuite/runtest.libs/specs.test new file mode 100644 index 0000000..d6eac07 --- /dev/null +++ b/testsuite/runtest.libs/specs.test @@ -0,0 +1,162 @@ +# Test procedures in lib/specs.exp -*- Tcl -*- + +# Copyright (C) 2021 Free Software Foundation, Inc. +# +# This file is part of DejaGnu. +# +# DejaGnu 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 3 of the License, or +# (at your option) any later version. +# +# DejaGnu 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 DejaGnu; if not, write to the Free Software Foundation, +# Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1301, USA. + +source $srcdir/$subdir/default_procs.tcl + +proc load_lib { lib } { + global srcdir + source $srcdir/../lib/$lib +} + +foreach lib { targetdb specs } { + source $srcdir/../lib/${lib}.exp +} + +# +# Create a false board config array +# +set board_info(baz,name) "baz" +set board_info(baz,ldscript) "-Tbaz.ld" +set board_info(quux,name) "quux" +set board_info(quux,ldscript) "-specs quux.specs" +set board_info(quux,other) "-mquux" + +::dejagnu::specs::load_specs test_specs { + one 1 + two 2 + three 3 + + percent {%%} + + base_test {%{two} %{one} %{three}} + esc_test_1 {%{two} %% %{three}} + esc_test_2 {%{one} %{percent} %{three}} + + + mapped/asc {%{one} %{two} %{three}} + mapped/desc {%{three} %{two} %{one}} + + mapped/ {%{mapped/asc}} + mapped_order asc + + map_test {%{mapped/%{mapped_order}}} + + + args {} + + call_test_1 {%[test_proc_1]} + call_test_2 {%[test_proc_2 %{args}]} + + + board {} + key {ldscript} + + board_test {%{board_info(%{board}):%{key}}} +} foo { + one 4 + three 6 +} bar { + two 8 + three 9 +} + +# test procedures for %[...] tests +proc test_proc_1 {} { return "test-1" } +proc test_proc_2 { args } { return "[llength $args]: $args" } + +# simple wrapper to bring global spec database into current scope +proc eval_specs { database_name goal options } { + global $database_name + ::dejagnu::specs::eval_specs $database_name $goal $options +} + +run_tests { + { "#" simple substitutions } + { lib_ret_test eval_specs {test_specs base_test {}} + {2 1 3} + "evaluate simple spec substitutions" } + { lib_ret_test eval_specs {test_specs base_test {one 5}} + {2 5 3} + "evaluate simple spec substitutions with option as override" } + { lib_ret_test eval_specs {test_specs esc_test_1 {}} + {2 % 3} + "evaluate simple spec substitutions with literal %" } + { lib_ret_test eval_specs {test_specs esc_test_2 {}} + {1 % 3} + "evaluate simple spec substitutions with literal % substituted" } + + { "#" layer search path } + { lib_ret_test eval_specs {test_specs base_test {_layers {foo}}} + {2 4 6} + "use layer 'foo'" } + { lib_ret_test eval_specs {test_specs base_test {_layers {bar}}} + {8 1 9} + "use layer 'bar'" } + { lib_ret_test eval_specs {test_specs base_test {_layers {foo bar}}} + {8 4 6} + "use layers 'foo' and 'bar'" } + { lib_ret_test eval_specs {test_specs base_test {_layers {bar foo}}} + {8 4 9} + "use layers 'bar' and 'foo'" } + + { "#" value-map substitutions } + { lib_ret_test eval_specs {test_specs map_test {}} + {1 2 3} + "mapped-value substitution as default" } + { lib_ret_test eval_specs {test_specs map_test {mapped_order desc}} + {3 2 1} + "mapped-value substitution with option as override" } + { lib_ret_test eval_specs {test_specs map_test {mapped_order ""}} + {1 2 3} + "mapped-value substitution with empty selector" } + { lib_errpat_test eval_specs {test_specs map_test {mapped_order bogus}} + {*mapped/bogus*} + "error if mapped value refers to non-existent spec string" } + + { "#" procedure-call substitutions } + { lib_ret_test eval_specs {test_specs call_test_1 {}} + {test-1} + "substitute arity 0 procedure call result" } + { lib_ret_test eval_specs {test_specs call_test_2 {}} + {0: } + "substitute procedure call result with no arguments" } + { lib_ret_test eval_specs {test_specs call_test_2 {args {%{base_test}}}} + {3: 2 1 3} + "substitute procedure call result with substituted arguments" } + { lib_ret_test eval_specs {test_specs call_test_2 {args {%%{one}}}} + {1: %{one}} + "substitutions not evaluated in procedure call result" } + + { "#" board_info substitutions } + { lib_ret_test eval_specs {test_specs board_test {board baz key other}} + {} + "empty result for non-existent key" } + { lib_ret_test eval_specs {test_specs board_test {board baz}} + {-Tbaz.ld} + "find 'ldscript' key for board 'baz'" } + { lib_ret_test eval_specs {test_specs board_test {board quux}} + {-specs quux.specs} + "find 'ldscript' key for board 'quux'" } + { lib_ret_test eval_specs {test_specs board_test {board quux key other}} + {-mquux} + "find 'other' key for board 'quux'" } +} + +puts "END specs.test" |