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