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 .
Download with wiki-reaper: wiki-reaper -x 55538 0 | tee cyao.tcl
# 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 }
% 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
% 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
% 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
% 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}}}
% 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
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.
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