\ Object Orienting Pocket Forth (23/296) \ Reply to (R Peters)[1] \ \ OBJECT ORIENTING POCKET FORTH \ \ Copyright (c) 1994 Randolph M. Peters \ \ This library is free software; you can redistribute it and/or modify it \ under the terms of the GNU Lesser General Public License as published by \ the Free Software Foundation; either version 2.1 of the License, or (at \ your option) any later version. \ \ This library is distributed in the hope that it will be useful, but \ WITHOUT ANY WARRANTY; without even the implied warranty of \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser \ General Public License for more details. \ \ You should have received a copy of the GNU Lesser General Public License \ along with this library; if not, write to the Free Software Foundation, \ Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. \ \ \ 1 Jun 1994 21:34:13 GMT \ University of Pennsylvania \ \ Newsgroups: comp.lang.forth[2] \ \ 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? \ \ Randolph M. Peters, M.D. \ West Mifflin Primary Care Center \ 1907 Lebanon Church Road \ West Mifflin, PA 15122 \ (412) 650-2370 \ qwerty1965@aol.com \ June, 2000 \ 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 ) ; : inc ( addr -- ) dup @ 1+ swap ! ; : dec ( addr -- ) dup @ 1- swap ! ; : 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 s0@ r 2* s>d d+ l@ . \ Jesus Consuegra -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 : ( stack -- addr ) 2 cells - ; \ var #items : items ( stack -- n ) @ ; \ # of items : +item ( stack -- ) inc ; \ +1 item : -item ( stack -- ) dec ; \ -1 item : cap ( stack -- n ) -cell @ ; \ max # of items \ 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 : ( stack -- addr ) dup items cells + ; \ stack manipulation words \ (the only words the user has to see) \ stack ( n "name" -- ) ... as above : top ( stack -- n ) dup ?under -cell @ ; : push ( n stack -- ) dup ?over swap over ! +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 ) 2 + @ ; : #methods ( class -- #methods ) methods.table @ ; : ancestor ( class -- superclass | 0 ) methods.table +cell @ ; : nth.method ( n method.table -- table.entry ) 2dup @ 1 + < if swap 2 * cells + 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 ; variable : the.class @ ; variable : the.msg @ ; variable found : ?found found @ ; : nth.method.table.entry the.class methods.table nth.method ; : ((search.method.table)) 1 swap do r nth.method.table.entry dup @ the.msg = if found on +cell @ true leave else drop then -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 ) ! ! 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 -cell @ ; : 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: ( ... -- ... ) create , does> @ send ; : class.size ( class -- n ) ?dup if 2 cells + @ else 0 then ; : new.object \ defining word \ compile: ( objName ( class -- ) \ runtime: ( -- object class ) create dup , class.size allot does> dup @ class.stack push +cell object.stack push ; : super ( -- ) class.stack pop ancestor class.stack push ; variable variable variable variable : new.class \ begin class compilation \ compile: ( superclass|0 -- ) \ runtime: ( -- newClass ) on create dup , ! here ! 0 , here ! 0 , ; : end.class \ end class compilation off ; : structure: ( -- initialSize ) \ begin structure compilation @ class.size ; : ;structure ( -- ) \ end structure compilation @ ! ; : ivar \ defining word \ compile: ( ivarName ( strSize ivarSize -- newStrSize ) \ runtime: ( -- addr ) create over , + does> @ self object.stack pop + class.stack pop drop ; : 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 here dup >r @ ! dup , @ , 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 ; 10 m: cr ." This planet is named " self >>name @ count type ; ;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 ; 10 m: self super >>describe cr ." It has " self >>#rings @ . ." rings." ; ;methods end.class : ," ( quote-delimited-string" ( -- addr ) \ string -> dictionary here dup 34 word c@ 1 + allot ; 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