There seems to be a mild interest in this article (judging from the
response to my offer to e-mail to folks), so I thought that I would
re-post the article in its entirety.
BTW, I am _NOT_ the original poster of the article! (Credit where
credit is due.) Mr. Peters is the author and his snail-mail address is
in the body of the article.
********************** Original Article Follows **********************
This is a long post, because it includes sample code.
I don't know how many people out there use Chris Heilman's Pocket Forth,
but I have found it to be an invaluable learning tool for learning forth on
the Macintosh. My heartfelt thanks goes out to him for a well put-together,
beautifully documented shareware forth for the Macintosh.
This sample code basically adds object-oriented extensions to Pocket Forth.
(I don't think this is re-inventing the wheel, although I admit that I
wanted to see if it were possible to actually "roll my own" OO system.) I
used code from the "Brodie" Starting Forth extensions file in the Pocket
Forth package (and commented where I did so.)
I believe that the syntax for creating and declaring objects and classes is
commented/demonstrated adequately enough to be self-explanatory. Cutting
and pasting should work fine to demonstrate this sample program.
A few words on my data stack notation are in order. Words that will be
parsed from the input stream (by create, for example) are indicated by a
word following a Left parenthesis prior to the first parenthesis for the
data stack diagram, ie:
: defining.word ( parsedWord ( before -- after )
Otherwise, I think it's pretty standard.
I am looking for comments, suggestions & discussion. Has anybody else
attempted to implement an object-oriented model in Forth?
Unfortunately, I don't have email, but I read this newsgroup regularly and
I can be reached via US mail at
Randolph M. Peters
Medical Clinic Suite C,
3rd Floor Silverstein
Hosp of the Univ of PA
34th and Spruce Sts.
Philadelphia, PA 19104
Standard disclaimer.
\ Object-Oriented Extensions to Pocket Forth
\ Randolph M. Peters
\
forget task : task ;
room
28 +md constant echo
: on ( addr -- ) -1 swap ! ;
: off ( addr -- ) 0 swap ! ;
echo off
2 constant bytes/cell
: cells ( n -- n' ) bytes/cell * ;
: +cell ( n -- n' ) 1 cells + ;
: -cell ( n -- n' ) 1 cells - ;
: bytes ( n -- n ) ;
: zero ( addr -- ) off ;
\ This code is from Brodie extensions, included with Pocket Forth.
\ Originally by Chris Heilman, except as where otherwise noted.
\ Display the contents of the stack from bottom to top.
: .S ( n[m] .. n[1] -- n[m] .. n[1] )
depth ?dup IF negate -1 DO \ contributed by
-1 +LOOP ELSE ." Empty" THEN ; \ * Thanks! *
: .( 41 word here count type ; \ interactive printing utility
: <> ( n1 n2 -- flag ) = 0= ; \ true if n1 and n2 are not the same
0 constant FALSE
-1 constant TRUE
: RECURSE ( -- ) latest 6 + compile ; immediate
\ Brodie extensions code ends here
: stack ( n "name" -- ) \ make space for n items
create 0 , dup , cells allot \ #items, max#items, data
does> ( -- addr ) 2 cells + ; \ data space base addr
\ stack parameter access words
: <items> ( stack -- addr ) 2 cells - ; \ var #items
: +item ( stack -- ) <items> inc ; \ +1 item
: -item ( stack -- ) <items> dec ; \ -1 item
\ stack error checking words
: ?empty ( stack -- boolean ) items -1 = ;
: ?full ( stack -- boolean ) dup items swap cap = ;
: ?over ( stack -- t|f ) \ stack error checking routine
?full if cr ." stack full" abort then ;
: ?under ( stack -- t|f ) \ stack error checking routine
?empty if cr ." stack empty" abort then ;
\ the slot where the next item pushed will go
: <top> ( stack -- addr ) dup items cells + ;
\ stack manipulation words
\ (the only words the user has to see)
\ stack ( n "name" -- ) ... as above
: push ( n stack -- ) dup ?over swap over <top> ! +item ;
: pop ( stack -- n ) dup ?under dup top swap -item ;
30 constant stksize stksize dup dup
stack class.stack
stack message.stack
stack object.stack
: methods.table ( class -- methods.table )
: #methods ( class -- #methods )
: ancestor ( class -- superclass | 0 )
: nth.method ( n method.table -- table.entry )
else ." method selector out of range." abort then ;
: bad.message ( object -- )
swap cr ." Unknown message " message.stack top .
." passed to object " object.stack top .
." of class " class.stack top . abort ;
: nth.method.table.entry
the.class methods.table nth.method ;
: ((search.method.table))
1 swap do r
-1 +loop ;
: (search.method.table) ( false -- token true | false )
the.class #methods ?dup if ((search.method.table)) then ;
: find.method ( class message -- class token true | false )
<msg> ! <class> ! the.class if
found off (search.method.table)
?found if else the.class ancestor the.msg recurse then
else false then ;
: class ( object -- class )
\ returns the class of which object is an instance
: send ( ... message -- ... )
message.stack push class.stack top message.stack top
find.method if execute else bad.message then
message.stack pop drop class.stack pop drop
object.stack pop drop ;
: self ( -- )
object.stack top object.stack push
class.stack top class.stack push ;
: message \ defining word
\ name will send message n to object class
\ compile: ( name ( n -- )
\ runtime: ( ... -- ... )
: class.size ( class -- n )
: new.object \ defining word
\ compile: ( objName ( class -- )
\ runtime: ( -- object class )
create dup , class.size allot
: super ( -- )
class.stack pop ancestor class.stack push ;
variable <ancestor>
variable <methods>
variable <size>
variable <class.compilation>
: new.class \ begin class compilation
\ compile: ( superclass|0 -- )
\ runtime: ( -- newClass )
<class.compilation> on create dup ,
<ancestor> ! here <methods> ! 0 , here <size> ! 0 , ;
: end.class \ end class compilation
<class.compilation> off ;
: structure: ( -- initialSize ) \ begin structure compilation
: ;structure ( -- ) \ end structure compilation
: ivar \ defining word
\ compile: ( ivarName ( strSize ivarSize -- newStrSize )
\ runtime: ( -- addr )
create over , +
: methods: ( -- 0 ) \ begin method compilation
0 ;
: m: \ compiles a method as headerless code, push token
\ compile: ( n msgId -- msgId addr n+1 )
swap here swap 1 + [ ' ] compile ] ;
: ;methods ( id1 addr1 ...idN addrN N -- )
\ compile methods table
0 do swap , , loop r> drop ;
page room - .( this package takes up ) . .( bytes.)
1 message >>new
2 message >>discard
3 message >>init
4 message >>free
0 new.class root
structure:
0 ivar >>base.addr
;structure
methods:
1 m: cr ." NEW" self >>init ;
2 m: self >>free cr ." DISCARD" ;
3 m: cr ." INIT" ;
4 m: cr ." FREE" ;
;methods
end.class
\ Here are some sample classes and objects, showing
\ how they are written and used.
10 message >>describe
root new.class planet
structure:
1 cells ivar >>name
;structure
methods:
3 m: self super >>init cr ." PLANET INIT" ;
4 m: cr ." PLANET FREE" self super >>free ;
;methods
end.class
planet new.class ringed.planet
structure:
1 cells ivar >>#rings
;structure
methods:
3 m: self super >>init cr ." RINGED PLANET INIT" ;
4 m: cr ." RINGED PLANET FREE" self super >>free ;
." rings." ;
;methods
end.class
: ," ( quote-delimited-string" ( -- addr ) \ string -> dictionary
echo on
planet new.object mars
mars >>new ," Mars" mars >>name !
ringed.planet new.object saturn
saturn >>new ," Saturn" saturn >>name ! 4 saturn >>#rings !
mars >>describe cr saturn >>describe
--
/ ------------------------------------------------------------------------ \
/ Mark Flacy "There's a lot to be said for a blow to the head" \
/ "I guess ya had to be there." - Me \