Object Oriented Extensions to Pocket Forth (repost) 
Author Message
 Object Oriented Extensions to Pocket Forth (repost)

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                \



Mon, 27 Jan 1997 09:04:47 GMT  
 Object Oriented Extensions to Pocket Forth (repost)
I've ported (hacked?) Mr. Peter's code over to F-PC.  The required
changes were minimal.

Don't forget to remove my .sig at the end!!

\ -------- F-PC version follows here -----------------------------
\ Object-Oriented Extensions to Pocket Forth
\ Randolph M. Peters
\

\ Hacked to work with F-PC by Mark A. Flacy via:
\   changing m: to work with F-PC (see MAKEDUMMY in the F-PC source code)
\   defining ,"" and using it rather than Mr. Peter's ,"
\   renaming "root" to "_root" (yes, I could have used a vocabulary)

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 ;

: 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 = ) 0= ;
: ?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  i \ 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 )
\ was
\      swap here swap 1 +     [ ' ] compile ] ;
     swap  here  swap 1 +  [ hex e9 decimal ] literal c,
     >nest here - 2 - ,
     xhere paragraph +
     dup xdpseg !

     xdp off !csp ] ;

: ;methods ( id1 addr1 ...idN addrN N -- )
   \ compile methods table

   0 do swap , , loop ;

\ create some messages for testing

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

.( _root defined ) cr

\ 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 defined ) cr

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 ;

;methods
end.class

.( ringed planet defined ) cr

\ : ," ( quote-delimited-string" ( -- addr ) \ string -> dictionary

\ echo on

\ His ," will not work.  The one in F-PC will not either (exactly).
: ,""  here ,"  ;

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                \



Tue, 28 Jan 1997 15:11:27 GMT  
 
 [ 2 post ] 

 Relevant Pages 

1. Object oriented programming extension for forth.

2. Object Orienting Pocket Forth

3. REPOST: Questionnaire Survey on Object-Oriented Programming

4. Object-Oriented numerical library: EiffelMath (repost)

5. REPOST: Object Oriented Questionnaire Survey

6. REPOST: Questionnaire Survey on Object-Oriented Programming

7. REPOST: Object Oriented Questionnaire Survey

8. ANNOUNCEMENT: Object-Oriented Systems - new object-oriented journal

9. ANNOUNCEMENT: Object-Oriented Systems - new object-oriented journal

10. Deadline extension-CFP-OOPSLA 98 Workshop on Implementation and Application of Object Oriented Workflow Management Systems

11. ANNOUNCEMENT: Dynace Object Oriented Extension to C

12. Object Oriented Extensions to Scheme

 

 
Powered by phpBB® Forum Software