This is a pure Tcl reference implementation for a variant of TIP 457. '''procx name paramspec body''' creates a command named ''name'' like tcl's proc, but allows for an extended syntax to specify the formal arguments. New Features by March 24th 2017: * no more ''-name ... -value ...'' -- the problems just didn't show up for the provided solution. * ''{allnkitchensink -names {n name ...} -flags {glob regexp exact} -flagvals {low 0 med 5 high 9} }'' -- Motivation for having both -flags and -flagvals: sometimes the flag names have a domain-specific meaning and sometimes the flag names are an interface detail not reflected in the body other than by mapping to something else. * ''{pair -list 2}'' * ''{cmd -name command -list 1 -default {}}'' -- safely detect unspecified non-required options with [[llength $cmd]] * tip288 semantics now also consider non-default named arguments * implementation moved into namespace procx, only import procx into :: * "-d" and "-def" as aliases for "-default". ''-names'', ''-flags'' and ''-flagvals'' also have singular forms as alias. New Features by March 22nd 2017: * '''-upvar''' is now supported * '''args''' and defaulted arguments can now occur at '''any''' position within the param-spec. Certain combinations might not be overly useful, though. This now also supports the `[[lsearch ... haystack needle]]` interface pattern. * no longer needs explicit ''call''-wrapping * probably some bugs fixed. Still missing, but on ToDo List: * detect cases compatible with old proc, and skip "call" for these - upvar would be still supported. Limitations of this pure-Tcl version are: (not likely to be changed) * ''-upvar'' is tied to the formal argument therefore cannot follow a -name * utter lack of introspection * ways slower than plain tcl procedure calls. ---- ***Example usage:*** ====== procx foo {a {b 0} {c -default 0} {d -default 0 -name d -value 1} {e 0}} { list $a -- $b -- $c -- $d -- $e } foo A foo A B foo A B C foo A B C -d foo A B C E procx process { {loglvl -default 3 -name lvl -name q -value 0 -name v -value 9 } {type -default "snafu" -name foo -value foo -name bar -value bar} args } { list lvl $loglvl -- type $type -- args $args } process la la la process -foo process -lvl 42 process -v process -q -- -bar goes in args procx testrep {{opt -default 42 -name o} val} { tcl::unsupported::representation $val } testrep [expr {-42}] testrep -- [expr {-42}] testrep -o 0 [expr {-42}] testrep -o 0 -- [expr {-42}] procx justsick { {arg1 -flags {foo bar} -name baz -list 2 -default none } {arg2 none} {arg3 -flags {foo bar baz} } args {arg4 -list 2} } { list $arg1 -- $arg2 -- $arg3 -- $args -- $arg4 } justsick -baz -baz -baz justsick -baz -baz -baz -baz justsick -baz -baz -baz -baz -baz justsick -baz -baz -baz -baz -baz -baz justsick -baz -baz -baz -baz -baz -baz -baz justsick -baz -baz -baz -baz -baz -baz -baz -baz justsick -baz -baz -baz -baz -baz -baz -baz -baz -baz justsick -baz -baz -baz -baz -baz -baz -baz -baz -baz -baz ====== ***Implementation:*** ====== namespace eval procx { proc procx {name params body} { set cache {}; set allnames {}; set has_args 0; set upvars {} set group_args [dict create]; # formal argnames with options set group_names [dict create]; # option names with description set group_minArgs 0 ; # number of required arguments in group set total_minArgs 0 ; # total number of required arguments foreach argspec $params { set argspec [lassign $argspec argname]; # extract argname if {$argname eq "args"} { set has_args 1 ; # will be added to allnames as last one. if {[llength $argspec]} { error "no flags or default allowed for `args'" } set minArgs 0 ;# args is certainly not "ND" } else { lappend allnames $argname; # add only non-"args" to list # canonicalize argspec: if {[llength $argspec] & 1} { set argspec [linsert $argspec 0 "-default"] } set minArgs -1 ;# undecided } # initialize option container and argspec state: set argopts {}; set listlen 0; set defset 0; set upvarset 0; set nameset 0 # sort out options into option groups: foreach {o v} $argspec { switch -exact -- $o { "-default" - "-def" - "-d" { if {$defset} { error "only one -default option allowed" } dict set argopts "-default" $v; set minArgs 0; set defset 1 } "-list" { if {$listlen} { error "only one -list option allowed" } if {$v <= 0} { error "-list arg must be positive" } set listlen $v } "-upvar" { if {$upvarset} { error "only one -upvar option allowed" } lappend upvars [list $argname] $v; set upvarset 1 } "-flags" - "-flag" {;# option names are their own values if {[llength $v]} { if {$minArgs!=0} { set minArgs 1 } foreach f $v { if {[dict exists group_names "-$f"]} { error "duplicate option name within group" }; dict set group_names "-$f" [list $argname 1 $f] }; set nameset 1 } } "-flagvals" - "-flagval" {;# option names mapped to values if {[llength $v]} { if {$minArgs!=0} { set minArgs 1 } foreach {f fv} $v { if {[dict exists group_names "-$f"]} { error "duplicate option name within group" }; dict set group_names "-$f" [list $argname 1 $fv] }; set nameset 1 } } "-name" - "-names" {;# option names taking >0 argument(s) if {[llength $v]} { if {$minArgs<0} { set minArgs -2 } foreach f $v { if {[dict exists group_names "-$f"]} { error "duplicate option name within group" }; dict set group_names "-$f" [list $argname 0 {}] }; set nameset 1 } } default { error "unknown option \"$o\" in argspec for \"$argname\"" } } } # minArgs: 0: has default; 1: has flags; -2: just name; -1: positional # listlen: 0: no enlisting (1 arg); : enlist arguments # if just name: minArgs = $listlen+1; if positional: minArgs = $listlen if {$minArgs < 0} { set minArgs [expr {max($listlen,1) - ($minArgs+1)}] } # save information for call-wrapper dict set argopts "-list" $listlen; dict set argopts "minArgs" $minArgs incr total_minArgs $minArgs if {$nameset} {;# named argument: add to group dict set group_args $argname $argopts incr group_minArgs $minArgs } else {;# positional argument # eventually finish group of named arguments if {[dict size $group_args]>0} {;# flush lappend cache $group_args $group_names $group_minArgs set group_args [dict create] set group_names [dict create] set group_minArgs 0 } # add this positional argument to the cache lappend cache [list $argname $argopts] [dict create] $minArgs } } # eventually finish remaining group of named arguments if {[dict size $group_names]>0} {;# flush lappend cache $group_args $group_names $group_minArgs } if {[llength $upvars]} { # inject the upvars into the body set templ0 { [set %s][unset %s] %s} set templ1 { [set %s [set %s]][unset %s] %s} set intro "upvar 1" foreach {la an} $upvars { if {$an eq ""} { append intro [format $templ0 $la $la $la] } else { append intro [format $templ1 [list $an] $la $la $la] } } set body "$intro;$body" } set intname "cache::$name" set cache::data($intname) [list $total_minArgs $allnames $cache] #debug Cache: $intname -- $cache::data($intname) if {$has_args} { lappend allnames "args" } uplevel 1 [list interp alias {} $name {} ::procx::call $intname] proc $intname $allnames $body } proc call {name args} { set argnr 0; set formargs [dict create "args" {}] lassign $cache::data($name) total_minArg allnames cache set nargs [expr {[llength $args]-$total_minArg}] #debug llengh [llength $args] -- tmin $total_minArg -- nargs $nargs if {$nargs < 0} { error "too few arguments" } foreach {argopts nameopts minArgs} $cache { set arg [lindex $args $argnr]; set isnamed [dict size $nameopts] #debug group [dict keys $argopts] -- arg $arg -- [expr {$isnamed?"isnamed":""}] if {$isnamed} {; # assign value to named argument set horizon [expr {$nargs + $minArgs}] #debug argnr $argnr -- min $minArgs -- horiz $horizon -- nargs $nargs while { $argnr < $horizon && $arg ne "--" && [dict exists $nameopts $arg] } { lassign [dict get $nameopts $arg] argname isflag flagval set opts [dict get $argopts $argname] set minArgs [dict get $opts "minArgs"] set listlen [dict get $opts "-list"] # Aspects to consider: # A) a) flag b) name w/o list c) name with list # -> number of values it would consume, if accepted set wanted [expr {$isflag ? 1 : max(1,$listlen) }] # B) arg has a) def b) flags c) only name # and: is the formal arg already set # -> number of values reserved for this option set reserved [expr {[dict exists $formargs $argname] ? 0 : $minArgs } ] if {$argnr+$wanted > $nargs+$reserved} { #debug not taken -- $argnr+$wanted>$nargs+$reserved break; # cannot use this option for this group! } incr nargs $reserved; if {$isflag} { dict set formargs $argname $flagval } elseif {$listlen} { set argto [expr {$argnr+$listlen-1}] dict set formargs $argname [lrange $args $argnr $argto] set argnr $argto } else { dict set formargs $argname [lindex $args [incr argnr]] }; incr argnr; set arg [lindex $args $argnr] } # no more args available for this group if {$argnr < $nargs && $arg eq "--"} { incr argnr } # now try to complete the group with defaults dict for {n opts} $argopts {; # check if all have value or default if {![dict exists $formargs $n]} { if {[dict exists $opts "-default"]} { dict set formargs $n [dict get $opts "-default"] } else { #puts "formargs: [dict get $formargs]" error "formal argument $n has not been given a value" } } #debug $n = [dict get $formargs $n] } } else { lassign $argopts argname opts #debug argnr $argnr -- min $minArgs -- nargs $nargs if {$argname eq "args"} { set argto [expr {$nargs-1}] dict set formargs "args" [lrange $args $argnr $argto] set argnr $nargs } else { set listlen [dict get $opts "-list"]; set useargs [expr {max(1,$listlen)}] # for positional arguments, minArgs equals either 0 or $useargs if {$minArgs || $argnr+$useargs <= $nargs} {;# fits incr nargs $minArgs; # $minArgs values are already reserved. if {$listlen} { set argto [expr {$argnr+$listlen-1}] dict set formargs $argname [lrange $args $argnr $argto] set argnr $argto } else { dict set formargs $argname $arg }; incr argnr; set arg [lindex $args $argnr] } else {;# doesn't fit => use default (not list'ed!) dict set formargs $argname [dict get $opts "-default"] } } #debug $argname = [dict get $formargs $argname] } } if {$argnr < [llength $args]} { error "too many arguments" } set args [lmap x $allnames {dict get $formargs $x}] lappend args {*}[dict get $formargs "args"] tailcall $name {*}$args } #proc debug {args} { puts "Debug: $args" } namespace eval cache {} namespace export procx } namespace import procx::procx ====== <>Enter Category Here