58 changed files with 15803 additions and 8236 deletions
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
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 |
||||
} |
||||
}] |
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
Binary file not shown.
Loading…
Reference in new issue