You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
1940 lines
81 KiB
1940 lines
81 KiB
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] |
|
} |
|
|
|
|
|
|
|
|
|
|
|
|