Updated 2017-06-22 03:46:03 by LarrySmith

I hope I got all the "smithisms" in this code - withOUT breaking it. I included the routines to implement a couple, notably the < > scheme for processing the args parameter.
  # pulls in arguments as needed. A prefixed & creates an upvar
  proc > {args} {
    upvar args argl; upvar set !
    if {[l# $argl]==0} {uplevel set #args -1;return}
    while {[l# $args]>0} {
      set arg [hd args]
      set val [hd argl]
      if {[string index $arg 0]eq"&"||[string index $val 0]eq"&"} {
        if {[string index $arg 0]eq"&"} {set arg [string range $arg 1 end]}
        if {[string index $val 0]eq"&"} {set val [string range $val 1 end]}
        set !($arg) $val
        uplevel upvar $val $arg
      } else {
        upvar $arg local
        set local $val
      }
    }
    uplevel set #args [l# $argl]
  }

  # reverse of >, puts args back in case we read too far in looking for options or overrides
  proc < {args} {
    upvar args argl; upvar set !
    while {[l# $args]>0} {
      set arg [hd args]
      if {[exists !($arg)]} {
        set name [set !($arg)]
        unset !($arg)
        lv^ argl 0 $name
      } else {
        lv^ argl 0 [uplevel set $arg]
      }
    }
  }

  proc strlast {args} {set rtn [[email protected] [join $args " "] end];return $rtn}
  proc hd {lv} {upvar $lv var;set rtn {};catch {set rtn [lindex $var 0];set var [lrange $var 1 end]};return $rtn}
  proc l+ {l args} {set l [lsort -unique [concat {*}$l {*}$args]];return [lsearch -all -inline -not -exact $l {}]}
  proc l- {l args} {each arg {*}$args {set rtn [ls? -all -inline -not -exact $l $arg]};return $rtn}
  proc l^ {l idx args} {set rtn [linsert $l $idx {*}$args]; return $rtn}
  proc lv+ {lv args} {upvar $lv l;lappend l {*}$args;return [lsort -unique [lsearch -all -inline -not -exact $l {}]]}
  proc lv++ {args} {> &rtn pos val mod;ifno val 1 mod 0;set val [lindex $var $pos];++ val $amt $mod;!set $rtn $pos $val;return $rtn}
  proc lv- {lv args} {upvar $lv rtn;each arg $args {set rtn [ls? -all -inline -not -exact $rtn $arg]};return $rtn}
  proc lv-- {args} {> &rtn pos val mod;ifno val 1 mod 0;set val [lindex $var $pos];-- val $amt $mod;!set $rtn $pos $val;return $rtn}
  proc lv^ {lv idx args} {upvar $lv rtn;set rtn [linsert $rtn $idx {*}$args]; return $rtn}

The real reason for the above is my version of "unknown" which serves a couple purposes. First, it recognizes expressions using the := operator: "[a := 2+7]" turns into "[set a [expr {2+7}]]". It will also recognize when an expr is present so [sin($x)/cos($x)] will turn into the appropriate expr. Another feature is conforming dict and array access. [[email protected]] returns the value of the dict or array with that index. You can ask for any number, and you can also do assignments: "[email protected]: [email protected]" will assign $name(index2) to dictname [index1 foobar]. $ are not needed, it knows one is required if you are trying to assign. Any number of assignments can be done. In addition to assignments, you can use +: or -: to add or remove elements in a list.
  rename unknown _unknown
  # This version of "unknown" recognizes expressions and evaluates
  # them, returning the result. It recognizes the assignment op :=
  # and generates appropriate code to implement it. It also implements
  # Rebol-style assignments using : - "i: 0" sets i to 0. Since it joins
  # the args beyond the varname to be assigned with space, "i: 1 2 3" sets
  # i to "1 2 3" rather than complaining about too many args to set. This
  # will shimmer to a normal list if thereafter treated as one. Finally,
  # it can set array members and dict keys. [email protected] is replaced by either
  # foo(bar) or by [dict get $foo $bar] in the enclosing scope according to
  # the type of "foo". This also works for assignment, [email protected]: [email protected]
  # will set [email protected] (whichever it is, dict or array) to [email protected] (same
  # deal). Any number can play, assignments and retrieves can be mixed in
  # one line - the result is a list of the retrieved items - if you want
  # to both assign in-line AND retrieve, you need to replicate one side
  # or the other.
  proc unknown args {
    set i [string first ":=" $args]
    if {$i!=-1} {
      return [uplevel "set [string range $args 0 $i-1] [= [string range $args $i+2 end]]"]
    } else {
      set cmd [lindex $args 0]
      if {[l# [cmds $cmd]]==0 && [regexp {return[0-9+\\-]} $cmd]} {
        return [expr $args]
      }
    }
    set arg [hd args]
    set rtn {}
    if {[string first "@" $arg]!=-1} {
      while {[set idx [string first "@" $arg]]!=-1} {
        if {[strlast $arg] in {: =}} {
          # doing an assignment
          set arg [string range $arg 0 end-1]
          set ch [string index $arg end]
          if {$ch eq "+" || ch eq "-"} {
            set arg [string range $arg 0 end-1]
          } else {set ch ":"}
          set arrname [string range $arg 0 $idx-1]
          set index [string range $arg $idx+1 end]
          upvar $arrname anarray
          set val [hd args]
          # if val is also a reference to
          # a dict or array evaluate it
          if {[set idx [string first "@" $val]]!=-1} {
            set valarr [string range $val 0 $idx-1]
            set index2 [string range $val $idx+1 end]
            upvar $valarr valarray
            set val {}
            if {[catch {set val $valarray($index2)}]} {
              catch {set val [dict get $valarray $index2]}
            }
          }
          # val is now whatever we want to assign
          # to the variable we processed above.
          # assign it.
          if {[uplevel array exists $arrname]} {
            switch -- $ch {
              : {set anarray($index) $val}
              + {lv+ anarray($index) $val}
              - {lv- anarray($index) $val}
            }
          } else {
            # weird issue with dict set, so treat dict as list
            set idx [ls? $anarray $index]
            if {$idx == -1} {
              # didn't find it, so add it to the end.
              lv+ anarray $index $val
            } else {
              incr idx      ;# point to slot where value is & do it.
              switch -- $ch {
                : {set anarray [lreplace $anarray $idx $idx $val]}
                + {lv+ anarray $val}
                - {lv- anarray $val}
              }
            }
          }
          set arg [hd args]
        } else {
          set arrname [string range $arg 0 $idx-1]
          set index [string range $arg $idx+1 end]
          upvar $arrname anarray
          if {[catch {lv+ rtn $anarray($index)}]} {
            catch {lv+ rtn [dict get $anarray $index]}
          }
          set arg [hd args]
        }
      }
      return $rtn
    } elseif {[strlast $arg] eq ":"} {
      upvar [string range $arg 0 end-1] var
      set var [join $args " "]
      return $var
    } else {eval _unknown $args}
  }

  # test and demo
  if 0 {
    foo(bar): now
    foo(bar2): it
    foo(grill): works
    set dict1 [dict create foo now foo2 it foo3 works]
    puts "should be 'now it works' = [[email protected] [email protected] [email protected]]"
    puts [[email protected] [email protected] [email protected]]
    [email protected]: really [email protected]: really [email protected]: fobby [email protected]+: [email protected]
    puts [[email protected] [email protected] [email protected] [email protected]]
    puts [[email protected] [email protected] [email protected] [email protected]]
    puts "$dict1"
  }


[Category Programming Unknown]