Updated 2018-03-24 00:06:40 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. Also demonstrates that the distinction between vars and procs is not very useful with < and > to process args, so the < and > are just vars that are compiled invisibly to procs when first processed.
  interp alias {} havevar {} info exists
  interp alias {} havecmd {} info commands

  # pulls in arguments as needed. A prefixed & creates an upvar
  set > {
    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
  set < {
    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]
      }
    }
  }

  set strlast {set rtn [[email protected] [join $args " "] end];return $rtn}
  set hd   {> &var;set rtn {};catch {set rtn [lindex $var 0];set var [lrange $var 1 end]};return $rtn}
  set l+   {> l;set l [lsort -unique [concat {*}$l {*}$args]];return [lsearch -all -inline -not -exact $l {}]}
  set l-   {l args} {> l;each arg {*}$args {set rtn [ls? -all -inline -not -exact $l $arg]};return $rtn}
  set l^   {> l idx;set rtn [linsert $l $idx {*}$args]; return $rtn}
  set lv+  {> &l;lappend l {*}$args;return [lsort -unique [lsearch -all -inline -not -exact $l {}]]}
  set lv++ {> &rtn pos val mod;ifno val 1 mod 0;set val [lindex $var $pos];++ val $amt $mod;!set $rtn $pos $val;return $rtn}
  set lv-  {> &rtn;each arg $args {set rtn [ls? -all -inline -not -exact $rtn $arg]};return $rtn}
  set lv-- {> &rtn pos val mod;ifno val 1 mod 0;set val [lindex $var $pos];-- val $amt $mod;!set $rtn $pos $val;return $rtn}
  set lv^  {> &rtn idx;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. +: and
  # -: will add or remove the following elements from the list. This will
  # shimmer to a normal list if thereafter treated as one. Finally, it can
  # set and get array members and dict keys. [email protected] is replaced by either
  # foo(bar) or by [dg $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 {
    # since most of my programming just uses "args" as a parameter and uses > and <
    # access them, the distinction between vars and procs is not very useful. This
    # section checks to see if the 1st passed argument (the name of the unknown proc)
    # is present as a var, to make the associated proc. It also traces the var so if
    # it is reassigned it will be again turning into a proc. Aside from making tcl a
    # bit more orthogonal, it permits more brevity.
    ! pname [[email protected] $args 0]
    if {[havevar ::$pname] && ([havecmd $pname] eq "")} {
      # we have a proc in a var, compile to proc
      proc ::$pname args [! ::$pname]
      # add trace to var so if it is rewritten the proc is deleted and recreated
      trace add variable ::$pname write {rename ::$pname ""}
      # call it
      tailcall ::$pname {*}[lspan $args 1 end]
    }
    # allow assignments in expr
    ! i [strpos ":=" $args]
    if {$i!=-1} {
      ^ [^^ "! [strcpy $args 0 $i-1] [= [strcpy $args $i+2 end]]"]
    } else {
      # otherwise if it doesn't start w/cmd eval as expr
      ! cmd [[email protected] $args 0]
      if {[l# [cmds $cmd]]==0 && [regexp {^[0-9+\\-]} $cmd]} {
        ^ [% $args]
      }
    }
    # fancy addressing - [email protected] can refer to either $foo(bar) OR dict get foo bar
    # also handling special ops to add or remove items to list - all triggered by
    # a "@" sign in first arg.
    ! arg [hd args]
    ! rtn {}
    if {[strpos "@" $arg]!=-1} {
      ! prev ""
      while {($arg ne $prev) && [strposany $arg \$ \[]!=-1} {! prev $arg; ! arg [^^ subst $arg]}
      while {[! idx [strpos "@" $arg]]!=-1} {
        if {[strlast $arg] in {: =}} {
          # doing an assignment
          ! arg [str-1e $arg]
          ! ch [strlast $arg]
          if {$ch eq "+" || $ch eq "-"} {
            ! arg [str-1e $arg]
          } else {! ch ":"}
          ! arrname [strcpy $arg 0 $idx-1]
          ! index [strcpy $arg $idx+1 end]
          & $arrname anarray
          ! val [hd args]
          ! prev ""
          while {($val ne $prev) && [strposany $val \$ \[]!=-1} {! prev $val; ! val [^^ subst $val]}
          # if val is also a reference to
          # a dict or array evaluate it
          if {[! idx [strpos "@" $val]]!=-1} {
            ! valarr [strcpy $val 0 $idx-1]
            ! index2 [strcpy $val $idx+1 end]
            & $valarr valarray
            ! val {}
            if {[catch {! val $valarray($index2)}]} {
              catch {! val [dg $valarray $index2]}
            }
          }
          # val is now whatever we want to assign
          # to the variable we processed above.
          # assign it.
          if {[^^ array exists $arrname]} {
            case $ch {
              : {! anarray($index) $val}
              + {lv+ anarray($index) $val}
              - {lv- anarray($index) $val}
            }
          } else {
            # weird issue with dict set, so treat dict as list
            ! idx [ls? $anarray $index]
            if {$idx == -1} {
              # didn't find it, so add it to the end.
              lv+ anarray $index $val
            } else {
              ++ idx      ;# point to slot where value is & do it.
              case $ch {
                : {! anarray [lreplace $anarray $idx $idx $val]}
                + {lv+ anarray $val}
                - {lv- anarray $val}
              }
            }
          }
          ! arg [hd args]
        } else {
          ! arrname [strcpy $arg 0 $idx-1]
          ! index [strcpy $arg $idx+1 end]
          & $arrname anarray
          if {[catch {lv+ rtn $anarray($index)}]} {
            catch {lv+ rtn [dg $anarray $index]}
          }
          ! arg [hd args]
        }
      }
      ^ $rtn
    } elseif {[strlast $arg] eq ":"} {
      & [str-1e $arg] var
      ! var [join $args " "]
      ^ $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]