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 [str@ [join $args " "] end];return $rtn}
proc hd {lv} {upvar $lv var;set rtn {};catch {set rtn [l@ $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 [l@ $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 [l@ $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. dictorarrayname@dictorarrayindex returns the value of the dict or array with that index. You can ask for any number, and you can also do assignments: "dictname@index1: arrayname@index2" 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. foo@bar 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, foo@bar: foo@grill
# will set foo@bar (whichever it is, dict or array) to foo@grill (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]}
+ {set anarray [lreplace $anarray $idx $idx [l+ [lindex $idx] $val]}
- {set anarray [lreplace $anarray $idx $idx [l- [lindex $idx] $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}
}