Contributed by Scott Anderson
Polymorphic XBase! Well, FoxPro 2.5a to be precise...
The class defs, method vtable, object defs, and object slot values are implemented in tables.
FoxPro uses the & character to do macro substitution. The procedure call syntax is a little wierd:
do procname with arg1, arg2, ...
It's different from the function call syntax:
x = funcname(arg1, arg2, ...)
I used macro substitution to accomplish the dynamic dispatch:
do &methodname with &args
Other notes:
&& FoxPro 2.x shapes example
&& November 9, 1999 - Scott Anderson
&& set up the tables
do mktables
&& set up the class definitions
do defclasses
&& put the shapes in an array
dimension aShapes[2]
aShapes[1] = createobj('rect1', 'rectangle', '10, 20, 5, 6')
aShapes[2] = createobj('circ1', 'circle', '15, 25, 8')
&& loop through and display the magic of polymorphism in FoxPro
for i = 1 to 2
do callmethod with aShapes[i], 'draw', ''
do callmethod with aShapes[i], 'r-move-to', '100, 100'
do callmethod with aShapes[i], 'draw', ''
endfor
&& call a rectangle-specific function
r = createobj('rect2', 'rectangle', '0, 0, 15, 15')
do callmethod with r, 'set-width', '30'
do callmethod with r, 'draw', ''
&& exit the program
cancel
&&&&&&&&&&&&&&&&&&&&&&&&&&&
&& define the class methods
&& create a shape
procedure c_shape
parameter obj, x, y
&& set the origin
do setslot with obj, 'x', str(x)
do setslot with obj, 'y', str(y)
return
&& move a shape to an absolute position
procedure c_moveto
parameter obj, newx, newy
do setslot with obj, 'x', newx
do setslot with obj, 'y', newy
return
&& move a shape relative to its origin
procedure s_rmoveto
parameter obj, delx, dely
&& note that the slot values are stored as strings
x = val(getslot(obj, 'x'))
y = val(getslot(obj, 'y'))
do setslot with obj, 'x', str(x + delx)
do setslot with obj, 'y', str(y + dely)
return
&& create a rectangle
procedure c_rect
parameter obj, x, y, w, h
&& call the shape constructor first
do c_shape with obj, x, y
&& set the width and height
do setslot with obj, 'width', str(w)
do setslot with obj, 'height', str(h)
return
&& set a rectangle width
procedure s_recw
parameter obj, neww
do setslot with obj, 'width', str(neww)
return
&& set a rectangle height
procedure s_rech
parameter obj, newh
do setslot with obj, 'height', str(newh)
return
&& draw a rectangle
procedure o_recdraw
parameter obj
x = alltrim(getslot(obj, 'x'))
y = alltrim(getslot(obj, 'y'))
w = alltrim(getslot(obj, 'width'))
h = alltrim(getslot(obj, 'height'))
? 'Drawing a rectangle at: (' + x + ', ' + y + '), width: ' + w + ',
height: ' + h
return
&& create a circle
procedure c_circle
parameter obj, x, y, r
&& call the shape constructor first
do c_shape with obj, x, y
&& set the radius
do setslot with obj, 'radius', str(r)
return
&& set a circle radius
procedure s_circr
parameter obj, newr
do setslot with obj, 'radius', newr
return
&& draw a circle
procedure o_circdraw
parameter obj
x = alltrim(getslot(obj, 'x'))
y = alltrim(getslot(obj, 'y'))
r = alltrim(getslot(obj, 'radius'))
? 'Drawing a circle at: (' + x + ', ' + y + '), radius: ' + r
return
&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
&& everything below implements the class framework
&& set a slot on an instance
procedure setslot
parameter obj, slotname, newval
select objslots
replace slotval with m.newval all for name = m.obj .and. slot =
m.slotname
return
&& get a slot value from an instance
function getslot
parameter obj, slotname
select slotval from objslots into array aSlot where name = m.obj .and.
slot = m.slotname
return aSlot[1]
&& get a method name by class
function getcmethod
parameter cname, methname
&& look the class and method up in the vtable
select clsmeth
locate for name = cname .and. method = methname
if found() then
mname = vlink
else
? 'Unknown class: ' + cname
cancel
endif
return mname
&& get a method name by object
function getomethod
parameter oname, methname
&& first get the class of the object
select objects
locate for name = oname
if found() then
cname = class
else
? 'Unknown object: ' + oname
cancel
endif
&& now get the method from the class vtable
mname = getcmethod(class, methname)
return mname
&& call a method on a class
procedure callmethod
parameter oname, methname, args
&& get the method name
mname = getomethod(oname, methname)
&& if there are args to the method, use them, otherwise not
&& the & is a macro substitution, allowing dynamic function calls
if len(args) > 0 then
do &mname with oname, &args
else
do &mname with oname
endif
return
&& create a new instance of a class
function createobj
parameter oname, cname, args
&& create the object
insert into objects (name, class) values (oname, cname)
&& set up the default values first
select m.oname, slot, defval from clsslot into array aDefault where
name = cname
insert into objslots from array aDefault
&& get the creation method for the class
&& don't use callmethod since it requires an instance
mname = getcmethod(cname, 'create')
&& if there are args to the create method, use them, otherwise not
&& the & is a macro substitution, allowing dynamic function calls
if len(args) > 0 then
do &mname with oname, &args
else
do &mname with oname
endif
return oname
&& add a slot definition to a class
procedure addslot
parameter cname, slotname, dval
insert into clsslot (name, slot, defval) values (cname, slotname, dval)
return
&& add a method to a class in the vtable
procedure addmethod
parameter cname, methname, vlinkn
insert into clsmeth (name, method, vlink) values (cname, methname,
vlinkn)
return
&& create a new class
procedure newclass
parameter cname, inhname
&& make sure we don't already have one
select classes
locate for name = cname
if found() then
? 'Class ' + cname + 'is already defined.'
cancel
endif
&& define the class
insert into classes (name, inherits) values (cname, inhname)
&& if it inherits another class, copy the slot and method defs
if len(inhname) > 0 then
select m.cname, method, vlink from clsmeth into array aInherit where
name = inhname .and. !(method = 'create')
insert into clsmeth from array aInherit
select m.cname, slot, defval from clsslot into array aInherit where
name = inhname
insert into clsslot from array aInherit
endif
return
&& make sure we have our tables set
procedure mktables
set safety off
close all
if file('classes.dbf')
delete file 'classes.dbf'
endif
create table classes (name c(20), inherits c(10))
use classes in 1 exclusive
if file('clsmeth.dbf')
delete file 'clsmeth.dbf'
endif
create table clsmeth (name c(20), method c(10), vlink c(10))
use clsmeth in 2 exclusive
if file('clsslot.dbf')
delete file 'clsslot.dbf'
endif
create table clsslot (name c(20), slot c(10), defval c(20))
use clsslot in 3 exclusive
if file('objects.dbf')
delete file 'objects.dbf'
endif
create table objects (name c(20), class c(20))
use objects in 4 exclusive
if file('objslots.dbf')
delete file 'objslots.dbf'
endif
create table objslots (name c(20), slot c(10), slotval c(20))
use objslots in 5 exclusive
return
procedure defclasses
&& define the base shape class
do newclass with 'shape', ''
&& give it some slots with defaults
do addslot with 'shape', 'x', '0'
do addslot with 'shape', 'y', '0'
&& notes on my naming convention:
&& c_ is a create method
&& s_ is a setter-type method
&& o_ is an output method
&& give it a create method and some move methods
do addmethod with 'shape', 'create', 'c_shape'
do addmethod with 'shape', 'move-to', 's_moveto'
do addmethod with 'shape', 'r-move-to', 's_rmoveto'
&& define the rectangle class as a subclass of shape
do newclass with 'rectangle', 'shape'
do addslot with 'rectangle', 'width', '0'
do addslot with 'rectangle', 'height', '0'
do addmethod with 'rectangle', 'create', 'c_rect'
do addmethod with 'rectangle', 'set-width', 's_recw'
do addmethod with 'rectangle', 'set-height', 's_rech'
do addmethod with 'rectangle', 'draw', 'o_recdraw'
&& define the circle class as a subclass of shape
do newclass with 'circle', 'shape'
do addslot with 'circle', 'radius', '0'
do addmethod with 'circle', 'create', 'c_circle'
do addmethod with 'circle', 'set-radius', 's_circr'
do addmethod with 'circle', 'draw', 'o_circdraw'
return