jn
/
punkshell
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

add src/deps for imported dependencies

master
Julian Noble 1 year ago
parent
1065bcf7ec
commit
7a8b2fe06a
6 changed files with 11828 additions and 0 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 143
      src/deps/dictutils-0.2.tm
  2. 6411
      src/deps/metaface-1.2.5.tm
  3. 1285
      src/deps/pattern-1.2.4.tm
  4. 645
      src/deps/patterncmd-1.2.4.tm
  5. 2590
      src/deps/patternlib-1.2.6.tm
  6. 754
      src/deps/patternpredator2-1.2.4.tm

143
src/deps/dictutils-0.2.tm vendored
Unescape View File

@ -0,0 +1,143 @@
# dictutils.tcl --
#
# Various dictionary utilities.
#
# Copyright (c) 2007 Neil Madden (nem@cs.nott.ac.uk).
#
# License: http://www.cs.nott.ac.uk/~nem/license.terms (Tcl-style).
#
package require Tcl 8.6
package provide dictutils 0.2
namespace eval dictutils {
namespace export equal apply capture witharray nlappend
namespace ensemble create
# dictutils witharray dictVar arrayVar script --
#
# Unpacks the elements of the dictionary in dictVar into the array
# variable arrayVar and then evaluates the script. If the script
# completes with an ok, return or continue status, then the result is copied
# back into the dictionary variable, otherwise it is discarded. A
# [break] can be used to explicitly abort the transaction.
#
proc witharray {dictVar arrayVar script} {
upvar 1 $dictVar dict $arrayVar array
array set array $dict
try { uplevel 1 $script
} on break {} { # Discard the result
} on continue result - on ok result {
set dict [array get array] ;# commit changes
return $result
} on return {result opts} {
set dict [array get array] ;# commit changes
dict incr opts -level ;# remove this proc from level
return -options $opts $result
}
# All other cases will discard the changes and propagage
}
# dictutils equal equalp d1 d2 --
#
# Compare two dictionaries for equality. Two dictionaries are equal
# if they (a) have the same keys, (b) the corresponding values for
# each key in the two dictionaries are equal when compared using the
# equality predicate, equalp (passed as an argument). The equality
# predicate is invoked with the key and the two values from each
# dictionary as arguments.
#
proc equal {equalp d1 d2} {
if {[dict size $d1] != [dict size $d2]} { return 0 }
dict for {k v} $d1 {
if {![dict exists $d2 $k]} { return 0 }
if {![invoke $equalp $k $v [dict get $d2 $k]]} { return 0 }
}
return 1
}
# apply dictVar lambdaExpr ?arg1 arg2 ...? --
#
# A combination of *dict with* and *apply*, this procedure creates a
# new procedure scope populated with the values in the dictionary
# variable. It then applies the lambdaTerm (anonymous procedure) in
# this new scope. If the procedure completes normally, then any
# changes made to variables in the dictionary are reflected back to
# the dictionary variable, otherwise they are ignored. This provides
# a transaction-style semantics whereby atomic updates to a
# dictionary can be performed. This procedure can also be useful for
# implementing a variety of control constructs, such as mutable
# closures.
#
proc apply {dictVar lambdaExpr args} {
upvar 1 $dictVar dict
set env $dict ;# copy
lassign $lambdaExpr params body ns
if {$ns eq ""} { set ns "::" }
set body [format {
upvar 1 env __env__
dict with __env__ %s
} [list $body]]
set lambdaExpr [list $params $body $ns]
set rc [catch { ::apply $lambdaExpr {*}$args } ret opts]
if {$rc == 0} {
# Copy back any updates
set dict $env
}
return -options $opts $ret
}
# capture ?level? ?exclude? ?include? --
#
# Captures a snapshot of the current (scalar) variable bindings at
# $level on the stack into a dictionary environment. This dictionary
# can later be used with *dictutils apply* to partially restore the
# scope, creating a first approximation of closures. The *level*
# argument should be of the forms accepted by *uplevel* and
# designates which level to capture. It defaults to 1 as in uplevel.
# The *exclude* argument specifies an optional list of literal
# variable names to avoid when performing the capture. No variables
# matching any item in this list will be captured. The *include*
# argument can be used to specify a list of glob patterns of
# variables to capture. Only variables matching one of these
# patterns are captured. The default is a single pattern "*", for
# capturing all visible variables (as determined by *info vars*).
#
proc capture {{level 1} {exclude {}} {include {*}}} {
if {[string is integer $level]} { incr level }
set env [dict create]
foreach pattern $include {
foreach name [uplevel $level [list info vars $pattern]] {
if {[lsearch -exact -index 0 $exclude $name] >= 0} { continue }
upvar $level $name value
catch { dict set env $name $value } ;# no arrays
}
}
return $env
}
# nlappend dictVar keyList ?value ...?
#
# Append zero or more elements to the list value stored in the given
# dictionary at the path of keys specified in $keyList. If $keyList
# specifies a non-existent path of keys, nlappend will behave as if
# the path mapped to an empty list.
#
proc nlappend {dictvar keylist args} {
upvar 1 $dictvar dict
if {[info exists dict] && [dict exists $dict {*}$keylist]} {
set list [dict get $dict {*}$keylist]
}
lappend list {*}$args
dict set dict {*}$keylist $list
}
# invoke cmd args... --
#
# Helper procedure to invoke a callback command with arguments at
# the global scope. The helper ensures that proper quotation is
# used. The command is expected to be a list, e.g. {string equal}.
#
proc invoke {cmd args} { uplevel #0 $cmd $args }
}

6411
src/deps/metaface-1.2.5.tm vendored
View File

File diff suppressed because it is too large Load Diff

1285
src/deps/pattern-1.2.4.tm vendored
View File

File diff suppressed because it is too large Load Diff

645
src/deps/patterncmd-1.2.4.tm vendored
Unescape View File

@ -0,0 +1,645 @@
package provide patterncmd [namespace eval patterncmd {
variable version
set version 1.2.4
}]
namespace eval pattern {
variable idCounter 1 ;#used by pattern::uniqueKey
namespace eval cmd {
namespace eval util {
package require overtype
variable colwidths_lib [dict create]
variable colwidths_lib_default 15
dict set colwidths_lib "library" [list ch " " num 21 head "|" tail ""]
dict set colwidths_lib "version" [list ch " " num 7 head "|" tail ""]
dict set colwidths_lib "type" [list ch " " num 9 head "|" tail ""]
dict set colwidths_lib "note" [list ch " " num 31 head "|" tail "|"]
proc colhead {type args} {
upvar #0 ::pattern::cmd::util::colwidths_$type colwidths
set line ""
foreach colname [dict keys $colwidths] {
append line "[col $type $colname [string totitle $colname] {*}$args]"
}
return $line
}
proc colbreak {type} {
upvar #0 ::pattern::cmd::util::colwidths_$type colwidths
set line ""
foreach colname [dict keys $colwidths] {
append line "[col $type $colname {} -backchar - -headoverridechar + -tailoverridechar +]"
}
return $line
}
proc col {type col val args} {
# args -head bool -tail bool ?
#----------------------------------------------------------------------------
set known_opts [list -backchar -headchar -tailchar -headoverridechar -tailoverridechar -justify]
dict set default -backchar ""
dict set default -headchar ""
dict set default -tailchar ""
dict set default -headoverridechar ""
dict set default -tailoverridechar ""
dict set default -justify "left"
if {([llength $args] % 2) != 0} {
error "(pattern::cmd::util::col) ERROR: uneven options supplied - must be of form '-option value' "
}
foreach {k v} $args {
if {$k ni $known_opts} {
error "((pattern::cmd::util::col) ERROR: option '$k' not in known options: '$known_opts'"
}
}
set opts [dict merge $default $args]
set backchar [dict get $opts -backchar]
set headchar [dict get $opts -headchar]
set tailchar [dict get $opts -tailchar]
set headoverridechar [dict get $opts -headoverridechar]
set tailoverridechar [dict get $opts -tailoverridechar]
set justify [dict get $opts -justify]
#----------------------------------------------------------------------------
upvar #0 ::pattern::cmd::util::colwidths_$type colwidths
#calculate headwidths
set headwidth 0
set tailwidth 0
foreach {key def} $colwidths {
set thisheadlen [string length [dict get $def head]]
if {$thisheadlen > $headwidth} {
set headwidth $thisheadlen
}
set thistaillen [string length [dict get $def tail]]
if {$thistaillen > $tailwidth} {
set tailwidth $thistaillen
}
}
set spec [dict get $colwidths $col]
if {[string length $backchar]} {
set ch $backchar
} else {
set ch [dict get $spec ch]
}
set num [dict get $spec num]
set headchar [dict get $spec head]
set tailchar [dict get $spec tail]
if {[string length $headchar]} {
set headchar $headchar
}
if {[string length $tailchar]} {
set tailchar $tailchar
}
#overrides only apply if the head/tail has a length
if {[string length $headchar]} {
if {[string length $headoverridechar]} {
set headchar $headoverridechar
}
}
if {[string length $tailchar]} {
if {[string length $tailoverridechar]} {
set tailchar $tailoverridechar
}
}
set head [string repeat $headchar $headwidth]
set tail [string repeat $tailchar $tailwidth]
set base [string repeat $ch [expr {$headwidth + $num + $tailwidth}]]
if {$justify eq "left"} {
set left_done [overtype::left $base "$head$val"]
return [overtype::right $left_done "$tail"]
} elseif {$justify in {centre center}} {
set mid_done [overtype::centre $base $val]
set left_mid_done [overtype::left $mid_done $head]
return [overtype::right $left_mid_done $tail]
} else {
set right_done [overtype::right $base "$val$tail"]
return [overtype::left $right_done $head]
}
}
}
}
}
#package require pattern
proc ::pattern::libs {} {
set libs [list \
pattern {-type core -note "alternative:pattern2"}\
pattern2 {-type core -note "alternative:pattern"}\
patterncmd {-type core}\
metaface {-type core}\
patternpredator2 {-type core}\
patterndispatcher {-type core}\
patternlib {-type core}\
patterncipher {-type optional -note optional}\
]
package require overtype
set result ""
append result "[cmd::util::colbreak lib]\n"
append result "[cmd::util::colhead lib -justify centre]\n"
append result "[cmd::util::colbreak lib]\n"
foreach libname [dict keys $libs] {
set libinfo [dict get $libs $libname]
append result [cmd::util::col lib library $libname]
if {[catch [list package present $libname] ver]} {
append result [cmd::util::col lib version "N/A"]
} else {
append result [cmd::util::col lib version $ver]
}
append result [cmd::util::col lib type [dict get $libinfo -type]]
if {[dict exists $libinfo -note]} {
set note [dict get $libinfo -note]
} else {
set note ""
}
append result [cmd::util::col lib note $note]
append result "\n"
}
append result "[cmd::util::colbreak lib]\n"
return $result
}
proc ::pattern::record {recname fields} {
if {[uplevel 1 [list namespace which $recname]] ne ""} {
error "(pattern::record) Can't create command '$recname': A command of that name already exists"
}
set index -1
set accessor [list ::apply {
{index rec args}
{
if {[llength $args] == 0} {
return [lindex $rec $index]
}
if {[llength $args] == 1} {
return [lreplace $rec $index $index [lindex $args 0]]
}
error "Invalid number of arguments."
}
}]
set map {}
foreach field $fields {
dict set map $field [linsert $accessor end [incr index]]
}
uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec]
}
proc ::pattern::record2 {recname fields} {
if {[uplevel 1 [list namespace which $recname]] ne ""} {
error "(pattern::record) Can't create command '$recname': A command of that name already exists"
}
set index -1
set accessor [list ::apply]
set template {
{rec args}
{
if {[llength $args] == 0} {
return [lindex $rec %idx%]
}
if {[llength $args] == 1} {
return [lreplace $rec %idx% %idx% [lindex $args 0]]
}
error "Invalid number of arguments."
}
}
set map {}
foreach field $fields {
set body [string map [list %idx% [incr index]] $template]
dict set map $field [list ::apply $body]
}
uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec]
}
proc ::argstest {args} {
package require cmdline
}
proc ::pattern::objects {} {
set result [::list]
foreach ns [namespace children ::pp] {
#lappend result [::list [namespace tail $ns] [set ${ns}::(self)]]
set ch [namespace tail $ns]
if {[string range $ch 0 2] eq "Obj"} {
set OID [string range $ch 3 end] ;#OID need not be digits (!?)
lappend result [::list $OID [list OID $OID object_command [set pp::${ch}::v_object_command] usedby [array names ${ns}::_iface::o_usedby]]]
}
}
return $result
}
proc ::pattern::name {num} {
#!todo - fix
#set ::p::${num}::(self)
lassign [interp alias {} ::p::$num] _predator info
if {![string length $_predator$info]} {
error "No object found for num:$num (no interp alias for ::p::$num)"
}
set invocants [dict get $info i]
set invocants_with_role_this [dict get $invocants this]
set invocant_this [lindex $invocants_with_role_this 0]
#lassign $invocant_this id info
#set map [dict get $info map]
#set fields [lindex $map 0]
lassign $invocant_this _id _ns _defaultmethod name _etc
return $name
}
proc ::pattern::with {cmd script} {
foreach c [info commands ::p::-1::*] {
interp alias {} [namespace tail $c] {} $c $cmd
}
interp alias {} . {} $cmd .
interp alias {} .. {} $cmd ..
return [uplevel 1 $script]
}
#system diagnostics etc
proc ::pattern::varspace_list {IID} {
namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_variables o_variables
set varspaces [list]
dict for {vname vdef} $o_variables {
set vs [dict get $vdef varspace]
if {$vs ni $varspaces} {
lappend varspaces $vs
}
}
if {$o_varspace ni $varspaces} {
lappend varspaces $o_varspace
}
return $varspaces
}
proc ::pattern::check_interfaces {} {
foreach ns [namespace children ::p] {
set IID [namespace tail $ns]
if {[string is digit $IID]} {
foreach ref [array names ${ns}::_iface::o_usedby] {
set OID [string range $ref 1 end]
if {![namespace exists ::p::${OID}::_iface]} {
puts -nonewline stdout "\r\nPROBLEM!!!!!!!!! nonexistant/invalid object $OID referenced by Interface $IID\r\n"
} else {
puts -nonewline stdout .
}
#if {![info exists ::p::${OID}::(self)]} {
# puts "PROBLEM!!!!!!!!! nonexistant object $OID referenced by Interface $IID"
#}
}
}
}
puts -nonewline stdout "\r\n"
}
#from: http://wiki.tcl.tk/8766 (Introspection on aliases)
#usedby: metaface-1.1.6+
#required because aliases can be renamed.
#A renamed alias will still return it's target with 'interp alias {} oldname'
# - so given newname - we require which_alias to return the same info.
proc ::pattern::which_alias {cmd} {
uplevel 1 [list ::trace add execution $cmd enterstep ::error]
catch {uplevel 1 $cmd} res
uplevel 1 [list ::trace remove execution $cmd enterstep ::error]
#puts stdout "which_alias $cmd returning '$res'"
return $res
}
# [info args] like proc following an alias recursivly until it reaches
# the proc it originates from or cannot determine it.
# accounts for default parameters set by interp alias
#
proc ::pattern::aliasargs {cmd} {
set orig $cmd
set defaultargs [list]
# loop until error or return occurs
while {1} {
# is it a proc already?
if {[string equal [info procs $cmd] $cmd]} {
set result [info args $cmd]
# strip off the interp set default args
return [lrange $result [llength $defaultargs] end]
}
# is it a built in or extension command we can get no args for?
if {![string equal [info commands $cmd] $cmd]} {
error "\"$orig\" isn't a procedure"
}
# catch bogus cmd names
if {[lsearch [interp aliases {}] $cmd]==-1} {
if {[catch {::pattern::which_alias $cmd} alias]} {
error "\"$orig\" isn't a procedure or alias or command"
}
#set cmd [lindex $alias 0]
if {[llength $alias]>1} {
set cmd [lindex $alias 0]
set defaultargs [concat [lrange $alias 1 end] $defaultargs]
} else {
set cmd $alias
}
} else {
if {[llength [set cmdargs [interp alias {} $cmd]]]>0} {
# check if it is aliased in from another interpreter
if {[catch {interp target {} $cmd} msg]} {
error "Cannot resolve \"$orig\", alias leads to another interpreter."
}
if {$msg != {} } {
error "Not recursing into slave interpreter \"$msg\".\
\"$orig\" could not be resolved."
}
# check if defaults are set for the alias
if {[llength $cmdargs]>1} {
set cmd [lindex $cmdargs 0]
set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs]
} else {
set cmd $cmdargs
}
}
}
}
}
proc ::pattern::aliasbody {cmd} {
set orig $cmd
set defaultargs [list]
# loop until error or return occurs
while {1} {
# is it a proc already?
if {[string equal [info procs $cmd] $cmd]} {
set result [info body $cmd]
# strip off the interp set default args
return $result
#return [lrange $result [llength $defaultargs] end]
}
# is it a built in or extension command we can get no args for?
if {![string equal [info commands $cmd] $cmd]} {
error "\"$orig\" isn't a procedure"
}
# catch bogus cmd names
if {[lsearch [interp aliases {}] $cmd]==-1} {
if {[catch {::pattern::which_alias $cmd} alias]} {
error "\"$orig\" isn't a procedure or alias or command"
}
#set cmd [lindex $alias 0]
if {[llength $alias]>1} {
set cmd [lindex $alias 0]
set defaultargs [concat [lrange $alias 1 end] $defaultargs]
} else {
set cmd $alias
}
} else {
if {[llength [set cmdargs [interp alias {} $cmd]]]>0} {
# check if it is aliased in from another interpreter
if {[catch {interp target {} $cmd} msg]} {
error "Cannot resolve \"$orig\", alias leads to another interpreter."
}
if {$msg != {} } {
error "Not recursing into slave interpreter \"$msg\".\
\"$orig\" could not be resolved."
}
# check if defaults are set for the alias
if {[llength $cmdargs]>1} {
set cmd [lindex $cmdargs 0]
set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs]
} else {
set cmd $cmdargs
}
}
}
}
}
proc ::pattern::uniqueKey2 {} {
#!todo - something else??
return [clock seconds]-[incr ::pattern::idCounter]
}
#used by patternlib package
proc ::pattern::uniqueKey {} {
return [incr ::pattern::idCounter]
#uuid with tcllibc is about 30us compared with 2us
# for large datasets, e.g about 100K inserts this would be pretty noticable!
#!todo - uuid pool with background thread to repopulate when idle?
#return [uuid::uuid generate]
}
#-------------------------------------------------------------------------------------------------------------------------
proc ::pattern::test1 {} {
set msg "OK"
puts stderr "next line should say:'--- saystuff:$msg"
::>pattern .. Create ::>thing
::>thing .. PatternMethod saystuff args {
puts stderr "--- saystuff: $args"
}
::>thing .. Create ::>jjj
::>jjj . saystuff $msg
::>jjj .. Destroy
::>thing .. Destroy
}
proc ::pattern::test2 {} {
set msg "OK"
puts stderr "next line should say:'--- property 'stuff' value:$msg"
::>pattern .. Create ::>thing
::>thing .. PatternProperty stuff $msg
::>thing .. Create ::>jjj
puts stderr "--- property 'stuff' value:[::>jjj . stuff]"
::>jjj .. Destroy
::>thing .. Destroy
}
proc ::pattern::test3 {} {
set msg "OK"
puts stderr "next line should say:'--- property 'stuff' value:$msg"
::>pattern .. Create ::>thing
::>thing .. Property stuff $msg
puts stderr "--- property 'stuff' value:[::>thing . stuff]"
::>thing .. Destroy
}
#---------------------------------
#unknown/obsolete
#proc ::p::internals::showargs {args {ch stdout}} {puts $ch $args}
if {0} {
proc ::p::internals::new_interface {{usedbylist {}}} {
set OID [incr ::p::ID]
::p::internals::new_object ::p::ifaces::>$OID "" $OID
puts "obsolete >> new_interface created object $OID"
foreach usedby $usedbylist {
set ::p::${OID}::_iface::o_usedby(i$usedby) 1
}
set ::p::${OID}::_iface::o_varspace "" ;#default varspace is the object's namespace. (varspace is absolute if it has leading :: , otherwise it's a relative namespace below the object's namespace)
#NOTE - o_varspace is only the default varspace for when new methods/properties are added.
# it is possible to create some methods/props with one varspace value, then create more methods/props with a different varspace value.
set ::p::${OID}::_iface::o_constructor [list]
set ::p::${OID}::_iface::o_variables [list]
set ::p::${OID}::_iface::o_properties [dict create]
set ::p::${OID}::_iface::o_methods [dict create]
array set ::p::${OID}::_iface::o_definition [list]
set ::p::${OID}::_iface::o_open 1 ;#open for extending
return $OID
}
#temporary way to get OID - assumes single 'this' invocant
#!todo - make generic.
proc ::pattern::get_oid {_ID_} {
#puts stderr "#* get_oid: [lindex [dict get $_ID_ i this] 0 0]"
return [lindex [dict get $_ID_ i this] 0 0]
#set invocants [dict get $_ID_ i]
#set invocant_roles [dict keys $invocants]
#set role_members [dict get $invocants this]
##set this_invocant [lindex $role_members 0] ;#for the role 'this' we assume only one invocant in the list.
#set this_invocant [lindex [dict get $_ID_ i this] 0] ;
#lassign $this_invocant OID this_info
#
#return $OID
}
#compile the uncompiled level1 interface
#assert: no more than one uncompiled interface present at level1
proc ::p::meta::PatternCompile {self} {
????
upvar #0 $self SELFMAP
set ID [lindex $SELFMAP 0 0]
set patterns [lindex $SELFMAP 1 1] ;#list of level1 interfaces
set iid -1
foreach i $patterns {
if {[set ::p::${i}::_iface::o_open]} {
set iid $i ;#found it
break
}
}
if {$iid > -1} {
#!todo
::p::compile_interface $iid
set ::p::${iid}::_iface::o_open 0
} else {
#no uncompiled interface present at level 1. Do nothing.
return
}
}
proc ::p::meta::Def {self} {
error ::p::meta::Def
upvar #0 $self SELFMAP
set self_ID [lindex $SELFMAP 0 0]
set IFID [lindex $SELFMAP 1 0 end]
set maxc1 0
set maxc2 0
set arrName ::p::${IFID}::
upvar #0 $arrName state
array set methods {}
foreach nm [array names state] {
if {[regexp {^m-1,name,(.+)} $nm _match mname]} {
set methods($mname) [set state($nm)]
if {[string length $mname] > $maxc1} {
set maxc1 [string length $mname]
}
if {[string length [set state($nm)]] > $maxc2} {
set maxc2 [string length [set state($nm)]]
}
}
}
set bg1 [string repeat " " [expr {$maxc1 + 2}]]
set bg2 [string repeat " " [expr {$maxc2 + 2}]]
set r {}
foreach nm [lsort -dictionary [array names methods]] {
set arglist $state(m-1,args,$nm)
append r "[overtype::left $bg1 $nm] : [overtype::left $bg2 $methods($nm)] [::list $arglist]\n"
}
return $r
}
}

