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:

   * Bugfixes & internal improvements (&args instead of args saves one {*} in call)

New Features by Mai 28th 2017:

   * -upvar <level> now follows tip-457 - plus auto-sets ''&paramname'' to the call-provided name.

   * -switch {optval1 {opt2 val2} ...} also follows tip-457.

   * Allow only one group of named parameters - having more of them just has no real use, and complicates assignment prediction.

   * Named options are now always defaulting. If they don't specify a default nor have ''-bool'' adverbs, then default is "". (Use -list 1 to be able to tell a given empty value from "" default)

   * Named options after 'args' no longer allowed - simplifies the logic and cuts weird corner cases.

   * Optional positionals after 'args' no longer allowed. It would have been unambiguous, but I couldn't think of any use case for it. (I would add it back, if a convincing use case is provided :-)

   * Preparation for "return" call pattern: fixed size options and optional positional(s) without need for "--". Not yet completed.

   * Fixed a bug with named params and "-list".

   * Dropped two of the examples. "foo" was boring, "justsick" was indeed just sick (and wouldn't work any more).



New Features by March 27th 2017:

   * procx can now detect procedures that don't need a call wrapper - Yay! full call speed!  -upvar included.

   * -array {}: turns the passed dict value into a local array. (doesn't need call wrapper)

   * -bool {names ...}: imply -default 0 and define option names all mapped to 1

   * added shortcuts for all the argspec options.

   * improved some error messages.


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:

   * examples for latest features


Limitations of this pure-Tcl version are:  (not likely to be changed)

   * utter lack of introspection

   * ways slower than plain tcl procedure calls, except the simple ones using only -upvar and -array.

   * no "unset" for non-provided named args.  (Use -list 1 to be able to tell a given empty value from "" default)


----

***Example usage:***

======
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}]


======


***Implementation:***


======
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
======


<<categories>>Enter Category Here