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