From 4e23a2c373f2df51545b88d912ef34200c52fd0f Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Mon, 13 Jul 2026 15:23:46 +1000 Subject: [PATCH] vfs: sync punk::args 0.12.0 and tclcore moduledoc 0.3.4 into _vfscommon.vfs (G-074) make.tcl modules + vfscommonupdate; old versions (args-0.11.2, tclcore-0.3.3) removed by the update. All four kits (punkbi, punksys, punk91, punk902z) rebuilt from the updated vfs and verified in kit mode: punk902z (9.0.2) and punksys (8.6.13) both load args=0.12.0 tclcore=0.3.4, punk::args::formcheck reports ::after as 6 forms / 15 pairs / 1 sanctioned structural overlap (cancelid/cancelscript, zero unsanctioned) and ::lseq as the two unsanctioned type_weakness findings ({range start_count} {range count}) on both runtimes. Assisted-by: harness=claude; primary-model=claude-fable-5; api-location=anthropic.com --- .../punk/{args-0.11.2.tm => args-0.12.0.tm} | 482 +++++++++++++++++- .../{tclcore-0.3.3.tm => tclcore-0.3.4.tm} | 12 +- 2 files changed, 487 insertions(+), 7 deletions(-) rename src/vfs/_vfscommon.vfs/modules/punk/{args-0.11.2.tm => args-0.12.0.tm} (97%) rename src/vfs/_vfscommon.vfs/modules/punk/args/moduledoc/{tclcore-0.3.3.tm => tclcore-0.3.4.tm} (99%) diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args-0.11.2.tm b/src/vfs/_vfscommon.vfs/modules/punk/args-0.12.0.tm similarity index 97% rename from src/vfs/_vfscommon.vfs/modules/punk/args-0.11.2.tm rename to src/vfs/_vfscommon.vfs/modules/punk/args-0.12.0.tm index 5622a59d..33388cdb 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/args-0.11.2.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/args-0.12.0.tm @@ -8,7 +8,7 @@ # (C) 2024 # # @@ Meta Begin -# Application punk::args 0.11.2 +# Application punk::args 0.12.0 # Meta platform tcl # Meta license # @@ Meta End @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin punkshell_module_punk::args 0 0.11.2] +#[manpage_begin punkshell_module_punk::args 0 0.12.0] #[copyright "2024"] #[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] #[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] @@ -820,8 +820,17 @@ tcl::namespace::eval punk::args { %B%@form%N% ?opt val...? (used for commands with multiple forms) directive-options: -form -synopsis + -overlapallowed The -synopsis value allows overriding the auto-calculated synopsis. + The -overlapallowed value names other forms this form is + KNOWN to overlap with (an argument list can cleanly match + both - e.g 'after cancel ' where real Tcl + disambiguates by runtime state). It sanctions the overlap + for punk::args::formcheck reporting only - parse behaviour + is unaffected (an ambiguous argument list still raises + multipleformmatches). Unknown form names are rejected when + the definition is resolved. %B%@formdisplay%N% ?opt val...? directive-options: -header (text for header row of table) -body (override autogenerated arg info for form) @@ -3606,6 +3615,19 @@ tcl::namespace::eval punk::args { dict for {fid FDICT} $F { dict set F $fid {} ;#detach + #G-074: @form -overlapallowed sanctions a known form overlap for + #punk::args::formcheck reporting - it must name forms that exist in this + #definition. Validated here because all forms have been created by now. + #(the current form's key still exists in F while detached - self-reference + #is pointless but harmless and not rejected) + if {[dict exists $FDICT -overlapallowed]} { + foreach oaform [dict get $FDICT -overlapallowed] { + if {![dict exists $F $oaform]} { + error "punk::args::resolve - @form -overlapallowed for form '$fid' names unknown form '$oaform' (known forms: [dict keys $F]) @id:$DEF_definition_id" + } + } + } + #set mashargs [dict get $F $fid OPT_MASHES] set mashargs [dict get $FDICT OPT_MASHES] if {[llength $mashargs]} { @@ -6979,6 +7001,460 @@ tcl::namespace::eval punk::args { return $ranked } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + #G-074 punk::args::formcheck - on-demand multiform ambiguity analysis. + #Static pairwise pass over a definition's resolved FORMS: enumerate the positional + #word-slot chains each form can present, derive candidate witness arglists for + #aligned chains of equal length, and CONFIRM each candidate by parsing the witness + #against both forms (parse_status - no error raise, no user-supplied words). + #Only a witnessed overlap is reported, so fully discriminated form pairs cannot + #false-alarm; the documented miss direction is witness derivation - exotic types + #without a derivable witness word, required options (options are excluded from the + #positional model), and enumeration caps (-multiple repetitions, chain counts). + #Nothing here runs at define/resolve time apart from the cheap -overlapallowed + #known-form validation. + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + #enumerate the positional word-slot chains a form can present - leaders then values, + #branching on -optional arguments and ?-wrapped optional clause members, with + #-multiple arguments capped at multiple_cap repetitions (same member pattern per + #repetition). Each chain is a list of slots {arg type } - one + #slot per word position. @leaders/@values min/max windows are not re-checked here: + #every candidate overlap is confirmed by a real parse before being reported. + proc private::formcheck_chains {formdict {multiple_cap 2} {chain_cap 400}} { + set ARG_INFO [dict get $formdict ARG_INFO] + set chains [list {}] + foreach argname [list {*}[dict get $formdict LEADER_NAMES] {*}[dict get $formdict VAL_NAMES]] { + set typelist [dict get $ARG_INFO $argname -type] + #member patterns for a single occurrence of this argument + set patterns [list {}] + foreach tp $typelist { + if {[string match {\?*\?} $tp]} { + set inclusions [list "" [string trim $tp ?]] + } else { + set inclusions [list $tp] + } + set withmember [list] + foreach p $patterns { + foreach inc $inclusions { + if {$inc eq ""} { + lappend withmember $p + } else { + lappend withmember [list {*}$p $inc] + } + } + } + set patterns $withmember + } + #an occurrence consumes at least one word + set occurrence_patterns [lsearch -all -inline -not -exact $patterns {}] + if {![llength $occurrence_patterns]} { + continue + } + if {[dict get $ARG_INFO $argname -multiple]} { + set max_occurrences $multiple_cap + } else { + set max_occurrences 1 + } + if {[dict get $ARG_INFO $argname -optional]} { + set min_occurrences 0 + } else { + set min_occurrences 1 + } + set newchains [list] + foreach chain $chains { + for {set occ $min_occurrences} {$occ <= $max_occurrences} {incr occ} { + if {$occ == 0} { + lappend newchains $chain + continue + } + foreach pat $occurrence_patterns { + set extended $chain + for {set r 0} {$r < $occ} {incr r} { + foreach membertype $pat { + lappend extended [dict create arg $argname type $membertype] + } + } + lappend newchains $extended + } + } + } + set chains $newchains + if {[llength $chains] > $chain_cap} { + #conservative truncation (documented miss direction) + set chains [lrange $chains 0 $chain_cap-1] + } + } + return $chains + } + + #static description of one positional slot for overlap screening: + # disc 1 if the slot is a discriminator (literal/literalprefix alternates + # or a restricted choice set - the same notion as form_literal_affinity) + # discwords the discriminator's words (choice words, literal values) + # permissive 1 if any type alternate performs no word validation (any/none/string/ + # ansistring/globstring/expr/script) - the 'type-weakness' side + # witnesses candidate words derivable from the types (a word satisfying the type) + proc private::formcheck_slotinfo {formdict slot} { + set ARG_INFO [dict get $formdict ARG_INFO] + set argname [dict get $slot arg] + set tp [string trim [dict get $slot type] ?] + set disc 0 + set discwords [list] + set permissive 0 + set witnesses [list] + if {[dict exists $ARG_INFO $argname -choices] || [dict exists $ARG_INFO $argname -choicegroups]} { + set choicewords [list] + if {[dict exists $ARG_INFO $argname -choices]} { + lappend choicewords {*}[dict get $ARG_INFO $argname -choices] + } + if {[dict exists $ARG_INFO $argname -choicegroups]} { + dict for {_grp grpmembers} [dict get $ARG_INFO $argname -choicegroups] { + lappend choicewords {*}$grpmembers + } + } + if {[Dict_getdef $ARG_INFO $argname -choicerestricted 1]} { + set disc 1 + lappend discwords {*}$choicewords + } else { + #unrestricted choices don't discriminate but their words satisfy validation + lappend witnesses {*}$choicewords + } + } + foreach alt [split_type_expression $tp] { + if {[llength $alt] == 2} { + lassign $alt t param + switch -exact -- $t { + literal - literalprefix { + set disc 1 + lappend discwords $param + } + stringstartswith - stringendswith - stringcontains { + lappend witnesses $param + } + default {} + } + } else { + switch -exact -- $alt { + any - none - string - ansistring - globstring - expr - script - "" { + set permissive 1 + } + int - integer - number - bool - boolean { + lappend witnesses 1 + } + double { + lappend witnesses 1.5 + } + list { + lappend witnesses x + } + dict { + lappend witnesses {k v} + } + default {} + } + } + } + if {$permissive} { + lappend witnesses x + } + return [dict create disc $disc discwords $discwords permissive $permissive witnesses $witnesses] + } + + #static acceptance screen of a word against a slot - returns yes|no|maybe. + #Restricted choice sets are screened via choiceword_match (the shared G-040 + #resolver) so screening cannot diverge from parse acceptance; type alternates the + #screen doesn't model return maybe - the confirming parse decides. This screen only + #prunes candidate witnesses: a wrongly optimistic maybe costs a parse attempt, it + #cannot produce a false finding. + proc private::formcheck_slot_accepts {formdict slot word} { + set ARG_INFO [dict get $formdict ARG_INFO] + set argname [dict get $slot arg] + set tp [string trim [dict get $slot type] ?] + if {([dict exists $ARG_INFO $argname -choices] || [dict exists $ARG_INFO $argname -choicegroups]) + && [Dict_getdef $ARG_INFO $argname -choicerestricted 1]} { + #a restricted choice set rejects non-choice words regardless of type + set cw_allchoices [list] + if {[dict exists $ARG_INFO $argname -choices]} { + lappend cw_allchoices {*}[dict get $ARG_INFO $argname -choices] + } + if {[dict exists $ARG_INFO $argname -choicegroups]} { + dict for {_grp grpmembers} [dict get $ARG_INFO $argname -choicegroups] { + lappend cw_allchoices {*}$grpmembers + } + } + set cwm [choiceword_match $word\ + [Dict_getdef $ARG_INFO $argname -nocase 0]\ + $cw_allchoices\ + [Dict_getdef $ARG_INFO $argname -choicealiases {}]\ + [Dict_getdef $ARG_INFO $argname -choiceprefix 1]\ + [Dict_getdef $ARG_INFO $argname -choiceprefixdenylist {}]\ + [Dict_getdef $ARG_INFO $argname -choiceprefixreservelist {}]\ + ] + return [expr {[dict get $cwm matched] ? "yes" : "no"}] + } + set has_maybe 0 + foreach alt [split_type_expression $tp] { + if {[llength $alt] == 2} { + lassign $alt t param + switch -exact -- $t { + literal { + if {$word eq $param} {return yes} + } + literalprefix { + if {$word ne "" && [string equal -length [string length $word] $word $param]} {return yes} + } + stringstartswith { + if {[string range $word 0 [string length $param]-1] eq $param} {return yes} + } + stringendswith { + set param_last [expr {[string length $param]-1}] + if {$param eq "" || [string range $word end-$param_last end] eq $param} {return yes} + } + stringcontains { + if {[string first $param $word] >= 0} {return yes} + } + default { + set has_maybe 1 + } + } + } else { + switch -exact -- $alt { + any - none - string - ansistring - globstring - expr - script - "" { + return yes + } + int - integer { + if {[string is integer -strict $word]} {return yes} + } + number - double { + if {[string is double -strict $word]} {return yes} + } + bool - boolean { + if {[string is boolean -strict $word]} {return yes} + } + list { + if {![catch {llength $word}]} {return yes} + } + dict { + if {![catch {dict size $word}]} {return yes} + } + default { + set has_maybe 1 + } + } + } + } + return [expr {$has_maybe ? "maybe" : "no"}] + } + + #overlap check of one form pair. For each pair of equal-length slot chains, derive + #per-position candidate witness words (discriminator words and type witnesses from + #both slots, screened by formcheck_slot_accepts) and confirm candidates with a real + #single-form parse of the witness against BOTH forms. Returns a finding dict + #(forms/class/length/witness/slots) for the first confirmed witness, or {} if no + #candidate was confirmed within the parse budget. + #class: type_weakness if some witness position aligns a discriminator with a + #permissive (non-validating) type on the other side; structural otherwise (the + #forms genuinely share an argument shape - 'after cancel id|script' class). + proc private::formcheck_pair {id spec fa fb {parse_budget 32}} { + set fda [dict get $spec FORMS $fa] + set fdb [dict get $spec FORMS $fb] + set chains_b_bylen [dict create] + foreach cb [formcheck_chains $fdb] { + dict lappend chains_b_bylen [llength $cb] $cb + } + set parses 0 + foreach ca [formcheck_chains $fda] { + set L [llength $ca] + if {$L == 0 || ![dict exists $chains_b_bylen $L]} {continue} + foreach cb [dict get $chains_b_bylen $L] { + #per-position candidate words + relation classification + set positions [list] + set viable 1 + for {set i 0} {$i < $L} {incr i} { + set slota [lindex $ca $i] + set slotb [lindex $cb $i] + set ia [formcheck_slotinfo $fda $slota] + set ib [formcheck_slotinfo $fdb $slotb] + set candidates [list] ;#{word score} - score 2: both sides screened yes + foreach w [list {*}[dict get $ia discwords] {*}[dict get $ib discwords]\ + {*}[dict get $ia witnesses] {*}[dict get $ib witnesses]] { + if {[lsearch -exact -index 0 $candidates $w] >= 0} {continue} + set acc_a [formcheck_slot_accepts $fda $slota $w] + set acc_b [formcheck_slot_accepts $fdb $slotb $w] + if {$acc_a eq "no" || $acc_b eq "no"} {continue} + lappend candidates [list $w [expr {($acc_a eq "yes") + ($acc_b eq "yes")}]] + } + if {![llength $candidates]} { + set viable 0 + break + } + set candidates [lrange [lsort -integer -decreasing -index 1 $candidates] 0 2] + if {[dict get $ia disc] && ![dict get $ib disc] && [dict get $ib permissive]} { + set relation discriminator_vs_permissive + } elseif {[dict get $ib disc] && ![dict get $ia disc] && [dict get $ia permissive]} { + set relation discriminator_vs_permissive + } elseif {[dict get $ia disc] && [dict get $ib disc]} { + set relation shared_discriminator + } else { + set relation co_satisfiable_types + } + lappend positions [list [lmap c $candidates {lindex $c 0}] $relation\ + [dict get $slota arg] [dict get $slotb arg]] + } + if {!$viable} {continue} + #witness combinations: best candidate per position, then vary one + #position at a time through its alternates + set base [lmap p $positions {lindex $p 0 0}] + set trylist [list $base] + for {set i 0} {$i < $L} {incr i} { + foreach altword [lrange [lindex $positions $i 0] 1 end] { + set varied $base + lset varied $i $altword + lappend trylist $varied + } + } + foreach witness $trylist { + if {$parses >= $parse_budget} {break} + incr parses 2 + if {![dict get [parse_status $witness -form [list $fa] withid $id] ok]} {continue} + if {![dict get [parse_status $witness -form [list $fb] withid $id] ok]} {continue} + #confirmed overlap - classify and report + set class structural + set slotreport [list] + for {set i 0} {$i < $L} {incr i} { + lassign [lindex $positions $i] _cands relation arga argb + if {$relation eq "discriminator_vs_permissive"} { + set class type_weakness + } + lappend slotreport [dict create word [lindex $witness $i]\ + args [list $arga $argb] relation $relation] + } + return [dict create forms [list $fa $fb] class $class length $L\ + witness $witness slots $slotreport] + } + if {$parses >= $parse_budget} {break} + } + if {$parses >= $parse_budget} {break} + } + return {} + } + + lappend PUNKARGS [list { + @id -id ::punk::args::formcheck + @cmd -name punk::args::formcheck\ + -summary\ + "Analyse a multiform definition for form pairs an argument list could match simultaneously."\ + -help\ + "Analyse the definition identified by id for AMBIGUOUS form pairs: pairs + of @form forms for which some argument list cleanly matches both, so a + parse without -form would raise a multipleformmatches error. + + The analysis is static-first: it aligns the positional argument slots of + each form pair (leaders then values - options are order-free and excluded + from the positional model), derives candidate 'witness' argument lists, + and only reports a pair after CONFIRMING a witness by parsing it against + both forms individually. A reported overlap is therefore always real - + fully discriminated form pairs cannot be false-alarmed - while the miss + direction is conservative: overlaps whose witness the analysis cannot + derive (exotic validation types, forms requiring options, deep -multiple + repetition) may go unreported. No user-supplied argument words are + parsed, and definitions that never call formcheck pay no cost at + define/resolve time. + + Finding classes: + type_weakness a discriminator slot (literal()/literalprefix() + alternates or a restricted choice set) in one form + aligns with a permissive type that performs no word + validation (any/none/string/ansistring/globstring/ + expr/script) in the other - the permissive type + swallows the discriminator word (e.g 'lseq 1 count 5': + range's end slot typed number|expr accepts the word + 'count'). Usually fixable by tightening the type. + structural the forms genuinely share an argument shape with no + discriminating slot difference (e.g 'after cancel x' + where x is id-shaped - real Tcl disambiguates by + runtime state). If intended, sanction the pair with + @form -overlapallowed so it reports as acknowledged. + + A pair sanctioned via @form -overlapallowed (on either + member) is still reported, with sanctioned 1 - the sanction documents + intent for this analysis only and never changes parse behaviour. + + Returns a dict: + id the analysed definition id + form_names declared forms in declaration order + pairs every form pair analysed (list of 2-element lists) + findings dict keyed by pair {formA formB} - each finding has + forms, class, length, witness (a confirmed argument + list matching both forms), slots (per-position word, + argument names and slot relation) and sanctioned (0|1) + unsanctioned pair keys of findings not covered by -overlapallowed + (the actionable subset - e.g a verification gate can + require this to be empty) + summary human-readable report of the above + With -return summary only the summary text is returned." + -return -type string -default dict -choices {dict summary} -help\ + "dict: full machine-parsable analysis (includes the summary as a key). + summary: the human-readable report text only." + @values -min 1 -max 1 + id -type string -help\ + "id of a punk::args definition (as accepted by punk::args::get_spec)" + }] + proc formcheck {args} { + set argd [punk::args::parse $args withid ::punk::args::formcheck] + lassign [dict values $argd] leaders opts values received + set id [dict get $values id] + set opt_return [dict get $opts -return] + + set spec [get_spec $id] + if {$spec eq ""} { + error "punk::args::formcheck - no such id: '$id'" + } + set form_names [dict get $spec form_names] + set pairs [list] + set findings [dict create] + set unsanctioned [list] + for {set i 0} {$i < [llength $form_names]} {incr i} { + for {set j [expr {$i+1}]} {$j < [llength $form_names]} {incr j} { + set fa [lindex $form_names $i] + set fb [lindex $form_names $j] + lappend pairs [list $fa $fb] + set finding [private::formcheck_pair $id $spec $fa $fb] + if {$finding eq ""} {continue} + set sanctioned 0 + if {$fb in [Dict_getdef $spec FORMS $fa -overlapallowed {}] + || $fa in [Dict_getdef $spec FORMS $fb -overlapallowed {}]} { + set sanctioned 1 + } + dict set finding sanctioned $sanctioned + dict set findings [list $fa $fb] $finding + if {!$sanctioned} { + lappend unsanctioned [list $fa $fb] + } + } + } + set summarylines [list] + lappend summarylines "punk::args::formcheck $id: [llength $form_names] form(s), [llength $pairs] pair(s) analysed, [dict size $findings] overlap(s) ([llength $unsanctioned] unsanctioned)" + dict for {pairkey finding} $findings { + lassign $pairkey fa fb + set tag [expr {[dict get $finding sanctioned] ? "sanctioned" : "UNSANCTIONED"}] + lappend summarylines " $tag [dict get $finding class] overlap: $fa vs $fb - witness arglist {[dict get $finding witness]} parses cleanly against both forms" + foreach slot [dict get $finding slots] { + lassign [dict get $slot args] arga argb + lappend summarylines " word '[dict get $slot word]' satisfies $fa/$arga and $fb/$argb ([dict get $slot relation])" + } + } + if {![dict size $findings]} { + lappend summarylines " no overlapping form pairs detected (static analysis - see the punk::args::formcheck help for the miss/report boundary)" + } + set summary [join $summarylines \n] + if {$opt_return eq "summary"} { + return $summary + } + return [dict create id $id form_names $form_names pairs $pairs findings $findings unsanctioned $unsanctioned summary $summary] + } + lappend PUNKARGS [list { @id -id ::punk::args::parse_status @cmd -name punk::args::parse_status\ @@ -14371,7 +14847,7 @@ package provide punk::args [tcl::namespace::eval punk::args { tcl::namespace::path {::punk::args::lib ::punk::args::system} variable pkg punk::args variable version - set version 0.11.2 + set version 0.12.0 }] return diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args/moduledoc/tclcore-0.3.3.tm b/src/vfs/_vfscommon.vfs/modules/punk/args/moduledoc/tclcore-0.3.4.tm similarity index 99% rename from src/vfs/_vfscommon.vfs/modules/punk/args/moduledoc/tclcore-0.3.3.tm rename to src/vfs/_vfscommon.vfs/modules/punk/args/moduledoc/tclcore-0.3.4.tm index b2753547..6e1ecebe 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/args/moduledoc/tclcore-0.3.3.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/args/moduledoc/tclcore-0.3.4.tm @@ -8,7 +8,7 @@ # (C) 2025 # # @@ Meta Begin -# Application punk::args::moduledoc::tclcore 0.3.3 +# Application punk::args::moduledoc::tclcore 0.3.4 # Meta platform tcl # Meta license MIT # @@ Meta End @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin punkshell_module_punk::args::moduledoc::tclcore 0 0.3.3] +#[manpage_begin punkshell_module_punk::args::moduledoc::tclcore 0 0.3.4] #[copyright "2025"] #[titledesc {punk::args definitions for tcl core commands}] [comment {-- Name section and table of contents description --}] #[moddesc {tcl core argument definitions}] [comment {-- Description at end of page heading --}] @@ -4591,7 +4591,11 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { #@form -form {cancelid} -synopsis "after cancel id" - @form -form {cancelid} + #The cancelid/cancelscript overlap is DOCUMENTED behaviour (an id-shaped word + #is genuinely ambiguous - see the id -type comment below), so it is sanctioned + #for punk::args::formcheck reporting (G-074). Parse behaviour is unaffected: + #'after cancel ' still raises multipleformmatches. + @form -form {cancelid} -overlapallowed {cancelscript} @leaders -min 1 -max 1 cancel -choices {cancel} @values -min 1 -max 1 @@ -12579,7 +12583,7 @@ namespace eval ::punk::args::register { package provide punk::args::moduledoc::tclcore [tcl::namespace::eval punk::args::moduledoc::tclcore { variable pkg punk::args::moduledoc::tclcore variable version - set version 0.3.3 + set version 0.3.4 }] return