core/implementation/Object.tcl


@implementation Object {

  + new {} {
      return [[$self alloc] init]
    }

  + alloc {} {
      return [@newInstanceFromClass $self]
    }

  - init {} {
      set refCount 1
    }

  - copy {} {
      set _newInstance [[$self class] new]
      upvar #0 @[$self class] _Class
      upvar #0 @${_newInstance} _NewInstance
      foreach _var $_Class(instance,variables) {
        if [regexp {^@} $_var] {
          global @${_newInstance}@{_$var}
          array set @${_newInstance}@{_$var} [array get $_var]
        } else {
          set _NewInstance($_var) [set $_var]
        }
      }
      return $_newInstance
    }

  - refCount {} {
      return $refCount
    }

  - retain {} {
      incr refCount
    }

  - release {} {
      incr refCount -1
      if {$refCount <= 0} {
        return [$self dealloc]
      }
    }

  - autorelease {} {
      if [string length [set _level [@getCallerLevel]]] {
        if {![uplevel #${_level} info exists AutoReleasePool]} {
          return -code error "must first create an AutoReleasePool object \
            before to invoke autorelease msg!"
        }
        set _cmd "\$AutoReleasePool add: $self"
        uplevel #${_level} $_cmd
      } else {
        return -code error "couldn't find caller level ([info level 0])"
      }
    }

  + self {} {
      return $self
    }

  - self {} {
      return $self
    }

  + class {} {
      return $self
    }

  - class {} {
      upvar #0 @$self _SELF
      return $_SELF(class)
    }

  + superclass {} {
      upvar #0 @$self _CLASS
      return $_CLASS(superclass)
    }

  - superclass {} {
      return [[$self class] superclass]
    }

  + isMemberOfClass: aClass {
      if {![string compare $aClass [$self class]]} {
        return 1
      } else {
        return 0
      }
    }

  - isMemberOfClass: aClass {
      return [[$self class] isMemberOfClass: $aClass]
    }

  + isKindOfClass: aClass {
      set _superclass [$self superclass]
      while [string length $_superclass] {
        if {![string compare $_superclass $aClass]} {
          return 1
        } else {
          set _superclass [$_superclass superclass]
          if {![string length $_superclass]} { return 0 }
        }
      }
      return 0
    }

  - isKindOfClass: aClass {
      return [[$self class] isKindOfClass: $aClass]
    }

  + respondsTo: aSelector {
      upvar #0 @$self _SELF
      if [_SELF(class,selectors) contains: $aSelector] {
        return 1
      } else {
        return 0
      }
    }

  - respondsTo: aSelector {
      upvar #0 @[$self class] _CLASS
      if [_CLASS(instance,selectors) contains: $aSelector] {
        return 1
      } else {
        return 0
      }
    }

  + conformsTo: aProtocol {
      upvar #0 @$self _SELF
      if [_SELF(protocols) contains: $aProtocol] {
        return 1
      } else {
        return 0
      }
    }

  - conformsTo: aProtocol {
      return [[$self class] conformsTo: $aProtocol]
    }

  + forwardInvocation: aMessage {
      return [$self doesNotRecognize: [@selector $aMessage]]
    }

  - forwardInvocation: aMessage {
      return [$self doesNotRecognize: [@selector $aMessage]]
    }
 
  + doesNotRecognize: aSelector {
      return [$self error: \
        "$self cannot respond to \"$aSelector\" selector !"]
    }

  - doesNotRecognize: aSelector {
      return [$self error: \
        "$self cannot respond to \"$aSelector\" selector !"]
    }

  + error: aString {
      return -code error $aString
    }

  - error: aString {
      return -code error $aString
    }

  + notImplemented: aSelector {
      return [$self error: \
        "\"$aSelector\" selector is not yet implemented !"]
    }

  - notImplemented: aSelector {
      return [$self error: \
        "\"$aSelector\" selector is not yet implemented !"]
    }

  - dealloc {} {
      upvar #0 @${self} _SELF
      unset _SELF
      rename $self ""
      return 
    }

}