This is a pure Tcl reference implementation for a slight 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.
Update by May 30th 2017:
New Features by Mai 28th 2017:
New Features by March 27th 2017:
New Features by March 24th 2017:
New Features by March 22nd 2017:
Still missing, but on ToDo List:
Limitations of this pure-Tcl version are: (not likely to be changed)
procx process { {loglvl -default 3 -name lvl -flagvals {q 0 v 9} } {type -default "bulk" -flags {advanced premium} } args } { list lvl $loglvl -- type $type -- args $args } process la la la process -premium process -lvl 5 process -q -- -bar goes in args procx testrep {{opt -default 42 -name o} val} { tcl::unsupported::representation $val } # in all these cases $val is a pure int (w/o string rep): testrep [expr {-42}] testrep -- [expr {-42}] testrep -o 0 [expr {-42}] testrep -o 0 -- [expr {-42}]
namespace eval procx { proc procx {name params body} { set cache {}; set allnames {}; set upvars {}; set arrays {} set group_args [dict create]; # formal argnames with options set group_names [dict create]; # option names with description set group_gcd 0 ; # gcd of all keyword-phrase lengths set total_reqArgs 0 ; # total number of required arguments # compatible procs cannot have reqd arg after dflted, nor named arguments: set iscompatible 1; set proc_has_def 0; set proc_has_args 0 foreach argspec $params { set argspec [lassign $argspec argname]; # extract argname # initialize option container and argspec state: set argopts {}; set listlen 0; set nameset {} set defval {}; set defset 0; set argtype "" if {$argname eq "args"} { if {$proc_has_args} { error "multiple arguments named `args'" } set proc_has_args 1; lappend allnames [list &args]; set minArgs 0 if {[llength $argspec]} { error "no flags or default allowed for `args'" } } else { if {$proc_has_args} { set iscompatible 0 }; # anything after args # canonicalize argspec: if {[llength $argspec] & 1} { set argspec [linsert $argspec 0 "-default"] } # $defset tells if a default was explicitly set. # # parse all the arg spec options: foreach {o v} $argspec { switch -exact -- $o { "-default" - "-def" - "-d" { if {$defset && $defval ne $v} { error "conflicting defaults for `$argname'" }; set defval $v; set defset 1 } "-list" - "-l" { if {$listlen && $listlen != $v} { error "conflicting -list options for `$argname'" } elseif {$v <= 0} { error "-list arg must be positive" } set listlen $v; set iscompatible 0 } "-upvar" - "-u" { if {$argtype ne ""} { error "conflicting types: $o versus $argtype" }; lappend upvars $argname $v; set argtype "upvar" } "-bool" - "-boolean" - "-b" {;# boolean option names if {[llength $v]} { # boolean implies 0 as default. value is 1 for all aliases. if {$defset && $defval ne 0} { error "conflicting defaults for `$argname'" }; set defval "0"; set defset 1 foreach f $v { if {[dict exists group_names "-$f"]} { error "duplicate option name within group" }; dict set group_names "-$f" [list $argname 1 1] }; dict set nameset adverb 1; set iscompatible 0 } } "-flags" - "-flag" - "-f" {;# option names are their own values if {[llength $v]} { foreach f $v { if {[dict exists group_names "-$f"]} { error "duplicate option name within group" }; dict set group_names "-$f" [list $argname 1 $f] }; dict set nameset adverb 1; set iscompatible 0 } } "-flagvals" - "-flagval" - "-fv" {;# option names mapped to values if {[llength $v]} { 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] }; dict set nameset adverb 1; set iscompatible 0 } } "-switch" - "-sw" {;# tip-457-style if {[llength $v]} { foreach {fl} $v { if {[llength $fl]>=2} { lassign $fl f fv } else { set f [set fv [lindex $fl 0]] } if {[dict exists group_names "-$f"]} { error "duplicate option name within group" }; dict set group_names "-$f" [list $argname 1 $fv] }; dict set nameset adverb 1; set iscompatible 0 } } "-names" - "-name" - "-n" {;# option names taking >0 argument(s) if {[llength $v]} { foreach f $v { if {[dict exists group_names "-$f"]} { error "duplicate option name within group" }; dict set group_names "-$f" [list $argname 0 {}] }; dict set nameset preposition 1; set iscompatible 0 } } "-array" - "-arr" - "-a" {;# initialize a local array with given dict. # TODO: think of a good use for the option argument... if {$argtype ne ""} { error "conflicting types: $o versus $argtype" }; lappend arrays $argname; set argtype "array" } default { set err "unknown option `$o' in argspec for `$argname' " append err "(Maybe, some option is missing its argument.)" error $err } } };#foreach {o v} $argspec # listlen: 0: no enlisting (but still takes 1 arg); <n>: enlist <n> arguments set minArgs [tcl::mathfunc::max $listlen 1] if {[dict size $nameset]} { # check that this is the one and only named group: if {$group_gcd < 0} { error "There can be only one group of named parameters." } if {$proc_has_args} { error "named parameters are not allowed after 'args'." } # update the gcd for the group: if {![dict exists $nameset adverb]} { # for purely prepositional phrases: #args+1 gcd group_gcd [expr {$minArgs + 1}] } else { set group_gcd 1 };# otherwise 1 # in procx, named params auto-default, anyway. set defset 1 } if {$defset} { if {$proc_has_args} {; # named have been excluded before. error "optional parameters are not allowed after 'args'." } dict set argopts "-default" $defval lappend allnames [list $argname $defval] set proc_has_def 1; set minArgs 0 } else { # non-defaulted after defaulted: not in plain proc if {$proc_has_def} { set iscompatible 0 } lappend allnames [list $argname] # update number of required arguments incr total_reqArgs $minArgs } # save information for call-wrapper dict set argopts "-list" $listlen };# not 'args' # also relevant for "args" (in particular the else block) if {[dict size $nameset]} {;# named argument: add to group dict set group_args $argname $argopts } else {;# positional argument # eventually finish group of named arguments if {[dict size $group_args]>0} {;# flush lappend cache $group_args $group_names $group_gcd set group_args {}; set group_names {}; set group_gcd -1 } # add this positional argument to the cache lappend cache [list $argname $argopts] [dict create] $minArgs } } # eventually finish a remaining open group of named arguments if {[dict size $group_names]>0} {;# flush lappend cache $group_args $group_names $group_gcd set group_args {}; set group_names {}; set group_gcd -1 } set intro {}; # injections... if {[llength $arrays]} { set templ0 {array set %s $%s[unset %s];} set templ1 {array set %s [set %s][unset %s];} foreach {pn} $arrays { if {[isbareword $pn]} { append intro [format $templ0 $pn $pn $pn] } else { set la [list $pn] append intro [format $templ1 $la $la $la] } } } if {[llength $upvars]} { # inject the upvars into the body set bylvl {}; foreach {pn lvl} $upvars { dict lappend bylvl $lvl $pn } set templ0 { [set &%s $%s][unset %s] %s} set templ1 { [set %s [set %s]][unset %s] %s} dict for {lvl lpn} $bylvl { append intro [list upvar $lvl] foreach {pn} $lpn { if {[isbareword $pn]} { append intro [format $templ0 $pn $pn $pn $pn] } else { set la [list $pn] append intro [format $templ1 [list &$pn] $la $la $la] } }; append intro ";" } } if {$iscompatible} { # if it is compatible and has args, then change last element from '&args' to 'args': if {$proc_has_args} { lset allnames end "args" } uplevel 1 [list proc $name $allnames "${intro}${body}"] return ""; # empty return for compatible procs } else { if {$proc_has_args} { # inject code to "rename" '&args' back to 'args': append intro {set args ${&args}[unset &args];} } set intname "cache::$name" # call-wrapper will deal with defaults: set allparams [lmap {a} $allnames { lrange $a 0 0 }] set allnames [lmap {a} $allnames { lindex $a 0 }] set cache::data($intname) [list $total_reqArgs $allnames $cache] #debug Cache: $intname -- $cache::data($intname) uplevel 1 [list interp alias {} $name {} ::procx::call $intname] proc $intname $allparams "${intro}${body}" return [namespace origin $intname]; # for debugging/information } } proc isbareword {s} { expr {[string is ascii $s]&&[string is wordchar $s]}} # maybe not the most efficient one, but only used in procx itself. proc gcd {&sofar new} { upvar 1 ${&sofar} sofar if {$sofar == 0 || $new == 1} { set sofar $new; return } if {$sofar < $new} { set new [expr {$new % $sofar}] } else { set sofar [expr {$sofar % $new}] }; tailcall gcd ${&sofar} $new } # this one does the parameter binding for the advanced cases 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 #debug argnr $argnr -- nargs $nargs -- gcd $minArgs while { $argnr < $nargs && $arg ne "--" && [dict exists $nameopts $arg] } { lassign [dict get $nameopts $arg] argname isflag flagval set opts [dict get $argopts $argname] set listlen [dict get $opts "-list"] # a) flag b) name w/o list c) name with list # -> number of values it would consume, if accepted set wanted [expr {$isflag ? 1 : 1+max(1,$listlen) }] if {$argnr+$wanted > $nargs} { #debug not taken -- $argnr+$wanted>$nargs break; # cannot use this option for this group! } if {$isflag} { dict set formargs $argname $flagval } elseif {$listlen} { incr argnr; 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 {; # cannot happen anymore. #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" } tailcall $name {*}[lmap x $allnames {dict get $formargs $x}] } #proc debug {args} { puts "Debug: $args" } namespace eval cache {} namespace export procx } namespace import procx::procx