IrnBru; a Forth open, extensible object model implementation

[Alex McDonald]

The play on words of the Jolt, Cola and Soda languages led me to call
this IrnBru. The joke will be lost to all but Scots I suspect.

Having the original paper to hand will help in understanding the code,
and its possible uses. It's a delegation style of object system;
binding is late. The format is <object> <method>; objects are Forth
constants on the stack, and methods are tickable words.

I may post up an extension that supports closures, and I'm interested
in implementing traits. It's certainly a very small object system;
whether it is of use I'll find out.

((
Copyright (c) 2008 Alex McDonald.
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:

Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.

Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in
the documentation and/or other materials provided with the
distribution.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

----------------------------------------------------------------------

based on http://piumarta.com/software/cola/objmodel2.pdf

In the original Piumarta & Warth paper, symbol_intern uses objects
derived from symbolVT. The lookup is based on interning the string,
then searching for the interned symbol through an array of symbol/
method pointers in the vtable.

In this implementation, I'm using the name field address as the
symbol; it points to a counted string of the name. There are no
symbolVT or symbol strings defined. First we look it up in the intern
wordlist; if it's defined, return the symbol (actually a pointer to
the symbol string), otherwise define it and return the newly created
name.

symbol is a pointer to the string
s_symbol is the symbol string, that is ( symbol count )

As the name is also the selector for the method, that can be used to
find the specific method in an objects vtable by executing its XT;
see symbol_create for details.

Function names follow the paper. Methods are indicated with a
preceding colon as in :delegated; this isn't a requirement, but is
just syntactic sugar to make it clear that an object precedes it on
the stack.

Objects are defined using allot, rather than dynamically
allocating them; this is a refinement that could be added later. It
allows use of wordlists without assuming we know how they are
constructed or maintained.

A vtable uses a Forth wordlist to do lookups via search-wordlist. The
vtable pointer is at a negative offset as in the original paper.

bind and vtable_lookup deviate from the paper but match better the C
code on Piumarta's website. Caches and closure objects are not
implemented.

There are a number of non-ANS and Forth 200x words used; the less
obvious are:

allot&zero n -
ALLOT and zero out n chars ( 0max here over allot swap erase )

find-name c-addr u – nt | 0
As in gforth: find the name c-addr u in the current search order.
Return its nt, if found, otherwise 0.

#wordlist n - wid
Create a new, empty word list represented by wid of a given size
n. Can be replaced by wordlist.

execute-parsing ... addr u xt – ...
Make addr u the current input source, execute xt ( ... -- ... ),
then restore the previous input source.

The following words are created:

s_lookup
symbol_intern symbol_create
vtable_addmethod vtable_delegated vtable_allocate vtable_lookup
send bind _bind
vt% vt.dict vt.parent vt.vtable
vtable@ parent@
:delegated :allocate :addmethod :lookup

))

begin-structure vt%
cell-
field: vt.vtable ( vtable )
field: vt.parent ( parent object )
field: vt.dict ( ptr to dictionary )
cell+
end-structure

: dictionary ( -- addr ) ( w32f specific for small wordlists )
3 #wordlist ;

: vtable@ vt.vtable @ ; ( my vtable )
: parent@ vt.parent @ ; ( for vtables, my delegation parent )

defer bind ( forward reference )

: send ( msg object -- [results] )
tuck bind execute ;

: symbol_create ( "name" -- symbol )
create last @ dup , ( symbol )
does> ( object msgptr -- results )
@ swap send ; ( send this message to the object )

