Contributed by Jim Weirich
This is an example OO system implemented in forth. Forth is a procedural language that uses postfix notation for all its operations. For example, to add 2 and 3, you would type:
2 3 +
Functions (called "words" in Forth) are defined with a colon ":" immediately followed by the name of the word. Definitions are terminated with a semi-colon ";". The following word (called addTwoAndThree will add 2 and 3 and leave the result on the stack.
: addTwoAndThree 2 3 + ;
Most data is passed on an explicit stack. Forth words take arguments from the stack and return results on the stack. Stack manipulation words (like "over" and "dup") are available.
Comments in forth begin with a "(" and end with the first ")" (remember, words are blank delimited in Forth, so the first ")" must be followed by a blank). Comments may also begin with a backslash ("\") and continue to the end of the line.
Forth is a great language for small, resource limited machines. It easily runs on my PalmPilot. It is also easy to extend, adding new words for specific applications, allowing very powerfull application specific vocabularies to be built. More information is availble on Forth from www.forth.org.
I used the GForth system available at www.forth.org
Forth has no OO features by default. But it is known as a very extensible language. If you need a feature, you just implement it (in Forth of course).
The first file below (ooforth.fs)implements the basic OO primitives for Forth. Instance variables are a sequence of cells in the object. All methods are polymorphic and expect the top argument of the stack to be the object (actually, the address of the object). The first cell of all objects is a pointer to their virtual table. The remaining cells of an object contain the instance data. Only simple single inheritance is supported.
The second file (shapes.fs) is the standard OO example that we have been using in the other OO examples.
\ OO Forth -- Jim Weirich 4/Aug/98
\ This is a (very simple) object system for Forth programs. You may
\ define instance variables and methods for a class, then create
\ variables of that class. Single inheritence is supported.
\ Declare a class using the class/endclass construction. A class may
\ containes instance variables and methods.
\
\ Example:
\ class Dog
\ ivar _age
\ method Speak
\ endclass
\
\ Dog fido
\
\ An instance variable declaration reserves one cell in the object for
\ that variable. The instance variable adds the proper offset to the
\ object base address.
\
\ Getting instance data: fido _age @
\ Storing instance data: 3 fido _age !
\
\ Methods are invoked with the address of the object at the top of the
\ stack. The body of the method should expect the object address as
\ the top argument.
\
\ Invoking a method: fido Speak
\
\ The class declaration only declares the existence of a method and
\ reserves room in the VTable. The actual method must be defined as a
\ normal Forth word (expecting the object as the top argument). To
\ establish the word as a method, use the "implements" phrase
\ immediately after the word definition.
\
\ Defining a Method:
\ : Dog::Speak ." Woof" ; implements Speak
\
\ Note: The double colon names used below (e.g. Dog::Speak) have no
\ significance to Forth. It is just a convention to reinforce the
\ notion that this particular word (Speak) belongs to the class (Dog).
\
\ Methods that are never defined will remain pure virtual.
\ ====================================================================
\ Warn that a Pure Virtual Function has been called.
: pvf ( -- )
1 abort" pure virtual called" ;
' pvf constant pvfc
\ Class Definition Structure
variable curclass \ Points to latest class definition structure
: _nvar ; \ number of variables (including base classes)
: _nmeth cell+ ; \ number of methods (including base classes)
: _vptr 2 cells + ; \ vptr
: _parent 3 cells + ; \ address of class definition for base class
\ Start a class declaration
: class ( "name" -- )
create here curclass !
0 , 0 , 0 , 0 ,
does>
curclass !
create
curclass @ _vptr @ ,
curclass @ _nvar @ cells allot ;
\ Declares the base class. Used within the class declaration before
\ any instance variable or method declarations.
: inherits ( "name" -- )
' >body
dup _nvar @ curclass @ _nvar !
dup _nmeth @ curclass @ _nmeth !
curclass @ _parent ! ;
\ Terminate the class declaration and create the VTable for the class.
: endclass ( -- )
here curclass @ _vptr !
\ initialize vtbl with pvf
curclass @ _nmeth @
0 ?do pvfc , loop
\ copy parents vtable to here, if parent exists
curclass @ _parent @
if
curclass @ _parent @ dup _vptr @ swap _nmeth @
curclass @ _vptr @ swap
cells cmove
then
;
\ Declare an instance variable. Used within a class declaration.
: ivar ( "name" -- )
create
curclass @ _nvar @ cells ,
1 curclass @ _nvar +!
does> @ + cell+ ;
\ Declare a method. Used within a class declaration.
: method ( "name" -- )
create curclass @ _nmeth @ cells ,
1 curclass @ _nmeth +!
does> @ over @ + @ execute ;
\ Declare that the immediately preceeding word is a class method
\ implementing the named method.
: implements ( "name" -- )
' >body @ curclass @ _vptr @ + lastxt swap ! ;
\ Shapes -- OO in Forth
require ooforth.fs
\ class Shape =======================================================
\ Declare the base class for shapes.
class Shape
ivar _x \ X position of shape
ivar _y \ Y position of shape
method MoveTo ( x y ) \ Move to new x,y position
method RMoveTo ( dx dy ) \ Move relative
method Draw ( ) \ Draw the shape
endclass
: Shape::MoveTo ( x y obj -- )
swap over _y ! _x !
; implements MoveTo
: Shape::RMoveTo ( dx dy obj -- )
swap over _y +! _x +!
; implements RMoveTo
\ class Rectangle ====================================================
\ Rectangle inherits from Shape, using the inherits clause. It adds
\ _width and _height instance variables and new methods for setting
\ these values. A definition of Draw is provided, making Rectangle a
\ concrete class.
class Rectangle
inherits Shape
ivar _width
ivar _height
method SetWidth ( w obj )
method SetHeight ( h obj )
endclass
: Rectange::Draw ( obj )
." Drawing a Rectangle at (" dup _x @ 0 .r
." ," dup _y @ 0 .r
." ), width " dup _width @ 0 .r
." , height " _height @ 0 .r
cr
; implements Draw
: Rectangle::SetWidth ( w obj )
_width !
; implements SetWidth
: Rectangle::SetHeight ( h obj )
_height !
; implements SetHeight
\ class Circle =======================================================
\ Circle, similar to Rectangle.
class Circle
inherits Shape
ivar _radius
method SetRadius ( r obj )
endclass
: Circle::Draw ( obj )
." Drawing a Circle at (" dup _x @ 0 .r
." ," dup _y @ 0 .r
." ), radius " _radius @ 0 .r
cr
; implements Draw
: Circle::SetRadiu ( r obj )
_radius !
; implements SetRadius
\ Main program =======================================================
\ create two shape objects and initialize their fields
Rectangle sh0 10 20 sh0 MoveTo 5 sh0 SetWidth 6 sh0 SetHeight
Circle sh1 15 25 sh1 MoveTo 8 sh1 SetRadius
\ store the shapes in a simple array
create shapes 2 cells allot
sh0 shapes ! sh1 shapes cell+ !
\ create one more stand alone rectangle
Rectangle r 0 0 r MoveTo 15 r SetWidth 15 r SetHeight
\ DoSomethingWithShape is a function that expects a shape object on
\ the stack.
: DoSomethingWithShape ( shape )
dup draw
dup 100 100 rot RMoveTo
draw
;
\ TryShape is the main program.
: TryShape
\ initialize the shapes
10 20 sh0 MoveTo 5 sh0 SetWidth 6 sh0 SetHeight
15 25 sh1 MoveTo 8 sh1 SetRadius
0 0 r MoveTo 15 r SetWidth 15 r SetHeight
\ write the output
cr
2 0 do shapes i cells + @ DoSomethingWithShape loop
30 r SetWidth
r Draw
;
Drawing a Rectangle at (10,20), width 5, height 6 Drawing a Rectangle at (110,120), width 5, height 6 Drawing a Circle at (15,25), radius 8 Drawing a Circle at (115,125), radius 8 Drawing a Rectangle at (0,0), width 30, height 15