5 changed files with 3271 additions and 0 deletions
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,664 @@
|
||||
package provide patternpredator1 1.0 |
||||
|
||||
proc ::p::internals::trailing, {map command stack i arglist pending} { |
||||
error "trailing ',' is not a valid sequence. If the comma was meant to be an argument, precede it with the -- operator." |
||||
} |
||||
proc ::p::internals::trailing.. {map command stack i arglist pending} { |
||||
error "trailing .. references not implemented." |
||||
} |
||||
|
||||
proc ::p::internals::trailing. {map command _ID_ stack i arglist pending} { |
||||
if {![llength $map]} { |
||||
error "Trailing . but no map - command:'$command' stack:$stack i:$i arglist:$arglist pending:$pending" |
||||
} |
||||
|
||||
|
||||
|
||||
#trailing dot - get reference. |
||||
#puts ">>trailing dot>> map:$map command:$command _ID_:$_ID_ stack:$stack i:$i arglist:$arglist pending:$pending" |
||||
lassign [lindex $map 0] OID alias itemCmd cmd |
||||
|
||||
|
||||
#lassign $command command _ID_ |
||||
|
||||
|
||||
if {$pending eq {}} { |
||||
#no pending operation requiring evaluation. |
||||
|
||||
#presumably we're getting a ref to the object, not a property or method. |
||||
#set traceCmd [::list ::p::objectRef_TraceHandler $cmd $_self $OID] |
||||
#if {[::list {array read write unset} $traceCmd] ni [trace info variable $refname]} { |
||||
# trace add variable $refname {array read write unset} $traceCmd |
||||
#} |
||||
set refname ::p::${OID}::_ref::__OBJECT ;#!todo - avoid potential collision with ref to member named '__OBJECT'. |
||||
#object ref - ensure trace-var is an array upon which the objects methods & properties can be accessed as indices |
||||
array set $refname [list] |
||||
#!todo?- populate array with object methods/properties now? |
||||
|
||||
|
||||
set _ID_ [list i [list this [list [list $OID [list map $map]]]]] |
||||
|
||||
#!todo - review. What if $map is out of date? |
||||
|
||||
set traceCmd [list ::p::predator::object_read_trace $OID $_ID_] |
||||
if {[list {read} $traceCmd] ni [trace info variable $refname]} { |
||||
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 |
||||
} |
||||
|
||||
|
||||
#set command $refname |
||||
return $refname |
||||
} else { |
||||
#puts "- 11111111 '$command' '$stack'" |
||||
|
||||
if {[string range $command 0 171] eq "::p::-1::"} { |
||||
#!todo - review/enable this branch? |
||||
|
||||
#reference to meta-member |
||||
|
||||
#STALE map problem!! |
||||
|
||||
puts "\naaaaa command: $command\n" |
||||
|
||||
set field [namespace tail [lindex $command 0]] |
||||
set map [lindex $stack 0] |
||||
set OID [lindex $map 0 0] |
||||
|
||||
|
||||
if {[llength $stack]} { |
||||
set refname ::p::${OID}::_ref::[join [concat $field [lrange $stack 1 end]] +] |
||||
set command [interp alias {} $refname {} {*}$command {*}$stack] |
||||
} else { |
||||
set refname ::p::${OID}::_ref::$field |
||||
set command [interp alias {} $refname {} {*}$command] |
||||
} |
||||
puts "???? command '$command' \n refname '$refname' \n" |
||||
|
||||
} else { |
||||
#Property or Method reference (possibly with curried indices or arguments) |
||||
|
||||
#we don't want our references to look like objects. |
||||
#(If they did, they might be found by namespace tidyup code and treated incorrectly) |
||||
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. |
||||
|
||||
|
||||
#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. |
||||
|
||||
|
||||
if {[llength $stack]} { |
||||
set refname ::p::${OID}::_ref::[join [concat $field $stack] +] |
||||
#puts stdout " ------------>>>> refname:$refname" |
||||
if {[string length $_ID_]} { |
||||
set command [interp alias {} $refname {} $command $_ID_ {*}$stack] |
||||
} else { |
||||
set command [interp alias {} $refname {} $command {*}$stack] |
||||
} |
||||
} else { |
||||
set refname ::p::${OID}::_ref::$field |
||||
#!review - for consistency.. we don't directly return method name. |
||||
if {[string length $_ID_]} { |
||||
set command [interp alias {} $refname {} $command $_ID_] |
||||
} else { |
||||
set command [interp alias {} $refname {} $command] |
||||
} |
||||
} |
||||
|
||||
|
||||
#puts ">>>!>>>> refname $refname \n" |
||||
|
||||
|
||||
#NOTE! - we always create a command alias even if $field is not a method. |
||||
#( |
||||
|
||||
#!todo? - build a list of properties from all interfaces (cache it on object??) |
||||
set iflist [lindex $map 1 0] |
||||
|
||||
|
||||
|
||||
|
||||
set found 0 |
||||
foreach IFID [lreverse $iflist] { |
||||
#if {$field in [dict keys [set ::p::${IFID}::_iface::o_methods]]} { |
||||
# set found 1 |
||||
# break |
||||
#} |
||||
if {[llength [info commands ::p::${IFID}::_iface::(GET)$field]] || [llength [info commands ::p::${IFID}::_iface::(SET)$field]]} { |
||||
set found 1 |
||||
break |
||||
} |
||||
} |
||||
|
||||
|
||||
if {$found} { |
||||
#property reference |
||||
|
||||
#? |
||||
#set readref [string map [list ::_ref:: ::_ref::(GET) |
||||
#set writeref [string map [list ::_ref:: ::_ref::(SET) |
||||
|
||||
#puts "-2222222222 $refname" |
||||
|
||||
#puts "---HERE! $OID $property ::p::${OID}::_ref::${property}" |
||||
#trace remove variable $refname {read write unset} [list ::p::internals::commandrefMisuse_TraceHandler $alias $field] |
||||
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 |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
#!todo - move to within trace info test below.. no need to test for refsync trace if no other trace? |
||||
#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::refsync_TraceHandler $OID $alias "" $field] |
||||
if { [::list {write unset} $Hndlr] ni [trace info variable ::p::${OID}::o_${field}]} { |
||||
trace add variable ::p::${OID}::o_${field} {write unset} $Hndlr |
||||
} |
||||
|
||||
set _ID_ [dict create i [dict create this [list [list $OID [list map $map] ]]]] |
||||
|
||||
#supply all data in easy-access form so that prop_trace_read is not doing any extra work. |
||||
set get_cmd ::p::${OID}::(GET)$field |
||||
set traceCmd [list ::p::predator::prop_trace_read $get_cmd $_ID_ $refname $field $stack] |
||||
|
||||
if {[list {read} $traceCmd] ni [trace info variable $refname]} { |
||||
|
||||
#synch the refvar with the real var if it exists |
||||
#catch {set $refname [$refname]} |
||||
if {[array exists ::p::${OID}::o_$field]} { |
||||
if {![llength $stack]} { |
||||
#unindexed reference |
||||
array set $refname [array get ::p::${OID}::o_$field] |
||||
} else { |
||||
#refs to nonexistant array members common? (catch vs 'info exists') |
||||
if {[info exists ::p::${OID}::o_${field}([lindex $stack 0])]} { |
||||
set $refname [set ::p::${OID}::o_${field}([lindex $stack 0])] |
||||
} |
||||
} |
||||
} else { |
||||
#catch means retrieving refs to non-initialised props slightly slower. |
||||
set errorInfo_prev $::errorInfo ;#preserve errorInfo across these catches! |
||||
|
||||
if {![llength $stack]} { |
||||
catch {set $refname [set ::p::${OID}::o_$field]} |
||||
} else { |
||||
if {[llength $stack] == 1} { |
||||
catch {set $refname [lindex [set ::p::${OID}::o_$field] [lindex $stack 0]]} |
||||
} else { |
||||
catch {set $refname [lindex [set ::p::${OID}::o_$field] $stack]} |
||||
} |
||||
} |
||||
|
||||
#! what if someone has put a trace on ::errorInfo?? |
||||
set ::errorInfo $errorInfo_prev |
||||
|
||||
} |
||||
|
||||
trace add variable $refname {read} $traceCmd |
||||
|
||||
set traceCmd [list ::p::predator::prop_trace_write $_ID_ $OID $alias $refname] |
||||
trace add variable $refname {write} $traceCmd |
||||
|
||||
set traceCmd [list ::p::predator::prop_trace_unset $_ID_ $OID $alias $refname] |
||||
trace add variable $refname {unset} $traceCmd |
||||
|
||||
set traceCmd [list ::p::predator::prop_trace_array $_ID_ $OID $alias $refname] |
||||
trace add variable $refname {array} $traceCmd |
||||
|
||||
} |
||||
|
||||
|
||||
} else { |
||||
#matching variable in order to detect attempted use as property and throw error |
||||
#puts "$refname ====> adding refMisuse_traceHandler $alias $field" |
||||
trace add variable $refname {read write unset} [list ::p::internals::commandrefMisuse_TraceHandler $alias $field] |
||||
} |
||||
} |
||||
|
||||
return $command |
||||
} |
||||
} |
||||
|
||||
|
||||
#script to inline at placeholder @reduce_pending_stack@ |
||||
set ::p::internals::reduce_pending_stack { |
||||
if {$pending eq {idx}} { |
||||
if {$OID ne {null}} { |
||||
#pattern object |
||||
#set command [list ::p::${OID}::$itemCmd [dict create i [dict create this [list $OID]]]] |
||||
set command ::p::${OID}::$itemCmd |
||||
set _ID_ [dict create i [dict create this [list [list $OID [list map $map]]]]] |
||||
#todo: set _ID_ [dict create i [dict create this [list [list $OID - - - {}]]] context {}] |
||||
|
||||
} else { |
||||
set command [list $itemCmd $command] |
||||
} |
||||
} |
||||
if {![llength [info commands [lindex $command 0]]]} { |
||||
set cmdname [namespace tail [lindex $command 0]] |
||||
if {[llength [info commands ::p::${OID}::(UNKNOWN)]]} { |
||||
lset command 0 ::p::${OID}::(UNKNOWN) |
||||
#puts stdout "!\n calling UNKNOWN $command $cmdname $stack\n\n" |
||||
|
||||
if {[string length $_ID_]} { |
||||
set interim [uplevel 1 [list {*}$command $_ID_ $cmdname {*}$stack]] ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||
} else { |
||||
set interim [uplevel 1 [list {*}$command $cmdname {*}$stack]] ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||
} |
||||
} else { |
||||
return -code error -errorinfo "1)error running command:'$command' argstack:'$stack'\n - command not found and no 'unknown' handler" "method '$command' not found" |
||||
} |
||||
} else { |
||||
#puts "---??? uplevelling $command $_ID_ $stack" |
||||
|
||||
if {[string length $_ID_]} { |
||||
set interim [uplevel 1 [list {*}$command $_ID_ {*}$stack]] |
||||
} else { |
||||
set interim [uplevel 1 [list {*}$command {*}$stack]] |
||||
} |
||||
#puts "---?2? interim:$interim" |
||||
} |
||||
|
||||
|
||||
|
||||
if {[string first ::> $interim] >= 0} { |
||||
#puts "--- ---> tailcalling $interim [lrange $args $i end]" |
||||
tailcall {*}$interim {*}[lrange $args $i end] ;#don't use a return statement as tailcall implies return |
||||
} else { |
||||
#the interim result is not a pattern object - but the . indicates we should treat it as a command |
||||
#tailcall ::p::internals::predator [list [list {null} {} {lindex} $interim {}]] {*}[lrange $args $i end] |
||||
#set nextmap [list [list {null} {} {lindex} $interim {}]] |
||||
#tailcall ::p::internals::predator [dict create i [dict create this [list null ]] map $nextmap] {*}[lrange $args $i end] |
||||
#tailcall ::p::internals::predator [dict create i [dict create this [list [list null [list]] ]] xmap $nextmap] {*}[lrange $args $i end] |
||||
|
||||
tailcall ::p::internals::predator [dict create i [dict create this [list [list null [list map [list [list {null} {} {lindex} $interim {}]]]] ]] callerinfo ""] {*}[lrange $args $i end] |
||||
|
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
proc ::p::predator1 {subject args} [string map [list @reduce_pending_stack@ $::p::internals::reduce_pending_stack] { |
||||
#set OID [lindex [dict get $subject i this] 0 0] |
||||
|
||||
set this_invocant [lindex [dict get $subject i this] 0] ;#for the role 'this' we assume only one invocant in the list. |
||||
lassign $this_invocant OID this_info |
||||
|
||||
if {$OID ne {null}} { |
||||
#upvar #0 ::p::${OID}::_meta::map map |
||||
#if {![dict exists [lindex [dict get $subject i this] 0 1] map]} { |
||||
# set map [set ::p::${OID}::_meta::map] |
||||
#} else { |
||||
# set map [dict get [lindex [dict get $subject i this] 0 1] map] |
||||
#} |
||||
#seems to be faster just to grab from the variable, than to unwrap from $_ID_ !? |
||||
#set map [set ::p::${OID}::_meta::map] |
||||
|
||||
|
||||
|
||||
# if {![dict exists $this_info map]} { |
||||
set map [set ::p::${OID}::_meta::map] |
||||
#} else { |
||||
# set map [dict get $this_info map] |
||||
#} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
lassign [lindex $map 0] OID alias itemCmd cmd |
||||
|
||||
set cheat 1 |
||||
#------- |
||||
#the common optimised case first. 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 {([llength $args] > 1) && ([lindex $args 0] eq {.}) && ([llength [lsearch -all $args .]] == 1) && ({,} ni $args) && ({..} ni $args) && ({--} ni $args)} { |
||||
set command ::p::${OID}::[lindex $args 1] |
||||
|
||||
if {![llength [info commands $command]]} { |
||||
if {[llength [info commands ::p::${OID}::(UNKNOWN)]]} { |
||||
set cmdname [namespace tail $command] |
||||
lset command 0 ::p::${OID}::(UNKNOWN) |
||||
#return [uplevel 1 [list {*}$command [dict create i [dict create this [list [list $OID [list map $map]]]]] $cmdname {*}[lrange $args 2 end]]] ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||
tailcall {*}$command [dict create i [dict create this [list [list $OID [list map [list [lindex $map 0] {{} {}} ] ] ]]]] $cmdname {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||
} else { |
||||
return -code error -errorinfo "2)error running command:'$command' argstack:'[lrange $args 2 end]'\n - command not found and no 'unknown' handler" "method '$command' not found" |
||||
} |
||||
} else { |
||||
#puts " -->> tailcalling $command [lrange $args 2 end]" |
||||
#tailcall $command [dict create i [dict create this [list [list $OID [list map $map]] ]]] {*}[lrange $args 2 end] |
||||
#tailcall $command [dict create i [dict create this [list [list $OID {}] ]]] {*}[lrange $args 2 end] |
||||
|
||||
#jjj |
||||
#tailcall $command [list i [list this [list [list $OID [list map $map]] ]]] {*}[lrange $args 2 end] |
||||
tailcall $command [list i [list this [list [list $OID [list map [list [lindex $map 0] { {} {} } ]]] ]]] {*}[lrange $args 2 end] |
||||
} |
||||
} |
||||
} |
||||
#------------ |
||||
|
||||
|
||||
if {![llength $args]} { |
||||
#return $map |
||||
return [lindex $map 0 1] |
||||
} elseif {[llength $args] == 1} { |
||||
#short-circuit the single index case for speed. |
||||
if {$args ni {.. . -- - & @}} { |
||||
if {$cheat} { |
||||
|
||||
lassign [lindex $map 0] OID alias itemCmd |
||||
#return [::p::${OID}::$itemCmd [lindex $args 0]] |
||||
#tailcall ::p::${OID}::$itemCmd [dict create i [dict create this [list [list $OID [list map $map]]]]] [lindex $args 0] |
||||
tailcall ::p::${OID}::$itemCmd [list i [list this [list [list $OID [list map $map]]]]] [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 $map |
||||
} |
||||
} |
||||
} else { |
||||
#null OID - assume map is included in the _ID_ dict. |
||||
#set map [dict get $subject map] |
||||
set map [dict get $this_info map] |
||||
|
||||
lassign [lindex $map 0] OID alias itemCmd cmd |
||||
} |
||||
#puts "predator==== subject:$subject args:$args map:$map cmd:$cmd " |
||||
|
||||
|
||||
|
||||
#set map $invocant ;#retain 'invocant' in case we need original caller info.. 'map' is the data for whatever is at base of stack. |
||||
set command $cmd |
||||
set stack [list] |
||||
|
||||
#set operators [list . , ..] ;#(exclude --) |
||||
|
||||
|
||||
#!todo? short-circuit/inline commonest/simplest case {llength $args == 2} |
||||
|
||||
|
||||
set argProtect 0 |
||||
set pending "" ;#pending operator e.g . , idx .. & @ |
||||
set _ID_ "" |
||||
|
||||
set i 0 |
||||
|
||||
while {$i < [llength $args]} { |
||||
set word [lindex $args $i] |
||||
|
||||
if {$argProtect} { |
||||
#argProtect must be checked first. |
||||
# We are here because a previous operator necessitates that this word is an argument, not another operator. |
||||
set argProtect 0 |
||||
lappend stack $word |
||||
if {$pending eq {}} { |
||||
set pending idx ;#An argument only implies the index operator if no existing operator is in effect. (because '>obj $arg' must be equivalent to '>obj . item $arg' |
||||
} |
||||
incr i |
||||
} else { |
||||
switch -- $word {.} { |
||||
#$i is the operator, $i + 1 is the command. |
||||
if {[llength $args] > ($i + 1)} { |
||||
#there is at least a command, possibly args too |
||||
|
||||
if {$pending ne {}} { |
||||
#puts ">>>> >>>>> about to reduce. pending:$pending command:$command _ID_:$_ID_ stack:$stack" |
||||
|
||||
|
||||
#always bounces back into the predator via tailcall |
||||
@reduce_pending_stack@ |
||||
} else { |
||||
if {$OID ne {null}} { |
||||
#set command ::p::${OID}::[lindex $args $i+1] |
||||
#lappend stack [dict create i [dict create this [list $OID]]] |
||||
|
||||
set command ::p::${OID}::[lindex $args $i+1] |
||||
set _ID_ [list i [list this [list [list $OID [list map $map]]]]] |
||||
|
||||
} else { |
||||
#set command [list $command [lindex $args $i+1]] |
||||
lappend stack [lindex $args $i+1] |
||||
} |
||||
set pending . |
||||
set argProtect 0 |
||||
incr i 2 |
||||
} |
||||
} else { |
||||
#this is a trailing . |
||||
#puts "----> MAP $map ,command $command ,stack $stack" |
||||
if {$OID ne {null}} { |
||||
return [::p::internals::trailing. $map $command $_ID_ $stack $i $args $pending] |
||||
} else { |
||||
#!todo - fix. This is broken! |
||||
#the usefulness of a reference to an already-resolved value is questionable.. but for consistency it should probably be made to work. |
||||
|
||||
#for a null object - we need to supply the map in the invocation data |
||||
set command ::p::internals::predator |
||||
|
||||
set this_info [dict create map [list [list {null} {} {lindex} $command {}]] ] |
||||
set this_invocant [list null $this_info] |
||||
|
||||
set _ID_ [dict create i [dict create this [list $this_invocant]] ] |
||||
|
||||
return [::p::internals::trailing. $map $command $_ID_ $stack $i $args $pending] |
||||
} |
||||
} |
||||
} {--} { |
||||
#argSafety operator (see also "," & -* below) |
||||
set argProtect 1 |
||||
incr i |
||||
} {,} { |
||||
set argProtect 1 |
||||
if {$i+1 < [llength $args]} { |
||||
#not trailing |
||||
if {$pending ne {}} { |
||||
@reduce_pending_stack@ |
||||
} else { |
||||
if {$OID ne {null}} { |
||||
#set command [list ::p::[lindex $map 0 0]::$itemCmd [lindex $args $i+1]] |
||||
#set command [list $command . $itemCmd [lindex $args $i+1]] |
||||
|
||||
set stack [list . $itemCmd [lindex $args $i+1]] |
||||
|
||||
set _ID_ "" |
||||
|
||||
#lappend stack [dict create i [dict create this [list $OID]]] |
||||
|
||||
set pending "." |
||||
} else { |
||||
# this is an index operation into what is presumed to be a previously returned standard tcl list. (as opposed to an index operation into a returned pattern object) |
||||
#set command [list $itemCmd $command [lindex $args $i+1]] |
||||
#set command [list ::p::internals::predator [list [list {null} {} {lindex} $command {}]] [lindex $args $i+1] ] |
||||
|
||||
|
||||
#set command ::p::internals::predator |
||||
#set _ID_ [dict create i [dict create this [list null]] map [list [list {null} {} {lindex} [lindex $args $i+1] {}]] ] |
||||
#lappend stack [lindex $args $i+1] |
||||
|
||||
|
||||
set command [list $itemCmd $command] ;#e.g {lindex {a b c}} |
||||
|
||||
#set command ::p::internals::predator |
||||
#set _ID_ [dict create i [dict create this [list null]] map [list [list {null} {} {lindex} $nextcommand {}]]] |
||||
set _ID_ {} |
||||
lappend stack [lindex $args $i+1] |
||||
|
||||
|
||||
set pending "." ;#*not* idx or "," |
||||
} |
||||
|
||||
set argProtect 0 |
||||
incr i 2 |
||||
} |
||||
} else { |
||||
return [::p::internals::trailing, $map $command $stack $i $args $pending] |
||||
} |
||||
} {..} { |
||||
#Metaface operator |
||||
if {$i+1 < [llength $args]} { |
||||
#operator is not trailing. |
||||
if {$pending ne {}} { |
||||
@reduce_pending_stack@ |
||||
} else { |
||||
incr i |
||||
|
||||
#set command [list ::p::-1::[lindex $args $i] [dict create i [dict create this [list $OID]]]] |
||||
set command ::p::-1::[lindex $args $i] |
||||
|
||||
#_ID_ is a list, 1st element being a dict of invocants. |
||||
# Each key of the dict is an invocant 'role' |
||||
# Each value is a list of invocant-aliases fulfilling that role |
||||
#lappend stack [list [list caller [lindex $map 0 1] ]] |
||||
#lappend stack [list [dict create this [lindex $map 0 1]]] ;#'this' being the 'subject' in a standard singledispatch method call. |
||||
#lappend stack [dict create i [dict create this [list [lindex $map 0 1]]]] |
||||
|
||||
set _ID_ [dict create i [dict create this [list [list $OID [list map $map]]]]] |
||||
|
||||
set pending .. |
||||
incr i |
||||
} |
||||
} else { |
||||
return [::p::internals::trailing.. $map $command $stack $i $args $pending] |
||||
} |
||||
} {&} { |
||||
#conglomeration operator |
||||
if {$i+1 < [llength $args]} { |
||||
if {$pending ne {} } { |
||||
@reduce_pending_stack@ |
||||
|
||||
#set interim [uplevel 1 [list {*}$command {*}$stack]] |
||||
#tailcall {*}$interim {*}[lrange $args $i end] ;#don't use a return statement as tailcall implies return |
||||
} |
||||
|
||||
set command [list ::p::-1::Conglomerate $command] |
||||
lappend stack [lindex $args $i+1] |
||||
set pending & |
||||
incr i |
||||
|
||||
|
||||
|
||||
} else { |
||||
error "trailing & not supported" |
||||
} |
||||
} {@} { |
||||
#named-invocant operator |
||||
if {$i+1 < [llength $args]} { |
||||
if {$pending ne {} } { |
||||
@reduce_pending_stack@ |
||||
} else { |
||||
error "@ not implemented" |
||||
|
||||
set pending @ |
||||
incr i |
||||
} |
||||
} else { |
||||
error "trailing @ not supported" |
||||
} |
||||
} default { |
||||
if {[string index $word 0] ni {. -}} { |
||||
lappend stack $word |
||||
if {$pending eq {}} { |
||||
set pending idx |
||||
} |
||||
incr i |
||||
} else { |
||||
if {[string match "-*" $word]} { |
||||
#argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument) |
||||
set argProtect 1 |
||||
lappend stack $word |
||||
incr i |
||||
} else { |
||||
if {([string index $word 0] eq ".") && ([string index $word end] eq ".") } { |
||||
#interface accessor! |
||||
error "interface casts not yet implemented!" |
||||
|
||||
set ifspec [string range $word 1 end] |
||||
if {$ifspec eq "!"} { |
||||
#create 'snapshot' reference with all current interfaces |
||||
|
||||
} else { |
||||
foreach ifname [split $ifspec ,] { |
||||
#make each comma-separated interface-name accessible via the 'casted object' |
||||
|
||||
} |
||||
} |
||||
|
||||
} else { |
||||
#has a leading . only. treat as an argument not an operator. |
||||
lappend stack $word |
||||
if {$pending eq {}} { |
||||
set pending idx |
||||
} |
||||
incr i |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
|
||||
} |
||||
} |
||||
|
||||
#assert: $pending ne "" |
||||
#(we've run out of args, and if no 'operators' were found, then $pending will have been set to 'idx' - equivalent to '. item' ) |
||||
|
||||
#puts "---> evalling command + stack:'$command' '$stack' (pending:'$pending')" |
||||
if {$pending in {idx}} { |
||||
if {$OID ne {null}} { |
||||
#pattern object |
||||
set command ::p::${OID}::$itemCmd |
||||
set _ID_ [dict create i [dict create this [list [list $OID [list map $map] ] ]]] |
||||
} else { |
||||
# some other kind of command |
||||
set command [list $itemCmd $command] |
||||
} |
||||
} |
||||
if {![llength [info commands [lindex $command 0]]]} { |
||||
set cmdname [namespace tail [lindex $command 0]] |
||||
if {[llength [info commands ::p::${OID}::(UNKNOWN)]]} { |
||||
lset command 0 ::p::${OID}::(UNKNOWN) |
||||
#puts stdout "!\n calling UNKNOWN $command $cmdname $stack\n\n" |
||||
|
||||
if {[string length $_ID_]} { |
||||
tailcall {*}$command $_ID_ $cmdname {*}$stack ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||
} else { |
||||
tailcall {*}$command $cmdname {*}$stack ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||
} |
||||
} else { |
||||
return -code error -errorinfo "3)error running command:'$command' argstack:'$stack'\n - command not found and no 'unknown' handler" "method '$command' not found" |
||||
} |
||||
} |
||||
#puts "... tailcalling $command $stack" |
||||
if {[string length $_ID_]} { |
||||
tailcall {*}$command $_ID_ {*}$stack |
||||
} else { |
||||
tailcall {*}$command {*}$stack |
||||
} |
||||
}] |
||||
@ -0,0 +1,664 @@
|
||||
package provide patternpredator1 1.2.4 |
||||
|
||||
proc ::p::internals::trailing, {map command stack i arglist pending} { |
||||
error "trailing ',' is not a valid sequence. If the comma was meant to be an argument, precede it with the -- operator." |
||||
} |
||||
proc ::p::internals::trailing.. {map command stack i arglist pending} { |
||||
error "trailing .. references not implemented." |
||||
} |
||||
|
||||
proc ::p::internals::trailing. {map command _ID_ stack i arglist pending} { |
||||
if {![llength $map]} { |
||||
error "Trailing . but no map - command:'$command' stack:$stack i:$i arglist:$arglist pending:$pending" |
||||
} |
||||
|
||||
|
||||
|
||||
#trailing dot - get reference. |
||||
#puts ">>trailing dot>> map:$map command:$command _ID_:$_ID_ stack:$stack i:$i arglist:$arglist pending:$pending" |
||||
lassign [lindex $map 0] OID alias itemCmd cmd |
||||
|
||||
|
||||
#lassign $command command _ID_ |
||||
|
||||
|
||||
if {$pending eq {}} { |
||||
#no pending operation requiring evaluation. |
||||
|
||||
#presumably we're getting a ref to the object, not a property or method. |
||||
#set traceCmd [::list ::p::objectRef_TraceHandler $cmd $_self $OID] |
||||
#if {[::list {array read write unset} $traceCmd] ni [trace info variable $refname]} { |
||||
# trace add variable $refname {array read write unset} $traceCmd |
||||
#} |
||||
set refname ::p::${OID}::_ref::__OBJECT ;#!todo - avoid potential collision with ref to member named '__OBJECT'. |
||||
#object ref - ensure trace-var is an array upon which the objects methods & properties can be accessed as indices |
||||
array set $refname [list] |
||||
#!todo?- populate array with object methods/properties now? |
||||
|
||||
|
||||
set _ID_ [list i [list this [list [list $OID [list map $map]]]]] |
||||
|
||||
#!todo - review. What if $map is out of date? |
||||
|
||||
set traceCmd [list ::p::predator::object_read_trace $OID $_ID_] |
||||
if {[list {read} $traceCmd] ni [trace info variable $refname]} { |
||||
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 |
||||
} |
||||
|
||||
|
||||
#set command $refname |
||||
return $refname |
||||
} else { |
||||
#puts "- 11111111 '$command' '$stack'" |
||||
|
||||
if {[string range $command 0 171] eq "::p::-1::"} { |
||||
#!todo - review/enable this branch? |
||||
|
||||
#reference to meta-member |
||||
|
||||
#STALE map problem!! |
||||
|
||||
puts "\naaaaa command: $command\n" |
||||
|
||||
set field [namespace tail [lindex $command 0]] |
||||
set map [lindex $stack 0] |
||||
set OID [lindex $map 0 0] |
||||
|
||||
|
||||
if {[llength $stack]} { |
||||
set refname ::p::${OID}::_ref::[join [concat $field [lrange $stack 1 end]] +] |
||||
set command [interp alias {} $refname {} {*}$command {*}$stack] |
||||
} else { |
||||
set refname ::p::${OID}::_ref::$field |
||||
set command [interp alias {} $refname {} {*}$command] |
||||
} |
||||
puts "???? command '$command' \n refname '$refname' \n" |
||||
|
||||
} else { |
||||
#Property or Method reference (possibly with curried indices or arguments) |
||||
|
||||
#we don't want our references to look like objects. |
||||
#(If they did, they might be found by namespace tidyup code and treated incorrectly) |
||||
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. |
||||
|
||||
|
||||
#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. |
||||
|
||||
|
||||
if {[llength $stack]} { |
||||
set refname ::p::${OID}::_ref::[join [concat $field $stack] +] |
||||
#puts stdout " ------------>>>> refname:$refname" |
||||
if {[string length $_ID_]} { |
||||
set command [interp alias {} $refname {} $command $_ID_ {*}$stack] |
||||
} else { |
||||
set command [interp alias {} $refname {} $command {*}$stack] |
||||
} |
||||
} else { |
||||
set refname ::p::${OID}::_ref::$field |
||||
#!review - for consistency.. we don't directly return method name. |
||||
if {[string length $_ID_]} { |
||||
set command [interp alias {} $refname {} $command $_ID_] |
||||
} else { |
||||
set command [interp alias {} $refname {} $command] |
||||
} |
||||
} |
||||
|
||||
|
||||
#puts ">>>!>>>> refname $refname \n" |
||||
|
||||
|
||||
#NOTE! - we always create a command alias even if $field is not a method. |
||||
#( |
||||
|
||||
#!todo? - build a list of properties from all interfaces (cache it on object??) |
||||
set iflist [lindex $map 1 0] |
||||
|
||||
|
||||
|
||||
|
||||
set found 0 |
||||
foreach IFID [lreverse $iflist] { |
||||
#if {$field in [dict keys [set ::p::${IFID}::_iface::o_methods]]} { |
||||
# set found 1 |
||||
# break |
||||
#} |
||||
if {[llength [info commands ::p::${IFID}::_iface::(GET)$field]] || [llength [info commands ::p::${IFID}::_iface::(SET)$field]]} { |
||||
set found 1 |
||||
break |
||||
} |
||||
} |
||||
|
||||
|
||||
if {$found} { |
||||
#property reference |
||||
|
||||
#? |
||||
#set readref [string map [list ::_ref:: ::_ref::(GET) |
||||
#set writeref [string map [list ::_ref:: ::_ref::(SET) |
||||
|
||||
#puts "-2222222222 $refname" |
||||
|
||||
#puts "---HERE! $OID $property ::p::${OID}::_ref::${property}" |
||||
#trace remove variable $refname {read write unset} [list ::p::internals::commandrefMisuse_TraceHandler $alias $field] |
||||
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 |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
#!todo - move to within trace info test below.. no need to test for refsync trace if no other trace? |
||||
#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::refsync_TraceHandler $OID $alias "" $field] |
||||
if { [::list {write unset} $Hndlr] ni [trace info variable ::p::${OID}::o_${field}]} { |
||||
trace add variable ::p::${OID}::o_${field} {write unset} $Hndlr |
||||
} |
||||
|
||||
set _ID_ [dict create i [dict create this [list [list $OID [list map $map] ]]]] |
||||
|
||||
#supply all data in easy-access form so that prop_trace_read is not doing any extra work. |
||||
set get_cmd ::p::${OID}::(GET)$field |
||||
set traceCmd [list ::p::predator::prop_trace_read $get_cmd $_ID_ $refname $field $stack] |
||||
|
||||
if {[list {read} $traceCmd] ni [trace info variable $refname]} { |
||||
|
||||
#synch the refvar with the real var if it exists |
||||
#catch {set $refname [$refname]} |
||||
if {[array exists ::p::${OID}::o_$field]} { |
||||
if {![llength $stack]} { |
||||
#unindexed reference |
||||
array set $refname [array get ::p::${OID}::o_$field] |
||||
} else { |
||||
#refs to nonexistant array members common? (catch vs 'info exists') |
||||
if {[info exists ::p::${OID}::o_${field}([lindex $stack 0])]} { |
||||
set $refname [set ::p::${OID}::o_${field}([lindex $stack 0])] |
||||
} |
||||
} |
||||
} else { |
||||
#catch means retrieving refs to non-initialised props slightly slower. |
||||
set errorInfo_prev $::errorInfo ;#preserve errorInfo across these catches! |
||||
|
||||
if {![llength $stack]} { |
||||
catch {set $refname [set ::p::${OID}::o_$field]} |
||||
} else { |
||||
if {[llength $stack] == 1} { |
||||
catch {set $refname [lindex [set ::p::${OID}::o_$field] [lindex $stack 0]]} |
||||
} else { |
||||
catch {set $refname [lindex [set ::p::${OID}::o_$field] $stack]} |
||||
} |
||||
} |
||||
|
||||
#! what if someone has put a trace on ::errorInfo?? |
||||
set ::errorInfo $errorInfo_prev |
||||
|
||||
} |
||||
|
||||
trace add variable $refname {read} $traceCmd |
||||
|
||||
set traceCmd [list ::p::predator::prop_trace_write $_ID_ $OID $alias $refname] |
||||
trace add variable $refname {write} $traceCmd |
||||
|
||||
set traceCmd [list ::p::predator::prop_trace_unset $_ID_ $OID $alias $refname] |
||||
trace add variable $refname {unset} $traceCmd |
||||
|
||||
set traceCmd [list ::p::predator::prop_trace_array $_ID_ $OID $alias $refname] |
||||
trace add variable $refname {array} $traceCmd |
||||
|
||||
} |
||||
|
||||
|
||||
} else { |
||||
#matching variable in order to detect attempted use as property and throw error |
||||
#puts "$refname ====> adding refMisuse_traceHandler $alias $field" |
||||
trace add variable $refname {read write unset} [list ::p::internals::commandrefMisuse_TraceHandler $alias $field] |
||||
} |
||||
} |
||||
|
||||
return $command |
||||
} |
||||
} |
||||
|
||||
|
||||
#script to inline at placeholder @reduce_pending_stack@ |
||||
set ::p::internals::reduce_pending_stack { |
||||
if {$pending eq {idx}} { |
||||
if {$OID ne {null}} { |
||||
#pattern object |
||||
#set command [list ::p::${OID}::$itemCmd [dict create i [dict create this [list $OID]]]] |
||||
set command ::p::${OID}::$itemCmd |
||||
set _ID_ [dict create i [dict create this [list [list $OID [list map $map]]]]] |
||||
#todo: set _ID_ [dict create i [dict create this [list [list $OID - - - {}]]] context {}] |
||||
|
||||
} else { |
||||
set command [list $itemCmd $command] |
||||
} |
||||
} |
||||
if {![llength [info commands [lindex $command 0]]]} { |
||||
set cmdname [namespace tail [lindex $command 0]] |
||||
if {[llength [info commands ::p::${OID}::(UNKNOWN)]]} { |
||||
lset command 0 ::p::${OID}::(UNKNOWN) |
||||
#puts stdout "!\n calling UNKNOWN $command $cmdname $stack\n\n" |
||||
|
||||
if {[string length $_ID_]} { |
||||
set interim [uplevel 1 [list {*}$command $_ID_ $cmdname {*}$stack]] ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||
} else { |
||||
set interim [uplevel 1 [list {*}$command $cmdname {*}$stack]] ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||
} |
||||
} else { |
||||
return -code error -errorinfo "1)error running command:'$command' argstack:'$stack'\n - command not found and no 'unknown' handler" "method '$command' not found" |
||||
} |
||||
} else { |
||||
#puts "---??? uplevelling $command $_ID_ $stack" |
||||
|
||||
if {[string length $_ID_]} { |
||||
set interim [uplevel 1 [list {*}$command $_ID_ {*}$stack]] |
||||
} else { |
||||
set interim [uplevel 1 [list {*}$command {*}$stack]] |
||||
} |
||||
#puts "---?2? interim:$interim" |
||||
} |
||||
|
||||
|
||||
|
||||
if {[string first ::> $interim] >= 0} { |
||||
#puts "--- ---> tailcalling $interim [lrange $args $i end]" |
||||
tailcall {*}$interim {*}[lrange $args $i end] ;#don't use a return statement as tailcall implies return |
||||
} else { |
||||
#the interim result is not a pattern object - but the . indicates we should treat it as a command |
||||
#tailcall ::p::internals::predator [list [list {null} {} {lindex} $interim {}]] {*}[lrange $args $i end] |
||||
#set nextmap [list [list {null} {} {lindex} $interim {}]] |
||||
#tailcall ::p::internals::predator [dict create i [dict create this [list null ]] map $nextmap] {*}[lrange $args $i end] |
||||
#tailcall ::p::internals::predator [dict create i [dict create this [list [list null [list]] ]] xmap $nextmap] {*}[lrange $args $i end] |
||||
|
||||
tailcall ::p::internals::predator [dict create i [dict create this [list [list null [list map [list [list {null} {} {lindex} $interim {}]]]] ]] callerinfo ""] {*}[lrange $args $i end] |
||||
|
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
proc ::p::predator1 {subject args} [string map [list @reduce_pending_stack@ $::p::internals::reduce_pending_stack] { |
||||
#set OID [lindex [dict get $subject i this] 0 0] |
||||
|
||||
set this_invocant [lindex [dict get $subject i this] 0] ;#for the role 'this' we assume only one invocant in the list. |
||||
lassign $this_invocant OID this_info |
||||
|
||||
if {$OID ne {null}} { |
||||
#upvar #0 ::p::${OID}::_meta::map map |
||||
#if {![dict exists [lindex [dict get $subject i this] 0 1] map]} { |
||||
# set map [set ::p::${OID}::_meta::map] |
||||
#} else { |
||||
# set map [dict get [lindex [dict get $subject i this] 0 1] map] |
||||
#} |
||||
#seems to be faster just to grab from the variable, than to unwrap from $_ID_ !? |
||||
#set map [set ::p::${OID}::_meta::map] |
||||
|
||||
|
||||
|
||||
# if {![dict exists $this_info map]} { |
||||
set map [set ::p::${OID}::_meta::map] |
||||
#} else { |
||||
# set map [dict get $this_info map] |
||||
#} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
lassign [lindex $map 0] OID alias itemCmd cmd |
||||
|
||||
set cheat 1 |
||||
#------- |
||||
#the common optimised case first. 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 {([llength $args] > 1) && ([lindex $args 0] eq {.}) && ([llength [lsearch -all $args .]] == 1) && ({,} ni $args) && ({..} ni $args) && ({--} ni $args)} { |
||||
set command ::p::${OID}::[lindex $args 1] |
||||
|
||||
if {![llength [info commands $command]]} { |
||||
if {[llength [info commands ::p::${OID}::(UNKNOWN)]]} { |
||||
set cmdname [namespace tail $command] |
||||
lset command 0 ::p::${OID}::(UNKNOWN) |
||||
#return [uplevel 1 [list {*}$command [dict create i [dict create this [list [list $OID [list map $map]]]]] $cmdname {*}[lrange $args 2 end]]] ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||
tailcall {*}$command [dict create i [dict create this [list [list $OID [list map [list [lindex $map 0] {{} {}} ] ] ]]]] $cmdname {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||
} else { |
||||
return -code error -errorinfo "2)error running command:'$command' argstack:'[lrange $args 2 end]'\n - command not found and no 'unknown' handler" "method '$command' not found" |
||||
} |
||||
} else { |
||||
#puts " -->> tailcalling $command [lrange $args 2 end]" |
||||
#tailcall $command [dict create i [dict create this [list [list $OID [list map $map]] ]]] {*}[lrange $args 2 end] |
||||
#tailcall $command [dict create i [dict create this [list [list $OID {}] ]]] {*}[lrange $args 2 end] |
||||
|
||||
#jjj |
||||
#tailcall $command [list i [list this [list [list $OID [list map $map]] ]]] {*}[lrange $args 2 end] |
||||
tailcall $command [list i [list this [list [list $OID [list map [list [lindex $map 0] { {} {} } ]]] ]]] {*}[lrange $args 2 end] |
||||
} |
||||
} |
||||
} |
||||
#------------ |
||||
|
||||
|
||||
if {![llength $args]} { |
||||
#return $map |
||||
return [lindex $map 0 1] |
||||
} elseif {[llength $args] == 1} { |
||||
#short-circuit the single index case for speed. |
||||
if {$args ni {.. . -- - & @}} { |
||||
if {$cheat} { |
||||
|
||||
lassign [lindex $map 0] OID alias itemCmd |
||||
#return [::p::${OID}::$itemCmd [lindex $args 0]] |
||||
#tailcall ::p::${OID}::$itemCmd [dict create i [dict create this [list [list $OID [list map $map]]]]] [lindex $args 0] |
||||
tailcall ::p::${OID}::$itemCmd [list i [list this [list [list $OID [list map $map]]]]] [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 $map |
||||
} |
||||
} |
||||
} else { |
||||
#null OID - assume map is included in the _ID_ dict. |
||||
#set map [dict get $subject map] |
||||
set map [dict get $this_info map] |
||||
|
||||
lassign [lindex $map 0] OID alias itemCmd cmd |
||||
} |
||||
#puts "predator==== subject:$subject args:$args map:$map cmd:$cmd " |
||||
|
||||
|
||||
|
||||
#set map $invocant ;#retain 'invocant' in case we need original caller info.. 'map' is the data for whatever is at base of stack. |
||||
set command $cmd |
||||
set stack [list] |
||||
|
||||
#set operators [list . , ..] ;#(exclude --) |
||||
|
||||
|
||||
#!todo? short-circuit/inline commonest/simplest case {llength $args == 2} |
||||
|
||||
|
||||
set argProtect 0 |
||||
set pending "" ;#pending operator e.g . , idx .. & @ |
||||
set _ID_ "" |
||||
|
||||
set i 0 |
||||
|
||||
while {$i < [llength $args]} { |
||||
set word [lindex $args $i] |
||||
|
||||
if {$argProtect} { |
||||
#argProtect must be checked first. |
||||
# We are here because a previous operator necessitates that this word is an argument, not another operator. |
||||
set argProtect 0 |
||||
lappend stack $word |
||||
if {$pending eq {}} { |
||||
set pending idx ;#An argument only implies the index operator if no existing operator is in effect. (because '>obj $arg' must be equivalent to '>obj . item $arg' |
||||
} |
||||
incr i |
||||
} else { |
||||
switch -- $word {.} { |
||||
#$i is the operator, $i + 1 is the command. |
||||
if {[llength $args] > ($i + 1)} { |
||||
#there is at least a command, possibly args too |
||||
|
||||
if {$pending ne {}} { |
||||
#puts ">>>> >>>>> about to reduce. pending:$pending command:$command _ID_:$_ID_ stack:$stack" |
||||
|
||||
|
||||
#always bounces back into the predator via tailcall |
||||
@reduce_pending_stack@ |
||||
} else { |
||||
if {$OID ne {null}} { |
||||
#set command ::p::${OID}::[lindex $args $i+1] |
||||
#lappend stack [dict create i [dict create this [list $OID]]] |
||||
|
||||
set command ::p::${OID}::[lindex $args $i+1] |
||||
set _ID_ [list i [list this [list [list $OID [list map $map]]]]] |
||||
|
||||
} else { |
||||
#set command [list $command [lindex $args $i+1]] |
||||
lappend stack [lindex $args $i+1] |
||||
} |
||||
set pending . |
||||
set argProtect 0 |
||||
incr i 2 |
||||
} |
||||
} else { |
||||
#this is a trailing . |
||||
#puts "----> MAP $map ,command $command ,stack $stack" |
||||
if {$OID ne {null}} { |
||||
return [::p::internals::trailing. $map $command $_ID_ $stack $i $args $pending] |
||||
} else { |
||||
#!todo - fix. This is broken! |
||||
#the usefulness of a reference to an already-resolved value is questionable.. but for consistency it should probably be made to work. |
||||
|
||||
#for a null object - we need to supply the map in the invocation data |
||||
set command ::p::internals::predator |
||||
|
||||
set this_info [dict create map [list [list {null} {} {lindex} $command {}]] ] |
||||
set this_invocant [list null $this_info] |
||||
|
||||
set _ID_ [dict create i [dict create this [list $this_invocant]] ] |
||||
|
||||
return [::p::internals::trailing. $map $command $_ID_ $stack $i $args $pending] |
||||
} |
||||
} |
||||
} {--} { |
||||
#argSafety operator (see also "," & -* below) |
||||
set argProtect 1 |
||||
incr i |
||||
} {,} { |
||||
set argProtect 1 |
||||
if {$i+1 < [llength $args]} { |
||||
#not trailing |
||||
if {$pending ne {}} { |
||||
@reduce_pending_stack@ |
||||
} else { |
||||
if {$OID ne {null}} { |
||||
#set command [list ::p::[lindex $map 0 0]::$itemCmd [lindex $args $i+1]] |
||||
#set command [list $command . $itemCmd [lindex $args $i+1]] |
||||
|
||||
set stack [list . $itemCmd [lindex $args $i+1]] |
||||
|
||||
set _ID_ "" |
||||
|
||||
#lappend stack [dict create i [dict create this [list $OID]]] |
||||
|
||||
set pending "." |
||||
} else { |
||||
# this is an index operation into what is presumed to be a previously returned standard tcl list. (as opposed to an index operation into a returned pattern object) |
||||
#set command [list $itemCmd $command [lindex $args $i+1]] |
||||
#set command [list ::p::internals::predator [list [list {null} {} {lindex} $command {}]] [lindex $args $i+1] ] |
||||
|
||||
|
||||
#set command ::p::internals::predator |
||||
#set _ID_ [dict create i [dict create this [list null]] map [list [list {null} {} {lindex} [lindex $args $i+1] {}]] ] |
||||
#lappend stack [lindex $args $i+1] |
||||
|
||||
|
||||
set command [list $itemCmd $command] ;#e.g {lindex {a b c}} |
||||
|
||||
#set command ::p::internals::predator |
||||
#set _ID_ [dict create i [dict create this [list null]] map [list [list {null} {} {lindex} $nextcommand {}]]] |
||||
set _ID_ {} |
||||
lappend stack [lindex $args $i+1] |
||||
|
||||
|
||||
set pending "." ;#*not* idx or "," |
||||
} |
||||
|
||||
set argProtect 0 |
||||
incr i 2 |
||||
} |
||||
} else { |
||||
return [::p::internals::trailing, $map $command $stack $i $args $pending] |
||||
} |
||||
} {..} { |
||||
#Metaface operator |
||||
if {$i+1 < [llength $args]} { |
||||
#operator is not trailing. |
||||
if {$pending ne {}} { |
||||
@reduce_pending_stack@ |
||||
} else { |
||||
incr i |
||||
|
||||
#set command [list ::p::-1::[lindex $args $i] [dict create i [dict create this [list $OID]]]] |
||||
set command ::p::-1::[lindex $args $i] |
||||
|
||||
#_ID_ is a list, 1st element being a dict of invocants. |
||||
# Each key of the dict is an invocant 'role' |
||||
# Each value is a list of invocant-aliases fulfilling that role |
||||
#lappend stack [list [list caller [lindex $map 0 1] ]] |
||||
#lappend stack [list [dict create this [lindex $map 0 1]]] ;#'this' being the 'subject' in a standard singledispatch method call. |
||||
#lappend stack [dict create i [dict create this [list [lindex $map 0 1]]]] |
||||
|
||||
set _ID_ [dict create i [dict create this [list [list $OID [list map $map]]]]] |
||||
|
||||
set pending .. |
||||
incr i |
||||
} |
||||
} else { |
||||
return [::p::internals::trailing.. $map $command $stack $i $args $pending] |
||||
} |
||||
} {&} { |
||||
#conglomeration operator |
||||
if {$i+1 < [llength $args]} { |
||||
if {$pending ne {} } { |
||||
@reduce_pending_stack@ |
||||
|
||||
#set interim [uplevel 1 [list {*}$command {*}$stack]] |
||||
#tailcall {*}$interim {*}[lrange $args $i end] ;#don't use a return statement as tailcall implies return |
||||
} |
||||
|
||||
set command [list ::p::-1::Conglomerate $command] |
||||
lappend stack [lindex $args $i+1] |
||||
set pending & |
||||
incr i |
||||
|
||||
|
||||
|
||||
} else { |
||||
error "trailing & not supported" |
||||
} |
||||
} {@} { |
||||
#named-invocant operator |
||||
if {$i+1 < [llength $args]} { |
||||
if {$pending ne {} } { |
||||
@reduce_pending_stack@ |
||||
} else { |
||||
error "@ not implemented" |
||||
|
||||
set pending @ |
||||
incr i |
||||
} |
||||
} else { |
||||
error "trailing @ not supported" |
||||
} |
||||
} default { |
||||
if {[string index $word 0] ni {. -}} { |
||||
lappend stack $word |
||||
if {$pending eq {}} { |
||||
set pending idx |
||||
} |
||||
incr i |
||||
} else { |
||||
if {[string match "-*" $word]} { |
||||
#argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument) |
||||
set argProtect 1 |
||||
lappend stack $word |
||||
incr i |
||||
} else { |
||||
if {([string index $word 0] eq ".") && ([string index $word end] eq ".") } { |
||||
#interface accessor! |
||||
error "interface casts not yet implemented!" |
||||
|
||||
set ifspec [string range $word 1 end] |
||||
if {$ifspec eq "!"} { |
||||
#create 'snapshot' reference with all current interfaces |
||||
|
||||
} else { |
||||
foreach ifname [split $ifspec ,] { |
||||
#make each comma-separated interface-name accessible via the 'casted object' |
||||
|
||||
} |
||||
} |
||||
|
||||
} else { |
||||
#has a leading . only. treat as an argument not an operator. |
||||
lappend stack $word |
||||
if {$pending eq {}} { |
||||
set pending idx |
||||
} |
||||
incr i |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
|
||||
} |
||||
} |
||||
|
||||
#assert: $pending ne "" |
||||
#(we've run out of args, and if no 'operators' were found, then $pending will have been set to 'idx' - equivalent to '. item' ) |
||||
|
||||
#puts "---> evalling command + stack:'$command' '$stack' (pending:'$pending')" |
||||
if {$pending in {idx}} { |
||||
if {$OID ne {null}} { |
||||
#pattern object |
||||
set command ::p::${OID}::$itemCmd |
||||
set _ID_ [dict create i [dict create this [list [list $OID [list map $map] ] ]]] |
||||
} else { |
||||
# some other kind of command |
||||
set command [list $itemCmd $command] |
||||
} |
||||
} |
||||
if {![llength [info commands [lindex $command 0]]]} { |
||||
set cmdname [namespace tail [lindex $command 0]] |
||||
if {[llength [info commands ::p::${OID}::(UNKNOWN)]]} { |
||||
lset command 0 ::p::${OID}::(UNKNOWN) |
||||
#puts stdout "!\n calling UNKNOWN $command $cmdname $stack\n\n" |
||||
|
||||
if {[string length $_ID_]} { |
||||
tailcall {*}$command $_ID_ $cmdname {*}$stack ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||
} else { |
||||
tailcall {*}$command $cmdname {*}$stack ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||
} |
||||
} else { |
||||
return -code error -errorinfo "3)error running command:'$command' argstack:'$stack'\n - command not found and no 'unknown' handler" "method '$command' not found" |
||||
} |
||||
} |
||||
#puts "... tailcalling $command $stack" |
||||
if {[string length $_ID_]} { |
||||
tailcall {*}$command $_ID_ {*}$stack |
||||
} else { |
||||
tailcall {*}$command {*}$stack |
||||
} |
||||
}] |
||||
Binary file not shown.
Loading…
Reference in new issue