diff --git a/src/vendormodules/include_modules.config b/src/vendormodules/include_modules.config index f9303a39..fc738609 100644 --- a/src/vendormodules/include_modules.config +++ b/src/vendormodules/include_modules.config @@ -19,7 +19,10 @@ set local_modules [list\ c:/repo/jn/tclmodules/pattern/modules patternlib\ c:/repo/jn/tclmodules/pattern/modules patterncipher\ c:/repo/jn/tclmodules/pattern/modules metaface\ + c:/repo/jn/tclmodules/pattern/modules patternpredator1\ c:/repo/jn/tclmodules/pattern/modules patternpredator2\ + c:/repo/jn/tclmodules/pattern/modules patterndispatcher\ + c:/repo/jn/tclmodules/pattern/modules treeobj\ c:/repo/jn/tarjar/modules tarjar\ ] diff --git a/src/vendormodules/patterndispatcher-1.2.4.tm b/src/vendormodules/patterndispatcher-1.2.4.tm new file mode 100644 index 00000000..14194aee --- /dev/null +++ b/src/vendormodules/patterndispatcher-1.2.4.tm @@ -0,0 +1,1940 @@ +package provide patterndispatcher 1.2.4 + + + +namespace eval pp { + variable operators [list .. . -- - & @ # ## > >> , ! =] + variable no_operators_in_args "" + foreach op $operators { + append no_operators_in_args "({$op} ni \$args) && " + } + variable system_varspaces [list main _apimanager _ref _meta _dispatcher _iface] + variable private_apis [list PatternBuilder PatternInternal varspace_main varspace_ref varspace_meta varspace_apimanager varspace_iface] + + set no_operators_in_args [string trimright $no_operators_in_args " &"] ;#trim trailing spaces and ampersands + #set no_operators_in_args {({.} ni $args) && ({,} ni $args) && ({..} ni $args)} +} + +package require TclOO + + + + + + + + + +oo::class create ::pp::namespacedcreate { + #to use as a mixin +} +oo::define ::pp::namespacedcreate method create {obj varspace _InvocantData_} { + #set OID [lindex [dict get $_InvocantData_ i this] 0 0] + set OID [dict get [lindex [dict get $_InvocantData_ i this] 0] id] + if {$varspace eq ""} { + #The main varspace ($varspace empty string) is a special case - as it's the parent of all the others + set ns ::pp::Obj${OID} + return [uplevel 1 [list [self] createWithNamespace $obj $ns "" $_InvocantData_]] + } else { + set parentns ::pp::Obj${OID} + if {![namespace exists $parentns]} { + error "Cannot create varspace. Dispatcher object with id:'$OID' needs to be created first" + } + if {[namespace exists ${parentns}::$varspace]} { + error "Cannot create varspace $varspace. Varspace at ${parentns}::$varspace already exists" + } + puts stderr "about to call createWithNamespace ns:${parentns}::$varspace" + return [uplevel 1 [list [self] createWithNamespace $obj ${parentns}::$varspace $varspace $_InvocantData_]] + } +} + + + + +#common varspace mixin +oo::class create ::pp::Ivarspaces + +oo::define ::pp::Ivarspaces method ID {} { + puts "generic varspaces method ID" + my variable o_OID + return $o_OID +} +oo::define ::pp::Ivarspaces method vars {} { + return [info object vars [self]] +} +oo::define ::pp::Ivarspaces method (GET)name {} { + my variable o_name + return $o_name +} +oo::define ::pp::Ivarspaces method get_refs {} { + return "not yet implemented - get_refs ns:[namespace current]" +} +#temporary violater +oo::define ::pp::Ivarspaces method do {script} { + #vars must be brought into scope with my in order for vars to be automatically visible from descendants + set script "my variable {*}[info object vars [self]];\n $script" + eval $script +} +oo::define ::pp::Ivarspaces export (GET)name ID + + +#A varspace instance is the namespace in which all the interface code actually runs (usually via mixins) +oo::class create ::pp::varspace { + superclass oo::class + variable o_OID o_name +} +oo::objdefine ::pp::varspace { + #export createWithNamespace + #mixin ::pp::namespacedcreate +} +oo::define ::pp::varspace constructor {varspace _InvocantData_} { + puts stderr "varspace constructor for varspace:'$varspace' _InvocantData_:'$_InvocantData_' ns:[namespace current]" + set invocant_list [dict get $_InvocantData_ i this] + set invocantD [lindex $invocant_list 0] + set o_OID [dict get $invocantD id] + #set o_OID [lindex $INVOCANTRECORD 0] + + set o_name $varspace + + set mymethods [info object methods [self] -private -all] + set api_methods [lsearch -all -inline $mymethods "API(*"] + puts stdout "varspace constructor [self] : directly defined api_methods: $api_methods" + if {[llength $api_methods]} { + oo::objdefine [self] export {*}$api_methods + } + + + +} +oo::define ::pp::varspace method unknown {args} { + #puts stderr "varspace 'unknown method handler' args:'$args' self: [self]" + if {[info frame] <=2} { + #called from outside + next {*}$args ;#unknown method on root object: oo::object + #nextto oo::object {*}$args + #error "unsupported call" + } + + + set simple_methodname [lindex $args 0] ;#the unknown method which was attempted + if {[string range $simple_methodname 0 3] eq {API(}} { + #The caller is already trying to call via an API(somename) prefixed method + #todo - pass to corresponding API(somename)unknown method if exists? + next {*}$args + } else { + set levelinfo [info level -1] + #puts stderr "self:[self] info level -1 $levelinfo" + + set context_args [lassign $levelinfo object context_methodname] ;#the method and args of the context from which the unknown invocation has occurred. + + + if {[set posn_endprefix [string first {)} $context_methodname]]} { + set prefix_api_name [string range $context_methodname 4 $posn_endprefix-1] ;#get the bracketed string within API(somename)something + tailcall $object "API($prefix_api_name)$simple_methodname" {*}[lrange $args 1 end] + } else { + next {*}$args + } + } +} + +oo::define ::pp::varspace method API(PatternInternal)get_dispatcher {{apiname default}} { + if {$apiname eq "default"} { + set apiname [set ::pp::Obj${o_OID}::_meta::o_interface_default_api] + } + + set dispatcher [set ::pp::Obj${o_OID}::_dispatcher::${apiname}::o_dispatcher_object_command] + + return $dispatcher +} + +oo::define ::pp::varspace method API(PatternInternal)add_mixin_for_api {apiname tcloo_mixin_class} { + set apiobj [pp::Obj${o_OID}::_apimanager get_api $apiname] + + if {![llength [uplevel #0 [list info commands $tcloo_mixin_class]]]} { + puts stderr "tcloo_mixin_class: $tcloo_mixin_class '[info commands $tcloo_mixin_class]'" + package require $tcloo_mixin_class ;# e.g pattern::IPatternBuilder + } + + set plain_method_names [info class methods $tcloo_mixin_class -private] ;#We want to export everything, capitalized or not. (-private returns all user-defined methods) + puts stderr "add_mixin_for_api $apiname $tcloo_mixin_class plain_method_names:'$plain_method_names'" + #we need a copy of the mixin_class in order to rename all methods to be prefixed with the apiname + #on the api object, the plain method names are forwarded to the renamed methods which are mixed in on the varspace object which is the actual execution context. + + if {![llength [info commands ${tcloo_mixin_class}_$apiname]]} { + oo::copy $tcloo_mixin_class ${tcloo_mixin_class}_$apiname ;#suffix with name of api we intend to apply it to + oo::objdefine ${tcloo_mixin_class}_$apiname export {*}$plain_method_names ;#note that renamed methods remain exported + foreach m $plain_method_names { + oo::define ${tcloo_mixin_class}_$apiname renamemethod $m API($apiname)$m + } + } + + #self e.g ::pp::Obj${o_OID}_meta + oo::objdefine [self] [list mixin -append ${tcloo_mixin_class}_$apiname] + set public_method_names [list] + set added_methods [list] + set added_properties [list] + foreach m $plain_method_names { + if {[string range $m 0 4] eq "(GET)"} { + set propname [string range $m 5 end] + oo::objdefine $apiobj forward $propname [self] API($apiname)$m + if {$propname ni $public_method_names} { + lappend public_method_names $propname ;#getter also available as a method + } + if {$propname ni $added_methods} { + lappend added_methods $propname + } + if {$propname ni $added_properties} { + lappend added_properties $propname + } + } elseif {[string range $m 0 4] eq "(SET)"} { + set propname [string range $m 5 end] + #do not forward or export setters - must use property syntax to set via API + if {$propname ni $added_properties} { + lappend added_properties $propname + } + } else { + #hack + if {$m eq "INFO"} { + oo::objdefine $apiobj forward $m [self] API($apiname)$m xxx + } else { + oo::objdefine $apiobj forward $m [self] API($apiname)$m + } + + if {$m ni $public_method_names} { + lappend public_method_names $m + } + } + } + oo::objdefine $apiobj export {*}$public_method_names + if {$apiname ni $::pp::private_apis} { + + } + + +} + + +#scan all methods on the varspace and make sure the api object has forwards from the simple method name to any prefixed method names we find +# (e.g API(xyz)methodblah ) - these are directly defined API methods as opposed to the usual(proper?) ones which are mixed in. +#Note - call order can be important if calling multiple times for the same apiname on different varspaces +# if a method is defined on the parent varspace class - the apiobj will forward to the instance of the last varspace to call update_api_methods +oo::define ::pp::varspace method API(PatternInternal)update_api_methods {apiname} { + + #todo - remove extra forwards etc? + + set mymethods [info object methods [self] -private -all] + set api_methods [lsearch -all -inline $mymethods "API($apiname)*"] + + + puts stdout "varspace update_api_methods [self] : api_methods for api $apiname: $api_methods" + if {[llength $api_methods]} { + oo::objdefine [self] export {*}$api_methods + + set plain_method_names [list] + foreach longname $api_methods { + set prefixposn [string first {)} $longname] + lappend plain_method_names [string range $longname $prefixposn+1 end] + } + set apiobj [pp::Obj${o_OID}::_apimanager get_api $apiname] + foreach m $plain_method_names { + oo::objdefine $apiobj forward $m [self] "API($apiname)$m" + } + oo::objdefine $apiobj export {*}$plain_method_names + + } + +} + +########################################## +#Main execution context for pattern objects. +# - methods are mixed in to instances of this class - (via renamed methods; prefixed with API($apiname) e.g API(collection)item +# - we should probably not add methods directly to this class - they would potentially conflict with user's added interfaces +# (or if we do need methods - prefix them with API(PatternInternal) ? +oo::class create ::pp::varspace_main { + superclass ::pp::varspace + variable _ID_ +} +oo::objdefine ::pp::varspace_main { + export createWithNamespace + mixin ::pp::namespacedcreate +} +oo::define ::pp::varspace_main constructor {varspace _InvocantData_} { + next $varspace $_InvocantData_ + puts stderr "constructor varspace_main" + set _ID_ $_InvocantData_ + + + + +} +########################################### + + +#mixin for varspace_ref apis: PatternInternal, varspace_ref +oo::class create ::pp::Ivarspace_ref +oo::define ::pp::Ivarspace_ref method get_refs {} { + return "not yet implemented - get_refs ns:[namespace current]" +} + + + +############################################################ +oo::class create ::pp::varspace_ref { + superclass ::pp::varspace + variable _ID_ __OBJECT +} +oo::objdefine ::pp::varspace_ref { + export createWithNamespace + mixin ::pp::namespacedcreate +} +oo::define ::pp::varspace_ref constructor {varspace _InvocantData_} { + next $varspace $_InvocantData_ + set _ID_ $_InvocantData_ +} + + +#exception - put internal methods directly on varspace_ref instances rather than indirect via interface mixins and api +oo::define ::pp::varspace_ref method object_read_trace {api vref idx op} { + #!review + my variable o_OID + upvar #0 ::pp::Obj${o_OID}::_meta::o_interface_apis interface_apis + if {$api eq "default"} { + set api [set ::pp::Obj${o_OID}::_meta::o_interface_default_api] + } + + + #don't rely on variable name passed by trace. + #set refvar ::pp::Obj${OID}::_ref::__OBJECT + set refvar __OBJECT + + #puts "\n\n+=====>object_read_trace '$vref' '$idx' '$op' refvar: $refvar\n\n" + + #!todo? - build a list of all interface properties (cache it on object??) + set iflist [dict get $interface_apis $api] + + set IID "" + foreach id [lreverse $iflist] { + if {$idx in [dict keys [set ::pp::Obj${id}::_iface::o_properties]]} { + set IID $id + break + } + } + + if {[string length $IID]} { + #property + set dispatcher_obj [::pp::Obj${o_OID} ## API(PatternInternal)get_dispatcher $api ] + if {[catch {set ${refvar}($idx) [$dispatcher_obj . idx]} errmsg]} { + puts stderr "\twarning: $dispatcher_obj . $idx retrieval failed (array?) errmsg:$errmsg" + } + + #if {[catch {set ${refvar}($idx) [::pp::Obj${id}::_iface::(GET)$idx $_ID_]} errmsg]} { + # puts stderr "\twarning: ::p::${id}::_iface::(GET)$idx retrieval failed (array?) errmsg:$errmsg" + #} + } else { + #method + error "property '$idx' not found" + } +} + +oo::define ::pp::varspace_ref method object_array_trace {api vref idx op} { + #!review + my variable o_OID __OBJECT + + if {$api eq "default"} { + set api [set ::pp::Obj${o_OID}::_meta::o_interface_default_api] + } + + #upvar #0 ::pp::Obj${o_OID}::_meta::o_invocantrecord invocantrecord + upvar #0 ::pp::Obj${o_OID}::_meta::o_interface_apis interface_apis + + #don't rely on variable name passed by trace - may have been 'upvar'ed + #set refvar ::pp::Obj${OID}::_ref::__OBJECT + set refvar __OBJECT + + #puts "+=====>object_array_trace api:'$api' vref:'$vref' idx:'$idx' '$op' refvar: $refvar" + + set iflist [dict get interface_apis $api] + + set plist [list] + + #review - why is this not using (GET)prop ? + + #!todo - get propertylist from cache on object(?) + foreach IFID [lreverse $iflist] { + dict for {prop pdef} [set ::pp::Obj${IFID}::_iface::o_properties] { + #lassign $pdef v + if {[catch {lappend plist $prop [set ::pp::Obj${OID}::o_${prop}]}]} { + if {[array exists ::pp::Obj${OID}::o_${prop}]} { + lappend plist $prop [array get ::pp::Obj${OID}::o_${prop}] + } else { + #ignore - array only represents properties that have been set. + #error "property $v is not set" + #!todo - unset corresponding items in $refvar if needed? + } + } + } + } + array set $refvar $plist +} + + +oo::define ::pp::varspace_ref method object_unset_trace {api vref idx op} { + #!review + my variable o_OID + upvar #0 ::pp::Obj${o_OID}::_meta::o_invocantrecord invocantrecord + upvar #0 ::pp::Obj${o_OID}::_meta::o_interface_apis interface_apis + + #!todo - ??? + + if {![llength [info commands ::pp::Obj${OID}::$idx]]} { + error "no such method or property: '$idx'" + } else { + #!todo? - build a list of all interface properties (cache it on object??) + set iflist [dict get $interface_apis $api] + set found 0 + foreach id [lreverse $iflist] { + if {$idx in [dict keys [set ::pp::Obj${id}::_iface::o_properties]]} { + set found 1 + break + } + } + + if {$found} { + unset ::pp::Obj${OID}::o_$idx + } else { + puts stderr "\tWARNING: UNIMPLEMENTED CASE! (unset) object_unset_trace id:$o_OID objectcmd:[lindex $invocantrecord 3] var:$vref prop:$idx" + } + } +} + +oo::define ::pp::varspace_ref method object_write_trace {api vref idx op} { + #!review + my variable o_OID + upvar #0 ::pp::Obj${o_OID}::_meta::o_interface_apis interface_apis + + #don't rely on variable name passed by trace. + #set refvar ::pp::Obj${OID}::_ref::__OBJECT + set refvar __OBJECT + #puts "+=====>object_write_trace api:'$api' '$vref' '$idx' '$op' refvar: $refvar" + + + if {![llength [info commands ::pp::Obj${OID}::$idx]]} { + #!todo - create new property in interface upon attempt to write to non-existant? + # - or should we require some different kind of object-reference for that? + array unset $refvar $idx ;#make sure 'array names' on the ref doesn't include this $idx + error "no such method or property: '$idx'" + } else { + #!todo? - build a list of all interface properties (cache it on object??) + set iflist [dict get $interface_apis $api] + set IID "" + foreach id [lreverse $iflist] { + if {$idx in [dict keys [set ::pp::Obj${id}::_iface::o_properties]]} { + set IID $id + break + } + } + + #$IID is now topmost interface in default iStack which has this property + + if {[string length $IID]} { + #write to defined property + + ::pp::Obj${IID}::_iface::(SET)$idx $_ID_ [set ${refvar}($idx)] + } else { + #!todo - allow write of method body back to underlying object? + #attempted write to 'method' ..undo(?) + array unset $refvar $idx ;#make sure 'array names' on the ref doesn't include this $idx + error "cannot write to method '$idx'" + #for now - disallow + } + } + +} +############################################################ + + + + +############################################################ + + + +oo::class create ::pp::varspace_meta { + superclass ::pp::varspace +} +oo::objdefine ::pp::varspace_meta { + export createWithNamespace + mixin ::pp::namespacedcreate +} +oo::define ::pp::varspace_meta { + variable _ID_ o_OID + variable o_invocantrecord o_interface_apis o_interface_default_api o_pattern_apis + + variable o_apimanager o_api_main o_api_patternsystem o_api_patternbuilder o_api_varspace_iface o_api_internal o_api_varspace_ref + +} +oo::define ::pp::varspace_meta constructor {varspace _InvocantData_} { + my variable o_OID + next $varspace $_InvocantData_ + set _ID_ $_InvocantData_ + set INVOCANTRECORD [lindex [dict get $_InvocantData_ i this] 0] + + set o_invocantrecord $INVOCANTRECORD + set o_interface_apis [dict create main {}] + set o_interface_default_api "main" + set o_pattern_apis [dict create main {}] + set o_default_pattern_api "main" + + + set o_ns ::pp::Obj$o_OID ;#namespace of the *main* varspace - not the namespace of this dispatcher + + + puts stderr "varspace_meta constructor OID:'$o_OID' " + puts stderr "varspace_meta constructor _ID_:'$_ID_'" + + + set v_reducer_id 0 + + set vs_main $o_ns ;#This is also the name of the main varspace object + set vs_meta [self] + set vs_ref [::pp::varspace_ref create ::pp::Obj${o_OID}::_ref _ref $_ID_] + set vs_iface [::pp::varspace_iface create ::pp::Obj${o_OID}::_iface _iface $_ID_] + + + set o_apimanager [::pp::varspace_apimanager create ::pp::Obj${o_OID}::_apimanager _apimanager $_ID_] + + + + set o_api_internal [$o_apimanager create_api "PatternInternal" {type private visible no}] + + #-------------------- + #! order important as all varspaces inherit from pp::varspace - so last varspace called here will be the context for those inherited methods + $vs_ref API(PatternInternal)update_api_methods "PatternInternal" + $vs_meta API(PatternInternal)update_api_methods "PatternInternal" + #-------------------- + + + + + set o_api_varspace_ref [$o_apimanager create_api "varspace_ref" {type private visible no}] + $vs_ref API(PatternInternal)update_api_methods "varspace_ref" + set o_api_varspace_meta [$o_apimanager create_api "varspace_meta" {type private visible no}] + set o_api_varspace_iface [$o_apimanager create_api "varspace_iface" {type private visible no}] + + $vs_meta API(PatternInternal)update_api_methods "varspace_meta" + + set o_api_main [$o_apimanager create_api "main" {type public visible yes}] + set o_api_patternsystem [$o_apimanager create_api "PatternSystem" {type private visible yes}] + set o_api_patternbuilder [$o_apimanager create_api "PatternBuilder" {type private visible yes}] + + $vs_meta API(PatternInternal)add_mixin_for_api "varspace_meta" "pp::Ivarspaces" + $vs_meta API(PatternInternal)add_mixin_for_api "PatternSystem" "pattern::IPatternSystem" + $vs_meta API(PatternInternal)add_mixin_for_api "PatternBuilder" "pattern::IPatternBuilder" + + $vs_iface API(PatternInternal)add_mixin_for_api "varspace_iface" "pp::Ivarspaces" + + #only relevant to interface objects + $vs_iface API(PatternInternal)add_mixin_for_api "varspace_iface" "pattern::IPatternInterface" + + #------ + # temporary test + #$vs_iface API(PatternInternal)add_mixin_for_api "main" "pattern::IPatternInterface" + #------ + + $vs_ref API(PatternInternal)add_mixin_for_api "varspace_ref" "pp::Ivarspaces" + $vs_ref API(PatternInternal)add_mixin_for_api "PatternInternal" "pp::Ivarspace_ref" + $vs_ref API(PatternInternal)add_mixin_for_api "varspace_ref" "pp::Ivarspace_ref" + + + + + + +} + + +oo::define ::pp::varspace_meta method API(varspace_meta)getmap {} { + my variable o_invocantrecord o_interface_apis o_pattern_apis + set result [dict create] + dict set result invocant $o_invocantrecord + dict set result interface_apis $o_interface_apis + dict set result pattern_apis $o_pattern_apis + return $result +} +oo::define ::pp::varspace_meta forward API(PatternInternal)getmap my API(varspace_meta)getmap + +oo::define ::pp::varspace_meta method API(varspace_meta)(SET)patterns {patternlist {api "default"}} { + my variable o_pattern_apis o_default_pattern_api + + if {$api eq "default"} { + set api $o_default_pattern_api + } + dict set o_pattern_apis $api $patternlist +} +oo::define ::pp::varspace_meta method API(varspace_meta)(GET)patterns {{api "default"}} { + my variable o_pattern_apis o_default_pattern_api + if {$api eq "default"} { + set api $o_default_pattern_api + } + return [dict get $o_pattern_apis $api] +} +oo::define ::pp::varspace_meta method API(varspace_meta)(SET)interfaces {interfacelist {api "default"}} { + my variable o_interface_apis o_interface_default_api + if {$api eq "default"} { + set api $o_interface_default_api + } + dict set o_interface_apis $api $interfacelist +} +oo::define ::pp::varspace_meta method API(varspace_meta)(GET)interfaces {{api "default"}} { + my variable o_interface_apis o_interface_default_api + if {$api eq "default"} { + set api $o_interface_default_api + } + return [dict get $o_interface_apis $api] +} +oo::define ::pp::varspace_meta method API(varspace_meta)(SET)default_method {default_method {api "default"}} { + my variable o_invocantrecord o_OID + if {$api eq "default"} { + set api $o_interface_default_api + } + + + #lset o_invocantrecord 2 $default_method + dict set o_invocantrecord defaultmethod $default_method + + + upvar #0 ::pp::Obj${o_OID}::_ID_ _InvocantData_ + + set extracted_record_list [dict get $_InvocantData_ i this] + #update the 1st in the list (review?) + set record [lindex $extracted_record_list 0] + lset $record 2 $default_method + lset extracted_record_list 0 $record + + dict set _InvocantData_ i this $extracted_record_list + + error "unimplemented" + foreach vs [(GET)varspaces] { + + } + + +} +oo::define ::pp::varspace_meta method API(varspace_meta)(GET)default_method {default_method} { + my variable o_invocantrecord + #return [lindex $o_invocantrecord 2] + return [dict get $o_invocantrecord defaultmethod] +} + +oo::define ::pp::varspace_meta method ID {} { + puts "varspace_meta method ID" + my variable o_OID + return $o_OID +} + +oo::define ::pp::varspace_meta { + export ID +} +############################################################ + + +#acts as manager and containing namespace for api instances +oo::class create ::pp::varspace_apimanager { + superclass pp::varspace + variable o_apis o_apis_public o_apis_private _ID_ o_api_main o_api_patternbuilder +} +oo::objdefine ::pp::varspace_apimanager { + export createWithNamespace + mixin ::pp::namespacedcreate +} +oo::define ::pp::varspace_apimanager constructor {varspace _InvocantData_} { + next $varspace $_InvocantData_ + set _ID_ $_InvocantData_ + set o_apis [dict create] + set o_apis_private [dict create] + set o_apis_public [dict create] + set o_api_main "" +} +#api factory for this pattern object +oo::define ::pp::varspace_apimanager method create_api {name {flagD {type public visible yes}}} { + set apiobj [namespace current]::api.$name + ::pp::api create $apiobj $name $_ID_ + + oo::objdefine $apiobj { + unexport destroy new create + } + + dict set o_apis $name $apiobj + if {[dict get $flagD type] eq "public"} { + dict set o_apis_public $name $apiobj + } + if {[dict get $flagD type] eq "private"} { + dict set o_apis_private $name $apiobj + } + + + + if {$name eq "default"} { + set o_api_main $apiobj + } + if {$name eq "PatternBuilder"} { + set o_api_patternbuilder $apiobj + } + #puts stderr "apimanager create_api $name returning apiobj:$apiobj" + return $apiobj +} +oo::define ::pp::varspace_apimanager method get_api {name} { + #puts stderr "varspace_apimanager [self] get_api $name" + #puts stderr "\t(returning [dict get $o_apis $name]" + return [dict get $o_apis $name] +} +oo::define ::pp::varspace_apimanager method get_api_public {name} { + return [dict get $o_apis_public $name] +} +oo::define ::pp::varspace_apimanager method get_api_private {name} { + return [dict get $o_apis_private $name] +} + +oo::define ::pp::varspace_apimanager method get_api_names {} { + return [dict keys $o_apis] +} +oo::define ::pp::varspace_apimanager method get_api_names_public {} { + return [dict keys $o_apis_public] +} +oo::define ::pp::varspace_apimanager method get_api_names_private {} { + return [dict keys $o_apis_private] +} + + + +#direct access methods for the 2 most common APIs +oo::define ::pp::varspace_apimanager method get_api_default {} { + return $o_api_main +} +oo::define ::pp::varspace_apimanager method get_api_patternbuilder {} { + return $o_api_patternbuilder +} + +################################################################## + +oo::class create ::pp::varspace_iface { + superclass ::pp::varspace + variable o_usedby o_open o_constructor o_variables o_properties o_methods o_varspace o_varspaces o_definition o_propertyunset_handlers +} +oo::objdefine ::pp::varspace_iface { + #self export createWithNamespace + export createWithNamespace + mixin ::pp::namespacedcreate +} +oo::define ::pp::varspace_iface constructor {varspace _InvocantData_} { + puts stderr "(::pp::varspace_iface constructor ) varspace:$varspace ns:[namespace current]" + if {$varspace ne "_iface"} { + error "(::pp::varspace_iface constructor) error. Attempt to create with varspace:'$varspace'. Must be '_iface'" + } + next $varspace $_InvocantData_ + set _ID_ $_InvocantData_ + array set o_usedby [list] + set o_open 0 + set o_constructor [list] + set o_variables [list] + set o_properties [dict create] + set o_methods [dict create] + set o_varspace "" + set o_varspaces [list] + array set o_definition [list] + set o_propertyunset_handlers [dict create] + +} + +oo::define ::pp::varspace_iface method API(varspace_iface)(GET)interface_varspaces {} { + my variable o_varspaces + return $o_varspaces +} + + + + +###################################################################### + +oo::class create ::pp::api { + superclass oo::class + #ok for api instances to have variables - because all methods are forwards to run in another object's namespace (forwards to methods mixed in to varspace objects) + variable o_name +} +oo::objdefine ::pp::api { + export createWithNamespace +} + +oo::objdefine ::pp::api method create {obj apiname _InvocantData_} { + #set OID [lindex [dict get $_InvocantData_ i this] 0 0] + set invocantD [lindex [dict get $_InvocantData_ i this] 0] + set OID [dict get $invocantD id] + set parentns ::pp::Obj${OID}::_apimanager + set api_ns ${parentns}::$apiname + if {[namespace exists $api_ns]} { + error "Cannot create api named '$apiname'. Already exists at $api_ns" + } + return [uplevel 1 [list [self] createWithNamespace $obj $api_ns $apiname $_InvocantData_]] +} +oo::define ::pp::api constructor {apiname _InvocantData_} { + puts stderr "api constructor _InvocantData_:'$_InvocantData_' apiname:'$apiname' ns:[namespace current]" + set o_name $apiname +} +#private +oo::define ::pp::api method _PATTERNSYSTEM_get_name {} { + return $o_name +} + + + +###################################################################### + + + + + + + + + + +oo::class create ::pp::dispatcher [string map [list @operators@ [list $pp::operators]] { + superclass oo::class + self export createWithNamespace + self method create {obj _InvocantData_ api} { + + #set dispatcher_ns ::pp::Obj${OID}::_dispatcher::$api + + set dispid [::pp::get_new_object_id] + set dispatcher_ns ::pp::Obj${dispid} ;# Dispatcher is it's own object - but is 'light' ie it doesn't have anything dispatching to itself, nor does it have the additional standard varspaces + #potentially the dispatcher could be morphed into a full object on an as-required basis if a particular app needs to manipulate dispatchers (specialize new_object ?) + # although we may need the dispatcher to be it's own dispatcher via a private api (as opposed to just dispatching to the separate object it is mainly intended for) + + return [uplevel 1 [list [self] createWithNamespace $obj $dispatcher_ns $_InvocantData_ $api]] + } + + variable o_OID o_ns v_operators v_reducer_id _ID_ + variable o_apimanager o_api o_api_patternbuilder o_dispatcher_object_command + variable o_single_dispatch + +}] +oo::define ::pp::dispatcher constructor {_InvocantData_ api args} [string map [list @operators@ [list $pp::operators]] { + if {[llength $args]} { + error "(::pp::dispatcher constructor) arguments to constructor not currently supported" + } + + set o_dispatcher_object_command [self] ;#todo add rename trace to update this with current name of dispatcher command + + set _ID_ $_InvocantData_ + set this_invocantD [lindex [dict get $_ID_ i this] 0] + set o_OID [dict get $this_invocantD id] + #set _ID_ [set ::pp::Obj${OID}::_ID_] + + puts stderr "(::pp::dispatcher constructor) >>> o_OID:$o_OID <<<" + set o_apimanager [set ::pp::Obj${o_OID}::_meta::o_apimanager] + + #the api that this dispatcher operates on by default + set o_api [$o_apimanager get_api $api] + + set o_api_patternbuilder [set ::pp::Obj${o_OID}::_meta::o_api_patternbuilder] + + set v_operators @operators@ + + + + #$o_apimanager create_api "_inspect_" + + set invocant_rolesD [dict get $_ID_ i] + set invocant_rolenames [dict keys $invocant_rolesD] + if {([llength $invocant_rolenames] == 1) && ([llength [dict get $invocant_rolesD [lindex $invocant_rolenames 0]]] == 1)} { + set o_single_dispatch 1 + } else { + #more than one invocant - this is a multi-dispatch dispatcher + set o_single_dispatch 0 + } + + if {$o_single_dispatch} { + oo::objdefine [self] forward GetApi $o_apimanager get_api + oo::objdefine [self] forward GetApiPublic $o_apimanager get_api_public + oo::objdefine [self] forward GetApiPrivate $o_apimanager get_api_private + } else { + #todo - add GetApi..etc methods which dispatch to all invocants? + } + + + + trace add command [self] rename [list [self] .. Rename] ;#will receive $oldname $newname "rename" + #trace add command $obj rename [$obj .. Rename .] ;#EXTREMELY slow. (but why?) + + # called when no DefaultMethod has been set for an object, but it is called with indices e.g >x something + #interp alias {} ::pp::Obj${OID}:: {} ::pp::func::no_default_method $_ID_ + +}] + +#return only the public apis shared by all invocants +oo::define ::pp::dispatcher method GetApiNamesPublic {} { + my variable _ID_ + set list_of_api_lists [list] + set invocant_rolesD [dict get $_ID_ i] + foreach rolename [dict keys $invocant_rolesD] { + set invocant_list_for_role [dict get $invocant_rolesD $rolename] + foreach invD $invocant_list_for_role { + set id [dict get $invD id] + set apiman [set ::pp::Obj${id}::_meta::o_apimanager] + set invocant_apis [$apiman get_api_names_public] + lappend list_of_api_lists $invocant_apis + } + } + package require struct::set + set common_apis [struct::set intersect {*}$list_of_api_lists] +} + +#private +oo::define ::pp::dispatcher method Update_invocant {new_invocant_record_data {rolename "this"}} { + error "unimplemented?" + #new_invocant_record_data is either a completely new record for insertion, or one that matches an existing OID + set changed_record_id [lindex $new_invocant_record_data 0] + + set extracted_invocants [dict get $_ID_ i $rolename] ;#A list of current invocant records + #OID is the 1st element in each record - search for a match + set posn [lsearch -index 0 $extracted_invocants $changed_record_id] + if {$posn >= 0} { + #set extracted_record [lindex $extracted_invocants 0] + set extracted_invocants [lreplace $extracted_invocants $posn $posn $new_invocant_record_data] + } else { + #invocant record not iin list for this role - add it + lappend extracted_invocants $new_invocant_record_data + } + + #Note that _ID_ can have multiple invocant records in multiple roles - as opposed to single object's o_invocantrecord + dict set _ID_ i this $extracted_invocants + + upvar #0 ::pp::Obj${o_OID}::_meta::o_invocantrecord invocantrecord + set invocantrecord $new_invocant_record_data +} + +oo::define ::pp::dispatcher method = {args} { + if {[llength $args]} { + set cmdname [lindex $args 0] + set match [uplevel 1 [list info commands $cmdname]] + if {[llength $match]} { + #override anyway + } + uplevel 1 [list interp alias {} $cmdname {} [self]] + if {[llength $args] > 1} { + tailcall [self] {*}[lrange $args 1 end] + } else { + return [self] + } + } else { + #review - store list of all aliases created in this manner - and allow querying? + #(maintaining such a list would also would allow proper cleanup!) + } +} + +oo::define ::pp::dispatcher method # {args} [string map [list @no_operators_in_args@ $pp::no_operators_in_args] { + + if {![llength $args]} { + #tailcall $o_apimanager get_api_names_public + tailcall my GetApiNamesPublic + } + + if {([llength $args] == 1) && @no_operators_in_args@} { + tailcall my GetApiPublic [lindex $args 0] + } + + if {@no_operators_in_args@} { + #tailcall [my GetApi [lindex $args 0]] {*}[lrange $args 1 end] ;#no! - we don't want to execute methods this way. + # Disallow to encourage proper use of "." and to allow potential future arguments to GetApi + #;This will currently raise an error - as GetApi accepts only 1 argument. That's ok for now. + tailcall [my GetApiPublic {*}$args] + } else { + tailcall my predator # {*}$args + } +}] + +oo::define ::pp::dispatcher method ## {args} [string map [list @no_operators_in_args@ $pp::no_operators_in_args] { + if {![llength $args]} { + tailcall $o_apimanager get_api_names_private + } + + if {([llength $args] == 1) && @no_operators_in_args@} { + tailcall my GetApiPrivate [lindex $args 0] + } + + if {@no_operators_in_args@} { + #tailcall [my GetApi [lindex $args 0]] {*}[lrange $args 1 end] ;#no! - we don't want to execute methods this way. + # Disallow to encourage proper use of "." and to allow potential future arguments to GetApi + #;This will currently raise an error - as GetApi accepts only 1 argument. That's ok for now. + tailcall [my GetApiPrivate {*}$args] + } else { + tailcall my predator ## {*}$args + } +}] + +oo::define ::pp::dispatcher method > {args} [string map [list @no_operators_in_args@ $pp::no_operators_in_args] { + if {![llength $args]} { + tailcall $o_apimanager get_api_names_public + } + + if {([llength $args] == 1) && @no_operators_in_args@} { + #tailcall my GetApiPrivate [lindex $args 0] + set dispatcher_patternobject ::pp::Obj${o_OID}::_dispatcher::>[lindex $args 0] + if {![llength [info commands $dispatcher_patternobject]]} { + pp::dispatcher create $dispatcher_patternobject $o_OID [lindex $args 0] + } + return $dispatcher_patternobject + } + + if {@no_operators_in_args@} { + #tailcall [my GetApi [lindex $args 0]] {*}[lrange $args 1 end] ;#no! - we don't want to execute methods this way. + # Disallow to encourage proper use of "." and to allow potential future arguments to GetApi + #;This will currently raise an error - as GetApi accepts only 1 argument. That's ok for now. + #tailcall [my GetApiPrivate {*}$args] + set dispatcher_patternobject ::pp::Obj${o_OID}::_dispatcher::>[lindex $args 0] + if {![llength [info commands $dispatcher_patternobject]]} { + pp::dispatcher create $dispatcher_patternobject $o_OID [lindex $args 0] [lrange $args 1 end] ;#pass to dispatcher constructor + } + return $dispatcher_patternobject + + + } else { + tailcall my predator > {*}$args + } +}] + +oo::define ::pp::dispatcher method >> {args} [string map [list @no_operators_in_args@ $pp::no_operators_in_args] { + if {![llength $args]} { + tailcall $o_apimanager get_api_names_private + } + + if {([llength $args] == 1) && @no_operators_in_args@} { + #tailcall my GetApiPrivate [lindex $args 0] + set dispatcher_patternobject ::pp::Obj${o_OID}::_dispatcher::>[lindex $args 0] + if {![llength [info commands $dispatcher_patternobject]]} { + pp::dispatcher create $dispatcher_patternobject $o_OID [lindex $args 0] + } + return $dispatcher_patternobject + } + + if {@no_operators_in_args@} { + #tailcall [my GetApi [lindex $args 0]] {*}[lrange $args 1 end] ;#no! - we don't want to execute methods this way. + # Disallow to encourage proper use of "." and to allow potential future arguments to GetApi + #;This will currently raise an error - as GetApi accepts only 1 argument. That's ok for now. + #tailcall [my GetApiPrivate {*}$args] + set dispatcher_patternobject ::pp::Obj${o_OID}::_dispatcher::>[lindex $args 0] + if {![llength [info commands $dispatcher_patternobject]]} { + pp::dispatcher create $dispatcher_patternobject $o_OID [lindex $args 0] [lrange $args 1 end] ;#pass to dispatcher constructor + } + return $dispatcher_patternobject + + + } else { + tailcall my predator >> {*}$args + } +}] + + + + +oo::define ::pp::dispatcher method . {args} [string map [list @no_operators_in_args@ $pp::no_operators_in_args] { + if {([llength $args] ==1)} { + if {[lindex $args 0] ni $v_operators} { + #set command ::pp::Obj${o_OID}::[lindex $args 0] + #set command [list [::pp::Obj${o_OID}::_apimanager get_api_default] [lindex $args 0]] + set command [list $o_api [lindex $args 0]] + tailcall {*}$command + + if 0 { + #fix + if {![llength [info commands [lindex $command 0]]]} { + if {[llength [info commands ::p::${o_OID}::(UNKNOWN)]]} { + set command ::p::${o_OID}::(UNKNOWN) + tailcall $command $_ID_ [lindex $args 0] ;#delegate to UNKNOWN, along with original commandname as 1st arg. + } else { + return -code error -errorinfo "2a)error running command:'$command' argstack:'[lrange $args 2 end]'\n - command not found and no 'unknown' handler" "method '[lindex $args 0]' not found" + } + } else { + #tailcall {*}$command $_ID_ + tailcall {*}$command + } + } + } else { + error "invalid syntax" ;#e.g >obj . , >obj . -- + } + } elseif {![llength $args]} { + #tailcall [::p::internals::ref_to_object $_ID_] + tailcall my Ref_to_object $_ID_ + } elseif {@no_operators_in_args@} { + #error "incomplete branch for '.'" + #no further operators + set remaining_args [lassign $args method_or_prop] + #set command ::p::${o_OID}::$method_or_prop + + tailcall $o_api {*}$args + + + if 0 { + if {![llength [info commands $command]]} { + if {[llength [info commands ::p::${o_OID}::(UNKNOWN)]]} { + set command ::p::${o_OID}::(UNKNOWN) + tailcall $command $_ID_ $method_or_prop {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg. + } else { + return -code error -errorinfo "2b)error running command:'$command' argstack:'[lrange $args 2 end]'\n - command not found and no 'unknown' handler" "method '$method_or_prop' not found" + } + } else { + tailcall $command $_ID_ {*}$remaining_args + } + } + } else { + if {[lindex $args end] eq "."} { + #shortcircuit for commonly used case + set args_original $args + set args [lrange $args[set args {}] 0 end-1] + if {@no_operators_in_args@} { + tailcall my Ref_to_stack $o_OID $_ID_ $args + } + set args $args_original + } + #$args contains further operators - requires reduction + #pass through to predator + tailcall my predator . {*}$args + } +}] + + +oo::define ::pp::dispatcher method .. {args} [string map [list @no_operators_in_args@ $pp::no_operators_in_args] { + my variable o_single_dispatch o_api_patternbuilder + if {![llength $args]} { + tailcall return $_ID_ + } elseif {[llength $args] == 1} { + #set api [$o_apimanager get_api_patternbuilder] + tailcall $o_api_patternbuilder [lindex $args 0] + + #tailcall [my GetApi "meta"] . [lindex $args 0] + } else { + if {@no_operators_in_args@} { + #set api [$o_apimanager get_api_patternbuilder] + tailcall $o_api_patternbuilder {*}$args + #tailcall ::p::-1::[lindex $args 0] $_ID_ {*}[lrange $args 1 end] + } else { + tailcall my predator .. {*}$args + } + } +}] + +oo::define ::pp::dispatcher method -- {args} { + if {![llength $args]} { + set result [dict create] + dict set result invocantrecord [set ::pp::Obj${o_OID}::_meta::o_invocantrecord] + dict set result interface_apis [set ::pp::Obj${o_OID}::_meta::o_interface_apis] + dict set result pattern_apis [set ::pp::Obj${o_OID}::_meta::o_pattern_apis] + tailcall return $result + } else { + tailcall my predator -- {*}$args + } +} + +oo::define ::pp::dispatcher method - {args} { + tailcall my predator - {*}$args +} + +oo::define ::pp::dispatcher method & {args} { + tailcall my predator & {*}$args +} +oo::define ::pp::dispatcher method @ {args} { + tailcall my predator @ {*}$args +} +oo::define ::pp::dispatcher method ! {args} { + tailcall my predator ! {*}$args +} + +oo::define ::pp::dispatcher method , {args} [string map [list @no_operators_in_args@ $pp::no_operators_in_args] { + if {[llength $args] == 1} { + upvar #0 [namespace parent]::_ID_ _ID_ + set default_method [lindex [dict get $_ID_ i this] 0 2] + tailcall ::pp::Obj${o_OID}::my $default_method $_ID_ [lindex $args 0] + } + if {([llength $args] > 1) && @no_operators_in_args@} { + upvar #0 [namespace parent]::_ID_ _ID_ + set default_method [lindex [dict get $_ID_ i this] 0 2] + tailcall ::pp::Obj${o_OID}::my $default_method $_ID_ {*}$args + } + tailcall my predator , {*}$args +}] + + +oo::define ::pp::dispatcher method unknown {args} { + puts stderr " !!!!pp::dispatcher call to unknown with args:'$args'" + if {![llength $args]} { + tailcall return $o_OID + } else { + if {[llength $args] == 1} { + set default_method [lindex [dict get $_ID_ i this] 0 2] + + #not an operator (since not dispatched to other methods) - single index case + if {![string length $default_method]} { + # call ::pp::Ob${o_OID}:: ?? + tailcall ::pp::func::no_default_method $_ID_ + } + tailcall ::pp::Obj${o_OID}::my $default_method $_ID_ [lindex $args 0] + } + tailcall my predator {*}$args + } +} + + +oo::define ::pp::dispatcher method do {script} { + eval $script +} + +oo::define ::pp::dispatcher { + export {*}$::pp::operators +} + +#trailing. after command/property +oo::define ::pp::dispatcher method Ref_to_stack {OID _InvocantData_ fullstack} { + #NOTE OID & _InvocantData_ may be from another instance + + #review - handle mechanism "execute" ? + set commandstack $fullstack + set argstack [lassign $commandstack command] + set field [string map {> __OBJECT_} [namespace tail $command]] + #!todo? + # - make every object's OID unpredictable and sparse (UUID) and modify 'namespace child' etc to prevent iteration/inspection of ::p namespace. + # - this would only make sense for an environment where any meta methods taking a code body (e.g .. Method .. PatternMethod etc) are restricted. + + #references created under ::p::${OID}::_ref are effectively inside a 'varspace' within the object itself. + # - this would in theory allow a set of interface functions on the object which have direct access to the reference variables. + + set refname ::p::${OID}::_ref::[join [concat $field $argstack] +] + if {[llength [info commands $refname]]} { + #todo - review - what if the field changed to/from a property/method? + #probably should fix that where such a change is made and leave this short circuit here to give reasonable performance for existing refs + return $refname + } + #::p::internals::create_or_update_reference $OID $_InvocantData_ $refname $command + my Create_or_update_reference $OID $_InvocantData_ $refname $command + return $refname +} + +oo::define ::pp::dispatcher method predator {args} { + #set reduce [namespace current]::${o_OID}_[incr v_reducer_id] + set reduce reducer_${o_OID}_[incr v_reducer_id] ;#need an id per predator call (as predator sometimes called within another call) + #puts stderr "pp::dispatcher predator ..................creating reducer $reduce with args o_OID:$o_OID _ID_ args:$args" + #coroutine $reduce ::p::internals::jaws $o_OID $_ID_ {*}$args + coroutine $reduce my Jaws $o_OID $_ID_ {*}$args + set reduced_ID_ $_ID_ + set final 0 + set result "" + while {$final == 0} { + #the argument given here to $reduce will be returned by 'yield' within the coroutine context (jaws) + #set reduction_args [lassign [$reduce $reduced_ID_[set reduced_ID_ [list]] ] final reduced_ID_ command] + set reduction_resultD [$reduce $reduced_ID_[set reduced_ID_ [list]]] + puts stderr "\tPREDATOR reduction_resultD:\n\t$reduction_resultD" + + + set final [dict get $reduction_resultD final] + set reduced_ID_ [dict get $reduction_resultD _ID_] + set stack [dict get $reduction_resultD stack] + set mechanism [dict get $reduction_resultD mechanism] + + set command [lindex $stack 0] + + if {[dict exists $reduction_resultD "makealias"]} { + #puts stderr "> > > reduction_resultD:$reduction_resultD" + set aliasinfo [dict get $reduction_resultD makealias] + set newalias [dict get $aliasinfo source] + set target [dict get $aliasinfo target] + uplevel 1 [list interp alias {} $newalias {} {*}[lindex $target 0] {*}[lrange $target 1 end]] + if {$mechanism eq "return"} { + set command [concat list $command] + } else { + set command $command + } + } + + + if {$final == 1} { + if {[llength $command] == 1} { + #puts stderr " .> stack:$stack mechanism:$mechanism reduction_resultD:$reduction_resultD <." + tailcall {*}$stack + #What is the difference between execute and reduce anyway? Reduce expects an object - so we can treat differently - but why? how? + #Better error reporting perhaps - but at what speed/efficiency cost? Should just let the API/interface unknown method handle errors (!?) + } else { + #e.g lindex {a b c} + tailcall {*}$command {*}[lrange $stack 1 end] + } + } else { + if {$mechanism eq "execute"} { + set result [uplevel 1 [list {*}$command {*}[lrange $stack 1 end]]] + set reduced_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {} ] + + } else { + set result [uplevel 1 [list {*}$command {*}[lrange $stack 1 end] ]] + + if {[llength [info commands $result]]} { + if {([llength $result] == 1) && ([string first ">" [namespace tail $result]] == 0)} { + #looks like a pattern command + set reduced_ID_ [$result ## PatternSystem . INVOCANTDATA] + } else { + #non-pattern command + set reduced_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}] + } + } else { + set reduced_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}] + #!todo - allow further operations on non-command values. e.g dicts, lists & strings (treat strings as lists) + } + } + } + } + error "Assert: Shouldn't get here (end of ::pp::dispatcher method 'predator')" + +} +oo::define ::pp::dispatcher unexport predator + +#trailing. directly after object +oo::define ::pp::dispatcher method Ref_to_object {arg_ID_} { + #NOTE - arg_ID_ may be from another object - hence it's an argument + set OID [dict get [lindex [dict get $arg_ID_ i this] 0] id] + + upvar #0 ::pp::Obj${OID}::_meta::o_invocantrecord invocantrecord + + #lassign $invocantrecord OID alias default_method object_command + dict update invocantrecord id OID ns ns defaultmethod default_method object object_command {} + + set refname ::pp::Obj${OID}::_ref::__OBJECT + + + #test $refname using 'info vars' - because 'info exists' or 'array exists' would fire traces + if {![llength [info vars $refname]]} { + #important to initialise the variable as an array - or initial read attempts on elements will not fire traces + array set $refname [list] + } + + set trace_list [trace info variable $refname] + + #set traceCmd [list ::p::predator::object_read_trace $OID $arg_ID_] + set traceCmd [list ::pp::Obj${OID}::_ref object_read_trace "default"] + if {[list {read} $traceCmd] ni $trace_list} { + #puts stdout "adding read trace on variable '$refname' - traceCmd:'$traceCmd'" + trace add variable $refname {read} $traceCmd + } + #set traceCmd [list ::p::predator::object_array_trace $OID $arg_ID_] + set traceCmd [list ::pp::Obj${OID}::_ref object_array_trace "default"] + if {[list {array} $traceCmd] ni $trace_list} { + trace add variable $refname {array} $traceCmd + } + + #set traceCmd [list ::p::predator::object_write_trace $OID $arg_ID_] + set traceCmd [list ::pp::Obj${OID}::_ref object_write_trace] + if {[list {write} $traceCmd] ni $trace_list} { + trace add variable $refname {write} $traceCmd + } + + #set traceCmd [list ::p::predator::object_unset_trace $OID $arg_ID_] + set traceCmd [list ::pp::Obj${OID}::_ref object_unset_trace] + if {[list {unset} $traceCmd] ni $trace_list} { + trace add variable $refname {unset} $traceCmd + } + return $refname +} + + +oo::define ::pp::dispatcher method Create_or_update_reference {OID _InvocantData_ refname command} { + + set reftail [namespace tail $refname] + set argstack [lassign [split $reftail +] field] + set field [string map {> __OBJECT_} [namespace tail $command]] + + puts stderr "refname:'$refname' command: $command field:$field" + + + if {$OID ne "null"} { + set invocantrecord [set ::pp::Obj${o_OID}::_meta::o_invocantrecord] + set interface_apis [set ::pp::Obj${o_OID}::_meta::o_interface_apis] + set pattern_apis [set ::pp::Obj${o_OID}::_meta::o_pattern_apis] + } else { + set invocantrecord [lindex [dict get $_InvocantData_ i this] 0] + set interface_apis {"main" {}} + set pattern_apis {"main" {}} + } + #lassign $invocantrecord OID alias default_method object_command + dict update invocantrecord id OID ns ns defaultmethod default_method object object_command {} + + + + if {$OID ne "null"} { + interp alias {} $refname {} $command $_InvocantData_ {*}$argstack + } else { + interp alias {} $refname {} $command {*}$argstack + } + + + set iflist [dict get $interface_apis "main"] + + set field_is_property_like 0 + foreach IFID [lreverse $iflist] { + #tcl (braced) expr has lazy evaluation for &&, || & ?: operators - so this should be reasonably efficient. + error "Create_or_update_reference incomplete - need test for field_is_property_like" + if {[llength [info commands ::p::${IFID}::_iface::(GET)$field]] || [llength [info commands ::p::${IFID}::_iface::(SET)$field]]} { + set field_is_property_like 1 + #There is a setter or getter (but not necessarily an entry in the o_properties dict) + break + } + } + + + #whether field is a property or a method - remove any commandrefMisuse_TraceHandler + foreach tinfo [trace info variable $refname] { + #puts "-->removing traces on $refname: $tinfo" + if {[lindex $tinfo 1 0] eq "::pp::func::commandrefMisuse_TraceHandler"} { + trace remove variable $refname {*}$tinfo + } + } + + if {$field_is_property_like} { + #property reference + + + set this_invocantdata [lindex [dict get $_InvocantData_ i this] 0] + lassign $this_invocantdata OID _alias _defaultmethod v_object_command + #get fully qualified varspace + + # + set propdict [$v_object_command .. GetPropertyInfo $field] + if {[dict exist $propdict $field]} { + set field_is_a_property 1 + set propinfo [dict get $propdict $field] + set varspace [dict get $propinfo varspace] + if {$varspace eq ""} { + set full_varspace ::pp::Obj${OID} + } else { + if {[::string match "::*" $varspace]} { + set full_varspace $varspace + } else { + set full_varspace ::pp::Obj${OID}::$varspace + } + } + } else { + set field_is_a_property 0 + #no propertyinfo - this field was probably established as a PropertyRead and/or PropertyWrite without a Property + #this is ok - and we still set the trace infrastructure below (app may convert it to a normal Property later) + set full_varspace ::pp::Obj${OID} + } + + + #We only trace on entire property.. not array elements (if references existed to both the array and an element both traces would be fired -(entire array trace first)) + set propvar_trace_list [trace info variable ${full_varspace}::o_${field}] + set Hndlr [::list ::p::predator::propvar_write_TraceHandler $OID $field] + if { [::list {write} $Hndlr] ni $propvar_trace_list} { + trace add variable ${full_varspace}::o_${field} {write} $Hndlr + } + set Hndlr [::list ::p::predator::propvar_unset_TraceHandler $OID $field] + if { [::list {unset} $Hndlr] ni $propvar_trace_list} { + trace add variable ${full_varspace}::o_${field} {unset} $Hndlr + } + + + #supply all data in easy-access form so that propref_trace_read is not doing any extra work. + set get_cmd ::pp::Obj${o_OID}::(GET)$field + set traceCmd [list ::p::predator::propref_trace_read $get_cmd $_InvocantData_ $refname $field $argstack] + + if {[list {read} $traceCmd] ni [trace info variable $refname]} { + set fieldvarname ${full_varspace}::o_${field} + + + #synch the refvar with the real var if it exists + #catch {set $refname [$refname]} + if {[array exists $fieldvarname]} { + if {![llength $argstack]} { + #unindexed reference + array set $refname [array get $fieldvarname] + #upvar $fieldvarname $refname + } else { + set s0 [lindex $argstack 0] + #refs to nonexistant array members common? (catch vs 'info exists') + if {[info exists ${fieldvarname}($s0)]} { + set $refname [set ${fieldvarname}($s0)] + } + } + } else { + #refs to uninitialised props actually should be *very* common. + #If we use 'catch', it means retrieving refs to non-initialised props is slower. Fired catches can be relatively expensive. + #Because it's common to get a ref to uninitialised props (e.g for initial setting of their value) - we will use 'info exists' instead of catch. + + #set errorInfo_prev $::errorInfo ;#preserve errorInfo across catches! + + #puts stdout " ---->>!!! ref to uninitialised prop $field $argstack !!!<------" + + + if {![llength $argstack]} { + #catch {set $refname [set ::p::${o_OID}::o_$field]} + if {[info exists $fieldvarname]} { + set $refname [set $fieldvarname] + #upvar $fieldvarname $refname + } + } else { + if {[llength $argstack] == 1} { + #catch {set $refname [lindex [set ::p::${o_OID}::o_$field] [lindex $argstack 0]]} + if {[info exists $fieldvarname]} { + set $refname [lindex [set $fieldvarname] [lindex $argstack 0]] + } + + } else { + #catch {set $refname [lindex [set ::p::${o_OID}::o_$field] $argstack]} + if {[info exists $fieldvarname]} { + set $refname [lindex [set $fieldvarname] $argstack] + } + } + } + + #! what if someone has put a trace on ::errorInfo?? + #set ::errorInfo $errorInfo_prev + } + trace add variable $refname {read} $traceCmd + + set traceCmd [list ::p::predator::propref_trace_write $_InvocantData_ $OID $full_varspace $refname] + trace add variable $refname {write} $traceCmd + + set traceCmd [list ::p::predator::propref_trace_unset $_InvocantData_ $OID $refname] + trace add variable $refname {unset} $traceCmd + + + set traceCmd [list ::p::predator::propref_trace_array $_InvocantData_ $OID $refname] + # puts "**************** installing array variable trace on ref:$refname - cmd:$traceCmd" + trace add variable $refname {array} $traceCmd + } + + } else { + #puts "$refname ====> adding refMisuse_traceHandler $alias $field" + #matching variable in order to detect attempted use as property and throw error + + #2018 + #Note that we are adding a trace on a variable (the refname) which does not exist. + #this is fine - except that the trace won't fire for attempt to write it as an array using syntax such as set $ref(someindex) + #we could set the ref to an empty array - but then we have to also undo this if a property with matching name is added + ##array set $refname {} ;#empty array + # - the empty array would mean a slightly better error message when misusing a command ref as an array + #but this seems like a code complication for little benefit + #review + + trace add variable $refname {read write unset array} [list ::pp::func::commandrefMisuse_TraceHandler $OID $field] + } +} + + + + +oo::define ::pp::dispatcher method Jaws {OID _InvocantData_ args} { + #puts stderr ">>>jaws called with OID'$OID' _InvocantData_:'$_InvocantData_' args: '$args'" + #set OID [lindex [dict get $_InvocantData_ i this] 0 0] ;#get_oid + + yield + set w 1 + + set stack [list] + set wordcount [llength $args] + set terminals [list . .. , # ## > >> @ ! =] ;#tokens which require the current stack to be evaluated(reduced) first + set unsupported 0 + set operator "" + set operator_prev "" ;#used only by argprotect to revert to previous operator + + + if {$OID ne "null"} { + #!DO NOT use upvar here! (calling set on an invocantrecord element in another iteration/call will overwrite data for another object!) + set invocantrecord [set ::pp::Obj${OID}::_meta::o_invocantrecord] + } else { + set invocantrecord [lindex [dict get $_InvocantData_ i this] 0] + + } + #lassign $invocantrecord OID alias default_method object_command wrapped + dict update invocantrecord id OID defaultmethod default_method object object_command {} + set finished_args 0 ;#whether we've completely processed all args in the while loop and therefor don't need to peform the final word processing code + + #don't use 'foreach word $args' - we sometimes need to backtrack a little by manipulating $w + + set mechanism "reduce" ;#default + + while {$w < $wordcount} { + set word [lindex $args [expr {$w -1}]] + #puts stdout "w:$w word:$word stack:$stack" + if {$operator eq "argprotect"} { + set operator $operator_prev + lappend stack $word + incr w + } else { + if {[llength $stack]} { + #puts stderr "$$ word:$word stack:$stack" + if {$word in $terminals} { + if {$word eq "="} { + incr w + set nextword [lindex $args [expr {$w -1}]] + #uplevel 2 interp alias {} $nextword {} $object_command {*}$stack + #we can't uplevel 2 here (becuase of coro?), so return a _makealias_ instruction to the predator + #incr w + if {$w eq $wordcount} { + set finished_args 1 + #we need the command name to be returned rather than executing it! + #set stack [linsert $stack 0 "_makealias_" $nextword "_return_"] + if {$operator in {"#" "##" ">" ">>"}} { + set mechanism "return" + } else { + set mechanism "reduce" + } + set reduction [list final 1 _ID_ $_InvocantData_ stack $stack mechanism $mechanism] + + dict set reduction makealias [list source $nextword target $stack] + + return $reduction + } else { + set mechanism "continue" + set reduction [list final 0 _ID_ $_InvocantData_ stack $stack mechanism $mechanism] + dict set reduction makealias [list source $nextword target $stack] + #set stack [linsert $stack 0 "_makealias_" $nextword "_evaluate_"] + + } + + puts stderr "!!!!!!!!!!! reduction:$reduction" + + } else { + if {$operator in {"#" "##"}} { + set mechanism "reduce" ;# back to default + set operator $word + incr w + continue + } elseif {$operator in {"x>" "x>>"}} { + set mechanism "reduce" ;# back to default + set operator $word + set dispatcher_object [lindex $stack 0] + set _InvocantData_ [$dispatcher_object ## PatternSystem .. INVOCANTDATA] + continue + } else { + #puts stsderr "here !!!! operator:$operator" + set mechanism "reduce" + set reduction [list final 0 _ID_ $_InvocantData_ stack $stack mechanism $mechanism] + } + } + + puts stderr "\t>>>jaws yielding value: [list $reduction]\n\ttriggered by word $word in position:$w" + set _InvocantData_ [yield $reduction] + puts stderr ">>>jaws got back value:$_InvocantData_" + set stack [list] + #set OID [::pattern::get_oid $_InvocantData_] + #set OID [lindex [dict get $_InvocantData_ i this] 0 0] ;#get_oid + set OID [dict get [lindex [dict get $_InvocantData_ i this] 0] id] + + if {$OID ne "null"} { + set invocantrecord [set ::pp::Obj${OID}::_meta::o_invocantrecord] ;#Do not use upvar here! + } else { + set invocantrecord [lindex [dict get $_InvocantData_ i this] 0] + #puts stderr "WARNING REVIEW: jaws-branch - leave empty??????" + } + + #review - 2018. switched to _InvocantData_ instead of _meta::o_invocantrecord etc + lassign [lindex [dict get $_InvocantData_ i this] 0] OID alias default_method object_command + + + #puts stdout "---->>> yielded _InvocantData_: $_InvocantData_ OID:$OID alias:$alias default_method:$default_method object_command:$object_command" + set operator $word + #don't incr w + #incr w + + } else { + if {$operator eq "argprotect"} { + set operator $operator_prev + set operator_prev "" + lappend stack $word + } else { + #only look for leading argprotect chacter (-) if we're not already in argprotect mode + if {$word eq "--"} { + set operator_prev $operator + set operator "argprotect" + #Don't add the plain argprotector to the stack + } elseif {[string match "-*" $word]} { + #argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument) + set operator_prev $operator + set operator "argprotect" + lappend stack $word + } else { + lappend stack $word + } + } + + + incr w + } + } else { + + + + #no stack + switch -- $word {.} { + + if {$OID ne "null"} { + #we know next word is a property or method of a pattern object + incr w + set nextword [lindex $args [expr {$w - 1}]] + #set command [list ::pp::Obj${OID} $nextword] ;#?? + #set command [list [::pp::Obj${OID}::_apimanager get_api_default] $nextword] + + set apiobj [::pp::Obj${OID}::_apimanager get_api_default] + set command [list $apiobj $nextword] + puts stderr ">>>> command:$command <<<" + + + set stack [list $command] ;#2018 j + set operator . + if {$w eq $wordcount} { + set finished_args 1 + } + } else { + error "untested" + # don't incr w + #set nextword [lindex $args [expr {$w - 1}]] + set command $object_command + set stack [list "_exec_" $command] + set operator . + } + + + } {..} { + incr w + set nextword [lindex $args [expr {$w -1}]] + set apiobj [::pp::Obj${OID}::_apimanager get_api_patternbuilder] + #set command [list $apiobj $nextword] + #lappend stack $command ;#lappend a small number of items to an empty list is slower than just setting the list. + #set stack [list $command] ;#faster, and intent is clearer than lappend. + + set stack [list $apiobj $nextword] + set operator .. + if {$w eq $wordcount} { + set finished_args 1 + } + } {#} { + incr w + set nextword [lindex $args [expr {$w -1}]] + set apiobj [::pp::Obj${OID}::_apimanager get_api_public $nextword] + set stack [list $apiobj] + set operator # + if {$w eq $wordcount} { + set finished_args 1 + } + } {##} { + incr w + set nextword [lindex $args [expr {$w -1}]] + set apiobj [::pp::Obj${OID}::_apimanager get_api_private $nextword] + set command $apiobj + set stack [list $command] + set operator ## + if {$w eq $wordcount} { + set finished_args 1 + } + } {>} { + incr w + set nextword [lindex $args [expr {$w -1}]] + set patternobj ::pp::Obj${OID}::_dispatcher::>$nextword + set stack [list $patternobj] + set operator > + if {$w eq $wordcount} { + set finished_args 1 + } + } {>>} { + incr w + set nextword [lindex $args [expr {$w -1}]] + set patternobj ::pp::Obj${OID}::_dispatcher::>$nextword + set _InvocantData_ [$patternobj ## PatternSystem .. INVOCANTDATA] + set stack [list] + #set stack [list $patternobj] + #set operator >> + if {$w eq $wordcount} { + set finished_args 1 + } + } {=} { + error "untested branch - needed?" + incr w + set nextword [lindex $args [expr {$w -1}]] + lassign [lindex [dict get $_InvocantData_ i this] 0] OID alias default_method object_command + set command [list $object_command = $nextword {*}[lrange $args [expr {$w -1}] end]] + set stack $command + set operator = + set finished_args 1 ;#jump to end because we've thrown all remaining args back to the predator + + } {,} { + #puts stdout "Stackless comma!" + + + if {$OID ne "null"} { + #set command ::p::${OID}::$default_method + set command [list ::pp::Obj${OID}::_apimanager get_api_default] $default_method] + + } else { + set command [list $default_method $object_command] + #object_command in this instance presumably be a list and $default_method a list operation + #e.g "lindex {A B C}" + } + #lappend stack $command + #set stack [list $command] + set stack $command + set operator , + } {--} { + set operator_prev $operator + set operator argprotect + #no stack - + } {!} { + set mechanism "execute" + set command $object_command + #set stack [list "_exec_" $object_command] + set stack [list $object_command] + #puts stdout "!!!! !!!! $stack" + set operator ! + } default { + if {$operator eq ""} { + if {$OID ne "null"} { + set command [list [::pp::Obj${OID}::_apimanager get_api_default] $default_method] + #set command ::p::${OID}::$default_method + } else { + set command [list $default_method $object_command] + } + set stack $command + set operator , + lappend stack $word + } else { + #no stack - so we don't expect to be in argprotect mode already. + if {[string match "-*" $word]} { + #argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument) + set operator_prev $operator + set operator "argprotect" + lappend stack $word + } else { + lappend stack $word + } + + } + } + incr w + } + } + } ;#end while + + + #process final word outside of loop + #assert $w == $wordcount + #trailing operators or last argument + if {!$finished_args} { + set word [lindex $args [expr {$w -1}]] + if {$operator eq "argprotect"} { + set operator $operator_prev + set operator_prev "" + + lappend stack $word + incr w + } else { + switch -- $word {.} { + if {![llength $stack]} { + #set stack [list "_result_" [::p::internals::ref_to_object $_InvocantData_]] + #yieldto return [::p::internals::ref_to_object $_InvocantData_] + yieldto return [my Ref_to_object $_InvocantData_] + error "assert: never gets here" + + } else { + #puts stdout "==== $stack" + #assert - whenever _InvocantData_ changed in this proc - we have updated the $OID variable + #yieldto return [::p::internals::ref_to_stack $OID $_InvocantData_ $stack] + yieldto return [my Ref_to_stack $OID $_InvocantData_ $stack] + error "assert: never gets here" + } + set operator . + } {..} { + #trailing .. after chained call e.g >x . item 0 .. + #puts stdout "$$$$$$$$$$$$ [list 0 $_InvocantData_ {*}$stack] $$$$" + #set reduction [list 0 $_InvocantData_ {*}$stack] + yieldto return [yield [list final 0 _ID_ $_InvocantData_ stack {*}$stack mechanism "reduce"]] + } {#} { + #yieldto tailcall error "Missing argument. Must supply apiname" + error "Missing argument. Must supply apiname" + #set unsupported 1 + } {,} { + set unsupported 1 + } {=} { + set unsupported 1 + } {&} { + set unsupported 1 + } {@} { + set unsupported 1 + } {--} { + #set reduction [list final 0 _ID_ $_InvocantData_ stack $stack[set stack [list]]] + #puts stdout " -> -> -> about to call yield $reduction <- <- <-" + set _InvocantData_ [yield [list final 0 _ID_ $_InvocantData_ stack $stack[set stack [list]] mechanism "reduce"] ] + #set OID [::pattern::get_oid $_InvocantData_] + #set OID [lindex [dict get $_InvocantData_ i this] 0 0] ;#get_oid + set OID [dict get [lindex [dict get $_InvocantData_ i this] 0] id] ;#get_oid + + if {$OID ne "null"} { + set invocantrecord [set ::pp::Obj${OID}::_meta::o_invocantrecord] ;#Do not use upvar here! + } else { + set invocantrecord [lindex [dict get $_InvocantData_ i this] 0] + } + #yieldto return $MAP + yieldto return $invocantrecord + } {!} { + set mechanism "reduce" ;#reduce the existing stack + + #return [list final 1 _ID_ $_InvocantData_ stack $stack mechanism $mechanism] + + set _InvocantData_ [yield [list final 0 _ID_ $_InvocantData_ stack $stack[set stack [list]] mechanism "reduce"]] + #set OID [::pattern::get_oid $_InvocantData_] + #set OID [lindex [dict get $_InvocantData_ i this] 0 0] ;#get_oid + set OID [dict get [lindex [dict get $_InvocantData_ i this] 0] id] ;#get_oid + + if {$OID ne "null"} { + set invocantrecord [set ::pp::Obj${OID}::_meta::o_invocantrecord] ;#Do not use upvar here! + } else { + set invocantrecord [lindex [dict get $_InvocantData_ i this] 0] + } + #lassign $invocantrecord OID alias default_method object_command + dict update invocantrecord id OID defaultmethod default_method object object_command {} + set command $object_command + #set stack [list "_exec_" $command] + set stack [list $command] + set mechanism "execute" + + set operator ! + } default { + if {$operator eq ""} { + #error "untested branch" + #lassign $invocantrecord OID alias default_method object_command + dict update invocantrecord id OID defaultmethod default_method object object_command {} + #set command ::p::${OID}::item + #set command ::p::${OID}::$default_method + set command [list [::pp::Obj${OID}::_apimanager get_api_default] $default_method] + + lappend stack $command + set operator , + } + #do not look for argprotect items here (e.g -option) as the final word can't be an argprotector anyway. + lappend stack $word + } + if {$unsupported} { + set unsupported 0 + error "trailing '$word' not supported" + } + #if {$operator eq ","} { + # incr wordcount 2 + # set stack [linsert $stack end-1 . item] + # + #} + incr w + } + } + + #final = 1 + puts stderr ">>>jaws [info coroutine] final return value: [list final 1 _ID_ $_InvocantData_ stack $stack mechanism $mechanism]" + + return [list final 1 _ID_ $_InvocantData_ stack $stack mechanism $mechanism] +} + + + + + diff --git a/src/vendormodules/patternpredator1-1.0.tm b/src/vendormodules/patternpredator1-1.0.tm new file mode 100644 index 00000000..067c5540 --- /dev/null +++ b/src/vendormodules/patternpredator1-1.0.tm @@ -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 + } +}] diff --git a/src/vendormodules/patternpredator1-1.2.4.tm b/src/vendormodules/patternpredator1-1.2.4.tm new file mode 100644 index 00000000..cc6f9b51 --- /dev/null +++ b/src/vendormodules/patternpredator1-1.2.4.tm @@ -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 + } +}] diff --git a/src/vendormodules/treeobj-1.3.1.tm b/src/vendormodules/treeobj-1.3.1.tm new file mode 100644 index 00000000..b3e37eea Binary files /dev/null and b/src/vendormodules/treeobj-1.3.1.tm differ