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 [str@ [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.
[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. +: 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. foo@bar 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, 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 {
# 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 [l@ $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 [l@ $args 0]
if {[l# [cmds $cmd]]==0 && [regexp {^[0-9+\\-]} $cmd]} {
^ [% $args]
}
}
# fancy addressing - foo@bar 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' = [foo@bar foo@bar2 foo@grill]"
puts [dict1@foo dict1@foo2 dict1@foo3]
dict1@foo2: really foo@bar2: really foo@urble: fobby dict1@urble+: foo@urble
puts [foo@bar foo@bar2 foo@grill foo@urble]
puts [dict1@foo dict1@foo2 dict1@foo3 dict1@urble]
puts "$dict1"
}
| [Category Programming Unknown] |