: symbol_intern ( string -- symbol )
2dup find-name ?dup if
nip nip
else
also definitions
['] symbol_create execute-parsing
previous definitions
then ;

: vtable_lookup ( symbol self -- method | 0 )
swap count ( symbol -> s_symbol )
rot vt.dict @ search-wordlist
if exit ( found in this object )
else 0 then ; ( return zero )

: vtable_allocate ( size self -- object )
align , here ( vtable, object returned )
swap allot&zero ;

: vtable_delegated ( self -- child )
align
vt% over vtable_allocate ( allocate an object -> self child )
tuck vt.parent ! ( child parent child.parent=self )
dictionary over vt.dict ! ( allocate a dictionary )
;

: vtable_addmethod ( method symbol self -- )
vt.dict @ swap-current >r ( build in self's vtable )
count ( symbol -> s_symbol )
['] alias execute-parsing ( ' xt alias "name" )
r> set-current ; ( out of vtable )

(( Now we have enough in place to construct the root vtable vtablevt
and the base object ))

0 vtable_delegated constant vtablevt
vtablevt vtablevt vt.vtable ! ( I'm my own vtable )

0 vtable_delegated constant object
vtablevt object vt.vtable ! ( object vtable is vtablevt )
object vtablevt vt.parent ! ( vtablevt parent is object )

s" :lookup" symbol_intern constant s_lookup

: _bind ( msg object -- method )
over s_lookup = ( short circuit send? )
over [ object vtable@ ] literal = and if
2drop ['] vtable_lookup exit ( this is just a lookup )
then
2dup
s_lookup swap vtable@ send ( msg lookup vtable )
?dup if nip nip exit then ( found, exit )
parent@ ( otherwise my parent )
dup 0= abort" method not found"
recurse ;

' _bind is bind

(( Install vtable_functions into object vtable@ as methods ))

' vtable_addmethod s" :addmethod" symbol_intern
object vtable@ vtable_addmethod

(( :addmethod is now operational ))

' vtable_lookup s" :lookup" symbol_intern
object vtable@ :addmethod
' vtable_allocate s" :allocate" symbol_intern
object vtable@ :addmethod
' vtable_delegated s" :delegated" symbol_intern
object vtable@ :addmethod

[Alex McDonald]

On Nov 3, 11:09 pm, Alex McDonald <b...@rivadpm.com> wrote:
> The play on words of the Jolt, Cola and Soda languages led me to call
> this IrnBru. The joke will be lost to all but Scots I suspect.
>
> Having the original paper to hand will help in understanding the code,
> and its possible uses. It's a delegation style of object system;
> binding is late. The format is <object> <method>; objects are Forth
> constants on the stack, and methods are tickable words.
>
> I may post up an extension that supports closures, and I'm interested
> in implementing traits. It's certainly a very small object system;
> whether it is of use I'll find out.
>
> ((
> Copyright (c) 2008 Alex McDonald.
> All rights reserved.
>

[snipped]

A slight correction to better map vtable_lookup and bind to the
paper...

: vtable_lookup ( symbol self -- method | 0 )

2dup swap count ( symbol -> s_symbol )
rot vt.dict @ search-wordlist
if nip nip exit then ( found in this object )
2dup parent@ ( otherwise my parent )

dup 0= abort" method not found"

send ;

: _bind ( msg object -- method )
over s_lookup = ( short circuit send? )
over [ object vtable@ ] literal = and if
2drop ['] vtable_lookup exit ( this is just a lookup )
then

;

[Alex McDonald]

After some testing, a few bugs were uncovered with the original. Next,
I'll be looking at closures, and I'll post up a few examples of how
this is used.

begin-structure vt%
cell-
field: vt.vt ( vtable )

field: vt.parent ( parent object )
field: vt.dict ( ptr to dictionary )
cell+
end-structure

: dictionary ( -- addr ) ( w32f specific for small wordlists )
3 #wordlist ;

: vtable vt.vt @ ; ( my vtable )
: parent vt.parent @ ; ( for vtables, my delegation parent )

defer bind ( forward reference )

: send ( msg object -- [results] )
tuck bind execute ;

: symbol_create ( "name" -- symbol )
create last @ dup , ( symbol )
does> ( object msgptr -- results )
@ swap send ; ( send this message to the object )

: symbol_intern ( string -- symbol )
2dup find-name ?dup if
nip nip
else
also definitions
['] symbol_create execute-parsing
previous definitions
then ;

: vtable_allocate ( size self -- object )
align , here ( vtable, object returned )
swap allot&zero ;

: vtable_delegated ( parent -- child )
align
dup vt% swap vtable_allocate ( parent child )

tuck vt.parent ! ( child parent child
child.parent=self )

dictionary over vt.dict ! ;

(( Now we have enough in place to construct the root vtable vtablevt
and the base object ))

0 vtable_delegated constant vtablevt

vtablevt vtablevt vt.vt ! ( I'm my own vtable )

0 vtable_delegated constant object
vtablevt object vt.vt ! ( object vtable is vtablevt )

object vtablevt vt.parent ! ( vtablevt parent is object )

: vtable_addmethod ( method symbol self -- )
vt.dict @ swap-current >r ( build in self's vtable )

count ( symbol -> s_symbol )

['] alias execute-parsing ( ' xt alias "name" )
r> set-current ; ( out of vtable )

s" :lookup" symbol_intern constant s_lookup

: vtable_lookup ( symbol self -- method )
2dup vt.dict @ swap count rot search-wordlist
0= if
parent dup 0= abort" method not found"
:lookup exit ( s_lookup swap send )
then nip nip ;

: _bind ( msg object -- method )
over s_lookup =

over vtablevt = and if
vtable vtable_lookup exit ( this is just a lookup )
then vtable :lookup ; ( msg lookup vtable )

' _bind is bind

(( Install vtable_functions into object vtable as methods ))

s" :addmethod" symbol_intern constant s_addmethod
s" :allocate" symbol_intern constant s_allocate
s" :delegated" symbol_intern constant s_delegated

' vtable_lookup s_lookup object vtable vtable_addmethod
' vtable_addmethod s_addmethod object vtable vtable_addmethod
' vtable_allocate s_allocate object vtable :addmethod
' vtable_delegated s_delegated object vtable :addmethod