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

   * no longer needs explicit ''call''-wrapping

   * probably some bugs fixed.


Still missing, but on ToDo List:

   * ''-flags {val1 val2 ...}'' and ''-flagmap {val1 1 val2 2 ...}

   * ''-multi <n>'' to collect groups of arguments to a single formal argument.

   * no examples yet for the new features.


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

======


***Implementation:***


======
proc procx {name params body} {
   set cache {}; set allnames {}; set upvars {}
   set group_args  [dict create]; # argnames with 1st option group
   set group_names [dict create]; # names with their specific options
   set count_NDPosArg 0         ; # number of non-default positionals
   set has_args 0               ; # does args exist?
   
   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 allowed for `args'" }
         set isNDPosArg 0 ;# 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 isNDPosArg 1 ;# could be for now...
      }
      # initialize container for option groups. 1st group has empty key:
      set optiongroups [dict create {} {}]; set curname {}
      # sort out options into option groups:
      foreach {o v} $argspec {
         if {$o eq "-name"} {
            dict set optiongroups "-$v" [dict create {} $argname]
            set curname "-$v"; set isNDPosArg 0
         } else {
            dict lappend optiongroups $curname $o $v
            if {$o eq "-default"} { set isNDPosArg 0 }
            if {$o eq "-upvar"} {
               if {$curname ne ""} { error "-upvar not yet allowed after -name" }
               lappend upvars [list $argname] $v
            }
         }
      }; incr count_NDPosArg $isNDPosArg
      set firstgroup [dict get $optiongroups {}]; # pick 1st group
      dict unset optiongroups {}; # remove the 1st group from dict
      # distinguish positional versus named arguments:
      if {[dict size $optiongroups] > 0} {;# named argument
         dict set group_args $argname $firstgroup
         # add the argname to each option group:
         dict for {n grp} $optiongroups {
            # TODO: check that $n didn't already exist in group_names
            dict set group_names $n [dict get $optiongroups $n]
         }
      } else {;# positional argument
         # finish group of named arguments, if any.
         if {[dict size $group_names]>0} {;# flush
            lappend cache $group_args $group_names
            set group_args [dict create]
            set group_names [dict create]
         }
         # add this positional argument to the cache
         lappend cache [list $argname $firstgroup] [dict create]
      }
   }
   # finish group of named arguments, if any.
   if {[dict size $group_names]>0} {;# flush
      lappend cache $group_args $group_names
   }

   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 "_$name"
   set ::tcl::proc_cache($intname) [list $count_NDPosArg $allnames $cache]
   if {$has_args} { lappend allnames "args" }
   uplevel 1 [list interp alias {} $name {} call $intname]
   uplevel 1 [list proc $intname $allnames $body]
}
proc call {name args} {
   set argnr 0; set formargs [dict create "args" {}]
   lassign $tcl::proc_cache($name) count_NDPosArg allnames cache
   set nargs [expr {[llength $args]-$count_NDPosArg}]
   if {$nargs < 0} { error "too few arguments" }

   foreach {argopts nameopts} $cache {
      set done 0
      set arg [lindex $args $argnr]; set isnamed [dict size $nameopts]

      if {$isnamed} {; # assign value to named argument
         while {
            $argnr < $nargs && ( $arg ne "--" && [dict exists $nameopts $arg] )
         } {
            set aname [dict get $nameopts $arg {}]
            #puts "arg: $arg -- aname: $aname"
            if {[dict exists $nameopts $arg "-value"]} {
               dict set formargs $aname [dict get $nameopts $arg "-value"]
            } elseif {$argnr+1 < $nargs} {
               dict set formargs $aname [lindex $args [incr argnr]]
            } else {
               error "no value given to $aname"
            }; incr argnr; set arg [lindex $args $argnr]
         }
         if {!$done} {
            # no more args for this group
            #puts "arg: >$arg< argnr: $argnr -- $argopts"
            if {$argnr < $nargs && $isnamed && $arg eq "--"} { incr argnr }
            dict for {n opts} $argopts {; # check if all have value or default
               if {![dict exists $formargs $n]} {
                  #puts "checking $n in $opts"
                  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"
                  }
               }
            }
         }
      } else {
         lassign $argopts argname opts
         if {$argname eq "args"} {
            set argto [expr {$nargs-1}]
            dict set formargs "args" [lrange $args $argnr $argto]
            set argnr $argto
         } elseif {[dict exists $opts "-default"]} {
            if {$argnr < $nargs} {
               dict set formargs $argname $arg
            } else {
               dict set formargs $argname [dict get $opts "-default"]
            }
         } else {
            dict set formargs $argname $arg
            incr nargs; # consumed one of the reserved ones.
         }
         incr argnr; set arg [lindex $args $argnr]
      }
   }
   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
}
======


<<categories>>Enter Category Here