[dbohdan] 2018-09-12: Classy YAO is a variation on [JCW]'s elegant [Yet another object system] ("YAO"). It extends YAO to add classes (in this case, collections of methods and property names, default values, and restrictions without inheritance). Like YAO's objects, its objects and classes are [transparent] values. It has support for basic runtime checking of value types . ** Code ** ====== # Classy YAO, an object/record system. # Copyright (c) 2018, dbohdan. # License: MIT. package require Tcl 8.5 namespace eval cyao { variable version 0.3.1 interp alias {} ::! {} cyao::! interp alias {} ::!! {} cyao::!! interp alias {} ::self! {} cyao::self! } proc cyao::check-value-type {class field value} { if {[dict exists $class %TYPES% $field]} { set type [dict get $class %TYPES% $field] lassign $type typeName typeValues switch $typeName { any - string {} enum { if {$value ni $typeValues} { error [list value $value not in enum $typeValues] } } lambda { if {![apply $typeValues $value]} { error [list value $value fails validator $typeValues] } } default { if {![string is $type -strict $value]} { error [list value $value is not $type] } } } } } proc cyao::! {classVarName selfVarName field args} { upvar $classVarName class upvar $selfVarName me if {![dict exists $class $field]} { error [list field $field not in class $classVarName] } set contents [dict get $class $field] switch [llength $contents] { 0 - 1 { if {[llength $args] == 0} { # Get value. if {[dict exists $me $field]} { set value [dict get $me $field] } else { set value $contents } check-value-type $class $field $value return $value } elseif {[llength $args] >= 2} { error {too many arguments} } # Set value. set newValue [lindex $args 0] check-value-type $class $field $newValue dict set me $field $newValue return $newValue } 2 { # Evaluate method. lassign $contents params body set preamble [list upvar $selfVarName me] append preamble \n[list upvar $classVarName class] uplevel 1 [list apply [list $params $preamble\n$body] {*}$args] } default { error [list field contents $contents has too many words] } } } proc cyao::define-class definiton { set class {} foreach {type field contents} $definiton { dict set class $field $contents if {$type ne {method}} { dict set class %TYPES% $field $type } } return $class } proc cyao::with-classes {mapping script} { upvar 1 %CLASSES% classes dict for {class varName} $mapping { dict set classes $varName $class } try { uplevel 1 $script } finally { dict for {class _} $mapping { dict unset classes $varName } } } proc cyao::!! {selfVarName field args} { upvar 1 %CLASSES% classes if {![info exists classes] || ![dict exists $classes $selfVarName]} { error [list do not know class of $selfVarName] } uplevel 1 [list [namespace current]::! \ [dict get $classes $selfVarName] \ $selfVarName \ $field \ {*}$args] } proc cyao::self! {field args} { uplevel 1 [list [namespace current]::! class me $field {*}$args] } namespace eval cyao::test { namespace path [namespace parent] variable clsCounter { i 0 incr {{{n 1}} { self! i [expr { [self! i] + $n }] }} } variable clsCheckedCounter [define-class { integer i 0 method set {n { self! i $n }} method incr {{{n 1}} { self! i [expr { [self! i] + $n }] }} }] variable clsCheckedList [define-class { any label {} list data {} }] } proc cyao::test::benchmark {{max 10000} {times 5}} { package require try proc benchmark-dict max { set counter {i 0} # Not using [dict incr] here. for {set i 0} {$i < $max} {incr i} { dict set counter i [expr {[dict get $counter i] + 1}] } } proc benchmark-counter-field {class max} { variable $class set counter {} for {set i 0} {$i < $max} {incr i} { ! $class counter i [expr {[! $class counter i] + 1}] } } proc benchmark-counter-field-!! {class max} { variable $class set counter {} with-classes [list $class counter] { for {set i 0} {$i < $max} {incr i} { !! counter i [expr {[!! counter i] + 1}] } } } proc benchmark-counter-method {class max} { variable $class set counter {} for {set i 0} {$i < $max} {incr i} { ! $class counter incr } } proc benchmark-counter-method-!! {class max} { variable $class set counter {} with-classes [list $class counter] { for {set i 0} {$i < $max} {incr i} { !! counter incr } } } puts "Counting up to $max $times times." puts -nonewline { dict: } puts [time {benchmark-dict $max} 5] puts -nonewline { counter field: } puts [time {benchmark-counter-field clsCounter $max} $times] puts -nonewline { checked counter field: } puts [time {benchmark-counter-field clsCheckedCounter $max} $times] puts -nonewline { with-classes counter field: } puts [time {benchmark-counter-field-!! clsCounter $max} $times] puts -nonewline { with-classes checked counter field: } puts [time {benchmark-counter-field-!! clsCheckedCounter $max} $times] puts -nonewline { counter method: } puts [time {benchmark-counter-method clsCounter $max} $times] puts -nonewline { checked counter method: } puts [time {benchmark-counter-method clsCheckedCounter $max} $times] puts -nonewline { with-classes counter method: } puts [time {benchmark-counter-method-!! clsCounter $max} $times] puts -nonewline { with-classes checked counter method: } puts [time {benchmark-counter-method-!! clsCheckedCounter $max} $times] } proc cyao::test::run tests { package require tcltest package require try namespace path [list [namespace parent] ::tcltest] if {[llength $tests] > 0} { tcltest::configure -match $tests } set counterSetupAndCleanup [list \ -setup { variable clsCounter variable clsCheckedCounter set counter {} set result {} } \ -cleanup { unset counter unset result } \ ] set checkedListSetupAndCleanup [list \ -setup { variable clsCheckedList set checkedList {} set result {} } \ -cleanup { unset checkedList unset result } \ ] test default-values-1.1 {} {*}$counterSetupAndCleanup -body { ! clsCounter counter i } -result 0 test default-values-1.2 {} {*}$counterSetupAndCleanup -body { dict set clsCounter i -157 lappend result [! clsCounter counter i] dict set clsCounter i 0 lappend result [! clsCounter counter i] } -result {-157 0} test methods-1.1 {} {*}$counterSetupAndCleanup -body { lappend result [! clsCounter counter incr 1] lappend result [! clsCounter counter incr 98] dict set clsCounter i -157 lappend result [! clsCounter counter i] dict set clsCounter i 0 lappend result [! clsCounter counter i] lappend result $counter } -result {1 99 99 99 {i 99}} test object-copies-1.1 {} {*}$counterSetupAndCleanup -body { set counter {i 99} lappend result [! clsCounter counter i] set counter2 $counter ! clsCounter counter2 incr lappend result [! clsCounter counter2 i] lappend result [! clsCounter counter i] } -result {99 100 99} test checked-values-1.1 {} {*}$counterSetupAndCleanup -body { lappend result [! clsCheckedCounter counter i] lappend result [! clsCheckedCounter counter i 5] lappend result [! clsCheckedCounter counter incr] } -result {0 5 6} test checked-values-1.2 {get wrong type} {*}$counterSetupAndCleanup -body { set counter {i hello} ! clsCheckedCounter counter i } -returnCodes error -result {hello is not integer} test checked-values-1.3 {set wrong type} {*}$counterSetupAndCleanup -body { set counter {i 5} ! clsCheckedCounter counter i 3.14159 } -returnCodes error -result {3.14159 is not integer} test checked-values-2.1 {} {*}$checkedListSetupAndCleanup -body { ! clsCheckedList checkedList data {1 2 3} ! clsCheckedList checkedList data } -result {1 2 3} test checked-values-2.2 {} {*}$checkedListSetupAndCleanup -body { ! clsCheckedList checkedList data \{ } -returnCodes error -result {\{ is not list} test checked-values-2.3 {} {*}$checkedListSetupAndCleanup -body { apply {{obj cls} { ! cls obj data {foo bar baz} }} $checkedList $clsCheckedList } -result {foo bar baz} test checked-values-2.4 {} {*}$checkedListSetupAndCleanup -body { with-classes {clsCheckedList checkedList} { !! checkedList label aribrary !! checkedList label } } -result aribrary test checked-values-3.0 {enums} -cleanup { unset class object result } -body { set class [define-class { {enum {RED GREEN BLUE UNKNOWN}} color UNKNOWN }] set object {color RED} catch { ! class object color MAROON } result set result [list $result] lappend result [! class object color] ! class object color BLUE lappend result [! class object color] } -result {{MAROON not in enum {RED GREEN BLUE UNKNOWN}} RED BLUE} test checked-values-4.0 {validators} -cleanup { unset class object result } -body { set class [define-class { {lambda {y {expr {$y >= 100}}}} x 100 }] set object {x 100} catch { ! class object x 95 } result set result [list $result] lappend result [! class object x] ! class object x 1000 lappend result [! class object x] } -result {{95 fails validator {y {expr {$y >= 100}}}} 100 1000} test with-classes-1.1 {} {*}$counterSetupAndCleanup -body { with-classes {clsCounter counter} { lappend result [!! counter i] !! counter incr lappend result [!! counter i] !! counter i 108 lappend result [!! counter i] } } -result {0 1 108} set success [expr {$tcltest::numTests(Failed) == 0}] tcltest::cleanupTests return $success } proc cyao::test::main argv { set argv [lassign $argv verb] if {$verb eq {benchmark}} { benchmark {*}$argv } elseif {$verb eq {test}} { # Prevent tcltest from processing the command line. set ::argv {} if {![run $argv]} { exit 1 } } else { set file [file tail [info script]] puts stderr "usage: $file test \[test1 test2 ...\]" puts stderr " $file benchmark \[max \[times\]\]" if {$verb in {help -h -help --help /?}} { exit 0 } exit 1 } } # If this is the main script... if {[info exists argv0] && ([file tail [info script]] eq [file tail $argv0])} { cyao::test::main $argv } ====== ** Examples ** *** Property *** ====== % set foo {color {} size 0 type {}} % set obj1 {color red size 10 type apple} % ! foo obj1 color red % ! foo obj1 color #00ff33 #00ff33 % ! foo obj1 weather raining field weather not in class foo ====== *** Method *** ====== % set bar { factor 10 times {x { expr {$x * [self! factor] } }} } % set obj2 {} % ! bar obj2 factor 2 % list $obj2 {factor 2} % ! bar obj2 times 123 246 ====== *** Counter *** ====== % set TCounter { i 0 incr {{{n 1}} { self! i [expr { [self! i] + $n }] }} } % set counter {} % ! TCounter counter incr 1 % ! TCounter counter incr 2 % set copy $counter i 2 % ! TCounter counter incr 98 100 % ! TCounter copy incr 3 ====== *** Checked propery *** ====== % set class [cyao::define-class { {enum {green orange red}} color {} integer size 0 {enum {apple orange pear}} type {} }] % set obj1 {color red size 10 type apple} % ! class obj1 color red % ! class obj1 color blue value blue not in enum {green orange red} % set class2 [cyao::define-class { {lambda {t {expr {$t >= 0}}}} time 0 }] % set obj2 {time -3576} % ! class2 obj2 time value -3576 fails validator {t {expr {$t >= 0}}} ====== *** `!!` shortcut *** ====== % set TCounter { i 0 incr {{{n 1}} { self! i [expr { [self! i] + $n }] }} } % set counter {} % set %CLASSES% {counter TCounter copy TCounter} % !! counter incr 1 % !! counter incr 2 % set copy $counter i 2 % !! copy incr 3 ====== ** Benchmark results ** Because its objects are values and not namespaces, CYAO is much slower than [TclOO] or [snit]. However, it is only about two times slower than YAO. ======none Counting up to 10000 5 times. dict: 2703.8 microseconds per iteration counter field: 69268.6 microseconds per iteration checked counter field: 115274.8 microseconds per iteration with-classes counter field: 139264.0 microseconds per iteration with-classes checked counter field: 190302.2 microseconds per iteration counter method: 677381.2 microseconds per iteration checked counter method: 775976.2 microseconds per iteration with-classes counter method: 949686.2 microseconds per iteration with-classes checked counter method: 1037058.0 microseconds per iteration ====== <> Object Orientation