Binary data and set. & other things

Parag Patel parag at hpsdeb.sde.hp.com
Fri May 31 18:14:22 UTC 1991


I'm interested in your OO extensions and would like to be on your
mailing list.  I'm "Parag Patel" <parag at sde.hp.com>.  Thanks!

Just for fun, a while ago I had built a primitive class mechanism for
TCL entirely written in TCL!  Here it is to add to your "truly
deranged" archives.

These files work with the Tcl 4.0 release as I use a lot of the 4.0
functions like incr, clength, split, etc.  It could be made to work
with Tcl 5.0, but I haven't had the time to hack it yet.  Sorry!

Just source "class.eg" for the example code of how classes work.  (I
use a Tcl proc named "@" as the basic "send-object-message" routine.)


	-- Parag

---- Cut Here and feed the following to sh ----
#!/bin/sh
# This is a shell archive (produced by shar 3.49)
# To extract the files from this archive, save it to a file, remove
# everything above the "!/bin/sh" line above, and type "sh file_name".
#
# made 05/31/1991 18:10 UTC by parag at hpsdeb
# Source directory /users/parag/lib/tcl
#
# existing files will NOT be overwritten unless -c is specified
#
# This shar contains:
# length  mode       name
# ------ ---------- ------------------------------------------
#    529 -rw-r--r-- class.eg
#   3345 -rw-r--r-- class.tcl
#
# ============= class.eg ==============
if test -f 'class.eg' -a X"$1" != X"-c"; then
	echo 'x - skipping class.eg (File already exists)'
else
sed 's/^X//' << 'SHAR_EOF' > 'class.eg' &&
source class.tcl
X
# define class "Foo" with construct, destructor, and message "Get"
class Foo {value string}
cproc Foo Foo {} { echo Constructed!; cset string "<default>" }
cproc Foo ~Foo {} { echo Destructed! }
cproc Foo Get {} { return [cset string] }
X
# define class Bar derived from Foo with an addition message "Set"
class Bar:Foo {}
cproc Bar Set {s} { cset string $s }
X
# create a new Bar object - both Set and Get should be available
set foo [new Bar]
echo [@ $foo Get]
@ $foo Set NewValue
echo [@ $foo Get]
delete $foo
SHAR_EOF
chmod 0644 class.eg ||
echo 'restore of class.eg failed'
Wc_c="`wc -c < 'class.eg'`"
test 529 -eq "$Wc_c" ||
	echo 'class.eg: original size 529, current size' "$Wc_c"
fi
# ============= class.tcl ==============
if test -f 'class.tcl' -a X"$1" != X"-c"; then
	echo 'x - skipping class.tcl (File already exists)'
else
sed 's/^X//' << 'SHAR_EOF' > 'class.tcl' &&
# Prototype of Class extensions to TCL
# by Parag Patel
X
set classlist ""
set inheritlist ""
X
proc class {class vars} {
X    global classlist inheritlist
X
X    # get the inheritance info, if any
X    set inh [split : $class]
X    set class [index $inh 0]
X    set inherit ""
X    if {[length $inh] == 2} { set inherit [index $inh 1] } {
X	if {[length $inh] != 1} {
X	    error "illegal inheritance syntax for class $class"
X	}
X    }
X
X    # each elt in inheritlist in the name of the parent class
X    # - the key is the child class which is derived from the parent
X    set inheritlist($class) $inherit
X
X    # each elt in classlist is a list of its class vars
X    set classlist($class) $vars
}
X
proc cproc {class mesg arglist body} {
X    # add "this" to the arglist and define a proc "class.mesg"
X    set arglist "this $arglist"
X    proc $class.$mesg "$arglist" $body
}
X
proc cset {var args} {
X    set this [uplevel {list $this}]
X    global $this
X    if {[clength "$args"]} {
X	set ${this}($var) $args
X    } {
X	return [set ${this}($var)]
X    }
}
X
set objectid 0
proc new {class args} {
X    global classlist inheritlist objectid
X
X    # create a new object handle
X    set this "@Object_$objectid"
X    incr objectid
X
X    # the handle is also an array indexed by its class var names
X    # - thus the values for these array elts are unique for each object!
X    global $this
X
X    # initialize all the class vars to empty
X    # - we need to walk the inheritance tree to get ALL the vars
X    set clist ""
X    set inhlist ""
X    set varlist ""
X    for {set c $class} {[clength "$c"] > 0} {set c [set inheritlist($c)]} {
X	foreach {v} [set classlist($c)] {
X	    set ${this}($v) ""
X	    set varlist "$v $varlist"
X	}
X	set clist " $c$clist"
X	set inhlist "$inhlist $c"
X    }
X    set clist "$c$clist"
X
X    # these are just to make message dispatching easier in "@" below, and
X    # so that delete can call the right destructors - at the very least,
X    # "class.name" must always be available to extract everything else
X    set ${this}(class.name) $class
X    set ${this}(class.variables) "$varlist"
X    set ${this}(class.inheritance) "$inhlist"
X
X    # invoke the constructors in the correct order, deepest parent 1st
X    foreach {c} $clist {
X	if {[clength "[info procs $c.$c]"]} {
X	    if {[clength "$args"]} { @ $this $c $args } { @ $this $c }
X	}
X    }
X
X    # and return our new object's handle
X    return $this
}
X
proc delete {this} {
X    global $this
X
X    # sanity check - do not allow deleting a deleted object
X    if {![info exists ${this}(class.inheritance)]} {
X	error "no object $this exists to delete"
X    }
X
X    # call the destructors in reverse order of constructors, child 1st
X    foreach {c} [set ${this}(class.inheritance)] {
X	if {[clength "[info procs $c.~$c]"]} { @ $this ~$c }
X    }
X
X    unset $this
}
X
proc @ {this mesg args} {
X    global classlist inheritlist $this
X
X    # find a message proc following the inheritance chain
X    set procname ""
X    foreach {c} [set ${this}(class.inheritance)] {
X	set p $c.$mesg
X	if {[clength "[info procs $p]"]} { set procname $p; break }
X    }
X    if {![clength "$procname"]} { 
X	error "No message $mesg defined for class [set ${this}(class.name)]"
X    }
X
X    # invoke the message proc adding "this" to the arguments
X    if {[clength "$args"]} {
X	return [$procname $this $args]
X    } {
X	return [$procname $this]
X    }
}
SHAR_EOF
chmod 0644 class.tcl ||
echo 'restore of class.tcl failed'
Wc_c="`wc -c < 'class.tcl'`"
test 3345 -eq "$Wc_c" ||
	echo 'class.tcl: original size 3345, current size' "$Wc_c"
fi
exit 0



More information about the Self-interest mailing list