diff options
Diffstat (limited to 'autosetup/proj.tcl')
| -rw-r--r-- | autosetup/proj.tcl | 492 |
1 files changed, 378 insertions, 114 deletions
diff --git a/autosetup/proj.tcl b/autosetup/proj.tcl index 133556706..5cebc0472 100644 --- a/autosetup/proj.tcl +++ b/autosetup/proj.tcl @@ -60,10 +60,11 @@ # $proj__Config is an internal-use-only array for storing whatever generic # internal stuff we need stored. # -array set ::proj__Config { - self-tests 1 -} - +array set ::proj__Config [subst { + self-tests [get-env proj.self-tests 0] + verbose-assert [get-env proj.assert-verbose 0] + isatty [isatty? stdout] +}] # # List of dot-in files to filter in the final stages of @@ -75,7 +76,6 @@ array set ::proj__Config { # See: proj-dot-ins-append and proj-dot-ins-process # set ::proj__Config(dot-in-files) [list] -set ::proj__Config(isatty) [isatty? stdout] # # @proj-warn msg @@ -85,28 +85,29 @@ set ::proj__Config(isatty) [isatty? stdout] # proc proj-warn {args} { show-notices - puts stderr [join [list "WARNING: \[[proj-scope 1]\]: " {*}$args] " "] + puts stderr [join [list "WARNING:" \[ [proj-scope 1] \]: {*}$args] " "] } +# # Internal impl of [proj-fatal] and [proj-error]. It must be called # using tailcall. -proc proj__faterr {failMode argv} { +# +proc proj__faterr {failMode args} { show-notices set lvl 1 - while {"-up" eq [lindex $argv 0]} { - set argv [lassign $argv -] + while {"-up" eq [lindex $args 0]} { + set args [lassign $args -] incr lvl } if {$failMode} { - puts stderr [join [list "FATAL: \[[proj-scope $lvl]]: " {*}$argv]] + puts stderr [join [list "FATAL:" \[ [proj-scope $lvl] \]: {*}$args]] exit 1 } else { - error [join [list "\[[proj-scope $lvl]]:" {*}$argv]] + error [join [list in \[ [proj-scope $lvl] \]: {*}$args]] } } - # # @proj-fatal ?-up...? msg... # @@ -118,7 +119,7 @@ proc proj__faterr {failMode argv} { # additional level. # proc proj-fatal {args} { - tailcall proj__faterr 1 $args + tailcall proj__faterr 1 {*}$args } # @@ -127,10 +128,9 @@ proc proj-fatal {args} { # Works like proj-fatal but uses [error] intead of [exit]. # proc proj-error {args} { - tailcall proj__faterr 0 $args + tailcall proj__faterr 0 {*}$args } -set ::proj__Config(verbose-assert) [get-env proj-assert-verbose 0] # # @proj-assert script ?message? # @@ -147,7 +147,7 @@ proc proj-assert {script {msg ""}} { if {"" eq $msg} { set msg $script } - proj-fatal "Assertion failed in \[[proj-scope 1]\]: $msg" + tailcall proj__faterr 1 "Assertion failed:" $msg } } @@ -885,7 +885,9 @@ proc proj-looks-like-windows {{key host}} { # proc proj-looks-like-mac {{key host}} { switch -glob -- [get-define $key] { - *apple* { + *-*-darwin* { + # https://sqlite.org/forum/forumpost/7b218c3c9f207646 + # There's at least one Linux out there which matches *apple*. return 1 } default { @@ -927,17 +929,13 @@ proc proj-exe-extension {} { # proc proj-dll-extension {} { set inner {{key} { - switch -glob -- [get-define $key] { - *apple* { - return ".dylib" - } - *-*-ming* - *-*-cygwin - *-*-msys { - return ".dll" - } - default { - return ".so" - } + if {[proj-looks-like-mac $key]} { + return ".dylib" + } + if {[proj-looks-like-windows $key]} { + return ".dll" } + return ".so" }} define BUILD_DLLEXT [apply $inner build] define TARGET_DLLEXT [apply $inner host] @@ -1665,7 +1663,7 @@ proc proj-dot-ins-append {fileIn args} { proj-fatal "Too many arguments: $fileIn $args" } } - #puts "******* [proj-scope]: adding $fileIn" + #puts "******* [proj-scope]: adding [llength $fileIn]-length item: $fileIn" lappend ::proj__Config(dot-in-files) $fileIn } @@ -1703,17 +1701,18 @@ proc proj-dot-ins-list {} { # makes proj-dot-ins-append available for re-use. # proc proj-dot-ins-process {args} { - proj-parse-simple-flags args flags { + proj-parse-flags args flags { -touch "" {return "-touch"} -clear 0 {expr 1} -validate 0 {expr 1} } + #puts "args=$args"; parray flags if {[llength $args] > 0} { error "Invalid argument to [proj-scope]: $args" } foreach f $::proj__Config(dot-in-files) { proj-assert {3==[llength $f]} \ - "Expecting proj-dot-ins-list to be stored in 3-entry lists" + "Expecting proj-dot-ins-list to be stored in 3-entry lists. Got: $f" lassign $f fIn fOut fScript #puts "DOING $fIn ==> $fOut" proj-make-from-dot-in {*}$flags(-touch) $fIn $fOut @@ -1753,7 +1752,7 @@ proc proj-validate-no-unresolved-ats {args} { set isMake [string match {*[Mm]ake*} $f] foreach line [proj-file-content-list $f] { if {!$isMake || ![string match "#*" [string trimleft $line]]} { - if {[regexp {(@[A-Za-z0-9_]+@)} $line match]} { + if {[regexp {(@[A-Za-z0-9_\.]+@)} $line match]} { error "Unresolved reference to $match at line $lnno of $f" } } @@ -1893,7 +1892,7 @@ proc proj-define-amend {args} { # proc proj-define-to-cflag {args} { set rv {} - proj-parse-simple-flags args flags { + proj-parse-flags args flags { -list 0 {expr 1} -quote 0 {expr 1} -zero-undef 0 {expr 1} @@ -2001,7 +2000,7 @@ proc proj-cache-key {arg {addLevel 0}} { # See proj-cache-key for -key's and -level's semantics, noting that # this function adds one to -level for purposes of that call. proc proj-cache-set {args} { - proj-parse-simple-flags args flags { + proj-parse-flags args flags { -key => 0 -level => 0 } @@ -2037,7 +2036,7 @@ proc proj-cache-remove {{key 0} {addLevel 0}} { # See proj-cache-key for $key's and $addLevel's semantics, noting that # this function adds one to $addLevel for purposes of that call. proc proj-cache-check {args} { - proj-parse-simple-flags args flags { + proj-parse-flags args flags { -key => 0 -level => 0 } @@ -2070,147 +2069,316 @@ proc proj-coalesce {args} { } # -# @proj-parse-simple-flags ... +# @proj-parse-flags argvListName targetArrayName {prototype} # # A helper to parse flags from proc argument lists. # -# Expects a list of arguments to parse, an array name to store any -# -flag values to, and a prototype object which declares the flags. +# The first argument is the name of a var holding the args to +# parse. It will be overwritten, possibly with a smaller list. # -# The prototype must be a list in one of the following forms: +# The second argument is the name of an array variable to create in +# the caller's scope. # -# -flag defaultValue {script} +# The third argument, $prototype, is a description of how to handle +# the flags. Each entry in that list must be in one of the +# following forms: # -# -flag => defaultValue -# -----^--^ (with spaces there!) +# -flag defaultValue ?-literal|-call|-apply? +# script|number|incr|proc-name|{apply $aLambda} # -# Repeated for each flag. +# -flag* ...as above... # -# The first form represents a basic flag with no associated -# following argument. The second form extracts its value -# from the following argument in $argvName. +# -flag => defaultValue ?-call proc-name-and-args|-apply lambdaExpr? # -# The first argument to this function is the name of a var holding the -# args to parse. It will be overwritten, possibly with a smaller list. +# -flag* => ...as above... # -# The second argument the name of an array variable to create in the -# caller's scope. (Pneumonic: => points to the next argument.) +# :PRAGMA # -# For the first form of flag, $script is run in the caller's scope if -# $argv contains -flag, and the result of that script is the new value -# for $tgtArrayName(-flag). This function intercepts [return $val] -# from $script. Any empty script will result in the flag having "" -# assigned to it. +# The first two forms represents a basic flag with no associated +# following argument. The third and fourth forms, called arg-consuming +# flags, extract the value from the following argument in $argvName +# (pneumonic: => points to the next argument.). The :PRAGMA form +# offers a way to configure certain aspects of this call. # -# The args list is only inspected until the first argument which is -# not described by $prototype. i.e. the first "non-flag" (not counting -# values consumed for flags defined like --flag=>default). +# If $argv contains any given flag from $prototype, its default value +# is overridden depending on several factors: # -# If a "--" flag is encountered, no more arguments are inspected as -# flags. If "--" is the first non-flag argument, the "--" flag is -# removed from the results but all remaining arguments are passed -# through. If "--" appears after the first non-flag, it is retained. +# - If the -literal flag is used, or the flag's script is a number, +# value is used verbatim. +# +# - Else if the -call flag is used, the argument must be a proc name +# and any leading arguments, e.g. {apply $myLambda}. The proc is passed +# the (flag, value) as arguments (non-consuming flags will get +# passed the flag's current/starting value and consuming flags will +# get the next argument). Its result becomes the result of the +# flag. +# +# - Else if -apply X is used, it's effectively shorthand for -call +# {apply X}. Its argument may either be a $lambaRef or a {{f v} +# {body}} construct. +# +# - Else if $script is one of the following values, it is treated as +# the result of... +# +# - incr: increments the current value of the flag. +# +# - Else $script is eval'd to get its result value. That result +# becomes the new flag value for $tgtArrayName(-flag). This +# function intercepts [return $val] from eval'ing $script. Any +# empty script will result in the flag having "" assigned to it. # -# This function assumes that each flag is unique, and using a flag -# more than once behaves in a last-one-wins fashion. +# Unless the -flag has a trailing asterisk, e.g. -flag*, this function +# assumes that each flag is unique, and using a flag more than once +# causes an error to be triggered. the -flag* forms works similarly +# except that may appear in $argv any number of times: # -# Any argvName entries not described in $prototype are not treated as -# flags. +# - For non-arg-consuming flags, each invocation of -flag causes the +# result of $script to overwrite the previous value. e.g. so +# {-flag* {x} {incr foo}} has a default value of x, but passing in +# -flag twice would change it to the result of incrementing foo +# twice. This form can be used to implement, e.g., increasing +# verbosity levels by passing -verbose multiple times. # -# Returns the number of flags it processed in $argvName. +# - For arg-consuming flags, the given flag starts with value X, but +# if the flag is provided in $argv, the default is cleared, then +# each instance of -flag causes its value to be appended to the +# result, so {-flag* => {a b c}} defaults to {a b c}, but passing +# in -flag y -flag z would change it to {y z}, not {a b c y z}.. +# +# By default, the args list is only inspected until the first argument +# which is not described by $prototype. i.e. the first "non-flag" (not +# counting values consumed for flags defined like -flag => default). +# The :all-flags pragma (see below) can modify this behavior. +# +# If a "--" flag is encountered, no more arguments are inspected as +# flags unless the :all-flags pragma (see below) is in effect. The +# first instance of "--" is removed from the target result list but +# all remaining instances of "--" are are passed through. +# +# Any argvName entries not described in $prototype are considered to +# be "non-flags" for purposes of this function, even if they +# ostensibly look like flags. +# +# Returns the number of flags it processed in $argvName, not counting +# "--". # # Example: # -# set args [list -foo -bar {blah} 8 9 10 -theEnd] -# proj-parse-simple-flags args flags { -# -foo 0 {expr 1} -# -bar => 0 -# -no-baz 2 {return 0} -# } +## set args [list -foo -bar {blah} -z 8 9 10 -theEnd] +## proj-parse-flags args flags { +## -foo 0 {expr 1} +## -bar => 0 +## -no-baz 1 {return 0} +## -z 0 2 +## } # -# After that $flags would contain {-foo 1 -bar {blah} -no-baz 2} +# After that $flags would contain {-foo 1 -bar {blah} -no-baz 1 -z 2} # and $args would be {8 9 10 -theEnd}. # -# Potential TODOs: consider using lappend instead of set so that any -# given flag can be used more than once. Or add a syntax to indicate -# that multiples are allowed. Also consider searching the whole -# argv list, rather than stopping at the first non-flag +# Pragmas: # -proc proj-parse-simple-flags {argvName tgtArrayName prototype} { +# Passing :PRAGMAS to this function may modify how it works. The +# following pragmas are supported (note the leading ":"): +# +# :all-flags indicates that the whole input list should be scanned, +# not stopping at the first non-flag or "--". +# +proc proj-parse-flags {argvName tgtArrayName prototype} { upvar $argvName argv - upvar $tgtArrayName tgt - array set dflt {} - array set scripts {} - array set consuming {} + upvar $tgtArrayName outFlags + array set flags {}; # staging area + array set blob {}; # holds markers for various per-key state and options + set incrSkip 1; # 1 if we stop at the first non-flag, else 0 + # Parse $prototype for flag definitions... set n [llength $prototype] - # Figure out what our flags are... + set checkProtoFlag { + #puts "**** checkProtoFlag #$i of $n k=$k fv=$fv" + switch -exact -- $fv { + -literal { + proj-assert {![info exists blob(${k}.consumes)]} + set blob(${k}.script) [list expr [lindex $prototype [incr i]]] + } + -apply { + set fv [lindex $prototype [incr i]] + if {2 == [llength $fv]} { + # Treat this as a lambda literal + set fv [list $fv] + } + lappend blob(${k}.call) "apply $fv" + } + -call { + # arg is either a proc name or {apply $aLambda} + set fv [lindex $prototype [incr i]] + lappend blob(${k}.call) $fv + } + default { + proj-assert {![info exists blob(${k}.consumes)]} + set blob(${k}.script) $fv + } + } + if {$i >= $n} { + proj-error -up "[proj-scope]: Missing argument for $k flag" + } + } for {set i 0} {$i < $n} {incr i} { set k [lindex $prototype $i] #puts "**** #$i of $n k=$k" + + # Check for :PRAGMA... + switch -exact -- $k { + :all-flags { + set incrSkip 0 + continue + } + } + proj-assert {[string match -* $k]} \ - "Invalid flag value: $k" - set v "" - set s "" + "Invalid argument: $k" + + if {[string match {*\*} $k]} { + # Re-map -foo* to -foo and flag -foo as a repeatable flag + set k [string map {* ""} $k] + incr blob(${k}.multi) + } + + if {[info exists flags($k)]} { + proj-error -up "[proj-scope]: Duplicated prototype for flag $k" + } + switch -exact -- [lindex $prototype [expr {$i + 1}]] { => { + # -flag => DFLT ?-subflag arg? incr i 2 if {$i >= $n} { - proj-error "Missing argument for $k => flag" + proj-error -up "[proj-scope]: Missing argument for $k => flag" + } + incr blob(${k}.consumes) + set vi [lindex $prototype $i] + if {$vi in {-apply -call}} { + proj-error -up "[proj-scope]: Missing default value for $k flag" + } else { + set fv [lindex $prototype [expr {$i + 1}]] + if {$fv in {-apply -call}} { + incr i + eval $checkProtoFlag + } } - set consuming($k) 1 - set v [lindex $prototype $i] } default { - set v [lindex $prototype [incr i]] - set s [lindex $prototype [incr i]] - set scripts($k) $s + # -flag VALUE ?flag? SCRIPT + set vi [lindex $prototype [incr i]] + set fv [lindex $prototype [incr i]] + eval $checkProtoFlag } } - #puts "**** #$i of $n k=$k v=$v s=$s" - set dflt($k) $v + #puts "**** #$i of $n k=$k vi=$vi" + set flags($k) $vi } - # Now look for those flags in the source list - array set tgt [array get dflt] - unset dflt + #puts "-- flags"; parray flags + #puts "-- blob"; parray blob set rc 0 - set rv {} + set rv {}; # staging area for the target argv value set skipMode 0 set n [llength $argv] + # Now look for those flags in $argv... for {set i 0} {$i < $n} {incr i} { set arg [lindex $argv $i] + #puts "-- [proj-scope] arg=$arg" if {$skipMode} { lappend rv $arg } elseif {"--" eq $arg} { - incr skipMode - } elseif {[info exists tgt($arg)]} { - if {[info exists consuming($arg)]} { - if {$i + 1 >= $n} { - proj-assert 0 {Cannot happen - bounds already checked} + # "--" is the conventional way to end processing of args + if {[incr blob(--)] > 1} { + # Elide only the first one + lappend rv $arg + } + incr skipMode $incrSkip + } elseif {[info exists flags($arg)]} { + # A known flag... + set isMulti [info exists blob(${arg}.multi)] + incr blob(${arg}.seen) + if {1 < $blob(${arg}.seen) && !$isMulti} { + proj-error -up [proj-scope] "$arg flag was used multiple times" + } + set vMode 0; # 0=as-is, 1=eval, 2=call + set isConsuming [info exists blob(${arg}.consumes)] + if {$isConsuming} { + incr i + if {$i >= $n} { + proj-error -up [proj-scope] "is missing argument for $arg flag" } - set tgt($arg) [lindex $argv [incr i]] - } elseif {"" eq $scripts($arg)} { - set tgt($arg) "" + set vv [lindex $argv $i] + } elseif {[info exists blob(${arg}.script)]} { + set vMode 1 + set vv $blob(${arg}.script) } else { - #puts "**** running scripts($arg) $scripts($arg)" - set code [catch {uplevel 1 $scripts($arg)} xrc xopt] - #puts "**** tgt($arg)=$scripts($arg) code=$code rc=$rc" - if {$code in {0 2}} { - set tgt($arg) $xrc + set vv $flags($arg) + } + + if {[info exists blob(${arg}.call)]} { + set vMode 2 + set vv [concat {*}$blob(${arg}.call) $arg $vv] + } elseif {$isConsuming} { + proj-assert {!$vMode} + # fall through + } elseif {"" eq $vv || [string is double -strict $vv]} { + set vMode 0 + } elseif {$vv in {incr}} { + set vMode 0 + switch -exact $vv { + incr { + set xx $flags($k); incr xx; set vv $xx; unset xx + } + default { + proj-error "Unhandled \$vv value $vv" + } + } + } else { + set vv [list eval $vv] + set vMode 1 + } + if {$vMode} { + set code [catch [list uplevel 1 $vv] vv xopt] + if {$code ni {0 2}} { + return {*}$xopt $vv + } + } + if {$isConsuming && $isMulti} { + if {1 == $blob(${arg}.seen)} { + # On the first hit, overwrite the default with a new list. + set flags($arg) [list $vv] } else { - return {*}$xopt $xrc + # On subsequent hits, append to the list. + lappend flags($arg) $vv } + } else { + set flags($arg) $vv } incr rc } else { - incr skipMode + # Non-flag + incr skipMode $incrSkip lappend rv $arg } } set argv $rv + array set outFlags [array get flags] + #puts "-- rv=$rv argv=$argv flags="; parray flags return $rc +}; # proj-parse-flags + +# +# Older (deprecated) name of proj-parse-flags. +# +proc proj-parse-simple-flags {args} { + tailcall proj-parse-flags {*}$args } if {$::proj__Config(self-tests)} { + set __ova $::proj__Config(verbose-assert); + set ::proj__Config(verbose-assert) 1 + puts "Running [info script] self-tests..." + # proj-cache... apply {{} { #proj-warn "Test code for proj-cache" proj-assert {![proj-cache-check -key here check]} @@ -2233,4 +2401,100 @@ if {$::proj__Config(self-tests)} { proj-assert {"" eq [proj-cache-remove]} proj-assert {"" eq $check} }} -} + + # proj-parse-flags ... + apply {{} { + set foo 3 + set argv {-a "hi - world" -b -b -b -- -a {bye bye} -- -d -D c -a "" --} + proj-parse-flags argv flags { + :all-flags + -a* => "gets overwritten" + -b* 7 {incr foo} + -d 1 0 + -D 0 1 + } + + #puts "-- argv = $argv"; parray flags; + proj-assert {"-- c --" eq $argv} + proj-assert {$flags(-a) eq "{hi - world} {bye bye} {}"} + proj-assert {$foo == 6} + proj-assert {$flags(-b) eq $foo} + proj-assert {$flags(-d) == 0} + proj-assert {$flags(-D) == 1} + set foo 0 + foreach x $flags(-a) { + proj-assert {$x in {{hi - world} {bye bye} {}}} + incr foo + } + proj-assert {3 == $foo} + + set argv {-a {hi world} -b -maybe -- -a {bye bye} -- -b c --} + set foo 0 + proj-parse-flags argv flags { + -a => "aaa" + -b 0 {incr foo} + -maybe no -literal yes + } + #parray flags; puts "--- argv = $argv" + proj-assert {"-a {bye bye} -- -b c --" eq $argv} + proj-assert {$flags(-a) eq "hi world"} + proj-assert {1 == $flags(-b)} + proj-assert {"yes" eq $flags(-maybe)} + + set argv {-f -g -a aaa -M -M -M -L -H -A AAA a b c} + set foo 0 + set myLambda {{flag val} { + proj-assert {$flag in {-f -g -M}} + #puts "myLambda flag=$flag val=$val" + incr val + }} + proc myNonLambda {flag val} { + proj-assert {$flag in {-A -a}} + #puts "myNonLambda flag=$flag val=$val" + concat $val $val + } + proj-parse-flags argv flags { + -f 0 -call {apply $myLambda} + -g 2 -apply $myLambda + -h 3 -apply $myLambda + -H 30 33 + -a => aAAAa -apply {{f v} { + set v + }} + -A => AaaaA -call myNonLambda + -B => 17 -call myNonLambda + -M* 0 -apply $myLambda + -L "" -literal $myLambda + } + rename myNonLambda "" + #puts "--- argv = $argv"; parray flags + proj-assert {$flags(-f) == 1} + proj-assert {$flags(-g) == 3} + proj-assert {$flags(-h) == 3} + proj-assert {$flags(-H) == 33} + proj-assert {$flags(-a) == {aaa}} + proj-assert {$flags(-A) eq "AAA AAA"} + proj-assert {$flags(-B) == 17} + proj-assert {$flags(-M) == 3} + proj-assert {$flags(-L) eq $myLambda} + + set argv {-touch -validate} + proj-parse-flags argv flags { + -touch "" {return "-touch"} + -validate 0 1 + } + #puts "----- argv = $argv"; parray flags + proj-assert {$flags(-touch) eq "-touch"} + proj-assert {$flags(-validate) == 1} + proj-assert {$argv eq {}} + + set argv {-i -i -i} + proj-parse-flags argv flags { + -i* 0 incr + } + proj-assert {3 == $flags(-i)} + }} + set ::proj__Config(verbose-assert) $__ova + unset __ova + puts "Done running [info script] self-tests." +}; # proj- API self-tests |