Path: well!moon!pixar!uupsi!psinntp!rpi!usc!cs.utexas.edu!uunet!aplcomm!john
From: [email protected] (John Hayes)
Newsgroups: comp.lang.forth
Subject: FOOP
Keywords: object-oriented
Message-ID: <[email protected]>
Date: 2 Mar 92 13:39:48 GMT
Reply-To: [email protected] (John Hayes)
Organization: JHU/APL, Laurel, MD
Lines: 177

The March '92 issue of Embedded Systems Programming has an
article called "Objects for Small Systems" by myself. The
article describes an object-oriented programming system
implemented in the draft-proposed ANS Forth standard.

Unfortunately, the source code was not printed with the article.
The code is sufficiently short that I have included it in this
posting. The code requires the Core and Search Order word
sets plus some odds and ends from the Core Extensions (:NONAME
and COMPILE, ). The only area in which the code does not conform
to the standard is in being lower case; you will have to translate
to upper case before running it.

The original code is contained in two files. These are delimited
by the comments containing a "cut here" message.

Have fun.

John R. [email protected]
Applied Physics Laboratory
Johns Hopkins University

\ ------------------------------ cut here ----------------------------
\ John R. Hayes, Johns Hopkins University / Applied Physics Laboratory
\ Structure access words usage:
\structure foo\ Declare a structure
\ 3 chars: .part1\ consisting of a 3 char part,
\cell: .part2\ a one cell part,
\char: .part3\ and a one char part.
\endstructure
\
\structure foobar\ Declare another structure
\ 2 cells: .this\ consisting of two cells,
\ foo struct: .that\ and substructure
\endstructure
\
\create teststruct foobar allot\ Allocate a structure instance
\123 teststruct .that .part2 !\ and store something in it.

\ Implementation notes:
\ 1. Structure instances must be placed at an aligned address (i.e. via create)
\ 2. endstructure pads out the end of the structure. This is unnecessary

: structure\ ( --- pfa template ) Start structure declaration.
create here 0 , 0
does> @ ;\ ( addr[size] --- size )

: aus:\ ( offset size --- offset' ) Structure member compiler.
create over , +
does> @ + ;\ ( base addr[offset] --- base' ) Add member's offset to base.

: chars:\ ( template n --- template' ) Create n char member.
chars aus: ;

: char:\ ( template --- template' ) Create 1 char member.
1 chars: ;

: cells:\ ( template n --- template' ) Create n cell member.
cells >r aligned r> aus: ;

: cell:\ ( template --- template' ) Create 1 cell member.
1 cells: ;

: struct:\ ( template size --- template' ) Create member of given size.
>r aligned r> aus: ;

: endstructure\ ( pfa template --- )
aligned swap ! ;

: makestruct\ ( size --- ) allocate memory for a struct of given size
create allot ;
\ ------------------------------ cut here ----------------------------
\ Object Oriented Programming System, Version 3.1, dpANS (October, 1991)
\ John R. Hayes, Johns Hopkins University / Applied Physics Laboratory
hex

\ Structure of class
structure class-structure
cell: .parent\ pointer to parent class
cell: .vocab\ cfa of local vocabulary
cell: .size\ size (in aus) of instance region
cell: .nmsgs\ number of messages accepted by class
\ method vectors are appended here
endstructure

\ Run-time Object Management
variable current-object\ current object

: self\ ( --- object ) Copy current object to parameter stack.
current-object @ ;
: self+\ ( offset --- object+offset ) Index instance variable.
current-object @ + ;

\ Define messages accepted by a particular class hierarchy.
: messages>\ ( --- addr[nmsgs] nmsgs )
create here 0 dup ,
does> @ ;\ ( addr[nmsgs] --- nmsgs )
: msg:\ ( n --- n' ) Create message n.
create dup cells class-structure + , 1+
does>\ ( object addr[n] --- ) Call method n for given object.
current-object @ >r\ save current object
@ >r dup current-object !\ set new current object
@ r> + @ execute\ fetch vector from class and execute
r> current-object ! ;\ restore original 'current' object
: endmessages> swap ! ;

\ Define class hierarchy constructors.
variable current-class\ class currently being defined
: push-vocabs\ ( class -- ' ) Add any parent
\ wordlists to the search order on the stack then add
\ the wordlist belonging to the given class.
?dup if dup >r .parent @ recurse r> .vocab @ swap 1+ then ;

: default-method \ ( -- ) This is executed if an object receives a
\ message for which there is no defined method.
." method undefined" abort ;

: construct-class \ ( nmsgs size-of-object parent -- ) Build a class
\ data structure with the given parameters, fill with
\ null execution vectors, create naming wordlist,
\ and modify search order.
wordlist\ create wordlist
create here dup >r current-class !\ name class; record address
class-structure allot\ allocate class structure
r@ .vocab ! r@ .parent !\ fill in wordlist, parent
r@ .size ! dup r> .nmsgs !\ fill in size and number of msgs
0 do ['] default-method , loop\ fill in default methods
get-order current-class @ push-vocabs
over set-current set-order ;\ defs in new wordlist

: class>\ ( nmsgs -- ) Create a new class hiearchy.
0 0 construct-class ;

: sub-class>\ ( class -- ) Create a subclass of the given class.
\ The subclass inherits the parents' methods and instance
\ variables.
dup >r .nmsgs @ r@ .size @ r@ construct-class
r@ class-structure + current-class @ class-structure +
r> .nmsgs @ cells move ;

: end>\ ( -- ) Complete class definition by restoring search order.
get-order current-class @ begin >r nip 1- r> .parent @ dup 0= until
drop over set-current set-order ;

\ Local variables
variable to?
: to true to? ! ; immediate
: local:\ ( -- ) Create an instance variable for current class.
create current-class @ .size @ dup , cell+ current-class @ .size ! immediate
does>\ ( addr[offset] -- ) Compile fetch or store of instance.
@ cell+ postpone literal postpone self+
to? @ if postpone ! false to? !
else postpone @
then ;

\ Methods
: get-body\ ( -- x ) Look up the next word in the input stream,
\ and extract its body. It must have been 'create'd.
bl word find 0= abort" unknown message"
>body @ ;

: super\ ( -- ) Convert the next message to the self object
\ into a subroutine call.
current-class @ .parent @ get-body + @ compile, ; immediate

: method:\ ( -- addr[slot] xt colon-sys ) Define a method to
\ correspond with message indicated in input stream.
get-body current-class @ + :noname ;

: ;method\ ( addr[slot] xt colon-sys -- ) Complete compilation
\ of method.
postpone ; swap ! ; immediate

\ Storage Allocator, first pass
: new\ ( class -- object ) Allocate an object of type class.
here >r dup .size @ cell+ allot\ allot object + class pointer
r@ ! r> ;\ init class pointer