2590
src/deps/patternlib-1.2.6.tm vendored
View File

File diff suppressed because it is too large Load Diff

754
src/deps/patternpredator2-1.2.4.tm vendored
Unescape View File

@ -0,0 +1,754 @@
package provide patternpredator2 1.2.4
proc ::p::internals::jaws {OID _ID_ args} {
#puts stderr ">>>(patternpredator2 lib)jaws called with _ID_:$_ID_ args: $args"
#set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid
yield
set w 1
set stack [list]
set wordcount [llength $args]
set terminals [list . .. , # @ !] ;#tokens which require the current stack to be evaluated first
set unsupported 0
set operator ""
set operator_prev "" ;#used only by argprotect to revert to previous operator
if {$OID ne "null"} {
#!DO NOT use upvar here for MAP! (calling set on a MAP in another iteration/call will overwrite a map for another object!)
#upvar #0 ::p::${OID}::_meta::map MAP
set MAP [set ::p::${OID}::_meta::map]
} else {
# error "jaws - OID = 'null' ???"
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ] ;#MAP taken from _ID_ will be missing 'interfaces' key
}
set invocantdata [dict get $MAP invocantdata]
lassign $invocantdata OID alias default_method object_command wrapped
set finished_args 0 ;#whether we've completely processed all args in the while loop and therefor don't need to peform the final word processing code
#don't use 'foreach word $args' - we sometimes need to backtrack a little by manipulating $w
while {$w < $wordcount} {
set word [lindex $args [expr {$w -1}]]
#puts stdout "w:$w word:$word stack:$stack"
if {$operator eq "argprotect"} {
set operator $operator_prev
lappend stack $word
incr w
} else {
if {[llength $stack]} {
if {$word in $terminals} {
set reduction [list 0 $_ID_ {*}$stack ]
#puts stderr ">>>jaws yielding value: $reduction triggered by word $word in position:$w"
set _ID_ [yield $reduction]
set stack [list]
#set OID [::pattern::get_oid $_ID_]
set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid
if {$OID ne "null"} {
set MAP [set ::p::${OID}::_meta::map] ;#Do not use upvar here!
} else {
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces [list level0 {} level1 {}]]
#puts stderr "WARNING REVIEW: jaws-branch - leave empty??????"
}
#review - 2018. switched to _ID_ instead of MAP
lassign [lindex [dict get $_ID_ i this] 0] OID alias default_method object_command
#lassign [dict get $MAP invocantdata] OID alias default_method object_command
#puts stdout "---->>> yielded _ID_: $_ID_ OID:$OID alias:$alias default_method:$default_method object_command:$object_command"
set operator $word
#don't incr w
#incr w
} else {
if {$operator eq "argprotect"} {
set operator $operator_prev
set operator_prev ""
lappend stack $word
} else {
#only look for leading argprotect chacter (-) if we're not already in argprotect mode
if {$word eq "--"} {
set operator_prev $operator
set operator "argprotect"
#Don't add the plain argprotector to the stack
} elseif {[string match "-*" $word]} {
#argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument)
set operator_prev $operator
set operator "argprotect"
lappend stack $word
} else {
lappend stack $word
}
}
incr w
}
} else {
#no stack
switch -- $word {.} {
if {$OID ne "null"} {
#we know next word is a property or method of a pattern object
incr w
set nextword [lindex $args [expr {$w - 1}]]
set command ::p::${OID}::$nextword
set stack [list $command] ;#2018 j
set operator .
if {$w eq $wordcount} {
set finished_args 1
}
} else {
# don't incr w
#set nextword [lindex $args [expr {$w - 1}]]
set command $object_command ;#taken from the MAP
set stack [list "_exec_" $command]
set operator .
}
} {..} {
incr w
set nextword [lindex $args [expr {$w -1}]]
set command ::p::-1::$nextword
#lappend stack $command ;#lappend a small number of items to an empty list is slower than just setting the list.
set stack [list $command] ;#faster, and intent is clearer than lappend.
set operator ..
if {$w eq $wordcount} {
set finished_args 1
}
} {,} {
#puts stdout "Stackless comma!"
if {$OID ne "null"} {
set command ::p::${OID}::$default_method
} else {
set command [list $default_method $object_command]
#object_command in this instance presumably be a list and $default_method a list operation
#e.g "lindex {A B C}"
}
#lappend stack $command
set stack [list $command]
set operator ,
} {--} {
set operator_prev $operator
set operator argprotect
#no stack -
} {!} {
set command $object_command
set stack [list "_exec_" $object_command]
#puts stdout "!!!! !!!! $stack"
set operator !
} default {
if {$operator eq ""} {
if {$OID ne "null"} {
set command ::p::${OID}::$default_method
} else {
set command [list $default_method $object_command]
}
set stack [list $command]
set operator ,
lappend stack $word
} else {
#no stack - so we don't expect to be in argprotect mode already.
if {[string match "-*" $word]} {
#argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument)
set operator_prev $operator
set operator "argprotect"
lappend stack $word
} else {
lappend stack $word
}
}
}
incr w
}
}
} ;#end while
#process final word outside of loop
#assert $w == $wordcount
#trailing operators or last argument
if {!$finished_args} {
set word [lindex $args [expr {$w -1}]]
if {$operator eq "argprotect"} {
set operator $operator_prev
set operator_prev ""
lappend stack $word
incr w
} else {
switch -- $word {.} {
if {![llength $stack]} {
#set stack [list "_result_" [::p::internals::ref_to_object $_ID_]]
yieldto return [::p::internals::ref_to_object $_ID_]
error "assert: never gets here"
} else {
#puts stdout "==== $stack"
#assert - whenever _ID_ changed in this proc - we have updated the $OID variable
yieldto return [::p::internals::ref_to_stack $OID $_ID_ $stack]
error "assert: never gets here"
}
set operator .
} {..} {
#trailing .. after chained call e.g >x . item 0 ..
#puts stdout "$$$$$$$$$$$$ [list 0 $_ID_ {*}$stack] $$$$"
#set reduction [list 0 $_ID_ {*}$stack]
yieldto return [yield [list 0 $_ID_ {*}$stack]]
} {#} {
set unsupported 1
} {,} {
set unsupported 1
} {&} {
set unsupported 1
} {@} {
set unsupported 1
} {--} {
#set reduction [list 0 $_ID_ {*}$stack[set stack [list]]]
#puts stdout " -> -> -> about to call yield $reduction <- <- <-"
set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]] ]
#set OID [::pattern::get_oid $_ID_]
set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid
if {$OID ne "null"} {
set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here!
} else {
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}} ]
}
yieldto return $MAP
} {!} {
#error "untested branch"
set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]]]
#set OID [::pattern::get_oid $_ID_]
set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid
if {$OID ne "null"} {
set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here!
} else {
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ]
}
lassign [dict get $MAP invocantdata] OID alias default_command object_command
set command $object_command
set stack [list "_exec_" $command]
set operator !
} default {
if {$operator eq ""} {
#error "untested branch"
lassign [dict get $MAP invocantdata] OID alias default_command object_command
#set command ::p::${OID}::item
set command ::p::${OID}::$default_command
lappend stack $command
set operator ,
}
#do not look for argprotect items here (e.g -option) as the final word can't be an argprotector anyway.
lappend stack $word
}
if {$unsupported} {
set unsupported 0
error "trailing '$word' not supported"
}
#if {$operator eq ","} {
# incr wordcount 2
# set stack [linsert $stack end-1 . item]
#}
incr w
}
}
#final = 1
#puts stderr ">>>jaws final return value: [list 1 $_ID_ {*}$stack]"
return [list 1 $_ID_ {*}$stack]
}
#trailing. directly after object
proc ::p::internals::ref_to_object {_ID_} {
set OID [lindex [dict get $_ID_ i this] 0 0]
upvar #0 ::p::${OID}::_meta::map MAP
lassign [dict get $MAP invocantdata] OID alias default_method object_command
set refname ::p::${OID}::_ref::__OBJECT
array set $refname [list] ;#important to initialise the variable as an array here - or initial read attempts on elements will not fire traces
set traceCmd [list ::p::predator::object_read_trace $OID $_ID_]
if {[list {read} $traceCmd] ni [trace info variable $refname]} {
#puts stdout "adding read trace on variable '$refname' - traceCmd:'$traceCmd'"
trace add variable $refname {read} $traceCmd
}
set traceCmd [list ::p::predator::object_array_trace $OID $_ID_]
if {[list {array} $traceCmd] ni [trace info variable $refname]} {
trace add variable $refname {array} $traceCmd
}
set traceCmd [list ::p::predator::object_write_trace $OID $_ID_]
if {[list {write} $traceCmd] ni [trace info variable $refname]} {
trace add variable $refname {write} $traceCmd
}
set traceCmd [list ::p::predator::object_unset_trace $OID $_ID_]
if {[list {unset} $traceCmd] ni [trace info variable $refname]} {
trace add variable $refname {unset} $traceCmd
}
return $refname
}
proc ::p::internals::create_or_update_reference {OID _ID_ refname command} {
#if {[lindex $fullstack 0] eq "_exec_"} {
# #strip it. This instruction isn't relevant for a reference.
# set commandstack [lrange $fullstack 1 end]
#} else {
# set commandstack $fullstack
#}
#set argstack [lassign $commandstack command]
#set field [string map {> __OBJECT_} [namespace tail $command]]
set reftail [namespace tail $refname]
set argstack [lassign [split $reftail +] field]
set field [string map {> __OBJECT_} [namespace tail $command]]
#puts stderr "refname:'$refname' command: $command field:$field"
if {$OID ne "null"} {
upvar #0 ::p::${OID}::_meta::map MAP
} else {
#set map [dict get [lindex [dict get $_ID_ i this] 0 1] map]
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}}]
}
lassign [dict get $MAP invocantdata] OID alias default_method object_command
if {$OID ne "null"} {
interp alias {} $refname {} $command $_ID_ {*}$argstack
} else {
interp alias {} $refname {} $command {*}$argstack
}
#set iflist [lindex $map 1 0]
set iflist [dict get $MAP interfaces level0]
#set iflist [dict get $MAP interfaces level0]
set field_is_property_like 0
foreach IFID [lreverse $iflist] {
#tcl (braced) expr has lazy evaluation for &&, || & ?: operators - so this should be reasonably efficient.
if {[llength [info commands ::p::${IFID}::_iface::(GET)$field]] || [llength [info commands ::p::${IFID}::_iface::(SET)$field]]} {
set field_is_property_like 1
#There is a setter or getter (but not necessarily an entry in the o_properties dict)
break
}
}
#whether field is a property or a method - remove any commandrefMisuse_TraceHandler
foreach tinfo [trace info variable $refname] {
#puts "-->removing traces on $refname: $tinfo"
if {[lindex $tinfo 1 0] eq "::p::internals::commandrefMisuse_TraceHandler"} {
trace remove variable $refname {*}$tinfo
}
}
if {$field_is_property_like} {
#property reference
set this_invocantdata [lindex [dict get $_ID_ i this] 0]
lassign $this_invocantdata OID _alias _defaultmethod object_command
#get fully qualified varspace
#
set propdict [$object_command .. GetPropertyInfo $field]
if {[dict exist $propdict $field]} {
set field_is_a_property 1
set propinfo [dict get $propdict $field]
set varspace [dict get $propinfo varspace]
if {$varspace eq ""} {
set full_varspace ::p::${OID}
} else {
if {[::string match "::*" $varspace]} {
set full_varspace $varspace
} else {
set full_varspace ::p::${OID}::$varspace
}
}
} else {
set field_is_a_property 0
#no propertyinfo - this field was probably established as a PropertyRead and/or PropertyWrite without a Property
#this is ok - and we still set the trace infrastructure below (app may convert it to a normal Property later)
set full_varspace ::p::${OID}
}
#We only trace on entire property.. not array elements (if references existed to both the array and an element both traces would be fired -(entire array trace first))
set Hndlr [::list ::p::predator::propvar_write_TraceHandler $OID $field]
if { [::list {write} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} {
trace add variable ${full_varspace}::o_${field} {write} $Hndlr
}
set Hndlr [::list ::p::predator::propvar_unset_TraceHandler $OID $field]
if { [::list {unset} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} {
trace add variable ${full_varspace}::o_${field} {unset} $Hndlr
}
#supply all data in easy-access form so that propref_trace_read is not doing any extra work.
set get_cmd ::p::${OID}::(GET)$field
set traceCmd [list ::p::predator::propref_trace_read $get_cmd $_ID_ $refname $field $argstack]
if {[list {read} $traceCmd] ni [trace info variable $refname]} {
set fieldvarname ${full_varspace}::o_${field}
#synch the refvar with the real var if it exists
#catch {set $refname [$refname]}
if {[array exists $fieldvarname]} {
if {![llength $argstack]} {
#unindexed reference
array set $refname [array get $fieldvarname]
#upvar $fieldvarname $refname
} else {
set s0 [lindex $argstack 0]
#refs to nonexistant array members common? (catch vs 'info exists')
if {[info exists ${fieldvarname}($s0)]} {
set $refname [set ${fieldvarname}($s0)]
}
}
} else {
#refs to uninitialised props actually should be *very* common.
#If we use 'catch', it means retrieving refs to non-initialised props is slower. Fired catches can be relatively expensive.
#Because it's common to get a ref to uninitialised props (e.g for initial setting of their value) - we will use 'info exists' instead of catch.
#set errorInfo_prev $::errorInfo ;#preserve errorInfo across catches!
#puts stdout " ---->>!!! ref to uninitialised prop $field $argstack !!!<------"
if {![llength $argstack]} {
#catch {set $refname [set ::p::${OID}::o_$field]}
if {[info exists $fieldvarname]} {
set $refname [set $fieldvarname]
#upvar $fieldvarname $refname
}
} else {
if {[llength $argstack] == 1} {
#catch {set $refname [lindex [set ::p::${OID}::o_$field] [lindex $argstack 0]]}
if {[info exists $fieldvarname]} {
set $refname [lindex [set $fieldvarname] [lindex $argstack 0]]
}
} else {
#catch {set $refname [lindex [set ::p::${OID}::o_$field] $argstack]}
if {[info exists $fieldvarname]} {
set $refname [lindex [set $fieldvarname] $argstack]
}
}
}
#! what if someone has put a trace on ::errorInfo??
#set ::errorInfo $errorInfo_prev
}
trace add variable $refname {read} $traceCmd
set traceCmd [list ::p::predator::propref_trace_write $_ID_ $OID $full_varspace $refname]
trace add variable $refname {write} $traceCmd
set traceCmd [list ::p::predator::propref_trace_unset $_ID_ $OID $refname]
trace add variable $refname {unset} $traceCmd
set traceCmd [list ::p::predator::propref_trace_array $_ID_ $OID $refname]
# puts "**************** installing array variable trace on ref:$refname - cmd:$traceCmd"
trace add variable $refname {array} $traceCmd
}
} else {
#puts "$refname ====> adding refMisuse_traceHandler $alias $field"
#matching variable in order to detect attempted use as property and throw error
#2018
#Note that we are adding a trace on a variable (the refname) which does not exist.
#this is fine - except that the trace won't fire for attempt to write it as an array using syntax such as set $ref(someindex)
#we could set the ref to an empty array - but then we have to also undo this if a property with matching name is added
##array set $refname {} ;#empty array
# - the empty array would mean a slightly better error message when misusing a command ref as an array
#but this seems like a code complication for little benefit
#review
trace add variable $refname {read write unset array} [list ::p::internals::commandrefMisuse_TraceHandler $OID $field]
}
}
#trailing. after command/property
proc ::p::internals::ref_to_stack {OID _ID_ fullstack} {
if {[lindex $fullstack 0] eq "_exec_"} {
#strip it. This instruction isn't relevant for a reference.
set commandstack [lrange $fullstack 1 end]
} else {
set commandstack $fullstack
}
set argstack [lassign $commandstack command]
set field [string map {> __OBJECT_} [namespace tail $command]]
#!todo?
# - make every object's OID unpredictable and sparse (UUID) and modify 'namespace child' etc to prevent iteration/inspection of ::p namespace.
# - this would only make sense for an environment where any meta methods taking a code body (e.g .. Method .. PatternMethod etc) are restricted.
#references created under ::p::${OID}::_ref are effectively inside a 'varspace' within the object itself.
# - this would in theory allow a set of interface functions on the object which have direct access to the reference variables.
set refname ::p::${OID}::_ref::[join [concat $field $argstack] +]
if {[llength [info commands $refname]]} {
#todo - review - what if the field changed to/from a property/method?
#probably should fix that where such a change is made and leave this short circuit here to give reasonable performance for existing refs
return $refname
}
::p::internals::create_or_update_reference $OID $_ID_ $refname $command
return $refname
}
namespace eval pp {
variable operators [list .. . -- - & @ # , !]
variable operators_notin_args ""
foreach op $operators {
append operators_notin_args "({$op} ni \$args) && "
}
set operators_notin_args [string trimright $operators_notin_args " &"] ;#trim trailing spaces and ampersands
#set operators_notin_args {({.} ni $args) && ({,} ni $args) && ({..} ni $args)}
}
interp alias {} strmap {} string map ;#stop code editor from mono-colouring our big string mapped code blocks!
# 2017 ::p::predator2 is the development version - intended for eventual use as the main dispatch mechanism.
#each map is a 2 element list of lists.
# form: {$commandinfo $interfaceinfo}
# commandinfo is of the form: {ID Namespace defaultmethod commandname _?}
#2018
#each map is a dict.
#form: {invocantdata {ID Namespace defaultmethod commandname _?} interfaces {level0 {} level1 {}}}
#OID = Object ID (integer for now - could in future be a uuid)
proc ::p::predator2 {_ID_ args} {
#puts stderr "predator2: _ID_:'$_ID_' args:'$args'"
#set invocants [dict get $_ID_ i]
#set invocant_roles [dict keys $invocants]
#For now - we are 'this'-centric (single dispatch). todo - adapt for multiple roles, multimethods etc.
#set this_role_members [dict get $invocants this]
#set this_invocant [lindex [dict get $_ID_ i this] 0] ;#for the role 'this' we assume only one invocant in the list.
#lassign $this_invocant this_OID this_info_dict
set this_OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid
set cheat 1 ;#
#-------
#Optimise the next most common use case. A single . followed by args which contain no other operators (non-chained call)
#(it should be functionally equivalent to remove this shortcut block)
if {$cheat} {
if { ([lindex $args 0] eq {.}) && ([llength $args] > 1) && ([llength [lsearch -all -inline $args .]] == 1) && ({,} ni $args) && ({..} ni $args) && ({--} ni $args) && ({!} ni $args)} {
set remaining_args [lassign $args dot method_or_prop]
#how will we do multiple apis? (separate interface stacks) apply? apply [list [list _ID_ {*}$arglist] ::p::${stackid?}::$method_or_prop ::p::${this_OID}] ???
set command ::p::${this_OID}::$method_or_prop
#REVIEW!
#e.g what if the method is named "say hello" ?? (hint - it will break because we will look for 'say')
#if {[llength $command] > 1} {
# error "methods with spaces not included in test suites - todo fix!"
#}
#Dont use {*}$command - (so we can support methods with spaces)
#if {![llength [info commands $command]]} {}
if {[namespace which $command] eq ""} {
if {[namespace which ::p::${this_OID}::(UNKNOWN)] ne ""} {
#lset command 0 ::p::${this_OID}::(UNKNOWN) ;#seems wrong - command could have spaces
set command ::p::${this_OID}::(UNKNOWN)
#tailcall {*}$command $_ID_ $cmdname {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg.
tailcall $command $_ID_ $method_or_prop {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg.
} else {
return -code error -errorinfo "(::p::predator2) error running command:'$command' argstack:'[lrange $args 2 end]'\n - command not found and no 'unknown' handler" "method '$method_or_prop' not found"
}
} else {
#tailcall {*}$command $_ID_ {*}$remaining_args
tailcall $command $_ID_ {*}$remaining_args
}
}
}
#------------
if {([llength $args] == 1) && ([lindex $args 0] eq "..")} {
return $_ID_
}
#puts stderr "pattern::predator (test version) called with: _ID_:$_ID_ args:$args"
#puts stderr "this_info_dict: $this_info_dict"
if {![llength $args]} {
#should return some sort of public info.. i.e probably not the ID which is an implementation detail
#return cmd
return [lindex [dict get [set ::p::${this_OID}::_meta::map] invocantdata] 0] ;#Object ID
#return a dict keyed on object command name - (suitable as use for a .. Create 'target')
#lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method object_command wrapped
#return [list $object_command [list -id $this_OID ]]
} elseif {[llength $args] == 1} {
#short-circuit the single index case for speed.
if {[lindex $args 0] ni {.. . -- - & @ # , !}} {
#lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method
lassign [lindex [dict get $_ID_ i this] 0] this_OID alias default_method
tailcall ::p::${this_OID}::$default_method $_ID_ [lindex $args 0]
} elseif {[lindex $args 0] eq {--}} {
#!todo - we could hide the invocant by only allowing this call from certain uplevel procs..
# - combined with using UUIDs for $OID, and a secured/removed metaface on the object
# - (and also hiding of [interp aliases] command so they can't iterate and examine all aliases)
# - this could effectively hide the object's namespaces,vars etc from the caller (?)
return [set ::p::${this_OID}::_meta::map]
}
}
#upvar ::p::coroutine_instance c ;#coroutine names must be unique per call to predator (not just per object - or we could get a clash during some cyclic calls)
#incr c
#set reduce ::p::reducer${this_OID}_$c
set reduce ::p::reducer${this_OID}_[incr ::p::coroutine_instance]
#puts stderr "..................creating reducer $reduce with args $this_OID _ID_ $args"
coroutine $reduce ::p::internals::jaws $this_OID $_ID_ {*}$args
set current_ID_ $_ID_
set final 0
set result ""
while {$final == 0} {
#the argument given here to $reduce will be returned by 'yield' within the coroutine context (jaws)
set reduction_args [lassign [$reduce $current_ID_[set current_ID_ [list]] ] final current_ID_ command]
#puts stderr "..> final:$final current_ID_:'$current_ID_' command:'$command' reduction_args:'$reduction_args'"
#if {[string match *Destroy $command]} {
# puts stdout " calling Destroy reduction_args:'$reduction_args'"
#}
if {$final == 1} {
if {[llength $command] == 1} {
if {$command eq "_exec_"} {
tailcall {*}$reduction_args
}
if {[llength [info commands $command]]} {
tailcall {*}$command $current_ID_ {*}$reduction_args
}
set cmdname [namespace tail $command]
set this_OID [lindex [dict get $current_ID_ i this] 0 0]
if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} {
lset command 0 ::p::${this_OID}::(UNKNOWN)
tailcall {*}$command $current_ID_ $cmdname {*}$reduction_args ;#delegate to UNKNOWN, along with original commandname as 1st arg.
} else {
return -code error -errorinfo "1)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found"
}
} else {
#e.g lindex {a b c}
tailcall {*}$command {*}$reduction_args
}
} else {
if {[lindex $command 0] eq "_exec_"} {
set result [uplevel 1 [list {*}[lrange $command 1 end] {*}$reduction_args]]
set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {} ]
} else {
if {[llength $command] == 1} {
if {![llength [info commands $command]]} {
set cmdname [namespace tail $command]
set this_OID [lindex [dict get $current_ID_ i this] 0 0]
if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} {
lset command 0 ::p::${this_OID}::(UNKNOWN)
set result [uplevel 1 [list {*}$command $current_ID_ $cmdname {*}$reduction_args]] ;#delegate to UNKNOWN, along with original commandname as 1st arg.
} else {
return -code error -errorinfo "2)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found"
}
} else {
#set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]]
set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]]
}
} else {
set result [uplevel 1 [list {*}$command {*}$reduction_args]]
}
if {[llength [info commands $result]]} {
if {([llength $result] == 1) && ([string first ">" [namespace tail $result]] == 0)} {
#looks like a pattern command
set current_ID_ [$result .. INVOCANTDATA]
#todo - determine if plain .. INVOCANTDATA is sufficient instead of .. UPDATEDINVOCANTDATA
#if {![catch {$result .. INVOCANTDATA} result_invocantdata]} {
# set current_ID_ $result_invocantdata
#} else {
# return -code error -errorinfo "3)error running command:'$command' argstack:'$reduction_args'\n - Failed to access result:'$result' as a pattern object." "Failed to access result:'$result' as a pattern object"
#}
} else {
#non-pattern command
set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}]
}
} else {
set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}]
#!todo - allow further operations on non-command values. e.g dicts, lists & strings (treat strings as lists)
}
}
}
}
error "Assert: Shouldn't get here (end of ::p::predator2)"
#return $result
}
Write Preview
Loading…
Cancel
Save